1533 files changed, 168657 insertions, 151764 deletions

diff --git a/.depend b/.depend
index 26002dd0..9ff2e69d 100644
--- a/.depend
+++ b/.depend
@@ -2,15 +2,15 @@ ide/config_parser.cmi: lib/util.cmi
 ide/coq.cmi: toplevel/vernacexpr.cmo lib/util.cmi kernel/term.cmi \
     kernel/names.cmi pretyping/evd.cmi kernel/environ.cmi 
 interp/constrextern.cmi: lib/util.cmi interp/topconstr.cmi \
-    pretyping/termops.cmi kernel/term.cmi interp/symbols.cmi kernel/sign.cmi \
-    pretyping/rawterm.cmi pretyping/pattern.cmi library/nametab.cmi \
-    kernel/names.cmi library/libnames.cmi library/impargs.cmi \
+    pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
+    pretyping/rawterm.cmi pretyping/pattern.cmi interp/notation.cmi \
+    library/nametab.cmi kernel/names.cmi library/libnames.cmi \
     kernel/environ.cmi 
 interp/constrintern.cmi: interp/topconstr.cmi pretyping/termops.cmi \
     kernel/term.cmi kernel/sign.cmi pretyping/rawterm.cmi \
-    pretyping/pattern.cmi kernel/names.cmi library/libnames.cmi \
-    library/impargs.cmi pretyping/evd.cmi kernel/environ.cmi \
-    parsing/coqast.cmi 
+    pretyping/pretyping.cmi pretyping/pattern.cmi kernel/names.cmi \
+    library/libnames.cmi library/impargs.cmi pretyping/evd.cmi \
+    kernel/environ.cmi 
 interp/coqlib.cmi: kernel/term.cmi pretyping/pattern.cmi library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi 
 interp/genarg.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
@@ -18,39 +18,51 @@ interp/genarg.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
     pretyping/evd.cmi 
 interp/modintern.cmi: interp/topconstr.cmi kernel/environ.cmi \
     kernel/entries.cmi kernel/declarations.cmi 
-interp/ppextend.cmi: lib/pp.cmi kernel/names.cmi 
-interp/reserve.cmi: lib/util.cmi pretyping/rawterm.cmi kernel/names.cmi 
-interp/symbols.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
+interp/notation.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
     pretyping/rawterm.cmi interp/ppextend.cmi lib/pp.cmi library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi pretyping/classops.cmi \
-    lib/bignat.cmi 
+    lib/bigint.cmi 
+interp/ppextend.cmi: lib/pp.cmi kernel/names.cmi 
+interp/reserve.cmi: lib/util.cmi pretyping/rawterm.cmi kernel/names.cmi 
 interp/syntax_def.cmi: lib/util.cmi interp/topconstr.cmi \
-    pretyping/rawterm.cmi kernel/names.cmi 
+    pretyping/rawterm.cmi kernel/names.cmi library/libnames.cmi 
 interp/topconstr.cmi: lib/util.cmi kernel/term.cmi pretyping/rawterm.cmi \
-    lib/pp.cmi kernel/names.cmi library/libnames.cmi lib/dyn.cmi \
-    lib/bignat.cmi 
+    lib/pp.cmi kernel/names.cmi kernel/mod_subst.cmi library/libnames.cmi \
+    pretyping/evd.cmi lib/dyn.cmi lib/bigint.cmi 
+kernel/cbytecodes.cmi: kernel/term.cmi kernel/names.cmi 
+kernel/cbytegen.cmi: kernel/term.cmi kernel/pre_env.cmi kernel/names.cmi \
+    kernel/declarations.cmi kernel/cemitcodes.cmi kernel/cbytecodes.cmi 
+kernel/cemitcodes.cmi: kernel/names.cmi kernel/mod_subst.cmi \
+    kernel/cbytecodes.cmi 
 kernel/closure.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi \
     kernel/esubst.cmi kernel/environ.cmi 
-kernel/conv_oracle.cmi: kernel/names.cmi kernel/closure.cmi 
-kernel/cooking.cmi: kernel/univ.cmi kernel/term.cmi kernel/names.cmi \
-    kernel/environ.cmi kernel/declarations.cmi 
+kernel/conv_oracle.cmi: kernel/names.cmi 
+kernel/cooking.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
+    kernel/names.cmi kernel/environ.cmi kernel/declarations.cmi 
+kernel/csymtable.cmi: kernel/term.cmi kernel/pre_env.cmi kernel/names.cmi 
 kernel/declarations.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
-    lib/rtree.cmi kernel/names.cmi 
+    lib/rtree.cmi kernel/names.cmi kernel/mod_subst.cmi kernel/cemitcodes.cmi \
+    kernel/cbytecodes.cmi 
 kernel/entries.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
     kernel/names.cmi 
 kernel/environ.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
-    kernel/names.cmi kernel/declarations.cmi 
+    kernel/pre_env.cmi kernel/names.cmi kernel/declarations.cmi \
+    kernel/cemitcodes.cmi 
 kernel/esubst.cmi: lib/util.cmi 
 kernel/indtypes.cmi: kernel/univ.cmi kernel/typeops.cmi kernel/term.cmi \
     kernel/names.cmi kernel/environ.cmi kernel/entries.cmi \
     kernel/declarations.cmi 
-kernel/inductive.cmi: kernel/univ.cmi kernel/term.cmi kernel/names.cmi \
-    kernel/environ.cmi kernel/declarations.cmi 
+kernel/inductive.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
+    kernel/names.cmi kernel/environ.cmi kernel/declarations.cmi 
+kernel/mod_subst.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi 
 kernel/mod_typing.cmi: kernel/environ.cmi kernel/entries.cmi \
     kernel/declarations.cmi 
 kernel/modops.cmi: lib/util.cmi kernel/univ.cmi kernel/names.cmi \
-    kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi 
+    kernel/mod_subst.cmi kernel/environ.cmi kernel/entries.cmi \
+    kernel/declarations.cmi 
 kernel/names.cmi: lib/predicate.cmi lib/pp.cmi 
+kernel/pre_env.cmi: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
+    kernel/sign.cmi kernel/names.cmi kernel/declarations.cmi 
 kernel/reduction.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
     kernel/environ.cmi 
 kernel/safe_typing.cmi: kernel/univ.cmi kernel/term.cmi kernel/names.cmi \
@@ -65,18 +77,22 @@ kernel/term_typing.cmi: kernel/univ.cmi kernel/typeops.cmi kernel/term.cmi \
     kernel/entries.cmi kernel/declarations.cmi kernel/cooking.cmi 
 kernel/type_errors.cmi: kernel/term.cmi kernel/names.cmi kernel/environ.cmi 
 kernel/typeops.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
-    kernel/names.cmi kernel/environ.cmi kernel/entries.cmi 
+    kernel/names.cmi kernel/environ.cmi kernel/entries.cmi \
+    kernel/declarations.cmi 
 kernel/univ.cmi: lib/pp.cmi kernel/names.cmi 
-lib/bignat.cmi: lib/pp.cmi 
+kernel/vconv.cmi: kernel/term.cmi kernel/reduction.cmi kernel/names.cmi \
+    kernel/environ.cmi 
+kernel/vm.cmi: kernel/term.cmi kernel/names.cmi kernel/cemitcodes.cmi \
+    kernel/cbytecodes.cmi 
+lib/bigint.cmi: lib/pp.cmi 
 lib/pp.cmi: lib/pp_control.cmi 
 lib/rtree.cmi: lib/pp.cmi 
 lib/system.cmi: lib/pp.cmi 
 lib/util.cmi: lib/pp.cmi lib/compat.cmo 
-library/declare.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
-    kernel/safe_typing.cmi library/nametab.cmi kernel/names.cmi \
-    library/libobject.cmi library/libnames.cmi kernel/indtypes.cmi \
-    kernel/entries.cmi library/dischargedhypsmap.cmi kernel/declarations.cmi \
-    library/decl_kinds.cmo kernel/cooking.cmi 
+library/declare.cmi: kernel/term.cmi kernel/sign.cmi kernel/safe_typing.cmi \
+    library/nametab.cmi kernel/names.cmi library/libnames.cmi \
+    kernel/indtypes.cmi kernel/environ.cmi kernel/entries.cmi \
+    kernel/declarations.cmi library/decl_kinds.cmo 
 library/declaremods.cmi: lib/util.cmi kernel/safe_typing.cmi lib/pp.cmi \
     kernel/names.cmi library/libobject.cmi library/libnames.cmi \
     library/lib.cmi kernel/environ.cmi kernel/entries.cmi 
@@ -87,165 +103,189 @@ library/global.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
     kernel/indtypes.cmi kernel/environ.cmi kernel/entries.cmi \
     kernel/declarations.cmi 
 library/goptions.cmi: lib/util.cmi kernel/term.cmi lib/pp.cmi \
-    library/nametab.cmi kernel/names.cmi library/libnames.cmi 
+    library/nametab.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    library/libnames.cmi 
 library/impargs.cmi: interp/topconstr.cmi kernel/term.cmi library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi kernel/environ.cmi 
-library/lib.cmi: lib/util.cmi library/summary.cmi kernel/names.cmi \
-    library/libobject.cmi library/libnames.cmi 
+library/lib.cmi: lib/util.cmi library/summary.cmi kernel/sign.cmi \
+    kernel/names.cmi kernel/mod_subst.cmi library/libobject.cmi \
+    library/libnames.cmi 
 library/libnames.cmi: lib/util.cmi kernel/term.cmi lib/predicate.cmi \
-    lib/pp.cmi kernel/names.cmi 
-library/libobject.cmi: kernel/names.cmi library/libnames.cmi 
+    lib/pp.cmi kernel/names.cmi kernel/mod_subst.cmi 
+library/libobject.cmi: kernel/names.cmi kernel/mod_subst.cmi \
+    library/libnames.cmi 
 library/library.cmi: lib/util.cmi lib/system.cmi lib/pp.cmi kernel/names.cmi \
     library/libobject.cmi library/libnames.cmi 
 library/nameops.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi 
 library/nametab.cmi: lib/util.cmi lib/pp.cmi kernel/names.cmi \
     library/libnames.cmi 
-parsing/ast.cmi: lib/util.cmi interp/topconstr.cmi lib/pp.cmi \
-    kernel/names.cmi library/libnames.cmi interp/genarg.cmi lib/dyn.cmi \
-    parsing/coqast.cmi 
-parsing/coqast.cmi: lib/util.cmi kernel/names.cmi library/libnames.cmi \
-    lib/dyn.cmi 
 parsing/egrammar.cmi: toplevel/vernacexpr.cmo lib/util.cmi \
     interp/topconstr.cmi proofs/tacexpr.cmo pretyping/rawterm.cmi \
-    parsing/pptactic.cmi interp/ppextend.cmi kernel/names.cmi \
-    interp/genarg.cmi parsing/extend.cmi parsing/coqast.cmi parsing/ast.cmi 
-parsing/esyntax.cmi: interp/topconstr.cmi interp/symbols.cmi \
-    interp/ppextend.cmi lib/pp.cmi parsing/extend.cmi parsing/coqast.cmi \
-    parsing/ast.cmi 
-parsing/extend.cmi: lib/util.cmi interp/topconstr.cmi interp/ppextend.cmi \
-    lib/pp.cmi kernel/names.cmi interp/genarg.cmi parsing/coqast.cmi \
-    parsing/ast.cmi 
+    interp/ppextend.cmi parsing/pcoq.cmi kernel/names.cmi \
+    kernel/mod_subst.cmi interp/genarg.cmi parsing/extend.cmi 
+parsing/extend.cmi: lib/util.cmi 
 parsing/g_minicoq.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi \
     kernel/environ.cmi 
 parsing/lexer.cmi: lib/util.cmi lib/pp.cmi 
 parsing/pcoq.cmi: toplevel/vernacexpr.cmo lib/util.cmi interp/topconstr.cmi \
     proofs/tacexpr.cmo pretyping/rawterm.cmi kernel/names.cmi \
     library/libnames.cmi interp/genarg.cmi parsing/extend.cmi \
-    library/decl_kinds.cmo parsing/coqast.cmi lib/bignat.cmi parsing/ast.cmi 
+    library/decl_kinds.cmo proofs/decl_expr.cmi lib/bigint.cmi 
 parsing/ppconstr.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    proofs/tacexpr.cmo pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi \
-    kernel/names.cmi library/libnames.cmi parsing/extend.cmi \
-    kernel/environ.cmi parsing/coqast.cmi 
-parsing/pptactic.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    proofs/tacexpr.cmo pretyping/rawterm.cmi proofs/proof_type.cmi \
-    pretyping/pretyping.cmi lib/pp.cmi library/libnames.cmi interp/genarg.cmi 
+    proofs/tacexpr.cmo pretyping/rawterm.cmi interp/ppextend.cmi lib/pp.cmi \
+    parsing/pcoq.cmi kernel/names.cmi library/libnames.cmi interp/genarg.cmi \
+    kernel/environ.cmi 
+parsing/ppdecl_proof.cmi: lib/pp.cmi kernel/environ.cmi proofs/decl_expr.cmi 
+parsing/pptactic.cmi: interp/topconstr.cmi kernel/term.cmi proofs/tacexpr.cmo \
+    pretyping/rawterm.cmi proofs/proof_type.cmi pretyping/pretyping.cmi \
+    interp/ppextend.cmi lib/pp.cmi library/libnames.cmi interp/genarg.cmi \
+    kernel/environ.cmi 
+parsing/ppvernac.cmi: toplevel/vernacexpr.cmo lib/util.cmi \
+    interp/topconstr.cmi pretyping/rawterm.cmi parsing/pptactic.cmi \
+    interp/ppextend.cmi parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi interp/genarg.cmi 
 parsing/prettyp.cmi: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
     kernel/sign.cmi kernel/safe_typing.cmi pretyping/reductionops.cmi \
     lib/pp.cmi library/nametab.cmi kernel/names.cmi library/libnames.cmi \
     library/lib.cmi library/impargs.cmi kernel/environ.cmi \
     pretyping/classops.cmi 
 parsing/printer.cmi: pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
-    pretyping/rawterm.cmi lib/pp.cmi pretyping/pattern.cmi \
-    library/nametab.cmi kernel/names.cmi library/libnames.cmi \
-    kernel/environ.cmi 
+    pretyping/rawterm.cmi proofs/proof_type.cmi lib/pp.cmi \
+    pretyping/pattern.cmi library/nametab.cmi kernel/names.cmi \
+    library/libnames.cmi pretyping/evd.cmi kernel/environ.cmi 
 parsing/printmod.cmi: lib/pp.cmi kernel/names.cmi 
+parsing/q_util.cmi: lib/util.cmi parsing/pcoq.cmi 
 parsing/search.cmi: kernel/term.cmi lib/pp.cmi pretyping/pattern.cmi \
     library/nametab.cmi kernel/names.cmi library/libnames.cmi \
     kernel/environ.cmi 
-parsing/termast.cmi: pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
-    pretyping/rawterm.cmi pretyping/pattern.cmi library/nametab.cmi \
-    kernel/names.cmi library/libnames.cmi kernel/environ.cmi \
-    parsing/coqast.cmi 
+parsing/tactic_printer.cmi: proofs/tacexpr.cmo kernel/sign.cmi \
+    proofs/proof_type.cmi lib/pp.cmi pretyping/evd.cmi 
 pretyping/cases.cmi: lib/util.cmi kernel/term.cmi pretyping/rawterm.cmi \
     kernel/names.cmi pretyping/inductiveops.cmi pretyping/evd.cmi \
-    pretyping/evarutil.cmi kernel/environ.cmi 
+    pretyping/evarutil.cmi kernel/environ.cmi pretyping/coercion.cmi 
 pretyping/cbv.cmi: kernel/term.cmi kernel/names.cmi kernel/esubst.cmi \
     kernel/environ.cmi kernel/closure.cmi 
 pretyping/classops.cmi: kernel/term.cmi lib/pp.cmi library/nametab.cmi \
-    kernel/names.cmi library/libobject.cmi library/libnames.cmi \
+    kernel/names.cmi kernel/mod_subst.cmi library/libnames.cmi \
     pretyping/evd.cmi kernel/environ.cmi library/decl_kinds.cmo 
+pretyping/clenv.cmi: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
+    pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi 
 pretyping/coercion.cmi: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
     pretyping/rawterm.cmi kernel/names.cmi pretyping/evd.cmi \
     pretyping/evarutil.cmi kernel/environ.cmi 
 pretyping/detyping.cmi: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
-    kernel/sign.cmi pretyping/rawterm.cmi kernel/names.cmi kernel/environ.cmi 
+    kernel/sign.cmi pretyping/rawterm.cmi kernel/names.cmi \
+    kernel/mod_subst.cmi kernel/environ.cmi 
 pretyping/evarconv.cmi: kernel/term.cmi kernel/sign.cmi \
-    pretyping/reductionops.cmi pretyping/evarutil.cmi kernel/environ.cmi 
+    pretyping/reductionops.cmi pretyping/evd.cmi kernel/environ.cmi 
 pretyping/evarutil.cmi: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
-    pretyping/reductionops.cmi pretyping/rawterm.cmi kernel/names.cmi \
-    pretyping/evd.cmi kernel/environ.cmi 
-pretyping/evd.cmi: kernel/term.cmi kernel/sign.cmi kernel/names.cmi 
+    pretyping/reductionops.cmi pretyping/rawterm.cmi lib/pp.cmi \
+    kernel/names.cmi pretyping/evd.cmi kernel/environ.cmi 
+pretyping/evd.cmi: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
+    kernel/reduction.cmi lib/pp.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    library/libnames.cmi kernel/environ.cmi lib/dyn.cmi 
 pretyping/indrec.cmi: kernel/term.cmi kernel/names.cmi \
     pretyping/inductiveops.cmi pretyping/evd.cmi kernel/environ.cmi \
     kernel/declarations.cmi 
 pretyping/inductiveops.cmi: kernel/term.cmi kernel/sign.cmi kernel/names.cmi \
-    pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi 
-pretyping/instantiate.cmi: kernel/term.cmi kernel/sign.cmi kernel/names.cmi \
-    pretyping/evd.cmi kernel/environ.cmi 
+    kernel/mod_subst.cmi pretyping/evd.cmi kernel/environ.cmi \
+    kernel/declarations.cmi 
 pretyping/matching.cmi: pretyping/termops.cmi kernel/term.cmi \
     pretyping/pattern.cmi kernel/names.cmi pretyping/evd.cmi \
     kernel/environ.cmi 
 pretyping/pattern.cmi: kernel/term.cmi kernel/sign.cmi pretyping/rawterm.cmi \
-    lib/pp.cmi library/nametab.cmi kernel/names.cmi library/libnames.cmi \
-    kernel/environ.cmi 
+    lib/pp.cmi library/nametab.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    library/libnames.cmi kernel/environ.cmi 
 pretyping/pretype_errors.cmi: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
     pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi \
     pretyping/inductiveops.cmi pretyping/evd.cmi kernel/environ.cmi 
 pretyping/pretyping.cmi: kernel/term.cmi kernel/sign.cmi \
     pretyping/rawterm.cmi kernel/names.cmi pretyping/evd.cmi \
-    pretyping/evarutil.cmi kernel/environ.cmi lib/dyn.cmi 
+    pretyping/evarutil.cmi kernel/environ.cmi lib/dyn.cmi \
+    pretyping/coercion.cmi pretyping/cases.cmi 
 pretyping/rawterm.cmi: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
     kernel/sign.cmi library/nametab.cmi kernel/names.cmi library/libnames.cmi \
-    lib/dyn.cmi 
+    pretyping/evd.cmi lib/dyn.cmi 
 pretyping/recordops.cmi: kernel/term.cmi library/nametab.cmi kernel/names.cmi \
     library/library.cmi library/libobject.cmi library/libnames.cmi \
     pretyping/classops.cmi 
 pretyping/reductionops.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
     kernel/names.cmi pretyping/evd.cmi kernel/environ.cmi kernel/closure.cmi 
 pretyping/retyping.cmi: pretyping/termops.cmi kernel/term.cmi \
-    pretyping/pattern.cmi kernel/names.cmi pretyping/evd.cmi \
-    kernel/environ.cmi 
-pretyping/tacred.cmi: kernel/term.cmi pretyping/reductionops.cmi \
-    pretyping/rawterm.cmi kernel/names.cmi library/libnames.cmi \
-    pretyping/evd.cmi kernel/environ.cmi kernel/closure.cmi 
+    kernel/names.cmi pretyping/evd.cmi kernel/environ.cmi 
+pretyping/tacred.cmi: kernel/type_errors.cmi kernel/term.cmi \
+    pretyping/reductionops.cmi pretyping/rawterm.cmi kernel/names.cmi \
+    library/libnames.cmi pretyping/evd.cmi kernel/environ.cmi \
+    kernel/closure.cmi 
 pretyping/termops.cmi: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
     kernel/sign.cmi lib/pp.cmi kernel/names.cmi kernel/environ.cmi 
 pretyping/typing.cmi: kernel/term.cmi pretyping/evd.cmi kernel/environ.cmi 
-proofs/clenv.cmi: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
-    kernel/sign.cmi pretyping/reductionops.cmi pretyping/rawterm.cmi \
-    proofs/proof_type.cmi pretyping/pretyping.cmi lib/pp.cmi kernel/names.cmi \
-    pretyping/evd.cmi kernel/environ.cmi 
-proofs/evar_refiner.cmi: interp/topconstr.cmi kernel/term.cmi \
-    proofs/tacexpr.cmo kernel/sign.cmi proofs/refiner.cmi \
-    proofs/proof_type.cmi kernel/names.cmi pretyping/evd.cmi \
+pretyping/unification.cmi: kernel/term.cmi pretyping/evd.cmi \
     kernel/environ.cmi 
+pretyping/vnorm.cmi: kernel/term.cmi kernel/reduction.cmi kernel/names.cmi \
+    kernel/environ.cmi 
+proofs/clenvtac.cmi: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
+    proofs/proof_type.cmi kernel/names.cmi pretyping/evd.cmi \
+    pretyping/clenv.cmi 
+proofs/decl_expr.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
+    proofs/tacexpr.cmo pretyping/rawterm.cmi kernel/names.cmi \
+    interp/genarg.cmi 
+proofs/decl_mode.cmi: kernel/term.cmi proofs/tacmach.cmi \
+    proofs/proof_type.cmi kernel/names.cmi pretyping/evd.cmi lib/dyn.cmi \
+    proofs/decl_expr.cmi 
+proofs/evar_refiner.cmi: interp/topconstr.cmi kernel/term.cmi \
+    proofs/refiner.cmi pretyping/rawterm.cmi kernel/names.cmi \
+    pretyping/evd.cmi kernel/environ.cmi 
 proofs/logic.cmi: kernel/term.cmi kernel/sign.cmi proofs/proof_type.cmi \
-    lib/pp.cmi kernel/names.cmi pretyping/evd.cmi kernel/environ.cmi 
+    kernel/names.cmi pretyping/evd.cmi kernel/environ.cmi 
 proofs/pfedit.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
     proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi lib/pp.cmi \
     kernel/names.cmi pretyping/evd.cmi kernel/environ.cmi kernel/entries.cmi \
     library/decl_kinds.cmo 
 proofs/proof_trees.cmi: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
     proofs/proof_type.cmi lib/pp.cmi kernel/names.cmi pretyping/evd.cmi \
-    kernel/environ.cmi 
+    kernel/environ.cmi lib/dyn.cmi 
 proofs/proof_type.cmi: lib/util.cmi kernel/term.cmi proofs/tacexpr.cmo \
     pretyping/rawterm.cmi pretyping/pattern.cmi library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi interp/genarg.cmi pretyping/evd.cmi \
-    kernel/environ.cmi 
+    kernel/environ.cmi proofs/decl_expr.cmi 
+proofs/redexpr.cmi: kernel/term.cmi pretyping/reductionops.cmi \
+    pretyping/rawterm.cmi kernel/names.cmi kernel/closure.cmi 
 proofs/refiner.cmi: pretyping/termops.cmi kernel/term.cmi proofs/tacexpr.cmo \
     kernel/sign.cmi proofs/proof_type.cmi proofs/proof_trees.cmi lib/pp.cmi \
-    pretyping/evd.cmi 
+    pretyping/evd.cmi kernel/environ.cmi 
 proofs/tacmach.cmi: interp/topconstr.cmi pretyping/termops.cmi \
-    kernel/term.cmi pretyping/tacred.cmi proofs/tacexpr.cmo kernel/sign.cmi \
-    proofs/refiner.cmi kernel/reduction.cmi pretyping/rawterm.cmi \
+    kernel/term.cmi proofs/tacexpr.cmo kernel/sign.cmi proofs/refiner.cmi \
+    kernel/reduction.cmi proofs/redexpr.cmi pretyping/rawterm.cmi \
     proofs/proof_type.cmi proofs/proof_trees.cmi lib/pp.cmi kernel/names.cmi \
     pretyping/evd.cmi kernel/environ.cmi 
 proofs/tactic_debug.cmi: kernel/term.cmi proofs/tacexpr.cmo \
     proofs/proof_type.cmi lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi \
-    kernel/environ.cmi 
+    pretyping/evd.cmi kernel/environ.cmi 
 tactics/auto.cmi: toplevel/vernacexpr.cmo lib/util.cmi kernel/term.cmi \
     proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi \
     pretyping/rawterm.cmi proofs/proof_type.cmi lib/pp.cmi \
-    pretyping/pattern.cmi kernel/names.cmi library/libnames.cmi \
-    pretyping/evd.cmi kernel/environ.cmi proofs/clenv.cmi tactics/btermdn.cmi 
-tactics/autorewrite.cmi: kernel/term.cmi proofs/tacmach.cmi \
-    proofs/tacexpr.cmo 
+    pretyping/pattern.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    library/libnames.cmi pretyping/evd.cmi kernel/environ.cmi \
+    pretyping/clenv.cmi tactics/btermdn.cmi 
+tactics/autorewrite.cmi: kernel/term.cmi tactics/tacticals.cmi \
+    proofs/tacmach.cmi proofs/tacexpr.cmo kernel/names.cmi 
 tactics/btermdn.cmi: kernel/term.cmi pretyping/pattern.cmi 
 tactics/contradiction.cmi: kernel/term.cmi pretyping/rawterm.cmi \
     proofs/proof_type.cmi kernel/names.cmi 
+tactics/decl_interp.cmi: tactics/tacinterp.cmi kernel/mod_subst.cmi \
+    pretyping/evd.cmi kernel/environ.cmi proofs/decl_mode.cmi \
+    proofs/decl_expr.cmi 
+tactics/decl_proof_instr.cmi: kernel/term.cmi proofs/tacmach.cmi \
+    proofs/refiner.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
+    kernel/names.cmi kernel/environ.cmi proofs/decl_mode.cmi \
+    proofs/decl_expr.cmi 
 tactics/dhyp.cmi: toplevel/vernacexpr.cmo interp/topconstr.cmi \
     proofs/tacmach.cmi proofs/tacexpr.cmo kernel/names.cmi 
-tactics/eauto.cmi: kernel/term.cmi proofs/tacexpr.cmo proofs/proof_type.cmi 
+tactics/eauto.cmi: interp/topconstr.cmi kernel/term.cmi proofs/tacexpr.cmo \
+    proofs/proof_type.cmi tactics/auto.cmi 
 tactics/elim.cmi: kernel/term.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
     pretyping/rawterm.cmi proofs/proof_type.cmi kernel/names.cmi \
     interp/genarg.cmi 
@@ -253,13 +293,18 @@ tactics/equality.cmi: kernel/term.cmi tactics/tactics.cmi \
     tactics/tacticals.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
     kernel/sign.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
     pretyping/pattern.cmi kernel/names.cmi tactics/hipattern.cmi \
-    pretyping/evd.cmi kernel/environ.cmi 
-tactics/extraargs.cmi: interp/topconstr.cmi kernel/term.cmi \
-    proofs/tacexpr.cmo proofs/proof_type.cmi parsing/pcoq.cmi 
-tactics/extratactics.cmi: kernel/term.cmi pretyping/rawterm.cmi \
-    proofs/proof_type.cmi kernel/names.cmi interp/genarg.cmi 
+    interp/genarg.cmi pretyping/evd.cmi kernel/environ.cmi 
+tactics/evar_tactics.cmi: kernel/term.cmi proofs/tacmach.cmi \
+    proofs/tacexpr.cmo pretyping/rawterm.cmi kernel/names.cmi 
+tactics/extraargs.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
+    tactics/tacticals.cmi proofs/tacexpr.cmo tactics/setoid_replace.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi parsing/pcoq.cmi \
+    kernel/names.cmi 
+tactics/extratactics.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
+    proofs/tacexpr.cmo pretyping/rawterm.cmi proofs/proof_type.cmi \
+    kernel/names.cmi interp/genarg.cmi 
 tactics/hiddentac.cmi: kernel/term.cmi tactics/tacticals.cmi \
-    pretyping/tacred.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi proofs/tacexpr.cmo proofs/redexpr.cmi \
     pretyping/rawterm.cmi proofs/proof_type.cmi kernel/names.cmi \
     interp/genarg.cmi 
 tactics/hipattern.cmi: lib/util.cmi kernel/term.cmi proofs/tacmach.cmi \
@@ -268,79 +313,72 @@ tactics/hipattern.cmi: lib/util.cmi kernel/term.cmi proofs/tacmach.cmi \
     interp/coqlib.cmi 
 tactics/inv.cmi: kernel/term.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
     pretyping/rawterm.cmi kernel/names.cmi interp/genarg.cmi 
-tactics/leminv.cmi: interp/topconstr.cmi kernel/term.cmi \
+tactics/leminv.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
     pretyping/rawterm.cmi proofs/proof_type.cmi kernel/names.cmi 
 tactics/nbtermdn.cmi: kernel/term.cmi pretyping/pattern.cmi \
-    tactics/btermdn.cmi 
-tactics/refine.cmi: kernel/term.cmi proofs/tacmach.cmi \
-    pretyping/pretyping.cmi 
+    library/libnames.cmi tactics/btermdn.cmi 
+tactics/refine.cmi: proofs/tacmach.cmi pretyping/evd.cmi 
 tactics/setoid_replace.cmi: interp/topconstr.cmi kernel/term.cmi \
-    proofs/proof_type.cmi kernel/names.cmi 
+    proofs/proof_type.cmi lib/pp.cmi kernel/names.cmi 
 tactics/tacinterp.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    proofs/tactic_debug.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
-    proofs/tacexpr.cmo proofs/proof_type.cmi lib/pp.cmi library/nametab.cmi \
-    kernel/names.cmi interp/genarg.cmi pretyping/evd.cmi kernel/environ.cmi \
-    lib/dyn.cmi parsing/coqast.cmi 
+    proofs/tactic_debug.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
+    proofs/redexpr.cmi proofs/proof_type.cmi lib/pp.cmi library/nametab.cmi \
+    kernel/names.cmi kernel/mod_subst.cmi library/libnames.cmi \
+    interp/genarg.cmi pretyping/evd.cmi kernel/environ.cmi lib/dyn.cmi 
 tactics/tacticals.cmi: kernel/term.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
-    kernel/sign.cmi kernel/reduction.cmi proofs/proof_type.cmi \
-    pretyping/pattern.cmi kernel/names.cmi interp/genarg.cmi proofs/clenv.cmi 
+    kernel/sign.cmi kernel/reduction.cmi proofs/proof_type.cmi lib/pp.cmi \
+    pretyping/pattern.cmi kernel/names.cmi interp/genarg.cmi \
+    pretyping/clenv.cmi 
 tactics/tactics.cmi: interp/topconstr.cmi kernel/term.cmi \
-    tactics/tacticals.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
-    proofs/tacexpr.cmo kernel/sign.cmi kernel/reduction.cmi \
+    tactics/tacticals.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
+    kernel/sign.cmi kernel/reduction.cmi proofs/redexpr.cmi \
     pretyping/rawterm.cmi proofs/proof_type.cmi library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi interp/genarg.cmi pretyping/evd.cmi \
-    proofs/evar_refiner.cmi kernel/environ.cmi proofs/clenv.cmi 
-tactics/termdn.cmi: kernel/term.cmi pretyping/pattern.cmi 
+    proofs/evar_refiner.cmi kernel/environ.cmi pretyping/clenv.cmi 
+tactics/termdn.cmi: kernel/term.cmi pretyping/pattern.cmi \
+    library/libnames.cmi 
 toplevel/cerrors.cmi: lib/util.cmi lib/pp.cmi 
 toplevel/class.cmi: kernel/term.cmi proofs/tacexpr.cmo library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi library/declare.cmi \
     library/decl_kinds.cmo pretyping/classops.cmi 
 toplevel/command.cmi: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi kernel/term.cmi pretyping/tacred.cmi \
-    proofs/tacexpr.cmo pretyping/rawterm.cmi library/nametab.cmi \
+    interp/topconstr.cmi kernel/term.cmi proofs/tacexpr.cmo \
+    proofs/redexpr.cmi pretyping/rawterm.cmi library/nametab.cmi \
     kernel/names.cmi library/library.cmi library/libnames.cmi \
     pretyping/evd.cmi kernel/environ.cmi kernel/entries.cmi \
     library/declare.cmi library/decl_kinds.cmo 
 toplevel/coqinit.cmi: kernel/names.cmi 
-toplevel/discharge.cmi: kernel/names.cmi 
+toplevel/discharge.cmi: kernel/sign.cmi kernel/entries.cmi \
+    kernel/declarations.cmi kernel/cooking.cmi 
 toplevel/fhimsg.cmi: kernel/type_errors.cmi kernel/term.cmi kernel/sign.cmi \
     lib/pp.cmi kernel/names.cmi kernel/environ.cmi 
-toplevel/himsg.cmi: kernel/type_errors.cmi pretyping/pretype_errors.cmi \
-    lib/pp.cmi kernel/names.cmi proofs/logic.cmi kernel/indtypes.cmi \
-    kernel/environ.cmi pretyping/cases.cmi 
+toplevel/himsg.cmi: kernel/type_errors.cmi pretyping/tacred.cmi \
+    pretyping/pretype_errors.cmi lib/pp.cmi kernel/names.cmi proofs/logic.cmi \
+    kernel/indtypes.cmi pretyping/indrec.cmi kernel/environ.cmi \
+    pretyping/cases.cmi 
 toplevel/metasyntax.cmi: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi proofs/tacexpr.cmo interp/symbols.cmi \
-    interp/ppextend.cmi library/libnames.cmi parsing/extend.cmi \
+    interp/topconstr.cmi proofs/tacexpr.cmo interp/ppextend.cmi \
+    interp/notation.cmi library/libnames.cmi parsing/extend.cmi \
     interp/constrintern.cmi pretyping/classops.cmi 
 toplevel/mltop.cmi: kernel/names.cmi library/libobject.cmi 
 toplevel/protectedtoplevel.cmi: lib/pp.cmi 
 toplevel/record.cmi: toplevel/vernacexpr.cmo interp/topconstr.cmi \
     kernel/term.cmi kernel/sign.cmi kernel/names.cmi 
-toplevel/recordobj.cmi: proofs/tacexpr.cmo library/libnames.cmi 
 toplevel/searchisos.cmi: kernel/term.cmi kernel/names.cmi \
     library/libobject.cmi 
 toplevel/toplevel.cmi: lib/pp.cmi parsing/pcoq.cmi 
 toplevel/vernac.cmi: toplevel/vernacexpr.cmo lib/util.cmi parsing/pcoq.cmi 
 toplevel/vernacentries.cmi: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
-    interp/topconstr.cmi kernel/term.cmi kernel/names.cmi \
+    lib/util.cmi interp/topconstr.cmi kernel/term.cmi kernel/names.cmi \
     library/libnames.cmi pretyping/evd.cmi kernel/environ.cmi 
 toplevel/vernacinterp.cmi: proofs/tacexpr.cmo 
-translate/ppconstrnew.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    proofs/tacexpr.cmo pretyping/rawterm.cmi interp/ppextend.cmi lib/pp.cmi \
-    parsing/pcoq.cmi pretyping/pattern.cmi kernel/names.cmi \
-    library/libnames.cmi interp/genarg.cmi parsing/extend.cmi \
-    kernel/environ.cmi parsing/coqast.cmi 
-translate/pptacticnew.cmi: interp/topconstr.cmi proofs/tacexpr.cmo \
-    proofs/proof_type.cmi lib/pp.cmi kernel/names.cmi interp/genarg.cmi \
+toplevel/whelp.cmi: interp/topconstr.cmi kernel/term.cmi kernel/names.cmi \
     kernel/environ.cmi 
-translate/ppvernacnew.cmi: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi proofs/tacexpr.cmo pretyping/rawterm.cmi \
-    parsing/pptactic.cmi interp/ppextend.cmi parsing/ppconstr.cmi lib/pp.cmi \
-    parsing/pcoq.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libnames.cmi interp/genarg.cmi parsing/extend.cmi \
-    kernel/environ.cmi parsing/coqast.cmi parsing/ast.cmi 
-contrib/cc/ccalgo.cmi: kernel/term.cmi kernel/names.cmi 
-contrib/cc/ccproof.cmi: kernel/names.cmi contrib/cc/ccalgo.cmi 
+contrib/cc/ccalgo.cmi: lib/util.cmi kernel/term.cmi lib/pp.cmi \
+    kernel/names.cmi 
+contrib/cc/ccproof.cmi: kernel/term.cmi kernel/names.cmi \
+    contrib/cc/ccalgo.cmi 
+contrib/cc/cctac.cmi: kernel/term.cmi proofs/proof_type.cmi 
 contrib/correctness/past.cmi: lib/util.cmi interp/topconstr.cmi \
     kernel/term.cmi kernel/names.cmi 
 contrib/correctness/pcic.cmi: pretyping/rawterm.cmi 
@@ -365,6 +403,11 @@ contrib/correctness/ptyping.cmi: interp/topconstr.cmi kernel/term.cmi \
     kernel/names.cmi 
 contrib/correctness/putil.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi 
 contrib/correctness/pwp.cmi: kernel/term.cmi 
+contrib/dp/dp.cmi: proofs/proof_type.cmi library/libnames.cmi 
+contrib/dp/dp_cvcl.cmi: contrib/dp/fol.cmi 
+contrib/dp/dp_simplify.cmi: contrib/dp/fol.cmi 
+contrib/dp/dp_sorts.cmi: contrib/dp/fol.cmi 
+contrib/dp/dp_zenon.cmi: contrib/dp/fol.cmi 
 contrib/extraction/common.cmi: kernel/names.cmi contrib/extraction/mlutil.cmi \
     contrib/extraction/miniml.cmi 
 contrib/extraction/extract_env.cmi: kernel/names.cmi library/libnames.cmi 
@@ -377,7 +420,7 @@ contrib/extraction/miniml.cmi: lib/util.cmi lib/pp.cmi kernel/names.cmi \
     library/libnames.cmi 
 contrib/extraction/mlutil.cmi: lib/util.cmi kernel/term.cmi kernel/names.cmi \
     contrib/extraction/miniml.cmi library/libnames.cmi 
-contrib/extraction/modutil.cmi: kernel/names.cmi \
+contrib/extraction/modutil.cmi: kernel/names.cmi kernel/mod_subst.cmi \
     contrib/extraction/miniml.cmi library/libnames.cmi kernel/environ.cmi \
     kernel/declarations.cmi 
 contrib/extraction/ocaml.cmi: lib/pp.cmi kernel/names.cmi \
@@ -402,29 +445,40 @@ contrib/first-order/sequent.cmi: lib/util.cmi kernel/term.cmi \
     library/libnames.cmi lib/heap.cmi contrib/first-order/formula.cmi \
     tactics/auto.cmi 
 contrib/first-order/unify.cmi: kernel/term.cmi 
+contrib/funind/functional_principles_proofs.cmi: kernel/term.cmi \
+    proofs/tacmach.cmi kernel/names.cmi 
+contrib/funind/functional_principles_types.cmi: kernel/term.cmi \
+    proofs/tacmach.cmi pretyping/rawterm.cmi kernel/names.cmi \
+    library/libnames.cmi kernel/entries.cmi 
+contrib/funind/indfun_common.cmi: kernel/term.cmi proofs/tacexpr.cmo \
+    pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi library/libnames.cmi \
+    kernel/entries.cmi library/decl_kinds.cmo 
+contrib/funind/rawterm_to_relation.cmi: interp/topconstr.cmi \
+    pretyping/rawterm.cmi kernel/names.cmi 
+contrib/funind/rawtermops.cmi: lib/util.cmi pretyping/rawterm.cmi \
+    kernel/names.cmi library/libnames.cmi 
 contrib/funind/tacinvutils.cmi: lib/util.cmi pretyping/termops.cmi \
     kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
     proofs/tacmach.cmi tactics/tacinterp.cmi tactics/refine.cmi \
     pretyping/reductionops.cmi proofs/proof_type.cmi parsing/printer.cmi \
     lib/pp.cmi kernel/names.cmi pretyping/inductiveops.cmi pretyping/evd.cmi \
     tactics/equality.cmi interp/coqlib.cmi 
-contrib/interface/blast.cmi: proofs/tacmach.cmi proofs/tacexpr.cmo \
-    proofs/proof_type.cmi 
+contrib/interface/blast.cmi: proofs/tacexpr.cmo proofs/proof_type.cmi 
 contrib/interface/dad.cmi: interp/topconstr.cmi proofs/tacmach.cmi \
     proofs/tacexpr.cmo proofs/proof_type.cmi 
 contrib/interface/debug_tac.cmi: proofs/tacmach.cmi proofs/tacexpr.cmo \
-    proofs/proof_type.cmi 
+    proofs/proof_type.cmi pretyping/evd.cmi 
 contrib/interface/name_to_ast.cmi: toplevel/vernacexpr.cmo \
-    library/libnames.cmi parsing/coqast.cmi 
-contrib/interface/pbp.cmi: proofs/tacmach.cmi proofs/tacexpr.cmo \
-    proofs/proof_type.cmi kernel/names.cmi 
+    library/libnames.cmi 
+contrib/interface/pbp.cmi: proofs/tacexpr.cmo proofs/proof_type.cmi \
+    kernel/names.cmi 
 contrib/interface/showproof.cmi: toplevel/vernacinterp.cmi lib/util.cmi \
-    pretyping/typing.cmi contrib/interface/translate.cmi kernel/term.cmi \
-    kernel/sign.cmi contrib/interface/showproof_ct.cmo kernel/reduction.cmi \
+    pretyping/typing.cmi kernel/term.cmi kernel/sign.cmi \
+    contrib/interface/showproof_ct.cmo kernel/reduction.cmi \
     proofs/proof_type.cmi proofs/proof_trees.cmi parsing/printer.cmi \
     lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi kernel/inductive.cmi \
     pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi \
-    parsing/coqast.cmi proofs/clenv.cmi contrib/interface/ascent.cmi 
+    pretyping/clenv.cmi contrib/interface/ascent.cmi 
 contrib/interface/translate.cmi: kernel/term.cmi proofs/proof_type.cmi \
     pretyping/evd.cmi kernel/environ.cmi contrib/interface/ascent.cmi 
 contrib/interface/vtp.cmi: contrib/interface/ascent.cmi 
@@ -434,34 +488,71 @@ contrib/jprover/jall.cmi: contrib/jprover/opname.cmi \
     contrib/jprover/jterm.cmi contrib/jprover/jlogic.cmi 
 contrib/jprover/jlogic.cmi: contrib/jprover/jterm.cmi 
 contrib/jprover/jterm.cmi: contrib/jprover/opname.cmi 
+contrib/rtauto/refl_tauto.cmi: kernel/term.cmi proofs/tacmach.cmi \
+    proofs/proof_type.cmi contrib/rtauto/proof_search.cmi kernel/names.cmi 
+contrib/subtac/context.cmi: kernel/term.cmi kernel/names.cmi 
+contrib/subtac/eterm.cmi: lib/util.cmi kernel/term.cmi proofs/tacmach.cmi \
+    kernel/names.cmi pretyping/evd.cmi 
+contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi 
+contrib/subtac/subtac_cases.cmi: lib/util.cmi kernel/term.cmi \
+    pretyping/rawterm.cmi kernel/names.cmi pretyping/inductiveops.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \
+    pretyping/coercion.cmi 
+contrib/subtac/subtac_coercion.cmi: pretyping/coercion.cmi 
+contrib/subtac/subtac_command.cmi: toplevel/vernacexpr.cmo \
+    interp/topconstr.cmi kernel/term.cmi pretyping/pretyping.cmi lib/pp.cmi \
+    kernel/names.cmi library/libnames.cmi pretyping/evd.cmi \
+    kernel/environ.cmi interp/constrintern.cmi 
+contrib/subtac/subtac_errors.cmi: lib/util.cmi lib/pp.cmi 
+contrib/subtac/subtac_interp_fixpoint.cmi: lib/util.cmi interp/topconstr.cmi \
+    lib/pp.cmi kernel/names.cmi library/libnames.cmi 
+contrib/subtac/subtac_obligations.cmi: lib/util.cmi interp/topconstr.cmi \
+    kernel/term.cmi proofs/proof_type.cmi kernel/names.cmi 
+contrib/subtac/subtac_pretyping.cmi: interp/topconstr.cmi kernel/term.cmi \
+    kernel/sign.cmi pretyping/pretyping.cmi kernel/names.cmi \
+    library/global.cmi pretyping/evd.cmi kernel/environ.cmi 
+contrib/subtac/subtac_utils.cmi: lib/util.cmi interp/topconstr.cmi \
+    kernel/term.cmi proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi lib/pp.cmi kernel/names.cmi \
+    library/libnames.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    kernel/environ.cmi library/decl_kinds.cmo interp/coqlib.cmi 
 contrib/xml/doubleTypeInference.cmi: kernel/term.cmi kernel/names.cmi \
     pretyping/evd.cmi kernel/environ.cmi contrib/xml/acic.cmo 
 contrib/xml/xmlcommand.cmi: contrib/xml/xml.cmi kernel/term.cmi \
     proofs/proof_type.cmi contrib/xml/proof2aproof.cmo library/libnames.cmi \
     pretyping/evd.cmi contrib/xml/acic.cmo 
-ide/utils/configwin.cmi: ide/utils/uoptions.cmi 
-tools/coqdoc/output.cmi: tools/coqdoc/index.cmi 
-tools/coqdoc/pretty.cmi: tools/coqdoc/index.cmi 
+ide/utils/configwin.cmi: ide/utils/config_file.cmi 
+tools/coqdoc/index.cmi: tools/coqdoc/cdglobals.cmo 
+tools/coqdoc/output.cmi: tools/coqdoc/index.cmi tools/coqdoc/cdglobals.cmo 
+tools/coqdoc/pretty.cmi: tools/coqdoc/index.cmi tools/coqdoc/cdglobals.cmo 
 config/coq_config.cmo: config/coq_config.cmi 
 config/coq_config.cmx: config/coq_config.cmi 
 dev/db_printers.cmo: lib/pp.cmi kernel/names.cmi 
 dev/db_printers.cmx: lib/pp.cmx kernel/names.cmx 
-dev/top_printers.cmo: kernel/univ.cmi pretyping/termops.cmi kernel/term.cmi \
-    proofs/tacmach.cmi lib/system.cmi kernel/sign.cmi proofs/refiner.cmi \
-    proofs/proof_trees.cmi parsing/printer.cmi parsing/pptactic.cmi \
-    lib/pp.cmi kernel/names.cmi library/nameops.cmi library/libobject.cmi \
-    library/libnames.cmi pretyping/evd.cmi kernel/environ.cmi \
-    kernel/declarations.cmi interp/constrintern.cmi interp/constrextern.cmi \
-    kernel/closure.cmi proofs/clenv.cmi toplevel/cerrors.cmi parsing/ast.cmi 
-dev/top_printers.cmx: kernel/univ.cmx pretyping/termops.cmx kernel/term.cmx \
-    proofs/tacmach.cmx lib/system.cmx kernel/sign.cmx proofs/refiner.cmx \
-    proofs/proof_trees.cmx parsing/printer.cmx parsing/pptactic.cmx \
-    lib/pp.cmx kernel/names.cmx library/nameops.cmx library/libobject.cmx \
-    library/libnames.cmx pretyping/evd.cmx kernel/environ.cmx \
-    kernel/declarations.cmx interp/constrintern.cmx interp/constrextern.cmx \
-    kernel/closure.cmx proofs/clenv.cmx toplevel/cerrors.cmx parsing/ast.cmx 
-doc/parse.cmo: parsing/ast.cmi 
-doc/parse.cmx: parsing/ast.cmx 
+dev/top_printers.cmo: toplevel/vernacinterp.cmi lib/util.cmi kernel/univ.cmi \
+    pretyping/termops.cmi kernel/term.cmi parsing/tactic_printer.cmi \
+    lib/system.cmi kernel/sign.cmi proofs/refiner.cmi proofs/proof_trees.cmi \
+    parsing/printer.cmi parsing/pptactic.cmi lib/pp.cmi proofs/pfedit.cmi \
+    parsing/pcoq.cmi kernel/names.cmi library/nameops.cmi proofs/logic.cmi \
+    library/libobject.cmi library/libnames.cmi library/goptions.cmi \
+    library/global.cmi interp/genarg.cmi pretyping/evd.cmi kernel/environ.cmi \
+    parsing/egrammar.cmi kernel/declarations.cmi interp/constrintern.cmi \
+    interp/constrextern.cmi kernel/closure.cmi pretyping/clenv.cmi \
+    toplevel/cerrors.cmi lib/bigint.cmi 
+dev/top_printers.cmx: toplevel/vernacinterp.cmx lib/util.cmx kernel/univ.cmx \
+    pretyping/termops.cmx kernel/term.cmx parsing/tactic_printer.cmx \
+    lib/system.cmx kernel/sign.cmx proofs/refiner.cmx proofs/proof_trees.cmx \
+    parsing/printer.cmx parsing/pptactic.cmx lib/pp.cmx proofs/pfedit.cmx \
+    parsing/pcoq.cmx kernel/names.cmx library/nameops.cmx proofs/logic.cmx \
+    library/libobject.cmx library/libnames.cmx library/goptions.cmx \
+    library/global.cmx interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \
+    parsing/egrammar.cmx kernel/declarations.cmx interp/constrintern.cmx \
+    interp/constrextern.cmx kernel/closure.cmx pretyping/clenv.cmx \
+    toplevel/cerrors.cmx lib/bigint.cmx 
+dev/vm_printers.cmo: kernel/vm.cmi kernel/term.cmi kernel/names.cmi \
+    kernel/cemitcodes.cmi kernel/cbytecodes.cmi 
+dev/vm_printers.cmx: kernel/vm.cmx kernel/term.cmx kernel/names.cmx \
+    kernel/cemitcodes.cmx kernel/cbytecodes.cmx 
 ide/blaster_window.cmo: ide/ideutils.cmi ide/coq.cmi 
 ide/blaster_window.cmx: ide/ideutils.cmx ide/coq.cmx 
 ide/command_windows.cmo: ide/ideutils.cmi ide/coq_commands.cmo ide/coq.cmi \
@@ -474,94 +565,98 @@ ide/config_parser.cmo: lib/util.cmi ide/config_parser.cmi
 ide/config_parser.cmx: lib/util.cmx ide/config_parser.cmi 
 ide/coq.cmo: toplevel/vernacexpr.cmo toplevel/vernacentries.cmi \
     toplevel/vernac.cmi lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
-    proofs/tacmach.cmi tactics/tacinterp.cmi library/states.cmi \
-    proofs/refiner.cmi pretyping/reductionops.cmi proofs/proof_trees.cmi \
+    proofs/tacmach.cmi tactics/tacinterp.cmi lib/system.cmi \
+    library/states.cmi proofs/refiner.cmi pretyping/reductionops.cmi \
     parsing/printer.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \
     lib/options.cmi library/nametab.cmi kernel/names.cmi toplevel/mltop.cmi \
     library/library.cmi library/libnames.cmi library/lib.cmi ide/ideutils.cmi \
-    tactics/hipattern.cmi library/global.cmi pretyping/evd.cmi \
-    pretyping/evarutil.cmi kernel/environ.cmi kernel/declarations.cmi \
-    toplevel/coqtop.cmi config/coq_config.cmi toplevel/cerrors.cmi \
-    ide/coq.cmi 
+    tactics/hipattern.cmi library/goptions.cmi library/global.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \
+    kernel/declarations.cmi proofs/decl_mode.cmi toplevel/coqtop.cmi \
+    config/coq_config.cmi toplevel/cerrors.cmi ide/coq.cmi 
 ide/coq.cmx: toplevel/vernacexpr.cmx toplevel/vernacentries.cmx \
     toplevel/vernac.cmx lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
-    proofs/tacmach.cmx tactics/tacinterp.cmx library/states.cmx \
-    proofs/refiner.cmx pretyping/reductionops.cmx proofs/proof_trees.cmx \
+    proofs/tacmach.cmx tactics/tacinterp.cmx lib/system.cmx \
+    library/states.cmx proofs/refiner.cmx pretyping/reductionops.cmx \
     parsing/printer.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \
     lib/options.cmx library/nametab.cmx kernel/names.cmx toplevel/mltop.cmx \
     library/library.cmx library/libnames.cmx library/lib.cmx ide/ideutils.cmx \
-    tactics/hipattern.cmx library/global.cmx pretyping/evd.cmx \
-    pretyping/evarutil.cmx kernel/environ.cmx kernel/declarations.cmx \
-    toplevel/coqtop.cmx config/coq_config.cmx toplevel/cerrors.cmx \
-    ide/coq.cmi 
+    tactics/hipattern.cmx library/goptions.cmx library/global.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \
+    kernel/declarations.cmx proofs/decl_mode.cmx toplevel/coqtop.cmx \
+    config/coq_config.cmx toplevel/cerrors.cmx ide/coq.cmi 
 ide/coq_tactics.cmo: ide/coq_tactics.cmi 
 ide/coq_tactics.cmx: ide/coq_tactics.cmi 
 ide/coqide.cmo: toplevel/vernacexpr.cmo lib/util.cmi ide/undo.cmi \
-    lib/system.cmi ide/preferences.cmi proofs/pfedit.cmi ide/ideutils.cmi \
-    ide/highlight.cmo ide/find_phrase.cmo ide/coq_commands.cmo ide/coq.cmi \
-    ide/command_windows.cmi ide/blaster_window.cmo ide/coqide.cmi 
+    lib/system.cmi ide/preferences.cmi lib/pp.cmi proofs/pfedit.cmi \
+    ide/ideutils.cmi ide/highlight.cmo ide/find_phrase.cmo \
+    proofs/decl_mode.cmi config/coq_config.cmi ide/coq_commands.cmo \
+    ide/coq.cmi ide/command_windows.cmi ide/blaster_window.cmo ide/coqide.cmi 
 ide/coqide.cmx: toplevel/vernacexpr.cmx lib/util.cmx ide/undo.cmx \
-    lib/system.cmx ide/preferences.cmx proofs/pfedit.cmx ide/ideutils.cmx \
-    ide/highlight.cmx ide/find_phrase.cmx ide/coq_commands.cmx ide/coq.cmx \
-    ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi 
-ide/find_phrase.cmo: ide/ideutils.cmi 
-ide/find_phrase.cmx: ide/ideutils.cmx 
+    lib/system.cmx ide/preferences.cmx lib/pp.cmx proofs/pfedit.cmx \
+    ide/ideutils.cmx ide/highlight.cmx ide/find_phrase.cmx \
+    proofs/decl_mode.cmx config/coq_config.cmx ide/coq_commands.cmx \
+    ide/coq.cmx ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi 
+ide/find_phrase.cmo: ide/preferences.cmi ide/ideutils.cmi 
+ide/find_phrase.cmx: ide/preferences.cmx ide/ideutils.cmx 
 ide/highlight.cmo: ide/ideutils.cmi 
 ide/highlight.cmx: ide/ideutils.cmx 
 ide/ideutils.cmo: ide/utf8_convert.cmo lib/system.cmi ide/preferences.cmi \
     lib/pp_control.cmi lib/options.cmi config/coq_config.cmi ide/ideutils.cmi 
 ide/ideutils.cmx: ide/utf8_convert.cmx lib/system.cmx ide/preferences.cmx \
     lib/pp_control.cmx lib/options.cmx config/coq_config.cmx ide/ideutils.cmi 
-ide/preferences.cmo: lib/util.cmi lib/system.cmi ide/utils/configwin.cmi \
-    ide/config_lexer.cmo ide/preferences.cmi 
-ide/preferences.cmx: lib/util.cmx lib/system.cmx ide/utils/configwin.cmx \
-    ide/config_lexer.cmx ide/preferences.cmi 
+ide/preferences.cmo: lib/util.cmi lib/system.cmi lib/options.cmi \
+    ide/utils/configwin.cmi ide/config_lexer.cmo ide/preferences.cmi 
+ide/preferences.cmx: lib/util.cmx lib/system.cmx lib/options.cmx \
+    ide/utils/configwin.cmx ide/config_lexer.cmx ide/preferences.cmi 
 ide/undo.cmo: ide/ideutils.cmi ide/undo.cmi 
 ide/undo.cmx: ide/ideutils.cmx ide/undo.cmi 
 interp/constrextern.cmo: lib/util.cmi kernel/univ.cmi interp/topconstr.cmi \
-    pretyping/termops.cmi kernel/term.cmi interp/symbols.cmi kernel/sign.cmi \
-    interp/reserve.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \
-    lib/pp.cmi pretyping/pattern.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/libnames.cmi library/lib.cmi \
-    kernel/inductive.cmi library/impargs.cmi library/global.cmi \
-    kernel/environ.cmi pretyping/detyping.cmi kernel/declarations.cmi \
-    pretyping/classops.cmi lib/bignat.cmi interp/constrextern.cmi 
+    pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi interp/reserve.cmi \
+    pretyping/recordops.cmi pretyping/rawterm.cmi lib/pp.cmi \
+    pretyping/pattern.cmi lib/options.cmi interp/notation.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi kernel/inductive.cmi library/impargs.cmi \
+    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    pretyping/detyping.cmi kernel/declarations.cmi pretyping/classops.cmi \
+    lib/bigint.cmi interp/constrextern.cmi 
 interp/constrextern.cmx: lib/util.cmx kernel/univ.cmx interp/topconstr.cmx \
-    pretyping/termops.cmx kernel/term.cmx interp/symbols.cmx kernel/sign.cmx \
-    interp/reserve.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \
-    lib/pp.cmx pretyping/pattern.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/libnames.cmx library/lib.cmx \
-    kernel/inductive.cmx library/impargs.cmx library/global.cmx \
-    kernel/environ.cmx pretyping/detyping.cmx kernel/declarations.cmx \
-    pretyping/classops.cmx lib/bignat.cmx interp/constrextern.cmi 
+    pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx interp/reserve.cmx \
+    pretyping/recordops.cmx pretyping/rawterm.cmx lib/pp.cmx \
+    pretyping/pattern.cmx lib/options.cmx interp/notation.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx kernel/inductive.cmx library/impargs.cmx \
+    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    pretyping/detyping.cmx kernel/declarations.cmx pretyping/classops.cmx \
+    lib/bigint.cmx interp/constrextern.cmi 
 interp/constrintern.cmo: lib/util.cmi interp/topconstr.cmi \
     pretyping/termops.cmi kernel/term.cmi interp/syntax_def.cmi \
-    interp/symbols.cmi kernel/sign.cmi pretyping/retyping.cmi \
-    interp/reserve.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \
-    pretyping/pretyping.cmi pretyping/pretype_errors.cmi lib/pp.cmi \
-    pretyping/pattern.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/libnames.cmi library/lib.cmi \
-    parsing/lexer.cmi kernel/inductive.cmi library/impargs.cmi \
-    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
-    kernel/declarations.cmi lib/bignat.cmi interp/constrintern.cmi 
+    kernel/sign.cmi interp/reserve.cmi pretyping/recordops.cmi \
+    pretyping/rawterm.cmi pretyping/pretyping.cmi \
+    pretyping/pretype_errors.cmi lib/pp.cmi pretyping/pattern.cmi \
+    lib/options.cmi interp/notation.cmi library/nametab.cmi kernel/names.cmi \
+    library/nameops.cmi library/libnames.cmi library/lib.cmi \
+    parsing/lexer.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
+    library/impargs.cmi library/global.cmi pretyping/evd.cmi \
+    kernel/environ.cmi kernel/declarations.cmi pretyping/cases.cmi \
+    lib/bigint.cmi interp/constrintern.cmi 
 interp/constrintern.cmx: lib/util.cmx interp/topconstr.cmx \
     pretyping/termops.cmx kernel/term.cmx interp/syntax_def.cmx \
-    interp/symbols.cmx kernel/sign.cmx pretyping/retyping.cmx \
-    interp/reserve.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \
-    pretyping/pretyping.cmx pretyping/pretype_errors.cmx lib/pp.cmx \
-    pretyping/pattern.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/libnames.cmx library/lib.cmx \
-    parsing/lexer.cmx kernel/inductive.cmx library/impargs.cmx \
-    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
-    kernel/declarations.cmx lib/bignat.cmx interp/constrintern.cmi 
+    kernel/sign.cmx interp/reserve.cmx pretyping/recordops.cmx \
+    pretyping/rawterm.cmx pretyping/pretyping.cmx \
+    pretyping/pretype_errors.cmx lib/pp.cmx pretyping/pattern.cmx \
+    lib/options.cmx interp/notation.cmx library/nametab.cmx kernel/names.cmx \
+    library/nameops.cmx library/libnames.cmx library/lib.cmx \
+    parsing/lexer.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
+    library/impargs.cmx library/global.cmx pretyping/evd.cmx \
+    kernel/environ.cmx kernel/declarations.cmx pretyping/cases.cmx \
+    lib/bigint.cmx interp/constrintern.cmi 
 interp/coqlib.cmo: lib/util.cmi kernel/term.cmi lib/pp.cmi \
-    pretyping/pattern.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/libnames.cmi interp/constrextern.cmi \
-    interp/coqlib.cmi 
+    pretyping/pattern.cmi library/nametab.cmi kernel/names.cmi \
+    library/library.cmi library/libnames.cmi interp/coqlib.cmi 
 interp/coqlib.cmx: lib/util.cmx kernel/term.cmx lib/pp.cmx \
-    pretyping/pattern.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/libnames.cmx interp/constrextern.cmx \
-    interp/coqlib.cmi 
+    pretyping/pattern.cmx library/nametab.cmx kernel/names.cmx \
+    library/library.cmx library/libnames.cmx interp/coqlib.cmi 
 interp/genarg.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
     pretyping/rawterm.cmi lib/pp.cmi library/nametab.cmi kernel/names.cmi \
     library/nameops.cmi pretyping/evd.cmi interp/genarg.cmi 
@@ -576,71 +671,95 @@ interp/modintern.cmx: lib/util.cmx interp/topconstr.cmx lib/pp.cmx \
     library/nametab.cmx kernel/names.cmx kernel/modops.cmx \
     library/libnames.cmx pretyping/evd.cmx kernel/entries.cmx \
     interp/constrintern.cmx interp/modintern.cmi 
-interp/ppextend.cmo: lib/util.cmi lib/pp.cmi kernel/names.cmi \
-    interp/ppextend.cmi 
-interp/ppextend.cmx: lib/util.cmx lib/pp.cmx kernel/names.cmx \
-    interp/ppextend.cmi 
-interp/reserve.cmo: lib/util.cmi library/summary.cmi pretyping/rawterm.cmi \
-    lib/pp.cmi lib/options.cmi kernel/names.cmi library/nameops.cmi \
-    library/libobject.cmi library/lib.cmi interp/reserve.cmi 
-interp/reserve.cmx: lib/util.cmx library/summary.cmx pretyping/rawterm.cmx \
-    lib/pp.cmx lib/options.cmx kernel/names.cmx library/nameops.cmx \
-    library/libobject.cmx library/lib.cmx interp/reserve.cmi 
-interp/symbols.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
+interp/notation.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
     library/summary.cmi pretyping/reductionops.cmi pretyping/rawterm.cmi \
     interp/ppextend.cmi lib/pp.cmi lib/options.cmi library/nametab.cmi \
     kernel/names.cmi library/libobject.cmi library/libnames.cmi \
     library/lib.cmi lib/gmapl.cmi lib/gmap.cmi library/global.cmi \
-    pretyping/classops.cmi lib/bignat.cmi interp/symbols.cmi 
-interp/symbols.cmx: lib/util.cmx interp/topconstr.cmx kernel/term.cmx \
+    pretyping/classops.cmi lib/bigint.cmi interp/notation.cmi 
+interp/notation.cmx: lib/util.cmx interp/topconstr.cmx kernel/term.cmx \
     library/summary.cmx pretyping/reductionops.cmx pretyping/rawterm.cmx \
     interp/ppextend.cmx lib/pp.cmx lib/options.cmx library/nametab.cmx \
     kernel/names.cmx library/libobject.cmx library/libnames.cmx \
     library/lib.cmx lib/gmapl.cmx lib/gmap.cmx library/global.cmx \
-    pretyping/classops.cmx lib/bignat.cmx interp/symbols.cmi 
-interp/syntax_def.cmo: lib/util.cmi interp/topconstr.cmi interp/symbols.cmi \
-    library/summary.cmi lib/pp.cmi library/nametab.cmi kernel/names.cmi \
-    library/nameops.cmi library/libobject.cmi library/libnames.cmi \
-    library/lib.cmi interp/syntax_def.cmi 
-interp/syntax_def.cmx: lib/util.cmx interp/topconstr.cmx interp/symbols.cmx \
-    library/summary.cmx lib/pp.cmx library/nametab.cmx kernel/names.cmx \
-    library/nameops.cmx library/libobject.cmx library/libnames.cmx \
-    library/lib.cmx interp/syntax_def.cmi 
+    pretyping/classops.cmx lib/bigint.cmx interp/notation.cmi 
+interp/ppextend.cmo: lib/util.cmi lib/pp.cmi kernel/names.cmi \
+    interp/ppextend.cmi 
+interp/ppextend.cmx: lib/util.cmx lib/pp.cmx kernel/names.cmx \
+    interp/ppextend.cmi 
+interp/reserve.cmo: lib/util.cmi library/summary.cmi pretyping/rawterm.cmi \
+    lib/pp.cmi kernel/names.cmi library/nameops.cmi library/libobject.cmi \
+    library/lib.cmi pretyping/evd.cmi interp/reserve.cmi 
+interp/reserve.cmx: lib/util.cmx library/summary.cmx pretyping/rawterm.cmx \
+    lib/pp.cmx kernel/names.cmx library/nameops.cmx library/libobject.cmx \
+    library/lib.cmx pretyping/evd.cmx interp/reserve.cmi 
+interp/syntax_def.cmo: lib/util.cmi interp/topconstr.cmi library/summary.cmi \
+    pretyping/rawterm.cmi lib/pp.cmi interp/notation.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi library/libobject.cmi \
+    library/libnames.cmi library/lib.cmi interp/syntax_def.cmi 
+interp/syntax_def.cmx: lib/util.cmx interp/topconstr.cmx library/summary.cmx \
+    pretyping/rawterm.cmx lib/pp.cmx interp/notation.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx library/libobject.cmx \
+    library/libnames.cmx library/lib.cmx interp/syntax_def.cmi 
 interp/topconstr.cmo: lib/util.cmi kernel/term.cmi pretyping/rawterm.cmi \
-    lib/pp.cmi lib/options.cmi kernel/names.cmi library/nameops.cmi \
-    library/libnames.cmi lib/dyn.cmi lib/bignat.cmi interp/topconstr.cmi 
+    lib/pp.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    kernel/mod_subst.cmi library/libnames.cmi pretyping/evd.cmi lib/dyn.cmi \
+    pretyping/detyping.cmi lib/bigint.cmi interp/topconstr.cmi 
 interp/topconstr.cmx: lib/util.cmx kernel/term.cmx pretyping/rawterm.cmx \
-    lib/pp.cmx lib/options.cmx kernel/names.cmx library/nameops.cmx \
-    library/libnames.cmx lib/dyn.cmx lib/bignat.cmx interp/topconstr.cmi 
-kernel/closure.cmo: lib/util.cmi kernel/term.cmi lib/pp.cmi kernel/names.cmi \
-    kernel/esubst.cmi kernel/environ.cmi kernel/declarations.cmi \
-    kernel/closure.cmi 
-kernel/closure.cmx: lib/util.cmx kernel/term.cmx lib/pp.cmx kernel/names.cmx \
-    kernel/esubst.cmx kernel/environ.cmx kernel/declarations.cmx \
-    kernel/closure.cmi 
-kernel/conv_oracle.cmo: kernel/names.cmi kernel/closure.cmi \
-    kernel/conv_oracle.cmi 
-kernel/conv_oracle.cmx: kernel/names.cmx kernel/closure.cmx \
-    kernel/conv_oracle.cmi 
-kernel/cooking.cmo: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
-    kernel/reduction.cmi lib/pp.cmi kernel/names.cmi kernel/environ.cmi \
-    kernel/declarations.cmi kernel/cooking.cmi 
-kernel/cooking.cmx: lib/util.cmx kernel/term.cmx kernel/sign.cmx \
-    kernel/reduction.cmx lib/pp.cmx kernel/names.cmx kernel/environ.cmx \
-    kernel/declarations.cmx kernel/cooking.cmi 
+    lib/pp.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    kernel/mod_subst.cmx library/libnames.cmx pretyping/evd.cmx lib/dyn.cmx \
+    pretyping/detyping.cmx lib/bigint.cmx interp/topconstr.cmi 
+kernel/cbytecodes.cmo: kernel/term.cmi kernel/names.cmi kernel/cbytecodes.cmi 
+kernel/cbytecodes.cmx: kernel/term.cmx kernel/names.cmx kernel/cbytecodes.cmi 
+kernel/cbytegen.cmo: lib/util.cmi kernel/term.cmi kernel/pre_env.cmi \
+    kernel/names.cmi kernel/declarations.cmi kernel/cemitcodes.cmi \
+    kernel/cbytecodes.cmi kernel/cbytegen.cmi 
+kernel/cbytegen.cmx: lib/util.cmx kernel/term.cmx kernel/pre_env.cmx \
+    kernel/names.cmx kernel/declarations.cmx kernel/cemitcodes.cmx \
+    kernel/cbytecodes.cmx kernel/cbytegen.cmi 
+kernel/cemitcodes.cmo: kernel/term.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    kernel/copcodes.cmo kernel/cbytecodes.cmi kernel/cemitcodes.cmi 
+kernel/cemitcodes.cmx: kernel/term.cmx kernel/names.cmx kernel/mod_subst.cmx \
+    kernel/copcodes.cmx kernel/cbytecodes.cmx kernel/cemitcodes.cmi 
+kernel/closure.cmo: lib/util.cmi kernel/term.cmi kernel/sign.cmi lib/pp.cmi \
+    kernel/names.cmi kernel/esubst.cmi kernel/environ.cmi \
+    kernel/declarations.cmi kernel/closure.cmi 
+kernel/closure.cmx: lib/util.cmx kernel/term.cmx kernel/sign.cmx lib/pp.cmx \
+    kernel/names.cmx kernel/esubst.cmx kernel/environ.cmx \
+    kernel/declarations.cmx kernel/closure.cmi 
+kernel/conv_oracle.cmo: kernel/names.cmi kernel/conv_oracle.cmi 
+kernel/conv_oracle.cmx: kernel/names.cmx kernel/conv_oracle.cmi 
+kernel/cooking.cmo: lib/util.cmi kernel/typeops.cmi kernel/term.cmi \
+    kernel/sign.cmi kernel/reduction.cmi lib/pp.cmi kernel/names.cmi \
+    kernel/environ.cmi kernel/declarations.cmi kernel/cemitcodes.cmi \
+    kernel/cooking.cmi 
+kernel/cooking.cmx: lib/util.cmx kernel/typeops.cmx kernel/term.cmx \
+    kernel/sign.cmx kernel/reduction.cmx lib/pp.cmx kernel/names.cmx \
+    kernel/environ.cmx kernel/declarations.cmx kernel/cemitcodes.cmx \
+    kernel/cooking.cmi 
+kernel/csymtable.cmo: kernel/vm.cmi kernel/term.cmi kernel/pre_env.cmi \
+    kernel/names.cmi kernel/declarations.cmi kernel/cemitcodes.cmi \
+    kernel/cbytegen.cmi kernel/cbytecodes.cmi kernel/csymtable.cmi 
+kernel/csymtable.cmx: kernel/vm.cmx kernel/term.cmx kernel/pre_env.cmx \
+    kernel/names.cmx kernel/declarations.cmx kernel/cemitcodes.cmx \
+    kernel/cbytegen.cmx kernel/cbytecodes.cmx kernel/csymtable.cmi 
 kernel/declarations.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
-    kernel/sign.cmi lib/rtree.cmi kernel/names.cmi kernel/declarations.cmi 
+    kernel/sign.cmi lib/rtree.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    kernel/cemitcodes.cmi kernel/cbytecodes.cmi kernel/declarations.cmi 
 kernel/declarations.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \
-    kernel/sign.cmx lib/rtree.cmx kernel/names.cmx kernel/declarations.cmi 
+    kernel/sign.cmx lib/rtree.cmx kernel/names.cmx kernel/mod_subst.cmx \
+    kernel/cemitcodes.cmx kernel/cbytecodes.cmx kernel/declarations.cmi 
 kernel/entries.cmo: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \
     kernel/names.cmi kernel/entries.cmi 
 kernel/entries.cmx: kernel/univ.cmx kernel/term.cmx kernel/sign.cmx \
     kernel/names.cmx kernel/entries.cmi 
 kernel/environ.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
-    kernel/sign.cmi kernel/names.cmi kernel/declarations.cmi \
+    kernel/sign.cmi kernel/pre_env.cmi kernel/names.cmi \
+    kernel/declarations.cmi kernel/csymtable.cmi kernel/cbytegen.cmi \
     kernel/environ.cmi 
 kernel/environ.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \
-    kernel/sign.cmx kernel/names.cmx kernel/declarations.cmx \
+    kernel/sign.cmx kernel/pre_env.cmx kernel/names.cmx \
+    kernel/declarations.cmx kernel/csymtable.cmx kernel/cbytegen.cmx \
     kernel/environ.cmi 
 kernel/esubst.cmo: lib/util.cmi kernel/esubst.cmi 
 kernel/esubst.cmx: lib/util.cmx kernel/esubst.cmi 
@@ -654,28 +773,44 @@ kernel/indtypes.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
     kernel/entries.cmx kernel/declarations.cmx kernel/indtypes.cmi 
 kernel/inductive.cmo: lib/util.cmi kernel/univ.cmi kernel/type_errors.cmi \
     kernel/term.cmi kernel/sign.cmi kernel/reduction.cmi kernel/names.cmi \
-    kernel/environ.cmi kernel/declarations.cmi kernel/inductive.cmi 
+    kernel/environ.cmi kernel/declarations.cmi kernel/closure.cmi \
+    kernel/inductive.cmi 
 kernel/inductive.cmx: lib/util.cmx kernel/univ.cmx kernel/type_errors.cmx \
     kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx kernel/names.cmx \
-    kernel/environ.cmx kernel/declarations.cmx kernel/inductive.cmi 
+    kernel/environ.cmx kernel/declarations.cmx kernel/closure.cmx \
+    kernel/inductive.cmi 
+kernel/mod_subst.cmo: lib/util.cmi kernel/term.cmi lib/pp.cmi \
+    kernel/names.cmi kernel/mod_subst.cmi 
+kernel/mod_subst.cmx: lib/util.cmx kernel/term.cmx lib/pp.cmx \
+    kernel/names.cmx kernel/mod_subst.cmi 
 kernel/mod_typing.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \
     kernel/term_typing.cmi kernel/subtyping.cmi kernel/reduction.cmi \
-    kernel/names.cmi kernel/modops.cmi kernel/environ.cmi kernel/entries.cmi \
-    kernel/declarations.cmi kernel/mod_typing.cmi 
+    kernel/names.cmi kernel/modops.cmi kernel/mod_subst.cmi \
+    kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \
+    kernel/cemitcodes.cmi kernel/mod_typing.cmi 
 kernel/mod_typing.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
     kernel/term_typing.cmx kernel/subtyping.cmx kernel/reduction.cmx \
-    kernel/names.cmx kernel/modops.cmx kernel/environ.cmx kernel/entries.cmx \
-    kernel/declarations.cmx kernel/mod_typing.cmi 
+    kernel/names.cmx kernel/modops.cmx kernel/mod_subst.cmx \
+    kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \
+    kernel/cemitcodes.cmx kernel/mod_typing.cmi 
 kernel/modops.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi lib/pp.cmi \
-    kernel/names.cmi kernel/environ.cmi kernel/entries.cmi \
-    kernel/declarations.cmi kernel/modops.cmi 
+    kernel/names.cmi kernel/mod_subst.cmi kernel/environ.cmi \
+    kernel/entries.cmi kernel/declarations.cmi kernel/cemitcodes.cmi \
+    kernel/modops.cmi 
 kernel/modops.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx lib/pp.cmx \
-    kernel/names.cmx kernel/environ.cmx kernel/entries.cmx \
-    kernel/declarations.cmx kernel/modops.cmi 
-kernel/names.cmo: lib/util.cmi lib/predicate.cmi lib/pp.cmi lib/options.cmi \
-    lib/hashcons.cmi kernel/names.cmi 
-kernel/names.cmx: lib/util.cmx lib/predicate.cmx lib/pp.cmx lib/options.cmx \
-    lib/hashcons.cmx kernel/names.cmi 
+    kernel/names.cmx kernel/mod_subst.cmx kernel/environ.cmx \
+    kernel/entries.cmx kernel/declarations.cmx kernel/cemitcodes.cmx \
+    kernel/modops.cmi 
+kernel/names.cmo: lib/util.cmi lib/predicate.cmi lib/pp.cmi lib/hashcons.cmi \
+    kernel/names.cmi 
+kernel/names.cmx: lib/util.cmx lib/predicate.cmx lib/pp.cmx lib/hashcons.cmx \
+    kernel/names.cmi 
+kernel/pre_env.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
+    kernel/sign.cmi kernel/names.cmi kernel/declarations.cmi \
+    kernel/pre_env.cmi 
+kernel/pre_env.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \
+    kernel/sign.cmx kernel/names.cmx kernel/declarations.cmx \
+    kernel/pre_env.cmi 
 kernel/reduction.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
     kernel/sign.cmi kernel/names.cmi kernel/esubst.cmi kernel/environ.cmi \
     kernel/declarations.cmi kernel/conv_oracle.cmi kernel/closure.cmi \
@@ -702,13 +837,15 @@ kernel/sign.cmo: lib/util.cmi kernel/term.cmi kernel/names.cmi \
     kernel/sign.cmi 
 kernel/sign.cmx: lib/util.cmx kernel/term.cmx kernel/names.cmx \
     kernel/sign.cmi 
-kernel/subtyping.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
-    kernel/reduction.cmi lib/pp.cmi kernel/names.cmi kernel/modops.cmi \
-    kernel/inductive.cmi kernel/environ.cmi kernel/declarations.cmi \
+kernel/subtyping.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \
+    kernel/term.cmi kernel/sign.cmi kernel/reduction.cmi kernel/names.cmi \
+    kernel/modops.cmi kernel/mod_subst.cmi kernel/inductive.cmi \
+    kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \
     kernel/subtyping.cmi 
-kernel/subtyping.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \
-    kernel/reduction.cmx lib/pp.cmx kernel/names.cmx kernel/modops.cmx \
-    kernel/inductive.cmx kernel/environ.cmx kernel/declarations.cmx \
+kernel/subtyping.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
+    kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx kernel/names.cmx \
+    kernel/modops.cmx kernel/mod_subst.cmx kernel/inductive.cmx \
+    kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \
     kernel/subtyping.cmi 
 kernel/term.cmo: lib/util.cmi kernel/univ.cmi lib/pp.cmi kernel/names.cmi \
     lib/hashcons.cmi kernel/esubst.cmi kernel/term.cmi 
@@ -718,12 +855,14 @@ kernel/term_typing.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \
     kernel/type_errors.cmi kernel/term.cmi kernel/sign.cmi \
     kernel/reduction.cmi kernel/names.cmi kernel/inductive.cmi \
     kernel/indtypes.cmi kernel/environ.cmi kernel/entries.cmi \
-    kernel/declarations.cmi kernel/cooking.cmi kernel/term_typing.cmi 
+    kernel/declarations.cmi kernel/cooking.cmi kernel/cemitcodes.cmi \
+    kernel/term_typing.cmi 
 kernel/term_typing.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
     kernel/type_errors.cmx kernel/term.cmx kernel/sign.cmx \
     kernel/reduction.cmx kernel/names.cmx kernel/inductive.cmx \
     kernel/indtypes.cmx kernel/environ.cmx kernel/entries.cmx \
-    kernel/declarations.cmx kernel/cooking.cmx kernel/term_typing.cmi 
+    kernel/declarations.cmx kernel/cooking.cmx kernel/cemitcodes.cmx \
+    kernel/term_typing.cmi 
 kernel/type_errors.cmo: kernel/term.cmi kernel/sign.cmi kernel/reduction.cmi \
     kernel/names.cmi kernel/environ.cmi kernel/type_errors.cmi 
 kernel/type_errors.cmx: kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx \
@@ -740,8 +879,20 @@ kernel/univ.cmo: lib/util.cmi lib/pp.cmi kernel/names.cmi lib/hashcons.cmi \
     kernel/univ.cmi 
 kernel/univ.cmx: lib/util.cmx lib/pp.cmx kernel/names.cmx lib/hashcons.cmx \
     kernel/univ.cmi 
-lib/bignat.cmo: lib/pp.cmi lib/bignat.cmi 
-lib/bignat.cmx: lib/pp.cmx lib/bignat.cmi 
+kernel/vconv.cmo: kernel/vm.cmi kernel/univ.cmi kernel/term.cmi \
+    kernel/reduction.cmi kernel/names.cmi kernel/environ.cmi \
+    kernel/declarations.cmi kernel/csymtable.cmi kernel/conv_oracle.cmi \
+    kernel/closure.cmi kernel/vconv.cmi 
+kernel/vconv.cmx: kernel/vm.cmx kernel/univ.cmx kernel/term.cmx \
+    kernel/reduction.cmx kernel/names.cmx kernel/environ.cmx \
+    kernel/declarations.cmx kernel/csymtable.cmx kernel/conv_oracle.cmx \
+    kernel/closure.cmx kernel/vconv.cmi 
+kernel/vm.cmo: lib/util.cmi kernel/term.cmi kernel/names.cmi \
+    kernel/conv_oracle.cmi kernel/cbytecodes.cmi kernel/vm.cmi 
+kernel/vm.cmx: lib/util.cmx kernel/term.cmx kernel/names.cmx \
+    kernel/conv_oracle.cmx kernel/cbytecodes.cmx kernel/vm.cmi 
+lib/bigint.cmo: lib/pp.cmi lib/bigint.cmi 
+lib/bigint.cmx: lib/pp.cmx lib/bigint.cmi 
 lib/bstack.cmo: lib/util.cmi lib/bstack.cmi 
 lib/bstack.cmx: lib/util.cmx lib/bstack.cmi 
 lib/dyn.cmo: lib/util.cmi lib/dyn.cmi 
@@ -772,44 +923,46 @@ lib/profile.cmo: lib/profile.cmi
 lib/profile.cmx: lib/profile.cmi 
 lib/rtree.cmo: lib/util.cmi lib/pp.cmi lib/rtree.cmi 
 lib/rtree.cmx: lib/util.cmx lib/pp.cmx lib/rtree.cmi 
-lib/stamps.cmo: lib/stamps.cmi 
-lib/stamps.cmx: lib/stamps.cmi 
 lib/system.cmo: lib/util.cmi lib/pp.cmi config/coq_config.cmi lib/system.cmi 
 lib/system.cmx: lib/util.cmx lib/pp.cmx config/coq_config.cmx lib/system.cmi 
 lib/tlm.cmo: lib/gset.cmi lib/gmap.cmi lib/tlm.cmi 
 lib/tlm.cmx: lib/gset.cmx lib/gmap.cmx lib/tlm.cmi 
 lib/util.cmo: lib/pp.cmi lib/compat.cmo lib/util.cmi 
 lib/util.cmx: lib/pp.cmx lib/compat.cmx lib/util.cmi 
+library/decl_kinds.cmo: lib/util.cmi 
+library/decl_kinds.cmx: lib/util.cmx 
 library/declare.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \
-    kernel/type_errors.cmi kernel/term.cmi interp/symbols.cmi \
-    library/summary.cmi kernel/sign.cmi kernel/safe_typing.cmi \
-    kernel/reduction.cmi lib/pp.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/libobject.cmi \
-    library/libnames.cmi library/lib.cmi kernel/inductive.cmi \
-    kernel/indtypes.cmi library/impargs.cmi library/global.cmi \
-    kernel/environ.cmi kernel/entries.cmi library/dischargedhypsmap.cmi \
-    kernel/declarations.cmi library/decl_kinds.cmo library/declare.cmi 
+    kernel/type_errors.cmi kernel/term.cmi library/summary.cmi \
+    kernel/sign.cmi kernel/safe_typing.cmi kernel/reduction.cmi lib/pp.cmi \
+    lib/options.cmi interp/notation.cmi library/nametab.cmi kernel/names.cmi \
+    library/nameops.cmi library/libobject.cmi library/libnames.cmi \
+    library/lib.cmi kernel/inductive.cmi kernel/indtypes.cmi \
+    library/impargs.cmi library/global.cmi kernel/environ.cmi \
+    kernel/entries.cmi library/dischargedhypsmap.cmi toplevel/discharge.cmi \
+    kernel/declarations.cmi library/decl_kinds.cmo kernel/cooking.cmi \
+    library/declare.cmi 
 library/declare.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
-    kernel/type_errors.cmx kernel/term.cmx interp/symbols.cmx \
-    library/summary.cmx kernel/sign.cmx kernel/safe_typing.cmx \
-    kernel/reduction.cmx lib/pp.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/libobject.cmx \
-    library/libnames.cmx library/lib.cmx kernel/inductive.cmx \
-    kernel/indtypes.cmx library/impargs.cmx library/global.cmx \
-    kernel/environ.cmx kernel/entries.cmx library/dischargedhypsmap.cmx \
-    kernel/declarations.cmx library/decl_kinds.cmx library/declare.cmi 
+    kernel/type_errors.cmx kernel/term.cmx library/summary.cmx \
+    kernel/sign.cmx kernel/safe_typing.cmx kernel/reduction.cmx lib/pp.cmx \
+    lib/options.cmx interp/notation.cmx library/nametab.cmx kernel/names.cmx \
+    library/nameops.cmx library/libobject.cmx library/libnames.cmx \
+    library/lib.cmx kernel/inductive.cmx kernel/indtypes.cmx \
+    library/impargs.cmx library/global.cmx kernel/environ.cmx \
+    kernel/entries.cmx library/dischargedhypsmap.cmx toplevel/discharge.cmx \
+    kernel/declarations.cmx library/decl_kinds.cmx kernel/cooking.cmx \
+    library/declare.cmi 
 library/declaremods.cmo: lib/util.cmi library/summary.cmi \
     kernel/subtyping.cmi lib/pp.cmi library/nametab.cmi kernel/names.cmi \
-    kernel/modops.cmi kernel/mod_typing.cmi library/libobject.cmi \
-    library/libnames.cmi library/lib.cmi library/global.cmi \
-    kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \
-    library/declaremods.cmi 
+    kernel/modops.cmi kernel/mod_typing.cmi kernel/mod_subst.cmi \
+    library/libobject.cmi library/libnames.cmi library/lib.cmi \
+    library/global.cmi kernel/environ.cmi kernel/entries.cmi \
+    kernel/declarations.cmi library/declaremods.cmi 
 library/declaremods.cmx: lib/util.cmx library/summary.cmx \
     kernel/subtyping.cmx lib/pp.cmx library/nametab.cmx kernel/names.cmx \
-    kernel/modops.cmx kernel/mod_typing.cmx library/libobject.cmx \
-    library/libnames.cmx library/lib.cmx library/global.cmx \
-    kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \
-    library/declaremods.cmi 
+    kernel/modops.cmx kernel/mod_typing.cmx kernel/mod_subst.cmx \
+    library/libobject.cmx library/libnames.cmx library/lib.cmx \
+    library/global.cmx kernel/environ.cmx kernel/entries.cmx \
+    kernel/declarations.cmx library/declaremods.cmi 
 library/dischargedhypsmap.cmo: lib/util.cmi kernel/term.cmi \
     library/summary.cmi kernel/reduction.cmi library/nametab.cmi \
     kernel/names.cmi library/libobject.cmi library/libnames.cmi \
@@ -820,46 +973,52 @@ library/dischargedhypsmap.cmx: lib/util.cmx kernel/term.cmx \
     kernel/names.cmx library/libobject.cmx library/libnames.cmx \
     library/lib.cmx kernel/inductive.cmx kernel/environ.cmx \
     kernel/declarations.cmx library/dischargedhypsmap.cmi 
-library/global.cmo: lib/util.cmi kernel/term.cmi library/summary.cmi \
-    kernel/sign.cmi kernel/safe_typing.cmi kernel/names.cmi \
-    library/libnames.cmi kernel/inductive.cmi kernel/environ.cmi \
-    library/global.cmi 
-library/global.cmx: lib/util.cmx kernel/term.cmx library/summary.cmx \
-    kernel/sign.cmx kernel/safe_typing.cmx kernel/names.cmx \
-    library/libnames.cmx kernel/inductive.cmx kernel/environ.cmx \
-    library/global.cmi 
+library/global.cmo: lib/util.cmi kernel/typeops.cmi kernel/term.cmi \
+    library/summary.cmi kernel/sign.cmi kernel/safe_typing.cmi \
+    kernel/names.cmi library/libnames.cmi kernel/inductive.cmi \
+    kernel/environ.cmi library/global.cmi 
+library/global.cmx: lib/util.cmx kernel/typeops.cmx kernel/term.cmx \
+    library/summary.cmx kernel/sign.cmx kernel/safe_typing.cmx \
+    kernel/names.cmx library/libnames.cmx kernel/inductive.cmx \
+    kernel/environ.cmx library/global.cmi 
 library/goptions.cmo: lib/util.cmi kernel/term.cmi library/summary.cmi \
-    lib/pp.cmi library/nametab.cmi kernel/names.cmi library/libobject.cmi \
-    library/libnames.cmi library/lib.cmi library/goptions.cmi 
+    lib/pp.cmi library/nametab.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    library/libobject.cmi library/libnames.cmi library/lib.cmi \
+    library/goptions.cmi 
 library/goptions.cmx: lib/util.cmx kernel/term.cmx library/summary.cmx \
-    lib/pp.cmx library/nametab.cmx kernel/names.cmx library/libobject.cmx \
-    library/libnames.cmx library/lib.cmx library/goptions.cmi 
-library/impargs.cmo: lib/util.cmi interp/topconstr.cmi pretyping/termops.cmi \
-    kernel/term.cmi library/summary.cmi kernel/reduction.cmi lib/pp.cmi \
-    lib/options.cmi library/nametab.cmi kernel/names.cmi \
+    lib/pp.cmx library/nametab.cmx kernel/names.cmx kernel/mod_subst.cmx \
+    library/libobject.cmx library/libnames.cmx library/lib.cmx \
+    library/goptions.cmi 
+library/impargs.cmo: lib/util.cmi kernel/typeops.cmi interp/topconstr.cmi \
+    pretyping/termops.cmi kernel/term.cmi library/summary.cmi \
+    kernel/reduction.cmi lib/pp.cmi library/nametab.cmi kernel/names.cmi \
     library/libobject.cmi library/libnames.cmi library/lib.cmi \
     kernel/inductive.cmi library/global.cmi kernel/environ.cmi \
     kernel/declarations.cmi library/impargs.cmi 
-library/impargs.cmx: lib/util.cmx interp/topconstr.cmx pretyping/termops.cmx \
-    kernel/term.cmx library/summary.cmx kernel/reduction.cmx lib/pp.cmx \
-    lib/options.cmx library/nametab.cmx kernel/names.cmx \
+library/impargs.cmx: lib/util.cmx kernel/typeops.cmx interp/topconstr.cmx \
+    pretyping/termops.cmx kernel/term.cmx library/summary.cmx \
+    kernel/reduction.cmx lib/pp.cmx library/nametab.cmx kernel/names.cmx \
     library/libobject.cmx library/libnames.cmx library/lib.cmx \
     kernel/inductive.cmx library/global.cmx kernel/environ.cmx \
     kernel/declarations.cmx library/impargs.cmi 
-library/lib.cmo: lib/util.cmi library/summary.cmi lib/pp.cmi lib/options.cmi \
-    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libobject.cmi library/libnames.cmi library/lib.cmi 
-library/lib.cmx: lib/util.cmx library/summary.cmx lib/pp.cmx lib/options.cmx \
-    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/libobject.cmx library/libnames.cmx library/lib.cmi 
+library/lib.cmo: lib/util.cmi kernel/term.cmi library/summary.cmi \
+    kernel/sign.cmi lib/pp.cmi lib/options.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi library/libobject.cmi \
+    library/libnames.cmi kernel/cooking.cmi library/lib.cmi 
+library/lib.cmx: lib/util.cmx kernel/term.cmx library/summary.cmx \
+    kernel/sign.cmx lib/pp.cmx lib/options.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx library/libobject.cmx \
+    library/libnames.cmx kernel/cooking.cmx library/lib.cmi 
 library/libnames.cmo: lib/util.cmi kernel/term.cmi lib/predicate.cmi \
-    lib/pp.cmi kernel/names.cmi library/nameops.cmi library/libnames.cmi 
+    lib/pp.cmi kernel/names.cmi library/nameops.cmi kernel/mod_subst.cmi \
+    library/libnames.cmi 
 library/libnames.cmx: lib/util.cmx kernel/term.cmx lib/predicate.cmx \
-    lib/pp.cmx kernel/names.cmx library/nameops.cmx library/libnames.cmi 
-library/libobject.cmo: lib/util.cmi kernel/names.cmi library/libnames.cmi \
-    lib/dyn.cmi library/libobject.cmi 
-library/libobject.cmx: lib/util.cmx kernel/names.cmx library/libnames.cmx \
-    lib/dyn.cmx library/libobject.cmi 
+    lib/pp.cmx kernel/names.cmx library/nameops.cmx kernel/mod_subst.cmx \
+    library/libnames.cmi 
+library/libobject.cmo: lib/util.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    library/libnames.cmi lib/dyn.cmi library/libobject.cmi 
+library/libobject.cmx: lib/util.cmx kernel/names.cmx kernel/mod_subst.cmx \
+    library/libnames.cmx lib/dyn.cmx library/libobject.cmi 
 library/library.cmo: lib/util.cmi lib/system.cmi library/summary.cmi \
     kernel/safe_typing.cmi lib/pp.cmi lib/options.cmi library/nametab.cmi \
     kernel/names.cmi library/nameops.cmi library/libobject.cmi \
@@ -888,550 +1047,528 @@ library/summary.cmo: lib/util.cmi lib/pp.cmi lib/dyn.cmi library/summary.cmi
 library/summary.cmx: lib/util.cmx lib/pp.cmx lib/dyn.cmx library/summary.cmi 
 parsing/argextend.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
     parsing/q_util.cmi parsing/q_coqast.cmo parsing/pcoq.cmi \
-    interp/genarg.cmi parsing/ast.cmi 
+    interp/genarg.cmi 
 parsing/argextend.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
     parsing/q_util.cmx parsing/q_coqast.cmx parsing/pcoq.cmx \
-    interp/genarg.cmx parsing/ast.cmx 
-parsing/ast.cmo: lib/util.cmi interp/topconstr.cmi lib/pp.cmi \
-    kernel/names.cmi library/libnames.cmi interp/genarg.cmi lib/dyn.cmi \
-    parsing/coqast.cmi parsing/ast.cmi 
-parsing/ast.cmx: lib/util.cmx interp/topconstr.cmx lib/pp.cmx \
-    kernel/names.cmx library/libnames.cmx interp/genarg.cmx lib/dyn.cmx \
-    parsing/coqast.cmx parsing/ast.cmi 
-parsing/coqast.cmo: lib/util.cmi kernel/names.cmi library/libnames.cmi \
-    lib/hashcons.cmi lib/dyn.cmi parsing/coqast.cmi 
-parsing/coqast.cmx: lib/util.cmx kernel/names.cmx library/libnames.cmx \
-    lib/hashcons.cmx lib/dyn.cmx parsing/coqast.cmi 
+    interp/genarg.cmx 
 parsing/egrammar.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi proofs/tacexpr.cmo library/summary.cmi \
-    parsing/pptactic.cmi interp/ppextend.cmi lib/pp.cmi parsing/pcoq.cmi \
-    lib/options.cmi kernel/names.cmi library/nameops.cmi library/libnames.cmi \
-    parsing/lexer.cmi interp/genarg.cmi parsing/extend.cmi lib/bignat.cmi \
-    parsing/ast.cmi parsing/egrammar.cmi 
-parsing/egrammar.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx proofs/tacexpr.cmx library/summary.cmx \
-    parsing/pptactic.cmx interp/ppextend.cmx lib/pp.cmx parsing/pcoq.cmx \
-    lib/options.cmx kernel/names.cmx library/nameops.cmx library/libnames.cmx \
-    parsing/lexer.cmx interp/genarg.cmx parsing/extend.cmx lib/bignat.cmx \
-    parsing/ast.cmx parsing/egrammar.cmi 
-parsing/esyntax.cmo: lib/util.cmi interp/topconstr.cmi interp/symbols.cmi \
-    interp/ppextend.cmi lib/pp.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/libnames.cmi lib/gmapl.cmi lib/gmap.cmi \
-    parsing/extend.cmi parsing/coqast.cmi parsing/ast.cmi parsing/esyntax.cmi 
-parsing/esyntax.cmx: lib/util.cmx interp/topconstr.cmx interp/symbols.cmx \
-    interp/ppextend.cmx lib/pp.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/libnames.cmx lib/gmapl.cmx lib/gmap.cmx \
-    parsing/extend.cmx parsing/coqast.cmx parsing/ast.cmx parsing/esyntax.cmi 
-parsing/extend.cmo: lib/util.cmi interp/topconstr.cmi pretyping/rawterm.cmi \
-    interp/ppextend.cmi lib/pp.cmi lib/options.cmi kernel/names.cmi \
+    interp/topconstr.cmi proofs/tacexpr.cmo library/summary.cmi lib/pp.cmi \
+    parsing/pcoq.cmi interp/notation.cmi kernel/names.cmi library/nameops.cmi \
     library/libnames.cmi parsing/lexer.cmi interp/genarg.cmi \
-    parsing/coqast.cmi parsing/ast.cmi parsing/extend.cmi 
-parsing/extend.cmx: lib/util.cmx interp/topconstr.cmx pretyping/rawterm.cmx \
-    interp/ppextend.cmx lib/pp.cmx lib/options.cmx kernel/names.cmx \
+    parsing/extend.cmi lib/bigint.cmi parsing/egrammar.cmi 
+parsing/egrammar.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    interp/topconstr.cmx proofs/tacexpr.cmx library/summary.cmx lib/pp.cmx \
+    parsing/pcoq.cmx interp/notation.cmx kernel/names.cmx library/nameops.cmx \
     library/libnames.cmx parsing/lexer.cmx interp/genarg.cmx \
-    parsing/coqast.cmx parsing/ast.cmx parsing/extend.cmi 
-parsing/g_basevernac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    parsing/termast.cmi interp/ppextend.cmi lib/pp.cmi parsing/pcoq.cmi \
-    lib/options.cmi kernel/names.cmi toplevel/metasyntax.cmi \
-    parsing/lexer.cmi library/goptions.cmi library/global.cmi \
-    parsing/extend.cmi pretyping/evd.cmi parsing/coqast.cmi \
-    interp/constrintern.cmi parsing/ast.cmi 
-parsing/g_basevernac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    parsing/termast.cmx interp/ppextend.cmx lib/pp.cmx parsing/pcoq.cmx \
-    lib/options.cmx kernel/names.cmx toplevel/metasyntax.cmx \
-    parsing/lexer.cmx library/goptions.cmx library/global.cmx \
-    parsing/extend.cmx pretyping/evd.cmx parsing/coqast.cmx \
-    interp/constrintern.cmx parsing/ast.cmx 
-parsing/g_cases.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    lib/pp.cmi parsing/pcoq.cmi lib/options.cmi library/libnames.cmi \
-    parsing/g_constr.cmo 
-parsing/g_cases.cmx: lib/util.cmx interp/topconstr.cmx kernel/term.cmx \
-    lib/pp.cmx parsing/pcoq.cmx lib/options.cmx library/libnames.cmx \
-    parsing/g_constr.cmx 
+    parsing/extend.cmx lib/bigint.cmx parsing/egrammar.cmi 
+parsing/extend.cmo: lib/util.cmi interp/topconstr.cmi interp/ppextend.cmi \
+    lib/pp.cmi kernel/names.cmi interp/genarg.cmi parsing/extend.cmi 
+parsing/extend.cmx: lib/util.cmx interp/topconstr.cmx interp/ppextend.cmx \
+    lib/pp.cmx kernel/names.cmx interp/genarg.cmx parsing/extend.cmi 
+parsing/g_ascii_syntax.cmo: lib/util.cmi interp/topconstr.cmi \
+    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi interp/notation.cmi \
+    kernel/names.cmi library/libnames.cmi interp/coqlib.cmi lib/bigint.cmi 
+parsing/g_ascii_syntax.cmx: lib/util.cmx interp/topconstr.cmx \
+    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx interp/notation.cmx \
+    kernel/names.cmx library/libnames.cmx interp/coqlib.cmx lib/bigint.cmx 
 parsing/g_constr.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi pretyping/pattern.cmi \
-    lib/options.cmi kernel/names.cmi library/libnames.cmi parsing/lexer.cmi 
+    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi \
+    library/libnames.cmi parsing/lexer.cmi lib/bigint.cmi 
 parsing/g_constr.cmx: lib/util.cmx interp/topconstr.cmx kernel/term.cmx \
-    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx pretyping/pattern.cmx \
-    lib/options.cmx kernel/names.cmx library/libnames.cmx parsing/lexer.cmx 
-parsing/g_constrnew.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    kernel/names.cmi library/libnames.cmi parsing/lexer.cmi \
-    parsing/coqast.cmi lib/bignat.cmi 
-parsing/g_constrnew.cmx: lib/util.cmx interp/topconstr.cmx kernel/term.cmx \
-    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    kernel/names.cmx library/libnames.cmx parsing/lexer.cmx \
-    parsing/coqast.cmx lib/bignat.cmx 
+    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \
+    library/libnames.cmx parsing/lexer.cmx lib/bigint.cmx 
+parsing/g_decl_mode.cmo: interp/topconstr.cmi kernel/term.cmi \
+    parsing/pcoq.cmi kernel/names.cmi library/libnames.cmi interp/genarg.cmi \
+    proofs/decl_expr.cmi 
+parsing/g_decl_mode.cmx: interp/topconstr.cmx kernel/term.cmx \
+    parsing/pcoq.cmx kernel/names.cmx library/libnames.cmx interp/genarg.cmx \
+    proofs/decl_expr.cmi 
 parsing/g_ltac.cmo: toplevel/vernacexpr.cmo lib/util.cmi interp/topconstr.cmi \
     proofs/tacexpr.cmo pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi \
-    pretyping/pattern.cmi lib/options.cmi kernel/names.cmi \
-    library/libnames.cmi interp/genarg.cmi parsing/ast.cmi 
+    kernel/names.cmi 
 parsing/g_ltac.cmx: toplevel/vernacexpr.cmx lib/util.cmx interp/topconstr.cmx \
     proofs/tacexpr.cmx pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx \
-    pretyping/pattern.cmx lib/options.cmx kernel/names.cmx \
-    library/libnames.cmx interp/genarg.cmx parsing/ast.cmx 
-parsing/g_ltacnew.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi proofs/tacexpr.cmo pretyping/rawterm.cmi lib/pp.cmi \
-    parsing/pcoq.cmi lib/options.cmi kernel/names.cmi interp/genarg.cmi \
-    parsing/ast.cmi 
-parsing/g_ltacnew.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx proofs/tacexpr.cmx pretyping/rawterm.cmx lib/pp.cmx \
-    parsing/pcoq.cmx lib/options.cmx kernel/names.cmx interp/genarg.cmx \
-    parsing/ast.cmx 
+    kernel/names.cmx 
 parsing/g_minicoq.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
     lib/pp.cmi kernel/names.cmi parsing/lexer.cmi kernel/environ.cmi \
     parsing/g_minicoq.cmi 
 parsing/g_minicoq.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \
     lib/pp.cmx kernel/names.cmx parsing/lexer.cmx kernel/environ.cmx \
     parsing/g_minicoq.cmi 
-parsing/g_module.cmo: lib/util.cmi interp/topconstr.cmi lib/pp.cmi \
-    parsing/pcoq.cmi lib/options.cmi parsing/ast.cmi 
-parsing/g_module.cmx: lib/util.cmx interp/topconstr.cmx lib/pp.cmx \
-    parsing/pcoq.cmx lib/options.cmx parsing/ast.cmx 
-parsing/g_natsyntax.cmo: lib/util.cmi parsing/termast.cmi interp/symbols.cmi \
-    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    kernel/names.cmi library/libnames.cmi parsing/extend.cmi \
-    parsing/esyntax.cmi interp/coqlib.cmi parsing/coqast.cmi lib/bignat.cmi \
-    parsing/ast.cmi parsing/g_natsyntax.cmi 
-parsing/g_natsyntax.cmx: lib/util.cmx parsing/termast.cmx interp/symbols.cmx \
-    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    kernel/names.cmx library/libnames.cmx parsing/extend.cmx \
-    parsing/esyntax.cmx interp/coqlib.cmx parsing/coqast.cmx lib/bignat.cmx \
-    parsing/ast.cmx parsing/g_natsyntax.cmi 
-parsing/g_prim.cmo: interp/topconstr.cmi parsing/pcoq.cmi library/nametab.cmi \
-    kernel/names.cmi library/libnames.cmi parsing/coqast.cmi lib/bignat.cmi 
-parsing/g_prim.cmx: interp/topconstr.cmx parsing/pcoq.cmx library/nametab.cmx \
-    kernel/names.cmx library/libnames.cmx parsing/coqast.cmx lib/bignat.cmx 
-parsing/g_primnew.cmo: lib/util.cmi interp/topconstr.cmi lib/pp.cmi \
-    parsing/pcoq.cmi lib/options.cmi library/nametab.cmi kernel/names.cmi \
-    library/libnames.cmi parsing/lexer.cmi parsing/coqast.cmi lib/bignat.cmi 
-parsing/g_primnew.cmx: lib/util.cmx interp/topconstr.cmx lib/pp.cmx \
-    parsing/pcoq.cmx lib/options.cmx library/nametab.cmx kernel/names.cmx \
-    library/libnames.cmx parsing/lexer.cmx parsing/coqast.cmx lib/bignat.cmx 
+parsing/g_natsyntax.cmo: lib/util.cmi pretyping/rawterm.cmi lib/pp.cmi \
+    parsing/pcoq.cmi lib/options.cmi interp/notation.cmi kernel/names.cmi \
+    library/libnames.cmi interp/coqlib.cmi lib/bigint.cmi \
+    parsing/g_natsyntax.cmi 
+parsing/g_natsyntax.cmx: lib/util.cmx pretyping/rawterm.cmx lib/pp.cmx \
+    parsing/pcoq.cmx lib/options.cmx interp/notation.cmx kernel/names.cmx \
+    library/libnames.cmx interp/coqlib.cmx lib/bigint.cmx \
+    parsing/g_natsyntax.cmi 
+parsing/g_prim.cmo: lib/util.cmi interp/topconstr.cmi lib/pp.cmi \
+    parsing/pcoq.cmi library/nametab.cmi kernel/names.cmi \
+    library/libnames.cmi parsing/lexer.cmi lib/bigint.cmi 
+parsing/g_prim.cmx: lib/util.cmx interp/topconstr.cmx lib/pp.cmx \
+    parsing/pcoq.cmx library/nametab.cmx kernel/names.cmx \
+    library/libnames.cmx parsing/lexer.cmx lib/bigint.cmx 
 parsing/g_proofs.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi proofs/tacexpr.cmo lib/pp.cmi parsing/pcoq.cmi \
-    lib/options.cmi interp/genarg.cmi 
+    interp/topconstr.cmi kernel/term.cmi proofs/tacexpr.cmo \
+    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi interp/genarg.cmi \
+    parsing/g_vernac.cmo 
 parsing/g_proofs.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx proofs/tacexpr.cmx lib/pp.cmx parsing/pcoq.cmx \
-    lib/options.cmx interp/genarg.cmx 
-parsing/g_proofsnew.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi proofs/tacexpr.cmo lib/pp.cmi parsing/pcoq.cmi \
-    lib/options.cmi interp/genarg.cmi parsing/g_vernacnew.cmo 
-parsing/g_proofsnew.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx proofs/tacexpr.cmx lib/pp.cmx parsing/pcoq.cmx \
-    lib/options.cmx interp/genarg.cmx parsing/g_vernacnew.cmx 
-parsing/g_rsyntax.cmo: lib/util.cmi interp/topconstr.cmi parsing/termast.cmi \
-    interp/symbols.cmi pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi \
-    lib/options.cmi library/nametab.cmi kernel/names.cmi library/libnames.cmi \
-    parsing/extend.cmi parsing/esyntax.cmi parsing/coqast.cmi lib/bignat.cmi \
-    parsing/ast.cmi 
-parsing/g_rsyntax.cmx: lib/util.cmx interp/topconstr.cmx parsing/termast.cmx \
-    interp/symbols.cmx pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx \
-    lib/options.cmx library/nametab.cmx kernel/names.cmx library/libnames.cmx \
-    parsing/extend.cmx parsing/esyntax.cmx parsing/coqast.cmx lib/bignat.cmx \
-    parsing/ast.cmx 
+    interp/topconstr.cmx kernel/term.cmx proofs/tacexpr.cmx \
+    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx interp/genarg.cmx \
+    parsing/g_vernac.cmx 
+parsing/g_rsyntax.cmo: lib/util.cmi interp/topconstr.cmi \
+    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi interp/notation.cmi \
+    kernel/names.cmi library/libnames.cmi lib/bigint.cmi 
+parsing/g_rsyntax.cmx: lib/util.cmx interp/topconstr.cmx \
+    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx interp/notation.cmx \
+    kernel/names.cmx library/libnames.cmx lib/bigint.cmx 
+parsing/g_string_syntax.cmo: lib/util.cmi interp/topconstr.cmi \
+    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi interp/notation.cmi \
+    kernel/names.cmi library/libnames.cmi parsing/g_ascii_syntax.cmo \
+    interp/coqlib.cmi 
+parsing/g_string_syntax.cmx: lib/util.cmx interp/topconstr.cmx \
+    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx interp/notation.cmx \
+    kernel/names.cmx library/libnames.cmx parsing/g_ascii_syntax.cmx \
+    interp/coqlib.cmx 
 parsing/g_tactic.cmo: lib/util.cmi interp/topconstr.cmi proofs/tacexpr.cmo \
-    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi pretyping/pattern.cmi \
-    lib/options.cmi kernel/names.cmi library/libnames.cmi parsing/lexer.cmi \
-    interp/genarg.cmi parsing/ast.cmi 
+    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi \
+    parsing/lexer.cmi interp/genarg.cmi 
 parsing/g_tactic.cmx: lib/util.cmx interp/topconstr.cmx proofs/tacexpr.cmx \
-    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx pretyping/pattern.cmx \
-    lib/options.cmx kernel/names.cmx library/libnames.cmx parsing/lexer.cmx \
-    interp/genarg.cmx parsing/ast.cmx 
-parsing/g_tacticnew.cmo: lib/util.cmi interp/topconstr.cmi proofs/tacexpr.cmo \
-    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    kernel/names.cmi parsing/lexer.cmi interp/genarg.cmi parsing/ast.cmi 
-parsing/g_tacticnew.cmx: lib/util.cmx interp/topconstr.cmx proofs/tacexpr.cmx \
-    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    kernel/names.cmx parsing/lexer.cmx interp/genarg.cmx parsing/ast.cmx 
+    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \
+    parsing/lexer.cmx interp/genarg.cmx 
 parsing/g_vernac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi toplevel/recordobj.cmi lib/pp.cmi parsing/pcoq.cmi \
-    lib/options.cmi kernel/names.cmi library/goptions.cmi interp/genarg.cmi \
-    parsing/g_proofs.cmo parsing/g_basevernac.cmo library/decl_kinds.cmo \
-    toplevel/class.cmi parsing/ast.cmi 
-parsing/g_vernac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx toplevel/recordobj.cmx lib/pp.cmx parsing/pcoq.cmx \
-    lib/options.cmx kernel/names.cmx library/goptions.cmx interp/genarg.cmx \
-    parsing/g_proofs.cmx parsing/g_basevernac.cmx library/decl_kinds.cmx \
-    toplevel/class.cmx parsing/ast.cmx 
-parsing/g_vernacnew.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi toplevel/recordobj.cmi interp/ppextend.cmi \
+    interp/topconstr.cmi pretyping/recordops.cmi interp/ppextend.cmi \
     lib/pp.cmi parsing/pcoq.cmi lib/options.cmi kernel/names.cmi \
     library/nameops.cmi parsing/lexer.cmi library/goptions.cmi \
-    interp/genarg.cmi parsing/g_constrnew.cmo parsing/extend.cmi \
-    parsing/egrammar.cmi library/decl_kinds.cmo parsing/coqast.cmi \
-    toplevel/class.cmi parsing/ast.cmi 
-parsing/g_vernacnew.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx toplevel/recordobj.cmx interp/ppextend.cmx \
+    interp/genarg.cmi parsing/g_constr.cmo parsing/extend.cmi \
+    proofs/decl_mode.cmi library/decl_kinds.cmo toplevel/class.cmi 
+parsing/g_vernac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    interp/topconstr.cmx pretyping/recordops.cmx interp/ppextend.cmx \
     lib/pp.cmx parsing/pcoq.cmx lib/options.cmx kernel/names.cmx \
     library/nameops.cmx parsing/lexer.cmx library/goptions.cmx \
-    interp/genarg.cmx parsing/g_constrnew.cmx parsing/extend.cmx \
-    parsing/egrammar.cmx library/decl_kinds.cmx parsing/coqast.cmx \
-    toplevel/class.cmx parsing/ast.cmx 
-parsing/g_zsyntax.cmo: lib/util.cmi interp/topconstr.cmi parsing/termast.cmi \
-    interp/symbols.cmi pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi \
-    lib/options.cmi kernel/names.cmi library/libnames.cmi parsing/extend.cmi \
-    parsing/esyntax.cmi interp/coqlib.cmi parsing/coqast.cmi lib/bignat.cmi \
-    parsing/ast.cmi parsing/g_zsyntax.cmi 
-parsing/g_zsyntax.cmx: lib/util.cmx interp/topconstr.cmx parsing/termast.cmx \
-    interp/symbols.cmx pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx \
-    lib/options.cmx kernel/names.cmx library/libnames.cmx parsing/extend.cmx \
-    parsing/esyntax.cmx interp/coqlib.cmx parsing/coqast.cmx lib/bignat.cmx \
-    parsing/ast.cmx parsing/g_zsyntax.cmi 
+    interp/genarg.cmx parsing/g_constr.cmx parsing/extend.cmx \
+    proofs/decl_mode.cmx library/decl_kinds.cmx toplevel/class.cmx 
+parsing/g_xml.cmo: lib/util.cmi kernel/term.cmi proofs/tacexpr.cmo \
+    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi library/nametab.cmi \
+    kernel/names.cmi library/libnames.cmi pretyping/inductiveops.cmi \
+    kernel/inductive.cmi library/global.cmi interp/genarg.cmi \
+    pretyping/detyping.cmi kernel/declarations.cmi 
+parsing/g_xml.cmx: lib/util.cmx kernel/term.cmx proofs/tacexpr.cmx \
+    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx library/nametab.cmx \
+    kernel/names.cmx library/libnames.cmx pretyping/inductiveops.cmx \
+    kernel/inductive.cmx library/global.cmx interp/genarg.cmx \
+    pretyping/detyping.cmx kernel/declarations.cmx 
+parsing/g_zsyntax.cmo: lib/util.cmi interp/topconstr.cmi \
+    pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi interp/notation.cmi \
+    kernel/names.cmi library/libnames.cmi lib/bigint.cmi \
+    parsing/g_zsyntax.cmi 
+parsing/g_zsyntax.cmx: lib/util.cmx interp/topconstr.cmx \
+    pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx interp/notation.cmx \
+    kernel/names.cmx library/libnames.cmx lib/bigint.cmx \
+    parsing/g_zsyntax.cmi 
 parsing/lexer.cmo: lib/util.cmi lib/pp.cmi lib/options.cmi parsing/lexer.cmi 
 parsing/lexer.cmx: lib/util.cmx lib/pp.cmx lib/options.cmx parsing/lexer.cmi 
 parsing/pcoq.cmo: lib/util.cmi interp/topconstr.cmi proofs/tacexpr.cmo \
     pretyping/rawterm.cmi interp/ppextend.cmi lib/pp.cmi lib/options.cmi \
     kernel/names.cmi library/libnames.cmi parsing/lexer.cmi interp/genarg.cmi \
-    parsing/extend.cmi library/decl_kinds.cmo parsing/coqast.cmi \
-    parsing/ast.cmi parsing/pcoq.cmi 
+    parsing/extend.cmi library/decl_kinds.cmo parsing/pcoq.cmi 
 parsing/pcoq.cmx: lib/util.cmx interp/topconstr.cmx proofs/tacexpr.cmx \
     pretyping/rawterm.cmx interp/ppextend.cmx lib/pp.cmx lib/options.cmx \
     kernel/names.cmx library/libnames.cmx parsing/lexer.cmx interp/genarg.cmx \
-    parsing/extend.cmx library/decl_kinds.cmx parsing/coqast.cmx \
-    parsing/ast.cmx parsing/pcoq.cmi 
-parsing/ppconstr.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    interp/symbols.cmi pretyping/rawterm.cmi interp/ppextend.cmi lib/pp.cmi \
-    pretyping/pattern.cmi library/nametab.cmi kernel/names.cmi \
+    parsing/extend.cmx library/decl_kinds.cmx parsing/pcoq.cmi 
+parsing/ppconstr.cmo: lib/util.cmi kernel/univ.cmi interp/topconstr.cmi \
+    pretyping/termops.cmi kernel/term.cmi pretyping/rawterm.cmi \
+    interp/ppextend.cmi lib/pp.cmi pretyping/pattern.cmi lib/options.cmi \
+    interp/notation.cmi library/nametab.cmi kernel/names.cmi \
     library/nameops.cmi library/libnames.cmi interp/genarg.cmi \
-    pretyping/evd.cmi parsing/coqast.cmi interp/constrextern.cmi \
-    lib/bignat.cmi parsing/ast.cmi parsing/ppconstr.cmi 
-parsing/ppconstr.cmx: lib/util.cmx interp/topconstr.cmx kernel/term.cmx \
-    interp/symbols.cmx pretyping/rawterm.cmx interp/ppextend.cmx lib/pp.cmx \
-    pretyping/pattern.cmx library/nametab.cmx kernel/names.cmx \
+    pretyping/evd.cmi interp/constrextern.cmi lib/bigint.cmi \
+    parsing/ppconstr.cmi 
+parsing/ppconstr.cmx: lib/util.cmx kernel/univ.cmx interp/topconstr.cmx \
+    pretyping/termops.cmx kernel/term.cmx pretyping/rawterm.cmx \
+    interp/ppextend.cmx lib/pp.cmx pretyping/pattern.cmx lib/options.cmx \
+    interp/notation.cmx library/nametab.cmx kernel/names.cmx \
     library/nameops.cmx library/libnames.cmx interp/genarg.cmx \
-    pretyping/evd.cmx parsing/coqast.cmx interp/constrextern.cmx \
-    lib/bignat.cmx parsing/ast.cmx parsing/ppconstr.cmi 
-parsing/pptactic.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
-    proofs/tacexpr.cmo pretyping/rawterm.cmi parsing/printer.cmi \
-    translate/ppconstrnew.cmi parsing/ppconstr.cmi lib/pp.cmi \
-    pretyping/pattern.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
-    interp/genarg.cmi parsing/extend.cmi lib/dyn.cmi interp/constrextern.cmi \
-    kernel/closure.cmi parsing/pptactic.cmi 
-parsing/pptactic.cmx: lib/util.cmx interp/topconstr.cmx kernel/term.cmx \
-    proofs/tacexpr.cmx pretyping/rawterm.cmx parsing/printer.cmx \
-    translate/ppconstrnew.cmx parsing/ppconstr.cmx lib/pp.cmx \
-    pretyping/pattern.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
-    interp/genarg.cmx parsing/extend.cmx lib/dyn.cmx interp/constrextern.cmx \
-    kernel/closure.cmx parsing/pptactic.cmi 
+    pretyping/evd.cmx interp/constrextern.cmx lib/bigint.cmx \
+    parsing/ppconstr.cmi 
+parsing/ppdecl_proof.cmo: lib/util.cmi kernel/term.cmi parsing/printer.cmi \
+    parsing/pptactic.cmi parsing/ppconstr.cmi lib/pp.cmi kernel/names.cmi \
+    library/nameops.cmi kernel/environ.cmi proofs/decl_expr.cmi \
+    parsing/ppdecl_proof.cmi 
+parsing/ppdecl_proof.cmx: lib/util.cmx kernel/term.cmx parsing/printer.cmx \
+    parsing/pptactic.cmx parsing/ppconstr.cmx lib/pp.cmx kernel/names.cmx \
+    library/nameops.cmx kernel/environ.cmx proofs/decl_expr.cmi \
+    parsing/ppdecl_proof.cmi 
+parsing/pptactic.cmo: lib/util.cmi interp/topconstr.cmi pretyping/termops.cmi \
+    kernel/term.cmi proofs/tactic_debug.cmi proofs/tacexpr.cmo \
+    pretyping/rawterm.cmi parsing/printer.cmi interp/ppextend.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi pretyping/pattern.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi library/global.cmi interp/genarg.cmi \
+    parsing/egrammar.cmi lib/dyn.cmi kernel/closure.cmi parsing/pptactic.cmi 
+parsing/pptactic.cmx: lib/util.cmx interp/topconstr.cmx pretyping/termops.cmx \
+    kernel/term.cmx proofs/tactic_debug.cmx proofs/tacexpr.cmx \
+    pretyping/rawterm.cmx parsing/printer.cmx interp/ppextend.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx pretyping/pattern.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx library/global.cmx interp/genarg.cmx \
+    parsing/egrammar.cmx lib/dyn.cmx kernel/closure.cmx parsing/pptactic.cmi 
+parsing/ppvernac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
+    interp/topconstr.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
+    pretyping/rawterm.cmi parsing/pptactic.cmi interp/ppextend.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \
+    lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    interp/modintern.cmi library/libnames.cmi library/lib.cmi \
+    library/impargs.cmi library/goptions.cmi library/global.cmi \
+    interp/genarg.cmi parsing/extend.cmi parsing/egrammar.cmi \
+    library/declaremods.cmi library/decl_kinds.cmo parsing/ppvernac.cmi 
+parsing/ppvernac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    interp/topconstr.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
+    pretyping/rawterm.cmx parsing/pptactic.cmx interp/ppextend.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \
+    lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    interp/modintern.cmx library/libnames.cmx library/lib.cmx \
+    library/impargs.cmx library/goptions.cmx library/global.cmx \
+    interp/genarg.cmx parsing/extend.cmx parsing/egrammar.cmx \
+    library/declaremods.cmx library/decl_kinds.cmx parsing/ppvernac.cmi 
 parsing/prettyp.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
-    interp/syntax_def.cmi interp/symbols.cmi kernel/sign.cmi \
-    kernel/safe_typing.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
-    parsing/printmod.cmi parsing/printer.cmi lib/pp.cmi lib/options.cmi \
+    interp/syntax_def.cmi kernel/sign.cmi kernel/safe_typing.cmi \
+    pretyping/reductionops.cmi kernel/reduction.cmi pretyping/recordops.cmi \
+    parsing/printmod.cmi parsing/printer.cmi lib/pp.cmi interp/notation.cmi \
     library/nametab.cmi kernel/names.cmi library/nameops.cmi \
     library/libobject.cmi library/libnames.cmi library/lib.cmi \
-    pretyping/instantiate.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
-    library/impargs.cmi library/global.cmi pretyping/evd.cmi \
-    kernel/environ.cmi library/declare.cmi kernel/declarations.cmi \
+    pretyping/inductiveops.cmi kernel/inductive.cmi library/impargs.cmi \
+    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    library/declare.cmi kernel/declarations.cmi kernel/conv_oracle.cmi \
     interp/constrextern.cmi pretyping/classops.cmi parsing/prettyp.cmi 
 parsing/prettyp.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
-    interp/syntax_def.cmx interp/symbols.cmx kernel/sign.cmx \
-    kernel/safe_typing.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
-    parsing/printmod.cmx parsing/printer.cmx lib/pp.cmx lib/options.cmx \
+    interp/syntax_def.cmx kernel/sign.cmx kernel/safe_typing.cmx \
+    pretyping/reductionops.cmx kernel/reduction.cmx pretyping/recordops.cmx \
+    parsing/printmod.cmx parsing/printer.cmx lib/pp.cmx interp/notation.cmx \
     library/nametab.cmx kernel/names.cmx library/nameops.cmx \
     library/libobject.cmx library/libnames.cmx library/lib.cmx \
-    pretyping/instantiate.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
-    library/impargs.cmx library/global.cmx pretyping/evd.cmx \
-    kernel/environ.cmx library/declare.cmx kernel/declarations.cmx \
+    pretyping/inductiveops.cmx kernel/inductive.cmx library/impargs.cmx \
+    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    library/declare.cmx kernel/declarations.cmx kernel/conv_oracle.cmx \
     interp/constrextern.cmx pretyping/classops.cmx parsing/prettyp.cmi 
-parsing/printer.cmo: lib/util.cmi pretyping/termops.cmi parsing/termast.cmi \
-    kernel/term.cmi kernel/sign.cmi interp/ppextend.cmi \
-    translate/ppconstrnew.cmi parsing/ppconstr.cmi lib/pp.cmi \
-    pretyping/pattern.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
-    library/global.cmi parsing/extend.cmi parsing/esyntax.cmi \
-    kernel/environ.cmi lib/dyn.cmi library/declare.cmi parsing/coqast.cmi \
-    interp/constrextern.cmi parsing/ast.cmi parsing/printer.cmi 
-parsing/printer.cmx: lib/util.cmx pretyping/termops.cmx parsing/termast.cmx \
-    kernel/term.cmx kernel/sign.cmx interp/ppextend.cmx \
-    translate/ppconstrnew.cmx parsing/ppconstr.cmx lib/pp.cmx \
-    pretyping/pattern.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
-    library/global.cmx parsing/extend.cmx parsing/esyntax.cmx \
-    kernel/environ.cmx lib/dyn.cmx library/declare.cmx parsing/coqast.cmx \
-    interp/constrextern.cmx parsing/ast.cmx parsing/printer.cmi 
+parsing/printer.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
+    kernel/sign.cmi proofs/refiner.cmi proofs/proof_type.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi library/global.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi kernel/environ.cmi library/declare.cmi \
+    proofs/decl_mode.cmi interp/constrextern.cmi parsing/printer.cmi 
+parsing/printer.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
+    kernel/sign.cmx proofs/refiner.cmx proofs/proof_type.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx library/global.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx kernel/environ.cmx library/declare.cmx \
+    proofs/decl_mode.cmx interp/constrextern.cmx parsing/printer.cmi 
 parsing/printmod.cmo: lib/util.cmi lib/pp.cmi library/nametab.cmi \
     kernel/names.cmi library/nameops.cmi library/libnames.cmi \
     library/global.cmi kernel/declarations.cmi parsing/printmod.cmi 
 parsing/printmod.cmx: lib/util.cmx lib/pp.cmx library/nametab.cmx \
     kernel/names.cmx library/nameops.cmx library/libnames.cmx \
     library/global.cmx kernel/declarations.cmx parsing/printmod.cmi 
+parsing/q_constr.cmo: lib/util.cmi kernel/term.cmi pretyping/rawterm.cmi \
+    parsing/q_util.cmi pretyping/pattern.cmi kernel/names.cmi 
+parsing/q_constr.cmx: lib/util.cmx kernel/term.cmx pretyping/rawterm.cmx \
+    parsing/q_util.cmx pretyping/pattern.cmx kernel/names.cmx 
 parsing/q_coqast.cmo: lib/util.cmi interp/topconstr.cmi proofs/tacexpr.cmo \
     pretyping/rawterm.cmi parsing/q_util.cmi parsing/pcoq.cmi \
-    kernel/names.cmi library/libnames.cmi interp/genarg.cmi \
-    parsing/coqast.cmi 
+    kernel/names.cmi library/libnames.cmi interp/genarg.cmi 
 parsing/q_coqast.cmx: lib/util.cmx interp/topconstr.cmx proofs/tacexpr.cmx \
     pretyping/rawterm.cmx parsing/q_util.cmx parsing/pcoq.cmx \
-    kernel/names.cmx library/libnames.cmx interp/genarg.cmx \
-    parsing/coqast.cmx 
-parsing/q_util.cmo: lib/util.cmi parsing/q_util.cmi 
-parsing/q_util.cmx: lib/util.cmx parsing/q_util.cmi 
-parsing/search.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
-    kernel/term.cmi pretyping/rawterm.cmi parsing/printer.cmi lib/pp.cmi \
-    pretyping/pattern.cmi library/nametab.cmi kernel/names.cmi \
-    library/nameops.cmi pretyping/matching.cmi library/library.cmi \
-    library/libobject.cmi library/libnames.cmi kernel/inductive.cmi \
+    kernel/names.cmx library/libnames.cmx interp/genarg.cmx 
+parsing/q_util.cmo: toplevel/vernacexpr.cmo lib/util.cmi parsing/pcoq.cmi \
+    interp/genarg.cmi parsing/q_util.cmi 
+parsing/q_util.cmx: toplevel/vernacexpr.cmx lib/util.cmx parsing/pcoq.cmx \
+    interp/genarg.cmx parsing/q_util.cmi 
+parsing/search.cmo: lib/util.cmi pretyping/typing.cmi kernel/typeops.cmi \
+    pretyping/termops.cmi kernel/term.cmi pretyping/rawterm.cmi \
+    parsing/printer.cmi lib/pp.cmi pretyping/pattern.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi pretyping/matching.cmi \
+    library/libobject.cmi library/libnames.cmi pretyping/inductiveops.cmi \
     library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
     library/declaremods.cmi library/declare.cmi kernel/declarations.cmi \
-    interp/coqlib.cmi parsing/coqast.cmi parsing/search.cmi 
-parsing/search.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
-    kernel/term.cmx pretyping/rawterm.cmx parsing/printer.cmx lib/pp.cmx \
-    pretyping/pattern.cmx library/nametab.cmx kernel/names.cmx \
-    library/nameops.cmx pretyping/matching.cmx library/library.cmx \
-    library/libobject.cmx library/libnames.cmx kernel/inductive.cmx \
+    interp/coqlib.cmi parsing/search.cmi 
+parsing/search.cmx: lib/util.cmx pretyping/typing.cmx kernel/typeops.cmx \
+    pretyping/termops.cmx kernel/term.cmx pretyping/rawterm.cmx \
+    parsing/printer.cmx lib/pp.cmx pretyping/pattern.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx pretyping/matching.cmx \
+    library/libobject.cmx library/libnames.cmx pretyping/inductiveops.cmx \
     library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
     library/declaremods.cmx library/declare.cmx kernel/declarations.cmx \
-    interp/coqlib.cmx parsing/coqast.cmx parsing/search.cmi 
-parsing/tacextend.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    parsing/q_util.cmi parsing/q_coqast.cmo lib/pp_control.cmi lib/pp.cmi \
-    parsing/pcoq.cmi interp/genarg.cmi parsing/argextend.cmo 
-parsing/tacextend.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    parsing/q_util.cmx parsing/q_coqast.cmx lib/pp_control.cmx lib/pp.cmx \
-    parsing/pcoq.cmx interp/genarg.cmx parsing/argextend.cmx 
-parsing/termast.cmo: lib/util.cmi kernel/univ.cmi pretyping/termops.cmi \
-    kernel/term.cmi kernel/sign.cmi pretyping/reductionops.cmi \
-    pretyping/rawterm.cmi lib/pp.cmi pretyping/pattern.cmi \
-    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libnames.cmi kernel/inductive.cmi library/impargs.cmi \
-    kernel/environ.cmi pretyping/detyping.cmi library/declare.cmi \
-    parsing/coqast.cmi interp/constrextern.cmi pretyping/classops.cmi \
-    parsing/ast.cmi parsing/termast.cmi 
-parsing/termast.cmx: lib/util.cmx kernel/univ.cmx pretyping/termops.cmx \
-    kernel/term.cmx kernel/sign.cmx pretyping/reductionops.cmx \
-    pretyping/rawterm.cmx lib/pp.cmx pretyping/pattern.cmx \
-    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/libnames.cmx kernel/inductive.cmx library/impargs.cmx \
-    kernel/environ.cmx pretyping/detyping.cmx library/declare.cmx \
-    parsing/coqast.cmx interp/constrextern.cmx pretyping/classops.cmx \
-    parsing/ast.cmx parsing/termast.cmi 
-parsing/vernacextend.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    parsing/q_util.cmi parsing/q_coqast.cmo lib/pp_control.cmi lib/pp.cmi \
-    parsing/pcoq.cmi interp/genarg.cmi parsing/ast.cmi parsing/argextend.cmo 
-parsing/vernacextend.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    parsing/q_util.cmx parsing/q_coqast.cmx lib/pp_control.cmx lib/pp.cmx \
-    parsing/pcoq.cmx interp/genarg.cmx parsing/ast.cmx parsing/argextend.cmx 
+    interp/coqlib.cmx parsing/search.cmi 
+parsing/tacextend.cmo: lib/util.cmi parsing/q_util.cmi parsing/q_coqast.cmo \
+    lib/pp_control.cmi lib/pp.cmi parsing/pcoq.cmi interp/genarg.cmi \
+    parsing/argextend.cmo 
+parsing/tacextend.cmx: lib/util.cmx parsing/q_util.cmx parsing/q_coqast.cmx \
+    lib/pp_control.cmx lib/pp.cmx parsing/pcoq.cmx interp/genarg.cmx \
+    parsing/argextend.cmx 
+parsing/tactic_printer.cmo: lib/util.cmi proofs/tacexpr.cmo kernel/sign.cmi \
+    proofs/refiner.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
+    parsing/printer.cmi parsing/pptactic.cmi parsing/ppdecl_proof.cmi \
+    lib/pp.cmi proofs/logic.cmi library/global.cmi pretyping/evd.cmi \
+    kernel/environ.cmi proofs/decl_expr.cmi parsing/tactic_printer.cmi 
+parsing/tactic_printer.cmx: lib/util.cmx proofs/tacexpr.cmx kernel/sign.cmx \
+    proofs/refiner.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
+    parsing/printer.cmx parsing/pptactic.cmx parsing/ppdecl_proof.cmx \
+    lib/pp.cmx proofs/logic.cmx library/global.cmx pretyping/evd.cmx \
+    kernel/environ.cmx proofs/decl_expr.cmi parsing/tactic_printer.cmi 
+parsing/vernacextend.cmo: lib/util.cmi parsing/q_util.cmi \
+    parsing/q_coqast.cmo lib/pp_control.cmi lib/pp.cmi interp/genarg.cmi \
+    parsing/argextend.cmo 
+parsing/vernacextend.cmx: lib/util.cmx parsing/q_util.cmx \
+    parsing/q_coqast.cmx lib/pp_control.cmx lib/pp.cmx interp/genarg.cmx \
+    parsing/argextend.cmx 
 pretyping/cases.cmo: lib/util.cmi kernel/typeops.cmi kernel/type_errors.cmi \
     pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
     pretyping/retyping.cmi pretyping/reductionops.cmi pretyping/rawterm.cmi \
     pretyping/pretype_errors.cmi lib/pp.cmi kernel/names.cmi \
     library/nameops.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
-    library/global.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \
-    kernel/environ.cmi kernel/declarations.cmi pretyping/coercion.cmi \
-    pretyping/cases.cmi 
+    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    pretyping/evarconv.cmi kernel/environ.cmi kernel/declarations.cmi \
+    pretyping/coercion.cmi kernel/closure.cmi pretyping/cases.cmi 
 pretyping/cases.cmx: lib/util.cmx kernel/typeops.cmx kernel/type_errors.cmx \
     pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx \
     pretyping/retyping.cmx pretyping/reductionops.cmx pretyping/rawterm.cmx \
     pretyping/pretype_errors.cmx lib/pp.cmx kernel/names.cmx \
     library/nameops.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
-    library/global.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \
-    kernel/environ.cmx kernel/declarations.cmx pretyping/coercion.cmx \
-    pretyping/cases.cmi 
+    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    pretyping/evarconv.cmx kernel/environ.cmx kernel/declarations.cmx \
+    pretyping/coercion.cmx kernel/closure.cmx pretyping/cases.cmi 
 pretyping/cbv.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi lib/pp.cmi \
-    kernel/names.cmi pretyping/instantiate.cmi pretyping/evd.cmi \
-    kernel/esubst.cmi kernel/environ.cmi kernel/closure.cmi pretyping/cbv.cmi 
+    kernel/names.cmi pretyping/evd.cmi kernel/esubst.cmi kernel/environ.cmi \
+    kernel/conv_oracle.cmi kernel/closure.cmi pretyping/cbv.cmi 
 pretyping/cbv.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx lib/pp.cmx \
-    kernel/names.cmx pretyping/instantiate.cmx pretyping/evd.cmx \
-    kernel/esubst.cmx kernel/environ.cmx kernel/closure.cmx pretyping/cbv.cmi 
+    kernel/names.cmx pretyping/evd.cmx kernel/esubst.cmx kernel/environ.cmx \
+    kernel/conv_oracle.cmx kernel/closure.cmx pretyping/cbv.cmi 
 pretyping/classops.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
     pretyping/tacred.cmi library/summary.cmi pretyping/reductionops.cmi \
     pretyping/rawterm.cmi lib/pp.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/library.cmi library/libobject.cmi \
-    library/libnames.cmi library/lib.cmi library/goptions.cmi lib/gmap.cmi \
+    kernel/names.cmi kernel/mod_subst.cmi library/library.cmi \
+    library/libobject.cmi library/libnames.cmi library/lib.cmi \
+    pretyping/inductiveops.cmi library/goptions.cmi lib/gmap.cmi \
     library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
     library/decl_kinds.cmo pretyping/classops.cmi 
 pretyping/classops.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
     pretyping/tacred.cmx library/summary.cmx pretyping/reductionops.cmx \
     pretyping/rawterm.cmx lib/pp.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/library.cmx library/libobject.cmx \
-    library/libnames.cmx library/lib.cmx library/goptions.cmx lib/gmap.cmx \
+    kernel/names.cmx kernel/mod_subst.cmx library/library.cmx \
+    library/libobject.cmx library/libnames.cmx library/lib.cmx \
+    pretyping/inductiveops.cmx library/goptions.cmx lib/gmap.cmx \
     library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
     library/decl_kinds.cmx pretyping/classops.cmi 
-pretyping/coercion.cmo: lib/util.cmi kernel/typeops.cmi kernel/term.cmi \
-    pretyping/retyping.cmi pretyping/reductionops.cmi pretyping/recordops.cmi \
-    pretyping/rawterm.cmi pretyping/pretype_errors.cmi kernel/names.cmi \
-    pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \
-    kernel/environ.cmi pretyping/classops.cmi pretyping/coercion.cmi 
-pretyping/coercion.cmx: lib/util.cmx kernel/typeops.cmx kernel/term.cmx \
-    pretyping/retyping.cmx pretyping/reductionops.cmx pretyping/recordops.cmx \
-    pretyping/rawterm.cmx pretyping/pretype_errors.cmx kernel/names.cmx \
-    pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \
-    kernel/environ.cmx pretyping/classops.cmx pretyping/coercion.cmi 
+pretyping/clenv.cmo: lib/util.cmi pretyping/unification.cmi \
+    pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
+    pretyping/tacred.cmi proofs/tacexpr.cmo kernel/sign.cmi \
+    pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
+    pretyping/rawterm.cmi pretyping/pretype_errors.cmi lib/pp.cmi \
+    pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
+    kernel/mod_subst.cmi library/global.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi kernel/environ.cmi pretyping/coercion.cmi \
+    pretyping/clenv.cmi 
+pretyping/clenv.cmx: lib/util.cmx pretyping/unification.cmx \
+    pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
+    pretyping/tacred.cmx proofs/tacexpr.cmx kernel/sign.cmx \
+    pretyping/retyping.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
+    pretyping/rawterm.cmx pretyping/pretype_errors.cmx lib/pp.cmx \
+    pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
+    kernel/mod_subst.cmx library/global.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx kernel/environ.cmx pretyping/coercion.cmx \
+    pretyping/clenv.cmi 
+pretyping/coercion.cmo: lib/util.cmi kernel/typeops.cmi pretyping/termops.cmi \
+    kernel/term.cmi pretyping/retyping.cmi pretyping/reductionops.cmi \
+    kernel/reduction.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \
+    pretyping/pretype_errors.cmi kernel/names.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi pretyping/evarconv.cmi kernel/environ.cmi \
+    pretyping/classops.cmi pretyping/coercion.cmi 
+pretyping/coercion.cmx: lib/util.cmx kernel/typeops.cmx pretyping/termops.cmx \
+    kernel/term.cmx pretyping/retyping.cmx pretyping/reductionops.cmx \
+    kernel/reduction.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \
+    pretyping/pretype_errors.cmx kernel/names.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx pretyping/evarconv.cmx kernel/environ.cmx \
+    pretyping/classops.cmx pretyping/coercion.cmi 
 pretyping/detyping.cmo: lib/util.cmi kernel/univ.cmi pretyping/termops.cmi \
     kernel/term.cmi kernel/sign.cmi pretyping/rawterm.cmi lib/pp.cmi \
     lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
-    library/goptions.cmi library/global.cmi kernel/environ.cmi \
-    kernel/declarations.cmi pretyping/detyping.cmi 
+    kernel/mod_subst.cmi library/libnames.cmi pretyping/inductiveops.cmi \
+    kernel/inductive.cmi library/goptions.cmi library/global.cmi \
+    pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi \
+    pretyping/detyping.cmi 
 pretyping/detyping.cmx: lib/util.cmx kernel/univ.cmx pretyping/termops.cmx \
     kernel/term.cmx kernel/sign.cmx pretyping/rawterm.cmx lib/pp.cmx \
     lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
-    library/goptions.cmx library/global.cmx kernel/environ.cmx \
-    kernel/declarations.cmx pretyping/detyping.cmi 
-pretyping/evarconv.cmo: lib/util.cmi pretyping/typing.cmi kernel/term.cmi \
-    pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \
-    kernel/names.cmi library/libnames.cmi pretyping/instantiate.cmi \
-    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \
-    kernel/closure.cmi pretyping/classops.cmi pretyping/evarconv.cmi 
-pretyping/evarconv.cmx: lib/util.cmx pretyping/typing.cmx kernel/term.cmx \
-    pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \
-    kernel/names.cmx library/libnames.cmx pretyping/instantiate.cmx \
-    pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \
-    kernel/closure.cmx pretyping/classops.cmx pretyping/evarconv.cmi 
-pretyping/evarutil.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \
-    pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
-    pretyping/reductionops.cmi pretyping/rawterm.cmi \
+    kernel/mod_subst.cmx library/libnames.cmx pretyping/inductiveops.cmx \
+    kernel/inductive.cmx library/goptions.cmx library/global.cmx \
+    pretyping/evd.cmx kernel/environ.cmx kernel/declarations.cmx \
+    pretyping/detyping.cmi 
+pretyping/evarconv.cmo: lib/util.cmi pretyping/typing.cmi \
+    pretyping/termops.cmi kernel/term.cmi pretyping/reductionops.cmi \
+    kernel/reduction.cmi pretyping/recordops.cmi lib/pp.cmi kernel/names.cmi \
+    library/libnames.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    kernel/environ.cmi kernel/closure.cmi pretyping/classops.cmi \
+    pretyping/evarconv.cmi 
+pretyping/evarconv.cmx: lib/util.cmx pretyping/typing.cmx \
+    pretyping/termops.cmx kernel/term.cmx pretyping/reductionops.cmx \
+    kernel/reduction.cmx pretyping/recordops.cmx lib/pp.cmx kernel/names.cmx \
+    library/libnames.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    kernel/environ.cmx kernel/closure.cmx pretyping/classops.cmx \
+    pretyping/evarconv.cmi 
+pretyping/evarutil.cmo: lib/util.cmi kernel/univ.cmi pretyping/typing.cmi \
+    kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
+    pretyping/reductionops.cmi kernel/reduction.cmi \
     pretyping/pretype_errors.cmi lib/pp.cmi kernel/names.cmi \
-    library/nameops.cmi pretyping/instantiate.cmi pretyping/indrec.cmi \
-    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
-    pretyping/evarutil.cmi 
-pretyping/evarutil.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
-    pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx \
-    pretyping/reductionops.cmx pretyping/rawterm.cmx \
+    library/nameops.cmi library/global.cmi pretyping/evd.cmi \
+    kernel/environ.cmi pretyping/evarutil.cmi 
+pretyping/evarutil.cmx: lib/util.cmx kernel/univ.cmx pretyping/typing.cmx \
+    kernel/typeops.cmx pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx \
+    pretyping/reductionops.cmx kernel/reduction.cmx \
     pretyping/pretype_errors.cmx lib/pp.cmx kernel/names.cmx \
-    library/nameops.cmx pretyping/instantiate.cmx pretyping/indrec.cmx \
-    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
-    pretyping/evarutil.cmi 
-pretyping/evd.cmo: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
-    kernel/names.cmi pretyping/evd.cmi 
-pretyping/evd.cmx: lib/util.cmx kernel/term.cmx kernel/sign.cmx \
-    kernel/names.cmx pretyping/evd.cmi 
+    library/nameops.cmx library/global.cmx pretyping/evd.cmx \
+    kernel/environ.cmx pretyping/evarutil.cmi 
+pretyping/evd.cmo: lib/util.cmi kernel/univ.cmi pretyping/termops.cmi \
+    kernel/term.cmi kernel/sign.cmi kernel/reduction.cmi lib/pp.cmi \
+    kernel/names.cmi library/nameops.cmi kernel/mod_subst.cmi \
+    library/libnames.cmi library/global.cmi kernel/environ.cmi lib/dyn.cmi \
+    pretyping/evd.cmi 
+pretyping/evd.cmx: lib/util.cmx kernel/univ.cmx pretyping/termops.cmx \
+    kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx lib/pp.cmx \
+    kernel/names.cmx library/nameops.cmx kernel/mod_subst.cmx \
+    library/libnames.cmx library/global.cmx kernel/environ.cmx lib/dyn.cmx \
+    pretyping/evd.cmi 
 pretyping/indrec.cmo: lib/util.cmi kernel/typeops.cmi kernel/type_errors.cmi \
-    pretyping/termops.cmi kernel/term.cmi kernel/safe_typing.cmi \
-    pretyping/reductionops.cmi kernel/reduction.cmi lib/pp.cmi \
-    lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libnames.cmi pretyping/instantiate.cmi pretyping/inductiveops.cmi \
-    kernel/inductive.cmi kernel/indtypes.cmi library/global.cmi \
-    kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \
-    pretyping/indrec.cmi 
+    pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
+    kernel/safe_typing.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
+    lib/pp.cmi lib/options.cmi library/nametab.cmi kernel/names.cmi \
+    library/nameops.cmi library/libnames.cmi pretyping/inductiveops.cmi \
+    kernel/inductive.cmi library/global.cmi kernel/environ.cmi \
+    kernel/entries.cmi kernel/declarations.cmi pretyping/indrec.cmi 
 pretyping/indrec.cmx: lib/util.cmx kernel/typeops.cmx kernel/type_errors.cmx \
-    pretyping/termops.cmx kernel/term.cmx kernel/safe_typing.cmx \
-    pretyping/reductionops.cmx kernel/reduction.cmx lib/pp.cmx \
-    lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/libnames.cmx pretyping/instantiate.cmx pretyping/inductiveops.cmx \
-    kernel/inductive.cmx kernel/indtypes.cmx library/global.cmx \
-    kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \
-    pretyping/indrec.cmi 
+    pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx \
+    kernel/safe_typing.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
+    lib/pp.cmx lib/options.cmx library/nametab.cmx kernel/names.cmx \
+    library/nameops.cmx library/libnames.cmx pretyping/inductiveops.cmx \
+    kernel/inductive.cmx library/global.cmx kernel/environ.cmx \
+    kernel/entries.cmx kernel/declarations.cmx pretyping/indrec.cmi 
 pretyping/inductiveops.cmo: lib/util.cmi kernel/univ.cmi \
     pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
-    pretyping/reductionops.cmi kernel/names.cmi kernel/inductive.cmi \
-    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
-    kernel/declarations.cmi pretyping/inductiveops.cmi 
+    pretyping/reductionops.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    kernel/inductive.cmi library/global.cmi pretyping/evd.cmi \
+    kernel/environ.cmi kernel/declarations.cmi pretyping/inductiveops.cmi 
 pretyping/inductiveops.cmx: lib/util.cmx kernel/univ.cmx \
     pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx \
-    pretyping/reductionops.cmx kernel/names.cmx kernel/inductive.cmx \
-    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
-    kernel/declarations.cmx pretyping/inductiveops.cmi 
-pretyping/instantiate.cmo: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
-    lib/pp.cmi kernel/names.cmi pretyping/evd.cmi kernel/environ.cmi \
-    kernel/declarations.cmi pretyping/instantiate.cmi 
-pretyping/instantiate.cmx: lib/util.cmx kernel/term.cmx kernel/sign.cmx \
-    lib/pp.cmx kernel/names.cmx pretyping/evd.cmx kernel/environ.cmx \
-    kernel/declarations.cmx pretyping/instantiate.cmi 
+    pretyping/reductionops.cmx kernel/names.cmx kernel/mod_subst.cmx \
+    kernel/inductive.cmx library/global.cmx pretyping/evd.cmx \
+    kernel/environ.cmx kernel/declarations.cmx pretyping/inductiveops.cmi 
 pretyping/matching.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
-    pretyping/reductionops.cmi pretyping/rawterm.cmi pretyping/pattern.cmi \
-    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
-    kernel/environ.cmi pretyping/matching.cmi 
+    kernel/sign.cmi pretyping/reductionops.cmi pretyping/rawterm.cmi \
+    pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi kernel/environ.cmi pretyping/matching.cmi 
 pretyping/matching.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
-    pretyping/reductionops.cmx pretyping/rawterm.cmx pretyping/pattern.cmx \
-    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
-    kernel/environ.cmx pretyping/matching.cmi 
+    kernel/sign.cmx pretyping/reductionops.cmx pretyping/rawterm.cmx \
+    pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx kernel/environ.cmx pretyping/matching.cmi 
 pretyping/pattern.cmo: lib/util.cmi kernel/term.cmi pretyping/rawterm.cmi \
     lib/pp.cmi lib/options.cmi library/nametab.cmi kernel/names.cmi \
-    library/nameops.cmi library/libnames.cmi kernel/environ.cmi \
+    library/nameops.cmi kernel/mod_subst.cmi library/libnames.cmi \
+    pretyping/inductiveops.cmi pretyping/evd.cmi kernel/environ.cmi \
     pretyping/pattern.cmi 
 pretyping/pattern.cmx: lib/util.cmx kernel/term.cmx pretyping/rawterm.cmx \
     lib/pp.cmx lib/options.cmx library/nametab.cmx kernel/names.cmx \
-    library/nameops.cmx library/libnames.cmx kernel/environ.cmx \
+    library/nameops.cmx kernel/mod_subst.cmx library/libnames.cmx \
+    pretyping/inductiveops.cmx pretyping/evd.cmx kernel/environ.cmx \
     pretyping/pattern.cmi 
 pretyping/pretype_errors.cmo: lib/util.cmi kernel/type_errors.cmi \
     pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
     pretyping/reductionops.cmi kernel/reduction.cmi pretyping/rawterm.cmi \
-    kernel/names.cmi pretyping/inductiveops.cmi pretyping/evd.cmi \
-    kernel/environ.cmi pretyping/pretype_errors.cmi 
+    library/nametab.cmi kernel/names.cmi pretyping/inductiveops.cmi \
+    pretyping/evd.cmi kernel/environ.cmi pretyping/pretype_errors.cmi 
 pretyping/pretype_errors.cmx: lib/util.cmx kernel/type_errors.cmx \
     pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx \
     pretyping/reductionops.cmx kernel/reduction.cmx pretyping/rawterm.cmx \
-    kernel/names.cmx pretyping/inductiveops.cmx pretyping/evd.cmx \
-    kernel/environ.cmx pretyping/pretype_errors.cmi 
+    library/nametab.cmx kernel/names.cmx pretyping/inductiveops.cmx \
+    pretyping/evd.cmx kernel/environ.cmx pretyping/pretype_errors.cmi 
 pretyping/pretyping.cmo: lib/util.cmi kernel/typeops.cmi \
     kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \
     kernel/sign.cmi pretyping/retyping.cmi pretyping/reductionops.cmi \
     pretyping/recordops.cmi pretyping/rawterm.cmi \
     pretyping/pretype_errors.cmi lib/pp.cmi pretyping/pattern.cmi \
-    lib/options.cmi kernel/names.cmi library/nameops.cmi library/libnames.cmi \
-    pretyping/instantiate.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
-    pretyping/indrec.cmi library/global.cmi pretyping/evd.cmi \
+    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
+    pretyping/inductiveops.cmi kernel/inductive.cmi pretyping/evd.cmi \
     pretyping/evarutil.cmi pretyping/evarconv.cmi kernel/environ.cmi \
-    lib/dyn.cmi pretyping/detyping.cmi kernel/declarations.cmi \
-    pretyping/coercion.cmi pretyping/classops.cmi pretyping/cases.cmi \
-    pretyping/pretyping.cmi 
+    lib/dyn.cmi kernel/declarations.cmi pretyping/coercion.cmi \
+    pretyping/classops.cmi pretyping/cases.cmi pretyping/pretyping.cmi 
 pretyping/pretyping.cmx: lib/util.cmx kernel/typeops.cmx \
     kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \
     kernel/sign.cmx pretyping/retyping.cmx pretyping/reductionops.cmx \
     pretyping/recordops.cmx pretyping/rawterm.cmx \
     pretyping/pretype_errors.cmx lib/pp.cmx pretyping/pattern.cmx \
-    lib/options.cmx kernel/names.cmx library/nameops.cmx library/libnames.cmx \
-    pretyping/instantiate.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
-    pretyping/indrec.cmx library/global.cmx pretyping/evd.cmx \
+    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
+    pretyping/inductiveops.cmx kernel/inductive.cmx pretyping/evd.cmx \
     pretyping/evarutil.cmx pretyping/evarconv.cmx kernel/environ.cmx \
-    lib/dyn.cmx pretyping/detyping.cmx kernel/declarations.cmx \
-    pretyping/coercion.cmx pretyping/classops.cmx pretyping/cases.cmx \
-    pretyping/pretyping.cmi 
+    lib/dyn.cmx kernel/declarations.cmx pretyping/coercion.cmx \
+    pretyping/classops.cmx pretyping/cases.cmx pretyping/pretyping.cmi 
 pretyping/rawterm.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
     kernel/sign.cmi library/nametab.cmi kernel/names.cmi library/libnames.cmi \
-    lib/dyn.cmi pretyping/rawterm.cmi 
+    pretyping/evd.cmi lib/dyn.cmi pretyping/rawterm.cmi 
 pretyping/rawterm.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \
     kernel/sign.cmx library/nametab.cmx kernel/names.cmx library/libnames.cmx \
-    lib/dyn.cmx pretyping/rawterm.cmi 
+    pretyping/evd.cmx lib/dyn.cmx pretyping/rawterm.cmi 
 pretyping/recordops.cmo: lib/util.cmi kernel/typeops.cmi \
-    pretyping/termops.cmi kernel/term.cmi library/summary.cmi lib/pp.cmi \
-    library/nametab.cmi kernel/names.cmi library/library.cmi \
-    library/libobject.cmi library/libnames.cmi library/lib.cmi \
+    pretyping/termops.cmi kernel/term.cmi library/summary.cmi \
+    pretyping/reductionops.cmi lib/pp.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi kernel/mod_subst.cmi \
+    library/library.cmi library/libobject.cmi library/libnames.cmi \
+    library/lib.cmi pretyping/inductiveops.cmi library/global.cmi \
+    pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi \
     pretyping/classops.cmi pretyping/recordops.cmi 
 pretyping/recordops.cmx: lib/util.cmx kernel/typeops.cmx \
-    pretyping/termops.cmx kernel/term.cmx library/summary.cmx lib/pp.cmx \
-    library/nametab.cmx kernel/names.cmx library/library.cmx \
-    library/libobject.cmx library/libnames.cmx library/lib.cmx \
+    pretyping/termops.cmx kernel/term.cmx library/summary.cmx \
+    pretyping/reductionops.cmx lib/pp.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx kernel/mod_subst.cmx \
+    library/library.cmx library/libobject.cmx library/libnames.cmx \
+    library/lib.cmx pretyping/inductiveops.cmx library/global.cmx \
+    pretyping/evd.cmx kernel/environ.cmx kernel/declarations.cmx \
     pretyping/classops.cmx pretyping/recordops.cmi 
 pretyping/reductionops.cmo: lib/util.cmi kernel/univ.cmi \
     pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
-    kernel/reduction.cmi lib/pp.cmi kernel/names.cmi \
-    pretyping/instantiate.cmi pretyping/evd.cmi kernel/esubst.cmi \
-    kernel/environ.cmi kernel/declarations.cmi kernel/closure.cmi \
-    pretyping/reductionops.cmi 
+    kernel/reduction.cmi lib/pp.cmi kernel/names.cmi pretyping/evd.cmi \
+    kernel/esubst.cmi kernel/environ.cmi kernel/declarations.cmi \
+    kernel/closure.cmi pretyping/reductionops.cmi 
 pretyping/reductionops.cmx: lib/util.cmx kernel/univ.cmx \
     pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx \
-    kernel/reduction.cmx lib/pp.cmx kernel/names.cmx \
-    pretyping/instantiate.cmx pretyping/evd.cmx kernel/esubst.cmx \
-    kernel/environ.cmx kernel/declarations.cmx kernel/closure.cmx \
-    pretyping/reductionops.cmi 
+    kernel/reduction.cmx lib/pp.cmx kernel/names.cmx pretyping/evd.cmx \
+    kernel/esubst.cmx kernel/environ.cmx kernel/declarations.cmx \
+    kernel/closure.cmx pretyping/reductionops.cmi 
 pretyping/retyping.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \
-    kernel/term.cmi pretyping/reductionops.cmi kernel/names.cmi \
-    pretyping/instantiate.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
-    kernel/environ.cmi kernel/declarations.cmi pretyping/retyping.cmi 
+    pretyping/termops.cmi kernel/term.cmi pretyping/reductionops.cmi \
+    kernel/names.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
+    pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi \
+    pretyping/retyping.cmi 
 pretyping/retyping.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
-    kernel/term.cmx pretyping/reductionops.cmx kernel/names.cmx \
-    pretyping/instantiate.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
-    kernel/environ.cmx kernel/declarations.cmx pretyping/retyping.cmi 
-pretyping/tacred.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
-    kernel/term.cmi library/summary.cmi pretyping/retyping.cmi \
-    pretyping/reductionops.cmi pretyping/rawterm.cmi lib/pp.cmi \
-    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libnames.cmi pretyping/instantiate.cmi kernel/inductive.cmi \
-    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
-    kernel/declarations.cmi kernel/conv_oracle.cmi kernel/closure.cmi \
-    pretyping/cbv.cmi pretyping/tacred.cmi 
-pretyping/tacred.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
-    kernel/term.cmx library/summary.cmx pretyping/retyping.cmx \
-    pretyping/reductionops.cmx pretyping/rawterm.cmx lib/pp.cmx \
-    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/libnames.cmx pretyping/instantiate.cmx kernel/inductive.cmx \
-    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
-    kernel/declarations.cmx kernel/conv_oracle.cmx kernel/closure.cmx \
-    pretyping/cbv.cmx pretyping/tacred.cmi 
+    pretyping/termops.cmx kernel/term.cmx pretyping/reductionops.cmx \
+    kernel/names.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
+    pretyping/evd.cmx kernel/environ.cmx kernel/declarations.cmx \
+    pretyping/retyping.cmi 
+pretyping/tacred.cmo: lib/util.cmi pretyping/typing.cmi \
+    kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \
+    library/summary.cmi pretyping/retyping.cmi pretyping/reductionops.cmi \
+    pretyping/rawterm.cmi lib/pp.cmi library/nametab.cmi kernel/names.cmi \
+    library/nameops.cmi library/libnames.cmi kernel/inductive.cmi \
+    pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi \
+    kernel/conv_oracle.cmi kernel/closure.cmi pretyping/cbv.cmi \
+    pretyping/tacred.cmi 
+pretyping/tacred.cmx: lib/util.cmx pretyping/typing.cmx \
+    kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \
+    library/summary.cmx pretyping/retyping.cmx pretyping/reductionops.cmx \
+    pretyping/rawterm.cmx lib/pp.cmx library/nametab.cmx kernel/names.cmx \
+    library/nameops.cmx library/libnames.cmx kernel/inductive.cmx \
+    pretyping/evd.cmx kernel/environ.cmx kernel/declarations.cmx \
+    kernel/conv_oracle.cmx kernel/closure.cmx pretyping/cbv.cmx \
+    pretyping/tacred.cmi 
 pretyping/termops.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
     kernel/sign.cmi lib/pp.cmi library/nametab.cmi kernel/names.cmi \
     library/nameops.cmi library/libnames.cmi library/lib.cmi \
@@ -1442,116 +1579,142 @@ pretyping/termops.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \
     library/global.cmx kernel/environ.cmx pretyping/termops.cmi 
 pretyping/typing.cmo: lib/util.cmi kernel/typeops.cmi kernel/type_errors.cmi \
     kernel/term.cmi pretyping/reductionops.cmi pretyping/pretype_errors.cmi \
-    kernel/names.cmi pretyping/instantiate.cmi kernel/inductive.cmi \
-    kernel/environ.cmi pretyping/typing.cmi 
+    kernel/names.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
+    pretyping/evd.cmi kernel/environ.cmi pretyping/typing.cmi 
 pretyping/typing.cmx: lib/util.cmx kernel/typeops.cmx kernel/type_errors.cmx \
     kernel/term.cmx pretyping/reductionops.cmx pretyping/pretype_errors.cmx \
-    kernel/names.cmx pretyping/instantiate.cmx kernel/inductive.cmx \
-    kernel/environ.cmx pretyping/typing.cmi 
-proofs/clenv.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
-    kernel/term.cmi proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi \
-    pretyping/retyping.cmi proofs/refiner.cmi pretyping/reductionops.cmi \
-    pretyping/rawterm.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
-    parsing/printer.cmi lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi \
-    library/nameops.cmi proofs/logic.cmi pretyping/instantiate.cmi \
+    kernel/names.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
+    pretyping/evd.cmx kernel/environ.cmx pretyping/typing.cmi 
+pretyping/unification.cmo: lib/util.cmi pretyping/typing.cmi \
+    pretyping/termops.cmi kernel/term.cmi kernel/sign.cmi \
+    pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
+    pretyping/rawterm.cmi pretyping/pretype_errors.cmi lib/pp.cmi \
+    pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
     library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
-    proofs/evar_refiner.cmi kernel/environ.cmi pretyping/coercion.cmi \
-    proofs/clenv.cmi 
-proofs/clenv.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
-    kernel/term.cmx proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx \
-    pretyping/retyping.cmx proofs/refiner.cmx pretyping/reductionops.cmx \
-    pretyping/rawterm.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
-    parsing/printer.cmx lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx \
-    library/nameops.cmx proofs/logic.cmx pretyping/instantiate.cmx \
+    kernel/environ.cmi pretyping/unification.cmi 
+pretyping/unification.cmx: lib/util.cmx pretyping/typing.cmx \
+    pretyping/termops.cmx kernel/term.cmx kernel/sign.cmx \
+    pretyping/retyping.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
+    pretyping/rawterm.cmx pretyping/pretype_errors.cmx lib/pp.cmx \
+    pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
     library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
-    proofs/evar_refiner.cmx kernel/environ.cmx pretyping/coercion.cmx \
-    proofs/clenv.cmi 
-proofs/evar_refiner.cmo: lib/util.cmi pretyping/typing.cmi \
-    kernel/type_errors.cmi kernel/term.cmi pretyping/tacred.cmi \
-    proofs/tacexpr.cmo kernel/sign.cmi proofs/refiner.cmi \
-    pretyping/reductionops.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
-    lib/pp.cmi lib/options.cmi kernel/names.cmi library/nameops.cmi \
-    proofs/logic.cmi pretyping/instantiate.cmi library/global.cmi \
-    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \
+    kernel/environ.cmx pretyping/unification.cmi 
+pretyping/vnorm.cmo: kernel/vm.cmi kernel/vconv.cmi lib/util.cmi \
+    kernel/typeops.cmi kernel/term.cmi kernel/reduction.cmi kernel/names.cmi \
+    kernel/inductive.cmi kernel/environ.cmi kernel/declarations.cmi \
+    pretyping/vnorm.cmi 
+pretyping/vnorm.cmx: kernel/vm.cmx kernel/vconv.cmx lib/util.cmx \
+    kernel/typeops.cmx kernel/term.cmx kernel/reduction.cmx kernel/names.cmx \
+    kernel/inductive.cmx kernel/environ.cmx kernel/declarations.cmx \
+    pretyping/vnorm.cmi 
+proofs/clenvtac.cmo: lib/util.cmi pretyping/unification.cmi \
+    pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
+    proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi proofs/refiner.cmi \
+    pretyping/reductionops.cmi kernel/reduction.cmi pretyping/rawterm.cmi \
+    proofs/proof_type.cmi proofs/proof_trees.cmi lib/pp.cmi \
+    pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
+    proofs/logic.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    proofs/evar_refiner.cmi kernel/environ.cmi pretyping/clenv.cmi \
+    proofs/clenvtac.cmi 
+proofs/clenvtac.cmx: lib/util.cmx pretyping/unification.cmx \
+    pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
+    proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx proofs/refiner.cmx \
+    pretyping/reductionops.cmx kernel/reduction.cmx pretyping/rawterm.cmx \
+    proofs/proof_type.cmx proofs/proof_trees.cmx lib/pp.cmx \
+    pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
+    proofs/logic.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    proofs/evar_refiner.cmx kernel/environ.cmx pretyping/clenv.cmx \
+    proofs/clenvtac.cmi 
+proofs/decl_mode.cmo: lib/util.cmi kernel/term.cmi proofs/refiner.cmi \
+    proofs/proof_trees.cmi proofs/pfedit.cmi kernel/names.cmi \
+    pretyping/evd.cmi lib/dyn.cmi proofs/decl_expr.cmi proofs/decl_mode.cmi 
+proofs/decl_mode.cmx: lib/util.cmx kernel/term.cmx proofs/refiner.cmx \
+    proofs/proof_trees.cmx proofs/pfedit.cmx kernel/names.cmx \
+    pretyping/evd.cmx lib/dyn.cmx proofs/decl_expr.cmi proofs/decl_mode.cmi 
+proofs/evar_refiner.cmo: lib/util.cmi kernel/term.cmi kernel/sign.cmi \
+    proofs/refiner.cmi proofs/proof_trees.cmi pretyping/pretyping.cmi \
+    kernel/names.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
     interp/constrintern.cmi proofs/evar_refiner.cmi 
-proofs/evar_refiner.cmx: lib/util.cmx pretyping/typing.cmx \
-    kernel/type_errors.cmx kernel/term.cmx pretyping/tacred.cmx \
-    proofs/tacexpr.cmx kernel/sign.cmx proofs/refiner.cmx \
-    pretyping/reductionops.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
-    lib/pp.cmx lib/options.cmx kernel/names.cmx library/nameops.cmx \
-    proofs/logic.cmx pretyping/instantiate.cmx library/global.cmx \
-    pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \
+proofs/evar_refiner.cmx: lib/util.cmx kernel/term.cmx kernel/sign.cmx \
+    proofs/refiner.cmx proofs/proof_trees.cmx pretyping/pretyping.cmx \
+    kernel/names.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
     interp/constrintern.cmx proofs/evar_refiner.cmi 
 proofs/logic.cmo: lib/util.cmi pretyping/typing.cmi kernel/typeops.cmi \
     kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \
     kernel/sign.cmi pretyping/retyping.cmi pretyping/reductionops.cmi \
-    proofs/proof_type.cmi proofs/proof_trees.cmi parsing/printer.cmi \
-    pretyping/pretype_errors.cmi lib/pp.cmi lib/options.cmi \
-    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    pretyping/inductiveops.cmi kernel/inductive.cmi kernel/indtypes.cmi \
-    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
-    kernel/environ.cmi parsing/coqast.cmi interp/constrextern.cmi \
-    proofs/logic.cmi 
+    proofs/proof_type.cmi proofs/proof_trees.cmi pretyping/pretype_errors.cmi \
+    lib/pp.cmi lib/options.cmi library/nametab.cmi kernel/names.cmi \
+    library/nameops.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
+    pretyping/indrec.cmi library/global.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi kernel/environ.cmi proofs/logic.cmi 
 proofs/logic.cmx: lib/util.cmx pretyping/typing.cmx kernel/typeops.cmx \
     kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \
     kernel/sign.cmx pretyping/retyping.cmx pretyping/reductionops.cmx \
-    proofs/proof_type.cmx proofs/proof_trees.cmx parsing/printer.cmx \
-    pretyping/pretype_errors.cmx lib/pp.cmx lib/options.cmx \
-    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    pretyping/inductiveops.cmx kernel/inductive.cmx kernel/indtypes.cmx \
-    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
-    kernel/environ.cmx parsing/coqast.cmx interp/constrextern.cmx \
-    proofs/logic.cmi 
+    proofs/proof_type.cmx proofs/proof_trees.cmx pretyping/pretype_errors.cmx \
+    lib/pp.cmx lib/options.cmx library/nametab.cmx kernel/names.cmx \
+    library/nameops.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
+    pretyping/indrec.cmx library/global.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx kernel/environ.cmx proofs/logic.cmi 
 proofs/pfedit.cmo: lib/util.cmi pretyping/typing.cmi kernel/term.cmi \
-    proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi \
-    kernel/safe_typing.cmi proofs/refiner.cmi proofs/proof_type.cmi \
-    proofs/proof_trees.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \
-    library/lib.cmi pretyping/evd.cmi proofs/evar_refiner.cmi \
-    kernel/environ.cmi kernel/entries.cmi lib/edit.cmi \
-    kernel/declarations.cmi library/decl_kinds.cmo proofs/pfedit.cmi 
+    proofs/tacexpr.cmo kernel/sign.cmi kernel/safe_typing.cmi \
+    proofs/refiner.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
+    lib/pp.cmi kernel/names.cmi library/nameops.cmi library/lib.cmi \
+    pretyping/evd.cmi proofs/evar_refiner.cmi kernel/environ.cmi \
+    kernel/entries.cmi lib/edit.cmi kernel/declarations.cmi \
+    library/decl_kinds.cmo proofs/pfedit.cmi 
 proofs/pfedit.cmx: lib/util.cmx pretyping/typing.cmx kernel/term.cmx \
-    proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx \
-    kernel/safe_typing.cmx proofs/refiner.cmx proofs/proof_type.cmx \
-    proofs/proof_trees.cmx lib/pp.cmx kernel/names.cmx library/nameops.cmx \
-    library/lib.cmx pretyping/evd.cmx proofs/evar_refiner.cmx \
-    kernel/environ.cmx kernel/entries.cmx lib/edit.cmx \
-    kernel/declarations.cmx library/decl_kinds.cmx proofs/pfedit.cmi 
+    proofs/tacexpr.cmx kernel/sign.cmx kernel/safe_typing.cmx \
+    proofs/refiner.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
+    lib/pp.cmx kernel/names.cmx library/nameops.cmx library/lib.cmx \
+    pretyping/evd.cmx proofs/evar_refiner.cmx kernel/environ.cmx \
+    kernel/entries.cmx lib/edit.cmx kernel/declarations.cmx \
+    library/decl_kinds.cmx proofs/pfedit.cmi 
 proofs/proof_trees.cmo: lib/util.cmi pretyping/typing.cmi \
     pretyping/termops.cmi kernel/term.cmi pretyping/tacred.cmi \
-    kernel/sign.cmi proofs/proof_type.cmi parsing/printer.cmi lib/pp.cmi \
-    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libnames.cmi library/global.cmi pretyping/evd.cmi \
-    pretyping/evarutil.cmi kernel/environ.cmi pretyping/detyping.cmi \
-    kernel/closure.cmi proofs/proof_trees.cmi 
+    kernel/sign.cmi proofs/proof_type.cmi lib/pp.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \
+    pretyping/detyping.cmi proofs/decl_expr.cmi kernel/closure.cmi \
+    proofs/proof_trees.cmi 
 proofs/proof_trees.cmx: lib/util.cmx pretyping/typing.cmx \
     pretyping/termops.cmx kernel/term.cmx pretyping/tacred.cmx \
-    kernel/sign.cmx proofs/proof_type.cmx parsing/printer.cmx lib/pp.cmx \
-    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/libnames.cmx library/global.cmx pretyping/evd.cmx \
-    pretyping/evarutil.cmx kernel/environ.cmx pretyping/detyping.cmx \
-    kernel/closure.cmx proofs/proof_trees.cmi 
+    kernel/sign.cmx proofs/proof_type.cmx lib/pp.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \
+    pretyping/detyping.cmx proofs/decl_expr.cmi kernel/closure.cmx \
+    proofs/proof_trees.cmi 
 proofs/proof_type.cmo: lib/util.cmi kernel/term.cmi proofs/tacexpr.cmo \
     pretyping/rawterm.cmi pretyping/pattern.cmi library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi interp/genarg.cmi pretyping/evd.cmi \
-    kernel/environ.cmi proofs/proof_type.cmi 
+    kernel/environ.cmi proofs/decl_expr.cmi proofs/proof_type.cmi 
 proofs/proof_type.cmx: lib/util.cmx kernel/term.cmx proofs/tacexpr.cmx \
     pretyping/rawterm.cmx pretyping/pattern.cmx library/nametab.cmx \
     kernel/names.cmx library/libnames.cmx interp/genarg.cmx pretyping/evd.cmx \
-    kernel/environ.cmx proofs/proof_type.cmi 
+    kernel/environ.cmx proofs/decl_expr.cmi proofs/proof_type.cmi 
+proofs/redexpr.cmo: pretyping/vnorm.cmi lib/util.cmi kernel/typeops.cmi \
+    kernel/term.cmi pretyping/tacred.cmi library/summary.cmi \
+    pretyping/reductionops.cmi pretyping/rawterm.cmi lib/pp.cmi \
+    library/nametab.cmi kernel/names.cmi library/libnames.cmi \
+    library/global.cmi kernel/environ.cmi kernel/declarations.cmi \
+    kernel/csymtable.cmi kernel/conv_oracle.cmi kernel/closure.cmi \
+    proofs/redexpr.cmi 
+proofs/redexpr.cmx: pretyping/vnorm.cmx lib/util.cmx kernel/typeops.cmx \
+    kernel/term.cmx pretyping/tacred.cmx library/summary.cmx \
+    pretyping/reductionops.cmx pretyping/rawterm.cmx lib/pp.cmx \
+    library/nametab.cmx kernel/names.cmx library/libnames.cmx \
+    library/global.cmx kernel/environ.cmx kernel/declarations.cmx \
+    kernel/csymtable.cmx kernel/conv_oracle.cmx kernel/closure.cmx \
+    proofs/redexpr.cmi 
 proofs/refiner.cmo: lib/util.cmi kernel/type_errors.cmi pretyping/termops.cmi \
     kernel/term.cmi proofs/tacexpr.cmo kernel/sign.cmi \
     pretyping/reductionops.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
-    parsing/printer.cmi translate/pptacticnew.cmi parsing/pptactic.cmi \
-    lib/pp.cmi lib/options.cmi proofs/logic.cmi pretyping/instantiate.cmi \
-    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
-    kernel/environ.cmi proofs/refiner.cmi 
+    lib/pp.cmi proofs/logic.cmi library/global.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi kernel/environ.cmi proofs/refiner.cmi 
 proofs/refiner.cmx: lib/util.cmx kernel/type_errors.cmx pretyping/termops.cmx \
     kernel/term.cmx proofs/tacexpr.cmx kernel/sign.cmx \
     pretyping/reductionops.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
-    parsing/printer.cmx translate/pptacticnew.cmx parsing/pptactic.cmx \
-    lib/pp.cmx lib/options.cmx proofs/logic.cmx pretyping/instantiate.cmx \
-    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
-    kernel/environ.cmx proofs/refiner.cmi 
+    lib/pp.cmx proofs/logic.cmx library/global.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx kernel/environ.cmx proofs/refiner.cmi 
 proofs/tacexpr.cmo: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
     pretyping/rawterm.cmi pretyping/pattern.cmi library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi interp/genarg.cmi lib/dyn.cmi \
@@ -1562,28 +1725,24 @@ proofs/tacexpr.cmx: lib/util.cmx interp/topconstr.cmx kernel/term.cmx \
     library/decl_kinds.cmx 
 proofs/tacmach.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
     kernel/term.cmi pretyping/tacred.cmi proofs/tacexpr.cmo kernel/sign.cmi \
-    proofs/refiner.cmi pretyping/reductionops.cmi pretyping/rawterm.cmi \
-    proofs/proof_type.cmi proofs/proof_trees.cmi parsing/printer.cmi \
-    lib/pp.cmi kernel/names.cmi library/nameops.cmi proofs/logic.cmi \
-    pretyping/instantiate.cmi library/global.cmi pretyping/evd.cmi \
-    kernel/environ.cmi interp/constrintern.cmi proofs/tacmach.cmi 
+    pretyping/retyping.cmi proofs/refiner.cmi pretyping/reductionops.cmi \
+    proofs/redexpr.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
+    proofs/proof_trees.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \
+    proofs/logic.cmi library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    interp/constrintern.cmi proofs/tacmach.cmi 
 proofs/tacmach.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
     kernel/term.cmx pretyping/tacred.cmx proofs/tacexpr.cmx kernel/sign.cmx \
-    proofs/refiner.cmx pretyping/reductionops.cmx pretyping/rawterm.cmx \
-    proofs/proof_type.cmx proofs/proof_trees.cmx parsing/printer.cmx \
-    lib/pp.cmx kernel/names.cmx library/nameops.cmx proofs/logic.cmx \
-    pretyping/instantiate.cmx library/global.cmx pretyping/evd.cmx \
-    kernel/environ.cmx interp/constrintern.cmx proofs/tacmach.cmi 
-proofs/tactic_debug.cmo: pretyping/termops.cmi proofs/tacmach.cmi \
-    proofs/tacexpr.cmo proofs/proof_trees.cmi parsing/printer.cmi \
-    translate/pptacticnew.cmi parsing/pptactic.cmi lib/pp.cmi lib/options.cmi \
-    kernel/names.cmi proofs/logic.cmi library/global.cmi \
-    interp/constrextern.cmi parsing/ast.cmi proofs/tactic_debug.cmi 
-proofs/tactic_debug.cmx: pretyping/termops.cmx proofs/tacmach.cmx \
-    proofs/tacexpr.cmx proofs/proof_trees.cmx parsing/printer.cmx \
-    translate/pptacticnew.cmx parsing/pptactic.cmx lib/pp.cmx lib/options.cmx \
-    kernel/names.cmx proofs/logic.cmx library/global.cmx \
-    interp/constrextern.cmx parsing/ast.cmx proofs/tactic_debug.cmi 
+    pretyping/retyping.cmx proofs/refiner.cmx pretyping/reductionops.cmx \
+    proofs/redexpr.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
+    proofs/proof_trees.cmx lib/pp.cmx kernel/names.cmx library/nameops.cmx \
+    proofs/logic.cmx library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    interp/constrintern.cmx proofs/tacmach.cmi 
+proofs/tactic_debug.cmo: pretyping/termops.cmi proofs/tacexpr.cmo \
+    proofs/refiner.cmi proofs/proof_trees.cmi lib/pp.cmi kernel/names.cmi \
+    proofs/logic.cmi interp/constrextern.cmi proofs/tactic_debug.cmi 
+proofs/tactic_debug.cmx: pretyping/termops.cmx proofs/tacexpr.cmx \
+    proofs/refiner.cmx proofs/proof_trees.cmx lib/pp.cmx kernel/names.cmx \
+    proofs/logic.cmx interp/constrextern.cmx proofs/tactic_debug.cmi 
 scripts/coqc.cmo: toplevel/usage.cmi config/coq_config.cmi 
 scripts/coqc.cmx: toplevel/usage.cmx config/coq_config.cmx 
 scripts/coqmktop.cmo: scripts/tolink.cmo config/coq_config.cmi 
@@ -1593,55 +1752,103 @@ tactics/auto.cmo: toplevel/vernacexpr.cmo lib/util.cmi pretyping/typing.cmi \
     tactics/tacticals.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
     proofs/tacexpr.cmo library/summary.cmi kernel/sign.cmi proofs/refiner.cmi \
     kernel/reduction.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
-    parsing/printer.cmi translate/pptacticnew.cmi parsing/pptactic.cmi \
-    lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi lib/options.cmi \
-    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    parsing/printer.cmi parsing/pptactic.cmi lib/pp.cmi proofs/pfedit.cmi \
+    pretyping/pattern.cmi lib/options.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi kernel/mod_subst.cmi \
     pretyping/matching.cmi proofs/logic.cmi library/library.cmi \
     library/libobject.cmi library/libnames.cmi library/lib.cmi \
     kernel/inductive.cmi tactics/hipattern.cmi tactics/hiddentac.cmi \
-    library/global.cmi interp/genarg.cmi pretyping/evd.cmi \
-    proofs/evar_refiner.cmi tactics/dhyp.cmi kernel/declarations.cmi \
-    interp/constrintern.cmi proofs/clenv.cmi tactics/btermdn.cmi \
+    lib/gmap.cmi library/global.cmi pretyping/evd.cmi proofs/evar_refiner.cmi \
+    kernel/environ.cmi tactics/dhyp.cmi kernel/declarations.cmi \
+    interp/constrintern.cmi pretyping/clenv.cmi tactics/btermdn.cmi \
     tactics/auto.cmi 
 tactics/auto.cmx: toplevel/vernacexpr.cmx lib/util.cmx pretyping/typing.cmx \
     pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
     tactics/tacticals.cmx pretyping/tacred.cmx proofs/tacmach.cmx \
     proofs/tacexpr.cmx library/summary.cmx kernel/sign.cmx proofs/refiner.cmx \
     kernel/reduction.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
-    parsing/printer.cmx translate/pptacticnew.cmx parsing/pptactic.cmx \
-    lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx lib/options.cmx \
-    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    parsing/printer.cmx parsing/pptactic.cmx lib/pp.cmx proofs/pfedit.cmx \
+    pretyping/pattern.cmx lib/options.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx kernel/mod_subst.cmx \
     pretyping/matching.cmx proofs/logic.cmx library/library.cmx \
     library/libobject.cmx library/libnames.cmx library/lib.cmx \
     kernel/inductive.cmx tactics/hipattern.cmx tactics/hiddentac.cmx \
-    library/global.cmx interp/genarg.cmx pretyping/evd.cmx \
-    proofs/evar_refiner.cmx tactics/dhyp.cmx kernel/declarations.cmx \
-    interp/constrintern.cmx proofs/clenv.cmx tactics/btermdn.cmx \
+    lib/gmap.cmx library/global.cmx pretyping/evd.cmx proofs/evar_refiner.cmx \
+    kernel/environ.cmx tactics/dhyp.cmx kernel/declarations.cmx \
+    interp/constrintern.cmx pretyping/clenv.cmx tactics/btermdn.cmx \
     tactics/auto.cmi 
 tactics/autorewrite.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
-    kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
-    tactics/tacinterp.cmi proofs/tacexpr.cmo library/summary.cmi \
-    proofs/proof_type.cmi lib/pp.cmi kernel/names.cmi library/libobject.cmi \
-    library/lib.cmi tactics/hipattern.cmi tactics/equality.cmi \
-    parsing/coqast.cmi parsing/ast.cmi tactics/autorewrite.cmi 
+    pretyping/typing.cmi kernel/term.cmi tactics/tactics.cmi \
+    tactics/tacticals.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
+    proofs/tacexpr.cmo library/summary.cmi proofs/refiner.cmi \
+    proofs/proof_type.cmi parsing/printer.cmi parsing/pptactic.cmi lib/pp.cmi \
+    kernel/names.cmi kernel/mod_subst.cmi library/libobject.cmi \
+    library/lib.cmi tactics/hipattern.cmi library/global.cmi \
+    pretyping/evd.cmi tactics/equality.cmi kernel/environ.cmi \
+    tactics/autorewrite.cmi 
 tactics/autorewrite.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
-    kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
-    tactics/tacinterp.cmx proofs/tacexpr.cmx library/summary.cmx \
-    proofs/proof_type.cmx lib/pp.cmx kernel/names.cmx library/libobject.cmx \
-    library/lib.cmx tactics/hipattern.cmx tactics/equality.cmx \
-    parsing/coqast.cmx parsing/ast.cmx tactics/autorewrite.cmi 
+    pretyping/typing.cmx kernel/term.cmx tactics/tactics.cmx \
+    tactics/tacticals.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
+    proofs/tacexpr.cmx library/summary.cmx proofs/refiner.cmx \
+    proofs/proof_type.cmx parsing/printer.cmx parsing/pptactic.cmx lib/pp.cmx \
+    kernel/names.cmx kernel/mod_subst.cmx library/libobject.cmx \
+    library/lib.cmx tactics/hipattern.cmx library/global.cmx \
+    pretyping/evd.cmx tactics/equality.cmx kernel/environ.cmx \
+    tactics/autorewrite.cmi 
 tactics/btermdn.cmo: tactics/termdn.cmi kernel/term.cmi pretyping/pattern.cmi \
-    tactics/dn.cmi tactics/btermdn.cmi 
+    library/libnames.cmi tactics/dn.cmi tactics/btermdn.cmi 
 tactics/btermdn.cmx: tactics/termdn.cmx kernel/term.cmx pretyping/pattern.cmx \
-    tactics/dn.cmx tactics/btermdn.cmi 
+    library/libnames.cmx tactics/dn.cmx tactics/btermdn.cmi 
 tactics/contradiction.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \
-    tactics/tacticals.cmi proofs/tacmach.cmi pretyping/reductionops.cmi \
-    pretyping/rawterm.cmi proofs/proof_type.cmi tactics/hipattern.cmi \
-    interp/coqlib.cmi tactics/contradiction.cmi 
+    tactics/tacticals.cmi proofs/tacmach.cmi pretyping/retyping.cmi \
+    pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
+    tactics/hipattern.cmi pretyping/evd.cmi kernel/environ.cmi \
+    interp/coqlib.cmi pretyping/coercion.cmi tactics/contradiction.cmi 
 tactics/contradiction.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \
-    tactics/tacticals.cmx proofs/tacmach.cmx pretyping/reductionops.cmx \
-    pretyping/rawterm.cmx proofs/proof_type.cmx tactics/hipattern.cmx \
-    interp/coqlib.cmx tactics/contradiction.cmi 
+    tactics/tacticals.cmx proofs/tacmach.cmx pretyping/retyping.cmx \
+    pretyping/reductionops.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
+    tactics/hipattern.cmx pretyping/evd.cmx kernel/environ.cmx \
+    interp/coqlib.cmx pretyping/coercion.cmx tactics/contradiction.cmi 
+tactics/decl_interp.cmo: lib/util.cmi interp/topconstr.cmi \
+    pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi \
+    tactics/tacinterp.cmi pretyping/rawterm.cmi pretyping/pretyping.cmi \
+    lib/pp.cmi kernel/names.cmi library/nameops.cmi library/libnames.cmi \
+    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    pretyping/detyping.cmi kernel/declarations.cmi proofs/decl_mode.cmi \
+    proofs/decl_expr.cmi interp/coqlib.cmi interp/constrintern.cmi \
+    kernel/closure.cmi tactics/decl_interp.cmi 
+tactics/decl_interp.cmx: lib/util.cmx interp/topconstr.cmx \
+    pretyping/termops.cmx kernel/term.cmx proofs/tacmach.cmx \
+    tactics/tacinterp.cmx pretyping/rawterm.cmx pretyping/pretyping.cmx \
+    lib/pp.cmx kernel/names.cmx library/nameops.cmx library/libnames.cmx \
+    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    pretyping/detyping.cmx kernel/declarations.cmx proofs/decl_mode.cmx \
+    proofs/decl_expr.cmi interp/coqlib.cmx interp/constrintern.cmx \
+    kernel/closure.cmx tactics/decl_interp.cmi 
+tactics/decl_proof_instr.cmo: lib/util.cmi pretyping/unification.cmi \
+    kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \
+    tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
+    tactics/tacinterp.cmi proofs/tacexpr.cmo proofs/refiner.cmi \
+    pretyping/reductionops.cmi kernel/reduction.cmi pretyping/rawterm.cmi \
+    proofs/proof_type.cmi proofs/proof_trees.cmi parsing/printer.cmi \
+    lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
+    library/goptions.cmi library/global.cmi interp/genarg.cmi \
+    pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi \
+    proofs/decl_mode.cmi tactics/decl_interp.cmi proofs/decl_expr.cmi \
+    interp/coqlib.cmi kernel/closure.cmi tactics/decl_proof_instr.cmi 
+tactics/decl_proof_instr.cmx: lib/util.cmx pretyping/unification.cmx \
+    kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \
+    tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \
+    tactics/tacinterp.cmx proofs/tacexpr.cmx proofs/refiner.cmx \
+    pretyping/reductionops.cmx kernel/reduction.cmx pretyping/rawterm.cmx \
+    proofs/proof_type.cmx proofs/proof_trees.cmx parsing/printer.cmx \
+    lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
+    library/goptions.cmx library/global.cmx interp/genarg.cmx \
+    pretyping/evd.cmx kernel/environ.cmx kernel/declarations.cmx \
+    proofs/decl_mode.cmx tactics/decl_interp.cmx proofs/decl_expr.cmi \
+    interp/coqlib.cmx kernel/closure.cmx tactics/decl_proof_instr.cmi 
 tactics/dhyp.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \
     tactics/tacticals.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
     library/summary.cmi proofs/refiner.cmi kernel/reduction.cmi \
@@ -1649,8 +1856,8 @@ tactics/dhyp.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \
     pretyping/pattern.cmi tactics/nbtermdn.cmi kernel/names.cmi \
     pretyping/matching.cmi library/library.cmi library/libobject.cmi \
     library/libnames.cmi library/lib.cmi library/global.cmi pretyping/evd.cmi \
-    kernel/environ.cmi interp/constrintern.cmi proofs/clenv.cmi \
-    parsing/ast.cmi tactics/dhyp.cmi 
+    kernel/environ.cmi interp/constrintern.cmi pretyping/clenv.cmi \
+    tactics/dhyp.cmi 
 tactics/dhyp.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \
     tactics/tacticals.cmx proofs/tacmach.cmx proofs/tacexpr.cmx \
     library/summary.cmx proofs/refiner.cmx kernel/reduction.cmx \
@@ -1658,8 +1865,8 @@ tactics/dhyp.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \
     pretyping/pattern.cmx tactics/nbtermdn.cmx kernel/names.cmx \
     pretyping/matching.cmx library/library.cmx library/libobject.cmx \
     library/libnames.cmx library/lib.cmx library/global.cmx pretyping/evd.cmx \
-    kernel/environ.cmx interp/constrintern.cmx proofs/clenv.cmx \
-    parsing/ast.cmx tactics/dhyp.cmi 
+    kernel/environ.cmx interp/constrintern.cmx pretyping/clenv.cmx \
+    tactics/dhyp.cmi 
 tactics/dn.cmo: lib/tlm.cmi tactics/dn.cmi 
 tactics/dn.cmx: lib/tlm.cmx tactics/dn.cmi 
 tactics/eauto.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
@@ -1667,55 +1874,57 @@ tactics/eauto.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
     tactics/tacinterp.cmi proofs/tacexpr.cmo kernel/sign.cmi \
     proofs/refiner.cmi kernel/reduction.cmi pretyping/rawterm.cmi \
     proofs/proof_type.cmi proofs/proof_trees.cmi parsing/pptactic.cmi \
-    lib/pp.cmi parsing/pcoq.cmi pretyping/pattern.cmi lib/options.cmi \
-    kernel/names.cmi library/nameops.cmi proofs/logic.cmi library/global.cmi \
-    interp/genarg.cmi parsing/extend.cmi lib/explore.cmi \
-    proofs/evar_refiner.cmi parsing/egrammar.cmi kernel/declarations.cmi \
-    proofs/clenv.cmi toplevel/cerrors.cmi tactics/auto.cmi tactics/eauto.cmi 
+    lib/pp.cmi parsing/pcoq.cmi pretyping/pattern.cmi kernel/names.cmi \
+    library/nameops.cmi proofs/logic.cmi parsing/lexer.cmi library/global.cmi \
+    interp/genarg.cmi lib/explore.cmi proofs/evar_refiner.cmi \
+    parsing/egrammar.cmi kernel/declarations.cmi proofs/clenvtac.cmi \
+    pretyping/clenv.cmi toplevel/cerrors.cmi tactics/auto.cmi \
+    tactics/eauto.cmi 
 tactics/eauto.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
     tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \
     tactics/tacinterp.cmx proofs/tacexpr.cmx kernel/sign.cmx \
     proofs/refiner.cmx kernel/reduction.cmx pretyping/rawterm.cmx \
     proofs/proof_type.cmx proofs/proof_trees.cmx parsing/pptactic.cmx \
-    lib/pp.cmx parsing/pcoq.cmx pretyping/pattern.cmx lib/options.cmx \
-    kernel/names.cmx library/nameops.cmx proofs/logic.cmx library/global.cmx \
-    interp/genarg.cmx parsing/extend.cmx lib/explore.cmx \
-    proofs/evar_refiner.cmx parsing/egrammar.cmx kernel/declarations.cmx \
-    proofs/clenv.cmx toplevel/cerrors.cmx tactics/auto.cmx tactics/eauto.cmi 
+    lib/pp.cmx parsing/pcoq.cmx pretyping/pattern.cmx kernel/names.cmx \
+    library/nameops.cmx proofs/logic.cmx parsing/lexer.cmx library/global.cmx \
+    interp/genarg.cmx lib/explore.cmx proofs/evar_refiner.cmx \
+    parsing/egrammar.cmx kernel/declarations.cmx proofs/clenvtac.cmx \
+    pretyping/clenv.cmx toplevel/cerrors.cmx tactics/auto.cmx \
+    tactics/eauto.cmi 
 tactics/elim.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
     tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
     proofs/tacexpr.cmo proofs/refiner.cmi kernel/reduction.cmi \
     proofs/proof_type.cmi parsing/printer.cmi lib/pp.cmi kernel/names.cmi \
     library/libnames.cmi pretyping/inductiveops.cmi tactics/hipattern.cmi \
     tactics/hiddentac.cmi interp/genarg.cmi kernel/environ.cmi \
-    proofs/clenv.cmi tactics/elim.cmi 
+    pretyping/clenv.cmi tactics/elim.cmi 
 tactics/elim.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
     tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \
     proofs/tacexpr.cmx proofs/refiner.cmx kernel/reduction.cmx \
     proofs/proof_type.cmx parsing/printer.cmx lib/pp.cmx kernel/names.cmx \
     library/libnames.cmx pretyping/inductiveops.cmx tactics/hipattern.cmx \
     tactics/hiddentac.cmx interp/genarg.cmx kernel/environ.cmx \
-    proofs/clenv.cmx tactics/elim.cmi 
+    pretyping/clenv.cmx tactics/elim.cmi 
 tactics/eqdecide.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \
     tactics/tacticals.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
     proofs/tacexpr.cmo proofs/refiner.cmi pretyping/rawterm.cmi \
     proofs/proof_type.cmi proofs/proof_trees.cmi parsing/pptactic.cmi \
-    lib/pp.cmi parsing/pcoq.cmi pretyping/pattern.cmi lib/options.cmi \
-    kernel/names.cmi library/nameops.cmi pretyping/matching.cmi \
-    tactics/hipattern.cmi tactics/hiddentac.cmi library/global.cmi \
-    interp/genarg.cmi tactics/extratactics.cmi tactics/equality.cmi \
-    parsing/egrammar.cmi kernel/declarations.cmi interp/coqlib.cmi \
-    toplevel/cerrors.cmi tactics/auto.cmi 
+    lib/pp.cmi parsing/pcoq.cmi pretyping/pattern.cmi kernel/names.cmi \
+    library/nameops.cmi pretyping/matching.cmi tactics/hipattern.cmi \
+    tactics/hiddentac.cmi library/global.cmi interp/genarg.cmi \
+    tactics/extratactics.cmi tactics/equality.cmi parsing/egrammar.cmi \
+    kernel/declarations.cmi interp/coqlib.cmi toplevel/cerrors.cmi \
+    tactics/auto.cmi 
 tactics/eqdecide.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \
     tactics/tacticals.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
     proofs/tacexpr.cmx proofs/refiner.cmx pretyping/rawterm.cmx \
     proofs/proof_type.cmx proofs/proof_trees.cmx parsing/pptactic.cmx \
-    lib/pp.cmx parsing/pcoq.cmx pretyping/pattern.cmx lib/options.cmx \
-    kernel/names.cmx library/nameops.cmx pretyping/matching.cmx \
-    tactics/hipattern.cmx tactics/hiddentac.cmx library/global.cmx \
-    interp/genarg.cmx tactics/extratactics.cmx tactics/equality.cmx \
-    parsing/egrammar.cmx kernel/declarations.cmx interp/coqlib.cmx \
-    toplevel/cerrors.cmx tactics/auto.cmx 
+    lib/pp.cmx parsing/pcoq.cmx pretyping/pattern.cmx kernel/names.cmx \
+    library/nameops.cmx pretyping/matching.cmx tactics/hipattern.cmx \
+    tactics/hiddentac.cmx library/global.cmx interp/genarg.cmx \
+    tactics/extratactics.cmx tactics/equality.cmx parsing/egrammar.cmx \
+    kernel/declarations.cmx interp/coqlib.cmx toplevel/cerrors.cmx \
+    tactics/auto.cmx 
 tactics/equality.cmo: toplevel/vernacexpr.cmo lib/util.cmi kernel/univ.cmi \
     pretyping/typing.cmi kernel/typeops.cmi pretyping/termops.cmi \
     kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
@@ -1724,11 +1933,10 @@ tactics/equality.cmo: toplevel/vernacexpr.cmo lib/util.cmi kernel/univ.cmi \
     pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
     lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
     pretyping/matching.cmi proofs/logic.cmi library/libnames.cmi \
-    pretyping/instantiate.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
-    pretyping/indrec.cmi tactics/hipattern.cmi pretyping/evarutil.cmi \
+    pretyping/inductiveops.cmi kernel/inductive.cmi pretyping/indrec.cmi \
+    tactics/hipattern.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
     pretyping/evarconv.cmi proofs/evar_refiner.cmi kernel/environ.cmi \
-    kernel/declarations.cmi interp/coqlib.cmi proofs/clenv.cmi \
-    tactics/equality.cmi 
+    kernel/declarations.cmi interp/coqlib.cmi tactics/equality.cmi 
 tactics/equality.cmx: toplevel/vernacexpr.cmx lib/util.cmx kernel/univ.cmx \
     pretyping/typing.cmx kernel/typeops.cmx pretyping/termops.cmx \
     kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
@@ -1737,229 +1945,268 @@ tactics/equality.cmx: toplevel/vernacexpr.cmx lib/util.cmx kernel/univ.cmx \
     pretyping/reductionops.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
     lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
     pretyping/matching.cmx proofs/logic.cmx library/libnames.cmx \
-    pretyping/instantiate.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
-    pretyping/indrec.cmx tactics/hipattern.cmx pretyping/evarutil.cmx \
+    pretyping/inductiveops.cmx kernel/inductive.cmx pretyping/indrec.cmx \
+    tactics/hipattern.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
     pretyping/evarconv.cmx proofs/evar_refiner.cmx kernel/environ.cmx \
-    kernel/declarations.cmx interp/coqlib.cmx proofs/clenv.cmx \
-    tactics/equality.cmi 
-tactics/extraargs.cmo: tactics/tacinterp.cmi parsing/pptactic.cmi lib/pp.cmi \
-    parsing/pcoq.cmi toplevel/metasyntax.cmi interp/genarg.cmi \
-    parsing/extend.cmi tactics/extraargs.cmi 
-tactics/extraargs.cmx: tactics/tacinterp.cmx parsing/pptactic.cmx lib/pp.cmx \
-    parsing/pcoq.cmx toplevel/metasyntax.cmx interp/genarg.cmx \
-    parsing/extend.cmx tactics/extraargs.cmi 
+    kernel/declarations.cmx interp/coqlib.cmx tactics/equality.cmi 
+tactics/evar_tactics.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
+    tactics/tactics.cmi proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi \
+    proofs/refiner.cmi proofs/proof_type.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi proofs/evar_refiner.cmi kernel/environ.cmi \
+    tactics/evar_tactics.cmi 
+tactics/evar_tactics.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
+    tactics/tactics.cmx proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx \
+    proofs/refiner.cmx proofs/proof_type.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx proofs/evar_refiner.cmx kernel/environ.cmx \
+    tactics/evar_tactics.cmi 
+tactics/extraargs.cmo: lib/util.cmi tactics/tacticals.cmi \
+    tactics/tacinterp.cmi proofs/tacexpr.cmo tactics/setoid_replace.cmi \
+    parsing/printer.cmi parsing/pptactic.cmi interp/ppextend.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi \
+    library/nameops.cmi toplevel/metasyntax.cmi parsing/lexer.cmi \
+    interp/genarg.cmi tactics/extraargs.cmi 
+tactics/extraargs.cmx: lib/util.cmx tactics/tacticals.cmx \
+    tactics/tacinterp.cmx proofs/tacexpr.cmx tactics/setoid_replace.cmx \
+    parsing/printer.cmx parsing/pptactic.cmx interp/ppextend.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \
+    library/nameops.cmx toplevel/metasyntax.cmx parsing/lexer.cmx \
+    interp/genarg.cmx tactics/extraargs.cmi 
 tactics/extratactics.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
     kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
     tactics/tacinterp.cmi proofs/tacexpr.cmo library/summary.cmi \
     tactics/setoid_replace.cmi proofs/refiner.cmi tactics/refine.cmi \
     pretyping/rawterm.cmi parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi \
-    lib/options.cmi library/nametab.cmi library/libobject.cmi \
+    kernel/names.cmi kernel/mod_subst.cmi library/libobject.cmi \
     library/libnames.cmi library/lib.cmi tactics/leminv.cmi tactics/inv.cmi \
     library/global.cmi interp/genarg.cmi tactics/extraargs.cmi \
-    pretyping/evd.cmi tactics/equality.cmi parsing/egrammar.cmi \
-    tactics/contradiction.cmi interp/constrintern.cmi toplevel/cerrors.cmi \
-    tactics/autorewrite.cmi tactics/extratactics.cmi 
+    pretyping/evd.cmi tactics/evar_tactics.cmi tactics/equality.cmi \
+    parsing/egrammar.cmi tactics/contradiction.cmi interp/constrintern.cmi \
+    toplevel/cerrors.cmi tactics/autorewrite.cmi tactics/extratactics.cmi 
 tactics/extratactics.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
     kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
     tactics/tacinterp.cmx proofs/tacexpr.cmx library/summary.cmx \
     tactics/setoid_replace.cmx proofs/refiner.cmx tactics/refine.cmx \
     pretyping/rawterm.cmx parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx \
-    lib/options.cmx library/nametab.cmx library/libobject.cmx \
+    kernel/names.cmx kernel/mod_subst.cmx library/libobject.cmx \
     library/libnames.cmx library/lib.cmx tactics/leminv.cmx tactics/inv.cmx \
     library/global.cmx interp/genarg.cmx tactics/extraargs.cmx \
-    pretyping/evd.cmx tactics/equality.cmx parsing/egrammar.cmx \
-    tactics/contradiction.cmx interp/constrintern.cmx toplevel/cerrors.cmx \
-    tactics/autorewrite.cmx tactics/extratactics.cmi 
+    pretyping/evd.cmx tactics/evar_tactics.cmx tactics/equality.cmx \
+    parsing/egrammar.cmx tactics/contradiction.cmx interp/constrintern.cmx \
+    toplevel/cerrors.cmx tactics/autorewrite.cmx tactics/extratactics.cmi 
 tactics/hiddentac.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \
     proofs/tacmach.cmi proofs/tacexpr.cmo proofs/refiner.cmi \
-    pretyping/rawterm.cmi proofs/proof_type.cmi interp/genarg.cmi \
-    proofs/evar_refiner.cmi tactics/hiddentac.cmi 
+    proofs/redexpr.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
+    interp/genarg.cmi tactics/evar_tactics.cmi tactics/hiddentac.cmi 
 tactics/hiddentac.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \
     proofs/tacmach.cmx proofs/tacexpr.cmx proofs/refiner.cmx \
-    pretyping/rawterm.cmx proofs/proof_type.cmx interp/genarg.cmx \
-    proofs/evar_refiner.cmx tactics/hiddentac.cmi 
+    proofs/redexpr.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
+    interp/genarg.cmx tactics/evar_tactics.cmx tactics/hiddentac.cmi 
 tactics/hipattern.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
     tactics/tacticals.cmi proofs/tacmach.cmi pretyping/reductionops.cmi \
-    proofs/proof_trees.cmi lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi \
-    library/nameops.cmi pretyping/matching.cmi pretyping/inductiveops.cmi \
+    pretyping/rawterm.cmi proofs/proof_trees.cmi lib/pp.cmi \
+    pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
+    pretyping/matching.cmi library/libnames.cmi pretyping/inductiveops.cmi \
     library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
-    kernel/declarations.cmi interp/coqlib.cmi proofs/clenv.cmi \
+    kernel/declarations.cmi interp/coqlib.cmi pretyping/clenv.cmi \
     tactics/hipattern.cmi 
 tactics/hipattern.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
     tactics/tacticals.cmx proofs/tacmach.cmx pretyping/reductionops.cmx \
-    proofs/proof_trees.cmx lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx \
-    library/nameops.cmx pretyping/matching.cmx pretyping/inductiveops.cmx \
+    pretyping/rawterm.cmx proofs/proof_trees.cmx lib/pp.cmx \
+    pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
+    pretyping/matching.cmx library/libnames.cmx pretyping/inductiveops.cmx \
     library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
-    kernel/declarations.cmx interp/coqlib.cmx proofs/clenv.cmx \
+    kernel/declarations.cmx interp/coqlib.cmx pretyping/clenv.cmx \
     tactics/hipattern.cmi 
-tactics/inv.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
-    kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
-    proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi \
-    pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
-    pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
-    lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
-    pretyping/matching.cmi pretyping/inductiveops.cmi tactics/hipattern.cmi \
-    library/global.cmi interp/genarg.cmi proofs/evar_refiner.cmi \
+tactics/inv.cmo: lib/util.cmi pretyping/unification.cmi pretyping/typing.cmi \
+    pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
+    tactics/tacticals.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
+    kernel/sign.cmi pretyping/retyping.cmi pretyping/reductionops.cmi \
+    kernel/reduction.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
+    parsing/printer.cmi lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi \
+    library/nameops.cmi pretyping/matching.cmi pretyping/inductiveops.cmi \
+    tactics/hipattern.cmi library/global.cmi interp/genarg.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi proofs/evar_refiner.cmi \
     tactics/equality.cmi kernel/environ.cmi tactics/elim.cmi \
-    interp/coqlib.cmi proofs/clenv.cmi tactics/inv.cmi 
-tactics/inv.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
-    kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
-    proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx \
-    pretyping/retyping.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
-    pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
-    lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
-    pretyping/matching.cmx pretyping/inductiveops.cmx tactics/hipattern.cmx \
-    library/global.cmx interp/genarg.cmx proofs/evar_refiner.cmx \
+    interp/coqlib.cmi pretyping/clenv.cmi tactics/inv.cmi 
+tactics/inv.cmx: lib/util.cmx pretyping/unification.cmx pretyping/typing.cmx \
+    pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
+    tactics/tacticals.cmx proofs/tacmach.cmx proofs/tacexpr.cmx \
+    kernel/sign.cmx pretyping/retyping.cmx pretyping/reductionops.cmx \
+    kernel/reduction.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
+    parsing/printer.cmx lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx \
+    library/nameops.cmx pretyping/matching.cmx pretyping/inductiveops.cmx \
+    tactics/hipattern.cmx library/global.cmx interp/genarg.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx proofs/evar_refiner.cmx \
     tactics/equality.cmx kernel/environ.cmx tactics/elim.cmx \
-    interp/coqlib.cmx proofs/clenv.cmx tactics/inv.cmi 
+    interp/coqlib.cmx pretyping/clenv.cmx tactics/inv.cmi 
 tactics/leminv.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
     pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
     tactics/tacticals.cmi proofs/tacmach.cmi kernel/sign.cmi \
     kernel/safe_typing.cmi pretyping/reductionops.cmi proofs/proof_type.cmi \
     proofs/proof_trees.cmi parsing/printer.cmi pretyping/pretyping.cmi \
-    lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi library/nameops.cmi \
-    tactics/inv.cmi pretyping/inductiveops.cmi library/global.cmi \
-    pretyping/evd.cmi proofs/evar_refiner.cmi kernel/environ.cmi \
-    kernel/entries.cmi library/declare.cmi kernel/declarations.cmi \
-    library/decl_kinds.cmo interp/constrintern.cmi proofs/clenv.cmi \
+    pretyping/pretype_errors.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \
+    kernel/names.cmi library/nameops.cmi tactics/inv.cmi \
+    pretyping/inductiveops.cmi library/global.cmi pretyping/evd.cmi \
+    proofs/evar_refiner.cmi kernel/environ.cmi kernel/entries.cmi \
+    library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \
+    interp/constrintern.cmi proofs/clenvtac.cmi pretyping/clenv.cmi \
     tactics/leminv.cmi 
 tactics/leminv.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
     pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
     tactics/tacticals.cmx proofs/tacmach.cmx kernel/sign.cmx \
     kernel/safe_typing.cmx pretyping/reductionops.cmx proofs/proof_type.cmx \
     proofs/proof_trees.cmx parsing/printer.cmx pretyping/pretyping.cmx \
-    lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx library/nameops.cmx \
-    tactics/inv.cmx pretyping/inductiveops.cmx library/global.cmx \
-    pretyping/evd.cmx proofs/evar_refiner.cmx kernel/environ.cmx \
-    kernel/entries.cmx library/declare.cmx kernel/declarations.cmx \
-    library/decl_kinds.cmx interp/constrintern.cmx proofs/clenv.cmx \
+    pretyping/pretype_errors.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \
+    kernel/names.cmx library/nameops.cmx tactics/inv.cmx \
+    pretyping/inductiveops.cmx library/global.cmx pretyping/evd.cmx \
+    proofs/evar_refiner.cmx kernel/environ.cmx kernel/entries.cmx \
+    library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \
+    interp/constrintern.cmx proofs/clenvtac.cmx pretyping/clenv.cmx \
     tactics/leminv.cmi 
 tactics/nbtermdn.cmo: lib/util.cmi tactics/termdn.cmi kernel/term.cmi \
     pretyping/pattern.cmi kernel/names.cmi library/library.cmi \
-    library/libobject.cmi lib/gmap.cmi tactics/btermdn.cmi \
-    tactics/nbtermdn.cmi 
+    library/libobject.cmi library/libnames.cmi lib/gmap.cmi \
+    tactics/btermdn.cmi tactics/nbtermdn.cmi 
 tactics/nbtermdn.cmx: lib/util.cmx tactics/termdn.cmx kernel/term.cmx \
     pretyping/pattern.cmx kernel/names.cmx library/library.cmx \
-    library/libobject.cmx lib/gmap.cmx tactics/btermdn.cmx \
-    tactics/nbtermdn.cmi 
+    library/libobject.cmx library/libnames.cmx lib/gmap.cmx \
+    tactics/btermdn.cmx tactics/nbtermdn.cmi 
 tactics/refine.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
     kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
     proofs/tacmach.cmi kernel/sign.cmi pretyping/retyping.cmi \
-    kernel/reduction.cmi parsing/printer.cmi lib/pp.cmi kernel/names.cmi \
-    pretyping/evd.cmi kernel/environ.cmi proofs/clenv.cmi tactics/refine.cmi 
+    proofs/refiner.cmi kernel/reduction.cmi parsing/printer.cmi lib/pp.cmi \
+    kernel/names.cmi pretyping/evarutil.cmi kernel/environ.cmi \
+    tactics/refine.cmi 
 tactics/refine.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
     kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
     proofs/tacmach.cmx kernel/sign.cmx pretyping/retyping.cmx \
-    kernel/reduction.cmx parsing/printer.cmx lib/pp.cmx kernel/names.cmx \
-    pretyping/evd.cmx kernel/environ.cmx proofs/clenv.cmx tactics/refine.cmi 
+    proofs/refiner.cmx kernel/reduction.cmx parsing/printer.cmx lib/pp.cmx \
+    kernel/names.cmx pretyping/evarutil.cmx kernel/environ.cmx \
+    tactics/refine.cmi 
 tactics/setoid_replace.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
-    tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
-    library/summary.cmi kernel/safe_typing.cmi pretyping/reductionops.cmi \
-    proofs/proof_type.cmi parsing/printer.cmi lib/pp.cmi proofs/pfedit.cmi \
-    lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libobject.cmi library/libnames.cmi library/lib.cmi lib/gmap.cmi \
-    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    pretyping/unification.cmi pretyping/typing.cmi interp/topconstr.cmi \
+    pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
+    tactics/tacticals.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
+    library/summary.cmi kernel/sign.cmi kernel/safe_typing.cmi \
+    pretyping/reductionops.cmi kernel/reduction.cmi pretyping/rawterm.cmi \
+    proofs/proof_type.cmi parsing/printer.cmi pretyping/pretype_errors.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    kernel/mod_subst.cmi proofs/logic.cmi library/libobject.cmi \
+    library/libnames.cmi library/lib.cmi lib/gmap.cmi library/global.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \
     kernel/entries.cmi library/declare.cmi library/decl_kinds.cmo \
-    interp/coqlib.cmi interp/constrintern.cmi tactics/auto.cmi \
-    tactics/setoid_replace.cmi 
+    interp/coqlib.cmi interp/constrintern.cmi kernel/closure.cmi \
+    pretyping/clenv.cmi tactics/setoid_replace.cmi 
 tactics/setoid_replace.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
-    tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \
-    library/summary.cmx kernel/safe_typing.cmx pretyping/reductionops.cmx \
-    proofs/proof_type.cmx parsing/printer.cmx lib/pp.cmx proofs/pfedit.cmx \
-    lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/libobject.cmx library/libnames.cmx library/lib.cmx lib/gmap.cmx \
-    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    pretyping/unification.cmx pretyping/typing.cmx interp/topconstr.cmx \
+    pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
+    tactics/tacticals.cmx pretyping/tacred.cmx proofs/tacmach.cmx \
+    library/summary.cmx kernel/sign.cmx kernel/safe_typing.cmx \
+    pretyping/reductionops.cmx kernel/reduction.cmx pretyping/rawterm.cmx \
+    proofs/proof_type.cmx parsing/printer.cmx pretyping/pretype_errors.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    kernel/mod_subst.cmx proofs/logic.cmx library/libobject.cmx \
+    library/libnames.cmx library/lib.cmx lib/gmap.cmx library/global.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \
     kernel/entries.cmx library/declare.cmx library/decl_kinds.cmx \
-    interp/coqlib.cmx interp/constrintern.cmx tactics/auto.cmx \
-    tactics/setoid_replace.cmi 
+    interp/coqlib.cmx interp/constrintern.cmx kernel/closure.cmx \
+    pretyping/clenv.cmx tactics/setoid_replace.cmi 
 tactics/tacinterp.cmo: lib/util.cmi pretyping/typing.cmi interp/topconstr.cmi \
     pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
     proofs/tactic_debug.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
-    proofs/tacexpr.cmo interp/syntax_def.cmi library/summary.cmi \
-    kernel/sign.cmi kernel/safe_typing.cmi pretyping/retyping.cmi \
-    proofs/refiner.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
-    parsing/printer.cmi pretyping/pretyping.cmi pretyping/pretype_errors.cmi \
-    lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi lib/options.cmi \
-    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    pretyping/matching.cmi proofs/logic.cmi library/libobject.cmi \
-    library/libnames.cmi library/lib.cmi tactics/leminv.cmi tactics/inv.cmi \
+    proofs/tacexpr.cmo lib/system.cmi interp/syntax_def.cmi \
+    library/summary.cmi kernel/sign.cmi kernel/safe_typing.cmi \
+    pretyping/retyping.cmi proofs/refiner.cmi pretyping/reductionops.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
+    pretyping/pretyping.cmi pretyping/pretype_errors.cmi parsing/pptactic.cmi \
+    lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi pretyping/pattern.cmi \
+    lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    kernel/mod_subst.cmi pretyping/matching.cmi proofs/logic.cmi \
+    library/libobject.cmi library/libnames.cmi library/lib.cmi \
+    tactics/leminv.cmi tactics/inv.cmi pretyping/inductiveops.cmi \
     tactics/hiddentac.cmi lib/gmap.cmi library/global.cmi interp/genarg.cmi \
-    pretyping/evd.cmi kernel/environ.cmi kernel/entries.cmi tactics/elim.cmi \
-    lib/dyn.cmi tactics/dhyp.cmi kernel/declarations.cmi \
-    library/decl_kinds.cmo parsing/coqast.cmi interp/constrintern.cmi \
-    kernel/closure.cmi tactics/auto.cmi parsing/ast.cmi tactics/tacinterp.cmi 
+    parsing/g_xml.cmo pretyping/evd.cmi tactics/equality.cmi \
+    kernel/environ.cmi kernel/entries.cmi tactics/elim.cmi lib/dyn.cmi \
+    tactics/dhyp.cmi pretyping/detyping.cmi kernel/declarations.cmi \
+    library/decl_kinds.cmo interp/constrintern.cmi kernel/closure.cmi \
+    tactics/auto.cmi tactics/tacinterp.cmi 
 tactics/tacinterp.cmx: lib/util.cmx pretyping/typing.cmx interp/topconstr.cmx \
     pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
     proofs/tactic_debug.cmx pretyping/tacred.cmx proofs/tacmach.cmx \
-    proofs/tacexpr.cmx interp/syntax_def.cmx library/summary.cmx \
-    kernel/sign.cmx kernel/safe_typing.cmx pretyping/retyping.cmx \
-    proofs/refiner.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
-    parsing/printer.cmx pretyping/pretyping.cmx pretyping/pretype_errors.cmx \
-    lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx lib/options.cmx \
-    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    pretyping/matching.cmx proofs/logic.cmx library/libobject.cmx \
-    library/libnames.cmx library/lib.cmx tactics/leminv.cmx tactics/inv.cmx \
+    proofs/tacexpr.cmx lib/system.cmx interp/syntax_def.cmx \
+    library/summary.cmx kernel/sign.cmx kernel/safe_typing.cmx \
+    pretyping/retyping.cmx proofs/refiner.cmx pretyping/reductionops.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
+    pretyping/pretyping.cmx pretyping/pretype_errors.cmx parsing/pptactic.cmx \
+    lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx pretyping/pattern.cmx \
+    lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    kernel/mod_subst.cmx pretyping/matching.cmx proofs/logic.cmx \
+    library/libobject.cmx library/libnames.cmx library/lib.cmx \
+    tactics/leminv.cmx tactics/inv.cmx pretyping/inductiveops.cmx \
     tactics/hiddentac.cmx lib/gmap.cmx library/global.cmx interp/genarg.cmx \
-    pretyping/evd.cmx kernel/environ.cmx kernel/entries.cmx tactics/elim.cmx \
-    lib/dyn.cmx tactics/dhyp.cmx kernel/declarations.cmx \
-    library/decl_kinds.cmx parsing/coqast.cmx interp/constrintern.cmx \
-    kernel/closure.cmx tactics/auto.cmx parsing/ast.cmx tactics/tacinterp.cmi 
+    parsing/g_xml.cmx pretyping/evd.cmx tactics/equality.cmx \
+    kernel/environ.cmx kernel/entries.cmx tactics/elim.cmx lib/dyn.cmx \
+    tactics/dhyp.cmx pretyping/detyping.cmx kernel/declarations.cmx \
+    library/decl_kinds.cmx interp/constrintern.cmx kernel/closure.cmx \
+    tactics/auto.cmx tactics/tacinterp.cmi 
 tactics/tacticals.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
     proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi proofs/refiner.cmi \
     kernel/reduction.cmi lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi \
     pretyping/matching.cmi library/libnames.cmi kernel/inductive.cmi \
     pretyping/indrec.cmi library/global.cmi interp/genarg.cmi \
-    proofs/evar_refiner.cmi kernel/environ.cmi kernel/declarations.cmi \
-    proofs/clenv.cmi tactics/tacticals.cmi 
+    pretyping/evd.cmi proofs/evar_refiner.cmi kernel/environ.cmi \
+    kernel/declarations.cmi proofs/clenvtac.cmi pretyping/clenv.cmi \
+    tactics/tacticals.cmi 
 tactics/tacticals.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
     proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx proofs/refiner.cmx \
     kernel/reduction.cmx lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx \
     pretyping/matching.cmx library/libnames.cmx kernel/inductive.cmx \
     pretyping/indrec.cmx library/global.cmx interp/genarg.cmx \
-    proofs/evar_refiner.cmx kernel/environ.cmx kernel/declarations.cmx \
-    proofs/clenv.cmx tactics/tacticals.cmi 
-tactics/tactics.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
-    tactics/tacticals.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
-    proofs/tacexpr.cmo kernel/sign.cmi proofs/refiner.cmi \
-    pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
-    proofs/proof_trees.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \
+    pretyping/evd.cmx proofs/evar_refiner.cmx kernel/environ.cmx \
+    kernel/declarations.cmx proofs/clenvtac.cmx pretyping/clenv.cmx \
+    tactics/tacticals.cmi 
+tactics/tactics.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tacticals.cmi pretyping/tacred.cmi \
+    proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi proofs/refiner.cmi \
+    pretyping/reductionops.cmi kernel/reduction.cmi proofs/redexpr.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
+    pretyping/pretype_errors.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \
     library/nametab.cmi kernel/names.cmi library/nameops.cmi proofs/logic.cmi \
     library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
     pretyping/indrec.cmi tactics/hipattern.cmi library/global.cmi \
     interp/genarg.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
     proofs/evar_refiner.cmi kernel/environ.cmi kernel/entries.cmi \
     library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \
-    interp/coqlib.cmi interp/constrintern.cmi proofs/clenv.cmi \
-    tactics/tactics.cmi 
-tactics/tactics.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
-    tactics/tacticals.cmx pretyping/tacred.cmx proofs/tacmach.cmx \
-    proofs/tacexpr.cmx kernel/sign.cmx proofs/refiner.cmx \
-    pretyping/reductionops.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
-    proofs/proof_trees.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \
+    interp/coqlib.cmi interp/constrintern.cmi proofs/clenvtac.cmi \
+    pretyping/clenv.cmi tactics/tactics.cmi 
+tactics/tactics.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tacticals.cmx pretyping/tacred.cmx \
+    proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx proofs/refiner.cmx \
+    pretyping/reductionops.cmx kernel/reduction.cmx proofs/redexpr.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
+    pretyping/pretype_errors.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \
     library/nametab.cmx kernel/names.cmx library/nameops.cmx proofs/logic.cmx \
     library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
     pretyping/indrec.cmx tactics/hipattern.cmx library/global.cmx \
     interp/genarg.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
     proofs/evar_refiner.cmx kernel/environ.cmx kernel/entries.cmx \
     library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \
-    interp/coqlib.cmx interp/constrintern.cmx proofs/clenv.cmx \
-    tactics/tactics.cmi 
+    interp/coqlib.cmx interp/constrintern.cmx proofs/clenvtac.cmx \
+    pretyping/clenv.cmx tactics/tactics.cmi 
 tactics/tauto.cmo: lib/util.cmi interp/topconstr.cmi tactics/tactics.cmi \
     tactics/tacticals.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
     proofs/refiner.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
-    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    kernel/names.cmi library/libnames.cmi tactics/hipattern.cmi \
-    interp/genarg.cmi parsing/egrammar.cmi parsing/coqast.cmi \
-    toplevel/cerrors.cmi parsing/ast.cmi 
+    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi \
+    library/libnames.cmi tactics/hipattern.cmi interp/genarg.cmi \
+    parsing/egrammar.cmi toplevel/cerrors.cmi 
 tactics/tauto.cmx: lib/util.cmx interp/topconstr.cmx tactics/tactics.cmx \
     tactics/tacticals.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
     proofs/refiner.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
-    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    kernel/names.cmx library/libnames.cmx tactics/hipattern.cmx \
-    interp/genarg.cmx parsing/egrammar.cmx parsing/coqast.cmx \
-    toplevel/cerrors.cmx parsing/ast.cmx 
+    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \
+    library/libnames.cmx tactics/hipattern.cmx interp/genarg.cmx \
+    parsing/egrammar.cmx toplevel/cerrors.cmx 
 tactics/termdn.cmo: lib/util.cmi kernel/term.cmi pretyping/rawterm.cmi \
     pretyping/pattern.cmi library/nametab.cmi kernel/names.cmi \
     library/nameops.cmi library/libnames.cmi tactics/dn.cmi \
@@ -1973,62 +2220,62 @@ tools/coqdep.cmx: tools/coqdep_lexer.cmx config/coq_config.cmx
 tools/gallina.cmo: tools/gallina_lexer.cmo 
 tools/gallina.cmx: tools/gallina_lexer.cmx 
 toplevel/cerrors.cmo: lib/util.cmi kernel/univ.cmi kernel/type_errors.cmi \
-    proofs/tactic_debug.cmi proofs/refiner.cmi pretyping/pretype_errors.cmi \
-    lib/pp.cmi lib/options.cmi library/nametab.cmi proofs/logic.cmi \
-    library/libnames.cmi parsing/lexer.cmi kernel/indtypes.cmi \
-    toplevel/himsg.cmi pretyping/cases.cmi parsing/ast.cmi \
-    toplevel/cerrors.cmi 
+    proofs/tactic_debug.cmi pretyping/tacred.cmi proofs/refiner.cmi \
+    pretyping/pretype_errors.cmi lib/pp.cmi lib/options.cmi \
+    library/nametab.cmi proofs/logic.cmi library/libnames.cmi \
+    parsing/lexer.cmi kernel/indtypes.cmi pretyping/indrec.cmi \
+    toplevel/himsg.cmi pretyping/cases.cmi toplevel/cerrors.cmi 
 toplevel/cerrors.cmx: lib/util.cmx kernel/univ.cmx kernel/type_errors.cmx \
-    proofs/tactic_debug.cmx proofs/refiner.cmx pretyping/pretype_errors.cmx \
-    lib/pp.cmx lib/options.cmx library/nametab.cmx proofs/logic.cmx \
-    library/libnames.cmx parsing/lexer.cmx kernel/indtypes.cmx \
-    toplevel/himsg.cmx pretyping/cases.cmx parsing/ast.cmx \
-    toplevel/cerrors.cmi 
+    proofs/tactic_debug.cmx pretyping/tacred.cmx proofs/refiner.cmx \
+    pretyping/pretype_errors.cmx lib/pp.cmx lib/options.cmx \
+    library/nametab.cmx proofs/logic.cmx library/libnames.cmx \
+    parsing/lexer.cmx kernel/indtypes.cmx pretyping/indrec.cmx \
+    toplevel/himsg.cmx pretyping/cases.cmx toplevel/cerrors.cmi 
 toplevel/class.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
     kernel/term.cmi kernel/sign.cmi kernel/safe_typing.cmi \
-    pretyping/retyping.cmi pretyping/reductionops.cmi parsing/printer.cmi \
-    lib/pp.cmi lib/options.cmi library/nametab.cmi kernel/names.cmi \
-    library/nameops.cmi library/libnames.cmi library/lib.cmi \
-    kernel/inductive.cmi library/global.cmi pretyping/evd.cmi \
-    kernel/environ.cmi kernel/entries.cmi library/declare.cmi \
-    kernel/declarations.cmi library/decl_kinds.cmo pretyping/classops.cmi \
-    toplevel/class.cmi 
+    pretyping/reductionops.cmi parsing/printer.cmi lib/pp.cmi lib/options.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi library/lib.cmi kernel/inductive.cmi \
+    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    kernel/entries.cmi library/declare.cmi kernel/declarations.cmi \
+    library/decl_kinds.cmo pretyping/classops.cmi toplevel/class.cmi 
 toplevel/class.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
     kernel/term.cmx kernel/sign.cmx kernel/safe_typing.cmx \
-    pretyping/retyping.cmx pretyping/reductionops.cmx parsing/printer.cmx \
-    lib/pp.cmx lib/options.cmx library/nametab.cmx kernel/names.cmx \
-    library/nameops.cmx library/libnames.cmx library/lib.cmx \
-    kernel/inductive.cmx library/global.cmx pretyping/evd.cmx \
-    kernel/environ.cmx kernel/entries.cmx library/declare.cmx \
-    kernel/declarations.cmx library/decl_kinds.cmx pretyping/classops.cmx \
-    toplevel/class.cmi 
+    pretyping/reductionops.cmx parsing/printer.cmx lib/pp.cmx lib/options.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx library/lib.cmx kernel/inductive.cmx \
+    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    kernel/entries.cmx library/declare.cmx kernel/declarations.cmx \
+    library/decl_kinds.cmx pretyping/classops.cmx toplevel/class.cmi 
 toplevel/command.cmo: toplevel/vernacexpr.cmo lib/util.cmi kernel/typeops.cmi \
     interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \
-    pretyping/tacred.cmi proofs/tacmach.cmi interp/syntax_def.cmi \
-    interp/symbols.cmi library/states.cmi kernel/safe_typing.cmi \
-    pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
-    proofs/proof_type.cmi parsing/printer.cmi pretyping/pretyping.cmi \
-    lib/pp.cmi proofs/pfedit.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi toplevel/metasyntax.cmi \
-    proofs/logic.cmi library/library.cmi library/libobject.cmi \
-    library/libnames.cmi library/lib.cmi kernel/inductive.cmi \
-    kernel/indtypes.cmi pretyping/indrec.cmi library/impargs.cmi \
-    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    proofs/tacmach.cmi interp/syntax_def.cmi library/states.cmi \
+    kernel/sign.cmi kernel/safe_typing.cmi pretyping/retyping.cmi \
+    pretyping/reductionops.cmi kernel/reduction.cmi proofs/redexpr.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi pretyping/pretyping.cmi \
+    lib/pp.cmi proofs/pfedit.cmi lib/options.cmi interp/notation.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    toplevel/metasyntax.cmi proofs/logic.cmi library/library.cmi \
+    library/libobject.cmi library/libnames.cmi library/lib.cmi \
+    pretyping/inductiveops.cmi kernel/inductive.cmi kernel/indtypes.cmi \
+    pretyping/indrec.cmi library/impargs.cmi library/global.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \
     kernel/environ.cmi kernel/entries.cmi library/declare.cmi \
     kernel/declarations.cmi library/decl_kinds.cmo interp/constrintern.cmi \
     interp/constrextern.cmi toplevel/class.cmi toplevel/command.cmi 
 toplevel/command.cmx: toplevel/vernacexpr.cmx lib/util.cmx kernel/typeops.cmx \
     interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \
-    pretyping/tacred.cmx proofs/tacmach.cmx interp/syntax_def.cmx \
-    interp/symbols.cmx library/states.cmx kernel/safe_typing.cmx \
-    pretyping/retyping.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
-    proofs/proof_type.cmx parsing/printer.cmx pretyping/pretyping.cmx \
-    lib/pp.cmx proofs/pfedit.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx toplevel/metasyntax.cmx \
-    proofs/logic.cmx library/library.cmx library/libobject.cmx \
-    library/libnames.cmx library/lib.cmx kernel/inductive.cmx \
-    kernel/indtypes.cmx pretyping/indrec.cmx library/impargs.cmx \
-    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    proofs/tacmach.cmx interp/syntax_def.cmx library/states.cmx \
+    kernel/sign.cmx kernel/safe_typing.cmx pretyping/retyping.cmx \
+    pretyping/reductionops.cmx kernel/reduction.cmx proofs/redexpr.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx pretyping/pretyping.cmx \
+    lib/pp.cmx proofs/pfedit.cmx lib/options.cmx interp/notation.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    toplevel/metasyntax.cmx proofs/logic.cmx library/library.cmx \
+    library/libobject.cmx library/libnames.cmx library/lib.cmx \
+    pretyping/inductiveops.cmx kernel/inductive.cmx kernel/indtypes.cmx \
+    pretyping/indrec.cmx library/impargs.cmx library/global.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \
     kernel/environ.cmx kernel/entries.cmx library/declare.cmx \
     kernel/declarations.cmx library/decl_kinds.cmx interp/constrintern.cmx \
     interp/constrextern.cmx toplevel/class.cmx toplevel/command.cmi 
@@ -2040,41 +2287,29 @@ toplevel/coqinit.cmx: toplevel/vernac.cmx toplevel/toplevel.cmx \
     lib/system.cmx lib/pp.cmx lib/options.cmx kernel/names.cmx \
     library/nameops.cmx toplevel/mltop.cmx config/coq_config.cmx \
     toplevel/coqinit.cmi 
-toplevel/coqtop.cmo: toplevel/vernac.cmi lib/util.cmi toplevel/usage.cmi \
-    toplevel/toplevel.cmi lib/system.cmi library/states.cmi lib/profile.cmi \
-    lib/pp.cmi lib/options.cmi kernel/names.cmi library/nameops.cmi \
-    toplevel/mltop.cmi library/library.cmi library/libnames.cmi \
-    library/lib.cmi library/global.cmi kernel/environ.cmi \
-    library/declaremods.cmi toplevel/coqinit.cmi config/coq_config.cmi \
+toplevel/coqtop.cmo: kernel/vm.cmi toplevel/vernac.cmi kernel/vconv.cmi \
+    lib/util.cmi toplevel/usage.cmi toplevel/toplevel.cmi lib/system.cmi \
+    library/states.cmi lib/profile.cmi lib/pp.cmi lib/options.cmi \
+    kernel/names.cmi library/nameops.cmi toplevel/mltop.cmi \
+    library/library.cmi library/libnames.cmi library/lib.cmi \
+    library/global.cmi library/declaremods.cmi kernel/declarations.cmi \
+    toplevel/coqinit.cmi config/coq_config.cmi interp/constrintern.cmi \
     toplevel/cerrors.cmi toplevel/coqtop.cmi 
-toplevel/coqtop.cmx: toplevel/vernac.cmx lib/util.cmx toplevel/usage.cmx \
-    toplevel/toplevel.cmx lib/system.cmx library/states.cmx lib/profile.cmx \
-    lib/pp.cmx lib/options.cmx kernel/names.cmx library/nameops.cmx \
-    toplevel/mltop.cmx library/library.cmx library/libnames.cmx \
-    library/lib.cmx library/global.cmx kernel/environ.cmx \
-    library/declaremods.cmx toplevel/coqinit.cmx config/coq_config.cmx \
+toplevel/coqtop.cmx: kernel/vm.cmx toplevel/vernac.cmx kernel/vconv.cmx \
+    lib/util.cmx toplevel/usage.cmx toplevel/toplevel.cmx lib/system.cmx \
+    library/states.cmx lib/profile.cmx lib/pp.cmx lib/options.cmx \
+    kernel/names.cmx library/nameops.cmx toplevel/mltop.cmx \
+    library/library.cmx library/libnames.cmx library/lib.cmx \
+    library/global.cmx library/declaremods.cmx kernel/declarations.cmx \
+    toplevel/coqinit.cmx config/coq_config.cmx interp/constrintern.cmx \
     toplevel/cerrors.cmx toplevel/coqtop.cmi 
-toplevel/discharge.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \
-    kernel/term.cmi library/summary.cmi kernel/sign.cmi kernel/reduction.cmi \
-    pretyping/recordops.cmi toplevel/recordobj.cmi lib/pp.cmi lib/options.cmi \
-    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/library.cmi library/libobject.cmi library/libnames.cmi \
-    library/lib.cmi pretyping/instantiate.cmi kernel/inductive.cmi \
-    kernel/indtypes.cmi library/impargs.cmi library/global.cmi \
-    kernel/environ.cmi kernel/entries.cmi library/dischargedhypsmap.cmi \
-    library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \
-    kernel/cooking.cmi pretyping/classops.cmi toplevel/class.cmi \
+toplevel/discharge.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
+    kernel/sign.cmi kernel/names.cmi kernel/inductive.cmi library/global.cmi \
+    kernel/entries.cmi kernel/declarations.cmi kernel/cooking.cmi \
     toplevel/discharge.cmi 
-toplevel/discharge.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
-    kernel/term.cmx library/summary.cmx kernel/sign.cmx kernel/reduction.cmx \
-    pretyping/recordops.cmx toplevel/recordobj.cmx lib/pp.cmx lib/options.cmx \
-    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/library.cmx library/libobject.cmx library/libnames.cmx \
-    library/lib.cmx pretyping/instantiate.cmx kernel/inductive.cmx \
-    kernel/indtypes.cmx library/impargs.cmx library/global.cmx \
-    kernel/environ.cmx kernel/entries.cmx library/dischargedhypsmap.cmx \
-    library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \
-    kernel/cooking.cmx pretyping/classops.cmx toplevel/class.cmx \
+toplevel/discharge.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
+    kernel/sign.cmx kernel/names.cmx kernel/inductive.cmx library/global.cmx \
+    kernel/entries.cmx kernel/declarations.cmx kernel/cooking.cmx \
     toplevel/discharge.cmi 
 toplevel/fhimsg.cmo: lib/util.cmi kernel/type_errors.cmi kernel/term.cmi \
     kernel/sign.cmi kernel/reduction.cmi lib/pp.cmi kernel/names.cmi \
@@ -2083,41 +2318,39 @@ toplevel/fhimsg.cmx: lib/util.cmx kernel/type_errors.cmx kernel/term.cmx \
     kernel/sign.cmx kernel/reduction.cmx lib/pp.cmx kernel/names.cmx \
     parsing/g_minicoq.cmx kernel/environ.cmx toplevel/fhimsg.cmi 
 toplevel/himsg.cmo: lib/util.cmi kernel/type_errors.cmi pretyping/termops.cmi \
-    kernel/term.cmi kernel/sign.cmi kernel/reduction.cmi \
+    kernel/term.cmi pretyping/tacred.cmi kernel/sign.cmi kernel/reduction.cmi \
     pretyping/rawterm.cmi parsing/printer.cmi pretyping/pretype_errors.cmi \
     lib/pp.cmi lib/options.cmi library/nametab.cmi kernel/names.cmi \
     library/nameops.cmi proofs/logic.cmi kernel/inductive.cmi \
-    kernel/indtypes.cmi library/global.cmi pretyping/evd.cmi \
-    kernel/environ.cmi pretyping/cases.cmi parsing/ast.cmi toplevel/himsg.cmi 
+    kernel/indtypes.cmi pretyping/indrec.cmi library/global.cmi \
+    pretyping/evd.cmi kernel/environ.cmi pretyping/cases.cmi \
+    toplevel/himsg.cmi 
 toplevel/himsg.cmx: lib/util.cmx kernel/type_errors.cmx pretyping/termops.cmx \
-    kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx \
+    kernel/term.cmx pretyping/tacred.cmx kernel/sign.cmx kernel/reduction.cmx \
     pretyping/rawterm.cmx parsing/printer.cmx pretyping/pretype_errors.cmx \
     lib/pp.cmx lib/options.cmx library/nametab.cmx kernel/names.cmx \
     library/nameops.cmx proofs/logic.cmx kernel/inductive.cmx \
-    kernel/indtypes.cmx library/global.cmx pretyping/evd.cmx \
-    kernel/environ.cmx pretyping/cases.cmx parsing/ast.cmx toplevel/himsg.cmi 
+    kernel/indtypes.cmx pretyping/indrec.cmx library/global.cmx \
+    pretyping/evd.cmx kernel/environ.cmx pretyping/cases.cmx \
+    toplevel/himsg.cmi 
 toplevel/line_oriented_parser.cmo: toplevel/line_oriented_parser.cmi 
 toplevel/line_oriented_parser.cmx: toplevel/line_oriented_parser.cmi 
 toplevel/metasyntax.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi parsing/termast.cmi interp/symbols.cmi \
-    library/summary.cmi pretyping/rawterm.cmi parsing/pptactic.cmi \
-    interp/ppextend.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    library/nametab.cmi kernel/names.cmi library/library.cmi \
+    interp/topconstr.cmi tactics/tacinterp.cmi library/summary.cmi \
+    pretyping/rawterm.cmi parsing/pptactic.cmi interp/ppextend.cmi lib/pp.cmi \
+    parsing/pcoq.cmi lib/options.cmi interp/notation.cmi kernel/names.cmi \
     library/libobject.cmi library/libnames.cmi library/lib.cmi \
-    parsing/lexer.cmi library/global.cmi interp/genarg.cmi parsing/extend.cmi \
-    pretyping/evd.cmi parsing/esyntax.cmi parsing/egrammar.cmi \
-    parsing/coqast.cmi interp/constrintern.cmi interp/constrextern.cmi \
-    pretyping/classops.cmi parsing/ast.cmi toplevel/metasyntax.cmi 
+    parsing/lexer.cmi library/global.cmi parsing/extend.cmi \
+    parsing/egrammar.cmi interp/constrintern.cmi pretyping/classops.cmi \
+    lib/bigint.cmi toplevel/metasyntax.cmi 
 toplevel/metasyntax.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx parsing/termast.cmx interp/symbols.cmx \
-    library/summary.cmx pretyping/rawterm.cmx parsing/pptactic.cmx \
-    interp/ppextend.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    library/nametab.cmx kernel/names.cmx library/library.cmx \
+    interp/topconstr.cmx tactics/tacinterp.cmx library/summary.cmx \
+    pretyping/rawterm.cmx parsing/pptactic.cmx interp/ppextend.cmx lib/pp.cmx \
+    parsing/pcoq.cmx lib/options.cmx interp/notation.cmx kernel/names.cmx \
     library/libobject.cmx library/libnames.cmx library/lib.cmx \
-    parsing/lexer.cmx library/global.cmx interp/genarg.cmx parsing/extend.cmx \
-    pretyping/evd.cmx parsing/esyntax.cmx parsing/egrammar.cmx \
-    parsing/coqast.cmx interp/constrintern.cmx interp/constrextern.cmx \
-    pretyping/classops.cmx parsing/ast.cmx toplevel/metasyntax.cmi 
+    parsing/lexer.cmx library/global.cmx parsing/extend.cmx \
+    parsing/egrammar.cmx interp/constrintern.cmx pretyping/classops.cmx \
+    lib/bigint.cmx toplevel/metasyntax.cmi 
 toplevel/minicoq.cmo: lib/util.cmi kernel/type_errors.cmi kernel/term.cmi \
     kernel/sign.cmi kernel/safe_typing.cmi lib/pp.cmi kernel/names.cmi \
     kernel/inductive.cmi parsing/g_minicoq.cmi toplevel/fhimsg.cmi \
@@ -2143,203 +2376,157 @@ toplevel/protectedtoplevel.cmx: toplevel/vernacexpr.cmx toplevel/vernac.cmx \
 toplevel/record.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
     kernel/type_errors.cmi interp/topconstr.cmi pretyping/termops.cmi \
     kernel/term.cmi kernel/safe_typing.cmi pretyping/recordops.cmi \
-    parsing/printer.cmi lib/pp.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
-    pretyping/inductiveops.cmi kernel/inductive.cmi kernel/indtypes.cmi \
-    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
-    kernel/entries.cmi library/declare.cmi kernel/declarations.cmi \
-    library/decl_kinds.cmo parsing/coqast.cmi interp/constrintern.cmi \
+    pretyping/rawterm.cmi parsing/printer.cmi lib/pp.cmi lib/options.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
+    kernel/indtypes.cmi library/global.cmi pretyping/evd.cmi \
+    kernel/environ.cmi kernel/entries.cmi library/declare.cmi \
+    kernel/declarations.cmi library/decl_kinds.cmo interp/constrintern.cmi \
     toplevel/command.cmi toplevel/class.cmi toplevel/record.cmi 
 toplevel/record.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
     kernel/type_errors.cmx interp/topconstr.cmx pretyping/termops.cmx \
     kernel/term.cmx kernel/safe_typing.cmx pretyping/recordops.cmx \
-    parsing/printer.cmx lib/pp.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
-    pretyping/inductiveops.cmx kernel/inductive.cmx kernel/indtypes.cmx \
-    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
-    kernel/entries.cmx library/declare.cmx kernel/declarations.cmx \
-    library/decl_kinds.cmx parsing/coqast.cmx interp/constrintern.cmx \
+    pretyping/rawterm.cmx parsing/printer.cmx lib/pp.cmx lib/options.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
+    kernel/indtypes.cmx library/global.cmx pretyping/evd.cmx \
+    kernel/environ.cmx kernel/entries.cmx library/declare.cmx \
+    kernel/declarations.cmx library/decl_kinds.cmx interp/constrintern.cmx \
     toplevel/command.cmx toplevel/class.cmx toplevel/record.cmi 
-toplevel/recordobj.cmo: lib/util.cmi kernel/term.cmi pretyping/recordops.cmi \
-    lib/pp.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/libnames.cmi library/lib.cmi pretyping/instantiate.cmi \
-    library/global.cmi kernel/environ.cmi library/declare.cmi \
-    pretyping/classops.cmi toplevel/recordobj.cmi 
-toplevel/recordobj.cmx: lib/util.cmx kernel/term.cmx pretyping/recordops.cmx \
-    lib/pp.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/libnames.cmx library/lib.cmx pretyping/instantiate.cmx \
-    library/global.cmx kernel/environ.cmx library/declare.cmx \
-    pretyping/classops.cmx toplevel/recordobj.cmi 
 toplevel/toplevel.cmo: toplevel/vernacexpr.cmo toplevel/vernac.cmi \
-    lib/util.cmi toplevel/protectedtoplevel.cmi lib/pp.cmi proofs/pfedit.cmi \
-    parsing/pcoq.cmi lib/options.cmi kernel/names.cmi toplevel/mltop.cmi \
-    library/lib.cmi toplevel/cerrors.cmi toplevel/toplevel.cmi 
+    lib/util.cmi toplevel/protectedtoplevel.cmi parsing/printer.cmi \
+    lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi lib/options.cmi \
+    kernel/names.cmi toplevel/mltop.cmi library/lib.cmi toplevel/cerrors.cmi \
+    toplevel/toplevel.cmi 
 toplevel/toplevel.cmx: toplevel/vernacexpr.cmx toplevel/vernac.cmx \
-    lib/util.cmx toplevel/protectedtoplevel.cmx lib/pp.cmx proofs/pfedit.cmx \
-    parsing/pcoq.cmx lib/options.cmx kernel/names.cmx toplevel/mltop.cmx \
-    library/lib.cmx toplevel/cerrors.cmx toplevel/toplevel.cmi 
+    lib/util.cmx toplevel/protectedtoplevel.cmx parsing/printer.cmx \
+    lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx lib/options.cmx \
+    kernel/names.cmx toplevel/mltop.cmx library/lib.cmx toplevel/cerrors.cmx \
+    toplevel/toplevel.cmi 
 toplevel/usage.cmo: config/coq_config.cmi toplevel/usage.cmi 
 toplevel/usage.cmx: config/coq_config.cmx toplevel/usage.cmi 
 toplevel/vernac.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
-    toplevel/vernacentries.cmi lib/util.cmi proofs/tacmach.cmi \
-    tactics/tacinterp.cmi lib/system.cmi library/states.cmi \
-    proofs/refiner.cmi translate/ppvernacnew.cmi lib/pp.cmi proofs/pfedit.cmi \
-    parsing/pcoq.cmi lib/options.cmi kernel/names.cmi library/library.cmi \
-    library/lib.cmi parsing/lexer.cmi parsing/coqast.cmi \
-    interp/constrintern.cmi interp/constrextern.cmi toplevel/vernac.cmi 
+    toplevel/vernacentries.cmi lib/util.cmi lib/system.cmi library/states.cmi \
+    parsing/ppvernac.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \
+    lib/options.cmi kernel/names.cmi library/library.cmi library/lib.cmi \
+    parsing/lexer.cmi interp/constrintern.cmi toplevel/vernac.cmi 
 toplevel/vernac.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \
-    toplevel/vernacentries.cmx lib/util.cmx proofs/tacmach.cmx \
-    tactics/tacinterp.cmx lib/system.cmx library/states.cmx \
-    proofs/refiner.cmx translate/ppvernacnew.cmx lib/pp.cmx proofs/pfedit.cmx \
-    parsing/pcoq.cmx lib/options.cmx kernel/names.cmx library/library.cmx \
-    library/lib.cmx parsing/lexer.cmx parsing/coqast.cmx \
-    interp/constrintern.cmx interp/constrextern.cmx toplevel/vernac.cmi 
-toplevel/vernacentries.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
-    lib/util.cmi kernel/univ.cmi kernel/typeops.cmi interp/topconstr.cmi \
-    kernel/term.cmi tactics/tactics.cmi proofs/tactic_debug.cmi \
-    pretyping/tacred.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
+    toplevel/vernacentries.cmx lib/util.cmx lib/system.cmx library/states.cmx \
+    parsing/ppvernac.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \
+    lib/options.cmx kernel/names.cmx library/library.cmx library/lib.cmx \
+    parsing/lexer.cmx interp/constrintern.cmx toplevel/vernac.cmi 
+toplevel/vernacentries.cmo: kernel/vm.cmi toplevel/vernacinterp.cmi \
+    toplevel/vernacexpr.cmo kernel/vconv.cmi lib/util.cmi kernel/univ.cmi \
+    kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tactics.cmi parsing/tactic_printer.cmi \
+    proofs/tactic_debug.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
     proofs/tacexpr.cmo lib/system.cmi interp/syntax_def.cmi \
-    interp/symbols.cmi library/states.cmi parsing/search.cmi \
-    kernel/safe_typing.cmi interp/reserve.cmi proofs/refiner.cmi \
-    pretyping/reductionops.cmi toplevel/recordobj.cmi toplevel/record.cmi \
-    pretyping/rawterm.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
-    parsing/printmod.cmi parsing/printer.cmi pretyping/pretyping.cmi \
-    parsing/prettyp.cmi lib/pp_control.cmi lib/pp.cmi proofs/pfedit.cmi \
-    lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    interp/modintern.cmi toplevel/mltop.cmi toplevel/metasyntax.cmi \
-    library/library.cmi library/libnames.cmi library/lib.cmi \
-    pretyping/inductiveops.cmi library/impargs.cmi library/goptions.cmi \
-    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
-    kernel/environ.cmi kernel/entries.cmi toplevel/discharge.cmi \
-    pretyping/detyping.cmi library/declaremods.cmi library/decl_kinds.cmo \
-    interp/constrintern.cmi interp/constrextern.cmi toplevel/command.cmi \
-    pretyping/classops.cmi toplevel/class.cmi tactics/auto.cmi \
-    toplevel/vernacentries.cmi 
-toplevel/vernacentries.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \
-    lib/util.cmx kernel/univ.cmx kernel/typeops.cmx interp/topconstr.cmx \
-    kernel/term.cmx tactics/tactics.cmx proofs/tactic_debug.cmx \
-    pretyping/tacred.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
+    library/states.cmi kernel/sign.cmi tactics/setoid_replace.cmi \
+    parsing/search.cmi kernel/safe_typing.cmi interp/reserve.cmi \
+    pretyping/reductionops.cmi proofs/redexpr.cmi pretyping/recordops.cmi \
+    toplevel/record.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
+    proofs/proof_trees.cmi parsing/printmod.cmi parsing/printer.cmi \
+    pretyping/pretyping.cmi parsing/prettyp.cmi lib/pp_control.cmi lib/pp.cmi \
+    proofs/pfedit.cmi lib/options.cmi interp/notation.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi interp/modintern.cmi \
+    toplevel/mltop.cmi toplevel/metasyntax.cmi library/library.cmi \
+    library/libnames.cmi library/lib.cmi pretyping/inductiveops.cmi \
+    library/impargs.cmi library/goptions.cmi library/global.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \
+    kernel/entries.cmi pretyping/detyping.cmi library/declaremods.cmi \
+    kernel/declarations.cmi tactics/decl_proof_instr.cmi proofs/decl_mode.cmi \
+    library/decl_kinds.cmo interp/constrintern.cmi interp/constrextern.cmi \
+    toplevel/command.cmi pretyping/classops.cmi toplevel/class.cmi \
+    tactics/autorewrite.cmi tactics/auto.cmi toplevel/vernacentries.cmi 
+toplevel/vernacentries.cmx: kernel/vm.cmx toplevel/vernacinterp.cmx \
+    toplevel/vernacexpr.cmx kernel/vconv.cmx lib/util.cmx kernel/univ.cmx \
+    kernel/typeops.cmx interp/topconstr.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tactics.cmx parsing/tactic_printer.cmx \
+    proofs/tactic_debug.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
     proofs/tacexpr.cmx lib/system.cmx interp/syntax_def.cmx \
-    interp/symbols.cmx library/states.cmx parsing/search.cmx \
-    kernel/safe_typing.cmx interp/reserve.cmx proofs/refiner.cmx \
-    pretyping/reductionops.cmx toplevel/recordobj.cmx toplevel/record.cmx \
-    pretyping/rawterm.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
-    parsing/printmod.cmx parsing/printer.cmx pretyping/pretyping.cmx \
-    parsing/prettyp.cmx lib/pp_control.cmx lib/pp.cmx proofs/pfedit.cmx \
-    lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    interp/modintern.cmx toplevel/mltop.cmx toplevel/metasyntax.cmx \
-    library/library.cmx library/libnames.cmx library/lib.cmx \
-    pretyping/inductiveops.cmx library/impargs.cmx library/goptions.cmx \
-    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
-    kernel/environ.cmx kernel/entries.cmx toplevel/discharge.cmx \
-    pretyping/detyping.cmx library/declaremods.cmx library/decl_kinds.cmx \
-    interp/constrintern.cmx interp/constrextern.cmx toplevel/command.cmx \
-    pretyping/classops.cmx toplevel/class.cmx tactics/auto.cmx \
-    toplevel/vernacentries.cmi 
+    library/states.cmx kernel/sign.cmx tactics/setoid_replace.cmx \
+    parsing/search.cmx kernel/safe_typing.cmx interp/reserve.cmx \
+    pretyping/reductionops.cmx proofs/redexpr.cmx pretyping/recordops.cmx \
+    toplevel/record.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
+    proofs/proof_trees.cmx parsing/printmod.cmx parsing/printer.cmx \
+    pretyping/pretyping.cmx parsing/prettyp.cmx lib/pp_control.cmx lib/pp.cmx \
+    proofs/pfedit.cmx lib/options.cmx interp/notation.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx interp/modintern.cmx \
+    toplevel/mltop.cmx toplevel/metasyntax.cmx library/library.cmx \
+    library/libnames.cmx library/lib.cmx pretyping/inductiveops.cmx \
+    library/impargs.cmx library/goptions.cmx library/global.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \
+    kernel/entries.cmx pretyping/detyping.cmx library/declaremods.cmx \
+    kernel/declarations.cmx tactics/decl_proof_instr.cmx proofs/decl_mode.cmx \
+    library/decl_kinds.cmx interp/constrintern.cmx interp/constrextern.cmx \
+    toplevel/command.cmx pretyping/classops.cmx toplevel/class.cmx \
+    tactics/autorewrite.cmx tactics/auto.cmx toplevel/vernacentries.cmi 
 toplevel/vernacexpr.cmo: lib/util.cmi interp/topconstr.cmi proofs/tacexpr.cmo \
     pretyping/rawterm.cmi interp/ppextend.cmi library/nametab.cmi \
     kernel/names.cmi library/libnames.cmi library/goptions.cmi \
-    interp/genarg.cmi parsing/extend.cmi library/decl_kinds.cmo 
+    interp/genarg.cmi parsing/extend.cmi library/decl_kinds.cmo \
+    proofs/decl_expr.cmi 
 toplevel/vernacexpr.cmx: lib/util.cmx interp/topconstr.cmx proofs/tacexpr.cmx \
     pretyping/rawterm.cmx interp/ppextend.cmx library/nametab.cmx \
     kernel/names.cmx library/libnames.cmx library/goptions.cmx \
-    interp/genarg.cmx parsing/extend.cmx library/decl_kinds.cmx 
+    interp/genarg.cmx parsing/extend.cmx library/decl_kinds.cmx \
+    proofs/decl_expr.cmi 
 toplevel/vernacinterp.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
     tactics/tacinterp.cmi proofs/tacexpr.cmo proofs/proof_type.cmi lib/pp.cmi \
     lib/options.cmi kernel/names.cmi library/libnames.cmi toplevel/himsg.cmi \
-    parsing/extend.cmi parsing/coqast.cmi parsing/ast.cmi \
     toplevel/vernacinterp.cmi 
 toplevel/vernacinterp.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
     tactics/tacinterp.cmx proofs/tacexpr.cmx proofs/proof_type.cmx lib/pp.cmx \
     lib/options.cmx kernel/names.cmx library/libnames.cmx toplevel/himsg.cmx \
-    parsing/extend.cmx parsing/coqast.cmx parsing/ast.cmx \
     toplevel/vernacinterp.cmi 
-translate/ppconstrnew.cmo: lib/util.cmi kernel/univ.cmi interp/topconstr.cmi \
-    pretyping/termops.cmi kernel/term.cmi interp/syntax_def.cmi \
-    interp/symbols.cmi pretyping/retyping.cmi pretyping/rawterm.cmi \
-    pretyping/pretyping.cmi interp/ppextend.cmi lib/pp.cmi \
-    pretyping/pattern.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/libnames.cmi library/lib.cmi \
-    library/global.cmi interp/genarg.cmi pretyping/evd.cmi parsing/coqast.cmi \
-    interp/constrintern.cmi interp/constrextern.cmi lib/bignat.cmi \
-    parsing/ast.cmi translate/ppconstrnew.cmi 
-translate/ppconstrnew.cmx: lib/util.cmx kernel/univ.cmx interp/topconstr.cmx \
-    pretyping/termops.cmx kernel/term.cmx interp/syntax_def.cmx \
-    interp/symbols.cmx pretyping/retyping.cmx pretyping/rawterm.cmx \
-    pretyping/pretyping.cmx interp/ppextend.cmx lib/pp.cmx \
-    pretyping/pattern.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/libnames.cmx library/lib.cmx \
-    library/global.cmx interp/genarg.cmx pretyping/evd.cmx parsing/coqast.cmx \
-    interp/constrintern.cmx interp/constrextern.cmx lib/bignat.cmx \
-    parsing/ast.cmx translate/ppconstrnew.cmi 
-translate/pptacticnew.cmo: lib/util.cmi interp/topconstr.cmi \
-    pretyping/termops.cmi kernel/term.cmi proofs/tacexpr.cmo \
-    pretyping/rawterm.cmi parsing/pptactic.cmi interp/ppextend.cmi \
-    translate/ppconstrnew.cmi lib/pp.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
-    library/global.cmi interp/genarg.cmi parsing/extend.cmi \
-    kernel/environ.cmi parsing/egrammar.cmi lib/dyn.cmi \
-    interp/constrextern.cmi kernel/closure.cmi translate/pptacticnew.cmi 
-translate/pptacticnew.cmx: lib/util.cmx interp/topconstr.cmx \
-    pretyping/termops.cmx kernel/term.cmx proofs/tacexpr.cmx \
-    pretyping/rawterm.cmx parsing/pptactic.cmx interp/ppextend.cmx \
-    translate/ppconstrnew.cmx lib/pp.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
-    library/global.cmx interp/genarg.cmx parsing/extend.cmx \
-    kernel/environ.cmx parsing/egrammar.cmx lib/dyn.cmx \
-    interp/constrextern.cmx kernel/closure.cmx translate/pptacticnew.cmi 
-translate/ppvernacnew.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \
-    tactics/tacinterp.cmi proofs/tacexpr.cmo pretyping/rawterm.cmi \
-    translate/pptacticnew.cmi parsing/pptactic.cmi interp/ppextend.cmi \
-    translate/ppconstrnew.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \
-    lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    interp/modintern.cmi toplevel/metasyntax.cmi library/library.cmi \
-    library/libnames.cmi library/lib.cmi library/impargs.cmi \
-    library/goptions.cmi library/global.cmi interp/genarg.cmi \
-    parsing/extend.cmi pretyping/evd.cmi kernel/environ.cmi \
-    parsing/egrammar.cmi library/declaremods.cmi library/decl_kinds.cmo \
-    parsing/coqast.cmi interp/constrintern.cmi interp/constrextern.cmi \
-    parsing/ast.cmi translate/ppvernacnew.cmi 
-translate/ppvernacnew.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \
-    tactics/tacinterp.cmx proofs/tacexpr.cmx pretyping/rawterm.cmx \
-    translate/pptacticnew.cmx parsing/pptactic.cmx interp/ppextend.cmx \
-    translate/ppconstrnew.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \
-    lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    interp/modintern.cmx toplevel/metasyntax.cmx library/library.cmx \
-    library/libnames.cmx library/lib.cmx library/impargs.cmx \
-    library/goptions.cmx library/global.cmx interp/genarg.cmx \
-    parsing/extend.cmx pretyping/evd.cmx kernel/environ.cmx \
-    parsing/egrammar.cmx library/declaremods.cmx library/decl_kinds.cmx \
-    parsing/coqast.cmx interp/constrintern.cmx interp/constrextern.cmx \
-    parsing/ast.cmx translate/ppvernacnew.cmi 
-contrib/cc/ccalgo.cmo: lib/util.cmi kernel/term.cmi kernel/names.cmi \
-    contrib/cc/ccalgo.cmi 
-contrib/cc/ccalgo.cmx: lib/util.cmx kernel/term.cmx kernel/names.cmx \
-    contrib/cc/ccalgo.cmi 
-contrib/cc/ccproof.cmo: lib/util.cmi lib/pp.cmi kernel/names.cmi \
+toplevel/whelp.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
+    pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi lib/system.cmi \
+    interp/syntax_def.cmi proofs/refiner.cmi pretyping/rawterm.cmi lib/pp.cmi \
+    proofs/pfedit.cmi parsing/pcoq.cmi lib/options.cmi library/nametab.cmi \
+    kernel/names.cmi library/libnames.cmi parsing/lexer.cmi interp/genarg.cmi \
+    kernel/environ.cmi parsing/egrammar.cmi library/dischargedhypsmap.cmi \
+    pretyping/detyping.cmi interp/constrintern.cmi toplevel/command.cmi \
+    toplevel/cerrors.cmi toplevel/whelp.cmi 
+toplevel/whelp.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
+    pretyping/termops.cmx kernel/term.cmx proofs/tacmach.cmx lib/system.cmx \
+    interp/syntax_def.cmx proofs/refiner.cmx pretyping/rawterm.cmx lib/pp.cmx \
+    proofs/pfedit.cmx parsing/pcoq.cmx lib/options.cmx library/nametab.cmx \
+    kernel/names.cmx library/libnames.cmx parsing/lexer.cmx interp/genarg.cmx \
+    kernel/environ.cmx parsing/egrammar.cmx library/dischargedhypsmap.cmx \
+    pretyping/detyping.cmx interp/constrintern.cmx toplevel/command.cmx \
+    toplevel/cerrors.cmx toplevel/whelp.cmi 
+contrib/cc/ccalgo.cmo: lib/util.cmi kernel/term.cmi lib/pp.cmi \
+    kernel/names.cmi library/goptions.cmi contrib/cc/ccalgo.cmi 
+contrib/cc/ccalgo.cmx: lib/util.cmx kernel/term.cmx lib/pp.cmx \
+    kernel/names.cmx library/goptions.cmx contrib/cc/ccalgo.cmi 
+contrib/cc/ccproof.cmo: lib/util.cmi kernel/term.cmi kernel/names.cmi \
     contrib/cc/ccalgo.cmi contrib/cc/ccproof.cmi 
-contrib/cc/ccproof.cmx: lib/util.cmx lib/pp.cmx kernel/names.cmx \
+contrib/cc/ccproof.cmx: lib/util.cmx kernel/term.cmx kernel/names.cmx \
     contrib/cc/ccalgo.cmx contrib/cc/ccproof.cmi 
 contrib/cc/cctac.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
     tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
-    tactics/tacinterp.cmi proofs/tacexpr.cmo kernel/sign.cmi \
-    proofs/refiner.cmi proofs/proof_type.cmi parsing/pptactic.cmi lib/pp.cmi \
-    parsing/pcoq.cmi lib/options.cmi kernel/names.cmi library/nameops.cmi \
-    library/library.cmi library/libnames.cmi pretyping/inductiveops.cmi \
-    kernel/inductive.cmi library/global.cmi pretyping/evd.cmi \
-    parsing/egrammar.cmi kernel/declarations.cmi interp/coqlib.cmi \
-    toplevel/cerrors.cmi contrib/cc/ccproof.cmi contrib/cc/ccalgo.cmi 
+    tactics/tacinterp.cmi kernel/sign.cmi proofs/proof_type.cmi lib/pp.cmi \
+    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
+    pretyping/inductiveops.cmi library/global.cmi pretyping/evd.cmi \
+    kernel/environ.cmi kernel/declarations.cmi interp/coqlib.cmi \
+    kernel/closure.cmi contrib/cc/ccproof.cmi contrib/cc/ccalgo.cmi \
+    contrib/cc/cctac.cmi 
 contrib/cc/cctac.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
     tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \
-    tactics/tacinterp.cmx proofs/tacexpr.cmx kernel/sign.cmx \
-    proofs/refiner.cmx proofs/proof_type.cmx parsing/pptactic.cmx lib/pp.cmx \
-    parsing/pcoq.cmx lib/options.cmx kernel/names.cmx library/nameops.cmx \
-    library/library.cmx library/libnames.cmx pretyping/inductiveops.cmx \
-    kernel/inductive.cmx library/global.cmx pretyping/evd.cmx \
-    parsing/egrammar.cmx kernel/declarations.cmx interp/coqlib.cmx \
-    toplevel/cerrors.cmx contrib/cc/ccproof.cmx contrib/cc/ccalgo.cmx 
+    tactics/tacinterp.cmx kernel/sign.cmx proofs/proof_type.cmx lib/pp.cmx \
+    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
+    pretyping/inductiveops.cmx library/global.cmx pretyping/evd.cmx \
+    kernel/environ.cmx kernel/declarations.cmx interp/coqlib.cmx \
+    kernel/closure.cmx contrib/cc/ccproof.cmx contrib/cc/ccalgo.cmx \
+    contrib/cc/cctac.cmi 
+contrib/cc/g_congruence.cmo: lib/util.cmi tactics/tactics.cmi \
+    tactics/tacticals.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
+    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi interp/genarg.cmi \
+    parsing/egrammar.cmi toplevel/cerrors.cmi contrib/cc/cctac.cmi 
+contrib/cc/g_congruence.cmx: lib/util.cmx tactics/tactics.cmx \
+    tactics/tacticals.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
+    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx interp/genarg.cmx \
+    parsing/egrammar.cmx toplevel/cerrors.cmx contrib/cc/cctac.cmx 
 contrib/correctness/pcic.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
     kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \
     kernel/term.cmi kernel/sign.cmi toplevel/record.cmi pretyping/rawterm.cmi \
@@ -2390,13 +2577,13 @@ contrib/correctness/pextract.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
     kernel/term.cmi lib/system.cmi pretyping/reductionops.cmi \
     kernel/reduction.cmi lib/pp_control.cmi lib/pp.cmi \
     contrib/extraction/ocaml.cmi library/nametab.cmi kernel/names.cmi \
-    library/library.cmi toplevel/himsg.cmi pretyping/evd.cmi parsing/ast.cmi \
+    library/library.cmi toplevel/himsg.cmi pretyping/evd.cmi \
     contrib/correctness/pextract.cmi 
 contrib/correctness/pextract.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
     kernel/term.cmx lib/system.cmx pretyping/reductionops.cmx \
     kernel/reduction.cmx lib/pp_control.cmx lib/pp.cmx \
     contrib/extraction/ocaml.cmx library/nametab.cmx kernel/names.cmx \
-    library/library.cmx toplevel/himsg.cmx pretyping/evd.cmx parsing/ast.cmx \
+    library/library.cmx toplevel/himsg.cmx pretyping/evd.cmx \
     contrib/correctness/pextract.cmi 
 contrib/correctness/pmisc.cmo: lib/util.cmi interp/topconstr.cmi \
     kernel/term.cmi lib/pp.cmi lib/options.cmi kernel/names.cmi \
@@ -2409,19 +2596,17 @@ contrib/correctness/pmisc.cmx: lib/util.cmx interp/topconstr.cmx \
     pretyping/evarutil.cmx interp/constrintern.cmx interp/constrextern.cmx \
     contrib/correctness/pmisc.cmi 
 contrib/correctness/pmlize.cmo: lib/util.cmi pretyping/typing.cmi \
-    parsing/termast.cmi kernel/term.cmi pretyping/reductionops.cmi \
-    pretyping/pattern.cmi kernel/names.cmi pretyping/matching.cmi \
-    tactics/hipattern.cmi library/global.cmi pretyping/evd.cmi \
-    contrib/correctness/pmlize.cmi 
+    kernel/term.cmi pretyping/reductionops.cmi pretyping/pattern.cmi \
+    kernel/names.cmi pretyping/matching.cmi tactics/hipattern.cmi \
+    library/global.cmi pretyping/evd.cmi contrib/correctness/pmlize.cmi 
 contrib/correctness/pmlize.cmx: lib/util.cmx pretyping/typing.cmx \
-    parsing/termast.cmx kernel/term.cmx pretyping/reductionops.cmx \
-    pretyping/pattern.cmx kernel/names.cmx pretyping/matching.cmx \
-    tactics/hipattern.cmx library/global.cmx pretyping/evd.cmx \
-    contrib/correctness/pmlize.cmi 
-contrib/correctness/pmonad.cmo: lib/util.cmi parsing/termast.cmi \
-    kernel/term.cmi kernel/names.cmi contrib/correctness/pmonad.cmi 
-contrib/correctness/pmonad.cmx: lib/util.cmx parsing/termast.cmx \
-    kernel/term.cmx kernel/names.cmx contrib/correctness/pmonad.cmi 
+    kernel/term.cmx pretyping/reductionops.cmx pretyping/pattern.cmx \
+    kernel/names.cmx pretyping/matching.cmx tactics/hipattern.cmx \
+    library/global.cmx pretyping/evd.cmx contrib/correctness/pmlize.cmi 
+contrib/correctness/pmonad.cmo: lib/util.cmi kernel/term.cmi kernel/names.cmi \
+    contrib/correctness/pmonad.cmi 
+contrib/correctness/pmonad.cmx: lib/util.cmx kernel/term.cmx kernel/names.cmx \
+    contrib/correctness/pmonad.cmi 
 contrib/correctness/pred.cmo: kernel/term.cmi pretyping/reductionops.cmi \
     lib/pp.cmi library/global.cmi pretyping/evd.cmi \
     contrib/correctness/pred.cmi 
@@ -2437,18 +2622,18 @@ contrib/correctness/ptactic.cmo: toplevel/vernacentries.cmi lib/util.cmi \
     tactics/tacticals.cmi proofs/tacmach.cmi kernel/reduction.cmi \
     parsing/printer.cmi pretyping/pretyping.cmi lib/pp.cmi proofs/pfedit.cmi \
     pretyping/pattern.cmi lib/options.cmi library/nametab.cmi \
-    kernel/names.cmi library/nameops.cmi library/library.cmi \
-    library/libnames.cmi library/global.cmi tactics/extratactics.cmi \
-    pretyping/evd.cmi tactics/equality.cmi library/decl_kinds.cmo \
+    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
+    library/global.cmi tactics/extratactics.cmi pretyping/evd.cmi \
+    tactics/equality.cmi library/decl_kinds.cmo interp/coqlib.cmi \
     contrib/correctness/ptactic.cmi 
 contrib/correctness/ptactic.cmx: toplevel/vernacentries.cmx lib/util.cmx \
     pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
     tactics/tacticals.cmx proofs/tacmach.cmx kernel/reduction.cmx \
     parsing/printer.cmx pretyping/pretyping.cmx lib/pp.cmx proofs/pfedit.cmx \
     pretyping/pattern.cmx lib/options.cmx library/nametab.cmx \
-    kernel/names.cmx library/nameops.cmx library/library.cmx \
-    library/libnames.cmx library/global.cmx tactics/extratactics.cmx \
-    pretyping/evd.cmx tactics/equality.cmx library/decl_kinds.cmx \
+    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
+    library/global.cmx tactics/extratactics.cmx pretyping/evd.cmx \
+    tactics/equality.cmx library/decl_kinds.cmx interp/coqlib.cmx \
     contrib/correctness/ptactic.cmi 
 contrib/correctness/ptyping.cmo: lib/util.cmi pretyping/typing.cmi \
     interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \
@@ -2482,70 +2667,108 @@ contrib/correctness/pwp.cmx: lib/util.cmx pretyping/termops.cmx \
     library/nametab.cmx kernel/names.cmx library/libnames.cmx \
     tactics/hipattern.cmx library/global.cmx kernel/environ.cmx \
     contrib/correctness/pwp.cmi 
+contrib/dp/dp.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
+    proofs/tacmach.cmi library/summary.cmi pretyping/reductionops.cmi \
+    parsing/printer.cmi lib/pp.cmi library/nametab.cmi kernel/names.cmi \
+    library/nameops.cmi library/libnames.cmi tactics/hipattern.cmi \
+    library/global.cmi contrib/dp/fol.cmi pretyping/evd.cmi \
+    kernel/environ.cmi contrib/dp/dp_why.cmo kernel/declarations.cmi \
+    interp/coqlib.cmi contrib/dp/dp.cmi 
+contrib/dp/dp.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
+    proofs/tacmach.cmx library/summary.cmx pretyping/reductionops.cmx \
+    parsing/printer.cmx lib/pp.cmx library/nametab.cmx kernel/names.cmx \
+    library/nameops.cmx library/libnames.cmx tactics/hipattern.cmx \
+    library/global.cmx contrib/dp/fol.cmi pretyping/evd.cmx \
+    kernel/environ.cmx contrib/dp/dp_why.cmx kernel/declarations.cmx \
+    interp/coqlib.cmx contrib/dp/dp.cmi 
+contrib/dp/dp_cvcl.cmo: contrib/dp/fol.cmi contrib/dp/dp_cvcl.cmi 
+contrib/dp/dp_cvcl.cmx: contrib/dp/fol.cmi contrib/dp/dp_cvcl.cmi 
+contrib/dp/dp_simplify.cmo: contrib/dp/fol.cmi contrib/dp/dp_simplify.cmi 
+contrib/dp/dp_simplify.cmx: contrib/dp/fol.cmi contrib/dp/dp_simplify.cmi 
+contrib/dp/dp_sorts.cmo: contrib/dp/fol.cmi contrib/dp/dp_sorts.cmi 
+contrib/dp/dp_sorts.cmx: contrib/dp/fol.cmi contrib/dp/dp_sorts.cmi 
+contrib/dp/dp_why.cmo: contrib/dp/fol.cmi 
+contrib/dp/dp_why.cmx: contrib/dp/fol.cmi 
+contrib/dp/dp_zenon.cmo: lib/util.cmi contrib/dp/fol.cmi \
+    contrib/dp/dp_zenon.cmi 
+contrib/dp/dp_zenon.cmx: lib/util.cmx contrib/dp/fol.cmi \
+    contrib/dp/dp_zenon.cmi 
+contrib/dp/g_dp.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
+    tactics/tactics.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
+    proofs/refiner.cmi parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi \
+    interp/genarg.cmi parsing/egrammar.cmi contrib/dp/dp.cmi \
+    toplevel/cerrors.cmi 
+contrib/dp/g_dp.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
+    tactics/tactics.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
+    proofs/refiner.cmx parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx \
+    interp/genarg.cmx parsing/egrammar.cmx contrib/dp/dp.cmx \
+    toplevel/cerrors.cmx 
 contrib/extraction/common.cmo: lib/util.cmi kernel/term.cmi \
     contrib/extraction/table.cmi contrib/extraction/scheme.cmi \
     lib/pp_control.cmi lib/pp.cmi lib/options.cmi \
     contrib/extraction/ocaml.cmi kernel/names.cmi library/nameops.cmi \
     contrib/extraction/modutil.cmi kernel/modops.cmi \
-    contrib/extraction/miniml.cmi library/libnames.cmi \
-    contrib/extraction/haskell.cmi lib/gset.cmi library/global.cmi \
-    contrib/extraction/extraction.cmi kernel/declarations.cmi \
-    contrib/extraction/common.cmi 
+    contrib/extraction/mlutil.cmi contrib/extraction/miniml.cmi \
+    library/libnames.cmi kernel/inductive.cmi contrib/extraction/haskell.cmi \
+    lib/gset.cmi library/global.cmi contrib/extraction/extraction.cmi \
+    kernel/declarations.cmi contrib/extraction/common.cmi 
 contrib/extraction/common.cmx: lib/util.cmx kernel/term.cmx \
     contrib/extraction/table.cmx contrib/extraction/scheme.cmx \
     lib/pp_control.cmx lib/pp.cmx lib/options.cmx \
     contrib/extraction/ocaml.cmx kernel/names.cmx library/nameops.cmx \
     contrib/extraction/modutil.cmx kernel/modops.cmx \
-    contrib/extraction/miniml.cmi library/libnames.cmx \
-    contrib/extraction/haskell.cmx lib/gset.cmx library/global.cmx \
+    contrib/extraction/mlutil.cmx contrib/extraction/miniml.cmi \
+    library/libnames.cmx kernel/inductive.cmx contrib/extraction/haskell.cmx \
+    lib/gset.cmx library/global.cmx contrib/extraction/extraction.cmx \
+    kernel/declarations.cmx contrib/extraction/common.cmi 
+contrib/extraction/extract_env.cmo: lib/util.cmi kernel/typeops.cmi \
+    kernel/term.cmi contrib/extraction/table.cmi kernel/reduction.cmi \
+    lib/pp.cmi library/nametab.cmi kernel/names.cmi \
+    contrib/extraction/modutil.cmi kernel/modops.cmi kernel/mod_subst.cmi \
+    contrib/extraction/miniml.cmi library/library.cmi library/libobject.cmi \
+    library/libnames.cmi library/lib.cmi library/global.cmi \
+    contrib/extraction/extraction.cmi kernel/declarations.cmi \
+    contrib/extraction/common.cmi contrib/extraction/extract_env.cmi 
+contrib/extraction/extract_env.cmx: lib/util.cmx kernel/typeops.cmx \
+    kernel/term.cmx contrib/extraction/table.cmx kernel/reduction.cmx \
+    lib/pp.cmx library/nametab.cmx kernel/names.cmx \
+    contrib/extraction/modutil.cmx kernel/modops.cmx kernel/mod_subst.cmx \
+    contrib/extraction/miniml.cmi library/library.cmx library/libobject.cmx \
+    library/libnames.cmx library/lib.cmx library/global.cmx \
     contrib/extraction/extraction.cmx kernel/declarations.cmx \
-    contrib/extraction/common.cmi 
-contrib/extraction/extract_env.cmo: lib/util.cmi kernel/term.cmi \
-    contrib/extraction/table.cmi kernel/reduction.cmi lib/pp.cmi \
-    library/nametab.cmi kernel/names.cmi contrib/extraction/modutil.cmi \
-    kernel/modops.cmi contrib/extraction/miniml.cmi library/library.cmi \
-    library/libobject.cmi library/libnames.cmi library/lib.cmi \
-    library/global.cmi contrib/extraction/extraction.cmi \
-    kernel/declarations.cmi contrib/extraction/common.cmi \
-    contrib/extraction/extract_env.cmi 
-contrib/extraction/extract_env.cmx: lib/util.cmx kernel/term.cmx \
-    contrib/extraction/table.cmx kernel/reduction.cmx lib/pp.cmx \
-    library/nametab.cmx kernel/names.cmx contrib/extraction/modutil.cmx \
-    kernel/modops.cmx contrib/extraction/miniml.cmi library/library.cmx \
-    library/libobject.cmx library/libnames.cmx library/lib.cmx \
-    library/global.cmx contrib/extraction/extraction.cmx \
-    kernel/declarations.cmx contrib/extraction/common.cmx \
-    contrib/extraction/extract_env.cmi 
-contrib/extraction/extraction.cmo: lib/util.cmi pretyping/termops.cmi \
-    kernel/term.cmi contrib/extraction/table.cmi library/summary.cmi \
-    pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
-    pretyping/recordops.cmi library/nametab.cmi kernel/names.cmi \
-    library/nameops.cmi contrib/extraction/mlutil.cmi \
+    contrib/extraction/common.cmx contrib/extraction/extract_env.cmi 
+contrib/extraction/extraction.cmo: lib/util.cmi kernel/typeops.cmi \
+    pretyping/termops.cmi kernel/term.cmi contrib/extraction/table.cmi \
+    library/summary.cmi pretyping/retyping.cmi pretyping/reductionops.cmi \
+    kernel/reduction.cmi pretyping/recordops.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi contrib/extraction/mlutil.cmi \
     contrib/extraction/miniml.cmi library/libnames.cmi \
     pretyping/inductiveops.cmi kernel/inductive.cmi pretyping/evd.cmi \
     kernel/environ.cmi kernel/declarations.cmi \
     contrib/extraction/extraction.cmi 
-contrib/extraction/extraction.cmx: lib/util.cmx pretyping/termops.cmx \
-    kernel/term.cmx contrib/extraction/table.cmx library/summary.cmx \
-    pretyping/retyping.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
-    pretyping/recordops.cmx library/nametab.cmx kernel/names.cmx \
-    library/nameops.cmx contrib/extraction/mlutil.cmx \
+contrib/extraction/extraction.cmx: lib/util.cmx kernel/typeops.cmx \
+    pretyping/termops.cmx kernel/term.cmx contrib/extraction/table.cmx \
+    library/summary.cmx pretyping/retyping.cmx pretyping/reductionops.cmx \
+    kernel/reduction.cmx pretyping/recordops.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx contrib/extraction/mlutil.cmx \
     contrib/extraction/miniml.cmi library/libnames.cmx \
     pretyping/inductiveops.cmx kernel/inductive.cmx pretyping/evd.cmx \
     kernel/environ.cmx kernel/declarations.cmx \
     contrib/extraction/extraction.cmi 
 contrib/extraction/g_extraction.cmo: toplevel/vernacinterp.cmi \
     toplevel/vernacexpr.cmo lib/util.cmi tactics/tacinterp.cmi \
-    contrib/extraction/table.cmi translate/pptacticnew.cmi \
-    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    interp/genarg.cmi contrib/extraction/extract_env.cmi parsing/extend.cmi \
-    parsing/egrammar.cmi toplevel/cerrors.cmi 
+    contrib/extraction/table.cmi parsing/pptactic.cmi lib/pp.cmi \
+    parsing/pcoq.cmi parsing/lexer.cmi interp/genarg.cmi \
+    contrib/extraction/extract_env.cmi parsing/egrammar.cmi \
+    toplevel/cerrors.cmi 
 contrib/extraction/g_extraction.cmx: toplevel/vernacinterp.cmx \
     toplevel/vernacexpr.cmx lib/util.cmx tactics/tacinterp.cmx \
-    contrib/extraction/table.cmx translate/pptacticnew.cmx \
-    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    interp/genarg.cmx contrib/extraction/extract_env.cmx parsing/extend.cmx \
-    parsing/egrammar.cmx toplevel/cerrors.cmx 
+    contrib/extraction/table.cmx parsing/pptactic.cmx lib/pp.cmx \
+    parsing/pcoq.cmx parsing/lexer.cmx interp/genarg.cmx \
+    contrib/extraction/extract_env.cmx parsing/egrammar.cmx \
+    toplevel/cerrors.cmx 
 contrib/extraction/haskell.cmo: lib/util.cmi contrib/extraction/table.cmi \
     lib/pp.cmi contrib/extraction/ocaml.cmi kernel/names.cmi \
     library/nameops.cmi contrib/extraction/mlutil.cmi \
@@ -2565,13 +2788,15 @@ contrib/extraction/mlutil.cmx: lib/util.cmx contrib/extraction/table.cmx \
     contrib/extraction/miniml.cmi library/libnames.cmx \
     contrib/extraction/mlutil.cmi 
 contrib/extraction/modutil.cmo: lib/util.cmi contrib/extraction/table.cmi \
-    kernel/names.cmi kernel/modops.cmi contrib/extraction/mlutil.cmi \
-    contrib/extraction/miniml.cmi library/libnames.cmi kernel/environ.cmi \
-    kernel/declarations.cmi contrib/extraction/modutil.cmi 
+    kernel/names.cmi kernel/modops.cmi kernel/mod_subst.cmi \
+    contrib/extraction/mlutil.cmi contrib/extraction/miniml.cmi \
+    library/libnames.cmi kernel/environ.cmi kernel/declarations.cmi \
+    contrib/extraction/modutil.cmi 
 contrib/extraction/modutil.cmx: lib/util.cmx contrib/extraction/table.cmx \
-    kernel/names.cmx kernel/modops.cmx contrib/extraction/mlutil.cmx \
-    contrib/extraction/miniml.cmi library/libnames.cmx kernel/environ.cmx \
-    kernel/declarations.cmx contrib/extraction/modutil.cmi 
+    kernel/names.cmx kernel/modops.cmx kernel/mod_subst.cmx \
+    contrib/extraction/mlutil.cmx contrib/extraction/miniml.cmi \
+    library/libnames.cmx kernel/environ.cmx kernel/declarations.cmx \
+    contrib/extraction/modutil.cmi 
 contrib/extraction/ocaml.cmo: lib/util.cmi contrib/extraction/table.cmi \
     lib/pp.cmi kernel/names.cmi library/nameops.cmi \
     contrib/extraction/modutil.cmi contrib/extraction/mlutil.cmi \
@@ -2592,13 +2817,13 @@ contrib/extraction/scheme.cmx: lib/util.cmx contrib/extraction/table.cmx \
     library/nameops.cmx contrib/extraction/mlutil.cmx \
     contrib/extraction/miniml.cmi library/libnames.cmx \
     contrib/extraction/scheme.cmi 
-contrib/extraction/table.cmo: lib/util.cmi kernel/term.cmi \
+contrib/extraction/table.cmo: lib/util.cmi kernel/typeops.cmi kernel/term.cmi \
     library/summary.cmi kernel/reduction.cmi parsing/printer.cmi lib/pp.cmi \
     lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
     contrib/extraction/miniml.cmi library/libobject.cmi library/libnames.cmi \
     library/lib.cmi library/goptions.cmi library/global.cmi \
     kernel/environ.cmi kernel/declarations.cmi contrib/extraction/table.cmi 
-contrib/extraction/table.cmx: lib/util.cmx kernel/term.cmx \
+contrib/extraction/table.cmx: lib/util.cmx kernel/typeops.cmx kernel/term.cmx \
     library/summary.cmx kernel/reduction.cmx parsing/printer.cmx lib/pp.cmx \
     lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
     contrib/extraction/miniml.cmi library/libobject.cmx library/libnames.cmx \
@@ -2608,63 +2833,65 @@ contrib/field/field.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
     lib/util.cmi pretyping/typing.cmi interp/topconstr.cmi kernel/term.cmi \
     tactics/tacticals.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
     proofs/tacexpr.cmo library/summary.cmi contrib/ring/ring.cmo \
-    proofs/refiner.cmi pretyping/reductionops.cmi contrib/ring/quote.cmo \
-    proofs/proof_type.cmi parsing/printer.cmi parsing/pptactic.cmi \
-    translate/ppconstrnew.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    kernel/names.cmi library/library.cmi library/libobject.cmi \
-    library/libnames.cmi library/lib.cmi tactics/hipattern.cmi lib/gmap.cmi \
-    library/global.cmi interp/genarg.cmi parsing/extend.cmi pretyping/evd.cmi \
+    pretyping/reductionops.cmi contrib/ring/quote.cmo proofs/proof_type.cmi \
+    parsing/printer.cmi parsing/pptactic.cmi parsing/ppconstr.cmi lib/pp.cmi \
+    parsing/pcoq.cmi kernel/names.cmi kernel/mod_subst.cmi \
+    library/libobject.cmi library/libnames.cmi library/lib.cmi \
+    parsing/lexer.cmi tactics/hipattern.cmi lib/gmap.cmi library/global.cmi \
+    interp/genarg.cmi parsing/extend.cmi pretyping/evd.cmi \
     parsing/egrammar.cmi interp/coqlib.cmi interp/constrintern.cmi \
     toplevel/cerrors.cmi 
 contrib/field/field.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \
     lib/util.cmx pretyping/typing.cmx interp/topconstr.cmx kernel/term.cmx \
     tactics/tacticals.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
     proofs/tacexpr.cmx library/summary.cmx contrib/ring/ring.cmx \
-    proofs/refiner.cmx pretyping/reductionops.cmx contrib/ring/quote.cmx \
-    proofs/proof_type.cmx parsing/printer.cmx parsing/pptactic.cmx \
-    translate/ppconstrnew.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    kernel/names.cmx library/library.cmx library/libobject.cmx \
-    library/libnames.cmx library/lib.cmx tactics/hipattern.cmx lib/gmap.cmx \
-    library/global.cmx interp/genarg.cmx parsing/extend.cmx pretyping/evd.cmx \
+    pretyping/reductionops.cmx contrib/ring/quote.cmx proofs/proof_type.cmx \
+    parsing/printer.cmx parsing/pptactic.cmx parsing/ppconstr.cmx lib/pp.cmx \
+    parsing/pcoq.cmx kernel/names.cmx kernel/mod_subst.cmx \
+    library/libobject.cmx library/libnames.cmx library/lib.cmx \
+    parsing/lexer.cmx tactics/hipattern.cmx lib/gmap.cmx library/global.cmx \
+    interp/genarg.cmx parsing/extend.cmx pretyping/evd.cmx \
     parsing/egrammar.cmx interp/coqlib.cmx interp/constrintern.cmx \
     toplevel/cerrors.cmx 
 contrib/first-order/formula.cmo: lib/util.cmi pretyping/termops.cmi \
     kernel/term.cmi proofs/tacmach.cmi kernel/sign.cmi \
     pretyping/reductionops.cmi kernel/names.cmi library/libnames.cmi \
-    pretyping/inductiveops.cmi kernel/inductive.cmi tactics/hipattern.cmi \
-    library/global.cmi kernel/declarations.cmi kernel/closure.cmi \
+    pretyping/inductiveops.cmi tactics/hipattern.cmi library/global.cmi \
+    kernel/declarations.cmi kernel/closure.cmi \
     contrib/first-order/formula.cmi 
 contrib/first-order/formula.cmx: lib/util.cmx pretyping/termops.cmx \
     kernel/term.cmx proofs/tacmach.cmx kernel/sign.cmx \
     pretyping/reductionops.cmx kernel/names.cmx library/libnames.cmx \
-    pretyping/inductiveops.cmx kernel/inductive.cmx tactics/hipattern.cmx \
-    library/global.cmx kernel/declarations.cmx kernel/closure.cmx \
+    pretyping/inductiveops.cmx tactics/hipattern.cmx library/global.cmx \
+    kernel/declarations.cmx kernel/closure.cmx \
     contrib/first-order/formula.cmi 
 contrib/first-order/g_ground.cmo: lib/util.cmi kernel/term.cmi \
     tactics/tactics.cmi tactics/tacticals.cmi tactics/tacinterp.cmi \
     proofs/tacexpr.cmo contrib/first-order/sequent.cmi proofs/refiner.cmi \
-    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    kernel/names.cmi library/libnames.cmi contrib/first-order/ground.cmi \
-    library/goptions.cmi interp/genarg.cmi contrib/first-order/formula.cmi \
-    parsing/egrammar.cmi toplevel/cerrors.cmi tactics/auto.cmi 
+    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi \
+    library/libnames.cmi contrib/first-order/ground.cmi library/goptions.cmi \
+    interp/genarg.cmi contrib/first-order/formula.cmi parsing/egrammar.cmi \
+    tactics/decl_proof_instr.cmi toplevel/cerrors.cmi contrib/cc/cctac.cmi \
+    tactics/auto.cmi 
 contrib/first-order/g_ground.cmx: lib/util.cmx kernel/term.cmx \
     tactics/tactics.cmx tactics/tacticals.cmx tactics/tacinterp.cmx \
     proofs/tacexpr.cmx contrib/first-order/sequent.cmx proofs/refiner.cmx \
-    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    kernel/names.cmx library/libnames.cmx contrib/first-order/ground.cmx \
-    library/goptions.cmx interp/genarg.cmx contrib/first-order/formula.cmx \
-    parsing/egrammar.cmx toplevel/cerrors.cmx tactics/auto.cmx 
+    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \
+    library/libnames.cmx contrib/first-order/ground.cmx library/goptions.cmx \
+    interp/genarg.cmx contrib/first-order/formula.cmx parsing/egrammar.cmx \
+    tactics/decl_proof_instr.cmx toplevel/cerrors.cmx contrib/cc/cctac.cmx \
+    tactics/auto.cmx 
 contrib/first-order/ground.cmo: kernel/term.cmi tactics/tactics.cmi \
     tactics/tacticals.cmi proofs/tactic_debug.cmi proofs/tacmach.cmi \
     tactics/tacinterp.cmi contrib/first-order/sequent.cmi \
-    contrib/first-order/rules.cmi proofs/proof_trees.cmi lib/pp.cmi \
+    contrib/first-order/rules.cmi parsing/printer.cmi lib/pp.cmi \
     kernel/names.cmi library/libnames.cmi contrib/first-order/instances.cmi \
     lib/heap.cmi contrib/first-order/formula.cmi kernel/closure.cmi \
     pretyping/classops.cmi contrib/first-order/ground.cmi 
 contrib/first-order/ground.cmx: kernel/term.cmx tactics/tactics.cmx \
     tactics/tacticals.cmx proofs/tactic_debug.cmx proofs/tacmach.cmx \
     tactics/tacinterp.cmx contrib/first-order/sequent.cmx \
-    contrib/first-order/rules.cmx proofs/proof_trees.cmx lib/pp.cmx \
+    contrib/first-order/rules.cmx parsing/printer.cmx lib/pp.cmx \
     kernel/names.cmx library/libnames.cmx contrib/first-order/instances.cmx \
     lib/heap.cmx contrib/first-order/formula.cmx kernel/closure.cmx \
     pretyping/classops.cmx contrib/first-order/ground.cmi 
@@ -2673,39 +2900,41 @@ contrib/first-order/instances.cmo: lib/util.cmi contrib/first-order/unify.cmi \
     tactics/tacticals.cmi proofs/tacmach.cmi kernel/sign.cmi \
     contrib/first-order/sequent.cmi contrib/first-order/rules.cmi \
     proofs/refiner.cmi pretyping/reductionops.cmi pretyping/rawterm.cmi \
-    pretyping/pretyping.cmi kernel/names.cmi library/libnames.cmi \
-    lib/heap.cmi contrib/first-order/formula.cmi pretyping/detyping.cmi \
-    kernel/declarations.cmi contrib/first-order/instances.cmi 
+    pretyping/pretyping.cmi lib/pp.cmi kernel/names.cmi library/libnames.cmi \
+    lib/heap.cmi contrib/first-order/formula.cmi pretyping/evd.cmi \
+    pretyping/detyping.cmi kernel/declarations.cmi \
+    contrib/first-order/instances.cmi 
 contrib/first-order/instances.cmx: lib/util.cmx contrib/first-order/unify.cmx \
     pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
     tactics/tacticals.cmx proofs/tacmach.cmx kernel/sign.cmx \
     contrib/first-order/sequent.cmx contrib/first-order/rules.cmx \
     proofs/refiner.cmx pretyping/reductionops.cmx pretyping/rawterm.cmx \
-    pretyping/pretyping.cmx kernel/names.cmx library/libnames.cmx \
-    lib/heap.cmx contrib/first-order/formula.cmx pretyping/detyping.cmx \
-    kernel/declarations.cmx contrib/first-order/instances.cmi 
+    pretyping/pretyping.cmx lib/pp.cmx kernel/names.cmx library/libnames.cmx \
+    lib/heap.cmx contrib/first-order/formula.cmx pretyping/evd.cmx \
+    pretyping/detyping.cmx kernel/declarations.cmx \
+    contrib/first-order/instances.cmi 
 contrib/first-order/rules.cmo: lib/util.cmi pretyping/termops.cmi \
     kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
     proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi \
-    contrib/first-order/sequent.cmi kernel/names.cmi library/libnames.cmi \
-    contrib/first-order/formula.cmi kernel/declarations.cmi interp/coqlib.cmi \
-    contrib/first-order/rules.cmi 
+    contrib/first-order/sequent.cmi lib/pp.cmi kernel/names.cmi \
+    library/libnames.cmi contrib/first-order/formula.cmi \
+    kernel/declarations.cmi interp/coqlib.cmi contrib/first-order/rules.cmi 
 contrib/first-order/rules.cmx: lib/util.cmx pretyping/termops.cmx \
     kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
     proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx \
-    contrib/first-order/sequent.cmx kernel/names.cmx library/libnames.cmx \
-    contrib/first-order/formula.cmx kernel/declarations.cmx interp/coqlib.cmx \
-    contrib/first-order/rules.cmi 
+    contrib/first-order/sequent.cmx lib/pp.cmx kernel/names.cmx \
+    library/libnames.cmx contrib/first-order/formula.cmx \
+    kernel/declarations.cmx interp/coqlib.cmx contrib/first-order/rules.cmi 
 contrib/first-order/sequent.cmo: lib/util.cmi contrib/first-order/unify.cmi \
-    kernel/term.cmi proofs/tacmach.cmi parsing/ppconstr.cmi lib/pp.cmi \
-    kernel/names.cmi library/libnames.cmi lib/heap.cmi library/global.cmi \
-    contrib/first-order/formula.cmi interp/constrextern.cmi tactics/auto.cmi \
-    contrib/first-order/sequent.cmi 
+    kernel/term.cmi proofs/tacmach.cmi parsing/printer.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi kernel/names.cmi library/libnames.cmi \
+    lib/heap.cmi library/global.cmi contrib/first-order/formula.cmi \
+    interp/constrextern.cmi tactics/auto.cmi contrib/first-order/sequent.cmi 
 contrib/first-order/sequent.cmx: lib/util.cmx contrib/first-order/unify.cmx \
-    kernel/term.cmx proofs/tacmach.cmx parsing/ppconstr.cmx lib/pp.cmx \
-    kernel/names.cmx library/libnames.cmx lib/heap.cmx library/global.cmx \
-    contrib/first-order/formula.cmx interp/constrextern.cmx tactics/auto.cmx \
-    contrib/first-order/sequent.cmi 
+    kernel/term.cmx proofs/tacmach.cmx parsing/printer.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx kernel/names.cmx library/libnames.cmx \
+    lib/heap.cmx library/global.cmx contrib/first-order/formula.cmx \
+    interp/constrextern.cmx tactics/auto.cmx contrib/first-order/sequent.cmi 
 contrib/first-order/unify.cmo: lib/util.cmi pretyping/termops.cmi \
     kernel/term.cmi proofs/tacmach.cmi pretyping/reductionops.cmi \
     kernel/names.cmi contrib/first-order/formula.cmi \
@@ -2717,23 +2946,235 @@ contrib/first-order/unify.cmx: lib/util.cmx pretyping/termops.cmx \
 contrib/fourier/fourierR.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
     kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
     proofs/tacmach.cmi contrib/ring/ring.cmo kernel/names.cmi \
-    library/library.cmi library/libnames.cmi contrib/fourier/fourier.cmo \
+    library/libnames.cmi contrib/fourier/fourier.cmo pretyping/evarutil.cmi \
     tactics/equality.cmi interp/coqlib.cmi tactics/contradiction.cmi \
-    proofs/clenv.cmi 
+    pretyping/clenv.cmi 
 contrib/fourier/fourierR.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
     kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
     proofs/tacmach.cmx contrib/ring/ring.cmx kernel/names.cmx \
-    library/library.cmx library/libnames.cmx contrib/fourier/fourier.cmx \
+    library/libnames.cmx contrib/fourier/fourier.cmx pretyping/evarutil.cmx \
     tactics/equality.cmx interp/coqlib.cmx tactics/contradiction.cmx \
-    proofs/clenv.cmx 
+    pretyping/clenv.cmx 
 contrib/fourier/g_fourier.cmo: lib/util.cmi tactics/tacinterp.cmi \
     proofs/tacexpr.cmo proofs/refiner.cmi parsing/pptactic.cmi lib/pp.cmi \
-    parsing/pcoq.cmi lib/options.cmi contrib/fourier/fourierR.cmo \
-    parsing/egrammar.cmi toplevel/cerrors.cmi 
+    parsing/pcoq.cmi contrib/fourier/fourierR.cmo parsing/egrammar.cmi \
+    toplevel/cerrors.cmi 
 contrib/fourier/g_fourier.cmx: lib/util.cmx tactics/tacinterp.cmx \
     proofs/tacexpr.cmx proofs/refiner.cmx parsing/pptactic.cmx lib/pp.cmx \
-    parsing/pcoq.cmx lib/options.cmx contrib/fourier/fourierR.cmx \
-    parsing/egrammar.cmx toplevel/cerrors.cmx 
+    parsing/pcoq.cmx contrib/fourier/fourierR.cmx parsing/egrammar.cmx \
+    toplevel/cerrors.cmx 
+contrib/funind/functional_principles_proofs.cmo: lib/util.cmi \
+    pretyping/typing.cmi kernel/typeops.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
+    pretyping/tacred.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
+    kernel/sign.cmi pretyping/reductionops.cmi contrib/recdef/recdef.cmo \
+    pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
+    lib/pp.cmi proofs/pfedit.cmi lib/options.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
+    contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \
+    interp/genarg.cmi pretyping/evd.cmi tactics/equality.cmi \
+    kernel/environ.cmi kernel/entries.cmi tactics/elim.cmi tactics/eauto.cmi \
+    kernel/declarations.cmi library/decl_kinds.cmo interp/coqlib.cmi \
+    toplevel/command.cmi kernel/closure.cmi toplevel/cerrors.cmi \
+    contrib/funind/functional_principles_proofs.cmi 
+contrib/funind/functional_principles_proofs.cmx: lib/util.cmx \
+    pretyping/typing.cmx kernel/typeops.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
+    pretyping/tacred.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
+    kernel/sign.cmx pretyping/reductionops.cmx contrib/recdef/recdef.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
+    lib/pp.cmx proofs/pfedit.cmx lib/options.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
+    contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \
+    interp/genarg.cmx pretyping/evd.cmx tactics/equality.cmx \
+    kernel/environ.cmx kernel/entries.cmx tactics/elim.cmx tactics/eauto.cmx \
+    kernel/declarations.cmx library/decl_kinds.cmx interp/coqlib.cmx \
+    toplevel/command.cmx kernel/closure.cmx toplevel/cerrors.cmx \
+    contrib/funind/functional_principles_proofs.cmi 
+contrib/funind/functional_principles_types.cmo: lib/util.cmi \
+    pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
+    tactics/tactics.cmi tactics/tacticals.cmi pretyping/tacred.cmi \
+    proofs/tacmach.cmi tactics/tacinterp.cmi lib/system.cmi kernel/sign.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
+    pretyping/pretyping.cmi parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi \
+    lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi pretyping/indrec.cmi \
+    contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \
+    contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \
+    kernel/environ.cmi kernel/entries.cmi library/declare.cmi \
+    kernel/declarations.cmi library/decl_kinds.cmo toplevel/command.cmi \
+    kernel/closure.cmi contrib/funind/functional_principles_types.cmi 
+contrib/funind/functional_principles_types.cmx: lib/util.cmx \
+    pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
+    tactics/tactics.cmx tactics/tacticals.cmx pretyping/tacred.cmx \
+    proofs/tacmach.cmx tactics/tacinterp.cmx lib/system.cmx kernel/sign.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
+    pretyping/pretyping.cmx parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx \
+    lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx pretyping/indrec.cmx \
+    contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \
+    contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \
+    kernel/environ.cmx kernel/entries.cmx library/declare.cmx \
+    kernel/declarations.cmx library/decl_kinds.cmx toplevel/command.cmx \
+    kernel/closure.cmx contrib/funind/functional_principles_types.cmi 
+contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
+    kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
+    proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
+    library/states.cmi kernel/sign.cmi contrib/recdef/recdef.cmo \
+    contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi \
+    parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi \
+    interp/notation.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi contrib/funind/invfun.cmo pretyping/indrec.cmi \
+    contrib/funind/indfun_common.cmi library/impargs.cmi \
+    tactics/hiddentac.cmi library/global.cmi \
+    contrib/funind/functional_principles_types.cmi \
+    contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \
+    tactics/equality.cmi kernel/environ.cmi kernel/declarations.cmi \
+    library/decl_kinds.cmo interp/constrintern.cmi interp/constrextern.cmi \
+    toplevel/command.cmi toplevel/cerrors.cmi 
+contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    kernel/typeops.cmx interp/topconstr.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
+    proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
+    library/states.cmx kernel/sign.cmx contrib/recdef/recdef.cmx \
+    contrib/funind/rawterm_to_relation.cmx pretyping/rawterm.cmx \
+    parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx \
+    interp/notation.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx contrib/funind/invfun.cmx pretyping/indrec.cmx \
+    contrib/funind/indfun_common.cmx library/impargs.cmx \
+    tactics/hiddentac.cmx library/global.cmx \
+    contrib/funind/functional_principles_types.cmx \
+    contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \
+    tactics/equality.cmx kernel/environ.cmx kernel/declarations.cmx \
+    library/decl_kinds.cmx interp/constrintern.cmx interp/constrextern.cmx \
+    toplevel/command.cmx toplevel/cerrors.cmx 
+contrib/funind/indfun_common.cmo: lib/util.cmi pretyping/termops.cmi \
+    kernel/term.cmi library/summary.cmi proofs/refiner.cmi \
+    pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
+    parsing/printer.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    kernel/mod_subst.cmi library/libobject.cmi library/libnames.cmi \
+    library/lib.cmi library/impargs.cmi library/goptions.cmi \
+    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    kernel/entries.cmi library/declare.cmi kernel/declarations.cmi \
+    library/decl_kinds.cmo interp/coqlib.cmi kernel/closure.cmi \
+    contrib/funind/indfun_common.cmi 
+contrib/funind/indfun_common.cmx: lib/util.cmx pretyping/termops.cmx \
+    kernel/term.cmx library/summary.cmx proofs/refiner.cmx \
+    pretyping/reductionops.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
+    parsing/printer.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    kernel/mod_subst.cmx library/libobject.cmx library/libnames.cmx \
+    library/lib.cmx library/impargs.cmx library/goptions.cmx \
+    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    kernel/entries.cmx library/declare.cmx kernel/declarations.cmx \
+    library/decl_kinds.cmx interp/coqlib.cmx kernel/closure.cmx \
+    contrib/funind/indfun_common.cmi 
+contrib/funind/indfun_main.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
+    interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \
+    tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
+    tactics/tacinterp.cmi proofs/tacexpr.cmo proofs/refiner.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
+    parsing/pptactic.cmi parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi \
+    library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    contrib/funind/merge.cmo parsing/lexer.cmi contrib/funind/invfun.cmo \
+    contrib/funind/indfun_common.cmi contrib/funind/indfun.cmo \
+    library/global.cmi interp/genarg.cmi \
+    contrib/funind/functional_principles_types.cmi pretyping/evd.cmi \
+    parsing/egrammar.cmi interp/coqlib.cmi interp/constrintern.cmi \
+    toplevel/cerrors.cmi 
+contrib/funind/indfun_main.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
+    interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \
+    tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \
+    tactics/tacinterp.cmx proofs/tacexpr.cmx proofs/refiner.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
+    parsing/pptactic.cmx parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx \
+    library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    contrib/funind/merge.cmx parsing/lexer.cmx contrib/funind/invfun.cmx \
+    contrib/funind/indfun_common.cmx contrib/funind/indfun.cmx \
+    library/global.cmx interp/genarg.cmx \
+    contrib/funind/functional_principles_types.cmx pretyping/evd.cmx \
+    parsing/egrammar.cmx interp/coqlib.cmx interp/constrintern.cmx \
+    toplevel/cerrors.cmx 
+contrib/funind/invfun.cmo: toplevel/vernacentries.cmi lib/util.cmi \
+    pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
+    tactics/tauto.cmo tactics/tactics.cmi tactics/tacticals.cmi \
+    proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
+    kernel/sign.cmi lib/rtree.cmi pretyping/reductionops.cmi \
+    pretyping/rawterm.cmi parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi \
+    proofs/pfedit.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi tactics/inv.cmi kernel/inductive.cmi \
+    pretyping/indrec.cmi contrib/funind/indfun_common.cmi \
+    tactics/hiddentac.cmi library/global.cmi interp/genarg.cmi \
+    pretyping/evd.cmi tactics/equality.cmi kernel/environ.cmi \
+    kernel/entries.cmi kernel/declarations.cmi library/decl_kinds.cmo \
+    interp/coqlib.cmi toplevel/command.cmi kernel/closure.cmi \
+    toplevel/cerrors.cmi 
+contrib/funind/invfun.cmx: toplevel/vernacentries.cmx lib/util.cmx \
+    pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
+    tactics/tauto.cmx tactics/tactics.cmx tactics/tacticals.cmx \
+    proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
+    kernel/sign.cmx lib/rtree.cmx pretyping/reductionops.cmx \
+    pretyping/rawterm.cmx parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx \
+    proofs/pfedit.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx tactics/inv.cmx kernel/inductive.cmx \
+    pretyping/indrec.cmx contrib/funind/indfun_common.cmx \
+    tactics/hiddentac.cmx library/global.cmx interp/genarg.cmx \
+    pretyping/evd.cmx tactics/equality.cmx kernel/environ.cmx \
+    kernel/entries.cmx kernel/declarations.cmx library/decl_kinds.cmx \
+    interp/coqlib.cmx toplevel/command.cmx kernel/closure.cmx \
+    toplevel/cerrors.cmx 
+contrib/funind/merge.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
+    interp/topconstr.cmi kernel/term.cmi tactics/tacinterp.cmi \
+    contrib/funind/rawtermops.cmi pretyping/rawterm.cmi parsing/printer.cmi \
+    pretyping/pretyping.cmi lib/pp.cmi lib/options.cmi kernel/names.cmi \
+    library/nameops.cmi library/libnames.cmi pretyping/inductiveops.cmi \
+    kernel/inductive.cmi library/global.cmi pretyping/evd.cmi \
+    kernel/environ.cmi pretyping/detyping.cmi kernel/declarations.cmi \
+    interp/constrintern.cmi interp/constrextern.cmi toplevel/command.cmi 
+contrib/funind/merge.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    interp/topconstr.cmx kernel/term.cmx tactics/tacinterp.cmx \
+    contrib/funind/rawtermops.cmx pretyping/rawterm.cmx parsing/printer.cmx \
+    pretyping/pretyping.cmx lib/pp.cmx lib/options.cmx kernel/names.cmx \
+    library/nameops.cmx library/libnames.cmx pretyping/inductiveops.cmx \
+    kernel/inductive.cmx library/global.cmx pretyping/evd.cmx \
+    kernel/environ.cmx pretyping/detyping.cmx kernel/declarations.cmx \
+    interp/constrintern.cmx interp/constrextern.cmx toplevel/command.cmx 
+contrib/funind/rawterm_to_relation.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
+    pretyping/typing.cmi interp/topconstr.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tacinterp.cmi lib/system.cmi kernel/sign.cmi \
+    kernel/reduction.cmi contrib/funind/rawtermops.cmi pretyping/rawterm.cmi \
+    parsing/printer.cmi pretyping/pretyping.cmi parsing/ppvernac.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi kernel/names.cmi \
+    library/nameops.cmi library/libnames.cmi pretyping/inductiveops.cmi \
+    kernel/inductive.cmi contrib/funind/indfun_common.cmi library/impargs.cmi \
+    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    pretyping/detyping.cmi kernel/declarations.cmi interp/coqlib.cmi \
+    interp/constrextern.cmi toplevel/command.cmi toplevel/cerrors.cmi \
+    contrib/funind/rawterm_to_relation.cmi 
+contrib/funind/rawterm_to_relation.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    pretyping/typing.cmx interp/topconstr.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tacinterp.cmx lib/system.cmx kernel/sign.cmx \
+    kernel/reduction.cmx contrib/funind/rawtermops.cmx pretyping/rawterm.cmx \
+    parsing/printer.cmx pretyping/pretyping.cmx parsing/ppvernac.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx kernel/names.cmx \
+    library/nameops.cmx library/libnames.cmx pretyping/inductiveops.cmx \
+    kernel/inductive.cmx contrib/funind/indfun_common.cmx library/impargs.cmx \
+    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    pretyping/detyping.cmx kernel/declarations.cmx interp/coqlib.cmx \
+    interp/constrextern.cmx toplevel/command.cmx toplevel/cerrors.cmx \
+    contrib/funind/rawterm_to_relation.cmi 
+contrib/funind/rawtermops.cmo: lib/util.cmi pretyping/rawterm.cmi lib/pp.cmi \
+    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
+    pretyping/inductiveops.cmi contrib/funind/indfun_common.cmi \
+    library/global.cmi pretyping/evd.cmi interp/coqlib.cmi \
+    contrib/funind/rawtermops.cmi 
+contrib/funind/rawtermops.cmx: lib/util.cmx pretyping/rawterm.cmx lib/pp.cmx \
+    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
+    pretyping/inductiveops.cmx contrib/funind/indfun_common.cmx \
+    library/global.cmx pretyping/evd.cmx interp/coqlib.cmx \
+    contrib/funind/rawtermops.cmi 
 contrib/funind/tacinv.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
     pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
     tactics/tactics.cmi tactics/tacticals.cmi pretyping/tacred.cmi \
@@ -2741,12 +3182,11 @@ contrib/funind/tacinv.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
     proofs/tacexpr.cmo tactics/setoid_replace.cmi kernel/safe_typing.cmi \
     proofs/refiner.cmi tactics/refine.cmi pretyping/reductionops.cmi \
     proofs/proof_type.cmi parsing/printer.cmi parsing/pptactic.cmi lib/pp.cmi \
-    parsing/pcoq.cmi lib/options.cmi kernel/names.cmi \
-    pretyping/inductiveops.cmi library/global.cmi interp/genarg.cmi \
-    pretyping/evd.cmi tactics/equality.cmi kernel/environ.cmi \
-    kernel/entries.cmi parsing/egrammar.cmi library/declare.cmi \
-    library/decl_kinds.cmo interp/coqlib.cmi interp/constrintern.cmi \
-    toplevel/cerrors.cmi 
+    parsing/pcoq.cmi kernel/names.cmi pretyping/inductiveops.cmi \
+    library/global.cmi interp/genarg.cmi pretyping/evd.cmi \
+    tactics/equality.cmi kernel/environ.cmi kernel/entries.cmi \
+    parsing/egrammar.cmi library/declare.cmi library/decl_kinds.cmo \
+    interp/coqlib.cmi interp/constrintern.cmi toplevel/cerrors.cmi 
 contrib/funind/tacinv.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
     pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
     tactics/tactics.cmx tactics/tacticals.cmx pretyping/tacred.cmx \
@@ -2754,12 +3194,11 @@ contrib/funind/tacinv.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
     proofs/tacexpr.cmx tactics/setoid_replace.cmx kernel/safe_typing.cmx \
     proofs/refiner.cmx tactics/refine.cmx pretyping/reductionops.cmx \
     proofs/proof_type.cmx parsing/printer.cmx parsing/pptactic.cmx lib/pp.cmx \
-    parsing/pcoq.cmx lib/options.cmx kernel/names.cmx \
-    pretyping/inductiveops.cmx library/global.cmx interp/genarg.cmx \
-    pretyping/evd.cmx tactics/equality.cmx kernel/environ.cmx \
-    kernel/entries.cmx parsing/egrammar.cmx library/declare.cmx \
-    library/decl_kinds.cmx interp/coqlib.cmx interp/constrintern.cmx \
-    toplevel/cerrors.cmx 
+    parsing/pcoq.cmx kernel/names.cmx pretyping/inductiveops.cmx \
+    library/global.cmx interp/genarg.cmx pretyping/evd.cmx \
+    tactics/equality.cmx kernel/environ.cmx kernel/entries.cmx \
+    parsing/egrammar.cmx library/declare.cmx library/decl_kinds.cmx \
+    interp/coqlib.cmx interp/constrintern.cmx toplevel/cerrors.cmx 
 contrib/funind/tacinvutils.cmo: lib/util.cmi pretyping/termops.cmi \
     kernel/term.cmi kernel/sign.cmi pretyping/reductionops.cmi \
     parsing/printer.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \
@@ -2774,80 +3213,74 @@ contrib/funind/tacinvutils.cmx: lib/util.cmx pretyping/termops.cmx \
     contrib/funind/tacinvutils.cmi 
 contrib/interface/blast.cmo: toplevel/vernacinterp.cmi \
     toplevel/vernacentries.cmi lib/util.cmi pretyping/typing.cmi \
-    pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
-    tactics/tacticals.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
-    tactics/tacinterp.cmi kernel/sign.cmi proofs/refiner.cmi \
-    kernel/reduction.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
-    proofs/proof_trees.cmi parsing/printer.cmi parsing/pptactic.cmi \
-    lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi contrib/interface/pbp.cmi \
-    pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
-    proofs/logic.cmi kernel/inductive.cmi tactics/hipattern.cmi \
-    library/global.cmi lib/explore.cmi pretyping/evd.cmi \
-    proofs/evar_refiner.cmi tactics/equality.cmi kernel/environ.cmi \
+    kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \
+    tactics/tactics.cmi tactics/tacticals.cmi parsing/tactic_printer.cmi \
+    pretyping/tacred.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
+    kernel/sign.cmi proofs/refiner.cmi kernel/reduction.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
+    parsing/printer.cmi parsing/pptactic.cmi lib/pp.cmi proofs/pfedit.cmi \
+    parsing/pcoq.cmi contrib/interface/pbp.cmi pretyping/pattern.cmi \
+    kernel/names.cmi library/nameops.cmi proofs/logic.cmi \
+    kernel/inductive.cmi tactics/hipattern.cmi library/global.cmi \
+    lib/explore.cmi pretyping/evd.cmi tactics/equality.cmi kernel/environ.cmi \
     tactics/eauto.cmi library/declare.cmi kernel/declarations.cmi \
-    contrib/interface/ctast.cmo toplevel/command.cmi proofs/clenv.cmi \
-    tactics/auto.cmi contrib/interface/blast.cmi 
+    toplevel/command.cmi pretyping/clenv.cmi tactics/auto.cmi \
+    contrib/interface/blast.cmi 
 contrib/interface/blast.cmx: toplevel/vernacinterp.cmx \
     toplevel/vernacentries.cmx lib/util.cmx pretyping/typing.cmx \
-    pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
-    tactics/tacticals.cmx pretyping/tacred.cmx proofs/tacmach.cmx \
-    tactics/tacinterp.cmx kernel/sign.cmx proofs/refiner.cmx \
-    kernel/reduction.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
-    proofs/proof_trees.cmx parsing/printer.cmx parsing/pptactic.cmx \
-    lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx contrib/interface/pbp.cmx \
-    pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
-    proofs/logic.cmx kernel/inductive.cmx tactics/hipattern.cmx \
-    library/global.cmx lib/explore.cmx pretyping/evd.cmx \
-    proofs/evar_refiner.cmx tactics/equality.cmx kernel/environ.cmx \
+    kernel/typeops.cmx pretyping/termops.cmx kernel/term.cmx \
+    tactics/tactics.cmx tactics/tacticals.cmx parsing/tactic_printer.cmx \
+    pretyping/tacred.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
+    kernel/sign.cmx proofs/refiner.cmx kernel/reduction.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
+    parsing/printer.cmx parsing/pptactic.cmx lib/pp.cmx proofs/pfedit.cmx \
+    parsing/pcoq.cmx contrib/interface/pbp.cmx pretyping/pattern.cmx \
+    kernel/names.cmx library/nameops.cmx proofs/logic.cmx \
+    kernel/inductive.cmx tactics/hipattern.cmx library/global.cmx \
+    lib/explore.cmx pretyping/evd.cmx tactics/equality.cmx kernel/environ.cmx \
     tactics/eauto.cmx library/declare.cmx kernel/declarations.cmx \
-    contrib/interface/ctast.cmx toplevel/command.cmx proofs/clenv.cmx \
-    tactics/auto.cmx contrib/interface/blast.cmi 
+    toplevel/command.cmx pretyping/clenv.cmx tactics/auto.cmx \
+    contrib/interface/blast.cmi 
 contrib/interface/centaur.cmo: contrib/interface/xlate.cmi \
     contrib/interface/vtp.cmi toplevel/vernacinterp.cmi \
     toplevel/vernacexpr.cmo toplevel/vernacentries.cmi toplevel/vernac.cmi \
-    lib/util.cmi contrib/interface/translate.cmi parsing/termast.cmi \
+    lib/util.cmi kernel/typeops.cmi contrib/interface/translate.cmi \
     kernel/term.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
     proofs/tacexpr.cmo contrib/interface/showproof_ct.cmo \
     contrib/interface/showproof.cmi parsing/search.cmi proofs/refiner.cmi \
     kernel/reduction.cmi pretyping/rawterm.cmi toplevel/protectedtoplevel.cmi \
-    proofs/proof_type.cmi proofs/proof_trees.cmi pretyping/pretyping.cmi \
-    parsing/pptactic.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \
-    contrib/interface/pbp.cmi lib/options.cmi library/nametab.cmi \
+    proofs/proof_type.cmi proofs/proof_trees.cmi parsing/printer.cmi \
+    pretyping/pretyping.cmi parsing/pptactic.cmi lib/pp.cmi proofs/pfedit.cmi \
+    parsing/pcoq.cmi contrib/interface/pbp.cmi library/nametab.cmi \
     kernel/names.cmi library/nameops.cmi contrib/interface/name_to_ast.cmi \
     pretyping/matching.cmi toplevel/line_oriented_parser.cmi \
     library/library.cmi library/libobject.cmi library/libnames.cmi \
-    library/lib.cmi contrib/interface/history.cmi library/global.cmi \
-    interp/genarg.cmi parsing/extend.cmi pretyping/evd.cmi kernel/environ.cmi \
+    library/lib.cmi parsing/lexer.cmi contrib/interface/history.cmi \
+    library/global.cmi interp/genarg.cmi pretyping/evd.cmi kernel/environ.cmi \
     parsing/egrammar.cmi library/declare.cmi kernel/declarations.cmi \
-    contrib/interface/debug_tac.cmi parsing/coqast.cmi \
-    interp/constrintern.cmi toplevel/command.cmi pretyping/classops.cmi \
-    toplevel/cerrors.cmi contrib/interface/blast.cmi parsing/ast.cmi \
-    contrib/interface/ascent.cmi 
+    contrib/interface/debug_tac.cmi interp/constrintern.cmi \
+    toplevel/command.cmi pretyping/classops.cmi toplevel/cerrors.cmi \
+    contrib/interface/blast.cmi contrib/interface/ascent.cmi 
 contrib/interface/centaur.cmx: contrib/interface/xlate.cmx \
     contrib/interface/vtp.cmx toplevel/vernacinterp.cmx \
     toplevel/vernacexpr.cmx toplevel/vernacentries.cmx toplevel/vernac.cmx \
-    lib/util.cmx contrib/interface/translate.cmx parsing/termast.cmx \
+    lib/util.cmx kernel/typeops.cmx contrib/interface/translate.cmx \
     kernel/term.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
     proofs/tacexpr.cmx contrib/interface/showproof_ct.cmx \
     contrib/interface/showproof.cmx parsing/search.cmx proofs/refiner.cmx \
     kernel/reduction.cmx pretyping/rawterm.cmx toplevel/protectedtoplevel.cmx \
-    proofs/proof_type.cmx proofs/proof_trees.cmx pretyping/pretyping.cmx \
-    parsing/pptactic.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \
-    contrib/interface/pbp.cmx lib/options.cmx library/nametab.cmx \
+    proofs/proof_type.cmx proofs/proof_trees.cmx parsing/printer.cmx \
+    pretyping/pretyping.cmx parsing/pptactic.cmx lib/pp.cmx proofs/pfedit.cmx \
+    parsing/pcoq.cmx contrib/interface/pbp.cmx library/nametab.cmx \
     kernel/names.cmx library/nameops.cmx contrib/interface/name_to_ast.cmx \
     pretyping/matching.cmx toplevel/line_oriented_parser.cmx \
     library/library.cmx library/libobject.cmx library/libnames.cmx \
-    library/lib.cmx contrib/interface/history.cmx library/global.cmx \
-    interp/genarg.cmx parsing/extend.cmx pretyping/evd.cmx kernel/environ.cmx \
+    library/lib.cmx parsing/lexer.cmx contrib/interface/history.cmx \
+    library/global.cmx interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \
     parsing/egrammar.cmx library/declare.cmx kernel/declarations.cmx \
-    contrib/interface/debug_tac.cmx parsing/coqast.cmx \
-    interp/constrintern.cmx toplevel/command.cmx pretyping/classops.cmx \
-    toplevel/cerrors.cmx contrib/interface/blast.cmx parsing/ast.cmx \
-    contrib/interface/ascent.cmi 
-contrib/interface/ctast.cmo: lib/util.cmi kernel/names.cmi \
-    library/libnames.cmi lib/dyn.cmi parsing/coqast.cmi 
-contrib/interface/ctast.cmx: lib/util.cmx kernel/names.cmx \
-    library/libnames.cmx lib/dyn.cmx parsing/coqast.cmx 
+    contrib/interface/debug_tac.cmx interp/constrintern.cmx \
+    toplevel/command.cmx pretyping/classops.cmx toplevel/cerrors.cmx \
+    contrib/interface/blast.cmx contrib/interface/ascent.cmi 
 contrib/interface/dad.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
     lib/util.cmi pretyping/typing.cmi interp/topconstr.cmi kernel/term.cmi \
     tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
@@ -2870,14 +3303,14 @@ contrib/interface/dad.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \
     interp/constrextern.cmx contrib/interface/dad.cmi 
 contrib/interface/debug_tac.cmo: lib/util.cmi tactics/tacticals.cmi \
     proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
-    proofs/refiner.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
-    parsing/pptactic.cmi lib/pp.cmi interp/genarg.cmi parsing/coqast.cmi \
-    toplevel/cerrors.cmi parsing/ast.cmi contrib/interface/debug_tac.cmi 
+    proofs/proof_type.cmi proofs/proof_trees.cmi parsing/printer.cmi \
+    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi library/global.cmi \
+    interp/genarg.cmi toplevel/cerrors.cmi contrib/interface/debug_tac.cmi 
 contrib/interface/debug_tac.cmx: lib/util.cmx tactics/tacticals.cmx \
     proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
-    proofs/refiner.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
-    parsing/pptactic.cmx lib/pp.cmx interp/genarg.cmx parsing/coqast.cmx \
-    toplevel/cerrors.cmx parsing/ast.cmx contrib/interface/debug_tac.cmi 
+    proofs/proof_type.cmx proofs/proof_trees.cmx parsing/printer.cmx \
+    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx library/global.cmx \
+    interp/genarg.cmx toplevel/cerrors.cmx contrib/interface/debug_tac.cmi 
 contrib/interface/history.cmo: contrib/interface/paths.cmi \
     contrib/interface/history.cmi 
 contrib/interface/history.cmx: contrib/interface/paths.cmx \
@@ -2885,39 +3318,37 @@ contrib/interface/history.cmx: contrib/interface/paths.cmx \
 contrib/interface/line_parser.cmo: contrib/interface/line_parser.cmi 
 contrib/interface/line_parser.cmx: contrib/interface/line_parser.cmi 
 contrib/interface/name_to_ast.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
-    interp/topconstr.cmi parsing/termast.cmi kernel/term.cmi kernel/sign.cmi \
+    kernel/typeops.cmi interp/topconstr.cmi kernel/term.cmi kernel/sign.cmi \
     kernel/reduction.cmi parsing/prettyp.cmi lib/pp.cmi library/nametab.cmi \
     kernel/names.cmi library/nameops.cmi library/libobject.cmi \
     library/libnames.cmi library/lib.cmi kernel/inductive.cmi \
     library/impargs.cmi library/global.cmi kernel/environ.cmi \
     library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \
-    parsing/coqast.cmi interp/constrextern.cmi pretyping/classops.cmi \
-    parsing/ast.cmi contrib/interface/name_to_ast.cmi 
+    interp/constrextern.cmi pretyping/classops.cmi \
+    contrib/interface/name_to_ast.cmi 
 contrib/interface/name_to_ast.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
-    interp/topconstr.cmx parsing/termast.cmx kernel/term.cmx kernel/sign.cmx \
+    kernel/typeops.cmx interp/topconstr.cmx kernel/term.cmx kernel/sign.cmx \
     kernel/reduction.cmx parsing/prettyp.cmx lib/pp.cmx library/nametab.cmx \
     kernel/names.cmx library/nameops.cmx library/libobject.cmx \
     library/libnames.cmx library/lib.cmx kernel/inductive.cmx \
     library/impargs.cmx library/global.cmx kernel/environ.cmx \
     library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \
-    parsing/coqast.cmx interp/constrextern.cmx pretyping/classops.cmx \
-    parsing/ast.cmx contrib/interface/name_to_ast.cmi 
+    interp/constrextern.cmx pretyping/classops.cmx \
+    contrib/interface/name_to_ast.cmi 
 contrib/interface/parse.cmo: contrib/interface/xlate.cmi \
     contrib/interface/vtp.cmi toplevel/vernacexpr.cmo \
     toplevel/vernacentries.cmi lib/util.cmi lib/system.cmi lib/pp.cmi \
     parsing/pcoq.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
     toplevel/mltop.cmi contrib/interface/line_parser.cmi library/library.cmi \
-    library/libobject.cmi library/libnames.cmi parsing/esyntax.cmi \
-    library/declaremods.cmi config/coq_config.cmi toplevel/cerrors.cmi \
-    contrib/interface/ascent.cmi 
+    library/libobject.cmi library/libnames.cmi library/declaremods.cmi \
+    config/coq_config.cmi toplevel/cerrors.cmi contrib/interface/ascent.cmi 
 contrib/interface/parse.cmx: contrib/interface/xlate.cmx \
     contrib/interface/vtp.cmx toplevel/vernacexpr.cmx \
     toplevel/vernacentries.cmx lib/util.cmx lib/system.cmx lib/pp.cmx \
     parsing/pcoq.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
     toplevel/mltop.cmx contrib/interface/line_parser.cmx library/library.cmx \
-    library/libobject.cmx library/libnames.cmx parsing/esyntax.cmx \
-    library/declaremods.cmx config/coq_config.cmx toplevel/cerrors.cmx \
-    contrib/interface/ascent.cmi 
+    library/libobject.cmx library/libnames.cmx library/declaremods.cmx \
+    config/coq_config.cmx toplevel/cerrors.cmx contrib/interface/ascent.cmi 
 contrib/interface/paths.cmo: contrib/interface/paths.cmi 
 contrib/interface/paths.cmx: contrib/interface/paths.cmi 
 contrib/interface/pbp.cmo: lib/util.cmi pretyping/typing.cmi \
@@ -2941,52 +3372,48 @@ contrib/interface/pbp.cmx: lib/util.cmx pretyping/typing.cmx \
     library/global.cmx interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \
     interp/coqlib.cmx contrib/interface/pbp.cmi 
 contrib/interface/showproof.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
-    pretyping/typing.cmi contrib/interface/translate.cmi \
-    pretyping/termops.cmi parsing/termast.cmi kernel/term.cmi \
-    proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi \
-    contrib/interface/showproof_ct.cmo pretyping/reductionops.cmi \
-    pretyping/rawterm.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
-    parsing/printer.cmi lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi \
-    library/nameops.cmi library/libnames.cmi pretyping/inductiveops.cmi \
-    kernel/inductive.cmi library/global.cmi interp/genarg.cmi \
-    pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi \
-    parsing/coqast.cmi interp/constrintern.cmi proofs/clenv.cmi \
+    pretyping/typing.cmi kernel/typeops.cmi contrib/interface/translate.cmi \
+    pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi \
+    proofs/tacexpr.cmo kernel/sign.cmi contrib/interface/showproof_ct.cmo \
+    pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
+    proofs/proof_trees.cmi parsing/printer.cmi lib/pp.cmi proofs/pfedit.cmi \
+    kernel/names.cmi library/nameops.cmi library/libnames.cmi \
+    pretyping/inductiveops.cmi kernel/inductive.cmi library/global.cmi \
+    interp/genarg.cmi pretyping/evd.cmi kernel/environ.cmi \
+    kernel/declarations.cmi interp/constrintern.cmi pretyping/clenv.cmi \
     contrib/interface/showproof.cmi 
 contrib/interface/showproof.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
-    pretyping/typing.cmx contrib/interface/translate.cmx \
-    pretyping/termops.cmx parsing/termast.cmx kernel/term.cmx \
-    proofs/tacmach.cmx proofs/tacexpr.cmx kernel/sign.cmx \
-    contrib/interface/showproof_ct.cmx pretyping/reductionops.cmx \
-    pretyping/rawterm.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
-    parsing/printer.cmx lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx \
-    library/nameops.cmx library/libnames.cmx pretyping/inductiveops.cmx \
-    kernel/inductive.cmx library/global.cmx interp/genarg.cmx \
-    pretyping/evd.cmx kernel/environ.cmx kernel/declarations.cmx \
-    parsing/coqast.cmx interp/constrintern.cmx proofs/clenv.cmx \
+    pretyping/typing.cmx kernel/typeops.cmx contrib/interface/translate.cmx \
+    pretyping/termops.cmx kernel/term.cmx proofs/tacmach.cmx \
+    proofs/tacexpr.cmx kernel/sign.cmx contrib/interface/showproof_ct.cmx \
+    pretyping/reductionops.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
+    proofs/proof_trees.cmx parsing/printer.cmx lib/pp.cmx proofs/pfedit.cmx \
+    kernel/names.cmx library/nameops.cmx library/libnames.cmx \
+    pretyping/inductiveops.cmx kernel/inductive.cmx library/global.cmx \
+    interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \
+    kernel/declarations.cmx interp/constrintern.cmx pretyping/clenv.cmx \
     contrib/interface/showproof.cmi 
 contrib/interface/showproof_ct.cmo: contrib/interface/xlate.cmi \
     contrib/interface/vtp.cmi contrib/interface/translate.cmi \
     parsing/printer.cmi lib/pp.cmi toplevel/metasyntax.cmi library/global.cmi \
-    parsing/esyntax.cmi contrib/interface/ascent.cmi 
+    contrib/interface/ascent.cmi 
 contrib/interface/showproof_ct.cmx: contrib/interface/xlate.cmx \
     contrib/interface/vtp.cmx contrib/interface/translate.cmx \
     parsing/printer.cmx lib/pp.cmx toplevel/metasyntax.cmx library/global.cmx \
-    parsing/esyntax.cmx contrib/interface/ascent.cmi 
+    contrib/interface/ascent.cmi 
 contrib/interface/translate.cmo: contrib/interface/xlate.cmi \
     contrib/interface/vtp.cmi toplevel/vernacinterp.cmi lib/util.cmi \
-    parsing/termast.cmi kernel/term.cmi proofs/tacmach.cmi kernel/sign.cmi \
-    proofs/proof_type.cmi lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi \
-    library/library.cmi library/libobject.cmi pretyping/evd.cmi \
-    pretyping/evarutil.cmi kernel/environ.cmi contrib/interface/ctast.cmo \
-    interp/constrextern.cmi parsing/ast.cmi contrib/interface/ascent.cmi \
+    kernel/term.cmi proofs/tacmach.cmi kernel/sign.cmi proofs/proof_type.cmi \
+    lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi library/library.cmi \
+    library/libobject.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    kernel/environ.cmi interp/constrextern.cmi contrib/interface/ascent.cmi \
     contrib/interface/translate.cmi 
 contrib/interface/translate.cmx: contrib/interface/xlate.cmx \
     contrib/interface/vtp.cmx toplevel/vernacinterp.cmx lib/util.cmx \
-    parsing/termast.cmx kernel/term.cmx proofs/tacmach.cmx kernel/sign.cmx \
-    proofs/proof_type.cmx lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx \
-    library/library.cmx library/libobject.cmx pretyping/evd.cmx \
-    pretyping/evarutil.cmx kernel/environ.cmx contrib/interface/ctast.cmx \
-    interp/constrextern.cmx parsing/ast.cmx contrib/interface/ascent.cmi \
+    kernel/term.cmx proofs/tacmach.cmx kernel/sign.cmx proofs/proof_type.cmx \
+    lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx library/library.cmx \
+    library/libobject.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    kernel/environ.cmx interp/constrextern.cmx contrib/interface/ascent.cmi \
     contrib/interface/translate.cmi 
 contrib/interface/vtp.cmo: contrib/interface/ascent.cmi \
     contrib/interface/vtp.cmi 
@@ -2994,20 +3421,18 @@ contrib/interface/vtp.cmx: contrib/interface/ascent.cmi \
     contrib/interface/vtp.cmi 
 contrib/interface/xlate.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
     interp/topconstr.cmi kernel/term.cmi proofs/tacexpr.cmo \
-    pretyping/rawterm.cmi parsing/ppconstr.cmi lib/options.cmi \
+    pretyping/rawterm.cmi parsing/ppconstr.cmi parsing/pcoq.cmi \
     kernel/names.cmi library/libnames.cmi library/goptions.cmi \
-    interp/genarg.cmi contrib/field/field.cmo tactics/extraargs.cmi \
-    parsing/extend.cmi tactics/eauto.cmi library/decl_kinds.cmo \
-    lib/bignat.cmi parsing/ast.cmi contrib/interface/ascent.cmi \
-    contrib/interface/xlate.cmi 
+    interp/genarg.cmi tactics/extraargs.cmi parsing/extend.cmi \
+    tactics/eauto.cmi library/decl_kinds.cmo lib/bigint.cmi \
+    contrib/interface/ascent.cmi contrib/interface/xlate.cmi 
 contrib/interface/xlate.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
     interp/topconstr.cmx kernel/term.cmx proofs/tacexpr.cmx \
-    pretyping/rawterm.cmx parsing/ppconstr.cmx lib/options.cmx \
+    pretyping/rawterm.cmx parsing/ppconstr.cmx parsing/pcoq.cmx \
     kernel/names.cmx library/libnames.cmx library/goptions.cmx \
-    interp/genarg.cmx contrib/field/field.cmx tactics/extraargs.cmx \
-    parsing/extend.cmx tactics/eauto.cmx library/decl_kinds.cmx \
-    lib/bignat.cmx parsing/ast.cmx contrib/interface/ascent.cmi \
-    contrib/interface/xlate.cmi 
+    interp/genarg.cmx tactics/extraargs.cmx parsing/extend.cmx \
+    tactics/eauto.cmx library/decl_kinds.cmx lib/bigint.cmx \
+    contrib/interface/ascent.cmi contrib/interface/xlate.cmi 
 contrib/jprover/jall.cmo: lib/pp.cmi contrib/jprover/opname.cmi \
     contrib/jprover/jtunify.cmi contrib/jprover/jterm.cmi \
     contrib/jprover/jlogic.cmi contrib/jprover/jall.cmi 
@@ -3024,20 +3449,20 @@ contrib/jprover/jprover.cmo: lib/util.cmi pretyping/termops.cmi \
     proofs/refiner.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
     pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
     parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi pretyping/pattern.cmi \
-    lib/options.cmi kernel/names.cmi contrib/jprover/jterm.cmi \
-    contrib/jprover/jlogic.cmi contrib/jprover/jall.cmi tactics/hipattern.cmi \
-    tactics/hiddentac.cmi library/global.cmi interp/genarg.cmi \
-    parsing/egrammar.cmi proofs/clenv.cmi toplevel/cerrors.cmi 
+    kernel/names.cmi contrib/jprover/jterm.cmi contrib/jprover/jlogic.cmi \
+    contrib/jprover/jall.cmi tactics/hipattern.cmi tactics/hiddentac.cmi \
+    library/global.cmi interp/genarg.cmi pretyping/evarutil.cmi \
+    parsing/egrammar.cmi toplevel/cerrors.cmi 
 contrib/jprover/jprover.cmx: lib/util.cmx pretyping/termops.cmx \
     kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
     proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
     proofs/refiner.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
     pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
     parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx pretyping/pattern.cmx \
-    lib/options.cmx kernel/names.cmx contrib/jprover/jterm.cmx \
-    contrib/jprover/jlogic.cmx contrib/jprover/jall.cmx tactics/hipattern.cmx \
-    tactics/hiddentac.cmx library/global.cmx interp/genarg.cmx \
-    parsing/egrammar.cmx proofs/clenv.cmx toplevel/cerrors.cmx 
+    kernel/names.cmx contrib/jprover/jterm.cmx contrib/jprover/jlogic.cmx \
+    contrib/jprover/jall.cmx tactics/hipattern.cmx tactics/hiddentac.cmx \
+    library/global.cmx interp/genarg.cmx pretyping/evarutil.cmx \
+    parsing/egrammar.cmx toplevel/cerrors.cmx 
 contrib/jprover/jterm.cmo: contrib/jprover/opname.cmi \
     contrib/jprover/jterm.cmi 
 contrib/jprover/jterm.cmx: contrib/jprover/opname.cmx \
@@ -3050,62 +3475,94 @@ contrib/omega/coq_omega.cmo: lib/util.cmi pretyping/termops.cmi \
     kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
     pretyping/tacred.cmi proofs/tacmach.cmi kernel/sign.cmi \
     kernel/reduction.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
-    parsing/printer.cmi lib/pp.cmi lib/options.cmi contrib/omega/omega.cmo \
+    parsing/printer.cmi lib/pp.cmi contrib/omega/omega.cmo \
     library/nametab.cmi kernel/names.cmi library/nameops.cmi proofs/logic.cmi \
-    library/library.cmi library/libnames.cmi kernel/inductive.cmi \
-    library/goptions.cmi library/global.cmi proofs/evar_refiner.cmi \
+    library/libnames.cmi kernel/inductive.cmi library/goptions.cmi \
+    library/global.cmi pretyping/evarutil.cmi proofs/evar_refiner.cmi \
     tactics/equality.cmi kernel/environ.cmi kernel/declarations.cmi \
     interp/coqlib.cmi tactics/contradiction.cmi kernel/closure.cmi \
-    proofs/clenv.cmi parsing/ast.cmi 
+    pretyping/clenv.cmi lib/bigint.cmi 
 contrib/omega/coq_omega.cmx: lib/util.cmx pretyping/termops.cmx \
     kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
     pretyping/tacred.cmx proofs/tacmach.cmx kernel/sign.cmx \
     kernel/reduction.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
-    parsing/printer.cmx lib/pp.cmx lib/options.cmx contrib/omega/omega.cmx \
+    parsing/printer.cmx lib/pp.cmx contrib/omega/omega.cmx \
     library/nametab.cmx kernel/names.cmx library/nameops.cmx proofs/logic.cmx \
-    library/library.cmx library/libnames.cmx kernel/inductive.cmx \
-    library/goptions.cmx library/global.cmx proofs/evar_refiner.cmx \
+    library/libnames.cmx kernel/inductive.cmx library/goptions.cmx \
+    library/global.cmx pretyping/evarutil.cmx proofs/evar_refiner.cmx \
     tactics/equality.cmx kernel/environ.cmx kernel/declarations.cmx \
     interp/coqlib.cmx tactics/contradiction.cmx kernel/closure.cmx \
-    proofs/clenv.cmx parsing/ast.cmx 
+    pretyping/clenv.cmx lib/bigint.cmx 
 contrib/omega/g_omega.cmo: lib/util.cmi tactics/tacinterp.cmi \
     proofs/tacexpr.cmo proofs/refiner.cmi parsing/pptactic.cmi lib/pp.cmi \
-    parsing/pcoq.cmi lib/options.cmi parsing/egrammar.cmi \
-    contrib/omega/coq_omega.cmo toplevel/cerrors.cmi 
+    parsing/pcoq.cmi parsing/egrammar.cmi contrib/omega/coq_omega.cmo \
+    toplevel/cerrors.cmi 
 contrib/omega/g_omega.cmx: lib/util.cmx tactics/tacinterp.cmx \
     proofs/tacexpr.cmx proofs/refiner.cmx parsing/pptactic.cmx lib/pp.cmx \
-    parsing/pcoq.cmx lib/options.cmx parsing/egrammar.cmx \
-    contrib/omega/coq_omega.cmx toplevel/cerrors.cmx 
-contrib/omega/omega.cmo: lib/util.cmi kernel/names.cmi library/nameops.cmi 
-contrib/omega/omega.cmx: lib/util.cmx kernel/names.cmx library/nameops.cmx 
+    parsing/pcoq.cmx parsing/egrammar.cmx contrib/omega/coq_omega.cmx \
+    toplevel/cerrors.cmx 
+contrib/omega/omega.cmo: lib/util.cmi kernel/names.cmi 
+contrib/omega/omega.cmx: lib/util.cmx kernel/names.cmx 
+contrib/recdef/recdef.cmo: toplevel/vernacinterp.cmi \
+    toplevel/vernacentries.cmi lib/util.cmi pretyping/typing.cmi \
+    kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
+    proofs/tactic_debug.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
+    tactics/tacinterp.cmi kernel/safe_typing.cmi pretyping/rawterm.cmi \
+    proofs/proof_type.cmi parsing/printer.cmi pretyping/pretyping.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \
+    lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi library/lib.cmi tactics/hiddentac.cmi \
+    library/global.cmi interp/genarg.cmi pretyping/evd.cmi \
+    tactics/equality.cmi kernel/environ.cmi kernel/entries.cmi \
+    tactics/elim.cmi parsing/egrammar.cmi tactics/eauto.cmi \
+    library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \
+    interp/coqlib.cmi interp/constrintern.cmi toplevel/command.cmi \
+    kernel/closure.cmi toplevel/cerrors.cmi tactics/auto.cmi 
+contrib/recdef/recdef.cmx: toplevel/vernacinterp.cmx \
+    toplevel/vernacentries.cmx lib/util.cmx pretyping/typing.cmx \
+    kernel/typeops.cmx interp/topconstr.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
+    proofs/tactic_debug.cmx pretyping/tacred.cmx proofs/tacmach.cmx \
+    tactics/tacinterp.cmx kernel/safe_typing.cmx pretyping/rawterm.cmx \
+    proofs/proof_type.cmx parsing/printer.cmx pretyping/pretyping.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \
+    lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx library/lib.cmx tactics/hiddentac.cmx \
+    library/global.cmx interp/genarg.cmx pretyping/evd.cmx \
+    tactics/equality.cmx kernel/environ.cmx kernel/entries.cmx \
+    tactics/elim.cmx parsing/egrammar.cmx tactics/eauto.cmx \
+    library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \
+    interp/coqlib.cmx interp/constrintern.cmx toplevel/command.cmx \
+    kernel/closure.cmx toplevel/cerrors.cmx tactics/auto.cmx 
 contrib/ring/g_quote.cmo: lib/util.cmi tactics/tacinterp.cmi \
-    proofs/tacexpr.cmo proofs/refiner.cmi contrib/ring/quote.cmo \
-    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    interp/genarg.cmi parsing/egrammar.cmi toplevel/cerrors.cmi 
+    proofs/tacexpr.cmo contrib/ring/quote.cmo parsing/pptactic.cmi lib/pp.cmi \
+    parsing/pcoq.cmi interp/genarg.cmi parsing/egrammar.cmi \
+    toplevel/cerrors.cmi 
 contrib/ring/g_quote.cmx: lib/util.cmx tactics/tacinterp.cmx \
-    proofs/tacexpr.cmx proofs/refiner.cmx contrib/ring/quote.cmx \
-    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    interp/genarg.cmx parsing/egrammar.cmx toplevel/cerrors.cmx 
+    proofs/tacexpr.cmx contrib/ring/quote.cmx parsing/pptactic.cmx lib/pp.cmx \
+    parsing/pcoq.cmx interp/genarg.cmx parsing/egrammar.cmx \
+    toplevel/cerrors.cmx 
 contrib/ring/g_ring.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
-    tactics/tacinterp.cmi proofs/tacexpr.cmo contrib/ring/ring.cmo \
-    proofs/refiner.cmi contrib/ring/quote.cmo parsing/pptactic.cmi lib/pp.cmi \
-    parsing/pcoq.cmi lib/options.cmi interp/genarg.cmi parsing/egrammar.cmi \
-    toplevel/cerrors.cmi 
+    tactics/tacticals.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
+    contrib/ring/ring.cmo proofs/refiner.cmi contrib/ring/quote.cmo \
+    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi interp/genarg.cmi \
+    parsing/egrammar.cmi toplevel/cerrors.cmi 
 contrib/ring/g_ring.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
-    tactics/tacinterp.cmx proofs/tacexpr.cmx contrib/ring/ring.cmx \
-    proofs/refiner.cmx contrib/ring/quote.cmx parsing/pptactic.cmx lib/pp.cmx \
-    parsing/pcoq.cmx lib/options.cmx interp/genarg.cmx parsing/egrammar.cmx \
-    toplevel/cerrors.cmx 
+    tactics/tacticals.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
+    contrib/ring/ring.cmx proofs/refiner.cmx contrib/ring/quote.cmx \
+    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx interp/genarg.cmx \
+    parsing/egrammar.cmx toplevel/cerrors.cmx 
 contrib/ring/quote.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
     tactics/tactics.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \
     proofs/proof_trees.cmi lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi \
-    pretyping/matching.cmi library/library.cmi pretyping/instantiate.cmi \
-    library/global.cmi kernel/environ.cmi interp/coqlib.cmi 
+    pretyping/matching.cmi library/global.cmi kernel/environ.cmi \
+    interp/coqlib.cmi 
 contrib/ring/quote.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \
     tactics/tactics.cmx proofs/tacmach.cmx proofs/tacexpr.cmx \
     proofs/proof_trees.cmx lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx \
-    pretyping/matching.cmx library/library.cmx pretyping/instantiate.cmx \
-    library/global.cmx kernel/environ.cmx interp/coqlib.cmx 
+    pretyping/matching.cmx library/global.cmx kernel/environ.cmx \
+    interp/coqlib.cmx 
 contrib/ring/ring.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
     lib/util.cmi pretyping/typing.cmi kernel/term.cmi tactics/tactics.cmi \
     tactics/tacticals.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
@@ -3113,7 +3570,7 @@ contrib/ring/ring.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
     pretyping/reductionops.cmi contrib/ring/quote.cmo proofs/proof_trees.cmi \
     parsing/printer.cmi lib/pp.cmi pretyping/pattern.cmi lib/options.cmi \
     library/nametab.cmi kernel/names.cmi library/nameops.cmi \
-    library/library.cmi library/libobject.cmi library/libnames.cmi \
+    kernel/mod_subst.cmi library/libobject.cmi library/libnames.cmi \
     library/lib.cmi tactics/hipattern.cmi tactics/hiddentac.cmi \
     library/global.cmi pretyping/evd.cmi tactics/equality.cmi \
     interp/coqlib.cmi interp/constrintern.cmi kernel/closure.cmi 
@@ -3124,170 +3581,496 @@ contrib/ring/ring.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \
     pretyping/reductionops.cmx contrib/ring/quote.cmx proofs/proof_trees.cmx \
     parsing/printer.cmx lib/pp.cmx pretyping/pattern.cmx lib/options.cmx \
     library/nametab.cmx kernel/names.cmx library/nameops.cmx \
-    library/library.cmx library/libobject.cmx library/libnames.cmx \
+    kernel/mod_subst.cmx library/libobject.cmx library/libnames.cmx \
     library/lib.cmx tactics/hipattern.cmx tactics/hiddentac.cmx \
     library/global.cmx pretyping/evd.cmx tactics/equality.cmx \
     interp/coqlib.cmx interp/constrintern.cmx kernel/closure.cmx 
-contrib/romega/const_omega.cmo: lib/util.cmi kernel/term.cmi lib/options.cmi \
+contrib/romega/const_omega.cmo: lib/util.cmi kernel/term.cmi \
     library/nametab.cmi kernel/names.cmi library/libnames.cmi \
-    library/global.cmi interp/coqlib.cmi 
-contrib/romega/const_omega.cmx: lib/util.cmx kernel/term.cmx lib/options.cmx \
+    interp/coqlib.cmi lib/bigint.cmi 
+contrib/romega/const_omega.cmx: lib/util.cmx kernel/term.cmx \
     library/nametab.cmx kernel/names.cmx library/libnames.cmx \
-    library/global.cmx interp/coqlib.cmx 
+    interp/coqlib.cmx lib/bigint.cmx 
 contrib/romega/g_romega.cmo: lib/util.cmi tactics/tacinterp.cmi \
     proofs/tacexpr.cmo contrib/romega/refl_omega.cmo proofs/refiner.cmi \
-    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \
-    parsing/egrammar.cmi toplevel/cerrors.cmi 
+    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi parsing/egrammar.cmi \
+    toplevel/cerrors.cmi 
 contrib/romega/g_romega.cmx: lib/util.cmx tactics/tacinterp.cmx \
     proofs/tacexpr.cmx contrib/romega/refl_omega.cmx proofs/refiner.cmx \
-    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \
-    parsing/egrammar.cmx toplevel/cerrors.cmx 
-contrib/romega/omega2.cmo: lib/util.cmi kernel/names.cmi 
-contrib/romega/omega2.cmx: lib/util.cmx kernel/names.cmx 
+    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx parsing/egrammar.cmx \
+    toplevel/cerrors.cmx 
 contrib/romega/refl_omega.cmo: lib/util.cmi kernel/term.cmi \
     tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
-    parsing/printer.cmi lib/pp.cmi lib/options.cmi contrib/romega/omega2.cmo \
-    kernel/names.cmi proofs/logic.cmi contrib/romega/const_omega.cmo 
+    parsing/printer.cmi lib/pp.cmi contrib/omega/omega.cmo kernel/names.cmi \
+    proofs/logic.cmi interp/coqlib.cmi contrib/romega/const_omega.cmo \
+    lib/bigint.cmi 
 contrib/romega/refl_omega.cmx: lib/util.cmx kernel/term.cmx \
     tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \
-    parsing/printer.cmx lib/pp.cmx lib/options.cmx contrib/romega/omega2.cmx \
-    kernel/names.cmx proofs/logic.cmx contrib/romega/const_omega.cmx 
+    parsing/printer.cmx lib/pp.cmx contrib/omega/omega.cmx kernel/names.cmx \
+    proofs/logic.cmx interp/coqlib.cmx contrib/romega/const_omega.cmx \
+    lib/bigint.cmx 
+contrib/rtauto/g_rtauto.cmo: lib/util.cmi tactics/tacinterp.cmi \
+    proofs/tacexpr.cmo contrib/rtauto/refl_tauto.cmi proofs/refiner.cmi \
+    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi parsing/egrammar.cmi \
+    toplevel/cerrors.cmi 
+contrib/rtauto/g_rtauto.cmx: lib/util.cmx tactics/tacinterp.cmx \
+    proofs/tacexpr.cmx contrib/rtauto/refl_tauto.cmx proofs/refiner.cmx \
+    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx parsing/egrammar.cmx \
+    toplevel/cerrors.cmx 
+contrib/rtauto/proof_search.cmo: lib/util.cmi kernel/term.cmi lib/pp.cmi \
+    library/goptions.cmi contrib/rtauto/proof_search.cmi 
+contrib/rtauto/proof_search.cmx: lib/util.cmx kernel/term.cmx lib/pp.cmx \
+    library/goptions.cmx contrib/rtauto/proof_search.cmi 
+contrib/rtauto/refl_tauto.cmo: lib/util.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tactics.cmi proofs/tactic_debug.cmi \
+    proofs/tacmach.cmi tactics/tacinterp.cmi lib/system.cmi \
+    pretyping/retyping.cmi contrib/rtauto/proof_search.cmi lib/pp.cmi \
+    kernel/names.cmi library/goptions.cmi lib/explore.cmi pretyping/evd.cmi \
+    kernel/environ.cmi interp/coqlib.cmi kernel/closure.cmi \
+    contrib/rtauto/refl_tauto.cmi 
+contrib/rtauto/refl_tauto.cmx: lib/util.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tactics.cmx proofs/tactic_debug.cmx \
+    proofs/tacmach.cmx tactics/tacinterp.cmx lib/system.cmx \
+    pretyping/retyping.cmx contrib/rtauto/proof_search.cmx lib/pp.cmx \
+    kernel/names.cmx library/goptions.cmx lib/explore.cmx pretyping/evd.cmx \
+    kernel/environ.cmx interp/coqlib.cmx kernel/closure.cmx \
+    contrib/rtauto/refl_tauto.cmi 
+contrib/setoid_ring/newring.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
+    pretyping/typing.cmi kernel/typeops.cmi interp/topconstr.cmi \
+    pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
+    tactics/tacticals.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
+    proofs/tacexpr.cmo library/summary.cmi tactics/setoid_replace.cmi \
+    pretyping/retyping.cmi proofs/refiner.cmi pretyping/reductionops.cmi \
+    pretyping/rawterm.cmi contrib/ring/quote.cmo proofs/proof_type.cmi \
+    parsing/printer.cmi pretyping/pretyping.cmi parsing/pptactic.cmi \
+    lib/pp.cmi parsing/pcoq.cmi library/nametab.cmi kernel/names.cmi \
+    kernel/mod_subst.cmi library/libobject.cmi library/libnames.cmi \
+    library/lib.cmi parsing/lexer.cmi library/global.cmi interp/genarg.cmi \
+    pretyping/evd.cmi kernel/esubst.cmi kernel/environ.cmi kernel/entries.cmi \
+    parsing/egrammar.cmi library/declare.cmi library/decl_kinds.cmo \
+    interp/coqlib.cmi interp/constrintern.cmi kernel/closure.cmi \
+    toplevel/cerrors.cmi 
+contrib/setoid_ring/newring.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
+    pretyping/typing.cmx kernel/typeops.cmx interp/topconstr.cmx \
+    pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
+    tactics/tacticals.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
+    proofs/tacexpr.cmx library/summary.cmx tactics/setoid_replace.cmx \
+    pretyping/retyping.cmx proofs/refiner.cmx pretyping/reductionops.cmx \
+    pretyping/rawterm.cmx contrib/ring/quote.cmx proofs/proof_type.cmx \
+    parsing/printer.cmx pretyping/pretyping.cmx parsing/pptactic.cmx \
+    lib/pp.cmx parsing/pcoq.cmx library/nametab.cmx kernel/names.cmx \
+    kernel/mod_subst.cmx library/libobject.cmx library/libnames.cmx \
+    library/lib.cmx parsing/lexer.cmx library/global.cmx interp/genarg.cmx \
+    pretyping/evd.cmx kernel/esubst.cmx kernel/environ.cmx kernel/entries.cmx \
+    parsing/egrammar.cmx library/declare.cmx library/decl_kinds.cmx \
+    interp/coqlib.cmx interp/constrintern.cmx kernel/closure.cmx \
+    toplevel/cerrors.cmx 
+contrib/subtac/context.cmo: kernel/term.cmi kernel/names.cmi \
+    contrib/subtac/context.cmi 
+contrib/subtac/context.cmx: kernel/term.cmx kernel/names.cmx \
+    contrib/subtac/context.cmi 
+contrib/subtac/eterm.cmo: lib/util.cmi kernel/term.cmi tactics/tacticals.cmi \
+    lib/pp.cmi lib/options.cmi kernel/names.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi kernel/environ.cmi contrib/subtac/eterm.cmi 
+contrib/subtac/eterm.cmx: lib/util.cmx kernel/term.cmx tactics/tacticals.cmx \
+    lib/pp.cmx lib/options.cmx kernel/names.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx kernel/environ.cmx contrib/subtac/eterm.cmi 
+contrib/subtac/g_eterm.cmo: lib/util.cmi proofs/tacmach.cmi \
+    tactics/tacinterp.cmi proofs/tacexpr.cmo proofs/refiner.cmi \
+    parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi contrib/subtac/eterm.cmi \
+    parsing/egrammar.cmi toplevel/cerrors.cmi 
+contrib/subtac/g_eterm.cmx: lib/util.cmx proofs/tacmach.cmx \
+    tactics/tacinterp.cmx proofs/tacexpr.cmx proofs/refiner.cmx \
+    parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx contrib/subtac/eterm.cmx \
+    parsing/egrammar.cmx toplevel/cerrors.cmx 
+contrib/subtac/g_subtac.cmo: toplevel/vernacinterp.cmi \
+    toplevel/vernacexpr.cmo toplevel/vernacentries.cmi lib/util.cmi \
+    interp/topconstr.cmi kernel/term.cmi tactics/tacinterp.cmi \
+    proofs/tacexpr.cmo contrib/subtac/subtac_obligations.cmi \
+    contrib/subtac/subtac.cmi kernel/reduction.cmi proofs/proof_type.cmi \
+    lib/pp.cmi parsing/pcoq.cmi lib/options.cmi kernel/names.cmi \
+    library/nameops.cmi library/libnames.cmi interp/genarg.cmi \
+    parsing/egrammar.cmi toplevel/cerrors.cmi 
+contrib/subtac/g_subtac.cmx: toplevel/vernacinterp.cmx \
+    toplevel/vernacexpr.cmx toplevel/vernacentries.cmx lib/util.cmx \
+    interp/topconstr.cmx kernel/term.cmx tactics/tacinterp.cmx \
+    proofs/tacexpr.cmx contrib/subtac/subtac_obligations.cmx \
+    contrib/subtac/subtac.cmx kernel/reduction.cmx proofs/proof_type.cmx \
+    lib/pp.cmx parsing/pcoq.cmx lib/options.cmx kernel/names.cmx \
+    library/nameops.cmx library/libnames.cmx interp/genarg.cmx \
+    parsing/egrammar.cmx toplevel/cerrors.cmx 
+contrib/subtac/subtac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
+    kernel/typeops.cmi kernel/type_errors.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \
+    contrib/subtac/subtac_utils.cmi contrib/subtac/subtac_pretyping.cmi \
+    contrib/subtac/subtac_obligations.cmi contrib/subtac/subtac_errors.cmi \
+    contrib/subtac/subtac_command.cmi contrib/subtac/subtac_coercion.cmi \
+    kernel/sign.cmi pretyping/reductionops.cmi pretyping/recordops.cmi \
+    pretyping/rawterm.cmi parsing/printer.cmi pretyping/pretype_errors.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi \
+    lib/options.cmi library/nametab.cmi kernel/names.cmi library/library.cmi \
+    library/libnames.cmi library/lib.cmi toplevel/himsg.cmi \
+    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    pretyping/evarconv.cmi contrib/subtac/eterm.cmi kernel/environ.cmi \
+    lib/dyn.cmi library/decl_kinds.cmo interp/coqlib.cmi \
+    contrib/subtac/context.cmi toplevel/command.cmi pretyping/classops.cmi \
+    toplevel/cerrors.cmi contrib/subtac/subtac.cmi 
+contrib/subtac/subtac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    kernel/typeops.cmx kernel/type_errors.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \
+    contrib/subtac/subtac_utils.cmx contrib/subtac/subtac_pretyping.cmx \
+    contrib/subtac/subtac_obligations.cmx contrib/subtac/subtac_errors.cmx \
+    contrib/subtac/subtac_command.cmx contrib/subtac/subtac_coercion.cmx \
+    kernel/sign.cmx pretyping/reductionops.cmx pretyping/recordops.cmx \
+    pretyping/rawterm.cmx parsing/printer.cmx pretyping/pretype_errors.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx \
+    lib/options.cmx library/nametab.cmx kernel/names.cmx library/library.cmx \
+    library/libnames.cmx library/lib.cmx toplevel/himsg.cmx \
+    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    pretyping/evarconv.cmx contrib/subtac/eterm.cmx kernel/environ.cmx \
+    lib/dyn.cmx library/decl_kinds.cmx interp/coqlib.cmx \
+    contrib/subtac/context.cmx toplevel/command.cmx pretyping/classops.cmx \
+    toplevel/cerrors.cmx contrib/subtac/subtac.cmi 
+contrib/subtac/subtac_cases.cmo: lib/util.cmi kernel/typeops.cmi \
+    kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \
+    contrib/subtac/subtac_utils.cmi kernel/sign.cmi pretyping/retyping.cmi \
+    pretyping/reductionops.cmi pretyping/rawterm.cmi parsing/printer.cmi \
+    pretyping/pretype_errors.cmi lib/pp.cmi kernel/names.cmi \
+    library/nameops.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
+    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    pretyping/evarconv.cmi kernel/environ.cmi kernel/declarations.cmi \
+    pretyping/coercion.cmi kernel/closure.cmi contrib/subtac/subtac_cases.cmi 
+contrib/subtac/subtac_cases.cmx: lib/util.cmx kernel/typeops.cmx \
+    kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \
+    contrib/subtac/subtac_utils.cmx kernel/sign.cmx pretyping/retyping.cmx \
+    pretyping/reductionops.cmx pretyping/rawterm.cmx parsing/printer.cmx \
+    pretyping/pretype_errors.cmx lib/pp.cmx kernel/names.cmx \
+    library/nameops.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
+    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    pretyping/evarconv.cmx kernel/environ.cmx kernel/declarations.cmx \
+    pretyping/coercion.cmx kernel/closure.cmx contrib/subtac/subtac_cases.cmi 
+contrib/subtac/subtac_coercion.cmo: lib/util.cmi pretyping/typing.cmi \
+    kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \
+    contrib/subtac/subtac_utils.cmi contrib/subtac/subtac_errors.cmi \
+    pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
+    pretyping/recordops.cmi pretyping/rawterm.cmi parsing/printer.cmi \
+    pretyping/pretype_errors.cmi lib/pp.cmi kernel/names.cmi \
+    library/nameops.cmi library/global.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi pretyping/evarconv.cmi contrib/subtac/eterm.cmi \
+    kernel/environ.cmi interp/coqlib.cmi contrib/subtac/context.cmi \
+    pretyping/classops.cmi contrib/subtac/subtac_coercion.cmi 
+contrib/subtac/subtac_coercion.cmx: lib/util.cmx pretyping/typing.cmx \
+    kernel/typeops.cmx pretyping/termops.cmx kernel/term.cmx \
+    contrib/subtac/subtac_utils.cmx contrib/subtac/subtac_errors.cmx \
+    pretyping/retyping.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
+    pretyping/recordops.cmx pretyping/rawterm.cmx parsing/printer.cmx \
+    pretyping/pretype_errors.cmx lib/pp.cmx kernel/names.cmx \
+    library/nameops.cmx library/global.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx pretyping/evarconv.cmx contrib/subtac/eterm.cmx \
+    kernel/environ.cmx interp/coqlib.cmx contrib/subtac/context.cmx \
+    pretyping/classops.cmx contrib/subtac/subtac_coercion.cmi 
+contrib/subtac/subtac_command.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
+    pretyping/typing.cmi interp/topconstr.cmi pretyping/termops.cmi \
+    kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
+    proofs/tactic_debug.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
+    tactics/tacinterp.cmi proofs/tacexpr.cmo interp/syntax_def.cmi \
+    contrib/subtac/subtac_utils.cmi contrib/subtac/subtac_pretyping.cmi \
+    contrib/subtac/subtac_obligations.cmi library/states.cmi kernel/sign.cmi \
+    kernel/safe_typing.cmi interp/reserve.cmi proofs/refiner.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
+    pretyping/pretyping.cmi lib/pp.cmi proofs/pfedit.cmi \
+    pretyping/pattern.cmi interp/notation.cmi library/nametab.cmi \
+    kernel/names.cmi library/nameops.cmi kernel/mod_subst.cmi \
+    toplevel/metasyntax.cmi pretyping/matching.cmi library/libobject.cmi \
+    library/libnames.cmi pretyping/inductiveops.cmi library/impargs.cmi \
+    tactics/hiddentac.cmi library/global.cmi interp/genarg.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi contrib/subtac/eterm.cmi \
+    kernel/environ.cmi kernel/entries.cmi lib/dyn.cmi kernel/declarations.cmi \
+    library/decl_kinds.cmo interp/coqlib.cmi interp/constrintern.cmi \
+    toplevel/command.cmi kernel/closure.cmi contrib/subtac/subtac_command.cmi 
+contrib/subtac/subtac_command.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    pretyping/typing.cmx interp/topconstr.cmx pretyping/termops.cmx \
+    kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
+    proofs/tactic_debug.cmx pretyping/tacred.cmx proofs/tacmach.cmx \
+    tactics/tacinterp.cmx proofs/tacexpr.cmx interp/syntax_def.cmx \
+    contrib/subtac/subtac_utils.cmx contrib/subtac/subtac_pretyping.cmx \
+    contrib/subtac/subtac_obligations.cmx library/states.cmx kernel/sign.cmx \
+    kernel/safe_typing.cmx interp/reserve.cmx proofs/refiner.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
+    pretyping/pretyping.cmx lib/pp.cmx proofs/pfedit.cmx \
+    pretyping/pattern.cmx interp/notation.cmx library/nametab.cmx \
+    kernel/names.cmx library/nameops.cmx kernel/mod_subst.cmx \
+    toplevel/metasyntax.cmx pretyping/matching.cmx library/libobject.cmx \
+    library/libnames.cmx pretyping/inductiveops.cmx library/impargs.cmx \
+    tactics/hiddentac.cmx library/global.cmx interp/genarg.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx contrib/subtac/eterm.cmx \
+    kernel/environ.cmx kernel/entries.cmx lib/dyn.cmx kernel/declarations.cmx \
+    library/decl_kinds.cmx interp/coqlib.cmx interp/constrintern.cmx \
+    toplevel/command.cmx kernel/closure.cmx contrib/subtac/subtac_command.cmi 
+contrib/subtac/subtac_errors.cmo: lib/util.cmi parsing/printer.cmi lib/pp.cmi \
+    contrib/subtac/subtac_errors.cmi 
+contrib/subtac/subtac_errors.cmx: lib/util.cmx parsing/printer.cmx lib/pp.cmx \
+    contrib/subtac/subtac_errors.cmi 
+contrib/subtac/subtac_interp_fixpoint.cmo: lib/util.cmi kernel/typeops.cmi \
+    kernel/type_errors.cmi interp/topconstr.cmi pretyping/termops.cmi \
+    kernel/term.cmi contrib/subtac/subtac_utils.cmi \
+    contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_coercion.cmi \
+    kernel/sign.cmi pretyping/reductionops.cmi pretyping/recordops.cmi \
+    pretyping/rawterm.cmi parsing/printer.cmi pretyping/pretype_errors.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi \
+    library/nameops.cmi library/libnames.cmi library/global.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \
+    contrib/subtac/eterm.cmi kernel/environ.cmi lib/dyn.cmi interp/coqlib.cmi \
+    contrib/subtac/context.cmi pretyping/classops.cmi \
+    contrib/subtac/subtac_interp_fixpoint.cmi 
+contrib/subtac/subtac_interp_fixpoint.cmx: lib/util.cmx kernel/typeops.cmx \
+    kernel/type_errors.cmx interp/topconstr.cmx pretyping/termops.cmx \
+    kernel/term.cmx contrib/subtac/subtac_utils.cmx \
+    contrib/subtac/subtac_errors.cmx contrib/subtac/subtac_coercion.cmx \
+    kernel/sign.cmx pretyping/reductionops.cmx pretyping/recordops.cmx \
+    pretyping/rawterm.cmx parsing/printer.cmx pretyping/pretype_errors.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx \
+    library/nameops.cmx library/libnames.cmx library/global.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \
+    contrib/subtac/eterm.cmx kernel/environ.cmx lib/dyn.cmx interp/coqlib.cmx \
+    contrib/subtac/context.cmx pretyping/classops.cmx \
+    contrib/subtac/subtac_interp_fixpoint.cmi 
+contrib/subtac/subtac_obligations.cmo: lib/util.cmi pretyping/termops.cmi \
+    kernel/term.cmi library/summary.cmi contrib/subtac/subtac_utils.cmi \
+    proofs/refiner.cmi pretyping/reductionops.cmi proofs/proof_type.cmi \
+    parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \
+    kernel/names.cmi library/libobject.cmi library/libnames.cmi \
+    library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    kernel/entries.cmi library/declare.cmi library/decl_kinds.cmo \
+    toplevel/command.cmi tactics/auto.cmi \
+    contrib/subtac/subtac_obligations.cmi 
+contrib/subtac/subtac_obligations.cmx: lib/util.cmx pretyping/termops.cmx \
+    kernel/term.cmx library/summary.cmx contrib/subtac/subtac_utils.cmx \
+    proofs/refiner.cmx pretyping/reductionops.cmx proofs/proof_type.cmx \
+    parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \
+    kernel/names.cmx library/libobject.cmx library/libnames.cmx \
+    library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    kernel/entries.cmx library/declare.cmx library/decl_kinds.cmx \
+    toplevel/command.cmx tactics/auto.cmx \
+    contrib/subtac/subtac_obligations.cmi 
+contrib/subtac/subtac_pretyping.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
+    kernel/typeops.cmi kernel/type_errors.cmi interp/topconstr.cmi \
+    pretyping/termops.cmi kernel/term.cmi contrib/subtac/subtac_utils.cmi \
+    contrib/subtac/subtac_pretyping_F.cmo \
+    contrib/subtac/subtac_obligations.cmi contrib/subtac/subtac_errors.cmi \
+    contrib/subtac/subtac_coercion.cmi kernel/sign.cmi \
+    pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \
+    parsing/printer.cmi pretyping/pretype_errors.cmi lib/pp.cmi \
+    pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi library/global.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi pretyping/evarconv.cmi contrib/subtac/eterm.cmi \
+    kernel/environ.cmi lib/dyn.cmi interp/coqlib.cmi \
+    contrib/subtac/context.cmi interp/constrintern.cmi pretyping/classops.cmi \
+    contrib/subtac/subtac_pretyping.cmi 
+contrib/subtac/subtac_pretyping.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+    kernel/typeops.cmx kernel/type_errors.cmx interp/topconstr.cmx \
+    pretyping/termops.cmx kernel/term.cmx contrib/subtac/subtac_utils.cmx \
+    contrib/subtac/subtac_pretyping_F.cmx \
+    contrib/subtac/subtac_obligations.cmx contrib/subtac/subtac_errors.cmx \
+    contrib/subtac/subtac_coercion.cmx kernel/sign.cmx \
+    pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \
+    parsing/printer.cmx pretyping/pretype_errors.cmx lib/pp.cmx \
+    pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx library/global.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx pretyping/evarconv.cmx contrib/subtac/eterm.cmx \
+    kernel/environ.cmx lib/dyn.cmx interp/coqlib.cmx \
+    contrib/subtac/context.cmx interp/constrintern.cmx pretyping/classops.cmx \
+    contrib/subtac/subtac_pretyping.cmi 
+contrib/subtac/subtac_pretyping_F.cmo: lib/util.cmi kernel/typeops.cmi \
+    kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \
+    contrib/subtac/subtac_cases.cmi kernel/sign.cmi pretyping/retyping.cmi \
+    pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \
+    pretyping/pretyping.cmi pretyping/pretype_errors.cmi lib/pp.cmi \
+    pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \
+    kernel/environ.cmi lib/dyn.cmi kernel/declarations.cmi \
+    pretyping/coercion.cmi pretyping/classops.cmi 
+contrib/subtac/subtac_pretyping_F.cmx: lib/util.cmx kernel/typeops.cmx \
+    kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \
+    contrib/subtac/subtac_cases.cmx kernel/sign.cmx pretyping/retyping.cmx \
+    pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \
+    pretyping/pretyping.cmx pretyping/pretype_errors.cmx lib/pp.cmx \
+    pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \
+    kernel/environ.cmx lib/dyn.cmx kernel/declarations.cmx \
+    pretyping/coercion.cmx pretyping/classops.cmx 
+contrib/subtac/subtac_utils.cmo: lib/util.cmi interp/topconstr.cmi \
+    pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
+    tactics/tacticals.cmi proofs/tacexpr.cmo kernel/reduction.cmi \
+    pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
+    pretyping/pretype_errors.cmi parsing/ppconstr.cmi lib/pp.cmi \
+    proofs/pfedit.cmi lib/options.cmi kernel/names.cmi library/nameops.cmi \
+    library/libnames.cmi library/global.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi kernel/entries.cmi library/decl_kinds.cmo \
+    interp/coqlib.cmi interp/constrextern.cmi toplevel/command.cmi \
+    contrib/subtac/subtac_utils.cmi 
+contrib/subtac/subtac_utils.cmx: lib/util.cmx interp/topconstr.cmx \
+    pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
+    tactics/tacticals.cmx proofs/tacexpr.cmx kernel/reduction.cmx \
+    pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
+    pretyping/pretype_errors.cmx parsing/ppconstr.cmx lib/pp.cmx \
+    proofs/pfedit.cmx lib/options.cmx kernel/names.cmx library/nameops.cmx \
+    library/libnames.cmx library/global.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx kernel/entries.cmx library/decl_kinds.cmx \
+    interp/coqlib.cmx interp/constrextern.cmx toplevel/command.cmx \
+    contrib/subtac/subtac_utils.cmi 
 contrib/xml/acic.cmo: kernel/term.cmi kernel/names.cmi 
 contrib/xml/acic.cmx: kernel/term.cmx kernel/names.cmx 
 contrib/xml/acic2Xml.cmo: contrib/xml/xml.cmi lib/util.cmi kernel/term.cmi \
     kernel/names.cmi contrib/xml/cic2acic.cmo contrib/xml/acic.cmo 
 contrib/xml/acic2Xml.cmx: contrib/xml/xml.cmx lib/util.cmx kernel/term.cmx \
     kernel/names.cmx contrib/xml/cic2acic.cmx contrib/xml/acic.cmx 
+contrib/xml/cic2Xml.cmo: contrib/xml/xml.cmi contrib/xml/unshare.cmi \
+    tactics/tacinterp.cmi contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \
+    contrib/xml/acic.cmo 
+contrib/xml/cic2Xml.cmx: contrib/xml/xml.cmx contrib/xml/unshare.cmx \
+    tactics/tacinterp.cmx contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx \
+    contrib/xml/acic.cmx 
 contrib/xml/cic2acic.cmo: lib/util.cmi contrib/xml/unshare.cmi \
-    kernel/univ.cmi pretyping/termops.cmi kernel/term.cmi \
+    kernel/univ.cmi kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \
     pretyping/reductionops.cmi parsing/printer.cmi lib/pp.cmi \
     library/nametab.cmi kernel/names.cmi library/nameops.cmi \
     library/library.cmi library/libnames.cmi library/lib.cmi \
-    pretyping/instantiate.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \
-    library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
+    pretyping/inductiveops.cmi library/global.cmi pretyping/evd.cmi \
     kernel/environ.cmi contrib/xml/doubleTypeInference.cmi \
     library/dischargedhypsmap.cmi library/declare.cmi kernel/declarations.cmi \
     contrib/xml/acic.cmo 
 contrib/xml/cic2acic.cmx: lib/util.cmx contrib/xml/unshare.cmx \
-    kernel/univ.cmx pretyping/termops.cmx kernel/term.cmx \
+    kernel/univ.cmx kernel/typeops.cmx pretyping/termops.cmx kernel/term.cmx \
     pretyping/reductionops.cmx parsing/printer.cmx lib/pp.cmx \
     library/nametab.cmx kernel/names.cmx library/nameops.cmx \
     library/library.cmx library/libnames.cmx library/lib.cmx \
-    pretyping/instantiate.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \
-    library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
+    pretyping/inductiveops.cmx library/global.cmx pretyping/evd.cmx \
     kernel/environ.cmx contrib/xml/doubleTypeInference.cmx \
     library/dischargedhypsmap.cmx library/declare.cmx kernel/declarations.cmx \
     contrib/xml/acic.cmx 
 contrib/xml/doubleTypeInference.cmo: lib/util.cmi contrib/xml/unshare.cmi \
     kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \
-    pretyping/tacred.cmi pretyping/retyping.cmi pretyping/reductionops.cmi \
-    kernel/reduction.cmi pretyping/rawterm.cmi parsing/printer.cmi lib/pp.cmi \
-    kernel/names.cmi library/libnames.cmi pretyping/instantiate.cmi \
+    pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
+    proofs/redexpr.cmi pretyping/rawterm.cmi parsing/printer.cmi lib/pp.cmi \
+    kernel/names.cmi library/libnames.cmi pretyping/inductiveops.cmi \
     kernel/inductive.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
     kernel/environ.cmi kernel/conv_oracle.cmi contrib/xml/acic.cmo \
     contrib/xml/doubleTypeInference.cmi 
 contrib/xml/doubleTypeInference.cmx: lib/util.cmx contrib/xml/unshare.cmx \
     kernel/typeops.cmx pretyping/termops.cmx kernel/term.cmx \
-    pretyping/tacred.cmx pretyping/retyping.cmx pretyping/reductionops.cmx \
-    kernel/reduction.cmx pretyping/rawterm.cmx parsing/printer.cmx lib/pp.cmx \
-    kernel/names.cmx library/libnames.cmx pretyping/instantiate.cmx \
+    pretyping/retyping.cmx pretyping/reductionops.cmx kernel/reduction.cmx \
+    proofs/redexpr.cmx pretyping/rawterm.cmx parsing/printer.cmx lib/pp.cmx \
+    kernel/names.cmx library/libnames.cmx pretyping/inductiveops.cmx \
     kernel/inductive.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
     kernel/environ.cmx kernel/conv_oracle.cmx contrib/xml/acic.cmx \
     contrib/xml/doubleTypeInference.cmi 
 contrib/xml/proof2aproof.cmo: lib/util.cmi contrib/xml/unshare.cmi \
-    pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi kernel/sign.cmi \
-    proofs/refiner.cmi proofs/proof_type.cmi lib/pp.cmi proofs/logic.cmi \
-    pretyping/instantiate.cmi library/global.cmi pretyping/evd.cmi \
-    pretyping/evarutil.cmi 
+    pretyping/termops.cmi kernel/term.cmi parsing/tactic_printer.cmi \
+    proofs/tacmach.cmi kernel/sign.cmi proofs/refiner.cmi \
+    proofs/proof_type.cmi lib/pp.cmi proofs/logic.cmi pretyping/evd.cmi \
+    pretyping/evarutil.cmi kernel/environ.cmi 
 contrib/xml/proof2aproof.cmx: lib/util.cmx contrib/xml/unshare.cmx \
-    pretyping/termops.cmx kernel/term.cmx proofs/tacmach.cmx kernel/sign.cmx \
-    proofs/refiner.cmx proofs/proof_type.cmx lib/pp.cmx proofs/logic.cmx \
-    pretyping/instantiate.cmx library/global.cmx pretyping/evd.cmx \
-    pretyping/evarutil.cmx 
+    pretyping/termops.cmx kernel/term.cmx parsing/tactic_printer.cmx \
+    proofs/tacmach.cmx kernel/sign.cmx proofs/refiner.cmx \
+    proofs/proof_type.cmx lib/pp.cmx proofs/logic.cmx pretyping/evd.cmx \
+    pretyping/evarutil.cmx kernel/environ.cmx 
 contrib/xml/proofTree2Xml.cmo: contrib/xml/xml.cmi lib/util.cmi \
     contrib/xml/unshare.cmi kernel/term.cmi proofs/tacexpr.cmo \
-    kernel/sign.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \
-    contrib/xml/proof2aproof.cmo parsing/printer.cmi \
-    translate/pptacticnew.cmi parsing/pptactic.cmi lib/pp.cmi lib/options.cmi \
-    kernel/names.cmi proofs/logic.cmi library/global.cmi pretyping/evd.cmi \
-    kernel/environ.cmi contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \
-    contrib/xml/acic.cmo 
+    kernel/sign.cmi proofs/proof_type.cmi contrib/xml/proof2aproof.cmo \
+    parsing/printer.cmi parsing/pptactic.cmi lib/pp.cmi kernel/names.cmi \
+    proofs/logic.cmi library/global.cmi pretyping/evd.cmi kernel/environ.cmi \
+    contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo contrib/xml/acic.cmo 
 contrib/xml/proofTree2Xml.cmx: contrib/xml/xml.cmx lib/util.cmx \
     contrib/xml/unshare.cmx kernel/term.cmx proofs/tacexpr.cmx \
-    kernel/sign.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \
-    contrib/xml/proof2aproof.cmx parsing/printer.cmx \
-    translate/pptacticnew.cmx parsing/pptactic.cmx lib/pp.cmx lib/options.cmx \
-    kernel/names.cmx proofs/logic.cmx library/global.cmx pretyping/evd.cmx \
-    kernel/environ.cmx contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx \
-    contrib/xml/acic.cmx 
+    kernel/sign.cmx proofs/proof_type.cmx contrib/xml/proof2aproof.cmx \
+    parsing/printer.cmx parsing/pptactic.cmx lib/pp.cmx kernel/names.cmx \
+    proofs/logic.cmx library/global.cmx pretyping/evd.cmx kernel/environ.cmx \
+    contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx contrib/xml/acic.cmx 
 contrib/xml/unshare.cmo: contrib/xml/unshare.cmi 
 contrib/xml/unshare.cmx: contrib/xml/unshare.cmi 
 contrib/xml/xml.cmo: contrib/xml/xml.cmi 
 contrib/xml/xml.cmx: contrib/xml/xml.cmi 
 contrib/xml/xmlcommand.cmo: contrib/xml/xml.cmi toplevel/vernac.cmi \
-    lib/util.cmi contrib/xml/unshare.cmi kernel/term.cmi proofs/tacmach.cmi \
-    kernel/sign.cmi pretyping/recordops.cmi proofs/proof_trees.cmi \
+    lib/util.cmi contrib/xml/unshare.cmi kernel/typeops.cmi kernel/term.cmi \
+    proofs/tacmach.cmi pretyping/recordops.cmi proofs/proof_trees.cmi \
     contrib/xml/proof2aproof.cmo proofs/pfedit.cmi library/nametab.cmi \
     kernel/names.cmi library/library.cmi library/libobject.cmi \
     library/libnames.cmi library/lib.cmi parsing/lexer.cmi \
-    kernel/inductive.cmi library/global.cmi pretyping/evd.cmi \
-    kernel/environ.cmi library/declare.cmi kernel/declarations.cmi \
-    library/decl_kinds.cmo config/coq_config.cmi contrib/xml/cic2acic.cmo \
-    contrib/xml/acic2Xml.cmo contrib/xml/acic.cmo contrib/xml/xmlcommand.cmi 
+    pretyping/inductiveops.cmi kernel/inductive.cmi library/global.cmi \
+    pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \
+    library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \
+    config/coq_config.cmi contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \
+    contrib/xml/acic.cmo contrib/xml/xmlcommand.cmi 
 contrib/xml/xmlcommand.cmx: contrib/xml/xml.cmx toplevel/vernac.cmx \
-    lib/util.cmx contrib/xml/unshare.cmx kernel/term.cmx proofs/tacmach.cmx \
-    kernel/sign.cmx pretyping/recordops.cmx proofs/proof_trees.cmx \
+    lib/util.cmx contrib/xml/unshare.cmx kernel/typeops.cmx kernel/term.cmx \
+    proofs/tacmach.cmx pretyping/recordops.cmx proofs/proof_trees.cmx \
     contrib/xml/proof2aproof.cmx proofs/pfedit.cmx library/nametab.cmx \
     kernel/names.cmx library/library.cmx library/libobject.cmx \
     library/libnames.cmx library/lib.cmx parsing/lexer.cmx \
-    kernel/inductive.cmx library/global.cmx pretyping/evd.cmx \
-    kernel/environ.cmx library/declare.cmx kernel/declarations.cmx \
-    library/decl_kinds.cmx config/coq_config.cmx contrib/xml/cic2acic.cmx \
-    contrib/xml/acic2Xml.cmx contrib/xml/acic.cmx contrib/xml/xmlcommand.cmi 
+    pretyping/inductiveops.cmx kernel/inductive.cmx library/global.cmx \
+    pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \
+    library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \
+    config/coq_config.cmx contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx \
+    contrib/xml/acic.cmx contrib/xml/xmlcommand.cmi 
 contrib/xml/xmlentries.cmo: contrib/xml/xmlcommand.cmi \
     toplevel/vernacinterp.cmi lib/util.cmi lib/pp.cmi parsing/pcoq.cmi \
-    interp/genarg.cmi parsing/extend.cmi parsing/egrammar.cmi \
-    toplevel/cerrors.cmi 
+    parsing/lexer.cmi interp/genarg.cmi parsing/extend.cmi \
+    parsing/egrammar.cmi toplevel/cerrors.cmi 
 contrib/xml/xmlentries.cmx: contrib/xml/xmlcommand.cmx \
     toplevel/vernacinterp.cmx lib/util.cmx lib/pp.cmx parsing/pcoq.cmx \
-    interp/genarg.cmx parsing/extend.cmx parsing/egrammar.cmx \
-    toplevel/cerrors.cmx 
+    parsing/lexer.cmx interp/genarg.cmx parsing/extend.cmx \
+    parsing/egrammar.cmx toplevel/cerrors.cmx 
+doc/refman/euclid.cmo: doc/refman/euclid.cmi 
+doc/refman/euclid.cmx: doc/refman/euclid.cmi 
+doc/refman/heapsort.cmo: doc/refman/heapsort.cmi 
+doc/refman/heapsort.cmx: doc/refman/heapsort.cmi 
+ide/utils/config_file.cmo: ide/utils/config_file.cmi 
+ide/utils/config_file.cmx: ide/utils/config_file.cmi 
 ide/utils/configwin.cmo: ide/utils/configwin_types.cmo \
     ide/utils/configwin_ihm.cmo ide/utils/configwin.cmi 
 ide/utils/configwin.cmx: ide/utils/configwin_types.cmx \
     ide/utils/configwin_ihm.cmx ide/utils/configwin.cmi 
-ide/utils/configwin_html_config.cmo: ide/utils/uoptions.cmi \
-    ide/utils/configwin_types.cmo ide/utils/configwin_messages.cmo \
-    ide/utils/configwin_ihm.cmo 
-ide/utils/configwin_html_config.cmx: ide/utils/uoptions.cmx \
-    ide/utils/configwin_types.cmx ide/utils/configwin_messages.cmx \
-    ide/utils/configwin_ihm.cmx 
-ide/utils/configwin_ihm.cmo: ide/utils/uoptions.cmi ide/utils/okey.cmi \
-    ide/utils/configwin_types.cmo ide/utils/configwin_messages.cmo 
-ide/utils/configwin_ihm.cmx: ide/utils/uoptions.cmx ide/utils/okey.cmx \
-    ide/utils/configwin_types.cmx ide/utils/configwin_messages.cmx 
-ide/utils/configwin_types.cmo: ide/utils/uoptions.cmi \
-    ide/utils/configwin_keys.cmo 
-ide/utils/configwin_types.cmx: ide/utils/uoptions.cmx \
-    ide/utils/configwin_keys.cmx 
+ide/utils/configwin_html_config.cmo: ide/utils/configwin_types.cmo \
+    ide/utils/configwin_messages.cmo ide/utils/configwin_ihm.cmo \
+    ide/utils/config_file.cmi 
+ide/utils/configwin_html_config.cmx: ide/utils/configwin_types.cmx \
+    ide/utils/configwin_messages.cmx ide/utils/configwin_ihm.cmx \
+    ide/utils/config_file.cmx 
+ide/utils/configwin_ihm.cmo: ide/utils/okey.cmi ide/utils/configwin_types.cmo \
+    ide/utils/configwin_messages.cmo ide/utils/config_file.cmi 
+ide/utils/configwin_ihm.cmx: ide/utils/okey.cmx ide/utils/configwin_types.cmx \
+    ide/utils/configwin_messages.cmx ide/utils/config_file.cmx 
+ide/utils/configwin_types.cmo: ide/utils/configwin_keys.cmo \
+    ide/utils/config_file.cmi 
+ide/utils/configwin_types.cmx: ide/utils/configwin_keys.cmx \
+    ide/utils/config_file.cmx 
 ide/utils/okey.cmo: ide/utils/okey.cmi 
 ide/utils/okey.cmx: ide/utils/okey.cmi 
 ide/utils/uoptions.cmo: ide/utils/uoptions.cmi 
 ide/utils/uoptions.cmx: ide/utils/uoptions.cmi 
 tools/coqdoc/alpha.cmo: tools/coqdoc/alpha.cmi 
 tools/coqdoc/alpha.cmx: tools/coqdoc/alpha.cmi 
-tools/coqdoc/index.cmo: tools/coqdoc/alpha.cmi tools/coqdoc/index.cmi 
-tools/coqdoc/index.cmx: tools/coqdoc/alpha.cmx tools/coqdoc/index.cmi 
+tools/coqdoc/cdglobals.cmo: config/coq_config.cmi 
+tools/coqdoc/cdglobals.cmx: config/coq_config.cmx 
+tools/coqdoc/index.cmo: tools/coqdoc/cdglobals.cmo tools/coqdoc/alpha.cmi \
+    tools/coqdoc/index.cmi 
+tools/coqdoc/index.cmx: tools/coqdoc/cdglobals.cmx tools/coqdoc/alpha.cmx \
+    tools/coqdoc/index.cmi 
 tools/coqdoc/main.cmo: tools/coqdoc/pretty.cmi tools/coqdoc/output.cmi \
-    tools/coqdoc/index.cmi config/coq_config.cmi 
+    tools/coqdoc/index.cmi config/coq_config.cmi tools/coqdoc/cdglobals.cmo 
 tools/coqdoc/main.cmx: tools/coqdoc/pretty.cmx tools/coqdoc/output.cmx \
-    tools/coqdoc/index.cmx config/coq_config.cmx 
-tools/coqdoc/output.cmo: tools/coqdoc/index.cmi tools/coqdoc/output.cmi 
-tools/coqdoc/output.cmx: tools/coqdoc/index.cmx tools/coqdoc/output.cmi 
+    tools/coqdoc/index.cmx config/coq_config.cmx tools/coqdoc/cdglobals.cmx 
+tools/coqdoc/output.cmo: tools/coqdoc/index.cmi tools/coqdoc/cdglobals.cmo \
+    tools/coqdoc/output.cmi 
+tools/coqdoc/output.cmx: tools/coqdoc/index.cmx tools/coqdoc/cdglobals.cmx \
+    tools/coqdoc/output.cmi 
 tools/coqdoc/pretty.cmo: tools/coqdoc/output.cmi tools/coqdoc/index.cmi \
-    tools/coqdoc/pretty.cmi 
+    tools/coqdoc/cdglobals.cmo tools/coqdoc/pretty.cmi 
 tools/coqdoc/pretty.cmx: tools/coqdoc/output.cmx tools/coqdoc/index.cmx \
-    tools/coqdoc/pretty.cmi 
+    tools/coqdoc/cdglobals.cmx tools/coqdoc/pretty.cmi 
 tactics/tauto.cmo: parsing/grammar.cma
 tactics/tauto.cmx: parsing/grammar.cma
 tactics/eqdecide.cmo: parsing/grammar.cma
@@ -3298,6 +4081,10 @@ tactics/extratactics.cmo: parsing/grammar.cma
 tactics/extratactics.cmx: parsing/grammar.cma
 tactics/eauto.cmo: parsing/grammar.cma
 tactics/eauto.cmx: parsing/grammar.cma
+toplevel/whelp.cmo: parsing/grammar.cma
+toplevel/whelp.cmx: parsing/grammar.cma
+tactics/hipattern.cmo: parsing/grammar.cma parsing/q_constr.cmo
+tactics/hipattern.cmx: parsing/grammar.cma parsing/q_constr.cmo
 contrib/omega/g_omega.cmo: parsing/grammar.cma
 contrib/omega/g_omega.cmx: parsing/grammar.cma
 contrib/romega/g_romega.cmo: parsing/grammar.cma
@@ -3306,6 +4093,10 @@ contrib/ring/g_quote.cmo: parsing/grammar.cma
 contrib/ring/g_quote.cmx: parsing/grammar.cma
 contrib/ring/g_ring.cmo: parsing/grammar.cma
 contrib/ring/g_ring.cmx: parsing/grammar.cma
+contrib/dp/g_dp.cmo: parsing/grammar.cma
+contrib/dp/g_dp.cmx: parsing/grammar.cma
+contrib/setoid_ring/newring.cmo: parsing/grammar.cma
+contrib/setoid_ring/newring.cmx: parsing/grammar.cma
 contrib/field/field.cmo: parsing/grammar.cma
 contrib/field/field.cmx: parsing/grammar.cma
 contrib/fourier/g_fourier.cmo: parsing/grammar.cma
@@ -3316,40 +4107,46 @@ contrib/xml/xmlentries.cmo: parsing/grammar.cma
 contrib/xml/xmlentries.cmx: parsing/grammar.cma
 contrib/jprover/jprover.cmo: parsing/grammar.cma
 contrib/jprover/jprover.cmx: parsing/grammar.cma
-contrib/cc/cctac.cmo: parsing/grammar.cma
-contrib/cc/cctac.cmx: parsing/grammar.cma
+contrib/cc/g_congruence.cmo: parsing/grammar.cma
+contrib/cc/g_congruence.cmx: parsing/grammar.cma
 contrib/funind/tacinv.cmo: parsing/grammar.cma
 contrib/funind/tacinv.cmx: parsing/grammar.cma
 contrib/first-order/g_ground.cmo: parsing/grammar.cma
 contrib/first-order/g_ground.cmx: parsing/grammar.cma
+contrib/subtac/g_subtac.cmo: parsing/grammar.cma
+contrib/subtac/g_subtac.cmx: parsing/grammar.cma
+contrib/subtac/g_eterm.cmo: parsing/grammar.cma
+contrib/subtac/g_eterm.cmx: parsing/grammar.cma
+contrib/rtauto/g_rtauto.cmo: parsing/grammar.cma
+contrib/rtauto/g_rtauto.cmx: parsing/grammar.cma
+contrib/recdef/recdef.cmo: parsing/grammar.cma
+contrib/recdef/recdef.cmx: parsing/grammar.cma
+contrib/funind/indfun_main.cmo: parsing/grammar.cma
+contrib/funind/indfun_main.cmx: parsing/grammar.cma
 contrib/interface/debug_tac.cmo: parsing/grammar.cma
 contrib/interface/debug_tac.cmx: parsing/grammar.cma
 contrib/interface/centaur.cmo: parsing/grammar.cma
 contrib/interface/centaur.cmx: parsing/grammar.cma
 parsing/lexer.cmo: 
 parsing/lexer.cmx: 
+parsing/pcoq.cmo: 
+parsing/pcoq.cmx: 
 parsing/q_util.cmo: 
 parsing/q_util.cmx: 
 parsing/q_coqast.cmo: 
 parsing/q_coqast.cmx: 
 parsing/g_prim.cmo: 
 parsing/g_prim.cmx: 
-parsing/pcoq.cmo: 
-parsing/pcoq.cmx: 
-parsing/g_basevernac.cmo: 
-parsing/g_basevernac.cmx: 
 parsing/g_minicoq.cmo: 
 parsing/g_minicoq.cmx: 
-parsing/g_vernac.cmo: 
-parsing/g_vernac.cmx: 
+parsing/g_vernac.cmo: parsing/grammar.cma
+parsing/g_vernac.cmx: parsing/grammar.cma
 parsing/g_proofs.cmo: 
 parsing/g_proofs.cmx: 
-parsing/g_cases.cmo: 
-parsing/g_cases.cmx: 
+parsing/g_xml.cmo: 
+parsing/g_xml.cmx: 
 parsing/g_constr.cmo: 
 parsing/g_constr.cmx: 
-parsing/g_module.cmo: 
-parsing/g_module.cmx: 
 parsing/g_tactic.cmo: 
 parsing/g_tactic.cmx: 
 parsing/g_ltac.cmo: 
@@ -3360,18 +4157,10 @@ parsing/tacextend.cmo:
 parsing/tacextend.cmx: 
 parsing/vernacextend.cmo: 
 parsing/vernacextend.cmx: 
-parsing/g_primnew.cmo: 
-parsing/g_primnew.cmx: 
-parsing/g_vernacnew.cmo: 
-parsing/g_vernacnew.cmx: 
-parsing/g_proofsnew.cmo: 
-parsing/g_proofsnew.cmx: 
-parsing/g_constrnew.cmo: 
-parsing/g_constrnew.cmx: 
-parsing/g_tacticnew.cmo: 
-parsing/g_tacticnew.cmx: 
-parsing/g_ltacnew.cmo: 
-parsing/g_ltacnew.cmx: 
+parsing/q_constr.cmo: 
+parsing/q_constr.cmx: 
+parsing/g_decl_mode.cmo: parsing/grammar.cma
+parsing/g_decl_mode.cmx: parsing/grammar.cma
 toplevel/mltop.cmo: 
 toplevel/mltop.cmx: 
 lib/pp.cmo: 
@@ -3390,3 +4179,39 @@ tools/coq_makefile.cmo:
 tools/coq_makefile.cmx: 
 tools/coq-tex.cmo: 
 tools/coq-tex.cmx: 
+coq_fix_code.o: kernel/byterun/coq_fix_code.c \
+  /usr/local/lib/ocaml/caml/config.h \
+  /usr/local/lib/ocaml/caml/compatibility.h \
+  /usr/local/lib/ocaml/caml/misc.h /usr/local/lib/ocaml/caml/config.h \
+  /usr/local/lib/ocaml/caml/mlvalues.h /usr/local/lib/ocaml/caml/misc.h \
+  /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/mlvalues.h \
+  /usr/local/lib/ocaml/caml/memory.h kernel/byterun/coq_instruct.h \
+  kernel/byterun/coq_fix_code.h
+coq_interp.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \
+  /usr/local/lib/ocaml/caml/mlvalues.h \
+  /usr/local/lib/ocaml/caml/compatibility.h \
+  /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
+  /usr/local/lib/ocaml/caml/alloc.h /usr/local/lib/ocaml/caml/mlvalues.h \
+  kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
+  kernel/byterun/coq_memory.h /usr/local/lib/ocaml/caml/config.h \
+  /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/misc.h \
+  /usr/local/lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
+  kernel/byterun/coq_jumptbl.h
+coq_memory.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \
+  /usr/local/lib/ocaml/caml/mlvalues.h \
+  /usr/local/lib/ocaml/caml/compatibility.h \
+  /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
+  /usr/local/lib/ocaml/caml/alloc.h /usr/local/lib/ocaml/caml/mlvalues.h \
+  kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
+  kernel/byterun/coq_memory.h /usr/local/lib/ocaml/caml/config.h \
+  /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/misc.h \
+  /usr/local/lib/ocaml/caml/memory.h kernel/byterun/coq_interp.h
+coq_values.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \
+  /usr/local/lib/ocaml/caml/mlvalues.h \
+  /usr/local/lib/ocaml/caml/compatibility.h \
+  /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
+  kernel/byterun/coq_instruct.h kernel/byterun/coq_memory.h \
+  /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/fail.h \
+  /usr/local/lib/ocaml/caml/mlvalues.h /usr/local/lib/ocaml/caml/misc.h \
+  /usr/local/lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
+  /usr/local/lib/ocaml/caml/alloc.h
diff --git a/.depend.camlp4 b/.depend.camlp4
index a34765fc..895c7857 100644
--- a/.depend.camlp4
+++ b/.depend.camlp4
@@ -3,43 +3,46 @@ tactics/eqdecide.ml: parsing/grammar.cma
 tactics/extraargs.ml: parsing/grammar.cma
 tactics/extratactics.ml: parsing/grammar.cma
 tactics/eauto.ml: parsing/grammar.cma
+toplevel/whelp.ml: parsing/grammar.cma
+tactics/hipattern.ml: parsing/grammar.cma parsing/q_constr.cmo
 contrib/omega/g_omega.ml: parsing/grammar.cma
 contrib/romega/g_romega.ml: parsing/grammar.cma
 contrib/ring/g_quote.ml: parsing/grammar.cma
 contrib/ring/g_ring.ml: parsing/grammar.cma
+contrib/dp/g_dp.ml: parsing/grammar.cma
+contrib/setoid_ring/newring.ml: parsing/grammar.cma
 contrib/field/field.ml: parsing/grammar.cma
 contrib/fourier/g_fourier.ml: parsing/grammar.cma
 contrib/extraction/g_extraction.ml: parsing/grammar.cma
 contrib/xml/xmlentries.ml: parsing/grammar.cma
 contrib/jprover/jprover.ml: parsing/grammar.cma
-contrib/cc/cctac.ml: parsing/grammar.cma
+contrib/cc/g_congruence.ml: parsing/grammar.cma
 contrib/funind/tacinv.ml: parsing/grammar.cma
 contrib/first-order/g_ground.ml: parsing/grammar.cma
+contrib/subtac/g_subtac.ml: parsing/grammar.cma
+contrib/subtac/g_eterm.ml: parsing/grammar.cma
+contrib/rtauto/g_rtauto.ml: parsing/grammar.cma
+contrib/recdef/recdef.ml: parsing/grammar.cma
+contrib/funind/indfun_main.ml: parsing/grammar.cma
 contrib/interface/debug_tac.ml: parsing/grammar.cma
 contrib/interface/centaur.ml: parsing/grammar.cma
 parsing/lexer.ml: 
+parsing/pcoq.ml: 
 parsing/q_util.ml: 
 parsing/q_coqast.ml: 
 parsing/g_prim.ml: 
-parsing/pcoq.ml: 
-parsing/g_basevernac.ml: 
 parsing/g_minicoq.ml: 
-parsing/g_vernac.ml: 
+parsing/g_vernac.ml: parsing/grammar.cma
 parsing/g_proofs.ml: 
-parsing/g_cases.ml: 
+parsing/g_xml.ml: 
 parsing/g_constr.ml: 
-parsing/g_module.ml: 
 parsing/g_tactic.ml: 
 parsing/g_ltac.ml: 
 parsing/argextend.ml: 
 parsing/tacextend.ml: 
 parsing/vernacextend.ml: 
-parsing/g_primnew.ml: 
-parsing/g_vernacnew.ml: 
-parsing/g_proofsnew.ml: 
-parsing/g_constrnew.ml: 
-parsing/g_tacticnew.ml: 
-parsing/g_ltacnew.ml: 
+parsing/q_constr.ml: 
+parsing/g_decl_mode.ml: parsing/grammar.cma
 toplevel/mltop.ml: 
 lib/pp.ml: 
 lib/compat.ml: 
diff --git a/.depend.coq b/.depend.coq
index 1b20c607..e2fa8ff5 100644
--- a/.depend.coq
+++ b/.depend.coq
@@ -1,15 +1,46 @@
+theories/FSets/OrderedType.vo: theories/FSets/OrderedType.v theories/Lists/SetoidList.vo
+theories/FSets/OrderedTypeEx.vo: theories/FSets/OrderedTypeEx.v theories/FSets/OrderedType.vo theories/ZArith/ZArith.vo contrib/omega/Omega.vo theories/NArith/NArith.vo theories/NArith/Ndec.vo theories/Arith/Compare_dec.vo
+theories/FSets/OrderedTypeAlt.vo: theories/FSets/OrderedTypeAlt.v theories/FSets/OrderedType.vo
+theories/FSets/FSetInterface.vo: theories/FSets/FSetInterface.v theories/Bool/Bool.vo theories/FSets/OrderedType.vo
+theories/FSets/FSetList.vo: theories/FSets/FSetList.v theories/FSets/FSetInterface.vo
+theories/FSets/FSetBridge.vo: theories/FSets/FSetBridge.v theories/FSets/FSetInterface.vo
+theories/FSets/FSetFacts.vo: theories/FSets/FSetFacts.v theories/FSets/FSetInterface.vo
+theories/FSets/FSetProperties.vo: theories/FSets/FSetProperties.v theories/FSets/FSetInterface.vo theories/FSets/FSetFacts.vo
+theories/FSets/FSetEqProperties.vo: theories/FSets/FSetEqProperties.v theories/FSets/FSetProperties.vo theories/Bool/Zerob.vo theories/Bool/Sumbool.vo contrib/omega/Omega.vo
+theories/FSets/FSets.vo: theories/FSets/FSets.v theories/FSets/OrderedType.vo theories/FSets/OrderedTypeEx.vo theories/FSets/OrderedTypeAlt.vo theories/FSets/FSetInterface.vo theories/FSets/FSetBridge.vo theories/FSets/FSetProperties.vo theories/FSets/FSetEqProperties.vo theories/FSets/FSetList.vo
+theories/FSets/FSetWeakProperties.vo: theories/FSets/FSetWeakProperties.v theories/FSets/FSetWeakInterface.vo theories/FSets/FSetWeakFacts.vo
+theories/FSets/FSetWeakInterface.vo: theories/FSets/FSetWeakInterface.v theories/Bool/Bool.vo theories/Logic/DecidableType.vo
+theories/FSets/FSetWeakList.vo: theories/FSets/FSetWeakList.v theories/FSets/FSetWeakInterface.vo
+theories/FSets/FSetWeakFacts.vo: theories/FSets/FSetWeakFacts.v theories/FSets/FSetWeakInterface.vo
+theories/FSets/FSetWeak.vo: theories/FSets/FSetWeak.v theories/Logic/DecidableType.vo theories/Logic/DecidableTypeEx.vo theories/FSets/FSetWeakInterface.vo theories/FSets/FSetWeakFacts.vo theories/FSets/FSetWeakProperties.vo theories/FSets/FSetWeakList.vo
+theories/FSets/FMapInterface.vo: theories/FSets/FMapInterface.v theories/FSets/FSetInterface.vo
+theories/FSets/FMapList.vo: theories/FSets/FMapList.v theories/FSets/FSetInterface.vo theories/FSets/FMapInterface.vo
+theories/FSets/FMaps.vo: theories/FSets/FMaps.v theories/FSets/OrderedType.vo theories/FSets/OrderedTypeEx.vo theories/FSets/OrderedTypeAlt.vo theories/FSets/FMapInterface.vo theories/FSets/FMapList.vo theories/FSets/FMapPositive.vo theories/FSets/FMapIntMap.vo theories/FSets/FMapFacts.vo
+theories/FSets/FMapFacts.vo: theories/FSets/FMapFacts.v theories/Bool/Bool.vo theories/FSets/OrderedType.vo theories/FSets/FMapInterface.vo
+theories/FSets/FMapWeakFacts.vo: theories/FSets/FMapWeakFacts.v theories/Bool/Bool.vo theories/FSets/OrderedType.vo theories/FSets/FMapWeakInterface.vo
+theories/FSets/FMapWeakInterface.vo: theories/FSets/FMapWeakInterface.v theories/FSets/FSetInterface.vo theories/FSets/FSetWeakInterface.vo
+theories/FSets/FMapWeakList.vo: theories/FSets/FMapWeakList.v theories/FSets/FSetInterface.vo theories/FSets/FSetWeakInterface.vo theories/FSets/FMapWeakInterface.vo
+theories/FSets/FMapWeak.vo: theories/FSets/FMapWeak.v theories/Logic/DecidableType.vo theories/Logic/DecidableTypeEx.vo theories/FSets/FMapWeakInterface.vo theories/FSets/FMapWeakList.vo theories/FSets/FMapWeakFacts.vo
+theories/FSets/FMapPositive.vo: theories/FSets/FMapPositive.v theories/Bool/Bool.vo theories/ZArith/ZArith.vo theories/FSets/OrderedType.vo theories/FSets/FMapInterface.vo
+theories/FSets/FMapIntMap.vo: theories/FSets/FMapIntMap.v theories/Bool/Bool.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/NArith/Nnat.vo theories/IntMap/Allmaps.vo theories/FSets/OrderedType.vo theories/FSets/OrderedTypeEx.vo theories/FSets/FMapInterface.vo theories/FSets/FMapList.vo
+theories/FSets/FSetToFiniteSet.vo: theories/FSets/FSetToFiniteSet.v theories/Sets/Ensembles.vo theories/Sets/Finite_sets.vo theories/FSets/FSetInterface.vo theories/FSets/FSetProperties.vo theories/FSets/OrderedTypeEx.vo
+theories/FSets/FMapAVL.vo: theories/FSets/FMapAVL.v theories/FSets/FSetInterface.vo theories/FSets/FMapInterface.vo theories/FSets/FMapList.vo theories/ZArith/ZArith.vo theories/ZArith/Int.vo
+theories/FSets/FSetAVL.vo: theories/FSets/FSetAVL.v theories/FSets/FSetInterface.vo theories/FSets/FSetList.vo theories/ZArith/ZArith.vo theories/ZArith/Int.vo
 theories/Reals/Rdefinitions.vo: theories/Reals/Rdefinitions.v theories/ZArith/ZArith_base.vo
+theories/Reals/Rpow_def.vo: theories/Reals/Rpow_def.v theories/Reals/Rdefinitions.vo
 theories/Reals/Raxioms.vo: theories/Reals/Raxioms.v theories/ZArith/ZArith_base.vo theories/Reals/Rdefinitions.vo
-theories/Reals/RIneq.vo: theories/Reals/RIneq.v theories/Reals/Raxioms.vo contrib/ring/ZArithRing.vo contrib/omega/Omega.vo contrib/field/Field.vo
+theories/Reals/RIneq.vo: theories/Reals/RIneq.v theories/Reals/Raxioms.vo theories/Reals/Rpow_def.vo theories/ZArith/Zpower.vo contrib/setoid_ring/ZArithRing.vo contrib/omega/Omega.vo contrib/setoid_ring/RealField.vo
 theories/Reals/DiscrR.vo: theories/Reals/DiscrR.v theories/Reals/RIneq.vo contrib/omega/Omega.vo
 theories/Reals/Rbase.vo: theories/Reals/Rbase.v theories/Reals/Rdefinitions.vo theories/Reals/Raxioms.vo theories/Reals/RIneq.vo theories/Reals/DiscrR.vo
+theories/Reals/LegacyRfield.vo: theories/Reals/LegacyRfield.v theories/Reals/Raxioms.vo contrib/field/LegacyField.vo
 theories/Reals/R_Ifp.vo: theories/Reals/R_Ifp.v theories/Reals/Rbase.vo contrib/omega/Omega.vo
+theories/Reals/Rpow_def.vo: theories/Reals/Rpow_def.v theories/Reals/Rdefinitions.vo
 theories/Reals/Rbasic_fun.vo: theories/Reals/Rbasic_fun.v theories/Reals/Rbase.vo theories/Reals/R_Ifp.vo contrib/fourier/Fourier.vo
 theories/Reals/R_sqr.vo: theories/Reals/R_sqr.v theories/Reals/Rbase.vo theories/Reals/Rbasic_fun.vo
 theories/Reals/SplitAbsolu.vo: theories/Reals/SplitAbsolu.v theories/Reals/Rbasic_fun.vo
 theories/Reals/SplitRmult.vo: theories/Reals/SplitRmult.v theories/Reals/Rbase.vo
-theories/Reals/ArithProp.vo: theories/Reals/ArithProp.v theories/Reals/Rbase.vo theories/Reals/Rbasic_fun.vo theories/Arith/Even.vo theories/Arith/Div2.vo
-theories/Reals/Rfunctions.vo: theories/Reals/Rfunctions.v theories/Reals/Rbase.vo theories/Reals/R_Ifp.vo theories/Reals/Rbasic_fun.vo theories/Reals/R_sqr.vo theories/Reals/SplitAbsolu.vo theories/Reals/SplitRmult.vo theories/Reals/ArithProp.vo contrib/omega/Omega.vo theories/ZArith/Zpower.vo
+theories/Reals/ArithProp.vo: theories/Reals/ArithProp.v theories/Reals/Rbase.vo theories/Reals/Rbasic_fun.vo theories/Arith/Even.vo theories/Arith/Div2.vo contrib/setoid_ring/ArithRing.vo
+theories/Reals/Rfunctions.vo: theories/Reals/Rfunctions.v contrib/setoid_ring/ArithRing.vo theories/Reals/Rbase.vo theories/Reals/Rpow_def.vo theories/Reals/R_Ifp.vo theories/Reals/Rbasic_fun.vo theories/Reals/R_sqr.vo theories/Reals/SplitAbsolu.vo theories/Reals/SplitRmult.vo theories/Reals/ArithProp.vo contrib/omega/Omega.vo theories/ZArith/Zpower.vo
 theories/Reals/Rseries.vo: theories/Reals/Rseries.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Logic/Classical.vo theories/Arith/Compare.vo
 theories/Reals/SeqProp.vo: theories/Reals/SeqProp.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Logic/Classical.vo theories/Arith/Max.vo
 theories/Reals/Rcomplete.vo: theories/Reals/Rcomplete.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/SeqProp.vo theories/Arith/Max.vo
@@ -58,7 +89,8 @@ theories/Init/Logic.vo: theories/Init/Logic.v theories/Init/Notations.vo
 theories/Init/Specif.vo: theories/Init/Specif.v theories/Init/Notations.vo theories/Init/Datatypes.vo theories/Init/Logic.vo
 theories/Init/Logic_Type.vo: theories/Init/Logic_Type.v theories/Init/Datatypes.vo theories/Init/Logic.vo
 theories/Init/Wf.vo: theories/Init/Wf.v theories/Init/Notations.vo theories/Init/Logic.vo theories/Init/Datatypes.vo
-theories/Init/Prelude.vo: theories/Init/Prelude.v theories/Init/Notations.vo theories/Init/Logic.vo theories/Init/Datatypes.vo theories/Init/Specif.vo theories/Init/Peano.vo theories/Init/Wf.vo
+theories/Init/Tactics.vo: theories/Init/Tactics.v theories/Init/Notations.vo theories/Init/Logic.vo
+theories/Init/Prelude.vo: theories/Init/Prelude.v theories/Init/Notations.vo theories/Init/Logic.vo theories/Init/Datatypes.vo theories/Init/Specif.vo theories/Init/Peano.vo theories/Init/Wf.vo theories/Init/Tactics.vo
 theories/Init/Notations.vo: theories/Init/Notations.v
 theories/Init/Datatypes.vo: theories/Init/Datatypes.v theories/Init/Notations.vo theories/Init/Logic.vo
 theories/Init/Peano.vo: theories/Init/Peano.v theories/Init/Notations.vo theories/Init/Datatypes.vo theories/Init/Logic.vo
@@ -66,33 +98,41 @@ theories/Init/Logic.vo: theories/Init/Logic.v theories/Init/Notations.vo
 theories/Init/Specif.vo: theories/Init/Specif.v theories/Init/Notations.vo theories/Init/Datatypes.vo theories/Init/Logic.vo
 theories/Init/Logic_Type.vo: theories/Init/Logic_Type.v theories/Init/Datatypes.vo theories/Init/Logic.vo
 theories/Init/Wf.vo: theories/Init/Wf.v theories/Init/Notations.vo theories/Init/Logic.vo theories/Init/Datatypes.vo
-theories/Init/Prelude.vo: theories/Init/Prelude.v theories/Init/Notations.vo theories/Init/Logic.vo theories/Init/Datatypes.vo theories/Init/Specif.vo theories/Init/Peano.vo theories/Init/Wf.vo
+theories/Init/Tactics.vo: theories/Init/Tactics.v theories/Init/Notations.vo theories/Init/Logic.vo
+theories/Init/Prelude.vo: theories/Init/Prelude.v theories/Init/Notations.vo theories/Init/Logic.vo theories/Init/Datatypes.vo theories/Init/Specif.vo theories/Init/Peano.vo theories/Init/Wf.vo theories/Init/Tactics.vo
 theories/Logic/Hurkens.vo: theories/Logic/Hurkens.v
-theories/Logic/ProofIrrelevance.vo: theories/Logic/ProofIrrelevance.v theories/Logic/Hurkens.vo
+theories/Logic/ProofIrrelevance.vo: theories/Logic/ProofIrrelevance.v theories/Logic/ProofIrrelevanceFacts.vo
 theories/Logic/Classical.vo: theories/Logic/Classical.v theories/Logic/Classical_Prop.vo theories/Logic/Classical_Pred_Type.vo
 theories/Logic/Classical_Type.vo: theories/Logic/Classical_Type.v theories/Logic/Classical_Prop.vo theories/Logic/Classical_Pred_Type.vo
-theories/Logic/Classical_Pred_Set.vo: theories/Logic/Classical_Pred_Set.v theories/Logic/Classical_Prop.vo
-theories/Logic/Eqdep.vo: theories/Logic/Eqdep.v
+theories/Logic/Classical_Pred_Set.vo: theories/Logic/Classical_Pred_Set.v theories/Logic/Classical_Pred_Type.vo
+theories/Logic/Eqdep.vo: theories/Logic/Eqdep.v theories/Logic/EqdepFacts.vo
+theories/Logic/Classical_Prop.vo: theories/Logic/Classical_Prop.v theories/Logic/ClassicalFacts.vo theories/Logic/EqdepFacts.vo
 theories/Logic/Classical_Pred_Type.vo: theories/Logic/Classical_Pred_Type.v theories/Logic/Classical_Prop.vo
-theories/Logic/Classical_Prop.vo: theories/Logic/Classical_Prop.v theories/Logic/ProofIrrelevance.vo
-theories/Logic/ClassicalFacts.vo: theories/Logic/ClassicalFacts.v
-theories/Logic/ChoiceFacts.vo: theories/Logic/ChoiceFacts.v
+theories/Logic/ClassicalFacts.vo: theories/Logic/ClassicalFacts.v theories/Logic/Hurkens.vo
+theories/Logic/ChoiceFacts.vo: theories/Logic/ChoiceFacts.v theories/Arith/Wf_nat.vo theories/Arith/Compare_dec.vo theories/Logic/Decidable.vo theories/Arith/Arith.vo theories/Setoids/Setoid.vo
 theories/Logic/Berardi.vo: theories/Logic/Berardi.v
-theories/Logic/Eqdep_dec.vo: theories/Logic/Eqdep_dec.v
+theories/Logic/Eqdep_dec.vo: theories/Logic/Eqdep_dec.v theories/Logic/EqdepFacts.vo
 theories/Logic/Decidable.vo: theories/Logic/Decidable.v
 theories/Logic/JMeq.vo: theories/Logic/JMeq.v theories/Logic/Eqdep.vo
-theories/Logic/ClassicalDescription.vo: theories/Logic/ClassicalDescription.v theories/Logic/Classical.vo
-theories/Logic/ClassicalChoice.vo: theories/Logic/ClassicalChoice.v theories/Logic/ClassicalDescription.vo theories/Logic/RelationalChoice.vo theories/Logic/ChoiceFacts.vo
+theories/Logic/ClassicalChoice.vo: theories/Logic/ClassicalChoice.v theories/Logic/ClassicalUniqueChoice.vo theories/Logic/RelationalChoice.vo theories/Logic/ChoiceFacts.vo
+theories/Logic/ClassicalDescription.vo: theories/Logic/ClassicalDescription.v theories/Logic/Classical.vo theories/Logic/ChoiceFacts.vo
 theories/Logic/RelationalChoice.vo: theories/Logic/RelationalChoice.v
 theories/Logic/Diaconescu.vo: theories/Logic/Diaconescu.v theories/Logic/ClassicalFacts.vo theories/Logic/ChoiceFacts.vo theories/Bool/Bool.vo
-theories/Arith/Arith.vo: theories/Arith/Arith.v theories/Arith/Le.vo theories/Arith/Lt.vo theories/Arith/Plus.vo theories/Arith/Gt.vo theories/Arith/Minus.vo theories/Arith/Mult.vo theories/Arith/Between.vo theories/Arith/Peano_dec.vo theories/Arith/Compare_dec.vo theories/Arith/Factorial.vo
+theories/Logic/EqdepFacts.vo: theories/Logic/EqdepFacts.v
+theories/Logic/ProofIrrelevanceFacts.vo: theories/Logic/ProofIrrelevanceFacts.v theories/Logic/EqdepFacts.vo
+theories/Logic/ClassicalEpsilon.vo: theories/Logic/ClassicalEpsilon.v theories/Logic/Classical.vo theories/Logic/ChoiceFacts.vo
+theories/Logic/ClassicalUniqueChoice.vo: theories/Logic/ClassicalUniqueChoice.v theories/Logic/Classical.vo theories/Setoids/Setoid.vo
+theories/Logic/DecidableType.vo: theories/Logic/DecidableType.v theories/Lists/SetoidList.vo
+theories/Logic/DecidableTypeEx.vo: theories/Logic/DecidableTypeEx.v theories/Logic/DecidableType.vo theories/FSets/OrderedType.vo theories/FSets/OrderedTypeEx.vo
+theories/Logic/ConstructiveEpsilon.vo: theories/Logic/ConstructiveEpsilon.v theories/Arith/Arith.vo
+theories/Arith/Arith.vo: theories/Arith/Arith.v theories/Arith/Arith_base.vo contrib/setoid_ring/ArithRing.vo
 theories/Arith/Gt.vo: theories/Arith/Gt.v theories/Arith/Le.vo theories/Arith/Lt.vo theories/Arith/Plus.vo
 theories/Arith/Between.vo: theories/Arith/Between.v theories/Arith/Le.vo theories/Arith/Lt.vo
 theories/Arith/Le.vo: theories/Arith/Le.v
-theories/Arith/Compare.vo: theories/Arith/Compare.v theories/Arith/Arith.vo theories/Arith/Peano_dec.vo theories/Arith/Compare_dec.vo theories/Arith/Wf_nat.vo theories/Arith/Min.vo
+theories/Arith/Compare.vo: theories/Arith/Compare.v theories/Arith/Arith_base.vo theories/Arith/Peano_dec.vo theories/Arith/Compare_dec.vo theories/Arith/Wf_nat.vo theories/Arith/Min.vo
 theories/Arith/Lt.vo: theories/Arith/Lt.v theories/Arith/Le.vo
 theories/Arith/Compare_dec.vo: theories/Arith/Compare_dec.v theories/Arith/Le.vo theories/Arith/Lt.vo theories/Arith/Gt.vo theories/Logic/Decidable.vo
-theories/Arith/Min.vo: theories/Arith/Min.v theories/Arith/Arith.vo
+theories/Arith/Min.vo: theories/Arith/Min.v theories/Arith/Le.vo
 theories/Arith/Div2.vo: theories/Arith/Div2.v theories/Arith/Lt.vo theories/Arith/Plus.vo theories/Arith/Compare_dec.vo theories/Arith/Even.vo
 theories/Arith/Minus.vo: theories/Arith/Minus.v theories/Arith/Lt.vo theories/Arith/Le.vo
 theories/Arith/Mult.vo: theories/Arith/Mult.v theories/Arith/Plus.vo theories/Arith/Minus.vo theories/Arith/Lt.vo theories/Arith/Le.vo
@@ -105,6 +145,7 @@ theories/Arith/Wf_nat.vo: theories/Arith/Wf_nat.v theories/Arith/Lt.vo
 theories/Arith/Max.vo: theories/Arith/Max.v theories/Arith/Arith.vo
 theories/Arith/Bool_nat.vo: theories/Arith/Bool_nat.v theories/Arith/Compare_dec.vo theories/Arith/Peano_dec.vo theories/Bool/Sumbool.vo
 theories/Arith/Factorial.vo: theories/Arith/Factorial.v theories/Arith/Plus.vo theories/Arith/Mult.vo theories/Arith/Lt.vo
+theories/Arith/Arith_base.vo: theories/Arith/Arith_base.v theories/Arith/Le.vo theories/Arith/Lt.vo theories/Arith/Plus.vo theories/Arith/Gt.vo theories/Arith/Minus.vo theories/Arith/Mult.vo theories/Arith/Between.vo theories/Arith/Peano_dec.vo theories/Arith/Compare_dec.vo theories/Arith/Factorial.vo
 theories/Bool/Bool.vo: theories/Bool/Bool.v
 theories/Bool/IfProp.vo: theories/Bool/IfProp.v theories/Bool/Bool.vo
 theories/Bool/Zerob.vo: theories/Bool/Zerob.v theories/Arith/Arith.vo theories/Bool/Bool.vo
@@ -115,35 +156,48 @@ theories/Bool/Bvector.vo: theories/Bool/Bvector.v theories/Bool/Bool.vo theories
 theories/NArith/BinPos.vo: theories/NArith/BinPos.v
 theories/NArith/Pnat.vo: theories/NArith/Pnat.v theories/NArith/BinPos.vo theories/Arith/Le.vo theories/Arith/Lt.vo theories/Arith/Gt.vo theories/Arith/Plus.vo theories/Arith/Mult.vo theories/Arith/Minus.vo
 theories/NArith/BinNat.vo: theories/NArith/BinNat.v theories/NArith/BinPos.vo
-theories/NArith/NArith.vo: theories/NArith/NArith.v theories/NArith/BinPos.vo theories/NArith/BinNat.vo
+theories/NArith/NArith.vo: theories/NArith/NArith.v theories/NArith/BinPos.vo theories/NArith/BinNat.vo contrib/setoid_ring/NArithRing.vo
+theories/NArith/Nnat.vo: theories/NArith/Nnat.v theories/Arith/Arith_base.vo theories/Arith/Compare_dec.vo theories/Bool/Sumbool.vo theories/Arith/Div2.vo theories/NArith/BinPos.vo theories/NArith/BinNat.vo theories/NArith/Pnat.vo
+theories/NArith/Ndigits.vo: theories/NArith/Ndigits.v theories/Bool/Bool.vo theories/Bool/Bvector.vo theories/NArith/BinPos.vo theories/NArith/BinNat.vo
+theories/NArith/Ndec.vo: theories/NArith/Ndec.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/NArith/BinPos.vo theories/NArith/BinNat.vo theories/NArith/Pnat.vo theories/NArith/Nnat.vo theories/NArith/Ndigits.vo
+theories/NArith/Ndist.vo: theories/NArith/Ndist.v theories/Arith/Arith.vo theories/Arith/Min.vo theories/NArith/BinPos.vo theories/NArith/BinNat.vo theories/NArith/Ndigits.vo
 theories/ZArith/BinInt.vo: theories/ZArith/BinInt.v theories/NArith/BinPos.vo theories/NArith/Pnat.vo theories/NArith/BinNat.vo theories/Arith/Plus.vo theories/Arith/Mult.vo
 theories/ZArith/Wf_Z.vo: theories/ZArith/Wf_Z.v theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo theories/ZArith/Znat.vo theories/ZArith/Zmisc.vo theories/Arith/Wf_nat.vo
 theories/ZArith/ZArith.vo: theories/ZArith/ZArith.v theories/ZArith/ZArith_base.vo theories/ZArith/Zcomplements.vo theories/ZArith/Zsqrt.vo theories/ZArith/Zpower.vo theories/ZArith/Zdiv.vo theories/ZArith/Zlogarithm.vo
 theories/ZArith/ZArith_dec.vo: theories/ZArith/ZArith_dec.v theories/Bool/Sumbool.vo theories/ZArith/BinInt.vo theories/ZArith/Zorder.vo theories/ZArith/Zcompare.vo
-theories/ZArith/auxiliary.vo: theories/ZArith/auxiliary.v theories/Arith/Arith.vo theories/ZArith/BinInt.vo theories/ZArith/Zorder.vo theories/Logic/Decidable.vo theories/Arith/Peano_dec.vo theories/Arith/Compare_dec.vo
+theories/ZArith/auxiliary.vo: theories/ZArith/auxiliary.v theories/Arith/Arith_base.vo theories/ZArith/BinInt.vo theories/ZArith/Zorder.vo theories/Logic/Decidable.vo theories/Arith/Peano_dec.vo theories/Arith/Compare_dec.vo
 theories/ZArith/Zmisc.vo: theories/ZArith/Zmisc.v theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo theories/Bool/Bool.vo
 theories/ZArith/Zcompare.vo: theories/ZArith/Zcompare.v theories/NArith/BinPos.vo theories/ZArith/BinInt.vo theories/Arith/Lt.vo theories/Arith/Gt.vo theories/Arith/Plus.vo theories/Arith/Mult.vo
-theories/ZArith/Znat.vo: theories/ZArith/Znat.v theories/Arith/Arith.vo theories/NArith/BinPos.vo theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo theories/Logic/Decidable.vo theories/Arith/Peano_dec.vo theories/Arith/Compare_dec.vo
-theories/ZArith/Zorder.vo: theories/ZArith/Zorder.v theories/NArith/BinPos.vo theories/ZArith/BinInt.vo theories/Arith/Arith.vo theories/Logic/Decidable.vo theories/ZArith/Zcompare.vo
-theories/ZArith/Zabs.vo: theories/ZArith/Zabs.v theories/Arith/Arith.vo theories/NArith/BinPos.vo theories/ZArith/BinInt.vo theories/ZArith/Zorder.vo theories/ZArith/ZArith_dec.vo
-theories/ZArith/Zmin.vo: theories/ZArith/Zmin.v theories/Arith/Arith.vo theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo
+theories/ZArith/Znat.vo: theories/ZArith/Znat.v theories/Arith/Arith_base.vo theories/NArith/BinPos.vo theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo theories/Logic/Decidable.vo theories/Arith/Peano_dec.vo theories/Arith/Compare_dec.vo
+theories/ZArith/Zorder.vo: theories/ZArith/Zorder.v theories/NArith/BinPos.vo theories/ZArith/BinInt.vo theories/Arith/Arith_base.vo theories/Logic/Decidable.vo theories/ZArith/Zcompare.vo
+theories/ZArith/Zabs.vo: theories/ZArith/Zabs.v theories/Arith/Arith_base.vo theories/NArith/BinPos.vo theories/ZArith/BinInt.vo theories/ZArith/Zorder.vo theories/ZArith/ZArith_dec.vo
+theories/ZArith/Zmin.vo: theories/ZArith/Zmin.v theories/Arith/Arith_base.vo theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo
+theories/ZArith/Zmax.vo: theories/ZArith/Zmax.v theories/Arith/Arith_base.vo theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo
+theories/ZArith/Zminmax.vo: theories/ZArith/Zminmax.v theories/ZArith/Zmin.vo theories/ZArith/Zmax.vo theories/ZArith/BinInt.vo theories/ZArith/Zorder.vo
 theories/ZArith/Zeven.vo: theories/ZArith/Zeven.v theories/ZArith/BinInt.vo
 theories/ZArith/Zhints.vo: theories/ZArith/Zhints.v theories/ZArith/BinInt.vo theories/ZArith/Zorder.vo theories/ZArith/Zmin.vo theories/ZArith/Zabs.vo theories/ZArith/Zcompare.vo theories/ZArith/Znat.vo theories/ZArith/auxiliary.vo theories/ZArith/Zmisc.vo theories/ZArith/Wf_Z.vo
 theories/ZArith/Zlogarithm.vo: theories/ZArith/Zlogarithm.v theories/ZArith/ZArith_base.vo contrib/omega/Omega.vo theories/ZArith/Zcomplements.vo theories/ZArith/Zpower.vo
-theories/ZArith/Zpower.vo: theories/ZArith/Zpower.v theories/ZArith/ZArith_base.vo contrib/omega/Omega.vo theories/ZArith/Zcomplements.vo
-theories/ZArith/Zcomplements.vo: theories/ZArith/Zcomplements.v contrib/ring/ZArithRing.vo theories/ZArith/ZArith_base.vo contrib/omega/Omega.vo theories/Arith/Wf_nat.vo theories/Lists/List.vo
-theories/ZArith/Zdiv.vo: theories/ZArith/Zdiv.v theories/ZArith/ZArith_base.vo theories/ZArith/Zbool.vo contrib/omega/Omega.vo contrib/ring/ZArithRing.vo theories/ZArith/Zcomplements.vo
-theories/ZArith/Zsqrt.vo: theories/ZArith/Zsqrt.v contrib/omega/Omega.vo theories/ZArith/ZArith_base.vo contrib/ring/ZArithRing.vo
+theories/ZArith/Zpower.vo: theories/ZArith/Zpower.v theories/ZArith/ZArith_base.vo theories/ZArith/Zpow_def.vo contrib/omega/Omega.vo theories/ZArith/Zcomplements.vo
+theories/ZArith/Zcomplements.vo: theories/ZArith/Zcomplements.v contrib/setoid_ring/ZArithRing.vo theories/ZArith/ZArith_base.vo contrib/omega/Omega.vo theories/Arith/Wf_nat.vo theories/Lists/List.vo
+theories/ZArith/Zdiv.vo: theories/ZArith/Zdiv.v theories/ZArith/ZArith_base.vo theories/ZArith/Zbool.vo contrib/omega/Omega.vo contrib/setoid_ring/ZArithRing.vo theories/ZArith/Zcomplements.vo
+theories/ZArith/Zsqrt.vo: theories/ZArith/Zsqrt.v contrib/setoid_ring/ZArithRing.vo contrib/omega/Omega.vo theories/ZArith/ZArith_base.vo
 theories/ZArith/Zwf.vo: theories/ZArith/Zwf.v theories/ZArith/ZArith_base.vo theories/Arith/Wf_nat.vo contrib/omega/Omega.vo
-theories/ZArith/ZArith_base.vo: theories/ZArith/ZArith_base.v theories/NArith/BinPos.vo theories/NArith/BinNat.vo theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo theories/ZArith/Zeven.vo theories/ZArith/Zmin.vo theories/ZArith/Zabs.vo theories/ZArith/Znat.vo theories/ZArith/auxiliary.vo theories/ZArith/ZArith_dec.vo theories/ZArith/Zbool.vo theories/ZArith/Zmisc.vo theories/ZArith/Wf_Z.vo theories/ZArith/Zhints.vo
+theories/ZArith/ZArith_base.vo: theories/ZArith/ZArith_base.v theories/NArith/BinPos.vo theories/NArith/BinNat.vo theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo theories/ZArith/Zeven.vo theories/ZArith/Zmin.vo theories/ZArith/Zmax.vo theories/ZArith/Zminmax.vo theories/ZArith/Zabs.vo theories/ZArith/Znat.vo theories/ZArith/auxiliary.vo theories/ZArith/ZArith_dec.vo theories/ZArith/Zbool.vo theories/ZArith/Zmisc.vo theories/ZArith/Wf_Z.vo theories/ZArith/Zhints.vo
 theories/ZArith/Zbool.vo: theories/ZArith/Zbool.v theories/ZArith/BinInt.vo theories/ZArith/Zeven.vo theories/ZArith/Zorder.vo theories/ZArith/Zcompare.vo theories/ZArith/ZArith_dec.vo theories/Bool/Sumbool.vo
 theories/ZArith/Zbinary.vo: theories/ZArith/Zbinary.v theories/Bool/Bvector.vo theories/ZArith/ZArith.vo theories/ZArith/Zpower.vo contrib/omega/Omega.vo
-theories/ZArith/Znumtheory.vo: theories/ZArith/Znumtheory.v theories/ZArith/ZArith_base.vo contrib/ring/ZArithRing.vo theories/ZArith/Zcomplements.vo theories/ZArith/Zdiv.vo
+theories/ZArith/Znumtheory.vo: theories/ZArith/Znumtheory.v theories/ZArith/ZArith_base.vo contrib/setoid_ring/ZArithRing.vo theories/ZArith/Zcomplements.vo theories/ZArith/Zdiv.vo theories/NArith/Ndigits.vo theories/Arith/Wf_nat.vo
+theories/ZArith/Int.vo: theories/ZArith/Int.v theories/ZArith/ZArith.vo contrib/romega/ROmega.vo
+theories/ZArith/Zpow_def.vo: theories/ZArith/Zpow_def.v theories/ZArith/ZArith_base.vo contrib/setoid_ring/Ring_theory.vo
+theories/Setoids/Setoid.vo: theories/Setoids/Setoid.v theories/Relations/Relation_Definitions.vo
 theories/Lists/MonoList.vo: theories/Lists/MonoList.v theories/Arith/Le.vo
 theories/Lists/ListSet.vo: theories/Lists/ListSet.v theories/Lists/List.vo
 theories/Lists/Streams.vo: theories/Lists/Streams.v
 theories/Lists/TheoryList.vo: theories/Lists/TheoryList.v theories/Lists/List.vo theories/Arith/Le.vo theories/Arith/Lt.vo theories/Arith/Minus.vo theories/Bool/DecBool.vo
-theories/Lists/List.vo: theories/Lists/List.v theories/Arith/Le.vo
+theories/Lists/List.vo: theories/Lists/List.v theories/Arith/Le.vo theories/Arith/Gt.vo theories/Arith/Minus.vo theories/Arith/Min.vo theories/Bool/Bool.vo theories/Setoids/Setoid.vo
+theories/Lists/SetoidList.vo: theories/Lists/SetoidList.v theories/Lists/List.vo theories/Sorting/Sorting.vo theories/Setoids/Setoid.vo
+theories/Lists/ListTactics.vo: theories/Lists/ListTactics.v theories/NArith/BinPos.vo theories/Lists/List.vo
+theories/Strings/Ascii.vo: theories/Strings/Ascii.v theories/Bool/Bool.vo theories/NArith/BinPos.vo
+theories/Strings/String.vo: theories/Strings/String.v theories/Arith/Arith.vo theories/Strings/Ascii.vo
 theories/Sets/Classical_sets.vo: theories/Sets/Classical_sets.v theories/Sets/Ensembles.vo theories/Sets/Constructive_sets.vo theories/Logic/Classical_Type.vo
 theories/Sets/Permut.vo: theories/Sets/Permut.v
 theories/Sets/Constructive_sets.vo: theories/Sets/Constructive_sets.v theories/Sets/Ensembles.vo
@@ -166,22 +220,47 @@ theories/Sets/Multiset.vo: theories/Sets/Multiset.v theories/Sets/Permut.vo theo
 theories/Sets/Relations_3_facts.vo: theories/Sets/Relations_3_facts.v theories/Sets/Relations_1.vo theories/Sets/Relations_1_facts.vo theories/Sets/Relations_2.vo theories/Sets/Relations_2_facts.vo theories/Sets/Relations_3.vo
 theories/Sets/Partial_Order.vo: theories/Sets/Partial_Order.v theories/Sets/Ensembles.vo theories/Sets/Relations_1.vo
 theories/Sets/Uniset.vo: theories/Sets/Uniset.v theories/Bool/Bool.vo theories/Sets/Permut.vo
-theories/IntMap/Adalloc.vo: theories/IntMap/Adalloc.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/ZArith/ZArith.vo theories/Arith/Arith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo
-theories/IntMap/Mapcanon.vo: theories/IntMap/Mapcanon.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo theories/IntMap/Fset.vo theories/Lists/List.vo theories/IntMap/Lsort.vo theories/IntMap/Mapsubset.vo theories/IntMap/Mapcard.vo
-theories/IntMap/Addec.vo: theories/IntMap/Addec.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo
-theories/IntMap/Mapcard.vo: theories/IntMap/Mapcard.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo theories/IntMap/Fset.vo theories/IntMap/Mapsubset.vo theories/Lists/List.vo theories/IntMap/Lsort.vo theories/Arith/Peano_dec.vo
-theories/IntMap/Addr.vo: theories/IntMap/Addr.v theories/Bool/Bool.vo theories/ZArith/ZArith.vo
-theories/IntMap/Mapc.vo: theories/IntMap/Mapc.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Fset.vo theories/IntMap/Mapiter.vo theories/IntMap/Mapsubset.vo theories/Lists/List.vo theories/IntMap/Lsort.vo theories/IntMap/Mapcard.vo theories/IntMap/Mapcanon.vo
-theories/IntMap/Adist.vo: theories/IntMap/Adist.v theories/Bool/Bool.vo theories/ZArith/ZArith.vo theories/Arith/Arith.vo theories/Arith/Min.vo theories/IntMap/Addr.vo
-theories/IntMap/Mapfold.vo: theories/IntMap/Mapfold.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo theories/IntMap/Lsort.vo theories/IntMap/Mapsubset.vo theories/Lists/List.vo
-theories/IntMap/Allmaps.vo: theories/IntMap/Allmaps.v theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo theories/IntMap/Mapsubset.vo theories/IntMap/Lsort.vo theories/IntMap/Mapfold.vo theories/IntMap/Mapcard.vo theories/IntMap/Mapcanon.vo theories/IntMap/Mapc.vo theories/IntMap/Maplists.vo theories/IntMap/Adalloc.vo
-theories/IntMap/Mapiter.vo: theories/IntMap/Mapiter.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Fset.vo theories/Lists/List.vo
-theories/IntMap/Fset.vo: theories/IntMap/Fset.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo
-theories/IntMap/Maplists.vo: theories/IntMap/Maplists.v theories/IntMap/Addr.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapsubset.vo theories/IntMap/Mapcard.vo theories/IntMap/Mapcanon.vo theories/IntMap/Mapc.vo theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Lists/List.vo theories/Arith/Arith.vo theories/IntMap/Mapiter.vo theories/IntMap/Mapfold.vo
-theories/IntMap/Lsort.vo: theories/IntMap/Lsort.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/Lists/List.vo theories/IntMap/Mapiter.vo
-theories/IntMap/Mapsubset.vo: theories/IntMap/Mapsubset.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo
-theories/IntMap/Mapaxioms.vo: theories/IntMap/Mapaxioms.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo
-theories/IntMap/Map.vo: theories/IntMap/Map.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/ZArith/ZArith.vo theories/IntMap/Addr.vo theories/IntMap/Adist.vo theories/IntMap/Addec.vo
+theories/FSets/OrderedType.vo: theories/FSets/OrderedType.v theories/Lists/SetoidList.vo
+theories/FSets/OrderedTypeEx.vo: theories/FSets/OrderedTypeEx.v theories/FSets/OrderedType.vo theories/ZArith/ZArith.vo contrib/omega/Omega.vo theories/NArith/NArith.vo theories/NArith/Ndec.vo theories/Arith/Compare_dec.vo
+theories/FSets/OrderedTypeAlt.vo: theories/FSets/OrderedTypeAlt.v theories/FSets/OrderedType.vo
+theories/FSets/FSetInterface.vo: theories/FSets/FSetInterface.v theories/Bool/Bool.vo theories/FSets/OrderedType.vo
+theories/FSets/FSetList.vo: theories/FSets/FSetList.v theories/FSets/FSetInterface.vo
+theories/FSets/FSetBridge.vo: theories/FSets/FSetBridge.v theories/FSets/FSetInterface.vo
+theories/FSets/FSetFacts.vo: theories/FSets/FSetFacts.v theories/FSets/FSetInterface.vo
+theories/FSets/FSetProperties.vo: theories/FSets/FSetProperties.v theories/FSets/FSetInterface.vo theories/FSets/FSetFacts.vo
+theories/FSets/FSetEqProperties.vo: theories/FSets/FSetEqProperties.v theories/FSets/FSetProperties.vo theories/Bool/Zerob.vo theories/Bool/Sumbool.vo contrib/omega/Omega.vo
+theories/FSets/FSets.vo: theories/FSets/FSets.v theories/FSets/OrderedType.vo theories/FSets/OrderedTypeEx.vo theories/FSets/OrderedTypeAlt.vo theories/FSets/FSetInterface.vo theories/FSets/FSetBridge.vo theories/FSets/FSetProperties.vo theories/FSets/FSetEqProperties.vo theories/FSets/FSetList.vo
+theories/FSets/FSetWeakProperties.vo: theories/FSets/FSetWeakProperties.v theories/FSets/FSetWeakInterface.vo theories/FSets/FSetWeakFacts.vo
+theories/FSets/FSetWeakInterface.vo: theories/FSets/FSetWeakInterface.v theories/Bool/Bool.vo theories/Logic/DecidableType.vo
+theories/FSets/FSetWeakList.vo: theories/FSets/FSetWeakList.v theories/FSets/FSetWeakInterface.vo
+theories/FSets/FSetWeakFacts.vo: theories/FSets/FSetWeakFacts.v theories/FSets/FSetWeakInterface.vo
+theories/FSets/FSetWeak.vo: theories/FSets/FSetWeak.v theories/Logic/DecidableType.vo theories/Logic/DecidableTypeEx.vo theories/FSets/FSetWeakInterface.vo theories/FSets/FSetWeakFacts.vo theories/FSets/FSetWeakProperties.vo theories/FSets/FSetWeakList.vo
+theories/FSets/FMapInterface.vo: theories/FSets/FMapInterface.v theories/FSets/FSetInterface.vo
+theories/FSets/FMapList.vo: theories/FSets/FMapList.v theories/FSets/FSetInterface.vo theories/FSets/FMapInterface.vo
+theories/FSets/FMaps.vo: theories/FSets/FMaps.v theories/FSets/OrderedType.vo theories/FSets/OrderedTypeEx.vo theories/FSets/OrderedTypeAlt.vo theories/FSets/FMapInterface.vo theories/FSets/FMapList.vo theories/FSets/FMapPositive.vo theories/FSets/FMapIntMap.vo theories/FSets/FMapFacts.vo
+theories/FSets/FMapFacts.vo: theories/FSets/FMapFacts.v theories/Bool/Bool.vo theories/FSets/OrderedType.vo theories/FSets/FMapInterface.vo
+theories/FSets/FMapWeakFacts.vo: theories/FSets/FMapWeakFacts.v theories/Bool/Bool.vo theories/FSets/OrderedType.vo theories/FSets/FMapWeakInterface.vo
+theories/FSets/FMapWeakInterface.vo: theories/FSets/FMapWeakInterface.v theories/FSets/FSetInterface.vo theories/FSets/FSetWeakInterface.vo
+theories/FSets/FMapWeakList.vo: theories/FSets/FMapWeakList.v theories/FSets/FSetInterface.vo theories/FSets/FSetWeakInterface.vo theories/FSets/FMapWeakInterface.vo
+theories/FSets/FMapWeak.vo: theories/FSets/FMapWeak.v theories/Logic/DecidableType.vo theories/Logic/DecidableTypeEx.vo theories/FSets/FMapWeakInterface.vo theories/FSets/FMapWeakList.vo theories/FSets/FMapWeakFacts.vo
+theories/FSets/FMapPositive.vo: theories/FSets/FMapPositive.v theories/Bool/Bool.vo theories/ZArith/ZArith.vo theories/FSets/OrderedType.vo theories/FSets/FMapInterface.vo
+theories/FSets/FMapIntMap.vo: theories/FSets/FMapIntMap.v theories/Bool/Bool.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/NArith/Nnat.vo theories/IntMap/Allmaps.vo theories/FSets/OrderedType.vo theories/FSets/OrderedTypeEx.vo theories/FSets/FMapInterface.vo theories/FSets/FMapList.vo
+theories/FSets/FSetToFiniteSet.vo: theories/FSets/FSetToFiniteSet.v theories/Sets/Ensembles.vo theories/Sets/Finite_sets.vo theories/FSets/FSetInterface.vo theories/FSets/FSetProperties.vo theories/FSets/OrderedTypeEx.vo
+theories/FSets/FMapAVL.vo: theories/FSets/FMapAVL.v theories/FSets/FSetInterface.vo theories/FSets/FMapInterface.vo theories/FSets/FMapList.vo theories/ZArith/ZArith.vo theories/ZArith/Int.vo
+theories/FSets/FSetAVL.vo: theories/FSets/FSetAVL.v theories/FSets/FSetInterface.vo theories/FSets/FSetList.vo theories/ZArith/ZArith.vo theories/ZArith/Int.vo
+theories/IntMap/Adalloc.vo: theories/IntMap/Adalloc.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/NArith/Nnat.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo
+theories/IntMap/Mapcanon.vo: theories/IntMap/Mapcanon.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo theories/IntMap/Fset.vo theories/Lists/List.vo theories/IntMap/Lsort.vo theories/IntMap/Mapsubset.vo theories/IntMap/Mapcard.vo
+theories/IntMap/Mapfold.vo: theories/IntMap/Mapfold.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo theories/IntMap/Lsort.vo theories/IntMap/Mapsubset.vo theories/Lists/List.vo
+theories/IntMap/Mapcard.vo: theories/IntMap/Mapcard.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo theories/IntMap/Fset.vo theories/IntMap/Mapsubset.vo theories/Lists/List.vo theories/IntMap/Lsort.vo theories/Arith/Peano_dec.vo
+theories/IntMap/Mapc.vo: theories/IntMap/Mapc.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/NArith/NArith.vo theories/IntMap/Map.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Fset.vo theories/IntMap/Mapiter.vo theories/IntMap/Mapsubset.vo theories/Lists/List.vo theories/IntMap/Lsort.vo theories/IntMap/Mapcard.vo theories/IntMap/Mapcanon.vo
+theories/IntMap/Allmaps.vo: theories/IntMap/Allmaps.v theories/IntMap/Map.vo theories/IntMap/Fset.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo theories/IntMap/Mapsubset.vo theories/IntMap/Lsort.vo theories/IntMap/Mapfold.vo theories/IntMap/Mapcard.vo theories/IntMap/Mapcanon.vo theories/IntMap/Mapc.vo theories/IntMap/Maplists.vo theories/IntMap/Adalloc.vo
+theories/IntMap/Mapiter.vo: theories/IntMap/Mapiter.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Fset.vo theories/Lists/List.vo
+theories/IntMap/Fset.vo: theories/IntMap/Fset.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo
+theories/IntMap/Maplists.vo: theories/IntMap/Maplists.v theories/NArith/BinNat.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapsubset.vo theories/IntMap/Mapcard.vo theories/IntMap/Mapcanon.vo theories/IntMap/Mapc.vo theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Lists/List.vo theories/Arith/Arith.vo theories/IntMap/Mapiter.vo theories/IntMap/Mapfold.vo
+theories/IntMap/Lsort.vo: theories/IntMap/Lsort.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo theories/Lists/List.vo theories/IntMap/Mapiter.vo
+theories/IntMap/Mapsubset.vo: theories/IntMap/Mapsubset.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo theories/IntMap/Mapaxioms.vo theories/IntMap/Mapiter.vo
+theories/IntMap/Mapaxioms.vo: theories/IntMap/Mapaxioms.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo theories/IntMap/Map.vo theories/IntMap/Fset.vo
+theories/IntMap/Map.vo: theories/IntMap/Map.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/NArith/NArith.vo theories/NArith/Ndigits.vo theories/NArith/Ndec.vo
 theories/Relations/Newman.vo: theories/Relations/Newman.v theories/Relations/Rstar.vo
 theories/Relations/Operators_Properties.vo: theories/Relations/Operators_Properties.v theories/Relations/Relation_Definitions.vo theories/Relations/Relation_Operators.vo
 theories/Relations/Relation_Definitions.vo: theories/Relations/Relation_Definitions.v
@@ -198,17 +277,20 @@ theories/Wellfounded/Wellfounded.vo: theories/Wellfounded/Wellfounded.v theories
 theories/Wellfounded/Well_Ordering.vo: theories/Wellfounded/Well_Ordering.v theories/Logic/Eqdep.vo
 theories/Wellfounded/Lexicographic_Product.vo: theories/Wellfounded/Lexicographic_Product.v theories/Logic/Eqdep.vo theories/Relations/Relation_Operators.vo theories/Wellfounded/Transitive_Closure.vo
 theories/Reals/Rdefinitions.vo: theories/Reals/Rdefinitions.v theories/ZArith/ZArith_base.vo
+theories/Reals/Rpow_def.vo: theories/Reals/Rpow_def.v theories/Reals/Rdefinitions.vo
 theories/Reals/Raxioms.vo: theories/Reals/Raxioms.v theories/ZArith/ZArith_base.vo theories/Reals/Rdefinitions.vo
-theories/Reals/RIneq.vo: theories/Reals/RIneq.v theories/Reals/Raxioms.vo contrib/ring/ZArithRing.vo contrib/omega/Omega.vo contrib/field/Field.vo
+theories/Reals/RIneq.vo: theories/Reals/RIneq.v theories/Reals/Raxioms.vo theories/Reals/Rpow_def.vo theories/ZArith/Zpower.vo contrib/setoid_ring/ZArithRing.vo contrib/omega/Omega.vo contrib/setoid_ring/RealField.vo
 theories/Reals/DiscrR.vo: theories/Reals/DiscrR.v theories/Reals/RIneq.vo contrib/omega/Omega.vo
 theories/Reals/Rbase.vo: theories/Reals/Rbase.v theories/Reals/Rdefinitions.vo theories/Reals/Raxioms.vo theories/Reals/RIneq.vo theories/Reals/DiscrR.vo
+theories/Reals/LegacyRfield.vo: theories/Reals/LegacyRfield.v theories/Reals/Raxioms.vo contrib/field/LegacyField.vo
 theories/Reals/R_Ifp.vo: theories/Reals/R_Ifp.v theories/Reals/Rbase.vo contrib/omega/Omega.vo
+theories/Reals/Rpow_def.vo: theories/Reals/Rpow_def.v theories/Reals/Rdefinitions.vo
 theories/Reals/Rbasic_fun.vo: theories/Reals/Rbasic_fun.v theories/Reals/Rbase.vo theories/Reals/R_Ifp.vo contrib/fourier/Fourier.vo
 theories/Reals/R_sqr.vo: theories/Reals/R_sqr.v theories/Reals/Rbase.vo theories/Reals/Rbasic_fun.vo
 theories/Reals/SplitAbsolu.vo: theories/Reals/SplitAbsolu.v theories/Reals/Rbasic_fun.vo
 theories/Reals/SplitRmult.vo: theories/Reals/SplitRmult.v theories/Reals/Rbase.vo
-theories/Reals/ArithProp.vo: theories/Reals/ArithProp.v theories/Reals/Rbase.vo theories/Reals/Rbasic_fun.vo theories/Arith/Even.vo theories/Arith/Div2.vo
-theories/Reals/Rfunctions.vo: theories/Reals/Rfunctions.v theories/Reals/Rbase.vo theories/Reals/R_Ifp.vo theories/Reals/Rbasic_fun.vo theories/Reals/R_sqr.vo theories/Reals/SplitAbsolu.vo theories/Reals/SplitRmult.vo theories/Reals/ArithProp.vo contrib/omega/Omega.vo theories/ZArith/Zpower.vo
+theories/Reals/ArithProp.vo: theories/Reals/ArithProp.v theories/Reals/Rbase.vo theories/Reals/Rbasic_fun.vo theories/Arith/Even.vo theories/Arith/Div2.vo contrib/setoid_ring/ArithRing.vo
+theories/Reals/Rfunctions.vo: theories/Reals/Rfunctions.v contrib/setoid_ring/ArithRing.vo theories/Reals/Rbase.vo theories/Reals/Rpow_def.vo theories/Reals/R_Ifp.vo theories/Reals/Rbasic_fun.vo theories/Reals/R_sqr.vo theories/Reals/SplitAbsolu.vo theories/Reals/SplitRmult.vo theories/Reals/ArithProp.vo contrib/omega/Omega.vo theories/ZArith/Zpower.vo
 theories/Reals/Rseries.vo: theories/Reals/Rseries.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Logic/Classical.vo theories/Arith/Compare.vo
 theories/Reals/SeqProp.vo: theories/Reals/SeqProp.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Logic/Classical.vo theories/Arith/Max.vo
 theories/Reals/Rcomplete.vo: theories/Reals/Rcomplete.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/SeqProp.vo theories/Arith/Max.vo
@@ -250,29 +332,55 @@ theories/Reals/RiemannInt_SF.vo: theories/Reals/RiemannInt_SF.v theories/Reals/R
 theories/Reals/RiemannInt.vo: theories/Reals/RiemannInt.v theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Ranalysis.vo theories/Reals/Rbase.vo theories/Reals/RiemannInt_SF.vo theories/Logic/Classical_Prop.vo theories/Logic/Classical_Pred_Type.vo theories/Arith/Max.vo
 theories/Reals/Integration.vo: theories/Reals/Integration.v theories/Reals/NewtonInt.vo theories/Reals/RiemannInt_SF.vo theories/Reals/RiemannInt.vo
 theories/Reals/Reals.vo: theories/Reals/Reals.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis.vo theories/Reals/Integration.vo
-theories/Setoids/Setoid.vo: theories/Setoids/Setoid.v
 theories/Sorting/Heap.vo: theories/Sorting/Heap.v theories/Lists/List.vo theories/Sets/Multiset.vo theories/Sorting/Permutation.vo theories/Relations/Relations.vo theories/Sorting/Sorting.vo
-theories/Sorting/Permutation.vo: theories/Sorting/Permutation.v theories/Relations/Relations.vo theories/Lists/List.vo theories/Sets/Multiset.vo
+theories/Sorting/Permutation.vo: theories/Sorting/Permutation.v theories/Relations/Relations.vo theories/Lists/List.vo theories/Sets/Multiset.vo theories/Arith/Arith.vo
 theories/Sorting/Sorting.vo: theories/Sorting/Sorting.v theories/Lists/List.vo theories/Sets/Multiset.vo theories/Sorting/Permutation.vo theories/Relations/Relations.vo
+theories/Sorting/PermutSetoid.vo: theories/Sorting/PermutSetoid.v contrib/omega/Omega.vo theories/Relations/Relations.vo theories/Lists/List.vo theories/Sets/Multiset.vo theories/Sorting/Permutation.vo theories/Lists/SetoidList.vo
+theories/Sorting/PermutEq.vo: theories/Sorting/PermutEq.v contrib/omega/Omega.vo theories/Relations/Relations.vo theories/Setoids/Setoid.vo theories/Lists/List.vo theories/Sets/Multiset.vo theories/Sorting/Permutation.vo
+theories/QArith/QArith_base.vo: theories/QArith/QArith_base.v theories/ZArith/ZArith.vo contrib/setoid_ring/ZArithRing.vo theories/Setoids/Setoid.vo
+theories/QArith/Qreduction.vo: theories/QArith/Qreduction.v theories/QArith/QArith_base.vo theories/ZArith/Znumtheory.vo
+theories/QArith/Qring.vo: theories/QArith/Qring.v contrib/setoid_ring/Ring.vo theories/QArith/QArith_base.vo
+theories/QArith/Qreals.vo: theories/QArith/Qreals.v theories/Reals/Rbase.vo theories/QArith/QArith_base.vo
+theories/QArith/QArith.vo: theories/QArith/QArith.v theories/QArith/QArith_base.vo theories/QArith/Qring.vo theories/QArith/Qreduction.vo
+theories/QArith/Qcanon.vo: theories/QArith/Qcanon.v contrib/setoid_ring/Field.vo theories/QArith/QArith.vo theories/ZArith/Znumtheory.vo theories/Logic/Eqdep_dec.vo
 contrib/omega/OmegaLemmas.vo: contrib/omega/OmegaLemmas.v theories/ZArith/ZArith_base.vo
 contrib/omega/Omega.vo: contrib/omega/Omega.v theories/ZArith/ZArith_base.vo contrib/omega/OmegaLemmas.vo theories/ZArith/Zhints.vo
-contrib/romega/ReflOmegaCore.vo: contrib/romega/ReflOmegaCore.v theories/Arith/Arith.vo theories/Lists/List.vo theories/Bool/Bool.vo theories/ZArith/ZArith.vo contrib/omega/OmegaLemmas.vo theories/Logic/Decidable.vo
-contrib/romega/ROmega.vo: contrib/romega/ROmega.v contrib/omega/Omega.vo contrib/romega/ReflOmegaCore.vo
-contrib/ring/ArithRing.vo: contrib/ring/ArithRing.v contrib/ring/Ring.vo theories/Arith/Arith.vo theories/Logic/Eqdep_dec.vo
-contrib/ring/Ring_normalize.vo: contrib/ring/Ring_normalize.v contrib/ring/Ring_theory.vo contrib/ring/Quote.vo
-contrib/ring/Ring_theory.vo: contrib/ring/Ring_theory.v theories/Bool/Bool.vo
-contrib/ring/Ring.vo: contrib/ring/Ring.v theories/Bool/Bool.vo contrib/ring/Ring_theory.vo contrib/ring/Quote.vo contrib/ring/Ring_normalize.vo contrib/ring/Ring_abstract.vo
-contrib/ring/NArithRing.vo: contrib/ring/NArithRing.v contrib/ring/Ring.vo theories/ZArith/ZArith_base.vo theories/NArith/NArith.vo theories/Logic/Eqdep_dec.vo
-contrib/ring/ZArithRing.vo: contrib/ring/ZArithRing.v contrib/ring/ArithRing.vo theories/ZArith/ZArith_base.vo theories/Logic/Eqdep_dec.vo
-contrib/ring/Ring_abstract.vo: contrib/ring/Ring_abstract.v contrib/ring/Ring_theory.vo contrib/ring/Quote.vo contrib/ring/Ring_normalize.vo
+contrib/romega/ReflOmegaCore.vo: contrib/romega/ReflOmegaCore.v theories/Arith/Arith.vo theories/Lists/List.vo theories/Bool/Bool.vo theories/ZArith/ZArith_base.vo contrib/omega/OmegaLemmas.vo theories/Logic/Decidable.vo
+contrib/romega/ROmega.vo: contrib/romega/ROmega.v contrib/romega/ReflOmegaCore.vo
+contrib/ring/LegacyArithRing.vo: contrib/ring/LegacyArithRing.v theories/Bool/Bool.vo contrib/ring/LegacyRing.vo theories/Arith/Arith.vo theories/Logic/Eqdep_dec.vo
+contrib/ring/Ring_normalize.vo: contrib/ring/Ring_normalize.v contrib/ring/LegacyRing_theory.vo contrib/ring/Quote.vo
+contrib/ring/LegacyRing_theory.vo: contrib/ring/LegacyRing_theory.v theories/Bool/Bool.vo
+contrib/ring/LegacyRing.vo: contrib/ring/LegacyRing.v theories/Bool/Bool.vo contrib/ring/LegacyRing_theory.vo contrib/ring/Quote.vo contrib/ring/Ring_normalize.vo contrib/ring/Ring_abstract.vo
+contrib/ring/LegacyNArithRing.vo: contrib/ring/LegacyNArithRing.v theories/Bool/Bool.vo contrib/ring/LegacyRing.vo theories/ZArith/ZArith_base.vo theories/NArith/NArith.vo theories/Logic/Eqdep_dec.vo
+contrib/ring/LegacyZArithRing.vo: contrib/ring/LegacyZArithRing.v contrib/ring/LegacyArithRing.vo theories/ZArith/ZArith_base.vo theories/Logic/Eqdep_dec.vo contrib/ring/LegacyRing.vo
+contrib/ring/Ring_abstract.vo: contrib/ring/Ring_abstract.v contrib/ring/LegacyRing_theory.vo contrib/ring/Quote.vo contrib/ring/Ring_normalize.vo
 contrib/ring/Quote.vo: contrib/ring/Quote.v
 contrib/ring/Setoid_ring_normalize.vo: contrib/ring/Setoid_ring_normalize.v contrib/ring/Setoid_ring_theory.vo contrib/ring/Quote.vo
 contrib/ring/Setoid_ring.vo: contrib/ring/Setoid_ring.v contrib/ring/Setoid_ring_theory.vo contrib/ring/Quote.vo contrib/ring/Setoid_ring_normalize.vo
 contrib/ring/Setoid_ring_theory.vo: contrib/ring/Setoid_ring_theory.v theories/Bool/Bool.vo theories/Setoids/Setoid.vo
-contrib/field/Field_Compl.vo: contrib/field/Field_Compl.v
-contrib/field/Field_Theory.vo: contrib/field/Field_Theory.v theories/Arith/Peano_dec.vo contrib/ring/Ring.vo contrib/field/Field_Compl.vo
-contrib/field/Field_Tactic.vo: contrib/field/Field_Tactic.v contrib/ring/Ring.vo contrib/field/Field_Compl.vo contrib/field/Field_Theory.vo
-contrib/field/Field.vo: contrib/field/Field.v contrib/field/Field_Compl.vo contrib/field/Field_Theory.vo contrib/field/Field_Tactic.vo
+contrib/field/LegacyField_Compl.vo: contrib/field/LegacyField_Compl.v theories/Lists/List.vo
+contrib/field/LegacyField_Theory.vo: contrib/field/LegacyField_Theory.v theories/Lists/List.vo theories/Arith/Peano_dec.vo contrib/ring/LegacyRing.vo contrib/field/LegacyField_Compl.vo
+contrib/field/LegacyField_Tactic.vo: contrib/field/LegacyField_Tactic.v theories/Lists/List.vo contrib/ring/LegacyRing.vo contrib/field/LegacyField_Compl.vo contrib/field/LegacyField_Theory.vo
+contrib/field/LegacyField.vo: contrib/field/LegacyField.v contrib/field/LegacyField_Compl.vo contrib/field/LegacyField_Theory.vo contrib/field/LegacyField_Tactic.vo
 contrib/fourier/Fourier_util.vo: contrib/fourier/Fourier_util.v theories/Reals/Rbase.vo
-contrib/fourier/Fourier.vo: contrib/fourier/Fourier.v contrib/ring/quote.cmo contrib/ring/ring.cmo contrib/fourier/fourier.cmo contrib/fourier/fourierR.cmo contrib/field/field.cmo contrib/fourier/Fourier_util.vo contrib/field/Field.vo theories/Reals/DiscrR.vo
-contrib/cc/CCSolve.vo: contrib/cc/CCSolve.v
+contrib/fourier/Fourier.vo: contrib/fourier/Fourier.v contrib/ring/quote.cmo contrib/ring/ring.cmo contrib/fourier/fourier.cmo contrib/fourier/fourierR.cmo contrib/field/field.cmo contrib/fourier/Fourier_util.vo contrib/field/LegacyField.vo theories/Reals/DiscrR.vo
+contrib/subtac/FixSub.vo: contrib/subtac/FixSub.v theories/Init/Wf.vo theories/Arith/Wf_nat.vo theories/Arith/Lt.vo
+contrib/subtac/Utils.vo: contrib/subtac/Utils.v
+contrib/rtauto/Bintree.vo: contrib/rtauto/Bintree.v theories/Lists/List.vo theories/NArith/BinPos.vo
+contrib/rtauto/Rtauto.vo: contrib/rtauto/Rtauto.v theories/Lists/List.vo contrib/rtauto/Bintree.vo theories/Bool/Bool.vo theories/NArith/BinPos.vo
+contrib/recdef/Recdef.vo: contrib/recdef/Recdef.v theories/Arith/Compare_dec.vo theories/Arith/Wf_nat.vo
+contrib/setoid_ring/BinList.vo: contrib/setoid_ring/BinList.v theories/NArith/BinPos.vo theories/Lists/List.vo theories/Lists/ListTactics.vo
+contrib/setoid_ring/Ring_theory.vo: contrib/setoid_ring/Ring_theory.v theories/Setoids/Setoid.vo theories/NArith/BinPos.vo theories/NArith/BinNat.vo
+contrib/setoid_ring/Ring_polynom.vo: contrib/setoid_ring/Ring_polynom.v theories/Setoids/Setoid.vo contrib/setoid_ring/BinList.vo theories/NArith/BinPos.vo theories/NArith/BinNat.vo theories/ZArith/BinInt.vo contrib/setoid_ring/Ring_theory.vo
+contrib/setoid_ring/Ring_tac.vo: contrib/setoid_ring/Ring_tac.v theories/Setoids/Setoid.vo theories/NArith/BinPos.vo contrib/setoid_ring/Ring_polynom.vo contrib/setoid_ring/BinList.vo contrib/setoid_ring/InitialRing.vo contrib/setoid_ring/newring.cmo
+contrib/setoid_ring/Ring_base.vo: contrib/setoid_ring/Ring_base.v contrib/setoid_ring/newring.cmo contrib/setoid_ring/Ring_theory.vo contrib/setoid_ring/Ring_tac.vo contrib/setoid_ring/InitialRing.vo
+contrib/setoid_ring/InitialRing.vo: contrib/setoid_ring/InitialRing.v theories/ZArith/ZArith_base.vo theories/ZArith/Zpow_def.vo theories/ZArith/BinInt.vo theories/NArith/BinNat.vo theories/Setoids/Setoid.vo contrib/setoid_ring/Ring_theory.vo contrib/setoid_ring/Ring_polynom.vo
+contrib/setoid_ring/Ring_equiv.vo: contrib/setoid_ring/Ring_equiv.v contrib/ring/Setoid_ring_theory.vo contrib/ring/LegacyRing_theory.vo contrib/setoid_ring/Ring_theory.vo
+contrib/setoid_ring/Ring.vo: contrib/setoid_ring/Ring.v theories/Bool/Bool.vo contrib/setoid_ring/Ring_theory.vo contrib/setoid_ring/Ring_base.vo contrib/setoid_ring/InitialRing.vo contrib/setoid_ring/Ring_tac.vo
+contrib/setoid_ring/ArithRing.vo: contrib/setoid_ring/ArithRing.v theories/Arith/Mult.vo theories/NArith/BinNat.vo theories/NArith/Nnat.vo contrib/setoid_ring/Ring.vo
+contrib/setoid_ring/NArithRing.vo: contrib/setoid_ring/NArithRing.v contrib/setoid_ring/Ring.vo theories/NArith/BinPos.vo theories/NArith/BinNat.vo
+contrib/setoid_ring/ZArithRing.vo: contrib/setoid_ring/ZArithRing.v contrib/setoid_ring/Ring.vo theories/ZArith/ZArith_base.vo theories/ZArith/Zpow_def.vo
+contrib/setoid_ring/Field_theory.vo: contrib/setoid_ring/Field_theory.v contrib/setoid_ring/Ring.vo theories/ZArith/ZArith_base.vo
+contrib/setoid_ring/Field_tac.vo: contrib/setoid_ring/Field_tac.v contrib/setoid_ring/Ring_tac.vo contrib/setoid_ring/BinList.vo contrib/setoid_ring/Ring_polynom.vo contrib/setoid_ring/InitialRing.vo contrib/setoid_ring/Field_theory.vo
+contrib/setoid_ring/Field.vo: contrib/setoid_ring/Field.v contrib/setoid_ring/Field_theory.vo contrib/setoid_ring/Field_tac.vo
+contrib/setoid_ring/RealField.vo: contrib/setoid_ring/RealField.v theories/NArith/Nnat.vo contrib/setoid_ring/ArithRing.vo contrib/setoid_ring/Ring.vo contrib/setoid_ring/Field.vo theories/Reals/Rdefinitions.vo theories/Reals/Rpow_def.vo theories/Reals/Raxioms.vo
diff --git a/.depend.coq7 b/.depend.coq7
deleted file mode 100644
index 452c951f..00000000
--- a/.depend.coq7
+++ /dev/null
@@ -1,231 +0,0 @@
-theories7/Init/Notations.vo: theories7/Init/Notations.v
-theories7/Init/Datatypes.vo: theories7/Init/Datatypes.v theories7/Init/Notations.vo theories7/Init/Logic.vo
-theories7/Init/Peano.vo: theories7/Init/Peano.v theories7/Init/Notations.vo theories7/Init/Datatypes.vo theories7/Init/Logic.vo
-theories7/Init/Logic.vo: theories7/Init/Logic.v theories7/Init/Notations.vo
-theories7/Init/Specif.vo: theories7/Init/Specif.v theories7/Init/Notations.vo theories7/Init/Datatypes.vo theories7/Init/Logic.vo
-theories7/Init/Logic_Type.vo: theories7/Init/Logic_Type.v theories7/Init/Datatypes.vo theories7/Init/Logic.vo
-theories7/Init/Wf.vo: theories7/Init/Wf.v theories7/Init/Notations.vo theories7/Init/Logic.vo theories7/Init/Datatypes.vo
-theories7/Init/Prelude.vo: theories7/Init/Prelude.v theories7/Init/Notations.vo theories7/Init/Logic.vo theories7/Init/Datatypes.vo theories7/Init/Specif.vo theories7/Init/Peano.vo theories7/Init/Wf.vo
-theories7/Init/Notations.vo: theories7/Init/Notations.v
-theories7/Init/Datatypes.vo: theories7/Init/Datatypes.v theories7/Init/Notations.vo theories7/Init/Logic.vo
-theories7/Init/Peano.vo: theories7/Init/Peano.v theories7/Init/Notations.vo theories7/Init/Datatypes.vo theories7/Init/Logic.vo
-theories7/Init/Logic.vo: theories7/Init/Logic.v theories7/Init/Notations.vo
-theories7/Init/Specif.vo: theories7/Init/Specif.v theories7/Init/Notations.vo theories7/Init/Datatypes.vo theories7/Init/Logic.vo
-theories7/Init/Logic_Type.vo: theories7/Init/Logic_Type.v theories7/Init/Datatypes.vo theories7/Init/Logic.vo
-theories7/Init/Wf.vo: theories7/Init/Wf.v theories7/Init/Notations.vo theories7/Init/Logic.vo theories7/Init/Datatypes.vo
-theories7/Init/Prelude.vo: theories7/Init/Prelude.v theories7/Init/Notations.vo theories7/Init/Logic.vo theories7/Init/Datatypes.vo theories7/Init/Specif.vo theories7/Init/Peano.vo theories7/Init/Wf.vo
-theories7/Logic/Hurkens.vo: theories7/Logic/Hurkens.v
-theories7/Logic/ProofIrrelevance.vo: theories7/Logic/ProofIrrelevance.v theories7/Logic/Hurkens.vo
-theories7/Logic/Classical.vo: theories7/Logic/Classical.v theories7/Logic/Classical_Prop.vo theories7/Logic/Classical_Pred_Type.vo
-theories7/Logic/Classical_Type.vo: theories7/Logic/Classical_Type.v theories7/Logic/Classical_Prop.vo theories7/Logic/Classical_Pred_Type.vo
-theories7/Logic/Classical_Pred_Set.vo: theories7/Logic/Classical_Pred_Set.v theories7/Logic/Classical_Prop.vo
-theories7/Logic/Eqdep.vo: theories7/Logic/Eqdep.v
-theories7/Logic/Classical_Pred_Type.vo: theories7/Logic/Classical_Pred_Type.v theories7/Logic/Classical_Prop.vo
-theories7/Logic/Classical_Prop.vo: theories7/Logic/Classical_Prop.v theories7/Logic/ProofIrrelevance.vo
-theories7/Logic/ClassicalFacts.vo: theories7/Logic/ClassicalFacts.v
-theories7/Logic/ChoiceFacts.vo: theories7/Logic/ChoiceFacts.v
-theories7/Logic/Berardi.vo: theories7/Logic/Berardi.v
-theories7/Logic/Eqdep_dec.vo: theories7/Logic/Eqdep_dec.v
-theories7/Logic/Decidable.vo: theories7/Logic/Decidable.v
-theories7/Logic/JMeq.vo: theories7/Logic/JMeq.v theories7/Logic/Eqdep.vo
-theories7/Logic/ClassicalDescription.vo: theories7/Logic/ClassicalDescription.v theories7/Logic/Classical.vo
-theories7/Logic/ClassicalChoice.vo: theories7/Logic/ClassicalChoice.v theories7/Logic/ClassicalDescription.vo theories7/Logic/RelationalChoice.vo theories7/Logic/ChoiceFacts.vo
-theories7/Logic/RelationalChoice.vo: theories7/Logic/RelationalChoice.v
-theories7/Logic/Diaconescu.vo: theories7/Logic/Diaconescu.v theories7/Logic/ClassicalFacts.vo theories7/Logic/ChoiceFacts.vo theories7/Bool/Bool.vo
-theories7/Arith/Arith.vo: theories7/Arith/Arith.v theories7/Arith/Le.vo theories7/Arith/Lt.vo theories7/Arith/Plus.vo theories7/Arith/Gt.vo theories7/Arith/Minus.vo theories7/Arith/Mult.vo theories7/Arith/Between.vo theories7/Arith/Peano_dec.vo theories7/Arith/Compare_dec.vo theories7/Arith/Factorial.vo
-theories7/Arith/Gt.vo: theories7/Arith/Gt.v theories7/Arith/Le.vo theories7/Arith/Lt.vo theories7/Arith/Plus.vo
-theories7/Arith/Between.vo: theories7/Arith/Between.v theories7/Arith/Le.vo theories7/Arith/Lt.vo
-theories7/Arith/Le.vo: theories7/Arith/Le.v
-theories7/Arith/Compare.vo: theories7/Arith/Compare.v theories7/Arith/Arith.vo theories7/Arith/Peano_dec.vo theories7/Arith/Compare_dec.vo theories7/Arith/Wf_nat.vo theories7/Arith/Min.vo
-theories7/Arith/Lt.vo: theories7/Arith/Lt.v theories7/Arith/Le.vo
-theories7/Arith/Compare_dec.vo: theories7/Arith/Compare_dec.v theories7/Arith/Le.vo theories7/Arith/Lt.vo theories7/Arith/Gt.vo theories7/Logic/Decidable.vo
-theories7/Arith/Min.vo: theories7/Arith/Min.v theories7/Arith/Arith.vo
-theories7/Arith/Div2.vo: theories7/Arith/Div2.v theories7/Arith/Lt.vo theories7/Arith/Plus.vo theories7/Arith/Compare_dec.vo theories7/Arith/Even.vo
-theories7/Arith/Minus.vo: theories7/Arith/Minus.v theories7/Arith/Lt.vo theories7/Arith/Le.vo
-theories7/Arith/Mult.vo: theories7/Arith/Mult.v theories7/Arith/Plus.vo theories7/Arith/Minus.vo theories7/Arith/Lt.vo theories7/Arith/Le.vo
-theories7/Arith/Even.vo: theories7/Arith/Even.v
-theories7/Arith/EqNat.vo: theories7/Arith/EqNat.v
-theories7/Arith/Peano_dec.vo: theories7/Arith/Peano_dec.v theories7/Logic/Decidable.vo
-theories7/Arith/Euclid.vo: theories7/Arith/Euclid.v theories7/Arith/Mult.vo theories7/Arith/Compare_dec.vo theories7/Arith/Wf_nat.vo
-theories7/Arith/Plus.vo: theories7/Arith/Plus.v theories7/Arith/Le.vo theories7/Arith/Lt.vo
-theories7/Arith/Wf_nat.vo: theories7/Arith/Wf_nat.v theories7/Arith/Lt.vo
-theories7/Arith/Max.vo: theories7/Arith/Max.v theories7/Arith/Arith.vo
-theories7/Arith/Bool_nat.vo: theories7/Arith/Bool_nat.v theories7/Arith/Compare_dec.vo theories7/Arith/Peano_dec.vo theories7/Bool/Sumbool.vo
-theories7/Arith/Factorial.vo: theories7/Arith/Factorial.v theories7/Arith/Plus.vo theories7/Arith/Mult.vo theories7/Arith/Lt.vo
-theories7/Bool/Bool.vo: theories7/Bool/Bool.v
-theories7/Bool/IfProp.vo: theories7/Bool/IfProp.v theories7/Bool/Bool.vo
-theories7/Bool/Zerob.vo: theories7/Bool/Zerob.v theories7/Arith/Arith.vo theories7/Bool/Bool.vo
-theories7/Bool/DecBool.vo: theories7/Bool/DecBool.v
-theories7/Bool/Sumbool.vo: theories7/Bool/Sumbool.v
-theories7/Bool/BoolEq.vo: theories7/Bool/BoolEq.v theories7/Bool/Bool.vo
-theories7/Bool/Bvector.vo: theories7/Bool/Bvector.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/Arith/Arith.vo
-theories7/NArith/BinPos.vo: theories7/NArith/BinPos.v
-theories7/NArith/Pnat.vo: theories7/NArith/Pnat.v theories7/NArith/BinPos.vo theories7/Arith/Le.vo theories7/Arith/Lt.vo theories7/Arith/Gt.vo theories7/Arith/Plus.vo theories7/Arith/Mult.vo theories7/Arith/Minus.vo
-theories7/NArith/BinNat.vo: theories7/NArith/BinNat.v theories7/NArith/BinPos.vo
-theories7/NArith/NArith.vo: theories7/NArith/NArith.v theories7/NArith/BinPos.vo theories7/NArith/BinNat.vo
-theories7/ZArith/BinInt.vo: theories7/ZArith/BinInt.v theories7/NArith/BinPos.vo theories7/NArith/Pnat.vo theories7/NArith/BinNat.vo theories7/Arith/Plus.vo theories7/Arith/Mult.vo
-theories7/ZArith/Wf_Z.vo: theories7/ZArith/Wf_Z.v theories7/ZArith/BinInt.vo theories7/ZArith/Zcompare.vo theories7/ZArith/Zorder.vo theories7/ZArith/Znat.vo theories7/ZArith/Zmisc.vo theories7/ZArith/Zsyntax.vo theories7/Arith/Wf_nat.vo
-theories7/ZArith/ZArith.vo: theories7/ZArith/ZArith.v theories7/ZArith/ZArith_base.vo theories7/ZArith/Zcomplements.vo theories7/ZArith/Zsqrt.vo theories7/ZArith/Zpower.vo theories7/ZArith/Zdiv.vo theories7/ZArith/Zlogarithm.vo theories7/ZArith/Zbool.vo
-theories7/ZArith/ZArith_dec.vo: theories7/ZArith/ZArith_dec.v theories7/Bool/Sumbool.vo theories7/ZArith/BinInt.vo theories7/ZArith/Zorder.vo theories7/ZArith/Zcompare.vo theories7/ZArith/Zsyntax.vo
-theories7/ZArith/auxiliary.vo: theories7/ZArith/auxiliary.v theories7/Arith/Arith.vo theories7/ZArith/BinInt.vo theories7/ZArith/Zorder.vo theories7/Logic/Decidable.vo theories7/Arith/Peano_dec.vo theories7/Arith/Compare_dec.vo theories7/ZArith/Znat.vo theories7/ZArith/Zcompare.vo
-theories7/ZArith/Zmisc.vo: theories7/ZArith/Zmisc.v theories7/ZArith/BinInt.vo theories7/ZArith/Zcompare.vo theories7/ZArith/Zorder.vo theories7/ZArith/Zsyntax.vo theories7/Bool/Bool.vo theories7/ZArith/Zbool.vo theories7/ZArith/Zeven.vo theories7/ZArith/Zabs.vo theories7/ZArith/Zmin.vo
-theories7/ZArith/Zcompare.vo: theories7/ZArith/Zcompare.v theories7/NArith/BinPos.vo theories7/ZArith/BinInt.vo theories7/ZArith/Zsyntax.vo theories7/Arith/Lt.vo theories7/Arith/Gt.vo theories7/Arith/Plus.vo theories7/Arith/Mult.vo
-theories7/ZArith/Znat.vo: theories7/ZArith/Znat.v theories7/Arith/Arith.vo theories7/NArith/BinPos.vo theories7/ZArith/BinInt.vo theories7/ZArith/Zcompare.vo theories7/ZArith/Zorder.vo theories7/Logic/Decidable.vo theories7/Arith/Peano_dec.vo theories7/Arith/Compare_dec.vo
-theories7/ZArith/Zorder.vo: theories7/ZArith/Zorder.v theories7/NArith/BinPos.vo theories7/ZArith/BinInt.vo theories7/Arith/Arith.vo theories7/Logic/Decidable.vo theories7/ZArith/Zsyntax.vo theories7/ZArith/Zcompare.vo
-theories7/ZArith/Zabs.vo: theories7/ZArith/Zabs.v theories7/Arith/Arith.vo theories7/NArith/BinPos.vo theories7/ZArith/BinInt.vo theories7/ZArith/Zorder.vo theories7/ZArith/Zsyntax.vo theories7/ZArith/ZArith_dec.vo
-theories7/ZArith/Zmin.vo: theories7/ZArith/Zmin.v theories7/Arith/Arith.vo theories7/ZArith/BinInt.vo theories7/ZArith/Zcompare.vo theories7/ZArith/Zorder.vo
-theories7/ZArith/Zeven.vo: theories7/ZArith/Zeven.v theories7/ZArith/BinInt.vo theories7/ZArith/Zsyntax.vo
-theories7/ZArith/Zhints.vo: theories7/ZArith/Zhints.v theories7/ZArith/BinInt.vo theories7/ZArith/Zorder.vo theories7/ZArith/Zmin.vo theories7/ZArith/Zabs.vo theories7/ZArith/Zcompare.vo theories7/ZArith/Znat.vo theories7/ZArith/auxiliary.vo theories7/ZArith/Zsyntax.vo theories7/ZArith/Zmisc.vo theories7/ZArith/Wf_Z.vo
-theories7/ZArith/Zlogarithm.vo: theories7/ZArith/Zlogarithm.v theories7/ZArith/ZArith_base.vo contrib7/omega/Omega.vo theories7/ZArith/Zcomplements.vo theories7/ZArith/Zpower.vo
-theories7/ZArith/Zpower.vo: theories7/ZArith/Zpower.v theories7/ZArith/ZArith_base.vo contrib7/omega/Omega.vo theories7/ZArith/Zcomplements.vo
-theories7/ZArith/Zcomplements.vo: theories7/ZArith/Zcomplements.v contrib7/ring/ZArithRing.vo theories7/ZArith/ZArith_base.vo contrib7/omega/Omega.vo theories7/Arith/Wf_nat.vo theories7/Lists/PolyList.vo
-theories7/ZArith/Zdiv.vo: theories7/ZArith/Zdiv.v theories7/ZArith/ZArith_base.vo theories7/ZArith/Zbool.vo contrib7/omega/Omega.vo contrib7/ring/ZArithRing.vo theories7/ZArith/Zcomplements.vo
-theories7/ZArith/Zsqrt.vo: theories7/ZArith/Zsqrt.v contrib7/omega/Omega.vo theories7/ZArith/ZArith_base.vo contrib7/ring/ZArithRing.vo
-theories7/ZArith/Zwf.vo: theories7/ZArith/Zwf.v theories7/ZArith/ZArith_base.vo theories7/Arith/Wf_nat.vo contrib7/omega/Omega.vo
-theories7/ZArith/ZArith_base.vo: theories7/ZArith/ZArith_base.v theories7/ZArith/fast_integer.vo theories7/ZArith/zarith_aux.vo theories7/NArith/BinPos.vo theories7/NArith/BinNat.vo theories7/ZArith/BinInt.vo theories7/ZArith/Zcompare.vo theories7/ZArith/Zorder.vo theories7/ZArith/Zeven.vo theories7/ZArith/Zmin.vo theories7/ZArith/Zabs.vo theories7/ZArith/Znat.vo theories7/ZArith/auxiliary.vo theories7/ZArith/Zsyntax.vo theories7/ZArith/ZArith_dec.vo theories7/ZArith/Zbool.vo theories7/ZArith/Zmisc.vo theories7/ZArith/Wf_Z.vo theories7/ZArith/Zhints.vo
-theories7/ZArith/Zbool.vo: theories7/ZArith/Zbool.v theories7/ZArith/BinInt.vo theories7/ZArith/Zeven.vo theories7/ZArith/Zorder.vo theories7/ZArith/Zcompare.vo theories7/ZArith/ZArith_dec.vo theories7/ZArith/Zsyntax.vo theories7/Bool/Sumbool.vo
-theories7/ZArith/Zbinary.vo: theories7/ZArith/Zbinary.v theories7/Bool/Bvector.vo theories7/ZArith/ZArith.vo theories7/ZArith/Zpower.vo contrib7/omega/Omega.vo
-theories7/ZArith/Znumtheory.vo: theories7/ZArith/Znumtheory.v theories7/ZArith/ZArith_base.vo contrib7/ring/ZArithRing.vo theories7/ZArith/Zcomplements.vo theories7/ZArith/Zdiv.vo
-theories7/Lists/MonoList.vo: theories7/Lists/MonoList.v theories7/Arith/Le.vo
-theories7/Lists/ListSet.vo: theories7/Lists/ListSet.v theories7/Lists/PolyList.vo
-theories7/Lists/Streams.vo: theories7/Lists/Streams.v
-theories7/Lists/TheoryList.vo: theories7/Lists/TheoryList.v theories7/Lists/PolyList.vo theories7/Arith/Le.vo theories7/Arith/Lt.vo theories7/Arith/Minus.vo theories7/Bool/DecBool.vo
-theories7/Lists/List.vo: theories7/Lists/List.v theories7/Arith/Le.vo
-theories7/Sets/Classical_sets.vo: theories7/Sets/Classical_sets.v theories7/Sets/Ensembles.vo theories7/Sets/Constructive_sets.vo theories7/Logic/Classical_Type.vo
-theories7/Sets/Permut.vo: theories7/Sets/Permut.v
-theories7/Sets/Constructive_sets.vo: theories7/Sets/Constructive_sets.v theories7/Sets/Ensembles.vo
-theories7/Sets/Powerset.vo: theories7/Sets/Powerset.v theories7/Sets/Ensembles.vo theories7/Sets/Relations_1.vo theories7/Sets/Relations_1_facts.vo theories7/Sets/Partial_Order.vo theories7/Sets/Cpo.vo
-theories7/Sets/Cpo.vo: theories7/Sets/Cpo.v theories7/Sets/Ensembles.vo theories7/Sets/Relations_1.vo theories7/Sets/Partial_Order.vo
-theories7/Sets/Powerset_Classical_facts.vo: theories7/Sets/Powerset_Classical_facts.v theories7/Sets/Ensembles.vo theories7/Sets/Constructive_sets.vo theories7/Sets/Relations_1.vo theories7/Sets/Relations_1_facts.vo theories7/Sets/Partial_Order.vo theories7/Sets/Cpo.vo theories7/Sets/Powerset.vo theories7/Sets/Powerset_facts.vo theories7/Logic/Classical_Type.vo theories7/Sets/Classical_sets.vo
-theories7/Sets/Ensembles.vo: theories7/Sets/Ensembles.v
-theories7/Sets/Powerset_facts.vo: theories7/Sets/Powerset_facts.v theories7/Sets/Ensembles.vo theories7/Sets/Constructive_sets.vo theories7/Sets/Relations_1.vo theories7/Sets/Relations_1_facts.vo theories7/Sets/Partial_Order.vo theories7/Sets/Cpo.vo theories7/Sets/Powerset.vo
-theories7/Sets/Finite_sets.vo: theories7/Sets/Finite_sets.v theories7/Sets/Ensembles.vo theories7/Sets/Constructive_sets.vo
-theories7/Sets/Relations_1.vo: theories7/Sets/Relations_1.v
-theories7/Sets/Finite_sets_facts.vo: theories7/Sets/Finite_sets_facts.v theories7/Sets/Finite_sets.vo theories7/Sets/Constructive_sets.vo theories7/Logic/Classical_Type.vo theories7/Sets/Classical_sets.vo theories7/Sets/Powerset.vo theories7/Sets/Powerset_facts.vo theories7/Sets/Powerset_Classical_facts.vo theories7/Arith/Gt.vo theories7/Arith/Lt.vo
-theories7/Sets/Relations_1_facts.vo: theories7/Sets/Relations_1_facts.v theories7/Sets/Relations_1.vo
-theories7/Sets/Image.vo: theories7/Sets/Image.v theories7/Sets/Finite_sets.vo theories7/Sets/Constructive_sets.vo theories7/Logic/Classical_Type.vo theories7/Sets/Classical_sets.vo theories7/Sets/Powerset.vo theories7/Sets/Powerset_facts.vo theories7/Sets/Powerset_Classical_facts.vo theories7/Arith/Gt.vo theories7/Arith/Lt.vo theories7/Arith/Le.vo theories7/Sets/Finite_sets_facts.vo
-theories7/Sets/Relations_2.vo: theories7/Sets/Relations_2.v theories7/Sets/Relations_1.vo
-theories7/Sets/Infinite_sets.vo: theories7/Sets/Infinite_sets.v theories7/Sets/Finite_sets.vo theories7/Sets/Constructive_sets.vo theories7/Logic/Classical_Type.vo theories7/Sets/Classical_sets.vo theories7/Sets/Powerset.vo theories7/Sets/Powerset_facts.vo theories7/Sets/Powerset_Classical_facts.vo theories7/Arith/Gt.vo theories7/Arith/Lt.vo theories7/Arith/Le.vo theories7/Sets/Finite_sets_facts.vo theories7/Sets/Image.vo
-theories7/Sets/Relations_2_facts.vo: theories7/Sets/Relations_2_facts.v theories7/Sets/Relations_1.vo theories7/Sets/Relations_1_facts.vo theories7/Sets/Relations_2.vo
-theories7/Sets/Integers.vo: theories7/Sets/Integers.v theories7/Sets/Finite_sets.vo theories7/Sets/Constructive_sets.vo theories7/Logic/Classical_Type.vo theories7/Sets/Classical_sets.vo theories7/Sets/Powerset.vo theories7/Sets/Powerset_facts.vo theories7/Sets/Powerset_Classical_facts.vo theories7/Arith/Gt.vo theories7/Arith/Lt.vo theories7/Arith/Le.vo theories7/Sets/Finite_sets_facts.vo theories7/Sets/Image.vo theories7/Sets/Infinite_sets.vo theories7/Arith/Compare_dec.vo theories7/Sets/Relations_1.vo theories7/Sets/Partial_Order.vo theories7/Sets/Cpo.vo
-theories7/Sets/Relations_3.vo: theories7/Sets/Relations_3.v theories7/Sets/Relations_1.vo theories7/Sets/Relations_2.vo
-theories7/Sets/Multiset.vo: theories7/Sets/Multiset.v theories7/Sets/Permut.vo theories7/Arith/Plus.vo
-theories7/Sets/Relations_3_facts.vo: theories7/Sets/Relations_3_facts.v theories7/Sets/Relations_1.vo theories7/Sets/Relations_1_facts.vo theories7/Sets/Relations_2.vo theories7/Sets/Relations_2_facts.vo theories7/Sets/Relations_3.vo
-theories7/Sets/Partial_Order.vo: theories7/Sets/Partial_Order.v theories7/Sets/Ensembles.vo theories7/Sets/Relations_1.vo
-theories7/Sets/Uniset.vo: theories7/Sets/Uniset.v theories7/Bool/Bool.vo theories7/Sets/Permut.vo
-theories7/IntMap/Adalloc.vo: theories7/IntMap/Adalloc.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/ZArith/ZArith.vo theories7/Arith/Arith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Fset.vo
-theories7/IntMap/Mapcanon.vo: theories7/IntMap/Mapcanon.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/Arith/Arith.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Mapaxioms.vo theories7/IntMap/Mapiter.vo theories7/IntMap/Fset.vo theories7/Lists/PolyList.vo theories7/IntMap/Lsort.vo theories7/IntMap/Mapsubset.vo theories7/IntMap/Mapcard.vo
-theories7/IntMap/Addec.vo: theories7/IntMap/Addec.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo
-theories7/IntMap/Mapcard.vo: theories7/IntMap/Mapcard.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/Arith/Arith.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Mapaxioms.vo theories7/IntMap/Mapiter.vo theories7/IntMap/Fset.vo theories7/IntMap/Mapsubset.vo theories7/Lists/PolyList.vo theories7/IntMap/Lsort.vo theories7/Arith/Peano_dec.vo
-theories7/IntMap/Addr.vo: theories7/IntMap/Addr.v theories7/Bool/Bool.vo theories7/ZArith/ZArith.vo
-theories7/IntMap/Mapc.vo: theories7/IntMap/Mapc.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/Arith/Arith.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Mapaxioms.vo theories7/IntMap/Fset.vo theories7/IntMap/Mapiter.vo theories7/IntMap/Mapsubset.vo theories7/Lists/PolyList.vo theories7/IntMap/Lsort.vo theories7/IntMap/Mapcard.vo theories7/IntMap/Mapcanon.vo
-theories7/IntMap/Adist.vo: theories7/IntMap/Adist.v theories7/Bool/Bool.vo theories7/ZArith/ZArith.vo theories7/Arith/Arith.vo theories7/Arith/Min.vo theories7/IntMap/Addr.vo
-theories7/IntMap/Mapfold.vo: theories7/IntMap/Mapfold.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Fset.vo theories7/IntMap/Mapaxioms.vo theories7/IntMap/Mapiter.vo theories7/IntMap/Lsort.vo theories7/IntMap/Mapsubset.vo theories7/Lists/PolyList.vo
-theories7/IntMap/Allmaps.vo: theories7/IntMap/Allmaps.v theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Fset.vo theories7/IntMap/Mapaxioms.vo theories7/IntMap/Mapiter.vo theories7/IntMap/Mapsubset.vo theories7/IntMap/Lsort.vo theories7/IntMap/Mapfold.vo theories7/IntMap/Mapcard.vo theories7/IntMap/Mapcanon.vo theories7/IntMap/Mapc.vo theories7/IntMap/Maplists.vo theories7/IntMap/Adalloc.vo
-theories7/IntMap/Mapiter.vo: theories7/IntMap/Mapiter.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Mapaxioms.vo theories7/IntMap/Fset.vo theories7/Lists/PolyList.vo
-theories7/IntMap/Fset.vo: theories7/IntMap/Fset.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo
-theories7/IntMap/Maplists.vo: theories7/IntMap/Maplists.v theories7/IntMap/Addr.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Fset.vo theories7/IntMap/Mapaxioms.vo theories7/IntMap/Mapsubset.vo theories7/IntMap/Mapcard.vo theories7/IntMap/Mapcanon.vo theories7/IntMap/Mapc.vo theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/Lists/PolyList.vo theories7/Arith/Arith.vo theories7/IntMap/Mapiter.vo theories7/IntMap/Mapfold.vo
-theories7/IntMap/Lsort.vo: theories7/IntMap/Lsort.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/Arith/Arith.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/Lists/PolyList.vo theories7/IntMap/Mapiter.vo
-theories7/IntMap/Mapsubset.vo: theories7/IntMap/Mapsubset.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/Arith/Arith.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Fset.vo theories7/IntMap/Mapaxioms.vo theories7/IntMap/Mapiter.vo
-theories7/IntMap/Mapaxioms.vo: theories7/IntMap/Mapaxioms.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo theories7/IntMap/Map.vo theories7/IntMap/Fset.vo
-theories7/IntMap/Map.vo: theories7/IntMap/Map.v theories7/Bool/Bool.vo theories7/Bool/Sumbool.vo theories7/ZArith/ZArith.vo theories7/IntMap/Addr.vo theories7/IntMap/Adist.vo theories7/IntMap/Addec.vo
-theories7/Relations/Newman.vo: theories7/Relations/Newman.v theories7/Relations/Rstar.vo
-theories7/Relations/Operators_Properties.vo: theories7/Relations/Operators_Properties.v theories7/Relations/Relation_Definitions.vo theories7/Relations/Relation_Operators.vo
-theories7/Relations/Relation_Definitions.vo: theories7/Relations/Relation_Definitions.v
-theories7/Relations/Relation_Operators.vo: theories7/Relations/Relation_Operators.v theories7/Relations/Relation_Definitions.vo theories7/Lists/PolyList.vo theories7/Lists/PolyListSyntax.vo
-theories7/Relations/Relations.vo: theories7/Relations/Relations.v theories7/Relations/Relation_Definitions.vo theories7/Relations/Relation_Operators.vo theories7/Relations/Operators_Properties.vo
-theories7/Relations/Rstar.vo: theories7/Relations/Rstar.v
-theories7/Wellfounded/Disjoint_Union.vo: theories7/Wellfounded/Disjoint_Union.v theories7/Relations/Relation_Operators.vo
-theories7/Wellfounded/Inclusion.vo: theories7/Wellfounded/Inclusion.v theories7/Relations/Relation_Definitions.vo
-theories7/Wellfounded/Inverse_Image.vo: theories7/Wellfounded/Inverse_Image.v
-theories7/Wellfounded/Lexicographic_Exponentiation.vo: theories7/Wellfounded/Lexicographic_Exponentiation.v theories7/Logic/Eqdep.vo theories7/Lists/PolyList.vo theories7/Lists/PolyListSyntax.vo theories7/Relations/Relation_Operators.vo theories7/Wellfounded/Transitive_Closure.vo
-theories7/Wellfounded/Transitive_Closure.vo: theories7/Wellfounded/Transitive_Closure.v theories7/Relations/Relation_Definitions.vo theories7/Relations/Relation_Operators.vo
-theories7/Wellfounded/Union.vo: theories7/Wellfounded/Union.v theories7/Relations/Relation_Operators.vo theories7/Relations/Relation_Definitions.vo theories7/Wellfounded/Transitive_Closure.vo
-theories7/Wellfounded/Wellfounded.vo: theories7/Wellfounded/Wellfounded.v theories7/Wellfounded/Disjoint_Union.vo theories7/Wellfounded/Inclusion.vo theories7/Wellfounded/Inverse_Image.vo theories7/Wellfounded/Lexicographic_Exponentiation.vo theories7/Wellfounded/Lexicographic_Product.vo theories7/Wellfounded/Transitive_Closure.vo theories7/Wellfounded/Union.vo theories7/Wellfounded/Well_Ordering.vo
-theories7/Wellfounded/Well_Ordering.vo: theories7/Wellfounded/Well_Ordering.v theories7/Logic/Eqdep.vo
-theories7/Wellfounded/Lexicographic_Product.vo: theories7/Wellfounded/Lexicographic_Product.v theories7/Logic/Eqdep.vo theories7/Relations/Relation_Operators.vo theories7/Wellfounded/Transitive_Closure.vo
-theories7/Reals/Rdefinitions.vo: theories7/Reals/Rdefinitions.v theories7/ZArith/ZArith_base.vo
-theories7/Reals/Raxioms.vo: theories7/Reals/Raxioms.v theories7/ZArith/ZArith_base.vo theories7/Reals/Rsyntax.vo
-theories7/Reals/RIneq.vo: theories7/Reals/RIneq.v theories7/Reals/Raxioms.vo contrib7/ring/ZArithRing.vo contrib7/omega/Omega.vo contrib7/field/Field.vo
-theories7/Reals/DiscrR.vo: theories7/Reals/DiscrR.v theories7/Reals/RIneq.vo contrib7/omega/Omega.vo
-theories7/Reals/Rbase.vo: theories7/Reals/Rbase.v theories7/Reals/Rdefinitions.vo theories7/Reals/Raxioms.vo theories7/Reals/RIneq.vo theories7/Reals/DiscrR.vo
-theories7/Reals/R_Ifp.vo: theories7/Reals/R_Ifp.v theories7/Reals/Rbase.vo contrib7/omega/Omega.vo
-theories7/Reals/Rbasic_fun.vo: theories7/Reals/Rbasic_fun.v theories7/Reals/Rbase.vo theories7/Reals/R_Ifp.vo contrib7/fourier/Fourier.vo
-theories7/Reals/R_sqr.vo: theories7/Reals/R_sqr.v theories7/Reals/Rbase.vo theories7/Reals/Rbasic_fun.vo
-theories7/Reals/SplitAbsolu.vo: theories7/Reals/SplitAbsolu.v theories7/Reals/Rbasic_fun.vo
-theories7/Reals/SplitRmult.vo: theories7/Reals/SplitRmult.v theories7/Reals/Rbase.vo
-theories7/Reals/ArithProp.vo: theories7/Reals/ArithProp.v theories7/Reals/Rbase.vo theories7/Reals/Rbasic_fun.vo theories7/Arith/Even.vo theories7/Arith/Div2.vo
-theories7/Reals/Rfunctions.vo: theories7/Reals/Rfunctions.v theories7/Reals/Rbase.vo theories7/Reals/R_Ifp.vo theories7/Reals/Rbasic_fun.vo theories7/Reals/R_sqr.vo theories7/Reals/SplitAbsolu.vo theories7/Reals/SplitRmult.vo theories7/Reals/ArithProp.vo contrib7/omega/Omega.vo theories7/ZArith/Zpower.vo
-theories7/Reals/Rseries.vo: theories7/Reals/Rseries.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Logic/Classical.vo theories7/Arith/Compare.vo
-theories7/Reals/SeqProp.vo: theories7/Reals/SeqProp.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rseries.vo theories7/Logic/Classical.vo theories7/Arith/Max.vo
-theories7/Reals/Rcomplete.vo: theories7/Reals/Rcomplete.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rseries.vo theories7/Reals/SeqProp.vo theories7/Arith/Max.vo
-theories7/Reals/PartSum.vo: theories7/Reals/PartSum.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rseries.vo theories7/Reals/Rcomplete.vo theories7/Arith/Max.vo
-theories7/Reals/AltSeries.vo: theories7/Reals/AltSeries.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rseries.vo theories7/Reals/SeqProp.vo theories7/Reals/PartSum.vo theories7/Arith/Max.vo
-theories7/Reals/Binomial.vo: theories7/Reals/Binomial.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/PartSum.vo
-theories7/Reals/Rsigma.vo: theories7/Reals/Rsigma.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rseries.vo theories7/Reals/PartSum.vo
-theories7/Reals/Rprod.vo: theories7/Reals/Rprod.v theories7/Arith/Compare.vo theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rseries.vo theories7/Reals/PartSum.vo theories7/Reals/Binomial.vo
-theories7/Reals/Cauchy_prod.vo: theories7/Reals/Cauchy_prod.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rseries.vo theories7/Reals/PartSum.vo
-theories7/Reals/Alembert.vo: theories7/Reals/Alembert.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rseries.vo theories7/Reals/SeqProp.vo theories7/Reals/PartSum.vo theories7/Arith/Max.vo
-theories7/Reals/SeqSeries.vo: theories7/Reals/SeqSeries.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Arith/Max.vo theories7/Reals/Rseries.vo theories7/Reals/SeqProp.vo theories7/Reals/Rcomplete.vo theories7/Reals/PartSum.vo theories7/Reals/AltSeries.vo theories7/Reals/Binomial.vo theories7/Reals/Rsigma.vo theories7/Reals/Rprod.vo theories7/Reals/Cauchy_prod.vo theories7/Reals/Alembert.vo
-theories7/Reals/Rtrigo_fun.vo: theories7/Reals/Rtrigo_fun.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo
-theories7/Reals/Rtrigo_def.vo: theories7/Reals/Rtrigo_def.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo_fun.vo theories7/Arith/Max.vo
-theories7/Reals/Rtrigo_alt.vo: theories7/Reals/Rtrigo_alt.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo_def.vo
-theories7/Reals/Cos_rel.vo: theories7/Reals/Cos_rel.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo_def.vo
-theories7/Reals/Cos_plus.vo: theories7/Reals/Cos_plus.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo_def.vo theories7/Reals/Cos_rel.vo theories7/Arith/Max.vo
-theories7/Reals/Rtrigo.vo: theories7/Reals/Rtrigo.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo_fun.vo theories7/Reals/Rtrigo_def.vo theories7/Reals/Rtrigo_alt.vo theories7/Reals/Cos_rel.vo theories7/Reals/Cos_plus.vo theories7/ZArith/ZArith_base.vo theories7/ZArith/Zcomplements.vo theories7/Logic/Classical_Prop.vo
-theories7/Reals/Rlimit.vo: theories7/Reals/Rlimit.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Logic/Classical_Prop.vo contrib7/fourier/Fourier.vo
-theories7/Reals/Rderiv.vo: theories7/Reals/Rderiv.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rlimit.vo contrib7/fourier/Fourier.vo theories7/Logic/Classical_Prop.vo theories7/Logic/Classical_Pred_Type.vo contrib7/omega/Omega.vo
-theories7/Reals/RList.vo: theories7/Reals/RList.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo
-theories7/Reals/Ranalysis1.vo: theories7/Reals/Ranalysis1.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rlimit.vo theories7/Reals/Rderiv.vo
-theories7/Reals/Ranalysis2.vo: theories7/Reals/Ranalysis2.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Ranalysis1.vo
-theories7/Reals/Ranalysis3.vo: theories7/Reals/Ranalysis3.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Ranalysis1.vo theories7/Reals/Ranalysis2.vo
-theories7/Reals/Rtopology.vo: theories7/Reals/Rtopology.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Ranalysis1.vo theories7/Reals/RList.vo theories7/Logic/Classical_Prop.vo theories7/Logic/Classical_Pred_Type.vo
-theories7/Reals/MVT.vo: theories7/Reals/MVT.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Ranalysis1.vo theories7/Reals/Rtopology.vo
-theories7/Reals/PSeries_reg.vo: theories7/Reals/PSeries_reg.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Ranalysis1.vo theories7/Arith/Max.vo theories7/Arith/Even.vo
-theories7/Reals/Exp_prop.vo: theories7/Reals/Exp_prop.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo.vo theories7/Reals/Ranalysis1.vo theories7/Reals/PSeries_reg.vo theories7/Arith/Div2.vo theories7/Arith/Even.vo theories7/Arith/Max.vo
-theories7/Reals/Rtrigo_reg.vo: theories7/Reals/Rtrigo_reg.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo.vo theories7/Reals/Ranalysis1.vo theories7/Reals/PSeries_reg.vo
-theories7/Reals/Rsqrt_def.vo: theories7/Reals/Rsqrt_def.v theories7/Bool/Sumbool.vo theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Ranalysis1.vo
-theories7/Reals/R_sqrt.vo: theories7/Reals/R_sqrt.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rsqrt_def.vo
-theories7/Reals/Rtrigo_calc.vo: theories7/Reals/Rtrigo_calc.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo.vo theories7/Reals/R_sqrt.vo
-theories7/Reals/Rgeom.vo: theories7/Reals/Rgeom.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo.vo theories7/Reals/R_sqrt.vo
-theories7/Reals/Sqrt_reg.vo: theories7/Reals/Sqrt_reg.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Ranalysis1.vo theories7/Reals/R_sqrt.vo
-theories7/Reals/Ranalysis4.vo: theories7/Reals/Ranalysis4.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo.vo theories7/Reals/Ranalysis1.vo theories7/Reals/Ranalysis3.vo theories7/Reals/Exp_prop.vo
-theories7/Reals/Rpower.vo: theories7/Reals/Rpower.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo.vo theories7/Reals/Ranalysis1.vo theories7/Reals/Exp_prop.vo theories7/Reals/Rsqrt_def.vo theories7/Reals/R_sqrt.vo theories7/Reals/MVT.vo theories7/Reals/Ranalysis4.vo
-theories7/Reals/Ranalysis.vo: theories7/Reals/Ranalysis.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Rtrigo.vo theories7/Reals/SeqSeries.vo theories7/Reals/Ranalysis1.vo theories7/Reals/Ranalysis2.vo theories7/Reals/Ranalysis3.vo theories7/Reals/Rtopology.vo theories7/Reals/MVT.vo theories7/Reals/PSeries_reg.vo theories7/Reals/Exp_prop.vo theories7/Reals/Rtrigo_reg.vo theories7/Reals/Rsqrt_def.vo theories7/Reals/R_sqrt.vo theories7/Reals/Rtrigo_calc.vo theories7/Reals/Rgeom.vo theories7/Reals/RList.vo theories7/Reals/Sqrt_reg.vo theories7/Reals/Ranalysis4.vo theories7/Reals/Rpower.vo
-theories7/Reals/NewtonInt.vo: theories7/Reals/NewtonInt.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo.vo theories7/Reals/Ranalysis.vo
-theories7/Reals/RiemannInt_SF.vo: theories7/Reals/RiemannInt_SF.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/Ranalysis.vo theories7/Logic/Classical_Prop.vo
-theories7/Reals/RiemannInt.vo: theories7/Reals/RiemannInt.v theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Ranalysis.vo theories7/Reals/Rbase.vo theories7/Reals/RiemannInt_SF.vo theories7/Logic/Classical_Prop.vo theories7/Logic/Classical_Pred_Type.vo theories7/Arith/Max.vo
-theories7/Reals/Integration.vo: theories7/Reals/Integration.v theories7/Reals/NewtonInt.vo theories7/Reals/RiemannInt_SF.vo theories7/Reals/RiemannInt.vo
-theories7/Reals/Reals.vo: theories7/Reals/Reals.v theories7/Reals/Rbase.vo theories7/Reals/Rfunctions.vo theories7/Reals/SeqSeries.vo theories7/Reals/Rtrigo.vo theories7/Reals/Ranalysis.vo theories7/Reals/Integration.vo
-theories7/Setoids/Setoid.vo: theories7/Setoids/Setoid.v
-theories7/Sorting/Heap.vo: theories7/Sorting/Heap.v theories7/Lists/PolyList.vo theories7/Sets/Multiset.vo theories7/Sorting/Permutation.vo theories7/Relations/Relations.vo theories7/Sorting/Sorting.vo
-theories7/Sorting/Permutation.vo: theories7/Sorting/Permutation.v theories7/Relations/Relations.vo theories7/Lists/PolyList.vo theories7/Sets/Multiset.vo
-theories7/Sorting/Sorting.vo: theories7/Sorting/Sorting.v theories7/Lists/PolyList.vo theories7/Sets/Multiset.vo theories7/Sorting/Permutation.vo theories7/Relations/Relations.vo
-theories7/Lists/PolyList.vo: theories7/Lists/PolyList.v theories7/Arith/Le.vo
-theories7/Lists/PolyListSyntax.vo: theories7/Lists/PolyListSyntax.v
-theories7/ZArith/Zsyntax.vo: theories7/ZArith/Zsyntax.v theories7/ZArith/BinInt.vo
-theories7/ZArith/zarith_aux.vo: theories7/ZArith/zarith_aux.v theories7/ZArith/BinInt.vo theories7/ZArith/Zcompare.vo theories7/ZArith/Zorder.vo theories7/ZArith/Zmin.vo theories7/ZArith/Zabs.vo
-theories7/ZArith/fast_integer.vo: theories7/ZArith/fast_integer.v theories7/NArith/BinPos.vo theories7/NArith/BinNat.vo theories7/ZArith/BinInt.vo theories7/ZArith/Zcompare.vo theories7/Arith/Mult.vo
-theories7/Reals/Rsyntax.vo: theories7/Reals/Rsyntax.v theories7/Reals/Rdefinitions.vo
-contrib7/omega/OmegaLemmas.vo: contrib7/omega/OmegaLemmas.v theories7/ZArith/ZArith_base.vo
-contrib7/omega/Omega.vo: contrib7/omega/Omega.v theories7/ZArith/ZArith_base.vo contrib7/omega/OmegaLemmas.vo theories7/ZArith/Zhints.vo
-contrib7/romega/ReflOmegaCore.vo: contrib7/romega/ReflOmegaCore.v theories7/Arith/Arith.vo theories7/Lists/PolyList.vo theories7/Bool/Bool.vo theories7/ZArith/ZArith.vo contrib7/omega/OmegaLemmas.vo theories7/Logic/Decidable.vo
-contrib7/romega/ROmega.vo: contrib7/romega/ROmega.v contrib7/omega/Omega.vo contrib7/romega/ReflOmegaCore.vo
-contrib7/ring/ArithRing.vo: contrib7/ring/ArithRing.v contrib7/ring/Ring.vo theories7/Arith/Arith.vo theories7/Logic/Eqdep_dec.vo
-contrib7/ring/Ring_normalize.vo: contrib7/ring/Ring_normalize.v contrib7/ring/Ring_theory.vo contrib7/ring/Quote.vo
-contrib7/ring/Ring_theory.vo: contrib7/ring/Ring_theory.v theories7/Bool/Bool.vo
-contrib7/ring/Ring.vo: contrib7/ring/Ring.v theories7/Bool/Bool.vo contrib7/ring/Ring_theory.vo contrib7/ring/Quote.vo contrib7/ring/Ring_normalize.vo contrib7/ring/Ring_abstract.vo
-contrib7/ring/NArithRing.vo: contrib7/ring/NArithRing.v contrib7/ring/Ring.vo theories7/ZArith/ZArith_base.vo theories7/NArith/NArith.vo theories7/Logic/Eqdep_dec.vo
-contrib7/ring/ZArithRing.vo: contrib7/ring/ZArithRing.v contrib7/ring/ArithRing.vo theories7/ZArith/ZArith_base.vo theories7/Logic/Eqdep_dec.vo
-contrib7/ring/Ring_abstract.vo: contrib7/ring/Ring_abstract.v contrib7/ring/Ring_theory.vo contrib7/ring/Quote.vo contrib7/ring/Ring_normalize.vo
-contrib7/ring/Quote.vo: contrib7/ring/Quote.v
-contrib7/ring/Setoid_ring_normalize.vo: contrib7/ring/Setoid_ring_normalize.v contrib7/ring/Setoid_ring_theory.vo contrib7/ring/Quote.vo
-contrib7/ring/Setoid_ring.vo: contrib7/ring/Setoid_ring.v contrib7/ring/Setoid_ring_theory.vo contrib7/ring/Quote.vo contrib7/ring/Setoid_ring_normalize.vo
-contrib7/ring/Setoid_ring_theory.vo: contrib7/ring/Setoid_ring_theory.v theories7/Bool/Bool.vo theories7/Setoids/Setoid.vo
-contrib7/field/Field_Compl.vo: contrib7/field/Field_Compl.v
-contrib7/field/Field_Theory.vo: contrib7/field/Field_Theory.v theories7/Arith/Peano_dec.vo contrib7/ring/Ring.vo contrib7/field/Field_Compl.vo
-contrib7/field/Field_Tactic.vo: contrib7/field/Field_Tactic.v contrib7/ring/Ring.vo contrib7/field/Field_Compl.vo contrib7/field/Field_Theory.vo
-contrib7/field/Field.vo: contrib7/field/Field.v contrib7/field/Field_Compl.vo contrib7/field/Field_Theory.vo contrib7/field/Field_Tactic.vo
-contrib7/fourier/Fourier_util.vo: contrib7/fourier/Fourier_util.v theories7/Reals/Rbase.vo
-contrib7/fourier/Fourier.vo: contrib7/fourier/Fourier.v contrib7/fourier/Fourier_util.vo contrib7/field/Field.vo theories7/Reals/DiscrR.vo
-contrib7/cc/CCSolve.vo: contrib7/cc/CCSolve.v
diff --git a/CHANGES b/CHANGES
index 7c7f5dc7..e0d08774 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,78 +1,256 @@
-Changes from V8.0pl2 to V8.0pl3
-===============================
+Changes from V8.1gamma to V8.1
+==============================
+
+Bug fixes
+
+- Many bugs have been fixed (cf coq-bugs web page)
 
 Tactics
 
-- The search depth argument of auto can be parameterised in the
-  Ltac language
-- Added entry constr_may_eval for tactic extensions (new syntax)
+- New tactic ring, ring_simplify and new tactic field now able to manage
+  power to a positive integer constant. Tactic ring on Z and R, and
+  field on R manage power (may lead to incompatibilities with V8.1gamma).
+- Tactic field_simplify now applicable in hypotheses.
+- New field_simplify_eq for simplifying field equations into ring equations.
+- Tactics ring, ring_simplify, field, field_simplify and field_simplify_eq 
+  all able to apply user-given equations to rewrite monoms on the fly 
+  (see documentation).
 
-Compilation
+Libraries
 
-- Coq sources made compatible with ocaml 3.09.0 and lablgtk 2.6.0.
+- New file ConstructiveEpsilon.v defining an epsilon operator and
+  proving the axiom of choice constructively for a countable domain
+  and a decidable predicate.
 
-Standard library
+Changes from V8.1beta to V8.1gamma
+==================================
 
-- A couple of lemmas of ZArith were renamed. This concerns names
-  containing O (the letter), which is replaced by 0 (the number).
+Syntax
 
-Bug fixes
+- changed parsing precedence of let/in and fun constructions of Ltac:
+  let x := t in e1; e2 is now parsed as let x := t in (e1;e2).
 
-- Fixes a serious bug in CoqIde. The windows port should be able
-  to load large libraries (such as Reals) without producing the
-  "bad file descriptor" error.
-- Scope of Ltac variables: global Ltac macros no longer hide goal
-  hypotheses
-- Many fixes concerning extraction: 
-  * fewer useless eta-expansions
-  * for Ocaml: extraction of records should be ok now. Problem with 
-    type t = M.t in modules fixed.
-  * in Haskell: improved use of unsafeCoerce, fixed Extract Constant, 
-    function types are now printed.
-  * important revision of the Scheme extraction: 
-    see http://www.pps.jussieu.fr/~letouzey/scheme
-- Fixes a bug in the interpretation of record projections ("bad number
-  of parameters" error)
-- Fixed a bug in the omega tactic
-- Fixed a bug in the fold tactic regarding hypotheses ordering
-- Pretty-print of universes fixed
-- Added an empty level 99 in patterns syntax entry
-- "Notation" bug fixes ("only parsing" bug, printing of numerals
-  arguments of coercions, default spacing for recursive notations
-  with no terminal separator, "Tactic Notation" printer).
-
-Changes from V8.0pl1 to V8.0pl2
-===============================
+Language and commands
 
-Notations
+- Added sort-polymorphism for definitions in Type.
+- Support for implicit arguments in the types of parameters in
+  (co-)fixpoints and (co-)inductive declarations.
+- Improved type inference: use as much of possible general information.
+  before applying irreversible unification heuristics (allow e.g. to
+  infer the predicate in "(exist _ 0 (refl_equal 0) : {n:nat | n=0 })").
+- Support for Miller-Pfenning's patterns unification in type synthesis
+  (e.g. can infer P such that P x y = phi(x,y)).
+- Support for "where" clause in cofixpoint definitions.
+- New option "Set Printing Universes" for making Type levels explicit.
+
+Tactics
 
-- Option "format" now aware of recursive notations
+- Improved implementation of the ring and field tactics. For compatibility
+  reasons, the previous tactics are renamed as legacy ring and legacy field,
+  but should be considered as deprecated.
+- New declarative mathematical proof language.
+- Support for argument lists of arbitrary length in Tactic Notation.
+- [rewrite ... in H] now fails if [H] is used either in an hypothesis
+  or in the goal.
+- The semantics of [rewrite ... in *] has been slightly modified (see doc). 
+- Support for "as" clause in tactic injection.
+- New forward-reasoning tactic "apply in".
+- Ltac fresh operator now builds names from a concatenation of its arguments.
+- New ltac tactic "remember" to abstract over a subterm and keep an equality
+- Support for Miller-Pfenning's patterns unification in apply/rewrite/...
+  (may lead to few incompatibilities - generally now useless tactic calls).
 
 Bug fixes
 
-- Tactic "fail n" for n<>0 now works (notice that each "match term with"
-  block decreases the failure level, in accordance with the intuition but
-  not in conformity with the reference manual)
-- Option -dump-glob now strips module segment as expected by coqdoc (which
-  is still not aware of modules)
-- See coq-bugs web page for a full list of fixed bugs (look for
-  fixes committed before Jan 2005 to cvs version V8-0-bugfix)
+- Fix for notations involving basic "match" expressions.
+- Numerous other bugs solved (a few fixes may lead to incompatibilities).
 
-Changes from V8.0 to V8.0pl1
-============================
 
-Unicode support
+Changes from V8.0 to V8.1beta
+=============================
 
-- Miscellaneous Mathematical Symbols-A and B, and Supplemental
-  Arrows-A now supported
+Logic
 
-Bug fixes
+- Added sort-polymorphism on inductive families
+- Allowance for recursively non uniform parameters in inductive types
+
+Syntax
+
+- No more support for version 7 syntax and for translation to version 8 syntax.
+- In fixpoints, the { struct ... } annotation is not mandatory any more when 
+  only one of the arguments has an inductive type
+- Added disjunctive patterns in match-with patterns
+- Support for primitive interpretation of string literals
+- Extended support for Unicode ranges
+
+Vernacular commands
+
+- Added "Print Ltac qualid" to print a user defined tactic.
+- Added "Print Rewrite HintDb" to print the content of a DB used by
+  autorewrite.
+- Added "Print Canonical Projections".
+- Added "Example" as synonym of "Definition".
+- Added "Proposition" and "Corollary" as extra synonyms of "Lemma".
+- New command "Whelp" to send requests to the Helm database of proofs
+  formalized in the Calculus of Inductive Constructions.
+- Command "functional induction" has been re-implemented from the new
+  "Function" command.
+
+Ltac and tactic syntactic extensions
+
+- New primitive "external" for communication with tool external to Coq.
+- New semantics for "match t with": if a clause returns a
+  tactic, it is now applied to the current goal. If it fails, the next
+  clause or next matching subterm is tried (i.e. it behaves as "match
+  goal with" does). The keyword "lazymatch" can be used to delay the 
+  evaluation of tactics occurring in matching clauses.
+- Hint base names can be parametric in auto and trivial.
+- Occurrence values can be parametric in unfold, pattern, etc.
+- Added entry constr_may_eval for tactic extensions.
+- Low-priority term printer made available in ML-written tactic extensions.
+- "Tactic Notation" extended to allow notations of tacticals.
+
+Tactics
+
+- New implementation and generalization of [setoid_]* (setoid_rewrite,
+  setoid_symmetry, setoid_transitivity, setoid_reflexivity and autorewite).
+  New syntax for declaring relations and morphisms (old syntax still working
+  with minor modifications, but deprecated).
+- New implementation (still experimental) of the ring tactic with a built-in
+  notion of coefficients and a better usage of setoids.
+- New conversion tactic "vm_compute": evaluates the goal (or an hypothesis)
+  with a call-by-value strategy, using the compiled version of terms. 
+- When rewriting H where H is not directly a Coq equality, search first H for 
+  a registered setoid equality before starting to reduce in H. This is unlikely
+  to break any script. Should this happen nonetheless, one can insert manually 
+  some "unfold ... in H" before rewriting.
+- Fixed various bugs about (setoid) rewrite ... in ... (in particular #1101)
+- "rewrite ... in" now accepts a clause as place where to rewrite instead of 
+  juste a simple hypothesis name. For instance: 
+   rewrite H in H1,H2 |- * means rewrite H in H1; rewrite H in H2; rewrite H
+   rewrite H in * |-  will do try rewrite H in Hi for all hypothesis Hi <> H.
+- Added "dependent rewrite term" and "dependent rewrite term in hyp" (doc TODO)
+- Added "autorewrite with ... in hyp [using ...]".
+- Tactic "replace" now accepts a "by" tactic clause.
+- Added "clear - id" to clear all hypotheses except the ones depending in id.
+- The argument of Declare Left Step and Declare Right Step is now a term
+  (it used to be a reference).
+- Omega now handles arbitrary precision integers.
+- Several bug fixes in Reflexive Omega (romega).
+- Idtac can now be left implicit in a [...|...] construct: for instance, 
+  [ foo | | bar ] stands for [ foo | idtac | bar ].
+- Fixed a "fold" bug (non critical but possible source of incompatibilities).
+- Added classical_left and classical_right which transforms |- A \/ B into 
+  ~B |- A and ~A |- B respectively.
+- Added command "Declare Implicit Tactic" to set up a default tactic to be
+  used to solve unresolved subterms of term arguments of tactics.
+- Better support for coercions to Sortclass in tactics expecting type 
+  arguments.
+- Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses.
+- New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns.
+- New introduction pattern "?" for letting Coq choose a name.
+- Added "eassumption".
+- Added option 'using lemmas' to auto, trivial and eauto.
+- Tactic "congruence" is now complete for its intended scope (ground
+  equalities and inequalities with constructors). Furthermore, it
+  tries to equates goal and hypotheses.
+- New tactic "rtauto" solves pure propositional logic and gives a
+  reflective version of the available proof.
+- Numbering of "pattern", "unfold", "simpl", ... occurrences in "match
+  with" made consistent with the printing of the return clause after
+  the term to match in the "match-with" construct (use "Set Printing All"
+  to see hidden occurrences).
+- Generalization of induction "induction x1...xn using scheme" where
+  scheme is an induction principle with complex predicates (like the
+  ones generated by function induction).
+- Some small Ltac tactics has been added to the standard library 
+  (file Tactics.v):
+  * f_equal : instead of using the different f_equalX lemmas
+  * case_eq : a "case" without loss of information. An equality 
+     stating the current situation is generated in every sub-cases.
+  * swap : for a negated goal ~B and a negated hypothesis H:~A, 
+     swap H asks you to prove A from hypothesis B 
+  * revert : revert H is generalize H; clear H.
+
+Extraction
+ 
+- All type parts should now disappear instead of sometimes producing _ 
+  (for instance in Map.empty).
+- Haskell extraction: types of functions are now printed, better 
+  unsafeCoerce mechanism, both for hugs and ghc.
+- Scheme extraction improved, see http://www.pps.jussieu.fr/~letouzey/scheme.
+- Many bug fixes.
+
+Modules
+
+- Added "Locate Module qualid" to get the full path of a module.
+- Module/Declare Module syntax made more uniform.
+- Added syntactic sugar "Declare Module Export/Import" and
+  "Module Export/Import".
+- Added syntactic sugar "Module M(Export/Import X Y: T)" and
+  "Module Type M(Export/Import X Y: T)"
+  (only for interactive definitions)
+- Construct "with" generalized to module paths:
+   T with (Definition|Module) M1.M2....Mn.l := l' (doc TODO).
+
+Notations
+
+- Option "format" aware of recursive notations.
+- Added insertion of spaces by default in recursive notations w/o separators.
+- No more automatic printing box in case of user-provided printing "format".
+- New notation "exists! x:A, P" for unique existence.
+- Notations for specific numerals now compatible with generic notations of
+  numerals (e.g. "1" can be used to denote the unit of a group without
+  hiding 1%nat)
+
+Libraries
+
+- New library on String and Ascii characters (contributed by L. Thery).
+- New library FSets+FMaps of finite sets and maps.
+- New library QArith on rational numbers.
+- Small extension of Zmin.V, new Zmax.v, new Zminmax.v.
+- Reworking and extension of the files on classical logic and
+  description principles (possible incompatibilities)
+- Few other improvements in ZArith potentially exceptionally breaking the
+  compatibility (useless hypothesys of Zgt_square_simpl and
+  Zlt_square_simpl removed; fixed names mentioning letter O instead of
+  digit 0; weaken premises in Z_lt_induction).
+- Restructuration of Eqdep_dec.v and Eqdep.v: more lemmas in Type.
+- Znumtheory now contains a gcd function that can compute within Coq.
+- More lemmas stated on Type in Wf.v, removal of redundant Fix_F.
+- Change of the internal names of lemmas in OmegaLemmas.
+- Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on
+  the allowance for recursively non uniform parameters (possible
+  source of incompatibilities: explicit pattern-matching on these
+  types may require to remove the occurrence associated to their
+  recursively non uniform parameter).
+- Coq.List.In_dec has been set transparent (this may exceptionally break
+  proof scripts, set it locally opaque for compatibility).
+- More on permutations of lists in List.v and Permutation.v.
+- List.v has been much expanded.
+- New file SetoidList.v now contains results about lists seen with 
+  respect to a setoid equality.
+- Library NArith has been expanded, mostly with results coming from 
+  Intmap (for instance a bitwise xor), plus also a bridge between N and 
+  Bitvector.
+- Intmap has been reorganized. In particular its address type "addr" is 
+  now N. User contributions known to use Intmap have been adapted 
+  accordingly. If you're using this library please contact us. 
+  A wrapper FMapIntMap now presents Intmap as a particular implementation 
+  of FMaps. New developments are strongly encouraged to use either this 
+  wrapper or any other implementations of FMap instead of using directly 
+  this obsolete Intmap.
+
+Tools
+
+- New semantics for coqtop options ("-batch" expects option "-top dir"
+  for loading vernac file that contains definitions).
+- Tool coq_makefile now removes custom targets that are file names in
+  "make clean"
+- New environment variable COQREMOTEBROWSER to set the command invoked
+  to start the remote browser both in Coq and coqide. Standard syntax:
+  "%s" is the placeholder for the URL.
 
-- GPL-incompatible QPL files for CoqIde are now GPL 
-- Pretty-printing of coercions to Funclass fixed and improved
-- Erroneous interpretation of the quantified hypothesis in intro until fixed
-- See coq-bugs web page for a full list of fixed bugs (look for
-  fixes in V8-0-bugfix before July 17)
 
 Changes from V8.0beta to V8.0
 =============================
@@ -253,13 +431,16 @@ Implicit arguments
 
 Grammar extensions
 
-- UTF-8 encoded unicode blocks 0380-03FF (greek letters) and 2100-214F
-  (letter-like, including aleph and double N,Z,Q,R) are supported
-  identifiers; UTF-8 unicode blocs 2200-22FF (mathematical operators),
-  2A00-2AFF (supplemental mathematical operators) 2300-23FF
-  (miscellaneous technical, including sqrt symbol), 2600-26FF
-  (miscellaneous symbols) 2190-21FF (arrows A) and 2900-297F (arrows B)
-  are supported symbols
+- Many newly supported UTF-8 encoded unicode blocks
+  - Greek letters (0380-03FF), Hebrew letters (U05D0-05EF), letter-like
+  symbols (2100-214F, that includes double N,Z,Q,R), prime
+  signs (from 2080-2089) and characters from many written languages
+  are valid in identifiers
+  - mathematical operators (2200-22FF), supplemental mathematical
+  operators (2A00-2AFF), miscellaneous technical (2300-23FF that
+  includes sqrt symbol), miscellaneous symbols (2600-26FF), arrows
+  (2190-21FF and 2900-297F), invisible mathematical operators (from
+  2080-2089), ... are valid symbols
 
 Library
 
diff --git a/COMPATIBILITY b/COMPATIBILITY
new file mode 100644
index 00000000..b5d94d58
--- /dev/null
+++ b/COMPATIBILITY
@@ -0,0 +1,58 @@
+Potential sources of incompatibilities between Coq V8.0 and V8.1
+----------------------------------------------------------------
+
+(see also file CHANGES)
+
+Language
+
+- Inductive types in Type are now polymorphic over their parameters in
+  Type. This may affect the naming of introduction hypotheses if such
+  an inductive type in Type is used on small types such as Prop or
+  Set: the hypothesis names suffix will default to H instead of X.  As
+  a matter of fact, it is recommended to systematically name the
+  hypotheses that are later refered to in the proof script.
+
+Tactics
+
+- Some bug fixes may lead to incompatibilities. This is e.g. the case
+  of inversion on Type which failed to rewrite some hypotheses as it
+  did on Prop/Set.
+
+- Add Morphism for the Prop/iff setoid now requires a proof of
+  biimplication instead of a proof of implication.
+
+- The order of arguments in compatibility morphisms changed: the
+  premises and the parameters are now interleaved while the whole
+  bunch of parameters used to come first.
+
+- The previous implementation of the ring and field tactics are
+  maintained but their name changed : require modules "LegacyRing" or
+  "LegacyField" and globally replace calls to "ring" and "field" by
+  calls to "legacy ring" and "legacy field".
+
+- Users ready to benefit of the power of the new implemetations have
+  to know that
+
+  - most of the time, ring solves goals similarly and often faster;
+  - if not, it may be because the old ring did some automatic unfold;
+    they now have to be done separately (by hand or using ltac);
+  - most of the time, field solvesp goals similarly but much faster but
+    there are usually less side conditions to prove;
+  - to simplify expressions, use now ring_simplify and field_simplify;
+  - simplifications are most of the time different: the new results are
+    more natural but they may require some adaptation of proof scripts;
+  - the Ring library no longer imports the Bool library (you may have
+    to explicitly request a "Require Import Bool");
+  - to declare new rings and fields, see the documentation.
+
+Libraries
+
+- A few changes in the library (as mentioned in the CHANGES file) may
+  imply the need for local adaptations.
+
+- Occurrence numbering order for unfold, pattern, etc changed for the
+  match construction: occurrences in the return clause now come after
+  the occurrences in the term matched; this was the opposite before.
+
+For changes in the ML interfaces, see file dev/doc/changes.txt in the
+main archive.
diff --git a/CREDITS b/CREDITS
index 12cd8e65..93e35164 100644
--- a/CREDITS
+++ b/CREDITS
@@ -1,115 +1,139 @@
-
-The "Coq proof assistant" was developed conjointly by 
-	INRIA Formel-Coq-LogiCal projects (since 1985), 
-	Laboratoire de l'Informatique du Parallelisme (LIP) 
-	associated to CNRS and ENS Lyon (Sep. 1989 to Aug. 1997),
-	Laboratoire de Recherche en Informatique (LRI)
-	associated to CNRS and Paris Sud (since Sep. 1997),
-	Laboratoire d'Informatique de l'Ecole Polytechnique (since Jan. 2003)
-	associated to CNRS and Ecole Polytechnique.
+The "Coq proof assistant" was jointly developed by 
+	
+- INRIA Formel, Coq, LogiCal, ProVal projects (since 1985), 
+- Laboratoire de l'Informatique du Parallelisme (LIP) 
+  associated to CNRS and ENS Lyon (Sep. 1989 to Aug. 1997),
+- Laboratoire de Recherche en Informatique (LRI)
+  associated to CNRS and Paris Sud (since Sep. 1997),
+- Laboratoire d'Informatique de l'Ecole Polytechnique (since Jan. 2003)
+  associated to CNRS and Ecole Polytechnique.
 
 All files of the "Coq proof assistant" in directories or sub-directories of
-	config dev doc interp kernel lib library parsing pretyping proofs
-	scripts syntax tactics test-suite theories tools toplevel translate
+
+  config dev ide interp kernel lib library parsing pretyping proofs
+  scripts states tactics test-suite theories tools toplevel
+
 are distributed under the terms of the GNU Lesser General Public License 
-Version 2.1 (see file LICENSE).
-These files are COPYRIGHT 1999-2004, The Coq development team, 
-CNRS, INRIA and Université Paris Sud
+Version 2.1 (see file LICENSE). These files are COPYRIGHT 1999-2006,
+The Coq development team, CNRS, INRIA and Université Paris Sud.
 
+Files from the directory doc are distributed as indicated in file doc/LICENCE.
 
 The following directories contain independent contributions supported 
-by the Coq development team :
+by the Coq development team. All of them are released under the terms of
+the GNU Lesser General Public License Version 2.1.
+
 contrib/cc
-	developed by Pierre Corbineau (ENS Cachan, 2001)
+  developed by Pierre Corbineau (ENS Cachan, 2001 and LRI, 2001-2005)
 contrib/correctness
-	developed by Jean-Christophe Filliâtre (LRI, 1999-2001)
+  developed by Jean-Christophe Filliâtre (LRI, 1999-2001)
+contrib/dp
+  developed by Nicolas Ayache and Jean-Christophe Filliâtre (LRI, 2005-2007)
 contrib/extraction
-	developed by Pierre Letouzey (LRI, 2000-2004)
+  developed by Pierre Letouzey (LRI, 2000-2007)
 contrib/field
-	developed by David Delahaye and Micaela Mayero (INRIA-LogiCal, 2001)
+  developed by David Delahaye and Micaela Mayero (INRIA-LogiCal, 2001)
 contrib/first-order 
-	developed by Pierre Corbineau (LRI, 2003-2004)
+  developed by Pierre Corbineau (LRI, 2003-2005)
 contrib/fourier
-	developed by Loïc Pottier (INRIA-Lemme, 2001)
+  developed by Loïc Pottier (INRIA-Lemme, 2001)
 contrib/funind
-	developed by Pierre Courtieu (INRIA-Lemme, 2003-2004)
+  developed by Pierre Courtieu (INRIA-Lemme, 2003-2004, CNAM, 2004-2007),
+  Julien Forest (INRIA-Everest, 2006-2007)
+  and Yves Bertot (INRIA-Marelle, 2005-2006).
 contrib/interface
-	developed by Yves Bertot with contributions from Loïc Pottier and
-	Laurence Rideau as part of the Pcoq project (INRIA-Lemme, 1997-2004)
-contrib/jprover
-	The author of JProver is Stephan Schmitt <schmitts@spmail.slu.edu>,
-	and is integrated into MetaPRL by Aleksey Nogin <nogin@cs.cornell.edu>
-	and then into Coq by Guan-Shieng Huang (LRI, 2001-2002)
-	original files from Stephan Schmitt are "GPL"
+  developed by Yves Bertot with contributions from Loïc Pottier and
+  Laurence Rideau as part of the Pcoq project (INRIA-Lemme, 1997-2006)
 contrib/omega
-	developed by Pierre Crégut (France Telecom R&D, 1996)
-contrib/romega
-	developed by Pierre Crégut (France Telecom R&D, 2001-2004)
+  developed by Pierre Crégut (France Telecom R&D, 1996)
+contrib/recdef
+  developed by Yves Bertot (INRIA-Marelle, 2005-2006)
 contrib/ring
-	developed by Samuel Boutin (INRIA-Coq, 1996) and Patrick 
-	Loiseleur (LRI, 1997-1999)
+  developed by Samuel Boutin (INRIA-Coq, 1996) and Patrick 
+  Loiseleur (LRI, 1997-1999)
+contrib/romega
+  developed by Pierre Crégut (France Telecom R&D, 2001-2004)
+contrib/rtauto
+  developed by Pierre Corbineau (LRI, 2005)
+contrib/setoid_ring
+  developed by Benjamin Grégoire (INRIA-Everest, 2005-2007),
+  Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2007)
+  and Bruno Barras (INRIA LogiCal, 2005-2007),
+contrib/subtac
+  developed by Matthieu Sozeau (LRI, 2005-2007)
 contrib/xml
-	developed by Claudio Sacerdoti (Univ. Bologna, 2000-2004) 
-	as part of the HELM and MoWGLI project
+  developed by Claudio Sacerdoti (Univ. Bologna, 2000-2005) 
+  as part of the HELM and MoWGLI projects
 
 parsing/search.ml
-	developed by Yves Bertot (INRIA-Lemme, 2000-2004)
+  mainly developed by Yves Bertot (INRIA-Lemme, 2000-2004)
 theories/ZArith
-	started by Pierre Crégut (France Telecom R&D, 1996)
-ide/
-	developed by Benjamin Monate (LRI, 2003) with contributions 
-	from Claude Marché (INRIA, 2003-2004); some files from ide/utils 
-	come from Maxence Guesdon's Cameleon project and are "GPL"
+  started by Pierre Crégut (France Telecom R&D, 1996)
+theories/IntMap
+  developed by Jean Goubault-Larrecq (Dyade, 1998)
+theories/Strings
+  developed by Laurent Théry (INRIA-Lemme, 2003)
+ide/utils
+  some files come from Maxence Guesdon's Cameleon tool 
 
-Many discussions within the Démons team and the LogiCal project
+Many discussions within the Démons team at LRI and the LogiCal project
 influenced significantly the design of Coq especially with
-J. Courant, P. Courtieu, J. Duprat, J. Goubault,
-A. Miquel, C. Marché, B. Monate, B. Werner
+
+  J. Courant, P. Courtieu, J. Duprat, J. Goubault,
+  A. Miquel, C. Marché, B. Monate, B. Werner.
 
 Intensive users suggested improvements of the system : 
-Y. Bertot, L. Pottier, L. Théry (INRIA-Lemme project) 
-C. Alvarado, P. Crégut, J.-F. Monin (France Telecom R&D)
-P. Castéran (Université Bordeaux 1)
+
+  Y. Bertot, L. Pottier, L. Théry (INRIA-Lemme projects),
+  C. Alvarado, P. Crégut, J.-F. Monin (France Telecom R&D),
+  P. Castéran (University Bordeaux 1),
+  The Foundations Group (Radboud University, Nijmegen, The Netherlands),
+  Laboratoire J.-A. Dieudonné (University of Nice-Sophia Antipolis).
 
 The following people have contributed to the development of different versions 
 of the Coq Proof assistant during the indicated time :
 
-	Bruno Barras (INRIA, 1995-now)
-	Jacek Chrzaszcz (Paris Sud, 1998-2003)
-	Thierry Coquand (INRIA, 1985-1989)
-	Cristina Cornes (INRIA, 1993-1996)
-	Yann Coscoy (INRIA Sophia-Antipolis, 1995-1996)
-	David Delahaye (INRIA, 1997-2002)
-	Daniel de Rauglaudre (INRIA, 1996-1998)
-	Olivier Desmettre (INRIA, 2001-2003)
-	Gilles Dowek (INRIA, 1991-1994)
-	Amy Felty (INRIA, 1993)
-	Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, Paris Sud, 1997-now)
-	Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998)
-	Hugo Herbelin (INRIA, 1996-now)
-	Gérard Huet (INRIA, 1985-1997)
-	Pierre Letouzey (LRI, 2000-now)
-	Pascal Manoury (INRIA, 1993)
-	Micaela Mayero (INRIA, 1997-2002)
-	Claude Marché (Paris Sud & INRIA, 2003-now)
-	César Muñoz (INRIA, 1994-1995)
-	Chetan Murthy (INRIA, 1992-1994)
-	Catherine Parent-Vigouroux (ENS Lyon, 1992-1995)
-	Patrick Loiseleur (Paris Sud, 1997-1999)
-	Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, 
-				  Paris Sud, 1997-now)
-	Clément Renard (INRIA, 2001-now)
-	Amokrane Saïbi (INRIA, 1993-1998)
-	Benjamin Werner (INRIA, 1989-1994)
-
+  Bruno Barras (INRIA, 1995-now)
+  Jacek Chrzaszcz (LRI, 1998-2003)
+  Thierry Coquand (INRIA, 1985-1989)
+  Pierre Corbineau (LRI, 2003-now)
+  Cristina Cornes (INRIA, 1993-1996)
+  Yann Coscoy (INRIA Sophia-Antipolis, 1995-1996)
+  David Delahaye (INRIA, 1997-2002)
+  Daniel de Rauglaudre (INRIA, 1996-1998)
+  Olivier Desmettre (INRIA, 2001-2003)
+  Gilles Dowek (INRIA, 1991-1994)
+  Amy Felty (INRIA, 1993)
+  Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-now)
+  Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998)
+  Benjamin Grégoire (INRIA, 2003-now)
+  Hugo Herbelin (INRIA, 1996-now)
+  Gérard Huet (INRIA, 1985-1997)
+  Pierre Letouzey (LRI, 2000-2005 & PPS-Paris 7, 2005-now)
+  Pascal Manoury (INRIA, 1993)
+  Micaela Mayero (INRIA, 1997-2002)
+  Claude Marché (INRIA 2003-2004 & LRI, 2004-2005)
+  Benjamin Monate (LRI, 2003)
+  César Muñoz (INRIA, 1994-1995)
+  Chetan Murthy (INRIA, 1992-1994)
+  Julien Narboux (INRIA, 2005-2006)
+  Jean-Marc Notin (CNRS, 2006-now)
+  Catherine Parent-Vigouroux (ENS Lyon, 1992-1995)
+  Patrick Loiseleur (Paris Sud, 1997-1999)
+  Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, 
+                            LRI, 1997-now)
+  Clément Renard (INRIA, 2001-2004)
+  Claudio Sacerdoti Coen (INRIA, 2004-2005)
+  Amokrane Saïbi (INRIA, 1993-1998)
+  Benjamin Werner (INRIA, 1989-1994)
 
 ***************************************************************************
 INRIA refers to :
-	Institut National de la Recherche en Informatique et Automatique
+  Institut National de la Recherche en Informatique et Automatique
 CNRS refers to :
-	Centre National de la Recherche Scientifique
-Paris Sud refers to :
-	Université Paris Sud
+  Centre National de la Recherche Scientifique
+LRI refers to : Laboratoire de Recherche en Informatique, UMR 8623 
+  CNRS and Université Paris-Sud
 ENS Lyon refers to :
-	Ecole Normale Supérieure de Lyon
+  Ecole Normale Supérieure de Lyon
 ****************************************************************************
diff --git a/Coq.bat b/Coq.bat
new file mode 100755
index 00000000..cdd7d50d
--- /dev/null
+++ b/Coq.bat
@@ -0,0 +1,8 @@
+@echo off
+set COQBIN=%~0\..\bin
+set COQLIB=%~0\..\lib
+echo Using COQBIN= %COQBIN%
+echo and   COQLIB= %COQLIB%
+echo Starting Coq
+%~0\..\bin\coqtop.opt.exe
+pause
\ No newline at end of file
diff --git a/Coqide.bat b/Coqide.bat
new file mode 100755
index 00000000..f955a970
--- /dev/null
+++ b/Coqide.bat
@@ -0,0 +1,7 @@
+@echo off
+set COQBIN=%~0\..\bin
+set COQLIB=%~0\..\lib
+echo Using COQBIN= %COQBIN%
+echo and   COQLIB= %COQLIB%
+echo Starting Coqide
+%~0\..\bin\coqide.opt.exe
\ No newline at end of file
diff --git a/INSTALL b/INSTALL
index ccfc65e0..1577ba90 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,14 +1,14 @@
 
-            INSTALLATION PROCEDURES FOR THE COQ V8.0 SYSTEM
+            INSTALLATION PROCEDURES FOR THE COQ V8.1 SYSTEM
             -----------------------------------------------
 
 WHAT DO YOU NEED ?
 ==================
 
    Coq is designed to work on computers equipped with the Unix operating 
-   system. In order to compile Coq V8.0 you need:
+   system. In order to compile Coq V8.1 you need:
 
-     - Objective Caml version 3.06 or later
+     - Objective Caml version 3.07 or later
        (available at http://caml.inria.fr/)
   
    Until now, it has mainly been tested on Sun workstations running Solaris,
@@ -29,7 +29,7 @@ QUICK INSTALLATION PROCEDURE.
 INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
 =================================================
 
-1- Check that you have the Objective Caml compiler version 3.06 (or later)
+1- Check that you have the Objective Caml compiler version 3.07 (or later)
    installed on your computer and that "ocamlmktop" and "ocamlc" (or
    its native code version "ocamlc.opt") lie in a directory which is present
    in your $PATH environment variable. 
diff --git a/INSTALL.ide b/INSTALL.ide
index 1c1d40c8..0ca3d9e0 100644
--- a/INSTALL.ide
+++ b/INSTALL.ide
@@ -9,7 +9,7 @@ DISCLAIMER: CoqIde is ongoing work. Eventhough it should never let you
  	    Do not hesitate to send suggestions/bug reports.
 
 REQUIREMENT:
-	- OCaml >= 3.06 with native thread support.
+	- OCaml >= 3.07 with native thread support.
 	- make world must succeed.
 	- The graphical toolkit Gtk 2.x. See http://www.gtk.org.
 	  The official supported version is at least 2.2.x.
@@ -35,9 +35,9 @@ INSTALLATION
 
  1) You need to install the OCaml stub library lablgtk2. See 
        	http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html
-    The first official release of lablgtk2 is here:
+    The first official release of lablftk2 is here:
 	http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/dist/lablgtk-2.2.0.tar.gz
-    Note that even if its README requires ocaml > 3.07, it works ok with 3.06.
+    Note that even if its README requires ocaml > 3.07, it works ok with 3.07.
     If you are in a hurry just run :
     
 cd /tmp && \
diff --git a/INSTALL.macosx b/INSTALL.macosx
index b756bdb7..84f32670 100644
--- a/INSTALL.macosx
+++ b/INSTALL.macosx
@@ -1,11 +1,11 @@
-INSTALLATION PROCEDURE FOR THE COQ V8.0 SYSTEM UNDER MACOS X
+INSTALLATION PROCEDURE FOR THE COQ V8.1 SYSTEM UNDER MACOS X
 ------------------------------------------------------------
 
-1) Download archive coq-8.0-macosx.dmg.
+1) Download archive coq-8.1-macosx.dmg.
 
-2) Double-click on its icon; it mounts a disk volume named "Coq V8.0".
+2) Double-click on its icon; it mounts a disk volume named "Coq V8.1".
 
-3) Open volume "Coq 8.0" and double-click on coq-8.0.pkg to launch the
+3) Open volume "Coq 8.1" and double-click on coq-8.1.pkg to launch the
    installer (you'll need administrator permissions).
 
 4) Coq installs in /usr/local/bin, which should be in your PATH, and
diff --git a/INSTALL.win b/INSTALL.win
new file mode 100644
index 00000000..f2cddb8a
--- /dev/null
+++ b/INSTALL.win
@@ -0,0 +1,63 @@
+*****************************************************************
+* INSTALLATION PROCEDURE FOR THE COQ V8 SYSTEM UNDER WINDOWS OS *
+*****************************************************************
+
+    The binary distribution consists in a .zip archive file. This .zip contains
+long filenames and cannot therefore be unpacked with pkunzip version 2. Use
+either Winzip (shareware) or the Windows version of unzip (freeware):
+
+    http://www.winzip.com/
+    http://www.winimage.com/zLibDll/
+
+    Unzipping the distribution creates (among others) the following directories
+and files:
+
+    coq\bin\		The command-line tools
+    coq\lib\		The standard library files
+    coq\emacs		A Coq mode for your Emacs
+    coq\man\man1	The man pages for the command-line tools
+
+    There are two cases to consider :
+
+1. You unzip in the root of your drive (say C):
+===============================================
+
+    Hence Coq will be installed in C:\coq
+
+    You must add the C:\coq\bin path to your environment variable PATH. This is
+done by adding the following line to your AUTOEXEC.BAT:
+
+	set PATH=%PATH%;C:\coq\bin
+
+    You may also want to specify where Coq has to look for your configuration
+file .coqrc (not mandatory), e.g.:
+
+	set HOME=C:\My_Documents\Coq
+
+2. You unzip in some other place (say D:\My_Dir):
+=================================================
+
+    You must add the D:\My_Dir\coq\bin path to your environment variable PATH.
+This is done by adding the following line to AUTOEXEC.BAT:
+
+	set PATH=%PATH%;D:\My_Dir\coq\bin
+
+    You must also set the environment variables COQBIN and COQLIB to tell Coq
+that binaries and libraries are not in the default place. This is done by
+adding the following lines to your AUTOEXEC.BAT:
+
+	set COQBIN=D:\My_Dir\coq\bin
+	set COQLIB=D:\My_Dir\coq\lib
+
+    You may also want to specify where Coq has to look for your configuration
+file .coqrc (not mandatory), e.g.:
+
+	set HOME=C:\My_Documents\Coq
+
+PROBLEMS:
+=========
+
+    If you have any trouble with this installation, please contact:
+coq-bugs@pauillac.inria.fr.
+
+    The Coq Team.
diff --git a/KNOWN-BUGS b/KNOWN-BUGS
new file mode 100644
index 00000000..774d181c
--- /dev/null
+++ b/KNOWN-BUGS
@@ -0,0 +1,20 @@
+  THIS IS A LIST OF KNOWN BUGS OF COQ V7.0
+
+- Realizer and Program/Program_all are not available
+
+- Local definitions in Record/Structure are not allowed
+
+- Alias of pattern with dependent types are not supported
+
+- Tokens with both symbols and letters are not supported
+
+- No consistency check is done when requiring a module (that is, a
+  module can be compiled with logical name Mycontrib.Arith.Plus but
+  required with name HisContrib.Zarith.Plus).
+
+- The syntax "Specialize num ident" is temporarily not accepted
+  outside "Tactic Definition". Syntax "Specialize ident" is OK.
+
+- New Induction fails for mutual inductive elimination
+
+- Elim fails with eliminators not imported
\ No newline at end of file
diff --git a/LICENSE b/LICENSE
index b1e3f5a2..27950e8d 100644
--- a/LICENSE
+++ b/LICENSE
@@ -55,7 +55,7 @@ modified by someone else and passed on, the recipients should know
 that what they have is not the original version, so that the original
 author's reputation will not be affected by problems that might be
 introduced by others.
-
+
   Finally, software patents pose a constant threat to the existence of
 any free program.  We wish to make sure that a company cannot
 effectively restrict the users of a free program by obtaining a
@@ -111,7 +111,7 @@ modification follow.  Pay close attention to the difference between a
 "work based on the library" and a "work that uses the library".  The
 former contains code derived from the library, whereas the latter must
 be combined with the library in order to run.
-
+
 		  GNU LESSER GENERAL PUBLIC LICENSE
    TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
 
@@ -158,7 +158,7 @@ Library.
   You may charge a fee for the physical act of transferring a copy,
 and you may at your option offer warranty protection in exchange for a
 fee.
-
+
   2. You may modify your copy or copies of the Library or any portion
 of it, thus forming a work based on the Library, and copy and
 distribute such modifications or work under the terms of Section 1
@@ -216,7 +216,7 @@ instead of to this License.  (If a newer version than version 2 of the
 ordinary GNU General Public License has appeared, then you can specify
 that version instead if you wish.)  Do not make any other change in
 these notices.
-
+
   Once this change is made in a given copy, it is irreversible for
 that copy, so the ordinary GNU General Public License applies to all
 subsequent copies and derivative works made from that copy.
@@ -267,7 +267,7 @@ Library will still fall under Section 6.)
 distribute the object code for the work under the terms of Section 6.
 Any executables containing that work also fall under Section 6,
 whether or not they are linked directly with the Library itself.
-
+
   6. As an exception to the Sections above, you may also combine or
 link a "work that uses the Library" with the Library to produce a
 work containing portions of the Library, and distribute that work
@@ -329,7 +329,7 @@ restrictions of other proprietary libraries that do not normally
 accompany the operating system.  Such a contradiction means you cannot
 use both them and the Library together in an executable that you
 distribute.
-
+
   7. You may place library facilities that are a work based on the
 Library side-by-side in a single library together with other library
 facilities not covered by this License, and distribute such a combined
@@ -370,7 +370,7 @@ subject to these terms and conditions.  You may not impose any further
 restrictions on the recipients' exercise of the rights granted herein.
 You are not responsible for enforcing compliance by third parties with
 this License.
-
+
   11. If, as a consequence of a court judgment or allegation of patent
 infringement or for any other reason (not limited to patent issues),
 conditions are imposed on you (whether by court order, agreement or
@@ -422,7 +422,7 @@ conditions either of that version or of any later version published by
 the Free Software Foundation.  If the Library does not specify a
 license version number, you may choose any version ever published by
 the Free Software Foundation.
-
+
   14. If you wish to incorporate parts of the Library into other free
 programs whose distribution conditions are incompatible with these,
 write to the author to ask for permission.  For software which is
@@ -456,49 +456,3 @@ SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
 DAMAGES.
 
 		     END OF TERMS AND CONDITIONS
-
-           How to Apply These Terms to Your New Libraries
-
-  If you develop a new library, and you want it to be of the greatest
-possible use to the public, we recommend making it free software that
-everyone can redistribute and change.  You can do so by permitting
-redistribution under these terms (or, alternatively, under the terms of the
-ordinary General Public License).
-
-  To apply these terms, attach the following notices to the library.  It is
-safest to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least the
-"copyright" line and a pointer to where the full notice is found.
-
-    <one line to give the library's name and a brief idea of what it does.>
-    Copyright (C) <year>  <name of author>
-
-    This library is free software; you can redistribute it and/or
-    modify it under the terms of the GNU Lesser General Public
-    License as published by the Free Software Foundation; either
-    version 2.1 of the License, or (at your option) any later version.
-
-    This library is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-    Lesser General Public License for more details.
-
-    You should have received a copy of the GNU Lesser General Public
-    License along with this library; if not, write to the Free Software
-    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-
-Also add information on how to contact you by electronic and paper mail.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the library, if
-necessary.  Here is a sample; alter the names:
-
-  Yoyodyne, Inc., hereby disclaims all copyright interest in the
-  library `Frob' (a library for tweaking knobs) written by James Random Hacker.
-
-  <signature of Ty Coon>, 1 April 1990
-  Ty Coon, President of Vice
-
-That's all there is to it!
-
-
diff --git a/Makefile b/Makefile
index fcd6c782..1428dafd 100644
--- a/Makefile
+++ b/Makefile
@@ -1,12 +1,12 @@
-########################################################################
-#  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        #
-########################################################################
+#######################################################################
+#  v      #   The Coq Proof Assistant  /  The Coq Development Team    #
+# <O___,, #        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              #
+#   \VV/  #############################################################
+#    //   #      This file is distributed under the terms of the      #
+#         #       GNU Lesser General Public License Version 2.1       #
+#######################################################################
 
-# $Id: Makefile,v 1.459.2.22 2006/01/11 23:18:05 barras Exp $ 
+# $Id: Makefile 9606 2007-02-07 12:21:01Z notin $ 
 
 
 # Makefile for Coq
@@ -26,7 +26,11 @@
 
 include config/Makefile
 
-noargument:
+.PHONY: NOARG
+
+NOARG: world
+
+help:
 	@echo "Please use either"
 	@echo "   ./configure"
 	@echo "   make world"
@@ -36,14 +40,11 @@ noargument:
 	@echo
 	@echo "For make to be verbose, add VERBOSE=1"
 
+
 # build and install the three subsystems: coq, coqide, pcoq
-world: coq coqide pcoq
-world8: coq8 coqide pcoq
-world7: coq7 coqide pcoq
+world: revision coq coqide pcoq
 
 install: install-coq install-coqide install-pcoq
-install8: install-coq8 install-coqide install-pcoq
-install7: install-coq7 install-coqide install-pcoq
 #install-manpages: install-coq-manpages install-pcoq-manpages
 
 ###########################################################################
@@ -63,42 +64,48 @@ else
 endif
 
 LOCALINCLUDES=-I config -I tools -I tools/coqdoc \
-	      -I scripts -I lib -I kernel -I library \
+	      -I scripts -I lib -I kernel -I kernel/byterun -I library \
               -I proofs -I tactics -I pretyping \
-              -I interp -I toplevel -I parsing -I ide/utils \
-	      -I ide -I translate \
+              -I interp -I toplevel -I parsing -I ide/utils -I ide \
               -I contrib/omega -I contrib/romega \
-	      -I contrib/ring -I contrib/xml \
-	      -I contrib/extraction \
+	      -I contrib/ring -I contrib/dp -I contrib/setoid_ring \
+              -I contrib/xml -I contrib/extraction \
               -I contrib/interface -I contrib/fourier \
 	      -I contrib/jprover -I contrib/cc \
 	      -I contrib/funind -I contrib/first-order \
-              -I contrib/field
+              -I contrib/field -I contrib/subtac -I contrib/rtauto \
+              -I contrib/recdef
 
 MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
 
-BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG)
-OPTFLAGS=$(MLINCLUDES) $(CAMLTIMEPROF)
-OCAMLDEP=ocamldep
-DEPFLAGS=-slash $(LOCALINCLUDES)
+OCAMLC += $(CAMLFLAGS)
+OCAMLOPT += $(CAMLFLAGS)
+
+BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG) $(USERFLAGS)
+OPTFLAGS=$(MLINCLUDES) $(CAMLTIMEPROF) $(INLINEFLAG) $(USERFLAGS)
+DEPFLAGS=$(LOCALINCLUDES)
 
 OCAMLC_P4O=$(OCAMLC) -pp $(CAMLP4O) $(BYTEFLAGS)
 OCAMLOPT_P4O=$(OCAMLOPT) -pp $(CAMLP4O) $(OPTFLAGS)
-CAMLP4EXTENDFLAGS=-I . pa_extend.cmo pa_extend_m.cmo pa_ifdef.cmo q_MLast.cmo 
-CAMLP4DEPS=sed -n -e 's|^(\*.*camlp4deps: "\(.*\)".*\*)$$|\1|p'
+CAMLP4EXTENDFLAGS=-I . pa_extend.cmo pa_extend_m.cmo q_MLast.cmo
+CAMLP4DEPS=sed -n -e 's|^(\*.*camlp4deps: "\(.*\)".*\*)|\1|p'
 
 COQINCLUDES=          # coqtop includes itself the needed paths
 GLOB=           # is "-dump-glob file" when making the doc
 COQ_XML=	# is "-xml" when building XML library
-COQOPTS=$(GLOB) $(COQ_XML)
-TRANSLATE=-translate -strict-implicit
+VM=          # is "-no-vm" to not use the vm"
+UNBOXEDVALUES=  # is "-unboxed-values" to use unboxed values
+COQOPTS=$(GLOB) $(COQ_XML) $(VM) $(UNBOXEDVALUES)
+TIME=           # is "'time -p'" to get compilation time of .v 
 
-BOOTCOQTOP=$(BESTCOQTOP) -boot $(COQOPTS)
+BOOTCOQTOP= $(TIME) $(BESTCOQTOP) -boot $(COQOPTS) 
 
 ###########################################################################
 # Objects files 
 ###########################################################################
 
+LIBCOQRUN=kernel/byterun/libcoqrun.a
+
 CLIBS=unix.cma
 
 CAMLP4OBJS=gramlib.cma
@@ -107,20 +114,28 @@ CONFIG=\
   config/coq_config.cmo
 
 LIBREP=\
-  lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bignat.cmo \
+  lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bigint.cmo \
   lib/hashcons.cmo lib/dyn.cmo lib/system.cmo lib/options.cmo \
   lib/bstack.cmo lib/edit.cmo lib/gset.cmo lib/gmap.cmo \
   lib/tlm.cmo lib/gmapl.cmo lib/profile.cmo lib/explore.cmo \
   lib/predicate.cmo lib/rtree.cmo lib/heap.cmo
 # Rem: Cygwin already uses variable LIB 
 
+BYTERUN=\
+  kernel/byterun/coq_fix_code.o kernel/byterun/coq_memory.o \
+  kernel/byterun/coq_values.o kernel/byterun/coq_interp.o 
+
 KERNEL=\
   kernel/names.cmo kernel/univ.cmo \
-  kernel/esubst.cmo kernel/term.cmo kernel/sign.cmo \
-  kernel/declarations.cmo kernel/environ.cmo kernel/closure.cmo \
-  kernel/conv_oracle.cmo kernel/reduction.cmo kernel/entries.cmo \
-  kernel/modops.cmo \
-  kernel/type_errors.cmo kernel/inductive.cmo kernel/typeops.cmo \
+  kernel/esubst.cmo kernel/term.cmo kernel/mod_subst.cmo kernel/sign.cmo \
+  kernel/cbytecodes.cmo kernel/copcodes.cmo \
+  kernel/cemitcodes.cmo kernel/vm.cmo \
+  kernel/declarations.cmo kernel/pre_env.cmo \
+  kernel/cbytegen.cmo  kernel/environ.cmo  \
+  kernel/csymtable.cmo kernel/conv_oracle.cmo \
+  kernel/closure.cmo kernel/reduction.cmo kernel/type_errors.cmo \
+  kernel/entries.cmo kernel/modops.cmo \
+  kernel/inductive.cmo kernel/vconv.cmo kernel/typeops.cmo \
   kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \
   kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo
 
@@ -128,85 +143,80 @@ LIBRARY=\
   library/nameops.cmo library/libnames.cmo library/libobject.cmo \
   library/summary.cmo library/nametab.cmo library/global.cmo library/lib.cmo \
   library/declaremods.cmo library/library.cmo library/states.cmo \
-  library/decl_kinds.cmo library/dischargedhypsmap.cmo library/goptions.cmo 
+  library/decl_kinds.cmo library/dischargedhypsmap.cmo library/goptions.cmo
 
 PRETYPING=\
-  pretyping/termops.cmo pretyping/evd.cmo pretyping/instantiate.cmo \
-  pretyping/reductionops.cmo pretyping/inductiveops.cmo \
-  pretyping/rawterm.cmo pretyping/pattern.cmo \
-  pretyping/detyping.cmo pretyping/retyping.cmo \
-  pretyping/cbv.cmo pretyping/pretype_errors.cmo pretyping/typing.cmo \
+  pretyping/termops.cmo pretyping/evd.cmo \
+  pretyping/reductionops.cmo pretyping/vnorm.cmo pretyping/inductiveops.cmo \
+  pretyping/retyping.cmo pretyping/cbv.cmo \
+  pretyping/pretype_errors.cmo pretyping/recordops.cmo pretyping/typing.cmo \
   pretyping/tacred.cmo \
-  pretyping/classops.cmo pretyping/recordops.cmo pretyping/indrec.cmo \
-  pretyping/evarutil.cmo pretyping/evarconv.cmo \
-  pretyping/coercion.cmo pretyping/cases.cmo pretyping/pretyping.cmo \
-  pretyping/matching.cmo
+  pretyping/evarutil.cmo pretyping/unification.cmo pretyping/evarconv.cmo \
+  pretyping/classops.cmo pretyping/coercion.cmo pretyping/clenv.cmo \
+  pretyping/rawterm.cmo pretyping/pattern.cmo \
+  pretyping/detyping.cmo  pretyping/indrec.cmo\
+  pretyping/cases.cmo pretyping/pretyping.cmo pretyping/matching.cmo
 
 INTERP=\
-  parsing/lexer.cmo interp/topconstr.cmo interp/ppextend.cmo interp/symbols.cmo \
+  parsing/lexer.cmo interp/topconstr.cmo interp/ppextend.cmo \
+  interp/notation.cmo \
   interp/genarg.cmo interp/syntax_def.cmo interp/reserve.cmo \
   library/impargs.cmo interp/constrintern.cmo \
   interp/modintern.cmo interp/constrextern.cmo interp/coqlib.cmo \
-  library/declare.cmo
-
-PARSING=\
-  parsing/coqast.cmo parsing/ast.cmo \
-  parsing/termast.cmo parsing/extend.cmo parsing/esyntax.cmo \
-  parsing/pcoq.cmo parsing/egrammar.cmo \
-  parsing/ppconstr.cmo translate/ppconstrnew.cmo parsing/printer.cmo \
-  parsing/pptactic.cmo translate/pptacticnew.cmo \
-  parsing/printmod.cmo parsing/prettyp.cmo parsing/search.cmo
-
-HIGHPARSING=\
-  parsing/g_prim.cmo parsing/g_proofs.cmo parsing/g_basevernac.cmo \
-  parsing/g_vernac.cmo parsing/g_tactic.cmo \
-  parsing/g_ltac.cmo parsing/g_constr.cmo parsing/g_cases.cmo \
-  parsing/g_module.cmo \
-  parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo
-
-HIGHPARSINGNEW=\
-  parsing/g_primnew.cmo parsing/g_constrnew.cmo parsing/g_tacticnew.cmo \
-  parsing/g_ltacnew.cmo parsing/g_vernacnew.cmo parsing/g_proofsnew.cmo
-
-ARITHSYNTAX=\
-  parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo
+  toplevel/discharge.cmo library/declare.cmo
 
 PROOFS=\
-  proofs/tacexpr.cmo proofs/proof_type.cmo \
+  proofs/tacexpr.cmo proofs/proof_type.cmo proofs/redexpr.cmo \
   proofs/proof_trees.cmo proofs/logic.cmo \
   proofs/refiner.cmo proofs/evar_refiner.cmo proofs/tacmach.cmo \
-  proofs/clenv.cmo proofs/pfedit.cmo proofs/tactic_debug.cmo
+  proofs/pfedit.cmo proofs/tactic_debug.cmo \
+  proofs/clenvtac.cmo proofs/decl_mode.cmo
+
+PARSING=\
+  parsing/extend.cmo \
+  parsing/pcoq.cmo parsing/egrammar.cmo parsing/g_xml.cmo \
+  parsing/ppconstr.cmo parsing/printer.cmo \
+  parsing/pptactic.cmo parsing/ppdecl_proof.cmo parsing/tactic_printer.cmo \
+  parsing/printmod.cmo parsing/prettyp.cmo parsing/search.cmo 
+
+HIGHPARSING=\
+  parsing/g_constr.cmo parsing/g_vernac.cmo parsing/g_prim.cmo \
+  parsing/g_proofs.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo \
+  parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo \
+  parsing/g_ascii_syntax.cmo parsing/g_string_syntax.cmo \
+  parsing/g_decl_mode.cmo
 
 TACTICS=\
   tactics/dn.cmo tactics/termdn.cmo tactics/btermdn.cmo \
   tactics/nbtermdn.cmo tactics/tacticals.cmo \
   tactics/hipattern.cmo tactics/tactics.cmo \
+  tactics/evar_tactics.cmo \
   tactics/hiddentac.cmo tactics/elim.cmo \
   tactics/dhyp.cmo tactics/auto.cmo \
   tactics/setoid_replace.cmo tactics/equality.cmo \
   tactics/contradiction.cmo tactics/inv.cmo tactics/leminv.cmo \
-  tactics/tacinterp.cmo \
+  tactics/tacinterp.cmo tactics/autorewrite.cmo \
+  tactics/decl_interp.cmo tactics/decl_proof_instr.cmo
 
 TOPLEVEL=\
   toplevel/himsg.cmo toplevel/cerrors.cmo toplevel/class.cmo \
-  toplevel/vernacexpr.cmo  toplevel/metasyntax.cmo \
-  toplevel/command.cmo \
-  toplevel/record.cmo toplevel/recordobj.cmo \
-  toplevel/discharge.cmo translate/ppvernacnew.cmo \
+  toplevel/vernacexpr.cmo toplevel/metasyntax.cmo \
+  toplevel/command.cmo toplevel/record.cmo \
+  parsing/ppvernac.cmo \
   toplevel/vernacinterp.cmo toplevel/mltop.cmo \
-  toplevel/vernacentries.cmo toplevel/vernac.cmo \
+  toplevel/vernacentries.cmo toplevel/whelp.cmo toplevel/vernac.cmo \
   toplevel/line_oriented_parser.cmo toplevel/protectedtoplevel.cmo \
   toplevel/toplevel.cmo toplevel/usage.cmo \
   toplevel/coqinit.cmo toplevel/coqtop.cmo
 
 HIGHTACTICS=\
-  tactics/autorewrite.cmo tactics/refine.cmo \
-  tactics/extraargs.cmo tactics/extratactics.cmo tactics/eauto.cmo
+  tactics/refine.cmo tactics/extraargs.cmo \
+  tactics/extratactics.cmo tactics/eauto.cmo
 
 SPECTAC= tactics/tauto.ml4 tactics/eqdecide.ml4
 USERTAC = $(SPECTAC)
 ML4FILES += $(USERTAC) tactics/extraargs.ml4 tactics/extratactics.ml4 \
-	tactics/eauto.ml4 
+	tactics/eauto.ml4 toplevel/whelp.ml4 tactics/hipattern.ml4
 
 USERTACCMO=$(USERTAC:.ml4=.cmo)
 USERTACCMX=$(USERTAC:.ml4=.cmx)
@@ -214,7 +224,8 @@ USERTACCMX=$(USERTAC:.ml4=.cmx)
 ML4FILES +=\
   contrib/omega/g_omega.ml4 \
   contrib/romega/g_romega.ml4 contrib/ring/g_quote.ml4 \
-  contrib/ring/g_ring.ml4 \
+  contrib/ring/g_ring.ml4 contrib/dp/g_dp.ml4 \
+  contrib/setoid_ring/newring.ml4  \
   contrib/field/field.ml4 contrib/fourier/g_fourier.ml4 \
   contrib/extraction/g_extraction.ml4 contrib/xml/xmlentries.ml4
 
@@ -223,13 +234,20 @@ OMEGACMO=\
   contrib/omega/g_omega.cmo 
 
 ROMEGACMO=\
-  contrib/romega/omega2.cmo contrib/romega/const_omega.cmo \
+  contrib/romega/const_omega.cmo \
   contrib/romega/refl_omega.cmo contrib/romega/g_romega.cmo
 
 RINGCMO=\
   contrib/ring/quote.cmo contrib/ring/g_quote.cmo \
   contrib/ring/ring.cmo contrib/ring/g_ring.cmo 
 
+NEWRINGCMO=\
+  contrib/setoid_ring/newring.cmo
+
+DPCMO=contrib/dp/dp_why.cmo contrib/dp/dp.cmo contrib/dp/g_dp.cmo
+#  contrib/dp/dp_simplify.cmo contrib/dp/dp_zenon.cmo contrib/dp/dp_cvcl.cmo \
+#  contrib/dp/dp_sorts.cmo 
+
 FIELDCMO=\
   contrib/field/field.cmo 
 
@@ -239,7 +257,7 @@ XMLCMO=\
   contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \
   contrib/xml/proof2aproof.cmo \
   contrib/xml/xmlcommand.cmo contrib/xml/proofTree2Xml.cmo \
-	contrib/xml/xmlentries.cmo 	
+  contrib/xml/xmlentries.cmo 	contrib/xml/cic2Xml.cmo
 
 FOURIERCMO=\
   contrib/fourier/fourier.cmo contrib/fourier/fourierR.cmo \
@@ -264,7 +282,16 @@ JPROVERCMO=\
   contrib/jprover/jprover.cmo
 
 FUNINDCMO=\
-  contrib/funind/tacinvutils.cmo contrib/funind/tacinv.cmo 
+  contrib/funind/tacinvutils.cmo contrib/funind/tacinv.cmo \
+  contrib/funind/indfun_common.cmo contrib/funind/rawtermops.cmo \
+  contrib/funind/rawterm_to_relation.cmo \
+  contrib/funind/functional_principles_proofs.cmo \
+  contrib/funind/functional_principles_types.cmo \
+  contrib/funind/invfun.cmo contrib/funind/indfun.cmo \
+  contrib/funind/merge.cmo contrib/funind/indfun_main.cmo
+
+RECDEFCMO=\
+  contrib/recdef/recdef.cmo
 
 FOCMO=\
   contrib/first-order/formula.cmo contrib/first-order/unify.cmo \
@@ -272,34 +299,101 @@ FOCMO=\
   contrib/first-order/instances.cmo contrib/first-order/ground.cmo \
   contrib/first-order/g_ground.cmo
 
-CCCMO=contrib/cc/ccalgo.cmo contrib/cc/ccproof.cmo contrib/cc/cctac.cmo  
+CCCMO=contrib/cc/ccalgo.cmo contrib/cc/ccproof.cmo contrib/cc/cctac.cmo \
+  contrib/cc/g_congruence.cmo 
+
+SUBTACCMO=contrib/subtac/subtac_utils.cmo contrib/subtac/eterm.cmo \
+  contrib/subtac/g_eterm.cmo contrib/subtac/context.cmo \
+  contrib/subtac/subtac_errors.cmo contrib/subtac/subtac_coercion.cmo \
+  contrib/subtac/subtac_obligations.cmo contrib/subtac/subtac_cases.cmo \
+  contrib/subtac/subtac_pretyping_F.cmo contrib/subtac/subtac_pretyping.cmo \
+  contrib/subtac/subtac_interp_fixpoint.cmo \
+  contrib/subtac/subtac_command.cmo contrib/subtac/subtac.cmo \
+  contrib/subtac/g_subtac.cmo
+
+
+RTAUTOCMO=contrib/rtauto/proof_search.cmo contrib/rtauto/refl_tauto.cmo \
+	contrib/rtauto/g_rtauto.cmo
+
+ML4FILES += contrib/jprover/jprover.ml4 contrib/cc/g_congruence.ml4 \
+	contrib/funind/tacinv.ml4 contrib/first-order/g_ground.ml4 \
+	contrib/subtac/g_subtac.ml4 contrib/subtac/g_eterm.ml4 \
+	contrib/rtauto/g_rtauto.ml4 contrib/recdef/recdef.ml4 \
+	contrib/funind/indfun_main.ml4 
 
-ML4FILES += contrib/jprover/jprover.ml4 contrib/cc/cctac.ml4 \
-  contrib/funind/tacinv.ml4 contrib/first-order/g_ground.ml4
 
-CONTRIB=$(OMEGACMO) $(ROMEGACMO) $(RINGCMO) $(FIELDCMO) \
+CONTRIB=$(OMEGACMO) $(ROMEGACMO) $(RINGCMO) $(NEWRINGCMO) $(DPCMO) $(FIELDCMO) \
 	$(FOURIERCMO) $(EXTRACTIONCMO) $(JPROVERCMO) $(XMLCMO) \
-	$(CCCMO) $(FUNINDCMO) $(FOCMO)
+	$(CCCMO)  $(FOCMO) $(SUBTACCMO) $(RTAUTOCMO) \
+        $(RECDEFCMO) $(FUNINDCMO)
 
 CMA=$(CLIBS) $(CAMLP4OBJS)
 CMXA=$(CMA:.cma=.cmxa)
 
-# Beware that highparsingnew.cma should appear before hightactics.cma
+# LINK ORDER:
+# Beware that highparsing.cma should appear before hightactics.cma
 # respecting this order is useful for developers that want to load or link
 # the libraries directly
-CMO=$(CONFIG) lib/lib.cma kernel/kernel.cma library/library.cma \
-    pretyping/pretyping.cma interp/interp.cma parsing/parsing.cma \
-    proofs/proofs.cma tactics/tactics.cma toplevel/toplevel.cma \
-    parsing/highparsing.cma parsing/highparsingnew.cma tactics/hightactics.cma \
-    contrib/contrib.cma
-CMOCMXA=$(CMO:.cma=.cmxa)
-CMX=$(CMOCMXA:.cmo=.cmx)
+LINKCMO=$(CONFIG) lib/lib.cma kernel/kernel.cma library/library.cma \
+        pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
+        parsing/parsing.cma tactics/tactics.cma toplevel/toplevel.cma \
+        parsing/highparsing.cma tactics/hightactics.cma contrib/contrib.cma
+LINKCMOCMXA=$(LINKCMO:.cma=.cmxa)
+LINKCMX=$(LINKCMOCMXA:.cmo=.cmx)
+
+# objects known by the toplevel of Coq
+OBJSCMO=$(CONFIG) $(LIBREP) $(KERNEL) $(LIBRARY) $(PRETYPING) $(INTERP) \
+        $(PROOFS) $(PARSING) $(TACTICS) $(TOPLEVEL) $(HIGHPARSING) \
+        $(HIGHTACTICS) $(USERTACMO) $(CONTRIB)
+
+###########################################################################
+# Compilation option for .c files 
+###########################################################################
+
+CINCLUDES= -I $(CAMLHLIB)
+
+ifeq ($(CAMLVERSION),OCAML307)
+  CFLAGS=-fno-defer-pop -Wall -Wno-unused -DOCAML_307
+else
+  CFLAGS=-fno-defer-pop -Wall -Wno-unused
+endif
+
+# libcoqrun.a 
+
+$(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) 
+	$(AR) rc $(LIBCOQRUN) $(BYTERUN) 
+	$(RANLIB) $(LIBCOQRUN)
+
+#coq_jumptbl.h is required only if you have GCC 2.0 or later
+kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h
+	sed -n -e '/^  /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \
+               -e '/^}/q' kernel/byterun/coq_instruct.h > \
+                          kernel/byterun/coq_jumptbl.h
+
+
+kernel/copcodes.ml: kernel/byterun/coq_instruct.h
+	sed -n -e '/^enum/p' -e 's/,//g' -e '/^  /p' \
+	kernel/byterun/coq_instruct.h | \
+	awk -f kernel/make-opcodes > kernel/copcodes.ml
+
+bytecompfile : kernel/byterun/coq_jumptbl.h kernel/copcodes.ml
+
+beforedepend:: bytecompfile
+
+clean ::
+	rm -f kernel/byterun/coq_jumptbl.h kernel/copcodes.ml
 
 ###########################################################################
 # Main targets (coqmktop, coqtop.opt, coqtop.byte)
 ###########################################################################
 
+COQMKTOPBYTE=bin/coqmktop.byte$(EXE)
+COQMKTOPOPT=bin/coqmktop.opt$(EXE)
+BESTCOQMKTOP=bin/coqmktop.$(BEST)$(EXE)
 COQMKTOP=bin/coqmktop$(EXE) 
+COQCBYTE=bin/coqc.byte$(EXE)
+COQCOPT=bin/coqc.opt$(EXE)
+BESTCOQC=bin/coqc.$(BEST)$(EXE)
 COQC=bin/coqc$(EXE)
 COQTOPBYTE=bin/coqtop.byte$(EXE)
 COQTOPOPT=bin/coqtop.opt$(EXE)
@@ -310,26 +404,20 @@ COQBINARIES= $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(BESTCOQTOP) $(COQTOP)
 
 coqbinaries:: ${COQBINARIES}
 
-coq: coqlib tools coqbinaries coqlib7
-coq8: coqlib tools coqbinaries
-coq7: coqlib7 tools coqbinaries
+coq: coqlib tools coqbinaries
 
-coqlib:: newtheories newcontrib
-
-coqlib7: theories7 contrib7
+coqlib:: theories contrib
 
 coqlight: theories-light tools coqbinaries
 
-states7:: states7/initial.coq
-
 states:: states/initial.coq
 
-$(COQTOPOPT): $(COQMKTOP) $(CMX) $(USERTACCMX)
+$(COQTOPOPT): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(USERTACCMX)
 	$(SHOW)'COQMKTOP -o $@'	
 	$(HIDE)$(COQMKTOP) -opt $(OPTFLAGS) -o $@
 	$(STRIP) $@
 
-$(COQTOPBYTE): $(COQMKTOP) $(CMO) $(USERTACCMO)
+$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(USERTACCMO)
 	$(SHOW)'COQMKTOP -o $@'	
 	$(HIDE)$(COQMKTOP) -top $(BYTEFLAGS) -o $@
 
@@ -339,27 +427,27 @@ $(COQTOP):
 # coqmktop 
 
 COQMKTOPCMO=$(CONFIG) scripts/tolink.cmo scripts/coqmktop.cmo 
+COQMKTOPCMX=config/coq_config.cmx scripts/tolink.cmx scripts/coqmktop.cmx 
 
-$(COQMKTOP): $(COQMKTOPCMO)
+$(COQMKTOPBYTE): $(COQMKTOPCMO)
 	$(SHOW)'OCAMLC -o $@'	
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ -custom str.cma unix.cma \
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma unix.cma \
           $(COQMKTOPCMO) $(OSDEPLIBS)
 
+$(COQMKTOPOPT): $(COQMKTOPCMX)
+	$(SHOW)'OCAMLOPT -o $@'	
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ str.cmxa unix.cmxa \
+          $(COQMKTOPCMX) $(OSDEPLIBS)
+
+$(COQMKTOP): $(BESTCOQMKTOP)
+	cd bin; ln -sf coqmktop.$(BEST)$(EXE) coqmktop$(EXE)
+
+
 scripts/tolink.ml: Makefile
 	$(SHOW)"ECHO... >" $@
-	$(HIDE)echo "let lib = \""$(LIBREP)"\"" > $@
-	$(HIDE)echo "let kernel = \""$(KERNEL)"\"" >> $@
-	$(HIDE)echo "let library = \""$(LIBRARY)"\"" >> $@
-	$(HIDE)echo "let pretyping = \""$(PRETYPING)"\"" >> $@
-	$(HIDE)echo "let proofs = \""$(PROOFS)"\"" >> $@
-	$(HIDE)echo "let tactics = \""$(TACTICS)"\"" >> $@
-	$(HIDE)echo "let interp = \""$(INTERP)"\"" >> $@
-	$(HIDE)echo "let parsing = \""$(PARSING)"\"" >> $@
-	$(HIDE)echo "let toplevel = \""$(TOPLEVEL)"\"" >> $@
-	$(HIDE)echo "let highparsing = \""$(HIGHPARSING)"\"" >> $@
-	$(HIDE)echo "let highparsingnew = \""$(HIGHPARSINGNEW)"\"" >> $@
-	$(HIDE)echo "let hightactics = \""$(HIGHTACTICS)" "$(USERTACCMO)"\"" >> $@
-	$(HIDE)echo "let contrib = \""$(CONTRIB)"\"" >> $@
+	$(HIDE)echo "let copts = \"-cclib -lcoqrun\"" > $@
+	$(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" >> $@
+	$(HIDE)echo "let core_objs = \""$(OBJSCMO)"\"" >> $@
 	$(HIDE)echo "let ide = \""$(COQIDECMO)"\"" >> $@
 
 beforedepend:: scripts/tolink.ml
@@ -367,18 +455,32 @@ beforedepend:: scripts/tolink.ml
 # coqc
 
 COQCCMO=$(CONFIG) toplevel/usage.cmo scripts/coqc.cmo
+COQCCMX=config/coq_config.cmx toplevel/usage.cmx scripts/coqc.cmx
 
-$(COQC): $(COQCCMO) $(COQTOPBYTE) $(BESTCOQTOP)
+$(COQCBYTE): $(COQCCMO) $(COQTOPBYTE) $(BESTCOQTOP)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ -custom unix.cma $(COQCCMO) $(OSDEPLIBS)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ unix.cma $(COQCCMO) $(OSDEPLIBS)
+
+$(COQCOPT): $(COQCCMX) $(COQTOPOPT) $(BESTCOQTOP)
+	$(SHOW)'OCAMLOPT -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ unix.cmxa $(COQCCMX) $(OSDEPLIBS)
+
+$(COQC): $(BESTCOQC)
+	cd bin; ln -sf coqc.$(BEST)$(EXE) coqc$(EXE)
+
 
 clean::
 	rm -f scripts/tolink.ml
 
+archclean::
+	rm -f $(COQTOPBYTE) $(COQTOPOPT) $(BESTCOQTOP) $(COQC) $(COQMKTOP)
+	rm -f $(COQTOP)
+
 # we provide targets for each subdirectory
 
 lib: $(LIBREP)
 kernel: $(KERNEL)
+byterun: $(BYTERUN)
 library: $(LIBRARY)
 proofs: $(PROOFS)
 tactics: $(TACTICS)
@@ -386,7 +488,6 @@ interp: $(INTERP)
 parsing: $(PARSING)
 pretyping: $(PRETYPING)
 highparsing: $(HIGHPARSING)
-highparsingnew: $(HIGHPARSINGNEW)
 toplevel: $(TOPLEVEL)
 hightactics: $(HIGHTACTICS)
 
@@ -489,14 +590,6 @@ contrib/contrib.cmxa: $(CONTRIB:.cmo=.cmx)
 	$(SHOW)'OCAMLOPT -a -o $@'
 	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(CONTRIB:.cmo=.cmx)
 
-parsing/highparsingnew.cma: $(HIGHPARSINGNEW)
-	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(HIGHPARSINGNEW)
-
-parsing/highparsingnew.cmxa: $(HIGHPARSINGNEW:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(HIGHPARSINGNEW:.cmo=.cmx)
-
 ###########################################################################
 # CoqIde special targets
 ###########################################################################
@@ -508,7 +601,7 @@ COQIDEBYTE=bin/coqide.byte$(EXE)
 COQIDEOPT=bin/coqide.opt$(EXE)
 COQIDE=bin/coqide$(EXE)
 
-COQIDECMO=ide/utils/okey.cmo ide/utils/uoptions.cmo \
+COQIDECMO=ide/utils/okey.cmo ide/utils/config_file.cmo \
 	  ide/utils/configwin_keys.cmo ide/utils/configwin_types.cmo \
 	  ide/utils/configwin_messages.cmo ide/utils/configwin_ihm.cmo \
 	  ide/utils/configwin.cmo \
@@ -530,7 +623,7 @@ COQIDEVO=ide/utf8.vo
 $(COQIDEVO): states/initial.coq 
 	$(BOOTCOQTOP) -compile $*
 
-IDEFILES=$(COQIDEVO) ide/utf8.v ide/coq.ico ide/coq2.ico ide/.coqide-gtk2rc
+IDEFILES=$(COQIDEVO) ide/utf8.v ide/coq.png ide/.coqide-gtk2rc
 
 coqide-binaries: coqide-$(HASCOQIDE)
 coqide-no:
@@ -544,47 +637,42 @@ clean-ide:
 	rm -f ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml
 	rm -f ide/utf8_convert.ml
 
-$(COQIDEOPT): $(COQMKTOP) $(CMX) $(USERTACCMX) ide/ide.cmxa
+$(COQIDEOPT): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(USERTACCMX) ide/ide.cmxa
 	$(SHOW)'COQMKTOP -o $@'	
 	$(HIDE)$(COQMKTOP) -ide -opt $(OPTFLAGS) -o $@
 	$(STRIP) $@
 
-$(COQIDEBYTE): $(COQMKTOP) $(CMO) $(USERTACCMO) ide/ide.cma
+$(COQIDEBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(USERTACCMO) ide/ide.cma
 	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(COQMKTOP) -ide -top $(BYTEFLAGS) -o $@
+	$(HIDE)$(COQMKTOP) -g -ide -top $(BYTEFLAGS) -o $@
 
 $(COQIDE):
 	cd bin; ln -sf coqide.$(HASCOQIDE)$(EXE) coqide$(EXE)
 
 ide/%.cmo: ide/%.ml
 	$(SHOW)'OCAMLC    $<'	
-	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
 
 ide/%.cmi: ide/%.mli
 	$(SHOW)'OCAMLC    $<'	
-	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
 
 ide/%.cmx: ide/%.ml
 	$(SHOW)'OCAMLOPT  $<'	
 	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $<
 
-ide/utils/%.cmo: ide/utils/%.ml
+ide/utils/%.cmo: ide/%.ml
 	$(SHOW)'OCAMLC    $<'	
-	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
 
-ide/utils/%.cmi: ide/utils/%.mli
+ide/utils/%.cmi: ide/%.mli
 	$(SHOW)'OCAMLC    $<'	
-	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
 
-ide/utils/%.cmx: ide/utils/%.ml
+ide/utils/%.cmx: ide/%.ml
 	$(SHOW)'OCAMLOPT  $<'	
 	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $<
 
-# Special target to select between whether lablgtk >= 2.6.0 or not
-ide/undo.cmi: ide/undo.mli
-	$(SHOW)'OCAMLC    $<'	
-	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) $(CAMLP4COMPAT) -intf" -c -intf $<
-
 clean::
 	rm -f ide/extract_index.ml ide/find_phrase.ml ide/highlight.ml
 	rm -f ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml
@@ -642,12 +730,13 @@ INTERFACE=\
   contrib/interface/name_to_ast.cmo contrib/interface/debug_tac.cmo \
   contrib/interface/showproof_ct.cmo contrib/interface/showproof.cmo \
   contrib/interface/blast.cmo contrib/interface/centaur.cmo
+
 INTERFACECMX=$(INTERFACE:.cmo=.cmx)
 
 ML4FILES += contrib/interface/debug_tac.ml4 contrib/interface/centaur.ml4
 
-PARSERREQUIRES=$(CMO) # Solution de facilité...
-PARSERREQUIRESCMX=$(CMX)
+PARSERREQUIRES=$(LINKCMO) $(LIBCOQRUN) # Solution de facilité...
+PARSERREQUIRESCMX=$(LINKCMX)
 
 ifeq ($(BEST),opt)
   COQINTERFACE=bin/coq-interface$(EXE) bin/coq-interface.opt$(EXE) bin/parser$(EXE) bin/parser.opt$(EXE)
@@ -657,11 +746,11 @@ endif
 
 pcoq-binaries:: $(COQINTERFACE) 
 
-bin/coq-interface$(EXE): $(COQMKTOP) $(CMO) $(USERTACCMO) $(INTERFACE)
+bin/coq-interface$(EXE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(USERTACCMO) $(INTERFACE)
 	$(SHOW)'COQMKTOP -o $@'
 	$(HIDE)$(COQMKTOP) -top $(BYTEFLAGS) -o $@ $(INTERFACE)
 
-bin/coq-interface.opt$(EXE): $(COQMKTOP) $(CMX) $(USERTACCMX) $(INTERFACECMX)
+bin/coq-interface.opt$(EXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(USERTACCMX) $(INTERFACECMX)
 	$(SHOW)'COQMKTOP -o $@'
 	$(HIDE)$(COQMKTOP) -opt $(OPTFLAGS) -o $@ $(INTERFACECMX)
 
@@ -670,15 +759,15 @@ PARSERCODE=contrib/interface/line_parser.cmo contrib/interface/vtp.cmo \
 PARSERCMO=$(PARSERREQUIRES) $(PARSERCODE)
 PARSERCMX= $(PARSERREQUIRESCMX) $(PARSERCODE:.cmo=.cmx)
 
-bin/parser$(EXE): $(PARSERCMO)
+bin/parser$(EXE):$(LIBCOQRUN) $(PARSERCMO)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) -linkall -custom -cclib -lunix $(OPTFLAGS) -o $@ \
-	  dynlink.cma $(CMA) $(PARSERCMO)
+	$(HIDE)$(OCAMLC) -custom -linkall $(BYTEFLAGS) -o $@ \
+	  dynlink.cma $(LIBCOQRUN) $(CMA) $(PARSERCMO)
 
-bin/parser.opt$(EXE): $(PARSERCMX)
+bin/parser.opt$(EXE): $(LIBCOQRUN) $(PARSERCMX)
 	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) -linkall -cclib -lunix $(OPTFLAGS) -o $@ \
-	  $(CMXA) $(PARSERCMX)
+	$(HIDE)$(OCAMLOPT) -linkall $(OPTFLAGS) -o $@ \
+	  $(LIBCOQRUN) $(CMXA) $(PARSERCMX)
 
 INTERFACEVO=
 
@@ -686,14 +775,8 @@ INTERFACERC= contrib/interface/vernacrc
 
 pcoq-files:: $(INTERFACEVO) $(INTERFACERC)
 
-# Centaur grammar rules now in centaur.ml4
-contrib7/interface/Centaur.vo: contrib7/interface/Centaur.v $(INTERFACE)
-	$(BESTCOQTOP) $(TRANSLATE) -boot -byte $(COQOPTS) -compile $*
-
-# Move the grammar rules to dad.ml ?
-contrib7/interface/AddDad.vo: contrib7/interface/AddDad.v $(INTERFACE) states7/initial.coq
-	$(BESTCOQTOP) $(TRANSLATE) -boot -byte  $(COQOPTS) -compile $*
-
+clean::
+	rm -f bin/parser$(EXE) bin/parser.opt$(EXE) bin/coq-interface$(EXE) bin/coq-interface.opt$(EXE)
 
 # install targets
 install-pcoq:: install-pcoq-binaries install-pcoq-files install-pcoq-manpages
@@ -730,20 +813,24 @@ INITVO=\
  theories/Init/Datatypes.vo         theories/Init/Peano.vo     \
  theories/Init/Logic.vo             theories/Init/Specif.vo    \
  theories/Init/Logic_Type.vo        theories/Init/Wf.vo      \
- theories/Init/Prelude.vo
+ theories/Init/Tactics.vo           theories/Init/Prelude.vo
 
 init: $(INITVO)
 
 LOGICVO=\
- theories/Logic/Hurkens.vo          	theories/Logic/ProofIrrelevance.vo\
- theories/Logic/Classical.vo          	theories/Logic/Classical_Type.vo \
- theories/Logic/Classical_Pred_Set.vo   theories/Logic/Eqdep.vo          \
- theories/Logic/Classical_Pred_Type.vo  theories/Logic/Classical_Prop.vo \
- theories/Logic/ClassicalFacts.vo       theories/Logic/ChoiceFacts.vo \
- theories/Logic/Berardi.vo       	theories/Logic/Eqdep_dec.vo \
- theories/Logic/Decidable.vo            theories/Logic/JMeq.vo \
- theories/Logic/ClassicalDescription.vo theories/Logic/ClassicalChoice.vo \
- theories/Logic/RelationalChoice.vo     theories/Logic/Diaconescu.vo
+ theories/Logic/Hurkens.vo            theories/Logic/ProofIrrelevance.vo\
+ theories/Logic/Classical.vo          theories/Logic/Classical_Type.vo \
+ theories/Logic/Classical_Pred_Set.vo theories/Logic/Eqdep.vo          \
+ theories/Logic/Classical_Prop.vo     theories/Logic/Classical_Pred_Type.vo \
+ theories/Logic/ClassicalFacts.vo     theories/Logic/ChoiceFacts.vo \
+ theories/Logic/Berardi.vo            theories/Logic/Eqdep_dec.vo \
+ theories/Logic/Decidable.vo          theories/Logic/JMeq.vo \
+ theories/Logic/ClassicalChoice.vo    theories/Logic/ClassicalDescription.vo \
+ theories/Logic/RelationalChoice.vo   theories/Logic/Diaconescu.vo \
+ theories/Logic/EqdepFacts.vo         theories/Logic/ProofIrrelevanceFacts.vo \
+ theories/Logic/ClassicalEpsilon.vo   theories/Logic/ClassicalUniqueChoice.vo \
+ theories/Logic/DecidableType.vo      theories/Logic/DecidableTypeEx.vo \
+ theories/Logic/ConstructiveEpsilon.vo
 
 ARITHVO=\
  theories/Arith/Arith.vo        theories/Arith/Gt.vo          \
@@ -756,11 +843,12 @@ ARITHVO=\
  theories/Arith/Euclid.vo       theories/Arith/Plus.vo        \
  theories/Arith/Wf_nat.vo  	theories/Arith/Max.vo	      \
  theories/Arith/Bool_nat.vo	theories/Arith/Factorial.vo   \
-# theories/Arith/Div.vo 
+ theories/Arith/Arith_base.vo 
 
 SORTINGVO=\
  theories/Sorting/Heap.vo	theories/Sorting/Permutation.vo \
- theories/Sorting/Sorting.vo
+ theories/Sorting/Sorting.vo	theories/Sorting/PermutSetoid.vo \
+ theories/Sorting/PermutEq.vo
  
 BOOLVO=\
  theories/Bool/Bool.vo  	theories/Bool/IfProp.vo \
@@ -770,7 +858,9 @@ BOOLVO=\
 
 NARITHVO=\
  theories/NArith/BinPos.vo	theories/NArith/Pnat.vo \
- theories/NArith/BinNat.vo	theories/NArith/NArith.vo
+ theories/NArith/BinNat.vo	theories/NArith/NArith.vo \
+ theories/NArith/Nnat.vo	theories/NArith/Ndigits.vo \
+ theories/NArith/Ndec.vo	theories/NArith/Ndist.vo 
 
 ZARITHVO=\
  theories/ZArith/BinInt.vo      theories/ZArith/Wf_Z.vo \
@@ -778,18 +868,29 @@ ZARITHVO=\
  theories/ZArith/auxiliary.vo   theories/ZArith/Zmisc.vo \
  theories/ZArith/Zcompare.vo    theories/ZArith/Znat.vo \
  theories/ZArith/Zorder.vo      theories/ZArith/Zabs.vo \
- theories/ZArith/Zmin.vo        theories/ZArith/Zeven.vo \
+ theories/ZArith/Zmin.vo        theories/ZArith/Zmax.vo \
+ theories/ZArith/Zminmax.vo     theories/ZArith/Zeven.vo \
  theories/ZArith/Zhints.vo	theories/ZArith/Zlogarithm.vo \
  theories/ZArith/Zpower.vo 	theories/ZArith/Zcomplements.vo \
  theories/ZArith/Zdiv.vo	theories/ZArith/Zsqrt.vo \
  theories/ZArith/Zwf.vo		theories/ZArith/ZArith_base.vo \
  theories/ZArith/Zbool.vo	theories/ZArith/Zbinary.vo \
- theories/ZArith/Znumtheory.vo
+ theories/ZArith/Znumtheory.vo  theories/ZArith/Int.vo \
+ theories/ZArith/Zpow_def.vo
+
+QARITHVO=\
+ theories/QArith/QArith_base.vo theories/QArith/Qreduction.vo \
+ theories/QArith/Qring.vo       theories/QArith/Qreals.vo \
+ theories/QArith/QArith.vo	theories/QArith/Qcanon.vo 
 
 LISTSVO=\
  theories/Lists/MonoList.vo \
  theories/Lists/ListSet.vo   	theories/Lists/Streams.vo \
- theories/Lists/TheoryList.vo   theories/Lists/List.vo
+ theories/Lists/TheoryList.vo   theories/Lists/List.vo \
+ theories/Lists/SetoidList.vo   theories/Lists/ListTactics.vo
+
+STRINGSVO=\
+ theories/Strings/Ascii.vo      theories/Strings/String.vo
 
 SETSVO=\
  theories/Sets/Classical_sets.vo    theories/Sets/Permut.vo \
@@ -804,11 +905,35 @@ SETSVO=\
  theories/Sets/Multiset.vo          theories/Sets/Relations_3_facts.vo \
  theories/Sets/Partial_Order.vo     theories/Sets/Uniset.vo
 
+FSETSBASEVO=\
+ theories/FSets/OrderedType.vo \
+ theories/FSets/OrderedTypeEx.vo     theories/FSets/OrderedTypeAlt.vo \
+ theories/FSets/FSetInterface.vo     theories/FSets/FSetList.vo \
+ theories/FSets/FSetBridge.vo        theories/FSets/FSetFacts.vo \
+ theories/FSets/FSetProperties.vo    theories/FSets/FSetEqProperties.vo \
+ theories/FSets/FSets.vo             theories/FSets/FSetWeakProperties.vo \
+ theories/FSets/FSetWeakInterface.vo theories/FSets/FSetWeakList.vo \
+ theories/FSets/FSetWeakFacts.vo     theories/FSets/FSetWeak.vo \
+ theories/FSets/FMapInterface.vo     theories/FSets/FMapList.vo \
+ theories/FSets/FMaps.vo             theories/FSets/FMapFacts.vo \
+ theories/FSets/FMapWeakFacts.vo \
+ theories/FSets/FMapWeakInterface.vo theories/FSets/FMapWeakList.vo \
+ theories/FSets/FMapWeak.vo          theories/FSets/FMapPositive.vo \
+ theories/FSets/FMapIntMap.vo        theories/FSets/FSetToFiniteSet.vo
+
+FSETS_basic=
+
+FSETS_all=\
+ theories/FSets/FMapAVL.vo           theories/FSets/FSetAVL.vo \
+
+FSETSVO=$(FSETSBASEVO) $(FSETS_$(FSETS))
+
+ALLFSETS=$(FSETSBASEVO) $(FSETS_all)
+
 INTMAPVO=\
  theories/IntMap/Adalloc.vo    theories/IntMap/Mapcanon.vo \
- theories/IntMap/Addec.vo      theories/IntMap/Mapcard.vo \
- theories/IntMap/Addr.vo       theories/IntMap/Mapc.vo \
- theories/IntMap/Adist.vo      theories/IntMap/Mapfold.vo \
+ theories/IntMap/Mapfold.vo \
+ theories/IntMap/Mapcard.vo    theories/IntMap/Mapc.vo \
  theories/IntMap/Allmaps.vo    theories/IntMap/Mapiter.vo \
  theories/IntMap/Fset.vo       theories/IntMap/Maplists.vo \
  theories/IntMap/Lsort.vo      theories/IntMap/Mapsubset.vo \
@@ -834,14 +959,15 @@ WELLFOUNDEDVO=\
  theories/Wellfounded/Lexicographic_Product.vo 
 
 REALSBASEVO=\
- theories/Reals/Rdefinitions.vo \
+ theories/Reals/Rdefinitions.vo theories/Reals/Rpow_def.vo \
  theories/Reals/Raxioms.vo      theories/Reals/RIneq.vo \
  theories/Reals/DiscrR.vo       theories/Reals/Rbase.vo \
+ theories/Reals/LegacyRfield.vo
 
 REALS_basic= 
 
 REALS_all=\
- theories/Reals/R_Ifp.vo \
+ theories/Reals/R_Ifp.vo        theories/Reals/Rpow_def.vo \
  theories/Reals/Rbasic_fun.vo   theories/Reals/R_sqr.vo \
  theories/Reals/SplitAbsolu.vo  theories/Reals/SplitRmult.vo \
  theories/Reals/ArithProp.vo    theories/Reals/Rfunctions.vo \
@@ -870,28 +996,30 @@ REALS_all=\
 REALSVO=$(REALSBASEVO) $(REALS_$(REALS))
 
 ALLREALS=$(REALSBASEVO) $(REALS_all)
-ALLOLDREALS=$(REALSBASEVO:theories%.vo:theories7%.vo) $(REALS_all:theories%.vo:theories7%.vo)
 
 SETOIDSVO=theories/Setoids/Setoid.vo
 
 THEORIESVO =\
   $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) $(NARITHVO) $(ZARITHVO) \
-  $(LISTSVO) $(SETSVO) $(INTMAPVO) $(RELATIONSVO) $(WELLFOUNDEDVO) \
-  $(REALSVO) $(SETOIDSVO) $(SORTINGVO)
+  $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) $(INTMAPVO) \
+  $(RELATIONSVO) $(WELLFOUNDEDVO) $(REALSVO)  $(SORTINGVO) $(QARITHVO)
 
-NEWTHEORIESLIGHTVO = $(INITVO) $(LOGICVO) $(ARITHVO)
-OLDTHEORIESLIGHTVO = $(NEWTHEORIESLIGHTVO:theories%.vo:theories7%.vo)
+THEORIESLIGHTVO = $(INITVO) $(LOGICVO) $(ARITHVO)
 
 theories: $(THEORIESVO)
-theories-light: $(NEWTHEORIESLIGHTVO)
+theories-light: $(THEORIESLIGHTVO)
 
 logic: $(LOGICVO)
 arith: $(ARITHVO)
 bool: $(BOOLVO)
 narith: $(NARITHVO)
 zarith: $(ZARITHVO)
-lists: $(LISTVO) $(LISTSVO)
+qarith: $(QARITHVO)
+lists: $(LISTSVO)
+strings: $(STRINGSVO)
 sets: $(SETSVO)
+fsets: $(FSETSVO)
+allfsets: $(ALLFSETS)
 intmap: $(INTMAPVO)
 relations: $(RELATIONSVO)
 wellfounded: $(WELLFOUNDEDVO)
@@ -901,8 +1029,8 @@ allreals: $(ALLREALS)
 setoids: $(SETOIDSVO)
 sorting: $(SORTINGVO)
 
-noreal: logic arith bool zarith lists sets intmap relations wellfounded \
-	setoids sorting
+noreal: logic arith bool zarith qarith lists sets fsets intmap relations \
+	wellfounded setoids sorting
 
 ###########################################################################
 # contribs (interface not included)
@@ -915,16 +1043,26 @@ ROMEGAVO=\
  contrib/romega/ReflOmegaCore.vo contrib/romega/ROmega.vo 
 
 RINGVO=\
- contrib/ring/ArithRing.vo      contrib/ring/Ring_normalize.vo \
- contrib/ring/Ring_theory.vo    contrib/ring/Ring.vo \
- contrib/ring/NArithRing.vo     \
- contrib/ring/ZArithRing.vo     contrib/ring/Ring_abstract.vo \
- contrib/ring/Quote.vo		contrib/ring/Setoid_ring_normalize.vo \
- contrib/ring/Setoid_ring.vo	contrib/ring/Setoid_ring_theory.vo
+ contrib/ring/LegacyArithRing.vo      	contrib/ring/Ring_normalize.vo \
+ contrib/ring/LegacyRing_theory.vo	contrib/ring/LegacyRing.vo \
+ contrib/ring/LegacyNArithRing.vo     \
+ contrib/ring/LegacyZArithRing.vo	contrib/ring/Ring_abstract.vo \
+ contrib/ring/Quote.vo			contrib/ring/Setoid_ring_normalize.vo \
+ contrib/ring/Setoid_ring.vo		contrib/ring/Setoid_ring_theory.vo
 
 FIELDVO=\
- contrib/field/Field_Compl.vo     contrib/field/Field_Theory.vo \
- contrib/field/Field_Tactic.vo    contrib/field/Field.vo
+ contrib/field/LegacyField_Compl.vo     contrib/field/LegacyField_Theory.vo \
+ contrib/field/LegacyField_Tactic.vo    contrib/field/LegacyField.vo
+
+NEWRINGVO=\
+ contrib/setoid_ring/BinList.vo   	contrib/setoid_ring/Ring_theory.vo \
+ contrib/setoid_ring/Ring_polynom.vo	contrib/setoid_ring/Ring_tac.vo \
+ contrib/setoid_ring/Ring_base.vo 	contrib/setoid_ring/InitialRing.vo \
+ contrib/setoid_ring/Ring_equiv.vo 	contrib/setoid_ring/Ring.vo \
+ contrib/setoid_ring/ArithRing.vo	contrib/setoid_ring/NArithRing.vo \
+ contrib/setoid_ring/ZArithRing.vo \
+ contrib/setoid_ring/Field_theory.vo	contrib/setoid_ring/Field_tac.vo \
+ contrib/setoid_ring/Field.vo		contrib/setoid_ring/RealField.vo
 
 XMLVO= 
 
@@ -933,19 +1071,29 @@ FOURIERVO=\
 
 FUNINDVO= 
 
+RECDEFVO=contrib/recdef/Recdef.vo
+
 JPROVERVO= 
 
-CCVO=\
- contrib/cc/CCSolve.vo
+CCVO=
+
+SUBTACVO=contrib/subtac/Utils.vo contrib/subtac/FixSub.vo contrib/subtac/Subtac.vo \
+       contrib/subtac/FunctionalExtensionality.vo
+
+RTAUTOVO = \
+ contrib/rtauto/Bintree.vo contrib/rtauto/Rtauto.vo
 
 CONTRIBVO = $(OMEGAVO) $(ROMEGAVO) $(RINGVO) $(FIELDVO) $(XMLVO) \
-	    $(FOURIERVO) $(JPROVERVO) $(CCVO) $(FUNINDVO)
+	    $(FOURIERVO) $(JPROVERVO) $(CCVO) $(FUNINDVO) $(SUBTACVO) \
+	    $(RTAUTOVO) $(RECDEFVO) $(NEWRINGVO)
 
 $(CONTRIBVO): states/initial.coq
 
 contrib: $(CONTRIBVO) $(CONTRIBCMO)
 omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO)
 ring: $(RINGVO) $(RINGCMO)
+setoid_ring: $(NEWRINGVO) $(NEWRINGCMO)
+dp: $(DPCMO)
 xml: $(XMLVO) $(XMLCMO)
 extraction: $(EXTRACTIONCMO)
 field: $(FIELDVO) $(FIELDCMO)
@@ -953,40 +1101,10 @@ fourier: $(FOURIERVO) $(FOURIERCMO)
 jprover: $(JPROVERVO) $(JPROVERCMO)
 funind: $(FUNINDCMO) $(FUNINDVO)
 cc: $(CCVO) $(CCCMO)
+subtac: $(SUBTACVO) $(SUBTACCMO)
+rtauto: $(RTAUTOVO) $(RTAUTOCMO)
 
-NEWINITVO=$(INITVO)
-NEWTHEORIESVO=$(THEORIESVO)
-NEWCONTRIBVO=$(CONTRIBVO)
-
-OBSOLETETHEORIESVO=\
- theories7/Lists/PolyList.vo theories7/Lists/PolyListSyntax.vo \
- theories7/ZArith/Zsyntax.vo \
- theories7/ZArith/zarith_aux.vo	theories7/ZArith/fast_integer.vo \
- theories7/Reals/Rsyntax.vo
-
-OLDINITVO=$(INITVO:theories%.vo=theories7%.vo)
-OLDTHEORIESVO=$(THEORIESVO:theories%.vo=theories7%.vo) $(OBSOLETETHEORIESVO)
-OLDCONTRIBVO=$(CONTRIBVO:contrib%.vo=contrib7%.vo)
-
-$(OLDCONTRIBVO): states7/initial.coq
-
-NEWINITV=$(INITVO:%.vo=%.v)
-NEWTHEORIESV=$(THEORIESVO:%.vo=%.v)
-NEWCONTRIBV=$(CONTRIBVO:%.vo=%.v)
-
-# Made *.vo and new*.v targets explicit, otherwise "make" 
-# either removes them after use or don't do them (e.g. List.vo)
-newinit:: $(NEWINITV) $(NEWINITVO)
-newtheories:: $(NEWTHEORIESV) $(NEWTHEORIESVO)
-newcontrib:: $(NEWCONTRIBV) $(NEWCONTRIBVO) $(CONTRIBCMO)
-
-theories7:: $(OLDTHEORIESVO)
-contrib7:: $(OLDCONTRIBVO) 
-
-translation:: $(NEWTHEORIESV) $(NEWCONTRIBV)
-
-ALLNEWVO = $(INITVO) $(THEORIESVO) $(CONTRIBVO)
-ALLOLDVO = $(OLDINITVO) $(OLDTHEORIESVO) $(OLDCONTRIBVO)
+ALLVO = $(INITVO) $(THEORIESVO) $(CONTRIBVO)
 
 ###########################################################################
 # rules to make theories, contrib and states
@@ -994,23 +1112,8 @@ ALLOLDVO = $(OLDINITVO) $(OLDTHEORIESVO) $(OLDCONTRIBVO)
 
 SYNTAXPP=syntax/PPConstr.v syntax/PPCases.v
 
-states7/barestate.coq: $(SYNTAXPP) $(BESTCOQTOP)
-	$(BESTCOQTOP) -v7 -boot -batch -silent -nois -I syntax -load-vernac-source syntax/MakeBare.v -outputstate $@
-
-states7/initial.coq: states7/barestate.coq states7/MakeInitial.v $(OLDINITVO) $(BESTCOQTOP)
-	$(BOOTCOQTOP) -v7 -batch -silent -is states7/barestate.coq -load-vernac-source states7/MakeInitial.v -outputstate states7/initial.coq
-
-states/initial.coq: states/MakeInitial.v $(NEWINITVO)
-	$(BOOTCOQTOP) -batch -silent -nois -load-vernac-source states/MakeInitial.v -outputstate states/initial.coq
-
-theories7/Init/%.vo: $(BESTCOQTOP) theories7/Init/%.v
-	$(BOOTCOQTOP) $(TRANSLATE) -nois -compile theories7/Init/$*
-
-theories7/%.vo: theories7/%.v states7/initial.coq
-	$(BOOTCOQTOP) $(TRANSLATE) -compile theories7/$*
-
-contrib7/%.vo: contrib7/%.v states7/initial.coq
-	$(BOOTCOQTOP) $(TRANSLATE) -compile contrib7/$*
+states/initial.coq: states/MakeInitial.v $(INITVO)
+	$(BOOTCOQTOP) -batch -notop -silent -nois -load-vernac-source states/MakeInitial.v -outputstate states/initial.coq
 
 theories/Init/%.vo: $(BESTCOQTOP) theories/Init/%.v
 	$(BOOTCOQTOP) -nois -compile theories/Init/$*
@@ -1021,16 +1124,14 @@ theories/%.vo: theories/%.v states/initial.coq
 contrib/%.vo: contrib/%.v
 	$(BOOTCOQTOP) -compile contrib/$*
 
-contrib/extraction/%.vo: contrib/extraction/%.v states/barestate.coq $(COQC)
-	$(BOOTCOQTOP) -is states/barestate.coq -compile $*
+cleantheories:
+	rm -f states/*.coq
+	rm -f theories/*/*.vo
 
-contrib7/extraction/%.vo: contrib7/extraction/%.v states/barestate.coq $(COQC)
-	$(BOOTCOQTOP) $(TRANSLATE) -is states7/barestate.coq -compile $*
+clean :: cleantheories
 
-clean::
-	rm -f states/*.coq states7/*.coq
-	rm -f theories/*/*.vo theories7/*/*.vo
-	rm -f contrib/*/*.cm[io] contrib/*.cma contrib/*/*.vo contrib7/*/*.vo 
+clean :: 
+	rm -f contrib/*/*.cm[io] contrib/*.cma contrib/*/*.vo
 
 archclean::
 	rm -f contrib/*/*.cmx contrib/*.cmxa contrib/*.a contrib/*/*.[so]
@@ -1056,13 +1157,17 @@ COQDOC=bin/coqdoc$(EXE)
 TOOLS=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) \
       $(COQWC) $(COQDOC)
 
-tools:: $(TOOLS) dev/top_printers.cmo
+DEBUGPRINTERS=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma
+
+printers: $(DEBUGPRINTERS)
+
+tools:: $(TOOLS) $(DEBUGPRINTERS)
 
 COQDEPCMO=config/coq_config.cmo tools/coqdep_lexer.cmo tools/coqdep.cmo
 
 $(COQDEP): $(COQDEPCMO)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ unix.cma $(COQDEPCMO) $(OSDEPLIBS)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ unix.cma $(COQDEPCMO) $(OSDEPLIBS)
 
 beforedepend:: tools/coqdep_lexer.ml $(COQDEP)
 
@@ -1070,39 +1175,42 @@ GALLINACMO=tools/gallina_lexer.cmo tools/gallina.cmo
 
 $(GALLINA): $(GALLINACMO)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ $(GALLINACMO)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(GALLINACMO)
 
 beforedepend:: tools/gallina_lexer.ml
 
 $(COQMAKEFILE): tools/coq_makefile.cmo
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ tools/coq_makefile.cmo
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ tools/coq_makefile.cmo
 
 $(COQTEX): tools/coq-tex.cmo
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ str.cma tools/coq-tex.cmo
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma tools/coq-tex.cmo
 
 beforedepend:: tools/coqwc.ml
 
 $(COQWC): tools/coqwc.cmo
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ tools/coqwc.cmo
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ tools/coqwc.cmo
 
 beforedepend:: tools/coqdoc/pretty.ml tools/coqdoc/index.ml
 
-COQDOCCMO=$(CONFIG) tools/coqdoc/alpha.cmo tools/coqdoc/index.cmo \
-          tools/coqdoc/output.cmo tools/coqdoc/pretty.cmo \
-	  tools/coqdoc/main.cmo
+COQDOCCMO=$(CONFIG) tools/coqdoc/cdglobals.cmo tools/coqdoc/alpha.cmo \
+	tools/coqdoc/index.cmo tools/coqdoc/output.cmo \
+	tools/coqdoc/pretty.cmo tools/coqdoc/main.cmo
 
 $(COQDOC): $(COQDOCCMO)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ str.cma unix.cma $(COQDOCCMO)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma unix.cma $(COQDOCCMO)
 
 clean::
 	rm -f tools/coqdep_lexer.ml tools/gallina_lexer.ml
 	rm -f tools/coqwc.ml
 	rm -f tools/coqdoc/pretty.ml tools/coqdoc/index.ml
 
+archclean::
+	rm -f $(TOOLS)
+
 ###########################################################################
 # minicoq
 ###########################################################################
@@ -1115,25 +1223,26 @@ MINICOQ=bin/minicoq$(EXE)
 
 $(MINICOQ): $(MINICOQCMO)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ -custom $(CMA) $(MINICOQCMO) $(OSDEPLIBS)
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(CMA) $(MINICOQCMO) $(OSDEPLIBS)
+
+archclean::
+	rm -f $(MINICOQ)
 
 ###########################################################################
 # Installation
 ###########################################################################
 
-#COQINSTALLPREFIX=
-# Can be changed for a local installation (to make packages).
-# You must NOT put a "/" at the end (Cygnus for win32 does not like "//").
+COQINSTALLPREFIX=
+  # Can be changed for a local installation (to make packages).
+  # You must NOT put a "/" at the end (Cygnus for win32 does not like "//").
 
-FULLBINDIR=$(BINDIR:'$(OLDROOT)%='$(COQINSTALLPREFIX)%)
-FULLCOQLIB=$(COQLIB:'$(OLDROOT)%='$(COQINSTALLPREFIX)%)
-FULLMANDIR=$(MANDIR:'$(OLDROOT)%='$(COQINSTALLPREFIX)%)
-FULLEMACSLIB=$(EMACSLIB:'$(OLDROOT)%='$(COQINSTALLPREFIX)%)
-FULLCOQDOCDIR=$(COQDOCDIR:'$(OLDROOT)%='$(COQINSTALLPREFIX)%)
+FULLBINDIR=$(COQINSTALLPREFIX)$(BINDIR)
+FULLCOQLIB=$(COQINSTALLPREFIX)$(COQLIB)
+FULLMANDIR=$(COQINSTALLPREFIX)$(MANDIR)
+FULLEMACSLIB=$(COQINSTALLPREFIX)$(EMACSLIB)
+FULLCOQDOCDIR=$(COQINSTALLPREFIX)$(COQDOCDIR)
 
 install-coq: install-binaries install-library install-coq-info
-install-coq8: install-binaries install-library8 install-coq-info
-install-coq7: install-binaries install-library7 install-coq-info
 install-coqlight: install-binaries install-library-light
 
 install-binaries:: install-$(BEST) install-tools
@@ -1150,44 +1259,40 @@ install-opt::
 
 install-tools::
 	$(MKDIR) $(FULLBINDIR)
+	# recopie des fichiers de style pour coqide
+	$(MKDIR) $(FULLCOQLIB)/tools/coqdoc
+	cp tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc
 	cp $(TOOLS) $(FULLBINDIR)
 
-LIBFILES=$(OLDTHEORIESVO) $(OLDCONTRIBVO)
-LIBFILESLIGHT=$(OLDTHEORIESLIGHTVO)
+LIBFILES=$(THEORIESVO) $(CONTRIBVO)
+LIBFILESLIGHT=$(THEORIESLIGHTVO)
 
-NEWLIBFILES=$(NEWTHEORIESVO) $(NEWCONTRIBVO)
-NEWLIBFILESLIGHT=$(NEWTHEORIESLIGHTVO)
+OBJECTCMA=lib/lib.cma kernel/kernel.cma library/library.cma \
+        pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
+        parsing/parsing.cma tactics/tactics.cma toplevel/toplevel.cma \
+        parsing/highparsing.cma tactics/hightactics.cma contrib/contrib.cma
 
-install-library: install-library7 install-library8
+OBJECTCMXA=$(OBJECTCMA:.cma=.cmxa)
 
-install-library8:
+install-library:
 	$(MKDIR) $(FULLCOQLIB)
-	for f in $(NEWLIBFILES); do \
+	for f in $(LIBFILES); do \
 	  $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \
 	  cp $$f $(FULLCOQLIB)/`dirname $$f`; \
         done
 	$(MKDIR) $(FULLCOQLIB)/states
 	cp states/*.coq $(FULLCOQLIB)/states
-
-install-library7:
-	$(MKDIR) $(FULLCOQLIB)
-	for f in $(LIBFILES); do \
-	  $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \
-	  cp $$f $(FULLCOQLIB)/`dirname $$f`; \
-        done
-	$(MKDIR) $(FULLCOQLIB)/states7
-	cp states7/*.coq $(FULLCOQLIB)/states7
+	$(MKDIR) $(FULLCOQLIB)/user-contrib
+	cp $(OBJECTCMA) $(OBJECTCMXA) $(FULLCOQLIB)
 
 install-library-light:
 	$(MKDIR) $(FULLCOQLIB)
-	for f in $(LIBFILESLIGHT) $(NEWLIBFILESLIGHT); do \
+	for f in $(LIBFILESLIGHT); do \
 	  $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \
 	  cp $$f $(FULLCOQLIB)/`dirname $$f`; \
         done
 	$(MKDIR) $(FULLCOQLIB)/states
 	cp states/*.coq $(FULLCOQLIB)/states
-	$(MKDIR) $(FULLCOQLIB)/states7
-	cp states7/*.coq $(FULLCOQLIB)/states7
 
 install-allreals::
 	for f in $(ALLREALS); do \
@@ -1215,7 +1320,7 @@ install-emacs:
 
 install-latex:
 	$(MKDIR) $(FULLCOQDOCDIR)
-	cp tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR)
+	cp tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR)	
 #	-$(UPDATETEX)
 
 ###########################################################################
@@ -1225,22 +1330,34 @@ install-latex:
 
 .PHONY: doc
 
-doc: doc/coq.tex
-	$(MAKE) -C doc coq.ps minicoq.dvi
+doc: glob.dump
+	(cd doc; $(MAKE) all)
 
-doc/coq.tex:
-	ocamlweb -p "\usepackage{epsfig}" \
-	doc/macros.tex doc/intro.tex \
-	lib/{doc.tex,*.mli} kernel/{doc.tex,*.mli} library/{doc.tex,*.mli} \
-	pretyping/{doc.tex,*.mli} interp/{doc.tex,*.mli} \
-	parsing/{doc.tex,*.mli} proofs/{doc.tex,tacexpr.ml,*.mli} \
-	tactics/{doc.tex,*.mli} toplevel/{doc.tex,vernacexpr.ml,*.mli} \
-	-o doc/coq.tex
+clean::
+	(cd doc; $(MAKE) clean)
 
 clean::
 	rm -f doc/coq.tex
 
 ###########################################################################
+# Documentation of the source code (using ocamldoc)
+###########################################################################
+
+SOURCEDOCDIR=dev/source-doc
+
+.PHONY: source-doc
+
+source-doc:
+	if !(test -d $(SOURCEDOCDIR)); then mkdir $(SOURCEDOCDIR); fi
+	$(OCAMLDOC) -html -rectypes $(LOCALINCLUDES) -d $(SOURCEDOCDIR) `find . -name "*.ml"`
+
+clean::
+	rm -rf $(SOURCEDOCDIR)
+
+
+
+
+###########################################################################
 # Emacs tags
 ###########################################################################
 
@@ -1277,60 +1394,121 @@ otags:
 
 # grammar modules with camlp4
 
-ML4FILES += parsing/lexer.ml4 parsing/q_util.ml4 parsing/q_coqast.ml4 \
-            parsing/g_prim.ml4 parsing/pcoq.ml4
+ML4FILES += parsing/lexer.ml4 parsing/pcoq.ml4 parsing/q_util.ml4 \
+  parsing/q_coqast.ml4 parsing/g_prim.ml4 
 
 GRAMMARNEEDEDCMO=\
-  lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bignat.cmo \
-  lib/dyn.cmo lib/options.cmo \
-  lib/hashcons.cmo lib/predicate.cmo lib/rtree.cmo \
-  kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo kernel/term.cmo \
-  kernel/sign.cmo kernel/declarations.cmo kernel/environ.cmo\
+  lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bigint.cmo \
+  lib/dyn.cmo lib/options.cmo lib/hashcons.cmo lib/predicate.cmo \
+  lib/rtree.cmo \
+  kernel/names.cmo kernel/univ.cmo \
+  kernel/esubst.cmo kernel/term.cmo kernel/mod_subst.cmo kernel/sign.cmo \
+  kernel/cbytecodes.cmo kernel/copcodes.cmo kernel/cemitcodes.cmo \
+  kernel/declarations.cmo kernel/pre_env.cmo \
+  kernel/cbytegen.cmo kernel/conv_oracle.cmo kernel/environ.cmo \
+  kernel/closure.cmo kernel/reduction.cmo kernel/type_errors.cmo\
+  kernel/entries.cmo \
+  kernel/modops.cmo \
+  kernel/inductive.cmo kernel/typeops.cmo \
+  kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \
+  kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo \
   library/nameops.cmo library/libnames.cmo library/summary.cmo \
   library/nametab.cmo library/libobject.cmo library/lib.cmo \
-  library/goptions.cmo library/decl_kinds.cmo \
-  pretyping/rawterm.cmo pretyping/pattern.cmo pretyping/evd.cmo \
-  interp/topconstr.cmo interp/genarg.cmo \
-  interp/ppextend.cmo parsing/coqast.cmo parsing/ast.cmo \
-  proofs/tacexpr.cmo parsing/ast.cmo \
-  parsing/lexer.cmo parsing/q_util.cmo parsing/extend.cmo \
-  toplevel/vernacexpr.cmo parsing/pcoq.cmo parsing/q_coqast.cmo \
-  parsing/egrammar.cmo
+  library/goptions.cmo library/decl_kinds.cmo library/global.cmo \
+  pretyping/termops.cmo pretyping/evd.cmo pretyping/reductionops.cmo \
+  pretyping/inductiveops.cmo pretyping/rawterm.cmo pretyping/detyping.cmo \
+  pretyping/pattern.cmo \
+  interp/topconstr.cmo interp/genarg.cmo interp/ppextend.cmo \
+  proofs/tacexpr.cmo \
+  parsing/lexer.cmo parsing/extend.cmo \
+  toplevel/vernacexpr.cmo parsing/pcoq.cmo parsing/q_util.cmo \
+  parsing/q_coqast.cmo 
 
 CAMLP4EXTENSIONSCMO=\
   parsing/argextend.cmo parsing/tacextend.cmo parsing/vernacextend.cmo 
 
 GRAMMARSCMO=\
   parsing/g_prim.cmo parsing/g_tactic.cmo \
-  parsing/g_ltac.cmo parsing/g_constr.cmo \
-  parsing/g_primnew.cmo parsing/g_tacticnew.cmo \
-  parsing/g_ltacnew.cmo parsing/g_constrnew.cmo 
+  parsing/g_ltac.cmo parsing/g_constr.cmo
 
 GRAMMARCMO=$(GRAMMARNEEDEDCMO) $(CAMLP4EXTENSIONSCMO) $(GRAMMARSCMO)
 
+PRINTERSCMO=\
+  config/coq_config.cmo lib/lib.cma \
+  kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo kernel/term.cmo	\
+  kernel/mod_subst.cmo kernel/copcodes.cmo kernel/cemitcodes.cmo	\
+  kernel/sign.cmo kernel/declarations.cmo kernel/pre_env.cmo \
+  kernel/cbytecodes.cmo kernel/cbytegen.cmo kernel/environ.cmo \
+  kernel/conv_oracle.cmo kernel/closure.cmo kernel/reduction.cmo	\
+  kernel/modops.cmo kernel/type_errors.cmo kernel/inductive.cmo		\
+  kernel/typeops.cmo kernel/subtyping.cmo kernel/indtypes.cmo		\
+  kernel/cooking.cmo 		\
+  kernel/term_typing.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo	\
+  library/summary.cmo library/global.cmo library/nameops.cmo		\
+  library/libnames.cmo library/nametab.cmo library/libobject.cmo	\
+  library/lib.cmo library/goptions.cmo \
+  pretyping/termops.cmo pretyping/evd.cmo				    \
+  pretyping/rawterm.cmo pretyping/termops.cmo pretyping/evd.cmo		    \
+  pretyping/reductionops.cmo pretyping/inductiveops.cmo			    \
+  pretyping/retyping.cmo pretyping/cbv.cmo				    \
+  pretyping/pretype_errors.cmo pretyping/recordops.cmo pretyping/typing.cmo \
+  pretyping/evarutil.cmo pretyping/unification.cmo pretyping/evarconv.cmo   \
+  pretyping/tacred.cmo pretyping/classops.cmo pretyping/detyping.cmo	    \
+  pretyping/indrec.cmo pretyping/coercion.cmo pretyping/cases.cmo	    \
+  pretyping/pretyping.cmo pretyping/clenv.cmo pretyping/pattern.cmo \
+  parsing/lexer.cmo interp/ppextend.cmo interp/genarg.cmo \
+  interp/topconstr.cmo interp/notation.cmo interp/reserve.cmo		\
+  library/impargs.cmo\
+  interp/constrextern.cmo interp/syntax_def.cmo interp/constrintern.cmo	\
+  proofs/proof_trees.cmo proofs/logic.cmo proofs/refiner.cmo \
+  proofs/tacexpr.cmo \
+  proofs/evar_refiner.cmo proofs/pfedit.cmo proofs/tactic_debug.cmo \
+  proofs/decl_mode.cmo \
+  parsing/ppconstr.cmo parsing/extend.cmo parsing/pcoq.cmo \
+  parsing/printer.cmo parsing/pptactic.cmo \
+  parsing/ppdecl_proof.cmo \
+  parsing/tactic_printer.cmo \
+  parsing/egrammar.cmo toplevel/himsg.cmo \
+  toplevel/cerrors.cmo toplevel/vernacexpr.cmo toplevel/vernacinterp.cmo \
+  dev/top_printers.cmo
+
+dev/printers.cma: $(PRINTERSCMO)
+	$(SHOW)'Testing $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) gramlib.cma $(PRINTERSCMO) -o test-printer
+	@rm -f test-printer
+	$(SHOW)'OCAMLC -a $@'   
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(PRINTERSCMO) -linkall -a -o $@
+
 parsing/grammar.cma: $(GRAMMARCMO)
+	$(SHOW)'Testing $@'
+	@touch test.ml4
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) $(GRAMMARCMO) -impl" -impl test.ml4 -o test-grammar
+	@rm -f test-grammar test.*
 	$(SHOW)'OCAMLC -a $@'   
 	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(GRAMMARCMO) -linkall -a -o $@
 
 clean::
 	rm -f parsing/grammar.cma
 
-ML4FILES +=parsing/g_basevernac.ml4 parsing/g_minicoq.ml4 \
+ML4FILES +=parsing/g_minicoq.ml4 \
 	   parsing/g_vernac.ml4 parsing/g_proofs.ml4 \
-	   parsing/g_cases.ml4 \
-	   parsing/g_constr.ml4 parsing/g_module.ml4 \
+	   parsing/g_xml.ml4 parsing/g_constr.ml4 \
 	   parsing/g_tactic.ml4 parsing/g_ltac.ml4 \
 	   parsing/argextend.ml4 parsing/tacextend.ml4 \
-	   parsing/vernacextend.ml4 \
-           parsing/g_primnew.ml4 \
-           parsing/g_vernacnew.ml4 parsing/g_proofsnew.ml4 \
-	   parsing/g_constrnew.ml4 \
-	   parsing/g_tacticnew.ml4 parsing/g_ltacnew.ml4 \
+	   parsing/vernacextend.ml4 parsing/q_constr.ml4 \
+	   parsing/g_decl_mode.ml4
+
 
 # beforedepend:: $(GRAMMARCMO)
 
 # beforedepend:: parsing/pcoq.ml parsing/extend.ml
 
+# File using pa_ifdef and only necessary for parsing ml files
+
+parsing/q_coqast.cmo: parsing/q_coqast.ml4
+	$(SHOW)'OCAMLC4  $<' 
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pa_ifdef.cmo $(CAMLP4COMPAT) -impl" -c -impl $<
+
 # toplevel/mltop.ml4 (ifdef Byte)
 
 toplevel/mltop.cmo: toplevel/mltop.byteml
@@ -1343,11 +1521,11 @@ toplevel/mltop.cmx: toplevel/mltop.optml
 
 toplevel/mltop.byteml: toplevel/mltop.ml4
 	$(SHOW)'CAMLP4O   $<'	
-	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo -DByte -impl $< > $@ || rm -f $@
+	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pa_ifdef.cmo pr_o.cmo -DByte -impl $< > $@ || rm -f $@
 
 toplevel/mltop.optml: toplevel/mltop.ml4
 	$(SHOW)'CAMLP4O   $<'	
-	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo -impl $< > $@ || rm -f $@
+	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pa_ifdef.cmo pr_o.cmo -impl $< > $@ || rm -f $@
 
 ML4FILES += toplevel/mltop.ml4
 
@@ -1380,21 +1558,27 @@ proofs/tacexpr.cmx: proofs/tacexpr.ml
 	$(SHOW)'OCAMLOPT  -rectypes $<'
 	$(HIDE)$(OCAMLOPT) -rectypes $(OPTFLAGS) -c $<
 
-# files compiled with camlp4 because of macros
+parsing/pptactic.cmo: parsing/pptactic.ml
+	$(SHOW)'OCAMLC    -rectypes $<'
+	$(HIDE)$(OCAMLC) -rectypes $(BYTEFLAGS) -c $<
+
+parsing/pptactic.cmx: parsing/pptactic.ml
+	$(SHOW)'OCAMLOPT    -rectypes $<'
+	$(HIDE)$(OCAMLOPT) -rectypes $(OPTFLAGS) -c $<
+
+ML4FILES += lib/pp.ml4 lib/compat.ml4
 
 lib/compat.cmo: lib/compat.ml4
 	$(SHOW)'OCAMLC4  $<' 
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) -impl" -c -impl $<
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pa_ifdef.cmo -impl" -c -impl $<
 
 lib/compat.cmx: lib/compat.ml4
 	$(SHOW)'OCAMLOPT  $<' 
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) -impl" -c -impl $<
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pa_ifdef.cmo -impl" -c -impl $<
 
 # files compiled with camlp4 because of streams syntax
 
-ML4FILES += lib/pp.ml4 			\
-         lib/compat.ml4 	       	\
-	 contrib/xml/xml.ml4		\
+ML4FILES += contrib/xml/xml.ml4		\
 	 contrib/xml/acic2Xml.ml4	\
 	 contrib/xml/proofTree2Xml.ml4	\
 	 contrib/interface/line_parser.ml4	\
@@ -1404,21 +1588,37 @@ ML4FILES += lib/pp.ml4 			\
 # Add pr_o.cmo to circumvent a useless-warning bug when preprocessed with
 # ast-based camlp4
 
-#parsing/lexer.cmx: parsing/lexer.ml4
-#	$(SHOW)'OCAMLOPT4 $<'
-#	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4DEPS) $<` pr_o.cmo -impl" -c -impl $<
+parsing/lexer.cmx: parsing/lexer.ml4
+	$(SHOW)'OCAMLOPT4 $<'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4DEPS) $<` pr_o.cmo -impl" -c -impl $<
+
+parsing/lexer.cmo: parsing/lexer.ml4
+	$(SHOW)'OCAMLC4   $<'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4DEPS) $<` pr_o.cmo -impl" -c -impl $<
+
+# pretty printing of the revision number when compiling a checked out
+# source tree
+.PHONY: revision
 
-#parsing/lexer.cmo: parsing/lexer.ml4
-#	$(SHOW)'OCAMLC4   $<'
-#	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4DEPS) $<` pr_o.cmo -impl" -c -impl $<
+revision:
+ifeq ($(CHECKEDOUT),1)
+	- /bin/rm -f revision
+	sed -ne '/url/s/^.*\/\([^\/"]\{1,\}\)"$$/\1/p' .svn/entries > revision
+	sed -ne '/revision/s/^.*"\([0-9]\{1,\}\)".*$$/r\1/p' .svn/entries >> revision
+endif
 
+archclean::
+	/bin/rm -f revision
 
 
 ###########################################################################
 # Default rules
 ###########################################################################
 
-.SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly .ml4 .v .vo .el .elc
+.SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly .ml4 .v .vo .el .elc .h .c .o
+
+.c.o:
+	$(CC) -o $@ $(CFLAGS) $(CINCLUDES)  -c $<
 
 .ml.cmo:
 	$(SHOW)'OCAMLC    $<'
@@ -1434,15 +1634,15 @@ ML4FILES += lib/pp.ml4 			\
 
 .mll.ml:
 	$(SHOW)'OCAMLLEX  $<'
-	$(HIDE)ocamllex $<
+	$(HIDE)$(OCAMLLEX) $<
 
 .mly.ml:
 	$(SHOW)'OCAMLYACC $<'
-	$(HIDE)ocamlyacc $<
+	$(HIDE)$(OCAMLYACC) $<
 
 .mly.mli:
 	$(SHOW)'OCAMLYACC $<'
-	$(HIDE)ocamlyacc $<
+	$(HIDE)$(OCAMLYACC) $<
 
 .ml4.cmx:
 	$(SHOW)'OCAMLOPT4 $<'
@@ -1466,10 +1666,11 @@ ML4FILES += lib/pp.ml4 			\
 ###########################################################################
 
 archclean::
-	-rm -f bin/*
 	rm -f config/*.cmx* config/*.[soa]
 	rm -f lib/*.cmx* lib/*.[soa]
-	rm -f kernel/*.cmx* kernel/*.[soa]
+	rm -f kernel/*.cmx* kernel/*.[soa]	
+	rm -f kernel/byterun/*.o
+	rm -f kernel/byterun/libcoqrun.a
 	rm -f library/*.cmx* library/*.[soa]
 	rm -f proofs/*.cmx* proofs/*.[soa]
 	rm -f tactics/*.cmx* tactics/*.[soa]
@@ -1479,7 +1680,6 @@ archclean::
 	rm -f toplevel/*.cmx* toplevel/*.[soa]
 	rm -f ide/*.cmx* ide/*.[soa]
 	rm -f ide/utils/*.cmx* ide/utils/*.[soa]
-	rm -f translate/*.cmx* translate/*.[soa]
 	rm -f tools/*.cmx* tools/*.[soa]
 	rm -f tools/*/*.cmx* tools/*/*.[soa]
 	rm -f scripts/*.cmx* scripts/*.[soa]
@@ -1488,23 +1688,22 @@ archclean::
 clean:: archclean
 	rm -f *~ */*~ */*/*~
 	rm -f gmon.out core
-	rm -f config/*.cm[ioa]
-	rm -f lib/*.cm[ioa]
-	rm -f kernel/*.cm[ioa]
-	rm -f library/*.cm[ioa]
-	rm -f proofs/*.cm[ioa]
-	rm -f tactics/*.cm[ioa]
-	rm -f interp/*.cm[ioa]
-	rm -f parsing/*.cm[ioa] parsing/*.ppo
-	rm -f pretyping/*.cm[ioa]
-	rm -f toplevel/*.cm[ioa]
-	rm -f ide/*.cm[ioa]
-	rm -f ide/utils/*.cm[ioa]
-	rm -f translate/*.cm[ioa]
-	rm -f tools/*.cm[ioa]
-	rm -f tools/*/*.cm[ioa]
-	rm -f scripts/*.cm[ioa]
-	rm -f dev/*.cm[ioa]
+	rm -f config/*.cm[ioa] config/*.annot
+	rm -f lib/*.cm[ioa] lib/*.annot
+	rm -f kernel/*.cm[ioa] kernel/*.annot
+	rm -f library/*.cm[ioa] library/*.annot
+	rm -f proofs/*.cm[ioa] proofs/*.annot
+	rm -f tactics/*.cm[ioa] tactics/*.annot
+	rm -f interp/*.cm[ioa] interp/*.annot
+	rm -f parsing/*.cm[ioa] parsing/*.ppo parsing/*.annot
+	rm -f pretyping/*.cm[ioa] pretyping/*.annot
+	rm -f toplevel/*.cm[ioa] toplevel/*.annot
+	rm -f ide/*.cm[ioa] ide/*.annot
+	rm -f ide/utils/*.cm[ioa] ide/utils/*.annot
+	rm -f tools/*.cm[ioa] tools/*.annot
+	rm -f tools/*/*.cm[ioa] tools/*/*.annot
+	rm -f scripts/*.cm[ioa] scripts/*.annot
+	rm -f dev/*.cm[ioa] dev/*.annot
 	rm -f */*.pp[iox] contrib/*/*.pp[iox]
 
 cleanconfig::
@@ -1518,9 +1717,7 @@ alldepend: depend dependcoq
 
 dependcoq:: beforedepend
 	$(COQDEP) -coqlib . -R theories Coq -R contrib Coq $(COQINCLUDES) \
-	 $(ALLREALS:.vo=.v) $(ALLNEWVO:.vo=.v) > .depend.coq
-	$(COQDEP) -coqlib . -R theories7 Coq -R contrib7 Coq $(COQINCLUDES) \
-	 $(ALLOLDREALS:.vo=.v) $(ALLOLDVO:.vo=.v) > .depend.coq7
+	 $(ALLFSETS:.vo=.v) $(ALLREALS:.vo=.v) $(ALLVO:.vo=.v) > .depend.coq
 
 # Build dependencies ignoring failures in building ml files from ml4 files
 # This is useful to rebuild dependencies when they are strongly corrupted:
@@ -1528,6 +1725,7 @@ dependcoq:: beforedepend
 # .ml4 files not using fancy parsers. This is sufficient to get beforedepend
 # and depend targets successfully built
 scratchdepend:: dependp4
+	$(OCAMLDEP) $(DEPFLAGS) */*.mli */*/*.mli */*.ml */*/*.ml > .depend
 	-$(MAKE) -k -f Makefile.dep $(ML4FILESML)
 	$(OCAMLDEP) $(DEPFLAGS) */*.mli */*/*.mli */*.ml */*/*.ml > .depend
 	$(MAKE) depend
@@ -1562,9 +1760,11 @@ depend: beforedepend dependp4 ml4filesml
 	  printf "%s" `dirname $$f`/`basename $$f .ml4`".cmx: " >> .depend; \
 	  echo `$(CAMLP4DEPS) $$f` >> .depend; \
 	done
-# 5. Finally, we erase the generated .ml files
+# 5.  We express dependencies of .o files
+	$(CC) -MM $(CINCLUDES) kernel/byterun/*.c >> .depend
+# 6. Finally, we erase the generated .ml files
 	rm -f $(ML4FILESML)
-# 6. Since .depend contains correct dependencies .depend.devel can be deleted
+# 7. Since .depend contains correct dependencies .depend.devel can be deleted
 # (see dev/Makefile.dir for details about this file)
 	if [ -e makefile ]; then >.depend.devel; else rm -f .depend.devel; fi
 
@@ -1578,15 +1778,12 @@ clean::
 devel:	
 	touch .depend.devel
 	$(MAKE) -f dev/Makefile.devel setup-devel
-	$(MAKE) dev/top_printers.cmo
+	$(MAKE) $(DEBUGPRINTERS)
 
-include .depend
-include .depend.coq
-include .depend.coq7
+-include .depend
+-include .depend.coq
 
 clean::
-	rm -fr *.v8 syntax/*.v8 ide/*.v8 theories7/*/*.v8 contrib7/*/*.v8
 	find . -name "\.#*" -exec rm -f {} \;
-	find . -name "*~" -exec rm -f {} \;
 
 ###########################################################################
diff --git a/Makefile.dep b/Makefile.dep
index 30690fac..93ca6dfa 100644
--- a/Makefile.dep
+++ b/Makefile.dep
@@ -12,4 +12,4 @@ include Makefile
 include .depend.camlp4
 
 .ml4.ml:
-	$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4DEPS) $<` -impl $< > $@ || rm -f $@
+	$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pa_ifdef.cmo pr_o.cmo `$(CAMLP4DEPS) $<` $(CAMLP4COMPAT) -impl $< > $@ || rm -f $@
diff --git a/README b/README
index f801891e..2ed855e7 100644
--- a/README
+++ b/README
@@ -1,5 +1,5 @@
 
-            		THE COQ V8.0 SYSTEM
+            		THE COQ V8.1 SYSTEM
             		===================
 
 INSTALLATION.
@@ -11,7 +11,7 @@ INSTALLATION.
 DOCUMENTATION.
 ==============
 
-   The documentation of Coq V8.0 is available by anonymous ftp (see below),
+   The documentation of Coq V8.1 is available by anonymous ftp (see below),
    in a directory doc/. It is also available on Coq web site at
    http://coq.inria.fr/doc-eng.html.
 
diff --git a/README.win b/README.win
index b8cc0c17..ee64a54d 100644
--- a/README.win
+++ b/README.win
@@ -1,4 +1,4 @@
-THE COQ V8.0 SYSTEM
+THE COQ V8.1 SYSTEM
 ===================
 
     This file contains remarks specific to the windows port of Coq.
@@ -6,26 +6,7 @@ THE COQ V8.0 SYSTEM
 INSTALLATION.
 =============
 
-    The windows distribution of Coq consists of an installer that should
-    perform all installation steps. CoqIde (a GTK interface to Coq) can
-    be installed. In case the GTK runtime libraries are not installed,
-    the Coq installer can be set to make a copy of those libraries
-    within the directory of Coq.
-    However, if the files are installed but Coq does not work properly,
-    some steps can be made manually.
-    Let us assume that the installation dir was c:\coq. The following
-    environment variables must be set as:
-      set COQBIN=c:\coq\bin
-      set COQLIB=c:\coq\lib
-    On win9x systems, this is achieved by inserting the 2 lines above
-    in the autoexec.bat file of the system. On other windows systems,
-    environment variables can be configured via the System application
-    of the Control Panel. Then select the Advanced tab.
-    The .bat files in c:\coq should now launch Coq (or CoqIde).
-    The COQBIN path can also be added to the PATH. This might be a
-    bad idea if the GTK libraries of Coq's installer were installed
-    since they might conflict with already installed GTK libraries.
-
+    See the file INSTALL.win for installation procedure.
 
 COMPILATION.
 ============
@@ -34,10 +15,12 @@ COMPILATION.
     distribution. If you really need to recompile under Windows, here
     are some indications:
 
-    1- Install ocaml version 3.06 or later (mingw port preferably).
+    1- Install ocaml version 3.07 or later, Visual C++ (needed
+       for the -custom option of ocaml) and MASM (needed if you want
+       to produce a native version).
 
     2- Install a complete set of Unix utilities (used by Makefiles). 
-       See: http://www.cygwin.com/.
+       See: http://sources.redhat.com/cygwin/.
 
     3- Under cygwin, type successively
 
diff --git a/config/Makefile.template b/config/Makefile.template
index e75b8bd0..3ea7c7c9 100644
--- a/config/Makefile.template
+++ b/config/Makefile.template
@@ -24,39 +24,55 @@ LOCAL=LOCALINSTALLATION
 # LIBDIR=path where the Coq library will reside
 # MANDIR=path where to install manual pages
 # EMACSDIR=path where to put Coq's Emacs mode (coq.el)
-BINDIR='BINDIRDIRECTORY'
-COQLIB='COQLIBDIRECTORY'
-MANDIR='MANDIRDIRECTORY'
-EMACSLIB='EMACSLIBDIRECTORY'
+BINDIR="BINDIRDIRECTORY"
+COQLIB="COQLIBDIRECTORY"
+MANDIR="MANDIRDIRECTORY"
+EMACSLIB="EMACSLIBDIRECTORY"
 EMACS=EMACSCOMMAND
 
 # Path to Coq distribution
-COQTOP='COQTOPDIRECTORY'
+COQTOP=COQTOPDIRECTORY
 VERSION=COQVERSION
 
 # Directory containing Camlp4 binaries. Can be empty if camlp4 is in the PATH
-CAMLP4BIN='CAMLP4BINDIRECTORY'
+CAMLP4BIN="CAMLP4BINDIRECTORY"
 
 # Ocaml version number
 CAMLVERSION=CAMLTAG
 
+# Ocaml .h directory
+CAMLHLIB="CAMLLIBDIRECTORY"/caml
+
 # Camlp4 library directory (avoid CAMLP4LIB used on Windows)
 CAMLP4O=CAMLP4TOOL
 CAMLP4COMPAT=CAMLP4COMPATFLAGS
-MYCAMLP4LIB='CAMLP4LIBDIRECTORY'
+MYCAMLP4LIB="CAMLP4LIBDIRECTORY"
 
 # Objective-Caml compile command 
-OCAMLC=BYTECAMLC
-OCAMLOPT=NATIVECAMLC
+OCAMLC="BYTECAMLC"
+OCAMLOPT="NATIVECAMLC"
+OCAMLDEP="OCAMLDEPEXEC"
+OCAMLDOC="OCAMLDOCEXEC"
+OCAMLLEX="OCAMLLEXEXEC"
+OCAMLYACC="OCAMLYACCEXEC"
 
 # Caml link command and Caml make top command
-CAMLLINK=BYTECAMLC
-CAMLOPTLINK=NATIVECAMLC
-CAMLMKTOP=ocamlmktop
+CAMLLINK="BYTECAMLC"
+CAMLOPTLINK="NATIVECAMLC"
+CAMLMKTOP="CAMLMKTOPEXEC"
+
+# Caml flags
+CAMLFLAGS=CAMLANNOTATEFLAG
 
 # Compilation debug flag
 CAMLDEBUG=COQDEBUGFLAG
 
+# Inlining flag (inlining causes problems with ocaml < 3.09.x)
+INLINEFLAG=COQINLINEFLAG
+
+# User compilation flag
+USERFLAGS=
+
 # Compilation profile flag
 CAMLTIMEPROF=COQPROFILEFLAG
 
@@ -71,6 +87,11 @@ P4DEP=$(COQTOP)/bin/$(ARCH)/camlp4dep
 # Can be obtain by UNIX command arch
 ARCH=ARCHITECTURE
 
+# Your C compiler and co
+CC="CCEXEC"
+AR="AREXEC"
+RANLIB="RANLIBEXEC"
+
 # Supplementary libs for some systems, currently:
 #  . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket
 #  . others     : -cclib -lunix
@@ -87,7 +108,7 @@ EXE=EXECUTEEXTENSION
 MKDIR=mkdir -p
 
 # where to put the coqdoc.sty style file
-COQDOCDIR='COQDOCDIRECTORY'
+COQDOCDIR="COQDOCDIRECTORY"
 
 # command to update TeX' kpathsea database
 #MKTEXLSR=MKTEXLSRCOMMAND
@@ -98,11 +119,18 @@ COQDOCDIR='COQDOCDIRECTORY'
 # Win32 systems: true (actually strip is bogus)
 STRIP=STRIPCOMMAND
 
+# Options for fsets (all/basic)
+FSETS=FSETSOPT
+
 # Options for reals (all/basic)
 REALS=REALSOPT
 
 # CoqIde (no/byte/opt)
 HASCOQIDE=COQIDEOPT
 
+# Defining REVISION
+CHECKEDOUT=CHECKEDOUTSOURCETREE
+
 # make or sed are bogus and believe lines not terminating by a return
 # are inexistent
+
diff --git a/config/coq_config.mli b/config/coq_config.mli
index 4b780b1f..c214344e 100644
--- a/config/coq_config.mli
+++ b/config/coq_config.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq_config.mli,v 1.9.16.2 2006/01/10 17:06:23 barras Exp $ i*)
+(*i $Id: coq_config.mli 9115 2006-09-01 13:47:00Z notin $ i*)
 
 val local : bool        (* local use (no installation) *)
 
@@ -15,6 +15,7 @@ val coqlib : string     (* where the std library is installed *)
 
 val coqtop : string     (* where are the sources *)
 
+val camldir : string    (* base directory of OCaml binaries *)
 val camllib : string    (* for Dynlink *)
 
 val camlp4lib : string  (* where is the library of Camlp4 *)
@@ -26,6 +27,7 @@ val osdeplibs : string  (* OS dependant link options for ocamlc *)
 (* val defined : string list  (* options for lib/ocamlpp *) *)
 
 val version : string    (* version number of Coq *)
+val versionsi : string  (* version number of Coq\_SearchIsos *)
 val date : string       (* release date *)
 val compile_date : string (* compile date *)
 
@@ -33,3 +35,4 @@ val theories_dirs : string list
 val contrib_dirs : string list
 
 val exec_extension : string (* "" under Unix, ".exe" under MS-windows *)
+val with_geoproof : bool ref (* to (de)activate functions specific to Geoproof with Coqide *)
diff --git a/configure b/configure
index 193ebff4..471c12fd 100755
--- a/configure
+++ b/configure
@@ -6,8 +6,8 @@
 # 
 ##################################
 
-VERSION=8.0pl3
-DATE="Jan 2006"
+VERSION=8.1
+DATE="Feb. 2007"
 
 # a local which command for sh
 which () {
@@ -22,13 +22,75 @@ for i in $PATH; do
 done
 }
 
+usage () {
+    echo -e "Available options for configure are:\n"
+    echo "-help"
+    echo -e "\tDisplays this help page\n"
+    echo "-prefix <dir>"
+    echo -e "\tSet installation directory to <dir>\n"
+    echo "-local"
+    echo -e "\tSet installation directory to the current source tree\n"
+    echo "-src"
+    echo -e "\tSpecifies the source directory\n"
+    echo "-bindir"
+    echo "-libdir"
+    echo "-mandir"
+    echo -e "\tSpecifies where to install bin/lib/man files resp.\n"
+    echo "-emacslib"
+    echo "-emacs"
+    echo -e "\tSpecifies where emacs files are to be installed\n"
+    echo "-coqdocdir"
+    echo -e "\tSpecifies where Coqdoc style files are to be installed\n"
+    echo "-camldir"
+    echo -e "\tTells configure where to look for OCaml files\n"
+    echo "-arch"
+    echo -e "\tSpecifies the architecture\n"
+    echo "-opt"
+    echo -e "\tSpecifies whether or not to generate optimized executables\n"
+    echo "-fsets (all|basic)"
+    echo "-reals (all|basic)"
+    echo -e "Specifies whether or not to compile full FSets/Reals library\n"
+    echo "-coqide (opt|byte|no)"
+    echo -e "\tSpecifies whether or not to compile Coqide\n"
+    echo "-with-geoproof (yes|no)"
+    echo -e "\tSpecifies whether or not to use Geoproof binding\n"
+    echo "-with-cc <file>"
+    echo "-with-ar <file>"
+    echo "-with-ranlib <file>"
+    echo -e "\tTells configure where to find gcc/ar/ranlib executables\n"
+    echo "-byte-only"
+    echo -e "\tCompiles only bytecode version of Coq\n"
+    echo "-debug"
+    echo -e "\tAdd debugging information in the Coq executables\n"
+    echo "-profile"
+    echo -e "\tAdd profiling information in the Coq executables\n"
+    echo "-annotate"
+    echo -e "\tCompiles Coq with -dtypes option"
+}
+
+
+# Default OCaml binaries
 bytecamlc=ocamlc
 nativecamlc=ocamlopt
-camlp4o=camlp4o
+ocamlexec=ocaml
+ocamldepexec=ocamldep
+ocamldocexec=ocamldoc
+ocamllexexec=ocamllex
+ocamlyaccexec=ocamlyacc
+ocamlmktopexec=ocamlmktop
+camlp4oexec=camlp4o
+
+
 coq_debug_flag=
 coq_profile_flag=
+coq_annotate_flag=
+coq_inline_flag=
 best_compiler=opt
 
+gcc_exec=gcc
+ar_exec=ar
+ranlib_exec=ranlib
+
 local=false
 src_spec=no
 prefix_spec=no
@@ -36,18 +98,27 @@ bindir_spec=no
 libdir_spec=no
 mandir_spec=no
 emacslib_spec=no
-#emacs_spec=no
+emacs_spec=no
+camldir_spec=no
 coqdocdir_spec=no
+fsets_opt=no
+fsets=all
 reals_opt=no
 reals=all
 arch_spec=no
 coqide_spec=no
+with_geoproof=false
+
+# COQTOP=`pwd`
+COQSRC=`pwd`
 
 # Parse command-line arguments
 
 while : ; do
   case "$1" in
     "") break;;
+    -help|--help) usage
+	          exit;;
     -prefix|--prefix) prefix_spec=yes
                       prefix="$2"
 		      shift;;
@@ -64,33 +135,67 @@ while : ; do
                       libdir="$2"
 		      shift;;
     -mandir|--mandir) mandir_spec=yes
-                      mandir=$2
+                      mandir="$2"
 		      shift;;
     -emacslib|--emacslib) emacslib_spec=yes
                           emacslib="$2"
 			  shift;;
-#    -emacs |--emacs) emacs_spec=yes
-#		     emacs="$2"
-#		     shift;;
+    -emacs |--emacs) emacs_spec=yes
+		     emacs="$2"
+		     shift;;
     -coqdocdir|--coqdocdir) coqdocdir_spec=yes
 	              coqdocdir="$2"
 		      shift;;
+    -camldir|--camldir) camldir_spec=yes
+	                camldir="$2"
+			shift;;
     -arch|--arch) arch_spec=yes
                   arch=$2
 		  shift;;
     -opt|--opt) bytecamlc=ocamlc.opt
-                camlp4o=camlp4o  # can't add .opt since dyn load'll be required
+                camlp4oexec=camlp4o  # can't add .opt since dyn load'll be required
                 nativecamlc=ocamlopt.opt;;
+    -fsets|--fsets) fsets_opt=yes
+                    case "$2" in
+			yes|all) fsets=all;;
+			*) fsets=basic
+		    esac
+		    shift;;
     -reals|--reals) reals_opt=yes
-		    reals=$2
+	            case "$2" in
+			yes|all) reals=all;;
+			*) reals=basic
+		    esac
 		    shift;;
     -coqide|--coqide) coqide_spec=yes
-		      COQIDE=$2
+		      case "$2" in
+			  byte|opt) COQIDE=$2;;
+			  *) COQIDE=no
+		      esac
 		      shift;;
+    -with-geoproof|--with-geoproof) 
+	  case $2 in
+	      yes) with_geoproof=true;;
+	      no) with_geoproof=false;;
+	  esac
+	  shift;;
+    -with-cc|-with-gcc|--with-cc|--with-gcc) 
+	  gcc_spec=yes
+	  gcc_exec=$2
+	  shift;;
+    -with-ar|--with-ar) 
+	  ar_spec=yes
+	  ar_exec=$2
+	  shift;;
+    -with-ranlib|--with-ranlib) 
+	  ranlib_spec=yes
+	  ranlib_exec=$2
+	  shift;;
     -byte-only|-byteonly|--byteonly|--byte-only) best_compiler=byte;;
     -debug|--debug) coq_debug_flag=-g;;
     -profile|--profile) coq_profile_flag=-p;;
-     *) echo "Unknown option \"$1\"." 1>&2; exit 2;;
+    -annotate|--annotate) coq_annotate_flag=-dtypes;;
+    *) echo "Unknown option \"$1\"." 1>&2; usage; exit 2;;
   esac
   shift
 done
@@ -156,50 +261,74 @@ case $ARCH in
     fi
 esac
 
+# Is the source tree checked out from svn ?
+if test -e .svn/entries ; then 
+    checkedout=1
+else 
+    checkedout=0
+fi
+
 #########################################
 # Objective Caml programs
 
-CAMLC=`which $bytecamlc`
-case "$CAMLC" in
-	"") echo "$bytecamlc is not present in your path !"
-	echo "Give me manually the path to the $bytecamlc executable [/usr/local/bin by default]: "
-	read CAMLC
-	
+case $camldir_spec in
+    no) CAMLC=`which $bytecamlc`
 	case "$CAMLC" in
-		"") CAMLC=/usr/local/bin/$bytecamlc;;
-		*/ocamlc|*/ocamlc.opt) true;;
-		*/) CAMLC="${CAMLC}"$bytecamlc;;
-		*) CAMLC="${CAMLC}"/$bytecamlc;;
+	    "") echo "$bytecamlc is not present in your path !"
+		echo "Give me manually the path to the $bytecamlc executable [/usr/local/bin by default]: "
+		read CAMLC
+		
+		case "$CAMLC" in
+		    "") CAMLC=/usr/local/bin/$bytecamlc;;
+		    */ocamlc|*/ocamlc.opt) true;;
+		    */) CAMLC="${CAMLC}"$bytecamlc;;
+		    *) CAMLC="${CAMLC}"/$bytecamlc;;
+		esac
 	esac
-	bytecamlc="$CAMLC"
-	nativecamlc=`dirname "$CAMLC"`/$nativecamlc;;
+	CAMLBIN=`dirname "$CAMLC"`;;
+    yes) CAMLC=$camldir/$bytecamlc
+        
+         CAMLBIN=`dirname "$CAMLC"`
+	 bytecamlc="$CAMLC"
+	 nativecamlc=$CAMLBIN/$nativecamlc
+	 ocamlexec=$CAMLBIN/ocaml
+	 ocamldepexec=$CAMLBIN/ocamldep
+	 ocamldocexec=$CAMLBIN/ocamldoc
+	 ocamllexexec=$CAMLBIN/ocamllex
+	 ocamlyaccexec=$CAMLBIN/ocamlyacc
+	 camlmktopexec=$CAMLBIN/ocamlmktop
+	 camlp4oexec=$CAMLBIN/camlp4o
 esac
 
 if test ! -f "$CAMLC" ; then
-	echo "I can not find the executable '$CAMLC'! (Have you installed it?)"
-	echo "Configuration script failed!"
-	exit 1
+    echo "I can not find the executable '$CAMLC'! (Have you installed it?)"
+    echo "Configuration script failed!"
+    exit 1
 fi
 
-CAMLBIN=`dirname "$CAMLC"`
-CAMLVERSION=`"$CAMLC" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+# this fixes a camlp4 bug under FreeBSD
+# ("native-code program cannot do a dynamic load")
+if [ `uname -s` = "FreeBSD" ]; then camlp4oexec=$camlp4oexec.byte; fi
+
+CAMLVERSION=`"$bytecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
 
 case $CAMLVERSION in
-  1.*|2.*|3.00|3.01|3.02|3.03|3.03alpha|3.04|3.05beta|3.05|3.08.0)
+    1.*|2.*|3.00|3.01|3.02|3.03|3.03alpha|3.04|3.05beta|3.05|3.08.0)
 	echo "Your version of Objective-Caml is $CAMLVERSION."
 	if [ "$CAMLVERSION" = "3.08.0" ] ; then
-	  echo "You need Objective-Caml 3.06 or later (to the exception of 3.08.0)!"
+	    echo "You need Objective-Caml 3.06 or later (to the exception of 3.08.0)!"
 	else
-	  echo "You need Objective-Caml 3.06 or later!";
+	    echo "You need Objective-Caml 3.06 or later!"
 	fi
 	echo "Configuration script failed!"
 	exit 1;;
-  3.06|3.07*|3.08*)
-	echo "You have Objective-Caml $CAMLVERSION. Good!";;
-  ?*)
+    3.06|3.07*|3.08*)
+	echo "You have Objective-Caml $CAMLVERSION. Good!"
+	coq_inline_flag="-inline 0";;
+    ?*)
 	CAMLP4COMPAT="-loc loc" 
 	echo "You have Objective-Caml $CAMLVERSION. Good!";;
-  *)
+    *)
 	echo "I found the Objective-Caml compiler but cannot find its version number!"
 	echo "Is it installed properly ?"
 	echo "Configuration script failed!"
@@ -211,25 +340,33 @@ CAMLTAG=OCAML`echo $CAMLVERSION | sed -e "s/\([1-9]\)\.\([0-9]*\).*/\1\2/g"`
 # do we have a native compiler: test of ocamlopt and its version
 
 if [ "$best_compiler" = "opt" ] ; then
-  CAMLOPT=`which $nativecamlc`
-  case "$CAMLOPT" in
-    "") best_compiler=byte
-        echo "You have only bytecode compilation.";;
-    *) CAMLOPTVERSION=`"$CAMLOPT" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
-       if [ "$CAMLOPTVERSION" != "$CAMLVERSION" ] ; then \
-         echo "native and bytecode compilers do not have the same version!"; fi
-       echo "You have native-code compilation. Good!"
-  esac
+  if test -e `which "$nativecamlc"` ; then
+      CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+      if [ "$CAMLOPTVERSION" != "$CAMLVERSION" ] ; then
+	  echo "native and bytecode compilers do not have the same version!"; fi
+      echo "You have native-code compilation. Good!"
+  else
+      best_compiler=byte ;
+      echo "You have only bytecode compilation."
+  fi
 fi
 
-# For coqmktop
+
+# For coqmktop & bytecode compiler
 
 CAMLLIB=`"$CAMLC" -where`
 
 # Camlp4 (greatly simplified since merged with ocaml)
 
 CAMLP4BIN=${CAMLBIN}
-CAMLP4LIB=+camlp4
+
+#case $OS in
+#  Win32)
+    CAMLP4LIB=+camlp4
+# ;;
+#  *)
+#    CAMLP4LIB=${CAMLLIB}/camlp4
+#esac
 
 # OS dependent libraries
 
@@ -259,6 +396,11 @@ if test -x "${CAMLLIB}/lablgtk2" ; then
             echo "LablGtk2 found, no native threads: bytecode CoqIde will be available"
 	    COQIDE=byte
 	fi
+	if grep "class view " "${CAMLLIB}/lablgtk2/gText.mli" | grep -q "\[>" ; then
+	    LABLGTKGE26=yes;
+        else
+	    LABLGTKGE26=no
+	fi;
     else
         echo "LablGtk2 found but too old: CoqIde will not be available"
         COQIDE=no;
@@ -269,23 +411,25 @@ else
 fi
 fi
 
-if [ $COQIDE != no ] ; then
-  if grep "class view " "${CAMLLIB}/lablgtk2/gText.mli" | grep -q "\[>" ; then
-    LABLGTKGE26=yes;
-  else
-    LABLGTKGE26=no
-  fi
-fi
-
 # Tell on windows if ocaml understands cygwin or windows path formats
 
 #"$CAMLC" -o config/giveostype config/giveostype.ml
 #CAMLOSTYPE=`config/giveostype`
 #rm config/giveostype
 
-######################################
-# mktexlsr
+case $ARCH in
+    win32)
+	# true -> strip : it exists under cygwin !
+	STRIPCOMMAND="strip";; 
+    *)
+    if [ "$coq_profile_flag" = "-p" ] ; then
+	STRIPCOMMAND="true"
+    else
+	STRIPCOMMAND="strip"
+    fi
+esac
 
+# mktexlsr
 #MKTEXLSR=`which mktexlsr`
 #case $MKTEXLSR in
 #    "") MKTEXLSR=true;;
@@ -430,6 +574,11 @@ echo "  Objective-Caml/Camlp4 version     : $CAMLVERSION"
 echo "  Objective-Caml/Camlp4 binaries in : $CAMLBIN"
 echo "  Objective-Caml library in         : $CAMLLIB"
 echo "  Camlp4 library in                 : $CAMLP4LIB"
+if test "$fsets" = "all"; then
+echo "  FSets theory                      : All"
+else
+echo "  FSets theory                      : Basic"
+fi
 if test "$reals" = "all"; then
 echo "  Reals theory                      : All"
 else
@@ -451,19 +600,20 @@ echo ""
 
 # An escaped version of a variable
 escape_var () {
-ocaml 2>&1 1>/dev/null <<EOF
+"$ocamlexec" 2>&1 1>/dev/null <<EOF
   prerr_endline(String.escaped(Sys.getenv"$VAR"));;
 EOF
 }
 
-export COQTOP BINDIR LIBDIR CAMLLIB
+export COQTOP BINDIR LIBDIR CAMLBIN CAMLLIB
 ESCCOQTOP="`VAR=COQTOP escape_var`"
 ESCBINDIR="`VAR=BINDIR escape_var`"
 ESCLIBDIR="`VAR=LIBDIR escape_var`"
+ESCCAMLDIR="`VAR=CAMLBIN escape_var`"
 ESCCAMLLIB="`VAR=CAMLLIB escape_var`"
 ESCCAMLP4LIB="$ESCCAMLLIB"/camlp4
 
-mlconfig_file=$COQTOP/config/coq_config.ml
+mlconfig_file="$COQSRC/config/coq_config.ml"
 rm -f $mlconfig_file
 cat << END_OF_COQ_CONFIG > $mlconfig_file
 (* DO NOT EDIT THIS FILE: automatically generated by ../configure *)
@@ -472,15 +622,18 @@ let local = $local
 let bindir = "$ESCBINDIR" 
 let coqlib = "$ESCLIBDIR"
 let coqtop = "$ESCCOQTOP"
+let camldir = "$ESCCAMLDIR"
 let camllib = "$ESCCAMLLIB"
 let camlp4lib = "$ESCCAMLP4LIB"
 let best = "$best_compiler"
 let arch = "$ARCH"
 let osdeplibs = "$OSDEPLIBS"
 let version = "$VERSION"
+let versionsi = "$VERSIONSI"
 let date = "$DATE"
 let compile_date = "$COMPILEDATE"
 let exec_extension = "$EXE"
+let with_geoproof = ref $with_geoproof
 
 END_OF_COQ_CONFIG
 
@@ -489,27 +642,27 @@ PRINTF=`which printf`
 
 # Subdirectories of theories/ added in coq_config.ml
 subdirs () {
-    (cd $1; find * -type d ! -name CVS -exec $PRINTF "\"%s\";\n" {} \; | grep -v extraction/test | grep -v correctness >> $mlconfig_file)
+    (cd $1; find * -type d ! -name .svn -exec $PRINTF "\"%s\";\n" {} \; | grep -v extraction/test | grep -v correctness >> "$mlconfig_file")
 }
 
-echo "let theories_dirs = [" >> $mlconfig_file
+echo "let theories_dirs = [" >> "$mlconfig_file"
 subdirs theories
-echo "]" >> $mlconfig_file
+echo "]" >> "$mlconfig_file"
 
-echo "let contrib_dirs = [" >> $mlconfig_file
+echo "let contrib_dirs = [" >> "$mlconfig_file"
 subdirs contrib
-echo "]" >> $mlconfig_file
+echo "]" >> "$mlconfig_file"
 
-chmod a-w $mlconfig_file
+chmod a-w "$mlconfig_file"
 
 
 ###############################################
 # Building the $COQTOP/config/Makefile file
 ###############################################
 
-rm -f $COQTOP/config/Makefile
+rm -f "$COQSRC/config/Makefile"
 
-# damned backslashes under M$Windows
+# damned backslashes under M$Windows (bis)
 case $ARCH in
     win32)
 	ESCCOQTOP=`echo $COQTOP |sed -e 's|\\\|\\\\\\\|g'`
@@ -543,36 +696,56 @@ sed -e "s|LOCALINSTALLATION|$local|" \
     -e "s|ARCHITECTURE|$ARCH|" \
     -e "s|OSDEPENDENTLIBS|$OSDEPLIBS|" \
     -e "s|OSDEPENDENTP4OPTFLAGS|$OSDEPP4OPTFLAGS|" \
+    -e "s|CAMLLIBDIRECTORY|$ESCCAMLLIB|" \
     -e "s|CAMLTAG|$CAMLTAG|" \
     -e "s|CAMLP4BINDIRECTORY|$ESCCAMLP4BIN|" \
     -e "s|CAMLP4LIBDIRECTORY|$CAMLP4LIB|" \
-    -e "s|CAMLP4TOOL|$camlp4o|" \
+    -e "s|CAMLP4TOOL|$camlp4oexec|" \
     -e "s|CAMLP4COMPATFLAGS|$CAMLP4COMPAT|" \
     -e "s|COQDEBUGFLAG|$coq_debug_flag|" \
     -e "s|COQPROFILEFLAG|$coq_profile_flag|" \
+    -e "s|COQINLINEFLAG|$coq_inline_flag|" \
+    -e "s|CAMLANNOTATEFLAG|$coq_annotate_flag|" \
     -e "s|BESTCOMPILER|$best_compiler|" \
     -e "s|EXECUTEEXTENSION|$EXE|" \
     -e "s|BYTECAMLC|$bytecamlc|" \
     -e "s|NATIVECAMLC|$nativecamlc|" \
+    -e "s|OCAMLDEPEXEC|$ocamldepexec|" \
+    -e "s|OCAMLDOCEXEC|$ocamldocexec|" \
+    -e "s|OCAMLLEXEXEC|$ocamllexexec|" \
+    -e "s|OCAMLYACCEXEC|$ocamlyaccexec|" \
+    -e "s|CAMLMKTOPEXEC|$camlmktopexec|" \
+    -e "s|CCEXEC|$gcc_exec|" \
+    -e "s|AREXEC|$ar_exec|" \
+    -e "s|RANLIBEXEC|$ranlib_exec|" \
     -e "s|STRIPCOMMAND|$STRIPCOMMAND|" \
+    -e "s|FSETSOPT|$fsets|" \
     -e "s|REALSOPT|$reals|" \
     -e "s|COQIDEOPT|$COQIDE|" \
-      $COQTOP/config/Makefile.template > $COQTOP/config/Makefile
+    -e "s|CHECKEDOUTSOURCETREE|$checkedout|" \
+      "$COQSRC/config/Makefile.template" > "$COQSRC/config/Makefile"
 
-chmod a-w $COQTOP/config/Makefile
+chmod a-w "$COQSRC/config/Makefile"
 
 ##################################################
-# Building the $COQTOP/dev/ocamldebug-v7 file
-####################################################
+# Building the $COQTOP/dev/ocamldebug-coq file
+##################################################
+
+OCAMLDEBUGCOQ=$COQTOP/dev/ocamldebug-coq
 
 if test "$coq_debug_flag" = "-g" ; then
-  rm -f $COQTOP/dev/ocamldebug-v7
+  rm -f $OCAMLDEBUGCOQ
+  if [ "$CAMLP4LIB" = "+camlp4" ] ; then
+    CAMLP4LIBFORCAMLDEBUG=$CAMLLIB/camlp4
+  else
+    CAMLP4LIBFORCAMLDEBUG=$CAMLP4LIB
+  fi
   sed -e "s|COQTOPDIRECTORY|$COQTOP|" \
       -e "s|COQLIBDIRECTORY|$LIBDIR|" \
       -e "s|CAMLBINDIRECTORY|$CAMLBIN|" \
-      -e "s|CAMLP4LIBDIRECTORY|$CAMLLIB/camlp4|" \
-      $COQTOP/dev/ocamldebug-v7.template > $COQTOP/dev/ocamldebug-v7
-  chmod a-w,a+x $COQTOP/dev/ocamldebug-v7
+      -e "s|CAMLP4LIBDIRECTORY|$CAMLP4LIBFORCAMLDEBUG|" \
+      $OCAMLDEBUGCOQ.template > $OCAMLDEBUGCOQ
+  chmod a-w,a+x $OCAMLDEBUGCOQ
 fi
 
 ##################################################
@@ -580,7 +753,7 @@ fi
 ####################################################
 
 if [ "$LABLGTKGE26" = "yes" ] ; then
-  cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli;
+  cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli
 else
   cp -f ide/undo_lablgtk_lt26.mli ide/undo.mli
 fi
@@ -594,4 +767,4 @@ echo
 echo "*Warning* To compile the system for a new architecture"
 echo "          don't forget to do a 'make archclean' before './configure'."
 
-# $Id: configure,v 1.74.2.19 2006/01/13 11:50:07 barras Exp $
+# $Id: configure 9637 2007-02-10 08:32:28Z notin $
diff --git a/contrib/cc/CCSolve.v b/contrib/cc/CCSolve.v
deleted file mode 100644
index fab6f775..00000000
--- a/contrib/cc/CCSolve.v
+++ /dev/null
@@ -1,22 +0,0 @@
-(************************************************************************)
-(*  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: CCSolve.v,v 1.4.2.1 2004/07/16 19:29:58 herbelin Exp $ *)
-
-Ltac CCsolve :=
-  repeat
-   match goal with
-   | H:?X1 |- ?X2 =>
-       let Heq := fresh "Heq" in
-       (assert (Heq : X2 = X1); [ congruence | rewrite Heq; exact H ])
-   | H:?X1,G:(?X2 -> ?X3) |- _ =>
-       let Heq := fresh "Heq" in
-       (assert (Heq : X2 = X1);
-         [ congruence
-         | rewrite Heq in G; generalize (G H); clear G; intro G ])
-   end.  
diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml
index e73a6221..8bdae54b 100644
--- a/contrib/cc/ccalgo.ml
+++ b/contrib/cc/ccalgo.ml
@@ -6,45 +6,33 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.ml,v 1.6.2.1 2004/07/16 19:29:58 herbelin Exp $ *)
+(* $Id: ccalgo.ml 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 (* This file implements the basic congruence-closure algorithm by *)
 (* Downey,Sethi and Tarjan. *)
 
 open Util
+open Pp
+open Goptions
 open Names
 open Term
 
-let init_size=251
-
-type pa_constructor=
-    {head_constr: int;
-     arity:int;
-     nhyps:int;
-     args:int list;
-     term_head:int}
+let init_size=5
 
+let cc_verbose=ref false 
 
-module PacMap=Map.Make(struct type t=int*int let compare=compare end) 
+let debug msg (stdpp:std_ppcmds) = 
+  if !cc_verbose then msg stdpp
 
-type term=
-    Symb of constr
-  | Appli of term*term
-  | Constructor of constructor*int*int (* constructor arity+ nhyps *)
-
-type rule=
-    Congruence
-  | Axiom of identifier
-  | Injection of int*int*int*int (* terms+head+arg position *)
-
-type equality = {lhs:int;rhs:int;rule:rule}
-
-let swap eq=
-  let swap_rule=match eq.rule with
-      Congruence -> Congruence
-    | Injection (i,j,c,a) -> Injection (j,i,c,a)
-    | Axiom id -> anomaly "no symmetry for axioms"    
-  in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule}
+let _=
+  let gdopt=
+    { optsync=true;
+      optname="Congruence Verbose";
+      optkey=SecondaryTable("Congruence","Verbose"); 
+      optread=(fun ()-> !cc_verbose); 
+      optwrite=(fun b -> cc_verbose := b)}  
+  in
+    declare_bool_option gdopt
 
 (* Signature table *)
 
@@ -67,291 +55,723 @@ module ST=struct
 	Hashtbl.replace st.tosign t sign
 	  
   let query sign st=Hashtbl.find st.toterm sign
+
+  let rev_query term st=Hashtbl.find st.tosign term
 	  
-  let delete t st=
+  let delete st t=
     try let sign=Hashtbl.find st.tosign t in
 	Hashtbl.remove st.toterm sign;
 	Hashtbl.remove st.tosign t
     with
 	Not_found -> ()
 
-  let rec delete_list l st=
-    match l with
-      []->()
-    | t::q -> delete t st;delete_list q st
+  let rec delete_set st s = Intset.iter (delete st) s
 	  
 end
-    
-(* Basic Union-Find algo w/o path compression *)
-    
-module UF = struct
 
-module IndMap=Map.Make(struct type t=inductive let compare=compare end) 
+type pa_constructor=
+    { cnode : int;
+      arity : int;
+      args  : int list}
 
-  type representative=
-      {mutable nfathers:int;
-       mutable fathers:int list;
-       mutable constructors:pa_constructor PacMap.t;
-       mutable inductives:(int * int) IndMap.t}
+type pa_fun=
+    {fsym:int;
+     fnargs:int}
 
-  type cl = Rep of representative| Eqto of int*equality
+type pa_mark=
+    Fmark of pa_fun
+  | Cmark of pa_constructor
 
-  type vertex = Leaf| Node of (int*int) 
+module PacMap=Map.Make(struct 
+			 type t=pa_constructor 
+			 let compare=Pervasives.compare end) 
 
-  type node = 
-      {clas:cl;
-       vertex:vertex;
-       term:term;
-       mutable node_constr: int PacMap.t}    
+module PafMap=Map.Make(struct 
+			 type t=pa_fun
+			 let compare=Pervasives.compare end)
 
-  type t={mutable size:int;
-          map:(int,node) Hashtbl.t;
-          syms:(term,int) Hashtbl.t;
-	  sigtable:ST.t}
+type cinfo=
+    {ci_constr: constructor; (* inductive type *)
+     ci_arity: int;     (* # args *)
+     ci_nhyps: int}     (* # projectable args *)
 
-  let empty ():t={size=0;
-		  map=Hashtbl.create init_size;
-		  syms=Hashtbl.create init_size;
-		  sigtable=ST.empty ()}
+type term=
+    Symb of constr
+  | Eps
+  | Appli of term*term
+  | Constructor of cinfo (* constructor arity + nhyps *)
 
-  let rec find uf i=
-    match (Hashtbl.find uf.map i).clas with
-	Rep _ -> i
-      | Eqto (j,_) ->find uf j
-	  
-  let get_representative uf i=
-    let node=Hashtbl.find uf.map i in
-      match node.clas with
-	  Rep r ->r
-	| _ -> anomaly "get_representative: not a representative"
+type ccpattern =
+    PApp of term * ccpattern list (* arguments are reversed *)
+  | PVar of int 
 
-  let get_constructor uf i=
-    match (Hashtbl.find uf.map i).term with
-	Constructor (cstr,_,_)->cstr
-      | _ -> anomaly "get_constructor: not a constructor"
+type rule=
+    Congruence
+  | Axiom of constr * bool 
+  | Injection of int * pa_constructor * int * pa_constructor * int
 
+type from=
+    Goal
+  | Hyp of constr
+  | HeqG of constr
+  | HeqnH of constr * constr
 
-  let fathers uf i=
-    (get_representative uf i).fathers
-	  
-  let size uf i=
-    (get_representative uf i).nfathers
+type 'a eq = {lhs:int;rhs:int;rule:'a}
 
-  let add_father uf i t=
-    let r=get_representative uf i in
-      r.nfathers<-r.nfathers+1;
-      r.fathers<-t::r.fathers 
+type equality = rule eq
 
-  let pac_map uf i=
-    (get_representative uf i).constructors  
+type disequality = from eq
 
-  let pac_arity uf i sg=
-    (PacMap.find sg (get_representative uf i).constructors).arity
+type quant_eq =
+    {qe_hyp_id: identifier;
+     qe_pol: bool;
+     qe_nvars:int;
+     qe_lhs: ccpattern;
+     qe_lhs_valid:bool;
+     qe_rhs: ccpattern;
+     qe_rhs_valid:bool}
 
-  let add_node_pac uf i sg j=
-    let node=Hashtbl.find uf.map i in
-      if not (PacMap.mem sg node.node_constr) then
-	node.node_constr<-PacMap.add sg j node.node_constr 
-  
-  let mem_node_pac uf i sg= 
-    PacMap.find sg (Hashtbl.find uf.map i).node_constr
+let swap eq : equality =
+  let swap_rule=match eq.rule with
+      Congruence -> Congruence
+    | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k)
+    | Axiom (id,reversed) -> Axiom (id,not reversed)
+  in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule}
+    
+type inductive_status =
+    Unknown
+  | Partial of pa_constructor
+  | Partial_applied
+  | Total of (int * pa_constructor)
+
+type representative=
+    {mutable nfathers:int;
+     mutable lfathers:Intset.t;
+     mutable fathers:Intset.t;
+     mutable inductive_status: inductive_status;
+     mutable functions: Intset.t PafMap.t;
+     mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *)
+
+type cl = Rep of representative| Eqto of int*equality
   
-  exception Discriminable of int * int * int * int * t 
-
-  let add_pacs uf i pacs =
-    let rep=get_representative uf i in
-    let pending=ref [] and combine=ref [] in 
-    let add_pac sg pac=
-      try  
-	let opac=PacMap.find sg rep.constructors in
-	  if (snd sg)>0 then () else
-	    let tk=pac.term_head 
-	    and tl=opac.term_head in
-	    let rec f n lk ll q=
-	      if n > 0 then match (lk,ll) with
-		  k::qk,l::ql->
-		    let eq=
-		      {lhs=k;rhs=l;rule=Injection(tk,tl,pac.head_constr,n)} 
-		    in f (n-1) qk ql (eq::q) 
-		| _-> anomaly 
-		    "add_pacs : weird error in injection subterms merge"
-	      else q in
- 	      combine:=f pac.nhyps pac.args opac.args !combine
-      with Not_found -> (* Still Unknown Constructor *)
-	rep.constructors <- PacMap.add sg pac rep.constructors;
-	pending:=
-	    (fathers uf (find uf pac.term_head)) @rep.fathers@ !pending;
-	let (c,a)=sg in
-	  if a=0 then
-	    let (ind,_)=get_constructor uf c in  
-	      try
-		let th2,hc2=IndMap.find ind rep.inductives in
-		  raise (Discriminable (pac.term_head,c,th2,hc2,uf)) 
-	      with Not_found ->
-		rep.inductives<-
-		IndMap.add ind (pac.term_head,c) rep.inductives in
-      PacMap.iter add_pac pacs;
-      !pending,!combine
+type vertex = Leaf| Node of (int*int) 
+
+type node = 
+    {mutable clas:cl;
+     mutable cpath: int; 
+     vertex:vertex;
+     term:term}
+    
+type forest=
+    {mutable max_size:int;
+     mutable size:int;
+     mutable map: node array;
+     axioms: (constr,term*term) Hashtbl.t;
+     mutable epsilons: pa_constructor list;
+     syms:(term,int) Hashtbl.t}
+
+type state = 
+    {uf: forest;
+     sigtable:ST.t;
+     mutable terms: Intset.t; 
+     combine: equality Queue.t; 
+     marks: (int * pa_mark) Queue.t;
+     mutable diseq: disequality list;
+     mutable quant: quant_eq list;
+     mutable pa_classes: Intset.t;
+     q_history: (constr,unit) Hashtbl.t;
+     mutable rew_depth:int;
+     mutable changed:bool}
+
+let dummy_node =
+  {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
+   cpath=min_int;
+   vertex=Leaf;
+   term=Symb (mkRel min_int)}
+
+let empty depth:state =
+  {uf=
+     {max_size=init_size;
+      size=0;
+      map=Array.create init_size dummy_node;
+      epsilons=[];
+      axioms=Hashtbl.create init_size;
+      syms=Hashtbl.create init_size};
+  terms=Intset.empty;
+  combine=Queue.create ();
+  marks=Queue.create ();
+  sigtable=ST.empty ();
+  diseq=[];
+  quant=[];
+  pa_classes=Intset.empty;
+  q_history=Hashtbl.create init_size;
+  rew_depth=depth;
+  changed=false}
+
+let forest state = state.uf 
+       
+let compress_path uf i j = uf.map.(j).cpath<-i
+			     
+let rec find_aux uf visited i=  
+  let j = uf.map.(i).cpath in 
+    if j<0 then let _ = List.iter (compress_path uf i) visited in i else
+      find_aux uf (i::visited) j
 	
-  let term uf i=(Hashtbl.find uf.map i).term
-		  
-  let subterms uf i=
-    match (Hashtbl.find uf.map i).vertex with
-	Node(j,k) -> (j,k)
-      | _ -> anomaly "subterms: not a node"
-
-  let signature uf i=
-    let j,k=subterms uf i in (find uf j,find uf k)
-
-  let nodes uf=  (* cherche les noeuds binaires *)
-    Hashtbl.fold 
-      (fun i node l->
-	 match node.vertex with 
-	     Node (_,_)->i::l
-	   | _ ->l) uf.map [] 
-
-  let next uf=
-    let n=uf.size in uf.size<-n+1; n
+let find uf i= find_aux uf [] i
+		 
+let get_representative uf i=
+  match uf.map.(i).clas with
+      Rep r -> r
+    | _ -> anomaly "get_representative: not a representative"
+
+let find_pac uf i pac =
+  PacMap.find pac (get_representative uf i).constructors
+
+let get_constructor_info uf i=
+  match uf.map.(i).term with
+      Constructor cinfo->cinfo
+    | _ -> anomaly "get_constructor: not a constructor"
 	
-  let new_representative pm im=
-    {nfathers=0;
-     fathers=[];
-     constructors=pm;
-     inductives=im}
+let size uf i=
+  (get_representative uf i).nfathers
+
+let axioms uf = uf.axioms
+
+let epsilons uf = uf.epsilons
+
+let add_lfather uf i t=
+  let r=get_representative uf i in
+    r.nfathers<-r.nfathers+1;
+    r.lfathers<-Intset.add t r.lfathers;
+    r.fathers <-Intset.add t r.fathers
+
+let add_rfather uf i t=
+  let r=get_representative uf i in
+    r.nfathers<-r.nfathers+1;
+    r.fathers <-Intset.add t r.fathers
+
+exception Discriminable of int * pa_constructor * int * pa_constructor 
+
+let append_pac t p =
+  {p with arity=pred p.arity;args=t::p.args} 
 
-  let rec add uf t= 
+let tail_pac p=
+  {p with arity=succ p.arity;args=List.tl p.args}
+
+let fsucc paf =
+  {paf with fnargs=succ paf.fnargs}
+    
+let add_pac rep pac t =
+  if not (PacMap.mem pac rep.constructors) then
+    rep.constructors<-PacMap.add pac t rep.constructors
+
+let add_paf rep paf t =
+  let already = 
+    try PafMap.find paf rep.functions with Not_found -> Intset.empty in
+    rep.functions<- PafMap.add paf (Intset.add t already) rep.functions
+
+let term uf i=uf.map.(i).term
+		
+let subterms uf i=
+  match uf.map.(i).vertex with
+      Node(j,k) -> (j,k)
+    | _ -> anomaly "subterms: not a node"
+	
+let signature uf i=
+  let j,k=subterms uf i in (find uf j,find uf k)
+			     
+let next uf=
+  let size=uf.size in
+  let nsize= succ size in
+    if nsize=uf.max_size then
+      let newmax=uf.max_size * 3 / 2 + 1 in
+      let newmap=Array.create newmax dummy_node in
+	begin
+	  uf.max_size<-newmax;
+	  Array.blit uf.map 0 newmap 0 size;
+	  uf.map<-newmap
+	end 
+    else ();
+    uf.size<-nsize; 
+    size
+	
+let new_representative ()=
+  {nfathers=0;
+   lfathers=Intset.empty;
+   fathers=Intset.empty;
+   inductive_status=Unknown;
+   functions=PafMap.empty;
+   constructors=PacMap.empty}
+    
+(* rebuild a constr from an applicative term *)
+    
+let rec constr_of_term = function
+    Symb s->s
+  | Eps -> anomaly "epsilon constant has no value" 
+  | Constructor cinfo -> mkConstruct cinfo.ci_constr 
+  | Appli (s1,s2)->
+      make_app [(constr_of_term s2)] s1
+and make_app l=function
+    Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1    
+  | other -> applistc (constr_of_term other) l 
+
+(* rebuild a term from a pattern and a substitution *)
+
+let build_subst uf subst =
+  Array.map (fun i -> 
+	       try term uf i 
+	       with _ -> anomaly "incomplete matching") subst
+
+let rec inst_pattern subst = function
+    PVar i -> 
+      subst.(pred i) 
+  | PApp (t, args) -> 
+      List.fold_right
+	(fun spat f -> Appli (f,inst_pattern subst spat))
+	   args t  
+
+let rec add_term state t= 
+  let uf=state.uf in
     try Hashtbl.find uf.syms t with 
 	Not_found ->
 	  let b=next uf in
 	  let new_node=
 	    match t with
-		Symb s -> 
-		  {clas=Rep (new_representative PacMap.empty IndMap.empty);
-		   vertex=Leaf;term=t;node_constr=PacMap.empty}
+		Symb _ ->
+		  let paf =
+		    {fsym=b;
+		     fnargs=0} in
+		    Queue.add (b,Fmark paf) state.marks;
+		    {clas= Rep (new_representative ());
+		     cpath= -1;
+		     vertex= Leaf;
+		     term= t}
+	      | Eps -> 
+		  {clas= Rep (new_representative ());
+		   cpath= -1;
+		   vertex= Leaf;
+		   term= t}
 	      | Appli (t1,t2) -> 
-		  let i1=add uf t1 and i2=add uf t2 in
-		    add_father uf (find uf i1) b;
-		    add_father uf (find uf i2) b;
-		    {clas=Rep (new_representative PacMap.empty IndMap.empty);
-		     vertex=Node(i1,i2);term=t;node_constr=PacMap.empty}
-	      | Constructor (c,a,n) ->
-		  let pacs=
-		    PacMap.add (b,a) 
-		      {head_constr=b;arity=a;nhyps=n;args=[];term_head=b} 
-		      PacMap.empty in
-		  let inds=
-		    if a=0 then
-		      let (ind,_)=c in
-			IndMap.add ind (b,b) IndMap.empty 
-		    else IndMap.empty in
-		    {clas=Rep (new_representative pacs inds);
-		     vertex=Leaf;term=t;node_constr=PacMap.empty}
+		  let i1=add_term state t1 and i2=add_term state t2 in
+		    add_lfather uf (find uf i1) b;
+		    add_rfather uf (find uf i2) b;
+		    state.terms<-Intset.add b state.terms;
+		    {clas= Rep (new_representative ());
+		     cpath= -1;
+		     vertex= Node(i1,i2);
+		     term= t}
+	      | Constructor cinfo ->
+		  let paf =
+		    {fsym=b;
+		     fnargs=0} in
+		    Queue.add (b,Fmark paf) state.marks;
+		  let pac =
+		    {cnode= b;
+		     arity= cinfo.ci_arity;
+		     args=[]} in
+		    Queue.add (b,Cmark pac) state.marks;
+		    {clas=Rep (new_representative ());
+		     cpath= -1;
+		     vertex=Leaf;
+		     term=t}
 	  in
-	    Hashtbl.add uf.map b new_node;
+	    uf.map.(b)<-new_node;
 	    Hashtbl.add uf.syms t b;
 	    b
 
-  let link uf i j eq= (* links i -> j *)
-    let node=Hashtbl.find uf.map i in 
-      Hashtbl.replace uf.map i {node with clas=Eqto (j,eq)}
-	      
-  let union uf i1 i2 eq=
-    let r1= get_representative uf i1 
-    and r2= get_representative uf i2 in
-      link uf i1 i2 eq;
-      r2.nfathers<-r1.nfathers+r2.nfathers;
-      r2.fathers<-r1.fathers@r2.fathers;
-      add_pacs uf i2 r1.constructors 
+let add_equality state c s t=
+  let i = add_term state s in
+  let j = add_term state t in
+    Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine;
+    Hashtbl.add state.uf.axioms c (s,t)
+
+let add_disequality state from s t =
+  let i = add_term state s in
+  let j = add_term state t in
+    state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq
+
+let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
+  state.quant<-
+    {qe_hyp_id= id;
+     qe_pol= pol;
+     qe_nvars=nvars;
+     qe_lhs= patt1;
+     qe_lhs_valid=valid1;
+     qe_rhs= patt2;
+     qe_rhs_valid=valid2}::state.quant
+
+let add_inst state (inst,int_subst) = 
+  if state.rew_depth > 0 then 
+  let subst = build_subst (forest state) int_subst in
+  let prfhead= mkVar inst.qe_hyp_id in
+  let args = Array.map constr_of_term subst in
+  let _ = array_rev args in (* highest deBruijn index first *)
+  let prf= mkApp(prfhead,args) in
+    try Hashtbl.find state.q_history prf
+    with Not_found ->
+      (* this instance is new, we can go on *)
+      let s = inst_pattern subst inst.qe_lhs 
+      and t = inst_pattern subst inst.qe_rhs in
+	state.changed<-true;
+	state.rew_depth<-pred state.rew_depth;
+	if inst.qe_pol then
+	  begin
+	    debug msgnl 
+	      (str "adding new equality, depth="++ int state.rew_depth);
+	    add_equality state prf s t
+	  end
+	else
+	  begin
+	    debug msgnl (str "adding new disequality, depth="++ 
+			   int state.rew_depth);
+	    add_disequality state (Hyp prf) s t 
+	  end
+
+let link uf i j eq = (* links i -> j *)
+  let node=uf.map.(i) in 
+    node.clas<-Eqto (j,eq);
+    node.cpath<-j
 	
-  let rec down_path uf i l=
-    match (Hashtbl.find uf.map i).clas with
-	Eqto(j,t)->down_path uf j (((i,j),t)::l)
-      | Rep _ ->l
-
-  let rec min_path=function
-      ([],l2)->([],l2)
-    | (l1,[])->(l1,[])
-    | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) 
-    | cpl -> cpl
+let rec down_path uf i l=
+  match uf.map.(i).clas with
+      Eqto(j,t)->down_path uf j (((i,j),t)::l)
+    | Rep _ ->l
 	
-  let join_path uf i j=
-    assert (find uf i=find uf j);
-    min_path (down_path uf i [],down_path uf j [])
+let rec min_path=function
+    ([],l2)->([],l2)
+  | (l1,[])->(l1,[])
+  | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) 
+  | cpl -> cpl
       
-end    
-    
-let rec combine_rec uf=function 
-    []->[]
-  | t::pending->
-      let combine=combine_rec uf pending in
-      let s=UF.signature uf t in
-      let u=snd (UF.subterms uf t) in
-      let f (c,a) pac pacs=
-	if a=0 then pacs else 
-	  let sg=(c,a-1) in
-	    UF.add_node_pac uf t sg pac.term_head;
-	    PacMap.add sg {pac with args=u::pac.args;term_head=t} pacs
-      in
-      let pacs=PacMap.fold f (UF.pac_map uf (fst s)) PacMap.empty in
-      let i=UF.find uf t in
-      let (p,c)=UF.add_pacs uf i pacs in
-      let combine2=(combine_rec uf p)@c@combine in
-      try {lhs=t;rhs=ST.query s uf.UF.sigtable;rule=Congruence}::combine2 with
-	Not_found->
-	  ST.enter t s uf.UF.sigtable;combine2
-	    
-let rec process_rec uf=function
-    []->[] 
-  | eq::combine->
-      let pending=process_rec uf combine in
-      let i=UF.find uf eq.lhs 
-      and j=UF.find uf eq.rhs in
-      if i=j then
-	pending
+let join_path uf i j=
+  assert (find uf i=find uf j);
+  min_path (down_path uf i [],down_path uf j [])
+
+let union state i1 i2 eq=
+  debug msgnl (str "Linking " ++ int i1 ++ str " and " ++ int i2 ++ str ".");
+  let r1= get_representative state.uf i1 
+  and r2= get_representative state.uf i2 in
+    link state.uf i1 i2 eq;
+    let f= Intset.union r1.fathers r2.fathers in
+      r2.nfathers<-Intset.cardinal f;
+      r2.fathers<-f;
+      r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
+      ST.delete_set state.sigtable r1.fathers;
+      state.terms<-Intset.union state.terms r1.fathers;       
+      PacMap.iter 
+	(fun pac b -> Queue.add (b,Cmark pac) state.marks) 
+	r1.constructors;
+      PafMap.iter 
+	(fun paf -> Intset.iter 
+	   (fun b -> Queue.add (b,Fmark paf) state.marks)) 
+	r1.functions;
+      match r1.inductive_status,r2.inductive_status with 
+	  Unknown,_ -> ()
+	| Partial pac,Unknown -> 
+	    r2.inductive_status<-Partial pac;
+	    state.pa_classes<-Intset.remove i1 state.pa_classes;
+	    state.pa_classes<-Intset.add i2 state.pa_classes
+	| Partial _ ,(Partial _ |Partial_applied) -> 
+	    state.pa_classes<-Intset.remove i1 state.pa_classes
+	| Partial_applied,Unknown -> 
+	    r2.inductive_status<-Partial_applied	      
+	| Partial_applied,Partial _ -> 
+	    state.pa_classes<-Intset.remove i2 state.pa_classes;
+	    r2.inductive_status<-Partial_applied
+	| Total cpl,Unknown -> r2.inductive_status<-Total cpl;
+	| Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks    
+	| _,_ -> () 
+            
+let merge eq state = (* merge and no-merge *)
+  debug msgnl 
+    (str "Merging " ++ int eq.lhs ++ str " and " ++ int eq.rhs ++ str ".");
+  let uf=state.uf in
+  let i=find uf eq.lhs 
+  and j=find uf eq.rhs in
+    if i<>j then 
+      if (size uf i)<(size uf j) then
+	union state i j eq
       else
-	if (UF.size uf i)<(UF.size uf j) then
-	  let l=UF.fathers uf i in
-	  let (p,c)=UF.union uf i j eq in
-	  let _ =ST.delete_list l uf.UF.sigtable in
-	  let inj_pending=process_rec uf c in
-	    inj_pending@p@l@pending
+	union state j i (swap eq)
+
+let update t state = (* update 1 and 2 *)
+  debug msgnl 
+    (str "Updating term " ++ int t ++ str ".");
+  let (i,j) as sign = signature state.uf t in
+  let (u,v) = subterms state.uf t in
+  let rep = get_representative state.uf i in
+    begin
+      match rep.inductive_status with 
+	  Partial _ ->
+	    rep.inductive_status <- Partial_applied;
+	    state.pa_classes <- Intset.remove i state.pa_classes
+	| _ -> ()
+    end;
+    PacMap.iter 
+      (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) 
+      rep.constructors; 
+    PafMap.iter 
+      (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) 
+      rep.functions; 
+    try 
+      let s = ST.query sign state.sigtable in 
+	Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine
+    with 
+	Not_found -> ST.enter t sign state.sigtable
+
+let process_function_mark t rep paf state  =
+  add_paf rep paf t;
+  state.terms<-Intset.union rep.lfathers state.terms
+    
+let process_constructor_mark t i rep pac state =
+    match rep.inductive_status with
+	Total (s,opac) ->
+	  if pac.cnode <> opac.cnode then (* Conflict *) 
+	    raise (Discriminable (s,opac,t,pac)) 
+	  else (* Match *)
+	    let cinfo = get_constructor_info state.uf pac.cnode in
+	    let rec f n oargs args=
+	      if n > 0 then 
+		match (oargs,args) with
+		    s1::q1,s2::q2->
+		      Queue.add 
+			{lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)}
+			state.combine;
+		      f (n-1) q1 q2 
+		  | _-> anomaly 
+		      "add_pacs : weird error in injection subterms merge" 
+	    in f cinfo.ci_nhyps opac.args pac.args
+      | Partial_applied | Partial _ ->
+	  add_pac rep pac t;
+	  state.terms<-Intset.union rep.lfathers state.terms
+      | Unknown ->
+	  if pac.arity = 0 then
+	    rep.inductive_status <- Total (t,pac)
+	  else
+	    begin
+	      add_pac rep pac t;
+	      state.terms<-Intset.union rep.lfathers state.terms;
+	      rep.inductive_status <- Partial pac;
+	      state.pa_classes<- Intset.add i state.pa_classes
+	    end
+
+let process_mark t m state = 
+  debug msgnl 
+    (str "Processing mark for term " ++ int t ++ str ".");
+  let i=find state.uf t in
+  let rep=get_representative state.uf i in
+    match m with
+	Fmark paf -> process_function_mark t rep paf state
+      | Cmark pac -> process_constructor_mark t i rep pac state
+
+type explanation =
+    Discrimination of (int*pa_constructor*int*pa_constructor)
+  | Contradiction of disequality
+  | Incomplete
+
+let check_disequalities state =
+  let uf=state.uf in
+  let rec check_aux = function
+      dis::q -> 
+	debug msg 
+	(str "Checking if " ++ int dis.lhs ++ str " = " ++ 
+	 int dis.rhs ++ str " ... ");  
+	if find uf dis.lhs=find uf dis.rhs then 
+	  begin debug msgnl (str "Yes");Some dis end 
 	else
-	  let l=UF.fathers uf j in
-	  let (p,c)=UF.union uf j i (swap eq) in
-	  let _ =ST.delete_list l uf.UF.sigtable in
-	  let inj_pending=process_rec uf c in
-	    inj_pending@p@l@pending
+	  begin debug msgnl (str "No");check_aux q end
+    | [] -> None 
+  in
+    check_aux state.diseq
+
+let one_step state =
+    try
+      let eq = Queue.take state.combine in
+	merge eq state;
+	true
+    with Queue.Empty -> 
+      try 
+	let (t,m) = Queue.take state.marks in
+	  process_mark t m state;
+	  true
+      with Queue.Empty ->
+	try
+	  let t = Intset.choose state.terms in
+	    state.terms<-Intset.remove t state.terms;
+	    update t state;
+	    true
+	with Not_found -> false
 	  
-let rec cc_rec uf=function
-    []->()
-  | pending->
-      let combine=combine_rec uf pending in
-      let pending0=process_rec uf combine in
-	cc_rec uf pending0
-	
-let cc uf=cc_rec uf (UF.nodes uf)
-
-let rec make_uf=function
-    []->UF.empty ()
-  | (ax,(t1,t2))::q->
-      let uf=make_uf q in
-      let i1=UF.add uf t1 in
-      let i2=UF.add uf t2 in
-      let j1=UF.find uf i1 and j2=UF.find uf i2 in
-	if j1=j2 then uf else  
-	    let (_,inj_combine)=
-		UF.union uf j1 j2 {lhs=i1;rhs=i2;rule=Axiom ax} in
-	    let _ = process_rec uf inj_combine in uf
-      
-let add_one_diseq uf (t1,t2)=(UF.add uf t1,UF.add uf t2)
 
-let add_disaxioms uf disaxioms=
-  let f (id,cpl)=(id,add_one_diseq uf cpl) in
-    List.map f disaxioms
+let complete_one_class state i=
+  match (get_representative state.uf i).inductive_status with
+      Partial pac ->
+	let rec app t n = 
+	  if n<=0 then t else
+	    app (Appli(t,Eps)) (n-1) in
+	  state.uf.epsilons <- pac :: state.uf.epsilons; 
+	  ignore (add_term state (app (term state.uf i) pac.arity))
+    | _ -> anomaly "wrong incomplete class" 
+
+let complete state =
+  Intset.iter (complete_one_class state) state.pa_classes
+
+type matching_problem = 
+{mp_subst : int array;
+ mp_inst : quant_eq;
+ mp_stack : (ccpattern*int) list }
+
+let make_fun_table state =
+  let uf= state.uf in
+  let funtab=ref PafMap.empty in
+  for cl=0 to pred uf.size do 
+    match uf.map.(cl).clas with
+	Rep rep ->
+	  PafMap.iter 
+	    (fun paf _ -> 
+	       let elem = 
+		 try PafMap.find paf !funtab 
+		 with Not_found -> Intset.empty in
+		 funtab:= PafMap.add paf (Intset.add cl elem) !funtab) 
+	    rep.functions
+      | _ -> ()   
+  done;
+    !funtab
+  
 
-let check_equal uf (i1,i2) = UF.find uf i1 = UF.find uf i2
+let rec do_match state res pb_stack =
+  let mp=Stack.pop pb_stack in
+    match mp.mp_stack with
+	[] -> 
+	  res:= (mp.mp_inst,mp.mp_subst) :: !res
+      | (patt,cl)::remains ->
+	  let uf=state.uf in
+	    match patt with
+		PVar i -> 
+		  if mp.mp_subst.(pred i)<0 then  
+		    begin
+		      mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *)
+		      Stack.push {mp with mp_stack=remains} pb_stack
+		    end
+		  else
+		    if mp.mp_subst.(pred i) = cl then
+		      Stack.push {mp with mp_stack=remains} pb_stack
+	      | PApp (f,[]) ->
+		  begin
+		    try let j=Hashtbl.find uf.syms f in
+		      if find uf j =cl then
+			Stack.push {mp with mp_stack=remains} pb_stack
+		    with Not_found -> ()
+		  end
+	      | PApp(f, ((last_arg::rem_args) as args)) ->
+		  try 
+		    let j=Hashtbl.find uf.syms f in
+		    let paf={fsym=j;fnargs=List.length args} in
+		    let rep=get_representative uf cl in
+		    let good_terms = PafMap.find paf rep.functions in
+		    let aux i = 
+		      let (s,t) = ST.rev_query i state.sigtable in
+			Stack.push 
+			  {mp with 
+			     mp_subst=Array.copy mp.mp_subst;
+			     mp_stack=
+			      (PApp(f,rem_args),s) :: 
+				(last_arg,t) :: remains} pb_stack in
+		      Intset.iter aux good_terms 
+		  with Not_found -> ()
+
+let paf_of_patt syms = function
+    PVar _ -> invalid_arg "paf_of_patt: pattern is trivial"
+  | PApp (f,args) ->
+      {fsym=Hashtbl.find syms f;
+       fnargs=List.length args}
+
+let init_pb_stack state = 
+  let syms= state.uf.syms in
+  let pb_stack = Stack.create () in
+  let funtab = make_fun_table state in
+  let aux inst =
+    begin
+      if inst.qe_lhs_valid then
+	try 
+	  let paf= paf_of_patt syms inst.qe_lhs in
+	  let good_classes = PafMap.find paf funtab in
+	    Intset.iter (fun i -> 
+			 Stack.push 
+			   {mp_subst = Array.make inst.qe_nvars (-1); 
+			    mp_inst=inst;
+			    mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes
+	with Not_found -> ()
+    end;
+    begin 
+      if inst.qe_rhs_valid then
+	try 
+	  let paf= paf_of_patt syms inst.qe_rhs in
+	  let good_classes = PafMap.find paf funtab in
+	    Intset.iter (fun i -> 
+			   Stack.push 
+			     {mp_subst = Array.make inst.qe_nvars (-1); 
+			      mp_inst=inst;
+			      mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes
+	with Not_found -> ()
+    end in
+    List.iter aux state.quant;
+    pb_stack
+
+let find_instances state = 
+  let pb_stack= init_pb_stack state in
+  let res =ref [] in
+  let _ =
+    debug msgnl (str "Running E-matching algorithm ... ");
+    try
+      while true do 
+	do_match state res pb_stack 
+      done;
+      anomaly "get out of here !"
+    with Stack.Empty -> () in
+    !res
+
+let rec execute first_run state =
+  debug msgnl (str "Executing ... ");
+  try
+    while one_step state do ()
+    done;
+    match check_disequalities state with
+	None -> 
+	  if not(Intset.is_empty state.pa_classes) then
+	    begin 
+	      debug msgnl (str "First run was incomplete, completing ... ");
+	      complete state;
+	      execute false state
+	    end
+	  else 
+	    if state.rew_depth>0 then
+	      let l=find_instances state in
+		List.iter (add_inst state) l;
+		if state.changed then 
+		  begin
+		    state.changed <- false;
+		    execute true state
+		  end
+		else
+	      begin 
+		debug msgnl (str "Out of instances ... ");
+		None
+	      end
+	    else 
+	      begin 
+		debug msgnl (str "Out of depth ... ");
+		None
+	      end
+      | Some dis -> Some
+	  begin
+	    if first_run then Contradiction dis
+	    else Incomplete
+	  end
+  with Discriminable(s,spac,t,tpac) -> Some
+    begin
+      if first_run then Discrimination (s,spac,t,tpac)
+      else Incomplete
+    end
 
-let find_contradiction uf diseq =
-  List.find (fun (id,cpl) -> check_equal uf cpl) diseq
- 
 
diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli
index 47cdb3ea..05a5c4d1 100644
--- a/contrib/cc/ccalgo.mli
+++ b/contrib/cc/ccalgo.mli
@@ -6,15 +6,148 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccalgo.mli,v 1.6.2.1 2004/07/16 19:29:58 herbelin Exp $ *)
+(* $Id: ccalgo.mli 9151 2006-09-19 13:32:22Z corbinea $ *)
 
-type pa_constructor
-    (*{head: int; arity: int; args: (int * int) list}*)
+open Util
+open Term
+open Names
 
-module PacMap:Map.S with type key=int * int 
+type cinfo =
+    {ci_constr: constructor; (* inductive type *)
+     ci_arity: int;     (* # args *)
+     ci_nhyps: int}     (* # projectable args *)
+
+type term =
+    Symb of constr
+  | Eps
+  | Appli of term*term
+  | Constructor of cinfo (* constructor arity + nhyps *)
+
+type ccpattern =
+    PApp of term * ccpattern list
+  | PVar of int 
+
+type pa_constructor =
+    { cnode : int;
+      arity : int;
+      args  : int list}
+
+module PacMap : Map.S with type key = pa_constructor  
+
+type forest
+
+type state 
+
+type rule=
+    Congruence
+  | Axiom of constr * bool 
+  | Injection of int * pa_constructor * int * pa_constructor * int
+
+type from=
+    Goal
+  | Hyp of constr
+  | HeqG of constr
+  | HeqnH of constr*constr 
+
+type 'a eq = {lhs:int;rhs:int;rule:'a}
+
+type equality = rule eq
+
+type disequality = from eq
+
+type explanation =
+    Discrimination of (int*pa_constructor*int*pa_constructor)
+  | Contradiction of disequality
+  | Incomplete
+
+val constr_of_term : term -> constr
+
+val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit
+
+val forest : state -> forest
+
+val axioms : forest -> (constr, term * term) Hashtbl.t
+
+val epsilons : forest -> pa_constructor list
+
+val empty : int -> state
+
+val add_term : state -> term -> int
+
+val add_equality : state -> constr -> term -> term -> unit
+
+val add_disequality : state -> from -> term -> term -> unit
+
+val add_quant : state -> identifier -> bool -> 
+  int * bool * ccpattern * bool * ccpattern -> unit
+
+
+val tail_pac : pa_constructor -> pa_constructor
+
+val find : forest -> int -> int
+
+val find_pac : forest -> int -> pa_constructor -> int
+
+val term : forest -> int -> term
+
+val get_constructor_info : forest -> int -> cinfo
+
+val subterms : forest -> int -> int * int
+
+val join_path : forest -> int -> int -> 
+  ((int * int) * equality) list * ((int * int) * equality) list
+
+type quant_eq=
+    {qe_hyp_id: identifier;
+     qe_pol: bool;
+     qe_nvars:int;
+     qe_lhs: ccpattern;
+     qe_lhs_valid:bool;
+     qe_rhs: ccpattern;
+     qe_rhs_valid:bool}
+
+
+type pa_fun=
+    {fsym:int;
+     fnargs:int}
+
+type matching_problem
+ 
+module PafMap: Map.S with type key = pa_fun
+
+val make_fun_table : state -> Intset.t PafMap.t 
+
+val do_match :  state ->
+    (quant_eq * int array) list ref -> matching_problem Stack.t -> unit
+
+val init_pb_stack : state -> matching_problem Stack.t
+
+val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun
+
+val find_instances : state -> (quant_eq * int array) list
+
+val execute : bool -> state -> explanation option
+
+
+
+
+
+
+
+
+
+
+
+
+
+(*type pa_constructor
+
+
+module PacMap:Map.S with type key=pa_constructor
 
 type term = 
     Symb of Term.constr 
+  | Eps
   | Appli of term * term 
   | Constructor of Names.constructor*int*int
 
@@ -79,6 +212,6 @@ val check_equal : UF.t -> int * int -> bool
 val find_contradiction : UF.t -> 
   (Names.identifier * (int * int)) list -> 
   (Names.identifier * (int * int))
-
+*)
 
 
diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml
index fa525e65..1ffa347a 100644
--- a/contrib/cc/ccproof.ml
+++ b/contrib/cc/ccproof.ml
@@ -6,18 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.ml,v 1.8.2.1 2004/07/16 19:29:58 herbelin Exp $ *)
+(* $Id: ccproof.ml 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 (* This file uses the (non-compressed) union-find structure to generate *) 
 (* proof-trees that will be transformed into proof-terms in cctac.ml4   *)
 
 open Util
 open Names
+open Term
 open Ccalgo
   
 type proof=
-    Ax of identifier
-  | SymAx of identifier
+    Ax of constr
+  | SymAx of constr
   | Refl of term
   | Trans of proof*proof
   | Congr of proof*proof
@@ -51,8 +52,8 @@ let pcongr=function
 let build_proof uf=
   
   let rec equal_proof i j=
-    if i=j then Refl (UF.term uf i) else 
-      let (li,lj)=UF.join_path uf i j in
+    if i=j then Refl (term uf i) else 
+      let (li,lj)=join_path uf i j in
 	ptrans (path_proof i li,psym (path_proof j lj))
   
   and edge_proof ((i,j),eq)=
@@ -60,45 +61,44 @@ let build_proof uf=
     let pj=psym (equal_proof j eq.rhs) in
     let pij=
       match eq.rule with 
-	  Axiom s->Ax s
+	  Axiom (s,reversed)->if reversed then SymAx s else Ax s
 	| Congruence ->congr_proof eq.lhs eq.rhs
-	| Injection (ti,tj,c,a) ->
-	    let p=equal_proof ti tj in
-	    let p1=constr_proof ti ti c 0
-	    and p2=constr_proof tj tj c 0 in
-	      match UF.term uf c with
-		  Constructor (cstr,nargs,nhyps) -> 
-		    Inject(ptrans(psym p1,ptrans(p,p2)),cstr,nhyps,a)
-		| _ -> anomaly "injection on non-constructor terms" 
+	| Injection (ti,ipac,tj,jpac,k) ->
+	    let p=ind_proof ti ipac tj jpac in
+	    let cinfo= get_constructor_info uf ipac.cnode in
+	      Inject(p,cinfo.ci_constr,cinfo.ci_nhyps,k)	
     in  ptrans(ptrans (pi,pij),pj)
 
-  and constr_proof i j c n=
-    try
-      let nj=UF.mem_node_pac uf j (c,n) in
-      let (ni,arg)=UF.subterms uf j in 
-      let p=constr_proof ni nj c (n+1) in
-      let targ=UF.term uf arg in 
-	ptrans (equal_proof i j, pcongr (p,Refl targ))
-    with Not_found->equal_proof i j
+  and constr_proof i t ipac=
+    if ipac.args=[] then
+      equal_proof i t
+    else
+      let npac=tail_pac ipac in
+      let (j,arg)=subterms uf t in
+      let targ=term uf arg in
+      let rj=find uf j in
+      let u=find_pac uf rj npac in
+      let p=constr_proof j u npac in
+	ptrans (equal_proof i t, pcongr (p,Refl targ))
 
   and path_proof i=function
-      [] -> Refl (UF.term uf i)
+      [] -> Refl (term uf i)
     | x::q->ptrans (path_proof (snd (fst x)) q,edge_proof x)
   
   and congr_proof i j=
-    let (i1,i2) = UF.subterms uf i
-    and (j1,j2) = UF.subterms uf j in   
+    let (i1,i2) = subterms uf i
+    and (j1,j2) = subterms uf j in   
       pcongr (equal_proof i1 j1, equal_proof i2 j2)
 	
-  and discr_proof i ci j cj=
+  and ind_proof i ipac j jpac=
     let p=equal_proof i j 
-    and p1=constr_proof i i ci 0 
-    and p2=constr_proof j j cj 0 in
+    and p1=constr_proof i i ipac 
+    and p2=constr_proof j j jpac in
       ptrans(psym p1,ptrans(p,p2))
   in
     function
-	`Prove_goal (i,j) | `Refute_hyp (i,j) -> equal_proof i j
-      | `Discriminate (i,ci,j,cj)-> discr_proof i ci j cj
+	`Prove (i,j) -> equal_proof i j
+      | `Discr (i,ci,j,cj)-> ind_proof i ci j cj
 
 let rec nth_arg t n=
   match t with 
@@ -110,8 +110,8 @@ let rec nth_arg t n=
 
 let rec type_proof axioms p=
   match p with
-      Ax s->List.assoc s axioms
-    | SymAx s-> let (t1,t2)=List.assoc s axioms in (t2,t1)
+      Ax s->Hashtbl.find axioms s
+    | SymAx s-> let (t1,t2)=Hashtbl.find axioms s in (t2,t1)
     | Refl t-> t,t
     | Trans (p1,p2)->
 	let (s1,t1)=type_proof axioms p1 
@@ -125,33 +125,3 @@ let rec type_proof axioms p=
 	let (ti,tj)=type_proof axioms p in
 	  nth_arg ti (n-a),nth_arg tj (n-a)
 
-let by_contradiction uf diseq axioms disaxioms= 
-  try 
-    let id,cpl=find_contradiction uf diseq in
-    let prf=build_proof uf (`Refute_hyp cpl) in
-      if List.assoc id disaxioms=type_proof axioms prf then
-	`Refute_hyp (id,prf)
-      else 
-	anomaly "wrong proof generated"
-  with Not_found ->
-    errorlabstrm  "Congruence" (Pp.str "I couldn't solve goal")  
-
-let cc_proof axioms disaxioms glo=
-  try
-    let uf=make_uf axioms in
-    let diseq=add_disaxioms uf disaxioms in
-      match glo with 
-	  Some cpl ->
-	    let goal=add_one_diseq uf cpl in cc uf;
-	      if check_equal uf goal then 
-		let prf=build_proof uf (`Prove_goal goal) in
-		  if cpl=type_proof axioms prf then
-		    `Prove_goal prf
-		  else anomaly "wrong proof generated"
-	      else by_contradiction uf diseq axioms disaxioms  
-	| None -> cc uf; by_contradiction uf diseq axioms disaxioms
-    with UF.Discriminable (i,ci,j,cj,uf) ->
-      let prf=build_proof uf (`Discriminate (i,ci,j,cj)) in 
-	`Discriminate (UF.get_constructor uf ci,prf) 
-
-
diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli
index 887ed070..abdd6fea 100644
--- a/contrib/cc/ccproof.mli
+++ b/contrib/cc/ccproof.mli
@@ -6,40 +6,26 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ccproof.mli,v 1.6.2.1 2004/07/16 19:29:59 herbelin Exp $ *)
+(* $Id: ccproof.mli 9151 2006-09-19 13:32:22Z corbinea $ *)
 
 open Ccalgo
 open Names
+open Term
 
 type proof =
-    Ax of identifier
-  | SymAx of identifier
+    Ax of constr
+  | SymAx of constr
   | Refl of term
   | Trans of proof * proof
   | Congr of proof * proof
   | Inject of proof * constructor * int * int
 
-val pcongr : proof * proof -> proof
-val ptrans : proof * proof -> proof
-val psym : proof -> proof
-val pcongr : proof * proof -> proof
-
 val build_proof : 
-  UF.t -> 
-  [ `Discriminate of int * int * int * int
-  | `Prove_goal of int * int
-  | `Refute_hyp of int * int ]
-  -> proof
+  forest -> 
+  [ `Discr of int * pa_constructor * int * pa_constructor
+  | `Prove of int * int ] -> proof
 
 val type_proof :
-  (identifier * (term * term)) list -> proof -> term * term
-
-val cc_proof :
-  (identifier * (term * term)) list ->
-  (identifier * (term * term)) list ->
-  (term * term) option ->
-  [ `Discriminate of constructor * proof
-  | `Prove_goal of proof
-  | `Refute_hyp of identifier * proof ]
+  (constr, (term * term)) Hashtbl.t -> proof -> term * term
 
 
diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml
new file mode 100644
index 00000000..ea8aceeb
--- /dev/null
+++ b/contrib/cc/cctac.ml
@@ -0,0 +1,382 @@
+(************************************************************************)
+(*  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: cctac.ml 9151 2006-09-19 13:32:22Z corbinea $ *)
+
+(* This file is the interface between the c-c algorithm and Coq *)
+
+open Evd
+open Proof_type
+open Names
+open Libnames
+open Nameops
+open Inductiveops
+open Declarations
+open Term
+open Termops
+open Tacmach
+open Tactics
+open Tacticals
+open Ccalgo
+open Tacinterp
+open Ccproof
+open Pp
+open Util
+open Format
+
+let constant dir s = lazy (Coqlib.gen_constant "CC" dir s)
+
+let _f_equal = constant ["Init";"Logic"] "f_equal"
+
+let _eq_rect = constant ["Init";"Logic"] "eq_rect"
+
+let _eq = constant ["Init";"Logic"] "eq"
+
+let _False = constant ["Init";"Logic"] "False"
+
+(* decompose member of equality in an applicative format *)
+
+let whd env=
+  let infos=Closure.create_clos_infos Closure.betaiotazeta env in
+    (fun t -> Closure.whd_val infos (Closure.inject t))
+
+let whd_delta env=
+   let infos=Closure.create_clos_infos Closure.betadeltaiota env in
+    (fun t -> Closure.whd_val infos (Closure.inject t))
+
+let rec decompose_term env t=
+    match kind_of_term (whd env t) with
+      App (f,args)->
+	let tf=decompose_term env f in
+	let targs=Array.map (decompose_term env) args in
+	  Array.fold_left (fun s t->Appli (s,t)) tf targs
+    | Construct c->
+	let (oib,_)=Global.lookup_inductive (fst c) in
+	let nargs=mis_constructor_nargs_env env c in
+	  Constructor {ci_constr=c;
+		       ci_arity=nargs;
+		       ci_nhyps=nargs-oib.mind_nparams}
+    | _ ->if closed0 t then (Symb t) else raise Not_found
+	
+(* decompose equality in members and type *)
+	
+let atom_of_constr env term =
+  let wh =  (whd_delta env term) in
+  let kot = kind_of_term wh in 
+    match kot with
+      App (f,args)->
+	  if eq_constr f (Lazy.force _eq) && (Array.length args)=3 
+	  then `Eq (args.(0),
+		   decompose_term env args.(1), 
+		   decompose_term env args.(2)) 
+	  else `Other (decompose_term env term)
+    | _ -> `Other (decompose_term env term)
+
+let rec pattern_of_constr env c =
+  match kind_of_term (whd env c) with
+      App (f,args)->
+	let pf = decompose_term env f in
+	let pargs,lrels = List.split 
+	  (array_map_to_list (pattern_of_constr env) args) in
+	  PApp (pf,List.rev pargs),
+	List.fold_left Intset.union Intset.empty lrels 
+    | Rel i -> PVar i,Intset.singleton i
+    | _ -> 
+	let pf = decompose_term env c in
+	  PApp (pf,[]),Intset.empty
+
+let non_trivial = function
+    PVar _ -> false
+  | _ -> true
+
+let patterns_of_constr env nrels term=
+  let f,args= 
+    try destApp (whd_delta env term) with _ -> raise Not_found in
+	if eq_constr f (Lazy.force _eq) && (Array.length args)=3 
+	then 
+	  let patt1,rels1 = pattern_of_constr env args.(1)
+	  and patt2,rels2 = pattern_of_constr env args.(2) in
+	  let valid1 = (Intset.cardinal rels1 = nrels && non_trivial patt1) 
+	  and valid2 = (Intset.cardinal rels2 = nrels && non_trivial patt2) in
+	    if valid1 || valid2 then 
+	      nrels,valid1,patt1,valid2,patt2
+	    else raise Not_found
+	else raise Not_found
+
+let rec quantified_atom_of_constr env nrels term =
+  match kind_of_term (whd_delta env term) with
+      Prod (_,atom,ff) -> 
+	if eq_constr ff (Lazy.force _False) then
+	  let patts=patterns_of_constr env nrels atom in
+	      `Nrule patts
+	else 
+	  quantified_atom_of_constr env (succ nrels) ff
+    | _ ->  
+	let patts=patterns_of_constr env nrels term in
+	    `Rule patts	  
+
+let litteral_of_constr env term=
+  match kind_of_term (whd_delta env term) with
+    | Prod (_,atom,ff) -> 
+	if eq_constr ff (Lazy.force _False) then
+	  match (atom_of_constr env atom) with
+	      `Eq(t,a,b) -> `Neq(t,a,b)
+	    | `Other(p) -> `Nother(p)
+	else
+	  begin
+	    try 
+	      quantified_atom_of_constr env 1 ff  
+	    with Not_found ->
+	      `Other (decompose_term env term)
+	  end
+    | _ -> 
+	atom_of_constr env term
+	
+
+(* store all equalities from the context *)
+	
+let rec make_prb gls depth additionnal_terms =
+  let env=pf_env gls in
+  let state = empty depth in
+  let pos_hyps = ref [] in
+  let neg_hyps =ref [] in
+    List.iter
+      (fun c ->
+	 let t = decompose_term env c in
+	   ignore (add_term state t)) additionnal_terms; 
+    List.iter 
+      (fun (id,_,e) ->
+	 begin
+	   let cid=mkVar id in
+	   match litteral_of_constr env e with
+	       `Eq (t,a,b) -> add_equality state cid a b
+	     | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b
+	     | `Other ph ->
+		 List.iter 
+		   (fun (cidn,nh) -> 
+		      add_disequality state (HeqnH (cid,cidn)) ph nh) 
+		   !neg_hyps;
+		 pos_hyps:=(cid,ph):: !pos_hyps
+	     | `Nother nh ->
+		 List.iter 
+		   (fun (cidp,ph) -> 
+		      add_disequality state (HeqnH (cidp,cid)) ph nh) 
+		   !pos_hyps;
+		 neg_hyps:=(cid,nh):: !neg_hyps
+	     | `Rule patts -> add_quant state id true patts
+	     | `Nrule patts -> add_quant state id false patts
+	 end) (Environ.named_context_of_val gls.it.evar_hyps);
+    begin
+      match atom_of_constr env gls.it.evar_concl with
+	  `Eq (t,a,b) -> add_disequality state Goal a b
+	|	`Other g ->  
+		  List.iter 
+	      (fun (idp,ph) -> 
+		 add_disequality state (HeqG idp) ph g) !pos_hyps
+    end;
+    state
+
+(* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
+
+let build_projection intype outtype (cstr:constructor) special default gls=
+  let env=pf_env gls in 
+  let (h,argv) = 
+    try destApp intype with 
+	Invalid_argument _ -> (intype,[||])  in
+  let ind=destInd h in 
+  let types=Inductiveops.arities_of_constructors env ind in
+  let lp=Array.length types in
+  let ci=(snd cstr)-1 in
+  let branch i=
+    let ti=Term.prod_appvect types.(i) argv in
+    let rc=fst (Sign.decompose_prod_assum ti) in
+    let head=
+      if i=ci then special else default in  
+      Sign.it_mkLambda_or_LetIn head rc in
+  let branches=Array.init lp branch in
+  let casee=mkRel 1 in
+  let pred=mkLambda(Anonymous,intype,outtype) in
+  let case_info=make_default_case_info (pf_env gls) RegularStyle ind in
+  let body= mkCase(case_info, pred, casee, branches) in
+  let id=pf_get_new_id (id_of_string "t") gls in     
+    mkLambda(Name id,intype,body)
+  
+(* generate an adhoc tactic following the proof tree  *)
+
+let rec proof_tac axioms=function
+    Ax c -> exact_check c
+  | SymAx c -> tclTHEN symmetry (exact_check c)
+  | Refl t -> reflexivity
+  | Trans (p1,p2)->let t=(constr_of_term (snd (type_proof axioms p1))) in
+      (tclTHENS (transitivity t) 
+	 [(proof_tac axioms p1);(proof_tac axioms p2)])
+  | Congr (p1,p2)->
+      fun gls->
+	let (f1,f2)=(type_proof axioms p1) 
+	and (x1,x2)=(type_proof axioms p2) in
+        let tf1=constr_of_term f1 and tx1=constr_of_term x1 
+	and tf2=constr_of_term f2 and tx2=constr_of_term x2 in
+	let typf=pf_type_of gls tf1 and typx=pf_type_of gls tx1
+	and typfx=pf_type_of gls (mkApp(tf1,[|tx1|])) in
+	let id=pf_get_new_id (id_of_string "f") gls in
+	let appx1=mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in
+	let lemma1=
+	  mkApp(Lazy.force _f_equal,[|typf;typfx;appx1;tf1;tf2|])
+	and lemma2=
+	  mkApp(Lazy.force _f_equal,[|typx;typfx;tf2;tx1;tx2|]) in
+	  (tclTHENS (transitivity (mkApp(tf2,[|tx1|])))
+	     [tclTHEN (apply lemma1) (proof_tac axioms p1);
+  	      tclFIRST
+		[tclTHEN (apply lemma2) (proof_tac axioms p2);
+		 reflexivity;
+		 fun gls ->
+		   errorlabstrm  "Congruence" 
+		   (Pp.str 
+		      "I don't know how to handle dependent equality")]]
+	     gls)
+  | Inject (prf,cstr,nargs,argind)  as gprf->
+      (fun gls ->
+	 let ti,tj=type_proof axioms prf in
+	 let ai,aj=type_proof axioms gprf in
+	 let cti=constr_of_term ti in
+	 let ctj=constr_of_term tj in
+	 let cai=constr_of_term ai in
+	 let intype=pf_type_of gls cti in
+	 let outtype=pf_type_of gls cai in
+	 let special=mkRel (1+nargs-argind) in
+	 let default=constr_of_term ai in
+	 let proj=build_projection intype outtype cstr special default gls in
+	 let injt=
+	   mkApp (Lazy.force _f_equal,[|intype;outtype;proj;cti;ctj|]) in 
+	   tclTHEN (apply injt) (proof_tac axioms prf) gls)
+
+let refute_tac axioms c t1 t2 p gls =      
+  let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
+  let intype=pf_type_of gls tt1 in
+  let neweq=
+    mkApp(Lazy.force _eq,
+	  [|intype;tt1;tt2|]) in
+  let hid=pf_get_new_id (id_of_string "Heq") gls in
+  let false_t=mkApp (c,[|mkVar hid|]) in
+    tclTHENS (true_cut (Name hid) neweq)
+      [proof_tac axioms p; simplest_elim false_t] gls
+
+let convert_to_goal_tac axioms c t1 t2 p gls =
+  let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
+  let sort=pf_type_of gls tt2 in
+  let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in 
+  let e=pf_get_new_id (id_of_string "e") gls in
+  let x=pf_get_new_id (id_of_string "X") gls in
+  let identity=mkLambda (Name x,sort,mkRel 1) in 
+  let endt=mkApp (Lazy.force _eq_rect,
+		  [|sort;tt1;identity;c;tt2;mkVar e|]) in
+    tclTHENS (true_cut (Name e) neweq) 
+      [proof_tac axioms p;exact_check endt] gls
+
+let convert_to_hyp_tac axioms c1 t1 c2 t2 p gls =
+  let tt2=constr_of_term t2 in
+  let h=pf_get_new_id (id_of_string "H") gls in
+  let false_t=mkApp (c2,[|mkVar h|]) in
+    tclTHENS (true_cut (Name h) tt2)
+      [convert_to_goal_tac axioms c1 t1 t2 p;
+       simplest_elim false_t] gls
+  
+let discriminate_tac axioms cstr p gls =
+  let t1,t2=type_proof axioms p in 
+  let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
+  let intype=pf_type_of gls tt1 in
+  let concl=pf_concl gls in
+  let outsort=mkType (new_univ ()) in
+  let xid=pf_get_new_id (id_of_string "X") gls in
+  let tid=pf_get_new_id (id_of_string "t") gls in
+  let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in
+  let trivial=pf_type_of gls identity in
+  let outtype=mkType (new_univ ()) in
+  let pred=mkLambda(Name xid,outtype,mkRel 1) in
+  let hid=pf_get_new_id (id_of_string "Heq") gls in     
+  let proj=build_projection intype outtype cstr trivial concl gls in
+  let injt=mkApp (Lazy.force _f_equal,
+		  [|intype;outtype;proj;tt1;tt2;mkVar hid|]) in   
+  let endt=mkApp (Lazy.force _eq_rect,
+		  [|outtype;trivial;pred;identity;concl;injt|]) in
+  let neweq=mkApp(Lazy.force _eq,[|intype;tt1;tt2|]) in
+    tclTHENS (true_cut (Name hid) neweq) 
+      [proof_tac axioms p;exact_check endt] gls
+      
+(* wrap everything *)
+	
+let build_term_to_complete uf meta pac =
+  let cinfo = get_constructor_info uf pac.cnode in
+  let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in
+  let dummy_args = List.rev (list_tabulate meta pac.arity) in
+  let all_args = List.rev_append real_args dummy_args in
+    applistc (mkConstruct cinfo.ci_constr) all_args
+      
+let cc_tactic depth additionnal_terms gls=
+  Coqlib.check_required_library ["Coq";"Init";"Logic"];
+  let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in
+  let state = make_prb gls depth additionnal_terms in
+  let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in
+  let sol = execute true state in
+  let _ = debug Pp.msgnl (Pp.str "Computation completed.") in
+  let uf=forest state in
+    match sol with
+	None -> tclFAIL 0 (str "congruence failed") gls  
+      | Some reason ->
+	  debug Pp.msgnl (Pp.str "Goal solved, generating proof ...");
+	  match reason with
+	      Discrimination (i,ipac,j,jpac) ->
+		let p=build_proof uf (`Discr (i,ipac,j,jpac)) in	  
+		let cstr=(get_constructor_info uf ipac.cnode).ci_constr in
+		  discriminate_tac (axioms uf) cstr p gls
+	    | Incomplete ->
+		let metacnt = ref 0 in
+		let newmeta _ = incr metacnt; mkMeta !metacnt in
+		let terms_to_complete = 
+		  List.map 
+		    (build_term_to_complete uf newmeta) 
+		    (epsilons uf) in 
+		  Pp.msgnl
+		    (Pp.str "Goal is solvable by congruence but \
+ some arguments are missing.");
+		  Pp.msgnl
+		    (Pp.str "  Try " ++
+		     hov 8
+		       begin 
+			 str "\"congruence with (" ++  
+			 prlist_with_sep 
+			   (fun () -> str ")" ++ pr_spc () ++ str "(")
+			   (print_constr_env (pf_env gls))
+			   terms_to_complete ++ 
+			 str ")\","
+		       end);
+		  Pp.msgnl
+		    (Pp.str "  replacing metavariables by arbitrary terms.");
+		  tclFAIL 0 (str "Incomplete") gls
+	    | Contradiction dis ->
+		let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in
+		let ta=term uf dis.lhs and tb=term uf dis.rhs in
+		let axioms = axioms uf in 
+		  match dis.rule with
+		      Goal -> proof_tac axioms p gls
+		    | Hyp id -> refute_tac axioms id ta tb p gls
+		    | HeqG id -> 
+			convert_to_goal_tac axioms id ta tb p gls
+		    | HeqnH (ida,idb) -> 
+			convert_to_hyp_tac axioms ida ta idb tb p gls
+		    
+
+let cc_fail gls =
+  errorlabstrm  "Congruence" (Pp.str "congruence failed.")     
+
+let congruence_tac depth l = 
+  tclORELSE 
+    (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) 
+    cc_fail
diff --git a/contrib/cc/cctac.ml4 b/contrib/cc/cctac.ml4
deleted file mode 100644
index 49fe46fe..00000000
--- a/contrib/cc/cctac.ml4
+++ /dev/null
@@ -1,247 +0,0 @@
-(************************************************************************)
-(*  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: cctac.ml4,v 1.13.2.1 2004/07/16 19:29:59 herbelin Exp $ *)
-
-(* This file is the interface between the c-c algorithm and Coq *)
-
-open Evd
-open Proof_type
-open Names
-open Libnames
-open Nameops
-open Inductiveops
-open Declarations
-open Term
-open Termops
-open Tacmach
-open Tactics
-open Tacticals
-open Ccalgo
-open Tacinterp
-open Ccproof
-open Pp
-open Util
-open Format
-
-exception Not_an_eq
-
-let fail()=raise Not_an_eq
-    
-let constant dir s = lazy (Coqlib.gen_constant "CC" dir s)
-
-let f_equal_theo = constant ["Init";"Logic"] "f_equal"
-
-let eq_rect_theo = constant ["Init";"Logic"] "eq_rect"
-
-(* decompose member of equality in an applicative format *)
-
-let rec decompose_term env t=
-  match kind_of_term t with
-      App (f,args)->
-	let tf=decompose_term env f in
-	let targs=Array.map (decompose_term env) args in
-	  Array.fold_left (fun s t->Appli (s,t)) tf targs
-    | Construct c->
-	let (_,oib)=Global.lookup_inductive (fst c) in
-	let nargs=mis_constructor_nargs_env env c in
-	  Constructor (c,nargs,nargs-oib.mind_nparams)
-    | _ ->(Symb t)
-	
-(* decompose equality in members and type *)
-	
-let rec eq_type_of_term term=
-  match kind_of_term term with
-      App (f,args)->
-	(try 
-	   let ref = reference_of_constr f in
-	     if ref=Coqlib.glob_eq && (Array.length args)=3 
-	     then (true,args.(0),args.(1),args.(2)) 
-	     else 
-	       if ref=(Lazy.force Coqlib.coq_not_ref) && 
-		 (Array.length args)=1 then
-		   let (pol,t,a,b)=eq_type_of_term args.(0) in
-		     if pol then (false,t,a,b) else fail ()
-	       else fail ()
-	 with Not_found -> fail ())
-    | Prod (_,eq,ff) ->
-	(try 
-	   let ref = reference_of_constr ff in
-	     if ref=(Lazy.force Coqlib.coq_False_ref) then
-	       let (pol,t,a,b)=eq_type_of_term eq in
-		 if pol then (false,t,a,b) else fail ()
-	     else fail ()
-	 with Not_found -> fail ())
-    | _ -> fail ()
-	
-(* read an equality *)
-	  
-let read_eq env term=
-  let (pol,_,t1,t2)=eq_type_of_term term in 
-    (pol,(decompose_term env t1,decompose_term env t2))
-
-(* rebuild a term from applicative format *)
-    
-let rec make_term=function
-    Symb s->s
-  | Constructor(c,_,_)->mkConstruct c 
-  | Appli (s1,s2)->
-      make_app [(make_term s2)] s1
-and make_app l=function
-    Symb s->applistc s l
-  | Constructor(c,_,_)->applistc (mkConstruct c) l
-  | Appli (s1,s2)->make_app ((make_term s2)::l) s1
-
-(* store all equalities from the context *)
-	
-let rec read_hyps env=function
-    []->[],[]
-  | (id,_,e)::hyps->let eq,diseq=read_hyps env hyps in
-      try let pol,cpl=read_eq env e in
-	if pol then 
-	  ((id,cpl)::eq),diseq 
-	else 
-	  eq,((id,cpl)::diseq)
-      with Not_an_eq -> eq,diseq
-
-(* build a problem ( i.e. read the goal as an equality ) *)
-	
-let make_prb gl=
-  let env=pf_env gl in
-  let eq,diseq=read_hyps env gl.it.evar_hyps in
-    try
-      let pol,cpl=read_eq env gl.it.evar_concl in
-	if pol then (eq,diseq,Some cpl) else assert false with 
-	    Not_an_eq -> (eq,diseq,None)
-
-(* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
-
-let build_projection intype outtype (cstr:constructor) special default gls=
-  let env=pf_env gls in 
-  let (h,argv) = 
-    try destApplication intype with 
-	Invalid_argument _ -> (intype,[||])  in
-  let ind=destInd h in 
-  let types=Inductive.arities_of_constructors env ind in
-  let lp=Array.length types in
-  let ci=(snd cstr)-1 in
-  let branch i=
-    let ti=Term.prod_appvect types.(i) argv in
-    let rc=fst (Sign.decompose_prod_assum ti) in
-    let head=
-      if i=ci then special else default in  
-      Sign.it_mkLambda_or_LetIn head rc in
-  let branches=Array.init lp branch in
-  let casee=mkRel 1 in
-  let pred=mkLambda(Anonymous,intype,outtype) in
-  let case_info=make_default_case_info (pf_env gls) RegularStyle ind in
-  let body= mkCase(case_info, pred, casee, branches) in
-  let id=pf_get_new_id (id_of_string "t") gls in     
-    mkLambda(Name id,intype,body)
-  
-(* generate an adhoc tactic following the proof tree  *)
-
-let rec proof_tac axioms=function
-    Ax id->exact_check (mkVar id)
-  | SymAx id->tclTHEN symmetry (exact_check (mkVar id))
-  | Refl t->reflexivity
-  | Trans (p1,p2)->let t=(make_term (snd (type_proof axioms p1))) in
-      (tclTHENS (transitivity t) 
-	 [(proof_tac axioms p1);(proof_tac axioms p2)])
-  | Congr (p1,p2)->
-      fun gls->
-	let (f1,f2)=(type_proof axioms p1) 
-	and (x1,x2)=(type_proof axioms p2) in
-        let tf1=make_term f1 and tx1=make_term x1 
-	and tf2=make_term f2 and tx2=make_term x2 in
-	let typf=pf_type_of gls tf1 and typx=pf_type_of gls tx1
-	and typfx=pf_type_of gls (mkApp(tf1,[|tx1|])) in
-	let id=pf_get_new_id (id_of_string "f") gls in
-	let appx1=mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in
-	let lemma1=
-	  mkApp(Lazy.force f_equal_theo,[|typf;typfx;appx1;tf1;tf2|])
-	and lemma2=
-	  mkApp(Lazy.force f_equal_theo,[|typx;typfx;tf2;tx1;tx2|]) in
-	  (tclTHENS (transitivity (mkApp(tf2,[|tx1|])))
-	     [tclTHEN (apply lemma1) (proof_tac axioms p1);
-  	      tclFIRST
-		[tclTHEN (apply lemma2) (proof_tac axioms p2);
-		 reflexivity;
-		 fun gls ->
-		   errorlabstrm  "Congruence" 
-		   (Pp.str 
-		      "I don't know how to handle dependent equality")]]
-	     gls)
-  | Inject (prf,cstr,nargs,argind)  as gprf->
-      (fun gls ->
-	 let ti,tj=type_proof axioms prf in
-	 let ai,aj=type_proof axioms gprf in
-	 let cti=make_term ti in
-	 let ctj=make_term tj in
-	 let cai=make_term ai in
-	 let intype=pf_type_of gls cti in
-	 let outtype=pf_type_of gls cai in
-	 let special=mkRel (1+nargs-argind) in
-	 let default=make_term ai in
-	 let proj=build_projection intype outtype cstr special default gls in
-	 let injt=
-	   mkApp (Lazy.force f_equal_theo,[|intype;outtype;proj;cti;ctj|]) in 
-	   tclTHEN (apply injt) (proof_tac axioms prf) gls)
-
-let refute_tac axioms disaxioms id p gls =      
-  let t1,t2=List.assoc id disaxioms in
-  let tt1=make_term t1 and tt2=make_term t2 in
-  let intype=pf_type_of gls tt1 in
-  let neweq=
-    mkApp(constr_of_reference Coqlib.glob_eq,
-	  [|intype;tt1;tt2|]) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in
-  let false_t=mkApp (mkVar id,[|mkVar hid|]) in
-    tclTHENS (true_cut (Name hid) neweq)
-      [proof_tac axioms p; simplest_elim false_t] gls
-
-let discriminate_tac axioms cstr p gls =
-  let t1,t2=type_proof axioms p in 
-  let tt1=make_term t1 and tt2=make_term t2 in
-  let intype=pf_type_of gls tt1 in
-  let concl=pf_concl gls in
-  let outsort=mkType (new_univ ()) in
-  let xid=pf_get_new_id (id_of_string "X") gls in
-  let tid=pf_get_new_id (id_of_string "t") gls in
-  let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in
-  let trivial=pf_type_of gls identity in
-  let outtype=mkType (new_univ ()) in
-  let pred=mkLambda(Name xid,outtype,mkRel 1) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in     
-  let proj=build_projection intype outtype cstr trivial concl gls in
-  let injt=mkApp (Lazy.force f_equal_theo,
-		  [|intype;outtype;proj;tt1;tt2;mkVar hid|]) in   
-  let endt=mkApp (Lazy.force eq_rect_theo,
-		  [|outtype;trivial;pred;identity;concl;injt|]) in
-  let neweq=mkApp(constr_of_reference Coqlib.glob_eq,[|intype;tt1;tt2|]) in
-    tclTHENS (true_cut (Name hid) neweq) 
-      [proof_tac axioms p;exact_check endt] gls
-      
-(* wrap everything *)
-	
-let cc_tactic gls=
-  Library.check_required_library ["Coq";"Init";"Logic"];
-  let (axioms,disaxioms,glo)=make_prb gls in
-    match (cc_proof axioms disaxioms glo) with
-        `Prove_goal p -> proof_tac axioms p gls
-      | `Refute_hyp (id,p) -> refute_tac axioms disaxioms id p gls
-      | `Discriminate (cstr,p) -> discriminate_tac axioms cstr p gls
-
-(* Tactic registration *)
-      
-TACTIC EXTEND CC
- [ "Congruence" ] -> [ tclSOLVE [tclTHEN (tclREPEAT introf) cc_tactic] ]
-END
-   
diff --git a/theories7/Logic/Classical.v b/contrib/cc/cctac.mli
index 8d7fe1d1..97fa4d77 100755..100644
--- a/theories7/Logic/Classical.v
+++ b/contrib/cc/cctac.mli
@@ -6,9 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
+(* $Id: cctac.mli 9151 2006-09-19 13:32:22Z corbinea $ *)
 
-(** Classical Logic *)
+open Term 
+open Proof_type
 
-Require Export Classical_Prop.
-Require Export Classical_Pred_Type.
+val cc_tactic : int -> constr list -> tactic
+
+val cc_fail : tactic
+
+val congruence_tac : int -> constr list -> tactic
diff --git a/theories7/Reals/SplitAbsolu.v b/contrib/cc/g_congruence.ml4
index 30580a0c..693aebb4 100644
--- a/theories7/Reals/SplitAbsolu.v
+++ b/contrib/cc/g_congruence.ml4
@@ -6,17 +6,20 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i      $Id: SplitAbsolu.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $       i*)
+(*i camlp4deps: "parsing/grammar.cma" i*)
 
-Require Rbasic_fun.
+(* $Id: g_congruence.ml4 9151 2006-09-19 13:32:22Z corbinea $ *)
 
-Recursive Tactic Definition SplitAbs :=
-  Match Context With
-    | [ |- [(case_Rabsolu ?1)] ] -> 
-         Case (case_Rabsolu ?1); Try SplitAbs.
+open Cctac
+open Tactics
+open Tacticals
 
-
-Recursive Tactic Definition SplitAbsolu :=
-  Match Context With
-    | [ id:[(Rabsolu ?)] |- ? ] -> Generalize id; Clear id;Try SplitAbsolu
-    | [ |- [(Rabsolu ?1)] ] ->  Unfold Rabsolu; Try SplitAbs;Intros.
+(* Tactic registration *)
+      
+TACTIC EXTEND cc
+ [ "congruence" ] -> [ congruence_tac 0 [] ]
+ |[ "congruence" integer(n) ] -> [ congruence_tac n [] ]
+ |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 0 l ]
+ |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> 
+   [ congruence_tac n l ]
+END
diff --git a/contrib/correctness/ArrayPermut.v b/contrib/correctness/ArrayPermut.v
index b352045a..30f5ac8f 100644
--- a/contrib/correctness/ArrayPermut.v
+++ b/contrib/correctness/ArrayPermut.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ArrayPermut.v,v 1.3.2.1 2004/07/16 19:29:59 herbelin Exp $ *)
+(* $Id: ArrayPermut.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (****************************************************************************)
 (*                    Permutations of elements in arrays                    *)
diff --git a/contrib/correctness/Arrays.v b/contrib/correctness/Arrays.v
index 1659917a..3a6aaaf8 100644
--- a/contrib/correctness/Arrays.v
+++ b/contrib/correctness/Arrays.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: Arrays.v,v 1.9.2.1 2004/07/16 19:29:59 herbelin Exp $ *)
+(* $Id: Arrays.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (**********************************************)
 (* Functional arrays, for use in Correctness. *)
diff --git a/contrib/correctness/Arrays_stuff.v b/contrib/correctness/Arrays_stuff.v
index 899d7007..a8a2858f 100644
--- a/contrib/correctness/Arrays_stuff.v
+++ b/contrib/correctness/Arrays_stuff.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: Arrays_stuff.v,v 1.2.16.1 2004/07/16 19:29:59 herbelin Exp $ *)
+(* $Id: Arrays_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Exchange.
 Require Export ArrayPermut.
diff --git a/contrib/correctness/Correctness.v b/contrib/correctness/Correctness.v
index a2ad2f50..b7513d09 100644
--- a/contrib/correctness/Correctness.v
+++ b/contrib/correctness/Correctness.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: Correctness.v,v 1.6.2.1 2004/07/16 19:29:59 herbelin Exp $ *)
+(* $Id: Correctness.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* Correctness is base on the tactic Refine (developped on purpose) *)
 
diff --git a/contrib/correctness/Exchange.v b/contrib/correctness/Exchange.v
index 7dc5218e..035a98f2 100644
--- a/contrib/correctness/Exchange.v
+++ b/contrib/correctness/Exchange.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: Exchange.v,v 1.4.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: Exchange.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (****************************************************************************)
 (*                   Exchange of two elements in an array                   *)
diff --git a/contrib/correctness/ProgBool.v b/contrib/correctness/ProgBool.v
index bce19870..38448efc 100644
--- a/contrib/correctness/ProgBool.v
+++ b/contrib/correctness/ProgBool.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ProgBool.v,v 1.4.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: ProgBool.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Import ZArith.
 Require Export Bool_nat.
diff --git a/contrib/correctness/ProgInt.v b/contrib/correctness/ProgInt.v
index c26e3553..b1eaaea7 100644
--- a/contrib/correctness/ProgInt.v
+++ b/contrib/correctness/ProgInt.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ProgInt.v,v 1.2.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: ProgInt.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export ZArith.
 Require Export ZArith_dec.
diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v
index 40253f33..5f7dfdbf 100644
--- a/contrib/correctness/ProgramsExtraction.v
+++ b/contrib/correctness/ProgramsExtraction.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ProgramsExtraction.v,v 1.2.16.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: ProgramsExtraction.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Extraction.
 
diff --git a/contrib/correctness/Programs_stuff.v b/contrib/correctness/Programs_stuff.v
index 1ca4b63e..6489de81 100644
--- a/contrib/correctness/Programs_stuff.v
+++ b/contrib/correctness/Programs_stuff.v
@@ -8,6 +8,6 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: Programs_stuff.v,v 1.1.16.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: Programs_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Arrays_stuff.
diff --git a/contrib/correctness/Sorted.v b/contrib/correctness/Sorted.v
index 2efe54a4..ca4ed880 100644
--- a/contrib/correctness/Sorted.v
+++ b/contrib/correctness/Sorted.v
@@ -8,7 +8,7 @@
 
 (*  Library about sorted (sub-)arrays / Nicolas Magaud, July 1998 *)
 
-(* $Id: Sorted.v,v 1.7.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: Sorted.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Arrays.
 Require Import ArrayPermut.
diff --git a/contrib/correctness/Tuples.v b/contrib/correctness/Tuples.v
index e3fff08d..c7071f32 100644
--- a/contrib/correctness/Tuples.v
+++ b/contrib/correctness/Tuples.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: Tuples.v,v 1.2.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: Tuples.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* Tuples *)
 
diff --git a/contrib/correctness/examples/Handbook.v b/contrib/correctness/examples/Handbook.v
index 8c983a72..abb1cc76 100644
--- a/contrib/correctness/examples/Handbook.v
+++ b/contrib/correctness/examples/Handbook.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: Handbook.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *)
+(* $Id: Handbook.v 1577 2001-04-11 07:56:19Z filliatr $ *)
 
 (* This file contains proofs of programs taken from the
  * "Handbook of Theoretical Computer Science", volume B,
diff --git a/contrib/correctness/examples/exp.v b/contrib/correctness/examples/exp.v
index dcfcec87..3142e906 100644
--- a/contrib/correctness/examples/exp.v
+++ b/contrib/correctness/examples/exp.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(*i $Id: exp.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ i*)
+(*i $Id: exp.v 1577 2001-04-11 07:56:19Z filliatr $ i*)
 
 (* Efficient computation of X^n using
  * 
diff --git a/contrib/correctness/examples/exp_int.v b/contrib/correctness/examples/exp_int.v
index accd60c2..044263ca 100644
--- a/contrib/correctness/examples/exp_int.v
+++ b/contrib/correctness/examples/exp_int.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: exp_int.v,v 1.4 2001/04/11 07:56:19 filliatr Exp $ *)
+(* $Id: exp_int.v 1577 2001-04-11 07:56:19Z filliatr $ *)
 
 (* Efficient computation of X^n using
  * 
diff --git a/contrib/correctness/examples/fact.v b/contrib/correctness/examples/fact.v
index e480c806..07e77140 100644
--- a/contrib/correctness/examples/fact.v
+++ b/contrib/correctness/examples/fact.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: fact.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *)
+(* $Id: fact.v 1577 2001-04-11 07:56:19Z filliatr $ *)
 
 (* Proof of an imperative program computing the factorial (over type nat) *)
 
diff --git a/contrib/correctness/examples/fact_int.v b/contrib/correctness/examples/fact_int.v
index cb2b0460..f463ca80 100644
--- a/contrib/correctness/examples/fact_int.v
+++ b/contrib/correctness/examples/fact_int.v
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: fact_int.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *)
+(* $Id: fact_int.v 1577 2001-04-11 07:56:19Z filliatr $ *)
 
 (* Proof of an imperative program computing the factorial (over type Z) *)
 
diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli
index 1cc7164e..70328704 100644
--- a/contrib/correctness/past.mli
+++ b/contrib/correctness/past.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: past.mli,v 1.7.6.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: past.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (*s Abstract syntax of imperative programs. *)
 
diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml
index e87ba70c..041cd81f 100644
--- a/contrib/correctness/pcic.ml
+++ b/contrib/correctness/pcic.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pcic.ml,v 1.23.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: pcic.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Util
 open Names
diff --git a/contrib/correctness/pcic.mli b/contrib/correctness/pcic.mli
index 89731472..67b152f3 100644
--- a/contrib/correctness/pcic.mli
+++ b/contrib/correctness/pcic.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(*i $Id: pcic.mli,v 1.3.16.1 2004/07/16 19:30:00 herbelin Exp $ i*)
+(*i $Id: pcic.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 open Past
 open Rawterm
diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml
index cc15c8f3..368d0281 100644
--- a/contrib/correctness/pcicenv.ml
+++ b/contrib/correctness/pcicenv.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pcicenv.ml,v 1.5.14.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: pcicenv.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 open Term
diff --git a/contrib/correctness/pcicenv.mli b/contrib/correctness/pcicenv.mli
index fc4fa0b9..365fa960 100644
--- a/contrib/correctness/pcicenv.mli
+++ b/contrib/correctness/pcicenv.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pcicenv.mli,v 1.2.16.1 2004/07/16 19:30:00 herbelin Exp $ *)
+(* $Id: pcicenv.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Penv
 open Names
diff --git a/contrib/correctness/pdb.ml b/contrib/correctness/pdb.ml
index 302db871..759e9133 100644
--- a/contrib/correctness/pdb.ml
+++ b/contrib/correctness/pdb.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pdb.ml,v 1.8.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: pdb.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 open Term
diff --git a/contrib/correctness/pdb.mli b/contrib/correctness/pdb.mli
index a0df29bd..d6e647b7 100644
--- a/contrib/correctness/pdb.mli
+++ b/contrib/correctness/pdb.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pdb.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: pdb.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Ptype
 open Past
diff --git a/contrib/correctness/peffect.ml b/contrib/correctness/peffect.ml
index 08d6b002..faf5f3d3 100644
--- a/contrib/correctness/peffect.ml
+++ b/contrib/correctness/peffect.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: peffect.ml,v 1.3.14.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: peffect.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 open Nameops
diff --git a/contrib/correctness/peffect.mli b/contrib/correctness/peffect.mli
index d6d0ce22..9a10dea4 100644
--- a/contrib/correctness/peffect.mli
+++ b/contrib/correctness/peffect.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: peffect.mli,v 1.1.16.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: peffect.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 
diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml
index 820d1cf0..7f89b1e1 100644
--- a/contrib/correctness/penv.ml
+++ b/contrib/correctness/penv.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: penv.ml,v 1.10.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: penv.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pmisc
 open Past
diff --git a/contrib/correctness/penv.mli b/contrib/correctness/penv.mli
index ef2e4c6e..6743b465 100644
--- a/contrib/correctness/penv.mli
+++ b/contrib/correctness/penv.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: penv.mli,v 1.3.8.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: penv.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Ptype
 open Past
diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml
index 40fe4c98..8415e96d 100644
--- a/contrib/correctness/perror.ml
+++ b/contrib/correctness/perror.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: perror.ml,v 1.9.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: perror.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Util
diff --git a/contrib/correctness/perror.mli b/contrib/correctness/perror.mli
index 40b2d25c..45b2acdc 100644
--- a/contrib/correctness/perror.mli
+++ b/contrib/correctness/perror.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: perror.mli,v 1.2.6.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: perror.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Util
diff --git a/contrib/correctness/pextract.ml b/contrib/correctness/pextract.ml
index 2a35d471..407567ad 100644
--- a/contrib/correctness/pextract.ml
+++ b/contrib/correctness/pextract.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pextract.ml,v 1.5.6.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: pextract.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp_control
 open Pp
diff --git a/contrib/correctness/pextract.mli b/contrib/correctness/pextract.mli
index dc5b4124..3492729c 100644
--- a/contrib/correctness/pextract.mli
+++ b/contrib/correctness/pextract.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pextract.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: pextract.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 
diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml
index aed8c5cb..076b11cd 100644
--- a/contrib/correctness/pmisc.ml
+++ b/contrib/correctness/pmisc.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pmisc.ml,v 1.18.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: pmisc.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
 
 open Pp
 open Util
@@ -216,7 +216,7 @@ let rec type_v_knsubst s = function
 and type_c_knsubst s ((id,v),e,pl,q) =
   ((id, type_v_knsubst s v), e, 
    List.map (fun p -> { p with p_value = subst_mps s p.p_value }) pl,
-   option_app (fun q -> { q with a_value = subst_mps s q.a_value }) q)
+   option_map (fun q -> { q with a_value = subst_mps s q.a_value }) q)
 
 and binder_knsubst s (id,b) = 
   (id, match b with BindType v -> BindType (type_v_knsubst s v) | _ -> b)
diff --git a/contrib/correctness/pmisc.mli b/contrib/correctness/pmisc.mli
index ec7521cc..9d96467f 100644
--- a/contrib/correctness/pmisc.mli
+++ b/contrib/correctness/pmisc.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pmisc.mli,v 1.9.6.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: pmisc.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 open Term
diff --git a/contrib/correctness/pmlize.ml b/contrib/correctness/pmlize.ml
index f899366d..e812fa57 100644
--- a/contrib/correctness/pmlize.ml
+++ b/contrib/correctness/pmlize.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pmlize.ml,v 1.7.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: pmlize.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 open Term
diff --git a/contrib/correctness/pmlize.mli b/contrib/correctness/pmlize.mli
index 95f74ef9..1f8936f0 100644
--- a/contrib/correctness/pmlize.mli
+++ b/contrib/correctness/pmlize.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pmlize.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *)
+(* $Id: pmlize.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Past
 open Penv
diff --git a/contrib/correctness/pmonad.ml b/contrib/correctness/pmonad.ml
index b8b39353..8f1b5946 100644
--- a/contrib/correctness/pmonad.ml
+++ b/contrib/correctness/pmonad.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pmonad.ml,v 1.6.16.1 2004/07/16 19:30:02 herbelin Exp $ *)
+(* $Id: pmonad.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
 
 open Util
 open Names
@@ -76,9 +76,9 @@ let rec abstract_post ren env (e,q) =
   let after_id id = id_of_string ((string_of_id id) ^ "'") in
   let (_,go) = Peffect.get_repr e in
   let al = List.map (fun id -> (id,after_id id)) go in
-  let q = option_app (named_app (subst_in_constr al)) q in
+  let q = option_map (named_app (subst_in_constr al)) q in
   let tgo = List.map (fun (id,aid) -> (aid, trad_type_in_env ren env id)) al in
-  option_app (named_app (abstract tgo)) q
+  option_map (named_app (abstract tgo)) q
 
 (* Translation of effects types in cic types.
  *
@@ -365,7 +365,7 @@ let make_app env ren args ren' (tf,cf) ((bl,cb),s,capp) c =
 	    @(eq_phi ren'' env s svi tf)
 	    @(List.map (fun c -> CC_hole c) holes))
   in
-  let qapp' = option_app (named_app (subst_in_constr svi)) qapp in
+  let qapp' = option_map (named_app (subst_in_constr svi)) qapp in
   let t = 
     make_let_in ren'' env fe [] (current_vars ren''' outf,qapp')
       (res,tyres) (t,ty)
diff --git a/contrib/correctness/pmonad.mli b/contrib/correctness/pmonad.mli
index e1400fcb..a46a040e 100644
--- a/contrib/correctness/pmonad.mli
+++ b/contrib/correctness/pmonad.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pmonad.mli,v 1.1.16.1 2004/07/16 19:30:02 herbelin Exp $ *)
+(* $Id: pmonad.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 open Term
diff --git a/contrib/correctness/pred.ml b/contrib/correctness/pred.ml
index 732dcf08..669727fc 100644
--- a/contrib/correctness/pred.ml
+++ b/contrib/correctness/pred.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pred.ml,v 1.6.14.1 2004/07/16 19:30:05 herbelin Exp $ *)
+(* $Id: pred.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Past
diff --git a/contrib/correctness/pred.mli b/contrib/correctness/pred.mli
index 2f43f4ad..a5a9549b 100644
--- a/contrib/correctness/pred.mli
+++ b/contrib/correctness/pred.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pred.mli,v 1.1.16.1 2004/07/16 19:30:05 herbelin Exp $ *)
+(* $Id: pred.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Term
 open Past
diff --git a/contrib/correctness/prename.ml b/contrib/correctness/prename.ml
index 864f6abd..4ef1982d 100644
--- a/contrib/correctness/prename.ml
+++ b/contrib/correctness/prename.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: prename.ml,v 1.3.14.1 2004/07/16 19:30:05 herbelin Exp $ *)
+(* $Id: prename.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 open Nameops
diff --git a/contrib/correctness/prename.mli b/contrib/correctness/prename.mli
index 88b49d2c..1d3ab669 100644
--- a/contrib/correctness/prename.mli
+++ b/contrib/correctness/prename.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: prename.mli,v 1.1.16.1 2004/07/16 19:30:05 herbelin Exp $ *)
+(* $Id: prename.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 
diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4
index c1f00a3d..98d43112 100644
--- a/contrib/correctness/psyntax.ml4
+++ b/contrib/correctness/psyntax.ml4
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: psyntax.ml4,v 1.29.2.1 2004/07/16 19:30:05 herbelin Exp $ *)
+(* $Id: psyntax.ml4 8752 2006-04-27 19:37:33Z herbelin $ *)
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
@@ -145,7 +145,7 @@ let bool_not loc a =
   let d = SApp ( [Variable connective_not ], [a]) in
   w d
 
-let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "ZERO"]
+let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "Z0"]
 
 (* program -> Coq AST *)
 
@@ -786,7 +786,7 @@ END
 
 VERNAC COMMAND EXTEND Correctness
   [ "Correctness" preident(str) program(pgm) then_tac(tac) ]
-   -> [ Ptactic.correctness str pgm (option_app Tacinterp.interp tac) ]
+   -> [ Ptactic.correctness str pgm (option_map Tacinterp.interp tac) ]
 END
 
 (* Show Programs *)
@@ -852,7 +852,7 @@ let pr_effects x =
   let (ro,rw) = Peffect.get_repr x in pr_reads ro ++ pr_writes rw
 
 let pr_predicate delimited { a_name = n; a_value = c } =
-  (if delimited then Ppconstrnew.pr_lconstr else Ppconstrnew.pr_constr) c ++
+  (if delimited then Ppconstr.pr_lconstr else Ppconstr.pr_constr) c ++
   (match n with Name id -> spc () ++ str "as " ++ pr_id id | Anonymous -> mt())
 
 let pr_assert b { p_name = x; p_value = v } =
@@ -870,7 +870,7 @@ let pr_post_condition_opt = function
 
 let rec pr_type_v_v8 = function
   | Array (a,v) ->
-      str "array" ++ spc() ++ Ppconstrnew.pr_constr a ++ spc() ++ str "of " ++
+      str "array" ++ spc() ++ Ppconstr.pr_constr a ++ spc() ++ str "of " ++
       pr_type_v_v8 v
   | v -> pr_type_v3 v
 
@@ -882,7 +882,7 @@ and pr_type_v3 = function
       pr_type_v_v8 v ++ pr_effects e ++ 
       pr_pre_condition_list prel ++ pr_post_condition_opt postl ++
       spc () ++ str "end"
-  | TypePure a -> Ppconstrnew.pr_constr a
+  | TypePure a -> Ppconstr.pr_constr a
   | v -> str "(" ++ pr_type_v_v8 v ++ str ")"
 
 and pr_binder = function
@@ -910,9 +910,9 @@ let pr_invariant = function
   | Some c -> hov 2 (str "invariant" ++ spc ()  ++ pr_predicate false c)
 
 let pr_variant (c1,c2) =
-  Ppconstrnew.pr_constr c1 ++
+  Ppconstr.pr_constr c1 ++
   (try Constrextern.check_same_type c2 (ast_zwf_zero dummy_loc); mt ()
-   with _ -> spc() ++ hov 0 (str "for" ++ spc () ++ Ppconstrnew.pr_constr c2))
+   with _ -> spc() ++ hov 0 (str "for" ++ spc () ++ Ppconstr.pr_constr c2))
 
 let rec pr_desc = function
   | Variable id ->
@@ -1025,7 +1025,7 @@ let rec pr_desc = function
       (* Numeral or "tt": use a printer which doesn't globalize *)
       Ppconstr.pr_constr
         (Constrextern.extern_constr_in_scope false "Z_scope" (Global.env()) c)
-  | Debug (s,p) -> str "@" ++ Pptacticnew.qsnew s ++ pr_prog p
+  | Debug (s,p) -> str "@" ++ Pptactic.qsnew s ++ pr_prog p
 
 and pr_block_st = function
   | Label s -> hov 0 (str "label" ++ spc() ++ str s)
@@ -1046,7 +1046,7 @@ and pr_prog0 b { desc = desc; pre = pre; post = post } =
     hov 0
       (if b & post<>None then str"(" ++ pr_desc desc ++ str")"
        else pr_desc desc)
-    ++ Ppconstrnew.pr_opt pr_postcondition post)
+    ++ Ppconstr.pr_opt pr_postcondition post)
 
 and pr_prog x = pr_prog0 true x
 
diff --git a/contrib/correctness/psyntax.mli b/contrib/correctness/psyntax.mli
index 18912548..c0f0990b 100644
--- a/contrib/correctness/psyntax.mli
+++ b/contrib/correctness/psyntax.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: psyntax.mli,v 1.3.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: psyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pcoq
 open Ptype
diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml
index 4b22954e..babc607d 100644
--- a/contrib/correctness/ptactic.ml
+++ b/contrib/correctness/ptactic.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ptactic.ml,v 1.30.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: ptactic.ml 8759 2006-04-28 12:24:14Z herbelin $ *)
 
 open Pp
 open Options
@@ -51,7 +51,7 @@ let coqast_of_prog p =
 
   (* 4a. traduction type *)
   let ty = Pmonad.trad_ml_type_c ren env c in
-  deb_print (Printer.prterm_env (Global.env())) ty;
+  deb_print (Printer.pr_lconstr_env (Global.env())) ty;
 
   (* 4b. traduction terme (terme intermédiaire de type cc_term) *)
   deb_mess 
@@ -65,12 +65,12 @@ let coqast_of_prog p =
     (fnl () ++ str"Pcic.constr_of_prog: Translation cc_term -> rawconstr..." ++ 
        fnl ());
   let r = Pcic.rawconstr_of_prog cc in
-  deb_print Printer.pr_rawterm r;
+  deb_print Printer.pr_lrawconstr r;
 
   (* 6. résolution implicites *)
   deb_mess (fnl () ++ str"Resolution implicits (? => Meta(n))..." ++ fnl ());
   let oc = understand_gen_tcc Evd.empty (Global.env()) [] None r in
-  deb_print (Printer.prterm_env (Global.env())) (snd oc);
+  deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc);
 
   p,oc,ty,v
 
@@ -208,8 +208,8 @@ let reduce_open_constr (em0,c) =
       | Cast (c',t) -> 
 	  (match kind_of_term c' with
 	     | Evar (ev,_) ->
-                 if not (Evd.in_dom em ev) then
-                   Evd.add em ev (Evd.map em0 ev)
+                 if not (Evd.mem em ev) then
+                   Evd.add em ev (Evd.find em0 ev)
                  else
                    em
 	     | _ -> fold_constr collect em c)
@@ -234,7 +234,7 @@ let correctness_hook _ ref =
   register pf_id None
 
 let correctness s p opttac =
-  Library.check_required_library ["Coq";"correctness";"Correctness"];
+  Coqlib.check_required_library ["Coq";"correctness";"Correctness"];
   Pmisc.reset_names();
   let p,oc,cty,v = coqast_of_prog p in
   let env = Global.env () in
@@ -248,7 +248,7 @@ let correctness s p opttac =
   deb_mess (str"Pred.red_cci: Reduction..." ++ fnl ());
   let oc = reduce_open_constr oc in
   deb_mess (str"AFTER REDUCTION:" ++ fnl ());
-  deb_print (Printer.prterm_env (Global.env())) (snd oc);
+  deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc);
   let tac = (tclTHEN (Extratactics.refine_tac oc) automatic) in
   let tac = match opttac with 
     | None -> tac
diff --git a/contrib/correctness/ptactic.mli b/contrib/correctness/ptactic.mli
index 875e0780..87378cff 100644
--- a/contrib/correctness/ptactic.mli
+++ b/contrib/correctness/ptactic.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ptactic.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: ptactic.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* The main tactic: takes a name N, a program P, creates a goal
  * of name N with the functional specification of P, then apply the Refine
diff --git a/contrib/correctness/ptype.mli b/contrib/correctness/ptype.mli
index f2dc85e3..be181bcc 100644
--- a/contrib/correctness/ptype.mli
+++ b/contrib/correctness/ptype.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ptype.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: ptype.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Term
 
diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml
index 9047a925..91c1f293 100644
--- a/contrib/correctness/ptyping.ml
+++ b/contrib/correctness/ptyping.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ptyping.ml,v 1.7.6.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: ptyping.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Util
diff --git a/contrib/correctness/ptyping.mli b/contrib/correctness/ptyping.mli
index 0c0d5905..eaf548b1 100644
--- a/contrib/correctness/ptyping.mli
+++ b/contrib/correctness/ptyping.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: ptyping.mli,v 1.3.6.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: ptyping.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Names
 open Term
diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml
index 48f0781a..18c3ba35 100644
--- a/contrib/correctness/putil.ml
+++ b/contrib/correctness/putil.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: putil.ml,v 1.10.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: putil.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
 
 open Util
 open Names
@@ -41,7 +41,7 @@ let anonymous x = { a_name = Anonymous; a_value = x }
 let anonymous_pre b x = { p_assert = b; p_name = Anonymous; p_value = x }
 
 let force_name f x =
-  option_app (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x
+  option_map (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x
 
 let force_post_name x = force_name post_name x
 
@@ -143,7 +143,7 @@ let rec type_c_subst s ((id,t),e,p,q) =
   let s' = s @ List.map (fun (x,x') -> (at_id x "", at_id x' "")) s in
   (id, type_v_subst s t), Peffect.subst s e,
   List.map (pre_app (subst_in_constr s)) p,
-  option_app (post_app (subst_in_constr s')) q
+  option_map (post_app (subst_in_constr s')) q
 
 and type_v_subst s = function
     Ref v -> Ref (type_v_subst s v)
@@ -160,7 +160,7 @@ and binder_subst s = function
 let rec type_c_rsubst s ((id,t),e,p,q) =
   (id, type_v_rsubst s t), e,
     List.map (pre_app (real_subst_in_constr s)) p,
-    option_app (post_app (real_subst_in_constr s)) q
+    option_map (post_app (real_subst_in_constr s)) q
 
 and type_v_rsubst s = function
     Ref v -> Ref (type_v_rsubst s v)
@@ -231,26 +231,26 @@ and c_of_constr c =
 open Pp
 open Util
 
-let prterm x = Printer.prterm_env (Global.env()) x
+let pr_lconstr x = Printer.pr_lconstr_env (Global.env()) x
 
 let pp_pre = function
     [] -> (mt ())
   | l  ->
       hov 0 (str"pre " ++ 
 	       prlist_with_sep (fun () -> (spc ())) 
-		 (fun x -> prterm x.p_value) l)
+		 (fun x -> pr_lconstr x.p_value) l)
 
 let pp_post = function
     None -> (mt ())
-  | Some c -> hov 0 (str"post " ++ prterm c.a_value)
+  | Some c -> hov 0 (str"post " ++ pr_lconstr c.a_value)
 
 let rec pp_type_v = function
     Ref v -> hov 0 (pp_type_v v ++ spc () ++ str"ref")
-  | Array (cc,v) -> hov 0 (str"array " ++ prterm cc ++ str" of " ++ pp_type_v v)
+  | Array (cc,v) -> hov 0 (str"array " ++ pr_lconstr cc ++ str" of " ++ pp_type_v v)
   | Arrow (b,c) -> 
       hov 0 (prlist_with_sep (fun () -> (mt ())) pp_binder b ++ 
 	       pp_type_c c)
-  | TypePure c -> prterm c
+  | TypePure c -> pr_lconstr c
 
 and pp_type_c ((id,v),e,p,q) =
   hov 0 (str"returns " ++ pr_id id ++ str":" ++ pp_type_v v ++ spc () ++ 
@@ -297,7 +297,7 @@ let rec pp_cc_term = function
   | CC_case _ ->
       hov 0 (str"<Case: not yet implemented>")
   | CC_expr c ->
-      hov 0 (prterm c)
+      hov 0 (pr_lconstr c)
   | CC_hole c ->
-      (str"(?::" ++ prterm c ++ str")")
+      (str"(?::" ++ pr_lconstr c ++ str")")
 
diff --git a/contrib/correctness/putil.mli b/contrib/correctness/putil.mli
index b44774ae..6c487f3f 100644
--- a/contrib/correctness/putil.mli
+++ b/contrib/correctness/putil.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: putil.mli,v 1.3.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: putil.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Names
diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml
index 58bef673..f422c5cd 100644
--- a/contrib/correctness/pwp.ml
+++ b/contrib/correctness/pwp.ml
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pwp.ml,v 1.8.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: pwp.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
 
 open Util
 open Names
@@ -64,7 +64,7 @@ let update_post env top ef c =
 let force_post up env top q e =
   let (res,ef,p,_) = e.info.kappa in
   let q' = 
-    if up then option_app (named_app (update_post env top ef)) q else q 
+    if up then option_map (named_app (update_post env top ef)) q else q 
   in
   let i = { env = e.info.env; kappa = (res,ef,p,q') } in
   { desc = e.desc; pre = e.pre; post = q'; loc = e.loc; info = i }
@@ -260,7 +260,7 @@ and propagate ren p =
     | Apply (f,l) ->
 	let _,(_,so,ok),(_,_,_,qapp) = effect_app ren env f l in
 	if ok then
-	  let q = option_app (named_app (real_subst_in_constr so)) qapp in
+	  let q = option_map (named_app (real_subst_in_constr so)) qapp in
 	  post_if_none env q p
 	else
 	  p
@@ -285,7 +285,7 @@ and propagate ren p =
 	    None -> Some (anonymous s)
 	  | Some i -> Some { a_value = conj i.a_value s; a_name = i.a_name }
 	in
-	let q = option_app (named_app abstract_unit) q in
+	let q = option_map (named_app abstract_unit) q in
 	post_if_none env q p
 
     | SApp ([Variable id], [e1;e2]) 
diff --git a/contrib/correctness/pwp.mli b/contrib/correctness/pwp.mli
index 015031a0..4027a623 100644
--- a/contrib/correctness/pwp.mli
+++ b/contrib/correctness/pwp.mli
@@ -8,7 +8,7 @@
 
 (* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
 
-(* $Id: pwp.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *)
+(* $Id: pwp.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Term
 open Penv
diff --git a/contrib/dp/TODO b/contrib/dp/TODO
new file mode 100644
index 00000000..387cacdf
--- /dev/null
+++ b/contrib/dp/TODO
@@ -0,0 +1,28 @@
+
+TODO
+----
+
+- axiomes pour les prédicats récursifs comme
+
+  Fixpoint even (n:nat) : Prop :=
+  match n with 
+  O => True
+  | S O => False
+  | S (S p) => even p
+  end.
+
+  ou encore In sur les listes du module Coq List.
+
+- discriminate
+
+- inversion (Set et Prop)
+
+
+BUGS
+----
+
+- value = Some : forall A:Set, A -> option A
+
+  -> eta_expanse échoue sur assert false (ligne 147)
+
+
diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml
new file mode 100644
index 00000000..131dd029
--- /dev/null
+++ b/contrib/dp/dp.ml
@@ -0,0 +1,759 @@
+(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *)
+(* Tactics to call decision procedures *)
+
+(* Works in two steps: 
+
+   - first the Coq context and the current goal are translated in
+     Polymorphic First-Order Logic (see fol.mli in this directory)
+
+   - then the resulting query is passed to the Why tool that translates
+     it to the syntax of the selected prover (Simplify, CVC Lite, haRVey,
+     Zenon)
+*)
+
+open Util
+open Pp
+open Term
+open Tacmach
+open Tactics
+open Tacticals
+open Fol
+open Names
+open Nameops
+open Termops
+open Coqlib
+open Hipattern
+open Libnames
+open Declarations
+
+let debug = ref false
+
+let logic_dir = ["Coq";"Logic";"Decidable"]
+let coq_modules =
+  init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
+    @ [["Coq"; "omega"; "OmegaLemmas"]]
+
+let constant = gen_constant_in_modules "dp" coq_modules
+
+let coq_Z = lazy (constant "Z")
+let coq_Zplus = lazy (constant "Zplus")
+let coq_Zmult = lazy (constant "Zmult")
+let coq_Zopp = lazy (constant "Zopp")
+let coq_Zminus = lazy (constant "Zminus")
+let coq_Zdiv = lazy (constant "Zdiv")
+let coq_Zs = lazy (constant "Zs")
+let coq_Zgt = lazy (constant "Zgt")
+let coq_Zle = lazy (constant "Zle")
+let coq_Zge = lazy (constant "Zge")
+let coq_Zlt = lazy (constant "Zlt")
+let coq_Z0 = lazy (constant "Z0")
+let coq_Zpos = lazy (constant "Zpos")
+let coq_Zneg = lazy (constant "Zneg")
+let coq_xH = lazy (constant "xH")
+let coq_xI = lazy (constant "xI")
+let coq_xO = lazy (constant "xO")
+
+(* not Prop typed expressions *)
+exception NotProp
+
+(* not first-order expressions *)
+exception NotFO
+
+(* Renaming of Coq globals *)
+
+let global_names = Hashtbl.create 97
+let used_names = Hashtbl.create 97
+
+let rename_global r =
+  try 
+    Hashtbl.find global_names r
+  with Not_found ->
+    let rec loop id = 
+      if Hashtbl.mem used_names id then 
+	loop (lift_ident id)
+      else begin 
+	Hashtbl.add used_names id ();
+	let s = string_of_id id in
+	Hashtbl.add global_names r s; 
+	s
+      end
+    in
+    loop (Nametab.id_of_global r)
+
+let foralls =
+  List.fold_right 
+    (fun (x,t) p -> Forall (x, t, p))
+
+let fresh_var = function
+  | Anonymous -> rename_global (VarRef (id_of_string "x"))
+  | Name x -> rename_global (VarRef x)
+
+(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of 
+   env names, and returns the new variables together with the new 
+   environment *)
+let coq_rename_vars env vars =
+  let avoid = ref (ids_of_named_context (Environ.named_context env)) in
+  List.fold_right
+    (fun (na,t) (newvars, newenv) -> 
+       let id = next_name_away na !avoid in
+       avoid := id :: !avoid;
+       id :: newvars, Environ.push_named (id, None, t) newenv)
+    vars ([],env)
+
+(* extract the prenex type quantifications i.e.
+   type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *)
+let decomp_type_quantifiers env t =
+  let rec loop vars t = match kind_of_term t with
+    | Prod (n, a, t) when is_Set a -> 
+	loop ((n,a) :: vars) t
+    | _ -> 
+	let vars, env = coq_rename_vars env vars in
+	let t = substl (List.map mkVar vars) t in
+	List.rev vars, env, t
+  in
+  loop [] t
+
+(* same thing with lambda binders (for axiomatize body) *)
+let decomp_type_lambdas env t =
+  let rec loop vars t = match kind_of_term t with
+    | Lambda (n, a, t) when is_Set a -> 
+	loop ((n,a) :: vars) t
+    | _ -> 
+	let vars, env = coq_rename_vars env vars in
+	let t = substl (List.map mkVar vars) t in
+	List.rev vars, env, t
+  in
+  loop [] t
+
+let decompose_arrows = 
+  let rec arrows_rec l c = match kind_of_term c with
+    | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c
+    | Cast (c,_,_) -> arrows_rec l c
+    | _ -> List.rev l, c
+  in 
+  arrows_rec []
+
+let rec eta_expanse t vars env i =
+  assert (i >= 0);
+  if i = 0 then
+    t, vars, env
+  else
+    match kind_of_term (Typing.type_of env Evd.empty t) with
+      | Prod (n, a, b) when not (dependent (mkRel 1) b) ->
+	  let avoid = ids_of_named_context (Environ.named_context env) in
+	  let id = next_name_away n avoid in
+	  let env' = Environ.push_named (id, None, a) env in
+	  let t' = mkApp (t, [| mkVar id |]) in
+	  eta_expanse t' (id :: vars) env' (pred i)
+      | _ -> 
+	  assert false
+
+let rec skip_k_args k cl = match k, cl with
+  | 0, _ -> cl
+  | _, _ :: cl -> skip_k_args (k-1) cl
+  | _, [] -> raise NotFO
+
+(* Coq global references *)
+
+type global = Gnot_fo | Gfo of Fol.decl
+
+let globals = ref Refmap.empty
+let globals_stack = ref []
+
+(* synchronization *)
+let () =
+  Summary.declare_summary "Dp globals"
+    { Summary.freeze_function = (fun () -> !globals, !globals_stack);
+      Summary.unfreeze_function = 
+	(fun (g,s) -> globals := g; globals_stack := s);
+      Summary.init_function = (fun () -> ());
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let add_global r d = globals := Refmap.add r d !globals
+let mem_global r = Refmap.mem r !globals
+let lookup_global r = match Refmap.find r !globals with
+  | Gnot_fo -> raise NotFO
+  | Gfo d -> d
+
+let locals = Hashtbl.create 97
+
+let lookup_local r =  match Hashtbl.find locals r with
+  | Gnot_fo -> raise NotFO
+  | Gfo d -> d
+
+let iter_all_constructors i f =  
+  let _, oib = Global.lookup_inductive i in
+  Array.iteri
+    (fun j tj -> f j (mkConstruct (i, j+1)))
+    oib.mind_nf_lc
+
+
+(* injection c [t1,...,tn] adds the injection axiom
+     forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. 
+       c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *)
+
+let injection c l =
+  let i = ref 0 in
+  let var s = incr i; id_of_string (s ^ string_of_int !i) in
+  let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in
+  i := 0;
+  let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in
+  let f = 
+    List.fold_right2 
+      (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p))
+      xl yl True
+  in
+  let vars = List.map (fun (x,_) -> App(x,[])) in
+  let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in
+  let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in
+  let f = foralls xl (foralls yl f) in
+  let ax = Axiom ("injection_" ^ c, f) in
+  globals_stack := ax :: !globals_stack
+
+(* rec_names_for c [|n1;...;nk|] builds the list of constant names for 
+   identifiers n1...nk with the same path as c, if they exist; otherwise
+   raises Not_found *)
+let rec_names_for c =
+  let mp,dp,_ = Names.repr_con c in
+  array_map_to_list
+    (function 
+       | Name id -> 
+	   let c' = Names.make_con mp dp (label_of_id id) in
+	   ignore (Global.lookup_constant c');
+	   msgnl (Printer.pr_constr (mkConst c'));
+	   c'
+       | Anonymous ->
+	   raise Not_found)
+
+(* abstraction tables *)
+
+let term_abstractions = Hashtbl.create 97
+
+let new_abstraction = 
+  let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r
+
+(* Arithmetic constants *)
+
+exception NotArithConstant
+
+(* translates a closed Coq term p:positive into a FOL term of type int *)
+let rec tr_positive p = match kind_of_term p with
+  | Term.Construct _ when p = Lazy.force coq_xH ->
+      Cst 1
+  | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
+      Plus (Mult (Cst 2, tr_positive a), Cst 1)
+  | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
+      Mult (Cst 2, tr_positive a)
+  | Term.Cast (p, _, _) ->
+      tr_positive p
+  | _ ->
+      raise NotArithConstant
+
+(* translates a closed Coq term t:Z into a FOL term of type int *)
+let rec tr_arith_constant t = match kind_of_term t with
+  | Term.Construct _ when t = Lazy.force coq_Z0 ->
+      Cst 0
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos ->
+      tr_positive a
+  | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg ->
+      Moins (Cst 0, tr_positive a)
+  | Term.Cast (t, _, _) ->
+      tr_arith_constant t
+  | _ -> 
+      raise NotArithConstant
+
+(* translate a Coq term t:Set into a FOL type expression;
+   tv = list of type variables *)
+and tr_type tv env t =
+  let t = Reductionops.nf_betadeltaiota env Evd.empty t in
+  if t = Lazy.force coq_Z then 
+    Tid ("int", [])
+  else match kind_of_term t with
+    | Var x when List.mem x tv ->
+	Tvar (string_of_id x)
+    | _ ->
+	let f, cl = decompose_app t in
+	begin try
+	  let r = global_of_constr f in
+	  match tr_global env r with
+	    | DeclType (id, k) -> 
+		assert (k = List.length cl); (* since t:Set *)
+		Tid (id, List.map (tr_type tv env) cl)
+	    | _ -> 
+		raise NotFO
+	with 
+	  | Not_found ->
+	      raise NotFO
+	  | NotFO -> 
+	      (* we need to abstract some part of (f cl) *)
+	      (*TODO*)
+	      raise NotFO
+	end
+
+and make_term_abstraction tv env c =
+  let ty = Typing.type_of env Evd.empty c in
+  let id = new_abstraction () in
+  match tr_decl env id ty with
+    | DeclFun (id,_,_,_) as d ->
+	begin try
+	  Hashtbl.find term_abstractions c
+	with Not_found ->
+	  Hashtbl.add term_abstractions c id;
+	  globals_stack := d :: !globals_stack;
+	  id
+	end
+    | _ ->
+	raise NotFO
+
+(* translate a Coq declaration id:ty in a FOL declaration, that is either
+   - a type declaration : DeclType (id, n) where n:int is the type arity
+   - a function declaration : DeclFun (id, tl, t) ; that includes constants
+   - a predicate declaration : DeclPred (id, tl)
+   - an axiom : Axiom (id, p)
+ *)
+and tr_decl env id ty =
+  let tv, env, t = decomp_type_quantifiers env ty in
+  if is_Set t then
+    DeclType (id, List.length tv)
+  else if is_Prop t then
+    DeclPred (id, List.length tv, [])
+  else 
+    let s = Typing.type_of env Evd.empty t in
+    if is_Prop s then
+      Axiom (id, tr_formula tv [] env t)
+    else
+      let l, t = decompose_arrows t in
+      let l = List.map (tr_type tv env) l in
+      if is_Prop t then
+	DeclPred(id, List.length tv, l)
+      else 
+	let s = Typing.type_of env Evd.empty t in
+	if is_Set s then 
+	  DeclFun(id, List.length tv, l, tr_type tv env t)
+	else 
+	  raise NotFO
+
+(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *)
+and tr_global env r = match r with
+  | VarRef id ->
+      lookup_local id
+  | r ->
+      try
+	lookup_global r
+      with Not_found ->
+	try
+	  let ty = Global.type_of_global r in
+	  let id = rename_global r in
+	  let d = tr_decl env id ty in
+	  (* r can be already declared if it is a constructor *)
+	  if not (mem_global r) then begin 
+	    add_global r (Gfo d);
+	    globals_stack := d :: !globals_stack
+	  end;
+	  begin try axiomatize_body env r id d with NotFO -> () end;
+	  d
+	with NotFO ->
+	  add_global r Gnot_fo;
+	  raise NotFO
+
+and axiomatize_body env r id d = match r with
+  | VarRef _ -> 
+      assert false
+  | ConstRef c ->
+      begin match (Global.lookup_constant c).const_body with
+	| Some b ->
+	    let b = force b in
+	    let tv, env, b = decomp_type_lambdas env b in
+	    let axioms =
+	      (match d with
+		 | DeclPred (id, _, []) ->
+		     let value = tr_formula tv [] env b in
+		     [id, Iff (Fatom (Pred (id, [])), value)]
+		 | DeclFun (id, _, [], _) ->
+		     let value = tr_term tv [] env b in
+		     [id, Fatom (Eq (Fol.App (id, []), value))]
+		 | DeclFun (id, _, l, _) | DeclPred (id, _, l) ->
+		     Format.eprintf "axiomatize_body %S@." id;
+		     let b = match kind_of_term b with
+		       (* a single recursive function *)
+		       | Fix (_, (_,_,[|b|])) -> 
+			   subst1 (mkConst c) b
+                       (* mutually recursive functions *)
+		       | Fix ((_,i), (names,_,bodies)) ->
+                           (* we only deal with named functions *)
+			   begin try
+			     let l = rec_names_for c names in
+			     substl (List.rev_map mkConst l) bodies.(i)
+			   with Not_found ->
+			     b
+			   end
+		       | _ -> 
+			   b
+		     in
+		     let vars, t = decompose_lam b in
+		     let n = List.length l in
+		     let k = List.length vars in
+		     assert (k <= n);
+		     let vars, env = coq_rename_vars env vars in
+		     let t = substl (List.map mkVar vars) t in
+		     let t, vars, env = eta_expanse t vars env (n-k) in
+		     let vars = List.rev vars in
+		     let bv = vars in
+		     let vars = List.map (fun x -> string_of_id x) vars in
+		     let fol_var x =
+		       Fol.App (x, []) in
+		     let fol_vars = List.map fol_var vars in
+		     let vars = List.combine vars l in
+		     begin match d with
+		       | DeclFun _ ->
+			   begin match kind_of_term t with
+			     | Case (ci, _, e, br) ->
+				 equations_for_case env id vars tv bv ci e br
+			     | _ -> 
+				 let p = 
+				   Fatom (Eq (App (id, fol_vars), 
+					      tr_term tv bv env t)) 
+				 in
+				 [id, foralls vars p]
+			   end
+		       | DeclPred _ ->
+			   let value = tr_formula tv bv env t in
+			   let p = Iff (Fatom (Pred (id, fol_vars)), value) in
+			   [id, foralls vars p]
+		       | _ ->
+			   assert false
+		     end
+		 | DeclType _ ->
+		     raise NotFO
+		 | Axiom _ -> assert false)
+	    in
+	    let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in
+	    globals_stack := axioms @ !globals_stack
+	| None -> 
+	    () (* Coq axiom *)
+      end
+  | IndRef i ->
+      iter_all_constructors i
+	(fun _ c ->
+	   let rc = reference_of_constr c in
+	   try
+	     begin match tr_global env rc with
+	       | DeclFun (_, _, [], _) -> ()
+	       | DeclFun (idc, _, al, _) -> injection idc al
+	       | _ -> ()
+	     end
+	   with NotFO ->
+	     ())
+  | _ -> ()
+
+and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
+  | Var x when List.exists (fun (y, _) -> string_of_id x = y) vars ->
+      let eqs = ref [] in
+      iter_all_constructors ci.ci_ind
+	(fun j cj ->
+	   try
+	     let cjr = reference_of_constr cj in
+	     begin match tr_global env cjr with
+	       | DeclFun (idc, _, l, _) ->
+		   let b = br.(j) in
+		   let rec_vars, b = decompose_lam b in
+		   let rec_vars, env = coq_rename_vars env rec_vars in
+		   let b = substl (List.map mkVar rec_vars) b in
+		   let rec_vars = List.rev rec_vars in
+		   let bv = bv @ rec_vars in
+		   let rec_vars = List.map string_of_id rec_vars in
+		   let fol_var x =
+		     Fol.App (x, []) in
+		   let fol_rec_vars = List.map fol_var rec_vars in
+		   let fol_rec_term = App (idc, fol_rec_vars) in
+		   let rec_vars = List.combine rec_vars l in
+		   let fol_vars = List.map fst vars in
+		   let fol_vars = List.map fol_var fol_vars in
+		   let fol_vars = List.map (fun y -> match y with
+					      | App (id, _) ->
+						  if id = string_of_id x
+						  then fol_rec_term
+						  else y
+					      | _ -> y)
+				    fol_vars in
+		   let vars = vars @ rec_vars in
+		   let rec remove l e = match l with
+		     | [] -> []
+		     | (y, t)::l' -> if y = string_of_id e then l'
+		       else (y, t)::(remove l' e) in
+		   let vars = remove vars x in
+		   let p = 
+		     Fatom (Eq (App (id, fol_vars), 
+				tr_term tv bv env b))
+		   in
+		   eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs
+	       | _ -> 
+		   assert false end
+	   with NotFO ->
+	     ());
+      !eqs
+  | _ ->
+      raise NotFO
+
+(* assumption: t:T:Set *)
+and tr_term tv bv env t = match kind_of_term t with
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> 
+      Plus (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> 
+      Moins (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> 
+      Mult (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> 
+      Div (tr_term tv bv env a, tr_term tv bv env b)
+  | Term.Var id when List.mem id bv ->
+      App (string_of_id id, [])
+  | _ ->
+      try
+	tr_arith_constant t
+      with NotArithConstant ->
+	let f, cl = decompose_app t in
+	begin try
+	  let r = global_of_constr f in
+	  match tr_global env r with
+	    | DeclFun (s, k, _, _) -> 
+		let cl = skip_k_args k cl in
+		Fol.App (s, List.map (tr_term tv bv env) cl)
+	    | _ -> 
+		raise NotFO
+	with 
+	  | Not_found ->
+	      raise NotFO
+	  | NotFO -> (* we need to abstract some part of (f cl) *)
+	      let rec abstract app = function
+		| [] ->
+		    Fol.App (make_term_abstraction tv env app, [])
+		| x :: l as args ->
+		    begin try
+		      let s = make_term_abstraction tv env app in
+		      Fol.App (s, List.map (tr_term tv bv env) args)
+		    with NotFO ->
+		      abstract (applist (app, [x])) l
+		    end
+	      in
+	      let app,l = match cl with 
+		| x :: l -> applist (f, [x]), l | [] -> raise NotFO
+	      in
+	      abstract app l
+	end
+
+and quantifiers n a b tv bv env =
+  let vars, env = coq_rename_vars env [n,a] in
+  let id = match vars with [x] -> x | _ -> assert false in
+  let b = subst1 (mkVar id) b in
+  let t = tr_type tv env a in
+  let bv = id :: bv in
+  id, t, bv, env, b
+
+(* assumption: f is of type Prop *)
+and tr_formula tv bv env f =
+  let c, args = decompose_app f in
+  match kind_of_term c, args with
+    | Var id, [] -> 
+	Fatom (Pred (rename_global (VarRef id), []))
+    | _, [t;a;b] when c = build_coq_eq () ->
+	let ty = Typing.type_of env Evd.empty t in
+	if is_Set ty then
+	  let _ = tr_type tv env t in
+	  Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b))
+	else 
+	  raise NotFO
+    | _, [a;b] when c = Lazy.force coq_Zle ->
+	Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Zlt ->
+	Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Zge ->
+	Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [a;b] when c = Lazy.force coq_Zgt ->
+	Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
+    | _, [] when c = build_coq_False () ->
+	False
+    | _, [] when c = build_coq_True () ->
+	True
+    | _, [a] when c = build_coq_not () ->
+	Not (tr_formula tv bv env a)
+    | _, [a;b] when c = build_coq_and () ->
+	And (tr_formula tv bv env a, tr_formula tv bv env b)
+    | _, [a;b] when c = build_coq_or () ->
+	Or (tr_formula tv bv env a, tr_formula tv bv env b)
+    | Prod (n, a, b), _ ->
+	if is_imp_term f then
+	  Imp (tr_formula tv bv env a, tr_formula tv bv env b)
+	else
+	  let id, t, bv, env, b = quantifiers n a b tv bv env in
+	  Forall (string_of_id id, t, tr_formula tv bv env b)
+    | _, [_; a] when c = build_coq_ex () ->
+	begin match kind_of_term a with
+	  | Lambda(n, a, b) ->
+	      let id, t, bv, env, b = quantifiers n a b tv bv env in
+	      Exists (string_of_id id, t, tr_formula tv bv env b)
+	  | _ -> 
+	      (* unusual case of the shape (ex p) *)
+	      raise NotFO (* TODO: we could eta-expanse *)
+	end
+    | _ ->
+	begin try
+	  let r = global_of_constr c in
+	  match tr_global env r with
+	    | DeclPred (s, k, _) -> 
+		let args = skip_k_args k args in
+		Fatom (Pred (s, List.map (tr_term tv bv env) args))
+	    | _ -> 
+		raise NotFO
+	with Not_found ->
+	  raise NotFO
+	end
+
+
+let tr_goal gl =
+  Hashtbl.clear locals;
+  let tr_one_hyp (id, ty) = 
+    try
+      let s = rename_global (VarRef id) in
+      let d = tr_decl (pf_env gl) s ty in
+      Hashtbl.add locals id (Gfo d);
+      d
+    with NotFO ->
+      Hashtbl.add locals id Gnot_fo;
+      raise NotFO
+  in
+  let hyps =
+    List.fold_right 
+      (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc)
+      (pf_hyps_types gl) []
+  in
+  let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in
+  let hyps = List.rev_append !globals_stack (List.rev hyps) in
+  hyps, c
+
+
+type prover = Simplify | CVCLite | Harvey | Zenon
+
+let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ())
+
+let sprintf = Format.sprintf
+
+let call_simplify fwhy =
+  let cmd = sprintf "why --simplify %s" fwhy in
+  if Sys.command cmd <> 0 then error ("Call to " ^ cmd ^ " failed");
+  let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in
+  let cmd = 
+    sprintf "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" fsx
+  in
+  let out = Sys.command cmd in
+  let r = if out = 0 then Valid else if out = 1 then Invalid else Timeout in
+  if not !debug then remove_files [fwhy; fsx];
+  r
+
+let call_zenon fwhy =
+  let cmd = sprintf "why --no-prelude --no-zenon-prelude --zenon %s" fwhy in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+  let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in
+  let cmd = 
+    sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" fznn
+  in
+  let out = Sys.command cmd in
+  let r = 
+    if out = 0 then Valid 
+    else if out = 1 then Invalid 
+    else if out = 137 then Timeout 
+    else anomaly ("malformed Zenon input file " ^ fznn)
+  in
+  if not !debug then remove_files [fwhy; fznn];
+  r
+
+let call_cvcl fwhy =
+  let cmd = sprintf "why --cvcl %s" fwhy in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+  let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in
+  let cmd = 
+    sprintf "timeout 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" fcvc
+  in
+  let out = Sys.command cmd in
+  let r = if out = 0 then Valid else if out = 1 then Invalid else Timeout in
+  if not !debug then remove_files [fwhy; fcvc];
+  r
+
+let call_harvey fwhy =
+  let cmd = sprintf "why --harvey %s" fwhy in
+  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+  let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in
+  let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in
+  if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed");
+  let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in
+  let outf = Filename.temp_file "rv" ".out" in
+  let out = 
+    Sys.command (sprintf "timeout 10 rv -e\"-T 2000\" %s > %s 2>&1" f outf) 
+  in
+  let r =
+    if out <> 0 then 
+      Timeout
+    else
+      let cmd = 
+	sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf
+      in
+      if Sys.command cmd = 0 then Valid else Invalid
+  in
+  if not !debug then remove_files [fwhy; frv; outf];
+  r
+
+let call_prover prover q =
+  let fwhy = Filename.temp_file "coq_dp" ".why" in
+  Dp_why.output_file fwhy q;
+  if !debug then ignore (Sys.command (sprintf "cat %s" fwhy));
+  match prover with
+    | Simplify -> call_simplify fwhy
+    | Zenon -> call_zenon fwhy
+    | CVCLite -> call_cvcl fwhy
+    | Harvey -> call_harvey fwhy
+  
+let dp prover gl =
+  let concl_type = pf_type_of gl (pf_concl gl) in
+  if not (is_Prop concl_type) then error "Conclusion is not a Prop";
+  try 
+    let q = tr_goal gl in
+    begin match call_prover prover q with
+      | Valid -> Tactics.admit_as_an_axiom gl
+      | Invalid -> error "Invalid"
+      | DontKnow -> error "Don't know"
+      | Timeout -> error "Timeout"
+    end
+  with NotFO ->
+    error "Not a first order goal"
+  
+
+let simplify = tclTHEN intros (dp Simplify)
+let cvc_lite = tclTHEN intros (dp CVCLite)
+let harvey = dp Harvey
+let zenon = tclTHEN intros (dp Zenon)
+
+let dp_hint l =
+  let env = Global.env () in
+  let one_hint (qid,r) = 
+    if not (mem_global r) then begin
+      let ty = Global.type_of_global r in
+      let s = Typing.type_of env Evd.empty ty in
+      if is_Prop s then
+	try
+	  let id = rename_global r in
+	  let d = Axiom (id, tr_formula [] [] env ty) in
+	  add_global r (Gfo d);
+	  globals_stack := d :: !globals_stack
+	with NotFO ->
+	  add_global r Gnot_fo;
+	  msg_warning
+	    (pr_reference qid ++ 
+	     str " ignored (not a first order proposition)")
+	else begin
+	  add_global r Gnot_fo;
+	  msg_warning
+	    (pr_reference qid ++ str " ignored (not a proposition)")
+	end
+    end
+  in
+  List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l)
diff --git a/contrib/dp/dp.mli b/contrib/dp/dp.mli
new file mode 100644
index 00000000..3dad469c
--- /dev/null
+++ b/contrib/dp/dp.mli
@@ -0,0 +1,12 @@
+
+open Libnames
+open Proof_type
+
+val simplify : tactic
+val cvc_lite : tactic
+val harvey : tactic
+val zenon : tactic
+
+val dp_hint : reference list -> unit
+
+
diff --git a/contrib/dp/dp_cvcl.ml b/contrib/dp/dp_cvcl.ml
new file mode 100644
index 00000000..05d43081
--- /dev/null
+++ b/contrib/dp/dp_cvcl.ml
@@ -0,0 +1,112 @@
+
+open Format
+open Fol
+
+let rec print_list sep print fmt = function
+  | [] -> ()
+  | [x] -> print fmt x
+  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
+
+let space fmt () = fprintf fmt "@ "
+let comma fmt () = fprintf fmt ",@ "
+
+let rec print_term fmt = function
+  | Cst n -> 
+      fprintf fmt "%d" n
+  | Plus (a, b) ->
+      fprintf fmt "@[(%a@ +@ %a)@]" print_term a print_term b
+  | Moins (a, b) ->
+      fprintf fmt "@[(%a@ -@ %a)@]" print_term a print_term b
+  | Mult (a, b) ->
+      fprintf fmt "@[(%a@ *@ %a)@]" print_term a print_term b
+  | Div (a, b) ->
+      fprintf fmt "@[(%a@ /@ %a)@]" print_term a print_term b
+  | App (id, []) ->
+      fprintf fmt "@[%s@]" id
+  | App (id, tl) ->
+      fprintf fmt "@[%s(%a)@]" id print_terms tl
+
+and print_terms fmt tl = 
+  print_list comma print_term fmt tl
+
+let rec print_predicate fmt p = 
+  let pp = print_predicate in 
+  match p with
+  | True ->
+      fprintf fmt "TRUE"
+  | False ->
+      fprintf fmt "FALSE"
+  | Fatom (Eq (a, b)) ->
+      fprintf fmt "@[(%a = %a)@]" print_term a print_term b
+  | Fatom (Le (a, b)) ->
+      fprintf fmt "@[(%a@ <= %a)@]" print_term a print_term b
+  | Fatom (Lt (a, b))->
+      fprintf fmt "@[(%a@ < %a)@]" print_term a print_term b
+  | Fatom (Ge (a, b)) ->
+      fprintf fmt "@[(%a@ >= %a)@]" print_term a print_term b
+  | Fatom (Gt (a, b)) ->
+      fprintf fmt "@[(%a@ > %a)@]" print_term a print_term b
+  | Fatom (Pred (id, [])) ->
+      fprintf fmt "@[%s@]" id
+  | Fatom (Pred (id, tl)) ->
+      fprintf fmt "@[%s(%a)@]" id print_terms tl
+  | Imp (a, b) ->
+      fprintf fmt "@[(%a@ => %a)@]" pp a pp b
+  | And (a, b) ->
+      fprintf fmt "@[(%a@ AND@ %a)@]" pp a pp b
+  | Or (a, b) ->
+      fprintf fmt "@[(%a@ OR@ %a)@]" pp a pp b
+  | Not a ->
+      fprintf fmt "@[(NOT@ %a)@]" pp a
+  | Forall (id, t, p) -> 
+      fprintf fmt "@[(FORALL (%s:%s): %a)@]" id t pp p
+  | Exists (id, t, p) -> 
+      fprintf fmt "@[(EXISTS (%s:%s): %a)@]" id t pp p
+
+let rec string_of_type_list  = function
+  | [] -> assert false
+  | [e] -> e
+  | e :: l' -> e ^ ", " ^ (string_of_type_list l')
+
+let print_query fmt (decls,concl) =
+  let print_decl = function
+    | DeclVar (id, [], t) ->
+	fprintf fmt "@[%s: %s;@]@\n" id t
+    | DeclVar (id, [e], t) ->
+	fprintf fmt "@[%s: [%s -> %s];@]@\n"
+	  id e t
+    | DeclVar (id, l, t) ->
+	fprintf fmt "@[%s: [[%s] -> %s];@]@\n"
+	  id (string_of_type_list l) t
+    | DeclPred (id, []) ->
+	fprintf fmt "@[%s: BOOLEAN;@]@\n" id
+     | DeclPred (id, [e]) ->
+	fprintf fmt "@[%s: [%s -> BOOLEAN];@]@\n"
+	  id e
+   | DeclPred (id, l) ->
+	fprintf fmt "@[%s: [[%s] -> BOOLEAN];@]@\n"
+	  id (string_of_type_list l)
+    | DeclType id ->
+	fprintf fmt "@[%s: TYPE;@]@\n" id
+    | Assert (id, f)  -> 
+	fprintf fmt "@[ASSERT %% %s@\n %a;@]@\n" id print_predicate f
+  in
+  List.iter print_decl decls;
+  fprintf fmt "QUERY %a;" print_predicate concl
+
+let call q = 
+  let f = Filename.temp_file "coq_dp" ".cvc" in
+  let c = open_out f in
+  let fmt = formatter_of_out_channel c in
+  fprintf fmt "@[%a@]@." print_query q;
+  close_out c;
+  ignore (Sys.command (sprintf "cat %s" f));
+  let cmd = 
+    sprintf "timeout 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" f
+  in
+  prerr_endline cmd; flush stderr;
+  let out = Sys.command cmd in
+  if out = 0 then Valid else if out = 1 then Invalid else Timeout
+  (* TODO: effacer le fichier f et le fichier out *)
+
+
diff --git a/contrib/dp/dp_cvcl.mli b/contrib/dp/dp_cvcl.mli
new file mode 100644
index 00000000..03b6d347
--- /dev/null
+++ b/contrib/dp/dp_cvcl.mli
@@ -0,0 +1,4 @@
+
+open Fol
+
+val call : query -> prover_answer
diff --git a/contrib/dp/dp_simplify.ml b/contrib/dp/dp_simplify.ml
new file mode 100644
index 00000000..d5376b8d
--- /dev/null
+++ b/contrib/dp/dp_simplify.ml
@@ -0,0 +1,117 @@
+
+open Format
+open Fol
+
+let is_simplify_ident s =
+  let is_simplify_char = function
+    | 'a'..'z' | 'A'..'Z' | '0'..'9' -> true 
+    | _ -> false
+  in
+  try 
+    String.iter (fun c -> if not (is_simplify_char c) then raise Exit) s; true
+  with Exit ->
+    false
+
+let ident fmt s =
+  if is_simplify_ident s then fprintf fmt "%s" s else fprintf fmt "|%s|" s
+
+let rec print_list sep print fmt = function
+  | [] -> ()
+  | [x] -> print fmt x
+  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
+
+let space fmt () = fprintf fmt "@ "
+let comma fmt () = fprintf fmt ",@ "
+
+let rec print_term fmt = function
+  | Cst n -> 
+      fprintf fmt "%d" n
+  | Plus (a, b) ->
+      fprintf fmt "@[(+@ %a@ %a)@]" print_term a print_term b
+  | Moins (a, b) ->
+      fprintf fmt "@[(-@ %a@ %a)@]" print_term a print_term b
+  | Mult (a, b) ->
+      fprintf fmt "@[(*@ %a@ %a)@]" print_term a print_term b
+  | Div (a, b) ->
+      fprintf fmt "@[(/@ %a@ %a)@]" print_term a print_term b
+  | App (id, []) ->
+      fprintf fmt "%a" ident id
+  | App (id, tl) ->
+      fprintf fmt "@[(%a@ %a)@]" ident id print_terms tl
+
+and print_terms fmt tl = 
+  print_list space print_term fmt tl
+
+let rec print_predicate fmt p = 
+  let pp = print_predicate in 
+  match p with
+  | True ->
+      fprintf fmt "TRUE"
+  | False ->
+      fprintf fmt "FALSE"
+  | Fatom (Eq (a, b)) ->
+      fprintf fmt "@[(EQ %a@ %a)@]" print_term a print_term b
+  | Fatom (Le (a, b)) ->
+      fprintf fmt "@[(<= %a@ %a)@]" print_term a print_term b
+  | Fatom (Lt (a, b))->
+      fprintf fmt "@[(< %a@ %a)@]" print_term a print_term b
+  | Fatom (Ge (a, b)) ->
+      fprintf fmt "@[(>= %a@ %a)@]" print_term a print_term b
+  | Fatom (Gt (a, b)) ->
+      fprintf fmt "@[(> %a@ %a)@]" print_term a print_term b
+  | Fatom (Pred (id, tl)) -> 
+      fprintf fmt "@[(EQ (%a@ %a) |@@true|)@]" ident id print_terms tl
+  | Imp (a, b) ->
+      fprintf fmt "@[(IMPLIES@ %a@ %a)@]" pp a pp b
+  | And (a, b) ->
+      fprintf fmt "@[(AND@ %a@ %a)@]" pp a pp b
+  | Or (a, b) ->
+      fprintf fmt "@[(OR@ %a@ %a)@]" pp a pp b
+  | Not a ->
+      fprintf fmt "@[(NOT@ %a)@]" pp a
+  | Forall (id, _, p) -> 
+      fprintf fmt "@[(FORALL (%a)@ %a)@]" ident id pp p
+  | Exists (id, _, p) -> 
+      fprintf fmt "@[(EXISTS (%a)@ %a)@]" ident id pp p
+
+(**
+let rec string_list l = match l with
+    [] -> ""
+  | [e] -> e
+  | e::l' -> e ^ " " ^ (string_list l')
+**)
+
+let print_query fmt (decls,concl) =
+  let print_decl = function
+    | DeclVar (id, [], t) ->
+	fprintf fmt "@[;; %s : %s@]@\n"	id t
+    | DeclVar (id, l, t) ->
+	fprintf fmt "@[;; %s : %a -> %s@]@\n" 
+	  id (print_list comma pp_print_string) l t
+    | DeclPred (id, []) ->
+	fprintf fmt "@[;; %s : BOOLEAN @]@\n" id
+    | DeclPred (id, l) -> 
+	fprintf fmt "@[;; %s : %a -> BOOLEAN@]@\n" 
+	  id (print_list comma pp_print_string) l
+    | DeclType id ->
+	fprintf fmt "@[;; %s : TYPE@]@\n" id
+    | Assert (id, f)  -> 
+	fprintf fmt "@[(BG_PUSH ;; %s@\n %a)@]@\n" id print_predicate f
+  in
+  List.iter print_decl decls;
+  fprintf fmt "%a@." print_predicate concl
+
+let call q = 
+  let f = Filename.temp_file "coq_dp" ".sx" in
+  let c = open_out f in
+  let fmt = formatter_of_out_channel c in
+  fprintf fmt "@[%a@]@." print_query q;
+  close_out c;
+  ignore (Sys.command (sprintf "cat %s" f));
+  let cmd = 
+    sprintf "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" f
+  in
+  prerr_endline cmd; flush stderr;
+  let out = Sys.command cmd in
+  if out = 0 then Valid else if out = 1 then Invalid else Timeout
+  (* TODO: effacer le fichier f et le fichier out *)
diff --git a/contrib/dp/dp_simplify.mli b/contrib/dp/dp_simplify.mli
new file mode 100644
index 00000000..03b6d347
--- /dev/null
+++ b/contrib/dp/dp_simplify.mli
@@ -0,0 +1,4 @@
+
+open Fol
+
+val call : query -> prover_answer
diff --git a/contrib/dp/dp_sorts.ml b/contrib/dp/dp_sorts.ml
new file mode 100644
index 00000000..7dbdfa56
--- /dev/null
+++ b/contrib/dp/dp_sorts.ml
@@ -0,0 +1,51 @@
+
+open Fol
+
+let term_has_sort x s = Fatom (Pred ("%sort_" ^ s, [x]))
+
+let has_sort x s = term_has_sort (App (x, [])) s
+
+let rec form = function
+  | True | False | Fatom _ as f -> f
+  | Imp (f1, f2) -> Imp (form f1, form f2)
+  | And (f1, f2) -> And (form f1, form f2)
+  | Or (f1, f2) -> Or (form f1, form f2)
+  | Not f -> Not (form f)
+  | Forall (x, ("INT" as t), f) -> Forall (x, t, form f)
+  | Forall (x, t, f) -> Forall (x, t, Imp (has_sort x t, form f))
+  | Exists (x, ("INT" as t), f) -> Exists (x, t, form f)
+  | Exists (x, t, f) -> Exists (x, t, Imp (has_sort x t, form f))
+
+let sort_ax = let r = ref 0 in fun () -> incr r; "sort_ax_" ^ string_of_int !r
+
+let hyp acc = function
+  | Assert (id, f) -> 
+      (Assert (id, form f)) :: acc
+  | DeclVar (id, _, "INT") as d ->
+      d :: acc
+  | DeclVar (id, [], t) as d -> 
+      (Assert (sort_ax (), has_sort id t)) :: d :: acc
+  | DeclVar (id, l, t) as d -> 
+      let n = ref 0 in
+      let xi = 
+	List.fold_left 
+	  (fun l t -> incr n; ("x" ^ string_of_int !n, t) :: l) [] l
+      in
+      let f =
+	List.fold_left
+	  (fun f (x,t) -> if t = "INT" then f else Imp (has_sort x t, f))
+	  (term_has_sort 
+	     (App (id, List.rev_map (fun (x,_) -> App (x,[])) xi)) t)
+	  xi 
+      in
+      let f = List.fold_left (fun f (x,t) -> Forall (x, t, f)) f xi in
+      (Assert (sort_ax (), f)) :: d :: acc
+  | DeclPred _ as d ->
+      d :: acc
+  | DeclType t as d ->
+      (DeclPred ("%sort_" ^ t, [t])) :: d :: acc
+
+let query (hyps, f) =
+  let hyps' = List.fold_left hyp [] hyps in
+  List.rev hyps', form f
+
diff --git a/contrib/dp/dp_sorts.mli b/contrib/dp/dp_sorts.mli
new file mode 100644
index 00000000..9e74f997
--- /dev/null
+++ b/contrib/dp/dp_sorts.mli
@@ -0,0 +1,4 @@
+
+open Fol
+
+val query : query -> query
diff --git a/contrib/dp/dp_why.ml b/contrib/dp/dp_why.ml
new file mode 100644
index 00000000..e1ddb039
--- /dev/null
+++ b/contrib/dp/dp_why.ml
@@ -0,0 +1,139 @@
+
+(* Pretty-print PFOL (see fol.mli) in Why syntax *)
+
+open Format
+open Fol
+
+let rec print_list sep print fmt = function
+  | [] -> ()
+  | [x] -> print fmt x
+  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
+
+let space fmt () = fprintf fmt "@ "
+let comma fmt () = fprintf fmt ",@ "
+
+let is_why_keyword = 
+  let h = Hashtbl.create 17 in
+  List.iter 
+    (fun s -> Hashtbl.add h s ())
+    ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin";
+     "bool"; "do"; "done"; "else"; "end"; "exception"; "exists";
+     "external"; "false"; "for"; "forall"; "fun"; "function"; "goal";
+     "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not";
+     "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises";
+     "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try";
+     "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; 
+  Hashtbl.mem h
+
+let ident fmt s =
+  if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s
+
+let rec print_typ fmt = function
+  | Tvar x -> fprintf fmt "'%a" ident x
+  | Tid ("int", []) -> fprintf fmt "int"
+  | Tid (x, []) -> fprintf fmt "%a" ident x
+  | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x
+  | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x
+
+let rec print_term fmt = function
+  | Cst n -> 
+      fprintf fmt "%d" n
+  | Plus (a, b) ->
+      fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b
+  | Moins (a, b) ->
+      fprintf fmt "@[(%a -@ %a)@]" print_term a print_term b
+  | Mult (a, b) ->
+      fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b
+  | Div (a, b) ->
+      fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b
+  | App (id, []) ->
+      fprintf fmt "%a" ident id
+  | App (id, tl) ->
+      fprintf fmt "@[%a(%a)@]" ident id print_terms tl
+
+and print_terms fmt tl = 
+  print_list comma print_term fmt tl
+
+let rec print_predicate fmt p = 
+  let pp = print_predicate in 
+  match p with
+  | True ->
+      fprintf fmt "true"
+  | False ->
+      fprintf fmt "false"
+  | Fatom (Eq (a, b)) ->
+      fprintf fmt "@[(%a =@ %a)@]" print_term a print_term b
+  | Fatom (Le (a, b)) ->
+      fprintf fmt "@[(%a <=@ %a)@]" print_term a print_term b
+  | Fatom (Lt (a, b))->
+      fprintf fmt "@[(%a <@ %a)@]" print_term a print_term b
+  | Fatom (Ge (a, b)) ->
+      fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b
+  | Fatom (Gt (a, b)) ->
+      fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b
+  | Fatom (Pred (id, [])) -> 
+      fprintf fmt "%a" ident id
+  | Fatom (Pred (id, tl)) -> 
+      fprintf fmt "@[%a(%a)@]" ident id print_terms tl
+  | Imp (a, b) ->
+      fprintf fmt "@[(%a ->@ %a)@]" pp a pp b
+  | Iff (a, b) ->
+      fprintf fmt "@[(%a <->@ %a)@]" pp a pp b
+  | And (a, b) ->
+      fprintf fmt "@[(%a and@ %a)@]" pp a pp b
+  | Or (a, b) ->
+      fprintf fmt "@[(%a or@ %a)@]" pp a pp b
+  | Not a ->
+      fprintf fmt "@[(not@ %a)@]" pp a
+  | Forall (id, t, p) -> 
+      fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p
+  | Exists (id, t, p) -> 
+      fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p
+
+let print_query fmt (decls,concl) =
+  let print_dtype = function
+    | DeclType (id, 0) ->
+	fprintf fmt "@[type %a@]@\n@\n" ident id
+    | DeclType (id, 1) ->
+	fprintf fmt "@[type 'a %a@]@\n@\n" ident id
+    | DeclType (id, n) ->
+	fprintf fmt "@[type (";
+	for i = 1 to n do 
+	  fprintf fmt "'a%d" i; if i < n then fprintf fmt ", "
+	done;
+	fprintf fmt ") %a@]@\n@\n" ident id
+    | DeclFun _ | DeclPred _ | Axiom _ ->
+	()
+  in
+  let print_dvar_dpred = function
+    | DeclFun (id, _, [], t) ->
+	fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t
+    | DeclFun (id, _, l, t) ->
+	fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" 
+	  ident id (print_list comma print_typ) l print_typ t
+    | DeclPred (id, _, []) ->
+	fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id
+    | DeclPred (id, _, l) -> 
+	fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" 
+	  ident id (print_list comma print_typ) l
+    | DeclType _ | Axiom _ ->
+	()
+  in
+  let print_assert = function
+    | Axiom (id, f)  -> 
+	fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f
+    | DeclType _ | DeclFun _ | DeclPred _ ->
+	()
+  in
+  List.iter print_dtype decls;
+  List.iter print_dvar_dpred decls;
+  List.iter print_assert decls;
+  fprintf fmt "@[<hov 2>goal coq___goal: %a@]" print_predicate concl
+
+let output_file f q =
+  let c = open_out f in
+  let fmt = formatter_of_out_channel c in
+  fprintf fmt "@[%a@]@." print_query q;
+  close_out c
+
+
diff --git a/contrib/dp/dp_zenon.ml b/contrib/dp/dp_zenon.ml
new file mode 100644
index 00000000..57b0a44f
--- /dev/null
+++ b/contrib/dp/dp_zenon.ml
@@ -0,0 +1,103 @@
+
+open Format
+open Fol
+
+let rec print_list sep print fmt = function
+  | [] -> ()
+  | [x] -> print fmt x
+  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
+
+let space fmt () = fprintf fmt "@ "
+
+let rec print_term fmt = function
+  | Cst n -> 
+      fprintf fmt "%d" n
+  | Plus (a, b) ->
+      fprintf fmt "@[(+@ %a@ %a)@]" print_term a print_term b
+  | Moins (a, b) ->
+      fprintf fmt "@[(-@ %a@ %a)@]" print_term a print_term b
+  | Mult (a, b) ->
+      fprintf fmt "@[(*@ %a@ %a)@]" print_term a print_term b
+  | Div (a, b) ->
+      fprintf fmt "@[(/@ %a@ %a)@]" print_term a print_term b
+  | App (id, []) ->
+      fprintf fmt "%s" id 
+  | App (id, tl) ->
+      fprintf fmt "@[(%s@ %a)@]" id print_terms tl
+
+and print_terms fmt tl = 
+  print_list space print_term fmt tl
+
+let rec print_predicate fmt p = 
+  let pp = print_predicate in 
+  match p with
+  | True ->
+      fprintf fmt "True"
+  | False ->
+      fprintf fmt "False"
+  | Fatom (Eq (a, b)) ->
+      fprintf fmt "@[(= %a@ %a)@]" print_term a print_term b
+  | Fatom (Le (a, b)) ->
+      fprintf fmt "@[(<= %a@ %a)@]" print_term a print_term b
+  | Fatom (Lt (a, b))->
+      fprintf fmt "@[(< %a@ %a)@]" print_term a print_term b
+  | Fatom (Ge (a, b)) ->
+      fprintf fmt "@[(>= %a@ %a)@]" print_term a print_term b
+  | Fatom (Gt (a, b)) ->
+      fprintf fmt "@[(> %a@ %a)@]" print_term a print_term b
+  | Fatom (Pred (id, tl)) -> 
+      fprintf fmt "@[(%s@ %a)@]" id print_terms tl
+  | Imp (a, b) ->
+      fprintf fmt "@[(=>@ %a@ %a)@]" pp a pp b
+  | And (a, b) ->
+      fprintf fmt "@[(/\\@ %a@ %a)@]" pp a pp b
+  | Or (a, b) ->
+      fprintf fmt "@[(\\/@ %a@ %a)@]" pp a pp b
+  | Not a ->
+      fprintf fmt "@[(-.@ %a)@]" pp a
+  | Forall (id, t, p) -> 
+      fprintf fmt "@[(A. ((%s \"%s\")@ %a))@]" id t pp p
+  | Exists (id, t, p) -> 
+      fprintf fmt "@[(E. ((%s \"%s\")@ %a))@]" id t pp p
+
+let rec string_of_type_list  = function
+  | [] -> ""
+  | e :: l' -> e ^ " -> " ^ (string_of_type_list l')
+
+let print_query fmt (decls,concl) =
+  let print_decl = function
+    | DeclVar (id, [], t) ->
+	fprintf fmt "@[;; %s: %s@]@\n" id t
+    | DeclVar (id, l, t) ->
+	fprintf fmt "@[;; %s: %s%s@]@\n"
+	  id (string_of_type_list l) t
+    | DeclPred (id, l) -> 
+	fprintf fmt "@[;; %s: %sBOOLEAN@]@\n"
+	  id (string_of_type_list l)
+    | DeclType id ->
+	fprintf fmt "@[;; %s: TYPE@]@\n" id
+    | Assert (id, f)  -> 
+	fprintf fmt "@[\"%s\" %a@]@\n" id print_predicate f
+  in
+  List.iter print_decl decls;
+  fprintf fmt "$goal %a@." print_predicate concl
+
+let call q = 
+  let f = Filename.temp_file "coq_dp" ".znn" in
+  let c = open_out f in
+  let fmt = formatter_of_out_channel c in
+  fprintf fmt "@[%a@]@." print_query q;
+  close_out c;
+  ignore (Sys.command (sprintf "cat %s" f));
+  let cmd = 
+    sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" f
+  in
+  prerr_endline cmd; flush stderr;
+  let out = Sys.command cmd in
+  if out = 0 then Valid 
+  else if out = 1 then Invalid 
+  else if out = 137 then Timeout
+  else Util.anomaly "malformed Zenon input file"
+  (* TODO: effacer le fichier f et le fichier out *)
+
+
diff --git a/contrib/dp/dp_zenon.mli b/contrib/dp/dp_zenon.mli
new file mode 100644
index 00000000..03b6d347
--- /dev/null
+++ b/contrib/dp/dp_zenon.mli
@@ -0,0 +1,4 @@
+
+open Fol
+
+val call : query -> prover_answer
diff --git a/contrib/dp/fol.mli b/contrib/dp/fol.mli
new file mode 100644
index 00000000..a85469cc
--- /dev/null
+++ b/contrib/dp/fol.mli
@@ -0,0 +1,48 @@
+
+(* Polymorphic First-Order Logic (that is Why's input logic) *)
+
+type typ = 
+  | Tvar of string
+  | Tid of string * typ list
+
+type term =   
+  | Cst of int
+  | Plus of term * term
+  | Moins of term * term
+  | Mult of term * term
+  | Div of term * term
+  | App of string * term list
+
+and atom =   
+  | Eq of term * term
+  | Le of term * term
+  | Lt of term * term
+  | Ge of term * term
+  | Gt of term * term
+  | Pred of string * term list
+
+and form = 
+  | Fatom of atom
+  | Imp of form * form
+  | Iff of form * form
+  | And of form * form
+  | Or of form * form
+  | Not of form
+  | Forall of string * typ * form
+  | Exists of string * typ * form
+  | True
+  | False
+
+(* the integer indicates the number of type variables *)
+type decl =
+  | DeclType of string * int
+  | DeclFun of string * int * typ list * typ
+  | DeclPred of string * int * typ list
+  | Axiom of string * form
+
+type query = decl list * form
+
+
+(* prover result *)
+
+type prover_answer = Valid | Invalid | DontKnow | Timeout
diff --git a/contrib7/fourier/Fourier.v b/contrib/dp/g_dp.ml4
index 740bbef6..eb7fb73b 100644
--- a/contrib7/fourier/Fourier.v
+++ b/contrib/dp/g_dp.ml4
@@ -6,23 +6,33 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
+(*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* "Fourier's method to solve linear inequations/equations systems.".*)
+(* $Id: g_dp.ml4 7165 2005-06-24 12:56:46Z coq $ *)
 
-Declare ML Module "quote".
-Declare ML Module "ring".
-Declare ML Module "fourier".
-Declare ML Module "fourierR".
-Declare ML Module "field".
+open Dp
 
-Require Export Fourier_util.
-Require Export Field.
-Require Export DiscrR.
+TACTIC EXTEND Simplify
+  [ "simplify" ] -> [ simplify ]
+END
 
-Tactic Definition Fourier  :=
-  Abstract (FourierZ;Field;DiscrR).
+TACTIC EXTEND CVCLite
+  [ "cvcl" ] -> [ cvc_lite ]
+END
 
-Tactic Definition FourierEq  :=
-  Apply Rge_ge_eq ; Fourier.
+TACTIC EXTEND Harvey
+  [ "harvey" ] -> [ harvey ]
+END
 
+TACTIC EXTEND Zenon
+  [ "zenon" ] -> [ zenon ]
+END
+
+(* should be part of basic tactics syntax *)
+TACTIC EXTEND admit
+  [ "admit"    ] -> [ Tactics.admit_as_an_axiom ]
+END
+
+VERNAC COMMAND EXTEND Dp_hint 
+  [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ]
+END
diff --git a/contrib/dp/test2.v b/contrib/dp/test2.v
new file mode 100644
index 00000000..4e933a3c
--- /dev/null
+++ b/contrib/dp/test2.v
@@ -0,0 +1,78 @@
+Require Import ZArith.
+Require Import Classical.
+Require Import List.
+
+Open Scope list_scope.
+Open Scope Z_scope.
+
+Definition neg (z:Z) : Z := match z with
+  | Z0 => Z0
+  | Zpos p => Zneg p
+  | Zneg p => Zpos p
+  end.
+
+Goal forall z, neg (neg z) = z.
+  Admitted.
+
+Open Scope nat_scope.
+Print plus.
+
+Goal forall x, x+0=x.
+  induction x.
+  zenon.
+  zenon.
+  (* simplify resoud le premier, pas le second *)
+  Admitted.
+
+Goal 1::2::3::nil = 1::2::(1+2)::nil.
+  zenon.
+  Admitted.
+
+Definition T := nat.
+Parameter fct : T -> nat.
+Goal fct O = O.
+ Admitted.
+
+Fixpoint even (n:nat) : Prop :=
+  match n with 
+  O => True
+  | S O => False
+  | S (S p) => even p
+  end.
+
+Goal even 4%nat.
+  try zenon.
+  Admitted.
+
+Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil.
+
+Definition head :=
+fun (A : Set) (l : list A) =>
+match l with
+| nil => None (A:=A)
+| x :: _ => Some x
+end.
+
+Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
+
+Admitted.
+
+(*
+BUG avec head prédéfini : manque eta-expansion sur A:Set
+
+Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
+
+Print value. 
+Print Some.
+ 
+zenon.
+*)
+
+Inductive IN (A:Set) : A -> list A -> Prop :=
+  | IN1 : forall x l, IN A x (x::l)
+  | IN2: forall x l, IN A x l -> forall y, IN A x (y::l).
+Implicit Arguments IN [A].
+
+Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l).
+  zenon.
+Print In.
diff --git a/contrib/dp/tests.v b/contrib/dp/tests.v
new file mode 100644
index 00000000..52a57a0c
--- /dev/null
+++ b/contrib/dp/tests.v
@@ -0,0 +1,220 @@
+
+Require Import ZArith.
+Require Import Classical.
+
+(* First example with the 0 and the equality translated *)
+
+Goal 0 = 0.
+zenon.
+Qed.
+
+
+(* Examples in the Propositional Calculus
+   and theory of equality *)
+
+Parameter A C : Prop.
+
+Goal A -> A.
+zenon.
+Qed.
+
+
+Goal A -> (A \/ C).
+
+zenon.
+Qed.
+
+
+Parameter x y z : Z.
+
+Goal x = y -> y = z -> x = z.
+
+zenon.
+Qed.
+
+
+Goal ((((A -> C) -> A) -> A) -> C) -> C.
+
+zenon.
+Qed.
+
+
+(* Arithmetic *)
+Open Scope Z_scope.
+
+Goal 1 + 1 = 2.
+simplify.
+Qed.
+
+
+Goal 2*x + 10 = 18 -> x = 4.
+
+simplify.
+Qed.
+
+
+(* Universal quantifier *)
+
+Goal (forall (x y : Z), x = y) -> 0=1.
+try zenon.
+simplify.
+Qed.
+
+Goal forall (x: nat), (x + 0 = x)%nat.
+
+induction x0.
+zenon.
+zenon.
+Qed.
+
+
+(* No decision procedure can solve this problem 
+  Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a.
+*)
+
+
+(* Functions definitions *) 
+
+Definition fst (x y : Z) : Z := x.
+
+Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x.
+
+simplify.
+Qed.
+
+
+(* Eta-expansion example *)
+
+Definition snd_of_3 (x y z : Z) : Z := y.
+
+Definition f : Z -> Z -> Z := snd_of_3 0.
+
+Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1.
+
+simplify.
+Qed.
+
+
+(* Inductive types definitions - call to incontrib/dp/jection function *)
+
+Inductive even : Z -> Prop :=
+| even_0 : even 0
+| even_plus2 : forall z : Z, even z -> even (z + 2).
+
+
+(* Simplify and Zenon can't prove this goal before the timeout
+   unlike CVC Lite *)
+
+Goal even 4.
+cvcl.
+Qed.
+
+
+Definition skip_z (z : Z) (n : nat) := n.
+
+Definition skip_z1 := skip_z.
+
+Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n.
+
+zenon.
+Qed.
+
+
+(* Axioms definitions and dp_hint *)
+
+Parameter add : nat -> nat -> nat.
+Axiom add_0 : forall (n : nat), add 0%nat n = n.
+Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2).
+
+Dp_hint add_0.
+Dp_hint add_S.
+
+(* Simplify can't prove this goal before the timeout 
+   unlike zenon *)
+
+Goal forall n : nat, add n 0 = n.
+
+induction n ; zenon.
+Qed.
+
+
+Definition pred (n : nat) : nat := match n with
+  | 0%nat => 0%nat
+  | S n' => n'
+end.
+
+Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat.
+
+zenon.
+Qed.
+
+
+Fixpoint plus (n m : nat) {struct n} : nat :=
+  match n with
+  | 0%nat => m
+  | S n' => S (plus n' m)
+end.
+
+Goal forall n : nat, plus n 0%nat = n.
+
+induction n; zenon.
+Qed.
+
+
+(* Mutually recursive functions *)
+
+Fixpoint even_b (n : nat) : bool := match n with
+  | O => true
+  | S m => odd_b m
+end
+with odd_b (n : nat) : bool := match n with
+  | O => false
+  | S m => even_b m
+end.
+
+Goal even_b (S (S O)) = true.
+
+zenon.
+Qed.
+
+
+(* sorts issues *)
+
+Parameter foo : Set.         
+Parameter ff : nat -> foo -> foo -> nat.
+Parameter g : foo -> foo.
+Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O.
+zenon.
+Qed.
+
+
+
+(* abstractions *)
+
+Parameter poly_f : forall A:Set, A->A.
+
+Goal forall x:nat, poly_f nat x = poly_f nat x.
+zenon.
+Qed.
+
+
+
+(* Anonymous mutually recursive functions : no equations are produced
+
+Definition mrf :=
+  fix even2 (n : nat) : bool := match n with
+    | O => true
+    | S m => odd2 m
+  end
+  with odd2 (n : nat) : bool := match n with
+    | O => false
+    | S m => even2 m
+  end for even.
+
+   Thus this goal is unsolvable
+
+Goal mrf (S (S O)) = true.
+
+zenon.
+
+*)
diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml
index 8e441613..346201ec 100644
--- a/contrib/extraction/common.ml
+++ b/contrib/extraction/common.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: common.ml,v 1.51.2.4 2005/12/16 03:07:39 letouzey Exp $ i*)
+(*i $Id: common.ml 8930 2006-06-09 02:14:34Z letouzey $ i*)
 
 open Pp
 open Util
@@ -112,7 +112,8 @@ let contents_first_level mp =
 		      | Extraction.Term -> add false (id_of_label l))
 	       | (_, SPBmind mib) ->
 		   Array.iter 
-		     (fun mip -> if mip.mind_sort <> (Prop Null) then begin
+		     (fun mip -> if snd (Inductive.mind_arity mip) <> InProp
+		      then begin
 			add upper_type mip.mind_typename; 
 			Array.iter (add true) mip.mind_consnames
 		      end)
@@ -143,7 +144,7 @@ let create_modular_renamings struc =
   in 
   (* 1) creates renamings of objects *)
   let add upper r = 
-    let mp = modpath (kn_of_r r) in 
+    let mp = modpath_of_r r in 
     let l = mp_create_modular_renamings mp in 
     let s = modular_rename upper (id_of_global r) in 
     global_ids := Idset.add (id_of_string s) !global_ids;    
@@ -184,7 +185,7 @@ let create_modular_renamings struc =
   List.iter contents_first_level used_modules; 
   let used_modules' = List.rev used_modules in 
   let needs_qualify r = 
-    let mp = modpath (kn_of_r r) in 
+    let mp = modpath_of_r r in 
     if (is_modfile mp) && mp <> current_module && 
       (clash mp [] (List.hd (get_renamings r)) used_modules')
     then to_qualify := Refset.add r !to_qualify
@@ -239,7 +240,7 @@ let rec mp_create_mono_renamings mp =
 let create_mono_renamings struc = 
   let { up = u ; down = d } = struct_get_references_list struc in 
   let add upper r = 
-    let mp = modpath (kn_of_r r) in 
+    let mp = modpath_of_r r in 
     let l = mp_create_mono_renamings mp in
     let mycase = if upper then uppercase_id else lowercase_id in 
     let id = 
@@ -267,8 +268,6 @@ module StdParams = struct
 
   let globals () = !global_ids
 
-  (* TODO: remettre des conditions [lang () = Haskell] disant de qualifier. *)
-
   let unquote s = 
     if lang () <> Scheme then s 
     else 
@@ -285,26 +284,34 @@ module StdParams = struct
   let pp_global mpl r = 
     let ls = get_renamings r in 
     let s = List.hd ls in 
-    let mp = modpath (kn_of_r r) in 
+    let mp = modpath_of_r r in 
     let ls = 
       if mp = List.hd mpl then [s] (* simpliest situation *)
-      else 
-	try (* has [mp] something in common with one of those in [mpl] ? *)
-	  let pref = common_prefix_from_list mp mpl in 
-	  (*i TODO: possibilité de clash i*)
-	  list_firstn ((mp_length mp)-(mp_length pref)+1) ls
-	with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
-	  let base = base_mp mp in 
-	  if !modular &&  
-	    (at_toplevel mp) && 
-	    not (Refset.mem r !to_qualify) && 
-	    not (clash base [] s mpl) 
-	  then snd (list_sep_last ls)
-	  else ls
+      else match lang () with 
+	| Scheme -> [s] (* no modular Scheme extraction... *)
+	| Toplevel -> [s] (* idem *)
+	| Haskell -> 
+	    if !modular then 
+	      ls (* for the moment we always qualify in modular Haskell *)
+	    else [s]
+	| Ocaml -> 
+	    try (* has [mp] something in common with one of those in [mpl] ? *)
+	      let pref = common_prefix_from_list mp mpl in 
+	      (*i TODO: possibilité de clash i*)
+	      list_firstn ((mp_length mp)-(mp_length pref)+1) ls
+	    with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
+	      let base = base_mp mp in 
+	      if !modular &&  
+		(at_toplevel mp) && 
+		not (Refset.mem r !to_qualify) && 
+		not (clash base [] s mpl) 
+	      then snd (list_sep_last ls)
+	      else ls
     in 
     add_module_contents mp s; (* update the visible environment *)
     str (dottify ls)
 
+  (* The next function is used only in Ocaml extraction...*)
   let pp_module mpl mp = 
     let ls = 
       if !modular 
@@ -317,7 +324,6 @@ module StdParams = struct
 	(*i TODO: clash possible i*)
 	list_firstn ((mp_length mp)-(mp_length pref)) ls
       with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
-	let base = base_mp mp in 
 	if !modular && (at_toplevel mp) 
 	then snd (list_sep_last ls)
 	else ls
@@ -394,15 +400,15 @@ let print_structure_to_file f prm struc =
   in 
   let print_dummys =
     (struct_ast_search ((=) MLdummy) struc, 
-     struct_type_search Tdummy struc, 
-     struct_type_search Tunknown struc)
+     struct_type_search Mlutil.isDummy struc, 
+     struct_type_search ((=) Tunknown) struc)
   in 
   let print_magic = 
     if lang () <> Haskell then false 
     else struct_ast_search (function MLmagic _ -> true | _ -> false) struc
   in
   (* print the implementation *)
-  let cout = option_app (fun (f,_) -> open_out f) f in 
+  let cout = option_map (fun (f,_) -> open_out f) f in 
   let ft = match cout with 
     | None -> !Pp_control.std_ft
     | Some cout -> Pp_control.with_output_to cout in 
diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli
index 3e5efa0c..2ba51e1c 100644
--- a/contrib/extraction/common.mli
+++ b/contrib/extraction/common.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: common.mli,v 1.19.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+(*i $Id: common.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 open Names
 open Miniml
diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml
index d725a1d7..e31b701c 100644
--- a/contrib/extraction/extract_env.ml
+++ b/contrib/extraction/extract_env.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extract_env.ml,v 1.74.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+(*i $Id: extract_env.ml 9486 2007-01-15 19:11:28Z letouzey $ i*)
 
 open Term
 open Declarations
@@ -19,6 +19,7 @@ open Table
 open Extraction
 open Modutil
 open Common
+open Mod_subst
 
 (*s Obtaining Coq environment. *)
 
@@ -28,7 +29,7 @@ let toplevel_env () =
     | (_,kn), Lib.Leaf o ->
 	let mp,_,l = repr_kn kn in 
 	let seb = match Libobject.object_tag o with
-	  | "CONSTANT" -> SEBconst (Global.lookup_constant kn)
+	  | "CONSTANT" -> SEBconst (Global.lookup_constant (constant_of_kn kn))
 	  | "INDUCTIVE" -> SEBmind (Global.lookup_mind kn) 
 	  | "MODULE" -> SEBmodule (Global.lookup_module (MPdot (mp,l)))
 	  | "MODULE TYPE" -> SEBmodtype (Global.lookup_modtype kn)
@@ -52,19 +53,61 @@ let environment_until dir_opt =
 	  | _ -> assert false
   in parse (Library.loaded_libraries ())
 
-type visit = { mutable kn : KNset.t; mutable mp : MPset.t }
 
-let in_kn v kn = KNset.mem kn v.kn
-let in_mp v mp = MPset.mem mp v.mp
-
-let visit_mp v mp = v.mp <- MPset.union (prefixes_mp mp) v.mp
-let visit_kn v kn = v.kn <- KNset.add kn v.kn; visit_mp v (modpath kn)
-let visit_ref v r = visit_kn v (kn_of_r r) 
+(*s Visit: 
+  a structure recording the needed dependencies for the current extraction *)
+
+module type VISIT = sig 
+  (* Reset the dependencies by emptying the visit lists *)
+  val reset : unit -> unit
+    
+  (* Add the module_path and all its prefixes to the mp visit list *)  
+  val add_mp : module_path -> unit
+    
+  (* Add kernel_name / constant / reference / ... in the visit lists. 
+     These functions silently add the mp of their arg in the mp list *)
+  val add_kn : kernel_name -> unit
+  val add_con : constant -> unit
+  val add_ref : global_reference -> unit
+  val add_decl_deps : ml_decl -> unit
+  val add_spec_deps : ml_spec -> unit
+
+  (* Test functions: 
+     is a particular object a needed dependency for the current extraction ? *)
+  val needed_kn : kernel_name -> bool 
+  val needed_con : constant -> bool
+  val needed_mp : module_path -> bool
+end
+  
+module Visit : VISIT = struct 
+  (* Thanks to C.S.C, what used to be in a single KNset should now be split 
+     into a KNset (for inductives and modules names) and a Cset for constants 
+     (and still the remaining MPset) *)
+  type must_visit = 
+      { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t }
+  (* the imperative internal visit lists *)
+  let v = { kn = KNset.empty ; con = Cset.empty ; mp = MPset.empty } 
+  (* the accessor functions *)
+  let reset () = v.kn <- KNset.empty; v.con <- Cset.empty; v.mp <- MPset.empty
+  let needed_kn kn = KNset.mem kn v.kn
+  let needed_con c = Cset.mem c v.con
+  let needed_mp mp = MPset.mem mp v.mp
+  let add_mp mp = v.mp <- MPset.union (prefixes_mp mp) v.mp
+  let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn)
+  let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c)
+  let add_ref = function 
+    | ConstRef c -> add_con c
+    | IndRef (kn,_) | ConstructRef ((kn,_),_) -> add_kn kn
+    | VarRef _ -> assert false
+  let add_decl_deps = decl_iter_references add_ref add_ref add_ref 
+  let add_spec_deps = spec_iter_references add_ref add_ref add_ref
+end
 
 exception Impossible
 
 let check_arity env cb = 
-  if Reduction.is_arity env cb.const_type then raise Impossible
+  let t = Typeops.type_of_constant_type env cb.const_type in
+  if Reduction.is_arity env t then raise Impossible
 
 let check_fix env cb i = 
   match cb.const_body with 
@@ -93,115 +136,108 @@ let factor_fix env l cb msb =
     labels, recd, msb''
   end
 
-let get_decl_references v d = 
-  let f = visit_ref v in decl_iter_references f f f d
-
-let get_spec_references v s = 
-  let f = visit_ref v in spec_iter_references f f f s
-
-let rec extract_msig env v mp = function 
+let rec extract_msig env mp = function 
   | [] -> [] 
   | (l,SPBconst cb) :: msig -> 
-      let kn = make_kn mp empty_dirpath l in 
+      let kn = make_con mp empty_dirpath l in 
       let s = extract_constant_spec env kn cb in 
-      if logical_spec s then extract_msig env v mp msig
+      if logical_spec s then extract_msig env mp msig
       else begin
-	get_spec_references v s; 
-	(l,Spec s) :: (extract_msig env v mp msig)
+	Visit.add_spec_deps s;
+	(l,Spec s) :: (extract_msig env mp msig)
       end
   | (l,SPBmind cb) :: msig -> 
       let kn = make_kn mp empty_dirpath l in 
       let s = Sind (kn, extract_inductive env kn) in 
-      if logical_spec s then extract_msig env v mp msig
+      if logical_spec s then extract_msig env mp msig
       else begin 
-	get_spec_references v s; 
-	(l,Spec s) :: (extract_msig env v mp msig)
+	Visit.add_spec_deps s;
+	(l,Spec s) :: (extract_msig env mp msig)
       end
   | (l,SPBmodule {msb_modtype=mtb}) :: msig -> 
-(*i      let mpo = Some (MPdot (mp,l)) in  i*)
-      (l,Smodule (extract_mtb env v None (*i mpo i*) mtb)) :: (extract_msig env v mp msig)
+      (l,Smodule (extract_mtb env None mtb)) :: (extract_msig env mp msig)
   | (l,SPBmodtype mtb) :: msig -> 
-      (l,Smodtype (extract_mtb env v None mtb)) :: (extract_msig env v mp msig)
+      (l,Smodtype (extract_mtb env None mtb)) :: (extract_msig env mp msig)
 
-and extract_mtb env v mpo = function 
-  | MTBident kn -> visit_kn v kn; MTident kn 
+and extract_mtb env mpo = function 
+  | MTBident kn -> Visit.add_kn kn; MTident kn 
   | MTBfunsig (mbid, mtb, mtb') -> 
       let mp = MPbound mbid in 
       let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in 
-      MTfunsig (mbid, extract_mtb env v None mtb, 
-		extract_mtb env' v None mtb') 
+      MTfunsig (mbid, extract_mtb env None mtb, 
+		extract_mtb env' None mtb') 
   | MTBsig (msid, msig) -> 
       let mp, msig = match mpo with 
 	| None -> MPself msid, msig
 	| Some mp -> mp, Modops.subst_signature_msid msid mp msig
       in
       let env' = Modops.add_signature mp msig env in 
-      MTsig (msid, extract_msig env' v mp msig) 
+      MTsig (msid, extract_msig env' mp msig) 
 
-let rec extract_msb env v mp all = function 
+let rec extract_msb env mp all = function 
   | [] -> [] 
   | (l,SEBconst cb) :: msb -> 
       (try 
 	 let vl,recd,msb = factor_fix env l cb msb in 
-	 let vkn = Array.map (fun id -> make_kn mp empty_dirpath id) vl in
-	 let ms = extract_msb env v mp all msb in 
-	 let b = array_exists (in_kn v) vkn in 
+	 let vc = Array.map (make_con mp empty_dirpath) vl in
+	 let ms = extract_msb env mp all msb in 
+	 let b = array_exists Visit.needed_con vc in 
 	 if all || b then 
-	   let d = extract_fixpoint env vkn recd in 
+	   let d = extract_fixpoint env vc recd in
 	   if (not b) && (logical_decl d) then ms 
-	   else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms
        with Impossible ->
-	 let ms = extract_msb env v mp all msb in 
-	 let kn = make_kn mp empty_dirpath l in 
-	 let b = in_kn v kn in 
+	 let ms = extract_msb env mp all msb in 
+	 let c = make_con mp empty_dirpath l in 
+	 let b = Visit.needed_con c in 
 	 if all || b then 
-	   let d = extract_constant env kn cb in
+	   let d = extract_constant env c cb in
 	   if (not b) && (logical_decl d) then ms 
-	   else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms)
   | (l,SEBmind mib) :: msb ->
-      let ms = extract_msb env v mp all msb in
+      let ms = extract_msb env mp all msb in
       let kn = make_kn mp empty_dirpath l in 
-      let b = in_kn v kn in 
+      let b = Visit.needed_kn kn in
       if all || b then 
 	let d = Dind (kn, extract_inductive env kn) in 
 	if (not b) && (logical_decl d) then ms 
-	else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
       else ms
   | (l,SEBmodule mb) :: msb -> 
-      let ms = extract_msb env v mp all msb in
+      let ms = extract_msb env mp all msb in
       let mp = MPdot (mp,l) in 
-      if all || in_mp v mp then 
-	(l,SEmodule (extract_module env v mp true mb)) :: ms
+      if all || Visit.needed_mp mp then 
+	(l,SEmodule (extract_module env mp true mb)) :: ms
       else ms
   | (l,SEBmodtype mtb) :: msb ->
-      let ms = extract_msb env v mp all msb in
+      let ms = extract_msb env mp all msb in
       let kn = make_kn mp empty_dirpath l in
-      if all || in_kn v kn then 
-	(l,SEmodtype (extract_mtb env v None mtb)) :: ms
+      if all || Visit.needed_kn kn then 
+	(l,SEmodtype (extract_mtb env None mtb)) :: ms
       else ms
 
-and extract_meb env v mpo all = function 
+and extract_meb env mpo all = function 
   | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *)
-  | MEBident mp -> visit_mp v mp; MEident mp 
+  | MEBident mp -> Visit.add_mp mp; MEident mp 
   | MEBapply (meb, meb',_) -> 
-      MEapply (extract_meb env v None true meb, 
-	       extract_meb env v None true meb')
+      MEapply (extract_meb env None true meb, 
+	       extract_meb env None true meb')
   | MEBfunctor (mbid, mtb, meb) -> 
       let mp = MPbound mbid in 
       let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in 
-      MEfunctor (mbid, extract_mtb env v None mtb, 
-		 extract_meb env' v None true meb)
+      MEfunctor (mbid, extract_mtb env None mtb, 
+		 extract_meb env' None true meb)
   | MEBstruct (msid, msb) -> 
       let mp,msb = match mpo with 
 	| None -> MPself msid, msb 
 	| Some mp -> mp, subst_msb (map_msid msid mp) msb
       in 
       let env' = add_structure mp msb env in 
-      MEstruct (msid, extract_msb env' v mp all msb) 
+      MEstruct (msid, extract_msb env' mp all msb) 
 
-and extract_module env v mp all mb = 
+and extract_module env mp all mb = 
   (* [mb.mod_expr <> None ], since we look at modules from outside. *)
   (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *)
   let meb = out_some mb.mod_expr in
@@ -209,25 +245,21 @@ and extract_module env v mp all mb =
   (* Because of the "with" construct, the module type can be [MTBsig] with *)
   (* a msid different from the one of the module. Here is the patch. *)
   let mtb = replicate_msid meb mtb in
-  { ml_mod_expr = extract_meb env v (Some mp) all meb;
-    ml_mod_type = extract_mtb env v None mtb }
+  { ml_mod_expr = extract_meb env (Some mp) all meb;
+    ml_mod_type = extract_mtb env None mtb }
 
 let unpack = function MEstruct (_,sel) -> sel | _ -> assert false 
 
 let mono_environment refs mpl = 
-  let l = environment_until None in 
-  let v = 
-    let add_kn r = KNset.add (kn_of_r r) in 
-    let kns = List.fold_right add_kn refs KNset.empty in 
-    let add_mp mp = MPset.union (prefixes_mp mp) in
-    let mps = List.fold_right add_mp mpl MPset.empty in 
-    let mps = KNset.fold (fun k -> add_mp (modpath k)) kns mps in 
-    { kn = kns; mp = mps }
-  in 
+  Visit.reset ();
+  List.iter Visit.add_ref refs; 
+  List.iter Visit.add_mp mpl; 
   let env = Global.env () in 
-  List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) false m)) 
-    (List.rev l)
+  let l = List.rev (environment_until None) in 
+  List.rev_map 
+    (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) false m)) l
 
+    
 (*s Recursive extraction in the Coq toplevel. The vernacular command is
     \verb!Recursive Extraction! [qualid1] ... [qualidn]. We use [extract_env]
     to get the saturated environment to extract. *)
@@ -248,6 +280,7 @@ let mono_extraction (f,m) qualids =
   let prm = {modular=false; mod_name = m; to_appear= refs} in
   let struc = optimize_struct prm None (mono_environment refs mps) in 
   print_structure_to_file f prm struc; 
+  Visit.reset ();
   reset_tables ()
 
 let extraction_rec = mono_extraction (None,id_of_string "Main")
@@ -266,16 +299,15 @@ let extraction qid =
     let r = Nametab.global qid in 
     if is_custom r then
       msgnl (str "User defined extraction:" ++ spc () ++ 
-	     str (find_custom r) ++ fnl ()) 
-    else begin 
+	       str (find_custom r) ++ fnl ()) 
+    else
       let prm = 
-	{ modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in 
-      let kn = kn_of_r r in 
+	{ modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in
       let struc = optimize_struct prm None (mono_environment [r] []) in 
       let d = get_decl_in_structure r struc in 
-      print_one_decl struc (modpath kn) d;
-      reset_tables ()
-    end
+      print_one_decl struc (modpath_of_r r) d;
+      Visit.reset (); 
+      reset_tables () 
 
 (*s Extraction to a file (necessarily recursive). 
     The vernacular command is 
@@ -303,32 +335,33 @@ let extraction_file f vl =
 let extraction_module m = 
   check_inside_section (); 
   check_inside_module ();
-  match lang () with 
+  begin match lang () with 
     | Toplevel -> error_toplevel ()
     | Scheme -> error_scheme ()
-    | _ -> 
-	let q = snd (qualid_of_reference m) in 
-	let mp = 
-	  try Nametab.locate_module q
-	  with Not_found -> error_unknown_module q
-	in 
-	let b = is_modfile mp in 
-	let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in
-	let l = environment_until None in 
-	let v = { kn = KNset.empty ; mp = prefixes_mp mp } in
-	let env = Global.env () in 
-	let struc = 
-	  List.rev_map
-	    (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) b m)) 
-	    (List.rev l)
-	in 
-	let struc = optimize_struct prm None struc in 
-	let struc = 
-	  let bmp = base_mp mp in 
-	  try [bmp, List.assoc bmp struc] with Not_found -> assert false
-	in
-	print_structure_to_file None prm struc; 
-	reset_tables ()
+    | _ -> ()
+  end; 
+  let q = snd (qualid_of_reference m) in 
+  let mp = 
+    try Nametab.locate_module q with Not_found -> error_unknown_module q
+  in 
+  let b = is_modfile mp in 
+  let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in
+  Visit.reset ();
+  Visit.add_mp mp; 
+  let env = Global.env () in 
+  let l = List.rev (environment_until None) in 
+  let struc = 
+    List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) b m)) l
+  in
+  let struc = optimize_struct prm None struc in 
+  let struc = 
+    let bmp = base_mp mp in 
+    try [bmp, List.assoc bmp struc] with Not_found -> assert false
+  in
+  print_structure_to_file None prm struc; 
+  Visit.reset (); 
+  reset_tables ()
+
 
 (*s (Recursive) Extraction of a library. The vernacular command is 
   \verb!(Recursive) Extraction Library! [M]. *) 
@@ -345,36 +378,38 @@ let dir_module_of_id m =
 let extraction_library is_rec m =
   check_inside_section (); 
   check_inside_module ();  
-  match lang () with 
+  begin match lang () with 
     | Toplevel -> error_toplevel ()
     | Scheme -> error_scheme ()
-    | _ -> 
-	let dir_m = dir_module_of_id m in 
-	let v = { kn = KNset.empty; mp = MPset.singleton (MPfile dir_m) } in 
-	let l = environment_until (Some dir_m) in 
-	let struc = 
-	  let env = Global.env () in
-	  let select l (mp,meb) = 
-	    if in_mp v mp (* [mp] est long -> [in_mp] peut etre sans [long_mp] *)
-	    then (mp, unpack (extract_meb env v (Some mp) true meb)) :: l 
-	    else l
-	  in 
-	  List.fold_left select [] (List.rev l)
-	in 
-	let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in
-	let struc = optimize_struct dummy_prm None struc in 
-	let rec print = function 
-	  | [] -> () 
-	  | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l 
-	  | (MPfile dir, sel) as e :: l -> 
-	      let short_m = snd (split_dirpath dir) in
-	      let f = module_file_name short_m in 
-	      let prm = {modular=true;mod_name=short_m;to_appear=[]} in
-	      print_structure_to_file (Some f) prm [e]; 
-	      print l 
-	  | _ -> assert false
-	in print struc; 
-	reset_tables ()
+    | _ -> () 
+  end; 
+  let dir_m = dir_module_of_id m in 
+  Visit.reset (); 
+  Visit.add_mp (MPfile dir_m); 
+  let env = Global.env () in	
+  let l = List.rev (environment_until (Some dir_m)) in 
+  let select l (mp,meb) = 
+    if Visit.needed_mp mp 
+    then (mp, unpack (extract_meb env (Some mp) true meb)) :: l 
+    else l
+  in 
+  let struc = List.fold_left select [] l in 
+  let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in
+  let struc = optimize_struct dummy_prm None struc in 
+  let rec print = function 
+    | [] -> () 
+    | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l 
+    | (MPfile dir, sel) as e :: l -> 
+	let short_m = snd (split_dirpath dir) in
+	let f = module_file_name short_m in 
+	let prm = {modular=true;mod_name=short_m;to_appear=[]} in
+	print_structure_to_file (Some f) prm [e]; 
+	print l 
+    | _ -> assert false
+  in 
+  print struc; 
+  Visit.reset ();
+  reset_tables ()
 
 
 
diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli
index 8ce64342..a09464a1 100644
--- a/contrib/extraction/extract_env.mli
+++ b/contrib/extraction/extract_env.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extract_env.mli,v 1.13.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+(*i $Id: extract_env.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*s This module declares the extraction commands. *)
 
diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
index 6bfe861f..6fd4a3cc 100644
--- a/contrib/extraction/extraction.ml
+++ b/contrib/extraction/extraction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraction.ml,v 1.136.2.4 2005/12/01 11:27:15 letouzey Exp $ i*)
+(*i $Id: extraction.ml 9456 2006-12-17 20:08:38Z letouzey $ i*)
 
 (*i*)
 open Util
@@ -35,6 +35,9 @@ exception I of inductive_info
    to avoid loops in [extract_inductive] *)
 let internal_call = ref KNset.empty
 
+(* A set of all fixpoint functions currently being extracted *)
+let current_fixpoints = ref ([] : constant list)
+
 let none = Evd.empty
 
 let type_of env c = Retyping.get_type_of env none (strip_outer_cast c)
@@ -80,6 +83,14 @@ let rec flag_of_type env t =
 
 let is_default env t = (flag_of_type env t = (Info, Default))
 
+exception NotDefault of kill_reason
+
+let check_default env t = 
+  match flag_of_type env t with 
+    | _,TypeScheme -> raise (NotDefault Ktype)
+    | Logic,_ -> raise (NotDefault Kother)
+    | _ -> ()
+
 let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme))
 
 (*s [type_sign] gernerates a signature aimed at treating a type application. *)
@@ -87,7 +98,8 @@ let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme))
 let rec type_sign env c = 
   match kind_of_term (whd_betadeltaiota env none c) with
     | Prod (n,t,d) -> 
-	(is_info_scheme env t)::(type_sign (push_rel_assum (n,t) env) d)
+	(if is_info_scheme env t then Keep else Kill Kother)
+	:: (type_sign (push_rel_assum (n,t) env) d)
     | _ -> []
 
 let rec type_scheme_nb_args env c = 
@@ -105,8 +117,8 @@ let rec type_sign_vl env c =
   match kind_of_term (whd_betadeltaiota env none c) with
     | Prod (n,t,d) -> 
 	let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in 
-	if not (is_info_scheme env t) then false::s, vl
-	else true::s, (next_ident_away (id_of_name n) vl) :: vl
+	if not (is_info_scheme env t) then Kill Kother::s, vl
+	else Keep::s, (next_ident_away (id_of_name n) vl) :: vl
     | _ -> [],[]
 
 let rec nb_default_params env c = 
@@ -126,8 +138,8 @@ let rec nb_default_params env c =
 let db_from_sign s = 
   let rec make i acc = function 
     | [] -> acc  
-    | true :: l -> make (i+1) (i::acc) l
-    | false :: l -> make i (0::acc) l
+    | Keep :: l -> make (i+1) (i::acc) l
+    | Kill _ :: l -> make i (0::acc) l
   in make 1 [] s
 
 (*s Create a type variable context from indications taken from 
@@ -150,8 +162,8 @@ let rec db_from_ind dbmap i =
 let parse_ind_args si args relmax = 
   let rec parse i j = function 
     | [] -> Intmap.empty
-    | false :: s -> parse (i+1) j s
-    | true :: s -> 
+    | Kill _ :: s -> parse (i+1) j s
+    | Keep :: s -> 
       (match kind_of_term args.(i-1) with 
 	 | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s)
 	 | _ -> parse (i+1) (j+1) s)
@@ -167,6 +179,7 @@ let parse_ind_args si args relmax =
 (* [j] stands for the next ML type var. [j=0] means we do not 
    generate ML type var anymore (in subterms for example). *) 
 
+
 let rec extract_type env db j c args = 
   match kind_of_term (whd_betaiotazeta c) with
     | App (d, args') ->
@@ -183,19 +196,24 @@ let rec extract_type env db j c args =
 	   | (Info, Default) -> 
 	       (* Standard case: two [extract_type] ... *)
 	       let mld = extract_type env' (0::db) j d [] in 
-	       if type_eq (mlt_env env) mld Tdummy then Tdummy 
-	       else Tarr (extract_type env db 0 t [], mld) 
+	       (match expand env mld with 
+		  | Tdummy d -> Tdummy d
+		  | _ -> Tarr (extract_type env db 0 t [], mld))
 	   | (Info, TypeScheme) when j > 0 -> 
 	       (* A new type var. *)
 	       let mld = extract_type env' (j::db) (j+1) d [] in 
-	       if type_eq (mlt_env env) mld Tdummy then Tdummy 
-	       else Tarr (Tdummy, mld)
-	   | _ -> 
+	       (match expand env mld with 
+		  | Tdummy d -> Tdummy d
+		  | _ -> Tarr (Tdummy Ktype, mld))
+	   | _,lvl -> 
 	       let mld = extract_type env' (0::db) j d [] in 
-	       if type_eq (mlt_env env) mld Tdummy then Tdummy 
-	       else Tarr (Tdummy, mld))
-    | Sort _ -> Tdummy (* The two logical cases. *)
-    | _ when sort_of env (applist (c, args)) = InProp -> Tdummy 
+	       (match expand env mld with 
+		  | Tdummy d -> Tdummy d
+		  | _ -> 
+		      let reason = if lvl=TypeScheme then Ktype else Kother in
+		      Tarr (Tdummy reason, mld)))
+    | Sort _ -> Tdummy Ktype (* The two logical cases. *)
+    | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother
     | Rel n -> 
 	(match lookup_rel n env with
            | (_,Some t,_) -> extract_type env db j (lift n t) args
@@ -207,7 +225,7 @@ let rec extract_type env db j c args =
     | Const kn -> 
 	let r = ConstRef kn in 
 	let cb = lookup_constant kn env in 
-	let typ = cb.const_type in 
+	let typ = Typeops.type_of_constant_type env cb.const_type in 
 	(match flag_of_type env typ with 
 	   | (Info, TypeScheme) -> 
 	       let mlt = extract_type_app env db (r, type_sign env typ) args in 
@@ -222,7 +240,7 @@ let rec extract_type env db j c args =
 		      (* The more precise is [mlt'], extracted after reduction *)
 		      (* The shortest is [mlt], which use abbreviations *)
 		      (* If possible, we take [mlt], otherwise [mlt']. *)
-		      if type_eq (mlt_env env) mlt mlt' then mlt else mlt')
+		      if expand env mlt = expand env mlt' then mlt else mlt')
 	   | _ -> (* only other case here: Info, Default, i.e. not an ML type *)
 	       (match cb.const_body with 
 		  | None -> Tunknown (* Brutal approximation ... *)
@@ -230,7 +248,7 @@ let rec extract_type env db j c args =
 		      (* We try to reduce. *)
 		      let newc = applist (Declarations.force lbody, args) in 
 		      extract_type env db j newc []))
-    | Ind ((kn,i) as ip) ->
+    | Ind (kn,i) ->
 	let s = (extract_ind env kn).ind_packets.(i).ip_sign in  
 	extract_type_app env db (IndRef (kn,i),s) args
     | Case _ | Fix _ | CoFix _ -> Tunknown
@@ -242,7 +260,7 @@ let rec extract_type env db j c args =
 and extract_maybe_type env db c = 
   let t = whd_betadeltaiota env none (type_of env c) in 
   if isSort t then extract_type env db 0 c [] 
-  else if sort_of env t = InProp then Tdummy else Tunknown
+  else if sort_of env t = InProp then Tdummy Kother else Tunknown
 
 (*s Auxiliary function dealing with type application. 
   Precondition: [r] is a type scheme represented by the signature [s], 
@@ -251,7 +269,7 @@ and extract_maybe_type env db c =
 and extract_type_app env db (r,s) args =
   let ml_args = 
     List.fold_right 
-      (fun (b,c) a -> if b then 
+      (fun (b,c) a -> if b=Keep then 
 	 let p = List.length (fst (splay_prod env none (type_of env c))) in
          let db = iterate (fun l -> 0 :: l) p db in
          (extract_type_scheme env db c p) :: a
@@ -292,18 +310,22 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
   with Not_found -> 
     internal_call := KNset.add kn !internal_call;
     let mib = Environ.lookup_mind kn env in 
+    (* First, if this inductive is aliased via a Module, *)
+    (* we process the original inductive. *)
+    option_iter (fun kn -> ignore (extract_ind env kn)) mib.mind_equiv; 
     (* Everything concerning parameters. *)
     (* We do that first, since they are common to all the [mib]. *)
     let mip0 = mib.mind_packets.(0) in 
-    let npar = mip0.mind_nparams in
-    let epar = push_rel_context mip0.mind_params_ctxt env in
+    let npar = mib.mind_nparams in
+    let epar = push_rel_context mib.mind_params_ctxt env in
     (* First pass: we store inductive signatures together with *)
     (* their type var list. *)
     let packets = 
       Array.map 
-	(fun mip -> 
-	   let b = mip.mind_sort <> (Prop Null) in 
-	   let s,v = if b then type_sign_vl env mip.mind_nf_arity else [],[] in
+	(fun mip ->
+	   let b = snd (mind_arity mip) <> InProp in
+	   let ar = Inductive.type_of_inductive env (mib,mip) in
+	   let s,v = if b then type_sign_vl env ar else [],[] in
 	   let t = Array.make (Array.length mip.mind_nf_lc) [] in 
 	   { ip_typename = mip.mind_typename;
 	     ip_consnames = mip.mind_consnames;
@@ -313,7 +335,11 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	     ip_types = t }) 
 	mib.mind_packets 
     in 
-    add_ind kn {ind_info = Standard; ind_nparams = npar; ind_packets = packets};
+    add_ind kn 
+      {ind_info = Standard; 
+       ind_nparams = npar; 
+       ind_packets = packets; 
+       ind_equiv = mib.mind_equiv };
     (* Second pass: we extract constructors *)
     for i = 0 to mib.mind_ntypes - 1 do
       let p = packets.(i) in 
@@ -341,7 +367,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	if p.ip_logical then raise (I Standard);
 	if Array.length p.ip_types <> 1 then raise (I Standard);
 	let typ = p.ip_types.(0) in 
-	let l = List.filter (type_neq (mlt_env env) Tdummy) typ in 
+	let l = List.filter (fun t -> not (isDummy (expand env t))) typ in 
 	if List.length l = 1 && not (type_mem_kn kn (List.hd l)) 
 	then raise (I Singleton); 
 	if l = [] then raise (I Standard);
@@ -354,25 +380,26 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	let rec names_prod t = match kind_of_term t with 
 	  | Prod(n,_,t) -> n::(names_prod t)
 	  | LetIn(_,_,_,t) -> names_prod t
-	  | Cast(t,_) -> names_prod t
+	  | Cast(t,_,_) -> names_prod t
 	  | _ -> []
 	in 
 	let field_names = 
-	  list_skipn mip0.mind_nparams (names_prod mip0.mind_user_lc.(0)) in 
+	  list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in 
 	assert (List.length field_names = List.length typ);
-	let projs = ref KNset.empty in 
+	let projs = ref Cset.empty in 
 	let mp,d,_ = repr_kn kn in 
 	let rec select_fields l typs = match l,typs with 
 	  | [],[] -> []
 	  | (Name id)::l, typ::typs -> 
-	      if type_eq (mlt_env env) Tdummy typ then select_fields l typs 
+	      if isDummy (expand env typ) then select_fields l typs 
 	      else  
-		let knp = make_kn mp d (label_of_id id) in 
-		if not (List.mem false (type_to_sign (mlt_env env) typ)) then 
-		  projs := KNset.add knp !projs; 
+		let knp = make_con mp d (label_of_id id) in 
+		if not (List.exists isKill (type2signature env typ))
+		then 
+		  projs := Cset.add knp !projs; 
 		(ConstRef knp) :: (select_fields l typs)
 	  | Anonymous::l, typ::typs -> 
-	      if type_eq (mlt_env env) Tdummy typ then select_fields l typs
+	      if isDummy (expand env typ) then select_fields l typs
 	      else error_record r
 	  | _ -> assert false 
 	in 
@@ -381,17 +408,23 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	(* Is this record officially declared with its projections ? *)
 	(* If so, we use this information. *)
 	begin try 
-	  let n = nb_default_params env mip0.mind_nf_arity in
+	  let n = nb_default_params env
+            (Inductive.type_of_inductive env (mib,mip0))
+	  in
 	  List.iter 
 	    (option_iter 
-	       (fun kn -> if KNset.mem kn !projs then add_projection n kn))
-	    (find_structure ip).s_PROJ 
+	       (fun kn -> if Cset.mem kn !projs then add_projection n kn))
+	    (lookup_projections ip)
 	with Not_found -> ()
 	end; 
 	Record field_glob
       with (I info) -> info
     in
-    let i = {ind_info = ind_info; ind_nparams = npar; ind_packets = packets} in
+    let i = {ind_info = ind_info; 
+	     ind_nparams = npar; 
+	     ind_packets = packets; 
+	     ind_equiv = mib.mind_equiv}
+    in
     add_ind kn i; 
     internal_call := KNset.remove kn !internal_call;
     i
@@ -419,13 +452,13 @@ and extract_type_cons env db dbmap c i =
 and mlt_env env r = match r with 
   | ConstRef kn -> 
       (try 
-	 if not (visible_kn kn) then raise Not_found; 
+	 if not (visible_con kn) then raise Not_found; 
 	 match lookup_term kn with 
 	   | Dtype (_,vl,mlt) -> Some mlt
 	   | _ -> None
        with Not_found -> 
 	 let cb = Environ.lookup_constant kn env in
-	 let typ = cb.const_type in
+	 let typ = Typeops.type_of_constant_type env cb.const_type in 
 	 match cb.const_body with
 	   | None -> None
 	   | Some l_body -> 
@@ -439,20 +472,20 @@ and mlt_env env r = match r with
 		  | _ -> None))
   | _ -> None
 
-let type_expand env = type_expand (mlt_env env)
-let type_neq env = type_neq (mlt_env env)
-let type_to_sign env = type_to_sign (mlt_env env)
+and expand env = type_expand (mlt_env env)
+and type2signature env = type_to_signature (mlt_env env)
+let type2sign env = type_to_sign (mlt_env env)
 let type_expunge env = type_expunge (mlt_env env)
 
 (*s Extraction of the type of a constant. *)
 
 let record_constant_type env kn opt_typ = 
   try 
-    if not (visible_kn kn) then raise Not_found; 
+    if not (visible_con kn) then raise Not_found; 
     lookup_type kn 
   with Not_found ->
     let typ = match opt_typ with 
-      | None -> constant_type env kn 
+      | None -> Typeops.type_of_constant env kn
       | Some typ -> typ 
     in let mlt = extract_type env [] 1 typ [] 
     in let schema = (type_maxvar mlt, mlt)
@@ -478,10 +511,9 @@ let rec extract_term env mle mlt c args =
 	       in extract_term env mle mlt d' []
 	   | [] -> 
 	       let env' = push_rel_assum (Name id, t) env in 
-	       let id, a = 
-		 if is_default env t 
-		 then id, new_meta () 
-		 else dummy_name, Tdummy in 
+	       let id, a = try check_default env t; id, new_meta()
+	       with NotDefault d -> dummy_name, Tdummy d
+	       in 
 	       let b = new_meta () in 
 	       (* If [mlt] cannot be unified with an arrow type, then magic! *)
 	       let magic = needs_magic (mlt, Tarr (a, b)) in 
@@ -491,15 +523,16 @@ let rec extract_term env mle mlt c args =
 	let id = id_of_name n in 
 	let env' = push_rel (Name id, Some c1, t1) env in 
 	let args' = List.map (lift 1) args in 
-	if is_default env t1 then 
+	(try 
+	  check_default env t1; 
 	  let a = new_meta () in 
 	  let c1' = extract_term env mle a c1 [] in
 	  (* The type of [c1'] is generalized and stored in [mle]. *)
 	  let mle' = Mlenv.push_gen mle a in 
 	  MLletin (id, c1', extract_term env' mle' mlt c2 args') 
-	else 
-	  let mle' = Mlenv.push_std_type mle Tdummy in 
-	  ast_pop (extract_term env' mle' mlt c2 args')
+	with NotDefault d -> 
+	  let mle' = Mlenv.push_std_type mle (Tdummy d) in 
+	  ast_pop (extract_term env' mle' mlt c2 args'))
     | Const kn ->
 	extract_cst_app env mle mlt kn args
     | Construct cp ->
@@ -515,14 +548,16 @@ let rec extract_term env mle mlt c args =
  	extract_app env mle mlt (extract_fix env mle i recd) args 
     | CoFix (i,recd) ->
  	extract_app env mle mlt (extract_fix env mle i recd) args
-    | Cast (c, _) -> extract_term env mle mlt c args
+    | Cast (c,_,_) -> extract_term env mle mlt c args
     | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false 
 
 (*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) 
 
 and extract_maybe_term env mle mlt c =
-  if is_default env (type_of env c) then extract_term env mle mlt c [] 
-  else put_magic (mlt, Tdummy) MLdummy
+  try check_default env (type_of env c); 
+    extract_term env mle mlt c [] 
+  with NotDefault d -> 
+    put_magic (mlt, Tdummy d) MLdummy
 
 (*s Generic way to deal with an application. *)
 
@@ -540,7 +575,7 @@ and extract_app env mle mlt mk_head args =
 
 and make_mlargs env e s args typs = 
   let l = ref s in 
-  let keep () = match !l with [] -> true | b :: s -> l:=s; b in
+  let keep () = match !l with [] -> true | b :: s -> l:=s; b=Keep in
   let rec f = function  
     | [], [] -> [] 
     | a::la, t::lt when keep() -> extract_maybe_term env e t a :: (f (la,lt))
@@ -553,19 +588,25 @@ and make_mlargs env e s args typs =
 and extract_cst_app env mle mlt kn args = 
   (* First, the [ml_schema] of the constant, in expanded version. *) 
   let nb,t = record_constant_type env kn None in 
-  let schema = nb, type_expand env t in 
+  let schema = nb, expand env t in 
+  (* Can we instantiate types variables for this constant ? *)
+  (* In Ocaml, inside the definition of this constant, the answer is no. *)
+  let instantiated = 
+    if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema)
+    else instantiation schema
+  in 
   (* Then the expected type of this constant. *)
-  let metas = List.map new_meta args in 
+  let a = new_meta () in 
   (* We compare stored and expected types in two steps. *)
   (* First, can [kn] be applied to all args ? *)
-  let a = new_meta () in 
-  let magic1 = needs_magic (type_recomp (metas, a), instantiation schema) in 
+  let metas = List.map new_meta args in 
+  let magic1 = needs_magic (type_recomp (metas, a), instantiated) in 
   (* Second, is the resulting type compatible with the expected type [mlt] ? *)
   let magic2 = needs_magic (a, mlt) in 
   (* The internal head receives a magic if [magic1] *)
   let head = put_magic_if magic1 (MLglob (ConstRef kn)) in 
   (* Now, the extraction of the arguments. *)
-  let s = type_to_sign env (snd schema) in 
+  let s = type2signature env (snd schema) in 
   let ls = List.length s in 
   let la = List.length args in
   let mla = make_mlargs env mle s args metas in 
@@ -580,8 +621,8 @@ and extract_cst_app env mle mlt kn args =
   in 			    
   (* Different situations depending of the number of arguments: *)
   if ls = 0 then put_magic_if magic2 head
-  else if List.mem true s then 
-    if la >= ls || not (List.mem false s) 
+  else if List.mem Keep s then 
+    if la >= ls || not (List.exists isKill s) 
     then 
       put_magic_if (magic2 && not magic1) (MLapp (head, mla))
     else 
@@ -590,12 +631,17 @@ and extract_cst_app env mle mlt kn args =
       let s' = list_lastn ls' s in
       let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
       put_magic_if magic2 (anonym_or_dummy_lams (MLapp (head, mla)) s')
-  else 
+  else if List.mem (Kill Kother) s then 
     (* In the special case of always false signature, one dummy lam is left. *)
     (* So a [MLdummy] is left accordingly. *) 
     if la >= ls 
     then put_magic_if (magic2 && not magic1) (MLapp (head, MLdummy :: mla))
     else put_magic_if magic2 (dummy_lams head (ls-la-1))
+  else (* s is made only of [Kill Ktype] *)
+    if la >= ls 
+    then put_magic_if (magic2 && not magic1) (MLapp (head, mla))
+    else put_magic_if magic2 (dummy_lams head (ls-la))
+
 
 (*s Extraction of an inductive constructor applied to arguments. *)
 
@@ -613,12 +659,12 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
   let params_nb = mi.ind_nparams in 
   let oi = mi.ind_packets.(i) in 
   let nb_tvars = List.length oi.ip_vars
-  and types = List.map (type_expand env) oi.ip_types.(j-1) in
+  and types = List.map (expand env) oi.ip_types.(j-1) in
   let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in 
   let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in
   let type_cons = instantiation (nb_tvars, type_cons) in 
   (* Then, the usual variables [s], [ls], [la], ... *)
-  let s = List.map (type_neq env Tdummy) types in
+  let s = List.map (type2sign env) types in
   let ls = List.length s in 
   let la = List.length args in 
   assert (la <= ls + params_nb);
@@ -671,14 +717,13 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
 	(* Logical singleton case: *)
 	(* [match c with C i j k -> t] becomes [t'] *)
 	assert (br_size = 1);
-	let s = iterate (fun l -> false :: l) ni.(0) [] in
-	let mlt = iterate (fun t -> Tarr (Tdummy, t)) ni.(0) mlt in 
+	let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in
+	let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in 
 	let e = extract_maybe_term env mle mlt br.(0) in 
 	snd (case_expunge s e)
       end 
     else 
       let mi = extract_ind env kn in 
-      let params_nb = mi.ind_nparams in 
       let oi = mi.ind_packets.(i) in 
       let metas = Array.init (List.length oi.ip_vars) new_meta in 
       (* The extraction of the head. *)
@@ -687,10 +732,10 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
       (* The extraction of each branch. *)
       let extract_branch i = 
 	(* The types of the arguments of the corresponding constructor. *)
-	let f t = type_subst_vect metas (type_expand env t) in 
+	let f t = type_subst_vect metas (expand env t) in 
 	let l = List.map f oi.ip_types.(i) in
 	(* the corresponding signature *)
-	let s = List.map (type_neq env Tdummy) oi.ip_types.(i) in
+	let s = List.map (type2sign env) oi.ip_types.(i) in
 	(* Extraction of the branch (in functional form). *)
 	let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in 
 	(* We suppress dummy arguments according to signature. *)
@@ -746,8 +791,8 @@ let extract_std_constant env kn body typ =
   let t = snd (record_constant_type env kn (Some typ)) in 
   (* The real type [t']: without head lambdas, expanded, *)
   (* and with [Tvar] translated to [Tvar'] (not instantiable). *)
-  let l,t' = type_decomp (type_expand env (var2var' t)) in 
-  let s = List.map (type_neq env Tdummy) l in 
+  let l,t' = type_decomp (expand env (var2var' t)) in 
+  let s = List.map (type2sign env) l in 
   (* The initial ML environment. *)
   let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in 
   (* Decomposing the top level lambdas of [body]. *)
@@ -763,10 +808,12 @@ let extract_std_constant env kn body typ =
 
 let extract_fixpoint env vkn (fi,ti,ci) = 
   let n = Array.length vkn in 
-  let types = Array.make n Tdummy
+  let types = Array.make n (Tdummy Kother)
   and terms = Array.make n MLdummy in 
+  let kns = Array.to_list vkn in 
+  current_fixpoints := kns; 
   (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
-  let sub = List.rev_map mkConst (Array.to_list vkn) in 
+  let sub = List.rev_map mkConst kns in 
   for i = 0 to n-1 do 
     if sort_of env ti.(i) <> InProp then begin 
       let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
@@ -774,11 +821,12 @@ let extract_fixpoint env vkn (fi,ti,ci) =
       types.(i) <- t;
     end 
   done; 
+  current_fixpoints := [];
   Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) 
 		 
 let extract_constant env kn cb = 
   let r = ConstRef kn in 
-  let typ = cb.const_type in
+  let typ = Typeops.type_of_constant_type env cb.const_type in 
   match cb.const_body with
     | None -> (* A logical axiom is risky, an informative one is fatal. *) 
         (match flag_of_type env typ with
@@ -791,12 +839,14 @@ let extract_constant env kn cb =
 	       if not (is_custom r) then warning_info_ax r; 
 	       let t = snd (record_constant_type env kn (Some typ)) in 
 	       Dterm (r, MLaxiom, type_expunge env t) 
-           | (Logic,TypeScheme) -> warning_log_ax r; Dtype (r, [], Tdummy)
-	   | (Logic,Default) -> warning_log_ax r; Dterm (r, MLdummy, Tdummy))
+           | (Logic,TypeScheme) -> 
+	       warning_log_ax r; Dtype (r, [], Tdummy Ktype)
+	   | (Logic,Default) -> 
+	       warning_log_ax r; Dterm (r, MLdummy, Tdummy Kother))
     | Some body ->
 	(match flag_of_type env typ with
-	   | (Logic, Default) -> Dterm (r, MLdummy, Tdummy)
-	   | (Logic, TypeScheme) -> Dtype (r, [], Tdummy)
+	   | (Logic, Default) -> Dterm (r, MLdummy, Tdummy Kother)
+	   | (Logic, TypeScheme) -> Dtype (r, [], Tdummy Ktype)
 	   | (Info, Default) -> 
 	       let e,t = extract_std_constant env kn (force body) typ in 
 	       Dterm (r,e,t)
@@ -808,10 +858,10 @@ let extract_constant env kn cb =
 
 let extract_constant_spec env kn cb = 
   let r = ConstRef kn in 
-  let typ = cb.const_type in
+  let typ = Typeops.type_of_constant_type env cb.const_type in 
   match flag_of_type env typ with 
-    | (Logic, TypeScheme) -> Stype (r, [], Some Tdummy)
-    | (Logic, Default) -> Sval (r, Tdummy) 
+    | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype))
+    | (Logic, Default) -> Sval (r, Tdummy Kother) 
     | (Info, TypeScheme) -> 
 	let s,vl = type_sign_vl env typ in 
 	(match cb.const_body with 
@@ -827,7 +877,7 @@ let extract_constant_spec env kn cb =
 let extract_inductive env kn = 
   let ind = extract_ind env kn in 
   add_recursors env kn; 
-  let f l = List.filter (type_neq env Tdummy) l in 
+  let f l = List.filter (fun t -> not (isDummy (expand env t))) l in 
   let packets = 
     Array.map (fun p -> { p with ip_types = Array.map f p.ip_types }) 
       ind.ind_packets
@@ -846,7 +896,7 @@ let extract_declaration env r = match r with
 type kind = Logical | Term | Type 
     
 let constant_kind env cb = 
-  match flag_of_type env cb.const_type with 
+  match flag_of_type env (Typeops.type_of_constant_type env cb.const_type) with 
     | (Logic,_) -> Logical
     | (Info,TypeScheme) -> Type
     | (Info,Default) -> Term
@@ -854,19 +904,19 @@ let constant_kind env cb =
 (*s Is a [ml_decl] logical ? *) 
 
 let logical_decl = function 
-  | Dterm (_,MLdummy,Tdummy) -> true
-  | Dtype (_,[],Tdummy) -> true 
+  | Dterm (_,MLdummy,Tdummy _) -> true
+  | Dtype (_,[],Tdummy _) -> true 
   | Dfix (_,av,tv) -> 
       (array_for_all ((=) MLdummy) av) && 
-      (array_for_all ((=) Tdummy) tv)
+      (array_for_all isDummy tv)
   | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
   | _ -> false
 
 (*s Is a [ml_spec] logical ? *)
 
 let logical_spec = function 
-  | Stype (_, [], Some Tdummy) -> true
-  | Sval (_,Tdummy) -> true
+  | Stype (_, [], Some (Tdummy _)) -> true
+  | Sval (_,Tdummy _) -> true
   | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
   | _ -> false
 
diff --git a/contrib/extraction/extraction.mli b/contrib/extraction/extraction.mli
index fc5782c9..1dfd7e1a 100644
--- a/contrib/extraction/extraction.mli
+++ b/contrib/extraction/extraction.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraction.mli,v 1.27.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+(*i $Id: extraction.mli 6303 2004-11-16 12:37:40Z sacerdot $ i*)
 
 (*s Extraction from Coq terms to Miniml. *)
 
@@ -17,12 +17,12 @@ open Environ
 open Libnames
 open Miniml
 
-val extract_constant : env -> kernel_name -> constant_body -> ml_decl
+val extract_constant : env -> constant -> constant_body -> ml_decl
 
-val extract_constant_spec : env -> kernel_name -> constant_body -> ml_spec
+val extract_constant_spec : env -> constant -> constant_body -> ml_spec
 
 val extract_fixpoint : 
-  env -> kernel_name array -> (constr, types) prec_declaration -> ml_decl 
+  env -> constant array -> (constr, types) prec_declaration -> ml_decl 
 
 val extract_inductive : env -> kernel_name -> ml_ind
 
diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4
index 33a6117d..13b29c7b 100644
--- a/contrib/extraction/g_extraction.ml4
+++ b/contrib/extraction/g_extraction.ml4
@@ -15,10 +15,7 @@ open Pcoq
 open Genarg
 open Pp
 
-let pr_mlname _ _ s =
-  spc () ++
-  (if !Options.v7 && not (Options.do_translate()) then qs s
-  else Pptacticnew.qsnew s)
+let pr_mlname _ _ _ s = spc () ++ qs s
 
 ARGUMENT EXTEND mlname
   TYPED AS string
@@ -37,21 +34,6 @@ VERNAC ARGUMENT EXTEND language
 | [ "Toplevel" ] -> [ Toplevel ]
 END
 
-(* Temporary for translator *)
-if !Options.v7 then
-  let pr_language _ _ = function
-    | Ocaml -> str " Ocaml"
-    | Haskell -> str " Haskell"
-    | Scheme -> str " Scheme"
-    | Toplevel -> str " Toplevel"
-  in
-  let globwit_language = Obj.magic rawwit_language in
-  let wit_language = Obj.magic rawwit_language in
-  Pptactic.declare_extra_genarg_pprule true
-    (rawwit_language, pr_language)
-    (globwit_language, pr_language)
-    (wit_language, pr_language);
-
 (* Extraction commands *)
 
 VERNAC COMMAND EXTEND Extraction
diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml
index 3834fe81..f924396c 100644
--- a/contrib/extraction/haskell.ml
+++ b/contrib/extraction/haskell.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: haskell.ml,v 1.40.2.5 2005/12/16 04:11:28 letouzey Exp $ i*)
+(*i $Id: haskell.ml 8930 2006-06-09 02:14:34Z letouzey $ i*)
 
 (*s Production of Haskell syntax. *)
 
@@ -106,7 +106,7 @@ let rec pp_type par vl t =
     | Tarr (t1,t2) ->
 	pp_par par 
 	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
-    | Tdummy -> str "()"
+    | Tdummy _ -> str "()"
     | Tunknown -> str "()"
     | Taxiom -> str "() -- AXIOM TO BE REALIZED\n"
  in 
@@ -210,7 +210,7 @@ and pp_function env f t =
   (f ++ pr_binding (List.rev bl) ++
      str " =" ++ fnl () ++ str "  " ++
      hov 2 (pp_expr false env' [] t'))
-	
+
 (*s Pretty-printing of inductive types declaration. *)
 
 let pp_comment s = str "-- " ++ s ++ fnl ()
@@ -240,11 +240,11 @@ let pp_one_ind ip pl cv =
       	       	prlist_with_sep 
 		  (fun () -> (str " ")) (pp_type true pl) l))
   in
-  str (if cv = [||] then "type " else "data ") ++ 
+  str (if Array.length cv = 0 then "type " else "data ") ++ 
   pp_global (IndRef ip) ++ str " " ++
   prlist_with_sep (fun () -> str " ") pr_lower_id pl ++
   (if pl = [] then mt () else str " ") ++
-  if cv = [||] then str "= () -- empty inductive"
+  if Array.length cv = 0 then str "= () -- empty inductive"
   else 
     (v 0 (str "= " ++
 	  prvect_with_sep (fun () -> fnl () ++ str "  | ") pp_constructor 
@@ -289,12 +289,16 @@ let pp_decl mpl =
 	    else str "=" ++ spc () ++ pp_type false l t
 	in 
 	hov 2 (str "type " ++ pp_global r ++ spc () ++ st) ++ fnl () ++ fnl ()
-  | Dfix (rv, defs,_) ->
-      let ppv = Array.map pp_global rv in 
-      prlist_with_sep (fun () -> fnl () ++ fnl ())
-	(fun (pi,ti) -> pp_function (empty_env ()) pi ti)
-	(List.combine (Array.to_list ppv) (Array.to_list defs)) 
-      ++ fnl () ++ fnl ()
+  | Dfix (rv, defs, typs) ->
+      let max = Array.length rv in 
+      let rec iter i = 
+	if i = max then mt () 
+	else
+	  let e = pp_global rv.(i) in 
+	  e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () 
+	  ++ pp_function (empty_env ()) e defs.(i) ++ fnl () ++ fnl () 
+	  ++ iter (i+1)
+      in iter 0
   | Dterm (r, a, t) ->
       if is_inline_custom r then mt () 
       else 
diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli
index 822444bd..106f7868 100644
--- a/contrib/extraction/haskell.mli
+++ b/contrib/extraction/haskell.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: haskell.mli,v 1.15.6.2 2005/12/01 17:01:22 letouzey Exp $ i*)
+(*i $Id: haskell.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
 
 open Pp
 open Names
diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli
index 7c18f9f5..3b4146f8 100644
--- a/contrib/extraction/miniml.mli
+++ b/contrib/extraction/miniml.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: miniml.mli,v 1.46.2.3 2005/12/01 16:43:58 letouzey Exp $ i*)
+(*i $Id: miniml.mli 9456 2006-12-17 20:08:38Z letouzey $ i*)
 
 (*s Target language for extraction: a core ML called MiniML. *)
 
@@ -18,11 +18,18 @@ open Libnames
 (* The [signature] type is used to know how many arguments a CIC
    object expects, and what these arguments will become in the ML
    object. *)
+
+(* We eliminate from terms:  1) types 2) logical parts.
+   [Kother] stands both for logical or unknown reason. *)
+
+type kill_reason = Ktype | Kother
+
+type sign = Keep | Kill of kill_reason
+
    
-(* Convention: outmost lambda/product gives the head of the list, 
-   and [true] means that the argument is to be kept. *)
+(* Convention: outmost lambda/product gives the head of the list. *)
 
-type signature = bool list
+type signature = sign list
 
 (*s ML type expressions. *)
 
@@ -32,7 +39,7 @@ type ml_type =
   | Tvar    of int
   | Tvar'   of int (* same as Tvar, used to avoid clash *)
   | Tmeta   of ml_meta (* used during ML type reconstruction *)
-  | Tdummy
+  | Tdummy  of kill_reason
   | Tunknown
   | Taxiom
 
@@ -72,7 +79,9 @@ type ml_ind_packet = {
 type ml_ind = {
   ind_info : inductive_info;
   ind_nparams : int; 	       
-  ind_packets : ml_ind_packet array }
+  ind_packets : ml_ind_packet array;
+  ind_equiv : kernel_name option
+}
 
 (*s ML terms. *)
 
diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml
index c01766b0..6bfedce5 100644
--- a/contrib/extraction/mlutil.ml
+++ b/contrib/extraction/mlutil.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mlutil.ml,v 1.104.2.3 2005/12/01 16:28:04 letouzey Exp $ i*)
+(*i $Id: mlutil.ml 8886 2006-06-01 13:53:45Z letouzey $ i*)
 
 (*i*)
 open Pp
@@ -111,7 +111,7 @@ let rec mgu = function
        List.iter mgu (List.combine l l')
   | Tvar i, Tvar j when i = j -> ()
   | Tvar' i, Tvar' j when i = j -> ()
-  | Tdummy, Tdummy -> ()
+  | Tdummy _, Tdummy _ -> ()
   | Tunknown, Tunknown -> ()
   | _ -> raise Impossible
 
@@ -209,8 +209,8 @@ end
 (*s Does a section path occur in a ML type ? *)
 
 let rec type_mem_kn kn = function 
-  | Tmeta _ -> assert false
-  | Tglob (r,l) -> (kn_of_r r) = kn || List.exists (type_mem_kn kn) l
+  | Tmeta {contents = Some t} -> type_mem_kn kn t
+  | Tglob (r,l) -> occur_kn_in_ref kn r || List.exists (type_mem_kn kn) l
   | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b)
   | _ -> false
 
@@ -218,7 +218,7 @@ let rec type_mem_kn kn = function
 
 let type_maxvar t = 
   let rec parse n = function 
-    | Tmeta _ -> assert false
+    | Tmeta {contents = Some t} -> parse n t
     | Tvar i -> max i n 
     | Tarr (a,b) -> parse (parse n a) b
     | Tglob (_,l) -> List.fold_left parse n l 
@@ -228,7 +228,7 @@ let type_maxvar t =
 (*s From [a -> b -> c] to [[a;b],c]. *) 
 
 let rec type_decomp = function 
-  | Tmeta _ -> assert false
+  | Tmeta {contents = Some t} -> type_decomp t 
   | Tarr (a,b) -> let l,h = type_decomp b in a::l, h 
   | a -> [],a
 
@@ -241,7 +241,7 @@ let rec type_recomp (l,t) = match l with
 (*s Translating [Tvar] to [Tvar'] to avoid clash. *)
 
 let rec var2var' = function 
-  | Tmeta _ -> assert false
+  | Tmeta {contents = Some t} -> var2var' t
   | Tvar i -> Tvar' i
   | Tarr (a,b) -> Tarr (var2var' a, var2var' b)
   | Tglob (r,l) -> Tglob (r, List.map var2var' l)
@@ -254,14 +254,14 @@ type abbrev_map = global_reference -> ml_type option
 
 let type_expand env t = 
   let rec expand = function
-    | Tmeta _ -> assert false
-    | Tglob (r,l) as t ->    
+    | Tmeta {contents = Some t} -> expand t
+    | Tglob (r,l) ->    
 	(match env r with 
 	   | Some mlt -> expand (type_subst_list l mlt) 
 	   | None -> Tglob (r, List.map expand l))
     | Tarr (a,b) -> Tarr (expand a, expand b)
     | a -> a
-  in expand t
+  in if Table.type_expand () then expand t else t
 
 (*s Idem, but only at the top level of implications. *)
 
@@ -269,7 +269,7 @@ let is_arrow = function Tarr _ -> true | _ -> false
 
 let type_weak_expand env t = 
   let rec expand = function
-    | Tmeta _ -> assert false
+    | Tmeta {contents = Some t} -> expand t
     | Tglob (r,l) as t ->    
 	(match env r with 
 	   | Some mlt -> 
@@ -280,34 +280,39 @@ let type_weak_expand env t =
     | a -> a
   in expand t
 
-(*s Equality over ML types modulo delta-reduction *)
-
-let type_eq env t t' = (type_expand env t = type_expand env t')
-
-let type_neq env t t' = (type_expand env t <> type_expand env t')
-
 (*s Generating a signature from a ML type. *)
 
-let type_to_sign env t = 
+let type_to_sign env t = match type_expand env t with 
+  | Tdummy d -> Kill d 
+  | _ -> Keep
+
+let type_to_signature env t = 
   let rec f = function 
-    | Tmeta _ -> assert false
-    | Tarr (a,b) -> (Tdummy <> a) :: (f b)
+    | Tmeta {contents = Some t} -> f t 
+    | Tarr (Tdummy d, b) -> Kill d :: f b
+    | Tarr (_, b) -> Keep :: f b
     | _ -> [] 
   in f (type_expand env t)
 
+let isKill = function Kill _ -> true | _ -> false
+
+let isDummy = function Tdummy _ -> true | _ -> false
+
+let sign_of_id i = if i = dummy_name then Kill Kother else Keep
+
 (*s Removing [Tdummy] from the top level of a ML type. *)
 
 let type_expunge env t = 
-  let s = type_to_sign env t in 
+  let s = type_to_signature env t in 
   if s = [] then t 
-  else if List.mem true s then 
+  else if List.mem Keep s then 
     let rec f t s = 
-      if List.mem false s then 
+      if List.exists isKill s then 
 	match t with 
-	  | Tmeta _ -> assert false
+	  | Tmeta {contents = Some t} -> f t s
 	  | Tarr (a,b) -> 
 	      let t = f b (List.tl s) in 
-	      if List.hd s then Tarr (a, t) else t  
+	      if List.hd s = Keep then Tarr (a, t) else t  
 	  | Tglob (r,l) ->
 	      (match env r with 
 		 | Some mlt -> f (type_subst_list l mlt) s
@@ -315,7 +320,9 @@ let type_expunge env t =
 	  | _ -> assert false
       else t 
     in f t s 
-  else Tarr (Tdummy, snd (type_decomp (type_weak_expand env t))) 
+  else if List.mem (Kill Kother) s then 
+    Tarr (Tdummy Kother, snd (type_decomp (type_weak_expand env t))) 
+  else snd (type_decomp (type_weak_expand env t))
 
 (*S Generic functions over ML ast terms. *)
 
@@ -377,7 +384,7 @@ let ast_iter f = function
   | MLapp (a,l) -> f a; List.iter f l
   | MLcons (_,c,l) -> List.iter f l
   | MLmagic a -> f a
-  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> ()
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom  -> ()
 
 (*S Operations concerning De Bruijn indices. *)
 
@@ -535,8 +542,8 @@ let rec dummy_lams a = function
 
 let rec anonym_or_dummy_lams a = function 
   | [] -> a 
-  | true :: s -> MLlam(anonymous, anonym_or_dummy_lams a s)
-  | false :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s)
+  | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s)
+  | Kill _ :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s)
 
 (*S Operations concerning eta. *)
 
@@ -549,8 +556,8 @@ let rec eta_args n =
 
 let rec eta_args_sign n = function 
   | [] -> [] 
-  | true :: s -> (MLrel n) :: (eta_args_sign (n-1) s) 
-  | false :: s -> eta_args_sign (n-1) s
+  | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s) 
+  | Kill _ :: s -> eta_args_sign (n-1) s
 
 (*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *)
 
@@ -594,11 +601,12 @@ let rec linear_beta_red a t = match a,t with
   linear beta reductions at modified positions. *)  
 
 let rec ast_glob_subst s t = match t with 
-  | MLapp ((MLglob (ConstRef kn)) as f, a) -> 
+  | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> 
       let a = List.map (ast_glob_subst s) a in 
-      (try linear_beta_red a (KNmap.find kn s) 
+      (try linear_beta_red a (Refmap.find refe s) 
        with Not_found -> MLapp (f, a))
-  | MLglob (ConstRef kn) -> (try KNmap.find kn s with Not_found -> t)
+  | MLglob ((ConstRef kn) as refe) ->
+      (try Refmap.find refe s with Not_found -> t)
   | _ -> ast_map (ast_glob_subst s) t
 
 
@@ -653,7 +661,7 @@ let check_generalizable_case unsafe br =
 (*s Do all branches correspond to the same thing? *)
 
 let check_constant_case br = 
-  if br = [||] then raise Impossible; 
+  if Array.length br = 0 then raise Impossible; 
   let (r,l,t) = br.(0) in
   let n = List.length l in 
   if ast_occurs_itvl 1 n t then raise Impossible; 
@@ -818,33 +826,33 @@ let rec post_simpl = function
 (*S Local prop elimination. *) 
 (* We try to eliminate as many [prop] as possible inside an [ml_ast]. *)
 
-(*s In a list, it selects only the elements corresponding to a [true] 
+(*s In a list, it selects only the elements corresponding to a [Keep] 
    in the boolean list [l]. *)
 
 let rec select_via_bl l args = match l,args with 
   | [],_ -> args
-  | true::l,a::args -> a :: (select_via_bl l args)
-  | false::l,a::args -> select_via_bl l args
+  | Keep::l,a::args -> a :: (select_via_bl l args)
+  | Kill _::l,a::args -> select_via_bl l args
   | _ -> assert false 
 
-(*s [kill_some_lams] removes some head lambdas according to the bool list [bl].
+(*s [kill_some_lams] removes some head lambdas according to the signature [bl].
    This list is build on the identifier list model: outermost lambda
-   is on the right. [true] means "to keep" and [false] means "to eliminate". 
+   is on the right. 
    [Rels] corresponding to removed lambdas are supposed not to occur, and 
    the other [Rels] are made correct via a [gen_subst].
    Output is not directly a [ml_ast], compose with [named_lams] if needed. *)
 
 let kill_some_lams bl (ids,c) =
   let n = List.length bl in
-  let n' = List.fold_left (fun n b -> if b then (n+1) else n) 0 bl in 
+  let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in 
   if n = n' then ids,c
   else if n' = 0 then [],ast_lift (-n) c 
   else begin
     let v = Array.make n MLdummy in 
     let rec parse_ids i j = function 
       | [] -> ()
-      | true :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l
-      | false :: l -> parse_ids (i+1) j l
+      | Keep :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l
+      | Kill _ :: l -> parse_ids (i+1) j l
     in parse_ids 0 1 bl ; 
     select_via_bl bl ids, gen_subst v (n'-n) c
   end
@@ -855,8 +863,8 @@ let kill_some_lams bl (ids,c) =
 
 let kill_dummy_lams c = 
   let ids,c = collect_lams c in 
-  let bl = List.map ((<>) dummy_name) ids in 
-  if (List.mem true bl) && (List.mem false bl) then 
+  let bl = List.map sign_of_id ids in
+  if (List.mem Keep bl) && (List.exists isKill bl) then 
     let ids',c = kill_some_lams bl (ids,c) in 
     ids, named_lams ids' c
   else raise Impossible
@@ -864,7 +872,7 @@ let kill_dummy_lams c =
 (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] 
    and a signature [s] and builds a eta-long version. *)
 
-(* For example, if [s = [true;true;false;true]] then the output is :
+(* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is :
    [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)]  with [c' = lift 4 c] *)
 
 let eta_expansion_sign s (ids,c) =
@@ -872,13 +880,13 @@ let eta_expansion_sign s (ids,c) =
     | [] -> 
 	let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels
 	in ids, MLapp (ast_lift (i-1) c, a) 
-    | true :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l 
-    | false :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l
+    | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l 
+    | Kill _ :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l
   in abs ids [] 1 s
 
 (*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] 
   in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas 
-  corresponding to [false] in [s]. *)
+  corresponding to [Del] in [s]. *)
 
 let case_expunge s e = 
   let m = List.length s in 
@@ -890,13 +898,14 @@ let case_expunge s e =
 (*s [term_expunge] takes a function [fun idn ... id1 -> c] 
   and a signature [s] and remove dummy lams. The difference 
   with [case_expunge] is that we here leave one dummy lambda 
-  if all lambdas are dummy. *)
+  if all lambdas are logical dummy. *)
 
 let term_expunge s (ids,c) =
   if s = [] then c 
   else 
     let ids,c = kill_some_lams (List.rev s) (ids,c) in 
-    if ids = [] then MLlam (dummy_name, ast_lift 1 c)
+    if ids = [] && List.mem (Kill Kother) s then 
+      MLlam (dummy_name, ast_lift 1 c)
     else named_lams ids c
 
 (*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and 
@@ -905,7 +914,7 @@ let term_expunge s (ids,c) =
 
 let kill_dummy_args ids t0 t =
   let m = List.length ids in 
-  let bl = List.rev_map ((<>) dummy_name) ids in
+  let bl = List.rev_map sign_of_id ids in
   let rec killrec n = function 
     | MLapp(e, a) when e = ast_lift n t0 -> 
 	let k = max 0 (m - (List.length a)) in 
@@ -972,7 +981,8 @@ let general_optimize_fix f ids n args m c =
   let v = Array.make n 0 in 
   for i=0 to (n-1) do v.(i)<-i done;
   let aux i = function 
-    | MLrel j when v.(j-1)>=0 -> v.(j-1)<-(-i-1)
+    | MLrel j when v.(j-1)>=0 -> 
+	if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1)
     | _ -> raise Impossible
   in list_iter_i aux args; 
   let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in
@@ -999,8 +1009,7 @@ let optimize_fix a =
 		 -> a'
 	     | MLfix(_,[|f|],[|c|]) -> 
 		 (try general_optimize_fix f ids n args m c
-		  with Impossible -> 
-		    named_lams ids (MLapp (MLfix (0,[|f|],[|c|]),args))) 
+		  with Impossible -> a)
 	     | _ -> a)
       | _ -> a
 
@@ -1117,7 +1126,7 @@ let inline_test t =
 
 let manual_inline_list = 
   let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in 
-  List.map (fun s -> (make_kn mp empty_dirpath (mk_label s)))
+  List.map (fun s -> (make_con mp empty_dirpath (mk_label s)))
     [ "well_founded_induction_type"; "well_founded_induction"; 
       "Acc_rect"; "Acc_rec" ; "Acc_iter" ]
 
diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli
index eaf38778..a55caaf2 100644
--- a/contrib/extraction/mlutil.mli
+++ b/contrib/extraction/mlutil.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mlutil.mli,v 1.47.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+(*i $Id: mlutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*)
 
 open Util
 open Names
@@ -62,13 +62,15 @@ val var2var' : ml_type -> ml_type
 type abbrev_map = global_reference -> ml_type option
 
 val type_expand : abbrev_map -> ml_type -> ml_type 
-val type_eq : abbrev_map -> ml_type -> ml_type -> bool
-val type_neq : abbrev_map -> ml_type -> ml_type -> bool
-val type_to_sign : abbrev_map -> ml_type -> bool list
+val type_to_sign : abbrev_map -> ml_type -> sign
+val type_to_signature : abbrev_map -> ml_type -> signature
 val type_expunge : abbrev_map -> ml_type -> ml_type
 
-val case_expunge : bool list -> ml_ast -> identifier list * ml_ast
-val term_expunge : bool list -> identifier list * ml_ast -> ml_ast
+val isDummy : ml_type -> bool
+val isKill : sign -> bool
+
+val case_expunge : signature -> ml_ast -> identifier list * ml_ast
+val term_expunge : signature -> identifier list * ml_ast -> ml_ast
 
 
 (*s Special identifiers. [dummy_name] is to be used for dead code
@@ -86,9 +88,9 @@ val collect_n_lams : int -> ml_ast -> identifier list * ml_ast
 val nb_lams : ml_ast -> int
 
 val dummy_lams : ml_ast -> int -> ml_ast
-val anonym_or_dummy_lams : ml_ast -> bool list -> ml_ast
+val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast
 
-val eta_args_sign : int -> bool list -> ml_ast list 
+val eta_args_sign : int -> signature -> ml_ast list 
 
 (*s Utility functions over ML terms. *)
 
@@ -101,7 +103,7 @@ val ast_lift : int -> ml_ast -> ml_ast
 val ast_pop : ml_ast -> ml_ast
 val ast_subst : ml_ast -> ml_ast -> ml_ast
 
-val ast_glob_subst : ml_ast KNmap.t -> ml_ast -> ml_ast
+val ast_glob_subst : ml_ast Refmap.t -> ml_ast -> ml_ast
 
 val normalize : ml_ast -> ml_ast 
 val optimize_fix : ml_ast -> ml_ast
diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml
index 54f0c992..c9d4e237 100644
--- a/contrib/extraction/modutil.ml
+++ b/contrib/extraction/modutil.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modutil.ml,v 1.7.2.4 2005/12/01 17:01:22 letouzey Exp $ i*)
+(*i $Id: modutil.ml 9456 2006-12-17 20:08:38Z letouzey $ i*)
 
 open Names
 open Declarations
@@ -16,6 +16,7 @@ open Util
 open Miniml
 open Table
 open Mlutil
+open Mod_subst
 
 (*S Functions upon modules missing in [Modops]. *) 
 
@@ -25,8 +26,9 @@ open Mlutil
 let add_structure mp msb env = 
   let add_one env (l,elem) = 
     let kn = make_kn mp empty_dirpath l in 
+    let con = make_con mp empty_dirpath l in 
     match elem with 
-      | SEBconst cb -> Environ.add_constant kn cb env 
+      | SEBconst cb -> Environ.add_constant con cb env 
       | SEBmind mib -> Environ.add_mind kn mib env 
       | SEBmodule mb -> Modops.add_module (MPdot (mp,l)) mb env 
       | SEBmodtype mtb -> Environ.add_modtype kn mtb env  
@@ -116,8 +118,15 @@ let rec parse_labels ll = function
 
 let labels_of_mp mp = parse_labels [] mp 
 
-let labels_of_kn kn = 
-  let mp,_,l = repr_kn kn in parse_labels [l] mp
+let labels_of_ref r = 
+ let mp,_,l =
+  match r with
+     ConstRef con -> repr_con con
+   | IndRef (kn,_)
+   | ConstructRef ((kn,_),_) -> repr_kn kn
+   | VarRef _ -> assert false
+ in
+  parse_labels [l] mp
 
 let rec add_labels_mp mp = function 
   | [] -> mp 
@@ -176,7 +185,7 @@ let ast_iter_references do_term do_cons do_type a =
       | MLcons (i,r,_) -> 
 	  if lang () = Ocaml then record_iter_references do_term i; 
 	  do_cons r 
-      | MLcase (i,_,v) as a -> 
+      | MLcase (i,_,v) -> 
 	  if lang () = Ocaml then record_iter_references do_term i; 
 	  Array.iter (fun (r,_,_) -> do_cons r) v
       | _ -> ()
@@ -186,7 +195,10 @@ let ind_iter_references do_term do_cons do_type kn ind =
   let type_iter = type_iter_references do_type in
   let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in 
   let packet_iter ip p = 
-    do_type (IndRef ip); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types 
+    do_type (IndRef ip); 
+    if lang () = Ocaml then 
+      option_iter (fun kne -> do_type (IndRef (kne,snd ip))) ind.ind_equiv; 
+    Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types 
   in
   if lang () = Ocaml then record_iter_references do_term ind.ind_info; 
   Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
@@ -243,40 +255,40 @@ let struct_get_references_list struc =
 
 exception Found
 
-let rec ast_search t a = 
-  if t a then raise Found else ast_iter (ast_search t) a
+let rec ast_search f a = 
+  if f a then raise Found else ast_iter (ast_search f) a
 
-let decl_ast_search t = function 
-  | Dterm (_,a,_) -> ast_search t a
-  | Dfix (_,c,_) -> Array.iter (ast_search t) c
+let decl_ast_search f = function 
+  | Dterm (_,a,_) -> ast_search f a
+  | Dfix (_,c,_) -> Array.iter (ast_search f) c
   | _ -> () 
 
-let struct_ast_search t s = 
-  try struct_iter (decl_ast_search t) (fun _ -> ()) s; false
+let struct_ast_search f s = 
+  try struct_iter (decl_ast_search f) (fun _ -> ()) s; false
   with Found -> true
 
-let rec type_search t = function  
-  | Tarr (a,b) -> type_search t a; type_search t b 
-  | Tglob (r,l) -> List.iter (type_search t) l
-  | u -> if t = u then raise Found
+let rec type_search f = function  
+  | Tarr (a,b) -> type_search f a; type_search f b 
+  | Tglob (r,l) -> List.iter (type_search f) l
+  | u -> if f u then raise Found
 
-let decl_type_search t = function 
+let decl_type_search f = function 
   | Dind (_,{ind_packets=p})  -> 
       Array.iter 
-	(fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p
-  | Dterm (_,_,u) -> type_search t u
-  | Dfix (_,_,v) -> Array.iter (type_search t) v
-  | Dtype (_,_,u) -> type_search t u
+	(fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p
+  | Dterm (_,_,u) -> type_search f u
+  | Dfix (_,_,v) -> Array.iter (type_search f) v
+  | Dtype (_,_,u) -> type_search f u
 
-let spec_type_search t = function 
+let spec_type_search f = function 
   | Sind (_,{ind_packets=p}) -> 
       Array.iter 
-	(fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p
-  | Stype (_,_,ot) -> option_iter (type_search t) ot
-  | Sval (_,u) -> type_search t u
+	(fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p
+  | Stype (_,_,ot) -> option_iter (type_search f) ot
+  | Sval (_,u) -> type_search f u
 
-let struct_type_search t s = 
-  try struct_iter (decl_type_search t) (spec_type_search t) s; false
+let struct_type_search f s = 
+  try struct_iter (decl_type_search f) (spec_type_search f) s; false
   with Found -> true
 
 
@@ -307,8 +319,7 @@ let signature_of_structure s =
 
 let get_decl_in_structure r struc = 
   try 
-    let kn = kn_of_r r in 
-    let base_mp,ll = labels_of_kn kn in 
+    let base_mp,ll = labels_of_ref r in 
     if not (at_toplevel base_mp) then error_not_visible r;
     let sel = List.assoc base_mp struc in
     let rec go ll sel = match ll with 
@@ -336,27 +347,27 @@ let get_decl_in_structure r struc =
 let dfix_to_mlfix rv av i = 
   let rec make_subst n s = 
     if n < 0 then s 
-    else make_subst (n-1) (KNmap.add (kn_of_r rv.(n)) (n+1) s)
+    else make_subst (n-1) (Refmap.add rv.(n) (n+1) s)
   in 
-  let s = make_subst (Array.length rv - 1) KNmap.empty 
+  let s = make_subst (Array.length rv - 1) Refmap.empty 
   in 
   let rec subst n t = match t with 
-    | MLglob (ConstRef kn) -> 
-	(try MLrel (n + (KNmap.find kn s)) with Not_found -> t)
+    | MLglob ((ConstRef kn) as refe) -> 
+	(try MLrel (n + (Refmap.find refe s)) with Not_found -> t)
     | _ -> ast_map_lift subst n t 
   in 
-  let ids = Array.map (fun r -> id_of_label (label (kn_of_r r))) rv in 
+  let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in 
   let c = Array.map (subst 0) av 
   in MLfix(i, ids, c)
 
 let rec optim prm s = function
   | [] -> []
-  | (Dtype (r,_,Tdummy) | Dterm(r,MLdummy,_)) as d :: l ->
+  | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l ->
       if List.mem r prm.to_appear then d :: (optim prm s l) else optim prm s l
   | Dterm (r,t,typ) :: l ->
       let t = normalize (ast_glob_subst !s t) in 
       let i = inline r t in 
-      if i then s := KNmap.add (kn_of_r r) t !s; 
+      if i then s := Refmap.add r t !s; 
       if not i || prm.modular || List.mem r prm.to_appear 
       then 
 	let d = match optimize_fix t with 
@@ -370,10 +381,9 @@ let rec optim prm s = function
 let rec optim_se top prm s = function 
   | [] -> [] 
   | (l,SEdecl (Dterm (r,a,t))) :: lse -> 
-      let kn = kn_of_r r in 
       let a = normalize (ast_glob_subst !s a) in 
       let i = inline r a in 
-      if i then s := KNmap.add kn a !s; 
+      if i then s := Refmap.add r a !s; 
       if top && i && not prm.modular && not (List.mem r prm.to_appear)
       then optim_se top prm s lse
       else 
@@ -389,7 +399,7 @@ let rec optim_se top prm s = function
       let fake_body = MLfix (0,[||],[||]) in 
       for i = 0 to Array.length rv - 1 do 
 	if inline rv.(i) fake_body
-	then s := KNmap.add (kn_of_r rv.(i)) (dfix_to_mlfix rv av i) !s
+	then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s
 	else all := false
       done; 
       if !all && top && not prm.modular 
@@ -408,6 +418,6 @@ and optim_me prm s = function
   | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me prm s me)
 
 let optimize_struct prm before struc = 
-  let subst = ref (KNmap.empty : ml_ast KNmap.t) in 
+  let subst = ref (Refmap.empty : ml_ast Refmap.t) in 
   option_iter (fun l -> ignore (optim prm subst l)) before; 
   List.map (fun (mp,lse) -> (mp, optim_se true prm subst lse)) struc
diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli
index 7f8c4113..115a42ca 100644
--- a/contrib/extraction/modutil.mli
+++ b/contrib/extraction/modutil.mli
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modutil.mli,v 1.2.2.2 2005/12/01 17:01:22 letouzey Exp $ i*)
+(*i $Id: modutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*)
 
 open Names
 open Declarations
 open Environ
 open Libnames
 open Miniml
+open Mod_subst
 
 (*s Functions upon modules missing in [Modops]. *) 
 
@@ -43,7 +44,7 @@ val add_labels_mp : module_path -> label list -> module_path
 (*s Functions upon ML modules. *)
 
 val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool
-val struct_type_search : ml_type -> ml_structure -> bool
+val struct_type_search : (ml_type -> bool) -> ml_structure -> bool
 
 type do_ref = global_reference -> unit 
 
diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml
index ff9cfd21..35f9a83c 100644
--- a/contrib/extraction/ocaml.ml
+++ b/contrib/extraction/ocaml.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ocaml.ml,v 1.100.2.6 2005/12/01 17:01:22 letouzey Exp $ i*)
+(*i $Id: ocaml.ml 9472 2007-01-05 15:49:32Z letouzey $ i*)
 
 (*s Production of Ocaml syntax. *)
 
@@ -196,7 +196,7 @@ let rec pp_type par vl t =
     | Tarr (t1,t2) ->
 	pp_par par 
 	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
-    | Tdummy -> str "__"
+    | Tdummy _ -> str "__"
     | Tunknown -> str "__"
   in 
   hov 0 (pp_rec par t)
@@ -264,7 +264,6 @@ let rec pp_expr par env args =
 	let tuple = pp_tuple (pp_expr true env []) args' in 
 	pp_par par (pp_global r ++ spc () ++ tuple)
     | MLcase (i, t, pv) ->
-	let r,_,_ = pv.(0) in 
 	let expr = if i = Coinductive then 
 	  (str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
 	else 
@@ -344,13 +343,9 @@ and pp_pat env i pv =
 and pp_function env f t =
   let bl,t' = collect_lams t in
   let bl,env' = push_vars bl env in
-  let is_function pv =
-    let ktl = array_map_to_list (fun (_,l,t0) -> (List.length l,t0)) pv in
-    not (List.exists (fun (k,t0) -> ast_occurs (k+1) t0) ktl)
-  in
   match t' with 
-    | MLcase(i,MLrel 1,pv) when i=Standard ->
-	if is_function pv then
+    | MLcase(i,MLrel 1,pv) when i=Standard -> 
+	if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then 
 	  (f ++ pr_binding (List.rev (List.tl bl)) ++
        	     str " = function" ++ fnl () ++
 	     v 0 (str "  | " ++ pp_pat env' i pv))
@@ -359,7 +354,6 @@ and pp_function env f t =
              str " = match " ++
 	     pr_id (List.hd bl) ++ str " with" ++ fnl () ++
 	     v 0 (str "  | " ++ pp_pat env' i pv))
-	  
     | _ -> (f ++ pr_binding (List.rev bl) ++
 	      str " =" ++ fnl () ++ str "  " ++
 	      hov 2 (pp_expr false env' [] t'))
@@ -398,7 +392,14 @@ let rec pp_Dfix init i ((rv,c,t) as fix) =
 	
 (*s Pretty-printing of inductive types declaration. *)
 
-let pp_one_ind prefix ip pl cv =
+let pp_equiv param_list = function 
+  | None -> mt ()
+  | Some ip_equiv -> 
+      str " = " ++ pp_parameters param_list ++ pp_global (IndRef ip_equiv)
+
+let pp_comment s = str "(* " ++ s ++ str " *)"
+
+let pp_one_ind prefix ip ip_equiv pl cv =
   let pl = rename_tvars keywords pl in
   let pp_constructor (r,l) =
     hov 2 (str "  | " ++ pp_global r ++
@@ -408,13 +409,12 @@ let pp_one_ind prefix ip pl cv =
 		      prlist_with_sep 
 			(fun () -> spc () ++ str "* ") (pp_type true pl) l))
   in
-  pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++ str " =" ++ 
-  if cv = [||] then str " unit (* empty inductive *)" 
+  pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++
+  pp_equiv pl ip_equiv ++ str " =" ++
+  if Array.length cv = 0 then str " unit (* empty inductive *)" 
   else fnl () ++ v 0 (prvect_with_sep fnl pp_constructor
 			(Array.mapi (fun i c -> ConstructRef (ip,i+1), c) cv))
 
-let pp_comment s = str "(* " ++ s ++ str " *)"
-
 let pp_logical_ind packet = 
   pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ 
   fnl () ++ pp_comment (str "with constructors : " ++ 
@@ -428,10 +428,11 @@ let pp_singleton kn packet =
 	 pp_comment (str "singleton inductive, whose constructor was " ++ 
 		     pr_id packet.ip_consnames.(0)))
 
-let pp_record kn projs packet = 
+let pp_record kn projs ip_equiv packet = 
   let l = List.combine projs packet.ip_types.(0) in 
   let pl = rename_tvars keywords packet.ip_vars in 
-  str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ str " = { "++
+  str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ 
+  pp_equiv pl ip_equiv ++ str " = { "++
   hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) 
 	   (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) 
   ++ str " }"
@@ -440,17 +441,20 @@ let pp_coind ip pl =
   let r = IndRef ip in 
   let pl = rename_tvars keywords pl in
   pp_parameters pl ++ pp_global r ++ str " = " ++ 
-  pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t"
+  pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t" ++ 
+  fnl() ++ str "and "
 
 let pp_ind co kn ind =
+  let prefix = if co then "__" else "" in 
   let some = ref false in 
   let init= ref (str "type ") in 
   let rec pp i =  
     if i >= Array.length ind.ind_packets then mt () 
     else 
       let ip = (kn,i) in 
+      let ip_equiv = option_map (fun kn -> (kn,i)) ind.ind_equiv in 
       let p = ind.ind_packets.(i) in 
-      if is_custom (IndRef (kn,i)) then pp (i+1)
+      if is_custom (IndRef ip) then pp (i+1)
       else begin 
 	some := true; 
 	if p.ip_logical then pp_logical_ind p ++ pp (i+1)
@@ -459,8 +463,8 @@ let pp_ind co kn ind =
 	  begin 
 	    init := (fnl () ++ str "and "); 
 	    s ++
-	    (if co then pp_coind ip p.ip_vars ++ fnl () ++ str "and " else mt ())
-	    ++ pp_one_ind (if co then "__" else "") ip p.ip_vars p.ip_types ++
+	    (if co then pp_coind ip p.ip_vars else mt ())
+	    ++ pp_one_ind prefix ip ip_equiv p.ip_vars p.ip_types ++
 	    pp (i+1)
 	  end
       end
@@ -474,19 +478,21 @@ let pp_mind kn i =
   match i.ind_info with 
     | Singleton -> pp_singleton kn i.ind_packets.(0)
     | Coinductive -> pp_ind true kn i
-    | Record projs -> pp_record kn projs i.ind_packets.(0)
+    | Record projs -> 
+	let ip_equiv = option_map (fun kn -> (kn,0)) i.ind_equiv in 
+	pp_record kn projs ip_equiv i.ind_packets.(0)
     | Standard -> pp_ind false kn i
 
 let pp_decl mpl = 
   local_mpl := mpl; 
   function
-    | Dind (kn,i) as d -> pp_mind kn i
+    | Dind (kn,i) -> pp_mind kn i
     | Dtype (r, l, t) ->
 	if is_inline_custom r then failwith "empty phrase"
 	else 
-	  let pp_r = pp_global r in 
+          let pp_r = pp_global r in 
 	  let l = rename_tvars keywords l in 
-	  let ids, def = try 
+          let ids, def = try 
 	    let ids,s = find_type_custom r in 
 	    pp_string_parameters ids, str "=" ++ spc () ++ str s 
 	  with not_found -> 
@@ -580,7 +586,7 @@ let rec pp_structure_elem mpl = function
   | (l,SEmodule m) ->
       hov 1 
 	(str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ 
-	 (* if you want signatures everywhere: *)
+	 (*i if you want signatures everywhere: i*)
 	 (*i str " :" ++ fnl () ++ i*)
 	 (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*)
 	 str " = " ++
diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli
index 5015a50d..8c521ccd 100644
--- a/contrib/extraction/ocaml.mli
+++ b/contrib/extraction/ocaml.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ocaml.mli,v 1.26.6.3 2005/12/01 17:01:22 letouzey Exp $ i*)
+(*i $Id: ocaml.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
 
 (*s Some utility functions to be reused in module [Haskell]. *)
 
diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml
index 4a881da2..7004a202 100644
--- a/contrib/extraction/scheme.ml
+++ b/contrib/extraction/scheme.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: scheme.ml,v 1.9.2.5 2005/12/16 03:07:39 letouzey Exp $ i*)
+(*i $Id: scheme.ml 7651 2005-12-16 03:19:20Z letouzey $ i*)
 
 (*s Production of Scheme syntax. *)
 
diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli
index 2a828fb9..ef4a3a63 100644
--- a/contrib/extraction/scheme.mli
+++ b/contrib/extraction/scheme.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: scheme.mli,v 1.6.6.2 2005/12/01 17:01:22 letouzey Exp $ i*)
+(*i $Id: scheme.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
 
 (*s Some utility functions to be reused in module [Haskell]. *)
 
diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml
index 9d73d13f..b1a3cb31 100644
--- a/contrib/extraction/table.ml
+++ b/contrib/extraction/table.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.ml,v 1.35.2.2 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: table.ml 9310 2006-10-28 19:35:09Z herbelin $ i*)
 
 open Names
 open Term
@@ -22,10 +22,23 @@ open Miniml
 
 (*S Utilities concerning [module_path] and [kernel_names] *)
 
-let kn_of_r r = match r with 
-    | ConstRef kn -> kn
-    | IndRef (kn,_) -> kn
-    | ConstructRef ((kn,_),_) -> kn
+let occur_kn_in_ref kn =
+ function
+  | IndRef (kn',_)
+  | ConstructRef ((kn',_),_) -> kn = kn'
+  | ConstRef _ -> false
+  | VarRef _ -> assert false
+
+let modpath_of_r r = match r with 
+    | ConstRef kn -> con_modpath kn
+    | IndRef (kn,_)
+    | ConstructRef ((kn,_),_) -> modpath kn
+    | VarRef _ -> assert false
+
+let label_of_r r = match r with 
+    | ConstRef kn -> con_label kn
+    | IndRef (kn,_)
+    | ConstructRef ((kn,_),_) -> label kn
     | VarRef _ -> assert false
 
 let current_toplevel () = fst (Lib.current_prefix ())
@@ -45,21 +58,22 @@ let at_toplevel mp =
   is_modfile mp || is_toplevel mp
 
 let visible_kn kn = at_toplevel (base_mp (modpath kn))
+let visible_con kn = at_toplevel (base_mp (con_modpath kn))
 
 
 (*S The main tables: constants, inductives, records, ... *)
 
 (*s Constants tables. *) 
 
-let terms = ref (KNmap.empty : ml_decl KNmap.t)
-let init_terms () = terms := KNmap.empty
-let add_term kn d = terms := KNmap.add kn d !terms
-let lookup_term kn = KNmap.find kn !terms
+let terms = ref (Cmap.empty : ml_decl Cmap.t)
+let init_terms () = terms := Cmap.empty
+let add_term kn d = terms := Cmap.add kn d !terms
+let lookup_term kn = Cmap.find kn !terms
 
-let types = ref (KNmap.empty : ml_schema KNmap.t)
-let init_types () = types := KNmap.empty
-let add_type kn s = types := KNmap.add kn s !types
-let lookup_type kn = KNmap.find kn !types 
+let types = ref (Cmap.empty : ml_schema Cmap.t)
+let init_types () = types := Cmap.empty
+let add_type kn s = types := Cmap.add kn s !types
+let lookup_type kn = Cmap.find kn !types 
 
 (*s Inductives table. *)
 
@@ -70,22 +84,22 @@ let lookup_ind kn = KNmap.find kn !inductives
 
 (*s Recursors table. *)
 
-let recursors = ref KNset.empty
-let init_recursors () = recursors := KNset.empty
+let recursors = ref Cset.empty
+let init_recursors () = recursors := Cset.empty
 
 let add_recursors env kn = 
-  let make_kn id = make_kn (modpath kn) empty_dirpath (label_of_id id) in 
+  let make_kn id = make_con (modpath kn) empty_dirpath (label_of_id id) in 
   let mib = Environ.lookup_mind kn env in 
   Array.iter 
     (fun mip -> 
        let id = mip.mind_typename in 
        let kn_rec = make_kn (Nameops.add_suffix id "_rec")
        and kn_rect = make_kn (Nameops.add_suffix id "_rect") in 
-       recursors := KNset.add kn_rec (KNset.add kn_rect !recursors))
+       recursors := Cset.add kn_rec (Cset.add kn_rect !recursors))
     mib.mind_packets
 
 let is_recursor = function 
-  | ConstRef kn -> KNset.mem kn !recursors
+  | ConstRef kn -> Cset.mem kn !recursors
   | _ -> false
 
 (*s Record tables. *)
@@ -109,7 +123,7 @@ let reset_tables () =
    done before. *)
 
 let id_of_global = function 
-  | ConstRef kn -> let _,_,l = repr_kn kn in id_of_label l
+  | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l
   | IndRef (kn,i) -> (lookup_ind kn).ind_packets.(i).ip_typename
   | ConstructRef ((kn,i),j) -> (lookup_ind kn).ind_packets.(i).ip_consnames.(j-1)
   | _ -> assert false
@@ -126,16 +140,14 @@ let error_axiom_scheme r i =
        str " type variable(s).") 
 
 let warning_info_ax r =
-  Options.if_verbose msg_warning
-    (str "You must realize axiom " ++
-     pr_global r ++ str " in the extracted code.")
+  msg_warning (str "You must realize axiom " ++
+		  pr_global r ++ str " in the extracted code.")
 
 let warning_log_ax r = 
-  Options.if_verbose msg_warning
-    (str "This extraction depends on logical axiom" ++ spc () ++ 
-     pr_global r ++ str "." ++ spc() ++ 
-     str "Having false logical axiom in the environment when extracting" ++ 
-     spc () ++ str "may lead to incorrect or non-terminating ML terms.")
+  msg_warning (str "This extraction depends on logical axiom" ++ spc () ++ 
+		  pr_global r ++ str "." ++ spc() ++ 
+		  str "Having false logical axiom in the environment when extracting" ++ 
+		  spc () ++ str "may lead to incorrect or non-terminating ML terms.")
 
 let check_inside_module () = 
   try 
@@ -207,6 +219,18 @@ let _ = declare_bool_option
 	   optread = auto_inline; 
 	   optwrite = (:=) auto_inline_ref}
 
+(*s Extraction TypeExpand *)
+
+let type_expand_ref = ref true
+
+let type_expand () = !type_expand_ref
+
+let _ = declare_bool_option 
+	  {optsync = true;
+	   optname = "Extraction TypeExpand";
+	   optkey = SecondaryTable ("Extraction", "TypeExpand");
+	   optread = type_expand; 
+	   optwrite = (:=) type_expand_ref}
 
 (*s Extraction Optimize *)
 
@@ -311,14 +335,22 @@ let add_inline_entries b l =
 
 (* Registration of operations for rollback. *)
 
-let (inline_extraction,_) = 
+let (inline_extraction,_) =
   declare_object 
     {(default_object "Extraction Inline") with 
        cache_function = (fun (_,(b,l)) -> add_inline_entries b l);
        load_function = (fun _ (_,(b,l)) -> add_inline_entries b l);
        export_function = (fun x -> Some x); 
        classify_function = (fun (_,o) -> Substitute o); 
-       subst_function = (fun (_,s,(b,l)) -> (b,(List.map (subst_global s) l))) }
+       (*CSC: The following substitution may istantiate a realized parameter.
+         The right solution would be to make the substitution erase the
+         realizer from the table. However, this is not allowed by Coq.
+         In this particular case, though, keeping the realizer is place seems
+         to be harmless since the current code looks for a realizer only
+         when the constant is a parameter. However, if this behaviour changes
+         subtle bugs can happear in the future. *)
+       subst_function =
+        (fun (_,s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))}
 
 let _ = declare_summary "Extraction Inline"
 	  { freeze_function = (fun () -> !inline_table);
@@ -409,7 +441,7 @@ let extract_constant_inline inline r ids s =
   match g with 
     | ConstRef kn -> 
 	let env = Global.env () in 
-	let typ = Environ.constant_type env kn in 
+	let typ = Typeops.type_of_constant env kn in 
 	let typ = Reduction.whd_betadeltaiota env typ in
 	if Reduction.is_arity env typ 
 	  then begin 
diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli
index 6160452a..66662138 100644
--- a/contrib/extraction/table.mli
+++ b/contrib/extraction/table.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: table.mli,v 1.25.2.2 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: table.mli 6441 2004-12-09 02:27:09Z letouzey $ i*)
 
 open Names
 open Libnames
@@ -35,7 +35,9 @@ val check_inside_section : unit -> unit
 
 (*s utilities concerning [module_path]. *)
 
-val kn_of_r : global_reference -> kernel_name
+val occur_kn_in_ref : kernel_name -> global_reference -> bool
+val modpath_of_r : global_reference -> module_path
+val label_of_r : global_reference -> label
 
 val current_toplevel : unit -> module_path
 val base_mp : module_path -> module_path
@@ -43,14 +45,15 @@ val is_modfile : module_path -> bool
 val is_toplevel : module_path -> bool
 val at_toplevel : module_path -> bool 
 val visible_kn : kernel_name -> bool
+val visible_con : constant -> bool
 
 (*s Some table-related operations *)
 
-val add_term : kernel_name -> ml_decl -> unit
-val lookup_term : kernel_name -> ml_decl
+val add_term : constant -> ml_decl -> unit
+val lookup_term : constant -> ml_decl
 
-val add_type : kernel_name -> ml_schema -> unit
-val lookup_type : kernel_name -> ml_schema
+val add_type : constant -> ml_schema -> unit
+val lookup_type : constant -> ml_schema
 
 val add_ind : kernel_name -> ml_ind -> unit
 val lookup_ind : kernel_name -> ml_ind
@@ -58,7 +61,7 @@ val lookup_ind : kernel_name -> ml_ind
 val add_recursors : Environ.env -> kernel_name -> unit
 val is_recursor : global_reference -> bool 
 
-val add_projection : int -> kernel_name -> unit
+val add_projection : int -> constant -> unit
 val is_projection : global_reference -> bool 
 val projection_arity : global_reference -> int
 
@@ -68,6 +71,10 @@ val reset_tables : unit -> unit
 
 val auto_inline : unit -> bool
 
+(*s TypeExpand parameter *) 
+
+val type_expand : unit -> bool
+
 (*s Optimize parameter *) 
 
 type opt_flag = 
diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend
index 641b50a7..31d46eeb 100644
--- a/contrib/extraction/test/.depend
+++ b/contrib/extraction/test/.depend
@@ -2,110 +2,318 @@ theories/Arith/arith.cmo: theories/Arith/arith.cmi
 theories/Arith/arith.cmx: theories/Arith/arith.cmi 
 theories/Arith/between.cmo: theories/Arith/between.cmi 
 theories/Arith/between.cmx: theories/Arith/between.cmi 
-theories/Arith/bool_nat.cmo: theories/Arith/compare_dec.cmi \
-    theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
+theories/Arith/bool_nat.cmo: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/Arith/peano_dec.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
     theories/Arith/bool_nat.cmi 
-theories/Arith/bool_nat.cmx: theories/Arith/compare_dec.cmx \
-    theories/Init/datatypes.cmx theories/Arith/peano_dec.cmx \
-    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
+theories/Arith/bool_nat.cmx: theories/Bool/sumbool.cmx \
+    theories/Init/specif.cmx theories/Arith/peano_dec.cmx \
+    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
     theories/Arith/bool_nat.cmi 
-theories/Arith/compare_dec.cmo: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Arith/compare_dec.cmi 
-theories/Arith/compare_dec.cmx: theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/Arith/compare_dec.cmi 
-theories/Arith/compare.cmo: theories/Arith/compare_dec.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/Arith/compare_dec.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi 
+theories/Arith/compare_dec.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmi 
+theories/Arith/compare.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
     theories/Arith/compare.cmi 
-theories/Arith/compare.cmx: theories/Arith/compare_dec.cmx \
-    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/Arith/compare.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
     theories/Arith/compare.cmi 
-theories/Arith/div2.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi \
-    theories/Init/specif.cmi theories/Arith/div2.cmi 
-theories/Arith/div2.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmx \
-    theories/Init/specif.cmx theories/Arith/div2.cmi 
-theories/Arith/eqNat.cmo: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Arith/eqNat.cmi 
-theories/Arith/eqNat.cmx: theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/Arith/eqNat.cmi 
-theories/Arith/euclid.cmo: theories/Arith/compare_dec.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/Arith/div2.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Arith/div2.cmi 
+theories/Arith/div2.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/Arith/div2.cmi 
+theories/Arith/eqNat.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Arith/eqNat.cmi 
+theories/Arith/eqNat.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Arith/eqNat.cmi 
+theories/Arith/euclid.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
     theories/Arith/euclid.cmi 
-theories/Arith/euclid.cmx: theories/Arith/compare_dec.cmx \
-    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/Arith/euclid.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
     theories/Arith/euclid.cmi 
-theories/Arith/even.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/Arith/even.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
     theories/Arith/even.cmi 
-theories/Arith/even.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/Arith/even.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
     theories/Arith/even.cmi 
-theories/Arith/factorial.cmo: theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/Arith/factorial.cmi 
-theories/Arith/factorial.cmx: theories/Init/datatypes.cmx \
-    theories/Init/peano.cmx theories/Arith/factorial.cmi 
+theories/Arith/factorial.cmo: theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Arith/factorial.cmi 
+theories/Arith/factorial.cmx: theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/Arith/factorial.cmi 
 theories/Arith/gt.cmo: theories/Arith/gt.cmi 
 theories/Arith/gt.cmx: theories/Arith/gt.cmi 
 theories/Arith/le.cmo: theories/Arith/le.cmi 
 theories/Arith/le.cmx: theories/Arith/le.cmi 
 theories/Arith/lt.cmo: theories/Arith/lt.cmi 
 theories/Arith/lt.cmx: theories/Arith/lt.cmi 
-theories/Arith/max.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/Arith/max.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
     theories/Arith/max.cmi 
-theories/Arith/max.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/Arith/max.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
     theories/Arith/max.cmi 
-theories/Arith/min.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/Arith/min.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
     theories/Arith/min.cmi 
-theories/Arith/min.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/Arith/min.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
     theories/Arith/min.cmi 
 theories/Arith/minus.cmo: theories/Arith/minus.cmi 
 theories/Arith/minus.cmx: theories/Arith/minus.cmi 
-theories/Arith/mult.cmo: theories/Init/datatypes.cmi theories/Arith/plus.cmi \
+theories/Arith/mult.cmo: theories/Arith/plus.cmi theories/Init/datatypes.cmi \
     theories/Arith/mult.cmi 
-theories/Arith/mult.cmx: theories/Init/datatypes.cmx theories/Arith/plus.cmx \
+theories/Arith/mult.cmx: theories/Arith/plus.cmx theories/Init/datatypes.cmx \
     theories/Arith/mult.cmi 
-theories/Arith/peano_dec.cmo: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Arith/peano_dec.cmi 
-theories/Arith/peano_dec.cmx: theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/Arith/peano_dec.cmi 
-theories/Arith/plus.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/Arith/peano_dec.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi 
+theories/Arith/peano_dec.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Arith/peano_dec.cmi 
+theories/Arith/plus.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
     theories/Arith/plus.cmi 
-theories/Arith/plus.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/Arith/plus.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
     theories/Arith/plus.cmi 
 theories/Arith/wf_nat.cmo: theories/Init/datatypes.cmi \
     theories/Arith/wf_nat.cmi 
 theories/Arith/wf_nat.cmx: theories/Init/datatypes.cmx \
     theories/Arith/wf_nat.cmi 
-theories/Bool/boolEq.cmo: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Bool/boolEq.cmi 
-theories/Bool/boolEq.cmx: theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/Bool/boolEq.cmi 
-theories/Bool/bool.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/Bool/boolEq.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Bool/boolEq.cmi 
+theories/Bool/boolEq.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Bool/boolEq.cmi 
+theories/Bool/bool.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
     theories/Bool/bool.cmi 
-theories/Bool/bool.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/Bool/bool.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
     theories/Bool/bool.cmi 
-theories/Bool/bvector.cmo: theories/Bool/bool.cmi theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/Bool/bvector.cmi 
-theories/Bool/bvector.cmx: theories/Bool/bool.cmx theories/Init/datatypes.cmx \
-    theories/Init/peano.cmx theories/Bool/bvector.cmi 
+theories/Bool/bvector.cmo: theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bool.cmi \
+    theories/Bool/bvector.cmi 
+theories/Bool/bvector.cmx: theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/Bool/bool.cmx \
+    theories/Bool/bvector.cmi 
 theories/Bool/decBool.cmo: theories/Init/specif.cmi theories/Bool/decBool.cmi 
 theories/Bool/decBool.cmx: theories/Init/specif.cmx theories/Bool/decBool.cmi 
-theories/Bool/ifProp.cmo: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Bool/ifProp.cmi 
-theories/Bool/ifProp.cmx: theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/Bool/ifProp.cmi 
-theories/Bool/sumbool.cmo: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
-theories/Bool/sumbool.cmx: theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/Bool/sumbool.cmi 
+theories/Bool/ifProp.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Bool/ifProp.cmi 
+theories/Bool/ifProp.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Bool/ifProp.cmi 
+theories/Bool/sumbool.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Bool/sumbool.cmi 
+theories/Bool/sumbool.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Bool/sumbool.cmi 
 theories/Bool/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi 
 theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.cmi 
+theories/FSets/decidableTypeEx.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \
+    theories/Init/datatypes.cmi theories/FSets/decidableTypeEx.cmi 
+theories/FSets/decidableTypeEx.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedTypeEx.cmx theories/FSets/orderedType.cmx \
+    theories/Init/datatypes.cmx theories/FSets/decidableTypeEx.cmi 
+theories/FSets/decidableType.cmo: theories/Init/specif.cmi \
+    theories/FSets/decidableType.cmi 
+theories/FSets/decidableType.cmx: theories/Init/specif.cmx \
+    theories/FSets/decidableType.cmi 
+theories/FSets/fMapAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/FSets/int.cmi theories/FSets/fMapList.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/FSets/fMapAVL.cmi 
+theories/FSets/fMapAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
+    theories/FSets/int.cmx theories/FSets/fMapList.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/FSets/fMapAVL.cmi 
+theories/FSets/fMapFacts.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/FSets/fMapInterface.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fMapFacts.cmi 
+theories/FSets/fMapFacts.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/FSets/fMapInterface.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fMapFacts.cmi 
+theories/FSets/fMapInterface.cmo: theories/FSets/orderedType.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi \
+    theories/FSets/fMapInterface.cmi 
+theories/FSets/fMapInterface.cmx: theories/FSets/orderedType.cmx \
+    theories/Lists/list.cmx theories/Init/datatypes.cmx \
+    theories/FSets/fMapInterface.cmi 
+theories/FSets/fMapIntMap.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \
+    theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \
+    theories/IntMap/map.cmi theories/Lists/list.cmi \
+    theories/FSets/fMapList.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binNat.cmi theories/FSets/fMapIntMap.cmi 
+theories/FSets/fMapIntMap.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/NArith/ndigits.cmx \
+    theories/IntMap/mapiter.cmx theories/IntMap/mapcanon.cmx \
+    theories/IntMap/map.cmx theories/Lists/list.cmx \
+    theories/FSets/fMapList.cmx theories/Init/datatypes.cmx \
+    theories/NArith/binNat.cmx theories/FSets/fMapIntMap.cmi 
+theories/FSets/fMapList.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fMapList.cmi 
+theories/FSets/fMapList.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fMapList.cmi 
+theories/FSets/fMapPositive.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/FSets/fMapPositive.cmi 
+theories/FSets/fMapPositive.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/FSets/fMapPositive.cmi 
+theories/FSets/fMaps.cmo: theories/FSets/fMaps.cmi 
+theories/FSets/fMaps.cmx: theories/FSets/fMaps.cmi 
+theories/FSets/fMapWeakFacts.cmo: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fMapWeakFacts.cmi 
+theories/FSets/fMapWeakFacts.cmx: theories/Init/specif.cmx \
+    theories/Lists/list.cmx theories/FSets/fMapWeakInterface.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fMapWeakFacts.cmi 
+theories/FSets/fMapWeakInterface.cmo: theories/Lists/list.cmi \
+    theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \
+    theories/FSets/fMapWeakInterface.cmi 
+theories/FSets/fMapWeakInterface.cmx: theories/Lists/list.cmx \
+    theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \
+    theories/FSets/fMapWeakInterface.cmi 
+theories/FSets/fMapWeakList.cmo: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/FSets/decidableType.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fMapWeakList.cmi 
+theories/FSets/fMapWeakList.cmx: theories/Init/specif.cmx \
+    theories/Lists/list.cmx theories/FSets/decidableType.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fMapWeakList.cmi 
+theories/FSets/fMapWeak.cmo: theories/FSets/fMapWeak.cmi 
+theories/FSets/fMapWeak.cmx: theories/FSets/fMapWeak.cmi 
+theories/FSets/fSetAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \
+    theories/Init/peano.cmi theories/FSets/orderedType.cmi \
+    theories/Lists/list.cmi theories/FSets/int.cmi \
+    theories/FSets/fSetList.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
+    theories/FSets/fSetAVL.cmi 
+theories/FSets/fSetAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \
+    theories/Init/peano.cmx theories/FSets/orderedType.cmx \
+    theories/Lists/list.cmx theories/FSets/int.cmx \
+    theories/FSets/fSetList.cmx theories/Init/datatypes.cmx \
+    theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
+    theories/FSets/fSetAVL.cmi 
+theories/FSets/fSetBridge.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
+    theories/FSets/fSetBridge.cmi 
+theories/FSets/fSetBridge.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
+    theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
+    theories/FSets/fSetBridge.cmi 
+theories/FSets/fSetEqProperties.cmo: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/Init/peano.cmi \
+    theories/FSets/orderedType.cmi theories/FSets/fSetProperties.cmi \
+    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
+    theories/Bool/bool.cmi theories/FSets/fSetEqProperties.cmi 
+theories/FSets/fSetEqProperties.cmx: theories/Init/specif.cmx \
+    theories/Setoids/setoid.cmx theories/Init/peano.cmx \
+    theories/FSets/orderedType.cmx theories/FSets/fSetProperties.cmx \
+    theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
+    theories/Bool/bool.cmx theories/FSets/fSetEqProperties.cmi 
+theories/FSets/fSetFacts.cmo: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \
+    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
+    theories/FSets/fSetFacts.cmi 
+theories/FSets/fSetFacts.cmx: theories/Init/specif.cmx \
+    theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \
+    theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
+    theories/FSets/fSetFacts.cmi 
+theories/FSets/fSetInterface.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fSetInterface.cmi 
+theories/FSets/fSetInterface.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fSetInterface.cmi 
+theories/FSets/fSetList.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fSetList.cmi 
+theories/FSets/fSetList.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fSetList.cmi 
+theories/FSets/fSetProperties.cmo: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \
+    theories/Lists/list.cmi theories/FSets/fSetInterface.cmi \
+    theories/FSets/fSetFacts.cmi theories/Init/datatypes.cmi \
+    theories/FSets/fSetProperties.cmi 
+theories/FSets/fSetProperties.cmx: theories/Init/specif.cmx \
+    theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \
+    theories/Lists/list.cmx theories/FSets/fSetInterface.cmx \
+    theories/FSets/fSetFacts.cmx theories/Init/datatypes.cmx \
+    theories/FSets/fSetProperties.cmi 
+theories/FSets/fSets.cmo: theories/FSets/fSets.cmi 
+theories/FSets/fSets.cmx: theories/FSets/fSets.cmi 
+theories/FSets/fSetToFiniteSet.cmo: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/FSets/fSetProperties.cmi theories/Init/datatypes.cmi \
+    theories/FSets/fSetToFiniteSet.cmi 
+theories/FSets/fSetToFiniteSet.cmx: theories/Init/specif.cmx \
+    theories/Setoids/setoid.cmx theories/FSets/orderedTypeEx.cmx \
+    theories/FSets/orderedType.cmx theories/Lists/list.cmx \
+    theories/FSets/fSetProperties.cmx theories/Init/datatypes.cmx \
+    theories/FSets/fSetToFiniteSet.cmi 
+theories/FSets/fSetWeakFacts.cmo: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fSetWeakFacts.cmi 
+theories/FSets/fSetWeakFacts.cmx: theories/Init/specif.cmx \
+    theories/Setoids/setoid.cmx theories/FSets/fSetWeakInterface.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fSetWeakFacts.cmi 
+theories/FSets/fSetWeakInterface.cmo: theories/Lists/list.cmi \
+    theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \
+    theories/FSets/fSetWeakInterface.cmi 
+theories/FSets/fSetWeakInterface.cmx: theories/Lists/list.cmx \
+    theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \
+    theories/FSets/fSetWeakInterface.cmi 
+theories/FSets/fSetWeakList.cmo: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/FSets/decidableType.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fSetWeakList.cmi 
+theories/FSets/fSetWeakList.cmx: theories/Init/specif.cmx \
+    theories/Lists/list.cmx theories/FSets/decidableType.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fSetWeakList.cmi 
+theories/FSets/fSetWeak.cmo: theories/FSets/fSetWeak.cmi 
+theories/FSets/fSetWeak.cmx: theories/FSets/fSetWeak.cmi 
+theories/FSets/fSetWeakProperties.cmo: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/Lists/list.cmi \
+    theories/FSets/fSetWeakInterface.cmi theories/FSets/fSetWeakFacts.cmi \
+    theories/Init/datatypes.cmi theories/FSets/fSetWeakProperties.cmi 
+theories/FSets/fSetWeakProperties.cmx: theories/Init/specif.cmx \
+    theories/Setoids/setoid.cmx theories/Lists/list.cmx \
+    theories/FSets/fSetWeakInterface.cmx theories/FSets/fSetWeakFacts.cmx \
+    theories/Init/datatypes.cmx theories/FSets/fSetWeakProperties.cmi 
+theories/FSets/int.cmo: theories/ZArith/zmax.cmi \
+    theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
+    theories/FSets/int.cmi 
+theories/FSets/int.cmx: theories/ZArith/zmax.cmx \
+    theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \
+    theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
+    theories/FSets/int.cmi 
+theories/FSets/orderedTypeAlt.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
+    theories/FSets/orderedTypeAlt.cmi 
+theories/FSets/orderedTypeAlt.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \
+    theories/FSets/orderedTypeAlt.cmi 
+theories/FSets/orderedTypeEx.cmo: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
+    theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi theories/ZArith/binInt.cmi \
+    theories/FSets/orderedTypeEx.cmi 
+theories/FSets/orderedTypeEx.cmx: theories/Init/specif.cmx \
+    theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \
+    theories/Arith/compare_dec.cmx theories/NArith/binPos.cmx \
+    theories/NArith/binNat.cmx theories/ZArith/binInt.cmx \
+    theories/FSets/orderedTypeEx.cmi 
+theories/FSets/orderedType.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/FSets/orderedType.cmi 
+theories/FSets/orderedType.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/FSets/orderedType.cmi 
 theories/Init/datatypes.cmo: theories/Init/datatypes.cmi 
 theories/Init/datatypes.cmx: theories/Init/datatypes.cmi 
 theories/Init/logic.cmo: theories/Init/logic.cmi 
 theories/Init/logic.cmx: theories/Init/logic.cmi 
-theories/Init/logic_Type.cmo: theories/Init/datatypes.cmi \
-    theories/Init/logic_Type.cmi 
-theories/Init/logic_Type.cmx: theories/Init/datatypes.cmx \
-    theories/Init/logic_Type.cmi 
+theories/Init/logic_Type.cmo: theories/Init/logic_Type.cmi 
+theories/Init/logic_Type.cmx: theories/Init/logic_Type.cmi 
 theories/Init/notations.cmo: theories/Init/notations.cmi 
 theories/Init/notations.cmx: theories/Init/notations.cmi 
 theories/Init/peano.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi 
@@ -116,152 +324,146 @@ theories/Init/specif.cmo: theories/Init/datatypes.cmi \
     theories/Init/specif.cmi 
 theories/Init/specif.cmx: theories/Init/datatypes.cmx \
     theories/Init/specif.cmi 
+theories/Init/tactics.cmo: theories/Init/tactics.cmi 
+theories/Init/tactics.cmx: theories/Init/tactics.cmi 
 theories/Init/wf.cmo: theories/Init/wf.cmi 
 theories/Init/wf.cmx: theories/Init/wf.cmi 
-theories/IntMap/adalloc.cmo: theories/IntMap/addec.cmi \
-    theories/IntMap/addr.cmi theories/NArith/binPos.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/map.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
-    theories/IntMap/adalloc.cmi 
-theories/IntMap/adalloc.cmx: theories/IntMap/addec.cmx \
-    theories/IntMap/addr.cmx theories/NArith/binPos.cmx \
-    theories/Init/datatypes.cmx theories/IntMap/map.cmx \
-    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
-    theories/IntMap/adalloc.cmi 
-theories/IntMap/addec.cmo: theories/IntMap/addr.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
-    theories/IntMap/addec.cmi 
-theories/IntMap/addec.cmx: theories/IntMap/addr.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
-    theories/IntMap/addec.cmi 
-theories/IntMap/addr.cmo: theories/NArith/binPos.cmi theories/Bool/bool.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi \
-    theories/IntMap/addr.cmi 
-theories/IntMap/addr.cmx: theories/NArith/binPos.cmx theories/Bool/bool.cmx \
-    theories/Init/datatypes.cmx theories/Init/specif.cmx \
-    theories/IntMap/addr.cmi 
-theories/IntMap/adist.cmo: theories/IntMap/addr.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/IntMap/adist.cmi 
-theories/IntMap/adist.cmx: theories/IntMap/addr.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/IntMap/adist.cmi 
+theories/IntMap/adalloc.cmo: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi theories/IntMap/adalloc.cmi 
+theories/IntMap/adalloc.cmx: theories/Bool/sumbool.cmx \
+    theories/Init/specif.cmx theories/NArith/ndec.cmx theories/IntMap/map.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/NArith/binNat.cmx theories/IntMap/adalloc.cmi 
 theories/IntMap/allmaps.cmo: theories/IntMap/allmaps.cmi 
 theories/IntMap/allmaps.cmx: theories/IntMap/allmaps.cmi 
-theories/IntMap/fset.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/map.cmi \
-    theories/Init/specif.cmi theories/IntMap/fset.cmi 
-theories/IntMap/fset.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \
-    theories/Init/datatypes.cmx theories/IntMap/map.cmx \
-    theories/Init/specif.cmx theories/IntMap/fset.cmi 
-theories/IntMap/lsort.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
-    theories/NArith/binPos.cmi theories/Bool/bool.cmi \
-    theories/Init/datatypes.cmi theories/Lists/list.cmi \
-    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
-    theories/IntMap/lsort.cmi 
-theories/IntMap/lsort.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \
-    theories/NArith/binPos.cmx theories/Bool/bool.cmx \
-    theories/Init/datatypes.cmx theories/Lists/list.cmx \
-    theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \
-    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
-    theories/IntMap/lsort.cmi 
+theories/IntMap/fset.cmo: theories/Init/specif.cmi \
+    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
+    theories/IntMap/map.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binNat.cmi theories/IntMap/fset.cmi 
+theories/IntMap/fset.cmx: theories/Init/specif.cmx \
+    theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
+    theories/IntMap/map.cmx theories/Init/datatypes.cmx \
+    theories/NArith/binNat.cmx theories/IntMap/fset.cmi 
+theories/IntMap/lsort.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
+    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
+    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binNat.cmi theories/IntMap/lsort.cmi 
+theories/IntMap/lsort.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \
+    theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
+    theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
+    theories/Lists/list.cmx theories/Init/datatypes.cmx \
+    theories/NArith/binNat.cmx theories/IntMap/lsort.cmi 
 theories/IntMap/mapaxioms.cmo: theories/IntMap/mapaxioms.cmi 
 theories/IntMap/mapaxioms.cmx: theories/IntMap/mapaxioms.cmi 
-theories/IntMap/mapcanon.cmo: theories/IntMap/map.cmi \
-    theories/Init/specif.cmi theories/IntMap/mapcanon.cmi 
-theories/IntMap/mapcanon.cmx: theories/IntMap/map.cmx \
-    theories/Init/specif.cmx theories/IntMap/mapcanon.cmi 
-theories/IntMap/mapcard.cmo: theories/IntMap/addec.cmi \
-    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
-    theories/IntMap/map.cmi theories/Init/peano.cmi \
-    theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi \
-    theories/IntMap/mapcard.cmi 
-theories/IntMap/mapcard.cmx: theories/IntMap/addec.cmx \
-    theories/IntMap/addr.cmx theories/Init/datatypes.cmx \
-    theories/IntMap/map.cmx theories/Init/peano.cmx \
-    theories/Arith/peano_dec.cmx theories/Arith/plus.cmx \
-    theories/Init/specif.cmx theories/Bool/sumbool.cmx \
-    theories/IntMap/mapcard.cmi 
+theories/IntMap/mapcanon.cmo: theories/Init/specif.cmi \
+    theories/IntMap/map.cmi theories/IntMap/mapcanon.cmi 
+theories/IntMap/mapcanon.cmx: theories/Init/specif.cmx \
+    theories/IntMap/map.cmx theories/IntMap/mapcanon.cmi 
+theories/IntMap/mapcard.cmo: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/Arith/plus.cmi \
+    theories/Arith/peano_dec.cmi theories/Init/peano.cmi \
+    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
+    theories/IntMap/map.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binNat.cmi theories/IntMap/mapcard.cmi 
+theories/IntMap/mapcard.cmx: theories/Bool/sumbool.cmx \
+    theories/Init/specif.cmx theories/Arith/plus.cmx \
+    theories/Arith/peano_dec.cmx theories/Init/peano.cmx \
+    theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
+    theories/IntMap/map.cmx theories/Init/datatypes.cmx \
+    theories/NArith/binNat.cmx theories/IntMap/mapcard.cmi 
 theories/IntMap/mapc.cmo: theories/IntMap/mapc.cmi 
 theories/IntMap/mapc.cmx: theories/IntMap/mapc.cmi 
-theories/IntMap/mapfold.cmo: theories/IntMap/addr.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/fset.cmi \
-    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
-    theories/Init/specif.cmi theories/IntMap/mapfold.cmi 
-theories/IntMap/mapfold.cmx: theories/IntMap/addr.cmx \
-    theories/Init/datatypes.cmx theories/IntMap/fset.cmx \
-    theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \
-    theories/Init/specif.cmx theories/IntMap/mapfold.cmi 
-theories/IntMap/mapiter.cmo: theories/IntMap/addec.cmi \
-    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi theories/IntMap/mapiter.cmi 
-theories/IntMap/mapiter.cmx: theories/IntMap/addec.cmx \
-    theories/IntMap/addr.cmx theories/Init/datatypes.cmx \
-    theories/Lists/list.cmx theories/IntMap/map.cmx theories/Init/specif.cmx \
-    theories/Bool/sumbool.cmx theories/IntMap/mapiter.cmi 
-theories/IntMap/maplists.cmo: theories/IntMap/addec.cmi \
-    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
-    theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \
-    theories/IntMap/mapiter.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi theories/IntMap/maplists.cmi 
-theories/IntMap/maplists.cmx: theories/IntMap/addec.cmx \
-    theories/IntMap/addr.cmx theories/Init/datatypes.cmx \
-    theories/IntMap/fset.cmx theories/Lists/list.cmx theories/IntMap/map.cmx \
-    theories/IntMap/mapiter.cmx theories/Init/specif.cmx \
-    theories/Bool/sumbool.cmx theories/IntMap/maplists.cmi 
-theories/IntMap/map.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/Init/specif.cmi theories/IntMap/map.cmi 
-theories/IntMap/map.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/Init/peano.cmx theories/Init/specif.cmx theories/IntMap/map.cmi 
-theories/IntMap/mapsubset.cmo: theories/Bool/bool.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/fset.cmi \
-    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
+theories/IntMap/mapfold.cmo: theories/Init/specif.cmi \
+    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
+    theories/IntMap/fset.cmi theories/Init/datatypes.cmi \
+    theories/IntMap/mapfold.cmi 
+theories/IntMap/mapfold.cmx: theories/Init/specif.cmx \
+    theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
+    theories/IntMap/fset.cmx theories/Init/datatypes.cmx \
+    theories/IntMap/mapfold.cmi 
+theories/IntMap/mapiter.cmo: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/NArith/ndigits.cmi \
+    theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binNat.cmi \
+    theories/IntMap/mapiter.cmi 
+theories/IntMap/mapiter.cmx: theories/Bool/sumbool.cmx \
+    theories/Init/specif.cmx theories/NArith/ndigits.cmx \
+    theories/NArith/ndec.cmx theories/IntMap/map.cmx theories/Lists/list.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binNat.cmx \
+    theories/IntMap/mapiter.cmi 
+theories/IntMap/maplists.cmo: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/NArith/ndec.cmi \
+    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
+    theories/Lists/list.cmi theories/IntMap/fset.cmi \
+    theories/Init/datatypes.cmi theories/IntMap/maplists.cmi 
+theories/IntMap/maplists.cmx: theories/Bool/sumbool.cmx \
+    theories/Init/specif.cmx theories/NArith/ndec.cmx \
+    theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
+    theories/Lists/list.cmx theories/IntMap/fset.cmx \
+    theories/Init/datatypes.cmx theories/IntMap/maplists.cmi 
+theories/IntMap/map.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi theories/IntMap/map.cmi 
+theories/IntMap/map.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
+    theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/NArith/binNat.cmx theories/IntMap/map.cmi 
+theories/IntMap/mapsubset.cmo: theories/IntMap/mapiter.cmi \
+    theories/IntMap/map.cmi theories/IntMap/fset.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bool.cmi \
     theories/IntMap/mapsubset.cmi 
-theories/IntMap/mapsubset.cmx: theories/Bool/bool.cmx \
-    theories/Init/datatypes.cmx theories/IntMap/fset.cmx \
-    theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \
+theories/IntMap/mapsubset.cmx: theories/IntMap/mapiter.cmx \
+    theories/IntMap/map.cmx theories/IntMap/fset.cmx \
+    theories/Init/datatypes.cmx theories/Bool/bool.cmx \
     theories/IntMap/mapsubset.cmi 
-theories/Lists/list.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/Lists/list.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
     theories/Lists/list.cmi 
-theories/Lists/list.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/Lists/list.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
     theories/Lists/list.cmi 
-theories/Lists/listSet.cmo: theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Init/specif.cmi \
-    theories/Lists/listSet.cmi 
-theories/Lists/listSet.cmx: theories/Init/datatypes.cmx \
-    theories/Lists/list.cmx theories/Init/specif.cmx \
-    theories/Lists/listSet.cmi 
+theories/Lists/listSet.cmo: theories/Init/specif.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/Lists/listSet.cmi 
+theories/Lists/listSet.cmx: theories/Init/specif.cmx theories/Lists/list.cmx \
+    theories/Init/datatypes.cmx theories/Lists/listSet.cmi 
 theories/Lists/monoList.cmo: theories/Init/datatypes.cmi \
     theories/Lists/monoList.cmi 
 theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \
     theories/Lists/monoList.cmi 
+theories/Lists/setoidList.cmo: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi \
+    theories/Lists/setoidList.cmi 
+theories/Lists/setoidList.cmx: theories/Init/specif.cmx \
+    theories/Lists/list.cmx theories/Init/datatypes.cmx \
+    theories/Lists/setoidList.cmi 
 theories/Lists/streams.cmo: theories/Init/datatypes.cmi \
     theories/Lists/streams.cmi 
 theories/Lists/streams.cmx: theories/Init/datatypes.cmx \
     theories/Lists/streams.cmi 
-theories/Lists/theoryList.cmo: theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Init/specif.cmi \
+theories/Lists/theoryList.cmo: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi \
     theories/Lists/theoryList.cmi 
-theories/Lists/theoryList.cmx: theories/Init/datatypes.cmx \
-    theories/Lists/list.cmx theories/Init/specif.cmx \
+theories/Lists/theoryList.cmx: theories/Init/specif.cmx \
+    theories/Lists/list.cmx theories/Init/datatypes.cmx \
     theories/Lists/theoryList.cmi 
 theories/Logic/berardi.cmo: theories/Logic/berardi.cmi 
 theories/Logic/berardi.cmx: theories/Logic/berardi.cmi 
-theories/Logic/choiceFacts.cmo: theories/Logic/choiceFacts.cmi 
-theories/Logic/choiceFacts.cmx: theories/Logic/choiceFacts.cmi 
+theories/Logic/choiceFacts.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Logic/choiceFacts.cmi 
+theories/Logic/choiceFacts.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Logic/choiceFacts.cmi 
 theories/Logic/classicalChoice.cmo: theories/Logic/classicalChoice.cmi 
 theories/Logic/classicalChoice.cmx: theories/Logic/classicalChoice.cmi 
-theories/Logic/classicalDescription.cmo: \
-    theories/Logic/classicalDescription.cmi 
-theories/Logic/classicalDescription.cmx: \
-    theories/Logic/classicalDescription.cmi 
+theories/Logic/classicalDescription.cmo: theories/Init/specif.cmi \
+    theories/Logic/choiceFacts.cmi theories/Logic/classicalDescription.cmi 
+theories/Logic/classicalDescription.cmx: theories/Init/specif.cmx \
+    theories/Logic/choiceFacts.cmx theories/Logic/classicalDescription.cmi 
+theories/Logic/classicalEpsilon.cmo: theories/Init/specif.cmi \
+    theories/Logic/choiceFacts.cmi theories/Logic/classicalEpsilon.cmi 
+theories/Logic/classicalEpsilon.cmx: theories/Init/specif.cmx \
+    theories/Logic/choiceFacts.cmx theories/Logic/classicalEpsilon.cmi 
 theories/Logic/classicalFacts.cmo: theories/Logic/classicalFacts.cmi 
 theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi 
 theories/Logic/classical.cmo: theories/Logic/classical.cmi 
@@ -272,38 +474,118 @@ theories/Logic/classical_Pred_Type.cmo: \
     theories/Logic/classical_Pred_Type.cmi 
 theories/Logic/classical_Pred_Type.cmx: \
     theories/Logic/classical_Pred_Type.cmi 
-theories/Logic/classical_Prop.cmo: theories/Logic/classical_Prop.cmi 
-theories/Logic/classical_Prop.cmx: theories/Logic/classical_Prop.cmi 
+theories/Logic/classical_Prop.cmo: theories/Logic/eqdepFacts.cmi \
+    theories/Logic/classical_Prop.cmi 
+theories/Logic/classical_Prop.cmx: theories/Logic/eqdepFacts.cmx \
+    theories/Logic/classical_Prop.cmi 
 theories/Logic/classical_Type.cmo: theories/Logic/classical_Type.cmi 
 theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.cmi 
+theories/Logic/classicalUniqueChoice.cmo: \
+    theories/Logic/classicalUniqueChoice.cmi 
+theories/Logic/classicalUniqueChoice.cmx: \
+    theories/Logic/classicalUniqueChoice.cmi 
 theories/Logic/decidable.cmo: theories/Logic/decidable.cmi 
 theories/Logic/decidable.cmx: theories/Logic/decidable.cmi 
-theories/Logic/diaconescu.cmo: theories/Logic/diaconescu.cmi 
-theories/Logic/diaconescu.cmx: theories/Logic/diaconescu.cmi 
-theories/Logic/eqdep_dec.cmo: theories/Logic/eqdep_dec.cmi 
-theories/Logic/eqdep_dec.cmx: theories/Logic/eqdep_dec.cmi 
-theories/Logic/eqdep.cmo: theories/Logic/eqdep.cmi 
-theories/Logic/eqdep.cmx: theories/Logic/eqdep.cmi 
+theories/Logic/diaconescu.cmo: theories/Init/specif.cmi \
+    theories/Logic/diaconescu.cmi 
+theories/Logic/diaconescu.cmx: theories/Init/specif.cmx \
+    theories/Logic/diaconescu.cmi 
+theories/Logic/eqdep_dec.cmo: theories/Init/specif.cmi \
+    theories/Logic/eqdep_dec.cmi 
+theories/Logic/eqdep_dec.cmx: theories/Init/specif.cmx \
+    theories/Logic/eqdep_dec.cmi 
+theories/Logic/eqdepFacts.cmo: theories/Logic/eqdepFacts.cmi 
+theories/Logic/eqdepFacts.cmx: theories/Logic/eqdepFacts.cmi 
+theories/Logic/eqdep.cmo: theories/Logic/eqdepFacts.cmi \
+    theories/Logic/eqdep.cmi 
+theories/Logic/eqdep.cmx: theories/Logic/eqdepFacts.cmx \
+    theories/Logic/eqdep.cmi 
 theories/Logic/hurkens.cmo: theories/Logic/hurkens.cmi 
 theories/Logic/hurkens.cmx: theories/Logic/hurkens.cmi 
 theories/Logic/jMeq.cmo: theories/Logic/jMeq.cmi 
 theories/Logic/jMeq.cmx: theories/Logic/jMeq.cmi 
-theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevance.cmi 
-theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevance.cmi 
+theories/Logic/proofIrrelevanceFacts.cmo: theories/Logic/eqdepFacts.cmi \
+    theories/Logic/proofIrrelevanceFacts.cmi 
+theories/Logic/proofIrrelevanceFacts.cmx: theories/Logic/eqdepFacts.cmx \
+    theories/Logic/proofIrrelevanceFacts.cmi 
+theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevanceFacts.cmi \
+    theories/Logic/proofIrrelevance.cmi 
+theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevanceFacts.cmx \
+    theories/Logic/proofIrrelevance.cmi 
 theories/Logic/relationalChoice.cmo: theories/Logic/relationalChoice.cmi 
 theories/Logic/relationalChoice.cmx: theories/Logic/relationalChoice.cmi 
-theories/NArith/binNat.cmo: theories/NArith/binPos.cmi \
-    theories/Init/datatypes.cmi theories/NArith/binNat.cmi 
-theories/NArith/binNat.cmx: theories/NArith/binPos.cmx \
-    theories/Init/datatypes.cmx theories/NArith/binNat.cmi 
-theories/NArith/binPos.cmo: theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/NArith/binPos.cmi 
-theories/NArith/binPos.cmx: theories/Init/datatypes.cmx \
-    theories/Init/peano.cmx theories/NArith/binPos.cmi 
+theories/NArith/binNat.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi 
+theories/NArith/binNat.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/NArith/binNat.cmi 
+theories/NArith/binPos.cmo: theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi 
+theories/NArith/binPos.cmx: theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmi 
 theories/NArith/nArith.cmo: theories/NArith/nArith.cmi 
 theories/NArith/nArith.cmx: theories/NArith/nArith.cmi 
+theories/NArith/ndec.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
+    theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
+    theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
+    theories/NArith/ndec.cmi 
+theories/NArith/ndec.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \
+    theories/NArith/nnat.cmx theories/NArith/ndigits.cmx \
+    theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
+    theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
+    theories/NArith/ndec.cmi 
+theories/NArith/ndigits.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
+    theories/Bool/bool.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi theories/NArith/ndigits.cmi 
+theories/NArith/ndigits.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Bool/bvector.cmx \
+    theories/Bool/bool.cmx theories/NArith/binPos.cmx \
+    theories/NArith/binNat.cmx theories/NArith/ndigits.cmi 
+theories/NArith/ndist.cmo: theories/NArith/ndigits.cmi theories/Arith/min.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi theories/NArith/ndist.cmi 
+theories/NArith/ndist.cmx: theories/NArith/ndigits.cmx theories/Arith/min.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/NArith/binNat.cmx theories/NArith/ndist.cmi 
+theories/NArith/nnat.cmo: theories/Init/datatypes.cmi \
+    theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
+    theories/NArith/nnat.cmi 
+theories/NArith/nnat.cmx: theories/Init/datatypes.cmx \
+    theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
+    theories/NArith/nnat.cmi 
 theories/NArith/pnat.cmo: theories/NArith/pnat.cmi 
 theories/NArith/pnat.cmx: theories/NArith/pnat.cmi 
+theories/QArith/qArith_base.cmo: theories/ZArith/zArith_dec.cmi \
+    theories/Init/specif.cmi theories/Setoids/setoid.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/QArith/qArith_base.cmi 
+theories/QArith/qArith_base.cmx: theories/ZArith/zArith_dec.cmx \
+    theories/Init/specif.cmx theories/Setoids/setoid.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/QArith/qArith_base.cmi 
+theories/QArith/qArith.cmo: theories/QArith/qArith.cmi 
+theories/QArith/qArith.cmx: theories/QArith/qArith.cmi 
+theories/QArith/qreals.cmo: theories/QArith/qArith_base.cmi \
+    theories/ZArith/binInt.cmi theories/QArith/qreals.cmi 
+theories/QArith/qreals.cmx: theories/QArith/qArith_base.cmx \
+    theories/ZArith/binInt.cmx theories/QArith/qreals.cmi 
+theories/QArith/qreduction.cmo: theories/ZArith/znumtheory.cmi \
+    theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/QArith/qreduction.cmi 
+theories/QArith/qreduction.cmx: theories/ZArith/znumtheory.cmx \
+    theories/Setoids/setoid.cmx theories/QArith/qArith_base.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/QArith/qreduction.cmi 
+theories/QArith/qring.cmo: theories/Init/specif.cmi \
+    theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi \
+    theories/QArith/qring.cmi 
+theories/QArith/qring.cmx: theories/Init/specif.cmx \
+    theories/QArith/qArith_base.cmx theories/Init/datatypes.cmx \
+    theories/QArith/qring.cmi 
 theories/Relations/newman.cmo: theories/Relations/newman.cmi 
 theories/Relations/newman.cmx: theories/Relations/newman.cmi 
 theories/Relations/operators_Properties.cmo: \
@@ -314,16 +596,18 @@ theories/Relations/relation_Definitions.cmo: \
     theories/Relations/relation_Definitions.cmi 
 theories/Relations/relation_Definitions.cmx: \
     theories/Relations/relation_Definitions.cmi 
-theories/Relations/relation_Operators.cmo: theories/Lists/list.cmi \
-    theories/Init/specif.cmi theories/Relations/relation_Operators.cmi 
-theories/Relations/relation_Operators.cmx: theories/Lists/list.cmx \
-    theories/Init/specif.cmx theories/Relations/relation_Operators.cmi 
+theories/Relations/relation_Operators.cmo: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/Relations/relation_Operators.cmi 
+theories/Relations/relation_Operators.cmx: theories/Init/specif.cmx \
+    theories/Lists/list.cmx theories/Relations/relation_Operators.cmi 
 theories/Relations/relations.cmo: theories/Relations/relations.cmi 
 theories/Relations/relations.cmx: theories/Relations/relations.cmi 
 theories/Relations/rstar.cmo: theories/Relations/rstar.cmi 
 theories/Relations/rstar.cmx: theories/Relations/rstar.cmi 
-theories/Setoids/setoid.cmo: theories/Setoids/setoid.cmi 
-theories/Setoids/setoid.cmx: theories/Setoids/setoid.cmi 
+theories/Setoids/setoid.cmo: theories/Init/datatypes.cmi \
+    theories/Setoids/setoid.cmi 
+theories/Setoids/setoid.cmx: theories/Init/datatypes.cmx \
+    theories/Setoids/setoid.cmi 
 theories/Sets/classical_sets.cmo: theories/Sets/classical_sets.cmi 
 theories/Sets/classical_sets.cmx: theories/Sets/classical_sets.cmi 
 theories/Sets/constructive_sets.cmo: theories/Sets/constructive_sets.cmi 
@@ -340,20 +624,18 @@ theories/Sets/image.cmo: theories/Sets/image.cmi
 theories/Sets/image.cmx: theories/Sets/image.cmi 
 theories/Sets/infinite_sets.cmo: theories/Sets/infinite_sets.cmi 
 theories/Sets/infinite_sets.cmx: theories/Sets/infinite_sets.cmi 
-theories/Sets/integers.cmo: theories/Init/datatypes.cmi \
-    theories/Sets/partial_Order.cmi theories/Sets/integers.cmi 
-theories/Sets/integers.cmx: theories/Init/datatypes.cmx \
-    theories/Sets/partial_Order.cmx theories/Sets/integers.cmi 
-theories/Sets/multiset.cmo: theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/Init/specif.cmi \
-    theories/Sets/multiset.cmi 
-theories/Sets/multiset.cmx: theories/Init/datatypes.cmx \
-    theories/Init/peano.cmx theories/Init/specif.cmx \
-    theories/Sets/multiset.cmi 
-theories/Sets/partial_Order.cmo: theories/Sets/ensembles.cmi \
-    theories/Sets/relations_1.cmi theories/Sets/partial_Order.cmi 
-theories/Sets/partial_Order.cmx: theories/Sets/ensembles.cmx \
-    theories/Sets/relations_1.cmx theories/Sets/partial_Order.cmi 
+theories/Sets/integers.cmo: theories/Sets/partial_Order.cmi \
+    theories/Init/datatypes.cmi theories/Sets/integers.cmi 
+theories/Sets/integers.cmx: theories/Sets/partial_Order.cmx \
+    theories/Init/datatypes.cmx theories/Sets/integers.cmi 
+theories/Sets/multiset.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Sets/multiset.cmi 
+theories/Sets/multiset.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/Sets/multiset.cmi 
+theories/Sets/partial_Order.cmo: theories/Sets/relations_1.cmi \
+    theories/Sets/ensembles.cmi theories/Sets/partial_Order.cmi 
+theories/Sets/partial_Order.cmx: theories/Sets/relations_1.cmx \
+    theories/Sets/ensembles.cmx theories/Sets/partial_Order.cmi 
 theories/Sets/permut.cmo: theories/Sets/permut.cmi 
 theories/Sets/permut.cmx: theories/Sets/permut.cmi 
 theories/Sets/powerset_Classical_facts.cmo: \
@@ -362,10 +644,10 @@ theories/Sets/powerset_Classical_facts.cmx: \
     theories/Sets/powerset_Classical_facts.cmi 
 theories/Sets/powerset_facts.cmo: theories/Sets/powerset_facts.cmi 
 theories/Sets/powerset_facts.cmx: theories/Sets/powerset_facts.cmi 
-theories/Sets/powerset.cmo: theories/Sets/ensembles.cmi \
-    theories/Sets/partial_Order.cmi theories/Sets/powerset.cmi 
-theories/Sets/powerset.cmx: theories/Sets/ensembles.cmx \
-    theories/Sets/partial_Order.cmx theories/Sets/powerset.cmi 
+theories/Sets/powerset.cmo: theories/Sets/partial_Order.cmi \
+    theories/Sets/ensembles.cmi theories/Sets/powerset.cmi 
+theories/Sets/powerset.cmx: theories/Sets/partial_Order.cmx \
+    theories/Sets/ensembles.cmx theories/Sets/powerset.cmi 
 theories/Sets/relations_1_facts.cmo: theories/Sets/relations_1_facts.cmi 
 theories/Sets/relations_1_facts.cmx: theories/Sets/relations_1_facts.cmi 
 theories/Sets/relations_1.cmo: theories/Sets/relations_1.cmi 
@@ -378,30 +660,46 @@ theories/Sets/relations_3_facts.cmo: theories/Sets/relations_3_facts.cmi
 theories/Sets/relations_3_facts.cmx: theories/Sets/relations_3_facts.cmi 
 theories/Sets/relations_3.cmo: theories/Sets/relations_3.cmi 
 theories/Sets/relations_3.cmx: theories/Sets/relations_3.cmi 
-theories/Sets/uniset.cmo: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Sets/uniset.cmi 
-theories/Sets/uniset.cmx: theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/Sets/uniset.cmi 
-theories/Sorting/heap.cmo: theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Sets/multiset.cmi \
-    theories/Init/peano.cmi theories/Sorting/sorting.cmi \
-    theories/Init/specif.cmi theories/Sorting/heap.cmi 
-theories/Sorting/heap.cmx: theories/Init/datatypes.cmx \
-    theories/Lists/list.cmx theories/Sets/multiset.cmx \
-    theories/Init/peano.cmx theories/Sorting/sorting.cmx \
-    theories/Init/specif.cmx theories/Sorting/heap.cmi 
-theories/Sorting/permutation.cmo: theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Sets/multiset.cmi \
-    theories/Init/peano.cmi theories/Init/specif.cmi \
+theories/Sets/uniset.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Sets/uniset.cmi 
+theories/Sets/uniset.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Sets/uniset.cmi 
+theories/Sorting/heap.cmo: theories/Init/specif.cmi \
+    theories/Sorting/sorting.cmi theories/Init/peano.cmi \
+    theories/Sets/multiset.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/Sorting/heap.cmi 
+theories/Sorting/heap.cmx: theories/Init/specif.cmx \
+    theories/Sorting/sorting.cmx theories/Init/peano.cmx \
+    theories/Sets/multiset.cmx theories/Lists/list.cmx \
+    theories/Init/datatypes.cmx theories/Sorting/heap.cmi 
+theories/Sorting/permutation.cmo: theories/Init/specif.cmi \
+    theories/Init/peano.cmi theories/Sets/multiset.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi \
     theories/Sorting/permutation.cmi 
-theories/Sorting/permutation.cmx: theories/Init/datatypes.cmx \
-    theories/Lists/list.cmx theories/Sets/multiset.cmx \
-    theories/Init/peano.cmx theories/Init/specif.cmx \
+theories/Sorting/permutation.cmx: theories/Init/specif.cmx \
+    theories/Init/peano.cmx theories/Sets/multiset.cmx \
+    theories/Lists/list.cmx theories/Init/datatypes.cmx \
     theories/Sorting/permutation.cmi 
-theories/Sorting/sorting.cmo: theories/Lists/list.cmi \
-    theories/Init/specif.cmi theories/Sorting/sorting.cmi 
-theories/Sorting/sorting.cmx: theories/Lists/list.cmx \
-    theories/Init/specif.cmx theories/Sorting/sorting.cmi 
+theories/Sorting/permutEq.cmo: theories/Sorting/permutEq.cmi 
+theories/Sorting/permutEq.cmx: theories/Sorting/permutEq.cmi 
+theories/Sorting/permutSetoid.cmo: theories/Sorting/permutSetoid.cmi 
+theories/Sorting/permutSetoid.cmx: theories/Sorting/permutSetoid.cmi 
+theories/Sorting/sorting.cmo: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/Sorting/sorting.cmi 
+theories/Sorting/sorting.cmx: theories/Init/specif.cmx \
+    theories/Lists/list.cmx theories/Sorting/sorting.cmi 
+theories/Strings/ascii.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bool.cmi \
+    theories/NArith/binPos.cmi theories/Strings/ascii.cmi 
+theories/Strings/ascii.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/Bool/bool.cmx \
+    theories/NArith/binPos.cmx theories/Strings/ascii.cmi 
+theories/Strings/string.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Strings/ascii.cmi \
+    theories/Strings/string.cmi 
+theories/Strings/string.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/Strings/ascii.cmx \
+    theories/Strings/string.cmi 
 theories/Wellfounded/disjoint_Union.cmo: \
     theories/Wellfounded/disjoint_Union.cmi 
 theories/Wellfounded/disjoint_Union.cmx: \
@@ -434,280 +732,405 @@ theories/Wellfounded/well_Ordering.cmx: theories/Init/specif.cmx \
     theories/Wellfounded/well_Ordering.cmi 
 theories/ZArith/auxiliary.cmo: theories/ZArith/auxiliary.cmi 
 theories/ZArith/auxiliary.cmx: theories/ZArith/auxiliary.cmi 
-theories/ZArith/binInt.cmo: theories/NArith/binNat.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+theories/ZArith/binInt.cmo: theories/Init/datatypes.cmi \
+    theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
     theories/ZArith/binInt.cmi 
-theories/ZArith/binInt.cmx: theories/NArith/binNat.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+theories/ZArith/binInt.cmx: theories/Init/datatypes.cmx \
+    theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
     theories/ZArith/binInt.cmi 
-theories/ZArith/wf_Z.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi 
-theories/ZArith/wf_Z.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/Init/peano.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmi 
-theories/ZArith/zabs.cmo: theories/ZArith/binInt.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi theories/ZArith/zabs.cmi 
-theories/ZArith/zabs.cmx: theories/ZArith/binInt.cmx theories/Init/specif.cmx \
-    theories/Bool/sumbool.cmx theories/ZArith/zabs.cmi 
+theories/ZArith/wf_Z.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/wf_Z.cmi 
+theories/ZArith/wf_Z.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/wf_Z.cmi 
+theories/ZArith/zabs.cmo: theories/Init/specif.cmi theories/ZArith/binInt.cmi \
+    theories/ZArith/zabs.cmi 
+theories/ZArith/zabs.cmx: theories/Init/specif.cmx theories/ZArith/binInt.cmx \
+    theories/ZArith/zabs.cmi 
 theories/ZArith/zArith_base.cmo: theories/ZArith/zArith_base.cmi 
 theories/ZArith/zArith_base.cmx: theories/ZArith/zArith_base.cmi 
-theories/ZArith/zArith_dec.cmo: theories/ZArith/binInt.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi 
-theories/ZArith/zArith_dec.cmx: theories/ZArith/binInt.cmx \
-    theories/Init/datatypes.cmx theories/Init/specif.cmx \
-    theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmi 
+theories/ZArith/zArith_dec.cmo: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/Init/datatypes.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zArith_dec.cmi 
+theories/ZArith/zArith_dec.cmx: theories/Bool/sumbool.cmx \
+    theories/Init/specif.cmx theories/Init/datatypes.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zArith_dec.cmi 
 theories/ZArith/zArith.cmo: theories/ZArith/zArith.cmi 
 theories/ZArith/zArith.cmx: theories/ZArith/zArith.cmi 
-theories/ZArith/zbinary.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Bool/bvector.cmi \
-    theories/Init/datatypes.cmi theories/ZArith/zeven.cmi \
+theories/ZArith/zbinary.cmo: theories/ZArith/zeven.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
     theories/ZArith/zbinary.cmi 
-theories/ZArith/zbinary.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Bool/bvector.cmx \
-    theories/Init/datatypes.cmx theories/ZArith/zeven.cmx \
+theories/ZArith/zbinary.cmx: theories/ZArith/zeven.cmx \
+    theories/Init/datatypes.cmx theories/Bool/bvector.cmx \
+    theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
     theories/ZArith/zbinary.cmi 
-theories/ZArith/zbool.cmo: theories/ZArith/binInt.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \
-    theories/ZArith/zeven.cmi theories/ZArith/zbool.cmi 
-theories/ZArith/zbool.cmx: theories/ZArith/binInt.cmx \
-    theories/Init/datatypes.cmx theories/Init/specif.cmx \
-    theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmx \
-    theories/ZArith/zeven.cmx theories/ZArith/zbool.cmi 
+theories/ZArith/zbool.cmo: theories/ZArith/zeven.cmi \
+    theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/Init/datatypes.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zbool.cmi 
+theories/ZArith/zbool.cmx: theories/ZArith/zeven.cmx \
+    theories/ZArith/zArith_dec.cmx theories/Bool/sumbool.cmx \
+    theories/Init/specif.cmx theories/Init/datatypes.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zbool.cmi 
 theories/ZArith/zcompare.cmo: theories/ZArith/zcompare.cmi 
 theories/ZArith/zcompare.cmx: theories/ZArith/zcompare.cmi 
-theories/ZArith/zcomplements.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \
-    theories/ZArith/zabs.cmi theories/ZArith/zcomplements.cmi 
-theories/ZArith/zcomplements.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/Lists/list.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \
-    theories/ZArith/zabs.cmx theories/ZArith/zcomplements.cmi 
-theories/ZArith/zdiv.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \
-    theories/ZArith/zbool.cmi theories/ZArith/zdiv.cmi 
-theories/ZArith/zdiv.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/ZArith/zArith_dec.cmx \
-    theories/ZArith/zbool.cmx theories/ZArith/zdiv.cmi 
-theories/ZArith/zeven.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/ZArith/zeven.cmi 
-theories/ZArith/zeven.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/ZArith/zeven.cmi 
+theories/ZArith/zcomplements.cmo: theories/ZArith/zabs.cmi \
+    theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zcomplements.cmi 
+theories/ZArith/zcomplements.cmx: theories/ZArith/zabs.cmx \
+    theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Lists/list.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zcomplements.cmi 
+theories/ZArith/zdiv.cmo: theories/ZArith/zbool.cmi \
+    theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zdiv.cmi 
+theories/ZArith/zdiv.cmx: theories/ZArith/zbool.cmx \
+    theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zdiv.cmi 
+theories/ZArith/zeven.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zeven.cmi 
+theories/ZArith/zeven.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zeven.cmi 
 theories/ZArith/zhints.cmo: theories/ZArith/zhints.cmi 
 theories/ZArith/zhints.cmx: theories/ZArith/zhints.cmi 
-theories/ZArith/zlogarithm.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/ZArith/zlogarithm.cmi 
-theories/ZArith/zlogarithm.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/ZArith/zlogarithm.cmi 
-theories/ZArith/zmin.cmo: theories/ZArith/binInt.cmi \
-    theories/Init/datatypes.cmi theories/ZArith/zmin.cmi 
-theories/ZArith/zmin.cmx: theories/ZArith/binInt.cmx \
-    theories/Init/datatypes.cmx theories/ZArith/zmin.cmi 
-theories/ZArith/zmisc.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
+theories/ZArith/zlogarithm.cmo: theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zlogarithm.cmi 
+theories/ZArith/zlogarithm.cmx: theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zlogarithm.cmi 
+theories/ZArith/zmax.cmo: theories/Init/datatypes.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zmax.cmi 
+theories/ZArith/zmax.cmx: theories/Init/datatypes.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zmax.cmi 
+theories/ZArith/zminmax.cmo: theories/ZArith/zminmax.cmi 
+theories/ZArith/zminmax.cmx: theories/ZArith/zminmax.cmi 
+theories/ZArith/zmin.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \
+    theories/ZArith/zmin.cmi 
+theories/ZArith/zmin.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \
+    theories/ZArith/zmin.cmi 
+theories/ZArith/zmisc.cmo: theories/Init/datatypes.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
     theories/ZArith/zmisc.cmi 
-theories/ZArith/zmisc.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
+theories/ZArith/zmisc.cmx: theories/Init/datatypes.cmx \
+    theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
     theories/ZArith/zmisc.cmi 
 theories/ZArith/znat.cmo: theories/ZArith/znat.cmi 
 theories/ZArith/znat.cmx: theories/ZArith/znat.cmi 
-theories/ZArith/znumtheory.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \
-    theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \
-    theories/ZArith/zorder.cmi theories/ZArith/znumtheory.cmi 
-theories/ZArith/znumtheory.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \
-    theories/ZArith/zArith_dec.cmx theories/ZArith/zdiv.cmx \
-    theories/ZArith/zorder.cmx theories/ZArith/znumtheory.cmi 
-theories/ZArith/zorder.cmo: theories/ZArith/binInt.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi \
+theories/ZArith/znumtheory.cmo: theories/ZArith/zorder.cmi \
+    theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \
+    theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/znumtheory.cmi 
+theories/ZArith/znumtheory.cmx: theories/ZArith/zorder.cmx \
+    theories/ZArith/zdiv.cmx theories/ZArith/zArith_dec.cmx \
+    theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Init/peano.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/znumtheory.cmi 
+theories/ZArith/zorder.cmo: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \
     theories/ZArith/zorder.cmi 
-theories/ZArith/zorder.cmx: theories/ZArith/binInt.cmx \
-    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+theories/ZArith/zorder.cmx: theories/Init/specif.cmx \
+    theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \
     theories/ZArith/zorder.cmi 
-theories/ZArith/zpower.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/ZArith/zmisc.cmi theories/ZArith/zpower.cmi 
-theories/ZArith/zpower.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Init/datatypes.cmx \
-    theories/ZArith/zmisc.cmx theories/ZArith/zpower.cmi 
-theories/ZArith/zsqrt.cmo: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/specif.cmi \
-    theories/ZArith/zArith_dec.cmi theories/ZArith/zsqrt.cmi 
-theories/ZArith/zsqrt.cmx: theories/ZArith/binInt.cmx \
-    theories/NArith/binPos.cmx theories/Init/specif.cmx \
-    theories/ZArith/zArith_dec.cmx theories/ZArith/zsqrt.cmi 
+theories/ZArith/zpower.cmo: theories/ZArith/zmisc.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zpower.cmi 
+theories/ZArith/zpower.cmx: theories/ZArith/zmisc.cmx \
+    theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zpower.cmi 
+theories/ZArith/zsqrt.cmo: theories/ZArith/zArith_dec.cmi \
+    theories/Init/specif.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi theories/ZArith/zsqrt.cmi 
+theories/ZArith/zsqrt.cmx: theories/ZArith/zArith_dec.cmx \
+    theories/Init/specif.cmx theories/NArith/binPos.cmx \
+    theories/ZArith/binInt.cmx theories/ZArith/zsqrt.cmi 
 theories/ZArith/zwf.cmo: theories/ZArith/zwf.cmi 
 theories/ZArith/zwf.cmx: theories/ZArith/zwf.cmi 
-theories/Arith/bool_nat.cmi: theories/Arith/compare_dec.cmi \
-    theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
-theories/Arith/compare_dec.cmi: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
-theories/Arith/compare.cmi: theories/Arith/compare_dec.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/Arith/div2.cmi: theories/Init/datatypes.cmi theories/Init/peano.cmi \
-    theories/Init/specif.cmi 
-theories/Arith/eqNat.cmi: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
-theories/Arith/euclid.cmi: theories/Arith/compare_dec.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/Arith/even.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/Arith/factorial.cmi: theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi 
-theories/Arith/max.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/Arith/min.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/Arith/mult.cmi: theories/Init/datatypes.cmi theories/Arith/plus.cmi 
-theories/Arith/peano_dec.cmi: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
-theories/Arith/plus.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
+theories/Arith/bool_nat.cmi: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/Arith/peano_dec.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi 
+theories/Arith/compare_dec.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi 
+theories/Arith/compare.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi 
+theories/Arith/div2.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi 
+theories/Arith/eqNat.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi 
+theories/Arith/euclid.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi 
+theories/Arith/even.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
+theories/Arith/factorial.cmi: theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi 
+theories/Arith/max.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
+theories/Arith/min.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
+theories/Arith/mult.cmi: theories/Arith/plus.cmi theories/Init/datatypes.cmi 
+theories/Arith/peano_dec.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi 
+theories/Arith/plus.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
 theories/Arith/wf_nat.cmi: theories/Init/datatypes.cmi 
-theories/Bool/boolEq.cmi: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
-theories/Bool/bool.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/Bool/bvector.cmi: theories/Bool/bool.cmi theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi 
+theories/Bool/boolEq.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi 
+theories/Bool/bool.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
+theories/Bool/bvector.cmi: theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bool.cmi 
 theories/Bool/decBool.cmi: theories/Init/specif.cmi 
-theories/Bool/ifProp.cmi: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
-theories/Bool/sumbool.cmi: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
+theories/Bool/ifProp.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi 
+theories/Bool/sumbool.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi 
 theories/Bool/zerob.cmi: theories/Init/datatypes.cmi 
-theories/Init/logic_Type.cmi: theories/Init/datatypes.cmi 
+theories/FSets/decidableTypeEx.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/decidableType.cmi: theories/Init/specif.cmi 
+theories/FSets/fMapAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/FSets/int.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi 
+theories/FSets/fMapFacts.cmi: theories/Init/specif.cmi \
+    theories/FSets/fMapInterface.cmi theories/Init/datatypes.cmi 
+theories/FSets/fMapInterface.cmi: theories/FSets/orderedType.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi 
+theories/FSets/fMapIntMap.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \
+    theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \
+    theories/IntMap/map.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binNat.cmi 
+theories/FSets/fMapList.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fMapPositive.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi 
+theories/FSets/fMapWeakFacts.cmi: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fMapWeakInterface.cmi: theories/Lists/list.cmi \
+    theories/FSets/decidableType.cmi theories/Init/datatypes.cmi 
+theories/FSets/fMapWeakList.cmi: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/FSets/decidableType.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fSetAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \
+    theories/Init/peano.cmi theories/FSets/orderedType.cmi \
+    theories/Lists/list.cmi theories/FSets/int.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/FSets/fSetBridge.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi 
+theories/FSets/fSetEqProperties.cmi: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/Init/peano.cmi \
+    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
+    theories/Bool/bool.cmi 
+theories/FSets/fSetFacts.cmi: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/FSets/fSetInterface.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fSetInterface.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fSetList.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fSetProperties.cmi: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/Lists/list.cmi \
+    theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi 
+theories/FSets/fSetToFiniteSet.cmi: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \
+    theories/FSets/orderedType.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fSetWeakFacts.cmi: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fSetWeakInterface.cmi: theories/Lists/list.cmi \
+    theories/FSets/decidableType.cmi theories/Init/datatypes.cmi 
+theories/FSets/fSetWeakList.cmi: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/FSets/decidableType.cmi \
+    theories/Init/datatypes.cmi 
+theories/FSets/fSetWeakProperties.cmi: theories/Init/specif.cmi \
+    theories/Setoids/setoid.cmi theories/Lists/list.cmi \
+    theories/FSets/fSetWeakInterface.cmi theories/Init/datatypes.cmi 
+theories/FSets/int.cmi: theories/ZArith/zmax.cmi \
+    theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi 
+theories/FSets/orderedTypeAlt.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Init/datatypes.cmi 
+theories/FSets/orderedTypeEx.cmi: theories/Init/specif.cmi \
+    theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
+    theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi theories/ZArith/binInt.cmi 
+theories/FSets/orderedType.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi 
 theories/Init/peano.cmi: theories/Init/datatypes.cmi 
 theories/Init/specif.cmi: theories/Init/datatypes.cmi 
-theories/IntMap/adalloc.cmi: theories/IntMap/addec.cmi \
-    theories/IntMap/addr.cmi theories/NArith/binPos.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/map.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
-theories/IntMap/addec.cmi: theories/IntMap/addr.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
-theories/IntMap/addr.cmi: theories/NArith/binPos.cmi theories/Bool/bool.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/IntMap/adist.cmi: theories/IntMap/addr.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi 
-theories/IntMap/fset.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/map.cmi \
-    theories/Init/specif.cmi 
-theories/IntMap/lsort.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
-    theories/NArith/binPos.cmi theories/Bool/bool.cmi \
-    theories/Init/datatypes.cmi theories/Lists/list.cmi \
-    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
-theories/IntMap/mapcanon.cmi: theories/IntMap/map.cmi \
-    theories/Init/specif.cmi 
-theories/IntMap/mapcard.cmi: theories/IntMap/addec.cmi \
-    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
-    theories/IntMap/map.cmi theories/Init/peano.cmi \
-    theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \
-    theories/Init/specif.cmi theories/Bool/sumbool.cmi 
-theories/IntMap/mapfold.cmi: theories/IntMap/addr.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/fset.cmi \
-    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \
-    theories/Init/specif.cmi 
-theories/IntMap/mapiter.cmi: theories/IntMap/addec.cmi \
-    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi 
-theories/IntMap/maplists.cmi: theories/IntMap/addec.cmi \
-    theories/IntMap/addr.cmi theories/Init/datatypes.cmi \
-    theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \
-    theories/IntMap/mapiter.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi 
-theories/IntMap/map.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/Init/specif.cmi 
-theories/IntMap/mapsubset.cmi: theories/Bool/bool.cmi \
-    theories/Init/datatypes.cmi theories/IntMap/fset.cmi \
-    theories/IntMap/map.cmi theories/IntMap/mapiter.cmi 
-theories/Lists/list.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/Lists/listSet.cmi: theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Init/specif.cmi 
+theories/IntMap/adalloc.cmi: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi 
+theories/IntMap/fset.cmi: theories/Init/specif.cmi \
+    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
+    theories/IntMap/map.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binNat.cmi 
+theories/IntMap/lsort.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
+    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
+    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binNat.cmi 
+theories/IntMap/mapcanon.cmi: theories/Init/specif.cmi \
+    theories/IntMap/map.cmi 
+theories/IntMap/mapcard.cmi: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/Arith/plus.cmi \
+    theories/Arith/peano_dec.cmi theories/Init/peano.cmi \
+    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
+    theories/IntMap/map.cmi theories/Init/datatypes.cmi \
+    theories/NArith/binNat.cmi 
+theories/IntMap/mapfold.cmi: theories/Init/specif.cmi \
+    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
+    theories/IntMap/fset.cmi theories/Init/datatypes.cmi 
+theories/IntMap/mapiter.cmi: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/NArith/ndigits.cmi \
+    theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binNat.cmi 
+theories/IntMap/maplists.cmi: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/NArith/ndec.cmi \
+    theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
+    theories/Lists/list.cmi theories/IntMap/fset.cmi \
+    theories/Init/datatypes.cmi 
+theories/IntMap/map.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi 
+theories/IntMap/mapsubset.cmi: theories/IntMap/mapiter.cmi \
+    theories/IntMap/map.cmi theories/IntMap/fset.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bool.cmi 
+theories/Lists/list.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi 
+theories/Lists/listSet.cmi: theories/Init/specif.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi 
 theories/Lists/monoList.cmi: theories/Init/datatypes.cmi 
+theories/Lists/setoidList.cmi: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi 
 theories/Lists/streams.cmi: theories/Init/datatypes.cmi 
-theories/Lists/theoryList.cmi: theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Init/specif.cmi 
-theories/NArith/binNat.cmi: theories/NArith/binPos.cmi \
+theories/Lists/theoryList.cmi: theories/Init/specif.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi 
+theories/Logic/choiceFacts.cmi: theories/Init/specif.cmi \
     theories/Init/datatypes.cmi 
-theories/NArith/binPos.cmi: theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi 
-theories/Relations/relation_Operators.cmi: theories/Lists/list.cmi \
-    theories/Init/specif.cmi 
+theories/Logic/classicalDescription.cmi: theories/Init/specif.cmi \
+    theories/Logic/choiceFacts.cmi 
+theories/Logic/classicalEpsilon.cmi: theories/Init/specif.cmi \
+    theories/Logic/choiceFacts.cmi 
+theories/Logic/diaconescu.cmi: theories/Init/specif.cmi 
+theories/Logic/eqdep_dec.cmi: theories/Init/specif.cmi 
+theories/NArith/binNat.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi 
+theories/NArith/binPos.cmi: theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi 
+theories/NArith/ndec.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
+    theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \
+    theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
+    theories/NArith/binPos.cmi theories/NArith/binNat.cmi 
+theories/NArith/ndigits.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
+    theories/Bool/bool.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi 
+theories/NArith/ndist.cmi: theories/NArith/ndigits.cmi theories/Arith/min.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/NArith/binNat.cmi 
+theories/NArith/nnat.cmi: theories/Init/datatypes.cmi \
+    theories/NArith/binPos.cmi theories/NArith/binNat.cmi 
+theories/QArith/qArith_base.cmi: theories/ZArith/zArith_dec.cmi \
+    theories/Init/specif.cmi theories/Setoids/setoid.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/QArith/qreals.cmi: theories/QArith/qArith_base.cmi \
+    theories/ZArith/binInt.cmi 
+theories/QArith/qreduction.cmi: theories/ZArith/znumtheory.cmi \
+    theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/QArith/qring.cmi: theories/Init/specif.cmi \
+    theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi 
+theories/Relations/relation_Operators.cmi: theories/Init/specif.cmi \
+    theories/Lists/list.cmi 
+theories/Setoids/setoid.cmi: theories/Init/datatypes.cmi 
 theories/Sets/cpo.cmi: theories/Sets/partial_Order.cmi 
-theories/Sets/integers.cmi: theories/Init/datatypes.cmi \
-    theories/Sets/partial_Order.cmi 
-theories/Sets/multiset.cmi: theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/Init/specif.cmi 
-theories/Sets/partial_Order.cmi: theories/Sets/ensembles.cmi \
-    theories/Sets/relations_1.cmi 
-theories/Sets/powerset.cmi: theories/Sets/ensembles.cmi \
-    theories/Sets/partial_Order.cmi 
-theories/Sets/uniset.cmi: theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
-theories/Sorting/heap.cmi: theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Sets/multiset.cmi \
-    theories/Init/peano.cmi theories/Sorting/sorting.cmi \
-    theories/Init/specif.cmi 
-theories/Sorting/permutation.cmi: theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Sets/multiset.cmi \
-    theories/Init/peano.cmi theories/Init/specif.cmi 
-theories/Sorting/sorting.cmi: theories/Lists/list.cmi \
-    theories/Init/specif.cmi 
-theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi 
-theories/ZArith/binInt.cmi: theories/NArith/binNat.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi 
-theories/ZArith/wf_Z.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/peano.cmi theories/Init/specif.cmi 
-theories/ZArith/zabs.cmi: theories/ZArith/binInt.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi 
-theories/ZArith/zArith_dec.cmi: theories/ZArith/binInt.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi 
-theories/ZArith/zbinary.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Bool/bvector.cmi \
-    theories/Init/datatypes.cmi theories/ZArith/zeven.cmi 
-theories/ZArith/zbool.cmi: theories/ZArith/binInt.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi \
-    theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \
-    theories/ZArith/zeven.cmi 
-theories/ZArith/zcomplements.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \
-    theories/ZArith/zabs.cmi 
-theories/ZArith/zdiv.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \
-    theories/ZArith/zbool.cmi 
-theories/ZArith/zeven.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi 
-theories/ZArith/zlogarithm.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi 
-theories/ZArith/zmin.cmi: theories/ZArith/binInt.cmi \
+theories/Sets/integers.cmi: theories/Sets/partial_Order.cmi \
     theories/Init/datatypes.cmi 
-theories/ZArith/zmisc.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi 
-theories/ZArith/znumtheory.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \
-    theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \
-    theories/ZArith/zorder.cmi 
-theories/ZArith/zorder.cmi: theories/ZArith/binInt.cmi \
-    theories/Init/datatypes.cmi theories/Init/specif.cmi 
-theories/ZArith/zpower.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/datatypes.cmi \
-    theories/ZArith/zmisc.cmi 
-theories/ZArith/zsqrt.cmi: theories/ZArith/binInt.cmi \
-    theories/NArith/binPos.cmi theories/Init/specif.cmi \
-    theories/ZArith/zArith_dec.cmi 
+theories/Sets/multiset.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi 
+theories/Sets/partial_Order.cmi: theories/Sets/relations_1.cmi \
+    theories/Sets/ensembles.cmi 
+theories/Sets/powerset.cmi: theories/Sets/partial_Order.cmi \
+    theories/Sets/ensembles.cmi 
+theories/Sets/uniset.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi 
+theories/Sorting/heap.cmi: theories/Init/specif.cmi \
+    theories/Sorting/sorting.cmi theories/Init/peano.cmi \
+    theories/Sets/multiset.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi 
+theories/Sorting/permutation.cmi: theories/Init/specif.cmi \
+    theories/Init/peano.cmi theories/Sets/multiset.cmi \
+    theories/Lists/list.cmi theories/Init/datatypes.cmi 
+theories/Sorting/sorting.cmi: theories/Init/specif.cmi \
+    theories/Lists/list.cmi 
+theories/Strings/ascii.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bool.cmi \
+    theories/NArith/binPos.cmi 
+theories/Strings/string.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/Strings/ascii.cmi 
+theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi 
+theories/ZArith/binInt.cmi: theories/Init/datatypes.cmi \
+    theories/NArith/binPos.cmi theories/NArith/binNat.cmi 
+theories/ZArith/wf_Z.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zabs.cmi: theories/Init/specif.cmi theories/ZArith/binInt.cmi 
+theories/ZArith/zArith_dec.cmi: theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/Init/datatypes.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zbinary.cmi: theories/ZArith/zeven.cmi \
+    theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi 
+theories/ZArith/zbool.cmi: theories/ZArith/zeven.cmi \
+    theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \
+    theories/Init/specif.cmi theories/Init/datatypes.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zcomplements.cmi: theories/ZArith/zabs.cmi \
+    theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zdiv.cmi: theories/ZArith/zbool.cmi \
+    theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zeven.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zlogarithm.cmi: theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zmax.cmi: theories/Init/datatypes.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zmin.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/ZArith/binInt.cmi 
+theories/ZArith/zmisc.cmi: theories/Init/datatypes.cmi \
+    theories/NArith/binPos.cmi theories/ZArith/binInt.cmi 
+theories/ZArith/znumtheory.cmi: theories/ZArith/zorder.cmi \
+    theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \
+    theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zorder.cmi: theories/Init/specif.cmi \
+    theories/Init/datatypes.cmi theories/ZArith/binInt.cmi 
+theories/ZArith/zpower.cmi: theories/ZArith/zmisc.cmi \
+    theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
+theories/ZArith/zsqrt.cmi: theories/ZArith/zArith_dec.cmi \
+    theories/Init/specif.cmi theories/NArith/binPos.cmi \
+    theories/ZArith/binInt.cmi 
diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile
index c9bb5623..65a54090 100644
--- a/contrib/extraction/test/Makefile
+++ b/contrib/extraction/test/Makefile
@@ -10,7 +10,7 @@ AXIOMSVO:= \
 theories/Reals/% \
 theories/Num/%
 
-DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS))
+DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -path \*.svn\*))
 
 INCL:= $(patsubst %,-I %,$(DIRS))
 
@@ -34,7 +34,7 @@ all: v2ml ml $(MLI) $(CMO)
 
 ml: $(ML)
 
-depend: $(ML)
+depend: #$(ML)
 	rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend
 
 tree:
diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc
index 0fb556aa..e7204838 100644
--- a/contrib/extraction/test/custom/Adalloc
+++ b/contrib/extraction/test/custom/Adalloc
@@ -1,2 +1,2 @@
-Require Import Addr.
-Extraction NoInline ad_double ad_double_plus_un.
+Require Import BinNat.
+Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort
index 6a185683..22ab18e3 100644
--- a/contrib/extraction/test/custom/Lsort
+++ b/contrib/extraction/test/custom/Lsort
@@ -1,2 +1,2 @@
-Require Import Addr. 
-Extraction NoInline ad_double ad_double_plus_un.
+Require Import BinNat. 
+Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map
index 3e464e39..f024dbd7 100644
--- a/contrib/extraction/test/custom/Map
+++ b/contrib/extraction/test/custom/Map
@@ -1,3 +1,3 @@
-Require Import Addr.
-Extraction NoInline ad_double ad_double_plus_un.
+Require Import BinNat.
+Extraction NoInline Ndouble Ndouble_plus_one.
 
diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard
index ca555aa3..5932cf7b 100644
--- a/contrib/extraction/test/custom/Mapcard
+++ b/contrib/extraction/test/custom/Mapcard
@@ -1,4 +1,4 @@
 Require Import Plus.
 Extraction NoInline plus_is_one.
-Require Import Addr.
-Extraction NoInline ad_double ad_double_plus_un.
+Require Import BinNat.
+Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter
index 6a185683..22ab18e3 100644
--- a/contrib/extraction/test/custom/Mapiter
+++ b/contrib/extraction/test/custom/Mapiter
@@ -1,2 +1,2 @@
-Require Import Addr. 
-Extraction NoInline ad_double ad_double_plus_un.
+Require Import BinNat. 
+Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib7/field/Field.v b/contrib/field/LegacyField.v
index f282e246..08397d02 100644
--- a/contrib7/field/Field.v
+++ b/contrib/field/LegacyField.v
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
+(* $Id: LegacyField.v 9273 2006-10-25 11:30:36Z barras $ *)
 
-Require Export Field_Compl.
-Require Export Field_Theory.
-Require Export Field_Tactic.
+Require Export LegacyField_Compl.
+Require Export LegacyField_Theory.
+Require Export LegacyField_Tactic.
 
 (* Command declarations are moved to the ML side *)
diff --git a/contrib/field/Field_Compl.v b/contrib/field/LegacyField_Compl.v
index cba921f7..b37281e9 100644
--- a/contrib/field/Field_Compl.v
+++ b/contrib/field/LegacyField_Compl.v
@@ -6,56 +6,33 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field_Compl.v,v 1.8.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+(* $Id: LegacyField_Compl.v 9273 2006-10-25 11:30:36Z barras $ *)
 
-Inductive listT (A:Type) : Type :=
-  | nilT : listT A
-  | consT : A -> listT A -> listT A.
-
-Fixpoint appT (A:Type) (l m:listT A) {struct l} : listT A :=
-  match l with
-  | nilT => m
-  | consT a l1 => consT A a (appT A l1 m)
-  end.
-
-Inductive prodT (A B:Type) : Type :=
-    pairT : A -> B -> prodT A B.
+Require Import List.
 
 Definition assoc_2nd :=
   (fix assoc_2nd_rec (A:Type) (B:Set)
                      (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
-                     (lst:listT (prodT A B)) {struct lst} : 
+                     (lst:list (prod A B)) {struct lst} : 
    B -> A -> A :=
      fun (key:B) (default:A) =>
        match lst with
-       | nilT => default
-       | consT (pairT v e) l =>
+       | nil => default
+       | (v,e) :: l =>
            match eq_dec e key with
            | left _ => v
            | right _ => assoc_2nd_rec A B eq_dec l key default
            end
        end).
 
-Definition fstT (A B:Type) (c:prodT A B) := match c with
-                                            | pairT a _ => a
-                                            end.
-
-Definition sndT (A B:Type) (c:prodT A B) := match c with
-                                            | pairT _ a => a
-                                            end.
-
 Definition mem :=
   (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) 
-           (a:A) (l:listT A) {struct l} : bool :=
+           (a:A) (l:list A) {struct l} : bool :=
      match l with
-     | nilT => false
-     | consT a1 l1 =>
+     | nil => false
+     | a1 :: l1 =>
          match eq_dec a a1 with
          | left _ => true
          | right _ => mem A eq_dec a l1
          end
      end).
-
-Inductive field_rel_option (A:Type) : Type :=
-  | Field_None : field_rel_option A
-  | Field_Some : (A -> A -> A) -> field_rel_option A.
\ No newline at end of file
diff --git a/contrib/field/Field_Tactic.v b/contrib/field/LegacyField_Tactic.v
index c5c06547..2b6ff5b4 100644
--- a/contrib/field/Field_Tactic.v
+++ b/contrib/field/LegacyField_Tactic.v
@@ -6,72 +6,74 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field_Tactic.v,v 1.20.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+(* $Id: LegacyField_Tactic.v 9319 2006-10-30 12:41:21Z barras $ *)
 
-Require Import Ring.
-Require Export Field_Compl.
-Require Export Field_Theory.
+Require Import List.
+Require Import LegacyRing.
+Require Export LegacyField_Compl.
+Require Export LegacyField_Theory.
 
 (**** Interpretation A --> ExprA ****)
 
+Ltac get_component a s := eval cbv beta iota delta [a] in (a s).
+
+Ltac body_of s := eval cbv beta iota delta [s] in s.
+
 Ltac mem_assoc var lvar :=
   match constr:lvar with
-  | (nilT _) => constr:false
-  | (consT _ ?X1 ?X2) =>
+  | nil => constr:false
+  | ?X1 :: ?X2 =>
       match constr:(X1 = var) with
       | (?X1 = ?X1) => constr:true
       | _ => mem_assoc var X2
       end
   end.
 
-Ltac seek_var_aux FT lvar trm :=
-  let AT := eval cbv beta iota delta [A] in (A FT)
-  with AzeroT := eval cbv beta iota delta [Azero] in (Azero FT)
-  with AoneT := eval cbv beta iota delta [Aone] in (Aone FT)
-  with AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT)
-  with AmultT := eval cbv beta iota delta [Amult] in (Amult FT)
-  with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT)
-  with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in
-  match constr:trm with
-  | AzeroT => lvar
-  | AoneT => lvar
-  | (AplusT ?X1 ?X2) =>
-      let l1 := seek_var_aux FT lvar X1 in
-      seek_var_aux FT l1 X2
-  | (AmultT ?X1 ?X2) =>
-      let l1 := seek_var_aux FT lvar X1 in
-      seek_var_aux FT l1 X2
-  | (AoppT ?X1) => seek_var_aux FT lvar X1
-  | (AinvT ?X1) => seek_var_aux FT lvar X1
-  | ?X1 =>
-      let res := mem_assoc X1 lvar in
-      match constr:res with
-      | true => lvar
-      | false => constr:(consT AT X1 lvar)
-      end
-  end.
-
-Ltac seek_var FT trm :=
-  let AT := eval cbv beta iota delta [A] in (A FT) in
-  seek_var_aux FT (nilT AT) trm.
-
-Ltac number_aux lvar cpt :=
-  match constr:lvar with
-  | (nilT ?X1) => constr:(nilT (prodT X1 nat))
-  | (consT ?X1 ?X2 ?X3) =>
-      let l2 := number_aux X3 (S cpt) in
-      constr:(consT (prodT X1 nat) (pairT X1 nat X2 cpt) l2)
-  end.
-
-Ltac number lvar := number_aux lvar 0.
-
-Ltac build_varlist FT trm := let lvar := seek_var FT trm in
-                             number lvar.
+Ltac number lvar := 
+  let rec number_aux lvar cpt :=
+    match constr:lvar with
+    | (@nil ?X1) => constr:(@nil (prod X1 nat))
+    | ?X2 :: ?X3 =>
+        let l2 := number_aux X3 (S cpt) in
+        constr:((X2,cpt) :: l2) 
+    end
+  in number_aux lvar 0.
+
+Ltac build_varlist FT trm := 
+  let rec seek_var lvar trm :=
+    let AT := get_component A FT
+    with AzeroT := get_component Azero FT
+    with AoneT := get_component Aone FT
+    with AplusT := get_component Aplus FT
+    with AmultT := get_component Amult FT
+    with AoppT := get_component Aopp FT
+    with AinvT := get_component Ainv FT in
+    match constr:trm with
+    | AzeroT => lvar
+    | AoneT => lvar
+    | (AplusT ?X1 ?X2) =>
+        let l1 := seek_var lvar X1 in
+        seek_var l1 X2
+    | (AmultT ?X1 ?X2) =>
+        let l1 := seek_var lvar X1 in
+        seek_var l1 X2
+    | (AoppT ?X1) => seek_var lvar X1
+    | (AinvT ?X1) => seek_var lvar X1
+    | ?X1 =>
+        let res := mem_assoc X1 lvar in
+        match constr:res with
+        | true => lvar
+        | false => constr:(X1 :: lvar)
+        end
+    end in
+  let AT := get_component A FT in
+  let lvar := seek_var (@nil AT) trm in
+  number lvar.
 
 Ltac assoc elt lst :=
   match constr:lst with
-  | (nilT _) => fail
-  | (consT (prodT _ nat) (pairT _ nat ?X1 ?X2) ?X3) =>
+  | nil => fail
+  | (?X1,?X2) :: ?X3 =>
       match constr:(elt = X1) with
       | (?X1 = ?X1) => constr:X2
       | _ => assoc elt X3
@@ -79,13 +81,13 @@ Ltac assoc elt lst :=
   end.
 
 Ltac interp_A FT lvar trm :=
-  let AT := eval cbv beta iota delta [A] in (A FT)
-  with AzeroT := eval cbv beta iota delta [Azero] in (Azero FT)
-  with AoneT := eval cbv beta iota delta [Aone] in (Aone FT)
-  with AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT)
-  with AmultT := eval cbv beta iota delta [Amult] in (Amult FT)
-  with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT)
-  with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in
+  let AT := get_component A FT
+  with AzeroT := get_component Azero FT
+  with AoneT := get_component Aone FT
+  with AplusT := get_component Aplus FT
+  with AmultT := get_component Amult FT
+  with AoppT := get_component Aopp FT
+  with AinvT := get_component Ainv FT in
   match constr:trm with
   | AzeroT => constr:EAzero
   | AoneT => constr:EAone
@@ -112,32 +114,31 @@ Ltac interp_A FT lvar trm :=
 
 Ltac remove e l :=
   match constr:l with
-  | (nilT _) => l
-  | (consT ?X1 e ?X2) => constr:X2
-  | (consT ?X1 ?X2 ?X3) => let nl := remove e X3 in
-                           constr:(consT X1 X2 nl)
+  | nil => l
+  | e :: ?X2 => constr:X2
+  | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl)
   end.
 
 Ltac union l1 l2 :=
   match constr:l1 with
-  | (nilT _) => l2
-  | (consT ?X1 ?X2 ?X3) =>
+  | nil => l2
+  | ?X2 :: ?X3 =>
       let nl2 := remove X2 l2 in
       let nl := union X3 nl2 in
-      constr:(consT X1 X2 nl)
+      constr:(X2 :: nl)
   end.
 
 Ltac raw_give_mult trm :=
   match constr:trm with
-  | (EAinv ?X1) => constr:(consT ExprA X1 (nilT ExprA))
+  | (EAinv ?X1) => constr:(X1 :: nil)
   | (EAopp ?X1) => raw_give_mult X1
   | (EAplus ?X1 ?X2) =>
       let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
       union l1 l2
   | (EAmult ?X1 ?X2) =>
       let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
-      eval compute in (appT ExprA l1 l2)
-  | _ => constr:(nilT ExprA)
+      eval compute in (app l1 l2)
+  | _ => constr:(@nil ExprA)
   end.
 
 Ltac give_mult trm :=
@@ -181,18 +182,17 @@ Ltac weak_reduce :=
 
 Ltac multiply mul :=
   match goal with
-  |  |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA ?X1 ?X2 ?X4) =>
-      let AzeroT := eval cbv beta iota delta [Azero X1] in (Azero X1) in
-      (cut (interp_ExprA X1 X2 mul <> AzeroT);
-        [ intro; let id := grep_mult in
-                 apply (mult_eq X1 X3 X4 mul X2 id)
-        | weak_reduce;
-           let AoneT := eval cbv beta iota delta [Aone X1] in (Aone X1)
-           with AmultT := eval cbv beta iota delta [Amult X1] in (Amult X1) in
-           (try
+  |  |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) =>
+      let AzeroT := get_component Azero FT in
+      cut (interp_ExprA FT X2 mul <> AzeroT);
+       [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id))
+       | weak_reduce;
+          (let AoneT := get_component Aone ltac:(body_of FT)
+           with AmultT := get_component Amult ltac:(body_of FT) in
+           try
              match goal with
-             |  |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r X1)
-             end; clear X1 X2) ])
+             |  |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT)
+             end; clear FT X2) ]
   end.
 
 Ltac apply_multiply FT lvar trm :=
@@ -219,10 +219,10 @@ Ltac apply_inverse mul FT lvar trm :=
 Ltac strong_fail tac := first [ tac | fail 2 ].
 
 Ltac inverse_test_aux FT trm :=
-  let AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT)
-  with AmultT := eval cbv beta iota delta [Amult] in (Amult FT)
-  with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT)
-  with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in
+  let AplusT := get_component Aplus FT
+  with AmultT := get_component Amult FT
+  with AoppT := get_component Aopp FT
+  with AinvT := get_component Ainv FT in
   match constr:trm with
   | (AinvT _) => fail 1
   | (AoppT ?X1) =>
@@ -235,7 +235,7 @@ Ltac inverse_test_aux FT trm :=
   end.
 
 Ltac inverse_test FT :=
-  let AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) in
+  let AplusT := get_component Aplus FT in
   match goal with
   |  |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2)
   end.
@@ -253,33 +253,33 @@ Ltac apply_simplif sfun :=
    end.
 
 Ltac unfolds FT :=
-  match eval cbv beta iota delta [Aminus] in (Aminus FT) with
-  | (Field_Some _ ?X1) => unfold X1 in |- *
+  match get_component Aminus FT with
+  | Some ?X1 => unfold X1 in |- *
   | _ => idtac
   end;
-   match eval cbv beta iota delta [Adiv] in (Adiv FT) with
-   | (Field_Some _ ?X1) => unfold X1 in |- *
-   | _ => idtac
-   end.
+  match get_component Adiv FT with
+  | Some ?X1 => unfold X1 in |- *
+  | _ => idtac
+  end.
 
 Ltac reduce FT :=
-  let AzeroT := eval cbv beta iota delta [Azero] in (Azero FT)
-  with AoneT := eval cbv beta iota delta [Aone] in (Aone FT)
-  with AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT)
-  with AmultT := eval cbv beta iota delta [Amult] in (Amult FT)
-  with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT)
-  with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in
+  let AzeroT := get_component Azero FT
+  with AoneT := get_component Aone FT
+  with AplusT := get_component Aplus FT
+  with AmultT := get_component Amult FT
+  with AoppT := get_component Aopp FT
+  with AinvT := get_component Ainv FT in
   (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] in |- * ||
      compute in |- *).
 
 Ltac field_gen_aux FT :=
-  let AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) in
+  let AplusT := get_component Aplus FT in
   match goal with
   |  |- (?X1 = ?X2) =>
       let lvar := build_varlist FT (AplusT X1 X2) in
       let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in
       let mul := give_mult (EAplus trm1 trm2) in
-      (cut
+      cut
         (let ft := FT in
          let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
         [ compute in |- *; auto
@@ -287,13 +287,14 @@ Ltac field_gen_aux FT :=
            apply_simplif apply_assoc; multiply mul;
            [ apply_simplif apply_multiply;
               apply_simplif ltac:(apply_inverse mul);
-              let id := grep_mult in
-              clear id; weak_reduce; clear ft vm; first
-              [ inverse_test FT; ring | field_gen_aux FT ]
-           | idtac ] ])
+              (let id := grep_mult in
+               clear id; weak_reduce; clear ft vm; first
+              [ inverse_test FT; legacy ring | field_gen_aux FT ])
+           | idtac ] ]
   end.
 
-Ltac field_gen FT := unfolds FT; (inverse_test FT; ring) || field_gen_aux FT.
+Ltac field_gen FT :=
+  unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT.
 
 (*****************************)
 (*    Term Simplification    *)
@@ -303,12 +304,12 @@ Ltac field_gen FT := unfolds FT; (inverse_test FT; ring) || field_gen_aux FT.
 
 Ltac init_exp FT trm :=
   let e :=
-   (match eval cbv beta iota delta [Aminus] in (Aminus FT) with
-    | (Field_Some _ ?X1) => eval cbv beta delta [X1] in trm
+   (match get_component Aminus FT with
+    | Some ?X1 => eval cbv beta delta [X1] in trm
     | _ => trm
     end) in
-  match eval cbv beta iota delta [Adiv] in (Adiv FT) with
-  | (Field_Some _ ?X1) => eval cbv beta delta [X1] in e
+  match get_component Adiv FT with
+  | Some ?X1 => eval cbv beta delta [X1] in e
   | _ => e
   end.
 
@@ -341,21 +342,21 @@ Ltac simpl_inv trm :=
 
 Ltac map_tactic fcn lst :=
   match constr:lst with
-  | (nilT _) => lst
-  | (consT ?X1 ?X2 ?X3) =>
+  | nil => lst
+  | ?X2 :: ?X3 =>
       let r := fcn X2 with t := map_tactic fcn X3 in
-      constr:(consT X1 r t)
+      constr:(r :: t)
   end.
 
 Ltac build_monom_aux lst trm :=
   match constr:lst with
-  | (nilT _) => eval compute in (assoc trm)
-  | (consT _ ?X1 ?X2) => build_monom_aux X2 (EAmult trm X1)
+  | nil => eval compute in (assoc trm)
+  | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1)
   end.
 
 Ltac build_monom lnum lden :=
   let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in
-  let ltot := eval compute in (appT ExprA lnum ildn) in
+  let ltot := eval compute in (app lnum ildn) in
   let trm := build_monom_aux ltot EAone in
   match constr:trm with
   | (EAmult _ ?X1) => constr:X1
@@ -370,7 +371,7 @@ Ltac simpl_monom_aux lnum lden trm :=
       | true =>
           let newlnum := remove X1 lnum in
           simpl_monom_aux newlnum lden X2
-      | false => simpl_monom_aux lnum (consT ExprA X1 lden) X2
+      | false => simpl_monom_aux lnum (X1 :: lden) X2
       end
   | (EAmult ?X1 ?X2) =>
       let mma := mem_assoc X1 lden in
@@ -378,7 +379,7 @@ Ltac simpl_monom_aux lnum lden trm :=
       | true =>
           let newlden := remove X1 lden in
           simpl_monom_aux lnum newlden X2
-      | false => simpl_monom_aux (consT ExprA X1 lnum) lden X2
+      | false => simpl_monom_aux (X1 :: lnum) lden X2
       end
   | (EAinv ?X1) =>
       let mma := mem_assoc X1 lnum in
@@ -386,7 +387,7 @@ Ltac simpl_monom_aux lnum lden trm :=
       | true =>
           let newlnum := remove X1 lnum in
           build_monom newlnum lden
-      | false => build_monom lnum (consT ExprA X1 lden)
+      | false => build_monom lnum (X1 :: lden)
       end
   | ?X1 =>
       let mma := mem_assoc X1 lden in
@@ -394,11 +395,11 @@ Ltac simpl_monom_aux lnum lden trm :=
       | true =>
           let newlden := remove X1 lden in
           build_monom lnum newlden
-      | false => build_monom (consT ExprA X1 lnum) lden
+      | false => build_monom (X1 :: lnum) lden
       end
   end.
 
-Ltac simpl_monom trm := simpl_monom_aux (nilT ExprA) (nilT ExprA) trm.
+Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm.
 
 Ltac simpl_all_monomials trm :=
   match constr:trm with
@@ -429,4 +430,4 @@ Ltac field_term FT exp :=
    simpl_all_monomials
     ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in
   let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in
-  (replace exp with trep; [ ring trep | field_gen FT ]).
\ No newline at end of file
+  (replace exp with trep; [ legacy ring trep | field_gen FT ]).
diff --git a/contrib/field/Field_Theory.v b/contrib/field/LegacyField_Theory.v
index 8737fd79..9c3a12fb 100644
--- a/contrib/field/Field_Theory.v
+++ b/contrib/field/LegacyField_Theory.v
@@ -6,11 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field_Theory.v,v 1.12.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+(* $Id: LegacyField_Theory.v 9288 2006-10-26 18:25:06Z herbelin $ *)
 
+Require Import List.
 Require Import Peano_dec.
-Require Import Ring.
-Require Import Field_Compl.
+Require Import LegacyRing.
+Require Import LegacyField_Compl.
 
 Record Field_Theory : Type := 
   {A : Type;
@@ -21,8 +22,8 @@ Record Field_Theory : Type :=
    Aopp : A -> A;
    Aeq : A -> A -> bool;
    Ainv : A -> A;
-   Aminus : field_rel_option A;
-   Adiv : field_rel_option A;
+   Aminus : option (A -> A -> A);
+   Adiv : option (A -> A -> A);
    RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq;
    Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}.
 
@@ -66,10 +67,10 @@ Definition eqExprA := Eval compute in eqExprA_O.
 
 (**** Generation of the multiplier ****)
 
-Fixpoint mult_of_list (e:listT ExprA) : ExprA :=
+Fixpoint mult_of_list (e:list ExprA) : ExprA :=
   match e with
-  | nilT => EAone
-  | consT e1 l1 => EAmult e1 (mult_of_list l1)
+  | nil => EAone
+  | e1 :: l1 => EAmult e1 (mult_of_list l1)
   end.
 
 Section Theory_of_fields.
@@ -87,66 +88,66 @@ Let AinvT := Ainv T.
 Let RTT := RT T.
 Let Th_inv_defT := Th_inv_def T.
 
-Add Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
+Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
  Azero T) (Aopp T) (Aeq T) (RT T).
 
-Add Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
+Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
 
 (***************************)
 (*    Lemmas to be used    *)
 (***************************)
 
-Lemma AplusT_sym : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
+Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AplusT_assoc :
  forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3).
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
-Lemma AmultT_sym : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
+Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AmultT_assoc :
  forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3).
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT.
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma AmultT_AplusT_distr :
  forall r1 r2 r3:AT,
    AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3).
 Proof.
-  intros; ring.
+  intros; legacy ring.
 Qed.
 
 Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2.
 Proof.
   intros; transitivity (AplusT (AplusT (AoppT r) r) r1).
-  ring.
+  legacy ring.
   transitivity (AplusT (AplusT (AoppT r) r) r2).
   repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
-  ring.
+  legacy ring.
 Qed.
  
 Lemma r_AmultT_mult :
@@ -161,28 +162,28 @@ Qed.
 
 Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
 Proof.
-  intro; ring.
+  intro; legacy ring.
 Qed.
  
 Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
 Proof.
-  intro; ring.
+  intro; legacy ring.
 Qed.
  
 Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
 Proof.
-  intro; ring.
+  intro; legacy ring.
 Qed.
  
 Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT.
 Proof.
-  intros; rewrite AmultT_sym; apply Th_inv_defT; auto.
+  intros; rewrite AmultT_comm; apply Th_inv_defT; auto.
 Qed.
  
 Lemma Rmult_neq_0_reg :
  forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
 Proof.
-  intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; ring.
+  intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring.
 Qed.
 
 (************************)
@@ -191,7 +192,7 @@ Qed.
 
 (**** ExprA --> A ****)
 
-Fixpoint interp_ExprA (lvar:listT (prodT AT nat)) (e:ExprA) {struct e} :
+Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} :
  AT :=
   match e with
   | EAzero => AzeroT
@@ -257,7 +258,7 @@ Fixpoint assoc (e:ExprA) : ExprA :=
   end.
 
 Lemma merge_mult_correct1 :
- forall (e1 e2 e3:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) =
    interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)).
 Proof.
@@ -271,11 +272,11 @@ unfold merge_mult at 1 in |- *; fold merge_mult in |- *;
 Qed.
 
 Lemma merge_mult_correct :
- forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2).
 Proof.
 simple induction e1; auto; intros.
-elim e0; try (intros; simpl in |- *; ring).
+elim e0; try (intros; simpl in |- *; legacy ring).
 unfold interp_ExprA in H2; fold interp_ExprA in H2;
  cut
   (AmultT (interp_ExprA lvar e2)
@@ -285,12 +286,12 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2;
      (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4))
         (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
 intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1;
- simpl in |- *; ring.
-ring.
+ simpl in |- *; legacy ring.
+legacy ring.
 Qed.
 
 Lemma assoc_mult_correct1 :
- forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
    AmultT (interp_ExprA lvar (assoc_mult e1))
      (interp_ExprA lvar (assoc_mult e2)) =
    interp_ExprA lvar (assoc_mult (EAmult e1 e2)).
@@ -302,12 +303,12 @@ rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct;
 Qed.
 
 Lemma assoc_mult_correct :
- forall (e:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e.
 Proof.
 simple induction e; auto; intros.
 elim e0; intros.
-intros; simpl in |- *; ring.
+intros; simpl in |- *; legacy ring.
 simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
  rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0.
 simpl in |- *; rewrite (H0 lvar); auto.
@@ -316,16 +317,16 @@ simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
  rewrite assoc_mult_correct1; rewrite H2; simpl in |- *;
  rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
  fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
- rewrite (AmultT_sym (interp_ExprA lvar e3) (interp_ExprA lvar e1));
+ rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
  rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; 
- ring.
+ legacy ring.
 simpl in |- *; rewrite (H0 lvar); auto.
 simpl in |- *; rewrite (H0 lvar); auto.
 simpl in |- *; rewrite (H0 lvar); auto.
 Qed.
 
 Lemma merge_plus_correct1 :
- forall (e1 e2 e3:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) =
    interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)).
 Proof.
@@ -339,11 +340,11 @@ unfold merge_plus at 1 in |- *; fold merge_plus in |- *;
 Qed.
 
 Lemma merge_plus_correct :
- forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2).
 Proof.
 simple induction e1; auto; intros.
-elim e0; try intros; try (simpl in |- *; ring).
+elim e0; try intros; try (simpl in |- *; legacy ring).
 unfold interp_ExprA in H2; fold interp_ExprA in H2;
  cut
   (AplusT (interp_ExprA lvar e2)
@@ -353,12 +354,12 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2;
      (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4))
         (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
 intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1;
- simpl in |- *; ring.
-ring.
+ simpl in |- *; legacy ring.
+legacy ring.
 Qed.
 
 Lemma assoc_plus_correct :
- forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
    AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) =
    interp_ExprA lvar (assoc (EAplus e1 e2)).
 Proof.
@@ -369,7 +370,7 @@ rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct;
 Qed.
 
 Lemma assoc_correct :
- forall (e:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (assoc e) = interp_ExprA lvar e.
 Proof.
 simple induction e; auto; intros.
@@ -386,7 +387,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
      (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
         (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
  rewrite
-  (AplusT_sym (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
+  (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
   ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; 
  rewrite (H0 lvar);
  rewrite <-
@@ -396,10 +397,10 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
  rewrite
   (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
      (interp_ExprA lvar e3));
- rewrite (AplusT_sym (interp_ExprA lvar e1) (interp_ExprA lvar e3));
+ rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3));
  rewrite <-
   (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
-     (interp_ExprA lvar e1)); apply AplusT_sym.
+     (interp_ExprA lvar e1)); apply AplusT_comm.
 unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
  fold interp_ExprA in |- *; rewrite assoc_mult_correct; 
  rewrite (H0 lvar); simpl in |- *; auto.
@@ -448,39 +449,39 @@ Fixpoint distrib_main (e:ExprA) : ExprA :=
 Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e).
 
 Lemma distrib_mult_right_correct :
- forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (distrib_mult_right e1 e2) =
    AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
 Proof.
 simple induction e1; try intros; simpl in |- *; auto.
-rewrite AmultT_sym; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
- rewrite (H0 e2 lvar); ring.
+rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
+ rewrite (H0 e2 lvar); legacy ring.
 Qed.
 
 Lemma distrib_mult_left_correct :
- forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (distrib_mult_left e1 e2) =
    AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
 Proof.
 simple induction e1; try intros; simpl in |- *.
 rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *;
  apply AmultT_Or.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. 
-rewrite AmultT_sym;
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. 
+rewrite AmultT_comm;
  rewrite
   (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
      (interp_ExprA lvar e0));
- rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e));
- rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e0));
+ rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e));
+ rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0));
  rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
 Qed.
 
 Lemma distrib_correct :
- forall (e:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (distrib e) = interp_ExprA lvar e.
 Proof.
 simple induction e; intros; auto.
@@ -490,13 +491,13 @@ simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
  unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct.
 simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar);
  unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct;
- simpl in |- *; fold AoppT in |- *; ring.
+ simpl in |- *; fold AoppT in |- *; legacy ring.
 Qed.
 
 (**** Multiplication by the inverse product ****)
 
 Lemma mult_eq :
- forall (e1 e2 a:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e1 e2 a:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar a <> AzeroT ->
    interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) ->
    interp_ExprA lvar e1 = interp_ExprA lvar e2.
@@ -520,17 +521,17 @@ Definition multiply (e:ExprA) : ExprA :=
   end.
 
 Lemma multiply_aux_correct :
- forall (a e:ExprA) (lvar:listT (prodT AT nat)),
+ forall (a e:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (multiply_aux a e) =
    AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
 Proof.
 simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct;
  auto.
-  simpl in |- *; rewrite (H0 lvar); ring.
+  simpl in |- *; rewrite (H0 lvar); legacy ring.
 Qed.
 
 Lemma multiply_correct :
- forall (e:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (multiply e) = interp_ExprA lvar e.
 Proof.
   simple induction e; simpl in |- *; auto.
@@ -578,7 +579,7 @@ Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA :=
   end.
 
 Lemma monom_remove_correct :
- forall (e a:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e a:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar a <> AzeroT ->
    interp_ExprA lvar (monom_remove a e) =
    AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
@@ -594,8 +595,8 @@ simpl in |- *; case (eqExprA e0 (EAinv a)); intros.
 rewrite e2; simpl in |- *; fold AinvT in |- *.
 rewrite <-
  (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
-    (interp_ExprA lvar e1)); rewrite AinvT_r; [ ring | assumption ].
-simpl in |- *; rewrite H0; auto; ring.
+    (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ].
+simpl in |- *; rewrite H0; auto; legacy ring.
 simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a));
  intros; [ inversion e1 | simpl in |- *; trivial ].
 unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros.
@@ -608,7 +609,7 @@ unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros;
 Qed.
 
 Lemma monom_simplif_rem_correct :
- forall (a e:ExprA) (lvar:listT (prodT AT nat)),
+ forall (a e:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar a <> AzeroT ->
    interp_ExprA lvar (monom_simplif_rem a e) =
    AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
@@ -618,11 +619,11 @@ simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct;
 elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1);
  intros.
 rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto.
-ring.
+legacy ring.
 Qed.
 
 Lemma monom_simplif_correct :
- forall (e a:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e a:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar a <> AzeroT ->
    interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e.
 Proof.
@@ -633,7 +634,7 @@ simpl in |- *; trivial.
 Qed.
 
 Lemma inverse_correct :
- forall (e a:ExprA) (lvar:listT (prodT AT nat)),
+ forall (e a:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar a <> AzeroT ->
    interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e.
 Proof.
@@ -642,4 +643,8 @@ simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto.
 unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto.
 Qed.
 
-End Theory_of_fields.
\ No newline at end of file
+End Theory_of_fields.
+
+(* Compatibility *)
+Notation AplusT_sym := AplusT_comm (only parsing).
+Notation AmultT_sym := AmultT_comm (only parsing).
diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4
index 32adec66..dab5a45c 100644
--- a/contrib/field/field.ml4
+++ b/contrib/field/field.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: field.ml4,v 1.33.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+(* $Id: field.ml4 9273 2006-10-25 11:30:36Z barras $ *)
 
 open Names
 open Pp
@@ -21,19 +21,23 @@ open Util
 open Vernacinterp
 open Vernacexpr
 open Tacexpr
+open Mod_subst
+open Coqlib
 
 (* Interpretation of constr's *)
 let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
 
 (* Construction of constants *)
-let constant dir s = Coqlib.gen_constant "Field" ("field"::dir) s
+let constant dir s = gen_constant "Field" ("field"::dir) s
+let init_constant s = gen_constant_in_modules "Field" init_modules s
 
 (* To deal with the optional arguments *)
 let constr_of_opt a opt =
   let ac = constr_of a in
+  let ac3 = mkArrow ac (mkArrow ac ac) in
   match opt with
-  | None -> mkApp ((constant ["Field_Compl"] "Field_None"),[|ac|])
-  | Some f -> mkApp ((constant ["Field_Compl"] "Field_Some"),[|ac;constr_of f|])
+  | None -> mkApp (init_constant "None",[|ac3|])
+  | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|])
 
 (* Table of theories *)
 let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t)
@@ -43,7 +47,7 @@ let lookup env typ =
   with Not_found -> 
     errorlabstrm "field"
       (str "No field is declared for type" ++ spc() ++
-      Printer.prterm_env env typ)
+      Printer.pr_lconstr_env env typ)
 
 let _ = 
   let init () = th_tab := Gmap.empty in
@@ -82,7 +86,7 @@ let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth
       Ring.add_theory true true false a None None None aplus amult aone azero
         (Some aopp) aeq rth Quote.ConstrSet.empty
      with | UserError("Add Semi Ring",_) -> ());
-    let th = mkApp ((constant ["Field_Theory"] "Build_Field_Theory"),
+    let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"),
       [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in
     begin
       let _ = type_of (Global.env ()) Evd.empty th in ();
@@ -113,8 +117,8 @@ END
 *)
 
 (* For the translator, otherwise the code above is OK *)
-open Ppconstrnew
-let pp_minus_div_arg _prc _prt (omin,odiv) = 
+open Ppconstr
+let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = 
   if omin=None && odiv=None then mt() else
     spc() ++ str "with" ++
     pr_opt (fun c -> str "minus := " ++ _prc c) omin ++
@@ -135,7 +139,7 @@ ARGUMENT EXTEND minus_div_arg
 END
 
 VERNAC COMMAND EXTEND Field
-  [ "Add" "Field" 
+  [ "Add" "Legacy" "Field" 
       constr(a) constr(aplus) constr(amult) constr(aone)
       constr(azero) constr(aopp) constr(aeq)
       constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ]
@@ -149,8 +153,7 @@ END
 
 (* Guesses the type and calls field_gen with the right theory *)
 let field g =
-  Library.check_required_library ["Coq";"field";"Field"];
-  let ist = { lfun=[]; debug=get_debug () } in
+  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
   let typ = 
     match Hipattern.match_with_equation (pf_concl g) with
       | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t
@@ -172,7 +175,7 @@ let guess_theory env evc = function
 
 (* Guesses the type and calls Field_Term with the right theory *)
 let field_term l g =
-  Library.check_required_library ["Coq";"field";"Field"];
+  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
   let env = (pf_env g)
   and evc = (project g) in
   let th = valueIn (VConstr (guess_theory env evc l))
@@ -184,7 +187,7 @@ let field_term l g =
 
 (* Declaration of Field *)
 
-TACTIC EXTEND Field
-| [ "Field" ] -> [ field ]
-| [ "Field" ne_constr_list(l) ] -> [ field_term l ]
+TACTIC EXTEND legacy_field
+| [ "legacy" "field" ] -> [ field ]
+| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ]
 END
diff --git a/contrib/first-order/formula.ml b/contrib/first-order/formula.ml
index 49cb8e25..0be468aa 100644
--- a/contrib/first-order/formula.ml
+++ b/contrib/first-order/formula.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: formula.ml,v 1.18.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: formula.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Hipattern
 open Names
@@ -46,15 +46,14 @@ let rec nb_prod_after n c=
     | _ -> 0
 
 let construct_nhyps ind gls =
-  let env=pf_env gls in
-  let nparams = (snd (Global.lookup_inductive ind)).mind_nparams in
-  let constr_types = Inductive.arities_of_constructors (pf_env gls) ind in 
+  let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
+  let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in 
   let hyp = nb_prod_after nparams in	
     Array.map hyp constr_types
 
 (* indhyps builds the array of arrays of constructor hyps for (ind largs)*)
 let ind_hyps nevar ind largs gls= 
-  let types= Inductive.arities_of_constructors (pf_env gls) ind in 
+  let types= Inductiveops.arities_of_constructors (pf_env gls) ind in 
   let lp=Array.length types in     
   let myhyps i=
     let t1=Term.prod_applist types.(i) largs in
@@ -99,7 +98,7 @@ let rec kind_of_formula gl term =
 			let has_realargs=(n>0) in
 			let is_trivial=
 			  let is_constant c =
-			    nb_prod c = mip.mind_nparams in  
+			    nb_prod c = mib.mind_nparams in  
 			    array_exists is_constant mip.mind_nf_lc in 
 			  if Inductiveops.mis_is_recursive (ind,mib,mip) ||
 			    (has_realargs && not is_trivial)
diff --git a/contrib/first-order/formula.mli b/contrib/first-order/formula.mli
index db24f20f..8703045c 100644
--- a/contrib/first-order/formula.mli
+++ b/contrib/first-order/formula.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: formula.mli,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: formula.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Term
 open Names
diff --git a/contrib/first-order/g_ground.ml4 b/contrib/first-order/g_ground.ml4
index f85f2171..366f563b 100644
--- a/contrib/first-order/g_ground.ml4
+++ b/contrib/first-order/g_ground.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma"  i*)
 
-(* $Id: g_ground.ml4,v 1.10.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: g_ground.ml4 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Formula
 open Sequent
@@ -24,7 +24,7 @@ open Libnames
 
 (* declaring search depth as a global option *)
 
-let ground_depth=ref 5
+let ground_depth=ref 3
 
 let _=
   let gdopt=
@@ -34,14 +34,29 @@ let _=
       optread=(fun ()->Some !ground_depth); 
       optwrite=
    (function 
-	None->ground_depth:=5
+	None->ground_depth:=3
       |	Some i->ground_depth:=(max i 0))}
   in
     declare_int_option gdopt
-      
+
+let congruence_depth=ref 100
+
+let _=
+  let gdopt=
+    { optsync=true;
+      optname="Congruence Depth";
+      optkey=SecondaryTable("Congruence","Depth"); 
+      optread=(fun ()->Some !congruence_depth); 
+      optwrite=
+   (function 
+	None->congruence_depth:=0
+      |	Some i->congruence_depth:=(max i 0))}
+  in
+    declare_int_option gdopt
+
 let default_solver=(Tacinterp.interp <:tactic<auto with *>>)
-    
-let fail_solver=tclFAIL 0 "GTauto failed"
+
+let fail_solver=tclFAIL 0 (Pp.str "GTauto failed")
 		      
 type external_env=
     Ids of global_reference list
@@ -81,23 +96,32 @@ let normalize_evaluables=
 	   unfold_in_hyp (Lazy.force defined_connectives) 
 	   (Tacexpr.InHypType id)) *)
 
-TACTIC EXTEND Firstorder
-    [ "Firstorder" tactic_opt(t) "with" ne_reference_list(l) ] -> 
-      [ gen_ground_tac true (option_app eval_tactic t) (Ids l) ]
-|   [ "Firstorder" tactic_opt(t) "using" ne_preident_list(l) ] -> 
-      [ gen_ground_tac true (option_app eval_tactic t) (Bases l) ]
-|   [ "Firstorder" tactic_opt(t) ] -> 
-      [ gen_ground_tac true (option_app eval_tactic t) Void ]
+TACTIC EXTEND firstorder
+    [ "firstorder" tactic_opt(t) "with" ne_reference_list(l) ] -> 
+      [ gen_ground_tac true (option_map eval_tactic t) (Ids l) ]
+|   [ "firstorder" tactic_opt(t) "using" ne_preident_list(l) ] -> 
+      [ gen_ground_tac true (option_map eval_tactic t) (Bases l) ]
+|   [ "firstorder" tactic_opt(t) ] -> 
+      [ gen_ground_tac true (option_map eval_tactic t) Void ]
 END
 
-(* Obsolete since V8.0
-TACTIC EXTEND GTauto   
-  [ "GTauto" ] ->
-     [ gen_ground_tac false (Some fail_solver) Void ]   
+TACTIC EXTEND gintuition
+  [ "gintuition" tactic_opt(t) ] ->
+     [ gen_ground_tac false (option_map eval_tactic t) Void ]
 END
-*)
 
-TACTIC EXTEND GIntuition
-  [ "GIntuition" tactic_opt(t) ] ->
-     [ gen_ground_tac false (option_app eval_tactic t) Void ]
-END
+
+let default_declarative_automation gls = 
+  tclORELSE 
+    (Cctac.congruence_tac !congruence_depth []) 
+    (gen_ground_tac true 
+       (Some (tclTHEN
+		default_solver
+		(Cctac.congruence_tac !congruence_depth [])))
+       Void) gls
+
+
+
+let () = 
+  Decl_proof_instr.register_automation_tac default_declarative_automation
+
diff --git a/contrib/first-order/ground.ml b/contrib/first-order/ground.ml
index 23e27a3c..bccac6df 100644
--- a/contrib/first-order/ground.ml
+++ b/contrib/first-order/ground.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ground.ml,v 1.5.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: ground.ml 9537 2007-01-26 10:05:04Z corbinea $ *)
 
 open Formula
 open Sequent
@@ -45,23 +45,23 @@ let update_flags ()=
 *)
 
 let update_flags ()=
-  let predref=ref Names.KNpred.empty in
+  let predref=ref Names.Cpred.empty in
   let f coe=
     try
       let kn=destConst (Classops.get_coercion_value coe) in
-	predref:=Names.KNpred.add kn !predref
+	predref:=Names.Cpred.add kn !predref
     with Invalid_argument "destConst"-> () in
     List.iter f (Classops.coercions ());
     red_flags:=
     Closure.RedFlags.red_add_transparent 
       Closure.betaiotazeta 
-      (Names.Idpred.full,Names.KNpred.complement !predref)
+      (Names.Idpred.full,Names.Cpred.complement !predref)
 
 let ground_tac solver startseq gl=
   update_flags ();
   let rec toptac skipped seq gl=
     if Tacinterp.get_debug()=Tactic_debug.DebugOn 0
-    then Pp.msgnl (Proof_trees.pr_goal (sig_it gl));
+    then Pp.msgnl (Printer.pr_goal (sig_it gl));
     tclORELSE (axiom_tac seq.gl seq)
       begin
 	try      
@@ -78,10 +78,10 @@ let ground_tac solver startseq gl=
 		      | Rforall->
 			  let backtrack1=
 			    if !qflag then 
-			      tclFAIL 0 "reversible in 1st order mode"
+			      tclFAIL 0 (Pp.str "reversible in 1st order mode")
 			    else
 			      backtrack in
-			    forall_tac backtrack continue (re_add seq1)
+			    forall_tac backtrack1 continue (re_add seq1)
 		      | Rarrow->
 			  arrow_tac backtrack continue (re_add seq1)
 		      | Ror->
@@ -117,7 +117,8 @@ let ground_tac solver startseq gl=
 			      backtrack2 (* need special backtracking *)
   		      | Lexists ind ->
 			  if !qflag then 
-			    left_exists_tac ind hd.id continue (re_add seq1)
+			    left_exists_tac ind backtrack hd.id
+			      continue (re_add seq1)
 			  else backtrack
 		      | LA (typ,lap)->
 			  let la_tac=
diff --git a/contrib/first-order/ground.mli b/contrib/first-order/ground.mli
index cfc17e77..621f99db 100644
--- a/contrib/first-order/ground.mli
+++ b/contrib/first-order/ground.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ground.mli,v 1.1.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: ground.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 val ground_tac:     Tacmach.tactic ->
   (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
diff --git a/contrib/first-order/instances.ml b/contrib/first-order/instances.ml
index e2e9e2ef..254d7b84 100644
--- a/contrib/first-order/instances.ml
+++ b/contrib/first-order/instances.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: instances.ml,v 1.9.2.1 2004/07/16 19:30:10 herbelin Exp $ i*)
+(*i $Id: instances.ml 8654 2006-03-22 15:36:58Z msozeau $ i*)
 
 open Formula
 open Sequent
@@ -105,10 +105,10 @@ let dummy_bvid=id_of_string "x"
 
 let mk_open_instance id gl m t=
   let env=pf_env gl in
-  let evmap=Refiner.sig_sig gl in
+  let evmap=Refiner.project gl in
   let var_id=
     if id==dummy_id then dummy_bvid else
-      let typ=pf_type_of gl (constr_of_reference id) in
+      let typ=pf_type_of gl (constr_of_global id) in
 	(* since we know we will get a product, 
 	   reduction is not too expensive *)
       let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in
@@ -121,15 +121,18 @@ let mk_open_instance id gl m t=
       let nid=(fresh_id avoid var_id gl) in
 	(Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in
   let nt=it_mkLambda_or_LetIn revt (aux m []) in
-  let rawt=Detyping.detype (false,env) [] [] nt in
+  let rawt=Detyping.detype false [] [] nt in
   let rec raux n t=
     if n=0 then t else 
       match t with
 	  RLambda(loc,name,_,t0)->
 	    let t1=raux (n-1) t0 in
-	      RLambda(loc,name,RHole (dummy_loc,BinderType name),t1)
+	      RLambda(loc,name,RHole (dummy_loc,Evd.BinderType name),t1)
 	| _-> anomaly "can't happen" in
-  let ntt=Pretyping.understand evmap env (raux m rawt) in
+  let ntt=try 
+    Pretyping.Default.understand evmap env (raux m rawt)
+  with _ -> 
+    error "Untypable instance, maybe higher-order non-prenex quantification" in
     Sign.decompose_lam_n_assum m ntt
 
 (* tactics   *)
@@ -138,13 +141,13 @@ let left_instance_tac (inst,id) continue seq=
   match inst with
       Phantom dom->
 	if lookup (id,None) seq then 
-	  tclFAIL 0 "already done"
+	  tclFAIL 0 (Pp.str "already done")
 	else
 	  tclTHENS (cut dom) 
 	    [tclTHENLIST
 	       [introf;
 		(fun gls->generalize 
-		   [mkApp(constr_of_reference id,
+		   [mkApp(constr_of_global id,
 			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls);
 		introf;
 		tclSOLVE [wrap 1 false continue 
@@ -152,7 +155,7 @@ let left_instance_tac (inst,id) continue seq=
 	    tclTRY assumption]
     | Real((m,t) as c,_)->
 	if lookup (id,Some c) seq then 
-	  tclFAIL 0 "already done" 
+	  tclFAIL 0 (Pp.str "already done")
 	else 
 	  let special_generalize=
 	    if m>0 then 
@@ -160,10 +163,10 @@ let left_instance_tac (inst,id) continue seq=
 		let (rc,ot)= mk_open_instance id gl m t in
 		let gt= 
 		  it_mkLambda_or_LetIn 
-		    (mkApp(constr_of_reference id,[|ot|])) rc in
+		    (mkApp(constr_of_global id,[|ot|])) rc in
 		  generalize [gt] gl
 	    else
-	      generalize [mkApp(constr_of_reference id,[|t|])]
+	      generalize [mkApp(constr_of_global id,[|t|])]
 	  in
 	    tclTHENLIST 
 	      [special_generalize;
@@ -186,7 +189,7 @@ let right_instance_tac inst continue seq=
 	(tclTHEN (split (Rawterm.ImplicitBindings [t]))
 	   (tclSOLVE [wrap 0 true continue (deepen seq)]))
     | Real ((m,t),_) ->
-	tclFAIL 0 "not implemented ... yet"
+	tclFAIL 0 (Pp.str "not implemented ... yet")
 
 let instance_tac inst=
   if (snd inst)==dummy_id then 
diff --git a/contrib/first-order/instances.mli b/contrib/first-order/instances.mli
index 509bfc70..7667c89f 100644
--- a/contrib/first-order/instances.mli
+++ b/contrib/first-order/instances.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: instances.mli,v 1.3.2.1 2004/07/16 19:30:10 herbelin Exp $ i*)
+(*i $Id: instances.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 open Term
 open Tacmach
diff --git a/contrib/first-order/rules.ml b/contrib/first-order/rules.ml
index 7fbefa37..6c51eda3 100644
--- a/contrib/first-order/rules.ml
+++ b/contrib/first-order/rules.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rules.ml,v 1.24.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: rules.ml 8878 2006-05-30 16:44:25Z herbelin $ *)
 
 open Util
 open Names
@@ -57,18 +57,18 @@ let clear_global=function
 (* connection rules *)
 
 let axiom_tac t seq=
-  try exact_no_check (constr_of_reference (find_left t seq)) 
-  with Not_found->tclFAIL 0 "No axiom link" 
+  try exact_no_check (constr_of_global (find_left t seq)) 
+  with Not_found->tclFAIL 0 (Pp.str "No axiom link")
 
 let ll_atom_tac a backtrack id continue seq= 
   tclIFTHENELSE
     (try 
       tclTHENLIST
-	[generalize [mkApp(constr_of_reference id,
-			   [|constr_of_reference (find_left a seq)|])];
+	[generalize [mkApp(constr_of_global id,
+			   [|constr_of_global (find_left a seq)|])];
 	 clear_global id;
 	 intro]
-    with Not_found->tclFAIL 0 "No link") 
+    with Not_found->tclFAIL 0 (Pp.str "No link"))
     (wrap 1 false continue seq) backtrack 
 
 (* right connectives rules *)
@@ -92,7 +92,7 @@ let left_and_tac ind backtrack id continue seq gls=
  let n=(construct_nhyps ind gls).(0) in  
    tclIFTHENELSE
      (tclTHENLIST 
-      [simplest_elim (constr_of_reference id);
+      [simplest_elim (constr_of_global id);
        clear_global id; 
        tclDO n intro])
      (wrap n false continue seq)
@@ -106,12 +106,12 @@ let left_or_tac ind backtrack id continue seq gls=
        tclDO n intro;
        wrap n false continue seq] in
     tclIFTHENSVELSE
-      (simplest_elim (constr_of_reference id))
+      (simplest_elim (constr_of_global id))
       (Array.map f v)
       backtrack gls
 
 let left_false_tac id=
-  simplest_elim (constr_of_reference id)
+  simplest_elim (constr_of_global id)
 
 (* left arrow connective rules *)
 
@@ -127,7 +127,7 @@ let ll_ind_tac ind largs backtrack id continue seq gl=
        let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in
        let vars=Array.init p (fun j->mkRel (p-j)) in
        let capply=mkApp ((lift p cstr),vars) in
-       let head=mkApp ((lift p (constr_of_reference id)),[|capply|]) in
+       let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in
 	 Sign.it_mkLambda_or_LetIn head rc in
        let lp=Array.length rcs in
        let newhyps=list_tabulate myterm lp in
@@ -141,7 +141,7 @@ let ll_ind_tac ind largs backtrack id continue seq gl=
 let ll_arrow_tac a b c backtrack id continue seq=
   let cc=mkProd(Anonymous,a,(lift 1 b)) in
   let d=mkLambda (Anonymous,b,
-		  mkApp ((constr_of_reference id),
+		  mkApp ((constr_of_global id),
 			 [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in
     tclORELSE
       (tclTHENS (cut c)
@@ -150,7 +150,7 @@ let ll_arrow_tac a b c backtrack id continue seq=
 	     clear_global id;
 	     wrap 1 false continue seq];
 	  tclTHENS (cut cc) 
-            [exact_no_check (constr_of_reference id); 
+            [exact_no_check (constr_of_global id); 
 	     tclTHENLIST 
 	       [generalize [d];
 		clear_global id;
@@ -168,17 +168,19 @@ let forall_tac backtrack continue seq=
 	  (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq)))
 	  backtrack))
     (if !qflag then 
-       tclFAIL 0 "reversible in 1st order mode"
+       tclFAIL 0 (Pp.str "reversible in 1st order mode")
      else
        backtrack)
 
-let left_exists_tac ind id continue seq gls=
+let left_exists_tac ind backtrack id continue seq gls=
   let n=(construct_nhyps ind gls).(0) in  
-    tclTHENLIST
-      [simplest_elim (constr_of_reference id);
-       clear_global id;
-       tclDO n intro;
-       (wrap (n-1) false continue seq)] gls
+    tclIFTHENELSE
+      (simplest_elim (constr_of_global id))
+      (tclTHENLIST [clear_global id;
+                    tclDO n intro;
+                    (wrap (n-1) false continue seq)]) 
+      backtrack 
+      gls
 	
 let ll_forall_tac prod backtrack id continue seq=
   tclORELSE
@@ -187,7 +189,7 @@ let ll_forall_tac prod backtrack id continue seq=
 	  [intro;
 	   (fun gls->
 	      let id0=pf_nth_hyp_id gls 1 in
-	      let term=mkApp((constr_of_reference id),[|mkVar(id0)|]) in
+	      let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in
 		tclTHEN (generalize [term]) (clear [id0]) gls);  
 	   clear_global id;
 	   intro;
@@ -209,6 +211,6 @@ let normalize_evaluables=
   onAllClauses
     (function 
 	 None->unfold_in_concl (Lazy.force defined_connectives)
-       | Some (id,_,_)-> 
+       | Some ((_,id),_)-> 
 	   unfold_in_hyp (Lazy.force defined_connectives) 
-	   (id,[],(Tacexpr.InHypTypeOnly,ref None)))
+	   (([],id),Tacexpr.InHypTypeOnly))
diff --git a/contrib/first-order/rules.mli b/contrib/first-order/rules.mli
index eb4d81bd..3798d8d4 100644
--- a/contrib/first-order/rules.mli
+++ b/contrib/first-order/rules.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rules.mli,v 1.11.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: rules.mli 6141 2004-09-27 14:55:34Z corbinea $ *)
 
 open Term
 open Tacmach
@@ -47,7 +47,7 @@ val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking
 
 val forall_tac : seqtac with_backtracking
 
-val left_exists_tac : inductive -> lseqtac
+val left_exists_tac : inductive -> lseqtac with_backtracking
 
 val ll_forall_tac : types -> lseqtac with_backtracking 
 
diff --git a/contrib/first-order/sequent.ml b/contrib/first-order/sequent.ml
index 13215348..805700b0 100644
--- a/contrib/first-order/sequent.ml
+++ b/contrib/first-order/sequent.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sequent.ml,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: sequent.ml 7925 2006-01-24 23:20:39Z herbelin $ *)
 
 open Term
 open Util
@@ -91,8 +91,8 @@ let compare_constr_int f t1 t2 =
     | Meta m1, Meta m2 -> m1 - m2
     | Var id1, Var id2 -> Pervasives.compare id1 id2
     | Sort s1, Sort s2 -> Pervasives.compare s1 s2
-    | Cast (c1,_), _ -> f c1 t2
-    | _, Cast (c2,_) -> f t1 c2
+    | Cast (c1,_,_), _ -> f c1 t2
+    | _, Cast (c2,_,_) -> f t1 c2
     | Prod (_,t1,c1), Prod (_,t2,c2) 
     | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
 	(f =? f) t1 t2 c1 c2 
@@ -255,7 +255,7 @@ let empty_seq depth=
 
 let create_with_ref_list l depth gl=
   let f gr seq=
-    let c=constr_of_reference gr in    
+    let c=constr_of_global gr in    
     let typ=(pf_type_of gl c) in
       add_formula Hyp gr typ seq gl in
     List.fold_right f l (empty_seq depth)
@@ -269,7 +269,7 @@ let create_with_auto_hints l depth gl=
 	Res_pf (c,_) | Give_exact c
       | Res_pf_THEN_trivial_fail (c,_) ->
 	  (try 
-	     let gr=reference_of_constr c in 
+	     let gr=global_of_constr c in 
 	     let typ=(pf_type_of gl c) in
 	       seqref:=add_formula Hint gr typ !seqref gl
 	   with Not_found->())
@@ -278,7 +278,7 @@ let create_with_auto_hints l depth gl=
   let h dbname=
     let hdb=
       try
-	Util.Stringmap.find dbname !searchtable 
+	searchtable_map dbname
       with Not_found-> 
 	error ("Firstorder: "^dbname^" : No such Hint database") in
       Hint_db.iter g hdb in
@@ -289,9 +289,9 @@ let print_cmap map=
   let print_entry c l s=
     let xc=Constrextern.extern_constr false (Global.env ()) c in
       str "| " ++ 
-      Util.prlist (Ppconstr.pr_global Idset.empty) l ++ 
+      Util.prlist Printer.pr_global l ++ 
       str " : " ++
-      Ppconstr.pr_constr xc ++ 
+      Ppconstr.pr_constr_expr xc ++ 
       cut () ++ 
       s in
     msgnl (v 0 
diff --git a/contrib/first-order/sequent.mli b/contrib/first-order/sequent.mli
index df27d2ff..47fb74c7 100644
--- a/contrib/first-order/sequent.mli
+++ b/contrib/first-order/sequent.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sequent.mli,v 1.8.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: sequent.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Term
 open Util
diff --git a/contrib/first-order/unify.ml b/contrib/first-order/unify.ml
index 1186fb90..1dd13cbe 100644
--- a/contrib/first-order/unify.ml
+++ b/contrib/first-order/unify.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: unify.ml,v 1.10.2.1 2004/07/16 19:30:10 herbelin Exp $ i*)
+(*i $Id: unify.ml 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 open Util
 open Formula 
@@ -59,8 +59,8 @@ let unif t1 t2=
 		if Intset.is_empty (free_rels t) && 
 		  not (occur_term (mkMeta i) t) then
 		    bind i t else raise (UFAIL(nt1,nt2))
-	  | Cast(_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige
- 	  | _,Cast(_,_)->Queue.add (nt1,strip_outer_cast nt2) bige 
+	  | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige
+ 	  | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige 
 	  | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))->
 	      Queue.add (a,c) bige;Queue.add (pop b,pop d) bige
 	  | Case (_,pa,ca,va),Case (_,pb,cb,vb)->
diff --git a/contrib/first-order/unify.mli b/contrib/first-order/unify.mli
index dd9dbdec..9fbe3dda 100644
--- a/contrib/first-order/unify.mli
+++ b/contrib/first-order/unify.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: unify.mli,v 1.7.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+(* $Id: unify.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Term
 
diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v
index f6faf94c..1a1a5055 100644
--- a/contrib/fourier/Fourier.v
+++ b/contrib/fourier/Fourier.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier.v,v 1.4.2.1 2004/07/16 19:30:11 herbelin Exp $ *)
+(* $Id: Fourier.v 9178 2006-09-26 11:18:22Z barras $ *)
 
 (* "Fourier's method to solve linear inequations/equations systems.".*)
 
@@ -17,7 +17,7 @@ Declare ML Module "fourierR".
 Declare ML Module "field".
 
 Require Export Fourier_util.
-Require Export Field.
+Require Export LegacyField.
 Require Export DiscrR.
 
 Ltac fourier := abstract (fourierz; field; discrR).
diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v
index abcd4449..c3257b7d 100644
--- a/contrib/fourier/Fourier_util.v
+++ b/contrib/fourier/Fourier_util.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Fourier_util.v,v 1.4.2.1 2004/07/16 19:30:11 herbelin Exp $ *)
+(* $Id: Fourier_util.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Rbase.
 Comments "Lemmas used by the tactic Fourier".
diff --git a/contrib/fourier/fourier.ml b/contrib/fourier/fourier.ml
index f5763c34..ed804e94 100644
--- a/contrib/fourier/fourier.ml
+++ b/contrib/fourier/fourier.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: fourier.ml,v 1.2.16.1 2004/07/16 19:30:11 herbelin Exp $ *)
+(* $Id: fourier.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* Méthode d'élimination de Fourier *)
 (* Référence:
diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml
index 49fa35da..f9518bcb 100644
--- a/contrib/fourier/fourierR.ml
+++ b/contrib/fourier/fourierR.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: fourierR.ml,v 1.14.2.2 2004/07/19 13:28:28 herbelin Exp $ *)
+(* $Id: fourierR.ml 7760 2005-12-30 10:49:13Z herbelin $ *)
 
 
 
@@ -76,7 +76,7 @@ open Vernacexpr
 type ineq = Rlt | Rle | Rgt | Rge
 
 let string_of_R_constant kn = 
-  match Names.repr_kn kn with
+  match Names.repr_con kn with
     | MPfile dir, sec_dir, id when 
 	sec_dir = empty_dirpath && 
 	string_of_dirpath dir = "Coq.Reals.Rdefinitions" 
@@ -85,13 +85,13 @@ let string_of_R_constant kn =
 
 let rec string_of_R_constr c =
  match kind_of_term c with
-   Cast (c,t) -> string_of_R_constr c
+   Cast (c,_,_) -> string_of_R_constr c
   |Const c -> string_of_R_constant c
   | _ -> "not_of_constant"
 
 let rec rational_of_constr c =
   match kind_of_term c with
-  | Cast (c,t) -> (rational_of_constr c)
+  | Cast (c,_,_) -> (rational_of_constr c)
   | App (c,args) ->
       (match (string_of_R_constr c) with
 	 | "Ropp" -> 
@@ -122,7 +122,7 @@ let rec rational_of_constr c =
 let rec flin_of_constr c =
   try(
     match kind_of_term c with
-  | Cast (c,t) -> (flin_of_constr c)
+  | Cast (c,_,_) -> (flin_of_constr c)
   | App (c,args) ->
       (match (string_of_R_constr c) with
 	   "Ropp" -> 
@@ -221,7 +221,7 @@ let ineq1_of_constr (h,t) =
 			   hstrict=false}]
                 |_->assert false)
           | Ind (kn,i) ->
-	      if IndRef(kn,i) = Coqlib.glob_eqT then
+	      if IndRef(kn,i) = Coqlib.glob_eq then
 		           let t0= args.(0) in
                            let t1= args.(1) in
                            let t2= args.(2) in
@@ -281,7 +281,7 @@ let constant = Coqlib.gen_constant "Fourier"
 
 (* Standard library *)
 open Coqlib
-let coq_sym_eqT = lazy (build_coq_sym_eqT ())
+let coq_sym_eqT = lazy (build_coq_sym_eq ())
 let coq_False = lazy (build_coq_False ())
 let coq_not = lazy (build_coq_not ())
 let coq_eq = lazy (build_coq_eq ())
@@ -303,7 +303,7 @@ let coq_R0 = lazy (constant_real "R0")
 let coq_R1 = lazy (constant_real "R1")
 
 (* RIneq *)
-let coq_Rinv_R1 = lazy (constant ["Reals";"RIneq"] "Rinv_R1")
+let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1")
 
 (* Fourier_util *)
 let constant_fourier = constant ["fourier";"Fourier_util"]
@@ -408,7 +408,7 @@ let tac_zero_infeq_false gl (n,d) =
 	      (tac_zero_inf_pos gl (-n,d)))
 ;;
 
-let create_meta () = mkMeta(new_meta());;
+let create_meta () = mkMeta(Evarutil.new_meta());;
    
 let my_cut c gl=
      let concl = pf_concl gl in
@@ -458,7 +458,7 @@ let mkAppL a =
 
 (* Résolution d'inéquations linéaires dans R *)
 let rec fourier gl=
-    Library.check_required_library ["Coq";"fourier";"Fourier"];
+    Coqlib.check_required_library ["Coq";"fourier";"Fourier"];
     let goal = strip_outer_cast (pf_concl gl) in
     let fhyp=id_of_string "new_hyp_for_fourier" in
     (* si le but est une inéquation, on introduit son contraire,
@@ -604,7 +604,7 @@ let rec fourier gl=
                                    (Ring.polynom [])
                                    tclIDTAC;
 					  (tclTHEN (apply (get coq_sym_eqT))
-						(apply (get coq_Rinv_R1)))]
+						(apply (get coq_Rinv_1)))]
                                
 					 )
 				]));
diff --git a/contrib/fourier/g_fourier.ml4 b/contrib/fourier/g_fourier.ml4
index 05c3adbd..3a6be850 100644
--- a/contrib/fourier/g_fourier.ml4
+++ b/contrib/fourier/g_fourier.ml4
@@ -8,10 +8,10 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_fourier.ml4,v 1.1.12.1 2004/07/16 19:30:11 herbelin Exp $ *)
+(* $Id: g_fourier.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
 
 open FourierR
 
-TACTIC EXTEND Fourier
-  [ "FourierZ" (* constr_list(l) *) ] -> [ fourier (* l *) ]
+TACTIC EXTEND fourier
+  [ "fourierz" ] -> [ fourier ]
 END
diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml
new file mode 100644
index 00000000..ff4f7499
--- /dev/null
+++ b/contrib/funind/functional_principles_proofs.ml
@@ -0,0 +1,1551 @@
+open Printer
+open Util
+open Term
+open Termops 
+open Names 
+open Declarations
+open Pp
+open Entries
+open Hiddentac
+open Evd
+open Tacmach
+open Proof_type
+open Tacticals
+open Tactics
+open Indfun_common
+open Libnames
+
+let msgnl = Pp.msgnl
+  
+
+let observe strm =
+  if do_observe ()
+  then Pp.msgnl strm
+  else ()
+
+let observennl strm =
+  if do_observe ()
+  then begin Pp.msg strm;Pp.pp_flush () end
+  else ()
+
+
+
+
+let do_observe_tac s tac g =
+ try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v
+ with e ->
+   let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
+   msgnl (str "observation "++ s++str " raised exception " ++ 
+	    Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
+   raise e;;
+
+let observe_tac_stream s tac g = 
+  if do_observe ()
+  then do_observe_tac  s tac g
+  else tac g
+
+let observe_tac s tac g = observe_tac_stream (str s) tac g
+
+let tclTRYD tac = 
+  if  !Options.debug  || do_observe ()
+  then (fun g -> try (* do_observe_tac ""  *)tac g with _ -> tclIDTAC g)
+  else tac
+
+
+let list_chop ?(msg="") n l = 
+  try 
+    list_chop n l 
+  with Failure (msg') -> 
+    failwith (msg ^ msg')
+  
+
+let make_refl_eq type_of_t t  =
+  let refl_equal_term = Lazy.force refl_equal in
+  mkApp(refl_equal_term,[|type_of_t;t|])
+
+
+type pte_info = 
+    { 
+      proving_tac : (identifier list ->  Tacmach.tactic);
+      is_valid : constr -> bool
+    }
+
+type ptes_info = pte_info Idmap.t
+
+type 'a dynamic_info = 
+    { 
+      nb_rec_hyps : int;
+      rec_hyps : identifier list ; 
+      eq_hyps : identifier list;
+      info : 'a
+    }
+
+type body_info = constr dynamic_info 
+      
+
+let finish_proof dynamic_infos g = 
+  observe_tac "finish" 
+    ( h_assumption)
+    g
+	  
+
+let refine c = 
+  Tacmach.refine_no_check c
+
+let thin l = 
+  Tacmach.thin_no_check l
+  
+
+let cut_replacing id t tac :tactic= 
+  tclTHENS (cut t)
+    [ tclTHEN (thin_no_check [id]) (introduction_no_check id);
+      tac 
+    ]
+
+let intro_erasing id = tclTHEN (thin [id]) (introduction id)
+
+
+
+let rec_hyp_id = id_of_string "rec_hyp"
+
+let is_trivial_eq t = 
+  match kind_of_term t with 
+    | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> 
+	eq_constr t1 t2
+    | _ -> false 
+
+
+let rec incompatible_constructor_terms t1 t2 = 
+  let c1,arg1 = decompose_app t1 
+  and c2,arg2 = decompose_app t2 
+  in 
+  (not (eq_constr t1 t2)) &&
+    isConstruct c1 && isConstruct c2 && 
+    (
+      not (eq_constr c1 c2) || 
+	List.exists2 incompatible_constructor_terms arg1 arg2
+    )
+
+let is_incompatible_eq t = 
+  match kind_of_term t with 
+    | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> 
+	incompatible_constructor_terms t1 t2
+    | _ -> false 
+
+let change_hyp_with_using msg hyp_id t tac : tactic = 
+  fun g -> 
+    let prov_id = pf_get_new_id hyp_id g in 
+    tclTHENS
+      (observe_tac msg (forward (Some  (tclCOMPLETE tac)) (Genarg.IntroIdentifier prov_id) t))
+      [tclTHENLIST 
+      [	
+	observe_tac "change_hyp_with_using thin" (thin [hyp_id]);
+	observe_tac "change_hyp_with_using rename " (h_rename prov_id hyp_id)
+      ]] g
+
+exception TOREMOVE
+
+
+let prove_trivial_eq h_id context (type_of_term,term) = 
+  let nb_intros = List.length context in 
+  tclTHENLIST
+    [
+      tclDO nb_intros intro; (* introducing context *)
+      (fun g -> 
+	 let context_hyps =  
+	   fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) 
+	 in
+	 let context_hyps' = 
+	   (mkApp(Lazy.force refl_equal,[|type_of_term;term|]))::
+	     (List.map mkVar context_hyps)
+	 in
+	 let to_refine = applist(mkVar h_id,List.rev context_hyps') in 
+	 refine to_refine g
+      )
+    ]
+
+
+let isAppConstruct t = 
+  if isApp t 
+  then isConstruct (fst (destApp t))
+  else false 
+
+let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
+  let clos_norm_flags flgs env sigma t =
+    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
+  clos_norm_flags Closure.betaiotazeta  Environ.empty_env Evd.empty
+    
+
+let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type  = 
+  let nochange msg  = 
+    begin 
+      observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t    );
+      failwith "NoChange"; 
+    end
+  in    
+  let eq_constr = Reductionops.is_conv env sigma in 
+  if not (noccurn 1 end_of_type)
+  then nochange "dependent"; (* if end_of_type depends on this term we don't touch it  *)
+    if not (isApp t) then nochange "not an equality";
+    let f_eq,args = destApp t in
+    if not (eq_constr f_eq (Lazy.force eq)) then nochange "not an equality";
+    let t1 = args.(1) 
+    and t2 = args.(2) 
+    and t1_typ = args.(0)
+    in 
+    if not (closed0 t1) then nochange "not a closed lhs";    
+    let rec compute_substitution sub t1 t2 = 
+      observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2);
+      if isRel t2 
+      then 
+	let t2 = destRel t2  in 
+	begin 
+	  try 
+	    let t1' = Intmap.find t2 sub in 
+	    if not (eq_constr t1 t1') then nochange "twice bound variable";
+	    sub
+	  with Not_found -> 
+	    assert (closed0 t1);
+	    Intmap.add t2 t1 sub
+	end
+      else if isAppConstruct t1 && isAppConstruct t2 
+      then 
+	begin
+	  let c1,args1 = destApp t1 
+	  and c2,args2 = destApp t2 
+	  in 
+	  if not (eq_constr c1 c2) then anomaly "deconstructing equation";
+	  array_fold_left2 compute_substitution sub args1 args2
+	end
+      else 
+	if (eq_constr t1 t2) then sub else nochange "cannot solve"
+    in
+    let sub = compute_substitution Intmap.empty t1 t2 in 
+    let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) 
+    let new_end_of_type = 
+      (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 
+	 Can be safely replaced by the next comment for Ocaml >= 3.08.4
+      *)
+      let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in 
+      let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in 
+      List.fold_left (fun end_of_type (i,t)  -> lift 1 (substnl  [t] (i-1) end_of_type))
+	end_of_type_with_pop
+	sub''
+    in
+    let old_context_length = List.length context + 1 in
+    let witness_fun = 
+      mkLetIn(Anonymous,make_refl_eq t1_typ t1,t,
+	       mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i)))
+	      )
+    in
+    let new_type_of_hyp,ctxt_size,witness_fun = 
+      list_fold_left_i 
+	(fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> 
+	   try 
+	     let witness = Intmap.find i sub in 
+	     if b' <> None then anomaly "can not redefine a rel!";
+	     (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun))
+	   with Not_found  -> 
+	     (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
+	)
+	1 
+	(new_end_of_type,0,witness_fun)
+	context
+    in
+    let new_type_of_hyp = Reductionops.nf_betaiota  new_type_of_hyp in 
+    let new_ctxt,new_end_of_type = 
+      Sign.decompose_prod_n_assum ctxt_size new_type_of_hyp 
+    in 
+    let prove_new_hyp : tactic = 
+      tclTHEN
+	(tclDO ctxt_size intro)
+	(fun g ->
+	   let all_ids = pf_ids_of_hyps g in 
+	   let new_ids,_  = list_chop ctxt_size all_ids in 
+	   let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in 
+	   refine to_refine g
+	)
+    in
+    let simpl_eq_tac = 
+      change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp
+    in
+(*     observe (str "In " ++ Ppconstr.pr_id hyp_id ++  *)
+(* 	       str "removing an equation " ++ fnl ()++  *)
+(* 	       str "old_typ_of_hyp :=" ++ *)
+(* 	       Printer.pr_lconstr_env *)
+(* 	       env *)
+(* 	       (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *)
+(* 	     ++ fnl () ++ *)
+(* 	       str "new_typ_of_hyp := "++  *)
+(* 	       Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *)
+(* 	     ++ str "old context := " ++ pr_rel_context env context ++ fnl ()  *)
+(* 	     ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl ()  *)
+(* 	     ++ str "old type  := " ++ pr_lconstr end_of_type ++ fnl ()  *)
+(* 	     ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl ()  *)
+(* ); *)
+    new_ctxt,new_end_of_type,simpl_eq_tac
+
+
+let is_property ptes_info t_x full_type_of_hyp = 
+  if isApp t_x 
+  then 
+    let pte,args = destApp t_x in 
+    if isVar pte && array_for_all closed0 args 
+    then 
+      try 
+	let info = Idmap.find (destVar pte) ptes_info in 
+	info.is_valid full_type_of_hyp	  
+      with Not_found -> false 
+    else false 
+  else false 
+
+let isLetIn t = 
+  match kind_of_term t with 
+    | LetIn _ -> true 
+    | _ -> false 
+
+
+let h_reduce_with_zeta = 	 
+  h_reduce 
+    (Rawterm.Cbv
+       {Rawterm.all_flags 
+	with Rawterm.rDelta = false; 		 
+       })
+  
+
+
+let rewrite_until_var arg_num eq_ids : tactic =
+  (* tests if the declares recursive argument is neither a Constructor nor 
+     an applied Constructor since such a form for the recursive argument 
+     will break the Guard when trying to save the Lemma. 
+  *)
+  let test_var g = 
+    let _,args = destApp (pf_concl g) in 
+    not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num))
+  in
+  let rec do_rewrite eq_ids g  = 
+    if test_var g 
+    then tclIDTAC g
+    else
+      match eq_ids with 
+	| [] -> anomaly "Cannot find a way to prove recursive property";
+	| eq_id::eq_ids -> 
+	    tclTHEN 
+	      (tclTRY (Equality.rewriteRL (mkVar eq_id)))
+	      (do_rewrite eq_ids)
+	      g
+  in
+  do_rewrite eq_ids
+
+
+let rec_pte_id = id_of_string "Hrec" 
+let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = 
+  let coq_False = Coqlib.build_coq_False () in 
+  let coq_True = Coqlib.build_coq_True () in 
+  let coq_I = Coqlib.build_coq_I () in 
+  let rec scan_type  context type_of_hyp : tactic = 
+    if isLetIn type_of_hyp then 
+      let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in
+      let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in 
+      (* length of context didn't change ? *)
+      let new_context,new_typ_of_hyp = 
+	 Sign.decompose_prod_n_assum (List.length context) reduced_type_of_hyp
+      in
+        tclTHENLIST 
+	[
+	  h_reduce_with_zeta
+	    (Tacticals.onHyp hyp_id)
+	  ;
+	  scan_type new_context new_typ_of_hyp 
+	  
+	]
+    else if isProd type_of_hyp 
+    then 
+      begin 
+	let (x,t_x,t') = destProd type_of_hyp in	
+	let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in 
+	if is_property ptes_infos t_x actual_real_type_of_hyp then
+	  begin
+	    let pte,pte_args =  (destApp t_x) in 
+	    let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in 
+	    let popped_t' = pop t' in 
+	    let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in 
+	    let prove_new_type_of_hyp = 
+	      let context_length = List.length context in 
+	      tclTHENLIST
+		[ 
+		  tclDO context_length intro; 
+		  (fun g ->  
+		     let context_hyps_ids = 
+		       fst (list_chop ~msg:"rec hyp : context_hyps"
+			      context_length (pf_ids_of_hyps g))
+		     in
+		     let rec_pte_id = pf_get_new_id rec_pte_id g in 
+		     let to_refine = 
+		       applist(mkVar hyp_id,
+			       List.rev_map mkVar (rec_pte_id::context_hyps_ids)
+			      )
+		     in
+		     observe_tac "rec hyp "
+		       (tclTHENS
+		       (assert_as true (Genarg.IntroIdentifier rec_pte_id) t_x)
+		       [observe_tac "prove rec hyp" (prove_rec_hyp eq_hyps);
+			observe_tac "prove rec hyp"
+			  (refine to_refine)
+		       ])
+		       g
+		  )
+		]
+	    in
+	    tclTHENLIST 
+	      [
+		observe_tac "hyp rec" 
+		  (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp);
+		scan_type context popped_t'
+	      ]
+	  end
+	else if eq_constr t_x coq_False then 
+	  begin
+(* 	    observe (str "Removing : "++ Ppconstr.pr_id hyp_id++  *)
+(* 		       str " since it has False in its preconds " *)
+(* 		    ); *)
+	    raise TOREMOVE;  (* False -> .. useless *)
+	  end
+	else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... =  C2 ... *) 
+	else if eq_constr t_x coq_True  (* Trivial => we remove this precons *)
+	then 
+(* 	    observe (str "In "++Ppconstr.pr_id hyp_id++  *)
+(* 		       str " removing useless precond True" *)
+(* 		    );  *)
+	  let popped_t' = pop t' in
+	  let real_type_of_hyp = 
+	    it_mkProd_or_LetIn ~init:popped_t' context 
+	  in 
+	  let prove_trivial =  
+	    let nb_intro = List.length context in 
+	    tclTHENLIST [
+	      tclDO nb_intro intro;
+	      (fun g -> 
+		 let context_hyps = 
+		   fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g))
+		 in
+		 let to_refine = 
+		   applist (mkVar hyp_id,
+			    List.rev (coq_I::List.map mkVar context_hyps)
+			   )
+		 in
+		 refine to_refine g
+	      )
+	    ]
+	  in
+	  tclTHENLIST[
+	    change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp 
+	      (observe_tac "prove_trivial" prove_trivial);
+	    scan_type context popped_t'
+	  ]
+	else if is_trivial_eq t_x 
+	then (*  t_x :=  t = t   => we remove this precond *) 
+	  let popped_t' = pop t' in
+	  let real_type_of_hyp =
+	    it_mkProd_or_LetIn ~init:popped_t' context
+	  in
+	  let _,args = destApp t_x in
+	  tclTHENLIST
+	    [
+	      change_hyp_with_using
+		"prove_trivial_eq"
+		hyp_id
+		real_type_of_hyp
+		(observe_tac "prove_trivial_eq" (prove_trivial_eq hyp_id context (args.(0),args.(1))));
+	      scan_type context popped_t'
+	    ] 
+	else 
+	  begin
+	    try 
+	      let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in 
+	      tclTHEN
+		tac 
+		(scan_type new_context new_t')
+	    with Failure "NoChange" -> 
+	      (* Last thing todo : push the rel in the context and continue *) 
+	      scan_type ((x,None,t_x)::context) t'
+	  end
+      end
+    else
+      tclIDTAC
+  in 
+  try 
+    scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id]
+  with TOREMOVE -> 
+    thin [hyp_id],[]
+
+
+let clean_goal_with_heq ptes_infos continue_tac dyn_infos  = 
+  fun g -> 
+    let env = pf_env g 
+    and sigma = project g 
+    in
+    let tac,new_hyps = 
+      List.fold_left ( 
+	fun (hyps_tac,new_hyps) hyp_id ->
+	  let hyp_tac,new_hyp = 
+	    clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma 
+	  in
+	  (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps
+      )
+	(tclIDTAC,[])
+	dyn_infos.rec_hyps
+    in
+    let new_infos = 
+      { dyn_infos with 
+	  rec_hyps = new_hyps; 
+	  nb_rec_hyps  = List.length new_hyps
+      }
+    in
+    tclTHENLIST 
+      [
+	tac ;
+	observe_tac "clean_hyp_with_heq continue" (continue_tac new_infos)
+      ]
+      g    
+
+let heq_id = id_of_string "Heq"
+
+let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = 
+  fun g -> 
+    let heq_id = pf_get_new_id heq_id g in 
+    let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in
+    tclTHENLIST
+      [ 
+	(* We first introduce the variables *) 
+	tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps);
+	(* Then the equation itself *)
+	introduction_no_check heq_id;
+	(* Then the new hypothesis *) 
+	tclMAP introduction_no_check dyn_infos.rec_hyps;
+	observe_tac "after_introduction" (fun g' -> 
+	   (* We get infos on the equations introduced*)
+	   let new_term_value_eq = pf_type_of g' (mkVar heq_id) in 
+	   (* compute the new value of the body *)
+	   let new_term_value =
+	     match kind_of_term new_term_value_eq with
+	       | App(f,[| _;_;args2 |]) -> args2
+	       | _ ->
+		   observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++
+			      pr_lconstr_env (pf_env g') new_term_value_eq
+			   );
+		   anomaly "cannot compute new term value"
+	   in
+	 let fun_body =
+	   mkLambda(Anonymous,
+		    pf_type_of g' term,
+		    replace_term term (mkRel 1) dyn_infos.info
+		   )
+	 in
+	 let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in
+	 let new_infos = 
+	   {dyn_infos with 
+	      info = new_body;
+	      eq_hyps = heq_id::dyn_infos.eq_hyps
+	   }
+	 in 
+	 clean_goal_with_heq ptes_infos continue_tac new_infos  g'
+      )
+    ]
+      g
+
+
+let my_orelse tac1 tac2 g = 
+  try 
+    tac1 g 
+  with e -> 
+(*     observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *)
+    tac2 g 
+
+let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = 
+  let args = Array.of_list (List.map mkVar  args_id) in 
+  let instanciate_one_hyp hid = 
+    my_orelse
+      ( (* we instanciate the hyp if possible  *)
+	fun g -> 
+	  let prov_hid = pf_get_new_id hid g in
+	  tclTHENLIST[
+	    forward None (Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args));
+	    thin [hid];
+	    h_rename prov_hid hid
+	  ] g
+      )
+      ( (*
+	  if not then we are in a mutual function block 
+	  and this hyp is a recursive hyp on an other function.
+	  
+	  We are not supposed to use it while proving this 
+	  principle so that we can trash it 
+	  
+	*)
+	(fun g -> 
+(* 	   observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *)
+	   thin [hid] g
+	)
+      )
+  in
+  if args_id = []  
+  then 
+    tclTHENLIST [
+      tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
+      do_prove hyps
+    ]
+  else
+    tclTHENLIST
+      [
+	tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
+	tclMAP instanciate_one_hyp hyps;
+	(fun g ->  
+	   let all_g_hyps_id = 
+	     List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty
+	   in 
+	   let remaining_hyps = 
+	     List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps
+	   in
+	   do_prove remaining_hyps g
+	  )
+      ]
+
+let build_proof 
+    (interactive_proof:bool)
+    (fnames:constant list)
+    ptes_infos
+    dyn_infos
+    : tactic =
+  let rec build_proof_aux do_finalize dyn_infos : tactic = 
+    fun g -> 
+      
+(*      observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*)
+	match kind_of_term dyn_infos.info with 
+	  | Case(_,_,t,_) -> 
+	      let g_nb_prod = nb_prod (pf_concl g) in
+	      let type_of_term = pf_type_of g t in
+	      let term_eq =
+		make_refl_eq type_of_term t
+	      in
+	      tclTHENSEQ
+		[
+		  h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
+		  thin dyn_infos.rec_hyps;
+		  pattern_option [[-1],t] None;
+		  h_simplest_case t;
+		  (fun g' -> 
+		     let g'_nb_prod = nb_prod (pf_concl g') in 
+		     let nb_instanciate_partial = g'_nb_prod - g_nb_prod in 
+		     observe_tac "treat_new_case" 
+		       (treat_new_case  
+		       ptes_infos
+		       nb_instanciate_partial 
+		       (build_proof do_finalize) 
+		       t 
+		       dyn_infos)
+		       g'
+		  )
+		  
+		] g
+	  | Lambda(n,t,b) ->
+	      begin
+		match kind_of_term( pf_concl g) with
+		  | Prod _ ->
+		      tclTHEN
+			intro
+			(fun g' ->
+			   let (id,_,_) = pf_last_hyp g' in
+			   let new_term = 
+			     pf_nf_betaiota g' 
+			       (mkApp(dyn_infos.info,[|mkVar id|])) 
+			   in
+			   let new_infos = {dyn_infos with info = new_term} in
+			   let do_prove new_hyps = 
+			     build_proof do_finalize 
+			       {new_infos with
+			       	  rec_hyps = new_hyps; 
+				  nb_rec_hyps  = List.length new_hyps
+			       }
+			   in 
+			   observe_tac "Lambda" (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g'
+			     (* 			   build_proof do_finalize new_infos g' *)
+			) g
+		  | _ ->
+		      do_finalize dyn_infos g 
+	      end
+	  | Cast(t,_,_) -> 
+	      build_proof do_finalize {dyn_infos with info = t} g
+	  | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
+	      do_finalize dyn_infos g
+	  | App(_,_) ->
+	      let f,args = decompose_app dyn_infos.info in
+	      begin
+		match kind_of_term f with
+		  | App _ -> assert false (* we have collected all the app in decompose_app *)
+		  | Var _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ | Sort _ | Prod _ ->
+		      let new_infos = 
+			{ dyn_infos with 
+			    info = (f,args)
+			}
+		      in
+		      build_proof_args do_finalize new_infos  g
+		  | Const c when not (List.mem c fnames) ->
+		      let new_infos = 
+			{ dyn_infos with 
+			    info = (f,args)
+			}
+		      in
+(* 		      Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *)
+		      build_proof_args do_finalize new_infos g
+		  | Const _ ->
+		      do_finalize dyn_infos  g
+		  | Lambda _ -> 
+		      let new_term = Reductionops.nf_beta dyn_infos.info in 
+		      build_proof do_finalize {dyn_infos with info = new_term} 
+			g
+		  | LetIn _ -> 
+		      let new_infos = 
+			{ dyn_infos with info = nf_betaiotazeta dyn_infos.info } 
+		      in 
+
+		      tclTHENLIST 
+			[tclMAP 
+			   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) 
+			   dyn_infos.rec_hyps;
+			 h_reduce_with_zeta Tacticals.onConcl;
+			 build_proof do_finalize new_infos
+			] 
+			g
+		  | Cast(b,_,_) -> 
+		      build_proof do_finalize {dyn_infos with info = b } g
+		  | Case _ | Fix _ | CoFix _ ->
+		      let new_finalize dyn_infos = 
+			let new_infos = 
+			  { dyn_infos with 
+			      info = dyn_infos.info,args
+			  }
+			in 
+			build_proof_args do_finalize new_infos 
+		      in 
+		      build_proof new_finalize {dyn_infos  with info = f } g
+	      end
+	  | Fix _ | CoFix _ ->
+	      error ( "Anonymous local (co)fixpoints are not handled yet")
+
+	  | Prod _ -> error "Prod" 
+	  | LetIn _ -> 
+	      let new_infos = 
+		{ dyn_infos with 
+		    info = nf_betaiotazeta dyn_infos.info 
+		}
+	      in 
+
+	      tclTHENLIST 
+		[tclMAP 
+		   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) 
+		   dyn_infos.rec_hyps;
+		 h_reduce_with_zeta Tacticals.onConcl;
+		 build_proof do_finalize new_infos
+		] g
+	  | Rel _ -> anomaly "Free var in goal conclusion !" 
+  and build_proof do_finalize dyn_infos g =
+(*     observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *)
+     (build_proof_aux do_finalize dyn_infos) g
+  and build_proof_args do_finalize dyn_infos (* f_args'  args *) :tactic =
+    fun g ->
+      let (f_args',args) = dyn_infos.info in 
+      let tac : tactic =
+	fun g -> 
+	match args with
+	  | []  ->
+	      do_finalize {dyn_infos with info = f_args'} g 
+	  | arg::args ->
+(* 		observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
+(* 			fnl () ++  *)
+(* 			pr_goal (Tacmach.sig_it g) *)
+(* 			); *)
+	      let do_finalize dyn_infos =
+		let new_arg = dyn_infos.info in 
+		(* 		tclTRYD *)
+		(build_proof_args
+		   do_finalize
+		   {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args}
+		)
+	      in
+	      build_proof do_finalize 
+		{dyn_infos with info = arg }
+		g
+      in
+      observe_tac "build_proof_args" (tac ) g
+   in
+   let do_finish_proof dyn_infos = 
+     (* tclTRYD *) (clean_goal_with_heq 
+      ptes_infos
+      finish_proof dyn_infos)
+  in
+  observe_tac "build_proof"
+    (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) 
+
+
+
+
+
+
+
+
+
+
+
+
+(* Proof of principles from structural functions *) 
+let is_pte_type t =
+  isSort (snd (decompose_prod t))
+    
+let is_pte (_,_,t) = is_pte_type t
+
+
+
+
+type static_fix_info = 
+    {
+      idx : int;
+      name : identifier;
+      types : types;
+      offset : int;
+      nb_realargs : int;
+      body_with_param : constr;
+      num_in_block : int 
+    }
+
+
+
+let prove_rec_hyp_for_struct fix_info = 
+      (fun  eq_hyps -> tclTHEN 
+	(rewrite_until_var (fix_info.idx) eq_hyps)
+	(fun g -> 
+	   let _,pte_args = destApp (pf_concl g) in 
+	   let rec_hyp_proof = 
+	     mkApp(mkVar fix_info.name,array_get_start pte_args) 
+	   in
+	   refine rec_hyp_proof g
+	))
+
+let prove_rec_hyp fix_info  =
+  { proving_tac = prove_rec_hyp_for_struct fix_info
+  ;
+    is_valid = fun _ -> true 
+  }
+
+
+exception Not_Rec
+    
+let generalize_non_dep hyp g = 
+(*   observe (str "rec id := " ++ Ppconstr.pr_id hyp); *)
+  let hyps = [hyp] in 
+  let env = Global.env () in 
+  let hyp_typ = pf_type_of g (mkVar hyp) in 
+  let to_revert,_ = 
+    Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
+      if List.mem hyp hyps
+	or List.exists (occur_var_in_decl env hyp) keep
+	or occur_var env hyp hyp_typ
+	or Termops.is_section_variable hyp (* should be dangerous *) 
+      then (clear,decl::keep)
+      else (hyp::clear,keep))
+      ~init:([],[]) (pf_env g)
+  in
+(*   observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
+  tclTHEN 
+    (observe_tac "h_generalize" (h_generalize  (List.map mkVar to_revert) ))
+    (observe_tac "thin" (thin to_revert))
+    g
+  
+let id_of_decl (na,_,_) =  (Nameops.out_name na)
+let var_of_decl decl = mkVar (id_of_decl decl)
+let revert idl = 
+  tclTHEN 
+    (generalize (List.map mkVar idl)) 
+    (thin idl)
+
+let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
+(*   observe (str "nb_args := " ++ str (string_of_int nb_args)); *)
+(*   observe (str "nb_params := " ++ str (string_of_int nb_params)); *)
+(*   observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *)
+  let f_def = Global.lookup_constant (destConst f) in
+  let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in
+  let f_body =
+    force (out_some f_def.const_body)
+  in
+  let params,f_body_with_params = decompose_lam_n nb_params f_body in
+  let (_,num),(_,_,bodies) = destFix f_body_with_params in
+  let fnames_with_params =
+    let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in
+    let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in
+    fnames
+  in
+(*   observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *)
+(*   observe (str "body " ++ pr_lconstr bodies.(num)); *)
+  let f_body_with_params_and_other_fun  = substl fnames_with_params bodies.(num) in
+(*   observe (str "f_body_with_params_and_other_fun " ++  pr_lconstr f_body_with_params_and_other_fun); *)
+  let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in
+(*   observe (str "eq_rhs " ++  pr_lconstr eq_rhs); *)
+  let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) 
+    (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in
+  let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
+  let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in
+  let f_id = id_of_label (con_label (destConst f)) in
+  let prove_replacement =
+    tclTHENSEQ
+      [
+	tclDO (nb_params + rec_args_num + 1) intro;
+	observe_tac "" (fun g ->
+	   let rec_id = pf_nth_hyp_id g 1 in
+	   tclTHENSEQ
+	     [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id);
+	      observe_tac "h_case" (h_case(mkVar rec_id,Rawterm.NoBindings));
+	      intros_reflexivity] g
+	)
+      ]
+  in
+  Command.start_proof
+    (*i The next call to mk_equation_id is valid since we are constructing the lemma
+      Ensures by: obvious
+      i*) 
+    (mk_equation_id f_id)
+    (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
+    lemma_type
+    (fun _ _ -> ());
+  Pfedit.by (prove_replacement);
+  Command.save_named false
+
+
+
+  
+let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
+  let equation_lemma = 
+    try 
+      let finfos = find_Function_infos (destConst f) in 
+      mkConst (out_some finfos.equation_lemma)
+    with (Not_found | Failure "out_some" as e) -> 
+      let f_id = id_of_label (con_label (destConst f)) in 
+      (*i The next call to mk_equation_id is valid since we will construct the lemma
+	Ensures by: obvious
+	i*) 
+      let equation_lemma_id = (mk_equation_id f_id) in 
+      generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num;
+      let _ =
+	match e with 
+	  | Failure "out_some" -> 
+	      let finfos = find_Function_infos (destConst f) in 
+	      update_Function 
+		{finfos with
+		   equation_lemma = Some (match Nametab.locate (make_short_qualid equation_lemma_id) with
+					      ConstRef c -> c
+					    | _ -> Util.anomaly "Not a constant" 
+					 )
+		}
+	  | _ -> () 
+
+      in 
+      Tacinterp.constr_of_id (pf_env g) equation_lemma_id
+  in
+  let nb_intro_to_do = nb_prod (pf_concl g) in
+    tclTHEN
+      (tclDO nb_intro_to_do intro)
+      (
+	fun g' -> 
+	  let just_introduced = nLastHyps nb_intro_to_do g' in 
+	  let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in 
+	  tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g'
+      )
+      g
+
+let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic =
+  fun g -> 
+    let princ_type = pf_concl g in 
+    let princ_info = compute_elim_sig princ_type in 
+    let fresh_id = 
+      let avoid = ref (pf_ids_of_hyps g) in 
+      (fun na -> 
+	 let new_id = 
+	   match na with 
+	       Name id -> fresh_id !avoid (string_of_id id) 
+	     | Anonymous -> fresh_id !avoid "H"
+	 in
+	 avoid := new_id :: !avoid; 
+	 (Name new_id)
+      )
+    in
+    let fresh_decl = 
+      (fun (na,b,t) -> 
+	 (fresh_id na,b,t)
+      )
+    in
+    let princ_info : elim_scheme = 
+      { princ_info with 
+	  params = List.map fresh_decl princ_info.params;
+	  predicates = List.map fresh_decl princ_info.predicates; 
+	  branches = List.map fresh_decl princ_info.branches; 
+	  args = List.map fresh_decl princ_info.args
+      }
+    in
+    let get_body const =
+      match (Global.lookup_constant const ).const_body with
+	| Some b ->
+	     let body = force b in
+	     Tacred.cbv_norm_flags
+	       (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+	       (Global.env ())
+	       (Evd.empty)
+	       body
+	| None -> error ( "Cannot define a principle over an axiom ")
+    in
+    let fbody = get_body fnames.(fun_num) in
+    let f_ctxt,f_body = decompose_lam fbody in 
+    let f_ctxt_length = List.length f_ctxt in 
+    let diff_params = princ_info.nparams - f_ctxt_length in 
+    let full_params,princ_params,fbody_with_full_params = 
+      if diff_params > 0
+      then 
+	let princ_params,full_params = 
+	  list_chop  diff_params princ_info.params 
+	in 
+	(full_params, (* real params *)
+	 princ_params, (* the params of the principle which are not params of the function *)
+	 substl (* function instanciated with real params *)
+	   (List.map var_of_decl full_params)
+	   f_body
+	)
+      else
+	let f_ctxt_other,f_ctxt_params = 
+	  list_chop (- diff_params) f_ctxt in 
+	let f_body = compose_lam f_ctxt_other f_body in 
+	(princ_info.params, (* real params *)
+	 [],(* all params are full params *)
+	 substl (* function instanciated with real params *)
+	   (List.map var_of_decl princ_info.params)
+	   f_body
+	)
+    in
+(*     observe (str "full_params := " ++  *)
+(* 	       prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *)
+(* 	       full_params *)
+(* 	    );  *)
+(*     observe (str "princ_params := " ++  *)
+(* 	       prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *)
+(* 	       princ_params *)
+(* 	    );  *)
+(*     observe (str "fbody_with_full_params := " ++  *)
+(* 	       pr_lconstr fbody_with_full_params *)
+(* 	    );  *)
+    let all_funs_with_full_params = 
+      Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs
+    in
+    let fix_offset = List.length princ_params in 
+    let ptes_to_fix,infos = 
+      match kind_of_term fbody_with_full_params with 
+	| Fix((idxs,i),(names,typess,bodies)) -> 
+	    let bodies_with_all_params = 
+	      Array.map 
+		(fun body -> 
+		   Reductionops.nf_betaiota 
+		     (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body,
+			      List.rev_map var_of_decl princ_params))
+		)
+		bodies
+	    in
+	    let info_array = 
+	      Array.mapi 
+		(fun i types -> 
+		   let types = prod_applist types (List.rev_map var_of_decl princ_params) in
+		   { idx = idxs.(i)  - fix_offset;
+		     name = Nameops.out_name (fresh_id names.(i));
+		     types = types; 
+		     offset = fix_offset;
+		     nb_realargs = 
+		       List.length 
+			 (fst (decompose_lam bodies.(i))) - fix_offset;
+		     body_with_param = bodies_with_all_params.(i);
+		     num_in_block = i
+		   }
+		)
+		typess
+	    in
+	    let pte_to_fix,rev_info = 
+	      list_fold_left_i 
+		(fun i (acc_map,acc_info) (pte,_,_) -> 
+		   let infos = info_array.(i) in 
+		   let type_args,_ = decompose_prod infos.types in 
+		   let nargs = List.length type_args in 
+		   let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in
+		   let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in
+		   let app_f = mkApp(f,first_args) in
+		   let pte_args = (Array.to_list first_args)@[app_f] in 
+		   let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in 
+		   let body_with_param,num = 
+		     let body = get_body fnames.(i) in 
+		     let body_with_full_params = 
+		       Reductionops.nf_betaiota (
+			 applist(body,List.rev_map var_of_decl full_params))
+		     in
+		     match kind_of_term body_with_full_params with 
+		       | Fix((_,num),(_,_,bs)) -> 
+			       Reductionops.nf_betaiota
+				 (
+				   (applist
+				      (substl 
+					 (List.rev 
+					    (Array.to_list all_funs_with_full_params)) 
+					 bs.(num),
+				       List.rev_map var_of_decl princ_params))
+				 ),num
+			 | _ -> error "Not a mutual block"
+		   in
+		   let info = 
+		     {infos with 
+			types = compose_prod type_args app_pte;
+			 body_with_param = body_with_param;
+			 num_in_block = num
+		     }
+		   in 
+(* 		   observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++  *)
+(* 			      str " to " ++ Ppconstr.pr_id info.name); *)
+		   (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info)
+		   )
+		0 
+		(Idmap.empty,[]) 
+		(List.rev princ_info.predicates)
+	    in
+	    pte_to_fix,List.rev rev_info
+	| _ -> Idmap.empty,[]
+    in
+    let mk_fixes : tactic = 
+      let pre_info,infos = list_chop fun_num infos in 
+      match pre_info,infos with 
+	| [],[] -> tclIDTAC
+	| _, this_fix_info::others_infos -> 
+	    let other_fix_infos =
+	      List.map
+		(fun fi -> fi.name,fi.idx + 1 ,fi.types) 
+		(pre_info@others_infos)
+	    in 
+	    if other_fix_infos = [] 
+	    then
+	      observe_tac ("h_fix") (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
+	    else
+	      h_mutual_fix this_fix_info.name (this_fix_info.idx + 1)
+		other_fix_infos
+	| _ -> anomaly "Not a valid information"
+    in
+    let first_tac : tactic = (* every operations until fix creations *)
+      tclTHENSEQ 
+	[ observe_tac "introducing params" (intros_using (List.rev_map id_of_decl princ_info.params)); 
+	  observe_tac "introducing predictes" (intros_using (List.rev_map id_of_decl princ_info.predicates)); 
+	  observe_tac "introducing branches" (intros_using (List.rev_map id_of_decl princ_info.branches)); 
+	  observe_tac "building fixes" mk_fixes;
+	]
+    in
+    let intros_after_fixes : tactic = 
+      fun gl -> 
+	let ctxt,pte_app =  (Sign.decompose_prod_assum (pf_concl gl)) in
+	let pte,pte_args = (decompose_app pte_app) in
+	try
+	  let pte = try destVar pte with _ -> anomaly "Property is not a variable"  in 
+	  let fix_info = Idmap.find  pte ptes_to_fix in
+	  let nb_args = fix_info.nb_realargs in 
+	  tclTHENSEQ
+	    [
+	      observe_tac ("introducing args") (tclDO nb_args intro);
+	      (fun g -> (* replacement of the function by its body *)
+		 let args = nLastHyps nb_args g in 
+		 let fix_body = fix_info.body_with_param in
+(* 		 observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *)
+		 let args_id = List.map (fun (id,_,_) -> id) args in
+		 let dyn_infos = 
+		   {
+		     nb_rec_hyps = -100;
+		     rec_hyps = [];
+		     info = 
+		       Reductionops.nf_betaiota 
+			 (applist(fix_body,List.rev_map mkVar args_id));
+		     eq_hyps = []
+		   }
+		 in
+		 tclTHENSEQ
+		   [
+		     observe_tac "do_replace" 
+		       (do_replace 
+			  full_params 
+			  (fix_info.idx + List.length princ_params) 
+			  (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params))
+			  (all_funs.(fix_info.num_in_block)) 
+			  fix_info.num_in_block 
+			  all_funs
+		       );
+(* 		     observe_tac "do_replace"  *)
+(* 		       (do_replace princ_info.params fix_info.idx args_id *)
+(* 			  (List.hd (List.rev pte_args)) fix_body); *)
+		     let do_prove = 
+		       build_proof 
+			 interactive_proof
+			 (Array.to_list fnames) 
+			 (Idmap.map prove_rec_hyp ptes_to_fix)
+		     in
+		     let prove_tac branches  = 
+		       let dyn_infos = 
+			 {dyn_infos with 
+			    rec_hyps = branches;
+			    nb_rec_hyps = List.length branches
+			 }
+		       in
+		       observe_tac "cleaning" (clean_goal_with_heq
+			 (Idmap.map prove_rec_hyp ptes_to_fix) 
+			 do_prove 
+			 dyn_infos)
+		     in
+(* 		     observe (str "branches := " ++ *)
+(* 				prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++  fnl () ++ *)
+(* 			   str "args := " ++ prlist_with_sep spc Ppconstr.pr_id  args_id *)
+			   
+(* 			   ); *)
+		     observe_tac "instancing" (instanciate_hyps_with_args prove_tac 
+		       (List.rev_map id_of_decl princ_info.branches) 
+		       (List.rev args_id))
+		   ]
+		   g
+	      );
+	    ] gl
+	with Not_found ->
+	  let nb_args = min (princ_info.nargs) (List.length ctxt) in
+	  tclTHENSEQ
+	    [
+	      tclDO nb_args intro;
+	      (fun g -> (* replacement of the function by its body *)
+		 let args = nLastHyps nb_args g in 
+		 let args_id = List.map (fun (id,_,_) -> id) args in
+		 let dyn_infos = 
+		   {
+		     nb_rec_hyps = -100;
+		     rec_hyps = [];
+		     info = 
+		       Reductionops.nf_betaiota 
+			 (applist(fbody_with_full_params,
+				  (List.rev_map var_of_decl princ_params)@
+				    (List.rev_map mkVar args_id)
+				 ));
+		     eq_hyps = []
+		   }
+		 in
+		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
+		 tclTHENSEQ
+		   [unfold_in_concl [([],Names.EvalConstRef fname)];
+		    let do_prove = 
+		      build_proof 
+			interactive_proof
+			(Array.to_list fnames) 
+			 (Idmap.map prove_rec_hyp ptes_to_fix)
+		    in
+		    let prove_tac branches  = 
+		      let dyn_infos = 
+			 {dyn_infos with 
+			    rec_hyps = branches;
+			    nb_rec_hyps = List.length branches
+			 }
+		      in
+		       clean_goal_with_heq
+			 (Idmap.map prove_rec_hyp ptes_to_fix) 
+			 do_prove 
+			 dyn_infos
+		    in
+		    instanciate_hyps_with_args prove_tac 
+		       (List.rev_map id_of_decl princ_info.branches) 
+		      (List.rev args_id)
+		   ]
+		   g
+	      )
+	    ] 
+	  gl
+    in
+    tclTHEN 
+      first_tac
+      intros_after_fixes
+      g
+	    
+
+
+
+
+
+(* Proof of principles of general functions *) 
+let h_id = Recdef.h_id
+and hrec_id = Recdef.hrec_id
+and acc_inv_id = Recdef.acc_inv_id
+and ltof_ref = Recdef.ltof_ref
+and acc_rel = Recdef.acc_rel
+and well_founded = Recdef.well_founded
+and delayed_force = Recdef.delayed_force
+and h_intros = Recdef.h_intros
+and list_rewrite = Recdef.list_rewrite
+and evaluable_of_global_reference = Recdef.evaluable_of_global_reference
+
+let prove_with_tcc tcc_lemma_constr eqs : tactic =
+  match !tcc_lemma_constr with
+    | None -> anomaly "No tcc proof !!"
+    | Some lemma ->
+	fun gls ->
+	  let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in
+	  tclTHENSEQ
+	    [
+	      generalize [lemma];
+	      h_intro hid;
+	      Elim.h_decompose_and (mkVar hid);
+	      tclTRY(list_rewrite true eqs);
+	      Eauto.gen_eauto false (false,5) [] (Some [])
+	    ]
+	    gls
+
+
+let backtrack_eqs_until_hrec hrec eqs : tactic = 
+  fun gls -> 
+    let rewrite = 
+      tclFIRST (List.map Equality.rewriteRL eqs )
+    in 
+    let _,hrec_concl  = decompose_prod (pf_type_of gls (mkVar hrec)) in 
+    let f_app = array_last (snd (destApp hrec_concl)) in 
+    let f =  (fst (destApp f_app)) in 
+    let rec backtrack : tactic = 
+      fun g -> 
+	let f_app = array_last (snd (destApp (pf_concl g))) in 
+	match kind_of_term f_app with 
+	  | App(f',_) when eq_constr f' f -> tclIDTAC g
+	  | _ -> tclTHEN rewrite backtrack g
+    in
+    backtrack gls
+
+    
+    
+  
+
+let new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_constr eqs : tactic = 
+  match !tcc_lemma_constr with 
+    | None -> tclIDTAC_MESSAGE (str "No tcc proof !!")
+    | Some lemma -> 
+	fun gls ->
+	  let hid = next_global_ident_away true Recdef.h_id (pf_ids_of_hyps gls) in 
+	    (tclTHENSEQ 
+	    [
+	      generalize [lemma];
+	      h_intro hid;
+	      Elim.h_decompose_and (mkVar hid); 
+	      backtrack_eqs_until_hrec hrec eqs;
+	      observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" )
+		(tclTHENS  (* We must have exactly ONE subgoal !*)
+		   (apply (mkVar hrec))
+		   [ tclTHENSEQ 
+		       [
+			 thin [hrec];
+			 apply (Lazy.force acc_inv);
+			 (fun g -> 
+			    if is_mes 
+			    then 
+			      unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] g 
+			    else tclIDTAC g
+			 );
+			 observe_tac "rew_and_finish"
+			   (tclTHEN 
+			      (tclTRY(Recdef.list_rewrite true eqs))
+			      (observe_tac "finishing"  (tclCOMPLETE (Eauto.gen_eauto false (false,5) [] (Some [])))))
+		       ]
+		])
+	    ])
+	    gls
+
+
+let is_valid_hypothesis predicates_name =
+  let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in
+  let is_pte typ =
+    if isApp typ
+    then
+      let pte,_ = destApp typ in
+      if isVar pte
+      then Idset.mem (destVar pte) predicates_name
+      else false
+    else false
+  in
+  let rec is_valid_hypothesis typ =
+    is_pte typ ||
+      match kind_of_term typ with 
+	| Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ'
+	| _ -> false 
+  in
+  is_valid_hypothesis 
+
+let prove_principle_for_gen
+    (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
+    rec_arg_num rec_arg_type relation gl = 
+  let princ_type = pf_concl gl in 
+  let princ_info = compute_elim_sig princ_type in 
+  let fresh_id = 
+    let avoid = ref (pf_ids_of_hyps gl) in 
+    fun na -> 
+      let new_id = 
+	  match na with 
+	    | Name id -> fresh_id !avoid (string_of_id id) 
+	    | Anonymous -> fresh_id !avoid "H" 
+      in
+      avoid := new_id :: !avoid;
+      Name new_id
+  in
+  let fresh_decl (na,b,t) = (fresh_id na,b,t) in
+  let princ_info : elim_scheme = 
+    { princ_info with 
+	params = List.map fresh_decl princ_info.params;
+	predicates = List.map fresh_decl princ_info.predicates; 
+	branches = List.map fresh_decl princ_info.branches; 
+	args = List.map fresh_decl princ_info.args
+    }
+  in
+  let wf_tac = 
+    if is_mes 
+    then 
+      (fun b -> Recdef.tclUSER_if_not_mes b None)
+    else fun _ -> prove_with_tcc tcc_lemma_ref []
+  in
+  let real_rec_arg_num = rec_arg_num - princ_info.nparams in 
+  let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in 
+  observe (
+    str "princ_type := " ++ pr_lconstr  princ_type ++ fnl () ++
+    str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ 
+      str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ 
+    str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ 
+	     str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++
+	     str "npost_rec_arg := " ++ int npost_rec_arg );
+  let (post_rec_arg,pre_rec_arg) = 
+    Util.list_chop npost_rec_arg princ_info.args
+  in
+  let rec_arg_id = 
+    match List.rev post_rec_arg with 
+      | (Name id,_,_)::_ -> id 
+      | _ -> assert false 
+  in
+  observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id));
+  let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in 
+  let relation = substl subst_constrs relation in 
+  let input_type = substl subst_constrs rec_arg_type in 
+  let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in 
+  let acc_rec_arg_id = 
+    Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id)))))
+  in 
+  let revert l = 
+    tclTHEN (h_generalize (List.map mkVar l)) (clear l) 
+  in
+  let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in 
+  let prove_rec_arg_acc g = 
+      (observe_tac "prove_rec_arg_acc" 
+	 (tclCOMPLETE
+	    (tclTHEN
+	       (forward 
+		  (Some ((fun g -> observe_tac "prove wf" (tclCOMPLETE (wf_tac is_mes)) g)))
+		  (Genarg.IntroIdentifier wf_thm_id)
+		  (mkApp (delayed_force well_founded,[|input_type;relation|])))
+	       (
+		 observe_tac 
+		   "apply wf_thm" 
+		   (h_apply ((mkApp(mkVar wf_thm_id,
+				    [|mkVar rec_arg_id |])),Rawterm.NoBindings)
+		   )
+	       )
+	    )
+	 )
+      )
+      g
+  in
+  let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
+  tclTHENSEQ
+    [ 
+      h_intros 
+	(List.rev_map (fun (na,_,_) -> Nameops.out_name na) 
+	   (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
+	);
+      observe_tac "" (forward
+	 (Some (prove_rec_arg_acc))
+	 (Genarg.IntroIdentifier acc_rec_arg_id)
+ 	 (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))
+      );
+      observe_tac "reverting" (revert (List.rev (acc_rec_arg_id::args_ids)));
+      observe_tac "h_fix" (h_fix (Some fix_id) (npost_rec_arg + 1)); 
+      h_intros (List.rev (acc_rec_arg_id::args_ids));
+      Equality.rewriteLR (mkConst eq_ref);
+      observe_tac "finish" (fun gl' -> 
+	 let body = 
+	   let _,args = destApp (pf_concl gl') in 
+	   array_last args
+	 in
+	 let body_info rec_hyps = 
+	   {
+	     nb_rec_hyps = List.length rec_hyps;
+	     rec_hyps = rec_hyps;
+	     eq_hyps = [];
+	     info = body
+	   }
+	 in 
+	 let acc_inv = 
+	   lazy (
+	     mkApp (
+	       delayed_force acc_inv_id,
+	       [|input_type;relation;mkVar rec_arg_id|]
+	     )
+	   )
+	 in
+	 let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar  acc_rec_arg_id|])) in
+	 let predicates_names = 
+	   List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates
+	 in
+	 let pte_info = 
+	   { proving_tac =
+	       (fun eqs -> 
+		  observe_tac "new_prove_with_tcc" 
+		    (new_prove_with_tcc 
+		       is_mes acc_inv fix_id tcc_lemma_ref (List.map mkVar eqs)
+		    )
+	       );
+	     is_valid = is_valid_hypothesis predicates_names
+	   }
+	 in
+	 let ptes_info : pte_info Idmap.t = 
+	   List.fold_left
+	     (fun map pte_id -> 
+		Idmap.add pte_id 
+		  pte_info			       
+		  map
+	     )
+	     Idmap.empty
+	     predicates_names
+	 in
+	 let make_proof rec_hyps = 
+	   build_proof 
+	     false 
+	     [f_ref]
+	     ptes_info
+	     (body_info rec_hyps)
+	 in
+	 observe_tac "instanciate_hyps_with_args" 
+	   (instanciate_hyps_with_args 
+	      make_proof
+	      (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches)
+	      (List.rev args_ids)
+	   )
+	   gl'
+      )
+			   
+    ]
+    gl    
+
+
+
+
+
+
+
+
diff --git a/contrib/funind/functional_principles_proofs.mli b/contrib/funind/functional_principles_proofs.mli
new file mode 100644
index 00000000..62eb528e
--- /dev/null
+++ b/contrib/funind/functional_principles_proofs.mli
@@ -0,0 +1,19 @@
+open Names
+open Term
+
+val prove_princ_for_struct :
+  bool ->
+  int -> constant array -> constr array -> int -> Tacmach.tactic
+
+
+val prove_principle_for_gen : 
+  constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *)
+  constr option ref -> (* a pointer to the obligation proofs lemma *)
+  bool -> (* is that function uses measure *)
+  int -> (* the number of recursive argument *) 
+  types -> (* the type of the recursive argument *)
+  constr -> (* the wf relation used to prove the function *)
+  Tacmach.tactic
+
+
+(* val is_pte  : rel_declaration -> bool  *)
diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml
new file mode 100644
index 00000000..8ad2e72b
--- /dev/null
+++ b/contrib/funind/functional_principles_types.ml
@@ -0,0 +1,704 @@
+open Printer
+open Util
+open Term
+open Termops 
+open Names 
+open Declarations
+open Pp
+open Entries
+open Hiddentac
+open Evd
+open Tacmach
+open Proof_type
+open Tacticals
+open Tactics
+open Indfun_common
+open Functional_principles_proofs
+
+exception Toberemoved_with_rel of int*constr
+exception Toberemoved
+
+
+let pr_elim_scheme el = 
+  let env = Global.env () in 
+  let msg = str "params := " ++ Printer.pr_rel_context env el.params in 
+  let env = Environ.push_rel_context el.params env in 
+  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in 
+  let env = Environ.push_rel_context el.predicates env in 
+  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in 
+  let env = Environ.push_rel_context el.branches env in 
+  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in 
+  let env = Environ.push_rel_context el.args env in 
+  msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
+
+
+let observe s = 
+  if do_observe () 
+  then Pp.msgnl s 
+
+
+let pr_elim_scheme el = 
+  let env = Global.env () in 
+  let msg = str "params := " ++ Printer.pr_rel_context env el.params in 
+  let env = Environ.push_rel_context el.params env in 
+  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in 
+  let env = Environ.push_rel_context el.predicates env in 
+  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in 
+  let env = Environ.push_rel_context el.branches env in 
+  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in 
+  let env = Environ.push_rel_context el.args env in 
+  msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
+
+
+let observe s = 
+  if do_observe () 
+  then Pp.msgnl s 
+
+(* 
+   Transform an inductive induction principle into 
+   a functional one
+*)  
+let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
+  let princ_type_info = compute_elim_sig princ_type in 
+  let env = Global.env () in 
+  let env_with_params = Environ.push_rel_context princ_type_info.params env in
+  let tbl = Hashtbl.create 792 in
+  let rec change_predicates_names (avoid:identifier list) (predicates:Sign.rel_context)  : Sign.rel_context = 
+    match predicates with 
+    | [] -> []
+    |(Name x,v,t)::predicates -> 
+       let id =  Nameops.next_ident_away x avoid in 
+       Hashtbl.add tbl id x;
+       (Name id,v,t)::(change_predicates_names (id::avoid) predicates)
+    | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder "
+  in
+  let avoid = (Termops.ids_of_context env_with_params ) in
+  let princ_type_info = 
+    { princ_type_info with
+	predicates = change_predicates_names avoid princ_type_info.predicates
+    }
+  in 
+(*   observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *)
+(*   observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *)
+  let change_predicate_sort i (x,_,t) = 
+    let new_sort = sorts.(i) in
+    let args,_ = decompose_prod t in 
+    let real_args = 
+      if princ_type_info.indarg_in_concl 
+      then List.tl args 
+      else args
+    in
+    Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) 
+  in
+  let new_predicates = 
+    list_map_i
+      change_predicate_sort 
+      0
+      princ_type_info.predicates
+  in
+  let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in
+  let rel_as_kn = 
+    fst (match princ_type_info.indref with
+	   | Some (Libnames.IndRef ind) -> ind 
+	   | _ -> error "Not a valid predicate"
+	)
+  in
+  let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
+  let is_pte = 
+    let set = List.fold_right Idset.add ptes_vars Idset.empty in 
+    fun t -> 
+      match kind_of_term t with 
+	| Var id -> Idset.mem id set 
+	| _ -> false 
+  in
+  let pre_princ = 
+    it_mkProd_or_LetIn 
+      ~init:
+      (it_mkProd_or_LetIn 
+	 ~init:(option_fold_right
+			   mkProd_or_LetIn
+			   princ_type_info.indarg
+			   princ_type_info.concl
+			)
+	 princ_type_info.args
+      )
+      princ_type_info.branches
+  in
+  let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in
+  let is_dom c =
+    match kind_of_term c with
+      | Ind((u,_)) -> u = rel_as_kn
+      | Construct((u,_),_) -> u = rel_as_kn
+      | _ -> false
+  in
+  let get_fun_num c =
+    match kind_of_term c with
+      | Ind(_,num) -> num
+      | Construct((_,num),_) -> num
+      | _ -> assert false
+  in
+  let dummy_var = mkVar (id_of_string "________") in
+  let mk_replacement c i args =
+    let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in 
+(*     observe (str "replacing " ++ pr_lconstr c ++ str " by "  ++ pr_lconstr res); *)
+    res
+  in
+  let rec has_dummy_var t  =
+    fold_constr
+      (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t))
+      false
+      t
+  in
+  let rec compute_new_princ_type remove env pre_princ : types*(constr list) =
+    let (new_princ_type,_) as res =
+      match kind_of_term pre_princ with
+	| Rel n ->
+	    begin
+	      try match Environ.lookup_rel n env with
+		| _,_,t when is_dom t -> raise Toberemoved
+		| _ -> pre_princ,[] with Not_found -> assert false
+	    end
+	| Prod(x,t,b) ->
+	    compute_new_princ_type_for_binder remove mkProd env x t b
+	| Lambda(x,t,b) ->
+	    compute_new_princ_type_for_binder  remove mkLambda env x t b
+	| Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved
+	| App(f,args) when is_dom f ->
+	    let var_to_be_removed = destRel (array_last args) in
+	    let num = get_fun_num f in
+	    raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args))
+	| App(f,args) ->
+	    let args = 
+	      if is_pte f && remove 
+	      then array_get_start args 
+	      else args 
+	    in
+	    let new_args,binders_to_remove =
+	      Array.fold_right (compute_new_princ_type_with_acc remove env)
+		args
+		([],[])
+	    in
+	    let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in
+	    applist(new_f, new_args),
+	    list_union_eq eq_constr binders_to_remove_from_f binders_to_remove
+	| LetIn(x,v,t,b) ->
+	    compute_new_princ_type_for_letin remove env x v t b
+	| _ -> pre_princ,[]
+    in
+(*     let _ = match kind_of_term pre_princ with *)
+(* 	| Prod _ -> *)
+(* 	    observe(str "compute_new_princ_type for "++ *)
+(* 	      pr_lconstr_env env pre_princ ++ *)
+(* 	      str" is "++ *)
+(* 	      pr_lconstr_env env new_princ_type ++ fnl ()) *)
+(* 	| _ -> () in *)
+    res
+	
+  and compute_new_princ_type_for_binder remove bind_fun env x t b =
+    begin
+      try
+	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
+	let new_x : name = get_name (ids_of_context env) x in
+	let new_env = Environ.push_rel (x,None,t) env in
+	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
+	 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
+	 then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
+	 else
+	   (
+	     bind_fun(new_x,new_t,new_b),
+	     list_union_eq
+	       eq_constr
+	       binders_to_remove_from_t
+	       (List.map pop binders_to_remove_from_b)
+	   )
+
+       with
+	 | Toberemoved ->
+(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
+	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b)  in
+	    new_b, List.map pop binders_to_remove_from_b
+	| Toberemoved_with_rel (n,c) ->
+(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
+	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b)  in
+	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b)
+    end
+  and compute_new_princ_type_for_letin remove env x v t b =
+    begin
+      try
+	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
+	let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in
+	let new_x : name = get_name (ids_of_context env) x in
+	let new_env = Environ.push_rel (x,Some v,t) env in
+	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
+	if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
+	then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
+	else
+	  (
+	    mkLetIn(new_x,new_v,new_t,new_b),
+	    list_union_eq
+	      eq_constr
+	      (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v)
+	      (List.map pop binders_to_remove_from_b)
+	  )
+	
+      with
+	| Toberemoved ->
+(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
+	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b)  in
+	    new_b, List.map pop binders_to_remove_from_b
+	| Toberemoved_with_rel (n,c) ->
+(* 	    observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
+	    let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b)  in
+	    new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b)
+    end
+  and  compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc)  =
+    let new_e,to_remove_from_e = compute_new_princ_type remove env e
+    in
+    new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc
+  in
+(*   observe (str "Computing new principe from " ++ pr_lconstr_env  env_with_params_and_predicates pre_princ); *)
+  let pre_res,_ = 
+    compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ 
+  in 
+  let pre_res = 
+    replace_vars 
+      (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
+      (lift (List.length ptes_vars) pre_res)
+  in
+  it_mkProd_or_LetIn  	 
+    ~init:(it_mkProd_or_LetIn 
+	     ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) 
+			      new_predicates)
+	  )
+    princ_type_info.params
+    
+  
+
+let change_property_sort toSort princ princName = 
+  let princ_info = compute_elim_sig princ in 
+  let change_sort_in_predicate (x,v,t) = 
+    (x,None,
+     let args,_ = decompose_prod t in 
+     compose_prod args (mkSort toSort)
+    )
+  in 
+  let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in 
+  let init = 
+    let nargs =  (princ_info.nparams + (List.length  princ_info.predicates)) in 
+    mkApp(princName_as_constr,
+	  Array.init nargs
+	    (fun i -> mkRel (nargs - i )))
+  in
+  it_mkLambda_or_LetIn
+    ~init: 
+    (it_mkLambda_or_LetIn ~init 
+       (List.map change_sort_in_predicate princ_info.predicates)
+    )
+    princ_info.params
+    
+
+let pp_dur time time' = 
+  str (string_of_float (System.time_difference time time'))
+
+(* let qed () = save_named true  *)
+let defined () = 
+  try 
+    Command.save_named false 
+  with 
+    | UserError("extract_proof",msg) ->
+	Util.errorlabstrm
+	  "defined"
+	  ((try
+	      str "On goal : " ++ fnl () ++  pr_open_subgoals () ++ fnl ()
+	    with _ -> mt ()
+	   ) ++msg)
+    | e -> raise e
+
+
+
+let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
+  (* First we get the type of the old graph principle *)
+  let mutr_nparams = (compute_elim_sig old_princ_type).nparams in 
+  (*   let time1 = System.get_time ()  in *)
+  let new_principle_type =
+    compute_new_princ_type_from_rel
+      (Array.map mkConst funs)
+      sorts
+      old_princ_type
+  in
+  (*    let time2 = System.get_time ()  in *)
+  (*    Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *)
+  (*    observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *)
+  let new_princ_name =
+    next_global_ident_away true (id_of_string "___________princ_________") []
+  in
+  begin
+    Command.start_proof
+      new_princ_name
+      (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
+      new_principle_type
+      (hook new_principle_type)
+    ;
+    (*       let _tim1 = System.get_time ()  in *)
+    Pfedit.by  (proof_tac (Array.map mkConst funs) mutr_nparams);
+    (*       let _tim2 =  System.get_time ()  in *)
+    (* 	begin *)
+    (* 	  let dur1 = System.time_difference tim1 tim2 in *)
+    (* 	  Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
+    (* 	end; *)
+    get_proof_clean true 
+  end
+
+
+
+let generate_functional_principle
+    interactive_proof
+    old_princ_type sorts new_princ_name funs i proof_tac
+    =
+  try 
+  let f = funs.(i) in
+  let type_sort = Termops.new_sort_in_family InType in
+  let new_sorts =
+    match sorts with
+      | None -> Array.make (Array.length funs) (type_sort)
+      | Some a -> a
+  in
+  let base_new_princ_name,new_princ_name =
+    match new_princ_name with
+      | Some (id) -> id,id
+      | None ->
+	  let id_of_f = id_of_label (con_label f) in
+	  id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort)
+  in
+  let names = ref [new_princ_name] in
+  let hook new_principle_type _ _  =
+    if sorts = None
+    then
+      (*     let id_of_f = id_of_label (con_label f) in *)
+      let register_with_sort fam_sort =
+	let s = Termops.new_sort_in_family fam_sort in
+	let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
+	let value = change_property_sort s new_principle_type new_princ_name in
+	(*       Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
+	let ce =
+	  { const_entry_body = value;
+	    const_entry_type = None;
+	    const_entry_opaque = false;
+	    const_entry_boxed = Options.boxed_definitions()
+	  }
+	in
+	ignore(
+	  Declare.declare_constant
+	    name
+	    (Entries.DefinitionEntry ce,
+	     Decl_kinds.IsDefinition (Decl_kinds.Scheme)
+	    )
+	);
+	Options.if_verbose 
+	  (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) 
+	  name;
+	names := name :: !names
+      in
+      register_with_sort InProp;
+      register_with_sort InSet
+  in
+  let (id,(entry,g_kind,hook)) =
+    build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook 
+  in
+  (* Pr  1278 :
+     Don't forget to close the goal if an error is raised !!!!
+  *) 
+  save false new_princ_name entry g_kind hook
+  with e -> 
+    begin
+      begin 
+	try 
+	  let id = Pfedit.get_current_proof_name () in 
+	  let s = string_of_id id in 
+	  let n = String.length "___________princ_________" in
+	  if String.length s >= n 
+	  then if String.sub s 0 n = "___________princ_________" 
+	  then Pfedit.delete_current_proof ()
+	  else ()
+	  else ()
+	with _ -> ()
+      end;
+      raise (Defining_principle e)
+    end
+(*   defined  () *)
+
+
+exception Not_Rec
+
+let get_funs_constant mp dp = 
+  let rec get_funs_constant const e : (Names.constant*int) array = 
+    match kind_of_term (snd (decompose_lam e)) with 
+      | Fix((_,(na,_,_))) -> 
+	  Array.mapi 
+	    (fun i na -> 
+	       match na with 
+		 | Name id -> 
+		     let const = make_con mp dp (label_of_id id) in 
+		     const,i
+		 | Anonymous -> 
+		     anomaly "Anonymous fix" 
+	    )
+	    na
+      | _ -> [|const,0|]
+  in
+  function const -> 
+    let find_constant_body const = 
+      match (Global.lookup_constant const ).const_body with
+	| Some b ->
+	    let body = force b in
+	    let body = Tacred.cbv_norm_flags
+	      (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+	      (Global.env ())
+	      (Evd.empty)
+	      body
+	    in
+	    body
+	| None -> error ( "Cannot define a principle over an axiom ")
+    in
+    let f = find_constant_body const in
+    let l_const = get_funs_constant const f in 
+    (* 
+       We need to check that all the functions found are in the same block 
+       to prevent Reset stange thing
+    *) 
+    let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in 
+    let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in 
+    (* all the paremeter must be equal*) 
+    let _check_params = 
+      let first_params = List.hd l_params  in 
+      List.iter 
+	(fun params -> 
+	   if not ((=) first_params params) 
+	   then error "Not a mutal recursive block"
+	)
+	l_params
+    in
+    (* The bodies has to be very similar *) 
+    let _check_bodies = 
+      try 
+	let extract_info is_first body = 
+	  match kind_of_term body with 
+	    | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca)
+	    | _ -> 
+		if is_first && (List.length l_bodies = 1) 
+		then raise Not_Rec
+		else error "Not a mutal recursive block"
+	in
+	let first_infos = extract_info true (List.hd l_bodies) in 
+	let check body  = (* Hope this is correct *)
+	  if not (first_infos = (extract_info false body)) 
+	  then  error "Not a mutal recursive block"
+	in 
+	List.iter check l_bodies
+      with Not_Rec -> ()
+    in
+    l_const
+
+exception No_graph_found 
+exception Found_type of int 
+
+let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = 
+  let env = Global.env () 
+  and sigma = Evd.empty in
+  let funs = List.map fst fas in 
+  let first_fun = List.hd funs in 
+
+
+  let funs_mp,funs_dp,_ = Names.repr_con first_fun in
+  let first_fun_kn = 
+    try 
+      fst (find_Function_infos  first_fun).graph_ind 
+    with Not_found -> raise No_graph_found 
+  in
+  let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
+  let this_block_funs = Array.map fst this_block_funs_indexes in 
+  let prop_sort = InProp in
+  let funs_indexes = 
+    let this_block_funs_indexes = Array.to_list this_block_funs_indexes in 
+    List.map
+      (function const -> List.assoc const this_block_funs_indexes)
+      funs
+  in
+  let ind_list = 
+    List.map 
+      (fun (idx) -> 
+	 let ind = first_fun_kn,idx in 
+	 let (mib,mip) = Global.lookup_inductive ind in
+	 ind,mib,mip,true,prop_sort
+      )
+      funs_indexes
+  in
+  let l_schemes = 
+    List.map
+      (Typing.type_of env sigma) 
+      (Indrec.build_mutual_indrec env sigma ind_list)
+  in 
+  let i = ref (-1) in
+  let sorts = 
+    List.rev_map (fun (_,x) -> 
+		Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
+	     ) 
+      fas 
+  in
+  (* We create the first priciple by tactic *)
+  let first_type,other_princ_types = 
+    match l_schemes with 
+	s::l_schemes -> s,l_schemes
+      | _ -> anomaly ""
+  in
+  let (_,(const,_,_)) = 
+    build_functional_principle false
+      first_type
+      (Array.of_list sorts)
+      this_block_funs
+      0
+      (prove_princ_for_struct false 0 (Array.of_list funs))
+      (fun _ _ _ -> ())
+  in      
+  incr i;
+  (* The others are just deduced *)
+  if other_princ_types = [] 
+  then
+    [const]
+  else
+    let other_fun_princ_types = 
+      let funs = Array.map mkConst this_block_funs in 
+      let sorts = Array.of_list sorts in 
+      List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types
+    in
+    let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in 
+    let ctxt,fix = Sign.decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
+    let (idxs,_),(_,ta,_ as decl) = destFix fix in 
+    let other_result = 
+      List.map (* we can now compute the other principles *)
+	(fun scheme_type -> 
+	   incr i;
+	   observe (Printer.pr_lconstr scheme_type);
+	   let type_concl = snd (Sign.decompose_prod_assum scheme_type) in 
+	   let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in 
+	   let f = fst (decompose_app applied_f) in
+	   try (* we search the number of the function in the fix block (name of the function) *)
+	     Array.iteri 
+	     (fun j t -> 
+		let t =  snd (Sign.decompose_prod_assum t) in 
+		let applied_g = List.hd (List.rev (snd (decompose_app t))) in 
+		let g = fst (decompose_app applied_g) in
+		if eq_constr f g
+		then raise (Found_type j); 
+		observe (Printer.pr_lconstr f ++ str " <> " ++
+			   Printer.pr_lconstr g)
+		  
+	     )
+	     ta;
+	   (* If we reach this point, the two principle are not mutually recursive 
+	      We fall back to the previous method 
+	   *)
+	     let (_,(const,_,_)) = 
+	       build_functional_principle
+		 false 
+		 (List.nth other_princ_types (!i - 1))
+		 (Array.of_list sorts)
+		 this_block_funs
+		 !i
+		 (prove_princ_for_struct false !i (Array.of_list funs))
+		 (fun _ _ _ -> ())
+	     in 
+	     const
+	 with Found_type i -> 
+	   let princ_body = 
+	     Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt
+	   in 
+	   {const with 
+	      Entries.const_entry_body = princ_body; 
+	      Entries.const_entry_type = Some scheme_type
+	   }
+      )
+      other_fun_princ_types
+    in
+    const::other_result
+
+let build_scheme fas = 
+  let bodies_types = 
+    make_scheme 
+      (List.map 
+	 (fun (_,f,sort) -> 
+	    let f_as_constant =
+	      try
+		match Nametab.global f with 
+		  | Libnames.ConstRef c -> c 
+		  | _ -> Util.error "Functional Scheme can only be used with functions"
+	      with Not_found ->
+	      	Util.error ("Cannot find "^ Libnames.string_of_reference f)
+	    in
+	    (f_as_constant,sort)
+	 ) 
+	 fas
+      ) 
+  in 
+  List.iter2 
+    (fun (princ_id,_,_) def_entry -> 
+       ignore (Declare.declare_constant 
+		 princ_id 
+		 (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
+       Options.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
+    )
+    fas
+    bodies_types
+  
+
+
+let build_case_scheme fa = 
+  let env = Global.env () 
+  and sigma = Evd.empty in
+(*   let id_to_constr id =  *)
+(*     Tacinterp.constr_of_id env  id *)
+(*   in  *)
+  let funs =  (fun (_,f,_) ->  
+		 try Libnames.constr_of_global (Nametab.global f)
+		 with Not_found -> 
+		   Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in 
+  let first_fun = destConst  funs in 
+
+  let funs_mp,funs_dp,_ = Names.repr_con first_fun in
+  let first_fun_kn = try fst (find_Function_infos  first_fun).graph_ind with Not_found -> raise No_graph_found in
+
+
+
+  let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
+  let this_block_funs = Array.map fst this_block_funs_indexes in 
+  let prop_sort = InProp in
+  let funs_indexes = 
+    let this_block_funs_indexes = Array.to_list this_block_funs_indexes in 
+    List.assoc (destConst funs) this_block_funs_indexes
+  in
+  let ind_fun = 
+	 let ind = first_fun_kn,funs_indexes in 
+	 ind,prop_sort
+  in
+  let scheme_type =  (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf)  ind_fun) in 
+  let sorts =
+    (fun (_,_,x) ->
+       Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
+    )
+      fa
+  in
+  let princ_name =  (fun (x,_,_) -> x) fa in
+  let _ = 
+(*     observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *)
+(* 	       pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *)
+(* 	    ); *)
+    generate_functional_principle
+      false
+      scheme_type
+      (Some ([|sorts|]))
+      (Some princ_name)
+      this_block_funs
+      0
+      (prove_princ_for_struct false 0 [|destConst funs|])
+  in
+  ()
diff --git a/contrib/funind/functional_principles_types.mli b/contrib/funind/functional_principles_types.mli
new file mode 100644
index 00000000..cf28c6e6
--- /dev/null
+++ b/contrib/funind/functional_principles_types.mli
@@ -0,0 +1,34 @@
+open Names
+open Term
+
+
+val generate_functional_principle : 
+  (* do we accept interactive proving *)
+  bool ->
+  (* induction principle on rel *) 
+  types ->
+  (* *)
+  sorts array option -> 
+  (* Name of the new principle *) 
+  (identifier) option -> 
+  (* the compute functions to use   *)
+  constant array -> 
+  (* We prove the nth- principle *)
+  int  ->
+  (* The tactic to use to make the proof w.r
+     the number of params
+  *)
+  (constr array -> int -> Tacmach.tactic) -> 
+  unit
+
+val compute_new_princ_type_from_rel : constr array -> sorts array -> 
+  types -> types
+
+
+exception No_graph_found
+
+val make_scheme : (constant*Rawterm.rawsort) list -> Entries.definition_entry list
+
+val build_scheme : (identifier*Libnames.reference*Rawterm.rawsort) list ->  unit
+val build_case_scheme : (identifier*Libnames.reference*Rawterm.rawsort)  ->  unit
+
diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml
new file mode 100644
index 00000000..6e2af224
--- /dev/null
+++ b/contrib/funind/indfun.ml
@@ -0,0 +1,747 @@
+open Util
+open Names
+open Term
+open Pp
+open Indfun_common
+open Libnames
+open Rawterm
+open Declarations
+
+let is_rec_info scheme_info = 
+  let test_branche min acc (_,_,br) = 
+    acc || (
+      let new_branche = 
+	Sign.it_mkProd_or_LetIn mkProp (fst (Sign.decompose_prod_assum br)) in 
+      let free_rels_in_br = Termops.free_rels new_branche in 
+      let max = min + scheme_info.Tactics.npredicates in 
+      Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br
+    )
+  in
+  Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
+
+
+let choose_dest_or_ind scheme_info =
+    if is_rec_info scheme_info
+    then Tactics.new_induct
+    else Tactics.new_destruct
+
+
+let functional_induction with_clean c princl pat =
+  let f,args = decompose_app c in 
+  fun g ->      
+    let princ,bindings, princ_type = 
+      match princl with 
+	| None -> (* No principle is given let's find the good one *)
+	    begin
+	      match kind_of_term f with
+		| Const c' ->
+		    let princ_option = 
+		      let finfo = (* we first try to find out a graph on f *)
+			try find_Function_infos c' 
+			with Not_found -> 
+			  errorlabstrm "" (str "Cannot find induction information on "++
+					     Printer.pr_lconstr (mkConst c') )
+		      in
+		      match Tacticals.elimination_sort_of_goal g with 
+			| InProp -> finfo.prop_lemma
+			| InSet -> finfo.rec_lemma
+			| InType -> finfo.rect_lemma
+		    in
+		    let princ =  (* then we get the principle *)
+		      try mkConst (out_some princ_option )
+		      with Failure "out_some" -> 
+			(*i If there is not default lemma defined then, 
+			  we cross our finger and try to find a lemma named f_ind 
+			  (or f_rec, f_rect) i*)
+			let princ_name = 
+			  Indrec.make_elimination_ident
+			    (id_of_label (con_label c'))
+			    (Tacticals.elimination_sort_of_goal g)
+			in
+			try 
+			  mkConst(const_of_id princ_name )
+			with Not_found -> (* This one is neither defined ! *)
+			  errorlabstrm "" (str "Cannot find induction principle for "
+					   ++Printer.pr_lconstr (mkConst c') )
+		    in
+		    (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ)
+		| _ -> raise (UserError("",str "functional induction must be used with a function" ))
+		    
+	    end
+	| Some ((princ,binding)) -> 
+	    princ,binding,Tacmach.pf_type_of g princ
+    in
+    let princ_infos = Tactics.compute_elim_sig princ_type in 
+    let args_as_induction_constr =
+      let c_list = 
+	if princ_infos.Tactics.farg_in_concl 
+	then [c] else [] 
+      in
+      List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list) 
+    in 
+    let princ' = Some (princ,bindings) in 
+    let princ_vars = 
+      List.fold_right 
+	(fun a acc -> 
+	  try Idset.add (destVar a) acc
+	  with _ -> acc
+	)
+	args
+	Idset.empty
+    in
+    let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in 
+    let old_idl = Idset.diff old_idl princ_vars in 
+    let subst_and_reduce g = 
+      if with_clean 
+      then
+	let idl = 
+	  map_succeed 
+	    (fun id -> 
+	       if Idset.mem id old_idl then failwith "subst_and_reduce";
+	       id 
+	    )
+	    (Tacmach.pf_ids_of_hyps g)
+	in 
+	let flag = 
+	  Rawterm.Cbv
+	    {Rawterm.all_flags 
+	     with Rawterm.rDelta = false; 		 
+	    }
+	in
+	Tacticals.tclTHEN
+	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl )
+	  (Hiddentac.h_reduce flag Tacticals.allClauses)	
+	  g
+      else Tacticals.tclIDTAC g 
+	
+    in
+    Tacticals.tclTHEN
+      (choose_dest_or_ind 
+	 princ_infos
+	 args_as_induction_constr
+	 princ'
+	 pat)
+      subst_and_reduce
+      g
+      
+      
+
+
+type annot = 
+    Struct of identifier 
+  | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
+  | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
+
+
+type newfixpoint_expr =
+    identifier * annot * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr
+
+let rec abstract_rawconstr c = function
+  | [] -> c
+  | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl)
+  | Topconstr.LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> Topconstr.mkLambdaC([x],t,b)) idl
+        (abstract_rawconstr c bl)
+
+let interp_casted_constr_with_implicits sigma env impls c  =
+(*   Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *)
+  Constrintern.intern_gen false sigma env ~impls:([],impls) 
+    ~allow_soapp:false  ~ltacvars:([],[]) c
+
+
+(* 
+   Construct a fixpoint as a Rawterm 
+   and not as a constr
+*)
+let build_newrecursive
+(lnameargsardef)  =
+  let env0 = Global.env()
+  and sigma = Evd.empty
+  in
+  let (rec_sign,rec_impls) =
+    List.fold_left
+      (fun (env,impls) (recname,_,bl,arityc,_) ->
+        let arityc = Command.generalize_constr_expr arityc bl in
+        let arity = Constrintern.interp_type sigma env0 arityc in
+	let impl =
+	  if Impargs.is_implicit_args()
+	  then Impargs.compute_implicits  env0 arity
+	  else [] in
+	let impls' =(recname,([],impl,Notation.compute_arguments_scope arity))::impls in
+        (Environ.push_named (recname,None,arity) env, impls'))
+      (env0,[]) lnameargsardef in
+  let recdef =
+    (* Declare local notations *)
+    let fs = States.freeze() in
+    let def =
+      try
+	List.map
+	  (fun (_,_,bl,_,def)  ->
+             let def = abstract_rawconstr def bl in
+             interp_casted_constr_with_implicits
+	       sigma rec_sign rec_impls def
+	  )
+          lnameargsardef
+	with e ->
+	States.unfreeze fs; raise e in
+    States.unfreeze fs; def
+  in
+  recdef,rec_impls
+	
+
+let compute_annot (name,annot,args,types,body) =
+  let names = List.map snd (Topconstr.names_of_local_assums args) in
+  match annot with
+    | None ->
+        if List.length names > 1 then
+          user_err_loc
+            (dummy_loc,"Function",
+             Pp.str "the recursive argument needs to be specified");
+        let new_annot = (id_of_name (List.hd names)) in
+	(name,Struct new_annot,args,types,body)
+    | Some r -> (name,r,args,types,body)
+
+
+(* Checks whether or not the mutual bloc is recursive *) 
+let rec is_rec names = 
+  let names = List.fold_right Idset.add names Idset.empty in 
+  let check_id id names =  Idset.mem id names in 
+  let rec lookup names = function 
+    | RVar(_,id) -> check_id id names
+    | RRef _ | REvar _ | RPatVar _ | RSort _ |  RHole _ | RDynamic _ -> false
+    | RCast(_,b,_,_) -> lookup names b
+    | RRec _ -> error "RRec not handled"
+    | RIf(_,b,_,lhs,rhs) -> 
+	(lookup names b) || (lookup names lhs) || (lookup names rhs)
+    | RLetIn(_,na,t,b) | RLambda(_,na,t,b) | RProd(_,na,t,b)  -> 
+	lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
+    | RLetTuple(_,nal,_,t,b) -> lookup names t || 
+	lookup 
+	  (List.fold_left 
+	     (fun acc na -> Nameops.name_fold Idset.remove na acc)
+	     names
+	     nal
+	  )
+	  b
+    | RApp(_,f,args) -> List.exists (lookup names) (f::args)
+    | RCases(_,_,el,brl) -> 
+	List.exists (fun (e,_) -> lookup names e) el ||
+	  List.exists (lookup_br names) brl
+  and lookup_br names (_,idl,_,rt) = 
+    let new_names = List.fold_right Idset.remove idl names in 
+    lookup new_names rt
+  in
+  lookup names
+
+let prepare_body (name,annot,args,types,body) rt = 
+  let n = (Topconstr.local_binders_length args) in 
+(*   Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *)
+  let fun_args,rt' = chop_rlambda_n n rt in
+  (fun_args,rt')
+
+
+let derive_inversion fix_names =
+  try 
+    (* we first transform the fix_names identifier into their corresponding constant *)
+    let fix_names_as_constant = 
+      List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names 
+    in 
+    (* 
+       Then we check that the graphs have been defined 
+       If one of the graphs haven't been defined 
+       we do nothing
+    *)
+    List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ;
+    try
+      Invfun.derive_correctness 
+	Functional_principles_types.make_scheme
+	functional_induction 
+	fix_names_as_constant
+	(*i The next call to mk_rel_id is valid since we have just construct the graph 
+	  Ensures by : register_built
+	  i*) 
+	(List.map
+	   (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id)))
+	   fix_names
+	)
+    with e -> 
+      msg_warning 
+	(str "Cannot build functional inversion principle" ++ 
+	   if do_observe () then Cerrors.explain_exn e else mt ())
+  with _ -> ()
+
+let generate_principle 
+    is_general do_built fix_rec_l recdefs  interactive_proof 
+    (continue_proof : int -> Names.constant array -> Term.constr array -> int -> 
+      Tacmach.tactic) : unit =
+  let names = List.map (function (name,_,_,_,_) -> name) fix_rec_l in
+  let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
+  let funs_args = List.map fst fun_bodies in
+  let funs_types =  List.map (function (_,_,_,types,_) -> types) fix_rec_l in
+  try 
+    (* We then register the Inductive graphs of the functions  *)
+    Rawterm_to_relation.build_inductive names funs_args funs_types recdefs;
+    if do_built 
+    then
+      begin
+	(*i The next call to mk_rel_id is valid since we have just construct the graph 
+	   Ensures by : do_built
+	i*) 
+	let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
+	let ind_kn =
+	  fst (locate_with_msg
+		 (pr_reference f_R_mut++str ": Not an inductive type!")
+		 locate_ind
+		 f_R_mut)
+	in
+	let fname_kn (fname,_,_,_,_) =
+	  let f_ref = Ident (dummy_loc,fname) in
+	  locate_with_msg
+	    (pr_reference f_ref++str ": Not an inductive type!")
+	    locate_constant
+	    f_ref
+	in
+	let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in 
+	let _ = 
+	  list_map_i
+	    (fun i x ->
+	       let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in 
+	       let princ_type = Typeops.type_of_constant (Global.env()) princ
+	       in
+	       Functional_principles_types.generate_functional_principle
+		 interactive_proof 
+		 princ_type
+		 None
+		 None 
+		 funs_kn
+		 i
+		 (continue_proof  0 [|funs_kn.(i)|]) 
+	    )
+	    0
+	    fix_rec_l
+	in 
+	Array.iter (add_Function is_general) funs_kn;
+	()
+      end
+  with e -> 
+    match e with 
+      | Building_graph e -> 
+	    Pp.msg_warning 
+	    (str "Cannot define graph(s) for " ++ 
+	       h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	       if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
+      | Defining_principle e -> 
+	    Pp.msg_warning
+	    (str "Cannot define principle(s) for "++ 
+	       h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	       if do_observe () then Cerrors.explain_exn e else mt ())
+      | _ -> anomaly ""
+
+let register_struct is_rec fixpoint_exprl = 
+  match fixpoint_exprl with 
+    | [(fname,_,bl,ret_type,body),_] when not is_rec -> 
+	Command.declare_definition
+	  fname
+	  (Decl_kinds.Global,Options.boxed_definitions (),Decl_kinds.Definition)
+	  bl
+	  None
+  	  body
+	  (Some ret_type)
+	  (fun _ _ -> ())
+    | _ -> 
+	Command.build_recursive fixpoint_exprl (Options.boxed_definitions())
+
+let generate_correction_proof_wf f_ref tcc_lemma_ref   
+    is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
+    (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = 
+  Functional_principles_proofs.prove_principle_for_gen
+    (f_ref,functional_ref,eq_ref)
+    tcc_lemma_ref is_mes  rec_arg_num rec_arg_type relation
+
+
+let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
+    pre_hook 
+    =  
+  let type_of_f = Command.generalize_constr_expr ret_type args in 
+  let rec_arg_num = 
+    let names = 
+      List.map
+	snd
+	(Topconstr.names_of_local_assums args) 
+    in 
+    match wf_arg with 
+      | None -> 
+	  if List.length names = 1 then 1
+	  else error "Recursive argument must be specified"
+      | Some wf_arg -> 
+	  list_index (Name wf_arg) names 
+  in
+  let unbounded_eq = 
+    let f_app_args = 
+      Topconstr.CAppExpl 
+	(dummy_loc, 
+	 (None,(Ident (dummy_loc,fname))) ,
+	 (List.map 
+	    (function
+	       | _,Anonymous -> assert false 
+	       | _,Name e -> (Topconstr.mkIdentC e)
+	    ) 
+	    (Topconstr.names_of_local_assums args)
+	 )
+	) 
+    in
+    Topconstr.CApp (dummy_loc,(None,Topconstr.mkIdentC (id_of_string "eq")),
+		    [(f_app_args,None);(body,None)])
+  in
+  let eq = Command.generalize_constr_expr unbounded_eq args in 
+  let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type
+      nb_args relation =
+    try 
+      pre_hook 
+	(generate_correction_proof_wf f_ref tcc_lemma_ref is_mes
+	   functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
+	);
+      derive_inversion [fname]
+    with e -> 
+      (* No proof done *) 
+      ()
+  in 
+  Recdef.recursive_definition 
+    is_mes fname rec_impls
+    type_of_f
+    wf_rel_expr
+    rec_arg_num
+    eq
+    hook
+    using_lemmas
+
+    
+let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = 
+  let wf_arg_type,wf_arg = 
+    match wf_arg with 
+      | None -> 
+	  begin
+	    match args with 
+	      | [Topconstr.LocalRawAssum ([(_,Name x)],t)] -> t,x 
+	      | _ -> error "Recursive argument must be specified" 
+	  end
+      | Some wf_args -> 
+	  try 
+	    match 
+	      List.find 
+		(function 
+		   | Topconstr.LocalRawAssum(l,t) -> 
+		       List.exists 
+			 (function (_,Name id) -> id =  wf_args | _ -> false) 
+			 l 
+		   | _ -> false
+		)
+		args 
+	    with 
+	      | Topconstr.LocalRawAssum(_,t)  ->	    t,wf_args
+	      | _ -> assert false 
+	  with Not_found -> assert false 
+  in
+  let ltof = 
+    let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in 
+    Libnames.Qualid (dummy_loc,Libnames.qualid_of_sp 
+      (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof")))
+  in
+  let fun_from_mes = 
+    let applied_mes = 
+      Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg])    in
+    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],wf_arg_type,applied_mes) 
+  in
+  let wf_rel_from_mes = 
+    Topconstr.mkAppC(Topconstr.mkRefC  ltof,[wf_arg_type;fun_from_mes])
+  in
+  register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) 
+    using_lemmas args ret_type body
+	  
+
+let do_generate_principle register_built interactive_proof fixpoint_exprl  = 
+  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in 
+  let _is_struct = 
+    match fixpoint_exprl with 
+      | [((name,Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> 
+	  let pre_hook = 
+	    generate_principle 
+	      true
+	      register_built
+	      fixpoint_exprl 
+	      recdefs
+	      true
+	  in 
+	  if register_built 
+	  then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook;
+	  false
+      | [((name,Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> 
+	  let pre_hook = 
+	    generate_principle 
+	      true
+	      register_built
+	      fixpoint_exprl 
+	      recdefs
+	      true
+	  in 
+	  if register_built 
+	  then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook;
+	  true
+      | _ -> 
+	  let fix_names = 
+	    List.map (function (name,_,_,_,_) -> name) fixpoint_exprl 
+	  in
+	  let is_one_rec = is_rec fix_names  in
+	  let old_fixpoint_exprl =  
+	    List.map
+	      (function
+		 | (name,Some (Struct id),args,types,body),_ -> 
+		     let names = 
+		       List.map
+			 snd
+			 (Topconstr.names_of_local_assums args) 
+		     in 
+		     let annot = 
+		       try Some (list_index (Name id) names - 1), Topconstr.CStructRec 
+		       with Not_found -> 
+			 raise (UserError("",str "Cannot find argument " ++ 
+					    Ppconstr.pr_id id)) 
+		     in 
+ 		     (name,annot,args,types,body),(None:Vernacexpr.decl_notation) 
+		 | (name,None,args,types,body),recdef -> 
+		     let names =  (Topconstr.names_of_local_assums args) in
+		     if  is_one_rec recdef  && List.length names > 1 then
+		       user_err_loc
+			 (dummy_loc,"Function",
+			  Pp.str "the recursive argument needs to be specified in Function")
+		     else 
+		       (name,(Some 0, Topconstr.CStructRec),args,types,body),
+		     (None:Vernacexpr.decl_notation)
+		 | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> 
+		     error 
+		       ("Cannot use mutual definition with well-founded recursion or measure")
+	      ) 
+	      (List.combine fixpoint_exprl recdefs)
+	  in
+	  (* ok all the expressions are structural *) 
+	  let fix_names = 
+	    List.map (function (name,_,_,_,_) -> name) fixpoint_exprl 
+	  in
+	  let is_rec = List.exists (is_rec fix_names) recdefs in
+	  if register_built then register_struct is_rec old_fixpoint_exprl;
+	  generate_principle
+	    false
+	    register_built
+	    fixpoint_exprl
+	    recdefs 
+	    interactive_proof
+	    (Functional_principles_proofs.prove_princ_for_struct interactive_proof);
+	  if register_built then derive_inversion fix_names;
+	  true;
+  in
+  ()
+
+open Topconstr
+let rec add_args id new_args b = 
+  match b with 
+  | CRef r -> 
+      begin      match r with 
+	| Libnames.Ident(loc,fname) when fname = id -> 
+	    CAppExpl(dummy_loc,(None,r),new_args)
+	| _ -> b
+      end
+  | CFix  _  | CCoFix _ -> anomaly "add_args : todo"
+  | CArrow(loc,b1,b2) -> 
+      CArrow(loc,add_args id new_args  b1, add_args id new_args b2)
+  | CProdN(loc,nal,b1) -> 
+      CProdN(loc,
+	     List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, 
+	     add_args id new_args  b1)
+  | CLambdaN(loc,nal,b1) -> 
+      CLambdaN(loc,
+	       List.map (fun (nal,b2) -> (nal,add_args id new_args  b2)) nal, 
+	       add_args id new_args  b1)
+  | CLetIn(loc,na,b1,b2) -> 
+      CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
+  | CAppExpl(loc,(pf,r),exprl) -> 
+      begin 
+	match r with 
+	| Libnames.Ident(loc,fname) when fname = id -> 
+	    CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl))
+	| _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl)
+      end
+  | CApp(loc,(pf,b),bl) -> 
+      CApp(loc,(pf,add_args id new_args b), 
+	   List.map (fun (e,o) -> add_args id new_args e,o) bl)
+  | CCases(loc,b_option,cel,cal) -> 
+      CCases(loc,option_map (add_args id new_args) b_option,
+	     List.map (fun (b,(na,b_option)) -> 
+			 add_args id new_args b,
+			 (na,option_map (add_args id new_args) b_option)) cel, 
+	     List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
+	    )
+  | CLetTuple(loc,nal,(na,b_option),b1,b2) -> 
+      CLetTuple(loc,nal,(na,option_map (add_args id new_args) b_option),
+		add_args id new_args b1,
+		add_args id new_args b2
+	       )
+		
+  | CIf(loc,b1,(na,b_option),b2,b3) -> 
+      CIf(loc,add_args id new_args b1, 
+	  (na,option_map (add_args id new_args) b_option),
+	  add_args id new_args b2,
+	  add_args id new_args b3
+	 )
+  | CHole _ -> b
+  | CPatVar _ -> b
+  | CEvar _ -> b
+  | CSort _ -> b
+  | CCast(loc,b1,ck,b2)  -> 
+      CCast(loc,add_args id new_args b1,ck,add_args id new_args b2)
+  | CNotation _ -> anomaly "add_args : CNotation"
+  | CPrim _ -> b
+  | CDelimiters _ -> anomaly "add_args : CDelimiters"
+  | CDynamic _ -> anomaly "add_args : CDynamic"
+exception Stop of  Topconstr.constr_expr
+
+
+(* [chop_n_arrow n t] chops the [n] first arrows in [t] 
+   Acts on Topconstr.constr_expr 
+*)
+let rec chop_n_arrow n t = 
+  if n <= 0 
+  then t (* If we have already removed all the arrows then return the type *)
+  else (* If not we check the form of [t] *) 
+    match t with 
+      | Topconstr.CArrow(_,_,t) ->  (* If we have an arrow, we discard it and recall [chop_n_arrow] *)
+	  chop_n_arrow (n-1) t
+      | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : 
+					     either we need to discard more than the number of arrows contained
+					     in this product declaration then we just recall [chop_n_arrow] on
+					     the remaining number of arrow to chop and [t'] we discard it and 
+					     recall [chop_n_arrow], either this product contains more arrows 
+					     than the number we need to chop and then we return the new type
+					  *)
+	  begin 
+	    try 
+	      let new_n =
+		let rec aux (n:int) = function 
+		    [] -> n
+		| (nal,t'')::nal_ta' -> 
+		    let nal_l = List.length nal in 
+		    if n >= nal_l
+		    then 
+		      aux (n - nal_l) nal_ta'
+		    else 
+		      let new_t' = Topconstr.CProdN(dummy_loc,((snd (list_chop n nal)),t'')::nal_ta',t')
+		      in 
+		      raise (Stop new_t')
+		in
+		aux n nal_ta'
+	    in 
+	      chop_n_arrow new_n t'
+	    with Stop t -> t
+	  end
+      | _ -> anomaly "Not enough products"
+  
+
+let rec get_args b t : Topconstr.local_binder list * 
+    Topconstr.constr_expr * Topconstr.constr_expr = 
+  match b with 
+    | Topconstr.CLambdaN (loc, (nal_ta), b') -> 
+	begin
+	  let n = 
+	    (List.fold_left (fun n (nal,_) -> 
+			       n+List.length nal) 0 nal_ta )
+	  in
+	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in 
+	  (List.map (fun (nal,ta) -> 
+		       (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' 
+	end
+    | _ -> [],b,t
+
+
+let make_graph (f_ref:global_reference) =
+ let c,c_body = 
+      match f_ref with 
+	| ConstRef c -> 
+	    begin try c,Global.lookup_constant c 
+	    with Not_found -> 
+	      raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) )
+	    end
+	| _ -> raise (UserError ("", str "Not a function reference") )
+
+  in
+  match c_body.const_body with
+    | None -> error "Cannot build a graph over an axiom !"
+    | Some b ->
+	let env = Global.env () in
+	let body = (force b) in
+	let extern_body,extern_type = 
+	  with_full_print 
+	    (fun () -> 
+	       (Constrextern.extern_constr false env body, 
+		Constrextern.extern_type false env
+                  (Typeops.type_of_constant_type env c_body.const_type)
+	       )
+	    )
+	    ()
+	in
+	let (nal_tas,b,t)  = get_args extern_body extern_type in
+	let expr_list = 
+	  match b with 
+	    | Topconstr.CFix(loc,l_id,fixexprl) -> 
+		let l = 
+		  List.map
+		    (fun (id,(n,recexp),bl,t,b) -> 
+		       let bl' =  
+			 List.flatten 
+			   (List.map 
+			      (function 
+				 | Topconstr.LocalRawDef (na,_)-> []
+				 | Topconstr.LocalRawAssum (nal,_) -> nal
+			      )
+			      bl
+			   )
+		       in 
+		       let rec_id = 
+			 match List.nth bl' (out_some n)  with 
+			   |(_,Name id) -> id | _ -> anomaly ""
+		       in
+		       let new_args = 
+			 List.flatten 
+			   (List.map 
+			      (function
+ 				 | Topconstr.LocalRawDef (na,_)-> []
+			      	 | Topconstr.LocalRawAssum (nal,_) -> 
+				     List.map 
+				       (fun (loc,n) -> 
+					  CRef(Libnames.Ident(loc, Nameops.out_name n))) 
+				       nal
+			      )
+			      nal_tas
+			   )
+		       in
+		       let b' = add_args id new_args b in 
+		       (id, Some (Struct rec_id),nal_tas@bl,t,b')
+		    )
+		    fixexprl
+		in
+		l
+	    | _ ->   
+		let id = id_of_label (con_label c) in 
+		[(id,None,nal_tas,t,b)]
+	in
+	do_generate_principle false false expr_list;
+	(* We register the infos *)
+	let mp,dp,_ = repr_con c in 
+	List.iter 
+	  (fun (id,_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) 
+	  expr_list
+
+
+(* let make_graph _ = assert false	 *)
+	  
+let do_generate_principle = do_generate_principle true 
+
+
diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml
new file mode 100644
index 00000000..13b242d5
--- /dev/null
+++ b/contrib/funind/indfun_common.ml
@@ -0,0 +1,508 @@
+open Names
+open Pp
+
+open Libnames
+
+let mk_prefix pre id = id_of_string (pre^(string_of_id id))
+let mk_rel_id = mk_prefix "R_"
+let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct"
+let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete"
+let mk_equation_id id = Nameops.add_suffix id "_equation"
+
+let msgnl m =
+  ()
+
+let invalid_argument s = raise (Invalid_argument s)
+
+
+let fresh_id avoid s = Termops.next_global_ident_away true (id_of_string s) avoid
+
+let fresh_name avoid s = Name (fresh_id avoid s)
+
+let get_name avoid ?(default="H") = function
+  | Anonymous -> fresh_name avoid default
+  | Name n -> Name n
+
+let array_get_start a =
+  try 
+    Array.init
+      (Array.length a - 1)
+      (fun i -> a.(i))
+  with Invalid_argument "index out of bounds" -> 
+    invalid_argument "array_get_start"
+      
+let id_of_name = function
+    Name id -> id
+  | _ -> raise Not_found
+
+let locate  ref =
+    let (loc,qid) = qualid_of_reference ref in
+    Nametab.locate qid
+
+let locate_ind ref =
+  match locate ref with
+    | IndRef x -> x
+    | _ -> raise Not_found
+
+let locate_constant ref =
+  match locate ref with
+    | ConstRef x -> x
+    | _ -> raise Not_found
+
+
+let locate_with_msg msg f x =
+  try
+    f x
+  with
+    | Not_found -> raise (Util.UserError("", msg))
+    | e -> raise e
+
+
+let filter_map filter f =
+  let rec it = function
+    | [] -> []
+    | e::l ->
+	if filter e
+	then
+	  (f e) :: it l
+	else it l
+  in
+  it
+
+
+let chop_rlambda_n  =
+  let rec chop_lambda_n acc n rt =
+      if n == 0
+      then List.rev acc,rt
+      else
+	match rt with
+	  | Rawterm.RLambda(_,name,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
+	  | Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
+	  | _ -> 
+	      raise (Util.UserError("chop_rlambda_n",
+				    str "chop_rlambda_n: Not enough Lambdas"))
+  in
+  chop_lambda_n []
+
+let chop_rprod_n  =
+  let rec chop_prod_n acc n rt =
+      if n == 0
+      then List.rev acc,rt
+      else
+	match rt with
+	  | Rawterm.RProd(_,name,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
+	  | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
+  in
+  chop_prod_n []
+
+
+
+let list_union_eq eq_fun l1 l2 =
+  let rec urec = function
+    | [] -> l2
+    | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l
+  in
+  urec l1
+
+let list_add_set_eq eq_fun x l =
+  if List.exists (eq_fun x) l then l else x::l
+
+  
+
+
+let const_of_id id =
+  let _,princ_ref = 
+    qualid_of_reference (Libnames.Ident (Util.dummy_loc,id))
+  in
+  try Nametab.locate_constant princ_ref
+  with Not_found -> Util.error ("cannot find "^ string_of_id id)
+
+let def_of_const t =
+   match (Term.kind_of_term t) with
+    Term.Const sp -> 
+      (try (match (Global.lookup_constant sp) with
+             {Declarations.const_body=Some c} -> Declarations.force c
+	     |_ -> assert false)
+       with _ -> assert false)
+    |_ -> assert false
+
+let coq_constant s =
+  Coqlib.gen_constant_in_modules "RecursiveDefinition" 
+    (Coqlib.init_modules @ Coqlib.arith_modules) s;;
+
+let constant sl s =
+  constr_of_reference
+    (Nametab.locate (make_qualid(Names.make_dirpath 
+			   (List.map id_of_string (List.rev sl)))
+	       (id_of_string s)));;
+
+let find_reference sl s =
+    (Nametab.locate (make_qualid(Names.make_dirpath 
+			   (List.map id_of_string (List.rev sl)))
+	       (id_of_string s)));;
+
+let eq = lazy(coq_constant "eq")
+let refl_equal = lazy(coq_constant "refl_equal")
+
+(*****************************************************************)
+(* Copy of the standart save mechanism but without the much too  *)
+(* slow reduction function                                       *) 
+(*****************************************************************)
+open Declarations
+open Entries
+open Decl_kinds
+open Declare
+let definition_message id =
+  Options.if_verbose message ((string_of_id id) ^ " is defined")
+
+
+let save with_clean id const (locality,kind) hook =
+  let {const_entry_body = pft;
+       const_entry_type = tpo;
+       const_entry_opaque = opacity } = const in
+  let l,r = match locality with
+    | Local when Lib.sections_are_opened () ->
+        let k = logical_kind_of_goal_kind kind in
+	let c = SectionLocalDef (pft, tpo, opacity) in
+	let _ = declare_variable id (Lib.cwd(), c, k) in
+	(Local, VarRef id)
+    | Local ->
+        let k = logical_kind_of_goal_kind kind in
+        let kn = declare_constant id (DefinitionEntry const, k) in
+	(Global, ConstRef kn)
+    | Global ->
+        let k = logical_kind_of_goal_kind kind in
+        let kn = declare_constant id (DefinitionEntry const, k) in
+	(Global, ConstRef kn) in
+  if with_clean then  Pfedit.delete_current_proof ();
+  hook l r;
+  definition_message id
+
+
+
+
+let extract_pftreestate pts =
+  let pfterm,subgoals = Refiner.extract_open_pftreestate pts in
+  let tpfsigma = Refiner.evc_of_pftreestate pts in 
+  let exl = Evarutil.non_instantiated tpfsigma  in
+  if subgoals <> [] or exl <> [] then
+    Util.errorlabstrm "extract_proof"
+      (if subgoals <> [] then
+        str "Attempt to save an incomplete proof"
+      else
+        str "Attempt to save a proof with existential variables still non-instantiated");
+  let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in
+  env,tpfsigma,pfterm
+
+
+let nf_betaiotazeta =
+  let clos_norm_flags flgs env sigma t =
+    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
+  clos_norm_flags Closure.betaiotazeta  
+
+let nf_betaiota =
+  let clos_norm_flags flgs env sigma t =
+    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
+  clos_norm_flags Closure.betaiota  
+
+let cook_proof do_reduce =
+  let pfs = Pfedit.get_pftreestate () 
+(*   and ident = Pfedit.get_current_proof_name ()  *)
+  and (ident,strength,concl,hook) = Pfedit.current_proof_statement ()  in
+  let env,sigma,pfterm = extract_pftreestate pfs in
+  let pfterm = 
+    if do_reduce
+    then nf_betaiota env sigma pfterm
+    else pfterm
+  in
+  (ident,
+   ({ const_entry_body = pfterm;
+      const_entry_type = Some concl;
+      const_entry_opaque = false;
+      const_entry_boxed = false},
+    strength, hook))
+
+
+let new_save_named opacity =
+  let id,(const,persistence,hook) = cook_proof true  in
+  let const = { const with const_entry_opaque = opacity } in
+  save true id const persistence hook
+
+let get_proof_clean do_reduce = 
+  let result = cook_proof do_reduce in 
+  Pfedit.delete_current_proof ();
+  result
+
+let with_full_print f a = 
+  let old_implicit_args = Impargs.is_implicit_args ()
+  and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
+  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
+  let old_rawprint = !Options.raw_print in 
+  Options.raw_print := true;
+  Impargs.make_implicit_args false;
+  Impargs.make_strict_implicit_args false;
+  Impargs.make_contextual_implicit_args false;
+  try 
+    let res = f a in 
+    Impargs.make_implicit_args old_implicit_args;
+    Impargs.make_strict_implicit_args old_strict_implicit_args;
+    Impargs.make_contextual_implicit_args old_contextual_implicit_args;
+    Options.raw_print := old_rawprint;
+    res
+  with  
+    | e -> 
+	Impargs.make_implicit_args old_implicit_args;
+	Impargs.make_strict_implicit_args old_strict_implicit_args;
+	Impargs.make_contextual_implicit_args old_contextual_implicit_args;
+	Options.raw_print := old_rawprint;
+	raise e
+
+
+
+
+
+
+(**********************)
+
+type function_info = 
+    { 
+      function_constant : constant;
+      graph_ind : inductive;
+      equation_lemma : constant option;
+      correctness_lemma : constant option;
+      completeness_lemma : constant option; 
+      rect_lemma : constant option;
+      rec_lemma : constant option;
+      prop_lemma : constant option;
+      is_general : bool; (* Has this function been defined using general recursive definition *)
+    }
+      
+
+(* type function_db  = function_info list *)
+
+(* let function_table = ref ([] : function_db) *)
+
+
+let from_function = ref Cmap.empty
+let from_graph = ref Indmap.empty
+(*
+let rec do_cache_info finfo = function 
+  | [] -> raise Not_found 
+  | (finfo'::finfos as l) -> 
+      if finfo' == finfo then l 
+      else if finfo'.function_constant = finfo.function_constant 
+      then finfo::finfos
+      else
+	let res = do_cache_info finfo finfos in 
+	if res == finfos then l else  finfo'::l
+  
+
+let cache_Function (_,(finfos)) = 
+  let new_tbl = 
+    try do_cache_info finfos !function_table
+    with Not_found -> finfos::!function_table
+  in  
+  if new_tbl != !function_table 
+  then function_table := new_tbl
+*)
+
+let cache_Function (_,finfos) = 
+  from_function := Cmap.add finfos.function_constant finfos !from_function;
+  from_graph := Indmap.add finfos.graph_ind finfos !from_graph
+
+
+let load_Function _  = cache_Function
+let open_Function _ = cache_Function
+let subst_Function (_,subst,finfos) = 
+  let do_subst_con c = fst (Mod_subst.subst_con subst c)
+  and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i)
+  in
+  let function_constant' = do_subst_con finfos.function_constant in 
+  let graph_ind' = do_subst_ind finfos.graph_ind in 
+  let equation_lemma' = Util.option_smartmap do_subst_con finfos.equation_lemma in 
+  let correctness_lemma' = Util.option_smartmap do_subst_con finfos.correctness_lemma in 
+  let completeness_lemma' = Util.option_smartmap do_subst_con finfos.completeness_lemma in 
+  let rect_lemma' = Util.option_smartmap do_subst_con finfos.rect_lemma in
+  let rec_lemma' = Util.option_smartmap do_subst_con finfos.rec_lemma in 
+  let prop_lemma' =  Util.option_smartmap do_subst_con finfos.prop_lemma in 
+  if function_constant' == finfos.function_constant && 
+    graph_ind' == finfos.graph_ind && 
+    equation_lemma' == finfos.equation_lemma &&
+    correctness_lemma' == finfos.correctness_lemma && 
+    completeness_lemma' == finfos.completeness_lemma && 
+    rect_lemma' == finfos.rect_lemma && 
+    rec_lemma' == finfos.rec_lemma && 
+    prop_lemma' == finfos.prop_lemma 
+  then finfos 
+  else
+    { function_constant = function_constant';
+      graph_ind = graph_ind';
+      equation_lemma = equation_lemma' ;
+      correctness_lemma = correctness_lemma' ;
+      completeness_lemma = completeness_lemma' ;
+      rect_lemma = rect_lemma' ;
+      rec_lemma = rec_lemma';
+      prop_lemma = prop_lemma';
+      is_general = finfos.is_general
+    }
+
+let classify_Function (_,infos) = Libobject.Substitute infos
+
+let export_Function infos = Some infos
+
+
+let discharge_Function (_,finfos) = 
+  let function_constant' = Lib.discharge_con finfos.function_constant
+  and graph_ind' = Lib.discharge_inductive finfos.graph_ind 
+  and equation_lemma' = Util.option_smartmap Lib.discharge_con finfos.equation_lemma 
+  and correctness_lemma' = Util.option_smartmap Lib.discharge_con finfos.correctness_lemma 
+  and completeness_lemma' = Util.option_smartmap Lib.discharge_con finfos.completeness_lemma 
+  and rect_lemma' = Util.option_smartmap Lib.discharge_con finfos.rect_lemma 
+  and rec_lemma' = Util.option_smartmap Lib.discharge_con finfos.rec_lemma
+  and prop_lemma' = Util.option_smartmap Lib.discharge_con finfos.prop_lemma
+  in
+  if function_constant' == finfos.function_constant && 
+    graph_ind' == finfos.graph_ind && 
+    equation_lemma' == finfos.equation_lemma &&
+    correctness_lemma' == finfos.correctness_lemma && 
+    completeness_lemma' == finfos.completeness_lemma && 
+    rect_lemma' == finfos.rect_lemma && 
+    rec_lemma' == finfos.rec_lemma && 
+    prop_lemma' == finfos.prop_lemma 
+  then Some finfos 
+  else
+    Some { function_constant = function_constant' ;
+	   graph_ind = graph_ind' ;
+	   equation_lemma = equation_lemma' ;
+	   correctness_lemma = correctness_lemma' ;
+	   completeness_lemma = completeness_lemma';
+	   rect_lemma = rect_lemma';
+	   rec_lemma = rec_lemma';
+	   prop_lemma = prop_lemma' ;
+	   is_general = finfos.is_general
+	 }    
+
+open Term
+let pr_info f_info = 
+  str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
+    str "function_constant_type := " ++ 
+    (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++
+    str "equation_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
+    str "completeness_lemma :=" ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
+    str "correctness_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
+    str "rect_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
+    str "rec_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
+    str "prop_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
+    str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () 
+
+let pr_table tb = 
+  let l = Cmap.fold (fun k v acc -> v::acc) tb [] in 
+  Util.prlist_with_sep fnl pr_info l
+
+let in_Function,out_Function = 
+  Libobject.declare_object
+    {(Libobject.default_object "FUNCTIONS_DB") with 
+       Libobject.cache_function = cache_Function;
+       Libobject.load_function  = load_Function;
+       Libobject.classify_function  = classify_Function;
+       Libobject.subst_function = subst_Function;
+       Libobject.export_function = export_Function;
+       Libobject.discharge_function = discharge_Function
+(*        Libobject.open_function = open_Function; *)
+    }
+
+
+
+(* Synchronisation with reset *)
+let freeze () = 
+  !from_function,!from_graph
+let unfreeze (functions,graphs) = 
+(*   Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
+  from_function := functions;
+  from_graph := graphs
+
+let init () = 
+(*   Pp.msgnl (str "reseting function_table");  *)
+  from_function := Cmap.empty;
+  from_graph := Indmap.empty
+
+let _ = 
+  Summary.declare_summary "functions_db_sum"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false; 
+      Summary.survive_section = false }
+
+let find_or_none id = 
+  try Some 
+    (match Nametab.locate (make_short_qualid id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" 
+    ) 
+  with Not_found -> None
+
+
+
+let find_Function_infos f = 
+  Cmap.find f !from_function
+
+
+let find_Function_of_graph ind = 
+  Indmap.find ind !from_graph
+  
+let update_Function finfo = 
+(*   Pp.msgnl (pr_info finfo); *)
+  Lib.add_anonymous_leaf (in_Function finfo)
+      
+  
+let add_Function is_general f = 
+  let f_id = id_of_label (con_label f) in 
+  let equation_lemma = find_or_none (mk_equation_id f_id)
+  and correctness_lemma = find_or_none (mk_correct_id f_id) 
+  and completeness_lemma = find_or_none (mk_complete_id f_id) 
+  and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect")
+  and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec")
+  and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
+  and graph_ind = 
+    match Nametab.locate (make_short_qualid (mk_rel_id f_id)) 
+    with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive"
+  in
+  let finfos = 
+    { function_constant = f;
+      equation_lemma = equation_lemma;
+      completeness_lemma = completeness_lemma;
+      correctness_lemma = correctness_lemma;
+      rect_lemma = rect_lemma;
+      rec_lemma = rec_lemma;
+      prop_lemma = prop_lemma;
+      graph_ind = graph_ind;
+      is_general = is_general
+      
+    }
+  in
+  update_Function finfos
+
+let pr_table () = pr_table !from_function
+(*********************************)
+(* Debuging *)
+let function_debug = ref false 
+open Goptions
+
+let function_debug_sig =
+  {
+    optsync = false;
+    optname = "Function debug";
+    optkey =  PrimaryTable("Function_debug");
+    optread = (fun () -> !function_debug);
+    optwrite = (fun b -> function_debug := b)
+  }
+
+let _ = declare_bool_option function_debug_sig
+
+
+let do_observe () = 
+  !function_debug = true
+      
+      
+    
+exception Building_graph of exn 
+exception Defining_principle of exn
diff --git a/contrib/funind/indfun_common.mli b/contrib/funind/indfun_common.mli
new file mode 100644
index 00000000..7da1d6f0
--- /dev/null
+++ b/contrib/funind/indfun_common.mli
@@ -0,0 +1,117 @@
+open Names
+open Pp
+
+(* 
+   The mk_?_id function build different name w.r.t. a function 
+   Each of their use is justified in the code 
+*) 
+val mk_rel_id : identifier -> identifier
+val mk_correct_id : identifier -> identifier
+val mk_complete_id : identifier -> identifier
+val mk_equation_id : identifier -> identifier
+
+
+val msgnl : std_ppcmds -> unit
+
+val invalid_argument : string -> 'a
+
+val fresh_id : identifier list -> string -> identifier
+val fresh_name : identifier list -> string -> name 
+val get_name : identifier list -> ?default:string -> name -> name 
+
+val array_get_start : 'a array -> 'a array
+
+val id_of_name : name -> identifier
+
+val locate_ind : Libnames.reference -> inductive
+val locate_constant : Libnames.reference -> constant
+val locate_with_msg :
+  Pp.std_ppcmds -> (Libnames.reference -> 'a) ->
+  Libnames.reference -> 'a
+
+val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list
+val list_union_eq :
+  ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
+val list_add_set_eq :
+  ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
+
+val chop_rlambda_n : int -> Rawterm.rawconstr ->
+  (name*Rawterm.rawconstr*bool) list * Rawterm.rawconstr
+
+val chop_rprod_n : int -> Rawterm.rawconstr ->
+  (name*Rawterm.rawconstr) list * Rawterm.rawconstr
+
+val def_of_const : Term.constr -> Term.constr
+val eq : Term.constr Lazy.t
+val refl_equal : Term.constr Lazy.t
+val const_of_id: identifier -> constant
+
+
+(* [save_named] is a copy of [Command.save_named] but uses 
+   [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] 
+   
+
+
+   DON'T USE IT if you cannot ensure that there is no VMcast in the proof
+
+*)
+
+(* val nf_betaiotazeta : Reductionops.reduction_function *)
+
+val new_save_named : bool -> unit 
+
+val save : bool -> identifier ->  Entries.definition_entry  -> Decl_kinds.goal_kind -> 
+  Tacexpr.declaration_hook -> unit 
+
+(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and 
+   abort the proof 
+*)
+val get_proof_clean : bool ->     
+  Names.identifier *
+    (Entries.definition_entry * Decl_kinds.goal_kind *
+       Tacexpr.declaration_hook)
+    
+
+
+(* [with_full_print f a] applies [f] to [a] in full printing environment 
+   
+   This function preserves the print settings 
+*)
+val with_full_print : ('a -> 'b) -> 'a -> 'b
+
+
+(*****************)
+
+type function_info = 
+    { 
+      function_constant : constant;
+      graph_ind : inductive;
+      equation_lemma : constant option;
+      correctness_lemma : constant option;
+      completeness_lemma : constant option;
+      rect_lemma : constant option;
+      rec_lemma : constant option;
+      prop_lemma : constant option;
+      is_general : bool;
+    }
+
+val find_Function_infos : constant -> function_info
+val find_Function_of_graph : inductive -> function_info
+(* WARNING: To be used just after the graph definition !!! *)
+val add_Function : bool -> constant -> unit
+
+val update_Function : function_info -> unit 
+
+
+(** debugging *) 
+val pr_info : function_info -> Pp.std_ppcmds
+val pr_table : unit -> Pp.std_ppcmds
+
+
+(* val function_debug : bool ref  *)
+val do_observe : unit -> bool
+
+(* To localize pb *)
+exception Building_graph of exn 
+exception Defining_principle of exn
+
diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/indfun_main.ml4
new file mode 100644
index 00000000..26a1066c
--- /dev/null
+++ b/contrib/funind/indfun_main.ml4
@@ -0,0 +1,467 @@
+(************************************************************************)
+(*  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*)
+open Term
+open Names
+open Pp
+open Topconstr
+open Indfun_common 
+open Indfun
+open Genarg
+open Pcoq
+open Tacticals
+
+let pr_binding prc = function
+  | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
+  | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+
+let pr_bindings prc prlc = function
+  | Rawterm.ImplicitBindings l ->
+      brk (1,1) ++ str "with" ++ brk (1,1) ++
+      Util.prlist_with_sep spc prc l
+  | Rawterm.ExplicitBindings l ->
+      brk (1,1) ++ str "with" ++ brk (1,1) ++ 
+        Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
+  | Rawterm.NoBindings -> mt ()
+
+
+let pr_with_bindings prc prlc (c,bl) =
+  prc c ++ hv 0 (pr_bindings prc prlc bl)
+
+
+let pr_fun_ind_using  prc prlc _ opt_c = 
+  match opt_c with
+    | None -> mt ()
+    | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b))
+
+
+ARGUMENT EXTEND fun_ind_using
+  TYPED AS constr_with_bindings_opt
+  PRINTED BY pr_fun_ind_using
+| [ "using" constr_with_bindings(c) ] -> [ Some c ]
+| [ ] -> [ None ]
+END
+
+
+TACTIC EXTEND newfuninv
+   [ "functional" "inversion"  quantified_hypothesis(hyp) reference_opt(fname) ] -> 
+     [
+       Invfun.invfun hyp fname
+     ]
+END
+
+
+let pr_intro_as_pat prc _ _ pat = 
+  match pat with 
+    | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat
+    | None -> mt ()
+
+
+ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat
+|   [ "as"  simple_intropattern(ipat) ] -> [ Some ipat ] 
+| []  ->[ None ] 
+END
+
+
+
+
+TACTIC EXTEND newfunind
+   ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> 
+     [ 
+       let pat = 
+	 match pat with 
+	   | None -> IntroAnonymous
+	   | Some pat -> pat
+       in
+       let c = match cl with 
+	 | [] -> assert false
+	 | [c] -> c 
+	 | c::cl -> applist(c,cl)
+       in 
+       functional_induction true c  princl pat ]
+END
+(***** debug only ***)
+TACTIC EXTEND snewfunind
+   ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> 
+     [ 
+       let pat = 
+	 match pat with 
+	   | None -> IntroAnonymous
+	   | Some pat -> pat
+       in
+       let c = match cl with 
+	 | [] -> assert false
+	 | [c] -> c 
+	 | c::cl -> applist(c,cl)
+       in 
+       functional_induction false c princl pat ]
+END
+
+
+let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_coma prc
+
+ARGUMENT EXTEND constr_coma_sequence'
+  TYPED AS constr_list
+  PRINTED BY pr_constr_coma_sequence
+| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ]
+| [ constr(c) ] -> [ [c] ]
+END
+
+let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
+
+ARGUMENT EXTEND auto_using'
+  TYPED AS constr_list
+  PRINTED BY pr_auto_using
+| [ "using" constr_coma_sequence'(l) ] -> [ l ]
+| [ ] -> [ [] ]
+END
+
+VERNAC ARGUMENT EXTEND rec_annotation2
+  [ "{"  "struct" ident(id)  "}"] -> [ Struct id ]
+| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ]
+| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] 
+END
+
+
+VERNAC ARGUMENT EXTEND binder2
+    [ "(" ne_ident_list(idl) ":" lconstr(c)  ")"] ->
+     [
+       LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,c) ]
+END
+
+
+VERNAC ARGUMENT EXTEND rec_definition2
+ [ ident(id)  binder2_list( bl)
+     rec_annotation2_opt(annot) ":" lconstr( type_)
+	":=" lconstr(def)] ->
+    [let names = List.map snd (Topconstr.names_of_local_assums bl) in
+     let check_one_name () =
+       if List.length names > 1 then
+         Util.user_err_loc
+           (Util.dummy_loc,"Function",
+            Pp.str "the recursive argument needs to be specified");
+     in
+     let check_exists_args an =
+       try 
+	 let id = match an with 
+	   | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id 
+	   | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" 
+	 in 
+	 (try ignore(Util.list_index (Name id) names - 1); annot
+	  with Not_found ->  Util.user_err_loc
+            (Util.dummy_loc,"Function",
+             Pp.str "No argument named " ++ Nameops.pr_id id)
+	 )
+       with Failure "check_exists_args" ->  check_one_name ();annot
+     in
+     let ni =
+       match annot with
+         | None ->
+             annot
+	 | Some an ->
+	     check_exists_args an
+     in
+     (id, ni, bl, type_, def) ]
+      END
+
+
+VERNAC ARGUMENT EXTEND rec_definitions2
+| [ rec_definition2(rd) ] -> [ [rd] ]
+| [ rec_definition2(hd) "with" rec_definitions2(tl) ] -> [ hd::tl ]
+END
+
+
+VERNAC COMMAND EXTEND Function
+   ["Function" rec_definitions2(recsl)] ->
+	[ 
+	  do_generate_principle false  recsl; 
+	  
+	]
+END
+
+
+VERNAC ARGUMENT EXTEND fun_scheme_arg
+| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] 
+END 
+
+VERNAC ARGUMENT EXTEND fun_scheme_args
+| [ fun_scheme_arg(fa) ] -> [ [fa] ] 
+| [ fun_scheme_arg(fa) "with" fun_scheme_args(fas) ] -> [fa::fas]
+END 
+
+VERNAC COMMAND EXTEND NewFunctionalScheme
+   ["Functional" "Scheme" fun_scheme_args(fas) ] ->
+    [
+      try 
+	Functional_principles_types.build_scheme fas
+      with Functional_principles_types.No_graph_found -> 
+	match fas with 
+	  | (_,fun_name,_)::_ -> 
+	      begin
+		make_graph (Nametab.global fun_name);
+		try Functional_principles_types.build_scheme fas
+		with Functional_principles_types.No_graph_found -> 
+		  Util.error ("Cannot generate induction principle(s)")
+	      end
+	  | _ -> assert false (* we can only have non empty  list *)
+    ]
+END
+(***** debug only ***)
+
+VERNAC COMMAND EXTEND NewFunctionalCase
+   ["Functional" "Case" fun_scheme_arg(fas) ] ->
+    [
+      Functional_principles_types.build_case_scheme fas
+    ]
+END
+
+(***** debug only ***)
+VERNAC COMMAND EXTEND GenerateGraph 
+["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ]
+END
+
+
+
+
+
+(* FINDUCTION *)
+
+(* comment this line to see debug msgs *)
+let msg x = () ;; let pr_lconstr c = str ""
+  (* uncomment this to see debugging *)
+let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
+let prlistconstr lc = List.iter prconstr lc
+let prstr s = msg(str s)
+let prNamedConstr s c = 
+  begin
+    msg(str "");
+    msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n");
+    msg(str "");
+  end
+
+
+
+(** Information about an occurrence of a function call (application)
+    inside a term. *)
+type fapp_info = {
+  fname: constr; (** The function applied *)
+  largs: constr list; (** List of arguments *)
+  free: bool; (** [true] if all arguments are debruijn free *)
+  max_rel: int; (** max debruijn index in the funcall *)
+  onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *)
+}
+
+
+(** [constr_head_match(a b c) a] returns true, false otherwise. *)
+let constr_head_match u t=
+  if isApp u 
+  then 
+    let uhd,args= destApp u in
+    uhd=t
+  else false
+
+(** [hdMatchSub inu t] returns the list of occurrences of [t] in
+    [inu]. DeBruijn are not pushed, so some of them may be unbound in
+    the result. *)
+let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
+  let subres = 
+    match kind_of_term inu with
+      | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> 
+	  hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test
+      | Fix (_,(lna,tl,bl))  -> (* not sure Fix is correct *)
+	  Array.fold_left 
+	    (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) 
+	    [] bl
+      | _ -> (* Cofix will be wrong *)
+	  fold_constr 
+	    (fun l cstr -> 
+	      l @ hdMatchSub cstr test) [] inu in 
+  if not (test inu) then subres
+  else
+    let f,args = decompose_app inu in
+    let freeset = Termops.free_rels inu in
+    let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in
+    {fname = f; largs = args; free = Util.Intset.is_empty freeset;
+    max_rel = max_rel; onlyvars = List.for_all isVar args } 
+    ::subres
+
+let mkEq typ c1 c2 = 
+  mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|])
+
+
+let poseq_unsafe idunsafe cstr gl =
+  let typ = Tacmach.pf_type_of gl cstr in
+  tclTHEN
+    (Tactics.letin_tac true (Name idunsafe) cstr allClauses)
+    (tclTHENFIRST 
+      (Tactics.assert_as true IntroAnonymous (mkEq typ (mkVar idunsafe) cstr)) 
+      Tactics.reflexivity)
+    gl
+  
+
+let poseq id cstr gl =
+  let x = Tactics.fresh_id [] id gl in
+  poseq_unsafe x cstr gl
+
+(* dirty? *)
+
+let list_constr_largs = ref []
+
+let rec poseq_list_ids_rec lcstr gl =
+  match lcstr with
+    | [] -> tclIDTAC gl
+    | c::lcstr' -> 
+	match kind_of_term c with
+	  | Var _ -> 
+	      (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl)
+	  | _ -> 
+	      let _ = prstr "c = " in
+	      let _ = prconstr c in
+	      let _ = prstr "\n" in
+	      let typ = Tacmach.pf_type_of gl c in
+	      let cname = Termops.id_of_name_using_hdchar (Global.env()) typ Anonymous in
+	      let x = Tactics.fresh_id [] cname gl in
+	      let _ = list_constr_largs:=mkVar x :: !list_constr_largs in
+	      let _ = prstr " list_constr_largs = " in
+	      let _ = prlistconstr !list_constr_largs in
+	      let _ = prstr "\n" in
+
+	      tclTHEN
+		(poseq_unsafe x c)
+		(poseq_list_ids_rec lcstr')
+		gl
+
+let poseq_list_ids lcstr gl = 
+  let _ = list_constr_largs := [] in
+  poseq_list_ids_rec lcstr gl
+
+(** [find_fapp test g] returns the list of [app_info] of all calls to
+    functions that satisfy [test] in the conclusion of goal g. Trivial
+    repetition (not modulo conversion) are deleted. *)
+let find_fapp (test:constr -> bool) g : fapp_info list = 
+  let pre_res = hdMatchSub (Tacmach.pf_concl g) test in
+  let res = 
+    List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in
+  (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res);
+  res)
+
+
+
+(** [finduction id filter g] tries to apply functional induction on
+    an occurence of function [id] in the conclusion of goal [g]. If
+    [id]=[None] then calls to any function are selected. In any case
+    [heuristic] is used to select the most pertinent occurrence. *)
+let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list)
+    (nexttac:Proof_type.tactic) g =
+  let test = match oid with
+    | Some id -> 
+	let idconstr = mkConst (const_of_id id) in
+	(fun u -> constr_head_match u idconstr) (* select only id *)
+    | None -> (fun u -> isApp u) in (* select calls to any function *)
+  let info_list = find_fapp test g in
+  let ordered_info_list = heuristic info_list in
+  prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); 
+  if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
+  let taclist: Proof_type.tactic list = 
+    List.map 
+      (fun info ->
+	(tclTHEN
+	  (tclTHEN (poseq_list_ids info.largs)
+	    (
+	      fun gl -> 
+		  (functional_induction 
+		    true (applist (info.fname, List.rev !list_constr_largs)) 
+		    None IntroAnonymous) gl)) 
+	  nexttac)) ordered_info_list in
+  (* we try each (f t u v) until one does not fail *)
+  (* TODO: try also to mix functional schemes *)
+  tclFIRST taclist g
+
+
+
+
+(** [chose_heuristic oi x] returns the heuristic for reordering
+    (and/or forgetting some elts of) a list of occurrences of
+     function calls infos to chose first with functional induction. *)
+let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
+  match oi with
+    | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *)
+    | None -> 
+	(* Default heuristic: put first occurrences where all arguments
+	   are *bound* (meaning already introduced) variables *)
+	let ordering x y =
+	  if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *)
+	  else if x.free && x.onlyvars then -1
+	  else if y.free && y.onlyvars then 1
+	  else 0 (* both not pertinent *)
+	in
+	List.sort ordering
+
+
+
+TACTIC EXTEND finduction
+    ["finduction" ident(id) natural_opt(oi)] -> 
+      [ 
+	match oi with
+	  | Some(n) when n<=0 -> Util.error "numerical argument must be > 0"
+	  | _ -> 
+	      let heuristic = chose_heuristic oi in
+	      finduction (Some id) heuristic tclIDTAC
+      ]
+END
+
+
+
+TACTIC EXTEND fauto
+    [ "fauto" tactic(tac)] -> 
+      [
+	let heuristic = chose_heuristic None in
+	finduction None heuristic (snd tac)
+      ]
+  |
+    [ "fauto" ] -> 
+      [
+	let heuristic = chose_heuristic None in
+	finduction None heuristic tclIDTAC
+      ]
+
+END
+
+
+TACTIC EXTEND poseq
+  [ "poseq" ident(x) constr(c) ] -> 
+      [ poseq x c ]
+END
+
+VERNAC COMMAND EXTEND Showindinfo
+  [ "showindinfo" ident(x) ] -> [ Merge.showind x ]
+END
+
+VERNAC COMMAND EXTEND MergeFunind
+  [ "Mergeschemes" lconstr(c) "with" lconstr(c') "using" ident(id) ] -> 
+     [ 
+       let c1 = Constrintern.interp_constr Evd.empty (Global.env()) c in
+       let c2 = Constrintern.interp_constr Evd.empty (Global.env()) c' in
+       let id1,args1 = 
+	 try 
+	   let hd,args = destApp c1 in
+	   if Term.isInd hd then hd , args 
+	   else raise (Util.error "Ill-formed (fst) argument")
+	 with Invalid_argument _ 
+	     -> Util.error ("Bad argument form for merging schemes") in
+       let id2,args2 = 
+	 try
+ 	   let hd,args = destApp c2 in
+	   if isInd hd then hd , args 
+	   else raise (Util.error "Ill-formed (snd) argument")
+	 with Invalid_argument _ 
+	     -> Util.error ("Bad argument form for merging schemes") in
+       (* TOFO: enlever le ignore et declarer l'inductif *)
+       ignore(Merge.merge c1 c2 args1 args2 id)
+     ]
+END
diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml
new file mode 100644
index 00000000..04110ea9
--- /dev/null
+++ b/contrib/funind/invfun.ml
@@ -0,0 +1,993 @@
+(************************************************************************)
+(*  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 Tacexpr
+open Declarations
+open Util
+open Names
+open Term
+open Pp
+open Libnames
+open Tacticals
+open Tactics
+open Indfun_common
+open Tacmach
+open Sign
+open Hiddentac
+
+(* Some pretty printing function for debugging purpose *)
+
+let pr_binding prc  = 
+  function
+    | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
+
+let pr_bindings prc prlc = function
+  | Rawterm.ImplicitBindings l ->
+      brk (1,1) ++ str "with" ++ brk (1,1) ++
+      Util.prlist_with_sep spc prc l
+  | Rawterm.ExplicitBindings l ->
+      brk (1,1) ++ str "with" ++ brk (1,1) ++ 
+        Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
+  | Rawterm.NoBindings -> mt ()
+
+
+let pr_with_bindings prc prlc (c,bl) =
+  prc c ++ hv 0 (pr_bindings prc prlc bl)
+
+
+
+let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds = 
+  pr_with_bindings prc prc  (c,bl)
+
+(* The local debuging mechanism *)
+let msgnl = Pp.msgnl
+
+let observe strm =
+  if do_observe ()
+  then Pp.msgnl strm
+  else ()
+
+let observennl strm =
+  if do_observe ()
+  then begin Pp.msg strm;Pp.pp_flush () end
+  else ()
+
+
+let do_observe_tac s tac g =
+ try    let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
+ let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
+ with e ->
+   let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
+   msgnl (str "observation "++ s++str " raised exception " ++ 
+	    Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
+   raise e;;
+
+
+let observe_tac s tac g =
+  if do_observe ()
+  then do_observe_tac (str s) tac g
+  else tac g
+
+(* [nf_zeta] $\zeta$-normalization of a term *)
+let nf_zeta =       
+  Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+    Environ.empty_env
+    Evd.empty
+
+
+(* [id_to_constr id] finds the term associated to [id] in the global environment *)
+let id_to_constr id = 
+  try
+    Tacinterp.constr_of_id (Global.env ())  id
+  with Not_found -> 
+    raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id))
+
+(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] 
+   (resp. g_to_f = false) where [graph]  is the graph of [f] and is the [i]th function in the block. 
+
+   [generate_type true f i] returns 
+   \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, 
+   graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion 
+
+   [generate_type false f i] returns 
+   \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, 
+   res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion 
+ *)
+
+let generate_type g_to_f f graph i = 
+  (*i we deduce the number of arguments of the function and its returned type from the graph i*)
+  let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph))  in 
+  let ctxt,_ = decompose_prod_assum graph_arity in 
+  let fun_ctxt,res_type = 
+    match ctxt with 
+      | [] | [_] -> anomaly "Not a valid context"
+      | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
+  in
+  let nb_args = List.length fun_ctxt in
+  let args_from_decl i decl = 
+    match decl with 
+      | (_,Some _,_) -> incr i; failwith "args_from_decl"
+      | _ -> let j = !i in incr i;mkRel (nb_args - j  + 1) 
+  in
+  (*i We need to name the vars [res] and [fv] i*)
+  let res_id = 
+    Termops.next_global_ident_away 
+      true
+      (id_of_string "res")
+      (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
+  in
+  let fv_id = 
+    Termops.next_global_ident_away 
+      true
+      (id_of_string "fv")
+      (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt))
+  in
+  (*i we can then type the argument to be applied to the function [f] i*)
+  let args_as_rels = 
+    let i = ref 0 in
+    Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) 
+  in
+  let args_as_rels = Array.map Termops.pop args_as_rels in
+  (*i
+    the hypothesis [res = fv] can then be computed 
+    We will need to lift it by one in order to use it as a conclusion 
+    i*)
+  let res_eq_f_of_args =
+    mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
+  in 
+  (*i 
+    The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed 
+    We will need to lift it by one in order to use it as a conclusion 
+    i*)  
+  let graph_applied = 
+    let args_and_res_as_rels = 
+      let i = ref 0 in
+      Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) )
+    in
+    let args_and_res_as_rels = 
+      Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels
+    in
+    mkApp(graph,args_and_res_as_rels) 
+  in 
+  (*i The [pre_context]  is the defined to be the context corresponding to 
+    \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,  \]
+    i*)
+  let pre_ctxt = 
+    (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt 
+  in 
+  (*i and we can return the solution depending on which lemma type we are defining i*)
+  if g_to_f 
+  then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args)
+  else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied)
+
+
+(* 
+   [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect]
+   
+   WARNING: while convertible, [type_of body] and [type] can be non equal
+*)
+let find_induction_principle f = 
+  let f_as_constant =  match kind_of_term f with  
+    | Const c' -> c'
+    | _ -> error "Must be used with a function"
+  in
+  let infos = find_Function_infos f_as_constant in 
+  match infos.rect_lemma with 
+    | None -> raise Not_found 
+    | Some rect_lemma -> 
+	let rect_lemma = mkConst rect_lemma in 
+	let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in 
+	rect_lemma,typ
+	
+  
+
+(*     let fname =  *)
+(*       match kind_of_term f with  *)
+(* 	| Const c' ->  *)
+(* 	    id_of_label (con_label c')  *)
+(* 	| _ -> error "Must be used with a function"  *)
+(*     in *)
+
+(*     let princ_name =  *)
+(*       ( *)
+(* 	Indrec.make_elimination_ident *)
+(* 	  fname *)
+(* 	  InType *)
+(*       ) *)
+(*     in *)
+(*     let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in  *\) failwith "" in  *)
+(*     c,Typing.type_of (Global.env ()) Evd.empty c *)
+
+
+let rec generate_fresh_id x avoid i = 
+  if i == 0 
+  then [] 
+  else
+    let id = Termops.next_global_ident_away true x avoid in 
+    id::(generate_fresh_id x (id::avoid) (pred i))
+
+
+(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] 
+   is the tactic used to prove correctness lemma. 
+   
+   [functional_induction] is the tactic defined in [indfun] (dependency problem)
+   [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions
+   (resp. graphs of the functions and principles and correctness lemma types) to prove correct. 
+   
+   [i] is the indice of the function to prove correct
+
+   The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is 
+   it looks like~:
+   [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, 
+   res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res]
+
+
+   The sketch of the proof is the following one~: 
+   \begin{enumerate}
+   \item intros until $x_n$
+   \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i)
+   \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the 
+   apply the corresponding constructor of the corresponding graph inductive.
+   \end{enumerate}
+   
+*)
+let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
+  fun g ->
+    (* first of all we recreate the lemmas types to be used as predicates of the induction principle 
+       that is~:
+       \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun  fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
+    *)
+    let lemmas =
+      Array.map
+	(fun (_,(ctxt,concl)) ->
+	   match ctxt with
+	     | [] | [_] | [_;_] -> anomaly "bad context"
+	     | hres::res::(x,_,t)::ctxt ->
+		 Termops.it_mkLambda_or_LetIn
+		   ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res])
+		   ((x,None,t)::ctxt)
+	)
+	lemmas_types_infos
+    in
+    (* we the get the definition of the graphs block *)
+    let graph_ind = destInd graphs_constr.(i) in
+    let kn = fst graph_ind in 
+    let mib,_ = Global.lookup_inductive graph_ind in 
+    (* and the principle to use in this lemma in $\zeta$ normal form *)
+    let f_principle,princ_type = schemes.(i) in
+    let princ_type =  nf_zeta princ_type in
+    let princ_infos = Tactics.compute_elim_sig princ_type in
+    (* The number of args of the function is then easilly computable *)
+    let nb_fun_args = nb_prod (pf_concl g)  - 2  in
+    let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
+    let ids = args_names@(pf_ids_of_hyps g) in
+    (* Since we cannot ensure that the funcitonnal principle is defined in the 
+       environement and due to the bug #1174, we will need to pose the principle
+       using a name 
+    *)
+    let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in
+    let ids = principle_id :: ids in
+    (* We get the branches of the principle *)
+    let branches = List.rev princ_infos.branches in
+    (* and built the intro pattern for each of them *)
+    let intro_pats =
+      List.map
+	(fun (_,_,br_type) ->
+	   List.map
+	     (fun id -> Genarg.IntroIdentifier id)
+	     (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
+	)
+	branches
+    in
+    (* before building the full intro pattern for the principle *)
+    let pat = Genarg.IntroOrAndPattern intro_pats in
+    let eq_ind = Coqlib.build_coq_eq () in
+    let eq_construct = mkConstruct((destInd eq_ind),1) in
+    (* The next to referencies will be used to find out which constructor to apply in each branch *)
+    let ind_number = ref 0 
+    and min_constr_number = ref 0 in 
+    (* The tactic to prove the ith branch of the principle *)
+    let prove_branche i g =
+      (* We get the identifiers of this branch *)
+      let this_branche_ids =
+	List.fold_right
+	  (fun pat acc ->
+	     match pat with
+	       | Genarg.IntroIdentifier id -> Idset.add id acc
+	       | _ -> anomaly "Not an identifier"
+	  )
+	  (List.nth intro_pats (pred i))
+	  Idset.empty
+      in
+      (* and get the real args of the branch by unfolding the defined constant *)
+      let pre_args,pre_tac =
+	List.fold_right
+	  (fun (id,b,t) (pre_args,pre_tac) ->
+	     if Idset.mem id this_branche_ids
+	     then
+	       match b with
+		 | None -> (id::pre_args,pre_tac)
+		 | Some b ->
+		     (pre_args,
+		      tclTHEN (h_reduce (Rawterm.Unfold([[],EvalVarRef id])) allHyps) pre_tac
+		     )
+		     
+	     else (pre_args,pre_tac)
+	  )
+	  (pf_hyps g)
+	  ([],tclIDTAC)
+      in
+      (* 
+	 We can then recompute the arguments of the constructor. 
+	 For each [hid] introduced by this branch, if [hid] has type  
+	 $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
+	 [ fv (hid fv (refl_equal fv)) ]. 
+	 
+	 If [hid] has another type the corresponding argument of the constructor is [hid]
+      *)
+      let constructor_args =
+	List.fold_right
+	  (fun hid acc ->
+	     let type_of_hid = pf_type_of g (mkVar hid) in
+	     match kind_of_term type_of_hid with
+	       | Prod(_,_,t') ->
+		   begin
+		     match kind_of_term t' with
+		       | Prod(_,t'',t''') ->
+			   begin
+			     match kind_of_term t'',kind_of_term t''' with
+			       | App(eq,args), App(graph',_)
+				   when
+				     (eq_constr eq eq_ind) &&
+				       array_exists  (eq_constr graph') graphs_constr ->
+				   ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
+				    ::args.(2)::acc)
+			       | _ -> mkVar hid ::  acc
+			   end
+		       | _ -> mkVar hid :: acc
+		   end
+	       | _ -> mkVar hid :: acc
+	  ) pre_args []
+      in
+      (* in fact we must also add the parameters to the constructor args *)
+      let constructor_args =
+	let params_id = fst (list_chop princ_infos.nparams args_names) in
+	(List.map mkVar params_id)@(List.rev constructor_args)
+      in
+      (* We then get the constructor corresponding to this branch and 
+	 modifies the references has needed i.e. 
+	 if the constructor is the last one of the current inductive then 
+	 add one the number of the inductive to take and add the number of constructor of the previous 
+	 graph to the minimal constructor number 
+      *)
+      let constructor = 
+	let constructor_num = i - !min_constr_number in 
+	let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in 
+	if constructor_num <= length
+	then 
+	  begin 
+	    (kn,!ind_number),constructor_num
+	  end
+	else 
+	  begin
+	    incr ind_number;
+	    min_constr_number := !min_constr_number + length ;
+	    (kn,!ind_number),1
+	  end
+      in
+      (* we can then build the final proof term *)
+      let app_constructor = applist((mkConstruct(constructor)),constructor_args) in
+      (* an apply the tactic *)
+      let res,hres =
+	match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with
+	  | [res;hres] -> res,hres
+	  | _ -> assert false
+      in
+      observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor);
+      (
+	tclTHENSEQ
+	  [
+	    (* unfolding of all the defined variables introduced by this branch *)
+	    observe_tac "unfolding" pre_tac;
+	    (* $zeta$ normalizing of the conclusion *)
+	    h_reduce
+	      (Rawterm.Cbv
+		 { Rawterm.all_flags with
+		     Rawterm.rDelta = false ;
+		     Rawterm.rConst = []
+		 }
+	      )
+	      onConcl;
+	    (* introducing the the result of the graph and the equality hypothesis *)
+	    observe_tac "introducing" (tclMAP h_intro [res;hres]);
+	    (* replacing [res] with its value *)
+	    observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres));
+	    (* Conclusion *)
+	    observe_tac "exact" (h_exact app_constructor)
+	  ]
+      )
+	g
+    in
+    (* end of branche proof *)
+    let param_names = fst (list_chop princ_infos.nparams args_names) in
+    let params = List.map mkVar param_names in
+    let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
+    (* The bindings of the principle 
+       that is the params of the principle and the different lemma types 
+    *)
+    let bindings =
+      let params_bindings,avoid =
+	List.fold_left2
+	  (fun (bindings,avoid) (x,_,_) p ->
+	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in
+	     (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid
+	  )
+	  ([],pf_ids_of_hyps g)
+	  princ_infos.params
+	  (List.rev params)
+      in
+      let lemmas_bindings =
+	List.rev (fst  (List.fold_left2
+	  (fun (bindings,avoid) (x,_,_) p ->
+	     let id = Nameops.next_ident_away (Nameops.out_name x) avoid in 
+	     (dummy_loc,Rawterm.NamedHyp id,nf_zeta p)::bindings,id::avoid)
+	  ([],avoid)
+	  princ_infos.predicates
+	  (lemmas)))
+      in
+      Rawterm.ExplicitBindings (params_bindings@lemmas_bindings)
+    in
+    tclTHENSEQ
+      [ observe_tac "intro args_names" (tclMAP h_intro args_names);
+	observe_tac "principle" (forward
+	  (Some (h_exact f_principle))
+	  (Genarg.IntroIdentifier principle_id)
+	  princ_type);
+	tclTHEN_i
+	  (observe_tac "functional_induction" (
+	     fun g -> 
+	       observe
+		 (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g))  (mkVar principle_id,bindings));
+	       functional_induction  false (applist(funs_constr.(i),List.map mkVar args_names))
+		 (Some (mkVar principle_id,bindings))
+		 pat g
+	   ))
+	  (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g )
+      ]
+      g
+
+(* [generalize_depedent_of x hyp g] 
+   generalize every hypothesis which depends of [x] but [hyp] 
+*)
+let generalize_depedent_of x hyp g = 
+  tclMAP 
+    (function 
+       | (id,None,t) when not (id = hyp) && 
+	   (Termops.occur_var (pf_env g) x t) -> h_generalize [mkVar id]
+       | _ -> tclIDTAC
+    )
+    (pf_hyps g)
+    g
+
+
+
+
+
+
+let rec reflexivity_with_destruct_cases g = 
+  let destruct_case () = 
+    try 
+      match kind_of_term (snd (destApp (pf_concl g))).(2) with 
+	| Case(_,_,v,_) -> 
+	    tclTHENSEQ[
+	      h_case (v,Rawterm.NoBindings);
+	      intros;
+	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases 
+	    ]
+	| _ -> reflexivity
+    with _ -> reflexivity
+  in
+  tclFIRST
+    [ reflexivity;
+      destruct_case ()
+    ]
+    g
+
+
+(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] 
+   is the tactic used to prove completness lemma. 
+   
+   [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions
+   (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. 
+   
+   [i] is the indice of the function to prove complete
+
+   The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is 
+   it looks like~:
+   [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, 
+   graph\ x_1\ldots x_n\ res, \rightarrow  res = f x_1\ldots x_n in]
+
+
+   The sketch of the proof is the following one~: 
+   \begin{enumerate}
+   \item intros until $H:graph\ x_1\ldots x_n\ res$
+   \item $elim\ H$ using schemes.(i)
+   \item for each generated branch, intro  the news hyptohesis, for each such hyptohesis [h], if [h] has 
+   type [x=?] with [x] a variable, then subst [x], 
+   if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else 
+   if [h] is a match then destruct it, else do just introduce it, 
+   after all intros, the conclusion should be a reflexive equality.
+   \end{enumerate}
+   
+*)
+
+
+let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = 
+  fun g ->  
+    (* We compute the types of the different mutually recursive lemmas 
+       in $\zeta$ normal form
+    *)
+    let lemmas = 
+      Array.map 
+	(fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) 
+	lemmas_types_infos
+    in
+    (* We get the constant and the principle corresponding to this lemma *)
+    let f = funcs.(i) in
+    let graph_principle = nf_zeta schemes.(i)  in 
+    let princ_type = pf_type_of g graph_principle in 
+    let princ_infos = Tactics.compute_elim_sig princ_type in 
+    (* Then we get the number of argument of the function 
+       and compute a fresh name for each of them
+    *)
+    let nb_fun_args = nb_prod (pf_concl g)  - 2  in 
+    let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
+    let ids = args_names@(pf_ids_of_hyps g) in
+    (* and fresh names for res H and the principle (cf bug bug #1174) *)
+    let res,hres,graph_principle_id = 
+      match generate_fresh_id (id_of_string "z") ids 3 with 
+	| [res;hres;graph_principle_id] -> res,hres,graph_principle_id
+	| _ -> assert false 
+    in
+    let ids = res::hres::graph_principle_id::ids in 
+    (* we also compute fresh names for each hyptohesis of each branche of the principle *)
+    let branches = List.rev princ_infos.branches in 
+    let intro_pats = 
+      List.map 
+	(fun (_,_,br_type) -> 
+	   List.map 
+	     (fun id -> id) 
+	     (generate_fresh_id (id_of_string "y") ids (nb_prod br_type))
+	)
+	branches
+    in
+    let eq_ind = Coqlib.build_coq_eq () in 
+    (* We will need to change the function by its body 
+       using [f_equation] if it is recursive (that is the graph is infinite 
+       or unfold if the graph is finite 
+    *)
+    let rewrite_tac j ids : tactic = 
+      let graph_def = graphs.(j) in 
+      let infos =  try find_Function_infos (destConst funcs.(j)) with Not_found ->  error "No graph found" in 
+      if infos.is_general ||  Rtree.is_infinite graph_def.mind_recargs
+      then 
+	let eq_lemma = 
+	  try out_some (infos).equation_lemma
+	  with Failure "out_some"  -> anomaly "Cannot find equation lemma"
+	in 
+	tclTHENSEQ[
+	  tclMAP h_intro ids;
+	  Equality.rewriteLR (mkConst eq_lemma);
+	  (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *)
+	  h_reduce 
+	    (Rawterm.Cbv
+	       {Rawterm.all_flags 
+		with Rawterm.rDelta = false; 		 
+	       }) 
+	    onConcl
+	  ;
+	  h_generalize (List.map mkVar ids);
+	  thin ids
+	]
+      else unfold_in_concl [([],Names.EvalConstRef (destConst f))]
+    in
+    (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis 
+       (unfolding, substituting, destructing cases \ldots)
+    *)
+    let rec intros_with_rewrite_aux : tactic = 
+      fun g -> 
+	match kind_of_term (pf_concl g) with 
+	  | Prod(_,t,t') -> 
+	      begin 
+		match kind_of_term t with 
+		  | App(eq,args) when (eq_constr eq eq_ind) -> 
+		      if isVar args.(1)
+		      then 			
+			let id = pf_get_new_id (id_of_string "y") g  in 
+			tclTHENSEQ [ h_intro id;
+				     generalize_depedent_of (destVar args.(1)) id; 
+				     tclTRY (Equality.rewriteLR (mkVar id));
+				     intros_with_rewrite
+				   ] 
+			  g
+		      else
+			begin 
+			  let id = pf_get_new_id (id_of_string "y") g  in 
+			  tclTHENSEQ[
+			    h_intro id;
+			    tclTRY (Equality.rewriteLR (mkVar id));
+			    intros_with_rewrite
+			  ] g
+			end
+		  | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> 
+		      Tauto.tauto g
+		  | Case(_,_,v,_) -> 
+		      tclTHENSEQ[
+			h_case (v,Rawterm.NoBindings);
+			intros_with_rewrite
+		      ] g
+		  | LetIn _ -> 
+		      tclTHENSEQ[
+			h_reduce 
+			  (Rawterm.Cbv
+			     {Rawterm.all_flags 
+			      with Rawterm.rDelta = false; 		 
+			     }) 
+			  onConcl
+			;
+			intros_with_rewrite
+		      ] g
+		  | _ -> 			
+		      let id = pf_get_new_id (id_of_string "y") g  in 
+		      tclTHENSEQ [ h_intro id;intros_with_rewrite] g
+	      end
+	  | LetIn _ -> 
+	      tclTHENSEQ[
+		h_reduce 
+		  (Rawterm.Cbv
+		     {Rawterm.all_flags 
+		      with Rawterm.rDelta = false; 		 
+		     }) 
+		  onConcl
+		;
+		intros_with_rewrite
+	      ] g
+	  | _ -> tclIDTAC g 
+    and intros_with_rewrite g = 
+      observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
+    in
+    (* The proof of each branche itself *)
+    let ind_number = ref 0 in 
+    let min_constr_number = ref 0 in
+    let prove_branche i g = 
+      (* we fist compute the inductive corresponding to the branch *)
+      let this_ind_number = 
+	let constructor_num = i - !min_constr_number in 
+	let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in 
+	if constructor_num <= length
+	then !ind_number
+	else 
+	  begin
+	    incr ind_number;
+	    min_constr_number := !min_constr_number + length;
+	    !ind_number
+	  end
+      in
+      let this_branche_ids = List.nth intro_pats (pred i) in
+      tclTHENSEQ[
+	(* we expand the definition of the function *)
+        observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
+	(* introduce hypothesis with some rewrite *)
+        (intros_with_rewrite);
+	(* The proof is (almost) complete *)
+        observe_tac "reflexivity" (reflexivity_with_destruct_cases)
+      ]
+	g
+    in
+    let params_names = fst (list_chop princ_infos.nparams args_names) in
+    let params = List.map mkVar params_names in 
+    tclTHENSEQ 
+      [ tclMAP h_intro (args_names@[res;hres]);
+	observe_tac "h_generalize" 
+	(h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
+	h_intro graph_principle_id;
+	observe_tac "" (tclTHEN_i 
+	  (observe_tac "elim" ((elim (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
+	  (fun i g -> prove_branche i g ))
+      ]
+      g
+
+
+
+
+let do_save () = Command.save_named false
+
+
+(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness 
+   lemmas for each function in [funs] w.r.t. [graphs]
+   
+   [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and 
+   [functional_induction] is Indfun.functional_induction (same pb) 
+*)
+   
+let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = 
+  let funs = Array.of_list funs and graphs = Array.of_list graphs in
+  let funs_constr = Array.map mkConst funs  in
+  try 
+    let graphs_constr = Array.map mkInd graphs in 
+    let lemmas_types_infos = 
+      Util.array_map2_i 
+	(fun i f_constr graph -> 
+	   let const_of_f = destConst f_constr in 
+	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = 
+	     generate_type false const_of_f graph i
+	   in 
+	   let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in 
+	   let type_of_lemma = nf_zeta type_of_lemma in
+	   observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
+	   type_of_lemma,type_info
+	)
+	funs_constr
+	graphs_constr 
+    in
+    let schemes = 
+      (* The functional induction schemes are computed and not saved if there is more that one function 
+	 if the block contains only one function we can safely reuse [f_rect]
+      *)
+      try
+	if Array.length funs_constr <> 1 then raise Not_found;
+	[| find_induction_principle funs_constr.(0) |]
+      with Not_found -> 
+	  Array.of_list 
+	    (List.map 
+	       (fun entry -> 
+		  (entry.Entries.const_entry_body, out_some entry.Entries.const_entry_type )
+	       )
+	       (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs))
+	    )
+    in
+    let proving_tac = 
+      prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos
+    in
+    Array.iteri 
+      (fun i f_as_constant -> 
+	 let f_id = id_of_label (con_label f_as_constant) in
+	 Command.start_proof 
+	   (*i The next call to mk_correct_id is valid since we are constructing the lemma
+	     Ensures by: obvious
+	     i*) 
+	   (mk_correct_id f_id)
+	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
+	   (fst lemmas_types_infos.(i))
+	   (fun _ _ -> ());
+	 Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i));
+	 do_save ();
+	 let finfo = find_Function_infos f_as_constant in 
+	 update_Function
+	   {finfo with 
+	      correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id)))
+	   }
+
+      )
+      funs;
+    let lemmas_types_infos = 
+      Util.array_map2_i 
+	(fun i f_constr graph -> 
+	   let const_of_f = destConst f_constr in 
+	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = 
+	     generate_type true  const_of_f graph i
+	   in 
+	   let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in 
+	   let type_of_lemma = nf_zeta type_of_lemma in
+	   observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
+	   type_of_lemma,type_info
+	)
+	funs_constr
+	graphs_constr 
+    in
+    let kn,_ as graph_ind  = destInd graphs_constr.(0) in 
+    let  mib,mip = Global.lookup_inductive graph_ind in
+    let schemes = 
+      Array.of_list 
+	(Indrec.build_mutual_indrec (Global.env ()) Evd.empty
+	   (Array.to_list 
+	      (Array.mapi
+		 (fun i mip -> (kn,i),mib,mip,true,InType)
+		 mib.Declarations.mind_packets
+	      )
+	   )
+	)
+    in
+    let proving_tac = 
+      prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos
+    in
+    Array.iteri 
+      (fun i f_as_constant -> 
+	 let f_id = id_of_label (con_label f_as_constant) in
+	 Command.start_proof 
+	   (*i The next call to mk_complete_id is valid since we are constructing the lemma
+	     Ensures by: obvious
+	     i*) 
+	   (mk_complete_id f_id)
+	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
+	   (fst lemmas_types_infos.(i))
+	   (fun _ _ -> ());
+	 Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i));
+	 do_save ();
+	 let finfo = find_Function_infos f_as_constant in 
+	 update_Function
+	   {finfo with 
+	      completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id)))
+	   }
+      )
+      funs;
+  with e ->
+    (* In case of problem, we reset all the lemmas *)
+    (*i The next call to mk_correct_id is valid since we are erasing the lemmas
+      Ensures by: obvious
+      i*) 
+    let first_lemma_id = 
+      let f_id = id_of_label (con_label funs.(0)) in 
+      
+      mk_correct_id f_id 
+    in
+     ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ());
+    raise e
+	   
+		   
+
+
+
+(***********************************************)
+
+(* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res
+   when [kn] denotes a graph block  into
+   f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result 
+   
+   if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing
+*)
+let revert_graph kn post_tac hid g =
+    let typ = pf_type_of g (mkVar hid) in 
+    match kind_of_term typ with 
+      | App(i,args) when isInd i -> 
+	  let ((kn',num) as ind') = destInd i in 
+	  if kn = kn' 
+	  then (* We have generated a graph hypothesis so that we must change it if we can *)
+	    let info = 
+	      try find_Function_of_graph ind'
+	      with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
+		anomaly "Cannot retrieve infos about a mutual block"
+	    in 
+	    (* if we can find a completeness lemma for this function 
+	       then we can come back to the functional form. If not, we do nothing 
+	    *)
+	    match info.completeness_lemma with 
+	      | None -> tclIDTAC g
+	      | Some f_complete -> 
+		  let f_args,res = array_chop (Array.length args - 1) args in
+		  tclTHENSEQ
+		    [
+		      h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
+		      thin [hid];
+		      h_intro hid; 
+		      post_tac hid
+		    ]
+		    g
+		    
+	  else tclIDTAC g
+      | _ -> tclIDTAC g
+
+
+(* 
+   [functional_inversion hid fconst f_correct ] is the functional version of [inversion]
+   
+   [hid] is the hypothesis to invert, [fconst] is the function to invert and  [f_correct]
+   is the correctness lemma for [fconst].
+
+   The sketch is the follwing~: 
+   \begin{enumerate} 
+   \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ 
+   (fails if it is not possible)
+   \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct]
+   \item apply [inversion] on [hid]
+   \item finally in each branch, replace each  hypothesis [R\_f ..]  by [f ...] using [f_complete] (whenever 
+   such a lemma exists)
+   \end{enumerate}
+*)
+     
+let functional_inversion kn hid fconst f_correct : tactic = 
+  fun g -> 
+    let old_ids = List.fold_right Idset.add  (pf_ids_of_hyps g) Idset.empty in 
+    let type_of_h = pf_type_of g (mkVar hid) in 
+    match kind_of_term type_of_h with 
+      | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ())  -> 
+	  let pre_tac,f_args,res = 
+	    match kind_of_term args.(1),kind_of_term args.(2) with 
+	      | App(f,f_args),_ when eq_constr f fconst -> 
+		  ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2))
+	      |_,App(f,f_args) when eq_constr f fconst -> 
+		 ((fun hid -> tclIDTAC),f_args,args.(1)) 
+	      | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
+	  in 
+	  tclTHENSEQ[
+	    pre_tac hid;
+	    h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
+	    thin [hid];
+	    h_intro hid;
+	    Inv.inv FullInversion Genarg.IntroAnonymous (Rawterm.NamedHyp hid);
+	    (fun g ->
+	       let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in 
+	       tclMAP (revert_graph kn pre_tac)  (hid::new_ids)  g
+	    );
+	  ] g
+      | _ -> tclFAIL 1 (mt ()) g
+
+
+
+let invfun qhyp f  =  
+  let f = 
+    match f with 
+      | ConstRef f -> f 
+      | _ -> raise (Util.UserError("",str "Not a function"))
+  in
+  try 
+    let finfos = find_Function_infos f in 
+    let f_correct = mkConst(out_some finfos.correctness_lemma) 
+    and kn = fst finfos.graph_ind
+    in
+    Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f)  f_correct) qhyp 
+  with 
+    | Not_found ->  error "No graph found" 
+    | Failure "out_some"  -> error "Cannot use equivalence with graph!"
+
+
+let invfun qhyp f g = 
+  match f with 
+    | Some f -> invfun qhyp f g
+    | None -> 
+	Tactics.try_intros_until 
+	  (fun hid g -> 
+	     let hyp_typ = pf_type_of g (mkVar hid)  in 
+	     match kind_of_term hyp_typ with 
+	       | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> 
+		   begin
+		     let f1,_ = decompose_app args.(1) in 
+		     try 
+		       if not (isConst f1) then failwith "";
+		       let finfos = find_Function_infos (destConst f1) in 
+		       let f_correct = mkConst(out_some finfos.correctness_lemma) 
+		       and kn = fst finfos.graph_ind
+		       in
+		       functional_inversion kn hid f1 f_correct g
+		     with | Failure "" | Failure "out_some" | Not_found -> 
+		       try 
+			 let f2,_ = decompose_app args.(2) in 
+			 if not (isConst f2) then failwith "";
+			 let finfos = find_Function_infos (destConst f2) in 
+			 let f_correct = mkConst(out_some finfos.correctness_lemma) 
+			 and kn = fst finfos.graph_ind
+			 in
+			 functional_inversion kn hid  f2 f_correct g
+		       with
+			 | Failure "" -> 
+			     errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function")
+			 | Failure "out_some"  ->  
+			     if do_observe () 
+			     then
+			       error "Cannot use equivalence with graph for any side of the equality"
+			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
+			 | Not_found -> 
+			     if do_observe () 
+			     then
+			       error "No graph found for any side of equality" 
+			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
+		   end
+	       | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
+	  )
+	  qhyp
+	  g
diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml
new file mode 100644
index 00000000..1b796a81
--- /dev/null
+++ b/contrib/funind/merge.ml
@@ -0,0 +1,826 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Merging of induction principles. *)
+
+(*i $Id: i*)
+
+open Util
+open Topconstr
+open Vernacexpr
+open Pp
+open Names
+open Term
+open Declarations
+open Environ
+open Rawterm
+open Rawtermops
+
+(** {1 Utilities}  *)
+
+(** {2 Useful operations on constr and rawconstr} *)
+
+(** Substitutions in constr *)
+let compare_constr_nosub t1 t2 =
+  if compare_constr (fun _ _ -> false) t1 t2 
+  then true
+  else false
+
+let rec compare_constr' t1 t2 =
+  if compare_constr_nosub t1 t2 
+  then true
+  else (compare_constr (compare_constr') t1 t2)
+
+let rec substitterm prof t by_t in_u =
+  if (compare_constr' (lift prof t) in_u)
+  then (lift prof by_t)
+  else map_constr_with_binders succ 
+    (fun i -> substitterm i t by_t) prof in_u
+
+let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
+
+let understand = Pretyping.Default.understand Evd.empty (Global.env())
+
+(** Operations on names and identifiers *)
+let id_of_name = function
+    Anonymous -> id_of_string "H"
+  | Name id   -> id;;
+let name_of_string str = Name (id_of_string str)
+let string_of_name nme = string_of_id (id_of_name nme)
+
+(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
+let isVarf f x = 
+    match x with
+      | RVar (_,x) -> Pervasives.compare x f = 0 
+      | _ -> false
+
+(** [ident_global_exist id] returns true if identifier [id] is linked
+    in global environment. *)
+let ident_global_exist id = 
+  try 
+    let ans = CRef (Libnames.Ident (dummy_loc,id)) in
+    let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
+    true
+  with _ -> false 
+
+(** [next_ident_fresh id] returns a fresh identifier (ie not linked in
+    global env) with base [id]. *)
+let next_ident_fresh (id:identifier) = 
+    let res = ref id in
+    while ident_global_exist !res do res := Nameops.lift_ident !res done;
+    !res
+
+
+(** {2 Debugging} *)
+(* comment this line to see debug msgs *)
+let msg x = () ;; let pr_lconstr c = str ""
+(* uncomment this to see debugging *)
+let prconstr c =  msg (str"  " ++ Printer.pr_lconstr c)
+let prconstrnl c =  msg (str"  " ++ Printer.pr_lconstr c ++ str"\n")
+let prlistconstr lc = List.iter prconstr lc
+let prstr s = msg(str s)
+let prNamedConstr s c = 
+  begin
+    msg(str "");
+    msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} ");
+    msg(str "");
+  end
+let prNamedRConstr s c = 
+  begin
+    msg(str "");
+    msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} ");
+    msg(str "");
+  end
+let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc
+let prNamedLConstr s lc = 
+  begin
+    prstr "[§§§ ";
+    prstr s;
+    prNamedLConstr_aux lc;
+    prstr " §§§]\n";
+  end
+let prNamedLDecl s lc = 
+  begin
+    prstr s; prstr "\n";
+    List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc;
+    prstr "\n";
+  end
+
+let showind (id:identifier) =
+  let cstrid = Tacinterp.constr_of_id (Global.env()) id in
+  let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
+  let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
+  List.iter (fun (nm, optcstr, tp) -> 
+    print_string (string_of_name nm^":");
+    prconstr tp; print_string "\n") 
+    ib1.mind_arity_ctxt;
+  (match ib1.mind_arity with
+    | Monomorphic x ->
+        Printf.printf "arity :"; prconstr x.mind_user_arity
+    | Polymorphic x -> 
+        Printf.printf "arity : universe?");
+  Array.iteri 
+    (fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
+    ib1.mind_user_lc
+
+(** {2 Misc} *)
+
+exception Found of int
+
+(* Array scanning *)
+let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = 
+  try
+    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
+    None
+  with Found i -> Some i
+
+let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
+  try
+    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
+    Array.length arr (* all elt are positive *)
+  with Found i -> i
+
+let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = 
+  let i = ref 0 in 
+  Array.fold_left 
+    (fun acc x -> 
+      let res = f !i acc x in i := !i + 1; res)
+    acc arr
+
+(* Like list_chop but except that [i] is the size of the suffix of [l]. *)
+let list_chop_end i l =
+  let size_prefix = List.length l -i in
+  if size_prefix < 0 then failwith "list_chop_end"
+  else list_chop size_prefix l
+
+let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = 
+  let i = ref 0 in 
+  List.fold_left 
+    (fun acc x -> 
+      let res = f !i acc x in i := !i + 1; res)
+    acc arr
+
+let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = 
+  let i = ref 0 in 
+  List.filter (fun x -> let res = f !i x in i := !i + 1; res) l
+
+
+(** Iteration module *)
+module For = 
+struct
+  let rec map i j (f: int -> 'a)  = if i>j then [] else f i :: (map (i+1) j f)
+  let rec foldup i j (f: 'a -> int -> 'a) acc = 
+    if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc
+  let rec folddown i j (f: 'a -> int -> 'a) acc = 
+    if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc
+  let fold i j = if i<j then foldup i j else folddown i j
+end
+
+
+(** {1 Parameters shifting and linking information} *)
+
+(** This type is used to deal with debruijn linked indices. When a
+    variable is linked to a previous one, we will ignore it and refer
+    to previous one. *)
+type linked_var =
+    | Linked of int
+    | Unlinked
+    | Funres
+
+(** When merging two graphs, parameters may become regular arguments,
+    and thus be shifted. This type describe the result of computing
+    the changes. *)
+type 'a shifted_params =
+    {
+      nprm1:'a;
+      nprm2:'a;
+      prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *)
+      nuprm1:'a;
+      nuprm2:'a;
+      nargs1:'a;
+      nargs2:'a;
+    }
+
+
+let prlinked x =
+  match x with
+    | Linked i -> Printf.sprintf "Linked %d" i
+    | Unlinked -> Printf.sprintf "Unlinked"
+    | Funres -> Printf.sprintf "Funres"
+
+let linkmonad f lnkvar = 
+  match lnkvar with
+    | Linked i -> Linked (f i)
+    | Unlinked -> Unlinked
+    | Funres -> Funres
+
+let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
+
+(* This map is used to deal with debruijn linked indices. *)
+module Link = Map.Make (struct type t = int let compare = Pervasives.compare end)
+
+let pr_links l = 
+  Printf.printf "links:\n";
+  Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l;
+  Printf.printf "_____________\n"
+
+type 'a merged_arg =
+    | Prm_stable of 'a
+    | Prm_linked of 'a
+    | Prm_arg of 'a
+    | Arg_stable of 'a
+    | Arg_linked of 'a
+    | Arg_funres
+
+type merge_infos =
+    {
+      ident:identifier; (* new inductive name *)
+      mib1: mutual_inductive_body;
+      oib1: one_inductive_body; 
+      mib2: mutual_inductive_body;
+      oib2: one_inductive_body; 
+      (* Array of links of the first inductive (should be all stable) *)
+      lnk1: int merged_arg array;
+      (* Array of links of the second inductive (point to the first ind param/args) *)
+      lnk2: int merged_arg array;
+      (* number of rec params of ind1 which remai rec param in merge *)
+      nrecprms1: int;
+      (* number of other rec params of ind1 (which become non parm) *)
+      notherprms1:int;
+      (* number of functional result params of ind2 (which become non parm) *)
+      nfunresprms1:int;
+      (* list of decl of rec parms from ind1 which remain parms *)
+      recprms1: rel_declaration list;
+      (* List of other rec parms from ind1 *)
+      otherprms1: rel_declaration list; (* parms that became args *)
+      funresprms1: rel_declaration list; (* parms that are functional result args *)
+      (* number of rec params of ind2 which remain rec param in merge (and not linked) *)
+      nrecprms2: int;
+      (* number of other params of ind2 (which become non rec parm) *)
+      notherprms2:int;
+      (* number of functional result params of ind2 (which become non parm) *)
+      nfunresprms2:int;
+      (* list of decl of rec parms from ind2 which remain parms (and not linked) *)
+      recprms2: rel_declaration list;
+      (* List of other rec parms from ind2 (which are linked or become non parm) *)
+      otherprms2: rel_declaration list;      
+      funresprms2: rel_declaration list; (* parms that are functional result args *)
+    }
+
+
+let pr_merginfo x =
+  let i,s=
+    match x with 
+      | Prm_linked i -> Some i,"Prm_linked"
+      | Arg_linked i -> Some i,"Arg_linked"
+      | Prm_stable i -> Some i,"Prm_stable"
+      | Prm_arg i -> Some i,"Prm_arg"
+      | Arg_stable i -> Some i,"Arg_stable"
+      | Arg_funres -> None , "Arg_funres" in
+  match i with
+    | Some i -> Printf.sprintf "%s(%d)" s i
+    | None -> Printf.sprintf "%s" s
+
+let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
+
+let isArg_stable x = match x with Arg_stable _ -> true | _ -> false
+
+let isArg_funres x = match x with Arg_funres -> true | _ -> false
+
+let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list =
+  let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in
+  let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in
+  let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in
+  prms@args@fres
+
+(** Reverse the link map, keeping only linked vars, elements are list
+    of int as several vars may be linked to the same var. *)
+let revlinked lnk =
+  For.fold 0 (Array.length lnk - 1)
+    (fun acc k -> 
+      match lnk.(k) with 
+        | Unlinked | Funres -> acc 
+        | Linked i -> 
+            let old = try Link.find i acc with Not_found -> [] in
+            Link.add i (k::old) acc)
+    Link.empty
+
+let array_switch arr i j = 
+  let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux
+
+let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
+  let larr = Array.of_list l in
+  let _ =
+    Array.iteri
+      (fun j x -> 
+        match x with
+          | Prm_linked i -> array_switch larr i j
+          | Arg_linked i -> array_switch larr i j
+          | Prm_stable i -> ()
+          | Prm_arg i -> ()
+          | Arg_stable i -> ()
+          | Arg_funres -> ()
+      ) lnk in
+  filter_shift_stable lnk (Array.to_list larr)
+
+
+
+
+(** {1 Utilities for merging} *)
+
+let ind1name = id_of_string "__ind1"
+let ind2name = id_of_string "__ind2"
+
+(** Performs verifications on two graphs before merging: they must not
+    be co-inductive, and for the moment they must not be mutual
+    either. *)
+let verify_inds mib1 mib2 =
+  if not mib1.mind_finite then error "First argument is coinductive";
+  if not mib2.mind_finite then error "Second argument is coinductive";
+  if mib1.mind_ntypes <> 1 then error "First argument is mutual";
+  if mib2.mind_ntypes <> 1 then error "Second argument is mutual";
+  ()
+
+
+(** {1 Merging function graphs} *)
+
+(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec
+    uniform and ordinary ones) of mutual inductives [mib1] and [mib2]
+    remain uniform when linked by [lnk]. All parameters are
+    considered, ie we take parameters of the first inductive body of
+    [mib1] and [mib2].
+    
+    Explanation: The two inductives have parameters, some of the first
+    are recursively uniform, some of the last are functional result of
+    the functional graph.
+
+   (I x1 x2 ... xk ... xk' ... xn)
+   (J y1 y2 ... xl ... yl' ... ym)
+
+   Problem is, if some rec unif params are linked to non rec unif
+   ones, they become non rec (and the following too). And functinal
+   argument have to be shifted at the end *)
+let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id =
+  let linked_targets = revlinked lnk2 in
+  let is_param_of_mib1 x = x < mib1.mind_nparams_rec in
+  let is_param_of_mib2 x = x < mib2.mind_nparams_rec in
+  let is_targetted_by_non_recparam_lnk1 i = 
+    try 
+      let targets = Link.find i linked_targets in 
+      List.exists (fun x -> not (is_param_of_mib2 x)) targets
+    with Not_found -> false in
+  let mlnk1 = 
+    Array.mapi
+      (fun i lkv -> 
+        let isprm = is_param_of_mib1 i in
+        let prmlost = is_targetted_by_non_recparam_lnk1 i in
+        match isprm , prmlost, lnk1.(i) with
+          | true , true , _ -> Prm_arg i (* recparam becoming ordinary *)
+          | true , false , _-> Prm_stable i (* recparam remains recparam*)
+          | false , false , Funres -> Arg_funres
+          | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *)
+          | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *)
+      lnk1 in
+  let mlnk2 = 
+    Array.mapi
+      (fun i lkv -> 
+        (* Is this correct if some param of ind2 is lost? *)
+        let isprm = is_param_of_mib2 i in
+        match isprm , lnk2.(i) with
+          | true , Linked j when not (is_param_of_mib1 j) -> 
+              Prm_arg j (* recparam becoming ordinary *)
+          | true , Linked j -> Prm_linked j (*recparam linked to recparam*)
+          | true , Unlinked -> Prm_stable i (* recparam remains recparam*)
+          | false , Linked j -> Arg_linked j (* Args of lnk2 lost *)
+          | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *)
+          | false , Funres -> Arg_funres
+          | true , Funres -> assert false (* fun res cannot be a rec param *)
+      )
+      lnk2 in
+  let oib1 = mib1.mind_packets.(0) in
+  let oib2 = mib2.mind_packets.(0) in
+  (* count params remaining params *)
+  let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in
+  let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
+  let bldprms arity_ctxt mlnk = 
+    list_fold_lefti
+      (fun i (acc1,acc2,acc3) x -> 
+        match mlnk.(i) with
+          | Prm_stable _ -> x::acc1 , acc2 , acc3
+          | Prm_arg _ | Arg_stable _ -> acc1 , x::acc2 , acc3
+          | Arg_funres -> acc1 , acc2 , x::acc3
+          | _ -> acc1 , acc2 , acc3) (* Prm_linked and Arg_xxx = forget it *)
+      ([],[],[]) arity_ctxt in
+  let recprms1,otherprms1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
+  let recprms2,otherprms2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
+  {
+    ident=id;
+    mib1=mib1;
+    oib1 = oib1;
+    mib2=mib2;
+    oib2 = oib2;
+    lnk1 = mlnk1;
+    lnk2 = mlnk2;
+    nrecprms1 = n_params1;
+    recprms1 = recprms1;
+    otherprms1 = otherprms1;
+    funresprms1 = funresprms1;
+    notherprms1 = Array.length mlnk1 - n_params1;
+    nfunresprms1 = List.length funresprms1;
+    nrecprms2 = n_params2;
+    recprms2 = recprms2;
+    otherprms2 = otherprms2;
+    funresprms2 = funresprms2;
+    notherprms2 = Array.length mlnk2 - n_params2;
+    nfunresprms2 = List.length funresprms2;
+  }
+
+
+
+
+(** {1 Merging functions} *)
+
+exception NoMerge
+
+(* lnk is an link array of *all* args (from 1 and 2) *)
+let merge_app c1 c2 id1 id2 shift filter_shift_stable = 
+  let lnk = Array.append shift.lnk1 shift.lnk2 in
+  match c1 , c2 with
+    | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> 
+        let args = filter_shift_stable lnk (arr1 @ arr2) in
+        RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args)
+    | RApp(_,f1, arr1), RApp(_,f2,arr2)  -> raise NoMerge
+    | _ -> raise NoMerge
+
+let merge_app_unsafe c1 c2 shift filter_shift_stable = 
+  let lnk = Array.append shift.lnk1 shift.lnk2 in
+  match c1 , c2 with
+    | RApp(_,f1, arr1), RApp(_,f2,arr2) -> 
+        let args = filter_shift_stable lnk (arr1 @ arr2) in
+        RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args)
+    | _ -> raise NoMerge
+
+
+
+(* Heuristic when merging two lists of hypothesis: merge every rec
+   calls of nrach 1 with all rec calls of branch 2. *)
+(* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
+let onefoud = ref false (* Ugly *)
+
+let rec merge_rec_hyps shift accrec (ltyp:(Names.name * Rawterm.rawconstr) list) 
+    filter_shift_stable =
+  match ltyp with
+    | [] -> []
+    | (nme,(RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> 
+        let _ = onefoud := true in
+        let rechyps = 
+          List.map 
+            (fun (nme,ind) -> 
+              match ind with
+                | RApp(_,i,args) -> 
+                    nme, merge_app_unsafe ind t shift filter_shift_stable
+                | _ -> assert false)
+            accrec in
+        rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable
+    | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable
+
+
+let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = 
+  List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
+
+
+let find_app (nme:identifier) (ltyp: (name * rawconstr) list) = 
+  try
+    ignore
+      (List.map
+          (fun x -> 
+            match x with
+              | _,(RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
+              | _ -> ())
+          ltyp);
+    false
+  with Found _ -> true
+        
+let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list)
+    concl1 (ltyp2:(name * rawconstr) list) concl2
+    : (name * rawconstr) list * rawconstr = 
+  let _ = prstr "MERGE_TYPES\n" in
+  let _ = prstr "ltyp 1 : " in
+  let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp1 in
+  let _ = prstr "\nltyp 2 : " in
+  let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp2 in
+  let _ = prstr "\n" in
+
+
+  let res =
+    match ltyp1 with
+      | [] -> 
+          let isrec1 = (accrec1<>[]) in
+          let isrec2 = find_app ind2name ltyp2 in
+          let _ = if isrec2 then prstr "  ISREC2 TRUE" else prstr "  ISREC2 FALSE" in
+          let _ = if isrec1 then prstr "  ISREC1 TRUE\n" else prstr "  ISREC1 FALSE\n" in
+          let rechyps =
+            if isrec1 && isrec2 
+            then merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable
+            else if isrec1 
+                (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *)
+            then merge_rec_hyps shift accrec1 (ltyp2@[name_of_string "concl2",concl2])
+              filter_shift_stable
+            else if isrec2
+            then merge_rec_hyps shift [name_of_string "concl1",concl1] ltyp2
+              filter_shift_stable_right
+            else [] in
+          let _ = prstr"\nrechyps : " in
+          let _ = List.iter 
+            (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) rechyps in
+          let _ = prstr "MERGE CONCL :  " in
+          let _ = prNamedRConstr "concl1" concl1 in
+          let _ = prstr " with " in
+          let _ = prNamedRConstr "concl2" concl2 in
+          let _ = prstr "\n" in
+          let concl = 
+            merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in
+          let _ = prstr "FIN " in
+          let _ = prNamedRConstr "concl" concl in
+          let _ = prstr "\n" in
+          rechyps , concl
+      | (nme,t1)as e ::lt1 -> 
+          match t1 with
+            | RApp(_,f,carr) when isVarf ind1name f -> 
+                merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 
+            | _ -> 
+                let recres, recconcl2 =
+                  merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
+                ((nme,t1) :: recres) , recconcl2
+  in
+  res
+
+
+(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of
+    linked args [allargs2] to target args of [allargs1] as specified
+    in [shift]. [allargs1] and [allargs2] are in reverse order.  Also
+    returns the list of unlinked vars of [allargs2]. *)
+let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
+    (lnk:int merged_arg array) =
+  array_fold_lefti
+    (fun i acc e -> 
+      if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *)
+      else 
+        match e with 
+          | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc
+          | _ -> acc)
+    Idmap.empty lnk
+
+let build_link_map allargs1 allargs2 lnk =
+  let allargs1 =
+    Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs1)) in
+  let allargs2 =
+    Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs2)) in
+  build_link_map_aux allargs1 allargs2 lnk
+
+
+(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two
+    constructor rawtypes [typcstr1] and [typcstr2].  [typcstr1] and
+    [typcstr2] contain all parameters (including rec. unif. ones) of
+    their inductive.
+
+    if  [typcstr1] and [typcstr2] are of the form:
+
+    forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1)
+    forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2)
+
+    we build:
+
+    forall recparams1 (recparams2 without linked params),
+     forall ordparams1 (ordparams2 without linked params),
+      H1a' -> H2a' -> ...  -> H2a' -> H2b' -> ... 
+        -> (newI x1 ... z1 x2 y2 ...z2 without linked params)
+
+    where Hix' have been adapted, ie: 
+      - linked vars have been changed,
+      - rec calls to I1 and I2 have been replaced by rec calls to
+        newI. More precisely calls to I1 and I2 have been merge by an
+        experimental heuristic (in particular if n o rec calls for I1
+        or I2 is found, we use the conclusion as a rec call). See
+        [merge_types] above.
+
+    Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint.
+
+    TODO: return nothing if equalities (after linking) are contradictory. *)
+let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
+    (typcstr2:rawconstr) : rawconstr =
+  (* FIXME: les noms des parametres corerspondent en principe au
+     parametres du niveau mib, mais il faudrait s'en assurer *)
+  (* shift.nfunresprmsx last args are functional result *)
+  let nargs1 = 
+    shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
+  let nargs2 =
+    shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
+  let allargs1,rest1 = raw_decompose_prod_n nargs1 typcstr1 in
+  let allargs2,rest2 = raw_decompose_prod_n nargs2 typcstr2 in  
+  (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *)
+  let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in
+  let rest2 = change_vars linked_map rest2 in
+  let hyps1,concl1 = raw_decompose_prod rest1 in
+  let hyps2,concl2' = raw_decompose_prod rest2 in
+  let ltyp,concl2 = 
+    merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in
+  let typ = raw_compose_prod concl2 (List.rev ltyp) in
+  let revargs1 = 
+    list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in
+  let revargs2 = 
+    list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in
+  let typwithprms = raw_compose_prod typ (List.rev revargs2 @ List.rev revargs1) in
+  typwithprms
+
+
+(** constructor numbering *)
+let fresh_cstror_suffix , cstror_suffix_init =
+  let cstror_num = ref 0 in
+  (fun () -> 
+    let res = string_of_int !cstror_num in
+    cstror_num := !cstror_num + 1;
+    res) ,
+  (fun () -> cstror_num := 0)
+
+(** [merge_constructor_id id1 id2 shift] returns the identifier of the
+    new constructor from the id of the two merged constructor and
+    the merging info. *)
+let merge_constructor_id id1 id2 shift:identifier = 
+  let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in
+  next_ident_fresh (id_of_string id)
+
+
+
+(** [merge_constructors lnk shift avoid] merges the two list of
+    constructor [(name*type)]. These are translated to rawterms
+    first, each of them having distinct var names. *)
+let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
+    (typcstr1:(identifier * types) list) 
+    (typcstr2:(identifier * types) list) : (identifier * rawconstr) list =
+  List.flatten 
+    (List.map
+        (fun (id1,typ1) -> 
+          let typ1 = substitterm 0 (mkRel 1) (mkVar ind1name) typ1 in
+          let rawtyp1 = Detyping.detype false (Idset.elements avoid) [] typ1 in
+          let idsoftyp1:Idset.t = ids_of_rawterm rawtyp1 in
+          List.map
+            (fun (id2,typ2) -> 
+              let typ2 = substitterm 0 (mkRel 1) (mkVar ind2name) typ2 in
+              (* Avoid also rawtyp1 names *)
+              let avoid2 = Idset.union avoid idsoftyp1 in
+              let rawtyp2 = Detyping.detype false (Idset.elements avoid2) [] typ2 in
+              let typ = merge_one_constructor shift rawtyp1 rawtyp2 in
+              let newcstror_id = merge_constructor_id id1 id2 shift in
+              newcstror_id , typ)
+            typcstr2)
+        typcstr1)
+    
+(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
+    inductive bodies [oib1] and [oib2], linking with [lnk], params
+    info in [shift], avoiding identifiers in [avoid]. *)
+let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
+    (oib2:one_inductive_body) : (identifier * rawconstr) list =
+  let lcstr1 = Array.to_list oib1.mind_user_lc in
+  let lcstr2 = Array.to_list oib2.mind_user_lc in
+  let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
+  let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in
+  cstror_suffix_init();
+  merge_constructors shift avoid lcstr1 lcstr2
+
+(** [build_raw_params prms_decl avoid] returns a list of variables
+    attributed to the list of decl [prms_decl], avoiding names in
+    [avoid]. *)
+let build_raw_params prms_decl avoid =
+  let dummy_constr = compose_prod prms_decl mkProp in
+  let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in
+  let res,_ = raw_decompose_prod dummy_rawconstr in
+  res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr)))
+
+(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual
+    inductive bodies [mib1] and [mib2] linking vars with
+    [lnk]. [shift] information on parameters of the new inductive.
+    For the moment, inductives are supposed to be non mutual.
+*)
+let rec merge_mutual_inductive_body
+    (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) 
+    (shift:merge_infos) =
+  (* Mutual not treated, we take first ind body of each. *)
+  let nprms1 = mib1.mind_nparams_rec in (* n# of rec uniform parms of mib1 *)
+  let prms1 = (* rec uniform parms of mib1 *)
+    List.map (fun (x,_,y) -> x,y) (fst (list_chop nprms1 mib1.mind_params_ctxt)) in
+
+  (* useless: *)
+  let prms1_named,avoid' = build_raw_params prms1 [] in
+  let prms2_named,avoid = build_raw_params prms1 avoid' in
+  let avoid:Idset.t = List.fold_right Idset.add avoid Idset.empty in  
+  (* *** *)
+
+  merge_inductive_body shift avoid mib1.mind_packets.(0) mib2.mind_packets.(0) 
+
+  
+
+let merge_rec_params_and_arity params1 params2 shift (concl:constr) = 
+  let params = shift.recprms1 @ shift.recprms2 in
+  let resparams, _ =
+    List.fold_left
+      (fun (acc,env) (nme,_,tp) -> 
+        let typ = Constrextern.extern_constr false env tp in
+        let newenv = Environ.push_rel (nme,None,tp) env in
+        LocalRawAssum ([(dummy_loc,nme)] , typ) :: acc , newenv)
+      ([],Global.env())
+      params in
+  let concl = Constrextern.extern_constr false (Global.env()) concl in
+  let arity,_ = 
+    List.fold_left 
+      (fun (acc,env) (nm,_,c) -> 
+        let typ = Constrextern.extern_constr false env c in
+        let newenv = Environ.push_rel (nm,None,c) env in
+        CProdN (dummy_loc, [[(dummy_loc,nm)],typ] , acc) , newenv)
+      (concl,Global.env())
+      (shift.otherprms1@shift.otherprms2@shift.funresprms1@shift.funresprms2) in  
+  resparams,arity
+
+  
+
+(** [rawterm_list_to_inductive_expr ident rawlist] returns the
+    induct_expr corresponding to the the list of constructor types
+    [rawlist], named ident.
+    FIXME: params et cstr_expr (arity) *)
+let rawterm_list_to_inductive_expr mib1 mib2 shift
+    (rawlist:(identifier * rawconstr) list):inductive_expr =
+  let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *)
+    Options.with_option Options.raw_print (Constrextern.extern_rawtype Idset.empty) x in
+  let lident = dummy_loc, shift.ident in
+  let bindlist , cstr_expr = (* params , arities *)
+    merge_rec_params_and_arity 
+      mib1.mind_params_ctxt mib2.mind_params_ctxt shift mkSet in
+  let lcstor_expr : (bool * (lident * constr_expr)) list  = 
+    List.map (* zeta_normalize t ? *)
+      (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t))
+      rawlist in  
+  lident , bindlist , cstr_expr , lcstor_expr
+
+(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
+    variables specified in [lnk]. Graphs are not supposed to be mutual
+    inductives for the moment. *)
+let merge_inductive (ind1: inductive) (ind2: inductive) 
+    (lnk1: linked_var array) (lnk2: linked_var array) id =
+  let env = Global.env() in
+  let mib1,_ = Inductive.lookup_mind_specif env ind1 in
+  let mib2,_ = Inductive.lookup_mind_specif env ind2 in
+  let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *)
+  (* compute params that become ordinary args (because linked to ord. args) *)
+  let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
+  let rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
+  let indexpr = rawterm_list_to_inductive_expr mib1 mib2 shift_prm rawlist in
+  (* Declare inductive *)
+  Command.build_mutual [(indexpr,None)] true (* means: not coinductive *)
+
+
+
+let merge (cstr1:constr) (cstr2:constr) (args1:constr array) (args2:constr array) id =
+  let env = Global.env() in
+  let ind1,_cstrlist1 = Inductiveops.find_inductive env Evd.empty cstr1 in
+  let ind2,_cstrlist2 = Inductiveops.find_inductive env Evd.empty cstr2 in
+  let lnk1 = (* args1 are unlinked. FIXME? mergescheme (G x x) ?? *)
+    Array.mapi (fun i c -> Unlinked) args1 in
+  let _ = lnk1.(Array.length lnk1 - 1) <- Funres in (* last arg is functional result *)
+  let lnk2 = (* args2 may be linked to args1 members. FIXME: same 
+                as above: vars may be linked inside args2?? *)
+    Array.mapi
+      (fun i c -> 
+        match array_find args1 (fun i x -> x=c) with
+          | Some j -> Linked j
+          | None -> Unlinked) 
+      args2 in
+  let _ = lnk2.(Array.length lnk2 - 1) <- Funres in (* last arg is functional result *)
+  let resa = merge_inductive ind1 ind2 lnk1 lnk2 id in
+  resa
+
+
+
+
+
+(* @article{ bundy93rippling,
+    author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill",
+    title = "Rippling: A Heuristic for Guiding Inductive Proofs",
+    journal = "Artificial Intelligence",
+    volume = "62",
+    number = "2",
+    pages = "185-253",
+    year = "1993",
+    url = "citeseer.ist.psu.edu/bundy93rippling.html" }
+
+ *)
+(* 
+*** Local Variables: ***
+*** compile-command: "make -C ../.. contrib/funind/merge.cmo" ***
+*** indent-tabs-mode: nil ***
+*** End: ***
+*)
diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml
new file mode 100644
index 00000000..aca84f06
--- /dev/null
+++ b/contrib/funind/rawterm_to_relation.ml
@@ -0,0 +1,1251 @@
+open Printer
+open Pp
+open Names 
+open Term
+open Rawterm
+open Libnames
+open Indfun_common
+open Util
+open Rawtermops
+
+let observe strm =  
+  if do_observe ()
+  then Pp.msgnl strm 
+  else ()
+let observennl strm =  
+  if do_observe ()
+  then Pp.msg strm 
+  else ()
+
+
+type binder_type =
+  | Lambda of name 
+  | Prod of name 
+  | LetIn of name
+
+type raw_context = (binder_type*rawconstr) list
+
+
+(* 
+   compose_raw_context [(bt_1,n_1,t_1);......] rt returns 
+   b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the 
+   binders corresponding to the bt_i's
+*)
+let compose_raw_context = 
+  let compose_binder  (bt,t) acc =
+    match bt with 
+      | Lambda n -> mkRLambda(n,t,acc)
+      | Prod n -> mkRProd(n,t,acc)
+      | LetIn n -> mkRLetIn(n,t,acc)
+  in
+  List.fold_right compose_binder
+  
+
+(* 
+   The main part deals with building a list of raw constructor expressions
+   from the rhs of a fixpoint equation. 
+*)
+
+type 'a build_entry_pre_return = 
+    {
+      context : raw_context;  (* the binding context of the result *)
+      value : 'a; (* The value *)
+    }
+
+type 'a build_entry_return = 
+    {
+      result : 'a build_entry_pre_return list; 
+      to_avoid : identifier list
+    }
+
+(*
+  [combine_results combine_fun res1 res2] combine two results [res1] and [res2] 
+  w.r.t. [combine_fun].
+
+  Informally, both [res1] and [res2] are lists of "constructors"  [res1_1;...] 
+  and [res2_1,....] and we need to produce 
+  [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........]
+*)
+
+let combine_results 
+    (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> 
+      'c build_entry_pre_return
+    )  
+    (res1: 'a build_entry_return) 
+    (res2 : 'b build_entry_return) 
+    : 'c build_entry_return 
+    = 
+  let pre_result =     List.map 
+    ( fun res1 ->  (* for each result in arg_res *)
+	  List.map (* we add it in each args_res *) 
+	    (fun res2 -> 
+	       combine_fun res1 res2
+	    )
+	    res2.result
+      )
+      res1.result
+  in (* and then we flatten the map *)
+  {
+    result = List.concat pre_result; 
+    to_avoid = list_union res1.to_avoid res2.to_avoid
+  }
+    
+
+(* 
+   The combination function for an argument with a list of argument 
+*)
+
+let combine_args arg args = 
+  {
+    context = arg.context@args.context; 
+    (* Note that the binding context of [arg] MUST be placed before the one of 
+       [args] in order to preserve possible type dependencies 
+    *)
+    value = arg.value::args.value;
+  }
+
+
+let ids_of_binder =  function 
+  | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> []
+  | LetIn (Name id)  | Prod (Name id) | Lambda (Name id) -> [id]
+
+let rec change_vars_in_binder mapping = function 
+    [] -> []
+  | (bt,t)::l ->
+      let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in 
+      (bt,change_vars mapping t)::
+	(if idmap_is_empty new_mapping
+	 then l 
+	 else change_vars_in_binder new_mapping l
+	)
+
+let rec replace_var_by_term_in_binder x_id term = function
+  | [] -> []
+  | (bt,t)::l -> 
+      (bt,replace_var_by_term x_id term t)::
+	if List.mem x_id (ids_of_binder bt) 
+	then l
+	else replace_var_by_term_in_binder x_id term l
+
+let add_bt_names bt = List.append (ids_of_binder bt)
+
+let apply_args ctxt body args = 
+  let need_convert_id avoid id = 
+    List.exists (is_free_in id) args || List.mem id avoid 
+  in 
+  let need_convert avoid  bt =  
+    List.exists (need_convert_id avoid) (ids_of_binder bt)
+  in
+  let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = 
+    match na with 
+       | Name id when List.mem id avoid -> 
+	   let new_id = Nameops.next_ident_away id avoid in 
+	   Name new_id,Idmap.add id new_id mapping,new_id::avoid
+       | _ -> na,mapping,avoid
+  in
+  let next_bt_away bt (avoid:identifier list) = 
+    match bt with 
+      | LetIn na -> 
+	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
+	  LetIn new_na,mapping,new_avoid
+      | Prod na -> 
+	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
+	  Prod new_na,mapping,new_avoid
+      | Lambda na -> 
+	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in 
+	  Lambda new_na,mapping,new_avoid
+  in
+  let rec do_apply avoid ctxt body args = 
+    match ctxt,args with  
+      | _,[] -> (* No more args *)
+	  (ctxt,body)
+      | [],_ -> (* no more fun *)
+	  let f,args' = raw_decompose_app body in
+	  (ctxt,mkRApp(f,args'@args))
+      | (Lambda Anonymous,t)::ctxt',arg::args' -> 
+	  do_apply avoid ctxt' body args'
+      | (Lambda (Name id),t)::ctxt',arg::args' -> 
+	  let new_avoid,new_ctxt',new_body,new_id = 
+	    if need_convert_id avoid id 
+	    then 
+	      let new_avoid =  id::avoid in 
+	      let new_id = Nameops.next_ident_away id new_avoid in 
+	      let new_avoid' = new_id :: new_avoid in 
+	      let mapping = Idmap.add id new_id Idmap.empty in 
+	      let new_ctxt' = change_vars_in_binder mapping ctxt' in 
+	      let new_body = change_vars mapping body in 
+	      new_avoid',new_ctxt',new_body,new_id
+	    else 
+	      id::avoid,ctxt',body,id 
+	  in
+	  let new_body = replace_var_by_term new_id arg new_body in
+	  let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in
+	  do_apply avoid new_ctxt' new_body args'
+      | (bt,t)::ctxt',_ -> 
+	  let new_avoid,new_ctxt',new_body,new_bt = 
+	    let new_avoid = add_bt_names bt avoid in 
+	    if need_convert avoid bt 
+	    then 
+	      let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in 
+	      (
+		new_avoid,
+		change_vars_in_binder mapping ctxt',
+		change_vars mapping body,
+		new_bt
+	     )
+	    else new_avoid,ctxt',body,bt
+	  in
+	  let new_ctxt',new_body = 
+	    do_apply new_avoid new_ctxt' new_body args 
+	  in
+	  (new_bt,t)::new_ctxt',new_body
+  in 
+  do_apply []  ctxt body args
+
+
+let combine_app f args = 
+  let new_ctxt,new_value = apply_args f.context f.value args.value in 
+  { 
+    (* Note that the binding context of [args] MUST be placed before the one of 
+       the applied value in order to preserve possible type dependencies 
+    *)
+      context = args.context@new_ctxt;
+      value = new_value;
+  }
+
+let combine_lam n t b = 
+  {
+    context = []; 
+    value = mkRLambda(n, compose_raw_context t.context t.value, 
+		      compose_raw_context b.context b.value )
+  }
+
+
+
+let combine_prod n t b = 
+  { context = t.context@((Prod n,t.value)::b.context); value = b.value}
+
+let combine_letin n t b = 
+  { context = t.context@((LetIn n,t.value)::b.context); value = b.value}
+
+
+let mk_result ctxt value avoid = 
+  { 
+    result = 
+      [{context = ctxt;
+	value = value}]
+	;
+    to_avoid = avoid
+  }
+(*************************************************
+  Some functions to deal with overlapping patterns 
+**************************************************)
+
+let coq_True_ref = 
+  lazy  (Coqlib.gen_reference "" ["Init";"Logic"] "True")
+
+let coq_False_ref = 
+  lazy  (Coqlib.gen_reference "" ["Init";"Logic"] "False")
+
+(*
+  [make_discr_match_el \[e1,...en\]] builds match e1,...,en with
+  (the list of expresions on which we will do the matching)
+ *) 
+let make_discr_match_el  = 
+  List.map (fun e -> (e,(Anonymous,None)))
+
+(*
+  [make_discr_match_brl i \[pat_1,...,pat_n\]]  constructs a discrimination pattern matching on the ith expression. 
+  that is. 
+  match ?????? with \\
+  | pat_1 => False  \\
+  | pat_{i-1} => False \\
+  | pat_i => True \\
+  | pat_{i+1} => False \\
+  \vdots 
+  | pat_n => False
+  end
+*)
+let make_discr_match_brl i = 
+  list_map_i 
+    (fun j (_,idl,patl,_) -> 
+       if j=i
+       then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref))
+       else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref))
+    )
+    0 
+(* 
+   [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff 
+   brl_{i} is the first branch matched by [el] 
+
+   Used when we want to simulate the coq pattern matching algorithm
+*)
+let make_discr_match brl = 
+  fun el i -> 
+  mkRCases(None,
+	   make_discr_match_el el,
+	   make_discr_match_brl i brl)
+
+let pr_name = function
+  | Name id -> Ppconstr.pr_id id
+  | Anonymous -> str "_"
+
+(**********************************************************************)
+(*  functions used to build case expression from lettuple and if ones *)
+(**********************************************************************)		
+
+(* [build_constructors_of_type] construct the array of pattern of its inductive argument*)	  
+let build_constructors_of_type ind' argl = 
+  let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in
+  let npar = mib.Declarations.mind_nparams in
+  Array.mapi (fun i _ ->
+		let construct = ind',i+1 in 
+		let constructref = ConstructRef(construct) in 
+		let _implicit_positions_of_cst =
+		  Impargs.implicits_of_global constructref
+		in
+		let cst_narg = 
+		  Inductiveops.mis_constructor_nargs_env
+		    (Global.env ())
+		    construct
+		in 
+		let argl = 
+		  if argl = [] 
+		  then
+ 		    Array.to_list 
+		      (Array.init (cst_narg - npar) (fun _ -> mkRHole ())
+		      )
+		  else argl
+		in
+		let pat_as_term = 
+		  mkRApp(mkRRef (ConstructRef(ind',i+1)),argl)
+		in
+		cases_pattern_of_rawconstr Anonymous pat_as_term
+	     )
+    ind.Declarations.mind_consnames
+
+(* [find_type_of] very naive attempts to discover the type of an if or a letin *)
+let rec find_type_of nb b = 
+  let f,_ = raw_decompose_app b in 
+  match f with 
+    | RRef(_,ref) -> 
+	begin 
+	  let ind_type  = 
+	    match ref with 
+	      | VarRef _ | ConstRef _ -> 
+		  let constr_of_ref = constr_of_global ref in  
+		  let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in 
+		  let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in 
+		  let ret_type,_ = decompose_app ret_type in 
+		  if not (isInd ret_type) then 
+		    begin
+(* 		      Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *)
+		      raise (Invalid_argument "not an inductive")
+		    end;
+		  destInd ret_type
+	      | IndRef ind -> ind
+	      | ConstructRef c -> fst c 
+	  in
+	  let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in 
+	  if not (Array.length ind_type_info.Declarations.mind_consnames = nb )
+	  then raise (Invalid_argument "find_type_of : not a valid inductive");
+	  ind_type	   
+	end
+    | RCast(_,b,_,_) -> find_type_of nb b 
+    | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *)
+    | _ -> raise (Invalid_argument "not a ref")
+    
+
+
+
+(******************)
+(* Main functions *)
+(******************)
+
+
+
+let raw_push_named (na,raw_value,raw_typ) env = 
+  match na with 
+    | Anonymous -> env 
+    | Name id -> 
+	let value = Util.option_map (Pretyping.Default.understand Evd.empty env) raw_value in 
+	let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in 
+	Environ.push_named (id,value,typ) env
+
+
+let add_pat_variables pat typ env : Environ.env = 
+  let rec add_pat_variables env pat typ  : Environ.env = 
+    observe (str "new rel env := " ++ Printer.pr_rel_context_of env);
+
+    match pat with 
+      | PatVar(_,na) -> Environ.push_rel (na,None,typ) env 
+      | PatCstr(_,c,patl,na) -> 
+	  let Inductiveops.IndType(indf,indargs) = 
+	    try Inductiveops.find_rectype env Evd.empty typ
+	    with Not_found -> assert false 
+	  in
+	  let constructors = Inductiveops.get_constructors env indf in 
+	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in 
+	  let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in 
+	  List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) 
+  in
+  let new_env = add_pat_variables  env pat typ in 
+  let res =
+    fst (
+      Sign.fold_rel_context
+	(fun (na,v,t) (env,ctxt) ->
+	 match na with
+	   | Anonymous -> assert false
+	   | Name id ->
+	       let new_t =  substl ctxt t in
+	       let new_v = option_map (substl ctxt) v in
+	       observe (str "for variable " ++ Ppconstr.pr_id id ++  fnl () ++
+			  str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++
+			  str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++
+			  option_fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++
+			  option_fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ())
+		       );
+	       (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt)
+      )
+	(Environ.rel_context new_env)
+	~init:(env,[])
+    )
+  in
+  observe (str "new var env := " ++ Printer.pr_named_context_of res);
+  res
+
+
+
+
+let rec pattern_to_term_and_type env typ  = function
+  | PatVar(loc,Anonymous) -> assert false
+  | PatVar(loc,Name id) ->
+	mkRVar id
+  | PatCstr(loc,constr,patternl,_) ->
+      let cst_narg =
+	Inductiveops.mis_constructor_nargs_env
+	  (Global.env ())
+	  constr
+      in
+      let Inductiveops.IndType(indf,indargs) = 
+	try Inductiveops.find_rectype env Evd.empty typ
+	with Not_found -> assert false 
+      in
+      let constructors = Inductiveops.get_constructors env indf in 
+      let constructor  = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in 
+      let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in 
+      let _,cstl = Inductiveops.dest_ind_family indf in 
+      let csta = Array.of_list cstl in 
+      let implicit_args =
+	Array.to_list
+	  (Array.init
+	     (cst_narg - List.length patternl)
+	     (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i))
+	  )
+      in
+      let patl_as_term =
+	List.map2 (pattern_to_term_and_type env)  (List.rev cs_args_types)  patternl
+      in
+      mkRApp(mkRRef(Libnames.ConstructRef constr),
+	     implicit_args@patl_as_term
+	    )
+
+(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) 
+   of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the 
+   corresponding graphs. 
+
+
+   The idea to transform a term [t] into a list of constructors [lc] is the following:
+   \begin{itemize} 
+   \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding 
+   to [body] and add (bind x. _) to each elements of [lc]
+   \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) 
+   then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], 
+   then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], 
+   [g c1 ... cn] is an element of [lc]
+   \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then 
+   compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], 
+   then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn]
+   create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc]
+   \item if the term is a cast just treat its body part
+   \item 
+   if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case 
+   and concatenate them (informally, each branch of a match produces a new constructor)
+   \end{itemize}
+   
+   WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. 
+   We must wait to have complete all the current calculi to set the recursive calls. 
+   At this point, each term [f t1 ... tn]  (where f appears in [funnames]) is replaced by 
+   a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. 
+   We in fact not create a constructor list since then end of each constructor has not the expected form 
+   but only the value of the function 
+*)
+
+
+let rec build_entry_lc env funnames avoid rt  : rawconstr build_entry_return = 
+  observe (str " Entering : " ++ Printer.pr_rawconstr rt);
+  match rt with 
+    | RRef _ | RVar _ | REvar _ | RPatVar _     | RSort _  | RHole _  -> 
+	(* do nothing (except changing type of course) *)
+	mk_result [] rt avoid 
+    | RApp(_,_,_) ->
+	let f,args = raw_decompose_app rt in
+	let args_res : (rawconstr list) build_entry_return =
+	  List.fold_right (* create the arguments lists of constructors and combine them *)
+	    (fun arg ctxt_argsl ->
+	       let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in
+	       combine_results combine_args arg_res ctxt_argsl
+	    )
+	    args
+	    (mk_result [] [] avoid)
+	in
+	begin
+	  match f with
+	    | RVar(_,id) when Idset.mem id funnames ->
+		(* if we have [f t1 ... tn] with [f]$\in$[fnames]
+		   then we create a fresh variable [res], 
+		   add [res] and its "value" (i.e. [res v1 ... vn]) to each 
+		   pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and 
+		   a pseudo value "v1 ... vn". 
+		   The "value" of this branch is then simply [res]
+		*)
+		let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in 
+		let rt_typ = Typing.type_of env Evd.empty rt_as_constr in 
+		let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
+		let res = fresh_id args_res.to_avoid "res" in
+		let new_avoid = res::args_res.to_avoid in
+		let res_rt = mkRVar res in 
+		let new_result = 
+		  List.map 
+		    (fun arg_res -> 
+		       let new_hyps = 
+			 [Prod (Name res),res_raw_type;
+			  Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)]
+		       in
+		       {context =  arg_res.context@new_hyps; value = res_rt } 
+		    )
+		    args_res.result
+		in 
+		{ result = new_result; to_avoid = new_avoid }
+	    | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> 
+		(* if have [g t1 ... tn] with [g] not appearing in [funnames] 
+		   then  
+		   foreach [ctxt,v1 ... vn] in [args_res] we return  
+		   [ctxt, g v1 .... vn]
+		*)
+		{
+		  args_res with 
+		    result = 
+		    List.map 
+		      (fun args_res -> 
+			 {args_res with value = mkRApp(f,args_res.value)})
+		      args_res.result
+		}
+	    | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *)
+       	    | RLetIn(_,n,t,b) -> 
+		(* if we have [(let x := v in b) t1 ... tn] , 
+		   we discard our work and compute the list of constructor for 
+		   [let x = v in (b t1 ... tn)] up to alpha conversion 
+		*)
+		let new_n,new_b,new_avoid = 
+		  match n with 
+		    | Name id when List.exists (is_free_in id) args -> 
+			(* need to alpha-convert the name *)
+			let new_id = Nameops.next_ident_away id avoid in 
+			let new_avoid = id:: avoid in
+			let new_b = 
+			  replace_var_by_term
+			    id
+			    (RVar(dummy_loc,id)) 
+			    b
+			in 
+			(Name new_id,new_b,new_avoid)
+		    | _ -> n,b,avoid
+		in
+		build_entry_lc 
+		  env
+		  funnames 
+		  avoid
+		  (mkRLetIn(new_n,t,mkRApp(new_b,args)))
+	    | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> 
+		(* we have [(match e1, ...., en with ..... end) t1 tn]
+		   we first compute the result from the case and 
+		   then combine each of them with each of args one
+		*)
+		let f_res = build_entry_lc env funnames args_res.to_avoid f in
+		combine_results combine_app f_res  args_res
+	    | RDynamic _ ->error "Not handled RDynamic" 
+	    | RCast(_,b,_,_) -> 
+		(* for an applied cast we just trash the cast part 
+		   and restart the work. 
+
+		   WARNING: We need to restart since [b] itself should be an application term
+		*)
+		build_entry_lc env funnames avoid (mkRApp(b,args))
+	    | RRec _ -> error "Not handled RRec"
+	    | RProd _ -> error "Cannot apply a type"
+	end (* end of the application treatement *) 
+
+    | RLambda(_,n,t,b) ->
+	(* we first compute the list of constructor 
+	   corresponding to the body of the function, 
+	   then the one corresponding to the type 
+	   and combine the two result
+	*)
+	let t_res = build_entry_lc env funnames avoid t  in
+	let new_n = 
+	  match n with 
+	    | Name _ -> n 
+	    | Anonymous -> Name (Indfun_common.fresh_id [] "_x")
+	in
+	let new_env = raw_push_named (new_n,None,t) env in
+	let b_res = build_entry_lc new_env funnames avoid b in
+	combine_results (combine_lam new_n) t_res b_res
+    | RProd(_,n,t,b) ->
+	(* we first compute the list of constructor 
+	   corresponding to the body of the function, 
+	   then the one corresponding to the type 
+	   and combine the two result
+	*)
+	let t_res = build_entry_lc env funnames avoid t in
+	let new_env = raw_push_named (n,None,t) env in
+	let b_res = build_entry_lc new_env funnames avoid b in
+	combine_results (combine_prod n) t_res b_res
+    | RLetIn(_,n,v,b) ->
+	(* we first compute the list of constructor 
+	   corresponding to the body of the function, 
+	   then the one corresponding to the value [t] 
+	   and combine the two result
+	*)
+	let v_res = build_entry_lc env funnames avoid v in
+	let v_as_constr = Pretyping.Default.understand Evd.empty env v in 
+	let v_type = Typing.type_of env Evd.empty v_as_constr in 
+	let new_env = 
+	  match n with
+	      Anonymous -> env
+	    | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env 
+	in
+	let b_res = build_entry_lc new_env funnames avoid b in
+	combine_results (combine_letin n) v_res b_res
+    | RCases(_,_,el,brl) -> 
+	(* we create the discrimination function 
+	   and treat the case itself 
+	*)
+	let make_discr = make_discr_match brl in 
+	build_entry_lc_from_case env funnames make_discr el brl avoid
+    | RIf(_,b,(na,e_option),lhs,rhs) -> 
+	let b_as_constr = Pretyping.Default.understand Evd.empty env b in
+	let b_typ = Typing.type_of env Evd.empty b_as_constr in 
+	let (ind,_) =  
+	  try Inductiveops.find_inductive env Evd.empty b_typ 
+	  with Not_found -> 
+	    errorlabstrm "" (str "Cannot find the inductive associated to " ++ 
+			       Printer.pr_rawconstr b ++ str " in " ++
+			       Printer.pr_rawconstr rt ++ str ". try again with a cast")
+	in
+	let case_pats = build_constructors_of_type ind [] in 
+	assert (Array.length case_pats = 2);
+	let brl =
+	  list_map_i
+	    (fun i x -> (dummy_loc,[],[case_pats.(i)],x))
+	    0
+	    [lhs;rhs]
+	in
+	let match_expr =
+	  mkRCases(None,[(b,(Anonymous,None))],brl)
+	in
+	(* 		Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
+	build_entry_lc env funnames avoid match_expr
+    | RLetTuple(_,nal,_,b,e) ->  
+	begin
+	  let nal_as_rawconstr =
+	    List.map
+	      (function
+		   Name id -> mkRVar id
+		 | Anonymous -> mkRHole ()
+	      )
+	      nal
+	  in
+	  let b_as_constr = Pretyping.Default.understand Evd.empty env b in
+	  let b_typ = Typing.type_of env Evd.empty b_as_constr in 
+	  let (ind,_) = 
+	    try Inductiveops.find_inductive env Evd.empty b_typ 
+	    with Not_found -> 
+	      errorlabstrm "" (str "Cannot find the inductive associated to " ++ 
+				 Printer.pr_rawconstr b ++ str " in " ++
+				 Printer.pr_rawconstr rt ++ str ". try again with a cast")
+	  in
+	  let case_pats = build_constructors_of_type ind nal_as_rawconstr in 
+	  assert (Array.length case_pats = 1);
+	  let br =
+	    (dummy_loc,[],[case_pats.(0)],e)
+	  in
+	  let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in
+	  build_entry_lc env funnames avoid match_expr
+
+	end
+    | RRec _ -> error "Not handled RRec"
+    | RCast(_,b,_,_) -> 
+	build_entry_lc env funnames  avoid b
+    | RDynamic _ -> error "Not handled RDynamic"
+and build_entry_lc_from_case env funname make_discr
+    (el:tomatch_tuple)
+    (brl:Rawterm.cases_clauses) avoid : 
+    rawconstr build_entry_return = 
+  match el with 
+    | [] -> assert false (* this case correspond to match <nothing> with .... !*) 
+    | el -> 
+	(* this case correspond to 
+	   match el with brl end
+	   we first compute the list of lists corresponding to [el] and 
+	   combine them . 
+	   Then for each elemeent of the combinations, 
+	   we compute the result we compute one list per branch in [brl] and 
+	   finally we just concatenate those list 
+	*)
+	let case_resl = 
+	    List.fold_right
+	    (fun (case_arg,_) ctxt_argsl ->
+	       let arg_res = build_entry_lc env funname avoid case_arg  in
+	       combine_results combine_args arg_res ctxt_argsl
+	    )
+	    el
+	      (mk_result [] [] avoid)
+	in
+	(****** The next works only if the match is not dependent ****)
+	let types = 
+	  List.map (fun (case_arg,_) -> 
+		      let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in 
+		      Typing.type_of env Evd.empty case_arg_as_constr
+		   ) el
+	in
+	let results =
+	  List.map 
+	    (build_entry_lc_from_case_term
+	       env types
+	       funname (make_discr (* (List.map fst el) *))
+	       []  brl 
+	       case_resl.to_avoid) 
+	    case_resl.result 
+	in 
+	{ 
+	  result = List.concat (List.map (fun r -> r.result) results);
+	  to_avoid = 
+	    List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results
+	} 
+
+and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid
+    matched_expr =
+  match brl with
+    | [] -> (* computed_branches  *) {result = [];to_avoid = avoid}
+    | br::brl' ->
+	(* alpha convertion to prevent name clashes *)
+	let _,idl,patl,return = alpha_br avoid br in
+	let new_avoid  = idl@avoid in 	(* for now we can no more use idl as an indentifier *)
+	(* building a list of precondition stating that we are not in this branch 
+	   (will be used in the following recursive calls)
+	*)
+	let new_env = List.fold_right2 add_pat_variables patl types env in 
+	let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = 
+	  List.map2
+	    (fun pat typ -> 
+	       fun avoid pat'_as_term -> 
+		 let renamed_pat,_,_ = alpha_pat avoid pat in
+		 let pat_ids = get_pattern_id renamed_pat  in 
+		 let env_with_pat_ids = add_pat_variables pat typ new_env in 
+		   List.fold_right 
+		   (fun id acc -> 		 
+		      let typ_of_id = Typing.type_of env_with_pat_ids Evd.empty (mkVar id) in 
+		      let raw_typ_of_id = 
+			Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
+		      in
+		      mkRProd (Name id,raw_typ_of_id,acc))
+		   pat_ids
+		   (raw_make_neq pat'_as_term (pattern_to_term renamed_pat))
+	    )
+	    patl
+	    types
+	in
+	(* Checking if we can be in this branch 
+	   (will be used in the following recursive calls)
+	*)	   
+	let unify_with_those_patterns : (cases_pattern -> bool*bool) list =
+	  List.map 
+	    (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') 
+	    patl
+	in
+	(* 
+	   we first compute the other branch result (in ordrer to keep the order of the matching 
+	   as much as possible)
+	*)
+	let brl'_res =
+	  build_entry_lc_from_case_term
+	    env 
+	    types
+	    funname
+	    make_discr
+	    ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent)
+	    brl'
+	    avoid
+	    matched_expr
+	in
+	(* We now create the precondition of this branch i.e.
+
+	   1- the list of variable appearing in the different patterns of this branch and 
+	      the list of equation stating than el = patl (List.flatten ...)
+	   2- If there exists a previous branch which pattern unify with the one of this branch 
+              then a discrimination precond stating that we are not in a previous branch (if List.exists ...)
+	*)
+      	let those_pattern_preconds =
+	  (List.flatten
+	    (
+	      list_map3
+	      (fun pat e typ_as_constr ->
+		 let this_pat_ids = ids_of_pat pat in 
+		 let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in
+		 let pat_as_term = pattern_to_term pat in
+		 List.fold_right 
+		   (fun id  acc -> 
+		      if Idset.mem id this_pat_ids 
+		      then (Prod (Name id),
+		      let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in 
+		      let raw_typ_of_id = 
+			Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id
+		      in
+		      raw_typ_of_id
+			   )::acc
+		      else acc
+			
+		   )
+		   idl
+		   [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)]
+	      )
+	      patl
+	      matched_expr.value
+	      types
+	  )
+	  )
+	  @
+	  (if List.exists (function (unifl,_) ->
+			     let (unif,_) = 
+			       List.split (List.map2 (fun x y -> x y) unifl patl)
+			     in
+			     List.for_all (fun x -> x) unif) patterns_to_prevent
+	   then 
+	     let i = List.length patterns_to_prevent in 
+	     let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in
+	     [(Prod Anonymous,make_discr pats_as_constr i  )]
+	   else 
+	     []
+	  )
+	in
+	(* We compute the result of the value returned by the branch*)
+	let return_res = build_entry_lc new_env funname new_avoid return in
+	(* and combine it with the preconds computed for this branch *)
+	let this_branch_res =
+	  List.map
+	    (fun res  ->
+	       { context = matched_expr.context@those_pattern_preconds@res.context ;
+		 value = res.value}
+	    )
+	    return_res.result
+	in
+	{ brl'_res with result = this_branch_res@brl'_res.result }
+	  
+	  
+let is_res id = 
+  try
+    String.sub (string_of_id id) 0 3 = "res"
+  with Invalid_argument _ -> false 
+
+(* 
+   The second phase which reconstruct the real type of the constructor. 
+   rebuild the raw constructors expression. 
+   eliminates some meaningless equalities, applies some rewrites......
+*)
+let rec rebuild_cons nb_args relname args crossed_types depth rt = 
+  match rt with 
+    | RProd(_,n,t,b) -> 
+	let not_free_in_t id = not (is_free_in id t) in 
+	let new_crossed_types = t::crossed_types in 
+	begin
+	  match t with 
+	    | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id ->
+		begin
+		  match args' with 
+		    | (RVar(_,this_relname))::args' -> 
+			let new_b,id_to_exclude =  
+			  rebuild_cons 
+			    nb_args relname
+			    args new_crossed_types
+			    (depth + 1) b
+			in 
+			(*i The next call to mk_rel_id is valid since we are constructing the graph
+			  Ensures by: obvious
+			  i*) 
+
+			let new_t = 
+			  mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) 
+			in mkRProd(n,new_t,new_b),
+			Idset.filter not_free_in_t id_to_exclude
+		    | _ -> (* the first args is the name of the function! *)
+			assert false 
+		end
+	    | RApp(_,RRef(_,eq_as_ref),[_;RVar(_,id);rt]) 
+		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
+		  -> 
+		let is_in_b = is_free_in id b in
+		let _keep_eq = 
+		  not (List.exists (is_free_in id) args) || is_in_b  || 
+		    List.exists (is_free_in id) crossed_types 
+		in 
+		let new_args = List.map (replace_var_by_term id rt) args in 
+		let subst_b = 
+		  if is_in_b then b else  replace_var_by_term id rt b 
+		in 
+		let new_b,id_to_exclude =  
+		  rebuild_cons 
+		    nb_args relname
+		    new_args new_crossed_types
+		    (depth + 1) subst_b
+		in 
+		mkRProd(n,t,new_b),id_to_exclude
+		  (* J.F:. keep this comment  it explain how to remove some meaningless equalities 
+		     if keep_eq then
+		     mkRProd(n,t,new_b),id_to_exclude
+		     else new_b, Idset.add id id_to_exclude
+		  *)
+	    | _ -> 
+		let new_b,id_to_exclude =  
+		  rebuild_cons 
+		    nb_args relname
+		    args new_crossed_types
+		    (depth + 1) b
+		in 
+		match n with
+		  | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
+		      new_b,Idset.remove id 
+			(Idset.filter not_free_in_t id_to_exclude)
+		  | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+	end
+    | RLambda(_,n,t,b) ->
+	begin
+	  let not_free_in_t id = not (is_free_in id t) in
+	  let new_crossed_types = t :: crossed_types in
+	  match n with
+	    | Name id ->
+		let new_b,id_to_exclude = 
+		  rebuild_cons 
+		    nb_args relname
+		    (args@[mkRVar id])new_crossed_types
+		    (depth + 1 ) b 
+		in
+		if Idset.mem id id_to_exclude && depth >= nb_args
+		then 
+		  new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
+		else
+		  RProd(dummy_loc,n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+	    | _ -> anomaly "Should not have an anonymous function here" 
+		(* We have renamed all the anonymous functions during alpha_renaming phase *)
+	  
+	end
+    | RLetIn(_,n,t,b) -> 
+	begin
+	  let not_free_in_t id = not (is_free_in id t) in 
+	  let new_b,id_to_exclude = 
+	    rebuild_cons 
+	      nb_args relname
+	      args (t::crossed_types)
+	      (depth + 1 ) b in
+	  match n with 
+	    | Name id when Idset.mem id id_to_exclude && depth >= nb_args  -> 
+		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
+	    | _ -> RLetIn(dummy_loc,n,t,new_b),
+		Idset.filter not_free_in_t id_to_exclude
+	end
+    | RLetTuple(_,nal,(na,rto),t,b) -> 
+	assert (rto=None);
+	begin
+	  let not_free_in_t id = not (is_free_in id t) in 
+	  let new_t,id_to_exclude' = 
+	    rebuild_cons 
+	      nb_args
+	      relname 
+	      args (crossed_types) 
+	      depth t 
+	  in
+	  let new_b,id_to_exclude = 
+	    rebuild_cons 
+	      nb_args relname
+	      args (t::crossed_types) 
+	      (depth + 1) b 
+	  in
+(* 	  match n with  *)
+(* 	    | Name id when Idset.mem id id_to_exclude ->  *)
+(* 		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *)
+(* 	    | _ -> *)
+	  RLetTuple(dummy_loc,nal,(na,None),t,new_b),
+		Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude')
+
+	end
+
+    | _ -> mkRApp(mkRVar  relname,args@[rt]),Idset.empty
+
+
+(* debuging wrapper *)
+let rebuild_cons nb_args relname args crossed_types rt = 
+(*   observennl  (str "rebuild_cons : rt := "++ pr_rawconstr rt ++  *)
+(* 		 str "nb_args := " ++ str (string_of_int nb_args)); *)
+  let res = 
+    rebuild_cons nb_args relname args crossed_types 0 rt 
+  in
+(*   observe (str " leads to "++ pr_rawconstr (fst res)); *)
+  res
+
+
+(* naive implementation of parameter detection. 
+
+   A parameter is an argument which is only preceded by parameters and whose 
+   calls are all syntaxically equal. 
+
+   TODO: Find a valid way to deal with implicit arguments here! 
+*)
+let rec compute_cst_params relnames params = function 
+  | RRef _ | RVar _ | REvar _ | RPatVar _ -> params
+  | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames ->
+      compute_cst_params_from_app [] (params,rtl)
+  | RApp(_,f,args) -> 
+      List.fold_left (compute_cst_params relnames) params (f::args)
+  | RLambda(_,_,t,b) | RProd(_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> 
+      let t_params = compute_cst_params relnames params t in 
+      compute_cst_params relnames t_params b
+  | RCases _ -> params  (* If there is still cases at this point they can only be 
+			discriminitation ones *)
+  | RSort _ -> params
+  | RHole _ -> params
+  | RIf _ | RRec _ | RCast _ | RDynamic _  ->
+      raise (UserError("compute_cst_params", str "Not handled case"))
+and compute_cst_params_from_app acc (params,rtl) = 
+  match params,rtl with 
+    | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
+    | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' 
+	when id_ord id id' == 0 && not is_defined -> 
+	compute_cst_params_from_app (param::acc) (params',rtl')
+    | _  -> List.rev acc 
+   
+let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts =  
+  let rels_params = 
+    Array.mapi 
+      (fun i args -> 
+	 List.fold_left 
+	   (fun params (_,cst) -> compute_cst_params relnames params cst) 
+	   args
+	   csts.(i)
+      )
+      args
+  in 
+  let l = ref [] in 
+  let _ = 
+    try 
+      list_iter_i
+	(fun i ((n,nt,is_defined) as param) -> 
+	   if array_for_all 
+	     (fun l -> 
+		let (n',nt',is_defined') = List.nth l i in 
+		n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined')
+	     rels_params
+	   then 
+	     l := param::!l
+	) 
+	rels_params.(0)
+    with _ -> 
+      ()
+  in 
+  List.rev !l
+
+let rec rebuild_return_type rt = 
+  match rt with 
+    | Topconstr.CProdN(loc,n,t') -> 
+	Topconstr.CProdN(loc,n,rebuild_return_type t') 
+    | Topconstr.CArrow(loc,t,t') -> 
+	Topconstr.CArrow(loc,t,rebuild_return_type t')
+    | Topconstr.CLetIn(loc,na,t,t') -> 
+	Topconstr.CLetIn(loc,na,t,rebuild_return_type t') 
+    | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
+
+
+let do_build_inductive 
+    funnames (funsargs: (Names.name * rawconstr * bool) list list)  
+    returned_types 
+    (rtl:rawconstr list) =
+  let _time1 = System.get_time () in
+(*   Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *)
+  let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
+  let funnames = Array.of_list funnames in  
+  let funsargs = Array.of_list funsargs in 
+  let returned_types = Array.of_list returned_types in
+  (* alpha_renaming of the body to prevent variable capture during manipulation *)
+  let rtl_alpha = List.map (function rt ->  expand_as (alpha_rt [] rt)) rtl in
+  let rta = Array.of_list rtl_alpha in
+  (*i The next call to mk_rel_id is valid since we are constructing the graph
+    Ensures by: obvious
+    i*) 
+  let relnames = Array.map mk_rel_id funnames in
+  let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in 
+  (* Construction of the pseudo constructors *)
+  let env = 
+    Array.fold_right 
+      (fun id env -> 
+	 Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id))  env
+      )
+      funnames 
+      (Global.env ())
+  in      
+  let resa = Array.map (build_entry_lc env  funnames_as_set []) rta in 
+  (* and of the real constructors*)
+  let constr i res = 
+    List.map 
+      (function result (* (args',concl') *) -> 
+	 let rt = compose_raw_context result.context result.value in 
+	 let nb_args = List.length funsargs.(i) in 
+	 (*  with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *)
+	 fst (
+	   rebuild_cons nb_args relnames.(i)
+	     []
+	     []
+	     rt 
+	 )
+      ) 
+      res.result 
+  in 
+  (* adding names to constructors  *)
+ let next_constructor_id = ref (-1) in 
+  let mk_constructor_id i = 
+    incr next_constructor_id;
+    (*i The next call to mk_rel_id is valid since we are constructing the graph
+      Ensures by: obvious
+      i*) 
+    id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
+  in
+  let rel_constructors i rt : (identifier*rawconstr) list = 
+    next_constructor_id := (-1);
+    List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
+  in
+  let rel_constructors = Array.mapi rel_constructors resa in
+  (* Computing the set of parameters if asked *)
+  let rels_params = compute_params_name relnames_as_set funsargs  rel_constructors in
+  let nrel_params = List.length rels_params in
+  let rel_constructors = (* Taking into account the parameters in constructors *)
+    Array.map (List.map 
+    (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt))))
+    rel_constructors
+  in
+  let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
+    let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list  = 
+      (snd (list_chop nrel_params funargs))
+    in 
+    List.fold_right
+      (fun (n,t,is_defined) acc -> 
+	 if is_defined
+	 then 
+	   Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
+			    acc)
+	 else
+	   Topconstr.CProdN
+	   (dummy_loc,
+	    [[(dummy_loc,n)],Constrextern.extern_rawconstr Idset.empty t],
+	    acc
+	   )
+      )
+      rel_first_args
+      (rebuild_return_type returned_types.(i))
+  in
+  (* We need to lift back our work topconstr but only with all information 
+     We mimick a Set Printing All. 
+     Then save the graphs and reset Printing options to their primitive values 
+  *)
+  let rel_arities = Array.mapi rel_arity funsargs in
+  let rel_params =  
+    List.map 
+      (fun (n,t,is_defined) -> 
+	 if is_defined 
+	 then
+	   Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
+	 else
+	 Topconstr.LocalRawAssum 
+	   ([(dummy_loc,n)], Constrextern.extern_rawconstr Idset.empty t)
+      )
+      rels_params
+  in 
+  let ext_rels_constructors = 
+    Array.map (List.map 
+      (fun (id,t) -> 
+	 false,((dummy_loc,id),
+		Options.with_option
+		  Options.raw_print
+		  (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t)
+	       )
+      ))
+      (rel_constructors)
+  in
+  let rel_ind i ext_rel_constructors = 
+    ((dummy_loc,relnames.(i)),
+    rel_params,
+    rel_arities.(i),
+    ext_rel_constructors),None
+  in
+  let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in 
+  let rel_inds = Array.to_list ext_rel_constructors in 
+(*   let _ =  *)
+(*   Pp.msgnl  (\* observe *\) ( *)
+(*       str "Inductive" ++ spc () ++ *)
+(* 	prlist_with_sep  *)
+(* 	(fun () -> fnl ()++spc () ++ str "with" ++ spc ())  *)
+(* 	(function ((_,id),_,params,ar,constr) ->  *)
+(* 	   Ppconstr.pr_id id ++ spc () ++  *)
+(* 	     Ppconstr.pr_binders params ++ spc () ++ *)
+(* 	     str ":" ++ spc () ++  *)
+(* 	     Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *)
+(* 	     prlist_with_sep  *)
+(* 	     (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *)
+(* 	     (function (_,((_,id),t)) ->  *)
+(* 		Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *)
+(* 		  Ppconstr.pr_lconstr_expr t) *)
+(* 	     constr *)
+(* 	) *)
+(* 	rel_inds *)
+(*     ) *)
+(*   in *)
+  let _time2 = System.get_time () in 
+  try 
+    with_full_print (Options.silently (Command.build_mutual rel_inds)) true
+  with 
+    | UserError(s,msg) as e ->
+	let _time3 = System.get_time () in
+(* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
+	let msg = 		     
+	  str "while trying to define"++ spc () ++
+	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++
+	    msg
+	in
+	observe (msg);
+	raise e
+    | e -> 
+	let _time3 = System.get_time () in
+(* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
+	let msg = 		     
+	  str "while trying to define"++ spc () ++
+	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++
+	    Cerrors.explain_exn e
+	in
+ 	observe msg;
+	raise e
+
+
+
+let build_inductive funnames funsargs returned_types rtl = 
+  try 
+    do_build_inductive funnames funsargs returned_types rtl
+  with e -> raise (Building_graph e)
+      
+
diff --git a/contrib/funind/rawterm_to_relation.mli b/contrib/funind/rawterm_to_relation.mli
new file mode 100644
index 00000000..0075fb0a
--- /dev/null
+++ b/contrib/funind/rawterm_to_relation.mli
@@ -0,0 +1,16 @@
+
+
+
+(*
+  [build_inductive parametrize funnames funargs returned_types bodies] 
+  constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments 
+  and returning [returned_types] using bodies [bodies]
+*)
+
+val build_inductive :
+  Names.identifier list -> (* The list of function name *)
+  (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *)
+  Topconstr.constr_expr list -> (* The list of function returned type *)
+  Rawterm.rawconstr list -> (* the list of body *)
+  unit
+
diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml
new file mode 100644
index 00000000..ba5c2bbd
--- /dev/null
+++ b/contrib/funind/rawtermops.ml
@@ -0,0 +1,671 @@
+open Pp 
+open Rawterm
+open Util
+open Names
+(* Ocaml 3.06 Map.S does not handle is_empty *)
+let idmap_is_empty m = m = Idmap.empty
+
+(* 
+   Some basic functions to rebuild rawconstr
+   In each of them the location is Util.dummy_loc
+*)
+let mkRRef ref = RRef(dummy_loc,ref)
+let mkRVar id = RVar(dummy_loc,id)
+let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl)
+let mkRLambda(n,t,b) = RLambda(dummy_loc,n,t,b)
+let mkRProd(n,t,b) = RProd(dummy_loc,n,t,b)
+let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b)
+let mkRCases(rto,l,brl) = RCases(dummy_loc,rto,l,brl)
+let mkRSort s = RSort(dummy_loc,s)
+let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous)
+let mkRCast(b,t) = RCast(dummy_loc,b,CastCoerce,t)
+
+(*
+  Some basic functions to decompose rawconstrs
+  These are analogous to the ones constrs
+*)
+let raw_decompose_prod = 
+  let rec raw_decompose_prod args = function 
+  | RProd(_,n,t,b) -> 
+      raw_decompose_prod ((n,t)::args) b 
+  | rt -> args,rt
+  in
+  raw_decompose_prod []
+
+let raw_compose_prod = 
+  List.fold_left (fun b (n,t) -> mkRProd(n,t,b))
+
+let raw_decompose_prod_n n = 
+  let rec raw_decompose_prod i args c = 
+    if i<=0 then args,c
+    else
+      match c with
+	| RProd(_,n,t,b) -> 
+	    raw_decompose_prod (i-1) ((n,t)::args) b 
+	| rt -> args,rt
+  in
+  raw_decompose_prod n []
+
+
+let raw_decompose_app = 
+  let rec decompose_rapp acc rt =
+(*     msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *)
+    match rt with 
+    | RApp(_,rt,rtl) -> 
+	decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
+    | rt -> rt,List.rev acc
+  in
+  decompose_rapp [] 
+
+
+
+
+(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) 
+let raw_make_eq ?(typ= mkRHole ()) t1 t2  = 
+  mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1])
+
+(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) 
+let raw_make_neq t1 t2 = 
+  mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2])
+
+(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) 
+let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
+
+(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding 
+   to [P1 \/ ( .... \/ Pn)] 
+*) 
+let rec raw_make_or_list = function  
+  | [] -> raise (Invalid_argument "mk_or")
+  | [e] -> e
+  | e::l -> raw_make_or e (raw_make_or_list l)
+
+  
+let remove_name_from_mapping mapping na = 
+  match na with 
+    | Anonymous -> mapping 
+    | Name id -> Idmap.remove id mapping
+
+let change_vars = 
+  let rec change_vars mapping rt = 
+    match rt with 
+      | RRef _ -> rt 
+      | RVar(loc,id) ->  
+	  let new_id = 
+	    try 
+	      Idmap.find id mapping 
+	    with Not_found -> id 
+	  in
+	  RVar(loc,new_id)
+      | REvar _ -> rt 
+      | RPatVar _ -> rt 
+      | RApp(loc,rt',rtl) -> 
+	  RApp(loc,
+	       change_vars mapping rt',
+	       List.map (change_vars mapping) rtl
+	      )
+      | RLambda(loc,name,t,b) -> 
+	  RLambda(loc,
+		  name,
+		  change_vars mapping t,
+		  change_vars (remove_name_from_mapping mapping name) b
+		 )
+      | RProd(loc,name,t,b) -> 
+	  RProd(loc,
+		  name,
+		  change_vars mapping t,
+		  change_vars (remove_name_from_mapping mapping name) b
+		 )
+      | RLetIn(loc,name,def,b) -> 
+	  RLetIn(loc,
+		 name,
+		 change_vars mapping def,
+		 change_vars (remove_name_from_mapping mapping name) b
+		)
+      | RLetTuple(loc,nal,(na,rto),b,e) -> 
+	  let new_mapping = List.fold_left remove_name_from_mapping mapping nal in 
+	  RLetTuple(loc,
+		    nal,
+		    (na, option_map (change_vars mapping) rto), 
+		    change_vars mapping b, 
+		    change_vars new_mapping e
+		   )
+      | RCases(loc,infos,el,brl) -> 
+	  RCases(loc,
+		 infos,
+		 List.map (fun (e,x) -> (change_vars mapping e,x)) el, 
+		 List.map (change_vars_br mapping) brl
+		)
+      | RIf(loc,b,(na,e_option),lhs,rhs) -> 
+	  RIf(loc,
+	      change_vars mapping b,
+	      (na,option_map (change_vars mapping) e_option),
+	      change_vars mapping lhs,
+	      change_vars mapping rhs
+	     )
+      | RRec _ -> error "Local (co)fixes are not supported"
+      | RSort _ -> rt 
+      | RHole _ -> rt 
+      | RCast(loc,b,k,t) -> 
+	  RCast(loc,change_vars mapping b,k,change_vars mapping t)
+      | RDynamic _ -> error "Not handled RDynamic"
+  and change_vars_br mapping ((loc,idl,patl,res) as br) = 
+    let new_mapping = List.fold_right Idmap.remove idl mapping in 
+    if idmap_is_empty new_mapping 
+    then br 
+    else (loc,idl,patl,change_vars new_mapping res)
+  in
+  change_vars 
+
+
+
+let rec alpha_pat excluded pat = 
+  match pat with 
+    | PatVar(loc,Anonymous) -> 
+	let new_id = Indfun_common.fresh_id excluded "_x" in 
+	PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty
+    | PatVar(loc,Name id) -> 
+	if List.mem id excluded 
+	then 
+	  let new_id = Nameops.next_ident_away id excluded in 
+	  PatVar(loc,Name new_id),(new_id::excluded),
+	(Idmap.add id new_id Idmap.empty)
+	else pat,excluded,Idmap.empty
+    | PatCstr(loc,constr,patl,na) -> 
+	let new_na,new_excluded,map = 
+	  match na with 
+	    | Name id when List.mem id excluded -> 
+		let new_id = Nameops.next_ident_away id excluded in 
+		Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty
+	    | _ -> na,excluded,Idmap.empty
+	in 
+	let new_patl,new_excluded,new_map = 
+	  List.fold_left 
+	    (fun (patl,excluded,map) pat -> 
+	       let new_pat,new_excluded,new_map = alpha_pat excluded pat in 
+	       (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map)
+	    )
+	    ([],new_excluded,map)
+	    patl
+	in 
+	PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map
+
+let alpha_patl excluded patl  = 
+  let patl,new_excluded,map = 
+    List.fold_left 
+      (fun (patl,excluded,map) pat -> 
+	 let new_pat,new_excluded,new_map = alpha_pat excluded pat in 
+	 new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map)
+      )
+      ([],excluded,Idmap.empty)
+      patl
+  in 
+  (List.rev patl,new_excluded,map)
+
+
+
+  
+let raw_get_pattern_id pat acc = 
+  let rec get_pattern_id pat = 
+    match pat with 
+      | PatVar(loc,Anonymous) -> assert false
+      | PatVar(loc,Name id) -> 
+	  [id]
+      | PatCstr(loc,constr,patternl,_) -> 
+	  List.fold_right 
+	  (fun pat idl -> 
+	     let idl' = get_pattern_id pat in 
+	     idl'@idl
+	  )
+	    patternl 
+	    []
+  in
+  (get_pattern_id pat)@acc
+
+let get_pattern_id pat = raw_get_pattern_id pat []
+	      
+let rec alpha_rt excluded rt = 
+  let new_rt = 
+    match rt with   
+      | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
+      | RLambda(loc,Anonymous,t,b) -> 
+	  let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in 
+	  let new_excluded = new_id :: excluded in 
+	  let new_t = alpha_rt new_excluded t in 
+	  let new_b = alpha_rt new_excluded b in 
+	  RLambda(loc,Name new_id,new_t,new_b)
+      | RProd(loc,Anonymous,t,b) -> 
+	let new_t = alpha_rt excluded t in 
+	let new_b = alpha_rt excluded b in 
+	RProd(loc,Anonymous,new_t,new_b)
+    | RLetIn(loc,Anonymous,t,b) -> 
+	let new_t = alpha_rt excluded t in 
+	let new_b = alpha_rt excluded b in 
+	RLetIn(loc,Anonymous,new_t,new_b)
+    | RLambda(loc,Name id,t,b) -> 
+	let new_id = Nameops.next_ident_away id excluded in 
+	let t,b = 
+	  if new_id = id 
+	  then t,b
+	  else 
+	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
+	    (t,replace b)
+	in
+	let new_excluded = new_id::excluded in 
+	let new_t = alpha_rt new_excluded t in 
+	let new_b = alpha_rt new_excluded b in 
+	RLambda(loc,Name new_id,new_t,new_b)
+    | RProd(loc,Name id,t,b) -> 
+	let new_id = Nameops.next_ident_away id excluded in 
+	let new_excluded = new_id::excluded in 
+	let t,b = 
+	  if new_id = id 
+	  then t,b
+	  else 
+	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
+	    (t,replace b)
+	in
+	let new_t = alpha_rt new_excluded t in 
+	let new_b = alpha_rt new_excluded b in 
+	RProd(loc,Name new_id,new_t,new_b)
+    | RLetIn(loc,Name id,t,b) -> 
+	let new_id = Nameops.next_ident_away id excluded in 
+	let t,b = 
+	  if new_id = id 
+	  then t,b
+	  else 
+	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in 
+	    (t,replace b)
+	in
+	let new_excluded = new_id::excluded in 
+	let new_t = alpha_rt new_excluded t in 
+	let new_b = alpha_rt new_excluded b in 
+	RLetIn(loc,Name new_id,new_t,new_b)
+
+
+    | RLetTuple(loc,nal,(na,rto),t,b) -> 
+	let rev_new_nal,new_excluded,mapping = 
+	  List.fold_left 
+	    (fun (nal,excluded,mapping) na -> 
+	       match na with 
+		 | Anonymous -> (na::nal,excluded,mapping)
+		 | Name id ->  
+		     let new_id = Nameops.next_ident_away id excluded in 
+		     if new_id = id 
+		     then 
+		       na::nal,id::excluded,mapping 
+		     else 
+		       (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping)
+	    )
+	    ([],excluded,Idmap.empty)
+	    nal
+	in
+	let new_nal = List.rev rev_new_nal in 
+	let new_rto,new_t,new_b = 
+	  if idmap_is_empty mapping
+	  then rto,t,b
+	  else let replace = change_vars mapping in 
+	  (option_map replace rto, t,replace b)
+	in
+	let new_t = alpha_rt new_excluded new_t in 
+	let new_b = alpha_rt new_excluded new_b in 
+	let new_rto = option_map (alpha_rt new_excluded) new_rto  in
+	RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
+    | RCases(loc,infos,el,brl) -> 
+	let new_el = 
+	  List.map (function (rt,i) -> alpha_rt excluded rt, i) el 
+	in 
+	RCases(loc,infos,new_el,List.map (alpha_br excluded) brl) 
+    | RIf(loc,b,(na,e_o),lhs,rhs) -> 
+	RIf(loc,alpha_rt excluded b,
+	    (na,option_map (alpha_rt excluded) e_o),
+	    alpha_rt excluded lhs,
+	    alpha_rt excluded rhs
+	   )
+    | RRec _ -> error "Not handled RRec"
+    | RSort _ -> rt 
+    | RHole _ -> rt 
+    | RCast (loc,b,k,t) -> 
+	RCast(loc,alpha_rt excluded b,k,alpha_rt excluded t)
+    | RDynamic _ -> error "Not handled RDynamic"
+    | RApp(loc,f,args) -> 
+	RApp(loc,
+	     alpha_rt excluded f,
+	     List.map (alpha_rt excluded) args
+	    )
+  in 
+  new_rt
+
+and alpha_br excluded (loc,ids,patl,res) = 
+  let new_patl,new_excluded,mapping = alpha_patl excluded patl in 
+  let new_ids = List.fold_right raw_get_pattern_id new_patl [] in 
+  let new_excluded = new_ids@excluded in 
+  let renamed_res = change_vars mapping res in 
+  let new_res = alpha_rt new_excluded renamed_res in 
+  (loc,new_ids,new_patl,new_res)
+    
+(* 
+   [is_free_in id rt] checks if [id] is a free variable in [rt]
+*)
+let is_free_in id =
+  let rec is_free_in = function
+    | RRef _ ->  false
+    | RVar(_,id') -> id_ord id' id == 0
+    | REvar _ -> false
+    | RPatVar _ -> false
+    | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
+    | RLambda(_,n,t,b) | RProd(_,n,t,b) | RLetIn(_,n,t,b) ->
+	let check_in_b =
+	  match n with
+	    | Name id' -> id_ord id' id <> 0
+	    | _ -> true
+	in
+	is_free_in t || (check_in_b && is_free_in b)
+    | RCases(_,_,el,brl) ->
+	(List.exists (fun (e,_) -> is_free_in e) el) ||
+	  List.exists is_free_in_br brl
+
+    | RLetTuple(_,nal,_,b,t) -> 
+	let check_in_nal = 
+	  not (List.exists (function Name id' -> id'= id | _ -> false) nal) 
+	in 
+	is_free_in t  || (check_in_nal && is_free_in b)
+	  
+    | RIf(_,cond,_,br1,br2) ->
+	is_free_in cond || is_free_in br1 || is_free_in br2
+    | RRec _ -> raise (UserError("",str "Not handled RRec"))
+    | RSort _ -> false
+    | RHole _ -> false
+    | RCast (_,b,_,t) -> is_free_in b || is_free_in t
+    | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+  and is_free_in_br (_,ids,_,rt) =
+    (not (List.mem id ids)) && is_free_in rt
+  in
+  is_free_in
+      
+
+
+let rec pattern_to_term  = function
+  | PatVar(loc,Anonymous) -> assert false
+  | PatVar(loc,Name id) ->
+	mkRVar id
+  | PatCstr(loc,constr,patternl,_) ->
+      let cst_narg =
+	Inductiveops.mis_constructor_nargs_env
+	  (Global.env ())
+	  constr
+      in
+      let implicit_args =
+	Array.to_list
+	  (Array.init
+	     (cst_narg - List.length patternl)
+	     (fun _ -> mkRHole ())
+	  )
+      in
+      let patl_as_term =
+	List.map pattern_to_term patternl
+      in
+      mkRApp(mkRRef(Libnames.ConstructRef constr),
+	     implicit_args@patl_as_term
+	    )
+
+  
+
+let replace_var_by_term x_id term = 
+  let rec replace_var_by_pattern rt = 
+    match rt with 
+      | RRef _ -> rt 
+      | RVar(_,id) when id_ord id x_id == 0 -> term
+      | RVar _ -> rt 
+      | REvar _ -> rt 
+      | RPatVar _ -> rt 
+      | RApp(loc,rt',rtl) -> 
+	  RApp(loc,
+	       replace_var_by_pattern rt',
+	       List.map replace_var_by_pattern rtl
+	      )
+      | RLambda(_,Name id,_,_) when id_ord id x_id == 0 -> rt
+      | RLambda(loc,name,t,b) -> 
+	  RLambda(loc,
+		  name,
+		  replace_var_by_pattern t,
+		  replace_var_by_pattern b
+		 )
+      | RProd(_,Name id,_,_) when id_ord id x_id == 0 -> rt
+      | RProd(loc,name,t,b) -> 
+	  RProd(loc,
+		  name,
+		  replace_var_by_pattern t,
+		  replace_var_by_pattern b
+		 )
+      | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
+      | RLetIn(loc,name,def,b) -> 
+	  RLetIn(loc,
+		 name,
+		 replace_var_by_pattern def,
+		 replace_var_by_pattern b
+		)
+      | RLetTuple(_,nal,_,_,_) 
+	  when List.exists (function Name id -> id = x_id | _ -> false) nal  ->  
+	  rt
+      | RLetTuple(loc,nal,(na,rto),def,b) -> 
+	  RLetTuple(loc,
+		    nal,
+		    (na,option_map replace_var_by_pattern rto),
+		    replace_var_by_pattern def,
+		    replace_var_by_pattern b
+		   )
+      | RCases(loc,infos,el,brl) -> 
+	  RCases(loc,
+		 infos,
+		 List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, 
+		 List.map replace_var_by_pattern_br brl
+		)
+      | RIf(loc,b,(na,e_option),lhs,rhs) -> 
+	  RIf(loc, replace_var_by_pattern b,
+	      (na,option_map replace_var_by_pattern e_option),
+	      replace_var_by_pattern lhs,
+	      replace_var_by_pattern rhs
+	     )
+      | RRec _ -> raise (UserError("",str "Not handled RRec"))
+      | RSort _ -> rt 
+      | RHole _ -> rt 
+      | RCast(loc,b,k,t) -> 
+	  RCast(loc,replace_var_by_pattern b,k,replace_var_by_pattern t)
+      | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+  and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = 
+    if List.exists (fun id -> id_ord id x_id == 0) idl 
+    then br 
+    else (loc,idl,patl,replace_var_by_pattern res)
+  in
+  replace_var_by_pattern 
+
+
+
+
+(* checking unifiability of patterns *) 
+exception NotUnifiable  
+
+let rec are_unifiable_aux  = function 
+  | [] -> () 
+  | eq::eqs -> 
+      match eq with 
+	 | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs 
+	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> 
+	     if constructor2 <> constructor1 
+	     then raise NotUnifiable
+	     else 
+	       let eqs' = 
+ 		 try  ((List.combine cpl1 cpl2)@eqs)
+		 with _ -> anomaly "are_unifiable_aux" 
+	       in
+	       are_unifiable_aux eqs'
+		 
+let are_unifiable pat1 pat2 = 
+  try 
+    are_unifiable_aux [pat1,pat2];
+    true
+  with NotUnifiable -> false
+
+
+let rec eq_cases_pattern_aux  = function 
+  | [] -> () 
+  | eq::eqs -> 
+      match eq with 
+	 | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs 
+	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> 
+	     if constructor2 <> constructor1 
+	     then raise NotUnifiable
+	     else 
+	       let eqs' = 
+ 		 try  ((List.combine cpl1 cpl2)@eqs)
+		 with _ -> anomaly "eq_cases_pattern_aux" 
+	       in
+	       eq_cases_pattern_aux eqs'
+	 | _ -> raise NotUnifiable
+
+let eq_cases_pattern pat1 pat2 = 
+  try
+    eq_cases_pattern_aux [pat1,pat2];
+    true
+  with NotUnifiable -> false
+
+
+
+let ids_of_pat = 
+  let rec ids_of_pat ids = function 
+    | PatVar(_,Anonymous) -> ids 
+    | PatVar(_,Name id) -> Idset.add id ids 
+    | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl
+  in
+  ids_of_pat Idset.empty 
+  
+let id_of_name = function 
+  | Names.Anonymous -> id_of_string "x" 
+  | Names.Name x -> x
+
+(* TODO: finish Rec caes *)
+let ids_of_rawterm c = 
+  let rec ids_of_rawterm acc c = 
+    let idof = id_of_name in
+    match c with
+      | RVar (_,id) -> id::acc
+      | RApp (loc,g,args) -> 
+          ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
+      | RLambda (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+      | RProd (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+      | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
+      | RCast (loc,c,k,t) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc
+      | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc
+      | RLetTuple (_,nal,(na,po),b,c) -> 
+          List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
+      | RCases (loc,rtntypopt,tml,brchl) -> 
+	  List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl)
+      | RRec _ -> failwith "Fix inside a constructor branch"
+      | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> []
+  in
+  (* build the set *)
+  List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
+  
+
+
+
+
+let zeta_normalize = 
+  let rec zeta_normalize_term rt = 
+    match rt with 
+      | RRef _ -> rt 
+      | RVar _ -> rt 
+      | REvar _ -> rt 
+      | RPatVar _ -> rt 
+      | RApp(loc,rt',rtl) -> 
+	  RApp(loc,
+	       zeta_normalize_term rt',
+	       List.map zeta_normalize_term rtl
+	      )
+      | RLambda(loc,name,t,b) -> 
+	  RLambda(loc,
+		  name,
+		  zeta_normalize_term t,
+		  zeta_normalize_term b
+		 )
+      | RProd(loc,name,t,b) -> 
+	  RProd(loc,
+		name, 		  
+		zeta_normalize_term t,
+		zeta_normalize_term b
+		 )
+      | RLetIn(_,Name id,def,b) -> 
+	  zeta_normalize_term (replace_var_by_term id def b)
+      | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
+      | RLetTuple(loc,nal,(na,rto),def,b) -> 
+	  RLetTuple(loc,
+		    nal,
+		    (na,option_map zeta_normalize_term rto),
+		    zeta_normalize_term def,
+		    zeta_normalize_term b
+		   )
+      | RCases(loc,infos,el,brl) -> 
+	  RCases(loc,
+		 infos,
+		 List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, 
+		 List.map zeta_normalize_br brl
+		)
+      | RIf(loc,b,(na,e_option),lhs,rhs) -> 
+	  RIf(loc, zeta_normalize_term b,
+	      (na,option_map zeta_normalize_term e_option),
+	      zeta_normalize_term lhs,
+	      zeta_normalize_term rhs
+	     )
+      | RRec _ -> raise (UserError("",str "Not handled RRec"))
+      | RSort _ -> rt 
+      | RHole _ -> rt 
+      | RCast(loc,b,k,t) -> 
+	  RCast(loc,zeta_normalize_term b,k,zeta_normalize_term t)
+      | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+  and zeta_normalize_br (loc,idl,patl,res) = 
+    (loc,idl,patl,zeta_normalize_term res)
+  in
+  zeta_normalize_term 
+
+
+
+
+let expand_as = 
+  
+  let rec add_as map pat = 
+    match pat with 
+      | PatVar _ -> map 
+      | PatCstr(_,_,patl,Name id) -> 
+	  Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl)
+      | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
+  in 
+  let rec expand_as map rt = 
+    match rt with 
+      | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt 
+      | RVar(_,id) -> 
+	  begin
+	    try 
+	      Idmap.find id map
+	    with Not_found -> rt 
+	  end
+      | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
+      | RLambda(loc,na,t,b) -> RLambda(loc,na,expand_as map t, expand_as map b)
+      | RProd(loc,na,t,b) -> RProd(loc,na,expand_as map t, expand_as map b)
+      | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b)
+      | RLetTuple(loc,nal,(na,po),v,b) ->
+	  RLetTuple(loc,nal,(na,option_map (expand_as map) po),
+		    expand_as map v, expand_as map b)
+      | RIf(loc,e,(na,po),br1,br2) ->
+	  RIf(loc,expand_as map e,(na,option_map (expand_as map) po),
+	      expand_as map br1, expand_as map br2)
+      | RRec _ ->  error "Not handled RRec"
+      | RDynamic _ -> error "Not handled RDynamic"
+      | RCast(loc,b,kind,t) -> RCast(loc,expand_as map b,kind,expand_as map t)
+      | RCases(loc,po,el,brl) ->
+	  RCases(loc, option_map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
+		List.map (expand_as_br map) brl)
+	    
+  and expand_as_br map (loc,idl,cpl,rt) = 
+    (loc,idl,cpl,    expand_as (List.fold_left add_as map cpl) rt)
+  in
+  expand_as Idmap.empty 
diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli
new file mode 100644
index 00000000..9647640c
--- /dev/null
+++ b/contrib/funind/rawtermops.mli
@@ -0,0 +1,120 @@
+open Rawterm
+
+(* Ocaml 3.06 Map.S does not handle is_empty *)
+val idmap_is_empty : 'a Names.Idmap.t -> bool
+
+
+(* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *)
+val get_pattern_id : cases_pattern -> Names.identifier list
+
+(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. 
+   [pat] must not contain occurences of anonymous pattern 
+*)
+val pattern_to_term : cases_pattern -> rawconstr 
+
+(* 
+   Some basic functions to rebuild rawconstr
+   In each of them the location is Util.dummy_loc
+*)
+val mkRRef : Libnames.global_reference -> rawconstr
+val mkRVar : Names.identifier -> rawconstr
+val mkRApp  : rawconstr*(rawconstr list) -> rawconstr
+val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr
+val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr
+val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr
+val mkRCases : rawconstr option * tomatch_tuple * cases_clauses -> rawconstr
+val mkRSort : rawsort -> rawconstr 
+val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *)
+val mkRCast : rawconstr* rawconstr -> rawconstr 
+(*
+  Some basic functions to decompose rawconstrs
+  These are analogous to the ones constrs
+*)
+val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr
+val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr
+val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list  ->  rawconstr 
+val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list)
+
+
+(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) 
+val  raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr
+(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) 
+val  raw_make_neq : rawconstr -> rawconstr -> rawconstr
+(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) 
+val  raw_make_or : rawconstr -> rawconstr -> rawconstr
+
+(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding 
+   to [P1 \/ ( .... \/ Pn)] 
+*) 
+val  raw_make_or_list : rawconstr list -> rawconstr
+
+
+(* alpha_conversion functions *)
+
+
+
+(* Replace the var mapped in the rawconstr/context *)
+val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr
+
+
+
+(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. 
+   the result does not share variables with [avoid]. This function create 
+   a fresh variable for each occurence of the anonymous pattern.
+
+   Also returns a mapping  from old variables to new ones and the concatenation of
+   [avoid] with the variables appearing in the result.
+*)
+  val alpha_pat :
+    Names.Idmap.key list ->
+    Rawterm.cases_pattern ->
+    Rawterm.cases_pattern * Names.Idmap.key list *
+      Names.identifier Names.Idmap.t
+
+(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt 
+   conventions and  does not share bound variables with avoid 
+*)
+val alpha_rt : Names.identifier list -> rawconstr -> rawconstr
+
+(* same as alpha_rt but for case branches *)
+val alpha_br : Names.identifier list ->
+    Util.loc * Names.identifier list * Rawterm.cases_pattern list *
+    Rawterm.rawconstr ->
+    Util.loc * Names.identifier list * Rawterm.cases_pattern list *
+    Rawterm.rawconstr
+
+
+(* Reduction function *) 
+val replace_var_by_term  :     
+  Names.identifier ->
+  Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr
+
+
+
+(* 
+   [is_free_in id rt] checks if [id] is a free variable in [rt]
+*)
+val is_free_in : Names.identifier -> rawconstr -> bool
+
+
+val are_unifiable : cases_pattern -> cases_pattern -> bool 
+val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
+
+
+
+(* 
+   ids_of_pat : cases_pattern -> Idset.t 
+   returns the set of variables appearing in a pattern 
+*)
+val   ids_of_pat : cases_pattern -> Names.Idset.t 
+
+(* TODO: finish this function (Fix not treated) *)
+val ids_of_rawterm: rawconstr -> Names.Idset.t
+
+(* 
+   removing let_in construction in a rawterm 
+*)
+val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr
+
+
+val expand_as : rawconstr -> rawconstr
diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4
index 1500e1ae..5d19079b 100644
--- a/contrib/funind/tacinv.ml4
+++ b/contrib/funind/tacinv.ml4
@@ -1,16 +1,10 @@
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
 (*s FunInv Tactic: inversion following the shape of a function.  *)
-(* Use:
-   \begin{itemize}
-   \item The Tacinv directory must be in the path (-I <path> option)
-   \item use the bytecode version of coqtop or coqc (-byte option), or make a
-         coqtop 
-   \item Do [Require Tacinv] to be able to use it.
-   \item For syntax see Tacinv.v
-   \end{itemize}
-*)
 
+(* Deprecated: see indfun_main.ml4 instead *)
+
+(* Don't delete this file yet, it may be used for other purposes *)
 
 (*i*)
 open Termops
@@ -46,6 +40,8 @@ let smap_to_list m = Smap.fold (fun c cb l -> (c,cb)::l) m []
 let merge_smap m1 m2 = Smap.fold (fun c cb m -> Smap.add c cb m) m1 m2
 let rec listsuf i l = if i<=0 then l else listsuf (i-1) (List.tl l)
 let rec listpref i l = if i<=0 then [] else List.hd l :: listpref (i-1) (List.tl l)
+let rec split3 l = 
+  List.fold_right (fun (e1,e2,e3) (a,b,c) -> (e1::a),(e2::b),(e3::c)) l ([],[],[])
 
 let mkthesort = mkProp (* would like to put Type here, but with which index? *)
 
@@ -56,9 +52,7 @@ let equality_hyp_string = "_eg_"
 (* bug de refine: on doit ssavoir sur quelle hypothese on se trouve. valeur
    initiale au debut de l'appel a la fonction proofPrinc: 1. *)
 let nthhyp = ref 1
- (*debugging*)
- (* let rewrules = ref [] *)
- (*debugging*)
+
 let debug i = prstr ("DEBUG "^ string_of_int i ^"\n")
 let pr2constr = (fun c1 c2 -> prconstr c1; prstr " <---> "; prconstr c2)
 (* Operations on names *)
@@ -71,21 +65,6 @@ let string_of_name nme = string_of_id (id_of_name nme)
 (* Interpretation of constr's *)
 let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
 
-let rec collect_cases l =
- match l with
-  | [||] -> [||],[],[],[||],[||],[]
-  | arr -> 
-     let (a,c,d,f,e,g)= arr.(0) in
-     let aa,lc,ld,_,_,_ = 
-      collect_cases (Array.sub arr 1 ((Array.length arr)-1)) in
-     Array.append [|a|] aa , (c@lc) , (d@ld) , f , e, g
-
-let rec collect_pred l =
- match l with
-  | [] -> [],[],[]
-  | (e1,e2,e3)::l' -> let a,b,c = collect_pred l' in (e1::a),(e2::b),(e3::c)
-
-
 (*s specific manipulations on constr *)
 let lift1_leqs leq=
  List.map 
@@ -194,29 +173,25 @@ let applFull c typofc =
  let res = mkAppRel c ltyp (List.length ltyp) in
  res
 
-
+(* Take two terms with same structure and return a map of deBruijn from the
+   first to the second. Only DeBruijn should be different between the two
+   terms. *)
 let rec build_rel_map typ type_of_b = 
  match (kind_of_term typ), (kind_of_term type_of_b) with
     Evar _ , Evar _  -> Smap.empty
-  | Rel i, Rel j -> if i=j then Smap.empty 
-    else Smap.add typ type_of_b Smap.empty
+  | Const c1, Const c2  when c1=c2 -> Smap.empty
+  | Ind c1, Ind c2 when c1=c2 -> Smap.empty
+  | Rel i, Rel j when i=j -> Smap.empty
+  | Rel i, Rel j -> Smap.add typ type_of_b Smap.empty
   | Prod (name,c1,c2), Prod (nameb,c1b,c2b) -> 
      let map1 = build_rel_map c1 c1b in
      let map2 = build_rel_map (pop c2) (pop c2b) in
      merge_smap map1 map2
-  | App (f,args), App (fb,argsb) ->
-     (try build_rel_map_list (Array.to_list args) (Array.to_list argsb)
-     with Invalid_argument _ -> 
-      failwith ("Could not generate case annotation. "^ 
-      "Two application with different length"))
-  | Const c1, Const c2 -> if c1=c2 then Smap.empty
-    else failwith ("Could not generate case annotation. "^ 
-    "Two different constants in a case annotation.")
-  | Ind c1, Ind c2 -> if c1=c2 then Smap.empty
-    else failwith ("Could not generate case annotation. "^ 
-    "Two different constants in a case annotation.")
+  | App (f,args), App (fb,argsb) when Array.length args = Array.length argsb ->
+     build_rel_map_list (Array.to_list args) (Array.to_list argsb)
   | _,_ -> failwith ("Could not generate case annotation. "^
     "Incompatibility between annotation and actual type")
+
 and build_rel_map_list ltyp ltype_of_b =
  List.fold_left2 (fun a b c -> merge_smap a (build_rel_map b c))
   Smap.empty ltyp ltype_of_b
@@ -224,299 +199,235 @@ and build_rel_map_list ltyp ltype_of_b =
 
 (*s Use (and proof) of the principle *)
 
-(*
-  \begin {itemize}
-  \item [concl] ([constr]): conclusions, cad (xi:ti)gl, ou gl est le but a
-  prouver, et xi:ti correspondent aux arguments donnés à la tactique.  On
-  enlève un produit à chaque fois qu'on rencontre un binder, sans lift ou pop.
-  Initialement: une seule conclusion, puis specifique a chaque branche.
-  \item[absconcl] ([constr array]): les conclusions (un predicat pour chaque
-  fixp. mutuel) patternisées pour  pouvoir être appliquées.
-  \item [mimick] ([constr]): le terme qu'on imite. On plonge  dedans au fur et
-  à mesure, sans lift ni pop.
-  \item [nmefonc] ([constr array]): la constante correspondant à la fonction
-  appelée, permet de remplacer les appels recursifs par des appels à la
-  constante correspondante (non pertinent (et inutile) si on permet l'appel de
-  la tactique sur une terme donné directement (au lieu d'une constante comme
-  pour l'instant)).
-  \item [fonc] ([int*int]) : bornes des indices des variable correspondant aux
-  appels récursifs (plusieurs car fixp.  mutuels), utile pour reconnaître les
-  appels récursifs (ATTENTION: initialement vide, reste vide tant qu'on n'est
-  pas dans un fix).  
-  \end{itemize}
-*)
+(* This is the type of the argument of [proofPrinc] *)
 
 type mimickinfo =
     {
-     concl: constr;
-     absconcl: constr array;
-     mimick: constr;
-     env: env;
-     sigma: Evd.evar_map;
-     nmefonc: constr array;
-     fonc: int * int;
+     concl: constr; (* conclusion voulue, cad (xi:ti)gl, ou gl est le but a
+                       prouver, et xi:ti correspondent aux arguments donnés à
+                       la tactique.  On enlèvera un produit à chaque fois
+                       qu'on rencontrera un binder, sans lift ou pop.
+                       Initialement: une seule conclusion, puis specifique à
+                       chaque branche. *)
+     absconcl: constr array; (* conclusions patternisées pour pouvoir être
+                                appliquées = un predicat pour chaque fixpt
+                                mutuel. *)
+     mimick: constr; (* le terme qu'on imite. On plongera  dedans au fur et
+                        à mesure, sans lift ni pop. *)
+     env: env; (* The global typing environment, we will add thing in it when
+                  going inside the term (push_rel, push_rec_types) *)
+     sigma: Evd.evar_map; 
+     nmefonc: constr array; (* la constante correspondant à la fonction
+                               appelée, permet de remplacer les appels
+                               recursifs par des appels à la constante
+                               correspondante (non pertinent (et inutile) si
+                               on permet l'appel de la tactique sur une terme
+                               donné directement (au lieu d'une constante
+                               comme pour l'instant)). *)
+     fonc: int * int; (* bornes des indices des variable correspondant aux
+                         appels récursifs (plusieurs car fixp.  mutuels),
+                         utile pour reconnaître les appels récursifs
+                         (ATTENTION: initialement vide, reste vide tant qu'on
+                         n'est pas dans un fix).  *)
      doeqs: bool; (* this reference is to toggle building of equalities during
                     the building of the principle (default is true) *)
-     fix: bool (* did I already went through a fix or case constr? lambdas
+     fix: bool; (* did I already went through a fix or case constr? lambdas
                   found before a case or a fix are treated as parameters of
                   the induction principle *)
+     lst_vars: (constr*(name*constr)) list ; (* Variables rencontrées jusque là *)
+     lst_eqs: (Term.constr * (Term.constr * Term.constr * Term.constr)) list ; 
+                                   (* liste d'équations engendrées au cours du
+                                      parcours, cette liste grandit à chaque
+                                      case, et il faut lifter le tout à chaque
+                                      binder *)
+     lst_recs: constr list ; (* appels récursifs rencontrés jusque là *)
     }
 
-(*
-  \begin{itemize}
-  \item [lst_vars] ([(constr*(name*constr)) list]): liste des variables
-  rencontrées jusqu'à maintenant.
-  \item [lst_eqs] ([constr list]): liste d'équations engendrées au cours du
-  parcours, cette liste grandit à chaque case, et il faut lifter le tout à
-  chaque binder.
-  \item [lst_recs] ([constr list]): listes des appels récursifs rencontrés
-  jusque là.
-  \end{itemize}
-
-  Cette fonction rends un nuplet de la forme:
-
-  [t,
-  [(ev1,tev1);(ev2,tev2)..],
-  [(i1,j1,k1);(i2,j2,k2)..],
-  [|c1;c2..|],
-  [|typ1;typ2..|],
-  [(param,tparam)..]]
-
- *)
-
-(* This could be the return type of [proofPrinc], but not yet *)
-type funind =
+(* This is the return type of [proofPrinc] *)
+type 'a funind = (* 'A = CONTR  OU  CONSTR ARRAY *)
     {
-     princ:constr;
-     evarlist: (constr*Term.types) list;
-     hypnum: (int*int*int) list;
-     mutfixmetas: constr array ;
-     conclarray: types array;
-     params:(constr*name*constr) list
+
+     princ:'a; (* le (ou les) principe(s) demandé(s), il contient des meta
+                  variables représentant soit des trous à prouver plus tard,
+                  soit les conclusions à compléter avant de rendre le terme
+                  (suivant qu'on utilise le principe pour faire refine ou
+                  functional scheme). Il y plusieurs conclusions si plusieurs
+                  fonction mutuellement récursives) voir la suite. *)
+     evarlist: (constr*Term.types) list; (* [(ev1,tev1);(ev2,tev2)...]]
+                                            l'ensemble des meta variables
+                                            correspondant à des trous. [evi]
+                                            est la meta variable, [tevi] est
+                                            son type. *)
+     hypnum: (int*int*int) list; (* [[(in,jn,kn)...]] sont les nombres
+                                    respectivement de variables, d'équations,
+                                    et d'hypothèses de récurrence pour le but
+                                    n. Permet de faire le bon nombre d'intros
+                                    et des rewrite au bons endroits dans la
+                                    suite. *)
+     mutfixmetas: constr array ; (* un tableau de meta variables correspondant
+                                    à chacun des prédicats mutuellement
+                                    récursifs construits. *)
+     conclarray: types array; (* un tableau contenant les conclusions
+                                 respectives de chacun des prédicats
+                                 mutuellement récursifs. Permet de finir la
+                                 construction du principe. *)
+     params:(constr*name*constr) list; (* [[(metavar,param,tparam)..]] la
+                                          liste des paramètres (les lambdas
+                                          au-dessus du fix) du fixpoint si
+                                          fixpoint il y a, le paramètre est
+                                          une meta var, dont on stocke le nom
+                                          et le type. TODO: utiliser la
+                                          structure adequat? *)
     }
 
-(* 
-  où:
 
-  \begin{itemize} 
 
-  \item[t] est le principe demandé, il contient des meta variables
-  représentant soit des trous à prouver plus tard, soit les conclusions à
-  compléter avant de rendre le terme (suivant qu'on utilise le principe pour
-  faire refine ou functional scheme). Il y plusieurs conclusions si plusieurs
-  fonction mutuellement récursives) voir la suite.
+let empty_funind_constr =
+    {
+     princ = mkProp;
+     evarlist = [];
+     hypnum = [];
+     mutfixmetas = [||];
+     conclarray = [||];
+     params = []
+    }
 
-  \item[[(ev1,tev1);(ev2,tev2)...]] est l'ensemble des méta variables
-  correspondant à des trous. [evi] est la meta variable, [tevi] est son type.
+let empty_funind_array =
+    { empty_funind_constr with
+     princ = [||];
+    }
 
-  \item[(in,jn,kn)] sont les nombres respectivement de variables, d'équations,
-  et d'hypothèses de récurrence pour le but n. Permet de faire le bon nombre
-  d'intros et des rewrite au bons endroits dans la suite.
+(* Replace the calls to the function (recursive calls) by calls to the
+   corresponding constant  *)
+let replace_reccalls mi b =
+ let d,f = mi.fonc in 
+ let res = ref b in
+ let _ = for i = d to f do 
+   res := substitterm 0 (mkRel i) mi.nmefonc.(f-i) !res done in
+ !res
+ 
 
-  \item[[|c1;c2...|]] est un tableau de meta variables correspondant à chacun
-  des prédicats mutuellement récursifs construits.
 
-  \item[[|typ1;typ2...|]] est un tableau contenant les conclusions respectives
-  de chacun des prédicats mutuellement récursifs. Permet de finir la
-  construction du principe.
+(* collects all information of match branches stored in [l] *)
+let rec collect_cases l =
+ match l with
+  | [||] -> empty_funind_array
+  | arr -> 
+     let x = arr.(0) in
+     let resrec = collect_cases (Array.sub arr 1 (Array.length arr - 1)) in
+     { x with
+      princ= Array.append [|x.princ|] resrec.princ;
+      evarlist = x.evarlist@resrec.evarlist;
+      hypnum = x.hypnum@resrec.hypnum;
+     }
+
+let collect_pred l = 
+ let l1,l2,l3 = split3 l in
+ Array.of_list l1 , Array.of_list l2 , Array.of_list l3
+
+
+(* [build_pred n tarr] builds the right predicates for each element of [tarr]
+   (of type: [type array] of size [n]). Return the list of triples: 
+   (?i , 
+   fun (x1:t1) ... (xn:tn) => (?i x1...xn) ,
+   forall (x1:t1) ... (xn:tn), (?i x1...xn)),
+   where ti's are deduced from elements of tarr, which are of the form:
+   t1 -> t2 -> ... -> tn -> <nevermind>. *)
+let rec build_pred n tarr =
+ if n >= Array.length tarr (* iarr *) then []
+ else
+   let ftyp = Array.get tarr n in
+   let gl = mknewmeta() in
+   let gl_app = applFull gl ftyp in
+   let pis = prod_change_concl ftyp gl_app in
+   let gl_abstr = lam_change_concl ftyp gl_app in
+   (gl,gl_abstr,pis):: build_pred (n+1) tarr
 
-  \item[[(param,tparam)..]] est la liste des paramètres (les lambda au-dessus
-  du fix) du fixpoint si fixpoint il y a.
 
-  \end{itemize}
-*)
 let heq_prefix = "H_eq_"
 
 type kind_of_hyp = Var | Eq  (*| Rec*)
 
-let rec proofPrinc mi lst_vars lst_eqs lst_recs:
- constr * (constr*Term.types) list * (int*int*int) list 
- * constr array * types array * (constr*name*constr) list =
+(* the main function, build the principle by exploring the term and reproduce
+   the same structure. *)
+let rec proofPrinc mi: constr funind =
  match kind_of_term mi.mimick with
     (* Fixpoint: we reproduce the Fix, fonc becomes (1,nbofmutf) to point on
        the name of recursive calls *) 
   | Fix((iarr,i),(narr,tarr,carr)) -> 
-
-     (* We construct the right predicates for each mutual fixpt *)     
-     let rec build_pred n =
-      if n >= Array.length iarr then []
-      else
-        let ftyp = Array.get tarr n in
-        let gl = mknewmeta() in
-        let gl_app = applFull gl ftyp in
-        let pis = prod_change_concl ftyp gl_app in
-        let gl_abstr = lam_change_concl ftyp gl_app in
-        (gl,gl_abstr,pis):: build_pred (n+1) in
-
-     let evarl,predl,pisl = collect_pred (build_pred 0) in
-     let newabsconcl = Array.of_list predl in
-     let evararr = Array.of_list evarl in
-     let pisarr = Array.of_list pisl in
+     (* We construct the right predicates for each mutual fixpt *)
+     let evararr,newabsconcl,pisarr = collect_pred (build_pred 0 tarr) in
      let newenv = push_rec_types (narr,tarr,carr) mi.env in
-
-     let rec collect_fix n =
-      if n >= Array.length iarr then [],[],[],[]
-      else
-        let nme = Array.get narr n in
-        let c = Array.get carr n in
-        (* rappelle sur le sous-terme, on ajoute un niveau de
-           profondeur (lift) parce que Fix est un binder. *)
-        let newmi = {mi with concl=(pisarr.(n)); absconcl=newabsconcl;
-        mimick=c; fonc=(1,((Array.length iarr)));env=newenv;fix=true} in
-        let appel_rec,levar,lposeq,_,evarrarr,parms = 
-         proofPrinc newmi (lift1_lvars lst_vars) 
-          (lift1_leqs lst_eqs) (lift1L lst_recs) in
-        let lnme,lappel_rec,llevar,llposeq = collect_fix (n+1) in
-        (nme::lnme),(appel_rec::lappel_rec),(levar@llevar), (lposeq@llposeq) in
-
-     let lnme,lappel_rec,llevar,llposeq =collect_fix  0 in
-     let lnme' = List.map (fun nme -> newname_append nme "_ind") lnme in
-     let anme = Array.of_list lnme' in
-     let aappel_rec = Array.of_list lappel_rec in
-     (* llevar are put outside the fix, so one level of rel must be removed *)
-     mkFix((iarr,i),(anme, pisarr,aappel_rec))
-      , (pop1_levar llevar) , llposeq,evararr,pisarr,[]
-
+     let anme',aappel_rec,llevar,llposeq = 
+      collect_fix mi 0 iarr narr carr pisarr newabsconcl newenv in
+     let anme = Array.map (fun nme -> newname_append nme "_ind") anme' in
+     { 
+      princ = mkFix((iarr,i),(anme, pisarr,aappel_rec));
+      evarlist= pop1_levar llevar; (* llevar are put outside the fix, so we pop 1 *)
+      hypnum = llposeq;
+      mutfixmetas = evararr;
+      conclarray = pisarr;
+      params = []
+     }
   (* <pcase> Cases b of arrPt end.*)
-  | Case(cinfo, pcase, b, arrPt) -> 
-
+  | Case (cinfo, pcase, b, arrPt) -> 
      let prod_pcase,_ = decompose_lam pcase in
-     let nmeb,lastprod_pcase = List.hd prod_pcase in
-     let b'= apply_leqtrpl_t b lst_eqs in
+     let _nmeb,_ = List.hd prod_pcase in
+     let newb'= apply_leqtrpl_t b mi.lst_eqs in
      let type_of_b = Typing.type_of mi.env mi.sigma b in
-     let new_lst_recs = lst_recs @ hdMatchSub_cpl b mi.fonc in
-     (* Replace the calls to the function (recursive calls) by calls to the
-        corresponding constant:  *)
-     let d,f = mi.fonc in 
-     let res = ref b' in
-     let _ = for i = d to f do 
-       res := substitterm 0 (mkRel i) mi.nmefonc.(f-i) !res done in
-     let newb = !res in
-
-     (* [fold_proof t l n] rend le resultat de l'appel recursif sur les
-        elements de la liste l (correpsondant a arrPt), appele avec les bons
-        arguments: [concl] devient [(DUMMY1:t1;...;DUMMY:tn)concl'], ou [n]
-        est le nombre d'arguments du constructeur considéré (FIX: Hormis les
-        parametres!!), et [concl'] est concl ou l'on a réécrit [b] en ($c_n$
-        [rel1]...).*)
-
-     let rec fold_proof nth_construct eltPt' =  
-      (* mise a jour de concl pour l'interieur du case, concl'= concl[b <- C x3
-         x2 x1... ], sans quoi les annotations ne sont plus coherentes *)
-      let cstr_appl,nargs = nth_dep_constructor type_of_b nth_construct in
-      let concl'' = 
-       substitterm 0 (lift nargs b) cstr_appl (lift nargs mi.concl) in
-      let neweq = mkEq type_of_b newb (popn nargs cstr_appl) in
-      let concl_dummy = add_n_dummy_prod concl'' nargs in
-      let lsteqs_rew = apply_eq_leqtrpl lst_eqs neweq in
-      let new_lsteqs = 
-       (mkRel (0-nargs),(type_of_b,newb, popn nargs cstr_appl))::lsteqs_rew in
-      let a',a'' = decompose_lam_n nargs eltPt' in
-      let newa'' = 
-       if mi.doeqs 
-       then mkLambda (name_of_string heq_prefix,lift nargs neweq,lift 1 a'') 
-       else a'' in
-      let newmimick = lamn nargs a' newa'' in
-      let b',b'' = decompose_prod_n nargs concl_dummy in
-      let newb'' = 
-       if mi.doeqs 
-       then mkProd (name_of_string heq_prefix,lift nargs neweq,lift 1 b'')
-       else b'' in
-      let newconcl = prodn nargs b' newb'' in
-      let newmi = {mi with mimick=newmimick; concl=newconcl; fix=true} in
-      let a,b,c,d,e,p = proofPrinc newmi lst_vars new_lsteqs new_lst_recs in
-      a,b,c,d,e,p
-      in
-     
-     let arrPt_proof,levar,lposeq,evararr,absc,_ = 
-      collect_cases (Array.mapi fold_proof arrPt) in
-     let prod_pcase,concl_pcase = decompose_lam pcase in
-     let nme,typ = List.hd prod_pcase in
-     let suppllam_pcase = List.tl prod_pcase in
-     (* je remplace b par rel1 (apres avoir lifte un coup) dans la
-        future annotation du futur case: ensuite je mettrai un lambda devant *)
-     let typesofeqs' = eqs_of_beqs_named equality_hyp_string lst_eqs in
-     (*      let typesofeqs = prod_it_lift typesofeqs' mi.concl in *)
-     let typesofeqs = mi.concl in
-     let typeof_case'' = 
-      substitterm 0 (lift 1 b) (mkRel 1) (lift 1 typesofeqs) in
-     
-     (* C'est un peu compliqué ici: en cas de type inductif vraiment dépendant
-        le piquant du case [pcase] contient des lambdas supplémentaires en tête
-        je les ai dans la variable [suppllam_pcase]. Le problème est que la
-        conclusion du piquant doit faire référence à ces variables plutôt qu'à
-        celle de l'exterieur. Ce qui suit permet de changer les reference de
-        newpacse' pour pointer vers les lambda du piquant. On procède comme
-        suit: on repère les rels qui pointent à l'interieur du piquant dans la
-        fonction imitée, pour ça on parcourt le dernier lambda du piquant (qui
-        contient le type de l'argument du case), et on remplace les rels
-        correspondant dans la preuve construite. *)
-     
-     (* typ vient du piquant, type_of_b vient du typage de b.*)
-     
-     let rel_smap = 
-      if List.length suppllam_pcase=0 then Smap.empty else
-        build_rel_map (lift (List.length suppllam_pcase) type_of_b) typ in
-     let rel_map = smap_to_list rel_smap in
-     let rec substL l c =
-      match l with
-         [] -> c
-       | ((e,e') ::l') -> substL l' (substitterm 0 e (lift 1 e') c) in
-     let newpcase' = substL rel_map typeof_case'' in
-     let neweq = mkEq (lift (List.length suppllam_pcase + 1) type_of_b) 
-      (lift (List.length suppllam_pcase + 1) newb) (mkRel 1) in
-     let newpcase = 
-      if mi.doeqs then
-        mkProd (name_of_string "eg", neweq, lift 1 newpcase') else newpcase'
-     in
-     (* construction du dernier lambda du piquant. *)
-     let typeof_case' = mkLambda (newname_append nme "_ind" ,typ, newpcase) in
-     (* ajout des lambdas supplémentaires (type dépendant) du piquant. *)
-     let typeof_case = 
-      lamn (List.length suppllam_pcase) suppllam_pcase typeof_case' in 
-     let trm' = mkCase (cinfo,typeof_case,newb, arrPt_proof) in
-     let trm = 
-      if mi.doeqs then mkApp (trm',[|(mkRefl type_of_b newb)|]) 
-      else trm' in
-     trm,levar,lposeq,evararr,absc,[] (* fix parms here (fix inside case)*)
-      
+     (* Replace the recursive calls to the function by calls to the constant *)
+     let newb = replace_reccalls mi newb' in     
+     let cases = collect_cases (Array.mapi (fold_proof mi b type_of_b newb) arrPt) in
+     (* the match (case) annotation must be transformed, see [build_pcase] below *)
+     let newpcase = build_pcase mi pcase b type_of_b newb in
+     let trm' = mkCase (cinfo,newpcase,newb, cases.princ) in
+    { cases with
+     princ = if mi.doeqs then mkApp (trm',[|(mkRefl type_of_b newb)|]) else trm';
+     params = [] (* FIX: fix parms here (fixpt inside a match)*)
+    }
+
+
   | Lambda(nme, typ, cstr) ->
      let _, _, cconcl = destProd mi.concl in
      let d,f=mi.fonc in
      let newenv = push_rel (nme,None,typ) mi.env in
-     let newmi = {mi with concl=cconcl; mimick=cstr; env=newenv;
-      fonc=((if d > 0 then d+1 else 0),(if f > 0 then f+1 else 0))} in
      let newlst_var = (* if this lambda is a param, then don't add it here *)
-      if mi.fix then (mkRel 1,(nme,typ)) :: lift1_lvars lst_vars
-      else (*(mkRel 1,(nme,typ)) :: *) lift1_lvars lst_vars in
-     let rec_call,levar,lposeq,evararr,absc,parms =
-      proofPrinc newmi newlst_var (lift1_leqs lst_eqs) (lift1L lst_recs) in
+      if mi.fix then (mkRel 1,(nme,typ)) :: lift1_lvars mi.lst_vars
+      else (*(mkRel 1,(nme,typ)) :: *) lift1_lvars mi.lst_vars in
+     let newmi = {mi with concl=cconcl; mimick=cstr; env=newenv;
+      fonc = (if d > 0 then d+1 else 0) , (if f > 0 then f+1 else 0);
+      lst_vars = newlst_var ; lst_eqs = lift1_leqs mi.lst_eqs;
+      lst_recs = lift1L mi.lst_recs} in
+     let resrec = proofPrinc newmi in
      (* are we inside a fixpoint or a case? then this is a normal lambda *)
-     if mi.fix then mkLambda (nme,typ,rec_call) , levar, lposeq,evararr,absc,[]
+     if mi.fix 
+     then { resrec with princ = mkLambda (nme,typ,resrec.princ) ; params = [] }
      else (* otherwise this is a parameter *)
        let metav = mknewmeta() in
        let substmeta t = popn 1 (substitterm 0 (mkRel 1) metav t) in
-       let newrec_call = substmeta rec_call in
-       let newlevar = List.map (fun (ev,tev) -> ev, substmeta tev) levar in
-       let newabsc = Array.map substmeta absc in
-       newrec_call,newlevar,lposeq,evararr,newabsc,((metav,nme, typ)::parms)
+       { resrec with
+        princ = substmeta resrec.princ;
+        evarlist = List.map (fun (ev,tev) -> ev, substmeta tev) resrec.evarlist;
+        conclarray = Array.map substmeta resrec.conclarray;
+        params = (metav,nme,typ) :: resrec.params
+       }
+
 
   | LetIn(nme,cstr1, typ, cstr) ->
      failwith ("I don't deal with let ins yet. "^
 				 "Please expand them before applying this function.")
 
   | u -> 
-     let varrels = List.rev (List.map fst lst_vars) in
-     let varnames = List.map snd lst_vars in
+     let varrels = List.rev (List.map fst mi.lst_vars) in
+     let varnames = List.map snd mi.lst_vars in
      let nb_vars = List.length varnames in
-     let nb_eqs = List.length lst_eqs in
-     let eqrels = List.map fst lst_eqs in
+     let nb_eqs = List.length mi.lst_eqs in
+     let _eqrels = List.map fst mi.lst_eqs in
      (* [terms_recs]: appel rec du fixpoint, On concatène les appels recs
         trouvés dans les let in et les Cases avec ceux trouves dans u (ie
         mi.mimick). *)
      (* TODO: il faudra gérer plusieurs pt fixes imbriqués ? *)
-     let terms_recs = lst_recs @ hdMatchSub_cpl mi.mimick mi.fonc in
-
+     let terms_recs = mi.lst_recs @ hdMatchSub_cpl mi.mimick mi.fonc in
      (*c construction du terme: application successive des variables, des
        egalites et des appels rec, a la variable existentielle correspondant a
        l'hypothese de recurrence en cours. *)
@@ -527,18 +438,110 @@ let rec proofPrinc mi lst_vars lst_eqs lst_recs:
      let appsrecpred = exchange_reli_arrayi_L mi.absconcl mi.fonc terms_recs in
      let typeofhole''  = prod_it_anonym_lift mi.concl appsrecpred in
      let typeofhole    = prodn nb_vars varnames typeofhole'' in
-		   
      (* Un bug de refine m'oblige à mettre ici un H (meta variable à ce point,
         mais remplacé par H avant le refine) au lieu d'un '?', je mettrai les
         '?'  à la fin comme ça [(([H1,H2,H3...] ...) ? ? ?)] *)
-
      let newmeta = mknewmeta() in
      let concl_with_var = applistc newmeta varrels in
      let conclrecs = applistc concl_with_var terms_recs in
-     conclrecs,[newmeta,typeofhole], [nb_vars,(List.length terms_recs)
-      ,nb_eqs],[||],mi.absconcl,[]
-
+     { empty_funind_constr with
+      princ = conclrecs;
+      evarlist = [ newmeta , typeofhole ];
+      hypnum = [ nb_vars , List.length terms_recs , nb_eqs ];
+      conclarray = mi.absconcl;
+     }
 
+     
+(* C'est un peu compliqué ici: en cas de type inductif vraiment dépendant
+   l'annotation de type du case [pcase] contient des lambdas supplémentaires
+   en tête. Je les récupère dans la variable [suppllam_pcase]. Le problème est
+   que la conclusion de l'annotation du nouveauacse doit faire référence à ces
+   variables plutôt qu'à celle de l'exterieur. Ce qui suit permet de changer
+   les reference de newpcase' pour pointer vers les lambda du piquant. On
+   procède comme suit: on repère les rels qui pointent à l'interieur de
+   l'annotation dans la fonction initiale et on les relie à celle du type
+   voulu pour le case, pour ça ([build_rel_map]) on parcourt en même temps le
+   dernier lambda du piquant ([typ]) (qui contient le type de l'argument du
+   case) et le type attendu pour le case ([type_of_b]) et on construit un
+   map. Ensuite on remplace les rels correspondant dans la preuve construite
+   en suivant le map. *)
+     
+and build_pcase mi pcase b type_of_b newb =
+     let prod_pcase,_ = decompose_lam pcase in
+     let nme,typ = List.hd prod_pcase in
+     (* je remplace b par rel1 (apres avoir lifte un coup) dans la future
+        annotation du futur case: ensuite je mettrai un lambda devant *)
+     let typeof_case'' = substitterm 0 (lift 1 b) (mkRel 1) (lift 1 mi.concl) in
+     let suppllam_pcase = List.tl prod_pcase in
+     let suppllam_pcasel = List.length suppllam_pcase  in
+     let rel_smap = 
+      if suppllam_pcasel=0 then Smap.empty else (* FIX: is this test necessary ? *)
+        build_rel_map (lift suppllam_pcasel type_of_b) typ in
+     let newpcase''' =  
+      Smap.fold (fun e e' acc -> substitterm 0 e (lift 1 e') acc)
+       rel_smap typeof_case'' in
+     let neweq = mkEq (lift (suppllam_pcasel + 1) type_of_b) 
+      (lift (suppllam_pcasel + 1) newb) (mkRel 1) in
+     let newpcase'' = 
+      if mi.doeqs 
+      then mkProd (name_of_string "eg", neweq, lift 1 newpcase''') 
+      else newpcase''' in
+     (* construction du dernier lambda du piquant. *)
+     let newpcase' = mkLambda (newname_append nme "_ind" ,typ, newpcase'') in
+     (* ajout des lambdas supplémentaires (type dépendant) du piquant. *)
+     lamn suppllam_pcasel suppllam_pcase newpcase'
+
+
+(* [fold_proof mi b typeofb newb l n] rend le resultat de l'appel recursif sur
+   cstr (correpsondant au ième elt de [arrPt] ci-dessus et donc au ième
+   constructeur de [typeofb]), appele avec les bons arguments: [mi.concl]
+   devient [(DUMMY1:t1;...;DUMMY:tn)concl'], ou [n] est le nombre d'arguments
+   du constructeur considéré, et [concl'] est [mi.concl] ou l'on a réécrit [b]
+   en ($c_n$ [rel1]...). *)
+and fold_proof mi b type_of_b newb i cstr = 
+ let new_lst_recs = mi.lst_recs @ hdMatchSub_cpl b mi.fonc in
+ (* mise a jour de concl pour l'interieur du case, concl'= concl[b <- C x3
+    x2 x1... ], sans quoi les annotations ne sont plus coherentes *)
+ let cstr_appl,nargs = nth_dep_constructor type_of_b i in
+ let concl'' = 
+  substitterm 0 (lift nargs b) cstr_appl (lift nargs mi.concl) in
+ let neweq = mkEq type_of_b newb (popn nargs cstr_appl) in
+ let concl_dummy = add_n_dummy_prod concl'' nargs in
+ let lsteqs_rew = apply_eq_leqtrpl mi.lst_eqs neweq in
+ let new_lsteqs = (mkRel (-nargs),(type_of_b,newb, popn nargs cstr_appl))::lsteqs_rew in
+ let a',a'' = decompose_lam_n nargs cstr in
+ let newa'' = 
+  if mi.doeqs 
+  then mkLambda (name_of_string heq_prefix,lift nargs neweq,lift 1 a'') 
+  else a'' in
+ let newmimick = lamn nargs a' newa'' in
+ let b',b'' = decompose_prod_n nargs concl_dummy in
+ let newb'' = 
+  if mi.doeqs 
+  then mkProd (name_of_string heq_prefix,lift nargs neweq,lift 1 b'')
+  else b'' in
+ let newconcl = prodn nargs b' newb'' in
+ let newmi = {mi with mimick=newmimick; concl=newconcl; fix=true; 
+  lst_eqs= new_lsteqs; lst_recs = new_lst_recs} in
+ proofPrinc newmi 
+
+
+and collect_fix mi n iarr narr carr pisarr newabsconcl newenv =
+ if n >= Array.length iarr then [||],[||],[],[]
+ else
+   let nme = Array.get narr n in
+   let c = Array.get carr n in
+   (* rappelle sur le sous-terme, on ajoute un niveau de
+      profondeur (lift) parce que Fix est un binder. *)
+   let newmi = {mi with concl=(pisarr.(n)); absconcl=newabsconcl;
+    mimick=c; fonc=(1,((Array.length iarr)));env=newenv;fix=true;
+    lst_vars=lift1_lvars mi.lst_vars; lst_eqs=lift1_leqs mi.lst_eqs; 
+    lst_recs= lift1L mi.lst_recs;} in
+   let resrec = proofPrinc newmi  in
+   let lnme,lappel_rec,llevar,llposeq = 
+    collect_fix mi (n+1) iarr narr carr pisarr newabsconcl newenv in
+   Array.append [|nme|] lnme , Array.append [|resrec.princ|] lappel_rec
+    , (resrec.evarlist@llevar) , (resrec.hypnum@llposeq)
 
 let mkevarmap_aux ex = let x,y = ex in	(mkevarmap_from_listex x),y
 
@@ -568,9 +571,10 @@ let interp_fonc_tacarg fonctac gl =
 
 let invfun_proof fonc def_fonc gl_abstr pis env sigma =
  let mi = {concl=pis; absconcl=gl_abstr; mimick=def_fonc; env=env;
- sigma=sigma; nmefonc=fonc; fonc=(0,0); doeqs=true; fix=false} in
- let princ_proof,levar,lposeq,evararr,absc,parms = proofPrinc mi [] [] [] in
- princ_proof,levar,lposeq,evararr,absc,parms
+ sigma=sigma; nmefonc=fonc; fonc=(0,0); doeqs=true; fix=false ; 
+ lst_vars = []; lst_eqs = []; lst_recs = []} in
+ proofPrinc mi
+
 (* Do intros [i] times, then do rewrite on all introduced hyps which are called
    like [heq_prefix], FIX: have another filter than the name. *)
 let rec iterintro i = 
@@ -587,7 +591,7 @@ let rec iterintro i =
         let sub = 
          try String.sub hypname 0 (String.length heq_prefix)
          with _ -> "" (* different than [heq_prefix] *) in
-        if sub=heq_prefix then rewriteLR hyp else tclFAIL 0 "Cannot rewrite")
+        if sub=heq_prefix then rewriteLR hyp else tclFAIL 0 (str "Cannot rewrite"))
       )) gl)
 
 
@@ -647,7 +651,7 @@ let rec applistc_iota cstr lcstr env sigma =
   | [] -> cstr,[]
   | arg::lcstr' -> 
      let arghd = 
-      if isApp arg then let x,_ = destApplication arg in x else arg in
+      if isApp arg then let x,_ = destApp arg in x else arg in
      if isConstruct arghd (* of the form [(C ...)]*)
      then 
         applistc_iota (Tacred.nf env sigma (nf_beta (applistc cstr [arg])))
@@ -686,39 +690,38 @@ let invfun c l dorew gl =
  let pis = add_pis (pf_concl gl) gl listargs' in
  (* princ_proof builds the principle *)
  let _ = resetmeta() in
- let princ_proof,levar, lposeq,evararr,_,parms = 
-  invfun_proof [|fonc|] def_fonc [||] pis (pf_env gl) (project gl) in
+ let pr = invfun_proof [|fonc|] def_fonc [||] pis (pf_env gl) (project gl) in
  (* Generalize the goal. [[x1:T1][x2:T2]... g[arg1 <- x1 ...]]. *)
  let gl_abstr' = add_lambdas (pf_concl gl) gl listargs' in
  (* apply parameters immediately *)
  let gl_abstr = 
-  applistc gl_abstr' (List.map (fun (x,y,z) -> x) (List.rev parms)) in
+  applistc gl_abstr' (List.map (fun (x,y,z) -> x) (List.rev pr.params)) in
  (* we apply args of the fix now, the parameters will be applied later *)
  let princ_proof_applied_args = 
-  applistc princ_proof (listsuf (List.length parms) listargs') in
+  applistc pr.princ (listsuf (List.length pr.params) listargs') in
  (* parameters are still there so patternify must not take them -> lift *)
  let princ_proof_applied_lift = 
-  lift (List.length levar) princ_proof_applied_args in
- let princ_applied_hyps'' = patternify (List.rev levar)
+  lift (List.length pr.evarlist) princ_proof_applied_args in
+ let princ_applied_hyps'' = patternify (List.rev pr.evarlist)
   princ_proof_applied_lift (Name (id_of_string "Hyp"))  in
  (* if there was a fix, we will not add "Q" as in funscheme, so we make a pop,
     TODO: find were we made the lift in proofPrinc instead and supress it here,
     and add lift in funscheme. *)
  let princ_applied_hyps' = 
-  if Array.length evararr > 0 then popn 1 princ_applied_hyps''
+  if Array.length pr.mutfixmetas > 0 then popn 1 princ_applied_hyps''
   else princ_applied_hyps'' in 
  (* if there is was fix, we have to replace the meta representing the
     predicate of the goal by the abstracted goal itself. *)
  let princ_applied_hyps = 
-  if Array.length evararr > 0 then (* mutual Fixpoint not treated in the tactic *) 
-    (substit_red 0 (evararr.(0)) gl_abstr princ_applied_hyps')
+  if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*) 
+    (substit_red 0 (pr.mutfixmetas.(0)) gl_abstr princ_applied_hyps')
   else princ_applied_hyps' (* No Fixpoint *) in
  let _ = prNamedConstr "princ_applied_hyps" princ_applied_hyps in
  (* Same thing inside levar *)
  let newlevar' = 
-  if Array.length evararr > 0 then (* mutual Fixpoint not treated in the tactic *) 
-    List.map (fun (x,y) -> x,substit_red 0 (evararr.(0)) gl_abstr y) levar 
-  else levar
+  if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*) 
+    List.map (fun (x,y) -> x,substit_red 0 (pr.mutfixmetas.(0)) gl_abstr y) pr.evarlist 
+  else pr.evarlist
  in
  (* replace params metavar by real args *)
  let rec replace_parms lparms largs t = 
@@ -726,19 +729,19 @@ let invfun c l dorew gl =
      [], _ -> t
    | ((p,_,_)::lp), (a::la) -> let t'= substitterm 0 p a t in replace_parms lp la t'
    | _, _ -> error "problem with number of args." in
- let princ_proof_applied = replace_parms parms listargs' princ_applied_hyps in
+ let princ_proof_applied = replace_parms pr.params listargs' princ_applied_hyps in
  let _ = prNamedLConstr "levar:" (List.map fst newlevar') in
  let _ = prNamedLConstr "levar types:" (List.map snd newlevar') in
  let _ = prNamedConstr "princ_proof_applied" princ_proof_applied in
  (* replace also in levar *)
  let newlevar = 
-  List.rev (List.map (fun (x,y) -> x, replace_parms parms listargs' y) newlevar') in
+  List.rev (List.map (fun (x,y) -> x, replace_parms pr.params listargs' y) newlevar') in
 (*
  (* replace params metavar by abstracted variables *)
-  let princ_proof_params = npatternify (List.rev parms) princ_applied_hyps in
+  let princ_proof_params = npatternify (List.rev pr.params) princ_applied_hyps in
  (* we apply now the real parameters *)
  let princ_proof_applied = 
-  applistc princ_proof_params (listpref (List.length parms) listargs') in
+  applistc princ_proof_params (listpref (List.length pr.params) listargs') in
 *)
  let princ_applied_evars = apply_levars princ_proof_applied newlevar in
  let open_princ_proof_applied = princ_applied_evars in
@@ -746,11 +749,11 @@ let invfun c l dorew gl =
  let _ = prNamedLConstr "evars" (List.map snd (fst princ_applied_evars)) in
  let listargs_ids = List.map destVar (List.filter isVar listargs') in
  (* debug: impression du but*)
-(*  let lgl = Evd.to_list (sig_sig gl) in *)
-(*  let _ = prNamedLConstr "\ngl= " (List.map (fun x -> (snd x).evar_concl) lgl) in *)
-(*  let _ = prstr "fin gl \n\n" in *)
+ let lgl = Evd.to_list (sig_sig gl) in
+ let _ = prNamedLConstr "\ngl= " (List.map (fun x -> (snd x).evar_concl) lgl) in
+ let _ = prstr "fin gl \n\n" in
  invfun_basic (mkevarmap_aux open_princ_proof_applied) listargs_ids 
-  gl dorew lposeq
+  gl dorew pr.hypnum
 
 (* function must be a constant, all arguments must be given. *)
 let invfun_verif c l dorew gl =
@@ -763,11 +766,6 @@ let invfun_verif c l dorew gl =
    else error "wrong number of arguments for the function"
 
 
-TACTIC EXTEND FunctionalInduction
-  [ "Functional" "Induction" constr(c)  ne_constr_list(l) ] 
-     -> [ invfun_verif c l true ]
-END
-
 
 
 (* Construction of the functional scheme. *)
@@ -780,13 +778,14 @@ let buildFunscheme fonc mutflist =
  let pis = prod_change_concl ftyp gl_app in
  (* Here we call the function invfun_proof, that effectively 
     builds the scheme *)
- let princ_proof,levar,_,evararr,absc,parms = 
-  invfun_proof mutflist def_fonc [||] pis (Global.env()) Evd.empty in
+(*  let princ_proof,levar,_,evararr,absc,parms =  *)
+ let _ = prstr "Recherche du principe... lancement de invfun_proof\n" in
+ let pr = invfun_proof mutflist def_fonc [||] pis (Global.env()) Evd.empty in
  (* parameters are still there (unboud rel), and patternify must not take them
   -> lift*)
- let princ_proof_lift = lift (List.length levar) princ_proof in
+ let princ_proof_lift = lift (List.length pr.evarlist) pr.princ in
  let princ_proof_hyps = 
-  patternify (List.rev levar) princ_proof_lift (Name (id_of_string "Hyp"))  in
+  patternify (List.rev pr.evarlist) princ_proof_lift (Name (id_of_string "Hyp"))  in
  let rec princ_replace_metas ev abs i t = 
   if i>= Array.length ev then t
   else (* fix? *)
@@ -802,49 +801,61 @@ let buildFunscheme fonc mutflist =
     mkLambda (Name (id_of_name nam) , typ, 
     substitterm 0 ev (mkRel 1) (lift 0 acc)))
    t (List.rev params) in
- if Array.length evararr = 0 (* Is there a Fixpoint? *)
+ if Array.length pr.mutfixmetas = 0 (* Is there a Fixpoint? *)
 	then (* No Fixpoint *)
-   princ_replace_params parms (mkLambda ((Name (id_of_string "Q")), 
+   princ_replace_params pr.params (mkLambda ((Name (id_of_string "Q")), 
 		 prod_change_concl ftyp mkthesort,
    (substitterm 0 gl (mkRel 1) princ_proof_hyps)))
 	else (* there is a fix -> add parameters + replace metas *)
-   let princ_rpl = princ_replace_metas evararr absc 0 princ_proof_hyps in
-   princ_replace_params parms princ_rpl
+   let princ_rpl = 
+    princ_replace_metas pr.mutfixmetas pr.conclarray 0 princ_proof_hyps in
+   princ_replace_params pr.params princ_rpl
 
 
     
 (* Declaration of the functional scheme. *)
 let declareFunScheme f fname mutflist =
+ let _ = prstr "Recherche du perincipe...\n" in
+ let id_to_cstr id = 
+  try constr_of_id (Global.env()) id 
+  with
+     Not_found -> error (string_of_id id ^ " not found in the environment") in
  let flist = if mutflist=[] then [f] else mutflist in
- let fcstrlist = Array.of_list (List.map constr_of flist) in
- let scheme = buildFunscheme (constr_of f) fcstrlist in
+ let fcstrlist = Array.of_list (List.map id_to_cstr flist) in
+ let idf = id_to_cstr f in
+ let scheme = buildFunscheme idf fcstrlist in
   let _ = prstr "Principe:" in
   let _ = prconstr scheme in
  let ce = { 
   const_entry_body = scheme;
   const_entry_type = None;
-  const_entry_opaque = false } in
- let _= ignore (declare_constant fname (DefinitionEntry ce,IsDefinition)) in
+  const_entry_opaque = false;
+  const_entry_boxed = true } in
+ let _= ignore (declare_constant fname (DefinitionEntry ce,IsDefinition Scheme)) in
  ()
 
 
 
+TACTIC EXTEND functional_induction
+  [ "old" "functional" "induction" constr(c)  ne_constr_list(l) ] 
+     -> [ invfun_verif c l true ]
+END
+
 VERNAC COMMAND EXTEND FunctionalScheme
- [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" 
-    constr(c) "with" ne_constr_list(l) ]
+ [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" 
+    ident(c) "with" ne_ident_list(l) ] 
   -> [ declareFunScheme c na l ]
-| [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" constr(c) ]
+| [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident (c) ]
   -> [ declareFunScheme c na [] ]
 END
 
- 
+
 
 
 
 (* 
 *** Local Variables: ***
 *** compile-command: "make -C ../.. contrib/funind/tacinv.cmo" ***
-*** tab-width: 1 ***
 *** tuareg-default-indent:1 ***
 *** tuareg-begin-indent:1 ***
 *** tuareg-let-indent:1 ***
diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml
index a125b9a7..ce775e0b 100644
--- a/contrib/funind/tacinvutils.ml
+++ b/contrib/funind/tacinvutils.ml
@@ -21,9 +21,9 @@ open Reductionops
 (*s printing of constr -- debugging *)
 
 (* comment this line to see debug msgs *)
-let msg x = () ;; let prterm c = str ""
+let msg x = () ;; let pr_lconstr c = str ""
   (* uncomment this to see debugging *)
-let prconstr c =  msg (str"  " ++ prterm c ++ str"\n")
+let prconstr c =  msg (str"  " ++ pr_lconstr c ++ str"\n")
 let prlistconstr lc = List.iter prconstr lc
 let prstr s = msg(str s)
 
@@ -31,7 +31,7 @@ let prchr () = msg (str" (ret) \n")
 let prNamedConstr s c = 
   begin
     msg(str "");
-    msg(str(s^"==>\n ") ++ prterm c ++ str "\n<==\n");
+    msg(str(s^"==>\n ") ++ pr_lconstr c ++ str "\n<==\n");
     msg(str "");
   end
 
@@ -72,10 +72,11 @@ let  rec mkevarmap_from_listex lex =
 		  let _ = prstr ("evar n. " ^ string_of_int ex ^ " ") in
 		  let _ = prstr "OF TYPE: " in
 		  let _ = prconstr typ in*)
-		  let info ={
+		  let info = {
 			 evar_concl = typ;
-			 evar_hyps = empty_named_context;
-			 evar_body = Evar_empty} in
+			 evar_hyps = empty_named_context_val;
+			 evar_body = Evar_empty;
+		         evar_extra = None} in
 		  Evd.add (mkevarmap_from_listex lex') ex info
 
 let mkEq typ c1 c2 = 
@@ -126,7 +127,7 @@ let apply_leqtrpl_t t leq =
 
 
 let apply_refl_term eq t =
-  let _,arr = destApplication eq in
+  let _,arr = destApp eq in
   let reli= (Array.get arr 1) in
   let by_t= (Array.get arr 2) in
   substitterm 0 reli by_t t
@@ -144,7 +145,7 @@ let apply_eq_leqtrpl leq eq =
 let constr_head_match u t=
   if isApp u 
   then 
-	 let uhd,args= destApplication u in
+	 let uhd,args= destApp u in
     uhd=t
   else false
 
@@ -187,7 +188,7 @@ let rec buildrefl_from_eqs eqs =
   match eqs with 
     | []  ->  []
     | cstr::eqs' -> 
-        let eq,args = destApplication cstr in
+        let eq,args = destApp cstr in
         (mkRefl (Array.get args 0) (Array.get args 2))
 	:: (buildrefl_from_eqs eqs')
 
@@ -237,7 +238,7 @@ let rec substit_red prof t by_t in_u =
 (* [exchange_reli_arrayi t=(reli x y ...) tarr (d,f)] exchange each
 	reli by tarr.(f-i). *) 
 let exchange_reli_arrayi tarr (d,f) t =
-  let hd,args= destApplication t in 
+  let hd,args= destApp t in 
   let i = destRel hd in
   let res = whd_beta (mkApp (tarr.(f-i) ,args)) in
   res
@@ -269,7 +270,7 @@ let def_of_const t =
 (* nom d'une constante. Must be a constante. x*)
 let name_of_const t =
     match (kind_of_term t) with
-        Const cst -> Names.string_of_label (Names.label cst)
+        Const cst -> Names.string_of_label (Names.con_label cst)
 		|_ -> assert false
  ;;
 
diff --git a/contrib/funind/tacinvutils.mli b/contrib/funind/tacinvutils.mli
index 2fc37b2c..64b21213 100644
--- a/contrib/funind/tacinvutils.mli
+++ b/contrib/funind/tacinvutils.mli
@@ -71,9 +71,10 @@ val expand_letins: constr -> constr
 
 val def_of_const: constr -> constr
 val name_of_const: constr -> string
+
 (*i
- Local Variables:
- compile-command: "make -k tacinvutils.cmi"
- End:
+ *** Local Variables: ***
+ *** compile-command: "make -C ../.. contrib/funind/tacinvutils.cmi" ***
+ *** End: ***
 i*)
 
diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli
index 61d0d5a3..ef1d095e 100644
--- a/contrib/interface/ascent.mli
+++ b/contrib/interface/ascent.mli
@@ -21,7 +21,7 @@ and ct_BINDING =
     CT_binding of ct_ID_OR_INT * ct_FORMULA
 and ct_BINDING_LIST =
     CT_binding_list of ct_BINDING list
-and ct_BOOL =
+and t_BOOL =
     CT_false
   | CT_true
 and ct_CASE =
@@ -46,7 +46,7 @@ and ct_COMMAND =
   | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL
   | CT_abort of ct_ID_OPT_OR_ALL
   | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST
-  | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_BINDING_LIST
+  | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA_OPT
   | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID
   | CT_addpath of ct_STRING * ct_ID_OPT
   | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST
@@ -119,11 +119,13 @@ and ct_COMMAND =
   | CT_print_about of ct_ID
   | CT_print_all
   | CT_print_classes
+  | CT_print_ltac of ct_ID
   | CT_print_coercions
   | CT_print_grammar of ct_GRAMMAR
   | CT_print_graph
   | CT_print_hint of ct_ID_OPT
   | CT_print_hintdb of ct_ID_OR_STAR
+  | CT_print_rewrite_hintdb of ct_ID
   | CT_print_id of ct_ID
   | CT_print_implicit of ct_ID
   | CT_print_loadpath
@@ -135,6 +137,7 @@ and ct_COMMAND =
   | CT_print_opaqueid of ct_ID
   | CT_print_path of ct_ID * ct_ID
   | CT_print_proof of ct_ID
+  | CT_print_setoids
   | CT_print_scope of ct_ID
   | CT_print_scopes
   | CT_print_section of ct_ID
@@ -465,8 +468,8 @@ and ct_MODULE_EXPR =
   | CT_module_app of ct_MODULE_EXPR * ct_MODULE_EXPR
 and ct_MODULE_TYPE =
     CT_coerce_ID_to_MODULE_TYPE of ct_ID
-  | CT_module_type_with_def of ct_MODULE_TYPE * ct_ID * ct_FORMULA
-  | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID * ct_ID
+  | CT_module_type_with_def of ct_MODULE_TYPE * ct_ID_LIST * ct_FORMULA
+  | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID_LIST * ct_ID
 and ct_MODULE_TYPE_CHECK =
     CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK of ct_MODULE_TYPE_OPT
   | CT_only_check of ct_MODULE_TYPE
@@ -530,6 +533,7 @@ and ct_RED_COM =
   | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET
   | CT_pattern of ct_PATTERN_NE_LIST
   | CT_red
+  | CT_cbvvm
   | CT_simpl of ct_PATTERN_OPT
   | CT_unfold of ct_UNFOLD_NE_LIST
 and ct_RETURN_INFO =
@@ -637,6 +641,8 @@ and ct_TACTIC_COM =
   | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING
   | CT_elim_type of ct_FORMULA
   | CT_exact of ct_FORMULA
+  | CT_exact_no_check of ct_FORMULA
+  | CT_vm_cast_no_check of ct_FORMULA
   | CT_exists of ct_SPEC_LIST
   | CT_fail of ct_ID_OR_INT * ct_STRING_OPT
   | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list
@@ -665,8 +671,8 @@ and ct_TACTIC_COM =
   | CT_match_context_reverse of ct_CONTEXT_RULE * ct_CONTEXT_RULE list
   | CT_match_tac of ct_TACTIC_COM * ct_MATCH_TAC_RULES
   | CT_move_after of ct_ID * ct_ID
-  | CT_new_destruct of ct_FORMULA_OR_INT * ct_USING * ct_INTRO_PATT_OPT
-  | CT_new_induction of ct_FORMULA_OR_INT * ct_USING * ct_INTRO_PATT_OPT
+  | CT_new_destruct of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT
+  | CT_new_induction of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT
   | CT_omega
   | CT_orelse of ct_TACTIC_COM * ct_TACTIC_COM
   | CT_parallel of ct_TACTIC_COM * ct_TACTIC_COM list
@@ -679,9 +685,9 @@ and ct_TACTIC_COM =
   | CT_reflexivity
   | CT_rename of ct_ID * ct_ID
   | CT_repeat of ct_TACTIC_COM
-  | CT_replace_with of ct_FORMULA * ct_FORMULA
-  | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT
-  | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT
+  | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_CLAUSE * ct_TACTIC_OPT
+  | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE
+  | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE
   | CT_right of ct_SPEC_LIST
   | CT_ring of ct_FORMULA_LIST
   | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST
diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml
index d5236a7a..dc27cf98 100755..100644
--- a/contrib/interface/blast.ml
+++ b/contrib/interface/blast.ml
@@ -1,13 +1,11 @@
 (* Une tactique qui tente de démontrer toute seule le but courant,
    interruptible par pcoq (si dans le fichier C:\WINDOWS\free il y a un A)
 *)
-open Ctast;;
 open Termops;;
 open Nameops;;
 open Auto;;
 open Clenv;;
 open Command;;
-open Ctast;;
 open Declarations;;
 open Declare;;
 open Eauto;;
@@ -38,7 +36,6 @@ open Typing;;
 open Util;;
 open Vernacentries;;
 open Vernacinterp;;
-open Evar_refiner;;
 
 
 let parse_com   = Pcoq.parse_string Pcoq.Constr.constr;;
@@ -89,13 +86,13 @@ let rec def_const_in_term_rec vl x =
    | Sort(c) -> c
    | Ind(ind) ->
           let (mib, mip) = Global.lookup_inductive ind in
-          mip.mind_sort
+	  new_sort_in_family (inductive_sort_family mip)
    | Construct(c) ->
           def_const_in_term_rec vl (mkInd (inductive_of_constructor c))
    | Case(_,x,t,a) 
         -> def_const_in_term_rec vl x
-   | Cast(x,t)-> def_const_in_term_rec vl t
-   | Const(c)  -> def_const_in_term_rec vl (lookup_constant c vl).const_type
+   | Cast(x,_,t)-> def_const_in_term_rec vl t
+   | Const(c)  -> def_const_in_term_rec vl (Typeops.type_of_constant vl c)
    | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x)
 ;;
 let def_const_in_term_ x =
@@ -113,7 +110,7 @@ let rec print_info_script sigma osign pf =
   match pf.ref with
     | None -> (mt ())
     | Some(r,spfl) ->
-        pr_rule r ++
+        Tactic_printer.pr_rule r ++
            match spfl with
              | [] ->
 		   (str " " ++ fnl())
@@ -152,8 +149,7 @@ let pp_string x =
 (***************************************************************************)
 
 let unify_e_resolve  (c,clenv) gls = 
-  let (wc,kONT) = startWalk gls in
-  let clenv' = connect_clenv wc clenv in
+  let clenv' = connect_clenv gls clenv in
   let _ = clenv_unique_resolver false clenv' gls in
   vernac_e_resolve_constr c gls
 
@@ -179,7 +175,7 @@ and e_my_find_search db_list local_db hdc concl =
       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) -> 
+    fun ({pri=b; pat = p; code=t} as _patac) -> 
       (b, 
        let tac =
 	 match t with
@@ -189,7 +185,7 @@ and e_my_find_search db_list local_db hdc concl =
 	   | 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
+	   | Unfold_nth c -> unfold_in_concl [[],c]
 	   | Extern tacast -> Auto.conclPattern concl 
 	       (out_some p) tacast
        in 
@@ -341,7 +337,7 @@ let e_breadth_search debug n db_list local_db gl =
   with Not_found -> error "EAuto: breadth first search failed"
 
 let e_search_auto debug (n,p) db_list gl = 
-  let local_db = make_local_hint_db gl in 
+  let local_db = make_local_hint_db [] gl in 
   if n = 0 then 
     e_depth_search debug p db_list local_db gl
   else 
@@ -351,17 +347,17 @@ let eauto debug np dbnames =
   let db_list =
     List.map
       (fun x -> 
-	 try Stringmap.find x !searchtable
+	 try searchtable_map x
 	 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 = current_db_names () 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
+  let db_list = List.map searchtable_map dbnames in
+  let _local_db = make_local_hint_db [] gl in
   tclTRY (e_search_auto debug n db_list) gl
 
 let my_full_eauto n gl = full_eauto false (n,0) gl
@@ -369,8 +365,6 @@ let my_full_eauto n gl = full_eauto false (n,0) gl
 (**********************************************************************
    copié de tactics/auto.ml on a juste modifié search_gen
 *)
-let searchtable_map name = 
-  Stringmap.find name !searchtable
 
 (* 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
@@ -397,7 +391,7 @@ and my_find_search db_list local_db hdc concl =
       	(local_db::db_list)
   in
   List.map 
-    (fun ({pri=b; pat=p; code=t} as patac) -> 
+    (fun ({pri=b; pat=p; code=t} as _patac) -> 
        (b,
 	match t with
 	  | Res_pf (term,cl)  -> unify_resolve (term,cl)
@@ -407,7 +401,7 @@ and my_find_search db_list local_db hdc concl =
 	      tclTHEN 
 		(unify_resolve (term,cl)) 
 		(trivial_fail_db db_list local_db)
-	  | Unfold_nth c -> unfold_constr c
+	  | Unfold_nth c -> unfold_in_concl [[],c]
 	  | Extern tacast -> 
 	      conclPattern concl (out_some p) tacast))
     tacl
@@ -476,7 +470,7 @@ let rec search_gen decomp n db_list local_db extra_sign goal =
 	   try 
 	     [make_apply_entry (pf_env g') (project g')
 		(true,false) 
-		hid (mkVar hid,body_of_type htyp)]
+		(mkVar hid,body_of_type htyp)]
 	   with Failure _ -> [] 
 	 in
          (free_try
@@ -499,11 +493,11 @@ let search = search_gen 0
 let default_search_depth = ref 5
 			     
 let full_auto n gl = 
-  let dbnames = stringmap_dom !searchtable in
+  let dbnames = current_db_names () in
   let dbnames = list_subtract dbnames ["v62"] in
-  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+  let db_list = List.map searchtable_map dbnames in
   let hyps = pf_hyps gl in
-  tclTRY (search n db_list (make_local_hint_db gl) hyps) gl
+  tclTRY (search n db_list (make_local_hint_db [] gl) hyps) gl
   
 let default_full_auto gl = full_auto !default_search_depth gl
 (************************************************************************)
@@ -568,7 +562,7 @@ let blast gls =
       open_subgoals = 1;
       goal = g;
       ref = None } in
-     try (let (sgl,v) as res = !blast_tactic gls in
+     try (let (sgl,v) as _res = !blast_tactic gls in
 	  let {it=lg} = sgl in
           if lg = [] 
           then (let pf = v (List.map leaf (sig_it sgl)) in
@@ -590,7 +584,7 @@ let blast gls =
 ;;
 
 let blast_tac display_function = function 
-          | (n::_) as l -> 
+          | (n::_) as _l -> 
                  (function g ->
                     let exp_ast = (blast g) in
                      (display_function exp_ast;
@@ -599,7 +593,7 @@ let blast_tac display_function = function
 
 let blast_tac_txt = 
   blast_tac
-    (function x -> msgnl(Pptactic.pr_glob_tactic (Tacinterp.glob_tactic x)));;
+    (function x -> msgnl(Pptactic.pr_glob_tactic (Global.env()) (Tacinterp.glob_tactic x)));;
 
 (* Obsolète ?
 overwriting_add_tactic "Blast1" blast_tac_txt;;
diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli
index 21c29bc9..f6701943 100644
--- a/contrib/interface/blast.mli
+++ b/contrib/interface/blast.mli
@@ -1,5 +1,3 @@
 val blast_tac : (Tacexpr.raw_tactic_expr -> 'a) ->
-    int list ->
-    Proof_type.goal Tacmach.sigma ->
-    Proof_type.goal list Proof_type.sigma * Proof_type.validation;;
+    int list -> Proof_type.tactic
 
diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4
index 7bf12f3b..730e055b 100644
--- a/contrib/interface/centaur.ml4
+++ b/contrib/interface/centaur.ml4
@@ -4,7 +4,6 @@
 open Names;;
 open Nameops;;
 open Util;;
-open Ast;;
 open Term;;
 open Pp;;
 open Libnames;;
@@ -13,7 +12,6 @@ open Library;;
 open Vernacinterp;;
 open Evd;;
 open Proof_trees;;
-open Termast;;
 open Tacmach;;
 open Pfedit;;
 open Proof_type;;
@@ -28,7 +26,6 @@ open Vernacinterp;;
 open Vernac;;
 open Command;;
 open Protectedtoplevel;;
-open Coqast;;
 open Line_oriented_parser;;
 open Xlate;;
 open Vtp;;
@@ -283,15 +280,12 @@ let print_check judg =
  let value_ct_ast = 
      (try translate_constr false (Global.env()) value 
       with UserError(f,str) ->
-           raise(UserError(f,
-			   Ast.print_ast 
-				(ast_of_constr true (Global.env()) value) ++
+           raise(UserError(f,Printer.pr_lconstr value ++
 			      fnl () ++ str ))) in
  let type_ct_ast =
      (try translate_constr false (Global.env()) typ
       with UserError(f,str) ->
-           raise(UserError(f, Ast.print_ast (ast_of_constr true (Global.env())
-					       value) ++ fnl() ++ str))) in
+           raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in
  ((ctf_SearchResults !global_request_id),
  (Some  (P_pl
   (CT_premises_list
@@ -315,18 +309,6 @@ and ntyp = nf_betaiota typ in
 
 
 
-(* The following function is copied from globpr in env/printer.ml *)
-let globcv x =
-    match x with
-      | Node(_,"MUTIND", (Path(_,sp))::(Num(_,tyi))::_) ->
-	    convert_qualid
-	      (Nametab.shortest_qualid_of_global Idset.empty (IndRef(sp,tyi)))
-      | Node(_,"MUTCONSTRUCT",(Path(_,sp))::(Num(_,tyi))::(Num(_,i))::_) ->
-	  convert_qualid
-            (Nametab.shortest_qualid_of_global Idset.empty
-	       (ConstructRef ((sp, tyi), i)))
-  | _ -> failwith "globcv : unexpected value";;
-
 let pbp_tac_pcoq =
     pbp_tac (function (x:raw_tactic_expr) -> 
       output_results
@@ -360,12 +342,13 @@ let debug_tac2_pcoq tac =
 	let the_ast = ref tac in
 	let the_path = ref ([] : int list) in
 	try
-	  let result = report_error tac the_goal the_ast the_path [] g in
+	  let _result = report_error tac the_goal the_ast the_path [] g in
 	  (errorlabstrm "DEBUG TACTIC"
-	     (str "no error here " ++ fnl () ++ pr_goal (sig_it g) ++
+	     (str "no error here " ++ fnl () ++ Printer.pr_goal (sig_it g) ++
 	      fnl () ++ str "the tactic is" ++ fnl () ++
-	      Pptactic.pr_glob_tactic tac);
-	   result)
+	      Pptactic.pr_glob_tactic (Global.env()) tac) (*
+Caution, this is in the middle of what looks like dead code. ;
+	   result *))
 	with
 	  e ->
 	    match !the_goal with
@@ -413,11 +396,11 @@ let inspect n =
 			 let (_, _, v) = get_variable (basename sp) in
 			   add_search2 (Nametab.locate (qualid_of_sp sp)) v
 		     | (sp,kn), "CONSTANT" ->
-			 let {const_type=typ} = Global.lookup_constant kn in
+			 let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in
 			   add_search2 (Nametab.locate (qualid_of_sp sp)) typ
 		     | (sp,kn), "MUTUALINDUCTIVE" ->
 			 add_search2 (Nametab.locate (qualid_of_sp sp))
-			   (Pretyping.understand Evd.empty (Global.env())
+			   (Pretyping.Default.understand Evd.empty (Global.env())
 			      (RRef(dummy_loc, IndRef(kn,0))))
 		     | _ -> failwith ("unexpected value 1 for "^ 
 				      (string_of_id (basename (fst oname)))))
@@ -571,11 +554,11 @@ let pcoq_search s l =
 
 (* Check sequentially whether the pattern is one of the premises *)
 let rec hyp_pattern_filter pat name a c =
-  let c1 = strip_outer_cast c in
+  let _c1 = strip_outer_cast c in
     match kind_of_term c with
       | Prod(_, hyp, c2) -> 
 	  (try
-(*	     let _ = msgnl ((str "WHOLE ") ++ (Printer.prterm c)) in
+(*	     let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in
              let _ = msgnl ((str "PAT ") ++ (Printer.pr_pattern pat)) in *)
              if Matching.is_matching pat hyp then
 	       (msgnl (str "ok"); true)
@@ -616,7 +599,7 @@ let pcoq_show_goal = function
   | Some n -> show_nth n
   | None ->
       if !pcoq_started = Some true (* = debug *) then
-	msg (Pfedit.pr_open_subgoals ())
+	msg (Printer.pr_open_subgoals ())
       else errorlabstrm "show_goal"
 	(str "Show must be followed by an integer in Centaur mode");;
 
@@ -632,17 +615,17 @@ let pcoq_hook = {
 }
 
 
-TACTIC EXTEND Pbp
-| [ "Pbp" ident_opt(idopt) natural_list(nl) ] -> 
+TACTIC EXTEND pbp
+| [ "pbp" ident_opt(idopt) natural_list(nl) ] -> 
     [ if_pcoq pbp_tac_pcoq idopt nl ]
 END
 
-TACTIC EXTEND CtDebugTac
-| [ "DebugTac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
+TACTIC EXTEND ct_debugtac
+| [ "debugtac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
 END
 
-TACTIC EXTEND CtDebugTac2
-| [ "DebugTac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
+TACTIC EXTEND ct_debugtac2
+| [ "debugtac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
 END
 
 
diff --git a/contrib/interface/ctast.ml b/contrib/interface/ctast.ml
deleted file mode 100644
index 67279bb8..00000000
--- a/contrib/interface/ctast.ml
+++ /dev/null
@@ -1,76 +0,0 @@
-(* A copy of pre V7 ast *)
-
-open Names
-open Libnames
-
-type loc = Util.loc
-
-type t =
-  | Node of loc * string * t list
-  | Nvar of loc * string
-  | Slam of loc * string option * t
-  | Num of loc * int
-  | Id of loc * string
-  | Str of loc * string
-  | Path of loc * string list
-  | Dynamic of loc * Dyn.t
-
-let section_path sl =
-  match List.rev sl with
-    | s::pa ->
-	Libnames.encode_kn
-	  (make_dirpath (List.map id_of_string pa))
-	  (id_of_string s)
-    | [] -> invalid_arg "section_path"
-
-let is_meta s = String.length s > 0 && s.[0] == '$'
-
-let purge_str s =
-  if String.length s == 0 || s.[0] <> '$' then s
-  else String.sub s 1 (String.length s - 1)
-
-let rec ct_to_ast = function
-  | Node (loc,a,b) -> Coqast.Node (loc,a,List.map ct_to_ast b)
-  | Nvar (loc,a) ->
-      if is_meta a then Coqast.Nmeta (loc,purge_str a)
-      else Coqast.Nvar (loc,id_of_string a)
-  | Slam (loc,Some a,b) ->
-      if is_meta a then Coqast.Smetalam (loc,purge_str a,ct_to_ast b)
-      else Coqast.Slam (loc,Some (id_of_string a),ct_to_ast b)
-  | Slam (loc,None,b) -> Coqast.Slam (loc,None,ct_to_ast b)
-  | Num (loc,a) -> Coqast.Num (loc,a)
-  | Id (loc,a) -> Coqast.Id (loc,a)
-  | Str (loc,a) -> Coqast.Str (loc,a)
-  | Path (loc,sl) -> Coqast.Path (loc,section_path sl)
-  | Dynamic (loc,a) -> Coqast.Dynamic (loc,a)
-
-let rec ast_to_ct = function x -> failwith "ast_to_ct: not TODO?"
-(*
-  | Coqast.Node (loc,a,b) -> Node (loc,a,List.map ast_to_ct b)
-  | Coqast.Nvar (loc,a) -> Nvar (loc,string_of_id a)
-  | Coqast.Nmeta (loc,a) -> Nvar (loc,"$"^a)
-  | Coqast.Slam (loc,Some a,b) ->
-   Slam (loc,Some (string_of_id a),ast_to_ct b)
-  | Coqast.Slam (loc,None,b) -> Slam (loc,None,ast_to_ct b)
-  | Coqast.Smetalam (loc,a,b) -> Slam (loc,Some ("$"^a),ast_to_ct b)
-  | Coqast.Num (loc,a) -> Num (loc,a)
-  | Coqast.Id (loc,a) -> Id (loc,a)
-  | Coqast.Str (loc,a) -> Str (loc,a)
-  | Coqast.Path (loc,a) ->
-    let (sl,bn) = Libnames.decode_kn a in
-    Path(loc, (List.map string_of_id
-                (List.rev (repr_dirpath sl))) @ [string_of_id bn])
-  | Coqast.Dynamic (loc,a) -> Dynamic (loc,a)
-*)
-
-let loc = function
-  | Node (loc,_,_) -> loc
-  | Nvar (loc,_) -> loc
-  | Slam (loc,_,_) -> loc
-  | Num (loc,_) -> loc
-  | Id (loc,_) -> loc
-  | Str (loc,_) -> loc
-  | Path (loc,_) -> loc
-  | Dynamic (loc,_) -> loc
-
-let str s = Str(Util.dummy_loc,s)
diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml
index ec989296..8096bc31 100644
--- a/contrib/interface/dad.ml
+++ b/contrib/interface/dad.ml
@@ -73,7 +73,7 @@ let rec map_subst (env :env) (subst:patvar_map) = function
   | CPatVar (_,(_,i)) ->
       let constr = List.assoc i subst in
       extern_constr false env constr
-  | x -> map_constr_expr_with_binders (map_subst env) (fun _ x -> x) subst x;;
+  | x -> map_constr_expr_with_binders (fun _ x -> x) (map_subst env) subst x;;
 
 let map_subst_tactic env subst = function
   | TacExtend (loc,("Rewrite" as x),[b;cbl]) ->
@@ -251,7 +251,7 @@ let rec sort_list = function
 let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));;
 let mk_rewrite lr ast =
   let b = in_gen rawwit_bool lr in
-  let cb = in_gen rawwit_constr_with_bindings ((*Ctast.ct_to_ast*) ast,NoBindings) in
+  let cb = in_gen rawwit_constr_with_bindings (ast,NoBindings) in
   TacExtend (zz,"Rewrite",[b;cb])
 
 open Vernacexpr
diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4
index bf596b28..890bb3ce 100644
--- a/contrib/interface/debug_tac.ml4
+++ b/contrib/interface/debug_tac.ml4
@@ -1,7 +1,5 @@
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-open Ast;;
-open Coqast;;
 open Tacmach;;
 open Tacticals;;
 open Proof_trees;;
@@ -12,6 +10,8 @@ open Proof_type;;
 open Tacexpr;;
 open Genarg;;
 
+let pr_glob_tactic = Pptactic.pr_glob_tactic (Global.env())
+
 (* Compacting and uncompacting proof commands *)
 
 type report_tree =
@@ -72,11 +72,6 @@ let check_subgoals_count2
 	 Recursive_fail (List.hd !new_report_holder)));
     result;;
 
-(*
-let traceable = function
-    Node(_, "TACTICLIST", a::b::tl) -> true
-  | _ -> false;;
-*)
 let traceable = function
   | TacThen _ | TacThens _ -> true
   | _ -> false;;
@@ -116,25 +111,6 @@ let count_subgoals2
     result;;
 
 let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function
-(*
-    Node(_, "TACTICLIST", [a;Node(_, "TACLIST", l)]) ->
-      (fun report_holder -> checked_thens report_holder a l)
-  | Node(_, "TACTICLIST", a::((Node(_, "TACLIST", l))as b)::c::tl) ->
-      local_interp(ope ("TACTICLIST", (ope("TACTICLIST", [a;b]))::c::tl))
-  | Node(_, "TACTICLIST", [a;b]) ->
-      (fun report_holder -> checked_then report_holder a b)
-  | Node(_, "TACTICLIST", a::b::c::tl) ->
-	local_interp(ope ("TACTICLIST", (ope("TACTICLIST", [a;b]))::c::tl))
-  | ast ->
-      (fun report_holder g ->
-	try
-	  let (gls, _) as result = Tacinterp.interp ast g in
-	  report_holder := (Report_node(true, List.length (sig_it gls), []))
-			    ::!report_holder;
-	  result
-	with e -> (report_holder := (Failed 1)::!report_holder;
-		   tclIDTAC g))
-*)
     TacThens (a,l) ->
       (fun report_holder -> checked_thens report_holder a l)
   | TacThen (a,b) ->
@@ -263,9 +239,14 @@ and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tacti
    by the list of integers given as extra arguments.
  *)
 
+let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level
+let globwit_main_tactic = Pcoq.globwit_tactic Pcoq.tactic_main_level
+let wit_main_tactic = Pcoq.wit_tactic Pcoq.tactic_main_level
+
+
 let on_then = function [t1;t2;l] ->
-  let t1 = out_gen wit_tactic t1 in
-  let t2 = out_gen wit_tactic t2 in
+  let t1 = out_gen wit_main_tactic t1 in
+  let t2 = out_gen wit_main_tactic t2 in
   let l = out_gen (wit_list0 wit_int) l in
   tclTHEN_i (Tacinterp.eval_tactic t1)
     (fun i ->
@@ -276,78 +257,18 @@ let on_then = function [t1;t2;l] ->
   | _ -> anomaly "bad arguments for on_then";;
 
 let mkOnThen t1 t2 selected_indices =
-  let a = in_gen rawwit_tactic t1 in
-  let b = in_gen rawwit_tactic t2 in
+  let a = in_gen rawwit_main_tactic t1 in
+  let b = in_gen rawwit_main_tactic t2 in
   let l = in_gen (wit_list0 rawwit_int) selected_indices in
   TacAtom (dummy_loc, TacExtend (dummy_loc, "OnThen", [a;b;l]));;
 
 (* Analyzing error reports *)
 
-(*
-let rec select_success n = function
-    [] -> []
-  | Report_node(true,_,_)::tl -> (Num((0,0),n))::select_success (n+1) tl
-  | _::tl -> select_success (n+1) tl;;
-*)
 let rec select_success n = function
     [] -> []
   | Report_node(true,_,_)::tl -> n::select_success (n+1) tl
   | _::tl -> select_success (n+1) tl;;
 
-(*
-let rec expand_tactic = function
-    Node(loc1, "TACTICLIST", [a;Node(loc2,"TACLIST", l)]) ->
-      Node(loc1, "TACTICLIST",
-	   [expand_tactic a;
-	     Node(loc2, "TACLIST", List.map expand_tactic l)])
-  | Node(loc1, "TACTICLIST", a::((Node(loc2, "TACLIST", l))as b)::c::tl) ->
-      expand_tactic (Node(loc1, "TACTICLIST",
-			  (Node(loc1, "TACTICLIST", [a;b]))::c::tl))
-  | Node(loc1, "TACTICLIST", [a;b]) ->
-      Node(loc1, "TACTICLIST",[expand_tactic a;expand_tactic b])
-  | Node(loc1, "TACTICLIST", a::b::c::tl) ->
-      expand_tactic (Node(loc1, "TACTICLIST",
-			  (Node(loc1, "TACTICLIST", [a;b]))::c::tl))
-  | any -> any;;
-*)
-(* Useless: already in binary form...
-let rec expand_tactic = function
-    TacThens (a,l) -> TacThens (expand_tactic a, List.map expand_tactic l)
-  | TacThen (a,b) -> TacThen (expand_tactic a, expand_tactic b)
-  | any -> any;;
-*)
-
-(*
-let rec reconstruct_success_tac ast = 
-  match ast with
-    Node(_, "TACTICLIST", [a;Node(_,"TACLIST",l)]) ->
-      (function 
-	  Report_node(true, n, l) -> ast
-      	| Report_node(false, n, rl) ->
-	    ope("TACTICLIST",[a;ope("TACLIST", 
-				    List.map2 reconstruct_success_tac l rl)])
-      	| Failed n -> ope("Idtac",[])
-      	| Tree_fail r -> reconstruct_success_tac a r
-      	| Mismatch (n,p) -> a)
-  | Node(_, "TACTICLIST", [a;b]) ->
-      (function
-	  Report_node(true, n, l) -> ast
-	| Report_node(false, n, rl) ->
-	    let selected_indices = select_success 1 rl in
-	    ope("OnThen", a::b::selected_indices)
-	| Failed n -> ope("Idtac",[])
-	| Tree_fail r -> reconstruct_success_tac a r
-	| _ -> error "this error case should not happen in a THEN tactic")
-  | _ -> 
-      (function
-	  Report_node(true, n, l) -> ast
-	| Failed n -> ope("Idtac",[])
-	| _ ->
-	    errorlabstrm
-	      "this error case should not happen on an unknown tactic"
-              (str "error in reconstruction with " ++ fnl () ++
-	       (gentacpr ast)));;
-*)
 let rec reconstruct_success_tac (tac:glob_tactic_expr) =
   match tac with
     TacThens (a,l) ->
@@ -355,7 +276,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) =
 	  Report_node(true, n, l) -> tac
       	| Report_node(false, n, rl) ->
 	    TacThens (a,List.map2 reconstruct_success_tac l rl)
-      	| Failed n -> TacId ""
+      	| Failed n -> TacId []
       	| Tree_fail r -> reconstruct_success_tac a r
       	| Mismatch (n,p) -> a)
   | TacThen (a,b) ->
@@ -364,16 +285,16 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) =
 	| Report_node(false, n, rl) ->
 	    let selected_indices = select_success 1 rl in
 	    TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen",
-	      [in_gen globwit_tactic a;
-	       in_gen globwit_tactic b;
+	      [in_gen globwit_main_tactic a;
+	       in_gen globwit_main_tactic b;
 	       in_gen (wit_list0 globwit_int) selected_indices]))
-	| Failed n -> TacId ""
+	| Failed n -> TacId []
 	| Tree_fail r -> reconstruct_success_tac a r
 	| _ -> error "this error case should not happen in a THEN tactic")
   | _ -> 
       (function
 	  Report_node(true, n, l) -> tac
-	| Failed n -> TacId ""
+	| Failed n -> TacId []
 	| _ ->
 	    errorlabstrm
 	      "this error case should not happen on an unknown tactic"
@@ -391,21 +312,6 @@ let rec path_to_first_error = function
     p::(path_to_first_error t)
 | _ -> [];;
 
-(*
-let rec flatten_then_list tail = function
-  | Node(_, "TACTICLIST", [a;b]) ->
-      flatten_then_list ((flatten_then b)::tail) a
-  | ast -> ast::tail
-and flatten_then = function
-    Node(_, "TACTICLIST", [a;b]) ->
-      ope("TACTICLIST", flatten_then_list [flatten_then b] a)
-  | Node(_, "TACLIST", l) ->
-      ope("TACLIST", List.map flatten_then l)
-  | Node(_, "OnThen", t1::t2::l) ->
-      ope("OnThen", (flatten_then t1)::(flatten_then t2)::l)
-  | ast -> ast;;
-*)
-
 let debug_tac = function
     [(Tacexp ast)] ->
       (fun g -> 
@@ -430,26 +336,8 @@ let debug_tac = function
 add_tactic "DebugTac" debug_tac;;
 *)
 
-(*
-hide_tactic "OnThen" on_then;;
-*)
-Refiner.add_tactic "OnThen" on_then;;
+Tacinterp.add_tactic "OnThen" on_then;;
 
-(*
-let rec clean_path p ast l = 
-  match ast, l with
-    Node(_, "TACTICLIST", ([_;_] as tacs)), fst::tl ->
-       fst::(clean_path 0 (List.nth tacs (fst - 1)) tl)
-  | Node(_, "TACTICLIST", tacs), 2::tl ->
-     let rank = (List.length tacs) - p in
-     rank::(clean_path 0 (List.nth tacs (rank - 1)) tl)
-  | Node(_, "TACTICLIST", tacs), 1::tl ->
-      clean_path (p+1) ast tl
-  | Node(_, "TACLIST", tacs), fst::tl ->
-      fst::(clean_path 0 (List.nth tacs (fst - 1)) tl)
-  | _, [] -> []
-  | _, _ -> failwith "this case should not happen in clean_path";;
-*)
 let rec clean_path tac l = 
   match tac, l with
   | TacThen (a,b), fst::tl ->
@@ -554,8 +442,8 @@ let descr_first_error tac =
 	    (msgnl (str "Execution of this tactic raised message " ++ fnl () ++
 		    fnl () ++ Cerrors.explain_exn e ++ fnl () ++
 		    fnl () ++ str "on goal"  ++ fnl () ++
-		    pr_goal (sig_it (strip_some !the_goal)) ++ fnl () ++
-		    str "faulty tactic is" ++ fnl () ++ fnl () ++
+		    Printer.pr_goal (sig_it (strip_some !the_goal)) ++
+                    fnl () ++ str "faulty tactic is" ++ fnl () ++ fnl () ++
 		    pr_glob_tactic ((*flatten_then*) !the_ast) ++ fnl ());
 	     tclIDTAC g))
 
diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli
index ded714b6..da4bbaa0 100644
--- a/contrib/interface/debug_tac.mli
+++ b/contrib/interface/debug_tac.mli
@@ -1,6 +1,6 @@
 
 val report_error : Tacexpr.glob_tactic_expr ->
-    Proof_type.goal Proof_type.sigma option ref ->
+    Proof_type.goal Evd.sigma option ref ->
     Tacexpr.glob_tactic_expr ref -> int list ref -> int list -> Tacmach.tactic;;
 
 val clean_path : Tacexpr.glob_tactic_expr -> int list -> int list;;
diff --git a/contrib/interface/line_parser.ml4 b/contrib/interface/line_parser.ml4
index b5669351..0b13a092 100755
--- a/contrib/interface/line_parser.ml4
+++ b/contrib/interface/line_parser.ml4
@@ -84,7 +84,7 @@ let rec string len = parser
    spaces and tabulations are ignored, identifiers, integers,
    strings, opening and closing square brackets.  Lexical errors are
    ignored ! *)
-let rec next_token = parser count
+let rec next_token = parser _count
   [< '' ' | '\t'; tok = next_token >] -> tok
 | [< ''_' | 'a'..'z' | 'A'..'Z' as c;i = (ident (add_in_buff 0 c))>] -> i
 | [< ''0'..'9' as c ; i = (parse_int (get_digit c))>] -> i
@@ -96,7 +96,7 @@ let rec next_token = parser count
 (* A very simple lexical analyser to recognize a integer value behind 
    blank characters *)
 
-let rec next_int = parser count
+let rec next_int = parser _count
   [< '' ' | '\t'; v = next_int >] -> v
 | [< ''0'..'9' as c; i = (parse_int (get_digit c))>] ->
      (match i with
diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml
index eaff0968..9a503cfb 100644
--- a/contrib/interface/name_to_ast.ml
+++ b/contrib/interface/name_to_ast.ml
@@ -2,9 +2,6 @@ open Sign;;
 open Classops;;
 open Names;;
 open Nameops
-open Coqast;;
-open Ast;;
-open Termast;;
 open Term;;
 open Impargs;;
 open Reduction;;
@@ -90,13 +87,6 @@ let implicit_args_to_ast_list sp mipv =
 	  [] -> []
 	| _ -> [VernacComments (List.rev implicit_args_descriptions)];;
 	      
-let convert_qualid qid =
-  let d, id = Libnames.repr_qualid qid in
-    match repr_dirpath d with
-	[] -> nvar id
-      | d -> ope("QUALID", List.fold_left (fun l s -> (nvar s)::l)
-		   [nvar id] d);;
-
 (* This function converts constructors for an inductive definition to a
    Coqast.t.  It is obtained directly from print_constructors in pretty.ml *)
 
@@ -117,10 +107,10 @@ let convert_one_inductive sp tyi =
   let env = Global.env () in
   let envpar = push_rel_context params env in
   let sp = sp_of_global (IndRef (sp, tyi)) in
-  ((dummy_loc,basename sp), None,
+  (((dummy_loc,basename sp),
    convert_env(List.rev params),
    (extern_constr true envpar arity),
-   convert_constructors envpar cstrnames cstrtypes);;
+   convert_constructors envpar cstrnames cstrtypes), None);;
 
 (* This function converts a Mutual inductive definition to a Coqast.t.
    It is obtained directly from print_mutual in pretty.ml.  However, all
@@ -142,16 +132,6 @@ let implicits_to_ast_list implicits =
     | None -> []
     | Some s -> [VernacComments [CommentString s]];;
 
-(*
-let make_variable_ast name typ implicits =
-   (ope("VARIABLE",
-    [string "VARIABLE";
-     ope("BINDERLIST",
-         [ope("BINDER",
-            [(constr_to_ast (body_of_type typ));
-             nvar name])])]))::(implicits_to_ast_list implicits)
-    ;;
-*)
 let make_variable_ast name typ implicits =
   (VernacAssumption
     ((Local,Definitional),
@@ -160,7 +140,7 @@ let make_variable_ast name typ implicits =
     
 
 let make_definition_ast name c typ implicits =
-  VernacDefinition ((Global,Definition), (dummy_loc,name), DefineBody ([], None,
+  VernacDefinition ((Global,false,Definition), (dummy_loc,name), DefineBody ([], None,
     (constr_to_ast c), Some (constr_to_ast (body_of_type typ))),
     (fun _ _ -> ()))
   ::(implicits_to_ast_list implicits);;
@@ -169,13 +149,13 @@ let make_definition_ast name c typ implicits =
 let constant_to_ast_list kn =
   let cb = Global.lookup_constant kn in
   let c = cb.const_body in
-  let typ = cb.const_type in
+  let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in
   let l = implicits_of_global (ConstRef kn) in
   (match c with
       None -> 
-	make_variable_ast (id_of_label (label kn)) typ l
+	make_variable_ast (id_of_label (con_label kn)) typ l
     | Some c1 ->
-	make_definition_ast (id_of_label (label kn)) (Declarations.force c1) typ l)
+	make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l)
 
 let variable_to_ast_list sp =
   let (id, c, v) = get_variable sp in
@@ -198,7 +178,7 @@ let leaf_entry_to_ast_list ((sp,kn),lobj) =
   let tag = object_tag lobj in
   match tag with
   | "VARIABLE" -> variable_to_ast_list (basename sp)
-  | "CONSTANT" -> constant_to_ast_list kn
+  | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn)
   | "INDUCTIVE" -> inductive_to_ast_list kn
   | s -> 
       errorlabstrm 
@@ -240,7 +220,7 @@ let name_to_ast ref =
 		   | Some c1 -> make_definition_ast name c1 typ [])
 	  with Not_found ->
 	    try
-	      let sp = Nametab.locate_syntactic_definition qid in
+	      let _sp = Nametab.locate_syntactic_definition qid in
 		errorlabstrm "print"
       		  (str "printing of syntax definitions not implemented")
 	    with Not_found ->
diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli
index 0eca0a1e..b8c2d7dc 100644
--- a/contrib/interface/name_to_ast.mli
+++ b/contrib/interface/name_to_ast.mli
@@ -1,2 +1 @@
 val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;;
-val convert_qualid : Libnames.qualid -> Coqast.t;;
diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml
index 3f0b2d2e..8cca7614 100644
--- a/contrib/interface/parse.ml
+++ b/contrib/interface/parse.ml
@@ -48,55 +48,8 @@ let ctf_FileErrorMessage reqid pps =
   int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++
   fnl ();;
 
-(*
-(*In the code for CoqV6.2, the require_module call is encapsulated in
-  a function "without_mes_ambig".  Here I have supposed that this
-  function has no effect on parsing *)
-let try_require_module import specif names =
- try Library.require_module 
-   (if specif = "UNSPECIFIED" then None
-    else Some (specif = "SPECIFICATION"))
-   (List.map 
-     (fun name ->
-       (dummy_loc,Libnames.make_short_qualid (Names.id_of_string name)))
-      names)
-   (import = "IMPORT")
- with
-   | e -> msgnl (str "Reinterning of " ++ prlist str names ++ str " failed");;
-*)
-(*
-let try_require_module_from_file import specif name fname =
- try Library.require_module_from_file (if specif = "UNSPECIFIED" then None
-  else Some (specif = "SPECIFICATION")) (Some (Names.id_of_string name)) fname (import = "IMPORT")
- with
- | e -> msgnl (str "Reinterning of " ++ str name ++ str " failed");;
-*)
-(*
-let execute_when_necessary ast =
- (match ast with
-  | Node (_, "GRAMMAR", ((Nvar (_, s)) :: ((Node (_, "ASTLIST", al)) :: []))) ->
-   Metasyntax.add_grammar_obj s (List.map Ctast.ct_to_ast al)
-(* Obsolete
-  | Node (_, "TOKEN", ((Str (_, s)) :: [])) -> Metasyntax.add_token_obj s
-*)
-  | Node (_, "Require",
-            ((Str (_, import)) ::
-              ((Str (_, specif)) :: l))) ->
-   let mnames = List.map (function
-     | (Nvar (_, m)) -> m
-     | _ -> error "parse_string_action : bad require expression") l in
-   try_require_module import specif mnames
-  | Node (_, "RequireFrom",
-            ((Str (_, import)) ::
-              ((Str (_, specif)) ::
-                ((Nvar (_, mname)) :: ((Str (_, file_name)) :: []))))) ->
-   try_require_module_from_file import specif mname file_name
-  | _ -> ()); ast;;
-*)
-
 let execute_when_necessary v =
  (match v with
-  | VernacGrammar _ -> Vernacentries.interp v
   | VernacOpenCloseScope sc -> Vernacentries.interp v
   | VernacRequire (_,_,l) ->
       (try 
@@ -202,12 +155,6 @@ let parse_command_list reqid stream string_list =
                 discard_to_dot stream;
                 msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++
 		       int (Stream.count stream));
-(*
-                Some( Node(l, "PARSING_ERROR",
-                        List.map Ctast.str
-                        (get_substring_list string_list this_pos
-                            (Stream.count stream))))
-*)
 		ParseError ("PARSING_ERROR",
                   get_substring_list string_list this_pos
 		    (Stream.count stream))
@@ -216,27 +163,14 @@ let parse_command_list reqid stream string_list =
         | e-> 
           begin
             discard_to_dot stream;
-(*
-            Some(Node((0,0), "PARSING_ERROR2",
-                   List.map Ctast.str
-		   (get_substring_list string_list this_pos
-                     (Stream.count stream))))
-*)
 	    ParseError ("PARSING_ERROR2",
 	      get_substring_list string_list this_pos (Stream.count stream))
           end in
     match first_ast with
     | ParseOK (Some (loc,ast)) ->
-        let ast0 = (execute_when_necessary ast) in
+        let _ast0 = (execute_when_necessary ast) in
           (try xlate_vernac ast
 	  with e ->
-(*
-	    xlate_vernac 
-              (Node((0,0), "PARSING_ERROR2",
-               List.map Ctast.str
-		 (get_substring_list string_list this_pos
-		    (Stream.count stream)))))::parse_whole_stream()
-*)
 	    make_parse_error_item "PARSING_ERROR2" 
 		     (get_substring_list string_list this_pos
 		       (Stream.count stream)))::parse_whole_stream()
@@ -311,7 +245,7 @@ let parse_file_action reqid file_name =
         get the text when a syntax error occurs *)
      let file_chan_err = open_in file_name in 
      let stream = Stream.of_channel file_chan in
-     let stream_err = Stream.of_channel file_chan_err in
+     let _stream_err = Stream.of_channel file_chan_err in
      let rec discard_to_dot () =
        try Gram.Entry.parse parse_to_dot (Gram.parsable stream)
        with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in
@@ -345,7 +279,7 @@ let parse_file_action reqid file_name =
 		   
              with
                | ParseOK (Some (_,ast)) ->
-		   let ast0=(execute_when_necessary ast) in 
+		   let _ast0=(execute_when_necessary ast) in 
 		   let term =
                      (try xlate_vernac ast
 		      with e ->
@@ -381,27 +315,27 @@ let parse_file_action reqid file_name =
 		   fnl () ++ Cerrors.explain_exn e));;
 
 let add_rec_path_action reqid string_arg ident_arg =
-  let directory_name = glob string_arg in
+  let directory_name = expand_path_macros string_arg in
     begin
       add_rec_path directory_name (Libnames.dirpath_of_string ident_arg)
     end;;
 	
 
 let add_path_action reqid string_arg =
-  let directory_name = glob string_arg in
+  let directory_name = expand_path_macros string_arg in
     begin
       add_path directory_name Names.empty_dirpath
     end;;
 
 let print_version_action () =
   msgnl (mt ());
-  msgnl (str "$Id: parse.ml,v 1.22 2004/04/21 08:36:58 barras Exp $");;
+  msgnl (str "$Id: parse.ml 9397 2006-11-21 21:50:54Z herbelin $");;
 
 let load_syntax_action reqid module_name =
  msg (str "loading " ++ str module_name ++ str "... ");
  try
       (let qid = Libnames.make_short_qualid (Names.id_of_string module_name) in
-      read_library (dummy_loc,qid);
+      require_library [dummy_loc,qid] None;
       msg (str "opening... ");
       Declaremods.import_module false (Nametab.locate_module qid); 
       msgnl (str "done" ++ fnl ());
@@ -456,7 +390,6 @@ Libobject.relax true;
 	   coqdir [ "contrib"; "interface"; "vernacrc"] in
    try
      (Gramext.warning_verbose := false;
-      Esyntax.warning_verbose := false;
       coqparser_loop (open_in vernacrc))
    with
      | End_of_file -> ()
@@ -470,7 +403,7 @@ Libobject.relax true;
 (try let user_vernacrc =
    try Some(Sys.getenv "USERVERNACRC")
    with
-     | Not_found as e ->
+     | Not_found ->
 	 msgnl (str "no .vernacrc file"); None in
    (match user_vernacrc with
       	Some f -> coqparser_loop (open_in f)
diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml
index e0f88ba6..d2f71bfc 100644
--- a/contrib/interface/pbp.ml
+++ b/contrib/interface/pbp.ml
@@ -34,13 +34,13 @@ let get_hyp_by_name g name =
   let evd = project g in
   let env = pf_env g in
   try (let judgment = 
-         Pretyping.understand_judgment 
+         Pretyping.Default.understand_judgment 
           evd env (RVar(zz, name)) in
        ("hyp",judgment.uj_type))
 (* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up...
    Loïc *)
   with _ -> (let c = Nametab.global (Ident (zz,name)) in
-             ("cste",type_of (Global.env()) Evd.empty (constr_of_reference c)))
+             ("cste",type_of (Global.env()) Evd.empty (constr_of_global c)))
 ;;
 
 type pbp_atom =
@@ -106,7 +106,7 @@ let make_final_cmd f optname clear_names constr path =
     add_clear_names_if_necessary (f optname constr path) clear_names;;
 
 let (rem_cast:pbp_rule) = function
-    (a,c,cf,o, Cast(f,_), p, func) ->
+    (a,c,cf,o, Cast(f,_,_), p, func) ->
       Some(func a c cf o (kind_of_term f) p)
   | _ -> None;;
 
@@ -154,7 +154,7 @@ let make_pbp_pattern x =
      [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))]
 
 let rec make_then = function
-  | [] -> TacId ""
+  | [] -> TacId []
   | [t] -> t
   | t1::t2::l -> make_then (TacThen (t1,t2)::l)
 
@@ -177,7 +177,7 @@ let make_pbp_atomic_tactic = function
       TacAtom
 	(zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None))
   | PbpTryClear l -> 
-      TacTry (TacAtom (zz, TacClear (List.map (fun s -> AI (zz,s)) l)))
+      TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l)))
   | PbpSplit -> TacAtom (zz, TacSplit (false,NoBindings));;
 
 let rec make_pbp_tactic = function
@@ -203,7 +203,7 @@ let (imply_elim1: pbp_rule) = function
   Some h, Prod(Anonymous, prem, body), 1::path, f ->
   let clear_names' = if clear_flag then h::clear_names else clear_names in
   let h' = next_global_ident hyp_radix avoid in
-  let str_h' = (string_of_id h') in
+  let _str_h' = (string_of_id h') in
   Some(PbpThens
 	  ([PbpLApply h],
 	   [chain_tactics [make_named_intro h'] (make_clears (h::clear_names));
diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli
index 43ec1274..9daba184 100644
--- a/contrib/interface/pbp.mli
+++ b/contrib/interface/pbp.mli
@@ -1,4 +1,2 @@
 val pbp_tac : (Tacexpr.raw_tactic_expr -> 'a) ->
-    Names.identifier option -> int list ->
-    Proof_type.goal Tacmach.sigma ->
-    Proof_type.goal list Proof_type.sigma * Proof_type.validation;;
+    Names.identifier option -> int list -> Proof_type.tactic
diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml
index 5b265ec8..4bec7350 100644
--- a/contrib/interface/showproof.ml
+++ b/contrib/interface/showproof.ml
@@ -11,7 +11,6 @@ open Term
 open Termops
 open Util
 open Proof_type
-open Coqast
 open Pfedit
 open Translate
 open Term
@@ -54,7 +53,7 @@ and ngoal=
      {newhyp : nhyp list;
       t_concl : Term.constr;
       t_full_concl: Term.constr;
-      t_full_env: Sign.named_context}
+      t_full_env: Environ.named_context_val}
 and ntree=
       {t_info:string;
 	t_goal:ngoal;
@@ -151,42 +150,22 @@ let seq_to_lnhyp sign sign' cl =
       {newhyp=nh;
        t_concl=cl;
        t_full_concl=long_type_hyp !lh cl;
-       t_full_env = sign@sign'}
+       t_full_env = Environ.val_of_named_context (sign@sign')}
 ;;
 
 
 let rule_is_complex r =
    match r with
-      Tactic (TacArg (Tacexp t),_) -> true  
-   |  Tactic (TacAtom (_,TacAuto _), _) -> true
-   |  Tactic (TacAtom (_,TacSymmetry _), _) -> true 
+       Nested (Tactic 
+		 ((TacArg (Tacexp _)
+		 |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true
    |_ -> false
 ;;
 
-let ast_of_constr = Termast.ast_of_constr true (Global.env()) ;;
-
-(*
-let rule_to_ntactic r =
-   let rast =
-     (match r with
-       Tactic (s,l) ->
-	 Ast.ope (s,(List.map ast_of_cvt_arg l))
-     | Prim (Refine h) ->
-	 Ast.ope ("Exact",
-		  [Node ((0,0), "COMMAND", [ast_of_constr h])])
-     | _ -> Ast.ope ("Intros",[])) in
-   if rule_is_complex r
-   then (match rast with
-           Node(_,_,[Node(_,_,[Node(_,_,x)])]) ->x
-          | _ -> assert false)
-
-   else [rast ]
-;;
-*)
 let rule_to_ntactic r =
    let rt =
      (match r with
-       Tactic (t,_) -> t
+       Nested(Tactic (t,_),_) -> t
      | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h)
      | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in
    if rule_is_complex r
@@ -197,14 +176,6 @@ let rule_to_ntactic r =
    else rt
 ;;
 
-(*
-let term_of_command x =
-  match x with
-    Node(_,_,y::_) -> y
-  | _ -> x
-;;
-*)
-
 (* Attribue les preuves de la liste l aux sous-buts non-prouvés de nt  *)
 
 
@@ -226,7 +197,7 @@ let fill_unproved nt l =
 let new_sign osign sign =
     let res=ref [] in
     List.iter (fun (id,c,ty) ->
-		   try (let  (_,_,ty1)= (lookup_named id osign) in
+		   try (let  (_,_,_ty1)= (lookup_named id osign) in
 			())
 		   with Not_found -> res:=(id,c,ty)::(!res))
               sign;
@@ -247,6 +218,7 @@ let old_sign osign sign =
 let  to_nproof sigma osign pf =
   let rec to_nproof_rec sigma osign pf =
     let {evar_hyps=sign;evar_concl=cl} = pf.goal in
+    let sign = Environ.named_context_of_val sign in
     let nsign = new_sign osign sign in 
     let oldsign = old_sign osign sign in 
     match pf.ref with
@@ -262,17 +234,17 @@ let  to_nproof sigma osign pf =
               (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof)
 		 spfl) in
 	  (match r with
-	    Tactic (TacAtom (_, TacAuto _),_) ->
-	      if spfl=[]
-	      then
-	      	{t_info="to_prove";
-	    	  t_goal= {newhyp=[];
-			    t_concl=concl ntree;
-			    t_full_concl=ntree.t_goal.t_full_concl;
-			    t_full_env=ntree.t_goal.t_full_env};
-		  t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])}
-	      else ntree
-	  | _ -> ntree))
+	       Nested(Tactic (TacAtom (_, TacAuto _),_),_) ->
+		 if spfl=[]
+		 then
+	      	   {t_info="to_prove";
+	    	    t_goal= {newhyp=[];
+			     t_concl=concl ntree;
+			     t_full_concl=ntree.t_goal.t_full_concl;
+			     t_full_env=ntree.t_goal.t_full_env};
+		    t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])}
+		 else ntree
+	     | _ -> ntree))
       	else
 	  {t_info="to_prove";
 	    t_goal=(seq_to_lnhyp oldsign nsign cl);
@@ -417,13 +389,6 @@ let enumerate f ln =
 
 let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());;
 
-(*
-let sp_tac tac =
-   try spt (constr_of_ast (term_of_command tac))
-   with _ -> (* let Node(_,t,_) = tac in *)
-             spe (* sps ("error in sp_tac " ^ t) *)
-;;
-*)
 let sp_tac tac = failwith "TODO"
 
 let soit_A_une_proposition nh ln t=  match !natural_language with
@@ -754,13 +719,13 @@ let rec nsortrec vl x =
    | Sort(c) -> c
    | Ind(ind) ->
           let (mib,mip) = lookup_mind_specif vl ind in
-          mip.mind_sort
+	  new_sort_in_family (inductive_sort_family mip)
    | Construct(c) ->
           nsortrec vl (mkInd (inductive_of_constructor c))
    | Case(_,x,t,a) 
         -> nsortrec vl x
-   | Cast(x,t)-> nsortrec vl t
-   | Const c  -> nsortrec vl (lookup_constant c vl).const_type
+   | Cast(x,_, t)-> nsortrec vl t
+   | Const c  -> nsortrec vl (Typeops.type_of_constant vl c)
    | _ -> nsortrec vl (type_of vl Evd.empty x)
 ;;
 let nsort x =
@@ -791,7 +756,7 @@ let rec group_lhyp lh =
 let natural_ghyp (sort,ln,lt) intro =
   let t=List.hd lt in
   let nh=List.length ln in
-  let ns=List.hd ln in
+  let _ns=List.hd ln in
   match sort with
     Nprop -> soit_A_une_proposition nh ln t
   | Ntype -> soit_X_un_element_de_T nh ln t
@@ -963,16 +928,6 @@ let  natural_lhyp lh hi =
     Analyse des tactiques.
 *)
 
-(*
-let name_tactic tac =
-      match tac with
-        (Node(_,"Interp",
-		(Node(_,_,
-		      (Node(_,t,_))::_))::_))::_  -> t
-       |(Node(_,t,_))::_ -> t
-       | _ -> assert false
-;;
-*)
 let name_tactic = function
   | TacIntroPattern _ -> "Intro"
   | TacAssumption -> "Assumption"
@@ -991,51 +946,8 @@ let arg1_tactic tac =
 ;;
 *)
 
-let arg1_tactic tac = failwith "TODO"
-
-let arg2_tactic tac =
-   match tac with
-     (Node(_,"Interp",
-		(Node(_,_,
-		      (Node(_,_,_::x::_))::_))::_))::_ -> x
-    | (Node(_,_,_::x::_))::_ -> x
-    | _ -> assert false
-;;
-
-(*
-type nat_tactic =
-    Split of (Coqast.t list)
-  | Generalize of (Coqast.t list)
-  | Reduce of string*(Coqast.t list)
-  | Other of string*(Coqast.t list)
-;;
-
-let analyse_tac tac =
-  match tac with
-    [Node (_, "Split", [Node (_, "BINDINGS", [])])]
-      -> Split []
-  | [Node (_, "Split",[Node(_, "BINDINGS",[Node(_, "BINDING",
-	[Node (_, "COMMAND", x)])])])] 
-     -> Split x
-  | [Node (_, "Generalize", [Node (_, "COMMAND", x)])] 
-     ->Generalize x
-  | [Node (_, "Reduce", [Node (_, "REDEXP", [Node (_, mode, _)]);
-             Node (_, "CLAUSE", lhyp)])] 
-     -> Reduce(mode,lhyp)
-  | [Node (_, x,la)] -> Other (x,la)
-  | _ -> assert false
-;;
-*)
-      
-
-
+let arg1_tactic tac = failwith "TODO";;
 
-
-let id_of_command x =
-  match x with
-      Node(_,_,Node(_,_,y::_)::_) ->  y
-     |_ -> assert false
-;;
 type type_info_subgoals =
     {ihsg: type_info_subgoals_hyp;
      isgintro : string}
@@ -1285,7 +1197,7 @@ let rec natural_ntree ig ntree =
 	  | TacAssumption -> natural_trivial ig lh g gs ltree
 	  | TacClear _ -> natural_clear ig lh g gs ltree
 (* Besoin de l'argument de la tactique *)
-	  | TacSimpleInduction (NamedHyp id,_) -> 
+	  | TacSimpleInduction (NamedHyp id) -> 
               natural_induction ig lh g gs ge id ltree false
 	  | TacExtend (_,"InductionIntro",[a]) -> 
               let id=(out_gen wit_ident a) in
@@ -1294,7 +1206,7 @@ let rec natural_ntree ig ntree =
 	  | TacExact c -> natural_exact ig lh g gs c ltree
 	  | TacCut c -> natural_cut ig lh g gs c ltree
 	  | TacExtend (_,"CutIntro",[a]) ->
-	      let c = out_gen wit_constr a in
+	      let _c = out_gen wit_constr a in
 	      natural_cutintro ig lh g gs a ltree
 	  | TacCase (c,_) -> natural_case ig lh g gs ge c ltree false
 	  | TacExtend (_,"CaseIntro",[a]) ->
@@ -1518,7 +1430,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros =
 	 if with_intros
          then (arity_of_constr_of_mind env indf 1)
 	 else 0 in
-       let ici= 1 in
+       let _ici= 1 in
        sph[ (natural_ntree  
                {ihsg=
                  (match (nsort targ1) with
@@ -1547,7 +1459,7 @@ and prod_list_var t =
 and  hd_is_mind t ti =
     try (let env = Global.env() in
          let IndType (indf,targ) = find_rectype env Evd.empty t in
-	 let ncti= Array.length(get_constructors env indf) in
+	 let _ncti= Array.length(get_constructors env indf) in
 	 let (ind,_) = dest_ind_family indf in
          let (mib,mip) = lookup_mind_specif env ind in
 	 (string_of_id mip.mind_typename) = ti)
@@ -1556,7 +1468,7 @@ and mind_ind_info_hyp_constr indf c =
   let env = Global.env() in
   let (ind,_) = dest_ind_family indf in
   let (mib,mip) = lookup_mind_specif env ind in
-  let p = mip.mind_nparams in
+  let _p = mib.mind_nparams in
   let a = arity_of_constr_of_mind env indf c in
   let lp=ref (get_constructors env indf).(c).cs_args in
   let lr=ref [] in
@@ -1586,8 +1498,8 @@ and natural_elim ig lh g gs ge arg1 ltree with_intros=
  let ncti= Array.length(get_constructors env indf) in
  let (ind,_) = dest_ind_family indf in
  let (mib,mip) = lookup_mind_specif env ind in
- let ti =(string_of_id mip.mind_typename) in
- let type_arg=targ1 (* List.nth targ (mis_index dmi) *) in
+ let _ti =(string_of_id mip.mind_typename) in
+ let _type_arg=targ1 (* List.nth targ (mis_index dmi) *) in
   spv
          [  (natural_lhyp lh ig.ihsg);
              (show_goal2 lh ig g gs "");
@@ -1630,11 +1542,11 @@ and natural_induction ig lh g gs ge arg2 ltree with_intros=
  let arg1= mkVar arg2 in
  let targ1 = prod_head (type_of env Evd.empty arg1) in
  let IndType (indf,targ) = find_rectype env Evd.empty targ1 in
- let ncti= Array.length(get_constructors env indf) in
+ let _ncti= Array.length(get_constructors env indf) in
  let (ind,_) = dest_ind_family indf in
  let (mib,mip) = lookup_mind_specif env ind in
- let ti =(string_of_id mip.mind_typename) in
- let type_arg= targ1(*List.nth targ (mis_index dmi)*) in
+ let _ti =(string_of_id mip.mind_typename) in
+ let _type_arg= targ1(*List.nth targ (mis_index dmi)*) in
 
  let lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *)
  (* on les enleve des hypotheses des sous-buts *)
@@ -1719,8 +1631,8 @@ and natural_reduce ig lh g gs ge mode la ltree =
 and natural_split ig lh g gs ge la ltree =
   match la with
     [arg] -> 
-      let env= (gLOB ge) in
-      let arg1= (*dbize env*) arg in
+      let _env= (gLOB ge) in
+      let arg1= (*dbize _env*) arg in
       spv
       	[ (natural_lhyp lh ig.ihsg);
           (show_goal2 lh ig g gs ""); 
@@ -1740,9 +1652,9 @@ and natural_split ig lh g gs ge la ltree =
 and natural_generalize ig lh g gs ge la ltree =
   match la with
     [arg] ->
-      let env= (gLOB ge) in
+      let _env= (gLOB ge) in
       let arg1= (*dbize env*) arg in
-      let type_arg=type_of (Global.env()) Evd.empty arg in
+      let _type_arg=type_of (Global.env()) Evd.empty arg in
 (*      let type_arg=type_of_ast ge arg in*)
       spv
       	[ (natural_lhyp lh ig.ihsg);
diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli
index ee269458..9b6787b7 100755
--- a/contrib/interface/showproof.mli
+++ b/contrib/interface/showproof.mli
@@ -4,9 +4,7 @@ open Names
 open Term
 open Util
 open Proof_type
-open Coqast
 open Pfedit
-open Translate
 open Term
 open Reduction
 open Clenv
diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml
index ee901c5e..dd7f455d 100644
--- a/contrib/interface/showproof_ct.ml
+++ b/contrib/interface/showproof_ct.ml
@@ -3,7 +3,6 @@
    Vers Ctcoq
 *)
 
-open Esyntax
 open Metasyntax
 open Printer
 open Pp
@@ -131,12 +130,12 @@ let rec sp_print x =
 	     | "\n" -> fnl ()
 	     | "Retour chariot pour Show proof" -> fnl ()
 	     |_ -> str s)
-     | CT_text_formula  f -> prterm (Hashtbl.find ct_FORMULA_constr f)
+     | CT_text_formula  f -> pr_lconstr (Hashtbl.find ct_FORMULA_constr f)
      | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove");
 		   CT_text_path (CT_signed_int_list p);
 		   CT_coerce_ID_to_TEXT (CT_ident "goal");
 		   g] ->
-      let p=(List.map (fun y -> match y with
+      let _p=(List.map (fun y -> match y with
 	                 (CT_coerce_INT_to_SIGNED_INT
 			      (CT_int x)) -> x
 		       | _ -> raise (Failure "sp_print")) p) in
@@ -149,7 +148,7 @@ let rec sp_print x =
 	      CT_text_path (CT_signed_int_list p);
 	      CT_coerce_ID_to_TEXT (CT_ident hyp);
               g]  ->
-      let p=(List.map (fun y -> match y with
+      let _p=(List.map (fun y -> match y with
 	                  (CT_coerce_INT_to_SIGNED_INT
 			      (CT_int x)) -> x
 		       | _ -> raise (Failure "sp_print")) p) in
@@ -159,7 +158,7 @@ let rec sp_print x =
 	      CT_text_path (CT_signed_int_list p);
 	      CT_coerce_ID_to_TEXT (CT_ident hyp);
               g]  ->
-      let p=(List.map (fun y -> match y with
+      let _p=(List.map (fun y -> match y with
                          (CT_coerce_INT_to_SIGNED_INT
 			      (CT_int x)) -> x
 		       | _ -> raise (Failure "sp_print")) p) in
diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml
index e63baecf..6e4782be 100644
--- a/contrib/interface/translate.ml
+++ b/contrib/interface/translate.ml
@@ -1,13 +1,11 @@
 open Names;;
 open Sign;;
 open Util;;
-open Ast;;
 open Term;;
 open Pp;;
 open Libobject;;
 open Library;;
 open Vernacinterp;;
-open Termast;;
 open Tacmach;;
 open Pfedit;;
 open Parsing;;
@@ -15,97 +13,11 @@ open Evd;;
 open Evarutil;;
 
 open Xlate;;
-open Ctast;;
 open Vtp;;
 open Ascent;;
 open Environ;;
 open Proof_type;;
 
-(* dead code: let rel_reference gt k oper = 
- if is_existential_oper oper then ope("XTRA", [str "ISEVAR"])
- else begin
-  let id = id_of_global oper in
-  let oper', _ = global_operator (Nametab.sp_of_id k id) id in
-  if oper = oper' then nvar (string_of_id id)
-  else failwith "xlate"
-end;;
-*)
-
-(* dead code: 
-let relativize relfun =
- let rec relrec =
-  function
-     | Nvar (_, id) -> nvar id
-     | Slam (l, na, ast) -> Slam (l, na, relrec ast)
-     | Node (loc, nna, l) as ast -> begin
-       try relfun ast
-       with
-       | Failure _ -> Node (loc, nna, List.map relrec l)
-     end
-     | a -> a in
- relrec;;
-*)
-
-(* dead code:
-let dbize_sp =
- function
-    | Path (loc, sl, s) -> begin
-      try section_path sl s
-      with
-      | Invalid_argument _ | Failure _ ->
-      anomaly_loc
-       (loc, "Translate.dbize_sp (taken from Astterm)",
-       [< str "malformed section-path" >])
-    end
-    | ast ->
-     anomaly_loc
-      (Ast.loc ast, "Translate.dbize_sp (taken from Astterm)",
-      [< str "not a section-path" >]);;
-*)
-
-(* dead code:
-let relativize_cci gt = relativize (function
-    | Node (_, "CONST", (p :: _)) as gt ->
-     rel_reference gt CCI (Const (dbize_sp p))
-    | Node (_, "MUTIND", (p :: ((Num (_, tyi)) :: _))) as gt ->
-     rel_reference gt CCI (MutInd (dbize_sp p, tyi))
-    | Node (_, "MUTCONSTRUCT", (p :: ((Num (_, tyi)) :: ((Num (_, i)) :: _)))) as gt ->
-     rel_reference gt CCI (MutConstruct (
-      (dbize_sp p, tyi), i))
-    | _ -> failwith "caught") gt;;
-*)
-
-let coercion_description_holder = ref (function _ -> None : t -> int option);;
-
-let coercion_description t = !coercion_description_holder t;;
-
-let set_coercion_description f =
- coercion_description_holder:=f; ();;
-
-let rec nth_tl l n = if n = 0 then l
- else (match l with
- | a :: b -> nth_tl b (n - 1)
- | [] -> failwith "list too short for nth_tl");;
-
-let rec discard_coercions =
- function
-    | Slam (l, na, ast) -> Slam (l, na, discard_coercions ast)
-    | Node (l, ("APPLIST" as nna), (f :: args as all_sons)) ->
-     (match coercion_description f with
-     | Some n ->
-      let new_args =
-       try nth_tl args n
-       with
-       | Failure "list too short for nth_tl" -> [] in
-      (match new_args with
-       | a :: (b :: c) -> Node (l, nna, List.map discard_coercions new_args)
-       | a :: [] -> discard_coercions a
-       | [] -> Node (l, nna, List.map discard_coercions all_sons))
-     | None -> Node (l, nna, List.map discard_coercions all_sons))
-    | Node (l, nna, all_sons) ->
-     Node (l, nna, List.map discard_coercions all_sons)
-    | it -> it;;
-
 (*translates a formula into a centaur-tree --> FORMULA *)
 let translate_constr at_top env c =
   xlate_formula (Constrextern.extern_constr at_top env c);;
diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc
index 42b5e5ab..4d3dc558 100644
--- a/contrib/interface/vernacrc
+++ b/contrib/interface/vernacrc
@@ -1,4 +1,4 @@
-# $Id: vernacrc,v 1.3 2004/01/14 14:52:59 bertot Exp $
+# $Id: vernacrc 5202 2004-01-14 14:52:59Z bertot $
 
 # This file is loaded initially by ./vernacparser.
 
diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml
index ff418523..166a0cbf 100644
--- a/contrib/interface/vtp.ml
+++ b/contrib/interface/vtp.ml
@@ -112,19 +112,12 @@ and fCOMMAND = function
    fFORMULA x2;
    fINT_LIST x3;
    fNODE "abstraction" 3
-| CT_add_field(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) ->
+| CT_add_field(x1, x2, x3, x4) ->
    fFORMULA x1;
    fFORMULA x2;
    fFORMULA x3;
-   fFORMULA x4;
-   fFORMULA x5;
-   fFORMULA x6;
-   fFORMULA x7;
-   fFORMULA x8;
-   fFORMULA x9;
-   fFORMULA x10;
-   fBINDING_LIST x11;
-   fNODE "add_field" 11
+   fFORMULA_OPT x4;
+   fNODE "add_field" 4
 | CT_add_natural_feature(x1, x2) ->
    fNATURAL_FEATURE x1;
    fID x2;
@@ -407,6 +400,9 @@ and fCOMMAND = function
    fNODE "print_about" 1
 | CT_print_all -> fNODE "print_all" 0
 | CT_print_classes -> fNODE "print_classes" 0
+| CT_print_ltac id ->
+   fID id;
+   fNODE "print_ltac" 1
 | CT_print_coercions -> fNODE "print_coercions" 0
 | CT_print_grammar(x1) ->
    fGRAMMAR x1;
@@ -418,6 +414,9 @@ and fCOMMAND = function
 | CT_print_hintdb(x1) ->
    fID_OR_STAR x1;
    fNODE "print_hintdb" 1
+| CT_print_rewrite_hintdb(x1) ->
+   fID x1;
+   fNODE "print_rewrite_hintdb" 1
 | CT_print_id(x1) ->
    fID x1;
    fNODE "print_id" 1
@@ -451,6 +450,7 @@ and fCOMMAND = function
 | CT_print_scope(x1) ->
    fID x1;
    fNODE "print_scope" 1
+| CT_print_setoids -> fNODE "print_setoids" 0
 | CT_print_scopes -> fNODE "print_scopes" 0
 | CT_print_section(x1) ->
    fID x1;
@@ -1153,12 +1153,12 @@ and fMODULE_TYPE = function
 | CT_coerce_ID_to_MODULE_TYPE x -> fID x
 | CT_module_type_with_def(x1, x2, x3) ->
    fMODULE_TYPE x1;
-   fID x2;
+   fID_LIST x2;
    fFORMULA x3;
    fNODE "module_type_with_def" 3
 | CT_module_type_with_mod(x1, x2, x3) ->
    fMODULE_TYPE x1;
-   fID x2;
+   fID_LIST x2;
    fID x3;
    fNODE "module_type_with_mod" 3
 and fMODULE_TYPE_CHECK = function
@@ -1281,6 +1281,7 @@ and fRED_COM = function
    fPATTERN_NE_LIST x1;
    fNODE "pattern" 1
 | CT_red -> fNODE "red" 0
+| CT_cbvvm -> fNODE "vm_compute" 0
 | CT_simpl(x1) ->
    fPATTERN_OPT x1;
    fNODE "simpl" 1
@@ -1545,6 +1546,12 @@ and fTACTIC_COM = function
 | CT_exact(x1) ->
    fFORMULA x1;
    fNODE "exact" 1
+| CT_exact_no_check(x1) ->
+   fFORMULA x1;
+   fNODE "exact_no_check" 1
+| CT_vm_cast_no_check(x1) ->
+   fFORMULA x1;
+   fNODE "vm_cast_no_check" 1
 | CT_exists(x1) ->
    fSPEC_LIST x1;
    fNODE "exists" 1
@@ -1649,12 +1656,12 @@ and fTACTIC_COM = function
    fID x2;
    fNODE "move_after" 2
 | CT_new_destruct(x1, x2, x3) ->
-   fFORMULA_OR_INT x1;
+   (List.iter fFORMULA_OR_INT x1); (* Julien F. Est-ce correct? *)
    fUSING x2;
    fINTRO_PATT_OPT x3;
    fNODE "new_destruct" 3
 | CT_new_induction(x1, x2, x3) ->
-   fFORMULA_OR_INT x1;
+   (List.iter fFORMULA_OR_INT x1); (* Pierre C. Est-ce correct? *)
    fUSING x2;
    fINTRO_PATT_OPT x3;
    fNODE "new_induction" 3
@@ -1697,19 +1704,21 @@ and fTACTIC_COM = function
 | CT_repeat(x1) ->
    fTACTIC_COM x1;
    fNODE "repeat" 1
-| CT_replace_with(x1, x2) ->
+| CT_replace_with(x1, x2,x3,x4) ->
    fFORMULA x1;
    fFORMULA x2;
-   fNODE "replace_with" 2
+   fCLAUSE x3;
+   fTACTIC_OPT x4;
+   fNODE "replace_with" 4
 | CT_rewrite_lr(x1, x2, x3) ->
    fFORMULA x1;
    fSPEC_LIST x2;
-   fID_OPT x3;
+   fCLAUSE x3;
    fNODE "rewrite_lr" 3
 | CT_rewrite_rl(x1, x2, x3) ->
    fFORMULA x1;
    fSPEC_LIST x2;
-   fID_OPT x3;
+   fCLAUSE x3;
    fNODE "rewrite_rl" 3
 | CT_right(x1) ->
    fSPEC_LIST x1;
diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml
index 02dc57de..60195229 100644
--- a/contrib/interface/xlate.ml
+++ b/contrib/interface/xlate.ml
@@ -3,7 +3,6 @@
 open String;;
 open Char;;
 open Util;;
-open Ast;;
 open Names;;
 open Ascent;;
 open Genarg;;
@@ -64,11 +63,7 @@ let coercion_description t = !coercion_description_holder t;;
 let set_coercion_description f =
  coercion_description_holder:=f; ();;
 
-let string_of_node_loc the_node =
-  match Util.unloc (loc the_node) with
-      (a,b) -> "(" ^ (string_of_int a) ^ ", " ^ (string_of_int b) ^ ")";;
-
-let xlate_error s = failwith ("Translation error: " ^ s);;
+let xlate_error s = print_endline ("xlate_error : "^s);failwith ("Translation error: " ^ s);;
 
 let ctf_STRING_OPT_NONE = CT_coerce_NONE_to_STRING_OPT CT_none;;
 
@@ -118,8 +113,16 @@ let nums_to_int_list_aux l = List.map (fun x -> CT_int x) l;;
 
 let nums_to_int_list l =  CT_int_list(nums_to_int_list_aux l);;
 
-let nums_to_int_ne_list n l =
-  CT_int_ne_list(CT_int n, nums_to_int_list_aux l);;
+let num_or_var_to_int = function
+  | ArgArg x -> CT_int x
+  | _ -> xlate_error "TODO: nums_to_int_list_aux ArgVar";;
+
+let nums_or_var_to_int_list_aux l = List.map num_or_var_to_int l;;
+
+let nums_or_var_to_int_list l = CT_int_list(nums_or_var_to_int_list_aux l);;
+
+let nums_or_var_to_int_ne_list n l =
+  CT_int_ne_list(num_or_var_to_int n, nums_or_var_to_int_list_aux l);;
 
 type iTARG =   Targ_command of ct_FORMULA
              | Targ_intropatt of ct_INTRO_PATT_LIST
@@ -266,11 +269,13 @@ let rec xlate_match_pattern =
     | CPatAlias  (_,  pattern, id) ->
      CT_pattern_as
       (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id))
+    | CPatOr (_,l) -> xlate_error "CPatOr: TODO"
     | CPatDelimiters(_, key, p) -> 
 	CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p)
-    | CPatNumeral(_,n) ->
+    | CPatPrim (_,Numeral n) ->
  	CT_coerce_NUM_to_MATCH_PATTERN
-	  (CT_int_encapsulator(Bignat.bigint_to_string n))
+	  (CT_int_encapsulator(Bigint.to_string n))
+    | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO"
     | CPatNotation(_, s, l) -> 
 	CT_pattern_notation(CT_string s,
 			    CT_match_pattern_list(List.map xlate_match_pattern l))
@@ -301,9 +306,11 @@ let rec decompose_last = function
 let make_fix_struct (n,bl) =
   let names = names_of_local_assums bl in
   let nn = List.length names in
-  if nn = 1 then ctv_ID_OPT_NONE
-  else if n < nn then xlate_id_opt(List.nth names n)
-  else xlate_error "unexpected result of parsing for Fixpoint";;
+  if nn = 1 || n = None then ctv_ID_OPT_NONE
+  else 
+    let n = out_some n in 
+    if n < nn then xlate_id_opt(List.nth names n)
+    else xlate_error "unexpected result of parsing for Fixpoint";;
 
 
 let rec xlate_binder = function
@@ -329,8 +336,8 @@ and
   | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, 
                                      List.map xlate_match_pattern l)
 and  translate_one_equation = function
-    (_,lp, a) -> CT_eqn ( xlate_match_pattern_ne_list lp,
-	     xlate_formula a)
+    (_,[lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a)
+  | _ -> xlate_error "TODO: disjunctive multiple patterns"
 and 
   xlate_binder_ne_list = function
     [] -> assert false
@@ -373,14 +380,11 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
    | CApp(_, (_,f), l) -> 
        CT_appc(xlate_formula f, xlate_formula_expl_ne_list l)
    | CCases (_, _, [], _) -> assert false
-   | CCases (_, (Some _, _), _, _) -> xlate_error "NOT parsed: Cases with Some"
-   | CCases (_,(None, ret_type), tm::tml, eqns)->
+   | CCases (_, ret_type, tm::tml, eqns)->
        CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm,
 					   List.map xlate_matched_formula tml),
 		xlate_formula_opt ret_type,
                 CT_eqn_list (List.map (fun x -> translate_one_equation x) eqns))
-   | COrderedCase (_,Term.IfStyle,po,c,[b1;b2]) -> 
-       xlate_error "No more COrderedCase"
    | CLetTuple (_,a::l, ret_info, c, b) -> 
       CT_let_tuple(CT_id_opt_ne_list(xlate_id_opt_aux a,
 				     List.map xlate_id_opt_aux l),
@@ -393,27 +397,18 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
 	 (xlate_formula c, xlate_return_info ret_info,
 	  xlate_formula b1, xlate_formula b2)
 
-   | COrderedCase (_,Term.LetStyle, po, c, [CLambdaN(_,[l,_],b)]) ->
-       CT_inductive_let(xlate_formula_opt po,
-	       xlate_id_opt_ne_list l,
-	       xlate_formula c, xlate_formula b) 
-   | COrderedCase (_,c,v,e,l) -> 
-       let case_string = match c with
-	   Term.MatchStyle -> "Match"
-	 | _ -> "Case" in
-	 CT_elimc(CT_case "Case", xlate_formula_opt v, xlate_formula e,
-		  CT_formula_list(List.map xlate_formula l))
    | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s)
    | CNotation(_, s, l) -> notation_to_formula s (List.map xlate_formula l)
-   | CNumeral(_, i) -> 
-       CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bignat.bigint_to_string i))
+   | CPrim (_, Numeral i) -> 
+       CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i))
+   | CPrim (_, String _) -> xlate_error "CPrim (String): TODO"
    | CHole _ -> CT_existvarc 
 (* I assume CDynamic has been inserted to make free form extension of
    the language possible, but this would go agains the logic of pcoq anyway. *)
    | CDynamic (_, _) -> assert false
    | CDelimiters (_, key, num) -> 
 	 CT_num_encapsulator(CT_num_type key , xlate_formula  num)
-   | CCast (_, e, t) -> 
+   | CCast (_, e,_, t) -> 
        CT_coerce_TYPED_FORMULA_to_FORMULA
 	 (CT_typed_formula(xlate_formula e, xlate_formula t))
    | CPatVar (_, (_,i)) when is_int_meta i ->
@@ -430,11 +425,13 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
         CT_cofixc(xlate_ident id,
 	  (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)))
    | CFix (_, (_, id), lm::lmi) ->       
-     let strip_mutrec (fid, n, bl, arf, ardef) =
+     let strip_mutrec (fid, (n, ro), bl, arf, ardef) =
         let (struct_arg,bl,arf,ardef) =
+	 (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *)
+	 (* By the way, how could [bl = []] happen in V8 syntax ?  *)
          if bl = [] then
+	   let n = out_some n in 
            let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in
-           let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in
            (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef)
          else (make_fix_struct (n, bl),bl,arf,ardef) in
         let arf = xlate_formula arf in
@@ -485,20 +482,23 @@ let xlate_hyp = function
 
 let xlate_hyp_location =
  function
-  | AI (_,id), nums, (InHypTypeOnly,_) ->
-      CT_intype(xlate_ident id, nums_to_int_list nums)
-  | AI (_,id), nums, (InHypValueOnly,_) ->
-      CT_invalue(xlate_ident id, nums_to_int_list nums)
-  | AI (_,id), [], (InHyp,_) ->
+  | (nums, AI (_,id)), InHypTypeOnly ->
+      CT_intype(xlate_ident id, nums_or_var_to_int_list nums)
+  | (nums, AI (_,id)), InHypValueOnly ->
+      CT_invalue(xlate_ident id, nums_or_var_to_int_list nums)
+  | ([], AI (_,id)), InHyp ->
       CT_coerce_UNFOLD_to_HYP_LOCATION 
 	(CT_coerce_ID_to_UNFOLD (xlate_ident id))
-  | AI (_,id), a::l, (InHyp,_) ->
+  | (a::l, AI (_,id)), InHyp ->
       CT_coerce_UNFOLD_to_HYP_LOCATION 
 	(CT_unfold_occ (xlate_ident id, 
-			CT_int_ne_list(CT_int a, nums_to_int_list_aux l)))
-  | MetaId _, _,_ -> 
+			CT_int_ne_list(num_or_var_to_int a, 
+                                       nums_or_var_to_int_list_aux l)))
+  | (_, MetaId _),_ -> 
       xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)"
 
+
+
 let xlate_clause cls =
   let hyps_info =
     match cls.onhyps with
@@ -631,6 +631,7 @@ let rec xlate_intro_pattern =
 	   ll)
   | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" )
   | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c)
+  | IntroAnonymous -> xlate_error "TODO: IntroAnonymous"
 
 let compute_INV_TYPE = function
    FullInversionClear -> CT_inv_clear
@@ -676,11 +677,14 @@ let xlate_using = function
 let xlate_one_unfold_block = function
     ([],qid) -> CT_coerce_ID_to_UNFOLD(tac_qualid_to_ct_ID qid)
   | (n::nums, qid) ->
-      CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_to_int_ne_list n nums);;
+      CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_or_var_to_int_ne_list n nums)
+;;
+
+let xlate_with_names = function
+    IntroAnonymous -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE
+  | fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp)
 
-let xlate_intro_patt_opt = function
-    None -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE
-  | Some fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp)
+let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level
 
 let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) =
   function
@@ -722,20 +726,23 @@ and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) =
     | Reference (Ident (_,s)) -> ident_tac s
     | ConstrMayEval(ConstrTerm a) ->
 	CT_formula_marker(xlate_formula a)
-    | TacFreshId s -> CT_fresh(ctf_STRING_OPT s)
+    | TacFreshId [] -> CT_fresh(ctf_STRING_OPT None)
+    | TacFreshId [ArgArg s] -> CT_fresh(ctf_STRING_OPT (Some s))
+    | TacFreshId _ -> xlate_error "TODO: fresh with many args"
     | t -> xlate_error "TODO LATER: result other than tactic or constr"
 
 and xlate_red_tactic =
  function
   | Red true -> xlate_error ""
   | Red false -> CT_red
+  | CbvVm -> CT_cbvvm
   | Hnf -> CT_hnf
   | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE
   | Simpl (Some (l,c)) -> 
       CT_simpl 
 	(CT_coerce_PATTERN_to_PATTERN_OPT
 	   (CT_pattern_occ
-	      (CT_int_list(List.map (fun n -> CT_int n) l), xlate_formula c)))
+	      (CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c)))
   | Cbv flag_list ->
      let conv_flags, red_ids = get_flag flag_list in
      CT_cbv (CT_conversion_flag_list conv_flags, red_ids)
@@ -752,7 +759,7 @@ and xlate_red_tactic =
   | Pattern l ->
      let pat_list = List.map (fun (nums,c) ->
           CT_pattern_occ
-           (CT_int_list (List.map (fun x -> CT_int x) nums),
+           (CT_int_list (nums_or_var_to_int_list_aux nums),
             xlate_formula c)) l in
      (match pat_list with
       | first :: others -> CT_pattern (CT_pattern_ne_list (first, others))
@@ -788,6 +795,7 @@ and xlate_tactic =
    | TacFirst(t1::l)-> CT_first(xlate_tactic t1, List.map xlate_tactic l)
    | TacSolve([]) -> assert false
    | TacSolve(t1::l)-> CT_tacsolve(xlate_tactic t1, List.map xlate_tactic l)
+   | TacComplete _ -> xlate_error "TODO: tactical complete"
    | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t)
    | TacTry t -> CT_try (xlate_tactic t)
    | TacRepeat t -> CT_repeat(xlate_tactic t)
@@ -798,7 +806,8 @@ and xlate_tactic =
 		   xlate_tactic t)
    | TacProgress t -> CT_progress(xlate_tactic t)
    | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2)
-   | TacMatch (exp, rules) ->
+   | TacMatch (true,_,_) -> failwith "TODO: lazy match"
+   | TacMatch (false, exp, rules) ->
         CT_match_tac(xlate_tactic exp,
                      match List.map 
                        (function 
@@ -814,11 +823,11 @@ and xlate_tactic =
                          | [] -> assert false
                          | fst::others ->
                              CT_match_tac_rules(fst, others))
-   | TacMatchContext (_,[]) -> failwith ""
-   | TacMatchContext (false,rule1::rules) ->
+   | TacMatchContext (_,_,[]) | TacMatchContext (true,_,_) -> failwith ""
+   | TacMatchContext (false,false,rule1::rules) ->
          CT_match_context(xlate_context_rule rule1,
                           List.map xlate_context_rule rules)
-   | TacMatchContext (true,rule1::rules) ->
+   | TacMatchContext (false,true,rule1::rules) ->
          CT_match_context_reverse(xlate_context_rule rule1,
                           List.map xlate_context_rule rules)
    | TacLetIn (l, t) ->
@@ -855,18 +864,23 @@ and xlate_tactic =
 		   (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in
        CT_rec_tactic_in(tl, xlate_tactic t)
    | TacAtom (_, t) -> xlate_tac t 
-   | TacFail (count, "") -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE)
-   | TacFail (count, s) -> CT_fail(xlate_id_or_int count,
+   | TacFail (count, []) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE)
+   | TacFail (count, [MsgString s]) -> CT_fail(xlate_id_or_int count,
 				   ctf_STRING_OPT_SOME (CT_string s))
-   | TacId "" -> CT_idtac ctf_STRING_OPT_NONE
-   | TacId s -> CT_idtac(ctf_STRING_OPT_SOME (CT_string s))
+   | TacFail (count, _) -> xlate_error "TODO: generic fail message"
+   | TacId [] -> CT_idtac ctf_STRING_OPT_NONE
+   | TacId [MsgString s] -> CT_idtac(ctf_STRING_OPT_SOME (CT_string s))
+   | TacId _ -> xlate_error "TODO: generic idtac message"
    | TacInfo t -> CT_info(xlate_tactic t)
    | TacArg a -> xlate_call_or_tacarg a
 
 and xlate_tac =
   function
     | TacExtend (_, "firstorder", tac_opt::l) ->
-       let t1 = match out_gen (wit_opt rawwit_tactic) tac_opt with
+       let t1 =
+	 match
+	   out_gen (wit_opt rawwit_main_tactic) tac_opt
+	 with
 	 | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none
 	 | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in
 	 (match l with
@@ -903,7 +917,7 @@ and xlate_tac =
     | TacChange (Some(l,c), f, b) -> 
 	(* TODO LATER: combine with other constructions of pattern_occ *)
 	CT_change_local(
-	  CT_pattern_occ(CT_int_list(List.map (fun n -> CT_int n) l), 
+	  CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), 
 			 xlate_formula c),
 	  xlate_formula f,
 	  xlate_clause b)
@@ -914,7 +928,7 @@ and xlate_tac =
      CT_discriminate_eq
          (xlate_quantified_hypothesis_opt
 	    (out_gen (wit_opt rawwit_quant_hyp) idopt))
-    | TacExtend (_,"deq", [idopt]) ->
+    | TacExtend (_,"simplify_eq", [idopt]) ->
 	let idopt1 = out_gen (wit_opt rawwit_quant_hyp) idopt in
 	let idopt2 = match idopt1 with
 	    None -> CT_coerce_ID_OPT_to_ID_OR_INT_OPT
@@ -927,6 +941,8 @@ and xlate_tac =
      CT_injection_eq
          (xlate_quantified_hypothesis_opt
 	    (out_gen (wit_opt rawwit_quant_hyp) idopt))
+    | TacExtend (_,"injection_as", [idopt;ipat]) ->
+	xlate_error "TODO: injection as"
     | TacFix (idopt, n) ->
      CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list [])
     | TacMutualFix (id, n, fixtac_list) ->
@@ -962,53 +978,75 @@ and xlate_tac =
     | TacRight bindl -> CT_right (xlate_bindings bindl)
     | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl)
     | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl)
-    | TacExtend (_,"replace", [c1; c2]) ->
-     let c1 = xlate_formula (out_gen rawwit_constr c1) in
-     let c2 = xlate_formula (out_gen rawwit_constr c2) in
-     CT_replace_with (c1, c2)
-    | TacExtend (_,"rewrite", [b; cbindl]) ->
-     let b = out_gen Extraargs.rawwit_orient b in
-     let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
-     let c = xlate_formula c and bindl = xlate_bindings bindl in
-     if b then CT_rewrite_lr (c, bindl, ctv_ID_OPT_NONE)
-     else CT_rewrite_rl (c, bindl, ctv_ID_OPT_NONE)
-    | TacExtend (_,"rewritein", [b; cbindl; id]) ->
-     let b = out_gen Extraargs.rawwit_orient b in
-     let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
-     let c = xlate_formula c and bindl = xlate_bindings bindl in
-     let id = ctf_ID_OPT_SOME (xlate_ident (out_gen rawwit_ident id)) in
-     if b then CT_rewrite_lr (c, bindl, id)
-     else CT_rewrite_rl (c, bindl, id)
-    | TacExtend (_,"conditionalrewrite", [t; b; cbindl]) ->
-     let t = out_gen rawwit_tactic t in
+    | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) ->
+	let c1 = xlate_formula (out_gen rawwit_constr c1) in
+	let c2 = xlate_formula (out_gen rawwit_constr c2) in
+	let cl = 
+	  (* J.F. : 18/08/2006 
+	     Hack to coerce the "clause" argument of replace to a real clause 
+	     To be remove if we can reuse the clause grammar entrie defined in g_tactic
+	  *)
+	  let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in 
+	  let cl_as_xlate_arg = 
+	    {cl_as_clause with 
+	       Tacexpr.onhyps = 
+		option_map 
+		  (fun l -> 
+		     List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l
+		  )
+		  cl_as_clause.Tacexpr.onhyps
+	    }
+	  in
+	  cl_as_xlate_arg
+	in 
+	let cl = xlate_clause cl in 
+	let tac_opt = 
+	  match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with
+	    | None -> CT_coerce_NONE_to_TACTIC_OPT  CT_none
+	    | Some tac ->
+		let tac =  xlate_tactic tac in
+		CT_coerce_TACTIC_COM_to_TACTIC_OPT tac
+	in 
+	CT_replace_with (c1, c2,cl,tac_opt)
+    | TacRewrite(b,cbindl,cl) -> 
+     let cl = xlate_clause cl 
+     and c = xlate_formula (fst cbindl) 
+     and bindl = xlate_bindings (snd cbindl) in
+     if b then CT_rewrite_lr (c, bindl, cl)
+     else CT_rewrite_rl (c, bindl, cl)
+    | TacExtend (_,"conditional_rewrite", [t; b; cbindl]) ->
+     let t = out_gen rawwit_main_tactic t in
      let b = out_gen Extraargs.rawwit_orient b in
      let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
      let c = xlate_formula c and bindl = xlate_bindings bindl in
      if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE)
      else CT_condrewrite_rl (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE)
-    | TacExtend (_,"conditionalrewritein", [t; b; cbindl; id]) ->
-     let t = out_gen rawwit_tactic t in
+    | TacExtend (_,"conditional_rewrite", [t; b; cbindl; id]) ->
+     let t = out_gen rawwit_main_tactic t in
      let b = out_gen Extraargs.rawwit_orient b in
      let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
      let c = xlate_formula c and bindl = xlate_bindings bindl in
-     let id = ctf_ID_OPT_SOME (xlate_ident (out_gen rawwit_ident id)) in
+     let id = ctf_ID_OPT_SOME (xlate_ident (snd (out_gen rawwit_var id))) in
      if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, id)
      else CT_condrewrite_rl (xlate_tactic t, c, bindl, id)
-    | TacExtend (_,"dependentrewrite", [b; id_or_constr]) ->
+    | TacExtend (_,"dependent_rewrite", [b; c]) ->
       let b = out_gen Extraargs.rawwit_orient b in
-      (match genarg_tag id_or_constr with
-	| IdentArgType -> (*Dependent Rewrite/SubstHypInConcl*)
-	    let id = xlate_ident (out_gen rawwit_ident id_or_constr) in
+      let c = xlate_formula (out_gen rawwit_constr c) in
+      (match c with
+	| CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> 
 	    if b then CT_deprewrite_lr id else CT_deprewrite_rl id
-	| ConstrArgType -> (*CutRewrite/SubstConcl*)
-	    let c = xlate_formula (out_gen rawwit_constr id_or_constr) in
-	    if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE)
-	    else CT_cutrewrite_rl (c, ctv_ID_OPT_NONE)
-	| _ -> xlate_error "")
-    | TacExtend (_,"dependentrewrite", [b; c; id]) -> (*CutRewrite in/SubstHyp*)
+	| _ -> xlate_error "dependent rewrite on term: not supported")
+    | TacExtend (_,"dependent_rewrite", [b; c; id]) ->
+	xlate_error "dependent rewrite on terms in hypothesis: not supported"
+    | TacExtend (_,"cut_rewrite", [b; c]) ->
+      let b = out_gen Extraargs.rawwit_orient b in
+      let c = xlate_formula (out_gen rawwit_constr c) in
+      if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE)
+      else CT_cutrewrite_lr (c, ctv_ID_OPT_NONE)
+    | TacExtend (_,"cut_rewrite", [b; c; id]) ->
       let b = out_gen Extraargs.rawwit_orient b in
       let c = xlate_formula (out_gen rawwit_constr c) in
-      let id = xlate_ident (out_gen rawwit_ident id) in
+      let id = xlate_ident (snd (out_gen rawwit_var id)) in
       if b then CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id)
       else CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id)
     | TacExtend(_, "subst", [l]) ->
@@ -1021,6 +1059,8 @@ and xlate_tac =
     | TacTransitivity c -> CT_transitivity (xlate_formula c)
     | TacAssumption -> CT_assumption
     | TacExact c -> CT_exact (xlate_formula c)
+    | TacExactNoCheck c -> CT_exact_no_check (xlate_formula c)
+    | TacVmCastNoCheck c -> CT_vm_cast_no_check (xlate_formula c)
     | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id)
     | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id)
     | TacDestructConcl -> CT_dconcl
@@ -1031,14 +1071,16 @@ and xlate_tac =
         (if a3 then CT_destructing else CT_coerce_NONE_to_DESTRUCTING CT_none),
         (if a4 then CT_usingtdb else CT_coerce_NONE_to_USINGTDB CT_none))
     | TacAutoTDB nopt -> CT_autotdb (xlate_int_opt nopt)
-    | TacAuto (nopt, Some []) -> CT_auto (xlate_int_or_var_opt_to_int_opt nopt)
-    | TacAuto (nopt, None) ->
+    | TacAuto (nopt, [], Some []) -> CT_auto (xlate_int_or_var_opt_to_int_opt nopt)
+    | TacAuto (nopt, [], None) ->
  	CT_auto_with (xlate_int_or_var_opt_to_int_opt nopt,
 		      CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
-    | TacAuto (nopt, Some (id1::idl)) ->
+    | TacAuto (nopt, [], Some (id1::idl)) ->
 	CT_auto_with(xlate_int_or_var_opt_to_int_opt nopt,
              CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR(
              CT_id_ne_list(CT_ident id1, List.map (fun x -> CT_ident x) idl)))
+    | TacAuto (nopt, _::_, _) ->
+	xlate_error "TODO: auto using"
     |TacExtend(_, ("autorewritev7"|"autorewritev8"), l::t) ->
        let (id_list:ct_ID list) =
 	 List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l) in
@@ -1048,21 +1090,25 @@ and xlate_tac =
 	 match t with
 	     [t0] -> 
 	       CT_coerce_TACTIC_COM_to_TACTIC_OPT
-		 (xlate_tactic(out_gen rawwit_tactic t0))
+	       (xlate_tactic(out_gen rawwit_main_tactic t0))
 	   | [] -> CT_coerce_NONE_to_TACTIC_OPT CT_none
 	   | _ -> assert false in
 	 CT_autorewrite (CT_id_ne_list(fst, id_list1), t1)
-    | TacExtend (_,"eauto", [nopt; popt; idl]) ->
+    | TacExtend (_,"eauto", [nopt; popt; lems; idl]) ->
 	let first_n =
 	  match out_gen (wit_opt rawwit_int_or_var) nopt with
 	    | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s
-	    | Some ArgArg n -> xlate_int_to_id_or_int_opt n
+	    | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n
 	    | None -> none_in_id_or_int_opt in
 	let second_n =
 	  match out_gen (wit_opt rawwit_int_or_var) popt with
 	    | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s
-	    | Some ArgArg n -> xlate_int_to_id_or_int_opt n
+	    | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n
 	    | None -> none_in_id_or_int_opt in
+	let _lems =
+	  match out_gen Eauto.rawwit_auto_using lems with
+	    | [] -> []
+	    | _ -> xlate_error "TODO: eauto using" in
 	let idl = out_gen Eauto.rawwit_hintbases idl in
           (match idl with
 	    None -> CT_eauto_with(first_n,
@@ -1077,19 +1123,21 @@ and xlate_tac =
 				  List.map (fun x -> CT_ident x) l))))
     | TacExtend (_,"prolog", [cl; n]) ->
       let cl = List.map xlate_formula (out_gen (wit_list0 rawwit_constr) cl) in
-      (match out_gen wit_int_or_var n with
+      (match out_gen rawwit_int_or_var n with
 	| ArgVar _ -> xlate_error ""
 	| ArgArg n -> CT_prolog (CT_formula_list cl, CT_int  n))
     | TacExtend (_,"eapply", [cbindl]) ->
      let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
      let c = xlate_formula c and bindl = xlate_bindings bindl in
      CT_eapply (c, bindl)
-    | TacTrivial (Some []) -> CT_trivial
-    | TacTrivial None -> 
+    | TacTrivial ([],Some []) -> CT_trivial
+    | TacTrivial ([],None) -> 
 	CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
-    | TacTrivial (Some (id1::idl)) ->
+    | TacTrivial ([],Some (id1::idl)) ->
 	 CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR(
             (CT_id_ne_list(CT_ident id1,List.map (fun x -> CT_ident x) idl))))
+    | TacTrivial (_::_,_) ->
+	xlate_error "TODO: trivial using"
     | TacReduce (red, l) ->
      CT_reduce (xlate_red_tactic red, xlate_clause l)
     | TacApply (c,bindl) ->
@@ -1111,7 +1159,7 @@ and xlate_tac =
      CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u)
     | TacCase (c1,sl) ->
      CT_casetac (xlate_formula c1, xlate_bindings sl)
-    | TacSimpleInduction (h,_) -> CT_induction (xlate_quantified_hypothesis h)
+    | TacSimpleInduction h -> CT_induction (xlate_quantified_hypothesis h)
     | TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h)
     | TacCut c -> CT_cut (xlate_formula c)
     | TacLApply c -> CT_use (xlate_formula c)
@@ -1123,20 +1171,21 @@ and xlate_tac =
         CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c)
     | TacDecomposeAnd c -> CT_decompose_record (xlate_formula c)
     | TacDecomposeOr c -> CT_decompose_sum(xlate_formula c)
-    | TacClear [] ->
+    | TacClear (false,[]) ->
 	xlate_error "Clear expects a non empty list of identifiers"
-    | TacClear (id::idl) ->
+    | TacClear (false,id::idl) ->
        let idl' = List.map xlate_hyp idl in
        CT_clear (CT_id_ne_list (xlate_hyp id, idl'))
+    | TacClear (true,_) -> xlate_error "TODO: 'clear - idl' and 'clear'"
     | (*For translating tactics/Inv.v *)
       TacInversion (NonDepInversion (k,idl,l),quant_hyp) ->
 	CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp,
-		     xlate_intro_patt_opt l,
+		     xlate_with_names l,
 	             CT_id_list (List.map xlate_hyp idl))
     | TacInversion (DepInversion (k,copt,l),quant_hyp) ->
 	let id = xlate_quantified_hypothesis quant_hyp in
 	CT_depinversion (compute_INV_TYPE k, id, 
-			 xlate_intro_patt_opt l, xlate_formula_opt copt)
+			 xlate_with_names l, xlate_formula_opt copt)
     | TacInversion (InversionUsing (c,idlist), id) ->
 	let id = xlate_quantified_hypothesis id in
 	  CT_use_inversion (id, xlate_formula c,
@@ -1148,28 +1197,34 @@ and xlate_tac =
 	CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l))
     | TacDAuto (a, b) ->
 	CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b)
-    | TacNewDestruct(a,b,(c,_)) ->
-	CT_new_destruct
-	  (xlate_int_or_constr a, xlate_using b, 
-	   xlate_intro_patt_opt c)
-    | TacNewInduction(a,b,(c,_)) ->
-	CT_new_induction
-	  (xlate_int_or_constr a, xlate_using b,
-	   xlate_intro_patt_opt c)
-    | TacInstantiate (a, b, cl) -> 
+    | TacNewDestruct(a,b,c) ->
+	CT_new_destruct (* Julien F. : est-ce correct *)
+	  (List.map  xlate_int_or_constr a, xlate_using b, 
+	   xlate_with_names c)
+    | TacNewInduction(a,b,c) ->
+	CT_new_induction (* Pierre C. : est-ce correct *)
+	  (List.map xlate_int_or_constr a, xlate_using b,
+	   xlate_with_names c)
+    (*| TacInstantiate (a, b, cl) -> 
         CT_instantiate(CT_int a, xlate_formula b,
-		       xlate_clause cl)
+		       assert false) *)
+    | TacLetTac (na, c, cl) when cl = nowhere -> 
+        CT_pose(xlate_id_opt_aux na, xlate_formula c)
     | TacLetTac (na, c, cl) ->
         CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, 
 		  (* TODO LATER: This should be shared with Unfold,
 		     but the structures are different *)
 		  xlate_clause cl)
-    | TacForward (true, name, c) -> 
-               CT_pose(xlate_id_opt_aux name, xlate_formula c)
-    | TacForward (false, name, c) -> 
-               CT_assert(xlate_id_opt ((0,0),name), xlate_formula c)
-    | TacTrueCut (na, c) -> 
-        CT_truecut(xlate_id_opt ((0,0),na), xlate_formula c)
+    | TacAssert (None, IntroIdentifier id, c) -> 
+        CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c)
+    | TacAssert (None, IntroAnonymous, c) -> 
+        CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c)
+    | TacAssert (Some (TacId []), IntroIdentifier id, c) -> 
+        CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c)
+    | TacAssert (Some (TacId []), IntroAnonymous, c) -> 
+        CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c)
+    | TacAssert _ ->
+	xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'"
     | TacAnyConstructor(Some tac) -> 
 	CT_any_constructor
 	(CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac))
@@ -1181,6 +1236,7 @@ and xlate_tac =
 	     (List.map xlate_formula
 		(out_gen (wit_list0 rawwit_constr) args)))
     | TacExtend (_,id, l) ->
+	print_endline ("Extratactics : "^ id);
      CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l))
     | TacAlias _ -> xlate_error "Alias not supported"
 
@@ -1216,8 +1272,11 @@ and coerce_genarg_to_TARG x =
 	CT_coerce_FORMULA_OR_INT_to_TARG
 	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
 	     (CT_coerce_ID_to_ID_OR_INT id))
-  | HypArgType ->
-      xlate_error "TODO (similar to IdentArgType)"
+  | VarArgType ->
+      let id = xlate_ident (snd (out_gen rawwit_var x)) in
+	CT_coerce_FORMULA_OR_INT_to_TARG
+	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
+	     (CT_coerce_ID_to_ID_OR_INT id))
   | RefArgType ->
       let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in
 	CT_coerce_FORMULA_OR_INT_to_TARG
@@ -1233,19 +1292,15 @@ and coerce_genarg_to_TARG x =
       (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x)))
   | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument"
   | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument"
-  | TacticArgType ->
-      let t = xlate_tactic (out_gen rawwit_tactic x) in
-      CT_coerce_TACTIC_COM_to_TARG t
-  | OpenConstrArgType ->
+  | OpenConstrArgType b -> 
       CT_coerce_SCOMMENT_CONTENT_to_TARG
       	(CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula
-						 (snd (out_gen
-						    rawwit_open_constr x))))
-  | CastedOpenConstrArgType -> 
-      CT_coerce_SCOMMENT_CONTENT_to_TARG
-      	(CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula
-						 (snd (out_gen
-						    rawwit_casted_open_constr x))))
+					 (snd (out_gen
+					    (rawwit_open_constr_gen b) x))))
+  | ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
+      let n = out_some (Pcoq.tactic_genarg_level s) in
+      let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in
+      CT_coerce_TACTIC_COM_to_TARG t
   | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings"
   | BindingsArgType -> xlate_error "TODO: generic with bindings"
   | RedExprArgType -> xlate_error "TODO: generic red expr"
@@ -1315,8 +1370,11 @@ let coerce_genarg_to_VARG x =
       CT_coerce_ID_OPT_OR_ALL_to_VARG
 	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
 	        (CT_coerce_ID_to_ID_OPT id))
-  | HypArgType ->
-      xlate_error "TODO (similar to IdentArgType)"
+  | VarArgType ->
+      let id = xlate_ident (snd (out_gen rawwit_var x)) in
+      CT_coerce_ID_OPT_OR_ALL_to_VARG
+	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
+	        (CT_coerce_ID_to_ID_OPT id))
   | RefArgType ->
       let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in
       CT_coerce_ID_OPT_OR_ALL_to_VARG
@@ -1332,11 +1390,11 @@ let coerce_genarg_to_VARG x =
       (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x)))
   | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument"
   | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument"
-  | TacticArgType ->
-      let t = xlate_tactic (out_gen rawwit_tactic x) in
+  | ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
+      let n = out_some (Pcoq.tactic_genarg_level s) in
+      let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in
       CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t)
-  | OpenConstrArgType -> xlate_error "TODO: generic open constr"
-  | CastedOpenConstrArgType -> xlate_error "TODO: generic open constr"
+  | OpenConstrArgType _ -> xlate_error "TODO: generic open constr"
   | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings"
   | BindingsArgType -> xlate_error "TODO: generic with bindings"
   | RedExprArgType -> xlate_error "TODO: red expr as generic argument"
@@ -1347,23 +1405,9 @@ let coerce_genarg_to_VARG x =
   | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments"
 
 
-let xlate_thm x = CT_thm (match x with
-  | Theorem -> "Theorem"
-  | Remark -> "Remark"
-  | Lemma -> "Lemma"
-  | Fact -> "Fact")
+let xlate_thm x = CT_thm (string_of_theorem_kind x)
 
-
-let xlate_defn x = CT_defn (match x with
- | (Local, Definition) -> "Local"
- | (Global, Definition) -> "Definition"
- | (Global, SubClass) -> "SubClass"
- | (Global, Coercion) -> "Coercion"
- | (Local, SubClass) -> "Local SubClass"
- | (Local, Coercion) -> "Local Coercion"
- | (Global,CanonicalStructure) -> "Canonical Structure"
- | (Local, CanonicalStructure) -> 
-     xlate_error "Local CanonicalStructure not parsed")
+let xlate_defn k = CT_defn (string_of_definition_kind k)
 
 let xlate_var x = CT_var (match x with
  | (Global,Definitional) -> "Parameter"
@@ -1511,17 +1555,18 @@ let rec xlate_module_type = function
   | CMTEwith(mty, decl) ->
       let mty1 = xlate_module_type mty in
 	(match decl with
-	     CWith_Definition((_, id), c) ->
-	       CT_module_type_with_def(xlate_module_type mty, 
-				       xlate_ident id, xlate_formula c)
-	   | CWith_Module((_, id), (_, qid)) ->
-	       CT_module_type_with_mod(xlate_module_type mty,
-				       xlate_ident id, 
+	     CWith_Definition((_, idl), c) ->
+	       CT_module_type_with_def(mty1, 
+				       CT_id_list (List.map xlate_ident idl),
+                                       xlate_formula c)
+	   | CWith_Module((_, idl), (_, qid)) ->
+	       CT_module_type_with_mod(mty1,
+				       CT_id_list (List.map xlate_ident idl), 
 				       CT_ident (xlate_qualid qid)));;
 
 let xlate_module_binder_list (l:module_binder list) =
   CT_module_binder_list
-    (List.map (fun (idl, mty) ->
+    (List.map (fun (_, idl, mty) ->
 		 let idl1 = 
 		   List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in
 		 let fst,idl2 = match idl1 with
@@ -1601,6 +1646,15 @@ let rec xlate_vernac =
 	CT_solve (CT_int n, xlate_tactic tac,
 		  if b then CT_dotdot
                   else CT_coerce_NONE_to_DOTDOT_OPT CT_none)
+
+(* MMode *)
+
+    | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> 
+	anomaly "No MMode in CTcoq"
+
+
+(* /MMode *)
+
     | VernacFocus nopt -> CT_focus (xlate_int_opt nopt)
     | VernacUnfocus -> CT_unfocus
     |VernacExtend("Extraction", [f;l]) ->
@@ -1621,40 +1675,22 @@ let rec xlate_vernac =
 	CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst,
 				List.map loc_qualid_to_ct_ID l2))
     | VernacExtend("Field", 
-		   [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl;minusdiv]) ->
+		   [fth;ainv;ainvl;div]) ->
 	(match List.map (fun v -> xlate_formula(out_gen rawwit_constr v))
-                   [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl]
+                   [fth;ainv;ainvl]
  	 with
-             [a1;aplus1;amult1;aone1;azero1;aopp1;aeq1;ainv1;fth1;ainvl1] ->
-	       let bind =
-		 match out_gen Field.rawwit_minus_div_arg minusdiv with
-		     None, None ->
-		       CT_binding_list[]
-		   | Some m, None ->
-		       CT_binding_list[
-			 CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m)]
-		   | None, Some d ->
-		       CT_binding_list[
-			 CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)]
-		   | Some m, Some d ->
-		       CT_binding_list[
-			 CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m);
-			 CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] in
-		 CT_add_field(a1, aplus1, amult1, aone1, azero1, aopp1, aeq1,
-			      ainv1, fth1, ainvl1, bind)
+             [fth1;ainv1;ainvl1] ->
+	       let adiv1 =
+                 xlate_formula_opt (out_gen (wit_opt rawwit_constr) div) in
+	       CT_add_field(fth1, ainv1, ainvl1, adiv1)
 	   |_ -> assert false)
-  | VernacExtend (("HintRewriteV7"|"HintRewriteV8") as key, largs) ->
-      let in_v8 = (key = "HintRewriteV8") in
-      let orient = out_gen Extraargs.rawwit_orient (List.nth largs 0) in
-      let formula_list = out_gen (wit_list1 rawwit_constr) (List.nth largs 1) in
-      let t =
-	if List.length largs = 4 then
-	   out_gen rawwit_tactic (List.nth largs (if in_v8 then 2 else 3))
-	 else
-	   TacId "" in
-      let base = 
-	out_gen rawwit_pre_ident
-	  (if in_v8 then last largs else List.nth largs 2) in
+  | VernacExtend ("HintRewrite", o::f::([b]|[_;b] as args)) ->
+      let orient = out_gen Extraargs.rawwit_orient o in
+      let formula_list = out_gen (wit_list1 rawwit_constr) f in
+      let base = out_gen rawwit_pre_ident b in
+      let t = 
+	match args with [t;_] -> out_gen rawwit_main_tactic t | _ -> TacId []
+      in
       let ct_orient = match orient with
 	| true  -> CT_lr
 	| false -> CT_rl in
@@ -1665,7 +1701,7 @@ let rec xlate_vernac =
   | VernacHints (local,dbnames,h) ->
       let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in
       (match h with
-	| HintsConstructors (None, l) ->
+	| HintsConstructors l ->
 	 let n1, names = match List.map tac_qualid_to_ct_ID l with
 	     n1 :: names -> n1, names
 	   | _  -> failwith "" in
@@ -1675,15 +1711,10 @@ let rec xlate_vernac =
 	   else
 	     CT_hints(CT_ident "Constructors",
 		      CT_id_ne_list(n1, names), dblist)
-	| HintsExtern (None, n, c, t) ->
+	| HintsExtern (n, c, t) ->
 	    CT_hint_extern(CT_int n, xlate_formula c, xlate_tactic t, dblist)
         | HintsResolve l | HintsImmediate l -> 
-	    let l = 
-	      List.map 
-	     	(function (None, f) -> xlate_formula f
-		   | _ -> 
-		       xlate_error "obsolete Hint Resolve not supported") l in
-	 let f1, formulas = match l  with
+	 let f1, formulas = match List.map xlate_formula l with
 	     a :: tl -> a, tl
 	   | _  -> failwith "" in
 	 let l' = CT_formula_ne_list(f1, formulas) in
@@ -1700,10 +1731,7 @@ let rec xlate_vernac =
 		| HintsImmediate _ -> CT_hints_immediate(l', dblist)
 		| _ -> assert false)
         | HintsUnfold l -> 
-	 let l = List.map
-	   (function (None,ref) -> loc_qualid_to_ct_ID ref |
-	      _ -> xlate_error "obsolete Hint Unfold not supported") l in
-	 let n1, names = match l with
+	 let n1, names = match List.map loc_qualid_to_ct_ID l with
 	     n1 :: names -> n1, names
 	   | _  -> failwith "" in
 	   if local then
@@ -1724,9 +1752,6 @@ let rec xlate_vernac =
 	       CT_hint_destruct
 		 (xlate_ident id, CT_int n, dl, xlate_formula f,
 		  xlate_tactic t, dblist)
-	| HintsExtern(Some _, _, _, _)
-	| HintsConstructors(Some _, _) -> 
-            xlate_error "obsolete Hint Constructors not supported"
 )
   | VernacEndProof (Proved (true,None)) ->
       CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), ctv_ID_OPT_NONE)
@@ -1759,9 +1784,11 @@ let rec xlate_vernac =
   | VernacShow (ShowGoalImplicitly (Some n)) -> CT_show_implicit (CT_int n)
   | VernacShow ShowExistentials -> CT_show_existentials
   | VernacShow ShowScript -> CT_show_script
+  | VernacShow(ShowMatch _) -> xlate_error "TODO: VernacShow(ShowMatch _)"
+  | VernacShow(ShowThesis) -> xlate_error "TODO: VernacShow(ShowThesis _)"
   | VernacGo arg -> CT_go (xlate_locn arg)
-  | VernacShow ExplainProof l -> CT_explain_proof (nums_to_int_list l)
-  | VernacShow ExplainTree l ->
+  | VernacShow (ExplainProof l) -> CT_explain_proof (nums_to_int_list l)
+  | VernacShow (ExplainTree l) ->
       CT_explain_prooftree (nums_to_int_list l)
   | VernacCheckGuard -> CT_guarded
   | VernacPrint p ->
@@ -1775,6 +1802,8 @@ let rec xlate_vernac =
 	| PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star)
 	| PrintHintDbName id -> 
 	    CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id))
+	| PrintRewriteHintDbName id -> 
+	    CT_print_rewrite_hintdb (CT_ident id)
 	| PrintHint id ->
 	    CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id))
 	| PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE
@@ -1783,12 +1812,15 @@ let rec xlate_vernac =
 	| PrintMLModules -> CT_ml_print_modules
 	| PrintGraph -> CT_print_graph
 	| PrintClasses -> CT_print_classes
+	| PrintLtac qid -> CT_print_ltac (loc_qualid_to_ct_ID qid)
 	| PrintCoercions -> CT_print_coercions
 	| PrintCoercionPaths (id1, id2) -> 
 	    CT_print_path (xlate_class id1, xlate_class id2)
+	| PrintCanonicalConversions ->
+	    xlate_error "TODO: Print Canonical Structures"
 	| PrintInspect n -> CT_inspect (CT_int n)
 	| PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s)
-	| PrintLocalContext -> CT_print
+	| PrintSetoids -> CT_print_setoids
 	| PrintTables -> CT_print_tables
         | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a)
         | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a)
@@ -1809,7 +1841,7 @@ let rec xlate_vernac =
 	CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s,
            xlate_binder_list bl, xlate_formula c))
   | VernacSuspend -> CT_suspend
-  | VernacResume idopt -> CT_resume (xlate_ident_opt (option_app snd idopt))
+  | VernacResume idopt -> CT_resume (xlate_ident_opt (option_map snd idopt))
   | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) ->
       CT_coerce_THEOREM_GOAL_to_COMMAND
 	(CT_theorem_goal
@@ -1851,7 +1883,7 @@ let rec xlate_vernac =
       (_, (add_coercion, (_,s)), binders, c1,
        rec_constructor_or_none, field_list) ->
       let record_constructor =
-        xlate_ident_opt (option_app snd rec_constructor_or_none) in
+        xlate_ident_opt (option_map snd rec_constructor_or_none) in
       CT_record
        ((if add_coercion then CT_coercion_atm else
           CT_coerce_NONE_to_COERCION_OPT(CT_none)),
@@ -1860,20 +1892,22 @@ let rec xlate_vernac =
          build_record_field_list field_list)
    | VernacInductive (isind, lmi) ->
       let co_or_ind = if isind then "Inductive" else "CoInductive" in
-      let strip_mutind ((_,s), notopt, parameters, c, constructors) =
+      let strip_mutind (((_,s), parameters, c, constructors), notopt) =
           CT_ind_spec
             (xlate_ident s, xlate_binder_list parameters, xlate_formula c,
              build_constructors constructors,
 	     translate_opt_notation_decl notopt) in
         CT_mind_decl
 	  (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi))
-   | VernacFixpoint [] -> xlate_error "mutual recursive"
-   | VernacFixpoint (lm :: lmi) ->
-      let strip_mutrec ((fid, n, bl, arf, ardef), ntn) =
+   | VernacFixpoint ([],_) -> xlate_error "mutual recursive"
+   | VernacFixpoint ((lm :: lmi),boxed) ->
+      let strip_mutrec ((fid, (n, ro), bl, arf, ardef), _ntn) =
         let (struct_arg,bl,arf,ardef) =
+	 (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *)
+	 (* By the way, how could [bl = []] happen in V8 syntax ?  *)
          if bl = [] then
+	   let n = out_some n in 
            let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in
-           let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in
            (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef)
          else (make_fix_struct (n, bl),bl,arf,ardef) in
         let arf = xlate_formula arf in
@@ -1885,9 +1919,9 @@ let rec xlate_vernac =
           | _ -> xlate_error "mutual recursive" in
         CT_fix_decl
 	  (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi))
-   | VernacCoFixpoint [] -> xlate_error "mutual corecursive"
-   | VernacCoFixpoint (lm :: lmi) ->
-      let strip_mutcorec (fid, bl, arf, ardef) =
+   | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive"
+   | VernacCoFixpoint ((lm :: lmi),boxed) ->
+      let strip_mutcorec ((fid, bl, arf, ardef), _ntn) =
 	CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
                       xlate_formula arf, xlate_formula ardef) in
         CT_cofix_decl
@@ -1916,20 +1950,18 @@ let rec xlate_vernac =
 			    | Some mty1 ->
 				CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT
 				  (xlate_module_type mty1))
-   | VernacDefineModule((_, id), bl, mty_o, mexpr_o) ->
+   | VernacDefineModule(_,(_, id), bl, mty_o, mexpr_o) ->
        CT_module(xlate_ident id, 
 		 xlate_module_binder_list bl,
 		 xlate_module_type_check_opt mty_o,
 		 match mexpr_o with
 		     None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE
 		   | Some m -> xlate_module_expr m)
-  | VernacDeclareModule((_, id), bl, mty_o, mexpr_o) -> 
+  | VernacDeclareModule(_,(_, id), bl, mty_o) -> 
        CT_declare_module(xlate_ident id, 
 		 xlate_module_binder_list bl,
-		 xlate_module_type_check_opt mty_o,
-		 match mexpr_o with
-		     None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE
-		   | Some m -> xlate_module_expr m)
+		 xlate_module_type_check_opt (Some mty_o),
+		 CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE)
    | VernacRequire (impexp, spec, id::idl) ->
       let ct_impexp, ct_spec = get_require_flags impexp spec in
       CT_require (ct_impexp, ct_spec, 
@@ -1943,13 +1975,11 @@ let rec xlate_vernac =
       CT_require(ct_impexp, ct_spec, 
 		 CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename))
 
-   | VernacSyntax (phylum, l) -> xlate_error "SYNTAX not implemented"
-
    | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s)
    | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s)
    | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s)
    | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s)
-   | VernacArgumentsScope(qid, l) -> 
+   | VernacArgumentsScope(true, qid, l) -> 
        CT_arguments_scope(loc_qualid_to_ct_ID qid,
 		       CT_id_opt_list
 		       (List.map
@@ -1957,6 +1987,8 @@ let rec xlate_vernac =
 				  match x with
 				      None -> ctv_ID_OPT_NONE
 				    | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l))
+   | VernacArgumentsScope(false, qid, l) -> 
+       xlate_error "TODO: Arguments Scope Global"
    | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2)
    | VernacBindScope(id, a::l) -> 
        let xlate_class_rawexpr = function
@@ -1966,8 +1998,7 @@ let rec xlate_vernac =
 		     CT_id_ne_list(xlate_class_rawexpr a,
 				   List.map xlate_class_rawexpr l))
    | VernacBindScope(id, []) -> assert false
-   | VernacNotation(b, c, None, _, _) -> assert false
-   | VernacNotation(b, c, Some(s,modif_list), _, opt_scope) -> 
+   | VernacNotation(b, c, (s,modif_list), opt_scope) -> 
        let translated_s = CT_string s in
        let formula = xlate_formula c in
        let translated_modif_list = 
@@ -1981,7 +2012,7 @@ let rec xlate_vernac =
        else
 	 CT_define_notation(translated_s, formula, 
 			    translated_modif_list, translated_scope)
-   | VernacSyntaxExtension(b,Some(s,modif_list), None) -> 
+   | VernacSyntaxExtension(b,(s,modif_list)) -> 
        let translated_s = CT_string s in
        let translated_modif_list = 
 	 CT_modifier_list(List.map xlate_syntax_modifier modif_list) in
@@ -1989,8 +2020,7 @@ let rec xlate_vernac =
 	 CT_local_reserve_notation(translated_s, translated_modif_list)
        else
 	 CT_reserve_notation(translated_s, translated_modif_list)
-   | VernacSyntaxExtension(_, _, _) -> assert false
-   | VernacInfix (b,(str,modl),id,_, opt_scope) ->
+   | VernacInfix (b,(str,modl),id, opt_scope) ->
        let id1 = loc_qualid_to_ct_ID id in
        let modl1 = CT_modifier_list(List.map xlate_syntax_modifier modl) in
        let s = CT_string str in
@@ -2001,7 +2031,6 @@ let rec xlate_vernac =
 	   CT_local_infix(s, id1,modl1, translated_scope)
 	 else
 	   CT_infix(s, id1,modl1, translated_scope)
-   | VernacGrammar _ -> xlate_error "GRAMMAR not implemented"
    | VernacCoercion (s, id1, id2, id3) ->
       let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in
       let local_opt =
@@ -2026,18 +2055,15 @@ let rec xlate_vernac =
   | VernacExtend (s, l) ->
       CT_user_vernac
        (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l))
-  | VernacDebug b -> xlate_error "Debug On/Off not supported"
   | VernacList((_, a)::l) -> 
       CT_coerce_COMMAND_LIST_to_COMMAND
 	(CT_command_list(xlate_vernac a, 
 			 List.map (fun (_, x) -> xlate_vernac x) l))
   | VernacList([]) -> assert false
-  | (VernacV7only _ | VernacV8only _) ->
-      xlate_error "Not treated here"
   | VernacNop -> CT_proof_no_op
   | VernacComments l -> 
       CT_scomments(CT_scomment_content_list (List.map xlate_comment l))
-  | VernacDeclareImplicits(id, opt_positions) ->
+  | VernacDeclareImplicits(true, id, opt_positions) ->
       CT_implicits
 	(reference_to_ct_ID id,
 	 match opt_positions with
@@ -2050,6 +2076,8 @@ let rec xlate_vernac =
 		       -> xlate_error
 			   "explication argument by rank is obsolete"
 		     | ExplByName id -> CT_ident (string_of_id id)) l)))
+  | VernacDeclareImplicits(false, id, opt_positions) ->
+      xlate_error "TODO: Implicit Arguments Global"
   | VernacReserve((_,a)::l, f) ->
       CT_reserve(CT_id_ne_list(xlate_ident a, 
 			       List.map (fun (_,x) -> xlate_ident x) l),
@@ -2057,6 +2085,7 @@ let rec xlate_vernac =
   | VernacReserve([], _) -> assert false
   | VernacLocate(LocateTerm id) -> CT_locate(reference_to_ct_ID id)
   | VernacLocate(LocateLibrary id) -> CT_locate_lib(reference_to_ct_ID id)
+  | VernacLocate(LocateModule _) -> xlate_error "TODO: Locate Module"
   | VernacLocate(LocateFile s) -> CT_locate_file(CT_string s)
   | VernacLocate(LocateNotation s) -> CT_locate_notation(CT_string s)
   | VernacTime(v) -> CT_time(xlate_vernac v)
@@ -2113,9 +2142,9 @@ let rec xlate_vernac =
   | VernacVar _ -> xlate_error "Grammar vernac obsolete"
   | (VernacGlobalCheck _|VernacPrintOption _|
      VernacMemOption (_, _)|VernacRemoveOption (_, _)
-  | VernacBack _|VernacRestoreState _| VernacWriteState _|
-    VernacSolveExistential (_, _)|VernacCanonical _ | VernacDistfix _|
-     VernacTacticGrammar _)
+  | VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _|
+    VernacSolveExistential (_, _)|VernacCanonical _ |
+     VernacTacticNotation _)
     -> xlate_error "TODO: vernac";;
 
 let rec xlate_vernac_list =
@@ -2123,8 +2152,5 @@ let rec xlate_vernac_list =
    | VernacList (v::l) ->
        CT_command_list
          (xlate_vernac (snd v), List.map (fun (_,x) -> xlate_vernac x) l)
-   | VernacV7only v -> 
-       if !Options.v7 then xlate_vernac_list v
-       else xlate_error "Unknown command"
    | VernacList [] -> xlate_error "xlate_command_list"
    | _ -> xlate_error "Not a list of commands";;
diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml
index 876dc6c0..a2a72676 100644
--- a/contrib/jprover/jall.ml
+++ b/contrib/jprover/jall.ml
@@ -1788,11 +1788,13 @@ struct
       else  if o = ("",Orr,dummyt,dummyt) then  (* Orr is a dummy for no d-gen. rule *)
          ptree
       else
+(*
          let (x1,x2,x3,x4) = r
          and (y1,y2,y3,y4) = o in
-(*   print_endline ("top or_l: "^x1);
+   print_endline ("top or_l: "^x1);
    print_endline ("or_l address: "^addr);
-   print_endline ("top dgen-rule: "^y1); *)
+   print_endline ("top dgen-rule: "^y1);
+*)
          trans_add_branch r o addr "" ptree dglist (subrel,tsubrel)
 
 (* Isolate layer and outer recursion structure *)
@@ -1989,8 +1991,7 @@ struct
                         let (srel,sren) = build_formula_rel dtreelist slist predname in
                         (srel @ rest_rel),(sren @ rest_renlist)
                    | Gamma ->
-                        let n = Array.length suctrees
-                        and succlist = (Array.to_list suctrees) in
+                        let succlist = (Array.to_list suctrees) in
                         let dtreelist = (List.map (fun x -> (1,x)) succlist) in
 (*                if (nonemptys suctrees 0 n) = 1  then
    let (srel,sren) = build_formula_rel dtreelist slist pos.name in
@@ -3039,8 +3040,7 @@ struct
                if (p.pt = Delta) then                 (* keep the tree ordering for the successor position only *)
                   let psucc = List.hd succs in
                   let ppsuccs = tpredsucc psucc ftree in
-                  let pre = List.hd ppsuccs
-                  and sucs = List.tl ppsuccs in
+                  let sucs = List.tl ppsuccs in
                   replace_ordering (psucc.name) sucs redpo (* union the succsets of psucc *)
                else
                   redpo
@@ -4582,7 +4582,6 @@ let gen_prover mult_limit logic calculus hyps concls =
    let (input_map,renamed_termlist) = renam_free_vars (hyps @ concls) in
    let (ftree,red_ordering,eqlist,(sigmaQ,sigmaJ),ext_proof) = prove mult_limit renamed_termlist logic in
    let sequent_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in
-      let (ptree,count_ax) = bproof sequent_proof in
       let idl = build_formula_id ftree in
 (*      print_ftree ftree;   apple *)
          (* transform types and rename constants *)
diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4
index dd76438f..294943f7 100644
--- a/contrib/jprover/jprover.ml4
+++ b/contrib/jprover/jprover.ml4
@@ -51,7 +51,7 @@ let mbreak s = Format.print_flush (); print_string ("-break at: "^s);
 let jp_error re = raise (JT.RefineError ("jprover", JT.StringError re))
 
 (* print Coq constructor *)
-let print_constr ct = Pp.ppnl (PR.prterm ct); Format.print_flush ()
+let print_constr ct = Pp.ppnl (PR.pr_lconstr ct); Format.print_flush ()
 
 let rec print_constr_list = function
   |  [] -> ()
@@ -361,7 +361,7 @@ let dyn_impl id gl =
          (TCL.tclTHENLAST
             (TCL.tclTHENS (T.cut b) [T.intro_using id2;TCL.tclIDTAC])
          (T.apply_term (TR.mkVar (short_addr id))
-                       [TR.mkMeta (Clenv.new_meta())])) gl
+                       [TR.mkMeta (Evarutil.new_meta())])) gl
 
 let dyn_allr c =       (* [c] must be an eigenvariable which replaces [v] *)
   HT.h_intro (N.id_of_string c)
@@ -390,7 +390,7 @@ let dyn_truer =
 (* Do the proof by the guidance of JProver. *)
 
 let do_one_step inf =
-  let (rule, (s1, t1), ((s2, t2) as k)) = inf in
+  let (rule, (s1, t1), (s2, t2)) = inf in
    begin
 (*i   if not (Jterm.is_xnil_term t2) then
    begin
@@ -542,20 +542,9 @@ let jpn n gls =
   TCL.tclTHEN (TCL.tclTRY T.red_in_concl)
               (TCL.tclTHEN (unfail_gen (List.map TR.mkVar ls))
                          (jp n)) gls
-(*
-let dyn_jpn l gls =
-  match l with
-   | [PT.Integer n] -> jpn n
-   | _ -> jp_error "Impossible!!!"
-
-
-let h_jp = TM.hide_tactic "Jp" dyn_jp
-
-let h_jpn = TM.hide_tactic "Jpn" dyn_jpn
-*)
 
-TACTIC EXTEND Jprover
-  [ "Jp" natural_opt(n) ] -> [ jpn n ]
+TACTIC EXTEND jprover
+  [ "jp" natural_opt(n) ] -> [ jpn n ]
 END
 
 (*
diff --git a/contrib/jprover/jtunify.ml b/contrib/jprover/jtunify.ml
index 2295e62c..91aa6b4b 100644
--- a/contrib/jprover/jtunify.ml
+++ b/contrib/jprover/jtunify.ml
@@ -177,7 +177,7 @@ let rec combine subst ((ov,oslist) as one_subst)  =
          else
             (f::rest_combine)
 
-let compose ((n,subst) as sigma) ((ov,oslist) as one_subst) =
+let compose ((n,subst) as _sigma) ((ov,oslist) as one_subst) =
    let com = combine subst one_subst in
 (* begin
    print_endline "!!!!!!!!!test print!!!!!!!!!!";
diff --git a/contrib/omega/Omega.v b/contrib/omega/Omega.v
index e72dcec2..66f86a49 100755..100644
--- a/contrib/omega/Omega.v
+++ b/contrib/omega/Omega.v
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* $Id: Omega.v,v 1.10.2.1 2004/07/16 19:30:12 herbelin Exp $ *)
+(* $Id: Omega.v 8642 2006-03-17 10:09:02Z notin $ *)
 
 (* We do not require [ZArith] anymore, but only what's necessary for Omega *)
 Require Export ZArith_base.
diff --git a/contrib/omega/OmegaLemmas.v b/contrib/omega/OmegaLemmas.v
index 6f0ea2c6..ae642a3e 100644
--- a/contrib/omega/OmegaLemmas.v
+++ b/contrib/omega/OmegaLemmas.v
@@ -1,45 +1,45 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
 
-(*i $Id: OmegaLemmas.v,v 1.4.2.1 2004/07/16 19:30:12 herbelin Exp $ i*)
+(*i $Id: OmegaLemmas.v 7727 2005-12-25 13:42:20Z herbelin $ i*)
 
 Require Import ZArith_base.
+Open Local Scope Z_scope.
 
 (** These are specific variants of theorems dedicated for the Omega tactic *)
 
-Lemma new_var : forall x:Z,  exists y : Z, x = y.
+Lemma new_var : forall x : Z, exists y : Z, x = y.
 intros x; exists x; trivial with arith. 
 Qed.
 
-Lemma OMEGA1 : forall x y:Z, x = y -> (0 <= x)%Z -> (0 <= y)%Z.
+Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y.
 intros x y H; rewrite H; auto with arith.
 Qed.
 
-Lemma OMEGA2 : forall x y:Z, (0 <= x)%Z -> (0 <= y)%Z -> (0 <= x + y)%Z.
+Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y.
 exact Zplus_le_0_compat.
 Qed. 
 
-Lemma OMEGA3 :
- forall x y k:Z, (k > 0)%Z -> x = (y * k)%Z -> x = 0%Z -> y = 0%Z.
+Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0.
 
 intros x y k H1 H2 H3; apply (Zmult_integral_l k);
- [ unfold not in |- *; intros H4; absurd (k > 0)%Z;
+ [ unfold not in |- *; intros H4; absurd (k > 0);
     [ rewrite H4; unfold Zgt in |- *; simpl in |- *; discriminate
     | assumption ]
  | rewrite <- H2; assumption ].
 Qed.
 
-Lemma OMEGA4 : forall x y z:Z, (x > 0)%Z -> (y > x)%Z -> (z * y + x)%Z <> 0%Z.
+Lemma OMEGA4 : forall x y z : Z, x > 0 -> y > x -> z * y + x <> 0.
 
-unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0)%Z;
- [ intros H4; cut (0 <= z * y + x)%Z;
+unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0);
+ [ intros H4; cut (0 <= z * y + x);
     [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6;
-       absurd (z * y + x > 0)%Z;
+       absurd (z * y + x > 0);
        [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate
        | apply Zle_gt_trans with x;
           [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x);
@@ -55,48 +55,44 @@ unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0)%Z;
  | apply Zgt_trans with x; [ assumption | assumption ] ].
 Qed.
 
-Lemma OMEGA5 : forall x y z:Z, x = 0%Z -> y = 0%Z -> (x + y * z)%Z = 0%Z.
+Lemma OMEGA5 : forall x y z : Z, x = 0 -> y = 0 -> x + y * z = 0.
 
 intros x y z H1 H2; rewrite H1; rewrite H2; simpl in |- *; trivial with arith.
 Qed.
 
-Lemma OMEGA6 : forall x y z:Z, (0 <= x)%Z -> y = 0%Z -> (0 <= x + y * z)%Z.
+Lemma OMEGA6 : forall x y z : Z, 0 <= x -> y = 0 -> 0 <= x + y * z.
 
 intros x y z H1 H2; rewrite H2; simpl in |- *; rewrite Zplus_0_r; assumption.
 Qed.
 
 Lemma OMEGA7 :
- forall x y z t:Z,
-   (z > 0)%Z ->
-   (t > 0)%Z -> (0 <= x)%Z -> (0 <= y)%Z -> (0 <= x * z + y * t)%Z.
+ forall x y z t : Z, z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t.
 
 intros x y z t H1 H2 H3 H4; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat;
  apply Zmult_gt_0_le_0_compat; assumption.
 Qed.
 
-Lemma OMEGA8 :
- forall x y:Z, (0 <= x)%Z -> (0 <= y)%Z -> x = (- y)%Z -> x = 0%Z.
+Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0.
 
 intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1);
- [ intros H4; absurd (0 < x)%Z;
-    [ change (0 >= x)%Z in |- *; apply Zle_ge; apply Zplus_le_reg_l with y;
+ [ intros H4; absurd (0 < x);
+    [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y;
        rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; 
        assumption
     | assumption ]
  | intros H4; rewrite H4; trivial with arith ].
 Qed.
 
-Lemma OMEGA9 :
- forall x y z t:Z, y = 0%Z -> x = z -> (y + (- x + z) * t)%Z = 0%Z.
+Lemma OMEGA9 : forall x y z t : Z, y = 0 -> x = z -> y + (- x + z) * t = 0.
 
 intros x y z t H1 H2; rewrite H2; rewrite Zplus_opp_l; rewrite Zmult_0_l;
  rewrite Zplus_0_r; assumption.
 Qed.
 
 Lemma OMEGA10 :
- forall v c1 c2 l1 l2 k1 k2:Z,
-   ((v * c1 + l1) * k1 + (v * c2 + l2) * k2)%Z =
-   (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))%Z.
+ forall v c1 c2 l1 l2 k1 k2 : Z,
+ (v * c1 + l1) * k1 + (v * c2 + l2) * k2 =
+ v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2).
 
 intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
  repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
@@ -104,8 +100,8 @@ intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
 Qed.
 
 Lemma OMEGA11 :
- forall v1 c1 l1 l2 k1:Z,
-   ((v1 * c1 + l1) * k1 + l2)%Z = (v1 * (c1 * k1) + (l1 * k1 + l2))%Z.
+ forall v1 c1 l1 l2 k1 : Z,
+ (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).
 
 intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
  repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
@@ -113,8 +109,8 @@ intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
 Qed.
 
 Lemma OMEGA12 :
- forall v2 c2 l1 l2 k2:Z,
-   (l1 + (v2 * c2 + l2) * k2)%Z = (v2 * (c2 * k2) + (l1 + l2 * k2))%Z.
+ forall v2 c2 l1 l2 k2 : Z,
+ l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).
 
 intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
  repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
@@ -122,8 +118,8 @@ intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
 Qed.
 
 Lemma OMEGA13 :
- forall (v l1 l2:Z) (x:positive),
-   (v * Zpos x + l1 + (v * Zneg x + l2))%Z = (l1 + l2)%Z.
+ forall (v l1 l2 : Z) (x : positive),
+ v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2.
 
 intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1);
  rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
@@ -133,8 +129,8 @@ intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1);
 Qed.
  
 Lemma OMEGA14 :
- forall (v l1 l2:Z) (x:positive),
-   (v * Zneg x + l1 + (v * Zpos x + l2))%Z = (l1 + l2)%Z.
+ forall (v l1 l2 : Z) (x : positive),
+ v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2.
 
 intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1);
  rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
@@ -142,128 +138,126 @@ intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1);
  rewrite Zplus_0_r; trivial with arith.
 Qed.
 Lemma OMEGA15 :
- forall v c1 c2 l1 l2 k2:Z,
-   (v * c1 + l1 + (v * c2 + l2) * k2)%Z =
-   (v * (c1 + c2 * k2) + (l1 + l2 * k2))%Z.
+ forall v c1 c2 l1 l2 k2 : Z,
+ v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).
 
 intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
  repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
  rewrite (Zplus_permute l1 (v * c2 * k2)); trivial with arith.
 Qed.
 
-Lemma OMEGA16 :
- forall v c l k:Z, ((v * c + l) * k)%Z = (v * (c * k) + l * k)%Z.
+Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k.
 
 intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
  repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
  trivial with arith.
 Qed.
 
-Lemma OMEGA17 : forall x y z:Z, Zne x 0 -> y = 0%Z -> Zne (x + y * z) 0.
+Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
 
 unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1;
- apply Zplus_reg_l with (y * z)%Z; rewrite Zplus_comm; 
+ apply Zplus_reg_l with (y * z); rewrite Zplus_comm; 
  rewrite H3; rewrite H2; auto with arith.
 Qed.
 
-Lemma OMEGA18 : forall x y k:Z, x = (y * k)%Z -> Zne x 0 -> Zne y 0.
+Lemma OMEGA18 : forall x y k : Z, x = y * k -> Zne x 0 -> Zne y 0.
 
 unfold Zne, not in |- *; intros x y k H1 H2 H3; apply H2; rewrite H1;
  rewrite H3; auto with arith.
 Qed.
 
-Lemma OMEGA19 :
- forall x:Z, Zne x 0 -> (0 <= x + -1)%Z \/ (0 <= x * -1 + -1)%Z.
+Lemma OMEGA19 : forall x : Z, Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1.
 
 unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x);
  [ intros H1; elim Zle_lt_or_eq with (1 := H1);
-    [ intros H2; left; change (0 <= Zpred x)%Z in |- *; apply Zsucc_le_reg;
+    [ intros H2; left; change (0 <= Zpred x) in |- *; apply Zsucc_le_reg;
        rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption
-    | intros H2; absurd (x = 0%Z); auto with arith ]
+    | intros H2; absurd (x = 0); auto with arith ]
  | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm;
     apply Zle_left; apply Zsucc_le_reg; simpl in |- *; 
     apply Zlt_le_succ; auto with arith ].
 Qed.
 
-Lemma OMEGA20 : forall x y z:Z, Zne x 0 -> y = 0%Z -> Zne (x + y * z) 0.
+Lemma OMEGA20 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
 
 unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; rewrite H2 in H3;
  simpl in H3; rewrite Zplus_0_r in H3; trivial with arith.
 Qed.
 
-Definition fast_Zplus_sym (x y:Z) (P:Z -> Prop) (H:P (y + x)%Z) :=
-  eq_ind_r P H (Zplus_comm x y).
+Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop)
+  (H : P (y + x)) := eq_ind_r P H (Zplus_comm x y).
 
-Definition fast_Zplus_assoc_r (n m p:Z) (P:Z -> Prop)
-  (H:P (n + (m + p))%Z) := eq_ind_r P H (Zplus_assoc_reverse n m p).
+Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop)
+  (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p).
 
-Definition fast_Zplus_assoc_l (n m p:Z) (P:Z -> Prop) 
-  (H:P (n + m + p)%Z) := eq_ind_r P H (Zplus_assoc n m p).
+Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) 
+  (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p).
 
-Definition fast_Zplus_permute (n m p:Z) (P:Z -> Prop)
-  (H:P (m + (n + p))%Z) := eq_ind_r P H (Zplus_permute n m p).
+Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop)
+  (H : P (m + (n + p))) := eq_ind_r P H (Zplus_permute n m p).
 
-Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2:Z) (P:Z -> Prop)
-  (H:P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))%Z) :=
+Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop)
+  (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) :=
   eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2).
 
-Definition fast_OMEGA11 (v1 c1 l1 l2 k1:Z) (P:Z -> Prop)
-  (H:P (v1 * (c1 * k1) + (l1 * k1 + l2))%Z) :=
+Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop)
+  (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) :=
   eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1).
-Definition fast_OMEGA12 (v2 c2 l1 l2 k2:Z) (P:Z -> Prop)
-  (H:P (v2 * (c2 * k2) + (l1 + l2 * k2))%Z) :=
+Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop)
+  (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) :=
   eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2).
 
-Definition fast_OMEGA15 (v c1 c2 l1 l2 k2:Z) (P:Z -> Prop)
-  (H:P (v * (c1 + c2 * k2) + (l1 + l2 * k2))%Z) :=
+Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop)
+  (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) :=
   eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2).
-Definition fast_OMEGA16 (v c l k:Z) (P:Z -> Prop)
-  (H:P (v * (c * k) + l * k)%Z) := eq_ind_r P H (OMEGA16 v c l k).
+Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop)
+  (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k).
 
-Definition fast_OMEGA13 (v l1 l2:Z) (x:positive) (P:Z -> Prop)
-  (H:P (l1 + l2)%Z) := eq_ind_r P H (OMEGA13 v l1 l2 x).
+Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
+  (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x).
 
-Definition fast_OMEGA14 (v l1 l2:Z) (x:positive) (P:Z -> Prop)
-  (H:P (l1 + l2)%Z) := eq_ind_r P H (OMEGA14 v l1 l2 x).
-Definition fast_Zred_factor0 (x:Z) (P:Z -> Prop) (H:P (x * 1)%Z) :=
-  eq_ind_r P H (Zred_factor0 x).
+Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
+  (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x).
+Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) 
+  (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x).
 
-Definition fast_Zopp_one (x:Z) (P:Z -> Prop) (H:P (x * -1)%Z) :=
-  eq_ind_r P H (Zopp_eq_mult_neg_1 x).
+Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop)
+  (H : P (x * -1)) := eq_ind_r P H (Zopp_eq_mult_neg_1 x).
 
-Definition fast_Zmult_sym (x y:Z) (P:Z -> Prop) (H:P (y * x)%Z) :=
-  eq_ind_r P H (Zmult_comm x y).
+Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop)
+  (H : P (y * x)) := eq_ind_r P H (Zmult_comm x y).
 
-Definition fast_Zopp_Zplus (x y:Z) (P:Z -> Prop) (H:P (- x + - y)%Z) :=
-  eq_ind_r P H (Zopp_plus_distr x y).
+Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop)
+  (H : P (- x + - y)) := eq_ind_r P H (Zopp_plus_distr x y).
 
-Definition fast_Zopp_Zopp (x:Z) (P:Z -> Prop) (H:P x) :=
+Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) :=
   eq_ind_r P H (Zopp_involutive x).
 
-Definition fast_Zopp_Zmult_r (x y:Z) (P:Z -> Prop) 
-  (H:P (x * - y)%Z) := eq_ind_r P H (Zopp_mult_distr_r x y).
+Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) 
+  (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y).
 
-Definition fast_Zmult_plus_distr (n m p:Z) (P:Z -> Prop)
-  (H:P (n * p + m * p)%Z) := eq_ind_r P H (Zmult_plus_distr_l n m p).
-Definition fast_Zmult_Zopp_left (x y:Z) (P:Z -> Prop) 
-  (H:P (x * - y)%Z) := eq_ind_r P H (Zmult_opp_comm x y).
+Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop)
+  (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p).
+Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) 
+  (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y).
 
-Definition fast_Zmult_assoc_r (n m p:Z) (P:Z -> Prop)
-  (H:P (n * (m * p))%Z) := eq_ind_r P H (Zmult_assoc_reverse n m p).
+Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop)
+  (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p).
 
-Definition fast_Zred_factor1 (x:Z) (P:Z -> Prop) (H:P (x * 2)%Z) :=
-  eq_ind_r P H (Zred_factor1 x).
+Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) 
+  (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x).
 
-Definition fast_Zred_factor2 (x y:Z) (P:Z -> Prop) 
-  (H:P (x * (1 + y))%Z) := eq_ind_r P H (Zred_factor2 x y).
-Definition fast_Zred_factor3 (x y:Z) (P:Z -> Prop) 
-  (H:P (x * (1 + y))%Z) := eq_ind_r P H (Zred_factor3 x y).
+Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop)
+  (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y).
 
-Definition fast_Zred_factor4 (x y z:Z) (P:Z -> Prop) 
-  (H:P (x * (y + z))%Z) := eq_ind_r P H (Zred_factor4 x y z).
+Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop)
+  (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y).
 
-Definition fast_Zred_factor5 (x y:Z) (P:Z -> Prop) 
-  (H:P y) := eq_ind_r P H (Zred_factor5 x y).
+Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop)
+  (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z).
 
-Definition fast_Zred_factor6 (x:Z) (P:Z -> Prop) (H:P (x + 0)%Z) :=
-  eq_ind_r P H (Zred_factor6 x).
+Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) 
+  (H : P y) := eq_ind_r P H (Zred_factor5 x y).
+
+Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) 
+  (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x).
diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml
index 7a20aeb6..da0817d1 100644
--- a/contrib/omega/coq_omega.ml
+++ b/contrib/omega/coq_omega.ml
@@ -13,13 +13,12 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* $Id: coq_omega.ml,v 1.59.2.3 2004/07/16 19:30:12 herbelin Exp $ *)
+(* $Id: coq_omega.ml 8934 2006-06-09 14:30:12Z herbelin $ *)
 
 open Util
 open Pp
 open Reduction
 open Proof_type
-open Ast
 open Names
 open Nameops
 open Term
@@ -36,9 +35,11 @@ open Clenv
 open Logic
 open Libnames
 open Nametab
-open Omega
 open Contradiction
 
+module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
+open OmegaSolver
+
 (* Added by JCF, 09/03/98 *)
 
 let elim_id id gl = simplest_elim (pf_global gl id) gl
@@ -56,16 +57,6 @@ let write f x = f:=x
 
 open Goptions
 
-(* Obsolete, subsumed by Time Omega
-let _ =
-  declare_bool_option 
-    { optsync  = false;
-      optname  = "Omega time displaying flag";
-      optkey   = SecondaryTable ("Omega","Time");
-      optread  = read display_time_flag;
-      optwrite = write display_time_flag }
-*)
-
 let _ =
   declare_bool_option 
     { optsync  = false;
@@ -110,6 +101,31 @@ let new_identifier_var =
   let cpt = ref 0 in 
   (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s)
 
+let new_id =
+  let cpt = ref 0 in fun () -> incr cpt; !cpt
+
+let new_var_num =
+  let cpt = ref 1000 in (fun () -> incr cpt; !cpt)
+
+let new_var =
+  let cpt = ref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt)
+
+let display_var i = Printf.sprintf "X%d" i
+
+let intern_id,unintern_id =
+  let cpt = ref 0 in
+  let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in
+  (fun (name : identifier) -> 
+     try Hashtbl.find table name with Not_found -> 
+       let idx = !cpt in
+       Hashtbl.add table name idx; 
+       Hashtbl.add co_table idx name;
+       incr cpt; idx),
+  (fun idx -> 
+     try Hashtbl.find co_table idx with Not_found -> 
+       let v = new_var () in
+       Hashtbl.add table v idx; Hashtbl.add co_table idx v; v)
+    
 let mk_then = tclTHENLIST
 
 let exists_tac c = constructor_tac (Some 1) 1 (Rawterm.ImplicitBindings [c])
@@ -146,32 +162,34 @@ let hide_constr,find_constr,clear_tables,dump_tables =
 open Coqlib
 
 let logic_dir = ["Coq";"Logic";"Decidable"]
+let init_arith_modules = init_modules @ arith_modules
 let coq_modules =
-  init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
+  init_arith_modules @ [logic_dir] @ zarith_base_modules
     @ [["Coq"; "omega"; "OmegaLemmas"]]
 
+let init_arith_constant = gen_constant_in_modules "Omega" init_arith_modules
 let constant = gen_constant_in_modules "Omega" coq_modules
 
 (* Zarith *)
 let coq_xH = lazy (constant "xH")
 let coq_xO = lazy (constant "xO")
 let coq_xI = lazy (constant "xI")
-let coq_ZERO = lazy (constant (if !Options.v7 then "ZERO" else "Z0"))
-let coq_POS = lazy (constant (if !Options.v7 then "POS" else "Zpos"))
-let coq_NEG = lazy (constant (if !Options.v7 then "NEG" else "Zneg"))
+let coq_Z0 = lazy (constant "Z0")
+let coq_Zpos = lazy (constant "Zpos")
+let coq_Zneg = lazy (constant "Zneg")
 let coq_Z = lazy (constant "Z")
-let coq_relation = lazy (constant (if !Options.v7 then "relation" else "comparison"))
-let coq_SUPERIEUR = lazy (constant "SUPERIEUR")
-let coq_INFEEIEUR = lazy (constant "INFERIEUR")
-let coq_EGAL = lazy (constant "EGAL")
+let coq_comparison = lazy (constant "comparison")
+let coq_Gt = lazy (constant "Gt")
+let coq_INFEEIEUR = lazy (constant "Lt")
+let coq_Eq = lazy (constant "Eq")
 let coq_Zplus = lazy (constant "Zplus")
 let coq_Zmult = lazy (constant "Zmult")
 let coq_Zopp = lazy (constant "Zopp")
 let coq_Zminus = lazy (constant "Zminus")
-let coq_Zs = lazy (constant "Zs")
+let coq_Zsucc = lazy (constant "Zsucc")
 let coq_Zgt = lazy (constant "Zgt")
 let coq_Zle = lazy (constant "Zle")
-let coq_inject_nat = lazy (constant "inject_nat")
+let coq_Z_of_nat = lazy (constant "Z_of_nat")
 let coq_inj_plus = lazy (constant "inj_plus")
 let coq_inj_mult = lazy (constant "inj_mult")
 let coq_inj_minus1 = lazy (constant "inj_minus1")
@@ -183,12 +201,12 @@ let coq_inj_ge = lazy (constant "inj_ge")
 let coq_inj_gt = lazy (constant "inj_gt")
 let coq_inj_neq = lazy (constant "inj_neq")
 let coq_inj_eq = lazy (constant "inj_eq")
-let coq_fast_Zplus_assoc_r = lazy (constant "fast_Zplus_assoc_r")
-let coq_fast_Zplus_assoc_l = lazy (constant "fast_Zplus_assoc_l")
-let coq_fast_Zmult_assoc_r = lazy (constant "fast_Zmult_assoc_r")
+let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse")
+let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc")
+let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse")
 let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute")
-let coq_fast_Zplus_sym = lazy (constant "fast_Zplus_sym")
-let coq_fast_Zmult_sym = lazy (constant "fast_Zmult_sym")
+let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm")
+let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm")
 let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx")
 let coq_OMEGA1 = lazy (constant "OMEGA1")
 let coq_OMEGA2 = lazy (constant "OMEGA2")
@@ -217,12 +235,12 @@ let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3")
 let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4")
 let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5")
 let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6")
-let coq_fast_Zmult_plus_distr = lazy (constant "fast_Zmult_plus_distr")
-let coq_fast_Zmult_Zopp_left =  lazy (constant "fast_Zmult_Zopp_left")
-let coq_fast_Zopp_Zplus =   lazy (constant "fast_Zopp_Zplus")
-let coq_fast_Zopp_Zmult_r = lazy (constant "fast_Zopp_Zmult_r")
-let coq_fast_Zopp_one =  lazy (constant "fast_Zopp_one")
-let coq_fast_Zopp_Zopp = lazy (constant "fast_Zopp_Zopp")
+let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l")
+let coq_fast_Zmult_opp_comm =  lazy (constant "fast_Zmult_opp_comm")
+let coq_fast_Zopp_plus_distr =   lazy (constant "fast_Zopp_plus_distr")
+let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r")
+let coq_fast_Zopp_eq_mult_neg_1 =  lazy (constant "fast_Zopp_eq_mult_neg_1")
+let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive")
 let coq_Zegal_left = lazy (constant "Zegal_left")
 let coq_Zne_left = lazy (constant "Zne_left")
 let coq_Zlt_left = lazy (constant "Zlt_left")
@@ -240,10 +258,10 @@ let coq_dec_Zgt = lazy (constant "dec_Zgt")
 let coq_dec_Zge = lazy (constant "dec_Zge")
 
 let coq_not_Zeq = lazy (constant "not_Zeq")
-let coq_not_Zle = lazy (constant "not_Zle")
-let coq_not_Zlt = lazy (constant "not_Zlt")
-let coq_not_Zge = lazy (constant "not_Zge")
-let coq_not_Zgt = lazy (constant "not_Zgt")
+let coq_Znot_le_gt = lazy (constant "Znot_le_gt")
+let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge")
+let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt")
+let coq_Znot_gt_le = lazy (constant "Znot_gt_le")
 let coq_neq = lazy (constant "neq")
 let coq_Zne = lazy (constant "Zne")
 let coq_Zle = lazy (constant "Zle")
@@ -252,17 +270,17 @@ let coq_Zge = lazy (constant "Zge")
 let coq_Zlt = lazy (constant "Zlt")
 
 (* Peano/Datatypes *)
-let coq_le = lazy (constant "le")
-let coq_lt = lazy (constant "lt")
-let coq_ge = lazy (constant "ge")
-let coq_gt = lazy (constant "gt")
-let coq_minus = lazy (constant "minus")
-let coq_plus = lazy (constant "plus")
-let coq_mult = lazy (constant "mult")
-let coq_pred = lazy (constant "pred")
-let coq_nat = lazy (constant "nat")
-let coq_S = lazy (constant "S")
-let coq_O = lazy (constant "O")
+let coq_le = lazy (init_arith_constant "le")
+let coq_lt = lazy (init_arith_constant "lt")
+let coq_ge = lazy (init_arith_constant "ge")
+let coq_gt = lazy (init_arith_constant "gt")
+let coq_minus = lazy (init_arith_constant "minus")
+let coq_plus = lazy (init_arith_constant "plus")
+let coq_mult = lazy (init_arith_constant "mult")
+let coq_pred = lazy (init_arith_constant "pred")
+let coq_nat = lazy (init_arith_constant "nat")
+let coq_S = lazy (init_arith_constant "S")
+let coq_O = lazy (init_arith_constant "O")
 
 (* Compare_dec/Peano_dec/Minus *)
 let coq_pred_of_minus = lazy (constant "pred_of_minus")
@@ -304,7 +322,7 @@ let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with
       EvalConstRef kn
   | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant")
 
-let sp_Zs =     lazy (evaluable_ref_of_constr "Zs" coq_Zs)
+let sp_Zsucc =     lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc)
 let sp_Zminus = lazy (evaluable_ref_of_constr "Zminus" coq_Zminus)
 let sp_Zle = lazy (evaluable_ref_of_constr "Zle" coq_Zle)
 let sp_Zgt = lazy (evaluable_ref_of_constr "Zgt" coq_Zgt)
@@ -324,23 +342,23 @@ let mk_and t1 t2 =  mkApp (build_coq_and (), [| t1; t2 |])
 let mk_or t1 t2 =  mkApp (build_coq_or (), [| t1; t2 |])
 let mk_not t = mkApp (build_coq_not (), [| t |])
 let mk_eq_rel t1 t2 = mkApp (build_coq_eq (),
-			      [| Lazy.force coq_relation; t1; t2 |])
-let mk_inj t = mkApp (Lazy.force coq_inject_nat, [| t |])
+			      [| Lazy.force coq_comparison; t1; t2 |])
+let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |])
 
 let mk_integer n =
   let rec loop n = 
-    if n=1 then Lazy.force coq_xH else 
-      mkApp ((if n mod 2 = 0 then Lazy.force coq_xO else Lazy.force coq_xI),
-		[| loop (n/2) |])
+    if n =? one then Lazy.force coq_xH else 
+    mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI),
+		[| loop (n/two) |])
   in
-  if n = 0 then Lazy.force coq_ZERO 
-  else mkApp ((if n > 0 then Lazy.force coq_POS else Lazy.force coq_NEG),
+  if n =? zero then Lazy.force coq_Z0 
+  else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg),
 		 [| loop (abs n) |])
     
 type omega_constant =
-  | Zplus | Zmult | Zminus | Zs | Zopp
+  | Zplus | Zmult | Zminus | Zsucc | Zopp
   | Plus | Mult | Minus | Pred | S | O
-  | POS | NEG | ZERO | Inject_nat
+  | Zpos | Zneg | Z0 | Z_of_nat
   | Eq | Neq
   | Zne | Zle | Zlt | Zge | Zgt
   | Z | Nat
@@ -401,7 +419,7 @@ let destructurate_term t =
     | _, [_;_] when c = Lazy.force coq_Zplus -> Kapp (Zplus,args)
     | _, [_;_] when c = Lazy.force coq_Zmult -> Kapp (Zmult,args)
     | _, [_;_] when c = Lazy.force coq_Zminus -> Kapp (Zminus,args)
-    | _, [_] when c = Lazy.force coq_Zs -> Kapp (Zs,args)
+    | _, [_] when c = Lazy.force coq_Zsucc -> Kapp (Zsucc,args)
     | _, [_] when c = Lazy.force coq_Zopp -> Kapp (Zopp,args)
     | _, [_;_] when c = Lazy.force coq_plus -> Kapp (Plus,args)
     | _, [_;_] when c = Lazy.force coq_mult -> Kapp (Mult,args)
@@ -409,25 +427,25 @@ let destructurate_term t =
     | _, [_] when c = Lazy.force coq_pred -> Kapp (Pred,args)
     | _, [_] when c = Lazy.force coq_S -> Kapp (S,args)
     | _, [] when c = Lazy.force coq_O -> Kapp (O,args)
-    | _, [_] when c = Lazy.force coq_POS -> Kapp (NEG,args)
-    | _, [_] when c = Lazy.force coq_NEG -> Kapp (POS,args)
-    | _, [] when c = Lazy.force coq_ZERO -> Kapp (ZERO,args)
-    | _, [_] when c = Lazy.force coq_inject_nat -> Kapp (Inject_nat,args)
+    | _, [_] when c = Lazy.force coq_Zpos -> Kapp (Zneg,args)
+    | _, [_] when c = Lazy.force coq_Zneg -> Kapp (Zpos,args)
+    | _, [] when c = Lazy.force coq_Z0 -> Kapp (Z0,args)
+    | _, [_] when c = Lazy.force coq_Z_of_nat -> Kapp (Z_of_nat,args)
     | Var id,[] -> Kvar id
     | _ -> Kufo
 
 let recognize_number t =
   let rec loop t =
     match decompose_app t with
-      | f, [t] when f = Lazy.force coq_xI -> 1 + 2 * loop t
-      | f, [t] when f = Lazy.force coq_xO -> 2 * loop t
-      | f, [] when f = Lazy.force coq_xH -> 1
+      | f, [t] when f = Lazy.force coq_xI -> one + two * loop t
+      | f, [t] when f = Lazy.force coq_xO -> two * loop t
+      | f, [] when f = Lazy.force coq_xH -> one
       | _ -> failwith "not a number" 
   in
   match decompose_app t with 
-    | f, [t] when f = Lazy.force coq_POS -> loop t
-    | f, [t] when f = Lazy.force coq_NEG -> - (loop t)
-    | f, [] when f = Lazy.force coq_ZERO -> 0
+    | f, [t] when f = Lazy.force coq_Zpos -> loop t
+    | f, [t] when f = Lazy.force coq_Zneg -> neg (loop t)
+    | f, [] when f = Lazy.force coq_Z0 -> zero
     | _ -> failwith "not a number"
 	  
 type constr_path =
@@ -443,13 +461,11 @@ type constr_path =
 let context operation path (t : constr) =
   let rec loop i p0 t = 
     match (p0,kind_of_term t) with 
-      | (p, Cast (c,t)) -> mkCast (loop i p c,t)
+      | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t)
       | ([], _) -> operation i t
       | ((P_APP n :: p),  App (f,v)) ->
-(*	  let f,l = get_applist t in   NECESSAIRE ??
-	  let v' = Array.of_list (f::l) in  *)
 	  let v' = Array.copy v in
-	  v'.(n-1) <- loop i p v'.(n-1); mkApp (f, v')
+	  v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v')
       | ((P_BRANCH n :: p), Case (ci,q,c,v)) ->
 	  (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *)
 	  let v' = Array.copy v in
@@ -462,13 +478,13 @@ let context operation path (t : constr) =
       | (p, Fix ((_,n as ln),(tys,lna,v))) ->
 	  let l = Array.length v in
 	  let v' = Array.copy v in
-	  v'.(n) <- loop (i+l) p v.(n); (mkFix (ln,(tys,lna,v')))
+	  v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v')))
       | ((P_BODY :: p), Prod (n,t,c)) ->
-	  (mkProd (n,t,loop (i+1) p c))
+	  (mkProd (n,t,loop (succ i) p c))
       | ((P_BODY :: p), Lambda (n,t,c)) ->
-	  (mkLambda (n,t,loop (i+1) p c))
+	  (mkLambda (n,t,loop (succ i) p c))
       | ((P_BODY :: p), LetIn (n,b,t,c)) ->
-	  (mkLetIn (n,b,t,loop (i+1) p c))
+	  (mkLetIn (n,b,t,loop (succ i) p c))
       | ((P_TYPE :: p), Prod (n,t,c)) ->
 	  (mkProd (n,loop i p t,c))
       | ((P_TYPE :: p), Lambda (n,t,c)) ->
@@ -476,16 +492,16 @@ let context operation path (t : constr) =
       | ((P_TYPE :: p), LetIn (n,b,t,c)) ->
 	  (mkLetIn (n,b,loop i p t,c))
       | (p, _) -> 
-	  ppnl (Printer.prterm t);
+	  ppnl (Printer.pr_lconstr t);
 	  failwith ("abstract_path " ^ string_of_int(List.length p)) 
   in
   loop 1 path t
 
 let occurence path (t : constr) =
   let rec loop p0 t = match (p0,kind_of_term t) with
-    | (p, Cast (c,t)) -> loop p c
+    | (p, Cast (c,_,_)) -> loop p c
     | ([], _) -> t
-    | ((P_APP n :: p),  App (f,v)) -> loop p v.(n-1)
+    | ((P_APP n :: p),  App (f,v)) -> loop p v.(pred n)
     | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n)
     | ((P_ARITY :: p),  App (f,_)) -> loop p f
     | ((P_ARG :: p),  App (f,v)) -> loop p v.(0)
@@ -497,7 +513,7 @@ let occurence path (t : constr) =
     | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term
     | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term
     | (p, _) -> 
-	ppnl (Printer.prterm t);
+	ppnl (Printer.pr_lconstr t);
 	failwith ("occurence " ^ string_of_int(List.length p)) 
   in
   loop path t
@@ -509,7 +525,7 @@ let abstract_path typ path t =
 
 let focused_simpl path gl =
   let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in
-  convert_concl_no_check newc gl
+  convert_concl_no_check newc DEFAULTcast gl
 
 let focused_simpl path = simpl_time (focused_simpl path)
 
@@ -518,7 +534,7 @@ type oformula =
   | Oinv of  oformula
   | Otimes of oformula * oformula
   | Oatom of identifier
-  | Oz of int
+  | Oz of bigint
   | Oufo of constr
 
 let rec oprint = function 
@@ -530,7 +546,7 @@ let rec oprint = function
       print_string "("; oprint t1; print_string "*"; 
       oprint t2; print_string ")"
   | Oatom s -> print_string (string_of_id s)
-  | Oz i -> print_int i
+  | Oz i -> print_string (string_of_bigint i)
   | Oufo f -> print_string "?"
 
 let rec weight = function
@@ -567,7 +583,7 @@ let rec decompile af =
   in
   loop af.body
 
-let mkNewMeta () = mkMeta (Clenv.new_meta())
+let mkNewMeta () = mkMeta (Evarutil.new_meta())
 
 let clever_rewrite_base_poly typ p result theorem gl = 
   let full = pf_concl gl in
@@ -606,7 +622,7 @@ let clever_rewrite p vpath t gl =
   let vargs = List.map (fun p -> occurence p occ) vpath in
   let t' = applist(t, (vargs @ [abstracted])) in
   exact (applist(t',[mkNewMeta()])) gl
-    
+
 let rec shuffle p (t1,t2) = 
   match t1,t2 with
     | Oplus(l1,r1), Oplus(l2,r2) ->
@@ -614,7 +630,7 @@ let rec shuffle p (t1,t2) =
           let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in
           (clever_rewrite p [[P_APP 1;P_APP 1]; 
 			     [P_APP 1; P_APP 2];[P_APP 2]]
-             (Lazy.force coq_fast_Zplus_assoc_r)
+             (Lazy.force coq_fast_Zplus_assoc_reverse)
            :: tac,
            Oplus(l1,t'))
 	else 
@@ -627,12 +643,12 @@ let rec shuffle p (t1,t2) =
 	if weight l1 > weight t2 then
           let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in
           clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
-            (Lazy.force coq_fast_Zplus_assoc_r)
+            (Lazy.force coq_fast_Zplus_assoc_reverse)
           :: tac, 
           Oplus(l1, t')
 	else 
           [clever_rewrite p [[P_APP 1];[P_APP 2]] 
-	     (Lazy.force coq_fast_Zplus_sym)],
+	     (Lazy.force coq_fast_Zplus_comm)],
           Oplus(t2,t1)
     | t1,Oplus(l2,r2) -> 
 	if weight l2 > weight t1 then
@@ -643,11 +659,11 @@ let rec shuffle p (t1,t2) =
           Oplus(l2,t')
 	else [],Oplus(t1,t2)
     | Oz t1,Oz t2 ->
-	[focused_simpl p], Oz(t1+t2)
+	[focused_simpl p], Oz(Bigint.add t1 t2)
     | t1,t2 ->
 	if weight t1 < weight t2 then
           [clever_rewrite p [[P_APP 1];[P_APP 2]] 
-	     (Lazy.force coq_fast_Zplus_sym)],
+	     (Lazy.force coq_fast_Zplus_comm)],
 	  Oplus(t2,t1)
 	else [],Oplus(t1,t2)
 	  
@@ -665,7 +681,7 @@ let rec shuffle_mult p_init k1 e1 k2 e2 =
                               [P_APP 2; P_APP 2]]
               (Lazy.force coq_fast_OMEGA10) 
 	  in
-          if k1*c1 + k2 * c2 = 0 then 
+          if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then 
             let tac' = 
 	      clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
                 (Lazy.force coq_fast_Zred_factor5) in
@@ -722,7 +738,7 @@ let rec shuffle_mult_right p_init e1 k2 e2 =
                [P_APP 2; P_APP 2]]
               (Lazy.force coq_fast_OMEGA15) 
 	  in
-          if c1 + k2 * c2 = 0 then 
+          if Bigint.add c1 (Bigint.mult k2 c2) =? zero then 
             let tac' = 
               clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
                 (Lazy.force coq_fast_Zred_factor5) 
@@ -732,7 +748,7 @@ let rec shuffle_mult_right p_init e1 k2 e2 =
           else tac :: loop (P_APP 2 :: p) (l1,l2)
 	else if v1 > v2 then
           clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
-            (Lazy.force coq_fast_Zplus_assoc_r) ::
+            (Lazy.force coq_fast_Zplus_assoc_reverse) ::
           loop (P_APP 2 :: p) (l1,l2')
 	else
           clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
@@ -744,7 +760,7 @@ let rec shuffle_mult_right p_init e1 k2 e2 =
           loop (P_APP 2 :: p) (l1',l2)
     | ({c=c1;v=v1}::l1), [] -> 
         clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
-          (Lazy.force coq_fast_Zplus_assoc_r) ::
+          (Lazy.force coq_fast_Zplus_assoc_reverse) ::
         loop (P_APP 2 :: p) (l1,[])
     | [],({c=c2;v=v2}::l2) -> 
         clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
@@ -765,7 +781,7 @@ let rec shuffle_cancel p = function
 	clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2];
                           [P_APP 2; P_APP 2]; 
                           [P_APP 1; P_APP 1; P_APP 2; P_APP 1]]
-          (if c1 > 0 then 
+          (if c1 >? zero then 
 	     (Lazy.force coq_fast_OMEGA13) 
 	   else 
 	     (Lazy.force coq_fast_OMEGA14)) 
@@ -777,15 +793,15 @@ let rec scalar p n = function
       let tac1,t1' = scalar (P_APP 1 :: p) n t1 and 
         tac2,t2' = scalar (P_APP 2 :: p) n t2 in
       clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]]
-        (Lazy.force coq_fast_Zmult_plus_distr) :: 
+        (Lazy.force coq_fast_Zmult_plus_distr_l) :: 
       (tac1 @ tac2), Oplus(t1',t2')
   | Oinv t ->
       [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] 
-	 (Lazy.force coq_fast_Zmult_Zopp_left);
-       focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(-n))
+	 (Lazy.force coq_fast_Zmult_opp_comm);
+       focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n))
   | Otimes(t1,Oz x) -> 
       [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]]
-         (Lazy.force coq_fast_Zmult_assoc_r);
+         (Lazy.force coq_fast_Zmult_assoc_reverse);
        focused_simpl (P_APP 2 :: p)], 
       Otimes(t1,Oz (n*x))
   | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products"
@@ -809,7 +825,7 @@ let rec norm_add p_init =
     | [] -> [focused_simpl p_init]
     | _:: l -> 
 	clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
-          (Lazy.force coq_fast_Zplus_assoc_r) ::
+          (Lazy.force coq_fast_Zplus_assoc_reverse) ::
 	loop (P_APP 2 :: p) l 
   in
   loop p_init
@@ -831,31 +847,31 @@ let rec negate p = function
       let tac1,t1' = negate (P_APP 1 :: p) t1 and 
         tac2,t2' = negate (P_APP 2 :: p) t2 in
       clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]]
-        (Lazy.force coq_fast_Zopp_Zplus) :: 
+        (Lazy.force coq_fast_Zopp_plus_distr) :: 
       (tac1 @ tac2),
       Oplus(t1',t2')
   | Oinv t ->
-      [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_Zopp)], t
+      [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t
   | Otimes(t1,Oz x) -> 
       [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]]
-         (Lazy.force coq_fast_Zopp_Zmult_r);
-       focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (-x))
+         (Lazy.force coq_fast_Zopp_mult_distr_r);
+       focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x))
   | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products"
   | (Oatom _ as t) ->
-      let r = Otimes(t,Oz(-1)) in
-      [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_one)], r
-  | Oz i -> [focused_simpl p],Oz(-i)
+      let r = Otimes(t,Oz(negone)) in
+      [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r
+  | Oz i -> [focused_simpl p],Oz(neg i)
   | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |]))
       
 let rec transform p t = 
-  let default () =
+  let default isnat t' =
     try 
-      let v,th,_ = find_constr t in
+      let v,th,_ = find_constr t' in
       [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
     with _ -> 
       let v = new_identifier_var ()
       and th = new_identifier () in
-      hide_constr t v th false;
+      hide_constr t' v th isnat;
       [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
   in
   try match destructurate_term t with
@@ -870,10 +886,10 @@ let rec transform p t =
 	    (mkApp (Lazy.force coq_Zplus,
 		     [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in
 	unfold sp_Zminus :: tac,t
-    | Kapp(Zs,[t1]) ->
+    | Kapp(Zsucc,[t1]) ->
 	let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
-					 [| t1; mk_integer 1 |])) in
-	unfold sp_Zs :: tac,t
+					 [| t1; mk_integer one |])) in
+	unfold sp_Zsucc :: tac,t
    | Kapp(Zmult,[t1;t2]) ->
        let tac1,t1' = transform (P_APP 1 :: p) t1 
        and tac2,t2' = transform (P_APP 2 :: p) t2 in
@@ -882,40 +898,32 @@ let rec transform p t =
          | (Oz n,_) ->
              let sym = 
 	       clever_rewrite p [[P_APP 1];[P_APP 2]] 
-		 (Lazy.force coq_fast_Zmult_sym) in
+		 (Lazy.force coq_fast_Zmult_comm) in
              let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t'
-         | _ -> default ()
+         | _ -> default false t
        end
-   | Kapp((POS|NEG|ZERO),_) -> 
-       (try ([],Oz(recognize_number t)) with _ -> default ())
+   | Kapp((Zpos|Zneg|Z0),_) -> 
+       (try ([],Oz(recognize_number t)) with _ -> default false t)
    | Kvar s -> [],Oatom s
    | Kapp(Zopp,[t]) ->
        let tac,t' = transform (P_APP 1 :: p) t in
        let tac',t'' = negate p t' in
        tac @ tac', t''
-   | Kapp(Inject_nat,[t']) ->
-       begin try 
-         let v,th,_ = find_constr t' in 
-         [clever_rewrite_base p (mkVar v) (mkVar th)],Oatom v
-       with _ -> 
-         let v = new_identifier_var () and th = new_identifier () in
-         hide_constr t' v th true;
-         [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
-       end
-   | _ -> default ()
-  with e when catchable_exception e -> default ()
+   | Kapp(Z_of_nat,[t']) -> default true t'
+   | _ -> default false t
+  with e when catchable_exception e -> default false t
       
 let shrink_pair p f1 f2 =
   match f1,f2 with
     | Oatom v,Oatom _ -> 
-	let r = Otimes(Oatom v,Oz 2) in
+	let r = Otimes(Oatom v,Oz two) in
 	clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r
     | Oatom v, Otimes(_,c2) -> 
-	let r = Otimes(Oatom v,Oplus(c2,Oz 1)) in
+	let r = Otimes(Oatom v,Oplus(c2,Oz one)) in
 	clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] 
 	  (Lazy.force coq_fast_Zred_factor2), r
     | Otimes (v1,c1),Oatom v -> 
-	let r = Otimes(Oatom v,Oplus(c1,Oz 1)) in
+	let r = Otimes(Oatom v,Oplus(c1,Oz one)) in
 	clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]]
           (Lazy.force coq_fast_Zred_factor3), r
     | Otimes (Oatom v,c1),Otimes (v2,c2) ->
@@ -931,13 +939,13 @@ let shrink_pair p f1 f2 =
 
 let reduce_factor p = function
   | Oatom v ->
-      let r = Otimes(Oatom v,Oz 1) in
+      let r = Otimes(Oatom v,Oz one) in
       [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r
   | Otimes(Oatom v,Oz n) as f -> [],f
   | Otimes(Oatom v,c) ->
       let rec compute = function
         | Oz n -> n
-	| Oplus(t1,t2) -> compute t1 + compute t2 
+	| Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2)
 	| _ -> error "condense.1" 
       in
       [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c))
@@ -950,7 +958,7 @@ let rec condense p = function
 	let assoc_tac = 
           clever_rewrite p 
             [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
-            (Lazy.force coq_fast_Zplus_assoc_l) in
+            (Lazy.force coq_fast_Zplus_assoc) in
 	let tac_list,t' = condense p (Oplus(t,r)) in
 	(assoc_tac :: shrink_tac :: tac_list), t'
       end else begin
@@ -958,7 +966,7 @@ let rec condense p = function
 	let tac',t' = condense (P_APP 2 :: p) t in 
 	(tac @ tac'), Oplus(f,t') 
       end
-  | Oplus(f1,Oz n) as t -> 
+  | Oplus(f1,Oz n) -> 
       let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n)
   | Oplus(f1,f2) -> 
       if weight f1 = weight f2 then begin
@@ -973,12 +981,12 @@ let rec condense p = function
   | Oz _ as t -> [],t
   | t -> 
       let tac,t' = reduce_factor p t in
-      let final = Oplus(t',Oz 0) in
+      let final = Oplus(t',Oz zero) in
       let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in
       tac @ [tac'], final
 
 let rec clear_zero p = function
-  | Oplus(Otimes(Oatom v,Oz 0),r) ->
+  | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero ->
       let tac =
 	clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] 
 	  (Lazy.force coq_fast_Zred_factor5) in
@@ -992,7 +1000,7 @@ let replay_history tactic_normalisation =
   let aux  = id_of_string "auxiliary" in
   let aux1 = id_of_string "auxiliary_1" in
   let aux2 = id_of_string "auxiliary_2" in
-  let zero = mk_integer 0 in
+  let izero = mk_integer zero in
   let rec loop t =
     match t with
       | HYP e :: l -> 
@@ -1007,7 +1015,7 @@ let replay_history tactic_normalisation =
 	  and eq2 = decompile e2 in 
 	  let id1 = hyp_of_tag e1.id 
 	  and id2 = hyp_of_tag e2.id in
-	  let k = if b then (-1) else 1 in
+	  let k = if b then negone else one in
 	  let p_initial = [P_APP 1;P_TYPE] in
 	  let tac= shuffle_mult_right p_initial e1.body k e2.body in
 	  tclTHENLIST [
@@ -1028,11 +1036,10 @@ let replay_history tactic_normalisation =
 	  let p_initial = [P_APP 2;P_TYPE] in
 	  let tac = shuffle_cancel p_initial e1.body in
 	  let solve_le =
-            let superieur = Lazy.force coq_SUPERIEUR in
             let not_sup_sup = mkApp (build_coq_eq (), [| 
-					Lazy.force coq_relation; 
-					Lazy.force coq_SUPERIEUR;
-					Lazy.force coq_SUPERIEUR |])
+					Lazy.force coq_comparison; 
+					Lazy.force coq_Gt;
+					Lazy.force coq_Gt |])
 	    in
             tclTHENS 
 	      (tclTHENLIST [
@@ -1070,7 +1077,7 @@ let replay_history tactic_normalisation =
 		  (intros_using [id]);
 		  (cut (mk_gt kk dd)) ])
 	        [ tclTHENS 
-		    (cut (mk_gt kk zero)) 
+		    (cut (mk_gt kk izero)) 
 		    [ tclTHENLIST [
 		        (intros_using [aux1; aux2]);
 		        (generalize_tac 
@@ -1088,20 +1095,16 @@ let replay_history tactic_normalisation =
 	      tclTHEN (mk_then tac) reflexivity ]
 	    
       | NOT_EXACT_DIVIDE (e1,k) :: l ->
-	  let id = hyp_of_tag e1.id in
 	  let c = floor_div e1.constant k in
-	  let d = e1.constant - c * k in
+	  let d = Bigint.sub e1.constant (Bigint.mult c k) in
 	  let e2 =  {id=e1.id; kind=EQUA;constant = c; 
                      body = map_eq_linear (fun c -> c / k) e1.body } in
-	  let eq1 = val_of(decompile e1) 
-	  and eq2 = val_of(decompile e2) in
+	  let eq2 = val_of(decompile e2) in
 	  let kk = mk_integer k 
 	  and dd = mk_integer d in
-	  let rhs = mk_plus (mk_times eq2 kk) dd in
-	  let state_eq = mk_eq eq1 rhs in
 	  let tac = scalar_norm_add [P_APP 2] e2.body in
 	  tclTHENS 
-	    (cut (mk_gt dd zero)) 
+	    (cut (mk_gt dd izero)) 
 	    [ tclTHENS (cut (mk_gt kk dd)) 
 		[tclTHENLIST [
 		  (intros_using [aux2;aux1]);
@@ -1147,7 +1150,7 @@ let replay_history tactic_normalisation =
             tclTHENS (cut state_eq) 
 	      [
 		tclTHENS 
-		 (cut (mk_gt kk zero)) 
+		 (cut (mk_gt kk izero)) 
 		 [tclTHENLIST [
 		   (intros_using [aux2;aux1]);
 		   (generalize_tac 
@@ -1170,7 +1173,7 @@ let replay_history tactic_normalisation =
 	  and eq2 = val_of (decompile (negate_eq e1)) in
 	  let tac = 
 	    clever_rewrite [P_APP 3] [[P_APP 1]] 
-	      (Lazy.force coq_fast_Zopp_one) ::
+	      (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
             scalar_norm [P_APP 3] e1.body 
 	  in
 	  tclTHENS 
@@ -1184,13 +1187,13 @@ let replay_history tactic_normalisation =
 	      (loop l) ];
             tclTHEN (mk_then tac) reflexivity]
 	    
-      | STATE(new_eq,def,orig,m,sigma) :: l ->
+      | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l ->
 	  let id = new_identifier () 
 	  and id2 = hyp_of_tag orig.id in
-	  tag_hypothesis id new_eq.id;
+	  tag_hypothesis id e.id;
 	  let eq1 = val_of(decompile def) 
 	  and eq2 = val_of(decompile orig) in
-	  let vid = unintern_id sigma in
+	  let vid = unintern_id v in
 	  let theorem =
             mkApp (build_coq_ex (), [| 
 		      Lazy.force coq_Z;
@@ -1201,12 +1204,11 @@ let replay_history tactic_normalisation =
 	  in
 	  let mm = mk_integer m in
 	  let p_initial = [P_APP 2;P_TYPE] in
-	  let r = mk_plus eq2 (mk_times (mk_plus (mk_inv (mkVar vid)) eq1) mm) in
 	  let tac = 
             clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) 
-              [[P_APP 1]] (Lazy.force coq_fast_Zopp_one) ::
+              [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
             shuffle_mult_right p_initial
-              orig.body m ({c= -1;v=sigma}::def.body) in
+              orig.body m ({c= negone;v= v}::def.body) in
 	  tclTHENS 
 	    (cut theorem)  
 	    [tclTHENLIST [
@@ -1241,7 +1243,7 @@ let replay_history tactic_normalisation =
 	  and id2 = hyp_of_tag e2.id in
 	  let eq1 = val_of(decompile e1) 
 	  and eq2 = val_of(decompile e2) in
-	  if k1 = 1 & e2.kind = EQUA then
+	  if k1 =? one & e2.kind = EQUA then
             let tac_thm =
               match e1.kind with
 		| EQUA -> Lazy.force coq_OMEGA5 
@@ -1264,9 +1266,9 @@ let replay_history tactic_normalisation =
 	    and kk2 = mk_integer k2 in
 	    let p_initial = [P_APP 2;P_TYPE] in
 	    let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in
-            tclTHENS (cut (mk_gt kk1 zero)) 
+            tclTHENS (cut (mk_gt kk1 izero)) 
 	      [tclTHENS 
-		 (cut (mk_gt kk2 zero)) 
+		 (cut (mk_gt kk2 izero)) 
 		 [tclTHENLIST [
 		   (intros_using [aux2;aux1]);
 		   (generalize_tac
@@ -1345,7 +1347,7 @@ let destructure_omega gl tac_def (id,c) =
 	  normalize_equation
 	    id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def
       | Kapp(Zlt,[t1;t2]) ->
-	  let t = mk_plus (mk_plus t2 (mk_integer (-1))) (mk_inv t1) in
+	  let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in
 	  normalize_equation
 	    id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def
       | Kapp(Zge,[t1;t2]) ->
@@ -1353,7 +1355,7 @@ let destructure_omega gl tac_def (id,c) =
 	  normalize_equation
 	    id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def
       | Kapp(Zgt,[t1;t2]) ->
-	  let t = mk_plus (mk_plus t1 (mk_integer (-1))) (mk_inv t2) in
+	  let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in
 	  normalize_equation
 	    id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def
       | _ -> tac_def
@@ -1362,7 +1364,7 @@ let destructure_omega gl tac_def (id,c) =
 let reintroduce id =
   (* [id] cannot be cleared if dependent: protect it by a try *)
   tclTHEN (tclTRY (clear [id])) (intro_using id)
-      
+
 let coq_omega gl =
   clear_tables ();
   let tactic_normalisation, system = 
@@ -1382,8 +1384,8 @@ let coq_omega gl =
 	     (intros_using [th;id]);
 	     tac ]),
            {kind = INEQ; 
-	    body = [{v=intern_id v; c=1}]; 
-            constant = 0; id = i} :: sys
+	    body = [{v=intern_id v; c=one}]; 
+            constant = zero; id = i} :: sys
 	 else
            (tclTHENLIST [
 	     (simplest_elim (applist (Lazy.force coq_new_var, [t])));
@@ -1393,17 +1395,19 @@ let coq_omega gl =
       (tclIDTAC,[]) (dump_tables ())
   in
   let system = system @ sys in
-  if !display_system_flag then display_system system;
+  if !display_system_flag then display_system display_var system;
   if !old_style_flag then begin
-    try let _ = simplify false system in tclIDTAC gl
+    try 
+      let _ = simplify (new_id,new_var_num,display_var) false system in
+      tclIDTAC gl
     with UNSOLVABLE -> 
       let _,path = depend [] [] (history ()) in
-      if !display_action_flag then display_action path;
+      if !display_action_flag then display_action display_var path;
       (tclTHEN prelude (replay_history tactic_normalisation path)) gl 
   end else begin 
     try
-      let path = simplify_strong system in
-      if !display_action_flag then display_action path; 
+      let path = simplify_strong (new_id,new_var_num,display_var) system in
+      if !display_action_flag then display_action display_var path; 
       (tclTHEN prelude (replay_history tactic_normalisation path)) gl
     with NO_CONTRADICTION -> error "Omega can't solve this system"
   end
@@ -1411,8 +1415,6 @@ let coq_omega gl =
 let coq_omega = solver_time coq_omega
 
 let nat_inject gl =
-  let aux = id_of_string "auxiliary" in
-  let table = Hashtbl.create 7 in
   let rec explore p t = 
     try match destructurate_term t with
       | Kapp(Plus,[t1;t2]) ->
@@ -1444,7 +1446,7 @@ let nat_inject gl =
 		(explore (P_APP 1 :: p) t1);
 		(explore (P_APP 2 :: p) t2) ];
 	      (tclTHEN 
-		 (clever_rewrite_gen p (mk_integer 0)
+		 (clever_rewrite_gen p (mk_integer zero)
                     ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))
 		 (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])]))
 	    ]
@@ -1461,7 +1463,7 @@ let nat_inject gl =
 		Kapp(S,[t]) ->
                   (tclTHEN 
                      (clever_rewrite_gen p 
-			(mkApp (Lazy.force coq_Zs, [| mk_inj t |]))
+			(mkApp (Lazy.force coq_Zsucc, [| mk_inj t |]))
 			((Lazy.force coq_inj_S),[t])) 
 		     (loop (P_APP 1 :: p) t))
               | _ -> explore p t 
@@ -1564,7 +1566,7 @@ let rec decidability gl t =
           | Kapp(Nat,[]) ->  mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |])
           | _ -> errorlabstrm "decidability" 
 		(str "Omega: Can't solve a goal with equality on " ++ 
-		   Printer.prterm typ)
+		   Printer.pr_lconstr typ)
 	end
     | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |])
     | Kapp(Zle,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |])
@@ -1665,25 +1667,25 @@ let destructure_hyps gl =
 		| Kapp(Zle, [t1;t2]) ->
                     tclTHENLIST [
 		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_Zle, [| t1;t2;mkVar i|])]);
+                        [mkApp (Lazy.force coq_Znot_le_gt, [| t1;t2;mkVar i|])]);
 		      (onClearedName i (fun _ -> loop lit))
                     ]
 		| Kapp(Zge, [t1;t2]) ->
                     tclTHENLIST [
 		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_Zge, [| t1;t2;mkVar i|])]);
+                        [mkApp (Lazy.force coq_Znot_ge_lt, [| t1;t2;mkVar i|])]);
 		      (onClearedName i (fun _ -> loop lit))
                     ]
 		| Kapp(Zlt, [t1;t2]) ->
                     tclTHENLIST [
 		      (generalize_tac 
-                        [mkApp (Lazy.force coq_not_Zlt, [| t1;t2;mkVar i|])]);
+                        [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]);
 		      (onClearedName i (fun _ -> loop lit))
                     ]
 		| Kapp(Zgt, [t1;t2]) ->
                     tclTHENLIST [
 		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_Zgt, [| t1;t2;mkVar i|])]);
+                        [mkApp (Lazy.force coq_Znot_gt_le, [| t1;t2;mkVar i|])]);
 		      (onClearedName i (fun _ -> loop lit))
                     ]
 		| Kapp(Le, [t1;t2]) ->
@@ -1776,7 +1778,7 @@ let destructure_goal gl =
 let destructure_goal = all_time (destructure_goal)
 
 let omega_solver gl =
-  Library.check_required_library ["Coq";"omega";"Omega"];
+  Coqlib.check_required_library ["Coq";"omega";"Omega"];
   let result = destructure_goal gl in 
   (* if !display_time_flag then begin text_time (); 
      flush Pervasives.stdout end; *)
diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4
index 726cf8bc..01592ebe 100644
--- a/contrib/omega/g_omega.ml4
+++ b/contrib/omega/g_omega.ml4
@@ -15,10 +15,10 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_omega.ml4,v 1.1.12.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: g_omega.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
 
 open Coq_omega
 
-TACTIC EXTEND Omega
-  [ "Omega" ] -> [ omega_solver ]
+TACTIC EXTEND omega
+  [ "omega" ] -> [ omega_solver ]
 END
diff --git a/contrib/omega/omega.ml b/contrib/omega/omega.ml
index f0eb1e78..fd774c16 100755..100644
--- a/contrib/omega/omega.ml
+++ b/contrib/omega/omega.ml
@@ -11,52 +11,75 @@
 (*                                                                        *)
 (* Pierre Crégut (CNET, Lannion, France)                                  *)
 (*                                                                        *)
+(* 13/10/2002 : modified to cope with an external numbering of equations  *)
+(*   and hypothesis. Its use for Omega is not more complex and it makes   *)
+(*   things much simpler for the reflexive version where we should limit  *)
+(*   the number of source of numbering.                                   *)
 (**************************************************************************)
 
-(* $Id: omega.ml,v 1.7.2.2 2005/02/17 18:25:20 herbelin Exp $ *) 
-
-open Util
-open Hashtbl
 open Names
 
-let flat_map f =
- let rec flat_map_f = function
-   | [] -> [] 
-   | x :: l -> f x @ flat_map_f l
- in 
- flat_map_f
-
-let pp i = print_int i; print_newline (); flush stdout
+module type INT = sig
+  type bigint
+  val less_than : bigint -> bigint -> bool
+  val add : bigint -> bigint -> bigint
+  val sub : bigint -> bigint -> bigint
+  val mult : bigint -> bigint -> bigint
+  val euclid : bigint -> bigint -> bigint * bigint
+  val neg : bigint -> bigint
+  val zero : bigint
+  val one : bigint
+  val to_string : bigint -> string
+end
 
 let debug = ref false
 
-let filter = List.partition
+module MakeOmegaSolver (Int:INT) = struct
+
+type bigint = Int.bigint
+let (<?) = Int.less_than
+let (<=?) x y = Int.less_than x y or x = y
+let (>?) x y = Int.less_than y x
+let (>=?) x y = Int.less_than y x or x = y
+let (=?) = (=)
+let (+) = Int.add
+let (-) = Int.sub
+let ( * ) = Int.mult
+let (/) x y = fst (Int.euclid x y)
+let (mod) x y = snd (Int.euclid x y)
+let zero = Int.zero
+let one = Int.one
+let two = one + one
+let negone = Int.neg one
+let abs x = if Int.less_than x zero then Int.neg x else x
+let string_of_bigint = Int.to_string
+let neg = Int.neg
+
+(* To ensure that polymorphic (<) is not used mistakenly on big integers *)
+(* Warning: do not use (=) either on big int *)
+let (<) = ((<) : int -> int -> bool)
+let (>) = ((>) : int -> int -> bool)
+let (<=) = ((<=) : int -> int -> bool)
+let (>=) = ((>=) : int -> int -> bool)
+
+let pp i = print_int i; print_newline (); flush stdout
 
 let push v l = l := v :: !l
 
-let rec pgcd x y = if y = 0 then x else pgcd y (x mod y)
+let rec pgcd x y = if y =? zero then x else pgcd y (x mod y)
 
 let pgcd_l = function
   | [] -> failwith "pgcd_l"
   | x :: l -> List.fold_left pgcd x l
 
 let floor_div a b =
-  match a >=0 , b > 0 with
+  match a >=? zero , b >? zero with
     | true,true -> a / b
     | false,false -> a / b
-    | true, false -> (a-1) / b - 1
-    | false,true  -> (a+1) / b - 1
+    | true, false -> (a-one) / b - one
+    | false,true  -> (a+one) / b - one
 
-let new_id =
-  let cpt = ref 0 in fun () -> incr cpt; ! cpt
-
-let new_var =
-  let cpt = ref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt)
-    
-let new_var_num =
-  let cpt = ref 1000 in (fun () -> incr cpt; !cpt)
-					  
-type coeff = {c: int ; v: int}
+type coeff = {c: bigint ; v: int}
 
 type linear = coeff list
 
@@ -70,60 +93,63 @@ type afine = {
   (* the variables and their coefficient *)
   body: coeff list; 
   (* a constant *)
-  constant: int }
+  constant: bigint }
+
+type state_action = {
+  st_new_eq : afine;
+  st_def    : afine;
+  st_orig   : afine;
+  st_coef   : bigint;
+  st_var    : int }
 
 type action =
-  | DIVIDE_AND_APPROX of afine * afine * int * int
-  | NOT_EXACT_DIVIDE of afine * int
+  | DIVIDE_AND_APPROX of afine * afine * bigint * bigint
+  | NOT_EXACT_DIVIDE of afine * bigint
   | FORGET_C of int
-  | EXACT_DIVIDE of afine * int
-  | SUM of int * (int * afine) * (int * afine)
-  | STATE of afine * afine * afine * int * int
+  | EXACT_DIVIDE of afine * bigint
+  | SUM of int * (bigint * afine) * (bigint * afine)
+  | STATE of state_action 
   | HYP of afine
   | FORGET   of int * int
   | FORGET_I of int * int
   | CONTRADICTION of afine * afine
   | NEGATE_CONTRADICT of afine * afine * bool
-  | MERGE_EQ of int * afine * int 
-  | CONSTANT_NOT_NUL of int * int
+  | MERGE_EQ of int * afine * int
+  | CONSTANT_NOT_NUL of int * bigint
   | CONSTANT_NUL of int
-  | CONSTANT_NEG of int * int
+  | CONSTANT_NEG of int * bigint
   | SPLIT_INEQ of afine * (int * action list) * (int * action list)
-  | WEAKEN of int * int
+  | WEAKEN of int * bigint
 
 exception UNSOLVABLE
 
 exception NO_CONTRADICTION
 
-let intern_id,unintern_id =
-  let cpt = ref 0 in
-  let table = create 7 and co_table = create 7 in
-  (fun (name : identifier) -> 
-     try find table name with Not_found -> 
-       let idx = !cpt in
-       add table name idx; add co_table idx name; incr cpt; idx),
-  (fun idx -> 
-     try find co_table idx with Not_found -> 
-       let v = new_var () in add table v idx; add co_table idx v; v)
-
-let display_eq (l,e) =
+let display_eq print_var (l,e) =
   let _ = 
     List.fold_left 
       (fun not_first f ->
 	 print_string 
-	   (if f.c < 0 then "- " else if not_first then "+ " else "");
+	   (if f.c <? zero then "- " else if not_first then "+ " else "");
 	 let c = abs f.c in
-	 if c = 1 then 
-	   Printf.printf "%s " (string_of_id (unintern_id f.v))
+	 if c =? one then 
+	   Printf.printf "%s " (print_var f.v)
 	 else 
-	   Printf.printf "%d %s " c (string_of_id (unintern_id f.v)); 
+	   Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); 
 	 true)
       false l
   in
-  if e > 0 then 
-    Printf.printf "+ %d " e 
-  else if e < 0 then 
-    Printf.printf "- %d " (abs e)
+  if e >? zero then 
+    Printf.printf "+ %s " (string_of_bigint e)
+  else if e <? zero then 
+    Printf.printf "- %s " (string_of_bigint (abs e))
+
+let rec trace_length l =
+  let action_length accu = function
+    | SPLIT_INEQ (_,(_,l1),(_,l2)) ->
+	accu + one + trace_length l1 + trace_length l2
+    | _ -> accu + one in
+  List.fold_left action_length zero l
 
 let operator_of_eq = function 
   | EQUA -> "=" | DISE -> "!=" | INEQ -> ">="
@@ -131,49 +157,51 @@ let operator_of_eq = function
 let kind_of = function
   | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation"
 
-let display_system l = 
+let display_system print_var l = 
   List.iter 
     (fun { kind=b; body=e; constant=c; id=id} -> 
-       print_int id; print_string ": ";
-       display_eq (e,c); print_string (operator_of_eq b);
-       print_string "0\n") 
+       Printf.printf "E%d: " id;
+       display_eq print_var (e,c);
+       Printf.printf "%s 0\n" (operator_of_eq b))
     l;
   print_string "------------------------\n\n"
 
-let display_inequations l = 
-  List.iter (fun e -> display_eq e;print_string ">= 0\n") l;
+let display_inequations print_var l = 
+  List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l;
   print_string "------------------------\n\n"
 
-let rec display_action = function
+let sbi = string_of_bigint
+
+let rec display_action print_var = function
   | act :: l -> begin match act with
       | DIVIDE_AND_APPROX (e1,e2,k,d) ->
           Printf.printf 
-            "Inequation E%d is divided by %d and the constant coefficient is \
-            rounded by substracting %d.\n" e1.id k d
+            "Inequation E%d is divided by %s and the constant coefficient is \
+            rounded by substracting %s.\n" e1.id (sbi k) (sbi d)
       | NOT_EXACT_DIVIDE (e,k) ->
           Printf.printf
             "Constant in equation E%d is not divisible by the pgcd \
-            %d of its other coefficients.\n" e.id k
+            %s of its other coefficients.\n" e.id (sbi k)
       | EXACT_DIVIDE (e,k) ->
           Printf.printf
             "Equation E%d is divided by the pgcd \
-            %d of its coefficients.\n" e.id k
+            %s of its coefficients.\n" e.id (sbi k)
       | WEAKEN (e,k) ->
           Printf.printf 
             "To ensure a solution in the dark shadow \
-            the equation E%d is weakened by %d.\n" e k
+            the equation E%d is weakened by %s.\n" e (sbi k)
       | SUM (e,(c1,e1),(c2,e2)) -> 
           Printf.printf
-            "We state %s E%d = %d %s E%d + %d %s E%d.\n" 
-            (kind_of e1.kind) e c1 (kind_of e1.kind) e1.id c2 
+            "We state %s E%d = %s %s E%d + %s %s E%d.\n" 
+            (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2)
             (kind_of e2.kind) e2.id
-      | STATE (e,_,_,x,_) ->
-          Printf.printf "We define a new equation %d :" e.id; 
-          display_eq (e.body,e.constant); 
-          print_string (operator_of_eq e.kind); print_string " 0\n"
+      | STATE { st_new_eq = e } ->
+          Printf.printf "We define a new equation E%d: " e.id; 
+          display_eq print_var (e.body,e.constant); 
+          print_string (operator_of_eq e.kind); print_string " 0"
       | HYP e ->   
-          Printf.printf "We define %d :" e.id; 
-          display_eq (e.body,e.constant); 
+          Printf.printf "We define E%d: " e.id; 
+          display_eq print_var (e.body,e.constant); 
           print_string (operator_of_eq e.kind); print_string " 0\n"
       | FORGET_C e ->  Printf.printf "E%d is trivially satisfiable.\n" e
       | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
@@ -182,33 +210,34 @@ let rec display_action = function
          Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e
       | CONTRADICTION (e1,e2) -> 
           Printf.printf
-            "equations E%d and E%d implie a contradiction on their \
+            "Equations E%d and E%d imply a contradiction on their \
             constant factors.\n" e1.id e2.id
       | NEGATE_CONTRADICT(e1,e2,b) ->
           Printf.printf
-            "Eqations E%d and E%d state that their body is at the same time
+            "Equations E%d and E%d state that their body is at the same time
             equal and different\n" e1.id e2.id
       | CONSTANT_NOT_NUL (e,k) -> 
-          Printf.printf "equation E%d states %d=0.\n" e k
+          Printf.printf "Equation E%d states %s = 0.\n" e (sbi k)
       | CONSTANT_NEG(e,k) -> 
-          Printf.printf "equation E%d states %d >= 0.\n" e k
+          Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k)
       | CONSTANT_NUL e ->
-          Printf.printf "inequation E%d states 0 != 0.\n" e
+          Printf.printf "Inequation E%d states 0 != 0.\n" e
       | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> 
-          Printf.printf "equation E%d is split in E%d and E%d\n\n" e.id e1 e2;
-          display_action l1;
+          Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2;
+          display_action print_var l1;
           print_newline ();
-          display_action l2;
+          display_action print_var l2;
           print_newline ()
-    end; display_action l
+    end; display_action print_var l
   | [] -> 
       flush stdout
 
-(*""*)
+let default_print_var v = Printf.sprintf "X%d" v (* For debugging *)
 
+(*""*)
 let add_event, history, clear_history =
   let accu = ref [] in
-  (fun (v : action) -> if !debug then display_action [v]; push v accu), 
+  (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu),
   (fun () -> !accu),
   (fun () -> accu := [])
 
@@ -218,7 +247,7 @@ let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x))
 
 let map_eq_linear f = 
   let rec loop = function
-    | x :: l -> let c = f x.c in if c=0 then loop l else {v=x.v; c=c} :: loop l
+    | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l
     | [] -> [] 
   in
   loop
@@ -227,28 +256,28 @@ let map_eq_afine f e =
   { id = e.id; kind = e.kind; body = map_eq_linear f e.body; 
     constant = f e.constant }
 
-let negate_eq = map_eq_afine (fun x -> -x)
+let negate_eq = map_eq_afine (fun x -> neg x)
 
 let rec sum p0 p1 = match (p0,p1) with 
   | ([], l) -> l | (l, []) -> l
   | (((x1::l1) as l1'), ((x2::l2) as l2')) -> 
       if x1.v = x2.v then
 	let c = x1.c + x2.c in
-	if c = 0 then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2
+	if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2
       else if x1.v > x2.v then 
 	x1 :: sum l1 l2'
       else 
 	x2 :: sum l1' l2
 
-let sum_afine eq1 eq2 = 
-  { kind = eq1.kind; id = new_id ();
+let sum_afine new_eq_id eq1 eq2 = 
+  { kind = eq1.kind; id = new_eq_id ();
     body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant }
 
 exception FACTOR1
 
 let rec chop_factor_1 = function
   | x :: l -> 
-      if abs x.c = 1 then x,l else let (c',l') = chop_factor_1 l in (c',x::l')
+    if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l')
   | [] -> raise FACTOR1
 
 exception CHOPVAR
@@ -261,24 +290,24 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
   if e = [] then begin 
     match eq_flag with
       | EQUA ->
-          if x =0 then [] else begin
+          if x =? zero then [] else begin
             add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE
          end
       | DISE ->
-          if x <> 0 then [] else begin
+          if x <> zero then [] else begin
             add_event (CONSTANT_NUL id); raise UNSOLVABLE
           end
       | INEQ ->
-          if x >= 0 then [] else begin
+          if x >=? zero then [] else begin
             add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE
           end
   end else
     let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in
-    if eq_flag=EQUA & x mod gcd <> 0 then begin
+    if eq_flag=EQUA & x mod gcd <> zero then begin
       add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE
-    end else if eq_flag=DISE & x mod gcd <> 0 then begin
+    end else if eq_flag=DISE & x mod gcd <> zero then begin
       add_event (FORGET_C eq.id); []
-    end else if gcd <> 1 then begin
+    end else if gcd <> one then begin
       let c = floor_div x gcd in
       let d = x - c * gcd in
       let new_eq = {id=id; kind=eq_flag; constant=c; 
@@ -288,97 +317,107 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
       [new_eq]
     end else [eq]
 
-let eliminate_with_in {v=v;c=c_unite} eq2
+let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2
                         ({body=e1; constant=c1} as eq1) =
   try
     let (f,_) = chop_var v e1 in 
-    let coeff = if c_unite=1 then -f.c else if c_unite= -1 then f.c 
+    let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c 
                 else failwith "eliminate_with_in" in
-    let res = sum_afine eq1 (map_eq_afine (fun c -> c * coeff) eq2) in
-    add_event (SUM (res.id,(1,eq1),(coeff,eq2))); res
+    let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in
+    add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res
   with CHOPVAR -> eq1
 
-let omega_mod a b = a - b * floor_div (2 * a + b) (2 * b)
-let banerjee_step original l1 l2 = 
+let omega_mod a b = a - b * floor_div (two * a + b) (two * b)
+let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = 
   let e = original.body in
-  let sigma = new_var_num () in
+  let sigma = new_var_id () in
   let smallest,var =
     try
-      List.fold_left (fun (v,p) c ->  if v > (abs c.c) then abs c.c,c.v else (v,p))
+      List.fold_left (fun (v,p) c ->  if v >? (abs c.c) then abs c.c,c.v else (v,p))
               (abs (List.hd e).c, (List.hd e).v) (List.tl e)
-    with Failure "tl" -> display_system [original] ; failwith "TL" in
-  let m = smallest + 1 in
+    with Failure "tl" -> display_system print_var [original] ; failwith "TL" in
+  let m = smallest + one in
   let new_eq =
     { constant = omega_mod original.constant m;
-      body = {c= -m;v=sigma} :: 
+      body = {c= neg m;v=sigma} :: 
              map_eq_linear (fun a -> omega_mod a m) original.body;
-      id = new_id (); kind = EQUA } in
+      id = new_eq_id (); kind = EQUA } in
   let definition =
-    { constant = - floor_div (2 * original.constant + m) (2 * m);
-      body = map_eq_linear (fun a -> - floor_div (2 * a + m) (2 * m))
+    { constant = neg (floor_div (two * original.constant + m) (two * m));
+      body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m)))
                              original.body;
-      id = new_id (); kind = EQUA } in
-  add_event (STATE (new_eq,definition,original,m,sigma));
+      id = new_eq_id (); kind = EQUA } in
+  add_event (STATE {st_new_eq = new_eq; st_def = definition;
+		    st_orig = original; st_coef = m; st_var = sigma});
   let new_eq = List.hd (normalize new_eq) in
   let eliminated_var, def = chop_var var new_eq.body in
   let other_equations = 
-    flat_map (fun e -> normalize (eliminate_with_in eliminated_var new_eq e))
-             l1 in
+    Util.list_map_append
+      (fun e -> 
+        normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in
   let inequations = 
-    flat_map (fun e -> normalize (eliminate_with_in eliminated_var new_eq e))
-             l2 in
-  let original' = eliminate_with_in eliminated_var new_eq original in
+    Util.list_map_append
+      (fun e ->
+        normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in
+  let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in
   let mod_original = map_eq_afine (fun c -> c / m) original' in
   add_event (EXACT_DIVIDE (original',m));
   List.hd (normalize mod_original),other_equations,inequations
 
-let rec eliminate_one_equation (e,other,ineqs) = 
-  if !debug then display_system (e::other);
+let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = 
+  if !debug then display_system print_var (e::other);
   try
     let v,def = chop_factor_1 e.body in
-    (flat_map (fun e' -> normalize (eliminate_with_in v e e')) other,
-     flat_map (fun e' -> normalize (eliminate_with_in v e e')) ineqs)
-  with FACTOR1 -> eliminate_one_equation (banerjee_step e other ineqs)
-
-let rec banerjee (sys_eq,sys_ineq) =
+    (Util.list_map_append
+      (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other,
+     Util.list_map_append
+       (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs)
+  with FACTOR1 ->
+    eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs)
+
+let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) =
   let rec fst_eq_1 = function
      (eq::l) -> 
-        if List.exists (fun x -> abs x.c = 1) eq.body then eq,l
+        if List.exists (fun x -> abs x.c =? one) eq.body then eq,l
         else let (eq',l') = fst_eq_1 l in (eq',eq::l')
    | [] -> raise Not_found in
   match sys_eq with
-     [] -> if !debug then display_system sys_ineq; sys_ineq
+     [] -> if !debug then display_system print_var sys_ineq; sys_ineq
    | (e1::rest) -> 
        let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in
        if eq.body = [] then 
-         if eq.constant = 0 then begin
-           add_event (FORGET_C eq.id); banerjee (other,sys_ineq)
+         if eq.constant =? zero then begin
+           add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq)
          end else begin
            add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE
          end
-       else banerjee (eliminate_one_equation (eq,other,sys_ineq))
+       else
+	 banerjee new_ids 
+	   (eliminate_one_equation new_ids (eq,other,sys_ineq))
+
 type kind = INVERTED | NORMAL
-let redundancy_elimination system =
+
+let redundancy_elimination new_eq_id system =
   let normal = function
-     ({body=f::_} as e) when f.c < 0 ->  negate_eq e, INVERTED
+     ({body=f::_} as e) when f.c <? zero ->  negate_eq e, INVERTED
    | e -> e,NORMAL in
-  let table = create 7 in
+  let table = Hashtbl.create 7 in
   List.iter
     (fun e -> 
        let ({body=ne} as nx) ,kind = normal e in
        if ne = [] then
-         if nx.constant < 0 then begin
+         if nx.constant <? zero then begin
            add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE
          end else add_event (FORGET_C nx.id)
        else
        try 
-         let (optnormal,optinvert) = find table ne in
+         let (optnormal,optinvert) = Hashtbl.find table ne in
          let final =
            if kind = NORMAL then begin
              match optnormal with 
                 Some v -> 
                   let kept =
-                    if v.constant < nx.constant 
+                    if v.constant <? nx.constant 
                     then begin add_event (FORGET (v.id,nx.id));v end
                     else begin add_event (FORGET (nx.id,v.id));nx end in
                   (Some(kept),optinvert)
@@ -386,32 +425,32 @@ let redundancy_elimination system =
            end else begin
              match optinvert with 
                 Some v ->
-                  let kept =
-                    if v.constant > nx.constant 
+                  let _kept =
+                    if v.constant >? nx.constant 
                     then begin add_event (FORGET_I (v.id,nx.id));v end
                     else begin add_event (FORGET_I (nx.id,v.id));nx end in
-                  (optnormal,Some(if v.constant > nx.constant then v else nx))
+                  (optnormal,Some(if v.constant >? nx.constant then v else nx))
               | None -> optnormal,Some nx
            end in
          begin match final with
             (Some high, Some low) -> 
-              if high.constant < low.constant then begin
+              if high.constant <? low.constant then begin
                 add_event(CONTRADICTION (high,negate_eq low));
                 raise UNSOLVABLE
               end
           | _ -> () end;
-         remove table ne;
-         add table ne final
+         Hashtbl.remove table ne;
+         Hashtbl.add table ne final
        with Not_found ->
-         add table ne 
+         Hashtbl.add table ne 
            (if kind = NORMAL then (Some nx,None) else (None,Some nx)))
     system;
   let accu_eq = ref [] in
   let accu_ineq = ref [] in
-  iter
+  Hashtbl.iter
     (fun p0 p1 -> match (p0,p1) with 
-       | (e, (Some x, Some y)) when x.constant = y.constant ->
-           let id=new_id () in
+       | (e, (Some x, Some y)) when x.constant =? y.constant ->
+           let id=new_eq_id () in
            add_event (MERGE_EQ(id,x,y.id));
            push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq
        | (e, (optnorm,optinvert)) ->
@@ -425,17 +464,17 @@ let redundancy_elimination system =
 exception SOLVED_SYSTEM
 
 let select_variable system =
-  let table = create 7 in
+  let table = Hashtbl.create 7 in
   let push v c= 
-    try let r = find table v in r := max !r (abs c)
-    with Not_found -> add table v (ref (abs c)) in
+    try let r = Hashtbl.find table v in r := max !r (abs c)
+    with Not_found -> Hashtbl.add table v (ref (abs c)) in
   List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system;
-  let vmin,cmin = ref (-1), ref 0 in
+  let vmin,cmin = ref (-1), ref zero in
   let var_cpt = ref 0 in
-  iter
+  Hashtbl.iter
     (fun v ({contents =  c}) ->
        incr var_cpt;
-       if c < !cmin or !vmin = (-1) then begin vmin := v; cmin := c end)
+       if c <? !cmin or !vmin = (-1) then begin vmin := v; cmin := c end)
     table;
   if !var_cpt < 1 then raise SOLVED_SYSTEM;
   !vmin
@@ -444,25 +483,25 @@ let classify v system =
   List.fold_left 
     (fun (not_occ,below,over) eq ->
        try let f,eq' = chop_var v eq.body in
-       if f.c >= 0 then (not_occ,((f.c,eq) :: below),over)
-       else (not_occ,below,((-f.c,eq) :: over))
+       if f.c >=? zero then (not_occ,((f.c,eq) :: below),over)
+       else (not_occ,below,((neg f.c,eq) :: over))
        with CHOPVAR -> (eq::not_occ,below,over))
     ([],[],[]) system
 
-let product dark_shadow low high =
+let product new_eq_id dark_shadow low high =
   List.fold_left
     (fun accu (a,eq1) ->
        List.fold_left
          (fun accu (b,eq2) ->
             let eq = 
-              sum_afine (map_eq_afine (fun c -> c * b) eq1)
+              sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1)
                 (map_eq_afine (fun c -> c * a) eq2) in
             add_event(SUM(eq.id,(b,eq1),(a,eq2)));
             match normalize eq with
 	      | [eq] ->
                   let final_eq =
                     if dark_shadow then 
-                      let delta = (a - 1) * (b - 1) in
+                      let delta = (a - one) * (b - one) in
                       add_event(WEAKEN(eq.id,delta));
                       {id = eq.id; kind=INEQ; body = eq.body; 
                        constant = eq.constant - delta} 
@@ -473,33 +512,34 @@ let product dark_shadow low high =
          accu high)
     [] low
 
-let fourier_motzkin dark_shadow system =
+let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system =
   let v = select_variable system in
   let (ineq_out, ineq_low,ineq_high) = classify v system in
-  let expanded = ineq_out @ product dark_shadow ineq_low ineq_high in
-  if !debug then display_system expanded; expanded
+  let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in
+  if !debug then display_system print_var expanded; expanded
 
-let simplify dark_shadow system =
+let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system =
   if List.exists (fun e -> e.kind = DISE) system then 
     failwith "disequation in simplify";
   clear_history ();
   List.iter (fun e -> add_event (HYP e)) system;
-  let system = flat_map normalize system in
-  let eqs,ineqs = filter (fun e -> e.kind=EQUA) system in
-  let simp_eq,simp_ineq = redundancy_elimination ineqs in
+  let system = Util.list_map_append normalize system in
+  let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
+  let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in
   let system = (eqs @ simp_eq,simp_ineq) in
   let rec loop1a system =
-    let sys_ineq = banerjee system in 
+    let sys_ineq = banerjee new_ids system in 
     loop1b sys_ineq 
   and loop1b sys_ineq =
-    let simp_eq,simp_ineq = redundancy_elimination sys_ineq in
+    let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in
     if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) 
   in
   let rec loop2 system =
     try
-      let expanded = fourier_motzkin dark_shadow system in
+      let expanded = fourier_motzkin new_ids dark_shadow system in
       loop2 (loop1b expanded)
-    with SOLVED_SYSTEM -> if !debug then display_system system; system 
+    with SOLVED_SYSTEM ->
+      if !debug then display_system print_var system; system 
   in
   loop2 (loop1a system)
 
@@ -520,11 +560,9 @@ let rec depend relie_on accu = function
 	      depend (e1.id::e2.id::relie_on) (act::accu) l
             else 
 	      depend relie_on accu l
-	| STATE (e,_,o,_,_) ->
-            if List.mem e.id relie_on then
-	      depend (o.id::relie_on) (act::accu) l
-            else
-	      depend relie_on accu l
+	| STATE {st_new_eq=e;st_orig=o} ->
+            if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l
+            else depend relie_on accu l
 	| HYP e ->   
             if List.mem e.id relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
@@ -548,59 +586,68 @@ let rec depend relie_on accu = function
       end
   | [] -> relie_on, accu
 
-let solve system =
-  try let _ = simplify false system in failwith "no contradiction"
-  with UNSOLVABLE -> display_action (snd (depend [] [] (history ())))
+(*
+let depend relie_on accu trace = 
+  Printf.printf "Longueur de la trace initiale : %d\n" 
+    (trace_length trace + trace_length accu);
+  let rel',trace' = depend relie_on accu trace in
+  Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace');
+  rel',trace'
+*)
+
+let solve (new_eq_id,new_eq_var,print_var) system =
+  try let _ = simplify new_eq_id false system in failwith "no contradiction"
+  with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ())))
       
 let negation (eqs,ineqs) =
-  let diseq,_ = filter (fun e -> e.kind = DISE) ineqs in
+  let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in
   let normal = function
-    | ({body=f::_} as e) when f.c < 0 ->  negate_eq e, INVERTED
+    | ({body=f::_} as e) when f.c <? zero ->  negate_eq e, INVERTED
     | e -> e,NORMAL in
-  let table = create 7 in
+  let table = Hashtbl.create 7 in
   List.iter (fun e -> 
                let {body=ne;constant=c} ,kind = normal e in
-               add table (ne,c) (kind,e)) diseq;
+               Hashtbl.add table (ne,c) (kind,e)) diseq;
   List.iter (fun e ->
-               if e.kind <> EQUA then pp 9999;
+               assert (e.kind = EQUA);
                let {body=ne;constant=c},kind = normal e in
                try 
-		 let (kind',e') = find table (ne,c) in
+		 let (kind',e') = Hashtbl.find table (ne,c) in
 		 add_event (NEGATE_CONTRADICT (e,e',kind=kind'));
 		 raise UNSOLVABLE
                with Not_found -> ()) eqs
 
 exception FULL_SOLUTION of action list * int list
 
-let simplify_strong system =
+let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
   clear_history ();
   List.iter (fun e -> add_event (HYP e)) system;
   (* Initial simplification phase *)
   let rec loop1a system =
     negation system;
-    let sys_ineq = banerjee system in 
+    let sys_ineq = banerjee new_ids system in 
     loop1b sys_ineq 
   and loop1b sys_ineq =
-    let dise,ine = filter (fun e -> e.kind = DISE) sys_ineq in
-    let simp_eq,simp_ineq = redundancy_elimination ine in
+    let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in
+    let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
     if simp_eq = [] then dise @ simp_ineq
     else loop1a (simp_eq,dise @ simp_ineq) 
   in
   let rec loop2 system =
     try
-      let expanded = fourier_motzkin false system in
+      let expanded = fourier_motzkin new_ids false system in
       loop2 (loop1b expanded)
-    with SOLVED_SYSTEM -> if !debug then display_system system; system 
+    with SOLVED_SYSTEM -> if !debug then display_system print_var system; system 
   in
   let rec explode_diseq = function 
     | (de::diseq,ineqs,expl_map) ->
-	let id1 = new_id () 
-	and id2 = new_id () in
+	let id1 = new_eq_id () 
+	and id2 = new_eq_id () in
 	let e1 = 
-	  {id = id1; kind=INEQ; body = de.body; constant = de.constant - 1} in
+          {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in
 	let e2 = 
-	  {id = id2; kind=INEQ; body = map_eq_linear (fun x -> -x) de.body; 
-           constant = - de.constant - 1} in
+	  {id = id2; kind=INEQ; body = map_eq_linear neg de.body; 
+           constant = neg de.constant - one} in
 	let new_sys =
           List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) 
 	    ineqs @ 
@@ -611,13 +658,13 @@ let simplify_strong system =
     | ([],ineqs,expl_map) -> ineqs,expl_map 
   in
   try 
-    let system = flat_map normalize system in
-    let eqs,ineqs = filter (fun e -> e.kind=EQUA) system in
-    let dise,ine = filter (fun e -> e.kind = DISE) ineqs in
-    let simp_eq,simp_ineq = redundancy_elimination ine in
+    let system = Util.list_map_append normalize system in
+    let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
+    let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in
+    let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
     let system = (eqs @ simp_eq,simp_ineq @ dise) in
     let system' = loop1a system in
-    let diseq,ineq = filter (fun e -> e.kind = DISE) system' in
+    let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in
     let first_segment = history () in
     let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in
     let all_solutions =
@@ -627,20 +674,21 @@ let simplify_strong system =
            try let _ = loop2 sys in raise NO_CONTRADICTION
            with UNSOLVABLE -> 
              let relie_on,path = depend [] [] (history ()) in
-             let dc,_ = filter (fun (_,id,_) -> List.mem id relie_on) decomp in
+             let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in
              let red = List.map (fun (x,_,_) -> x) dc in
              (red,relie_on,decomp,path))
         sys_exploded 
     in
     let max_count sys = 
-      let tbl = create 7 in
+      let tbl = Hashtbl.create 7 in
       let augment x = 
-        try incr (find tbl x) with Not_found -> add tbl x (ref 1) in
+        try incr (Hashtbl.find tbl x) 
+	with Not_found -> Hashtbl.add tbl x (ref 1) in
       let eq = ref (-1) and c = ref 0 in
       List.iter (function 
 		   | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on))
                    | (l,_,_,_) -> List.iter augment l) sys;
-      iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl;
+      Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl;
       !eq 
     in
     let rec solve systems = 
@@ -649,17 +697,20 @@ let simplify_strong system =
         let rec sign = function 
 	  | ((id',_,b)::l) -> if id=id' then b else sign l 
           | [] -> failwith "solve" in
-        let s1,s2 = filter (fun (_,_,decomp,_) -> sign decomp) systems in
+        let s1,s2 =
+          List.partition (fun (_,_,decomp,_) -> sign decomp) systems in
         let s1' = 
-	  List.map (fun (dep,ro,dc,pa) -> (list_except id dep,ro,dc,pa)) s1 in
+	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in
         let s2' = 
-	  List.map (fun (dep,ro,dc,pa) -> (list_except id dep,ro,dc,pa)) s2 in
+	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in
         let (r1,relie1) = solve s1' 
 	and (r2,relie2) = solve s2' in
 	let (eq,id1,id2) = List.assoc id explode_map in
-	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: list_union relie1 relie2
+	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2
       with FULL_SOLUTION (x0,x1) -> (x0,x1) 
     in
     let act,relie_on = solve all_solutions in
     snd(depend relie_on act first_segment)
   with UNSOLVABLE -> snd (depend [] [] (history ()))
+
+end
diff --git a/contrib/recdef/Recdef.v b/contrib/recdef/Recdef.v
new file mode 100644
index 00000000..2d206220
--- /dev/null
+++ b/contrib/recdef/Recdef.v
@@ -0,0 +1,48 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+Require Compare_dec.
+Require Wf_nat.
+
+Section Iter.
+Variable A : Type.
+
+Fixpoint iter (n : nat) : (A -> A) -> A -> A :=
+  fun (fl : A -> A) (def : A) =>
+  match n with
+  | O => def
+  | S m => fl (iter m fl def)
+  end.
+End Iter.
+
+Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')).
+  intro p; intro p'; change (S p <= S (S (p + p'))); 
+    apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); 
+    apply Lt.le_lt_n_Sm; apply Plus.le_plus_l.
+Qed.
+ 
+
+Theorem Splus_lt : forall p p' : nat, p' < S (p + p').
+  intro p; intro p'; change (S p' <= S (p + p')); 
+    apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm;
+       apply Plus.le_plus_r.
+Qed.
+
+Theorem le_lt_SS : forall x y, x <= y -> x < S (S y).
+intro x; intro y; intro H; change (S x <= S (S y)); 
+    apply le_S; apply Gt.gt_le_S; change (x < S y); 
+    apply Lt.le_lt_n_Sm; exact H.
+Qed.
+
+Inductive max_type (m n:nat) : Set :=
+  cmt : forall v, m <= v -> n <= v -> max_type m n.
+
+Definition max : forall m n:nat, max_type m n.
+intros m n; case (Compare_dec.le_gt_dec m n).
+intros h; exists n; [exact h | apply le_n].
+intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h].
+Defined.
diff --git a/contrib/recdef/recdef.ml4 b/contrib/recdef/recdef.ml4
new file mode 100644
index 00000000..353fcdb3
--- /dev/null
+++ b/contrib/recdef/recdef.ml4
@@ -0,0 +1,1263 @@
+(************************************************************************)
+(*  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*)
+
+open Term
+open Termops
+open Environ
+open Declarations
+open Entries
+open Pp
+open Names
+open Libnames
+open Nameops
+open Util
+open Closure
+open RedFlags
+open Tacticals
+open Typing
+open Tacmach
+open Tactics
+open Nametab
+open Declare
+open Decl_kinds
+open Tacred
+open Proof_type
+open Vernacinterp
+open Pfedit
+open Topconstr
+open Rawterm
+open Pretyping
+open Pretyping.Default
+open Safe_typing
+open Constrintern
+open Hiddentac
+
+open Equality
+open Auto
+open Eauto
+
+open Genarg
+
+
+let qed () = Command.save_named true 
+let defined () = Command.save_named false
+
+let pf_get_new_ids idl g = 
+  let ids = pf_ids_of_hyps g in 
+  List.fold_right
+    (fun id acc -> next_global_ident_away false id (acc@ids)::acc)
+    idl 
+    []
+
+let pf_get_new_id id g = 
+  List.hd (pf_get_new_ids [id] g)
+
+let h_intros l = 
+  tclMAP h_intro l
+
+let do_observe_tac s tac g =
+  let goal = begin (Printer.pr_goal (sig_it g)) end in
+ try let v = tac g in msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); v
+ with e ->
+   msgnl (str "observation "++str s++str " raised exception " ++ 
+	    Cerrors.explain_exn e ++ str " on goal " ++ goal ); 
+   raise e;;
+
+
+let observe_tac s tac g = 
+  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
+  then do_observe_tac s tac g
+  else tac g
+
+let hyp_ids = List.map id_of_string
+    ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res";
+     "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];;
+
+let rec nthtl = function
+    l, 0 -> l  | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];;
+
+let hyp_id n l = List.nth l n;;
+
+let (x_id:identifier) = hyp_id 0 hyp_ids;;
+let (v_id:identifier) = hyp_id 1 hyp_ids;;
+let (k_id:identifier) = hyp_id 2 hyp_ids;;
+let (def_id:identifier) = hyp_id 3 hyp_ids;;
+let (p_id:identifier) = hyp_id 4 hyp_ids;;
+let (h_id:identifier) = hyp_id 5 hyp_ids;;
+let (n_id:identifier) = hyp_id 6 hyp_ids;;
+let (h'_id:identifier) = hyp_id 7 hyp_ids;;
+let (ano_id:identifier) = hyp_id 8 hyp_ids;;
+let (rec_res_id:identifier) = hyp_id 10 hyp_ids;;
+let (hspec_id:identifier) = hyp_id 11 hyp_ids;;
+let (heq_id:identifier) = hyp_id 12 hyp_ids;;
+let (hrec_id:identifier) = hyp_id 13 hyp_ids;;
+let (hex_id:identifier) = hyp_id 14 hyp_ids;;
+let (teq_id:identifier) = hyp_id 15 hyp_ids;;
+let (pmax_id:identifier) = hyp_id 16 hyp_ids;;
+let (hle_id:identifier) = hyp_id 17 hyp_ids;;
+
+let message s = if Options.is_verbose () then msgnl(str s);;
+
+let def_of_const t =
+   match (kind_of_term t) with
+    Const sp -> 
+      (try (match (Global.lookup_constant sp) with
+             {const_body=Some c} -> Declarations.force c
+	     |_ -> assert false)
+       with _ -> 
+	 anomaly ("Cannot find definition of constant "^
+		    (string_of_id (id_of_label (con_label sp))))
+      )
+     |_ -> assert false
+
+let type_of_const t =
+   match (kind_of_term t) with
+    Const sp -> Typeops.type_of_constant (Global.env()) sp
+    |_ -> assert false
+
+let arg_type t =
+  match kind_of_term (def_of_const t) with
+      Lambda(a,b,c) -> b
+    | _ -> assert false;;
+
+let evaluable_of_global_reference r =
+  match r with 
+      ConstRef sp -> EvalConstRef sp
+    | VarRef id -> EvalVarRef id
+    | _ -> assert false;;
+
+
+let rank_for_arg_list h = 
+  let predicate a b = 
+      try List.for_all2 eq_constr a b with
+        Invalid_argument _ -> false in
+  let rec rank_aux i = function
+  | [] -> None
+  | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
+  rank_aux 0;;
+
+let rec (find_call_occs:
+	   constr -> constr -> (constr list ->constr)*(constr  list list)) =
+ fun f expr ->
+  match (kind_of_term expr) with
+    App (g, args) when g = f -> 
+      (fun l -> List.hd l), [Array.to_list args]
+  | App (g, args) ->
+     let (largs: constr list) = Array.to_list args in
+     let rec find_aux = function
+	 []    -> (fun x -> []), []
+       | a::upper_tl ->
+         (match find_aux upper_tl with
+          (cf, ((arg1::args) as args_for_upper_tl)) -> 
+           (match find_call_occs f a with
+             cf2, (_ :: _ as other_args) ->
+               let rec avoid_duplicates args =
+                  match args with
+                  | [] -> (fun _ -> []), []
+                  | h::tl -> 
+                      let recomb_tl, args_for_tl =
+                          avoid_duplicates tl in
+                    match rank_for_arg_list h args_for_upper_tl with
+                    | None -> 
+                        (fun l -> List.hd l::recomb_tl(List.tl l)),
+                        h::args_for_tl
+                    | Some i ->
+                        (fun l -> List.nth l (i+List.length args_for_tl)::
+                            recomb_tl l),
+                        args_for_tl
+               in
+               let recombine, other_args' =
+                   avoid_duplicates other_args in
+	       let len1 = List.length other_args' in                   
+                   (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))),
+                     other_args'@args_for_upper_tl
+           | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
+	 | _, [] ->
+	   (match find_call_occs f a with
+	     cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args)
+	   | _, [] -> (fun x -> a::upper_tl), [])) in
+     begin
+       match (find_aux largs) with
+	   cf, [] -> (fun l -> mkApp(g, args)), []
+	 | cf, args ->
+	     (fun l -> mkApp (g, Array.of_list (cf l))), args
+     end
+  | Rel(_) -> error "find_call_occs : Rel"
+  | Var(id) -> (fun l -> expr), []
+  | Meta(_) -> error "find_call_occs : Meta"
+  | Evar(_) -> error "find_call_occs : Evar"
+  | Sort(_)  -> error "find_call_occs : Sort"
+  | Cast(b,_,_) -> find_call_occs f b
+  | Prod(_,_,_) -> error "find_call_occs : Prod"
+  | Lambda(_,_,_) -> error "find_call_occs : Lambda"
+  | LetIn(_,_,_,_) -> error "find_call_occs : let in"
+  | Const(_) -> (fun l -> expr), []
+  | Ind(_) -> (fun l -> expr), []
+  | Construct (_, _) -> (fun l -> expr), []
+  | Case(i,t,a,r) ->
+      (match find_call_occs f a with
+	cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
+      | _ -> (fun l -> mkCase(i, t, a, r)),[])
+  | Fix(_) -> error "find_call_occs : Fix"
+  | CoFix(_) -> error "find_call_occs : CoFix";;
+
+
+
+let coq_constant s =
+  Coqlib.gen_constant_in_modules "RecursiveDefinition" 
+    (Coqlib.init_modules @ Coqlib.arith_modules) s;;
+
+let constant sl s =
+  constr_of_reference
+    (locate (make_qualid(Names.make_dirpath 
+			   (List.map id_of_string (List.rev sl)))
+	       (id_of_string s)));;
+
+let find_reference sl s =
+    (locate (make_qualid(Names.make_dirpath 
+			   (List.map id_of_string (List.rev sl)))
+	       (id_of_string s)));;
+
+let delayed_force f = f ()
+
+let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
+let le_lt_n_Sm = function () -> (coq_constant "le_lt_n_Sm")
+
+let le_trans = function () -> (coq_constant "le_trans")
+let le_lt_trans = function () -> (coq_constant "le_lt_trans")
+let lt_S_n = function () -> (coq_constant "lt_S_n")
+let le_n = function () -> (coq_constant "le_n")
+let refl_equal = function () -> (coq_constant "refl_equal")
+let eq = function () -> (coq_constant "eq")
+let ex = function () -> (coq_constant "ex")
+let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
+let coq_sig = function () -> (coq_constant "sig")
+let coq_O = function () -> (coq_constant "O")
+let coq_S = function () -> (coq_constant "S")
+
+let gt_antirefl = function () -> (coq_constant "gt_irrefl")
+let lt_n_O = function () -> (coq_constant "lt_n_O")
+let lt_n_Sn = function () -> (coq_constant "lt_n_Sn")
+
+let f_equal = function () -> (coq_constant "f_equal")
+let well_founded_induction = function () -> (coq_constant "well_founded_induction")
+let well_founded = function () -> (coq_constant "well_founded")
+let acc_rel = function () -> (coq_constant "Acc")
+let acc_inv_id = function () -> (coq_constant "Acc_inv")
+let well_founded_ltof = function () ->  (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof")
+let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded")
+let max_ref = function () -> (find_reference ["Recdef"] "max")
+let iter = function () -> (constr_of_reference (delayed_force iter_ref))
+let max_constr = function () -> (constr_of_reference (delayed_force max_ref))
+
+let ltof_ref = function  () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof")
+let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj"
+
+(* These are specific to experiments in nat with lt as well_founded_relation, *)
+(*    but this should be made more general. *)
+let nat = function () -> (coq_constant "nat")
+let lt = function () -> (coq_constant "lt")
+
+let  mkCaseEq a  : tactic =
+     (fun g ->
+	(* commentaire de Yves: on pourra avoir des problemes si
+	   a n'est pas bien type dans l'environnement du but *)
+       let type_of_a = pf_type_of g a in
+       (tclTHEN (generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])])
+	  (tclTHEN 
+	     (fun g2 ->
+		change_in_concl None 
+		  (pattern_occs [([2], a)] (pf_env g2) Evd.empty (pf_concl g2))
+		  g2)
+	     (simplest_case a))) g);;
+
+let rec  mk_intros_and_continue (extra_eqn:bool)
+    cont_function (eqs:constr list) (expr:constr) g =
+  match kind_of_term expr with
+    | Lambda (n, _, b) -> 
+     	let n1 = 
+	  match n with
+      	      Name x -> x
+            | Anonymous -> ano_id
+	in
+     	let new_n = pf_get_new_id n1 g in
+	  tclTHEN (h_intro new_n)
+	    (mk_intros_and_continue extra_eqn cont_function eqs 
+	       (subst1 (mkVar new_n) b)) g
+    | _ -> 
+ 	if extra_eqn then
+	  let teq = pf_get_new_id teq_id g in
+	    tclTHENLIST
+	      [ h_intro teq;
+		tclMAP 
+		  (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) 
+		  (List.rev eqs);
+		(fun g1 -> 
+		   let ty_teq = pf_type_of g1 (mkVar teq) in 
+		   let teq_lhs,teq_rhs = 
+		     let _,args = destApp ty_teq in 
+		     args.(1),args.(2) 
+		   in
+	           cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1
+		)
+	      ]
+	      g
+	else
+	  cont_function eqs expr g
+
+let const_of_ref = function
+    ConstRef kn -> kn
+  | _ -> anomaly "ConstRef expected"
+
+let simpl_iter () =
+  reduce 
+    (Lazy 
+       {rBeta=true;rIota=true;rZeta= true; rDelta=false;
+        rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
+    onConcl
+
+(* The boolean value is_mes expresses that the termination is expressed
+  using a measure function instead of a well-founded relation. *)
+let tclUSER is_mes l g = 
+  let clear_tac = 
+    match l with 
+      | None -> h_clear true []
+      | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l)
+  in
+  tclTHENSEQ 
+    [
+      clear_tac;
+      if is_mes 
+      then unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))]
+      else tclIDTAC
+    ]
+    g
+    
+    
+let list_rewrite (rev:bool) (eqs: constr list) =
+  tclREPEAT
+    (List.fold_right
+       (fun eq i -> tclORELSE (rewriteLR eq) i)
+       (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));;
+
+let base_leaf_terminate (func:global_reference) eqs expr =
+(*  let _ = msgnl (str "entering base_leaf") in *)
+  (fun g ->
+     let k',h = 
+       match pf_get_new_ids [k_id;h_id] g with 
+	   [k';h] -> k',h
+	 | _ -> assert false
+     in
+     tclTHENLIST [observe_tac "first split" (split (ImplicitBindings [expr]));
+		  observe_tac "second split" (split (ImplicitBindings [delayed_force coq_O]));
+		  observe_tac "intro k" (h_intro k');
+                  observe_tac "case on k" 
+		      (tclTHENS 
+			 (simplest_case (mkVar k'))
+			 [(tclTHEN (h_intro h) 
+		     	     (tclTHEN (simplest_elim 
+					 (mkApp (delayed_force gt_antirefl,
+						 [| delayed_force coq_O |])))
+				default_auto)); tclIDTAC ]);
+                  intros;
+		  simpl_iter();
+		  unfold_constr func;
+                  list_rewrite true eqs;
+		  default_auto ] g);;
+
+(* La fonction est donnee en premier argument a la 
+   fonctionnelle suivie d'autres Lambdas et de Case ...
+   Pour recuperer la fonction f a partir de la 
+   fonctionnelle *)
+
+let get_f foncl = 
+  match (kind_of_term (def_of_const foncl)) with
+      Lambda (Name f, _, _) -> f  
+    |_ -> error "la fonctionnelle est mal definie";;
+
+
+let rec compute_le_proofs = function
+    [] -> assumption
+  | a::tl ->
+      tclORELSE assumption 
+	(tclTHENS
+	   (apply_with_bindings
+	      (delayed_force le_trans,
+	       ExplicitBindings[dummy_loc,NamedHyp(id_of_string "m"),a]))
+	   [compute_le_proofs tl; 
+            tclORELSE (apply (delayed_force le_n)) assumption])
+
+let make_lt_proof pmax le_proof =
+  tclTHENS
+    (apply_with_bindings
+       (delayed_force le_lt_trans,
+	ExplicitBindings[dummy_loc,NamedHyp(id_of_string "m"), pmax]))
+    [compute_le_proofs le_proof; 
+     tclTHENLIST[apply (delayed_force lt_S_n); default_full_auto]];;
+
+let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
+  match cond_eqs with
+    [] -> tclIDTAC
+  | eq::eqs ->
+      (fun g -> 
+	 tclTHENS
+	   (general_rewrite_bindings false
+	      (mkVar eq,
+	       ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
+				dummy_loc, NamedHyp def_id, mkVar def]))
+	   [list_cond_rewrite k def pmax eqs le_proofs;
+            make_lt_proof pmax le_proofs] g
+      ) 
+
+let rec introduce_all_equalities func eqs values specs bound le_proofs 
+    cond_eqs =
+  match specs with
+    [] -> 
+      fun g ->
+	let ids = pf_ids_of_hyps g in
+	let s_max = mkApp(delayed_force coq_S, [|bound|]) in
+	let k = next_global_ident_away true k_id ids in
+        let ids = k::ids in
+	let h' = next_global_ident_away true (h'_id) ids in
+        let ids = h'::ids in
+	let def = next_global_ident_away true def_id ids in
+	tclTHENLIST
+	  [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max]));
+	   observe_tac "introduce_all_equalities_final intro k" (h_intro  k);
+	   tclTHENS
+	     (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k)))
+	     [
+	       tclTHENLIST[h_intro h';
+			   simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]));
+			   default_full_auto];
+	       tclIDTAC
+	     ];
+	   observe_tac "clearing k " (clear [k]);
+	   observe_tac "intros k h' def" (h_intros [k;h';def]);
+	   observe_tac "simple_iter" (simpl_iter());
+	   observe_tac "unfold functional" 
+	     (unfold_in_concl[([1],evaluable_of_global_reference func)]);
+	   observe_tac "rewriting equations" 
+	     (list_rewrite true eqs);
+           observe_tac "cond rewrite" (list_cond_rewrite  k def bound cond_eqs le_proofs);
+	   observe_tac "refl equal" (apply (delayed_force refl_equal))] g
+  | spec1::specs ->
+      fun g ->
+	let ids = ids_of_named_context (pf_hyps g) in
+	let p = next_global_ident_away true p_id ids in
+        let ids = p::ids in
+	let pmax = next_global_ident_away true pmax_id ids in
+        let ids = pmax::ids in
+	let hle1 = next_global_ident_away true hle_id ids in
+        let ids = hle1::ids in
+	let hle2 = next_global_ident_away true  hle_id ids in
+	let ids = hle2::ids in
+	let heq = next_global_ident_away true heq_id ids in
+	tclTHENLIST
+	  [simplest_elim (mkVar spec1);
+	   list_rewrite true eqs;
+	   h_intros [p; heq];
+	   simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]));
+	   h_intros [pmax; hle1; hle2];
+	   introduce_all_equalities func eqs values specs 
+	     (mkVar pmax) ((mkVar pmax)::le_proofs)
+	     (heq::cond_eqs)] g;;
+    
+let string_match  s =
+ try 
+  for i = 0 to 3  do
+    if String.get s i <> String.get "Acc_" i then failwith "string_match"
+  done;
+ with Invalid_argument _ -> failwith "string_match"
+	  
+let retrieve_acc_var g = 
+  (* Julien: I don't like this version .... *) 
+  let hyps = pf_ids_of_hyps g  in 
+  map_succeed 
+    (fun id -> string_match (string_of_id id);id)
+    hyps 
+
+let rec introduce_all_values is_mes acc_inv func context_fn
+    eqs  hrec args values specs =
+    (match args with
+    [] -> 
+      tclTHENLIST
+	[observe_tac "split" (split(ImplicitBindings
+		 [context_fn (List.map mkVar (List.rev values))]));
+	 observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs
+	   (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])]
+  | arg::args ->
+      (fun g ->
+	let ids = ids_of_named_context (pf_hyps g) in
+	let rec_res = next_global_ident_away true rec_res_id ids in
+        let ids = rec_res::ids in
+	let hspec = next_global_ident_away true hspec_id ids in
+	let tac =  
+	  observe_tac "introduce_all_values" (
+	    introduce_all_values is_mes acc_inv func context_fn eqs
+	      hrec args
+	      (rec_res::values)(hspec::specs)) in
+	(tclTHENS
+	   (observe_tac "elim h_rec" (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))))
+	   [tclTHENLIST [h_intros [rec_res; hspec];
+			 tac]; 
+	    (tclTHENS
+		 (observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
+		 [ observe_tac "h_assumption" h_assumption
+		 ;
+		  tclTHENLIST
+		    [
+		      tclTRY(list_rewrite true eqs);
+		      observe_tac "user proof" 
+			(fun g ->  
+			   tclUSER
+			     is_mes
+			     (Some (hrec::hspec::(retrieve_acc_var g)@specs))
+			     g
+			)		     
+		    ]
+		 ]
+	    )
+	   ]) g)
+	
+    )
+ 
+	   
+let rec_leaf_terminate is_mes acc_inv hrec (func:global_reference) eqs expr =
+  match find_call_occs (mkVar (get_f (constr_of_reference func))) expr with
+  | context_fn, args ->
+      observe_tac "introduce_all_values" 
+	(introduce_all_values is_mes acc_inv func context_fn eqs  hrec args  [] [])
+
+let proveterminate is_mes acc_inv (hrec:identifier)  
+  (f_constr:constr) (func:global_reference) base_leaf rec_leaf = 
+  let rec proveterminate (eqs:constr list) (expr:constr)  =
+    try
+      (*  let _ = msgnl (str "entering proveterminate") in *)
+      let v =
+	match (kind_of_term expr) with
+	    Case (_, t, a, l) -> 
+	      (match find_call_occs f_constr a with
+		   _,[] ->
+      		     tclTHENS 
+		       (fun g ->
+			  (* let _ = msgnl(str "entering mkCaseEq") in *)
+			  let v = (mkCaseEq a) g in 
+			  (* let _ = msgnl (str "exiting mkCaseEq") in *)
+			  v
+		       )
+   	               (List.map 
+			  (mk_intros_and_continue true proveterminate eqs)
+			  (Array.to_list l)
+		       )
+		 | _, _::_ -> 
+		     (
+		       match find_call_occs  f_constr expr with
+	     		   _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr)
+			 | _, _:: _ -> 
+			     observe_tac "rec_leaf" 
+			       (rec_leaf is_mes acc_inv hrec  func eqs expr)
+		     )
+	      )
+	  | _ ->  (match find_call_occs  f_constr expr with
+	     	       _,[] -> 
+			 (try 
+			    observe_tac "base_leaf" (base_leaf func eqs expr)
+			  with e -> 
+			    (msgerrnl (str "failure in base case");raise e ))
+		     | _, _::_ -> 
+			 observe_tac "rec_leaf" 
+			   (rec_leaf is_mes acc_inv hrec  func eqs expr)
+		  ) in
+      (*  let _ = msgnl(str "exiting proveterminate") in *)
+      v
+    with e -> 
+      begin 
+	msgerrnl(str "failure in proveterminate"); 
+	raise e
+      end
+  in 
+  proveterminate 
+
+let hyp_terminates func = 
+  let a_arrow_b = arg_type (constr_of_reference func) in 
+  let rev_args,b = decompose_prod a_arrow_b in 
+  let left = 
+    mkApp(delayed_force iter, 
+	  Array.of_list 
+	    (lift 5 a_arrow_b:: mkRel 3::
+	       constr_of_reference func::mkRel 1::
+	       List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
+	    )
+	 )
+  in
+  let right = mkRel 5 in 
+  let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in
+  let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in
+  let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in
+  let nb_iter =
+    mkApp(delayed_force ex,
+	  [|delayed_force nat;
+	    (mkLambda 
+	       (Name
+		  p_id,
+		  delayed_force nat, 
+		  (mkProd (Name k_id, delayed_force nat, 
+			   mkArrow cond result))))|])in
+  let value = mkApp(delayed_force coq_sig, 
+		    [|b;
+		      (mkLambda (Name v_id, b, nb_iter))|]) in
+  compose_prod rev_args value
+	     
+
+
+let tclUSER_if_not_mes is_mes names_to_suppress = 
+  if is_mes 
+  then 
+    tclCOMPLETE (h_apply (delayed_force well_founded_ltof,Rawterm.NoBindings))
+  else tclUSER is_mes names_to_suppress
+
+let termination_proof_header is_mes input_type ids args_id relation
+    rec_arg_num rec_arg_id tac wf_tac : tactic = 
+  begin 
+    fun g -> 
+      let nargs = List.length args_id in
+      let pre_rec_args = 
+	List.rev_map
+	  mkVar (fst (list_chop (rec_arg_num - 1) args_id)) 
+      in 
+      let relation = substl pre_rec_args relation in 
+      let input_type = substl pre_rec_args input_type in 
+      let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in 
+      let wf_rec_arg = 
+	next_global_ident_away true 
+	  (id_of_string ("Acc_"^(string_of_id rec_arg_id)))
+	  (wf_thm::ids) 
+      in 
+      let hrec = next_global_ident_away true hrec_id
+	(wf_rec_arg::wf_thm::ids) in 
+      let acc_inv = 
+	  lazy (
+	    mkApp (
+	      delayed_force acc_inv_id,
+	      [|input_type;relation;mkVar rec_arg_id|]
+	    )
+	  )
+      in
+      tclTHEN
+	(h_intros args_id)
+	(tclTHENS
+	   (observe_tac 
+	      "first assert" 
+	      (assert_tac 
+		 true (* the assert thm is in first subgoal *)
+		 (Name wf_rec_arg) 
+		 (mkApp (delayed_force acc_rel,
+			 [|input_type;relation;mkVar rec_arg_id|])
+		 )
+	      )
+	   )
+	   [
+	     (* accesibility proof *) 
+	     tclTHENS 
+	       (observe_tac 
+		  "second assert" 
+		  (assert_tac 
+		     true 
+		     (Name wf_thm)
+		     (mkApp (delayed_force well_founded,[|input_type;relation|]))
+		  )
+	       )
+	       [ 
+		 (* interactive proof that the relation is well_founded *)
+		 observe_tac "wf_tac" (wf_tac is_mes (Some args_id));
+		 (* this gives the accessibility argument *)
+		 observe_tac 
+		   "apply wf_thm" 
+		   (h_apply ((mkApp(mkVar wf_thm,
+				    [|mkVar rec_arg_id |])),Rawterm.NoBindings)
+		   )
+	       ]
+	     ;
+	     (* rest of the proof *)
+	     tclTHENSEQ 
+	       [observe_tac "generalize" 
+		  (onNLastHyps (nargs+1)
+		     (fun (id,_,_) -> 
+			tclTHEN (generalize [mkVar id]) (h_clear false [id])
+		     ))
+	       ;
+		observe_tac "h_fix" (h_fix (Some hrec) (nargs+1));
+		h_intros args_id;
+		h_intro wf_rec_arg;
+		observe_tac "tac" (tac hrec acc_inv)
+	       ]
+	   ]
+	) g  
+  end
+
+
+
+let rec instantiate_lambda t l = 
+  match l with
+  | [] -> t
+  | a::l -> 
+      let (bound_name, _, body) = destLambda t in
+      instantiate_lambda (subst1 a body) l
+;;
+
+
+let whole_start is_mes func input_type relation rec_arg_num  : tactic = 
+  begin 
+    fun g -> 
+      let ids = ids_of_named_context (pf_hyps g) in
+      let func_body = (def_of_const (constr_of_reference func)) in
+      let (f_name, _, body1) = destLambda func_body in
+      let f_id =
+	match f_name with
+	  | Name f_id -> next_global_ident_away true f_id ids
+	  | Anonymous -> anomaly "Anonymous function"
+      in
+      let n_names_types,_ = decompose_lam body1 in 
+      let n_ids,ids = 
+	List.fold_left 
+	  (fun (n_ids,ids) (n_name,_) -> 
+	     match n_name with 
+	       | Name id -> 
+		   let n_id = next_global_ident_away true id ids in 
+		   n_id::n_ids,n_id::ids
+	       | _ -> anomaly "anonymous argument"
+	  )
+	  ([],(f_id::ids))
+	  n_names_types
+      in
+      let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in
+      let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in 
+      termination_proof_header 
+	is_mes
+	input_type
+	ids
+	n_ids
+	relation 
+	rec_arg_num
+	rec_arg_id
+	(fun hrec acc_inv g ->  
+           (proveterminate 
+	      is_mes
+	      acc_inv 
+	      hrec
+	      (mkVar f_id)
+	      func
+	      base_leaf_terminate 
+	      rec_leaf_terminate
+	      []
+	      expr
+	   )
+	     g 
+	)
+	tclUSER_if_not_mes 
+	g 
+  end
+
+
+let get_current_subgoals_types () = 
+  let pts =  get_pftreestate () in 
+  let _,subs = extract_open_pftreestate pts in 
+  List.map snd (List.sort (fun (x,_) (y,_) -> x -y )subs )
+
+
+let build_and_l l = 
+  let and_constr =  Coqlib.build_coq_and () in 
+  let conj_constr = coq_conj () in 
+  let mk_and p1 p2 = 
+    Term.mkApp(and_constr,[|p1;p2|]) in 
+  let rec f  = function 
+    | [] -> failwith "empty list of subgoals!" 
+    | [p] -> p,tclIDTAC,1 
+    | p1::pl -> 
+	let c,tac,nb = f pl in 
+	mk_and p1 c, 
+	tclTHENS
+	  (apply (constr_of_reference conj_constr)) 
+	  [tclIDTAC;
+	   tac
+	  ],nb+1
+  in f l
+
+
+let is_rec_res id = 
+  let rec_res_name = string_of_id rec_res_id   in 
+  let id_name = string_of_id id in 
+  try 
+    String.sub id_name 0 (String.length rec_res_name) = rec_res_name 
+  with _ -> false
+
+let clear_goals = 
+  let rec clear_goal t = 
+    match kind_of_term t with 
+      | Prod(Name id as na,t,b) -> 
+	  let b' = clear_goal b in 
+	  if noccurn 1 b' && (is_rec_res id) 
+	  then pop b' 
+	  else if b' == b then t 
+	  else mkProd(na,t,b')
+      | _ -> map_constr clear_goal t
+  in 
+  List.map clear_goal 
+
+
+let build_new_goal_type () = 
+  let sub_gls_types = get_current_subgoals_types () in 
+  let sub_gls_types = clear_goals sub_gls_types in 
+  let res = build_and_l sub_gls_types in 
+  res
+  
+
+    
+let prove_with_tcc lemma _ : tactic = 
+  fun gls ->
+    let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in 
+    tclTHENSEQ 
+      [
+	generalize [lemma];
+	h_intro hid;
+	Elim.h_decompose_and (mkVar hid); 
+	gen_eauto(* default_eauto *) false (false,5) [] (Some [])
+	  (* 	      default_auto *)
+      ]
+      gls
+      
+	     
+
+let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal)   = 
+  let current_proof_name = get_current_proof_name () in
+  let name = match goal_name with 
+    | Some s -> s 
+    | None   ->  
+	try (add_suffix current_proof_name "_subproof") 
+	with _ -> anomaly "open_new_goal with an unamed theorem"
+  in  
+  let sign = Global.named_context () in
+  let sign = clear_proofs sign in
+  let na = next_global_ident_away false name [] in
+  if occur_existential gls_type then
+    Util.error "\"abstract\" cannot handle existentials";
+  let hook _ _ = 
+    let lemma = mkConst (Lib.make_con na) in 
+    Array.iteri 
+      (fun i _ -> 
+	 by (observe_tac ("reusing lemma "^(string_of_id na)) (prove_with_tcc lemma i)))
+      (Array.make nb_goal ())
+    ;
+    ref := Some lemma ;
+    defined ();
+  in
+  start_proof
+    na
+    (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) 
+    sign
+    gls_type 
+    hook ;
+  by (
+    fun g -> 
+      tclTHEN 
+	(decompose_and_tac)
+	(tclORELSE 
+	(tclFIRST 
+	   (List.map
+	      (fun c -> 
+		 tclTHENSEQ
+		   [intros; 
+		    h_apply (interp_constr Evd.empty (Global.env()) c,Rawterm.NoBindings); 
+		    tclCOMPLETE Auto.default_auto
+		   ]
+	      )
+	      using_lemmas)
+	) tclIDTAC)
+	g);
+  try
+    by tclIDTAC; (* raises UserError _ if the proof is complete *)
+    if Options.is_verbose () then (pp (Printer.pr_open_subgoals()))
+  with UserError _ -> 
+    defined ()
+  
+    
+let com_terminate 
+    tcc_lemma_name 
+    tcc_lemma_ref 
+    is_mes 
+    fonctional_ref
+    input_type
+    relation 
+    rec_arg_num
+    thm_name using_lemmas hook =
+  let (evmap, env) = Command.get_current_context() in
+  start_proof thm_name
+    (Global, Proof Lemma) (Environ.named_context_val env)
+    (hyp_terminates fonctional_ref) hook;
+  by (observe_tac "whole_start" (whole_start is_mes fonctional_ref
+				       input_type relation rec_arg_num ));
+  try 
+    let new_goal_type = build_new_goal_type () in 
+    open_new_goal using_lemmas tcc_lemma_ref
+      (Some tcc_lemma_name)
+      (new_goal_type)
+  with Failure "empty list of subgoals!" -> 
+    (* a non recursive function declared with measure ! *)
+    defined ()
+
+    
+
+let ind_of_ref = function 
+  | IndRef (ind,i) -> (ind,i)
+  | _ -> anomaly "IndRef expected"
+
+let (value_f:constr list -> global_reference -> constr) =
+  fun al fterm ->
+    let d0 = dummy_loc in 
+    let rev_x_id_l =  
+      (
+	List.fold_left 
+	  (fun x_id_l _ -> 
+	     let x_id = next_global_ident_away true x_id x_id_l in 
+	     x_id::x_id_l
+	  )
+	  []
+	  al
+      )
+    in
+    let fun_body = 
+      RCases
+	(d0,None,
+	 [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l),
+	  (Anonymous,None)],
+	 [d0, [v_id], [PatCstr(d0,(ind_of_ref 
+				     (delayed_force coq_sig_ref),1),
+			       [PatVar(d0, Name v_id);
+				PatVar(d0, Anonymous)],
+			       Anonymous)],
+	  RVar(d0,v_id)])
+    in
+    let value =
+      List.fold_left2 
+	(fun acc x_id a -> 
+	   RLambda
+      	     (d0, Name x_id, RDynamic(d0, constr_in a),
+	      acc
+	     ) 
+	)
+	fun_body
+	rev_x_id_l
+	(List.rev al)
+    in
+    understand Evd.empty (Global.env()) value;;
+
+let (declare_fun : identifier -> logical_kind -> constr -> global_reference) =
+  fun f_id kind value ->
+    let ce = {const_entry_body = value;
+	      const_entry_type = None;
+	      const_entry_opaque = false;
+              const_entry_boxed = true} in
+      ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
+
+let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) =
+  fun f_id kind input_type fterm_ref ->
+    declare_fun f_id kind (value_f input_type fterm_ref);;
+
+let start_equation (f:global_reference) (term_f:global_reference) 
+  (cont_tactic:identifier list -> tactic) g =
+  let ids = pf_ids_of_hyps g in
+  let terminate_constr = constr_of_reference term_f in 
+  let nargs = nb_prod (type_of_const terminate_constr) in 
+  let x = 
+    let rec f ids n =
+      if n = 0 
+      then []
+      else 
+	let x = next_global_ident_away true x_id ids in 
+	x::f (x::ids) (n-1)
+    in
+    f ids nargs
+  in
+  tclTHENLIST [
+    h_intros x;
+    observe_tac "unfold_constr f" (unfold_constr f);
+    observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))));
+    observe_tac "prove_eq" (cont_tactic x)] g
+;;
+
+let base_leaf_eq func eqs f_id g =
+  let ids = pf_ids_of_hyps g in
+  let k = next_global_ident_away true k_id ids in
+  let p = next_global_ident_away true p_id (k::ids) in
+  let v = next_global_ident_away true v_id (p::k::ids) in
+  let heq = next_global_ident_away true heq_id (v::p::k::ids) in
+  let heq1 = next_global_ident_away true heq_id (heq::v::p::k::ids) in
+  let hex = next_global_ident_away true hex_id (heq1::heq::v::p::k::ids) in
+    tclTHENLIST [
+      h_intros [v; hex]; 
+      simplest_elim (mkVar hex);
+      h_intros [p;heq1];
+      tclTRY
+	(rewriteRL 
+	   (mkApp(mkVar heq1, 
+		  [|mkApp (delayed_force coq_S, [|mkVar p|]);
+		    mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
+      simpl_iter();
+      unfold_in_concl [([1], evaluable_of_global_reference func)];
+      list_rewrite true eqs;
+      apply (delayed_force refl_equal)] g;;
+
+let f_S t = mkApp(delayed_force coq_S, [|t|]);;
+
+let rec introduce_all_values_eq  cont_tac functional termine 
+    f p heq1 pmax bounds le_proofs eqs ids =
+  function
+      [] ->
+	tclTHENLIST
+	  [tclTHENS
+	     (general_rewrite_bindings false
+		(mkVar heq1,
+		 ExplicitBindings[dummy_loc,NamedHyp k_id,
+				  f_S(f_S(mkVar pmax));
+				  dummy_loc,NamedHyp def_id,
+				  f]))
+	     [tclTHENLIST
+		[simpl_iter();
+		 unfold_constr (reference_of_constr functional);
+		 list_rewrite true eqs; cont_tac pmax le_proofs];
+	      tclTHENLIST[apply (delayed_force le_lt_SS);
+			compute_le_proofs le_proofs]]]
+    | arg::args ->
+	let v' = next_global_ident_away true v_id ids in
+        let ids = v'::ids in
+	let hex' = next_global_ident_away true hex_id ids in
+        let ids = hex'::ids in
+	let p' = next_global_ident_away true p_id ids in
+        let ids = p'::ids in
+	let new_pmax = next_global_ident_away true pmax_id ids in
+        let ids = pmax::ids in
+	let hle1 = next_global_ident_away true hle_id ids in
+        let ids = hle1::ids in
+	let hle2 = next_global_ident_away true hle_id ids in
+        let ids = hle2::ids in
+	let heq = next_global_ident_away true heq_id ids in
+        let ids = heq::ids in
+	let heq2 = next_global_ident_away true heq_id ids in
+        let ids = heq2::ids in
+	tclTHENLIST
+	  [mkCaseEq(mkApp(termine, Array.of_list arg));
+	   h_intros [v'; hex'];
+	   simplest_elim(mkVar hex');
+	   h_intros [p'];
+	   simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax;
+							mkVar p'|]));
+	   h_intros [new_pmax;hle1;hle2];
+           introduce_all_values_eq 
+              (fun pmax' le_proofs'->
+		tclTHENLIST
+		  [cont_tac pmax' le_proofs';
+		   h_intros [heq;heq2];
+		   rewriteLR (mkVar heq2);
+		   tclTHENS
+		     (general_rewrite_bindings false
+			(mkVar heq,
+			 ExplicitBindings
+			   [dummy_loc, NamedHyp k_id,
+			    f_S(mkVar pmax');
+			    dummy_loc, NamedHyp def_id, f]))
+		     [tclIDTAC;
+		      tclTHENLIST
+			[apply (delayed_force le_lt_n_Sm);
+			 compute_le_proofs le_proofs']]])
+	     functional termine f p heq1 new_pmax
+	     (p'::bounds)((mkVar pmax)::le_proofs) eqs
+             (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args]
+  
+
+let rec_leaf_eq termine f ids functional eqs expr fn args =
+  let p = next_global_ident_away true p_id ids in
+  let ids = p::ids in
+  let v = next_global_ident_away true v_id ids in
+  let ids = v::ids in
+  let hex = next_global_ident_away true hex_id ids in
+  let ids = hex::ids in
+  let heq1 = next_global_ident_away true heq_id ids in
+  let ids = heq1::ids in
+  let hle1 = next_global_ident_away true hle_id ids in
+  let ids = hle1::ids in
+    tclTHENLIST
+      [h_intros [v;hex];
+       simplest_elim (mkVar hex);
+       h_intros [p;heq1];
+       generalize [mkApp(delayed_force le_n,[|mkVar p|])];
+       h_intros [hle1];
+       introduce_all_values_eq
+	 (fun _ _ -> tclIDTAC)
+	 functional termine f p heq1 p [] [] eqs ids args;
+       apply (delayed_force refl_equal)]
+
+let rec prove_eq  (termine:constr) (f:constr)(functional:global_reference)
+    (eqs:constr list)
+  (expr:constr) =
+  tclTRY
+    (match kind_of_term expr with
+      Case(_,t,a,l) ->
+	(match find_call_occs f a with
+	     _,[] -> 
+	       tclTHENS(mkCaseEq a)(* (simplest_case a) *)
+	  	 (List.map
+		    (fun expr -> observe_tac "mk_intros_and_continue" (mk_intros_and_continue true
+		       (prove_eq  termine f functional) eqs expr))
+		    (Array.to_list l))
+	   | _,_::_ ->
+               	(match find_call_occs f expr with
+	     _,[] -> base_leaf_eq functional eqs f
+	   | fn,args ->
+	       fun g ->
+		 let ids = ids_of_named_context (pf_hyps g) in
+	       rec_leaf_eq termine f ids
+		 (constr_of_reference functional)
+		 eqs expr fn args g))
+       | _ -> 
+	   (match find_call_occs f expr with
+		_,[] -> base_leaf_eq functional eqs f
+	      | fn,args ->
+		  fun g ->
+		    let ids = ids_of_named_context (pf_hyps g) in
+		    rec_leaf_eq  
+		      termine f ids (constr_of_reference functional)
+		      eqs expr fn args g));;
+
+let (com_eqn : identifier ->
+       global_reference -> global_reference -> global_reference
+	 -> constr -> unit) =
+  fun eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
+    let (evmap, env) = Command.get_current_context() in
+    let f_constr = (constr_of_reference f_ref) in
+    let equation_lemma_type = subst1 f_constr equation_lemma_type in
+    (start_proof eq_name (Global, Proof Lemma)
+       (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ());
+     by
+       (start_equation f_ref terminate_ref
+	  (fun x ->
+	     prove_eq 
+	       (constr_of_reference terminate_ref)
+	       f_constr 
+	       functional_ref
+	       []
+	       (instantiate_lambda
+	       	  (def_of_const (constr_of_reference functional_ref))
+	       	  (f_constr::List.map mkVar x)
+	       )
+	  )
+       );
+     Options.silently defined (); 
+    );;
+
+
+let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq 
+    generate_induction_principle using_lemmas : unit =
+  let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
+  let env = push_named (function_name,None,function_type) (Global.env()) in
+(*   Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *)
+  let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in 
+(*   Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *)
+  let res_vars,eq' = decompose_prod equation_lemma_type in 
+  let res = 
+(*     Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
+(*     Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
+(*     Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
+    match kind_of_term eq' with 
+      | App(e,[|_;_;eq_fix|]) -> 
+	  mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars  eq_fix))
+      | _ -> failwith "Recursive Definition (res not eq)"
+  in
+  let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in 
+  let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in
+  let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in
+  let equation_id = add_suffix function_name "_equation" in
+  let functional_id =  add_suffix function_name "_F" in
+  let term_id = add_suffix function_name "_terminate" in
+  let functional_ref = declare_fun functional_id (IsDefinition Definition) res in
+  let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in 
+  let relation = 
+    interp_constr
+      Evd.empty 
+      env_with_pre_rec_args
+      r
+  in 
+  let tcc_lemma_name = add_suffix function_name "_tcc" in
+  let tcc_lemma_constr = ref None in 
+(*   let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
+  let hook _ _ =   
+    let term_ref = Nametab.locate (make_short_qualid term_id) in
+    let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
+(*     message "start second proof"; *)
+    begin 
+      try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
+      with e -> 
+	begin 
+	  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
+	  then anomalylabstrm "" (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e);
+	  ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
+	  anomaly "Cannot create equation Lemma"
+	end
+    end;
+    let eq_ref = Nametab.locate (make_short_qualid equation_id ) in
+    let f_ref = destConst (constr_of_reference f_ref) 
+    and functional_ref = destConst (constr_of_reference functional_ref) 
+    and eq_ref = destConst (constr_of_reference eq_ref) in
+    generate_induction_principle f_ref tcc_lemma_constr
+     functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation;
+     if Options.is_verbose ()
+     then msgnl (h 1 (Ppconstr.pr_id function_name ++ 
+			spc () ++ str"is defined" )++ fnl () ++ 
+		   h 1 (Ppconstr.pr_id equation_id ++ 
+			  spc () ++ str"is defined" )
+		  )
+  in
+  try 
+    com_terminate 
+      tcc_lemma_name
+      tcc_lemma_constr
+      is_mes functional_ref
+      rec_arg_type
+      relation rec_arg_num
+      term_id
+      using_lemmas
+      hook 
+  with e -> 
+    begin
+      ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
+(*       anomaly "Cannot create termination Lemma" *)
+      raise e
+    end
+
+
+VERNAC COMMAND EXTEND RecursiveDefinition
+  [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
+     constr(proof) integer_opt(rec_arg_num) constr(eq) ] ->
+  [ 
+    warning "Recursive Definition is obsolete. Use Function instead";
+    ignore(proof);ignore(wf);
+    let rec_arg_num = 
+      match rec_arg_num with 
+	| None -> 1
+	| Some n -> n 
+    in
+    recursive_definition false f [] type_of_f r rec_arg_num eq (fun _ _ _ _ _  _ _ _ -> ()) []]
+| [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
+     "[" ne_constr_list(proof) "]" constr(eq) ] ->
+  [ ignore(proof);ignore(wf);recursive_definition false f [] type_of_f r 1 eq  (fun  _ _  _ _ _ _ _ _ -> ()) []]
+END
+
+
+
diff --git a/contrib/ring/ArithRing.v b/contrib/ring/LegacyArithRing.v
index 1a6e0ba6..e062b731 100644
--- a/contrib/ring/ArithRing.v
+++ b/contrib/ring/LegacyArithRing.v
@@ -6,17 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ArithRing.v,v 1.9.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: LegacyArithRing.v 9179 2006-09-26 12:13:06Z barras $ *)
 
 (* Instantiation of the Ring tactic for the naturals of Arith $*)
 
-Require Export Ring.
+Require Import Bool.
+Require Export LegacyRing.
 Require Export Arith.
 Require Import Eqdep_dec.
 
 Open Local Scope nat_scope.
 
-Fixpoint nateq (n m:nat) {struct m} : bool :=
+Unboxed Fixpoint nateq (n m:nat) {struct m} : bool :=
   match n, m with
   | O, O => true
   | S n', S m' => nateq n' m'
@@ -32,16 +33,16 @@ Proof.
   trivial.
 Qed.
 
-Hint Resolve nateq_prop eq2eqT: arithring.
+Hint Resolve nateq_prop: arithring.
 
 Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
   split; intros; auto with arith arithring.
-  apply eq2eqT; apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
-  apply eqT2eq; trivial.
+(*  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
+  trivial.*)
 Defined.
 
 
-Add Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
+Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
 
 Goal forall n:nat, S n = 1 + n.
 intro; reflexivity.
@@ -86,4 +87,4 @@ Ltac rewrite_S_to_plus :=
        change (t1 = t2) in |- *
   end.
 
-Ltac ring_nat := rewrite_S_to_plus; ring.
\ No newline at end of file
+Ltac ring_nat := rewrite_S_to_plus; ring.
diff --git a/contrib/ring/NArithRing.v b/contrib/ring/LegacyNArithRing.v
index cfec29ce..c689fc40 100644
--- a/contrib/ring/NArithRing.v
+++ b/contrib/ring/LegacyNArithRing.v
@@ -6,16 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: NArithRing.v,v 1.5.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: LegacyNArithRing.v 9179 2006-09-26 12:13:06Z barras $ *)
 
 (* Instantiation of the Ring tactic for the binary natural numbers *)
 
-Require Export Ring.
+Require Import Bool.
+Require Export LegacyRing.
 Require Export ZArith_base.
 Require Import NArith.
 Require Import Eqdep_dec.
 
-Definition Neq (n m:N) :=
+Unboxed Definition Neq (n m:N) :=
   match (n ?= m)%N with
   | Datatypes.Eq => true
   | _ => false
@@ -37,8 +38,9 @@ Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq.
     apply Nmult_1_l.
     apply Nmult_0_l.
     apply Nmult_plus_distr_r.
-    apply Nplus_reg_l.
+(*    apply Nplus_reg_l.*)
     apply Neq_prop.
 Qed.
 
-Add Semi Ring N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
\ No newline at end of file
+Add Legacy Semi Ring
+  N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
diff --git a/contrib/ring/Ring.v b/contrib/ring/LegacyRing.v
index 81497533..dc8635bd 100644
--- a/contrib/ring/Ring.v
+++ b/contrib/ring/LegacyRing.v
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring.v,v 1.9.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: Ring.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Bool.
-Require Export Ring_theory.
+Require Export LegacyRing_theory.
 Require Export Quote.
 Require Export Ring_normalize.
 Require Export Ring_abstract.
@@ -32,5 +32,5 @@ destruct n; destruct m; destruct p; reflexivity.
 destruct x; destruct y; reflexivity || simpl in |- *; tauto.
 Defined.
 
-Add Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
- [ true false ].
\ No newline at end of file
+Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
+ [ true false ].
diff --git a/contrib/ring/Ring_theory.v b/contrib/ring/LegacyRing_theory.v
index dfdfdf66..5df927a6 100644
--- a/contrib/ring/Ring_theory.v
+++ b/contrib/ring/LegacyRing_theory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_theory.v,v 1.21.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: LegacyRing_theory.v 9179 2006-09-26 12:13:06Z barras $ *)
 
 Require Export Bool.
 
@@ -39,7 +39,7 @@ Record Semi_Ring_Theory : Prop :=
    SR_mult_one_left : forall n:A, 1 * n = n;
    SR_mult_zero_left : forall n:A, 0 * n = 0;
    SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
-   SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;
+(*   SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*)
    SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
 
 Variable T : Semi_Ring_Theory.
@@ -52,10 +52,10 @@ Let plus_zero_left := SR_plus_zero_left T.
 Let mult_one_left := SR_mult_one_left T. 
 Let mult_zero_left := SR_mult_zero_left T.
 Let distr_left := SR_distr_left T.
-Let plus_reg_left := SR_plus_reg_left T.
+(*Let plus_reg_left := SR_plus_reg_left T.*)
 
 Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left mult_zero_left distr_left plus_reg_left.
+  mult_one_left mult_zero_left distr_left (*plus_reg_left*).
 
 (* Lemmas whose form is x=y are also provided in form y=x because Auto does
   not symmetry *) 
@@ -126,11 +126,11 @@ Qed.
 Lemma SR_mult_one_right2 : forall n:A, n = n * 1.
 intro; elim mult_comm; auto.
 Qed.
-
+(*
 Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
 intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto.
 Qed.
-
+*)
 End Theory_of_semi_rings.
 
 Section Theory_of_rings.
@@ -320,7 +320,7 @@ symmetry  in |- *; apply Th_mult_opp_opp. Qed.
 Lemma Th_opp_zero : - 0 = 0.
 rewrite <- (plus_zero_left (- 0)).
 auto. Qed.
-
+(*
 Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p.
 intros; generalize (f_equal (fun z => - n + z) H).
 repeat rewrite plus_assoc.
@@ -336,7 +336,7 @@ rewrite (plus_comm n m).
 rewrite (plus_comm n p).
 auto.
 Qed.
-
+*)
 Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
 intros.
 repeat rewrite (mult_comm n).
@@ -349,7 +349,7 @@ Qed.
 
 End Theory_of_rings.
 
-Hint Resolve Th_mult_zero_left Th_plus_reg_left: core.
+Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core.
 
 Unset Implicit Arguments.
 
@@ -373,4 +373,4 @@ End product_ring.
 
 Section power_ring.
 
-End power_ring.
\ No newline at end of file
+End power_ring.
diff --git a/contrib/ring/ZArithRing.v b/contrib/ring/LegacyZArithRing.v
index c511c076..a410fbc5 100644
--- a/contrib/ring/ZArithRing.v
+++ b/contrib/ring/LegacyZArithRing.v
@@ -6,15 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ZArithRing.v,v 1.5.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: LegacyZArithRing.v 9181 2006-09-26 16:38:33Z barras $ *)
 
 (* Instantiation of the Ring tactic for the binary integers of ZArith *)
 
-Require Export ArithRing.
+Require Export LegacyArithRing.
 Require Export ZArith_base.
 Require Import Eqdep_dec.
+Require Import LegacyRing.
 
-Definition Zeq (x y:Z) :=
+Unboxed Definition Zeq (x y:Z) :=
   match (x ?= y)%Z with
   | Datatypes.Eq => true
   | _ => false
@@ -27,10 +28,10 @@ Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
 Qed.
 
 Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq.
-  split; intros; apply eq2eqT; eauto with zarith.
-  apply eqT2eq; apply Zeq_prop; assumption.
+  split; intros; eauto with zarith.
+  apply Zeq_prop; assumption.
 Qed.
 
 (* NatConstants and NatTheory are defined in Ring_theory.v *)
-Add Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory
- [ Zpos Zneg 0%Z xO xI 1%positive ].
\ No newline at end of file
+Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory
+ [ Zpos Zneg 0%Z xO xI 1%positive ].
diff --git a/contrib/ring/Quote.v b/contrib/ring/Quote.v
index b4ac5745..6f7414a3 100644
--- a/contrib/ring/Quote.v
+++ b/contrib/ring/Quote.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Quote.v,v 1.7.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: Quote.v 6295 2004-11-12 16:40:39Z gregoire $ *)
 
 (***********************************************************************
   The "abstract" type index is defined to represent variables.
@@ -26,6 +26,7 @@
 ***********************************************************************)
 
 Set Implicit Arguments.
+Unset Boxed Definitions.
 
 Section variables_map.
 
@@ -81,4 +82,4 @@ Qed.
 
 End variables_map.
 
-Unset Implicit Arguments.
\ No newline at end of file
+Unset Implicit Arguments.
diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v
index de42e8c3..115ed5ca 100644
--- a/contrib/ring/Ring_abstract.v
+++ b/contrib/ring/Ring_abstract.v
@@ -6,12 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_abstract.v,v 1.13.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: Ring_abstract.v 9179 2006-09-26 12:13:06Z barras $ *)
 
-Require Import Ring_theory.
+Require Import LegacyRing_theory.
 Require Import Quote.
 Require Import Ring_normalize.
 
+Unset Boxed Definitions.
+
 Section abstract_semi_rings.
 
 Inductive aspolynomial : Type :=
@@ -127,7 +129,7 @@ Hint Resolve (SR_mult_zero_left T).
 Hint Resolve (SR_mult_zero_left2 T).
 Hint Resolve (SR_distr_left T).
 Hint Resolve (SR_distr_left2 T).
-Hint Resolve (SR_plus_reg_left T).
+(*Hint Resolve (SR_plus_reg_left T).*)
 Hint Resolve (SR_plus_permute T).
 Hint Resolve (SR_mult_permute T).
 Hint Resolve (SR_distr_right T).
@@ -138,7 +140,7 @@ Hint Resolve (SR_plus_zero_right T).
 Hint Resolve (SR_plus_zero_right2 T).
 Hint Resolve (SR_mult_one_right T).
 Hint Resolve (SR_mult_one_right2 T).
-Hint Resolve (SR_plus_reg_right T).
+(*Hint Resolve (SR_plus_reg_right T).*)
 Hint Resolve refl_equal sym_equal trans_equal.
 (*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
 Hint Immediate T.
@@ -437,7 +439,7 @@ Hint Resolve (Th_mult_zero_left T).
 Hint Resolve (Th_mult_zero_left2 T).
 Hint Resolve (Th_distr_left T).
 Hint Resolve (Th_distr_left2 T).
-Hint Resolve (Th_plus_reg_left T).
+(*Hint Resolve (Th_plus_reg_left T).*)
 Hint Resolve (Th_plus_permute T).
 Hint Resolve (Th_mult_permute T).
 Hint Resolve (Th_distr_right T).
@@ -447,7 +449,7 @@ Hint Resolve (Th_plus_zero_right T).
 Hint Resolve (Th_plus_zero_right2 T).
 Hint Resolve (Th_mult_one_right T).
 Hint Resolve (Th_mult_one_right2 T).
-Hint Resolve (Th_plus_reg_right T).
+(*Hint Resolve (Th_plus_reg_right T).*)
 Hint Resolve refl_equal sym_equal trans_equal.
 (*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
 Hint Immediate T.
@@ -701,4 +703,4 @@ Proof.
     rewrite H; reflexivity.
 Qed.  
 
-End abstract_rings.
\ No newline at end of file
+End abstract_rings.
diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v
index 8c0fd5fb..4a082396 100644
--- a/contrib/ring/Ring_normalize.v
+++ b/contrib/ring/Ring_normalize.v
@@ -6,12 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Ring_normalize.v,v 1.16.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: Ring_normalize.v 9179 2006-09-26 12:13:06Z barras $ *)
 
-Require Import Ring_theory.
+Require Import LegacyRing_theory.
 Require Import Quote.
 
 Set Implicit Arguments.
+Unset Boxed Definitions.
 
 Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
 Proof.
@@ -355,7 +356,7 @@ Hint Resolve (SR_mult_zero_left T).
 Hint Resolve (SR_mult_zero_left2 T).
 Hint Resolve (SR_distr_left T).
 Hint Resolve (SR_distr_left2 T).
-Hint Resolve (SR_plus_reg_left T).
+(*Hint Resolve (SR_plus_reg_left T).*)
 Hint Resolve (SR_plus_permute T).
 Hint Resolve (SR_mult_permute T).
 Hint Resolve (SR_distr_right T).
@@ -366,7 +367,7 @@ Hint Resolve (SR_plus_zero_right T).
 Hint Resolve (SR_plus_zero_right2 T).
 Hint Resolve (SR_mult_one_right T).
 Hint Resolve (SR_mult_one_right2 T).
-Hint Resolve (SR_plus_reg_right T).
+(*Hint Resolve (SR_plus_reg_right T).*)
 Hint Resolve refl_equal sym_equal trans_equal.
 (* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
 Hint Immediate T.
@@ -784,7 +785,7 @@ Hint Resolve (Th_mult_zero_left T).
 Hint Resolve (Th_mult_zero_left2 T).
 Hint Resolve (Th_distr_left T).
 Hint Resolve (Th_distr_left2 T).
-Hint Resolve (Th_plus_reg_left T).
+(*Hint Resolve (Th_plus_reg_left T).*)
 Hint Resolve (Th_plus_permute T).
 Hint Resolve (Th_mult_permute T).
 Hint Resolve (Th_distr_right T).
@@ -795,7 +796,7 @@ Hint Resolve (Th_plus_zero_right T).
 Hint Resolve (Th_plus_zero_right2 T).
 Hint Resolve (Th_mult_one_right T).
 Hint Resolve (Th_mult_one_right2 T).
-Hint Resolve (Th_plus_reg_right T).
+(*Hint Resolve (Th_plus_reg_right T).*)
 Hint Resolve refl_equal sym_equal trans_equal.
 (*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
 Hint Immediate T.
@@ -898,4 +899,4 @@ Infix "*" := Pmult : ring_scope.
 Notation "- x" := (Popp x) : ring_scope.
 Notation "[ x ]" := (Pvar x) (at level 1) : ring_scope.
 
-Delimit Scope ring_scope with ring.
\ No newline at end of file
+Delimit Scope ring_scope with ring.
diff --git a/contrib/ring/Setoid_ring.v b/contrib/ring/Setoid_ring.v
index c4537fe3..7bf33b17 100644
--- a/contrib/ring/Setoid_ring.v
+++ b/contrib/ring/Setoid_ring.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring.v,v 1.4.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: Setoid_ring.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Setoid_ring_theory.
 Require Export Quote.
diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v
index 0c9c1e6a..56329ade 100644
--- a/contrib/ring/Setoid_ring_normalize.v
+++ b/contrib/ring/Setoid_ring_normalize.v
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring_normalize.v,v 1.11.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: Setoid_ring_normalize.v 6662 2005-02-02 21:33:14Z sacerdot $ *)
 
 Require Import Setoid_ring_theory.
 Require Import Quote.
 
 Set Implicit Arguments.
-
+Unset Boxed Definitions.
+ 
 Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
 Proof.
   simple induction n; simple induction m; simpl in |- *;
@@ -34,24 +35,24 @@ Variable Aeq : A -> A -> bool.
 
 Variable S : Setoid_Theory A Aequiv.
 
-Add Setoid A Aequiv S.
+Add Setoid A Aequiv S as Asetoid.
 
-Variable
-  plus_morph :
-    forall a a0 a1 a2:A,
-      Aequiv a a0 -> Aequiv a1 a2 -> Aequiv (Aplus a a1) (Aplus a0 a2).
-Variable
-  mult_morph :
-    forall a a0 a1 a2:A,
-      Aequiv a a0 -> Aequiv a1 a2 -> Aequiv (Amult a a1) (Amult a0 a2).
+Variable plus_morph :
+ forall a a0:A, Aequiv a a0 ->
+   forall a1 a2:A, Aequiv a1 a2 ->
+     Aequiv (Aplus a a1)  (Aplus a0 a2).
+Variable mult_morph :
+ forall a a0:A, Aequiv a a0 ->
+   forall a1 a2:A, Aequiv a1 a2 ->
+     Aequiv (Amult a a1) (Amult a0 a2).
 Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0).
 
 Add Morphism Aplus : Aplus_ext.
-exact plus_morph.
+intros; apply plus_morph; assumption.
 Qed.
 
 Add Morphism Amult : Amult_ext.
-exact mult_morph.
+intros; apply mult_morph; assumption.
 Qed.
 
 Add Morphism Aopp : Aopp_ext.
@@ -488,19 +489,22 @@ rewrite (interp_m_ok (Aplus a a0) v0).
 rewrite (interp_m_ok a v0).
 rewrite (interp_m_ok a0 v0).
 setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with
- (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))).
+ (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)));
+ [ idtac | trivial ].
 setoid_replace
  (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)))
     (Aplus (interp_setcs c) (interp_setcs c0))) with
  (Aplus (Amult a (interp_vl v0))
     (Aplus (Amult a0 (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0)))).
+       (Aplus (interp_setcs c) (interp_setcs c0))));
+ [ idtac | trivial ].
 setoid_replace
  (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
     (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with
  (Aplus (Amult a (interp_vl v0))
     (Aplus (interp_setcs c)
-       (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0)))).
+       (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))));
+ [ idtac | trivial ].
 auto.
 
 elim (varlist_lt v v0); simpl in |- *.
@@ -550,19 +554,23 @@ rewrite (H c0).
 rewrite (interp_m_ok (Aplus a Aone) v0).
 rewrite (interp_m_ok a v0).
 setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with
- (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))).
+ (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)));
+ [ idtac | trivial ].
 setoid_replace
  (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)))
     (Aplus (interp_setcs c) (interp_setcs c0))) with
  (Aplus (Amult a (interp_vl v0))
     (Aplus (Amult Aone (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0)))).
+       (Aplus (interp_setcs c) (interp_setcs c0))));
+ [ idtac | trivial ].
 setoid_replace
  (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
     (Aplus (interp_vl v0) (interp_setcs c0))) with
  (Aplus (Amult a (interp_vl v0))
-    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))).
-setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0).
+    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0);
+ [ idtac | trivial ].
 auto.
 
 elim (varlist_lt v v0); simpl in |- *.
@@ -613,18 +621,21 @@ rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0));
 rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0).
 setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with
  (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)));
- setoid_replace
-  (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)))
-     (Aplus (interp_setcs c) (interp_setcs c0))) with
-  (Aplus (Amult Aone (interp_vl v0))
-     (Aplus (Amult a (interp_vl v0))
-        (Aplus (interp_setcs c) (interp_setcs c0))));
- setoid_replace
-  (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-     (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with
-  (Aplus (interp_vl v0)
-     (Aplus (interp_setcs c)
-        (Aplus (Amult a (interp_vl v0)) (interp_setcs c0)))).
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)))
+    (Aplus (interp_setcs c) (interp_setcs c0))) with
+ (Aplus (Amult Aone (interp_vl v0))
+    (Aplus (Amult a (interp_vl v0))
+       (Aplus (interp_setcs c) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (interp_vl v0) (interp_setcs c))
+    (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with
+ (Aplus (interp_vl v0)
+    (Aplus (interp_setcs c)
+       (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))));
+ [ idtac | trivial ].
 auto.
 
 elim (varlist_lt v v0); simpl in |- *; intros.
@@ -668,17 +679,20 @@ rewrite
 rewrite (interp_m_ok (Aplus Aone Aone) v0).
 setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with
  (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)));
- setoid_replace
-  (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)))
-     (Aplus (interp_setcs c) (interp_setcs c0))) with
-  (Aplus (Amult Aone (interp_vl v0))
-     (Aplus (Amult Aone (interp_vl v0))
-        (Aplus (interp_setcs c) (interp_setcs c0))));
- setoid_replace
-  (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-     (Aplus (interp_vl v0) (interp_setcs c0))) with
-  (Aplus (interp_vl v0)
-     (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))).
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)))
+    (Aplus (interp_setcs c) (interp_setcs c0))) with
+ (Aplus (Amult Aone (interp_vl v0))
+    (Aplus (Amult Aone (interp_vl v0))
+       (Aplus (interp_setcs c) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (interp_vl v0) (interp_setcs c))
+    (Aplus (interp_vl v0) (interp_setcs c0))) with
+ (Aplus (interp_vl v0)
+    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
+[ idtac | trivial ].
 setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto.
 
 elim (varlist_lt v v0); simpl in |- *.
@@ -727,7 +741,8 @@ rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
  rewrite (ics_aux_ok (interp_m a0 v) c).
 rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v).
 setoid_replace (Amult (Aplus a a0) (interp_vl v)) with
- (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v))).
+ (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v)));
+ [ idtac | trivial ].
 auto.
 
 elim (varlist_lt l v); simpl in |- *; intros.
@@ -746,8 +761,10 @@ rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
  rewrite (ics_aux_ok (interp_vl v) c).
 rewrite (interp_m_ok (Aplus a Aone) v).
 setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with
- (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v))).
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v).
+ (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v)));
+ [ idtac | trivial ].
+setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v);
+ [ idtac | trivial ].
 auto.
 
 elim (varlist_lt l v); simpl in |- *; intros; auto.
@@ -769,7 +786,8 @@ rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
  rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v).
 setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with
- (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v))).
+ (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v)));
+ [ idtac | trivial ].
 setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
 
 elim (varlist_lt l v); simpl in |- *; intros; auto.
@@ -784,7 +802,8 @@ rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
  rewrite (ics_aux_ok (interp_vl v) c).
 rewrite (interp_m_ok (Aplus Aone Aone) v).
 setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with
- (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v))).
+ (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v)));
+ [ idtac | trivial ].
 setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
 
 elim (varlist_lt l v); simpl in |- *; intros; auto.
@@ -806,7 +825,8 @@ rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c));
 rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v).
 rewrite H.
 setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c)))
- with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c))).
+ with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c)));
+ [ idtac | trivial ].
 auto.
 
 rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c));
@@ -829,7 +849,8 @@ rewrite (varlist_merge_ok l v).
 setoid_replace
  (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with
  (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-    (Amult (interp_vl l) (interp_setcs c))).
+    (Amult (interp_vl l) (interp_setcs c)));
+ [ idtac | trivial ].
 auto.
 
 rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)).
@@ -858,15 +879,18 @@ rewrite (varlist_merge_ok l v).
 setoid_replace
  (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with
  (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-    (Amult (interp_vl l) (interp_setcs c0))).
+    (Amult (interp_vl l) (interp_setcs c0)));
+ [ idtac | trivial ].
 setoid_replace
  (Amult c
     (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
        (Amult (interp_vl l) (interp_setcs c0)))) with
  (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v))))
-    (Amult c (Amult (interp_vl l) (interp_setcs c0)))).
+    (Amult c (Amult (interp_vl l) (interp_setcs c0))));
+ [ idtac | trivial ].
 setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with
- (Amult c (Amult a (Amult (interp_vl l) (interp_vl v)))).
+ (Amult c (Amult a (Amult (interp_vl l) (interp_vl v))));
+ [ idtac | trivial ].
 auto.
 
 rewrite
@@ -880,7 +904,8 @@ setoid_replace
     (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with
  (Amult c
     (Aplus (Amult (interp_vl l) (interp_vl v))
-       (Amult (interp_vl l) (interp_setcs c0)))).
+       (Amult (interp_vl l) (interp_setcs c0))));
+ [ idtac | trivial ].
 auto.
 Qed.
 
@@ -900,12 +925,14 @@ rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (interp_m_ok a v).
 rewrite (H y).
 setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with
- (Amult (Amult a (interp_vl v)) (interp_setcs y)).
+ (Amult (Amult a (interp_vl v)) (interp_setcs y));
+ [ idtac | trivial ].
 setoid_replace
  (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y))
  with
  (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y))
-    (Amult (interp_setcs c) (interp_setcs y))).
+    (Amult (interp_setcs c) (interp_setcs y)));
+ [ idtac | trivial ].
 trivial.
 
 rewrite
@@ -947,7 +974,8 @@ intros.
 rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (interp_m_ok a v).
 rewrite (H0 I).
-setoid_replace (Amult Azero (interp_vl v)) with Azero.
+setoid_replace (Amult Azero (interp_vl v)) with Azero;
+ [ idtac | trivial ].
 rewrite H.
 trivial.
 
@@ -1134,4 +1162,4 @@ Qed.
 
 End setoid_rings.
 
-End setoid.
\ No newline at end of file
+End setoid.
diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v
index 69712216..ae6610d3 100644
--- a/contrib/ring/Setoid_ring_theory.v
+++ b/contrib/ring/Setoid_ring_theory.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Setoid_ring_theory.v,v 1.16.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: Setoid_ring_theory.v 6662 2005-02-02 21:33:14Z sacerdot $ *)
 
 Require Export Bool.
 Require Export Setoid.
@@ -22,7 +22,7 @@ Infix Local "==" := Aequiv (at level 70, no associativity).
 
 Variable S : Setoid_Theory A Aequiv.
 
-Add Setoid A Aequiv S.
+Add Setoid A Aequiv S as Asetoid.
 
 Variable Aplus : A -> A -> A.
 Variable Amult : A -> A -> A.
@@ -37,18 +37,18 @@ Notation "0" := Azero.
 Notation "1" := Aone.
 Notation "- x" := (Aopp x).
 
-Variable
-  plus_morph : forall a a0 a1 a2:A, a == a0 -> a1 == a2 -> a + a1 == a0 + a2.
-Variable
-  mult_morph : forall a a0 a1 a2:A, a == a0 -> a1 == a2 -> a * a1 == a0 * a2.
+Variable plus_morph :
+ forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2.
+Variable mult_morph :
+  forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2.
 Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0.
 
 Add Morphism Aplus : Aplus_ext.
-exact plus_morph.
+intros; apply plus_morph; assumption.
 Qed.
 
 Add Morphism Amult : Amult_ext.
-exact mult_morph.
+intros; apply mult_morph; assumption.
 Qed.
 
 Add Morphism Aopp : Aopp_ext.
@@ -424,4 +424,4 @@ Section power_ring.
 
 End power_ring.
 
-End Setoid_rings.
\ No newline at end of file
+End Setoid_rings.
diff --git a/contrib/ring/g_quote.ml4 b/contrib/ring/g_quote.ml4
index af23a8f7..d0058026 100644
--- a/contrib/ring/g_quote.ml4
+++ b/contrib/ring/g_quote.ml4
@@ -8,11 +8,11 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_quote.ml4,v 1.1.12.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: g_quote.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
 
 open Quote
 
-TACTIC EXTEND Quote
-  [ "Quote" ident(f) ] -> [ quote f [] ]
-| [ "Quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ]
+TACTIC EXTEND quote
+  [ "quote" ident(f) ] -> [ quote f [] ]
+| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ]
 END
diff --git a/contrib/ring/g_ring.ml4 b/contrib/ring/g_ring.ml4
index f7c74c0b..2f964988 100644
--- a/contrib/ring/g_ring.ml4
+++ b/contrib/ring/g_ring.ml4
@@ -8,13 +8,14 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: g_ring.ml4,v 1.4.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+(* $Id: g_ring.ml4 9178 2006-09-26 11:18:22Z barras $ *)
 
 open Quote
 open Ring
+open Tacticals
 
-TACTIC EXTEND Ring
-  [ "Ring" constr_list(l) ] -> [ polynom l ]
+TACTIC EXTEND ring
+| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ]
 END
 
 (* The vernac commands "Add Ring" and co *)
@@ -23,7 +24,7 @@ let cset_of_constrarg_list l =
   List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty
 
 VERNAC COMMAND EXTEND AddRing
-  [ "Add" "Ring" 
+  [ "Add" "Legacy" "Ring" 
           constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
           constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] 
   -> [ add_theory true false false
@@ -40,7 +41,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Semi" "Ring" 
+| [ "Add" "Legacy" "Semi" "Ring" 
       	  constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
           constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] 
   -> [ add_theory false false false
@@ -57,7 +58,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Abstract" "Ring" 
+| [ "Add" "Legacy" "Abstract" "Ring" 
     	  constr(a) constr(aplus) constr(amult) constr(aone)
           constr(azero) constr(aopp) constr(aeq) constr(t) ] 
   -> [ add_theory true true false
@@ -74,7 +75,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 ConstrSet.empty ]
 
-| [ "Add" "Abstract" "Semi" "Ring" 
+| [ "Add" "Legacy" "Abstract" "Semi" "Ring" 
           constr(a) constr(aplus) constr(amult) constr(aone)
           constr(azero) constr(aeq) constr(t) ] 
   -> [ add_theory false true false
@@ -91,7 +92,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 ConstrSet.empty ]
 
-| [ "Add" "Setoid" "Ring"
+| [ "Add" "Legacy" "Setoid" "Ring"
       	  constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) 
 	  constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm)
 	  constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] 
@@ -112,7 +113,7 @@ VERNAC COMMAND EXTEND AddRing
 			 (constr_of t)
 			 (cset_of_constrarg_list l) ]
 
-| [ "Add" "Semi" "Setoid" "Ring" 
+| [ "Add" "Legacy" "Semi" "Setoid" "Ring" 
           constr(a) constr(aequiv) constr(asetth) constr(aplus)
 	  constr(amult) constr(aone) constr(azero) constr(aeq) 
           constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] 
diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml
index bda04db3..e0a6cba3 100644
--- a/contrib/ring/quote.ml
+++ b/contrib/ring/quote.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: quote.ml,v 1.30.2.1 2004/07/16 19:30:14 herbelin Exp $ *)
+(* $Id: quote.ml 9178 2006-09-26 11:18:22Z barras $ *)
 
 (* The `Quote' tactic *)
 
@@ -107,7 +107,6 @@ open Pp
 open Util
 open Names
 open Term
-open Instantiate
 open Pattern
 open Matching
 open Tacmach
@@ -213,7 +212,7 @@ let compute_rhs bodyi index_of_f =
 	  PMeta (Some (coerce_meta_in i))
       | App (f,args) ->
           PApp (pattern_of_constr f, Array.map aux args)
-      | Cast (c,t) -> aux c 
+      | Cast (c,_,_) -> aux c 
       | _ -> pattern_of_constr c
   in
   aux bodyi
@@ -298,8 +297,8 @@ binary search trees (see file \texttt{Quote.v}) *)
 let rec closed_under cset t =
   (ConstrSet.mem t cset) or
   (match (kind_of_term t) with
-     | Cast(c,_) -> closed_under cset c  
-     | App(f,l) -> closed_under cset f & array_for_all (closed_under cset) l
+     | Cast(c,_,_) -> closed_under cset c  
+     | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l
      | _ -> false)
     
 (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete
@@ -361,7 +360,7 @@ let rec subterm gl (t : constr) (t' : constr) =
   (pf_conv_x gl t t') or
   (match (kind_of_term t) with 
      | App (f,args) -> array_exists (fun t -> subterm gl t t') args
-     | Cast(t,_) -> (subterm gl t t')
+     | Cast(t,_,_) -> (subterm gl t t')
      | _ -> false)
            
 (*s We want to sort the list according to reverse subterm order. *)
@@ -386,7 +385,7 @@ let rec sort_subterm gl l =
   [gl: goal sigma]\\ *)
 
 let quote_terms ivs lc gl =
-  Library.check_required_library ["Coq";"ring";"Quote"];
+  Coqlib.check_required_library ["Coq";"ring";"Quote"];
   let varhash  = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
   let counter = ref 1 in (* number of variables created + 1 *)
@@ -448,8 +447,8 @@ let quote f lid gl =
     | _ -> assert false
   in
   match ivs.variable_lhs with
-    | None -> Tactics.convert_concl (mkApp (f, [| p |])) gl
-    | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) gl
+    | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl
+    | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl
 
 (*i 
 
diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml
index 378f19a4..6b82b75b 100644
--- a/contrib/ring/ring.ml
+++ b/contrib/ring/ring.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ring.ml,v 1.49.2.1 2004/07/16 19:30:14 herbelin Exp $ *)
+(* $Id: ring.ml 9179 2006-09-26 12:13:06Z barras $ *)
 
 (* ML part of the Ring tactic *)
 
@@ -34,6 +34,7 @@ open Pattern
 open Hiddentac
 open Nametab
 open Quote
+open Mod_subst
 
 let mt_evd = Evd.empty
 let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c
@@ -42,7 +43,7 @@ let ring_dir = ["Coq";"ring"]
 let setoids_dir = ["Coq";"Setoids"]
 
 let ring_constant = Coqlib.gen_constant_in_modules "Ring"
-  [ring_dir@["Ring_theory"];
+  [ring_dir@["LegacyRing_theory"];
    ring_dir@["Setoid_ring_theory"];
    ring_dir@["Ring_normalize"];
    ring_dir@["Ring_abstract"];
@@ -286,7 +287,7 @@ let guess_theory a =
   with Not_found -> 
     errorlabstrm "Ring" 
       (str "No Declared Ring Theory for " ++
-	 prterm a ++ fnl () ++
+	 pr_lconstr a ++ fnl () ++
 	 str "Use Add [Semi] Ring to declare it")
 
 (* Looks up an option *)
@@ -306,23 +307,42 @@ let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false
 let implement_theory env t th args =
   is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args))
 
+(* The following test checks whether the provided morphism is the default
+   one for the given operation. In principle the test is too strict, since
+   it should possible to provide another proof for the same fact (proof
+   irrelevance). In particular, the error message is be not very explicative. *)
+let states_compatibility_for env plus mult opp morphs =
+ let check op compat =
+  is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem
+   compat in
+ check plus morphs.plusm &&
+ check mult morphs.multm &&
+ (match (opp,morphs.oppm) with
+     None, None -> true
+   | Some opp, Some compat -> check opp compat
+   | _,_ -> assert false)
+
 let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = 
   if theories_map_mem a then errorlabstrm "Add Semi Ring" 
     (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++
-       prterm a);
+       pr_lconstr a);
   let env = Global.env () in
-    if (want_ring & want_setoid &
+    if (want_ring & want_setoid & (
 	not (implement_theory env t coq_Setoid_Ring_Theory
 	  [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|])
-        &
+        ||
 	not (implement_theory env (unbox asetth) coq_Setoid_Theory
-	  [| a; (unbox aequiv) |])) then 
+	  [| a; (unbox aequiv) |]) ||
+        not (states_compatibility_for env aplus amult aopp (unbox amorph))
+        )) then 
       errorlabstrm "addring" (str "Not a valid Setoid-Ring theory");
-    if (not want_ring & want_setoid &
+    if (not want_ring & want_setoid & (
         not (implement_theory env t coq_Semi_Setoid_Ring_Theory 
-	  [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) &
+	  [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) ||
 	not (implement_theory env (unbox asetth) coq_Setoid_Theory
-	  [| a; (unbox aequiv) |])) then 
+	  [| a; (unbox aequiv) |]) ||
+        not (states_compatibility_for env aplus amult aopp (unbox amorph))))
+    then
       errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory");
     if (want_ring & not want_setoid &
 	not (implement_theory env t coq_Ring_Theory
@@ -705,10 +725,10 @@ let build_setspolynom gl th lc =
 			       th.th_eq; p |])) |]),
 	mkLApp(coq_setspolynomial_simplify_ok,
 	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
-                  th.th_mult; th.th_one; th.th_zero; th.th_eq; v;
-                  th.th_t; (unbox th.th_setoid_th);
+                  th.th_mult; th.th_one; th.th_zero; th.th_eq;
+                  (unbox th.th_setoid_th);
 		  (unbox th.th_morph).plusm;
-                  (unbox th.th_morph).multm; p |])))
+                  (unbox th.th_morph).multm; v; th.th_t; p |])))
     lp
 
 module SectionPathSet =
@@ -724,7 +744,7 @@ let constants_to_unfold =
   let transform s = 
     let sp = path_of_string s in
     let dir, id = repr_path sp in
-      Libnames.encode_kn dir id 
+      Libnames.encode_con dir id 
   in
   List.map transform
     [ "Coq.ring.Ring_normalize.interp_cs";
@@ -753,7 +773,7 @@ open RedFlags
 let polynom_unfold_tac =
   let flags =
     (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in
-  reduct_in_concl (cbv_norm_flags flags)
+  reduct_in_concl (cbv_norm_flags flags,DEFAULTcast)
       
 let polynom_unfold_tac_in_term gl =
   let flags = 
@@ -804,20 +824,22 @@ let raw_polynom th op lc gl =
 				  [| th.th_a; (unbox th.th_equiv);
                                      (unbox th.th_setoid_th);
 				     c'''i; ci; c'i_eq_c''i |]))))
-	      (tclTHEN 
-		 (Setoid_replace.setoid_replace ci c'''i None)
-		 (tclTHEN 
-		    (tclTRY (h_exact c'i_eq_c''i))
-		    tac)))
+	      (tclTHENS
+		 (tclORELSE
+                   (Setoid_replace.general_s_rewrite true c'i_eq_c''i
+                     ~new_goals:[])
+                   (Setoid_replace.general_s_rewrite false c'i_eq_c''i
+                     ~new_goals:[]))
+                 [tac]))
 	 else
            (tclORELSE
               (tclORELSE
 		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkApp(build_coq_sym_eqT (),
+		 (h_exact (mkApp(build_coq_sym_eq (),
 				 [|th.th_a; c'''i; ci; c'i_eq_c''i |]))))
 	      (tclTHENS 
 		 (elim_type 
-		    (mkApp(build_coq_eqT (), [|th.th_a; c'''i; ci |])))
+		    (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |])))
 		 [ tac;
                    h_exact c'i_eq_c''i ]))
 )
@@ -863,7 +885,7 @@ let match_with_equiv c = match (kind_of_term c) with
   | _ -> None
 
 let polynom lc gl =
-  Library.check_required_library ["Coq";"ring";"Ring"];
+  Coqlib.check_required_library ["Coq";"ring";"LegacyRing"];
   match lc with 
    (* If no argument is given, try to recognize either an equality or
       a declared relation with arguments c1 ... cn, 
diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v
index b3895b2a..19933873 100644
--- a/contrib/romega/ROmega.v
+++ b/contrib/romega/ROmega.v
@@ -6,6 +6,5 @@
 
  *************************************************************************)
 
-Require Import Omega.
 Require Import ReflOmegaCore.
 
diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v
index 3dfb5593..83ea5b63 100644
--- a/contrib/romega/ReflOmegaCore.v
+++ b/contrib/romega/ReflOmegaCore.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
@@ -9,9 +10,11 @@
 Require Import Arith.
 Require Import List.
 Require Import Bool.
-Require Import ZArith.
+Require Import ZArith_base.
 Require Import OmegaLemmas.
 
+Open Scope Z_scope.
+
 (* \subsection{Definition of basic types} *)
 
 (* \subsubsection{Environment of propositions (lists) *)
@@ -45,6 +48,18 @@ Inductive term : Set :=
   | Topp : term -> term
   | Tvar : nat -> term.
 
+Delimit Scope romega_scope with term.
+Arguments Scope Tplus [romega_scope romega_scope].
+Arguments Scope Tmult [romega_scope romega_scope].
+Arguments Scope Tminus [romega_scope romega_scope].
+Arguments Scope Topp [romega_scope romega_scope].
+
+Infix "+" := Tplus : romega_scope.
+Infix "*" := Tmult : romega_scope.
+Infix "-" := Tminus : romega_scope.
+Notation "- x" := (Topp x) : romega_scope.
+Notation "[ x ]" := (Tvar x) (at level 1) : romega_scope.
+
 (* \subsubsection{Definition of reified goals} *)
 (* Very restricted definition of handled predicates that should be extended
    to cover a wider set of operations.
@@ -67,13 +82,13 @@ Inductive proposition : Set :=
   | Tprop : nat -> proposition.
 
 (* Definition of goals as a list of hypothesis *)
-Notation hyps := (list proposition) (only parsing).      
+Notation hyps := (list proposition).      
 
 (* Definition of lists of subgoals  (set of open goals) *)
-Notation lhyps := (list (list proposition)) (only parsing).
+Notation lhyps := (list hyps).
 
 (* a syngle goal packed in a subgoal list *)
-Notation singleton := (fun a : list proposition => a :: nil) (only parsing).
+Notation singleton := (fun a : hyps => a :: nil).
 
 (* an absurd goal *)
 Definition absurd := FalseTerm :: nil.
@@ -120,7 +135,7 @@ Inductive step : Set :=
   | C_PLUS_ASSOC_R : step
   | C_PLUS_ASSOC_L : step
   | C_PLUS_PERMUTE : step
-  | C_PLUS_SYM : step
+  | C_PLUS_COMM : step
   | C_RED0 : step
   | C_RED1 : step
   | C_RED2 : step
@@ -130,7 +145,7 @@ Inductive step : Set :=
   | C_RED6 : step
   | C_MULT_ASSOC_REDUCED : step
   | C_MINUS : step
-  | C_MULT_SYM : step.
+  | C_MULT_COMM : step.
 
 (* \subsubsection{Omega steps} *)
 (* The following inductive type describes steps as they can be found in
@@ -176,7 +191,7 @@ Inductive p_step : Set :=
    type [p_step] permettant
    de parcourir à la fois les branches gauches et droit, on pourrait n'avoir
    qu'une normalisation par hypothèse. Et comme toutes les hypothèses sont 
-   utiles (sinon on ne les incluerait pas), on pourrait remplacer [h_step] 
+   utiles (sinon on ne les inclurait pas), on pourrait remplacer [h_step] 
    par une simple liste *)
 
 Inductive h_step : Set :=
@@ -360,29 +375,31 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool :=
                 | Tint st2 => eq_Z st1 st2
                 | _ => false
                 end
-  | Tplus st11 st12 =>
+  | (st11 + st12)%term =>
       match t2 with
-      | Tplus st21 st22 => eq_term st11 st21 && eq_term st12 st22
+      | (st21 + st22)%term => eq_term st11 st21 && eq_term st12 st22
       | _ => false
       end
-  | Tmult st11 st12 =>
+  | (st11 * st12)%term =>
       match t2 with
-      | Tmult st21 st22 => eq_term st11 st21 && eq_term st12 st22
+      | (st21 * st22)%term => eq_term st11 st21 && eq_term st12 st22
       | _ => false
       end
-  | Tminus st11 st12 =>
+  | (st11 - st12)%term =>
       match t2 with
-      | Tminus st21 st22 => eq_term st11 st21 && eq_term st12 st22
+      | (st21 - st22)%term => eq_term st11 st21 && eq_term st12 st22
+      | _ => false
+      end
+  | (- st1)%term =>
+      match t2 with
+      | (- st2)%term => eq_term st1 st2
+      | _ => false
+      end
+  | [st1]%term =>
+      match t2 with
+      | [st2]%term => eq_nat st1 st2
       | _ => false
       end
-  | Topp st1 => match t2 with
-                | Topp st2 => eq_term st1 st2
-                | _ => false
-                end
-  | Tvar st1 => match t2 with
-                | Tvar st2 => eq_nat st1 st2
-                | _ => false
-                end
   end.  
 
 Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2.
@@ -480,15 +497,15 @@ Ltac elim_eq_pos t1 t2 :=
    avec son théorème *)
 
 Theorem relation_ind2 :
- forall (P : Datatypes.comparison -> Prop) (b : Datatypes.comparison),
- (b = Datatypes.Eq -> P Datatypes.Eq) ->
- (b = Datatypes.Lt -> P Datatypes.Lt) ->
- (b = Datatypes.Gt -> P Datatypes.Gt) -> P b.
+ forall (P : comparison -> Prop) (b : comparison),
+ (b = Eq -> P Eq) ->
+ (b = Lt -> P Lt) ->
+ (b = Gt -> P Gt) -> P b.
 
 simple induction b; auto.
 Qed.
 
-Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2)%Z in |- *; apply relation_ind2.
+Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2) in |- *; apply relation_ind2.
 
 (* \subsection{Interprétations}
    \subsubsection{Interprétation des termes dans Z} *)
@@ -496,11 +513,11 @@ Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2)%Z in |- *; apply relation_ind2.
 Fixpoint interp_term (env : list Z) (t : term) {struct t} : Z :=
   match t with
   | Tint x => x
-  | Tplus t1 t2 => (interp_term env t1 + interp_term env t2)%Z
-  | Tmult t1 t2 => (interp_term env t1 * interp_term env t2)%Z
-  | Tminus t1 t2 => (interp_term env t1 - interp_term env t2)%Z
-  | Topp t => (- interp_term env t)%Z
-  | Tvar n => nth n env 0%Z
+  | (t1 + t2)%term => interp_term env t1 + interp_term env t2
+  | (t1 * t2)%term => interp_term env t1 * interp_term env t2
+  | (t1 - t2)%term => interp_term env t1 - interp_term env t2
+  | (- t)%term => - interp_term env t
+  | [n]%term => nth n env 0
   end.
 
 (* \subsubsection{Interprétation des prédicats} *) 
@@ -508,13 +525,13 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z)
  (p : proposition) {struct p} : Prop :=
   match p with
   | EqTerm t1 t2 => interp_term env t1 = interp_term env t2
-  | LeqTerm t1 t2 => (interp_term env t1 <= interp_term env t2)%Z
+  | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2
   | TrueTerm => True
   | FalseTerm => False
   | Tnot p' => ~ interp_proposition envp env p'
-  | GeqTerm t1 t2 => (interp_term env t1 >= interp_term env t2)%Z
-  | GtTerm t1 t2 => (interp_term env t1 > interp_term env t2)%Z
-  | LtTerm t1 t2 => (interp_term env t1 < interp_term env t2)%Z
+  | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2
+  | GtTerm t1 t2 => interp_term env t1 > interp_term env t2
+  | LtTerm t1 t2 => interp_term env t1 < interp_term env t2
   | NeqTerm t1 t2 => Zne (interp_term env t1) (interp_term env t2)
   | Tor p1 p2 =>
       interp_proposition envp env p1 \/ interp_proposition envp env p2
@@ -531,7 +548,7 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z)
    à manipuler individuellement *)
 
 Fixpoint interp_hyps (envp : PropList) (env : list Z) 
- (l : list proposition) {struct l} : Prop :=
+ (l : hyps) {struct l} : Prop :=
   match l with
   | nil => True
   | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l'
@@ -542,26 +559,22 @@ Fixpoint interp_hyps (envp : PropList) (env : list Z)
    [Generalize] et qu'une conjonction est forcément lourde (répétition des
    types dans les conjonctions intermédiaires) *)
 
-Fixpoint interp_goal_concl (envp : PropList) (env : list Z) 
- (c : proposition) (l : list proposition) {struct l} : Prop :=
+Fixpoint interp_goal_concl (c : proposition) (envp : PropList) 
+ (env : list Z) (l : hyps) {struct l} : Prop :=
   match l with
   | nil => interp_proposition envp env c
   | p' :: l' =>
-      interp_proposition envp env p' -> interp_goal_concl envp env c l'
+      interp_proposition envp env p' -> interp_goal_concl c envp env l'
   end.
 
-Notation interp_goal :=
-  (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-   interp_goal_concl envp env FalseTerm l) (only parsing).
+Notation interp_goal := (interp_goal_concl FalseTerm).
 
 (* Les théorèmes qui suivent assurent la correspondance entre les deux
    interprétations. *)
 
 Theorem goal_to_hyps :
- forall (envp : PropList) (env : list Z) (l : list proposition),
- (interp_hyps envp env l -> False) ->
- (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-  interp_goal_concl envp env FalseTerm l) envp env l.
+ forall (envp : PropList) (env : list Z) (l : hyps),
+ (interp_hyps envp env l -> False) -> interp_goal envp env l.
 
 simple induction l;
  [ simpl in |- *; auto
@@ -569,10 +582,8 @@ simple induction l;
 Qed.
 
 Theorem hyps_to_goal :
- forall (envp : PropList) (env : list Z) (l : list proposition),
- (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-  interp_goal_concl envp env FalseTerm l) envp env l ->
- interp_hyps envp env l -> False.
+ forall (envp : PropList) (env : list Z) (l : hyps),
+ interp_goal envp env l -> interp_hyps envp env l -> False.
 
 simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
 Qed.
@@ -603,22 +614,16 @@ Definition valid2 (f : proposition -> proposition -> proposition) :=
    liste de propositions et rend une nouvelle liste de proposition. 
    On reste contravariant *)
 
-Definition valid_hyps (f : list proposition -> list proposition) :=
-  forall (ep : PropList) (e : list Z) (lp : list proposition),
+Definition valid_hyps (f : hyps -> hyps) :=
+  forall (ep : PropList) (e : list Z) (lp : hyps),
   interp_hyps ep e lp -> interp_hyps ep e (f lp).
 
 (* Enfin ce théorème élimine la contravariance et nous ramène à une 
    opération sur les buts *)
 
  Theorem valid_goal :
-  forall (ep : PropList) (env : list Z) (l : list proposition)
-    (a : list proposition -> list proposition),
-  valid_hyps a ->
-  (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-   interp_goal_concl envp env FalseTerm l) ep env (
-    a l) ->
-  (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-   interp_goal_concl envp env FalseTerm l) ep env l.
+  forall (ep : PropList) (env : list Z) (l : hyps) (a : hyps -> hyps),
+  valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l.
 
 intros; simpl in |- *; apply goal_to_hyps; intro H1;
  apply (hyps_to_goal ep env (a l) H0); apply H; assumption.
@@ -627,25 +632,22 @@ Qed.
 (* \subsubsection{Généralisation a des listes de buts (disjonctions)} *)
 
 
-Fixpoint interp_list_hyps (envp : PropList) (env : list Z)
- (l : list (list proposition)) {struct l} : Prop :=
+Fixpoint interp_list_hyps (envp : PropList) (env : list Z) 
+ (l : lhyps) {struct l} : Prop :=
   match l with
   | nil => False
   | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l'
   end.
 
-Fixpoint interp_list_goal (envp : PropList) (env : list Z)
- (l : list (list proposition)) {struct l} : Prop :=
+Fixpoint interp_list_goal (envp : PropList) (env : list Z) 
+ (l : lhyps) {struct l} : Prop :=
   match l with
   | nil => True
-  | h :: l' =>
-      (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-       interp_goal_concl envp env FalseTerm l) envp env h /\
-      interp_list_goal envp env l'
+  | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l'
   end.
 
 Theorem list_goal_to_hyps :
- forall (envp : PropList) (env : list Z) (l : list (list proposition)),
+ forall (envp : PropList) (env : list Z) (l : lhyps),
  (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l.
 
 simple induction l; simpl in |- *;
@@ -656,7 +658,7 @@ simple induction l; simpl in |- *;
 Qed.
 
 Theorem list_hyps_to_goal :
- forall (envp : PropList) (env : list Z) (l : list (list proposition)),
+ forall (envp : PropList) (env : list Z) (l : lhyps),
  interp_list_goal envp env l -> interp_list_hyps envp env l -> False.
 
 simple induction l; simpl in |- *;
@@ -665,21 +667,16 @@ simple induction l; simpl in |- *;
     [ apply hyps_to_goal with (1 := H1); assumption | auto ] ].
 Qed.
 
-Definition valid_list_hyps
-  (f : list proposition -> list (list proposition)) :=
-  forall (ep : PropList) (e : list Z) (lp : list proposition),
+Definition valid_list_hyps (f : hyps -> lhyps) :=
+  forall (ep : PropList) (e : list Z) (lp : hyps),
   interp_hyps ep e lp -> interp_list_hyps ep e (f lp).
 
-Definition valid_list_goal
-  (f : list proposition -> list (list proposition)) :=
-  forall (ep : PropList) (e : list Z) (lp : list proposition),
-  interp_list_goal ep e (f lp) ->
-  (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-   interp_goal_concl envp env FalseTerm l) ep e lp.
+Definition valid_list_goal (f : hyps -> lhyps) :=
+  forall (ep : PropList) (e : list Z) (lp : hyps),
+  interp_list_goal ep e (f lp) -> interp_goal ep e lp.
 
 Theorem goal_valid :
- forall f : list proposition -> list (list proposition),
- valid_list_hyps f -> valid_list_goal f.
+ forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f.
 
 unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps;
  intro H2; apply list_hyps_to_goal with (1 := H1); 
@@ -687,7 +684,7 @@ unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps;
 Qed.
  
 Theorem append_valid :
- forall (ep : PropList) (e : list Z) (l1 l2 : list (list proposition)),
+ forall (ep : PropList) (e : list Z) (l1 l2 : lhyps),
  interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 ->
  interp_list_hyps ep e (l1 ++ l2).
 
@@ -703,10 +700,10 @@ Qed.
 (* \subsubsection{Opérateurs valides sur les hypothèses} *)
 
 (* Extraire une hypothèse de la liste *)
-Definition nth_hyps (n : nat) (l : list proposition) := nth n l TrueTerm.
+Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm.
 
 Theorem nth_valid :
- forall (ep : PropList) (e : list Z) (i : nat) (l : list proposition),
+ forall (ep : PropList) (e : list Z) (i : nat) (l : hyps),
  interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
 
 unfold nth_hyps in |- *; simple induction i;
@@ -719,7 +716,7 @@ Qed.
 (* Appliquer une opération (valide) sur deux hypothèses extraites de 
    la liste et ajouter le résultat à la liste. *)
 Definition apply_oper_2 (i j : nat)
-  (f : proposition -> proposition -> proposition) (l : list proposition) :=
+  (f : proposition -> proposition -> proposition) (l : hyps) :=
   f (nth_hyps i l) (nth_hyps j l) :: l.
 
 Theorem apply_oper_2_valid :
@@ -732,8 +729,8 @@ Qed.
 
 (* Modifier une hypothèse par application d'une opération valide *)
 
-Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition)
- (l : list proposition) {struct i} : list proposition :=
+Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) 
+ (l : hyps) {struct i} : hyps :=
   match l with
   | nil => nil (A:=proposition)
   | p :: l' =>
@@ -767,23 +764,23 @@ Qed.
 
 Definition apply_left (f : term -> term) (t : term) :=
   match t with
-  | Tplus x y => Tplus (f x) y
-  | Tmult x y => Tmult (f x) y
-  | Topp x => Topp (f x)
+  | (x + y)%term => (f x + y)%term
+  | (x * y)%term => (f x * y)%term
+  | (- x)%term => (- f x)%term
   | x => x
   end.
 
 Definition apply_right (f : term -> term) (t : term) :=
   match t with
-  | Tplus x y => Tplus x (f y)
-  | Tmult x y => Tmult x (f y)
+  | (x + y)%term => (x + f y)%term
+  | (x * y)%term => (x * f y)%term
   | x => x
   end.
 
 Definition apply_both (f g : term -> term) (t : term) :=
   match t with
-  | Tplus x y => Tplus (f x) (g y)
-  | Tmult x y => Tmult (f x) (g y)
+  | (x + y)%term => (f x + g y)%term
+  | (x * y)%term => (f x * g y)%term
   | x => x
   end.
 
@@ -849,31 +846,25 @@ Qed.
 (* \subsubsection{La tactique pour prouver la stabilité} *)
 
 Ltac loop t :=
-  match constr:t with
-  | (?X1 = ?X2) => 
-                    (* Global *)
-                    loop X1 || loop X2
+  match t with
+  (* Global *)
+  | (?X1 = ?X2) => loop X1 || loop X2
   | (_ -> ?X1) => loop X1
-  | (interp_hyps _ _ ?X1) =>
-      
   (* Interpretations *)
-  loop X1
+  | (interp_hyps _ _ ?X1) => loop X1
   | (interp_list_hyps _ _ ?X1) => loop X1
   | (interp_proposition _ _ ?X1) => loop X1
   | (interp_term _ ?X1) => loop X1
-  | (EqTerm ?X1 ?X2) =>
-      
-       (* Propositions *)
-       loop X1 || loop X2
+  (* Propositions *)
+  | (EqTerm ?X1 ?X2) => loop X1 || loop X2
   | (LeqTerm ?X1 ?X2) => loop X1 || loop X2
-  | (Tplus ?X1 ?X2) => 
-                        (* Termes *)
-                        loop X1 || loop X2
-  | (Tminus ?X1 ?X2) => loop X1 || loop X2
-  | (Tmult ?X1 ?X2) => loop X1 || loop X2
-  | (Topp ?X1) => loop X1
-  | (Tint ?X1) =>
-      loop X1
+  (* Termes *)
+  | (?X1 + ?X2)%term => loop X1 || loop X2
+  | (?X1 - ?X2)%term => loop X1 || loop X2
+  | (?X1 * ?X2)%term => loop X1 || loop X2
+  | (- ?X1)%term => loop X1
+  | (Tint ?X1) => loop X1
+  (* Eliminations *)
   | match ?X1 with
     | EqTerm x x0 => _
     | LeqTerm x x0 => _
@@ -889,8 +880,6 @@ Ltac loop t :=
     | Timp x x0 => _
     | Tprop x => _
     end =>
-      
-       (* Eliminations *)
        case X1;
        [ intro; intro
        | intro; intro
@@ -907,19 +896,19 @@ Ltac loop t :=
        | intro ]; auto; Simplify
   | match ?X1 with
     | Tint x => _
-    | Tplus x x0 => _
-    | Tmult x x0 => _
-    | Tminus x x0 => _
-    | Topp x => _
-    | Tvar x => _
+    | (x + x0)%term => _
+    | (x * x0)%term => _
+    | (x - x0)%term => _
+    | (- x)%term => _
+    | [x]%term => _
     end =>
       case X1;
        [ intro | intro; intro | intro; intro | intro; intro | intro | intro ];
        auto; Simplify
-  | match (?X1 ?= ?X2)%Z with
-    | Datatypes.Eq => _
-    | Datatypes.Lt => _
-    | Datatypes.Gt => _
+  | match ?X1 ?= ?X2 with
+    | Eq => _
+    | Lt => _
+    | Gt => _
     end =>
       elim_Zcompare X1 X2; intro; auto; Simplify
   | match ?X1 with
@@ -955,7 +944,7 @@ Ltac prove_stable x th :=
 (* \subsubsection{Les règles elle mêmes} *)
 Definition Tplus_assoc_l (t : term) :=
   match t with
-  | Tplus n (Tplus m p) => Tplus (Tplus n m) p
+  | (n + (m + p))%term => (n + m + p)%term
   | _ => t
   end.
 
@@ -966,7 +955,7 @@ Qed.
 
 Definition Tplus_assoc_r (t : term) :=
   match t with
-  | Tplus (Tplus n m) p => Tplus n (Tplus m p)
+  | (n + m + p)%term => (n + (m + p))%term
   | _ => t
   end.
 
@@ -977,7 +966,7 @@ Qed.
 
 Definition Tmult_assoc_r (t : term) :=
   match t with
-  | Tmult (Tmult n m) p => Tmult n (Tmult m p)
+  | (n * m * p)%term => (n * (m * p))%term
   | _ => t
   end.
 
@@ -988,7 +977,7 @@ Qed.
 
 Definition Tplus_permute (t : term) :=
   match t with
-  | Tplus n (Tplus m p) => Tplus m (Tplus n p)
+  | (n + (m + p))%term => (m + (n + p))%term
   | _ => t
   end.
 
@@ -999,7 +988,7 @@ Qed.
 
 Definition Tplus_sym (t : term) :=
   match t with
-  | Tplus x y => Tplus y x
+  | (x + y)%term => (y + x)%term
   | _ => t
   end.
 
@@ -1010,7 +999,7 @@ Qed.
 
 Definition Tmult_sym (t : term) :=
   match t with
-  | Tmult x y => Tmult y x
+  | (x * y)%term => (y * x)%term
   | _ => t
   end.
 
@@ -1021,12 +1010,10 @@ Qed.
 
 Definition T_OMEGA10 (t : term) :=
   match t with
-  | Tplus (Tmult (Tplus (Tmult v (Tint c1)) l1) (Tint k1)) (Tmult (Tplus
-    (Tmult v' (Tint c2)) l2) (Tint k2)) =>
+  | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term =>
       match eq_term v v' with
       | true =>
-          Tplus (Tmult v (Tint (c1 * k1 + c2 * k2)))
-            (Tplus (Tmult l1 (Tint k1)) (Tmult l2 (Tint k2)))
+          (v * Tint (c1 * k1 + c2 * k2) + (l1 * Tint k1 + l2 * Tint k2))%term
       | false => t
       end
   | _ => t
@@ -1039,8 +1026,8 @@ Qed.
 
 Definition T_OMEGA11 (t : term) :=
   match t with
-  | Tplus (Tmult (Tplus (Tmult v1 (Tint c1)) l1) (Tint k1)) l2 =>
-      Tplus (Tmult v1 (Tint (c1 * k1))) (Tplus (Tmult l1 (Tint k1)) l2)
+  | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term =>
+      (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term
   | _ => t
   end.
 
@@ -1051,8 +1038,8 @@ Qed.
 
 Definition T_OMEGA12 (t : term) :=
   match t with
-  | Tplus l1 (Tmult (Tplus (Tmult v2 (Tint c2)) l2) (Tint k2)) =>
-      Tplus (Tmult v2 (Tint (c2 * k2))) (Tplus l1 (Tmult l2 (Tint k2)))
+  | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term =>
+      (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term
   | _ => t
   end.
 
@@ -1063,22 +1050,22 @@ Qed.
 
 Definition T_OMEGA13 (t : term) :=
   match t with
-  | Tplus (Tplus (Tmult v (Tint (Zpos x))) l1) (Tplus (Tmult v' (Tint (Zneg
-    x'))) l2) =>
+  | (v * Tint (Zpos x) + l1 + (v' * Tint (Zneg x') + l2))%term =>
       match eq_term v v' with
-      | true => match eq_pos x x' with
-                | true => Tplus l1 l2
-                | false => t
-                end
+      | true =>
+          match eq_pos x x' with
+          | true => (l1 + l2)%term
+          | false => t
+          end
       | false => t
       end
-  | Tplus (Tplus (Tmult v (Tint (Zneg x))) l1) (Tplus (Tmult v' (Tint (Zpos
-    x'))) l2) =>
+  | (v * Tint (Zneg x) + l1 + (v' * Tint (Zpos x') + l2))%term =>
       match eq_term v v' with
-      | true => match eq_pos x x' with
-                | true => Tplus l1 l2
-                | false => t
-                end
+      | true =>
+          match eq_pos x x' with
+          | true => (l1 + l2)%term
+          | false => t
+          end
       | false => t
       end
   | _ => t
@@ -1092,12 +1079,9 @@ Qed.
 
 Definition T_OMEGA15 (t : term) :=
   match t with
-  | Tplus (Tplus (Tmult v (Tint c1)) l1) (Tmult (Tplus (Tmult v' (Tint c2))
-    l2) (Tint k2)) =>
+  | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term =>
       match eq_term v v' with
-      | true =>
-          Tplus (Tmult v (Tint (c1 + c2 * k2)))
-            (Tplus l1 (Tmult l2 (Tint k2)))
+      | true => (v * Tint (c1 + c2 * k2) + (l1 + l2 * Tint k2))%term
       | false => t
       end
   | _ => t
@@ -1110,8 +1094,7 @@ Qed.
 
 Definition T_OMEGA16 (t : term) :=
   match t with
-  | Tmult (Tplus (Tmult v (Tint c)) l) (Tint k) =>
-      Tplus (Tmult v (Tint (c * k))) (Tmult l (Tint k))
+  | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term
   | _ => t
   end.
 
@@ -1123,7 +1106,7 @@ Qed.
 
 Definition Tred_factor5 (t : term) :=
   match t with
-  | Tplus (Tmult x (Tint Z0)) y => y
+  | (x * Tint Z0 + y)%term => y
   | _ => t
   end.
 
@@ -1135,7 +1118,7 @@ Qed.
 
 Definition Topp_plus (t : term) :=
   match t with
-  | Topp (Tplus x y) => Tplus (Topp x) (Topp y)
+  | (- (x + y))%term => (- x + - y)%term
   | _ => t
   end.
 
@@ -1147,7 +1130,7 @@ Qed.
 
 Definition Topp_opp (t : term) :=
   match t with
-  | Topp (Topp x) => x
+  | (- - x)%term => x
   | _ => t
   end.
 
@@ -1158,7 +1141,7 @@ Qed.
 
 Definition Topp_mult_r (t : term) :=
   match t with
-  | Topp (Tmult x (Tint k)) => Tmult x (Tint (- k))
+  | (- (x * Tint k))%term => (x * Tint (- k))%term
   | _ => t
   end.
 
@@ -1169,7 +1152,7 @@ Qed.
 
 Definition Topp_one (t : term) :=
   match t with
-  | Topp x => Tmult x (Tint (-1))
+  | (- x)%term => (x * Tint (-1))%term
   | _ => t
   end.
 
@@ -1180,7 +1163,7 @@ Qed.
 
 Definition Tmult_plus_distr (t : term) :=
   match t with
-  | Tmult (Tplus n m) p => Tplus (Tmult n p) (Tmult m p)
+  | ((n + m) * p)%term => (n * p + m * p)%term
   | _ => t
   end.
 
@@ -1191,7 +1174,7 @@ Qed.
 
 Definition Tmult_opp_left (t : term) :=
   match t with
-  | Tmult (Topp x) (Tint y) => Tmult x (Tint (- y))
+  | (- x * Tint y)%term => (x * Tint (- y))%term
   | _ => t
   end.
 
@@ -1202,7 +1185,7 @@ Qed.
 
 Definition Tmult_assoc_reduced (t : term) :=
   match t with
-  | Tmult (Tmult n (Tint m)) (Tint p) => Tmult n (Tint (m * p))
+  | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term
   | _ => t
   end.
 
@@ -1211,7 +1194,7 @@ Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced.
 prove_stable Tmult_assoc_reduced Zmult_assoc_reverse.
 Qed.
 
-Definition Tred_factor0 (t : term) := Tmult t (Tint 1).
+Definition Tred_factor0 (t : term) := (t * Tint 1)%term.
 
 Theorem Tred_factor0_stable : term_stable Tred_factor0.
 
@@ -1220,9 +1203,9 @@ Qed.
 
 Definition Tred_factor1 (t : term) :=
   match t with
-  | Tplus x y =>
+  | (x + y)%term =>
       match eq_term x y with
-      | true => Tmult x (Tint 2)
+      | true => (x * Tint 2)%term
       | false => t
       end
   | _ => t
@@ -1235,9 +1218,9 @@ Qed.
 
 Definition Tred_factor2 (t : term) :=
   match t with
-  | Tplus x (Tmult y (Tint k)) =>
+  | (x + y * Tint k)%term =>
       match eq_term x y with
-      | true => Tmult x (Tint (1 + k))
+      | true => (x * Tint (1 + k))%term
       | false => t
       end
   | _ => t
@@ -1254,9 +1237,9 @@ Qed.
 
 Definition Tred_factor3 (t : term) :=
   match t with
-  | Tplus (Tmult x (Tint k)) y =>
+  | (x * Tint k + y)%term =>
       match eq_term x y with
-      | true => Tmult x (Tint (1 + k))
+      | true => (x * Tint (1 + k))%term
       | false => t
       end
   | _ => t
@@ -1270,9 +1253,9 @@ Qed.
 
 Definition Tred_factor4 (t : term) :=
   match t with
-  | Tplus (Tmult x (Tint k1)) (Tmult y (Tint k2)) =>
+  | (x * Tint k1 + y * Tint k2)%term =>
       match eq_term x y with
-      | true => Tmult x (Tint (k1 + k2))
+      | true => (x * Tint (k1 + k2))%term
       | false => t
       end
   | _ => t
@@ -1283,7 +1266,7 @@ Theorem Tred_factor4_stable : term_stable Tred_factor4.
 prove_stable Tred_factor4 Zred_factor4.
 Qed.
 
-Definition Tred_factor6 (t : term) := Tplus t (Tint 0).
+Definition Tred_factor6 (t : term) := (t + Tint 0)%term.
 
 Theorem Tred_factor6_stable : term_stable Tred_factor6.
 
@@ -1294,7 +1277,7 @@ Transparent Zplus.
 
 Definition Tminus_def (t : term) :=
   match t with
-  | Tminus x y => Tplus x (Topp y)
+  | (x - y)%term => (x + - y)%term
   | _ => t
   end.
 
@@ -1313,37 +1296,37 @@ Qed.
 
 Fixpoint reduce (t : term) : term :=
   match t with
-  | Tplus x y =>
+  | (x + y)%term =>
       match reduce x with
       | Tint x' =>
           match reduce y with
           | Tint y' => Tint (x' + y')
-          | y' => Tplus (Tint x') y'
+          | y' => (Tint x' + y')%term
           end
-      | x' => Tplus x' (reduce y)
+      | x' => (x' + reduce y)%term
       end
-  | Tmult x y =>
+  | (x * y)%term =>
       match reduce x with
       | Tint x' =>
           match reduce y with
           | Tint y' => Tint (x' * y')
-          | y' => Tmult (Tint x') y'
+          | y' => (Tint x' * y')%term
           end
-      | x' => Tmult x' (reduce y)
+      | x' => (x' * reduce y)%term
       end
-  | Tminus x y =>
+  | (x - y)%term =>
       match reduce x with
       | Tint x' =>
           match reduce y with
           | Tint y' => Tint (x' - y')
-          | y' => Tminus (Tint x') y'
+          | y' => (Tint x' - y')%term
           end
-      | x' => Tminus x' (reduce y)
+      | x' => (x' - reduce y)%term
       end
-  | Topp x =>
+  | (- x)%term =>
       match reduce x with
       | Tint x' => Tint (- x')
-      | x' => Topp x'
+      | x' => (- x')%term
       end
   | _ => t
   end.
@@ -1412,7 +1395,7 @@ Definition fusion_right (trace : list t_fusion) (t : term) : term :=
       end
   end.
 
-(* \paragraph{Fusion avec anihilation} *)
+(* \paragraph{Fusion avec annihilation} *)
 (* Normalement le résultat est une constante *)
 
 Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term :=
@@ -1428,7 +1411,7 @@ unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace;
  | intros n H t; elim H; exact (T_OMEGA13_stable e t) ].
 Qed. 
 
-(* \subsubsection{Opérations afines sur une équation} *)
+(* \subsubsection{Opérations affines sur une équation} *)
 (* \paragraph{Multiplication scalaire et somme d'une constante} *)
 
 Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term :=
@@ -1497,7 +1480,7 @@ Fixpoint rewrite (s : step) : term -> term :=
   | C_PLUS_ASSOC_R => Tplus_assoc_r
   | C_PLUS_ASSOC_L => Tplus_assoc_l
   | C_PLUS_PERMUTE => Tplus_permute
-  | C_PLUS_SYM => Tplus_sym
+  | C_PLUS_COMM => Tplus_sym
   | C_RED0 => Tred_factor0
   | C_RED1 => Tred_factor1
   | C_RED2 => Tred_factor2
@@ -1507,7 +1490,7 @@ Fixpoint rewrite (s : step) : term -> term :=
   | C_RED6 => Tred_factor6
   | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced
   | C_MINUS => Tminus_def
-  | C_MULT_SYM => Tmult_sym
+  | C_MULT_COMM => Tmult_sym
   end.
 
 Theorem rewrite_stable : forall s : step, term_stable (rewrite s).
@@ -1547,7 +1530,7 @@ Qed.
 \subsubsection{Tactiques générant une contradiction}
 \paragraph{[O_CONSTANT_NOT_NUL]} *)
 
-Definition constant_not_nul (i : nat) (h : list proposition) :=
+Definition constant_not_nul (i : nat) (h : hyps) :=
   match nth_hyps i h with
   | EqTerm (Tint Z0) (Tint n) =>
       match eq_Z n 0 with
@@ -1562,13 +1545,13 @@ Theorem constant_not_nul_valid :
 
 unfold valid_hyps, constant_not_nul in |- *; intros;
  generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- elim_eq_Z ipattern:z0 0%Z; auto; simpl in |- *; intros H1 H2; 
+ elim_eq_Z ipattern:z0 0; auto; simpl in |- *; intros H1 H2; 
  elim H1; symmetry  in |- *; auto.
 Qed.   
 
 (* \paragraph{[O_CONSTANT_NEG]} *)
 
-Definition constant_neg (i : nat) (h : list proposition) :=
+Definition constant_neg (i : nat) (h : hyps) :=
   match nth_hyps i h with
   | LeqTerm (Tint Z0) (Tint (Zneg n)) => absurd
   | _ => h
@@ -1584,18 +1567,17 @@ Qed.
 
 (* \paragraph{[NOT_EXACT_DIVIDE]} *)
 Definition not_exact_divide (k1 k2 : Z) (body : term) 
-  (t i : nat) (l : list proposition) :=
+  (t i : nat) (l : hyps) :=
   match nth_hyps i l with
   | EqTerm (Tint Z0) b =>
       match
-        eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2)))
-          b
+        eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b
       with
       | true =>
-          match (k2 ?= 0)%Z with
-          | Datatypes.Gt =>
-              match (k1 ?= k2)%Z with
-              | Datatypes.Gt => absurd
+          match k2 ?= 0 with
+          | Gt =>
+              match k1 ?= k2 with
+              | Gt => absurd
               | _ => l
               end
           | _ => l
@@ -1611,27 +1593,26 @@ Theorem not_exact_divide_valid :
 
 unfold valid_hyps, not_exact_divide in |- *; intros;
  generalize (nth_valid ep e i lp); Simplify;
- elim_eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) t1;
+ elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1; 
  auto; Simplify; intro H2; elim H2; simpl in |- *;
  elim (scalar_norm_add_stable t e); simpl in |- *; 
- intro H4; absurd ((interp_term e body * k1 + k2)%Z = 0%Z);
+ intro H4; absurd (interp_term e body * k1 + k2 = 0);
  [ apply OMEGA4; assumption | symmetry  in |- *; auto ].
 
 Qed.
 
 (* \paragraph{[O_CONTRADICTION]} *)
 
-Definition contradiction (t i j : nat) (l : list proposition) :=
+Definition contradiction (t i j : nat) (l : hyps) :=
   match nth_hyps i l with
   | LeqTerm (Tint Z0) b1 =>
       match nth_hyps j l with
       | LeqTerm (Tint Z0) b2 =>
-          match fusion_cancel t (Tplus b1 b2) with
-          | Tint k =>
-              match (0 ?= k)%Z with
-              | Datatypes.Gt => absurd
-              | _ => l
-              end
+          match fusion_cancel t (b1 + b2)%term with
+          | Tint k => match 0 ?= k with
+                      | Gt => absurd
+                      | _ => l
+                      end
           | _ => l
           end
       | _ => l
@@ -1648,9 +1629,9 @@ unfold valid_hyps, contradiction in |- *; intros t i j ep e l H;
  auto; intros z; case z; auto; case (nth_hyps j l); 
  auto; intros t3 t4; case t3; auto; intros z'; case z'; 
  auto; simpl in |- *; intros H1 H2;
- generalize (refl_equal (interp_term e (fusion_cancel t (Tplus t2 t4))));
- pattern (fusion_cancel t (Tplus t2 t4)) at 2 3 in |- *;
- case (fusion_cancel t (Tplus t2 t4)); simpl in |- *; 
+ generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term)));
+ pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *;
+ case (fusion_cancel t (t2 + t4)%term); simpl in |- *; 
  auto; intro k; elim (fusion_cancel_stable t); simpl in |- *; 
  intro E; generalize (OMEGA2 _ _ H2 H1); rewrite E; 
  case k; auto; unfold Zle in |- *; simpl in |- *; intros p H3; 
@@ -1660,7 +1641,7 @@ Qed.
 
 (* \paragraph{[O_NEGATE_CONTRADICT]} *)
 
-Definition negate_contradict (i1 i2 : nat) (h : list proposition) :=
+Definition negate_contradict (i1 i2 : nat) (h : hyps) :=
   match nth_hyps i1 h with
   | EqTerm (Tint Z0) b1 =>
       match nth_hyps i2 h with
@@ -1683,12 +1664,12 @@ Definition negate_contradict (i1 i2 : nat) (h : list proposition) :=
   | _ => h
   end.
 
-Definition negate_contradict_inv (t i1 i2 : nat) (h : list proposition) :=
+Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
   match nth_hyps i1 h with
   | EqTerm (Tint Z0) b1 =>
       match nth_hyps i2 h with
       | NeqTerm (Tint Z0) b2 =>
-          match eq_term b1 (scalar_norm t (Tmult b2 (Tint (-1)))) with
+          match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
           | true => absurd
           | false => h
           end
@@ -1697,7 +1678,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : list proposition) :=
   | NeqTerm (Tint Z0) b1 =>
       match nth_hyps i2 h with
       | EqTerm (Tint Z0) b2 =>
-          match eq_term b1 (scalar_norm t (Tmult b2 (Tint (-1)))) with
+          match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
           | true => absurd
           | false => h
           end
@@ -1732,11 +1713,11 @@ unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H;
  auto; intros z; case z; auto; case (nth_hyps j l); 
  auto; intros t3 t4; case t3; auto; intros z'; case z'; 
  auto; simpl in |- *; intros H1 H2;
- (pattern (eq_term t2 (scalar_norm t (Tmult t4 (Tint (-1))))) in |- *;
+ (pattern (eq_term t2 (scalar_norm t (t4 * Tint (-1))%term)) in |- *;
    apply bool_ind2; intro Aux;
-   [ generalize (eq_term_true t2 (scalar_norm t (Tmult t4 (Tint (-1)))) Aux);
+   [ generalize (eq_term_true t2 (scalar_norm t (t4 * Tint (-1))%term) Aux);
       clear Aux
-   | generalize (eq_term_false t2 (scalar_norm t (Tmult t4 (Tint (-1)))) Aux);
+   | generalize (eq_term_false t2 (scalar_norm t (t4 * Tint (-1))%term) Aux);
       clear Aux ]);
  [ intro H3; elim H1; generalize H2; rewrite H3;
     rewrite <- (scalar_norm_stable t e); simpl in |- *;
@@ -1762,32 +1743,28 @@ Definition sum (k1 k2 : Z) (trace : list t_fusion)
   | EqTerm (Tint Z0) b1 =>
       match prop2 with
       | EqTerm (Tint Z0) b2 =>
-          EqTerm (Tint 0)
-            (fusion trace (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+          EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
       | LeqTerm (Tint Z0) b2 =>
-          match (k2 ?= 0)%Z with
-          | Datatypes.Gt =>
+          match k2 ?= 0 with
+          | Gt =>
               LeqTerm (Tint 0)
-                (fusion trace
-                   (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+                (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
           | _ => TrueTerm
           end
       | _ => TrueTerm
       end
   | LeqTerm (Tint Z0) b1 =>
-      match (k1 ?= 0)%Z with
-      | Datatypes.Gt =>
+      match k1 ?= 0 with
+      | Gt =>
           match prop2 with
           | EqTerm (Tint Z0) b2 =>
               LeqTerm (Tint 0)
-                (fusion trace
-                   (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+                (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
           | LeqTerm (Tint Z0) b2 =>
-              match (k2 ?= 0)%Z with
-              | Datatypes.Gt =>
+              match k2 ?= 0 with
+              | Gt =>
                   LeqTerm (Tint 0)
-                    (fusion trace
-                       (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+                    (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
               | _ => TrueTerm
               end
           | _ => TrueTerm
@@ -1801,23 +1778,20 @@ Definition sum (k1 k2 : Z) (trace : list t_fusion)
           | true => TrueTerm
           | false =>
               NeqTerm (Tint 0)
-                (fusion trace
-                   (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+                (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
           end
       | _ => TrueTerm
       end
   | _ => TrueTerm
   end.
 
-Theorem sum1 :
- forall a b c d : Z, 0%Z = a -> 0%Z = b -> 0%Z = (a * c + b * d)%Z.
+Theorem sum1 : forall a b c d : Z, 0 = a -> 0 = b -> 0 = a * c + b * d.
 
 intros; elim H; elim H0; simpl in |- *; auto.
 Qed.
   
 Theorem sum2 :
- forall a b c d : Z,
- (0 <= d)%Z -> 0%Z = a -> (0 <= b)%Z -> (0 <= a * c + b * d)%Z.
+ forall a b c d : Z, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d.
 
 intros; elim H0; simpl in |- *; generalize H H1; case b; case d;
  unfold Zle in |- *; simpl in |- *; auto.  
@@ -1825,21 +1799,19 @@ Qed.
 
 Theorem sum3 :
  forall a b c d : Z,
- (0 <= c)%Z ->
- (0 <= d)%Z -> (0 <= a)%Z -> (0 <= b)%Z -> (0 <= a * c + b * d)%Z.
+ 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d.
 
 intros a b c d; case a; case b; case c; case d; unfold Zle in |- *;
  simpl in |- *; auto. 
 Qed.
 
-Theorem sum4 : forall k : Z, (k ?= 0)%Z = Datatypes.Gt -> (0 <= k)%Z.
+Theorem sum4 : forall k : Z, (k ?= 0) = Gt -> 0 <= k.
 
 intro; case k; unfold Zle in |- *; simpl in |- *; auto; intros; discriminate.  
 Qed.
 
 Theorem sum5 :
- forall a b c d : Z,
- c <> 0%Z -> 0%Z <> a -> 0%Z = b -> 0%Z <> (a * c + b * d)%Z.
+ forall a b c d : Z, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d.
 
 intros a b c d H1 H2 H3; elim H3; simpl in |- *; rewrite Zplus_comm;
  simpl in |- *; generalize H1 H2; case a; case c; simpl in |- *; 
@@ -1857,9 +1829,8 @@ unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *;
  | apply sum2; try assumption; apply sum4; assumption
  | rewrite Zplus_comm; apply sum2; try assumption; apply sum4; assumption
  | apply sum3; try assumption; apply sum4; assumption
- | elim_eq_Z k1 0%Z; simpl in |- *; auto; elim (fusion_stable t);
-    simpl in |- *; intros; unfold Zne in |- *; apply sum5; 
-    assumption ].
+ | elim_eq_Z k1 0; simpl in |- *; auto; elim (fusion_stable t); simpl in |- *;
+    intros; unfold Zne in |- *; apply sum5; assumption ].
 Qed.
 
 (* \paragraph{[O_EXACT_DIVIDE]}
@@ -1869,7 +1840,7 @@ Definition exact_divide (k : Z) (body : term) (t : nat)
   (prop : proposition) :=
   match prop with
   | EqTerm (Tint Z0) b =>
-      match eq_term (scalar_norm t (Tmult body (Tint k))) b with
+      match eq_term (scalar_norm t (body * Tint k)%term) b with
       | true =>
           match eq_Z k 0 with
           | true => TrueTerm
@@ -1885,13 +1856,13 @@ Theorem exact_divide_valid :
 
 
 unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; Simplify;
- simpl in |- *; auto; elim_eq_term (scalar_norm t (Tmult k2 (Tint k1))) t1;
- simpl in |- *; auto; elim_eq_Z k1 0%Z; simpl in |- *; 
+ simpl in |- *; auto; elim_eq_term (scalar_norm t (k2 * Tint k1)%term) t1;
+ simpl in |- *; auto; elim_eq_Z k1 0; simpl in |- *; 
  auto; intros H1 H2; elim H2; elim scalar_norm_stable; 
  simpl in |- *; generalize H1; case (interp_term e k2); 
  try trivial;
  (case k1; simpl in |- *;
-   [ intros; absurd (0%Z = 0%Z); assumption
+   [ intros; absurd (0 = 0); assumption
    | intros p2 p3 H3 H4; discriminate H4
    | intros p2 p3 H3 H4; discriminate H4 ]).
 
@@ -1908,14 +1879,13 @@ Definition divide_and_approx (k1 k2 : Z) (body : term)
   match prop with
   | LeqTerm (Tint Z0) b =>
       match
-        eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2)))
-          b
+        eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b
       with
       | true =>
-          match (k1 ?= 0)%Z with
-          | Datatypes.Gt =>
-              match (k1 ?= k2)%Z with
-              | Datatypes.Gt => LeqTerm (Tint 0) body
+          match k1 ?= 0 with
+          | Gt =>
+              match k1 ?= k2 with
+              | Gt => LeqTerm (Tint 0) body
               | _ => prop
               end
           | _ => prop
@@ -1931,7 +1901,7 @@ Theorem divide_and_approx_valid :
 
 unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1;
  Simplify;
- elim_eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) t1;
+ elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1;
  Simplify; auto; intro E; elim E; simpl in |- *;
  elim (scalar_norm_add_stable t e); simpl in |- *; 
  intro H1; apply Zmult_le_approx with (3 := H1); assumption.
@@ -1944,7 +1914,7 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) :=
   | LeqTerm (Tint Z0) b1 =>
       match prop2 with
       | LeqTerm (Tint Z0) b2 =>
-          match eq_term b1 (scalar_norm t (Tmult b2 (Tint (-1)))) with
+          match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
           | true => EqTerm (Tint 0) b1
           | false => TrueTerm
           end
@@ -1965,7 +1935,7 @@ Qed.
 
 (* \paragraph{[O_CONSTANT_NUL]} *)
 
-Definition constant_nul (i : nat) (h : list proposition) :=
+Definition constant_nul (i : nat) (h : hyps) :=
   match nth_hyps i h with
   | NeqTerm (Tint Z0) (Tint Z0) => absurd
   | _ => h
@@ -1975,8 +1945,7 @@ Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i).
 
 unfold valid_hyps, constant_nul in |- *; intros;
  generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- unfold Zne in |- *; intro H1; absurd (0%Z = 0%Z); 
- auto.
+ unfold Zne in |- *; intro H1; absurd (0 = 0); auto.
 Qed.
 
 (* \paragraph{[O_STATE]} *)
@@ -1985,9 +1954,8 @@ Definition state (m : Z) (s : step) (prop1 prop2 : proposition) :=
   match prop1 with
   | EqTerm (Tint Z0) b1 =>
       match prop2 with
-      | EqTerm (Tint Z0) (Tplus b2 (Topp b3)) =>
-          EqTerm (Tint 0)
-            (rewrite s (Tplus b1 (Tmult (Tplus (Topp b3) b2) (Tint m))))
+      | EqTerm (Tint Z0) (b2 + - b3)%term =>
+          EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term)
       | _ => TrueTerm
       end
   | _ => TrueTerm
@@ -2007,21 +1975,19 @@ Qed.
    \paragraph{[O_SPLIT_INEQ]} 
    La seule pour le moment (tant que la normalisation n'est pas réfléchie). *)
 
-Definition split_ineq (i t : nat)
-  (f1 f2 : list proposition -> list (list proposition))
-  (l : list proposition) :=
+Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) 
+  (l : hyps) :=
   match nth_hyps i l with
   | NeqTerm (Tint Z0) b1 =>
-      f1 (LeqTerm (Tint 0) (add_norm t (Tplus b1 (Tint (-1)))) :: l) ++
+      f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-1))%term) :: l) ++
       f2
         (LeqTerm (Tint 0)
-           (scalar_norm_add t (Tplus (Tmult b1 (Tint (-1))) (Tint (-1))))
-         :: l)
+           (scalar_norm_add t (b1 * Tint (-1) + Tint (-1))%term) :: l)
   | _ => l :: nil
   end.
 
 Theorem split_ineq_valid :
- forall (i t : nat) (f1 f2 : list proposition -> list (list proposition)),
+ forall (i t : nat) (f1 f2 : hyps -> lhyps),
  valid_list_hyps f1 ->
  valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2).
 
@@ -2041,34 +2007,27 @@ Qed.
 
 (* \subsection{La fonction de rejeu de la trace} *)
 
-Fixpoint execute_omega (t : t_omega) (l : list proposition) {struct t} :
- list (list proposition) :=
+Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps :=
   match t with
-  | O_CONSTANT_NOT_NUL n =>
-      (fun a : list proposition => a :: nil) (constant_not_nul n l)
-  | O_CONSTANT_NEG n =>
-      (fun a : list proposition => a :: nil) (constant_neg n l)
+  | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l)
+  | O_CONSTANT_NEG n => singleton (constant_neg n l)
   | O_DIV_APPROX k1 k2 body t cont n =>
       execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l)
   | O_NOT_EXACT_DIVIDE k1 k2 body t i =>
-      (fun a : list proposition => a :: nil)
-        (not_exact_divide k1 k2 body t i l)
+      singleton (not_exact_divide k1 k2 body t i l)
   | O_EXACT_DIVIDE k body t cont n =>
       execute_omega cont (apply_oper_1 n (exact_divide k body t) l)
   | O_SUM k1 i1 k2 i2 t cont =>
       execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l)
-  | O_CONTRADICTION t i j =>
-      (fun a : list proposition => a :: nil) (contradiction t i j l)
+  | O_CONTRADICTION t i j => singleton (contradiction t i j l)
   | O_MERGE_EQ t i1 i2 cont =>
       execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l)
   | O_SPLIT_INEQ t i cont1 cont2 =>
       split_ineq i t (execute_omega cont1) (execute_omega cont2) l
-  | O_CONSTANT_NUL i =>
-      (fun a : list proposition => a :: nil) (constant_nul i l)
-  | O_NEGATE_CONTRADICT i j =>
-      (fun a : list proposition => a :: nil) (negate_contradict i j l)
+  | O_CONSTANT_NUL i => singleton (constant_nul i l)
+  | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l)
   | O_NEGATE_CONTRADICT_INV t i j =>
-      (fun a : list proposition => a :: nil) (negate_contradict_inv t i j l)
+      singleton (negate_contradict_inv t i j l)
   | O_STATE m s i1 i2 cont =>
       execute_omega cont (apply_oper_2 i1 i2 (state m s) l)
   end.
@@ -2126,14 +2085,12 @@ Qed.
 
 Definition move_right (s : step) (p : proposition) :=
   match p with
-  | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (Tplus t1 (Topp t2)))
-  | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (Tplus t2 (Topp t1)))
-  | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (Tplus t1 (Topp t2)))
-  | LtTerm t1 t2 =>
-      LeqTerm (Tint 0) (rewrite s (Tplus (Tplus t2 (Tint (-1))) (Topp t1)))
-  | GtTerm t1 t2 =>
-      LeqTerm (Tint 0) (rewrite s (Tplus (Tplus t1 (Tint (-1))) (Topp t2)))
-  | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (Tplus t1 (Topp t2)))
+  | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
+  | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + - t1)%term)
+  | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
+  | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-1) + - t1)%term)
+  | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-1) + - t2)%term)
+  | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (t1 + - t2)%term)
   | p => p
   end.
 
@@ -2165,7 +2122,7 @@ intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
 Qed.
 
 Fixpoint do_normalize_list (l : list step) (i : nat) 
- (h : list proposition) {struct l} : list proposition :=
+ (h : hyps) {struct l} : hyps :=
   match l with
   | s :: l' => do_normalize_list l' (S i) (do_normalize i s h)
   | nil => h
@@ -2181,11 +2138,8 @@ simple induction l; simpl in |- *; unfold valid_hyps in |- *;
 Qed.
 
 Theorem normalize_goal :
- forall (s : list step) (ep : PropList) (env : list Z) (l : list proposition),
- (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-  interp_goal_concl envp env FalseTerm l) ep env (do_normalize_list s 0 l) ->
- (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-  interp_goal_concl envp env FalseTerm l) ep env l.
+ forall (s : list step) (ep : PropList) (env : list Z) (l : hyps),
+ interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l.
 
 intros; apply valid_goal with (2 := H); apply do_normalize_list_valid.
 Qed.
@@ -2193,17 +2147,15 @@ Qed.
 (* \subsubsection{Exécution de la trace} *)
 
 Theorem execute_goal :
- forall (t : t_omega) (ep : PropList) (env : list Z) (l : list proposition),
- interp_list_goal ep env (execute_omega t l) ->
- (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-  interp_goal_concl envp env FalseTerm l) ep env l.
+ forall (t : t_omega) (ep : PropList) (env : list Z) (l : hyps),
+ interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l.
 
 intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
 Qed.
 
 
 Theorem append_goal :
- forall (ep : PropList) (e : list Z) (l1 l2 : list (list proposition)),
+ forall (ep : PropList) (e : list Z) (l1 l2 : lhyps),
  interp_list_goal ep e l1 /\ interp_list_goal ep e l2 ->
  interp_list_goal ep e (l1 ++ l2).
 
@@ -2262,15 +2214,15 @@ Qed.
    conclusion. We use an intermediate fixpoint. *)
 
 Fixpoint interp_full_goal (envp : PropList) (env : list Z) 
- (c : proposition) (l : list proposition) {struct l} : Prop :=
+ (c : proposition) (l : hyps) {struct l} : Prop :=
   match l with
   | nil => interp_proposition envp env c
   | p' :: l' =>
       interp_proposition envp env p' -> interp_full_goal envp env c l'
   end.
 
-Definition interp_full (ep : PropList) (e : list Z)
-  (lc : list proposition * proposition) : Prop :=
+Definition interp_full (ep : PropList) (e : list Z) 
+  (lc : hyps * proposition) : Prop :=
   match lc with
   | (l, c) => interp_full_goal ep e c l
   end.
@@ -2279,7 +2231,7 @@ Definition interp_full (ep : PropList) (e : list Z)
    of its hypothesis and conclusion *)
 
 Theorem interp_full_false :
- forall (ep : PropList) (e : list Z) (l : list proposition) (c : proposition),
+ forall (ep : PropList) (e : list Z) (l : hyps) (c : proposition),
  (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c).
 
 simple induction l; unfold interp_full in |- *; simpl in |- *;
@@ -2291,7 +2243,7 @@ Qed.
    If the decidability cannot be "proven", then just forget about the 
    conclusion (equivalent of replacing it with false) *)
 
-Definition to_contradict (lc : list proposition * proposition) :=
+Definition to_contradict (lc : hyps * proposition) :=
   match lc with
   | (l, c) => if decidability c then Tnot c :: l else l
   end.
@@ -2300,10 +2252,8 @@ Definition to_contradict (lc : list proposition * proposition) :=
    hypothesis implies the original goal *)
 
 Theorem to_contradict_valid :
- forall (ep : PropList) (e : list Z) (lc : list proposition * proposition),
- (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-  interp_goal_concl envp env FalseTerm l) ep e (to_contradict lc) ->
- interp_full ep e lc.
+ forall (ep : PropList) (e : list Z) (lc : hyps * proposition),
+ interp_goal ep e (to_contradict lc) -> interp_full ep e lc.
 
 intros ep e lc; case lc; intros l c; simpl in |- *;
  pattern (decidability c) in |- *; apply bool_ind2;
@@ -2336,8 +2286,7 @@ Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} :
           hypothesis will get desynchronised and this will be a mess.
  *)
  
-Fixpoint destructure_hyps (nn : nat) (ll : list proposition) {struct nn} :
- list (list proposition) :=
+Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps :=
   match nn with
   | O => ll :: nil
   | S n =>
@@ -2371,8 +2320,7 @@ Fixpoint destructure_hyps (nn : nat) (ll : list proposition) {struct nn} :
   end.
 
 Theorem map_cons_val :
- forall (ep : PropList) (e : list Z) (p : proposition)
-   (l : list (list proposition)),
+ forall (ep : PropList) (e : list Z) (p : proposition) (l : lhyps),
  interp_proposition ep e p ->
  interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l).
 
@@ -2514,7 +2462,7 @@ unfold prop_stable in |- *; intros f H ep e p; split;
       unfold decidable, Zne in |- *; tauto ]).
 Qed.
 
-Theorem Zlt_left_inv : forall x y : Z, (0 <= y + -1 + - x)%Z -> (x < y)%Z.
+Theorem Zlt_left_inv : forall x y : Z, 0 <= y + -1 + - x -> x < y.
 
 intros; apply Zsucc_lt_reg; apply Zle_lt_succ;
  apply (fun a b : Z => Zplus_le_reg_r a b (-1 + - x)); 
@@ -2570,8 +2518,7 @@ simple induction s; simpl in |- *;
  | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ].
 Qed.
 
-Fixpoint normalize_hyps (l : list h_step) (lh : list proposition) {struct l}
- : list proposition :=
+Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps :=
   match l with
   | nil => lh
   | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh)
@@ -2590,12 +2537,8 @@ simple induction l; unfold valid_hyps in |- *; simpl in |- *;
 Qed.
 
 Theorem normalize_hyps_goal :
- forall (s : list h_step) (ep : PropList) (env : list Z)
-   (l : list proposition),
- (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-  interp_goal_concl envp env FalseTerm l) ep env (normalize_hyps s l) ->
- (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-  interp_goal_concl envp env FalseTerm l) ep env l.
+ forall (s : list h_step) (ep : PropList) (env : list Z) (l : hyps),
+ interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l.
 
 intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
 Qed.
@@ -2675,8 +2618,7 @@ unfold valid1, co_valid1 in |- *; simple induction s;
 
 Qed.
 
-Fixpoint decompose_solve (s : e_step) (h : list proposition) {struct s} :
- list (list proposition) :=
+Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps :=
   match s with
   | E_SPLIT i dl s1 s2 =>
       match extract_hyp_pos dl (nth_hyps i h) with
@@ -2687,6 +2629,10 @@ Fixpoint decompose_solve (s : e_step) (h : list proposition) {struct s} :
            decompose_solve s1 (Tnot x :: h) ++
            decompose_solve s2 (Tnot y :: h)
           else h :: nil
+      | Timp x y => 
+          if decidability x then 
+            decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h)
+          else h::nil
       | _ => h :: nil
       end
   | E_EXTRACT i dl s1 =>
@@ -2710,28 +2656,32 @@ intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s;
           | simpl in |- *; auto ]
        | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2;
           [ intros H3; left; apply H; simpl in |- *; auto
-          | intros H3; right; apply H0; simpl in |- *; auto ] ]
+          | intros H3; right; apply H0; simpl in |- *; auto ] 
+       | intros p1 p2 H2;
+         pattern (decidability p1) in |- *; apply bool_ind2;
+          [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4;
+             apply append_valid; elim H4; intro H5; 
+             [ right; apply H0; simpl in |- *; tauto
+             | left; apply H; simpl in |- *; tauto ]
+          | simpl in |- *; auto ] ]
     | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ]
  | intros; apply H; simpl in |- *; split;
     [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto
     | auto ]
  | apply omega_valid with (1 := H) ].
-
 Qed.
 
 (* \subsection{La dernière étape qui élimine tous les séquents inutiles} *)
 
-Definition valid_lhyps
-  (f : list (list proposition) -> list (list proposition)) :=
-  forall (ep : PropList) (e : list Z) (lp : list (list proposition)),
+Definition valid_lhyps (f : lhyps -> lhyps) :=
+  forall (ep : PropList) (e : list Z) (lp : lhyps),
   interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp).
 
-Fixpoint reduce_lhyps (lp : list (list proposition)) :
- list (list proposition) :=
+Fixpoint reduce_lhyps (lp : lhyps) : lhyps :=
   match lp with
   | (FalseTerm :: nil) :: lp' => reduce_lhyps lp'
   | x :: lp' => x :: reduce_lhyps lp'
-  | nil => nil (A:=list proposition)
+  | nil => nil (A:=hyps)
   end.
 
 Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps.
@@ -2744,7 +2694,7 @@ unfold valid_lhyps in |- *; intros ep e lp; elim lp;
 Qed.
 
 Theorem do_reduce_lhyps :
- forall (envp : PropList) (env : list Z) (l : list (list proposition)),
+ forall (envp : PropList) (env : list Z) (l : lhyps),
  interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l.
 
 intros envp env l H; apply list_goal_to_hyps; intro H1;
@@ -2756,13 +2706,11 @@ Definition concl_to_hyp (p : proposition) :=
   if decidability p then Tnot p else TrueTerm.
 
 Definition do_concl_to_hyp :
-  forall (envp : PropList) (env : list Z) (c : proposition)
-    (l : list proposition),
-  (fun (envp : PropList) (env : list Z) (l : list proposition) =>
-   interp_goal_concl envp env FalseTerm l) envp env (
-    concl_to_hyp c :: l) -> interp_goal_concl envp env c l.
+  forall (envp : PropList) (env : list Z) (c : proposition) (l : hyps),
+  interp_goal envp env (concl_to_hyp c :: l) ->
+  interp_goal_concl c envp env l.
 
-simpl in |- *; intros envp env c l; induction  l as [| a l Hrecl];
+simpl in |- *; intros envp env c l; induction l as [| a l Hrecl];
  [ simpl in |- *; unfold concl_to_hyp in |- *;
     pattern (decidability c) in |- *; apply bool_ind2;
     [ intro H; generalize (decidable_correct envp env c H);
@@ -2772,16 +2720,16 @@ simpl in |- *; intros envp env c l; induction  l as [| a l Hrecl];
 Qed.
 
 Definition omega_tactic (t1 : e_step) (t2 : list h_step) 
-  (c : proposition) (l : list proposition) :=
+  (c : proposition) (l : hyps) :=
   reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))).
 
 Theorem do_omega :
  forall (t1 : e_step) (t2 : list h_step) (envp : PropList) 
-   (env : list Z) (c : proposition) (l : list proposition),
+   (env : list Z) (c : proposition) (l : hyps),
  interp_list_goal envp env (omega_tactic t1 t2 c l) ->
- interp_goal_concl envp env c l.
+ interp_goal_concl c envp env l.
 
 unfold omega_tactic in |- *; intros; apply do_concl_to_hyp;
  apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1);
  apply do_reduce_lhyps; assumption.
-Qed.
\ No newline at end of file
+Qed.
diff --git a/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml
index 3b2a7d31..69b4b2de 100644
--- a/contrib/romega/const_omega.ml
+++ b/contrib/romega/const_omega.ml
@@ -17,7 +17,6 @@ type result =
 
 let destructurate t =
   let c, args = Term.decompose_app t in
-  let env = Global.env() in
   match Term.kind_of_term c, args with
     | Term.Const sp, args ->
 	Kapp (Names.string_of_id
@@ -43,7 +42,7 @@ let dest_const_apply t =
   let f,args = Term.decompose_app t in 
   let ref = 
   match Term.kind_of_term f with 
-    | Term.Const sp         -> Libnames.ConstRef sp
+    | Term.Const sp      -> Libnames.ConstRef sp
     | Term.Construct csp -> Libnames.ConstructRef csp
     | Term.Ind isp       -> Libnames.IndRef isp
     | _ -> raise Destruct
@@ -53,14 +52,16 @@ let recognize_number t =
   let rec loop t =
     let f,l = dest_const_apply t in
     match Names.string_of_id f,l with
-       "xI",[t] -> 1 + 2 * loop t
-     | "xO",[t] -> 2 * loop t 
-     | "xH",[] -> 1
+       "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t))
+     | "xO",[t] -> Bigint.mult Bigint.two (loop t)
+     | "xH",[] -> Bigint.one
      | _ -> failwith "not a number" in
   let f,l = dest_const_apply t in
     match Names.string_of_id f,l with
-       "Zpos",[t] -> loop t | "Zneg",[t] -> - (loop t) | "Z0",[] -> 0
-     | _ -> failwith "not a number";;
+        "Zpos",[t] -> loop t
+      | "Zneg",[t] -> Bigint.neg (loop t)
+      | "Z0",[] -> Bigint.zero
+      | _ -> failwith "not a number";;
 
 
 let logic_dir = ["Coq";"Logic";"Decidable"]
@@ -68,7 +69,7 @@ let logic_dir = ["Coq";"Logic";"Decidable"]
 let coq_modules =
   Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules
     @ [["Coq"; "omega"; "OmegaLemmas"]]
-    @ [["Coq"; "Lists"; (if !Options.v7 then "PolyList" else "List")]]
+    @ [["Coq"; "Lists"; "List"]]
     @ [module_refl_path]
 
 
@@ -77,23 +78,23 @@ let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules
 let coq_xH = lazy (constant "xH")
 let coq_xO = lazy (constant "xO")
 let coq_xI = lazy (constant "xI")
-let coq_ZERO = lazy (constant "Z0")
-let coq_POS = lazy (constant "Zpos")
-let coq_NEG = lazy (constant "Zneg")
+let coq_Z0 = lazy (constant "Z0")
+let coq_Zpos = lazy (constant "Zpos")
+let coq_Zneg = lazy (constant "Zneg")
 let coq_Z = lazy (constant "Z")
-let coq_relation = lazy (constant  "comparison")
-let coq_SUPERIEUR = lazy (constant "SUPERIEUR")
-let coq_INFEEIEUR = lazy (constant "INFERIEUR")
-let coq_EGAL = lazy (constant "EGAL")
+let coq_comparison = lazy (constant  "comparison")
+let coq_Gt = lazy (constant "Gt")
+let coq_Lt = lazy (constant "Lt")
+let coq_Eq = lazy (constant "Eq")
 let coq_Zplus = lazy (constant "Zplus")
 let coq_Zmult = lazy (constant  "Zmult")
 let coq_Zopp = lazy (constant "Zopp")
 
 let coq_Zminus = lazy (constant "Zminus")
-let coq_Zs = lazy (constant  "Zs")
+let coq_Zsucc = lazy (constant  "Zsucc")
 let coq_Zgt = lazy (constant "Zgt")
 let coq_Zle = lazy (constant "Zle")
-let coq_inject_nat = lazy (constant  "inject_nat")
+let coq_Z_of_nat = lazy (constant  "Z_of_nat")
 
 (* Peano *)
 let coq_le = lazy(constant "le")
@@ -111,8 +112,8 @@ let coq_refl_equal = lazy(constant  "refl_equal")
 let coq_and = lazy(constant "and")
 let coq_not = lazy(constant "not")
 let coq_or = lazy(constant "or")
-let coq_true = lazy(constant "true")
-let coq_false = lazy(constant "false")
+let coq_True = lazy(constant "True")
+let coq_False = lazy(constant "False")
 let coq_ex = lazy(constant "ex")
 let coq_I = lazy(constant "I")
 
@@ -159,8 +160,7 @@ let coq_normalize_sequent = lazy (constant  "normalize_goal")
 let coq_execute_sequent = lazy (constant  "execute_goal")
 let coq_do_concl_to_hyp =  lazy (constant  "do_concl_to_hyp")
 let coq_sequent_to_hyps = lazy (constant  "goal_to_hyps")
-let coq_normalize_hyps_goal =
-  lazy (constant  "normalize_hyps_goal")
+let coq_normalize_hyps_goal = lazy (constant  "normalize_hyps_goal")
 
 (* Constructors for shuffle tactic *)
 let coq_t_fusion =  lazy (constant  "t_fusion")
@@ -187,7 +187,7 @@ let coq_c_mult_assoc_r = lazy (constant  "C_MULT_ASSOC_R")
 let coq_c_plus_assoc_r = lazy (constant  "C_PLUS_ASSOC_R")
 let coq_c_plus_assoc_l = lazy (constant  "C_PLUS_ASSOC_L")
 let coq_c_plus_permute = lazy (constant  "C_PLUS_PERMUTE")
-let coq_c_plus_sym = lazy (constant  "C_PLUS_SYM")
+let coq_c_plus_comm = lazy (constant  "C_PLUS_COMM")
 let coq_c_red0 = lazy (constant  "C_RED0")
 let coq_c_red1 = lazy (constant  "C_RED1")
 let coq_c_red2 = lazy (constant  "C_RED2")
@@ -199,7 +199,7 @@ let coq_c_mult_opp_left = lazy (constant  "C_MULT_OPP_LEFT")
 let coq_c_mult_assoc_reduced = 
   lazy (constant  "C_MULT_ASSOC_REDUCED")
 let coq_c_minus = lazy (constant  "C_MINUS")
-let coq_c_mult_sym = lazy (constant  "C_MULT_SYM")
+let coq_c_mult_comm = lazy (constant  "C_MULT_COMM")
 
 let coq_s_constant_not_nul = lazy (constant  "O_CONSTANT_NOT_NUL")
 let coq_s_constant_neg = lazy (constant  "O_CONSTANT_NEG")
@@ -230,184 +230,6 @@ let coq_decompose_solve_valid =
 let coq_do_reduce_lhyps = lazy (constant   "do_reduce_lhyps")
 let coq_do_omega = lazy (constant  "do_omega")
 
-(**
-let constant dir s =
-   try
-     Libnames.constr_of_reference 
-       (Nametab.absolute_reference
-	  (Libnames.make_path
-             (Names.make_dirpath (List.map Names.id_of_string (List.rev dir)))
-             (Names.id_of_string s)))
-   with e -> print_endline (String.concat "." dir); print_endline s;
-             raise e
-
-let path_fast_integer = ["Coq"; "ZArith"; "fast_integer"]
-let path_zarith_aux = ["Coq"; "ZArith"; "zarith_aux"]
-let path_logic = ["Coq"; "Init";"Logic"]
-let path_datatypes = ["Coq"; "Init";"Datatypes"]
-let path_peano = ["Coq"; "Init"; "Peano"]
-let path_list = ["Coq"; "Lists"; "PolyList"]
-
-let coq_xH = lazy (constant path_fast_integer "xH")
-let coq_xO = lazy (constant path_fast_integer "xO")
-let coq_xI = lazy (constant path_fast_integer "xI")
-let coq_ZERO = lazy (constant path_fast_integer "ZERO")
-let coq_POS = lazy (constant path_fast_integer "POS")
-let coq_NEG = lazy (constant path_fast_integer "NEG")
-let coq_Z = lazy (constant path_fast_integer "Z")
-let coq_relation = lazy (constant path_fast_integer "relation")
-let coq_SUPERIEUR = lazy (constant path_fast_integer "SUPERIEUR")
-let coq_INFEEIEUR = lazy (constant path_fast_integer "INFERIEUR")
-let coq_EGAL = lazy (constant path_fast_integer "EGAL")
-let coq_Zplus = lazy (constant path_fast_integer "Zplus")
-let coq_Zmult = lazy (constant path_fast_integer "Zmult")
-let coq_Zopp = lazy (constant path_fast_integer "Zopp")
-
-(* auxiliaires zarith *)
-let coq_Zminus = lazy (constant path_zarith_aux "Zminus")
-let coq_Zs = lazy (constant path_zarith_aux "Zs")
-let coq_Zgt = lazy (constant path_zarith_aux "Zgt")
-let coq_Zle = lazy (constant path_zarith_aux "Zle")
-let coq_inject_nat = lazy (constant path_zarith_aux "inject_nat")
-
-(* Peano *)
-let coq_le = lazy(constant path_peano "le")
-let coq_gt = lazy(constant path_peano "gt")
-
-(* Integers *)
-let coq_nat = lazy(constant path_datatypes "nat")
-let coq_S = lazy(constant path_datatypes "S")
-let coq_O = lazy(constant path_datatypes "O")
-
-(* Minus *)
-let coq_minus = lazy(constant ["Arith"; "Minus"] "minus")
-
-(* Logic *)
-let coq_eq = lazy(constant path_logic "eq")
-let coq_refl_equal = lazy(constant path_logic "refl_equal")
-let coq_and = lazy(constant path_logic "and")
-let coq_not = lazy(constant path_logic "not")
-let coq_or = lazy(constant path_logic "or")
-let coq_true = lazy(constant path_logic "true")
-let coq_false = lazy(constant path_logic "false")
-let coq_ex = lazy(constant path_logic "ex")
-let coq_I = lazy(constant path_logic "I")
-
-(* Lists *)
-let coq_cons =  lazy (constant path_list  "cons")
-let coq_nil =  lazy (constant path_list "nil")
-
-let coq_pcons = lazy (constant module_refl_path "Pcons")
-let coq_pnil = lazy (constant module_refl_path "Pnil")
-
-let coq_h_step = lazy (constant module_refl_path "h_step")
-let coq_pair_step = lazy (constant module_refl_path "pair_step")
-let coq_p_left = lazy (constant module_refl_path "P_LEFT")
-let coq_p_right = lazy (constant module_refl_path "P_RIGHT")
-let coq_p_invert = lazy (constant module_refl_path "P_INVERT")
-let coq_p_step = lazy (constant module_refl_path "P_STEP")
-let coq_p_nop = lazy (constant module_refl_path "P_NOP")
-
-
-let coq_t_int = lazy (constant module_refl_path "Tint")
-let coq_t_plus = lazy (constant module_refl_path "Tplus")
-let coq_t_mult = lazy (constant module_refl_path "Tmult")
-let coq_t_opp = lazy (constant module_refl_path "Topp")
-let coq_t_minus = lazy (constant module_refl_path "Tminus")
-let coq_t_var = lazy (constant module_refl_path "Tvar")
-
-let coq_p_eq = lazy (constant module_refl_path "EqTerm")
-let coq_p_leq = lazy (constant module_refl_path "LeqTerm")
-let coq_p_geq = lazy (constant module_refl_path "GeqTerm")
-let coq_p_lt = lazy (constant module_refl_path "LtTerm")
-let coq_p_gt = lazy (constant module_refl_path "GtTerm")
-let coq_p_neq = lazy (constant module_refl_path "NeqTerm")
-let coq_p_true = lazy (constant module_refl_path "TrueTerm")
-let coq_p_false = lazy (constant module_refl_path "FalseTerm")
-let coq_p_not = lazy (constant module_refl_path "Tnot")
-let coq_p_or = lazy (constant module_refl_path "Tor")
-let coq_p_and = lazy (constant module_refl_path "Tand")
-let coq_p_imp = lazy (constant module_refl_path "Timp")
-let coq_p_prop = lazy (constant module_refl_path "Tprop")
-
-let coq_proposition = lazy (constant module_refl_path "proposition")
-let coq_interp_sequent = lazy (constant module_refl_path "interp_goal_concl")
-let coq_normalize_sequent = lazy (constant module_refl_path "normalize_goal")
-let coq_execute_sequent = lazy (constant module_refl_path "execute_goal")
-let coq_do_concl_to_hyp =  lazy (constant module_refl_path "do_concl_to_hyp")
-let coq_sequent_to_hyps = lazy (constant module_refl_path "goal_to_hyps")
-let coq_normalize_hyps_goal =
-  lazy (constant module_refl_path "normalize_hyps_goal")
-
-(* Constructors for shuffle tactic *)
-let coq_t_fusion =  lazy (constant module_refl_path "t_fusion")
-let coq_f_equal =  lazy (constant module_refl_path "F_equal")
-let coq_f_cancel =  lazy (constant module_refl_path "F_cancel")
-let coq_f_left =  lazy (constant module_refl_path "F_left")
-let coq_f_right =  lazy (constant module_refl_path "F_right")
-
-(* Constructors for reordering tactics *)
-let coq_step = lazy (constant module_refl_path "step")
-let coq_c_do_both = lazy (constant module_refl_path "C_DO_BOTH")
-let coq_c_do_left = lazy (constant module_refl_path "C_LEFT")
-let coq_c_do_right = lazy (constant module_refl_path "C_RIGHT")
-let coq_c_do_seq = lazy (constant module_refl_path "C_SEQ")
-let coq_c_nop = lazy (constant module_refl_path "C_NOP")
-let coq_c_opp_plus = lazy (constant module_refl_path "C_OPP_PLUS")
-let coq_c_opp_opp = lazy (constant module_refl_path "C_OPP_OPP")
-let coq_c_opp_mult_r = lazy (constant module_refl_path "C_OPP_MULT_R")
-let coq_c_opp_one = lazy (constant module_refl_path "C_OPP_ONE")
-let coq_c_reduce = lazy (constant module_refl_path "C_REDUCE")
-let coq_c_mult_plus_distr = lazy (constant module_refl_path "C_MULT_PLUS_DISTR")
-let coq_c_opp_left = lazy (constant module_refl_path "C_MULT_OPP_LEFT")
-let coq_c_mult_assoc_r = lazy (constant module_refl_path "C_MULT_ASSOC_R")
-let coq_c_plus_assoc_r = lazy (constant module_refl_path "C_PLUS_ASSOC_R")
-let coq_c_plus_assoc_l = lazy (constant module_refl_path "C_PLUS_ASSOC_L")
-let coq_c_plus_permute = lazy (constant module_refl_path "C_PLUS_PERMUTE")
-let coq_c_plus_sym = lazy (constant module_refl_path "C_PLUS_SYM")
-let coq_c_red0 = lazy (constant module_refl_path "C_RED0")
-let coq_c_red1 = lazy (constant module_refl_path "C_RED1")
-let coq_c_red2 = lazy (constant module_refl_path "C_RED2")
-let coq_c_red3 = lazy (constant module_refl_path "C_RED3")
-let coq_c_red4 = lazy (constant module_refl_path "C_RED4")
-let coq_c_red5 = lazy (constant module_refl_path "C_RED5")
-let coq_c_red6 = lazy (constant module_refl_path "C_RED6")
-let coq_c_mult_opp_left = lazy (constant module_refl_path "C_MULT_OPP_LEFT")
-let coq_c_mult_assoc_reduced = 
-  lazy (constant module_refl_path "C_MULT_ASSOC_REDUCED")
-let coq_c_minus = lazy (constant module_refl_path "C_MINUS")
-let coq_c_mult_sym = lazy (constant module_refl_path "C_MULT_SYM")
-
-let coq_s_constant_not_nul = lazy (constant module_refl_path "O_CONSTANT_NOT_NUL")
-let coq_s_constant_neg = lazy (constant module_refl_path "O_CONSTANT_NEG")
-let coq_s_div_approx = lazy (constant module_refl_path "O_DIV_APPROX")
-let coq_s_not_exact_divide = lazy (constant module_refl_path "O_NOT_EXACT_DIVIDE")
-let coq_s_exact_divide = lazy (constant module_refl_path "O_EXACT_DIVIDE")
-let coq_s_sum = lazy (constant module_refl_path "O_SUM")
-let coq_s_state = lazy (constant module_refl_path "O_STATE")
-let coq_s_contradiction = lazy (constant module_refl_path "O_CONTRADICTION")
-let coq_s_merge_eq = lazy (constant module_refl_path "O_MERGE_EQ")
-let coq_s_split_ineq =lazy (constant module_refl_path "O_SPLIT_INEQ")
-let coq_s_constant_nul =lazy (constant module_refl_path "O_CONSTANT_NUL")
-let coq_s_negate_contradict =lazy (constant module_refl_path "O_NEGATE_CONTRADICT")
-let coq_s_negate_contradict_inv =lazy (constant module_refl_path "O_NEGATE_CONTRADICT_INV")
-
-(* construction for the [extract_hyp] tactic *)
-let coq_direction = lazy  (constant module_refl_path "direction")
-let coq_d_left = lazy  (constant module_refl_path "D_left")
-let coq_d_right = lazy  (constant module_refl_path "D_right")
-let coq_d_mono = lazy  (constant module_refl_path "D_mono")
-
-let coq_e_split = lazy  (constant module_refl_path "E_SPLIT")
-let coq_e_extract = lazy  (constant module_refl_path "E_EXTRACT")
-let coq_e_solve = lazy  (constant module_refl_path "E_SOLVE")
-
-let coq_decompose_solve_valid = 
-  lazy (constant  module_refl_path "decompose_solve_valid")
-let coq_do_reduce_lhyps = lazy (constant  module_refl_path "do_reduce_lhyps")
-let coq_do_omega = lazy (constant module_refl_path "do_omega")
-
-*)
 (* \subsection{Construction d'expressions} *)
 
 
@@ -423,8 +245,8 @@ let mk_and t1 t2 =  Term.mkApp (Lazy.force coq_and, [|t1; t2 |])
 let mk_or t1 t2 =  Term.mkApp (Lazy.force coq_or, [|t1; t2 |])
 let mk_not t = Term.mkApp (Lazy.force coq_not, [|t |])
 let mk_eq_rel t1 t2 = Term.mkApp (Lazy.force coq_eq, [|
-				Lazy.force coq_relation; t1; t2 |])
-let mk_inj t = Term.mkApp (Lazy.force coq_inject_nat, [|t |])
+				Lazy.force coq_comparison; t1; t2 |])
+let mk_inj t = Term.mkApp (Lazy.force coq_Z_of_nat, [|t |])
 
 
 let do_left t = 
@@ -450,16 +272,20 @@ let rec do_list = function
   | [x] -> x
   | (x::l) -> do_seq x (do_list l)
 
-				 
 let mk_integer n =
   let rec loop n = 
-    if n=1 then Lazy.force coq_xH else 
-      Term.mkApp ((if n mod 2 = 0 then Lazy.force coq_xO else Lazy.force coq_xI),
-		 [| loop (n/2) |]) in
+    if n=Bigint.one then Lazy.force coq_xH else
+      let (q,r) = Bigint.euclid n Bigint.two in
+      Term.mkApp
+        ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI),
+	[| loop q |]) in
     
-    if n = 0 then Lazy.force coq_ZERO 
-    else Term.mkApp ((if n > 0 then Lazy.force coq_POS else Lazy.force coq_NEG),
-		     [| loop (abs n) |])
+    if n = Bigint.zero then Lazy.force coq_Z0 
+    else
+      if Bigint.is_strictly_pos n then
+        Term.mkApp (Lazy.force coq_Zpos, [| loop n |])
+      else
+        Term.mkApp (Lazy.force coq_Zneg, [| loop (Bigint.neg n) |])
 
 let mk_Z = mk_integer
 
diff --git a/contrib/romega/g_romega.ml4 b/contrib/romega/g_romega.ml4
index 386f7f28..7cfc50f8 100644
--- a/contrib/romega/g_romega.ml4
+++ b/contrib/romega/g_romega.ml4
@@ -10,6 +10,6 @@
 
 open Refl_omega
 
-TACTIC EXTEND ROmega
-  [ "ROmega" ] -> [ total_reflexive_omega_tactic ]
+TACTIC EXTEND romelga
+  [ "romega" ] -> [ total_reflexive_omega_tactic ]
 END
diff --git a/contrib/romega/omega2.ml b/contrib/romega/omega2.ml
deleted file mode 100644
index 91aefc60..00000000
--- a/contrib/romega/omega2.ml
+++ /dev/null
@@ -1,675 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(**************************************************************************)
-(*                                                                        *)
-(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
-(*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
-(*                                                                        *)
-(* 13/10/2002 : modified to cope with an external numbering of equations  *)
-(*   and hypothesis. Its use for Omega is not more complex and it makes   *)
-(*   things much simpler for the reflexive version where we should limit  *)
-(*   the number of source of numbering.                                   *)
-(**************************************************************************)
-
-open Names
-
-let flat_map f =
- let rec flat_map_f = function
-   | [] -> [] 
-   | x :: l -> f x @ flat_map_f l
- in 
- flat_map_f
-
-let pp i = print_int i; print_newline (); flush stdout
-
-let debug = ref false
-
-let filter = List.partition
-
-let push v l = l := v :: !l
-
-let rec pgcd x y = if y = 0 then x else pgcd y (x mod y)
-
-let pgcd_l = function
-  | [] -> failwith "pgcd_l"
-  | x :: l -> List.fold_left pgcd x l
-
-let floor_div a b =
-  match a >=0 , b > 0 with
-    | true,true -> a / b
-    | false,false -> a / b
-    | true, false -> (a-1) / b - 1
-    | false,true  -> (a+1) / b - 1
-
-type coeff = {c: int ; v: int}
-
-type linear = coeff list
-
-type eqn_kind = EQUA | INEQ | DISE
-
-type afine = { 
-  (* a number uniquely identifying the equation *)
-  id: int ; 
-  (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *)
-  kind: eqn_kind; 
-  (* the variables and their coefficient *)
-  body: coeff list; 
-  (* a constant *)
-  constant: int }
-
-type state_action = {
-  st_new_eq : afine;
-  st_def    :  afine;
-  st_orig   : afine;
-  st_coef   : int;
-  st_var    : int }
-
-type action =
-  | DIVIDE_AND_APPROX of afine * afine * int * int
-  | NOT_EXACT_DIVIDE of afine * int
-  | FORGET_C of int
-  | EXACT_DIVIDE of afine * int
-  | SUM of int * (int * afine) * (int * afine)
-  | STATE of state_action 
-  | HYP of afine
-  | FORGET   of int * int
-  | FORGET_I of int * int
-  | CONTRADICTION of afine * afine
-  | NEGATE_CONTRADICT of afine * afine * bool
-  | MERGE_EQ of int * afine * int 
-  | CONSTANT_NOT_NUL of int * int
-  | CONSTANT_NUL of int
-  | CONSTANT_NEG of int * int
-  | SPLIT_INEQ of afine * (int * action list) * (int * action list)
-  | WEAKEN of int * int
-
-exception UNSOLVABLE
-
-exception NO_CONTRADICTION
-
-let display_eq print_var (l,e) =
-  let _ = 
-    List.fold_left 
-      (fun not_first f ->
-	 print_string 
-	   (if f.c < 0 then "- " else if not_first then "+ " else "");
-	 let c = abs f.c in
-	 if c = 1 then 
-	   Printf.printf "%s " (print_var f.v)
-	 else 
-	   Printf.printf "%d %s " c (print_var f.v); 
-	 true)
-      false l
-  in
-  if e > 0 then 
-    Printf.printf "+ %d " e 
-  else if e < 0 then 
-    Printf.printf "- %d " (abs e)
-
-let rec trace_length l =
-  let action_length accu = function
-    | SPLIT_INEQ (_,(_,l1),(_,l2)) ->
-	accu + 1 + trace_length l1 + trace_length l2
-    | _ -> accu + 1 in
-  List.fold_left action_length 0 l
-
-let operator_of_eq = function 
-  | EQUA -> "=" | DISE -> "!=" | INEQ -> ">="
-
-let kind_of = function
-  | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation"
-
-let display_system print_var l = 
-  List.iter 
-    (fun { kind=b; body=e; constant=c; id=id} -> 
-       print_int id; print_string ": ";
-       display_eq print_var (e,c); print_string (operator_of_eq b);
-       print_string "0\n") 
-    l;
-  print_string "------------------------\n\n"
-
-let display_inequations print_var l = 
-  List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l;
-  print_string "------------------------\n\n"
-
-let rec display_action print_var = function
-  | act :: l -> begin match act with
-      | DIVIDE_AND_APPROX (e1,e2,k,d) ->
-          Printf.printf 
-            "Inequation E%d is divided by %d and the constant coefficient is \
-            rounded by substracting %d.\n" e1.id k d
-      | NOT_EXACT_DIVIDE (e,k) ->
-          Printf.printf
-            "Constant in equation E%d is not divisible by the pgcd \
-            %d of its other coefficients.\n" e.id k
-      | EXACT_DIVIDE (e,k) ->
-          Printf.printf
-            "Equation E%d is divided by the pgcd \
-            %d of its coefficients.\n" e.id k
-      | WEAKEN (e,k) ->
-          Printf.printf 
-            "To ensure a solution in the dark shadow \
-            the equation E%d is weakened by %d.\n" e k
-      | SUM (e,(c1,e1),(c2,e2)) -> 
-          Printf.printf
-            "We state %s E%d = %d %s E%d + %d %s E%d.\n" 
-            (kind_of e1.kind) e c1 (kind_of e1.kind) e1.id c2 
-            (kind_of e2.kind) e2.id
-      | STATE { st_new_eq = e; st_coef = x} ->
-          Printf.printf "We define a new equation %d :" e.id; 
-          display_eq print_var (e.body,e.constant); 
-          print_string (operator_of_eq e.kind); print_string " 0\n"
-      | HYP e ->   
-          Printf.printf "We define %d :" e.id; 
-          display_eq print_var (e.body,e.constant); 
-          print_string (operator_of_eq e.kind); print_string " 0\n"
-      | FORGET_C e ->  Printf.printf "E%d is trivially satisfiable.\n" e
-      | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
-      | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
-      | MERGE_EQ (e,e1,e2) ->
-         Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e
-      | CONTRADICTION (e1,e2) -> 
-          Printf.printf
-            "equations E%d and E%d implie a contradiction on their \
-            constant factors.\n" e1.id e2.id
-      | NEGATE_CONTRADICT(e1,e2,b) ->
-          Printf.printf
-            "Eqations E%d and E%d state that their body is at the same time
-            equal and different\n" e1.id e2.id
-      | CONSTANT_NOT_NUL (e,k) -> 
-          Printf.printf "equation E%d states %d=0.\n" e k
-      | CONSTANT_NEG(e,k) -> 
-          Printf.printf "equation E%d states %d >= 0.\n" e k
-      | CONSTANT_NUL e ->
-          Printf.printf "inequation E%d states 0 != 0.\n" e
-      | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> 
-          Printf.printf "equation E%d is split in E%d and E%d\n\n" e.id e1 e2;
-          display_action print_var l1;
-          print_newline ();
-          display_action print_var l2;
-          print_newline ()
-    end; display_action print_var l
-  | [] -> 
-      flush stdout
-
-(*""*)
-let default_print_var v = Printf.sprintf "XX%d" v
-
-let add_event, history, clear_history =
-  let accu = ref [] in
-  (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu),
-  (fun () -> !accu),
-  (fun () -> accu := [])
-
-let nf_linear = Sort.list (fun x y -> x.v > y.v)
-
-let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x))
-
-let map_eq_linear f = 
-  let rec loop = function
-    | x :: l -> let c = f x.c in if c=0 then loop l else {v=x.v; c=c} :: loop l
-    | [] -> [] 
-  in
-  loop
-
-let map_eq_afine f e = 
-  { id = e.id; kind = e.kind; body = map_eq_linear f e.body; 
-    constant = f e.constant }
-
-let negate_eq = map_eq_afine (fun x -> -x)
-
-let rec sum p0 p1 = match (p0,p1) with 
-  | ([], l) -> l | (l, []) -> l
-  | (((x1::l1) as l1'), ((x2::l2) as l2')) -> 
-      if x1.v = x2.v then
-	let c = x1.c + x2.c in
-	if c = 0 then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2
-      else if x1.v > x2.v then 
-	x1 :: sum l1 l2'
-      else 
-	x2 :: sum l1' l2
-
-let sum_afine new_eq_id eq1 eq2 = 
-  { kind = eq1.kind; id = new_eq_id ();
-    body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant }
-
-exception FACTOR1
-
-let rec chop_factor_1 = function
-  | x :: l -> 
-      if abs x.c = 1 then x,l else let (c',l') = chop_factor_1 l in (c',x::l')
-  | [] -> raise FACTOR1
-
-exception CHOPVAR
-
-let rec chop_var v = function
-  | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l')
-  | [] -> raise CHOPVAR
-
-let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
-  if e = [] then begin 
-    match eq_flag with
-      | EQUA ->
-          if x =0 then [] else begin
-            add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE
-         end
-      | DISE ->
-          if x <> 0 then [] else begin
-            add_event (CONSTANT_NUL id); raise UNSOLVABLE
-          end
-      | INEQ ->
-          if x >= 0 then [] else begin
-            add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE
-          end
-  end else
-    let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in
-    if eq_flag=EQUA & x mod gcd <> 0 then begin
-      add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE
-    end else if eq_flag=DISE & x mod gcd <> 0 then begin
-      add_event (FORGET_C eq.id); []
-    end else if gcd <> 1 then begin
-      let c = floor_div x gcd in
-      let d = x - c * gcd in
-      let new_eq = {id=id; kind=eq_flag; constant=c; 
-                    body=map_eq_linear (fun c -> c / gcd) e} in
-      add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd)
-                 else DIVIDE_AND_APPROX(eq,new_eq,gcd,d));
-      [new_eq]
-    end else [eq]
-
-let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2
-                        ({body=e1; constant=c1} as eq1) =
-  try
-    let (f,_) = chop_var v e1 in 
-    let coeff = if c_unite=1 then -f.c else if c_unite= -1 then f.c 
-                else failwith "eliminate_with_in" in
-    let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in
-    add_event (SUM (res.id,(1,eq1),(coeff,eq2))); res
-  with CHOPVAR -> eq1
-
-let omega_mod a b = a - b * floor_div (2 * a + b) (2 * b)
-let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = 
-  let e = original.body in
-  let sigma = new_var_id () in
-  let smallest,var =
-    try
-      List.fold_left (fun (v,p) c ->  if v > (abs c.c) then abs c.c,c.v else (v,p))
-              (abs (List.hd e).c, (List.hd e).v) (List.tl e)
-    with Failure "tl" -> display_system print_var [original] ; failwith "TL" in
-  let m = smallest + 1 in
-  let new_eq =
-    { constant = omega_mod original.constant m;
-      body = {c= -m;v=sigma} :: 
-             map_eq_linear (fun a -> omega_mod a m) original.body;
-      id = new_eq_id (); kind = EQUA } in
-  let definition =
-    { constant = - floor_div (2 * original.constant + m) (2 * m);
-      body = map_eq_linear (fun a -> - floor_div (2 * a + m) (2 * m))
-                             original.body;
-      id = new_eq_id (); kind = EQUA } in
-  add_event (STATE {st_new_eq = new_eq; st_def = definition;
-		    st_orig =original; st_coef = m; st_var = sigma});
-  let new_eq = List.hd (normalize new_eq) in
-  let eliminated_var, def = chop_var var new_eq.body in
-  let other_equations = 
-    flat_map (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e))
-             l1 in
-  let inequations = 
-    flat_map (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e))
-             l2 in
-  let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in
-  let mod_original = map_eq_afine (fun c -> c / m) original' in
-  add_event (EXACT_DIVIDE (original',m));
-  List.hd (normalize mod_original),other_equations,inequations
-
-let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = 
-  if !debug then display_system print_var (e::other);
-  try
-    let v,def = chop_factor_1 e.body in
-    (flat_map (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other,
-     flat_map (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs)
-  with FACTOR1 -> 
-    eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs)
-
-let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) =
-  let rec fst_eq_1 = function
-     (eq::l) -> 
-        if List.exists (fun x -> abs x.c = 1) eq.body then eq,l
-        else let (eq',l') = fst_eq_1 l in (eq',eq::l')
-   | [] -> raise Not_found in
-  match sys_eq with
-     [] -> if !debug then display_system print_var sys_ineq; sys_ineq
-   | (e1::rest) -> 
-       let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in
-       if eq.body = [] then 
-         if eq.constant = 0 then begin
-           add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq)
-         end else begin
-           add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE
-         end
-       else
-	 banerjee new_ids 
-	   (eliminate_one_equation new_ids (eq,other,sys_ineq))
-
-type kind = INVERTED | NORMAL
-
-let redundancy_elimination new_eq_id system =
-  let normal = function
-     ({body=f::_} as e) when f.c < 0 ->  negate_eq e, INVERTED
-   | e -> e,NORMAL in
-  let table = Hashtbl.create 7 in
-  List.iter
-    (fun e -> 
-       let ({body=ne} as nx) ,kind = normal e in
-       if ne = [] then
-         if nx.constant < 0 then begin
-           add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE
-         end else add_event (FORGET_C nx.id)
-       else
-       try 
-         let (optnormal,optinvert) = Hashtbl.find table ne in
-         let final =
-           if kind = NORMAL then begin
-             match optnormal with 
-                Some v -> 
-                  let kept =
-                    if v.constant < nx.constant 
-                    then begin add_event (FORGET (v.id,nx.id));v end
-                    else begin add_event (FORGET (nx.id,v.id));nx end in
-                  (Some(kept),optinvert)
-              | None -> Some nx,optinvert
-           end else begin
-             match optinvert with 
-                Some v ->
-                  let kept =
-                    if v.constant > nx.constant 
-                    then begin add_event (FORGET_I (v.id,nx.id));v end
-                    else begin add_event (FORGET_I (nx.id,v.id));nx end in
-                  (optnormal,Some(if v.constant > nx.constant then v else nx))
-              | None -> optnormal,Some nx
-           end in
-         begin match final with
-            (Some high, Some low) -> 
-              if high.constant < low.constant then begin
-                add_event(CONTRADICTION (high,negate_eq low));
-                raise UNSOLVABLE
-              end
-          | _ -> () end;
-         Hashtbl.remove table ne;
-         Hashtbl.add table ne final
-       with Not_found ->
-         Hashtbl.add table ne 
-           (if kind = NORMAL then (Some nx,None) else (None,Some nx)))
-    system;
-  let accu_eq = ref [] in
-  let accu_ineq = ref [] in
-  Hashtbl.iter
-    (fun p0 p1 -> match (p0,p1) with 
-       | (e, (Some x, Some y)) when x.constant = y.constant -> 
-           let id=new_eq_id () in
-           add_event (MERGE_EQ(id,x,y.id));
-           push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq
-       | (e, (optnorm,optinvert)) ->
-           begin match optnorm with 
-               Some x -> push x accu_ineq | _ -> () end;
-           begin match optinvert with 
-               Some x -> push (negate_eq x) accu_ineq | _ -> () end)
-    table;
-  !accu_eq,!accu_ineq
-
-exception SOLVED_SYSTEM
-
-let select_variable system =
-  let table = Hashtbl.create 7 in
-  let push v c= 
-    try let r = Hashtbl.find table v in r := max !r (abs c)
-    with Not_found -> Hashtbl.add table v (ref (abs c)) in
-  List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system;
-  let vmin,cmin = ref (-1), ref 0 in
-  let var_cpt = ref 0 in
-  Hashtbl.iter
-    (fun v ({contents =  c}) ->
-       incr var_cpt;
-       if c < !cmin or !vmin = (-1) then begin vmin := v; cmin := c end)
-    table;
-  if !var_cpt < 1 then raise SOLVED_SYSTEM;
-  !vmin
-
-let classify v system =
-  List.fold_left 
-    (fun (not_occ,below,over) eq ->
-       try let f,eq' = chop_var v eq.body in
-       if f.c >= 0 then (not_occ,((f.c,eq) :: below),over)
-       else (not_occ,below,((-f.c,eq) :: over))
-       with CHOPVAR -> (eq::not_occ,below,over))
-    ([],[],[]) system
-
-let product new_eq_id dark_shadow low high =
-  List.fold_left
-    (fun accu (a,eq1) ->
-       List.fold_left
-         (fun accu (b,eq2) ->
-            let eq = 
-              sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1)
-                (map_eq_afine (fun c -> c * a) eq2) in
-            add_event(SUM(eq.id,(b,eq1),(a,eq2)));
-            match normalize eq with
-	      | [eq] ->
-                  let final_eq =
-                    if dark_shadow then 
-                      let delta = (a - 1) * (b - 1) in
-                      add_event(WEAKEN(eq.id,delta));
-                      {id = eq.id; kind=INEQ; body = eq.body; 
-                       constant = eq.constant - delta} 
-                    else eq
-                  in final_eq :: accu
-              | (e::_) -> failwith "Product dardk"
-              | [] -> accu)
-         accu high)
-    [] low
-
-let fourier_motzkin (_,new_eq_id,print_var) dark_shadow system =
-  let v = select_variable system in
-  let (ineq_out, ineq_low,ineq_high) = classify v system in
-  let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in
-  if !debug then display_system print_var expanded; expanded
-
-let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system =
-  if List.exists (fun e -> e.kind = DISE) system then 
-    failwith "disequation in simplify";
-  clear_history ();
-  List.iter (fun e -> add_event (HYP e)) system;
-  let system = flat_map normalize system in
-  let eqs,ineqs = filter (fun e -> e.kind=EQUA) system in
-  let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in
-  let system = (eqs @ simp_eq,simp_ineq) in
-  let rec loop1a system =
-    let sys_ineq = banerjee new_ids system in 
-    loop1b sys_ineq 
-  and loop1b sys_ineq =
-    let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in
-    if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) 
-  in
-  let rec loop2 system =
-    try
-      let expanded = fourier_motzkin new_ids dark_shadow system in
-      loop2 (loop1b expanded)
-    with SOLVED_SYSTEM ->
-      if !debug then display_system print_var system; system 
-  in
-  loop2 (loop1a system)
-
-let rec depend relie_on accu = function
-  | act :: l -> 
-      begin match act with
-	| DIVIDE_AND_APPROX (e,_,_,_) ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| EXACT_DIVIDE (e,_) ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| WEAKEN (e,_) ->
-            if List.mem e relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| SUM (e,(_,e1),(_,e2)) -> 
-            if List.mem e relie_on then 
-	      depend (e1.id::e2.id::relie_on) (act::accu) l
-            else 
-	      depend relie_on accu l
-	| STATE {st_new_eq=e} ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| HYP e ->   
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
-            else depend relie_on accu l
-	| FORGET_C _ -> depend relie_on accu l
-	| FORGET _ -> depend relie_on accu l
-	| FORGET_I _ -> depend relie_on accu l
-	| MERGE_EQ (e,e1,e2) ->
-            if List.mem e relie_on then 
-	      depend (e1.id::e2::relie_on) (act::accu) l
-            else 
-	      depend relie_on accu l
-	| NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l
-	| CONTRADICTION (e1,e2) -> 
-	    depend (e1.id::e2.id::relie_on) (act::accu) l
-	| CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l
-	| CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l
-	| CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l
-	| NEGATE_CONTRADICT (e1,e2,_) -> 
-            depend (e1.id::e2.id::relie_on) (act::accu) l
-	| SPLIT_INEQ _ -> failwith "depend"
-      end
-  | [] -> relie_on, accu
-
-(*
-let depend relie_on accu trace = 
-  Printf.printf "Longueur de la trace initiale : %d\n" 
-    (trace_length trace + trace_length accu);
-  let rel',trace' = depend relie_on accu trace in
-  Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace');
-  rel',trace'
-*)
-
-let solve (new_eq_id,new_eq_var,print_var) system =
-  try let _ = simplify new_eq_id false system in failwith "no contradiction"
-  with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ())))
-      
-let negation (eqs,ineqs) =
-  let diseq,_ = filter (fun e -> e.kind = DISE) ineqs in
-  let normal = function
-    | ({body=f::_} as e) when f.c < 0 ->  negate_eq e, INVERTED
-    | e -> e,NORMAL in
-  let table = Hashtbl.create 7 in
-  List.iter (fun e -> 
-               let {body=ne;constant=c} ,kind = normal e in
-               Hashtbl.add table (ne,c) (kind,e)) diseq;
-  List.iter (fun e ->
-               if e.kind <> EQUA then pp 9999;
-               let {body=ne;constant=c},kind = normal e in
-               try 
-		 let (kind',e') = Hashtbl.find table (ne,c) in
-		 add_event (NEGATE_CONTRADICT (e,e',kind=kind'));
-		 raise UNSOLVABLE
-               with Not_found -> ()) eqs
-
-exception FULL_SOLUTION of action list * int list
-
-let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
-  clear_history ();
-  List.iter (fun e -> add_event (HYP e)) system;
-  (* Initial simplification phase *)
-  let rec loop1a system =
-    negation system;
-    let sys_ineq = banerjee new_ids system in 
-    loop1b sys_ineq 
-  and loop1b sys_ineq =
-    let dise,ine = filter (fun e -> e.kind = DISE) sys_ineq in
-    let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
-    if simp_eq = [] then dise @ simp_ineq
-    else loop1a (simp_eq,dise @ simp_ineq) 
-  in
-  let rec loop2 system =
-    try
-      let expanded = fourier_motzkin new_ids false system in
-      loop2 (loop1b expanded)
-    with SOLVED_SYSTEM -> if !debug then display_system print_var system; system 
-  in
-  let rec explode_diseq = function 
-    | (de::diseq,ineqs,expl_map) ->
-	let id1 = new_eq_id () 
-	and id2 = new_eq_id () in
-	let e1 = 
-	  {id = id1; kind=INEQ; body = de.body; constant = de.constant - 1} in
-	let e2 = 
-	  {id = id2; kind=INEQ; body = map_eq_linear (fun x -> -x) de.body; 
-           constant = - de.constant - 1} in
-	let new_sys =
-          List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) 
-	    ineqs @ 
-          List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) 
-	    ineqs 
-	in
-	explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map)
-    | ([],ineqs,expl_map) -> ineqs,expl_map 
-  in
-  try 
-    let system = flat_map normalize system in
-    let eqs,ineqs = filter (fun e -> e.kind=EQUA) system in
-    let dise,ine = filter (fun e -> e.kind = DISE) ineqs in
-    let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
-    let system = (eqs @ simp_eq,simp_ineq @ dise) in
-    let system' = loop1a system in
-    let diseq,ineq = filter (fun e -> e.kind = DISE) system' in
-    let first_segment = history () in
-    let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in
-    let all_solutions =
-      List.map
-        (fun (decomp,sys) -> 
-           clear_history ();
-           try let _ = loop2 sys in raise NO_CONTRADICTION
-           with UNSOLVABLE -> 
-             let relie_on,path = depend [] [] (history ()) in
-             let dc,_ = filter (fun (_,id,_) -> List.mem id relie_on) decomp in
-             let red = List.map (fun (x,_,_) -> x) dc in
-             (red,relie_on,decomp,path))
-        sys_exploded 
-    in
-    let max_count sys = 
-      let tbl = Hashtbl.create 7 in
-      let augment x = 
-        try incr (Hashtbl.find tbl x) 
-	with Not_found -> Hashtbl.add tbl x (ref 1) in
-      let eq = ref (-1) and c = ref 0 in
-      List.iter (function 
-		   | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on))
-                   | (l,_,_,_) -> List.iter augment l) sys;
-      Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl;
-      !eq 
-    in
-    let rec solve systems = 
-      try 
-	let id = max_count systems in 
-        let rec sign = function 
-	  | ((id',_,b)::l) -> if id=id' then b else sign l 
-          | [] -> failwith "solve" in
-        let s1,s2 = filter (fun (_,_,decomp,_) -> sign decomp) systems in
-        let s1' = 
-	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in
-        let s2' = 
-	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in
-        let (r1,relie1) = solve s1' 
-	and (r2,relie2) = solve s2' in
-	let (eq,id1,id2) = List.assoc id explode_map in
-	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2
-      with FULL_SOLUTION (x0,x1) -> (x0,x1) 
-    in
-    let act,relie_on = solve all_solutions in
-    snd(depend relie_on act first_segment)
-  with UNSOLVABLE -> snd (depend [] [] (history ()))
diff --git a/contrib/romega/refl_omega.ml b/contrib/romega/refl_omega.ml
index ef68c587..285fc0ca 100644
--- a/contrib/romega/refl_omega.ml
+++ b/contrib/romega/refl_omega.ml
@@ -7,7 +7,8 @@
  *************************************************************************)
 
 open Const_omega
-
+module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
+open OmegaSolver
 
 (* \section{Useful functions and flags} *)
 (* Especially useful debugging functions *)
@@ -25,7 +26,7 @@ let (>>) = Tacticals.tclTHEN
 
 let list_index t = 
   let rec loop i = function
-    | (u::l) -> if u = t then i else loop (i+1) l
+    | (u::l) -> if u = t then i else loop (succ i) l
     | [] -> raise Not_found in
   loop 0
 
@@ -101,7 +102,7 @@ type occurence = {o_hyp : Names.identifier; o_path : occ_path}
 (* \subsection{refiable formulas} *)
 type oformula =
     (* integer *)
-  | Oint of int
+  | Oint of Bigint.bigint
     (* recognized binary and unary operations *)
   | Oplus of oformula * oformula
   | Omult of oformula * oformula
@@ -139,7 +140,7 @@ and oequation = {
     e_depends: direction  list;		(* liste des points de disjonction dont 
 					   dépend l'accès à l'équation avec la 
 					   direction (branche) pour y accéder *)
-    e_omega: Omega2.afine		(* la fonction normalisée *)
+    e_omega: afine		(* la fonction normalisée *)
   } 
 
 (* \subsection{Proof context} 
@@ -172,7 +173,7 @@ type environment = {
 type solution = {
   s_index : int;
   s_equa_deps : int list;
-  s_trace : Omega2.action list }
+  s_trace : action list }
 
 (* Arbre de solution résolvant complètement un ensemble de systèmes *)
 type solution_tree = 
@@ -203,8 +204,8 @@ let new_environment () = {
 }
 
 (* Génération d'un nom d'équation *)
-let new_eq_id env =
-   env.cnt_connectors <- env.cnt_connectors + 1; env.cnt_connectors
+let new_connector_id env =  
+   env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors
 
 (* Calcul de la branche complémentaire *)
 let barre = function Left x -> Right x | Right x -> Left x
@@ -215,21 +216,36 @@ let indice = function Left x | Right x -> x
 (* Affichage de l'environnement de réification (termes et propositions) *)
 let print_env_reification env = 
   let rec loop c i = function
-      [] -> Printf.printf "===============================\n\n"
+      [] -> Printf.printf "  ===============================\n\n"
     | t :: l -> 
-	Printf.printf "(%c%02d) : " c i;
-	Pp.ppnl (Printer.prterm t);
+	Printf.printf "  (%c%02d) := " c i;
+	Pp.ppnl (Printer.pr_lconstr t);
 	Pp.flush_all ();
-	loop c (i+1) l in
-  Printf.printf "PROPOSITIONS :\n\n"; loop 'P' 0 env.props;
-  Printf.printf "TERMES :\n\n"; loop 'V' 0 env.terms
+	loop c (succ i) l in
+  print_newline ();
+  Printf.printf "  ENVIRONMENT OF PROPOSITIONS :\n\n"; loop 'P' 0 env.props;
+  Printf.printf "  ENVIRONMENT OF TERMS :\n\n"; loop 'V' 0 env.terms
 
 
 (* \subsection{Gestion des environnements de variable pour Omega} *)
 (* generation d'identifiant d'equation pour Omega *)
-let new_omega_id = let cpt = ref 0 in function () -> incr cpt; !cpt
+
+let new_omega_eq, rst_omega_eq = 
+  let cpt = ref 0 in 
+  (function () -> incr cpt; !cpt), 
+  (function () -> cpt:=0)
+
+(* generation d'identifiant de variable pour Omega *)
+
+let new_omega_var, rst_omega_var = 
+  let cpt = ref 0 in 
+  (function () -> incr cpt; !cpt), 
+  (function () -> cpt:=0)
+
 (* Affichage des variables d'un système *)
-let display_omega_id i = Printf.sprintf "O%d" i
+
+let display_omega_var i = Printf.sprintf "OV%d" i
+
 (* Recherche la variable codant un terme pour Omega et crée la variable dans
    l'environnement si il n'existe pas. Cas ou la variable dans Omega représente
    le terme d'un monome (le plus souvent un atome) *)
@@ -237,12 +253,12 @@ let display_omega_id i = Printf.sprintf "O%d" i
 let intern_omega env t =
   begin try List.assoc t env.om_vars
   with Not_found -> 
-    let v = new_omega_id () in 
+    let v = new_omega_var () in 
     env.om_vars <- (t,v) :: env.om_vars; v
   end
 
-(* Ajout forcé d'un lien entre un terme et une variable Omega. Cas ou la
-   variable est crée par Omega et ou il faut la lier après coup a un atome
+(* Ajout forcé d'un lien entre un terme et une variable  Cas où la
+   variable est créée par Omega et où il faut la lier après coup à un atome
    réifié introduit de force *)
 let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars
 
@@ -281,7 +297,7 @@ let get_prop v env = try List.nth v env with _ -> failwith "get_prop"
 (* \subsection{Gestion du nommage des équations} *)
 (* Ajout d'une equation dans l'environnement de reification *)
 let add_equation env e =
-  let id = e.e_omega.Omega2.id in
+  let id = e.e_omega.id in
   try let _ = Hashtbl.find env.equations id in ()
   with Not_found -> Hashtbl.add env.equations id e
 
@@ -292,7 +308,7 @@ let get_equation env id =
 
 (* Affichage des termes réifiés *)
 let rec oprint ch = function 
-  | Oint n -> Printf.fprintf ch "%d" n
+  | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n)
   | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2  
   | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 
   | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 
@@ -304,7 +320,7 @@ let rec pprint ch = function
     Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 })  ->
       let connector = 
 	match comp with 
-	  Eq -> "=" | Leq -> "=<" | Geq -> ">="
+	  Eq -> "=" | Leq -> "<=" | Geq -> ">="
 	| Gt -> ">" | Lt -> "<" | Neq -> "!=" in
       Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2  
   | Ptrue -> Printf.fprintf ch "TT"
@@ -331,12 +347,12 @@ let rec weight env = function
 let omega_of_oformula env kind = 
   let rec loop accu = function
     | Oplus(Omult(v,Oint n),r) -> 
-	loop ({Omega2.v=intern_omega env v; Omega2.c=n} :: accu) r
+	loop ({v=intern_omega env v; c=n} :: accu) r
     | Oint n ->
-	let id = new_omega_id () in
+	let id = new_omega_eq () in
 	(*i tag_equation name id; i*)
-	{Omega2.kind = kind; Omega2.body = List.rev accu; 
-	 Omega2.constant = n; Omega2.id = id}
+	{kind = kind; body = List.rev accu; 
+	 constant = n; id = id}
     | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in
   loop []
 
@@ -351,10 +367,10 @@ let reified_of_atom env i =
 
 let rec oformula_of_omega env af = 
   let rec loop = function
-    | ({Omega2.v=v; Omega2.c=n}::r) ->
+    | ({v=v; c=n}::r) ->
 	Oplus(Omult(unintern_omega env v,Oint n),loop r)
-    | [] -> Oint af.Omega2.constant in
-  loop af.Omega2.body
+    | [] -> Oint af.constant in
+  loop af.body
 
 let app f v = mkApp(Lazy.force f,v)
 
@@ -429,7 +445,7 @@ let reified_of_proposition env f =
 let reified_of_omega env body constant = 
   let coeff_constant = 
     app coq_t_int [| mk_Z constant |] in
-  let mk_coeff {Omega2.c=c; Omega2.v=v} t =
+  let mk_coeff {c=c; v=v} t =
     let coef = 
       app coq_t_mult 
 	[| reified_of_formula env (unintern_omega env v); 
@@ -441,7 +457,7 @@ let reified_of_omega env body c  =
   begin try 
     reified_of_omega env body c 
   with e -> 
-    Omega2.display_eq display_omega_id (body,c); raise e 
+    display_eq display_omega_var (body,c); raise e 
   end
 
 (* \section{Opérations sur les équations}
@@ -475,7 +491,7 @@ let rec scalar n = function
      do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], 
      Oplus(t1',t2')
  | Oopp t ->
-     do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(-n))
+     do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n))
  | Omult(t1,Oint x) -> 
      do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
  | Omult(t1,t2) -> 
@@ -496,12 +512,12 @@ let rec negate = function
  | Oopp t ->
      do_list [Lazy.force coq_c_opp_opp], t
  | Omult(t1,Oint x) -> 
-     do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (-x))
+     do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x))
  | Omult(t1,t2) -> 
      Util.error "Omega: Can't solve a goal with non-linear products"
  | (Oatom _ as t) ->
-     do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(-1))
- | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(-i)
+     do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone))
+ | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i)
  | Oufo c -> do_list [], Oufo (Oopp c)
  | Ominus _ -> failwith "negate minus"
 
@@ -511,10 +527,10 @@ let rec norm l = (List.length l)
 (* \subsubsection{Version avec coefficients} *)
 let rec shuffle_path k1 e1 k2 e2 =
   let rec loop = function
-      (({Omega2.c=c1;Omega2.v=v1}::l1) as l1'),
-      (({Omega2.c=c2;Omega2.v=v2}::l2) as l2') ->
+      (({c=c1;v=v1}::l1) as l1'),
+      (({c=c2;v=v2}::l2) as l2') ->
 	if v1 = v2 then
-          if k1*c1 + k2 * c2 = 0 then (
+          if k1*c1 + k2 * c2 = zero then (
             Lazy.force coq_f_cancel :: loop (l1,l2))
           else (
             Lazy.force coq_f_equal :: loop (l1,l2) )
@@ -522,9 +538,9 @@ let rec shuffle_path k1 e1 k2 e2 =
 	  Lazy.force coq_f_left :: loop(l1,l2'))
 	else (
 	  Lazy.force coq_f_right :: loop(l1',l2))
-    | ({Omega2.c=c1;Omega2.v=v1}::l1), [] -> 
+    | ({c=c1;v=v1}::l1), [] -> 
 	  Lazy.force coq_f_left :: loop(l1,[])
-    | [],({Omega2.c=c2;Omega2.v=v2}::l2) -> 
+    | [],({c=c2;v=v2}::l2) -> 
 	  Lazy.force coq_f_right :: loop([],l2)
     | [],[] -> flush stdout; [] in
   mk_shuffle_list (loop (e1,e2))
@@ -543,7 +559,7 @@ let rec shuffle env (t1,t2) =
       if weight env l1 > weight env t2 then
         let (l_action,t') = shuffle env (r1,t2) in
 	do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t')
-      else do_list [Lazy.force coq_c_plus_sym], Oplus(t2,t1)
+      else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
   | t1,Oplus(l2,r2) -> 
       if weight env l2 > weight env t1 then
         let (l_action,t') = shuffle env (t1,r2) in
@@ -553,7 +569,7 @@ let rec shuffle env (t1,t2) =
       do_list [Lazy.force coq_c_reduce], Oint(t1+t2)
   | t1,t2 ->
       if weight env t1 < weight env t2 then
-	do_list [Lazy.force coq_c_plus_sym], Oplus(t2,t1)
+	do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
       else do_list [],Oplus(t1,t2)
 
 (* \subsection{Fusion avec réduction} *)
@@ -561,11 +577,11 @@ let rec shuffle env (t1,t2) =
 let shrink_pair f1 f2 =
   begin match f1,f2 with
      Oatom v,Oatom _ -> 
-       Lazy.force coq_c_red1, Omult(Oatom v,Oint 2)
+       Lazy.force coq_c_red1, Omult(Oatom v,Oint two)
    | Oatom v, Omult(_,c2) -> 
-       Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint 1))
+       Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one))
    | Omult (v1,c1),Oatom v -> 
-       Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint 1))
+       Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one))
    | Omult (Oatom v,c1),Omult (v2,c2) ->
        Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
    | t1,t2 -> 
@@ -577,7 +593,7 @@ let shrink_pair f1 f2 =
 
 let reduce_factor = function
    Oatom v ->
-     let r = Omult(Oatom v,Oint 1) in
+     let r = Omult(Oatom v,Oint one) in
        [Lazy.force coq_c_red0],r
   | Omult(Oatom v,Oint n) as f -> [],f
   | Omult(Oatom v,c) ->
@@ -588,7 +604,7 @@ let reduce_factor = function
 	[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
   | t -> Util.error "reduce_factor.1"
 
-(* \subsection{Réordonancement} *)
+(* \subsection{Réordonnancement} *)
 
 let rec condense env = function
     Oplus(f1,(Oplus(f2,r) as t)) ->
@@ -602,7 +618,7 @@ let rec condense env = function
 	let tac',t' = condense env t in 
 	[do_both (do_list tac) (do_list tac')], Oplus(f,t') 
       end
-  | (Oplus(f1,Oint n) as t) -> 
+  | Oplus(f1,Oint n) -> 
       let tac,f1' = reduce_factor f1 in 
       [do_left (do_list tac)],Oplus(f1',Oint n)
   | Oplus(f1,f2) -> 
@@ -618,13 +634,13 @@ let rec condense env = function
   | (Oint _ as t)-> [],t
   | t -> 
       let tac,t' = reduce_factor t in
-      let final = Oplus(t',Oint 0) in
+      let final = Oplus(t',Oint zero) in
       tac @ [Lazy.force coq_c_red6], final
 
 (* \subsection{Elimination des zéros} *)
 
 let rec clear_zero = function
-   Oplus(Omult(Oatom v,Oint 0),r) ->
+   Oplus(Omult(Oatom v,Oint n),r) when n=zero ->
      let tac',t = clear_zero r in
      Lazy.force coq_c_red5 :: tac',t
   | Oplus(f,r) -> 
@@ -652,7 +668,7 @@ let rec reduce env = function
 	  t', do_list [do_both trace1 trace2; tac]
       | (Oint n,_) ->
 	  let tac,t' = scalar n t2' in
-	  t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_sym; tac]
+	  t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac]
       | _ -> Oufo t, Lazy.force coq_c_nop
       end
   | Oopp t ->
@@ -681,25 +697,36 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) =
       e_origin = { o_hyp = origin; o_path = List.rev path };
       e_trace = trace; e_omega = equa } in
   try match (if negated then (negate_oper oper) else oper) with
-    | Eq  -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) Omega2.EQUA
-    | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) Omega2.DISE
-    | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) Omega2.INEQ
-    | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) Omega2.INEQ
+    | Eq  -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA
+    | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE
+    | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ
+    | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ
     | Lt  ->
-        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint (-1)),Oopp o1))
-	  Omega2.INEQ
+        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1))
+	  INEQ
     | Gt ->
-        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint (-1)),Oopp o2)) 
-	  Omega2.INEQ
+        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) 
+	  INEQ
   with e when Logic.catchable_exception e -> raise e
 
 (* \section{Compilation des hypothèses} *)
 
+let is_scalar t =
+  let rec aux t = match destructurate t with
+    | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2
+    | Kapp(("Zopp"|"Zsucc"),[t]) -> aux t
+    | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize_number t in true
+    | _ -> false in
+  try aux t with _ -> false
+
 let rec oformula_of_constr env t =
   try match destructurate t with
   | Kapp("Zplus",[t1;t2]) -> binop env (fun x y -> Oplus(x,y)) t1 t2
-  | Kapp("Zminus",[t1;t2]) ->binop env (fun x y -> Ominus(x,y)) t1 t2
-  | Kapp("Zmult",[t1;t2]) ->binop env (fun x y -> Omult(x,y)) t1 t2
+  | Kapp("Zminus",[t1;t2]) -> binop env (fun x y -> Ominus(x,y)) t1 t2
+  | Kapp("Zmult",[t1;t2]) when is_scalar t1 or is_scalar t2 ->
+      binop env (fun x y -> Omult(x,y)) t1 t2
+  | Kapp("Zopp",[t]) -> Oopp(oformula_of_constr env t)
+  | Kapp("Zsucc",[t]) -> Oplus(oformula_of_constr env t, Oint one)
   | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> 
       begin try Oint(recognize_number t)
       with _ -> Oatom (add_reified_atom t env) end
@@ -715,7 +742,7 @@ and  binop env c t1 t2 =
 
 and  binprop env (neg2,depends,origin,path) 
              add_to_depends neg1 gl c t1 t2 =
-  let i = new_eq_id env in
+  let i = new_connector_id env in
   let depends1 = if add_to_depends then Left i::depends else depends in
   let depends2 = if add_to_depends then Right i::depends else depends in
   if add_to_depends then
@@ -775,13 +802,14 @@ let reify_gl env gl =
   let t_concl =
     Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in
   if !debug then begin
-    Printf.printf "CONCL: "; pprint stdout t_concl; Printf.printf "\n"
+    Printf.printf "REIFED PROBLEM\n\n";
+    Printf.printf "  CONCL: "; pprint stdout t_concl; Printf.printf "\n"
   end;
   let rec loop = function
       (i,t) :: lhyps ->
 	let t' = oproposition_of_constr env (false,[],i,[]) gl t in
 	if !debug then begin
-	  Printf.printf "%s: " (Names.string_of_id i);
+	  Printf.printf "  %s: " (Names.string_of_id i);
 	  pprint stdout t';
 	  Printf.printf "\n"
 	end;
@@ -859,11 +887,11 @@ let display_depend = function
 
 let display_systems syst_list = 
   let display_omega om_e = 
-    Printf.printf "%d : %a %s 0\n"
-      om_e.Omega2.id
-      (fun _ -> Omega2.display_eq display_omega_id) 
-      (om_e.Omega2.body, om_e.Omega2.constant)
-      (Omega2.operator_of_eq om_e.Omega2.kind) in
+    Printf.printf "  E%d : %a %s 0\n"
+      om_e.id
+      (fun _ -> display_eq display_omega_var) 
+      (om_e.body, om_e.constant)
+      (operator_of_eq om_e.kind) in
 
   let display_equation oformula_eq = 
     pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline ();
@@ -874,12 +902,12 @@ let display_systems syst_list =
       (String.concat ""
 	 (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M")
 	    oformula_eq.e_origin.o_path));
-    Printf.printf "\n  Origin: %s -- Negated : %s\n"
+    Printf.printf "\n  Origin: %s (negated : %s)\n\n"
       (Names.string_of_id oformula_eq.e_origin.o_hyp)
-      (if oformula_eq.e_negated then "yes" else "false") in
+      (if oformula_eq.e_negated then "yes" else "no") in
 
   let display_system syst =
-    Printf.printf "=SYSTEME==================================\n";
+    Printf.printf "=SYSTEM===================================\n";
     List.iter display_equation syst in
   List.iter display_system syst_list
 
@@ -889,8 +917,8 @@ let display_systems syst_list =
 let rec hyps_used_in_trace = function
   | act :: l -> 
       begin match act with
-	| Omega2.HYP e -> e.Omega2.id :: hyps_used_in_trace l
-	| Omega2.SPLIT_INEQ (_,(_,act1),(_,act2)) -> 
+	| HYP e -> e.id :: hyps_used_in_trace l
+	| SPLIT_INEQ (_,(_,act1),(_,act2)) -> 
 	    hyps_used_in_trace act1 @ hyps_used_in_trace act2
 	| _ -> hyps_used_in_trace l
       end
@@ -903,11 +931,11 @@ let rec hyps_used_in_trace = function
 let rec variable_stated_in_trace = function
   | act :: l -> 
       begin match act with
-	| Omega2.STATE action ->
+	| STATE action ->
 	    (*i nlle_equa: afine, def: afine, eq_orig: afine, i*)
             (*i coef: int, var:int                            i*)
 	    action :: variable_stated_in_trace l
-	| Omega2.SPLIT_INEQ (_,(_,act1),(_,act2)) -> 
+	| SPLIT_INEQ (_,(_,act1),(_,act2)) -> 
 	    variable_stated_in_trace act1 @ variable_stated_in_trace act2
 	| _ -> variable_stated_in_trace l
       end
@@ -922,10 +950,10 @@ let add_stated_equations env tree =
   (* Il faut trier les variables par ordre d'introduction pour ne pas risquer
      de définir dans le mauvais ordre *)
   let stated_equations = 
-    List.sort (fun x y -> x.Omega2.st_var - y.Omega2.st_var) (loop tree) in
+    List.sort (fun x y -> Pervasives.(-) x.st_var y.st_var) (loop tree) in
   let add_env st = 
     (* On retransforme la définition de v en formule reifiée *)
-    let v_def = oformula_of_omega env st.Omega2.st_def in
+    let v_def = oformula_of_omega env st.st_def in
     (* Notez que si l'ordre de création des variables n'est pas respecté, 
      * ca va planter *)
     let coq_v = coq_of_formula env v_def in
@@ -936,8 +964,8 @@ let add_stated_equations env tree =
      * l'environnement pour le faire correctement *)
     let term_to_reify = (v_def,Oatom v) in
     (* enregistre le lien entre la variable omega et la variable Coq *)
-    intern_omega_force env (Oatom v) st.Omega2.st_var; 
-    (v, term_to_generalize,term_to_reify,st.Omega2.st_def.Omega2.id) in
+    intern_omega_force env (Oatom v) st.st_var; 
+    (v, term_to_generalize,term_to_reify,st.st_def.id) in
  List.map add_env stated_equations
 
 (* Calcule la liste des éclatements à réaliser sur les hypothèses 
@@ -950,7 +978,7 @@ let rec get_eclatement env = function
   | [] -> []
 
 let select_smaller l = 
-  let comp (_,x) (_,y) = List.length x - List.length y in
+  let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in
   try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller"
 
 let filter_compatible_systems required systems =
@@ -968,11 +996,15 @@ let rec equas_of_solution_tree = function
   | Leaf s -> s.s_equa_deps
 
 
+(* Because of really_useful_prop, decidable formulas such as Pfalse
+   and Ptrue are moved to Pprop, thus breaking the decidability check
+   in ReflOmegaCore.concl_to_hyp... *)
+
 let really_useful_prop l_equa c =
   let rec real_of = function
       Pequa(t,_) -> t
-    | Ptrue ->  app  coq_true [||]
-    | Pfalse -> app  coq_false [||]
+    | Ptrue ->  app  coq_True [||]
+    | Pfalse -> app  coq_False [||]
     | Pnot t1 -> app coq_not [|real_of t1|]
     | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|]
     | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|]
@@ -982,7 +1014,7 @@ let really_useful_prop l_equa c =
   let rec loop c = 
     match c with 
       Pequa(_,e) ->
-	if List.mem e.e_omega.Omega2.id l_equa then Some c else None
+	if List.mem e.e_omega.id l_equa then Some c else None
     | Ptrue -> None
     | Pfalse -> None
     | Pnot t1 -> 
@@ -1041,9 +1073,9 @@ let find_path {o_hyp=id;o_path=p} env =
       CCHyp{o_hyp=id';o_path=p'} :: l when id = id' ->
 	begin match loop_path (p',p) with
 	  Some r -> i,r
-	| None -> loop_id (i+1) l
+	| None -> loop_id (succ i) l
 	end
-    | _ :: l -> loop_id (i+1) l
+    | _ :: l -> loop_id (succ i) l
     | [] -> failwith "find_path" in
   loop_id 0 env
 
@@ -1062,59 +1094,59 @@ let get_hyp env_hyp i =
 let replay_history env env_hyp =
   let rec loop env_hyp t =
     match t with
-      | Omega2.CONTRADICTION (e1,e2) :: l -> 
-	  let trace = mk_nat (List.length e1.Omega2.body) in
+      | CONTRADICTION (e1,e2) :: l -> 
+	  let trace = mk_nat (List.length e1.body) in
 	  mkApp (Lazy.force coq_s_contradiction,
-		 [| trace ; mk_nat (get_hyp env_hyp e1.Omega2.id); 
-		    mk_nat (get_hyp env_hyp e2.Omega2.id) |])
-      | Omega2.DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
+		 [| trace ; mk_nat (get_hyp env_hyp e1.id); 
+		    mk_nat (get_hyp env_hyp e2.id) |])
+      | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
 	  mkApp (Lazy.force coq_s_div_approx,
 		 [| mk_Z k; mk_Z d; 
-		    reified_of_omega env e2.Omega2.body e2.Omega2.constant;
-		    mk_nat (List.length e2.Omega2.body); 
-		    loop env_hyp l; mk_nat (get_hyp env_hyp e1.Omega2.id) |])
-      | Omega2.NOT_EXACT_DIVIDE (e1,k) :: l ->
-	  let e2_constant = Omega2.floor_div e1.Omega2.constant k in
-	  let d = e1.Omega2.constant - e2_constant * k in
-	  let e2_body = Omega2.map_eq_linear (fun c -> c / k) e1.Omega2.body in
+		    reified_of_omega env e2.body e2.constant;
+		    mk_nat (List.length e2.body); 
+		    loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |])
+      | NOT_EXACT_DIVIDE (e1,k) :: l ->
+	  let e2_constant = floor_div e1.constant k in
+	  let d = e1.constant - e2_constant * k in
+	  let e2_body = map_eq_linear (fun c -> c / k) e1.body in
           mkApp (Lazy.force coq_s_not_exact_divide,
 		 [|mk_Z k; mk_Z d; 
 		   reified_of_omega env e2_body e2_constant; 
 		   mk_nat (List.length e2_body); 
-		   mk_nat (get_hyp env_hyp e1.Omega2.id)|])
-      | Omega2.EXACT_DIVIDE (e1,k) :: l ->
+		   mk_nat (get_hyp env_hyp e1.id)|])
+      | EXACT_DIVIDE (e1,k) :: l ->
 	  let e2_body =  
-	    Omega2.map_eq_linear (fun c -> c / k) e1.Omega2.body in
-	  let e2_constant = Omega2.floor_div e1.Omega2.constant k in
+	    map_eq_linear (fun c -> c / k) e1.body in
+	  let e2_constant = floor_div e1.constant k in
           mkApp (Lazy.force coq_s_exact_divide,
 		 [|mk_Z k; 
 		   reified_of_omega env e2_body e2_constant; 
 		   mk_nat (List.length e2_body);
-		   loop env_hyp l; mk_nat (get_hyp env_hyp e1.Omega2.id)|])
-      | (Omega2.MERGE_EQ(e3,e1,e2)) :: l ->
-	  let n1 = get_hyp env_hyp e1.Omega2.id and n2 = get_hyp env_hyp e2 in
+		   loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|])
+      | (MERGE_EQ(e3,e1,e2)) :: l ->
+	  let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in
           mkApp (Lazy.force coq_s_merge_eq,
-		 [| mk_nat (List.length e1.Omega2.body);
+		 [| mk_nat (List.length e1.body);
 		    mk_nat n1; mk_nat n2;
 		    loop (CCEqua e3:: env_hyp) l |])
-      | Omega2.SUM(e3,(k1,e1),(k2,e2)) :: l ->
-	  let n1 = get_hyp env_hyp e1.Omega2.id 
-	  and n2 = get_hyp env_hyp e2.Omega2.id in
-	  let trace = shuffle_path k1 e1.Omega2.body k2 e2.Omega2.body in
+      | SUM(e3,(k1,e1),(k2,e2)) :: l ->
+	  let n1 = get_hyp env_hyp e1.id 
+	  and n2 = get_hyp env_hyp e2.id in
+	  let trace = shuffle_path k1 e1.body k2 e2.body in
           mkApp (Lazy.force coq_s_sum,
 		 [| mk_Z k1; mk_nat n1; mk_Z k2;
 		    mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |])
-      | Omega2.CONSTANT_NOT_NUL(e,k) :: l -> 
+      | CONSTANT_NOT_NUL(e,k) :: l -> 
           mkApp (Lazy.force coq_s_constant_not_nul,
 		 [|  mk_nat (get_hyp env_hyp e) |])
-      | Omega2.CONSTANT_NEG(e,k) :: l ->
+      | CONSTANT_NEG(e,k) :: l ->
           mkApp (Lazy.force coq_s_constant_neg,
 		 [|  mk_nat (get_hyp env_hyp e) |])
-      | Omega2.STATE {Omega2.st_new_eq=new_eq; Omega2.st_def =def; 
-		      Omega2.st_orig=orig; Omega2.st_coef=m;
-                      Omega2.st_var=sigma } :: l ->
-	  let n1 = get_hyp env_hyp orig.Omega2.id 
-	  and n2 = get_hyp env_hyp def.Omega2.id in
+      | STATE {st_new_eq=new_eq; st_def =def; 
+		      st_orig=orig; st_coef=m;
+                      st_var=sigma } :: l ->
+	  let n1 = get_hyp env_hyp orig.id 
+	  and n2 = get_hyp env_hyp def.id in
 	  let v = unintern_omega env sigma in
 	  let o_def = oformula_of_omega env def in
 	  let o_orig = oformula_of_omega env orig in
@@ -1123,24 +1155,24 @@ let replay_history env env_hyp =
           let trace,_ = normalize_linear_term env body in
 	  mkApp (Lazy.force coq_s_state,
 		 [| mk_Z m; trace; mk_nat n1; mk_nat n2; 
-		    loop (CCEqua new_eq.Omega2.id :: env_hyp) l |])
-      |	Omega2.HYP _ :: l -> loop env_hyp l
-      |	Omega2.CONSTANT_NUL e :: l ->
+		    loop (CCEqua new_eq.id :: env_hyp) l |])
+      |	HYP _ :: l -> loop env_hyp l
+      |	CONSTANT_NUL e :: l ->
 	  mkApp (Lazy.force coq_s_constant_nul, 
 		 [|  mk_nat (get_hyp env_hyp e) |])
-      |	Omega2.NEGATE_CONTRADICT(e1,e2,b) :: l ->
+      |	NEGATE_CONTRADICT(e1,e2,b) :: l ->
 	  mkApp (Lazy.force coq_s_negate_contradict, 
-		 [|  mk_nat (get_hyp env_hyp e1.Omega2.id);
-		     mk_nat (get_hyp env_hyp e2.Omega2.id) |])
-      | Omega2.SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l ->
-	  let i =  get_hyp env_hyp e.Omega2.id in
+		 [|  mk_nat (get_hyp env_hyp e1.id);
+		     mk_nat (get_hyp env_hyp e2.id) |])
+      | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l ->
+	  let i =  get_hyp env_hyp e.id in
 	  let r1 = loop (CCEqua e1 :: env_hyp) l1 in
 	  let r2 = loop (CCEqua e2 :: env_hyp) l2 in
 	  mkApp (Lazy.force coq_s_split_ineq, 
-                  [| mk_nat (List.length e.Omega2.body); mk_nat i; r1 ; r2 |])
-      |	(Omega2.FORGET_C _ | Omega2.FORGET _ | Omega2.FORGET_I _) :: l ->
+                  [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |])
+      |	(FORGET_C _ | FORGET _ | FORGET_I _) :: l ->
 	  loop env_hyp l
-      | (Omega2.WEAKEN  _ ) :: l -> failwith "not_treated"
+      | (WEAKEN  _ ) :: l -> failwith "not_treated"
       |	[] -> failwith "no contradiction"
   in loop env_hyp
 
@@ -1171,7 +1203,7 @@ and decompose_tree_hyps trace env ctxt = function
       let full_path = if equation.e_negated then path @ [O_mono] else path in
       let cont = 
 	decompose_tree_hyps trace env 
-	   (CCEqua equation.e_omega.Omega2.id :: ctxt) l in
+	   (CCEqua equation.e_omega.id :: ctxt) l in
       app coq_e_extract [|mk_nat index;
 			  mk_direction_list full_path;
 			  cont |]
@@ -1190,15 +1222,15 @@ let resolution env full_reified_goal systems_list =
     let index = !num in
     let system = List.map (fun eq -> eq.e_omega) list_eq in
     let trace = 
-      Omega2.simplify_strong 
-	((fun () -> new_eq_id env),new_omega_id,display_omega_id) 
+      simplify_strong 
+	(new_omega_eq,new_omega_var,display_omega_var) 
 	system in 
     (* calcule les hypotheses utilisées pour la solution *)
     let vars = hyps_used_in_trace trace in
     let splits = get_eclatement env vars in
     if !debug then begin
       Printf.printf "SYSTEME %d\n" index;
-      Omega2.display_action display_omega_id trace;
+      display_action display_omega_var trace;
       print_string "\n  Depend :";
       List.iter (fun i -> Printf.printf " %d" i) vars;
       print_string "\n  Split points :";
@@ -1236,7 +1268,7 @@ let resolution env full_reified_goal systems_list =
     let rec loop i = function
 	var :: l -> 
 	  let t = get_reified_atom env var in 
-	  Hashtbl.add env.real_indices var i; t :: loop (i+1) l
+	  Hashtbl.add env.real_indices var i; t :: loop (succ i) l
       |	[] -> [] in
     loop 0 all_vars_env in
   let env_terms_reified = mk_list (Lazy.force coq_Z) basic_env in
@@ -1262,7 +1294,7 @@ let resolution env full_reified_goal systems_list =
             (l_reified_stated @ l_reified_terms) in
   let reified = 
     app coq_interp_sequent 
-       [| env_props_reified;env_terms_reified;reified_concl;reified_goal |] in
+       [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in
   let normalize_equation e = 
     let rec loop = function
 	[] -> app (if e.e_negated then coq_p_invert else coq_p_step)
@@ -1286,20 +1318,26 @@ let resolution env full_reified_goal systems_list =
   Tactics.change_in_concl None reified >> 
   Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >>
   show_goal >>
-  Tactics.normalise_in_concl >>
+  Tactics.normalise_vm_in_concl >>
+  (*i Alternatives to the previous line: 
+   - Normalisation without VM: 
+      Tactics.normalise_in_concl
+   - Skip the conversion check and rely directly on the QED: 
+      Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> 
+  i*)
   Tactics.apply (Lazy.force coq_I)
 
 let total_reflexive_omega_tactic gl = 
-  if !Options.v7 then Util.error "ROmega does not work in v7 mode";
+  Coqlib.check_required_library ["Coq";"romega";"ROmega"];
+  rst_omega_eq (); 
+  rst_omega_var ();
   try
   let env = new_environment () in
   let full_reified_goal = reify_gl env gl in
   let systems_list = destructurate_hyps full_reified_goal in
-  if !debug then begin 
-    display_systems systems_list
-  end;
+  if !debug then display_systems systems_list;
   resolution env full_reified_goal systems_list gl
-  with Omega2.NO_CONTRADICTION -> Util.error "ROmega can't solve this system"
+  with NO_CONTRADICTION -> Util.error "ROmega can't solve this system"
 
 
 (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*)
diff --git a/contrib/rtauto/Bintree.v b/contrib/rtauto/Bintree.v
new file mode 100644
index 00000000..f4b24d4b
--- /dev/null
+++ b/contrib/rtauto/Bintree.v
@@ -0,0 +1,498 @@
+(************************************************************************)
+(*  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: Bintree.v 8881 2006-05-31 18:16:34Z jforest $ *)
+
+Require Export List.
+Require Export BinPos.
+
+Unset Boxed Definitions.
+
+Open Scope positive_scope.
+
+Ltac clean := try (simpl; congruence). 
+Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
+
+Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop.
+
+Lemma Prect : forall P : positive -> Type,
+       P 1 ->
+       (forall n : positive, P n -> P (Psucc n)) -> forall p : positive, P p.
+intros P H1 Hsucc n; induction n.
+rewrite <- plus_iter_xI; apply Hsucc; apply iterate_add; assumption.
+rewrite <- plus_iter_xO; apply iterate_add; assumption.
+assumption.
+Qed.
+
+Lemma Gt_Eq_Gt : forall p q cmp,
+       (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt.
+apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt));
+simpl;auto;congruence.
+Qed.
+
+Lemma Gt_Lt_Gt : forall p q cmp,
+       (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt.
+apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt));
+simpl;auto;congruence.
+Qed.
+
+Lemma Gt_Psucc_Eq: forall p q,
+  (p ?= Psucc q) Gt = Gt -> (p ?= q) Eq = Gt.
+intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
+intro;apply Gt_Eq_Gt;auto.
+apply Gt_Lt_Gt.
+Qed.
+
+Lemma Eq_Psucc_Gt: forall p q,
+  (p ?= Psucc q) Eq = Eq -> (p ?= q) Eq = Gt.
+intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
+intro H;elim (Pcompare_not_Eq p (Psucc q));tauto.
+intro H;apply Gt_Eq_Gt;auto.
+intro H;rewrite Pcompare_Eq_eq with p q;auto.
+generalize q;clear q IHq p H;induction q;simpl;auto.
+intro H;elim (Pcompare_not_Eq p q);tauto.
+Qed.
+
+Lemma Gt_Psucc_Gt : forall n p cmp cmp0,
+ (n?=p) cmp = Gt -> (Psucc n?=p) cmp0 = Gt.
+induction n;intros [ | p | p];simpl;try congruence.
+intros; apply IHn with cmp;trivial.
+intros; apply IHn with Gt;trivial.
+intros;apply Gt_Lt_Gt;trivial.
+intros [ | | ] _ H.
+apply Gt_Eq_Gt;trivial.
+apply Gt_Lt_Gt;trivial.
+trivial.
+Qed.
+
+Lemma Gt_Psucc: forall p q,
+       (p ?= Psucc q) Eq = Gt -> (p ?= q) Eq = Gt.
+intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
+apply Gt_Psucc_Eq.
+intro;apply Gt_Eq_Gt;apply IHq;auto.
+apply Gt_Eq_Gt.
+apply Gt_Lt_Gt.
+Qed.
+
+Lemma Psucc_Gt : forall p,
+       (Psucc p ?= p) Eq = Gt.
+induction p;simpl.
+apply Gt_Eq_Gt;auto.
+generalize p;clear p IHp.
+induction p;simpl;auto.
+reflexivity.
+Qed.
+
+Fixpoint pos_eq (m n:positive) {struct m} :bool :=
+match m, n with
+  xI mm, xI nn => pos_eq mm nn
+| xO mm, xO nn => pos_eq mm nn
+| xH, xH => true
+| _, _ => false
+end. 
+
+Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
+induction m;simpl;intro n;destruct n;congruence ||
+(intro e;apply f_equal with positive;auto).
+Defined.
+
+Theorem refl_pos_eq : forall m, pos_eq m m = true.
+induction m;simpl;auto.
+Qed.
+
+Definition pos_eq_dec (m n:positive) :{m=n}+{m<>n} .
+fix 1;intros [mm|mm|] [nn|nn|];try (right;congruence).
+case (pos_eq_dec mm nn).
+intro e;left;apply (f_equal xI e).
+intro ne;right;congruence.
+case (pos_eq_dec mm nn).
+intro e;left;apply (f_equal xO e).
+intro ne;right;congruence.
+left;reflexivity.
+Defined.
+
+Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left (m<>m) (refl_equal m) .
+fix 1;intros [mm|mm|].
+simpl; rewrite  pos_eq_dec_refl; reflexivity.
+simpl; rewrite  pos_eq_dec_refl; reflexivity.
+reflexivity.
+Qed.
+
+Theorem pos_eq_dec_ex : forall m n,
+ pos_eq m n =true -> exists h:m=n,
+ pos_eq_dec m n = left (m<>n) h.
+fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence).
+simpl;intro e.
+elim (pos_eq_dec_ex _ _ e).
+intros x ex; rewrite ex. 
+exists (f_equal xI x).
+reflexivity.
+simpl;intro e.
+elim (pos_eq_dec_ex _ _ e).
+intros x ex; rewrite ex. 
+exists (f_equal xO x).
+reflexivity.
+simpl.
+exists (refl_equal xH).
+reflexivity.
+Qed.
+
+Fixpoint nat_eq (m n:nat) {struct m}: bool:=
+match m, n with 
+O,O => true
+| S mm,S nn => nat_eq mm nn
+| _,_ => false
+end.
+
+Theorem nat_eq_refl : forall m n, nat_eq m n = true -> m = n.
+induction m;simpl;intro n;destruct n;congruence ||
+(intro e;apply f_equal with nat;auto).
+Defined.
+
+Theorem refl_nat_eq : forall n, nat_eq n n = true.
+induction n;simpl;trivial.
+Defined.
+
+Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A :=
+match l with nil => None
+| x::q => 
+match n with O => Some x
+| S m => Lget A m q
+end end .
+
+Implicit Arguments Lget [A].
+
+Lemma map_app : forall (A B:Set) (f:A -> B) l m, 
+List.map  f (l ++ m) = List.map  f  l ++ List.map  f  m.
+induction l.
+reflexivity.
+simpl.
+intro m ; apply f_equal with (list B);apply IHl.
+Qed.
+
+Lemma length_map : forall (A B:Set) (f:A -> B) l, 
+length (List.map  f l) = length l.
+induction l.
+reflexivity.
+simpl; apply f_equal with nat;apply IHl.
+Qed.
+
+Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, 
+Lget i (List.map  f l) = 
+match Lget i l with Some a => 
+Some (f a) | None => None end.
+induction i;intros [ | x l ] ;trivial.
+simpl;auto.
+Qed.
+
+Lemma Lget_app : forall (A:Set) (a:A) l i,
+Lget i (l ++ a :: nil) = if nat_eq i (length l) then Some a else Lget i l.
+induction l;simpl Lget;simpl length.
+intros [ | i];simpl;reflexivity.
+intros [ | i];simpl.
+reflexivity.
+auto.
+Qed.
+
+Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), 
+Lget i l = Some a ->
+Lget i (l ++ delta) = Some a.
+induction l;destruct i;simpl;try congruence;auto.
+Qed.
+
+Section Store.
+
+Variable A:Type.
+
+Inductive Poption : Type:=
+  PSome : A -> Poption
+| PNone : Poption.
+
+Inductive Tree : Type :=
+   Tempty : Tree
+ | Branch0 : Tree -> Tree -> Tree
+ | Branch1 : A -> Tree -> Tree -> Tree.
+        
+Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := 
+  match T with
+    Tempty => PNone
+  | Branch0 T1 T2 =>
+    match p with
+      xI pp => Tget pp T2
+    | xO pp => Tget pp T1
+    | xH => PNone
+    end
+  | Branch1 a T1 T2 =>
+    match p with
+      xI pp => Tget pp T2
+    | xO pp => Tget pp T1
+    | xH => PSome a
+    end
+end.
+
+Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := 
+ match T with
+   | Tempty =>
+       match p with
+       | xI pp => Branch0 Tempty (Tadd pp a Tempty)
+       | xO pp => Branch0 (Tadd pp a Tempty) Tempty
+       | xH => Branch1 a Tempty Tempty
+       end
+   | Branch0 T1 T2 =>
+       match p with
+       | xI pp => Branch0 T1 (Tadd pp a T2)
+       | xO pp => Branch0 (Tadd pp a T1) T2
+       | xH => Branch1 a T1 T2
+       end
+   | Branch1 b T1 T2 =>
+       match p with
+       | xI pp => Branch1 b T1 (Tadd pp a T2)
+       | xO pp => Branch1 b (Tadd pp a T1) T2
+       | xH => Branch1 a T1 T2
+       end
+   end.
+
+Definition mkBranch0 (T1 T2:Tree) :=
+  match T1,T2 with
+    Tempty ,Tempty => Tempty
+  | _,_ => Branch0 T1 T2
+  end.
+  
+Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree :=
+   match T with
+      | Tempty => Tempty
+      | Branch0 T1 T2 => 
+        match p with
+        | xI pp => mkBranch0 T1 (Tremove pp T2)                  
+        | xO pp => mkBranch0 (Tremove pp T1) T2
+        | xH => T
+        end
+      | Branch1 b T1 T2 =>
+        match p with
+        | xI pp => Branch1 b T1 (Tremove pp T2)
+        | xO pp => Branch1 b (Tremove pp T1) T2
+        | xH => mkBranch0 T1 T2
+        end
+      end.
+                                                                                                                        
+ 
+Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone.
+destruct p;reflexivity.
+Qed.
+
+Theorem Tget_Tadd: forall i j a T,
+       Tget i (Tadd j a T) =
+       match (i ?= j) Eq with
+         Eq => PSome a
+       | Lt => Tget i T
+       | Gt => Tget i T
+       end.
+intros i j.
+caseq ((i ?= j) Eq).
+intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H.
+induction j;destruct T;simpl;try (apply IHj);congruence.
+generalize i;clear i;induction j;destruct T;simpl in H|-*;
+destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
+generalize i;clear i;induction j;destruct T;simpl in H|-*;
+destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
+Qed.
+
+Record Store : Type :=  
+mkStore  {index:positive;contents:Tree}.
+
+Definition empty := mkStore xH Tempty.
+
+Definition push a  S :=
+mkStore (Psucc (index S)) (Tadd (index S) a (contents S)).
+
+Definition get i S := Tget i (contents S).
+
+Lemma get_empty : forall i, get i empty = PNone.
+intro i; case i; unfold empty,get; simpl;reflexivity.
+Qed.
+
+Inductive Full : Store -> Type:=
+    F_empty : Full empty
+  | F_push : forall a S, Full S -> Full (push a S).
+
+Theorem get_Full_Gt : forall S, Full S ->
+       forall i, (i ?= index S) Eq = Gt -> get i S = PNone.
+intros S W;induction W.
+unfold empty,index,get,contents;intros;apply Tget_Tempty.
+unfold index,get,push;simpl contents.
+intros i e;rewrite Tget_Tadd.
+rewrite (Gt_Psucc _ _ e). 
+unfold get in IHW.
+apply IHW;apply Gt_Psucc;assumption.
+Qed.
+
+Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone.
+intros [index0 contents0] F.
+case F.
+unfold empty,index,get,contents;intros;apply Tget_Tempty.
+unfold index,get,push;simpl contents.
+intros a S.
+rewrite Tget_Tadd.
+rewrite Psucc_Gt.
+intro W.
+change (get (Psucc (index S)) S =PNone).
+apply get_Full_Gt; auto.
+apply Psucc_Gt.
+Qed.
+
+Theorem get_push_Full : 
+  forall i a S, Full S -> 
+  get i (push a S) =
+  match (i ?= index S) Eq with
+    Eq => PSome a
+  | Lt => get i S
+  | Gt => PNone
+end.
+intros i a S F.
+caseq ((i ?= index S) Eq).
+intro e;rewrite (Pcompare_Eq_eq _ _ e).
+destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
+rewrite Pcompare_refl;reflexivity.
+intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
+simpl index in H;rewrite H;reflexivity.
+intro H;generalize H;clear H.
+unfold get,push;simpl index;simpl contents.
+rewrite Tget_Tadd;intro e;rewrite e.
+change (get i S=PNone).
+apply get_Full_Gt;auto.
+Qed.
+
+Lemma Full_push_compat : forall i a S, Full S ->
+forall x, get i S = PSome x -> 
+ get i (push a S) = PSome x.
+intros i a S F x H. 
+caseq ((i ?= index S) Eq);intro test.
+rewrite (Pcompare_Eq_eq _ _ test) in H.
+rewrite (get_Full_Eq _ F) in H;congruence.
+rewrite <- H.
+rewrite (get_push_Full i a).
+rewrite test;reflexivity.
+assumption.
+rewrite (get_Full_Gt _ F) in H;congruence.
+Qed.
+
+Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. 
+intros [ind cont] F one; inversion F.
+reflexivity.
+simpl index in one;assert (h:=Psucc_not_one (index S)).
+congruence.
+Qed.
+
+Lemma push_not_empty: forall a S, (push a S) <> empty.
+intros a [ind cont];unfold push,empty.
+simpl;intro H;injection H; intros _ ; apply Psucc_not_one.
+Qed. 
+
+Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
+match F with
+F_empty => False
+| F_push a SS FF => x=a \/ In x SS FF
+end.
+
+Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , 
+get i S = PSome x -> In x S F.
+induction F.
+intro i;rewrite get_empty; congruence.
+intro i;rewrite get_push_Full;trivial.
+caseq ((i ?= index S) Eq);simpl.
+left;congruence.
+right;eauto.
+congruence.
+Qed.
+
+End Store.
+
+Implicit Arguments PNone [A].
+Implicit Arguments PSome [A].
+
+Implicit Arguments Tempty [A].
+Implicit Arguments Branch0 [A].
+Implicit Arguments Branch1 [A].
+
+Implicit Arguments Tget [A].
+Implicit Arguments Tadd [A].
+
+Implicit Arguments Tget_Tempty [A].
+Implicit Arguments Tget_Tadd [A].
+
+Implicit Arguments mkStore [A].
+Implicit Arguments index [A].
+Implicit Arguments contents [A].
+
+Implicit Arguments empty [A].
+Implicit Arguments get [A].
+Implicit Arguments push [A].
+
+Implicit Arguments get_empty [A].
+Implicit Arguments get_push_Full [A].
+
+Implicit Arguments Full [A].
+Implicit Arguments F_empty [A].
+Implicit Arguments F_push [A].
+Implicit Arguments In [A].
+
+Section Map. 
+
+Variables A B:Set.
+
+Variable f: A -> B.
+
+Fixpoint Tmap (T: Tree A) : Tree B :=
+match T with
+Tempty => Tempty
+| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2)
+| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2)
+end.
+
+Lemma Tget_Tmap: forall T i, 
+Tget i (Tmap T)= match Tget i T with PNone => PNone 
+| PSome a => PSome (f a) end.
+induction T;intro i;case i;simpl;auto.
+Defined.
+
+Lemma Tmap_Tadd: forall i a T,
+Tmap (Tadd i a T) = Tadd i (f a) (Tmap T).
+induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity.
+Defined.
+
+Definition map (S:Store A) : Store B :=
+mkStore (index S) (Tmap (contents S)).
+
+Lemma get_map: forall i S, 
+get i (map S)= match get i S with PNone => PNone 
+| PSome a => PSome (f a) end.
+destruct S;unfold get,map,contents,index;apply Tget_Tmap.
+Defined.
+
+Lemma map_push: forall a S, 
+map (push a S) = push (f a) (map S).
+intros a S.
+case S.
+unfold push,map,contents,index.
+intros;rewrite Tmap_Tadd;reflexivity.
+Defined.
+
+Theorem Full_map : forall S, Full S -> Full (map S).
+intros S F. 
+induction F.
+exact F_empty.
+rewrite map_push;constructor 2;assumption.
+Defined.
+
+End Map.
+
+Implicit Arguments Tmap [A B].
+Implicit Arguments map [A B].
+Implicit Arguments Full_map [A B f].
+
+Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).
diff --git a/contrib/rtauto/Rtauto.v b/contrib/rtauto/Rtauto.v
new file mode 100644
index 00000000..98fca90f
--- /dev/null
+++ b/contrib/rtauto/Rtauto.v
@@ -0,0 +1,398 @@
+(************************************************************************)
+(*  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: Rtauto.v 7639 2005-12-02 10:01:15Z gregoire $ *)
+
+
+Require Export List.
+Require Export Bintree.
+Require Import Bool.
+Unset Boxed Definitions.
+
+Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
+Ltac clean:=try (simpl;congruence).
+
+Inductive form:Set:=
+  Atom : positive -> form
+| Arrow : form -> form -> form
+| Bot
+| Conjunct : form -> form -> form 
+| Disjunct : form -> form -> form.
+
+Notation "[ n ]":=(Atom n).
+Notation "A =>> B":= (Arrow A B) (at level 59, right associativity).
+Notation "#" := Bot.
+Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity).
+Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity).
+
+Definition ctx := Store form.
+
+Fixpoint pos_eq (m n:positive) {struct m} :bool :=
+match m with
+  xI mm => match n with xI nn => pos_eq mm nn | _ => false end
+| xO mm => match n with xO nn => pos_eq mm nn | _ => false end
+| xH => match n with xH => true | _ => false end
+end. 
+
+Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
+induction m;simpl;destruct n;congruence ||
+(intro e;apply f_equal with positive;auto).
+Qed.
+
+Fixpoint form_eq (p q:form) {struct p} :bool :=
+match p with
+  Atom m => match q with Atom n => pos_eq m n | _ => false end
+| Arrow p1 p2 => 
+match q with 
+  Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 
+| _ => false end
+| Bot => match q with Bot => true | _ => false end
+| Conjunct p1 p2 => 
+match q with 
+  Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 
+| _ => false 
+end
+| Disjunct p1 p2 => 
+match q with 
+  Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 
+| _ => false 
+end
+end. 
+
+Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q.
+induction p;destruct q;simpl;clean.
+intro h;generalize (pos_eq_refl _ _ h);congruence.
+caseq (form_eq p1 q1);clean.
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
+caseq (form_eq p1 q1);clean.
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
+caseq (form_eq p1 q1);clean.
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. 
+Qed.
+
+Implicit Arguments form_eq_refl [p q].
+
+Section with_env.
+
+Variable env:Store Prop.
+
+Fixpoint interp_form (f:form): Prop :=
+match f with
+[n]=> match get n env with PNone => True | PSome P => P end
+| A =>> B => (interp_form A) -> (interp_form B)
+| # => False
+| A //\\ B => (interp_form A) /\ (interp_form B)
+| A \\// B => (interp_form A) \/ (interp_form B)
+end.
+
+Notation "[[ A ]]" := (interp_form A).
+
+Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop :=
+match F with
+  F_empty => G
+| F_push H hyps0 F0 =>  interp_ctx hyps0 F0  ([[H]] -> G)
+end.
+
+Require Export BinPos.
+
+Ltac wipe := intros;simpl;constructor.  
+
+Lemma compose0 : 
+forall hyps F (A:Prop),
+ A -> 
+ (interp_ctx hyps F A).
+induction F;intros A H;simpl;auto.
+Qed.
+
+Lemma compose1 : 
+forall hyps F (A B:Prop),
+ (A -> B) ->
+ (interp_ctx hyps F A) ->
+ (interp_ctx hyps F B).
+induction F;intros A B H;simpl;auto.
+apply IHF;auto.
+Qed.
+
+Theorem compose2 : 
+forall hyps F (A B C:Prop),
+ (A -> B -> C) -> 
+ (interp_ctx hyps F A) ->
+ (interp_ctx hyps F B) ->
+ (interp_ctx hyps F C).
+induction F;intros A B C H;simpl;auto.
+apply IHF;auto.
+Qed.
+
+Theorem compose3 : 
+forall hyps F (A B C D:Prop),
+ (A -> B -> C -> D) -> 
+ (interp_ctx hyps F A) -> 
+ (interp_ctx hyps F B) ->
+ (interp_ctx hyps F C) ->
+ (interp_ctx hyps F D).
+induction F;intros A B C D H;simpl;auto.
+apply IHF;auto.
+Qed.
+
+Lemma weaken : forall hyps F f G,
+ (interp_ctx hyps F G) ->
+ (interp_ctx (hyps\f)  (F_push f hyps F) G).
+induction F;simpl;intros;auto.
+apply compose1 with ([[a]]-> G);auto.
+Qed.
+
+Theorem project_In : forall hyps F g, 
+In g hyps F ->
+interp_ctx hyps F [[g]].
+induction F;simpl.
+contradiction.
+intros g H;destruct H.
+subst;apply compose0;simpl;trivial.
+apply compose1 with [[g]];auto.
+Qed.
+
+Theorem project : forall hyps F p g, 
+get  p hyps = PSome g->
+interp_ctx hyps F [[g]].
+intros hyps F p g e; apply project_In.
+apply get_In with p;assumption.
+Qed.
+
+Implicit Arguments project [hyps p g].
+
+Inductive proof:Set :=
+  Ax : positive -> proof
+| I_Arrow : proof -> proof
+| E_Arrow : positive -> positive -> proof -> proof
+| D_Arrow : positive -> proof -> proof -> proof
+| E_False : positive -> proof
+| I_And: proof -> proof -> proof
+| E_And: positive -> proof -> proof
+| D_And: positive -> proof -> proof
+| I_Or_l: proof -> proof
+| I_Or_r: proof -> proof
+| E_Or: positive -> proof -> proof -> proof
+| D_Or: positive -> proof -> proof
+| Cut: form -> proof -> proof -> proof.
+
+Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).
+
+Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
+ match P with
+   Ax i => 
+     match get i hyps with
+         PSome F => form_eq F gl
+ | _ => false
+    end 
+| I_Arrow p =>
+   match gl with
+      A  =>> B  => check_proof (hyps \ A) B p
+   | _ => false        
+    end 
+| E_Arrow i j p =>
+   match get i hyps,get j hyps with
+       PSome A,PSome (B =>>C) =>
+         form_eq A B && check_proof (hyps \ C) (gl) p
+    | _,_ => false
+    end
+| D_Arrow i p1 p2 => 
+   match get i hyps with
+      PSome  ((A =>>B)=>>C) =>
+     (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2)
+    | _ => false
+  end
+| E_False i =>
+  match get i hyps with
+    PSome # => true
+  | _ => false
+  end
+| I_And p1 p2 =>
+   match gl with
+      A //\\ B =>
+      check_proof hyps A p1 && check_proof hyps B p2
+      | _ => false
+      end
+| E_And i p => 
+   match get i hyps with
+      PSome  (A //\\ B) => check_proof (hyps \ A \ B) gl p
+    | _=> false
+   end
+| D_And i p => 
+   match get i hyps with
+      PSome  (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p
+    | _=> false
+   end
+| I_Or_l p =>
+   match gl with
+      (A \\// B) => check_proof hyps A p
+      | _ => false
+      end
+| I_Or_r p =>
+   match gl with
+      (A \\// B) => check_proof hyps B p
+      | _ => false
+      end
+| E_Or i p1 p2 =>
+  match get i hyps with
+  PSome (A \\// B) =>
+  check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2
+  | _=> false
+  end
+| D_Or i p => 
+   match get i hyps with
+      PSome  (A \\// B =>> C) =>
+      (check_proof (hyps \ A=>>C \ B=>>C) gl p)
+    | _=> false
+   end
+| Cut A p1 p2 =>
+  check_proof hyps A p1 && check_proof (hyps \ A) gl p2
+end. 
+
+Theorem interp_proof: 
+forall p hyps F gl, 
+check_proof hyps gl p = true -> interp_ctx hyps F [[gl]].
+
+induction p;intros hyps F gl.
+
+(* cas Axiom *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f nth_f e;rewrite <- (form_eq_refl e).
+apply project with p;trivial.
+
+(* Cas Arrow_Intro *)
+Focus 1.
+destruct gl;clean.
+simpl;intros.
+change (interp_ctx (hyps\gl1)  (F_push gl1 hyps F) [[gl2]]).
+apply IHp;try constructor;trivial.
+
+(* Cas Arrow_Elim *)
+Focus 1.
+simpl check_proof;caseq (get p hyps);clean.
+intros f ef;caseq (get p0 hyps);clean.
+intros f0 ef0;destruct f0;clean.
+caseq (form_eq f f0_1);clean.
+simpl;intros e check_p1.
+generalize  (project  F ef) (project  F ef0) 
+(IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
+clear check_p1 IHp p p0 p1 ef ef0.
+simpl.
+apply compose3.
+rewrite (form_eq_refl e).
+auto.
+
+(* cas Arrow_Destruct *)
+Focus 1.
+simpl;caseq (get p1 hyps);clean.
+intros f ef;destruct f;clean.
+destruct f1;clean.
+caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean.
+intros check_p1 check_p2.
+generalize (project F ef)
+(IHp1 (hyps \ f1_2 =>> f2 \ f1_1)   
+(F_push f1_1 (hyps \ f1_2 =>> f2)
+ (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1)
+(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2).
+simpl;apply compose3;auto.
+
+(* Cas False_Elim *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f ef;destruct f;clean.
+intros _; generalize (project F ef).
+apply compose1;apply False_ind.
+
+(* Cas And_Intro *)
+Focus 1.
+simpl;destruct gl;clean.
+caseq (check_proof hyps gl1 p1);clean.
+intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2).
+apply compose2 ;simpl;auto.
+
+(* cas And_Elim *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f ef;destruct f;clean.
+intro check_p;generalize  (project F ef)
+(IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p).
+simpl;apply compose2;intros [h1 h2];auto.
+
+(* cas And_Destruct *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f ef;destruct f;clean.
+destruct f1;clean.
+intro H;generalize  (project F ef)
+(IHp (hyps \ f1_1 =>> f1_2 =>> f2)  
+(F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl.
+apply compose2;auto.
+
+(* cas Or_Intro_left *)
+Focus 1.
+destruct gl;clean.
+intro Hp;generalize (IHp hyps F gl1 Hp).
+apply compose1;simpl;auto.
+
+(* cas Or_Intro_right *)
+Focus 1.
+destruct gl;clean.
+intro Hp;generalize (IHp hyps F gl2 Hp).
+apply compose1;simpl;auto.
+
+(* cas Or_elim *)
+Focus 1.
+simpl;caseq (get p1 hyps);clean.
+intros f ef;destruct f;clean.
+caseq (check_proof (hyps \ f1) gl p2);clean.
+intros check_p1 check_p2;generalize (project F ef)
+(IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1)
+(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2);
+simpl;apply compose3;simpl;intro h;destruct h;auto.
+
+(* cas Or_Destruct *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f ef;destruct f;clean.
+destruct f1;clean.
+intro check_p0;generalize (project F ef)
+(IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2)
+(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) 
+ (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl.
+apply compose2;auto.
+
+(* cas Cut *)
+Focus 1.
+simpl;caseq (check_proof hyps f p1);clean.
+intros check_p1 check_p2;
+generalize (IHp1 hyps F f check_p1) 
+(IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
+simpl; apply compose2;auto.
+Qed.
+
+Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True.
+intros gl prf;caseq (check_proof empty gl prf);intro check_prf.
+change (interp_ctx empty F_empty [[gl]]) ;
+apply interp_proof with prf;assumption.
+trivial.
+Qed.
+
+End with_env.
+
+(*
+(* A small example *)
+Parameters A B C D:Prop.
+Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
+exact (Reflect (empty \ A \ B \ C)
+([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3])
+(I_Arrow (E_And 1 (E_Or 3 
+  (I_Or_l (I_And (Ax 2) (Ax 4))) 
+  (I_Or_r (I_And (Ax 2) (Ax 4))))))).
+Qed.
+Print toto.
+*)
diff --git a/theories7/NArith/NArith.v b/contrib/rtauto/g_rtauto.ml4
index d924ae2e..d7bb6e31 100644
--- a/theories7/NArith/NArith.v
+++ b/contrib/rtauto/g_rtauto.ml4
@@ -6,9 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: NArith.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ *)
+(* $Id: g_rtauto.ml4 7734 2005-12-26 14:06:51Z herbelin $*)
 
-(** Library for binary natural numbers *)
+(*i camlp4deps: "parsing/grammar.cma"  i*)
+
+TACTIC EXTEND rtauto
+  [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ]
+END
 
-Require Export BinPos.
-Require Export BinNat.
diff --git a/contrib/rtauto/proof_search.ml b/contrib/rtauto/proof_search.ml
new file mode 100644
index 00000000..98643e0f
--- /dev/null
+++ b/contrib/rtauto/proof_search.ml
@@ -0,0 +1,546 @@
+(************************************************************************)
+(*  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: proof_search.ml 7233 2005-07-15 12:34:56Z corbinea $ *)
+
+open Term
+open Util  
+open Goptions
+
+type s_info=
+    {mutable created_steps     : int; (* node count*)
+     mutable pruned_steps      : int;
+     mutable created_branches  : int; (* path count *)
+     mutable pruned_branches   : int;
+     mutable created_hyps      : int; (* hyps count *)
+     mutable pruned_hyps       : int;
+     mutable branch_failures   : int;
+     mutable branch_successes  : int;
+     mutable nd_branching      : int}
+
+let s_info=
+    {created_steps    = 0; (* node count*)
+     pruned_steps     = 0;
+     created_branches = 0; (* path count *)
+     pruned_branches  = 0;
+     created_hyps     = 0; (* hyps count *)
+     pruned_hyps      = 0;
+     branch_failures  = 0;
+     branch_successes = 0;
+     nd_branching     = 0}
+
+let reset_info () =
+     s_info.created_steps    <- 0; (* node count*)
+     s_info.pruned_steps     <- 0;
+     s_info.created_branches <- 0; (* path count *)
+     s_info.pruned_branches  <- 0;
+     s_info.created_hyps     <- 0; (* hyps count *)
+     s_info.pruned_hyps      <- 0;
+     s_info.branch_failures  <- 0;
+     s_info.branch_successes <- 0;
+     s_info.nd_branching     <- 0
+
+let pruning = ref true
+
+let opt_pruning=
+  {optsync=true;
+   optname="Rtauto Pruning";
+   optkey=SecondaryTable("Rtauto","Pruning");
+   optread=(fun () -> !pruning);
+   optwrite=(fun b -> pruning:=b)}
+
+let _ = declare_bool_option opt_pruning 
+
+type form=
+    Atom of int
+  | Arrow of form * form
+  | Bot 
+  | Conjunct of form * form
+  | Disjunct of form * form
+
+type tag=int
+
+let decomp_form=function
+    Atom i -> Some (i,[])
+  | Arrow (f1,f2) -> Some (-1,[f1;f2]) 
+  | Bot -> Some (-2,[])
+  | Conjunct (f1,f2) -> Some (-3,[f1;f2])
+  | Disjunct (f1,f2) -> Some (-4,[f1;f2])
+
+module Fmap=Map.Make(struct type t=form let compare=compare end)
+
+type sequent = 
+    {rev_hyps: form Intmap.t;
+     norev_hyps: form Intmap.t;
+     size:int;
+     left:int Fmap.t;
+     right:(int*form) list Fmap.t;
+     cnx:(int*int*form*form) list;
+     abs:int option;
+     gl:form}
+
+let add_one_arrow i f1 f2 m=
+  try Fmap.add f1 ((i,f2)::(Fmap.find f1 m)) m with
+      Not_found ->
+	Fmap.add f1 [i,f2] m
+
+type proof =
+    Ax of int
+  | I_Arrow of proof
+  | E_Arrow of int*int*proof
+  | D_Arrow of int*proof*proof
+  | E_False of int
+  | I_And of proof*proof
+  | E_And of int*proof
+  | D_And of int*proof
+  | I_Or_l of proof
+  | I_Or_r of proof
+  | E_Or of int*proof*proof
+  | D_Or of int*proof
+  | Pop of int*proof
+      
+type rule =
+    SAx of int
+  | SI_Arrow 
+  | SE_Arrow of int*int
+  | SD_Arrow of int
+  | SE_False of int
+  | SI_And 
+  | SE_And of int
+  | SD_And of int
+  | SI_Or_l
+  | SI_Or_r
+  | SE_Or of int
+  | SD_Or of int
+
+let add_step s sub =
+  match s,sub with
+      SAx i,[] -> Ax i
+    | SI_Arrow,[p] -> I_Arrow p
+    | SE_Arrow(i,j),[p] -> E_Arrow (i,j,p)
+    | SD_Arrow i,[p1;p2] -> D_Arrow (i,p1,p2)
+    | SE_False i,[] -> E_False i
+    | SI_And,[p1;p2] -> I_And(p1,p2)
+    | SE_And i,[p] -> E_And(i,p)
+    | SD_And i,[p] -> D_And(i,p)
+    | SI_Or_l,[p] -> I_Or_l p
+    | SI_Or_r,[p] -> I_Or_r p
+    | SE_Or i,[p1;p2] -> E_Or(i,p1,p2)
+    | SD_Or i,[p] -> D_Or(i,p)
+    | _,_ -> anomaly "add_step: wrong arity" 
+    
+type 'a with_deps = 
+    {dep_it:'a;
+     dep_goal:bool;
+     dep_hyps:Intset.t}
+
+type slice=
+    {proofs_done:proof list;
+     proofs_todo:sequent with_deps list;
+     step:rule;
+     needs_goal:bool;
+     needs_hyps:Intset.t;
+     changes_goal:bool;
+     creates_hyps:Intset.t}
+
+type state = 
+    Complete of proof
+  | Incomplete of sequent * slice list
+
+let project = function
+    Complete prf -> prf
+  | Incomplete (_,_) -> anomaly "not a successful state"
+
+let pop n prf =
+  let nprf=
+    match prf.dep_it with
+	Pop (i,p) -> Pop (i+n,p)
+      | p -> Pop(n,p) in
+    {prf with dep_it = nprf}
+
+let rec fill stack proof =
+  match stack with 
+      [] -> Complete proof.dep_it
+    | slice::super ->
+	if 
+	  !pruning &&
+	  slice.proofs_done=[] &&
+	  not (slice.changes_goal && proof.dep_goal) &&
+	  not (Intset.exists 
+		 (fun i -> Intset.mem i proof.dep_hyps) 
+		 slice.creates_hyps)
+	then
+	  begin
+	    s_info.pruned_steps<-s_info.pruned_steps+1;
+	    s_info.pruned_branches<- s_info.pruned_branches +
+	    List.length slice.proofs_todo;
+	    let created_here=Intset.cardinal slice.creates_hyps in
+	      s_info.pruned_hyps<-s_info.pruned_hyps+
+	      List.fold_left 
+		(fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) 
+		created_here slice.proofs_todo;
+	    fill super (pop (Intset.cardinal slice.creates_hyps) proof)
+	  end
+	else
+	  let dep_hyps=
+	    Intset.union slice.needs_hyps 
+	      (Intset.diff proof.dep_hyps slice.creates_hyps) in
+	  let dep_goal=
+	    slice.needs_goal || 
+	    ((not slice.changes_goal) && proof.dep_goal) in
+	  let proofs_done=
+	    proof.dep_it::slice.proofs_done in
+	    match slice.proofs_todo with
+		[] ->
+		  fill super {dep_it = 
+				add_step slice.step (List.rev proofs_done);
+			      dep_goal = dep_goal;
+			      dep_hyps = dep_hyps}
+	      | current::next ->
+		  let nslice=
+		    {proofs_done=proofs_done;
+		     proofs_todo=next;
+		     step=slice.step;
+		     needs_goal=dep_goal;
+		     needs_hyps=dep_hyps;
+		     changes_goal=current.dep_goal;
+		     creates_hyps=current.dep_hyps} in
+		    Incomplete (current.dep_it,nslice::super)
+
+let append stack (step,subgoals) =
+  s_info.created_steps<-s_info.created_steps+1;
+  match subgoals with 
+      [] -> 
+	s_info.branch_successes<-s_info.branch_successes+1;
+	fill stack {dep_it=add_step step.dep_it [];
+		    dep_goal=step.dep_goal;
+		    dep_hyps=step.dep_hyps}
+    | hd :: next ->
+	s_info.created_branches<-
+	s_info.created_branches+List.length next;
+	let slice=
+	  {proofs_done=[];
+	   proofs_todo=next;
+	   step=step.dep_it;
+	   needs_goal=step.dep_goal;
+	   needs_hyps=step.dep_hyps;
+	   changes_goal=hd.dep_goal;
+	   creates_hyps=hd.dep_hyps} in
+	  Incomplete(hd.dep_it,slice::stack)
+
+let embed seq=
+  {dep_it=seq;
+   dep_goal=false;
+   dep_hyps=Intset.empty}
+
+let change_goal seq gl=
+    {seq with 
+       dep_it={seq.dep_it with gl=gl};
+       dep_goal=true}
+	
+let add_hyp seqwd f=
+  s_info.created_hyps<-s_info.created_hyps+1;
+  let seq=seqwd.dep_it in
+  let num = seq.size+1 in
+  let left = Fmap.add f num seq.left in
+  let cnx,right=
+    try
+      let l=Fmap.find f seq.right in
+	List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx,
+	Fmap.remove f seq.right
+    with Not_found -> seq.cnx,seq.right in
+  let nseq=
+    match f with
+	Bot -> 
+	  {seq with 
+	     left=left;
+	     right=right;
+	     size=num;
+	     abs=Some num;
+	     cnx=cnx}
+      | Atom _ ->
+	  {seq with 
+	     size=num;
+	     left=left;
+	     right=right;
+	     cnx=cnx}
+      | Conjunct (_,_) | Disjunct (_,_) ->
+	  {seq with
+	     rev_hyps=Intmap.add num f seq.rev_hyps; 
+	     size=num;
+	     left=left;
+	     right=right;
+	     cnx=cnx}
+      | Arrow (f1,f2) ->
+	  let ncnx,nright=
+	    try 
+	      let i = Fmap.find f1 seq.left in	  
+		(i,num,f1,f2)::cnx,right
+	    with Not_found ->
+	      cnx,(add_one_arrow num f1 f2 right) in
+	    match f1 with
+		Conjunct (_,_) | Disjunct (_,_) ->
+		  {seq with
+		     rev_hyps=Intmap.add num f seq.rev_hyps; 
+		     size=num;
+		     left=left;
+		     right=nright;
+		     cnx=ncnx}
+	      | Arrow(_,_) ->
+		  {seq with
+		     norev_hyps=Intmap.add num f seq.norev_hyps; 
+		     size=num;
+		     left=left;
+		     right=nright;
+		     cnx=ncnx}
+	      | _ -> 
+		  {seq with
+		     size=num;
+		     left=left;
+		     right=nright;
+		     cnx=ncnx} in
+    {seqwd with 
+       dep_it=nseq;
+       dep_hyps=Intset.add num seqwd.dep_hyps}
+
+exception Here_is of (int*form)
+
+let choose m= 
+  try 
+    Intmap.iter (fun i f -> raise (Here_is (i,f))) m;
+    raise Not_found
+  with 
+      Here_is (i,f) -> (i,f)
+
+
+let search_or seq=
+  match seq.gl with
+      Disjunct (f1,f2) -> 
+	[{dep_it = SI_Or_l;
+	  dep_goal = true;
+	  dep_hyps = Intset.empty},
+	 [change_goal (embed seq) f1];
+	 {dep_it = SI_Or_r;
+	  dep_goal = true;
+	  dep_hyps = Intset.empty},
+	 [change_goal (embed seq) f2]]
+    | _ -> []
+
+let search_norev seq=
+  let goals=ref (search_or seq) in
+  let add_one i f= 
+    match f with
+	Arrow (Arrow (f1,f2),f3) ->
+	  let nseq = 
+	    {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in
+	    goals:=
+	      ({dep_it=SD_Arrow(i);
+		dep_goal=false;
+		dep_hyps=Intset.singleton i},
+	       [add_hyp 
+		  (add_hyp 
+		     (change_goal (embed nseq) f2) 
+		     (Arrow(f2,f3))) 
+		  f1;
+		add_hyp (embed nseq) f3]):: !goals
+      | _ -> anomaly "search_no_rev: can't happen" in
+    Intmap.iter add_one seq.norev_hyps;
+    List.rev !goals
+
+let search_in_rev_hyps seq=
+  try 
+    let i,f=choose seq.rev_hyps in
+    let make_step step=
+      {dep_it=step;
+       dep_goal=false;
+       dep_hyps=Intset.singleton i} in
+    let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in
+      match f with
+	  Conjunct (f1,f2) -> 
+	    [make_step (SE_And(i)),
+	     [add_hyp (add_hyp (embed nseq) f1) f2]]
+	| Disjunct (f1,f2) ->
+	    [make_step (SE_Or(i)),
+	     [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]]
+	| Arrow (Conjunct (f1,f2),f0) -> 
+	    [make_step (SD_And(i)),
+	     [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]]
+	| Arrow (Disjunct (f1,f2),f0) ->
+	    [make_step (SD_Or(i)),
+	     [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]]
+	| _ -> anomaly "search_in_rev_hyps: can't happen"	      
+  with
+      Not_found -> search_norev seq
+ 
+let search_rev seq=
+  match seq.cnx with
+      (i,j,f1,f2)::next -> 
+	let nseq=
+	  match f1 with
+	      Conjunct (_,_) | Disjunct (_,_) ->
+		{seq with cnx=next;
+		   rev_hyps=Intmap.remove j seq.rev_hyps}
+	    | Arrow (_,_) ->
+		{seq with cnx=next;
+		   norev_hyps=Intmap.remove j seq.norev_hyps}
+	    | _ ->
+		{seq with cnx=next} in
+	  [{dep_it=SE_Arrow(i,j);
+	    dep_goal=false;
+	    dep_hyps=Intset.add i (Intset.singleton j)},
+	   [add_hyp (embed nseq) f2]]
+    | [] -> 
+	match seq.gl with
+	    Arrow (f1,f2) ->
+	      [{dep_it=SI_Arrow;
+		dep_goal=true;
+		dep_hyps=Intset.empty},
+	       [add_hyp (change_goal (embed seq) f2) f1]]
+	  | Conjunct (f1,f2) ->
+	      [{dep_it=SI_And;
+		dep_goal=true;
+		dep_hyps=Intset.empty},[change_goal (embed seq) f1;
+					change_goal (embed seq) f2]]
+	  | _ -> search_in_rev_hyps seq
+
+let search_all seq=
+  match seq.abs with
+      Some i -> 
+	[{dep_it=SE_False (i);
+	  dep_goal=false;
+	  dep_hyps=Intset.singleton i},[]]
+    | None ->
+	try 
+	  let ax = Fmap.find seq.gl seq.left in
+	    [{dep_it=SAx (ax);
+	      dep_goal=true;
+	      dep_hyps=Intset.singleton ax},[]]
+	with Not_found -> search_rev seq
+
+let bare_sequent = embed 
+		     {rev_hyps=Intmap.empty;
+		      norev_hyps=Intmap.empty;
+		      size=0;
+		      left=Fmap.empty;
+		      right=Fmap.empty;
+		      cnx=[];
+		      abs=None;
+		      gl=Bot}
+		     
+let init_state hyps gl=
+  let init = change_goal bare_sequent gl in
+  let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in
+    Incomplete (goal.dep_it,[])
+
+let success= function
+    Complete _ -> true
+  | Incomplete (_,_) -> false
+
+let branching = function
+    Incomplete (seq,stack) ->
+      check_for_interrupt ();
+      let successors = search_all seq in
+      let _ =
+	match successors with
+	    [] -> s_info.branch_failures<-s_info.branch_failures+1
+	  | _::next ->  
+	      s_info.nd_branching<-s_info.nd_branching+List.length next in
+	List.map (append stack) successors
+  | Complete prf -> anomaly "already succeeded"
+
+open Pp 
+
+let rec pp_form =
+  function
+      Arrow(f1,f2) -> (pp_or f1) ++ (str " -> ") ++ (pp_form f2)
+    | f -> pp_or f
+and pp_or = function
+    Disjunct(f1,f2) ->
+      (pp_or f1) ++ (str " \\/ ") ++ (pp_and f2)
+  | f -> pp_and f
+and pp_and = function
+    Conjunct(f1,f2) ->
+      (pp_and f1) ++ (str " /\\ ") ++ (pp_atom f2)
+  | f -> pp_atom f
+and pp_atom= function
+    Bot -> str "#"
+  | Atom n -> int n
+  | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" 
+
+let pr_form f = msg (pp_form f)
+
+let pp_intmap map = 
+  let pp=ref (str "") in  
+   Intmap.iter (fun i obj -> pp:= (!pp ++ 
+		pp_form obj ++ cut ())) map;
+    str "{ " ++ v 0 (!pp) ++ str " }"
+
+let pp_list pp_obj l=
+let pp=ref (str "") in
+  List.iter (fun o -> pp := !pp ++ (pp_obj o) ++ str ", ") l;
+  str "[ " ++ !pp ++ str "]"
+
+let pp_mapint map =
+  let pp=ref (str "") in  
+   Fmap.iter (fun obj l -> pp:= (!pp ++ 
+		pp_form obj ++ str " => " ++ 
+				 pp_list (fun (i,f) -> pp_form f) l ++ 
+				 cut ()) ) map;
+    str "{ " ++ vb 0 ++  (!pp) ++ str " }" ++ close ()
+
+let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2
+
+let pp_gl gl= cut () ++
+  str "{ " ++ vb 0 ++ 
+	      begin
+		match gl.abs with
+		    None -> str ""
+		  | Some i -> str "ABSURD" ++ cut ()
+	      end ++
+  str "rev   =" ++ pp_intmap gl.rev_hyps ++ cut () ++
+  str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++
+  str "arrows=" ++ pp_mapint gl.right ++ cut () ++ 
+  str "cnx   =" ++ pp_list pp_connect gl.cnx ++ cut () ++ 
+  str "goal  =" ++ pp_form gl.gl ++ str " }" ++ close ()
+
+let pp = 
+  function
+      Incomplete(gl,ctx) -> msgnl (pp_gl gl)
+    | _ -> msg (str "<complete>")
+
+let pp_info () = 
+  let count_info = 
+    if !pruning then
+	str "Proof steps : " ++ 
+	int s_info.created_steps ++ str " created / " ++ 
+	int s_info.pruned_steps ++ str " pruned" ++ fnl () ++
+	str "Proof branches : " ++ 
+	int s_info.created_branches ++ str " created / " ++ 
+	int s_info.pruned_branches ++ str " pruned" ++ fnl () ++
+	str "Hypotheses : " ++ 
+	int s_info.created_hyps ++ str " created / " ++ 
+	int s_info.pruned_hyps ++ str " pruned" ++ fnl ()
+    else
+	str "Pruning is off" ++ fnl () ++
+	str "Proof steps : " ++ 
+	int s_info.created_steps ++ str " created" ++ fnl () ++
+	str "Proof branches : " ++ 
+	int s_info.created_branches ++ str " created" ++ fnl () ++
+	str "Hypotheses : " ++ 
+	int s_info.created_hyps ++ str " created" ++ fnl () in
+    msgnl
+      ( str "Proof-search statistics :" ++ fnl () ++
+	count_info ++ 
+	str "Branch ends: " ++
+	int s_info.branch_successes ++ str " successes / " ++
+	int s_info.branch_failures ++ str " failures" ++ fnl () ++
+	str "Non-deterministic choices : " ++
+	int s_info.nd_branching ++ str " branches")
+
+
+ 
diff --git a/contrib/rtauto/proof_search.mli b/contrib/rtauto/proof_search.mli
new file mode 100644
index 00000000..eb11aeae
--- /dev/null
+++ b/contrib/rtauto/proof_search.mli
@@ -0,0 +1,49 @@
+(************************************************************************)
+(*  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: proof_search.mli 7233 2005-07-15 12:34:56Z corbinea $ *)
+
+type form=
+    Atom of int
+  | Arrow of form * form
+  | Bot 
+  | Conjunct of form * form
+  | Disjunct of form * form
+  
+type proof =
+    Ax of int
+  | I_Arrow of proof
+  | E_Arrow of int*int*proof
+  | D_Arrow of int*proof*proof
+  | E_False of int
+  | I_And of proof*proof
+  | E_And of int*proof
+  | D_And of int*proof
+  | I_Or_l of proof
+  | I_Or_r of proof
+  | E_Or of int*proof*proof
+  | D_Or of int*proof
+  | Pop of int*proof
+
+type state
+
+val project: state -> proof
+
+val init_state : ('a * form * 'b)  list -> form -> state
+
+val branching: state -> state list
+
+val success: state -> bool
+
+val pp: state -> unit
+
+val pr_form : form -> unit
+
+val reset_info : unit -> unit
+
+val pp_info : unit -> unit
diff --git a/contrib/rtauto/refl_tauto.ml b/contrib/rtauto/refl_tauto.ml
new file mode 100644
index 00000000..a1f5e5aa
--- /dev/null
+++ b/contrib/rtauto/refl_tauto.ml
@@ -0,0 +1,337 @@
+(************************************************************************)
+(*  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: refl_tauto.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+
+module Search = Explore.Make(Proof_search)
+
+open Util
+open Term
+open Termops
+open Names
+open Evd
+open Tacmach
+open Proof_search
+
+let force count lazc = incr count;Lazy.force lazc 
+
+let step_count = ref 0
+
+let node_count = ref 0  
+
+let logic_constant = 
+  Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] 
+
+let li_False = lazy (destInd (logic_constant "False"))
+let li_and = lazy (destInd (logic_constant "and"))
+let li_or =  lazy (destInd (logic_constant "or"))
+
+let data_constant =
+  Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] 
+
+let l_true_equals_true = 
+  lazy (mkApp(logic_constant "refl_equal", 
+        [|data_constant "bool";data_constant "true"|]))
+
+let pos_constant =
+  Coqlib.gen_constant "refl_tauto" ["NArith";"BinPos"]
+
+let l_xI = lazy (pos_constant "xI")
+let l_xO = lazy (pos_constant "xO")
+let l_xH = lazy (pos_constant "xH")
+
+let store_constant = 
+  Coqlib.gen_constant "refl_tauto" ["rtauto";"Bintree"]
+
+let l_empty = lazy (store_constant "empty")
+let l_push = lazy (store_constant "push")
+
+let constant=
+  Coqlib.gen_constant "refl_tauto" ["rtauto";"Rtauto"]
+
+let l_Reflect = lazy (constant "Reflect")
+
+let l_Atom = lazy (constant "Atom")
+let l_Arrow = lazy (constant "Arrow")
+let l_Bot = lazy (constant "Bot")
+let l_Conjunct = lazy (constant "Conjunct")
+let l_Disjunct = lazy (constant "Disjunct")
+
+let l_Ax = lazy (constant "Ax")
+let l_I_Arrow = lazy (constant "I_Arrow")
+let l_E_Arrow = lazy (constant "E_Arrow")
+let l_D_Arrow = lazy (constant "D_Arrow")
+let l_E_False = lazy (constant "E_False")
+let l_I_And = lazy (constant "I_And")
+let l_E_And = lazy (constant "E_And")
+let l_D_And = lazy (constant "D_And")
+let l_I_Or_l = lazy (constant "I_Or_l")
+let l_I_Or_r = lazy (constant "I_Or_r")
+let l_E_Or = lazy (constant "E_Or")
+let l_D_Or = lazy (constant "D_Or")
+
+
+let special_whd gl=
+  let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
+    (fun t -> Closure.whd_val infos (Closure.inject t))
+
+let special_nf gl=
+  let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
+    (fun t -> Closure.norm_val infos (Closure.inject t))
+
+type atom_env=
+    {mutable next:int;
+     mutable env:(constr*int) list}
+
+let make_atom atom_env term=
+  try
+    let (_,i)=
+      List.find (fun (t,_)-> eq_constr term t) atom_env.env
+    in Atom i
+  with Not_found ->
+    let i=atom_env.next in
+      atom_env.env <- (term,i)::atom_env.env;
+      atom_env.next<- i + 1;
+      Atom i
+
+let rec make_form atom_env gls term =
+  let normalize=special_nf gls in
+  let cciterm=special_whd gls term  in
+    match kind_of_term cciterm with
+	Prod(_,a,b) -> 
+	  if not (dependent (mkRel 1) b) && 
+	    Retyping.get_sort_family_of 
+	    (pf_env gls) (Tacmach.project gls) a = InProp
+	  then 
+	    let fa=make_form atom_env gls a in
+	    let fb=make_form atom_env gls b in
+	      Arrow (fa,fb)
+	  else
+	    make_atom atom_env (normalize term)
+      | Cast(a,_,_) -> 
+	  make_form atom_env gls a
+      | Ind ind ->
+	  if ind = Lazy.force li_False then
+	    Bot
+	  else
+	    make_atom atom_env (normalize term)
+      | App(hd,argv) when Array.length argv = 2 ->
+	  begin
+	    try 
+	      let ind = destInd hd in
+		if ind = Lazy.force li_and then
+		  let fa=make_form atom_env gls argv.(0) in
+		  let fb=make_form atom_env gls argv.(1) in
+		    Conjunct (fa,fb)
+		else if ind = Lazy.force li_or then
+		  let fa=make_form atom_env gls argv.(0) in
+		  let fb=make_form atom_env gls argv.(1) in
+		    Disjunct (fa,fb)
+		else make_atom atom_env (normalize term)
+	    with Invalid_argument _ -> make_atom atom_env (normalize term)
+	  end
+      | _ -> make_atom atom_env (normalize term)
+
+let rec make_hyps atom_env gls lenv = function
+    [] -> []
+  | (_,Some body,typ)::rest -> 
+      make_hyps atom_env gls (typ::body::lenv) rest  
+  | (id,None,typ)::rest ->
+      let hrec=
+	make_hyps atom_env gls (typ::lenv) rest in
+	if List.exists (dependent (mkVar id)) lenv || 
+	  (Retyping.get_sort_family_of 
+	     (pf_env gls) (Tacmach.project gls) typ <> InProp) 
+	then
+	  hrec 
+	else
+	  (id,make_form atom_env gls typ)::hrec
+
+let rec build_pos n =
+  if n<=1 then force node_count l_xH 
+  else if n land 1 = 0 then 
+    mkApp (force node_count l_xO,[|build_pos (n asr 1)|])
+  else 
+    mkApp (force node_count l_xI,[|build_pos (n asr 1)|])
+
+let rec build_form = function
+    Atom n -> mkApp (force node_count l_Atom,[|build_pos n|])
+  | Arrow (f1,f2) -> 
+      mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|])
+  | Bot -> force node_count l_Bot
+  | Conjunct (f1,f2) -> 
+      mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|])
+  | Disjunct (f1,f2) -> 
+      mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|])
+
+let rec decal k = function 
+    [] -> k
+  | (start,delta)::rest -> 
+      if k>start then
+	k - delta
+      else 
+	decal k rest
+
+let add_pop size d pops=
+  match pops with
+      [] -> [size+d,d]
+    | (_,sum)::_ -> (size+sum,sum+d)::pops  
+
+let rec build_proof pops size = 
+  function
+      Ax i ->
+	mkApp (force step_count l_Ax,
+	       [|build_pos (decal i pops)|])
+      | I_Arrow p -> 
+	  mkApp (force step_count l_I_Arrow,
+		 [|build_proof pops (size + 1) p|])
+      | E_Arrow(i,j,p) -> 
+	  mkApp (force step_count l_E_Arrow, 
+		 [|build_pos (decal i pops);
+		   build_pos (decal j pops);
+		   build_proof pops (size + 1) p|])
+      | D_Arrow(i,p1,p2) -> 
+	  mkApp (force step_count l_D_Arrow, 
+		 [|build_pos (decal i pops);
+		   build_proof pops (size + 2) p1;
+		   build_proof pops (size + 1) p2|])
+      | E_False i -> 
+	  mkApp (force step_count l_E_False,
+		 [|build_pos (decal i pops)|])
+      | I_And(p1,p2) -> 
+	  mkApp (force step_count l_I_And, 
+		 [|build_proof pops size p1;
+		   build_proof pops size p2|])
+      | E_And(i,p) -> 
+	  mkApp (force step_count l_E_And,
+		 [|build_pos (decal i pops);
+		   build_proof pops (size + 2) p|])
+      | D_And(i,p) -> 
+	  mkApp (force step_count l_D_And,
+		 [|build_pos (decal i pops);
+		   build_proof pops (size + 1) p|])
+      | I_Or_l(p) -> 
+	  mkApp (force step_count l_I_Or_l,
+		 [|build_proof pops size p|])
+      | I_Or_r(p) -> 
+	  mkApp (force step_count l_I_Or_r,
+		 [|build_proof pops size p|])
+      | E_Or(i,p1,p2) ->
+	  mkApp (force step_count l_E_Or, 
+		 [|build_pos (decal i pops);
+		   build_proof pops (size + 1) p1;
+		   build_proof pops (size + 1) p2|])
+      | D_Or(i,p) -> 
+	  mkApp (force step_count l_D_Or,
+		 [|build_pos (decal i pops);
+		   build_proof pops (size + 2) p|])
+      | Pop(d,p) ->
+	  build_proof (add_pop size d pops) size p 
+	    
+let build_env gamma=
+  List.fold_right (fun (p,_) e -> 
+		     mkApp(force node_count l_push,[|mkProp;p;e|])) 
+    gamma.env (mkApp (force node_count l_empty,[|mkProp|]))
+
+open Goptions
+
+let verbose = ref false
+
+let opt_verbose=
+  {optsync=true;
+   optname="Rtauto Verbose";
+   optkey=SecondaryTable("Rtauto","Verbose");
+   optread=(fun () -> !verbose);
+   optwrite=(fun b -> verbose:=b)}
+
+let _ = declare_bool_option opt_verbose 
+
+let check = ref false
+
+let opt_check=
+  {optsync=true;
+   optname="Rtauto Check";
+   optkey=SecondaryTable("Rtauto","Check");
+   optread=(fun () -> !check);
+   optwrite=(fun b -> check:=b)}
+
+let _ = declare_bool_option opt_check 
+
+open Pp
+
+let rtauto_tac gls=
+  Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"];
+  let gamma={next=1;env=[]} in
+  let gl=gls.it.evar_concl in
+  let _=
+    if Retyping.get_sort_family_of 
+      (pf_env gls) (Tacmach.project gls) gl <> InProp 
+    then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in
+  let glf=make_form gamma gls gl in
+  let hyps=make_hyps gamma gls [gl] 
+      (Environ.named_context_of_val gls.it.evar_hyps) in
+  let formula=
+    List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in  
+  let search_fun = 
+    if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then
+      Search.debug_depth_first
+    else 
+      Search.depth_first in
+  let _ = 
+    begin
+      reset_info ();
+      if !verbose then
+	msgnl (str "Starting proof-search ...");
+    end in
+  let search_start_time = System.get_time () in
+  let prf = 
+    try project (search_fun (init_state [] formula)) 
+    with Not_found ->
+      errorlabstrm "rtauto" (Pp.str "rtauto could'nt find any proof") in
+  let search_end_time = System.get_time () in
+  let _ = if !verbose then
+    begin
+      msgnl (str "Proof tree found in " ++ 
+	     System.fmt_time_difference search_start_time search_end_time);
+      pp_info ();
+      msgnl (str "Building proof term ... ")
+    end in
+  let build_start_time=System.get_time () in
+  let _ = step_count := 0; node_count := 0 in
+  let main = mkApp (force node_count l_Reflect,
+		    [|build_env gamma;
+		      build_form formula;
+		      build_proof [] 0 prf|]) in
+  let term=
+    Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in
+  let build_end_time=System.get_time () in
+  let _ = if !verbose then
+    begin
+      msgnl (str "Proof term built in " ++ 
+	     System.fmt_time_difference build_start_time build_end_time ++
+	     fnl () ++
+	     str "Proof size : " ++ int !step_count ++ 
+	     str " steps" ++ fnl () ++
+	     str "Proof term size : " ++ int (!step_count+ !node_count) ++
+	     str " nodes (constants)" ++ fnl () ++
+	     str "Giving proof term to Coq ... ")
+    end in
+  let tac_start_time = System.get_time () in
+  let result=
+    if !check then 
+      Tactics.exact_check term gls
+    else
+      Tactics.exact_no_check term gls in
+  let tac_end_time = System.get_time () in
+  let _ = 
+    if !check then msgnl (str "Proof term type-checking is on");
+    if !verbose then
+      msgnl (str "Internal tactic executed in " ++ 
+	     System.fmt_time_difference tac_start_time tac_end_time) in
+    result
+
diff --git a/theories7/Bool/DecBool.v b/contrib/rtauto/refl_tauto.mli
index c22cd032..480dbb30 100755..100644
--- a/theories7/Bool/DecBool.v
+++ b/contrib/rtauto/refl_tauto.mli
@@ -5,23 +5,22 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
+(* $Id: refl_tauto.mli 7233 2005-07-15 12:34:56Z corbinea $ *)
 
-(*i $Id: DecBool.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
+(* raises Not_found if no proof is found *)
 
-Set Implicit Arguments.
+type atom_env=
+    {mutable next:int;
+     mutable env:(Term.constr*int) list}
 
-Definition ifdec : (A,B:Prop)(C:Set)({A}+{B})->C->C->C
-   := [A,B,C,H,x,y]if H then [_]x else [_]y.
+val make_form : atom_env ->
+    Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form
 
+val make_hyps :
+    atom_env ->
+    Proof_type.goal Tacmach.sigma ->
+    Term.types list ->
+    (Names.identifier * Term.types option * Term.types) list ->
+    (Names.identifier * Proof_search.form) list
 
-Theorem ifdec_left : (A,B:Prop)(C:Set)(H:{A}+{B})~B->(x,y:C)(ifdec H x y)=x.
-Intros; Case H; Auto.
-Intro; Absurd B; Trivial.
-Qed.
-
-Theorem ifdec_right : (A,B:Prop)(C:Set)(H:{A}+{B})~A->(x,y:C)(ifdec H x y)=y.
-Intros; Case H; Auto.
-Intro; Absurd A; Trivial.
-Qed.
-
-Unset Implicit Arguments.
+val rtauto_tac : Proof_type.tactic
diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v
new file mode 100644
index 00000000..074f6ef7
--- /dev/null
+++ b/contrib/setoid_ring/ArithRing.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Require Import Mult.
+Require Import BinNat.
+Require Import Nnat.
+Require Export Ring.
+Set Implicit Arguments.
+
+Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
+ Proof.
+  constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
+  exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
+  exact mult_plus_distr_r. 
+ Qed.
+
+Lemma nat_morph_N : 
+   semi_morph 0 1 plus mult (eq (A:=nat)) 
+          0%N 1%N Nplus Nmult Neq_bool nat_of_N.
+Proof.
+  constructor;trivial.
+  exact nat_of_Nplus.
+  exact nat_of_Nmult.
+  intros x y H;rewrite (Neq_bool_ok _ _ H);trivial.
+Qed.
+
+Ltac natcst t :=
+  match isnatcst t with
+    true => constr:(N_of_nat t)
+  | _ => InitialRing.NotConstant
+  end.
+
+Ltac Ss_to_add f acc :=
+  match f with
+  | S ?f1 => Ss_to_add f1 (S acc)
+  | _ => constr:(acc + f)%nat
+  end.
+
+Ltac natprering :=
+  match goal with
+    |- context C [S ?p] =>
+    match p with
+      O => fail 1 (* avoid replacing 1 with 1+0 ! *)
+    | p => match isnatcst p with 
+           | true => fail 1
+           | false => let v := Ss_to_add p (S 0) in
+                         fold v; natprering
+           end
+    end
+  | _ => idtac
+  end.
+
+Add Ring natr : natSRth
+  (morphism nat_morph_N, constants [natcst], preprocess [natprering]).
+
diff --git a/contrib/setoid_ring/BinList.v b/contrib/setoid_ring/BinList.v
new file mode 100644
index 00000000..50902004
--- /dev/null
+++ b/contrib/setoid_ring/BinList.v
@@ -0,0 +1,93 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Set Implicit Arguments.
+Require Import BinPos.
+Require Export List.
+Require Export ListTactics.
+Open Local Scope positive_scope.
+
+Section MakeBinList.
+ Variable A : Type.
+ Variable default : A.
+
+ Fixpoint jump (p:positive) (l:list A) {struct p} : list A :=
+  match p with
+  | xH => tail l
+  | xO p => jump p (jump p l)
+  | xI p  => jump p (jump p (tail l))
+  end.
+
+ Fixpoint nth (p:positive) (l:list A) {struct p} : A:=
+  match p with
+  | xH => hd default l
+  | xO p => nth p (jump p l)
+  | xI p => nth p (jump p (tail l))
+  end. 
+
+ Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
+ Proof. 
+  induction j;simpl;intros.
+  repeat rewrite IHj;trivial.
+  repeat rewrite IHj;trivial.
+  trivial.
+ Qed.
+
+ Lemma jump_Psucc : forall j l, 
+  (jump (Psucc j) l) = (jump 1 (jump j l)).
+ Proof.
+  induction j;simpl;intros.
+  repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial.
+  repeat rewrite jump_tl;trivial.
+  trivial.
+ Qed.
+
+ Lemma jump_Pplus : forall i j l, 
+  (jump (i + j) l) = (jump i (jump j l)).
+ Proof.
+  induction i;intros.
+  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
+  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+  repeat rewrite IHi.
+  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
+  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+  repeat rewrite IHi;trivial.
+  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
+ Qed.
+
+ Lemma jump_Pdouble_minus_one : forall i l,
+  (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
+ Proof.
+  induction i;intros;simpl.
+  repeat rewrite jump_tl;trivial.
+  rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial.
+  trivial.
+ Qed.
+
+ 
+ Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l).
+ Proof.
+  induction p;simpl;intros.
+  rewrite <-jump_tl;rewrite IHp;trivial.
+  rewrite <-jump_tl;rewrite IHp;trivial.
+  trivial.
+ Qed.
+
+ Lemma nth_Pdouble_minus_one :
+  forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
+ Proof.
+  induction p;simpl;intros.
+  repeat rewrite jump_tl;trivial.
+  rewrite jump_Pdouble_minus_one.
+  repeat rewrite <- jump_tl;rewrite IHp;trivial.
+  trivial.
+ Qed.
+
+End MakeBinList.
+
+
diff --git a/states7/MakeInitial.v b/contrib/setoid_ring/Field.v
index 64c540fa..a944ba5f 100644
--- a/states7/MakeInitial.v
+++ b/contrib/setoid_ring/Field.v
@@ -5,5 +5,6 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-Require Export Prelude.
-Require Export Logic_Type.
+
+Require Export Field_theory.
+Require Export Field_tac.
diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v
new file mode 100644
index 00000000..aad3a580
--- /dev/null
+++ b/contrib/setoid_ring/Field_tac.v
@@ -0,0 +1,405 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Require Import Ring_tac BinList Ring_polynom InitialRing.
+Require Export Field_theory.
+
+ (* syntaxification *)
+ Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := 
+ let rec mkP t :=
+    match Cst t with
+    | InitialRing.NotConstant =>
+        match t with 
+        | (radd ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEadd e1 e2)
+        | (rmul ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEmul e1 e2)
+        | (rsub ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEsub e1 e2)
+        | (ropp ?t1) =>
+          let e1 := mkP t1 in constr:(FEopp e1)
+        | (rdiv ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(FEdiv e1 e2)
+        | (rinv ?t1) =>
+          let e1 := mkP t1 in constr:(FEinv e1)
+        | (rpow ?t1 ?n) =>
+          match CstPow n with
+          | InitialRing.NotConstant => 
+            let p := Find_at t fv in constr:(@FEX C p)
+          | ?c => let e1 := mkP t1 in constr:(FEpow e1 c)
+          end
+  
+        | _ =>
+          let p := Find_at t fv in constr:(@FEX C p)
+        end
+    | ?c => constr:(FEc c)
+    end
+ in mkP t.
+
+Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
+ let rec TFV t fv :=
+  match Cst t with
+  | InitialRing.NotConstant =>
+      match t with
+      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (opp ?t1) => TFV t1 fv
+      | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (inv ?t1) => TFV t1 fv
+      | (pow ?t1 ?n) =>
+        match CstPow n with
+        | InitialRing.NotConstant => AddFvTail t fv
+        | _ => TFV t1 fv
+        end
+      | _ => AddFvTail t fv
+      end
+  | _ => fv
+  end 
+ in TFV t fv.
+
+Ltac ParseFieldComponents lemma :=
+  match type of lemma with
+  | context [
+     (*   PCond _ _ _  _ _ _ _  _ _  _ _ -> *)
+        (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv 
+                 ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) ] =>
+      (fun f => f radd rmul rsub ropp rdiv rinv rpow C)
+  | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
+  end.
+
+(* simplifying the non-zero condition... *)
+
+Ltac fold_field_cond req :=
+  let rec fold_concl t :=
+    match t with
+      ?x /\ ?y =>
+        let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy)
+    | req ?x ?y -> False => constr:(~ req x y)
+    | _ => t
+    end in
+  match goal with
+    |- ?t => let ft := fold_concl t in change ft
+  end.
+
+Ltac simpl_PCond req :=
+  protect_fv "field_cond";
+  (try exact I);
+  fold_field_cond req.
+
+Ltac simpl_PCond_BEURK req :=
+  protect_fv "field_cond";
+  fold_field_cond req.
+
+(* Rewriting (field_simplify) *)
+Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl :=
+  let Main radd rmul rsub ropp rdiv rinv rpow C :=
+    let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
+    let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+    let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+    let mkFE := 
+       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+    let fv := FV_hypo_tac mkFV req lH in
+    let simpl_field H := (protect_fv "field" in H;f H) in
+    let lemma_tac fv RW_tac :=
+      let rr_lemma := fresh "f_rw_lemma" in
+      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+      let vlpe := fresh "list_hyp" in
+      let vlmp := fresh "list_hyp_norm" in
+      let vlmp_eq := fresh "list_hyp_norm_eq" in
+      let prh := proofHyp_tac lH in
+      pose (vlpe := lpe);
+      match type of lemma with
+      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] =>
+        compute_assertion vlmp_eq vlmp 
+            (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe);
+         (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq)
+          || fail "type error when build the rewriting lemma");
+         RW_tac rr_lemma;
+        try clear rr_lemma vlmp_eq vlmp vlpe
+      | _ => fail 1 "field_simplify anomaly: bad correctness lemma"
+      end in
+    ReflexiveRewriteTactic mkFFV mkFE simpl_field lemma_tac fv rl;
+    try (apply Cond_lemma; simpl_PCond req) in
+  ParseFieldComponents lemma Main.
+
+Ltac Field_simplify_gen f := 
+     fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl =>
+       pre(); 
+       Field_norm_gen f cst_tac pow_tac field_simplify_ok cond_ok req 
+                  ring_subst_niter lH rl; 
+      post().
+
+Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H).
+
+Tactic Notation (at level 0) 
+  "field_simplify" constr_list(rl) :=
+  match goal with [|- ?G] => field_lookup Field_simplify [] rl [G] end.
+
+Tactic Notation (at level 0) 
+  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+  match goal with [|- ?G] => field_lookup Field_simplify [lH] rl [G] end.
+
+Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):=   
+   let G := getGoal in
+   let t := type of H in   
+   let g := fresh "goal" in
+   set (g:= G);
+   generalize H;clear H;
+   field_lookup Field_simplify [] rl [t];
+   intro H;
+   unfold g;clear g.
+
+Tactic Notation "field_simplify" "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):=   
+   let G := getGoal in
+   let t := type of H in   
+   let g := fresh "goal" in
+   set (g:= G);
+   generalize H;clear H;
+   field_lookup Field_simplify [lH] rl [t];
+   intro H;
+   unfold g;clear g.
+
+(*
+Ltac Field_simplify_in hyp:= 
+   Field_simplify_gen ltac:(fun H => rewrite H in hyp).
+
+Tactic Notation (at level 0) 
+  "field_simplify" constr_list(rl) "in" hyp(h) :=
+  let t := type of h in
+  field_lookup (Field_simplify_in h) [] rl [t].
+
+Tactic Notation (at level 0) 
+  "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) :=
+  let t := type of h in
+  field_lookup (Field_simplify_in h) [lH] rl [t].
+*)
+
+(** Generic tactic for solving equations *)
+
+Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH :=
+  let Main radd rmul rsub ropp rdiv rinv rpow C :=
+    let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
+    let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+    let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+    let mkFE := 
+       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+    let rec ParseExpr ilemma :=
+      match type of ilemma with
+        forall nfe, ?fe = nfe -> _ =>
+          (fun t => 
+            let x := fresh "fld_expr" in 
+            let H := fresh "norm_fld_expr" in
+            compute_assertion H x fe;
+            ParseExpr (ilemma x H) t;
+            try clear x H)
+      | _ => (fun t => t ilemma)
+      end in
+    let Main_eq t1 t2 :=
+      let fv := FV_hypo_tac mkFV req lH in
+      let fv := mkFFV t1 fv in
+      let fv := mkFFV t2 fv in
+      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+      let prh := proofHyp_tac lH in
+      let vlpe := fresh "list_hyp" in
+      let fe1 := mkFE t1 fv in
+      let fe2 := mkFE t2 fv in
+      pose (vlpe := lpe);
+      let nlemma := fresh "field_lemma" in
+      (assert (nlemma := lemma n fv vlpe fe1 fe2 prh)
+       || fail "field anomaly:failed to build lemma"); 
+      ParseExpr nlemma
+         ltac:(fun ilemma =>
+                  apply ilemma 
+                  || fail "field anomaly: failed in applying lemma";
+                  [ Simpl_tac | apply Cond_lemma; simpl_PCond req]);
+      clear vlpe nlemma in
+    OnEquation req Main_eq in
+  ParseFieldComponents lemma Main.
+
+(* solve completely a field equation, leaving non-zero conditions to be
+   proved (field) *)
+
+Ltac FIELD :=
+   let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in
+   fun req cst_tac pow_tac field_ok _ _ _ cond_ok pre post lH rl =>
+       pre(); 
+       Field_Scheme Simpl cst_tac pow_tac field_ok cond_ok req 
+         Ring_tac.ring_subst_niter lH;
+       try exact I;
+       post().
+ 
+Tactic Notation (at level 0) "field" :=
+  let G := getGoal in field_lookup FIELD [] [G].
+
+Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
+  let G := getGoal in field_lookup FIELD [lH] [G].
+
+(* transforms a field equation to an equivalent (simplified) ring equation,
+   and leaves non-zero conditions to be proved (field_simplify_eq) *)
+
+Ltac FIELD_SIMPL  :=
+  let Simpl := (protect_fv "field") in
+  fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl =>
+       pre(); 
+       Field_Scheme Simpl cst_tac pow_tac field_simplify_eq_ok cond_ok 
+          req Ring_tac.ring_subst_niter lH;
+       post().
+
+Tactic Notation (at level 0) "field_simplify_eq" :=  
+  let G := getGoal in field_lookup FIELD_SIMPL [] [G].
+
+Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=  
+  let G := getGoal in field_lookup FIELD_SIMPL [lH] [G].
+
+(* Same as FIELD_SIMPL but in hypothesis *)
+
+Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH :=
+   let Main radd rmul rsub ropp rdiv rinv rpow C :=
+    let hyp := fresh "hyp" in
+    intro hyp;
+    match type of hyp with
+    | req ?t1 ?t2 =>
+      let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
+      let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+      let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+      let mkFE := 
+        mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in
+      let rec ParseExpr ilemma :=
+        match type of ilemma with
+        |  forall nfe, ?fe = nfe -> _ =>
+          (fun t => 
+            let x := fresh "fld_expr" in 
+            let H := fresh "norm_fld_expr" in
+            compute_assertion H x fe;
+            ParseExpr (ilemma x H) t;
+            try clear H x)
+        | _ => (fun t => t ilemma)
+        end in
+      let fv := FV_hypo_tac mkFV req lH in
+      let fv := mkFFV t1 fv in
+      let fv := mkFFV t2 fv in
+      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+      let prh := proofHyp_tac lH in
+      let fe1 := mkFE t1 fv in
+      let fe2 := mkFE t2 fv in
+      let vlpe := fresh "vlpe" in
+      ParseExpr (lemma n fv lpe fe1 fe2 prh)
+         ltac:(fun ilemma =>
+             match type of ilemma with
+             | req _ _ ->  _ -> ?EQ => 
+               let tmp := fresh "tmp" in
+               assert (tmp : EQ);
+               [ apply ilemma; 
+                 [ exact hyp | apply Cond_lemma; simpl_PCond_BEURK req]
+               | protect_fv "field" in tmp;
+                 generalize tmp;clear tmp ];
+               clear hyp  
+             end)
+     end in
+  ParseFieldComponents lemma Main.
+
+Ltac FIELD_SIMPL_EQ :=
+ fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl =>
+       pre(); 
+       Field_simplify_eq cst_tac pow_tac lemma cond_ok req
+         Ring_tac.ring_subst_niter lH;
+       post().
+
+Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
+  let t := type of H in
+  generalize H;
+  field_lookup FIELD_SIMPL_EQ [] [t];
+  [ try exact I
+  | clear H;intro H].
+
+
+Tactic Notation (at level 0) 
+  "field_simplify_eq" "[" constr_list(lH) "]"  "in" hyp(H) :=  
+  let t := type of H in
+  generalize H;
+  field_lookup FIELD_SIMPL_EQ [lH] [t];
+  [ try exact I
+  |clear H;intro H].
+ 
+(* Adding a new field *)
+
+Ltac ring_of_field f :=
+  match type of f with
+  | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f)
+  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f)
+  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f)
+  end.
+
+Ltac coerce_to_almost_field set ext f :=
+  match type of f with
+  | almost_field_theory _ _ _ _ _ _ _ _ _ => f
+  | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f)
+  | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
+  end.
+
+Ltac field_elements set ext fspec pspec sspec rk :=
+  let afth := coerce_to_almost_field set ext fspec in
+  let rspec := ring_of_field fspec in
+  ring_elements set ext rspec pspec sspec rk
+  ltac:(fun arth ext_r morph p_spec s_spec f => f afth ext_r morph p_spec s_spec).
+
+Ltac field_lemmas set ext inv_m fspec pspec sspec rk :=
+  let simpl_eq_lemma := 
+     match pspec with
+     | None => constr:(Field_simplify_eq_correct)
+     | Some _ => constr:(Field_simplify_eq_pow_correct)
+     end in
+  let simpl_eq_in_lemma :=
+     match pspec with
+     | None => constr:(Field_simplify_eq_in_correct)
+     | Some _ => constr:(Field_simplify_eq_pow_in_correct)
+     end in
+  let rw_lemma :=
+     match pspec with
+     | None => constr:(Field_rw_correct)
+     | Some _ => constr:(Field_rw_pow_correct)
+     end in
+  field_elements set ext fspec pspec sspec rk
+   ltac:(fun afth ext_r morph p_spec s_spec =>
+     match p_spec with
+     | mkhypo ?pp_spec => match s_spec with
+     | mkhypo ?ss_spec =>
+       let field_simpl_eq_ok :=
+         constr:(simpl_eq_lemma _ _ _  _ _ _  _ _ _ _ 
+                   set ext_r inv_m afth 
+                   _ _ _  _ _ _  _ _ _ morph 
+                   _ _ _ pp_spec _ ss_spec) in 
+       let field_simpl_ok :=
+         constr:(rw_lemma _ _ _  _ _ _  _ _ _ _
+                   set ext_r inv_m afth 
+                   _ _ _  _ _ _  _ _ _ morph 
+                   _ _ _ pp_spec _ ss_spec) in
+       let field_simpl_eq_in :=
+         constr:(simpl_eq_in_lemma _ _ _  _ _ _  _ _ _ _
+                   set ext_r inv_m afth 
+                   _ _ _  _ _ _  _ _ _ morph 
+                   _ _ _ pp_spec _ ss_spec) in
+       let field_ok := 
+         constr:(Field_correct set ext_r inv_m afth morph pp_spec ss_spec) in
+       let cond1_ok := 
+         constr:(Pcond_simpl_gen set ext_r afth morph pp_spec) in
+       let cond2_ok := 
+         constr:(Pcond_simpl_complete set ext_r afth morph pp_spec) in
+       (fun f => 
+         f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in
+                cond1_ok cond2_ok)
+     | _ => fail 2 "bad sign specification"
+     end 
+     | _ => fail 1 "bad power specification" 
+     end).
+
diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v
new file mode 100644
index 00000000..ea8421cf
--- /dev/null
+++ b/contrib/setoid_ring/Field_theory.v
@@ -0,0 +1,1859 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Require Ring.
+Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List.
+Require Import ZArith_base.
+(*Require Import Omega.*)
+Set Implicit Arguments.
+
+Section MakeFieldPol.
+
+(* Field elements *)     
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
+ Variable req : R -> R -> Prop.
+
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y).
+ Notation "- x" := (ropp x). Notation "/ x" := (rinv x).
+ Notation "x == y" := (req x y) (at level 70, no associativity).
+
+ (* Equality properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable SRinv_ext : forall p q, p == q ->  / p == / q.
+ 
+ (* Field properties *)
+  Record almost_field_theory : Prop := mk_afield {
+    AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
+    AF_1_neq_0 : ~ 1 == 0;
+    AFdiv_def : forall p q, p / q == p * / q;
+    AFinv_l : forall p, ~ p == 0 ->  / p * p == 1
+  }.
+
+Section AlmostField.
+
+ Variable AFth : almost_field_theory.
+ Let ARth := AFth.(AF_AR).
+ Let rI_neq_rO := AFth.(AF_1_neq_0).
+ Let rdiv_def := AFth.(AFdiv_def).
+ Let rinv_l := AFth.(AFinv_l).
+
+ (* Coefficients *) 
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool. 
+ Variable phi : C -> R.
+
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+                               cO cI cadd cmul csub copp ceqb phi.
+
+Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
+  (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y).
+Proof.
+intros.
+generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
+case (ceqb c1 c2); auto.
+Qed.
+
+
+ (* C notations *)		 
+ Notation "x +! y" := (cadd x y) (at level 50).
+ Notation "x *! y " := (cmul x y) (at level 40).
+ Notation "x -! y " := (csub x y) (at level 50).
+ Notation "-! x" := (copp x) (at level 35).
+ Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity).
+ Notation "[ x ]" := (phi x) (at level 0).
+
+
+ (* Usefull tactics *)		  
+  Add Setoid R req Rsth as R_set1.
+  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
+  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
+  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
+  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+  Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed.
+ 
+Let eq_trans := Setoid.Seq_trans _ _ Rsth.
+Let eq_sym := Setoid.Seq_sym _ _ Rsth.
+Let eq_refl := Setoid.Seq_refl _ _ Rsth.
+
+Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) .
+Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe)
+             (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext.
+Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc ARth)
+             (ARmul_1_l  ARth) (ARmul_0_l  ARth) 
+             (ARmul_comm  ARth) (ARmul_assoc ARth) (ARdistr_l  ARth)
+             (ARopp_mul_l ARth) (ARopp_add  ARth) 
+             (ARsub_def  ARth) .
+
+ (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R. 
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+ (* sign function *)
+ Variable get_sign : C -> option C.
+ Variable get_sign_spec : sign_theory ropp req phi get_sign.
+
+Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow).
+Notation Nnorm := (norm_subst cO cI cadd cmul csub copp ceqb).
+
+Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign).
+Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign).
+
+(* add abstract semi-ring to help with some proofs *)
+Add Ring Rring : (ARth_SRth ARth).
+
+
+(* additional ring properties *)
+
+Lemma rsub_0_l : forall r, 0 - r == - r.
+intros; rewrite (ARsub_def ARth) in |- *;ring.
+Qed.
+
+Lemma rsub_0_r : forall r, r - 0 == r.
+intros; rewrite (ARsub_def ARth) in |- *.
+rewrite (ARopp_zero Rsth Reqe ARth) in |- *;  ring.
+Qed.
+
+(***************************************************************************
+                                                                          
+                       Properties of division                             
+                                                                          
+  ***************************************************************************)
+ 
+Theorem rdiv_simpl: forall p q, ~ q == 0 ->  q * (p / q) == p.
+intros p q H.
+rewrite rdiv_def in |- *.
+transitivity (/ q * q * p); [  ring | idtac ].
+rewrite rinv_l in |- *; auto.
+Qed.
+Hint Resolve rdiv_simpl .
+ 
+Theorem SRdiv_ext:
+ forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 ->  p1 / q1 == p2 / q2.
+intros p1 p2 H q1 q2 H0.
+transitivity (p1 * / q1); auto.
+transitivity (p2 * / q2); auto.
+Qed.
+Hint Resolve SRdiv_ext .
+
+ Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed.
+
+Lemma rmul_reg_l : forall p q1 q2,
+  ~ p == 0 -> p * q1 == p * q2 -> q1 == q2.
+intros.
+rewrite <- (@rdiv_simpl q1 p) in |- *; trivial.
+rewrite <- (@rdiv_simpl q2 p) in |- *; trivial.
+repeat rewrite rdiv_def in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+auto.
+Qed.
+
+Theorem field_is_integral_domain : forall r1 r2,
+  ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0.
+Proof.
+red in |- *; intros.
+apply H0.
+transitivity (1 * r2); auto.
+transitivity (/ r1 * r1 * r2); auto.
+rewrite <- (ARmul_assoc ARth) in |- *.
+rewrite H1 in |- *.
+apply ARmul_0_r with (1 := Rsth) (2 := ARth).
+Qed.
+
+Theorem ropp_neq_0 : forall r,
+  ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0.
+intros.
+setoid_replace (- r) with (- (1) * r).
+ apply field_is_integral_domain; trivial.
+ rewrite <- (ARopp_mul_l ARth) in |- *.
+   rewrite (ARmul_1_l ARth) in |- *.
+   reflexivity.
+Qed.
+
+Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1.
+intros.
+rewrite (AFdiv_def AFth) in |- *.
+rewrite (ARmul_comm ARth) in |- *.
+apply (AFinv_l AFth).
+trivial.
+Qed.
+
+Theorem rdiv1: forall r,  r == r / 1.
+intros r; transitivity (1 * (r / 1)); auto.
+Qed.
+ 
+Theorem rdiv2:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4).
+Proof.
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * r4); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
+apply (Radd_ext Reqe).
+ transitivity (r2 * (r1 / r2) * r4); [  ring | auto ].
+ transitivity (r2 * (r4 * (r3 / r4))); auto.
+   transitivity (r2 * r3); auto.
+Qed.
+
+
+Theorem rdiv2b:
+ forall r1 r2 r3 r4 r5,
+ ~ (r2*r5) == 0 ->
+ ~ (r4*r5) == 0 ->
+ r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)).
+Proof.
+intros r1 r2 r3 r4 r5 H H0.
+assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring).
+assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring).
+assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring).
+assert (HH4: ~ r2 * (r4 * r5) == 0) 
+   by complete (repeat apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * (r4 * r5)); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
+apply (Radd_ext Reqe).
+ transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [  ring | auto ].
+ transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [  ring | auto ].
+Qed.
+
+Theorem rdiv5: forall r1 r2,  - (r1 / r2) == - r1 / r2.
+intros r1 r2.
+transitivity (- (r1 * / r2)); auto.
+transitivity (- r1 * / r2); auto.
+Qed.
+Hint Resolve rdiv5 .
+
+Theorem rdiv3:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ r1 / r2 - r3 / r4 == (r1 * r4 -  r3 * r2) / (r2 * r4).
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
+transitivity (r1 / r2 + - (r3 / r4)); auto.
+transitivity (r1 / r2 + - r3 / r4); auto.
+transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto.
+apply rdiv2; auto.
+apply SRdiv_ext; auto.
+transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
+Qed.
+
+
+Theorem rdiv3b:
+ forall r1 r2 r3 r4 r5,
+ ~ (r2 * r5) == 0 ->
+ ~ (r4 * r5) == 0 ->
+ r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)).
+Proof.
+intros r1 r2 r3 r4 r5 H H0.
+transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto.
+transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto.
+transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))).
+apply rdiv2b; auto; try ring.
+apply (SRdiv_ext); auto.
+transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
+Qed.
+
+Theorem rdiv6:
+ forall r1 r2,
+ ~ r1 == 0 -> ~ r2 == 0 ->  / (r1 / r2) == r2 / r1.
+intros r1 r2 H H0.
+assert (~ r1 / r2 == 0) as Hk.
+ intros H1; case H.
+   transitivity (r2 * (r1 / r2)); auto.
+   rewrite H1 in |- *;  ring.
+ apply rmul_reg_l with (r1 / r2); auto.
+   transitivity (/ (r1 / r2) * (r1 / r2)); auto.
+   transitivity 1; auto.
+   repeat rewrite rdiv_def in |- *.
+   transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac |  ring ].
+   repeat rewrite rinv_l in |- *; auto.
+Qed.
+Hint Resolve rdiv6 .
+ 
+ Theorem rdiv4:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4).
+Proof.
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * r4); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [  ring | idtac ].
+repeat rewrite rdiv_simpl in |- *; trivial.
+Qed.
+
+ Theorem rdiv7:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r3 == 0 ->
+ ~ r4 == 0 ->
+ (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3).
+Proof.
+intros.
+rewrite (rdiv_def (r1 / r2)) in |- *.
+rewrite rdiv6 in |- *; trivial.
+apply rdiv4; trivial.
+Qed.
+
+Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 ->  r1 / r2 == 0.
+intros r1 r2 H H0.
+transitivity (r1 * / r2); auto.
+transitivity (0 * / r2); auto.
+Qed.
+
+
+Theorem cross_product_eq : forall r1 r2 r3 r4,
+  ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4.
+intros.
+transitivity (r1 / r2 * (r4 / r4)).
+ rewrite rdiv_r_r in |- *; trivial.
+   symmetry  in |- *.
+   apply (ARmul_1_r Rsth ARth).
+ rewrite rdiv4 in |- *; trivial.
+   rewrite H1 in |- *.
+   rewrite (ARmul_comm ARth r2 r4) in |- *.
+   rewrite <- rdiv4 in |- *; trivial.
+   rewrite rdiv_r_r in |- *.
+  trivial.
+  apply (ARmul_1_r Rsth ARth).
+Qed.
+
+(***************************************************************************
+                                                                          
+                       Some equality test                             
+                                                                          
+  ***************************************************************************)
+
+Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool :=
+ match p1, p2 with
+   xH, xH => true
+  | xO p3, xO p4 => positive_eq p3 p4
+  | xI p3, xI p4 => positive_eq p3 p4
+  | _, _ => false
+ end.
+ 
+Theorem positive_eq_correct:
+ forall p1 p2,  if positive_eq p1 p2 then p1 = p2 else p1 <> p2.
+intros p1; elim p1;
+ (try (intros p2; case p2; simpl; auto; intros; discriminate)).
+intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
+generalize (rec p4); case (positive_eq p3 p4); auto.
+intros H1; apply f_equal with ( f := xI ); auto.
+intros H1 H2; case H1; injection H2; auto.
+intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
+generalize (rec p4); case (positive_eq p3 p4); auto.
+intros H1; apply f_equal with ( f := xO ); auto.
+intros H1 H2; case H1; injection H2; auto.
+Qed.
+ 
+Definition N_eq n1 n2 := 
+  match n1, n2 with
+  | N0, N0 => true
+  | Npos p1, Npos p2 => positive_eq p1 p2
+  | _, _ => false
+  end.
+
+Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2.
+Proof.
+  intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail).
+  assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2);
+     [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial].
+Qed.
+
+(* equality test *)
+Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
+ match e1, e2 with
+   PEc c1, PEc c2 => ceqb c1 c2
+  | PEX p1, PEX p2 => positive_eq p1 p2
+  | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
+  | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
+  | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
+  | PEopp e3, PEopp e4 => PExpr_eq e3 e4
+  | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false
+  | _, _ => false
+ end.
+ 
+Add Morphism (pow_pos rmul) : pow_morph.
+intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH].
+Qed.
+
+Add Morphism (pow_N rI rmul) : pow_N_morph.
+intros x y H [|p];simpl;auto. apply pow_morph;trivial.
+Qed.
+(*
+Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n).
+Proof.
+  intros; repeat rewrite pow_th.(rpow_pow_N).
+  destruct n;simpl. apply eq_refl.
+  induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl.
+Qed.
+*)
+Theorem PExpr_eq_semi_correct:
+ forall l e1 e2, PExpr_eq e1 e2 = true ->  NPEeval l e1 == NPEeval l e2.
+intros l e1; elim e1.
+intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)).
+intros c2; apply (morph_eq CRmorph).
+intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)).
+intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2);
+ (try (intros; discriminate)); intros H; rewrite H; auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))).
+intros e4; generalize (rec e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); auto.
+intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))).
+intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4);
+intros;try discriminate.
+repeat rewrite  pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto.
+Qed.
+
+(* add *)
+Definition NPEadd e1 e2 :=
+  match e1, e2 with
+    PEc c1, PEc c2 => PEc (cadd c1 c2)
+  | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2
+  |  _, PEc c => if ceqb c cO then e1 else PEadd e1 e2
+    (* Peut t'on factoriser ici ??? *)
+  | _, _ => PEadd e1 e2
+  end.
+
+Theorem NPEadd_correct:
+ forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2).
+Proof.
+intros l e1 e2.
+destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl;
+ try ring [(morph0 CRmorph)].
+ apply (morph_add CRmorph).
+Qed.
+
+Definition NPEpow x n :=
+  match n with
+  | N0 => PEc cI
+  | Npos p =>
+    if positive_eq p xH then x else
+    match x with 
+    | PEc c => 
+      if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p)  
+    | _ => PEpow x n         
+    end
+  end.
+
+Theorem NPEpow_correct : forall l e n,
+  NPEeval l (NPEpow e n) == NPEeval l (PEpow e n).
+Proof.
+ destruct n;simpl.
+ rewrite pow_th.(rpow_pow_N);simpl;auto.
+ generalize (positive_eq_correct p xH).
+ destruct (positive_eq p 1);intros.
+ rewrite H;rewrite  pow_th.(rpow_pow_N). trivial.
+ clear H;destruct e;simpl;auto.
+ repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl.
+ symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)].
+ symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)].
+ induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp].
+Qed.
+
+(* mul *) 
+Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
+  match x, y with
+    PEc c1, PEc c2 => PEc (cmul c1 c2)
+  | PEc c, _ =>
+      if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y
+  |  _, PEc c =>
+      if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y
+  | PEpow e1 n1, PEpow e2 n2 =>
+      if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y
+  | _, _ => PEmul x y
+  end.
+
+Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
+induction p;simpl;auto;try ring [IHp].
+Qed.
+          
+Theorem NPEmul_correct : forall l e1 e2,
+  NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2).
+induction e1;destruct e2; simpl in |- *;try reflexivity;
+ repeat apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity;
+ try ring [(morph0 CRmorph) (morph1 CRmorph)].
+ apply (morph_mul CRmorph).
+assert (H:=N_eq_correct n n0);destruct (N_eq n n0).
+rewrite NPEpow_correct. simpl.
+repeat rewrite pow_th.(rpow_pow_N).
+rewrite IHe1;rewrite <- H;destruct n;simpl;try ring.
+apply pow_pos_mul.
+simpl;auto.
+Qed.
+
+(* sub *)
+Definition NPEsub e1 e2 :=
+  match e1, e2 with
+    PEc c1, PEc c2 => PEc (csub c1 c2)
+  | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2
+  |  _, PEc c => if ceqb c cO then e1 else PEsub e1 e2
+     (* Peut-on factoriser ici *)
+  | _, _ => PEsub e1 e2
+  end.
+
+Theorem NPEsub_correct:
+ forall l e1 e2,  NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2).
+intros l e1 e2.
+destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;
+ try rewrite (morph0 CRmorph) in |- *; try reflexivity;
+ try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r).
+apply (morph_sub CRmorph).
+Qed.
+ 
+(* opp *)
+Definition NPEopp e1 :=
+  match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end.
+ 
+Theorem NPEopp_correct:
+ forall l e1,  NPEeval l (NPEopp e1) == NPEeval l (PEopp e1).
+intros l e1; case e1; simpl; auto.
+intros; apply (morph_opp CRmorph).
+Qed.
+ 
+(* simplification *)
+Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
+ match e with
+   PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2)
+  | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2)
+  | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2)
+  | PEopp e1 => NPEopp (PExpr_simp e1)
+  | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1
+  | _ => e
+ end.
+ 
+Theorem PExpr_simp_correct:
+ forall l e,  NPEeval l (PExpr_simp e) == NPEeval l e.
+intros l e; elim e; simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEadd_correct.
+simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEsub_correct.
+simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEmul_correct.
+simpl; auto.
+intros e1 He1.
+transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto.
+apply NPEopp_correct.
+simpl; auto.
+intros e1 He1 n;simpl.
+rewrite NPEpow_correct;simpl.
+repeat rewrite pow_th.(rpow_pow_N).
+rewrite He1;auto.
+Qed.
+
+
+(****************************************************************************
+                                                                          
+                               Datastructure                              
+                                                                          
+  ***************************************************************************)
+
+(* The input: syntax of a field expression *)
+
+Inductive FExpr : Type :=
+   FEc: C ->  FExpr
+ | FEX: positive ->  FExpr
+ | FEadd: FExpr -> FExpr ->  FExpr
+ | FEsub: FExpr -> FExpr ->  FExpr
+ | FEmul: FExpr -> FExpr ->  FExpr
+ | FEopp: FExpr ->  FExpr
+ | FEinv: FExpr ->  FExpr
+ | FEdiv: FExpr -> FExpr ->  FExpr
+ | FEpow: FExpr -> N -> FExpr .
+ 
+Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
+  match pe with
+  | FEc c     => phi c
+  | FEX x     => BinList.nth 0 x l
+  | FEadd x y => FEeval l x + FEeval l y
+  | FEsub x y => FEeval l x - FEeval l y
+  | FEmul x y => FEeval l x * FEeval l y
+  | FEopp x   => - FEeval l x
+  | FEinv x   => / FEeval l x
+  | FEdiv x y => FEeval l x / FEeval l y
+  | FEpow x n => rpow (FEeval l x) (Cp_phi n)
+  end.
+
+(* The result of the normalisation *)
+ 
+Record linear : Type := mk_linear {
+   num : PExpr C;
+   denum : PExpr C;
+   condition : list (PExpr C) }.
+
+(***************************************************************************
+
+                Semantics and properties of side condition
+
+  ***************************************************************************)
+ 
+Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop :=
+  match le with
+  | nil => True
+  | e1 :: nil => ~ req (NPEeval l e1) rO
+  | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1
+  end.
+
+Theorem PCond_cons_inv_l :
+   forall l a l1, PCond l (a::l1) ->  ~ NPEeval l a == 0.
+intros l a l1 H.
+destruct l1; simpl in H |- *; trivial.
+destruct H; trivial.
+Qed.
+ 
+Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) ->  PCond l l1.
+intros l a l1 H.
+destruct l1; simpl in H |- *; trivial.
+destruct H; trivial.
+Qed.
+
+Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l1.
+intros l l1 l2; elim l1; simpl app in |- *.
+ simpl in |- *; auto.
+ destruct l0; simpl in *.
+  destruct l2; firstorder.
+  firstorder.
+Qed.
+ 
+Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l2.
+intros l l1 l2; elim l1; simpl app; auto.
+intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ).
+Qed.
+ 
+(* An unsatisfiable condition: issued when a division by zero is detected *)
+Definition absurd_PCond := cons (PEc cO) nil.
+
+Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond.
+unfold absurd_PCond in |- *; simpl in |- *.
+red in |- *; intros.
+apply H.
+apply (morph0 CRmorph).
+Qed.
+
+(***************************************************************************
+                                                                          
+                               Normalisation                              
+                                                                          
+  ***************************************************************************)
+
+Fixpoint isIn (e1:PExpr C)  (p1:positive)
+                      (e2:PExpr C)  (p2:positive) {struct e2}: option (N * PExpr C) :=
+  match e2 with
+  | PEmul e3 e4 =>
+       match isIn e1 p1 e3 p2 with
+       | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2)))
+       | Some (Npos p, e5) => 
+          match isIn e1 p e4 p2 with
+          | Some (n, e6) => Some (n, NPEmul e5 e6)
+          | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2)))
+          end
+       | None => 
+         match isIn e1 p1 e4 p2 with
+         | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5)
+         | None => None
+         end
+       end
+  | PEpow e3 N0 => None 
+  | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2)
+  | _ =>
+     if  PExpr_eq e1 e2 then
+         match Zminus (Zpos p1) (Zpos p2) with
+          | Zpos p => Some (Npos p, PEc cI)
+          | Z0 => Some (N0, PEc cI)
+          | Zneg p => Some (N0, NPEpow e2 (Npos p))
+          end
+     else None 
+   end.
+ 
+ Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
+ Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
+
+ Notation pow_pos_plus :=  (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) 
+                        ARth.(ARmul_comm) ARth.(ARmul_assoc)).
+
+ Lemma isIn_correct_aux : forall l e1 e2 p1 p2, 
+  match 
+      (if  PExpr_eq e1 e2 then
+         match Zminus (Zpos p1) (Zpos p2) with
+          | Zpos p => Some (Npos p, PEc cI)
+          | Z0 => Some (N0, PEc cI)
+          | Zneg p => Some (N0, NPEpow e2 (Npos p))
+          end
+     else None) 
+   with
+   | Some(n, e3) => 
+       NPEeval l (PEpow e2 (Npos p2)) == 
+       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
+       (Zpos p1 > NtoZ n)%Z
+   |  _ => True
+  end.
+Proof.
+  intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2);
+   case (PExpr_eq e1 e2); simpl; auto; intros H.
+  case_eq ((p1 ?= p2)%positive Eq);intros;simpl. 
+  repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _).
+  rewrite (Pcompare_Eq_eq _ _ H0).  
+  rewrite H;[trivial | ring [ (morph1 CRmorph)]].
+  fold (NPEpow e2 (Npos (p2 - p1))).
+  rewrite NPEpow_correct;simpl.
+  repeat rewrite pow_th.(rpow_pow_N);simpl.
+  rewrite H;trivial. split. 2:refine (refl_equal _).
+  rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. 
+  repeat rewrite pow_th.(rpow_pow_N);simpl.
+  rewrite H;trivial.
+   change (ZtoN
+     match (p1 ?= p1 - p2)%positive Eq with
+     | Eq => 0
+     | Lt => Zneg (p1 - p2 - p1)
+     | Gt => Zpos (p1 - (p1 - p2))
+     end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))).
+  replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z.
+  split.
+  repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth).
+  rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl.
+  ring [ (morph1 CRmorph)].
+ assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). 
+ apply Zplus_gt_reg_l with (Zpos p2).
+ rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z.
+ apply Zplus_gt_compat_r. refine (refl_equal _).
+ simpl;rewrite H0;trivial.
+Qed.
+
+Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2).
+induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl.
+ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto.
+Qed.
+
+
+Theorem isIn_correct: forall l e1 p1 e2 p2,
+  match isIn e1 p1 e2 p2 with 
+   | Some(n, e3) => 
+       NPEeval l (PEpow e2 (Npos p2)) == 
+       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
+        (Zpos p1 > NtoZ n)%Z
+   |  _ => True
+  end.
+Proof.
+Opaque NPEpow.
+intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros;
+  try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn.
+generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3.
+destruct n. 
+  simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl.
+  repeat rewrite pow_th.(rpow_pow_N);simpl.
+  rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial].
+  generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5.
+  destruct n;simpl.
+    rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl.
+    intros (H1,H2) (H3,H4).
+    unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3.
+    rewrite pow_pos_mul. rewrite H1;rewrite H3.
+    assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
+        (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == 
+        pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) *
+        NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H.
+   rewrite <- pow_pos_plus. rewrite Pplus_minus.
+   split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial.
+   repeat rewrite pow_th.(rpow_pow_N);simpl. 
+   intros (H1,H2) (H3,H4).
+   unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3.
+   rewrite H2 in H1;simpl in H1.
+   assert (Zpos p1 > Zpos p6)%Z.
+     apply Zgt_trans with (Zpos p4). exact H4. exact H2.
+  unfold Zgt in H;simpl in H;rewrite H.
+  split. 2:exact H.
+  rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3.
+  assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
+                (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) ==
+             pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) *
+                NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0.
+  rewrite <- pow_pos_plus.
+  replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. 
+ rewrite NPEmul_correct. simpl;ring.
+  assert 
+     (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
+ change  ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
+ rewrite <- Zplus_assoc. rewrite (Zplus_assoc  (- Zpos p4)).
+ simpl. rewrite Pcompare_refl. reflexivity.
+ unfold Zminus, Zopp in H0. simpl in H0.
+  rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial.
+ simpl. repeat rewrite pow_th.(rpow_pow_N). 
+ intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3.
+ rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
+ simpl in H2. rewrite pow_th.(rpow_pow_N);simpl.
+ rewrite pow_pos_mul. split. ring [H2]. exact H3.
+ generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3.
+ destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
+ repeat rewrite pow_th.(rpow_pow_N);simpl.
+ intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1].
+ rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
+ repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul.
+ intros (H1, H2);rewrite H1;split.
+   unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1.
+   simpl in H1;ring [H1]. trivial. 
+ trivial. 
+ destruct n. trivial.
+ generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3.
+ destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl.
+ intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial.
+ repeat rewrite pow_th.(rpow_pow_N). simpl.
+ intros (H1,H2);split;trivial.
+ rewrite pow_pos_pow_pos;trivial.
+ trivial.
+Qed.
+
+Record rsplit : Type := mk_rsplit {
+   rsplit_left : PExpr C;
+   rsplit_common : PExpr C;
+   rsplit_right : PExpr C}.
+
+(* Stupid name clash *)
+Notation left := rsplit_left.
+Notation right := rsplit_right.
+Notation common := rsplit_common.
+
+Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit :=
+  match e1 with
+  | PEmul e3 e4 =>
+      let r1 := split_aux e3 p e2 in
+      let r2 := split_aux e4 p (right r1) in
+          mk_rsplit (NPEmul (left r1) (left r2))
+                    (NPEmul (common r1) (common r2))
+                    (right r2)
+  | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2
+  | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2      
+  | _ => 
+       match isIn e1 p e2 xH with
+       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 
+       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
+       | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2
+       end
+  end. 
+
+Lemma split_aux_correct_1 : forall l e1 p e2,
+  let res :=  match isIn e1 p e2 xH with
+       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 
+       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
+       | None => mk_rsplit (NPEpow e1  (Npos p)) (PEc cI) e2
+       end in
+       NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res))
+   /\
+       NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)).
+Proof.
+ intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH).
+ destruct (isIn e1 p e2 1). destruct p0.
+ Opaque NPEpow NPEmul.
+  destruct n;simpl; 
+    (repeat rewrite NPEmul_correct;simpl;
+     repeat rewrite NPEpow_correct;simpl;
+     repeat rewrite pow_th.(rpow_pow_N);simpl).
+  intros (H, Hgt);split;try ring [H CRmorph.(morph1)].
+  intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H.
+  simpl in H;split;try ring [H].
+  rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial.
+  simpl;intros. repeat rewrite NPEmul_correct;simpl.
+  rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)].
+Qed.
+
+Theorem split_aux_correct: forall l e1 p e2,
+  NPEeval l (PEpow e1 (Npos p)) == 
+       NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2)))
+/\
+  NPEeval l  e2 == NPEeval l (NPEmul (right (split_aux e1 p e2))
+                                   (common (split_aux e1 p e2))).
+Proof.
+intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl.
+generalize (IHe1_1 k e2); clear IHe1_1.
+generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. 
+simpl. repeat (rewrite NPEmul_correct;simpl).
+repeat rewrite pow_th.(rpow_pow_N);simpl. 
+intros (H1,H2) (H3,H4);split.
+rewrite pow_pos_mul. rewrite H1;rewrite H3. ring.
+rewrite H4;rewrite H2;ring.
+destruct n;simpl.
+split. repeat rewrite pow_th.(rpow_pow_N);simpl.
+rewrite NPEmul_correct. simpl.
+ induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)].
+ rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)].
+generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl.
+repeat rewrite NPEmul_correct;simpl.
+repeat rewrite pow_th.(rpow_pow_N);simpl.
+rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2].
+Qed.
+
+Definition split e1 e2 := split_aux e1 xH e2.
+ 
+Theorem split_correct_l: forall l e1 e2,
+  NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2))
+                                   (common (split e1 e2))).
+Proof.
+intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl.
+rewrite pow_th.(rpow_pow_N);simpl;auto.
+Qed.
+
+Theorem split_correct_r: forall l e1 e2,
+  NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2))
+                                   (common (split e1 e2))).
+Proof.
+intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto.
+Qed.
+
+Fixpoint Fnorm (e : FExpr) : linear := 
+  match e with
+  | FEc c => mk_linear (PEc c) (PEc cI) nil
+  | FEX x => mk_linear (PEX C x) (PEc cI) nil
+  | FEadd e1 e2 =>
+      let x := Fnorm e1 in
+      let y := Fnorm e2 in
+      let s := split (denum x) (denum y) in
+      mk_linear
+        (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
+        (NPEmul (left s) (NPEmul (right s) (common s)))
+        (condition x ++ condition y)
+ 
+  | FEsub e1 e2 =>
+      let x := Fnorm e1 in
+      let y := Fnorm e2 in
+      let s := split (denum x) (denum y) in
+      mk_linear
+        (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
+        (NPEmul (left s) (NPEmul (right s) (common s)))
+        (condition x ++ condition y)
+  | FEmul e1 e2 =>
+      let x := Fnorm e1 in
+      let y := Fnorm e2 in
+      mk_linear (NPEmul (num x) (num y))
+        (NPEmul (denum x) (denum y))
+        (condition x ++ condition y)
+  | FEopp e1 =>
+      let x := Fnorm e1 in
+      mk_linear (NPEopp (num x)) (denum x) (condition x)
+  | FEinv e1 =>
+      let x := Fnorm e1 in
+      mk_linear (denum x) (num x) (num x :: condition x)
+  | FEdiv e1 e2 =>
+      let x := Fnorm e1 in
+      let y := Fnorm e2 in
+      mk_linear (NPEmul (num x) (denum y))
+        (NPEmul (denum x) (num y))
+        (num y :: condition x ++ condition y)
+  | FEpow e1 n =>
+      let x := Fnorm e1 in
+      mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x)
+  end.
+
+
+(* Example *)
+(*
+Eval compute
+   in (Fnorm
+        (FEdiv
+          (FEc cI)
+          (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))).
+*)
+
+ Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0.
+Proof.
+ induction p;simpl.
+  intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H).
+  apply IHp.
+  rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp). rewrite H1. rewrite Hp;ring. ring.
+  reflexivity. 
+  intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
+  rewrite Hp;ring. reflexivity. trivial.
+Qed.
+ 
+Theorem Pcond_Fnorm:
+ forall l e,
+ PCond l (condition (Fnorm e)) ->  ~ NPEeval l (denum (Fnorm e)) == 0.
+intros l e; elim e.
+ simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
+ simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   rewrite NPEmul_correct in |- *.
+   simpl in |- *.
+   apply field_is_integral_domain.
+   intros HH; case Hrec1; auto.
+     apply PCond_app_inv_l with (1 := Hcond).
+   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
+   rewrite NPEmul_correct; simpl; rewrite HH; ring.
+   intros HH; case Hrec2; auto.
+     apply PCond_app_inv_r with (1 := Hcond).
+   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   rewrite NPEmul_correct in |- *.
+   simpl in |- *.
+   apply field_is_integral_domain.
+   intros HH; case Hrec1; auto.
+     apply PCond_app_inv_l with (1 := Hcond).
+   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
+   rewrite NPEmul_correct; simpl; rewrite HH; ring.
+   intros HH; case Hrec2; auto.
+     apply PCond_app_inv_r with (1 := Hcond).
+   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   rewrite NPEmul_correct in |- *.
+   simpl in |- *.
+   apply field_is_integral_domain.
+  apply Hrec1.
+    apply PCond_app_inv_l with (1 := Hcond).
+  apply Hrec2.
+    apply PCond_app_inv_r with (1 := Hcond).
+ intros e1 Hrec1 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   auto.
+ intros e1 Hrec1 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   apply PCond_cons_inv_l with (1:=Hcond).
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+   simpl condition in Hcond.
+   simpl denum in |- *.
+   rewrite NPEmul_correct in |- *.
+   simpl in |- *.
+   apply field_is_integral_domain.
+  apply Hrec1.
+    specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
+    apply PCond_app_inv_l with (1 := Hcond1).
+   apply PCond_cons_inv_l with (1:=Hcond).
+ simpl;intros e1 Hrec1 n Hcond.
+  rewrite NPEpow_correct.
+  simpl;rewrite pow_th.(rpow_pow_N).
+  destruct n;simpl;intros.
+  apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto.
+Qed.
+Hint Resolve Pcond_Fnorm.
+
+
+(***************************************************************************
+                                                                          
+                       Main theorem                                       
+                                                                          
+  ***************************************************************************)
+
+Theorem Fnorm_FEeval_PEeval:
+ forall l fe,
+ PCond l (condition (Fnorm fe)) ->
+ FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)).
+Proof.
+intros l fe; elim fe; simpl.
+intros c H; rewrite CRmorph.(morph1); apply rdiv1.
+intros p H; rewrite CRmorph.(morph1); apply rdiv1.
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+rewrite NPEadd_correct; simpl.
+repeat rewrite NPEmul_correct; simpl.
+generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
+   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2; rewrite U1; rewrite U2.
+apply rdiv2b; auto.
+  rewrite <- U1; auto.
+  rewrite <- U2; auto.
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+rewrite NPEsub_correct; simpl.
+repeat rewrite NPEmul_correct; simpl.
+generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
+   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2; rewrite U1; rewrite U2.
+apply rdiv3b; auto.
+  rewrite <- U1; auto.
+  rewrite <- U2; auto.
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+repeat rewrite NPEmul_correct; simpl.
+apply rdiv4; auto.
+
+intros e1 He1 HH.
+rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto.
+
+intros e1 He1 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_cons_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); apply rdiv6; auto.
+apply PCond_cons_inv_l with ( 1 := HH ).
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with (condition (Fnorm e2)).
+apply PCond_cons_inv_r with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with (condition (Fnorm e1)).
+apply PCond_cons_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+repeat rewrite NPEmul_correct;simpl.
+apply rdiv7; auto.
+apply PCond_cons_inv_l with ( 1 := HH ).
+
+intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1.
+repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N).
+rewrite He1';clear He1'.
+destruct n;simpl. apply rdiv1.
+generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1)))
+  (Pcond_Fnorm _ _ Hcond).
+intros r r0 Hdiff;induction p;simpl.
+repeat (rewrite <- rdiv4;trivial).
+intro Hp;apply (pow_pos_not_0 Hdiff  p). 
+rewrite  (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p)  0).
+ apply pow_pos_not_0;trivial. ring [Hp]. reflexivity.
+apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
+rewrite IHp;reflexivity.
+rewrite <- rdiv4;trivial. apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
+rewrite IHp;reflexivity.
+reflexivity.
+Qed.
+
+Theorem Fnorm_crossproduct:
+ forall l fe1 fe2,
+ let nfe1 := Fnorm fe1 in
+ let nfe2 := Fnorm fe2 in
+ NPEeval l (PEmul (num nfe1) (denum nfe2)) ==
+ NPEeval l (PEmul (num nfe2) (denum nfe1)) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
+rewrite Fnorm_FEeval_PEeval in |- *.
+ apply PCond_app_inv_l with (1 := Hcond).
+ rewrite Fnorm_FEeval_PEeval in |- *.
+  apply PCond_app_inv_r with (1 := Hcond).
+  apply cross_product_eq; trivial.
+   apply Pcond_Fnorm.
+     apply PCond_app_inv_l with (1 := Hcond).
+   apply Pcond_Fnorm.
+     apply PCond_app_inv_r with (1 := Hcond).
+Qed.
+
+(* Correctness lemmas of reflexive tactics *)
+Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow).
+Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb).
+
+Theorem Fnorm_correct:
+ forall n l lpe fe,
+  Ninterp_PElist l lpe ->
+  Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true ->
+  PCond l (condition (Fnorm fe)) ->  FEeval l fe == 0.
+intros n l lpe fe Hlpe H H1;
+ apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1).
+apply rdiv8; auto.
+transitivity (NPEeval l (PEc cO)); auto.
+rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th n l lpe);auto.
+change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)).
+apply (Peq_ok Rsth Reqe CRmorph);auto.
+simpl. apply (morph0 CRmorph); auto.
+Qed.
+
+(* simplify a field expression into a fraction *)
+(* TODO: simplify when den is constant... *)
+Definition display_linear l num den :=
+  NPphi_dev l num / NPphi_dev l den.
+
+Definition display_pow_linear l num den :=
+  NPphi_pow l num / NPphi_pow l den.
+
+Theorem Field_rw_correct :
+ forall n lpe l,
+   Ninterp_PElist l lpe ->
+   forall lmp, Nmk_monpol_list lpe = lmp ->
+   forall fe nfe, Fnorm fe = nfe ->
+   PCond l (condition nfe) ->
+   FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+Proof.
+  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
+  unfold display_linear; apply SRdiv_ext;
+  eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto.
+Qed.
+
+Theorem Field_rw_pow_correct :
+ forall n lpe l,
+   Ninterp_PElist l lpe ->
+   forall lmp, Nmk_monpol_list lpe = lmp ->
+   forall fe nfe, Fnorm fe = nfe ->
+   PCond l (condition nfe) ->
+   FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+Proof.
+  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
+  unfold display_pow_linear; apply SRdiv_ext;
+  eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto.
+Qed.
+
+Theorem Field_correct :
+ forall n l lpe fe1 fe2, Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2)))
+          (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp.
+apply Fnorm_crossproduct; trivial.
+eapply (ring_correct Rsth Reqe ARth CRmorph); eauto.
+Qed.
+
+(* simplify a field equation : generate the crossproduct and simplify
+   polynomials *)
+Theorem Field_simplify_eq_old_correct :
+ forall l fe1 fe2 nfe1 nfe2,
+ Fnorm fe1 = nfe1 ->
+ Fnorm fe2 = nfe2 ->
+ NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) ==
+ NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond;  subst nfe1 nfe2.
+apply Fnorm_crossproduct; trivial.
+match goal with 
+ [ |- NPEeval l ?x == NPEeval l ?y] =>
+    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec
+       O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x)));
+    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec
+       O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y)))
+ end.
+trivial.
+Qed.
+
+Theorem Field_simplify_eq_correct :
+ forall n l lpe fe1 fe2,
+    Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den -> 
+ NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
+ NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
+  subst nfe1 nfe2 den lmp.
+apply Fnorm_crossproduct; trivial.
+simpl in |- *.
+rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite NPEmul_correct in |- *.
+rewrite NPEmul_correct in |- *.
+simpl in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+rewrite <-(
+  let x := PEmul (num (Fnorm fe1))
+                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
+ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+        Hlpe (refl_equal (Nmk_monpol_list lpe))
+        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+rewrite <-(
+  let x := (PEmul (num (Fnorm fe2))
+                     (rsplit_left
+                        (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
+    ring_rw_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+        Hlpe (refl_equal (Nmk_monpol_list lpe))
+        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+simpl in Hcrossprod.
+rewrite Hcrossprod in |- *.
+reflexivity.
+Qed.
+
+Theorem Field_simplify_eq_pow_correct :
+ forall n l lpe fe1 fe2,
+    Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den -> 
+ NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
+ NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
+  subst nfe1 nfe2 den lmp.
+apply Fnorm_crossproduct; trivial.
+simpl in |- *.
+rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite NPEmul_correct in |- *.
+rewrite NPEmul_correct in |- *.
+simpl in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+rewrite <-(
+  let x := PEmul (num (Fnorm fe1))
+                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
+ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+        Hlpe (refl_equal (Nmk_monpol_list lpe))
+        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+rewrite <-(
+  let x := (PEmul (num (Fnorm fe2))
+                     (rsplit_left
+                        (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
+    ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th get_sign_spec n lpe l 
+        Hlpe (refl_equal (Nmk_monpol_list lpe))
+        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+simpl in Hcrossprod.
+rewrite Hcrossprod in |- *.
+reflexivity.
+Qed.
+
+Theorem Field_simplify_eq_pow_in_correct :
+ forall n l lpe fe1 fe2,
+    Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den -> 
+ forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
+ forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ FEeval l fe1 == FEeval l fe2 ->
+  PCond l (condition nfe1 ++ condition nfe2) ->
+ NPphi_pow l np1 ==
+ NPphi_pow l np2.
+Proof.
+ intros. subst nfe1 nfe2 lmp np1 np2.
+ repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
+ assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
+ assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
+ apply (@rmul_reg_l (NPEeval l (rsplit_common den))). 
+ intro Heq;apply N1.
+ rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+ rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
+ repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
+ repeat rewrite <- ARth.(ARmul_assoc).
+ change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
+      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
+ change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
+      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
+ repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l.
+ rewrite <- split_correct_r.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
+ ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
+ ring [Heq]. repeat rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe1)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial.
+ rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
+ rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (AFth.(AFdiv_def)).
+ repeat rewrite <- Fnorm_FEeval_PEeval;trivial.
+ apply (PCond_app_inv_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ H7).
+Qed.
+
+Theorem Field_simplify_eq_in_correct :
+forall n l lpe fe1 fe2,
+    Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den -> 
+ forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
+ forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ FEeval l fe1 == FEeval l fe2 ->
+  PCond l (condition nfe1 ++ condition nfe2) ->
+ NPphi_dev l np1 ==
+ NPphi_dev l np2.
+Proof.
+ intros. subst nfe1 nfe2 lmp np1 np2.
+ repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph  get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
+ assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
+ assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
+ apply (@rmul_reg_l (NPEeval l (rsplit_common den))). 
+ intro Heq;apply N1.
+ rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+ rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
+ repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
+ repeat rewrite <- ARth.(ARmul_assoc).
+ change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
+      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
+ change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
+      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
+ repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l.
+ rewrite <- split_correct_r.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
+ ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
+ ring [Heq]. repeat rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe1)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r. trivial.
+ rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
+ rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (AFth.(AFdiv_def)).
+ repeat rewrite <- Fnorm_FEeval_PEeval;trivial.
+ apply (PCond_app_inv_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ H7).
+Qed.
+
+
+Section Fcons_impl.
+
+Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C).
+
+Hypothesis PCond_fcons_inv : forall l a l1,
+  PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
+
+Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
+  match l with
+  | nil => m
+  | cons a l1 => Fcons a (Fapp l1 m)
+  end.
+
+Lemma fcons_correct : forall l l1,
+  PCond l (Fapp l1 nil) -> PCond l l1.
+induction l1; simpl in |- *; intros.
+ trivial.
+ elim PCond_fcons_inv with (1 := H); intros.
+   destruct l1; auto.
+Qed.
+
+End Fcons_impl.
+
+Section Fcons_simpl.
+
+(* Some general simpifications of the condition: eliminate duplicates,
+   split multiplications *)
+
+Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
+ match l with
+   nil       => cons e nil
+ | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1)
+ end.
+ 
+Theorem PFcons_fcons_inv:
+ forall l a l1, PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a l1; elim l1; simpl Fcons; auto.
+simpl; auto.
+intros a0 l0.
+generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0).
+intros H H0 H1; split; auto.
+rewrite H; auto.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+intros H H0 H1;
+ assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
+split.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+apply H0.
+generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
+generalize Hp; case l0; simpl; intuition.
+Qed.
+
+(* equality of normal forms rather than syntactic equality *)
+Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
+ match l with
+   nil       => cons e nil
+ | cons a l1 =>
+     if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1)
+ end.
+ 
+Theorem PFcons0_fcons_inv:
+ forall l a l1, PCond l (Fcons0 a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a l1; elim l1; simpl Fcons0; auto.
+simpl; auto.
+intros a0 l0.
+generalize (ring_correct Rsth Reqe ARth CRmorph pow_th O l nil a a0). simpl.
+  case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)).
+intros H H0 H1; split; auto.
+rewrite H; auto.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+intros H H0 H1;
+ assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
+split.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+apply H0.
+generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
+generalize Hp; case l0; simpl; intuition.
+Qed.
+
+Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
+ match e with
+   PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l)
+ | PEpow e1 _ => Fcons00 e1 l
+ | _ => Fcons0 e l
+ end.
+
+Theorem PFcons00_fcons_inv:
+  forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
+ intros p H p0 H0 l1 H1.
+   simpl in H1.
+   case (H _ H1); intros H2 H3.
+   case (H0 _ H3); intros H4 H5; split; auto.
+   simpl in |- *.
+   apply field_is_integral_domain; trivial.
+   simpl;intros. rewrite pow_th.(rpow_pow_N).
+   destruct (H _ H0);split;auto.
+   destruct n;simpl. apply AFth.(AF_1_neq_0).
+   apply pow_pos_not_0;trivial.
+Qed.
+
+Definition Pcond_simpl_gen := 
+  fcons_correct _ PFcons00_fcons_inv.
+
+
+(* Specific case when the equality test of coefs is complete w.r.t. the
+   field equality: non-zero coefs can be eliminated, and opposite can
+   be simplified (if -1 <> 0) *)
+
+Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true.
+
+Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
+  (phi c1 == phi c2 -> P x) ->
+  (~ phi c1 == phi c2 -> P y) ->
+  P (if ceqb c1 c2 then x else y).
+Proof.
+intros.
+generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
+generalize (@ceqb_complete c1 c2).
+case (c1 ?=! c2); auto; intros.
+apply X0.
+red in |- *; intro.
+absurd (false = true); auto;  discriminate.
+Qed.
+
+Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
+ match e with
+   PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
+ | PEpow e _ => Fcons1 e l 
+ | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l
+ | PEc c => if ceqb c cO then absurd_PCond else l
+ | _ => Fcons0 e l
+ end.
+
+Theorem PFcons1_fcons_inv:
+  forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
+ simpl in |- *; intros c l1.
+   apply ceqb_rect_complete; intros.
+  elim (@absurd_PCond_bottom l H0).
+  split; trivial.
+    rewrite <- (morph0 CRmorph) in |- *; trivial.
+ intros p H p0 H0 l1 H1.
+   simpl in H1.
+   case (H _ H1); intros H2 H3.
+   case (H0 _ H3); intros H4 H5; split; auto.
+   simpl in |- *.
+   apply field_is_integral_domain; trivial.
+ simpl in |- *; intros p H l1.
+   apply ceqb_rect_complete; intros.
+  elim (@absurd_PCond_bottom l H1).
+  destruct (H _ H1).
+    split; trivial.
+    apply ropp_neq_0; trivial.
+    rewrite (morph_opp CRmorph) in H0.
+    rewrite (morph1 CRmorph) in H0.
+    rewrite (morph0 CRmorph) in H0.
+    trivial.
+ intros;simpl. destruct (H _ H0);split;trivial.
+ rewrite pow_th.(rpow_pow_N). destruct n;simpl.
+ apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial.
+Qed.
+
+Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
+ 
+Theorem PFcons2_fcons_inv:
+ forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+unfold Fcons2 in |- *; intros l a l1 H; split;
+ case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto.
+intros H1 H2 H3; case H1.
+transitivity (NPEeval l a); trivial.
+apply PExpr_simp_correct.
+Qed.
+
+Definition Pcond_simpl_complete := 
+  fcons_correct _ PFcons2_fcons_inv.
+
+End Fcons_simpl.
+
+End AlmostField.
+
+Section FieldAndSemiField.
+
+  Record field_theory : Prop := mk_field {
+    F_R : ring_theory rO rI radd rmul rsub ropp req;
+    F_1_neq_0 : ~ 1 == 0;
+    Fdiv_def : forall p q, p / q == p * / q;
+    Finv_l : forall p, ~ p == 0 ->  / p * p == 1
+  }.
+
+  Definition F2AF f :=
+    mk_afield
+      (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l).
+
+  Record semi_field_theory : Prop := mk_sfield {
+    SF_SR : semi_ring_theory rO rI radd rmul req;
+    SF_1_neq_0 : ~ 1 == 0;
+    SFdiv_def : forall p q, p / q == p * / q;
+    SFinv_l : forall p, ~ p == 0 ->  / p * p == 1
+  }.
+
+End FieldAndSemiField.
+
+End MakeFieldPol.
+
+  Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth 
+    (sf:semi_field_theory rO rI radd rmul rdiv rinv req)  :=
+    mk_afield _ _
+      (SRth_ARth Rsth sf.(SF_SR))
+      sf.(SF_1_neq_0)
+      sf.(SFdiv_def)
+      sf.(SFinv_l).
+
+
+Section Complete.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
+ Variable req : R -> R -> Prop.
+  Notation "0" := rO.  Notation "1" := rI.
+  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
+  Notation "x / y " := (rdiv x y).  Notation "/ x" := (rinv x).
+  Notation "x == y" := (req x y) (at level 70, no associativity).
+ Variable Rsth : Setoid_Theory R req.
+   Add Setoid R req Rsth as R_setoid3.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+   Add Morphism radd : radd_ext3.  exact (Radd_ext Reqe). Qed.
+   Add Morphism rmul : rmul_ext3.  exact (Rmul_ext Reqe). Qed.
+   Add Morphism ropp : ropp_ext3.  exact (Ropp_ext Reqe). Qed.
+
+Section AlmostField.
+
+ Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req.
+ Let ARth := AFth.(AF_AR).
+ Let rI_neq_rO := AFth.(AF_1_neq_0).
+ Let rdiv_def := AFth.(AFdiv_def).
+ Let rinv_l := AFth.(AFinv_l).
+
+Hypothesis S_inj : forall x y, 1+x==1+y -> x==y.
+
+Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
+
+Lemma add_inj_r : forall p x y,
+   gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y.
+intros p x y.
+elim p using Pind; simpl in |- *; intros.
+ apply S_inj; trivial.
+ apply H.
+   apply S_inj.
+   repeat rewrite (ARadd_assoc ARth) in |- *.
+   rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial.
+Qed.
+
+Lemma gen_phiPOS_inj : forall x y,
+  gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y ->
+  x = y.
+intros x y.
+repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *.
+ElimPcompare x y; intro.
+ intros.
+   apply Pcompare_Eq_eq; trivial.
+ intro.
+   elim gen_phiPOS_not_0 with (y - x)%positive.
+   apply add_inj_r with x.
+   symmetry  in |- *.
+   rewrite (ARadd_0_r Rsth ARth) in |- *.
+   rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+   rewrite Pplus_minus in |- *; trivial.
+   change Eq with (CompOpp Eq) in |- *.
+   rewrite <- Pcompare_antisym in |- *; trivial.
+   rewrite H in |- *; trivial.
+ intro.
+   elim gen_phiPOS_not_0 with (x - y)%positive.
+   apply add_inj_r with y.
+   rewrite (ARadd_0_r Rsth ARth) in |- *.
+   rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+   rewrite Pplus_minus in |- *; trivial.
+Qed.
+
+
+Lemma gen_phiN_inj : forall x y,
+  gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
+  x = y.
+destruct x; destruct y; simpl in |- *; intros; trivial.
+ elim gen_phiPOS_not_0 with p.
+   symmetry  in |- *.
+   rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
+ rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial.
+Qed.
+
+Lemma gen_phiN_complete : forall x y,
+  gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
+  Neq_bool x y = true.
+intros.
+ replace y with x.
+ unfold Neq_bool in |- *.
+   rewrite Ncompare_refl in |- *; trivial.
+ apply gen_phiN_inj; trivial.
+Qed.
+
+End AlmostField.
+
+Section Field.
+
+ Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req.
+ Let Rth := Fth.(F_R).
+ Let rI_neq_rO := Fth.(F_1_neq_0).
+ Let rdiv_def := Fth.(Fdiv_def).
+ Let rinv_l := Fth.(Finv_l).
+ Let AFth := F2AF Rsth Reqe Fth.
+ Let ARth := Rth_ARth Rsth Reqe Rth.
+
+Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y.
+intros.
+transitivity (x + (1 + - (1))).
+ rewrite (Ropp_def Rth) in |- *.
+   symmetry  in |- *.
+   apply (ARadd_0_r Rsth ARth).
+ transitivity (y + (1 + - (1))).
+  repeat rewrite <- (ARplus_assoc ARth) in |- *.
+    repeat rewrite (ARadd_assoc ARth) in |- *.
+    apply (Radd_ext Reqe).
+   repeat rewrite <- (ARadd_comm ARth 1) in |- *.
+     trivial.
+   reflexivity.
+  rewrite (Ropp_def Rth) in |- *.
+    apply (ARadd_0_r Rsth ARth).
+Qed.
+
+
+ Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
+
+Let gen_phiPOS_inject :=
+   gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0.
+
+Lemma gen_phiPOS_discr_sgn : forall x y,
+  ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y.
+red in |- *; intros.
+apply gen_phiPOS_not_0 with (y + x)%positive.
+rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y).
+ apply (Radd_ext Reqe); trivial.
+  reflexivity.
+  rewrite (same_gen Rsth Reqe ARth) in |- *.
+    rewrite (same_gen Rsth Reqe ARth) in |- *.
+    trivial.
+ apply (Ropp_def Rth).
+Qed.
+
+Lemma gen_phiZ_inj : forall x y,
+  gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
+  x = y.
+destruct x; destruct y; simpl in |- *; intros.
+ trivial.
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   symmetry  in |- *; trivial.
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+   rewrite <- H in |- *.
+   apply (ARopp_zero Rsth Reqe ARth).
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   trivial.
+ rewrite gen_phiPOS_inject  with (1 := H) in |- *; trivial.
+ elim gen_phiPOS_discr_sgn with (1 := H).
+ elim gen_phiPOS_not_0 with p.
+   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+   rewrite H in |- *.
+   apply (ARopp_zero Rsth Reqe ARth).
+ elim gen_phiPOS_discr_sgn with p0 p.
+   symmetry  in |- *; trivial.
+ replace p0 with p; trivial.
+   apply gen_phiPOS_inject.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *.
+   rewrite H in |- *; trivial.
+   reflexivity.
+Qed.
+
+Lemma gen_phiZ_complete : forall x y,
+  gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
+  Zeq_bool x y = true.
+intros.
+ replace y with x.
+ unfold Zeq_bool in |- *.
+   rewrite Zcompare_refl in |- *; trivial.
+ apply gen_phiZ_inj; trivial.
+Qed.
+
+End Field.
+
+End Complete.
diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v
new file mode 100644
index 00000000..bbdcd443
--- /dev/null
+++ b/contrib/setoid_ring/InitialRing.v
@@ -0,0 +1,581 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Require Import ZArith_base.
+Require Import Zpow_def.
+Require Import BinInt.
+Require Import BinNat.
+Require Import Setoid.
+Require Import Ring_theory.
+Require Import Ring_polynom.
+
+Set Implicit Arguments.
+
+Import RingSyntax.
+
+
+(* An object to return when an expression is not recognized as a constant *)
+Definition NotConstant := false.
+
+(** Z is a ring and a setoid*)
+
+Lemma Zsth : Setoid_Theory Z (@eq Z).
+Proof (Eqsth Z).
+ 
+Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z).
+Proof (Eq_ext Zplus Zmult Zopp).
+
+Lemma Zth : ring_theory Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z).
+Proof.
+ constructor. exact Zplus_0_l. exact Zplus_comm. exact Zplus_assoc.
+ exact Zmult_1_l. exact Zmult_comm. exact Zmult_assoc.
+ exact Zmult_plus_distr_l. trivial. exact Zminus_diag.
+Qed.
+
+ Lemma Zeqb_ok : forall x y, Zeq_bool x y = true -> x = y.
+ Proof.
+  intros x y.
+  assert (H := Zcompare_Eq_eq x y);unfold Zeq_bool;
+  destruct (Zcompare x y);intros H1;auto;discriminate H1.
+ Qed.
+
+
+(** Two generic morphisms from Z to (abrbitrary) rings, *)
+(**second one is more convenient for proofs but they are ext. equal*)
+Section ZMORPHISM.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop.
+  Notation "0" := rO.  Notation "1" := rI.
+  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
+  Notation "x == y" := (req x y).
+  Variable Rsth : Setoid_Theory R req.
+     Add Setoid R req Rsth as R_setoid3.
+     Ltac rrefl := gen_reflexivity Rsth.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+   Add Morphism radd : radd_ext3.  exact (Radd_ext Reqe). Qed.
+   Add Morphism rmul : rmul_ext3.  exact (Rmul_ext Reqe). Qed.
+   Add Morphism ropp : ropp_ext3.  exact (Ropp_ext Reqe). Qed.
+
+ Fixpoint gen_phiPOS1 (p:positive) : R :=
+  match p with
+  | xH => 1
+  | xO p => (1 + 1) * (gen_phiPOS1 p)
+  | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p))
+  end.
+
+ Fixpoint gen_phiPOS (p:positive) : R :=
+  match p with
+  | xH => 1 
+  | xO xH => (1 + 1)
+  | xO p => (1 + 1) * (gen_phiPOS p)
+  | xI xH => 1 + (1 +1)
+  | xI p => 1 + ((1 + 1) * (gen_phiPOS p))
+  end.
+
+ Definition gen_phiZ1 z :=
+  match z with
+  | Zpos p => gen_phiPOS1 p
+  | Z0 => 0
+  | Zneg p => -(gen_phiPOS1 p)
+  end.
+ 
+ Definition gen_phiZ z := 
+  match z with
+  | Zpos p => gen_phiPOS p
+  | Z0 => 0
+  | Zneg p => -(gen_phiPOS p)
+  end.
+ Notation "[ x ]" := (gen_phiZ x).   
+
+ Definition get_signZ z :=
+  match z with
+  | Zneg p => Some (Zpos p) 
+  | _ => None
+  end.
+
+ Lemma get_signZ_th : sign_theory ropp req gen_phiZ get_signZ.
+ Proof.
+  constructor.
+  destruct c;intros;try discriminate.
+  injection H;clear H;intros H1;subst c'.
+  simpl;rrefl.
+ Qed.
+
+ 
+ Section ALMOST_RING.
+ Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
+   Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed.
+   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+   Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+ 
+ Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x.
+ Proof.
+  induction x;simpl. 
+  rewrite IHx;destruct x;simpl;norm.
+  rewrite IHx;destruct x;simpl;norm.
+  rrefl.
+ Qed.
+
+ Lemma ARgen_phiPOS_Psucc : forall x,
+   gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x).
+ Proof.
+  induction x;simpl;norm.
+  rewrite IHx;norm.
+  add_push 1;rrefl.
+ Qed.
+
+ Lemma ARgen_phiPOS_add : forall x y,
+   gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y).
+ Proof.
+  induction x;destruct y;simpl;norm.
+  rewrite Pplus_carry_spec.
+  rewrite ARgen_phiPOS_Psucc.
+  rewrite IHx;norm.
+  add_push (gen_phiPOS1 y);add_push 1;rrefl.
+  rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl.
+  rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl.
+  rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl.
+  rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl.
+  add_push 1;rrefl.
+  rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl.
+ Qed.
+
+ Lemma ARgen_phiPOS_mult :
+   forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y.
+ Proof.
+  induction x;intros;simpl;norm.
+  rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm.
+  rewrite IHx;rrefl.
+ Qed.
+
+ End ALMOST_RING.
+
+ Variable Rth : ring_theory 0 1 radd rmul rsub ropp req.
+ Let ARth := Rth_ARth Rsth Reqe Rth.
+   Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed.
+   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+   Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+  
+(*morphisms are extensionaly equal*)
+ Lemma same_genZ : forall x, [x] == gen_phiZ1 x.
+ Proof.
+  destruct x;simpl; try rewrite (same_gen ARth);rrefl.
+ Qed.
+ 
+ Lemma gen_Zeqb_ok : forall x y, 
+   Zeq_bool x y = true -> [x] == [y].
+ Proof.
+  intros x y H; repeat rewrite same_genZ.
+  assert (H1 := Zeqb_ok x y H);unfold IDphi in H1.
+  rewrite H1;rrefl.
+ Qed.
+  
+ Lemma gen_phiZ1_add_pos_neg : forall x y,
+ gen_phiZ1
+    match (x ?= y)%positive Eq with
+    | Eq => Z0
+    | Lt => Zneg (y - x)
+    | Gt => Zpos (x - y)
+    end 
+ == gen_phiPOS1 x + -gen_phiPOS1 y.
+ Proof.
+  intros x y.
+  assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y).
+  generalize (Pminus_mask_Gt y x).
+  replace Eq with (CompOpp Eq);[intro H1;simpl|trivial].
+  rewrite <- Pcompare_antisym in H1.
+  destruct ((x ?= y)%positive Eq).
+  rewrite H;trivial. rewrite (Ropp_def Rth);rrefl.
+  destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial.
+  unfold Pminus; rewrite Heq1;rewrite <- Heq2.
+  rewrite (ARgen_phiPOS_add ARth);simpl;norm.
+  rewrite (Ropp_def Rth);norm.
+  destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial.
+  unfold Pminus; rewrite Heq1;rewrite <- Heq2.
+  rewrite (ARgen_phiPOS_add ARth);simpl;norm.
+  add_push (gen_phiPOS1 h);rewrite (Ropp_def Rth); norm.
+ Qed.
+
+ Lemma match_compOpp : forall x (B:Type) (be bl bg:B),
+  match CompOpp x with Eq => be | Lt => bl | Gt => bg end 
+  = match x with Eq => be | Lt => bg | Gt => bl end.
+ Proof. destruct x;simpl;intros;trivial. Qed.
+
+ Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y].
+ Proof.
+  intros x y; repeat rewrite same_genZ; generalize x y;clear x y.
+  induction x;destruct y;simpl;norm.
+  apply (ARgen_phiPOS_add ARth).
+  apply gen_phiZ1_add_pos_neg.
+  replace Eq with (CompOpp Eq);trivial.
+  rewrite <- Pcompare_antisym;simpl.
+  rewrite match_compOpp.    
+  rewrite (Radd_comm Rth).
+  apply gen_phiZ1_add_pos_neg.
+  rewrite (ARgen_phiPOS_add ARth); norm.
+ Qed.
+
+ Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y].
+ Proof.
+  intros x y;repeat rewrite same_genZ.
+  destruct x;destruct y;simpl;norm;
+  rewrite  (ARgen_phiPOS_mult ARth);try (norm;fail).
+  rewrite (Ropp_opp Rsth Reqe Rth);rrefl.
+ Qed.
+
+ Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y].
+ Proof. intros;subst;rrefl. Qed.
+
+(*proof that [.] satisfies morphism specifications*)
+ Lemma gen_phiZ_morph : 
+  ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) 
+   Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ.
+ Proof. 
+  assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) 
+                  Zplus Zmult Zeq_bool gen_phiZ).
+   apply mkRmorph;simpl;try rrefl.
+   apply gen_phiZ_add.  apply gen_phiZ_mul. apply gen_Zeqb_ok.
+  apply  (Smorph_morph Rsth Reqe Rth Zsth Zth SRmorph gen_phiZ_ext).
+ Qed.
+
+End ZMORPHISM.
+
+(** N is a semi-ring and a setoid*)
+Lemma Nsth : Setoid_Theory N (@eq N).
+Proof (Eqsth N).
+
+Lemma Nseqe : sring_eq_ext Nplus Nmult (@eq N).
+Proof (Eq_s_ext Nplus Nmult).
+
+Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N).
+Proof.
+ constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc.
+ exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc.
+ exact Nmult_plus_distr_r. 
+Qed.
+
+Definition Nsub := SRsub Nplus.
+Definition Nopp := (@SRopp N).
+
+Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N).
+Proof (SReqe_Reqe Nseqe).
+
+Lemma Nath : 
+ almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N).
+Proof (SRth_ARth Nsth Nth).
+ 
+Definition Neq_bool (x y:N) := 
+  match Ncompare x y with
+  | Eq => true
+  | _ => false
+  end.
+
+Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y.
+ Proof.
+  intros x y;unfold Neq_bool.
+  assert (H:=Ncompare_Eq_eq x y); 
+   destruct (Ncompare x y);intros;try discriminate.
+  rewrite H;trivial. 
+ Qed.
+
+Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y.
+ Proof.
+  intros x y;unfold Neq_bool.
+  assert (H:=Ncompare_Eq_eq x y); 
+   destruct (Ncompare x y);intros;try discriminate.
+  rewrite H;trivial. 
+ Qed.
+
+(**Same as above : definition of two,extensionaly equal, generic morphisms *)
+(**from N to any semi-ring*)
+Section NMORPHISM.
+ Variable R : Type.
+ Variable  (rO rI : R) (radd rmul: R->R->R).
+ Variable req : R -> R -> Prop.
+  Notation "0" := rO.  Notation "1" := rI.
+  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+ Variable Rsth : Setoid_Theory R req.
+     Add Setoid R req Rsth as R_setoid4.
+     Ltac rrefl := gen_reflexivity Rsth.
+ Variable SReqe : sring_eq_ext radd rmul req.
+ Variable SRth : semi_ring_theory 0 1 radd rmul req. 
+ Let ARth := SRth_ARth Rsth SRth.
+ Let Reqe := SReqe_Reqe SReqe.
+ Let ropp := (@SRopp R).
+ Let rsub := (@SRsub R radd).
+  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
+  Notation "x == y" := (req x y).
+   Add Morphism radd : radd_ext4.  exact (Radd_ext Reqe). Qed.
+   Add Morphism rmul : rmul_ext4.  exact (Rmul_ext Reqe). Qed.
+   Add Morphism ropp : ropp_ext4.  exact (Ropp_ext Reqe). Qed.
+   Add Morphism rsub : rsub_ext5.  exact (ARsub_ext Rsth Reqe ARth). Qed.
+   Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+  
+ Definition gen_phiN1 x :=
+  match x with
+  | N0 => 0
+  | Npos x => gen_phiPOS1 1 radd rmul x
+  end. 
+
+ Definition gen_phiN x :=
+  match x with
+  | N0 => 0
+  | Npos x => gen_phiPOS 1 radd rmul x
+  end. 
+ Notation "[ x ]" := (gen_phiN x).   
+  
+ Lemma same_genN : forall x, [x] == gen_phiN1 x.
+ Proof.
+  destruct x;simpl. rrefl.
+  rewrite (same_gen Rsth Reqe ARth);rrefl.
+ Qed.
+
+ Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y].
+ Proof.
+  intros x y;repeat rewrite same_genN.
+  destruct x;destruct y;simpl;norm.
+  apply (ARgen_phiPOS_add Rsth Reqe ARth).
+ Qed.
+ 
+ Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y].
+ Proof.
+  intros x y;repeat rewrite same_genN.
+  destruct x;destruct y;simpl;norm.
+  apply (ARgen_phiPOS_mult Rsth Reqe ARth).
+ Qed.
+
+ Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y].
+ Proof. exact gen_phiN_add. Qed.
+
+(*gen_phiN satisfies morphism specifications*)
+ Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req
+                           N0 (Npos xH) Nplus Nmult Nsub Nopp Neq_bool gen_phiN.
+ Proof.
+  constructor;intros;simpl; try rrefl.
+  apply gen_phiN_add. apply gen_phiN_sub.  apply gen_phiN_mult.
+  rewrite (Neq_bool_ok x y);trivial. rrefl.
+ Qed.
+
+End NMORPHISM.
+
+ (* syntaxification of constants in an abstract ring:
+    the inverse of gen_phiPOS 
+    Why we do not reconnize only rI ?????? *)
+ Ltac inv_gen_phi_pos rI add mul t :=
+   let rec inv_cst t :=
+   match t with
+     rI => constr:1%positive
+   | (add rI rI) => constr:2%positive
+   | (add rI (add rI rI)) => constr:3%positive
+   | (mul (add rI rI) ?p) => (* 2p *)
+       match inv_cst p with
+         NotConstant => NotConstant
+       | 1%positive => NotConstant (* 2*1 is not convertible to 2 *)
+       | ?p => constr:(xO p)
+       end
+   | (add rI (mul (add rI rI) ?p)) => (* 1+2p *)
+       match inv_cst p with
+         NotConstant => NotConstant
+       | 1%positive => NotConstant
+       | ?p => constr:(xI p)
+       end
+   | _ => NotConstant
+   end in
+   inv_cst t.
+
+(* The inverse of gen_phiN *)
+ Ltac inv_gen_phiN rO rI add mul t :=
+   match t with
+     rO => constr:0%N
+   | _ =>
+     match inv_gen_phi_pos rI add mul t with
+       NotConstant => NotConstant
+     | ?p => constr:(Npos p)
+     end
+   end.
+
+(* The inverse of gen_phiZ *)
+ Ltac inv_gen_phiZ rO rI add mul opp t :=
+   match t with
+     rO => constr:0%Z
+   | (opp ?p) =>
+     match inv_gen_phi_pos rI add mul p with
+       NotConstant => NotConstant
+     | ?p => constr:(Zneg p)
+     end
+   | _ =>
+     match inv_gen_phi_pos rI add mul t with
+       NotConstant => NotConstant
+     | ?p => constr:(Zpos p)
+     end
+   end.
+
+(* A simpl tactic reconninzing nothing *)
+ Ltac inv_morph_nothing t := constr:(NotConstant).
+
+
+Ltac coerce_to_almost_ring set ext rspec :=
+  match type of rspec with
+  | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec)
+  | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec)
+  | almost_ring_theory _ _ _ _ _ _ _ => rspec
+  | _ => fail 1 "not a valid ring theory"
+  end.
+
+Ltac coerce_to_ring_ext ext :=
+  match type of ext with
+  | ring_eq_ext _ _ _ _ => ext
+  | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext)
+  | _ => fail 1 "not a valid ring_eq_ext theory"
+  end.
+
+Ltac abstract_ring_morphism set ext rspec :=
+  match type of rspec with
+  | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec)
+  | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec)
+  | almost_ring_theory _ _ _ _ _ _ _ =>
+      fail 1 "an almost ring cannot be abstract"
+  | _ => fail 1 "bad ring structure"
+  end.
+
+Record hypo : Type := mkhypo {
+   hypo_type : Type;
+   hypo_proof : hypo_type
+ }.
+
+Ltac gen_ring_pow set arth pspec :=
+ match pspec with
+ | None =>
+   match type of arth with
+   | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req =>
+     constr:(mkhypo (@pow_N_th R rI rmul req set))
+   | _ => fail 1 "gen_ring_pow"
+   end
+ | Some ?t => constr:(t)
+ end.
+
+Ltac default_sign_spec morph :=
+ match type of morph with
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req 
+               ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi =>
+      constr:(mkhypo (@get_sign_None_th R ropp req C phi))
+ | _ => fail 1 "ring anomaly : default_sign_spec" 
+ end.
+
+Ltac gen_ring_sign set rspec morph sspec rk :=
+ match sspec with
+ | None =>
+   match rk with
+   | Abstract =>
+     match type of rspec with
+     | @ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req =>
+       constr:(mkhypo (@get_signZ_th R rO rI radd rmul ropp req set))
+     | _ => default_sign_spec morph 
+     end
+   | _ => default_sign_spec morph 
+   end
+ | Some ?t => constr:(t)
+ end.
+
+
+Ltac ring_elements set ext rspec pspec sspec rk :=
+  let arth := coerce_to_almost_ring set ext rspec in
+  let ext_r := coerce_to_ring_ext ext in
+  let morph :=
+    match rk with
+    | Abstract => abstract_ring_morphism set ext rspec
+    | @Computational ?reqb_ok =>
+        match type of arth with
+        | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ =>
+            constr:(IDmorph rO rI add mul sub opp set _ reqb_ok)
+        | _ => fail 2 "ring anomaly"
+        end
+    | @Morphism ?m =>
+       match type of m with 
+       | ring_morph _ _ _ _ _ _ _  _ _ _ _ _ _  _ _ => m 
+       | @semi_morph _ _ _ _ _ _  _ _ _ _ _  _ _   => 
+           constr:(SRmorph_Rmorph set m) 
+       | _ => fail 2 " ici"
+       end
+    | _ => fail 1 "ill-formed ring kind"
+    end in
+  let p_spec := gen_ring_pow set arth pspec in
+  let s_spec := gen_ring_sign set rspec morph sspec rk in
+  fun f => f arth ext_r morph p_spec s_spec.
+
+(* Given a ring structure and the kind of morphism,
+   returns 2 lemmas (one for ring, and one for ring_simplify). *)
+Ltac ring_lemmas set ext rspec pspec sspec rk :=
+  let gen_lemma2 :=
+    match pspec with
+    | None => constr:(ring_rw_correct) 
+    | Some _ => constr:(ring_rw_pow_correct)
+    end in
+  ring_elements set ext rspec pspec sspec rk
+    ltac:(fun arth ext_r morph p_spec s_spec =>
+        match p_spec with
+        | mkhypo ?pp_spec =>
+        match s_spec with
+        | mkhypo ?ps_spec =>
+          let lemma1 := 
+            constr:(ring_correct set ext_r arth morph pp_spec) in
+          let lemma2 := 
+            constr:(gen_lemma2 _  _ _  _ _ _  _  _ set ext_r arth 
+                           _  _ _  _ _ _  _  _  _ morph 
+                           _ _ _ pp_spec
+                           _ ps_spec) in 
+          fun f => f arth ext_r morph lemma1 lemma2
+        | _ => fail 2 "bad sign specification"
+       end
+       | _ => fail 1 "bad power specification" 
+       end).
+ 
+(* Tactic for constant *)
+Ltac isnatcst t :=
+  match t with
+    O => true
+  | S ?p => isnatcst p
+  | _ => false
+  end.
+
+Ltac isPcst t :=
+  match t with
+  | xI ?p => isPcst p
+  | xO ?p => isPcst p
+  | xH => constr:true
+  (* nat -> positive *)
+  | P_of_succ_nat ?n => isnatcst n 
+  | _ => false
+  end.
+
+Ltac isNcst t :=
+  match t with
+    N0 => constr:true
+  | Npos ?p => isPcst p
+  | _ => constr:false
+  end.
+
+Ltac isZcst t :=
+  match t with
+    Z0 => true
+  | Zpos ?p => isPcst p
+  | Zneg ?p => isPcst p
+  (* injection nat -> Z *)
+  | Z_of_nat ?n => isnatcst n
+  (* injection N -> Z *)
+  | Z_of_N ?n => isNcst n
+  (* *)
+  | _ => false
+  end.
+
+
+
+
+
diff --git a/contrib7/correctness/Arrays_stuff.v b/contrib/setoid_ring/NArithRing.v
index 448b0ab6..ae067a8a 100644
--- a/contrib7/correctness/Arrays_stuff.v
+++ b/contrib/setoid_ring/NArithRing.v
@@ -6,11 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+Require Export Ring.
+Require Import BinPos BinNat.
+Import InitialRing.
 
-(* $Id: Arrays_stuff.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
+Set Implicit Arguments.
 
-Require Export Exchange.
-Require Export ArrayPermut.
-Require Export Sorted.
+Ltac Ncst t :=
+  match isNcst t with
+    true => t
+  | _ => NotConstant
+  end.
 
+Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]).
diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v
new file mode 100644
index 00000000..d0512dff
--- /dev/null
+++ b/contrib/setoid_ring/RealField.v
@@ -0,0 +1,133 @@
+Require Import Nnat.
+Require Import ArithRing. 
+Require Export Ring Field.
+Require Import Rdefinitions.
+Require Import Rpow_def.
+Require Import Raxioms.
+
+Open Local Scope R_scope.
+
+Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)).
+Proof.
+constructor.
+ intro; apply Rplus_0_l.
+ exact Rplus_comm.
+ symmetry  in |- *; apply Rplus_assoc.
+ intro; apply Rmult_1_l.
+ exact Rmult_comm.
+ symmetry  in |- *; apply Rmult_assoc.
+ intros m n p.
+   rewrite Rmult_comm in |- *.
+   rewrite (Rmult_comm n p) in |- *.
+   rewrite (Rmult_comm m p) in |- *.
+   apply Rmult_plus_distr_l.
+ reflexivity.
+ exact Rplus_opp_r.
+Qed.
+
+Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)).
+Proof.
+constructor.
+ exact RTheory.
+ exact R1_neq_R0.
+ reflexivity.
+ exact Rinv_l.
+Qed.
+
+Lemma Rlt_n_Sn : forall x, x < x + 1.
+Proof.
+intro.
+elim archimed with x; intros.
+destruct H0.
+ apply Rlt_trans with (IZR (up x)); trivial.
+    replace (IZR (up x)) with (x + (IZR (up x) - x))%R.
+  apply Rplus_lt_compat_l; trivial.
+  unfold Rminus in |- *.
+    rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
+    rewrite <- Rplus_assoc in |- *.
+    rewrite Rplus_opp_r in |- *.
+    apply Rplus_0_l.
+ elim H0.
+   unfold Rminus in |- *.
+   rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
+   rewrite <- Rplus_assoc in |- *.
+   rewrite Rplus_opp_r in |- *.
+   rewrite Rplus_0_l in |- *; trivial.
+Qed.
+
+Notation Rset := (Eqsth R).
+Notation Rext := (Eq_ext Rplus Rmult Ropp).
+
+Lemma Rlt_0_2 : 0 < 2.
+apply Rlt_trans with (0 + 1).
+ apply Rlt_n_Sn.
+ rewrite Rplus_comm in |- *.
+   apply Rplus_lt_compat_l.
+    replace 1 with (0 + 1).
+  apply Rlt_n_Sn.
+  apply Rplus_0_l.
+Qed.
+
+Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0.
+unfold Rgt in |- *.
+induction x; simpl in |- *; intros.
+ apply Rlt_trans with (1 + 0).
+  rewrite Rplus_comm in |- *.
+    apply Rlt_n_Sn.
+  apply Rplus_lt_compat_l.
+    rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
+    rewrite Rmult_comm in |- *.
+    apply Rmult_lt_compat_l.
+   apply Rlt_0_2.
+   trivial.
+ rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
+   rewrite Rmult_comm in |- *.
+   apply Rmult_lt_compat_l.
+  apply Rlt_0_2.
+  trivial.
+  replace 1 with (0 + 1).
+  apply Rlt_n_Sn.
+  apply Rplus_0_l.
+Qed.
+
+
+Lemma Rgen_phiPOS_not_0 :
+  forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0.
+red in |- *; intros.
+specialize (Rgen_phiPOS x).
+rewrite H in |- *; intro.
+apply (Rlt_asym 0 0); trivial.
+Qed.
+
+Lemma Zeq_bool_complete : forall x y, 
+  InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x =
+  InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y ->
+  Zeq_bool x y = true.
+Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0.
+
+Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x  (n + m) = pow x n * pow x m.
+Proof.
+  intros x n; elim n; simpl in |- *; auto with real.
+  intros n0 H' m; rewrite H'; auto with real.
+Qed.
+
+Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R))  nat_of_N pow.
+Proof.
+ constructor. destruct n. reflexivity.
+ simpl. induction p;simpl. 
+ rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity.
+ unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial.
+ rewrite Rmult_comm;apply Rmult_1_l.
+Qed.
+
+Ltac Rpow_tac t := 
+  match isnatcst t with
+  | false => constr:(InitialRing.NotConstant)
+  | _ => constr:(N_of_nat t)
+  end. 
+
+Add Field RField : Rfield  
+   (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]).
+
+
+ 
diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v
new file mode 100644
index 00000000..1a4e1cc7
--- /dev/null
+++ b/contrib/setoid_ring/Ring.v
@@ -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        *)
+(************************************************************************)
+
+Require Import Bool.
+Require Export Ring_theory.
+Require Export Ring_base.
+Require Export InitialRing.
+Require Export Ring_tac.
+
+Lemma BoolTheory :
+  ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)).
+split; simpl in |- *.
+destruct x; reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; destruct z; reflexivity.
+reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; destruct z; reflexivity.
+reflexivity.
+destruct x; reflexivity.
+Qed.
+
+Definition bool_eq (b1 b2:bool) :=
+  if b1 then b2 else negb b2.
+
+Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2.
+destruct b1; destruct b2; auto.
+Qed.
+
+Ltac bool_cst t :=
+  let t := eval hnf in t in
+  match t with
+    true => constr:true
+  | false => constr:false
+  | _ => NotConstant
+  end.
+
+Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/contrib/field/Field.v b/contrib/setoid_ring/Ring_base.v
index 7b48e275..95b037e3 100644
--- a/contrib/field/Field.v
+++ b/contrib/setoid_ring/Ring_base.v
@@ -6,10 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field.v,v 1.6.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+(* This module gathers the necessary base to build an instance of the
+   ring tactic. Abstract rings need more theory, depending on
+   ZArith_base. *)
 
-Require Export Field_Compl.
-Require Export Field_Theory.
-Require Export Field_Tactic.
-
-(* Command declarations are moved to the ML side *)
\ No newline at end of file
+Declare ML Module "newring".
+Require Export Ring_theory.
+Require Export Ring_tac.
+Require Import InitialRing.
diff --git a/contrib/setoid_ring/Ring_equiv.v b/contrib/setoid_ring/Ring_equiv.v
new file mode 100644
index 00000000..945f6c68
--- /dev/null
+++ b/contrib/setoid_ring/Ring_equiv.v
@@ -0,0 +1,74 @@
+Require Import Setoid_ring_theory.
+Require Import LegacyRing_theory.
+Require Import Ring_theory.
+
+Set Implicit Arguments.
+
+Section Old2New.
+
+Variable A : Type.
+
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
+
+Let Aminus := fun x y => Aplus x (Aopp y).
+
+Lemma ring_equiv1 :
+  ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)).
+Proof.
+destruct R.
+split;  eauto.
+Qed.
+
+End Old2New.
+
+Section New2OldRing.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)).
+
+ Variable reqb : R -> R -> bool.
+ Variable reqb_ok : forall x y, reqb x y = true -> x = y.
+
+ Lemma ring_equiv2 :
+   Ring_Theory radd  rmul rI rO ropp reqb.
+Proof.
+elim Rth; intros; constructor;  eauto.
+intros.
+apply reqb_ok.
+destruct (reqb x y); trivial; intros.
+elim H.
+Qed.
+
+ Definition default_eqb : R -> R -> bool := fun x y => false.
+ Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y.
+Proof.
+discriminate 1.
+Qed.
+
+End New2OldRing.
+
+Section New2OldSemiRing.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul: R->R->R).
+ Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)).
+
+ Variable reqb : R -> R -> bool.
+ Variable reqb_ok : forall x y, reqb x y = true -> x = y.
+
+ Lemma sring_equiv2 :
+   Semi_Ring_Theory radd rmul rI rO reqb.
+Proof.
+elim SRth; intros; constructor;  eauto.
+intros.
+apply reqb_ok.
+destruct (reqb x y); trivial; intros.
+elim H.
+Qed.
+
+End New2OldSemiRing.
diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v
new file mode 100644
index 00000000..b79f2fe2
--- /dev/null
+++ b/contrib/setoid_ring/Ring_polynom.v
@@ -0,0 +1,1696 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinList.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Export Ring_theory.
+
+Open Local Scope positive_scope.
+Import RingSyntax.
+
+Section MakeRingPol.
+ 
+ (* Ring elements *)     
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable req : R -> R -> Prop.
+ 
+ (* Ring properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
+
+ (* Coefficients *) 
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool. 
+ Variable phi : C -> R.
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+                                cO cI cadd cmul csub copp ceqb phi.
+
+  (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R. 
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+
+
+ (* R notations *)
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+
+ (* C notations *)		 
+ Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
+ Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
+ Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+
+ (* Usefull tactics *)		  
+  Add Setoid R req Rsth as R_set1.
+ Ltac rrefl := gen_reflexivity Rsth.
+  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
+  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
+  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
+  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac rsimpl := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+ Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
+
+ (* Definition of multivariable polynomials with coefficients in C :
+    Type [Pol] represents [X1 ... Xn].
+    The representation is Horner's where a [n] variable polynomial
+    (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients
+    are polynomials with [n-1] variables (C[X2..Xn]).
+    There are several optimisations to make the repr compacter:
+    - [Pc c] is the constant polynomial of value c
+       == c*X1^0*..*Xn^0
+    - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables.
+        variable indices are shifted of j in Q.
+       == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn}
+    - [PX P i Q] is an optimised Horner form of P*X^i + Q
+        with P not the null polynomial
+       == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn}
+
+    In addition:
+    - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden
+      since they can be represented by the simpler form (PX P (i+j) Q)
+    - (Pinj i (Pinj j P)) is (Pinj (i+j) P)
+    - (Pinj i (Pc c)) is (Pc c)
+ *)
+
+ Inductive Pol : Type :=
+  | Pc : C -> Pol 
+  | Pinj : positive -> Pol -> Pol                   
+  | PX : Pol -> positive -> Pol -> Pol.
+
+ Definition P0 := Pc cO.
+ Definition P1 := Pc cI.
+ 
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool := 
+  match P, P' with
+  | Pc c, Pc c' => c ?=! c'
+  | Pinj j Q, Pinj j' Q' => 
+    match Pcompare j j' Eq with
+    | Eq => Peq Q Q' 
+    | _ => false 
+    end
+  | PX P i Q, PX P' i' Q' =>
+    match Pcompare i i' Eq with
+    | Eq => if Peq P P' then Peq Q Q' else false
+    | _ => false
+    end
+  | _, _ => false
+  end.
+
+ Notation " P ?== P' " := (Peq P P').
+
+ Definition mkPinj j P :=
+  match P with 
+  | Pc _ => P
+  | Pinj j' Q => Pinj ((j + j'):positive) Q
+  | _ => Pinj j P
+  end.
+
+ Definition mkPinj_pred j P:=
+  match j with
+  | xH => P
+  | xO j => Pinj (Pdouble_minus_one j) P
+  | xI j => Pinj (xO j) P
+  end.
+
+ Definition mkPX P i Q := 
+  match P with
+  | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
+  | Pinj _ _ => PX P i Q
+  | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q
+  end.
+
+ Definition mkXi i := PX P1 i P0.
+
+ Definition mkX := mkXi 1.
+ 
+ (** Opposite of addition *)
+ 
+ Fixpoint Popp (P:Pol) : Pol := 
+  match P with
+  | Pc c => Pc (-! c)
+  | Pinj j Q => Pinj j (Popp Q)
+  | PX P i Q => PX (Popp P) i (Popp Q)
+  end.
+ 
+ Notation "-- P" := (Popp P).
+
+ (** Addition et subtraction *)
+ 
+ Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c1 => Pc (c1 +! c)
+  | Pinj j Q => Pinj j (PaddC Q c)
+  | PX P i Q => PX P i (PaddC Q c)
+  end.
+
+ Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c1 => Pc (c1 -! c)
+  | Pinj j Q => Pinj j (PsubC Q c)
+  | PX P i Q => PX P i (PsubC Q c)
+  end.
+
+ Section PopI.
+
+  Variable Pop : Pol -> Pol -> Pol.
+  Variable Q : Pol.
+
+  Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PaddC Q c)
+   | Pinj j' Q' => 
+     match ZPminus j' j with
+     | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pop Q' Q)
+     | Zneg k => mkPinj j' (PaddI k Q')
+     end
+   | PX P i Q' => 
+     match j with
+     | xH => PX P i (Pop Q' Q)
+     | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
+     | xI j => PX P i (PaddI (xO j) Q')
+     end 
+   end.
+
+  Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PaddC (--Q) c)
+   | Pinj j' Q' => 
+     match ZPminus j' j with
+     | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pop Q' Q)
+     | Zneg k => mkPinj j' (PsubI k Q')
+     end
+   | PX P i Q' => 
+     match j with
+     | xH => PX P i (Pop Q' Q)
+     | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
+     | xI j => PX P i (PsubI (xO j) Q')
+     end 
+   end.
+ 
+ Variable P' : Pol.
+ 
+ Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
+  match P with
+  | Pc c => PX P' i' P
+  | Pinj j Q' =>
+    match j with
+    | xH =>  PX P' i' Q'
+    | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
+    | xI j => PX P' i' (Pinj (xO j) Q')
+    end
+  | PX P i Q' =>
+    match ZPminus i i' with
+    | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+    | Z0 => mkPX (Pop P P') i Q'
+    | Zneg k => mkPX (PaddX k P) i Q'
+    end
+  end.
+
+ Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
+  match P with
+  | Pc c => PX (--P') i' P
+  | Pinj j Q' =>
+    match j with
+    | xH =>  PX (--P') i' Q'
+    | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
+    | xI j => PX (--P') i' (Pinj (xO j) Q')
+    end
+  | PX P i Q' =>
+    match ZPminus i i' with
+    | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+    | Z0 => mkPX (Pop P P') i Q'
+    | Zneg k => mkPX (PsubX k P) i Q'
+    end
+  end.
+
+    
+ End PopI.
+
+ Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
+  match P' with
+  | Pc c' => PaddC P c'
+  | Pinj j' Q' => PaddI Padd Q' j' P
+  | PX P' i' Q' =>
+    match P with
+    | Pc c => PX P' i' (PaddC Q' c)
+    | Pinj j Q =>  
+      match j with
+      | xH => PX P' i' (Padd Q Q')
+      | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
+      | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
+      end 
+    | PX P i Q =>
+      match ZPminus i i' with
+      | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
+      | Z0 => mkPX (Padd P P') i (Padd Q Q')
+      | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
+      end
+    end
+  end.
+ Notation "P ++ P'" := (Padd P P').
+
+ Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
+  match P' with
+  | Pc c' => PsubC P c'
+  | Pinj j' Q' => PsubI Psub Q' j' P
+  | PX P' i' Q' =>
+    match P with
+    | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
+    | Pinj j Q =>  
+      match j with
+      | xH => PX (--P') i' (Psub Q Q')
+      | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
+      | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
+      end 
+    | PX P i Q =>
+      match ZPminus i i' with
+      | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
+      | Z0 => mkPX (Psub P P') i (Psub Q Q')
+      | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
+      end
+    end
+  end.
+ Notation "P -- P'" := (Psub P P').
+ 
+ (** Multiplication *) 
+
+ Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
+  match P with
+  | Pc c' => Pc (c' *! c)
+  | Pinj j Q => mkPinj j (PmulC_aux Q c)
+  | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c)
+  end.
+
+ Definition PmulC P c :=
+  if c ?=! cO then P0 else
+  if c ?=! cI then P else PmulC_aux P c.
+ 
+ Section PmulI. 
+  Variable Pmul : Pol -> Pol -> Pol.
+  Variable Q : Pol.
+  Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
+   match P with
+   | Pc c => mkPinj j (PmulC Q c)
+   | Pinj j' Q' => 
+     match ZPminus j' j with
+     | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
+     | Z0 => mkPinj j (Pmul Q' Q)
+     | Zneg k => mkPinj j' (PmulI k Q')
+     end
+   | PX P' i' Q' =>
+     match j with
+     | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
+     | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
+     | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
+     end
+   end.
+ 
+ End PmulI.
+(* A symmetric version of the multiplication *)
+
+ Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
+   match P'' with
+   | Pc c => PmulC P c
+   | Pinj j' Q' => PmulI Pmul Q' j' P
+   | PX P' i' Q' =>
+     match P with
+     | Pc c => PmulC P'' c
+     | Pinj j Q =>
+       let QQ' := 
+         match j with
+         | xH => Pmul Q Q'
+         | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' 
+         | xI j => Pmul (Pinj (xO j) Q) Q'
+         end in
+       mkPX (Pmul P P') i' QQ'
+     | PX P i Q=>
+       let QQ' := Pmul Q Q' in
+       let PQ' := PmulI Pmul Q' xH P in
+       let QP' := Pmul (mkPinj xH Q) P' in
+       let PP' := Pmul P P' in
+       (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
+     end
+  end.    
+
+(* Non symmetric *)
+(*       
+ Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
+  match P' with
+  | Pc c' => PmulC P c'
+  | Pinj j' Q' => PmulI Pmul_aux Q' j' P
+  | PX P' i' Q' => 
+     (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
+  end.
+
+ Definition Pmul P P' :=
+  match P with
+  | Pc c => PmulC P' c
+  | Pinj j Q => PmulI Pmul_aux Q j P'
+  | PX P i Q => 
+    (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
+  end.
+*)
+ Notation "P ** P'" := (Pmul P P').
+
+ Fixpoint Psquare (P:Pol) : Pol :=
+   match P with
+   | Pc c => Pc (c *! c)
+   | Pinj j Q => Pinj j (Psquare Q)
+   | PX P i Q => 
+     let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
+     let Q2 := Psquare Q in
+     let P2 := Psquare P in
+     mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
+   end.
+
+ (** Monomial **)
+     
+  Inductive Mon: Set :=
+    mon0: Mon 
+  | zmon: positive -> Mon -> Mon 
+  | vmon: positive -> Mon -> Mon.
+
+ Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R :=
+  match M with
+     mon0 => rI
+  | zmon j M1  => Mphi (jump j l) M1
+  | vmon i M1 =>
+     let x := hd 0 l in
+     let xi := pow_pos rmul x i in
+    (Mphi (tail l) M1) * xi 
+  end.
+
+ Definition mkZmon j M :=
+   match M with mon0 => mon0 | _ => zmon j M end.
+
+ Definition zmon_pred j M :=
+   match j with xH => M | _ => mkZmon (Ppred j) M end.
+
+ Definition mkVmon i M :=
+   match M with 
+   | mon0 => vmon i mon0 
+   | zmon j m => vmon i (zmon_pred j m)
+   | vmon i' m => vmon (i+i') m
+   end.
+
+ Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
+   match P, M with
+        _, mon0 => (Pc cO, P)
+   | Pc _, _    => (P, Pc cO)
+   | Pinj j1 P1, zmon j2 M1 =>
+      match (j1 ?= j2) Eq with
+        Eq => let (R,S) := MFactor P1 M1 in
+                 (mkPinj j1 R, mkPinj j1 S)
+      | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
+                 (mkPinj j1 R, mkPinj j1 S)
+      | Gt => (P, Pc cO)
+      end
+  | Pinj _ _, vmon _ _ => (P, Pc cO)
+  | PX P1 i Q1, zmon j M1 =>
+             let M2 := zmon_pred j M1 in
+             let (R1, S1) := MFactor P1 M in
+             let (R2, S2) := MFactor Q1 M2 in
+               (mkPX R1 i R2, mkPX S1 i S2)
+  | PX P1 i Q1, vmon j M1 =>
+      match (i ?= j) Eq with
+        Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+                 (mkPX R1 i Q1, S1)
+      | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
+                 (mkPX R1 i Q1, S1)
+      | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+                 (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
+      end
+   end.
+
+  Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
+    let (Q1,R1) := MFactor P1 M1 in
+    match R1 with 
+     (Pc c) => if c ?=! cO then None 
+               else Some (Padd Q1 (Pmul P2 R1))
+    | _ => Some (Padd Q1 (Pmul P2 R1))
+    end.
+
+  Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+    match POneSubst P1 M1 P2 with 
+     Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
+    | _ => P1
+    end.
+
+  Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
+    match POneSubst P1 M1 P2 with 
+     Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
+    | _ => None
+    end.
+            
+  Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: 
+     Pol :=
+    match LM1 with 
+     cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
+    | _ => P1
+    end.
+
+  Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+    match LM1 with 
+     cons (M1,P2) LM2 =>
+      match PNSubst P1 M1 P2 n with 
+        Some P3 => Some (PSubstL1 P3 LM2 n)
+     |  None => PSubstL P1 LM2 n
+     end
+    | _ => None
+    end.
+
+  Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+    match PSubstL P1 LM1 n with 
+     Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
+    | _ => P1
+    end.
+
+ (** Evaluation of a polynomial towards R *)
+
+ Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R :=
+  match P with
+  | Pc c => [c]
+  | Pinj j Q => Pphi (jump j l) Q
+  | PX P i Q => 
+     let x := hd 0 l in
+     let xi := pow_pos rmul x i in
+    (Pphi l P) * xi + (Pphi (tail l) Q)      
+  end.
+
+ Reserved Notation "P @ l " (at level 10, no associativity).
+ Notation "P @ l " := (Pphi l P).
+ (** Proofs *)
+ Lemma ZPminus_spec : forall x y,
+  match ZPminus x y with
+  | Z0 => x = y
+  | Zpos k => x = (y + k)%positive
+  | Zneg k => y = (x + k)%positive
+  end.
+ Proof.
+  induction x;destruct y.
+  replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+  replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
+  apply Pplus_xI_double_minus_one.
+  simpl;trivial.
+  replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
+  apply Pplus_xI_double_minus_one.
+  replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
+  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+  replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial.
+  rewrite <- Pplus_one_succ_l.
+  rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+  replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial.
+  replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial.
+  rewrite <- Pplus_one_succ_l.
+  rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+  simpl;trivial.
+ Qed.
+  
+ Lemma Peq_ok : forall P P', 
+    (P ?== P') = true -> forall l, P@l == P'@ l.
+ Proof.
+  induction P;destruct P';simpl;intros;try discriminate;trivial.
+  apply (morph_eq CRmorph);trivial.
+  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+   try discriminate H.
+  rewrite (IHP P' H); rewrite H1;trivial;rrefl.
+  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+   try discriminate H.
+  rewrite H1;trivial. clear H1.
+  assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
+   destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
+                         |discriminate H].
+  rewrite (H1 H);rewrite (H2 H);rrefl.
+ Qed.
+
+ Lemma Pphi0 : forall l, P0@l == 0.
+ Proof.
+  intros;simpl;apply (morph0 CRmorph).
+ Qed.
+
+ Lemma Pphi1 : forall l,  P1@l == 1.
+ Proof.
+  intros;simpl;apply (morph1 CRmorph).
+ Qed.
+
+ Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
+ Proof.
+  intros j l p;destruct p;simpl;rsimpl.
+  rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl.
+ Qed.
+
+ Let pow_pos_Pplus := 
+    pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
+
+ Lemma mkPX_ok : forall l P i Q, 
+  (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
+ Proof.
+  intros l P i Q;unfold mkPX.
+  destruct P;try (simpl;rrefl).
+  assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
+  rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
+  rewrite mkPinj_ok;rsimpl;simpl;rrefl.
+  assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
+  rewrite (H (refl_equal true));trivial.
+  rewrite Pphi0.  rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+ Ltac Esimpl :=
+  repeat (progress (
+   match goal with
+   | |- context [P0@?l] => rewrite (Pphi0 l)
+   | |- context [P1@?l] => rewrite (Pphi1 l)
+   | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P)
+   | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q)
+   | |- context [[cO]] => rewrite (morph0 CRmorph)
+   | |- context [[cI]] => rewrite (morph1 CRmorph)
+   | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y)
+   | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y)
+   | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y)
+   | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x)
+   end));
+  rsimpl; simpl. 
+ 
+ Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
+ Proof.
+  induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
+ Proof.
+  induction P;simpl;intros.
+  Esimpl.
+  rewrite IHP;rsimpl.
+  rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
+ Proof.
+  induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+  mul_push ([c]);rrefl.
+ Qed. 
+
+ Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
+ Proof.
+  intros c P l; unfold PmulC.
+  assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
+  rewrite (H (refl_equal true));Esimpl.
+  assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+  rewrite (H1 (refl_equal true));Esimpl.
+  apply PmulC_aux_ok.
+ Qed.
+
+ Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Proof.
+  induction P;simpl;intros.
+  Esimpl.
+  apply IHP.
+  rewrite IHP1;rewrite IHP2;rsimpl.
+ Qed.
+
+ Ltac Esimpl2 :=
+  Esimpl;
+  repeat (progress (
+   match goal with 
+   | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
+   | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
+   | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
+   | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
+   end)); Esimpl.
+
+ Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
+ Proof.
+  induction P';simpl;intros;Esimpl2.
+  generalize P p l;clear P p l.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARadd_comm ARth).
+  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+  rewrite H;Esimpl. rewrite IHP';rrefl.
+  rewrite H;Esimpl. rewrite IHP';Esimpl.
+  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
+  rewrite H;Esimpl. rewrite IHP.
+  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
+  destruct p0;simpl.
+  rewrite IHP2;simpl;rsimpl.
+  rewrite IHP2;simpl.
+  rewrite jump_Pdouble_minus_one;rsimpl.
+  rewrite IHP';rsimpl.
+  destruct P;simpl. 
+  Esimpl2;add_push [c];rrefl.
+  destruct p0;simpl;Esimpl2.
+  rewrite IHP'2;simpl.
+  rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+  rewrite IHP'2;simpl.
+  rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+  rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl.
+  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+  rewrite IHP'1;rewrite IHP'2;rsimpl.
+  add_push (P3 @ (tail l));rewrite H;rrefl.
+  rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
+  rewrite H;rewrite Pplus_comm.
+  rewrite pow_pos_Pplus;rsimpl.
+  add_push (P3 @ (tail l));rrefl.
+  assert (forall P k l, 
+           (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
+   induction P;simpl;intros;try apply (ARadd_comm ARth).
+   destruct p2;simpl;try apply (ARadd_comm ARth).
+   rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth).
+    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
+    rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP'1;simpl;Esimpl.
+    rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;Esimpl.
+    add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;rsimpl.
+    add_push (P5 @ (tail l0));rrefl.
+  rewrite H0;rsimpl.
+  add_push (P3 @ (tail l)).
+  rewrite H;rewrite Pplus_comm.
+  rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
+  add_push (P3 @ (tail l));rrefl.
+ Qed.
+
+ Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+ Proof.
+  induction P';simpl;intros;Esimpl2;trivial.
+  generalize P p l;clear P p l.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARadd_comm ARth).
+  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+  rewrite H;Esimpl. rewrite IHP';rsimpl. 
+  rewrite H;Esimpl. rewrite IHP';Esimpl.
+  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
+  rewrite H;Esimpl. rewrite IHP.
+  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
+  destruct p0;simpl.
+  rewrite IHP2;simpl;rsimpl.
+  rewrite IHP2;simpl.
+  rewrite jump_Pdouble_minus_one;rsimpl.
+  rewrite IHP';rsimpl. 
+  destruct P;simpl. 
+  repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
+  destruct p0;simpl;Esimpl2.
+  rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
+  add_push (P @ (jump p0 (jump p0 (tail l))));rrefl.
+  rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl.
+  add_push (- (P'1 @ l * pow_pos  rmul (hd 0 l) p));rrefl.
+  rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl.
+  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+  rewrite IHP'1; rewrite IHP'2;rsimpl.
+  add_push (P3 @ (tail l));rewrite H;rrefl.
+   rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
+  rewrite H;rewrite Pplus_comm.
+  rewrite pow_pos_Pplus;rsimpl.
+  add_push (P3 @ (tail l));rrefl.
+  assert (forall P k l, 
+           (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
+   induction P;simpl;intros.
+   rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
+   destruct p2;simpl;rewrite Popp_ok;rsimpl.
+   apply (ARadd_comm ARth);trivial.
+   rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial.
+   apply (ARadd_comm ARth);trivial.
+    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
+    rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
+    rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;Esimpl.
+    add_push (P5 @ (tail l0));rrefl.
+    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+    rewrite pow_pos_Pplus;simpl;rsimpl.
+    add_push (P5 @ (tail l0));rrefl.
+  rewrite H0;rsimpl.
+  rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
+  rewrite H;rewrite Pplus_comm.
+  rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+(* Proof for the symmetriv version *)
+
+ Lemma PmulI_ok : 
+  forall P', 
+   (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) ->
+   forall (P : Pol) (p : positive) (l : list R),
+    (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARmul_comm ARth).
+  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+  rewrite H1; rewrite H;rrefl.
+  rewrite H1; rewrite H.
+  rewrite Pplus_comm.
+  rewrite jump_Pplus;simpl;rrefl.
+  rewrite H1;rewrite Pplus_comm.
+  rewrite jump_Pplus;rewrite IHP;rrefl.
+  destruct p0;Esimpl2.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+  rewrite IHP1;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p).
+  rewrite H;rrefl.
+ Qed.
+
+(*
+ Lemma PmulI_ok : 
+  forall P', 
+   (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
+   forall (P : Pol) (p : positive) (l : list R),
+    (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+  induction P;simpl;intros.
+  Esimpl2;apply (ARmul_comm ARth).
+  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+  rewrite H1; rewrite H;rrefl.
+  rewrite H1; rewrite H.
+  rewrite Pplus_comm.
+  rewrite jump_Pplus;simpl;rrefl.
+  rewrite H1;rewrite Pplus_comm.
+  rewrite jump_Pplus;rewrite IHP;rrefl.
+  destruct p0;Esimpl2.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+  rewrite IHP1;simpl;rsimpl.
+  mul_push (pow_pos rmul (hd 0 l) p).
+  rewrite H;rrefl.
+ Qed.
+
+ Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
+ Proof.
+  induction P';simpl;intros.
+  Esimpl2;trivial.
+  apply PmulI_ok;trivial.
+  rewrite Padd_ok;Esimpl2.
+  rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
+ Qed.
+*)
+
+(* Proof for the symmetric version *)
+ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+  intros P P';generalize P;clear P;induction P';simpl;intros.
+  apply PmulC_ok. apply PmulI_ok;trivial.
+  destruct P.
+  rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
+  Esimpl2. rewrite IHP'1;Esimpl2.
+   assert (match p0 with
+           | xI j => Pinj (xO j) P ** P'2
+           | xO j => Pinj (Pdouble_minus_one j) P ** P'2 
+           | 1 => P ** P'2
+           end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
+   destruct p0;simpl;rewrite IHP'2;Esimpl.
+   rewrite jump_Pdouble_minus_one;Esimpl.
+   rewrite H;Esimpl.
+   rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
+   repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
+   rewrite PmulI_ok;trivial.
+   mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl.
+ Qed.
+
+(*
+Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+  destruct P;simpl;intros.
+  Esimpl2;apply (ARmul_comm ARth).
+  rewrite (PmulI_ok P (Pmul_aux_ok P)).
+  apply (ARmul_comm ARth).
+  rewrite Padd_ok; Esimpl2.
+  rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
+  rewrite Pmul_aux_ok;mul_push (P' @ l).
+  rewrite (ARmul_comm ARth (P' @ l));rrefl.
+ Qed.
+*)
+
+ Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Proof.
+  induction P;simpl;intros;Esimpl2.
+  apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
+  rewrite IHP1;rewrite IHP2.
+  mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l).
+  rrefl.
+ Qed.
+
+
+ Lemma mkZmon_ok: forall M j l,
+   Mphi l (mkZmon j M) == Mphi l (zmon j M).
+ intros M j l; case M; simpl; intros; rsimpl.
+ Qed.
+ 
+ Lemma zmon_pred_ok : forall M j l, 
+    Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
+ Proof.
+   destruct j; simpl;intros auto; rsimpl.
+   rewrite mkZmon_ok;rsimpl.
+   rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl.
+ Qed.
+
+ Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
+ Proof.
+  destruct M;simpl;intros;rsimpl.
+   rewrite zmon_pred_ok;simpl;rsimpl.
+  rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+
+ Lemma Mphi_ok: forall P M l, 
+    let (Q,R) := MFactor P M in
+      P@l == Q@l + (Mphi l M) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+   intros c M l; case M; simpl; auto; try intro p; try intro m;
+   try rewrite (morph0 CRmorph); rsimpl.
+
+   intros i P Hrec M l; case M; simpl; clear M.
+     rewrite (morph0 CRmorph); rsimpl.
+     intros j M.
+     case_eq ((i ?= j) Eq); intros He; simpl.
+       rewrite (Pcompare_Eq_eq _ _ He).
+       generalize (Hrec M (jump j l)); case (MFactor P M);
+        simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+       generalize (Hrec (zmon (j -i) M) (jump i l)); 
+       case (MFactor P (zmon (j -i) M)); simpl.
+       intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+       rewrite  <- (Pplus_minus _ _ (ZC2 _ _ He)).
+       rewrite Pplus_comm; rewrite jump_Pplus; auto.
+       rewrite (morph0 CRmorph); rsimpl.
+       intros P2 m; rewrite (morph0 CRmorph); rsimpl.
+
+   intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
+   rewrite (morph0 CRmorph); rsimpl.
+   intros j M1.
+     generalize (Hrec1 (zmon j M1) l); 
+     case (MFactor P2 (zmon j M1)).
+     intros R1 S1 H1.
+     generalize (Hrec2 (zmon_pred j M1) (List.tail l)); 
+     case (MFactor Q2 (zmon_pred j M1)); simpl.
+     intros R2 S2 H2; rewrite H1; rewrite H2.
+     repeat rewrite mkPX_ok; simpl.
+     rsimpl.  
+     apply radd_ext; rsimpl.
+     rewrite (ARadd_comm ARth); rsimpl.
+     apply radd_ext; rsimpl.
+     rewrite (ARadd_comm ARth); rsimpl.
+     rewrite zmon_pred_ok;rsimpl.
+   intros j M1.
+     case_eq ((i ?= j) Eq); intros He; simpl.
+       rewrite (Pcompare_Eq_eq _ _ He).
+       generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       rewrite mkZmon_ok.
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       generalize (Hrec1 (vmon (j - i) M1) l); 
+             case (MFactor P2 (vmon (j - i) M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
+       rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       apply rmul_ext; rsimpl.
+       rewrite <- pow_pos_Pplus.
+       rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
+       generalize (Hrec1 (mkZmon 1 M1) l); 
+             case (MFactor P2 (mkZmon 1 M1));
+        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+       rewrite H; rsimpl.
+       rewrite mkPX_ok; rsimpl.
+       repeat (rewrite <-(ARadd_assoc ARth)).
+       apply radd_ext; rsimpl.
+       rewrite (ARadd_comm ARth); rsimpl.
+       apply radd_ext; rsimpl.
+       rewrite mkZmon_ok.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       apply rmul_ext; rsimpl.
+       rewrite (ARmul_comm ARth); rsimpl.
+       rewrite mkPX_ok; simpl; rsimpl.
+       rewrite (morph0 CRmorph); rsimpl.
+       repeat (rewrite <-(ARmul_assoc ARth)).
+       rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
+       apply rmul_ext; rsimpl.
+       rewrite <- pow_pos_Pplus.
+       rewrite (Pplus_minus _ _ He); rsimpl.
+ Qed.
+
+(* Proof for the symmetric version *)
+
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+    POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+   intros c H; rewrite H.
+   generalize (morph_eq CRmorph c cO);
+        case (c ?=! cO); simpl; auto.
+   intros H1 H2; rewrite H1; auto; rsimpl.
+   discriminate.
+   intros _ H1 H2; injection H1; intros; subst.
+   rewrite H2; rsimpl.
+ (* new version *)
+   rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
+ intros i P5 H; rewrite H.
+   intros HH H1; injection HH; intros; subst; rsimpl.
+   rewrite Padd_ok; rewrite PmulI_ok. intros;apply Pmul_ok. rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+   assert (P4 = Q1 ++ P3 ** PX i P5 P6).
+   injection H2; intros; subst;trivial.
+  rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl.
+ Qed.
+(*
+  Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+    POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+   intros c H; rewrite H.
+   generalize (morph_eq CRmorph c cO);
+        case (c ?=! cO); simpl; auto.
+   intros H1 H2; rewrite H1; auto; rsimpl.
+   discriminate.
+   intros _ H1 H2; injection H1; intros; subst.
+   rewrite H2; rsimpl.
+  rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
+  intros i P5 H; rewrite H.
+   intros HH H1; injection HH; intros; subst; rsimpl.
+   rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl.
+   intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+   injection H2; intros; subst; rsimpl.
+   rewrite Padd_ok.
+   rewrite Pmul_ok; rsimpl.
+ Qed. 
+*)
+ Lemma PNSubst1_ok: forall n P1 M1 P2 l,
+    Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+ Proof.
+ intros n; elim n; simpl; auto.
+   intros P2 M1 P3 l H.
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
+   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+   intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
+ intros n1 Hrec P2 M1 P3 l H.
+   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
+   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+   intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ Qed.
+
+ Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
+    PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros n P2 M1 P3 l P4; unfold PNSubst.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); 
+ case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
+ intros P5 H1; case n; try (intros; discriminate). 
+ intros n1 H2; injection H2; intros; subst.
+ rewrite <- PNSubst1_ok; auto.
+ Qed.
+
+ Fixpoint MPcond (LM1: list (Mon * Pol)) (l: list R) {struct LM1} : Prop :=            
+    match LM1 with 
+     cons (M1,P2) LM2 =>  (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
+    | _ => True
+    end.
+
+ Lemma PSubstL1_ok: forall n LM1 P1 l,
+    MPcond LM1 l ->  P1@l == (PSubstL1 P1 LM1 n)@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+   intros; rsimpl.
+ intros (M2,P2) LM2 Hrec P3 l [H H1].
+ rewrite <- Hrec; auto.
+ apply PNSubst1_ok; auto.
+ Qed.
+
+ Lemma PSubstL_ok: forall n LM1 P1 P2 l,
+   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l ->  P1@l == P2@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+   intros; discriminate.
+ intros (M2,P2) LM2 Hrec P3 P4 l.
+ generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
+   intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
+   rewrite <- PSubstL1_ok; auto.
+ intros l1 H [H1 H2]; auto.
+ Qed.
+
+ Lemma PNSubstL_ok: forall m n LM1 P1 l,
+    MPcond LM1 l ->  P1@l == (PNSubstL P1 LM1 m n)@l.
+ Proof.
+ intros m; elim m; simpl; auto.
+   intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ intros m1 Hrec n LM1 P2 l H.
+ generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ rewrite <- Hrec; auto.
+ Qed.
+
+ (** Definition of polynomial expressions *)
+
+ Inductive PExpr : Type :=
+  | PEc : C -> PExpr
+  | PEX : positive -> PExpr
+  | PEadd : PExpr -> PExpr -> PExpr
+  | PEsub : PExpr -> PExpr -> PExpr
+  | PEmul : PExpr -> PExpr -> PExpr
+  | PEopp : PExpr -> PExpr
+  | PEpow : PExpr -> N -> PExpr.
+
+ (** evaluation of polynomial expressions towards R *)
+ Definition mk_X j := mkPinj_pred j mkX.
+
+ (** evaluation of polynomial expressions towards R *)
+
+ Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R :=
+   match pe with
+   | PEc c => phi c
+   | PEX j => nth 0 j l
+   | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
+   | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
+   | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
+   | PEopp pe1 => - (PEeval l pe1)
+   | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n)
+   end.
+
+ (** Correctness proofs *)
+ 
+ Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
+ Proof.
+  destruct p;simpl;intros;Esimpl;trivial.
+  rewrite <-jump_tl;rewrite nth_jump;rrefl.
+  rewrite <- nth_jump.
+  rewrite nth_Pdouble_minus_one;rrefl.
+ Qed.
+
+ Ltac Esimpl3 := 
+  repeat match goal with
+  | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
+  | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
+  end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). 
+
+(* Power using the chinise algorithm *)
+(*Section POWER.
+  Variable subst_l : Pol -> Pol.
+  Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
+   match p with
+   | xH => P
+   | xO p => subst_l (Psquare (Ppow_pos P p))
+   | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
+   end.
+ 
+  Definition Ppow_N P n :=
+   match n with
+   | N0 => P1
+   | Npos p => Ppow_pos P p
+   end.
+ 
+  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+         forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
+  Proof.
+   intros l subst_l_ok P.
+   induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
+   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+  Qed.
+ 
+  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
+         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+  Proof.  destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial.  Qed.
+    
+ End POWER. *)
+
+Section POWER.
+  Variable subst_l : Pol -> Pol.
+  Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+   match p with
+   | xH => subst_l (Pmul res P) 
+   | xO p => Ppow_pos (Ppow_pos res P p) P p
+   | xI p => subst_l (Pmul  (Ppow_pos (Ppow_pos res P p) P p) P)
+   end.
+ 
+  Definition Ppow_N P n :=
+   match n with
+   | N0 => P1
+   | Npos p => Ppow_pos P1 P p
+   end.
+ 
+  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+         forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
+  Proof.
+   intros l subst_l_ok res P p. generalize res;clear res.
+   induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp.
+   rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl.
+  Qed.
+ 
+  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
+         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+  Proof.  destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl.  Qed.
+    
+ End POWER.
+
+ (** Normalization and rewriting *)
+
+ Section NORM_SUBST_REC.
+  Variable n : nat.
+  Variable lmp:list (Mon*Pol).
+  Let subst_l P := PNSubstL P lmp n n.
+  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+  Let Ppow_subst := Ppow_N subst_l.
+
+  Fixpoint norm_aux (pe:PExpr) : Pol :=
+   match pe with
+   | PEc c => Pc c
+   | PEX j => mk_X j  
+   | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
+   | PEadd pe1 (PEopp pe2) => 
+     Psub (norm_aux pe1) (norm_aux pe2)
+   | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
+   | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
+   | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) 
+   | PEopp pe1 => Popp (norm_aux pe1)
+   | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
+   end.
+
+  Definition norm_subst pe := subst_l (norm_aux pe).
+
+ (* 
+  Fixpoint norm_subst (pe:PExpr) : Pol :=
+   match pe with
+   | PEc c => Pc c
+   | PEX j => subst_l (mk_X j)  
+   | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
+   | PEadd pe1 (PEopp pe2) => 
+     Psub (norm_subst pe1) (norm_subst pe2)
+   | PEadd pe1 pe2 => Padd (norm_subst  pe1) (norm_subst pe2)
+   | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
+   | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) 
+   | PEopp pe1 => Popp (norm_subst pe1)
+   | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
+   end.
+
+  Lemma norm_subst_spec : 
+     forall l pe, MPcond lmp l ->
+       PEeval l pe == (norm_subst pe)@l. 
+  Proof.
+   intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). 
+      unfold subst_l;intros.
+      rewrite <- PNSubstL_ok;trivial. rrefl.
+   assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
+    intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
+   induction pe;simpl;Esimpl3.
+   rewrite subst_l_ok;apply mkX_ok.
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. 
+   rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite IHpe;rrefl.
+   unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
+   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; 
+      repeat rewrite Pmul_ok;rrefl.
+  Qed.
+*)
+ Lemma norm_aux_spec : 
+     forall l pe, MPcond lmp l ->
+       PEeval l pe == (norm_aux pe)@l. 
+  Proof.
+   intros.
+   induction pe;simpl;Esimpl3.
+   apply mkX_ok.
+   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. 
+   rewrite IHpe1;rewrite IHpe2;rrefl.
+   rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
+   rewrite IHpe;rrefl.
+   rewrite Ppow_N_ok. intros;rrefl.
+   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; 
+      repeat rewrite Pmul_ok;rrefl.
+  Qed.
+
+ Lemma norm_subst_spec : 
+     forall l pe, MPcond lmp l ->
+       PEeval l pe == (norm_subst pe)@l.
+ Proof.
+  intros;unfold norm_subst.
+  unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial.
+ Qed. 
+ 
+ End NORM_SUBST_REC.
+  
+ Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop :=
+   match lpe with
+   | nil => True
+   | (me,pe)::lpe => 
+     match lpe with
+     | nil => PEeval l me == PEeval l pe
+     | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe
+     end
+  end.
+
+  Fixpoint mon_of_pol (P:Pol) : option Mon :=
+  match P with
+  | Pc c => if (c ?=! cI) then Some mon0 else None
+  | Pinj j P =>
+    match mon_of_pol P with 
+    | None => None
+    | Some m =>  Some (mkZmon j m) 
+    end
+  | PX P i Q =>
+    if Peq Q P0 then
+      match mon_of_pol P with
+      | None => None
+      | Some m => Some (mkVmon i m)
+      end
+    else None
+  end.
+
+ Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (Mon*Pol) :=
+  match lpe with
+  | nil => nil
+  | (me,pe)::lpe =>
+    match mon_of_pol (norm_subst 0 nil me) with
+    | None => mk_monpol_list lpe 
+    | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe 
+    end
+  end.
+
+  Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m ->
+              forall l, Mphi l m == P@l.
+  Proof.
+    induction P;simpl;intros;Esimpl.  
+    assert (H1 := (morph_eq CRmorph) c cI).
+    destruct (c ?=! cI).
+    inversion H;rewrite H1;trivial;Esimpl.
+    discriminate.
+    generalize H;clear H;case_eq (mon_of_pol P);intros;try discriminate.
+    inversion H0.
+    rewrite mkZmon_ok;simpl;auto.
+    generalize H;clear H;change match P3 with
+        | Pc c => c ?=! cO
+        | Pinj _ _ => false
+        | PX _ _ _ => false
+        end with (P3 ?== P0).
+    assert (H := Peq_ok P3 P0).
+    destruct (P3 ?== P0).
+    case_eq (mon_of_pol P2);intros.
+    inversion H1.
+    rewrite mkVmon_ok;simpl.
+    rewrite H;trivial;Esimpl.  rewrite IHP1;trivial;Esimpl. discriminate.
+    intros;discriminate.
+   Qed.
+ 
+ Lemma interp_PElist_ok : forall l lpe, 
+         interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l.
+ Proof.
+   induction lpe;simpl. trivial.
+   destruct a;simpl;intros.
+   assert (HH:=mon_of_pol_ok (norm_subst 0 nil  p));
+     destruct  (mon_of_pol (norm_subst 0 nil p)).  
+   split.
+   rewrite <- norm_subst_spec. exact I.
+   destruct lpe;try destruct H;rewrite <- H;
+   rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial.
+   apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0.
+   apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0.
+ Qed.
+
+ Lemma norm_subst_ok : forall n l lpe pe,
+   interp_PElist l lpe ->
+   PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l.
+ Proof.
+   intros;apply norm_subst_spec. apply interp_PElist_ok;trivial.
+  Qed.
+ 
+ Lemma ring_correct : forall n l lpe pe1 pe2,
+   interp_PElist l lpe ->
+   (let lmp := mk_monpol_list lpe in
+   norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true ->
+   PEeval l pe1 == PEeval l pe2.
+ Proof.
+  simpl;intros.
+  do 2 (rewrite (norm_subst_ok n l lpe);trivial). 
+  apply Peq_ok;trivial.
+ Qed.  
+
+
+
+  (** Generic evaluation of polynomial towards R avoiding parenthesis *)
+ Variable get_sign : C -> option C.
+ Variable get_sign_spec : sign_theory ropp req phi get_sign.
+
+
+ Section EVALUATION.
+
+  (* [mkpow x p] = x^p *)
+  Variable mkpow : R -> positive -> R.
+  (* [mkpow x p] = -(x^p) *)
+  Variable mkopp_pow : R -> positive -> R.
+  (* [mkmult_pow r x p] = r * x^p *)
+  Variable mkmult_pow : R -> R -> positive -> R.
+    
+  Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R :=
+   match lm with
+   | nil => r
+   | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t 
+   end.
+
+  Definition mkmult1 lm :=
+   match lm with
+   | nil => 1
+   | cons (x,p) t => mkmult_rec (mkpow x p) t 
+   end.
+
+  Definition mkmultm1 lm :=
+   match lm with
+   | nil => ropp rI
+   | cons (x,p) t => mkmult_rec (mkopp_pow x p) t 
+   end.
+
+  Definition mkmult_c_pos c lm :=
+   if c ?=! cI then mkmult1 (rev' lm)
+   else mkmult_rec [c] (rev' lm).
+
+  Definition mkmult_c c lm :=
+   match get_sign c with
+   | None => mkmult_c_pos c lm
+   | Some c' => 
+     if c' ?=! cI then mkmultm1 (rev' lm)
+     else mkmult_rec [c] (rev' lm)
+   end.
+      
+  Definition mkadd_mult rP c lm :=
+   match get_sign c with
+   | None => rP + mkmult_c_pos c lm
+   | Some c' => rP - mkmult_c_pos c' lm
+   end.
+
+  Definition add_pow_list (r:R) n l :=
+   match n with 
+   | N0 => l
+   | Npos p => (r,p)::l
+   end.
+
+  Fixpoint add_mult_dev 
+      (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R :=
+   match P with
+   | Pc c => 
+     let lm := add_pow_list (hd 0 fv) n lm in
+     mkadd_mult rP c lm
+   | Pinj j Q => 
+     add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
+   | PX P i Q => 
+     let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in
+     if Q ?== P0 then rP 
+     else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm)
+   end.
+
+  Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) 
+                     (lm:list (R*positive)) {struct P} : R :=
+  (* P@l * (hd 0 l)^n * lm *)						      
+  match P with
+  | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm)
+  | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
+  | PX P i Q => 
+     let rP := mult_dev P fv (Nplus (Npos i) n) lm in
+     if Q ?== P0 then rP 
+     else 
+       let lmq := add_pow_list (hd 0 fv) n lm in
+       add_mult_dev rP Q (tail fv) N0 lmq
+  end. 
+
+ Definition Pphi_avoid fv P := mult_dev P fv N0 nil.
+ 
+ Fixpoint r_list_pow (l:list (R*positive)) : R :=
+  match l with
+  | nil => rI
+  | cons (r,p) l => pow_pos rmul r p * r_list_pow l 
+  end.
+
+  Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p.
+  Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). 
+  Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p.
+
+ Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm.
+ Proof.
+   induction lm;intros;simpl;Esimpl.
+   destruct a as (x,p);Esimpl.
+   rewrite IHlm. rewrite mkmult_pow_spec. Esimpl.
+  Qed.
+
+ Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm.
+ Proof.
+   destruct lm;simpl;Esimpl.
+   destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl.
+ Qed.
+
+ Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm.
+ Proof.
+  destruct lm;simpl;Esimpl.
+  destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl.
+ Qed.
+
+ Lemma r_list_pow_rev :  forall l, r_list_pow (rev' l) == r_list_pow l.
+ Proof.
+   assert 
+    (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l).
+   induction l;intros;simpl;Esimpl.
+   destruct a;rewrite IHl;Esimpl.
+   rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl.
+  intros;unfold rev'. rewrite H;simpl;Esimpl.
+  Qed.
+
+ Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm.
+ Proof.
+  intros;unfold mkmult_c_pos;simpl.
+   assert (H := (morph_eq CRmorph) c cI).
+   rewrite <- r_list_pow_rev; destruct (c ?=! cI). 
+  rewrite H;trivial;Esimpl.
+  apply mkmult1_ok.  apply mkmult_rec_ok.
+ Qed.
+
+ Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm.
+ Proof.
+  intros;unfold mkmult_c;simpl.
+  case_eq (get_sign c);intros.
+  assert (H1 := (morph_eq CRmorph) c0  cI).
+  destruct (c0 ?=! cI).
+   rewrite (get_sign_spec.(sign_spec) _ H). rewrite H1;trivial.
+   rewrite <- r_list_pow_rev;trivial;Esimpl.
+  apply mkmultm1_ok.
+ rewrite <- r_list_pow_rev; apply mkmult_rec_ok.
+ apply mkmult_c_pos_ok.
+Qed.
+
+ Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm.
+ Proof.
+  intros;unfold mkadd_mult.
+  case_eq (get_sign c);intros.
+  rewrite (get_sign_spec.(sign_spec) _ H).
+  rewrite mkmult_c_pos_ok;Esimpl.
+  rewrite mkmult_c_pos_ok;Esimpl.
+ Qed.
+
+ Lemma add_pow_list_ok : 
+      forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l.
+ Proof.
+   destruct n;simpl;intros;Esimpl.
+ Qed.
+
+ Lemma add_mult_dev_ok : forall P rP fv n lm, 
+    add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
+  Proof.
+    induction P;simpl;intros.  
+    rewrite mkadd_mult_ok. rewrite  add_pow_list_ok; Esimpl.
+    rewrite IHP. simpl. rewrite  add_pow_list_ok; Esimpl.
+    change (match P3 with
+       | Pc c => c ?=! cO
+       | Pinj _ _ => false
+       | PX _ _ _ => false
+       end) with (Peq P3 P0).
+   change match n with
+    | N0 => Npos p
+    | Npos q => Npos (p + q)
+    end with (Nplus (Npos p) n);trivial.
+   assert (H := Peq_ok P3 P0).
+    destruct (P3 ?== P0).
+    rewrite (H (refl_equal true)).
+   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+   rewrite  IHP2.
+   rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+ Qed.
+
+ Lemma mult_dev_ok : forall P fv n lm,    
+    mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
+ Proof.
+   induction P;simpl;intros;Esimpl.
+   rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl.
+   rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl.
+  change (match P3 with
+       | Pc c => c ?=! cO
+       | Pinj _ _ => false
+       | PX _ _ _ => false
+       end) with (Peq P3 P0).
+   change match n with
+    | N0 => Npos p
+    | Npos q => Npos (p + q)
+    end with (Nplus (Npos p) n);trivial.
+   assert (H := Peq_ok P3 P0).
+    destruct (P3 ?== P0).
+    rewrite (H (refl_equal true)).
+   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+   rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok.
+   destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+  Qed.
+
+ Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P  == P@fv.
+ Proof.
+   unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl.
+ Qed.
+
+ End EVALUATION.
+
+  Definition Pphi_pow := 
+   let mkpow x p := 
+      match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in
+   let mkopp_pow x p := ropp (mkpow x p)  in
+   let mkmult_pow r x p := rmul r (mkpow x p) in
+    Pphi_avoid mkpow mkopp_pow mkmult_pow.
+
+ Lemma local_mkpow_ok : 
+   forall (r : R) (p : positive),
+    match p with
+    | xI _ => rpow r (Cp_phi (Npos p))
+    | xO _ => rpow r (Cp_phi (Npos p))
+    | 1 => r
+    end == pow_pos rmul r p.
+ Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed.
+ 
+ Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P  == P@fv.
+ Proof.
+  unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl.
+ Qed.
+
+ Lemma ring_rw_pow_correct : forall n lH l,  
+      interp_PElist l lH ->
+      forall lmp, mk_monpol_list lH = lmp ->
+      forall pe npe, norm_subst n lmp pe = npe ->
+      PEeval l pe == Pphi_pow l npe.
+ Proof.
+  intros n lH l H1 lmp Heq1 pe npe Heq2.
+  rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1.
+  apply norm_subst_ok. trivial.
+ Qed.
+
+ Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := 
+   match p with
+   | xH => r*x 
+   | xO p => mkmult_pow (mkmult_pow r x p) x p
+   | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p
+   end.
+ 
+  Definition mkpow x p :=
+    match p with 
+    | xH => x
+    | xO p => mkmult_pow x x (Pdouble_minus_one p)
+    | xI p => mkmult_pow x x (xO p)
+    end.
+ 
+  Definition mkopp_pow x p :=
+    match p with 
+    | xH => -x
+    | xO p => mkmult_pow (-x) x (Pdouble_minus_one p)
+    | xI p => mkmult_pow (-x) x (xO p)
+    end.
+
+  Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow.
+
+  Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p.
+  Proof.
+    induction p;intros;simpl;Esimpl.   
+    repeat rewrite IHp;Esimpl.
+    repeat rewrite IHp;Esimpl.
+  Qed.
+  
+ Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p.
+  Proof.
+    destruct p;simpl;intros;Esimpl.
+    repeat rewrite mkmult_pow_ok;Esimpl.
+    rewrite mkmult_pow_ok;Esimpl.
+    pattern x at 1;replace x with (pow_pos rmul x 1). 
+    rewrite <- pow_pos_Pplus. 
+    rewrite <- Pplus_one_succ_l.
+    rewrite Psucc_o_double_minus_one_eq_xO.
+    simpl;Esimpl.
+    trivial.
+  Qed.
+ 
+  Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p.
+  Proof.
+    destruct p;simpl;intros;Esimpl.
+    repeat rewrite mkmult_pow_ok;Esimpl.
+    rewrite mkmult_pow_ok;Esimpl.
+    pattern x at 1;replace x with (pow_pos rmul x 1). 
+    rewrite <- pow_pos_Pplus. 
+    rewrite <- Pplus_one_succ_l.
+    rewrite Psucc_o_double_minus_one_eq_xO.
+    simpl;Esimpl.
+    trivial.
+  Qed.
+
+ Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv.
+  Proof.
+   unfold Pphi_dev;intros;apply Pphi_avoid_ok.
+   intros;apply mkpow_ok.
+   intros;apply mkopp_pow_ok.
+   intros;apply mkmult_pow_ok.
+  Qed.
+
+ Lemma ring_rw_correct : forall n lH l,  
+      interp_PElist l lH ->
+      forall lmp, mk_monpol_list lH = lmp ->
+      forall pe npe, norm_subst n lmp pe = npe ->
+      PEeval l pe == Pphi_dev l npe.
+ Proof.
+  intros n lH l H1 lmp Heq1 pe npe Heq2.
+  rewrite  Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1.
+  apply norm_subst_ok. trivial.
+ Qed.
+
+
+End MakeRingPol.
+
diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v
new file mode 100644
index 00000000..7419f184
--- /dev/null
+++ b/contrib/setoid_ring/Ring_tac.v
@@ -0,0 +1,356 @@
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinPos.
+Require Import Ring_polynom.
+Require Import BinList.
+Require Import InitialRing.
+Declare ML Module "newring".
+  
+
+(* adds a definition id' on the normal form of t and an hypothesis id
+   stating that t = id' (tries to produces a proof as small as possible) *)
+Ltac compute_assertion id  id' t :=
+  let t' := eval vm_compute in t in
+  pose (id' := t');
+  assert (id : t = id');
+  [vm_cast_no_check (refl_equal id')|idtac].
+(* [exact_no_check (refl_equal id'<: t = id')|idtac]). *)
+
+Ltac getGoal :=
+  match goal with 
+  | |- ?G => G
+  end.
+
+(********************************************************************)
+(* Tacticals to build reflexive tactics *)
+
+Ltac OnEquation req :=
+  match goal with
+  | |- req ?lhs ?rhs => (fun f => f lhs rhs)
+  | _ => fail 1 "Goal is not an equation (of expected equality)"
+  end.
+
+Ltac OnMainSubgoal H ty :=
+  match ty with
+  | _ -> ?ty' =>
+     let subtac := OnMainSubgoal H ty' in
+     fun tac => lapply H; [clear H; intro H; subtac tac | idtac]
+  | _ => (fun tac => tac)
+  end.
+
+Ltac ApplyLemmaThen lemma expr tac :=
+  let nexpr := fresh "expr_nf" in
+  let H := fresh "eq_nf" in
+  let Heq := fresh "thm" in
+  let nf_spec :=
+    match type of (lemma expr) with
+      forall x, ?nf_spec = x -> _ => nf_spec
+    | _ => fail 1 "ApplyLemmaThen: cannot find norm expression"
+    end in
+  (compute_assertion H nexpr nf_spec;
+   (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma");
+   clear H;
+   OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr)).
+
+Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg :=
+  let npe := fresh "expr_nf" in
+  let H := fresh "eq_nf" in
+  let Heq := fresh "thm" in
+  let npe_spec :=
+    match type of (lemma expr) with
+      forall npe, ?npe_spec = npe -> _ => npe_spec
+    | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression"
+    end in
+  (compute_assertion H npe npe_spec;
+   (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma");
+   clear H;
+   OnMainSubgoal Heq ltac:(type of Heq)
+     ltac:(try tac Heq; clear Heq npe;CONT_tac cont_arg)).
+
+(* General scheme of reflexive tactics using of correctness lemma
+   that involves normalisation of one expression *)
+
+Ltac ReflexiveRewriteTactic FV_tac SYN_tac MAIN_tac LEMMA_tac fv terms :=
+  (* extend the atom list *)
+  let fv := list_fold_left FV_tac fv terms in
+  let RW_tac lemma := 
+     let fcons term CONT_tac cont_arg := 
+      let expr := SYN_tac term fv in
+      (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac cont_arg) in
+     (* rewrite steps *)
+     lazy_list_fold_right fcons ltac:(idtac) terms in
+  LEMMA_tac fv RW_tac.
+
+(********************************************************)
+
+
+(* Building the atom list of a ring expression *)
+Ltac FV Cst CstPow add mul sub opp pow t fv :=
+ let rec TFV t fv :=
+  match Cst t with
+  | NotConstant =>
+      match t with
+      | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+      | (opp ?t1) => TFV t1 fv
+      | (pow ?t1 ?n) =>
+        match CstPow n with
+        | InitialRing.NotConstant => AddFvTail t fv
+        | _ => TFV t1 fv
+        end
+      | _ => AddFvTail t fv
+      end
+  | _ => fv
+  end
+ in TFV t fv.
+
+ (* syntaxification of ring expressions *)
+Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := 
+ let rec mkP t :=
+    match Cst t with
+    | InitialRing.NotConstant =>
+        match t with 
+        | (radd ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(PEadd e1 e2)
+        | (rmul ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(PEmul e1 e2)
+        | (rsub ?t1 ?t2) => 
+          let e1 := mkP t1 in
+          let e2 := mkP t2 in constr:(PEsub e1 e2)
+        | (ropp ?t1) =>
+          let e1 := mkP t1 in constr:(PEopp e1)
+        | (rpow ?t1 ?n) =>
+          match CstPow n with
+          | InitialRing.NotConstant => 
+            let p := Find_at t fv in constr:(PEX C p)
+          | ?c => let e1 := mkP t1 in constr:(PEpow e1 c)
+          end
+        | _ =>
+          let p := Find_at t fv in constr:(PEX C p)
+        end
+    | ?c => constr:(PEc c)
+    end
+ in mkP t.
+
+Ltac ParseRingComponents lemma :=
+  match type of lemma with
+  | context
+     [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+      (fun f => f R add mul sub opp pow C)
+  | _ => fail 1 "ring anomaly: bad correctness lemma (parse)"
+  end.
+
+
+(* ring tactics *)
+
+Ltac FV_hypo_tac mkFV req lH :=
+  let R := match type of req with ?R -> _ => R end in
+  let FV_hypo_l_tac h :=
+    match h with @mkhypo (req ?pe _) _ => mkFV pe end in
+  let FV_hypo_r_tac h :=
+    match h with @mkhypo (req _ ?pe) _ => mkFV pe end in
+  let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in
+  list_fold_right FV_hypo_r_tac fv lH.
+
+Ltac mkHyp_tac C req mkPE lH :=
+  let mkHyp h res := 
+   match h with 
+   | @mkhypo (req ?r1 ?r2) _ =>
+     let pe1 := mkPE r1 in
+     let pe2 := mkPE r2 in
+     constr:(cons (pe1,pe2) res)
+   | _ => fail "hypothesis is not a ring equality"
+   end in
+  list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH.
+     
+Ltac proofHyp_tac lH :=
+  let get_proof h :=
+    match h with
+    | @mkhypo _ ?p => p
+    end in
+  let rec bh l :=
+    match l with
+    | nil => constr:(I)
+    | cons ?h nil => get_proof h
+    | cons ?h ?tl => 
+      let l := get_proof h in
+      let r := bh tl in  
+      constr:(conj l r)
+    end in
+  bh lH.
+
+Definition ring_subst_niter := (10*10*10)%nat.
+ 
+Ltac Ring Cst_tac CstPow_tac lemma1 req n lH :=
+  let Main lhs rhs R radd rmul rsub ropp rpow C :=
+    let mkFV := FV Cst_tac CstPow_tac radd rmul rsub ropp rpow in
+    let mkPol := mkPolexpr C Cst_tac CstPow_tac radd rmul rsub ropp rpow in
+    let fv := FV_hypo_tac mkFV req lH in
+    let fv := mkFV lhs fv in
+    let fv := mkFV rhs fv in
+    check_fv fv;
+    let pe1 := mkPol lhs fv in
+    let pe2 := mkPol rhs fv in
+    let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+    let vlpe := fresh "hyp_list" in
+    let vfv := fresh "fv_list" in
+    pose (vlpe := lpe);
+    pose (vfv := fv);
+    (apply (lemma1 n vfv vlpe pe1 pe2)
+      || fail "typing error while applying ring");
+    [ ((let prh := proofHyp_tac lH in exact prh)
+        || idtac "can not automatically proof hypothesis : maybe a left member of a hypothesis is not a monomial") 
+    | vm_compute;
+      (exact (refl_equal true) || fail "not a valid ring equation")] in
+  ParseRingComponents lemma1 ltac:(OnEquation req Main).
+
+Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl :=
+  let Main R add mul sub opp pow C :=
+    let mkFV := FV Cst_tac CstPow_tac add mul sub opp pow in
+    let mkPol := mkPolexpr C Cst_tac CstPow_tac add mul sub opp pow in
+    let fv := FV_hypo_tac mkFV req lH in
+    let simpl_ring H := (protect_fv "ring" in H; f H) in
+    let Coeffs :=
+      match type of lemma2 with
+      | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] =>
+        (fun f => f cO cI cadd cmul csub copp ceqb)
+      | _ => fail 1 "ring_simplify anomaly: bad correctness lemma"
+      end in
+    let lemma_tac fv RW_tac := 
+      let rr_lemma := fresh "r_rw_lemma" in
+      let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
+      let vlpe := fresh "list_hyp" in
+      let vlmp := fresh "list_hyp_norm" in
+      let vlmp_eq := fresh "list_hyp_norm_eq" in
+      let prh := proofHyp_tac lH in
+      pose (vlpe := lpe);
+      Coeffs ltac:(fun cO cI cadd cmul csub copp ceqb =>
+        compute_assertion vlmp_eq vlmp 
+            (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe);
+        assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq)
+         || fail "type error when build the rewriting lemma";
+        RW_tac rr_lemma;
+        try clear rr_lemma vlmp_eq vlmp vlpe) in
+    ReflexiveRewriteTactic mkFV mkPol simpl_ring lemma_tac fv rl in
+  ParseRingComponents lemma2 Main.
+
+Ltac Ring_gen
+  req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl :=
+  pre();Ring cst_tac pow_tac lemma1 req ring_subst_niter lH.
+
+Tactic Notation (at level 0) "ring" :=
+  let G := getGoal in ring_lookup Ring_gen [] [G].
+
+Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" :=
+  let G := getGoal in ring_lookup Ring_gen [lH] [G].
+
+(* Simplification *)
+
+Ltac Ring_simplify_gen f :=
+  fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
+     let l := fresh "to_rewrite" in
+     pose (l:= rl);
+     generalize (refl_equal l);
+     unfold l at 2;
+     pre(); 
+     match goal with
+     | [|- l = ?RL -> _ ] =>
+       let Heq := fresh "Heq" in
+       intros Heq;clear Heq l;
+       Ring_norm_gen f cst_tac pow_tac lemma2 req ring_subst_niter lH RL; 
+       post()
+     | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
+     end.
+
+Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H).
+
+Ltac Ring_nf Cst_tac lemma2 req rl f :=
+  let on_rhs H :=
+   match type of H with
+   | req _ ?rhs => clear H; f rhs
+   end in
+  Ring_norm_gen on_rhs Cst_tac lemma2 req rl.
+
+
+Tactic Notation (at level 0) 
+  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+  let G := getGoal in ring_lookup Ring_simplify [lH] rl [G].
+
+Tactic Notation (at level 0) 
+  "ring_simplify" constr_list(rl) := 
+  let G := getGoal in ring_lookup Ring_simplify [] rl [G].
+
+
+Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):=   
+ let G := getGoal in
+ let t := type of H in   
+ let g := fresh "goal" in
+ set (g:= G);
+ generalize H;clear H;
+ ring_lookup Ring_simplify [] rl [t];
+ intro H;
+ unfold g;clear g.
+
+Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):=   
+ let G := getGoal in
+ let t := type of H in   
+ let g := fresh "goal" in
+ set (g:= G);
+ generalize H;clear H;
+ ring_lookup Ring_simplify [lH] rl [t];
+ intro H;
+ unfold g;clear g.
+
+
+(*
+
+Ltac Ring_simplify_in hyp:= Ring_simplify_gen ltac:(fun H => rewrite H in hyp).
+
+
+Tactic Notation (at level 0) 
+  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := 
+  match goal with [|- ?G] => ring_lookup Ring_simplify [lH] rl [G] end.
+
+Tactic Notation (at level 0) 
+  "ring_simplify" constr_list(rl) := 
+  match goal with [|- ?G] => ring_lookup Ring_simplify [] rl [G] end.
+
+Tactic Notation (at level 0) 
+  "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h):= 
+  let t := type of h in
+  ring_lookup 
+   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
+     pre(); 
+     Ring_norm_gen ltac:(fun EQ => rewrite EQ in h) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
+     post()) 
+  [lH] rl [t]. 
+(*  ring_lookup ltac:(Ring_simplify_in h) [lH] rl [t]. NE MARCHE PAS ??? *)
+
+Ltac Ring_simpl_in hyp := Ring_norm_gen ltac:(fun H => rewrite H in hyp).
+
+Tactic Notation (at level 0) 
+  "ring_simplify" constr_list(rl) "in" constr(h):= 
+  let t := type of h in
+  ring_lookup   
+   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
+     pre(); 
+     Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
+     post())
+ [] rl [t].
+
+Ltac rw_in H Heq := rewrite Heq in H.
+
+Ltac simpl_in H := 
+  let t := type of H in
+   ring_lookup 
+   (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl =>
+     pre(); 
+     Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; 
+     post()) 
+   [] [t].
+
+
+*)
diff --git a/contrib/setoid_ring/Ring_theory.v b/contrib/setoid_ring/Ring_theory.v
new file mode 100644
index 00000000..5498911d
--- /dev/null
+++ b/contrib/setoid_ring/Ring_theory.v
@@ -0,0 +1,601 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinNat.
+
+Set Implicit Arguments.
+
+Module RingSyntax.
+Reserved Notation "x ?=! y" (at level 70, no associativity).
+Reserved Notation "x +! y " (at level 50, left associativity).
+Reserved Notation "x -! y" (at level 50, left associativity).
+Reserved Notation "x *! y" (at level 40, left associativity).
+Reserved Notation "-! x" (at level 35, right associativity).
+
+Reserved Notation "[ x ]" (at level 1, no associativity).
+
+Reserved Notation "x ?== y" (at level 70, no associativity).
+Reserved Notation "x -- y" (at level 50, left associativity).
+Reserved Notation "x ** y" (at level 40, left associativity).
+Reserved Notation "-- x" (at level 35, right associativity).
+
+Reserved Notation "x == y" (at level 70, no associativity).
+End RingSyntax.
+Import RingSyntax.
+
+Section Power.
+ Variable R:Type.
+ Variable rI : R.
+ Variable rmul : R -> R -> R.
+ Variable req : R -> R -> Prop.
+ Variable Rsth : Setoid_Theory R req.
+ Notation "x * y " := (rmul x y).
+ Notation "x == y" := (req x y).
+
+ Hypothesis mul_ext : 
+   forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2.
+ Hypothesis mul_comm : forall x y, x * y == y * x.
+ Hypothesis mul_assoc  : forall x y z, x * (y * z) == (x * y) * z.
+ Add Setoid R req Rsth as R_set_Power.
+ Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed.
+
+
+ Fixpoint pow_pos (x:R) (i:positive) {struct i}: R :=
+  match i with
+  | xH => x
+  | xO i => let p := pow_pos x i in rmul p p
+  | xI i => let p := pow_pos x i in rmul x (rmul p p)
+  end.
+
+ Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j.
+ Proof.
+  induction j;simpl.
+  rewrite IHj.
+  rewrite (mul_comm x (pow_pos x j *pow_pos x j)).
+  set (w:= x*pow_pos x j);unfold w at 2.
+  rewrite (mul_comm x (pow_pos x j));unfold w.
+  repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+  repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+  apply (Seq_refl _ _ Rsth).
+ Qed.
+
+ Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j.
+ Proof.
+  intro x;induction i;intros.
+  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
+  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+  repeat rewrite IHi.
+  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc.
+  simpl;repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+  repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc;
+   simpl. apply (Seq_refl _ _ Rsth).
+ Qed.
+
+ Definition pow_N (x:R) (p:N) := 
+  match p with
+  | N0 => rI
+  | Npos p => pow_pos x p
+  end. 
+
+ Definition id_phi_N (x:N) : N := x.
+
+ Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n.
+ Proof.
+  intros; apply (Seq_refl _ _ Rsth).
+ Qed.
+
+End Power.
+
+Section DEFINITIONS.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop.
+  Notation "0" := rO.  Notation "1" := rI.
+  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
+  Notation "x == y" := (req x y).
+
+ (** Semi Ring *)
+ Record semi_ring_theory : Prop := mk_srt {
+    SRadd_0_l   : forall n, 0 + n == n;
+    SRadd_comm   : forall n m, n + m == m + n ;
+    SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p;
+    SRmul_1_l   : forall n, 1*n == n;
+    SRmul_0_l   : forall n, 0*n == 0; 
+    SRmul_comm   : forall n m, n*m == m*n;
+    SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p;
+    SRdistr_l   : forall n m p, (n + m)*p == n*p + m*p
+  }.
+  
+ (** Almost Ring *)
+(*Almost ring are no ring : Ropp_def is missing **)
+ Record almost_ring_theory : Prop := mk_art {
+    ARadd_0_l   : forall x, 0 + x == x;
+    ARadd_comm   : forall x y, x + y == y + x;
+    ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z;
+    ARmul_1_l   : forall x, 1 * x == x;
+    ARmul_0_l   : forall x, 0 * x == 0;
+    ARmul_comm   : forall x y, x * y == y * x;
+    ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z;
+    ARdistr_l   : forall x y z, (x + y) * z == (x * z) + (y * z);
+    ARopp_mul_l : forall x y, -(x * y) == -x * y;
+    ARopp_add   : forall x y, -(x + y) == -x + -y;
+    ARsub_def   : forall x y, x - y == x + -y
+  }. 
+
+ (** Ring *)
+ Record ring_theory : Prop := mk_rt {
+    Radd_0_l    : forall x, 0 + x == x;
+    Radd_comm    : forall x y, x + y == y + x;
+    Radd_assoc  : forall x y z, x + (y + z) == (x + y) + z;
+    Rmul_1_l    : forall x, 1 * x == x;
+    Rmul_comm    : forall x y, x * y == y * x;
+    Rmul_assoc  : forall x y z, x * (y * z) == (x * y) * z;
+    Rdistr_l    : forall x y z, (x + y) * z == (x * z) + (y * z);
+    Rsub_def    : forall x y, x - y == x + -y;
+    Ropp_def    : forall x, x + (- x) == 0
+ }.
+
+ (** Equality is extensional *)
+  
+ Record sring_eq_ext : Prop := mk_seqe {
+    (* SRing operators are compatible with equality *)
+    SRadd_ext :
+      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
+    SRmul_ext :
+      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2
+  }.
+
+ Record ring_eq_ext : Prop := mk_reqe {
+    (* Ring operators are compatible with equality *)
+    Radd_ext :
+      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
+    Rmul_ext :
+      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
+    Ropp_ext : forall x1 x2, x1 == x2 ->  -x1 == -x2
+  }.
+
+ (** Interpretation morphisms definition*) 
+ Section MORPHISM.
+ Variable C:Type.
+ Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool.
+ (* [phi] est un morphisme de [C] dans [R] *) 
+ Variable phi : C -> R.
+ Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y).
+ Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x).
+ Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+
+(*for semi rings*)
+ Record semi_morph : Prop := mkRmorph {
+    Smorph0 : [cO] == 0;
+    Smorph1 : [cI] == 1;
+    Smorph_add : forall x y, [x +! y] == [x]+[y];
+    Smorph_mul : forall x y, [x *! y] == [x]*[y];
+    Smorph_eq  : forall x y, x?=!y = true -> [x] == [y] 
+  }.
+
+(* for rings*)
+ Record ring_morph : Prop := mkmorph {
+    morph0    : [cO] == 0;
+    morph1    : [cI] == 1;
+    morph_add : forall x y, [x +! y] == [x]+[y];
+    morph_sub : forall x y, [x -! y] == [x]-[y];
+    morph_mul : forall x y, [x *! y] == [x]*[y];
+    morph_opp : forall x, [-!x] == -[x];
+    morph_eq  : forall x y, x?=!y = true -> [x] == [y] 
+  }.
+
+ Section SIGN.
+  Variable get_sign : C -> option C.
+  Record sign_theory : Prop := mksign_th {
+    sign_spec : forall c c', get_sign c = Some c' -> [c] == - [c']
+  }.
+ End SIGN.
+
+ Definition get_sign_None (c:C) := @None C.
+
+ Lemma get_sign_None_th : sign_theory get_sign_None.
+ Proof. constructor;intros;discriminate. Qed.
+
+ End MORPHISM. 
+
+ (** Identity is a morphism *)
+ Variable Rsth : Setoid_Theory R req.
+   Add Setoid R req Rsth as R_setoid1.
+ Variable reqb : R->R->bool.
+ Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y.
+ Definition IDphi (x:R) := x.
+ Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi.
+ Proof.
+  apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi);intros;unfold IDphi;
+  try apply (Seq_refl _ _ Rsth);auto.
+ Qed.
+
+ (** Specification of the power function *)
+ Section POWER.
+  Variable Cpow : Set.
+  Variable Cp_phi : N -> Cpow.
+  Variable rpow : R -> Cpow -> R. 
+  
+  Record power_theory : Prop := mkpow_th {
+    rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n)
+  }.
+
+ End POWER.
+
+ Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
+
+End DEFINITIONS.
+
+
+
+Section ALMOST_RING.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop.
+  Notation "0" := rO.  Notation "1" := rI.
+  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
+  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
+  Notation "x == y" := (req x y).
+
+ (** Leibniz equality leads to a setoid theory and is extensional*)
+ Lemma Eqsth : Setoid_Theory R (@eq R).
+ Proof.  constructor;intros;subst;trivial. Qed.
+
+ Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R).
+ Proof. constructor;intros;subst;trivial. Qed.
+
+ Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R).
+ Proof. constructor;intros;subst;trivial. Qed.
+
+ Variable Rsth : Setoid_Theory R req.
+   Add Setoid R req Rsth as R_setoid2.
+   Ltac sreflexivity := apply (Seq_refl _ _ Rsth).
+ 
+ Section SEMI_RING.
+ Variable SReqe : sring_eq_ext radd rmul req.
+   Add Morphism radd : radd_ext1.  exact (SRadd_ext SReqe). Qed.
+   Add Morphism rmul : rmul_ext1.  exact (SRmul_ext SReqe). Qed.
+ Variable SRth : semi_ring_theory 0 1 radd rmul req.
+
+ (** Every semi ring can be seen as an almost ring, by taking :
+        -x = x and x - y = x + y *)
+ Definition SRopp (x:R) := x. Notation "- x" := (SRopp x).
+ 
+ Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y).
+
+ Lemma SRopp_ext : forall x y, x == y -> -x == -y.
+ Proof. intros x y H;exact H. Qed.
+
+ Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req.
+ Proof.
+  constructor.  exact (SRadd_ext SReqe). exact (SRmul_ext SReqe).
+  exact SRopp_ext.
+ Qed.
+
+ Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y.
+ Proof. intros;sreflexivity. Qed.
+
+ Lemma SRopp_add : forall x y, -(x + y) == -x + -y.
+ Proof. intros;sreflexivity.  Qed.
+
+  
+ Lemma SRsub_def   : forall x y, x - y == x + -y.
+ Proof. intros;sreflexivity. Qed.
+
+ Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req.
+ Proof (mk_art 0 1 radd rmul SRsub SRopp req
+    (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth)
+    (SRmul_1_l SRth) (SRmul_0_l SRth)
+    (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth)
+    SRopp_mul_l SRopp_add SRsub_def).
+ 
+ (** Identity morphism for semi-ring equipped with their almost-ring structure*)
+ Variable reqb : R->R->bool.
+
+ Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y.
+
+ Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req
+                            0 1 radd rmul SRsub SRopp reqb (@IDphi R).
+ Proof.
+  apply mkmorph;intros;try sreflexivity.  unfold IDphi;auto.
+ Qed.
+
+ (* a semi_morph can be extended to a ring_morph for the almost_ring derived
+    from a semi_ring, provided the ring is a setoid (we only need
+    reflexivity) *)
+ Variable C : Type.
+ Variable (cO cI : C) (cadd cmul: C->C->C).
+ Variable (ceqb : C -> C -> bool).
+ Variable phi : C -> R.
+ Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi.
+
+ Lemma SRmorph_Rmorph :
+   ring_morph rO rI radd rmul SRsub SRopp req
+              cO cI cadd cmul cadd (fun x => x) ceqb phi.
+ Proof.
+ case Smorph; intros; constructor; auto.
+ unfold SRopp in |- *; intros.
+  setoid_reflexivity.
+ Qed.
+
+ End  SEMI_RING.
+ 
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+   Add Morphism radd : radd_ext2.  exact (Radd_ext Reqe). Qed.
+   Add Morphism rmul : rmul_ext2.  exact (Rmul_ext Reqe). Qed.
+   Add Morphism ropp : ropp_ext2.  exact (Ropp_ext Reqe). Qed.
+ 
+ Section RING.
+ Variable Rth : ring_theory 0 1 radd rmul rsub ropp req.
+
+ (** Rings are almost rings*)
+ Lemma Rmul_0_l : forall x, 0 * x == 0.
+ Proof.
+  intro x; setoid_replace (0*x) with ((0+1)*x + -x).
+  rewrite (Radd_0_l Rth); rewrite (Rmul_1_l Rth).
+  rewrite (Ropp_def Rth);sreflexivity.
+
+  rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth).
+  rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
+  rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity.
+ Qed.
+
+ Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y.
+ Proof.
+  intros x y;rewrite <-(Radd_0_l Rth (- x * y)).
+  rewrite (Radd_comm Rth).
+  rewrite <-(Ropp_def Rth (x*y)).
+  rewrite (Radd_assoc Rth).
+  rewrite <- (Rdistr_l Rth).
+  rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth).
+  rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity.
+ Qed.
+ 
+ Lemma Ropp_add : forall x y, -(x + y) == -x + -y.
+ Proof.
+  intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))).
+  rewrite <- ((Ropp_def Rth) x).
+  rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))).
+  rewrite <- ((Ropp_def Rth) y).
+  rewrite ((Radd_comm Rth) x).
+  rewrite ((Radd_comm Rth) y).
+  rewrite <- ((Radd_assoc Rth) (-y)).
+  rewrite <- ((Radd_assoc Rth) (- x)).
+  rewrite ((Radd_assoc Rth)  y).
+  rewrite ((Radd_comm Rth) y).
+  rewrite <- ((Radd_assoc Rth)  (- x)).
+  rewrite ((Radd_assoc Rth) y).
+  rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth).
+  rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth).
+  apply (Radd_comm Rth).
+ Qed.
+ 
+ Lemma Ropp_opp : forall x, - -x == x.
+ Proof.
+  intros x; rewrite <- (Radd_0_l Rth (- -x)).
+  rewrite <- (Ropp_def Rth x).
+  rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
+  rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth).
+ Qed.
+
+ Lemma  Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
+ Proof
+  (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth)
+    (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth)
+    Ropp_mul_l Ropp_add (Rsub_def Rth)).
+
+ (** Every semi morphism between two rings is a morphism*) 
+ Variable C : Type.
+ Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C).
+ Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool).
+ Variable phi : C -> R.
+  Notation "x +! y" := (cadd x y).  Notation "x *! y " := (cmul x y).
+  Notation "x -! y " := (csub x y).  Notation "-! x" := (copp x).
+  Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+ Variable Csth : Setoid_Theory C ceq.
+ Variable Ceqe : ring_eq_ext cadd cmul copp ceq.
+   Add Setoid C ceq Csth as C_setoid.
+   Add Morphism cadd : cadd_ext.  exact (Radd_ext Ceqe). Qed.
+   Add Morphism cmul : cmul_ext.  exact (Rmul_ext Ceqe). Qed.
+   Add Morphism copp : copp_ext.  exact (Ropp_ext Ceqe). Qed.
+ Variable Cth : ring_theory cO cI cadd cmul csub copp ceq.
+ Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi.
+ Variable phi_ext : forall x y, ceq x y -> [x] == [y].
+   Add Morphism phi : phi_ext1.  exact phi_ext. Qed.
+ Lemma Smorph_opp : forall x, [-!x] == -[x].
+ Proof.
+  intros x;rewrite <-  (Rth.(Radd_0_l) [-!x]).
+  rewrite <- ((Ropp_def Rth) [x]).
+  rewrite ((Radd_comm Rth) [x]).
+  rewrite <- (Radd_assoc Rth).
+  rewrite <- (Smorph_add Smorph).
+  rewrite (Ropp_def Cth).
+  rewrite (Smorph0 Smorph).
+  rewrite (Radd_comm Rth (-[x])).
+  apply (Radd_0_l Rth);sreflexivity.
+ Qed. 
+
+ Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y].
+ Proof.
+  intros x y; rewrite (Rsub_def Cth);rewrite (Rsub_def Rth).
+  rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity.
+ Qed.
+
+ Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req 
+                                             cO cI cadd cmul csub copp ceqb phi.
+ Proof
+  (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi
+        (Smorph0 Smorph) (Smorph1 Smorph) 
+         (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp
+         (Smorph_eq Smorph)).
+
+ End RING.
+
+ (** Usefull lemmas on almost ring *)
+ Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
+
+ Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req.
+Proof.
+elim ARth; intros.
+constructor; trivial.
+Qed.
+
+ Lemma ARsub_ext :
+      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2.
+ Proof.
+  intros.
+  setoid_replace (x1 - y1) with (x1 + -y1). 
+  setoid_replace (x2 - y2) with (x2 + -y2).
+  rewrite H;rewrite H0;sreflexivity.
+  apply (ARsub_def ARth).
+  apply (ARsub_def ARth).
+ Qed.
+   Add Morphism rsub : rsub_ext.  exact ARsub_ext. Qed.
+
+ Ltac mrewrite :=
+   repeat first
+     [ rewrite (ARadd_0_l ARth)
+     | rewrite <- ((ARadd_comm ARth) 0)
+     | rewrite (ARmul_1_l ARth)
+     | rewrite <- ((ARmul_comm ARth) 1)
+     | rewrite (ARmul_0_l ARth)
+     | rewrite <- ((ARmul_comm ARth) 0)
+     | rewrite (ARdistr_l ARth)
+     | sreflexivity
+     | match goal with
+       | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y))
+       end].
+ 
+ Lemma ARadd_0_r : forall x, (x + 0) == x.
+ Proof. intros; mrewrite. Qed.
+ 
+ Lemma ARmul_1_r   : forall x, x * 1 == x.
+ Proof. intros;mrewrite. Qed.
+
+ Lemma ARmul_0_r : forall x, x * 0 == 0.
+ Proof. intros;mrewrite. Qed.
+
+ Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y.
+ Proof. 
+  intros;mrewrite. 
+  repeat rewrite (ARth.(ARmul_comm) z);sreflexivity.
+ Qed.
+
+ Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x.
+ Proof.
+  intros;rewrite <-(ARth.(ARadd_assoc) x).
+  rewrite (ARth.(ARadd_comm) x);sreflexivity.
+ Qed.
+
+ Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x.
+ Proof.
+  intros; repeat rewrite <- (ARadd_assoc ARth);
+   rewrite ((ARadd_comm ARth) x); sreflexivity.
+ Qed.
+
+ Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x.
+ Proof.
+  intros;rewrite <-((ARmul_assoc ARth) x).
+  rewrite ((ARmul_comm ARth) x);sreflexivity.
+ Qed.
+ 
+ Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x.
+ Proof.
+  intros; repeat rewrite <- (ARmul_assoc ARth);
+   rewrite ((ARmul_comm ARth) x); sreflexivity.
+ Qed.
+
+ Lemma ARopp_mul_r : forall x y,  - (x * y) == x * -y.
+ Proof.
+  intros;rewrite ((ARmul_comm ARth) x y);
+   rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth).
+ Qed.
+
+ Lemma ARopp_zero : -0 == 0.
+ Proof.
+  rewrite <- (ARmul_0_r 0); rewrite (ARopp_mul_l ARth).
+  repeat rewrite ARmul_0_r; sreflexivity.
+ Qed.
+
+
+
+End ALMOST_RING.
+
+
+Section AddRing.
+
+(* Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop. *)
+
+Inductive ring_kind : Type :=
+| Abstract
+| Computational
+    (R:Type)
+    (req : R -> R -> Prop)
+    (reqb : R -> R -> bool)
+    (_ : forall x y, (reqb x y) = true -> req x y)
+| Morphism
+    (R : Type)
+    (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R)
+    (req : R -> R -> Prop)
+    (C : Type)
+    (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C)
+    (ceqb : C->C->bool)
+    phi
+    (_ : ring_morph rO rI radd rmul rsub ropp req
+                    cO cI cadd cmul csub copp ceqb phi).
+
+
+End AddRing.
+
+
+(** Some simplification tactics*)
+Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth).
+
+Ltac gen_srewrite O I add mul sub opp eq Rsth Reqe ARth :=
+  repeat first
+     [ gen_reflexivity Rsth
+     | progress rewrite (ARopp_zero Rsth Reqe ARth)
+     | rewrite (ARadd_0_l ARth)
+     | rewrite (ARadd_0_r Rsth ARth)
+     | rewrite (ARmul_1_l ARth)
+     | rewrite (ARmul_1_r Rsth ARth)
+     | rewrite (ARmul_0_l ARth)
+     | rewrite (ARmul_0_r Rsth ARth)
+     | rewrite (ARdistr_l ARth)
+     | rewrite (ARdistr_r Rsth Reqe ARth)
+     | rewrite (ARadd_assoc ARth)
+     | rewrite (ARmul_assoc ARth)
+     | progress rewrite (ARopp_add ARth)
+     | progress rewrite (ARsub_def ARth)
+     | progress rewrite <- (ARopp_mul_l ARth)
+     | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ].
+
+Ltac gen_add_push add Rsth Reqe ARth x :=
+  repeat (match goal with
+  | |- context [add (add ?y x) ?z] => 
+     progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z)
+  | |- context [add (add x ?y) ?z] => 
+     progress rewrite (ARadd_assoc1 Rsth ARth x y z)
+  end).
+
+Ltac gen_mul_push mul Rsth Reqe ARth x :=
+  repeat (match goal with
+  | |- context [mul (mul ?y x) ?z] => 
+     progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z)
+  | |- context [mul (mul x ?y) ?z] => 
+     progress rewrite (ARmul_assoc1 Rsth ARth x y z)
+  end).
+
diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v
new file mode 100644
index 00000000..8de7021e
--- /dev/null
+++ b/contrib/setoid_ring/ZArithRing.v
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Require Export Ring.
+Require Import ZArith_base.
+Require Import Zpow_def.
+
+Import InitialRing.
+
+Set Implicit Arguments.
+
+Ltac Zcst t :=
+  match isZcst t with
+    true => t
+  | _ => NotConstant
+  end.
+
+Ltac isZpow_coef t :=
+  match t with 
+  | Zpos ?p => isPcst p
+  | Z0 => true
+  | _ => false
+  end.
+
+Definition N_of_Z x :=
+ match x with
+ | Zpos p => Npos p
+ | _ => N0
+ end.
+
+Ltac Zpow_tac t :=
+ match isZpow_coef t with
+ | true => constr:(N_of_Z t)
+ | _ => constr:(NotConstant)
+ end.
+
+Ltac Zpower_neg :=
+  repeat match goal with
+  | [|- ?G] => 
+    match G with 
+    | context c [Zpower _ (Zneg _)] =>
+      let t := context c [Z0] in
+      change t
+    end
+  end.   
+
+
+Add Ring Zr : Zth
+  (decidable Zeqb_ok, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
+   power_tac Zpower_theory [Zpow_tac]).
+
diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4
new file mode 100644
index 00000000..8b2ce26b
--- /dev/null
+++ b/contrib/setoid_ring/newring.ml4
@@ -0,0 +1,1072 @@
+(************************************************************************)
+(*  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: newring.ml4 9603 2007-02-07 00:41:16Z barras $ i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Closure
+open Environ
+open Libnames
+open Tactics
+open Rawterm
+open Tacticals
+open Tacexpr
+open Pcoq
+open Tactic
+open Constr
+open Setoid_replace
+open Proof_type
+open Coqlib
+open Tacmach
+open Mod_subst
+open Tacinterp
+open Libobject
+open Printer
+open Declare
+open Decl_kinds
+open Entries
+
+(****************************************************************************)
+(* controlled reduction *)
+
+let mark_arg i c = mkEvar(i,[|c|])
+let unmark_arg f c =
+  match destEvar c with
+    | (i,[|c|]) -> f i c
+    | _ -> assert false
+
+type protect_flag = Eval|Prot|Rec
+
+let tag_arg tag_rec map subs i c =
+  match map i with
+      Eval -> mk_clos subs c
+    | Prot -> mk_atom c
+    | Rec -> if i = -1 then mk_clos subs c else tag_rec c
+
+let rec mk_clos_but f_map subs t =
+  match f_map t with
+    | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t
+    | None ->
+        (match kind_of_term t with
+            App(f,args) -> mk_clos_app_but f_map subs f args 0
+          | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t
+          | _ -> mk_atom t)
+
+and mk_clos_app_but f_map subs f args n =
+  if n >= Array.length args then mk_atom(mkApp(f, args))
+  else
+    let fargs, args' = array_chop n args in
+    let f' = mkApp(f,fargs) in
+    match f_map f' with
+        Some map ->
+          mk_clos_deep
+            (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s'))
+            subs
+            (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
+      | None -> mk_clos_app_but f_map subs f args (n+1)
+
+
+let interp_map l c =
+  try
+    let (im,am) = List.assoc c l in
+    Some(fun i ->
+      if List.mem i im then Eval
+      else if List.mem i am then Prot
+      else if i = -1 then Eval
+      else Rec)
+  with Not_found -> None
+
+let interp_map l t =
+  try Some(List.assoc t l) with Not_found -> None
+
+let protect_maps = ref ([]:(string*(constr->'a)) list)
+let add_map s m = protect_maps := (s,m) :: !protect_maps
+let lookup_map map =
+  try List.assoc map !protect_maps
+  with Not_found ->
+    errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
+
+let protect_red map env sigma c =
+  kl (create_clos_infos betadeltaiota env)
+    (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);;
+
+let protect_tac map =
+  Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
+
+let protect_tac_in map id =
+  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(([],id),InHyp));;
+
+
+TACTIC EXTEND protect_fv
+  [ "protect_fv" string(map) "in" ident(id) ] -> 
+    [ protect_tac_in map id ]
+| [ "protect_fv" string(map) ] -> 
+    [ protect_tac map ]
+END;;
+
+(****************************************************************************)
+
+let closed_term t l =
+  let l = List.map constr_of_global l in
+  let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
+  if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
+;;
+
+TACTIC EXTEND closed_term
+  [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
+    [ closed_term t l ]
+END
+;;
+
+TACTIC EXTEND echo 
+| [ "echo" constr(t) ] -> 
+  [ Pp.msg (Termops.print_constr t);  Tacinterp.eval_tactic (TacId []) ]
+END;;
+
+(*
+let closed_term_ast l =
+  TacFun([Some(id_of_string"t")],
+  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
+  [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t"));
+   Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l])))
+*)
+let closed_term_ast l =
+  let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in
+  TacFun([Some(id_of_string"t")],
+  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
+  [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None);
+   Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l])))
+(*
+let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term"
+*)
+
+(****************************************************************************)
+
+let ic c =
+  let env = Global.env() and sigma = Evd.empty in
+  Constrintern.interp_constr sigma env c
+
+let ty c = Typing.type_of (Global.env()) Evd.empty c
+
+let decl_constant na c =
+  mkConst(declare_constant (id_of_string na) (DefinitionEntry 
+    { const_entry_body = c;
+      const_entry_type = None;
+      const_entry_opaque = true;
+      const_entry_boxed = true}, 
+    IsProof Lemma))
+
+let ltac_call tac args =
+  TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
+
+let ltac_lcall tac args =
+  TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
+
+let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
+
+let dummy_goal env =
+  {Evd.it=
+    {Evd.evar_concl=mkProp;
+     Evd.evar_hyps=named_context_val env;
+     Evd.evar_body=Evd.Evar_empty;
+     Evd.evar_extra=None};
+   Evd.sigma=Evd.empty}
+
+let exec_tactic env n f args =
+  let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in
+  let res = ref [||] in
+  let get_res ist =
+    let l = List.map (fun id ->  List.assoc id ist.lfun) lid in
+    res := Array.of_list l;
+    TacId[] in
+  let getter =
+    Tacexp(TacFun(List.map(fun id -> Some id) lid,
+                  glob_tactic(tacticIn get_res))) in
+  let _ =
+    Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in
+  !res
+
+let constr_of = function
+  | VConstr c -> c
+  | _ -> failwith "Ring.exec_tactic: anomaly"
+
+let stdlib_modules =
+  [["Coq";"Setoids";"Setoid"];
+   ["Coq";"Lists";"List"];
+   ["Coq";"Init";"Datatypes"]
+  ]
+
+let coq_constant c =
+  lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
+
+let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
+let coq_cons = coq_constant "cons"
+let coq_nil = coq_constant "nil"
+let coq_None = coq_constant "None"
+let coq_Some = coq_constant "Some"
+
+let lapp f args = mkApp(Lazy.force f,args)
+
+let dest_rel0 t =  
+  match kind_of_term t with
+  | App(f,args) when Array.length args >= 2 ->
+      let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in
+      if closed0 rel then
+        (rel,args.(Array.length args - 2),args.(Array.length args - 1))
+      else error "ring: cannot find relation (not closed)"
+  | _ -> error "ring: cannot find relation"
+
+let rec dest_rel t =
+  match kind_of_term t with
+  | Prod(_,_,c) -> dest_rel c
+  | _ -> dest_rel0 t
+
+(****************************************************************************)
+(* Library linking *)
+
+let contrib_name = "setoid_ring"
+
+let cdir = ["Coq";contrib_name]
+let contrib_modules =
+  List.map (fun d -> cdir@d)
+    [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"];
+     ["Field_tac"]; ["Field_theory"]
+    ]
+
+let my_constant c =
+  lazy (Coqlib.gen_constant_in_modules "Ring" contrib_modules c)
+
+let new_ring_path =
+  make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"])
+let ltac s =
+  lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s))
+let znew_ring_path =
+  make_dirpath (List.map id_of_string ["InitialRing";contrib_name;"Coq"])
+let zltac s =
+  lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s))
+
+let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);;
+let pol_cst s = mk_cst [contrib_name;"Ring_polynom"] s ;;
+
+(* Ring theory *)
+
+(* almost_ring defs *)
+let coq_almost_ring_theory = my_constant "almost_ring_theory"
+
+(* setoid and morphism utilities *)
+let coq_eq_setoid = my_constant "Eqsth"
+let coq_eq_morph = my_constant "Eq_ext"
+let coq_eq_smorph = my_constant "Eq_s_ext"
+
+(* ring -> almost_ring utilities *)
+let coq_ring_theory = my_constant "ring_theory"
+let coq_mk_reqe = my_constant "mk_reqe"
+
+(* semi_ring -> almost_ring utilities *)
+let coq_semi_ring_theory = my_constant "semi_ring_theory"
+let coq_mk_seqe = my_constant "mk_seqe"
+
+let ltac_inv_morphZ = zltac"inv_gen_phiZ"
+let ltac_inv_morphN = zltac"inv_gen_phiN"
+let coq_abstract = my_constant"Abstract"
+let coq_comp = my_constant"Computational"
+let coq_morph = my_constant"Morphism"
+
+(* power function *)
+let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
+let coq_pow_N_pow_N = my_constant "pow_N_pow_N"
+
+(* hypothesis *)
+let coq_mkhypo = my_constant "mkhypo"
+let coq_hypo = my_constant "hypo"
+
+(* Equality: do not evaluate but make recursive call on both sides *)
+let map_with_eq arg_map c =
+  let (req,_,_) = dest_rel c in
+  interp_map
+    ((req,(function -1->Prot|_->Rec))::
+    List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
+
+let _ = add_map "ring"
+  (map_with_eq
+    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+    coq_nil, (function -1->Eval|_ -> Prot);
+    (* Pphi_dev: evaluate polynomial and coef operations, protect
+       ring operations and make recursive call on the var map *)
+    pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
+    pol_cst "Pphi_pow", 
+          (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
+    (* PEeval: evaluate morphism and polynomial, protect ring 
+       operations and make recursive call on the var map *)
+    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
+
+(****************************************************************************)
+(* Ring database *)
+
+type ring_info =
+    { ring_carrier : types;
+      ring_req : constr;
+      ring_setoid : constr;
+      ring_ext : constr;
+      ring_morph : constr;
+      ring_th : constr;
+      ring_cst_tac : glob_tactic_expr;
+      ring_pow_tac : glob_tactic_expr;
+      ring_lemma1 : constr;
+      ring_lemma2 : constr;
+      ring_pre_tac : glob_tactic_expr;
+      ring_post_tac : glob_tactic_expr }
+
+module Cmap = Map.Make(struct type t = constr let compare = compare end)
+
+let from_carrier = ref Cmap.empty
+let from_relation = ref Cmap.empty
+let from_name = ref Spmap.empty
+
+let ring_for_carrier r = Cmap.find r !from_carrier
+let ring_for_relation rel = Cmap.find rel !from_relation
+let ring_lookup_by_name ref =
+  Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) !from_name
+
+
+let find_ring_structure env sigma l oname =
+  match oname, l with
+      Some rf, _ ->
+        (try ring_lookup_by_name rf
+        with Not_found ->
+          errorlabstrm "ring"
+            (str "found no ring named "++pr_reference rf))
+    | None, t::cl' ->
+        let ty = Retyping.get_type_of env sigma t in
+        let check c =
+          let ty' = Retyping.get_type_of env sigma c in
+          if not (Reductionops.is_conv env sigma ty ty') then
+            errorlabstrm "ring"
+              (str"arguments of ring_simplify do not have all the same type")
+        in
+        List.iter check cl';
+        (try ring_for_carrier ty
+        with Not_found ->
+          errorlabstrm "ring"
+            (str"cannot find a declared ring structure over"++
+             spc()++str"\""++pr_constr ty++str"\""))
+    | None, [] -> assert false
+(*
+        let (req,_,_) = dest_rel cl in
+        (try ring_for_relation req
+        with Not_found ->
+          errorlabstrm "ring"
+            (str"cannot find a declared ring structure for equality"++
+             spc()++str"\""++pr_constr req++str"\"")) *)
+
+let _ = 
+  Summary.declare_summary "tactic-new-ring-table"
+    { Summary.freeze_function =
+        (fun () -> !from_carrier,!from_relation,!from_name);
+      Summary.unfreeze_function =
+        (fun (ct,rt,nt) ->
+          from_carrier := ct; from_relation := rt; from_name := nt);
+      Summary.init_function =
+        (fun () ->
+          from_carrier := Cmap.empty; from_relation := Cmap.empty;
+          from_name := Spmap.empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let add_entry (sp,_kn) e =
+(*  let _ = ty e.ring_lemma1 in
+  let _ = ty e.ring_lemma2 in
+*)
+  from_carrier := Cmap.add e.ring_carrier e !from_carrier;
+  from_relation := Cmap.add e.ring_req e !from_relation;
+  from_name := Spmap.add sp e !from_name 
+
+
+let subst_th (_,subst,th) = 
+  let c' = subst_mps subst th.ring_carrier in                   
+  let eq' = subst_mps subst th.ring_req in
+  let set' = subst_mps subst th.ring_setoid in
+  let ext' = subst_mps subst th.ring_ext in
+  let morph' = subst_mps subst th.ring_morph in
+  let th' = subst_mps subst th.ring_th in
+  let thm1' = subst_mps subst th.ring_lemma1 in
+  let thm2' = subst_mps subst th.ring_lemma2 in
+  let tac'= subst_tactic subst th.ring_cst_tac in
+  let pow_tac'= subst_tactic subst th.ring_pow_tac in
+  let pretac'= subst_tactic subst th.ring_pre_tac in
+  let posttac'= subst_tactic subst th.ring_post_tac in
+  if c' == th.ring_carrier &&
+     eq' == th.ring_req &&
+     set' = th.ring_setoid &&
+     ext' == th.ring_ext &&
+     morph' == th.ring_morph &&
+     th' == th.ring_th &&
+     thm1' == th.ring_lemma1 &&
+     thm2' == th.ring_lemma2 &&
+     tac' == th.ring_cst_tac &&
+     pow_tac' == th.ring_pow_tac &&
+     pretac' == th.ring_pre_tac &&
+     posttac' == th.ring_post_tac then th
+  else
+    { ring_carrier = c';
+      ring_req = eq';
+      ring_setoid = set';
+      ring_ext = ext';
+      ring_morph = morph';
+      ring_th = th';
+      ring_cst_tac = tac';
+      ring_pow_tac = pow_tac';
+      ring_lemma1 = thm1';
+      ring_lemma2 = thm2';
+      ring_pre_tac = pretac';
+      ring_post_tac = posttac' }
+
+
+let (theory_to_obj, obj_to_theory) = 
+  let cache_th (name,th) = add_entry name th
+  and export_th x = Some x in
+  declare_object
+    {(default_object "tactic-new-ring-theory") with
+      open_function = (fun i o -> if i=1 then cache_th o);
+      cache_function = cache_th;
+      subst_function = subst_th;
+      classify_function = (fun (_,x) -> Substitute x);
+      export_function = export_th }
+
+
+let setoid_of_relation r =
+  lapp coq_mk_Setoid
+    [|r.rel_a; r.rel_aeq;
+      out_some r.rel_refl; out_some r.rel_sym; out_some r.rel_trans |]
+
+let op_morph r add mul opp req m1 m2 m3 =
+  lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |]
+
+let op_smorph r add mul req m1 m2 =
+  lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]
+
+let default_ring_equality (r,add,mul,opp,req) =
+  let is_setoid = function
+      {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true
+    | _ -> false in
+  match default_relation_for_carrier ~filter:is_setoid r with
+      Leibniz _ ->
+        let setoid = lapp coq_eq_setoid [|r|] in
+        let op_morph =
+          match opp with
+              Some opp -> lapp coq_eq_morph [|r;add;mul;opp|]
+            | None -> lapp coq_eq_smorph [|r;add;mul|] in
+        (setoid,op_morph)
+    | Relation rel ->
+        let setoid = setoid_of_relation rel in
+        let is_endomorphism = function
+            { args=args } -> List.for_all
+                (function (var,Relation rel) ->
+                  var=None && eq_constr req rel
+                  | _ -> false) args in
+        let add_m =
+          try default_morphism ~filter:is_endomorphism add
+          with Not_found ->
+            error "ring addition should be declared as a morphism" in
+        let mul_m =
+          try default_morphism ~filter:is_endomorphism mul
+          with Not_found ->
+            error "ring multiplication should be declared as a morphism" in
+        let op_morph =
+          match opp with
+            | Some opp ->
+            (let opp_m =
+              try default_morphism ~filter:is_endomorphism opp
+              with Not_found ->
+                error "ring opposite should be declared as a morphism" in
+             let op_morph =
+               op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in
+             msgnl
+               (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++  
+               str"and morphisms \""++pr_constr add_m.morphism_theory++
+               str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++
+               str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++
+               str"\"");
+             op_morph)
+            | None ->
+            (msgnl
+              (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++  
+               str"and morphisms \""++pr_constr add_m.morphism_theory++
+               str"\""++spc()++str"and \""++
+               pr_constr mul_m.morphism_theory++str"\"");
+            op_smorph r add mul req add_m.lem mul_m.lem) in
+        (setoid,op_morph)
+
+let build_setoid_params r add mul opp req eqth =
+  match eqth with
+      Some th -> th
+    | None -> default_ring_equality (r,add,mul,opp,req)
+
+let dest_ring env sigma th_spec =
+  let th_typ = Retyping.get_type_of env sigma th_spec in
+  match kind_of_term th_typ with
+      App(f,[|r;zero;one;add;mul;sub;opp;req|])
+        when f = Lazy.force coq_almost_ring_theory ->
+          (None,r,zero,one,add,mul,Some sub,Some opp,req)
+    | App(f,[|r;zero;one;add;mul;req|])
+        when f = Lazy.force coq_semi_ring_theory ->
+        (Some true,r,zero,one,add,mul,None,None,req)
+    | App(f,[|r;zero;one;add;mul;sub;opp;req|])
+        when f = Lazy.force coq_ring_theory ->
+        (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
+    | _ -> error "bad ring structure"
+
+
+
+type coeff_spec =
+    Computational of constr (* equality test *)
+  | Abstract (* coeffs = Z *)
+  | Morphism of constr (* general morphism *)
+
+
+let reflect_coeff rkind =
+  (* We build an ill-typed terms on purpose... *)
+  match rkind with
+      Abstract -> Lazy.force coq_abstract
+    | Computational c -> lapp coq_comp [|c|]
+    | Morphism m -> lapp coq_morph [|m|]
+
+type cst_tac_spec =
+    CstTac of raw_tactic_expr
+  | Closed of reference list
+
+let interp_cst_tac kind (zero,one,add,mul,opp) cst_tac =
+  match cst_tac with
+      Some (CstTac t) -> Tacinterp.glob_tactic t
+    | Some (Closed lc) -> closed_term_ast (List.map Nametab.global lc)
+    | None ->
+        (match opp, kind with
+            None, _ ->
+              let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in
+              TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
+          | Some opp, Some _ ->
+              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in
+              TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
+          | _ -> error"a tactic must be specified for an almost_ring")
+
+let make_hyp env c =
+  let t = (Typeops.typing env c).uj_type in
+  lapp coq_mkhypo [|t;c|]
+
+let make_hyp_list env lH =
+  let carrier = Lazy.force coq_hypo in
+  List.fold_right 
+    (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH
+    (lapp coq_nil [|carrier|])
+
+let interp_power env pow =  
+  let carrier = Lazy.force coq_hypo in
+  match pow with
+  | None -> 
+      let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in
+      (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
+  | Some (tac, spec) -> 
+      let tac = 
+        match tac with
+        | CstTac t -> Tacinterp.glob_tactic t
+        | Closed lc -> closed_term_ast (List.map Nametab.global lc) in
+      let spec = make_hyp env (ic spec) in
+      (tac, lapp coq_Some [|carrier; spec|])
+
+let interp_sign env sign =
+  let carrier = Lazy.force coq_hypo in
+  match sign with
+  | None -> lapp coq_None [|carrier|] 
+  | Some spec -> 
+      let spec = make_hyp env (ic spec) in
+      lapp coq_Some [|carrier;spec|]
+       (* Same remark on ill-typed terms ... *)
+
+let add_theory name rth eqth morphth cst_tac (pre,post) power sign =
+  let env = Global.env() in
+  let sigma = Evd.empty in
+  let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
+  let (sth,ext) = build_setoid_params r add mul opp req eqth in
+  let (pow_tac, pspec) = interp_power env power in 
+  let sspec = interp_sign env sign in
+  let rk = reflect_coeff morphth in
+  let params =
+    exec_tactic env 5 (zltac "ring_lemmas") 
+      (List.map carg[sth;ext;rth;pspec;sspec;rk]) in
+  let lemma1 = constr_of params.(3) in
+  let lemma2 = constr_of params.(4) in
+
+  let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in
+  let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in
+  let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in
+  let pretac =
+    match pre with
+        Some t -> Tacinterp.glob_tactic t
+      | _ -> TacId [] in
+  let posttac =
+    match post with
+        Some t -> Tacinterp.glob_tactic t
+      | _ -> TacId [] in
+  let _ =
+    Lib.add_leaf name
+      (theory_to_obj
+        { ring_carrier = r;
+          ring_req = req;
+          ring_setoid = sth;
+          ring_ext = constr_of params.(1);
+          ring_morph = constr_of params.(2);
+          ring_th = constr_of params.(0);
+          ring_cst_tac = cst_tac;
+	  ring_pow_tac = pow_tac;
+          ring_lemma1 = lemma1;
+          ring_lemma2 = lemma2;
+          ring_pre_tac = pretac;
+          ring_post_tac = posttac }) in
+  ()
+
+type ring_mod =
+    Ring_kind of coeff_spec
+  | Const_tac of cst_tac_spec
+  | Pre_tac of raw_tactic_expr
+  | Post_tac of raw_tactic_expr
+  | Setoid of Topconstr.constr_expr * Topconstr.constr_expr
+  | Pow_spec of cst_tac_spec * Topconstr.constr_expr
+           (* Syntaxification tactic , correctness lemma *)
+  | Sign_spec of Topconstr.constr_expr
+
+
+VERNAC ARGUMENT EXTEND ring_mod
+  | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ]
+  | [ "abstract" ] -> [ Ring_kind Abstract ]
+  | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ]
+  | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
+  | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
+  | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
+  | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
+  | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
+  | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
+  | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
+           [ Pow_spec (Closed l, pow_spec) ]   
+  | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
+           [ Pow_spec (CstTac cst_tac, pow_spec) ]
+END
+
+let set_once s r v =
+  if !r = None then r := Some v else error (s^" cannot be set twice")
+
+let process_ring_mods l =
+  let kind = ref None in
+  let set = ref None in
+  let cst_tac = ref None in
+  let pre = ref None in
+  let post = ref None in
+  let sign = ref None in
+  let power = ref None in
+  List.iter(function
+      Ring_kind k -> set_once "ring kind" kind k
+    | Const_tac t -> set_once "tactic recognizing constants" cst_tac t
+    | Pre_tac t -> set_once "preprocess tactic" pre t
+    | Post_tac t -> set_once "postprocess tactic" post t
+    | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) 
+    | Pow_spec(t,spec) -> set_once "power" power (t,spec)
+    | Sign_spec t -> set_once "sign" sign t) l;
+  let k = match !kind with Some k -> k | None -> Abstract in
+  (k, !set, !cst_tac, !pre, !post, !power, !sign)
+
+VERNAC COMMAND EXTEND AddSetoidRing
+  | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
+    [ let (k,set,cst,pre,post,power,sign) = process_ring_mods l in
+      add_theory id (ic t) set k cst (pre,post) power sign ]
+END
+
+(*****************************************************************************)
+(* The tactics consist then only in a lookup in the ring database and
+   call the appropriate ltac. *)
+
+let make_args_list rl t = 
+  match rl with
+  | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
+  | _ -> rl
+
+let make_term_list carrier rl =
+  List.fold_right
+    (fun x l -> lapp coq_cons [|carrier;x;l|]) rl
+    (lapp coq_nil [|carrier|])
+
+
+let ring_lookup (f:glob_tactic_expr) lH rl t gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let rl = make_args_list rl t in
+  let e = find_ring_structure env sigma rl None in
+  let rl = carg (make_term_list e.ring_carrier rl) in
+  let lH = carg (make_hyp_list env lH) in
+  let req = carg e.ring_req in
+  let sth = carg e.ring_setoid in
+  let ext = carg e.ring_ext in
+  let morph = carg e.ring_morph in
+  let th = carg e.ring_th in
+  let cst_tac = Tacexp e.ring_cst_tac in
+  let pow_tac = Tacexp e.ring_pow_tac in
+  let lemma1 = carg e.ring_lemma1 in
+  let lemma2 = carg e.ring_lemma2 in
+  let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in
+  let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
+  Tacinterp.eval_tactic
+    (TacLetIn
+      ([(dummy_loc,id_of_string"f"),None,Tacexp f],
+       ltac_lcall "f"
+         [req;sth;ext;morph;th;cst_tac;pow_tac;
+          lemma1;lemma2;pretac;posttac;lH;rl])) gl
+
+TACTIC EXTEND ring_lookup
+| [ "ring_lookup" tactic(f) "[" constr_list(lH) "]" constr_list(lr)
+      "[" constr(t) "]" ] ->
+          [ring_lookup (fst f) lH lr t]
+END
+
+
+ 
+(***********************************************************************)
+
+let new_field_path =
+  make_dirpath (List.map id_of_string ["Field_tac";contrib_name;"Coq"])
+
+let field_ltac s =
+  lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s))
+
+
+let _ = add_map "field"
+  (map_with_eq
+    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+    coq_nil, (function -1->Eval|_ -> Prot);
+    (* display_linear: evaluate polynomials and coef operations, protect
+       field operations and make recursive call on the var map *)
+    my_constant "display_linear",
+      (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
+    my_constant "display_pow_linear",
+     (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
+   (* Pphi_dev: evaluate polynomial and coef operations, protect
+       ring operations and make recursive call on the var map *)
+    pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
+    pol_cst "Pphi_pow", 
+          (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
+    (* PEeval: evaluate morphism and polynomial, protect ring 
+       operations and make recursive call on the var map *)
+    pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
+    (* FEeval: evaluate morphism, protect field 
+       operations and make recursive call on the var map *)
+    my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
+
+let _ = add_map "field_cond"
+  (map_with_eq
+    [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+     coq_nil, (function -1->Eval|_ -> Prot);
+    (* PCond: evaluate morphism and denum list, protect ring
+       operations and make recursive call on the var map *)
+     my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);;
+(*                       (function -1|8|10->Eval|9->Rec|_->Prot)]);;*)
+
+
+let afield_theory = my_constant "almost_field_theory"
+let field_theory = my_constant "field_theory"
+let sfield_theory = my_constant "semi_field_theory"
+let af_ar = my_constant"AF_AR"
+let f_r = my_constant"F_R"
+let sf_sr = my_constant"SF_SR"
+let dest_field env sigma th_spec =
+  let th_typ = Retyping.get_type_of env sigma th_spec in
+  match kind_of_term th_typ with
+    | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
+        when f = Lazy.force afield_theory ->
+        let rth = lapp af_ar
+          [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
+        (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
+    | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
+        when f = Lazy.force field_theory ->
+        let rth =
+          lapp f_r
+            [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
+        (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
+    | App(f,[|r;zero;one;add;mul;div;inv;req|])
+        when f = Lazy.force sfield_theory ->
+        let rth = lapp sf_sr
+          [|r;zero;one;add;mul;div;inv;req;th_spec|] in
+        (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
+    | _ -> error "bad field structure"
+
+type field_info =
+    { field_carrier : types;
+      field_req : constr;
+      field_cst_tac : glob_tactic_expr;
+      field_pow_tac : glob_tactic_expr;
+      field_ok : constr;
+      field_simpl_eq_ok : constr;
+      field_simpl_ok : constr;
+      field_simpl_eq_in_ok : constr;
+      field_cond : constr;
+      field_pre_tac : glob_tactic_expr;
+      field_post_tac : glob_tactic_expr }
+
+let field_from_carrier = ref Cmap.empty
+let field_from_relation = ref Cmap.empty
+let field_from_name = ref Spmap.empty
+
+
+let field_for_carrier r = Cmap.find r !field_from_carrier
+let field_for_relation rel = Cmap.find rel !field_from_relation
+let field_lookup_by_name ref =
+  Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref)))
+    !field_from_name
+
+
+let find_field_structure env sigma l oname =
+  check_required_library (cdir@["Field_tac"]);
+  match oname, l with
+      Some rf, _ ->
+        (try field_lookup_by_name rf
+        with Not_found ->
+          errorlabstrm "field"
+            (str "found no field named "++pr_reference rf))
+    | None, t::cl' ->
+        let ty = Retyping.get_type_of env sigma t in
+        let check c =
+          let ty' = Retyping.get_type_of env sigma c in
+          if not (Reductionops.is_conv env sigma ty ty') then
+            errorlabstrm "field"
+              (str"arguments of field_simplify do not have all the same type")
+        in
+        List.iter check cl';
+        (try field_for_carrier ty
+        with Not_found ->
+          errorlabstrm "field"
+            (str"cannot find a declared field structure over"++
+             spc()++str"\""++pr_constr ty++str"\""))
+    | None, [] -> assert false
+(*        let (req,_,_) = dest_rel cl in
+        (try field_for_relation req
+        with Not_found ->
+          errorlabstrm "field"
+            (str"cannot find a declared field structure for equality"++
+             spc()++str"\""++pr_constr req++str"\"")) *)
+
+let _ = 
+  Summary.declare_summary "tactic-new-field-table"
+    { Summary.freeze_function =
+        (fun () -> !field_from_carrier,!field_from_relation,!field_from_name);
+      Summary.unfreeze_function =
+        (fun (ct,rt,nt) ->
+          field_from_carrier := ct; field_from_relation := rt;
+          field_from_name := nt);
+      Summary.init_function =
+        (fun () ->
+          field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty;
+          field_from_name := Spmap.empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let add_field_entry (sp,_kn) e =
+(*
+  let _ = ty e.field_ok in
+  let _ = ty e.field_simpl_eq_ok in
+  let _ = ty e.field_simpl_ok in
+  let _ = ty e.field_cond in
+*)
+  field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
+  field_from_relation := Cmap.add e.field_req e !field_from_relation;
+  field_from_name := Spmap.add sp e !field_from_name 
+
+let subst_th (_,subst,th) = 
+  let c' = subst_mps subst th.field_carrier in                   
+  let eq' = subst_mps subst th.field_req in
+  let thm1' = subst_mps subst th.field_ok in
+  let thm2' = subst_mps subst th.field_simpl_eq_ok in
+  let thm3' = subst_mps subst th.field_simpl_ok in
+  let thm4' = subst_mps subst th.field_simpl_eq_in_ok in
+  let thm5' = subst_mps subst th.field_cond in
+  let tac'= subst_tactic subst th.field_cst_tac in
+  let pow_tac' = subst_tactic subst th.field_pow_tac in
+  let pretac'= subst_tactic subst th.field_pre_tac in
+  let posttac'= subst_tactic subst th.field_post_tac in
+  if c' == th.field_carrier &&
+     eq' == th.field_req &&
+     thm1' == th.field_ok &&
+     thm2' == th.field_simpl_eq_ok &&
+     thm3' == th.field_simpl_ok &&
+     thm4' == th.field_simpl_eq_in_ok &&
+     thm5' == th.field_cond &&
+     tac' == th.field_cst_tac &&
+     pow_tac' == th.field_pow_tac &&
+     pretac' == th.field_pre_tac &&
+     posttac' == th.field_post_tac then th
+  else
+    { field_carrier = c';
+      field_req = eq';
+      field_cst_tac = tac';
+      field_pow_tac = pow_tac';
+      field_ok = thm1';
+      field_simpl_eq_ok = thm2';
+      field_simpl_ok = thm3';
+      field_simpl_eq_in_ok = thm4';
+      field_cond = thm5';
+      field_pre_tac = pretac';
+      field_post_tac = posttac' }
+
+let (ftheory_to_obj, obj_to_ftheory) = 
+  let cache_th (name,th) = add_field_entry name th
+  and export_th x = Some x in
+  declare_object
+    {(default_object "tactic-new-field-theory") with
+      open_function = (fun i o -> if i=1 then cache_th o);
+      cache_function = cache_th;
+      subst_function = subst_th;
+      classify_function = (fun (_,x) -> Substitute x);
+      export_function = export_th }
+
+let default_field_equality r inv req =
+  let is_setoid = function
+      {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true
+    | _ -> false in
+  match default_relation_for_carrier ~filter:is_setoid r with
+      Leibniz _ ->
+        mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
+    | Relation rel ->
+        let is_endomorphism = function
+            { args=args } -> List.for_all
+                (function (var,Relation rel) ->
+                  var=None && eq_constr req rel
+                  | _ -> false) args in
+        let inv_m =
+          try default_morphism ~filter:is_endomorphism inv
+          with Not_found ->
+            error "field inverse should be declared as a morphism" in
+        inv_m.lem
+
+let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign =
+  let env = Global.env() in
+  let sigma = Evd.empty in
+  let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) =
+    dest_field env sigma fth in
+  let (sth,ext) = build_setoid_params r add mul opp req eqth in
+  let eqth = Some(sth,ext) in
+  let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign in
+  let (pow_tac, pspec) = interp_power env power in 
+  let sspec = interp_sign env sign in
+  let inv_m = default_field_equality r inv req in
+  let rk = reflect_coeff morphth in
+  let params =
+    exec_tactic env 9 (field_ltac"field_lemmas")
+      (List.map carg[sth;ext;inv_m;fth;pspec;sspec;rk]) in
+  let lemma1 = constr_of params.(3) in
+  let lemma2 = constr_of params.(4) in
+  let lemma3 = constr_of params.(5) in
+  let lemma4 = constr_of params.(6) in
+  let cond_lemma =
+    match inj with
+      | Some thm -> mkApp(constr_of params.(8),[|thm|])
+      | None -> constr_of params.(7) in
+  let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in
+  let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in
+  let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in
+  let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in
+  let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in
+  let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in
+  let pretac =
+    match pre with
+        Some t -> Tacinterp.glob_tactic t
+      | _ -> TacId [] in
+  let posttac =
+    match post with
+        Some t -> Tacinterp.glob_tactic t
+      | _ -> TacId [] in
+  let _ =
+    Lib.add_leaf name
+      (ftheory_to_obj
+        { field_carrier = r;
+          field_req = req;
+          field_cst_tac = cst_tac;
+          field_pow_tac = pow_tac;
+          field_ok = lemma1;
+          field_simpl_eq_ok = lemma2;
+          field_simpl_ok = lemma3;
+          field_simpl_eq_in_ok = lemma4;
+          field_cond = cond_lemma;
+          field_pre_tac = pretac;
+          field_post_tac = posttac }) in  ()
+
+type field_mod =
+    Ring_mod of ring_mod
+  | Inject of Topconstr.constr_expr
+
+VERNAC ARGUMENT EXTEND field_mod
+  | [ ring_mod(m) ] -> [ Ring_mod m ]
+  | [ "completeness" constr(inj) ] -> [ Inject inj ]
+END
+
+let process_field_mods l =
+  let kind = ref None in
+  let set = ref None in
+  let cst_tac = ref None in
+  let pre = ref None in
+  let post = ref None in
+  let inj = ref None in  
+  let sign = ref None in
+  let power = ref None in
+  List.iter(function
+      Ring_mod(Ring_kind k) -> set_once "field kind" kind k
+    | Ring_mod(Const_tac t) ->
+        set_once "tactic recognizing constants" cst_tac t
+    | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t
+    | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t
+    | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext)
+    | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec)
+    | Ring_mod(Sign_spec t) -> set_once "sign" sign t
+    | Inject i -> set_once "infinite property" inj (ic i)) l;
+  let k = match !kind with Some k -> k | None -> Abstract in
+  (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign)
+
+VERNAC COMMAND EXTEND AddSetoidField
+| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> 
+  [ let (k,set,inj,cst_tac,pre,post,power,sign) = process_field_mods l in
+    add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign]
+END
+
+let field_lookup (f:glob_tactic_expr) lH rl t gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let rl = make_args_list rl t in
+  let e = find_field_structure env sigma rl None in
+  let rl = carg (make_term_list e.field_carrier rl) in
+  let lH = carg (make_hyp_list env lH) in
+  let req = carg e.field_req in
+  let cst_tac = Tacexp e.field_cst_tac in
+  let pow_tac = Tacexp e.field_pow_tac in
+  let field_ok = carg e.field_ok in
+  let field_simpl_ok = carg e.field_simpl_ok in
+  let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
+  let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
+  let cond_ok = carg e.field_cond in
+  let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in
+  let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
+  Tacinterp.eval_tactic
+    (TacLetIn
+      ([(dummy_loc,id_of_string"f"),None,Tacexp f],
+       ltac_lcall "f"
+        [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
+         field_simpl_eq_in_ok;cond_ok;pretac;posttac;lH;rl])) gl
+
+TACTIC EXTEND field_lookup
+| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" constr_list(l) 
+     "[" constr(t) "]" ] -> 
+      [ field_lookup (fst f) lH l t ]
+END
diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v
new file mode 100644
index 00000000..46121ff1
--- /dev/null
+++ b/contrib/subtac/FixSub.v
@@ -0,0 +1,98 @@
+Require Import Wf.
+Require Import Coq.subtac.Utils.
+
+Section Well_founded.
+  Variable A : Type.
+  Variable R : A -> A -> Prop.
+  Hypothesis Rwf : well_founded R.
+  
+  Section Acc.
+    
+    Variable P : A -> Type.
+    
+    Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
+    
+    Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x :=
+      F_sub x (fun y: { y : A | R y x}  => Fix_F_sub (proj1_sig y) 
+        (Acc_inv r (proj1_sig y) (proj2_sig y))).
+    
+    Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x).
+  End Acc.
+  
+  Section FixPoint.
+    Variable P : A -> Type.
+    
+    Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
+    
+    Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *)
+    
+    Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x).
+    
+    Hypothesis
+      F_ext :
+      forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)),
+        (forall y:{ y:A | R y x}, f y = g y) -> F_sub x f = F_sub x g.
+
+    Lemma Fix_F_eq :
+      forall (x:A) (r:Acc R x),
+        F_sub x (fun (y:{y:A|R y x}) => Fix_F (`y) (Acc_inv r (proj1_sig y) (proj2_sig y))) = Fix_F x r.
+    Proof. 
+      destruct r using Acc_inv_dep; auto.
+    Qed.
+    
+    Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F x r = Fix_F x s.
+    Proof.
+      intro x; induction (Rwf x); intros.
+      rewrite <- (Fix_F_eq x r); rewrite <- (Fix_F_eq x s); intros.
+      apply F_ext; auto.
+      intros.
+      rewrite (proof_irrelevance (Acc R x) r s) ; auto.
+    Qed.
+
+    Lemma Fix_eq : forall x:A, Fix x = F_sub x (fun (y:{y:A|R y x}) => Fix (proj1_sig y)).
+    Proof.
+      intro x; unfold Fix in |- *.
+      rewrite <- (Fix_F_eq ).
+      apply F_ext; intros.
+      apply Fix_F_inv.
+    Qed.
+
+    Lemma fix_sub_eq :
+        forall x : A,
+          Fix_sub P F_sub x =
+          let f_sub := F_sub in
+            f_sub x (fun  {y : A | R y x}=> Fix (`y)).
+      exact Fix_eq.
+    Qed.
+
+ End FixPoint.
+
+End Well_founded.
+
+Extraction Inline Fix_F_sub Fix_sub.
+
+Require Import Wf_nat.
+Require Import Lt.
+
+Section Well_founded_measure.
+Variable A : Type.
+Variable f : A -> nat.
+Definition R := fun x y => f x < f y.
+
+Section FixPoint.
+
+Variable P : A -> Type.
+
+Variable F_sub : forall x:A, (forall y: { y : A | f y < f x }, P (proj1_sig y)) -> P x.
+ 
+Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (f x)) {struct r} : P x :=
+   F_sub x (fun y: { y : A | f y < f x}  => Fix_measure_F_sub (proj1_sig y) 
+   (Acc_inv r (f (proj1_sig y)) (proj2_sig y))).
+
+Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (f x)).
+
+End FixPoint.
+
+End Well_founded_measure.
+
+Extraction Inline Fix_measure_F_sub Fix_measure_sub.
diff --git a/contrib/subtac/FunctionalExtensionality.v b/contrib/subtac/FunctionalExtensionality.v
new file mode 100644
index 00000000..1a12ac82
--- /dev/null
+++ b/contrib/subtac/FunctionalExtensionality.v
@@ -0,0 +1,25 @@
+Axiom fun_extensionality : forall A B (f g : A -> B), 
+  (forall x, f x = g x) -> f = g.
+
+Axiom fun_extensionality_dep : forall A, forall B : (A -> Type), forall (f g : forall x : A, B x), 
+  (forall x, f x = g x) -> f = g.
+
+Hint Resolve fun_extensionality fun_extensionality_dep : subtac.
+
+Require Import Coq.subtac.Utils.
+Require Import Coq.subtac.FixSub.
+
+Lemma fix_sub_eq_ext :
+  forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R)
+    (P : A -> Set)
+    (F_sub : forall x : A, (forall  {y : A | R y x}, P (`y)) -> P x),
+    forall x : A,
+      Fix_sub A R Rwf P F_sub x =
+        F_sub x (fun {y : A | R y x}=> Fix A R Rwf P F_sub (`y)).
+Proof.
+  intros ; apply Fix_eq ; auto.
+  intros.
+  assert(f = g).
+  apply (fun_extensionality_dep _ _ _ _ H).
+  rewrite H0 ; auto.
+Qed.
diff --git a/contrib/subtac/Subtac.v b/contrib/subtac/Subtac.v
new file mode 100644
index 00000000..9912cd24
--- /dev/null
+++ b/contrib/subtac/Subtac.v
@@ -0,0 +1,2 @@
+Require Export Coq.subtac.Utils.
+Require Export Coq.subtac.FixSub.
\ No newline at end of file
diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v
new file mode 100644
index 00000000..4a2208ce
--- /dev/null
+++ b/contrib/subtac/Utils.v
@@ -0,0 +1,75 @@
+Set Implicit Arguments.
+
+Notation "'fun' { x : A | P } => Q" :=
+  (fun x:{x:A|P} => Q)
+  (at level 200, x ident, right associativity).
+
+Notation "( x & ? )" := (@exist _ _ x _) : core_scope.
+
+Notation " ! " := (False_rect _ _).
+
+Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A.
+intros.
+induction t.
+exact x.
+Defined.
+
+Lemma ex_pi2  : forall (A : Prop) (P : A -> Prop) (t : ex P),
+ P (ex_pi1 t).
+intros A P.
+dependent inversion t.
+simpl.
+exact p.
+Defined.
+
+
+Notation "` t" := (proj1_sig t) (at level 100) : core_scope.
+Notation "'forall' { x : A | P } , Q" :=
+  (forall x:{x:A|P}, Q)
+  (at level 200, x ident, right associativity).
+
+Lemma subset_simpl : forall (A : Set) (P : A -> Prop) 
+	(t : sig P), P (` t).
+Proof.
+intros.
+induction t.
+ simpl ; auto.
+Qed.
+
+Ltac destruct_one_pair :=
+ match goal with
+ | [H : (ex _) |- _] => destruct H
+ | [H : (ex2 _) |- _] => destruct H
+ | [H : (sig _) |- _] => destruct H
+ | [H : (_ /\ _) |- _] => destruct H
+end.
+
+Ltac destruct_exists := repeat (destruct_one_pair) .
+
+Ltac subtac_simpl := simpl ; intros ; destruct_exists ; simpl in * ; try subst ; auto with arith.  
+
+(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *)
+Ltac destruct_call f :=
+  match goal with
+    | H : ?T |- _  =>
+      match T with
+         context [f ?x ?y ?z] => destruct (f x y z)
+       | context [f ?x ?y] => destruct (f x y)
+       | context [f ?x] => destruct (f x)        
+      end
+    | |- ?T  =>
+      match T with
+        context [f ?x ?y ?z] => let n := fresh "H" in set (n:=f x y z); destruct n
+        | context [f ?x ?y] => let n := fresh "H" in set (n:=f x y); destruct n
+        | context [f ?x] => let n := fresh "H" in set (n:=f x); destruct n
+      end
+    end.
+
+Extraction Inline proj1_sig.
+Extract Inductive unit => "unit" [ "()" ].
+Extract Inductive bool => "bool" [ "true" "false" ].
+Extract Inductive sumbool => "bool" [ "true" "false" ].
+Extract Inductive prod => "pair" [ "" ].
+Extract Inductive sigT => "pair" [ "" ].
+
+Require Export ProofIrrelevance.
diff --git a/contrib/subtac/context.ml b/contrib/subtac/context.ml
new file mode 100644
index 00000000..236b0ea5
--- /dev/null
+++ b/contrib/subtac/context.ml
@@ -0,0 +1,35 @@
+open Term
+open Names
+
+type t = rel_declaration list (* name, optional coq interp, algorithmic type *)
+
+let assoc n t = 
+  let _, term, typ = List.find (fun (x, _, _) -> x = n) t in
+    term, typ
+
+let assoc_and_index x l =
+  let rec aux i = function
+      (y, term, typ) :: tl -> if x = y then i, term, typ else aux (succ i) tl
+    | [] -> raise Not_found
+  in aux 0 l
+
+let id_of_name = function
+    Name id -> id
+  | Anonymous -> raise (Invalid_argument "id_of_name")
+(*
+
+let subst_ctx ctx c = 
+  let rec aux ((ctx, n, c) as acc) = function
+      (name, None, typ) :: tl -> 
+	aux (((id_of_name name, None, rel_to_vars ctx typ) :: ctx), 
+	     pred n, c) tl
+    | (name, Some term, typ) :: tl ->
+	let t' = Term.substnl [term] n c in
+	  aux (ctx, n, t') tl
+    | [] -> acc
+  in 
+  let (x, _, z) = aux ([], pred (List.length ctx), c) (List.rev ctx) in 
+    (x, rel_to_vars x z)
+*)
+
+let subst_env env c = (env, c)
diff --git a/contrib/subtac/context.mli b/contrib/subtac/context.mli
new file mode 100644
index 00000000..671d6f36
--- /dev/null
+++ b/contrib/subtac/context.mli
@@ -0,0 +1,5 @@
+type t = Term.rel_declaration list
+val assoc : 'a -> ('a * 'b * 'c) list -> 'b * 'c
+val assoc_and_index : 'a -> ('a * 'b * 'c) list -> int * 'b * 'c
+val id_of_name : Names.name -> Names.identifier
+val subst_env : 'a -> 'b -> 'a * 'b
diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml
new file mode 100644
index 00000000..1844fea5
--- /dev/null
+++ b/contrib/subtac/eterm.ml
@@ -0,0 +1,178 @@
+(**
+   - Get types of existentials ;
+   - Flatten dependency tree (prefix order) ;
+   - Replace existentials by De Bruijn indices in term, applied to the right arguments ;
+   - Apply term prefixed by quantification on "existentials".
+*)
+
+open Term
+open Names
+open Evd
+open List
+open Pp
+open Util
+
+let reverse_array arr = 
+  Array.of_list (List.rev (Array.to_list arr))
+    
+let trace s = 
+  if !Options.debug then (msgnl s; msgerr s)
+  else ()
+
+(** Utilities to find indices in lists *)
+let list_index x l =
+  let rec aux i = function
+      k :: tl -> if k = x then i else aux (succ i) tl
+    | [] -> raise Not_found
+  in aux 0 l
+
+let list_assoc_index x l =
+  let rec aux i = function
+      (k, _, v) :: tl -> if k = x then i else aux (succ i) tl
+    | [] -> raise Not_found
+  in aux 0 l
+
+
+(** Substitute evar references in t using De Bruijn indices, 
+  where n binders were passed through. *)
+let subst_evar_constr evs n t = 
+  let seen = ref Intset.empty in
+  let evar_info id = 
+    let rec aux i = function
+	(k, x) :: tl -> 
+	  if k = id then x else aux (succ i) tl
+      | [] -> raise Not_found
+    in aux 0 evs
+  in
+  let rec substrec depth c = match kind_of_term c with
+    | Evar (k, args) ->
+	let (id, idstr), hyps, _, _ = 
+	  try evar_info k
+	  with Not_found -> 
+	    anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
+	in
+        seen := Intset.add id !seen;
+(* 	  (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ *)
+(* 			int (List.length hyps) ++ str " hypotheses"); 	      with _ -> () ); *)
+	  (* Evar arguments are created in inverse order, 
+	     and we must not apply to defined ones (i.e. LetIn's)
+	  *)
+	let args =
+	  let rec aux hyps args acc =
+	     match hyps, args with
+		 ((_, None, _) :: tlh), (c :: tla) -> 
+		   aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc)
+	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
+		   aux tlh tla acc
+	       | [], [] -> acc
+	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
+	   in aux hyps (Array.to_list args) [] 
+	 in
+	   mkApp (mkVar idstr, Array.of_list args)
+    | _ -> map_constr_with_binders succ substrec depth c
+  in 
+  let t' = substrec 0 t in
+    t', !seen
+
+      
+(** Substitute variable references in t using De Bruijn indices, 
+  where n binders were passed through. *)
+let subst_vars acc n t = 
+  let var_index id = 
+    let idx = list_index id acc in
+      idx + 1
+  in
+  let rec substrec depth c = match kind_of_term c with
+    | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
+    | _ -> map_constr_with_binders succ substrec depth c
+  in 
+    substrec 0 t
+
+(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
+  to a product : forall H1 : t1, ..., forall Hn : tn, concl.
+    Changes evars and hypothesis references to variable references.
+*)
+let etype_of_evar evs ev hyps =
+  let rec aux acc n = function
+      (id, copt, t) :: tl ->
+	let t', s = subst_evar_constr evs n t in
+	let t'' = subst_vars acc 0 t' in
+	let copt', s = 
+	  match copt with
+	      Some c -> 
+		let c', s' = subst_evar_constr evs n c in
+		  Some c', Intset.union s s'
+	    | None -> None, s
+	in
+	let copt' = option_map (subst_vars acc 0) copt' in
+ 	let rest, s' = aux (id :: acc) (succ n) tl in
+	  mkNamedProd_or_LetIn (id, copt', t'') rest, Intset.union s' s
+    | [] ->
+	let t', s = subst_evar_constr evs n ev.evar_concl in
+	  subst_vars acc 0 t', s
+  in aux [] 0 (rev hyps)
+
+
+open Tacticals
+    
+let rec take n l = 
+  if n = 0 then [] else List.hd l :: take (pred n) (List.tl l)    
+
+let trunc_named_context n ctx = 
+  let len = List.length ctx in
+    take (len - n) ctx
+  
+let eterm_obligations name nclen evm t tycon = 
+  (* 'Serialize' the evars, we assume that the types of the existentials
+     refer to previous existentials in the list only *)
+  let evl = List.rev (to_list evm) in
+  let evn = 
+    let i = ref (-1) in
+      List.rev_map (fun (id, ev) -> incr i; 
+		  (id, (!i, id_of_string (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), ev)) evl
+  in
+  let evts = 
+    (* Remove existential variables in types and build the corresponding products *)
+    fold_right 
+      (fun (id, (n, nstr), ev) l ->
+	 let hyps = Environ.named_context_of_val ev.evar_hyps in
+	 let hyps = trunc_named_context nclen hyps in
+	 let evtyp, deps = etype_of_evar l ev hyps in
+	 let y' = (id, ((n, nstr), hyps, evtyp, deps)) in
+	   y' :: l) 
+      evn []
+  in 
+  let t', _ = (* Substitute evar refs in the term by variables *)
+    subst_evar_constr evts 0 t 
+  in
+  let evars = 
+    List.map (fun (_, ((_, name), _, typ, deps)) -> name, typ, deps) evts
+  in
+(*     (try  *)
+(*        trace (str "Term given to eterm" ++ spc () ++ *)
+(* 		Termops.print_constr_env (Global.env ()) t); *)
+(*        trace (str "Term constructed in eterm" ++ spc () ++ *)
+(* 		Termops.print_constr_env (Global.env ()) t'); *)
+(*        ignore(iter *)
+(* 		(fun (name, typ, deps) -> *)
+(* 		   trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ *)
+(* 			    Termops.print_constr_env (Global.env ()) typ)) *)
+(* 		evars); *)
+(*      with _ -> ()); *)
+    Array.of_list (List.rev evars), t'
+
+let mkMetas n = 
+  let rec aux i acc = 
+    if i > 0 then aux (pred i) (Evarutil.mk_new_meta () :: acc)
+    else acc
+  in aux n []
+
+(* let eterm evm t (tycon : types option) =  *)
+(*   let t, tycon, evs = eterm_term evm t tycon in *)
+(*     match tycon with *)
+(* 	Some typ -> Tactics.apply_term (mkCast (t, DEFAULTcast, typ)) [] *)
+(*       | None -> Tactics.apply_term t (mkMetas (List.length evs)) *)
+     
+(* open Tacmach *)
+
+let etermtac (evm, t) = assert(false) (*eterm evm t None *)
diff --git a/pretyping/instantiate.mli b/contrib/subtac/eterm.mli
index 44c4d579..3a571ee1 100644
--- a/pretyping/instantiate.mli
+++ b/contrib/subtac/eterm.mli
@@ -6,20 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: instantiate.mli,v 1.2.14.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+(*i $Id: eterm.mli 9326 2006-10-31 12:57:26Z msozeau $ i*)
 
-(*i*)
-open Names
+open Tacmach
 open Term
 open Evd
-open Sign
-open Environ
-(*i*)
+open Names
+open Util
+
+val mkMetas : int -> constr list
+
+(* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *)
 
-(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
-no body and [Not_found] if it does not exist in [sigma] *)
+val eterm_obligations : identifier -> int -> evar_map -> constr -> types option -> 
+  (identifier * types * Intset.t) array * constr (* Obl. name, type as product and dependencies as indexes into the array *)
 
-exception NotInstantiatedEvar
-val existential_value : evar_map -> existential -> constr
-val existential_type : evar_map -> existential -> types
-val existential_opt_value : evar_map -> existential -> constr option
+val etermtac : open_constr -> tactic
diff --git a/contrib/subtac/g_eterm.ml4 b/contrib/subtac/g_eterm.ml4
new file mode 100644
index 00000000..d9dd42cd
--- /dev/null
+++ b/contrib/subtac/g_eterm.ml4
@@ -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        *)
+(************************************************************************)
+(**************************************************************************)
+(*                                                                        *)
+(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
+(*                                                                        *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: g_eterm.ml4 8654 2006-03-22 15:36:58Z msozeau $ *)
+
+open Eterm
+
+TACTIC EXTEND eterm
+  [ "eterm" ] -> [ 
+    (fun gl ->
+       let evm = Tacmach.project gl and t = Tacmach.pf_concl gl in
+         Eterm.etermtac (evm, t) gl) ]
+END
diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4
new file mode 100644
index 00000000..e31326e9
--- /dev/null
+++ b/contrib/subtac/g_subtac.ml4
@@ -0,0 +1,121 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*
+  Syntax for the subtac terms and types.
+  Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
+
+(* $Id: g_subtac.ml4 9588 2007-02-02 16:17:13Z herbelin $ *)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Options
+open Util
+open Names
+open Nameops
+open Vernacentries
+open Reduction
+open Term
+open Libnames
+open Topconstr
+
+(* We define new entries for programs, with the use of this module
+ * Subtac. These entries are named Subtac.<foo>
+ *)
+
+module Gram = Pcoq.Gram
+module Vernac = Pcoq.Vernac_
+module Tactic = Pcoq.Tactic
+
+module SubtacGram =
+struct
+  let gec s = Gram.Entry.create ("Subtac."^s)
+		(* types *)
+  let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc"
+
+  let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt"
+end
+
+open SubtacGram 
+open Util
+open Pcoq
+
+let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
+
+GEXTEND Gram
+  GLOBAL: subtac_gallina_loc Constr.binder_let Constr.binder subtac_nameopt;
+ 
+  subtac_gallina_loc:
+    [ [ g = Vernac.gallina -> loc, g ] ]
+    ;
+
+  subtac_nameopt:
+    [ [ "ofb"; id=Prim.ident -> Some (id) 
+      | -> None ] ]
+    ;
+
+  Constr.binder_let:
+    [ [ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> 
+	  let typ = mkAppC (sigref, [mkLambdaC ([id], t, c)]) in
+	    LocalRawAssum ([id], typ)
+    ] ];
+
+  Constr.binder:
+    [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" ->
+          ([id],mkAppC (sigref, [mkLambdaC ([id], c, p)]))
+      | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" ->
+          ([id],c)
+      | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" ->
+          (id::lid,c)
+    ] ];
+
+  END
+
+
+type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type
+
+let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_argtype),
+  (globwit_subtac_gallina_loc : (Genarg.glevel, Tacexpr.glob_tactic_expr ) gallina_loc_argtype),
+  (rawwit_subtac_gallina_loc : (Genarg.rlevel, Tacexpr.raw_tactic_expr) gallina_loc_argtype) =
+  Genarg.create_arg "subtac_gallina_loc"
+
+type 'a nameopt_argtype = (identifier option, 'a, 'a) Genarg.abstract_argument_type
+
+let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype),
+  (globwit_subtac_nameopt : Genarg.glevel nameopt_argtype),
+  (rawwit_subtac_nameopt : Genarg.rlevel nameopt_argtype) =
+  Genarg.create_arg "subtac_nameopt"
+
+VERNAC COMMAND EXTEND Subtac
+[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
+  END
+
+VERNAC COMMAND EXTEND Subtac_Obligations
+| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, Some t) ]
+| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, None) ]
+| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, None, Some t) ]      
+| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None, None) ]
+| [ "Next" "Obligation" "of" ident(name) ] -> [ Subtac_obligations.next_obligation (Some name) ]
+| [ "Next" "Obligation" ] -> [ Subtac_obligations.next_obligation None ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Solve_Obligations
+| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations (Some name) (Tacinterp.interp t) ]
+| [ "Solve" "Obligations" "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations None (Tacinterp.interp t) ]
+| [ "Admit" "Obligations" "of" ident(name) ] -> [ Subtac_obligations.admit_obligations (Some name) ] 
+| [ "Admit" "Obligations" ] -> [ Subtac_obligations.admit_obligations None ] 
+    END
+
+VERNAC COMMAND EXTEND Subtac_Set_Solver
+| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.interp t) ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Show_Obligations
+| [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ]
+| [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ]
+END
diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml
new file mode 100644
index 00000000..5e46bead
--- /dev/null
+++ b/contrib/subtac/subtac.ml
@@ -0,0 +1,267 @@
+(************************************************************************)
+(*  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: subtac.ml 9563 2007-01-31 09:37:18Z msozeau $ *)
+
+open Global
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Reductionops
+open Environ
+open Type_errors
+open Typeops
+open Libnames
+open Classops
+open List
+open Recordops 
+open Evarutil
+open Pretype_errors
+open Rawterm
+open Evarconv
+open Pattern
+open Dyn
+open Vernacexpr
+
+open Subtac_coercion
+open Subtac_utils
+open Coqlib
+open Printer
+open Subtac_errors
+open Context
+open Eterm
+
+let require_library dirpath =
+  let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in
+    Library.require_library [qualid] None
+(*
+let subtac_one_fixpoint env isevars (f, decl) = 
+  let ((id, n, bl, typ, body), decl) = 
+    Subtac_interp_fixpoint.rewrite_fixpoint env [] (f, decl) 
+  in
+  let _ = 
+    try trace (str "Working on a single fixpoint rewritten as: " ++ spc () ++
+	       Ppconstr.pr_constr_expr body)
+    with _ -> ()
+  in ((id, n, bl, typ, body), decl)
+*)
+	      
+let subtac_fixpoint isevars l = 
+  (* TODO: Copy command.build_recursive *)
+  ()
+(*
+let save id const (locality,kind) hook =
+  let {const_entry_body = pft;
+       const_entry_type = tpo;
+       const_entry_opaque = opacity } = const in
+  let l,r = match locality with
+    | Local when Lib.sections_are_opened () ->
+        let k = logical_kind_of_goal_kind kind in
+	let c = SectionLocalDef (pft, tpo, opacity) in
+	let _ = declare_variable id (Lib.cwd(), c, k) in
+	(Local, VarRef id)
+    | Local ->
+        let k = logical_kind_of_goal_kind kind in
+        let kn = declare_constant id (DefinitionEntry const, k) in
+	(Global, ConstRef kn)
+    | Global ->
+        let k = logical_kind_of_goal_kind kind in
+        let kn = declare_constant id (DefinitionEntry const, k) in
+	(Global, ConstRef kn) in
+  Pfedit.delete_current_proof ();
+  hook l r;
+  definition_message id
+
+let save_named opacity =
+  let id,(const,persistence,hook) = Pfedit.cook_proof () in
+  let const = { const with const_entry_opaque = opacity } in
+  save id const persistence hook
+
+let check_anonymity id save_ident =
+  if atompart_of_id id <> "Unnamed_thm" then
+    error "This command can only be used for unnamed theorem"
+(*
+    message("Overriding name "^(string_of_id id)^" and using "^save_ident)
+*)
+
+let save_anonymous opacity save_ident =
+  let id,(const,persistence,hook) = Pfedit.cook_proof () in
+  let const = { const with const_entry_opaque = opacity } in
+  check_anonymity id save_ident;
+  save save_ident const persistence hook
+
+let save_anonymous_with_strength kind opacity save_ident =
+  let id,(const,_,hook) = Pfedit.cook_proof () in
+  let const = { const with const_entry_opaque = opacity } in
+  check_anonymity id save_ident;
+  (* we consider that non opaque behaves as local for discharge *)
+  save save_ident const (Global, Proof kind) hook
+
+let subtac_end_proof = function
+  | Admitted -> admit ()
+  | Proved (is_opaque,idopt) ->
+    if_verbose show_script ();
+    match idopt with
+    | None -> save_named is_opaque
+    | Some ((_,id),None) -> save_anonymous is_opaque id
+    | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id
+
+	*)
+
+open Pp
+open Ppconstr
+open Decl_kinds
+open Tacinterp
+open Tacexpr
+
+let start_proof_com env isevars sopt kind (bl,t) hook =
+  let id = match sopt with
+    | Some id ->
+        (* We check existence here: it's a bit late at Qed time *)
+        if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
+          errorlabstrm "start_proof" (pr_id id ++ str " already exists");
+        id
+    | None ->
+	next_global_ident_away false (id_of_string "Unnamed_thm")
+ 	  (Pfedit.get_all_proof_names ())
+  in
+  let evm, c, typ = 
+    Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None 
+  in
+  let _ = Typeops.infer_type env c in
+    Command.start_proof id kind c hook
+      
+let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
+
+let subtac_utils_path =
+  make_dirpath (List.map id_of_string ["Utils";contrib_name;"Coq"])
+let utils_tac s =
+  lazy(make_kn (MPfile subtac_utils_path) (make_dirpath []) (mk_label s))
+
+let utils_call tac args =
+  TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (utils_tac tac)),args))
+
+let start_proof_and_print env isevars idopt k t hook =
+  start_proof_com env isevars idopt k t hook;
+  print_subgoals ()
+  (*if !pcoq <> None then (out_some !pcoq).start_proof ()*)
+
+let _ = Subtac_obligations.set_default_tactic 
+    (Tacinterp.eval_tactic (utils_call "subtac_simpl" []))
+
+
+let subtac (loc, command) =
+  check_required_library ["Coq";"Init";"Datatypes"];
+  check_required_library ["Coq";"Init";"Specif"];
+  (* check_required_library ["Coq";"Logic";"JMeq"]; *)
+  require_library "Coq.subtac.FixSub";
+  require_library "Coq.subtac.Utils";
+  let env = Global.env () in
+  let isevars = ref (create_evar_defs Evd.empty) in
+  try
+    match command with
+	VernacDefinition (defkind, (locid, id), expr, hook) -> 
+	    (match expr with
+		 ProveBody (bl, c) -> Subtac_pretyping.subtac_proof env isevars id bl c None
+(* 		   let evm, c, ctyp =  in *)
+(* 		     trace (str "Starting proof"); *)
+(* 		     Command.start_proof id goal_kind c hook; *)
+(* 		     trace (str "Started proof");	      *)
+		     
+	       | DefineBody (bl, _, c, tycon) -> 
+		   Subtac_pretyping.subtac_proof env isevars id bl c tycon
+		     (* let tac = Eterm.etermtac (evm, c) in  *)
+		     (* 		     trace (str "Starting proof"); *)
+		     (* 		     Command.start_proof id goal_kind ctyp hook; *)
+		     (* 		     trace (str "Started proof"); *)
+		     (* 		     Pfedit.by tac) *))
+      | VernacFixpoint (l, b) -> 
+	  let _ = trace (str "Building fixpoint") in
+	    ignore(Subtac_command.build_recursive l b)
+
+      | VernacStartTheoremProof (thkind, (locid, id), (bl, t), lettop, hook) ->
+	  if not(Pfedit.refining ()) then
+	    if lettop then
+	      errorlabstrm "Subtac_command.StartProof"
+		(str "Let declarations can only be used in proof editing mode");
+	  if Lib.is_modtype () then
+	    errorlabstrm "Subtac_command.StartProof"
+	      (str "Proof editing mode not supported in module types");
+	  start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook
+
+
+
+      (*| VernacEndProof e -> 
+	  subtac_end_proof e*)
+
+      | _ -> user_err_loc (loc,"", str ("Invalid Program command"))
+  with 
+    | Typing_error e ->
+	msg_warning (str "Type error in Program tactic:");
+	let cmds = 
+	  (match e with
+	     | NonFunctionalApp (loc, x, mux, e) ->
+		 str "non functional application of term " ++ 
+		 e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux
+	     | NonSigma (loc, t) ->
+		 str "Term is not of Sigma type: " ++ t
+	     | NonConvertible (loc, x, y) ->
+		 str "Unconvertible terms:" ++ spc () ++
+		   x ++ spc () ++ str "and" ++ spc () ++ y
+	     | IllSorted (loc, t) ->
+		 str "Term is ill-sorted:" ++ spc () ++ t
+	  )
+	in msg_warning cmds
+	     
+    | Subtyping_error e ->
+	msg_warning (str "(Program tactic) Subtyping error:");
+	let cmds = 
+	  match e with
+	    | UncoercibleInferType (loc, x, y) ->
+		str "Uncoercible terms:" ++ spc ()
+		++ x ++ spc () ++ str "and" ++ spc () ++ y
+	    | UncoercibleInferTerm (loc, x, y, tx, ty) ->
+		str "Uncoercible terms:" ++ spc ()
+		++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x
+		++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y
+	    | UncoercibleRewrite (x, y) ->
+		str "Uncoercible terms:" ++ spc ()
+		++ x ++ spc () ++ str "and" ++ spc () ++ y
+	in msg_warning cmds
+    
+    | Type_errors.TypeError (env, exn) as e ->
+	debug 2 (Himsg.explain_type_error env exn);
+	raise e
+	  
+    | Pretype_errors.PretypeError (env, exn) as e ->
+	debug 2 (Himsg.explain_pretype_error env exn);
+	raise e
+	  
+    | (Stdpp.Exc_located (loc, e')) as e ->
+	debug 2 (str "Parsing exception: ");
+	(match e' with
+	   | Type_errors.TypeError (env, exn) ->
+	       debug 2 (Himsg.explain_type_error env exn);
+	       raise e
+		 
+	   | Pretype_errors.PretypeError (env, exn) ->
+	       debug 2 (Himsg.explain_pretype_error env exn);
+	       raise e
+
+	   | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e'');
+	       raise e)
+  
+    | e -> 
+	msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e);
+	raise e
+
+
diff --git a/contrib/subtac/subtac.mli b/contrib/subtac/subtac.mli
new file mode 100644
index 00000000..25922782
--- /dev/null
+++ b/contrib/subtac/subtac.mli
@@ -0,0 +1,3 @@
+val require_library : string -> unit
+val subtac_fixpoint : 'a -> 'b -> unit
+val subtac : Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml
new file mode 100644
index 00000000..fbe1ac37
--- /dev/null
+++ b/contrib/subtac/subtac_cases.ml
@@ -0,0 +1,1925 @@
+(************************************************************************)
+(*  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: cases.ml 9399 2006-11-22 16:11:53Z herbelin $ *)
+
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Declarations
+open Inductiveops
+open Environ
+open Sign
+open Reductionops
+open Typeops
+open Type_errors
+
+open Rawterm
+open Retyping
+open Pretype_errors
+open Evarutil
+open Evarconv
+
+open Subtac_utils
+
+(* Pattern-matching errors *)
+
+type pattern_matching_error =
+  | BadPattern of constructor * constr
+  | BadConstructor of constructor * inductive
+  | WrongNumargConstructor of constructor * int
+  | WrongNumargInductive of inductive * int
+  | WrongPredicateArity of constr * constr * constr
+  | NeedsInversion of constr * constr
+  | UnusedClause of cases_pattern list
+  | NonExhaustive of cases_pattern list
+  | CannotInferPredicate of (constr * types) array
+
+exception PatternMatchingError of env * pattern_matching_error
+
+let raise_pattern_matching_error (loc,ctx,te) =
+  Stdpp.raise_with_loc loc (PatternMatchingError(ctx,te))
+
+let error_bad_pattern_loc loc cstr ind =
+  raise_pattern_matching_error (loc, Global.env(), BadPattern (cstr,ind))
+
+let error_bad_constructor_loc loc cstr ind =
+  raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind))
+
+let error_wrong_numarg_constructor_loc loc env c n =
+  raise_pattern_matching_error (loc, env, WrongNumargConstructor(c,n))
+
+let error_wrong_numarg_inductive_loc loc env c n =
+  raise_pattern_matching_error (loc, env, WrongNumargInductive(c,n))
+
+let error_wrong_predicate_arity_loc loc env c n1 n2 =
+  raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2))
+
+let error_needs_inversion env x t =
+  raise (PatternMatchingError (env, NeedsInversion (x,t)))
+
+module type S = sig
+  val compile_cases :
+    loc ->
+    (type_constraint -> env -> rawconstr -> unsafe_judgment) *
+      Evd.evar_defs ref ->
+    type_constraint -> 
+    env -> rawconstr option * tomatch_tuple * cases_clauses ->
+    unsafe_judgment
+end
+
+(************************************************************************)
+(*            Pattern-matching compilation (Cases)                      *)
+(************************************************************************)
+
+(************************************************************************)
+(* Configuration, errors and warnings *)
+
+open Pp
+
+let mssg_may_need_inversion () =
+  str "Found a matching with no clauses on a term unknown to have an empty inductive type"
+
+(* Utils *)
+let make_anonymous_patvars =
+  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) 
+
+(* Environment management *)
+let push_rels vars env = List.fold_right push_rel vars env
+
+let push_rel_defs =
+  List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e)
+
+(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
+   over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
+
+let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j
+
+let rec regeneralize_index i k t = match kind_of_term t with
+  | Rel j when j = i+k -> mkRel (k+1)
+  | Rel j when j < i+k -> t
+  | Rel j when j > i+k -> t
+  | _ -> map_constr_with_binders succ (regeneralize_index i) k t
+
+type alias_constr =
+  | DepAlias
+  | NonDepAlias
+
+let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
+  { uj_val =
+      (match d with
+	| DepAlias -> mkLetIn (na,deppat,t,j.uj_val)
+	| NonDepAlias ->
+	    if (not (dependent (mkRel 1) j.uj_type))
+	      or (* A leaf: *) isRel deppat
+	    then 
+	      (* The body of pat is not needed to type j - see *)
+	      (* insert_aliases - and both deppat and nondeppat have the *)
+	      (* same type, then one can freely substitute one by the other *)
+	      subst1 nondeppat j.uj_val
+	    else
+	      (* The body of pat is not needed to type j but its value *)
+	      (* is dependent in the type of j; our choice is to *)
+	      (* enforce this dependency *)
+	      mkLetIn (na,deppat,t,j.uj_val));
+    uj_type = subst1 deppat j.uj_type }
+
+(**********************************************************************)
+(* Structures used in compiling pattern-matching *)
+
+type rhs =
+    { rhs_env    : env;
+      avoid_ids  : identifier list;
+      it         : rawconstr;
+    }
+
+type equation =
+    { patterns     : cases_pattern list; 
+      rhs          : rhs;
+      alias_stack  : name list;
+      eqn_loc      : loc;
+      used         : bool ref;
+      tag          : pattern_source }
+
+type matrix = equation list
+
+(* 1st argument of IsInd is the original ind before extracting the summary *)
+type tomatch_type =
+  | IsInd of types * inductive_type
+  | NotInd of constr option * types
+
+type tomatch_status =
+  | Pushed of ((constr * tomatch_type) * int list)
+  | Alias of (constr * constr * alias_constr * constr)
+  | Abstract of rel_declaration
+
+type tomatch_stack = tomatch_status list
+
+(* The type [predicate_signature] types the terms to match and the rhs:
+
+   - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
+     if dep<>Anonymous, the term is dependent, let n=|names|, if
+     n<>0 then the type of the pushed term is necessarily an
+     inductive with n real arguments. Otherwise, it may be
+     non inductive, or inductive without real arguments, or inductive
+     originating from a subterm in which case real args are not dependent;
+     it accounts for n+1 binders if dep or n binders if not dep
+   - [PrProd] types abstracted term ([Abstract]); it accounts for one binder
+   - [PrCcl] types the right-hand-side
+   - Aliases [Alias] have no trace in [predicate_signature]
+*)
+
+type predicate_signature =
+  | PrLetIn of (name list * name) * predicate_signature
+  | PrProd of predicate_signature
+  | PrCcl of constr
+
+(* We keep a constr for aliases and a cases_pattern for error message *)
+
+type alias_builder =
+  | AliasLeaf
+  | AliasConstructor of constructor
+
+type pattern_history =
+  | Top
+  | MakeAlias of alias_builder * pattern_continuation
+
+and pattern_continuation =
+  | Continuation of int * cases_pattern list * pattern_history
+  | Result of cases_pattern list
+
+let start_history n = Continuation (n, [], Top)
+
+let initial_history = function Continuation (_,[],Top) -> true | _ -> false
+
+let feed_history arg = function
+  | Continuation (n, l, h) when n>=1 ->
+      Continuation (n-1, arg :: l, h)
+  | Continuation (n, _, _) ->
+      anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
+  | Result _ -> 
+      anomaly "Exhausted pattern history"
+
+(* This is for non exhaustive error message *)
+
+let rec rawpattern_of_partial_history args2 = function
+  | Continuation (n, args1, h) ->
+      let args3 = make_anonymous_patvars (n - (List.length args2)) in
+      build_rawpattern (List.rev_append args1 (args2@args3)) h
+  | Result pl -> pl
+
+and build_rawpattern args = function
+  | Top -> args
+  | MakeAlias (AliasLeaf, rh) ->
+      assert (args = []);
+      rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
+  | MakeAlias (AliasConstructor pci, rh) ->
+      rawpattern_of_partial_history
+	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
+
+let complete_history = rawpattern_of_partial_history []
+
+(* This is to build glued pattern-matching history and alias bodies *)
+
+let rec simplify_history = function
+  | Continuation (0, l, Top) -> Result (List.rev l)
+  | Continuation (0, l, MakeAlias (f, rh)) ->
+      let pargs = List.rev l in
+      let pat = match f with
+	| AliasConstructor pci ->
+	    PatCstr (dummy_loc,pci,pargs,Anonymous)
+	| AliasLeaf -> 
+	    assert (l = []);
+	    PatVar (dummy_loc, Anonymous) in
+      feed_history pat rh
+  | h -> h
+
+(* Builds a continuation expecting [n] arguments and building [ci] applied
+   to this [n] arguments *)
+
+let push_history_pattern n current cont =
+  Continuation (n, [], MakeAlias (current, cont))
+
+(* A pattern-matching problem has the following form:
+
+   env, isevars |- <pred> Cases tomatch of mat end
+
+  where tomatch is some sequence of "instructions" (t1  ... tn)
+
+  and mat is some matrix 
+   (p11 ... p1n -> rhs1)
+   (    ...            )
+   (pm1 ... pmn -> rhsm)
+
+  Terms to match: there are 3 kinds of instructions
+
+  - "Pushed" terms to match are typed in [env]; these are usually just
+    Rel(n) except for the initial terms given by user and typed in [env]
+  - "Abstract" instructions means an abstraction has to be inserted in the
+    current branch to build (this means a pattern has been detected dependent
+    in another one and generalisation is necessary to ensure well-typing)
+  - "Alias" instructions means an alias has to be inserted (this alias
+    is usually removed at the end, except when its type is not the
+    same as the type of the matched term from which it comes -
+    typically because the inductive types are "real" parameters)
+
+  Right-hand-sides:
+
+  They consist of a raw term to type in an environment specific to the
+  clause they belong to: the names of declarations are those of the
+  variables present in the patterns. Therefore, they come with their
+  own [rhs_env] (actually it is the same as [env] except for the names
+  of variables).
+
+*)
+type pattern_matching_problem =
+    { env      : env;
+      isevars  : Evd.evar_defs ref;
+      pred     : predicate_signature option;
+      tomatch  : tomatch_stack;
+      history  : pattern_continuation;
+      mat      : matrix;
+      caseloc  : loc;
+      typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
+
+(*--------------------------------------------------------------------------*
+ * A few functions to infer the inductive type from the patterns instead of *
+ * checking that the patterns correspond to the ind. type of the            *
+ * destructurated object. Allows type inference of examples like            *
+ *  match n with O => true | _ => false end                                 *
+ *  match x in I with C => true | _ => false end                            *
+ *--------------------------------------------------------------------------*)
+
+(* Computing the inductive type from the matrix of patterns *)
+
+(* We use the "in I" clause to coerce the terms to match and otherwise
+   use the constructor to know in which type is the matching problem
+
+   Note that insertion of coercions inside nested patterns is done
+   each time the matrix is expanded *)
+
+let rec find_row_ind = function
+    [] -> None
+  | PatVar _ :: l -> find_row_ind l
+  | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
+
+let inductive_template isevars env tmloc ind =
+  let arsign = get_full_arity_sign env ind in
+  let hole_source = match tmloc with 
+    | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
+    | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
+   let (_,evarl,_) =
+    List.fold_right
+      (fun (na,b,ty) (subst,evarl,n) ->
+	match b with
+        | None ->
+	    let ty' = substl subst ty in
+	    let e = e_new_evar isevars env ~src:(hole_source n) ty' in
+	    (e::subst,e::evarl,n+1) 
+	| Some b ->
+	    (b::subst,evarl,n+1))
+      arsign ([],[],1) in
+   applist (mkInd ind,List.rev evarl)
+
+
+(************************************************************************)
+(* Utils *)
+
+let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
+  e_new_evar isevars env ~src:src (new_Type ())
+
+let evd_comb2 f isevars x y =
+  let (evd',y) = f !isevars x y in
+  isevars := evd';
+  y
+
+
+module Cases_F(Coercion : Coercion.S) : S = struct
+
+let inh_coerce_to_ind isevars env ty tyi =
+  let expected_typ = inductive_template isevars env None tyi in
+     (* devrait être indifférent d'exiger leq ou pas puisque pour 
+        un inductif cela doit être égal *)
+  let _ = e_cumul env isevars expected_typ ty in ()
+
+let unify_tomatch_with_patterns isevars env loc typ pats =
+  match find_row_ind pats with
+    | None -> NotInd (None,typ)
+    | Some (_,(ind,_)) ->
+	inh_coerce_to_ind isevars env typ ind;
+	try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+	with Not_found -> NotInd (None,typ)
+
+let find_tomatch_tycon isevars env loc = function
+  (* Try if some 'in I ...' is present and can be used as a constraint *)
+  | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind)
+  | None -> empty_tycon
+
+let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
+  let loc = Some (loc_of_rawconstr tomatch) in
+  let tycon = find_tomatch_tycon isevars env loc indopt in
+  let j = typing_fun tycon env tomatch in
+  let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in
+  isevars := evd;
+  let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in
+  let t =
+    try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+    with Not_found ->
+      unify_tomatch_with_patterns isevars env loc typ pats in
+  (j.uj_val,t)
+
+let coerce_to_indtype typing_fun isevars env matx tomatchl =
+  let pats = List.map (fun r ->  r.patterns) matx in
+  let matx' = match matrix_transpose pats with
+    | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
+    | m -> m in
+  List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
+
+
+
+let adjust_tomatch_to_pattern pb ((current,typ),deps) =
+  (* Ideally, we could find a common inductive type to which both the
+     term to match and the patterns coerce *)
+  (* In practice, we coerce the term to match if it is not already an
+     inductive type and it is not dependent; moreover, we use only 
+     the first pattern type and forget about the others *)
+  let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
+  let typ =
+    try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ)
+    with Not_found -> NotInd (None,typ) in
+  let tomatch = ((current,typ),deps) in
+  match typ with
+  | NotInd (None,typ) ->
+      let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
+      (match find_row_ind tm1 with
+	| None -> tomatch
+	| Some (_,(ind,_)) ->
+	    let indt = inductive_template pb.isevars pb.env None ind in
+	    let current =
+	      if deps = [] & isEvar typ then
+	      (* Don't insert coercions if dependent; only solve evars *)
+		let _ = e_cumul pb.env pb.isevars indt typ in
+		current
+	      else
+		(evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
+		  pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
+	    let sigma = Evd.evars_of !(pb.isevars) in
+	    let typ = IsInd (indt,find_rectype pb.env sigma indt) in
+	    ((current,typ),deps))
+  | _ -> tomatch
+
+   (* extract some ind from [t], possibly coercing from constructors in [tm] *)
+let to_mutind env isevars tm c t =
+(*  match c with
+    | Some body -> *) NotInd (c,t)
+(*    | None -> unify_tomatch_with_patterns isevars env t tm*)
+
+let type_of_tomatch = function
+  | IsInd (t,_) -> t
+  | NotInd (_,t) -> t
+
+let mkDeclTomatch na = function
+  | IsInd (t,_) -> (na,None,t)
+  | NotInd (c,t) -> (na,c,t)
+
+let map_tomatch_type f = function
+  | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind)
+  | NotInd (c,t) -> NotInd (option_map f c, f t)
+
+let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
+let lift_tomatch_type n = liftn_tomatch_type n 1
+
+let lift_tomatch n ((current,typ),info) =
+  ((lift n current,lift_tomatch_type n typ),info)
+
+(**********************************************************************)
+(* Utilities on patterns *)
+
+let current_pattern eqn =
+  match eqn.patterns with
+    | pat::_ -> pat
+    | [] -> anomaly "Empty list of patterns"
+
+let alias_of_pat = function
+  | PatVar (_,name) -> name
+  | PatCstr(_,_,_,name) -> name
+
+let unalias_pat = function
+  | PatVar (c,name) as p ->
+      if name = Anonymous then p else PatVar (c,Anonymous)
+  | PatCstr(a,b,c,name) as p ->
+      if name = Anonymous then p else PatCstr (a,b,c,Anonymous)
+
+let remove_current_pattern eqn =
+  match eqn.patterns with
+    | pat::pats ->
+	{ eqn with
+	    patterns = pats;
+	    alias_stack = alias_of_pat pat :: eqn.alias_stack }
+    | [] -> anomaly "Empty list of patterns"
+
+let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
+
+(**********************************************************************)
+(* Dealing with regular and default patterns *)
+let is_regular eqn = eqn.tag = RegularPat
+
+let lower_pattern_status = function
+  | RegularPat -> DefaultPat 0
+  | DefaultPat n -> DefaultPat (n+1)
+
+let pattern_status pats =
+  if array_exists ((=) RegularPat) pats then RegularPat
+  else 
+    let min =
+      Array.fold_right
+	(fun pat n -> match pat with
+	   | DefaultPat i when i<n -> i
+	   | _ -> n)
+	pats 0 in
+    DefaultPat min
+
+(**********************************************************************)
+(* Well-formedness tests *)
+(* Partial check on patterns *)
+
+exception NotAdjustable
+
+let rec adjust_local_defs loc = function
+  | (pat :: pats, (_,None,_) :: decls) ->
+      pat :: adjust_local_defs loc (pats,decls)
+  | (pats, (_,Some _,_) :: decls) ->
+      PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
+  | [], [] -> []
+  | _ -> raise NotAdjustable
+
+let check_and_adjust_constructor env ind cstrs = function 
+  | PatVar _ as pat -> pat
+  | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
+      (* Check it is constructor of the right type *)
+      let ind' = inductive_of_constructor cstr in
+      if Closure.mind_equiv env ind' ind then
+	(* Check the constructor has the right number of args *)
+	let ci = cstrs.(i-1) in
+	let nb_args_constr = ci.cs_nargs in
+	if List.length args = nb_args_constr then pat
+	else
+	  try 
+	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
+	    in PatCstr (loc, cstr, args', alias)
+	  with NotAdjustable ->
+	    error_wrong_numarg_constructor_loc loc (Global.env())
+	      cstr nb_args_constr
+      else
+	(* Try to insert a coercion *)
+	try
+	  Coercion.inh_pattern_coerce_to loc pat ind' ind
+	with Not_found -> 
+	  error_bad_constructor_loc loc cstr ind
+
+let check_all_variables typ mat =
+  List.iter
+    (fun eqn -> match current_pattern eqn with
+       | PatVar (_,id) -> ()
+       | PatCstr (loc,cstr_sp,_,_) ->
+	   error_bad_pattern_loc loc cstr_sp typ)
+    mat
+
+let check_unused_pattern env eqn =
+  if not !(eqn.used) then 
+    raise_pattern_matching_error
+      (eqn.eqn_loc, env, UnusedClause eqn.patterns)
+
+let set_used_pattern eqn = eqn.used := true
+
+let extract_rhs pb =
+  match pb.mat with 
+    | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
+    | eqn::_ ->
+	set_used_pattern eqn;
+	eqn.tag, eqn.rhs
+
+(**********************************************************************)
+(* Functions to deal with matrix factorization *)
+
+let occur_in_rhs na rhs =
+  match na with
+    | Anonymous -> false
+    | Name id -> occur_rawconstr id rhs.it
+
+let is_dep_patt eqn = function
+  | PatVar (_,name) -> occur_in_rhs name eqn.rhs
+  | PatCstr _ -> true
+
+let dependencies_in_rhs nargs eqns =
+  if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *)
+  else
+  let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in
+  let columns = matrix_transpose deps in
+  List.map (List.exists ((=) true)) columns
+
+let dependent_decl a = function
+  | (na,None,t) -> dependent a t
+  | (na,Some c,t) -> dependent a t || dependent a c
+
+(* Computing the matrix of dependencies *)
+
+(* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
+   computes for declaration [k+1] in which of declarations in
+   [nextlist] (which corresponds to d(k+2)...dn) it depends;
+   declarations are expressed by index, e.g. in dependency list
+   [n-2;1], [1] points to [dn] and [n-2] to [d3] *)
+
+let rec find_dependency_list k n = function
+  | [] -> []
+  | (used,tdeps,d)::rest -> 
+      let deps = find_dependency_list k (n+1) rest in
+      if used && dependent_decl (mkRel n) d
+      then list_add_set (List.length rest + 1) (list_union deps tdeps)
+      else deps
+
+let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) =
+  let deps = find_dependency_list k 1 nextlist in
+  if is_dep_or_cstr_in_rhs || deps <> []
+  then (k-1,(true ,deps,d)::nextlist)
+  else (k-1,(false,[]  ,d)::nextlist)
+
+let find_dependencies_signature deps_in_rhs typs =
+  let k = List.length deps_in_rhs in
+  let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in
+  List.map (fun (_,deps,_) -> deps) l
+
+(******)
+
+(* A Pushed term to match has just been substituted by some
+   constructor t = (ci x1...xn) and the terms x1 ... xn have been added to
+   match 
+
+   - all terms to match and to push (dependent on t by definition)
+     must have (Rel depth) substituted by t and Rel's>depth lifted by n
+   - all pushed terms to match (non dependent on t by definition) must
+     be lifted by n
+
+  We start with depth=1
+*)
+
+let regeneralize_index_tomatch n =
+  let rec genrec depth = function
+  | [] -> []
+  | Pushed ((c,tm),l)::rest ->
+      let c = regeneralize_index n depth c in
+      let tm = map_tomatch_type (regeneralize_index n depth) tm in
+      let l = List.map (regeneralize_rel n depth) l in
+      Pushed ((c,tm),l)::(genrec depth rest)
+  | Alias (c1,c2,d,t)::rest ->
+      Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest)
+  | Abstract d::rest ->
+      Abstract (map_rel_declaration (regeneralize_index n depth) d)
+      ::(genrec (depth+1) rest) in
+  genrec 0
+
+let rec replace_term n c k t = 
+  if t = mkRel (n+k) then lift k c
+  else map_constr_with_binders succ (replace_term n c) k t
+
+let replace_tomatch n c =
+  let rec replrec depth = function
+  | [] -> []
+  | Pushed ((b,tm),l)::rest ->
+      let b = replace_term n c depth b in
+      let tm = map_tomatch_type (replace_term n c depth) tm in
+      List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
+      Pushed ((b,tm),l)::(replrec depth rest)
+  | Alias (c1,c2,d,t)::rest ->
+      Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest)
+  | Abstract d::rest ->
+      Abstract (map_rel_declaration (replace_term n c depth) d)
+      ::(replrec (depth+1) rest) in
+  replrec 0
+
+let liftn_rel_declaration n k = map_rel_declaration (liftn n k)
+let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k)
+
+let rec liftn_tomatch_stack n depth = function
+  | [] -> []
+  | Pushed ((c,tm),l)::rest ->
+      let c = liftn n depth c in
+      let tm = liftn_tomatch_type n depth tm in
+      let l = List.map (fun i -> if i<depth then i else i+n) l in
+      Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest)
+  | Alias (c1,c2,d,t)::rest ->
+      Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t)
+      ::(liftn_tomatch_stack n depth rest)
+  | Abstract d::rest ->
+      Abstract (map_rel_declaration (liftn n depth) d)
+      ::(liftn_tomatch_stack n (depth+1) rest)
+
+
+let lift_tomatch_stack n = liftn_tomatch_stack n 1
+
+(* if [current] has type [I(p1...pn u1...um)] and we consider the case
+   of constructor [ci] of type [I(p1...pn u'1...u'm)], then the
+   default variable [name] is expected to have which type?
+   Rem: [current] is [(Rel i)] except perhaps for initial terms to match *)
+
+(************************************************************************)
+(* Some heuristics to get names for variables pushed in pb environment *)
+(* Typical requirement:
+
+   [match y with (S (S x)) => x | x => x end] should be compiled into
+   [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
+
+   and [match y with (S (S n)) => n | n => n end] into 
+   [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
+
+  i.e. user names should be preserved and created names should not
+  interfere with user names *)
+
+let merge_name get_name obj = function
+  | Anonymous -> get_name obj
+  | na -> na
+
+let merge_names get_name = List.map2 (merge_name get_name)
+
+let get_names env sign eqns =
+  let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in
+  (* If any, we prefer names used in pats, from top to bottom *)
+  let names2 = 
+    List.fold_right
+      (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
+      eqns names1 in
+  (* Otherwise, we take names from the parameters of the constructor but
+     avoiding conflicts with user ids *)
+  let allvars =
+    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in
+  let names4,_ =
+    List.fold_left2
+      (fun (l,avoid) d na ->
+	 let na =
+	   merge_name
+	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
+	     d na 
+	 in
+         (na::l,(out_name na)::avoid))
+      ([],allvars) (List.rev sign) names2 in
+  names4
+
+(************************************************************************)
+(* Recovering names for variables pushed to the rhs' environment *)
+
+let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
+
+let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in
+				(n, b, t)) sign
+
+let push_rels_eqn sign eqn =
+  let sign = all_name sign in
+(*    trace (str "push_rels_eqn: " ++ my_print_rel_context eqn.rhs.rhs_env sign ++ str "end");   *)
+(* 	str " branch is " ++ my_print_constr (fst eqn.rhs.c_orig) (snd eqn.rhs.c_orig)); *)
+(*   let rhs = eqn.rhs in *)
+(*   let l, c, s, e = *)
+(*     List.fold_right *)
+(*       (fun (na, c, t) (itlift, it, sign, env) -> *)
+(* 	 (try trace (str "Pushing decl: " ++ pr_rel_decl env (na, c, t) ++ *)
+(* 		  str " lift is " ++ int itlift); *)
+(* 	 with _ -> trace (str "error in push_rels_eqn")); *)
+(* 	 let env' = push_rel (na, c, t) env in *)
+(* 	   match sign with  *)
+(* 	       [] -> (itlift, lift 1 it, sign, env') *)
+(* 	     | (na', c, t) :: sign' ->  *)
+(* 		 if na' = na then  *)
+(* 		   (pred itlift, it, sign', env') *)
+(* 		 else ( *)
+(* 		   trace (str "skipping it"); *)
+(* 		   (itlift, liftn 1 itlift it, sign, env'))) *)
+(*       sign (rhs.rhs_lift, rhs.c_it, eqn.rhs.rhs_sign, eqn.rhs.rhs_env) *)
+(*   in *)
+    {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } }
+
+let push_rels_eqn_with_names sign eqn =
+  let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in
+  let sign = recover_alias_names alias_of_pat pats sign in
+  push_rels_eqn sign eqn
+
+let build_aliases_context env sigma names allpats pats =
+  (* pats is the list of bodies to push as an alias *)
+  (* They all are defined in env and we turn them into a sign *)
+  (* cuts in sign need to be done in allpats *)
+  let rec insert env sign1 sign2 n newallpats oldallpats = function
+    | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) ->
+        (* Anonymous leaves must be considered named and treated in the *)
+        (* next clause because they may occur in implicit arguments *)
+	insert env sign1 sign2
+	  n newallpats (List.map List.tl oldallpats) (pats,names)
+    | (deppat,nondeppat,d,t)::pats, na::names ->
+	let nondeppat = lift n nondeppat in
+	let deppat = lift n deppat in
+	let newallpats =
+	  List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
+	let oldallpats = List.map List.tl oldallpats in
+	let decl = (na,Some deppat,t) in
+	let a = (deppat,nondeppat,d,t) in
+	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) 
+	  newallpats oldallpats (pats,names)
+    | [], [] -> newallpats, sign1, sign2, env
+    | _ -> anomaly "Inconsistent alias and name lists" in
+  let allpats = List.map (fun x -> [x]) allpats
+  in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names)
+
+let insert_aliases_eqn sign eqnnames alias_rest eqn =
+  let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
+    push_rels_eqn thissign { eqn with  alias_stack = alias_rest; }
+	    
+
+let insert_aliases env sigma alias eqns =
+  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
+  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
+  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
+  let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
+  let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
+  (* names2 takes the meet of all needed aliases *)
+  let names2 = 
+    List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
+  (* Only needed aliases are kept by build_aliases_context *)
+  let eqnsnames, sign1, sign2, env =
+    build_aliases_context env sigma [names2] eqnsnames [alias] in
+  let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
+  sign2, env, eqns
+
+(**********************************************************************)
+(* Functions to deal with elimination predicate *)
+
+exception Occur
+let noccur_between_without_evar n m term = 
+  let rec occur_rec n c = match kind_of_term c with
+    | Rel p       -> if n<=p && p<n+m then raise Occur
+    | Evar (_,cl) -> ()
+    | _             -> iter_constr_with_binders succ occur_rec n c
+  in 
+  try occur_rec n term; true with Occur -> false
+
+(* Inferring the predicate *)
+let prepare_unif_pb typ cs =
+  let n = List.length (assums_of_rel_context cs.cs_args) in
+
+  (* We may need to invert ci if its parameters occur in typ *)
+  let typ' =
+    if noccur_between_without_evar 1 n typ then lift (-n) typ
+    else (* TODO4-1 *)
+      error "Unable to infer return clause of this pattern-matching problem" in
+  let args = extended_rel_list (-n) cs.cs_args in
+  let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in
+
+  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *)
+  (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ')
+
+
+(* Infering the predicate *)
+(*
+The problem to solve is the following:
+
+We match Gamma |- t : I(u01..u0q) against the following constructors:
+
+  Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q)
+   ...
+  Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq)
+
+Assume the types in the branches are the following
+
+  Gamma, x11...x1p1 |- branch1 : T1
+   ...
+  Gamma, xn1...xnpn |- branchn : Tn
+
+Assume the type of the global case expression is Gamma |- T
+
+The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy
+the following n+1 equations:
+
+  Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1))  =  T1
+   ...
+  Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn))  =  Tn
+  Gamma             |- (phi u01..u0q t)               =  T
+
+Some hints:
+
+- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
+  should be inserted somewhere in Ti.
+
+- If T is undefined, an easy solution is to insert a "match z with (Ci
+  xi1..xipi) => ..." in front of each Ti
+
+- Otherwise, T1..Tn and T must be step by step unified, if some of them
+  diverge, then try to replace the diverging subterm by one of y1..yq or z.
+
+- The main problem is what to do when an existential variables is encountered
+
+let prepare_unif_pb typ cs =
+  let n = cs.cs_nargs in
+  let _,p = decompose_prod_n n typ in
+  let ci = build_dependent_constructor cs in
+  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *)
+  (n, cs.cs_concl_realargs, ci, p)
+
+let eq_operator_lift k (n,n') = function
+  | OpRel p, OpRel p' when p > k & p' > k ->
+      if p < k+n or p' < k+n' then false else p - n = p' - n'
+  | op, op' -> op = op'
+
+let rec transpose_args n =
+  if n=0 then []
+  else
+    (Array.map (fun l -> List.hd l) lv)::
+    (transpose_args (m-1) (Array.init (fun l -> List.tl l)))
+
+let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
+
+let reloc_operator (k,n) = function OpRel p when p > k -> 
+let rec unify_clauses k pv =
+  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in
+  let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
+  if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
+  then
+    let argvl = transpose_args (List.length args1) pv' in
+    let k' = shift_operator k op1 in
+    let argl = List.map (unify_clauses k') argvl in
+    gather_constr (reloc_operator (k,n1) op1) argl
+*)
+
+let abstract_conclusion typ cs =
+  let n = List.length (assums_of_rel_context cs.cs_args) in
+  let (sign,p) = decompose_prod_n n typ in
+  lam_it p sign
+
+let infer_predicate loc env isevars typs cstrs indf =
+  (* Il faudra substituer les isevars a un certain moment *)
+  if Array.length cstrs = 0 then (* "TODO4-3" *)
+    error "Inference of annotation for empty inductive types not implemented"
+  else
+    (* Empiric normalization: p may depend in a irrelevant way on args of the*)
+    (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
+    let typs =
+      Array.map (local_strong (whd_betaevar empty_env (Evd.evars_of !isevars))) typs
+    in
+    let eqns = array_map2 prepare_unif_pb typs cstrs in
+    (* First strategy: no dependencies at all *)
+(*
+    let (mis,_) = dest_ind_family indf in
+    let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
+*)
+    let (sign,_) = get_arity env indf in
+    let mtyp =
+      if array_exists is_Type typs then
+	(* Heuristic to avoid comparison between non-variables algebric univs*)
+	new_Type ()
+      else
+	mkExistential env ~src:(loc, Evd.CasesType) isevars
+    in
+    if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
+    then
+      (* Non dependent case -> turn it into a (dummy) dependent one *)
+      let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
+      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
+      (true,pred) (* true = dependent -- par défaut *)
+    else
+(*
+      let s = get_sort_of env (evars_of isevars) typs.(0) in
+      let predpred = it_mkLambda_or_LetIn (mkSort s) sign in
+      let caseinfo = make_default_case_info mis in
+      let brs = array_map2 abstract_conclusion typs cstrs in
+      let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in
+      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
+*)
+      (* "TODO4-2" *)
+      (* We skip parameters *)
+      let cis = 
+	Array.map
+	  (fun cs ->
+	     applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args))
+	  cstrs in
+      let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in
+      raise_pattern_matching_error (loc,env, CannotInferPredicate ct)
+(*
+      (true,pred)
+*)
+
+(* Propagation of user-provided predicate through compilation steps *)
+
+let rec map_predicate f k = function
+  | PrCcl ccl -> PrCcl (f k ccl)
+  | PrProd pred ->
+      PrProd (map_predicate f (k+1) pred)
+  | PrLetIn ((names,dep as tm),pred) ->
+      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
+      PrLetIn (tm, map_predicate f (k+k') pred)
+
+let rec noccurn_predicate k = function
+  | PrCcl ccl -> noccurn k ccl
+  | PrProd pred -> noccurn_predicate (k+1) pred
+  | PrLetIn ((names,dep),pred) ->
+      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
+      noccurn_predicate (k+k') pred
+
+let liftn_predicate n = map_predicate (liftn n)
+
+let lift_predicate n = liftn_predicate n 1
+
+let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0
+
+let substnl_predicate sigma = map_predicate (substnl sigma)
+
+(* This is parallel bindings *)
+let subst_predicate (args,copt) pred =
+  let sigma = match copt with
+    | None -> List.rev args
+    | Some c -> c::(List.rev args) in
+  substnl_predicate sigma 0 pred
+
+let specialize_predicate_var (cur,typ) = function
+  | PrProd _ | PrCcl _ ->
+     anomaly "specialize_predicate_var: a pattern-variable must be pushed"
+  | PrLetIn (([],dep),pred) ->
+      subst_predicate ([],if dep<>Anonymous then Some cur else None) pred
+  | PrLetIn ((_,dep),pred) ->
+      (match typ with
+        | IsInd (_,IndType (_,realargs)) ->
+           subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred
+        | _ -> anomaly "specialize_predicate_var")
+
+let ungeneralize_predicate = function
+  | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product"
+  | PrProd pred -> pred
+
+(*****************************************************************************)
+(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *)
+(* and we want to abstract P over y:t(x) typed in the same context to get    *)
+(*                                                                           *)
+(*    pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y']                          *)
+(*                                                                           *)
+(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x'        *)
+(* then we have to replace x by x' in t(x) and y by y' in P                  *)
+(*****************************************************************************)
+let generalize_predicate ny d = function
+  | PrLetIn ((names,dep as tm),pred) ->
+      if dep=Anonymous then anomaly "Undetected dependency";
+      let p = List.length names + 1 in
+      let pred = lift_predicate 1 pred in
+      let pred = regeneralize_index_predicate (ny+p+1) pred in
+      PrLetIn (tm, PrProd pred)
+  | PrProd _ | PrCcl _ ->
+      anomaly "generalize_predicate: expects a non trivial pattern"
+
+let rec extract_predicate l = function
+  | pred, Alias (deppat,nondeppat,_,_)::tms ->
+      let tms' = match kind_of_term nondeppat with
+        | Rel i -> replace_tomatch i deppat tms
+        | _ -> (* initial terms are not dependent *) tms in
+      extract_predicate l (pred,tms')
+  | PrProd pred, Abstract d'::tms ->
+      let d' = map_rel_declaration (lift (List.length l)) d' in
+      substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms)))
+  | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms ->
+      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
+  | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms ->
+      let l = List.rev realargs@l in
+      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
+  | PrCcl ccl, [] ->
+      substl l ccl
+  | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match"
+
+let abstract_predicate env sigma indf cur tms = function
+  | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn"
+  | PrLetIn ((names,dep),pred) ->
+      let sign = make_arity_signature env true indf in
+      (* n is the number of real args + 1 *)
+      let n = List.length sign in
+      let tms = lift_tomatch_stack n tms in
+      let tms =
+        match kind_of_term cur with
+          | Rel i -> regeneralize_index_tomatch (i+n) tms
+          | _ -> (* Initial case *) tms in
+      (* Depending on whether the predicate is dependent or not, and has real
+         args or not, we lift it to make room for [sign] *)
+      (* Even if not intrinsically dep, we move the predicate into a dep one *)
+      let sign,k =
+        if names = [] & n <> 1 then
+          (* Real args were not considered *)
+          (if dep<>Anonymous then
+            ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1)
+          else
+            (sign,n))
+        else
+          (* Real args are OK *)
+          (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign,
+           if dep<>Anonymous then 0 else 1) in
+      let pred = lift_predicate k pred in
+      let pred = extract_predicate [] (pred,tms) in
+      (true, it_mkLambda_or_LetIn_name env pred sign)
+
+let rec known_dependent = function
+  | None -> false
+  | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous
+  | Some (PrCcl _) -> false
+  | Some (PrProd _) ->
+      anomaly "known_dependent: can only be used when patterns remain"
+
+(* [expand_arg] is used by [specialize_predicate]
+   it replaces gamma, x1...xn, x1...xk |- pred
+   by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or
+   by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
+
+let expand_arg n alreadydep (na,t) deps (k,pred) =
+  (* current can occur in pred even if the original problem is not dependent *)
+  let dep =
+    if alreadydep<>Anonymous then alreadydep
+    else if deps = [] && noccurn_predicate 1 pred then Anonymous
+    else Name (id_of_string "x") in
+  let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in
+  (* There is no dependency in realargs for subpattern *)
+  (k-1, PrLetIn (([],dep), pred))
+
+
+(*****************************************************************************)
+(* pred = [X:=realargs;x:=c]P types the following problem:                   *)
+(*                                                                           *)
+(*  Gamma |- match Pushed(c:I(realargs)) rest with...end: pred               *)
+(*                                                                           *)
+(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi)      *)
+(* is considered. Assume each Ti is some Ii(argsi).                          *)
+(* We let e=Ci(x1,...,xn) and replace pred by                                *)
+(*                                                                           *)
+(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
+(*                                                                           *)
+(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
+(*                                                                           *)
+(*****************************************************************************)
+let specialize_predicate tomatchs deps cs = function
+  | (PrProd _ | PrCcl _) ->
+      anomaly "specialize_predicate: a matched pattern must be pushed"
+  | PrLetIn ((names,isdep),pred) ->
+      (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
+      let nrealargs = List.length names in
+      let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in
+      (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *)
+      let n = cs.cs_nargs in
+      let pred' = liftn_predicate n (k+1) pred in
+      let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
+      let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in
+      (* The substituends argsi, copti are all defined in gamma, x1...xn *)
+      (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *)
+      let pred'' = subst_predicate (argsi, copti) pred' in
+      (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *)
+      let pred''' = liftn_predicate n (n+1) pred'' in
+      (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
+      snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred'''))
+
+let find_predicate loc env isevars p typs cstrs current
+  (IndType (indf,realargs)) tms =
+  let (dep,pred) =
+    match p with
+      | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p
+      | None -> infer_predicate loc env isevars typs cstrs indf in
+  let typ = whd_beta (applist (pred, realargs)) in
+  if dep then
+    (pred, whd_beta (applist (typ, [current])), new_Type ())
+  else
+    (pred, typ, new_Type ())
+
+(************************************************************************)
+(* Sorting equations by constructor *)
+
+type inversion_problem =
+  (* the discriminating arg in some Ind and its order in Ind *)
+  | Incompatible of int * (int * int)
+  | Constraints of (int * constr) list
+
+let solve_constraints constr_info indt =
+  (* TODO *)
+  Constraints []
+
+let rec irrefutable env = function
+  | PatVar (_,name) -> true
+  | PatCstr (_,cstr,args,_) ->
+      let ind = inductive_of_constructor cstr in
+      let (_,mip) = Inductive.lookup_mind_specif env ind in
+      let one_constr = Array.length mip.mind_user_lc = 1 in
+      one_constr & List.for_all (irrefutable env) args
+
+let first_clause_irrefutable env = function
+  | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
+  | _ -> false
+
+let group_equations pb ind current cstrs mat =
+  let mat =
+    if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
+  let brs = Array.create (Array.length cstrs) [] in
+  let only_default = ref true in
+  let _ =
+    List.fold_right (* To be sure it's from bottom to top *)
+      (fun eqn () ->
+	 let rest = remove_current_pattern eqn in
+	 let pat = current_pattern eqn in
+	 match check_and_adjust_constructor pb.env ind cstrs pat with 
+	   | PatVar (_,name) -> 
+	       (* This is a default clause that we expand *)
+	       for i=1 to Array.length cstrs do
+		 let n = cstrs.(i-1).cs_nargs in
+		 let args = make_anonymous_patvars n in
+		 let rest = {rest with tag = lower_pattern_status rest.tag } in
+		 brs.(i-1) <- (args, rest) :: brs.(i-1)
+	       done
+	   | PatCstr (loc,((_,i)),args,_) ->
+	       (* This is a regular clause *)
+	       only_default := false;
+	       brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
+  (brs,!only_default)
+
+(************************************************************************)
+(* Here starts the pattern-matching compilation algorithm *)
+
+(* Abstracting over dependent subterms to match *)
+let rec generalize_problem pb = function
+  | [] -> pb
+  | i::l ->
+      let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
+      let pb' = generalize_problem pb l in
+      let tomatch = lift_tomatch_stack 1 pb'.tomatch in
+      let tomatch = regeneralize_index_tomatch (i+1) tomatch in
+      { pb with
+	  tomatch = Abstract d :: tomatch;
+          pred = option_map (generalize_predicate i d) pb'.pred }
+
+(* No more patterns: typing the right-hand-side of equations *)
+let build_leaf pb =
+  let tag, rhs = extract_rhs pb in
+  let tycon = match pb.pred with
+    | None -> anomaly "Predicate not found"
+    | Some (PrCcl typ) -> mk_tycon typ
+    | Some _ -> anomaly "not all parameters of pred have been consumed" in
+    tag, pb.typing_function tycon rhs.rhs_env rhs.it
+
+(* Building the sub-problem when all patterns are variables *)
+let shift_problem (current,t) pb =
+  {pb with
+     tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
+     pred = option_map (specialize_predicate_var (current,t)) pb.pred;
+     history = push_history_pattern 0 AliasLeaf pb.history;
+     mat = List.map remove_current_pattern pb.mat }
+
+(* Building the sub-pattern-matching problem for a given branch *)
+let build_branch current deps pb eqns const_info =
+  (* We remember that we descend through a constructor *)
+  let alias_type =
+    if Array.length const_info.cs_concl_realargs = 0
+      & not (known_dependent pb.pred) & deps = []
+    then
+      NonDepAlias
+    else 
+      DepAlias
+  in
+  let history = 
+    push_history_pattern const_info.cs_nargs
+      (AliasConstructor const_info.cs_cstr)
+      pb.history in
+
+  (* We find matching clauses *)
+  let cs_args = (*assums_of_rel_context*) const_info.cs_args in
+  let names = get_names pb.env cs_args eqns in
+  let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in
+  if submat = [] then
+    raise_pattern_matching_error
+      (dummy_loc, pb.env, NonExhaustive (complete_history history));
+  let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
+  let _,typs',_ =
+    List.fold_right
+      (fun (na,c,t as d) (env,typs,tms) ->
+	 let tm1 = List.map List.hd tms in
+	 let tms = List.map List.tl tms in
+ 	 (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms))
+      typs (pb.env,[],List.map fst eqns) in
+
+  let dep_sign =
+    find_dependencies_signature
+      (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in
+
+  (* The dependent term to subst in the types of the remaining UnPushed 
+     terms is relative to the current context enriched by topushs *)
+  let ci = build_dependent_constructor const_info in
+
+  (* We replace [(mkRel 1)] by its expansion [ci] *)
+  (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *)
+  (* This is done in two steps : first from "Gamma |- tms" *)
+  (* into  "Gamma; typs; curalias |- tms" *)
+  let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
+
+  let currents =
+    list_map2_i
+      (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps))
+      1 typs' (List.rev dep_sign) in
+
+  let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in
+  let ind =
+    appvect (
+      applist (mkInd (inductive_of_constructor const_info.cs_cstr),
+      List.map (lift const_info.cs_nargs) const_info.cs_params),
+      const_info.cs_concl_realargs) in
+
+  let cur_alias = lift (List.length sign) current in
+  let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
+  let env' = push_rels sign pb.env in
+  let pred' = option_map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in
+    sign,
+  { pb with
+      env = env';
+      tomatch = List.rev_append currents tomatch;
+      pred = pred';
+      history = history;
+      mat = List.map (push_rels_eqn_with_names sign) submat }
+
+(**********************************************************************
+ INVARIANT:
+
+  pb = { env, subst, tomatch, mat, ...}
+  tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T)
+
+  "Pushed" terms and types are relative to env
+  "Abstract" types are relative to env enriched by the previous terms to match
+
+*)
+
+(**********************************************************************)
+(* Main compiling descent *)
+let rec compile pb =
+  match pb.tomatch with
+    | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur
+    | (Alias x)::rest -> compile_alias pb x rest
+    | (Abstract d)::rest -> compile_generalization pb d rest
+    | [] -> build_leaf pb
+
+and match_current pb tomatch =
+  let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
+  match typ with
+    | NotInd (_,typ) ->
+	check_all_variables typ pb.mat;
+	compile (shift_problem ct pb)
+    | IsInd (_,(IndType(indf,realargs) as indt)) ->
+	let mind,_ = dest_ind_family indf in
+	let cstrs = get_constructors pb.env indf in
+	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
+	if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt  then
+	  compile (shift_problem ct pb)
+	else
+          let _constraints = Array.map (solve_constraints indt) cstrs in
+
+	  (* We generalize over terms depending on current term to match *)
+	  let pb = generalize_problem pb deps in
+
+	  (* We compile branches *)
+	  let brs = array_map2 (compile_branch current deps pb) eqns cstrs in
+
+	  (* We build the (elementary) case analysis *)
+	  let tags   = Array.map (fun (t,_,_) -> t) brs in
+	  let brvals = Array.map (fun (_,v,_) -> v) brs in
+	  let brtyps = Array.map (fun (_,_,t) -> t) brs in
+	  let (pred,typ,s) =
+	    find_predicate pb.caseloc pb.env pb.isevars 
+	      pb.pred brtyps cstrs current indt pb.tomatch in
+	  let ci = make_case_info pb.env mind RegularStyle tags in
+	  let case = mkCase (ci,nf_betaiota pred,current,brvals) in
+	  let inst = List.map mkRel deps in
+	  pattern_status tags,
+	  { uj_val = applist (case, inst);
+	    uj_type = substl inst typ }
+
+and compile_branch current deps pb eqn cstr =
+  let sign, pb = build_branch current deps pb eqn cstr in
+  let tag, j = compile pb in
+  (tag, it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
+
+and compile_generalization pb d rest =
+  let pb =
+    { pb with
+       env = push_rel d pb.env;
+       tomatch = rest;
+       pred = option_map ungeneralize_predicate pb.pred;
+       mat = List.map (push_rels_eqn [d]) pb.mat } in
+  let patstat,j = compile pb in
+  patstat, 
+  { uj_val = mkLambda_or_LetIn d j.uj_val;
+    uj_type = mkProd_or_LetIn d j.uj_type }
+
+and compile_alias pb (deppat,nondeppat,d,t) rest =
+  let history = simplify_history pb.history in
+  let sign, newenv, mat =
+    insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
+  let n = List.length sign in
+
+  (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
+  (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *)
+  let tomatch = lift_tomatch_stack n rest in
+  let tomatch = match kind_of_term nondeppat with
+    | Rel i ->
+	if n = 1 then regeneralize_index_tomatch (i+n) tomatch
+	else replace_tomatch i deppat tomatch
+    | _ -> (* initial terms are not dependent *) tomatch in
+
+  let pb =
+    {pb with
+       env = newenv;
+       tomatch = tomatch;
+       pred = option_map (lift_predicate n) pb.pred;
+       history = history;
+       mat = mat } in
+  let patstat,j = compile pb in
+  patstat, 
+  List.fold_left mkSpecialLetInJudge j sign
+
+(* pour les alias des initiaux, enrichir les env de ce qu'il faut et
+substituer après par les initiaux *)
+
+(**************************************************************************)
+(* Preparation of the pattern-matching problem                            *)
+
+(* builds the matrix of equations testing that each eqn has n patterns
+ * and linearizing the _ patterns.
+ * Syntactic correctness has already been done in astterm *)
+let matx_of_eqns env eqns =
+  let build_eqn (loc,ids,lpat,rhs) =
+    let rhs =
+      { rhs_env = env;
+	avoid_ids = ids@(ids_of_named_context (named_context env));
+	it = rhs;
+      } in
+    { patterns = lpat;
+      tag = RegularPat;
+      alias_stack = [];
+      eqn_loc = loc;
+      used = ref false;
+      rhs = rhs }
+  in List.map build_eqn eqns
+
+(************************************************************************)
+(* preparing the elimination predicate if any                          *)
+
+let build_expected_arity env isevars isdep tomatchl =
+  let cook n = function
+    | _,IsInd (_,IndType(indf,_)) ->
+        let indf' = lift_inductive_family n indf in
+	Some (build_dependent_inductive env indf', fst (get_arity env indf'))
+    | _,NotInd _ -> None
+  in
+  let rec buildrec n env = function
+    | [] -> new_Type ()
+    | tm::ltm ->
+	match cook n tm with
+	  | None -> buildrec n env ltm
+	  | Some (ty1,aritysign) ->
+	      let rec follow n env = function
+		| d::sign ->
+		    mkProd_or_LetIn_name env
+		      (follow (n+1) (push_rel d env) sign) d
+		| [] ->
+		    if isdep then
+		      mkProd (Anonymous, ty1, 
+			      buildrec (n+1)
+				(push_rel_assum (Anonymous, ty1) env)
+				ltm)
+		    else buildrec n env ltm
+	      in follow n env (List.rev aritysign)
+  in buildrec 0 env tomatchl
+
+let extract_predicate_conclusion isdep tomatchl pred =
+  let cook = function
+    | _,IsInd (_,IndType(_,args)) -> Some (List.length args)
+    | _,NotInd _ -> None in
+  let rec decomp_lam_force n l p =
+    if n=0 then (l,p) else
+    match kind_of_term p with
+      | Lambda (na,_,c) -> decomp_lam_force (n-1) (na::l) c
+      | _ -> (* eta-expansion *)
+          let na = Name (id_of_string "x") in
+          decomp_lam_force (n-1) (na::l) (applist (lift 1 p, [mkRel 1])) in
+  let rec buildrec allnames p = function
+    | [] -> (List.rev allnames,p)
+    | tm::ltm ->
+	match cook tm with
+	  | None -> 
+              let p = 
+                (* adjust to a sign containing the NotInd's *)
+                if isdep then lift 1 p else p in
+              let names = if isdep then [Anonymous] else [] in
+              buildrec (names::allnames) p ltm
+	  | Some n ->
+              let n = if isdep then n+1 else n in
+              let names,p = decomp_lam_force n [] p in
+              buildrec (names::allnames) p ltm
+  in buildrec [] pred tomatchl
+
+let set_arity_signature dep n arsign tomatchl pred x =
+  (* avoid is not exhaustive ! *)
+  let rec decomp_lam_force n avoid l p =
+    if n = 0 then (List.rev l,p,avoid) else
+    match p with
+      | RLambda (_,(Name id as na),_,c) -> 
+          decomp_lam_force (n-1) (id::avoid) (na::l) c
+      | RLambda (_,(Anonymous as na),_,c) -> decomp_lam_force (n-1) avoid (na::l) c
+      | _ ->
+          let x = next_ident_away (id_of_string "x") avoid in
+          decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
+          (* eta-expansion *)
+            (let a = RVar (dummy_loc,x) in
+             match p with
+               | RApp (loc,p,l) -> RApp (loc,p,l@[a])
+               | _ -> (RApp (dummy_loc,p,[a]))) in
+  let rec decomp_block avoid p = function
+    | ([], _) -> x := Some p
+    | ((_,IsInd (_,IndType(indf,realargs)))::l),(y::l')  ->
+	let (ind,params) = dest_ind_family indf in
+        let (nal,p,avoid') = decomp_lam_force (List.length realargs) avoid [] p 
+        in
+        let na,p,avoid' = 
+          if dep then decomp_lam_force 1 avoid' [] p else [Anonymous],p,avoid'
+        in 
+        y :=
+        (List.hd na,
+         if List.for_all ((=) Anonymous) nal then
+           None
+         else
+           Some (dummy_loc, ind, (List.map (fun _ -> Anonymous) params)@nal));
+        decomp_block avoid' p (l,l')
+    | (_::l),(y::l') ->
+        y := (Anonymous,None);
+        decomp_block avoid p (l,l')
+    | _ -> anomaly "set_arity_signature"
+  in
+  decomp_block [] pred (tomatchl,arsign)
+
+let prepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
+  let cook (n, l, env, signs) = function
+    | c,IsInd (_,IndType(indf,realargs)) ->
+	let indf' = lift_inductive_family n indf in
+	let sign = make_arity_signature env dep indf' in
+	let p = List.length realargs in
+	if dep then
+	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
+	else
+	  (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
+    | c,NotInd _ ->
+	(n, l, env, []::signs) in
+  let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
+  let names = List.rev (List.map (List.map pi1) signs) in
+  let allargs =
+    List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in
+  let rec build_skeleton env c =
+    (* Don't put into normal form, it has effects on the synthesis of evars *)
+ (* let c = whd_betadeltaiota env (evars_of isevars) c in *)
+    (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
+    if isEvar c or List.exists (eq_constr c) allargs then
+      e_new_evar isevars env  ~src:(loc, Evd.CasesType)
+        (Retyping.get_type_of env (Evd.evars_of !isevars) c)
+    else
+      map_constr_with_full_binders push_rel build_skeleton env c 
+  in
+    names, build_skeleton env (lift n c)
+  
+(* Here, [pred] is assumed to be in the context built from all *)
+(* realargs and terms to match *)
+let build_initial_predicate isdep allnames pred =
+  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
+  let rec buildrec n pred = function
+    | [] -> PrCcl pred
+    | names::lnames ->
+        let names' = if isdep then List.tl names else names in
+        let n' = n + List.length names' in
+        let pred, p, user_p =
+          if isdep then 
+            if dependent (mkRel (nar-n')) pred then pred, 1, 1
+            else liftn (-1) (nar-n') pred, 0, 1
+          else pred, 0, 0 in
+        let na =
+          if p=1 then
+            let na = List.hd names in
+            if na = Anonymous then
+              (* peut arriver en raison des evars *)
+              Name (id_of_string "x") (*Hum*)
+            else na
+          else Anonymous in
+        PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
+  in buildrec 0 pred allnames
+
+let extract_arity_signature env0 tomatchl tmsign =
+  let get_one_sign n tm (na,t) =
+    match tm with
+      | NotInd (bo,typ) -> 
+	  (match t with
+	    | None -> [na,option_map (lift n) bo,lift n typ]
+	    | Some (loc,_,_,_) -> 
+ 	    user_err_loc (loc,"",
+	    str "Unexpected type annotation for a term of non inductive type"))
+      | IsInd (_,IndType(indf,realargs)) ->
+          let indf' = lift_inductive_family n indf in
+	  let (ind,params) = dest_ind_family indf' in
+	  let nrealargs = List.length realargs in
+	  let realnal =
+	    match t with
+	      | Some (loc,ind',nparams,realnal) ->
+		  if ind <> ind' then
+		    user_err_loc (loc,"",str "Wrong inductive type");
+		  if List.length params <> nparams
+		    or nrealargs <> List.length realnal then
+		      anomaly "Ill-formed 'in' clause in cases";
+		  List.rev realnal
+	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
+	  let arsign = fst (get_arity env0 indf') in
+	  (na,None,build_dependent_inductive env0 indf')
+	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
+  let rec buildrec n = function
+    | [],[] -> []
+    | (_,tm)::ltm, x::tmsign ->
+	let l = get_one_sign n tm x in
+	l :: buildrec (n + List.length l) (ltm,tmsign)
+    | _ -> assert false
+  in List.rev (buildrec 0 (tomatchl,tmsign))
+
+let inh_conv_coerce_to_tycon loc env isevars j tycon =
+  match tycon with
+    | Some p ->
+	let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in
+          isevars := evd';
+          j
+    | None -> j
+
+let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false)
+  
+let list_mapi f l = 
+  let rec aux n = function
+      [] -> []
+    | hd :: tl -> f n hd :: aux (succ n) tl
+  in aux 0 l
+
+let constr_of_pat env isevars ty pat idents = 
+  let rec typ env ty pat idents = 
+    trace (str "Typing pattern " ++ Printer.pr_cases_pattern pat ++ str " in env " ++
+	     print_env env ++ str" should have type: " ++ my_print_constr env ty);
+    match pat with
+    | PatVar (l,name) -> 
+	let name, idents' = match name with
+	    Name n -> name, idents
+	  | Anonymous -> 
+	      let n' = next_ident_away_from (id_of_string "wildcard") idents in
+		Name n', n' :: idents
+	in
+(* 	  trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name name))); *)
+	  PatVar (l, name), [name, None, ty], mkRel 1, 1, idents'
+    | PatCstr (l,((_, i) as cstr),args,alias) ->
+	let _ind = inductive_of_constructor cstr in
+	let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) ty in
+	let ind, params = dest_ind_family indf in
+	let cstrs = get_constructors env indf in
+	let ci = cstrs.(i-1) in
+	let nb_args_constr = ci.cs_nargs in
+	assert(nb_args_constr = List.length args);
+	let idents' = idents in
+	let patargs, args, sign, env, n, m, idents' = 
+	  List.fold_right2
+	    (fun (na, c, t) ua (patargs, args, sign, env, n, m, idents)  ->
+	       let pat', sign', arg', n', idents' = typ env (lift (n - m) t) ua idents in
+	       let args' = arg' :: List.map (lift n') args in
+	       let env' = push_rels sign' env in
+		 (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, idents'))
+	    ci.cs_args (List.rev args) ([], [], [], env, 0, 0, idents')
+	in
+	let args = List.rev args in
+	let patargs = List.rev patargs in
+	let pat' = PatCstr (l, cstr, patargs, alias) in
+	let cstr = mkConstruct ci.cs_cstr in
+	let app = applistc cstr (List.map (lift (List.length sign)) params) in
+	let app = applistc app args in
+(* 	  trace (str "New pattern: " ++ Printer.pr_cases_pattern pat'); *)
+(* 	let alname = if alias <> Anonymous then alias else Name (id_of_string "anon") in *)
+(* 	let al = alname, Some (mkRel 1), lift 1 ty in *)
+	  if alias <> Anonymous then
+	    pat', (alias, Some app, ty) :: sign, lift 1 app, n + 1, idents'
+	  else pat', sign, app, n, idents'
+  in 
+  let pat', sign, y, z, idents = typ env ty pat idents in 
+  let c = it_mkProd_or_LetIn y sign in
+    trace (str "Constr_of_pat gives: " ++ my_print_constr env c);
+    pat', (sign, y), idents
+
+let mk_refl typ a = mkApp (Lazy.force eq_refl, [| typ; a |])
+
+let vars_of_ctx = 
+  List.rev_map (fun (na, _, t) -> 
+	      match na with
+		  Anonymous -> raise (Invalid_argument "vars_of_ctx")
+		| Name n -> RVar (dummy_loc, n))
+
+(*let build_ineqs eqns pats = 
+  List.fold_left 
+    (fun (sign, c) eqn -> 
+       let acc = fold_left3
+	 (fun acc prevpat (ppat_sign, ppat_c, ppat_ty) (pat, pat_c) ->
+	    match acc with
+		None -> None
+	      | Some (sign,len, c) ->
+		  if is_included pat prevpat then
+		    let lens = List.length ppat_sign in
+		    let acc = 
+		      (lift_rels lens ppat_sign @ sign, 
+		       lens + len,
+		       mkApp (Lazy.force eq_ind,
+			      [| ppat_ty ; ppat_c ; 
+				 lift (lens + len) pat_c |]) :: c)
+		    in Some acc
+		  else None)
+	 (sign, c) eqn.patterns eqn.c_patterns pats
+       in match acc with 
+	   None -> (sign, c)
+	 | Some (sign, len, c) ->
+	     it_mkProd_or_LetIn c sign
+	     
+    )
+    ([], []) eqns*)
+
+let constrs_of_pats typing_fun tycon env isevars eqns tomatchs =
+  let i = ref 0 in
+  List.fold_left
+    (fun (branches, eqns) eqn ->
+       let _, newpatterns, pats = 
+	 List.fold_right2 (fun pat (_, ty) (idents, newpatterns, pats) -> 
+			    let x, y, z = constr_of_pat env isevars (type_of_tomatch ty) pat idents in
+			      (z, x :: newpatterns, y :: pats)) 
+	   eqn.patterns tomatchs ([], [], [])
+       in
+       let rhs_rels, signlen = 
+	 List.fold_left (fun (renv, n) (sign,_) -> 
+			   ((lift_rel_context n sign) @ renv, List.length sign + n)) 
+	   ([], 0) pats in
+       let eqs, _, _ = List.fold_left2 
+	 (fun (eqs, n, slen) (sign, c) (tm, ty) -> 
+	    let len = n + signlen in (* Number of already defined equations + signature *)
+	    let csignlen = List.length sign in
+	    let slen' = slen - csignlen in (* Lift to get pattern variables signature *)	      
+	    let c = liftn (signlen - slen) signlen c in (* Lift to jump over previous ind signatures for pattern variables outside sign 
+							in c (e.g. type arguments of constructors instanciated by variables ) *)
+	    let cstr = lift (slen' + n) c in
+(* 	      trace (str "lift " ++ my_print_constr (push_rels sign env) c ++ *)
+(* 		       str " by " ++ int  ++ str " to get " ++ *)
+(* 		       my_print_constr (push_rels sign env) cstr); *)
+	    let app = 
+	      mkApp (Lazy.force eq_ind, 
+		     [| lift len (type_of_tomatch ty); cstr; lift len tm |])
+	    in app :: eqs, succ n, slen')
+	 ([], 0, signlen) pats tomatchs
+       in
+       let eqs_rels = List.map (fun eq -> Name (id_of_string "H"), None, eq) eqs in
+(*        let ineqs = build_ineqs eqns newpatterns in *)
+       let rhs_rels' = eqs_rels @ rhs_rels in
+       let rhs_env = push_rels rhs_rels' env in
+(*        (try trace (str "branch env: " ++ print_env rhs_env) *)
+(* 	with _ -> trace (str "error in print branch env")); *)
+       let tycon = lift_tycon (List.length eqs + signlen) tycon in
+	 
+       let j = typing_fun tycon rhs_env eqn.rhs.it in
+(* 	 (try trace (str "in env: " ++ my_print_env rhs_env ++ str"," ++ *)
+(* 		       str "Typed branch: " ++ Prettyp.print_judgment rhs_env j); *)
+(* 	  with _ -> *)
+(* 	    trace (str "Error in typed branch pretty printing")); *)
+	 let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels'
+	 and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
+	 let branch_name = id_of_string ("branch_" ^ (string_of_int !i)) in
+	 let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
+(* 	 (try trace (str "Branch decl: " ++ pr_rel_decl env (Name branch_name, Some bbody, btype)) *)
+(* 	  with _ -> trace (str "Error in branch decl pp")); *)
+	 let branch = 
+	   let bref = RVar (dummy_loc, branch_name) in
+	   match vars_of_ctx rhs_rels with
+	       [] -> bref
+	     | l -> RApp (dummy_loc, bref, l)
+	 in
+(* 	 let branch =  *)
+(* 	   List.fold_left (fun br (eqH, _, t) -> RLambda (dummy_loc, eqH, RHole (dummy_loc, Evd.InternalHole), br)) branch eqs_rels *)
+(* 	 in *)
+(* 	 (try trace (str "New branch: " ++ Printer.pr_rawconstr branch) *)
+(* 	  with _ -> trace (str "Error in new branch pp")); *)
+	 incr i;
+	 let rhs = { eqn.rhs with it = branch } in
+	   (branch_decl :: branches,
+	    { eqn with patterns = newpatterns; rhs = rhs } :: eqns))
+    ([], []) eqns
+    
+
+(* 		   liftn_rel_declaration *)
+
+
+(* Builds the predicate. If the predicate is dependent, its context is
+ * made of 1+nrealargs assumptions for each matched term in an inductive
+ * type and 1 assumption for each term not _syntactically_ in an
+ * inductive type.
+
+ * Each matched terms are independently considered dependent or not.
+
+ * A type constraint but no annotation case: it is assumed non dependent.
+ *)
+
+let prepare_predicate_from_tycon loc typing_fun isevars env tomatchs arsign tycon = 
+  (* We extract the signature of the arity *)
+(*   List.iter *)
+(*       (fun arsign ->  *)
+(* 	 trace (str "arity signature: " ++ my_print_rel_context env arsign)) *)
+(*     arsign; *)
+(*   let env = List.fold_right push_rels arsign env in *)
+  let allnames = List.rev (List.map (List.map pi1) arsign) in
+  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
+  let pred = out_some (valcon_of_tycon tycon) in
+  let predcclj, pred, neqs = 
+    let _, _, eqs = 
+      List.fold_left2
+	(fun (neqs, slift, eqs) ctx (tm,ty) ->
+	   let len = List.length ctx in
+	   let _name, _, _typ' = List.hd ctx in (* FixMe: Ignoring dependent inductives *)
+	   let eq = mkApp (Lazy.force eq_ind, 
+			   [| lift (neqs + nar) (type_of_tomatch ty); 
+			      mkRel (neqs + slift);
+			      lift (neqs + nar) tm|]) 
+	   in
+	     (succ neqs, slift - len, (Anonymous, None, eq) :: eqs))
+	(0, nar, []) (List.rev arsign) tomatchs
+    in
+    let len = List.length eqs in
+      it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len
+  in
+  let predccl = nf_isevar !isevars predcclj in
+(*   let env' = List.fold_right push_rel_context arsign env in *)
+(*     trace (str " Env:" ++ my_print_env env' ++ str" Predicate: " ++ my_print_constr env' predccl); *)
+    build_initial_predicate true allnames predccl, pred
+    
+let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp =
+  (* We extract the signature of the arity *)
+  let arsign = extract_arity_signature env tomatchs sign in
+  let env = List.fold_right push_rels arsign env in
+  let allnames = List.rev (List.map (List.map pi1) arsign) in
+  let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in
+(*   let _ =  *)
+(*     option_map (fun tycon ->  *)
+(* 		  isevars := Coercion.inh_conv_coerces_to loc env !isevars predcclj.uj_val  *)
+(* 		    (lift_tycon_type (List.length arsign) tycon)) *)
+(*       tycon *)
+(*   in *)
+  let predccl = (j_nf_isevar !isevars predcclj).uj_val in      
+    Some (build_initial_predicate true allnames predccl)
+  
+let lift_ctx n ctx = 
+  let ctx', _ =
+    List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0)
+  in ctx'
+
+(* Turn matched terms into variables. *)
+let abstract_tomatch env tomatchs =
+  let prev, ctx, names = 
+    List.fold_left
+      (fun (prev, ctx, names) (c, t) ->
+	 let lenctx =  List.length ctx in
+	 match kind_of_term c with
+	     Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names
+	   | _ -> 
+	       let name = next_ident_away_from (id_of_string "filtered_var") names in
+		 (mkRel 1, lift_tomatch_type 1 t) :: lift_ctx 1 prev, 
+	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, 
+	       name :: names)
+      ([], [], []) tomatchs
+  in List.rev prev, ctx
+    
+(**************************************************************************)
+(* Main entry of the matching compilation                                 *)
+  
+let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns)=
+  let tycon0 = tycon in
+  (* We build the matrix of patterns and right-hand-side *)
+  let matx = matx_of_eqns env eqns in
+     
+  (* We build the vector of terms to match consistently with the *)
+  (* constructors found in patterns *)
+  let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
+  let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in
+  let tomatchs_len = List.length tomatchs_lets in
+  let tycon = lift_tycon tomatchs_len tycon in
+  let env = push_rel_context tomatchs_lets env in
+    match predopt with
+	None ->	  
+	  let lets, matx = constrs_of_pats typing_fun tycon env isevars matx tomatchs in
+	  let matx = List.rev matx in
+	  let len = List.length lets in
+	  let sign = 
+	    let arsign = extract_arity_signature env tomatchs (List.map snd tomatchl) in
+	      List.map (lift_rel_context len) arsign
+	  in
+	  let env = push_rels lets env in	      
+	  let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in
+	  let tycon = lift_tycon len tycon in
+	  let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in
+	  let args = List.map (fun (tm,ty) -> mk_refl (type_of_tomatch ty) tm) tomatchs in
+	    
+	  (* We build the elimination predicate if any and check its consistency *)
+	  (* with the type of arguments to match *)
+	  let pred, opred = prepare_predicate_from_tycon loc typing_fun isevars env tomatchs sign tycon in
+	  (* We push the initial terms to match and push their alias to rhs' envs *)
+	  (* names of aliases will be recovered from patterns (hence Anonymous here) *)
+	  let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
+	    
+	  let pb =
+	    { env      = env;
+	      isevars  = isevars;
+	      pred     = Some pred;
+	      tomatch  = initial_pushed;
+	      history  = start_history (List.length initial_pushed);
+	      mat      = matx;
+	      caseloc  = loc;
+	      typing_function = typing_fun } in
+	    
+	  let _, j = compile pb in
+	    (* We check for unused patterns *)
+	    List.iter (check_unused_pattern env) matx;
+	    let ty = out_some (valcon_of_tycon tycon0) in
+	    let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in
+	    let j = 
+	      { uj_val = it_mkLambda_or_LetIn body tomatchs_lets;
+		uj_type = ty; }
+	    in
+	      inh_conv_coerce_to_tycon loc env isevars j tycon0
+
+      | Some rtntyp ->
+	  (* We build the elimination predicate if any and check its consistency *)
+	  (* with the type of arguments to match *)
+	  let tmsign = List.map snd tomatchl in
+	  let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon rtntyp in
+	    
+	  (* We push the initial terms to match and push their alias to rhs' envs *)
+	  (* names of aliases will be recovered from patterns (hence Anonymous here) *)
+	  let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
+	    
+	  let pb =
+	    { env      = env;
+	      isevars  = isevars;
+	      pred     = pred;
+	      tomatch  = initial_pushed;
+	      history  = start_history (List.length initial_pushed);
+	      mat      = matx;
+	      caseloc  = loc;
+	      typing_function = typing_fun } in
+	    
+	  let _, j = compile pb in
+	  (* We check for unused patterns *)
+	  List.iter (check_unused_pattern env) matx;
+	  let j = { j with uj_val = it_mkLambda_or_LetIn j.uj_val tomatchs_lets } in
+	    inh_conv_coerce_to_tycon loc env isevars j tycon	  
+
+end
+  
diff --git a/contrib/subtac/subtac_cases.mli b/contrib/subtac/subtac_cases.mli
new file mode 100644
index 00000000..9e902126
--- /dev/null
+++ b/contrib/subtac/subtac_cases.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  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: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Evd
+open Environ
+open Inductiveops
+open Rawterm
+open Evarutil
+(*i*)
+
+type pattern_matching_error =
+  | BadPattern of constructor * constr
+  | BadConstructor of constructor * inductive
+  | WrongNumargConstructor of constructor * int
+  | WrongNumargInductive of inductive * int
+  | WrongPredicateArity of constr * constr * constr
+  | NeedsInversion of constr * constr
+  | UnusedClause of cases_pattern list
+  | NonExhaustive of cases_pattern list
+  | CannotInferPredicate of (constr * types) array
+
+exception PatternMatchingError of env * pattern_matching_error
+
+val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a
+
+val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a
+
+(*s Compilation of pattern-matching. *)
+
+module type S = sig
+  val compile_cases :
+    loc ->
+    (type_constraint -> env -> rawconstr -> unsafe_judgment) * evar_defs ref ->
+    type_constraint -> 
+    env -> rawconstr option * tomatch_tuple * cases_clauses ->
+    unsafe_judgment
+end
+
+module Cases_F(C : Coercion.S) : S
diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml
new file mode 100644
index 00000000..3613ec4f
--- /dev/null
+++ b/contrib/subtac/subtac_coercion.ml
@@ -0,0 +1,527 @@
+(************************************************************************)
+(*  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: subtac_coercion.ml 9563 2007-01-31 09:37:18Z msozeau $ *)
+
+open Util
+open Names
+open Term
+open Reductionops
+open Environ
+open Typeops
+open Pretype_errors
+open Classops
+open Recordops
+open Evarutil
+open Evarconv
+open Retyping
+open Evd
+
+open Global
+open Subtac_utils
+open Coqlib
+open Printer
+open Subtac_errors
+open Context
+open Eterm
+open Pp
+
+let pair_of_array a = (a.(0), a.(1))
+let make_name s = Name (id_of_string s)
+
+module Coercion = struct
+
+  exception NoSubtacCoercion
+
+  let rec disc_subset x = 
+    match kind_of_term x with
+      | App (c, l) ->
+	  (match kind_of_term c with
+	       Ind i ->
+		 let len = Array.length l in
+		 let sig_ = Lazy.force sig_ in
+		   if len = 2 && i = Term.destInd sig_.typ
+		   then
+		     let (a, b) = pair_of_array l in
+		       Some (a, b)
+		   else None
+	     | _ -> None)
+      | _ -> None
+	  
+  and disc_exist env x =
+    match kind_of_term x with
+      | App (c, l) ->
+	  (match kind_of_term c with
+	       Construct c ->	       
+		 if c = Term.destConstruct (Lazy.force sig_).intro
+		 then Some (l.(0), l.(1), l.(2), l.(3))
+		 else None
+	     | _ -> None)
+      | _ -> None
+
+
+  let disc_proj_exist env x =
+    match kind_of_term x with
+      | App (c, l) ->
+	  (if Term.eq_constr c (Lazy.force sig_).proj1 
+	     && Array.length l = 3 
+	   then disc_exist env l.(2)
+	   else None)
+      | _ -> None
+
+
+  let sort_rel s1 s2 = 
+    match s1, s2 with
+	Prop Pos, Prop Pos -> Prop Pos
+      | Prop Pos, Prop Null -> Prop Null
+      | Prop Null, Prop Null -> Prop Null
+      | Prop Null, Prop Pos -> Prop Pos
+      | Type _, Prop Pos -> Prop Pos
+      | Type _, Prop Null -> Prop Null
+      | _, Type _ -> s2
+
+  let hnf env isevars c = whd_betadeltaiota env (evars_of !isevars) c
+
+  let rec mu env isevars t =   
+    let isevars = ref isevars in
+    let rec aux v = 
+      let v = hnf env isevars v in
+      match disc_subset v with
+	  Some (u, p) -> 
+	    let f, ct = aux u in
+	      (Some (fun x ->		   
+		       app_opt f (mkApp ((Lazy.force sig_).proj1, 
+					 [| u; p; x |]))),
+	       ct)
+	| None -> (None, v)
+    in aux t
+
+  and coerce loc env isevars (x : Term.constr) (y : Term.constr) 
+      : (Term.constr -> Term.constr) option 
+      =
+    let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in
+(*       (try debug 1 (str "Coerce called for " ++ (my_print_constr env x) ++  *)
+(* 		  str " and "++ my_print_constr env y ++  *)
+(* 		  str " with evars: " ++ spc () ++ *)
+(* 		  my_print_evardefs !isevars); *)
+(*        with _ -> ()); *)
+    let rec coerce_unify env x y =
+(*       (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++  *)
+(* 		  str " to "++ my_print_constr env y) *)
+(*        with _ -> ()); *)
+      try 
+	isevars := the_conv_x_leq env x y !isevars;
+(* 	(try debug 1 (str "Unified " ++ (my_print_constr env x) ++  *)
+(* 			str " and "++ my_print_constr env y); *)
+(* 	 with _ -> ()); *)
+	None
+      with Reduction.NotConvertible -> coerce' env (hnf env isevars x) (hnf env isevars y)
+    and coerce' env x y : (Term.constr -> Term.constr) option =
+      let subco () = subset_coerce env isevars x y in
+(* 	(try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++  *)
+(* 		    str " to "++ my_print_constr env y); *)
+(* 	 with _ -> ()); *)
+	match (kind_of_term x, kind_of_term y) with
+	  | Sort s, Sort s' -> 
+	      (match s, s' with
+		   Prop x, Prop y when x = y -> None
+		 | Prop _, Type _ -> None
+		 | Type x, Type y when x = y -> None (* false *)
+		 | _ -> subco ())
+	  | Prod (name, a, b), Prod (name', a', b') ->
+	      let name' = Name (Nameops.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
+	      let env' = push_rel (name', None, a') env in
+	      let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
+	      let c2 = coerce_unify env' b b' in
+		(match c1, c2 with
+		     None, None -> failwith "subtac.coerce': Should have detected equivalence earlier"
+		   | _, _ ->
+		       Some
+			 (fun f -> 
+			    mkLambda (name', a',
+				      app_opt c2
+					(mkApp (Term.lift 1 f, 
+						[| app_opt c1 (mkRel 1) |])))))
+		  
+	  | App (c, l), App (c', l') ->
+	      (match kind_of_term c, kind_of_term c' with
+		   Ind i, Ind i' -> (* Sigma types *)
+		     let len = Array.length l in
+		     let existS = Lazy.force existS in
+		     let prod = Lazy.force prod in
+		       if len = Array.length l' && len = 2 && i = i'
+			 && (i = Term.destInd existS.typ || i = Term.destInd prod.typ)
+		       then 
+			 if i = Term.destInd existS.typ 
+			 then
+			   begin 
+			     let (a, pb), (a', pb') = 
+			       pair_of_array l, pair_of_array l' 
+			     in
+			     let c1 = coerce_unify env a a' in
+			     let rec remove_head a c = 
+			       match kind_of_term c with 
+				 | Lambda (n, t, t') -> c, t'
+				     (*| Prod (n, t, t') -> t'*)
+				 | Evar (k, args) ->
+				     let (evs, t) = Evarutil.define_evar_as_lambda !isevars (k,args) in
+				       isevars := evs;
+				       let (n, dom, rng) = destLambda t in
+				       let (domk, args) = destEvar dom in
+					 isevars := evar_define domk a !isevars;
+					 t, rng
+				 | _ -> raise NoSubtacCoercion
+			     in
+			     let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
+			     let env' = push_rel (make_name "x", None, a) env in
+			     let c2 = coerce_unify env' b b' in
+			       match c1, c2 with
+				   None, None -> 
+				     None
+				 | _, _ ->
+				     Some 
+				       (fun x ->
+					  let x, y = 
+					    app_opt c1 (mkApp (existS.proj1,
+							       [| a; pb; x |])),
+					    app_opt c2 (mkApp (existS.proj2, 
+							       [| a; pb; x |]))
+					  in
+					    mkApp (existS.intro, [| a'; pb'; x ; y |]))
+			   end
+			 else 
+			   begin 
+			     let (a, b), (a', b') = 
+			       pair_of_array l, pair_of_array l' 
+			     in
+			     let c1 = coerce_unify env a a' in
+			     let c2 = coerce_unify env b b' in
+			       match c1, c2 with
+				   None, None -> None
+				 | _, _ ->
+				     Some 
+				       (fun x ->
+					  let x, y = 
+					    app_opt c1 (mkApp (prod.proj1,
+							       [| a; b; x |])),
+					    app_opt c2 (mkApp (prod.proj2, 
+							       [| a; b; x |]))
+					  in
+					    mkApp (prod.intro, [| a'; b'; x ; y |]))
+			   end
+		       else
+			 (* if len = 1 && len = Array.length l' && i = i' then *)
+(* 			   let argx, argy = l.(0), l'.(0) in *)
+(* 			   let indtyp = Inductiveops.type_of_inductive env i in *)
+(* 			   let argname, argtype, _ = destProd indtyp in *)
+(* 			   let eq = *)
+(* 			     mkApp (Lazy.force eqind, [| argtype; argx; argy |]) *)
+(* 			   in *)
+(* 			   let pred = mkLambda (argname, argtype,  *)
+(* 						mkApp (mkInd i, [| mkRel 1 |])) *)
+(* 			   in *)
+(* 			   let evar = make_existential dummy_loc env isevars eq in *)
+(* 			     Some (fun x -> *)
+(* 				     mkApp (Lazy.force eqrec,  *)
+(* 					    [| argtype; argx; pred; x; argy; evar |])) *)
+(* 			 else  *)subco ()
+		 | x, y when x = y ->
+		     let lam_type = Typing.type_of env (evars_of !isevars) c in
+		     let rec coerce typ i co =
+		       if i < Array.length l then
+			 let hdx = l.(i) and hdy = l'.(i) in
+			 let (n, eqT, restT) = destProd typ in
+			 let pred = mkLambda (n, eqT, mkApp (lift 1 c, [| mkRel 1 |])) in
+			 let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in
+			 let evar = make_existential dummy_loc env isevars eq in
+			 let eq_app x = mkApp (Lazy.force eq_rect,
+					       [| eqT; hdx; pred; x; hdy; evar|])
+			 in 
+			   coerce (subst1 hdy restT) (succ i) (fun x -> eq_app (co x))
+		       else co
+		     in
+		       if Array.length l = Array.length l' then (
+			 trace (str"Inserting coercion at application");
+			 Some (coerce lam_type 0 (fun x -> x))
+		       ) else subco ()
+		 | _ -> subco ())
+	  | _, _ ->  subco ()
+
+    and subset_coerce env isevars x y =
+      match disc_subset x with
+	  Some (u, p) -> 
+	    (* trace (str "Inserting projection ");	     *)
+	    let c = coerce_unify env u y in
+	    let f x = 
+	      app_opt c (mkApp ((Lazy.force sig_).proj1, 
+				[| u; p; x |]))
+	    in Some f
+	| None ->
+	    match disc_subset y with
+		Some (u, p) ->
+		  let c = coerce_unify env x u in
+		    Some 
+		      (fun x ->
+			 let cx = app_opt c x in
+			 let evar = make_existential dummy_loc env isevars (mkApp (p, [| cx |]))
+			 in
+			   (mkApp 
+			      ((Lazy.force sig_).intro, 
+			       [| u; p; cx; evar |])))
+	      | None -> 
+		  raise NoSubtacCoercion
+		    (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars;
+		  None*)
+    in coerce_unify env x y
+
+  let coerce_itf loc env isevars v t c1 =
+    let evars = ref isevars in
+    let coercion = coerce loc env evars t c1 in
+      !evars, option_map (app_opt coercion) v, t
+	
+  (* Taken from pretyping/coercion.ml *)
+
+  (* Typing operations dealing with coercions *)
+
+  let class_of1 env sigma t = class_of env sigma (nf_evar sigma t)
+
+  (* Here, funj is a coercion therefore already typed in global context *)
+  let apply_coercion_args env argl funj =
+    let rec apply_rec acc typ = function
+      | [] -> { uj_val = applist (j_val funj,argl);
+		uj_type = typ }
+      | h::restl ->
+	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
+  	  match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
+	    | Prod (_,c1,c2) -> 
+		(* Typage garanti par l'appel à app_coercion*)
+		apply_rec (h::acc) (subst1 h c2) restl
+	    | _ -> anomaly "apply_coercion_args"
+    in 
+      apply_rec [] funj.uj_type argl
+
+  (* appliquer le chemin de coercions de patterns p *)
+  exception NoCoercion
+
+  let apply_pattern_coercion loc pat p =
+    List.fold_left
+      (fun pat (co,n) ->
+	 let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
+	   Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
+      pat p
+
+  (* raise Not_found if no coercion found *)
+  let inh_pattern_coerce_to loc pat ind1 ind2 =
+    let i1 = inductive_class_of ind1 in
+    let i2 = inductive_class_of ind2 in
+    let p = lookup_pattern_path_between (i1,i2) in
+      apply_pattern_coercion loc pat p
+
+  (* appliquer le chemin de coercions p à hj *)
+
+  let apply_coercion env p hj typ_cl =
+    try 
+      fst (List.fold_left
+             (fun (ja,typ_cl) i -> 
+		let fv,isid = coercion_value i in
+		let argl = (class_args_of typ_cl)@[ja.uj_val] in
+		let jres = apply_coercion_args env argl fv in
+		  (if isid then 
+		     { uj_val = ja.uj_val; uj_type = jres.uj_type }
+		   else 
+		     jres),
+		jres.uj_type)
+             (hj,typ_cl) p)
+    with _ -> anomaly "apply_coercion"
+
+  let inh_app_fun env isevars j = 
+    let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+      match kind_of_term t with
+	| Prod (_,_,_) -> (isevars,j)
+	| Evar ev when not (is_defined_evar isevars ev) ->
+	    let (isevars',t) = define_evar_as_arrow isevars ev in
+	      (isevars',{ uj_val = j.uj_val; uj_type = t })
+	| _ ->
+       	    (try
+ 	       let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
+      	       let p = lookup_path_to_fun_from i1 in
+		 (isevars,apply_coercion env p j t)
+	     with Not_found ->
+	       try 
+		 let coercef, t = mu env isevars t in
+		   (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t })
+	       with NoSubtacCoercion | NoCoercion ->
+		 (isevars,j))
+
+  let inh_tosort_force loc env isevars j =
+    try
+      let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
+      let p = lookup_path_to_sort_from i1 in
+      let j1 = apply_coercion env p j t in 
+	(isevars,type_judgment env (j_nf_evar (evars_of isevars) j1))
+    with Not_found ->
+      error_not_a_type_loc loc env (evars_of isevars) j
+
+  let inh_coerce_to_sort loc env isevars j =
+    let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+      match kind_of_term typ with
+	| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
+	| Evar ev when not (is_defined_evar isevars ev) ->
+	    let (isevars',s) = define_evar_as_sort isevars ev in
+	      (isevars',{ utj_val = j.uj_val; utj_type = s })
+	| _ ->
+	    inh_tosort_force loc env isevars j
+
+  let inh_coerce_to_base loc env isevars j =
+    let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+    let ct, typ' = mu env isevars typ in
+      isevars, { uj_val = app_opt ct j.uj_val; 
+		 uj_type = typ' }
+
+
+  let inh_coerce_to_fail env isevars c1 v t =
+    let v', t' =
+      try 
+	let t1,i1 = class_of1 env (evars_of isevars) c1 in
+	let t2,i2 = class_of1 env (evars_of isevars) t in
+	let p = lookup_path_between (i2,i1) in
+	  match v with
+	      Some v -> 
+		let j = apply_coercion env p {uj_val = v; uj_type = t} t2 in
+		  Some j.uj_val, j.uj_type
+	    | None -> None, t
+      with Not_found -> raise NoCoercion 
+    in
+      try (the_conv_x_leq env t' c1 isevars, v', t')
+      with Reduction.NotConvertible -> raise NoCoercion
+
+  let rec inh_conv_coerce_to_fail loc env isevars v t c1 =
+(*     (try *)
+(*        debug 1 (str "inh_conv_coerce_to_fail called for " ++ *)
+(* 	      Termops.print_constr_env env t ++ str " and "++ spc () ++ *)
+(* 	      Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++ *)
+(* 	      Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
+(* 	      Termops.print_env env); *)
+(*      with _ -> ()); *)
+    try (the_conv_x_leq env t c1 isevars, v, t)
+    with Reduction.NotConvertible ->
+      (try 
+	 inh_coerce_to_fail env isevars c1 v t
+	 with NoCoercion ->
+	   (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
+	      kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with
+		| Prod (_,t1,t2), Prod (name,u1,u2) -> 
+		    let v' = option_map (whd_betadeltaiota env (evars_of isevars)) v in
+		    let (evd',b) =
+		      match v' with 
+			  Some v' ->
+			    (match kind_of_term v' with
+			       | Lambda (x,v1,v2) ->
+				   (try the_conv_x env v1 u1 isevars, Some (x, v1, v2)  (* leq v1 u1? *)
+				    with Reduction.NotConvertible -> (isevars, None))
+			       | _  -> (isevars, None))
+			| None -> (isevars, None)
+		    in 
+		      (match b with
+			   Some (x, v1, v2) ->
+			     let env1 = push_rel (x,None,v1) env in
+			     let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd'
+						       (Some v2) t2 u2 in
+			       (evd'', option_map (fun v2' -> mkLambda (x, v1, v2')) v2', 
+				mkProd (x, v1, t2'))
+			 | None ->
+			     (* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
+			     (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
+			     (* has type (name:u1)u2 (with v' recursively obtained) *)
+			     let name = (match name with 
+					   | Anonymous -> Name (id_of_string "x")
+					   | _ -> name) in
+			     let env1 = push_rel (name,None,u1) env in
+			     let (evd', v1', t1') =
+			       inh_conv_coerce_to_fail loc env1 isevars
+				 (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) 
+			     in
+			     let (evd'', v2', t2') = 
+			       let v2 =
+				 match v with 
+				     Some v -> option_map (fun v1' -> mkApp (lift 1 v, [|v1'|])) v1'
+				   | None -> None
+			       and evd', t2 =
+				 match v1' with 
+				     Some v1' -> evd', subst1 v1' t2
+				   | None -> 
+				       let evd', ev = new_evar evd' env ~src:(loc, InternalHole) t1' in
+					 evd', subst1 ev t2
+			       in
+				 inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2
+			     in
+			       (evd'', option_map (fun v2' -> mkLambda (name, u1, v2')) v2',
+				mkProd (name, u1, t2')))
+		| _ -> raise NoCoercion))
+
+	
+  (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
+  let inh_conv_coerce_to loc env isevars cj ((n, t) as _tycon) =
+(*     (try *)
+(*        trace (str "Subtac_coercion.inh_conv_coerce_to called for " ++ *)
+(* 	      Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++ *)
+(* 	      Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *)
+(* 	      Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
+(* 	      Termops.print_env env); *)
+(*      with _ -> ()); *)
+    match n with
+	None ->
+	  let (evd', val', type') = 
+	    try 
+	      inh_conv_coerce_to_fail loc env isevars (Some cj.uj_val) cj.uj_type t
+	    with NoCoercion ->
+	      let sigma = evars_of isevars in
+		try
+		  coerce_itf loc env isevars (Some cj.uj_val) cj.uj_type t
+		with NoSubtacCoercion ->
+		  error_actual_type_loc loc env sigma cj t
+	  in
+	  let val' = match val' with Some v -> v | None -> assert(false) in
+	    (evd',{ uj_val = val'; uj_type = t })
+      | Some (init, cur) ->
+	  (isevars, cj)
+
+  let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) =
+(*     (try  *)
+(*        trace (str "Subtac_coercion.inh_conv_coerces_to called for " ++ *)
+(* 	      Termops.print_constr_env env t ++ str " and "++ spc () ++  *)
+(* 	      Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *)
+(* 	      Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
+(* 	      Termops.print_env env); *)
+(*      with _ -> ()); *)
+    let nabsinit, nabs = 
+      match abs with
+	  None -> 0, 0
+	| Some (init, cur) -> init, cur
+    in
+      (* a little more effort to get products is needed *) 
+      try let rels, rng = decompose_prod_n nabs t in
+	(* The final range free variables must have been replaced by evars, we accept only that evars
+	   in rng are applied to free vars. *)
+	if noccur_with_meta 0 (succ nabsinit) rng then (
+(* 	  trace (str "No occur between 0 and " ++ int (succ nabsinit)); *)
+	  let env', t, t' = 
+	    let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in
+	      env', rng, lift nabs t'
+	  in
+	    try 
+	      pi1 (try inh_conv_coerce_to_fail loc env' isevars None t t'
+		   with NoCoercion ->
+		     coerce_itf loc env' isevars None t t') 
+	    with NoSubtacCoercion ->
+	      let sigma = evars_of isevars in
+		error_cannot_coerce env' sigma (t, t'))
+	else isevars 
+      with _ -> isevars
+ (* 	trace (str "decompose_prod_n failed"); *)
+ (* 	raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") *)
+end
diff --git a/contrib/subtac/subtac_coercion.mli b/contrib/subtac/subtac_coercion.mli
new file mode 100644
index 00000000..53a8d213
--- /dev/null
+++ b/contrib/subtac/subtac_coercion.mli
@@ -0,0 +1 @@
+module Coercion : Coercion.S
diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml
new file mode 100644
index 00000000..68ab8c46
--- /dev/null
+++ b/contrib/subtac/subtac_command.ml
@@ -0,0 +1,411 @@
+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 Term
+open Termops
+open Tacexpr
+open Safe_typing
+open Typing
+open Hiddentac
+open Genarg
+open Decl_kinds
+open Mod_subst
+open Printer
+open Inductiveops
+open Syntax_def
+open Environ
+open Tactics
+open Tacticals
+open Tacinterp
+open Vernacexpr
+open Notation
+
+module SPretyping = Subtac_pretyping.Pretyping
+open Subtac_utils
+open Pretyping
+open Subtac_obligations
+
+(*********************************************************************)
+(* Functions to parse and interpret constructions *)
+
+let evar_nf isevars c =
+  isevars := Evarutil.nf_evar_defs !isevars;
+  Evarutil.nf_isevar !isevars c
+
+let interp_gen kind isevars env 
+               ?(impls=([],[])) ?(allow_soapp=false) ?(ltacvars=([],[]))
+               c =
+  let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in
+  let c' = Subtac_utils.rewrite_cases env c' in
+(*     (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); *)
+  let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in
+    evar_nf isevars c'
+    
+let interp_constr isevars env c =
+  interp_gen (OfType None) isevars env c 
+
+let interp_type isevars env ?(impls=([],[])) c =
+  interp_gen IsType isevars env ~impls c
+
+let interp_casted_constr isevars env ?(impls=([],[])) c typ =
+  interp_gen (OfType (Some typ)) isevars env ~impls c 
+
+let interp_open_constr isevars env c =
+    msgnl (str "Pretyping " ++ my_print_constr_expr c);
+  let c = Constrintern.intern_constr (Evd.evars_of !isevars) env c in
+  let c' = SPretyping.pretype_gen isevars env ([], []) (OfType None) c in
+    evar_nf isevars c'
+
+let interp_constr_judgment isevars env c =
+  let j = 
+    SPretyping.understand_judgment_tcc isevars env
+      (Constrintern.intern_constr (Evd.evars_of !isevars) env c) 
+  in
+    { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type }
+
+let locate_if_isevar loc na = function
+  | RHole _ -> 
+      (try match na with
+	| Name id ->  Reserve.find_reserved_type id
+	| Anonymous -> raise Not_found 
+      with Not_found -> RHole (loc, Evd.BinderType na))
+  | x -> x
+
+let interp_binder sigma env na t =
+  let t = Constrintern.intern_gen true (Evd.evars_of !sigma) env t in
+    SPretyping.understand_type (Evd.evars_of !sigma) env (locate_if_isevar (loc_of_rawconstr t) na t)
+      
+
+let interp_context sigma env params = 
+  List.fold_left
+    (fun (env,params) d -> match d with
+      | LocalRawAssum ([_,na],(CHole _ as t)) ->
+	  let t = interp_binder sigma env na t in
+	  let d = (na,None,t) in
+	  (push_rel d env, d::params)
+      | LocalRawAssum (nal,t) ->
+	  let t = interp_type sigma env t in
+	  let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
+	  let ctx = List.rev ctx in
+	  (push_rel_context ctx env, ctx@params)
+      | LocalRawDef ((_,na),c) ->
+	  let c = interp_constr_judgment sigma env c in
+	  let d = (na, Some c.uj_val, c.uj_type) in
+	  (push_rel d env,d::params))
+    (env,[]) params
+
+(* try to find non recursive definitions *)
+
+let list_chop_hd i l = match list_chop i l with
+  | (l1,x::l2) -> (l1,x,l2)
+  | (x :: [], l2) -> ([], x, [])
+  | _ -> assert(false)
+
+let collect_non_rec env = 
+  let rec searchrec lnonrec lnamerec ldefrec larrec nrec = 
+    try
+      let i = 
+        list_try_find_i
+          (fun i f ->
+             if List.for_all (fun (_, _, def) -> not (occur_var env f def)) ldefrec
+             then i else failwith "try_find_i")
+          0 lnamerec 
+      in
+      let (lf1,f,lf2) = list_chop_hd i lnamerec in
+      let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
+      let (lar1,ar,lar2) = list_chop_hd i larrec in
+      let newlnv = 
+	try 
+	  match list_chop i nrec with 
+            | (lnv1,_::lnv2) -> (lnv1@lnv2)
+	    | _ -> [] (* nrec=[] for cofixpoints *)
+        with Failure "list_chop" -> []
+      in 
+      searchrec ((f,def,ar)::lnonrec) 
+	(lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
+    with Failure "try_find_i" -> 
+      (List.rev lnonrec,
+       (Array.of_list lnamerec, Array.of_list ldefrec,
+        Array.of_list larrec, Array.of_list nrec))
+  in 
+  searchrec [] 
+
+let list_of_local_binders l = 
+  let rec aux acc = function
+      Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl
+    | Topconstr.LocalRawAssum (nl, c) :: tl -> 
+	aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl
+    | [] -> List.rev acc
+  in aux [] l
+
+let lift_binders k n l =
+  let rec aux n = function
+    | (id, t, c) :: tl -> (id, option_map (liftn k n) t, liftn k n c) :: aux (pred n) tl
+    | [] -> []
+  in aux n l
+
+let rec gen_rels = function
+    0 -> []
+  | n -> mkRel n :: gen_rels (pred n)
+
+let split_args n rel = match list_chop ((List.length rel) - n) rel with
+    (l1, x :: l2) -> l1, x, l2
+  | _ -> assert(false)
+
+let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
+  let sigma = Evd.empty in
+  let isevars = ref (Evd.create_evar_defs sigma) in
+  let env = Global.env() in 
+  let nc = named_context env in
+  let nc_len = named_context_length nc in
+(*   let pr c = my_print_constr env c in *)
+(*   let prr = Printer.pr_rel_context env in *)
+(*   let prn = Printer.pr_named_context env in *)
+(*   let pr_rel env = Printer.pr_rel_context env in *)
+(*   let _ =  *)
+(*     try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++  *)
+(* 		 Ppconstr.pr_binders bl ++ str " : " ++  *)
+(* 		 Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ *)
+(* 		 Ppconstr.pr_constr_expr body) *)
+(*     with _ -> () *)
+    (*   in *)
+  let env', binders_rel = interp_context isevars env bl in
+  let after, ((argname, _, argtyp) as arg), before = split_args (succ n) binders_rel in
+  let before_length, after_length = List.length before, List.length after in
+  let argid = match argname with Name n -> n | _ -> assert(false) in
+  let _liftafter = lift_binders 1 after_length after in
+  let envwf = push_rel_context before env in
+  let wf_rel, wf_rel_fun, measure_fn = 
+    let rconstr_body, rconstr = 
+      let app = mkAppC (r, [mkIdentC (id_of_name argname)]) in
+       let env = push_rel_context [arg] envwf in
+       let capp = interp_constr isevars env app in
+ 	capp, mkLambda (argname, argtyp, capp)
+     in
+       if measure then
+ 	let lt_rel = constr_of_global (Lazy.force lt_ref) in
+ 	let name s = Name (id_of_string s) in
+ 	let wf_rel_fun = 
+ 	  (fun x y ->
+ 	      mkApp (lt_rel, [| subst1 x rconstr_body; 
+ 				subst1 y rconstr_body |])) 
+ 	in
+ 	let wf_rel = 
+ 	  mkLambda (name "x", argtyp,
+ 		    mkLambda (name "y", lift 1 argtyp,
+ 			      wf_rel_fun (mkRel 2) (mkRel 1)))
+ 	in
+ 	  wf_rel, wf_rel_fun , Some rconstr
+       else rconstr, (fun x y -> mkApp (rconstr, [|x; y|])), None
+  in
+  let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |])
+  in
+  let argid' = id_of_string (string_of_id argid ^ "'") in
+  let wfarg len = (Name argid', None, 
+  		   mkSubset (Name argid') (lift len argtyp) 
+		     (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
+  in
+  let top_bl = after @ (arg :: before) in
+  let intern_bl = after @ (wfarg 1 :: arg :: before) in
+  let top_env = push_rel_context top_bl env in
+  let _intern_env = push_rel_context intern_bl env in
+  let top_arity = interp_type isevars top_env arityc in
+  let proj = (Lazy.force sig_).Coqlib.proj1 in
+  let projection = 
+    mkApp (proj, [| argtyp ;
+		    (mkLambda (Name argid', argtyp,
+			       (wf_rel_fun (mkRel 1) (mkRel 3)))) ;
+		    mkRel 1
+		 |])
+  in
+    (*   (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ()); *)
+  let intern_arity = substnl [projection] after_length top_arity in 
+(*   (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ()); *)
+  let intern_before_env = push_rel_context before env in
+  let intern_fun_bl = after @ [wfarg 1]  in
+(*   (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); *)
+  let intern_fun_arity = intern_arity in
+(*   (try debug 2 (str "Intern fun arity: " ++  *)
+(* 		  my_print_constr intern_env intern_fun_arity) with _ -> ()); *)
+  let intern_fun_arity_prod = it_mkProd_or_LetIn intern_fun_arity intern_fun_bl in
+  let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in
+  let fun_bl = after @ (intern_fun_binder :: [arg]) in
+(*   (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ()); *)
+  let fun_env = push_rel_context fun_bl intern_before_env in
+  let fun_arity = interp_type isevars fun_env arityc in
+  let intern_body = interp_casted_constr isevars fun_env body fun_arity in
+  let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in
+(*   let _ =  *)
+(*       try debug 2 (str "Fun bl: " ++ prr fun_bl ++ spc () ++ *)
+(* 		   str "Intern bl" ++ prr intern_bl ++ spc () ++ *)
+(* 		   str "Top bl" ++ prr top_bl ++ spc () ++ *)
+(* 		   str "Intern arity: " ++ pr intern_arity ++ *)
+(* 		   str "Top arity: " ++ pr top_arity ++ spc () ++ *)
+(* 		   str "Intern body " ++ pr intern_body_lam) *)
+(*       with _ -> () *)
+(*   in *)
+  let _impl = 
+    if Impargs.is_implicit_args()
+    then Impargs.compute_implicits top_env top_arity
+    else [] 
+  in
+  let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in
+  let fix_def =
+    match measure_fn with
+	None ->
+	  mkApp (constr_of_reference (Lazy.force fix_sub_ref), 
+		 [| argtyp ;
+		    wf_rel ;
+		    make_existential dummy_loc intern_before_env isevars wf_proof ;
+		    prop ;
+		    intern_body_lam |])
+      | Some f ->
+	  mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref), 
+		 [| argtyp ; f ; prop ;
+		    intern_body_lam |])
+  in
+  let def_appl = applist (fix_def, gen_rels (after_length + 1)) in
+  let def = it_mkLambda_or_LetIn def_appl binders_rel in
+  let typ = it_mkProd_or_LetIn top_arity binders_rel in
+  let fullcoqc = Evarutil.nf_isevar !isevars def in
+  let fullctyp = Evarutil.nf_isevar !isevars typ in
+(*   let _ = try trace (str "After evar normalization: " ++ spc () ++ *)
+(* 		 str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *)
+(* 		     ++ str "Coq type: " ++ my_print_constr env fullctyp)  *)
+(*      with _ -> ()  *)
+(*   in *)
+  let evm = non_instanciated_map env isevars in
+    (*   let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm)  with _ -> () in *)
+  let evars, evars_def = Eterm.eterm_obligations recname nc_len evm fullcoqc (Some fullctyp) in
+    (*     (try trace (str "Generated obligations : "); *)
+(*        Array.iter *)
+    (* 	 (fun (n, t, _) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) *)
+    (* 	 evars; *)
+    (*      with _ -> ());     *)
+    Subtac_obligations.add_definition recname evars_def fullctyp evars
+    
+let build_mutrec l boxed = 
+  let sigma = Evd.empty and env = Global.env () in 
+  let nc = named_context env in
+  let nc_len = named_context_length nc in
+  let lnameargsardef =
+    (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env protos (f, d))*)
+    l
+  in
+  let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef 
+  and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef
+  in
+    (* Build the recursive context and notations for the recursive types *)
+  let (rec_sign,rec_env,rec_impls,arityl) = 
+    List.fold_left 
+      (fun (sign,env,impls,arl) ((recname, n, bl,arityc,body),_) -> 
+	 let isevars = ref (Evd.create_evar_defs sigma) in	  
+	 let arityc = Command.generalize_constr_expr arityc bl in
+	 let arity = interp_type isevars env arityc in
+	 let impl = 
+	   if Impargs.is_implicit_args()
+	   then Impargs.compute_implicits env arity
+	   else [] in
+	 let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in
+	   ((recname,None,arity) :: sign, Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl))
+      ([],env,[],[]) lnameargsardef in
+  let arityl = List.rev arityl in
+  let notations = 
+    List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) 
+      lnameargsardef [] in
+
+  let recdef =
+
+    (* Declare local notations *)
+    let fs = States.freeze() in
+    let def = 
+      try
+	List.iter (fun (df,c,scope) -> (* No scope for tmp notation *)
+	 Metasyntax.add_notation_interpretation df rec_impls c None) notations;
+	List.map2
+	  (fun ((_,_,bl,_,def),_) (isevars, info, arity) ->
+	     match info with
+		 None ->
+		   let def = abstract_constr_expr def bl in
+		     isevars, info, interp_casted_constr isevars rec_env ~impls:([],rec_impls)
+		       def arity
+	       | Some (n, artyp, wfrel, fun_bl, intern_bl, intern_arity) ->
+		   let rec_env = push_rel_context fun_bl rec_env in
+		   let cstr = interp_casted_constr isevars rec_env ~impls:([],rec_impls)
+				def intern_arity
+		   in isevars, info, it_mkLambda_or_LetIn cstr fun_bl)
+          lnameargsardef arityl
+      with e ->
+	States.unfreeze fs; raise e in
+    States.unfreeze fs; def 
+  in
+  let (lnonrec,(namerec,defrec,arrec,nvrec)) = 
+    collect_non_rec env lrecnames recdef arityl nv in
+  let recdefs = Array.length defrec in
+    (* Solve remaining evars *)
+  let rec collect_evars i acc = 
+    if i < recdefs then
+      let (isevars, info, def) = defrec.(i) in
+	(*       let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in *)
+      let def = evar_nf isevars def in
+      let isevars = Evd.undefined_evars !isevars in
+	(*       let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in *)
+      let evm = Evd.evars_of isevars in
+      let _, _, typ = arrec.(i) in
+      let id = namerec.(i) in
+	(* Generalize by the recursive prototypes  *)
+      let def = 
+	Termops.it_mkNamedLambda_or_LetIn def rec_sign
+      and typ = 
+	Termops.it_mkNamedProd_or_LetIn typ rec_sign
+      in
+      let evars, def = Eterm.eterm_obligations id nc_len evm def (Some typ) in
+	collect_evars (succ i) ((id, def, typ, evars) :: acc)
+    else acc
+  in 
+  let defs = collect_evars 0 [] in
+    Subtac_obligations.add_mutual_definitions (List.rev defs) nvrec
+      
+let out_n = function
+    Some n -> n
+  | None -> 0
+
+let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed =
+  match lnameargsardef with
+    | ((id, (n, CWfRec r), bl, typ, body), no) :: [] -> 
+	build_wellfounded (id, out_n n, bl, typ, body) r false no boxed
+    | ((id, (n, CMeasureRec r), bl, typ, body), no) :: [] -> 
+	build_wellfounded (id, out_n n, bl, typ, body) r true no boxed
+    | l -> 
+	let lnameargsardef = 
+	  List.map (fun ((id, (n, ro), bl, typ, body), no) ->
+		 match ro with
+		     CStructRec -> (id, out_n n, bl, typ, body), no
+		   | CWfRec _ | CMeasureRec _ -> 
+		       errorlabstrm "Subtac_command.build_recursive"
+			 (str "Well-founded fixpoints not allowed in mutually recursive blocks"))
+	    lnameargsardef
+	in build_mutrec lnameargsardef boxed
+	  
+      
+      
diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli
new file mode 100644
index 00000000..846e06cf
--- /dev/null
+++ b/contrib/subtac/subtac_command.mli
@@ -0,0 +1,42 @@
+open Pretyping
+open Evd
+open Environ
+open Term
+open Topconstr
+open Names
+open Libnames
+open Pp
+open Vernacexpr
+open Constrintern
+
+val interp_gen :
+  typing_constraint ->
+  evar_defs ref ->
+  env ->
+  ?impls:full_implicits_env ->
+  ?allow_soapp:bool ->
+  ?ltacvars:ltac_sign ->
+  constr_expr -> constr
+val interp_constr :
+  evar_defs ref ->
+  env -> constr_expr -> constr
+val interp_type :
+  evar_defs ref ->
+  env ->
+  ?impls:full_implicits_env ->
+  constr_expr -> constr
+val interp_casted_constr :
+  evar_defs ref ->
+  env ->
+  ?impls:full_implicits_env ->
+  constr_expr -> types -> constr
+val interp_open_constr :
+  evar_defs ref -> env -> constr_expr -> constr
+val interp_constr_judgment :
+  evar_defs ref ->
+  env ->
+  constr_expr -> unsafe_judgment
+val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
+
+val build_recursive :
+  (fixpoint_expr * decl_notation) list -> bool -> unit
diff --git a/contrib/subtac/subtac_errors.ml b/contrib/subtac/subtac_errors.ml
new file mode 100644
index 00000000..3bbfe22b
--- /dev/null
+++ b/contrib/subtac/subtac_errors.ml
@@ -0,0 +1,24 @@
+open Util
+open Pp
+open Printer
+
+type term_pp = Pp.std_ppcmds
+
+type subtyping_error = 
+  | UncoercibleInferType of loc * term_pp * term_pp
+  | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp
+  | UncoercibleRewrite of term_pp * term_pp
+
+type typing_error = 
+  | NonFunctionalApp of loc * term_pp * term_pp * term_pp
+  | NonConvertible of loc * term_pp * term_pp
+  | NonSigma of loc * term_pp
+  | IllSorted of loc * term_pp
+
+exception Subtyping_error of subtyping_error
+exception Typing_error of typing_error
+  
+exception Debug_msg of string
+
+let typing_error e = raise (Typing_error e)
+let subtyping_error e = raise (Subtyping_error e)
diff --git a/contrib/subtac/subtac_errors.mli b/contrib/subtac/subtac_errors.mli
new file mode 100644
index 00000000..8d75b9c0
--- /dev/null
+++ b/contrib/subtac/subtac_errors.mli
@@ -0,0 +1,15 @@
+type term_pp = Pp.std_ppcmds
+type subtyping_error =
+    UncoercibleInferType of Util.loc * term_pp * term_pp
+  | UncoercibleInferTerm of Util.loc * term_pp * term_pp * term_pp * term_pp
+  | UncoercibleRewrite of term_pp * term_pp
+type typing_error =
+    NonFunctionalApp of Util.loc * term_pp * term_pp * term_pp
+  | NonConvertible of Util.loc * term_pp * term_pp
+  | NonSigma of Util.loc * term_pp
+  | IllSorted of Util.loc * term_pp
+exception Subtyping_error of subtyping_error
+exception Typing_error of typing_error
+exception Debug_msg of string
+val typing_error : typing_error -> 'a
+val subtyping_error : subtyping_error -> 'a
diff --git a/contrib/subtac/subtac_interp_fixpoint.ml b/contrib/subtac/subtac_interp_fixpoint.ml
new file mode 100644
index 00000000..bb35833f
--- /dev/null
+++ b/contrib/subtac/subtac_interp_fixpoint.ml
@@ -0,0 +1,154 @@
+open Global
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Reductionops
+open Environ
+open Type_errors
+open Typeops
+open Libnames
+open Classops
+open List
+open Recordops 
+open Evarutil
+open Pretype_errors
+open Rawterm
+open Evarconv
+open Pattern
+open Dyn
+open Topconstr
+
+open Subtac_coercion
+open Subtac_utils
+open Coqlib
+open Printer
+open Subtac_errors
+open Context
+open Eterm
+
+
+let mkAppExplC (f, args) = CAppExpl (dummy_loc, (None, f), args)
+
+let mkSubset name typ prop = 
+  mkAppExplC (sig_ref,
+	      [ typ; mkLambdaC ([name], typ, prop) ])
+	      
+let mkProj1 u p x = 
+  mkAppExplC (proj1_sig_ref, [ u; p; x ])
+
+let mkProj2 u p x = 
+  mkAppExplC (proj2_sig_ref, [ u; p; x ])
+
+let list_of_local_binders l = 
+  let rec aux acc = function
+      Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, c) :: acc) tl
+    | Topconstr.LocalRawAssum (nl, c) :: tl -> 
+	aux (List.fold_left (fun acc n -> (n, c) :: acc) acc nl) tl
+    | [] -> List.rev acc
+  in aux [] l
+       
+let abstract_constr_expr_bl abs c bl =
+  List.fold_right (fun (n, t) c -> abs ([n], t, c)) bl c
+
+let pr_binder_list b = 
+  List.fold_right (fun ((loc, name), t) acc -> Nameops.pr_name name ++ str " : " ++
+		     Ppconstr.pr_constr_expr t ++ spc () ++ acc) b (mt ()) 
+
+
+let rec rewrite_rec_calls l c = c
+(*
+let rewrite_fixpoint env l (f, decl) = 
+  let (id, (n, ro), bl, typ, body) = f in
+  let body = rewrite_rec_calls l body in
+    match ro with
+	CStructRec -> ((id, (n, ro), bl, typ, body), decl)
+      | CWfRec wfrel -> 
+	  let bls = list_of_local_binders bl in
+	  let _ = trace (str "Rewriting fixpoint: " ++ Ppconstr.pr_id id ++ 
+			 Ppconstr.pr_binders bl ++ str " : " ++ 
+			 Ppconstr.pr_constr_expr typ ++ str " := " ++ spc () ++
+			 Ppconstr.pr_constr_expr body)
+	  in
+	  let before, after = list_chop n bls in
+	  let _ = trace (str "Binders before the recursion arg: " ++ spc () ++
+			 pr_binder_list before ++ str "; after the recursion arg: " ++
+			 pr_binder_list after)
+	  in
+	  let ((locn, name) as lnid, ntyp), after = match after with
+	      hd :: tl -> hd, tl
+	    | _ -> assert(false) (* Rec arg must be in after *)
+	  in
+	  let nid = match name with
+	      Name id -> id
+	    | Anonymous -> assert(false) (* Rec arg _must_ be named *)
+	  in
+	  let _wfproof = 
+	    let _wf_rel = mkAppExplC (well_founded_ref, [ntyp; wfrel]) in
+	      (*make_existential_expr dummy_loc before wf_rel*)
+	      mkRefC lt_wf_ref
+	  in
+	  let nid', accproofid = 
+	    let nid = string_of_id nid in
+	      id_of_string (nid ^ "'"), id_of_string ("Acc_" ^ nid)
+	  in
+	  let lnid', laccproofid = (dummy_loc, Name nid'), (dummy_loc, Name accproofid) in
+	  let wf_prop = (mkAppC (wfrel, [ mkIdentC nid'; mkIdentC nid ])) in
+	  let lam_wf_prop = mkLambdaC ([lnid'], ntyp, wf_prop) in
+	  let typnid' = mkSubset lnid' ntyp wf_prop in
+	  let internal_type = 
+	    abstract_constr_expr_bl mkProdC 
+	      (mkProdC ([lnid'], typnid', 
+			mkLetInC (lnid, mkProj1 ntyp lam_wf_prop (mkIdentC nid'), 
+				  abstract_constr_expr_bl mkProdC typ after)))
+	      before
+	  in
+	  let body' =
+	    let body =
+	      (* cast or we will loose some info at pretyping time as body
+		 is a function *)
+	      CCast (dummy_loc, body,  CastConv DEFAULTcast, typ) 
+	    in
+	    let body' = (* body abstracted by rec call *)
+	      mkLambdaC ([(dummy_loc, Name id)], internal_type, body)
+	    in
+	      mkAppC (body',
+		      [mkLambdaC 
+			 ([lnid'], typnid',
+			  mkAppC (mkIdentC id, 
+				  [mkProj1 ntyp lam_wf_prop (mkIdentC nid');
+				   (mkAppExplC (acc_inv_ref,
+						[ ntyp; wfrel;
+						  mkIdentC nid;
+						  mkIdentC accproofid;
+						  mkProj1 ntyp lam_wf_prop (mkIdentC nid');
+						  mkProj2 ntyp lam_wf_prop (mkIdentC nid') ])) ]))])
+	  in
+	  let acctyp = mkAppExplC (acc_ref, [ ntyp; wfrel; mkIdentC nid ]) in
+	  let bl' = 
+	    let rec aux acc = function
+		Topconstr.LocalRawDef _ as x :: tl -> 
+		  aux (x :: acc) tl
+	      | Topconstr.LocalRawAssum (bl, typ) as assum :: tl ->
+		  let rec aux' bl' = function
+		      ((loc, name') as x) :: tl ->
+			if name' = name then
+			  (if tl = [] then [] else [LocalRawAssum (tl, typ)]) @
+			  LocalRawAssum ([(dummy_loc, Name accproofid)], acctyp) ::
+			    [LocalRawAssum (List.rev (x :: bl'), typ)]
+			else aux' (x :: bl') tl
+		    | [] -> [assum]
+		  in aux (aux' [] bl @ acc) tl
+	      | [] -> List.rev acc
+	    in aux [] bl
+	  in
+	  let _ = trace (str "Rewrote fixpoint: " ++ Ppconstr.pr_id id ++ 
+			 Ppconstr.pr_binders bl' ++ str " : " ++ 
+			 Ppconstr.pr_constr_expr typ ++ str " := " ++ spc () ++
+			 Ppconstr.pr_constr_expr body')
+	  in (id, (succ n, ro), bl', typ, body'), decl
+
+*)
diff --git a/contrib/subtac/subtac_interp_fixpoint.mli b/contrib/subtac/subtac_interp_fixpoint.mli
new file mode 100644
index 00000000..149e7580
--- /dev/null
+++ b/contrib/subtac/subtac_interp_fixpoint.mli
@@ -0,0 +1,17 @@
+val mkAppExplC :
+  Libnames.reference * Topconstr.constr_expr list -> Topconstr.constr_expr
+val mkSubset :
+  Names.name Util.located ->
+  Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr
+val mkProj1 :
+  Topconstr.constr_expr ->
+  Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr
+val mkProj2 :
+  Topconstr.constr_expr ->
+  Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr
+val list_of_local_binders :
+  Topconstr.local_binder list ->
+  (Names.name Util.located * Topconstr.constr_expr) list
+val pr_binder_list :
+  (('a * Names.name) * Topconstr.constr_expr) list -> Pp.std_ppcmds
+val rewrite_rec_calls : 'a -> 'b -> 'b
diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml
new file mode 100644
index 00000000..d6c1772f
--- /dev/null
+++ b/contrib/subtac/subtac_obligations.ml
@@ -0,0 +1,394 @@
+open Printf
+open Pp
+open Subtac_utils
+
+open Term
+open Names
+open Libnames
+open Summary
+open Libobject
+open Entries
+open Decl_kinds
+open Util
+open Evd
+
+type obligation_info = (Names.identifier * Term.types * Intset.t) array
+
+type obligation =
+    { obl_name : identifier;
+      obl_type : types;
+      obl_body : constr option;
+      obl_deps : Intset.t;
+    }
+
+type obligations = (obligation array * int)
+
+type program_info = {
+  prg_name: identifier;
+  prg_body: constr;
+  prg_type: constr;
+  prg_obligations: obligations;
+  prg_deps : identifier list;
+  prg_nvrec : int array;
+}
+
+let assumption_message id =
+  Options.if_verbose message ((string_of_id id) ^ " is assumed")
+
+let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC
+
+let set_default_tactic t = default_tactic := t
+
+let evar_of_obligation o = { evar_hyps = Global.named_context_val () ;
+			     evar_concl = o.obl_type ; 
+			     evar_body = Evar_empty ;
+			     evar_extra = None }
+
+let subst_deps obls deps t =
+  Intset.fold
+    (fun x acc ->
+       let xobl = obls.(x) in
+	 debug 3 (str "Trying to get body of obligation " ++ int x);
+       let oblb = 
+	 try out_some xobl.obl_body
+	 with _ ->
+	   debug 3 (str "Couldn't get body of obligation " ++ int x);
+	   assert(false)
+       in
+	 Term.subst1 oblb (Term.subst_var xobl.obl_name acc))
+    deps t
+
+let subst_deps_obl obls obl =
+  let t' = subst_deps obls obl.obl_deps obl.obl_type in
+    { obl with obl_type = t' }
+
+module ProgMap = Map.Make(struct type t = identifier let compare = compare end)
+
+let map_replace k v m = ProgMap.add k v (ProgMap.remove k m)
+
+let map_cardinal m = 
+  let i = ref 0 in 
+    ProgMap.iter (fun _ _ -> incr i) m;
+    !i
+
+exception Found of program_info
+
+let map_first m = 
+  try
+    ProgMap.iter (fun _ v -> raise (Found v)) m;
+    assert(false)
+  with Found x -> x
+    
+let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
+
+let _ = 
+  Summary.declare_summary "program-tcc-table"
+    { Summary.freeze_function = (fun () -> !from_prg);
+      Summary.unfreeze_function =
+        (fun v -> from_prg := v);
+      Summary.init_function =
+        (fun () -> from_prg := ProgMap.empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+open Evd
+
+let terms_of_evar ev = 
+  match ev.evar_body with
+      Evar_defined b ->
+	let nc = Environ.named_context_of_val ev.evar_hyps in
+	let body = Termops.it_mkNamedLambda_or_LetIn b nc in
+	let typ = Termops.it_mkNamedProd_or_LetIn ev.evar_concl nc in
+	  body, typ
+    | _ -> assert(false)
+	  
+let rec intset_to = function
+    -1 -> Intset.empty
+  | n -> Intset.add n (intset_to (pred n))
+  
+let subst_body prg = 
+  let obls, _ = prg.prg_obligations in
+    subst_deps obls (intset_to (pred (Array.length obls))) prg.prg_body
+
+let declare_definition prg =
+  let body = subst_body prg in
+    (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++
+		  my_print_constr (Global.env()) body);
+     with _ -> ());
+  let ce = 
+    { const_entry_body = body;
+      const_entry_type = Some prg.prg_type;
+      const_entry_opaque = false;
+      const_entry_boxed = false} 
+  in
+  let _constant = Declare.declare_constant 
+    prg.prg_name (DefinitionEntry ce,IsDefinition Definition)
+  in
+    Subtac_utils.definition_message prg.prg_name
+
+open Pp
+open Ppconstr
+
+let declare_mutual_definition l =
+  let len = List.length l in
+  let namerec = Array.of_list (List.map (fun x -> x.prg_name) l) in
+  let arrec = 
+    Array.of_list (List.map (fun x -> snd (decompose_prod_n len x.prg_type)) l)
+  in
+  let recvec = 
+    Array.of_list 
+      (List.map (fun x -> 
+		   let subs = (subst_body x) in
+		     snd (decompose_lam_n len subs)) l)
+  in
+  let nvrec = (List.hd l).prg_nvrec in
+  let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in
+  let rec declare i fi =
+    (try trace (str "Declaring: " ++ pr_id fi ++ spc () ++
+		  my_print_constr (Global.env()) (recvec.(i)));
+     with _ -> ());
+    let ce = 
+      { const_entry_body = mkFix ((nvrec,i),recdecls); 
+        const_entry_type = Some arrec.(i);
+        const_entry_opaque = false;
+        const_entry_boxed = true} in
+    let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Fixpoint)
+    in
+      ConstRef kn
+  in
+  let lrefrec = Array.mapi declare namerec in
+    Options.if_verbose ppnl (recursive_message lrefrec)
+         
+let declare_obligation obl body =
+  let ce = 
+    { const_entry_body = body;
+      const_entry_type = Some obl.obl_type;
+      const_entry_opaque = false;
+      const_entry_boxed = false} 
+  in
+  let constant = Declare.declare_constant obl.obl_name 
+    (DefinitionEntry ce,IsProof Property)
+  in
+    Subtac_utils.definition_message obl.obl_name;
+    { obl with obl_body = Some (mkConst constant) }
+      
+let try_tactics obls = 
+  Array.map
+    (fun obl ->
+       match obl.obl_body with
+	   None ->
+	     (try
+		let ev = evar_of_obligation obl in
+		let c = Subtac_utils.solve_by_tac ev Auto.default_full_auto in	       
+		  declare_obligation obl c		  
+	      with _ -> obl)
+	 | _ -> obl)
+    obls
+        
+let red = Reductionops.nf_betaiota
+
+let init_prog_info n b t deps nvrec obls =
+  let obls' = 
+    Array.mapi
+      (fun i (n, t, d) ->
+	 debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d));
+         { obl_name = n ; obl_body = None; 
+	   obl_type = red t; 
+	   obl_deps = d })
+      obls
+  in
+    { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls');
+      prg_deps = deps; prg_nvrec = nvrec; }
+    
+let pperror cmd = Util.errorlabstrm "Subtac" cmd
+let error s = pperror (str s)
+
+let get_prog name =
+  let prg_infos = !from_prg in
+    match name with
+	Some n -> 
+	  (try ProgMap.find n prg_infos
+	   with Not_found -> error ("No obligations for program " ^ string_of_id n))
+      | None -> 
+	  (let n = map_cardinal prg_infos in
+	     match n with 
+		 0 -> error "No obligations remaining"
+	       | 1 -> map_first prg_infos
+	       | _ -> error "More than one program with unsolved obligations")
+
+let obligations_solved prg = (snd prg.prg_obligations) = 0
+
+let update_obls prg obls rem = 
+  let prg' = { prg with prg_obligations = (obls, rem) } in
+    from_prg := map_replace prg.prg_name prg' !from_prg;
+    if rem > 0 then (
+      Options.if_verbose msgnl (int rem ++ str " obligation(s) remaining");
+    )
+    else (
+      Options.if_verbose msgnl (str "No more obligations remaining");
+      match prg'.prg_deps with
+	  [] ->
+	    declare_definition prg';
+	    from_prg := ProgMap.remove prg.prg_name !from_prg
+	| l ->
+	    let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in
+	      if List.for_all (fun x -> obligations_solved x) progs then 
+		(declare_mutual_definition progs;
+		 from_prg := List.fold_left
+		   (fun acc x -> ProgMap.remove x.prg_name acc) !from_prg progs))
+	    
+let is_defined obls x = obls.(x).obl_body <> None
+
+let deps_remaining obls deps = 
+    Intset.fold
+      (fun x acc -> 
+	 if is_defined obls x then acc
+	 else x :: acc)
+      deps []
+
+let solve_obligation prg num =
+  let user_num = succ num in
+  let obls, rem = prg.prg_obligations in
+  let obl = obls.(num) in
+    if obl.obl_body <> None then
+      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")    
+    else
+      match deps_remaining obls obl.obl_deps with
+	  [] ->
+	    let obl = subst_deps_obl obls obl in
+	      Command.start_proof obl.obl_name Subtac_utils.goal_proof_kind obl.obl_type
+		(fun strength gr -> 
+		   debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished");		   
+		   let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in
+		   let obls = Array.copy obls in
+		   let _ = obls.(num) <- obl in
+		     update_obls prg obls (pred rem));
+	      trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
+		       Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
+	      Pfedit.by !default_tactic
+	| l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
+			++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))
+
+let subtac_obligation (user_num, name, typ) =
+  let num = pred user_num in
+  let prg = get_prog name in
+  let obls, rem = prg.prg_obligations in
+    if num < Array.length obls then
+      let obl = obls.(num) in
+	match obl.obl_body with
+	    None -> solve_obligation prg num
+	  | Some r -> error "Obligation already solved"
+    else error (sprintf "Unknown obligation number %i" (succ num))
+      
+      
+let obligations_of_evars evars =
+  let arr = 
+    Array.of_list
+      (List.map
+	 (fun (n, t) ->
+	    { obl_name = n;
+	      obl_type = t;
+	      obl_body = None;
+	      obl_deps = Intset.empty;
+	    }) evars)
+  in arr, Array.length arr
+
+let solve_obligation_by_tac prg obls i tac =
+  let obl = obls.(i) in
+  match obl.obl_body with 
+      Some _ -> false
+    | None -> 
+	(try
+	   if deps_remaining obls obl.obl_deps = [] then
+	     let obl = subst_deps_obl obls obl in
+	     let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
+	       obls.(i) <- { obl with obl_body = Some t };
+	       true		 
+	   else false
+	 with _ -> false)  
+
+let solve_obligations n tac = 
+  let prg = get_prog n in
+  let obls, rem = prg.prg_obligations in
+  let rem = ref rem in
+  let obls' = Array.copy obls in
+  let _ = 
+    Array.iteri (fun i x -> 
+		   if solve_obligation_by_tac prg obls' i tac then
+		     decr rem)
+      obls'
+  in
+    update_obls prg obls' !rem
+
+let add_definition n b t obls =
+  Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
+  let prg = init_prog_info n b t [] (Array.make 0 0) obls in
+  let obls,_ = prg.prg_obligations in
+  if Array.length obls = 0 then (
+    Options.if_verbose ppnl (str ".");    
+    declare_definition prg;
+    from_prg := ProgMap.remove prg.prg_name !from_prg)
+  else (
+    let len = Array.length obls in
+    let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
+      from_prg := ProgMap.add n prg !from_prg; 
+      solve_obligations (Some n) !default_tactic)
+	
+let add_mutual_definitions l nvrec =
+  let deps = List.map (fun (n, b, t, obls) -> n) l in
+  let upd = List.fold_left
+      (fun acc (n, b, t, obls) ->
+	 let prg = init_prog_info n b t deps nvrec obls in
+	   ProgMap.add n prg acc)
+      !from_prg l
+  in
+    from_prg := upd;
+    List.iter (fun x -> solve_obligations (Some x) !default_tactic) deps
+
+let admit_obligations n =
+  let prg = get_prog n in
+  let obls, rem = prg.prg_obligations in
+  let obls' = 
+    Array.mapi (fun i x -> 
+		 match x.obl_body with 
+		     None -> 
+			 let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) in
+			   assumption_message x.obl_name;
+			   { x with obl_body = Some (mkConst kn) }
+		   | Some _ -> x)
+      obls
+  in
+    update_obls prg obls' 0
+
+exception Found of int
+
+let array_find f arr = 
+  try Array.iteri (fun i x -> if f x then raise (Found i)) arr;
+    raise Not_found
+  with Found i -> i
+
+let rec next_obligation n =
+  let prg = get_prog n in
+  let obls, rem = prg.prg_obligations in
+  let i = 
+    array_find (fun x ->  x.obl_body = None && deps_remaining obls x.obl_deps = [])
+      obls
+  in
+    if solve_obligation_by_tac prg obls i !default_tactic then (
+      update_obls prg obls (pred rem);
+      next_obligation n
+    ) else solve_obligation prg i
+      
+open Pp
+let show_obligations n =
+  let prg = get_prog n in
+  let n = prg.prg_name in
+  let obls, rem = prg.prg_obligations in
+    msgnl (int rem ++ str " obligation(s) remaining: ");
+    Array.iteri (fun i x -> 
+		   match x.obl_body with 
+		       None -> msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ 
+					my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ())
+		    | Some _ -> ())
+      obls
+			
diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli
new file mode 100644
index 00000000..3981d4c6
--- /dev/null
+++ b/contrib/subtac/subtac_obligations.mli
@@ -0,0 +1,21 @@
+open Util
+
+type obligation_info = (Names.identifier * Term.types * Intset.t) array
+
+val set_default_tactic : Proof_type.tactic -> unit
+
+val add_definition : Names.identifier ->  Term.constr -> Term.types -> 
+  obligation_info -> unit
+
+val add_mutual_definitions : 
+  (Names.identifier * Term.constr * Term.types * obligation_info) list -> int array -> unit
+
+val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option -> unit
+
+val next_obligation : Names.identifier option -> unit
+
+val solve_obligations : Names.identifier option -> Proof_type.tactic -> unit
+
+val show_obligations : Names.identifier option -> unit
+
+val admit_obligations : Names.identifier option -> unit
diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml
new file mode 100644
index 00000000..4d1ac731
--- /dev/null
+++ b/contrib/subtac/subtac_pretyping.ml
@@ -0,0 +1,156 @@
+(************************************************************************)
+(*  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: subtac_pretyping.ml 9563 2007-01-31 09:37:18Z msozeau $ *)
+
+open Global
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Reductionops
+open Environ
+open Type_errors
+open Typeops
+open Libnames
+open Classops
+open List
+open Recordops 
+open Evarutil
+open Pretype_errors
+open Rawterm
+open Evarconv
+open Pattern
+open Dyn
+
+open Subtac_coercion
+open Subtac_utils
+open Coqlib
+open Printer
+open Subtac_errors
+open Context
+open Eterm
+
+module Pretyping = Subtac_pretyping_F.SubtacPretyping_F(Subtac_coercion.Coercion)
+
+open Pretyping
+
+let _ = Pretyping.allow_anonymous_refs := true
+
+type recursion_info = {
+  arg_name: name;
+  arg_type: types; (* A *)
+  args_after : rel_context;
+  wf_relation: constr; (* R : A -> A -> Prop *)
+  wf_proof: constr; (* : well_founded R *)
+  f_type: types; (* f: A -> Set *)
+  f_fulltype: types; (* Type with argument and wf proof product first *)
+}
+
+let my_print_rec_info env t = 
+  str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++
+  str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++
+  str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++
+  str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++
+  str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++
+  str "Full type: " ++ my_print_constr env t.f_fulltype
+(*   trace (str "pretype for " ++ (my_print_rawconstr env c) ++ *)
+(* 	   str " and tycon "++ my_print_tycon env tycon ++ *)
+(* 	   str " in environment: " ++ my_print_env env); *)
+
+let merge_evms x y = 
+  Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y
+
+let interp env isevars c tycon = 
+  let j = pretype tycon env isevars ([],[]) c in
+  let evm = evars_of !isevars in    
+    nf_evar evm j.uj_val, nf_evar evm j.uj_type
+
+let find_with_index x l =
+  let rec aux i = function
+      (y, _, _) as t :: tl -> if x = y then i, t else aux (succ i) tl
+    | [] -> raise Not_found
+  in aux 0 l
+
+let list_split_at index l = 
+  let rec aux i acc = function
+      hd :: tl when i = index -> (List.rev acc), tl
+    | hd :: tl -> aux (succ i) (hd :: acc) tl
+    | [] -> failwith "list_split_at: Invalid argument"
+  in aux 0 [] l
+
+open Vernacexpr
+
+let coqintern evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr (evars_of evd) env
+let coqinterp evd env : Topconstr.constr_expr -> Term.constr = Constrintern.interp_constr (evars_of evd) env
+
+let env_with_binders env isevars l =
+  let rec aux ((env, rels) as acc) = function
+      Topconstr.LocalRawDef ((loc, name), def) :: tl -> 
+	let rawdef = coqintern !isevars env def in
+	let coqdef, deftyp = interp env isevars rawdef empty_tycon in
+	let reldecl = (name, Some coqdef, deftyp) in
+	  aux  (push_rel reldecl env, reldecl :: rels) tl
+    | Topconstr.LocalRawAssum (bl, typ) :: tl ->
+	let rawtyp = coqintern !isevars env typ in
+	let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in
+	let acc = 
+	  List.fold_left (fun (env, rels) (loc, name) -> 
+			    let reldecl = (name, None, coqtyp) in
+			      (push_rel reldecl env, 
+			       reldecl :: rels))
+	    (env, rels) bl
+	in aux acc tl
+    | [] -> acc
+  in aux (env, []) l
+
+let subtac_process env isevars id l c tycon =
+  let env_binders, binders_rel = env_with_binders env isevars l in
+  let tycon = 
+    match tycon with
+	None -> empty_tycon
+      | Some t -> 
+	  let t = coqintern !isevars env_binders t in
+	  let coqt, ttyp = interp env_binders isevars t empty_tycon in
+	    mk_tycon coqt
+  in    
+  let c = coqintern !isevars env_binders c in
+  let c = Subtac_utils.rewrite_cases env c in
+  let coqc, ctyp = interp env_binders isevars c tycon in
+(*   let _ = try trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ *)
+(* 		 str "Coq type: " ++ my_print_constr env_binders ctyp) *)
+(*   with _ -> ()  *)
+(*   in *)
+(*   let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ()))  with _ -> () in *)
+    
+  let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel 
+  and fullctyp = it_mkProd_or_LetIn ctyp binders_rel
+  in
+  let fullcoqc = Evarutil.nf_evar (evars_of !isevars) fullcoqc in
+  let fullctyp = Evarutil.nf_evar (evars_of !isevars) fullctyp in
+
+(*   let _ = try trace (str "After evar normalization: " ++ spc () ++ *)
+(* 		 str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *)
+(* 		 ++ str "Coq type: " ++ my_print_constr env fullctyp)  *)
+(*      with _ -> ()  *)
+(*   in *)
+  let evm = non_instanciated_map env isevars in
+(*   let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm)  with _ -> () in *)
+    evm, fullcoqc, fullctyp
+
+open Subtac_obligations
+
+let subtac_proof env isevars id l c tycon =
+  let nc = named_context env in
+  let nc_len = named_context_length nc in
+  let evm, coqc, coqt = subtac_process env isevars id l c tycon in
+  let evars, def = Eterm.eterm_obligations id nc_len evm coqc (Some coqt) in
+    add_definition id def coqt evars
diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli
new file mode 100644
index 00000000..b62a8766
--- /dev/null
+++ b/contrib/subtac/subtac_pretyping.mli
@@ -0,0 +1,15 @@
+open Term
+open Environ
+open Names
+open Sign
+open Evd
+open Global
+open Topconstr
+
+module Pretyping : Pretyping.S
+
+val subtac_process : env -> evar_defs ref -> identifier -> local_binder list ->
+  constr_expr -> constr_expr option -> evar_map * constr * types
+
+val subtac_proof : env -> evar_defs ref -> identifier -> local_binder list ->
+  constr_expr -> constr_expr option -> unit
diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml
new file mode 100644
index 00000000..6244aef3
--- /dev/null
+++ b/contrib/subtac/subtac_pretyping_F.ml
@@ -0,0 +1,617 @@
+(************************************************************************)
+(*  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: subtac_pretyping_F.ml 9563 2007-01-31 09:37:18Z msozeau $ *)
+
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Reductionops
+open Environ
+open Type_errors
+open Typeops
+open Libnames
+open Nameops
+open Classops
+open List
+open Recordops 
+open Evarutil
+open Pretype_errors
+open Rawterm
+open Evarconv
+open Pattern
+open Dyn
+open Pretyping
+
+(************************************************************************)
+(* This concerns Cases *)
+open Declarations
+open Inductive
+open Inductiveops
+
+module SubtacPretyping_F (Coercion : Coercion.S) = struct
+
+  module Cases = Subtac_cases.Cases_F(Coercion)
+
+  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+  let allow_anonymous_refs = ref true
+
+  let evd_comb0 f isevars =
+    let (evd',x) = f !isevars in
+      isevars := evd';
+      x
+
+  let evd_comb1 f isevars x =
+    let (evd',y) = f !isevars x in
+      isevars := evd';
+      y
+
+  let evd_comb2 f isevars x y =
+    let (evd',z) = f !isevars x y in
+      isevars := evd';
+      z
+
+  let evd_comb3 f isevars x y z =
+    let (evd',t) = f !isevars x y z in
+      isevars := evd';
+      t
+	
+  let mt_evd = Evd.empty
+    
+  let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
+      
+  (* Utilisé pour inférer le prédicat des Cases *)
+  (* Semble exagérement fort *)
+  (* Faudra préférer une unification entre les types de toutes les clauses *)
+  (* et autoriser des ? à rester dans le résultat de l'unification *)
+  
+  let evar_type_fixpoint loc env isevars lna lar vdefj =
+    let lt = Array.length vdefj in 
+      if Array.length lar = lt then 
+	for i = 0 to lt-1 do 
+          if not (e_cumul env isevars (vdefj.(i)).uj_type
+		    (lift lt lar.(i))) then
+            error_ill_typed_rec_body_loc loc env (evars_of !isevars)
+              i lna vdefj lar
+	done
+
+  let check_branches_message loc env isevars c (explft,lft) = 
+    for i = 0 to Array.length explft - 1 do
+      if not (e_cumul env isevars lft.(i) explft.(i)) then 
+	let sigma = evars_of !isevars in
+	  error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
+    done
+
+  (* coerce to tycon if any *)
+  let inh_conv_coerce_to_tycon loc env isevars j = function
+    | None -> j
+    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t
+
+  let push_rels vars env = List.fold_right push_rel vars env
+
+  (*
+    let evar_type_case isevars env ct pt lft p c =
+    let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c
+    in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty)
+  *)
+
+  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 pretype_id loc env (lvar,unbndltacvars) id =
+    let id = strip_meta id in (* May happen in tactics defined by Grammar *)
+      try
+	let (n,typ) = lookup_rel_id id (rel_context env) in
+	  { uj_val  = mkRel n; uj_type = type_app (lift n) typ }
+      with Not_found ->
+	try
+	  List.assoc id lvar
+	with Not_found ->
+	  try
+	    let (_,_,typ) = lookup_named id env in
+	      { uj_val  = mkVar id; uj_type = typ }
+	  with Not_found ->
+	    try (* To build a nicer ltac error message *)
+	      match List.assoc id unbndltacvars with
+		| None -> user_err_loc (loc,"",
+					str "variable " ++ pr_id id ++ str " should be bound to a term")
+		| Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
+	    with Not_found ->
+	      error_var_not_found_loc loc id
+
+  (* make a dependent predicate from an undependent one *)
+
+  let make_dep_of_undep env (IndType (indf,realargs)) pj =
+    let n = List.length realargs in
+    let rec decomp n p =
+      if n=0 then p else
+	match kind_of_term p with
+	  | Lambda (_,_,c) -> decomp (n-1) c
+	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) 
+    in
+    let sign,s = decompose_prod_n n pj.uj_type in
+    let ind = build_dependent_inductive env indf in
+    let s' = mkProd (Anonymous, ind, s) in
+    let ccl = lift 1 (decomp n pj.uj_val) in
+    let ccl' = mkLambda (Anonymous, ind, ccl) in
+      {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} 
+
+  (*************************************************************************)
+  (* Main pretyping function                                               *)
+
+  let pretype_ref isevars env ref = 
+    let c = constr_of_global ref in
+      make_judge c (Retyping.get_type_of env Evd.empty c)
+
+  let pretype_sort = function
+    | RProp c -> judge_of_prop_contents c
+    | RType _ -> judge_of_new_Type ()
+
+  (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
+  (* in environment [env], with existential variables [(evars_of isevars)] and *)
+  (* the type constraint tycon *)
+  let rec pretype (tycon : type_constraint) env isevars lvar c = 
+(*     let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *)
+(* 			       str " with tycon " ++ Evarutil.pr_tycon env tycon)  *)
+(*     with _ -> () *)
+(*     in *)
+    match c with
+    | RRef (loc,ref) ->
+	inh_conv_coerce_to_tycon loc env isevars
+	  (pretype_ref isevars env ref)
+	  tycon
+
+    | RVar (loc, id) ->
+	inh_conv_coerce_to_tycon loc env isevars
+	  (pretype_id loc env lvar id)
+	  tycon
+
+    | REvar (loc, ev, instopt) ->
+	(* Ne faudrait-il pas s'assurer que hyps est bien un
+	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
+	let hyps = evar_context (Evd.find (evars_of !isevars) ev) in
+	let args = match instopt with
+          | None -> instance_from_named_context hyps
+          | Some inst -> failwith "Evar subtitutions not implemented" in
+	let c = mkEvar (ev, args) in
+	let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
+	  inh_conv_coerce_to_tycon loc env isevars j tycon
+
+    | RPatVar (loc,(someta,n)) -> 
+	anomaly "Found a pattern variable in a rawterm to type"
+	  
+    | RHole (loc,k) ->
+	let ty =
+          match tycon with 
+            | Some (None, ty) -> ty
+            | None | Some _ ->
+		e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) in
+	  { uj_val = e_new_evar isevars env ~src:(loc,k) ty; uj_type = ty }
+
+    | RRec (loc,fixkind,names,bl,lar,vdef) ->
+	let rec type_bl env ctxt = function
+            [] -> ctxt
+          | (na,None,ty)::bl ->
+              let ty' = pretype_type empty_valcon env isevars lvar ty in
+              let dcl = (na,None,ty'.utj_val) in
+		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
+          | (na,Some bd,ty)::bl ->
+              let ty' = pretype_type empty_valcon env isevars lvar ty in
+              let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
+              let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
+		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
+	let ctxtv = Array.map (type_bl env empty_rel_context) bl in
+	let larj =
+          array_map2
+            (fun e ar ->
+               pretype_type empty_valcon (push_rel_context e env) isevars lvar ar)
+            ctxtv lar in
+	let lara = Array.map (fun a -> a.utj_val) larj in
+	let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
+	let nbfix = Array.length lar in
+	let names = Array.map (fun id -> Name id) names in
+	  (* Note: bodies are not used by push_rec_types, so [||] is safe *)
+	let newenv = push_rec_types (names,ftys,[||]) env in
+	let vdefj =
+	  array_map2_i 
+	    (fun i ctxt def ->
+               (* we lift nbfix times the type in tycon, because of
+		* the nbfix variables pushed to newenv *)
+               let (ctxt,ty) =
+		 decompose_prod_n_assum (rel_context_length ctxt)
+                   (lift nbfix ftys.(i)) in
+               let nenv = push_rel_context ctxt newenv in
+               let j = pretype (mk_tycon ty) nenv isevars lvar def in
+		 { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
+		   uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
+            ctxtv vdef in
+	evar_type_fixpoint loc env isevars names ftys vdefj;
+	let fixj = match fixkind with
+	  | RFix (vn,i) ->
+	      let guard_indexes = Array.mapi 
+		(fun i (n,_) -> match n with 
+		   | Some n -> n 
+		   | None -> 
+		       (* Recursive argument was not given by the user : We
+			  check that there is only one inductive argument *)
+		       let ctx = ctxtv.(i) in 
+		       let isIndApp t = 
+			 isInd (fst (decompose_app (strip_head_cast t))) in
+			 (* This could be more precise (e.g. do some delta) *)
+		       let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in
+		       try (list_unique_index true lb) - 1
+		       with Not_found -> 
+			 Util.user_err_loc
+			   (loc,"pretype",
+			    Pp.str "cannot guess decreasing argument of fix"))
+		vn 
+	      in
+	      let fix = ((guard_indexes, i),(names,ftys,Array.map j_val vdefj)) in
+	      (try check_fix env fix with e -> Stdpp.raise_with_loc loc e);
+	      make_judge (mkFix fix) ftys.(i)
+	  | RCoFix i -> 
+	      let cofix = (i,(names,ftys,Array.map j_val vdefj)) in
+	      (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
+	      make_judge (mkCoFix cofix) ftys.(i) in
+	inh_conv_coerce_to_tycon loc env isevars fixj tycon
+
+    | RSort (loc,s) ->
+	inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
+
+    | RApp (loc,f,args) -> 
+	let length = List.length args in	 
+	let ftycon = 
+	  match tycon with
+	      None -> None
+	    | Some (None, ty) -> mk_abstr_tycon length ty
+	    | Some (Some (init, cur), ty) ->
+		Some (Some (length + init, length + cur), ty)
+	in
+	let fj = pretype ftycon env isevars lvar f in
+ 	let floc = loc_of_rawconstr f in
+	let rec apply_rec env n resj tycon = function
+	  | [] -> resj
+	  | c::rest ->
+	      let argloc = loc_of_rawconstr c in
+	      let resj = evd_comb1 (Coercion.inh_app_fun env) isevars resj in
+              let resty = whd_betadeltaiota env (evars_of !isevars) resj.uj_type in
+      		match kind_of_term resty with
+		  | Prod (na,c1,c2) ->
+		      let hj = pretype (mk_tycon c1) env isevars lvar c in
+		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
+		      let typ' = nf_isevar !isevars typ in
+		      let tycon = 
+			option_map 
+			  (fun (abs, ty) ->
+			     match abs with
+				 None ->
+				   isevars := Coercion.inh_conv_coerces_to loc env !isevars typ'
+				     (abs, ty);
+				   (abs, ty)
+			       | Some (init, cur) ->
+				   isevars := Coercion.inh_conv_coerces_to loc env !isevars typ' 
+				     (abs, ty);
+				   (Some (init, pred cur), ty))
+			  tycon
+		      in 
+			apply_rec env (n+1) 
+			  { uj_val = nf_isevar !isevars value;
+			    uj_type = nf_isevar !isevars typ' }
+			  (option_map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest
+
+		  | _ ->
+		      let hj = pretype empty_tycon env isevars lvar c in
+			error_cant_apply_not_functional_loc 
+			  (join_loc floc argloc) env (evars_of !isevars)
+	      		  resj [hj]
+	in
+	let ftycon = option_map (lift_abstr_tycon_type (-1)) ftycon in
+	let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in
+	let resj =
+	  match kind_of_term resj.uj_val with
+	  | App (f,args) when isInd f or isConst f ->
+	      let sigma = evars_of !isevars in
+	      let c = mkApp (f,Array.map (whd_evar sigma) args) in
+	      let t = Retyping.get_type_of env sigma c in
+	      make_judge c t
+	  | _ -> resj in
+	  inh_conv_coerce_to_tycon loc env isevars resj tycon
+
+    | RLambda(loc,name,c1,c2)      ->
+	let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in
+	let dom_valcon = valcon_of_tycon dom in
+	let j = pretype_type dom_valcon env isevars lvar c1 in
+	let var = (name,None,j.utj_val) in
+	let j' = pretype rng (push_rel var env) isevars lvar c2 in 
+	  judge_of_abstraction env name j j'
+
+    | RProd(loc,name,c1,c2)        ->
+	let j = pretype_type empty_valcon env isevars lvar c1 in
+	let var = (name,j.utj_val) in
+	let env' = push_rel_assum var env in
+	let j' = pretype_type empty_valcon env' isevars lvar c2 in
+	let resj =
+	  try judge_of_product env name j j'
+	  with TypeError _ as e -> Stdpp.raise_with_loc loc e in
+	  inh_conv_coerce_to_tycon loc env isevars resj tycon
+	    
+    | RLetIn(loc,name,c1,c2)      ->
+	let j = pretype empty_tycon env isevars lvar c1 in
+	let t = refresh_universes j.uj_type in
+	let var = (name,Some j.uj_val,t) in
+        let tycon = lift_tycon 1 tycon in
+	let j' = pretype tycon (push_rel var env) isevars lvar c2 in
+	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
+	    uj_type = subst1 j.uj_val j'.uj_type }
+
+    | RLetTuple (loc,nal,(na,po),c,d) ->
+	let cj = pretype empty_tycon env isevars lvar c in
+	let (IndType (indf,realargs)) = 
+	  try find_rectype env (evars_of !isevars) cj.uj_type
+	  with Not_found ->
+	    let cloc = loc_of_rawconstr c in
+	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj 
+	in
+	let cstrs = get_constructors env indf in
+	  if Array.length cstrs <> 1 then
+            user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
+	  let cs = cstrs.(0) in
+	    if List.length nal <> cs.cs_nargs then
+              user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
+	    let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
+              (List.rev nal) cs.cs_args in
+	    let env_f = push_rels fsign env in
+	      (* Make dependencies from arity signature impossible *)
+	    let arsgn =
+	      let arsgn,_ = get_arity env indf in
+		if not !allow_anonymous_refs then
+		  List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+		else arsgn
+	    in
+	    let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+	    let nar = List.length arsgn in
+	      (match po with
+		 | Some p ->
+		     let env_p = push_rels psign env in
+		     let pj = pretype_type empty_valcon env_p isevars lvar p in
+		     let ccl = nf_evar (evars_of !isevars) pj.utj_val in
+		     let psign = make_arity_signature env true indf in (* with names *)
+		     let p = it_mkLambda_or_LetIn ccl psign in
+		     let inst = 
+		       (Array.to_list cs.cs_concl_realargs)
+		       @[build_dependent_constructor cs] in
+		     let lp = lift cs.cs_nargs p in
+		     let fty = hnf_lam_applist env (evars_of !isevars) lp inst in
+		     let fj = pretype (mk_tycon fty) env_f isevars lvar d in
+		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+		     let v =
+		       let mis,_ = dest_ind_family indf in
+		       let ci = make_default_case_info env LetStyle mis in
+			 mkCase (ci, p, cj.uj_val,[|f|]) in 
+		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
+
+		 | None -> 
+		     let tycon = lift_tycon cs.cs_nargs tycon in
+		     let fj = pretype tycon env_f isevars lvar d in
+		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+		     let ccl = nf_evar (evars_of !isevars) fj.uj_type in
+		     let ccl =
+		       if noccur_between 1 cs.cs_nargs ccl then
+			 lift (- cs.cs_nargs) ccl 
+		       else
+			 error_cant_find_case_type_loc loc env (evars_of !isevars) 
+			   cj.uj_val in
+		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
+		     let v =
+		       let mis,_ = dest_ind_family indf in
+		       let ci = make_default_case_info env LetStyle mis in
+			 mkCase (ci, p, cj.uj_val,[|f|] ) 
+		     in
+		       { uj_val = v; uj_type = ccl })
+
+    | RIf (loc,c,(na,po),b1,b2) ->
+	let cj = pretype empty_tycon env isevars lvar c in
+	let (IndType (indf,realargs)) = 
+	  try find_rectype env (evars_of !isevars) cj.uj_type
+	  with Not_found ->
+	    let cloc = loc_of_rawconstr c in
+	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj in
+	let cstrs = get_constructors env indf in 
+	  if Array.length cstrs <> 2 then
+            user_err_loc (loc,"",
+			  str "If is only for inductive types with two constructors");
+
+	  let arsgn = 
+	    let arsgn,_ = get_arity env indf in
+	      if not !allow_anonymous_refs then
+		(* Make dependencies from arity signature impossible *)
+		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn 
+	      else arsgn
+	  in
+	  let nar = List.length arsgn in
+	  let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+	  let pred,p = match po with
+	    | Some p ->
+		let env_p = push_rels psign env in
+		let pj = pretype_type empty_valcon env_p isevars lvar p in
+		let ccl = nf_evar (evars_of !isevars) pj.utj_val in
+		let pred = it_mkLambda_or_LetIn ccl psign in
+		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
+		let jtyp = inh_conv_coerce_to_tycon loc env isevars {uj_val = pred;
+								     uj_type = typ} tycon 
+		in
+		  jtyp.uj_val, jtyp.uj_type
+	    | None -> 
+		let p = match tycon with
+		  | Some (None, ty) -> ty
+		  | None | Some _ ->
+                      e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ())
+		in
+		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
+	  let pred = nf_evar (evars_of !isevars) pred in
+	  let p = nf_evar (evars_of !isevars) p in
+	 (*   msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
+	  let f cs b =
+	    let n = rel_context_length cs.cs_args in
+	    let pi = lift n pred in (* liftn n 2 pred ? *)
+	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
+	    let csgn = 
+	      if not !allow_anonymous_refs then
+		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args 
+	      else 
+		List.map 
+		  (fun (n, b, t) ->
+		     match n with
+                         Name _ -> (n, b, t)
+                       | Anonymous -> (Name (id_of_string "H"), b, t))
+		cs.cs_args
+	    in
+	    let env_c = push_rels csgn env in 
+(* 	      msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
+	    let bj = pretype (mk_tycon pi) env_c isevars lvar b in
+	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
+	  let b1 = f cstrs.(0) b1 in
+	  let b2 = f cstrs.(1) b2 in
+	  let v =
+	    let mis,_ = dest_ind_family indf in
+	    let ci = make_default_case_info env IfStyle mis in
+	      mkCase (ci, pred, cj.uj_val, [|b1;b2|])
+	  in
+	    { uj_val = v; uj_type = p }
+
+    | RCases (loc,po,tml,eqns) ->
+	Cases.compile_cases loc
+	  ((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
+	  tycon env (* loc *) (po,tml,eqns)
+
+    | RCast(loc,c,k,t) ->
+	let cj =
+	  match k with
+	      CastCoerce ->
+		let cj = pretype empty_tycon env isevars lvar c in
+		  evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj
+	    | CastConv k ->
+		let tj = pretype_type empty_valcon env isevars lvar t in
+		let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
+		  (* User Casts are for helping pretyping, experimentally not to be kept*)
+		  (* ... except for Correctness *)
+		let v = mkCast (cj.uj_val, k, tj.utj_val) in
+		  { uj_val = v; uj_type = tj.utj_val }
+	in
+	  inh_conv_coerce_to_tycon loc env isevars cj tycon
+
+    | RDynamic (loc,d) ->
+	if (tag d) = "constr" then
+	  let c = constr_out d in
+	  let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
+	    j
+	      (*inh_conv_coerce_to_tycon loc env isevars j tycon*)
+	else
+	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic"))
+
+  (* [pretype_type valcon env isevars lvar c] coerces [c] into a type *)
+  and pretype_type valcon env isevars lvar = function
+    | RHole loc ->
+	(match valcon with
+	   | Some v ->
+               let s =
+		 let sigma = evars_of !isevars in
+		 let t = Retyping.get_type_of env sigma v in
+		   match kind_of_term (whd_betadeltaiota env sigma t) with
+                     | Sort s -> s
+                     | Evar v when is_Type (existential_type sigma v) -> 
+			 evd_comb1 (define_evar_as_sort) isevars v
+                     | _ -> anomaly "Found a type constraint which is not a type"
+               in
+		 { utj_val = v;
+		   utj_type = s }
+	   | None ->
+	       let s = new_Type_sort () in
+		 { utj_val = e_new_evar isevars env ~src:loc (mkSort s);
+		   utj_type = s})
+    | c ->
+	let j = pretype empty_tycon env isevars lvar c in
+	let loc = loc_of_rawconstr c in
+	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) isevars j in
+	  match valcon with
+	    | None -> tj
+	    | Some v ->
+		if e_cumul env isevars v tj.utj_val then tj
+		else
+		  error_unexpected_type_loc
+                    (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v
+
+  let pretype_gen isevars env lvar kind c =
+    let c' = match kind with
+      | OfType exptyp ->
+	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
+	    (pretype tycon env isevars lvar c).uj_val
+      | IsType ->
+	  (pretype_type empty_valcon env isevars lvar c).utj_val in
+      nf_evar (evars_of !isevars) c'
+
+  (* TODO: comment faire remonter l'information si le typage a resolu des
+     variables du sigma original. il faudrait que la fonction de typage
+     retourne aussi le nouveau sigma...
+  *)
+
+  let understand_judgment sigma env c =
+    let isevars = ref (create_evar_defs sigma) in
+    let j = pretype empty_tycon env isevars ([],[]) c in
+    let j = j_nf_evar (evars_of !isevars) j in
+    let isevars,_ = consider_remaining_unif_problems env !isevars in
+      check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
+      j
+
+  let understand_judgment_tcc isevars env c =
+    let j = pretype empty_tycon env isevars ([],[]) c in
+    let sigma = evars_of !isevars in
+    let j = j_nf_evar sigma j in
+      j
+
+  (* Raw calls to the unsafe inference machine: boolean says if we must
+     fail on unresolved evars; the unsafe_judgment list allows us to
+     extend env with some bindings *)
+
+  let ise_pretype_gen fail_evar sigma env lvar kind c =
+    let isevars = ref (Evd.create_evar_defs sigma) in
+    let c = pretype_gen isevars env lvar kind c in
+    let isevars,_ = consider_remaining_unif_problems env !isevars in
+    let c = nf_evar (evars_of isevars) c in
+      if fail_evar then check_evars env sigma isevars c;
+      isevars, c
+
+  (** Entry points of the high-level type synthesis algorithm *)
+
+  let understand_gen kind sigma env c =
+    snd (ise_pretype_gen true sigma env ([],[]) kind c)
+
+  let understand sigma env ?expected_type:exptyp c =
+    snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c)
+
+  let understand_type sigma env c =
+    snd (ise_pretype_gen true sigma env ([],[]) IsType c)
+
+  let understand_ltac sigma env lvar kind c =
+    ise_pretype_gen false sigma env lvar kind c
+      
+  let understand_tcc_evars isevars env kind c =
+    pretype_gen isevars env ([],[]) kind c
+
+  let understand_tcc sigma env ?expected_type:exptyp c =
+    let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c in
+      Evd.evars_of ev, t
+end
+
+module Default : S = SubtacPretyping_F(Coercion.Default)
diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml
new file mode 100644
index 00000000..01dee3e9
--- /dev/null
+++ b/contrib/subtac/subtac_utils.ml
@@ -0,0 +1,707 @@
+open Evd
+open Libnames
+open Coqlib
+open Term
+open Names
+open Util
+
+let ($) f x = f x
+
+(****************************************************************************)
+(* Library linking *)
+
+let contrib_name = "subtac"
+
+let subtac_dir = [contrib_name]
+let fix_sub_module = "FixSub"
+let utils_module = "Utils"
+let fixsub_module = subtac_dir @ [fix_sub_module]
+let utils_module = subtac_dir @ [utils_module]
+let init_constant dir s = gen_constant contrib_name dir s
+let init_reference dir s = gen_reference contrib_name dir s
+
+let fixsub = lazy (init_constant fixsub_module "Fix_sub")
+let ex_pi1 = lazy (init_constant utils_module "ex_pi1")
+let ex_pi2 = lazy (init_constant utils_module "ex_pi2")
+
+let make_ref l s = lazy (init_reference l s)
+let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded"
+let acc_ref = make_ref  ["Init";"Wf"] "Acc"
+let acc_inv_ref = make_ref  ["Init";"Wf"] "Acc_inv"
+let fix_sub_ref = make_ref ["subtac";"FixSub"] "Fix_sub"
+let fix_measure_sub_ref = make_ref ["subtac";"FixSub"] "Fix_measure_sub"
+let lt_ref = make_ref ["Init";"Peano"] "lt"
+let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf"
+
+let make_ref s = Qualid (dummy_loc, qualid_of_string s)
+let sig_ref = make_ref "Init.Specif.sig"
+let proj1_sig_ref = make_ref "Init.Specif.proj1_sig"
+let proj2_sig_ref = make_ref "Init.Specif.proj2_sig"
+
+let build_sig () = 
+  { proj1 = init_constant ["Init"; "Specif"] "proj1_sig";
+    proj2 = init_constant ["Init"; "Specif"] "proj2_sig";
+    elim = init_constant ["Init"; "Specif"] "sig_rec";
+    intro = init_constant ["Init"; "Specif"] "exist";
+    typ = init_constant ["Init"; "Specif"] "sig" }
+
+let sig_ = lazy (build_sig ())
+
+let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq")
+let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec")
+let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect")
+let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal")
+let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq")
+let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal")
+
+let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep")
+let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec")
+let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep")
+let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro")
+
+let jmeq_ind = lazy (init_constant ["Logic";"JMeq"] "JMeq")
+let jmeq_rec = lazy (init_constant ["Logic";"JMeq"] "JMeq_rec")
+let jmeq_ind_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq")
+let jmeq_refl_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq_refl")
+
+let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex")
+let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro")
+
+let proj1 = lazy (init_constant ["Init"; "Logic"] "proj1")
+let proj2 = lazy (init_constant ["Init"; "Logic"] "proj2")
+
+let boolind = lazy (init_constant ["Init"; "Datatypes"] "bool")
+let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool")
+let natind = lazy (init_constant ["Init"; "Datatypes"] "nat")
+let intind = lazy (init_constant ["ZArith"; "binint"] "Z")
+let existSind = lazy (init_constant ["Init"; "Specif"] "sigS")
+  
+let existS = lazy (build_sigma_type ())
+
+let prod = lazy (build_prod ())
+
+
+(* orders *)
+let well_founded = lazy (init_constant ["Init"; "Wf"] "well_founded")
+let fix = lazy (init_constant ["Init"; "Wf"] "Fix")
+let acc = lazy (init_constant ["Init"; "Wf"] "Acc")
+let acc_inv = lazy (init_constant ["Init"; "Wf"] "Acc_inv")
+
+let extconstr = Constrextern.extern_constr true (Global.env ())
+let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s)
+
+open Pp
+
+let my_print_constr = Termops.print_constr_env
+let my_print_constr_expr = Ppconstr.pr_constr_expr
+let my_print_rel_context env ctx = Printer.pr_rel_context env ctx
+let my_print_context = Termops.print_rel_context
+let my_print_named_context = Termops.print_named_context
+let my_print_env = Termops.print_env
+let my_print_rawconstr = Printer.pr_rawconstr_env
+let my_print_evardefs = Evd.pr_evar_defs
+
+let my_print_tycon_type = Evarutil.pr_tycon_type
+
+let debug_level = 2
+
+let debug_on = true
+
+let debug n s = 
+  if debug_on then
+    if !Options.debug && n >= debug_level then
+      msgnl s
+    else ()
+  else ()
+
+let debug_msg n s = 
+  if debug_on then
+    if !Options.debug  && n >= debug_level then s
+    else mt ()
+  else mt ()
+
+let trace s = 
+  if debug_on then
+    if !Options.debug  && debug_level > 0 then msgnl s
+    else ()
+  else ()
+
+let wf_relations = Hashtbl.create 10
+
+let std_relations () = 
+  let add k v = Hashtbl.add wf_relations k v in
+    add (init_constant ["Init"; "Peano"] "lt")
+      (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf"))
+      
+let std_relations = Lazy.lazy_from_fun std_relations
+
+type binders = Topconstr.local_binder list
+
+let app_opt c e = 
+  match c with
+      Some constr -> constr e
+    | None -> e	
+
+let print_args env args = 
+  Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "")
+
+let make_existential loc env isevars c =
+  let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark) c in
+  let (key, args) = destEvar evar in
+    (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++
+		  print_args env args ++ str " for type: "++ 
+		  my_print_constr env c) with _ -> ());
+    evar
+
+let make_existential_expr loc env c =
+  let key = Evarutil.new_untyped_evar () in
+  let evar = Topconstr.CEvar (loc, key) in
+    debug 2 (str "Constructed evar " ++ int key);
+    evar
+
+let string_of_hole_kind = function
+  | ImplicitArg _ -> "ImplicitArg"
+  | BinderType _ -> "BinderType"
+  | QuestionMark -> "QuestionMark"
+  | CasesType -> "CasesType"
+  | InternalHole -> "InternalHole"
+  | TomatchTypeParameter _ -> "TomatchTypeParameter"
+      
+let non_instanciated_map env evd =
+  let evm = evars_of !evd in
+    List.fold_left 
+      (fun evm (key, evi) -> 
+	 let (loc,k) = evar_source key !evd in
+	   debug 2 (str "evar " ++ int key ++ str " has kind " ++ 
+		      str (string_of_hole_kind k));
+	   match k with 
+	       QuestionMark -> Evd.add evm key evi
+	     | _ ->
+	       debug 2 (str " and is an implicit");
+	       Pretype_errors.error_unsolvable_implicit loc env evm k)
+      Evd.empty (Evarutil.non_instantiated evm)
+
+let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition
+let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition
+
+let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma
+let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma
+
+let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint
+let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint
+
+open Tactics
+open Tacticals
+
+let id x = x
+let filter_map f l = 
+  let rec aux acc = function
+      hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
+		     | None -> aux acc tl)
+    | [] -> List.rev acc
+  in aux [] l
+
+let build_dependent_sum l =
+  let rec aux names conttac conttype = function
+      (n, t) :: ((_ :: _) as tl) ->
+	let hyptype = substl names t in
+	  trace (spc () ++ str ("treating evar " ^ string_of_id n));
+	  (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype)
+	   with _ -> ());
+	let tac = assert_tac true (Name n) hyptype in
+	let conttac = 
+	  (fun cont -> 
+	     conttac
+	     (tclTHENS tac
+		([intros;
+		  (tclTHENSEQ 
+		     [constructor_tac (Some 1) 1 
+			(Rawterm.ImplicitBindings [mkVar n]);
+		      cont]);
+		 ])))
+	in
+	let conttype = 
+	  (fun typ -> 
+	     let tex = mkLambda (Name n, t, typ) in
+	       conttype
+		 (mkApp (Lazy.force ex_ind, [| t; tex |])))
+	in
+	  aux (mkVar n :: names) conttac conttype tl
+    | (n, t) :: [] -> 
+	(conttac intros, conttype t)
+    | [] -> raise (Invalid_argument "build_dependent_sum")
+  in aux [] id id (List.rev l)       
+	  
+open Proof_type
+open Tacexpr
+
+let mkProj1 a b c = 
+  mkApp (Lazy.force proj1, [| a; b; c |])
+
+let mkProj2 a b c = 
+  mkApp (Lazy.force proj2, [| a; b; c |])
+
+let mk_ex_pi1 a b c =
+  mkApp (Lazy.force ex_pi1, [| a; b; c |])
+
+let mk_ex_pi2 a b c =
+  mkApp (Lazy.force ex_pi2, [| a; b; c |])
+    
+
+let mkSubset name typ prop = 
+  mkApp ((Lazy.force sig_).typ,
+	 [| typ; mkLambda (name, typ, prop) |])
+
+let and_tac l hook =
+  let andc = Coqlib.build_coq_and () in      
+  let rec aux ((accid, goal, tac, extract) as acc) = function
+    | [] -> (* Singleton *) acc
+	
+    | (id, x, elgoal, eltac) :: tl ->
+	let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in
+	let proj = fun c -> mkProj2 goal elgoal c in
+	let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in
+	  aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', 
+	       (id, x, elgoal, proj) :: extract) tl
+
+  in
+  let and_proof_id, and_goal, and_tac, and_extract = 
+    match l with
+      | [] -> raise (Invalid_argument "and_tac: empty list of goals")
+      | (hdid, x, hdg, hdt) :: tl -> 
+	  aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl
+  in
+  let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in
+    Command.start_proof and_proofid goal_kind and_goal
+      (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract));
+    trace (str "Started and proof");
+    Pfedit.by and_tac;
+    trace (str "Applied and tac")
+      
+
+let destruct_ex ext ex = 
+  let rec aux c acc = 
+    match kind_of_term c with
+	App (f, args) ->
+	  (match kind_of_term f with
+	       Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 ->
+		 let (dom, rng) = 
+		   try (args.(0), args.(1))
+		   with _ -> assert(false)
+		 in
+		 let pi1 = (mk_ex_pi1 dom rng acc) in
+		 let rng_body = 
+		   match kind_of_term rng with
+		       Lambda (_, _, t) -> subst1 pi1 t
+		     | t -> rng
+		 in
+		   pi1 :: aux rng_body (mk_ex_pi2 dom rng acc)
+	     | _ -> [acc])
+      | _ -> [acc]
+  in aux ex ext
+
+open Rawterm
+
+let rec concatMap f l = 
+  match l with
+      hd :: tl -> f hd @ concatMap f tl      
+    | [] -> []
+	
+let list_mapi f = 
+  let rec aux i = function 
+      hd :: tl -> f i hd :: aux (succ i) tl 
+    | [] -> []
+  in aux 0
+
+(*
+let make_discr (loc, po, tml, eqns) =
+  let mkHole = RHole (dummy_loc, InternalHole) in
+  
+  let rec vars_of_pat = function
+      RPatVar (loc, n) -> (match n with Anonymous -> [] | Name n -> [n])
+    | RPatCstr (loc, csrt, pats, _) -> 
+	concatMap vars_of_pat pats
+  in
+  let rec constr_of_pat l = function 
+      RPatVar (loc, n) -> 
+	(match n with 
+	     Anonymous -> 
+	       let n = next_name_away_from "x" l in
+		 RVar n, (n :: l)
+	   | Name n -> RVar n, l)
+    | RPatCstr (loc, csrt, pats, _) -> 
+	let (args, vars) =
+	  List.fold_left
+	    (fun (args, vars) x ->
+	       let c, vars = constr_of_pat vars x in
+		 c :: args, vars)
+	    ([], l) pats
+	in		 
+	  RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars
+  in
+  let rec constr_of_pat l = function 
+      RPatVar (loc, n) -> 
+	(match n with 
+	     Anonymous -> 
+	       let n = next_name_away_from "x" l in
+		 RVar n, (n :: l)
+	   | Name n -> RVar n, l)
+    | RPatCstr (loc, csrt, pats, _) -> 
+	let (args, vars) =
+	  List.fold_left
+	    (fun (args, vars) x ->
+	       let c, vars = constr_of_pat vars x in
+		 c :: args, vars)
+	    ([], l) pats
+	in		 
+	  RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars
+  in
+  let constrs_of_pats v l =
+    List.fold_left 
+      (fun (v, acc) x -> 
+	 let x', v' = constr_of_pat v x in
+	   (l', v' :: acc))
+      (v, []) l
+  in
+  let rec pat_of_pat l = function
+      RPatVar (loc, n) -> 
+	let n', l = match n with
+	    Anonymous -> 
+	      let n = next_name_away_from "x" l in
+		n, n :: l
+	  | Name n -> n, n :: l 
+	in
+	  RPatVar (loc, Name n'), l
+    | RPatCstr (loc, cstr, pats, (loc, alias)) ->
+	let args, vars, s = 
+	  List.fold_left (fun (args, vars) x -> 
+			    let pat', vars = pat_of_pat vars pat in
+			      pat' :: args, vars)
+	    ([], alias :: l) pats
+	in RPatCstr (loc, cstr, args, (loc, alias)), vars
+  in
+  let pats_of_pats l =
+    List.fold_left 
+      (fun (v, acc) x -> 
+	 let x', v' = pat_of_pat v x in
+	   (v', x' :: acc))
+      ([], []) l
+  in
+  let eq_of_pat p used c = 
+    let constr, vars' = constr_of_pat used p in
+    let eq = RApp (dummy_loc, RRef (dummy_loc, Lazy.force eqind_ref), [mkHole; constr; c]) in
+      vars', eq
+  in
+  let eqs_of_pats ps used cstrs =
+    List.fold_left2 
+      (fun (vars, eqs) pat c ->
+	 let (vars', eq) = eq_of_pat pat c in
+	   match eqs with 
+	       None -> Some eq 
+	     | Some eqs ->
+		 Some (RApp (dummy_loc, RRef (dummy_loc, Lazy.force and_ref), [eq, eqs])))
+      (used, None) ps cstrs
+  in
+  let quantify c l =
+    List.fold_left
+      (fun acc name -> RProd (dummy_loc, name, mkHole, acc))
+      c l
+  in
+  let quantpats = 
+    List.fold_left
+      (fun (acc, pats) ((loc, idl, cpl, c) as x) ->
+	 let vars, cpl = pats_of_pats cpl in
+	 let l', constrs = constrs_of_pats vars cpl in	   
+	 let discrs = 
+	   List.map (fun (_, _, cpl', _) -> 
+		       let qvars, eqs = eqs_of_pats cpl' l' constrs in
+		       let neg = RApp (dummy_loc, RRef (dummy_loc, Lazy.force not_ref), [out_some eqs]) in
+		       let pat_ineq = quantify qvars neg in
+			 
+		    )
+	     pats in
+	   
+			 
+
+
+	   
+	   
+
+	   (x, pat_ineq))
+  in
+    List.fold_left 
+      (fun acc ((loc, idl, cpl, c0) pat) -> 
+    
+		
+		let c' = 
+		  List.fold_left 
+		    (fun acc (n, t) ->
+		       RLambda (dummy_loc, n, mkHole, acc))
+		    c eqs_types
+		in (loc, idl, cpl, c'))
+      eqns
+  i
+*)
+(* let rewrite_cases_aux (loc, po, tml, eqns) = *)
+(*   let tml = list_mapi (fun i (c, (n, opt)) -> c,  *)
+(* 		       ((match n with *)
+(* 			    Name id -> (match c with *)
+(* 					  | RVar (_, id') when id = id' -> *)
+(* 					      Name (id_of_string (string_of_id id ^ "'")) *)
+(* 					  | _ -> n) *)
+(* 			  | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))), *)
+(* 			opt)) tml  *)
+(*   in *)
+(*   let mkHole = RHole (dummy_loc, InternalHole) in *)
+(*   (\* let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), *\) *)
+(* (\* 		       [mkHole; c; n]) *\) *)
+(* (\*   in *\) *)
+(*   let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqdep_ind_ref)), *)
+(* 		       [mkHole; c; mkHole; n]) *)
+(*   in *)
+(*   let eqs_types =  *)
+(*     List.map *)
+(*       (fun (c, (n, _)) -> *)
+(* 	 let id = match n with Name id -> id | _ -> assert false in *)
+(* 	 let heqid = id_of_string ("Heq" ^ string_of_id id) in *)
+(* 	   Name heqid, mkeq c (RVar (dummy_loc, id))) *)
+(*       tml *)
+(*   in *)
+(*   let po =  *)
+(*     List.fold_right *)
+(*       (fun (n,t) acc -> *)
+(* 	 RProd (dummy_loc, Anonymous, t, acc)) *)
+(*       eqs_types (match po with  *)
+(* 		     Some e -> e *)
+(* 		   | None -> mkHole) *)
+(*   in *)
+(*   let eqns =    *)
+(*     List.map (fun (loc, idl, cpl, c) -> *)
+(* 		let c' =  *)
+(* 		  List.fold_left  *)
+(* 		    (fun acc (n, t) -> *)
+(* 		       RLambda (dummy_loc, n, mkHole, acc)) *)
+(* 		    c eqs_types *)
+(* 		in (loc, idl, cpl, c')) *)
+(*       eqns *)
+(*   in *)
+(*   let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *)
+(* 			      [mkHole; c]) *)
+(*   in *)
+(*   (\*let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *)
+(* 			      [mkHole; c]) *)
+(*   in*\) *)
+(*   let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in *)
+(*   let case = RCases (loc,Some po,tml,eqns) in *)
+(*   let app = RApp (dummy_loc, case, refls) in *)
+(*     app *)
+
+(* let rec rewrite_cases c =  *)
+(*   match c with  *)
+(*       RCases _ -> let c' = map_rawconstr rewrite_cases c in *)
+(* 	(match c' with  *)
+(* 	   | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) *)
+(* 	   | _ -> assert(false)) *)
+(*     | _ -> map_rawconstr rewrite_cases c *)
+	  
+(* let rewrite_cases env c = *)
+(*   let c' = rewrite_cases c in *)
+(*   let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *)
+(*     c' *)
+
+let list_mapi f = 
+  let rec aux i = function 
+      hd :: tl -> f i hd :: aux (succ i) tl 
+    | [] -> []
+  in aux 0
+
+open Rawterm
+
+let rewrite_cases_aux (loc, po, tml, eqns) =
+  let tml' = list_mapi (fun i (c, (n, opt)) -> c, 
+		       ((match n with
+			    Name id -> (match c with
+					  | RVar (_, id') when id = id' ->
+					      id, (id_of_string (string_of_id id ^ "Heq_id"))
+					  | RVar (_, id') ->
+					      id', id
+					  | _ -> id_of_string (string_of_id id ^ "Heq_id"), id)
+			   | Anonymous -> 
+			       let str = "Heq_id" ^ string_of_int i in
+				 id_of_string str, id_of_string (str ^ "'")),
+			opt)) tml 
+  in
+  let mkHole = RHole (dummy_loc, InternalHole) in
+  let mkCoerceCast c = RCast (dummy_loc, c, CastCoerce, mkHole) in
+  let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eq_ind_ref)),
+		       [mkHole; c; n])
+  in
+  let eqs_types = 
+    List.map
+      (fun (c, ((id, id'), _)) ->
+	 let heqid = id_of_string ("Heq" ^ string_of_id id) in
+	   Name heqid, mkeq (RVar (dummy_loc, id')) c)
+      tml'
+  in
+  let po = 
+    List.fold_right
+      (fun (n,t) acc ->
+	 RProd (dummy_loc, Anonymous, t, acc))
+      eqs_types (match po with 
+		     Some e -> e
+		   | None -> mkHole)
+  in
+  let eqns =   
+    List.map (fun (loc, idl, cpl, c) ->
+		let c' = 
+		  List.fold_left 
+		    (fun acc (n, t) ->
+		       RLambda (dummy_loc, n, mkHole, acc))
+		    c eqs_types
+		in (loc, idl, cpl, c'))
+      eqns
+  in
+  let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref),
+			      [mkHole; c])
+  in
+  let refls = List.map (fun (c, ((id, _), _)) -> mk_refl_equal (mkCoerceCast c)) tml' in
+  let tml'' = List.map (fun (c, ((id, id'), opt)) -> c, (Name id', opt)) tml' in
+  let case = RCases (loc,Some po,tml'',eqns) in
+  let app = RApp (dummy_loc, case, refls) in
+(*   let letapp = List.fold_left (fun acc (c, ((id, id'), opt)) -> RLetIn (dummy_loc, Name id, c, acc)) *)
+(* 		 app tml' *)
+(*   in *)
+    app
+
+let rec rewrite_cases c = 
+  match c with 
+      RCases _ -> let c' = map_rawconstr rewrite_cases c in
+	(match c' with 
+	   | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w)
+	   | _ -> assert(false))
+    | _ -> map_rawconstr rewrite_cases c
+	  
+let rewrite_cases env c = c
+(*   let c' = rewrite_cases c in *)
+(*   let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *)
+(*     c' *)
+
+let id_of_name = function
+    Name n -> n
+  | Anonymous -> raise (Invalid_argument "id_of_name")
+
+let definition_message id =
+  Options.if_verbose message ((string_of_id id) ^ " is defined")
+
+let recursive_message v =
+  match Array.length v with
+    | 0 -> error "no recursive definition"
+    | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined")
+    | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
+		    spc () ++ str "are recursively defined")
+
+(* Solve an obligation using tactics, return the corresponding proof term *)
+(*
+let solve_by_tac ev t =
+  debug 1 (str "Solving goal using tactics: " ++ Evd.pr_evar_info ev);
+  let goal = Proof_trees.mk_goal ev.evar_hyps ev.evar_concl None in
+  debug 1 (str "Goal created");
+  let ts = Tacmach.mk_pftreestate goal in
+  debug 1 (str "Got pftreestate");
+  let solved_state = Tacmach.solve_pftreestate t ts in
+  debug 1 (str "Solved goal");
+    let _, l = Tacmach.extract_open_pftreestate solved_state in
+      List.iter (fun (_, x) -> debug 1 (str "left hole of type " ++ my_print_constr (Global.env()) x)) l;
+    let c = Tacmach.extract_pftreestate solved_state in
+    debug 1 (str "Extracted term");
+    debug 1 (str "Term constructed in solve by tac: " ++ my_print_constr (Global.env ()) c);
+    c
+    *)
+
+let solve_by_tac evi t =
+  debug 2 (str "Solving goal using tactics: " ++ Evd.pr_evar_info evi);
+  let id = id_of_string "H" in
+  try 
+    Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl
+    (fun _ _ -> ());
+    debug 2 (str "Started proof");
+    Pfedit.by (tclCOMPLETE t);
+    let _,(const,_,_) = Pfedit.cook_proof () in 
+      Pfedit.delete_current_proof (); const.Entries.const_entry_body
+  with e -> 
+    Pfedit.delete_current_proof();
+    raise Exit
+
+let rec string_of_list sep f = function
+    [] -> ""
+  | x :: [] -> f x
+  | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
+
+let string_of_intset d = 
+  string_of_list "," string_of_int (Intset.elements d)
+
+(**********************************************************)
+(* Pretty-printing *)
+open Printer
+open Ppconstr
+open Nameops
+open Termops
+open Evd
+
+let pr_meta_map evd =
+  let ml = meta_list evd in
+  let pr_name = function
+      Name id -> str"[" ++ pr_id id ++ str"]"
+    | _ -> mt() in
+  let pr_meta_binding = function
+    | (mv,Cltyp (na,b)) ->
+      	hov 0 
+	  (pr_meta mv ++ pr_name na ++ str " : " ++
+           print_constr b.rebus ++ fnl ())
+    | (mv,Clval(na,b,_)) ->
+      	hov 0 
+	  (pr_meta mv ++ pr_name na ++ str " := " ++
+             print_constr b.rebus ++ fnl ())
+  in
+  prlist pr_meta_binding ml    
+
+let pr_idl idl = prlist_with_sep pr_spc pr_id idl
+
+let pr_evar_info evi =
+  let phyps = 
+    (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *)
+    Printer.pr_named_context (Global.env()) (evar_context evi)
+  in
+  let pty = print_constr evi.evar_concl in
+  let pb =
+    match evi.evar_body with
+      | Evar_empty -> mt ()
+      | Evar_defined c -> spc() ++ str"=> "  ++ print_constr c
+  in
+  hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
+
+let pr_evar_map sigma =
+  h 0 
+    (prlist_with_sep pr_fnl
+      (fun (ev,evi) ->
+        h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
+      (to_list sigma))
+
+let pr_constraints pbs =
+  h 0
+    (prlist_with_sep pr_fnl (fun (pbty,t1,t2) ->
+      print_constr t1 ++ spc() ++
+      str (match pbty with
+	| Reduction.CONV -> "=="
+	| Reduction.CUMUL -> "<=") ++ 
+      spc() ++ print_constr t2) pbs)
+
+let pr_evar_defs evd =
+  let pp_evm =
+    let evars = evars_of evd in
+    if evars = empty then mt() else
+      str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in
+  let pp_met =
+    if meta_list evd = [] then mt() else
+      str"METAS:"++brk(0,1)++pr_meta_map evd in
+  v 0 (pp_evm ++ pp_met)
diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli
new file mode 100644
index 00000000..482640f9
--- /dev/null
+++ b/contrib/subtac/subtac_utils.mli
@@ -0,0 +1,116 @@
+open Term
+open Libnames
+open Coqlib
+open Environ
+open Pp
+open Evd
+open Decl_kinds
+open Topconstr
+open Rawterm
+open Util
+open Evarutil
+open Names
+open Sign
+
+val ($) : ('a -> 'b) -> 'a -> 'b
+val contrib_name : string
+val subtac_dir : string list
+val fix_sub_module : string
+val fixsub_module : string list
+val init_constant : string list -> string -> constr
+val init_reference : string list -> string -> global_reference
+val fixsub : constr lazy_t
+val well_founded_ref : global_reference lazy_t
+val acc_ref : global_reference lazy_t
+val acc_inv_ref : global_reference lazy_t
+val fix_sub_ref : global_reference lazy_t
+val fix_measure_sub_ref : global_reference lazy_t
+val lt_ref : global_reference lazy_t
+val lt_wf_ref : global_reference lazy_t
+val sig_ref : reference
+val proj1_sig_ref : reference
+val proj2_sig_ref : reference
+val build_sig : unit -> coq_sigma_data
+val sig_ : coq_sigma_data lazy_t
+
+val eq_ind : constr lazy_t
+val eq_rec : constr lazy_t
+val eq_rect : constr lazy_t
+val eq_refl : constr lazy_t
+val eq_ind_ref : global_reference lazy_t
+val refl_equal_ref : global_reference lazy_t
+
+val eqdep_ind : constr lazy_t
+val eqdep_rec : constr lazy_t
+val eqdep_ind_ref : global_reference lazy_t
+val eqdep_intro_ref : global_reference lazy_t
+
+val boolind : constr lazy_t
+val sumboolind : constr lazy_t
+val natind : constr lazy_t
+val intind : constr lazy_t
+val existSind : constr lazy_t
+val existS : coq_sigma_data lazy_t
+val prod : coq_sigma_data lazy_t
+
+val well_founded : constr lazy_t
+val fix : constr lazy_t
+val acc : constr lazy_t
+val acc_inv : constr lazy_t
+val extconstr : constr -> constr_expr
+val extsort : sorts -> constr_expr
+
+val my_print_constr : env -> constr -> std_ppcmds
+val my_print_constr_expr : constr_expr -> std_ppcmds
+val my_print_evardefs : evar_defs -> std_ppcmds
+val my_print_context : env -> std_ppcmds
+val my_print_rel_context : env -> rel_context -> std_ppcmds
+val my_print_named_context : env -> std_ppcmds
+val my_print_env : env -> std_ppcmds
+val my_print_rawconstr : env -> rawconstr -> std_ppcmds
+val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds
+
+
+val debug : int -> std_ppcmds -> unit
+val debug_msg : int -> std_ppcmds -> std_ppcmds
+val trace : std_ppcmds -> unit
+val wf_relations : (constr, constr lazy_t) Hashtbl.t
+
+type binders = local_binder list
+val app_opt : ('a -> 'a) option -> 'a -> 'a
+val print_args : env -> constr array -> std_ppcmds
+val make_existential : loc -> env -> evar_defs ref -> types -> constr
+val make_existential_expr : loc -> 'a -> 'b -> constr_expr
+val string_of_hole_kind : hole_kind -> string
+val non_instanciated_map : env -> evar_defs ref -> evar_map
+val global_kind : logical_kind
+val goal_kind : locality_flag * goal_object_kind
+val global_proof_kind : logical_kind
+val goal_proof_kind : locality_flag * goal_object_kind
+val global_fix_kind : logical_kind
+val goal_fix_kind : locality_flag * goal_object_kind
+
+val mkSubset : name -> constr -> constr -> constr
+val mkProj1 : constr -> constr -> constr -> constr
+val mkProj1 : constr -> constr -> constr -> constr
+val mk_ex_pi1 : constr -> constr -> constr -> constr
+val mk_ex_pi1 : constr -> constr -> constr -> constr
+
+val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types
+val and_tac : (identifier * 'a * constr * Proof_type.tactic) list ->  
+  ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit
+
+val destruct_ex : constr -> constr -> constr list
+
+val rewrite_cases : Environ.env -> Rawterm.rawconstr -> Rawterm.rawconstr
+val id_of_name : name -> identifier
+
+val definition_message : identifier -> unit
+val recursive_message : global_reference array -> std_ppcmds
+
+val solve_by_tac : evar_info -> Tacmach.tactic -> constr
+
+val string_of_list : string -> ('a -> string) -> 'a list -> string
+val string_of_intset : Intset.t -> string
+
+val pr_evar_defs : evar_defs -> Pp.std_ppcmds
diff --git a/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v
new file mode 100644
index 00000000..7ab720f6
--- /dev/null
+++ b/contrib/subtac/test/ListDep.v
@@ -0,0 +1,86 @@
+Require Import List.
+Require Import Coq.subtac.Utils.
+
+Set Implicit Arguments.
+
+Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l.
+
+Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'.
+Proof.
+  intros.
+  inversion H.
+  split.
+  intros.
+  apply H0.
+  auto with datatypes.
+  auto with arith.
+Qed.
+
+Section Map_DependentRecursor.
+  Variable U V : Set.
+  Variable l : list U.
+  Variable f : { x : U | In x l } -> V.
+
+  Program Fixpoint map_rec ( l' : list U | sub_list l' l )
+    { measure l' length } : { r : list V | length r = length l' } :=
+    match l' with
+    nil => nil
+    | cons x tl => let tl' := map_rec tl in
+	f x :: tl'
+    end.
+    
+    Obligation 1.
+    intros.
+    destruct tl' ; simpl ; simpl in e.
+    subst x0 tl0.
+    rewrite <- Heql'.
+    rewrite e.
+    auto.
+    Qed.
+
+    Obligation 2.
+    simpl.
+    intros.
+    destruct l'.
+    simpl in Heql'.
+    destruct x0 ; simpl ; try discriminate.
+    inversion Heql'.
+    inversion s.
+    apply H.
+    auto with datatypes.
+    Qed.
+
+
+    Obligation 3 of map_rec.
+    simpl.
+    intros.
+    rewrite <- Heql'.
+    simpl ; auto with arith.
+    Qed.
+
+    Obligation 4.
+    simpl.
+    intros.
+    destruct l'.
+    simpl in Heql'.
+    destruct x0 ; simpl ; try discriminate.
+    inversion Heql'.
+    subst x tl.
+    apply sub_list_tl with u ; auto.
+    Qed.
+  
+    Obligation 5.
+    intros.
+    rewrite <- Heql' ; auto.
+    Qed.
+    
+    Program Definition map : list V := map_rec l.
+    Obligation 1.
+      split ; auto.
+    Qed.
+    
+End Map_DependentRecursor.
+
+Extraction map.
+Extraction map_rec.
+
diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v
new file mode 100644
index 00000000..b8d13fe6
--- /dev/null
+++ b/contrib/subtac/test/ListsTest.v
@@ -0,0 +1,76 @@
+(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
+Require Import Coq.subtac.Utils.
+Require Import List.
+
+Set Implicit Arguments.
+
+Section Accessors.
+  Variable A : Set.
+
+  Program Definition myhd : forall { l : list A | length l <> 0 }, A :=  
+    fun l =>
+      match l with
+        | nil => !
+        | hd :: tl => hd
+      end.
+
+  Program Definition mytail (l : list A | length l <> 0) : list A :=
+    match l with
+      | nil => !
+      | hd :: tl => tl
+    end.
+End Accessors.
+
+Program Definition test_hd : nat := myhd (cons 1 nil).
+
+(*Eval compute in test_hd*)
+(*Program Definition test_tail : list A := mytail nil.*)
+
+Section app.
+  Variable A : Set.
+
+  Program Fixpoint app (l : list A) (l' : list A) { struct l } :
+    { r : list A | length r = length l + length l' } :=
+    match l with
+      | nil => l'
+      | hd :: tl => hd :: (tl ++ l')
+    end 
+    where "x ++ y" := (app x y).
+
+  Next Obligation.
+    intros.
+    destruct_call app ; subtac_simpl.
+  Defined.
+  
+  Program Lemma app_id_l : forall l : list A, l = nil ++ l.
+  Proof.
+    simpl ; auto.
+  Qed.
+  
+  Program Lemma app_id_r : forall l : list A, l = l ++ nil.
+  Proof.
+    induction l ; simpl ; auto.
+    rewrite <- IHl ; auto.
+  Qed.
+
+End app.
+
+Extraction app.
+
+Section Nth.
+
+  Variable A : Set.
+
+  Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := 
+    match n, l with
+      | 0, hd :: _ => hd
+      | S n', _ :: tl => nth tl n'
+      | _, nil => !
+    end.
+
+  Next Obligation.
+  Proof.
+    inversion l0.
+  Defined.
+End Nth.
+
diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v
new file mode 100644
index 00000000..0b40ef82
--- /dev/null
+++ b/contrib/subtac/test/Mutind.v
@@ -0,0 +1,13 @@
+Program Fixpoint f (a : nat) : nat := 
+  match a with
+  | 0 => 0
+  | S a' => g a a'
+  end
+with g (a b : nat) { struct b } : nat := 
+  match b with
+  | 0 => 0
+  | S b' => f b'
+  end.
+
+Check f.
+Check g.
\ No newline at end of file
diff --git a/contrib/subtac/test/Test1.v b/contrib/subtac/test/Test1.v
new file mode 100644
index 00000000..14b80854
--- /dev/null
+++ b/contrib/subtac/test/Test1.v
@@ -0,0 +1,16 @@
+Program Definition test (a b : nat) : { x : nat | x = a + b } := 
+  ((a + b) : { x : nat | x = a + b }).
+Proof.
+intros.
+reflexivity.
+Qed.
+
+Print test.
+
+Require Import List.
+
+Program hd_opt (l : list nat) : { x : nat | x <> 0 } :=
+  match l with
+    nil => 1
+    | a :: l => a
+  end.
diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v
new file mode 100644
index 00000000..a5a8b85f
--- /dev/null
+++ b/contrib/subtac/test/euclid.v
@@ -0,0 +1,27 @@
+Require Import Coq.subtac.Utils.
+Require Import Coq.Arith.Compare_dec.
+Notation "( x & y )" := (existS _ x y) : core_scope.
+  
+Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a}  :
+  { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
+  if le_lt_dec b a then let (q', r) := euclid (a - b) b in 
+  (S q' & r)
+  else (O & a).
+
+Require Import Omega.
+
+Obligations.
+Solve Obligations using subtac_simpl ; omega.
+
+Next Obligation.
+  assert(x0 * S q' = x0 * q' + x0) by auto with arith ; omega.
+Defined.
+
+Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q).
+
+Eval lazy beta zeta delta iota in test_euclid.
+
+Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } :=
+  (a & S a).
+
+Check testsig.
diff --git a/contrib/subtac/test/id.v b/contrib/subtac/test/id.v
new file mode 100644
index 00000000..9ae11088
--- /dev/null
+++ b/contrib/subtac/test/id.v
@@ -0,0 +1,46 @@
+Require Coq.Arith.Arith.
+
+Require Import Coq.subtac.Utils.
+Program Fixpoint id (n : nat) : { x : nat | x = n } :=
+  match n with
+  | O => O
+  | S p => S (id p)
+  end.
+intros ; auto.
+
+pose (subset_simpl (id p)).
+simpl in e.
+unfold p0.
+rewrite e.
+auto.
+Defined.
+
+Check id.
+Print id.
+Extraction id.
+
+Axiom le_gt_dec : forall n m, { n <= m } + { n > m }.
+Require Import Omega.
+
+Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } :=
+  if le_gt_dec n 0 then 0
+  else S (id_if (pred n)).
+intros.
+auto with arith.
+intros.
+pose (subset_simpl (id_if (pred n))).
+simpl in e.
+rewrite e.
+induction n ; auto with arith.
+Defined.
+
+Print id_if_instance.
+Extraction id_if_instance.
+
+Notation "( x & y )" := (@existS _ _ x y) : core_scope.
+
+Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} :=
+  (a & a).
+intros.
+auto.
+Qed.
diff --git a/contrib/subtac/test/measure.v b/contrib/subtac/test/measure.v
new file mode 100644
index 00000000..4764037d
--- /dev/null
+++ b/contrib/subtac/test/measure.v
@@ -0,0 +1,24 @@
+Notation "( x & y )" := (@existS _ _ x y) : core_scope.
+Unset Printing All.
+Require Import Coq.Arith.Compare_dec.
+
+Require Import Coq.subtac.Utils.
+
+Fixpoint size (a : nat) : nat :=
+  match a with
+  0 => 1
+  | S n => S (size n)
+  end.
+
+Program Fixpoint test_measure (a : nat) {measure a size}  : nat :=
+  match a with
+  | S (S n) => S (test_measure n)
+  | x => x
+  end.
+subst.
+unfold n0.
+auto with arith.
+Qed.
+
+Check test_measure.
+Print test_measure.
\ No newline at end of file
diff --git a/contrib/subtac/test/rec.v b/contrib/subtac/test/rec.v
new file mode 100644
index 00000000..aaefd8cc
--- /dev/null
+++ b/contrib/subtac/test/rec.v
@@ -0,0 +1,65 @@
+Require Import Coq.Arith.Arith.
+Require Import Lt.
+Require Import Omega.
+
+Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }.
+(*Proof.
+  intros.
+  elim (le_lt_dec y x) ; intros ; auto with arith.
+Defined.
+*)
+Require Import Coq.subtac.FixSub.
+Require Import Wf_nat.
+
+Lemma preda_lt_a : forall a, 0 < a -> pred a < a.
+auto with arith.
+Qed.
+
+Program Fixpoint id_struct (a : nat) : nat :=
+  match a with
+  0 => 0
+  | S n => S (id_struct n)
+  end.
+
+Check struct_rec.
+
+  if (lt_ge_dec O a)
+  then S (wfrec (pred a))
+  else O.
+
+Program Fixpoint wfrec (a : nat) { wf a lt } : nat :=
+  if (lt_ge_dec O a)
+  then S (wfrec (pred a))
+  else O.
+intros.
+apply preda_lt_a ; auto.
+
+Defined.
+
+Extraction wfrec.
+Extraction Inline proj1_sig.
+Extract Inductive bool => "bool" [ "true" "false" ].
+Extract Inductive sumbool => "bool" [ "true" "false" ].
+Extract Inlined Constant lt_ge_dec => "<".
+
+Extraction wfrec.
+Extraction Inline lt_ge_dec le_lt_dec.
+Extraction wfrec.
+
+
+Program Fixpoint structrec (a : nat) { wf a lt } : nat :=
+  match a with
+   S n => S (structrec n)
+   | 0 => 0
+   end.
+intros.
+unfold n0.
+omega.
+Defined.
+
+Print structrec.
+Extraction structrec.
+Extraction structrec.
+
+Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a).
+Print structrec_fun.
diff --git a/contrib/subtac/test/wf.v b/contrib/subtac/test/wf.v
new file mode 100644
index 00000000..49fec2b8
--- /dev/null
+++ b/contrib/subtac/test/wf.v
@@ -0,0 +1,48 @@
+Notation "( x & y )" := (@existS _ _ x y) : core_scope.
+Unset Printing All.
+Require Import Coq.Arith.Compare_dec.
+
+Require Import Coq.subtac.Utils.
+
+Ltac one_simpl_hyp :=
+ match goal with
+ | [H : (`exist _ _ _) = _ |- _] => simpl in H
+ | [H : _ = (`exist _ _ _) |- _] => simpl in H
+ | [H : (`exist _ _ _) < _ |- _] => simpl in H
+ | [H : _ < (`exist _ _ _) |- _] => simpl in H
+ | [H : (`exist _ _ _) <= _ |- _] => simpl in H
+ | [H : _ <= (`exist _ _ _) |- _] => simpl in H
+ | [H : (`exist _ _ _) > _ |- _] => simpl in H
+ | [H : _ > (`exist _ _ _) |- _] => simpl in H
+ | [H : (`exist _ _ _) >= _ |- _] => simpl in H
+ | [H : _ >= (`exist _ _ _) |- _] => simpl in H
+ end.
+
+Ltac one_simpl_subtac :=
+  destruct_exists ;
+  repeat one_simpl_hyp ; simpl.
+
+Ltac simpl_subtac :=  do 3 one_simpl_subtac ; simpl.
+
+Require Import Omega.
+Require Import Wf_nat.
+
+Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt}  :
+  { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
+  if le_lt_dec b a then let (q', r) := euclid (a - b) b in 
+  (S q' & r)
+  else (O & a).
+destruct b ; simpl_subtac.
+omega.
+simpl_subtac.
+assert(x0 * S q' = x0 + x0 * q').
+rewrite <- mult_n_Sm.
+omega.
+rewrite H2 ; omega.
+simpl_subtac.
+split ; auto with arith.
+omega.
+apply lt_wf.
+Defined.
+
+Check euclid_evars_proof.
\ No newline at end of file
diff --git a/contrib/xml/cic2Xml.ml b/contrib/xml/cic2Xml.ml
new file mode 100644
index 00000000..f04a03f9
--- /dev/null
+++ b/contrib/xml/cic2Xml.ml
@@ -0,0 +1,17 @@
+let print_xml_term ch env sigma cic =
+  let ids_to_terms = Hashtbl.create 503 in
+  let constr_to_ids = Acic.CicHash.create 503 in
+  let ids_to_father_ids = Hashtbl.create 503 in
+  let ids_to_inner_sorts = Hashtbl.create 503 in
+  let ids_to_inner_types = Hashtbl.create 503 in
+  let seed = ref 0 in
+  let acic =
+   Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids 
+    ids_to_father_ids ids_to_inner_sorts ids_to_inner_types []
+    env [] sigma (Unshare.unshare cic) None in
+  let xml = Acic2Xml.print_term ids_to_inner_sorts acic in
+  Xml.pp_ch xml ch
+;;
+
+Tacinterp.declare_xml_printer print_xml_term
+;;
diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml
index d820f9e5..ff07c3c4 100644
--- a/contrib/xml/cic2acic.ml
+++ b/contrib/xml/cic2acic.ml
@@ -64,7 +64,7 @@ let get_uri_of_var v pvars =
   in
   let rec search_in_open_sections =
    function
-      [] -> Util.error "Variable not found"
+      [] -> Util.error ("Variable "^v^" not found")
     | he::tl as modules ->
        let dirpath = N.make_dirpath modules in
         if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then
@@ -83,16 +83,28 @@ let get_uri_of_var v pvars =
 ;;
 
 type tag =
-   Constant
- | Inductive
- | Variable
+   Constant of Names.constant
+ | Inductive of Names.kernel_name
+ | Variable of Names.kernel_name
 ;;
 
+type etag =
+   TConstant
+ | TInductive
+ | TVariable
+;;
+
+let etag_of_tag =
+ function
+    Constant _ -> TConstant
+  | Inductive _ -> TInductive
+  | Variable _ -> TVariable
+
 let ext_of_tag =
  function
-    Constant  -> "con"
-  | Inductive -> "ind"
-  | Variable  -> "var"
+    TConstant -> "con"
+  | TInductive -> "ind"
+  | TVariable -> "var"
 ;;
 
 exception FunctorsXMLExportationNotImplementedYet;;
@@ -147,23 +159,24 @@ let token_list_of_path dir id tag =
    List.rev_map N.string_of_id (N.repr_dirpath dirpath) in
   token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)]
 
-let token_list_of_kernel_name kn tag =
+let token_list_of_kernel_name tag =
  let module N = Names in
  let module LN = Libnames in
- let dir = match tag with
-   | Variable -> 
-       Lib.cwd ()
-   | Constant -> 
-       Lib.library_part (LN.ConstRef kn)
-   | Inductive ->
-       Lib.library_part (LN.IndRef (kn,0))
+ let id,dir = match tag with
+   | Variable kn -> 
+       N.id_of_label (N.label kn), Lib.cwd ()
+   | Constant con -> 
+       N.id_of_label (N.con_label con),
+       Lib.remove_section_part (LN.ConstRef con)
+   | Inductive kn ->
+       N.id_of_label (N.label kn),
+       Lib.remove_section_part (LN.IndRef (kn,0))
  in
- let id = N.id_of_label (N.label kn) in
- token_list_of_path dir id tag
+ token_list_of_path dir id (etag_of_tag tag)
 ;;
 
-let uri_of_kernel_name kn tag =
-  let tokens = token_list_of_kernel_name kn tag in
+let uri_of_kernel_name tag =
+  let tokens = token_list_of_kernel_name tag in
    "cic:/" ^ String.concat "/" tokens
 
 let uri_of_declaration id tag =
@@ -228,11 +241,11 @@ let typeur sigma metamap =
           Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound"))
     | T.Const c ->
         let cb = Environ.lookup_constant c env in
-        T.body_of_type cb.Declarations.const_type
-    | T.Evar ev -> Instantiate.existential_type sigma ev
-    | T.Ind ind -> T.body_of_type (Inductive.type_of_inductive env ind)
+        Typeops.type_of_constant_type env (cb.Declarations.const_type)
+    | T.Evar ev -> Evd.existential_type sigma ev
+    | T.Ind ind -> T.body_of_type (Inductiveops.type_of_inductive env ind)
     | T.Construct cstr ->
-       T.body_of_type (Inductive.type_of_constructor env cstr)
+       T.body_of_type (Inductiveops.type_of_constructor env cstr)
     | T.Case (_,p,c,lf) ->
         let Inductiveops.IndType(_,realargs) =
           try Inductiveops.find_rectype env sigma (type_of env c)
@@ -250,7 +263,7 @@ let typeur sigma metamap =
     | T.App(f,args)->
         T.strip_outer_cast
           (subst_type env sigma (type_of env f) (Array.to_list args))
-    | T.Cast (c,t) -> t
+    | T.Cast (c,_, t) -> t
     | T.Sort _ | T.Prod _ ->
        match sort_of env cstr with
           Coq_sort T.InProp -> T.mkProp
@@ -260,7 +273,7 @@ let typeur sigma metamap =
                                                                                 
   and sort_of env t =
     match Term.kind_of_term t with
-    | T.Cast (c,s) when T.isSort s -> family_of_term s
+    | T.Cast (c,_, s) when T.isSort s -> family_of_term s
     | T.Sort (T.Prop c) -> Coq_sort T.InType
     | T.Sort (T.Type u) -> Coq_sort T.InType
     | T.Prod (name,t,c2) ->
@@ -270,7 +283,7 @@ let typeur sigma metamap =
           | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s
           | Coq_sort T.InType, (Coq_sort T.InSet as s)
           | CProp, (Coq_sort T.InSet as s) when
-              Environ.engagement env = Some Environ.ImpredicativeSet -> s
+              Environ.engagement env = Some Declarations.ImpredicativeSet -> s
           | Coq_sort T.InType, Coq_sort T.InSet
           | CProp, Coq_sort T.InSet -> Coq_sort T.InType
           | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*)
@@ -282,7 +295,7 @@ let typeur sigma metamap =
                                                                                 
   and sort_family_of env t =
     match T.kind_of_term t with
-    | T.Cast (c,s) when T.isSort s -> family_of_term s
+    | T.Cast (c,_, s) when T.isSort s -> family_of_term s
     | T.Sort (T.Prop c) -> Coq_sort T.InType
     | T.Sort (T.Type u) -> Coq_sort T.InType
     | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2
@@ -375,7 +388,7 @@ try
           Acic.CicHash.find terms_to_types tt
 with _ ->
 (*CSC: Warning: it really happens, for example in Ring_theory!!! *)
-Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.prterm tt)) ; assert false
+Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false
          else
           (* We are already in an inner-type and Coscoy's double *)
           (* type inference algorithm has not been applied.      *)
@@ -384,19 +397,33 @@ Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-ty
           {D.synthesized =
             Reductionops.nf_beta
              (CPropRetyping.get_type_of env evar_map
-              (Evarutil.refresh_universes tt)) ;
+              (Termops.refresh_universes tt)) ;
            D.expected = None}
         in
 (* Debugging only:
 print_endline "TERMINE:" ; flush stdout ;
-Pp.ppnl (Printer.prterm tt) ; flush stdout ;
+Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ;
 print_endline "TIPO:" ; flush stdout ;
-Pp.ppnl (Printer.prterm synthesized) ; flush stdout ;
+Pp.ppnl (Printer.pr_lconstr synthesized) ; flush stdout ;
 print_endline "ENVIRONMENT:" ; flush stdout ;
 Pp.ppnl (Printer.pr_context_of env) ; flush stdout ;
 print_endline "FINE_ENVIRONMENT" ; flush stdout ;
 *)
-         let innersort = get_sort_family_of env evar_map synthesized in
+         let innersort =
+          let synthesized_innersort =
+           get_sort_family_of env evar_map synthesized
+          in
+           match expected with
+              None -> synthesized_innersort
+            | Some ty ->
+              let expected_innersort =
+               get_sort_family_of env evar_map ty
+              in
+               match expected_innersort, synthesized_innersort with
+                  CProp, _
+                | _, CProp -> CProp
+                | _, _ -> expected_innersort
+         in
 (* Debugging only:
 print_endline "PASSATO" ; flush stdout ;
 *)
@@ -441,7 +468,7 @@ print_endline "PASSATO" ; flush stdout ;
           let subst,residual_args,uninst_vars =
            let variables,basedir =
              try
-               let g = Libnames.reference_of_constr h in
+               let g = Libnames.global_of_constr h in
                let sp =
                 match g with
                    Libnames.ConstructRef ((induri,_),_)
@@ -533,7 +560,7 @@ print_endline "PASSATO" ; flush stdout ;
                (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l))
            | T.Meta _ -> Util.anomaly "Meta met during exporting to XML"
            | T.Sort s -> A.ASort (fresh_id'', s)
-           | T.Cast (v,t) ->
+           | T.Cast (v,_, t) ->
               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
               if is_a_Prop innersort then
                add_inner_type fresh_id'' ;
@@ -670,7 +697,7 @@ print_endline "PASSATO" ; flush stdout ;
               let
                compute_result_if_eta_expansion_not_required subst residual_args
               =
-               let residual_args_not_empty = List.length residual_args > 0 in
+               let residual_args_not_empty = residual_args <> [] in
                let h' =
                 if residual_args_not_empty then
                  aux' env idrefs ~subst:(None,subst) h
@@ -695,7 +722,7 @@ print_endline "PASSATO" ; flush stdout ;
               if is_a_Prop innersort  && expected_available then
                add_inner_type fresh_id'' ;
               let compute_result_if_eta_expansion_not_required _ _ =
-               A.AConst (fresh_id'', subst, (uri_of_kernel_name kn Constant))
+               A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn)))
               in
                let (_,subst') = subst in
                 explicit_substitute_and_eta_expand_if_required tt []
@@ -703,7 +730,7 @@ print_endline "PASSATO" ; flush stdout ;
                  compute_result_if_eta_expansion_not_required
            | T.Ind (kn,i) ->
               let compute_result_if_eta_expansion_not_required _ _ =
-               A.AInd (fresh_id'', subst, (uri_of_kernel_name kn Inductive), i)
+               A.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i)
               in
                let (_,subst') = subst in
                 explicit_substitute_and_eta_expand_if_required tt []
@@ -715,7 +742,7 @@ print_endline "PASSATO" ; flush stdout ;
                add_inner_type fresh_id'' ;
               let compute_result_if_eta_expansion_not_required _ _ =
                A.AConstruct
-                (fresh_id'', subst, (uri_of_kernel_name kn Inductive), i, j)
+                (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j)
               in
                let (_,subst') = subst in
                 explicit_substitute_and_eta_expand_if_required tt []
@@ -729,7 +756,7 @@ print_endline "PASSATO" ; flush stdout ;
                Array.fold_right (fun x i -> (aux' env idrefs x)::i) a []
               in
                A.ACase
-                (fresh_id'', (uri_of_kernel_name kn Inductive), i,
+                (fresh_id'', (uri_of_kernel_name (Inductive kn)), i,
                   aux' env idrefs ty, aux' env idrefs term, a')
            | T.Fix ((ai,i),(f,t,b)) ->
               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml
index f0e3f5e3..c7d3b4ff 100644
--- a/contrib/xml/doubleTypeInference.ml
+++ b/contrib/xml/doubleTypeInference.ml
@@ -19,7 +19,7 @@ let prerr_endline _ = ();;
 
 let cprop =
  let module N = Names in
-  N.make_kn
+  N.make_con
    (N.MPfile
      (Libnames.dirpath_of_string "CoRN.algebra.CLogic"))
    (N.make_dirpath [])
@@ -40,13 +40,13 @@ let whd_betadeltaiotacprop env evar_map ty =
 Conv_oracle.set_opaque_const cprop;
 prerr_endline "###whd_betadeltaiotacprop:" ;
 let xxx =
-(*Pp.msgerr (Printer.prterm_env env ty);*)
+(*Pp.msgerr (Printer.pr_lconstr_env env ty);*)
 prerr_endline "";
-   Tacred.reduction_of_redexp red_exp env evar_map ty
+   (fst (Redexpr.reduction_of_red_expr red_exp)) env evar_map ty
 in
 prerr_endline "###FINE" ;
 (*
-Pp.msgerr (Printer.prterm_env env xxx);
+Pp.msgerr (Printer.pr_lconstr_env env xxx);
 *)
 prerr_endline "";
 Conv_oracle.set_transparent_const cprop;
@@ -89,10 +89,11 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
          "DoubleTypeInference.double_type_of: found a non-instanciated goal"
  
      | T.Evar ((n,l) as ev) ->
-        let ty = Unshare.unshare (Instantiate.existential_type sigma ev) in
+        let ty = Unshare.unshare (Evd.existential_type sigma ev) in
         let jty = execute env sigma ty None in
         let jty = assumption_of_judgment env sigma jty in
-        let evar_context = (Evd.map sigma n).Evd.evar_hyps in
+        let evar_context = 
+	  E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in
          let rec iter actual_args evar_context =
           match actual_args,evar_context with
              [],[] -> ()
@@ -121,13 +122,13 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
         Typeops.judge_of_variable env id
 	  
      | T.Const c ->
-        E.make_judge cstr (E.constant_type env c)
+        E.make_judge cstr (Typeops.type_of_constant env c)
 	  
      | T.Ind ind ->
-        E.make_judge cstr (Inductive.type_of_inductive env ind)
+        E.make_judge cstr (Inductiveops.type_of_inductive env ind)
 	  
      | T.Construct cstruct -> 
-        E.make_judge cstr (Inductive.type_of_constructor env cstruct)
+        E.make_judge cstr (Inductiveops.type_of_constructor env cstruct)
 	  
      | T.Case (ci,p,c,lf) ->
         let expectedtype =
@@ -230,11 +231,11 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
          let j3 = execute env1 sigma c3 None in
           Typeops.judge_of_letin env name j1 j2 j3
   
-     | T.Cast (c,t) ->
+     | T.Cast (c,k,t) ->
         let cj = execute env sigma c (Some (Reductionops.nf_beta t)) in
         let tj = execute env sigma t None in
 	let tj = type_judgment env sigma tj in
-        let j, _ = Typeops.judge_of_cast env cj tj in
+        let j, _ = Typeops.judge_of_cast env cj k tj in
 	 j
     in
      let synthesized = E.j_type judgement in
@@ -244,19 +245,20 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
           None ->
            (* No expected type *)
            {synthesized = synthesized' ; expected = None}, synthesized
-        (*CSC: in HELM we did not considered Casts to be irrelevant. *)
-        (*CSC: does it really matter? (eq_constr is up to casts)     *)
         | Some ty when Term.eq_constr synthesized' ty ->
-           (* The expected type is synthactically equal to *)
-           (* the synthesized type. Let's forget it.       *)
-           {synthesized = synthesized' ; expected = None}, synthesized
+           (* The expected type is synthactically equal to the    *)
+           (* synthesized type. Let's forget it.                  *)
+           (* Note: since eq_constr is up to casts, it is better  *)
+           (* to keep the expected type, since it can bears casts *)
+           (* that change the innersort to CProp                  *)
+           {synthesized = ty ; expected = None}, ty
         | Some expectedty' ->
            {synthesized = synthesized' ; expected = Some expectedty'},
            expectedty'
       in
 (*CSC: debugging stuff to be removed *)
 if Acic.CicHash.mem subterms_to_types cstr then
- (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.prterm cstr)) ; flush stdout ) ;
+ (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.pr_lconstr cstr)) ; flush stdout ) ;
        Acic.CicHash.add subterms_to_types cstr types ;
        E.make_judge cstr res
 
diff --git a/contrib/xml/doubleTypeInference.mli b/contrib/xml/doubleTypeInference.mli
index 33d3e5cd..2e14b558 100644
--- a/contrib/xml/doubleTypeInference.mli
+++ b/contrib/xml/doubleTypeInference.mli
@@ -14,7 +14,7 @@
 
 type types = { synthesized : Term.types; expected : Term.types option; } 
 
-val cprop : Names.kernel_name
+val cprop : Names.constant
 
 val whd_betadeltaiotacprop :
   Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml
index 165a456d..30dc7b71 100644
--- a/contrib/xml/proof2aproof.ml
+++ b/contrib/xml/proof2aproof.ml
@@ -32,7 +32,7 @@ let nf_evar sigma ~preserve =
     match T.kind_of_term t with
      | T.Rel _ | T.Meta _ | T.Var _ | T.Sort _ | T.Const _ | T.Ind _
      | T.Construct _ -> t
-     | T.Cast (c1,c2) -> T.mkCast (aux c1, aux c2)
+     | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2)
      | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2)
      | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c)
      | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c)
@@ -41,14 +41,14 @@ let nf_evar sigma ~preserve =
         let l' = Array.map aux l in
          (match T.kind_of_term c' with
              T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
-           | T.Cast (he,_) ->
+           | T.Cast (he,_,_) ->
               (match T.kind_of_term he with
                   T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
                 | _ -> T.mkApp (c', l')
               )
            | _ -> T.mkApp (c', l'))
-     | T.Evar (e,l) when Evd.in_dom sigma e & Evd.is_defined sigma e ->
-	aux (Instantiate.existential_value sigma (e,l))
+     | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e ->
+	aux (Evd.existential_value sigma (e,l))
      | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l)
      | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl)
      | T.Fix (ln,(lna,tl,bl)) ->
@@ -63,21 +63,24 @@ let nf_evar sigma ~preserve =
 (* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *)
 let rec unshare_proof_tree =
  let module PT = Proof_type in
-  function {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = ref} ->
+  function {PT.open_subgoals = status ; 
+	    PT.goal = goal ; 
+	    PT.ref = ref} ->
    let unshared_ref =
     match ref with
        None -> None
      | Some (rule,pfs) ->
         let unshared_rule =
          match rule with
-            PT.Prim prim -> PT.Prim prim
-          | PT.Change_evars -> PT.Change_evars
-          | PT.Tactic (tactic_expr, pf) ->
-             PT.Tactic (tactic_expr, unshare_proof_tree pf)
-        in
+             PT.Nested (cmpd, pf) ->
+               PT.Nested (cmpd, unshare_proof_tree pf)
+	   | other -> other
+	in
          Some (unshared_rule, List.map unshare_proof_tree pfs)
    in
-    {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = unshared_ref}
+    {PT.open_subgoals = status ; 
+     PT.goal = goal ; 
+     PT.ref = unshared_ref}
 ;;
 
 module ProofTreeHash =
@@ -93,7 +96,7 @@ module ProofTreeHash =
 let extract_open_proof sigma pf =
  let module PT = Proof_type in
  let module L = Logic in
-  let sigma = ref sigma in
+  let evd = ref (Evd.create_evar_defs sigma) in
   let proof_tree_to_constr = ProofTreeHash.create 503 in
   let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in
   let unshared_constrs = ref S.empty in
@@ -103,48 +106,51 @@ let extract_open_proof sigma pf =
        {PT.ref=Some(PT.Prim _,_)} as pf ->
         L.prim_extractor proof_extractor vl pf
 	  
-     | {PT.ref=Some(PT.Tactic (_,hidden_proof),spfl)} ->
+     | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} ->
 	 let sgl,v = Refiner.frontier hidden_proof in
 	 let flat_proof = v spfl in
          ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ;
 	 proof_extractor vl flat_proof
 	  
-     | {PT.ref=Some(PT.Change_evars,[pf])} -> (proof_extractor vl) pf
-	  
      | {PT.ref=None;PT.goal=goal} ->
 	 let visible_rels =
            Util.map_succeed
              (fun id ->
                 (* Section variables are in the [id] list but are not *)
                 (* lambda abstracted in the term [vl]                 *)
-                try let n = Util.list_index id vl in (n,id)
+                try let n = Logic.proof_variable_index id vl in (n,id)
 	        with Not_found -> failwith "caught")
 (*CSC: the above function must be modified such that when it is found  *)
 (*CSC: it becomes a Rel; otherwise a Var. Then it can be already used  *)
 (*CSC: as the evar_instance. Ordering the instance becomes useless (it *)
 (*CSC: will already be ordered.                                        *)
-             (Termops.ids_of_named_context goal.Evd.evar_hyps) in
+             (Termops.ids_of_named_context 
+		(Environ.named_context_of_val goal.Evd.evar_hyps)) in
 	 let sorted_rels =
 	   Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in
 	 let context =
-          List.map
-            (fun (_,id) -> Sign.lookup_named id goal.Evd.evar_hyps)
-            sorted_rels
+	   let l = 
+             List.map
+               (fun (_,id) -> Sign.lookup_named id 
+		   (Environ.named_context_of_val goal.Evd.evar_hyps))
+               sorted_rels in
+	   Environ.val_of_named_context l
          in
 (*CSC: the section variables in the right order must be added too *)
          let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in
-         let env = Global.env_of_context context in
-         let sigma',evar =
-          Evarutil.new_isevar_sign env !sigma goal.Evd.evar_concl evar_instance
-         in
-         sigma := sigma' ;
+    (*     let env = Global.env_of_context context in *)
+	 let evd',evar =
+           Evarutil.new_evar_instance context !evd goal.Evd.evar_concl
+             evar_instance in
+         evd := evd' ;
          evar
 	  
      | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor"
    in
     let unsharedconstr =
      let evar_nf_constr =
-      nf_evar !sigma ~preserve:(function e -> S.mem e !unshared_constrs) constr
+      nf_evar (Evd.evars_of !evd)
+        ~preserve:(function e -> S.mem e !unshared_constrs) constr
      in
       Unshare.unshare
        ~already_unshared:(function e -> S.mem e !unshared_constrs)
@@ -152,14 +158,15 @@ let extract_open_proof sigma pf =
     in
 (*CSC: debugging stuff to be removed *)
 if ProofTreeHash.mem proof_tree_to_constr node then
- Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ") (Refiner.print_proof !sigma [] node)) ;
+ Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ")
+ (Tactic_printer.print_proof (Evd.evars_of !evd) [] node)) ;
      ProofTreeHash.add proof_tree_to_constr node unsharedconstr ;
      unshared_constrs := S.add unsharedconstr !unshared_constrs ;
      unsharedconstr
   in
   let unshared_pf = unshare_proof_tree pf in
   let pfterm = proof_extractor [] unshared_pf in
-   (pfterm, !sigma, proof_tree_to_constr, proof_tree_to_flattened_proof_tree,
+   (pfterm, Evd.evars_of !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree,
     unshared_pf)
 ;;
 
diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4
index b9b66774..9afd07a6 100644
--- a/contrib/xml/proofTree2Xml.ml4
+++ b/contrib/xml/proofTree2Xml.ml4
@@ -46,7 +46,8 @@ let constr_to_xml obj sigma env =
   let rel_context = Sign.push_named_to_rel_context named_context' [] in
   let rel_env =
    Environ.push_rel_context rel_context
-    (Environ.reset_with_named_context real_named_context env) in
+    (Environ.reset_with_named_context 
+	(Environ.val_of_named_context real_named_context) env) in
   let obj' =
    Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in
   let seed = ref 0 in
@@ -66,9 +67,9 @@ Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ;
 Pp.ppnl (Pp.str "ENVIRONMENT:") ;
 Pp.ppnl (Printer.pr_context_of rel_env) ;
 Pp.ppnl (Pp.str "TERM:") ;
-Pp.ppnl (Printer.prterm_env rel_env obj') ;
+Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ;
 Pp.ppnl (Pp.str "RAW-TERM:") ;
-Pp.ppnl (Printer.prterm obj') ;
+Pp.ppnl (Printer.pr_lconstr obj') ;
 Xml.xml_empty "MISSING TERM" [] (*; raise e*)
 *)
 ;;
@@ -92,10 +93,10 @@ let string_of_prim_rule x = match x with
   | Proof_type.ThinBody _-> "ThinBody"
   | Proof_type.Move (_,_,_) -> "Move"
   | Proof_type.Rename (_,_) -> "Rename"
-
+  | Proof_type.Change_evars -> "Change_evars"
 
 let
- print_proof_tree curi sigma0 pf proof_tree_to_constr
+ print_proof_tree curi sigma pf proof_tree_to_constr
   proof_tree_to_flattened_proof_tree constr_to_ids
 =
  let module PT = Proof_type in
@@ -119,7 +120,7 @@ in
    with _ ->
 Pp.ppnl (Pp.(++) (Pp.str
 "The_generated_term_is_not_a_subterm_of_the_final_lambda_term")
-(Printer.prterm constr)) ;
+(Printer.pr_lconstr constr)) ;
     None
   in
   let rec aux node old_hyps =
@@ -140,7 +141,7 @@ Pp.ppnl (Pp.(++) (Pp.str
               (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
 
      | {PT.goal=goal;
-        PT.ref=Some(PT.Tactic (tactic_expr,hidden_proof),nodes)} ->
+        PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} ->
          (* [hidden_proof] is the proof of the tactic;                     *)
          (* [nodes] are the proof of the subgoals generated by the tactic; *)
          (* [flat_proof] if the proof-tree obtained substituting [nodes]   *)
@@ -155,7 +156,7 @@ Pp.ppnl (Pp.(++) (Pp.str
             aux flat_proof old_hyps
         | _ ->
          (****** la tactique employee *)
-	 let prtac = if !Options.v7 then Pptactic.pr_tactic else Pptacticnew.pr_tactic (Global.env()) in
+	 let prtac = Pptactic.pr_tactic (Global.env()) in
          let tac = std_ppcmds_to_string (prtac tactic_expr) in
          let tacname= first_word tac in
          let of_attribute = ("name",tacname)::("script",tac)::of_attribute in
@@ -164,10 +165,7 @@ Pp.ppnl (Pp.(++) (Pp.str
          let {Evd.evar_concl=concl;
               Evd.evar_hyps=hyps}=goal in
 
-         let rc = (Proof_trees.rc_of_gc sigma0 goal) in
-         let sigma = Proof_trees.get_gc rc in
-         let hyps = Proof_trees.get_hyps rc in
-         let env= Proof_trees.get_env rc in
+         let env = Global.env_of_context hyps in
 
          let xgoal =
           X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in
@@ -183,17 +181,19 @@ Pp.ppnl (Pp.(++) (Pp.str
                     (constr_to_xml tid sigma env))
                >] in
          let old_names = List.map (fun (id,c,tid)->id) old_hyps in
+	 let nhyps = Environ.named_context_of_val hyps in
          let new_hyps =
-          List.filter (fun (id,c,tid)-> not (List.mem id old_names)) hyps in
+          List.filter (fun (id,c,tid)-> not (List.mem id old_names)) nhyps in
 
          X.xml_nempty "Tactic" of_attribute
-          [<(build_hyps new_hyps) ; (aux flat_proof hyps)>]
+          [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>]
         end
 
-     | {PT.ref=Some(PT.Change_evars,nodes)} ->
-         X.xml_nempty "Change_evars" of_attribute
-          (List.fold_left
-            (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
+     | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} ->
+         Util.anomaly "Not Implemented" 
+
+     | {PT.ref=Some(PT.Daimon,_)} ->
+         X.xml_empty "Hidden_open_goal" of_attribute
 
      | {PT.ref=None;PT.goal=goal} ->
          X.xml_empty "Open_goal" of_attribute
diff --git a/contrib/xml/xml.ml4 b/contrib/xml/xml.ml4
index d0c64f30..e2d04cb7 100644
--- a/contrib/xml/xml.ml4
+++ b/contrib/xml/xml.ml4
@@ -31,8 +31,7 @@ let xml_cdata str = [< 'Str str >]
 (* Usage:                                                                   *)
 (*  pp tokens None     pretty prints the output on stdout                   *)
 (*  pp tokens (Some filename) pretty prints the output on the file filename *)
-let pp strm fn =
- let channel = ref stdout in
+let pp_ch strm channel =
  let rec pp_r m =
   parser
     [< 'Str a ; s >] ->
@@ -58,16 +57,22 @@ let pp strm fn =
  and print_spaces m =
   for i = 1 to m do fprint_string "  " done
  and fprint_string str =
-  output_string !channel str
+  output_string channel str
  in
+  pp_r 0 strm
+;;
+
+
+let pp strm fn =
   match fn with
      Some filename ->
       let filename = filename ^ ".xml" in
-       channel := open_out filename ;
-       pp_r 0 strm ;
-       close_out !channel ;
+      let ch = open_out filename in
+       pp_ch strm ch;
+       close_out ch ;
        print_string ("\nWriting on file \"" ^ filename ^ "\" was succesful\n");
        flush stdout
    | None ->
-       pp_r 0 strm
+       pp_ch strm stdout
 ;;
+
diff --git a/contrib/xml/xml.mli b/contrib/xml/xml.mli
index e65e6c81..38a4e01c 100644
--- a/contrib/xml/xml.mli
+++ b/contrib/xml/xml.mli
@@ -12,7 +12,7 @@
 (*                       http://helm.cs.unibo.it                        *)
 (************************************************************************)
 
-(*i $Id: xml.mli,v 1.5.2.2 2004/07/16 19:30:15 herbelin Exp $ i*)
+(*i $Id: xml.mli 6681 2005-02-04 18:20:16Z herbelin $ i*)
 
 (* Tokens for XML cdata, empty elements and not-empty elements           *)
 (* Usage:                                                                *)
@@ -31,6 +31,8 @@ val xml_nempty :
   string -> (string * string) list -> token Stream.t -> token Stream.t
 val xml_cdata : string -> token Stream.t
 
+val pp_ch : token Stream.t -> out_channel -> unit
+
 (* The pretty printer for streams of token                                  *)
 (* Usage:                                                                   *)
 (*  pp tokens None     pretty prints the output on stdout                   *)
diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml
index 9fba5474..f286d2c8 100644
--- a/contrib/xml/xmlcommand.ml
+++ b/contrib/xml/xmlcommand.ml
@@ -38,6 +38,8 @@ let print_if_verbose s = if !verbose then print_string s;;
 (* Next exception is used only inside print_coq_object and tag_of_string_tag *)
 exception Uninteresting;;
 
+(* NOT USED anymore, we back to the V6 point of view with global parameters 
+
 (* Internally, for Coq V7, params of inductive types are associated     *)
 (* not to the whole block of mutual inductive (as it was in V6) but to  *)
 (* each member of the block; but externally, all params are required    *)
@@ -60,6 +62,8 @@ let extract_nparams pack =
   done;
   nparams0
 
+*)
+
 (* could_have_namesakes sp = true iff o is an object that could be cooked and *)
 (* than that could exists in cooked form with the same name in a super        *)
 (* section of the actual section                                              *)
@@ -177,12 +181,12 @@ let rec join_dirs cwd =
       join_dirs newcwd tail
 ;;
 
-let filename_of_path xml_library_root kn tag =
+let filename_of_path xml_library_root tag =
  let module N = Names in
   match xml_library_root with
      None -> None  (* stdout *)
    | Some xml_library_root' ->
-      let tokens = Cic2acic.token_list_of_kernel_name kn tag in
+      let tokens = Cic2acic.token_list_of_kernel_name tag in
        Some (join_dirs xml_library_root' tokens)
 ;;
 
@@ -210,7 +214,6 @@ let theory_filename xml_library_root =
     None -> None  (* stdout *)
   | Some xml_library_root' ->
      let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in
-     let hd = List.hd toks in
      (* theory from A/B/C/F.v goes into A/B/C/F.theory *)
      let alltoks = List.rev toks in
        Some (join_dirs xml_library_root' alltoks ^ ".theory")
@@ -286,7 +289,7 @@ let find_hyps t =
     | T.Meta _
     | T.Evar _
     | T.Sort _ -> l
-    | T.Cast (te,ty) -> aux (aux l te) ty
+    | T.Cast (te,_, ty) -> aux (aux l te) ty
     | T.Prod (_,s,t) -> aux (aux l s) t
     | T.Lambda (_,s,t) -> aux (aux l s) t
     | T.LetIn (_,s,_,t) -> aux (aux l s) t
@@ -355,11 +358,11 @@ let mk_current_proof_obj is_a_variable id bo ty evar_map env =
                (* t will not be exported to XML. Thus no unsharing performed *)
                final_var_ids,(n, Acic.Def  (Unshare.unshare b',t))::tl'
         in
-         aux [] (List.rev evar_hyps)
+         aux [] (List.rev (Environ.named_context_of_val evar_hyps))
        in
         (* We map the named context to a rel context and every Var to a Rel *)
         (n,context,Unshare.unshare (Term.subst_vars final_var_ids evar_concl))
-   ) (Evd.non_instantiated evar_map)
+   ) (Evarutil.non_instantiated evar_map)
  in
   let id' = Names.string_of_id id in
    if metasenv = [] then
@@ -392,21 +395,21 @@ let mk_constant_obj id bo ty variables hyps =
          ty,params)
 ;;
 
-let mk_inductive_obj sp packs variables hyps finite =
+let mk_inductive_obj sp mib packs variables nparams hyps finite =
  let module D = Declarations in
   let hyps = string_list_of_named_context_list hyps in
   let params = filter_params variables hyps in
-  let nparams = extract_nparams packs in
+(*  let nparams = extract_nparams packs in *)
    let tys =
     let tyno = ref (Array.length packs) in
     Array.fold_right
      (fun p i ->
        decr tyno ;
        let {D.mind_consnames=consnames ;
-            D.mind_typename=typename ;
-            D.mind_nf_arity=arity} = p
+            D.mind_typename=typename } = p
        in
-        let lc = Inductive.arities_of_constructors (Global.env ()) (sp,!tyno) in
+        let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in
+        let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in
         let cons =
          (Array.fold_right (fun (name,lc) i -> (name,lc)::i)
           (Array.mapi
@@ -430,16 +433,10 @@ let theory_output_string ?(do_not_quote = false) s =
    Buffer.add_string theory_buffer s
 ;;
 
-let kind_of_theorem = function
-  | Decl_kinds.Theorem -> "Theorem"
-  | Decl_kinds.Lemma -> "Lemma"
-  | Decl_kinds.Fact -> "Fact"
-  | Decl_kinds.Remark -> "Remark"
-
 let kind_of_global_goal = function
-  | Decl_kinds.IsGlobal Decl_kinds.DefinitionBody -> "DEFINITION","InteractiveDefinition"
-  | Decl_kinds.IsGlobal (Decl_kinds.Proof k) -> "THEOREM",kind_of_theorem k
-  | Decl_kinds.IsLocal -> assert false
+  | Decl_kinds.Global, Decl_kinds.DefinitionBody _ -> "DEFINITION","InteractiveDefinition"
+  | Decl_kinds.Global, (Decl_kinds.Proof k) -> "THEOREM",Decl_kinds.string_of_theorem_kind k
+  | Decl_kinds.Local, _ -> assert false
 
 let kind_of_inductive isrecord kn =
  "DEFINITION",
@@ -454,9 +451,9 @@ let kind_of_variable id =
     | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption"
     | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis"
     | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture"
-    | DK.IsDefinition -> "VARIABLE","LocalDefinition"
-    | DK.IsConjecture -> "VARIABLE","Conjecture"
-    | DK.IsProof DK.LocalStatement -> "VARIABLE","LocalFact"
+    | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition"
+    | DK.IsProof _ -> "VARIABLE","LocalFact"
+    | _ -> Util.anomaly "Unsupported variable kind"
 ;;
 
 let kind_of_constant kn = 
@@ -465,9 +462,10 @@ let kind_of_constant kn =
     | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration"
     | DK.IsAssumption DK.Logical -> "AXIOM","Axiom"
     | DK.IsAssumption DK.Conjectural -> "AXIOM","Conjecture"
-    | DK.IsDefinition -> "DEFINITION","Definition"
-    | DK.IsConjecture -> "THEOREM","Conjecture"
-    | DK.IsProof thm -> "THEOREM",kind_of_theorem thm
+    | DK.IsDefinition DK.Definition -> "DEFINITION","Definition"
+    | DK.IsDefinition DK.Example -> "DEFINITION","Example"
+    | DK.IsDefinition _ -> Util.anomaly "Unsupported constant kind"
+    | DK.IsProof thm -> "THEOREM",DK.string_of_theorem_kind thm
 ;;
 
 let kind_of_global r =
@@ -476,7 +474,7 @@ let kind_of_global r =
   match r with
   | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> 
       let isrecord =
-	try let _ = Recordops.find_structure kn in true
+	try let _ = Recordops.lookup_projections kn in true
         with Not_found -> false in
       kind_of_inductive isrecord (fst kn)
   | Ln.VarRef id -> kind_of_variable id
@@ -509,7 +507,7 @@ let print internal glob_ref kind xml_library_root =
  let module Ln = Libnames in
   (* Variables are the identifiers of the variables in scope *)
   let variables = search_variables () in
-  let kn,tag,obj =
+  let tag,obj =
    match glob_ref with
       Ln.VarRef id ->
        let sp = Declare.find_section_variable id in
@@ -519,23 +517,25 @@ let print internal glob_ref kind xml_library_root =
         N.make_kn mod_path dir_path (N.label_of_id (Ln.basename sp))
        in
        let (_,body,typ) = G.lookup_named id in
-        kn,Cic2acic.Variable,mk_variable_obj id body typ
+        Cic2acic.Variable kn,mk_variable_obj id body typ
     | Ln.ConstRef kn ->
-       let id = N.id_of_label (N.label kn) in
+       let id = N.id_of_label (N.con_label kn) in
        let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} =
         G.lookup_constant kn in
-        kn,Cic2acic.Constant,mk_constant_obj id val0 typ variables hyps
+       let typ = Typeops.type_of_constant_type (Global.env()) typ in
+        Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps
     | Ln.IndRef (kn,_) ->
-       let {D.mind_packets=packs ;
+       let mib = G.lookup_mind kn in
+       let {D.mind_nparams=nparams;
+	    D.mind_packets=packs ;
             D.mind_hyps=hyps;
-            D.mind_finite=finite} = G.lookup_mind kn in
-          kn,Cic2acic.Inductive,
-           mk_inductive_obj kn packs variables hyps finite
+            D.mind_finite=finite} = mib in
+          Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite
     | Ln.ConstructRef _ ->
-       Util.anomaly ("print: this should not happen")
+       Util.error ("a single constructor cannot be printed in XML")
   in
-  let fn = filename_of_path xml_library_root kn tag in
-  let uri = Cic2acic.uri_of_kernel_name kn tag in
+  let fn = filename_of_path xml_library_root tag in
+  let uri = Cic2acic.uri_of_kernel_name tag in
    if not internal then print_object_kind uri kind;
    print_object uri obj Evd.empty None fn
 ;;
@@ -548,28 +548,27 @@ let print_ref qid fn =
 (*  where dest is either None (for stdout) or (Some filename) *)
 (* pretty prints via Xml.pp the proof in progress on dest     *)
 let show_pftreestate internal fn (kind,pftst) id =
- let str = Names.string_of_id id in
  let pf = Tacmach.proof_of_pftreestate pftst in
  let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in
  let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree,
      unshared_pf
  =
   Proof2aproof.extract_open_pftreestate pftst in
- let kn = Lib.make_kn id in
  let env = Global.env () in
  let obj =
-  mk_current_proof_obj (kind = Decl_kinds.IsLocal) id val0 typ evar_map env in
+  mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in
  let uri =
   match kind with
-     Decl_kinds.IsLocal ->
+     Decl_kinds.Local, _ ->
       let uri =
        "cic:/" ^ String.concat "/"
-        (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.Variable) in
+        (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable)
+      in
       let kind_of_var = "VARIABLE","LocalFact" in
        if not internal then print_object_kind uri kind_of_var;
       uri
-   | Decl_kinds.IsGlobal _ ->
-      let uri = Cic2acic.uri_of_declaration id Cic2acic.Constant in
+   | Decl_kinds.Global, _ ->
+      let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in
        if not internal then print_object_kind uri (kind_of_global_goal kind);
        uri
  in
@@ -610,7 +609,7 @@ let _ =
 
 let _ =
   Declare.set_xml_declare_constant
-   (function (internal,(sp,kn)) ->
+   (function (internal,kn) ->
      match !proof_to_export with
         None ->
           print internal (Libnames.ConstRef kn) (kind_of_constant kn) 
@@ -618,9 +617,9 @@ let _ =
       | Some pftreestate ->
          (* It is a proof. Let's export it starting from the proof-tree *)
          (* I saved in the Pfedit.set_xml_cook_proof callback.          *)
-        let fn = filename_of_path xml_library_root kn Cic2acic.Constant in
+        let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in
          show_pftreestate internal fn pftreestate 
-	  (Names.id_of_label (Names.label kn)) ;
+	  (Names.id_of_label (Names.con_label kn)) ;
          proof_to_export := None)
 ;;
 
@@ -675,7 +674,7 @@ let _ =
            let dot = if fn.[0]='/' then "." else "" in
            command ("mv "^dir^"/"^dot^"*.html "^fn^".xml ");
            command ("rm "^fn^".v");
-           print_string("\nWriting on file \"" ^ fn ^ ".xml\" was succesful\n"))
+           print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n"))
        ofn)
 ;;
 
diff --git a/contrib/xml/xmlcommand.mli b/contrib/xml/xmlcommand.mli
index 9a7464bd..7c0d31a1 100644
--- a/contrib/xml/xmlcommand.mli
+++ b/contrib/xml/xmlcommand.mli
@@ -12,7 +12,7 @@
 (*                       http://helm.cs.unibo.it                        *)
 (************************************************************************)
 
-(*i $Id: xmlcommand.mli,v 1.18.2.2 2004/07/16 19:30:15 herbelin Exp $ i*)
+(*i $Id: xmlcommand.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* print_global qid fn                                                    *)
 (*  where qid  is a long name denoting a definition/theorem or            *)
diff --git a/contrib/xml/xmlentries.ml4 b/contrib/xml/xmlentries.ml4
index 2bc686f7..496debe1 100644
--- a/contrib/xml/xmlentries.ml4
+++ b/contrib/xml/xmlentries.ml4
@@ -14,7 +14,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: xmlentries.ml4,v 1.12.2.2 2004/07/16 19:30:15 herbelin Exp $ *)
+(* $Id: xmlentries.ml4 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Util;;
 open Vernacinterp;;
diff --git a/contrib7/cc/CCSolve.v b/contrib7/cc/CCSolve.v
deleted file mode 100644
index 388763ed..00000000
--- a/contrib7/cc/CCSolve.v
+++ /dev/null
@@ -1,20 +0,0 @@
-(************************************************************************)
-(*  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: CCSolve.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
-
-Tactic Definition CCsolve :=
- Repeat (Match Context With
- [ H: ?1 |- ?2] -> 
-  Let Heq = FreshId "Heq" In
- (Assert Heq:(?2==?1);[Congruence|(Rewrite Heq;Exact H)])
- |[ H: ?1; G: ?2 -> ?3 |- ?] ->                        
-  Let Heq = FreshId "Heq" In
- (Assert Heq:(?2==?1) ;[Congruence|                              
-     (Rewrite Heq in G;Generalize (G H);Clear G;Intro G)])).  
-
diff --git a/contrib7/correctness/ArrayPermut.v b/contrib7/correctness/ArrayPermut.v
deleted file mode 100644
index 4a0025ca..00000000
--- a/contrib7/correctness/ArrayPermut.v
+++ /dev/null
@@ -1,183 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ArrayPermut.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
-
-(****************************************************************************)
-(*                    Permutations of elements in arrays                    *)
-(*                        Definition and properties                         *)
-(****************************************************************************)
-
-Require ProgInt.
-Require Arrays.
-Require Export Exchange.
-
-Require Omega.
-
-Set Implicit Arguments.
-
-(* We define "permut" as the smallest equivalence relation which contains
- * transpositions i.e. exchange of two elements.
- *)
-
-Inductive permut [n:Z; A:Set] : (array n A)->(array n A)->Prop :=
-    exchange_is_permut : 
-      (t,t':(array n A))(i,j:Z)(exchange t t' i j) -> (permut t t')
-  | permut_refl : 
-      (t:(array n A))(permut t t)
-  | permut_sym : 
-      (t,t':(array n A))(permut t t') -> (permut t' t)
-  | permut_trans : 
-      (t,t',t'':(array n A))
-      (permut t t') -> (permut t' t'') -> (permut t t'').
-
-Hints Resolve exchange_is_permut permut_refl permut_sym permut_trans : v62 datatypes.
-
-(* We also define the permutation on a segment of an array, "sub_permut",
- * the other parts of the array being unchanged
- *
- * One again we define it as the smallest equivalence relation containing
- * transpositions on the given segment.
- *)
-
-Inductive sub_permut [n:Z; A:Set; g,d:Z] : (array n A)->(array n A)->Prop :=
-    exchange_is_sub_permut : 
-      (t,t':(array n A))(i,j:Z)`g <= i <= d` -> `g <= j <= d`
-      -> (exchange t t' i j) -> (sub_permut g d t t')
-  | sub_permut_refl : 
-      (t:(array n A))(sub_permut g d t t)
-  | sub_permut_sym : 
-      (t,t':(array n A))(sub_permut g d t t') -> (sub_permut g d t' t)
-  | sub_permut_trans : 
-      (t,t',t'':(array n A))
-      (sub_permut g d t t') -> (sub_permut g d t' t'') 
-      -> (sub_permut g d t t'').
-
-Hints Resolve exchange_is_sub_permut sub_permut_refl sub_permut_sym sub_permut_trans
-  : v62 datatypes.
-
-(* To express that some parts of arrays are equal we introduce the
- * property "array_id" which says that a segment is the same on two
- * arrays.
- *)
-
-Definition array_id := [n:Z][A:Set][t,t':(array n A)][g,d:Z]
-  (i:Z) `g <= i <= d` -> #t[i] = #t'[i].
-
-(* array_id is an equivalence relation *)
-
-Lemma array_id_refl : 
-  (n:Z)(A:Set)(t:(array n A))(g,d:Z)
-  (array_id t t g d).
-Proof.
-Unfold array_id.
-Auto with datatypes.
-Save.
-
-Hints Resolve array_id_refl : v62 datatypes.
-
-Lemma array_id_sym :
-  (n:Z)(A:Set)(t,t':(array n A))(g,d:Z)
-  (array_id t t' g d)
-  -> (array_id t' t g d).
-Proof.
-Unfold array_id. Intros.
-Symmetry; Auto with datatypes.
-Save.
-
-Hints Resolve  array_id_sym : v62 datatypes.
-
-Lemma array_id_trans :
-  (n:Z)(A:Set)(t,t',t'':(array n A))(g,d:Z)
-  (array_id t t' g d)
-  -> (array_id t' t'' g d)
-    -> (array_id t t'' g d).
-Proof.
-Unfold array_id. Intros.
-Apply trans_eq with y:=#t'[i]; Auto with datatypes.
-Save.
-
-Hints Resolve array_id_trans: v62 datatypes.
-
-(* Outside the segment [g,d] the elements are equal *)
-
-Lemma sub_permut_id :
-  (n:Z)(A:Set)(t,t':(array n A))(g,d:Z)
-  (sub_permut g d t t') ->
-  (array_id t t' `0` `g-1`) /\ (array_id t t' `d+1` `n-1`).
-Proof.
-Intros n A t t' g d. Induction 1; Intros.
-Elim H2; Intros.
-Unfold array_id; Split; Intros.
-Apply H7; Omega.
-Apply H7; Omega.
-Auto with datatypes.
-Decompose [and] H1; Auto with datatypes.
-Decompose [and] H1; Decompose [and] H3; EAuto with datatypes.
-Save.
-
-Hints Resolve sub_permut_id.
-
-Lemma sub_permut_eq :
-  (n:Z)(A:Set)(t,t':(array n A))(g,d:Z)
-  (sub_permut g d t t') ->
-  (i:Z) (`0<=i<g` \/ `d<i<n`) -> #t[i]=#t'[i].
-Proof.
-Intros n A t t' g d Htt' i Hi.
-Elim (sub_permut_id Htt'). Unfold array_id. 
-Intros.
-Elim Hi; [ Intro; Apply H; Omega | Intro; Apply H0; Omega ].
-Save.
-
-(* sub_permut is a particular case of permutation *)
-
-Lemma sub_permut_is_permut :
-  (n:Z)(A:Set)(t,t':(array n A))(g,d:Z)
-  (sub_permut g d t t') ->
-  (permut t t').
-Proof.
-Intros n A t t' g d. Induction 1; Intros; EAuto with datatypes.
-Save.
-
-Hints Resolve sub_permut_is_permut.
-
-(* If we have a sub-permutation on an empty segment, then we have a 
- * sub-permutation on any segment.
- *)
-
-Lemma sub_permut_void :
-  (N:Z)(A:Set)(t,t':(array N A))
-  (g,g',d,d':Z) `d < g`
-   -> (sub_permut g d t t') -> (sub_permut g' d' t t').
-Proof.
-Intros N A t t' g g' d d' Hdg.
-(Induction 1; Intros).
-(Absurd `g <= d`; Omega).
-Auto with datatypes.
-Auto with datatypes.
-EAuto with datatypes.
-Save.
-
-(* A sub-permutation on a segment may be extended to any segment that
- * contains the first one.
- *)
-
-Lemma sub_permut_extension :
-  (N:Z)(A:Set)(t,t':(array N A))
-  (g,g',d,d':Z) `g' <= g` -> `d <= d'`
-   -> (sub_permut g d t t') -> (sub_permut g' d' t t').
-Proof.
-Intros N A t t' g g' d d' Hgg' Hdd'.
-(Induction 1; Intros).
-Apply exchange_is_sub_permut with i:=i j:=j; [ Omega | Omega | Assumption ].
-Auto with datatypes.
-Auto with datatypes.
-EAuto with datatypes.
-Save.
diff --git a/contrib7/correctness/Arrays.v b/contrib7/correctness/Arrays.v
deleted file mode 100644
index 3fdc78c1..00000000
--- a/contrib7/correctness/Arrays.v
+++ /dev/null
@@ -1,75 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: Arrays.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
-
-(**********************************************)
-(* Functional arrays, for use in Correctness. *)
-(**********************************************)
-
-(* This is an axiomatization of arrays.
- *
- * The type (array N T) is the type of arrays ranging from 0 to N-1 
- * which elements are of type T.
- *
- * Arrays are created with new, accessed with access and modified with store. 
- *
- * Operations of accessing and storing are not guarded, but axioms are.
- * So these arrays can be viewed as arrays where accessing and storing
- * out of the bounds has no effect.
- *)
-
-
-Require Export ProgInt.
-
-Set Implicit Arguments.
-
-
-(* The type of arrays *)
-
-Parameter array : Z -> Set -> Set.
-
-
-(* Functions to create, access and modify arrays *)
-
-Parameter new : (n:Z)(T:Set) T -> (array n T).
-
-Parameter access : (n:Z)(T:Set) (array n T) -> Z -> T.
-
-Parameter store : (n:Z)(T:Set) (array n T) -> Z -> T -> (array n T).
-
-
-(* Axioms *)
-
-Axiom new_def : (n:Z)(T:Set)(v0:T)
-                (i:Z) `0<=i<n` -> (access (new n v0) i) = v0.
-
-Axiom store_def_1 : (n:Z)(T:Set)(t:(array n T))(v:T)
-                    (i:Z) `0<=i<n` ->
-                    (access (store t i v) i) = v.
-
-Axiom store_def_2 : (n:Z)(T:Set)(t:(array n T))(v:T)
-                    (i:Z)(j:Z) `0<=i<n` -> `0<=j<n` ->
-		    `i <> j` ->
-                    (access (store t i v) j) = (access t j).
-
-Hints Resolve new_def store_def_1 store_def_2 : datatypes v62.
-
-(* A tactic to simplify access in arrays *)
-
-Tactic Definition ArrayAccess i j H :=
-    Elim (Z_eq_dec i j); [ 
-      Intro H; Rewrite H; Rewrite store_def_1
-    | Intro H; Rewrite store_def_2; [ Idtac | Idtac | Idtac | Exact H ] ].
-
-(* Symbolic notation for access *)
-
-Notation "# t [ c ]" := (access t c) (at level 0, t ident)
-  V8only (at level 0, t at level 0).
diff --git a/contrib7/correctness/Exchange.v b/contrib7/correctness/Exchange.v
deleted file mode 100644
index 12c8c9de..00000000
--- a/contrib7/correctness/Exchange.v
+++ /dev/null
@@ -1,94 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: Exchange.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
-
-(****************************************************************************)
-(*                   Exchange of two elements in an array                   *)
-(*                        Definition and properties                         *)
-(****************************************************************************)
-
-Require ProgInt.
-Require Arrays.
-
-Set Implicit Arguments.
-
-(* Definition *)
-
-Inductive exchange [n:Z; A:Set; t,t':(array n A); i,j:Z] : Prop :=
-  exchange_c :
-    `0<=i<n` -> `0<=j<n` ->
-    (#t[i] = #t'[j]) ->
-    (#t[j] = #t'[i]) ->
-    ((k:Z)`0<=k<n` -> `k<>i` -> `k<>j` -> #t[k] = #t'[k]) ->
-    (exchange t t' i j).
-    
-(* Properties about exchanges *)
-
-Lemma exchange_1 : (n:Z)(A:Set)(t:(array n A))
-  (i,j:Z) `0<=i<n` -> `0<=j<n` ->
-  (access (store (store t i #t[j]) j #t[i]) i) = #t[j].
-Proof.
-Intros n A t i j H_i H_j.
-Case (dec_eq j i).
-Intro eq_i_j. Rewrite eq_i_j.
-Auto with datatypes.
-Intro not_j_i.
-Rewrite (store_def_2 (store t i #t[j]) #t[i] H_j H_i not_j_i).
-Auto with datatypes.
-Save.
-
-Hints Resolve exchange_1 : v62 datatypes.
-
-
-Lemma exchange_proof :
-  (n:Z)(A:Set)(t:(array n A))
-  (i,j:Z) `0<=i<n` -> `0<=j<n` ->
-  (exchange (store (store t i (access t j)) j (access t i)) t i j).
-Proof.
-Intros n A t i j H_i H_j.
-Apply exchange_c; Auto with datatypes.
-Intros k H_k not_k_i not_k_j.
-Cut ~j=k; Auto with datatypes. Intro not_j_k.
-Rewrite (store_def_2 (store t i (access t j)) (access t i) H_j H_k not_j_k).
-Auto with datatypes.
-Save.
-
-Hints Resolve exchange_proof : v62 datatypes.
-
-
-Lemma exchange_sym :
-  (n:Z)(A:Set)(t,t':(array n A))(i,j:Z)
-  (exchange t t' i j) -> (exchange t' t i j).
-Proof.
-Intros n A t t' i j H1.
-Elim H1. Clear H1. Intros.
-Constructor 1; Auto with datatypes.
-Intros. Rewrite (H3 k); Auto with datatypes.
-Save.
-
-Hints Resolve exchange_sym : v62 datatypes.
-
-
-Lemma exchange_id :
-  (n:Z)(A:Set)(t,t':(array n A))(i,j:Z)
-  (exchange t t' i j) -> 
-  i=j ->
-  (k:Z) `0 <= k < n` -> (access t k)=(access t' k).
-Proof.
-Intros n A t t' i j Hex Heq k Hk.
-Elim Hex. Clear Hex. Intros.
-Rewrite Heq in H1. Rewrite Heq in H2.
-Case (Z_eq_dec k j). 
-  Intro Heq'. Rewrite Heq'. Assumption.
-  Intro Hnoteq. Apply (H3 k); Auto with datatypes. Rewrite Heq. Assumption.
-Save.
-
-Hints Resolve exchange_id : v62 datatypes.
diff --git a/contrib7/correctness/ProgBool.v b/contrib7/correctness/ProgBool.v
deleted file mode 100644
index c7a7687d..00000000
--- a/contrib7/correctness/ProgBool.v
+++ /dev/null
@@ -1,66 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ProgBool.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
-
-Require ZArith.
-Require Export Bool_nat.
-Require Export Sumbool.
-
-Definition annot_bool :
-  (b:bool) { b':bool | if b' then b=true else b=false }.
-Proof.
-Intro b.
-Exists b. Case b; Trivial.
-Save.
-
-
-(* Logical connectives *)
-
-Definition spec_and := [A,B,C,D:Prop][b:bool]if b then A /\ C else B \/ D.
-
-Definition prog_bool_and :
-  (Q1,Q2:bool->Prop) (sig bool Q1) -> (sig bool Q2)
-  -> { b:bool | if b then (Q1 true) /\ (Q2 true)
-                     else (Q1 false) \/ (Q2 false) }.
-Proof.
-Intros Q1 Q2 H1 H2.
-Elim H1. Intro b1. Elim H2. Intro b2. 
-Case b1; Case b2; Intros.
-Exists true; Auto.
-Exists false; Auto. Exists false; Auto. Exists false; Auto.
-Save.
-
-Definition spec_or := [A,B,C,D:Prop][b:bool]if b then A \/ C else B /\ D.
-
-Definition prog_bool_or :
-  (Q1,Q2:bool->Prop) (sig bool Q1) -> (sig bool Q2)
-  -> { b:bool | if b then (Q1 true) \/ (Q2 true)
-                     else (Q1 false) /\ (Q2 false) }.
-Proof.
-Intros Q1 Q2 H1 H2.
-Elim H1. Intro b1. Elim H2. Intro b2. 
-Case b1; Case b2; Intros.
-Exists true; Auto. Exists true; Auto. Exists true; Auto.
-Exists false; Auto.
-Save.
-
-Definition spec_not:= [A,B:Prop][b:bool]if b then B else A.
-
-Definition prog_bool_not :
-  (Q:bool->Prop) (sig bool Q)
-  -> { b:bool | if b then (Q false) else (Q true) }.
-Proof.
-Intros Q H.
-Elim H. Intro b.
-Case b; Intro.
-Exists false; Auto. Exists true; Auto.
-Save.
-
diff --git a/contrib7/correctness/ProgramsExtraction.v b/contrib7/correctness/ProgramsExtraction.v
deleted file mode 100644
index 20f82ce4..00000000
--- a/contrib7/correctness/ProgramsExtraction.v
+++ /dev/null
@@ -1,30 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ProgramsExtraction.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
-
-Require Export Extraction.
-
-Extract Inductive unit => unit [ "()" ].
-Extract Inductive bool => bool [ true false ].
-Extract Inductive sumbool => bool [ true false ].
-
-Require Export Correctness.
-
-Declare ML Module "pextract".
-
-Grammar vernac vernac : ast :=
-  imperative_ocaml [ "Write" "Caml" "File" stringarg($file) 
-    "[" ne_identarg_list($idl) "]" "." ]
-     -> [ (IMPERATIVEEXTRACTION $file (VERNACARGLIST ($LIST $idl))) ]
-
-| initialize [ "Initialize" identarg($id) "with" comarg($c) "." ]
-     -> [ (INITIALIZE $id $c) ]
-.
diff --git a/contrib7/correctness/Sorted.v b/contrib7/correctness/Sorted.v
deleted file mode 100644
index f476142e..00000000
--- a/contrib7/correctness/Sorted.v
+++ /dev/null
@@ -1,198 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-(*  Library about sorted (sub-)arrays / Nicolas Magaud, July 1998 *)
-
-(* $Id: Sorted.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
-
-Require Export Arrays.
-Require ArrayPermut.
-
-Require ZArithRing.
-Require Omega.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-Set Implicit Arguments.
-
-(* Definition *)
-
-Definition sorted_array :=
-  [N:Z][A:(array N Z)][deb:Z][fin:Z]
-     `deb<=fin` -> (x:Z) `x>=deb` -> `x<fin` -> (Zle #A[x] #A[`x+1`]).
-
-(* Elements of a sorted sub-array are in increasing order *)
-
-(* one element and the next one *)
-
-Lemma sorted_elements_1 :
-  (N:Z)(A:(array N Z))(n:Z)(m:Z)
-  (sorted_array A n m)
-  -> (k:Z)`k>=n`
-  -> (i:Z) `0<=i` -> `k+i<=m`
-  -> (Zle (access A k) (access A `k+i`)).
-Proof.
-Intros N A n m H_sorted k H_k i H_i.
-Pattern i. Apply natlike_ind.
-Intro.
-Replace `k+0` with k; Omega. (*** Ring `k+0` => BUG ***)
-
-Intros.
-Apply Zle_trans with m:=(access A `k+x`).
-Apply H0 ; Omega.
-
-Unfold Zs.
-Replace `k+(x+1)` with `(k+x)+1`.
-Unfold sorted_array in H_sorted.
-Apply H_sorted ; Omega.
-
-Omega.
-
-Assumption.
-Save.
-
-(* one element and any of the following *)
-
-Lemma sorted_elements :
-  (N:Z)(A:(array N Z))(n:Z)(m:Z)(k:Z)(l:Z)
-  (sorted_array A n m)
-  -> `k>=n` -> `l<N` -> `k<=l` -> `l<=m`
-  -> (Zle (access A k) (access A l)).
-Proof.
-Intros.
-Replace l with `k+(l-k)`.
-Apply sorted_elements_1 with n:=n m:=m; [Assumption | Omega | Omega | Omega].
-Omega.
-Save.
-
-Hints Resolve sorted_elements : datatypes v62.
-
-(* A sub-array of a sorted array is sorted *)
-
-Lemma sub_sorted_array : (N:Z)(A:(array N Z))(deb:Z)(fin:Z)(i:Z)(j:Z)
-      (sorted_array A deb fin) -> 
-        (`i>=deb` -> `j<=fin` -> `i<=j` -> (sorted_array A i j)).
-Proof.
-Unfold sorted_array.
-Intros.
-Apply H ; Omega.
-Save.
-
-Hints Resolve sub_sorted_array : datatypes v62.
-
-(* Extension on the left of the property of being sorted *)
-
-Lemma left_extension : (N:Z)(A:(array N Z))(i:Z)(j:Z)
-   `i>0` -> `j<N` -> (sorted_array A i j) 
-   -> (Zle #A[`i-1`]  #A[i]) -> (sorted_array A `i-1` j).
-Proof.
-(Intros; Unfold sorted_array ; Intros).
-Elim (Z_ge_lt_dec x i).   (* (`x >= i`) + (`x < i`) *)
-Intro Hcut.
-Apply H1 ; Omega.
-
-Intro Hcut.
-Replace x with `i-1`.
-Replace `i-1+1` with i ; [Assumption | Omega].
-
-Omega.
-Save.
-
-(* Extension on the right *)
-
-Lemma right_extension : (N:Z)(A:(array N Z))(i:Z)(j:Z)
-   `i>=0` -> `j<N-1` -> (sorted_array A i j) 
-   -> (Zle #A[j]  #A[`j+1`]) -> (sorted_array A i `j+1`).
-Proof.
-(Intros; Unfold sorted_array ; Intros).
-Elim (Z_lt_ge_dec x j).
-Intro Hcut. 
-Apply H1 ; Omega.
-
-Intro HCut.
-Replace x with j ; [Assumption | Omega].
-Save.
-
-(* Substitution of the leftmost value by a smaller value *) 
-
-Lemma left_substitution : 
-   (N:Z)(A:(array N Z))(i:Z)(j:Z)(v:Z)
-   `i>=0`  -> `j<N`  -> (sorted_array A i j)
-   -> (Zle v #A[i])
-   -> (sorted_array (store A i v) i j).
-Proof.
-Intros N A i j v H_i H_j H_sorted H_v.
-Unfold sorted_array ; Intros.
-
-Cut `x = i`\/`x > i`.
-(Intro Hcut ; Elim Hcut ; Clear Hcut ; Intro).
-Rewrite H2.
-Rewrite store_def_1 ; Try Omega.
-Rewrite store_def_2 ; Try Omega.
-Apply Zle_trans with m:=(access A i) ; [Assumption | Apply H_sorted ; Omega].
-
-(Rewrite store_def_2; Try Omega).
-(Rewrite store_def_2; Try Omega).
-Apply H_sorted ; Omega.
-Omega.
-Save.
-
-(* Substitution of the rightmost value by a larger value *)
-
-Lemma right_substitution : 
-   (N:Z)(A:(array N Z))(i:Z)(j:Z)(v:Z)
-   `i>=0`  -> `j<N`  -> (sorted_array A i j)
-   -> (Zle #A[j] v)
-   -> (sorted_array (store A j v) i j).
-Proof.
-Intros N A i j v H_i H_j H_sorted H_v.
-Unfold sorted_array ; Intros.
-
-Cut `x = j-1`\/`x < j-1`.
-(Intro Hcut ; Elim Hcut ; Clear Hcut ; Intro).
-Rewrite H2.
-Replace `j-1+1` with j; [ Idtac | Omega ]. (*** Ring `j-1+1`. => BUG ***)
-Rewrite store_def_2 ; Try Omega.
-Rewrite store_def_1 ; Try Omega.
-Apply Zle_trans with m:=(access A j). 
-Apply sorted_elements with n:=i m:=j ; Try Omega ; Assumption.
-Assumption.
-
-(Rewrite store_def_2; Try Omega).
-(Rewrite store_def_2; Try Omega).
-Apply H_sorted ; Omega.
-
-Omega.
-Save.
-
-(* Affectation outside of the sorted region *)
-
-Lemma no_effect : 
-   (N:Z)(A:(array N Z))(i:Z)(j:Z)(k:Z)(v:Z)
-   `i>=0`  -> `j<N`  -> (sorted_array A i j)
-   -> `0<=k<i`\/`j<k<N`
-   -> (sorted_array (store A k v) i j).
-Proof.
-Intros.
-Unfold sorted_array ; Intros. 
-Rewrite store_def_2 ; Try Omega.
-Rewrite store_def_2 ; Try Omega.
-Apply H1 ; Assumption.
-Save.
-
-Lemma sorted_array_id : (N:Z)(t1,t2:(array N Z))(g,d:Z)
-  (sorted_array t1 g d) -> (array_id t1 t2 g d) -> (sorted_array t2 g d).
-Proof.
-Intros N t1 t2 g d Hsorted Hid.
-Unfold array_id in Hid.
-Unfold sorted_array in Hsorted. Unfold sorted_array.
-Intros Hgd x H1x H2x.
-Rewrite <- (Hid x); [ Idtac | Omega ].
-Rewrite <- (Hid `x+1`); [ Idtac | Omega ].
-Apply Hsorted; Assumption.
-Save.
diff --git a/contrib7/correctness/Tuples.v b/contrib7/correctness/Tuples.v
deleted file mode 100644
index 6e1eb03a..00000000
--- a/contrib7/correctness/Tuples.v
+++ /dev/null
@@ -1,106 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: Tuples.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
-
-(* Tuples *)
-
-Definition tuple_1 := [X:Set]X.
-Definition tuple_2 := prod.
-Definition Build_tuple_2 := pair.
-Definition proj_2_1 := fst.
-Definition proj_2_2 := snd.
-
-Record tuple_3 [ T1,T2,T3 : Set ] : Set := 
-  { proj_3_1 : T1 ;
-    proj_3_2 : T2 ;
-    proj_3_3 : T3 }.
-
-Record tuple_4 [ T1,T2,T3,T4 : Set ] : Set := 
-  { proj_4_1 : T1 ;
-    proj_4_2 : T2 ;
-    proj_4_3 : T3 ;
-    proj_4_4 : T4 }.
-
-Record tuple_5 [ T1,T2,T3,T4,T5 : Set ] : Set :=
-  { proj_5_1 : T1 ;
-    proj_5_2 : T2 ;
-    proj_5_3 : T3 ;
-    proj_5_4 : T4 ;
-    proj_5_5 : T5 }.
-
-Record tuple_6 [ T1,T2,T3,T4,T5,T6 : Set ] : Set :=
-  { proj_6_1 : T1 ;
-    proj_6_2 : T2 ;
-    proj_6_3 : T3 ;
-    proj_6_4 : T4 ;
-    proj_6_5 : T5 ;
-    proj_6_6 : T6 }.
-
-Record tuple_7 [ T1,T2,T3,T4,T5,T6,T7 : Set ] : Set :=
-  { proj_7_1 : T1 ;
-    proj_7_2 : T2 ;
-    proj_7_3 : T3 ;
-    proj_7_4 : T4 ;
-    proj_7_5 : T5 ;
-    proj_7_6 : T6 ;
-    proj_7_7 : T7 }.
-
-
-(* Existentials *)
-
-Definition sig_1 := sig.
-Definition exist_1 := exist.
-
-Inductive sig_2 [ T1,T2 : Set; P:T1->T2->Prop ] : Set := 
-  exist_2 : (x1:T1)(x2:T2)(P x1 x2) -> (sig_2 T1 T2 P).
-
-Inductive sig_3 [ T1,T2,T3 : Set; P:T1->T2->T3->Prop ] : Set := 
-  exist_3 : (x1:T1)(x2:T2)(x3:T3)(P x1 x2 x3) -> (sig_3 T1 T2 T3 P).
-
-
-Inductive sig_4 [ T1,T2,T3,T4 : Set;
-                  P:T1->T2->T3->T4->Prop ] : Set :=
-  exist_4 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)
-             (P x1 x2 x3 x4)
-          -> (sig_4 T1 T2 T3 T4 P).
-
-Inductive sig_5 [ T1,T2,T3,T4,T5 : Set;
-                  P:T1->T2->T3->T4->T5->Prop ] : Set :=
-  exist_5 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)(x5:T5)
-             (P x1 x2 x3 x4 x5)
-          -> (sig_5 T1 T2 T3 T4 T5 P).
-
-Inductive sig_6 [ T1,T2,T3,T4,T5,T6 : Set;
-                  P:T1->T2->T3->T4->T5->T6->Prop ] : Set :=
-  exist_6 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)(x5:T5)(x6:T6)
-             (P x1 x2 x3 x4 x5 x6)
-          -> (sig_6 T1 T2 T3 T4 T5 T6 P).
-
-Inductive sig_7 [ T1,T2,T3,T4,T5,T6,T7 : Set;
-                  P:T1->T2->T3->T4->T5->T6->T7->Prop ] : Set :=
-  exist_7 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)(x5:T5)(x6:T6)(x7:T7)
-             (P x1 x2 x3 x4 x5 x6 x7)
-          -> (sig_7 T1 T2 T3 T4 T5 T6 T7 P).
-
-Inductive sig_8 [ T1,T2,T3,T4,T5,T6,T7,T8 : Set;
-                  P:T1->T2->T3->T4->T5->T6->T7->T8->Prop ] : Set :=
-  exist_8 : (x1:T1)(x2:T2)(x3:T3)(x4:T4)(x5:T5)(x6:T6)(x7:T7)(x8:T8)
-             (P x1 x2 x3 x4 x5 x6 x7 x8)
-          -> (sig_8 T1 T2 T3 T4 T5 T6 T7 T8 P).      
-
-Inductive dep_tuple_2 [ T1,T2 : Set; P:T1->T2->Set ] : Set := 
-  Build_dep_tuple_2 : (x1:T1)(x2:T2)(P x1 x2) -> (dep_tuple_2 T1 T2 P).
-
-Inductive dep_tuple_3 [ T1,T2,T3 : Set; P:T1->T2->T3->Set ] : Set := 
-  Build_dep_tuple_3 : (x1:T1)(x2:T2)(x3:T3)(P x1 x2 x3)
-      	       	   -> (dep_tuple_3 T1 T2 T3 P).
-
-
diff --git a/contrib7/correctness/preuves.v b/contrib7/correctness/preuves.v
deleted file mode 100644
index 33659b43..00000000
--- a/contrib7/correctness/preuves.v
+++ /dev/null
@@ -1,128 +0,0 @@
-
-(* Quelques preuves sur des programmes simples,
- * juste histoire d'avoir un petit bench.
- *)
-
-Require Correctness.
-Require Omega.
-
-Global Variable x : Z ref.
-Global Variable y : Z ref.
-Global Variable z : Z ref.
-Global Variable i : Z ref.
-Global Variable j : Z ref.
-Global Variable n : Z ref.
-Global Variable m : Z ref.
-Variable r : Z.
-Variable N : Z.
-Global Variable t : array N of Z.
-
-(**********************************************************************)
-
-Require Exchange.
-Require ArrayPermut.
-
-Correctness swap
-  fun (N:Z)(t:array N of Z)(i,j:Z) ->
-    { `0 <= i < N` /\ `0 <= j < N` }
-    (let v = t[i] in
-     begin
-       t[i] := t[j];
-       t[j] := v
-     end)
-    { (exchange t t@ i j) }.
-Proof.
-Auto with datatypes.
-Save.
-
-Correctness downheap
-  let rec downheap (N:Z)(t:array N of Z) : unit { variant `0` } =
-    (swap N t 0 0) { True }
-.
-
-(**********************************************************************)
-
-Global Variable x : Z ref.
-Debug on.
-Correctness assign0 (x := 0) { `x=0` }.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness assign1 { `0 <= i` } (i := !i + 1) { `0 < i` }.
-Omega.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness if0 { `0 <= i` } (if !i>0 then i:=!i-1 else tt) { `0 <= i` }.
-Omega.
-Save.
-
-(**********************************************************************)
-
-Global Variable i : Z ref.
-Debug on.
-Correctness assert0 { `0 <= i` } begin assert { `i=2` }; i:=!i-1 end { `i=1` }.
-
-(**********************************************************************)
-
-Correctness echange
-  { `0 <= i < N` /\ `0 <= j < N` }
-  begin
-    label B;
-    x := t[!i]; t[!i] := t[!j]; t[!j] := !x;
-    assert { #t[i] = #t@B[j] /\ #t[j] = #t@B[i] }
-  end.
-Proof.
-Auto with datatypes.
-Save.
-
-  
-(**********************************************************************)
-
-(*
- *   while x <= y do x := x+1 done { y < x }
- *)
-
-Correctness incrementation
-  while !x < !y do
-    { invariant True variant `(Zs y)-x` }
-    x := !x + 1
-  done
-  { `y < x` }.
-Proof.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Omega.
-Exact I.
-Save.
-
-
-(************************************************************************)
-
-Correctness pivot1
-  begin
-    while (Z_lt_ge_dec !i r) do
-      { invariant True variant (Zminus (Zs r) i) } i := (Zs !i)
-    done;
-    while (Z_lt_ge_dec r !j) do
-      { invariant True variant (Zminus (Zs j) r) } j := (Zpred !j)
-    done
-  end
-  { `j <= r` /\ `r <= i` }.
-Proof.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Omega.
-Exact I.
-Exact (Zwf_well_founded `0`).
-Unfold Zwf. Unfold Zpred. Omega.
-Exact I.
-Omega.
-Save.
-
-
-
diff --git a/contrib7/extraction/test_extraction.v b/contrib7/extraction/test_extraction.v
deleted file mode 100644
index e76b1c69..00000000
--- a/contrib7/extraction/test_extraction.v
+++ /dev/null
@@ -1,533 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-Require Arith.
-Require PolyList.
-
-(*** STANDARD EXAMPLES *)
-
-(** Functions. *)
-
-Definition idnat := [x:nat]x.
-Extraction idnat.
-(* let idnat x = x *)
-
-Definition id := [X:Type][x:X]x.      
-Extraction id. (* let id x = x *)
-Definition id' := (id Set nat).
-Extraction id'. (* type id' = nat *)
-
-Definition test2 := [f:nat->nat][x:nat](f x).
-Extraction test2.
-(* let test2 f x = f x *)
-
-Definition test3 := [f:nat->Set->nat][x:nat](f x nat).
-Extraction test3.
-(* let test3 f x = f x __ *)
-
-Definition test4 := [f:(nat->nat)->nat][x:nat][g:nat->nat](f g).
-Extraction test4.
-(* let test4 f x g = f g *)
-
-Definition test5 := ((1),(0)).
-Extraction test5.
-(* let test5 = Pair ((S O), O) *)
-
-Definition cf :=  [x:nat][_:(le x O)](S x).
-Extraction NoInline cf.
-Definition test6 := (cf O (le_n O)).
-Extraction test6.  
-(* let test6 = cf O *)
-
-Definition test7 := ([X:Set][x:X]x nat).
-Extraction test7.
-(* let test7 x = x *)
-
-Definition d := [X:Type]X.
-Extraction d. (* type 'x d = 'x *)
-Definition d2 := (d Set).
-Extraction d2. (* type d2 = __ d *)
-Definition d3 := [x:(d Set)]O.
-Extraction d3. (* let d3 _ = O *)
-Definition d4 := (d nat). 
-Extraction d4. (* type d4 = nat d *)
-Definition d5 := ([x:(d Type)]O Type).  
-Extraction d5.  (* let d5 = O *)
-Definition d6 := ([x:(d Type)]x).
-Extraction d6.  (* type 'x d6 = 'x *)
-
-Definition test8 := ([X:Type][x:X]x Set nat).
-Extraction test8. (* type test8 = nat *)
-
-Definition test9 := let t = nat in (id Set t).
-Extraction test9.  (* type test9 = nat *)
-
-Definition test10 := ([X:Type][x:X]O Type Type).
-Extraction test10. (* let test10 = O *)
-
-Definition test11 := let n=O in let p=(S n) in (S p).
-Extraction test11. (* let test11 = S (S O) *)
-
-Definition test12 := (x:(X:Type)X->X)(x Type Type).
-Extraction test12. 
-(* type test12 = (__ -> __ -> __) -> __ *)
-
-
-Definition test13 := Cases (left True True I) of (left x)=>(S O) | (right x)=>O end.
-Extraction test13. (* let test13 = S O *)
-
-
-(** example with more arguments that given by the type *)
-
-Definition test19 := (nat_rec [n:nat]nat->nat [n:nat]O [n:nat][f:nat->nat]f O O).
-Extraction test19.
-(* let test19 =
-  let rec f = function
-    | O -> (fun n0 -> O)
-    | S n0 -> f n0
-  in f O O
-*)
-
-
-(** casts *)
-
-Definition test20 := (True :: Type).
-Extraction test20.
-(* type test20 = __ *)
-
-
-(** Simple inductive type and recursor. *)
-
-Extraction nat.
-(* 
-type nat = 
-  | O 
-  | S of nat 
-*)
-
-Extraction sumbool_rect.
-(* 
-let sumbool_rect f f0 = function
-  |  Left -> f __
-  | Right -> f0 __
-*)
-
-(** Less simple inductive type. *)
-
-Inductive c [x:nat] : nat -> Set :=
-    refl : (c x x)                  
-  | trans : (y,z:nat)(c x y)->(le y z)->(c x z).
-Extraction c.
-(* 
-type c =
-  | Refl
-  | Trans of nat * nat * c
-*)
-
-Definition Ensemble := [U:Type]U->Prop.
-Definition Empty_set := [U:Type][x:U]False.
-Definition Add := [U:Type][A:(Ensemble U)][x:U][y:U](A y) \/ x==y.
-
-Inductive Finite [U:Type] : (Ensemble U) -> Set :=
-      Empty_is_finite: (Finite U (Empty_set U))
-   |  Union_is_finite:
-      (A: (Ensemble U)) (Finite U A) -> 
-      (x: U) ~ (A x) -> (Finite U (Add U A x)).
-Extraction Finite.
-(* 
-type 'u finite =
-  | Empty_is_finite
-  | Union_is_finite of 'u finite * 'u
-*)
-
-
-(** Mutual Inductive *)
-
-Inductive tree : Set := 
-   Node : nat -> forest -> tree
-with forest : Set :=
- | Leaf : nat -> forest
- | Cons : tree -> forest -> forest .
-
-Extraction tree.
-(* 
-type tree =
-  | Node of nat * forest
-and forest =
-  | Leaf of nat
-  | Cons of tree * forest
-*)
-
-Fixpoint tree_size [t:tree] : nat :=
-         Cases t of (Node a f) => (S (forest_size f)) end
-with forest_size [f:forest] : nat :=
-         Cases f of 
-	 | (Leaf b) => (S O)
-         | (Cons t f') => (plus (tree_size t) (forest_size f'))
-         end.
-
-Extraction tree_size.
-(* 
-let rec tree_size = function
-  | Node (a, f) -> S (forest_size f)
-and forest_size = function
-  | Leaf b -> S O
-  | Cons (t, f') -> plus (tree_size t) (forest_size f')
-*)
-
-
-(** Eta-expansions of inductive constructor *)
-
-Inductive titi : Set := tata : nat->nat->nat->nat->titi.
-Definition test14 := (tata O).
-Extraction test14.
-(* let test14 x x0 x1 = Tata (O, x, x0, x1) *)
-Definition test15 := (tata O (S O)).
-Extraction test15. 
-(* let test15 x x0 = Tata (O, (S O), x, x0) *)
-
-Inductive eta : Set := eta_c : nat->Prop->nat->Prop->eta.
-Extraction eta_c.
-(* 
-type eta =
-  | Eta_c of nat * nat
-*)
-Definition test16 := (eta_c O).
-Extraction test16.
-(* let test16 x = Eta_c (O, x) *)
-Definition test17 := (eta_c O True).
-Extraction test17.
-(* let test17 x = Eta_c (O, x) *)
-Definition test18 := (eta_c O True O).
-Extraction test18. 
-(* let test18 _ = Eta_c (O, O) *)
-
-
-(** Example of singleton inductive type *)
-
-Inductive bidon [A:Prop;B:Type] : Set := tb : (x:A)(y:B)(bidon A B). 
-Definition fbidon := [A,B:Type][f:A->B->(bidon True nat)][x:A][y:B](f x y).
-Extraction bidon.
-(* type 'b bidon = 'b *)
-Extraction tb.
-(* tb : singleton inductive constructor *)
-Extraction fbidon.
-(* let fbidon f x y =
-  f x y
-*)
-
-Definition fbidon2 := (fbidon True nat (tb True nat)).
-Extraction fbidon2. (* let fbidon2 y = y *)
-Extraction NoInline fbidon.
-Extraction fbidon2.
-(* let fbidon2 y = fbidon (fun _ x -> x) __ y *)
-
-(* NB: first argument of fbidon2 has type [True], so it disappears. *)
-
-(** mutual inductive on many sorts *)
-
-Inductive 
-  test_0 : Prop := ctest0 : test_0 
-with 
-  test_1 : Set := ctest1 : test_0-> test_1.  
-Extraction test_0.
-(* test0 : logical inductive *)
-Extraction test_1. 
-(* 
-type test1 =
-  | Ctest1
-*)
-
-(** logical singleton *)
-
-Extraction eq.
-(* eq : logical inductive *)
-Extraction eq_rect.
-(* let eq_rect x f y =
-  f
-*)
-
-(** No more propagation of type parameters. Obj.t instead. *)
-
-Inductive tp1 : Set := 
-  T : (C:Set)(c:C)tp2 -> tp1 with tp2 : Set  := T' : tp1->tp2.
-Extraction tp1.
-(* 
-type tp1 =
-  | T of __ * tp2
-and tp2 =
-  | T' of tp1
-*) 
-
-Inductive tp1bis : Set := 
-  Tbis : tp2bis -> tp1bis 
-with tp2bis : Set  := T'bis : (C:Set)(c:C)tp1bis->tp2bis.
-Extraction tp1bis.
-(* 
-type tp1bis =
-  | Tbis of tp2bis
-and tp2bis =
-  | T'bis of __ * tp1bis
-*)
-
-
-(** Strange inductive type. *)
-
-Inductive Truc : Set->Set :=
-       chose  : (A:Set)(Truc A)
-     | machin : (A:Set)A->(Truc bool)->(Truc A).
-Extraction Truc.
-(*
-type 'x truc =
-  | Chose
-  | Machin of 'x * bool truc
-*)
-
-
-(** Dependant type over Type *)
-
-Definition test24:= (sigT Set [a:Set](option a)).
-Extraction test24.
-(* type test24 = (__, __ option) sigT *)
-
-
-(** Coq term non strongly-normalizable after extraction *)
-
-Require Gt.
-Definition loop := 
- [Ax:(Acc nat gt O)]
- (Fix F {F [a:nat;b:(Acc nat gt a)] : nat := 
-          (F (S a) (Acc_inv nat gt a b (S a) (gt_Sn_n a)))}
- O Ax).
-Extraction loop.
-(* let loop _ =
-  let rec f a =
-    f (S a)
-  in f O
-*)
-
-(*** EXAMPLES NEEDING OBJ.MAGIC *)
-
-(** False conversion of type: *)
-
-Lemma oups : (H:(nat==(list nat)))nat -> nat.
-Intros.
-Generalize H0;Intros.
-Rewrite H in H1.
-Case H1.
-Exact H0.
-Intros.
-Exact n.
-Qed.
-Extraction oups.
-(* 
-let oups h0 = 
-  match Obj.magic h0 with
-    | Nil -> h0
-    | Cons0 (n, l) -> n
-*)
-
-
-(** hybrids *)
-
-Definition horibilis := [b:bool]<[b:bool]if b then Type else nat>if b then Set else O.
-Extraction horibilis.
-(* 
-let horibilis = function
-  | True -> Obj.magic __
-  | False -> Obj.magic O
-*)
-
-Definition PropSet := [b:bool]if b then Prop else Set.
-Extraction PropSet. (* type propSet = __ *)
-
-Definition natbool := [b:bool]if b then nat else bool.
-Extraction natbool. (* type natbool = __ *)
-
-Definition zerotrue := [b:bool]<natbool>if b then O else true.
-Extraction zerotrue. 
-(* 
-let zerotrue = function
-  | True -> Obj.magic O
-  | False -> Obj.magic True
-*)
-
-Definition natProp := [b:bool]<[_:bool]Type>if b then nat else Prop.
-
-Definition natTrue := [b:bool]<[_:bool]Type>if b then nat else True.
-
-Definition zeroTrue := [b:bool]<natProp>if b then O else True.
-Extraction zeroTrue.
-(* 
-let zeroTrue = function
-  | True -> Obj.magic O
-  | False -> Obj.magic __
-*)
-
-Definition natTrue2 := [b:bool]<[_:bool]Type>if b then nat else True.
-
-Definition zeroprop := [b:bool]<natTrue>if b then O else I.
-Extraction zeroprop.
-(* 
-let zeroprop = function
-  | True -> Obj.magic O
-  | False -> Obj.magic __
-*)
-
-(** polymorphic f applied several times *)
-
-Definition test21 := (id nat O, id bool true).
-Extraction test21.
-(* let test21 = Pair ((id O), (id True)) *)
-
-(** ok *)
-
-Definition test22 := ([f:(X:Type)X->X](f nat O, f bool true) [X:Type][x:X]x).
-Extraction test22. 
-(* let test22 = 
-  let f = fun x -> x in Pair ((f O), (f True)) *)
-
-(* still ok via optim beta -> let *)
-
-Definition test23 := [f:(X:Type)X->X](f nat O, f bool true).
-Extraction test23.
-(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *)
-
-(* problem: fun f -> (f 0, f true) not legal in ocaml *)
-(* solution: magic ... *)
-
-
-(** Dummy constant __ can be applied.... *)
-
-Definition f : (X:Type)(nat->X)->(X->bool)->bool := 
- [X:Type;x:nat->X;y:X->bool](y (x O)).
-Extraction f.
-(* let f x y =
-  y (x O)
-*)
-
-Definition f_prop := (f (O=O) [_](refl_equal ? O) [_]true).
-Extraction NoInline f.
-Extraction f_prop.
-(* let f_prop =
-  f (Obj.magic __) (fun _ -> True)
-*)
-
-Definition f_arity := (f Set [_:nat]nat [_:Set]true).
-Extraction f_arity.
-(* let f_arity =
-  f (Obj.magic __) (fun _ -> True)
-*)
-
-Definition f_normal := (f nat [x]x [x](Cases x of O => true | _ => false end)).
-Extraction f_normal.
-(* let f_normal =
-  f (fun x -> x) (fun x -> match x with
-                             | O -> True
-                             | S n -> False)
-*)
-
-
-(* inductive with magic needed *)
-
-Inductive Boite : Set := 
-  boite : (b:bool)(if b then nat else nat*nat)->Boite. 
-Extraction Boite. 
-(*
-type boite =
-  | Boite of bool * __
-*)
-
-
-Definition boite1 := (boite true O).
-Extraction boite1.
-(* let boite1 = Boite (True, (Obj.magic O)) *)
-
-Definition boite2 := (boite false (O,O)).
-Extraction boite2.
-(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *)
-
-Definition test_boite := [B:Boite]<nat>Cases B of 
-  (boite true n) => n 
-| (boite false n) => (plus (fst ? ? n) (snd ? ? n))
-end.
-Extraction test_boite. 
-(* 
-let test_boite = function
-  | Boite (b0, n) ->
-      (match b0 with
-         | True -> Obj.magic n
-         | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n)))
-*)
-
-(* singleton inductive with magic needed *)
-
-Inductive Box : Set := 
-  box : (A:Set)A -> Box. 
-Extraction Box.
-(* type box = __ *)
-
-Definition box1 := (box nat O). 
-Extraction box1. (* let box1 = Obj.magic O *)
-
-(* applied constant, magic needed *)
-
-Definition idzarb := [b:bool][x:(if b then nat else bool)]x.
-Definition zarb := (idzarb true O).
-Extraction NoInline idzarb. 
-Extraction zarb. 
-(* let zarb = Obj.magic idzarb True (Obj.magic O) *)
-
-(** function of variable arity. *)
-(** Fun n = nat -> nat -> ... -> nat *)  
-
-Fixpoint Fun [n:nat] : Set := 
-   Cases n of 
-     O => nat
-   | (S n) => nat -> (Fun n)
-  end.
-
-Fixpoint Const [k,n:nat] : (Fun n) := 
-  <Fun>Cases n of 
-     O => k 
-   | (S n) => [p:nat](Const k n)
-  end.
-
-Fixpoint proj [k,n:nat] : (Fun n) := 
-  <Fun>Cases n of 
-    O => O (* ou assert false ....*)
-  | (S n) => Cases k of 
-             O => [x](Const x n)
-           | (S k) => [x](proj k n)
-          end 
-  end. 
-
-Definition test_proj := (proj (2) (4) (0) (1) (2) (3)).
-
-Eval Compute in test_proj. 
-
-Recursive Extraction test_proj. 
-
-
-
-(*** TO SUM UP: ***) 
-
-
-Extraction "test_extraction.ml" 
-  idnat id id' test2 test3 test4 test5 test6 test7 
-  d d2 d3 d4 d5 d6 test8 id id' test9 test10 test11 
-  test12 test13 test19 test20 
-  nat sumbool_rect c Finite tree tree_size
-  test14 test15 eta_c test16 test17 test18 bidon tb fbidon fbidon2 
-  fbidon2 test_0 test_1 eq eq_rect tp1 tp1bis Truc oups test24 loop
-  horibilis PropSet natbool zerotrue zeroTrue zeroprop test21 test22 
-  test23 f f_prop f_arity f_normal
-  Boite boite1 boite2 test_boite
-  Box box1 zarb test_proj.
-
-
diff --git a/contrib7/field/Field_Compl.v b/contrib7/field/Field_Compl.v
deleted file mode 100644
index 2cc01038..00000000
--- a/contrib7/field/Field_Compl.v
+++ /dev/null
@@ -1,62 +0,0 @@
-(************************************************************************)
-(*  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: Field_Compl.v,v 1.2.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
-
-Inductive listT [A:Type] : Type :=
-  nilT : (listT A) | consT : A->(listT A)->(listT A).
-
-Fixpoint appT [A:Type][l:(listT A)] : (listT A) -> (listT A) :=
-  [m:(listT A)]
-  Cases l of
-  | nilT => m 
-  | (consT a l1) => (consT A a (appT A l1 m))
-  end.
-
-Inductive prodT [A,B:Type] : Type :=
-  pairT: A->B->(prodT A B).
-
-Definition assoc_2nd :=
-Fix assoc_2nd_rec
-  {assoc_2nd_rec 
-   [A:Type;B:Set;eq_dec:(e1,e2:B){e1=e2}+{~e1=e2};lst:(listT (prodT A B))]
-   : B->A->A:=
-  [key:B;default:A]
-  Cases lst of
-  | nilT => default
-  | (consT (pairT v e) l) =>
-    (Cases (eq_dec e key) of
-    | (left _) => v
-    | (right _) => (assoc_2nd_rec A B eq_dec l key default)
-    end)
-  end}.
-
-Definition fstT [A,B:Type;c:(prodT A B)] :=
-  Cases c of
-  | (pairT a _) => a
-  end.
-
-Definition sndT [A,B:Type;c:(prodT A B)] :=
-  Cases c of
-  | (pairT _ a) => a
-  end.
-
-Definition mem :=
-Fix mem {mem [A:Set;eq_dec:(e1,e2:A){e1=e2}+{~e1=e2};a:A;l:(listT A)] : bool :=
-  Cases l of
-  | nilT => false
-  | (consT a1 l1) =>
-    Cases (eq_dec a a1) of
-    | (left _) => true
-    | (right _) => (mem A eq_dec a l1)
-    end
-  end}.
-
-Inductive field_rel_option [A:Type] : Type :=
-  | Field_None : (field_rel_option A)
-  | Field_Some : (A -> A -> A) -> (field_rel_option A).
diff --git a/contrib7/field/Field_Tactic.v b/contrib7/field/Field_Tactic.v
deleted file mode 100644
index ffd2aad4..00000000
--- a/contrib7/field/Field_Tactic.v
+++ /dev/null
@@ -1,397 +0,0 @@
-(************************************************************************)
-(*  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: Field_Tactic.v,v 1.2.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
-
-Require Ring.
-Require Export Field_Compl.
-Require Export Field_Theory.
-
-(**** Interpretation A --> ExprA ****)
-
-Recursive Tactic Definition MemAssoc var lvar :=
-  Match lvar With
-  | [(nilT ?)] -> false
-  | [(consT ? ?1 ?2)] ->
-    (Match ?1=var With
-     | [?1=?1] -> true
-     | _ -> (MemAssoc var ?2)).
-
-Recursive Tactic Definition SeekVarAux FT lvar trm :=
-  Let AT     = Eval Cbv Beta Delta [A] Iota in (A FT)
-  And AzeroT = Eval Cbv Beta Delta [Azero] Iota in (Azero FT)
-  And AoneT  = Eval Cbv Beta Delta [Aone] Iota in (Aone FT)
-  And AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT)
-  And AmultT = Eval Cbv Beta Delta [Amult] Iota in (Amult FT)
-  And AoppT  = Eval Cbv Beta Delta [Aopp] Iota in (Aopp FT)
-  And AinvT  = Eval Cbv Beta Delta [Ainv] Iota in (Ainv FT) In 
-  Match trm With
-  | [(AzeroT)] -> lvar
-  | [(AoneT)] -> lvar
-  | [(AplusT ?1 ?2)] ->
-    Let l1 = (SeekVarAux FT lvar ?1) In
-    (SeekVarAux FT l1 ?2)
-  | [(AmultT ?1 ?2)] ->
-    Let l1 = (SeekVarAux FT lvar ?1) In
-    (SeekVarAux FT l1 ?2)
-  | [(AoppT ?1)] -> (SeekVarAux FT lvar ?1)
-  | [(AinvT ?1)] -> (SeekVarAux FT lvar ?1)
-  | [?1] ->
-    Let res = (MemAssoc ?1 lvar) In
-    Match res With
-    | [(true)] -> lvar
-    | [(false)] -> '(consT AT ?1 lvar).
-
-Tactic Definition SeekVar FT trm :=
-  Let AT = Eval Cbv Beta Delta [A] Iota in (A FT) In
-  (SeekVarAux FT '(nilT AT) trm).
-
-Recursive Tactic Definition NumberAux lvar cpt :=
-  Match lvar With
-  | [(nilT ?1)] -> '(nilT (prodT ?1 nat))
-  | [(consT ?1 ?2 ?3)] ->
-    Let l2 = (NumberAux ?3 '(S cpt)) In
-    '(consT (prodT ?1 nat) (pairT ?1 nat ?2 cpt) l2).
-
-Tactic Definition Number lvar := (NumberAux lvar O).
-
-Tactic Definition BuildVarList FT trm :=
-  Let lvar = (SeekVar FT trm) In
-  (Number lvar).
-V7only [
-(*Used by contrib Maple *)
-Tactic Definition build_var_list := BuildVarList.
-].
-
-Recursive Tactic Definition Assoc elt lst :=
-  Match lst With
-  | [(nilT ?)] -> Fail
-  | [(consT (prodT ? nat) (pairT ? nat ?1 ?2) ?3)] ->
-    Match elt= ?1 With
-    | [?1= ?1] -> ?2
-    | _ -> (Assoc elt ?3).
-
-Recursive Meta Definition interp_A FT lvar trm :=
-  Let AT     = Eval Cbv Beta Delta [A] Iota in (A FT)
-  And AzeroT = Eval Cbv Beta Delta [Azero] Iota in (Azero FT)
-  And AoneT  = Eval Cbv Beta Delta [Aone] Iota in (Aone FT)
-  And AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT)
-  And AmultT = Eval Cbv Beta Delta [Amult] Iota in (Amult FT)
-  And AoppT  = Eval Cbv Beta Delta [Aopp] Iota in (Aopp FT)
-  And AinvT  = Eval Cbv Beta Delta [Ainv] Iota in (Ainv FT) In
-  Match trm With
-  | [(AzeroT)] -> EAzero
-  | [(AoneT)] -> EAone
-  | [(AplusT ?1 ?2)] ->
-    Let e1 = (interp_A FT lvar ?1)
-    And e2 = (interp_A FT lvar ?2) In
-    '(EAplus e1 e2)
-  | [(AmultT ?1 ?2)] ->
-    Let e1 = (interp_A FT lvar ?1)
-    And e2 = (interp_A FT lvar ?2) In
-    '(EAmult e1 e2)
-  | [(AoppT ?1)] ->
-    Let e = (interp_A FT lvar ?1) In
-    '(EAopp e)
-  | [(AinvT ?1)] ->
-    Let e = (interp_A FT lvar ?1) In
-    '(EAinv e)
-  | [?1] ->
-    Let idx = (Assoc ?1 lvar) In
-    '(EAvar idx).
-
-(************************)
-(*    Simplification    *)
-(************************)
-
-(**** Generation of the multiplier ****)
-
-Recursive Tactic Definition Remove e l :=
-  Match l With
-  | [(nilT ?)] -> l
-  | [(consT ?1 e ?2)] -> ?2
-  | [(consT ?1 ?2 ?3)] ->
-    Let nl = (Remove e ?3) In
-    '(consT ?1 ?2 nl).
-
-Recursive Tactic Definition Union l1 l2 :=
-  Match l1 With
-  | [(nilT ?)] -> l2
-  | [(consT ?1 ?2 ?3)] ->
-    Let nl2 = (Remove ?2 l2) In
-    Let nl = (Union ?3 nl2) In
-    '(consT ?1 ?2 nl).
-
-Recursive Tactic Definition RawGiveMult trm :=
-  Match trm With
-  | [(EAinv ?1)] -> '(consT ExprA ?1 (nilT ExprA))
-  | [(EAopp ?1)] -> (RawGiveMult ?1)
-  | [(EAplus ?1 ?2)] ->
-    Let l1 = (RawGiveMult ?1)
-    And l2 = (RawGiveMult ?2) In
-    (Union l1 l2)
-  | [(EAmult ?1 ?2)] ->
-    Let l1 = (RawGiveMult ?1)
-    And l2 = (RawGiveMult ?2) In
-    Eval Compute in (appT ExprA l1 l2)
-  | _ -> '(nilT ExprA).
-
-Tactic Definition GiveMult trm :=
-  Let ltrm = (RawGiveMult trm) In
-  '(mult_of_list ltrm).
-
-(**** Associativity ****)
-
-Tactic Definition ApplyAssoc FT lvar trm :=
-  Let t=Eval Compute in (assoc trm) In
-  Match t=trm With
-  | [ ?1=?1 ] -> Idtac
-  | _ -> Rewrite <- (assoc_correct FT trm); Change (assoc trm) with t.
-
-(**** Distribution *****)
-
-Tactic Definition ApplyDistrib FT lvar trm :=
-  Let t=Eval Compute in (distrib trm) In
-  Match t=trm With
-  | [ ?1=?1 ] -> Idtac
-  | _ -> Rewrite <- (distrib_correct FT trm); Change (distrib trm) with t.
-
-(**** Multiplication by the inverse product ****)
-
-Tactic Definition GrepMult :=
-  Match Context With
-    | [ id: ~(interp_ExprA ? ? ?)= ? |- ?] -> id.
-
-Tactic Definition WeakReduce :=
-  Match Context With
-  | [|-[(interp_ExprA ?1 ?2 ?)]] ->
-    Cbv Beta Delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list ?1 ?2 A
-                    Azero Aone Aplus Amult Aopp Ainv] Zeta Iota.
-
-Tactic Definition Multiply mul :=
-  Match Context With
-  | [|-(interp_ExprA ?1 ?2 ?3)=(interp_ExprA ?1 ?2 ?4)] ->
-    Let AzeroT = Eval Cbv Beta Delta [Azero ?1] Iota in (Azero ?1) In
-    Cut ~(interp_ExprA ?1 ?2 mul)=AzeroT;
-    [Intro;
-     Let id = GrepMult In
-     Apply (mult_eq ?1 ?3 ?4 mul ?2 id)
-    |WeakReduce;
-     Let AoneT  = Eval Cbv Beta Delta [Aone ?1] Iota in (Aone ?1)
-     And AmultT = Eval Cbv Beta Delta [Amult ?1] Iota in (Amult ?1) In
-     Try (Match Context With
-          | [|-[(AmultT ? AoneT)]] -> Rewrite (AmultT_1r ?1));Clear ?1 ?2].
-
-Tactic Definition ApplyMultiply FT lvar trm :=
-  Let t=Eval Compute in (multiply trm) In
-  Match t=trm With
-  | [ ?1=?1 ] -> Idtac
-  | _ -> Rewrite <- (multiply_correct FT trm); Change (multiply trm) with t.
-
-(**** Permutations and simplification ****)
-
-Tactic Definition ApplyInverse mul FT lvar trm :=
-  Let t=Eval Compute in (inverse_simplif mul trm) In
-  Match t=trm With
-  | [ ?1=?1 ] -> Idtac
-  | _ -> Rewrite <- (inverse_correct FT trm mul);
-         [Change (inverse_simplif mul trm) with t|Assumption].
-(**** Inverse test ****)
-
-Tactic Definition StrongFail tac := First [tac|Fail 2].
-
-Recursive Tactic Definition InverseTestAux FT trm :=
-  Let AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT)
-  And AmultT = Eval Cbv Beta Delta [Amult] Iota in (Amult FT)
-  And AoppT  = Eval Cbv Beta Delta [Aopp] Iota in (Aopp FT)
-  And AinvT  = Eval Cbv Beta Delta [Ainv] Iota in (Ainv FT) In
-  Match trm With
-  | [(AinvT ?)] -> Fail 1
-  | [(AoppT ?1)] -> StrongFail ((InverseTestAux FT ?1);Idtac)
-  | [(AplusT ?1 ?2)] ->
-    StrongFail ((InverseTestAux FT ?1);(InverseTestAux FT ?2))
-  | [(AmultT ?1 ?2)] ->
-    StrongFail ((InverseTestAux FT ?1);(InverseTestAux FT ?2))
-  | _ -> Idtac.
-
-Tactic Definition InverseTest FT :=
-  Let AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT) In
-  Match Context With
-  | [|- ?1=?2] -> (InverseTestAux FT '(AplusT ?1 ?2)).
-
-(**** Field itself ****)
-
-Tactic Definition ApplySimplif sfun :=
-  (Match Context With
-   | [|- (interp_ExprA ?1 ?2 ?3)=(interp_ExprA ? ? ?)] ->
-     (sfun ?1 ?2 ?3));
-  (Match Context With
-   | [|- (interp_ExprA ? ? ?)=(interp_ExprA ?1 ?2 ?3)] ->
-     (sfun ?1 ?2 ?3)).
-
-Tactic Definition Unfolds FT :=
-  (Match Eval Cbv Beta Delta [Aminus] Iota in (Aminus FT) With
-   | [(Field_Some ? ?1)] -> Unfold ?1
-   | _ -> Idtac);
-  (Match Eval Cbv Beta Delta [Adiv] Iota in (Adiv FT) With
-   | [(Field_Some ? ?1)] -> Unfold ?1
-   | _ -> Idtac).
-
-Tactic Definition Reduce FT :=
-  Let AzeroT = Eval Cbv Beta Delta [Azero] Iota in (Azero FT)
-  And AoneT  = Eval Cbv Beta Delta [Aone] Iota in (Aone FT)
-  And AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT)
-  And AmultT = Eval Cbv Beta Delta [Amult] Iota in (Amult FT)
-  And AoppT  = Eval Cbv Beta Delta [Aopp] Iota in (Aopp FT)
-  And AinvT  = Eval Cbv Beta Delta [Ainv] Iota in (Ainv FT) In
-  Cbv Beta Delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] Zeta Iota
-  Orelse Compute.
-
-Recursive Tactic Definition Field_Gen_Aux FT :=
-  Let AplusT = Eval Cbv Beta Delta [Aplus] Iota in (Aplus FT) In
-  Match Context With
-  | [|- ?1=?2] ->
-    Let lvar = (BuildVarList FT '(AplusT ?1 ?2)) In
-    Let trm1 = (interp_A FT lvar ?1)
-    And trm2 = (interp_A FT lvar ?2) In
-    Let mul = (GiveMult '(EAplus trm1 trm2)) In
-    Cut [ft:=FT][vm:=lvar](interp_ExprA ft vm trm1)=(interp_ExprA ft vm trm2);
-    [Compute;Auto
-    |Intros ft vm;(ApplySimplif ApplyDistrib);(ApplySimplif ApplyAssoc);
-     (Multiply mul);[(ApplySimplif ApplyMultiply);
-       (ApplySimplif (ApplyInverse mul));
-       (Let id = GrepMult In Clear id);WeakReduce;Clear ft vm;
-       First [(InverseTest FT);Ring|(Field_Gen_Aux FT)]|Idtac]].
-
-Tactic Definition Field_Gen FT :=
-  Unfolds FT;((InverseTest FT);Ring) Orelse (Field_Gen_Aux FT).
-V7only [Tactic Definition field_gen := Field_Gen.].
-
-(*****************************)
-(*    Term Simplification    *)
-(*****************************)
-
-(**** Minus and division expansions ****)
-
-Meta Definition InitExp FT trm :=
-  Let e =
-    (Match Eval Cbv Beta Delta [Aminus] Iota in (Aminus FT) With
-     | [(Field_Some ? ?1)] -> Eval Cbv Beta Delta [?1] in trm
-     | _ -> trm) In
-  Match Eval Cbv Beta Delta [Adiv] Iota in (Adiv FT) With
-  | [(Field_Some ? ?1)] -> Eval Cbv Beta Delta [?1] in e
-  | _ -> e.
-V7only [
-(*Used by contrib Maple *)
-Tactic Definition init_exp := InitExp.
-].
-
-(**** Inverses simplification ****)
-
-Recursive Meta Definition SimplInv trm:=
-  Match trm With
-  | [(EAplus ?1 ?2)] ->
-    Let e1 = (SimplInv ?1)
-    And e2 = (SimplInv ?2) In
-    '(EAplus e1 e2)
-  | [(EAmult ?1 ?2)] ->
-    Let e1 = (SimplInv ?1)
-    And e2 = (SimplInv ?2) In
-    '(EAmult e1 e2)
-  | [(EAopp ?1)] -> Let e = (SimplInv ?1) In '(EAopp e)
-  | [(EAinv ?1)] -> (SimplInvAux ?1)
-  | [?1] -> ?1
-And SimplInvAux trm :=
-  Match trm With
-  | [(EAinv ?1)] -> (SimplInv ?1)
-  | [(EAmult ?1 ?2)] ->
-    Let e1 = (SimplInv '(EAinv ?1))
-    And e2 = (SimplInv '(EAinv ?2)) In
-    '(EAmult e1 e2)
-  | [?1] -> Let e = (SimplInv ?1) In '(EAinv e).
-
-(**** Monom simplification ****)
-
-Recursive Meta Definition Map fcn lst :=
-  Match lst With
-  | [(nilT ?)] -> lst
-  | [(consT ?1 ?2 ?3)] ->
-    Let r = (fcn ?2)
-    And t = (Map fcn ?3) In
-    '(consT ?1 r t).
-
-Recursive Meta Definition BuildMonomAux lst trm :=
-  Match lst With
-  | [(nilT ?)] -> Eval Compute in (assoc trm)
-  | [(consT ? ?1 ?2)] -> BuildMonomAux ?2 '(EAmult trm ?1).
-
-Recursive Meta Definition BuildMonom lnum lden :=
-  Let ildn = (Map (Fun e -> '(EAinv e)) lden) In
-  Let ltot = Eval Compute in (appT ExprA lnum ildn) In
-  Let trm = (BuildMonomAux ltot EAone) In
-  Match trm With
-  | [(EAmult ? ?1)] -> ?1
-  | [?1] -> ?1.
-
-Recursive Meta Definition SimplMonomAux lnum lden trm :=
-  Match trm With
-  | [(EAmult (EAinv ?1) ?2)] ->
-    Let mma = (MemAssoc ?1 lnum) In
-    (Match mma With
-     | [true] ->
-       Let newlnum = (Remove ?1 lnum) In SimplMonomAux newlnum lden ?2
-     | [false] -> SimplMonomAux lnum '(consT ExprA ?1 lden) ?2)
-  | [(EAmult ?1 ?2)] ->
-    Let mma = (MemAssoc ?1 lden) In
-    (Match mma With
-     | [true] ->
-       Let newlden = (Remove ?1 lden) In SimplMonomAux lnum newlden ?2
-     | [false] -> SimplMonomAux '(consT ExprA ?1 lnum) lden ?2)
-  | [(EAinv ?1)] ->
-    Let mma = (MemAssoc ?1 lnum) In
-    (Match mma With
-     | [true] ->
-       Let newlnum = (Remove ?1 lnum) In BuildMonom newlnum lden
-     | [false] -> BuildMonom lnum '(consT ExprA ?1 lden))
-  | [?1] ->
-    Let mma = (MemAssoc ?1 lden) In
-    (Match mma With
-     | [true] ->
-       Let newlden = (Remove ?1 lden) In BuildMonom lnum newlden
-     | [false] -> BuildMonom '(consT ExprA ?1 lnum) lden).
-
-Meta Definition SimplMonom trm :=
-  SimplMonomAux '(nilT ExprA) '(nilT ExprA) trm.
-
-Recursive Meta Definition SimplAllMonoms trm :=
-  Match trm With
-  | [(EAplus ?1 ?2)] ->
-    Let e1 = (SimplMonom ?1)
-    And e2 = (SimplAllMonoms ?2) In
-    '(EAplus e1 e2)
-  | [?1] -> SimplMonom ?1.
-
-(**** Associativity and distribution ****)
-
-Meta Definition AssocDistrib trm := Eval Compute in (assoc (distrib trm)).
-
-(**** The tactic Field_Term ****)
-
-Tactic Definition EvalWeakReduce trm :=
-  Eval Cbv Beta Delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero
-                       Aone Aplus Amult Aopp Ainv] Zeta Iota in trm.
-
-Tactic Definition Field_Term FT exp :=
-  Let newexp = (InitExp FT exp) In
-  Let lvar = (BuildVarList FT newexp) In
-  Let trm = (interp_A FT lvar newexp) In
-  Let tma = Eval Compute in (assoc trm) In
-  Let tsmp = (SimplAllMonoms (AssocDistrib (SimplAllMonoms
-                (SimplInv tma)))) In
-  Let trep = (EvalWeakReduce '(interp_ExprA FT lvar tsmp)) In
-  Replace exp with trep;[Ring trep|Field_Gen FT].
diff --git a/contrib7/field/Field_Theory.v b/contrib7/field/Field_Theory.v
deleted file mode 100644
index 3ba2fbc0..00000000
--- a/contrib7/field/Field_Theory.v
+++ /dev/null
@@ -1,612 +0,0 @@
-(************************************************************************)
-(*  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: Field_Theory.v,v 1.2.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
-
-Require Peano_dec.
-Require Ring.
-Require Field_Compl.
-
-Record Field_Theory : Type :=
-{ A : Type;
-  Aplus : A -> A -> A;
-  Amult : A -> A -> A;
-  Aone : A;
-  Azero : A;
-  Aopp : A -> A;
-  Aeq : A -> A -> bool;
-  Ainv : A -> A;
-  Aminus : (field_rel_option A);
-  Adiv : (field_rel_option A);
-  RT : (Ring_Theory Aplus Amult Aone Azero Aopp Aeq);
-  Th_inv_def : (n:A)~(n=Azero)->(Amult (Ainv n) n)=Aone
-}.
-
-(* The reflexion structure *)
-Inductive ExprA : Set :=
-| EAzero    : ExprA
-| EAone    : ExprA
-| EAplus : ExprA -> ExprA -> ExprA
-| EAmult : ExprA -> ExprA -> ExprA
-| EAopp  : ExprA -> ExprA
-| EAinv  : ExprA -> ExprA
-| EAvar  : nat -> ExprA.
-
-(**** Decidability of equality ****)
-
-Lemma eqExprA_O:(e1,e2:ExprA){e1=e2}+{~e1=e2}.
-Proof.
-  Double Induction e1 e2;Try Intros;
-   Try (Left;Reflexivity) Orelse Try (Right;Discriminate).
-  Elim (H1 e0);Intro y;Elim (H2 e);Intro y0;
-    Try (Left; Rewrite y; Rewrite y0;Auto)
-    Orelse (Right;Red;Intro;Inversion H3;Auto).
-  Elim (H1 e0);Intro y;Elim (H2 e);Intro y0;
-    Try (Left; Rewrite y; Rewrite y0;Auto)
-    Orelse (Right;Red;Intro;Inversion H3;Auto).
-  Elim (H0 e);Intro y.
-  Left; Rewrite y; Auto.
-  Right;Red; Intro;Inversion H1;Auto.
-  Elim (H0 e);Intro y.
-  Left; Rewrite y; Auto.
-  Right;Red; Intro;Inversion H1;Auto.
-  Elim (eq_nat_dec n n0);Intro y.
-  Left; Rewrite y; Auto.
-  Right;Red;Intro;Inversion H;Auto. 
-Defined.
-
-Definition eq_nat_dec := Eval Compute in Peano_dec.eq_nat_dec.
-Definition eqExprA := Eval Compute in eqExprA_O.
-
-(**** Generation of the multiplier ****)
-
-Fixpoint mult_of_list [e:(listT ExprA)]: ExprA :=
-  Cases e of
-  | nilT => EAone
-  | (consT e1 l1) => (EAmult e1 (mult_of_list l1))
-  end.
-
-Section Theory_of_fields.
-
-Variable T : Field_Theory.
-
-Local AT := (A T).
-Local AplusT := (Aplus T).
-Local AmultT := (Amult T).
-Local AoneT := (Aone T).
-Local AzeroT := (Azero T).
-Local AoppT := (Aopp T).
-Local AeqT := (Aeq T).
-Local AinvT := (Ainv T).
-Local RTT := (RT T).
-Local Th_inv_defT := (Th_inv_def T).
-
-Add Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (Azero T) (Aopp T) 
-  (Aeq T) (RT T).
-
-Add Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
-
-(***************************)
-(*    Lemmas to be used    *)
-(***************************)
-
-Lemma AplusT_sym:(r1,r2:AT)(AplusT r1 r2)=(AplusT r2 r1).
-Proof.
-  Intros;Ring.
-Save.
-
-Lemma AplusT_assoc:(r1,r2,r3:AT)(AplusT (AplusT r1 r2) r3)=
-                                (AplusT r1 (AplusT r2 r3)).
-Proof.
-  Intros;Ring.
-Save.
-
-Lemma AmultT_sym:(r1,r2:AT)(AmultT r1 r2)=(AmultT r2 r1).
-Proof.
-  Intros;Ring.
-Save.
-
-Lemma AmultT_assoc:(r1,r2,r3:AT)(AmultT (AmultT r1 r2) r3)=
-                                (AmultT r1 (AmultT r2 r3)).
-Proof.
-  Intros;Ring.
-Save.
-
-Lemma AplusT_Ol:(r:AT)(AplusT AzeroT r)=r.
-Proof.
-  Intros;Ring.
-Save.
-
-Lemma AmultT_1l:(r:AT)(AmultT AoneT r)=r.
-Proof.
-  Intros;Ring.
-Save.
-
-Lemma AplusT_AoppT_r:(r:AT)(AplusT r (AoppT r))=AzeroT.
-Proof.
-  Intros;Ring.
-Save.
-
-Lemma AmultT_AplusT_distr:(r1,r2,r3:AT)(AmultT r1 (AplusT r2 r3))=
-                        (AplusT (AmultT r1 r2) (AmultT r1 r3)).
-Proof.
-  Intros;Ring.
-Save.
-
-Lemma r_AplusT_plus:(r,r1,r2:AT)(AplusT r r1)=(AplusT r r2)->r1=r2.
-Proof.
-  Intros; Transitivity (AplusT (AplusT (AoppT r) r) r1).
-  Ring.
-  Transitivity (AplusT (AplusT (AoppT r) r) r2).
-  Repeat Rewrite -> AplusT_assoc; Rewrite <- H; Reflexivity.
-  Ring.
-Save.
- 
-Lemma r_AmultT_mult:
-  (r,r1,r2:AT)(AmultT r r1)=(AmultT r r2)->~r=AzeroT->r1=r2.
-Proof.
-  Intros; Transitivity (AmultT (AmultT (AinvT r) r) r1).
-  Rewrite Th_inv_defT;[Symmetry; Apply AmultT_1l;Auto|Auto].
-  Transitivity (AmultT (AmultT (AinvT r) r) r2).
-  Repeat Rewrite AmultT_assoc; Rewrite H; Trivial.
-  Rewrite Th_inv_defT;[Apply AmultT_1l;Auto|Auto].
-Save.
-
-Lemma AmultT_Or:(r:AT) (AmultT r AzeroT)=AzeroT.
-Proof.
-  Intro; Ring.
-Save.
- 
-Lemma AmultT_Ol:(r:AT)(AmultT AzeroT r)=AzeroT.
-Proof.
-  Intro; Ring.
-Save.
- 
-Lemma AmultT_1r:(r:AT)(AmultT r AoneT)=r.
-Proof.
-  Intro; Ring.
-Save.
- 
-Lemma AinvT_r:(r:AT)~r=AzeroT->(AmultT r (AinvT r))=AoneT.
-Proof.
-  Intros; Rewrite -> AmultT_sym; Apply Th_inv_defT; Auto.
-Save.
- 
-Lemma without_div_O_contr:
-  (r1,r2:AT)~(AmultT r1 r2)=AzeroT ->~r1=AzeroT/\~r2=AzeroT.
-Proof.
-  Intros r1 r2 H; Split; Red; Intro; Apply H; Rewrite H0; Ring.
-Save.
-
-(************************)
-(*    Interpretation    *)
-(************************)
-
-(**** ExprA --> A ****)
-
-Fixpoint interp_ExprA [lvar:(listT (prodT AT nat));e:ExprA] : AT :=
-  Cases e of
-  | EAzero         => AzeroT
-  | EAone          => AoneT
-  | (EAplus e1 e2) => (AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2))
-  | (EAmult e1 e2) => (AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2))
-  | (EAopp e)      => ((Aopp T) (interp_ExprA lvar e))
-  | (EAinv e)      => ((Ainv T) (interp_ExprA lvar e))
-  | (EAvar n)      => (assoc_2nd AT nat eq_nat_dec lvar n AzeroT)
-  end.
-
-(************************)
-(*    Simplification    *)
-(************************)
-
-(**** Associativity ****)
-
-Definition merge_mult :=
-  Fix merge_mult {merge_mult [e1:ExprA] : ExprA -> ExprA :=
-  [e2:ExprA]Cases e1 of
-  | (EAmult t1 t2) =>
-    Cases t2 of
-    | (EAmult t2 t3) => (EAmult t1 (EAmult t2 (merge_mult t3 e2)))
-    | _ => (EAmult t1 (EAmult t2 e2))
-    end
-  | _ => (EAmult e1 e2)
-  end}.
-
-Fixpoint assoc_mult [e:ExprA] : ExprA :=
-  Cases e of
-  | (EAmult e1 e3) =>
-    Cases e1 of
-    | (EAmult e1 e2) =>
-      (merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2))
-        (assoc_mult e3))
-    | _ => (EAmult e1 (assoc_mult e3))
-    end
-  | _ => e
-  end.
-
-Definition merge_plus :=
-  Fix merge_plus {merge_plus [e1:ExprA]:ExprA->ExprA:=
-  [e2:ExprA]Cases e1 of
-  | (EAplus t1 t2) =>
-    Cases t2 of
-    | (EAplus t2 t3) => (EAplus t1 (EAplus t2 (merge_plus t3 e2)))
-    | _ => (EAplus t1 (EAplus t2 e2))
-    end
-  | _ => (EAplus e1 e2)
-  end}.
-
-Fixpoint assoc [e:ExprA] : ExprA :=
-  Cases e of
-  | (EAplus e1 e3) =>
-    Cases e1 of
-    | (EAplus e1 e2) =>
-      (merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3))
-    | _ => (EAplus (assoc_mult e1) (assoc e3))
-    end
-  | _ => (assoc_mult e)
-  end.
-
-Lemma merge_mult_correct1:
-  (e1,e2,e3:ExprA)(lvar:(listT (prodT AT nat)))
-  (interp_ExprA lvar (merge_mult (EAmult e1 e2) e3))=
-  (interp_ExprA lvar (EAmult e1 (merge_mult e2 e3))).
-Proof.
-Intros e1 e2;Generalize e1;Generalize e2;Clear e1 e2.
-Induction e2;Auto;Intros.
-Unfold 1 merge_mult;Fold merge_mult;
- Unfold 2 interp_ExprA;Fold interp_ExprA;
- Rewrite (H0 e e3 lvar);
- Unfold 1 interp_ExprA;Fold interp_ExprA;
- Unfold 5 interp_ExprA;Fold interp_ExprA;Auto.
-Save.
-
-Lemma merge_mult_correct:
-  (e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
-    (interp_ExprA lvar (merge_mult e1 e2))=
-    (interp_ExprA lvar (EAmult e1 e2)).
-Proof.
-Induction e1;Auto;Intros.
-Elim e0;Try (Intros;Simpl;Ring).
-Unfold interp_ExprA in H2;Fold interp_ExprA in H2;
- Cut (AmultT (interp_ExprA lvar e2) (AmultT (interp_ExprA lvar e4) 
-       (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))))=
-       (AmultT (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4)) 
-       (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
-Intro H3;Rewrite H3;Rewrite <-H2;
- Rewrite merge_mult_correct1;Simpl;Ring.
-Ring.
-Save.
-
-Lemma assoc_mult_correct1:(e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
-  (AmultT (interp_ExprA lvar (assoc_mult e1)) 
-         (interp_ExprA lvar (assoc_mult e2)))=
-  (interp_ExprA lvar (assoc_mult (EAmult e1 e2))).
-Proof.
-Induction e1;Auto;Intros.
-Rewrite <-(H e0 lvar);Simpl;Rewrite merge_mult_correct;Simpl;
- Rewrite merge_mult_correct;Simpl;Auto.
-Save.
-
-Lemma assoc_mult_correct:
-  (e:ExprA)(lvar:(listT (prodT AT nat)))
-    (interp_ExprA lvar (assoc_mult e))=(interp_ExprA lvar e).
-Proof.
-Induction e;Auto;Intros.
-Elim e0;Intros.
-Intros;Simpl;Ring.
-Simpl;Rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
- Rewrite (AmultT_1l (interp_ExprA lvar e1)); Apply H0.
-Simpl;Rewrite (H0 lvar);Auto.
-Simpl;Rewrite merge_mult_correct;Simpl;Rewrite merge_mult_correct;Simpl;
- Rewrite AmultT_assoc;Rewrite assoc_mult_correct1;Rewrite H2;Simpl;
- Rewrite <-assoc_mult_correct1 in H1;
- Unfold 3 interp_ExprA in H1;Fold interp_ExprA in H1;
- Rewrite (H0 lvar) in H1;
- Rewrite (AmultT_sym (interp_ExprA lvar e3) (interp_ExprA lvar e1));
- Rewrite <-AmultT_assoc;Rewrite H1;Rewrite AmultT_assoc;Ring.
-Simpl;Rewrite (H0 lvar);Auto.
-Simpl;Rewrite (H0 lvar);Auto.
-Simpl;Rewrite (H0 lvar);Auto.
-Save.
-
-Lemma merge_plus_correct1:
-  (e1,e2,e3:ExprA)(lvar:(listT (prodT AT nat)))
-  (interp_ExprA lvar (merge_plus (EAplus e1 e2) e3))=
-  (interp_ExprA lvar (EAplus e1 (merge_plus e2 e3))).
-Proof.
-Intros e1 e2;Generalize e1;Generalize e2;Clear e1 e2.
-Induction e2;Auto;Intros.
-Unfold 1 merge_plus;Fold merge_plus;
- Unfold 2 interp_ExprA;Fold interp_ExprA;
- Rewrite (H0 e e3 lvar);
- Unfold 1 interp_ExprA;Fold interp_ExprA;
- Unfold 5 interp_ExprA;Fold interp_ExprA;Auto.
-Save.
-
-Lemma merge_plus_correct:
-  (e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
-    (interp_ExprA lvar (merge_plus e1 e2))=
-    (interp_ExprA lvar (EAplus e1 e2)).
-Proof.
-Induction e1;Auto;Intros.
-Elim e0;Try Intros;Try (Simpl;Ring).
-Unfold interp_ExprA in H2;Fold interp_ExprA in H2;
-  Cut (AplusT (interp_ExprA lvar e2) (AplusT (interp_ExprA lvar e4) 
-        (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))))=
-        (AplusT (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4)) 
-       (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
-Intro H3;Rewrite H3;Rewrite <-H2;Rewrite merge_plus_correct1;Simpl;Ring.
-Ring.
-Save.
-
-Lemma assoc_plus_correct:(e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
-  (AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))=
-  (interp_ExprA lvar (assoc (EAplus e1 e2))).
-Proof.
-Induction e1;Auto;Intros.
-Rewrite <-(H e0 lvar);Simpl;Rewrite merge_plus_correct;Simpl;
- Rewrite merge_plus_correct;Simpl;Auto.
-Save.
-
-Lemma assoc_correct:
-  (e:ExprA)(lvar:(listT (prodT AT nat)))
-    (interp_ExprA lvar (assoc e))=(interp_ExprA lvar e).
-Proof.
-Induction e;Auto;Intros.
-Elim e0;Intros.
-Simpl;Rewrite (H0 lvar);Auto.
-Simpl;Rewrite (H0 lvar);Auto.
-Simpl;Rewrite merge_plus_correct;Simpl;Rewrite merge_plus_correct;
- Simpl;Rewrite AplusT_assoc;Rewrite assoc_plus_correct;Rewrite H2;
- Simpl;Apply (r_AplusT_plus (interp_ExprA lvar (assoc e1))
-   (AplusT (interp_ExprA lvar (assoc e2))
-     (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1)))
-   (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
-        (interp_ExprA lvar e1)));Rewrite <-AplusT_assoc; 
- Rewrite (AplusT_sym (interp_ExprA lvar (assoc e1)) 
-                    (interp_ExprA lvar (assoc e2)));
- Rewrite assoc_plus_correct;Rewrite H1;Simpl;Rewrite (H0 lvar);
- Rewrite <-(AplusT_assoc (AplusT (interp_ExprA lvar e2) 
-            (interp_ExprA lvar e1))
- (interp_ExprA lvar e3) (interp_ExprA lvar e1));
- Rewrite (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
-                      (interp_ExprA lvar e3));
- Rewrite (AplusT_sym (interp_ExprA lvar e1) (interp_ExprA lvar e3));
- Rewrite <-(AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
-                        (interp_ExprA lvar e1));Apply AplusT_sym.
-Unfold assoc;Fold assoc;Unfold interp_ExprA;Fold interp_ExprA;
- Rewrite assoc_mult_correct;Rewrite (H0 lvar);Simpl;Auto.
-Simpl;Rewrite (H0 lvar);Auto.
-Simpl;Rewrite (H0 lvar);Auto.
-Simpl;Rewrite (H0 lvar);Auto.
-Unfold assoc;Fold assoc;Unfold interp_ExprA;Fold interp_ExprA;
- Rewrite assoc_mult_correct;Simpl;Auto.
-Save.
-
-(**** Distribution *****)
-
-Fixpoint distrib_EAopp [e:ExprA] : ExprA :=
-  Cases e of
-  | (EAplus e1 e2) => (EAplus (distrib_EAopp e1) (distrib_EAopp e2))
-  | (EAmult e1 e2) => (EAmult (distrib_EAopp e1) (distrib_EAopp e2))
-  | (EAopp e) => (EAmult (EAopp EAone) (distrib_EAopp e))
-  | e => e
-  end.
-
-Definition distrib_mult_right :=
-  Fix distrib_mult_right {distrib_mult_right [e1:ExprA]:ExprA->ExprA:=
-  [e2:ExprA]Cases e1 of
-  | (EAplus t1 t2) =>
-    (EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2))
-  | _ => (EAmult e1 e2)
-  end}.
-
-Fixpoint distrib_mult_left [e1:ExprA] : ExprA->ExprA :=
-  [e2:ExprA]
-  Cases e1 of
-  | (EAplus t1 t2) =>
-    (EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2))
-  | _ => (distrib_mult_right e2 e1)
-  end.
-
-Fixpoint distrib_main [e:ExprA] : ExprA :=
-  Cases e of
-  | (EAmult e1 e2) => (distrib_mult_left (distrib_main e1) (distrib_main e2))
-  | (EAplus e1 e2) => (EAplus (distrib_main e1) (distrib_main e2))
-  | (EAopp e) => (EAopp (distrib_main e))
-  | _ => e
-  end.
-
-Definition distrib [e:ExprA] : ExprA := (distrib_main (distrib_EAopp e)).
-
-Lemma distrib_mult_right_correct:
-  (e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
-     (interp_ExprA lvar (distrib_mult_right e1 e2))=
-     (AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2)).
-Proof.
-Induction e1;Try Intros;Simpl;Auto.
-Rewrite AmultT_sym;Rewrite AmultT_AplusT_distr;
- Rewrite (H e2 lvar);Rewrite (H0 e2 lvar);Ring.
-Save.
-
-Lemma distrib_mult_left_correct:
-  (e1,e2:ExprA)(lvar:(listT (prodT AT nat)))
-     (interp_ExprA lvar (distrib_mult_left e1 e2))=
-     (AmultT (interp_ExprA lvar e1)  (interp_ExprA lvar e2)).
-Proof.
-Induction e1;Try Intros;Simpl.
-Rewrite AmultT_Ol;Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_Or.
-Rewrite distrib_mult_right_correct;Simpl;
- Apply AmultT_sym. 
-Rewrite AmultT_sym;
- Rewrite (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
-  (interp_ExprA lvar e0)); 
- Rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e));
- Rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e0));
- Rewrite (H e2 lvar);Rewrite (H0 e2 lvar);Auto.
-Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_sym.
-Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_sym.
-Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_sym.
-Rewrite distrib_mult_right_correct;Simpl;Apply AmultT_sym.
-Save.
-
-Lemma distrib_correct:
-  (e:ExprA)(lvar:(listT (prodT AT nat)))
-    (interp_ExprA lvar (distrib e))=(interp_ExprA lvar e).
-Proof.
-Induction e;Intros;Auto.
-Simpl;Rewrite <- (H lvar);Rewrite <- (H0 lvar); Unfold distrib;Simpl;Auto.
-Simpl;Rewrite <- (H lvar);Rewrite <- (H0 lvar); Unfold distrib;Simpl;
- Apply distrib_mult_left_correct.
-Simpl;Fold AoppT;Rewrite <- (H lvar);Unfold distrib;Simpl; 
- Rewrite distrib_mult_right_correct;
- Simpl;Fold AoppT;Ring.
-Save.
-
-(**** Multiplication by the inverse product ****)
-
-Lemma mult_eq:
-  (e1,e2,a:ExprA)(lvar:(listT (prodT AT nat)))
-    ~((interp_ExprA lvar a)=AzeroT)->
-      (interp_ExprA lvar (EAmult a e1))=(interp_ExprA lvar (EAmult a e2))->
-        (interp_ExprA lvar e1)=(interp_ExprA lvar e2).
-Proof.
-  Simpl;Intros;
-    Apply (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
-      (interp_ExprA lvar e2));Assumption.
-Save.
-
-Fixpoint multiply_aux [a,e:ExprA] : ExprA :=
-  Cases e of
-  | (EAplus e1 e2) =>
-    (EAplus (EAmult a e1) (multiply_aux a e2))
-  | _ => (EAmult a e)
-  end.
-
-Definition multiply [e:ExprA] : ExprA :=
-  Cases e of
-  | (EAmult a e1) => (multiply_aux a e1)
-  | _ => e
-  end.
-
-Lemma multiply_aux_correct:
-  (a,e:ExprA)(lvar:(listT (prodT AT nat)))
-    (interp_ExprA lvar (multiply_aux a e))=
-    (AmultT (interp_ExprA lvar a) (interp_ExprA lvar e)).
-Proof.
-Induction e;Simpl;Intros;Try (Rewrite merge_mult_correct);Auto.
-  Simpl;Rewrite (H0 lvar);Ring.
-Save.
-
-Lemma multiply_correct:
-  (e:ExprA)(lvar:(listT (prodT AT nat)))
-    (interp_ExprA lvar (multiply e))=(interp_ExprA lvar e).
-Proof.
-  Induction e;Simpl;Auto.
-  Intros;Apply multiply_aux_correct.
-Save.
-
-(**** Permutations and simplification ****)
-
-Fixpoint monom_remove [a,m:ExprA] : ExprA :=
-  Cases m of
-  | (EAmult m0 m1) =>
-    (Cases (eqExprA m0 (EAinv a)) of
-     | (left _) => m1
-     | (right _) => (EAmult m0 (monom_remove a m1))
-     end)
-  | _ =>
-    (Cases (eqExprA m (EAinv a)) of
-     | (left _) => EAone
-     | (right _) => (EAmult a m)
-     end)
-  end.
-
-Definition monom_simplif_rem := 
-  Fix monom_simplif_rem {monom_simplif_rem/1:ExprA->ExprA->ExprA:=
-  [a,m:ExprA] 
-  Cases a of
-  | (EAmult a0 a1) => (monom_simplif_rem a1 (monom_remove a0 m))
-  | _ => (monom_remove a m)
-  end}.
-
-Definition monom_simplif [a,m:ExprA] : ExprA :=
-  Cases m of
-  | (EAmult a' m') =>
-    (Cases (eqExprA a a') of
-     | (left _) => (monom_simplif_rem a m')
-     | (right _) => m
-     end)
-  | _ => m
-  end.
-
-Fixpoint inverse_simplif [a,e:ExprA] : ExprA :=
-  Cases e of
-  | (EAplus e1 e2) => (EAplus (monom_simplif a e1) (inverse_simplif a e2))
-  | _ => (monom_simplif a e)
-  end.
-
-Lemma monom_remove_correct:(e,a:ExprA)
-  (lvar:(listT (prodT AT nat)))~((interp_ExprA lvar a)=AzeroT)->
-  (interp_ExprA lvar (monom_remove a e))=
-  (AmultT (interp_ExprA lvar a) (interp_ExprA lvar e)).
-Proof.
-Induction e; Intros.
-Simpl;Case (eqExprA EAzero (EAinv a));Intros;[Inversion e0|Simpl;Trivial].
-Simpl;Case (eqExprA EAone (EAinv a));Intros;[Inversion e0|Simpl;Trivial].
-Simpl;Case (eqExprA (EAplus e0 e1) (EAinv a));Intros;[Inversion e2|
- Simpl;Trivial].
-Simpl;Case (eqExprA e0 (EAinv a));Intros.
-Rewrite e2;Simpl;Fold AinvT.
-Rewrite <-(AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
-             (interp_ExprA lvar e1));
-  Rewrite AinvT_r;[Ring|Assumption].
-Simpl;Rewrite H0;Auto; Ring.
-Simpl;Fold AoppT;Case (eqExprA (EAopp e0) (EAinv a));Intros;[Inversion e1|
- Simpl;Trivial].
-Unfold monom_remove;Case (eqExprA (EAinv e0) (EAinv a));Intros.
-Case (eqExprA e0 a);Intros.
-Rewrite e2;Simpl;Fold AinvT;Rewrite AinvT_r;Auto.
-Inversion e1;Simpl;ElimType False;Auto.
-Simpl;Trivial.
-Unfold monom_remove;Case (eqExprA (EAvar n) (EAinv a));Intros;
- [Inversion e0|Simpl;Trivial].
-Save.
-
-Lemma monom_simplif_rem_correct:(a,e:ExprA)
-  (lvar:(listT (prodT AT nat)))~((interp_ExprA lvar a)=AzeroT)->
-  (interp_ExprA lvar (monom_simplif_rem a e))=
-  (AmultT (interp_ExprA lvar a) (interp_ExprA lvar e)).
-Proof.
-Induction a;Simpl;Intros; Try Rewrite monom_remove_correct;Auto.
-Elim (without_div_O_contr (interp_ExprA lvar e) 
-                          (interp_ExprA lvar e0) H1);Intros.
-Rewrite (H0 (monom_remove e e1) lvar H3);Rewrite monom_remove_correct;Auto.
-Ring.
-Save.
-
-Lemma monom_simplif_correct:(e,a:ExprA)
-  (lvar:(listT (prodT AT nat)))~((interp_ExprA lvar a)=AzeroT)->
-  (interp_ExprA lvar (monom_simplif a e))=(interp_ExprA lvar e).
-Proof.
-Induction e;Intros;Auto.
-Simpl;Case (eqExprA a e0);Intros.
-Rewrite <-e2;Apply monom_simplif_rem_correct;Auto. 
-Simpl;Trivial.
-Save.
-
-Lemma inverse_correct:
-  (e,a:ExprA)(lvar:(listT (prodT AT nat)))~((interp_ExprA lvar a)=AzeroT)->
-    (interp_ExprA lvar (inverse_simplif a e))=(interp_ExprA lvar e).
-Proof.
-Induction e;Intros;Auto.
-Simpl;Rewrite (H0 a lvar H1); Rewrite monom_simplif_correct ; Auto.
-Unfold inverse_simplif;Rewrite monom_simplif_correct ; Auto.
-Save.
-
-End Theory_of_fields.
diff --git a/contrib7/fourier/Fourier_util.v b/contrib7/fourier/Fourier_util.v
deleted file mode 100644
index be22e2ff..00000000
--- a/contrib7/fourier/Fourier_util.v
+++ /dev/null
@@ -1,236 +0,0 @@
-(************************************************************************)
-(*  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: Fourier_util.v,v 1.2.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
-
-Require Export Rbase.
-Comments "Lemmas used by the tactic Fourier".
-
-Open Scope R_scope.
- 
-Lemma Rfourier_lt:
- (x1, y1, a : R) (Rlt x1 y1) -> (Rlt R0 a) ->  (Rlt (Rmult a x1) (Rmult a y1)).
-Intros; Apply Rlt_monotony; Assumption.
-Qed.
- 
-Lemma Rfourier_le:
- (x1, y1, a : R) (Rle x1 y1) -> (Rlt R0 a) ->  (Rle (Rmult a x1) (Rmult a y1)).
-Red.
-Intros.
-Case H; Auto with real.
-Qed.
- 
-Lemma Rfourier_lt_lt:
- (x1, y1, x2, y2, a : R)
- (Rlt x1 y1) ->
- (Rlt x2 y2) ->
- (Rlt R0 a) ->  (Rlt (Rplus x1 (Rmult a x2)) (Rplus y1 (Rmult a y2))).
-Intros x1 y1 x2 y2 a H H0 H1; Try Assumption.
-Apply Rplus_lt.
-Try Exact H.
-Apply Rfourier_lt.
-Try Exact H0.
-Try Exact H1.
-Qed.
- 
-Lemma Rfourier_lt_le:
- (x1, y1, x2, y2, a : R)
- (Rlt x1 y1) ->
- (Rle x2 y2) ->
- (Rlt R0 a) ->  (Rlt (Rplus x1 (Rmult a x2)) (Rplus y1 (Rmult a y2))).
-Intros x1 y1 x2 y2 a H H0 H1; Try Assumption.
-Case H0; Intros.
-Apply Rplus_lt.
-Try Exact H.
-Apply Rfourier_lt; Auto with real.
-Rewrite H2.
-Rewrite (Rplus_sym y1 (Rmult a y2)).
-Rewrite (Rplus_sym x1 (Rmult a y2)).
-Apply Rlt_compatibility.
-Try Exact H.
-Qed.
- 
-Lemma Rfourier_le_lt:
- (x1, y1, x2, y2, a : R)
- (Rle x1 y1) ->
- (Rlt x2 y2) ->
- (Rlt R0 a) ->  (Rlt (Rplus x1 (Rmult a x2)) (Rplus y1 (Rmult a y2))).
-Intros x1 y1 x2 y2 a H H0 H1; Try Assumption.
-Case H; Intros.
-Apply Rfourier_lt_le; Auto with real.
-Rewrite H2.
-Apply Rlt_compatibility.
-Apply Rfourier_lt; Auto with real.
-Qed.
- 
-Lemma Rfourier_le_le:
- (x1, y1, x2, y2, a : R)
- (Rle x1 y1) ->
- (Rle x2 y2) ->
- (Rlt R0 a) ->  (Rle (Rplus x1 (Rmult a x2)) (Rplus y1 (Rmult a y2))).
-Intros x1 y1 x2 y2 a H H0 H1; Try Assumption.
-Case H0; Intros.
-Red.
-Left; Try Assumption.
-Apply Rfourier_le_lt; Auto with real.
-Rewrite H2.
-Case H; Intros.
-Red.
-Left; Try Assumption.
-Rewrite (Rplus_sym x1 (Rmult a y2)).
-Rewrite (Rplus_sym y1 (Rmult a y2)).
-Apply Rlt_compatibility.
-Try Exact H3.
-Rewrite H3.
-Red.
-Right; Try Assumption.
-Auto with real.
-Qed.
- 
-Lemma Rlt_zero_pos_plus1: (x : R) (Rlt R0 x) ->  (Rlt R0 (Rplus R1 x)).
-Intros x H; Try Assumption.
-Rewrite Rplus_sym.
-Apply Rlt_r_plus_R1.
-Red; Auto with real.
-Qed.
- 
-Lemma Rlt_mult_inv_pos:
- (x, y : R) (Rlt R0 x) -> (Rlt R0 y) ->  (Rlt R0 (Rmult x (Rinv y))).
-Intros x y H H0; Try Assumption.
-Replace R0 with (Rmult x R0).
-Apply Rlt_monotony; Auto with real.
-Ring.
-Qed.
- 
-Lemma Rlt_zero_1: (Rlt R0 R1).
-Exact Rlt_R0_R1.
-Qed.
- 
-Lemma Rle_zero_pos_plus1: (x : R) (Rle R0 x) ->  (Rle R0 (Rplus R1 x)).
-Intros x H; Try Assumption.
-Case H; Intros.
-Red.
-Left; Try Assumption.
-Apply Rlt_zero_pos_plus1; Auto with real.
-Rewrite <- H0.
-Replace (Rplus R1 R0) with R1.
-Red; Left.
-Exact Rlt_zero_1.
-Ring.
-Qed.
- 
-Lemma Rle_mult_inv_pos:
- (x, y : R) (Rle R0 x) -> (Rlt R0 y) ->  (Rle R0 (Rmult x (Rinv y))).
-Intros x y H H0; Try Assumption.
-Case H; Intros.
-Red; Left.
-Apply Rlt_mult_inv_pos; Auto with real.
-Rewrite <- H1.
-Red; Right; Ring.
-Qed.
- 
-Lemma Rle_zero_1: (Rle R0 R1).
-Red; Left.
-Exact Rlt_zero_1.
-Qed.
- 
-Lemma Rle_not_lt:
- (n, d : R) (Rle R0 (Rmult n (Rinv d))) ->  ~ (Rlt R0 (Rmult (Ropp n) (Rinv d))).
-Intros n d H; Red; Intros H0; Try Exact H0.
-Generalize (Rle_not R0 (Rmult n (Rinv d))).
-Intros H1; Elim H1; Try Assumption.
-Replace (Rmult n (Rinv d)) with (Ropp (Ropp (Rmult n (Rinv d)))).
-Replace R0 with (Ropp (Ropp R0)).
-Replace (Ropp (Rmult n (Rinv d))) with (Rmult (Ropp n) (Rinv d)).
-Replace (Ropp R0) with R0.
-Red.
-Apply Rgt_Ropp.
-Red.
-Exact H0.
-Ring.
-Ring.
-Ring.
-Ring.
-Qed.
- 
-Lemma Rnot_lt0: (x : R)  ~ (Rlt R0 (Rmult R0 x)).
-Intros x; Try Assumption.
-Replace (Rmult R0 x) with R0.
-Apply Rlt_antirefl.
-Ring.
-Qed.
- 
-Lemma Rlt_not_le:
- (n, d : R) (Rlt R0 (Rmult n (Rinv d))) ->  ~ (Rle R0 (Rmult (Ropp n) (Rinv d))).
-Intros n d H; Try Assumption.
-Apply Rle_not.
-Replace R0 with (Ropp R0).
-Replace (Rmult (Ropp n) (Rinv d)) with (Ropp (Rmult n (Rinv d))).
-Apply Rlt_Ropp.
-Try Exact H.
-Ring.
-Ring.
-Qed.
- 
-Lemma Rnot_lt_lt: (x, y : R) ~ (Rlt R0 (Rminus y x)) ->  ~ (Rlt x y).
-Unfold not; Intros.
-Apply H.
-Apply Rlt_anti_compatibility with x.
-Replace (Rplus x R0) with x.
-Replace (Rplus x (Rminus y x)) with y.
-Try Exact H0.
-Ring.
-Ring.
-Qed.
- 
-Lemma Rnot_le_le: (x, y : R) ~ (Rle R0 (Rminus y x)) ->  ~ (Rle x y).
-Unfold not; Intros.
-Apply H.
-Case H0; Intros.
-Left.
-Apply Rlt_anti_compatibility with x.
-Replace (Rplus x R0) with x.
-Replace (Rplus x (Rminus y x)) with y.
-Try Exact H1.
-Ring.
-Ring.
-Right.
-Rewrite H1; Ring.
-Qed.
- 
-Lemma Rfourier_gt_to_lt: (x, y : R) (Rgt y x) ->  (Rlt x y).
-Unfold Rgt; Intros; Assumption.
-Qed.
- 
-Lemma Rfourier_ge_to_le: (x, y : R) (Rge y x) ->  (Rle x y).
-Intros x y; Exact (Rge_le y x).
-Qed.
- 
-Lemma Rfourier_eqLR_to_le: (x, y : R) x == y ->  (Rle x y).
-Exact eq_Rle.
-Qed.
- 
-Lemma Rfourier_eqRL_to_le: (x, y : R) y == x ->  (Rle x y).
-Exact eq_Rle_sym.
-Qed.
- 
-Lemma Rfourier_not_ge_lt: (x, y : R) ((Rge x y) ->  False) ->  (Rlt x y).
-Exact not_Rge.
-Qed.
- 
-Lemma Rfourier_not_gt_le: (x, y : R) ((Rgt x y) ->  False) ->  (Rle x y).
-Exact Rgt_not_le.
-Qed.
- 
-Lemma Rfourier_not_le_gt: (x, y : R) ((Rle x y) ->  False) ->  (Rgt x y).
-Exact not_Rle.
-Qed.
- 
-Lemma Rfourier_not_lt_ge: (x, y : R) ((Rlt x y) ->  False) ->  (Rge x y).
-Exact Rlt_not_ge.
-Qed.
diff --git a/contrib7/interface/AddDad.v b/contrib7/interface/AddDad.v
deleted file mode 100644
index d22b7ed1..00000000
--- a/contrib7/interface/AddDad.v
+++ /dev/null
@@ -1,19 +0,0 @@
-Grammar vernac vernac : ast :=
- add_dad_rule00 ["AddDadRule" stringarg($name) constrarg($pat) 
-       "first_path" "second_path" tacarg($tac) "."] ->
-    [(AddDadRule $name $pat (NUMBERLIST) (NUMBERLIST) (TACTIC $tac))].
-Grammar vernac vernac:ast :=
-| add_dad_rule01 ["AddDadRule" stringarg($name) constrarg($pat)
-       "first_path" "second_path" ne_numarg_list($l) tacarg($tac) "."] ->
-    [(AddDadRule $name $pat (NUMBERLIST) (NUMBERLIST ($LIST $l)) (TACTIC $tac))]
-| add_dad_rule10 ["AddDadRule" stringarg($name) constrarg($pat)
-       "first_path" ne_numarg_list($l) "second_path" tacarg($tac) "."] ->
-    [(AddDadRule $name $pat (NUMBERLIST ($LIST $l))(NUMBERLIST) (TACTIC $tac))]
-| add_dad_rule11 ["AddDadRule" stringarg($name) constrarg($pat)
-       "first_path" ne_numarg_list($l) "second_path" ne_numarg_list($l1)
-       tacarg($tac) "."] ->
-    [(AddDadRule $name $pat (NUMBERLIST ($LIST $l))(NUMBERLIST ($LIST $l1))
-       (TACTIC $tac))].
-
-Grammar vernac vernac : ast :=
- start_dad [ "StartDad" "."] -> [(StartDad)].
diff --git a/contrib7/interface/Centaur.v b/contrib7/interface/Centaur.v
deleted file mode 100644
index d27929f8..00000000
--- a/contrib7/interface/Centaur.v
+++ /dev/null
@@ -1,88 +0,0 @@
-(*
-Declare ML Module "ctast".
-Declare ML Module "paths".
-Declare ML Module "name_to_ast".
-Declare ML Module "xlate".
-Declare ML Module "vtp".
-Declare ML Module "translate".
-Declare ML Module "pbp".
-Declare ML Module "blast".
-Declare ML Module "dad".
-Declare ML Module "showproof_ct".
-Declare ML Module "showproof".
-Declare ML Module "debug_tac".
-Declare ML Module "paths".
-Declare ML Module "history".
-Declare ML Module "centaur".
-(* Require Export Illustrations. *)
-(* Require Export AddDad. *)
-(*
-Grammar vernac vernac : ast :=
-  goal_cmd [ "Goal" "Cmd" numarg($n) "with" tacarg($tac) "." ] ->
-        [(GOAL_CMD $n (TACTIC $tac))]
-| kill_proof_after [ "Kill" "Proof" "after"  numarg($n)"." ] -> [(KILL_NODE $n)]
-| kill_proof_at [ "Kill" "Proof" "at"  numarg($n)"." ] -> [(KILL_NODE $n)]
-| kill_sub_proof [ "Kill" "SubProof" numarg($n) "." ] -> [(KILL_SUB_PROOF $n)]
-
-| print_past_goal [ "Print" "Past" "Goal" numarg($n) "." ] ->
-        [(PRINT_GOAL_AT $n) ]
-
-| check_in_goal [ "CHECK_IN_GOAL" numarg($n) constrarg($c) "." ] ->
-       [(CHECK_IN_GOAL "CHECK" $n $c)]
-| eval_in_goal [ "EVAL_IN_GOAL" numarg($n) constrarg($c) "." ] ->
-       [(CHECK_IN_GOAL "EVAL" $n $c)]
-| compute_in_goal [ "COMPUTE_IN_GOAL" numarg($n) constrarg($c) "." ] ->
-       [(CHECK_IN_GOAL "COMPUTE" $n $c)]
-| centaur_reset [ "Centaur" "Reset" identarg($id) "." ] -> [(Centaur_Reset $id)]
-(*| show_dad_rules [ "Show" "Dad" "Rules" "." ] -> [(Show_dad_rules)]*)
-| start_pcoq [ "Start" "Pcoq" "Mode" "." ] -> [ (START_PCOQ) ]
-| start_pcoq [ "Start" "Pcoq" "Debug" "Mode" "." ] -> [ (START_PCOQ_DEBUG) ].
-Grammar vernac ne_id_list : ast list :=
-   id_one [ identarg($id)] -> [$id]
- | id_more [identarg($id) ne_id_list($others)] -> [$id ($LIST $others)].
-
-Grammar tactic ne_num_list : ast list :=
-  ne_last [ numarg($n) ] -> [ $n ]
-| ne_num_ste  [ numarg($n) ne_num_list($ns) ] -> [ $n ($LIST $ns)].
-
-Grammar tactic two_numarg_list : ast list :=
-  two_single_and_ne [ numarg($n) "to"  ne_num_list($ns)] ->
-        [$n (TACTIC (to)) ($LIST $ns)]
-| two_rec [ numarg($n) two_numarg_list($ns)] -> [ $n ($LIST $ns)].
-
-Grammar tactic simple_tactic : ast :=
-  pbp0 [ "Pbp" ] -> [(PcoqPbp)]
-| pbp1 [ "Pbp" ne_num_list($ns) ] ->
-         [ (PcoqPbp ($LIST $ns)) ]
-| pbp2 [ "Pbp" identarg($id) ] -> [ (PcoqPbp $id) ]
-| pbp3 [ "Pbp" identarg($id) ne_num_list($ns)] ->
-         [ (PcoqPbp $id ($LIST $ns)) ]
-| blast1 [ "Blast" ne_num_list($ns) ] ->
-         [ (PcoqBlast ($LIST $ns)) ]
-| dad00 [ "Dad" "to" ] -> [(Dad (TACTIC (to)))]
-| dad01 [ "Dad" "to" ne_num_list($ns) ] ->
-        [(Dad (TACTIC (to)) ($LIST $ns))]
-| dadnn [ "Dad" two_numarg_list($ns) ] -> [ (Dad ($LIST $ns)) ]
-| debug_tac [ "DebugTac" tactic($tac) ] ->
-  [(CtDebugTac (TACTIC $tac))]
-| on_then_empty [ "OnThen" tactic($tac1) tactic($tac2) ] ->
-    [(OnThen (TACTIC $tac1) (TACTIC $tac2))]
-| on_then_ne [ "OnThen" tactic($tac1) tactic($tac2) ne_num_list($l) ] ->
-  [(OnThen (TACTIC $tac1) (TACTIC $tac2) ($LIST $l))]
-| debug_tac2 [ "DebugTac2" tactic($tac) ] ->
-  [(CtDebugTac2 (TACTIC $tac))].
-
-
-(* Maybe we should have syntactic rules to make sur that syntax errors are
-   displayed with a readable syntax.  It is not sure, since the error reporting
-   procedure changed from V6.1 and does not reprint the command anymore. *)
-Grammar vernac vernac : ast :=
-  text_proof_flag_on [ "Text" "Mode" "fr" "." ] ->
-       [(TEXT_MODE (AST "fr"))]
-| text_proof_flag_on [ "Text" "Mode" "en" "." ] ->
-       [(TEXT_MODE (AST "en"))]
-| text_proof_flag_on [ "Text" "Mode" "Off" "." ] ->
-       [(TEXT_MODE (AST "off"))].
-
-*)
-*)
diff --git a/contrib7/interface/vernacrc b/contrib7/interface/vernacrc
deleted file mode 100644
index f95c4212..00000000
--- a/contrib7/interface/vernacrc
+++ /dev/null
@@ -1,17 +0,0 @@
-# $Id: vernacrc,v 1.1 2003/11/29 20:02:41 herbelin Exp $
-
-# This file is loaded initially by ./vernacparser.
-
-load_syntax_file 17 LogicSyntax
-load_syntax_file 36 SpecifSyntax
-load_syntax_file 18 Logic_TypeSyntax
-load_syntax_file 19 DatatypesSyntax
-load_syntax_file 21 Equality
-load_syntax_file 22 Inv
-load_syntax_file 26 Tauto
-load_syntax_file 34 Omega
-load_syntax_file 27 Ring
-quiet_parse_string
-Goal a.
-&& END--OF--DATA
-print_version
diff --git a/contrib7/omega/Omega.v b/contrib7/omega/Omega.v
deleted file mode 100644
index 76e37519..00000000
--- a/contrib7/omega/Omega.v
+++ /dev/null
@@ -1,57 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(**************************************************************************)
-(*                                                                        *)
-(* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
-(*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* $Id: Omega.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
-
-(* We do not require [ZArith] anymore, but only what's necessary for Omega *)
-Require Export ZArith_base.
-Require Export OmegaLemmas.
-
-Hints Resolve Zle_n Zplus_sym Zplus_assoc Zmult_sym Zmult_assoc
-  Zero_left Zero_right Zmult_one Zplus_inverse_l Zplus_inverse_r 
-  Zmult_plus_distr_l Zmult_plus_distr_r : zarith.
-
-Require Export Zhints.
-
-(*
-(* The constant minus is required in coq_omega.ml *)
-Require Minus.
-*)
-
-Hint eq_nat_Omega : zarith := Extern 10 (eq nat ? ?) Abstract Omega.
-Hint le_Omega : zarith := Extern 10 (le ? ?) Abstract Omega.
-Hint lt_Omega : zarith := Extern 10 (lt ? ?) Abstract Omega.
-Hint ge_Omega : zarith := Extern 10 (ge ? ?) Abstract Omega.
-Hint gt_Omega : zarith := Extern 10 (gt ? ?) Abstract Omega.
-
-Hint not_eq_nat_Omega : zarith := Extern 10 ~(eq nat ? ?) Abstract Omega.
-Hint not_le_Omega : zarith := Extern 10 ~(le ? ?) Abstract Omega.
-Hint not_lt_Omega : zarith := Extern 10 ~(lt ? ?) Abstract Omega.
-Hint not_ge_Omega : zarith := Extern 10 ~(ge ? ?) Abstract Omega.
-Hint not_gt_Omega : zarith := Extern 10 ~(gt ? ?) Abstract Omega.
-
-Hint eq_Z_Omega : zarith := Extern 10 (eq Z ? ?) Abstract Omega.
-Hint Zle_Omega : zarith := Extern 10 (Zle ? ?) Abstract Omega.
-Hint Zlt_Omega : zarith := Extern 10 (Zlt ? ?) Abstract Omega.
-Hint Zge_Omega : zarith := Extern 10 (Zge ? ?) Abstract Omega.
-Hint Zgt_Omega : zarith := Extern 10 (Zgt ? ?) Abstract Omega.
-
-Hint not_eq_nat_Omega : zarith := Extern 10 ~(eq Z ? ?) Abstract Omega.
-Hint not_Zle_Omega : zarith := Extern 10 ~(Zle ? ?) Abstract Omega.
-Hint not_Zlt_Omega : zarith := Extern 10 ~(Zlt ? ?) Abstract Omega.
-Hint not_Zge_Omega : zarith := Extern 10 ~(Zge ? ?) Abstract Omega.
-Hint not_Zgt_Omega : zarith := Extern 10 ~(Zgt ? ?) Abstract Omega.
-
-Hint false_Omega : zarith := Extern 10 False Abstract Omega.
diff --git a/contrib7/omega/OmegaLemmas.v b/contrib7/omega/OmegaLemmas.v
deleted file mode 100644
index 0d05fc3e..00000000
--- a/contrib7/omega/OmegaLemmas.v
+++ /dev/null
@@ -1,399 +0,0 @@
-(************************************************************************)
-(*  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: OmegaLemmas.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ i*)
-
-Require ZArith_base.
-
-(** These are specific variants of theorems dedicated for the Omega tactic *)
-
-Lemma new_var: (x:Z) (EX y:Z |(x=y)).
-Intros x; Exists x; Trivial with arith. 
-Qed.
-
-Lemma OMEGA1 : (x,y:Z) (x=y) -> (Zle ZERO x) -> (Zle ZERO y).
-Intros x y H; Rewrite H; Auto with arith.
-Qed.
-
-Lemma OMEGA2 : (x,y:Z) (Zle ZERO x) -> (Zle ZERO y) -> (Zle ZERO (Zplus x y)).
-Exact Zle_0_plus.
-Qed. 
-
-Lemma OMEGA3 : 
-  (x,y,k:Z)(Zgt k ZERO)-> (x=(Zmult y k)) -> (x=ZERO) -> (y=ZERO).
-
-Intros x y k H1 H2 H3; Apply (Zmult_eq k); [
-  Unfold not ; Intros H4; Absurd (Zgt k ZERO); [
-    Rewrite H4; Unfold Zgt ; Simpl; Discriminate | Assumption]
-  | Rewrite <- H2; Assumption].
-Qed.
-
-Lemma OMEGA4 :
-  (x,y,z:Z)(Zgt x ZERO) -> (Zgt y x) -> ~(Zplus (Zmult z y) x) = ZERO.
-
-Unfold not ; Intros x y z H1 H2 H3; Cut (Zgt y ZERO); [
-  Intros H4; Cut (Zle ZERO (Zplus (Zmult z y) x)); [
-    Intros H5; Generalize (Zmult_le_approx y z x H4 H2 H5) ; Intros H6;
-    Absurd (Zgt (Zplus (Zmult z y) x) ZERO); [
-      Rewrite -> H3; Unfold Zgt ; Simpl; Discriminate
-    | Apply Zle_gt_trans with x ; [
-        Pattern 1 x ; Rewrite <- (Zero_left x); Apply Zle_reg_r;
-        Rewrite -> Zmult_sym; Generalize H4 ; Unfold Zgt;
-        Case y; [
-          Simpl; Intros H7; Discriminate H7
-        | Intros p H7; Rewrite <- (Zero_mult_right (POS p));
-          Unfold Zle ; Rewrite -> Zcompare_Zmult_compatible; Exact H6
-        | Simpl; Intros p H7; Discriminate H7]
-      | Assumption]]
-    | Rewrite -> H3; Unfold Zle ; Simpl; Discriminate]
-  | Apply Zgt_trans with x ; [ Assumption | Assumption]].
-Qed.
-
-Lemma OMEGA5: (x,y,z:Z)(x=ZERO) -> (y=ZERO) -> (Zplus x (Zmult y z)) = ZERO.
-
-Intros x y z H1 H2; Rewrite H1; Rewrite H2; Simpl; Trivial with arith.
-Qed.
-
-Lemma OMEGA6:
-  (x,y,z:Z)(Zle ZERO x) -> (y=ZERO) -> (Zle ZERO (Zplus x (Zmult y z))).
-
-Intros x y z H1 H2; Rewrite H2; Simpl; Rewrite Zero_right; Assumption.
-Qed.
-
-Lemma OMEGA7:
-  (x,y,z,t:Z)(Zgt z ZERO) -> (Zgt t ZERO) -> (Zle ZERO x) -> (Zle ZERO y) -> 
-    (Zle ZERO (Zplus (Zmult x z) (Zmult y t))).
-
-Intros x y z t H1 H2 H3 H4; Rewrite <- (Zero_left ZERO);
-Apply Zle_plus_plus; Apply Zle_mult; Assumption.
-Qed.
-
-Lemma OMEGA8: 
-  (x,y:Z) (Zle ZERO x) -> (Zle ZERO y) -> x = (Zopp y) -> x = ZERO.
-
-Intros x y H1 H2 H3; Elim (Zle_lt_or_eq ZERO x H1); [
-  Intros H4; Absurd (Zlt ZERO x); [
-    Change (Zge ZERO x); Apply Zle_ge; Apply Zsimpl_le_plus_l with y;
-    Rewrite -> H3; Rewrite Zplus_inverse_r; Rewrite Zero_right; Assumption
-  | Assumption]
-| Intros H4; Rewrite -> H4; Trivial with arith].
-Qed.
-
-Lemma OMEGA9:(x,y,z,t:Z) y=ZERO -> x = z -> 
-  (Zplus y (Zmult (Zplus (Zopp x) z) t)) = ZERO.
-
-Intros x y z t H1 H2; Rewrite H2; Rewrite Zplus_inverse_l; 
-Rewrite Zero_mult_left;  Rewrite Zero_right; Assumption.
-Qed.
-
-Lemma OMEGA10:(v,c1,c2,l1,l2,k1,k2:Z)
-  (Zplus (Zmult (Zplus (Zmult v c1) l1) k1) (Zmult (Zplus (Zmult v c2) l2) k2))
-  = (Zplus (Zmult v (Zplus (Zmult c1 k1) (Zmult c2 k2)))
-           (Zplus (Zmult l1 k1) (Zmult l2 k2))).
-
-Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
-Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; 
-Rewrite (Zplus_permute (Zmult l1 k1) (Zmult (Zmult v c2) k2)); Trivial with arith.
-Qed.
-
-Lemma OMEGA11:(v1,c1,l1,l2,k1:Z)
-  (Zplus (Zmult (Zplus (Zmult v1 c1) l1) k1) l2)
-  = (Zplus (Zmult v1 (Zmult c1 k1)) (Zplus (Zmult l1 k1) l2)).
-
-Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
-Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; Trivial with arith.
-Qed.
-
-Lemma OMEGA12:(v2,c2,l1,l2,k2:Z)
-  (Zplus l1 (Zmult (Zplus (Zmult v2 c2) l2) k2))
-  = (Zplus (Zmult v2 (Zmult c2 k2)) (Zplus l1 (Zmult l2 k2))).
-
-Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
-Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; Rewrite Zplus_permute;
-Trivial with arith.
-Qed.
-
-Lemma OMEGA13:(v,l1,l2:Z)(x:positive)
-  (Zplus (Zplus (Zmult v (POS x)) l1) (Zplus (Zmult v (NEG x)) l2))
-  = (Zplus l1 l2).
-
-Intros; Rewrite  Zplus_assoc; Rewrite (Zplus_sym (Zmult v (POS x)) l1);
-Rewrite (Zplus_assoc_r l1); Rewrite <- Zmult_plus_distr_r;
-Rewrite <- Zopp_NEG; Rewrite (Zplus_sym (Zopp (NEG x)) (NEG x));
-Rewrite Zplus_inverse_r; Rewrite  Zero_mult_right; Rewrite Zero_right; Trivial with arith.
-Qed.
- 
-Lemma OMEGA14:(v,l1,l2:Z)(x:positive)
-  (Zplus (Zplus (Zmult v (NEG x)) l1) (Zplus (Zmult v (POS x)) l2))
-  = (Zplus l1 l2).
-
-Intros; Rewrite  Zplus_assoc; Rewrite (Zplus_sym (Zmult v (NEG x)) l1);
-Rewrite (Zplus_assoc_r l1); Rewrite <- Zmult_plus_distr_r;
-Rewrite <- Zopp_NEG; Rewrite  Zplus_inverse_r; Rewrite  Zero_mult_right;
-Rewrite Zero_right; Trivial with arith.
-Qed.
-Lemma OMEGA15:(v,c1,c2,l1,l2,k2:Z)
-  (Zplus (Zplus (Zmult v c1) l1) (Zmult (Zplus (Zmult v c2) l2) k2))
-  = (Zplus (Zmult v (Zplus c1  (Zmult c2 k2)))
-           (Zplus l1 (Zmult l2 k2))).
-
-Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
-Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; 
-Rewrite (Zplus_permute l1 (Zmult (Zmult v c2) k2)); Trivial with arith.
-Qed.
-
-Lemma OMEGA16:
-  (v,c,l,k:Z)
-   (Zmult (Zplus (Zmult v c) l) k) = (Zplus (Zmult v (Zmult c k)) (Zmult l k)).
-
-Intros; Repeat (Rewrite Zmult_plus_distr_l Orelse Rewrite Zmult_plus_distr_r);
-Repeat Rewrite Zmult_assoc; Repeat Elim Zplus_assoc; Trivial with arith.
-Qed.
-
-Lemma OMEGA17: 
-  (x,y,z:Z)(Zne x ZERO) -> (y=ZERO) -> (Zne (Zplus x (Zmult y z)) ZERO).
-
-Unfold Zne not; Intros x y z H1 H2 H3; Apply H1; 
-Apply Zsimpl_plus_l with (Zmult y z); Rewrite Zplus_sym; Rewrite H3; 
-Rewrite H2; Auto with arith.
-Qed.
-
-Lemma OMEGA18:
-  (x,y,k:Z) x=(Zmult y k) -> (Zne x ZERO) -> (Zne y ZERO).
-
-Unfold Zne not; Intros x y k H1 H2 H3; Apply H2; Rewrite H1; Rewrite H3; Auto with arith.
-Qed.
-
-Lemma OMEGA19:
-  (x:Z) (Zne x ZERO) -> 
-    (Zle ZERO (Zplus x (NEG xH))) \/ (Zle ZERO (Zplus (Zmult x (NEG xH)) (NEG xH))).
-
-Unfold Zne ; Intros x H; Elim (Zle_or_lt ZERO x); [
-  Intros H1; Elim Zle_lt_or_eq with 1:=H1; [
-    Intros H2; Left;  Change (Zle ZERO (Zpred x)); Apply Zle_S_n;
-    Rewrite <- Zs_pred; Apply Zlt_le_S; Assumption
-  | Intros H2; Absurd x=ZERO; Auto with arith]
-| Intros H1; Right; Rewrite <- Zopp_one; Rewrite Zplus_sym;
-  Apply Zle_left; Apply Zle_S_n; Simpl; Apply Zlt_le_S; Auto with arith].
-Qed.
-
-Lemma OMEGA20:
-  (x,y,z:Z)(Zne x  ZERO) -> (y=ZERO) -> (Zne (Zplus x (Zmult y z)) ZERO).
-
-Unfold Zne not; Intros x y z H1 H2 H3; Apply H1; Rewrite H2 in H3;
-Simpl in H3; Rewrite Zero_right in H3; Trivial with arith.
-Qed.
-
-Definition fast_Zplus_sym := 
-[x,y:Z][P:Z -> Prop][H: (P (Zplus y x))]
-  (eq_ind_r Z (Zplus y x) P H (Zplus x y) (Zplus_sym x y)).
-
-Definition fast_Zplus_assoc_r :=
-[n,m,p:Z][P:Z -> Prop][H : (P (Zplus n (Zplus m p)))]
- (eq_ind_r Z (Zplus n (Zplus m p)) P H (Zplus (Zplus n m) p) (Zplus_assoc_r n m p)).
-
-Definition fast_Zplus_assoc_l :=
-[n,m,p:Z][P:Z -> Prop][H : (P (Zplus (Zplus n m) p))]
- (eq_ind_r Z (Zplus (Zplus n m) p) P H (Zplus n (Zplus m p)) 
-           (Zplus_assoc_l n m p)).
-
-Definition fast_Zplus_permute :=
-[n,m,p:Z][P:Z -> Prop][H : (P (Zplus m (Zplus n p)))]
- (eq_ind_r Z (Zplus m (Zplus n p)) P H (Zplus n (Zplus m p))
-           (Zplus_permute n m p)).
-
-Definition fast_OMEGA10 := 
-[v,c1,c2,l1,l2,k1,k2:Z][P:Z -> Prop]
-[H : (P (Zplus (Zmult v (Zplus (Zmult c1 k1) (Zmult c2 k2)))
-               (Zplus (Zmult l1 k1) (Zmult l2 k2))))]
- (eq_ind_r Z 
-           (Zplus (Zmult v (Zplus (Zmult c1 k1) (Zmult c2 k2)))
-            (Zplus (Zmult l1 k1) (Zmult l2 k2)))
-           P H 
-          (Zplus (Zmult (Zplus (Zmult v c1) l1) k1)
-                 (Zmult (Zplus (Zmult v c2) l2) k2))
-        (OMEGA10 v c1 c2 l1 l2 k1 k2)).
-
-Definition fast_OMEGA11 := 
-[v1,c1,l1,l2,k1:Z][P:Z -> Prop]
-[H : (P (Zplus (Zmult v1 (Zmult c1 k1)) (Zplus (Zmult l1 k1) l2)))]
- (eq_ind_r Z 
-   (Zplus (Zmult v1 (Zmult c1 k1)) (Zplus (Zmult l1 k1) l2))
-   P H 
-   (Zplus (Zmult (Zplus (Zmult v1 c1) l1) k1) l2)
-   (OMEGA11 v1 c1 l1 l2 k1)).
-Definition fast_OMEGA12 := 
-[v2,c2,l1,l2,k2:Z][P:Z -> Prop]
-[H : (P (Zplus (Zmult v2 (Zmult c2 k2)) (Zplus l1 (Zmult l2 k2))))]
- (eq_ind_r Z 
-   (Zplus (Zmult v2 (Zmult c2 k2)) (Zplus l1 (Zmult l2 k2)))
-   P H 
-   (Zplus l1 (Zmult (Zplus (Zmult v2 c2) l2) k2))
-   (OMEGA12 v2 c2 l1 l2 k2)).
-
-Definition fast_OMEGA15 :=
-[v,c1,c2,l1,l2,k2 :Z][P:Z -> Prop]
-[H : (P (Zplus (Zmult v (Zplus c1 (Zmult c2 k2))) (Zplus l1 (Zmult l2 k2))))]
- (eq_ind_r Z 
-   (Zplus (Zmult v (Zplus c1 (Zmult c2 k2))) (Zplus l1 (Zmult l2 k2)))
-   P H 
-   (Zplus (Zplus (Zmult v c1) l1) (Zmult (Zplus (Zmult v c2) l2) k2))
-   (OMEGA15 v c1 c2 l1 l2 k2)).
-Definition fast_OMEGA16 :=
-[v,c,l,k :Z][P:Z -> Prop]
-[H : (P (Zplus (Zmult v (Zmult c k)) (Zmult l k)))]
- (eq_ind_r Z 
-   (Zplus (Zmult v (Zmult c k)) (Zmult l k))
-   P H 
-   (Zmult (Zplus (Zmult v c) l) k)
-   (OMEGA16 v c l k)).
-
-Definition fast_OMEGA13 :=
-[v,l1,l2 :Z][x:positive][P:Z -> Prop]
-[H : (P (Zplus l1 l2))]
- (eq_ind_r Z 
-   (Zplus l1 l2)
-   P H 
-   (Zplus (Zplus (Zmult v (POS x)) l1) (Zplus (Zmult v (NEG x)) l2))
-   (OMEGA13 v l1 l2 x )).
-
-Definition fast_OMEGA14 :=
-[v,l1,l2 :Z][x:positive][P:Z -> Prop]
-[H : (P (Zplus l1 l2))]
- (eq_ind_r Z 
-   (Zplus l1 l2)
-   P H 
-   (Zplus (Zplus (Zmult v (NEG x)) l1) (Zplus (Zmult v (POS x)) l2))
-   (OMEGA14 v l1 l2 x )).
-Definition fast_Zred_factor0:=
-[x:Z][P:Z -> Prop]
-[H : (P (Zmult x (POS xH)) )]
- (eq_ind_r Z 
-   (Zmult x (POS xH))
-   P H 
-   x
-   (Zred_factor0 x)).
-
-Definition fast_Zopp_one :=
-[x:Z][P:Z -> Prop]
-[H : (P (Zmult x (NEG xH)))]
- (eq_ind_r Z 
-   (Zmult x (NEG xH))
-   P H 
-   (Zopp x)
-   (Zopp_one x)).
-
-Definition fast_Zmult_sym :=
-[x,y :Z][P:Z -> Prop]
-[H : (P (Zmult y x))]
- (eq_ind_r Z 
-(Zmult y x)
-   P H 
-(Zmult x y)
-   (Zmult_sym x y )).
-
-Definition fast_Zopp_Zplus :=
-[x,y :Z][P:Z -> Prop]
-[H : (P (Zplus (Zopp x) (Zopp y)) )]
- (eq_ind_r Z 
-   (Zplus (Zopp x) (Zopp y))
-   P H 
-   (Zopp (Zplus x y))
-   (Zopp_Zplus x y )).
-
-Definition fast_Zopp_Zopp :=
-[x:Z][P:Z -> Prop]
-[H : (P x )] (eq_ind_r Z x P H (Zopp (Zopp x)) (Zopp_Zopp x)).
-
-Definition fast_Zopp_Zmult_r :=
-[x,y:Z][P:Z -> Prop]
-[H : (P (Zmult x (Zopp y)))]
- (eq_ind_r Z 
-   (Zmult x (Zopp y))
-   P H 
-   (Zopp (Zmult x y))
-   (Zopp_Zmult_r x y )).
-
-Definition fast_Zmult_plus_distr :=
-[n,m,p:Z][P:Z -> Prop]
-[H : (P (Zplus (Zmult n p) (Zmult m p)))]
- (eq_ind_r Z 
-   (Zplus (Zmult n p) (Zmult m p))
-   P H 
-   (Zmult (Zplus n m) p)
-   (Zmult_plus_distr_l n m p)).
-Definition fast_Zmult_Zopp_left:=
-[x,y:Z][P:Z -> Prop]
-[H : (P (Zmult x (Zopp y)))]
- (eq_ind_r Z 
-   (Zmult x (Zopp y))
-   P H 
-   (Zmult (Zopp x) y)
-   (Zmult_Zopp_left x y)).
-
-Definition fast_Zmult_assoc_r :=
-[n,m,p :Z][P:Z -> Prop]
-[H : (P (Zmult n (Zmult m p)))]
- (eq_ind_r Z 
-   (Zmult n (Zmult m p))
-   P H 
-   (Zmult (Zmult n m) p)
-   (Zmult_assoc_r n m p)).
-
-Definition fast_Zred_factor1 :=
-[x:Z][P:Z -> Prop]
-[H : (P (Zmult x (POS (xO xH))) )]
- (eq_ind_r Z 
-   (Zmult x (POS (xO xH)))
-   P H 
-   (Zplus x x)
-   (Zred_factor1 x)).
-
-Definition fast_Zred_factor2 :=
-[x,y:Z][P:Z -> Prop]
-[H : (P (Zmult x (Zplus (POS xH) y)))]
- (eq_ind_r Z 
-   (Zmult x (Zplus (POS xH) y))
-   P H 
-   (Zplus x (Zmult x y))
-   (Zred_factor2 x y)).
-Definition fast_Zred_factor3 :=
-[x,y:Z][P:Z -> Prop]
-[H : (P (Zmult x (Zplus (POS xH) y)))]
- (eq_ind_r Z 
-   (Zmult x (Zplus (POS xH) y))
-   P H 
-   (Zplus (Zmult x y) x)
-   (Zred_factor3 x y)).
-
-Definition fast_Zred_factor4 :=
-[x,y,z:Z][P:Z -> Prop]
-[H : (P (Zmult x (Zplus y z)))]
- (eq_ind_r Z 
-   (Zmult x (Zplus y z))
-   P H 
-   (Zplus (Zmult x y) (Zmult x z))
-   (Zred_factor4 x y z)).
-
-Definition fast_Zred_factor5 :=
-[x,y:Z][P:Z -> Prop]
-[H : (P y)]
- (eq_ind_r Z 
-   y
-   P H 
-   (Zplus (Zmult x ZERO) y)
-   (Zred_factor5 x y)).
-
-Definition fast_Zred_factor6 :=
-[x :Z][P:Z -> Prop]
-[H : (P(Zplus x ZERO) )]
- (eq_ind_r Z 
-   (Zplus x ZERO)
-   P H 
-   x
-   (Zred_factor6 x )).
diff --git a/contrib7/ring/ArithRing.v b/contrib7/ring/ArithRing.v
deleted file mode 100644
index c2abc4d1..00000000
--- a/contrib7/ring/ArithRing.v
+++ /dev/null
@@ -1,81 +0,0 @@
-(************************************************************************)
-(*  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: ArithRing.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *)
-
-(* Instantiation of the Ring tactic for the naturals of Arith $*)
-
-Require Export Ring.
-Require Export Arith.
-Require Eqdep_dec.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Fixpoint nateq [n,m:nat] : bool :=
-  Cases n m of
-  | O O => true
-  | (S n') (S m') => (nateq n' m')
-  | _ _ => false
-  end.
-
-Lemma nateq_prop : (n,m:nat)(Is_true (nateq n m))->n==m.
-Proof.
-  Induction n; Induction m; Intros; Try Contradiction.
-  Trivial.
-  Unfold Is_true in H1.
-  Rewrite (H n1 H1).
-  Trivial.
-Save.
-
-Hints Resolve nateq_prop eq2eqT : arithring.
-
-Definition NatTheory : (Semi_Ring_Theory plus mult (1) (0) nateq).
-  Split; Intros; Auto with arith arithring.
-  Apply eq2eqT; Apply simpl_plus_l with n:=n.
-  Apply eqT2eq; Trivial.
-Defined.
-
-
-Add Semi Ring nat plus mult (1) (0) nateq NatTheory [O S].
-
-Goal (n:nat)(S n)=(plus (S O) n).
-Intro; Reflexivity.
-Save S_to_plus_one.
-
-(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
-   exp is already O and only for those occurrences than can be reached by going
-   down plus and mult operations  *)
-Recursive Meta Definition S_to_plus t :=
-   Match t With 
-   | [(S O)] -> '(S O)
-   | [(S ?1)] -> Let t1 = (S_to_plus ?1) In
-                 '(plus (S O) t1)
-   | [(plus ?1 ?2)] -> Let t1 = (S_to_plus ?1) 
-                     And t2 = (S_to_plus ?2) In
-                     '(plus t1 t2)
-   | [(mult ?1 ?2)] -> Let t1 = (S_to_plus ?1)
-                     And t2 = (S_to_plus ?2) In
-                     '(mult t1 t2)
-   | [?] -> 't.
-
-(* Apply S_to_plus on both sides of an equality *)
-Tactic Definition S_to_plus_eq :=
-   Match Context With
-   | [ |- ?1 = ?2 ] -> 
-      (**) Try (**)
-      Let t1 = (S_to_plus ?1)
-      And t2 = (S_to_plus ?2) In
-        Change t1=t2
-   | [ |- ?1 == ?2 ] ->
-      (**) Try (**)
-      Let t1 = (S_to_plus ?1)
-      And t2 = (S_to_plus ?2) In
-        Change (t1==t2).
-
-Tactic Definition NatRing := S_to_plus_eq;Ring.
diff --git a/contrib7/ring/NArithRing.v b/contrib7/ring/NArithRing.v
deleted file mode 100644
index f4548bbb..00000000
--- a/contrib7/ring/NArithRing.v
+++ /dev/null
@@ -1,44 +0,0 @@
-(************************************************************************)
-(*  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: NArithRing.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *)
-
-(* Instantiation of the Ring tactic for the binary natural numbers *)
-
-Require Export Ring.
-Require Export ZArith_base.
-Require NArith.
-Require Eqdep_dec.
-
-Definition Neq := [n,m:entier]
-  Cases (Ncompare n m) of
-    EGAL => true
-  | _ => false
-  end.
-
-Lemma Neq_prop : (n,m:entier)(Is_true (Neq n m)) -> n=m.
-  Intros n m H; Unfold Neq in H.
-  Apply Ncompare_Eq_eq.
-  NewDestruct (Ncompare n m); [Reflexivity | Contradiction | Contradiction ].
-Save.
-
-Definition NTheory : (Semi_Ring_Theory Nplus Nmult (Pos xH) Nul Neq).
-  Split.
-    Apply Nplus_comm.
-    Apply Nplus_assoc.
-    Apply Nmult_comm.
-    Apply Nmult_assoc.
-    Apply Nplus_0_l.
-    Apply Nmult_1_l.
-    Apply Nmult_0_l.
-    Apply Nmult_plus_distr_r.
-    Apply Nplus_reg_l.
-    Apply Neq_prop.
-Save.
-
-Add Semi Ring entier Nplus Nmult (Pos xH) Nul Neq NTheory [Pos Nul xO xI xH].
diff --git a/contrib7/ring/Quote.v b/contrib7/ring/Quote.v
deleted file mode 100644
index 12a51c9f..00000000
--- a/contrib7/ring/Quote.v
+++ /dev/null
@@ -1,85 +0,0 @@
-(************************************************************************)
-(*  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: Quote.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *)
-
-(***********************************************************************
-  The "abstract" type index is defined to represent variables.
-
-  index : Set
-  index_eq : index -> bool
-  index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m
-  index_lt : index -> bool
-  varmap : Type -> Type.	
-  varmap_find : (A:Type)A -> index -> (varmap A) -> A.
-
-  The first arg. of varmap_find is the default value to take
-  if the object is not found in the varmap.
-
-  index_lt defines a total well-founded order, but we don't prove that.
-
-***********************************************************************)
-
-Set Implicit Arguments.
-
-Section variables_map.
-
-Variable A : Type.
-
-Inductive varmap : Type :=
-  Empty_vm : varmap
-| Node_vm : A->varmap->varmap->varmap.
-
-Inductive index : Set := 
-| Left_idx : index -> index
-| Right_idx : index -> index
-| End_idx : index
-.
-
-Fixpoint varmap_find [default_value:A; i:index; v:varmap] : A :=
-  Cases i v of
-    End_idx (Node_vm x _ _) => x
-  | (Right_idx i1) (Node_vm x v1 v2) => (varmap_find default_value i1 v2)
-  | (Left_idx i1) (Node_vm x v1 v2) => (varmap_find default_value i1 v1)
-  | _ _ => default_value
-  end.
-
-Fixpoint index_eq [n,m:index] : bool :=
-  Cases n m of
-  | End_idx End_idx => true
-  | (Left_idx n') (Left_idx m') => (index_eq n' m')
-  | (Right_idx n') (Right_idx m') => (index_eq n' m')
-  | _ _ => false
-  end.
-
-Fixpoint index_lt[n,m:index] : bool :=
-  Cases n m of
-  | End_idx (Left_idx _) => true
-  | End_idx (Right_idx _) => true
-  | (Left_idx n') (Right_idx m') => true
-  | (Right_idx n') (Right_idx m') => (index_lt n' m') 
-  | (Left_idx n') (Left_idx m') => (index_lt n' m') 
-  | _ _ => false
-  end.
-
-Lemma index_eq_prop : (n,m:index)(index_eq n m)=true -> n=m.
-  Induction n; Induction m; Simpl; Intros.
-  Rewrite (H i0 H1); Reflexivity.
-  Discriminate.
-  Discriminate.
-  Discriminate.
-  Rewrite (H i0 H1); Reflexivity.
-  Discriminate.
-  Discriminate.
-  Discriminate.
-  Reflexivity.
-Save.
-
-End variables_map.
-
-Unset Implicit Arguments.
diff --git a/contrib7/ring/Ring.v b/contrib7/ring/Ring.v
deleted file mode 100644
index 860dda13..00000000
--- a/contrib7/ring/Ring.v
+++ /dev/null
@@ -1,34 +0,0 @@
-(************************************************************************)
-(*  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: Ring.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *)
-
-Require Export Bool.
-Require Export Ring_theory.
-Require Export Quote.
-Require Export Ring_normalize.
-Require Export Ring_abstract.
-
-(* As an example, we provide an instantation for bool. *)
-(* Other instatiations are given in ArithRing and ZArithRing in the
-   same directory *)
-
-Definition BoolTheory : (Ring_Theory xorb andb true false [b:bool]b eqb).
-Split; Simpl.
-NewDestruct n; NewDestruct m; Reflexivity.
-NewDestruct n; NewDestruct m; NewDestruct p; Reflexivity.
-NewDestruct n; NewDestruct m; Reflexivity.
-NewDestruct n; NewDestruct m; NewDestruct p; Reflexivity.
-NewDestruct n; Reflexivity.
-NewDestruct n; Reflexivity.
-NewDestruct n; Reflexivity.
-NewDestruct n; NewDestruct m; NewDestruct p; Reflexivity.
-NewDestruct x; NewDestruct y; Reflexivity Orelse Simpl; Tauto.
-Defined.
-
-Add Ring bool xorb andb true false [b:bool]b eqb BoolTheory [ true false ].
diff --git a/contrib7/ring/Ring_abstract.v b/contrib7/ring/Ring_abstract.v
deleted file mode 100644
index 55bb31da..00000000
--- a/contrib7/ring/Ring_abstract.v
+++ /dev/null
@@ -1,699 +0,0 @@
-(************************************************************************)
-(*  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: Ring_abstract.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *)
-
-Require Ring_theory.
-Require Quote.
-Require Ring_normalize.
-
-Section abstract_semi_rings.
-
-Inductive Type aspolynomial :=
-  ASPvar : index -> aspolynomial
-| ASP0 : aspolynomial
-| ASP1 : aspolynomial
-| ASPplus : aspolynomial -> aspolynomial -> aspolynomial
-| ASPmult : aspolynomial -> aspolynomial -> aspolynomial
-.
-
-Inductive abstract_sum : Type := 
-| Nil_acs : abstract_sum
-| Cons_acs : varlist -> abstract_sum -> abstract_sum
-.
-
-Fixpoint abstract_sum_merge [s1:abstract_sum] 
-      	 : abstract_sum -> abstract_sum :=
-Cases s1 of
-| (Cons_acs l1 t1) =>      
-     Fix asm_aux{asm_aux[s2:abstract_sum] : abstract_sum :=
-           Cases s2 of
-      	   | (Cons_acs l2 t2) =>
-	       if (varlist_lt l1 l2)
-	       then (Cons_acs l1 (abstract_sum_merge t1 s2))
-	       else (Cons_acs l2 (asm_aux t2))
-	   | Nil_acs => s1
-	   end}
-| Nil_acs => [s2]s2
-end.
-
-Fixpoint abstract_varlist_insert [l1:varlist; s2:abstract_sum] 
-      : abstract_sum :=
-  Cases s2 of
-  | (Cons_acs l2 t2) =>
-       if (varlist_lt l1 l2)
-       then (Cons_acs l1 s2)
-       else (Cons_acs l2 (abstract_varlist_insert l1 t2))
-  | Nil_acs => (Cons_acs l1 Nil_acs)
-  end.
-
-Fixpoint abstract_sum_scalar [l1:varlist; s2:abstract_sum] 
-      : abstract_sum :=
-  Cases s2 of
-  | (Cons_acs l2 t2) => (abstract_varlist_insert (varlist_merge l1 l2) 
-                                (abstract_sum_scalar l1 t2))
-  | Nil_acs => Nil_acs
-  end.
-
-Fixpoint abstract_sum_prod [s1:abstract_sum] 
-      	 : abstract_sum -> abstract_sum := 
-    [s2]Cases s1 of
-    | (Cons_acs l1 t1) =>
-	(abstract_sum_merge (abstract_sum_scalar l1 s2) 
-			     (abstract_sum_prod t1 s2))
-    | Nil_acs => Nil_acs
-    end.
-
-Fixpoint aspolynomial_normalize[p:aspolynomial] : abstract_sum :=
-  Cases p of
-  | (ASPvar i) => (Cons_acs (Cons_var i Nil_var) Nil_acs)
-  | ASP1 => (Cons_acs Nil_var Nil_acs)
-  | ASP0 => Nil_acs
-  | (ASPplus l r) => (abstract_sum_merge (aspolynomial_normalize l) 
-      	       	       	       	       	 (aspolynomial_normalize r))
-  | (ASPmult l r) => (abstract_sum_prod (aspolynomial_normalize l) 
-      	       	       	       	        (aspolynomial_normalize r))
-  end.
-
-
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aeq : A -> A -> bool.
-Variable vm : (varmap A).
-Variable T : (Semi_Ring_Theory Aplus Amult Aone Azero Aeq).
-
-Fixpoint interp_asp [p:aspolynomial] : A :=
-  Cases p of
-  | (ASPvar i) => (interp_var Azero vm i)
-  | ASP0 => Azero
-  | ASP1 => Aone
-  | (ASPplus l r) => (Aplus (interp_asp l) (interp_asp r))
-  | (ASPmult l r) => (Amult (interp_asp l) (interp_asp r))
-  end.
-
-(* Local *) Definition iacs_aux := Fix iacs_aux{iacs_aux [a:A; s:abstract_sum] : A :=  
-  Cases s of
-  | Nil_acs => a
-  | (Cons_acs l t) => (Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t))
-  end}.
-
-Definition interp_acs [s:abstract_sum] : A :=
-  Cases s of
-  | (Cons_acs l t) => (iacs_aux (interp_vl Amult Aone Azero vm l) t)
-  | Nil_acs => Azero
-  end.
-
-Hint SR_plus_sym_T := Resolve (SR_plus_sym T).
-Hint SR_plus_assoc_T := Resolve (SR_plus_assoc T).
-Hint SR_plus_assoc2_T := Resolve (SR_plus_assoc2 T).
-Hint SR_mult_sym_T := Resolve (SR_mult_sym T).
-Hint SR_mult_assoc_T := Resolve (SR_mult_assoc T).
-Hint SR_mult_assoc2_T := Resolve (SR_mult_assoc2 T).
-Hint SR_plus_zero_left_T := Resolve (SR_plus_zero_left T).
-Hint SR_plus_zero_left2_T := Resolve (SR_plus_zero_left2 T).
-Hint SR_mult_one_left_T := Resolve (SR_mult_one_left T).
-Hint SR_mult_one_left2_T := Resolve (SR_mult_one_left2 T).
-Hint SR_mult_zero_left_T := Resolve (SR_mult_zero_left T).
-Hint SR_mult_zero_left2_T := Resolve (SR_mult_zero_left2 T).
-Hint SR_distr_left_T := Resolve (SR_distr_left T).
-Hint SR_distr_left2_T := Resolve (SR_distr_left2 T).
-Hint SR_plus_reg_left_T := Resolve (SR_plus_reg_left T).
-Hint SR_plus_permute_T := Resolve (SR_plus_permute T).
-Hint SR_mult_permute_T := Resolve (SR_mult_permute T).
-Hint SR_distr_right_T := Resolve (SR_distr_right T).
-Hint SR_distr_right2_T := Resolve (SR_distr_right2 T).
-Hint SR_mult_zero_right_T := Resolve (SR_mult_zero_right T).
-Hint SR_mult_zero_right2_T := Resolve (SR_mult_zero_right2 T).
-Hint SR_plus_zero_right_T := Resolve (SR_plus_zero_right T).
-Hint SR_plus_zero_right2_T := Resolve (SR_plus_zero_right2 T).
-Hint SR_mult_one_right_T := Resolve (SR_mult_one_right T).
-Hint SR_mult_one_right2_T := Resolve (SR_mult_one_right2 T).
-Hint SR_plus_reg_right_T := Resolve (SR_plus_reg_right T).
-Hints Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hints Immediate T.
-
-Remark iacs_aux_ok : (x:A)(s:abstract_sum)
-  (iacs_aux x s)==(Aplus x (interp_acs s)).
-Proof.
-  Induction s; Simpl; Intros.
-  Trivial.
-  Reflexivity.
-Save.
-
-Hint rew_iacs_aux : core := Extern 10 (eqT A ? ?) Rewrite iacs_aux_ok.
-
-Lemma abstract_varlist_insert_ok : (l:varlist)(s:abstract_sum)
-  (interp_acs (abstract_varlist_insert l s)) 
-   ==(Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s)).
-
-  Induction s.
-  Trivial.
-
-  Simpl; Intros.
-  Elim (varlist_lt l v); Simpl.  	
-  EAuto.
-  Rewrite iacs_aux_ok.
-  Rewrite H; Auto.
-
-Save.
-
-Lemma abstract_sum_merge_ok : (x,y:abstract_sum)
-  (interp_acs (abstract_sum_merge x y))
-  ==(Aplus (interp_acs x) (interp_acs y)).
-
-Proof.  
-  Induction x.
-  Trivial.
-  Induction y; Intros.
-
-  Auto.
-
-  Simpl; Elim (varlist_lt v v0); Simpl.
-  Repeat Rewrite iacs_aux_ok.
-  Rewrite H;  Simpl; Auto.
-
-  Simpl in H0.
-  Repeat Rewrite iacs_aux_ok.
-  Rewrite H0. Simpl; Auto.
-Save.
-
-Lemma abstract_sum_scalar_ok : (l:varlist)(s:abstract_sum)
-  (interp_acs (abstract_sum_scalar l s)) 
-   == (Amult (interp_vl Amult Aone Azero vm l) (interp_acs s)).
-Proof.
-  Induction s.
-  Simpl; EAuto.
-
-  Simpl; Intros.
-  Rewrite iacs_aux_ok.
-  Rewrite abstract_varlist_insert_ok.
-  Rewrite H.
-  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  Auto.
-Save.
-
-Lemma abstract_sum_prod_ok : (x,y:abstract_sum)
-  (interp_acs (abstract_sum_prod x y)) 
-   == (Amult (interp_acs x) (interp_acs y)).
-
-Proof.
-  Induction x.
-  Intros; Simpl; EAuto.
-
-  NewDestruct y; Intros.
-
-  Simpl; Rewrite H; EAuto.
-
-  Unfold abstract_sum_prod; Fold abstract_sum_prod.
-  Rewrite abstract_sum_merge_ok.
-  Rewrite abstract_sum_scalar_ok.
-  Rewrite H; Simpl; Auto.
-Save.
-
-Theorem aspolynomial_normalize_ok : (x:aspolynomial)
-	(interp_asp x)==(interp_acs (aspolynomial_normalize x)).
-Proof.
-  Induction x; Simpl; Intros; Trivial.
-  Rewrite abstract_sum_merge_ok.
-  Rewrite H; Rewrite H0; EAuto.
-  Rewrite abstract_sum_prod_ok.
-  Rewrite H; Rewrite H0; EAuto.
-Save.
-
-End abstract_semi_rings.
-
-Section abstract_rings.
-
-(* In abstract polynomials there is no constants other
-   than 0 and 1. An abstract ring is a ring whose operations plus, 
-   and mult are not functions but  constructors. In other words,
-   when c1 and c2 are closed,  (plus c1 c2) doesn't reduce to a closed
-   term. "closed" mean here "without plus and mult". *)
-
-(* this section is not parametrized by a (semi-)ring.
-   Nevertheless, they are two different types for semi-rings and rings 
-   and there will be 2 correction theorems *)
-
-Inductive Type apolynomial :=
-  APvar : index -> apolynomial
-| AP0 : apolynomial
-| AP1 : apolynomial
-| APplus : apolynomial -> apolynomial -> apolynomial
-| APmult : apolynomial -> apolynomial -> apolynomial
-| APopp : apolynomial -> apolynomial
-.
-
-(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-".
-   Invariant : the list is sorted and there is no varlist is present
-   with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *)
-
-Inductive signed_sum : Type := 
-| Nil_varlist : signed_sum
-| Plus_varlist : varlist -> signed_sum -> signed_sum
-| Minus_varlist : varlist -> signed_sum -> signed_sum
-.
-
-Fixpoint signed_sum_merge [s1:signed_sum] 
-      	 : signed_sum -> signed_sum :=
-Cases s1 of
-| (Plus_varlist l1 t1) =>      
-     Fix ssm_aux{ssm_aux[s2:signed_sum] : signed_sum :=
-           Cases s2 of
-      	   | (Plus_varlist l2 t2) =>
-	       if (varlist_lt l1 l2)
-	       then (Plus_varlist l1 (signed_sum_merge t1 s2))
-	       else (Plus_varlist l2 (ssm_aux t2))
-      	   | (Minus_varlist l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (signed_sum_merge t1 t2)
-	       else if (varlist_lt l1 l2)
-	       then (Plus_varlist l1 (signed_sum_merge t1 s2))
-	       else (Minus_varlist l2 (ssm_aux t2))
-	   | Nil_varlist => s1
-	   end}
-| (Minus_varlist l1 t1) =>
-     Fix ssm_aux2{ssm_aux2[s2:signed_sum] : signed_sum :=
-           Cases s2 of
-      	   | (Plus_varlist l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (signed_sum_merge t1 t2)
-	       else if (varlist_lt l1 l2)
-	       then (Minus_varlist l1 (signed_sum_merge t1 s2))
-	       else (Plus_varlist l2 (ssm_aux2 t2))
-      	   | (Minus_varlist l2 t2) =>
-	       if (varlist_lt l1 l2)
-	       then (Minus_varlist l1 (signed_sum_merge t1 s2))
-	       else (Minus_varlist l2 (ssm_aux2 t2))
-	   | Nil_varlist => s1
-	   end}
-| Nil_varlist => [s2]s2
-end.
-
-Fixpoint plus_varlist_insert [l1:varlist; s2:signed_sum] 
-      : signed_sum :=
-  Cases s2 of
-  | (Plus_varlist l2 t2) =>
-       if (varlist_lt l1 l2)
-       then (Plus_varlist l1 s2)
-       else (Plus_varlist l2 (plus_varlist_insert l1 t2))
-  | (Minus_varlist l2 t2) =>
-       if (varlist_eq l1 l2)
-       then t2
-       else if (varlist_lt l1 l2)
-       then (Plus_varlist l1 s2)
-       else (Minus_varlist l2 (plus_varlist_insert l1 t2))
-  | Nil_varlist => (Plus_varlist l1 Nil_varlist)
-  end.
-
-Fixpoint minus_varlist_insert [l1:varlist; s2:signed_sum] 
-      : signed_sum :=
-  Cases s2 of
-  | (Plus_varlist l2 t2) =>
-       if (varlist_eq l1 l2)
-       then t2
-       else if (varlist_lt l1 l2)
-       then (Minus_varlist l1 s2)
-       else (Plus_varlist l2 (minus_varlist_insert l1 t2))
-  | (Minus_varlist l2 t2) =>
-       if (varlist_lt l1 l2)
-       then (Minus_varlist l1 s2)
-       else (Minus_varlist l2 (minus_varlist_insert l1 t2))
-  | Nil_varlist => (Minus_varlist l1 Nil_varlist)
-  end.
-
-Fixpoint signed_sum_opp [s:signed_sum] : signed_sum :=
-  Cases s of
-  | (Plus_varlist l2 t2) => (Minus_varlist l2 (signed_sum_opp t2))
-  | (Minus_varlist l2 t2) => (Plus_varlist l2 (signed_sum_opp t2))
-  | Nil_varlist => Nil_varlist
-  end.
-
-
-Fixpoint plus_sum_scalar [l1:varlist; s2:signed_sum] 
-      : signed_sum :=
-  Cases s2 of
-  | (Plus_varlist l2 t2) => (plus_varlist_insert (varlist_merge l1 l2) 
-                                (plus_sum_scalar l1 t2))
-  | (Minus_varlist l2 t2) => (minus_varlist_insert (varlist_merge l1 l2) 
-                                (plus_sum_scalar l1 t2))
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint minus_sum_scalar [l1:varlist; s2:signed_sum] 
-      : signed_sum :=
-  Cases s2 of
-  | (Plus_varlist l2 t2) => (minus_varlist_insert (varlist_merge l1 l2) 
-                                (minus_sum_scalar l1 t2))
-  | (Minus_varlist l2 t2) => (plus_varlist_insert (varlist_merge l1 l2) 
-                                (minus_sum_scalar l1 t2))
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint signed_sum_prod [s1:signed_sum] 
-      	 : signed_sum -> signed_sum := 
-    [s2]Cases s1 of
-    | (Plus_varlist l1 t1) =>
-	(signed_sum_merge (plus_sum_scalar l1 s2) 
-			     (signed_sum_prod t1 s2))
-    | (Minus_varlist l1 t1) =>
-	(signed_sum_merge (minus_sum_scalar l1 s2) 
-			     (signed_sum_prod t1 s2))
-    | Nil_varlist => Nil_varlist
-    end.
-
-Fixpoint apolynomial_normalize[p:apolynomial] : signed_sum :=
-  Cases p of
-  | (APvar i) => (Plus_varlist (Cons_var i Nil_var) Nil_varlist)
-  | AP1 => (Plus_varlist Nil_var Nil_varlist)
-  | AP0 => Nil_varlist
-  | (APplus l r) => (signed_sum_merge (apolynomial_normalize l) 
-      	       	       	       	       	 (apolynomial_normalize r))
-  | (APmult l r) => (signed_sum_prod (apolynomial_normalize l) 
-      	       	       	       	        (apolynomial_normalize r))
-  | (APopp q) => (signed_sum_opp (apolynomial_normalize q))
-  end.
-
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp :A -> A.
-Variable Aeq : A -> A -> bool.
-Variable vm : (varmap A).
-Variable T : (Ring_Theory Aplus Amult Aone Azero Aopp Aeq).
-
-(* Local *) Definition isacs_aux := Fix isacs_aux{isacs_aux [a:A; s:signed_sum] : A :=  
-  Cases s of
-  | Nil_varlist => a
-  | (Plus_varlist l t) => 
-	(Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t))
-  | (Minus_varlist l t) => 
-	(Aplus a (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t))
-  end}.
-
-Definition interp_sacs [s:signed_sum] : A :=
-  Cases s of
-  | (Plus_varlist l t) => (isacs_aux (interp_vl Amult Aone Azero vm l) t)
-  | (Minus_varlist l t) => 
-	(isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t)
-  | Nil_varlist => Azero
-  end.
-
-Fixpoint interp_ap [p:apolynomial] : A :=
-  Cases p of
-  | (APvar i) => (interp_var Azero vm i)
-  | AP0 => Azero
-  | AP1 => Aone
-  | (APplus l r) => (Aplus (interp_ap l) (interp_ap r))
-  | (APmult l r) => (Amult (interp_ap l) (interp_ap r))
-  | (APopp q) => (Aopp (interp_ap q))
-  end.
-
-Hint Th_plus_sym_T := Resolve (Th_plus_sym T).
-Hint Th_plus_assoc_T := Resolve (Th_plus_assoc T).
-Hint Th_plus_assoc2_T := Resolve (Th_plus_assoc2 T).
-Hint Th_mult_sym_T := Resolve (Th_mult_sym T).
-Hint Th_mult_assoc_T := Resolve (Th_mult_assoc T).
-Hint Th_mult_assoc2_T := Resolve (Th_mult_assoc2 T).
-Hint Th_plus_zero_left_T := Resolve (Th_plus_zero_left T).
-Hint Th_plus_zero_left2_T := Resolve (Th_plus_zero_left2 T).
-Hint Th_mult_one_left_T := Resolve (Th_mult_one_left T).
-Hint Th_mult_one_left2_T := Resolve (Th_mult_one_left2 T).
-Hint Th_mult_zero_left_T := Resolve (Th_mult_zero_left T).
-Hint Th_mult_zero_left2_T := Resolve (Th_mult_zero_left2 T).
-Hint Th_distr_left_T := Resolve (Th_distr_left T).
-Hint Th_distr_left2_T := Resolve (Th_distr_left2 T).
-Hint Th_plus_reg_left_T := Resolve (Th_plus_reg_left T).
-Hint Th_plus_permute_T := Resolve (Th_plus_permute T).
-Hint Th_mult_permute_T := Resolve (Th_mult_permute T).
-Hint Th_distr_right_T := Resolve (Th_distr_right T).
-Hint Th_distr_right2_T := Resolve (Th_distr_right2 T).
-Hint Th_mult_zero_right2_T := Resolve (Th_mult_zero_right2 T).
-Hint Th_plus_zero_right_T := Resolve (Th_plus_zero_right T).
-Hint Th_plus_zero_right2_T := Resolve (Th_plus_zero_right2 T).
-Hint Th_mult_one_right_T := Resolve (Th_mult_one_right T).
-Hint Th_mult_one_right2_T := Resolve (Th_mult_one_right2 T).
-Hint Th_plus_reg_right_T := Resolve (Th_plus_reg_right T).
-Hints Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hints Immediate T.
-
-Lemma isacs_aux_ok : (x:A)(s:signed_sum)
-  (isacs_aux x s)==(Aplus x (interp_sacs s)).
-Proof.
-  Induction s; Simpl; Intros.
-  Trivial.
-  Reflexivity.
-  Reflexivity.
-Save.
-
-Hint rew_isacs_aux : core := Extern 10 (eqT A ? ?) Rewrite isacs_aux_ok.
-
-Tactic Definition Solve1 v v0 H H0 := 
-  Simpl; Elim (varlist_lt v v0); Simpl; Rewrite isacs_aux_ok;
-    [Rewrite H; Simpl; Auto
-    |Simpl in H0; Rewrite H0; Auto ].
-
-Lemma signed_sum_merge_ok : (x,y:signed_sum)
-  (interp_sacs (signed_sum_merge x y))
-  ==(Aplus (interp_sacs x) (interp_sacs y)).
-
-  Induction x.
-  Intro; Simpl; Auto.
-
-  Induction y; Intros.
-
-  Auto.
-
-  Solve1 v v0 H H0.
-
-  Simpl; Generalize (varlist_eq_prop v v0).
-  Elim (varlist_eq v v0); Simpl.
-
-  Intro Heq; Rewrite (Heq I).
-  Rewrite H.
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite (Th_plus_permute T). 
-  Repeat Rewrite (Th_plus_assoc T).
-  Rewrite (Th_plus_sym T (Aopp (interp_vl Amult Aone Azero vm v0))
-                         (interp_vl Amult Aone Azero vm v0)).
-  Rewrite (Th_opp_def T).
-  Rewrite (Th_plus_zero_left T).
-  Reflexivity.
-
-  Solve1 v v0 H H0.
-
-  Induction y; Intros.
-
-  Auto.
-
-  Simpl; Generalize (varlist_eq_prop v v0).
-  Elim (varlist_eq v v0); Simpl.
-
-  Intro Heq; Rewrite (Heq I).
-  Rewrite H.
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite (Th_plus_permute T). 
-  Repeat Rewrite (Th_plus_assoc T).
-  Rewrite (Th_opp_def T).
-  Rewrite (Th_plus_zero_left T).
-  Reflexivity.
-
-  Solve1 v v0 H H0.
-
-  Solve1 v v0 H H0.
-
-Save.
-
-Tactic Definition Solve2 l v H :=
- 	Elim (varlist_lt l v); Simpl; Rewrite isacs_aux_ok;
-  	[ Auto
-  	| Rewrite H; Auto ].
-
-Lemma plus_varlist_insert_ok : (l:varlist)(s:signed_sum)
-	(interp_sacs (plus_varlist_insert l s)) 
-	== (Aplus (interp_vl  Amult Aone Azero vm l) (interp_sacs s)).
-Proof.
-
-  Induction s.
-  Trivial.
-
-  Simpl; Intros.
-  Solve2 l v H.
-
-  Simpl; Intros.
-  Generalize (varlist_eq_prop l v).
-  Elim (varlist_eq l v); Simpl.
-
-  Intro Heq; Rewrite (Heq I).
-  Repeat Rewrite isacs_aux_ok.
-  Repeat Rewrite (Th_plus_assoc T).
-  Rewrite (Th_opp_def T).
-  Rewrite (Th_plus_zero_left T).
-  Reflexivity.
-
-  Solve2 l v H.
-
-Save.
-
-Lemma minus_varlist_insert_ok : (l:varlist)(s:signed_sum)
-	(interp_sacs (minus_varlist_insert l s)) 
-	== (Aplus (Aopp (interp_vl  Amult Aone Azero vm l)) (interp_sacs s)).
-Proof.
-
-  Induction s.
-  Trivial.
-
-  Simpl; Intros.
-  Generalize (varlist_eq_prop l v).
-  Elim (varlist_eq l v); Simpl.
-
-  Intro Heq; Rewrite (Heq I).
-  Repeat Rewrite isacs_aux_ok.
-  Repeat Rewrite (Th_plus_assoc T).
-  Rewrite (Th_plus_sym T (Aopp (interp_vl Amult Aone Azero vm v))
-         (interp_vl Amult Aone Azero vm v)).
-  Rewrite (Th_opp_def T).
-  Auto.
-
-  Simpl; Intros.
-  Solve2 l v H.
-
-  Simpl; Intros; Solve2 l v H.
-
-Save.
-
-Lemma signed_sum_opp_ok : (s:signed_sum)
-	(interp_sacs (signed_sum_opp s)) 
-	== (Aopp (interp_sacs s)).
-Proof.
-
-  Induction s; Simpl; Intros.
-
-  Symmetry; Apply (Th_opp_zero T).
-
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite H.
-  Rewrite (Th_plus_opp_opp T).
-  Reflexivity.
-
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite H.
-  Rewrite <- (Th_plus_opp_opp T).
-  Rewrite (Th_opp_opp T).
-  Reflexivity.
-
-Save.
-
-Lemma plus_sum_scalar_ok : (l:varlist)(s:signed_sum)
-	(interp_sacs (plus_sum_scalar l s)) 
-	== (Amult (interp_vl  Amult Aone Azero vm l) (interp_sacs s)).
-Proof.
-
-  Induction s.
-  Trivial.
-
-  Simpl; Intros.
-  Rewrite plus_varlist_insert_ok.
-  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite H.
-  Auto.
-
-  Simpl; Intros.
-  Rewrite minus_varlist_insert_ok.
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  Rewrite H.
-  Rewrite (Th_distr_right T).
-  Rewrite <- (Th_opp_mult_right T).
-  Reflexivity.
-
-Save.
-
-Lemma minus_sum_scalar_ok : (l:varlist)(s:signed_sum)
-	(interp_sacs (minus_sum_scalar l s)) 
-	== (Aopp (Amult (interp_vl  Amult Aone Azero vm l) (interp_sacs s))).
-Proof.
-
-  Induction s; Simpl; Intros.
-
-  Rewrite (Th_mult_zero_right T); Symmetry; Apply (Th_opp_zero T).
-
-  Simpl; Intros.
-  Rewrite minus_varlist_insert_ok.
-  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite H.
-  Rewrite (Th_distr_right T).
-  Rewrite (Th_plus_opp_opp T).
-  Reflexivity.
-
-  Simpl; Intros.
-  Rewrite plus_varlist_insert_ok.
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  Rewrite H.
-  Rewrite (Th_distr_right T).
-  Rewrite <- (Th_opp_mult_right T).
-  Rewrite <- (Th_plus_opp_opp T).
-  Rewrite (Th_opp_opp T).
-  Reflexivity.
-
-Save.
-
-Lemma signed_sum_prod_ok : (x,y:signed_sum)
-	(interp_sacs (signed_sum_prod x y)) ==
-		(Amult (interp_sacs x) (interp_sacs y)).
-Proof.
-
-  Induction x.
-
-  Simpl; EAuto 1.
-
-  Intros; Simpl.
-  Rewrite signed_sum_merge_ok.
-  Rewrite plus_sum_scalar_ok.
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite H.
-  Auto.
-
-  Intros; Simpl.
-  Repeat Rewrite isacs_aux_ok.
-  Rewrite signed_sum_merge_ok.
-  Rewrite minus_sum_scalar_ok.
-  Rewrite H.
-  Rewrite (Th_distr_left T).
-  Rewrite (Th_opp_mult_left T).
-  Reflexivity.
-
-Save.
-
-Theorem apolynomial_normalize_ok : (p:apolynomial)
-	(interp_sacs (apolynomial_normalize p))==(interp_ap p).
-Proof.
-  Induction p; Simpl; Auto 1.
-  Intros.
-    Rewrite signed_sum_merge_ok.
-    Rewrite H; Rewrite H0; Reflexivity.
-  Intros.
-    Rewrite signed_sum_prod_ok.
-    Rewrite H; Rewrite H0; Reflexivity.
-  Intros.
-    Rewrite signed_sum_opp_ok.
-    Rewrite H; Reflexivity.
-Save.  
-
-End abstract_rings.
diff --git a/contrib7/ring/Ring_normalize.v b/contrib7/ring/Ring_normalize.v
deleted file mode 100644
index 1dbd9d56..00000000
--- a/contrib7/ring/Ring_normalize.v
+++ /dev/null
@@ -1,893 +0,0 @@
-(************************************************************************)
-(*  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: Ring_normalize.v,v 1.1.2.1 2004/07/16 19:30:18 herbelin Exp $ *)
-
-Require Ring_theory.
-Require Quote.
-
-Set Implicit Arguments.
-
-Lemma index_eq_prop: (n,m:index)(Is_true (index_eq n m)) -> n=m.
-Proof.
-  Intros.
-  Apply Quote.index_eq_prop.
-  Generalize H.
-  Case (index_eq n m); Simpl; Trivial; Intros.
-  Contradiction.
-Save.
-
-Section semi_rings.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aeq : A -> A -> bool.
-
-(* Section definitions. *)
-
-
-(******************************************)
-(* Normal abtract Polynomials             *)
-(******************************************)
-(* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z 
-- A monom is a constant, a varlist or the product of a constant by a varlist
-  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms 
-  (the order on monoms is defined later) 
-- A normal polynomial it either a constant or a canonical sum or a constant
-  plus a canonical sum
-*)
-
-(* varlist is isomorphic to (list var), but we built a special inductive
-   for efficiency *)
-Inductive varlist : Type := 
-| Nil_var : varlist
-| Cons_var : index -> varlist -> varlist
-.
-
-Inductive canonical_sum : Type := 
-| Nil_monom : canonical_sum
-| Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
-| Cons_varlist : varlist -> canonical_sum -> canonical_sum 
-.
-
-(* Order on monoms *)
-
-(* That's the lexicographic order on varlist, extended by : 
-  - A constant is less than every monom 
-  - The relation between two varlist is preserved by multiplication by a
-  constant.
-
-  Examples : 
-  3 < x < y
-  x*y < x*y*y*z 
-  2*x*y < x*y*y*z
-  x*y < 54*x*y*y*z
-  4*x*y < 59*x*y*y*z
-*)
-
-Fixpoint varlist_eq [x,y:varlist] : bool :=
-  Cases x y of
-  | Nil_var Nil_var => true
-  | (Cons_var i xrest) (Cons_var j yrest) => 
-        (andb (index_eq i j) (varlist_eq xrest yrest))
-  | _ _ => false
-  end.
-
-Fixpoint varlist_lt [x,y:varlist] : bool :=
-  Cases x y of 
-  | Nil_var (Cons_var _ _) => true
-  | (Cons_var i xrest) (Cons_var j yrest) => 
-      	if (index_lt i j) then true
-        else (andb (index_eq i j) (varlist_lt xrest yrest))
-  | _ _ => false
-  end.
-
-(* merges two variables lists *)
-Fixpoint varlist_merge [l1:varlist] : varlist -> varlist :=
-  Cases l1 of	
-  | (Cons_var v1 t1) => 
-      Fix vm_aux {vm_aux [l2:varlist] : varlist :=
-	Cases l2 of
-	| (Cons_var v2 t2) => 
-		     if (index_lt v1 v2)
-		     then (Cons_var v1 (varlist_merge t1 l2))
-		     else (Cons_var v2 (vm_aux t2))
-	| Nil_var => l1
-	end}
-  | Nil_var => [l2]l2
-  end.
-
-(* returns the sum of two canonical sums  *)
-Fixpoint canonical_sum_merge [s1:canonical_sum] 
-      	 : canonical_sum -> canonical_sum :=
-Cases s1 of
-| (Cons_monom c1 l1 t1) =>      
-     Fix csm_aux{csm_aux[s2:canonical_sum] : canonical_sum :=
-           Cases s2 of
-      	   | (Cons_monom c2 l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (Cons_monom (Aplus c1 c2) l1 
-      	       	       	        (canonical_sum_merge t1 t2))
-	       else if (varlist_lt l1 l2)
-	       then (Cons_monom c1 l1 (canonical_sum_merge t1 s2))
-	       else (Cons_monom c2 l2 (csm_aux t2))
-      	   | (Cons_varlist l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (Cons_monom (Aplus c1 Aone) l1 
-      	       	       	        (canonical_sum_merge t1 t2))
-	       else if (varlist_lt l1 l2)
-	       then (Cons_monom c1 l1 (canonical_sum_merge t1 s2))
-	       else (Cons_varlist l2 (csm_aux t2))
-	   | Nil_monom => s1
-	   end}
-| (Cons_varlist l1 t1) =>      
-     Fix csm_aux2{csm_aux2[s2:canonical_sum] : canonical_sum :=
-           Cases s2 of
-      	   | (Cons_monom c2 l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (Cons_monom (Aplus Aone c2) l1 
-      	       	       	        (canonical_sum_merge t1 t2))
-	       else if (varlist_lt l1 l2)
-	       then (Cons_varlist l1 (canonical_sum_merge t1 s2))
-	       else (Cons_monom c2 l2 (csm_aux2 t2))
-      	   | (Cons_varlist l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (Cons_monom (Aplus Aone Aone) l1 
-      	       	       	        (canonical_sum_merge t1 t2))
-	       else if (varlist_lt l1 l2)
-	       then (Cons_varlist l1 (canonical_sum_merge t1 s2))
-	       else (Cons_varlist l2 (csm_aux2 t2))
-	   | Nil_monom => s1
-	   end}
-| Nil_monom => [s2]s2
-end.
-
-(* Insertion of a monom in a canonical sum *)
-Fixpoint monom_insert [c1:A; l1:varlist; s2 : canonical_sum] 
-      : canonical_sum := 
-  Cases s2 of
-  | (Cons_monom c2 l2 t2) =>
-       if (varlist_eq l1 l2)
-       then (Cons_monom (Aplus c1 c2) l1 t2)
-       else if (varlist_lt l1 l2)
-       then (Cons_monom c1 l1 s2)
-       else (Cons_monom c2 l2 (monom_insert c1 l1 t2))
-  | (Cons_varlist l2 t2) =>
-       if (varlist_eq l1 l2)
-       then (Cons_monom (Aplus c1 Aone) l1 t2)
-       else if (varlist_lt l1 l2)
-       then (Cons_monom c1 l1 s2)
-       else (Cons_varlist l2 (monom_insert c1 l1 t2))
-  | Nil_monom => (Cons_monom c1 l1 Nil_monom)
-  end.
-
-Fixpoint varlist_insert [l1:varlist; s2:canonical_sum] 
-      : canonical_sum :=
-  Cases s2 of
-  | (Cons_monom c2 l2 t2) =>
-       if (varlist_eq l1 l2)
-       then (Cons_monom (Aplus Aone c2) l1 t2)
-       else if (varlist_lt l1 l2)
-       then (Cons_varlist l1 s2)
-       else (Cons_monom c2 l2 (varlist_insert l1 t2))
-  | (Cons_varlist l2 t2) =>
-       if (varlist_eq l1 l2)
-       then (Cons_monom (Aplus Aone Aone) l1 t2)
-       else if (varlist_lt l1 l2)
-       then (Cons_varlist l1 s2)
-       else (Cons_varlist l2 (varlist_insert l1 t2))
-  | Nil_monom => (Cons_varlist l1 Nil_monom)
-  end.
-
-(* Computes c0*s *)
-Fixpoint canonical_sum_scalar [c0:A; s:canonical_sum] : canonical_sum :=
-    Cases s of
-    | (Cons_monom c l t) => 
-	(Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t))
-    | (Cons_varlist l t) => 
-	(Cons_monom c0 l (canonical_sum_scalar c0 t))
-    | Nil_monom => Nil_monom
-    end.
-
-(* Computes l0*s  *)
-Fixpoint canonical_sum_scalar2 [l0:varlist; s:canonical_sum] 
-      	       	       	      : canonical_sum :=
-    Cases s of
-    | (Cons_monom c l t) => 
-      	  (monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t))
-    | (Cons_varlist l t) => 
-          (varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t))
-    | Nil_monom  => Nil_monom
-    end.
-
-(* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 [c0:A;l0:varlist; s:canonical_sum] 
-      	       	       	      : canonical_sum :=
-    Cases s of
-    | (Cons_monom c l t) => 
-          (monom_insert (Amult c0 c) (varlist_merge l0 l) 
-                        (canonical_sum_scalar3 c0 l0 t))
-    | (Cons_varlist l t) => 
-      	  (monom_insert c0 (varlist_merge l0 l) 
-                          (canonical_sum_scalar3 c0 l0 t))
-    | Nil_monom  => Nil_monom
-    end.
-
-(* returns the product of two canonical sums *) 
-Fixpoint canonical_sum_prod [s1:canonical_sum] 
-      	 : canonical_sum -> canonical_sum := 
-    [s2]Cases s1 of
-    | (Cons_monom c1 l1 t1) =>
-	(canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) 
-			     (canonical_sum_prod t1 s2))
-    | (Cons_varlist l1 t1) =>
-	(canonical_sum_merge (canonical_sum_scalar2 l1 s2) 
-			     (canonical_sum_prod t1 s2))
-    | Nil_monom => Nil_monom
-    end.
-
-(* The type to represent concrete semi-ring polynomials *)
-Inductive Type spolynomial :=
-  SPvar : index -> spolynomial
-| SPconst : A -> spolynomial
-| SPplus : spolynomial -> spolynomial -> spolynomial
-| SPmult : spolynomial -> spolynomial -> spolynomial.
-
-Fixpoint spolynomial_normalize[p:spolynomial] : canonical_sum :=
-  Cases p of
-  | (SPvar i) => (Cons_varlist (Cons_var i Nil_var) Nil_monom)
-  | (SPconst c) => (Cons_monom c Nil_var Nil_monom)
-  | (SPplus l r) => (canonical_sum_merge (spolynomial_normalize l) 
-      	       	       	       	       	 (spolynomial_normalize r))
-  | (SPmult l r) => (canonical_sum_prod (spolynomial_normalize l) 
-      	       	       	       	        (spolynomial_normalize r))
-  end.
-
-(* Deletion of useless 0 and 1 in canonical sums *)
-Fixpoint canonical_sum_simplify [ s:canonical_sum] : canonical_sum :=
-  Cases s of
-  | (Cons_monom c l t) => 
-	 if (Aeq c Azero) 
-	 then (canonical_sum_simplify t)
-	 else if (Aeq c Aone)
-	 then (Cons_varlist l (canonical_sum_simplify t))
-	 else (Cons_monom c l (canonical_sum_simplify t))
-  | (Cons_varlist l t) => (Cons_varlist l (canonical_sum_simplify t))
-  | Nil_monom => Nil_monom
-  end.
-
-Definition spolynomial_simplify :=
-  [x:spolynomial](canonical_sum_simplify (spolynomial_normalize x)).
-
-(* End definitions. *)
-
-(* Section interpretation. *)
-
-(*** Here a variable map is defined and the interpetation of a spolynom
-  acording to a certain variables map. Once again the choosen definition
-  is generic and could be changed ****)
-
-Variable vm : (varmap A).
-
-(* Interpretation of list of variables 
- * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn)
- * The unbound variables are mapped to 0. Normally this case sould
- * never occur. Since we want only to prove correctness theorems, which form
- * is : for any varmap and any spolynom ... this is a safe and pain-saving
- * choice *)
-Definition interp_var [i:index] := (varmap_find Azero i vm).
-
-(* Local *) Definition ivl_aux := Fix ivl_aux {ivl_aux[x:index; t:varlist] : A := 
-  Cases t of
-  | Nil_var => (interp_var x)
-  | (Cons_var x' t') => (Amult (interp_var x) (ivl_aux x' t'))
-  end}.
-
-Definition interp_vl :=  [l:varlist] 
-  Cases l of
-  | Nil_var => Aone
-  | (Cons_var x t) => (ivl_aux x t)
-  end.
-
-(* Local *) Definition interp_m := [c:A][l:varlist] 
-  Cases l of
-  | Nil_var => c
-  | (Cons_var x t) => 
-      (Amult c (ivl_aux x t))
-  end.
-
-(* Local *) Definition ics_aux := Fix ics_aux{ics_aux[a:A; s:canonical_sum] : A :=  
-  Cases s of
-  | Nil_monom => a
-  | (Cons_varlist l t) => (Aplus a (ics_aux (interp_vl l) t))
-  | (Cons_monom c l t) => (Aplus a (ics_aux (interp_m c l) t))
-  end}.
-
-(* Interpretation of a canonical sum *)
-Definition interp_cs : canonical_sum -> A  := 
-  [s]Cases s of 
-  | Nil_monom => Azero
-  | (Cons_varlist l t) =>
-      	(ics_aux (interp_vl l) t)
-  | (Cons_monom c l t) =>
-      	(ics_aux (interp_m c l) t)
-  end.
-
-Fixpoint interp_sp [p:spolynomial] : A :=
-  Cases p of
-    (SPconst c) => c
-  | (SPvar i) => (interp_var i)
-  | (SPplus p1 p2) => (Aplus (interp_sp p1) (interp_sp p2))
-  | (SPmult p1 p2) => (Amult (interp_sp p1) (interp_sp p2))
-  end.
-
-
-(* End interpretation. *)
-
-Unset Implicit Arguments.
-
-(* Section properties. *)
-
-Variable T : (Semi_Ring_Theory Aplus Amult Aone Azero Aeq).
-
-Hint SR_plus_sym_T := Resolve (SR_plus_sym T).
-Hint SR_plus_assoc_T := Resolve (SR_plus_assoc T).
-Hint SR_plus_assoc2_T := Resolve (SR_plus_assoc2 T).
-Hint SR_mult_sym_T := Resolve (SR_mult_sym T).
-Hint SR_mult_assoc_T := Resolve (SR_mult_assoc T).
-Hint SR_mult_assoc2_T := Resolve (SR_mult_assoc2 T).
-Hint SR_plus_zero_left_T := Resolve (SR_plus_zero_left T).
-Hint SR_plus_zero_left2_T := Resolve (SR_plus_zero_left2 T).
-Hint SR_mult_one_left_T := Resolve (SR_mult_one_left T).
-Hint SR_mult_one_left2_T := Resolve (SR_mult_one_left2 T).
-Hint SR_mult_zero_left_T := Resolve (SR_mult_zero_left T).
-Hint SR_mult_zero_left2_T := Resolve (SR_mult_zero_left2 T).
-Hint SR_distr_left_T := Resolve (SR_distr_left T).
-Hint SR_distr_left2_T := Resolve (SR_distr_left2 T).
-Hint SR_plus_reg_left_T := Resolve (SR_plus_reg_left T).
-Hint SR_plus_permute_T := Resolve (SR_plus_permute T).
-Hint SR_mult_permute_T := Resolve (SR_mult_permute T).
-Hint SR_distr_right_T := Resolve (SR_distr_right T).
-Hint SR_distr_right2_T := Resolve (SR_distr_right2 T).
-Hint SR_mult_zero_right_T := Resolve (SR_mult_zero_right T).
-Hint SR_mult_zero_right2_T := Resolve (SR_mult_zero_right2 T).
-Hint SR_plus_zero_right_T := Resolve (SR_plus_zero_right T).
-Hint SR_plus_zero_right2_T := Resolve (SR_plus_zero_right2 T).
-Hint SR_mult_one_right_T := Resolve (SR_mult_one_right T).
-Hint SR_mult_one_right2_T := Resolve (SR_mult_one_right2 T).
-Hint SR_plus_reg_right_T := Resolve (SR_plus_reg_right T).
-Hints Resolve refl_equal sym_equal trans_equal.
-(* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
-Hints Immediate T.
-
-Lemma varlist_eq_prop : (x,y:varlist)
-  (Is_true (varlist_eq x y))->x==y.
-Proof.
-  Induction x; Induction y; Contradiction Orelse Try Reflexivity.
-  Simpl; Intros.
-  Generalize (andb_prop2 ? ? H1); Intros; Elim H2; Intros.
-  Rewrite (index_eq_prop H3); Rewrite (H v0 H4); Reflexivity.
-Save.
-
-Remark ivl_aux_ok : (v:varlist)(i:index)
-  (ivl_aux i v)==(Amult (interp_var i) (interp_vl v)).
-Proof.
-  Induction v; Simpl; Intros.
-  Trivial.
-  Rewrite H; Trivial.
-Save.
-
-Lemma varlist_merge_ok : (x,y:varlist)
-  (interp_vl (varlist_merge x y))
-  ==(Amult (interp_vl x) (interp_vl y)).
-Proof.
-  Induction x.
-  Simpl; Trivial.
-  Induction y.
-  Simpl; Trivial.
-  Simpl; Intros.
-  Elim (index_lt i i0); Simpl; Intros.
-
-  Repeat Rewrite ivl_aux_ok.
-  Rewrite H. Simpl.
-  Rewrite ivl_aux_ok.
-  EAuto.
-
-  Repeat Rewrite ivl_aux_ok.
-  Rewrite H0.
-  Rewrite ivl_aux_ok.
-  EAuto.
-Save.
-
-Remark ics_aux_ok : (x:A)(s:canonical_sum)
-  (ics_aux x s)==(Aplus x (interp_cs s)).
-Proof.
-  Induction s; Simpl; Intros.
-  Trivial.
-  Reflexivity.
-  Reflexivity.
-Save.
-
-Remark interp_m_ok : (x:A)(l:varlist)
-  (interp_m x l)==(Amult x (interp_vl l)).
-Proof.
-  NewDestruct l.
-  Simpl; Trivial.
-  Reflexivity.
-Save.
-
-Lemma canonical_sum_merge_ok : (x,y:canonical_sum)
-  (interp_cs (canonical_sum_merge x y))
-  ==(Aplus (interp_cs x) (interp_cs y)).
-
-Induction x; Simpl.
-Trivial.
-
-Induction y; Simpl; Intros.
-(* monom and nil *)
-EAuto.
-
-(* monom and monom *)
-Generalize (varlist_eq_prop v v0).
-Elim (varlist_eq v v0).
-Intros; Rewrite (H1 I).
-Simpl; Repeat Rewrite ics_aux_ok; Rewrite H.
-Repeat Rewrite interp_m_ok.
-Rewrite (SR_distr_left T).
-Repeat Rewrite <- (SR_plus_assoc T).
-Apply congr_eqT with f:=(Aplus (Amult a (interp_vl v0))).
-Trivial.
-
-Elim (varlist_lt v v0); Simpl.
-Repeat Rewrite ics_aux_ok.
-Rewrite H; Simpl; Rewrite ics_aux_ok; EAuto.
-
-Rewrite ics_aux_ok; Rewrite H0; Repeat Rewrite ics_aux_ok; Simpl; EAuto.
-
-(* monom and varlist *)
-Generalize (varlist_eq_prop v v0).
-Elim (varlist_eq v v0).
-Intros; Rewrite (H1 I).
-Simpl; Repeat Rewrite ics_aux_ok; Rewrite H.
-Repeat Rewrite interp_m_ok.
-Rewrite (SR_distr_left T).
-Repeat Rewrite <- (SR_plus_assoc T).
-Apply congr_eqT with f:=(Aplus (Amult a (interp_vl v0))).
-Rewrite (SR_mult_one_left T).
-Trivial.
-
-Elim (varlist_lt v v0); Simpl.
-Repeat Rewrite ics_aux_ok.
-Rewrite H; Simpl; Rewrite ics_aux_ok; EAuto.
-Rewrite ics_aux_ok; Rewrite H0; Repeat Rewrite ics_aux_ok; Simpl; EAuto.
-
-Induction y; Simpl; Intros.
-(* varlist and nil *)
-Trivial.
-
-(* varlist and monom *)
-Generalize (varlist_eq_prop v v0).
-Elim (varlist_eq v v0).
-Intros; Rewrite (H1 I).
-Simpl; Repeat Rewrite ics_aux_ok; Rewrite H.
-Repeat Rewrite interp_m_ok.
-Rewrite (SR_distr_left T).
-Repeat Rewrite <- (SR_plus_assoc T).
-Rewrite (SR_mult_one_left T).
-Apply congr_eqT with f:=(Aplus (interp_vl v0)).
-Trivial.
-
-Elim (varlist_lt v v0); Simpl.
-Repeat Rewrite ics_aux_ok.
-Rewrite H; Simpl; Rewrite ics_aux_ok; EAuto.
-Rewrite ics_aux_ok; Rewrite H0; Repeat Rewrite ics_aux_ok; Simpl; EAuto.
-
-(* varlist and varlist *)
-Generalize (varlist_eq_prop v v0).
-Elim (varlist_eq v v0).
-Intros; Rewrite (H1 I).
-Simpl; Repeat Rewrite ics_aux_ok; Rewrite H.
-Repeat Rewrite interp_m_ok.
-Rewrite (SR_distr_left T).
-Repeat Rewrite <- (SR_plus_assoc T).
-Rewrite (SR_mult_one_left T).
-Apply congr_eqT with f:=(Aplus (interp_vl v0)).
-Trivial.
-
-Elim (varlist_lt v v0); Simpl.
-Repeat Rewrite ics_aux_ok.
-Rewrite H; Simpl; Rewrite ics_aux_ok; EAuto.
-Rewrite ics_aux_ok; Rewrite H0; Repeat Rewrite ics_aux_ok; Simpl; EAuto.
-Save.
-
-Lemma monom_insert_ok: (a:A)(l:varlist)(s:canonical_sum)
-  (interp_cs (monom_insert a l s)) 
-  == (Aplus (Amult a (interp_vl l)) (interp_cs s)).
-Intros; Generalize s; Induction s0.
-
-Simpl; Rewrite interp_m_ok; Trivial.
-
-Simpl; Intros.
-Generalize (varlist_eq_prop  l v); Elim (varlist_eq l v).
-Intro Hr; Rewrite (Hr I); Simpl; Rewrite interp_m_ok; 
-  Repeat Rewrite ics_aux_ok; Rewrite interp_m_ok;
-  Rewrite (SR_distr_left T); EAuto.
-Elim (varlist_lt l v); Simpl; 
-[ Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok; EAuto
-| Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok;
-  Rewrite H; Rewrite ics_aux_ok; EAuto].
-
-Simpl; Intros.
-Generalize (varlist_eq_prop  l v); Elim (varlist_eq l v).
-Intro Hr; Rewrite (Hr I); Simpl;  Rewrite interp_m_ok; 
-  Repeat Rewrite ics_aux_ok; 
-  Rewrite (SR_distr_left T); Rewrite (SR_mult_one_left T); EAuto.
-Elim (varlist_lt l v); Simpl; 
-[ Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok; EAuto
-| Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok;
-  Rewrite H; Rewrite ics_aux_ok; EAuto].
-Save.
-
-Lemma varlist_insert_ok :
- (l:varlist)(s:canonical_sum)
-  (interp_cs (varlist_insert l s)) 
-  == (Aplus (interp_vl l) (interp_cs s)).
-Intros; Generalize s; Induction s0.
-
-Simpl; Trivial.
-
-Simpl; Intros.
-Generalize (varlist_eq_prop  l v); Elim (varlist_eq l v).
-Intro Hr; Rewrite (Hr I); Simpl; Rewrite interp_m_ok; 
-  Repeat Rewrite ics_aux_ok; Rewrite interp_m_ok;
-  Rewrite (SR_distr_left T); Rewrite (SR_mult_one_left T); EAuto.
-Elim (varlist_lt l v); Simpl; 
-[ Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok; EAuto
-| Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok;
-  Rewrite H; Rewrite ics_aux_ok; EAuto].
-
-Simpl; Intros.
-Generalize (varlist_eq_prop  l v); Elim (varlist_eq l v).
-Intro Hr; Rewrite (Hr I); Simpl;  Rewrite interp_m_ok; 
-  Repeat Rewrite ics_aux_ok; 
-  Rewrite (SR_distr_left T); Rewrite (SR_mult_one_left T); EAuto.
-Elim (varlist_lt l v); Simpl; 
-[ Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok; EAuto
-| Repeat Rewrite interp_m_ok; Rewrite ics_aux_ok;
-  Rewrite H; Rewrite ics_aux_ok; EAuto].
-Save.
-
-Lemma canonical_sum_scalar_ok : (a:A)(s:canonical_sum)
-  (interp_cs (canonical_sum_scalar a s))
-  ==(Amult a (interp_cs s)).
-Induction s.
-Simpl; EAuto.
-
-Simpl; Intros.
-Repeat Rewrite ics_aux_ok.
-Repeat Rewrite interp_m_ok.
-Rewrite H.
-Rewrite (SR_distr_right T).
-Repeat Rewrite <- (SR_mult_assoc T).
-Reflexivity.
-
-Simpl; Intros.
-Repeat Rewrite ics_aux_ok.
-Repeat Rewrite interp_m_ok.
-Rewrite H.
-Rewrite (SR_distr_right T).
-Repeat Rewrite <- (SR_mult_assoc T).
-Reflexivity.
-Save.
-
-Lemma canonical_sum_scalar2_ok : (l:varlist; s:canonical_sum)
-  (interp_cs (canonical_sum_scalar2 l s))
-   ==(Amult (interp_vl l) (interp_cs s)).
-Induction s.
-Simpl; Trivial.
-
-Simpl; Intros.
-Rewrite monom_insert_ok.
-Repeat Rewrite ics_aux_ok.
-Repeat Rewrite interp_m_ok.
-Rewrite H.
-Rewrite varlist_merge_ok.
-Repeat Rewrite (SR_distr_right T). 
-Repeat Rewrite <- (SR_mult_assoc T).
-Repeat Rewrite <- (SR_plus_assoc T).
-Rewrite (SR_mult_permute T  a (interp_vl l) (interp_vl v)).
-Reflexivity.
-
-Simpl; Intros.
-Rewrite varlist_insert_ok.
-Repeat Rewrite ics_aux_ok.
-Repeat Rewrite interp_m_ok.
-Rewrite H.
-Rewrite varlist_merge_ok.
-Repeat Rewrite (SR_distr_right T). 
-Repeat Rewrite <- (SR_mult_assoc T).
-Repeat Rewrite <- (SR_plus_assoc T).
-Reflexivity.
-Save.
-
-Lemma canonical_sum_scalar3_ok : (c:A; l:varlist; s:canonical_sum)
-  (interp_cs (canonical_sum_scalar3 c l s))
-   ==(Amult c (Amult (interp_vl l) (interp_cs s))).
-Induction s.
-Simpl; Repeat Rewrite (SR_mult_zero_right T); Reflexivity.
-
-Simpl; Intros.
-Rewrite monom_insert_ok.
-Repeat Rewrite ics_aux_ok.
-Repeat Rewrite interp_m_ok.
-Rewrite H.
-Rewrite varlist_merge_ok.
-Repeat Rewrite (SR_distr_right T). 
-Repeat Rewrite <- (SR_mult_assoc T).
-Repeat Rewrite <- (SR_plus_assoc T).
-Rewrite (SR_mult_permute T  a (interp_vl l) (interp_vl v)).
-Reflexivity.
-
-Simpl; Intros.
-Rewrite monom_insert_ok.
-Repeat Rewrite ics_aux_ok.
-Repeat Rewrite interp_m_ok.
-Rewrite H.
-Rewrite varlist_merge_ok.
-Repeat Rewrite (SR_distr_right T). 
-Repeat Rewrite <- (SR_mult_assoc T).
-Repeat Rewrite <- (SR_plus_assoc T).
-Rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)).
-Reflexivity.
-Save.
-
-Lemma canonical_sum_prod_ok : (x,y:canonical_sum)
-  (interp_cs (canonical_sum_prod x y))
-  ==(Amult (interp_cs x) (interp_cs y)).
-Induction x; Simpl; Intros.
-Trivial.
-
-Rewrite canonical_sum_merge_ok.
-Rewrite canonical_sum_scalar3_ok.
-Rewrite ics_aux_ok.
-Rewrite interp_m_ok.
-Rewrite H.
-Rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)).
-Symmetry.
-EAuto.
-
-Rewrite canonical_sum_merge_ok.
-Rewrite canonical_sum_scalar2_ok.
-Rewrite ics_aux_ok.
-Rewrite H.
-Trivial.
-Save.
-
-Theorem spolynomial_normalize_ok : (p:spolynomial)
-  (interp_cs (spolynomial_normalize p)) == (interp_sp p).
-Induction p; Simpl; Intros.
-
-Reflexivity.
-Reflexivity.
-
-Rewrite canonical_sum_merge_ok.
-Rewrite H; Rewrite H0.
-Reflexivity.
-
-Rewrite canonical_sum_prod_ok.
-Rewrite H; Rewrite H0.
-Reflexivity.
-Save.
-
-Lemma canonical_sum_simplify_ok : (s:canonical_sum)
-  (interp_cs (canonical_sum_simplify s)) == (interp_cs s).
-Induction s.
-
-Reflexivity.
-
-(* cons_monom *)
-Simpl; Intros.
-Generalize (SR_eq_prop T 8!a 9!Azero).
-Elim (Aeq a Azero).
-Intro Heq; Rewrite (Heq I).
-Rewrite H.
-Rewrite ics_aux_ok.
-Rewrite interp_m_ok.
-Rewrite (SR_mult_zero_left T).
-Trivial.
-
-Intros; Simpl.
-Generalize (SR_eq_prop T 8!a 9!Aone).
-Elim (Aeq a Aone).
-Intro Heq; Rewrite (Heq I).
-Simpl.
-Repeat Rewrite ics_aux_ok.
-Rewrite interp_m_ok.
-Rewrite H.
-Rewrite (SR_mult_one_left T).
-Reflexivity.
-
-Simpl.
-Repeat Rewrite ics_aux_ok.
-Rewrite interp_m_ok.
-Rewrite H.
-Reflexivity.
-
-(* cons_varlist *)
-Simpl; Intros.
-Repeat Rewrite ics_aux_ok.
-Rewrite H.
-Reflexivity.
-
-Save.
-
-Theorem spolynomial_simplify_ok : (p:spolynomial)
-  (interp_cs (spolynomial_simplify p)) == (interp_sp p).
-Intro.
-Unfold spolynomial_simplify.
-Rewrite canonical_sum_simplify_ok.
-Apply spolynomial_normalize_ok.
-Save.
-
-(* End properties. *)
-End semi_rings.
-
-Implicits Cons_varlist.
-Implicits Cons_monom.
-Implicits SPconst.
-Implicits SPplus.
-Implicits SPmult.
-
-Section rings.
-
-(* Here the coercion between Ring and Semi-Ring will be useful *)
-
-Set Implicit Arguments.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable vm : (varmap A).
-Variable T : (Ring_Theory Aplus Amult Aone Azero Aopp Aeq).
-
-Hint Th_plus_sym_T := Resolve (Th_plus_sym T).
-Hint Th_plus_assoc_T := Resolve (Th_plus_assoc T).
-Hint Th_plus_assoc2_T := Resolve (Th_plus_assoc2 T).
-Hint Th_mult_sym_T := Resolve (Th_mult_sym T).
-Hint Th_mult_assoc_T := Resolve (Th_mult_assoc T).
-Hint Th_mult_assoc2_T := Resolve (Th_mult_assoc2 T).
-Hint Th_plus_zero_left_T := Resolve (Th_plus_zero_left T).
-Hint Th_plus_zero_left2_T := Resolve (Th_plus_zero_left2 T).
-Hint Th_mult_one_left_T := Resolve (Th_mult_one_left T).
-Hint Th_mult_one_left2_T := Resolve (Th_mult_one_left2 T).
-Hint Th_mult_zero_left_T := Resolve (Th_mult_zero_left T).
-Hint Th_mult_zero_left2_T := Resolve (Th_mult_zero_left2 T).
-Hint Th_distr_left_T := Resolve (Th_distr_left T).
-Hint Th_distr_left2_T := Resolve (Th_distr_left2 T).
-Hint Th_plus_reg_left_T := Resolve (Th_plus_reg_left T).
-Hint Th_plus_permute_T := Resolve (Th_plus_permute T).
-Hint Th_mult_permute_T := Resolve (Th_mult_permute T).
-Hint Th_distr_right_T := Resolve (Th_distr_right T).
-Hint Th_distr_right2_T := Resolve (Th_distr_right2 T).
-Hint Th_mult_zero_right_T := Resolve (Th_mult_zero_right T).
-Hint Th_mult_zero_right2_T := Resolve (Th_mult_zero_right2 T).
-Hint Th_plus_zero_right_T := Resolve (Th_plus_zero_right T).
-Hint Th_plus_zero_right2_T := Resolve (Th_plus_zero_right2 T).
-Hint Th_mult_one_right_T := Resolve (Th_mult_one_right T).
-Hint Th_mult_one_right2_T := Resolve (Th_mult_one_right2 T).
-Hint Th_plus_reg_right_T := Resolve (Th_plus_reg_right T).
-Hints Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hints Immediate T.
-
-(*** Definitions *)
-
-Inductive Type polynomial := 
-  Pvar : index -> polynomial
-| Pconst : A -> polynomial
-| Pplus : polynomial -> polynomial -> polynomial
-| Pmult : polynomial -> polynomial -> polynomial
-| Popp : polynomial -> polynomial.
-
-Fixpoint polynomial_normalize [x:polynomial] : (canonical_sum A) :=
-  Cases x of
-    (Pplus l r) => (canonical_sum_merge Aplus Aone
-      	       	       	       	(polynomial_normalize l) 
-                                (polynomial_normalize r))
-  | (Pmult l r) => (canonical_sum_prod Aplus Amult Aone 
-      	       	       	       	(polynomial_normalize l)
-                                (polynomial_normalize r))
-  | (Pconst c)  => (Cons_monom c Nil_var (Nil_monom A))
-  | (Pvar i)    => (Cons_varlist (Cons_var i Nil_var) (Nil_monom A))
-  | (Popp p)    => (canonical_sum_scalar3 Aplus Amult Aone
-                                     (Aopp Aone) Nil_var
-                                     (polynomial_normalize p))
-  end.
-
-Definition polynomial_simplify :=
-  [x:polynomial](canonical_sum_simplify Aone Azero Aeq 
-      	       	       	(polynomial_normalize x)).
-
-Fixpoint spolynomial_of [x:polynomial] : (spolynomial A) :=
-  Cases x of 
-    (Pplus l r) => (SPplus (spolynomial_of l) (spolynomial_of r))
-  | (Pmult l r) => (SPmult (spolynomial_of l) (spolynomial_of r))
-  | (Pconst c)  => (SPconst c)
-  | (Pvar i)    => (SPvar A i)
-  | (Popp p)    => (SPmult (SPconst (Aopp Aone)) (spolynomial_of p))
-  end.
-
-(*** Interpretation *)
-
-Fixpoint interp_p [p:polynomial] : A :=
-  Cases p of
-    (Pconst c)    => c
-  | (Pvar i)      => (varmap_find Azero i vm)
-  | (Pplus p1 p2) => (Aplus (interp_p p1) (interp_p p2))
-  | (Pmult p1 p2) => (Amult (interp_p p1) (interp_p p2))
-  | (Popp p1)     => (Aopp (interp_p p1))
-  end.
-
-(*** Properties *)
-
-Unset Implicit Arguments.
-
-Lemma spolynomial_of_ok : (p:polynomial)
-  (interp_p p)==(interp_sp Aplus Amult Azero vm (spolynomial_of p)).
-Induction p; Reflexivity Orelse (Simpl; Intros).
-Rewrite H; Rewrite H0; Reflexivity.
-Rewrite H; Rewrite H0; Reflexivity.
-Rewrite H.
-Rewrite (Th_opp_mult_left2 T).
-Rewrite (Th_mult_one_left T).
-Reflexivity.
-Save.
-
-Theorem polynomial_normalize_ok : (p:polynomial)
-  (polynomial_normalize p)
-  ==(spolynomial_normalize Aplus Amult Aone (spolynomial_of p)).
-Induction p; Reflexivity Orelse (Simpl; Intros).
-Rewrite H; Rewrite H0; Reflexivity.
-Rewrite H; Rewrite H0; Reflexivity.
-Rewrite H; Simpl.
-Elim (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
-     (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
-[ Reflexivity
-| Simpl; Intros; Rewrite H0; Reflexivity
-| Simpl; Intros; Rewrite H0; Reflexivity ].
-Save.
-
-Theorem polynomial_simplify_ok : (p:polynomial)
-  (interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p))
-  ==(interp_p p).
-Intro.
-Unfold polynomial_simplify.
-Rewrite spolynomial_of_ok.
-Rewrite polynomial_normalize_ok.
-Rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T).
-Rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T).
-Reflexivity.
-Save.
-
-End rings.
-
-V8Infix "+" Pplus : ring_scope.
-V8Infix "*" Pmult : ring_scope.
-V8Notation "- x" := (Popp x) : ring_scope.
-V8Notation "[ x ]" := (Pvar x) (at level 1) : ring_scope.
-
-Delimits Scope ring_scope with ring.
diff --git a/contrib7/ring/Ring_theory.v b/contrib7/ring/Ring_theory.v
deleted file mode 100644
index 85fb7f6c..00000000
--- a/contrib7/ring/Ring_theory.v
+++ /dev/null
@@ -1,384 +0,0 @@
-(************************************************************************)
-(*  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: Ring_theory.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
-
-Require Export Bool.
-
-Set Implicit Arguments.
-
-Section Theory_of_semi_rings.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-(* There is also a "weakly decidable" equality on A. That means 
-  that if (A_eq x y)=true then x=y but x=y can arise when 
-  (A_eq x y)=false. On an abstract ring the function [x,y:A]false
-  is a good choice. The proof of A_eq_prop is in this case easy. *)
-Variable Aeq : A -> A -> bool.
-
-Infix 4 "+" Aplus V8only 50 (left associativity).
-Infix 4 "*" Amult V8only 40 (left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-
-Record Semi_Ring_Theory : Prop :=
-{ SR_plus_sym  : (n,m:A) n + m == m + n;
-  SR_plus_assoc : (n,m,p:A) n + (m + p) == (n + m) + p;
-  SR_mult_sym : (n,m:A) n*m == m*n;
-  SR_mult_assoc : (n,m,p:A) n*(m*p) == (n*m)*p;
-  SR_plus_zero_left :(n:A) 0 + n == n;
-  SR_mult_one_left : (n:A) 1*n == n;
-  SR_mult_zero_left : (n:A) 0*n == 0;
-  SR_distr_left   : (n,m,p:A) (n + m)*p == n*p + m*p;
-  SR_plus_reg_left : (n,m,p:A) n + m == n + p -> m==p;
-  SR_eq_prop : (x,y:A) (Is_true (Aeq x y)) -> x==y
-}.
-
-Variable T : Semi_Ring_Theory.
-
-Local plus_sym  := (SR_plus_sym T).
-Local plus_assoc := (SR_plus_assoc T).
-Local mult_sym  := ( SR_mult_sym T).
-Local mult_assoc := (SR_mult_assoc T).
-Local plus_zero_left := (SR_plus_zero_left T).
-Local mult_one_left := (SR_mult_one_left T). 
-Local mult_zero_left := (SR_mult_zero_left T).
-Local distr_left := (SR_distr_left T).
-Local plus_reg_left := (SR_plus_reg_left T).
-
-Hints Resolve  plus_sym plus_assoc mult_sym mult_assoc
-  plus_zero_left mult_one_left mult_zero_left distr_left
-  plus_reg_left.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *) 
-Lemma SR_mult_assoc2 : (n,m,p:A) (n * m) * p == n * (m * p).
-Symmetry; EAuto. Qed.
-
-Lemma SR_plus_assoc2 : (n,m,p:A) (n + m) + p == n + (m + p).
-Symmetry; EAuto. Qed.
-
-Lemma SR_plus_zero_left2 : (n:A) n == 0 + n.
-Symmetry; EAuto. Qed.
-
-Lemma SR_mult_one_left2 : (n:A) n == 1*n.
-Symmetry; EAuto. Qed.
-
-Lemma SR_mult_zero_left2 : (n:A) 0 == 0*n.
-Symmetry; EAuto. Qed.
-
-Lemma SR_distr_left2 : (n,m,p:A) n*p + m*p  == (n + m)*p.
-Symmetry; EAuto. Qed.
-
-Lemma SR_plus_permute : (n,m,p:A) n + (m + p) == m + (n + p).
-Intros.
-Rewrite -> plus_assoc.
-Elim (plus_sym m n).
-Rewrite <- plus_assoc.
-Reflexivity.
-Qed.
-
-Lemma SR_mult_permute : (n,m,p:A) n*(m*p) == m*(n*p).
-Intros.
-Rewrite -> mult_assoc.
-Elim (mult_sym m n).
-Rewrite <- mult_assoc.
-Reflexivity.
-Qed.
-
-Hints Resolve SR_plus_permute SR_mult_permute.
-
-Lemma SR_distr_right : (n,m,p:A) n*(m + p) == (n*m) + (n*p).
-Intros.
-Repeat Rewrite -> (mult_sym n).
-EAuto.
-Qed.
-
-Lemma SR_distr_right2 : (n,m,p:A) (n*m) + (n*p) == n*(m + p).
-Symmetry; Apply SR_distr_right. Qed.
-
-Lemma SR_mult_zero_right : (n:A) n*0 == 0.
-Intro; Rewrite mult_sym; EAuto.
-Qed.
-
-Lemma SR_mult_zero_right2 : (n:A) 0 == n*0.
-Intro; Rewrite mult_sym; EAuto.
-Qed.
-
-Lemma SR_plus_zero_right :(n:A) n + 0 == n.
-Intro; Rewrite plus_sym; EAuto.
-Qed.
-Lemma SR_plus_zero_right2 :(n:A) n == n + 0.
-Intro; Rewrite plus_sym; EAuto.
-Qed.
-
-Lemma SR_mult_one_right : (n:A) n*1 == n.
-Intro; Elim mult_sym; Auto.
-Qed.
-
-Lemma SR_mult_one_right2 : (n:A) n == n*1.
-Intro; Elim mult_sym; Auto.
-Qed.
-
-Lemma SR_plus_reg_right : (n,m,p:A) m + n == p + n -> m==p.
-Intros n m p; Rewrite (plus_sym m n); Rewrite (plus_sym p n); EAuto.
-Qed.
-
-End Theory_of_semi_rings.
-
-Section Theory_of_rings.
-
-Variable A : Type.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Infix 4 "+" Aplus V8only 50 (left associativity).
-Infix 4 "*" Amult V8only 40 (left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-Notation "- x" := (Aopp x) (at level 0) V8only.
-
-Record Ring_Theory : Prop :=
-{ Th_plus_sym  : (n,m:A) n + m == m + n;
-  Th_plus_assoc : (n,m,p:A) n + (m + p) == (n + m) + p;
-  Th_mult_sym : (n,m:A) n*m == m*n;
-  Th_mult_assoc : (n,m,p:A) n*(m*p) == (n*m)*p;
-  Th_plus_zero_left :(n:A) 0 + n == n;
-  Th_mult_one_left : (n:A) 1*n == n;
-  Th_opp_def : (n:A) n + (-n) == 0;
-  Th_distr_left : (n,m,p:A) (n + m)*p == n*p + m*p;
-  Th_eq_prop : (x,y:A) (Is_true (Aeq x y)) -> x==y
-}.
-
-Variable T : Ring_Theory.
-
-Local plus_sym  := (Th_plus_sym T).
-Local plus_assoc := (Th_plus_assoc T).
-Local mult_sym  := ( Th_mult_sym T).
-Local mult_assoc := (Th_mult_assoc T).
-Local plus_zero_left := (Th_plus_zero_left T).
-Local mult_one_left := (Th_mult_one_left T). 
-Local opp_def := (Th_opp_def T).
-Local distr_left := (Th_distr_left T).
-
-Hints Resolve plus_sym plus_assoc mult_sym mult_assoc
-  plus_zero_left mult_one_left opp_def distr_left.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *) 
-Lemma Th_mult_assoc2 : (n,m,p:A) (n * m) * p == n * (m * p).
-Symmetry; EAuto. Qed.
-
-Lemma Th_plus_assoc2 : (n,m,p:A) (n + m) + p == n + (m + p).
-Symmetry; EAuto. Qed.
-
-Lemma Th_plus_zero_left2 : (n:A) n == 0 + n.
-Symmetry; EAuto. Qed.
-
-Lemma Th_mult_one_left2 : (n:A) n == 1*n.
-Symmetry; EAuto. Qed.
-
-Lemma Th_distr_left2 : (n,m,p:A) n*p + m*p  == (n + m)*p.
-Symmetry; EAuto. Qed.
-
-Lemma Th_opp_def2 : (n:A) 0 == n + (-n).
-Symmetry; EAuto. Qed.
-
-Lemma Th_plus_permute : (n,m,p:A) n + (m + p) == m + (n + p).
-Intros.
-Rewrite -> plus_assoc.
-Elim (plus_sym m n).
-Rewrite <- plus_assoc.
-Reflexivity.
-Qed.
-
-Lemma Th_mult_permute : (n,m,p:A) n*(m*p) == m*(n*p).
-Intros.
-Rewrite -> mult_assoc.
-Elim (mult_sym m n).
-Rewrite <- mult_assoc.
-Reflexivity.
-Qed.
-
-Hints Resolve Th_plus_permute Th_mult_permute.
-
-Lemma aux1 : (a:A) a + a == a -> a == 0.
-Intros.
-Generalize (opp_def a).
-Pattern 1 a.
-Rewrite <- H.
-Rewrite <- plus_assoc.
-Rewrite -> opp_def.
-Elim plus_sym.
-Rewrite plus_zero_left.
-Trivial.
-Qed.
-
-Lemma Th_mult_zero_left :(n:A) 0*n == 0.
-Intros.
-Apply aux1.
-Rewrite <- distr_left.
-Rewrite plus_zero_left.
-Reflexivity.
-Qed.
-Hints Resolve Th_mult_zero_left.
-
-Lemma Th_mult_zero_left2 : (n:A) 0 == 0*n.
-Symmetry; EAuto. Qed.
-
-Lemma aux2 : (x,y,z:A) x+y==0 -> x+z==0 -> y==z.
-Intros.
-Rewrite <- (plus_zero_left y).
-Elim H0.
-Elim plus_assoc.
-Elim (plus_sym y z).
-Rewrite -> plus_assoc.
-Rewrite -> H.
-Rewrite plus_zero_left.
-Reflexivity.
-Qed.
-
-Lemma Th_opp_mult_left : (x,y:A) -(x*y) == (-x)*y.
-Intros.
-Apply (aux2 1!x*y);
-[ Apply opp_def
-| Rewrite <- distr_left;
-  Rewrite -> opp_def;
-  Auto].
-Qed.
-Hints Resolve Th_opp_mult_left.
-
-Lemma Th_opp_mult_left2 : (x,y:A) (-x)*y == -(x*y).
-Symmetry; EAuto. Qed.
-
-Lemma Th_mult_zero_right : (n:A) n*0 == 0.
-Intro; Elim mult_sym; EAuto.
-Qed.
-
-Lemma Th_mult_zero_right2 : (n:A) 0 == n*0.
-Intro; Elim mult_sym; EAuto.
-Qed.
-
-Lemma Th_plus_zero_right :(n:A) n + 0 == n.
-Intro; Rewrite plus_sym; EAuto.
-Qed.
-
-Lemma Th_plus_zero_right2 :(n:A) n == n + 0.
-Intro; Rewrite plus_sym; EAuto.
-Qed.
-
-Lemma Th_mult_one_right : (n:A) n*1 == n.
-Intro;Elim mult_sym; EAuto.
-Qed.
-
-Lemma Th_mult_one_right2  : (n:A) n == n*1.
-Intro;Elim mult_sym; EAuto.
-Qed.
-
-Lemma Th_opp_mult_right : (x,y:A) -(x*y) == x*(-y).
-Intros; Do 2 Rewrite -> (mult_sym x); Auto.
-Qed.
-
-Lemma Th_opp_mult_right2 : (x,y:A) x*(-y) == -(x*y).
-Intros; Do 2 Rewrite -> (mult_sym x); Auto.
-Qed.
-
-Lemma Th_plus_opp_opp : (x,y:A) (-x) + (-y) == -(x+y).
-Intros.
-Apply (aux2 1! x + y);
-[ Elim plus_assoc;
-  Rewrite -> (Th_plus_permute y (-x)); Rewrite -> plus_assoc;
-  Rewrite -> opp_def;  Rewrite plus_zero_left; Auto
-| Auto ].
-Qed.
-
-Lemma Th_plus_permute_opp: (n,m,p:A) (-m)+(n+p) == n+((-m)+p).
-EAuto. Qed.
-
-Lemma Th_opp_opp : (n:A) -(-n) == n.
-Intro; Apply (aux2 1! -n); 
-  [ Auto | Elim plus_sym; Auto ].
-Qed.
-Hints Resolve Th_opp_opp.
-
-Lemma Th_opp_opp2 : (n:A) n == -(-n).
-Symmetry; EAuto. Qed.
-
-Lemma Th_mult_opp_opp : (x,y:A) (-x)*(-y) == x*y.
-Intros; Rewrite <- Th_opp_mult_left; Rewrite <- Th_opp_mult_right; Auto.
-Qed.
-
-Lemma Th_mult_opp_opp2 : (x,y:A) x*y == (-x)*(-y).
-Symmetry; Apply Th_mult_opp_opp. Qed.
-
-Lemma Th_opp_zero : -0 == 0.
-Rewrite <- (plus_zero_left (-0)).
-Auto. Qed.
-
-Lemma Th_plus_reg_left : (n,m,p:A) n + m == n + p -> m==p.
-Intros; Generalize (congr_eqT ? ? [z] (-n)+z ? ? H).
-Repeat Rewrite plus_assoc.
-Rewrite (plus_sym (-n) n).
-Rewrite opp_def.
-Repeat Rewrite Th_plus_zero_left; EAuto.
-Qed.
-
-Lemma Th_plus_reg_right : (n,m,p:A) m + n == p + n -> m==p.
-Intros.
-EApply Th_plus_reg_left with n. 
-Rewrite (plus_sym n m).
-Rewrite (plus_sym n p).
-Auto.
-Qed.
-
-Lemma Th_distr_right : (n,m,p:A)  n*(m + p) == (n*m) + (n*p).
-Intros.
-Repeat Rewrite -> (mult_sym n).
-EAuto.
-Qed.
-
-Lemma Th_distr_right2  : (n,m,p:A) (n*m) + (n*p) == n*(m + p).
-Symmetry; Apply Th_distr_right.
-Qed.
-
-End Theory_of_rings.
-
-Hints Resolve Th_mult_zero_left Th_plus_reg_left : core.
-
-Unset Implicit Arguments.
-
-Definition Semi_Ring_Theory_of :
-  (A:Type)(Aplus : A -> A -> A)(Amult : A -> A -> A)(Aone : A)
-  (Azero : A)(Aopp : A -> A)(Aeq : A -> A -> bool)
-  (Ring_Theory Aplus Amult Aone Azero Aopp Aeq)
-    ->(Semi_Ring_Theory Aplus Amult Aone Azero Aeq).
-Intros until 1; Case H.
-Split; Intros; Simpl; EAuto.
-Defined.
-
-(* Every ring can be viewed as a semi-ring : this property will be used
-  in Abstract_polynom. *)
-Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory.
-
-
-Section product_ring.
-
-End product_ring.
-
-Section power_ring.
-
-End power_ring.
diff --git a/contrib7/ring/Setoid_ring_normalize.v b/contrib7/ring/Setoid_ring_normalize.v
deleted file mode 100644
index b6b79dae..00000000
--- a/contrib7/ring/Setoid_ring_normalize.v
+++ /dev/null
@@ -1,1141 +0,0 @@
-(************************************************************************)
-(*  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_ring_normalize.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
-
-Require Setoid_ring_theory.
-Require Quote.
-
-Set Implicit Arguments.
-
-Lemma index_eq_prop: (n,m:index)(Is_true (index_eq n m)) -> n=m.
-Proof.
-  Induction n; Induction m; Simpl; Try (Reflexivity Orelse Contradiction).
-  Intros; Rewrite (H i0); Trivial.
-  Intros; Rewrite (H i0); Trivial.
-Save.
-
-Section setoid.
-
-Variable A : Type.
-Variable Aequiv : A -> A -> Prop.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Variable S : (Setoid_Theory A Aequiv).
-
-Add Setoid A Aequiv S.
-
-Variable plus_morph : (a,a0,a1,a2:A)
- (Aequiv a a0)->(Aequiv a1 a2)->(Aequiv (Aplus a a1) (Aplus a0 a2)).
-Variable mult_morph : (a,a0,a1,a2:A)
- (Aequiv a a0)->(Aequiv a1 a2)->(Aequiv (Amult a a1) (Amult a0 a2)).
-Variable opp_morph : (a,a0:A)
- (Aequiv a a0)->(Aequiv (Aopp a) (Aopp a0)).
-
-Add Morphism Aplus : Aplus_ext.
-Exact plus_morph.
-Save.
-
-Add Morphism Amult : Amult_ext.
-Exact mult_morph.
-Save.
-
-Add Morphism Aopp : Aopp_ext.
-Exact opp_morph.
-Save.
-
-Local equiv_refl := (Seq_refl A Aequiv S).
-Local equiv_sym := (Seq_sym A Aequiv S).
-Local equiv_trans := (Seq_trans A Aequiv S).
-
-Hints Resolve equiv_refl equiv_trans.
-Hints Immediate equiv_sym.
-
-Section semi_setoid_rings.
-
-(* Section definitions. *)
-
-
-(******************************************)
-(* Normal abtract Polynomials             *)
-(******************************************)
-(* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z 
-- A monom is a constant, a varlist or the product of a constant by a varlist
-  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms 
-  (the order on monoms is defined later) 
-- A normal polynomial it either a constant or a canonical sum or a constant
-  plus a canonical sum
-*)
-
-(* varlist is isomorphic to (list var), but we built a special inductive
-   for efficiency *)
-Inductive varlist : Type := 
-| Nil_var : varlist
-| Cons_var : index -> varlist -> varlist
-.
-
-Inductive canonical_sum : Type := 
-| Nil_monom : canonical_sum
-| Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
-| Cons_varlist : varlist -> canonical_sum -> canonical_sum 
-.
-
-(* Order on monoms *)
-
-(* That's the lexicographic order on varlist, extended by : 
-  - A constant is less than every monom 
-  - The relation between two varlist is preserved by multiplication by a
-  constant.
-
-  Examples : 
-  3 < x < y
-  x*y < x*y*y*z 
-  2*x*y < x*y*y*z
-  x*y < 54*x*y*y*z
-  4*x*y < 59*x*y*y*z
-*)
-
-Fixpoint varlist_eq [x,y:varlist] : bool :=
-  Cases x y of
-  | Nil_var Nil_var => true
-  | (Cons_var i xrest) (Cons_var j yrest) => 
-        (andb (index_eq i j) (varlist_eq xrest yrest))
-  | _ _ => false
-  end.
-
-Fixpoint varlist_lt [x,y:varlist] : bool :=
-  Cases x y of 
-  | Nil_var (Cons_var _ _) => true
-  | (Cons_var i xrest) (Cons_var j yrest) => 
-      	if (index_lt i j) then true
-        else (andb (index_eq i j) (varlist_lt xrest yrest))
-  | _ _ => false
-  end.
-
-(* merges two variables lists *)
-Fixpoint varlist_merge [l1:varlist] : varlist -> varlist :=
-  Cases l1 of	
-  | (Cons_var v1 t1) => 
-      Fix vm_aux {vm_aux [l2:varlist] : varlist :=
-	Cases l2 of
-	| (Cons_var v2 t2) => 
-		     if (index_lt v1 v2)
-		     then (Cons_var v1 (varlist_merge t1 l2))
-		     else (Cons_var v2 (vm_aux t2))
-	| Nil_var => l1
-	end}
-  | Nil_var => [l2]l2
-  end.
-
-(* returns the sum of two canonical sums  *)
-Fixpoint canonical_sum_merge [s1:canonical_sum] 
-      	 : canonical_sum -> canonical_sum :=
-Cases s1 of
-| (Cons_monom c1 l1 t1) =>      
-     Fix csm_aux{csm_aux[s2:canonical_sum] : canonical_sum :=
-           Cases s2 of
-      	   | (Cons_monom c2 l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (Cons_monom (Aplus c1 c2) l1 
-      	       	       	        (canonical_sum_merge t1 t2))
-	       else if (varlist_lt l1 l2)
-	       then (Cons_monom c1 l1 (canonical_sum_merge t1 s2))
-	       else (Cons_monom c2 l2 (csm_aux t2))
-      	   | (Cons_varlist l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (Cons_monom (Aplus c1 Aone) l1 
-      	       	       	        (canonical_sum_merge t1 t2))
-	       else if (varlist_lt l1 l2)
-	       then (Cons_monom c1 l1 (canonical_sum_merge t1 s2))
-	       else (Cons_varlist l2 (csm_aux t2))
-	   | Nil_monom => s1
-	   end}
-| (Cons_varlist l1 t1) =>      
-     Fix csm_aux2{csm_aux2[s2:canonical_sum] : canonical_sum :=
-           Cases s2 of
-      	   | (Cons_monom c2 l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (Cons_monom (Aplus Aone c2) l1 
-      	       	       	        (canonical_sum_merge t1 t2))
-	       else if (varlist_lt l1 l2)
-	       then (Cons_varlist l1 (canonical_sum_merge t1 s2))
-	       else (Cons_monom c2 l2 (csm_aux2 t2))
-      	   | (Cons_varlist l2 t2) =>
-      	       if (varlist_eq l1 l2)
-	       then (Cons_monom (Aplus Aone Aone) l1 
-      	       	       	        (canonical_sum_merge t1 t2))
-	       else if (varlist_lt l1 l2)
-	       then (Cons_varlist l1 (canonical_sum_merge t1 s2))
-	       else (Cons_varlist l2 (csm_aux2 t2))
-	   | Nil_monom => s1
-	   end}
-| Nil_monom => [s2]s2
-end.
-
-(* Insertion of a monom in a canonical sum *)
-Fixpoint monom_insert [c1:A; l1:varlist; s2 : canonical_sum] 
-      : canonical_sum := 
-  Cases s2 of
-  | (Cons_monom c2 l2 t2) =>
-       if (varlist_eq l1 l2)
-       then (Cons_monom (Aplus c1 c2) l1 t2)
-       else if (varlist_lt l1 l2)
-       then (Cons_monom c1 l1 s2)
-       else (Cons_monom c2 l2 (monom_insert c1 l1 t2))
-  | (Cons_varlist l2 t2) =>
-       if (varlist_eq l1 l2)
-       then (Cons_monom (Aplus c1 Aone) l1 t2)
-       else if (varlist_lt l1 l2)
-       then (Cons_monom c1 l1 s2)
-       else (Cons_varlist l2 (monom_insert c1 l1 t2))
-  | Nil_monom => (Cons_monom c1 l1 Nil_monom)
-  end.
-
-Fixpoint varlist_insert [l1:varlist; s2:canonical_sum] 
-      : canonical_sum :=
-  Cases s2 of
-  | (Cons_monom c2 l2 t2) =>
-       if (varlist_eq l1 l2)
-       then (Cons_monom (Aplus Aone c2) l1 t2)
-       else if (varlist_lt l1 l2)
-       then (Cons_varlist l1 s2)
-       else (Cons_monom c2 l2 (varlist_insert l1 t2))
-  | (Cons_varlist l2 t2) =>
-       if (varlist_eq l1 l2)
-       then (Cons_monom (Aplus Aone Aone) l1 t2)
-       else if (varlist_lt l1 l2)
-       then (Cons_varlist l1 s2)
-       else (Cons_varlist l2 (varlist_insert l1 t2))
-  | Nil_monom => (Cons_varlist l1 Nil_monom)
-  end.
-
-(* Computes c0*s *)
-Fixpoint canonical_sum_scalar [c0:A; s:canonical_sum] : canonical_sum :=
-    Cases s of
-    | (Cons_monom c l t) => 
-	(Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t))
-    | (Cons_varlist l t) => 
-	(Cons_monom c0 l (canonical_sum_scalar c0 t))
-    | Nil_monom => Nil_monom
-    end.
-
-(* Computes l0*s  *)
-Fixpoint canonical_sum_scalar2 [l0:varlist; s:canonical_sum] 
-      	       	       	      : canonical_sum :=
-    Cases s of
-    | (Cons_monom c l t) => 
-      	  (monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t))
-    | (Cons_varlist l t) => 
-          (varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t))
-    | Nil_monom  => Nil_monom
-    end.
-
-(* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 [c0:A;l0:varlist; s:canonical_sum] 
-      	       	       	      : canonical_sum :=
-    Cases s of
-    | (Cons_monom c l t) => 
-          (monom_insert (Amult c0 c) (varlist_merge l0 l) 
-                        (canonical_sum_scalar3 c0 l0 t))
-    | (Cons_varlist l t) => 
-      	  (monom_insert c0 (varlist_merge l0 l) 
-                          (canonical_sum_scalar3 c0 l0 t))
-    | Nil_monom  => Nil_monom
-    end.
-
-(* returns the product of two canonical sums *) 
-Fixpoint canonical_sum_prod [s1:canonical_sum] 
-      	 : canonical_sum -> canonical_sum := 
-    [s2]Cases s1 of
-    | (Cons_monom c1 l1 t1) =>
-	(canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) 
-			     (canonical_sum_prod t1 s2))
-    | (Cons_varlist l1 t1) =>
-	(canonical_sum_merge (canonical_sum_scalar2 l1 s2) 
-			     (canonical_sum_prod t1 s2))
-    | Nil_monom => Nil_monom
-    end.
-
-(* The type to represent concrete semi-setoid-ring polynomials *)
-
-Inductive Type setspolynomial :=
-  SetSPvar : index -> setspolynomial
-| SetSPconst : A -> setspolynomial
-| SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
-| SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.
-
-Fixpoint setspolynomial_normalize [p:setspolynomial] : canonical_sum :=
- Cases p of
- | (SetSPplus l r) => (canonical_sum_merge (setspolynomial_normalize l) (setspolynomial_normalize r))
- | (SetSPmult l r) => (canonical_sum_prod (setspolynomial_normalize l) (setspolynomial_normalize r))
- | (SetSPconst c)  => (Cons_monom c Nil_var Nil_monom)
- | (SetSPvar i)    => (Cons_varlist (Cons_var i Nil_var) Nil_monom)
- end.
-
-Fixpoint canonical_sum_simplify [ s:canonical_sum] : canonical_sum :=
-  Cases s of
-  | (Cons_monom c l t) => 
-	 if (Aeq c Azero) 
-	 then (canonical_sum_simplify t)
-	 else if (Aeq c Aone)
-	 then (Cons_varlist l (canonical_sum_simplify t))
-	 else (Cons_monom c l (canonical_sum_simplify t))
-  | (Cons_varlist l t) => (Cons_varlist l (canonical_sum_simplify t))
-  | Nil_monom => Nil_monom
-  end.
-
-Definition setspolynomial_simplify :=
-  [x:setspolynomial] (canonical_sum_simplify (setspolynomial_normalize x)).
-
-Variable vm : (varmap A).
-
-Definition interp_var [i:index] := (varmap_find Azero i vm).
-
-Definition ivl_aux := Fix ivl_aux {ivl_aux[x:index; t:varlist] : A := 
-  Cases t of
-  | Nil_var => (interp_var x)
-  | (Cons_var x' t') => (Amult (interp_var x) (ivl_aux x' t'))
-  end}.
-
-Definition interp_vl :=  [l:varlist] 
-  Cases l of
-  | Nil_var => Aone
-  | (Cons_var x t) => (ivl_aux x t)
-  end.
-
-Definition interp_m := [c:A][l:varlist] 
-  Cases l of
-  | Nil_var => c
-  | (Cons_var x t) => 
-      (Amult c (ivl_aux x t))
-  end.
-
-Definition ics_aux := Fix ics_aux{ics_aux[a:A; s:canonical_sum] : A :=  
-  Cases s of
-  | Nil_monom => a
-  | (Cons_varlist l t) => (Aplus a (ics_aux (interp_vl l) t))
-  | (Cons_monom c l t) => (Aplus a (ics_aux (interp_m c l) t))
-  end}.
-
-Definition interp_setcs : canonical_sum -> A  := 
-  [s]Cases s of 
-  | Nil_monom => Azero
-  | (Cons_varlist l t) =>
-      	(ics_aux (interp_vl l) t)
-  | (Cons_monom c l t) =>
-      	(ics_aux (interp_m c l) t)
-  end.
-
-Fixpoint interp_setsp [p:setspolynomial] : A :=
- Cases p of
- | (SetSPconst c) => c
- | (SetSPvar i) => (interp_var i)
- | (SetSPplus p1 p2) => (Aplus (interp_setsp p1) (interp_setsp p2))
- | (SetSPmult p1 p2) => (Amult (interp_setsp p1) (interp_setsp p2))
- end.
-
-(* End interpretation. *)
-
-Unset Implicit Arguments.
-
-(* Section properties. *)
-
-Variable T : (Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq).
-
-Hint SSR_plus_sym_T := Resolve (SSR_plus_sym T).
-Hint SSR_plus_assoc_T := Resolve (SSR_plus_assoc T).
-Hint SSR_plus_assoc2_T := Resolve (SSR_plus_assoc2 S T).
-Hint SSR_mult_sym_T := Resolve (SSR_mult_sym T).
-Hint SSR_mult_assoc_T := Resolve (SSR_mult_assoc T).
-Hint SSR_mult_assoc2_T := Resolve (SSR_mult_assoc2 S T).
-Hint SSR_plus_zero_left_T := Resolve (SSR_plus_zero_left T).
-Hint SSR_plus_zero_left2_T := Resolve (SSR_plus_zero_left2 S T).
-Hint SSR_mult_one_left_T := Resolve (SSR_mult_one_left T).
-Hint SSR_mult_one_left2_T := Resolve (SSR_mult_one_left2 S T).
-Hint SSR_mult_zero_left_T := Resolve (SSR_mult_zero_left T).
-Hint SSR_mult_zero_left2_T := Resolve (SSR_mult_zero_left2 S T).
-Hint SSR_distr_left_T := Resolve (SSR_distr_left T).
-Hint SSR_distr_left2_T := Resolve (SSR_distr_left2 S T).
-Hint SSR_plus_reg_left_T := Resolve (SSR_plus_reg_left T).
-Hint SSR_plus_permute_T := Resolve (SSR_plus_permute S plus_morph T).
-Hint SSR_mult_permute_T := Resolve (SSR_mult_permute S mult_morph T).
-Hint SSR_distr_right_T := Resolve (SSR_distr_right S plus_morph T).
-Hint SSR_distr_right2_T := Resolve (SSR_distr_right2 S plus_morph T).
-Hint SSR_mult_zero_right_T := Resolve (SSR_mult_zero_right S T).
-Hint SSR_mult_zero_right2_T := Resolve (SSR_mult_zero_right2 S T).
-Hint SSR_plus_zero_right_T := Resolve (SSR_plus_zero_right S T).
-Hint SSR_plus_zero_right2_T := Resolve (SSR_plus_zero_right2 S T).
-Hint SSR_mult_one_right_T := Resolve (SSR_mult_one_right S T).
-Hint SSR_mult_one_right2_T := Resolve (SSR_mult_one_right2 S T).
-Hint SSR_plus_reg_right_T := Resolve (SSR_plus_reg_right S T).
-Hints Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hints Immediate T.
-
-Lemma varlist_eq_prop : (x,y:varlist)
-  (Is_true (varlist_eq x y))->x==y.
-Proof.
-  Induction x; Induction y; Contradiction Orelse Try Reflexivity.
-  Simpl; Intros.
-  Generalize (andb_prop2 ? ? H1); Intros; Elim H2; Intros.
-  Rewrite (index_eq_prop H3); Rewrite (H v0 H4); Reflexivity.
-Save.
-
-Remark ivl_aux_ok : (v:varlist)(i:index)
-  (Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v))).
-Proof.
-  Induction v; Simpl; Intros.
-  Trivial.
-  Rewrite (H i); Trivial.
-Save.
-
-Lemma varlist_merge_ok : (x,y:varlist)
-  (Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y))).
-Proof.
-  Induction x.
-  Simpl; Trivial.
-  Induction y.
-  Simpl; Trivial.
-  Simpl; Intros.
-  Elim (index_lt i i0); Simpl; Intros.
-
-  Rewrite (ivl_aux_ok v i).
-  Rewrite (ivl_aux_ok v0 i0).
-  Rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i).
-  Rewrite (H (Cons_var i0 v0)).
-  Simpl.
-  Rewrite (ivl_aux_ok v0 i0).
-  EAuto.
-
-  Rewrite (ivl_aux_ok v i).
-  Rewrite (ivl_aux_ok v0 i0).
-  Rewrite (ivl_aux_ok
-                 (Fix vm_aux
-                    {vm_aux [l2:varlist] : varlist :=
-                       Cases (l2) of
-                         Nil_var => (Cons_var i v)
-                       | (Cons_var v2 t2) => 
-                          (if (index_lt i v2)
-                           then (Cons_var i (varlist_merge v l2))
-                           else (Cons_var v2 (vm_aux t2)))
-                       end} v0) i0).
-  Rewrite H0.
-  Rewrite (ivl_aux_ok v i).
-  EAuto.
-Save.
-
-Remark ics_aux_ok : (x:A)(s:canonical_sum)
-  (Aequiv (ics_aux x s) (Aplus x (interp_setcs s))).
-Proof.
- Induction s; Simpl; Intros;Trivial.
-Save.
-
-Remark interp_m_ok : (x:A)(l:varlist)
-  (Aequiv (interp_m x l) (Amult x (interp_vl l))).
-Proof.
-  NewDestruct l;Trivial.
-Save.
-
-Hint ivl_aux_ok_ := Resolve ivl_aux_ok.
-Hint ics_aux_ok_ := Resolve ics_aux_ok.
-Hint interp_m_ok_ := Resolve interp_m_ok.
-
-(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)
-
-Lemma canonical_sum_merge_ok : (x,y:canonical_sum)
-  (Aequiv (interp_setcs (canonical_sum_merge x y))
-  (Aplus (interp_setcs x) (interp_setcs y))).
-Proof.
-Induction x; Simpl.
-Trivial.
-
-Induction y; Simpl; Intros.
-EAuto.
-
-Generalize (varlist_eq_prop v v0).
-Elim (varlist_eq v v0).
-Intros; Rewrite (H1 I).
-Simpl.
-Rewrite (ics_aux_ok (interp_m a v0) c).
-Rewrite (ics_aux_ok (interp_m a0 v0) c0).
-Rewrite (ics_aux_ok (interp_m (Aplus a a0) v0)
-                 (canonical_sum_merge c c0)).
-Rewrite (H c0).
-Rewrite (interp_m_ok (Aplus a a0) v0).
-Rewrite (interp_m_ok a v0).
-Rewrite (interp_m_ok a0 v0).
-Setoid_replace (Amult (Aplus a a0) (interp_vl v0))
- with (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))).
-Setoid_replace (Aplus
-                 (Aplus (Amult a (interp_vl v0))
-                   (Amult a0 (interp_vl v0)))
-                 (Aplus (interp_setcs c) (interp_setcs c0)))
- with (Aplus (Amult a (interp_vl v0))
-        (Aplus (Amult a0 (interp_vl v0))
-          (Aplus (interp_setcs c) (interp_setcs c0)))).
-Setoid_replace (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
-                 (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0)))
- with (Aplus (Amult a (interp_vl v0))
-        (Aplus (interp_setcs c)
-          (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0)))).
-Auto.
-
-Elim (varlist_lt v v0); Simpl.
-Intro.
-Rewrite (ics_aux_ok (interp_m a v)
-                 (canonical_sum_merge c (Cons_monom a0 v0 c0))).
-Rewrite (ics_aux_ok (interp_m a v) c).
-Rewrite (ics_aux_ok (interp_m a0 v0) c0).
-Rewrite (H (Cons_monom a0 v0 c0)); Simpl.
-Rewrite (ics_aux_ok (interp_m a0 v0) c0); Auto.
-
-Intro.
-Rewrite (ics_aux_ok (interp_m a0 v0)
-                 (Fix csm_aux
-                    {csm_aux [s2:canonical_sum] : canonical_sum :=
-                       Cases (s2) of
-                         Nil_monom => (Cons_monom a v c)
-                       | (Cons_monom c2 l2 t2) => 
-                          (if (varlist_eq v l2)
-                           then
-                            (Cons_monom (Aplus a c2) v
-                              (canonical_sum_merge c t2))
-                           else
-                            (if (varlist_lt v l2)
-                             then
-                              (Cons_monom a v
-                                (canonical_sum_merge c s2))
-                             else (Cons_monom c2 l2 (csm_aux t2))))
-                       | (Cons_varlist l2 t2) => 
-                          (if (varlist_eq v l2)
-                           then
-                            (Cons_monom (Aplus a Aone) v
-                              (canonical_sum_merge c t2))
-                           else
-                            (if (varlist_lt v l2)
-                             then
-                              (Cons_monom a v
-                                (canonical_sum_merge c s2))
-                             else (Cons_varlist l2 (csm_aux t2))))
-                       end} c0)).
-Rewrite H0.
-Rewrite (ics_aux_ok (interp_m a v) c);
-Rewrite (ics_aux_ok (interp_m a0 v0) c0); Simpl; Auto.
-
-Generalize (varlist_eq_prop v v0).
-Elim (varlist_eq v v0).
-Intros; Rewrite (H1 I).
-Simpl.
-Rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0)
-                 (canonical_sum_merge c c0));
-Rewrite (ics_aux_ok (interp_m a v0) c);
-Rewrite (ics_aux_ok (interp_vl v0) c0).
-Rewrite (H c0).
-Rewrite (interp_m_ok (Aplus a Aone) v0).
-Rewrite (interp_m_ok a v0).
-Setoid_replace (Amult (Aplus a Aone) (interp_vl v0))
- with (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))).
-Setoid_replace (Aplus
-                 (Aplus (Amult a (interp_vl v0))
-                   (Amult Aone (interp_vl v0)))
-                 (Aplus (interp_setcs c) (interp_setcs c0)))
- with (Aplus (Amult a (interp_vl v0))
-        (Aplus (Amult Aone (interp_vl v0))
-          (Aplus (interp_setcs c) (interp_setcs c0)))).
-Setoid_replace (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
-                 (Aplus (interp_vl v0) (interp_setcs c0)))
- with (Aplus (Amult a (interp_vl v0))
-        (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))).
-Setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0).
-Auto.
-
-Elim (varlist_lt v v0); Simpl.
-Intro.
-Rewrite (ics_aux_ok (interp_m a v)
-                 (canonical_sum_merge c (Cons_varlist v0 c0)));
-Rewrite (ics_aux_ok (interp_m a v) c);
-Rewrite (ics_aux_ok (interp_vl v0) c0).
-Rewrite (H (Cons_varlist v0 c0)); Simpl.
-Rewrite (ics_aux_ok (interp_vl v0) c0).
-Auto.
-
-Intro.
-Rewrite (ics_aux_ok (interp_vl v0)
-                 (Fix csm_aux
-                    {csm_aux [s2:canonical_sum] : canonical_sum :=
-                       Cases (s2) of
-                         Nil_monom => (Cons_monom a v c)
-                       | (Cons_monom c2 l2 t2) => 
-                          (if (varlist_eq v l2)
-                           then
-                            (Cons_monom (Aplus a c2) v
-                              (canonical_sum_merge c t2))
-                           else
-                            (if (varlist_lt v l2)
-                             then
-                              (Cons_monom a v
-                                (canonical_sum_merge c s2))
-                             else (Cons_monom c2 l2 (csm_aux t2))))
-                       | (Cons_varlist l2 t2) => 
-                          (if (varlist_eq v l2)
-                           then
-                            (Cons_monom (Aplus a Aone) v
-                              (canonical_sum_merge c t2))
-                           else
-                            (if (varlist_lt v l2)
-                             then
-                              (Cons_monom a v
-                                (canonical_sum_merge c s2))
-                             else (Cons_varlist l2 (csm_aux t2))))
-                       end} c0)); Rewrite H0.
-Rewrite (ics_aux_ok (interp_m a v) c);
-Rewrite (ics_aux_ok (interp_vl v0) c0); Simpl.
-Auto.
-
-Induction y; Simpl; Intros.
-Trivial.
-
-Generalize (varlist_eq_prop v v0).
-Elim (varlist_eq v v0).
-Intros; Rewrite (H1 I).
-Simpl.
-Rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0)
-                 (canonical_sum_merge c c0));
-Rewrite (ics_aux_ok (interp_vl v0) c);
-Rewrite (ics_aux_ok (interp_m a v0) c0); Rewrite (
-H c0).
-Rewrite (interp_m_ok (Aplus Aone a) v0);
-Rewrite (interp_m_ok a v0).
-Setoid_replace (Amult (Aplus Aone a) (interp_vl v0))
- with (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)));
-Setoid_replace (Aplus
-                 (Aplus (Amult Aone (interp_vl v0))
-                   (Amult a (interp_vl v0)))
-                 (Aplus (interp_setcs c) (interp_setcs c0)))
- with (Aplus (Amult Aone (interp_vl v0))
-        (Aplus (Amult a (interp_vl v0))
-          (Aplus (interp_setcs c) (interp_setcs c0))));
-Setoid_replace (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-                 (Aplus (Amult a (interp_vl v0)) (interp_setcs c0)))
- with (Aplus (interp_vl v0)
-        (Aplus (interp_setcs c)
-          (Aplus (Amult a (interp_vl v0)) (interp_setcs c0)))).
-Auto.
-
-Elim (varlist_lt v v0); Simpl; Intros.
-Rewrite (ics_aux_ok (interp_vl v)
-                 (canonical_sum_merge c (Cons_monom a v0 c0)));
-Rewrite (ics_aux_ok (interp_vl v) c);
-Rewrite (ics_aux_ok (interp_m a v0) c0).
-Rewrite (H (Cons_monom a v0 c0)); Simpl.
-Rewrite (ics_aux_ok (interp_m a v0) c0); Auto.
-
-Rewrite (ics_aux_ok (interp_m a v0)
-                 (Fix csm_aux2
-                    {csm_aux2 [s2:canonical_sum] : canonical_sum :=
-                       Cases (s2) of
-                         Nil_monom => (Cons_varlist v c)
-                       | (Cons_monom c2 l2 t2) => 
-                          (if (varlist_eq v l2)
-                           then
-                            (Cons_monom (Aplus Aone c2) v
-                              (canonical_sum_merge c t2))
-                           else
-                            (if (varlist_lt v l2)
-                             then
-                              (Cons_varlist v
-                                (canonical_sum_merge c s2))
-                             else (Cons_monom c2 l2 (csm_aux2 t2))))
-                       | (Cons_varlist l2 t2) => 
-                          (if (varlist_eq v l2)
-                           then
-                            (Cons_monom (Aplus Aone Aone) v
-                              (canonical_sum_merge c t2))
-                           else
-                            (if (varlist_lt v l2)
-                             then
-                              (Cons_varlist v
-                                (canonical_sum_merge c s2))
-                             else (Cons_varlist l2 (csm_aux2 t2))))
-                       end} c0)); Rewrite H0.
-Rewrite (ics_aux_ok (interp_vl v) c);
-Rewrite (ics_aux_ok (interp_m a v0) c0); Simpl; Auto.
-
-Generalize (varlist_eq_prop v v0).
-Elim (varlist_eq v v0); Intros.
-Rewrite (H1 I); Simpl.
-Rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v0)
-                 (canonical_sum_merge c c0));
-Rewrite (ics_aux_ok (interp_vl v0) c);
-Rewrite (ics_aux_ok (interp_vl v0) c0); Rewrite (
-H c0).
-Rewrite (interp_m_ok (Aplus Aone Aone) v0).
-Setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0))
- with (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)));
-Setoid_replace (Aplus
-                 (Aplus (Amult Aone (interp_vl v0))
-                   (Amult Aone (interp_vl v0)))
-                 (Aplus (interp_setcs c) (interp_setcs c0)))
- with (Aplus (Amult Aone (interp_vl v0))
-        (Aplus (Amult Aone (interp_vl v0))
-          (Aplus (interp_setcs c) (interp_setcs c0))));
-Setoid_replace (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-                 (Aplus (interp_vl v0) (interp_setcs c0)))
- with (Aplus (interp_vl v0)
-        (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))).
-Setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); Auto.
-
-Elim (varlist_lt v v0); Simpl.
-Rewrite (ics_aux_ok (interp_vl v)
-                 (canonical_sum_merge c (Cons_varlist v0 c0)));
-Rewrite (ics_aux_ok (interp_vl v) c);
-Rewrite (ics_aux_ok (interp_vl v0) c0);
-Rewrite (H (Cons_varlist v0 c0)); Simpl.
-Rewrite (ics_aux_ok (interp_vl v0) c0); Auto.
-
-Rewrite (ics_aux_ok (interp_vl v0)
-                 (Fix csm_aux2
-                    {csm_aux2 [s2:canonical_sum] : canonical_sum :=
-                       Cases (s2) of
-                         Nil_monom => (Cons_varlist v c)
-                       | (Cons_monom c2 l2 t2) => 
-                          (if (varlist_eq v l2)
-                           then
-                            (Cons_monom (Aplus Aone c2) v
-                              (canonical_sum_merge c t2))
-                           else
-                            (if (varlist_lt v l2)
-                             then
-                              (Cons_varlist v
-                                (canonical_sum_merge c s2))
-                             else (Cons_monom c2 l2 (csm_aux2 t2))))
-                       | (Cons_varlist l2 t2) => 
-                          (if (varlist_eq v l2)
-                           then
-                            (Cons_monom (Aplus Aone Aone) v
-                              (canonical_sum_merge c t2))
-                           else
-                            (if (varlist_lt v l2)
-                             then
-                              (Cons_varlist v
-                                (canonical_sum_merge c s2))
-                             else (Cons_varlist l2 (csm_aux2 t2))))
-                       end} c0)); Rewrite H0.
-Rewrite (ics_aux_ok (interp_vl v) c);
-Rewrite (ics_aux_ok (interp_vl v0) c0); Simpl; Auto.
-Save.
-
-Lemma monom_insert_ok: (a:A)(l:varlist)(s:canonical_sum)
- (Aequiv (interp_setcs (monom_insert a l s)) 
-   (Aplus (Amult a (interp_vl l)) (interp_setcs s))).
-Proof.
-Induction s; Intros.
-Simpl; Rewrite (interp_m_ok a l); Trivial.
-
-Simpl; Generalize (varlist_eq_prop l v); Elim (varlist_eq l v).
-Intro Hr; Rewrite (Hr I); Simpl.
-Rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
-Rewrite (ics_aux_ok (interp_m a0 v) c).
-Rewrite (interp_m_ok (Aplus a a0) v);
-Rewrite (interp_m_ok a0 v).
-Setoid_replace (Amult (Aplus a a0) (interp_vl v))
- with (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v))).
-Auto.
-
-Elim (varlist_lt l v); Simpl; Intros.
-Rewrite (ics_aux_ok (interp_m a0 v) c).
-Rewrite (interp_m_ok a0 v); Rewrite (interp_m_ok a l).
-Auto.
-
-Rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c));
-Rewrite (ics_aux_ok (interp_m a0 v) c); Rewrite H.
-Auto.
-
-Simpl.
-Generalize (varlist_eq_prop l v); Elim (varlist_eq l v).
-Intro Hr; Rewrite (Hr I); Simpl.
-Rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
-Rewrite (ics_aux_ok (interp_vl v) c).
-Rewrite (interp_m_ok (Aplus a Aone) v).
-Setoid_replace (Amult (Aplus a Aone) (interp_vl v))
- with (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v))).
-Setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v).
-Auto.
-
-Elim (varlist_lt l v); Simpl; Intros; Auto.
-Rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c));
-Rewrite H.
-Rewrite (ics_aux_ok (interp_vl v) c); Auto.
-Save.
-
-Lemma varlist_insert_ok :
- (l:varlist)(s:canonical_sum)
- (Aequiv (interp_setcs (varlist_insert l s)) 
-   (Aplus (interp_vl l) (interp_setcs s))).
-Proof.
-Induction s; Simpl; Intros.
-Trivial.
-
-Generalize (varlist_eq_prop l v); Elim (varlist_eq l v).
-Intro Hr; Rewrite (Hr I); Simpl.
-Rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
-Rewrite (ics_aux_ok (interp_m a v) c).
-Rewrite (interp_m_ok (Aplus Aone a) v);
-Rewrite (interp_m_ok a v).
-Setoid_replace (Amult (Aplus Aone a) (interp_vl v))
- with (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v))).
-Setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); Auto.
-
-Elim (varlist_lt l v); Simpl; Intros; Auto.
-Rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c));
-Rewrite (ics_aux_ok (interp_m a v) c).
-Rewrite (interp_m_ok a v).
-Rewrite H; Auto.
-
-Generalize (varlist_eq_prop l v); Elim (varlist_eq l v).
-Intro Hr; Rewrite (Hr I); Simpl.
-Rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
-Rewrite (ics_aux_ok (interp_vl v) c).
-Rewrite (interp_m_ok (Aplus Aone Aone) v).
-Setoid_replace (Amult (Aplus Aone Aone) (interp_vl v))
- with (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v))).
-Setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); Auto.
-
-Elim (varlist_lt l v); Simpl; Intros; Auto.
-Rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
-Rewrite H.
-Rewrite (ics_aux_ok (interp_vl v) c); Auto.
-Save.
-
-Lemma canonical_sum_scalar_ok : (a:A)(s:canonical_sum)
-  (Aequiv (interp_setcs (canonical_sum_scalar a s)) (Amult a (interp_setcs s))).
-Proof.
-Induction s; Simpl; Intros.
-Trivial.
-
-Rewrite (ics_aux_ok (interp_m (Amult a a0) v)
-                 (canonical_sum_scalar a c));
-Rewrite (ics_aux_ok (interp_m a0 v) c).
-Rewrite (interp_m_ok (Amult a a0) v);
-Rewrite (interp_m_ok a0 v).
-Rewrite H.
-Setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c)))
- with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c))).
-Auto.
-
-Rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c));
-Rewrite (ics_aux_ok (interp_vl v) c); Rewrite H.
-Rewrite (interp_m_ok a v).
-Auto.
-Save.
-
-Lemma canonical_sum_scalar2_ok : (l:varlist; s:canonical_sum)
-  (Aequiv (interp_setcs (canonical_sum_scalar2 l s)) (Amult (interp_vl l) (interp_setcs s))).
-Proof.
-Induction s; Simpl; Intros; Auto.
-Rewrite (monom_insert_ok a (varlist_merge l v)
-                 (canonical_sum_scalar2 l c)).
-Rewrite (ics_aux_ok (interp_m a v) c).
-Rewrite (interp_m_ok a v).
-Rewrite H.
-Rewrite (varlist_merge_ok l v).
-Setoid_replace (Amult (interp_vl l)
-                 (Aplus (Amult a (interp_vl v)) (interp_setcs c)))
- with (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-        (Amult (interp_vl l) (interp_setcs c))).
-Auto.
-
-Rewrite (varlist_insert_ok (varlist_merge l v)
-                 (canonical_sum_scalar2 l c)).
-Rewrite (ics_aux_ok (interp_vl v) c).
-Rewrite H.
-Rewrite (varlist_merge_ok l v).
-Auto.
-Save.
-
-Lemma canonical_sum_scalar3_ok : (c:A; l:varlist; s:canonical_sum)
-  (Aequiv (interp_setcs (canonical_sum_scalar3 c l s)) (Amult c (Amult (interp_vl l) (interp_setcs s)))).
-Proof.
-Induction s; Simpl; Intros.
-Rewrite (SSR_mult_zero_right S T (interp_vl l)).
-Auto.
-
-Rewrite (monom_insert_ok (Amult c a) (varlist_merge l v)
-                 (canonical_sum_scalar3 c l c0)).
-Rewrite (ics_aux_ok (interp_m a v) c0).
-Rewrite (interp_m_ok a v).
-Rewrite H.
-Rewrite (varlist_merge_ok l v).
-Setoid_replace (Amult (interp_vl l)
-                 (Aplus (Amult a (interp_vl v)) (interp_setcs c0)))
- with (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-        (Amult (interp_vl l) (interp_setcs c0))).
-Setoid_replace (Amult c
-                 (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-                   (Amult (interp_vl l) (interp_setcs c0))))
- with (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v))))
-        (Amult c (Amult (interp_vl l) (interp_setcs c0)))).
-Setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v)))
- with (Amult c (Amult a (Amult (interp_vl l) (interp_vl v)))).
-Auto.
-
-Rewrite (monom_insert_ok c (varlist_merge l v)
-                 (canonical_sum_scalar3 c l c0)).
-Rewrite (ics_aux_ok (interp_vl v) c0).
-Rewrite H.
-Rewrite (varlist_merge_ok l v).
-Setoid_replace (Aplus (Amult c (Amult (interp_vl l) (interp_vl v)))
-                 (Amult c (Amult (interp_vl l) (interp_setcs c0))))
- with (Amult c
-        (Aplus (Amult (interp_vl l) (interp_vl v))
-          (Amult (interp_vl l) (interp_setcs c0)))).
-Auto.
-Save.
-
-Lemma canonical_sum_prod_ok : (x,y:canonical_sum)
-  (Aequiv (interp_setcs (canonical_sum_prod x y)) (Amult (interp_setcs x) (interp_setcs y))).
-Proof.
-Induction x; Simpl; Intros.
-Trivial.
-
-Rewrite (canonical_sum_merge_ok (canonical_sum_scalar3 a v y)
-                 (canonical_sum_prod c y)).
-Rewrite (canonical_sum_scalar3_ok a v y).
-Rewrite (ics_aux_ok (interp_m a v) c).
-Rewrite (interp_m_ok a v).
-Rewrite (H y).
-Setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y)))
- with (Amult (Amult a (interp_vl v)) (interp_setcs y)).
-Setoid_replace (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c))
-                 (interp_setcs y))
- with (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y))
-        (Amult (interp_setcs c) (interp_setcs y))).
-Trivial.
-
-Rewrite (canonical_sum_merge_ok (canonical_sum_scalar2 v y)
-                 (canonical_sum_prod c y)).
-Rewrite (canonical_sum_scalar2_ok v y).
-Rewrite (ics_aux_ok (interp_vl v) c).
-Rewrite (H y).
-Trivial.
-Save.
-
-Theorem setspolynomial_normalize_ok : (p:setspolynomial)
-  (Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p)).
-Proof.
-Induction p; Simpl; Intros; Trivial.
-Rewrite (canonical_sum_merge_ok (setspolynomial_normalize s)
-                 (setspolynomial_normalize s0)).
-Rewrite H; Rewrite H0; Trivial.
-
-Rewrite (canonical_sum_prod_ok (setspolynomial_normalize s)
-                 (setspolynomial_normalize s0)).
-Rewrite H; Rewrite H0; Trivial.
-Save.
-
-Lemma canonical_sum_simplify_ok : (s:canonical_sum)
-  (Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s)).
-Proof.
-Induction s; Simpl; Intros.
-Trivial.
-
-Generalize (SSR_eq_prop T 9!a 10!Azero).
-Elim (Aeq a Azero).
-Simpl.
-Intros.
-Rewrite (ics_aux_ok (interp_m a v) c).
-Rewrite (interp_m_ok a v).
-Rewrite (H0 I).
-Setoid_replace (Amult Azero (interp_vl v)) with Azero.
-Rewrite H.
-Trivial.
-
-Intros; Simpl.
-Generalize (SSR_eq_prop T 9!a 10!Aone).
-Elim (Aeq a Aone).
-Intros.
-Rewrite (ics_aux_ok (interp_m a v) c).
-Rewrite (interp_m_ok a v).
-Rewrite (H1 I).
-Simpl.
-Rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
-Rewrite H.
-Auto.
-
-Simpl.
-Intros.
-Rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)).
-Rewrite (ics_aux_ok (interp_m a v) c).
-Rewrite H; Trivial.
-
-Rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
-Rewrite H.
-Auto.
-Save.
-
-Theorem setspolynomial_simplify_ok : (p:setspolynomial)
-  (Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p)).
-Proof.
-Intro.
-Unfold setspolynomial_simplify.
-Rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
-Exact (setspolynomial_normalize_ok p).
-Save.
-
-End semi_setoid_rings.
-
-Implicits Cons_varlist.
-Implicits Cons_monom.
-Implicits SetSPconst.
-Implicits SetSPplus.
-Implicits SetSPmult.
-
-
-
-Section setoid_rings.
-
-Set Implicit Arguments.
-
-Variable vm : (varmap A).
-Variable T : (Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq).
-
-Hint STh_plus_sym_T := Resolve (STh_plus_sym T).
-Hint STh_plus_assoc_T := Resolve (STh_plus_assoc T).
-Hint STh_plus_assoc2_T := Resolve (STh_plus_assoc2 S T).
-Hint STh_mult_sym_T := Resolve (STh_mult_sym T).
-Hint STh_mult_assoc_T := Resolve (STh_mult_assoc T).
-Hint STh_mult_assoc2_T := Resolve (STh_mult_assoc2 S T).
-Hint STh_plus_zero_left_T := Resolve (STh_plus_zero_left T).
-Hint STh_plus_zero_left2_T := Resolve (STh_plus_zero_left2 S T).
-Hint STh_mult_one_left_T := Resolve (STh_mult_one_left T).
-Hint STh_mult_one_left2_T := Resolve (STh_mult_one_left2 S T).
-Hint STh_mult_zero_left_T := Resolve (STh_mult_zero_left S plus_morph mult_morph T).
-Hint STh_mult_zero_left2_T := Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
-Hint STh_distr_left_T := Resolve (STh_distr_left T).
-Hint STh_distr_left2_T := Resolve (STh_distr_left2 S T).
-Hint STh_plus_reg_left_T := Resolve (STh_plus_reg_left S plus_morph T).
-Hint STh_plus_permute_T := Resolve (STh_plus_permute S plus_morph T).
-Hint STh_mult_permute_T := Resolve (STh_mult_permute S mult_morph T).
-Hint STh_distr_right_T := Resolve (STh_distr_right S plus_morph T).
-Hint STh_distr_right2_T := Resolve (STh_distr_right2 S plus_morph T).
-Hint STh_mult_zero_right_T := Resolve (STh_mult_zero_right S plus_morph mult_morph T).
-Hint STh_mult_zero_right2_T := Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
-Hint STh_plus_zero_right_T := Resolve (STh_plus_zero_right S T).
-Hint STh_plus_zero_right2_T := Resolve (STh_plus_zero_right2 S T).
-Hint STh_mult_one_right_T := Resolve (STh_mult_one_right S T).
-Hint STh_mult_one_right2_T := Resolve (STh_mult_one_right2 S T).
-Hint STh_plus_reg_right_T := Resolve (STh_plus_reg_right S plus_morph T).
-Hints Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
-Hints Immediate T.
-
-
-(*** Definitions *)
-
-Inductive Type setpolynomial := 
-  SetPvar : index -> setpolynomial
-| SetPconst : A -> setpolynomial
-| SetPplus : setpolynomial -> setpolynomial -> setpolynomial
-| SetPmult : setpolynomial -> setpolynomial -> setpolynomial
-| SetPopp : setpolynomial -> setpolynomial.
-
-Fixpoint setpolynomial_normalize [x:setpolynomial] : canonical_sum :=
- Cases x of
- | (SetPplus l r) => (canonical_sum_merge
-     (setpolynomial_normalize l) 
-     (setpolynomial_normalize r))
- | (SetPmult l r) => (canonical_sum_prod
-     (setpolynomial_normalize l)
-     (setpolynomial_normalize r))
- | (SetPconst c)  => (Cons_monom c Nil_var Nil_monom)
- | (SetPvar i)    => (Cons_varlist (Cons_var i Nil_var) Nil_monom)
- | (SetPopp p)    => (canonical_sum_scalar3
-     (Aopp Aone) Nil_var
-     (setpolynomial_normalize p))
- end.
-
-Definition setpolynomial_simplify :=
- [x:setpolynomial](canonical_sum_simplify (setpolynomial_normalize x)).
-
-Fixpoint setspolynomial_of [x:setpolynomial] : setspolynomial :=
- Cases x of 
- | (SetPplus l r) => (SetSPplus (setspolynomial_of l) (setspolynomial_of r))
- | (SetPmult l r) => (SetSPmult (setspolynomial_of l) (setspolynomial_of r))
- | (SetPconst c)  => (SetSPconst c)
- | (SetPvar i)    => (SetSPvar i)
- | (SetPopp p)    => (SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p))
- end.
-
-(*** Interpretation *)
-
-Fixpoint interp_setp [p:setpolynomial] : A :=
- Cases p of
- | (SetPconst c)    => c
- | (SetPvar i)      => (varmap_find Azero i vm)
- | (SetPplus p1 p2) => (Aplus (interp_setp p1) (interp_setp p2))
- | (SetPmult p1 p2) => (Amult (interp_setp p1) (interp_setp p2))
- | (SetPopp p1)     => (Aopp (interp_setp p1))
- end.
-
-(*** Properties *)
-
-Unset Implicit Arguments.
-
-Lemma setspolynomial_of_ok : (p:setpolynomial)
- (Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p))).
-Induction p; Trivial; Simpl; Intros.
-Rewrite H; Rewrite H0; Trivial.
-Rewrite H; Rewrite H0; Trivial.
-Rewrite H.
-Rewrite (STh_opp_mult_left2 S plus_morph mult_morph T Aone
-                 (interp_setsp vm (setspolynomial_of s))).
-Rewrite (STh_mult_one_left T
-                 (interp_setsp vm (setspolynomial_of s))).
-Trivial.
-Save.
-
-Theorem setpolynomial_normalize_ok : (p:setpolynomial)
- (setpolynomial_normalize p)
-  ==(setspolynomial_normalize (setspolynomial_of p)).
-Induction p; Trivial; Simpl; Intros.
-Rewrite H; Rewrite H0; Reflexivity.
-Rewrite H; Rewrite H0; Reflexivity.
-Rewrite H; Simpl.
-Elim (canonical_sum_scalar3 (Aopp Aone) Nil_var
-   (setspolynomial_normalize (setspolynomial_of s)));
- [ Reflexivity
- | Simpl; Intros; Rewrite H0; Reflexivity
- | Simpl; Intros; Rewrite H0; Reflexivity ].
-Save.
-
-Theorem setpolynomial_simplify_ok : (p:setpolynomial)
- (Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p)).
-Intro.
-Unfold setpolynomial_simplify.
-Rewrite (setspolynomial_of_ok p).
-Rewrite setpolynomial_normalize_ok.
-Rewrite (canonical_sum_simplify_ok vm
-   (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp
-    Aeq plus_morph mult_morph T)
-   (setspolynomial_normalize (setspolynomial_of p))).
-Rewrite (setspolynomial_normalize_ok vm 
-   (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp
-    Aeq plus_morph mult_morph T) (setspolynomial_of p)).
-Trivial.
-Save.
-
-End setoid_rings.
-
-End setoid.
diff --git a/contrib7/ring/Setoid_ring_theory.v b/contrib7/ring/Setoid_ring_theory.v
deleted file mode 100644
index 13afc5ee..00000000
--- a/contrib7/ring/Setoid_ring_theory.v
+++ /dev/null
@@ -1,429 +0,0 @@
-(************************************************************************)
-(*  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_ring_theory.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
-
-Require Export Bool.
-Require Export Setoid.
-
-Set Implicit Arguments.
-
-Section Setoid_rings.
-
-Variable A : Type.
-Variable Aequiv : A -> A -> Prop.
-
-Infix Local "==" Aequiv (at level 5, no associativity).
-
-Variable S : (Setoid_Theory A Aequiv).
-
-Add Setoid A Aequiv S.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Infix 4 "+" Aplus V8only 50 (left associativity).
-Infix 4 "*" Amult V8only 40 (left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-Notation "- x" := (Aopp x) (at level 0) V8only.
-
-Variable plus_morph : (a,a0,a1,a2:A) a == a0 -> a1 == a2 -> a+a1 == a0+a2.
-Variable mult_morph : (a,a0,a1,a2:A) a == a0 -> a1 == a2 -> a*a1 == a0*a2.
-Variable opp_morph : (a,a0:A) a == a0 -> -a == -a0.
-
-Add Morphism Aplus : Aplus_ext.
-Exact plus_morph.
-Save.
-
-Add Morphism Amult : Amult_ext.
-Exact mult_morph.
-Save.
-
-Add Morphism Aopp : Aopp_ext.
-Exact opp_morph.
-Save.
-
-Section Theory_of_semi_setoid_rings.
-
-Record Semi_Setoid_Ring_Theory : Prop :=
-{ SSR_plus_sym  : (n,m:A) n + m == m + n;
-  SSR_plus_assoc : (n,m,p:A) n + (m + p) == (n + m) + p;
-  SSR_mult_sym : (n,m:A) n*m == m*n;
-  SSR_mult_assoc : (n,m,p:A) n*(m*p) == (n*m)*p;
-  SSR_plus_zero_left :(n:A) 0 + n == n;
-  SSR_mult_one_left : (n:A) 1*n == n;
-  SSR_mult_zero_left : (n:A) 0*n == 0;
-  SSR_distr_left : (n,m,p:A) (n + m)*p == n*p + m*p;
-  SSR_plus_reg_left : (n,m,p:A)n + m == n + p -> m == p;
-  SSR_eq_prop : (x,y:A) (Is_true (Aeq x y)) -> x == y
-}.
-
-Variable T : Semi_Setoid_Ring_Theory.
-
-Local plus_sym  := (SSR_plus_sym T).
-Local plus_assoc := (SSR_plus_assoc T).
-Local mult_sym  := ( SSR_mult_sym T).
-Local mult_assoc := (SSR_mult_assoc T).
-Local plus_zero_left := (SSR_plus_zero_left T).
-Local mult_one_left := (SSR_mult_one_left T). 
-Local mult_zero_left := (SSR_mult_zero_left T).
-Local distr_left := (SSR_distr_left T).
-Local plus_reg_left := (SSR_plus_reg_left T).
-Local equiv_refl := (Seq_refl A Aequiv S).
-Local equiv_sym := (Seq_sym A Aequiv S).
-Local equiv_trans := (Seq_trans A Aequiv S).
-
-Hints Resolve plus_sym plus_assoc mult_sym mult_assoc
-  plus_zero_left mult_one_left mult_zero_left distr_left
-  plus_reg_left equiv_refl (*equiv_sym*).
-Hints Immediate equiv_sym.
-
-(* Lemmas whose form is x=y are also provided in form y=x because
-  Auto does not symmetry *) 
-Lemma SSR_mult_assoc2 : (n,m,p:A) (n * m) * p == n * (m * p).
-Auto. Save.
-
-Lemma SSR_plus_assoc2 : (n,m,p:A) (n + m) + p == n + (m + p).
-Auto. Save.
-
-Lemma SSR_plus_zero_left2 : (n:A) n == 0 + n.
-Auto. Save.
-
-Lemma SSR_mult_one_left2 : (n:A) n == 1*n.
-Auto. Save.
-
-Lemma SSR_mult_zero_left2 : (n:A) 0 == 0*n.
-Auto. Save.
-
-Lemma SSR_distr_left2 : (n,m,p:A) n*p + m*p  == (n + m)*p.
-Auto. Save.
-
-Lemma SSR_plus_permute : (n,m,p:A) n+(m+p) == m+(n+p).
-Intros.
-Rewrite (plus_assoc n m p).
-Rewrite (plus_sym n m).
-Rewrite <- (plus_assoc m n p).
-Trivial.
-Save.
-
-Lemma SSR_mult_permute : (n,m,p:A) n*(m*p) == m*(n*p).
-Intros.
-Rewrite (mult_assoc n m p).
-Rewrite (mult_sym n m).
-Rewrite <- (mult_assoc m n p).
-Trivial.
-Save.
-
-Hints Resolve SSR_plus_permute SSR_mult_permute.
-
-Lemma SSR_distr_right : (n,m,p:A) n*(m+p) == (n*m) + (n*p).
-Intros.
-Rewrite (mult_sym n (Aplus m p)).
-Rewrite (mult_sym n m).
-Rewrite (mult_sym n p).
-Auto.
-Save.
-
-Lemma SSR_distr_right2 : (n,m,p:A) (n*m) + (n*p) == n*(m + p).
-Intros.
-Apply equiv_sym.
-Apply SSR_distr_right.
-Save.
-
-Lemma SSR_mult_zero_right : (n:A) n*0 == 0.
-Intro; Rewrite (mult_sym n Azero); Auto.
-Save.
-
-Lemma SSR_mult_zero_right2 : (n:A) 0 == n*0.
-Intro; Rewrite (mult_sym n Azero); Auto.
-Save.
-
-Lemma SSR_plus_zero_right :(n:A) n + 0 == n.
-Intro; Rewrite (plus_sym n Azero); Auto.
-Save.
-
-Lemma SSR_plus_zero_right2 :(n:A) n == n + 0.
-Intro; Rewrite (plus_sym n Azero); Auto.
-Save.
-
-Lemma SSR_mult_one_right : (n:A) n*1 == n.
-Intro; Rewrite (mult_sym n Aone); Auto.
-Save.
-
-Lemma SSR_mult_one_right2 : (n:A) n == n*1.
-Intro; Rewrite (mult_sym n Aone); Auto.
-Save.
-
-Lemma SSR_plus_reg_right : (n,m,p:A) m+n == p+n -> m==p.
-Intros n m p; Rewrite (plus_sym m n); Rewrite (plus_sym p n).
-Intro; Apply plus_reg_left with n; Trivial.
-Save.
-
-End Theory_of_semi_setoid_rings.
-
-Section Theory_of_setoid_rings.
-
-Record Setoid_Ring_Theory : Prop :=
-{ STh_plus_sym  : (n,m:A) n + m == m + n;
-  STh_plus_assoc : (n,m,p:A) n + (m + p) == (n + m) + p;
-  STh_mult_sym : (n,m:A) n*m == m*n;
-  STh_mult_assoc : (n,m,p:A) n*(m*p) == (n*m)*p;
-  STh_plus_zero_left :(n:A) 0 + n == n;
-  STh_mult_one_left : (n:A) 1*n == n;
-  STh_opp_def : (n:A)  n + (-n) == 0;
-  STh_distr_left : (n,m,p:A) (n + m)*p == n*p + m*p;
-  STh_eq_prop : (x,y:A) (Is_true (Aeq x y)) -> x == y
-}.
-
-Variable T : Setoid_Ring_Theory.
-
-Local plus_sym  := (STh_plus_sym T).
-Local plus_assoc := (STh_plus_assoc T).
-Local mult_sym  := (STh_mult_sym T).
-Local mult_assoc := (STh_mult_assoc T).
-Local plus_zero_left := (STh_plus_zero_left T).
-Local mult_one_left := (STh_mult_one_left T). 
-Local opp_def := (STh_opp_def T).
-Local distr_left := (STh_distr_left T).
-Local equiv_refl := (Seq_refl A Aequiv S).
-Local equiv_sym := (Seq_sym A Aequiv S).
-Local equiv_trans := (Seq_trans A Aequiv S).
-
-Hints Resolve plus_sym plus_assoc mult_sym mult_assoc
-  plus_zero_left mult_one_left opp_def distr_left
-  equiv_refl equiv_sym.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *)
-
-Lemma STh_mult_assoc2 : (n,m,p:A) (n * m) * p == n * (m * p).
-Auto. Save.
-
-Lemma STh_plus_assoc2 : (n,m,p:A) (n + m) + p == n + (m + p).
-Auto. Save.
-
-Lemma STh_plus_zero_left2 : (n:A) n == 0 + n.
-Auto. Save.
-
-Lemma STh_mult_one_left2 : (n:A) n == 1*n.
-Auto. Save.
-
-Lemma STh_distr_left2 : (n,m,p:A) n*p + m*p  == (n + m)*p.
-Auto. Save.
-
-Lemma STh_opp_def2 : (n:A) 0 == n + (-n).
-Auto. Save.
-
-Lemma STh_plus_permute : (n,m,p:A) n + (m + p) == m + (n + p).
-Intros.
-Rewrite (plus_assoc n m p).
-Rewrite (plus_sym n m).
-Rewrite <- (plus_assoc m n p).
-Trivial.
-Save.
-
-Lemma STh_mult_permute : (n,m,p:A) n*(m*p) == m*(n*p).
-Intros.
-Rewrite (mult_assoc n m p).
-Rewrite (mult_sym n m).
-Rewrite <- (mult_assoc m n p).
-Trivial.
-Save.
-
-Hints Resolve STh_plus_permute STh_mult_permute.
-
-Lemma Saux1 : (a:A)  a + a == a -> a == 0.
-Intros.
-Rewrite <- (plus_zero_left a).
-Rewrite (plus_sym Azero a).
-Setoid_replace (Aplus a Azero) with (Aplus a (Aplus a (Aopp a))); Auto.
-Rewrite (plus_assoc a a (Aopp a)).
-Rewrite H.
-Apply opp_def.
-Save.
-
-Lemma STh_mult_zero_left :(n:A) 0*n == 0.
-Intros.
-Apply Saux1.
-Rewrite <- (distr_left Azero Azero n).
-Rewrite (plus_zero_left Azero).
-Trivial.
-Save.
-Hints Resolve STh_mult_zero_left.
-
-Lemma STh_mult_zero_left2 : (n:A) 0 == 0*n.
-Auto.
-Save.
-
-Lemma Saux2 : (x,y,z:A) x+y==0 -> x+z==0 -> y == z.
-Intros.
-Rewrite <- (plus_zero_left y).
-Rewrite <- H0.
-Rewrite <- (plus_assoc x z y).
-Rewrite (plus_sym z y).
-Rewrite (plus_assoc x y z).
-Rewrite H.
-Auto.
-Save.
-
-Lemma STh_opp_mult_left : (x,y:A) -(x*y) == (-x)*y.
-Intros.
-Apply Saux2 with (Amult x y); Auto.
-Rewrite <- (distr_left x (Aopp x) y).
-Rewrite (opp_def x).
-Auto.
-Save.
-Hints Resolve STh_opp_mult_left.
-
-Lemma STh_opp_mult_left2 : (x,y:A) (-x)*y == -(x*y) .
-Auto.
-Save.
-
-Lemma STh_mult_zero_right : (n:A) n*0 == 0.
-Intro; Rewrite (mult_sym n Azero); Auto.
-Save.
-
-Lemma STh_mult_zero_right2 : (n:A) 0 == n*0.
-Intro; Rewrite (mult_sym n Azero); Auto.
-Save.
-
-Lemma STh_plus_zero_right :(n:A) n + 0 == n.
-Intro; Rewrite (plus_sym n Azero); Auto.
-Save.
-
-Lemma STh_plus_zero_right2 :(n:A) n == n + 0.
-Intro; Rewrite (plus_sym n Azero); Auto.
-Save.
-
-Lemma STh_mult_one_right : (n:A) n*1 == n.
-Intro; Rewrite (mult_sym n Aone); Auto.
-Save.
-
-Lemma STh_mult_one_right2  : (n:A) n == n*1.
-Intro; Rewrite (mult_sym n Aone); Auto.
-Save.
-
-Lemma STh_opp_mult_right : (x,y:A) -(x*y) == x*(-y).
-Intros.
-Rewrite (mult_sym x y).
-Rewrite (mult_sym x (Aopp y)).
-Auto.
-Save.
-
-Lemma STh_opp_mult_right2 : (x,y:A) x*(-y) == -(x*y).
-Intros.
-Rewrite (mult_sym x y).
-Rewrite (mult_sym x (Aopp y)).
-Auto.
-Save.
-
-Lemma STh_plus_opp_opp : (x,y:A) (-x) + (-y) == -(x+y).
-Intros.
-Apply Saux2 with (Aplus x y); Auto.
-Rewrite (STh_plus_permute (Aplus x y) (Aopp x) (Aopp y)).
-Rewrite <- (plus_assoc x y (Aopp y)).
-Rewrite (opp_def y); Rewrite (STh_plus_zero_right x).
-Rewrite (STh_opp_def2 x); Trivial.
-Save.
-
-Lemma STh_plus_permute_opp: (n,m,p:A) (-m)+(n+p) == n+((-m)+p).
-Auto.
-Save.
-
-Lemma STh_opp_opp : (n:A) -(-n) == n.
-Intro.
-Apply Saux2 with (Aopp n); Auto.
-Rewrite (plus_sym (Aopp n) n); Auto.
-Save.
-Hints Resolve STh_opp_opp.
-
-Lemma STh_opp_opp2 : (n:A) n == -(-n).
-Auto.
-Save.
-
-Lemma STh_mult_opp_opp : (x,y:A) (-x)*(-y) == x*y.
-Intros.
-Rewrite (STh_opp_mult_left2 x (Aopp y)).
-Rewrite (STh_opp_mult_right2 x y).
-Trivial.
-Save.
-
-Lemma STh_mult_opp_opp2 : (x,y:A) x*y == (-x)*(-y).
-Intros.
-Apply equiv_sym.
-Apply STh_mult_opp_opp.
-Save.
-
-Lemma STh_opp_zero : -0 == 0.
-Rewrite <- (plus_zero_left (Aopp Azero)).
-Trivial.
-Save.
-
-Lemma STh_plus_reg_left : (n,m,p:A) n+m == n+p -> m==p.
-Intros.
-Rewrite <- (plus_zero_left m).
-Rewrite <- (plus_zero_left p).
-Rewrite <- (opp_def n).
-Rewrite (plus_sym n (Aopp n)).
-Rewrite <- (plus_assoc (Aopp n) n m).
-Rewrite <- (plus_assoc (Aopp n) n p).
-Auto.
-Save.
-
-Lemma STh_plus_reg_right : (n,m,p:A) m+n == p+n -> m==p.
-Intros.
-Apply STh_plus_reg_left with n.
-Rewrite (plus_sym n m); Rewrite (plus_sym n p);
-Assumption.
-Save.
-
-Lemma STh_distr_right : (n,m,p:A) n*(m+p) == (n*m)+(n*p).
-Intros.
-Rewrite (mult_sym n (Aplus m p)).
-Rewrite (mult_sym n m).
-Rewrite (mult_sym n p).
-Trivial.
-Save.
-
-Lemma STh_distr_right2 : (n,m,p:A) (n*m)+(n*p) == n*(m+p).
-Intros.
-Apply equiv_sym.
-Apply STh_distr_right.
-Save.
-
-End Theory_of_setoid_rings.
-
-Hints Resolve STh_mult_zero_left STh_plus_reg_left : core.
-
-Unset Implicit Arguments.
-
-Definition Semi_Setoid_Ring_Theory_of :
-  Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory.
-Intros until 1; Case H.
-Split; Intros; Simpl; EAuto.
-Defined.
-
-Coercion Semi_Setoid_Ring_Theory_of :
-  Setoid_Ring_Theory >-> Semi_Setoid_Ring_Theory.
-
-
-
-Section product_ring.
-
-End product_ring.
-
-Section power_ring.
-
-End power_ring.
-
-End Setoid_rings.
diff --git a/contrib7/ring/ZArithRing.v b/contrib7/ring/ZArithRing.v
deleted file mode 100644
index fc7ef29f..00000000
--- a/contrib7/ring/ZArithRing.v
+++ /dev/null
@@ -1,35 +0,0 @@
-(************************************************************************)
-(*  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: ZArithRing.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
-
-(* Instantiation of the Ring tactic for the binary integers of ZArith *)
-
-Require Export ArithRing.
-Require Export ZArith_base.
-Require Eqdep_dec.
-
-Definition Zeq := [x,y:Z]
-  Cases `x ?= y ` of
-    EGAL => true
-  | _ => false
-  end.
-
-Lemma Zeq_prop : (x,y:Z)(Is_true (Zeq x y)) -> x==y.
-  Intros x y H; Unfold Zeq in H.
-  Apply Zcompare_EGAL_eq.
-  NewDestruct (Zcompare x y); [Reflexivity | Contradiction | Contradiction ].
-Save.
-
-Definition ZTheory : (Ring_Theory Zplus Zmult `1` `0` Zopp Zeq).
-  Split; Intros; Apply eq2eqT; EAuto with zarith.
-  Apply eqT2eq; Apply Zeq_prop; Assumption.
-Save.
-
-(* NatConstants and NatTheory are defined in Ring_theory.v *)
-Add Ring Z Zplus Zmult `1` `0` Zopp Zeq ZTheory [POS NEG ZERO xO xI xH].
diff --git a/contrib7/romega/ROmega.v b/contrib7/romega/ROmega.v
deleted file mode 100644
index 7ee246c7..00000000
--- a/contrib7/romega/ROmega.v
+++ /dev/null
@@ -1,12 +0,0 @@
-(*************************************************************************
-
-   PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
-   Licence : LGPL version 2.1
-
- *************************************************************************)
-
-Require Omega.
-Require ReflOmegaCore.
-
-
diff --git a/contrib7/romega/ReflOmegaCore.v b/contrib7/romega/ReflOmegaCore.v
deleted file mode 100644
index 81baa8d9..00000000
--- a/contrib7/romega/ReflOmegaCore.v
+++ /dev/null
@@ -1,2602 +0,0 @@
-(*************************************************************************
-
-   PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
-   Licence du projet : LGPL version 2.1
-
- *************************************************************************)
-
-Require Arith.
-Require PolyList.
-Require Bool.
-Require ZArith.
-Require Import OmegaLemmas.
-
-(* \subsection{Definition of basic types} *)
-
-(* \subsubsection{Environment of propositions (lists) *)
-Inductive PropList : Type := 
-  Pnil : PropList | Pcons : Prop -> PropList -> PropList.
-
-(* Access function for the environment with a default *)
-Fixpoint nthProp [n:nat; l:PropList] : Prop -> Prop :=
-  [default]Cases n l of
-    O (Pcons x l') => x
-  | O other => default
-  | (S m) Pnil => default
-  | (S m) (Pcons x t) => (nthProp m t default)
-  end.
-   
-(* \subsubsection{Définition of reified integer expressions}
-   Terms are either:
-   \begin{itemize}
-   \item integers [Tint]
-   \item variables [Tvar]
-   \item operation over integers (addition, product, opposite, subtraction)
-   The last two are translated in additions and products. *)
-
-Inductive term : Set :=
-   Tint : Z -> term
- | Tplus : term -> term -> term
- | Tmult : term -> term -> term
- | Tminus : term -> term -> term
- | Topp : term -> term
- | Tvar : nat -> term
-.
-
-(* \subsubsection{Definition of reified goals} *)
-(* Very restricted definition of handled predicates that should be extended
-   to cover a wider set of operations.
-   Taking care of negations and disequations require solving more than a
-   goal in parallel. This is a major improvement over previous versions. *)
-
-Inductive proposition : Set :=
-  EqTerm : term -> term -> proposition (* egalité entre termes *)
-| LeqTerm : term -> term -> proposition (* plus petit ou egal *)
-| TrueTerm : proposition (* vrai *)
-| FalseTerm : proposition (* faux *)
-| Tnot : proposition -> proposition (* négation *)
-| GeqTerm : term -> term -> proposition
-| GtTerm : term -> term -> proposition
-| LtTerm : term -> term -> proposition
-| NeqTerm: term -> term -> proposition
-| Tor : proposition -> proposition -> proposition
-| Tand : proposition -> proposition -> proposition
-| Timp : proposition -> proposition -> proposition
-| Tprop : nat -> proposition
-.
-
-(* Definition of goals as a list of hypothesis *)
-Syntactic Definition hyps := (list proposition).      
-
-(* Definition of lists of subgoals  (set of open goals) *)
-Syntactic Definition lhyps := (list hyps).
-
-(* a syngle goal packed in a subgoal list *)
-Syntactic Definition singleton :=  [a: hyps] (cons a (nil hyps)).
-
-(* an absurd goal *)
-Definition absurd := (cons FalseTerm (nil proposition)).
-
-(* \subsubsection{Traces for merging equations}
-   This inductive type describes how the monomial of two equations should be
-   merged when the equations are added.
-
-   For [F_equal], both equations have the same head variable and coefficient
-   must be added, furthermore if coefficients are opposite, [F_cancel] should
-   be used to collapse the term. [F_left] and [F_right] indicate which monomial
-   should be put first in the result *)
-
-Inductive t_fusion : Set :=
-    F_equal : t_fusion | F_cancel : t_fusion
-  | F_left : t_fusion  | F_right : t_fusion.
-
-(* \subsubsection{Rewriting steps to normalize terms} *)
-Inductive step : Set := 
- (* apply the rewriting steps to both subterms of an operation *)
- | C_DO_BOTH : step -> step -> step
- (* apply the rewriting step to the first branch *)
- | C_LEFT : step -> step
- (* apply the rewriting step to the second branch *)
- | C_RIGHT : step -> step
- (* apply two steps consecutively to a term *)
- | C_SEQ : step -> step -> step
- (* empty step *)
- | C_NOP : step
- (* the following operations correspond to actual rewriting *)
- | C_OPP_PLUS : step
- | C_OPP_OPP : step
- | C_OPP_MULT_R : step
- | C_OPP_ONE : step
- (* This is a special step that reduces the term (computation) *)
- | C_REDUCE : step
- | C_MULT_PLUS_DISTR : step
- | C_MULT_OPP_LEFT : step
- | C_MULT_ASSOC_R : step
- | C_PLUS_ASSOC_R : step
- | C_PLUS_ASSOC_L : step
- | C_PLUS_PERMUTE : step
- | C_PLUS_SYM : step
- | C_RED0 : step
- | C_RED1 : step
- | C_RED2 : step
- | C_RED3 : step
- | C_RED4 : step
- | C_RED5 : step
- | C_RED6 : step
- | C_MULT_ASSOC_REDUCED : step
- | C_MINUS :step
- | C_MULT_SYM : step
-.
-
-(* \subsubsection{Omega steps} *)
-(* The following inductive type describes steps as they can be found in
-   the trace coming from the decision procedure Omega. *)
-
-Inductive t_omega : Set :=
-   (* n = 0 n!= 0 *)
- | O_CONSTANT_NOT_NUL : nat -> t_omega
- | O_CONSTANT_NEG : nat -> t_omega
-   (* division et approximation of an equation *)
- | O_DIV_APPROX : Z -> Z -> term -> nat -> t_omega -> nat -> t_omega
-   (* no solution because no exact division *)
- | O_NOT_EXACT_DIVIDE :  Z -> Z -> term -> nat -> nat -> t_omega
-   (* exact division *)
- | O_EXACT_DIVIDE : Z -> term -> nat -> t_omega -> nat -> t_omega
- | O_SUM : Z -> nat -> Z -> nat -> (list t_fusion) -> t_omega -> t_omega
- | O_CONTRADICTION : nat -> nat -> nat -> t_omega
- | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega
- | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega
- | O_CONSTANT_NUL : nat -> t_omega 
- | O_NEGATE_CONTRADICT : nat -> nat -> t_omega
- | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega
- | O_STATE : Z -> step -> nat -> nat -> t_omega -> t_omega.
-
-(* \subsubsection{Règles pour normaliser les hypothèses} *)
-(* Ces règles indiquent comment normaliser les propositions utiles 
-   de chaque hypothèse utile avant la décomposition des hypothèses et 
-   incluent l'étape d'inversion pour la suppression des négations *)
-Inductive p_step : Set :=
-  P_LEFT : p_step -> p_step
-| P_RIGHT :  p_step -> p_step
-| P_INVERT :  step -> p_step
-| P_STEP : step -> p_step
-| P_NOP : p_step
-.
-(* Liste des normalisations a effectuer : avec un constructeur dans le
-   type [p_step] permettant
-   de parcourir à la fois les branches gauches et droit, on pourrait n'avoir
-   qu'une normalisation par hypothèse. Et comme toutes les hypothèses sont 
-   utiles (sinon on ne les incluerait pas), on pourrait remplacer [h_step] 
-   par une simple liste *)
-
-Inductive h_step : Set := pair_step : nat -> p_step -> h_step.
-
-(* \subsubsection{Règles pour décomposer les hypothèses} *)
-(* Ce type permet de se diriger dans les constructeurs logiques formant les
-   prédicats des hypothèses pour aller les décomposer. Ils permettent
-   en particulier d'extraire une hypothèse d'une conjonction avec
-   éventuellement le bon niveau de négations. *)
-
-Inductive direction : Set :=
-   D_left : direction
- | D_right : direction
- | D_mono : direction.
-
-(* Ce type permet d'extraire les composants utiles des hypothèses : que ce
-   soit des hypothèses générées par éclatement d'une disjonction, ou 
-   des équations. Le constructeur terminal indique comment résoudre le système
-   obtenu en recourrant au type de trace d'Omega [t_omega] *)
-
-Inductive e_step : Set :=
-   E_SPLIT : nat -> (list direction) -> e_step -> e_step -> e_step
- | E_EXTRACT : nat -> (list direction) -> e_step -> e_step
- | E_SOLVE : t_omega -> e_step.
-
-(* \subsection{Egalité décidable efficace} *)
-(* Pour chaque type de donnée réifié, on calcule un test d'égalité efficace.
-   Ce n'est pas le cas de celui rendu par [Decide Equality].
-   
-   Puis on prouve deux théorèmes permettant d'éliminer de telles égalités :
-   \begin{verbatim}
-   (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2.
-   (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2.
-   \end{verbatim} *)
-
-(* Ces deux tactiques permettent de résoudre pas mal de cas. L'une pour
-   les théorèmes positifs, l'autre pour les théorèmes négatifs *)
-
-Tactic Definition absurd_case := Simpl; Intros; Discriminate.
-Tactic Definition trivial_case := Unfold not; Intros; Discriminate.
-
-(* \subsubsection{Entiers naturels} *)
-
-Fixpoint eq_nat [t1,t2: nat] : bool := 
-  Cases t1 of
-    O => Cases t2 of O => true | _ => false end
-  | (S n1)=> Cases t2 of O => false | (S n2)  => (eq_nat n1 n2) end
-  end.
-
-Theorem eq_nat_true : (t1,t2: nat) (eq_nat t1 t2) = true -> t1 = t2.
-
-Induction t1; [
-  Intro t2; Case t2; [ Trivial | absurd_case ]
-| Intros n H t2; Case t2; 
-    [ absurd_case |  Simpl; Intros; Rewrite (H n0); [ Trivial | Assumption]]].
-
-Save.
-  
-Theorem eq_nat_false : (t1,t2: nat) (eq_nat t1 t2) = false -> ~t1 = t2.
-
-Induction t1; [
-  Intro t2; Case t2;
-   [ Simpl;Intros; Discriminate | trivial_case ]
-| Intros n H t2; Case t2; Simpl; Unfold not; Intros; [
-    Discriminate
-  | Elim (H n0 H0); Simplify_eq H1; Trivial]].
-
-Save.
-                                   
-
-(* \subsubsection{Entiers positifs} *)
-
-Fixpoint eq_pos [p1,p2 : positive] : bool := 
-  Cases p1 of
-    (xI n1) => Cases p2 of (xI n2) => (eq_pos n1 n2) | _ => false end
-  | (xO n1) =>  Cases p2 of (xO n2) => (eq_pos n1 n2) | _ => false end
-  | xH =>  Cases p2 of xH => true | _ => false end
-  end.
-
-Theorem eq_pos_true : (t1,t2: positive) (eq_pos t1 t2) = true -> t1 = t2.
-
-Induction t1; [
-  Intros p H t2; Case t2; [
-    Simpl; Intros; Rewrite (H p0 H0); Trivial | absurd_case | absurd_case ]
-| Intros p H t2; Case t2; [
-    absurd_case | Simpl; Intros; Rewrite (H p0 H0); Trivial | absurd_case ]
-| Intro t2; Case t2; [ absurd_case | absurd_case | Auto ]].
-
-Save.
-  
-Theorem eq_pos_false : (t1,t2: positive) (eq_pos t1 t2) = false -> ~t1 = t2.
-
-Induction t1; [
-  Intros p H t2; Case t2; [
-    Simpl; Unfold not; Intros; Elim (H p0 H0); Simplify_eq H1; Auto
-  | trivial_case | trivial_case ]
-| Intros p H t2; Case t2; [
-    trivial_case 
-  | Simpl; Unfold not; Intros; Elim (H p0 H0); Simplify_eq H1; Auto
-  | trivial_case ]
-| Intros t2; Case t2; [ trivial_case | trivial_case  | absurd_case ]].
-Save.
-
-(* \subsubsection{Entiers relatifs} *)
-
-Definition eq_Z [z1,z2: Z] : bool :=
-  Cases z1 of
-     ZERO     => Cases z2 of ZERO => true | _ => false end
-   | (POS p1) => Cases z2 of (POS p2) => (eq_pos p1 p2) | _ => false end
-   | (NEG p1) => Cases z2 of (NEG p2) => (eq_pos p1 p2) | _ => false end
-  end.
-
-Theorem eq_Z_true : (t1,t2: Z) (eq_Z t1 t2) = true -> t1 = t2.
-
-Induction t1; [
-  Intros t2; Case t2; [ Auto | absurd_case | absurd_case ]
-| Intros p t2; Case t2; [
-    absurd_case | Simpl; Intros; Rewrite (eq_pos_true p p0 H); Trivial 
-  | absurd_case ]
-| Intros p t2; Case t2; [
-    absurd_case | absurd_case
-  | Simpl; Intros; Rewrite (eq_pos_true p p0 H); Trivial ]].
-
-Save.
-
-Theorem eq_Z_false : (t1,t2: Z) (eq_Z t1 t2) = false -> ~(t1 = t2).
-
-Induction t1; [
-  Intros t2; Case t2; [ absurd_case | trivial_case | trivial_case ]
-| Intros p t2; Case t2; [
-    absurd_case
-  | Simpl; Unfold not; Intros; Elim (eq_pos_false p p0 H); Simplify_eq H0; Auto
-  | trivial_case ]
-| Intros p t2; Case t2; [
-    absurd_case | trivial_case 
-  | Simpl; Unfold not; Intros; Elim (eq_pos_false p p0 H); 
-    Simplify_eq H0; Auto]].
-Save.
-
-(* \subsubsection{Termes réifiés} *)
-
-Fixpoint eq_term [t1,t2: term] : bool := 
-   Cases t1 of
-      (Tint st1) =>
-         Cases t2 of (Tint st2) => (eq_Z st1 st2) | _ => false end
-    | (Tplus st11 st12) =>
-         Cases t2 of
-            (Tplus st21 st22) => 
-               (andb (eq_term st11 st21) (eq_term st12 st22))
-         | _ => false 
-         end
-    | (Tmult st11 st12) =>
-         Cases t2 of
-            (Tmult st21 st22) => 
-               (andb (eq_term st11 st21) (eq_term st12 st22))
-         | _ => false 
-         end
-    | (Tminus st11 st12) =>
-         Cases t2 of
-            (Tminus st21 st22) => 
-               (andb (eq_term st11 st21) (eq_term st12 st22))
-         | _ => false 
-         end
-    | (Topp st1) =>
-         Cases t2 of (Topp st2) => (eq_term st1 st2) | _ => false end
-    | (Tvar st1) =>
-         Cases t2 of (Tvar st2) => (eq_nat st1 st2) | _ => false end
-   end.  
-
-Theorem eq_term_true : (t1,t2: term) (eq_term t1 t2) = true -> t1 = t2.
-
-
-Induction t1; Intros until t2; Case t2; Try absurd_case; Simpl; [
-  Intros; Elim eq_Z_true with 1 := H; Trivial
-| Intros t21 t22 H3; Elim andb_prop with 1:= H3; Intros H4 H5; 
-  Elim H with 1 := H4; Elim H0 with 1 := H5; Trivial
-| Intros t21 t22 H3; Elim andb_prop with 1:= H3; Intros H4 H5;
-  Elim H with 1 := H4; Elim H0 with 1 := H5; Trivial
-| Intros t21 t22 H3; Elim andb_prop with 1:= H3; Intros H4 H5; 
-  Elim H with 1 := H4; Elim H0 with 1 := H5; Trivial
-| Intros t21 H3; Elim H with 1 := H3; Trivial
-| Intros; Elim eq_nat_true with 1 := H; Trivial ].
-
-Save.
-
-Theorem eq_term_false : (t1,t2: term) (eq_term t1 t2) = false -> ~(t1 = t2).
-
-Induction t1; [
-  Intros z t2; Case t2; Try trivial_case; Simpl; Unfold not; Intros;
-  Elim eq_Z_false with 1:=H; Simplify_eq H0; Auto
-| Intros t11 H1 t12 H2 t2; Case t2; Try trivial_case; Simpl; Intros t21 t22 H3;
-  Unfold not; Intro H4; Elim andb_false_elim with 1:= H3; Intros H5; 
-  [ Elim H1 with 1 := H5; Simplify_eq H4; Auto |
-    Elim H2 with 1 := H5; Simplify_eq H4; Auto ]
-| Intros t11 H1 t12 H2 t2; Case t2; Try trivial_case; Simpl; Intros t21 t22 H3;
-  Unfold not; Intro H4; Elim andb_false_elim with 1:= H3; Intros H5; 
-  [ Elim H1 with 1 := H5; Simplify_eq H4; Auto |
-    Elim H2 with 1 := H5; Simplify_eq H4; Auto ]
-| Intros t11 H1 t12 H2 t2; Case t2; Try trivial_case; Simpl; Intros t21 t22 H3;
-  Unfold not; Intro H4; Elim andb_false_elim with 1:= H3; Intros H5; 
-  [ Elim H1 with 1 := H5; Simplify_eq H4; Auto |
-    Elim H2 with 1 := H5; Simplify_eq H4; Auto ]
-| Intros t11 H1 t2; Case t2; Try trivial_case; Simpl; Intros t21 H3;
-  Unfold not; Intro H4; Elim H1 with 1 := H3; Simplify_eq H4; Auto 
-| Intros n t2; Case t2; Try trivial_case; Simpl; Unfold not; Intros;
-  Elim eq_nat_false with 1:=H; Simplify_eq H0; Auto ].
-
-Save.
-
-(* \subsubsection{Tactiques pour éliminer ces tests} 
-
-   Si on se contente de faire un [Case (eq_typ t1 t2)] on perd 
-   totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2].
-
-   Initialement, les développements avaient été réalisés avec les
-   tests rendus par [Decide Equality], c'est à dire un test rendant
-   des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un 
-   tel test préserve bien l'information voulue mais calculatoirement de
-   telles fonctions sont trop lentes. *)
-
-(* Le théorème suivant permet de garder dans les hypothèses la valeur
-   du booléen lors de l'élimination. *)
-
-Theorem bool_ind2 : 
-   (P:(bool->Prop)) (b:bool)
-     (b = true -> (P true))->
-     (b = false -> (P false)) -> (P b).
-
-Induction b; Auto.
-Save.
-
-(* Les tactiques définies si après se comportent exactement comme si on
-   avait utilisé le test précédent et fait une elimination dessus. *)
-
-Tactic Definition Elim_eq_term t1 t2 :=
-  Pattern (eq_term t1 t2); Apply bool_ind2; Intro Aux; [
-    Generalize (eq_term_true t1 t2 Aux); Clear Aux
-  | Generalize (eq_term_false t1 t2 Aux); Clear Aux ].
-
-Tactic Definition Elim_eq_Z t1 t2 :=
-  Pattern (eq_Z t1 t2); Apply bool_ind2; Intro Aux; [
-    Generalize (eq_Z_true t1 t2 Aux); Clear Aux
-  | Generalize (eq_Z_false t1 t2 Aux); Clear Aux ].
-
-Tactic Definition Elim_eq_pos t1 t2 :=
-  Pattern (eq_pos t1 t2); Apply bool_ind2; Intro Aux; [
-    Generalize (eq_pos_true t1 t2 Aux); Clear Aux
-  | Generalize (eq_pos_false t1 t2 Aux); Clear Aux ].
-
-(* \subsubsection{Comparaison sur Z} *)
-
-(* Sujet très lié au précédent : on introduit la tactique d'élimination
-   avec son théorème *)
-
-Theorem relation_ind2 : 
-   (P:(relation->Prop)) (b:relation)
-     (b = EGAL -> (P EGAL))->
-     (b = INFERIEUR -> (P INFERIEUR))->
-     (b = SUPERIEUR -> (P SUPERIEUR)) -> (P b).
-
-Induction b; Auto.
-Save.
-
-Tactic Definition Elim_Zcompare t1 t2 :=
-  Pattern (Zcompare t1 t2); Apply relation_ind2.
-
-(* \subsection{Interprétations}
-   \subsubsection{Interprétation des termes dans Z} *)
-
-Fixpoint interp_term [env:(list Z); t:term] : Z :=
-  Cases t of
-    (Tint x) => x
-  | (Tplus t1 t2) => (Zplus (interp_term env t1) (interp_term env t2))
-  | (Tmult t1 t2) => (Zmult (interp_term env t1) (interp_term env t2))
-  | (Tminus t1 t2) => (Zminus (interp_term env t1) (interp_term env t2))
-  | (Topp t) => (Zopp (interp_term env t))
-  | (Tvar n) => (nth n env ZERO)
-  end.
-
-(* \subsubsection{Interprétation des prédicats} *) 
-Fixpoint interp_proposition 
-    [envp : PropList; env: (list Z); p:proposition] : Prop := 
-  Cases p of
-    (EqTerm t1 t2) => ((interp_term env t1) = (interp_term env t2))
-  | (LeqTerm t1 t2) => `(interp_term env t1) <= (interp_term env t2)`
-  | TrueTerm => True
-  | FalseTerm => False
-  | (Tnot p') => ~(interp_proposition envp env p')
-  | (GeqTerm t1 t2) => `(interp_term env t1) >= (interp_term env t2)`
-  | (GtTerm t1 t2) => `(interp_term env t1) > (interp_term env t2)`
-  | (LtTerm t1 t2) => `(interp_term env t1) < (interp_term env t2)`
-  | (NeqTerm t1 t2) => `(Zne (interp_term env t1) (interp_term env t2))`
-
-  | (Tor p1 p2) => 
-	(interp_proposition envp env p1) \/ (interp_proposition envp env p2)
-  | (Tand p1 p2) =>
-	(interp_proposition envp env p1) /\ (interp_proposition envp env p2)
-  | (Timp p1 p2) =>
-	(interp_proposition envp env p1) -> (interp_proposition envp env p2)
-  | (Tprop n) => (nthProp n envp True)
-  end.
-
-(* \subsubsection{Inteprétation des listes d'hypothèses}
-   \paragraph{Sous forme de conjonction}
-   Interprétation sous forme d'une conjonction d'hypothèses plus faciles
-   à manipuler individuellement *)
-
-Fixpoint interp_hyps [envp: PropList; env : (list Z); l: hyps] : Prop :=
-  Cases l of 
-     nil => True
-   | (cons p' l') => 
-	(interp_proposition envp env p') /\ (interp_hyps envp env l')
-  end.
-
-(* \paragraph{sous forme de but}
-   C'est cette interpétation que l'on utilise sur le but (car on utilise
-   [Generalize] et qu'une conjonction est forcément lourde (répétition des
-   types dans les conjonctions intermédiaires) *)
-
-Fixpoint interp_goal_concl [envp: PropList;env : (list Z); c: proposition; l: hyps] : Prop :=
-  Cases l of 
-     nil => (interp_proposition envp env c)
-   | (cons p' l') => 
-	(interp_proposition envp env p') -> (interp_goal_concl envp env c l')
-  end.
-
-Syntactic Definition interp_goal  :=
-  [envp: PropList;env : (list Z); l: hyps]
-	(interp_goal_concl envp env FalseTerm l).
-
-(* Les théorèmes qui suivent assurent la correspondance entre les deux
-   interprétations. *)
-
-Theorem goal_to_hyps : 
-  (envp: PropList; env : (list Z); l: hyps) 
-     ((interp_hyps envp env l) -> False) -> (interp_goal envp env l).
-
-Induction l; [
-  Simpl; Auto
-| Simpl; Intros a l1 H1 H2 H3; Apply H1; Intro H4; Apply H2; Auto ].
-Save.
-
-Theorem hyps_to_goal : 
-  (envp: PropList; env : (list Z); l: hyps) 
-     (interp_goal envp env l) -> ((interp_hyps envp env l) -> False).
-
-Induction l; Simpl; [
-  Auto
-| Intros; Apply H; Elim H1; Auto ].
-Save.
-      
-(* \subsection{Manipulations sur les hypothèses} *)
-
-(* \subsubsection{Définitions de base de stabilité pour la réflexion} *)
-(* Une opération laisse un terme stable si l'égalité est préservée *)
-Definition term_stable [f: term -> term] :=
- (e: (list Z); t:term) (interp_term e t) = (interp_term e (f t)).
-
-(* Une opération est valide sur une hypothèse, si l'hypothèse implique le
-   résultat de l'opération. \emph{Attention : cela ne concerne que des 
-   opérations sur les hypothèses et non sur les buts (contravariance)}.
-   On définit la validité pour une opération prenant une ou deux propositions
-   en argument (cela suffit pour omega). *)
-
-Definition valid1 [f: proposition -> proposition] :=
-  (ep : PropList; e: (list Z)) (p1: proposition) 
-    (interp_proposition ep e p1) -> (interp_proposition ep e (f p1)).
-
-Definition valid2 [f: proposition -> proposition -> proposition] :=
-  (ep : PropList; e: (list Z)) (p1,p2: proposition) 
-    (interp_proposition ep e p1) -> (interp_proposition ep e p2) ->
-      (interp_proposition ep e (f p1 p2)).
-
-(* Dans cette notion de validité, la fonction prend directement une 
-   liste de propositions et rend une nouvelle liste de proposition. 
-   On reste contravariant *)
-
-Definition valid_hyps [f: hyps -> hyps] :=
-  (ep : PropList; e : (list Z))
-    (lp: hyps) (interp_hyps ep e lp) -> (interp_hyps ep e (f lp)).
-
-(* Enfin ce théorème élimine la contravariance et nous ramène à une 
-   opération sur les buts *)
-
- Theorem valid_goal :
-  (ep: PropList; env : (list Z); l: hyps; a : hyps -> hyps) 
-    (valid_hyps a) -> (interp_goal ep env (a l)) -> (interp_goal ep env l).
-
-Intros; Simpl; Apply goal_to_hyps; Intro H1;
-Apply (hyps_to_goal ep env (a l) H0); Apply H; Assumption.
-Save.
-
-(* \subsubsection{Généralisation a des listes de buts (disjonctions)} *)
-
-
-Fixpoint interp_list_hyps [envp: PropList; env: (list Z); l : lhyps] : Prop :=
-   Cases l of
-      nil => False
-    | (cons h l') => (interp_hyps envp env h) \/ (interp_list_hyps envp env l')
-   end.
-
-Fixpoint interp_list_goal [envp: PropList; env: (list Z);l : lhyps] : Prop :=
-   Cases l of
-      nil => True
-    | (cons h l') => (interp_goal envp env h) /\ (interp_list_goal envp env l')
-   end.
-
-Theorem list_goal_to_hyps : 
-  (envp: PropList; env: (list Z); l: lhyps)
-    ((interp_list_hyps envp env l) -> False) -> (interp_list_goal envp env l).
-
-Induction l; Simpl; [
-  Auto
-| Intros h1 l1 H H1; Split; [
-    Apply goal_to_hyps; Intro H2; Apply H1; Auto
-  | Apply H; Intro H2; Apply H1; Auto ]].
-Save.
-
-Theorem list_hyps_to_goal : 
-  (envp: PropList; env: (list Z); l: lhyps)
-    (interp_list_goal envp env l) -> ((interp_list_hyps envp env l) -> False).
-
-Induction l; Simpl; [
-  Auto
-|  Intros h1 l1 H (H1,H2) H3; Elim H3; Intro H4; [
-     Apply hyps_to_goal with 1 := H1; Assumption
-   | Auto ]].
-Save.
-
-Definition valid_list_hyps [f: hyps -> lhyps] :=
-  (ep : PropList; e : (list Z)) (lp: hyps)
-    (interp_hyps ep e lp) -> (interp_list_hyps ep e (f lp)).
-
-Definition valid_list_goal [f: hyps -> lhyps] :=
-  (ep : PropList; e : (list Z)) (lp: hyps) 
-     (interp_list_goal ep e (f lp)) -> (interp_goal ep e lp) .
-
-Theorem goal_valid : 
-  (f: hyps -> lhyps) (valid_list_hyps f) -> (valid_list_goal f).
-
-Unfold valid_list_goal; Intros f H ep e lp H1; Apply goal_to_hyps;
-Intro H2; Apply list_hyps_to_goal with 1:=H1; Apply (H ep e lp); Assumption.
-Save.
- 
-Theorem append_valid :
-  (ep: PropList; e: (list Z)) (l1,l2:lhyps)
-     (interp_list_hyps ep e l1) \/ (interp_list_hyps ep e l2) ->
-     (interp_list_hyps ep e (app l1 l2)).
-
-Intros ep e; Induction l1; [
-  Simpl; Intros l2 [H | H]; [ Contradiction | Trivial ]
-| Simpl; Intros h1 t1 HR l2 [[H | H] | H] ;[
-    Auto
-  | Right; Apply (HR l2); Left; Trivial
-  | Right; Apply (HR l2); Right; Trivial ]].
-
-Save.
-
-(* \subsubsection{Opérateurs valides sur les hypothèses} *)
-
-(* Extraire une hypothèse de la liste *)
-Definition nth_hyps [n:nat; l: hyps] := (nth n l TrueTerm).
-
-Theorem nth_valid :
-  (ep: PropList; e: (list Z); i:nat; l: hyps) 
-     (interp_hyps ep e l) -> (interp_proposition ep e (nth_hyps i l)).
-
-Unfold nth_hyps; Induction i; [
-  Induction l; Simpl; [ Auto | Intros; Elim H0; Auto ]
-| Intros n H; Induction l;
-    [ Simpl; Trivial | Intros; Simpl; Apply H; Elim H1; Auto ]].
-Save.
-
-(* Appliquer une opération (valide) sur deux hypothèses extraites de 
-   la liste et ajouter le résultat à la liste. *)
-Definition apply_oper_2 
-  [i,j : nat; f : proposition -> proposition -> proposition ] :=
-  [l: hyps] (cons (f (nth_hyps i l)  (nth_hyps j l)) l).
-
-Theorem apply_oper_2_valid :
-  (i,j : nat; f : proposition -> proposition -> proposition )
-    (valid2 f) -> (valid_hyps (apply_oper_2 i j f)).
-
-Intros i j f Hf; Unfold apply_oper_2 valid_hyps; Simpl; Intros lp Hlp; Split;
-  [ Apply Hf; Apply nth_valid; Assumption | Assumption].
-Save.
-
-(* Modifier une hypothèse par application d'une opération valide *)
-
-Fixpoint apply_oper_1 [i:nat] : (proposition -> proposition) -> hyps -> hyps :=
-  [f : (proposition -> proposition); l : hyps] 
-    Cases l of 
-       nil => (nil proposition)
-    | (cons p l') =>
-	 Cases i of
-           O => (cons (f p) l')
-         | (S j) => (cons p (apply_oper_1 j f l'))
-         end
-    end.
-
-Theorem apply_oper_1_valid :
-  (i : nat; f : proposition -> proposition )
-    (valid1 f) -> (valid_hyps (apply_oper_1 i f)).
-
-Unfold valid_hyps; Intros i f Hf ep e; Elim i; [
-  Intro lp; Case lp; [
-    Simpl; Trivial
-  | Simpl; Intros p l' (H1, H2); Split; [ Apply Hf with 1:=H1 | Assumption ]]
-| Intros n Hrec lp; Case lp; [
-    Simpl; Auto
-  | Simpl; Intros p l' (H1, H2); 
-    Split; [ Assumption | Apply Hrec; Assumption ]]].
-
-Save.
-
-(* \subsubsection{Manipulations de termes} *)
-(* Les fonctions suivantes permettent d'appliquer une fonction de
-   réécriture sur un sous terme du terme principal. Avec la composition,
-   cela permet de construire des réécritures complexes proches des 
-   tactiques de conversion *)
-
-Definition apply_left [f: term -> term; t : term]:= 
-  Cases t of
-    (Tplus x y) => (Tplus (f x) y)
-  | (Tmult x y) => (Tmult (f x) y)
-  | (Topp x) => (Topp (f x))
-  | x => x
-  end.
-
-Definition apply_right [f: term -> term; t : term]:= 
-  Cases t of
-    (Tplus x y) => (Tplus x (f y))
-  | (Tmult x y) => (Tmult x (f y))
-  | x => x
-  end.
-
-Definition apply_both [f,g: term -> term; t : term]:= 
-  Cases t of
-    (Tplus x y) => (Tplus (f x) (g y))
-  | (Tmult x y) => (Tmult (f x) (g y))
-  | x => x
-  end.
-
-(* Les théorèmes suivants montrent la stabilité (conditionnée) des 
-   fonctions. *)
-
-Theorem apply_left_stable :
-  (f: term -> term) (term_stable f) -> (term_stable (apply_left f)).
-
-Unfold term_stable; Intros f H e t; Case t; Auto; Simpl; 
-Intros;  Elim H; Trivial.
-Save.
-
-Theorem apply_right_stable :
-  (f: term -> term) (term_stable f) -> (term_stable (apply_right f)).
-
-Unfold term_stable; Intros f H e t; Case t; Auto; Simpl; 
-Intros t0 t1; Elim H; Trivial.
-Save.
-
-Theorem apply_both_stable :
-  (f,g: term -> term) (term_stable f) -> (term_stable g) -> 
-     (term_stable (apply_both f g)).
-
-Unfold term_stable; Intros f g H1 H2 e t; Case t; Auto; Simpl; 
-Intros t0 t1; Elim H1; Elim H2; Trivial.
-Save.
-
-Theorem compose_term_stable :
-  (f,g: term -> term) (term_stable f) -> (term_stable g) -> 
-    (term_stable [t: term](f (g t))).
-
-Unfold term_stable; Intros f g Hf Hg e t; Elim Hf; Apply Hg.
-Save.
-
-(* \subsection{Les règles de réécriture} *)
-(* Chacune des règles de réécriture est accompagnée par sa preuve de 
-   stabilité. Toutes ces preuves ont la même forme : il faut analyser 
-   suivant la forme du terme (élimination de chaque Case). On a besoin d'une
-   élimination uniquement dans les cas d'utilisation d'égalité décidable. 
-
-   Cette tactique itère la décomposition des Case. Elle est
-   constituée de deux fonctions s'appelant mutuellement :
-   \begin{itemize} 
-    \item une fonction d'enrobage qui lance la recherche sur le but,
-    \item une fonction récursive qui décompose ce but. Quand elle a trouvé un
-          Case, elle l'élimine. 
-   \end{itemize}  
-   Les motifs sur les cas sont très imparfaits et dans certains cas, il
-   semble que cela ne marche pas. On aimerait plutot un motif de la
-   forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on 
-   utilise le bon type.
-
-   Chaque élimination introduit correctement exactement le nombre d'hypothèses
-   nécessaires et conserve dans le cas d'une égalité la connaissance du
-   résultat du test en faisant la réécriture. Pour un test de comparaison,
-   on conserve simplement le résultat.
-
-   Cette fonction déborde très largement la résolution des réécritures
-   simples et fait une bonne partie des preuves des pas de Omega.
-*)
-
-(* \subsubsection{La tactique pour prouver la stabilité} *)
-
-Recursive Tactic Definition loop t := (
-  Match t With
-  (* Global *)
-    [(?1 = ?2)] -> (loop ?1) Orelse (loop ?2)
-  | [ ? -> ?1 ] ->  (loop ?1)
-  (* Interpretations *)
-  | [ (interp_hyps ? ? ?1) ] -> (loop ?1)
-  | [ (interp_list_hyps ? ? ?1) ] -> (loop ?1)
-  | [ (interp_proposition ? ? ?1) ] -> (loop ?1)
-  | [ (interp_term ? ?1) ] -> (loop ?1)
-  (* Propositions *)
-  | [(EqTerm ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
-  | [(LeqTerm ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
-  (* Termes *)
-  | [(Tplus ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
-  | [(Tminus ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
-  | [(Tmult ?1 ?2)] -> (loop ?1) Orelse (loop ?2)
-  | [(Topp ?1)] -> (loop ?1)
-  | [(Tint ?1)] -> (loop ?1)
-  (* Eliminations *)
-  |  [(Cases ?1 of
-        | (EqTerm _ _) => ?
-        | (LeqTerm _ _) => ?
-        | TrueTerm => ?
-        | FalseTerm => ?
-        | (Tnot _) => ?
-        | (GeqTerm _ _) => ?
-        | (GtTerm _ _) => ?
-        | (LtTerm _ _) => ?
-        | (NeqTerm _ _) => ?
-        | (Tor _ _) => ?
-        | (Tand _ _) => ?
-        | (Timp _ _) => ?
-        | (Tprop _) => ?
-        end)] -> 
-       (Case ?1; [ Intro; Intro | Intro; Intro | Idtac | Idtac 
-                 | Intro | Intro; Intro | Intro; Intro | Intro; Intro
-                 | Intro; Intro
-                 | Intro;Intro | Intro;Intro | Intro;Intro | Intro  ]);
-        Auto; Simplify
-  | [(Cases ?1 of
-        (Tint _) => ?
-      | (Tplus _ _) => ?
-      | (Tmult _ _) => ?
-      | (Tminus _ _) => ?
-      | (Topp _) => ?
-      | (Tvar _) => ?
-      end)] -> 
-       (Case ?1; [ Intro | Intro; Intro | Intro; Intro | Intro; Intro | 
-                   Intro | Intro ]); Auto; Simplify
-  | [(Cases (Zcompare ?1 ?2) of
-        EGAL => ?
-      | INFERIEUR => ?
-      | SUPERIEUR => ?
-      end)] -> 
-       (Elim_Zcompare ?1 ?2) ; Intro ; Auto; Simplify
-  | [(Cases ?1 of ZERO => ? | (POS _) => ? | (NEG _) => ? end)] -> 
-       (Case ?1; [ Idtac | Intro | Intro ]); Auto; Simplify
-  | [(if (eq_Z ?1 ?2) then ? else ?)] -> 
-       ((Elim_eq_Z ?1 ?2); Intro H; [Rewrite H; Clear H | Clear H]);
-       Simpl; Auto; Simplify
-  | [(if (eq_term ?1 ?2) then ? else ?)] -> 
-       ((Elim_eq_term ?1 ?2); Intro H; [Rewrite H; Clear H | Clear H]); 
-       Simpl; Auto; Simplify
-  | [(if (eq_pos ?1 ?2) then ? else ?)] -> 
-       ((Elim_eq_pos ?1 ?2); Intro H; [Rewrite H; Clear H | Clear H]);
-       Simpl; Auto; Simplify
-  | _ -> Fail)
-And Simplify := (
-  Match Context With [|- ?1 ] -> Try (loop ?1) | _ -> Idtac).
-
-
-Tactic Definition ProveStable x th :=
-  (Match x With [?1] -> Unfold term_stable ?1; Intros; Simplify; Simpl; Apply th).
-
-(* \subsubsection{Les règles elle mêmes} *)
-Definition Tplus_assoc_l [t: term] :=
-  Cases t of
-    (Tplus n (Tplus m p)) => (Tplus (Tplus n m) p)
-  | _ => t
-  end.
-
-Theorem  Tplus_assoc_l_stable : (term_stable  Tplus_assoc_l).
-
-(ProveStable Tplus_assoc_l Zplus_assoc_l).
-Save.
-
-Definition Tplus_assoc_r [t: term] :=
-  Cases t of
-    (Tplus (Tplus n m) p) => (Tplus n (Tplus m p))
-  | _ => t
-  end.
-
-Theorem  Tplus_assoc_r_stable : (term_stable  Tplus_assoc_r).
-
-(ProveStable Tplus_assoc_r Zplus_assoc_r).
-Save.
-
-Definition Tmult_assoc_r [t: term] :=
-  Cases t of
-    (Tmult (Tmult n m) p) => (Tmult n (Tmult m p))
-  | _ => t
-  end.
-
-Theorem  Tmult_assoc_r_stable : (term_stable  Tmult_assoc_r).
-
-(ProveStable Tmult_assoc_r Zmult_assoc_r).
-Save.
-
-Definition Tplus_permute [t: term] :=
-  Cases t of
-    (Tplus n (Tplus m p)) => (Tplus m (Tplus n p))
-  | _ => t
-  end.
-
-Theorem  Tplus_permute_stable : (term_stable  Tplus_permute).
-
-(ProveStable Tplus_permute Zplus_permute).
-Save.
-
-Definition Tplus_sym [t: term] :=
-  Cases t of
-    (Tplus x y) => (Tplus y x)
-  | _ => t
-  end.
-
-Theorem Tplus_sym_stable : (term_stable Tplus_sym).
-
-(ProveStable Tplus_sym Zplus_sym).
-Save.
-
-Definition Tmult_sym [t: term] :=
-  Cases t of
-    (Tmult x y) => (Tmult y x)
-  | _ => t
-  end.
-
-Theorem Tmult_sym_stable : (term_stable Tmult_sym).
-
-(ProveStable Tmult_sym Zmult_sym).
-Save.
-
-Definition T_OMEGA10 [t: term] :=
-  Cases t of
-    (Tplus (Tmult (Tplus (Tmult v (Tint c1)) l1) (Tint k1))
-           (Tmult (Tplus (Tmult v' (Tint c2)) l2) (Tint k2))) =>
-	Case (eq_term v v') of
-	    (Tplus (Tmult v (Tint (Zplus (Zmult c1 k1) (Zmult c2 k2)))) 
-                   (Tplus (Tmult l1 (Tint k1)) (Tmult l2 (Tint k2))))
-           t
-        end
-  | _ => t
-  end.
-
-Theorem  T_OMEGA10_stable : (term_stable  T_OMEGA10).
-
-(ProveStable T_OMEGA10 OMEGA10).
-Save.
-
-Definition T_OMEGA11 [t: term] :=
-  Cases t of
-    (Tplus (Tmult (Tplus (Tmult v1 (Tint c1)) l1) (Tint k1)) l2) =>
-	(Tplus (Tmult v1 (Tint (Zmult c1 k1))) (Tplus (Tmult l1 (Tint k1)) l2))
-  | _ => t
-  end.
-
-Theorem  T_OMEGA11_stable : (term_stable  T_OMEGA11).
-
-(ProveStable T_OMEGA11 OMEGA11).
-Save.
-
-Definition T_OMEGA12 [t: term] :=
-  Cases t of
-    (Tplus l1 (Tmult (Tplus (Tmult v2 (Tint c2)) l2) (Tint k2))) =>
-        (Tplus (Tmult v2 (Tint (Zmult c2 k2))) (Tplus l1 (Tmult l2 (Tint k2))))
-  | _ => t
-  end.
-
-Theorem  T_OMEGA12_stable : (term_stable  T_OMEGA12).
-
-(ProveStable T_OMEGA12 OMEGA12).
-Save. 
-
-Definition T_OMEGA13 [t: term] :=
-  Cases t of
-    (Tplus (Tplus (Tmult v (Tint (POS x))) l1) 
-	   (Tplus (Tmult v' (Tint (NEG x'))) l2)) =>
-	Case (eq_term v v') of
-	  Case (eq_pos x x') of
-	    (Tplus l1 l2)
-            t
-	  end
-	  t
-	end
-  | (Tplus (Tplus (Tmult v (Tint (NEG x))) l1) 
-	   (Tplus (Tmult v' (Tint (POS x'))) l2)) =>
-	Case (eq_term v v') of
-	  Case (eq_pos x x') of
-	    (Tplus l1 l2)
-             t
-	  end
-	  t
-	end
-
-  | _ => t
-  end.
-
-Theorem  T_OMEGA13_stable : (term_stable  T_OMEGA13).
-
-Unfold term_stable T_OMEGA13; Intros; Simplify; Simpl; 
-  [ Apply OMEGA13 | Apply OMEGA14 ].
-Save.
-
-Definition T_OMEGA15 [t: term] :=
-  Cases t of
-    (Tplus (Tplus (Tmult v (Tint c1)) l1) 
-	   (Tmult (Tplus (Tmult v' (Tint c2)) l2) (Tint k2))) =>
-	Case (eq_term v v') of
-	  (Tplus (Tmult v (Tint (Zplus c1 (Zmult c2 k2))))
-	                  (Tplus l1 (Tmult l2 (Tint k2))))
-	  t
-	end
-  | _ => t
-  end.
-
-Theorem  T_OMEGA15_stable : (term_stable  T_OMEGA15).
-
-(ProveStable T_OMEGA15 OMEGA15).
-Save.
-
-Definition T_OMEGA16 [t: term] :=
-  Cases t of
-    (Tmult (Tplus (Tmult v (Tint c)) l) (Tint k)) =>
-       (Tplus (Tmult v (Tint (Zmult c k))) (Tmult l (Tint k)))
-  | _ => t
-  end.
-
-
-Theorem  T_OMEGA16_stable : (term_stable  T_OMEGA16).
-
-(ProveStable T_OMEGA16 OMEGA16).
-Save.
-
-Definition Tred_factor5 [t: term] := 
-   Cases t of
-      (Tplus (Tmult x (Tint ZERO)) y) => y
-   | _ => t
-   end.
-
-Theorem Tred_factor5_stable : (term_stable  Tred_factor5).
-
-
-(ProveStable Tred_factor5 Zred_factor5).
-Save.
-
-Definition Topp_plus [t: term] :=
-  Cases t of
-    (Topp (Tplus x y)) => (Tplus (Topp x) (Topp y))
-  | _ => t
-  end.
-
-Theorem Topp_plus_stable : (term_stable Topp_plus).
-
-(ProveStable Topp_plus Zopp_Zplus).
-Save.
-
-
-Definition Topp_opp [t: term] :=
-  Cases t of
-    (Topp (Topp x)) => x
-  | _ => t
-  end.
-
-Theorem Topp_opp_stable : (term_stable Topp_opp).
-
-(ProveStable Topp_opp Zopp_Zopp).
-Save.
-
-Definition Topp_mult_r [t: term] :=
-  Cases t of
-    (Topp (Tmult x (Tint k))) => (Tmult x (Tint (Zopp k)))
-  | _ => t
-  end.
-
-Theorem Topp_mult_r_stable : (term_stable Topp_mult_r).
-
-(ProveStable Topp_mult_r Zopp_Zmult_r).
-Save.
-
-Definition Topp_one [t: term] :=
-  Cases t of
-    (Topp x) => (Tmult x (Tint `-1`))
-  | _ => t
-  end.
-
-Theorem Topp_one_stable : (term_stable Topp_one).
-
-(ProveStable Topp_one Zopp_one).
-Save.
-
-Definition Tmult_plus_distr  [t: term] :=
-  Cases t of
-    (Tmult (Tplus n m) p) => (Tplus (Tmult n p) (Tmult m p))
-  | _ => t
-  end.
-
-Theorem Tmult_plus_distr_stable : (term_stable Tmult_plus_distr).
-
-(ProveStable Tmult_plus_distr Zmult_plus_distr).
-Save.
-
-Definition Tmult_opp_left [t: term] :=
-  Cases t of
-    (Tmult (Topp x) (Tint y)) => (Tmult x (Tint (Zopp y)))
-  | _ => t
-  end.
-
-Theorem Tmult_opp_left_stable : (term_stable Tmult_opp_left).
-
-(ProveStable Tmult_opp_left Zmult_Zopp_left).
-Save.
-
-Definition Tmult_assoc_reduced [t: term] :=
-  Cases t of
-    (Tmult (Tmult n (Tint m)) (Tint p)) => (Tmult n (Tint (Zmult m p)))
-  | _ => t
-  end.
-
-Theorem  Tmult_assoc_reduced_stable : (term_stable  Tmult_assoc_reduced).
-
-(ProveStable Tmult_assoc_reduced Zmult_assoc_r).
-Save.
-
-Definition Tred_factor0 [t: term] := (Tmult t (Tint `1`)).
-
-Theorem  Tred_factor0_stable : (term_stable  Tred_factor0).
-
-(ProveStable Tred_factor0 Zred_factor0).
-Save.
-
-Definition Tred_factor1 [t: term] :=
-  Cases t of
-    (Tplus x y) => 
-	Case (eq_term x y) of
-	  (Tmult x (Tint `2`))
-	  t
-        end
-  | _ => t
-  end.
-
-Theorem  Tred_factor1_stable : (term_stable  Tred_factor1).
-
-(ProveStable Tred_factor1 Zred_factor1).
-Save.
-
-Definition Tred_factor2 [t: term] :=
-  Cases t of
-    (Tplus x (Tmult y (Tint k))) => 
-	Case (eq_term x y) of
-	  (Tmult x (Tint (Zplus `1` k)))
-	  t
-        end
-  | _ => t
-  end.
-
-(* Attention : il faut rendre opaque [Zplus] pour éviter que la tactique
-   de simplification n'aille trop loin et défasse [Zplus 1 k] *)
-
-Opaque Zplus.
-
-Theorem  Tred_factor2_stable : (term_stable  Tred_factor2).
-(ProveStable Tred_factor2 Zred_factor2).
-Save.
-
-Definition Tred_factor3 [t: term] :=
-  Cases t of
-    (Tplus (Tmult x (Tint k)) y) => 
-	Case (eq_term x y) of
-	  (Tmult x (Tint `1+k`))
-	  t
-        end
-  | _ => t
-  end.
-
-Theorem  Tred_factor3_stable : (term_stable  Tred_factor3).
-
-(ProveStable Tred_factor3 Zred_factor3).
-Save.
-
-
-Definition Tred_factor4 [t: term] :=
-  Cases t of
-    (Tplus (Tmult x (Tint k1)) (Tmult y (Tint k2))) => 
-	Case (eq_term x y) of
-	  (Tmult x (Tint `k1+k2`))
-	  t
-        end
-  | _ => t
-  end.
-
-Theorem  Tred_factor4_stable : (term_stable  Tred_factor4).
-
-(ProveStable Tred_factor4 Zred_factor4).
-Save.
-
-Definition Tred_factor6 [t: term] := (Tplus t (Tint `0`)).
-
-Theorem  Tred_factor6_stable : (term_stable  Tred_factor6).
-
-(ProveStable Tred_factor6 Zred_factor6).
-Save.
-
-Transparent Zplus.
-
-Definition Tminus_def [t:term] :=
-  Cases t of
-    (Tminus x y) => (Tplus x (Topp y))
-  | _ => t
-  end.
-
-Theorem  Tminus_def_stable : (term_stable  Tminus_def).
-
-(* Le théorème ne sert à rien. Le but est prouvé avant. *)
-(ProveStable Tminus_def False).
-Save.
-
-(* \subsection{Fonctions de réécriture complexes} *)
-
-(* \subsubsection{Fonction de réduction} *)
-(* Cette fonction réduit un terme dont la forme normale est un entier. Il
-   suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs
-   réifiés. La réduction est ``gratuite''.  *)
-
-Fixpoint reduce [t:term] : term :=
-  Cases t of
-     (Tplus x y) =>
-	 Cases (reduce x) of
-	   (Tint x') =>
-	      Cases (reduce y) of
-	        (Tint y') => (Tint (Zplus x' y'))
-              | y' => (Tplus (Tint x') y')
-              end
-         | x' => (Tplus x' (reduce y))
-	 end
-  | (Tmult x y) =>
-	 Cases (reduce x) of
-	   (Tint x') =>
-	      Cases (reduce y) of
-	        (Tint y') => (Tint (Zmult x' y'))
-              | y' => (Tmult (Tint x') y')
-              end
-         | x' => (Tmult x' (reduce y))
-	 end
-  | (Tminus x y) =>
-	 Cases (reduce x) of
-	   (Tint x') =>
-	      Cases (reduce y) of
-	        (Tint y') => (Tint (Zminus x' y'))
-              | y' => (Tminus (Tint x') y')
-              end
-         | x' => (Tminus x' (reduce y))
-	 end
-  | (Topp x) =>
-        Cases (reduce x) of
-	  (Tint x') => (Tint (Zopp x'))
-	| x' => (Topp x')
-	end
-  | _ => t
-  end.
-
-Theorem reduce_stable : (term_stable reduce).
-
-Unfold term_stable; Intros e t; Elim t; Auto; 
-Try (Intros t0 H0 t1 H1; Simpl; Rewrite H0; Rewrite H1; (
- Case (reduce t0); [ 
-   Intro z0; Case (reduce t1); Intros; Auto
- | Intros; Auto
- | Intros; Auto
- | Intros; Auto
- | Intros; Auto
- | Intros; Auto ]));
-Intros t0 H0; Simpl; Rewrite H0; Case (reduce t0); Intros; Auto.
-Save.
-
-(* \subsubsection{Fusions}
-    \paragraph{Fusion de deux équations} *)
-(* On donne une somme de deux équations qui sont supposées normalisées. 
-   Cette fonction prend une trace de fusion en argument et transforme
-   le terme en une équation normalisée. C'est une version très simplifiée
-   du moteur de réécriture [rewrite]. *)
-
-Fixpoint fusion [trace : (list t_fusion)] : term -> term := [t: term]
-  Cases trace of
-    nil => (reduce t)
-  | (cons step trace') =>
-	Cases step of
-        | F_equal => 
-	    (apply_right (fusion trace') (T_OMEGA10 t))
-        | F_cancel => 
-	    (fusion trace' (Tred_factor5 (T_OMEGA10 t)))
-        | F_left => 
-	    (apply_right (fusion trace') (T_OMEGA11 t))
-        | F_right =>
-	    (apply_right (fusion trace') (T_OMEGA12 t))
-	end
-  end.
-    
-Theorem fusion_stable : (t : (list t_fusion)) (term_stable (fusion t)).
-
-Induction t; Simpl; [
-  Exact reduce_stable
-| Intros stp l H; Case stp; [
-    Apply compose_term_stable; 
-      [ Apply apply_right_stable; Assumption | Exact T_OMEGA10_stable ]
-  | Unfold term_stable; Intros e t1; Rewrite T_OMEGA10_stable; 
-    Rewrite Tred_factor5_stable; Apply H
-  | Apply compose_term_stable; 
-      [ Apply apply_right_stable; Assumption | Exact T_OMEGA11_stable ]
-  | Apply compose_term_stable;
-      [ Apply apply_right_stable; Assumption | Exact T_OMEGA12_stable ]]].
-
-Save.
-
-(* \paragraph{Fusion de deux équations dont une sans coefficient} *)
-
-Definition fusion_right [trace : (list t_fusion)] : term -> term := [t: term]
-  Cases trace of
-    nil => (reduce t)  (* Il faut mettre un compute *)
-  | (cons step trace') =>
-	Cases step of
-        | F_equal => 
-	    (apply_right (fusion trace') (T_OMEGA15 t))
-        | F_cancel => 
-	    (fusion trace' (Tred_factor5 (T_OMEGA15 t)))
-        | F_left => 
-	    (apply_right (fusion trace') (Tplus_assoc_r t))
-        | F_right =>
-	    (apply_right (fusion trace') (T_OMEGA12 t))
-	end
-  end.
-
-(* \paragraph{Fusion avec anihilation} *)
-(* Normalement le résultat est une constante *)
-
-Fixpoint fusion_cancel [trace:nat] : term -> term := [t:term]
-  Cases trace of
-    O => (reduce t)
-  | (S trace') => (fusion_cancel trace' (T_OMEGA13 t))
-  end.
-
-Theorem fusion_cancel_stable : (t:nat) (term_stable (fusion_cancel t)).
-
-Unfold term_stable fusion_cancel; Intros trace e; Elim trace; [
-  Exact (reduce_stable e)
-| Intros n H t; Elim H; Exact (T_OMEGA13_stable e t) ].
-Save. 
-
-(* \subsubsection{Opérations afines sur une équation} *)
-(* \paragraph{Multiplication scalaire et somme d'une constante} *)
-
-Fixpoint scalar_norm_add [trace:nat] : term -> term := [t: term]
-  Cases trace of
-    O => (reduce t)
-  | (S trace') => (apply_right (scalar_norm_add trace') (T_OMEGA11 t))
-  end.
-
-Theorem scalar_norm_add_stable : (t:nat) (term_stable (scalar_norm_add t)).
-
-Unfold term_stable scalar_norm_add; Intros trace; Elim trace; [
-  Exact reduce_stable
-| Intros n H e t; Elim apply_right_stable; 
-    [ Exact (T_OMEGA11_stable e t) | Exact H ]].
-Save.
-   
-(* \paragraph{Multiplication scalaire} *)
-Fixpoint scalar_norm [trace:nat] : term -> term := [t: term]
-  Cases trace of
-    O => (reduce t)
-  | (S trace') => (apply_right (scalar_norm trace') (T_OMEGA16 t))
-  end.
-
-Theorem scalar_norm_stable : (t:nat) (term_stable (scalar_norm t)).
-
-Unfold term_stable scalar_norm; Intros trace; Elim trace; [
-  Exact reduce_stable
-| Intros n H e t; Elim apply_right_stable;
-    [ Exact (T_OMEGA16_stable e t) | Exact H ]].
-Save.
-
-(* \paragraph{Somme d'une constante} *)
-Fixpoint add_norm [trace:nat] : term -> term := [t: term]
-  Cases trace of
-    O => (reduce t)
-  | (S trace') => (apply_right (add_norm trace') (Tplus_assoc_r t))
-  end.
-
-Theorem add_norm_stable : (t:nat) (term_stable (add_norm t)).
-
-Unfold term_stable add_norm; Intros trace; Elim trace; [
-  Exact reduce_stable
-| Intros n H e t; Elim apply_right_stable;
-    [ Exact (Tplus_assoc_r_stable e t) | Exact H ]].
-Save.
-
-(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *)
-
-
-Fixpoint rewrite [s: step] : term -> term :=
-  Cases s of 
-   | (C_DO_BOTH s1 s2) => (apply_both (rewrite s1) (rewrite s2))
-   | (C_LEFT s) => (apply_left (rewrite s))
-   | (C_RIGHT s) => (apply_right (rewrite s))
-   | (C_SEQ s1 s2) => [t: term] (rewrite s2 (rewrite s1 t))
-   | C_NOP => [t:term] t
-   | C_OPP_PLUS => Topp_plus
-   | C_OPP_OPP => Topp_opp
-   | C_OPP_MULT_R => Topp_mult_r
-   | C_OPP_ONE => Topp_one
-   | C_REDUCE => reduce
-   | C_MULT_PLUS_DISTR => Tmult_plus_distr
-   | C_MULT_OPP_LEFT => Tmult_opp_left
-   | C_MULT_ASSOC_R => Tmult_assoc_r
-   | C_PLUS_ASSOC_R => Tplus_assoc_r
-   | C_PLUS_ASSOC_L => Tplus_assoc_l
-   | C_PLUS_PERMUTE => Tplus_permute
-   | C_PLUS_SYM => Tplus_sym
-   | C_RED0 => Tred_factor0
-   | C_RED1 => Tred_factor1
-   | C_RED2 => Tred_factor2
-   | C_RED3 => Tred_factor3
-   | C_RED4 => Tred_factor4
-   | C_RED5 => Tred_factor5
-   | C_RED6 => Tred_factor6
-   | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced
-   | C_MINUS => Tminus_def
-   | C_MULT_SYM => Tmult_sym
-  end.
-
-Theorem rewrite_stable : (s:step) (term_stable (rewrite s)).
-
-Induction s; Simpl; [
-  Intros; Apply apply_both_stable; Auto
-| Intros; Apply apply_left_stable; Auto
-| Intros; Apply apply_right_stable; Auto
-| Unfold term_stable; Intros; Elim H0; Apply H
-| Unfold term_stable; Auto
-| Exact Topp_plus_stable
-| Exact Topp_opp_stable
-| Exact Topp_mult_r_stable
-| Exact Topp_one_stable
-| Exact reduce_stable
-| Exact Tmult_plus_distr_stable
-| Exact Tmult_opp_left_stable
-| Exact Tmult_assoc_r_stable
-| Exact Tplus_assoc_r_stable
-| Exact Tplus_assoc_l_stable
-| Exact Tplus_permute_stable
-| Exact Tplus_sym_stable
-| Exact Tred_factor0_stable
-| Exact Tred_factor1_stable
-| Exact Tred_factor2_stable
-| Exact Tred_factor3_stable
-| Exact Tred_factor4_stable
-| Exact Tred_factor5_stable
-| Exact Tred_factor6_stable
-| Exact Tmult_assoc_reduced_stable
-| Exact Tminus_def_stable
-| Exact Tmult_sym_stable ].
-Save.
-
-(* \subsection{tactiques de résolution d'un but omega normalisé} 
-   Trace de la procédure 
-\subsubsection{Tactiques générant une contradiction}
-\paragraph{[O_CONSTANT_NOT_NUL]} *)
-
-Definition constant_not_nul [i:nat; h: hyps] :=
-  Cases (nth_hyps i h) of
-     (EqTerm (Tint ZERO) (Tint n)) =>
-	Case (eq_Z n ZERO) of
-	    h
-            absurd
-        end
-   | _ => h
-  end.
-
-Theorem constant_not_nul_valid : 
-  (i:nat) (valid_hyps (constant_not_nul i)).
-
-Unfold valid_hyps constant_not_nul; Intros;
-Generalize (nth_valid ep e i lp); Simplify; Simpl; (Elim_eq_Z z0 ZERO); Auto;
-Simpl; Intros H1 H2; Elim H1; Symmetry; Auto.
-Save.   
-
-(* \paragraph{[O_CONSTANT_NEG]} *)
-
-Definition constant_neg [i:nat; h: hyps] :=
-   Cases (nth_hyps i h) of
-      (LeqTerm (Tint ZERO) (Tint (NEG n))) => absurd
-   | _ => h
-   end.
-
-Theorem constant_neg_valid : (i:nat) (valid_hyps (constant_neg i)).
-
-Unfold valid_hyps constant_neg; Intros;
-Generalize (nth_valid ep e i lp); Simplify; Simpl; Unfold Zle; Simpl;
-Intros H1; Elim H1; [ Assumption | Trivial ].
-Save.   
-
-(* \paragraph{[NOT_EXACT_DIVIDE]} *)
-Definition not_exact_divide [k1,k2:Z; body:term; t:nat; i : nat; l:hyps] :=
-  Cases (nth_hyps i l) of
-      (EqTerm (Tint ZERO) b) =>
-         Case (eq_term
-	         (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) b) of
-	   Cases (Zcompare k2 ZERO) of
-	     SUPERIEUR =>
-	       Cases (Zcompare k1 k2) of
-		 SUPERIEUR => absurd
-	       | _ => l
-	       end
-	   | _ => l
-           end
-	   l
-         end
-   | _ => l
-   end.
-
-Theorem not_exact_divide_valid : (k1,k2:Z; body:term; t:nat; i:nat) 
-	(valid_hyps (not_exact_divide k1 k2 body t i)).
-
-Unfold valid_hyps not_exact_divide; Intros; Generalize (nth_valid ep e i lp);
-Simplify;
-(Elim_eq_term '(scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2)))
-	     't1); Auto; 
-Simplify; 
-Intro H2; Elim H2; Simpl; Elim (scalar_norm_add_stable t e); Simpl;
-Intro H4; Absurd `(interp_term e body)*k1+k2 = 0`; [
-   Apply OMEGA4; Assumption | Symmetry; Auto ].
-
-Save.
-
-(* \paragraph{[O_CONTRADICTION]} *)
-
-Definition contradiction [t: nat; i,j:nat;l:hyps] :=
-  Cases (nth_hyps i l) of
-    (LeqTerm  (Tint ZERO) b1) =>
-	Cases (nth_hyps j l) of 
-	  (LeqTerm  (Tint ZERO) b2) => 
-	     Cases (fusion_cancel t (Tplus b1 b2)) of
-	       (Tint k) =>
-		  Cases (Zcompare ZERO k) of
-	            SUPERIEUR => absurd
-	          | _ => l
-                  end
-             | _ => l
-             end
-         | _ => l 
-        end
-  | _ => l 
-  end.
-
-Theorem contradiction_valid : (t,i,j: nat) (valid_hyps (contradiction t i j)).
-
-Unfold valid_hyps contradiction; Intros t i j ep e l H;
-Generalize (nth_valid ? ? i ? H); Generalize (nth_valid ? ? j ? H);
-Case (nth_hyps i l); Auto; Intros t1 t2; Case t1; Auto; Intros z; Case z; Auto;
-Case (nth_hyps j l); Auto; Intros t3 t4; Case t3; Auto; Intros z'; Case z'; 
-Auto; Simpl; Intros H1 H2;
-Generalize (refl_equal Z (interp_term e (fusion_cancel t (Tplus t2 t4))));
-Pattern 2 3 (fusion_cancel t (Tplus t2 t4));
-Case (fusion_cancel t (Tplus t2 t4)); 
-Simpl; Auto; Intro k; Elim (fusion_cancel_stable t);
-Simpl; Intro E; Generalize (OMEGA2 ? ? H2 H1); Rewrite E; Case k; 
-Auto;Unfold Zle; Simpl; Intros p H3; Elim H3; Auto.
-
-Save.
-
-(* \paragraph{[O_NEGATE_CONTRADICT]} *)
-
-Definition negate_contradict [i1,i2:nat; h:hyps]:=
-  Cases (nth_hyps i1 h) of
-    (EqTerm (Tint ZERO) b1) =>
-	Cases (nth_hyps i2 h) of
-           (NeqTerm (Tint ZERO) b2) =>
-	      Cases (eq_term b1 b2) of
-	         true => absurd
-              |  false => h
-	    end
-        | _ => h
-        end
-  | (NeqTerm (Tint ZERO) b1) =>
-	Cases (nth_hyps i2 h) of
-           (EqTerm (Tint ZERO) b2) =>
-	      Cases (eq_term b1 b2) of
-	         true => absurd
-              |  false => h
-	    end
-        | _ => h
-        end
-  | _ => h
-  end.
-
-Definition negate_contradict_inv [t:nat; i1,i2:nat; h:hyps]:=
-  Cases (nth_hyps i1 h) of
-    (EqTerm (Tint ZERO) b1) =>
-	Cases (nth_hyps i2 h) of
-           (NeqTerm (Tint ZERO) b2) =>
-              Cases (eq_term b1 (scalar_norm t (Tmult b2 (Tint `-1`)))) of
-	         true => absurd
-              |  false => h
-	    end
-        | _ => h
-        end
-  | (NeqTerm (Tint ZERO) b1) =>
-	Cases (nth_hyps i2 h) of
-           (EqTerm (Tint ZERO) b2) =>
-              Cases (eq_term b1 (scalar_norm t (Tmult b2 (Tint `-1`)))) of
-	         true => absurd
-              |  false => h
-	    end
-        | _ => h
-        end
-  | _ => h
-  end.
-
-Theorem negate_contradict_valid :
-  (i,j:nat) (valid_hyps (negate_contradict i j)).
-
-Unfold valid_hyps negate_contradict; Intros i j ep e l H;
-Generalize (nth_valid ? ? i ? H); Generalize (nth_valid ? ? j ? H);
-Case (nth_hyps i l); Auto; Intros t1 t2; Case t1; Auto; Intros z; Case z; Auto;
-Case (nth_hyps j l); Auto; Intros t3 t4; Case t3; Auto; Intros z'; Case z'; 
-Auto; Simpl; Intros H1 H2; [
-  (Elim_eq_term t2 t4); Intro H3; [ Elim H1; Elim H3; Assumption | Assumption ]
-| (Elim_eq_term t2 t4); Intro H3; 
-    [ Elim H2; Rewrite H3; Assumption | Assumption ]].
-
-Save.
-
-Theorem negate_contradict_inv_valid :
-  (t,i,j:nat) (valid_hyps (negate_contradict_inv t i j)).
-
-
-Unfold valid_hyps negate_contradict_inv; Intros t i j ep e l H;
-Generalize (nth_valid ? ? i ? H); Generalize (nth_valid ? ? j ? H);
-Case (nth_hyps i l); Auto; Intros t1 t2; Case t1; Auto; Intros z; Case z; Auto;
-Case (nth_hyps j l); Auto; Intros t3 t4; Case t3; Auto; Intros z'; Case z'; 
-Auto; Simpl; Intros H1 H2;
-(Pattern (eq_term t2 (scalar_norm t (Tmult t4 (Tint (NEG xH))))); Apply bool_ind2; Intro Aux; [
-  Generalize (eq_term_true t2 (scalar_norm t (Tmult t4 (Tint (NEG xH)))) Aux);
-  Clear Aux
-| Generalize (eq_term_false t2 (scalar_norm t (Tmult t4 (Tint (NEG xH)))) Aux);
-  Clear Aux ]); [
-   Intro H3; Elim H1; Generalize H2; Rewrite H3; 
-   Rewrite <- (scalar_norm_stable t e); Simpl; Elim (interp_term e t4) ; 
-   Simpl; Auto; Intros p H4; Discriminate H4
- | Auto 
- | Intro H3; Elim H2; Rewrite H3; Elim (scalar_norm_stable t e); Simpl;
-   Elim H1; Simpl; Trivial
- | Auto ].
-
-Save.
-
-(* \subsubsection{Tactiques générant une nouvelle équation} *)
-(* \paragraph{[O_SUM]}
- C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant
- les opérateurs de comparaison des deux arguments) d'où une
- preuve un peu compliquée. On utilise quelques lemmes qui sont des 
- généralisations des théorèmes utilisés par OMEGA. *)
-
-Definition sum [k1,k2: Z; trace: (list t_fusion); prop1,prop2:proposition]:=
-  Cases prop1 of
-    (EqTerm (Tint ZERO) b1) =>
-	Cases prop2 of
-          (EqTerm (Tint ZERO) b2) =>
-	    (EqTerm 
-	       (Tint ZERO) 
-	       (fusion trace 
-	               (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))))
-        | (LeqTerm (Tint ZERO) b2) =>
-	    Cases (Zcompare k2 ZERO) of
-	       SUPERIEUR =>
-		 (LeqTerm 
-		    (Tint ZERO) 
-		    (fusion trace 
-			 (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))))
-            | _ => TrueTerm
-           end
-       | _ => TrueTerm
-       end
-  | (LeqTerm (Tint ZERO) b1) =>
-      Cases (Zcompare k1 ZERO) of
-        SUPERIEUR =>
-	  Cases prop2 of
-	    (EqTerm (Tint ZERO) b2) =>
-	      (LeqTerm 
-		 (Tint ZERO) 
-		 (fusion trace 
-			 (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))))
-	  | (LeqTerm (Tint ZERO) b2) =>
-	       Cases (Zcompare k2 ZERO) of
-		  SUPERIEUR =>
-		    (LeqTerm 
-		       (Tint ZERO) 
-		       (fusion trace 
-			    (Tplus (Tmult b1 (Tint k1)) 
-                                   (Tmult b2 (Tint k2)))))
-	       | _ => TrueTerm
-	      end
-	 | _ => TrueTerm
-	 end
-     | _ => TrueTerm
-     end
-  | (NeqTerm (Tint ZERO) b1) =>
-       Cases prop2 of
-	 (EqTerm (Tint ZERO) b2) =>
-	    Case (eq_Z k1 ZERO) of
-	       TrueTerm
-	       (NeqTerm 
-		  (Tint ZERO) 
-		  (fusion trace 
-			  (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))))
-	    end
-      | _ => TrueTerm
-      end
-  | _ => TrueTerm
-  end.
-
-Theorem sum1 :
-  (a,b,c,d:Z) (`0 = a`) -> (`0 = b`) -> (`0 = a*c + b*d`).
-
-Intros; Elim H; Elim H0; Simpl; Auto.
-Save.
-  
-Theorem sum2 :
-  (a,b,c,d:Z)  (`0 <= d`) -> (`0 = a`) -> (`0 <= b`) ->(`0 <= a*c + b*d`).
-
-Intros; Elim H0; Simpl; Generalize H H1; Case b; Case d; 
-Unfold Zle; Simpl; Auto.  
-Save.
-
-Theorem sum3 :
-  (a,b,c,d:Z)  (`0 <= c`) -> (`0 <= d`) -> (`0 <= a`) -> (`0 <= b`) ->(`0 <= a*c + b*d`).
-
-Intros a b c d; Case a; Case b; Case c; Case d; Unfold Zle; Simpl; Auto. 
-Save.
-
-Theorem sum4 : (k:Z) (Zcompare k `0`)=SUPERIEUR -> (`0 <= k`).
-
-Intro; Case k; Unfold Zle; Simpl; Auto; Intros; Discriminate.  
-Save.
-
-Theorem sum5 :
-  (a,b,c,d:Z) (`c <> 0`) -> (`0 <> a`) -> (`0 = b`) -> (`0 <> a*c + b*d`).
-
-Intros a b c d H1 H2 H3; Elim H3; Simpl; Rewrite Zplus_sym;
-Simpl; Generalize H1 H2; Case a; Case c; Simpl; Intros; Try Discriminate;
-Assumption.
-Save.
-
-
-Theorem sum_valid : (k1,k2:Z; t:(list t_fusion)) (valid2 (sum k1 k2 t)).
-
-Unfold valid2; Intros k1 k2 t ep e p1 p2; Unfold sum; Simplify; Simpl; Auto;
-Try (Elim (fusion_stable t)); Simpl; Intros; [
-  Apply sum1; Assumption
-| Apply sum2; Try Assumption; Apply sum4; Assumption
-| Rewrite Zplus_sym; Apply sum2; Try Assumption; Apply sum4; Assumption
-| Apply sum3; Try Assumption; Apply sum4; Assumption
-| (Elim_eq_Z k1 ZERO); Simpl; Auto; Elim (fusion_stable t); Simpl; Intros;
-  Unfold Zne; Apply sum5; Assumption].
-Save.
-
-(* \paragraph{[O_EXACT_DIVIDE]}
-   c'est une oper1 valide mais on préfère une substitution a ce point la *)
-
-Definition exact_divide [k:Z; body:term; t: nat; prop:proposition] :=
-   Cases prop of
-      (EqTerm (Tint ZERO) b) =>
-         Case (eq_term (scalar_norm t (Tmult body (Tint k))) b) of
-	   Case (eq_Z k ZERO) of
-	      TrueTerm
-	      (EqTerm (Tint ZERO) body)
-           end
-           TrueTerm
-         end
-   | _ => TrueTerm
-   end.
-
-Theorem exact_divide_valid :
-  (k:Z) (t:term) (n:nat) (valid1 (exact_divide k t n)).
-
-
-Unfold valid1 exact_divide; Intros k1 k2 t ep e p1; Simplify;Simpl; Auto;
-(Elim_eq_term  '(scalar_norm t (Tmult k2 (Tint k1))) 't1); Simpl; Auto;
-(Elim_eq_Z 'k1 'ZERO); Simpl; Auto;  Intros H1 H2; Elim H2; 
-Elim scalar_norm_stable; Simpl; Generalize H1; Case (interp_term e k2);
-Try Trivial; (Case k1; Simpl; [
-  Intros; Absurd `0 = 0`; Assumption
-| Intros p2 p3 H3 H4; Discriminate H4
-| Intros p2 p3 H3 H4; Discriminate H4 ]).
-
-Save.
-
-
-
-(* \paragraph{[O_DIV_APPROX]}
-  La preuve reprend le schéma de la précédente mais on
-  est sur une opération de type valid1 et non sur une opération terminale. *)
-
-Definition divide_and_approx [k1,k2:Z; body:term; t:nat; prop:proposition] :=
-  Cases prop of
-      (LeqTerm (Tint ZERO) b) =>
-         Case (eq_term
-                (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) b) of
-	   Cases (Zcompare k1 ZERO) of
-	     SUPERIEUR =>
-	       Cases (Zcompare k1 k2) of
-		 SUPERIEUR =>(LeqTerm (Tint ZERO) body)
-	       | _ => prop
-	       end
-	   | _ => prop
-           end
-	   prop
-         end
-   | _ => prop
-   end.
-
-Theorem divide_and_approx_valid : (k1,k2:Z; body:term; t:nat) 
-	(valid1 (divide_and_approx k1 k2 body t)).
-
-Unfold valid1 divide_and_approx; Intros k1 k2 body t ep e p1;Simplify;
-(Elim_eq_term '(scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) 't1); Simplify; Auto;  Intro E; Elim E; Simpl; 
-Elim (scalar_norm_add_stable t e); Simpl; Intro H1; 
-Apply Zmult_le_approx with 3 := H1; Assumption.
-Save.
-
-(* \paragraph{[MERGE_EQ]} *)
-
-Definition merge_eq [t: nat; prop1, prop2: proposition] :=
-  Cases prop1 of
-     (LeqTerm (Tint ZERO) b1) =>
-	Cases prop2 of
-     	  (LeqTerm (Tint ZERO) b2) =>
-             Case (eq_term b1 (scalar_norm t (Tmult b2 (Tint `-1`)))) of
-	        (EqTerm (Tint ZERO) b1)
- 	       	TrueTerm
-	     end
-        | _ => TrueTerm
-	end
-  | _ => TrueTerm
-  end.
-
-Theorem merge_eq_valid : (n:nat) (valid2 (merge_eq n)).
-
-Unfold valid2 merge_eq; Intros n ep e p1 p2; Simplify; Simpl; Auto;
-Elim (scalar_norm_stable n e); Simpl; Intros; Symmetry; 
-Apply OMEGA8 with 2 := H0; [ Assumption | Elim Zopp_one; Trivial ].
-Save.
-
-
-
-(* \paragraph{[O_CONSTANT_NUL]} *)
-
-Definition constant_nul [i:nat; h: hyps] :=
-  Cases (nth_hyps i h) of
-     (NeqTerm (Tint ZERO) (Tint ZERO)) => absurd
-   | _ => h
-  end.
-
-Theorem constant_nul_valid : 
-  (i:nat) (valid_hyps (constant_nul i)).
-
-Unfold valid_hyps constant_nul; Intros; Generalize (nth_valid ep e i lp);
-Simplify; Simpl; Unfold Zne; Intro H1; Absurd `0=0`; Auto.
-Save.
-
-(* \paragraph{[O_STATE]} *)
-
-Definition state [m:Z;s:step; prop1,prop2:proposition] :=
-  Cases prop1 of
-     (EqTerm (Tint ZERO) b1) =>
-	Cases prop2 of
-	   (EqTerm (Tint ZERO) (Tplus b2 (Topp b3))) =>
-	      (EqTerm (Tint ZERO) (rewrite s (Tplus b1 (Tmult (Tplus (Topp b3) b2) (Tint m)))))
-	| _ => TrueTerm
-	end
-  | _ => TrueTerm
-  end.
-
-Theorem state_valid : (m:Z; s:step) (valid2 (state m s)).
-
-Unfold valid2; Intros m s ep e p1 p2; Unfold state; Simplify; Simpl;Auto;
-Elim (rewrite_stable s e); Simpl; Intros H1 H2; Elim H1;
-Rewrite (Zplus_sym `-(interp_term e t5)` `(interp_term e t3)`);
-Elim H2; Simpl; Reflexivity.
-
-Save.
-
-(* \subsubsection{Tactiques générant plusieurs but}
-   \paragraph{[O_SPLIT_INEQ]} 
-   La seule pour le moment (tant que la normalisation n'est pas réfléchie). *)
-
-Definition split_ineq  [i,t: nat; f1,f2:hyps -> lhyps;  l:hyps] :=
-  Cases (nth_hyps i l) of
-    (NeqTerm  (Tint ZERO) b1) =>
-       (app (f1 (cons (LeqTerm (Tint ZERO) (add_norm t (Tplus b1 (Tint `-1`)))) l))
-            (f2 (cons (LeqTerm (Tint ZERO) 
-                               (scalar_norm_add t 
-	                         (Tplus (Tmult b1 (Tint `-1`)) (Tint `-1`))))
-                      l)))
-  | _ => (cons l (nil ?))
-  end.
-
-Theorem split_ineq_valid : 
-  (i,t: nat; f1,f2: hyps -> lhyps) 
-    (valid_list_hyps f1) ->(valid_list_hyps f2) -> 
-      (valid_list_hyps (split_ineq i t f1 f2)).
-
-Unfold valid_list_hyps split_ineq; Intros i t f1 f2 H1 H2 ep e lp H; 
-Generalize (nth_valid ? ? i ? H); 
-Case (nth_hyps i lp); Simpl; Auto; Intros t1 t2; Case t1; Simpl; Auto;
-Intros z; Case z; Simpl; Auto;
-Intro H3; Apply append_valid;Elim (OMEGA19 (interp_term e t2)) ;[
-  Intro H4; Left; Apply H1; Simpl; Elim (add_norm_stable t); Simpl; Auto
-| Intro H4; Right; Apply H2; Simpl; Elim (scalar_norm_add_stable t); 
-  Simpl; Auto
-| Generalize H3; Unfold Zne not; Intros E1 E2; Apply E1; Symmetry; Trivial ].
-Save.
-
-
-(* \subsection{La fonction de rejeu de la trace} *)
-
-Fixpoint execute_omega [t: t_omega] : hyps -> lhyps := 
-  [l : hyps] Cases t of
-   | (O_CONSTANT_NOT_NUL n) => (singleton (constant_not_nul n l))
-   | (O_CONSTANT_NEG n) => (singleton (constant_neg n l))
-   | (O_DIV_APPROX  k1 k2 body t cont n) =>
-       (execute_omega cont 
-	  (apply_oper_1 n (divide_and_approx k1 k2 body t) l))
-   | (O_NOT_EXACT_DIVIDE  k1 k2 body t i) =>
-       (singleton (not_exact_divide k1 k2 body t i l))
-   | (O_EXACT_DIVIDE k body t cont n) =>
-       (execute_omega cont (apply_oper_1 n (exact_divide k body t) l))
-   | (O_SUM k1 i1 k2 i2 t cont) =>
-       (execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l))
-   | (O_CONTRADICTION t i j) =>
-       (singleton (contradiction t i j l))
-   | (O_MERGE_EQ t i1 i2 cont) =>
-       (execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l))
-   | (O_SPLIT_INEQ t i cont1 cont2) =>
-       (split_ineq i t (execute_omega cont1) (execute_omega cont2) l)
-   | (O_CONSTANT_NUL i) => (singleton (constant_nul i l))
-   | (O_NEGATE_CONTRADICT i j) =>  (singleton (negate_contradict i j l))
-   | (O_NEGATE_CONTRADICT_INV t i j) => (singleton (negate_contradict_inv t i j l))
-   | (O_STATE m s i1 i2 cont) =>
-       (execute_omega cont (apply_oper_2 i1 i2 (state m s) l))
-  end.
-
-Theorem omega_valid : (t: t_omega) (valid_list_hyps (execute_omega t)).
-
-Induction t; Simpl; [
-  Unfold valid_list_hyps; Simpl; Intros; Left; 
-  Apply (constant_not_nul_valid n ep e lp H)
-| Unfold valid_list_hyps; Simpl; Intros; Left; 
-  Apply (constant_neg_valid n ep e lp H)
-| Unfold valid_list_hyps valid_hyps; Intros k1 k2 body n t' Ht' m ep e lp H; 
-  Apply Ht';
-  Apply (apply_oper_1_valid m (divide_and_approx k1 k2 body n)
-	  (divide_and_approx_valid k1 k2 body n) ep e lp H)
-| Unfold valid_list_hyps; Simpl; Intros; Left; 
-  Apply (not_exact_divide_valid z z0 t0 n n0 ep e lp H)
-| Unfold valid_list_hyps valid_hyps; Intros k body n t' Ht' m ep e lp H; 
-  Apply Ht';
-  Apply (apply_oper_1_valid m (exact_divide k body n)
-	  (exact_divide_valid k body n) ep e lp H)
-| Unfold valid_list_hyps valid_hyps; Intros k1 i1 k2 i2 trace t' Ht' ep e lp H;
-  Apply Ht'; 
-  Apply (apply_oper_2_valid i1 i2 (sum k1 k2 trace) 
-	  (sum_valid k1 k2 trace) ep e lp H)
-| Unfold valid_list_hyps; Simpl; Intros; Left; 
-  Apply (contradiction_valid n n0 n1 ep e lp H)
-| Unfold valid_list_hyps valid_hyps; Intros trace i1 i2 t' Ht' ep e lp H; 
-  Apply Ht';
-  Apply (apply_oper_2_valid i1 i2 (merge_eq trace) 
-          (merge_eq_valid trace) ep e lp H) 
-| Intros t' i k1 H1 k2 H2; Unfold valid_list_hyps; Simpl; Intros ep e lp H;
-  Apply (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) 
-	 H1 H2 ep e lp H)
-| Unfold valid_list_hyps; Simpl; Intros i ep e lp H; Left; 
-  Apply (constant_nul_valid i ep e lp H)
-| Unfold valid_list_hyps; Simpl; Intros i j ep e lp H; Left; 
-  Apply (negate_contradict_valid i j ep e lp H)
-| Unfold valid_list_hyps; Simpl; Intros n i j ep e lp H; Left; 
-  Apply (negate_contradict_inv_valid n i j ep e lp H)
-| Unfold valid_list_hyps valid_hyps; Intros m s i1 i2 t' Ht' ep e lp H; Apply Ht';
-  Apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H)
-].
-Save.
-
-
-(* \subsection{Les opérations globales sur le but} 
-   \subsubsection{Normalisation} *)
-
-Definition move_right [s: step; p:proposition] :=
-  Cases p of
-     (EqTerm t1 t2) => (EqTerm (Tint ZERO) (rewrite s (Tplus t1 (Topp t2))))
-   | (LeqTerm t1 t2) => (LeqTerm (Tint ZERO) (rewrite s (Tplus t2 (Topp t1))))
-   | (GeqTerm t1 t2) => (LeqTerm (Tint ZERO) (rewrite s (Tplus t1 (Topp t2))))
-   | (LtTerm t1 t2) =>
-        (LeqTerm (Tint ZERO)
-	         (rewrite s (Tplus (Tplus t2 (Tint `-1`)) (Topp t1))))
-   | (GtTerm t1 t2) => 
-        (LeqTerm (Tint ZERO)
-                 (rewrite s (Tplus (Tplus t1 (Tint `-1`)) (Topp t2))))
-   | (NeqTerm t1 t2) => (NeqTerm (Tint ZERO) (rewrite s (Tplus t1 (Topp t2))))
-   | p => p
-  end.
-
-Theorem Zne_left_2 : (x,y:Z)(Zne x y)->(Zne `0` `x+(-y)`).
-Unfold Zne not; Intros x y H1 H2; Apply H1; Apply (Zsimpl_plus_l `-y`);
-Rewrite Zplus_sym; Elim H2; Rewrite Zplus_inverse_l; Trivial.
-Save.
-
-Theorem move_right_valid : (s: step) (valid1 (move_right s)).
-
-Unfold valid1 move_right; Intros s ep e p; Simplify; Simpl;
-Elim (rewrite_stable s e); Simpl; [
-  Symmetry; Apply Zegal_left; Assumption
-| Intro; Apply Zle_left; Assumption 
-| Intro; Apply Zge_left; Assumption
-| Intro; Apply Zgt_left; Assumption
-| Intro; Apply Zlt_left; Assumption
-| Intro; Apply Zne_left_2; Assumption
-].
-Save.
-
-Definition do_normalize [i:nat; s: step] := (apply_oper_1 i (move_right s)).
-
-Theorem do_normalize_valid : (i:nat; s:step) (valid_hyps (do_normalize i s)).
-
-Intros; Unfold do_normalize; Apply apply_oper_1_valid; Apply move_right_valid.
-Save.
-
-Fixpoint do_normalize_list [l:(list step)] : nat -> hyps -> hyps := 
-  [i:nat; h:hyps] Cases l of
-    (cons s l') => (do_normalize_list l' (S i) (do_normalize i s h))
-  | nil => h
-  end.
-
-Theorem do_normalize_list_valid : 
-  (l:(list step); i:nat) (valid_hyps (do_normalize_list l i)).
-
-Induction l; Simpl; Unfold valid_hyps; [
-  Auto
-| Intros a l' Hl' i ep e lp H; Unfold valid_hyps in Hl'; Apply Hl';
-  Apply (do_normalize_valid i a ep e lp); Assumption ].
-Save.
-
-Theorem normalize_goal :
-  (s: (list step); ep: PropList; env : (list Z); l: hyps)
-    (interp_goal ep env (do_normalize_list s O l)) -> 
-      (interp_goal ep env l).
-
-Intros; Apply valid_goal with 2:=H; Apply do_normalize_list_valid.
-Save.
-
-(* \subsubsection{Exécution de la trace} *)
-
-Theorem execute_goal :
-  (t : t_omega; ep: PropList; env : (list Z); l: hyps)
-    (interp_list_goal ep env (execute_omega t l)) -> (interp_goal ep env l).
-
-Intros; Apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
-Save.
-
-
-Theorem append_goal :
-  (ep: PropList; e: (list Z)) (l1,l2:lhyps)
-     (interp_list_goal ep e l1) /\ (interp_list_goal ep e l2) ->
-     (interp_list_goal ep e (app l1 l2)).
-
-Intros ep e; Induction l1; [
-  Simpl; Intros l2 (H1, H2); Assumption
-| Simpl; Intros h1 t1 HR l2 ((H1 , H2), H3) ; Split; Auto].
-
-Save.
-
-Require Decidable.
-
-(* A simple decidability checker : if the proposition belongs to the
-   simple grammar describe below then it is decidable. Proof is by 
-   induction and uses well known theorem about arithmetic and propositional
-   calculus *)
-
-Fixpoint decidability [p:proposition] : bool :=
-  Cases p of
-    (EqTerm _ _) => true
-  | (LeqTerm _ _) => true
-  | (GeqTerm _ _) => true
-  | (GtTerm _ _) => true
-  | (LtTerm _ _) => true
-  | (NeqTerm _ _) => true
-  | (FalseTerm) => true
-  | (TrueTerm) => true
-  | (Tnot t) => (decidability t)
-  | (Tand t1 t2) => (andb (decidability t1) (decidability t2))
-  | (Timp t1 t2) => (andb (decidability t1) (decidability t2))
-  | (Tor t1 t2) =>  (andb (decidability t1) (decidability t2))
-  | (Tprop _) => false
-  end
-.
-
-Theorem decidable_correct :
-  (ep: PropList) (e: (list Z)) (p:proposition)
-    (decidability p)=true -> (decidable (interp_proposition ep e p)).
-
-Induction p; Simpl; Intros; [
-  Apply dec_eq
-| Apply dec_Zle
-| Left;Auto
-| Right; Unfold not; Auto
-| Apply dec_not; Auto
-| Apply dec_Zge
-| Apply dec_Zgt
-| Apply dec_Zlt
-| Apply dec_Zne
-| Apply dec_or; Elim andb_prop with 1 := H1; Auto
-| Apply dec_and; Elim andb_prop with 1 := H1; Auto
-| Apply dec_imp; Elim andb_prop with 1 := H1; Auto
-| Discriminate H].
-
-Save.
-
-(* An interpretation function for a complete goal with an explicit
-   conclusion. We use an intermediate fixpoint. *)
-
-Fixpoint interp_full_goal 
-    [envp: PropList;env : (list Z); c : proposition; l: hyps] : Prop :=
-  Cases l of 
-     nil => (interp_proposition envp env c)
-   | (cons p' l') => 
-	(interp_proposition envp env p') -> (interp_full_goal envp env c l')
-  end.
-
-Definition interp_full 
-    [ep: PropList;e : (list Z); lc : (hyps * proposition)] : Prop :=
-      Cases lc of (l,c) => (interp_full_goal ep e c l) end.
-
-(* Relates the interpretation of a complete goal with the interpretation
-   of its hypothesis and conclusion *)
-
-Theorem interp_full_false :
-  (ep: PropList; e : (list Z); l: hyps; c : proposition) 
-    ((interp_hyps ep e l) -> (interp_proposition ep e c)) -> 
-	(interp_full ep e (l,c)).
-
-Induction l; Unfold interp_full; Simpl; [
-  Auto
-| Intros a l1 H1 c H2 H3; Apply H1; Auto].
-
-Save.
-
-(* Push the conclusion in the list of hypothesis using a double negation
-   If the decidability cannot be "proven", then just forget about the 
-   conclusion (equivalent of replacing it with false) *)
-
-Definition to_contradict [lc : hyps * proposition] :=
-   Cases lc of
-      (l,c) => (if (decidability c) then (cons (Tnot c) l) else l)
-   end.
-
-(* The previous operation is valid in the sense that the new list of
-   hypothesis implies the original goal *)
-
-Theorem to_contradict_valid :
-  (ep: PropList; e : (list Z); lc: hyps * proposition)
-	(interp_goal ep e (to_contradict lc)) -> (interp_full ep e lc).
-
-Intros ep e lc; Case lc; Intros l c; Simpl; (Pattern (decidability c));
-Apply bool_ind2; [
-   Simpl; Intros H H1; Apply interp_full_false; Intros H2; Apply not_not; [
-     Apply decidable_correct; Assumption
-   | Unfold 1 not; Intro H3; Apply hyps_to_goal with 2:=H2; Auto]
-| Intros H1 H2; Apply interp_full_false; Intro H3; Elim hyps_to_goal with 1:= H2; Assumption ].
-Save.
-
-(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list
-   of lists *)
-
-Fixpoint map_cons [A:Set; x:A; l:(list (list A))] : (list (list A)) :=
-  Cases l of
-    nil => (nil ?)
-  | (cons l ll) => (cons (cons x l) (map_cons A x ll))
-  end.
-
-(* This function breaks up a list of hypothesis in a list of simpler 
-   list of hypothesis that together implie the original one. The goal
-   of all this is to transform the goal in a list of solvable problems. 
-   Note that :
-	- we need a way to drive the analysis as some hypotheis may not
-          require a split. 
-        - this procedure must be perfectly mimicked by the ML part otherwise
-          hypothesis will get desynchronised and this will be a mess.
- *)
- 
-Fixpoint destructure_hyps [nn: nat] : hyps -> lhyps :=
-  [ll:hyps]Cases nn of
-    O => (cons ll (nil ?))
-  | (S n) =>
-       Cases ll of 
-	  nil => (cons (nil ?) (nil ?))
-       | (cons (Tor p1 p2) l) => 
-	    (app (destructure_hyps n (cons p1 l))
-	         (destructure_hyps n (cons p2 l)))
-       | (cons (Tand p1 p2) l) => 
-	    (destructure_hyps n (cons p1 (cons p2 l)))
-       | (cons (Timp p1 p2) l) =>
-	    (if (decidability p1) then 
-	      (app (destructure_hyps n (cons (Tnot p1) l))
-		   (destructure_hyps n (cons p2 l)))
-	     else (map_cons ? (Timp p1 p2) (destructure_hyps n l)))
-       | (cons (Tnot p) l) =>
-	    Cases p of 
-	       (Tnot p1) =>
-		    (if (decidability p1) then (destructure_hyps n (cons p1 l))
-		     else (map_cons ? (Tnot (Tnot p1)) (destructure_hyps n l)))
- 	    | (Tor p1 p2) =>
-		  (destructure_hyps n (cons (Tnot p1) (cons (Tnot p2) l)))
- 	    | (Tand p1 p2) =>
-   	         (if (decidability p1) then 
- 		    (app (destructure_hyps n (cons (Tnot p1) l))
-			 (destructure_hyps n (cons (Tnot p2) l)))
-		 else (map_cons ? (Tnot p) (destructure_hyps n l)))
-	    | _ =>  (map_cons ? (Tnot p) (destructure_hyps n l))
-	    end
-       | (cons x l) => (map_cons ? x (destructure_hyps n l))
-       end
-  end.
-
-Theorem map_cons_val : 
-  (ep: PropList; e : (list Z))
-  (p:proposition;l:lhyps) 
-	(interp_proposition ep e p) ->
-	(interp_list_hyps ep e l) ->
-	(interp_list_hyps ep e (map_cons ? p l) ).
-
-Induction l; Simpl; [ Auto | Intros; Elim H1;  Intro H2; Auto ].
-Save.
-
-Hints Resolve map_cons_val append_valid decidable_correct.
-
-Theorem destructure_hyps_valid : 
-  (n:nat) (valid_list_hyps (destructure_hyps n)).
-
-Induction n; [
-  Unfold valid_list_hyps; Simpl; Auto
-| Unfold 2 valid_list_hyps; Intros n1 H  ep e lp; Case lp; [
-    Simpl; Auto
-  | Intros p l; Case p; 
-    Try (Simpl; Intros; Apply map_cons_val; Simpl; Elim H0; Auto); [
-      Intro p'; Case p';
-      Try (Simpl; Intros; Apply map_cons_val; Simpl; Elim H0; Auto); [
-	Simpl; Intros p1 (H1,H2);  Pattern (decidability p1); Apply bool_ind2;
-	Intro H3; [
-	  Apply H; Simpl; Split; [ Apply not_not; Auto | Assumption ]
-        | Auto]
-      | Simpl; Intros p1 p2 (H1,H2); Apply H; Simpl; 
-	Elim not_or with 1 := H1; Auto
-      | Simpl; Intros p1 p2 (H1,H2);Pattern (decidability p1); Apply bool_ind2;
-        Intro H3; [
-	  Apply append_valid; Elim not_and with 2 := H1; [
-	    Intro; Left; Apply H; Simpl; Auto
-	  | Intro; Right; Apply H; Simpl; Auto
-          | Auto ]
-        | Auto ]]
-    | Simpl; Intros p1 p2 (H1, H2); Apply append_valid; 
-      (Elim H1; Intro H3; Simpl; [ Left | Right ]); Apply H; Simpl; Auto 
-    | Simpl; Intros; Apply H; Simpl; Tauto
-    | Simpl; Intros p1 p2 (H1, H2); Pattern (decidability p1); Apply bool_ind2;
-      Intro H3; [ 
-	Apply append_valid; Elim imp_simp with 2:=H1; [
-	  Intro H4; Left; Simpl; Apply H; Simpl; Auto
-	| Intro H4; Right; Simpl; Apply H; Simpl; Auto
-	| Auto ]
-      | Auto ]]]].
-
-Save.
-
-Definition prop_stable [f: proposition -> proposition] :=
-  (ep: PropList; e: (list Z); p:proposition) 
-     (interp_proposition ep e p) <-> (interp_proposition ep e (f p)).
-
-Definition p_apply_left [f: proposition -> proposition; p : proposition]:= 
-  Cases p of
-    (Timp x y) => (Timp (f x) y)
-  | (Tor x y) => (Tor (f x) y)
-  | (Tand x y) => (Tand (f x) y)
-  | (Tnot x) => (Tnot (f x))
-  | x => x
-  end.
-
-Theorem p_apply_left_stable :
-  (f : proposition -> proposition) 
-    (prop_stable f) -> (prop_stable (p_apply_left f)).
-
-Unfold prop_stable; Intros f H ep e p; Split; 
-(Case p; Simpl; Auto; Intros p1; Elim (H ep e p1); Tauto).
-Save.
-
-Definition p_apply_right [f: proposition -> proposition; p : proposition]:= 
-  Cases p of
-    (Timp x y) => (Timp x (f y))
-  | (Tor x y) => (Tor x (f y))
-  | (Tand x y) => (Tand x (f y))
-  | (Tnot x) => (Tnot (f x))
-  | x => x
-  end.
-
-Theorem p_apply_right_stable :
-  (f : proposition -> proposition) 
-    (prop_stable f) -> (prop_stable (p_apply_right f)).
-
-Unfold prop_stable; Intros f H ep e p; Split; 
-(Case p; Simpl; Auto; [
-   Intros p1; Elim (H ep e p1); Tauto
- | Intros p1 p2; Elim (H ep e p2); Tauto
- | Intros p1 p2; Elim (H ep e p2); Tauto
- | Intros p1 p2; Elim (H ep e p2); Tauto
- ]).
-Save.
-
-Definition p_invert [f : proposition -> proposition; p : proposition] := 
-Cases p of
-  (EqTerm x y) => (Tnot (f (NeqTerm x y)))
-| (LeqTerm x y) => (Tnot (f (GtTerm x y)))
-| (GeqTerm x y) => (Tnot (f (LtTerm x y)))
-| (GtTerm x y) => (Tnot (f (LeqTerm x y)))
-| (LtTerm x y) => (Tnot (f (GeqTerm x y)))
-| (NeqTerm x y) => (Tnot (f (EqTerm x y)))
-| x => x
-end.
-
-Theorem p_invert_stable :
-  (f : proposition -> proposition) 
-    (prop_stable f) -> (prop_stable (p_invert f)).
-
-Unfold prop_stable; Intros f H ep e p; Split;(Case p; Simpl; Auto; [
-  Intros t1 t2; Elim (H ep e (NeqTerm t1 t2)); Simpl; Unfold Zne; 
-  Generalize (dec_eq (interp_term e t1) (interp_term e t2)); 
-  Unfold decidable; Tauto
-| Intros t1 t2; Elim (H ep e (GtTerm t1 t2)); Simpl; Unfold Zgt; 
-  Generalize (dec_Zgt (interp_term e t1) (interp_term e t2)); 
-  Unfold decidable Zgt Zle; Tauto
-| Intros t1 t2; Elim (H ep e (LtTerm t1 t2)); Simpl; Unfold Zlt; 
-  Generalize (dec_Zlt (interp_term e t1) (interp_term e t2)); 
-  Unfold decidable Zge; Tauto
-| Intros t1 t2; Elim (H ep e (LeqTerm t1 t2)); Simpl; 
-  Generalize (dec_Zgt (interp_term e t1) (interp_term e t2)); Unfold Zle Zgt;
-  Unfold decidable; Tauto
-| Intros t1 t2; Elim (H ep e (GeqTerm t1 t2)); Simpl;
-  Generalize (dec_Zlt (interp_term e t1) (interp_term e t2));  Unfold Zge Zlt; 
-  Unfold decidable; Tauto
-| Intros t1 t2; Elim (H ep e (EqTerm t1 t2)); Simpl;
-  Generalize (dec_eq (interp_term e t1) (interp_term e t2)); 
-  Unfold decidable Zne; Tauto ]).
-Save.
-
-Theorem Zlt_left_inv : (x,y:Z) `0 <= ((y + (-1)) + (-x))` ->  `x<y`.
-
-Intros; Apply Zlt_S_n; Apply Zle_lt_n_Sm; 
-Apply (Zsimpl_le_plus_r (Zplus `-1` (Zopp x))); Rewrite Zplus_assoc_l; 
-Unfold Zs; Rewrite (Zplus_assoc_r x); Rewrite (Zplus_assoc_l y); Simpl;
-Rewrite Zero_right; Rewrite Zplus_inverse_r; Assumption.
-Save.
-
-Theorem move_right_stable : (s: step) (prop_stable (move_right s)).
-
-Unfold move_right prop_stable; Intros s ep e p; Split; [
-    Simplify; Simpl; Elim (rewrite_stable s e); Simpl; [
-    Symmetry; Apply Zegal_left; Assumption
-  | Intro; Apply Zle_left; Assumption
-  | Intro; Apply Zge_left; Assumption
-  | Intro; Apply Zgt_left; Assumption
-  | Intro; Apply Zlt_left; Assumption
-  | Intro; Apply Zne_left_2; Assumption ]
-| Case p; Simpl; Intros; Auto; Generalize H; Elim (rewrite_stable s); Simpl; 
-  Intro H1; [
-    Rewrite (Zplus_n_O (interp_term e t0)); Rewrite H1; Rewrite Zplus_permute;
-    Rewrite Zplus_inverse_r; Rewrite Zero_right; Trivial
-  | Apply (Zsimpl_le_plus_r (Zopp (interp_term e t))); Rewrite Zplus_inverse_r;
-    Assumption
-  | Apply Zle_ge; Apply (Zsimpl_le_plus_r (Zopp (interp_term e t0))); 
-    Rewrite Zplus_inverse_r; Assumption
-  | Apply Zlt_gt; Apply Zlt_left_inv; Assumption
-  | Apply Zlt_left_inv; Assumption
-  | Unfold Zne not; Unfold Zne in H1; Intro H2; Apply H1; Rewrite H2;
-    Rewrite Zplus_inverse_r; Trivial ]].
-Save.
-
-
-Fixpoint p_rewrite [s: p_step] : proposition -> proposition :=
-  Cases s of 
-   | (P_LEFT s) => (p_apply_left (p_rewrite s))
-   | (P_RIGHT s) => (p_apply_right (p_rewrite s))
-   | (P_STEP s) => (move_right s)
-   | (P_INVERT s) => (p_invert (move_right s))
-   | P_NOP => [p:proposition]p
-  end.
-
-Theorem p_rewrite_stable : (s : p_step) (prop_stable (p_rewrite s)).
-
-
-Induction s; Simpl; [
-  Intros; Apply p_apply_left_stable; Trivial
-| Intros; Apply p_apply_right_stable; Trivial
-| Intros; Apply p_invert_stable; Apply move_right_stable
-| Apply move_right_stable
-| Unfold prop_stable; Simpl; Intros; Split; Auto ].
-Save.
-
-Fixpoint normalize_hyps [l: (list h_step)] : hyps -> hyps :=
-  [lh:hyps] Cases l of
-    nil => lh
-  | (cons (pair_step i s) r) =>
-	 (normalize_hyps r (apply_oper_1 i (p_rewrite s) lh))
-  end.
-
-Theorem normalize_hyps_valid : 
-  (l: (list h_step)) (valid_hyps (normalize_hyps l)).
-
-Induction l; Unfold valid_hyps; Simpl; [
-  Auto
-| Intros n_s r; Case n_s; Intros n s H ep e lp H1; Apply H; 
-  Apply apply_oper_1_valid; [
-    Unfold valid1; Intros ep1 e1 p1 H2; Elim (p_rewrite_stable s ep1 e1 p1);
-    Auto
-  | Assumption ]].
-Save.
-
-Theorem normalize_hyps_goal :
-  (s: (list h_step); ep: PropList; env : (list Z); l: hyps)
-    (interp_goal ep env (normalize_hyps s l)) -> 
-      (interp_goal ep env l).
-
-Intros; Apply valid_goal with 2:=H; Apply normalize_hyps_valid.
-Save.
-
-Fixpoint extract_hyp_pos [s: (list direction)] : proposition -> proposition :=
-  [p: proposition]
-  Cases s of 
-   | (cons D_left l) =>
-	Cases p of
-          (Tand x y) => (extract_hyp_pos l x)
-        | _ => p
-        end
-   | (cons D_right l) =>
-	Cases p of
-          (Tand x y) => (extract_hyp_pos l y)
-        | _ => p
-        end
-   | (cons D_mono l) =>
-	Cases p of
-          (Tnot x ) => (extract_hyp_neg l x)
-        | _ => p
-        end
-   | _ => p
-  end
-with extract_hyp_neg [s: (list direction)] : proposition -> proposition :=
-  [p: proposition]
-  Cases s of 
-   | (cons D_left l) =>
-	Cases p of
-          (Tor x y) => (extract_hyp_neg l x)
-	| (Timp x y) =>
-	    (if (decidability x) then (extract_hyp_pos l x) else (Tnot p))
-        | _ => (Tnot p)
-        end
-   | (cons D_right l) =>
-	Cases p of
-          (Tor x y) => (extract_hyp_neg l y)
-	| (Timp x y) => (extract_hyp_neg l y)
-        | _ => (Tnot p)
-        end
-   | (cons D_mono l) =>
-	Cases p of
-          (Tnot x) => 
-	     (if (decidability x) then (extract_hyp_pos l x) else (Tnot p))
-        | _ => (Tnot p)
-        end
-   | _ => 
-	Cases p of
-	  (Tnot x) => (if (decidability x) then x else (Tnot p))
-        | _ => (Tnot p) 
-	end
-  end.
-
-Definition co_valid1 [f: proposition -> proposition] :=
-  (ep : PropList; e: (list Z)) (p1: proposition) 
-     (interp_proposition ep e (Tnot p1)) -> (interp_proposition ep e (f p1)).
-
-Theorem extract_valid : 
-  (s: (list direction))
-    ((valid1 (extract_hyp_pos s)) /\ (co_valid1 (extract_hyp_neg s))).
-
-Unfold valid1 co_valid1; Induction s; [
-  Split; [
-    Simpl; Auto
-  | Intros ep e p1; Case p1; Simpl; Auto; Intro p; Pattern (decidability p);
-    Apply bool_ind2; [
-      Intro H; Generalize (decidable_correct ep e p H); Unfold decidable; Tauto
-    | Simpl; Auto]]
-| Intros a s' (H1,H2);  Simpl in H2; Split; Intros ep e p; Case a; Auto; 
-  Case p; Auto; Simpl; Intros; 
-  (Apply H1; Tauto) Orelse (Apply H2; Tauto) Orelse
-  (Pattern (decidability p0); Apply bool_ind2; [
-     Intro H3; Generalize (decidable_correct ep e p0 H3);Unfold decidable;
-     Intro H4; Apply H1; Tauto
-   | Intro; Tauto ])].
-
-Save.
-
-Fixpoint decompose_solve [s: e_step] : hyps -> lhyps := 
- [h:hyps]
- Cases s of 
-   (E_SPLIT i dl s1 s2) => 
-	(Cases (extract_hyp_pos dl (nth_hyps i h)) of
-	   (Tor x y) => 
-	      (app (decompose_solve s1 (cons x h)) 
-	           (decompose_solve s2 (cons y h)))
-	|  (Tnot (Tand x y)) => 
-	      (if (decidability x) then
-		      (app (decompose_solve s1 (cons (Tnot x) h)) 
-		           (decompose_solve s2 (cons (Tnot y) h)))
-		else (cons h (nil hyps)))
-	| _ => (cons h (nil hyps))
-	end)
- | (E_EXTRACT i dl s1) =>
-     (decompose_solve s1 (cons (extract_hyp_pos dl (nth_hyps i h)) h))
- | (E_SOLVE t) => (execute_omega t h)
- end.
-
-Theorem decompose_solve_valid : 
-   (s:e_step)(valid_list_goal (decompose_solve s)).
-
-Intro s; Apply goal_valid; Unfold valid_list_hyps; Elim s; Simpl; Intros; [
-  Cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); [
-    Case (extract_hyp_pos l (nth_hyps n lp)); Simpl; Auto; [
-      Intro p; Case p; Simpl;Auto; Intros p1 p2 H2;
-      Pattern (decidability p1); Apply bool_ind2; [
-        Intro H3; Generalize (decidable_correct ep e1 p1 H3); 
-        Intro H4; Apply append_valid; Elim H4; Intro H5; [
-          Right; Apply H0; Simpl; Tauto
-        | Left; Apply H; Simpl; Tauto ]
-      | Simpl; Auto]
-    | Intros p1 p2 H2; Apply append_valid; Simpl; Elim H2; [
-        Intros H3; Left; Apply H; Simpl; Auto
-      | Intros H3; Right; Apply H0; Simpl; Auto ]]
-  | Elim (extract_valid l); Intros H2 H3; Apply H2; Apply nth_valid; Auto]
-| Intros; Apply H; Simpl; Split; [
-    Elim (extract_valid l); Intros H2 H3; Apply H2; Apply nth_valid; Auto
-  | Auto ]
-| Apply omega_valid with 1:= H].
-
-Save.
-
-(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *)
-
-Definition valid_lhyps [f: lhyps -> lhyps] :=
-  (ep : PropList; e : (list Z)) (lp: lhyps)
-    (interp_list_hyps ep e lp) -> (interp_list_hyps ep e (f lp)).
-
-Fixpoint reduce_lhyps [lp:lhyps] : lhyps :=
-   Cases lp of
-     (cons (cons FalseTerm nil) lp') => (reduce_lhyps lp')
-   | (cons x lp') => (cons x (reduce_lhyps lp'))
-   | nil => (nil hyps)
-   end.
-
-Theorem reduce_lhyps_valid : (valid_lhyps reduce_lhyps).
-
-Unfold valid_lhyps; Intros ep e lp; Elim lp; [
-  Simpl; Auto
-| Intros a l HR; Elim a; [
-    Simpl; Tauto
-  | Intros a1 l1; Case l1; Case a1; Simpl; Try Tauto]].
-Save.
-
-Theorem do_reduce_lhyps : 
-  (envp: PropList; env: (list Z); l: lhyps)
-    (interp_list_goal envp env (reduce_lhyps l)) ->
-	 (interp_list_goal envp env l).
-
-Intros envp env l H; Apply list_goal_to_hyps; Intro H1; 
-Apply list_hyps_to_goal with 1 := H; Apply reduce_lhyps_valid; Assumption.
-Save.
-
-Definition concl_to_hyp := [p:proposition]
-  (if (decidability p) then (Tnot p) else TrueTerm).
-
-Definition do_concl_to_hyp :
-  (envp: PropList; env: (list Z); c : proposition; l:hyps)
-    (interp_goal envp env (cons (concl_to_hyp c) l)) ->
-       (interp_goal_concl envp env c l).
-
-Simpl; Intros envp env c l; Induction l; [
-  Simpl; Unfold concl_to_hyp; Pattern (decidability c); Apply bool_ind2; [
-    Intro H; Generalize (decidable_correct envp env c H); Unfold decidable;
-    Simpl; Tauto
-  | Simpl; Intros H1 H2; Elim H2; Trivial]
-| Simpl; Tauto ].
-Save.
-
-Definition omega_tactic := 
-  [t1:e_step ; t2:(list h_step) ; c:proposition; l:hyps] 
-    (reduce_lhyps 
-      (decompose_solve t1 (normalize_hyps t2 (cons (concl_to_hyp c) l)))).
-
-Theorem do_omega:
-  (t1: e_step ; t2: (list h_step);
-   envp: PropList; env: (list Z); c: proposition; l:hyps)
-    (interp_list_goal envp env (omega_tactic t1 t2 c l)) ->
-       (interp_goal_concl envp env c l).
-
-Unfold omega_tactic; Intros; Apply do_concl_to_hyp; 
-Apply (normalize_hyps_goal t2); Apply (decompose_solve_valid t1); 
-Apply do_reduce_lhyps; Assumption.
-Save.
diff --git a/debian/changelog b/debian/changelog
index afb42a67..a161de61 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,96 @@
+coq (8.1+dfsg-2) experimental; urgency=low
+
+  * Added cmxa-install.dpatch to install cmxa only on native archs,
+    closes: #415867.
+  * Added configure.dpatch for the configure to correctly detect whether
+    ocamlopt is present or not.
+  * Use dh_installtex instead of hand-crafted postinst.
+
+ -- Samuel Mimram <smimram@debian.org>  Sun, 18 Mar 2007 13:21:56 +0100
+
+coq (8.1+dfsg-1) experimental; urgency=low
+
+  * New upstream release.
+  * Removed system.dpatch and next-ia64.dpatch, integrated upstream.
+  * Removed the subdirectories common, faq, RecTutorial, refman, rt, tools,
+    tutorial of the directory doc since they contain documentation under the
+    Open Publication License which is not DFSG-free (thus the +dfsg in the
+    version number). The script debian/utils/purify_tarball automates this
+    process. This documentation in packaged separately in non-free, in
+    the coq-doc package.
+
+ -- Samuel Mimram <smimram@debian.org>  Tue, 13 Feb 2007 11:38:43 +0000
+
+coq (8.1~gamma-4) experimental; urgency=low
+
+  * Correctly build glob.dump on non-native archs, closes: #400535.
+
+ -- Samuel Mimram <smimram@debian.org>  Sun, 11 Feb 2007 18:02:49 +0100
+
+coq (8.1~gamma-3) experimental; urgency=low
+
+  * Added next-ia64.dpatch to fix the FTBFS on ia64.
+  * Correctly install coqdoc.sty, closes: #409027.
+  * Build-depend on tetex-extra | texlive-latex-extra in order to allow
+    building with texlive.
+
+ -- Samuel Mimram <smimram@debian.org>  Sun,  4 Feb 2007 20:38:43 +0100
+
+coq (8.1~gamma-2) experimental; urgency=low
+
+  * Added no-complexity-test.dpatch to skip complexity checks (thanks Julien
+    Cristau), closes: #399919.
+
+ -- Samuel Mimram <smimram@debian.org>  Thu, 23 Nov 2006 14:27:15 +0000
+
+coq (8.1~gamma-1) experimental; urgency=low
+
+  * New upstream release.
+  * Made the package binNMU-safe.
+  * Minor improvements of the coqide.desktop file, closes: #383310.
+  * Added system.dpatch to avoid erroneous interpretation of ~.
+  * Removed assert.dpatch, integrated upstream.
+
+ -- Samuel Mimram <smimram@debian.org>  Tue, 21 Nov 2006 13:33:55 +0000
+
+coq (8.0pl3+8.1beta.2-1) experimental; urgency=low
+
+  * New upstream beta release.
+  * Added assert.dpatch to check assertions in native mode.
+
+ -- Samuel Mimram <smimram@debian.org>  Thu, 13 Jul 2006 16:28:24 +0000
+
+coq (8.0pl3+8.1beta-1) experimental; urgency=low
+
+  * New upstream release.
+  * Added --fsets all option to configure to build the theory of finite sets. 
+  * Updated coqdoc_stdlib.dpatch, partly integrated upstream.
+  * Removed failing_tests.dpath, all the tests should succeed now.
+  * We don't need to remove rpaths anymore.
+  * Updated standards version to 3.7.2, no changes needed.
+
+ -- Samuel Mimram <smimram@debian.org>  Fri, 16 Jun 2006 12:59:07 +0000
+
+coq (8.0pl3+8.1alpha-2) experimental; urgency=low
+
+  * Added makefile.dpatch in order for ocamlopt not to be called when
+    compiling on non-native archs.
+  * Do not build the pdf documentation for the library since we don't ship it.
+    This will avoid the FTBFS because of missing LaTeX fonts.
+
+ -- Samuel Mimram <smimram@debian.org>  Sun, 30 Apr 2006 11:51:57 +0000
+
+coq (8.0pl3+8.1alpha-1) experimental; urgency=low
+
+  * New upstream release.
+  * No longer providing the compatibility coq7-libs package.
+  * coq-libs is now providing its documentation in html format.
+  * Added browser.dpatch to use the default Debian browser for help.
+  * Disabling checks which don't succeed for now: failing_tests.dpatch.
+  * Removed coq-8.0pl3-ocaml-3.09.dpatch.
+
+ -- Samuel Mimram <smimram@debian.org>  Thu, 27 Apr 2006 13:43:16 +0000
+
 coq (8.0pl3-2) unstable; urgency=low
 
   * Added coq-8.0pl3-ocaml-3.09.dpatch in order to prevent intuition from
diff --git a/debian/control b/debian/control
index 92b0d596..88c3e39b 100644
--- a/debian/control
+++ b/debian/control
@@ -3,16 +3,16 @@ Section: math
 Priority: optional
 Maintainer: Debian OCaml Maintainers <debian-ocaml-maint@lists.debian.org>
 Uploaders: Ralf Treinen <treinen@debian.org>, Sven Luther <luther@debian.org>, Remi Vanicat <vanicat@debian.org>, Stefano Zacchiroli <zack@debian.org>, Samuel Mimram <smimram@debian.org>
-Standards-Version: 3.6.2
-Build-Depends: debhelper (>= 4.0.0), dpatch, ocaml-nox (>= 3.09.0), ocaml-best-compilers, liblablgtk2-ocaml-dev (>= 2.4.0), chrpath
+Standards-Version: 3.7.2
+Build-Depends: debhelper (>= 4.0.0), dpkg-dev (>= 1.13.19), dpatch, ocaml-nox (>= 3.09.0), ocaml-best-compilers, liblablgtk2-ocaml-dev (>= 2.4.0), tetex-extra | texlive-latex-extra, hevea
 XS-Vcs-Svn: svn://svn.debian.org/svn/pkg-ocaml-maint/trunk/packages/coq
 XS-Vcs-Browser: http://svn.debian.org/wsvn/pkg-ocaml-maint/trunk/packages/coq/trunk/
 
 Package: coq
 Architecture: any
-Depends: ${shlibs:Depends}, coq-libs (= ${Source-Version})
+Depends: ${shlibs:Depends}, ${misc:Depends}, coq-libs (= ${source:Version})
 Recommends: coqide | proofgeneral-coq
-Suggests: ocaml-nox (>= 3.08), proofgeneral-coq, ledit, cle
+Suggests: ocaml-nox (>= 3.08), proofgeneral-coq, ledit, cle, coq-doc
 Description: proof assistant for higher-order logic (toplevel and compiler)
  Coq is a proof assistant for higher-order logic, which allows the
  development of computer programs consistent with their formal
@@ -41,7 +41,7 @@ Description: proof assistant for higher-order logic (gtk interface)
 Package: coq-libs
 Architecture: all
 Recommends: coq (>= 8.0)
-Conflicts: coq (<< 8.0)
+Conflicts: coq (<< 8.0), coq-doc (<= 8.0pl1.0-2)
 Description: proof assistant for higher-order logic (theories)
  Coq is a proof assistant for higher-order logic, which allows the
  development of computer programs consistent with their formal
@@ -50,18 +50,3 @@ Description: proof assistant for higher-order logic (theories)
  .
  This package provides existing theories that new proofs can be
  based upon, including theories of arithmetic and Boolean values.
-
-Package: coq7-libs
-Architecture: all
-Recommends: coq (>= 8.0)
-Description: proof assistant for higher-order logic (Coq 7 theories)
- Coq is a proof assistant for higher-order logic, which allows the
- development of computer programs consistent with their formal
- specification. It is developed using Objective Caml and Camlp4.
- For more information, see <http://coq.inria.fr/>.
- .
- This package provides existing theories from Coq 7 in Coq 8, and
- allows proofs that were developed in Coq 7 to be used in Coq 8.
- It is also required to translate theories in Coq 7 syntax into
- the new syntax introduced in Coq 8. However, this package does
- not need to be installed to use Coq 7.
diff --git a/debian/copyright b/debian/copyright
index c53b8733..f0856000 100644
--- a/debian/copyright
+++ b/debian/copyright
@@ -14,9 +14,9 @@ INRIA-CNRS, University Paris Sud, All rights reserved.
 This product includes also software developed by
         Yves Bertot, Lemme, INRIA Sophia-Antipolis (contrib/interface,
           parsing/search.ml)
-        Pierre Crégut, France Telecom R & D (contrib/omega and contrib/romega)
+        Pierre Crégut, France Telecom R & D (contrib/omega and contrib/romega)
         Pierre Courtieu, Lemme (contrib/funind)
-        Loïc Pottier, Lemme, INRIA Sophia-Antipolis (contrib/fourier)
+        Loïc Pottier, Lemme, INRIA Sophia-Antipolis (contrib/fourier)
         Claudio Sacerdoti Coen, HELM, University of Bologna (contrib/xml)
 
 Coq includes a tactic Jp based on JProver, a theorem prover for
@@ -27,13 +27,13 @@ and then integrated it into Coq.
         
 The Coq development Team (march 2004)
         Bruno Barras (INRIA)
-        Pierre Corbineau (Université Paris Sud)
-        Jean-Christophe Filliâtre (CNRS)
+        Pierre Corbineau (Université Paris Sud)
+        Jean-Christophe Filliâtre (CNRS)
         Hugo Herbelin (INRIA)
-        Pierre Letouzey (Université Paris Sud)
-        Claude Marché (Université Paris Sud-INRIA)
-        Christine Paulin (Université Paris Sud) 
-        Clément Renard (INRIA)
+        Pierre Letouzey (Université Paris Sud)
+        Claude Marché (Université Paris Sud-INRIA)
+        Christine Paulin (Université Paris Sud) 
+        Clément Renard (INRIA)
 
 The complete list of developpers and contributors can be found in
 /usr/share/doc/doc/CREDITS.gz
diff --git a/debian/coq-libs.install b/debian/coq-libs.install
index c721f0c8..653e2b54 100644
--- a/debian/coq-libs.install
+++ b/debian/coq-libs.install
@@ -1,4 +1,4 @@
 usr/lib/coq/contrib
 usr/lib/coq/states
 usr/lib/coq/theories
-usr/lib/coq/ide/utf8.vo usr/lib/coq
+usr/lib/coq/ide/utf8.vo	usr/lib/coq
diff --git a/debian/coq.install b/debian/coq.install
index d1182ab6..59bcb594 100644
--- a/debian/coq.install
+++ b/debian/coq.install
@@ -8,8 +8,11 @@ usr/bin/coq-tex
 usr/bin/coqtop*
 usr/bin/coqwc
 usr/bin/gallina
-usr/share/emacs/site-lisp/coq
-usr/share/emacs/site-lisp/coqdoc.sty
+usr/lib/coq/*.cma
+usr/lib/coq/*.cmxa
+usr/lib/coq/tools/coqdoc/
+usr/share/emacs/site-lisp/coq/*
 usr/share/man/man1/c*
 usr/share/man/man1/gallina.1
 usr/share/texmf/tex/latex/misc/*
+usr/share/emacs/site-lisp/coqdoc.sty    usr/share/texmf/tex/latex/misc/
diff --git a/debian/coq.xpm b/debian/coq.xpm
index e58ebad7..fe188d02 100644
--- a/debian/coq.xpm
+++ b/debian/coq.xpm
@@ -1,54 +1,52 @@
 /* XPM */
-static char *coq[] = {
-/* columns rows colors chars-per-pixel */
-"32 32 16 1",
-"  c #220C08",
-". c #342A2C",
-"X c #5A261F",
-"o c #6A4D4B",
-"O c #923827",
-"+ c #BF381C",
-"@ c #996252",
-"# c #837671",
-"$ c #D35E3A",
-"% c #CA7852",
-"& c #E19667",
-"* c #A59082",
-"= c #B9ADA8",
-"- c #EAB48F",
-"; c #F2D3B6",
-": c #FCFDF9",
-/* pixels */
-"::::::::::::::::::::::::::::::::",
-"::::::::::::::::::::::::::::::::",
-":::::X.:::::::::::::::::::::::::",
-"::::++-==:::::::::::::::::::::::",
-":::+;;+$:*::::::::::::::::::::::",
-":::;-++%:: :::::::::::::::::::::",
-":::*+++#:::;::::::::::::::::::::",
-"::::= +O::::::::::::::::::::::::",
-":::::: :::::o:::::::::::::::::::",
-"::::::=;:::::=::::::::::::::*:::",
-"::::::;::::::::: :::::::::::=:::",
-":::::=:::::::::::::::::: :::.:::",
-":::::*:::::::::::::.::.::::;X:::",
-":::::;::::::::::::::o:::;:-*.:::",
-"::::*;;;::::::;;:;-::--:;&&&X:::",
-"::::#;;;;-;;::;;;;;-;;--%%-%::::",
-":::::--;;@;;;;;-;-;--%oO%&% ::::",
-":::::.--;-@%&--&&%$$OOXO%%@:::::",
-"::::::o&--& O+XO&& XXX Oo ::::::",
-"::::::;@%%&%$  XX$X X Oo@ ::::::",
-"::::::::=O$OO+XX O X OO@ :::::::",
-"::::::::::;+X O%OOOOOOOo::::::::",
-"::::::::::::oOOXXX X  ::::::::::",
-":::::::::::::XX  X X::::::::::::",
-"::::::::::::::    .:::::::::::::",
-":::::::::::::: o:.::::::::::::::",
-":::::::::::::: #:.::::::::::::::",
-":::::::::::-oX%oo&*:::::::::::::",
-"::::::::::::o.#:::=@::::::::::::",
-"::::::::::::::::::::::::::::::::",
-"::::::::::::::::::::::::::::::::",
-"::::::::::::::::::::::::::::::::"
-};
+static char * coq_xpm[] = {
+"32 32 17 1",
+" 	c None",
+".	c #5A261F",
+"+	c #342A2C",
+"@	c #BF381C",
+"#	c #EAB48F",
+"$	c #B9ADA8",
+"%	c #F2D3B6",
+"&	c #D35E3A",
+"*	c #FCFDF9",
+"=	c #A59082",
+"-	c #CA7852",
+";	c #220C08",
+">	c #837671",
+",	c #923827",
+"'	c #6A4D4B",
+")	c #E19667",
+"!	c #996252",
+"                                ",
+"                                ",
+"     .+                         ",
+"    @@#$$                       ",
+"   @%%@&*=                      ",
+"   %#@@-**;                     ",
+"   =@@@>***                     ",
+"    $;@,****                    ",
+"      ;*****'                   ",
+"      $%*****$              =   ",
+"      %*********;         **$   ",
+"     $************      ;***+   ",
+"     =*************+**+****%.   ",
+"     %**************'***%*#=+   ",
+"    =%%%******%%*%#**##*%))).   ",
+"    >%%%%#%%**%%%%%#%%##--#-    ",
+"     ##%%!%%%%%#%#%##-',-)-;    ",
+"     +##%#!-)##))-&&,,.,--!     ",
+"      ')##);,@.,));...;,';      ",
+"       !--)-&;;..&.;.;,'!;      ",
+"        $,&,,@..;,;.;,,!;       ",
+"           @.;,-,,,,,,,'        ",
+"            ',,...;.;;          ",
+"             ..;;.;.            ",
+"              ;;;;+             ",
+"              ;' +              ",
+"              ;> +              ",
+"           #'.-'')=             ",
+"            '+>   $!            ",
+"                                ",
+"                                ",
+"                                "};
diff --git a/debian/coq7-libs.install b/debian/coq7-libs.install
deleted file mode 100644
index e888a17f..00000000
--- a/debian/coq7-libs.install
+++ /dev/null
@@ -1,3 +0,0 @@
-usr/lib/coq/contrib7
-usr/lib/coq/states7
-usr/lib/coq/theories7
diff --git a/debian/coqide.desktop b/debian/coqide.desktop
index 1515c273..c56bfec4 100644
--- a/debian/coqide.desktop
+++ b/debian/coqide.desktop
@@ -1,9 +1,9 @@
 [Desktop Entry]
 Encoding=UTF-8
-Name=CoqIde
+Name=CoqIDE Proof Assistant
 Comment=Graphical interface for the Coq proof assistant
-Exec=/usr/bin/coqide
+Exec=coqide
 Type=Application
-Categories=GTK;Science;Math;
+Categories=Application;Development;Science;Math;IDE;GTK;
 Terminal=false
-Icon=/usr/share/pixmaps/coq.xpm
+Icon=coq
diff --git a/debian/coqide.install b/debian/coqide.install
index 7df75581..f214e01c 100644
--- a/debian/coqide.install
+++ b/debian/coqide.install
@@ -1,5 +1,4 @@
 usr/bin/coqide*
-usr/lib/coq/ide/coq.ico
-usr/lib/coq/ide/coq2.ico
+usr/lib/coq/ide/coq.png
 usr/lib/coq/ide/utf8.vo
 usr/lib/coq/ide/.coqide-gtk2rc
diff --git a/debian/coqide.menu b/debian/coqide.menu
index 0fb1935a..2bf7d541 100644
--- a/debian/coqide.menu
+++ b/debian/coqide.menu
@@ -1,4 +1,4 @@
 ?package(coqide):command="/usr/bin/coqide" \
   icon="/usr/share/pixmaps/coqide.xpm" \
   needs="X11" \
-  section="Apps/Math" title="CoqIde"
+  section="Apps/Math" title="CoqIDE"
diff --git a/debian/patches/00list b/debian/patches/00list
index 3804c9ad..bbb91a76 100644
--- a/debian/patches/00list
+++ b/debian/patches/00list
@@ -1 +1,6 @@
-coq-8.0pl3-ocaml-3.09
+coqdoc_stdlib
+browser
+makefile
+no-complexity-test
+configure
+cmxa-install
diff --git a/debian/patches/cmxa-install.dpatch b/debian/patches/cmxa-install.dpatch
new file mode 100755
index 00000000..7e8d2ffb
--- /dev/null
+++ b/debian/patches/cmxa-install.dpatch
@@ -0,0 +1,23 @@
+#! /bin/sh /usr/share/dpatch/dpatch-run
+## cmxa-install.dpatch by Samuel Mimram <smimram@debian.org>
+##
+## All lines beginning with `## DP:' are a description of the patch.
+## DP: .cmxa are not generated on non-native archs, so don't install them.
+
+@DPATCH@
+diff -urNad coq-8.1+dfsg~/Makefile coq-8.1+dfsg/Makefile
+--- coq-8.1+dfsg~/Makefile	2007-02-18 13:25:29.000000000 +0100
++++ coq-8.1+dfsg/Makefile	2007-02-18 13:27:28.000000000 +0100
+@@ -1272,7 +1272,11 @@
+         parsing/parsing.cma tactics/tactics.cma toplevel/toplevel.cma \
+         parsing/highparsing.cma tactics/hightactics.cma contrib/contrib.cma
+ 
+-OBJECTCMXA=$(OBJECTCMA:.cma=.cmxa)
++ifeq ($(BEST),opt)
++  OBJECTCMXA=$(OBJECTCMA:.cma=.cmxa)
++else
++  OBJECTCMXA=
++endif
+ 
+ install-library:
+ 	$(MKDIR) $(FULLCOQLIB)
diff --git a/debian/patches/configure.dpatch b/debian/patches/configure.dpatch
new file mode 100755
index 00000000..db3ef2a5
--- /dev/null
+++ b/debian/patches/configure.dpatch
@@ -0,0 +1,19 @@
+#! /bin/sh /usr/share/dpatch/dpatch-run
+## configure.dpatch by Pierre Letouzey <pierre.letouzey@pps.jussieu.fr>
+##
+## All lines beginning with `## DP:' are a description of the patch.
+## DP: Correctly detect whether ocamlopt is present or not.
+
+@DPATCH@
+diff -urNad coq-8.1+dfsg~/configure coq-8.1+dfsg/configure
+--- coq-8.1+dfsg~/configure	2007-02-10 08:32:28.000000000 +0000
++++ coq-8.1+dfsg/configure	2007-02-15 12:58:56.000000000 +0000
+@@ -340,7 +340,7 @@
+ # do we have a native compiler: test of ocamlopt and its version
+ 
+ if [ "$best_compiler" = "opt" ] ; then
+-  if test -e `which "$nativecamlc"` ; then
++  if test -e "`which $nativecamlc`" ; then
+       CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+       if [ "$CAMLOPTVERSION" != "$CAMLVERSION" ] ; then
+ 	  echo "native and bytecode compilers do not have the same version!"; fi
diff --git a/debian/patches/coq-8.0pl3-ocaml-3.09.dpatch b/debian/patches/coq-8.0pl3-ocaml-3.09.dpatch
deleted file mode 100755
index 90b4d583..00000000
--- a/debian/patches/coq-8.0pl3-ocaml-3.09.dpatch
+++ /dev/null
@@ -1,507 +0,0 @@
-#! /bin/sh /usr/share/dpatch/dpatch-run
-## coq-8.0pl3-ocaml-3.09.dpatch by Samuel Mimram <smimram@debian.org>
-##
-## All lines beginning with `## DP:' are a description of the patch.
-## DP: Patch provided by coq's upstream to fix problems with OCaml 3.09.
-## DP: ftp://ftp.inria.fr/INRIA/coq/V8.0pl3/patch-coq-8.0pl3-ocaml-3.09
-
-@DPATCH@
-diff -urNad coq-8.0pl3~/Makefile coq-8.0pl3/Makefile
---- coq-8.0pl3~/Makefile	2006-01-11 23:18:05.000000000 +0000
-+++ coq-8.0pl3/Makefile	2006-02-19 11:28:43.000000000 +0000
-@@ -77,8 +77,8 @@
- 
- MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
- 
--BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG)
--OPTFLAGS=$(MLINCLUDES) $(CAMLTIMEPROF)
-+BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG) -w y
-+OPTFLAGS=$(MLINCLUDES) $(CAMLTIMEPROF) -w y
- OCAMLDEP=ocamldep
- DEPFLAGS=-slash $(LOCALINCLUDES)
- 
-diff -urNad coq-8.0pl3~/contrib/first-order/sequent.ml coq-8.0pl3/contrib/first-order/sequent.ml
---- coq-8.0pl3~/contrib/first-order/sequent.ml	2004-07-16 19:30:10.000000000 +0000
-+++ coq-8.0pl3/contrib/first-order/sequent.ml	2006-02-19 11:28:43.000000000 +0000
-@@ -6,7 +6,7 @@
- (*         *       GNU Lesser General Public License Version 2.1        *)
- (************************************************************************)
- 
--(* $Id: sequent.ml,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
-+(* $Id: sequent.ml,v 1.17.2.2 2006/01/25 22:40:30 herbelin Exp $ *)
- 
- open Term
- open Util
-@@ -278,7 +278,7 @@
-   let h dbname=
-     let hdb=
-       try
--	Util.Stringmap.find dbname !searchtable 
-+	searchtable_map dbname 
-       with Not_found-> 
- 	error ("Firstorder: "^dbname^" : No such Hint database") in
-       Hint_db.iter g hdb in
-diff -urNad coq-8.0pl3~/contrib/interface/blast.ml coq-8.0pl3/contrib/interface/blast.ml
---- coq-8.0pl3~/contrib/interface/blast.ml	2004-07-16 19:30:11.000000000 +0000
-+++ coq-8.0pl3/contrib/interface/blast.ml	2006-02-19 11:28:43.000000000 +0000
-@@ -351,16 +351,16 @@
-   let db_list =
-     List.map
-       (fun x -> 
--	 try Stringmap.find x !searchtable
-+	 try searchtable_map x
- 	 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 = current_db_names () in
-   let dbnames =  list_subtract dbnames ["v62"] in
--  let db_list = List.map (fun x -> Stringmap.find x !searchtable) dbnames in
-+  let db_list = List.map searchtable_map dbnames in
-   let local_db = make_local_hint_db gl in
-   tclTRY (e_search_auto debug n db_list) gl
- 
-@@ -369,8 +369,6 @@
- (**********************************************************************
-    copié de tactics/auto.ml on a juste modifié search_gen
- *)
--let searchtable_map name = 
--  Stringmap.find name !searchtable
- 
- (* 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
-@@ -499,9 +497,9 @@
- let default_search_depth = ref 5
- 			     
- let full_auto n gl = 
--  let dbnames = stringmap_dom !searchtable in
-+  let dbnames = current_db_names () in
-   let dbnames = list_subtract dbnames ["v62"] in
--  let db_list = List.map (fun x -> searchtable_map x) dbnames in
-+  let db_list = List.map searchtable_map dbnames in
-   let hyps = pf_hyps gl in
-   tclTRY (search n db_list (make_local_hint_db gl) hyps) gl
-   
-diff -urNad coq-8.0pl3~/interp/symbols.ml coq-8.0pl3/interp/symbols.ml
---- coq-8.0pl3~/interp/symbols.ml	2004-11-17 09:33:38.000000000 +0000
-+++ coq-8.0pl3/interp/symbols.ml	2006-02-19 11:28:43.000000000 +0000
-@@ -6,7 +6,7 @@
- (*         *       GNU Lesser General Public License Version 2.1        *)
- (************************************************************************)
- 
--(* $Id: symbols.ml,v 1.31.2.2 2004/11/17 09:33:38 herbelin Exp $ *)
-+(* $Id: symbols.ml,v 1.31.2.3 2006/01/25 22:40:30 herbelin Exp $ *)
- 
- (*i*)
- open Util
-@@ -43,18 +43,18 @@
- type delimiters = string
- 
- type scope = {
--  notations: (interpretation * (dir_path * string) * bool) Stringmap.t;
-+  notations: (string, interpretation * (dir_path * string) * bool) Gmap.t;
-   delimiters: delimiters option
- }
- 
- (* Uninterpreted notation map: notation -> level * dir_path *)
--let notation_level_map = ref Stringmap.empty
-+let notation_level_map = ref Gmap.empty
- 
- (* Scopes table: scope_name -> symbol_interpretation *)
--let scope_map = ref Stringmap.empty
-+let scope_map = ref Gmap.empty
- 
- let empty_scope = {
--  notations = Stringmap.empty;
-+  notations = Gmap.empty;
-   delimiters = None
- }
- 
-@@ -62,20 +62,20 @@
- let type_scope = "type_scope" (* special scope used for interpreting types *)
- 
- let init_scope_map () =
--  scope_map := Stringmap.add default_scope empty_scope !scope_map;
--  scope_map := Stringmap.add type_scope empty_scope !scope_map
-+  scope_map := Gmap.add default_scope empty_scope !scope_map;
-+  scope_map := Gmap.add type_scope empty_scope !scope_map
- 
- (**********************************************************************)
- (* Operations on scopes *)
- 
- let declare_scope scope =
--  try let _ = Stringmap.find scope !scope_map in ()
-+  try let _ = Gmap.find scope !scope_map in ()
-   with Not_found ->
- (*    Options.if_verbose message ("Creating scope "^scope);*)
--    scope_map := Stringmap.add scope empty_scope !scope_map
-+    scope_map := Gmap.add scope empty_scope !scope_map
- 
- let find_scope scope =
--  try Stringmap.find scope !scope_map
-+  try Gmap.find scope !scope_map
-   with Not_found -> error ("Scope "^scope^" is not declared")
- 
- let check_scope sc = let _ = find_scope sc in ()
-@@ -124,7 +124,7 @@
- (**********************************************************************)
- (* Delimiters *)
- 
--let delimiters_map = ref Stringmap.empty
-+let delimiters_map = ref Gmap.empty
- 
- let declare_delimiters scope key =
-   let sc = find_scope scope in
-@@ -134,15 +134,15 @@
-       warning ("Overwritting previous delimiting key "^old^" in scope "^scope)
-   end;
-   let sc = { sc with delimiters = Some key } in
--  scope_map := Stringmap.add scope sc !scope_map;
--  if Stringmap.mem key !delimiters_map then begin
--    let oldsc = Stringmap.find key !delimiters_map in
-+  scope_map := Gmap.add scope sc !scope_map;
-+  if Gmap.mem key !delimiters_map then begin
-+    let oldsc = Gmap.find key !delimiters_map in
-     Options.if_verbose warning ("Hidding binding of key "^key^" to "^oldsc)
-   end;
--  delimiters_map := Stringmap.add key scope !delimiters_map
-+  delimiters_map := Gmap.add key scope !delimiters_map
- 
- let find_delimiters_scope loc key = 
--  try Stringmap.find key !delimiters_map
-+  try Gmap.find key !delimiters_map
-   with Not_found -> 
-     user_err_loc 
-     (loc, "find_delimiters", str ("Unknown scope delimiting key "^key))
-@@ -229,7 +229,7 @@
- let find_with_delimiters = function
-   | None -> None
-   | Some scope ->
--      match (Stringmap.find scope !scope_map).delimiters with
-+      match (Gmap.find scope !scope_map).delimiters with
- 	| Some key -> Some (Some scope, Some key)
- 	| None -> None
- 
-@@ -257,23 +257,23 @@
- (* Uninterpreted notation levels *)
- 
- let declare_notation_level ntn level =
--  if not !Options.v7 & Stringmap.mem ntn !notation_level_map then
-+  if not !Options.v7 & Gmap.mem ntn !notation_level_map then
-     error ("Notation "^ntn^" is already assigned a level");
--  notation_level_map := Stringmap.add ntn level !notation_level_map
-+  notation_level_map := Gmap.add ntn level !notation_level_map
- 
- let level_of_notation ntn =
--  Stringmap.find ntn !notation_level_map
-+  Gmap.find ntn !notation_level_map
- 
- (* The mapping between notations and their interpretation *)
- 
- let declare_notation_interpretation ntn scopt pat df pp8only =
-   let scope = match scopt with Some s -> s | None -> default_scope in
-   let sc = find_scope scope in
--  if Stringmap.mem ntn sc.notations && Options.is_verbose () then
-+  if Gmap.mem ntn sc.notations && Options.is_verbose () then
-     warning ("Notation "^ntn^" was already used"^
-     (if scopt = None then "" else " in scope "^scope));
--  let sc = { sc with notations = Stringmap.add ntn (pat,df,pp8only) sc.notations } in
--  scope_map := Stringmap.add scope sc !scope_map;
-+  let sc = { sc with notations = Gmap.add ntn (pat,df,pp8only) sc.notations } in
-+  scope_map := Gmap.add scope sc !scope_map;
-   if scopt = None then scope_stack := SingleNotation ntn :: !scope_stack
- 
- let declare_uninterpretation rule (metas,c as pat) =
-@@ -292,7 +292,7 @@
- let rec interp_notation loc ntn scopes =
-   let f sc =
-     let scope = find_scope sc in
--    let (pat,df,pp8only) = Stringmap.find ntn scope.notations in
-+    let (pat,df,pp8only) = Gmap.find ntn scope.notations in
-     if pp8only then raise Not_found;
-     pat,(df,if sc = default_scope then None else Some sc) in
-   try find_interpretation f (List.fold_right push_scope scopes !scope_stack)
-@@ -308,7 +308,7 @@
- 
- let availability_of_notation (ntn_scope,ntn) scopes =
-   let f scope =
--    Stringmap.mem ntn (Stringmap.find scope !scope_map).notations in
-+    Gmap.mem ntn (Gmap.find scope !scope_map).notations in
-   find_without_delimiters f (ntn_scope,Some ntn) scopes
- 
- let rec interp_numeral_gen loc f n = function
-@@ -356,8 +356,8 @@
- let exists_notation_in_scope scopt ntn r =
-   let scope = match scopt with Some s -> s | None -> default_scope in
-   try
--    let sc = Stringmap.find scope !scope_map in
--    let (r',_,pp8only) = Stringmap.find ntn sc.notations in
-+    let sc = Gmap.find scope !scope_map in
-+    let (r',_,pp8only) = Gmap.find ntn sc.notations in
-     r' = r, pp8only
-   with Not_found -> false, false
- 
-@@ -487,14 +487,14 @@
- 
- let pr_named_scope prraw scope sc =
-  (if scope = default_scope then
--   match Stringmap.fold (fun _ _ x -> x+1) sc.notations 0 with
-+   match Gmap.fold (fun _ _ x -> x+1) sc.notations 0 with
-      | 0 -> str "No lonely notation"
-      | n -> str "Lonely notation" ++ (if n=1 then mt() else str"s")
-   else 
-     str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters)
-   ++ fnl ()
-   ++ pr_scope_classes scope
--  ++ Stringmap.fold
-+  ++ Gmap.fold
-        (fun ntn ((_,r),(_,df),_) strm ->
- 	 pr_notation_info prraw df r ++ fnl () ++ strm)
-        sc.notations (mt ())
-@@ -502,12 +502,12 @@
- let pr_scope prraw scope = pr_named_scope prraw scope (find_scope scope)
- 
- let pr_scopes prraw =
-- Stringmap.fold 
-+ Gmap.fold 
-    (fun scope sc strm -> pr_named_scope prraw scope sc ++ fnl () ++ strm)
-    !scope_map (mt ())
- 
- let rec find_default ntn = function
--  | Scope scope::_ when Stringmap.mem ntn (find_scope scope).notations ->
-+  | Scope scope::_ when Gmap.mem ntn (find_scope scope).notations ->
-       Some scope
-   | SingleNotation ntn'::_ when ntn = ntn' -> Some default_scope
-   | _::scopes -> find_default ntn scopes
-@@ -531,9 +531,9 @@
-     if String.contains ntn ' ' then (=) ntn
-     else fun ntn' -> List.mem (Terminal ntn) (decompose_notation_key ntn') in
-   let l =
--    Stringmap.fold 
-+    Gmap.fold 
-       (fun scope_name sc ->
--	Stringmap.fold (fun ntn ((_,r),df,_) l ->
-+	Gmap.fold (fun ntn ((_,r),df,_) l ->
- 	  if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations)
-       map [] in
-   let l = List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) l in
-@@ -560,7 +560,7 @@
- 
- let collect_notation_in_scope scope sc known =
-   assert (scope <> default_scope);
--  Stringmap.fold
-+  Gmap.fold
-     (fun ntn ((_,r),(_,df),_) (l,known as acc) ->
-       if List.mem ntn known then acc else ((df,r)::l,ntn::known))
-     sc.notations ([],known)
-@@ -578,7 +578,7 @@
- 	  if List.mem ntn knownntn then (all,knownntn)
- 	  else
- 	    let ((_,r),(_,df),_) =
--	      Stringmap.find ntn (find_scope default_scope).notations in
-+	      Gmap.find ntn (find_scope default_scope).notations in
- 	    let all' = match all with
- 	      | (s,lonelyntn)::rest when s = default_scope ->
- 		  (s,(df,r)::lonelyntn)::rest
-@@ -614,13 +614,13 @@
- 
- (* Concrete syntax for symbolic-extension table *)
- let printing_rules = 
--  ref (Stringmap.empty : unparsing_rule Stringmap.t)
-+  ref (Gmap.empty : (string, unparsing_rule) Gmap.t)
- 
- let declare_notation_printing_rule ntn unpl =
--  printing_rules := Stringmap.add ntn unpl !printing_rules
-+  printing_rules := Gmap.add ntn unpl !printing_rules
- 
- let find_notation_printing_rule ntn =
--  try Stringmap.find ntn !printing_rules
-+  try Gmap.find ntn !printing_rules
-   with Not_found -> anomaly ("No printing rule found for "^ntn)
- 
- (**********************************************************************)
-@@ -644,13 +644,13 @@
- let init () =
-   init_scope_map ();
- (*
--  scope_stack := Stringmap.empty
-+  scope_stack := Gmap.empty
-   arguments_scope := Refmap.empty
- *)
--  notation_level_map := Stringmap.empty;
--  delimiters_map := Stringmap.empty;
-+  notation_level_map := Gmap.empty;
-+  delimiters_map := Gmap.empty;
-   notations_key_table := Gmapl.empty;
--  printing_rules := Stringmap.empty;
-+  printing_rules := Gmap.empty;
-   class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty
- 
- let _ = 
-diff -urNad coq-8.0pl3~/tactics/auto.ml coq-8.0pl3/tactics/auto.ml
---- coq-8.0pl3~/tactics/auto.ml	2005-05-15 12:47:04.000000000 +0000
-+++ coq-8.0pl3/tactics/auto.ml	2006-02-19 11:28:43.000000000 +0000
-@@ -6,7 +6,7 @@
- (*         *       GNU Lesser General Public License Version 2.1        *)
- (************************************************************************)
- 
--(* $Id: auto.ml,v 1.63.2.3 2005/05/15 12:47:04 herbelin Exp $ *)
-+(* $Id: auto.ml,v 1.63.2.4 2006/01/25 22:40:29 herbelin Exp $ *)
- 
- open Pp
- open Util
-@@ -134,24 +134,28 @@
- 
- end
- 
--type frozen_hint_db_table = Hint_db.t Stringmap.t 
-+module Hintdbmap = Gmap
- 
--type hint_db_table = Hint_db.t Stringmap.t ref
-+type frozen_hint_db_table = (string,Hint_db.t) Hintdbmap.t 
-+
-+type hint_db_table = (string,Hint_db.t) Hintdbmap.t ref
- 
- type hint_db_name = string
- 
--let searchtable = (ref Stringmap.empty : hint_db_table)
-+let searchtable = (ref Hintdbmap.empty : hint_db_table)
- 
- let searchtable_map name = 
--  Stringmap.find name !searchtable
-+  Hintdbmap.find name !searchtable
- let searchtable_add (name,db) = 
--  searchtable := Stringmap.add name db !searchtable
-+  searchtable := Hintdbmap.add name db !searchtable
-+let current_db_names () =
-+  Hintdbmap.dom !searchtable
- 
- (**************************************************************************)
- (*                       Definition of the summary                        *)
- (**************************************************************************)
- 
--let init     () = searchtable := Stringmap.empty
-+let init     () = searchtable := Hintdbmap.empty
- let freeze   () = !searchtable
- let unfreeze fs = searchtable := fs
- 
-@@ -498,7 +502,7 @@
- 
- (* 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 dbs = Hintdbmap.to_list !searchtable in
-   let valid_dbs = 
-     map_succeed 
-       (fun (name,db) -> (name,db,Hint_db.map_all c db)) 
-@@ -523,7 +527,7 @@
-       | [] -> assert false 
-     in
-     let hd = head_of_constr_reference hdc in
--    let dbs = stringmap_to_list !searchtable in
-+    let dbs = Hintdbmap.to_list !searchtable in
-     let valid_dbs = 
-       if occur_existential cl then 
- 	map_succeed 
-@@ -568,7 +572,7 @@
-   
- (* displays all the hints of all databases *)
- let print_searchtable () =
--  Stringmap.iter
-+  Hintdbmap.iter
-     (fun name db ->
-        msg (str "In the database " ++ str name ++ fnl ());
-        print_hint_db db)
-@@ -693,7 +697,7 @@
-   tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl 
-     
- let full_trivial gl =
--  let dbnames = stringmap_dom !searchtable in
-+  let dbnames = Hintdbmap.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
-@@ -798,7 +802,7 @@
- let default_auto = auto !default_search_depth []
- 
- let full_auto n gl = 
--  let dbnames = stringmap_dom !searchtable in
-+  let dbnames = Hintdbmap.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
-@@ -911,7 +915,7 @@
-       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
-+  super_search n [Hintdbmap.find "core" !searchtable] db argl g
- 
- let superauto n to_add argl  = 
-   tclTRY (tclCOMPLETE (search_superauto n to_add argl))
-diff -urNad coq-8.0pl3~/tactics/auto.mli coq-8.0pl3/tactics/auto.mli
---- coq-8.0pl3~/tactics/auto.mli	2005-01-21 16:41:52.000000000 +0000
-+++ coq-8.0pl3/tactics/auto.mli	2006-02-19 11:28:43.000000000 +0000
-@@ -6,7 +6,7 @@
- (*         *       GNU Lesser General Public License Version 2.1        *)
- (************************************************************************)
- 
--(*i $Id: auto.mli,v 1.22.2.2 2005/01/21 16:41:52 herbelin Exp $ i*)
-+(*i $Id: auto.mli,v 1.22.2.3 2006/01/25 22:40:29 herbelin Exp $ i*)
- 
- (*i*)
- open Util
-@@ -56,12 +56,16 @@
-     val iter : (constr_label -> stored_data list -> unit) -> t -> unit
-   end
- 
--type frozen_hint_db_table = Hint_db.t Stringmap.t
-+type frozen_hint_db_table
- 
--type hint_db_table = Hint_db.t Stringmap.t ref
-+type hint_db_table
- 
- type hint_db_name = string
- 
-+val searchtable_map : hint_db_name -> Hint_db.t
-+
-+val current_db_names : unit -> hint_db_name list
-+
- val add_hints : locality_flag -> hint_db_name list -> hints -> unit
- 
- val print_searchtable : unit -> unit
-diff -urNad coq-8.0pl3~/tactics/eauto.ml4 coq-8.0pl3/tactics/eauto.ml4
---- coq-8.0pl3~/tactics/eauto.ml4	2004-07-16 19:30:52.000000000 +0000
-+++ coq-8.0pl3/tactics/eauto.ml4	2006-02-19 11:28:43.000000000 +0000
-@@ -8,7 +8,7 @@
- 
- (*i camlp4deps: "parsing/grammar.cma" i*)
- 
--(* $Id: eauto.ml4,v 1.11.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
-+(* $Id: eauto.ml4,v 1.11.2.2 2006/01/25 22:40:29 herbelin Exp $ *)
- 
- open Pp
- open Util
-@@ -391,16 +391,16 @@
-   let db_list =
-     List.map
-       (fun x -> 
--	 try Stringmap.find x !searchtable
-+	 try searchtable_map x
- 	 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 = current_db_names () in
-   let dbnames =  list_subtract dbnames ["v62"] in
--  let db_list = List.map (fun x -> Stringmap.find x !searchtable) dbnames in
-+  let db_list = List.map (fun x -> searchtable_map x) dbnames in
-   let local_db = make_local_hint_db gl in
-   tclTRY (e_search_auto debug n db_list) gl
- 
diff --git a/debian/patches/no-complexity-test.dpatch b/debian/patches/no-complexity-test.dpatch
new file mode 100644
index 00000000..bf89f1f7
--- /dev/null
+++ b/debian/patches/no-complexity-test.dpatch
@@ -0,0 +1,21 @@
+#! /bin/sh /usr/share/dpatch/dpatch-run
+## no-complexity-test.dpatch by Julien Cristau <julien.cristau@ens-lyon.org>
+##
+## All lines beginning with `## DP:' are a description of the patch.
+## DP: Don't run complexity tests, they are far too fragile.
+
+@DPATCH@
+diff -urNad coq-8.1gamma~/test-suite/check coq-8.1gamma/test-suite/check
+--- coq-8.1gamma~/test-suite/check	2006-11-03 14:07:27.000000000 +0100
++++ coq-8.1gamma/test-suite/check	2006-11-23 15:19:49.000000000 +0100
+@@ -145,8 +145,8 @@
+ test_parser parser
+ echo "Interactive tests"
+ test_interactive interactive
+-echo "Complexity tests"
+-test_complexity complexity
++echo "Skipping complexity tests"
++#test_complexity complexity
+ echo "Module tests"
+ $coqtop -compile modules/Nat
+ $coqtop -compile modules/plik
diff --git a/debian/rules b/debian/rules
index b4498d12..d8920943 100755
--- a/debian/rules
+++ b/debian/rules
@@ -10,11 +10,10 @@ export DH_OPTIONS
 # We want to use dpatch
 include /usr/share/dpatch/dpatch.make
 
-COQPREF=$(CURDIR)/debian/tmp
-ADDPREF=COQINSTALLPREFIX=$(COQPREF)
+COQPREF := $(CURDIR)/debian/tmp
+ADDPREF := COQINSTALLPREFIX=$(COQPREF)
 
-CONFIGUREOPTS=--prefix /usr --mandir /usr/share/man \
-	--emacslib /usr/share/emacs/site-lisp/coq --reals all
+CONFIGUREOPTS := --prefix /usr --mandir /usr/share/man --emacslib /usr/share/emacs/site-lisp/coq --reals all --fsets all
 
 configure: configure-stamp
 configure-stamp:
@@ -43,6 +42,13 @@ build-stamp:
 	else \
 		$(MAKE) BEST=byte HASCOQIDE=byte check; \
 	fi
+	if [ -e opt-stamp ]; then \
+		$(MAKE) BEST=opt glob.dump; \
+	else \
+		$(MAKE) BEST=byte HASCOQIDE=byte glob.dump; \
+	fi
+	cp tools/coqdoc/coqdoc.sty doc/stdlib/
+	$(MAKE) -C doc stdlib/html/index.html
 	touch build-stamp
 
 clean: unpatch
@@ -52,9 +58,11 @@ clean: unpatch
 
 	-$(MAKE) clean
 	-$(MAKE) archclean
-	rm -f bin/parser.opt
+	rm -f bin/*
 	rm -f tools/coqdoc/*.cm[oi]
 	rm -f config/coq_config.ml config/Makefile test-suite/check.log
+	rm -f dev/ocamldebug-v7
+	rm -f ide/undo.mli glob.dump
 
 	dh_clean
 
@@ -74,11 +82,10 @@ install: build
 		echo "Stripping: $$i"; \
 		strip -R .note -R .comment $$i; \
 	done
-	-for i in $(COQPREF)/usr/bin/coqide.*; do \
-		echo "Rpath for `chrpath $$i`"; \
-		echo "Removing rpath: $$i"; \
-		chrpath -d $$i; \
-	done
+	if [ -e opt-stamp ]; then \
+		strip -R .note -R .comment $ $(COQPREF)/usr/bin/coqc; \
+		strip -R .note -R .comment $(COQPREF)/usr/bin/coqmktop; \
+	fi
 	cp debian/coq.xpm debian/coq/usr/share/pixmaps/coq.xpm
 	cp debian/coq.xpm debian/coqide/usr/share/pixmaps/coqide.xpm
 	cp debian/coqide.desktop debian/coqide/usr/share/applications
@@ -96,7 +103,8 @@ install: build
 	cp debian/coqmktop.1 debian/coq/usr/share/man/man1/coqmktop.1
 	cp debian/coqtop.1 debian/coq/usr/share/man/man1/coqtop.1
 
-	chmod -x debian/tmp/usr/lib/coq/ide/coq2.ico
+	cp -r doc/stdlib/html debian/coq-libs/usr/share/doc/coq-libs/
+	cd debian/coq-libs/usr/share/doc/coq; ln -s ../coq-libs/html stdlib
 
 	# These are installed as docs
 	rm -f $(COQPREF)/usr/lib/coq/ide/utf8.v $(COQPREF)/usr/lib/coq/ide/FAQ
@@ -111,6 +119,7 @@ binary-common:
 	dh_installemacsen
 	dh_installman
 	dh_installchangelogs CHANGES
+	dh_installtex
 	dh_desktop
 	dh_link
 	dh_compress
diff --git a/debian/utils/purify_tarball b/debian/utils/purify_tarball
new file mode 100755
index 00000000..ea7e08f1
--- /dev/null
+++ b/debian/utils/purify_tarball
@@ -0,0 +1,26 @@
+#!/bin/sh
+
+set -e
+
+CURDIR=`pwd`
+ORIG=$1
+WORKDIR=`dirname $ORIG`
+ORIGFILE=`basename $ORIG`
+VERSION=`echo "$ORIGFILE" | sed "s/^coq-\([0-9\.]\+\)\.tar\.gz$/\1/"`
+
+cd $WORKDIR
+
+tar zxf $ORIGFILE
+
+rm -rf coq-$VERSION/doc/common
+rm -rf coq-$VERSION/doc/faq
+rm -rf coq-$VERSION/doc/RecTutorial
+rm -rf coq-$VERSION/doc/refman
+rm -rf coq-$VERSION/doc/rt
+rm -rf coq-$VERSION/doc/tools
+rm -rf coq-$VERSION/doc/tutorial
+
+tar zcf coq_$VERSION+dfsg.orig.tar.gz coq-$VERSION/
+rm -rf coq-$VERSION
+
+cd $CURDIR
diff --git a/debian/watch b/debian/watch
index 8867705d..45c97702 100644
--- a/debian/watch
+++ b/debian/watch
@@ -1,2 +1,2 @@
-version=2
+version=3
 ftp://ftp.inria.fr/INRIA/coq/current/coq-([0-9a-z\.]*)\.tar\.gz debian uupdate
diff --git a/dev/Makefile.common b/dev/Makefile.common
deleted file mode 100644
index 1ff5cf79..00000000
--- a/dev/Makefile.common
+++ /dev/null
@@ -1,52 +0,0 @@
-# this Makefile contains goals common for directory and main devel makefiles
-
-ifndef TOPDIR
-TOPDIR=..
-endif
-
-ifndef BASEDIR
-BASEDIR=
-endif
-
-# the following entries are used to make synchronize two source trees
-# (on big computer and on a laptop for example)
-
-OTHER_FILE=$(TOPDIR)/dev/other
-OTHER=$(shell cat $(OTHER_FILE))
-
-# this is a directory of useful temporary things
-WORKDIR=tmp
-
-ifneq (,$(findstring n,$(MAKEFLAGS)))
-NFLAG=-n
-else
-NFLAG=
-endif
-
-check_other:
-	+@(if [ "$(OTHER)" = "" ] ; then \
-	  echo You must put the ssh path to the other Coq source in $(OTHER_FILE) ; \
-	  echo For example: chrzaszc@ruta:coq/V7 ; \
-	  exit 1; \
-	fi)
-
-get:	check_other
-	+rsync -Cauvz $(NFLAG) $(OTHER)/ $(TOPDIR)/
-	+@(if [ -d $(TOPDIR)/$(WORKDIR) ]; then \
-	  rsync -auvz $(NFLAG) $(OTHER)/tmp/ $(TOPDIR)/tmp/ ; \
-	fi)
-
-put:	check_other
-	+rsync -Cauvz $(NFLAG) $(TOPDIR)/ $(OTHER)/
-	+@(if [ -d $(TOPDIR)/$(WORKDIR) ]; then \
-	  rsync -auvz $(NFLAG) $(TOPDIR)/tmp/ $(OTHER)/tmp/ ; \
-	fi)
-
-sync:	get put
-
-
-conflicts:
-	cvs status | grep File | grep conflicts | less
-
-confl:	conflicts
-
diff --git a/dev/Makefile.subdir b/dev/Makefile.subdir
deleted file mode 100644
index 45358c42..00000000
--- a/dev/Makefile.subdir
+++ /dev/null
@@ -1,7 +0,0 @@
-# if you work in a sub/sub-rectory of Coq
-# you should make a link to that makefile 
-#    ln -s ../../dev/Makefile.subdir Makefile
-# in order to have all the facilities of dev/Makefile.dir
-
-TOPDIR=../..
-include $(TOPDIR)/dev/Makefile.dir
diff --git a/dev/README b/dev/README
index a8811bea..0e40e820 100644
--- a/dev/README
+++ b/dev/README
@@ -1,21 +1,49 @@
-This directory contains informations and tools to help developping the
-Coq system
+This directory contains informations and tools to help developing the
+                             Coq system
+                       ======================
 
 
-TODO
-changements.txt
-header
-lisezmoi.txt			   
-style.txt			   
+Debugging and profiling (in current directory - see doc/debugging.txt)
+-----------------------
 
-Debugging and profiling
-=======================
+ocamldebug-coq: to launch ocaml debugger
 
-debugging.txt: help for debugging or profiling
-db: to install pretty-printers from ocaml debugger
+db:      to install pretty-printers from ocaml debugger
 base_db: to install raw pretty-printers from ocaml debugger
-ocamldebug-v7: to launch ocaml debugger
-include: to install pretty-printers from ocaml toplevel
+
+include:      to install pretty-printers from ocaml toplevel
 base_include: to install raw pretty-printers from ocaml toplevel
+
+vm_printers.ml, dev_printers.ml: ML pretty-printers for debugging
+
+
+Miscellaneous informations about the code (directory doc)
+-----------------------------------------
+
+changes.txt:   (partial) per-version summary of the evolutions of Coq ML source
+style.txt:     a few style recommendations for writing Coq ML files
+debugging.txt: help for debugging or profiling
 universes.txt: help to debug universes
+translate.txt: help to use coq translator
+extensions.txt: some help about TACTIC EXTEND
+
+header:        standard header for Coq ML files
+perf-analysis: analysis of perfs measured on the compilation of user contribs
+cic.dtd:       official dtd of the calc. of ind. constr. for im/ex-portation
+
+
+Documentation of ML interfaces using tex (directory ocamlweb-doc)
+----------------------------------------
+
+go in directory and call "make"
+
+
+Other development tools (directory tools)
+-----------------------
+
 univdot: produces a graph of CIC universes
+Makefile.dir: makefile dedicated to intensive work in a given directory
+Makefile.subdir: makefile dedicated to intensive work in a given subdirectory
+Makefile.devel: utilities to automatically launch coq in various states
+Makefile.common: used by other Makefiles
+objects.el: various development utilities at emacs level
diff --git a/dev/base_include b/dev/base_include
index 17293776..b7fa38ea 100644
--- a/dev/base_include
+++ b/dev/base_include
@@ -13,45 +13,153 @@
 #directory "proofs";;
 #directory "tactics";;
 #directory "translate";;
-#use "top_printers.ml";;
 
-#install_printer  (* identifier *) prid;;
-#install_printer  (* label *) prlab;;
-#install_printer prmsid;;
-#install_printer prmbid;;
-#install_printer prdir;;
-#install_printer prmp;;
-#install_printer  (* section_path *)  prsp;;
-#install_printer  (* qualid *)  prqualid;;
-#install_printer  (* kernel_name *) prkn;;
-#install_printer  (* constr *)  print_pure_constr;;
+#use "top_printers.ml";;
+#use "vm_printers.ml";;
+
+#install_printer  (* identifier *) ppid;;
+#install_printer  (* identifier *) ppidset;;
+#install_printer  (* label *) pplab;;
+#install_printer  (* mod_self_id *) ppmsid;;
+#install_printer  (* mod_bound_id *) ppmbid;;
+#install_printer  (* dir_path *) ppdir;;
+#install_printer  (* module_path *) ppmp;;
+#install_printer  (* section_path *)  ppsp;;
+#install_printer  (* qualid *)  ppqualid;;
+#install_printer  (* kernel_name *) ppkn;;
+#install_printer  (* constant *) ppcon;;
+#install_printer  (* constr *)  print_pure_constr;; 
+#install_printer  (* patch *) ppripos;;
+#install_printer  (* values *) ppvalues;;
+#install_printer ppzipper;;
+#install_printer ppstack;;
+#install_printer ppatom;;
+#install_printer ppwhd;;
+#install_printer ppvblock;;
+#install_printer  (* bigint *) ppbigint;;
+#install_printer  (* loc *) pploc;;
+
+(* Open main files *)
+
+open Names
+open Term
+open Typeops
+open Univ
+open Inductive
+open Indtypes
+open Cooking
+open Closure
+open Reduction
+open Safe_typing
+open Declare
+open Declaremods
+open Impargs
+open Libnames
+open Nametab
+open Library
+
+open Cases
+open Pattern
+open Cbv
+open Classops
+open Pretyping
+open Cbv
+open Classops
+open Pretyping
+open Clenv
+open Rawterm
+open Coercion
+open Recordops
+open Detyping
+open Reductionops
+open Evarconv
+open Retyping
+open Evarutil
+open Tacred
+open Evd
+open Termops
+open Indrec
+open Typing
+open Inductiveops
+open Unification
+
+open Constrextern
+open Constrintern
+open Coqlib
+open Genarg
+open Modintern
+open Notation
+open Ppextend
+open Reserve
+open Syntax_def
+open Topconstr
+
+open Clenvtac
+open Evar_refiner
+open Logic
+open Pfedit
+open Proof_trees
+open Proof_type
+open Redexpr
+open Refiner
+open Tacmach
+
+open Auto
+open Autorewrite
+open Contradiction
+open Dhyp
+open Eauto
+open Elim
+open Equality
+open Evar_tactics
+open Extraargs
+open Extratactics
+open Hiddentac
+open Hipattern
+open Inv
+open Leminv
+open Refine
+open Setoid_replace
+open Tacinterp
+open Tacticals
+open Tactics
+
+open Cerrors
+open Class
+open Command
+open Coqinit
+open Coqtop
+open Discharge
+open Himsg
+open Metasyntax
+open Mltop
+open Record
+open Toplevel
+open Vernacentries
+open Vernacinterp
+open Vernac
 
-(* parsing of names *)
+(* Various utilities *)
 
 let qid = Libnames.qualid_of_string;;
 
 (* parsing of terms *)
 
-let parse_com   = Pcoq.parse_string Pcoq.Constr.constr;;
-let parse_tac = Pcoq.parse_string Pcoq.Tactic.tactic;;
+let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;;
+let parse_tac    = Pcoq.parse_string Pcoq.Tactic.tactic;;
 let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;;
 
-(* For compatibility reasons *)
-let parse_ast = parse_com;;
-
 (* build a term of type rawconstr without type-checking or resolution of 
    implicit syntax *)
 
-let e s = Constrintern.interp_rawconstr Evd.empty (Global.env()) (parse_ast s);;
-
-(* For compatibility *)
-let raw_constr_of_string = e;;
+let e s =
+  Constrintern.intern_constr Evd.empty (Global.env()) (parse_constr s);;
 
 (* build a term of type constr with type-checking and resolution of 
    implicit syntax *)
 
 let constr_of_string s = 
-  Constrintern.interp_constr Evd.empty (Global.env()) (parse_ast s);;
+  Constrintern.interp_constr Evd.empty (Global.env()) (parse_constr s);;
 
 (* get the body of a constant *)
 
@@ -69,7 +177,7 @@ let get_nth_goal n = nth_goal_of_pftreestate n (Pfedit.get_pftreestate ());;
 let current_goal () = get_nth_goal 1;;
 
 let pf_e gl s = 
-    Constrintern.interp_constr (project gl) (pf_env gl) (parse_ast s);;
+  Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);;
 
 open Toplevel
 let go = loop
diff --git a/dev/db b/dev/db
index 44effd77..784e5bac 100644
--- a/dev/db
+++ b/dev/db
@@ -1,35 +1,38 @@
 load_printer "gramlib.cma"
-load_printer "top_printers.cmo"
-install_printer Top_printers.prid
-install_printer Top_printers.prlab
-install_printer Top_printers.prmsid
-install_printer Top_printers.prmbid
-install_printer Top_printers.prdir
-install_printer Top_printers.prmp
-install_printer Top_printers.prkn
-install_printer Top_printers.prsp
-install_printer Top_printers.prqualid
-install_printer Top_printers.prast
-install_printer Top_printers.prastpat
-install_printer Top_printers.prastpatl
+load_printer "printers.cma"
+
+install_printer Top_printers.ppid
+install_printer Top_printers.ppidset
+install_printer Top_printers.pplab
+install_printer Top_printers.ppmsid
+install_printer Top_printers.ppmbid
+install_printer Top_printers.ppdir
+install_printer Top_printers.ppmp
+install_printer Top_printers.ppkn
+install_printer Top_printers.ppcon
+install_printer Top_printers.ppsp
+install_printer Top_printers.ppqualid
+install_printer Top_printers.ppbigint
 
 install_printer Top_printers.pppattern
-install_printer Top_printers.pprawterm
+install_printer Top_printers.pprawconstr
 
-install_printer Top_printers.ppterm
-install_printer Top_printers.print_uni
-install_printer Top_printers.pp_universes
+install_printer Top_printers.ppconstr
+install_printer Top_printers.ppuni
+install_printer Top_printers.ppuniverses
 install_printer Top_printers.pptype
-install_printer Top_printers.prj
+install_printer Top_printers.ppj
+install_printer Top_printers.ppenv
 
-install_printer Top_printers.prgoal
-install_printer Top_printers.prsigmagoal
+install_printer Top_printers.ppgoal
+install_printer Top_printers.ppsigmagoal
 install_printer Top_printers.pproof
-install_printer Top_printers.prevd
-install_printer Top_printers.prevc
-install_printer Top_printers.prwc
-install_printer Top_printers.prclenv
+install_printer Top_printers.ppevd
+install_printer Top_printers.ppevm
+install_printer Top_printers.ppclenv
 
 install_printer Top_printers.pptac
-install_printer Top_printers.pr_obj                                                     
+install_printer Top_printers.ppobj
+install_printer Top_printers.pploc
+                                                  
 
diff --git a/dev/deboguage.txt b/dev/deboguage.txt
deleted file mode 100644
index eea7a0bc..00000000
--- a/dev/deboguage.txt
+++ /dev/null
@@ -1,30 +0,0 @@
-
-Debuggage
-=========
-
-   dans Emacs. nécessite le mode tuareg.
-   Coq doit être configuré avec -debug et -local (./configure -debug -local)
-
-   1. M-x camldebug
-   2. spécifier le binaire coqtop.byte
-   3. spécifier dev/ocamldebug-v7
-   4. source db  (pour avoir les pretty-printers)
-   5. poser ses points d'arrêts avec C-x C-a C-b (penser "add breakpoint")
-      directement dans le source ocaml
-   6. ensuite voir le man d'ocamldebug
-         run
-	 step
-	 next
-	 last
-	 print x
-	 ...
-
-
-Profiling
-=========
-
-   Coq doit être configuré avec -profile
-
-   1. Lancer Coq en natif, qui doit terminer normalement (utiliser Quit
-      ou l'option -batch)
-   2. gprof ./coqtop gmon.out
diff --git a/dev/changements.txt b/dev/doc/changes.txt
index d1df2a81..90e29496 100644
--- a/dev/changements.txt
+++ b/dev/doc/changes.txt
@@ -1,3 +1,70 @@
+=========================================
+= CHANGES BETWEEN COQ V8.0 AND COQ V8.1 =
+=========================================
+
+A few differences in Coq ML interfaces between Coq V8.0 and V8.1
+================================================================
+
+** Functions
+
+Util: option_app -> option_map
+Term: substl_decl -> subst_named_decl
+Lib: library_part -> remove_section_part
+Printer: prterm -> pr_lconstr
+Printer: prterm_env -> pr_lconstr_env
+Ppconstr: pr_sort -> pr_rawsort
+Evd: in_dom, etc got standard ocaml names (i.e. mem, etc)
+Pretyping: 
+ - understand_gen_tcc and understand_gen_ltac merged into understand_ltac
+ - type_constraints can now say typed by a sort (use OfType to get the
+   previous behavior)
+Library: import_library -> import_module
+
+** Constructors
+
+Declarations: mind_consnrealargs -> mind_consnrealdecls
+NoRedun -> NoDup
+Cast and RCast have an extra argument: you can recover the previous
+  behavior by setting the extra argument to "CastConv DEFAULTcast" and
+  "DEFAULTcast" respectively
+Names: "kernel_name" is now "constant" when argument of Term.Const
+Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert
+Tacexpr: TacForward(true,_,_) branched to TacLetTac
+
+** Modules
+
+module Decl_kinds: new interface
+module Bigint: new interface
+module Tacred spawned module Redexpr
+module Symbols -> Notation
+module Coqast, Ast, Esyntax, Termast, and all other modules related to old
+  syntax are removed
+module Instantiate: integrated to Evd
+module Pretyping now a functor: use Pretyping.Default instead
+
+** Internal names
+
+OBJDEF and OBJDEF1 -> CANONICAL-STRUCTURE
+
+** Tactic extensions
+
+- printers have an extra parameter which is a constr printer at high precedence
+- the tactic printers have an extra arg which is the expected precedence 
+- level is now a precedence in declare_extra_tactic_pprule
+- "interp" functions now of types the actual arg type, not its encapsulation
+  as a generic_argument
+
+=========================================
+= CHANGES BETWEEN COQ V7.4 AND COQ V8.0 =
+=========================================
+
+See files in dev/syntax-v8
+
+
+==============================================
+= MAIN CHANGES BETWEEN COQ V7.3 AND COQ V7.4 =
+==============================================
+
 CHANGES DUE TO INTRODUCTION OF MODULES
 ======================================
 
@@ -183,8 +250,8 @@ Uses Declaremods to actually communicate with Global and to register
 objects.
 
 
-MAIN CHANGES FROM COQ V7.3
-==========================
+OTHER CHANGES
+=============
 
 Internal representation of tactics bindings has changed (see type
 Rawterm.substitution).
@@ -228,8 +295,10 @@ Tactics about False and not now in tactics/contradiction.ml
 Tactics depending on Init now tactics/*.ml4 (no longer in tactics/*.v)
 File tacinterp.ml moved from proofs to directory tactics
 
-MAIN CHANGES FROM COQ V7.1 TO COQ V7.2
-======================================
+
+==========================================
+= MAIN CHANGES FROM COQ V7.1 TO COQ V7.2 =
+==========================================
 
 The core of Coq (kernel) has meen minimized with the following effects:
 
@@ -242,8 +311,9 @@ the prefixes "Is" ans "IsMut" have been dropped from kind_of_term constructors,
 e.g. IsRel is now Rel, IsMutCase is now Case, etc.
 
 
-PRINCIPAUX CHANGEMENTS ENTRE COQ V6.3.1 ET COQ V7.0
-===================================================
+=======================================================
+= PRINCIPAUX CHANGEMENTS ENTRE COQ V6.3.1 ET COQ V7.0 =
+=======================================================
 
 Changements d'organisation / modules :
 --------------------------------------
diff --git a/dev/doc/cic.dtd b/dev/doc/cic.dtd
new file mode 100644
index 00000000..f2314e22
--- /dev/null
+++ b/dev/doc/cic.dtd
@@ -0,0 +1,231 @@
+<?xml encoding="ISO-8859-1"?>
+
+<!-- DTD FOR CIC OBJECTS: -->
+
+<!-- CIC term declaration -->
+
+<!ENTITY % term '(LAMBDA|CAST|PROD|REL|SORT|APPLY|VAR|META|IMPLICIT|CONST|
+                  LETIN|MUTIND|MUTCONSTRUCT|MUTCASE|FIX|COFIX|instantiate)'>
+
+<!-- CIC sorts -->
+
+<!ENTITY % sort '(Prop|Set|Type)'>
+
+<!-- CIC sequents -->
+
+<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'>
+
+<!-- CIC objects: -->
+
+<!ELEMENT ConstantType %term;>
+<!ATTLIST ConstantType
+          name       CDATA      #REQUIRED
+          id         ID         #REQUIRED>
+
+<!ELEMENT ConstantBody %term;>
+<!ATTLIST ConstantBody
+          for        CDATA      #REQUIRED
+          params     CDATA      #REQUIRED
+          id         ID         #REQUIRED>
+
+<!ELEMENT CurrentProof (Conjecture*,body)>
+<!ATTLIST CurrentProof
+          of         CDATA      #REQUIRED
+          id         ID         #REQUIRED>
+
+<!ELEMENT InductiveDefinition (InductiveType+)>
+<!ATTLIST InductiveDefinition
+          noParams NMTOKEN #REQUIRED
+          params   CDATA   #REQUIRED
+          id       ID      #REQUIRED>
+
+<!ELEMENT Variable (body?,type)>
+<!ATTLIST Variable
+          name CDATA #REQUIRED
+          id   ID    #REQUIRED>
+
+<!ELEMENT Sequent %sequent;>
+<!ATTLIST Sequent
+          no  NMTOKEN #REQUIRED
+          id  ID      #REQUIRED>
+
+<!-- Elements used in CIC objects, which are not terms: -->
+
+<!ELEMENT InductiveType (arity,Constructor*)>
+<!ATTLIST InductiveType
+          name      CDATA        #REQUIRED
+          inductive (true|false) #REQUIRED>
+
+<!ELEMENT Conjecture %sequent;>
+<!ATTLIST Conjecture
+          no NMTOKEN #REQUIRED
+          id ID      #REQUIRED>
+
+<!ELEMENT Constructor %term;>
+<!ATTLIST Constructor
+          name CDATA #REQUIRED>
+
+<!ELEMENT Decl %term;>
+<!ATTLIST Decl
+          name CDATA #IMPLIED
+          id   ID    #REQUIRED>
+
+<!ELEMENT Def %term;>
+<!ATTLIST Def
+          name CDATA #IMPLIED
+          id   ID    #REQUIRED>
+
+<!ELEMENT Hidden EMPTY>
+<!ATTLIST Hidden
+          id ID #REQUIRED>
+
+<!ELEMENT Goal %term;>
+
+<!-- CIC terms: -->
+
+<!ELEMENT LAMBDA (decl*,target)>
+<!ATTLIST LAMBDA
+          sort %sort; #REQUIRED>
+
+<!ELEMENT LETIN (def*,target)>
+<!ATTLIST LETIN
+          id   ID     #REQUIRED
+          sort %sort; #REQUIRED>
+
+<!ELEMENT PROD (decl*,target)>
+<!ATTLIST PROD
+          type %sort; #REQUIRED>
+
+<!ELEMENT CAST (term,type)>
+<!ATTLIST CAST
+          id   ID     #REQUIRED
+          sort %sort; #REQUIRED>
+
+<!ELEMENT REL EMPTY>
+<!ATTLIST REL
+          value  NMTOKEN #REQUIRED
+          binder CDATA   #REQUIRED
+          id     ID      #REQUIRED
+          idref  IDREF   #REQUIRED
+          sort   %sort;  #REQUIRED>
+
+<!ELEMENT SORT EMPTY>
+<!ATTLIST SORT
+          value CDATA #REQUIRED
+          id    ID    #REQUIRED>
+
+<!ELEMENT APPLY (%term;)+>
+<!ATTLIST APPLY
+          id   ID     #REQUIRED
+          sort %sort; #REQUIRED>
+
+<!ELEMENT VAR EMPTY>
+<!ATTLIST VAR
+          relUri CDATA  #REQUIRED
+          id     ID     #REQUIRED
+          sort   %sort; #REQUIRED>
+
+<!-- The substitutions are ordered by increasing DeBrujin  -->
+<!-- index. An empty substitution means that that index is -->
+<!-- not accessible.                                       -->
+<!ELEMENT META (substitution*)>
+<!ATTLIST META
+          no              NMTOKEN #REQUIRED
+          id              ID      #REQUIRED
+          sort            %sort;  #REQUIRED>
+
+<!ELEMENT IMPLICIT EMPTY>
+<!ATTLIST IMPLICIT
+          id ID #REQUIRED>
+
+<!ELEMENT CONST EMPTY>
+<!ATTLIST CONST
+          uri  CDATA  #REQUIRED
+          id   ID     #REQUIRED
+          sort %sort; #REQUIRED>
+
+<!ELEMENT MUTIND EMPTY>
+<!ATTLIST MUTIND
+          uri    CDATA   #REQUIRED
+          noType NMTOKEN #REQUIRED
+          id     ID      #REQUIRED>
+
+<!ELEMENT MUTCONSTRUCT EMPTY>
+<!ATTLIST MUTCONSTRUCT
+          uri      CDATA   #REQUIRED
+          noType   NMTOKEN #REQUIRED
+          noConstr NMTOKEN #REQUIRED
+          id       ID      #REQUIRED
+          sort     %sort;  #REQUIRED>
+
+<!ELEMENT MUTCASE (patternsType,inductiveTerm,pattern*)>
+<!ATTLIST MUTCASE
+          uriType CDATA   #REQUIRED
+          noType  NMTOKEN #REQUIRED
+          id      ID      #REQUIRED
+          sort    %sort;  #REQUIRED>
+
+<!ELEMENT FIX (FixFunction+)>
+<!ATTLIST FIX
+          noFun NMTOKEN #REQUIRED
+          id    ID      #REQUIRED
+          sort  %sort;  #REQUIRED>
+
+<!ELEMENT COFIX (CofixFunction+)>
+<!ATTLIST COFIX
+          noFun NMTOKEN #REQUIRED
+          id    ID      #REQUIRED
+          sort  %sort;  #REQUIRED>
+
+<!-- Elements used in CIC terms: -->
+
+<!ELEMENT FixFunction (type,body)>
+<!ATTLIST FixFunction
+          name     CDATA   #REQUIRED
+          recIndex NMTOKEN #REQUIRED>
+
+<!ELEMENT CofixFunction (type,body)>
+<!ATTLIST CofixFunction
+          name     CDATA   #REQUIRED>
+
+<!ELEMENT substitution ((%term;)?)>
+
+<!-- Explicit named substitutions: -->
+
+<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT),arg+)>
+<!ATTLIST instantiate
+          id ID #IMPLIED>
+
+<!-- Sintactic sugar for CIC terms and for CIC objects: -->
+
+<!ELEMENT arg %term;>
+<!ATTLIST arg
+          relUri CDATA #REQUIRED>
+
+<!ELEMENT decl %term;>
+<!ATTLIST decl
+          id     ID     #REQUIRED
+          type   %sort; #REQUIRED
+          binder CDATA  #IMPLIED>
+          
+<!ELEMENT def %term;>
+<!ATTLIST def
+          id     ID     #REQUIRED
+          sort   %sort; #REQUIRED
+          binder CDATA  #IMPLIED>
+
+<!ELEMENT target %term;>
+
+<!ELEMENT term %term;>
+
+<!ELEMENT type  %term;>
+
+<!ELEMENT arity %term;>
+
+<!ELEMENT patternsType  %term;>
+
+<!ELEMENT inductiveTerm  %term;>
+
+<!ELEMENT pattern  %term;>
+
+<!ELEMENT body  %term;>
diff --git a/dev/debugging.txt b/dev/doc/debugging.txt
index d3fbf48a..e5c83139 100644
--- a/dev/debugging.txt
+++ b/dev/doc/debugging.txt
@@ -1,4 +1,3 @@
-
 Debugging from Coq toplevel using Caml trace mechanism
 ======================================================
 
@@ -12,6 +11,10 @@ Debugging from Coq toplevel using Caml trace mechanism
   6. Test your Coq command and observe the result of tracing your functions
   7. Freely switch from Coq to Ocaml toplevels with 'Drop.' and 'go();;'
 
+  Hints: To remove high-level pretty-printing features (coercions,
+  notations, ...), use "Set Printing All". It will affect the #trace
+  printers too.
+
 Debugging from Caml debugger
 ============================
 
@@ -19,8 +22,8 @@ Debugging from Caml debugger
    Coq must be configured with -debug and -local (./configure -debug -local)
 
    1. M-x camldebug
-   2. give the binary name coqtop.byte
-   3. give dev/ocamldebug-v7
+   2. give the binary name bin/coqtop.byte
+   3. give ../dev/ocamldebug-coq
    4. source db  (to get pretty-printers)
    5. add breakpoints with C-x C-a C-b from the buffer displaying the ocaml
       source
@@ -36,15 +39,33 @@ Debugging from Caml debugger
    7. some hints: 
 
    - To debug a failure/error/anomaly, add a breakpoint in
-     Vernacinterp.call just before "if !Options.debug" then go "back" to
-     find where the failure/error/anomaly has been raised
-   - If "source db" fails, first recompile top_printers.ml with
-     "make dev/top_printers.cmo"
+     Vernac.vernac_com at the with clause of the "try ... interp com
+     with ..." block, then go "back" a few steps to find where the
+     failure/error/anomaly has been raised
+   - Alternatively, for an error or an anomaly, add breakpoints in the middle  
+     of each of error* functions or anomaly* functions in lib/util.ml
+   - If "source db" fails, recompile printers.cma with
+     "make dev/printers.cma" and try again
 
-Profiling
-=========
+Global gprof-based profiling
+============================
 
    Coq must be configured with option -profile
 
    1. Run native Coq which must end normally (use Quit or option -batch)
    2. gprof ./coqtop gmon.out
+
+Per function profiling
+======================
+
+   1. To profile function foo in file bar.ml, add the following lines, just
+      after the definition of the function:
+
+     let fookey = Profile.declare_profile "foo";;
+     let foo a b c = Profile.profile3 fookey foo a b c;;
+
+     where foo is assumed to have three arguments (adapt using
+     Profile.profile1, Profile. profile2, etc).
+
+     This has the effect to cumulate the time passed in foo under a
+     line of name "foo" which is displayed at the time coqtop exits.
diff --git a/dev/doc/extensions.txt b/dev/doc/extensions.txt
new file mode 100644
index 00000000..eb4d2659
--- /dev/null
+++ b/dev/doc/extensions.txt
@@ -0,0 +1,19 @@
+Comment ajouter une nouvelle entrée primitive pour les TACTIC EXTEND ?
+======================================================================
+
+Exemple de l'ajout de l'entrée "clause":
+
+- ajouter un type ClauseArgType dans interp/genarg.ml{,i}, avec les
+  wit_, rawwit_, et globwit_ correspondants
+
+- ajouter partout où Genarg.argument_type est filtré le cas traitant de
+  ce nouveau ClauseArgType
+
+- utiliser le rawwit_clause pour définir une entrée clause du bon
+  type et du bon nom dans le module Tactic de pcoq.ml4
+
+- il faut aussi exporter la règle hors de g_tactic.ml4. Pour cela, il
+  faut rejouter clause dans le GLOBAL du GEXTEND
+
+- seulement après, le nom clause sera accessible dans les TACTIC EXTEND !
+
diff --git a/dev/header b/dev/doc/header
index 57945e47..57945e47 100644
--- a/dev/header
+++ b/dev/doc/header
diff --git a/dev/doc/minicoq.tex b/dev/doc/minicoq.tex
new file mode 100644
index 00000000..a34b03a4
--- /dev/null
+++ b/dev/doc/minicoq.tex
@@ -0,0 +1,98 @@
+\documentclass{article}
+
+\usepackage{fullpage}
+\input{./macros.tex}
+\newcommand{\minicoq}{\textsf{minicoq}}
+\newcommand{\nonterm}[1]{\textit{#1}}
+\newcommand{\terminal}[1]{\textsf{#1}}
+\newcommand{\listzero}{\textit{LIST$_0$}}
+\newcommand{\listun}{\textit{LIST$_1$}}
+\newcommand{\sep}{\textit{SEP}}
+
+\title{Minicoq: a type-checker for the pure \\ 
+       Calculus of Inductive Constructions}
+
+
+\begin{document}
+
+\maketitle
+
+\section{Introduction}
+
+\minicoq\ is a minimal toplevel for the \Coq\ kernel.
+
+
+\section{Grammar of terms}
+
+The grammar of \minicoq's terms is given in Figure~\ref{fig:terms}. 
+
+\begin{figure}[htbp]
+  \hrulefill
+  \begin{center}
+    \begin{tabular}{lrl}
+      term & ::= & identifier \\
+           & $|$ & \terminal{Rel} integer \\
+           & $|$ & \terminal{Set} \\
+           & $|$ & \terminal{Prop} \\
+           & $|$ & \terminal{Type} \\
+           & $|$ & \terminal{Const} identifier \\
+           & $|$ & \terminal{Ind} identifier integer \\
+           & $|$ & \terminal{Construct} identifier integer integer \\
+           & $|$ & \terminal{[} name \terminal{:} term
+                   \terminal{]} term \\
+           & $|$ & \terminal{(} name \terminal{:} term
+                   \terminal{)} term \\
+           & $|$ & term \verb!->! term \\
+           & $|$ & \terminal{(} \listun\ term \terminal{)} \\
+           & $|$ & \terminal{(} term \terminal{::} term \terminal{)} \\
+           & $|$ & \verb!<! term \verb!>! \terminal{Case}
+                   term \terminal{of} \listzero\ term \terminal{end} 
+      \\[1em]
+      name & ::= & \verb!_! \\
+           & $|$ & identifier 
+   \end{tabular}
+  \end{center}
+  \hrulefill
+  \caption{Grammar of terms}
+  \label{fig:terms}
+\end{figure}
+
+\section{Commands}
+The grammar of \minicoq's commands are given in
+Figure~\ref{fig:commands}. All commands end with a dot.
+
+\begin{figure}[htbp]
+  \hrulefill
+  \begin{center}
+    \begin{tabular}{lrl}
+      command & ::= & \terminal{Definition} identifier \terminal{:=} term. \\
+              & $|$ & \terminal{Definition} identifier \terminal{:} term
+                      \terminal{:=} term. \\
+              & $|$ & \terminal{Parameter} identifier \terminal{:} term. \\
+              & $|$ & \terminal{Variable} identifier \terminal{:} term. \\
+              & $|$ & \terminal{Inductive} \terminal{[} \listzero\ param 
+                      \terminal{]} \listun\ inductive \sep\ 
+                      \terminal{with}. \\
+              & $|$ & \terminal{Check} term. 
+      \\[1em]
+      param   & ::= & identifier 
+      \\[1em]
+      inductive & ::= & identifier \terminal{:} term \terminal{:=}
+                        \listzero\ constructor \sep\ \terminal{$|$}
+      \\[1em]
+      constructor & ::= & identifier \terminal{:} term
+    \end{tabular}
+  \end{center}
+  \hrulefill
+  \caption{Commands}
+  \label{fig:commands}
+\end{figure}
+
+
+\end{document}
+
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 
diff --git a/dev/doc/newsyntax.tex b/dev/doc/newsyntax.tex
new file mode 100644
index 00000000..96e61292
--- /dev/null
+++ b/dev/doc/newsyntax.tex
@@ -0,0 +1,725 @@
+
+%% -*-french-tex-*-
+
+\documentclass{article}
+
+\usepackage{verbatim}
+\usepackage[T1]{fontenc}
+\usepackage[latin1]{inputenc}
+\usepackage[french]{babel}
+\usepackage{amsmath}
+\usepackage{amssymb}
+\usepackage{array}
+
+
+\author{B.~Barras}
+\title{Proposition de syntaxe pour Coq}
+
+%% Le _ est un caractère normal
+\catcode`\_=13
+\let\subscr=_
+\def_{\ifmmode\sb\else\subscr\fi}
+
+%% Macros pour les grammaires
+\def\NT#1{\langle\textit{#1}\rangle}
+\def\TERM#1{\textsf{#1}}
+\def\STAR#1{#1\!*}
+\def\PLUS#1{#1\!+}
+
+%% Tableaux de definition de non-terminaux
+\newenvironment{cadre}
+        {\begin{array}{|c|}\hline\\}
+        {\\\\\hline\end{array}}
+\newenvironment{rulebox}
+        {$$\begin{cadre}\begin{array}{r@{~}c@{~}l@{}r}}
+        {\end{array}\end{cadre}$$}
+\def\DEFNT#1{\NT{#1} & ::= &}
+\def\EXTNT#1{\NT{#1} & ::= & ... \\&|&}
+\def\RNAME#1{(\textsc{#1})}
+\def\SEPDEF{\\\\}
+\def\nlsep{\\&|&}
+
+
+\begin{document}
+
+\maketitle
+
+\section{Grammaire des tactiques}
+\label{tacticsyntax}
+
+La réflexion de la rénovation de la syntaxe des tactiques n'est pas
+encore aussi poussée que pour les termes (section~\ref{constrsyntax}),
+mais cette section vise à énoncer les quelques principes que l'on
+souhaite suivre. 
+
+\begin{itemize}
+\item Réutiliser les mots-clés de la syntaxe des termes (i.e. en
+  minuscules) pour les constructions similaires de tactiques (let_in,
+  match, and, etc.). Le connecteur logique \texttt{and} n'étant que
+  rarement utilisé autrement que sous la forme \texttt{$\wedge$} (sauf
+  dans le code ML), on pourrait dégager ce mot-clé.
+\item Les arguments passés aux tactiques sont principalement des
+  termes, on préconise l'utilisation d'un symbole spécial (par exemple
+  l'apostrophe) pour passer une tactique ou une expression
+  (AST). L'idée étant que l'on écrit plus souvent des tactiques
+  prenant des termes en argument que des tacticals.
+\end{itemize}
+
+\begin{figure}
+\begin{rulebox}
+\DEFNT{tactic}
+       \NT{tactic} ~\TERM{\&} ~\NT{tactic}            & \RNAME{then}
+\nlsep \TERM{[} ~\NT{tactic}~\TERM{|}~...
+      ~\TERM{|}~\NT{tactic}~\TERM{]}                  & \RNAME{par}
+\nlsep \NT{ident} ~\STAR{\NT{tactic-arg}}   ~~~       & \RNAME{apply}
+\nlsep \TERM{fun} ~....                               & \RNAME{function}
+\nlsep \NT{simple-tactic}
+\SEPDEF
+\DEFNT{tactic-arg}
+       \NT{constr}
+\nlsep \TERM{'} ~\NT{tactic}
+\SEPDEF
+\DEFNT{simple-tactic}
+       \TERM{Apply} ~\NT{binding-term}
+\nlsep \NT{elim-kw} ~\NT{binding-term}
+\nlsep \NT{elim-kw} ~\NT{binding-term} ~\TERM{using} ~\NT{binding-term}
+\nlsep \TERM{Intros} ~\NT{intro-pattern}
+\SEPDEF
+\DEFNT{elim-kw}
+       \TERM{Elim} ~\mid~ \TERM{Case} ~\mid~ \TERM{Induction}
+       ~\mid~ \TERM{Destruct}
+\end{rulebox}
+\caption{Grammaire des tactiques}
+\label{tactic}
+\end{figure}
+
+
+\subsection{Arguments de tactiques}
+
+La syntaxe actuelle des arguments de tactiques est que l'on parse par
+défaut une expression de tactique, ou bien l'on parse un terme si
+celui-ci est préfixé par \TERM{'} (sauf dans le cas des
+variables). Cela est gênant pour les utilisateurs qui doivent écrire
+des \TERM{'} pour leurs tactiques.
+
+À mon avis, il n'est pas souhaitable pour l'utilisateur de l'obliger à
+marquer une différence entre les tactiques ``primitives'' (en fait
+``système'') et les tactiques définies par Ltac. En effet, on se
+dirige inévitablement vers une situation où il existera des librairies
+de tactiques et il va devenir difficile de savoir facilement s'il faut
+ou non mettre des \TERM{'}.
+
+
+
+\subsection{Bindings}
+
+Dans un premier temps, les ``bindings'' sont toujours considérés comme
+une construction du langage des tactiques, mais il est intéressant de
+prévoir l'extension de ce procédé aux termes, puisqu'il s'agit
+simplement de construire un n{\oe}ud d'application dans lequel on
+donne les arguments par nom ou par position, les autres restant à
+inférer. Le principal point est de trouver comment combiner de manière
+uniforme ce procédé avec les arguments implicites.
+
+Il est toutefois important de réfléchir dès maintenant à une syntaxe
+pour éviter de rechanger encore la syntaxe.
+
+Intégrer la notation \TERM{with} aux termes peut poser des problèmes
+puisque ce mot-clé est utilisé pour le filtrage: comment parser (en
+LL(1)) l'expression:
+\begin{verbatim}
+Cases x with y ...
+\end{verbatim}
+
+Soit on trouve un autre mot-clé, soit on joue avec les niveaus de
+priorité en obligeant a parenthéser le \TERM{with} des ``bindings'':
+\begin{verbatim}
+Cases (x with y) with (C z) => ...
+\end{verbatim}
+ce qui introduit un constructeur moralement équivalent à une
+application situé à une priorité totalement différente (les
+``bindings'' seraient au plus haut niveau alors que l'application est
+à un niveau bas).
+
+
+\begin{figure}
+\begin{rulebox}
+\DEFNT{binding-term}
+       \NT{constr} ~\TERM{with} ~\STAR{\NT{binding}}
+\SEPDEF
+\DEFNT{binding}
+       \NT{constr}
+\end{rulebox}
+\caption{Grammaire des bindings}
+\label{bindings}
+\end{figure}
+
+\subsection{Enregistrements}
+
+Il faudrait aménager la syntaxe des enregistrements dans l'optique
+d'avoir des enregistrements anonymes (termes de première classe), même
+si pour l'instant, on ne dispose que d'enregistrements définis a
+toplevel.
+
+Exemple de syntaxe pour les types d'enregistrements:
+\begin{verbatim}
+{ x1 : A1;
+  x2 : A2(x1);
+  _ : T;   (* Pas de projection disponible *)
+  y;       (* Type infere *)
+  ...      (* ; optionnel pour le dernier champ *)
+}
+\end{verbatim}
+
+Exemple de syntaxe pour le constructeur:
+\begin{verbatim}
+{ x1 = O;
+  x2 : A2(x1) = v1;
+  _ = v2;
+  ...
+}
+\end{verbatim}
+Quant aux dépendences, une convention pourrait être de considérer les
+champs non annotés par le type comme non dépendants.
+
+Plusieurs interrogations:
+\begin{itemize}
+\item l'ordre des champs doit-il être respecté ?
+  sinon, que faire pour les champs sans projection ?
+\item autorise-t-on \texttt{v1} a mentionner \texttt{x1} (comme dans
+  la définition d'un module), ce qui se comporterait comme si on avait
+  écrit \texttt{v1} à la place. Cela pourrait être une autre manière
+  de déclarer les dépendences
+\end{itemize}
+
+La notation pointée pour les projections pose un problème de parsing,
+sauf si l'on a une convention lexicale qui discrimine les noms de
+modules des projections et identificateurs: \texttt{x.y.z} peut être
+compris comme \texttt{(x.y).z} ou texttt{x.(y.z)}.
+
+
+\section{Grammaire des termes}
+\label{constrsyntax}
+
+\subsection{Quelques principes}
+
+\begin{enumerate}
+\item Diminuer le nombre de niveaux de priorité en regroupant les
+  règles qui se ressemblent: infixes, préfixes, lieurs (constructions
+  ouvertes à droite), etc.
+\item Éviter de surcharger la signification d'un symbole (ex:
+  \verb+( )+ comme parenthésage et produit dans la V7).
+\item Faire en sorte que les membres gauches (motifs de Cases, lieurs
+  d'abstraction ou de produits) utilisent une syntaxe compatible avec
+  celle des membres droits (branches de Cases et corps de fonction).
+\end{enumerate}
+
+\subsection{Présentation de la grammaire}
+
+\begin{figure}
+\begin{rulebox}
+\DEFNT{paren-constr}
+       \NT{cast-constr}~\TERM{,}~\NT{paren-constr}     &\RNAME{pair}
+\nlsep \NT{cast-constr}
+\SEPDEF
+\DEFNT{cast-constr}
+       \NT{constr}~\TERM{\!\!:}~\NT{cast-constr}       &\RNAME{cast}
+\nlsep \NT{constr}
+\SEPDEF
+\DEFNT{constr}
+       \NT{appl-constr}~\NT{infix}~\NT{constr}      &\RNAME{infix}
+\nlsep \NT{prefix}~\NT{constr}                      &\RNAME{prefix}
+\nlsep \NT{constr}~\NT{postfix}                     &\RNAME{postfix}
+\nlsep \NT{appl-constr}
+\SEPDEF
+\DEFNT{appl-constr}
+       \NT{appl-constr}~\PLUS{\NT{appl-arg}}           &\RNAME{apply}
+\nlsep \TERM{@}~\NT{global}~\PLUS{\NT{simple-constr}}  &\RNAME{expl-apply}
+\nlsep \NT{simple-constr}
+\SEPDEF
+\DEFNT{appl-arg}
+       \TERM{@}~\NT{int}~\TERM{\!:=}~\NT{simple-constr}  &\RNAME{impl-arg}
+\nlsep \NT{simple-constr}
+\SEPDEF
+\DEFNT{simple-constr}
+       \NT{atomic-constr}
+\nlsep \TERM{(}~\NT{paren-constr}~\TERM{)}
+\nlsep \NT{match-constr}
+\nlsep \NT{fix-constr}
+%% \nlsep \TERM{<\!\!:ast\!\!:<}~\NT{ast}~\TERM{>\!>} &\RNAME{quotation}
+\end{rulebox}
+\caption{Grammaire des termes}
+\label{constr}
+\end{figure}
+
+\begin{figure}
+\begin{rulebox}
+\DEFNT{prefix}
+       \TERM{!}~\PLUS{\NT{binder}}~\TERM{.}~    &\RNAME{prod}
+\nlsep \TERM{fun} ~\PLUS{\NT{binder}} ~\TERM{$\Rightarrow$} &\RNAME{lambda}
+\nlsep \TERM{let}~\NT{ident}~\STAR{\NT{binder}} ~\TERM{=}~\NT{constr}
+        ~\TERM{in}  &\RNAME{let}
+%\nlsep \TERM{let (}~\NT{comma-ident-list}~\TERM{) =}~\NT{constr}
+%        ~\TERM{in}   &~~~\RNAME{let-case}
+\nlsep \TERM{if}~\NT{constr}~\TERM{then}~\NT{constr}~\TERM{else}
+      &\RNAME{if-case}
+\nlsep \TERM{eval}~\NT{red-fun}~\TERM{in}       &\RNAME{eval}
+\SEPDEF
+\DEFNT{infix}
+      \TERM{$\rightarrow$}                     & \RNAME{impl}
+\SEPDEF
+\DEFNT{atomic-constr}
+      \TERM{_}
+\nlsep \TERM{?}\NT{int}
+\nlsep \NT{sort}
+\nlsep \NT{global}
+\SEPDEF
+\DEFNT{binder}
+       \NT{ident}                              &\RNAME{infer}
+\nlsep \TERM{(}~\NT{ident}~\NT{type}~\TERM{)}  &\RNAME{binder}
+\SEPDEF
+\DEFNT{type}
+       \TERM{\!:}~\NT{constr}
+\nlsep \epsilon
+\end{rulebox}
+\caption{Grammaires annexes aux termes}
+\label{gram-annexes}
+\end{figure}
+
+La grammaire des termes (correspondant à l'état \texttt{barestate})
+est décrite figures~\ref{constr} et~\ref{gram-annexes}. On constate
+par rapport aux précédentes versions de Coq d'importants changements
+de priorité, le plus marquant étant celui de l'application qui se
+trouve désormais juste au dessus\footnote{La convention est de
+considérer les opérateurs moins lieurs comme ``au dessus'',
+c'est-à-dire ayant un niveau de priorité plus élévé (comme c'est le
+cas avec le niveau de la grammaire actuelle des termes).} des
+constructions fermées à gauche et à droite.
+
+La grammaire des noms globaux est la suivante:
+\begin{eqnarray*}
+\DEFNT{global}
+      \NT{ident}
+%% \nlsep \TERM{\$}\NT{ident}
+\nlsep \NT{ident}\TERM{.}\NT{global}
+\end{eqnarray*}
+
+Le $\TERM{_}$ dénote les termes à synthétiser. Les métavariables sont
+reconnues au niveau du lexer pour ne pas entrer en conflit avec le
+$\TERM{?}$ de l'existentielle.
+
+Les opérateurs infixes ou préfixes sont tous au même niveau de
+priorité du point de vue de Camlp4. La solution envisagée est de les
+gérer à la manière de Yacc, avec une pile (voir discussions plus
+bas). Ainsi, l'implication est un infixe normal; la quantification
+universelle et le let sont vus comme des opérateurs préfixes avec un
+niveau de priorité plus haut (i.e. moins lieur). Il subsiste des
+problèmes si l'on ne veut pas écrire de parenthèses dans:
+\begin{verbatim}
+ A -> (!x. B -> (let y = C in D))
+\end{verbatim}
+
+La solution proposée est d'analyser le membre droit d'un infixe de
+manière à autoriser les préfixes et les infixes de niveau inférieur,
+et d'exiger le parenthésage que pour les infixes de niveau supérieurs.
+
+En revanche, à l'affichage, certains membres droits seront plus
+lisibles s'ils n'utilisent pas cette astuce:
+\begin{verbatim}
+(fun x => x) = fun x => x
+\end{verbatim}
+
+La proposition est d'autoriser ce type d'écritures au parsing, mais
+l'afficheur écrit de manière standardisée en mettant quelques
+parenthèses superflues: $\TERM{=}$ serait symétrique alors que
+$\rightarrow$ appellerait l'afficheur de priorité élevée pour son
+sous-terme droit.
+
+Les priorités des opérateurs primitifs sont les suivantes (le signe
+$*$ signifie que pour le membre droit les opérateurs préfixes seront
+affichés sans parenthèses quel que soit leur priorité):
+$$
+\begin{array}{c|l}
+$symbole$ & $priorité$ \\
+\hline
+\TERM{!}      & 200\,R* \\
+\TERM{fun}    & 200\,R* \\
+\TERM{let}    & 200\,R* \\
+\TERM{if}     & 200\,R \\
+\TERM{eval}   & 200\,R \\
+\rightarrow   & 90\,R*
+\end{array}
+$$
+
+Il y a deux points d'entrée pour les termes: $\NT{constr}$ et
+$\NT{simple-constr}$. Le premier peut être utilisé lorsqu'il est suivi
+d'un séparateur particulier. Dans le cas où l'on veut une liste de
+termes séparés par un espace, il faut lire des $\NT{simple-constr}$.
+
+
+
+Les constructions $\TERM{fix}$ et $\TERM{cofix}$ (voir aussi
+figure~\ref{gram-fix}) sont fermées par end pour simplifier
+l'analyse. Sinon, une expression de point fixe peut être suivie par un
+\TERM{in} ou un \TERM{and}, ce qui pose les mêmes problèmes que le
+``dangling else'': dans
+\begin{verbatim}
+fix f1 x {x} = fix f2 y {y} = ... and ... in ...
+\end{verbatim}
+il faut définir une stratégie pour associer le \TERM{and} et le
+\TERM{in} au bon point fixe.
+
+Un autre avantage est de faire apparaitre que le \TERM{fix} est un
+constructeur de terme de première classe et pas un lieur:
+\begin{verbatim}
+fix f1 ... and f2 ...
+in f1 end x
+\end{verbatim}
+Les propositions précédentes laissaient \texttt{f1} et \texttt{x}
+accolés, ce qui est source de confusion lorsque l'on fait par exemple
+\texttt{Pattern (f1 x)}.
+
+Les corps de points fixes et co-points fixes sont identiques, bien que
+ces derniers n'aient pas d'information de décroissance. Cela
+fonctionne puisque l'annotation est optionnelle. Cela préfigure des
+cas où l'on arrive à inférer quel est l'argument qui décroit
+structurellement (en particulier dans le cas où il n'y a qu'un seul
+argument).
+
+\begin{figure}
+\begin{rulebox}
+\DEFNT{fix-expr}
+       \TERM{fix}~\NT{fix-decls}    ~\NT{fix-select} ~\TERM{end} &\RNAME{fix}
+\nlsep \TERM{cofix}~\NT{cofix-decls}~\NT{fix-select} ~\TERM{end} &\RNAME{cofix}
+\SEPDEF
+\DEFNT{fix-decls}
+       \NT{fix-decl}~\TERM{and}~\NT{fix-decls}
+\nlsep \NT{fix-decl}
+\SEPDEF
+\DEFNT{fix-decl}
+       \NT{ident}~\PLUS{\NT{binder}}~\NT{type}~\NT{annot}
+       ~\TERM{=}~\NT{constr}
+\SEPDEF
+\DEFNT{annot}
+       \TERM{\{}~\NT{ident}~\TERM{\}}
+\nlsep \epsilon
+\SEPDEF
+\DEFNT{fix-select}
+       \TERM{in}~\NT{ident}
+\nlsep \epsilon
+\end{rulebox}
+\caption{Grammaires annexes des points fixes}
+\label{gram-fix}
+\end{figure}
+
+La construction $\TERM{Case}$ peut-être considérée comme
+obsolète. Quant au $\TERM{Match}$ de la V6, il disparaît purement et
+simplement.
+
+\begin{figure}
+\begin{rulebox}
+\DEFNT{match-expr}
+       \TERM{match}~\NT{case-items}~\NT{case-type}~\TERM{with}~
+       \NT{branches}~\TERM{end}        &\RNAME{match}
+\nlsep \TERM{match}~\NT{case-items}~\TERM{with}~
+       \NT{branches}~\TERM{end}        &\RNAME{infer-match}
+%%\nlsep \TERM{case}~\NT{constr}~\NT{case-predicate}~\TERM{of}~
+%%      \STAR{\NT{constr}}~\TERM{end}   &\RNAME{case}
+\SEPDEF
+\DEFNT{case-items}
+       \NT{case-item} ~\TERM{\&} ~\NT{case-items}
+\nlsep \NT{case-item}
+\SEPDEF
+\DEFNT{case-item}
+       \NT{constr}~\NT{pred-pattern} &\RNAME{dep-case}
+\nlsep \NT{constr}                   &\RNAME{nodep-case}
+\SEPDEF
+\DEFNT{case-type}
+       \TERM{$\Rightarrow$}~\NT{constr}
+\nlsep \epsilon
+\SEPDEF
+\DEFNT{pred-pattern}
+       \TERM{as}~\NT{ident} ~\TERM{\!:}~\NT{constr}
+\SEPDEF
+\DEFNT{branches}
+       \TERM{|} ~\NT{patterns} ~\TERM{$\Rightarrow$}
+        ~\NT{constr} ~\NT{branches}
+\nlsep \epsilon
+\SEPDEF
+\DEFNT{patterns}
+       \NT{pattern} ~\TERM{\&} ~\NT{patterns}
+\nlsep \NT{pattern}
+\SEPDEF
+\DEFNT{pattern} ...
+\end{rulebox}
+\caption{Grammaires annexes du filtrage}
+\label{gram-match}
+\end{figure}
+
+De manière globale, l'introduction de définitions dans les termes se
+fait avec le symbole $=$, et le $\!:=$ est réservé aux définitions au
+niveau vernac. Il y avait un manque de cohérence dans la
+V6, puisque l'on utilisait $=$ pour le $\TERM{let}$ et $\!:=$ pour les
+points fixes et les commandes vernac.
+
+% OBSOLETE: lieurs multiples supprimes
+%On peut remarquer que $\NT{binder}$ est un sous-ensemble de
+%$\NT{simple-constr}$, à l'exception de $\texttt{(a,b\!\!:T)}$: en tant
+%que lieur, {\tt a} et {\tt b} sont tous deux contraints, alors qu'en
+%tant que terme, seul {\tt b} l'est. Cela qui signifie que l'objectif
+%de rendre compatibles les membres gauches et droits est {\it presque}
+%atteint.
+
+\subsection{Infixes}
+
+\subsubsection{Infixes extensibles}
+
+Le problème de savoir si la liste des symboles pouvant apparaître en
+infixe est fixée ou extensible par l'utilisateur reste à voir.
+
+Notons que la solution où les symboles infixes sont des
+identificateurs que l'on peut définir paraît difficilement praticable:
+par exemple $\texttt{Logic.eq}$ n'est pas un opérateur binaire, mais
+ternaire. Il semble plus simple de garder des déclarations infixes qui
+relient un symbole infixe à un terme avec deux ``trous''. Par exemple:
+
+$$\begin{array}{c|l}
+$infixe$ &  $identificateur$ \\
+\hline
+= & \texttt{Logic.eq _ ?1 ?2} \\
+== & \texttt{JohnMajor.eq _ ?1 _ ?2}
+\end{array}$$
+
+La syntaxe d'une déclaration d'infixe serait par exemple:
+\begin{verbatim}
+Infix "=" 50 := Logic.eq _ ?1 ?2;
+\end{verbatim}
+
+
+\subsubsection{Gestion des précédences}
+
+Les infixes peuvent être soit laissé à Camlp4, ou bien (comme ici)
+considérer que tous les opérateurs ont la même précédence et gérer
+soit même la recomposition des termes à l'aide d'une pile (comme
+Yacc).
+
+
+\subsection{Extensions de syntaxe}
+
+\subsubsection{Litéraux numériques}
+
+La proposition est de considerer les litéraux numériques comme de
+simples identificateurs. Comme il en existe une infinité, il faut un
+nouveau mécanisme pour leur associer une définition. Par exemple, en
+ce qui concerne \texttt{Arith}, la définition de $5$ serait
+$\texttt{S}~4$. Pour \texttt{ZArith}, $5$ serait $\texttt{xI}~2$.
+
+Comme les infixes, les constantes numériques peuvent être qualifiées
+pour indiquer dans quels module est le type que l'on veut
+référencer. Par exemple (si on renomme \texttt{Arith} en \texttt{N} et
+\texttt{ZArith} en \texttt{Z}): \verb+N.5+, \verb+Z.5+.
+
+\begin{eqnarray*}
+\EXTNT{global}
+      \NT{int}
+\end{eqnarray*}
+
+\subsubsection{Nouveaux lieurs}
+
+$$
+\begin{array}{rclr}
+\EXTNT{constr}
+       \TERM{ex}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr}  &\RNAME{ex}
+\nlsep \TERM{ex}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr}~\TERM{,}~\NT{constr}
+        &\RNAME{ex2}
+\nlsep \TERM{ext}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr}  &\RNAME{exT}
+\nlsep \TERM{ext}~\PLUS{\NT{binder}}~\TERM{.}~\NT{constr}~\TERM{,}~\NT{constr}
+        &\RNAME{exT2}
+\end{array}
+$$
+
+Pour l'instant l'existentielle n'admet qu'une seule variable, ce qui
+oblige à écrire des cascades de $\TERM{ex}$.
+
+Pour parser les existentielles avec deux prédicats, on peut considérer
+\TERM{\&} comme un infixe intermédiaire et l'opérateur existentiel en
+présence de cet infixe se transforme en \texttt{ex2}.
+
+\subsubsection{Nouveaux infixes}
+
+Précédences des opérateurs infixes (les plus grands associent moins fort):
+$$
+\begin{array}{l|l|c|l}
+$identificateur$      & $module$     & $infixe/préfixe$ & $précédence$ \\
+\hline
+\texttt{iff}          & $Logic$      & \longleftrightarrow & 100 \\
+\texttt{or}           & $Logic$      & \vee     & 80\, R \\
+\texttt{sum}          & $Datatypes$  & +        & 80\, R \\
+\texttt{and}          & $Logic$      & \wedge   & 70\, R \\
+\texttt{prod}         & $Datatypes$  & *        & 70\, R \\
+\texttt{not}          & $Logic$      & \tilde{} & 60\, L \\
+\texttt{eq _}         & $Logic$      & =        & 50 \\
+\texttt{eqT _}        & $Logic_Type$ & =        & 50 \\
+\texttt{identityT _}  & $Data_Type$  & =        & 50 \\
+\texttt{le}           & $Peano$      & $<=$     & 50 \\
+\texttt{lt}           & $Peano$      & $<$      & 50 \\
+\texttt{ge}           & $Peano$      & $>=$     & 50 \\
+\texttt{gt}           & $Peano$      & $>$      & 50 \\
+\texttt{Zle}          & $zarith_aux$   & $<=$   & 50 \\
+\texttt{Zlt}          & $zarith_aux$   & $<$    & 50 \\
+\texttt{Zge}          & $zarith_aux$   & $>=$   & 50 \\
+\texttt{Zgt}          & $zarith_aux$   & $>$    & 50 \\
+\texttt{Rle}          & $Rdefinitions$ & $<=$   & 50 \\
+\texttt{Rlt}          & $Rdefinitions$ & $<$    & 50 \\
+\texttt{Rge}          & $Rdefinitions$ & $>=$   & 50 \\
+\texttt{Rgt}          & $Rdefinitions$ & $>$    & 50 \\
+\texttt{plus}         & $Peano$        & +      & 40\,L \\
+\texttt{Zplus}        & $fast_integer$ & +      & 40\,L \\
+\texttt{Rplus}        & $Rdefinitions$ & +      & 40\,L \\
+\texttt{minus}        & $Minus$        & -      & 40\,L \\
+\texttt{Zminus}       & $zarith_aux$   & -      & 40\,L \\
+\texttt{Rminus}       & $Rdefinitions$ & -      & 40\,L \\
+\texttt{Zopp}         & $fast_integer$ & -      & 40\,L \\
+\texttt{Ropp}         & $Rdefinitions$ & -      & 40\,L \\
+\texttt{mult}         & $Peano$        & *      & 30\,L \\
+\texttt{Zmult}        & $fast_integer$ & *      & 30\,L \\
+\texttt{Rmult}        & $Rdefinitions$ & *      & 30\,L \\
+\texttt{Rdiv}         & $Rdefinitions$ & /      & 30\,L \\
+\texttt{pow}          & $Rfunctions$   & \hat   & 20\,L \\
+\texttt{fact}         & $Rfunctions$   & !      & 20\,L \\
+\end{array}
+$$
+
+Notons qu'il faudrait découper {\tt Logic_Type} en deux car celui-ci
+définit deux égalités, ou alors les mettre dans des modules différents.
+
+\subsection{Exemples}
+
+\begin{verbatim}
+Definition not (A:Prop) := A->False;
+Inductive eq (A:Set) (x:A) : A->Prop :=
+    refl_equal : eq A x x;
+Inductive ex (A:Set) (P:A->Prop) : Prop :=
+    ex_intro : !x. P x -> ex A P;
+Lemma not_all_ex_not : !(P:U->Prop). ~(!n. P n) -> ?n. ~ P n;
+Fixpoint plus n m : nat {struct n} :=
+  match n with
+    O     => m
+  | (S k) => S (plus k m)
+  end;
+\end{verbatim}
+
+\subsection{Questions ouvertes}
+
+Voici les points sur lesquels la discussion est particulièrement
+ouverte: 
+\begin{itemize}
+\item choix d'autres symboles pour les quantificateurs \TERM{!} et
+  \TERM{?}. En l'état actuel des discussions, on garderait le \TERM{!}
+  pour la qunatification universelle, mais on choisirait quelquechose
+  comme \TERM{ex} pour l'existentielle, afin de ne pas suggérer trop
+  de symétrie entre ces quantificateurs (l'un est primitif, l'autre
+  pas).
+\item syntaxe particulière pour les \texttt{sig}, \texttt{sumor}, etc.
+\item la possibilité d'introduire plusieurs variables du même type est
+  pour l'instant supprimée au vu des problèmes de compatibilité de
+  syntaxe entre les membres gauches et membres droits. L'idée étant
+  que l'inference de type permet d'éviter le besoin de déclarer tous
+  les types.
+\end{itemize}
+
+\subsection{Autres extensions}
+
+\subsubsection{Lieur multiple}
+
+L'écriture de types en présence de polymorphisme est souvent assez
+pénible:
+\begin{verbatim}
+Check !(A:Set) (x:A) (B:Set) (y:B). P A x B y;
+\end{verbatim}
+
+On pourrait avoir des déclarations introduisant à la fois un type
+d'une certaine sorte et une variable de ce type:
+\begin{verbatim}
+Check !(x:A:Set) (y:B:Set). P A x B y;
+\end{verbatim}
+
+Noter que l'on aurait pu écrire:
+\begin{verbatim}
+Check !A x B y. P A (x:A:Set) B (y:B:Set);
+\end{verbatim}
+
+\section{Syntaxe des tactiques}
+
+\subsection{Questions diverses}
+
+Changer ``Pattern nl c ... nl c'' en ``Pattern [ nl ] c ... [ nl ] c''
+pour permettre des chiffres seuls dans la catégorie syntaxique des
+termes.
+
+Par uniformité remplacer ``Unfold nl c'' par ``Unfold [ nl ] c'' ?
+
+Même problème pour l'entier de Specialize (ou virer Specialize ?) ?
+
+\subsection{Questions en suspens}
+
+\verb=EAuto= : deux syntaxes différentes pour la recherche en largeur
+et en profondeur ? Quelle recherche par défaut ?
+
+\section*{Remarques pêle-mêle (HH)}
+
+Autoriser la syntaxe
+
+\begin{verbatim}
+Variable R (a : A) (b : B) : Prop.
+Hypotheses H (a : A) (b : B) : Prop; Y (u : U) : V.
+Variables H (a : A) (b : B), J (k : K) : nat; Z (v : V) : Set.
+\end{verbatim}
+
+Renommer eqT, refl_eqT, eqT_ind, eqT_rect, eqT_rec en eq, refl_equal, etc.
+Remplacer == en =.
+
+Mettre des \verb=?x= plutot que des \verb=?1= dans les motifs de ltac ??
+
+\section{Moulinette}
+
+\begin{itemize}
+
+\item Mettre \verb=/= et * au même niveau dans R.
+
+\item Changer la précédence du - unaire dans R.
+
+\item Ajouter Require Arith par necessite si Require ArithRing ou Require ZArithRing.
+
+\item Ajouter Require ZArith par necessite si Require ZArithRing ou Require Omega.
+
+\item Enlever le Export de Bool, Arith et ZARith de Ring quand inapproprié et
+l'ajouter à côté des Require Ring.
+
+\item Remplacer "Check n" par "n:Check ..."
+
+\item Renommer Variable/Hypothesis hors section en Parameter/Axiom.
+
+\item Renommer les \verb=command0=, \verb=command1=, ... \verb=lcommand= etc en
+\verb=constr0=, \verb=constr1=, ... \verb=lconstr=.
+
+\item Remplacer les noms Coq.omega.Omega par Coq.Omega ...
+
+\item Remplacer AddPath par Add LoadPath (ou + court)
+
+\item Unify + and \{\}+\{\} and +\{\} using Prop $\leq$ Set ??
+
+\item Remplacer Implicit Arguments On/Off par Set/Unset Implicit Arguments.
+
+\item La syntaxe \verb=Intros (a,b)= est inutile, \verb=Intros [a b]= fait l'affaire.
+
+\item Virer \verb=Goal= sans argument (synonyme de \verb=Proof= et sans effets).
+
+\item Remplacer Save. par Qed.
+
+\item Remplacer \verb=Zmult_Zplus_distr= par \verb=Zmult_plus_distr_r=
+et \verb=Zmult_plus_distr= par \verb=Zmult_plus_distr_l=.
+
+\end{itemize}
+
+\end{document}
diff --git a/dev/doc/perf-analysis b/dev/doc/perf-analysis
new file mode 100644
index 00000000..f4cb3bff
--- /dev/null
+++ b/dev/doc/perf-analysis
@@ -0,0 +1,68 @@
+Performance analysis for V8-0 branch
+------------------------------------
+
+Oct 29, 2006: polymorphism on definitions (+ 4%)
+
+Oct 17, 2006: improvement in new field [r9248]
+  (QArith -3%, geometry: -2%)
+
+Oct 5, 2006: fixing wrong unification of Meta below binders
+  (e.g. CatsInZFC: +10%, CoRN: -2.5%, Godel: +4%, 
+   DISTRIBUTED_REFERENCE_COUNTING: +10%, CoLoR: +1%)
+
+Sep 26, 2006: new field [r9178-9181]
+  (QArith: -16%, geometry: -5%, Float: +6%, BDDS:+5% but no ring in it)
+
+  Sep 12, 2006: Rocq/AREA_METHOD extended (~ 530s)
+  Aug 12, 2006: Rocq/AREA_METHOD added (~ 480s)
+  May 30, 2006: Nancy/CoLoR added (~ 319s)
+
+May 17, 2006: changes in List.v (DISTRIBUTED_REFERENCE_COUNTING: -)
+
+May 5, 2006: improvement in closure (array instead of lists)
+  (e.g. CatsInZFC: -10%, CoRN: -3%, 
+
+  Dec 29, 2005: new test and use of -vm in Stalmarck
+
+  Dec 27, 2005: contrib Karatsuba added (~ 30s)
+
+Dec 28, 2005: size decrease
+  mainly due to Defined moved to Qed in FSets (reduction from 95M to 7Mo)
+
+Dec 1-14, 2005: benchmarking server down
+  between the two dates: Godel: -10%, CoRN: -10%
+  probably due to changes around vm (new informative Cast,
+  change of equality in named_context_val) 
+
+  Oct 6, 2005: contribs IPC and Tait added (~ 22s and ~ 25s)
+
+Aug 19, 2005: time decrease after application of "Array.length x=0" Xavier's 
+  suggestions for optimisation
+  (e.g. Nijmegen/QArith: -3%, Nijmegen/CoRN: -7%, Godel: -3%)
+ 
+  Aug 1, 2005: contrib Kildall added (~ 65s)
+
+Jul 26-Aug 2, 2005: bench down
+
+Jul 14-15, 2005: 4 contribs failed including CoRN
+
+Jul 14, 2005: time increase after activation of "closure optimisation"
+  (e.g. Nijmegen/QArith: +8%, Nijmegen/CoRN: +3%, Godel: +13%)
+
+  Jul 7, 2005: adding contrib Fermat4
+
+  Jun 17, 2005: contrib Goodstein extended and moved to CantorOrdinals (~ 30s)
+
+  May 19, 2005: contrib Goodstein and prfx (~ 9s) added 
+
+Apr 21, 2005: strange time decrease
+  (could it be due to the change of Back and Reset mechanism) 
+  (e.g. Nijmegen/CoRN: -2%, Nijmegen/QARITH: -4%, Godel: -11%)
+
+Mar 20, 2005: fixed Logic.with_check bug
+  global time decrease (e.g. Nijmegen/CoRN: -3%, Nijmegen/QARITH: -1.5%)
+
+Jan 31-Feb 8, 2005: small instability
+  (e.g. CoRN: ~2015s -> ~1999s -> ~2032s, Godel: ~340s -> ~370s)
+
+  Jan 13, 2005: contrib SumOfTwoSquare added (~ 38s)
diff --git a/dev/style.txt b/dev/doc/style.txt
index 2e597dc4..2e597dc4 100644
--- a/dev/style.txt
+++ b/dev/doc/style.txt
diff --git a/dev/translate.txt b/dev/doc/translate.txt
index 5b372c96..5b372c96 100644
--- a/dev/translate.txt
+++ b/dev/doc/translate.txt
diff --git a/dev/universes.txt b/dev/doc/universes.txt
index 65c1e522..65c1e522 100644
--- a/dev/universes.txt
+++ b/dev/doc/universes.txt
diff --git a/dev/include b/dev/include
index eb370a5d..42d2a017 100644
--- a/dev/include
+++ b/dev/include
@@ -4,32 +4,28 @@
 #cd ".";;
 #use "base_include";;
 
-#install_printer  (* ast *)  prast;;
-#install_printer  (* pat *)  prastpat;;
-#install_printer  (* patlist *)  prastpatl;;
-
 #install_printer  (* pattern *) pppattern;;
-#install_printer  (* rawconstr *) pprawterm;;
+#install_printer  (* rawconstr *) pprawconstr;;
 
-#install_printer  (* constr *) ppterm;;
-#install_printer  (* constr_substituted *) ppsterm;; 
-#install_printer  (* universe *)  print_uni;;
-#install_printer  (* universes *)  pp_universes;;
-#install_printer  (* type_judgement*) pptype;;
-#install_printer  (* judgement*) prj;;
+#install_printer  (* constr *) ppconstr;;
+#install_printer  (* constr_substituted *) ppsconstr;; 
+#install_printer  (* universe *)  ppuni;;
+#install_printer  (* universes *)  ppuniverses;;
+#install_printer  (* type_judgement *) pptype;;
+#install_printer  (* judgement *) ppj;;
 
-#install_printer  (* goal *)  prgoal;;
-#install_printer  (* sigma goal *)  prsigmagoal;;
+#install_printer  (* goal *)  ppgoal;;
+#install_printer  (* sigma goal *)  ppsigmagoal;;
 #install_printer  (* proof *)  pproof;;
-#install_printer  (* global_constraints *)  prevd;;
-#install_printer  (* readable_constraints *)  prevc;;
-#install_printer  (* walking_constraints *)  prwc;;
-#install_printer  (* clenv *) prclenv;;
+#install_printer  (* evar_map *)  ppevm;;
+#install_printer  (* evar_defs *)  ppevd;;
+#install_printer  (* clenv *) ppclenv;;
 #install_printer  (* env *) ppenv;;
 
 #install_printer  (* tactic *) pptac;;
-#install_printer  (* object *) pr_obj;;
-#install_printer  (* global_reference *) prglobal;;
+#install_printer  (* object *) ppobj;;
+#install_printer  (* global_reference *) ppglobal;;
+#install_printer  (* generic_argument *) pp_generic_argument;;
 
 #install_printer  (* fconstr *) ppfconstr;;
 
diff --git a/dev/ocamldebug-v7.template b/dev/ocamldebug-coq.template
index 1dd625c8..44680d6d 100644
--- a/dev/ocamldebug-v7.template
+++ b/dev/ocamldebug-coq.template
@@ -2,27 +2,14 @@
 
 # wrap around ocamldebug for Coq
 
-export COQTOP='COQTOPDIRECTORY'
-export COQLIB='COQLIBDIRECTORY'
+export COQTOP=COQTOPDIRECTORY
+export COQLIB=COQLIBDIRECTORY
 export COQTH=$COQLIB/theories
-CAMLBIN='CAMLBINDIRECTORY'
+CAMLBIN=CAMLBINDIRECTORY
 OCAMLDEBUG=$CAMLBIN/ocamldebug
 export CAMLP4LIB=`$CAMLBIN/camlp4 -where`
 
-args=""
-coqdebug="no"
-for op in $*
-    do case `basename $op` in
-	coq-debug-programs.out) 
-	    coqdebug="yes"
-	    args="-is programs.coq";;
-	*coq*) coqdebug="yes";;
-       esac
-done
-
-case $coqdebug in
-    yes)
-	exec $OCAMLDEBUG \
+exec $OCAMLDEBUG \
 	-I $CAMLP4LIB \
 	-I $COQTOP/config \
 	-I $COQTOP/lib -I $COQTOP/kernel \
@@ -30,12 +17,12 @@ case $coqdebug in
         -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics \
 	-I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \
 	-I $COQTOP/translate \
-        -I $COQTOP/contrib/correctness \
         -I $COQTOP/contrib/extraction -I $COQTOP/contrib/field \
-        -I $COQTOP/contrib/fourier    -I $COQTOP/contrib/graphs \
+        -I $COQTOP/contrib/fourier    -I $COQTOP/contrib/first-order \
         -I $COQTOP/contrib/interface  -I $COQTOP/contrib/jprover \
         -I $COQTOP/contrib/omega      -I $COQTOP/contrib/romega \
         -I $COQTOP/contrib/ring       -I $COQTOP/contrib/xml \
-	$* $args;;
-    *) exec $OCAMLDEBUG $*;;
-esac
+	-I $COQTOP/contrib/subtac     -I $COQTOP/contrib/funind \
+        -I $COQTOP/contrib/rtauto     -I $COQTOP/contrib/setoid_ring \
+        -I $COQTOP/contrib/recdef     -I $COQTOP/contrib/dp \
+	$*
diff --git a/dev/ocamlweb-doc/Makefile b/dev/ocamlweb-doc/Makefile
new file mode 100644
index 00000000..96491017
--- /dev/null
+++ b/dev/ocamlweb-doc/Makefile
@@ -0,0 +1,75 @@
+
+# Makefile for doc/
+
+all:: newparse coq.ps minicop.ps
+#newsyntax.dvi minicoq.dvi
+
+
+OBJS=lex.cmo ast.cmo parse.cmo syntax.cmo
+
+newparse: $(OBJS) syntax.mli lex.ml syntax.ml
+	ocamlc -o newparse $(OBJS)
+
+%.cmo: %.ml
+	ocamlc -c $<
+
+%.cmi: %.mli
+	ocamlc -c $<
+
+%.ml: %.mll
+	ocamllex $<
+
+%.ml: %.mly
+	ocamlyacc -v $<
+
+%.mli: %.mly
+	ocamlyacc -v $<
+
+clean::
+	rm -f *.cm* *.output syntax.ml syntax.mli lex.ml newparse
+
+parse.cmo: ast.cmo
+syntax.cmi: parse.cmo
+syntax.cmo: lex.cmo parse.cmo syntax.cmi
+lex.cmo: syntax.cmi
+ast.cmo: ast.ml
+
+newsyntax.dvi: newsyntax.tex
+	latex $<
+	latex $<
+
+coq.dvi: coq.tex
+	latex coq
+	latex coq
+
+coq.tex::
+	ocamlweb -p "\usepackage{epsfig}" \
+	macros.tex intro.tex \
+	../../lib/{doc.tex,*.mli} ../../kernel/{doc.tex,*.mli} ../../library/{doc.tex,*.mli} \
+	../../pretyping/{doc.tex,*.mli} ../../interp/{doc.tex,*.mli} \
+	../../parsing/{doc.tex,*.mli} ../../proofs/{doc.tex,*.mli} \
+	../../tactics/{doc.tex,*.mli} ../../toplevel/{doc.tex,*.mli} \
+	-o coq.tex
+
+
+depend:: kernel.dep.ps library.dep.ps pretyping.dep.ps parsing.dep.ps \
+         proofs.dep.ps tactics.dep.ps toplevel.dep.ps interp.dep.ps
+
+%.dot: ../%
+	(cd ../$*; ocamldep *.ml *.mli) | ocamldot -lr > $@
+
+%.dep.ps: %.dot
+	dot -Tps $< -o $@
+
+clean::
+	rm -f *~ *.log *.aux
+
+.SUFFIXES: .tex .dvi .ps .cmo .cmi .mli .ml .mll .mly
+
+%.dvi: %.tex
+	latex $< && latex $<
+
+%.ps: %.dvi
+	dvips $< -o $@
+
+
diff --git a/dev/ocamlweb-doc/ast.ml b/dev/ocamlweb-doc/ast.ml
new file mode 100644
index 00000000..2153ef47
--- /dev/null
+++ b/dev/ocamlweb-doc/ast.ml
@@ -0,0 +1,47 @@
+
+type constr_ast =
+  Pair of constr_ast * constr_ast
+| Prod of binder list * constr_ast
+| Lambda of binder list * constr_ast
+| Let of string * constr_ast * constr_ast
+| LetCase of binder list * constr_ast * constr_ast
+| IfCase of constr_ast * constr_ast * constr_ast
+| Eval of red_fun * constr_ast
+| Infix of string * constr_ast * constr_ast
+| Prefix of string * constr_ast
+| Postfix of string * constr_ast
+| Appl of constr_ast * constr_arg list
+| ApplExpl of string list * constr_ast list
+| Scope of string * constr_ast
+| Qualid of string list
+| Prop | Set | Type
+| Int of string
+| Hole
+| Meta of string
+| Fixp of fix_kind *
+      (string * binder list * constr_ast * string option * constr_ast) list *
+      string
+| Match of case_item list * constr_ast option *
+           (pattern list * constr_ast) list 
+
+and red_fun = Simpl
+
+and binder = string * constr_ast
+
+and constr_arg = string option * constr_ast
+
+and fix_kind = Fix | CoFix
+
+and case_item = constr_ast * (string option * constr_ast option)
+
+and pattern = 
+  PatAs of pattern * string
+| PatType of pattern * constr_ast
+| PatConstr of string * pattern list
+| PatVar of string
+
+let mk_cast c t =
+  if t=Hole then c else Infix(":",c,t)
+
+let mk_lambda bl t =
+  if bl=[] then t else Lambda(bl,t)
diff --git a/dev/ocamlweb-doc/interp.dep.ps b/dev/ocamlweb-doc/interp.dep.ps
new file mode 100644
index 00000000..b0554481
--- /dev/null
+++ b/dev/ocamlweb-doc/interp.dep.ps
@@ -0,0 +1,583 @@
+%!PS-Adobe-2.0
+%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
+%%For: (herbelin) Hugo Herbelin
+%%Title: G
+%%Pages: (atend)
+%%BoundingBox: 35 35 577 160
+%%EndComments
+save
+%%BeginProlog
+/DotDict 200 dict def
+DotDict begin
+
+/setupLatin1 {
+mark
+/EncodingVector 256 array def
+ EncodingVector 0
+
+ISOLatin1Encoding 0 255 getinterval putinterval
+
+EncodingVector
+  dup 306 /AE
+  dup 301 /Aacute
+  dup 302 /Acircumflex
+  dup 304 /Adieresis
+  dup 300 /Agrave
+  dup 305 /Aring
+  dup 303 /Atilde
+  dup 307 /Ccedilla
+  dup 311 /Eacute
+  dup 312 /Ecircumflex
+  dup 313 /Edieresis
+  dup 310 /Egrave
+  dup 315 /Iacute
+  dup 316 /Icircumflex
+  dup 317 /Idieresis
+  dup 314 /Igrave
+  dup 334 /Udieresis
+  dup 335 /Yacute
+  dup 376 /thorn
+  dup 337 /germandbls
+  dup 341 /aacute
+  dup 342 /acircumflex
+  dup 344 /adieresis
+  dup 346 /ae
+  dup 340 /agrave
+  dup 345 /aring
+  dup 347 /ccedilla
+  dup 351 /eacute
+  dup 352 /ecircumflex
+  dup 353 /edieresis
+  dup 350 /egrave
+  dup 355 /iacute
+  dup 356 /icircumflex
+  dup 357 /idieresis
+  dup 354 /igrave
+  dup 360 /dcroat
+  dup 361 /ntilde
+  dup 363 /oacute
+  dup 364 /ocircumflex
+  dup 366 /odieresis
+  dup 362 /ograve
+  dup 365 /otilde
+  dup 370 /oslash
+  dup 372 /uacute
+  dup 373 /ucircumflex
+  dup 374 /udieresis
+  dup 371 /ugrave
+  dup 375 /yacute
+  dup 377 /ydieresis  
+
+% Set up ISO Latin 1 character encoding
+/starnetISO {
+        dup dup findfont dup length dict begin
+        { 1 index /FID ne { def }{ pop pop } ifelse
+        } forall
+        /Encoding EncodingVector def
+        currentdict end definefont
+} def
+/Times-Roman starnetISO def
+/Times-Italic starnetISO def
+/Times-Bold starnetISO def
+/Times-BoldItalic starnetISO def
+/Helvetica starnetISO def
+/Helvetica-Oblique starnetISO def
+/Helvetica-Bold starnetISO def
+/Helvetica-BoldOblique starnetISO def
+/Courier starnetISO def
+/Courier-Oblique starnetISO def
+/Courier-Bold starnetISO def
+/Courier-BoldOblique starnetISO def
+cleartomark
+} bind def
+
+%%BeginResource: procset graphviz 0 0
+/coord-font-family /Times-Roman def
+/default-font-family /Times-Roman def
+/coordfont coord-font-family findfont 8 scalefont def
+
+/InvScaleFactor 1.0 def
+/set_scale {
+	dup 1 exch div /InvScaleFactor exch def
+	dup scale
+} bind def
+
+% styles
+/solid { [] 0 setdash } bind def
+/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
+/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
+/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
+/bold { 2 setlinewidth } bind def
+/filled { } bind def
+/unfilled { } bind def
+/rounded { } bind def
+/diagonals { } bind def
+
+% hooks for setting color 
+/nodecolor { sethsbcolor } bind def
+/edgecolor { sethsbcolor } bind def
+/graphcolor { sethsbcolor } bind def
+/nopcolor {pop pop pop} bind def
+
+/beginpage {	% i j npages
+	/npages exch def
+	/j exch def
+	/i exch def
+	/str 10 string def
+	npages 1 gt {
+		gsave
+			coordfont setfont
+			0 0 moveto
+			(\() show i str cvs show (,) show j str cvs show (\)) show
+		grestore
+	} if
+} bind def
+
+/set_font {
+	findfont exch
+	scalefont setfont
+} def
+
+% draw aligned label in bounding box aligned to current point
+/alignedtext {			% width adj text
+	/text exch def
+	/adj exch def
+	/width exch def
+	gsave
+		width 0 gt {
+			text stringwidth pop adj mul 0 rmoveto
+		} if
+		[] 0 setdash
+		text show
+	grestore
+} def
+
+/boxprim {				% xcorner ycorner xsize ysize
+		4 2 roll
+		moveto
+		2 copy
+		exch 0 rlineto
+		0 exch rlineto
+		pop neg 0 rlineto
+		closepath
+} bind def
+
+/ellipse_path {
+	/ry exch def
+	/rx exch def
+	/y exch def
+	/x exch def
+	matrix currentmatrix
+	newpath
+	x y translate
+	rx ry scale
+	0 0 1 0 360 arc
+	setmatrix
+} bind def
+
+/endpage { showpage } bind def
+/showpage { } def
+
+/layercolorseq
+	[	% layer color sequence - darkest to lightest
+		[0 0 0]
+		[.2 .8 .8]
+		[.4 .8 .8]
+		[.6 .8 .8]
+		[.8 .8 .8]
+	]
+def
+
+/layerlen layercolorseq length def
+
+/setlayer {/maxlayer exch def /curlayer exch def
+	layercolorseq curlayer 1 sub layerlen mod get
+	aload pop sethsbcolor
+	/nodecolor {nopcolor} def
+	/edgecolor {nopcolor} def
+	/graphcolor {nopcolor} def
+} bind def
+
+/onlayer { curlayer ne {invis} if } def
+
+/onlayers {
+	/myupper exch def
+	/mylower exch def
+	curlayer mylower lt
+	curlayer myupper gt
+	or
+	{invis} if
+} def
+
+/curlayer 0 def
+
+%%EndResource
+%%EndProlog
+%%BeginSetup
+14 default-font-family set_font
+1 setmiterlimit
+% /arrowlength 10 def
+% /arrowwidth 5 def
+
+% make sure pdfmark is harmless for PS-interpreters other than Distiller
+/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
+% make '<<' and '>>' safe on PS Level 1 devices
+/languagelevel where {pop languagelevel}{1} ifelse
+2 lt {
+    userdict (<<) cvn ([) cvn load put
+    userdict (>>) cvn ([) cvn load put
+} if
+
+%%EndSetup
+%%Page: 1 1
+%%PageBoundingBox: 36 36 577 160
+%%PageOrientation: Portrait
+gsave
+35 35 542 125 boxprim clip newpath
+36 36 translate
+0 0 1 beginpage
+0.9343 set_scale
+0 0 translate 0 rotate
+0.000 0.000 0.000 graphcolor
+14.00 /Times-Roman set_font
+
+%	Syntax_def
+gsave 10 dict begin
+303 110 45 18 ellipse_path
+stroke
+gsave 10 dict begin
+271 105 moveto
+(Syntax_def)
+[7.68 6.96 6.96 4.08 6.24 6.96 6.96 6.96 6.24 4.56]
+xshow
+end grestore
+end grestore
+
+%	Notation
+gsave 10 dict begin
+422 60 38 18 ellipse_path
+stroke
+gsave 10 dict begin
+397 55 moveto
+(Notation)
+[9.84 6.72 4.08 6.24 3.84 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Syntax_def -> Notation
+newpath 334 97 moveto
+350 90 369 83 385 76 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 386 79 moveto
+394 72 lineto
+383 73 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 386 79 moveto
+394 72 lineto
+383 73 lineto
+closepath
+stroke
+end grestore
+
+%	Ppextend
+gsave 10 dict begin
+537 60 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+511 55 moveto
+(Ppextend)
+[7.68 6.96 5.76 6.96 3.84 6.24 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Notation -> Ppextend
+newpath 460 60 moveto
+469 60 478 60 488 60 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 488 64 moveto
+498 60 lineto
+488 57 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 488 64 moveto
+498 60 lineto
+488 57 lineto
+closepath
+stroke
+end grestore
+
+%	Topconstr
+gsave 10 dict begin
+537 114 41 18 ellipse_path
+stroke
+gsave 10 dict begin
+509 109 moveto
+(Topconstr)
+[7.2 6.96 6.96 6.24 6.96 6.96 5.28 3.84 4.56]
+xshow
+end grestore
+end grestore
+
+%	Notation -> Topconstr
+newpath 449 73 moveto
+464 80 483 89 500 97 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 498 100 moveto
+509 101 lineto
+501 94 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 498 100 moveto
+509 101 lineto
+501 94 lineto
+closepath
+stroke
+end grestore
+
+%	Modintern
+gsave 10 dict begin
+44 98 43 18 ellipse_path
+stroke
+gsave 10 dict begin
+13 93 moveto
+(Modintern)
+[12.48 6.96 6.96 3.84 6.96 3.84 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	Constrintern
+gsave 10 dict begin
+173 98 48 18 ellipse_path
+stroke
+gsave 10 dict begin
+138 93 moveto
+(Constrintern)
+[9.36 6.96 6.96 5.28 3.84 4.8 3.84 6.96 3.84 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	Modintern -> Constrintern
+newpath 88 98 moveto
+97 98 106 98 115 98 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 115 102 moveto
+125 98 lineto
+115 95 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 115 102 moveto
+125 98 lineto
+115 95 lineto
+closepath
+stroke
+end grestore
+
+%	Constrintern -> Syntax_def
+newpath 220 102 moveto
+229 103 239 104 249 105 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 249 108 moveto
+259 106 lineto
+249 102 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 249 108 moveto
+259 106 lineto
+249 102 lineto
+closepath
+stroke
+end grestore
+
+%	Reserve
+gsave 10 dict begin
+303 56 35 18 ellipse_path
+stroke
+gsave 10 dict begin
+280 51 moveto
+(Reserve)
+[9.12 6.24 5.52 6.24 4.8 6.48 6.24]
+xshow
+end grestore
+end grestore
+
+%	Constrintern -> Reserve
+newpath 210 86 moveto
+227 81 246 75 263 69 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 264 72 moveto
+273 66 lineto
+262 66 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 264 72 moveto
+273 66 lineto
+262 66 lineto
+closepath
+stroke
+end grestore
+
+%	Genarg
+gsave 10 dict begin
+422 114 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+401 109 moveto
+(Genarg)
+[10.08 6.24 6.96 6.24 4.32 6.96]
+xshow
+end grestore
+end grestore
+
+%	Genarg -> Topconstr
+newpath 456 114 moveto
+465 114 476 114 486 114 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 486 118 moveto
+496 114 lineto
+486 111 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 486 118 moveto
+496 114 lineto
+486 111 lineto
+closepath
+stroke
+end grestore
+
+%	Coqlib
+gsave 10 dict begin
+44 21 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+24 16 moveto
+(Coqlib)
+[9.36 6.96 6.96 3.84 3.84 6.96]
+xshow
+end grestore
+end grestore
+
+%	Constrextern
+gsave 10 dict begin
+173 21 49 18 ellipse_path
+stroke
+gsave 10 dict begin
+137 16 moveto
+(Constrextern)
+[9.36 6.96 6.96 5.28 3.84 4.56 5.76 6.96 3.84 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	Coqlib -> Constrextern
+newpath 77 21 moveto
+88 21 101 21 114 21 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 114 25 moveto
+124 21 lineto
+114 18 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 114 25 moveto
+124 21 lineto
+114 18 lineto
+closepath
+stroke
+end grestore
+
+%	Constrextern -> Notation
+newpath 222 19 moveto
+257 18 307 20 348 29 curveto
+361 31 375 37 388 42 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 386 45 moveto
+397 46 lineto
+389 39 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 386 45 moveto
+397 46 lineto
+389 39 lineto
+closepath
+stroke
+end grestore
+
+%	Constrextern -> Reserve
+newpath 213 32 moveto
+228 36 246 41 261 45 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 260 48 moveto
+271 48 lineto
+262 42 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 260 48 moveto
+271 48 lineto
+262 42 lineto
+closepath
+stroke
+end grestore
+endpage
+showpage
+grestore
+%%PageTrailer
+%%EndPage: 1
+%%Trailer
+%%Pages: 1
+end
+restore
+%%EOF
diff --git a/dev/ocamlweb-doc/intro.tex b/dev/ocamlweb-doc/intro.tex
new file mode 100644
index 00000000..4cec8673
--- /dev/null
+++ b/dev/ocamlweb-doc/intro.tex
@@ -0,0 +1,25 @@
+
+\ocwsection This is \Coq, a proof assistant for the \CCI.
+This document describes the implementation of \Coq.
+It has been automatically generated from the source of
+\Coq\ using \textsf{ocamlweb}, a literate programming tool for
+\textsf{Objective Caml}\footnote{\Coq, \textsf{Objective Caml} and
+  \textsf{ocamlweb} are all freely available at
+  \textsf{http://coq.inria.fr/}, \textsf{http://caml.inria.fr/} and
+  \textsf{http://www.lri.fr/\~{}filliatr/ocamlweb}.}.
+The source files are organized in several directories, which are
+described here as separate chapters.
+
+\begin{center}
+  \begin{tabular}{p{10cm}rr}
+    Chapter & section & page \\[0.5em]
+    \hline\\[0.2em]
+    Utility libraries \dotfill & \refsec{lib}     & \pageref{lib}     \\[0.5em]
+    Kernel            \dotfill & \refsec{kernel}  & \pageref{kernel}  \\[0.5em]
+    Library           \dotfill & \refsec{library} & \pageref{library} \\[0.5em]
+    Pretyping     \dotfill & \refsec{pretyping} & \pageref{pretyping} \\[0.5em]
+    Proof engine      \dotfill & \refsec{proofs}  & \pageref{proofs}  \\[0.5em]
+    Tactics           \dotfill & \refsec{tactics} & \pageref{tactics} \\[0.5em]
+    Toplevel          \dotfill & \refsec{toplevel}& \pageref{toplevel}\\[0.5em]
+  \end{tabular}
+\end{center}
\ No newline at end of file
diff --git a/dev/ocamlweb-doc/kernel.dep.ps b/dev/ocamlweb-doc/kernel.dep.ps
new file mode 100644
index 00000000..3c00121e
--- /dev/null
+++ b/dev/ocamlweb-doc/kernel.dep.ps
@@ -0,0 +1,1454 @@
+%!PS-Adobe-2.0
+%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
+%%For: (herbelin) Hugo Herbelin
+%%Title: G
+%%Pages: (atend)
+%%BoundingBox: 35 35 577 127
+%%EndComments
+save
+%%BeginProlog
+/DotDict 200 dict def
+DotDict begin
+
+/setupLatin1 {
+mark
+/EncodingVector 256 array def
+ EncodingVector 0
+
+ISOLatin1Encoding 0 255 getinterval putinterval
+
+EncodingVector
+  dup 306 /AE
+  dup 301 /Aacute
+  dup 302 /Acircumflex
+  dup 304 /Adieresis
+  dup 300 /Agrave
+  dup 305 /Aring
+  dup 303 /Atilde
+  dup 307 /Ccedilla
+  dup 311 /Eacute
+  dup 312 /Ecircumflex
+  dup 313 /Edieresis
+  dup 310 /Egrave
+  dup 315 /Iacute
+  dup 316 /Icircumflex
+  dup 317 /Idieresis
+  dup 314 /Igrave
+  dup 334 /Udieresis
+  dup 335 /Yacute
+  dup 376 /thorn
+  dup 337 /germandbls
+  dup 341 /aacute
+  dup 342 /acircumflex
+  dup 344 /adieresis
+  dup 346 /ae
+  dup 340 /agrave
+  dup 345 /aring
+  dup 347 /ccedilla
+  dup 351 /eacute
+  dup 352 /ecircumflex
+  dup 353 /edieresis
+  dup 350 /egrave
+  dup 355 /iacute
+  dup 356 /icircumflex
+  dup 357 /idieresis
+  dup 354 /igrave
+  dup 360 /dcroat
+  dup 361 /ntilde
+  dup 363 /oacute
+  dup 364 /ocircumflex
+  dup 366 /odieresis
+  dup 362 /ograve
+  dup 365 /otilde
+  dup 370 /oslash
+  dup 372 /uacute
+  dup 373 /ucircumflex
+  dup 374 /udieresis
+  dup 371 /ugrave
+  dup 375 /yacute
+  dup 377 /ydieresis  
+
+% Set up ISO Latin 1 character encoding
+/starnetISO {
+        dup dup findfont dup length dict begin
+        { 1 index /FID ne { def }{ pop pop } ifelse
+        } forall
+        /Encoding EncodingVector def
+        currentdict end definefont
+} def
+/Times-Roman starnetISO def
+/Times-Italic starnetISO def
+/Times-Bold starnetISO def
+/Times-BoldItalic starnetISO def
+/Helvetica starnetISO def
+/Helvetica-Oblique starnetISO def
+/Helvetica-Bold starnetISO def
+/Helvetica-BoldOblique starnetISO def
+/Courier starnetISO def
+/Courier-Oblique starnetISO def
+/Courier-Bold starnetISO def
+/Courier-BoldOblique starnetISO def
+cleartomark
+} bind def
+
+%%BeginResource: procset graphviz 0 0
+/coord-font-family /Times-Roman def
+/default-font-family /Times-Roman def
+/coordfont coord-font-family findfont 8 scalefont def
+
+/InvScaleFactor 1.0 def
+/set_scale {
+	dup 1 exch div /InvScaleFactor exch def
+	dup scale
+} bind def
+
+% styles
+/solid { [] 0 setdash } bind def
+/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
+/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
+/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
+/bold { 2 setlinewidth } bind def
+/filled { } bind def
+/unfilled { } bind def
+/rounded { } bind def
+/diagonals { } bind def
+
+% hooks for setting color 
+/nodecolor { sethsbcolor } bind def
+/edgecolor { sethsbcolor } bind def
+/graphcolor { sethsbcolor } bind def
+/nopcolor {pop pop pop} bind def
+
+/beginpage {	% i j npages
+	/npages exch def
+	/j exch def
+	/i exch def
+	/str 10 string def
+	npages 1 gt {
+		gsave
+			coordfont setfont
+			0 0 moveto
+			(\() show i str cvs show (,) show j str cvs show (\)) show
+		grestore
+	} if
+} bind def
+
+/set_font {
+	findfont exch
+	scalefont setfont
+} def
+
+% draw aligned label in bounding box aligned to current point
+/alignedtext {			% width adj text
+	/text exch def
+	/adj exch def
+	/width exch def
+	gsave
+		width 0 gt {
+			text stringwidth pop adj mul 0 rmoveto
+		} if
+		[] 0 setdash
+		text show
+	grestore
+} def
+
+/boxprim {				% xcorner ycorner xsize ysize
+		4 2 roll
+		moveto
+		2 copy
+		exch 0 rlineto
+		0 exch rlineto
+		pop neg 0 rlineto
+		closepath
+} bind def
+
+/ellipse_path {
+	/ry exch def
+	/rx exch def
+	/y exch def
+	/x exch def
+	matrix currentmatrix
+	newpath
+	x y translate
+	rx ry scale
+	0 0 1 0 360 arc
+	setmatrix
+} bind def
+
+/endpage { showpage } bind def
+/showpage { } def
+
+/layercolorseq
+	[	% layer color sequence - darkest to lightest
+		[0 0 0]
+		[.2 .8 .8]
+		[.4 .8 .8]
+		[.6 .8 .8]
+		[.8 .8 .8]
+	]
+def
+
+/layerlen layercolorseq length def
+
+/setlayer {/maxlayer exch def /curlayer exch def
+	layercolorseq curlayer 1 sub layerlen mod get
+	aload pop sethsbcolor
+	/nodecolor {nopcolor} def
+	/edgecolor {nopcolor} def
+	/graphcolor {nopcolor} def
+} bind def
+
+/onlayer { curlayer ne {invis} if } def
+
+/onlayers {
+	/myupper exch def
+	/mylower exch def
+	curlayer mylower lt
+	curlayer myupper gt
+	or
+	{invis} if
+} def
+
+/curlayer 0 def
+
+%%EndResource
+%%EndProlog
+%%BeginSetup
+14 default-font-family set_font
+1 setmiterlimit
+% /arrowlength 10 def
+% /arrowwidth 5 def
+
+% make sure pdfmark is harmless for PS-interpreters other than Distiller
+/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
+% make '<<' and '>>' safe on PS Level 1 devices
+/languagelevel where {pop languagelevel}{1} ifelse
+2 lt {
+    userdict (<<) cvn ([) cvn load put
+    userdict (>>) cvn ([) cvn load put
+} if
+
+%%EndSetup
+%%Page: 1 1
+%%PageBoundingBox: 36 36 577 127
+%%PageOrientation: Portrait
+gsave
+35 35 542 92 boxprim clip newpath
+36 36 translate
+0 0 1 beginpage
+0.2845 set_scale
+0 0 translate 0 rotate
+0.000 0.000 0.000 graphcolor
+14.00 /Times-Roman set_font
+
+%	Vm
+gsave 10 dict begin
+801 294 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+789 289 moveto
+(Vm)
+[10.08 10.8]
+xshow
+end grestore
+end grestore
+
+%	Cemitcodes
+gsave 10 dict begin
+1427 200 46 18 ellipse_path
+stroke
+gsave 10 dict begin
+1393 195 moveto
+(Cemitcodes)
+[9.36 6.24 10.8 3.84 3.84 6.24 6.96 6.96 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Vm -> Cemitcodes
+newpath 826 287 moveto
+871 276 969 254 1053 254 curveto
+1053 254 1053 254 1174 254 curveto
+1249 254 1332 231 1382 215 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1383 218 moveto
+1392 212 lineto
+1381 212 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1383 218 moveto
+1392 212 lineto
+1381 212 lineto
+closepath
+stroke
+end grestore
+
+%	Conv_oracle
+gsave 10 dict begin
+1053 300 48 18 ellipse_path
+stroke
+gsave 10 dict begin
+1017 295 moveto
+(Conv_oracle)
+[9.36 6.96 6.48 6.96 6.96 6.96 4.56 6.24 6.24 3.84 6.24]
+xshow
+end grestore
+end grestore
+
+%	Vm -> Conv_oracle
+newpath 828 295 moveto
+868 296 942 298 995 299 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 995 303 moveto
+1005 299 lineto
+995 296 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 995 303 moveto
+1005 299 lineto
+995 296 lineto
+closepath
+stroke
+end grestore
+
+%	Mod_subst
+gsave 10 dict begin
+1556 146 45 18 ellipse_path
+stroke
+gsave 10 dict begin
+1524 141 moveto
+(Mod_subst)
+[12.48 6.96 6.96 6.96 5.52 6.96 6.96 5.28 3.84]
+xshow
+end grestore
+end grestore
+
+%	Cemitcodes -> Mod_subst
+newpath 1459 187 moveto
+1476 180 1497 171 1516 163 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1517 166 moveto
+1525 159 lineto
+1514 160 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1517 166 moveto
+1525 159 lineto
+1514 160 lineto
+closepath
+stroke
+end grestore
+
+%	Cbytecodes
+gsave 10 dict begin
+1556 200 45 18 ellipse_path
+stroke
+gsave 10 dict begin
+1523 195 moveto
+(Cbytecodes)
+[9.36 6.48 6.96 3.84 6.24 6.24 6.96 6.96 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Cemitcodes -> Cbytecodes
+newpath 1474 200 moveto
+1482 200 1491 200 1500 200 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1500 204 moveto
+1510 200 lineto
+1500 197 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1500 204 moveto
+1510 200 lineto
+1500 197 lineto
+closepath
+stroke
+end grestore
+
+%	Copcodes
+gsave 10 dict begin
+1556 254 41 18 ellipse_path
+stroke
+gsave 10 dict begin
+1528 249 moveto
+(Copcodes)
+[9.36 6.96 6.96 6.24 6.96 6.96 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Cemitcodes -> Copcodes
+newpath 1459 213 moveto
+1476 221 1498 230 1517 237 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1515 240 moveto
+1526 241 lineto
+1518 234 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1515 240 moveto
+1526 241 lineto
+1518 234 lineto
+closepath
+stroke
+end grestore
+
+%	Names
+gsave 10 dict begin
+1865 270 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+1845 265 moveto
+(Names)
+[9.6 6.24 10.8 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Conv_oracle -> Names
+newpath 1102 300 moveto
+1151 300 1228 300 1295 300 curveto
+1295 300 1295 300 1666 300 curveto
+1722 300 1785 288 1825 279 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1826 282 moveto
+1835 277 lineto
+1825 276 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1826 282 moveto
+1835 277 lineto
+1825 276 lineto
+closepath
+stroke
+end grestore
+
+%	Vconv
+gsave 10 dict begin
+552 202 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+533 197 moveto
+(Vconv)
+[10.08 6.24 6.96 6.48 6.96]
+xshow
+end grestore
+end grestore
+
+%	Csymtable
+gsave 10 dict begin
+674 202 43 18 ellipse_path
+stroke
+gsave 10 dict begin
+643 197 moveto
+(Csymtable)
+[9.36 5.52 6.96 10.8 4.08 6.24 6.96 3.84 6.24]
+xshow
+end grestore
+end grestore
+
+%	Vconv -> Csymtable
+newpath 584 202 moveto
+595 202 608 202 620 202 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 620 206 moveto
+630 202 lineto
+620 199 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 620 206 moveto
+630 202 lineto
+620 199 lineto
+closepath
+stroke
+end grestore
+
+%	Inductive
+gsave 10 dict begin
+674 110 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+647 105 moveto
+(Inductive)
+[4.56 6.96 6.96 6.96 6.24 3.84 3.84 6.48 6.24]
+xshow
+end grestore
+end grestore
+
+%	Vconv -> Inductive
+newpath 571 187 moveto
+591 172 622 149 645 132 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 647 135 moveto
+653 126 lineto
+643 129 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 647 135 moveto
+653 126 lineto
+643 129 lineto
+closepath
+stroke
+end grestore
+
+%	Csymtable -> Vm
+newpath 696 218 moveto
+717 234 751 258 775 275 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 773 278 moveto
+783 281 lineto
+777 272 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 773 278 moveto
+783 281 lineto
+777 272 lineto
+closepath
+stroke
+end grestore
+
+%	Cbytegen
+gsave 10 dict begin
+801 164 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+774 159 moveto
+(Cbytegen)
+[9.36 6.48 6.96 3.84 6.24 6.72 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	Csymtable -> Cbytegen
+newpath 709 191 moveto
+724 187 742 181 758 177 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 759 180 moveto
+768 174 lineto
+757 174 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 759 180 moveto
+768 174 lineto
+757 174 lineto
+closepath
+stroke
+end grestore
+
+%	Type_errors
+gsave 10 dict begin
+801 110 47 18 ellipse_path
+stroke
+gsave 10 dict begin
+767 105 moveto
+(Type_errors)
+[6.96 6.96 6.96 6.24 6.96 6.24 5.04 4.56 6.96 4.56 5.52]
+xshow
+end grestore
+end grestore
+
+%	Inductive -> Type_errors
+newpath 714 110 moveto
+724 110 734 110 744 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 744 114 moveto
+754 110 lineto
+744 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 744 114 moveto
+754 110 lineto
+744 107 lineto
+closepath
+stroke
+end grestore
+
+%	Univ
+gsave 10 dict begin
+1763 241 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+1748 236 moveto
+(Univ)
+[9.6 6.96 3.84 6.96]
+xshow
+end grestore
+end grestore
+
+%	Univ -> Names
+newpath 1788 248 moveto
+1800 251 1814 255 1826 259 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1825 262 moveto
+1836 262 lineto
+1827 256 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1825 262 moveto
+1836 262 lineto
+1827 256 lineto
+closepath
+stroke
+end grestore
+
+%	Typeops
+gsave 10 dict begin
+552 110 36 18 ellipse_path
+stroke
+gsave 10 dict begin
+528 105 moveto
+(Typeops)
+[6.96 6.96 6.96 6.24 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Typeops -> Inductive
+newpath 589 110 moveto
+600 110 612 110 624 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 624 114 moveto
+634 110 lineto
+624 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 624 114 moveto
+634 110 lineto
+624 107 lineto
+closepath
+stroke
+end grestore
+
+%	Entries
+gsave 10 dict begin
+801 56 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+780 51 moveto
+(Entries)
+[8.4 6.96 3.84 4.8 3.84 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Typeops -> Entries
+newpath 581 99 moveto
+595 93 614 87 630 83 curveto
+673 73 723 66 758 61 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 758 64 moveto
+768 60 lineto
+758 58 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 758 64 moveto
+768 60 lineto
+758 58 lineto
+closepath
+stroke
+end grestore
+
+%	Sign
+gsave 10 dict begin
+1427 100 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+1414 95 moveto
+(Sign)
+[7.68 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Entries -> Sign
+newpath 834 61 moveto
+882 68 974 79 1053 79 curveto
+1053 79 1053 79 1174 79 curveto
+1251 79 1342 89 1390 95 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1390 98 moveto
+1400 96 lineto
+1390 92 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1390 98 moveto
+1400 96 lineto
+1390 92 lineto
+closepath
+stroke
+end grestore
+
+%	Reduction
+gsave 10 dict begin
+926 208 42 18 ellipse_path
+stroke
+gsave 10 dict begin
+897 203 moveto
+(Reduction)
+[9.12 6.24 6.96 6.96 6.24 3.84 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Type_errors -> Reduction
+newpath 829 125 moveto
+836 129 842 133 848 137 curveto
+868 151 887 170 902 184 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 900 187 moveto
+910 191 lineto
+905 182 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 900 187 moveto
+910 191 lineto
+905 182 lineto
+closepath
+stroke
+end grestore
+
+%	Reduction -> Conv_oracle
+newpath 948 224 moveto
+968 239 999 261 1023 278 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1021 281 moveto
+1031 284 lineto
+1025 275 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1021 281 moveto
+1031 284 lineto
+1025 275 lineto
+closepath
+stroke
+end grestore
+
+%	Closure
+gsave 10 dict begin
+1053 208 35 18 ellipse_path
+stroke
+gsave 10 dict begin
+1031 203 moveto
+(Closure)
+[9.36 3.84 6.96 5.52 6.96 4.56 6.24]
+xshow
+end grestore
+end grestore
+
+%	Reduction -> Closure
+newpath 968 208 moveto
+981 208 994 208 1008 208 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1008 212 moveto
+1018 208 lineto
+1008 205 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1008 212 moveto
+1018 208 lineto
+1008 205 lineto
+closepath
+stroke
+end grestore
+
+%	Term_typing
+gsave 10 dict begin
+313 110 49 18 ellipse_path
+stroke
+gsave 10 dict begin
+277 105 moveto
+(Term_typing)
+[7.2 6.24 4.8 10.8 6.96 3.84 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Term_typing -> Cbytegen
+newpath 347 123 moveto
+363 128 381 134 398 137 curveto
+524 161 675 165 752 165 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 752 169 moveto
+762 165 lineto
+752 162 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 752 169 moveto
+762 165 lineto
+752 162 lineto
+closepath
+stroke
+end grestore
+
+%	Cooking
+gsave 10 dict begin
+436 225 37 18 ellipse_path
+stroke
+gsave 10 dict begin
+411 220 moveto
+(Cooking)
+[9.36 6.96 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Term_typing -> Cooking
+newpath 331 127 moveto
+352 147 387 179 410 202 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 408 205 moveto
+418 209 lineto
+413 200 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 408 205 moveto
+418 209 lineto
+413 200 lineto
+closepath
+stroke
+end grestore
+
+%	Indtypes
+gsave 10 dict begin
+436 110 37 18 ellipse_path
+stroke
+gsave 10 dict begin
+411 105 moveto
+(Indtypes)
+[4.56 6.96 6.96 3.84 6.96 6.96 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Term_typing -> Indtypes
+newpath 362 110 moveto
+370 110 379 110 388 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 388 114 moveto
+398 110 lineto
+388 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 388 114 moveto
+398 110 lineto
+388 107 lineto
+closepath
+stroke
+end grestore
+
+%	Environ
+gsave 10 dict begin
+1174 181 36 18 ellipse_path
+stroke
+gsave 10 dict begin
+1151 176 moveto
+(Environ)
+[8.4 6.48 6.96 3.84 4.56 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Cbytegen -> Environ
+newpath 841 166 moveto
+911 169 1054 175 1128 179 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1128 183 moveto
+1138 179 lineto
+1128 176 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1128 183 moveto
+1138 179 lineto
+1128 176 lineto
+closepath
+stroke
+end grestore
+
+%	Cooking -> Reduction
+newpath 473 227 moveto
+485 228 498 229 510 229 curveto
+603 231 626 233 718 229 curveto
+773 226 834 220 876 214 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 876 217 moveto
+886 213 lineto
+876 211 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 876 217 moveto
+886 213 lineto
+876 211 lineto
+closepath
+stroke
+end grestore
+
+%	Indtypes -> Typeops
+newpath 474 110 moveto
+484 110 495 110 505 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 505 114 moveto
+515 110 lineto
+505 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 505 114 moveto
+515 110 lineto
+505 107 lineto
+closepath
+stroke
+end grestore
+
+%	Term
+gsave 10 dict begin
+1666 173 28 18 ellipse_path
+stroke
+gsave 10 dict begin
+1651 168 moveto
+(Term)
+[7.2 6.24 4.8 10.8]
+xshow
+end grestore
+end grestore
+
+%	Term -> Univ
+newpath 1685 186 moveto
+1699 196 1719 211 1736 222 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1734 225 moveto
+1744 228 lineto
+1738 219 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1734 225 moveto
+1744 228 lineto
+1738 219 lineto
+closepath
+stroke
+end grestore
+
+%	Esubst
+gsave 10 dict begin
+1763 173 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+1743 168 moveto
+(Esubst)
+[8.4 5.52 6.96 6.96 5.28 3.84]
+xshow
+end grestore
+end grestore
+
+%	Term -> Esubst
+newpath 1694 173 moveto
+1702 173 1711 173 1720 173 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1720 177 moveto
+1730 173 lineto
+1720 170 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1720 177 moveto
+1730 173 lineto
+1720 170 lineto
+closepath
+stroke
+end grestore
+
+%	Subtyping
+gsave 10 dict begin
+552 56 42 18 ellipse_path
+stroke
+gsave 10 dict begin
+523 51 moveto
+(Subtyping)
+[7.68 6.96 6.96 3.84 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Subtyping -> Inductive
+newpath 581 69 moveto
+597 77 618 86 636 93 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 634 96 moveto
+645 97 lineto
+637 90 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 634 96 moveto
+645 97 lineto
+637 90 lineto
+closepath
+stroke
+end grestore
+
+%	Modops
+gsave 10 dict begin
+674 18 36 18 ellipse_path
+stroke
+gsave 10 dict begin
+650 13 moveto
+(Modops)
+[12.48 6.96 6.96 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Subtyping -> Modops
+newpath 586 45 moveto
+601 41 618 35 633 31 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 634 34 moveto
+643 28 lineto
+632 28 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 634 34 moveto
+643 28 lineto
+632 28 lineto
+closepath
+stroke
+end grestore
+
+%	Modops -> Entries
+newpath 705 27 moveto
+722 32 743 39 761 44 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 760 47 moveto
+771 47 lineto
+762 41 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 760 47 moveto
+771 47 lineto
+762 41 lineto
+closepath
+stroke
+end grestore
+
+%	Modops -> Cbytegen
+newpath 686 35 moveto
+695 48 707 67 718 83 curveto
+735 107 733 118 754 137 curveto
+757 140 761 143 765 145 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 763 148 moveto
+773 151 lineto
+767 142 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 763 148 moveto
+773 151 lineto
+767 142 lineto
+closepath
+stroke
+end grestore
+
+%	Sign -> Term
+newpath 1454 99 moveto
+1489 98 1553 100 1602 119 curveto
+1626 129 1637 135 1649 148 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1647 151 moveto
+1656 156 lineto
+1652 146 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1647 151 moveto
+1656 156 lineto
+1652 146 lineto
+closepath
+stroke
+end grestore
+
+%	Safe_typing
+gsave 10 dict begin
+47 85 46 18 ellipse_path
+stroke
+gsave 10 dict begin
+13 80 moveto
+(Safe_typing)
+[7.68 6.24 4.08 6.24 6.96 3.84 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Mod_typing
+gsave 10 dict begin
+179 85 48 18 ellipse_path
+stroke
+gsave 10 dict begin
+143 80 moveto
+(Mod_typing)
+[12.48 6.96 6.96 6.96 3.84 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Safe_typing -> Mod_typing
+newpath 94 85 moveto
+103 85 111 85 120 85 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 120 89 moveto
+130 85 lineto
+120 82 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 120 89 moveto
+130 85 lineto
+120 82 lineto
+closepath
+stroke
+end grestore
+
+%	Mod_typing -> Term_typing
+newpath 223 93 moveto
+235 95 248 98 260 100 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 260 103 moveto
+270 102 lineto
+261 97 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 260 103 moveto
+270 102 lineto
+261 97 lineto
+closepath
+stroke
+end grestore
+
+%	Mod_typing -> Subtyping
+newpath 227 81 moveto
+297 75 428 65 500 60 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 500 63 moveto
+510 59 lineto
+500 57 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 500 63 moveto
+510 59 lineto
+500 57 lineto
+closepath
+stroke
+end grestore
+
+%	Closure -> Environ
+newpath 1085 201 moveto
+1099 198 1116 194 1131 190 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1132 193 moveto
+1141 188 lineto
+1131 187 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1132 193 moveto
+1141 188 lineto
+1131 187 lineto
+closepath
+stroke
+end grestore
+
+%	Mod_subst -> Term
+newpath 1594 155 moveto
+1606 158 1618 161 1630 164 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1630 167 moveto
+1640 166 lineto
+1631 161 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1630 167 moveto
+1640 166 lineto
+1631 161 lineto
+closepath
+stroke
+end grestore
+
+%	Declarations
+gsave 10 dict begin
+1295 181 49 18 ellipse_path
+stroke
+gsave 10 dict begin
+1259 176 moveto
+(Declarations)
+[10.08 6.24 6.24 3.84 6.24 4.56 6.24 3.84 3.84 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Environ -> Declarations
+newpath 1210 181 moveto
+1218 181 1227 181 1236 181 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1236 185 moveto
+1246 181 lineto
+1236 178 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1236 185 moveto
+1246 181 lineto
+1236 178 lineto
+closepath
+stroke
+end grestore
+
+%	Declarations -> Cemitcodes
+newpath 1341 188 moveto
+1351 189 1363 191 1373 192 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1373 195 moveto
+1383 194 lineto
+1374 189 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1373 195 moveto
+1383 194 lineto
+1374 189 lineto
+closepath
+stroke
+end grestore
+
+%	Declarations -> Sign
+newpath 1320 165 moveto
+1343 152 1375 132 1398 118 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1401 120 moveto
+1407 112 lineto
+1397 115 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1401 120 moveto
+1407 112 lineto
+1397 115 lineto
+closepath
+stroke
+end grestore
+
+%	Cbytecodes -> Term
+newpath 1595 190 moveto
+1607 188 1619 185 1630 182 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1631 185 moveto
+1640 179 lineto
+1629 179 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1631 185 moveto
+1640 179 lineto
+1629 179 lineto
+closepath
+stroke
+end grestore
+endpage
+showpage
+grestore
+%%PageTrailer
+%%EndPage: 1
+%%Trailer
+%%Pages: 1
+end
+restore
+%%EOF
diff --git a/dev/ocamlweb-doc/lex.mll b/dev/ocamlweb-doc/lex.mll
new file mode 100644
index 00000000..617163e7
--- /dev/null
+++ b/dev/ocamlweb-doc/lex.mll
@@ -0,0 +1,81 @@
+
+{
+ open Lexing
+ open Syntax
+
+ let chan_out = ref stdout
+
+ let comment_depth = ref 0
+ let print s = output_string !chan_out s
+ 
+ exception Fin_fichier
+
+}
+
+let space = [' ' '\t' '\n']
+let letter = ['a'-'z' 'A'-'Z']
+let digit = ['0'-'9']
+
+let identifier = letter (letter | digit | ['_' '\''])*
+let number = digit+
+let oper = ['-' '+' '/' '*' '|' '>' '<' '=' '%' '#' '$' ':' '\\' '?'
+            '.' '!' '@' ]+
+
+rule token = parse
+  | "let" {LET}
+  | "in" {IN}
+  | "match" {MATCH}
+  | "with" {WITH}
+  | "end" {END}
+  | "and" {AND}
+  | "fun" {FUN}
+  | "if" {IF}
+  | "then" {THEN}
+  | "else" {ELSE}
+  | "eval" {EVAL}
+  | "for" {FOR}
+  | "Prop" {PROP}
+  | "Set" {SET}
+  | "Type" {TYPE}
+  | "fix" {FIX}
+  | "cofix" {COFIX}
+  | "struct" {STRUCT}
+  | "as" {AS}
+
+  | "Simpl" {SIMPL}
+
+  | "_" {WILDCARD}
+  | "(" {LPAR}
+  | ")" {RPAR}
+  | "{" {LBRACE}
+  | "}" {RBRACE}
+  | "!" {BANG}
+  | "@" {AT}
+  | ":" {COLON}
+  | ":=" {COLONEQ}
+  | "." {DOT}
+  | "," {COMMA}
+  | "->" {OPER "->"}
+  | "=>" {RARROW}
+  | "|" {BAR}
+  | "%" {PERCENT}
+
+  | '?' { META(ident lexbuf)}
+  | number { INT(Lexing.lexeme lexbuf) }
+  | oper { OPER(Lexing.lexeme lexbuf) }
+  | identifier { IDENT (Lexing.lexeme lexbuf) }
+  | "(*" (*"*)"*)       { comment_depth := 1;
+                          comment lexbuf;
+		          token lexbuf }
+  | space+     { token lexbuf}
+  | eof        { EOF }
+
+and ident = parse
+  | identifier { Lexing.lexeme lexbuf }
+
+and comment = parse
+  | "(*" (*"*)"*)  { incr comment_depth; comment lexbuf }
+  | (*"(*"*) "*)"
+      { decr comment_depth; if !comment_depth > 0 then comment lexbuf }
+  | eof   { raise Fin_fichier } 
+  | _     { comment lexbuf }
diff --git a/dev/ocamlweb-doc/library.dep.ps b/dev/ocamlweb-doc/library.dep.ps
new file mode 100644
index 00000000..1c68240e
--- /dev/null
+++ b/dev/ocamlweb-doc/library.dep.ps
@@ -0,0 +1,836 @@
+%!PS-Adobe-2.0
+%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
+%%For: (herbelin) Hugo Herbelin
+%%Title: G
+%%Pages: (atend)
+%%BoundingBox: 35 35 577 207
+%%EndComments
+save
+%%BeginProlog
+/DotDict 200 dict def
+DotDict begin
+
+/setupLatin1 {
+mark
+/EncodingVector 256 array def
+ EncodingVector 0
+
+ISOLatin1Encoding 0 255 getinterval putinterval
+
+EncodingVector
+  dup 306 /AE
+  dup 301 /Aacute
+  dup 302 /Acircumflex
+  dup 304 /Adieresis
+  dup 300 /Agrave
+  dup 305 /Aring
+  dup 303 /Atilde
+  dup 307 /Ccedilla
+  dup 311 /Eacute
+  dup 312 /Ecircumflex
+  dup 313 /Edieresis
+  dup 310 /Egrave
+  dup 315 /Iacute
+  dup 316 /Icircumflex
+  dup 317 /Idieresis
+  dup 314 /Igrave
+  dup 334 /Udieresis
+  dup 335 /Yacute
+  dup 376 /thorn
+  dup 337 /germandbls
+  dup 341 /aacute
+  dup 342 /acircumflex
+  dup 344 /adieresis
+  dup 346 /ae
+  dup 340 /agrave
+  dup 345 /aring
+  dup 347 /ccedilla
+  dup 351 /eacute
+  dup 352 /ecircumflex
+  dup 353 /edieresis
+  dup 350 /egrave
+  dup 355 /iacute
+  dup 356 /icircumflex
+  dup 357 /idieresis
+  dup 354 /igrave
+  dup 360 /dcroat
+  dup 361 /ntilde
+  dup 363 /oacute
+  dup 364 /ocircumflex
+  dup 366 /odieresis
+  dup 362 /ograve
+  dup 365 /otilde
+  dup 370 /oslash
+  dup 372 /uacute
+  dup 373 /ucircumflex
+  dup 374 /udieresis
+  dup 371 /ugrave
+  dup 375 /yacute
+  dup 377 /ydieresis  
+
+% Set up ISO Latin 1 character encoding
+/starnetISO {
+        dup dup findfont dup length dict begin
+        { 1 index /FID ne { def }{ pop pop } ifelse
+        } forall
+        /Encoding EncodingVector def
+        currentdict end definefont
+} def
+/Times-Roman starnetISO def
+/Times-Italic starnetISO def
+/Times-Bold starnetISO def
+/Times-BoldItalic starnetISO def
+/Helvetica starnetISO def
+/Helvetica-Oblique starnetISO def
+/Helvetica-Bold starnetISO def
+/Helvetica-BoldOblique starnetISO def
+/Courier starnetISO def
+/Courier-Oblique starnetISO def
+/Courier-Bold starnetISO def
+/Courier-BoldOblique starnetISO def
+cleartomark
+} bind def
+
+%%BeginResource: procset graphviz 0 0
+/coord-font-family /Times-Roman def
+/default-font-family /Times-Roman def
+/coordfont coord-font-family findfont 8 scalefont def
+
+/InvScaleFactor 1.0 def
+/set_scale {
+	dup 1 exch div /InvScaleFactor exch def
+	dup scale
+} bind def
+
+% styles
+/solid { [] 0 setdash } bind def
+/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
+/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
+/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
+/bold { 2 setlinewidth } bind def
+/filled { } bind def
+/unfilled { } bind def
+/rounded { } bind def
+/diagonals { } bind def
+
+% hooks for setting color 
+/nodecolor { sethsbcolor } bind def
+/edgecolor { sethsbcolor } bind def
+/graphcolor { sethsbcolor } bind def
+/nopcolor {pop pop pop} bind def
+
+/beginpage {	% i j npages
+	/npages exch def
+	/j exch def
+	/i exch def
+	/str 10 string def
+	npages 1 gt {
+		gsave
+			coordfont setfont
+			0 0 moveto
+			(\() show i str cvs show (,) show j str cvs show (\)) show
+		grestore
+	} if
+} bind def
+
+/set_font {
+	findfont exch
+	scalefont setfont
+} def
+
+% draw aligned label in bounding box aligned to current point
+/alignedtext {			% width adj text
+	/text exch def
+	/adj exch def
+	/width exch def
+	gsave
+		width 0 gt {
+			text stringwidth pop adj mul 0 rmoveto
+		} if
+		[] 0 setdash
+		text show
+	grestore
+} def
+
+/boxprim {				% xcorner ycorner xsize ysize
+		4 2 roll
+		moveto
+		2 copy
+		exch 0 rlineto
+		0 exch rlineto
+		pop neg 0 rlineto
+		closepath
+} bind def
+
+/ellipse_path {
+	/ry exch def
+	/rx exch def
+	/y exch def
+	/x exch def
+	matrix currentmatrix
+	newpath
+	x y translate
+	rx ry scale
+	0 0 1 0 360 arc
+	setmatrix
+} bind def
+
+/endpage { showpage } bind def
+/showpage { } def
+
+/layercolorseq
+	[	% layer color sequence - darkest to lightest
+		[0 0 0]
+		[.2 .8 .8]
+		[.4 .8 .8]
+		[.6 .8 .8]
+		[.8 .8 .8]
+	]
+def
+
+/layerlen layercolorseq length def
+
+/setlayer {/maxlayer exch def /curlayer exch def
+	layercolorseq curlayer 1 sub layerlen mod get
+	aload pop sethsbcolor
+	/nodecolor {nopcolor} def
+	/edgecolor {nopcolor} def
+	/graphcolor {nopcolor} def
+} bind def
+
+/onlayer { curlayer ne {invis} if } def
+
+/onlayers {
+	/myupper exch def
+	/mylower exch def
+	curlayer mylower lt
+	curlayer myupper gt
+	or
+	{invis} if
+} def
+
+/curlayer 0 def
+
+%%EndResource
+%%EndProlog
+%%BeginSetup
+14 default-font-family set_font
+1 setmiterlimit
+% /arrowlength 10 def
+% /arrowwidth 5 def
+
+% make sure pdfmark is harmless for PS-interpreters other than Distiller
+/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
+% make '<<' and '>>' safe on PS Level 1 devices
+/languagelevel where {pop languagelevel}{1} ifelse
+2 lt {
+    userdict (<<) cvn ([) cvn load put
+    userdict (>>) cvn ([) cvn load put
+} if
+
+%%EndSetup
+%%Page: 1 1
+%%PageBoundingBox: 36 36 577 207
+%%PageOrientation: Portrait
+gsave
+35 35 542 172 boxprim clip newpath
+36 36 translate
+0 0 1 beginpage
+0.6750 set_scale
+0 0 translate 0 rotate
+0.000 0.000 0.000 graphcolor
+14.00 /Times-Roman set_font
+
+%	States
+gsave 10 dict begin
+30 18 30 18 ellipse_path
+stroke
+gsave 10 dict begin
+13 13 moveto
+(States)
+[7.44 4.08 6.24 3.84 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Library
+gsave 10 dict begin
+132 18 34 18 ellipse_path
+stroke
+gsave 10 dict begin
+110 13 moveto
+(Library)
+[8.4 3.84 6.96 4.56 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	States -> Library
+newpath 60 18 moveto
+69 18 78 18 87 18 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 87 22 moveto
+97 18 lineto
+87 15 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 87 22 moveto
+97 18 lineto
+87 15 lineto
+closepath
+stroke
+end grestore
+
+%	Declaremods
+gsave 10 dict begin
+274 18 50 18 ellipse_path
+stroke
+gsave 10 dict begin
+236 13 moveto
+(Declaremods)
+[10.08 6.24 6.24 3.84 6.24 4.56 6.24 10.8 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Library -> Declaremods
+newpath 167 18 moveto
+181 18 197 18 213 18 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 213 22 moveto
+223 18 lineto
+213 15 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 213 22 moveto
+223 18 lineto
+213 15 lineto
+closepath
+stroke
+end grestore
+
+%	Nametab
+gsave 10 dict begin
+523 134 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+497 129 moveto
+(Nametab)
+[9.6 6.24 10.8 6 4.08 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	Libnames
+gsave 10 dict begin
+642 134 41 18 ellipse_path
+stroke
+gsave 10 dict begin
+613 129 moveto
+(Libnames)
+[8.4 3.84 6.96 6.96 6.24 10.8 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Nametab -> Libnames
+newpath 562 134 moveto
+571 134 580 134 590 134 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 590 138 moveto
+600 134 lineto
+590 131 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 590 138 moveto
+600 134 lineto
+590 131 lineto
+closepath
+stroke
+end grestore
+
+%	Summary
+gsave 10 dict begin
+642 65 40 18 ellipse_path
+stroke
+gsave 10 dict begin
+614 60 moveto
+(Summary)
+[7.68 6.96 10.8 10.8 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	Nametab -> Summary
+newpath 547 120 moveto
+565 110 589 96 608 84 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 610 87 moveto
+617 79 lineto
+607 81 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 610 87 moveto
+617 79 lineto
+607 81 lineto
+closepath
+stroke
+end grestore
+
+%	Nameops
+gsave 10 dict begin
+760 134 40 18 ellipse_path
+stroke
+gsave 10 dict begin
+733 129 moveto
+(Nameops)
+[9.6 6.24 10.8 6.24 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Libnames -> Nameops
+newpath 684 134 moveto
+693 134 701 134 710 134 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 710 138 moveto
+720 134 lineto
+710 131 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 710 138 moveto
+720 134 lineto
+710 131 lineto
+closepath
+stroke
+end grestore
+
+%	Lib
+gsave 10 dict begin
+413 153 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+402 148 moveto
+(Lib)
+[8.4 3.84 6.96]
+xshow
+end grestore
+end grestore
+
+%	Declaremods -> Lib
+newpath 315 29 moveto
+325 33 336 38 344 45 curveto
+359 58 383 99 399 127 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 396 129 moveto
+404 136 lineto
+402 126 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 396 129 moveto
+404 136 lineto
+402 126 lineto
+closepath
+stroke
+end grestore
+
+%	Global
+gsave 10 dict begin
+413 65 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+393 60 moveto
+(Global)
+[10.08 3.84 6.96 6.96 6.24 3.84]
+xshow
+end grestore
+end grestore
+
+%	Declaremods -> Global
+newpath 311 30 moveto
+331 37 355 45 375 52 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 374 55 moveto
+385 55 lineto
+376 49 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 374 55 moveto
+385 55 lineto
+376 49 lineto
+closepath
+stroke
+end grestore
+
+%	Libobject
+gsave 10 dict begin
+523 188 40 18 ellipse_path
+stroke
+gsave 10 dict begin
+495 183 moveto
+(Libobject)
+[8.4 3.84 6.96 6.96 6.96 3.84 6.24 6.24 3.84]
+xshow
+end grestore
+end grestore
+
+%	Libobject -> Libnames
+newpath 552 175 moveto
+567 168 587 159 604 151 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 605 154 moveto
+613 147 lineto
+602 148 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 605 154 moveto
+613 147 lineto
+602 148 lineto
+closepath
+stroke
+end grestore
+
+%	Lib -> Nametab
+newpath 439 148 moveto
+450 146 464 144 476 142 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 477 145 moveto
+486 140 lineto
+476 139 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 477 145 moveto
+486 140 lineto
+476 139 lineto
+closepath
+stroke
+end grestore
+
+%	Lib -> Libobject
+newpath 437 161 moveto
+450 165 466 170 480 174 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 479 177 moveto
+490 177 lineto
+481 171 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 479 177 moveto
+490 177 lineto
+481 171 lineto
+closepath
+stroke
+end grestore
+
+%	Impargs
+gsave 10 dict begin
+274 126 36 18 ellipse_path
+stroke
+gsave 10 dict begin
+251 121 moveto
+(Impargs)
+[4.56 10.56 6.96 6.24 4.32 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Impargs -> Lib
+newpath 308 133 moveto
+329 137 355 142 377 146 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 377 149 moveto
+387 148 lineto
+378 143 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 377 149 moveto
+387 148 lineto
+378 143 lineto
+closepath
+stroke
+end grestore
+
+%	Impargs -> Global
+newpath 304 116 moveto
+316 111 331 105 344 99 curveto
+357 94 369 88 381 82 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 382 85 moveto
+390 78 lineto
+379 79 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 382 85 moveto
+390 78 lineto
+379 79 lineto
+closepath
+stroke
+end grestore
+
+%	Global -> Libnames
+newpath 443 73 moveto
+473 81 522 94 564 107 curveto
+576 111 589 115 600 119 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 599 122 moveto
+610 122 lineto
+601 116 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 599 122 moveto
+610 122 lineto
+601 116 lineto
+closepath
+stroke
+end grestore
+
+%	Global -> Summary
+newpath 446 65 moveto
+484 65 547 65 591 65 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 591 69 moveto
+601 65 lineto
+591 62 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 591 69 moveto
+601 65 lineto
+591 62 lineto
+closepath
+stroke
+end grestore
+
+%	Goptions
+gsave 10 dict begin
+274 180 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+248 175 moveto
+(Goptions)
+[10.08 6.96 6.96 3.84 3.84 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Goptions -> Lib
+newpath 310 173 moveto
+331 169 356 164 377 160 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 378 163 moveto
+387 158 lineto
+377 157 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 378 163 moveto
+387 158 lineto
+377 157 lineto
+closepath
+stroke
+end grestore
+
+%	Dischargedhypsmap
+gsave 10 dict begin
+274 234 70 18 ellipse_path
+stroke
+gsave 10 dict begin
+217 229 moveto
+(Dischargedhypsmap)
+[10.08 3.84 5.52 6 6.96 6.24 4.32 6.72 6.24 6.96 6.48 6.96 6.96 5.52 10.8 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	Dischargedhypsmap -> Lib
+newpath 317 220 moveto
+326 216 336 212 344 207 curveto
+360 197 376 185 389 175 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 392 177 moveto
+397 168 lineto
+387 172 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 392 177 moveto
+397 168 lineto
+387 172 lineto
+closepath
+stroke
+end grestore
+
+%	Declare
+gsave 10 dict begin
+132 126 35 18 ellipse_path
+stroke
+gsave 10 dict begin
+109 121 moveto
+(Declare)
+[10.08 6.24 6.24 3.84 6.24 4.56 6.24]
+xshow
+end grestore
+end grestore
+
+%	Declare -> Impargs
+newpath 168 126 moveto
+186 126 208 126 228 126 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 228 130 moveto
+238 126 lineto
+228 123 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 228 130 moveto
+238 126 lineto
+228 123 lineto
+closepath
+stroke
+end grestore
+
+%	Declare -> Dischargedhypsmap
+newpath 144 143 moveto
+157 161 179 189 204 207 curveto
+209 210 215 213 221 216 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 219 219 moveto
+230 220 lineto
+222 213 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 219 219 moveto
+230 220 lineto
+222 213 lineto
+closepath
+stroke
+end grestore
+
+%	Decl_kinds
+gsave 10 dict begin
+274 72 45 18 ellipse_path
+stroke
+gsave 10 dict begin
+241 67 moveto
+(Decl_kinds)
+[10.08 6.24 6.24 3.84 6.96 6.96 3.84 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Declare -> Decl_kinds
+newpath 161 115 moveto
+181 107 209 97 232 88 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 233 91 moveto
+241 84 lineto
+230 85 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 233 91 moveto
+241 84 lineto
+230 85 lineto
+closepath
+stroke
+end grestore
+endpage
+showpage
+grestore
+%%PageTrailer
+%%EndPage: 1
+%%Trailer
+%%Pages: 1
+end
+restore
+%%EOF
diff --git a/dev/ocamlweb-doc/macros.tex b/dev/ocamlweb-doc/macros.tex
new file mode 100644
index 00000000..6beacf7b
--- /dev/null
+++ b/dev/ocamlweb-doc/macros.tex
@@ -0,0 +1,7 @@
+
+% macros for coq.tex
+
+\newcommand{\Coq}{\textsf{Coq}}
+\newcommand{\CCI}{Calculus of Inductive Constructions}
+
+\newcommand{\refsec}[1]{\textbf{\ref{#1}}}
\ No newline at end of file
diff --git a/dev/ocamlweb-doc/parse.ml b/dev/ocamlweb-doc/parse.ml
new file mode 100644
index 00000000..e537b1f2
--- /dev/null
+++ b/dev/ocamlweb-doc/parse.ml
@@ -0,0 +1,183 @@
+
+open Ast
+
+type assoc = L | R | N
+
+let level = function
+  | "--" -> 70,L
+  | "=" -> 70,N
+  | "+" -> 60,L
+  | "++" -> 60,R
+  | "+++" -> 60,R
+  | "-" -> 60,L
+  | "*" -> 50,L
+  | "/" -> 50,L
+  | "**" -> 40,R
+  | ":" -> (100,R)
+  | "->" -> (90,R)
+  | s -> failwith ("unknowm operator '"^s^"'")
+
+let fixity = function
+  | "--" -> [L]
+  | "=" -> [N]
+  | ("+"|"-"|"*"|"/") -> [L;N]
+  | "++" -> [R]
+  | _ -> [L;N;R]
+
+let ground_oper = function
+    ("-"|"+") -> true
+  | _ -> false
+
+let is_prefix op = List.mem L (fixity op)
+let is_infix op = List.mem N (fixity op)
+let is_postfix op = List.mem R (fixity op)
+
+let mk_inf op t1 t2 =
+  if not (is_infix op) then failwith (op^" not infix");
+  Infix(op,t1,t2)
+
+let mk_post op t =
+  if not (is_postfix op) then failwith (op^" not postfix");
+  Postfix(op,t)
+
+
+(* Pb avec ground_oper: pas de diff entre -1 et -(1) *)
+let mk_pre op t =
+  if not (is_prefix op) then failwith (op^" not prefix");
+  if ground_oper op then
+    match t with
+    | Int i -> Int (op^i)
+    | _     -> Prefix(op,t)
+  else Prefix(op,t)
+
+(* teste si on peut reduire op suivi d'un op de niveau (n,a)
+   si la reponse est false, c'est que l'op (n,a) doit se reduire
+   avant *)
+let red_left_op (nl,al) (nr,ar) =
+  if nl < nr then true
+  else
+    if nl = nr then
+      match al,ar with
+        | (L|N), L -> true
+        | R, (R|N) -> false
+        | R, L ->  failwith "conflit d'assoc: ambigu"
+        | (L|N), (R|N) -> failwith "conflit d'assoc: blocage"
+    else false
+
+
+type level = int * assoc
+type stack =
+  | PrefixOper of string list
+  | Term of constr_ast * stack
+  | Oper of string list * string * constr_ast * stack
+
+let rec str_ast = function
+  | Infix(op,t1,t2) -> str_ast t1 ^ " " ^ op ^ " " ^ str_ast t2
+  | Postfix(op,t) -> str_ast t ^ " " ^ op
+  | Prefix(op,t) -> op ^ " " ^ str_ast t
+  | _ -> "_"
+
+let rec str_stack = function
+  | PrefixOper ops -> String.concat " " (List.rev ops)
+  | Term (t,s) -> str_stack s ^ " (" ^ str_ast t ^ ")"
+  | Oper(ops,lop,t,s) ->
+      str_stack (Term(t,s)) ^ " " ^ lop ^ " " ^
+      String.concat " " (List.rev ops) 
+
+let pps s = prerr_endline (str_stack s)
+let err s stk = failwith (s^": "^str_stack stk)
+
+
+let empty = PrefixOper []
+
+let check_fixity_term stk =
+  match stk with
+      Term _ -> err "2 termes successifs" stk
+    | _ -> ()
+
+let shift_term t stk =
+  check_fixity_term stk;
+  Term(t,stk)
+
+let shift_oper op stk =
+  match stk with
+    | Oper(ops,lop,t,s) -> Oper(op::ops,lop,t,s)
+    | Term(t,s) -> Oper([],op,t,s)
+    | PrefixOper ops -> PrefixOper (op::ops)
+
+let is_reducible lv stk =
+  match stk with
+    | Oper([],iop,_,_)  -> red_left_op (level iop) lv
+    | Oper(op::_,_,_,_) -> red_left_op (level op) lv
+    | PrefixOper(op::_) -> red_left_op (level op) lv
+    | _                 -> false
+
+let reduce_head (t,stk) =
+  match stk with
+    | Oper([],iop,t1,s) ->
+        (Infix(iop,t1,t), s)
+    | Oper(op::ops,lop,t',s) ->
+        (mk_pre op t, Oper(ops,lop,t',s))
+    | PrefixOper(op::ops) ->
+        (Prefix(op,t), PrefixOper ops)
+    | _ -> assert false
+
+let rec reduce_level lv (t,s) =
+  if is_reducible lv s then reduce_level lv (reduce_head (t, s))
+  else (t, s)
+
+let reduce_post op (t,s) =
+  let (t',s') = reduce_level (level op) (t,s) in
+  (mk_post op t', s')
+
+let reduce_posts stk =
+  match stk with
+      Oper(ops,iop,t,s) ->
+        let pts1 = reduce_post iop (t,s) in
+        List.fold_right reduce_post ops pts1
+    | Term(t,s) -> (t,s)
+    | PrefixOper _ -> failwith "reduce_posts"
+
+
+let shift_infix op stk =
+  let (t,s) = reduce_level (level op) (reduce_posts stk) in
+  Oper([],op,t,s)
+
+let is_better_infix op stk =
+  match stk with
+    | Oper(ops,iop,t,s) ->
+        is_postfix iop &&
+        List.for_all is_postfix ops &&
+        (not (is_prefix op) || red_left_op (level iop) (level op))
+    | Term _ -> false
+    | _ -> assert false
+
+let parse_oper op stk =
+  match stk with
+    | PrefixOper _ ->
+        if is_prefix op then shift_oper op stk else failwith "prefix_oper"
+    | Oper _ ->
+        if is_infix op then
+          if is_better_infix op stk then shift_infix op stk
+          else shift_oper op stk
+        else if is_prefix op then shift_oper op stk
+        else if is_postfix op then
+          let (t,s) = reduce_post op (reduce_posts stk) in
+          Term(t,s)
+        else assert false
+    | Term(t,s) ->
+        if is_infix op then shift_infix op stk
+        else if is_postfix op then
+          let (t2,s2) = reduce_post op (t,s) in Term(t2,s2)
+        else failwith "infix/postfix"
+
+let parse_term = shift_term
+
+let rec close_stack stk =
+  match stk with
+      Term(t,PrefixOper []) -> t
+    | PrefixOper _ -> failwith "expression sans atomes"
+    | _ ->
+        let (t,s) = reduce_head (reduce_posts stk) in
+        close_stack (Term(t,s))
+
diff --git a/dev/ocamlweb-doc/parsing.dep.ps b/dev/ocamlweb-doc/parsing.dep.ps
new file mode 100644
index 00000000..723d8c69
--- /dev/null
+++ b/dev/ocamlweb-doc/parsing.dep.ps
@@ -0,0 +1,1115 @@
+%!PS-Adobe-2.0
+%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
+%%For: (herbelin) Hugo Herbelin
+%%Title: G
+%%Pages: (atend)
+%%BoundingBox: 35 35 577 314
+%%EndComments
+save
+%%BeginProlog
+/DotDict 200 dict def
+DotDict begin
+
+/setupLatin1 {
+mark
+/EncodingVector 256 array def
+ EncodingVector 0
+
+ISOLatin1Encoding 0 255 getinterval putinterval
+
+EncodingVector
+  dup 306 /AE
+  dup 301 /Aacute
+  dup 302 /Acircumflex
+  dup 304 /Adieresis
+  dup 300 /Agrave
+  dup 305 /Aring
+  dup 303 /Atilde
+  dup 307 /Ccedilla
+  dup 311 /Eacute
+  dup 312 /Ecircumflex
+  dup 313 /Edieresis
+  dup 310 /Egrave
+  dup 315 /Iacute
+  dup 316 /Icircumflex
+  dup 317 /Idieresis
+  dup 314 /Igrave
+  dup 334 /Udieresis
+  dup 335 /Yacute
+  dup 376 /thorn
+  dup 337 /germandbls
+  dup 341 /aacute
+  dup 342 /acircumflex
+  dup 344 /adieresis
+  dup 346 /ae
+  dup 340 /agrave
+  dup 345 /aring
+  dup 347 /ccedilla
+  dup 351 /eacute
+  dup 352 /ecircumflex
+  dup 353 /edieresis
+  dup 350 /egrave
+  dup 355 /iacute
+  dup 356 /icircumflex
+  dup 357 /idieresis
+  dup 354 /igrave
+  dup 360 /dcroat
+  dup 361 /ntilde
+  dup 363 /oacute
+  dup 364 /ocircumflex
+  dup 366 /odieresis
+  dup 362 /ograve
+  dup 365 /otilde
+  dup 370 /oslash
+  dup 372 /uacute
+  dup 373 /ucircumflex
+  dup 374 /udieresis
+  dup 371 /ugrave
+  dup 375 /yacute
+  dup 377 /ydieresis  
+
+% Set up ISO Latin 1 character encoding
+/starnetISO {
+        dup dup findfont dup length dict begin
+        { 1 index /FID ne { def }{ pop pop } ifelse
+        } forall
+        /Encoding EncodingVector def
+        currentdict end definefont
+} def
+/Times-Roman starnetISO def
+/Times-Italic starnetISO def
+/Times-Bold starnetISO def
+/Times-BoldItalic starnetISO def
+/Helvetica starnetISO def
+/Helvetica-Oblique starnetISO def
+/Helvetica-Bold starnetISO def
+/Helvetica-BoldOblique starnetISO def
+/Courier starnetISO def
+/Courier-Oblique starnetISO def
+/Courier-Bold starnetISO def
+/Courier-BoldOblique starnetISO def
+cleartomark
+} bind def
+
+%%BeginResource: procset graphviz 0 0
+/coord-font-family /Times-Roman def
+/default-font-family /Times-Roman def
+/coordfont coord-font-family findfont 8 scalefont def
+
+/InvScaleFactor 1.0 def
+/set_scale {
+	dup 1 exch div /InvScaleFactor exch def
+	dup scale
+} bind def
+
+% styles
+/solid { [] 0 setdash } bind def
+/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
+/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
+/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
+/bold { 2 setlinewidth } bind def
+/filled { } bind def
+/unfilled { } bind def
+/rounded { } bind def
+/diagonals { } bind def
+
+% hooks for setting color 
+/nodecolor { sethsbcolor } bind def
+/edgecolor { sethsbcolor } bind def
+/graphcolor { sethsbcolor } bind def
+/nopcolor {pop pop pop} bind def
+
+/beginpage {	% i j npages
+	/npages exch def
+	/j exch def
+	/i exch def
+	/str 10 string def
+	npages 1 gt {
+		gsave
+			coordfont setfont
+			0 0 moveto
+			(\() show i str cvs show (,) show j str cvs show (\)) show
+		grestore
+	} if
+} bind def
+
+/set_font {
+	findfont exch
+	scalefont setfont
+} def
+
+% draw aligned label in bounding box aligned to current point
+/alignedtext {			% width adj text
+	/text exch def
+	/adj exch def
+	/width exch def
+	gsave
+		width 0 gt {
+			text stringwidth pop adj mul 0 rmoveto
+		} if
+		[] 0 setdash
+		text show
+	grestore
+} def
+
+/boxprim {				% xcorner ycorner xsize ysize
+		4 2 roll
+		moveto
+		2 copy
+		exch 0 rlineto
+		0 exch rlineto
+		pop neg 0 rlineto
+		closepath
+} bind def
+
+/ellipse_path {
+	/ry exch def
+	/rx exch def
+	/y exch def
+	/x exch def
+	matrix currentmatrix
+	newpath
+	x y translate
+	rx ry scale
+	0 0 1 0 360 arc
+	setmatrix
+} bind def
+
+/endpage { showpage } bind def
+/showpage { } def
+
+/layercolorseq
+	[	% layer color sequence - darkest to lightest
+		[0 0 0]
+		[.2 .8 .8]
+		[.4 .8 .8]
+		[.6 .8 .8]
+		[.8 .8 .8]
+	]
+def
+
+/layerlen layercolorseq length def
+
+/setlayer {/maxlayer exch def /curlayer exch def
+	layercolorseq curlayer 1 sub layerlen mod get
+	aload pop sethsbcolor
+	/nodecolor {nopcolor} def
+	/edgecolor {nopcolor} def
+	/graphcolor {nopcolor} def
+} bind def
+
+/onlayer { curlayer ne {invis} if } def
+
+/onlayers {
+	/myupper exch def
+	/mylower exch def
+	curlayer mylower lt
+	curlayer myupper gt
+	or
+	{invis} if
+} def
+
+/curlayer 0 def
+
+%%EndResource
+%%EndProlog
+%%BeginSetup
+14 default-font-family set_font
+1 setmiterlimit
+% /arrowlength 10 def
+% /arrowwidth 5 def
+
+% make sure pdfmark is harmless for PS-interpreters other than Distiller
+/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
+% make '<<' and '>>' safe on PS Level 1 devices
+/languagelevel where {pop languagelevel}{1} ifelse
+2 lt {
+    userdict (<<) cvn ([) cvn load put
+    userdict (>>) cvn ([) cvn load put
+} if
+
+%%EndSetup
+%%Page: 1 1
+%%PageBoundingBox: 36 36 577 314
+%%PageOrientation: Portrait
+gsave
+35 35 542 279 boxprim clip newpath
+36 36 translate
+0 0 1 beginpage
+0.6027 set_scale
+0 0 translate 0 rotate
+0.000 0.000 0.000 graphcolor
+14.00 /Times-Roman set_font
+
+%	Pcoq
+gsave 10 dict begin
+557 280 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+543 275 moveto
+(Pcoq)
+[7.68 6.24 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Extend
+gsave 10 dict begin
+664 226 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+643 221 moveto
+(Extend)
+[8.4 6.96 3.84 6.24 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Pcoq -> Extend
+newpath 579 269 moveto
+593 261 613 252 630 243 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 632 246 moveto
+639 238 lineto
+629 240 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 632 246 moveto
+639 238 lineto
+629 240 lineto
+closepath
+stroke
+end grestore
+
+%	Ast
+gsave 10 dict begin
+764 172 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+753 167 moveto
+(Ast)
+[10.08 5.28 3.84]
+xshow
+end grestore
+end grestore
+
+%	Extend -> Ast
+newpath 688 213 moveto
+701 206 719 196 734 188 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 736 191 moveto
+743 183 lineto
+733 185 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 736 191 moveto
+743 183 lineto
+733 185 lineto
+closepath
+stroke
+end grestore
+
+%	Lexer
+gsave 10 dict begin
+764 226 29 18 ellipse_path
+stroke
+gsave 10 dict begin
+747 221 moveto
+(Lexer)
+[8.4 5.76 6.48 6.24 4.56]
+xshow
+end grestore
+end grestore
+
+%	Extend -> Lexer
+newpath 698 226 moveto
+706 226 715 226 724 226 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 724 230 moveto
+734 226 lineto
+724 223 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 724 230 moveto
+734 226 lineto
+724 223 lineto
+closepath
+stroke
+end grestore
+
+%	Termast
+gsave 10 dict begin
+557 172 35 18 ellipse_path
+stroke
+gsave 10 dict begin
+534 167 moveto
+(Termast)
+[7.2 6.24 4.8 10.8 6.24 5.28 3.84]
+xshow
+end grestore
+end grestore
+
+%	Termast -> Ast
+newpath 593 172 moveto
+630 172 689 172 727 172 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 727 176 moveto
+737 172 lineto
+727 169 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 727 176 moveto
+737 172 lineto
+727 169 lineto
+closepath
+stroke
+end grestore
+
+%	Coqast
+gsave 10 dict begin
+863 172 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+843 167 moveto
+(Coqast)
+[9.36 6.96 6.96 6.24 5.28 3.84]
+xshow
+end grestore
+end grestore
+
+%	Ast -> Coqast
+newpath 791 172 moveto
+800 172 810 172 820 172 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 820 176 moveto
+830 172 lineto
+820 169 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 820 176 moveto
+830 172 lineto
+820 169 lineto
+closepath
+stroke
+end grestore
+
+%	Tactic_printer
+gsave 10 dict begin
+53 126 52 18 ellipse_path
+stroke
+gsave 10 dict begin
+13 121 moveto
+(Tactic_printer)
+[7.44 6.24 6.24 3.84 3.84 6.24 6.96 6.96 4.8 3.84 6.96 3.84 6.24 4.56]
+xshow
+end grestore
+end grestore
+
+%	Pptactic
+gsave 10 dict begin
+178 126 36 18 ellipse_path
+stroke
+gsave 10 dict begin
+155 121 moveto
+(Pptactic)
+[7.68 6.96 4.08 6.24 6.24 3.84 3.84 6.24]
+xshow
+end grestore
+end grestore
+
+%	Tactic_printer -> Pptactic
+newpath 106 126 moveto
+114 126 123 126 132 126 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 132 130 moveto
+142 126 lineto
+132 123 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 132 130 moveto
+142 126 lineto
+132 123 lineto
+closepath
+stroke
+end grestore
+
+%	Printer
+gsave 10 dict begin
+289 72 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+269 67 moveto
+(Printer)
+[7.68 4.8 3.84 6.96 3.84 6.24 4.56]
+xshow
+end grestore
+end grestore
+
+%	Pptactic -> Printer
+newpath 204 113 moveto
+219 105 238 96 255 88 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 256 91 moveto
+264 84 lineto
+253 85 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 256 91 moveto
+264 84 lineto
+253 85 lineto
+closepath
+stroke
+end grestore
+
+%	Search
+gsave 10 dict begin
+178 72 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+159 67 moveto
+(Search)
+[7.68 6.24 6.24 4.56 6 6.96]
+xshow
+end grestore
+end grestore
+
+%	Search -> Printer
+newpath 210 72 moveto
+221 72 234 72 246 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 246 76 moveto
+256 72 lineto
+246 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 246 76 moveto
+256 72 lineto
+246 69 lineto
+closepath
+stroke
+end grestore
+
+%	Printer -> Termast
+newpath 316 62 moveto
+355 48 430 30 484 58 curveto
+518 77 538 117 548 144 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 545 146 moveto
+552 154 lineto
+552 143 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 545 146 moveto
+552 154 lineto
+552 143 lineto
+closepath
+stroke
+end grestore
+
+%	Esyntax
+gsave 10 dict begin
+557 226 36 18 ellipse_path
+stroke
+gsave 10 dict begin
+533 221 moveto
+(Esyntax)
+[8.4 5.52 6.96 6.96 4.08 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	Printer -> Esyntax
+newpath 322 71 moveto
+370 70 460 72 484 91 curveto
+489 95 516 193 520 197 curveto
+527 204 532 203 538 204 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 536 207 moveto
+547 208 lineto
+539 201 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 536 207 moveto
+547 208 lineto
+539 201 lineto
+closepath
+stroke
+end grestore
+
+%	Ppconstr
+gsave 10 dict begin
+424 388 37 18 ellipse_path
+stroke
+gsave 10 dict begin
+399 383 moveto
+(Ppconstr)
+[7.68 6.96 6.24 6.96 6.96 5.28 3.84 4.56]
+xshow
+end grestore
+end grestore
+
+%	Printer -> Ppconstr
+newpath 292 90 moveto
+300 147 329 319 364 361 curveto
+369 367 375 371 382 375 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 380 378 moveto
+391 379 lineto
+383 372 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 380 378 moveto
+391 379 lineto
+383 372 lineto
+closepath
+stroke
+end grestore
+
+%	Esyntax -> Extend
+newpath 594 226 moveto
+602 226 611 226 620 226 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 620 230 moveto
+630 226 lineto
+620 223 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 620 230 moveto
+630 226 lineto
+620 223 lineto
+closepath
+stroke
+end grestore
+
+%	Ppconstr -> Pcoq
+newpath 454 377 moveto
+464 373 475 368 484 361 curveto
+506 345 526 322 540 304 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 543 306 moveto
+546 296 lineto
+537 302 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 543 306 moveto
+546 296 lineto
+537 302 lineto
+closepath
+stroke
+end grestore
+
+%	Prettyp
+gsave 10 dict begin
+178 18 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+158 13 moveto
+(Prettyp)
+[7.68 4.56 6 3.84 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Prettyp -> Printer
+newpath 203 30 moveto
+218 38 238 47 255 55 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 254 58 moveto
+264 60 lineto
+257 52 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 254 58 moveto
+264 60 lineto
+257 52 lineto
+closepath
+stroke
+end grestore
+
+%	Printmod
+gsave 10 dict begin
+289 18 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+263 13 moveto
+(Printmod)
+[7.68 4.8 3.84 6.96 3.84 10.8 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Prettyp -> Printmod
+newpath 211 18 moveto
+220 18 230 18 240 18 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 240 22 moveto
+250 18 lineto
+240 15 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 240 22 moveto
+250 18 lineto
+240 15 lineto
+closepath
+stroke
+end grestore
+
+%	G_zsyntax
+gsave 10 dict begin
+424 172 43 18 ellipse_path
+stroke
+gsave 10 dict begin
+393 167 moveto
+(G_zsyntax)
+[10.08 6.96 6.24 5.52 6.96 6.96 4.08 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	G_zsyntax -> Pcoq
+newpath 458 183 moveto
+467 188 476 193 484 199 curveto
+507 218 501 233 520 253 curveto
+523 256 526 259 530 261 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 528 264 moveto
+538 267 lineto
+532 258 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 528 264 moveto
+538 267 lineto
+532 258 lineto
+closepath
+stroke
+end grestore
+
+%	G_zsyntax -> Termast
+newpath 468 172 moveto
+482 172 497 172 511 172 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 511 176 moveto
+521 172 lineto
+511 169 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 511 176 moveto
+521 172 lineto
+511 169 lineto
+closepath
+stroke
+end grestore
+
+%	G_zsyntax -> Esyntax
+newpath 455 185 moveto
+474 193 499 203 520 211 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 518 214 moveto
+529 215 lineto
+521 208 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 518 214 moveto
+529 215 lineto
+521 208 lineto
+closepath
+stroke
+end grestore
+
+%	G_string_syntax
+gsave 10 dict begin
+424 280 59 18 ellipse_path
+stroke
+gsave 10 dict begin
+377 275 moveto
+(G_string_syntax)
+[10.08 6.96 5.28 3.84 4.8 3.84 6.96 6.96 6.96 5.52 6.96 6.96 4.08 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	G_string_syntax -> Pcoq
+newpath 484 280 moveto
+496 280 509 280 520 280 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 520 284 moveto
+530 280 lineto
+520 277 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 520 284 moveto
+530 280 lineto
+520 277 lineto
+closepath
+stroke
+end grestore
+
+%	G_string_syntax -> Esyntax
+newpath 460 266 moveto
+478 258 501 249 520 242 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 521 245 moveto
+529 238 lineto
+518 239 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 521 245 moveto
+529 238 lineto
+518 239 lineto
+closepath
+stroke
+end grestore
+
+%	G_rsyntax
+gsave 10 dict begin
+424 118 42 18 ellipse_path
+stroke
+gsave 10 dict begin
+394 113 moveto
+(G_rsyntax)
+[10.08 6.96 4.56 5.52 6.96 6.96 4.08 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	G_rsyntax -> Pcoq
+newpath 459 128 moveto
+468 132 477 138 484 145 curveto
+518 183 491 213 520 253 curveto
+523 256 526 259 529 262 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 527 265 moveto
+537 268 lineto
+531 259 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 527 265 moveto
+537 268 lineto
+531 259 lineto
+closepath
+stroke
+end grestore
+
+%	G_rsyntax -> Termast
+newpath 455 131 moveto
+474 139 499 149 520 157 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 518 160 moveto
+529 161 lineto
+521 154 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 518 160 moveto
+529 161 lineto
+521 154 lineto
+closepath
+stroke
+end grestore
+
+%	G_rsyntax -> Esyntax
+newpath 457 129 moveto
+467 133 476 139 484 145 curveto
+507 164 501 179 520 199 curveto
+522 201 525 203 527 205 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 525 208 moveto
+535 212 lineto
+530 203 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 525 208 moveto
+535 212 lineto
+530 203 lineto
+closepath
+stroke
+end grestore
+
+%	G_natsyntax
+gsave 10 dict begin
+424 226 48 18 ellipse_path
+stroke
+gsave 10 dict begin
+388 221 moveto
+(G_natsyntax)
+[10.08 6.96 6.96 6.24 3.84 5.52 6.96 6.96 4.08 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	G_natsyntax -> Pcoq
+newpath 457 239 moveto
+478 248 504 259 525 266 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 523 269 moveto
+534 270 lineto
+526 263 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 523 269 moveto
+534 270 lineto
+526 263 lineto
+closepath
+stroke
+end grestore
+
+%	G_natsyntax -> Termast
+newpath 457 213 moveto
+476 205 500 195 520 187 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 521 190 moveto
+529 183 lineto
+518 184 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 521 190 moveto
+529 183 lineto
+518 184 lineto
+closepath
+stroke
+end grestore
+
+%	G_natsyntax -> Esyntax
+newpath 473 226 moveto
+485 226 498 226 510 226 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 510 230 moveto
+520 226 lineto
+510 223 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 510 230 moveto
+520 226 lineto
+510 223 lineto
+closepath
+stroke
+end grestore
+
+%	G_ascii_syntax
+gsave 10 dict begin
+424 334 56 18 ellipse_path
+stroke
+gsave 10 dict begin
+380 329 moveto
+(G_ascii_syntax)
+[10.08 6.96 6.24 5.52 6.24 3.84 3.84 6.96 5.52 6.96 6.96 4.08 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	G_ascii_syntax -> Pcoq
+newpath 459 320 moveto
+479 311 504 301 525 293 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 526 296 moveto
+534 289 lineto
+523 290 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 526 296 moveto
+534 289 lineto
+523 290 lineto
+closepath
+stroke
+end grestore
+
+%	G_ascii_syntax -> Esyntax
+newpath 462 321 moveto
+470 317 478 312 484 307 curveto
+507 288 501 273 520 253 curveto
+522 251 524 249 527 247 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 529 250 moveto
+535 241 lineto
+525 244 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 529 250 moveto
+535 241 lineto
+525 244 lineto
+closepath
+stroke
+end grestore
+
+%	Egrammar
+gsave 10 dict begin
+424 442 43 18 ellipse_path
+stroke
+gsave 10 dict begin
+394 437 moveto
+(Egrammar)
+[8.4 7.2 4.56 6.24 10.8 10.8 6.24 4.56]
+xshow
+end grestore
+end grestore
+
+%	Egrammar -> Pcoq
+newpath 458 431 moveto
+467 427 477 422 484 415 curveto
+516 385 537 337 548 308 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 551 309 moveto
+551 298 lineto
+545 307 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 551 309 moveto
+551 298 lineto
+545 307 lineto
+closepath
+stroke
+end grestore
+endpage
+showpage
+grestore
+%%PageTrailer
+%%EndPage: 1
+%%Trailer
+%%Pages: 1
+end
+restore
+%%EOF
diff --git a/dev/ocamlweb-doc/preamble.tex b/dev/ocamlweb-doc/preamble.tex
new file mode 100644
index 00000000..2cd21f02
--- /dev/null
+++ b/dev/ocamlweb-doc/preamble.tex
@@ -0,0 +1,8 @@
+\documentclass[11pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{ocamlweb}
+\pagestyle{ocamlweb}
+\usepackage{fullpage}
+\usepackage{epsfig}
+\begin{document}
diff --git a/dev/ocamlweb-doc/pretyping.dep.ps b/dev/ocamlweb-doc/pretyping.dep.ps
new file mode 100644
index 00000000..02d1b8b5
--- /dev/null
+++ b/dev/ocamlweb-doc/pretyping.dep.ps
@@ -0,0 +1,1259 @@
+%!PS-Adobe-2.0
+%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
+%%For: (herbelin) Hugo Herbelin
+%%Title: G
+%%Pages: (atend)
+%%BoundingBox: 35 35 577 146
+%%EndComments
+save
+%%BeginProlog
+/DotDict 200 dict def
+DotDict begin
+
+/setupLatin1 {
+mark
+/EncodingVector 256 array def
+ EncodingVector 0
+
+ISOLatin1Encoding 0 255 getinterval putinterval
+
+EncodingVector
+  dup 306 /AE
+  dup 301 /Aacute
+  dup 302 /Acircumflex
+  dup 304 /Adieresis
+  dup 300 /Agrave
+  dup 305 /Aring
+  dup 303 /Atilde
+  dup 307 /Ccedilla
+  dup 311 /Eacute
+  dup 312 /Ecircumflex
+  dup 313 /Edieresis
+  dup 310 /Egrave
+  dup 315 /Iacute
+  dup 316 /Icircumflex
+  dup 317 /Idieresis
+  dup 314 /Igrave
+  dup 334 /Udieresis
+  dup 335 /Yacute
+  dup 376 /thorn
+  dup 337 /germandbls
+  dup 341 /aacute
+  dup 342 /acircumflex
+  dup 344 /adieresis
+  dup 346 /ae
+  dup 340 /agrave
+  dup 345 /aring
+  dup 347 /ccedilla
+  dup 351 /eacute
+  dup 352 /ecircumflex
+  dup 353 /edieresis
+  dup 350 /egrave
+  dup 355 /iacute
+  dup 356 /icircumflex
+  dup 357 /idieresis
+  dup 354 /igrave
+  dup 360 /dcroat
+  dup 361 /ntilde
+  dup 363 /oacute
+  dup 364 /ocircumflex
+  dup 366 /odieresis
+  dup 362 /ograve
+  dup 365 /otilde
+  dup 370 /oslash
+  dup 372 /uacute
+  dup 373 /ucircumflex
+  dup 374 /udieresis
+  dup 371 /ugrave
+  dup 375 /yacute
+  dup 377 /ydieresis  
+
+% Set up ISO Latin 1 character encoding
+/starnetISO {
+        dup dup findfont dup length dict begin
+        { 1 index /FID ne { def }{ pop pop } ifelse
+        } forall
+        /Encoding EncodingVector def
+        currentdict end definefont
+} def
+/Times-Roman starnetISO def
+/Times-Italic starnetISO def
+/Times-Bold starnetISO def
+/Times-BoldItalic starnetISO def
+/Helvetica starnetISO def
+/Helvetica-Oblique starnetISO def
+/Helvetica-Bold starnetISO def
+/Helvetica-BoldOblique starnetISO def
+/Courier starnetISO def
+/Courier-Oblique starnetISO def
+/Courier-Bold starnetISO def
+/Courier-BoldOblique starnetISO def
+cleartomark
+} bind def
+
+%%BeginResource: procset graphviz 0 0
+/coord-font-family /Times-Roman def
+/default-font-family /Times-Roman def
+/coordfont coord-font-family findfont 8 scalefont def
+
+/InvScaleFactor 1.0 def
+/set_scale {
+	dup 1 exch div /InvScaleFactor exch def
+	dup scale
+} bind def
+
+% styles
+/solid { [] 0 setdash } bind def
+/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
+/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
+/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
+/bold { 2 setlinewidth } bind def
+/filled { } bind def
+/unfilled { } bind def
+/rounded { } bind def
+/diagonals { } bind def
+
+% hooks for setting color 
+/nodecolor { sethsbcolor } bind def
+/edgecolor { sethsbcolor } bind def
+/graphcolor { sethsbcolor } bind def
+/nopcolor {pop pop pop} bind def
+
+/beginpage {	% i j npages
+	/npages exch def
+	/j exch def
+	/i exch def
+	/str 10 string def
+	npages 1 gt {
+		gsave
+			coordfont setfont
+			0 0 moveto
+			(\() show i str cvs show (,) show j str cvs show (\)) show
+		grestore
+	} if
+} bind def
+
+/set_font {
+	findfont exch
+	scalefont setfont
+} def
+
+% draw aligned label in bounding box aligned to current point
+/alignedtext {			% width adj text
+	/text exch def
+	/adj exch def
+	/width exch def
+	gsave
+		width 0 gt {
+			text stringwidth pop adj mul 0 rmoveto
+		} if
+		[] 0 setdash
+		text show
+	grestore
+} def
+
+/boxprim {				% xcorner ycorner xsize ysize
+		4 2 roll
+		moveto
+		2 copy
+		exch 0 rlineto
+		0 exch rlineto
+		pop neg 0 rlineto
+		closepath
+} bind def
+
+/ellipse_path {
+	/ry exch def
+	/rx exch def
+	/y exch def
+	/x exch def
+	matrix currentmatrix
+	newpath
+	x y translate
+	rx ry scale
+	0 0 1 0 360 arc
+	setmatrix
+} bind def
+
+/endpage { showpage } bind def
+/showpage { } def
+
+/layercolorseq
+	[	% layer color sequence - darkest to lightest
+		[0 0 0]
+		[.2 .8 .8]
+		[.4 .8 .8]
+		[.6 .8 .8]
+		[.8 .8 .8]
+	]
+def
+
+/layerlen layercolorseq length def
+
+/setlayer {/maxlayer exch def /curlayer exch def
+	layercolorseq curlayer 1 sub layerlen mod get
+	aload pop sethsbcolor
+	/nodecolor {nopcolor} def
+	/edgecolor {nopcolor} def
+	/graphcolor {nopcolor} def
+} bind def
+
+/onlayer { curlayer ne {invis} if } def
+
+/onlayers {
+	/myupper exch def
+	/mylower exch def
+	curlayer mylower lt
+	curlayer myupper gt
+	or
+	{invis} if
+} def
+
+/curlayer 0 def
+
+%%EndResource
+%%EndProlog
+%%BeginSetup
+14 default-font-family set_font
+1 setmiterlimit
+% /arrowlength 10 def
+% /arrowwidth 5 def
+
+% make sure pdfmark is harmless for PS-interpreters other than Distiller
+/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
+% make '<<' and '>>' safe on PS Level 1 devices
+/languagelevel where {pop languagelevel}{1} ifelse
+2 lt {
+    userdict (<<) cvn ([) cvn load put
+    userdict (>>) cvn ([) cvn load put
+} if
+
+%%EndSetup
+%%Page: 1 1
+%%PageBoundingBox: 36 36 577 146
+%%PageOrientation: Portrait
+gsave
+35 35 542 111 boxprim clip newpath
+36 36 translate
+0 0 1 beginpage
+0.3600 set_scale
+0 0 translate 0 rotate
+0.000 0.000 0.000 graphcolor
+14.00 /Times-Roman set_font
+
+%	Unification
+gsave 10 dict begin
+610 118 45 18 ellipse_path
+stroke
+gsave 10 dict begin
+577 113 moveto
+(Unification)
+[9.6 6.96 3.84 4.8 3.84 6.24 6.24 3.84 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Evarutil
+gsave 10 dict begin
+728 72 36 18 ellipse_path
+stroke
+gsave 10 dict begin
+705 67 moveto
+(Evarutil)
+[8.4 6.72 6.24 4.8 6.96 3.84 3.84 3.84]
+xshow
+end grestore
+end grestore
+
+%	Unification -> Evarutil
+newpath 643 105 moveto
+657 99 674 93 689 87 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 691 90 moveto
+699 83 lineto
+688 83 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 691 90 moveto
+699 83 lineto
+688 83 lineto
+closepath
+stroke
+end grestore
+
+%	Pattern
+gsave 10 dict begin
+728 210 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+708 205 moveto
+(Pattern)
+[7.44 6.24 3.84 3.84 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	Unification -> Pattern
+newpath 631 134 moveto
+650 150 680 173 701 189 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 699 192 moveto
+709 195 lineto
+703 186 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 699 192 moveto
+709 195 lineto
+703 186 lineto
+closepath
+stroke
+end grestore
+
+%	Retyping
+gsave 10 dict begin
+839 118 38 18 ellipse_path
+stroke
+gsave 10 dict begin
+813 113 moveto
+(Retyping)
+[9.12 6 3.84 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Unification -> Retyping
+newpath 656 118 moveto
+695 118 750 118 790 118 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 790 122 moveto
+800 118 lineto
+790 115 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 790 122 moveto
+800 118 lineto
+790 115 lineto
+closepath
+stroke
+end grestore
+
+%	Typing
+gsave 10 dict begin
+839 64 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+819 59 moveto
+(Typing)
+[6.96 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Evarutil -> Typing
+newpath 764 69 moveto
+775 68 786 67 797 67 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 797 70 moveto
+807 66 lineto
+797 64 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 797 70 moveto
+807 66 lineto
+797 64 lineto
+closepath
+stroke
+end grestore
+
+%	Rawterm
+gsave 10 dict begin
+1109 110 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+1083 105 moveto
+(Rawterm)
+[9.36 5.76 10.08 3.84 6.24 4.8 10.8]
+xshow
+end grestore
+end grestore
+
+%	Pattern -> Rawterm
+newpath 759 216 moveto
+816 226 939 239 1024 191 curveto
+1049 176 1038 155 1060 138 curveto
+1069 131 1077 130 1084 129 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1085 132 moveto
+1094 127 lineto
+1084 126 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1085 132 moveto
+1094 127 lineto
+1084 126 lineto
+closepath
+stroke
+end grestore
+
+%	Inductiveops
+gsave 10 dict begin
+1109 164 49 18 ellipse_path
+stroke
+gsave 10 dict begin
+1073 159 moveto
+(Inductiveops)
+[4.56 6.96 6.96 6.96 6.24 3.84 3.84 6.48 6.24 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Retyping -> Inductiveops
+newpath 878 120 moveto
+915 122 974 126 1024 137 curveto
+1037 139 1051 144 1064 148 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1063 151 moveto
+1074 151 lineto
+1065 145 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1063 151 moveto
+1074 151 lineto
+1065 145 lineto
+closepath
+stroke
+end grestore
+
+%	Pretype_errors
+gsave 10 dict begin
+969 72 54 18 ellipse_path
+stroke
+gsave 10 dict begin
+927 67 moveto
+(Pretype_errors)
+[7.68 4.56 6 3.84 6.96 6.96 6.24 6.96 6.24 5.04 4.56 6.96 4.56 5.52]
+xshow
+end grestore
+end grestore
+
+%	Typing -> Pretype_errors
+newpath 871 66 moveto
+881 67 893 68 905 68 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 905 71 moveto
+915 69 lineto
+905 65 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 905 71 moveto
+915 69 lineto
+905 65 lineto
+closepath
+stroke
+end grestore
+
+%	Pretype_errors -> Inductiveops
+newpath 998 87 moveto
+1007 92 1016 98 1024 104 curveto
+1042 116 1043 124 1060 137 curveto
+1063 139 1067 142 1071 144 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1070 147 moveto
+1080 149 lineto
+1073 141 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1070 147 moveto
+1080 149 lineto
+1073 141 lineto
+closepath
+stroke
+end grestore
+
+%	Pretype_errors -> Rawterm
+newpath 1011 84 moveto
+1029 88 1048 94 1065 98 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1064 101 moveto
+1075 101 lineto
+1066 95 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1064 101 moveto
+1075 101 lineto
+1066 95 lineto
+closepath
+stroke
+end grestore
+
+%	Tacred
+gsave 10 dict begin
+728 18 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+709 13 moveto
+(Tacred)
+[7.44 6.24 6.24 4.56 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	Tacred -> Retyping
+newpath 748 32 moveto
+754 36 759 41 764 45 curveto
+783 63 782 73 800 91 curveto
+802 93 805 95 808 97 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 806 100 moveto
+816 103 lineto
+810 94 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 806 100 moveto
+816 103 lineto
+810 94 lineto
+closepath
+stroke
+end grestore
+
+%	Tacred -> Typing
+newpath 754 29 moveto
+769 35 787 43 803 49 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 802 53 moveto
+813 53 lineto
+805 46 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 802 53 moveto
+813 53 lineto
+805 46 lineto
+closepath
+stroke
+end grestore
+
+%	Cbv
+gsave 10 dict begin
+1246 41 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+1234 36 moveto
+(Cbv)
+[9.36 6.48 6.96]
+xshow
+end grestore
+end grestore
+
+%	Tacred -> Cbv
+newpath 760 19 moveto
+852 23 1111 35 1209 40 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1209 44 moveto
+1219 40 lineto
+1209 37 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1209 44 moveto
+1219 40 lineto
+1209 37 lineto
+closepath
+stroke
+end grestore
+
+%	Evd
+gsave 10 dict begin
+1361 110 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+1349 105 moveto
+(Evd)
+[8.4 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Cbv -> Evd
+newpath 1266 53 moveto
+1284 64 1312 80 1332 93 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1331 96 moveto
+1341 98 lineto
+1334 90 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1331 96 moveto
+1341 98 lineto
+1334 90 lineto
+closepath
+stroke
+end grestore
+
+%	Reductionops
+gsave 10 dict begin
+1246 164 51 18 ellipse_path
+stroke
+gsave 10 dict begin
+1207 159 moveto
+(Reductionops)
+[9.12 6.24 6.96 6.96 6.24 3.84 3.84 6.96 6.96 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Inductiveops -> Reductionops
+newpath 1158 164 moveto
+1167 164 1175 164 1184 164 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1184 168 moveto
+1194 164 lineto
+1184 161 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1184 168 moveto
+1194 164 lineto
+1184 161 lineto
+closepath
+stroke
+end grestore
+
+%	Reductionops -> Evd
+newpath 1277 150 moveto
+1294 142 1313 133 1330 125 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1331 128 moveto
+1339 121 lineto
+1328 122 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1331 128 moveto
+1339 121 lineto
+1328 122 lineto
+closepath
+stroke
+end grestore
+
+%	Termops
+gsave 10 dict begin
+1462 110 37 18 ellipse_path
+stroke
+gsave 10 dict begin
+1437 105 moveto
+(Termops)
+[7.2 6.24 4.8 10.8 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Evd -> Termops
+newpath 1388 110 moveto
+1396 110 1405 110 1414 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1414 114 moveto
+1424 110 lineto
+1414 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1414 114 moveto
+1424 110 lineto
+1414 107 lineto
+closepath
+stroke
+end grestore
+
+%	Recordops
+gsave 10 dict begin
+485 24 43 18 ellipse_path
+stroke
+gsave 10 dict begin
+455 19 moveto
+(Recordops)
+[9.12 6.24 6.24 6.96 4.32 6.96 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Classops
+gsave 10 dict begin
+610 20 38 18 ellipse_path
+stroke
+gsave 10 dict begin
+584 15 moveto
+(Classops)
+[9.36 3.84 6.24 5.52 5.52 6.96 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Recordops -> Classops
+newpath 528 23 moveto
+538 22 550 22 561 22 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 561 25 moveto
+571 21 lineto
+561 19 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 561 25 moveto
+571 21 lineto
+561 19 lineto
+closepath
+stroke
+end grestore
+
+%	Classops -> Tacred
+newpath 649 19 moveto
+661 19 674 19 686 19 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 686 23 moveto
+696 19 lineto
+686 16 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 686 23 moveto
+696 19 lineto
+686 16 lineto
+closepath
+stroke
+end grestore
+
+%	Rawterm -> Evd
+newpath 1148 110 moveto
+1196 110 1277 110 1324 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1324 114 moveto
+1334 110 lineto
+1324 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1324 114 moveto
+1334 110 lineto
+1324 107 lineto
+closepath
+stroke
+end grestore
+
+%	Pretyping
+gsave 10 dict begin
+40 183 40 18 ellipse_path
+stroke
+gsave 10 dict begin
+13 178 moveto
+(Pretyping)
+[7.68 4.56 6 3.84 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Pretyping -> Pattern
+newpath 78 189 moveto
+121 194 191 202 251 202 curveto
+251 202 251 202 485 202 curveto
+556 202 636 205 685 208 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 685 212 moveto
+695 208 lineto
+685 205 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 685 212 moveto
+695 208 lineto
+685 205 lineto
+closepath
+stroke
+end grestore
+
+%	Cases
+gsave 10 dict begin
+146 64 30 18 ellipse_path
+stroke
+gsave 10 dict begin
+129 59 moveto
+(Cases)
+[9.36 6.24 5.52 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Pretyping -> Cases
+newpath 53 166 moveto
+68 147 93 115 116 91 curveto
+118 89 119 88 121 86 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 124 88 moveto
+129 79 lineto
+119 83 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 124 88 moveto
+129 79 lineto
+119 83 lineto
+closepath
+stroke
+end grestore
+
+%	Detyping
+gsave 10 dict begin
+969 164 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+942 159 moveto
+(Detyping)
+[10.08 6 3.84 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Pretyping -> Detyping
+newpath 78 177 moveto
+121 172 191 164 251 164 curveto
+251 164 251 164 728 164 curveto
+794 164 870 164 919 164 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 919 168 moveto
+929 164 lineto
+919 161 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 919 168 moveto
+929 164 lineto
+919 161 lineto
+closepath
+stroke
+end grestore
+
+%	Indrec
+gsave 10 dict begin
+251 271 31 18 ellipse_path
+stroke
+gsave 10 dict begin
+233 266 moveto
+(Indrec)
+[4.56 6.96 6.96 4.56 6.24 6.24]
+xshow
+end grestore
+end grestore
+
+%	Pretyping -> Indrec
+newpath 69 195 moveto
+83 202 101 209 116 216 curveto
+150 230 188 246 216 257 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 214 260 moveto
+225 261 lineto
+217 254 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 214 260 moveto
+225 261 lineto
+217 254 lineto
+closepath
+stroke
+end grestore
+
+%	Coercion
+gsave 10 dict begin
+251 67 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+225 62 moveto
+(Coercion)
+[9.36 6.96 6.24 4.56 6.24 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Cases -> Coercion
+newpath 176 65 moveto
+184 65 193 66 202 66 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 202 70 moveto
+212 66 lineto
+202 63 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 202 70 moveto
+212 66 lineto
+202 63 lineto
+closepath
+stroke
+end grestore
+
+%	Detyping -> Inductiveops
+newpath 1009 164 moveto
+1022 164 1036 164 1050 164 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1050 168 moveto
+1060 164 lineto
+1050 161 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1050 168 moveto
+1060 164 lineto
+1050 161 lineto
+closepath
+stroke
+end grestore
+
+%	Detyping -> Rawterm
+newpath 999 152 moveto
+1020 144 1047 133 1069 125 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1070 128 moveto
+1079 122 lineto
+1068 122 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1070 128 moveto
+1079 122 lineto
+1068 122 lineto
+closepath
+stroke
+end grestore
+
+%	Indrec -> Inductiveops
+newpath 281 276 moveto
+325 283 412 294 485 294 curveto
+485 294 485 294 839 294 curveto
+937 294 1036 225 1082 188 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1085 190 moveto
+1090 181 lineto
+1080 185 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1085 190 moveto
+1090 181 lineto
+1080 185 lineto
+closepath
+stroke
+end grestore
+
+%	Matching
+gsave 10 dict begin
+610 248 40 18 ellipse_path
+stroke
+gsave 10 dict begin
+582 243 moveto
+(Matching)
+[12.48 6.24 3.84 6 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Matching -> Pattern
+newpath 643 237 moveto
+658 232 675 227 689 222 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 690 225 moveto
+699 219 lineto
+688 219 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 690 225 moveto
+699 219 lineto
+688 219 lineto
+closepath
+stroke
+end grestore
+
+%	Matching -> Reductionops
+newpath 650 250 moveto
+696 253 773 256 839 256 curveto
+839 256 839 256 969 256 curveto
+1059 256 1159 212 1210 184 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1212 187 moveto
+1219 179 lineto
+1209 181 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1212 187 moveto
+1219 179 lineto
+1209 181 lineto
+closepath
+stroke
+end grestore
+
+%	Evarconv
+gsave 10 dict begin
+366 67 40 18 ellipse_path
+stroke
+gsave 10 dict begin
+339 62 moveto
+(Evarconv)
+[8.4 6.72 6.24 4.56 6.24 6.96 6.48 6.96]
+xshow
+end grestore
+end grestore
+
+%	Evarconv -> Evarutil
+newpath 406 68 moveto
+474 69 610 71 682 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 682 76 moveto
+692 72 lineto
+682 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 682 76 moveto
+692 72 lineto
+682 69 lineto
+closepath
+stroke
+end grestore
+
+%	Evarconv -> Recordops
+newpath 397 56 moveto
+411 51 428 45 442 39 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 443 42 moveto
+452 36 lineto
+441 36 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 443 42 moveto
+452 36 lineto
+441 36 lineto
+closepath
+stroke
+end grestore
+
+%	Coercion -> Evarconv
+newpath 290 67 moveto
+299 67 307 67 316 67 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 316 71 moveto
+326 67 lineto
+316 64 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 316 71 moveto
+326 67 lineto
+316 64 lineto
+closepath
+stroke
+end grestore
+
+%	Clenv
+gsave 10 dict begin
+146 118 30 18 ellipse_path
+stroke
+gsave 10 dict begin
+129 113 moveto
+(Clenv)
+[9.36 3.84 6.24 6.48 6.96]
+xshow
+end grestore
+end grestore
+
+%	Clenv -> Unification
+newpath 176 118 moveto
+252 118 455 118 554 118 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 554 122 moveto
+564 118 lineto
+554 115 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 554 122 moveto
+564 118 lineto
+554 115 lineto
+closepath
+stroke
+end grestore
+
+%	Clenv -> Coercion
+newpath 170 107 moveto
+183 100 200 93 215 85 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 217 88 moveto
+224 80 lineto
+214 82 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 217 88 moveto
+224 80 lineto
+214 82 lineto
+closepath
+stroke
+end grestore
+endpage
+showpage
+grestore
+%%PageTrailer
+%%EndPage: 1
+%%Trailer
+%%Pages: 1
+end
+restore
+%%EOF
diff --git a/dev/ocamlweb-doc/proofs.dep.ps b/dev/ocamlweb-doc/proofs.dep.ps
new file mode 100644
index 00000000..0e78f422
--- /dev/null
+++ b/dev/ocamlweb-doc/proofs.dep.ps
@@ -0,0 +1,638 @@
+%!PS-Adobe-2.0
+%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
+%%For: (herbelin) Hugo Herbelin
+%%Title: G
+%%Pages: (atend)
+%%BoundingBox: 35 35 577 136
+%%EndComments
+save
+%%BeginProlog
+/DotDict 200 dict def
+DotDict begin
+
+/setupLatin1 {
+mark
+/EncodingVector 256 array def
+ EncodingVector 0
+
+ISOLatin1Encoding 0 255 getinterval putinterval
+
+EncodingVector
+  dup 306 /AE
+  dup 301 /Aacute
+  dup 302 /Acircumflex
+  dup 304 /Adieresis
+  dup 300 /Agrave
+  dup 305 /Aring
+  dup 303 /Atilde
+  dup 307 /Ccedilla
+  dup 311 /Eacute
+  dup 312 /Ecircumflex
+  dup 313 /Edieresis
+  dup 310 /Egrave
+  dup 315 /Iacute
+  dup 316 /Icircumflex
+  dup 317 /Idieresis
+  dup 314 /Igrave
+  dup 334 /Udieresis
+  dup 335 /Yacute
+  dup 376 /thorn
+  dup 337 /germandbls
+  dup 341 /aacute
+  dup 342 /acircumflex
+  dup 344 /adieresis
+  dup 346 /ae
+  dup 340 /agrave
+  dup 345 /aring
+  dup 347 /ccedilla
+  dup 351 /eacute
+  dup 352 /ecircumflex
+  dup 353 /edieresis
+  dup 350 /egrave
+  dup 355 /iacute
+  dup 356 /icircumflex
+  dup 357 /idieresis
+  dup 354 /igrave
+  dup 360 /dcroat
+  dup 361 /ntilde
+  dup 363 /oacute
+  dup 364 /ocircumflex
+  dup 366 /odieresis
+  dup 362 /ograve
+  dup 365 /otilde
+  dup 370 /oslash
+  dup 372 /uacute
+  dup 373 /ucircumflex
+  dup 374 /udieresis
+  dup 371 /ugrave
+  dup 375 /yacute
+  dup 377 /ydieresis  
+
+% Set up ISO Latin 1 character encoding
+/starnetISO {
+        dup dup findfont dup length dict begin
+        { 1 index /FID ne { def }{ pop pop } ifelse
+        } forall
+        /Encoding EncodingVector def
+        currentdict end definefont
+} def
+/Times-Roman starnetISO def
+/Times-Italic starnetISO def
+/Times-Bold starnetISO def
+/Times-BoldItalic starnetISO def
+/Helvetica starnetISO def
+/Helvetica-Oblique starnetISO def
+/Helvetica-Bold starnetISO def
+/Helvetica-BoldOblique starnetISO def
+/Courier starnetISO def
+/Courier-Oblique starnetISO def
+/Courier-Bold starnetISO def
+/Courier-BoldOblique starnetISO def
+cleartomark
+} bind def
+
+%%BeginResource: procset graphviz 0 0
+/coord-font-family /Times-Roman def
+/default-font-family /Times-Roman def
+/coordfont coord-font-family findfont 8 scalefont def
+
+/InvScaleFactor 1.0 def
+/set_scale {
+	dup 1 exch div /InvScaleFactor exch def
+	dup scale
+} bind def
+
+% styles
+/solid { [] 0 setdash } bind def
+/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
+/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
+/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
+/bold { 2 setlinewidth } bind def
+/filled { } bind def
+/unfilled { } bind def
+/rounded { } bind def
+/diagonals { } bind def
+
+% hooks for setting color 
+/nodecolor { sethsbcolor } bind def
+/edgecolor { sethsbcolor } bind def
+/graphcolor { sethsbcolor } bind def
+/nopcolor {pop pop pop} bind def
+
+/beginpage {	% i j npages
+	/npages exch def
+	/j exch def
+	/i exch def
+	/str 10 string def
+	npages 1 gt {
+		gsave
+			coordfont setfont
+			0 0 moveto
+			(\() show i str cvs show (,) show j str cvs show (\)) show
+		grestore
+	} if
+} bind def
+
+/set_font {
+	findfont exch
+	scalefont setfont
+} def
+
+% draw aligned label in bounding box aligned to current point
+/alignedtext {			% width adj text
+	/text exch def
+	/adj exch def
+	/width exch def
+	gsave
+		width 0 gt {
+			text stringwidth pop adj mul 0 rmoveto
+		} if
+		[] 0 setdash
+		text show
+	grestore
+} def
+
+/boxprim {				% xcorner ycorner xsize ysize
+		4 2 roll
+		moveto
+		2 copy
+		exch 0 rlineto
+		0 exch rlineto
+		pop neg 0 rlineto
+		closepath
+} bind def
+
+/ellipse_path {
+	/ry exch def
+	/rx exch def
+	/y exch def
+	/x exch def
+	matrix currentmatrix
+	newpath
+	x y translate
+	rx ry scale
+	0 0 1 0 360 arc
+	setmatrix
+} bind def
+
+/endpage { showpage } bind def
+/showpage { } def
+
+/layercolorseq
+	[	% layer color sequence - darkest to lightest
+		[0 0 0]
+		[.2 .8 .8]
+		[.4 .8 .8]
+		[.6 .8 .8]
+		[.8 .8 .8]
+	]
+def
+
+/layerlen layercolorseq length def
+
+/setlayer {/maxlayer exch def /curlayer exch def
+	layercolorseq curlayer 1 sub layerlen mod get
+	aload pop sethsbcolor
+	/nodecolor {nopcolor} def
+	/edgecolor {nopcolor} def
+	/graphcolor {nopcolor} def
+} bind def
+
+/onlayer { curlayer ne {invis} if } def
+
+/onlayers {
+	/myupper exch def
+	/mylower exch def
+	curlayer mylower lt
+	curlayer myupper gt
+	or
+	{invis} if
+} def
+
+/curlayer 0 def
+
+%%EndResource
+%%EndProlog
+%%BeginSetup
+14 default-font-family set_font
+1 setmiterlimit
+% /arrowlength 10 def
+% /arrowwidth 5 def
+
+% make sure pdfmark is harmless for PS-interpreters other than Distiller
+/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
+% make '<<' and '>>' safe on PS Level 1 devices
+/languagelevel where {pop languagelevel}{1} ifelse
+2 lt {
+    userdict (<<) cvn ([) cvn load put
+    userdict (>>) cvn ([) cvn load put
+} if
+
+%%EndSetup
+%%Page: 1 1
+%%PageBoundingBox: 36 36 577 136
+%%PageOrientation: Portrait
+gsave
+35 35 542 101 boxprim clip newpath
+36 36 translate
+0 0 1 beginpage
+0.6923 set_scale
+0 0 translate 0 rotate
+0.000 0.000 0.000 graphcolor
+14.00 /Times-Roman set_font
+
+%	Tactic_debug
+gsave 10 dict begin
+163 72 51 18 ellipse_path
+stroke
+gsave 10 dict begin
+125 67 moveto
+(Tactic_debug)
+[7.44 6.24 6.24 3.84 3.84 6.24 6.96 6.96 6.24 6.96 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Refiner
+gsave 10 dict begin
+287 72 34 18 ellipse_path
+stroke
+gsave 10 dict begin
+266 67 moveto
+(Refiner)
+[9.12 6.24 4.8 3.84 6.96 6.24 4.56]
+xshow
+end grestore
+end grestore
+
+%	Tactic_debug -> Refiner
+newpath 214 72 moveto
+223 72 233 72 243 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 243 76 moveto
+253 72 lineto
+243 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 243 76 moveto
+253 72 lineto
+243 69 lineto
+closepath
+stroke
+end grestore
+
+%	Logic
+gsave 10 dict begin
+390 72 30 18 ellipse_path
+stroke
+gsave 10 dict begin
+373 67 moveto
+(Logic)
+[8.4 6.96 6.96 3.84 6.24]
+xshow
+end grestore
+end grestore
+
+%	Refiner -> Logic
+newpath 321 72 moveto
+330 72 340 72 350 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 350 76 moveto
+360 72 lineto
+350 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 350 76 moveto
+360 72 lineto
+350 69 lineto
+closepath
+stroke
+end grestore
+
+%	Tacmach
+gsave 10 dict begin
+163 126 38 18 ellipse_path
+stroke
+gsave 10 dict begin
+137 121 moveto
+(Tacmach)
+[7.44 6.24 6.24 10.8 6.24 6 6.96]
+xshow
+end grestore
+end grestore
+
+%	Tacmach -> Refiner
+newpath 191 114 moveto
+209 106 232 96 251 88 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 253 91 moveto
+261 84 lineto
+250 84 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 253 91 moveto
+261 84 lineto
+250 84 lineto
+closepath
+stroke
+end grestore
+
+%	Redexpr
+gsave 10 dict begin
+287 126 36 18 ellipse_path
+stroke
+gsave 10 dict begin
+263 121 moveto
+(Redexpr)
+[9.12 6.24 6.96 5.76 6.96 6.96 4.56]
+xshow
+end grestore
+end grestore
+
+%	Tacmach -> Redexpr
+newpath 202 126 moveto
+214 126 227 126 240 126 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 240 130 moveto
+250 126 lineto
+240 123 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 240 130 moveto
+250 126 lineto
+240 123 lineto
+closepath
+stroke
+end grestore
+
+%	Proof_trees
+gsave 10 dict begin
+502 72 45 18 ellipse_path
+stroke
+gsave 10 dict begin
+469 67 moveto
+(Proof_trees)
+[7.68 4.56 6.96 6.96 4.56 6.96 3.84 4.56 6.24 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Logic -> Proof_trees
+newpath 420 72 moveto
+428 72 437 72 446 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 446 76 moveto
+456 72 lineto
+446 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 446 76 moveto
+456 72 lineto
+446 69 lineto
+closepath
+stroke
+end grestore
+
+%	Proof_type
+gsave 10 dict begin
+628 72 44 18 ellipse_path
+stroke
+gsave 10 dict begin
+597 67 moveto
+(Proof_type)
+[7.68 4.56 6.96 6.96 4.56 6.96 3.84 6.96 6.96 6.24]
+xshow
+end grestore
+end grestore
+
+%	Tacexpr
+gsave 10 dict begin
+744 72 35 18 ellipse_path
+stroke
+gsave 10 dict begin
+721 67 moveto
+(Tacexpr)
+[7.44 6.24 6.24 5.76 6.96 6.96 4.56]
+xshow
+end grestore
+end grestore
+
+%	Proof_type -> Tacexpr
+newpath 672 72 moveto
+680 72 689 72 698 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 698 76 moveto
+708 72 lineto
+698 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 698 76 moveto
+708 72 lineto
+698 69 lineto
+closepath
+stroke
+end grestore
+
+%	Proof_trees -> Proof_type
+newpath 548 72 moveto
+557 72 565 72 574 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 574 76 moveto
+584 72 lineto
+574 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 574 76 moveto
+584 72 lineto
+574 69 lineto
+closepath
+stroke
+end grestore
+
+%	Pfedit
+gsave 10 dict begin
+38 112 29 18 ellipse_path
+stroke
+gsave 10 dict begin
+21 107 moveto
+(Pfedit)
+[7.68 4.08 6.24 6.96 3.84 3.84]
+xshow
+end grestore
+end grestore
+
+%	Pfedit -> Tacmach
+newpath 67 115 moveto
+81 117 99 118 115 120 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 115 123 moveto
+125 122 lineto
+116 117 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 115 123 moveto
+125 122 lineto
+116 117 lineto
+closepath
+stroke
+end grestore
+
+%	Evar_refiner
+gsave 10 dict begin
+163 18 49 18 ellipse_path
+stroke
+gsave 10 dict begin
+127 13 moveto
+(Evar_refiner)
+[8.4 6.72 6.24 4.56 6.96 4.56 6.24 4.8 3.84 6.96 6.24 4.56]
+xshow
+end grestore
+end grestore
+
+%	Pfedit -> Evar_refiner
+newpath 53 96 moveto
+67 82 90 60 112 45 curveto
+116 42 120 40 124 37 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 126 40 moveto
+133 32 lineto
+123 34 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 126 40 moveto
+133 32 lineto
+123 34 lineto
+closepath
+stroke
+end grestore
+
+%	Evar_refiner -> Refiner
+newpath 195 32 moveto
+212 40 233 49 251 57 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 249 60 moveto
+260 61 lineto
+252 54 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 249 60 moveto
+260 61 lineto
+252 54 lineto
+closepath
+stroke
+end grestore
+
+%	Clenvtac
+gsave 10 dict begin
+38 45 38 18 ellipse_path
+stroke
+gsave 10 dict begin
+13 40 moveto
+(Clenvtac)
+[9.36 3.84 6.24 6.48 6.96 4.08 6.24 6.24]
+xshow
+end grestore
+end grestore
+
+%	Clenvtac -> Tacmach
+newpath 58 61 moveto
+73 72 93 87 112 99 curveto
+117 102 123 105 128 108 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 127 111 moveto
+137 113 lineto
+130 105 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 127 111 moveto
+137 113 lineto
+130 105 lineto
+closepath
+stroke
+end grestore
+
+%	Clenvtac -> Evar_refiner
+newpath 73 37 moveto
+85 35 98 32 110 29 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 111 32 moveto
+120 27 lineto
+110 26 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 111 32 moveto
+120 27 lineto
+110 26 lineto
+closepath
+stroke
+end grestore
+endpage
+showpage
+grestore
+%%PageTrailer
+%%EndPage: 1
+%%Trailer
+%%Pages: 1
+end
+restore
+%%EOF
diff --git a/dev/ocamlweb-doc/syntax.mly b/dev/ocamlweb-doc/syntax.mly
new file mode 100644
index 00000000..bfc7d5cc
--- /dev/null
+++ b/dev/ocamlweb-doc/syntax.mly
@@ -0,0 +1,224 @@
+%{
+open Ast
+open Parse
+%}
+
+%token <string> META INT IDENT
+%token <string> OPER
+%token LPAR RPAR BAR COMMA COLON BANG FUN DOT RARROW LET COLONEQ IN IF
+%token THEN ELSE EVAL AT FOR PROP SET TYPE WILDCARD FIX
+%token COFIX MATCH WITH END AND LBRACE RBRACE STRUCT AS SIMPL PERCENT
+%token EOF
+
+%start main
+%type <Ast.constr_ast> main
+
+%start constr
+%type <Ast.constr_ast> constr
+
+%start simple_constr
+%type <Ast.constr_ast> simple_constr
+
+%%
+
+main:
+          constr EOF { $1 }
+;
+
+
+paren_constr:
+          constr COMMA paren_constr  { Pair($1,$3) }
+        | constr                     { $1 }
+;
+
+constr:
+          binder_constr  { $1 }
+        | oper_constr    { close_stack $1 }
+;
+
+binder_constr:
+          BANG ne_binders DOT constr              { Prod($2, $4) }
+        | FUN ne_binders type_cstr RARROW constr  { Lambda($2,mk_cast $5 $3) }
+        | LET IDENT binders type_cstr COLONEQ constr IN constr
+            { Let($2,mk_lambda $3 (mk_cast $6 $4),$8) }
+        | LET LPAR comma_binders RPAR COLONEQ constr IN constr
+            { LetCase($3,$6,$8) }
+        | IF constr THEN constr ELSE constr       { IfCase($2,$4,$6) }
+        | fix_constr                              { $1 }
+        | EVAL rfun IN constr                     { Eval($2,$4) }
+;
+
+comma_binders:
+          ne_comma_binders  { $1 }
+        |                   { [] }
+;
+
+ne_comma_binders:
+          binder COMMA ne_comma_binders  { $1 :: $3 }
+        | binder                         { [$1] }
+;
+
+rfun:
+          SIMPL  { Simpl }
+;
+
+
+/* 2 Conflits shift/reduce */
+oper_constr:
+          oper_constr oper appl_constr
+            { parse_term $3 (parse_oper $2 $1) }
+        | oper_constr oper binder_constr
+            { parse_term $3 (parse_oper $2 $1) }
+        | oper_constr oper  { parse_oper $2 $1 }
+        |                   { empty }
+        | appl_constr       { parse_term $1 empty }
+;
+
+oper:
+          OPER {$1}
+        | COLON {":"}
+;
+
+appl_constr:
+          simple_constr ne_appl_args  { Appl($1,$2) }
+        | AT global simple_constrs    { ApplExpl($2,$3) }
+        | simple_constr               { $1 }
+;
+
+appl_arg:
+          AT INT COLONEQ simple_constr  { (Some $2,$4) }
+        | simple_constr                 { (None,$1) }
+;
+
+ne_appl_args:
+          appl_arg               { [$1] }
+        | appl_arg ne_appl_args  { $1::$2 }
+;
+
+simple_constr:
+          atomic_constr                           { $1 }
+        | match_constr                            { $1 }
+        | LPAR paren_constr RPAR                  { $2 }
+        | simple_constr PERCENT IDENT { Scope($3,$1) }
+;
+
+simple_constrs:
+          simple_constr simple_constrs  { $1::$2 }
+        |                               { [] }
+;
+
+atomic_constr:
+          global    { Qualid $1 }
+        | PROP      { Prop }
+        | SET       { Set }
+        | TYPE      { Type }
+        | INT       { Int $1 }
+        | WILDCARD  { Hole }
+        | META      { Meta $1 }
+;
+
+global:
+          IDENT DOT global  { $1 :: $3 }
+        | IDENT             { [$1] }
+;
+
+/* Conflit normal */
+fix_constr:
+          fix_kw fix_decl
+            { let (id,_,_,_,_ as fx) = $2 in Fixp($1,[fx],id) }
+        | fix_kw fix_decl fix_decls FOR IDENT  { Fixp($1, $2::$3, $5) }
+;
+
+fix_kw: FIX {Fix} | COFIX {CoFix}
+;
+
+fix_decl:
+          IDENT binders type_cstr annot COLONEQ constr  { ($1,$2,$3,$4,$6) }
+;
+
+fix_decls:
+          AND fix_decl fix_decls  { $2::$3 }
+        | AND fix_decl            { [$2] }
+;
+
+annot:
+          LBRACE STRUCT IDENT RBRACE  { Some $3 }
+        |                             { None }
+;
+
+match_constr:
+          MATCH case_items case_type WITH branches END  { Match($2,$3,$5) }
+;
+
+case_items:
+          case_item                   { [$1] }
+        | case_item COMMA case_items  { $1::$3 }
+;
+
+case_item:
+          constr pred_pattern { ($1,$2) }
+;
+
+case_type:
+          RARROW constr  { Some $2 }
+        |                { None }
+;
+
+pred_pattern:
+          AS IDENT COLON constr  { (Some $2, Some $4) }
+        | AS IDENT               { (Some $2, None) }
+        | COLON constr           { (None, Some $2) }
+        |                        { (None,None) }
+;
+
+branches:
+          BAR branch_list  { $2 }
+        | branch_list      { $1 }
+        |                  { [] }
+;
+
+branch_list:
+          patterns RARROW constr                  { [$1, $3] }
+        | patterns RARROW constr BAR branch_list  { ($1,$3)::$5 }
+;
+
+patterns:
+          pattern                 { [$1] }
+        | pattern COMMA patterns  { $1::$3 }
+;
+
+pattern:
+          pattern AS IDENT       { PatAs($1,$3) }
+        | pattern COLON constr   { PatType($1,$3) }
+        | IDENT simple_patterns  { PatConstr($1,$2) }
+        | simple_pattern         { $1 }
+;
+
+simple_pattern:
+          IDENT              { PatVar $1 }
+        | LPAR pattern RPAR  { $2 }
+;
+
+simple_patterns:
+          simple_pattern                  { [$1] }
+        | simple_pattern simple_patterns  { $1::$2 }
+;
+
+binder:
+          IDENT                 { ($1,Hole) }
+        | LPAR IDENT type_cstr RPAR  { ($2,$3) }
+;
+
+binders:
+          ne_binders  { $1 }
+        |             { [] }
+
+ne_binders:
+          binder             { [$1] }
+        | binder ne_binders  { $1::$2 }
+;
+
+type_cstr:
+          COLON constr  { $2 }
+        |               { Hole }
+;
diff --git a/dev/ocamlweb-doc/tactics.dep.ps b/dev/ocamlweb-doc/tactics.dep.ps
new file mode 100644
index 00000000..f4de22b7
--- /dev/null
+++ b/dev/ocamlweb-doc/tactics.dep.ps
@@ -0,0 +1,991 @@
+%!PS-Adobe-2.0
+%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
+%%For: (herbelin) Hugo Herbelin
+%%Title: G
+%%Pages: (atend)
+%%BoundingBox: 35 35 577 165
+%%EndComments
+save
+%%BeginProlog
+/DotDict 200 dict def
+DotDict begin
+
+/setupLatin1 {
+mark
+/EncodingVector 256 array def
+ EncodingVector 0
+
+ISOLatin1Encoding 0 255 getinterval putinterval
+
+EncodingVector
+  dup 306 /AE
+  dup 301 /Aacute
+  dup 302 /Acircumflex
+  dup 304 /Adieresis
+  dup 300 /Agrave
+  dup 305 /Aring
+  dup 303 /Atilde
+  dup 307 /Ccedilla
+  dup 311 /Eacute
+  dup 312 /Ecircumflex
+  dup 313 /Edieresis
+  dup 310 /Egrave
+  dup 315 /Iacute
+  dup 316 /Icircumflex
+  dup 317 /Idieresis
+  dup 314 /Igrave
+  dup 334 /Udieresis
+  dup 335 /Yacute
+  dup 376 /thorn
+  dup 337 /germandbls
+  dup 341 /aacute
+  dup 342 /acircumflex
+  dup 344 /adieresis
+  dup 346 /ae
+  dup 340 /agrave
+  dup 345 /aring
+  dup 347 /ccedilla
+  dup 351 /eacute
+  dup 352 /ecircumflex
+  dup 353 /edieresis
+  dup 350 /egrave
+  dup 355 /iacute
+  dup 356 /icircumflex
+  dup 357 /idieresis
+  dup 354 /igrave
+  dup 360 /dcroat
+  dup 361 /ntilde
+  dup 363 /oacute
+  dup 364 /ocircumflex
+  dup 366 /odieresis
+  dup 362 /ograve
+  dup 365 /otilde
+  dup 370 /oslash
+  dup 372 /uacute
+  dup 373 /ucircumflex
+  dup 374 /udieresis
+  dup 371 /ugrave
+  dup 375 /yacute
+  dup 377 /ydieresis  
+
+% Set up ISO Latin 1 character encoding
+/starnetISO {
+        dup dup findfont dup length dict begin
+        { 1 index /FID ne { def }{ pop pop } ifelse
+        } forall
+        /Encoding EncodingVector def
+        currentdict end definefont
+} def
+/Times-Roman starnetISO def
+/Times-Italic starnetISO def
+/Times-Bold starnetISO def
+/Times-BoldItalic starnetISO def
+/Helvetica starnetISO def
+/Helvetica-Oblique starnetISO def
+/Helvetica-Bold starnetISO def
+/Helvetica-BoldOblique starnetISO def
+/Courier starnetISO def
+/Courier-Oblique starnetISO def
+/Courier-Bold starnetISO def
+/Courier-BoldOblique starnetISO def
+cleartomark
+} bind def
+
+%%BeginResource: procset graphviz 0 0
+/coord-font-family /Times-Roman def
+/default-font-family /Times-Roman def
+/coordfont coord-font-family findfont 8 scalefont def
+
+/InvScaleFactor 1.0 def
+/set_scale {
+	dup 1 exch div /InvScaleFactor exch def
+	dup scale
+} bind def
+
+% styles
+/solid { [] 0 setdash } bind def
+/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
+/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
+/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
+/bold { 2 setlinewidth } bind def
+/filled { } bind def
+/unfilled { } bind def
+/rounded { } bind def
+/diagonals { } bind def
+
+% hooks for setting color 
+/nodecolor { sethsbcolor } bind def
+/edgecolor { sethsbcolor } bind def
+/graphcolor { sethsbcolor } bind def
+/nopcolor {pop pop pop} bind def
+
+/beginpage {	% i j npages
+	/npages exch def
+	/j exch def
+	/i exch def
+	/str 10 string def
+	npages 1 gt {
+		gsave
+			coordfont setfont
+			0 0 moveto
+			(\() show i str cvs show (,) show j str cvs show (\)) show
+		grestore
+	} if
+} bind def
+
+/set_font {
+	findfont exch
+	scalefont setfont
+} def
+
+% draw aligned label in bounding box aligned to current point
+/alignedtext {			% width adj text
+	/text exch def
+	/adj exch def
+	/width exch def
+	gsave
+		width 0 gt {
+			text stringwidth pop adj mul 0 rmoveto
+		} if
+		[] 0 setdash
+		text show
+	grestore
+} def
+
+/boxprim {				% xcorner ycorner xsize ysize
+		4 2 roll
+		moveto
+		2 copy
+		exch 0 rlineto
+		0 exch rlineto
+		pop neg 0 rlineto
+		closepath
+} bind def
+
+/ellipse_path {
+	/ry exch def
+	/rx exch def
+	/y exch def
+	/x exch def
+	matrix currentmatrix
+	newpath
+	x y translate
+	rx ry scale
+	0 0 1 0 360 arc
+	setmatrix
+} bind def
+
+/endpage { showpage } bind def
+/showpage { } def
+
+/layercolorseq
+	[	% layer color sequence - darkest to lightest
+		[0 0 0]
+		[.2 .8 .8]
+		[.4 .8 .8]
+		[.6 .8 .8]
+		[.8 .8 .8]
+	]
+def
+
+/layerlen layercolorseq length def
+
+/setlayer {/maxlayer exch def /curlayer exch def
+	layercolorseq curlayer 1 sub layerlen mod get
+	aload pop sethsbcolor
+	/nodecolor {nopcolor} def
+	/edgecolor {nopcolor} def
+	/graphcolor {nopcolor} def
+} bind def
+
+/onlayer { curlayer ne {invis} if } def
+
+/onlayers {
+	/myupper exch def
+	/mylower exch def
+	curlayer mylower lt
+	curlayer myupper gt
+	or
+	{invis} if
+} def
+
+/curlayer 0 def
+
+%%EndResource
+%%EndProlog
+%%BeginSetup
+14 default-font-family set_font
+1 setmiterlimit
+% /arrowlength 10 def
+% /arrowwidth 5 def
+
+% make sure pdfmark is harmless for PS-interpreters other than Distiller
+/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
+% make '<<' and '>>' safe on PS Level 1 devices
+/languagelevel where {pop languagelevel}{1} ifelse
+2 lt {
+    userdict (<<) cvn ([) cvn load put
+    userdict (>>) cvn ([) cvn load put
+} if
+
+%%EndSetup
+%%Page: 1 1
+%%PageBoundingBox: 36 36 577 165
+%%PageOrientation: Portrait
+gsave
+35 35 542 130 boxprim clip newpath
+36 36 translate
+0 0 1 beginpage
+0.4696 set_scale
+0 0 translate 0 rotate
+0.000 0.000 0.000 graphcolor
+14.00 /Times-Roman set_font
+
+%	Extraargs
+gsave 10 dict begin
+483 110 40 18 ellipse_path
+stroke
+gsave 10 dict begin
+455 105 moveto
+(Extraargs)
+[8.4 6.96 3.84 4.56 6.24 6.24 4.32 6.96 5.52]
+xshow
+end grestore
+end grestore
+
+%	Setoid_replace
+gsave 10 dict begin
+615 64 54 18 ellipse_path
+stroke
+gsave 10 dict begin
+573 59 moveto
+(Setoid_replace)
+[7.68 6 3.84 6.96 3.84 6.96 6.96 4.56 6.24 6.96 3.84 6.24 6.24 6.24]
+xshow
+end grestore
+end grestore
+
+%	Extraargs -> Setoid_replace
+newpath 515 99 moveto
+531 93 550 87 567 81 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 569 84 moveto
+577 77 lineto
+566 77 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 569 84 moveto
+577 77 lineto
+566 77 lineto
+closepath
+stroke
+end grestore
+
+%	Tactics
+gsave 10 dict begin
+884 110 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+864 105 moveto
+(Tactics)
+[7.44 6.24 6.24 3.84 3.84 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Setoid_replace -> Tactics
+newpath 669 66 moveto
+709 68 764 72 810 83 curveto
+823 85 837 90 848 94 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 847 98 moveto
+858 98 lineto
+850 91 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 847 98 moveto
+858 98 lineto
+850 91 lineto
+closepath
+stroke
+end grestore
+
+%	Termdn
+gsave 10 dict begin
+998 256 35 18 ellipse_path
+stroke
+gsave 10 dict begin
+976 251 moveto
+(Termdn)
+[7.2 6.24 4.8 10.8 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Dn
+gsave 10 dict begin
+1112 256 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+1102 251 moveto
+(Dn)
+[10.08 6.96]
+xshow
+end grestore
+end grestore
+
+%	Termdn -> Dn
+newpath 1033 256 moveto
+1047 256 1061 256 1075 256 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1075 260 moveto
+1085 256 lineto
+1075 253 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1075 260 moveto
+1085 256 lineto
+1075 253 lineto
+closepath
+stroke
+end grestore
+
+%	Hipattern
+gsave 10 dict begin
+998 110 40 18 ellipse_path
+stroke
+gsave 10 dict begin
+971 105 moveto
+(Hipattern)
+[10.08 3.84 6.96 6.24 3.84 3.84 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	Tactics -> Hipattern
+newpath 917 110 moveto
+927 110 938 110 948 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 948 114 moveto
+958 110 lineto
+948 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 948 114 moveto
+958 110 lineto
+948 107 lineto
+closepath
+stroke
+end grestore
+
+%	Tacticals
+gsave 10 dict begin
+1112 110 38 18 ellipse_path
+stroke
+gsave 10 dict begin
+1087 105 moveto
+(Tacticals)
+[7.44 6.24 6.24 3.84 3.84 6.24 6.24 3.84 5.52]
+xshow
+end grestore
+end grestore
+
+%	Hipattern -> Tacticals
+newpath 1038 110 moveto
+1047 110 1055 110 1064 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1064 114 moveto
+1074 110 lineto
+1064 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1064 114 moveto
+1074 110 lineto
+1064 107 lineto
+closepath
+stroke
+end grestore
+
+%	Tacinterp
+gsave 10 dict begin
+170 191 39 18 ellipse_path
+stroke
+gsave 10 dict begin
+143 186 moveto
+(Tacinterp)
+[7.44 6.24 6.24 3.84 6.96 3.84 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	Auto
+gsave 10 dict begin
+483 218 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+468 213 moveto
+(Auto)
+[9.6 6.96 3.84 6.96]
+xshow
+end grestore
+end grestore
+
+%	Tacinterp -> Auto
+newpath 209 194 moveto
+269 200 386 210 445 215 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 445 218 moveto
+455 216 lineto
+445 212 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 445 218 moveto
+455 216 lineto
+445 212 lineto
+closepath
+stroke
+end grestore
+
+%	Leminv
+gsave 10 dict begin
+281 166 35 18 ellipse_path
+stroke
+gsave 10 dict begin
+259 161 moveto
+(Leminv)
+[8.4 6.24 10.8 3.84 6.48 6.96]
+xshow
+end grestore
+end grestore
+
+%	Tacinterp -> Leminv
+newpath 205 183 moveto
+216 181 228 178 239 175 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 240 178 moveto
+249 173 lineto
+239 172 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 240 178 moveto
+249 173 lineto
+239 172 lineto
+closepath
+stroke
+end grestore
+
+%	Hiddentac
+gsave 10 dict begin
+615 164 42 18 ellipse_path
+stroke
+gsave 10 dict begin
+585 159 moveto
+(Hiddentac)
+[10.08 3.84 6.96 6.96 6.24 6.96 4.08 6.24 6.24]
+xshow
+end grestore
+end grestore
+
+%	Auto -> Hiddentac
+newpath 507 208 moveto
+526 200 553 189 574 181 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 576 184 moveto
+584 177 lineto
+573 177 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 576 184 moveto
+584 177 lineto
+573 177 lineto
+closepath
+stroke
+end grestore
+
+%	Dhyp
+gsave 10 dict begin
+615 218 29 18 ellipse_path
+stroke
+gsave 10 dict begin
+599 213 moveto
+(Dhyp)
+[10.08 6.48 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Auto -> Dhyp
+newpath 511 218 moveto
+530 218 555 218 576 218 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 576 222 moveto
+586 218 lineto
+576 215 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 576 222 moveto
+586 218 lineto
+576 215 lineto
+closepath
+stroke
+end grestore
+
+%	Inv
+gsave 10 dict begin
+379 164 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+369 159 moveto
+(Inv)
+[4.56 6.48 6.96]
+xshow
+end grestore
+end grestore
+
+%	Leminv -> Inv
+newpath 316 165 moveto
+324 165 333 165 342 165 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 342 169 moveto
+352 165 lineto
+342 162 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 342 169 moveto
+352 165 lineto
+342 162 lineto
+closepath
+stroke
+end grestore
+
+%	Refine
+gsave 10 dict begin
+758 110 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+739 105 moveto
+(Refine)
+[9.12 6.24 4.8 3.84 6.96 6.24]
+xshow
+end grestore
+end grestore
+
+%	Refine -> Tactics
+newpath 790 110 moveto
+805 110 824 110 841 110 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 841 114 moveto
+851 110 lineto
+841 107 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 841 114 moveto
+851 110 lineto
+841 107 lineto
+closepath
+stroke
+end grestore
+
+%	Nbtermdn
+gsave 10 dict begin
+758 256 42 18 ellipse_path
+stroke
+gsave 10 dict begin
+729 251 moveto
+(Nbtermdn)
+[10.08 6.96 3.84 6.24 4.8 10.8 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Btermdn
+gsave 10 dict begin
+884 256 38 18 ellipse_path
+stroke
+gsave 10 dict begin
+859 251 moveto
+(Btermdn)
+[9.36 3.84 6.24 4.8 10.8 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Nbtermdn -> Btermdn
+newpath 800 256 moveto
+812 256 824 256 836 256 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 836 260 moveto
+846 256 lineto
+836 253 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 836 260 moveto
+846 256 lineto
+836 253 lineto
+closepath
+stroke
+end grestore
+
+%	Btermdn -> Termdn
+newpath 922 256 moveto
+932 256 943 256 953 256 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 953 260 moveto
+963 256 lineto
+953 253 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 953 260 moveto
+963 256 lineto
+953 253 lineto
+closepath
+stroke
+end grestore
+
+%	Elim
+gsave 10 dict begin
+483 164 27 18 ellipse_path
+stroke
+gsave 10 dict begin
+468 159 moveto
+(Elim)
+[8.4 3.84 3.84 10.8]
+xshow
+end grestore
+end grestore
+
+%	Inv -> Elim
+newpath 406 164 moveto
+418 164 432 164 445 164 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 445 168 moveto
+455 164 lineto
+445 161 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 445 168 moveto
+455 164 lineto
+445 161 lineto
+closepath
+stroke
+end grestore
+
+%	Equality
+gsave 10 dict begin
+483 56 37 18 ellipse_path
+stroke
+gsave 10 dict begin
+459 51 moveto
+(Equality)
+[8.4 6.72 6.96 6.24 3.84 3.84 3.84 6.96]
+xshow
+end grestore
+end grestore
+
+%	Inv -> Equality
+newpath 390 147 moveto
+401 130 421 102 442 83 curveto
+445 80 448 78 451 76 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 453 79 moveto
+459 70 lineto
+449 73 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 453 79 moveto
+459 70 lineto
+449 73 lineto
+closepath
+stroke
+end grestore
+
+%	Elim -> Hiddentac
+newpath 511 164 moveto
+526 164 545 164 562 164 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 562 168 moveto
+572 164 lineto
+562 161 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 562 168 moveto
+572 164 lineto
+562 161 lineto
+closepath
+stroke
+end grestore
+
+%	Equality -> Setoid_replace
+newpath 520 58 moveto
+530 59 540 60 551 60 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 551 63 moveto
+561 61 lineto
+551 57 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 551 63 moveto
+561 61 lineto
+551 57 lineto
+closepath
+stroke
+end grestore
+
+%	Evar_tactics
+gsave 10 dict begin
+758 164 48 18 ellipse_path
+stroke
+gsave 10 dict begin
+722 159 moveto
+(Evar_tactics)
+[8.4 6.72 6.24 4.56 6.96 4.08 6.24 6.24 3.84 3.84 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Hiddentac -> Evar_tactics
+newpath 658 164 moveto
+671 164 685 164 699 164 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 699 168 moveto
+709 164 lineto
+699 161 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 699 168 moveto
+709 164 lineto
+699 161 lineto
+closepath
+stroke
+end grestore
+
+%	Evar_tactics -> Tactics
+newpath 790 150 moveto
+808 142 830 132 849 125 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 850 128 moveto
+858 121 lineto
+847 122 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 850 128 moveto
+858 121 lineto
+847 122 lineto
+closepath
+stroke
+end grestore
+
+%	Dhyp -> Tactics
+newpath 644 219 moveto
+684 220 756 217 810 191 curveto
+844 175 855 163 872 137 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 875 138 moveto
+877 128 lineto
+869 135 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 875 138 moveto
+877 128 lineto
+869 135 lineto
+closepath
+stroke
+end grestore
+
+%	Dhyp -> Nbtermdn
+newpath 642 225 moveto
+662 230 689 238 712 244 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 712 247 moveto
+722 246 lineto
+713 241 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 712 247 moveto
+722 246 lineto
+713 241 lineto
+closepath
+stroke
+end grestore
+
+%	Contradiction
+gsave 10 dict begin
+758 18 51 18 ellipse_path
+stroke
+gsave 10 dict begin
+719 13 moveto
+(Contradiction)
+[9.36 6.96 6.96 3.84 4.56 6.24 6.96 3.84 6.24 3.84 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Contradiction -> Tactics
+newpath 784 34 moveto
+793 39 802 44 810 50 curveto
+827 62 845 76 859 88 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 857 91 moveto
+867 95 lineto
+862 86 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 857 91 moveto
+867 95 lineto
+862 86 lineto
+closepath
+stroke
+end grestore
+
+%	Autorewrite
+gsave 10 dict begin
+47 191 47 18 ellipse_path
+stroke
+gsave 10 dict begin
+13 186 moveto
+(Autorewrite)
+[9.6 6.96 3.84 6.96 4.56 5.76 10.08 4.8 3.84 3.84 6.24]
+xshow
+end grestore
+end grestore
+
+%	Autorewrite -> Tacinterp
+newpath 94 191 moveto
+102 191 111 191 120 191 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 120 195 moveto
+130 191 lineto
+120 188 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 120 195 moveto
+130 191 lineto
+120 188 lineto
+closepath
+stroke
+end grestore
+endpage
+showpage
+grestore
+%%PageTrailer
+%%EndPage: 1
+%%Trailer
+%%Pages: 1
+end
+restore
+%%EOF
diff --git a/dev/ocamlweb-doc/toplevel.dep.ps b/dev/ocamlweb-doc/toplevel.dep.ps
new file mode 100644
index 00000000..e0355aac
--- /dev/null
+++ b/dev/ocamlweb-doc/toplevel.dep.ps
@@ -0,0 +1,971 @@
+%!PS-Adobe-2.0
+%%Creator: dot version 2.2 (Wed Jan 19 21:09:25 UTC 2005)
+%%For: (herbelin) Hugo Herbelin
+%%Title: G
+%%Pages: (atend)
+%%BoundingBox: 35 35 577 166
+%%EndComments
+save
+%%BeginProlog
+/DotDict 200 dict def
+DotDict begin
+
+/setupLatin1 {
+mark
+/EncodingVector 256 array def
+ EncodingVector 0
+
+ISOLatin1Encoding 0 255 getinterval putinterval
+
+EncodingVector
+  dup 306 /AE
+  dup 301 /Aacute
+  dup 302 /Acircumflex
+  dup 304 /Adieresis
+  dup 300 /Agrave
+  dup 305 /Aring
+  dup 303 /Atilde
+  dup 307 /Ccedilla
+  dup 311 /Eacute
+  dup 312 /Ecircumflex
+  dup 313 /Edieresis
+  dup 310 /Egrave
+  dup 315 /Iacute
+  dup 316 /Icircumflex
+  dup 317 /Idieresis
+  dup 314 /Igrave
+  dup 334 /Udieresis
+  dup 335 /Yacute
+  dup 376 /thorn
+  dup 337 /germandbls
+  dup 341 /aacute
+  dup 342 /acircumflex
+  dup 344 /adieresis
+  dup 346 /ae
+  dup 340 /agrave
+  dup 345 /aring
+  dup 347 /ccedilla
+  dup 351 /eacute
+  dup 352 /ecircumflex
+  dup 353 /edieresis
+  dup 350 /egrave
+  dup 355 /iacute
+  dup 356 /icircumflex
+  dup 357 /idieresis
+  dup 354 /igrave
+  dup 360 /dcroat
+  dup 361 /ntilde
+  dup 363 /oacute
+  dup 364 /ocircumflex
+  dup 366 /odieresis
+  dup 362 /ograve
+  dup 365 /otilde
+  dup 370 /oslash
+  dup 372 /uacute
+  dup 373 /ucircumflex
+  dup 374 /udieresis
+  dup 371 /ugrave
+  dup 375 /yacute
+  dup 377 /ydieresis  
+
+% Set up ISO Latin 1 character encoding
+/starnetISO {
+        dup dup findfont dup length dict begin
+        { 1 index /FID ne { def }{ pop pop } ifelse
+        } forall
+        /Encoding EncodingVector def
+        currentdict end definefont
+} def
+/Times-Roman starnetISO def
+/Times-Italic starnetISO def
+/Times-Bold starnetISO def
+/Times-BoldItalic starnetISO def
+/Helvetica starnetISO def
+/Helvetica-Oblique starnetISO def
+/Helvetica-Bold starnetISO def
+/Helvetica-BoldOblique starnetISO def
+/Courier starnetISO def
+/Courier-Oblique starnetISO def
+/Courier-Bold starnetISO def
+/Courier-BoldOblique starnetISO def
+cleartomark
+} bind def
+
+%%BeginResource: procset graphviz 0 0
+/coord-font-family /Times-Roman def
+/default-font-family /Times-Roman def
+/coordfont coord-font-family findfont 8 scalefont def
+
+/InvScaleFactor 1.0 def
+/set_scale {
+	dup 1 exch div /InvScaleFactor exch def
+	dup scale
+} bind def
+
+% styles
+/solid { [] 0 setdash } bind def
+/dashed { [9 InvScaleFactor mul dup ] 0 setdash } bind def
+/dotted { [1 InvScaleFactor mul 6 InvScaleFactor mul] 0 setdash } bind def
+/invis {/fill {newpath} def /stroke {newpath} def /show {pop newpath} def} bind def
+/bold { 2 setlinewidth } bind def
+/filled { } bind def
+/unfilled { } bind def
+/rounded { } bind def
+/diagonals { } bind def
+
+% hooks for setting color 
+/nodecolor { sethsbcolor } bind def
+/edgecolor { sethsbcolor } bind def
+/graphcolor { sethsbcolor } bind def
+/nopcolor {pop pop pop} bind def
+
+/beginpage {	% i j npages
+	/npages exch def
+	/j exch def
+	/i exch def
+	/str 10 string def
+	npages 1 gt {
+		gsave
+			coordfont setfont
+			0 0 moveto
+			(\() show i str cvs show (,) show j str cvs show (\)) show
+		grestore
+	} if
+} bind def
+
+/set_font {
+	findfont exch
+	scalefont setfont
+} def
+
+% draw aligned label in bounding box aligned to current point
+/alignedtext {			% width adj text
+	/text exch def
+	/adj exch def
+	/width exch def
+	gsave
+		width 0 gt {
+			text stringwidth pop adj mul 0 rmoveto
+		} if
+		[] 0 setdash
+		text show
+	grestore
+} def
+
+/boxprim {				% xcorner ycorner xsize ysize
+		4 2 roll
+		moveto
+		2 copy
+		exch 0 rlineto
+		0 exch rlineto
+		pop neg 0 rlineto
+		closepath
+} bind def
+
+/ellipse_path {
+	/ry exch def
+	/rx exch def
+	/y exch def
+	/x exch def
+	matrix currentmatrix
+	newpath
+	x y translate
+	rx ry scale
+	0 0 1 0 360 arc
+	setmatrix
+} bind def
+
+/endpage { showpage } bind def
+/showpage { } def
+
+/layercolorseq
+	[	% layer color sequence - darkest to lightest
+		[0 0 0]
+		[.2 .8 .8]
+		[.4 .8 .8]
+		[.6 .8 .8]
+		[.8 .8 .8]
+	]
+def
+
+/layerlen layercolorseq length def
+
+/setlayer {/maxlayer exch def /curlayer exch def
+	layercolorseq curlayer 1 sub layerlen mod get
+	aload pop sethsbcolor
+	/nodecolor {nopcolor} def
+	/edgecolor {nopcolor} def
+	/graphcolor {nopcolor} def
+} bind def
+
+/onlayer { curlayer ne {invis} if } def
+
+/onlayers {
+	/myupper exch def
+	/mylower exch def
+	curlayer mylower lt
+	curlayer myupper gt
+	or
+	{invis} if
+} def
+
+/curlayer 0 def
+
+%%EndResource
+%%EndProlog
+%%BeginSetup
+14 default-font-family set_font
+1 setmiterlimit
+% /arrowlength 10 def
+% /arrowwidth 5 def
+
+% make sure pdfmark is harmless for PS-interpreters other than Distiller
+/pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse
+% make '<<' and '>>' safe on PS Level 1 devices
+/languagelevel where {pop languagelevel}{1} ifelse
+2 lt {
+    userdict (<<) cvn ([) cvn load put
+    userdict (>>) cvn ([) cvn load put
+} if
+
+%%EndSetup
+%%Page: 1 1
+%%PageBoundingBox: 36 36 577 166
+%%PageOrientation: Portrait
+gsave
+35 35 542 131 boxprim clip newpath
+36 36 translate
+0 0 1 beginpage
+0.4180 set_scale
+0 0 translate 0 rotate
+0.000 0.000 0.000 graphcolor
+14.00 /Times-Roman set_font
+
+%	Vernac
+gsave 10 dict begin
+562 145 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+541 140 moveto
+(Vernac)
+[8.88 6.24 4.8 6.96 6.24 6.24]
+xshow
+end grestore
+end grestore
+
+%	Vernacentries
+gsave 10 dict begin
+724 158 52 18 ellipse_path
+stroke
+gsave 10 dict begin
+685 153 moveto
+(Vernacentries)
+[8.88 6.24 4.8 6.96 6.24 6.24 6.24 6.96 3.84 4.8 3.84 6.24 5.52]
+xshow
+end grestore
+end grestore
+
+%	Vernac -> Vernacentries
+newpath 595 148 moveto
+615 149 640 151 663 153 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 663 156 moveto
+673 154 lineto
+663 150 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 663 156 moveto
+673 154 lineto
+663 150 lineto
+closepath
+stroke
+end grestore
+
+%	Vernacinterp
+gsave 10 dict begin
+862 158 50 18 ellipse_path
+stroke
+gsave 10 dict begin
+825 153 moveto
+(Vernacinterp)
+[8.88 6.24 4.8 6.96 6.24 6.24 3.84 6.96 3.84 6.24 4.8 6.96]
+xshow
+end grestore
+end grestore
+
+%	Vernacentries -> Vernacinterp
+newpath 776 158 moveto
+785 158 793 158 802 158 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 802 162 moveto
+812 158 lineto
+802 155 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 802 162 moveto
+812 158 lineto
+802 155 lineto
+closepath
+stroke
+end grestore
+
+%	Discharge
+gsave 10 dict begin
+862 212 42 18 ellipse_path
+stroke
+gsave 10 dict begin
+833 207 moveto
+(Discharge)
+[10.08 3.84 5.52 6 6.96 6.24 4.32 6.72 6.24]
+xshow
+end grestore
+end grestore
+
+%	Vernacentries -> Discharge
+newpath 758 171 moveto
+777 179 801 188 822 196 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 820 199 moveto
+831 200 lineto
+823 193 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 820 199 moveto
+831 200 lineto
+823 193 lineto
+closepath
+stroke
+end grestore
+
+%	Mltop
+gsave 10 dict begin
+862 104 31 18 ellipse_path
+stroke
+gsave 10 dict begin
+844 99 moveto
+(Mltop)
+[12.48 3.84 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Vernacentries -> Mltop
+newpath 758 145 moveto
+779 137 805 126 826 118 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 828 121 moveto
+836 114 lineto
+825 114 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 828 121 moveto
+836 114 lineto
+825 114 lineto
+closepath
+stroke
+end grestore
+
+%	Record
+gsave 10 dict begin
+862 281 33 18 ellipse_path
+stroke
+gsave 10 dict begin
+842 276 moveto
+(Record)
+[9.12 6.24 6.24 6.96 4.32 6.96]
+xshow
+end grestore
+end grestore
+
+%	Vernacentries -> Record
+newpath 742 175 moveto
+760 192 788 217 812 239 curveto
+819 246 828 253 835 259 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 833 262 moveto
+843 266 lineto
+838 257 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 833 262 moveto
+843 266 lineto
+838 257 lineto
+closepath
+stroke
+end grestore
+
+%	Himsg
+gsave 10 dict begin
+991 85 32 18 ellipse_path
+stroke
+gsave 10 dict begin
+971 80 moveto
+(Himsg)
+[10.08 3.84 10.8 5.52 6.96]
+xshow
+end grestore
+end grestore
+
+%	Vernacinterp -> Himsg
+newpath 890 143 moveto
+897 139 905 135 912 131 curveto
+929 123 946 112 960 103 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 962 106 moveto
+969 98 lineto
+959 100 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 962 106 moveto
+969 98 lineto
+959 100 lineto
+closepath
+stroke
+end grestore
+
+%	Vernacexpr
+gsave 10 dict begin
+1246 221 45 18 ellipse_path
+stroke
+gsave 10 dict begin
+1213 216 moveto
+(Vernacexpr)
+[8.88 6.24 4.8 6.96 6.24 6.24 5.76 6.96 6.96 4.56]
+xshow
+end grestore
+end grestore
+
+%	Vernacinterp -> Vernacexpr
+newpath 912 159 moveto
+947 160 994 163 1034 169 curveto
+1092 178 1158 195 1200 207 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1199 210 moveto
+1210 210 lineto
+1201 204 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1199 210 moveto
+1210 210 lineto
+1201 204 lineto
+closepath
+stroke
+end grestore
+
+%	Class
+gsave 10 dict begin
+1117 238 28 18 ellipse_path
+stroke
+gsave 10 dict begin
+1101 233 moveto
+(Class)
+[9.36 3.84 6.24 5.52 5.52]
+xshow
+end grestore
+end grestore
+
+%	Discharge -> Class
+newpath 902 217 moveto
+917 219 933 221 948 223 curveto
+992 228 1044 232 1079 235 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1079 238 moveto
+1089 236 lineto
+1079 232 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1079 238 moveto
+1089 236 lineto
+1079 232 lineto
+closepath
+stroke
+end grestore
+
+%	Recordobj
+gsave 10 dict begin
+991 196 42 18 ellipse_path
+stroke
+gsave 10 dict begin
+962 191 moveto
+(Recordobj)
+[9.12 6.24 6.24 6.96 4.32 6.96 6.96 6.96 3.84]
+xshow
+end grestore
+end grestore
+
+%	Discharge -> Recordobj
+newpath 902 207 moveto
+914 205 927 204 940 202 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 940 205 moveto
+950 201 lineto
+940 199 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 940 205 moveto
+950 201 lineto
+940 199 lineto
+closepath
+stroke
+end grestore
+
+%	Command
+gsave 10 dict begin
+991 288 42 18 ellipse_path
+stroke
+gsave 10 dict begin
+961 283 moveto
+(Command)
+[9.36 6.96 10.8 10.8 6.24 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Record -> Command
+newpath 895 283 moveto
+908 284 923 285 938 285 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 938 288 moveto
+948 286 lineto
+938 282 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 938 288 moveto
+948 286 lineto
+938 282 lineto
+closepath
+stroke
+end grestore
+
+%	Toplevel
+gsave 10 dict begin
+255 72 37 18 ellipse_path
+stroke
+gsave 10 dict begin
+231 67 moveto
+(Toplevel)
+[7.2 6.96 6.96 3.84 5.76 6.48 6.24 3.84]
+xshow
+end grestore
+end grestore
+
+%	Protectedtoplevel
+gsave 10 dict begin
+390 72 61 18 ellipse_path
+stroke
+gsave 10 dict begin
+341 67 moveto
+(Protectedtoplevel)
+[7.68 4.56 6.72 3.84 6.24 6.24 3.84 6.24 6.96 3.84 6.96 6.96 3.84 5.76 6.48 6.24 3.84]
+xshow
+end grestore
+end grestore
+
+%	Toplevel -> Protectedtoplevel
+newpath 292 72 moveto
+300 72 309 72 318 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 318 76 moveto
+328 72 lineto
+318 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 318 76 moveto
+328 72 lineto
+318 69 lineto
+closepath
+stroke
+end grestore
+
+%	Protectedtoplevel -> Vernac
+newpath 425 87 moveto
+455 100 497 117 527 130 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 525 133 moveto
+536 134 lineto
+528 127 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 525 133 moveto
+536 134 lineto
+528 127 lineto
+closepath
+stroke
+end grestore
+
+%	Cerrors
+gsave 10 dict begin
+724 65 34 18 ellipse_path
+stroke
+gsave 10 dict begin
+702 60 moveto
+(Cerrors)
+[9.36 6.24 5.04 4.56 6.96 4.56 5.52]
+xshow
+end grestore
+end grestore
+
+%	Protectedtoplevel -> Cerrors
+newpath 452 71 moveto
+518 70 621 67 679 66 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 679 70 moveto
+689 66 lineto
+679 63 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 679 70 moveto
+689 66 lineto
+679 63 lineto
+closepath
+stroke
+end grestore
+
+%	Line_oriented_parser
+gsave 10 dict begin
+562 26 73 18 ellipse_path
+stroke
+gsave 10 dict begin
+501 21 moveto
+(Line_oriented_parser)
+[8.4 3.84 6.96 6.24 6.96 6.96 4.8 3.84 6.24 6.96 3.84 6.24 6.96 6.96 6.96 6.24 4.56 5.52 6.24 4.56]
+xshow
+end grestore
+end grestore
+
+%	Protectedtoplevel -> Line_oriented_parser
+newpath 436 60 moveto
+457 55 481 48 502 42 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 503 45 moveto
+512 39 lineto
+501 39 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 503 45 moveto
+512 39 lineto
+501 39 lineto
+closepath
+stroke
+end grestore
+
+%	Metasyntax
+gsave 10 dict begin
+1117 292 46 18 ellipse_path
+stroke
+gsave 10 dict begin
+1083 287 moveto
+(Metasyntax)
+[12.48 6 4.08 6.24 5.52 6.96 6.96 4.08 6.24 6.96]
+xshow
+end grestore
+end grestore
+
+%	Command -> Metasyntax
+newpath 1034 289 moveto
+1043 290 1052 290 1061 290 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1061 293 moveto
+1071 291 lineto
+1061 287 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1061 293 moveto
+1071 291 lineto
+1061 287 lineto
+closepath
+stroke
+end grestore
+
+%	Command -> Class
+newpath 1022 276 moveto
+1041 268 1065 259 1084 252 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1085 255 moveto
+1093 248 lineto
+1082 249 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1085 255 moveto
+1093 248 lineto
+1082 249 lineto
+closepath
+stroke
+end grestore
+
+%	Cerrors -> Himsg
+newpath 758 67 moveto
+796 69 859 73 912 77 curveto
+924 78 937 79 949 80 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 949 83 moveto
+959 81 lineto
+949 77 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 949 83 moveto
+959 81 lineto
+949 77 lineto
+closepath
+stroke
+end grestore
+
+%	Minicoq
+gsave 10 dict begin
+38 126 37 18 ellipse_path
+stroke
+gsave 10 dict begin
+13 121 moveto
+(Minicoq)
+[12.48 3.84 6.96 3.84 6.24 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Fhimsg
+gsave 10 dict begin
+147 126 34 18 ellipse_path
+stroke
+gsave 10 dict begin
+125 121 moveto
+(Fhimsg)
+[7.68 6.96 3.84 10.8 5.52 6.96]
+xshow
+end grestore
+end grestore
+
+%	Minicoq -> Fhimsg
+newpath 76 126 moveto
+84 126 93 126 102 126 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 102 130 moveto
+112 126 lineto
+102 123 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 102 130 moveto
+112 126 lineto
+102 123 lineto
+closepath
+stroke
+end grestore
+
+%	Metasyntax -> Vernacexpr
+newpath 1144 277 moveto
+1163 267 1189 252 1210 241 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 1212 244 moveto
+1219 236 lineto
+1209 238 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 1212 244 moveto
+1219 236 lineto
+1209 238 lineto
+closepath
+stroke
+end grestore
+
+%	Coqtop
+gsave 10 dict begin
+38 45 34 18 ellipse_path
+stroke
+gsave 10 dict begin
+17 40 moveto
+(Coqtop)
+[9.36 6.96 6.96 3.84 6.96 6.96]
+xshow
+end grestore
+end grestore
+
+%	Coqinit
+gsave 10 dict begin
+147 72 34 18 ellipse_path
+stroke
+gsave 10 dict begin
+126 67 moveto
+(Coqinit)
+[9.36 6.96 6.96 3.84 6.96 3.84 3.84]
+xshow
+end grestore
+end grestore
+
+%	Coqtop -> Coqinit
+newpath 69 53 moveto
+81 56 94 59 106 62 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 105 65 moveto
+116 65 lineto
+107 59 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 105 65 moveto
+116 65 lineto
+107 59 lineto
+closepath
+stroke
+end grestore
+
+%	Usage
+gsave 10 dict begin
+147 18 31 18 ellipse_path
+stroke
+gsave 10 dict begin
+129 13 moveto
+(Usage)
+[10.08 5.52 6.24 6.72 6.24]
+xshow
+end grestore
+end grestore
+
+%	Coqtop -> Usage
+newpath 69 37 moveto
+81 34 95 31 108 28 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 109 31 moveto
+118 25 lineto
+107 25 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 109 31 moveto
+118 25 lineto
+107 25 lineto
+closepath
+stroke
+end grestore
+
+%	Coqinit -> Toplevel
+newpath 181 72 moveto
+190 72 199 72 208 72 curveto
+stroke
+gsave 10 dict begin
+solid
+1 setlinewidth
+0.000 0.000 0.000 edgecolor
+newpath 208 76 moveto
+218 72 lineto
+208 69 lineto
+closepath
+fill
+0.000 0.000 0.000 edgecolor
+newpath 208 76 moveto
+218 72 lineto
+208 69 lineto
+closepath
+stroke
+end grestore
+endpage
+showpage
+grestore
+%%PageTrailer
+%%EndPage: 1
+%%Trailer
+%%Pages: 1
+end
+restore
+%%EOF
diff --git a/dev/perf-analysis b/dev/perf-analysis
deleted file mode 100644
index 4295a573..00000000
--- a/dev/perf-analysis
+++ /dev/null
@@ -1,51 +0,0 @@
-Performance analysis for V8-0-bugfix branch
--------------------------------------------
-
-  Dec 27, 2005: contrib Karatsuba added (~ 24s)
-
-Dec 1-14, 2005: benchmarking server down
-
-Nov 29 and Dec 16, 2005: size increase
-  due to new record flag in inductive for extraction
-
-  Oct 6, 2005: contribs IPC and Tait added (~ 22s and ~ 24s)
- 
-  Aug 1, 2005: contrib Kildall added (~ 64s)
- 
-Jul 26-Aug 2, 2005: bench down
-
-Jul 14-15, 2005: 4 contribs failed including CoRN
-
-  Jul 7, 2005: adding contrib Fermat4: but not compabible and remove on Jul 8
-
-  Jun 17, 2005: contrib Goodstein extended and moved to CantorOrdinals (~ 28s)
-
-Jun 4, 2005: significant time reduction
-   (e.g. Nijmegen/LinAlg: -15%, Nijmegen/QArith: stable; Nijmegen/CoRN: -1%)
-   only changes are the removal of an assert checking location and
-   the pre-definition of level 200 (could it be just a parsing improvement??)
-
-  May 19, 2005: contrib Goodstein and prfx (~ 9s) added 
-
-Apr 30, 2005: evaluation order of atomic tactics changed
-   (e.g. Nijmegen/CoRN: stable, Nijmegen/QArith: -2%, Nijmegen/LinAlg: +20%) 
-
-Mar 20, 2005: fixed Logic.with_check bug
-  improved whole V8-0-bugfix bench by 4 %
-  (e.g. Nijmegen/CoRN: - 7.5 %, Nijmegen/QARITH: - 1.5 %)
-
-Mar 7-10, 2005: unexplained time reduction 
-  (on Mar 7, changed Ppconstrnew univ printer only)
-  (note also a server upgrade around Mar 10)
-
-Feb 17, 2005: fixed omega bug #922 (wrong STATE dependency):
-  improved whole V8-0-bugfix bench by 2 %
-  (e.g. Nijmegen/CoRN: - 6.5 %, Nijmegen/QARITH: - 3 %)
-
-Feb 2, 2005: fixed ltac var interpretation order
-
-  Jan 13, 2005: contrib SumOfTwoSquare added (~ 37s)
-
-Dec 20-29, 2004: reduced whole V8-0-bugfix due to Berkeley/Godel failure
-
-Nov 27 - Dec 10, 2004: strong instability
diff --git a/dev/tools/Makefile.common b/dev/tools/Makefile.common
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/dev/tools/Makefile.common
diff --git a/dev/Makefile.devel b/dev/tools/Makefile.devel
index f3abb62d..8dcc70cf 100644
--- a/dev/Makefile.devel
+++ b/dev/tools/Makefile.devel
@@ -16,9 +16,9 @@ usage::
 usage::
 	@echo "  setup-devel	-- set the devel makefile"
 setup-devel:
-	@ln -sfv dev/Makefile.devel makefile
+	@ln -sfv dev/tools/Makefile.devel makefile
 	@(for i in $(SOURCEDIRS); do \
-	    (cd $(TOPDIR)/$$i; ln -sfv ../dev/Makefile.dir Makefile) \
+	    (cd $(TOPDIR)/$$i; ln -sfv ../dev/tools/Makefile.dir Makefile) \
 	done)
 
 
@@ -42,14 +42,14 @@ quick:
 
 include Makefile
 
-include $(TOPDIR)/dev/Makefile.common
+include $(TOPDIR)/dev/tools/Makefile.common
 
-# this file is better described in dev/Makefile.dir
+# this file is better described in dev/tools/Makefile.dir
 include .depend.devel
 
-#if dev/Makefile.local exists, it is included
-ifneq ($(wildcard $(TOPDIR)/dev/Makefile.local),)
-include $(TOPDIR)/dev/Makefile.local
+#if dev/tools/Makefile.local exists, it is included
+ifneq ($(wildcard $(TOPDIR)/dev/tools/Makefile.local),)
+include $(TOPDIR)/dev/tools/Makefile.local
 endif
 
 
@@ -71,4 +71,4 @@ usage::
 vars:
 	@(cd $(TOPDIR); \
 	echo export COQTOP=`pwd`/ ; \
-	echo export COQBIN=`pwd`/bin/ )
\ No newline at end of file
+	echo export COQBIN=`pwd`/bin/ )
diff --git a/dev/Makefile.dir b/dev/tools/Makefile.dir
index 54f7bfe9..1a1bb90b 100644
--- a/dev/Makefile.dir
+++ b/dev/tools/Makefile.dir
@@ -1,6 +1,6 @@
 # make a link to this file if you are working hard in one directory of Coq
-#   ln -s ../dev/Makefile.dir Makefile
-# if you are working in a sub/dir/ make a link to dev/Makefile.subdir instead
+#   ln -s ../dev/tools/Makefile.dir Makefile
+# if you are working in a sub/dir/ make a link to dev/tools/Makefile.subdir instead
 # this Makefile provides many useful facilities to develop Coq
 # it is not completely compatible with .ml4 files unfortunately
 
@@ -17,7 +17,7 @@ test-dir:
 	@echo TOPDIR=$(TOPDIR)
 	@echo BASEDIR=$(BASEDIR)
 
-include $(TOPDIR)/dev/Makefile.common
+include $(TOPDIR)/dev/tools/Makefile.common
 
 # make this directory
 dir:
diff --git a/dev/tools/Makefile.subdir b/dev/tools/Makefile.subdir
new file mode 100644
index 00000000..cb914bd1
--- /dev/null
+++ b/dev/tools/Makefile.subdir
@@ -0,0 +1,7 @@
+# if you work in a sub/sub-rectory of Coq
+# you should make a link to that makefile 
+#    ln -s ../../dev/tools/Makefile.subdir Makefile
+# in order to have all the facilities of dev/tools/Makefile.dir
+
+TOPDIR=../..
+include $(TOPDIR)/dev/tools/Makefile.dir
diff --git a/dev/objects.el b/dev/tools/objects.el
index b3a2694d..b3a2694d 100644
--- a/dev/objects.el
+++ b/dev/tools/objects.el
diff --git a/dev/univdot b/dev/tools/univdot
index bb0dd2c8..bb0dd2c8 100755
--- a/dev/univdot
+++ b/dev/tools/univdot
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
index 1e314929..e1ee29e4 100644
--- a/dev/top_printers.ml
+++ b/dev/top_printers.ml
@@ -9,8 +9,8 @@
 (* Printers for the ocaml toplevel. *)
 
 open System
+open Util
 open Pp
-open Ast
 open Names
 open Libnames
 open Nameops
@@ -19,104 +19,113 @@ open Univ
 open Proof_trees
 open Environ
 open Printer
+open Tactic_printer
 open Refiner
-open Tacmach
 open Term
 open Termops
 open Clenv
 open Cerrors
-open Constrextern
-open Constrintern
+open Evd
+open Goptions
+open Genarg
+
 
 let _ = Constrextern.print_evar_arguments := true
+let _ = set_bool_option_value (SecondaryTable ("Printing","Matching")) false
+
+(* name printers *)
+let ppid id = pp (pr_id id)
+let pplab l = pp (pr_lab l)
+let ppmsid msid = pp (str (debug_string_of_msid msid))
+let ppmbid mbid = pp (str (debug_string_of_mbid mbid))
+let ppdir dir = pp (pr_dirpath dir)
+let ppmp mp = pp(str (string_of_mp mp))
+let ppcon con = pp(pr_con con)
+let ppkn kn = pp(pr_kn kn)
+let ppsp sp = pp(pr_sp sp)
+let ppqualid qid = pp(pr_qualid qid)
+
+(* term printers *)
+let ppconstr x = pp(Termops.print_constr x)
+let ppterm = ppconstr
+let ppsconstr x = ppconstr (Declarations.force x)
+let ppconstr_univ x = Constrextern.with_universes ppconstr x
+let pprawconstr = (fun x -> pp(pr_lrawconstr x))
+let pppattern = (fun x -> pp(pr_constr_pattern x))
+let pptype = (fun x -> pp(pr_ltype x))
+let ppfconstr c = ppconstr (Closure.term_of_fconstr c)
+
+let ppbigint n = pp (Bigint.pr_bigint n);;
+
+let ppidset l = pp (prlist_with_sep spc pr_id (Idset.elements l))
 
 let pP s = pp (hov 0 s)
 
-let prast c = pp(print_ast c)
-
-let prastpat c = pp(print_astpat c)
-let prastpatl c = pp(print_astlpat c)
-let ppterm x = pp(prterm x)
-let ppsterm x = ppterm (Declarations.force x)
-let ppterm_univ x = Constrextern.with_universes ppterm x
-let pprawterm = (fun x -> pp(pr_rawterm x))
-let pppattern = (fun x -> pp(pr_pattern x))
-let pptype = (fun x -> pp(prtype x))
-
-let safe_prglobal = function 
-  | ConstRef kn -> pp (str "CONSTREF(" ++ pr_kn kn ++ str ")")
+let safe_pr_global = function 
+  | ConstRef kn -> pp (str "CONSTREF(" ++ pr_con kn ++ str ")")
   | IndRef (kn,i) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ 
 			  int i ++ str ")")
   | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ 
 				      int i ++ str "," ++ int j ++ str ")")
   | VarRef id -> pp (str "VARREF(" ++ pr_id id ++ str ")")
 
-let prglobal x = try pp(pr_global x) with _ -> safe_prglobal x
-
-let prid id = pp (pr_id id)
-let prlab l = pp (pr_lab l)
-
-let prmsid msid = pp (str (debug_string_of_msid msid))
-let prmbid mbid = pp (str (debug_string_of_mbid mbid))
-
-let prdir dir = pp (pr_dirpath dir)
-
-let prmp mp = pp(str (string_of_mp mp))
-let prkn kn = pp(pr_kn kn)
-
-let prsp sp = pp(pr_sp sp)
+let ppglobal x = try pp(pr_global x) with _ -> safe_pr_global x
 
-let prqualid qid = pp(pr_qualid qid)
+let ppconst (sp,j) =
+    pp (str"#" ++ pr_kn sp ++ str"=" ++ pr_lconstr j.uj_val)
 
-let prconst (sp,j) =
-    pp (str"#" ++ pr_kn sp ++ str"=" ++ prterm j.uj_val)
+let ppvar ((id,a)) =
+    pp (str"#" ++ pr_id id ++ str":" ++ pr_lconstr a)
 
-let prvar ((id,a)) =
-    pp (str"#" ++ pr_id id ++ str":" ++ prterm a)
+let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t)
 
-let genprj f j = let (c,t) = f j in (c ++ str " : " ++ t)
+let ppj j = pp (genppj pr_ljudge j)
 
-let prj j = pp (genprj prjudge j)
+(* proof printers *)
+let ppevm evd = pp(pr_evar_map evd)
+let ppevd evd = pp(pr_evar_defs evd)
+let ppclenv clenv = pp(pr_clenv clenv)
+let ppgoal g = pp(db_pr_goal g)
 
-let prgoal g = pp(prgl g)
+let pr_gls gls =
+  hov 0 (pr_evar_map (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls))
 
-let prsigmagoal g = pp(prgl (sig_it g))
+let pr_glls glls =
+  hov 0 (pr_evar_map (sig_sig glls) ++ fnl () ++
+         prlist_with_sep pr_fnl db_pr_goal (sig_it glls))
 
+let ppsigmagoal g = pp(pr_goal (sig_it g))
 let prgls gls = pp(pr_gls gls)
-
 let prglls glls = pp(pr_glls glls)
-
 let pproof p = pp(print_proof Evd.empty empty_named_context p)
 
-let prevd evd = pp(pr_decls evd)
-
-let prevc evc = pp(pr_evc evc)
-
-let prwc wc = pp(pr_evc wc)
+let ppuni u = pp(pr_uni u)
 
-let prclenv clenv = pp(pr_clenv clenv)
-
-let print_uni u = (pp (pr_uni u))
-
-let pp_universes u = pp (str"[" ++ pr_universes u ++ str"]")
+let ppuniverses u = pp (str"[" ++ pr_universes u ++ str"]")
 
 let ppenv e = pp
   (str "[" ++ pr_named_context_of e ++ str "]" ++ spc() ++
    str "[" ++ pr_rel_context e (rel_context e) ++ str "]")
 
-let pptac = (fun x -> pp(Pptactic.pr_glob_tactic x))
+let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x))
 
-let pr_obj obj = Format.print_string (Libobject.object_tag obj)
+let ppobj obj = Format.print_string (Libobject.object_tag obj)
 
 let cnt = ref 0
 
+let cast_kind_display k = 
+  match k with
+  | VMcast -> "VMcast"
+  | DEFAULTcast -> "DEFAULTcast"
+
 let constr_display csr =
   let rec term_display c = match kind_of_term c with
   | Rel n -> "Rel("^(string_of_int n)^")"
   | Meta n -> "Meta("^(string_of_int n)^")"
   | Var id -> "Var("^(string_of_id id)^")"
   | Sort s -> "Sort("^(sort_display s)^")"
-  | Cast (c,t) -> "Cast("^(term_display c)^","^(term_display t)^")"
+  | Cast (c,k, t) -> 
+      "Cast("^(term_display c)^","^(cast_kind_display k)^","^(term_display t)^")"
   | Prod (na,t,c) ->
       "Prod("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n"
   | Lambda (na,t,c) ->
@@ -126,7 +135,7 @@ let constr_display csr =
       ^(term_display t)^","^(term_display c)^")"
   | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n"
   | Evar (e,l) -> "Evar("^(string_of_int e)^","^(array_display l)^")"
-  | Const c -> "Const("^(string_of_kn c)^")"
+  | Const c -> "Const("^(string_of_con c)^")"
   | Ind (sp,i) ->
       "MutInd("^(string_of_kn sp)^","^(string_of_int i)^")"
   | Construct ((sp,i),j) ->
@@ -138,9 +147,9 @@ let constr_display csr =
   | Fix ((t,i),(lna,tl,bl)) ->
       "Fix(([|"^(Array.fold_right (fun x i -> (string_of_int x)^(if not(i="")
         then (";"^i) else "")) t "")^"|],"^(string_of_int i)^"),"
-      ^(array_display tl)^","
+      ^(array_display tl)^",[|"
       ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="")
-        then (";"^i) else "")) lna "")^","
+        then (";"^i) else "")) lna "")^"|],"
       ^(array_display bl)^")"
   | CoFix(i,(lna,tl,bl)) ->
       "CoFix("^(string_of_int i)^"),"
@@ -177,7 +186,7 @@ let print_pure_constr csr =
   | Meta n -> print_string "Meta("; print_int n; print_string ")"
   | Var id -> print_string (string_of_id id)
   | Sort s -> sort_display s
-  | Cast (c,t) -> open_hovbox 1;
+  | Cast (c,_, t) -> open_hovbox 1;
       print_string "("; (term_display c); print_cut();
       print_string "::"; (term_display t); print_string ")"; close_box()
   | Prod (Name(id),t,c) ->
@@ -207,7 +216,7 @@ let print_pure_constr csr =
       Array.iter (fun x -> print_space (); box_display x) l;
       print_string"}"
   | Const c -> print_string "Cons(";
-      sp_display c;
+      sp_con_display c;
       print_string ")"
   | Ind (sp,i) ->
       print_string "Ind(";
@@ -231,11 +240,12 @@ let print_pure_constr csr =
       print_string "end"; 
       close_box()
   | Fix ((t,i),(lna,tl,bl)) ->
-      print_string "Fix("; print_int i; print_string ")"; 
+      print_string "Fix"
+(* "("; print_int i; print_string ")"; 
       print_cut();
       open_vbox 0;
       let rec print_fix () =
-        for k = 0 to Array.length tl - 1 do
+        for k = 0 to (Array.length tl) - 1 do
 	  open_vbox 0;
 	  name_display lna.(k); print_string "/"; 
 	  print_int t.(k); print_cut(); print_string ":";
@@ -243,13 +253,13 @@ let print_pure_constr csr =
 	  box_display bl.(k); close_box ();
 	  print_cut()
         done
-      in print_string"{"; print_fix(); print_string"}"
+      in print_string"{"; print_fix(); print_string"}" *)
   | CoFix(i,(lna,tl,bl)) ->
       print_string "CoFix("; print_int i; print_string ")"; 
       print_cut();
       open_vbox 0;
       let rec print_fix () =
-        for k = 0 to Array.length tl - 1 do
+        for k = 0 to (Array.length tl) - 1 do
           open_vbox 1;
 	  name_display lna.(k);  print_cut(); print_string ":";
 	  box_display tl.(k) ; print_cut(); print_string ":=";
@@ -279,27 +289,118 @@ let print_pure_constr csr =
 	| l             -> l
     in  List.iter (fun x -> print_string x; print_string ".") ls;*)
       print_string (string_of_kn sp)
+  and sp_con_display sp = 
+(*    let dir,l = decode_kn sp in
+    let ls = 
+      match List.rev (List.map string_of_id (repr_dirpath dir)) with 
+          ("Top"::l)-> l
+	| ("Coq"::_::l) -> l 
+	| l             -> l
+    in  List.iter (fun x -> print_string x; print_string ".") ls;*)
+      print_string (string_of_con sp)
 
   in
+    try 
      box_display csr; print_flush()
-(*
-let _ =
-  Vernacentries.add "PrintConstr"
-    (function
-       | [VARG_CONSTR c] -> 
-	   (fun () ->
-              let (evmap,sign) = Command.get_current_context () in
-  	      constr_display (Constrintern.interp_constr evmap sign c))
-       | _ -> bad_vernac_args "PrintConstr")
+    with e ->
+	print_string (Printexc.to_string e);print_flush ();
+	raise e
+
+let ppfconstr c = ppconstr (Closure.term_of_fconstr c)
+
+let pploc x = let (l,r) = unloc x in
+  print_string"(";print_int l;print_string",";print_int r;print_string")"
+
+(* extendable tactic arguments *)
+let rec pr_argument_type = function
+  (* Basic types *)
+  | BoolArgType -> str"bool"
+  | IntArgType -> str"int"
+  | IntOrVarArgType -> str"int-or-var"
+  | StringArgType -> str"string"
+  | PreIdentArgType -> str"pre-ident"
+  | IntroPatternArgType -> str"intro-pattern"
+  | IdentArgType -> str"ident"
+  | VarArgType -> str"var"
+  | RefArgType -> str"ref"
+  (* Specific types *)
+  | SortArgType -> str"sort"
+  | ConstrArgType -> str"constr"
+  | ConstrMayEvalArgType -> str"constr-may-eval"
+  | QuantHypArgType -> str"qhyp"
+  | OpenConstrArgType _ -> str"open-constr"
+  | ConstrWithBindingsArgType -> str"constr-with-bindings"
+  | BindingsArgType -> str"bindings"
+  | RedExprArgType -> str"redexp"
+  | List0ArgType t -> pr_argument_type t ++ str" list0"
+  | List1ArgType t -> pr_argument_type t ++ str" list1"
+  | OptArgType t -> pr_argument_type t ++ str" opt"
+  | PairArgType (t1,t2) ->
+      str"("++ pr_argument_type t1 ++ str"*" ++ pr_argument_type t2 ++str")"
+  | ExtraArgType s -> str"\"" ++ str s ++ str "\""
+
+let pp_argument_type t = pp (pr_argument_type t)
+
+let pp_generic_argument arg =
+  pp(str"<genarg:"++pr_argument_type(genarg_tag arg)++str">")
+
+(**********************************************************************)
+(* Vernac-level debugging commands                                    *)
+
+let in_current_context f c =
+  let (evmap,sign) = 
+    try Pfedit.get_current_goal_context ()
+    with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) in
+  f (Constrintern.interp_constr evmap sign c)
+
+(* We expand the result of preprocessing to be independent of camlp4
+
+VERNAC COMMAND EXTEND PrintPureConstr
+| [ "PrintPureConstr" constr(c) ] -> [ in_current_context print_pure_constr c ]
+END
+VERNAC COMMAND EXTEND PrintConstr
+  [ "PrintConstr" constr(c) ] -> [ in_current_context constr_display c ]
+END
+*)
+
+open Pcoq
+open Genarg
+open Egrammar
 
 let _ =
-  Vernacentries.add "PrintPureConstr"
-    (function
-       | [VARG_CONSTR c] -> 
-	   (fun () ->
-              let (evmap,sign) = Command.get_current_context () in
-  	      print_pure_constr (Constrintern.interp_constr evmap sign c))
-       | _ -> bad_vernac_args "PrintPureConstr")
-*)
+  try
+    Vernacinterp.vinterp_add "PrintConstr"
+      (function
+         [c] when genarg_tag c = ConstrArgType && true ->
+           let c = out_gen rawwit_constr c in
+           (fun () -> in_current_context constr_display c)
+       | _ -> failwith "Vernac extension: cannot occur")
+  with
+    e -> Pp.pp (Cerrors.explain_exn e)
+let _ =
+  extend_vernac_command_grammar "PrintConstr"
+    [[TacTerm "PrintConstr";
+      TacNonTerm
+        (dummy_loc,
+         (Gramext.Snterm (Pcoq.Gram.Entry.obj Constr.constr),
+          ConstrArgType),
+         Some "c")]]
 
-let ppfconstr c = ppterm (Closure.term_of_fconstr c)
+let _ =
+  try
+    Vernacinterp.vinterp_add "PrintPureConstr"
+      (function
+         [c] when genarg_tag c = ConstrArgType && true ->
+           let c = out_gen rawwit_constr c in
+           (fun () -> in_current_context print_pure_constr c)
+       | _ -> failwith "Vernac extension: cannot occur")
+  with
+    e -> Pp.pp (Cerrors.explain_exn e)
+let _ =
+  extend_vernac_command_grammar "PrintPureConstr"
+    [[TacTerm "PrintPureConstr";
+      TacNonTerm
+        (dummy_loc,
+         (Gramext.Snterm (Pcoq.Gram.Entry.obj Constr.constr),
+          ConstrArgType),
+         Some "c")]]
diff --git a/dev/v8-syntax/check-grammar b/dev/v8-syntax/check-grammar
new file mode 100755
index 00000000..67da1bc5
--- /dev/null
+++ b/dev/v8-syntax/check-grammar
@@ -0,0 +1,50 @@
+#!/bin/bash
+# This scripts checks that the new grammar of Coq as defined in syntax-v8.tex
+# is consistent in the sense that all invoked non-terminals are defined
+
+defined-nt() {
+  grep "\\DEFNT{.*}" syntax-v8.tex | sed -e "s|.*DEFNT{\([^}]*\)}.*|\1|"|\
+    sort | sort -u
+}
+
+used-nt() {
+  cat syntax-v8.tex | tr \\\\ \\n | grep "^NT{.*}" |\
+    sed -e "s|^NT{\([^}]*\)}.*|\1|" | egrep -v ^\#1\|non-terminal | sort -u
+}
+
+used-term() {
+  cat syntax-v8.tex | tr \\\\ \\n | grep "^TERM{.*}" |\
+    sed -e "s|^TERM{\([^}]*\)}.*|\1|" -e "s|\\$||g" | egrep -v ^\#1\|terminal | sort -u
+}
+
+used-kwd() {
+  cat syntax-v8.tex | tr \\\\ \\n | grep "^KWD{.*}" |\
+    sed -e "s|^KWD{\([^}]*\)}.*|\1|" -e "s|\\$||g" | egrep -v ^\#1 | sort -u
+}
+
+defined-nt > def
+used-nt > use
+used-term > use-t
+used-kwd > use-k
+diff def use > df
+
+###############################
+echo
+if grep ^\> df > /dev/null 2>&1 ; then
+  echo Undefined non-terminals:
+  echo ========================
+  echo
+  grep ^\> df | sed -e "s|^> ||"
+  echo
+fi
+if grep ^\< df > /dev/null 2>&1 ; then
+  echo Unused non-terminals:
+  echo =====================
+  echo
+  grep ^\< df | sed -e "s|^< ||"
+  echo
+fi
+#echo Used terminals:
+#echo ===============
+#echo
+#cat use-t
\ No newline at end of file
diff --git a/dev/v8-syntax/memo-v8.tex b/dev/v8-syntax/memo-v8.tex
new file mode 100644
index 00000000..8d116de2
--- /dev/null
+++ b/dev/v8-syntax/memo-v8.tex
@@ -0,0 +1,286 @@
+
+\documentclass{article}
+
+\usepackage{verbatim}
+\usepackage{amsmath}
+\usepackage{amssymb}
+\usepackage{array}
+\usepackage{fullpage}
+
+\author{B.~Barras}
+\title{An introduction to syntax of Coq V8}
+
+%% Le _ est un caractère normal
+\catcode`\_=13
+\let\subscr=_
+\def_{\ifmmode\sb\else\subscr\fi}
+
+\def\NT#1{\langle\textit{#1}\rangle}
+\def\NTL#1#2{\langle\textit{#1}\rangle_{#2}}
+\def\TERM#1{\textsf{\bf #1}}
+
+\newenvironment{transbox}
+  {\begin{center}\tt\begin{tabular}{l|ll} \hfil\textrm{V7} & \hfil\textrm{V8} \\ \hline}
+  {\end{tabular}\end{center}}
+\def\TRANS#1#2
+  {\begin{tabular}[t]{@{}l@{}}#1\end{tabular} & 
+   \begin{tabular}[t]{@{}l@{}}#2\end{tabular} \\}
+\def\TRANSCOM#1#2#3
+  {\begin{tabular}[t]{@{}l@{}}#1\end{tabular} & 
+   \begin{tabular}[t]{@{}l@{}}#2\end{tabular} & #3 \\}
+
+\begin{document}
+
+\maketitle
+
+The goal of this document is to introduce by example to the new syntax of
+Coq. It is strongly recommended to read first the definition of the new
+syntax, but this document should also be useful for the eager user who wants
+to start with the new syntax quickly.
+
+
+\section{Changes in lexical conventions w.r.t. V7}
+
+\subsection{Identifiers}
+
+The lexical conventions changed: \TERM{_} is not a regular identifier
+anymore. It is used in terms as a placeholder for subterms to be inferred
+at type-checking, and in patterns as a non-binding variable.
+
+Furthermore, only letters (unicode letters), digits, single quotes and
+_ are allowed after the first character.
+
+\subsection{Quoted string}
+
+Quoted strings are used typically to give a filename (which may not
+be a regular identifier). As before they are written between double
+quotes ("). Unlike for V7, there is no escape character: characters
+are written normaly but the double quote which is doubled.
+
+\section{Main changes in terms w.r.t. V7}
+
+
+\subsection{Precedence of application}
+
+In the new syntax, parentheses are not really part of the syntax of
+application. The precedence of application (10) is tighter than all
+prefix and infix notations. It makes it possible to remove parentheses
+in many contexts.
+
+\begin{transbox}
+\TRANS{(A x)->(f x)=(g y)}{A x -> f x = g y}
+\TRANS{(f [x]x)}{f (fun x => x)}
+\end{transbox}
+
+
+\subsection{Arithmetics and scopes}
+
+The specialized notation for \TERM{Z} and \TERM{R} (introduced by
+symbols \TERM{`} and \TERM{``}) have disappeared. They have been
+replaced by the general notion of scope.
+
+\begin{center}
+\begin{tabular}{l|l|l}
+type & scope name & delimiter \\
+\hline
+types & type_scope & \TERM{T} \\
+\TERM{bool} & bool_scope & \\
+\TERM{nat} & nat_scope & \TERM{nat} \\
+\TERM{Z} & Z_scope & \TERM{Z} \\
+\TERM{R} & R_scope & \TERM{R} \\
+\TERM{positive} & positive_scope & \TERM{P}
+\end{tabular}
+\end{center}
+
+In order to use notations of arithmetics on \TERM{Z}, its scope must be opened with command \verb+Open Scope Z_scope.+ Another possibility is using the scope change notation (\TERM{\%}). The latter notation is to be used when notations of several scopes appear in the same expression.
+
+In examples below, scope changes are not needed if the appropriate scope
+has been opened. Scope nat_scope is opened in the initial state of Coq.
+\begin{transbox}
+\TRANSCOM{`0+x=x+0`}{0+x=x+0}{\textrm{Z_scope}}
+\TRANSCOM{``0 + [if b then ``1`` else ``2``]``}{0 + if b then 1 else 2}{\textrm{R_scope}}
+\TRANSCOM{(0)}{0}{\textrm{nat_scope}}
+\end{transbox}
+
+Below is a table that tells which notation is available in which
+scope. The relative precedences and associativity of operators is the
+same as in usual mathematics. See the reference manual for more
+details. However, it is important to remember that unlike V7, the type
+operators for product and sum are left associative, in order not to
+clash with arithmetic operators.
+
+\begin{center}
+\begin{tabular}{l|l}
+scope & notations \\
+\hline
+nat_scope & $+ ~- ~* ~< ~\leq ~> ~\geq$ \\
+Z_scope & $+ ~- ~* ~/ ~\TERM{mod} ~< ~\leq ~> ~\geq ~?=$ \\
+R_scope & $+ ~- ~* ~/ ~< ~\leq ~> ~\geq$ \\
+type_scope & $* ~+$ \\
+bool_scope & $\TERM{\&\&} ~\TERM{$||$} ~\TERM{-}$ \\
+list_scope & $\TERM{::} ~\TERM{++}$
+\end{tabular}
+\end{center}
+(Note: $\leq$ is written \TERM{$<=$})
+
+
+
+\subsection{Notation for implicit arguments}
+
+The explicitation of arguments is closer to the \emph{bindings} notation in
+tactics. Argument positions follow the argument names of the head constant.
+
+\begin{transbox}
+\TRANS{f 1!t1 2!t2}{f (x:=t1) (y:=t2)}
+\TRANS{!f t1 t2}{@f t1 t2}
+\end{transbox}
+
+
+\subsection{Universal quantification}
+
+The universal quantification and dependent product types are now
+materialized with the \TERM{forall} keyword before the binders and a
+comma after the binders.
+
+The syntax of binders also changed significantly. A binder can simply be
+a name when its type can be inferred. In other cases, the name and the type
+of the variable are put between parentheses. When several consecutive
+variables have the same type, they can be grouped. Finally, if all variables
+have the same type parentheses can be omitted.
+
+\begin{transbox}
+\TRANS{(x:A)B}{forall (x:~A), B ~~\textrm{or}~~ forall x:~A, B}
+\TRANS{(x,y:nat)P}{forall (x y :~nat), P ~~\textrm{or}~~ forall x y :~nat, P}
+\TRANS{(x,y:nat;z:A)P}{forall (x y :~nat) (z:A), P}
+\TRANS{(x,y,z,t:?)P}{forall x y z t, P}
+\TRANS{(x,y:nat;z:?)P}{forall (x y :~nat) z, P}
+\end{transbox}
+
+\subsection{Abstraction}
+
+The notation for $\lambda$-abstraction follows that of universal
+quantification. The binders are surrounded by keyword \TERM{fun}
+and $\Rightarrow$ (\verb+=>+ in ascii).
+
+\begin{transbox}
+\TRANS{[x,y:nat; z](f a b c)}{fun (x y:nat) z => f a b c}
+\end{transbox}
+
+
+\subsection{Pattern-matching}
+
+Beside the usage of the keyword pair \TERM{match}/\TERM{with} instead of
+\TERM{Cases}/\TERM{of}, the main change is the notation for the type of
+branches and return type. It is no longer written between \TERM{$<$ $>$} before
+the \TERM{Cases} keyword, but interleaved with the destructured objects.
+
+The idea is that for each destructured object, one may specify a variable
+name to tell how the branches types depend on this destructured objects (case
+of a dependent elimination), and also how they depend on the value of the
+arguments of the inductive type of the destructured objects. The type of
+branches is then given after the keyword \TERM{return}, unless it can be
+inferred.
+
+Moreover, when the destructured object is a variable, one may use this
+variable in the return type.
+
+\begin{transbox}
+\TRANS{Cases n of\\~~ O => O \\| (S k) => (1) end}{match n with\\~~ 0 => 0 \\| (S k) => 1 end}
+\TRANS{Cases m n of \\~~0 0 => t \\| ... end}{match m, n with \\~~0, 0 => t \\| .. end}
+\TRANS{<[n:nat](P n)>Cases T of ... end}{match T as n return P n with ... end}
+\TRANS{<[n:nat][p:(even n)]\~{}(odd n)>Cases p of\\~~ ... \\end}{match p in even n return \~{} odd n with\\~~ ...\\end}
+\end{transbox}
+
+
+\subsection{Fixpoints and cofixpoints}
+
+An easier syntax for non-mutual fixpoints is provided, making it very close
+to the usual notation for non-recursive functions. The decreasing argument
+is now indicated by an annotation between curly braces, regardless of the
+binders grouping. The annotation can be omitted if the binders introduce only
+one variable. The type of the result can be omitted if inferable.
+
+\begin{transbox}
+\TRANS{Fix plus\{plus [n:nat] : nat -> nat :=\\~~ [m]...\}}{fix plus (n m:nat) \{struct n\}: nat := ...}
+\TRANS{Fix fact\{fact [n:nat]: nat :=\\
+~~Cases n of\\~~~~ O => (1) \\~~| (S k) => (mult n (fact k)) end\}}{fix fact
+  (n:nat) :=\\
+~~match n with \\~~~~0 => 1 \\~~| (S k) => n * fact k end}
+\end{transbox}
+
+There is a syntactic sugar for mutual fixpoints associated to a local
+definition:
+
+\begin{transbox}
+\TRANS{let f := Fix f \{f [x:A] : T := M\} in\\(g (f y))}{let fix f (x:A) : T := M in\\g (f x)}
+\end{transbox}
+
+The same applies to cofixpoints, annotations are not allowed in that case.
+
+\subsection{Notation for type cast}
+
+\begin{transbox}
+\TRANS{O :: nat}{0 : nat}
+\end{transbox}
+
+\section{Main changes in tactics w.r.t. V7}
+
+The main change is that all tactic names are lowercase. This also holds for
+Ltac keywords.
+
+\subsection{Ltac}
+
+Definitions of macros are introduced by \TERM{Ltac} instead of
+\TERM{Tactic Definition}, \TERM{Meta Definition} or \TERM{Recursive
+Definition}.
+
+Rules of a match command are not between square brackets anymore.
+
+Context (understand a term with a placeholder) instantiation \TERM{inst}
+became \TERM{context}. Syntax is unified with subterm matching.
+
+\begin{transbox}
+\TRANS{match t with [C[x=y]] => inst C[y=x]}{match t with context C[x=y] => context C[y=x]}
+\end{transbox}
+
+\subsection{Named arguments of theorems}
+
+\begin{transbox}
+\TRANS{Apply thm with x:=t 1:=u}{apply thm with (x:=t) (1:=u)}
+\end{transbox}
+
+
+\subsection{Occurrences}
+
+To avoid ambiguity between a numeric literal and the optionnal
+occurence numbers of this term, the occurence numbers are put after
+the term itself. This applies to tactic \TERM{pattern} and also
+\TERM{unfold}
+\begin{transbox}
+\TRANS{Pattern 1 2 (f x) 3 4 d y z}{pattern (f x at 1 2) (d at 3 4) y z}
+\end{transbox}
+
+\section{Main changes in vernacular commands w.r.t. V7}
+
+
+\subsection{Binders}
+
+The binders of vernacular commands changed in the same way as those of
+fixpoints. This also holds for parameters of inductive definitions.
+
+
+\begin{transbox}
+\TRANS{Definition x [a:A] : T := M}{Definition x (a:A) : T := M}
+\TRANS{Inductive and [A,B:Prop]: Prop := \\~~conj : A->B->(and A B)}%
+      {Inductive and (A B:Prop): Prop := \\~~conj : A -> B -> and A B}
+\end{transbox}
+
+\subsection{Hints}
+
+The syntax of \emph{extern} hints changed: the pattern and the tactic
+to be applied are separated by a \TERM{$\Rightarrow$}.
+\begin{transbox}
+\TRANS{Hint Extern 4 (toto ?) Apply lemma}{Hint Extern 4 (toto _) => apply lemma}
+\end{transbox}
+
+\end{document}
diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex
new file mode 100644
index 00000000..97973df2
--- /dev/null
+++ b/dev/v8-syntax/syntax-v8.tex
@@ -0,0 +1,1268 @@
+
+\documentclass{article}
+
+\usepackage{verbatim}
+\usepackage{amsmath}
+\usepackage{amssymb}
+\usepackage{array}
+\usepackage{fullpage}
+
+\author{B.~Barras}
+\title{Syntax of Coq V8}
+
+%% Le _ est un caractère normal
+\catcode`\_=13
+\let\subscr=_
+\def_{\ifmmode\sb\else\subscr\fi}
+
+\def\bfbar{\ensuremath{|\hskip -0.22em{}|\hskip -0.24em{}|}}
+\def\TERMbar{\bfbar}
+\def\TERMbarbar{\bfbar\bfbar}
+\def\notv{\text{_}}
+\def\infx#1{\notv#1\notv}
+
+
+%% Macros pour les grammaires
+\def\GR#1{\text{\large(}#1\text{\large)}}
+\def\NT#1{\langle\textit{#1}\rangle}
+\def\NTL#1#2{\langle\textit{#1}\rangle_{#2}}
+\def\TERM#1{{\bf\textrm{\bf #1}}}
+%\def\TERM#1{{\bf\textsf{#1}}}
+\def\KWD#1{\TERM{#1}}
+\def\ETERM#1{\TERM{#1}}
+\def\CHAR#1{\TERM{#1}}
+
+\def\STAR#1{#1*}
+\def\STARGR#1{\GR{#1}*}
+\def\PLUS#1{#1+}
+\def\PLUSGR#1{\GR{#1}+}
+\def\OPT#1{#1?}
+\def\OPTGR#1{\GR{#1}?}
+%% Tableaux de definition de non-terminaux
+\newenvironment{cadre}
+        {\begin{array}{|c|}\hline\\}
+        {\\\\\hline\end{array}}
+\newenvironment{rulebox}
+        {$$\begin{cadre}\begin{array}{r@{~}c@{~}l@{}l@{}r}}
+        {\end{array}\end{cadre}$$}
+\def\DEFNT#1{\NT{#1} & ::= &}
+\def\EXTNT#1{\NT{#1} & ::= & ... \\&|&}
+\def\RNAME#1{(\textsc{#1})}
+\def\SEPDEF{\\\\}
+\def\nlsep{\\&|&}
+\def\nlcont{\\&&}
+\newenvironment{rules}
+        {\begin{center}\begin{rulebox}}
+        {\end{rulebox}\end{center}}
+
+\begin{document}
+
+\maketitle
+
+\section{Meta notations used in this document}
+
+Non-terminals are printed between angle brackets (e.g. $\NT{non-terminal}$) and
+terminal symbols are printed in bold font (e.g. $\ETERM{terminal}$). Lexemes
+are displayed as non-terminals.
+
+The usual operators on regular expressions:
+\begin{center}
+\begin{tabular}{l|l}
+\hfil notation & \hfil  meaning \\
+\hline
+$\STAR{regexp}$ & repeat $regexp$ 0 or more times \\
+$\PLUS{regexp}$ & repeat $regexp$ 1 or more times \\
+$\OPT{regexp}$ & $regexp$ is optional \\
+$regexp_1~\mid~regexp_2$ & alternative
+\end{tabular}
+\end{center}
+
+Parenthesis are used to group regexps. Beware to distinguish this operator
+$\GR{~}$ from the terminals $\ETERM{( )}$, and $\mid$ from terminal
+\TERMbar.
+
+Rules are optionaly annotated in the right margin with:
+\begin{itemize}
+\item a precedence and associativity (L for left, R for right and N for no associativity), indicating how to solve conflicts;
+  lower levels are tighter;
+\item a rule name.
+\end{itemize}
+In order to solve some conflicts, a non-terminal may be invoked with a
+precedence (notation: $\NTL{entry}{prec}$), meaning that rules with higher
+precedence do not apply.
+
+\section{Lexical conventions}
+
+Lexical categories are:
+\begin{rules}
+\DEFNT{ident}
+     \STARGR{\NT{letter}\mid\CHAR{_}}
+     \STARGR{\NT{letter}\mid \NT{digit} \mid \CHAR{'} \mid \CHAR{_}}
+\SEPDEF
+\DEFNT{field}       \CHAR{.}\NT{ident}
+\SEPDEF
+\DEFNT{meta-ident}  \CHAR{?}\NT{ident}   
+\SEPDEF
+\DEFNT{num}         \PLUS{\NT{digit}}
+\SEPDEF
+\DEFNT{int}         \NT{num} \mid \CHAR{-}\NT{num}
+\SEPDEF
+\DEFNT{digit}       \CHAR{0}-\CHAR{9}
+\SEPDEF
+\DEFNT{letter}      \CHAR{a}-\CHAR{z}\mid\CHAR{A}-\CHAR{Z}
+                    \mid\NT{unicode-letter}
+
+\SEPDEF
+\DEFNT{string}      \CHAR{"}~\STARGR{\CHAR{""}\mid\NT{unicode-char-but-"}}~\CHAR{"}
+\end{rules}
+
+Reserved identifiers for the core syntax are:
+\begin{quote}
+\KWD{as},
+\KWD{cofix},
+\KWD{else},
+\KWD{end},
+\KWD{fix},
+\KWD{for},
+\KWD{forall},
+\KWD{fun},
+\KWD{if},
+\KWD{in},
+\KWD{let},
+\KWD{match}, 
+\KWD{Prop},
+\KWD{return}, 
+\KWD{Set},
+\KWD{then},
+\KWD{Type},
+\KWD{with}  
+\end{quote}
+
+Symbols used in the core syntax:
+$$ \KWD{(}
+~~ \KWD{)}
+~~ \KWD{\{}
+~~ \KWD{\}}
+~~ \KWD{:}
+~~ \KWD{,}
+~~ \Rightarrow
+~~ \rightarrow
+~~ \KWD{:=}
+~~ \KWD{_}
+~~ \TERMbar
+~~ \KWD{@}
+~~ \KWD{\%}
+~~ \KWD{.(}
+$$
+
+Note that \TERM{struct} is not a reserved identifier.
+
+\section{Syntax of terms}
+
+\subsection{Core syntax}
+
+The main entry point of the term grammar is $\NTL{constr}{9}$. When no
+conflict can appear, $\NTL{constr}{200}$ is also used as entry point.
+
+\begin{rules}
+\DEFNT{constr}
+       \NT{binder-constr}                             &200R~~ &\RNAME{binders}
+\nlsep \NT{constr}~\KWD{:}~\NT{constr}                &100R &\RNAME{cast}
+\nlsep \NT{constr}~\KWD{:}~\NT{binder-constr}         &100R &\RNAME{cast'}
+\nlsep \NT{constr}~\KWD{$\rightarrow$}~\NT{constr}    &80R  &\RNAME{arrow}
+\nlsep \NT{constr}~\KWD{$\rightarrow$}~\NT{binder-constr} &80R &\RNAME{arrow'}
+\nlsep \NT{constr}~\PLUS{\NT{appl-arg}}               &10L  &\RNAME{apply}
+\nlsep \KWD{@}~\NT{reference}~\STAR{\NTL{constr}{9}}  &10L  &\RNAME{expl-apply}
+\nlsep \NT{constr}~\KWD{.(}
+       ~\NT{reference}~\STAR{\NT{appl-arg}}~\TERM{)}  &1L & \RNAME{proj}
+\nlsep \NT{constr}~\KWD{.(}~\TERM{@}
+       ~\NT{reference}~\STAR{\NTL{constr}{9}}~\TERM{)} &1L & \RNAME{expl-proj}
+\nlsep \NT{constr} ~ \KWD{\%} ~ \NT{ident}            &1L   &\RNAME{scope-chg}
+\nlsep \NT{atomic-constr}                             &0
+\nlsep \NT{match-expr}                                &0
+\nlsep \KWD{(}~\NT{constr}~\KWD{)}                    &0
+\SEPDEF
+\DEFNT{binder-constr}
+       \KWD{forall}~\NT{binder-list}~\KWD{,}~\NTL{constr}{200} 
+          &&\RNAME{prod}
+\nlsep \KWD{fun} ~\NT{binder-list} ~\KWD{$\Rightarrow$}~\NTL{constr}{200}
+          &&\RNAME{lambda}
+\nlsep \NT{fix-expr}
+\nlsep \KWD{let}~\NT{ident-with-params} ~\KWD{:=}~\NTL{constr}{200}
+       ~\KWD{in}~\NTL{constr}{200}  &&\RNAME{let}
+\nlsep \KWD{let}~\NT{single-fix} ~\KWD{in}~\NTL{constr}{200}
+          &&\RNAME{rec-let}
+\nlsep \KWD{let}~\KWD{(}~\OPT{\NT{let-pattern}}~\KWD{)}~\OPT{\NT{return-type}}
+       ~\KWD{:=}~\NTL{constr}{200}~\KWD{in}~\NTL{constr}{200}
+          &&\RNAME{let-case}
+\nlsep \KWD{if}~\NT{if-item}
+       ~\KWD{then}~\NTL{constr}{200}~\KWD{else}~\NTL{constr}{200}
+          &&\RNAME{if-case}
+\SEPDEF
+\DEFNT{appl-arg}
+       \KWD{(}~\NT{ident}~\!\KWD{:=}~\NTL{constr}{200}~\KWD{)}
+          &&\RNAME{impl-arg}
+\nlsep \KWD{(}~\NT{num}~\!\KWD{:=}~\NTL{constr}{200}~\KWD{)}
+          &&\RNAME{impl-arg}
+\nlsep \NTL{constr}{9}
+\SEPDEF
+\DEFNT{atomic-constr}
+       \NT{reference}     && \RNAME{variables}
+\nlsep \NT{sort}          && \RNAME{CIC-sort}
+\nlsep \NT{num}           && \RNAME{number}
+\nlsep \KWD{_}            && \RNAME{hole}
+\nlsep \NT{meta-ident}    && \RNAME{meta/evar}
+\end{rules}
+
+
+
+\begin{rules}
+\DEFNT{ident-with-params}
+       \NT{ident}~\STAR{\NT{binder-let}}~\NT{type-cstr}
+\SEPDEF
+\DEFNT{binder-list}
+       \NT{binder}~\STAR{\NT{binder-let}}
+\nlsep \PLUS{\NT{name}}~\KWD{:}~\NT{constr}
+\SEPDEF
+\DEFNT{binder}
+       \NT{name}      &&\RNAME{infer}
+\nlsep \KWD{(}~\PLUS{\NT{name}}~\KWD{:}~\NT{constr}
+       ~\KWD{)}      &&\RNAME{binder}
+\SEPDEF
+\DEFNT{binder-let}
+       \NT{binder}
+\nlsep \KWD{(}~\NT{name}~\NT{type-cstr}~\KWD{:=}~\NT{constr}~\KWD{)}
+\SEPDEF
+\DEFNT{let-pattern}
+       \NT{name}
+\nlsep \NT{name} ~\KWD{,} ~\NT{let-pattern}
+\SEPDEF
+\DEFNT{type-cstr}
+       \OPTGR{\KWD{:}~\NT{constr}}
+\SEPDEF
+\DEFNT{reference}
+       \NT{ident}                   && \RNAME{short-ident}
+\nlsep \NT{ident}~\PLUS{\NT{field}} && \RNAME{qualid}
+\SEPDEF
+\DEFNT{sort}
+       \KWD{Prop} ~\mid~ \KWD{Set} ~\mid~ \KWD{Type}
+\SEPDEF
+\DEFNT{name}
+       \NT{ident} ~\mid~ \KWD{_}
+\end{rules}
+
+\begin{rules}
+\DEFNT{fix-expr}
+       \NT{single-fix}
+\nlsep \NT{single-fix}~\PLUSGR{\KWD{with}~\NT{fix-decl}}
+      ~\KWD{for}~\NT{ident}
+\SEPDEF
+\DEFNT{single-fix}
+       \NT{fix-kw}~\NT{fix-decl}
+\SEPDEF
+\DEFNT{fix-kw} \KWD{fix} ~\mid~ \KWD{cofix}
+\SEPDEF
+\DEFNT{fix-decl}
+       \NT{ident}~\STAR{\NT{binder-let}}~\OPT{\NT{annot}}~\NT{type-cstr}
+       ~\KWD{:=}~\NTL{constr}{200}
+\SEPDEF
+\DEFNT{annot}
+       \KWD{\{}~\TERM{struct}~\NT{ident}~\KWD{\}}
+\end{rules}
+
+
+\begin{rules}
+\DEFNT{match-expr}
+       \KWD{match}~\NT{match-items}~\OPT{\NT{return-type}}~\KWD{with}
+  ~\OPT{\TERMbar}~\OPT{\NT{branches}}~\KWD{end}        &&\RNAME{match}
+\SEPDEF
+\DEFNT{match-items}
+       \NT{match-item} ~\KWD{,} ~\NT{match-items}
+\nlsep \NT{match-item}
+\SEPDEF
+\DEFNT{match-item}
+       \NTL{constr}{100}~\OPTGR{\KWD{as}~\NT{name}}
+       ~\OPTGR{\KWD{in}~\NTL{constr}{100}}
+\SEPDEF
+\DEFNT{return-type}
+       \KWD{return}~\NTL{constr}{100}
+\SEPDEF
+\DEFNT{if-item}
+       \NT{constr}~\OPTGR{\OPTGR{\KWD{as}~\NT{name}}~\NT{return-type}}
+\SEPDEF
+\DEFNT{branches}
+       \NT{eqn}~\TERMbar~\NT{branches}
+\nlsep \NT{eqn}
+\SEPDEF
+\DEFNT{eqn}
+       \NT{pattern} ~\STARGR{\KWD{,}~\NT{pattern}}
+       ~\KWD{$\Rightarrow$}~\NT{constr}
+\SEPDEF
+\DEFNT{pattern}
+       \NT{reference}~\PLUS{\NT{pattern}}  &1L~~ & \RNAME{constructor}
+\nlsep \NT{pattern}~\KWD{as}~\NT{ident}    &1L & \RNAME{alias}
+\nlsep \NT{pattern}~\KWD{\%}~\NT{ident}    &1L & \RNAME{scope-change}
+\nlsep \NT{reference}                      &0  & \RNAME{pattern-var}
+\nlsep \KWD{_}                             &0  & \RNAME{hole}
+\nlsep \NT{num}                            &0
+\nlsep \KWD{(}~\NT{tuple-pattern}~\KWD{)}
+\SEPDEF
+\DEFNT{tuple-pattern}
+       \NT{pattern}
+\nlsep \NT{tuple-pattern}~\KWD{,}~\NT{pattern} && \RNAME{pair}
+\end{rules}
+
+\subsection{Notations of the prelude (logic and basic arithmetic)}
+
+Reserved notations:
+
+$$
+\begin{array}{l|c}
+\text{Symbol} & \text{precedence} \\
+\hline
+\infx{,}             & 250L \\
+\KWD{IF}~\notv~\KWD{then}~\notv~\KWD{else}~\notv
+                     & 200R \\
+\infx{:}             & 100R \\
+\infx{\leftrightarrow} & 95N \\
+\infx{\rightarrow}   & 90R \\
+\infx{\vee}          & 85R \\
+\infx{\wedge}        & 80R \\
+\tilde{}\notv        & 75R \\
+\begin{array}[c]{@{}l@{}}
+ \infx{=}\quad \infx{=}\KWD{$:>$}\notv \quad \infx{=}=\notv
+ \quad \infx{\neq} \quad  \infx{\neq}\KWD{$:>$}\notv \\
+ \infx{<}\quad\infx{>} \quad \infx{\leq}\quad\infx{\geq}
+ \quad \infx{<}<\notv \quad \infx{<}\leq\notv
+ \quad \infx{\leq}<\notv \quad \infx{\leq}\leq\notv
+\end{array}          & 70N \\
+\infx{+}\quad\infx{-}\quad -\notv   & 50L \\
+\infx{*}\quad\infx{/}\quad /\notv   & 40L \\
+\end{array}
+$$
+
+Existential quantifiers follows the \KWD{forall} notation (with same
+precedence 200), but only one quantified variable is allowed.
+
+\begin{rules}
+\EXTNT{binder-constr}
+       \NT{quantifier-kwd}~\NT{name}~\NT{type-cstr}~\KWD{,}~\NTL{constr}{200} \\
+\SEPDEF
+\DEFNT{quantifier-kwd}
+       \TERM{exists} && \RNAME{ex}
+\nlsep \TERM{exists2} && \RNAME{ex2}
+\end{rules}
+
+$$
+\begin{array}{l|c|l}
+\text{Symbol} & \text{precedence} \\
+\hline
+\notv+\{\notv\}                            & 50 & \RNAME{sumor} \\
+\{\notv:\notv~|~\notv\}                    & 0 & \RNAME{sig} \\
+\{\notv:\notv~|~\notv \& \notv \}          & 0 & \RNAME{sig2} \\
+\{\notv:\notv~\&~\notv \}                  & 0 & \RNAME{sigS} \\
+\{\notv:\notv~\&~\notv \& \notv \}         & 0 & \RNAME{sigS2} \\
+\{\notv\}+\{\notv\}                        & 0 & \RNAME{sumbool} \\
+\end{array}
+$$
+
+%% Strange: nat + {x:nat|x=x} * nat  == ( + ) *
+
+\section{Grammar of tactics}
+
+\def\tacconstr{\NTL{constr}{9}}
+\def\taclconstr{\NTL{constr}{200}}
+
+Additional symbols are:
+$$ \TERM{'}
+~~ \KWD{;}
+~~ \TERM{()}
+~~ \TERMbarbar
+~~ \TERM{$\vdash$}
+~~ \TERM{[}
+~~ \TERM{]}
+~~ \TERM{$\leftarrow$}
+$$
+Additional reserved keywords are:
+$$ \KWD{at}
+~~ \TERM{using}
+$$
+
+\subsection{Basic tactics}
+
+\begin{rules}
+\DEFNT{simple-tactic}
+       \TERM{intros}~\TERM{until}~\NT{quantified-hyp}
+\nlsep \TERM{intros}~\NT{intro-patterns}
+\nlsep \TERM{intro}~\OPT{\NT{ident}}~\OPTGR{\TERM{after}~\NT{ident}}
+%%
+\nlsep \TERM{assumption}
+\nlsep \TERM{exact}~\tacconstr
+%%
+\nlsep \TERM{apply}~\NT{constr-with-bindings}
+\nlsep \TERM{elim}~\NT{constr-with-bindings}~\OPT{\NT{eliminator}}
+\nlsep \TERM{elimtype}~\tacconstr
+\nlsep \TERM{case}~\NT{constr-with-bindings}
+\nlsep \TERM{casetype}~\tacconstr
+\nlsep \KWD{fix}~\OPT{\NT{ident}}~\NT{num}
+\nlsep \KWD{fix}~\NT{ident}~\NT{num}~\KWD{with}~\PLUS{\NT{fix-spec}}
+\nlsep \KWD{cofix}~\OPT{\NT{ident}}
+\nlsep \KWD{cofix}~\NT{ident}~\PLUS{\NT{fix-spec}}
+%%
+\nlsep \TERM{cut}~\tacconstr
+\nlsep \TERM{assert}~\tacconstr
+\nlsep \TERM{assert}~
+  \TERM{(}~\NT{ident}~\KWD{:}~\taclconstr~\TERM{)}
+\nlsep \TERM{assert}~
+  \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)}
+\nlsep \TERM{pose}~\tacconstr
+\nlsep \TERM{pose}~
+  \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)}
+\nlsep \TERM{generalize}~\PLUS{\tacconstr}
+\nlsep \TERM{generalize}~\TERM{dependent}~\tacconstr
+\nlsep \TERM{set}~\tacconstr~\OPT{\NT{clause}}
+\nlsep \TERM{set}~
+  \TERM{(}~\NT{ident}~\KWD{:=}~\taclconstr~\TERM{)}~\OPT{\NT{clause}}
+\nlsep \TERM{instantiate}~
+  \TERM{(}~\NT{num}~\TERM{:=}~\taclconstr~\TERM{)}~\OPT{\NT{clause}}
+%%
+\nlsep \TERM{specialize}~\OPT{\NT{num}}~\NT{constr-with-bindings}
+\nlsep \TERM{lapply}~\tacconstr
+%%
+\nlsep \TERM{simple}~\TERM{induction}~\NT{quantified-hyp}
+\nlsep \TERM{induction}~\NT{induction-arg}~\OPT{\NT{with-names}}
+       ~\OPT{\NT{eliminator}}
+\nlsep \TERM{double}~\TERM{induction}~\NT{quantified-hyp}~\NT{quantified-hyp}
+\nlsep \TERM{simple}~\TERM{destruct}~\NT{quantified-hyp}
+\nlsep \TERM{destruct}~\NT{induction-arg}~\OPT{\NT{with-names}}
+       ~\OPT{\NT{eliminator}}
+\nlsep \TERM{decompose}~\TERM{record}~\tacconstr
+\nlsep \TERM{decompose}~\TERM{sum}~\tacconstr
+\nlsep \TERM{decompose}~\TERM{[}~\PLUS{\NT{reference}}~\TERM{]}
+       ~\tacconstr
+%%
+\nlsep ...
+\end{rules}
+
+\begin{rules}
+\EXTNT{simple-tactic}
+       \TERM{trivial}~\OPT{\NT{hint-bases}}
+\nlsep \TERM{auto}~\OPT{\NT{num}}~\OPT{\NT{hint-bases}}
+%%
+%%\nlsep \TERM{autotdb}~\OPT{\NT{num}}
+%%\nlsep \TERM{cdhyp}~\NT{ident}
+%%\nlsep \TERM{dhyp}~\NT{ident}
+%%\nlsep \TERM{dconcl}
+%%\nlsep \TERM{superauto}~\NT{auto-args}
+\nlsep \TERM{auto}~\OPT{\NT{num}}~\TERM{decomp}~\OPT{\NT{num}}
+%%
+\nlsep \TERM{clear}~\PLUS{\NT{ident}}
+\nlsep \TERM{clearbody}~\PLUS{\NT{ident}}
+\nlsep \TERM{move}~\NT{ident}~\TERM{after}~\NT{ident}
+\nlsep \TERM{rename}~\NT{ident}~\TERM{into}~\NT{ident}
+%%
+\nlsep \TERM{left}~\OPT{\NT{with-binding-list}}
+\nlsep \TERM{right}~\OPT{\NT{with-binding-list}}
+\nlsep \TERM{split}~\OPT{\NT{with-binding-list}}
+\nlsep \TERM{exists}~\OPT{\NT{binding-list}}
+\nlsep \TERM{constructor}~\NT{num}~\OPT{\NT{with-binding-list}}
+\nlsep \TERM{constructor}~\OPT{\NT{tactic}}
+%%
+\nlsep \TERM{reflexivity}
+\nlsep \TERM{symmetry}~\OPTGR{\KWD{in}~\NT{ident}}
+\nlsep \TERM{transitivity}~\tacconstr
+%%
+\nlsep \NT{inversion-kwd}~\NT{quantified-hyp}~\OPT{\NT{with-names}}~\OPT{\NT{clause}}
+\nlsep \TERM{dependent}~\NT{inversion-kwd}~\NT{quantified-hyp}
+  ~\OPT{\NT{with-names}}~\OPTGR{\KWD{with}~\tacconstr}
+\nlsep \TERM{inversion}~\NT{quantified-hyp}~\TERM{using}~\tacconstr~\OPT{\NT{clause}}
+%%
+\nlsep \NT{red-expr}~\OPT{\NT{clause}}
+\nlsep \TERM{change}~\NT{conversion}~\OPT{\NT{clause}}
+\SEPDEF
+\DEFNT{red-expr}
+       \TERM{red} ~\mid~ \TERM{hnf} ~\mid~ \TERM{compute}
+\nlsep \TERM{simpl}~\OPT{\NT{pattern-occ}}
+\nlsep \TERM{cbv}~\PLUS{\NT{red-flag}}
+\nlsep \TERM{lazy}~\PLUS{\NT{red-flag}}
+\nlsep \TERM{unfold}~\NT{unfold-occ}~\STARGR{\KWD{,}~\NT{unfold-occ}}
+\nlsep \TERM{fold}~\PLUS{\tacconstr}
+\nlsep \TERM{pattern}~\NT{pattern-occ}~\STARGR{\KWD{,}~\NT{pattern-occ}}
+\SEPDEF
+\DEFNT{conversion}
+       \NT{pattern-occ}~\KWD{with}~\tacconstr
+\nlsep \tacconstr
+\SEPDEF
+\DEFNT{inversion-kwd}
+       \TERM{inversion} ~\mid~ \TERM{invesion_clear} ~\mid~
+       \TERM{simple}~\TERM{inversion}
+\end{rules}
+
+Conflicts exists between integers and constrs.
+
+\begin{rules}
+\DEFNT{quantified-hyp}
+       \NT{int}~\mid~\NT{ident}
+\SEPDEF
+\DEFNT{induction-arg}
+       \NT{int}~\mid~\tacconstr
+\SEPDEF
+\DEFNT{fix-spec}
+       \KWD{(}~\NT{ident}~\STAR{\NT{binder}}~\OPT{\NT{annot}}
+       ~\KWD{:}~\taclconstr~\KWD{)}
+\SEPDEF
+\DEFNT{intro-patterns}
+       \STAR{\NT{intro-pattern}}
+\SEPDEF
+\DEFNT{intro-pattern}
+       \NT{name}
+\nlsep \TERM{[}~\NT{intro-patterns}~\STARGR{\TERMbar~\NT{intro-patterns}}
+       ~\TERM{]}
+\nlsep \KWD{(}~\NT{intro-pattern}~\STARGR{\KWD{,}~\NT{intro-pattern}}
+       ~\KWD{)}
+\SEPDEF
+\DEFNT{with-names}
+%       \KWD{as}~\TERM{[}~\STAR{\NT{ident}}~\STARGR{\TERMbar~\STAR{\NT{ident}}}
+%       ~\TERM{]}
+       \KWD{as}~\NT{intro-pattern}
+\SEPDEF
+\DEFNT{eliminator}
+       \TERM{using}~\NT{constr-with-bindings}
+\SEPDEF
+\DEFNT{constr-with-bindings}
+       % dangling ``with'' of ``fix'' can conflict with ``with''
+       \tacconstr~\OPT{\NT{with-binding-list}}
+\SEPDEF
+\DEFNT{with-binding-list}
+       \KWD{with}~\NT{binding-list}
+\SEPDEF
+\DEFNT{binding-list}
+       \PLUS{\tacconstr}
+\nlsep \PLUS{\NT{simple-binding}}
+\SEPDEF
+\DEFNT{simple-binding}
+       \KWD{(}~\NT{quantified-hyp}~\KWD{:=}~\taclconstr~\KWD{)}
+\SEPDEF
+\DEFNT{red-flag}
+       \TERM{beta} ~\mid~ \TERM{iota} ~\mid~ \TERM{zeta}
+       ~\mid~ \TERM{delta} ~\mid~
+       \TERM{delta}~\OPT{\TERM{-}}~\TERM{[}~\PLUS{\NT{reference}}~\TERM{]}
+\SEPDEF
+\DEFNT{clause}
+       \KWD{in}~\TERM{*}
+\nlsep \KWD{in}~\TERM{*}~\KWD{$\vdash$}~\OPT{\NT{concl-occ}}
+\nlsep \KWD{in}~\OPT{\NT{hyp-ident-list}} ~\KWD{$\vdash$} ~\OPT{\NT{concl-occ}}
+\nlsep \KWD{in}~\OPT{\NT{hyp-ident-list}}
+\SEPDEF
+\DEFNT{hyp-ident-list}
+       \NT{hyp-ident}
+\nlsep \NT{hyp-ident}~\KWD{,}~\NT{hyp-ident-list}
+\SEPDEF
+\DEFNT{hyp-ident}
+       \NT{ident}
+\nlsep \KWD{(}~\TERM{type}~\TERM{of}~\NT{ident}~\KWD{)}
+\nlsep \KWD{(}~\TERM{value}~\TERM{of}~\NT{ident}~\KWD{)}
+\SEPDEF
+\DEFNT{concl-occ}
+       \TERM{*} ~\NT{occurrences}
+\SEPDEF
+\DEFNT{pattern-occ}
+       \tacconstr ~\NT{occurrences}
+\SEPDEF
+\DEFNT{unfold-occ}
+       \NT{reference}~\NT{occurrences}
+\SEPDEF
+\DEFNT{occurrences}
+       ~\OPTGR{\KWD{at}~\PLUS{\NT{int}}}
+\SEPDEF
+\DEFNT{hint-bases}
+       \KWD{with}~\TERM{*}
+\nlsep \KWD{with}~\PLUS{\NT{ident}}
+\SEPDEF
+\DEFNT{auto-args}
+       \OPT{\NT{num}}~\OPTGR{\TERM{adding}~\TERM{[}~\PLUS{\NT{reference}}
+       ~\TERM{]}}~\OPT{\TERM{destructuring}}~\OPTGR{\TERM{using}~\TERM{tdb}}
+\end{rules}
+
+\subsection{Ltac}
+
+%% Currently, there are conflicts with keyword \KWD{in}: in the following,
+%% has the keyword to be associated to \KWD{let} or to tactic \TERM{simpl} ?
+%% \begin{center}
+%% \texttt{let x := simpl in ...}
+%% \end{center}
+
+
+\begin{rules}
+\DEFNT{tactic}
+       \NT{tactic} ~\KWD{;} ~\NT{tactic}  &5 &\RNAME{Then}
+\nlsep \NT{tactic} ~\KWD{;}~\TERM{[} ~\OPT{\NT{tactic-seq}} ~\TERM{]}
+         &5 &\RNAME{Then-seq}
+%%
+\nlsep \TERM{try} ~\NT{tactic}     &3R &\RNAME{Try}
+\nlsep \TERM{do} ~\NT{int-or-var} ~\NT{tactic}
+\nlsep \TERM{repeat} ~\NT{tactic}
+\nlsep \TERM{progress} ~\NT{tactic}
+\nlsep \TERM{info} ~\NT{tactic}
+\nlsep \TERM{abstract}~\NTL{tactic}{2}~\OPTGR{\TERM{using}~\NT{ident}}
+%%
+\nlsep \NT{tactic} ~\TERMbarbar ~\NT{tactic} &2R &\RNAME{Orelse}
+%%
+\nlsep \KWD{fun} ~\PLUS{\NT{name}} ~\KWD{$\Rightarrow$}
+       ~\NT{tactic}  &1 &\RNAME{Fun-tac}
+\nlsep \KWD{let} ~\NT{let-clauses} ~\KWD{in} ~\NT{tactic}
+\nlsep \KWD{let} ~\TERM{rec} ~\NT{rec-clauses} ~\KWD{in} ~\NT{tactic}
+\nlsep \KWD{match}~\OPT{\TERM{reverse}}~\TERM{goal}~\KWD{with}
+       ~\OPT{\TERMbar}~\OPT{\NT{match-goal-rules}} ~\KWD{end}
+\nlsep \KWD{match} ~\NT{tactic} ~\KWD{with}
+       ~\OPT{\TERMbar}~\OPT{\NT{match-rules}} ~\KWD{end}
+\nlsep \TERM{first}~\TERM{[} ~\NT{tactic-seq} ~\TERM{]}
+\nlsep \TERM{solve}~\TERM{[} ~\NT{tactic-seq} ~\TERM{]}
+\nlsep \TERM{idtac}
+\nlsep \TERM{fail} ~\OPT{\NT{num}} ~\OPT{\NT{string}}
+\nlsep \TERM{constr}~\KWD{:}~\tacconstr
+\nlsep \TERM{ipattern}~\KWD{:}~\NT{intro-pattern}
+\nlsep \NT{term-ltac}
+\nlsep \NT{reference}~\STAR{\NT{tactic-arg}}  &&\RNAME{call-tactic}
+\nlsep \NT{simple-tactic}
+%%
+\nlsep \NT{tactic-atom}  &0 &\RNAME{atomic}
+\nlsep \KWD{(} ~\NT{tactic} ~\KWD{)}
+\SEPDEF
+\DEFNT{tactic-arg}
+       \TERM{ltac}~\KWD{:}~\NTL{tactic}{0}
+\nlsep \TERM{ipattern}~\KWD{:}~\NT{intro-pattern}
+\nlsep \NT{term-ltac}
+\nlsep \NT{tactic-atom}
+\nlsep \tacconstr
+\SEPDEF
+\DEFNT{term-ltac}
+       \TERM{fresh} ~\OPT{\NT{string}}
+\nlsep \TERM{context} ~\NT{ident} ~\TERM{[} ~\taclconstr ~\TERM{]}
+\nlsep \TERM{eval} ~\NT{red-expr} ~\KWD{in} ~\tacconstr
+\nlsep \TERM{type} ~\tacconstr
+\SEPDEF
+\DEFNT{tactic-atom}
+       \NT{reference}
+\nlsep \TERM{()}
+\SEPDEF
+\DEFNT{tactic-seq}
+       \NT{tactic} ~\TERMbar ~\NT{tactic-seq}
+\nlsep \NT{tactic}
+\end{rules}
+
+
+
+\begin{rules}
+\DEFNT{let-clauses}
+       \NT{let-clause} ~\STARGR{\KWD{with}~\NT{let-clause}}
+\SEPDEF
+\DEFNT{let-clause}
+       \NT{ident} ~\STAR{\NT{name}} ~\KWD{:=} ~\NT{tactic}
+\SEPDEF
+\DEFNT{rec-clauses}
+       \NT{rec-clause} ~\KWD{with} ~\NT{rec-clauses}
+\nlsep \NT{rec-clause}
+\SEPDEF
+\DEFNT{rec-clause}
+       \NT{ident} ~\PLUS{\NT{name}} ~\KWD{:=} ~\NT{tactic}
+\SEPDEF
+\DEFNT{match-goal-rules}
+       \NT{match-goal-rule}
+\nlsep \NT{match-goal-rule} ~\TERMbar ~\NT{match-goal-rules}
+\SEPDEF
+\DEFNT{match-goal-rule}
+       \NT{match-hyps-list} ~\TERM{$\vdash$} ~\NT{match-pattern}
+       ~\KWD{$\Rightarrow$} ~\NT{tactic}
+\nlsep \KWD{[}~\NT{match-hyps-list} ~\TERM{$\vdash$} ~\NT{match-pattern}
+       ~\KWD{]}~\KWD{$\Rightarrow$} ~\NT{tactic}
+\nlsep \KWD{_} ~\KWD{$\Rightarrow$} ~\NT{tactic}
+\SEPDEF
+\DEFNT{match-hyps-list}
+       \NT{match-hyps} ~\KWD{,} ~\NT{match-hyps-list}
+\nlsep \NT{match-hyps}
+\SEPDEF
+\DEFNT{match-hyps}
+       \NT{name} ~\KWD{:} ~\NT{match-pattern}
+\SEPDEF
+\DEFNT{match-rules}
+       \NT{match-rule}
+\nlsep \NT{match-rule} ~\TERMbar ~\NT{match-rules}
+\SEPDEF
+\DEFNT{match-rule}
+       \NT{match-pattern} ~\KWD{$\Rightarrow$} ~\NT{tactic}
+\nlsep \KWD{_} ~\KWD{$\Rightarrow$} ~\NT{tactic}
+\SEPDEF
+\DEFNT{match-pattern}
+       \TERM{context}~\OPT{\NT{ident}}
+       ~\TERM{[} ~\NT{constr-pattern} ~\TERM{]}  &&\RNAME{subterm}
+\nlsep \NT{constr-pattern}
+\SEPDEF
+\DEFNT{constr-pattern}
+       \tacconstr
+\end{rules}
+
+\subsection{Other tactics}
+
+\begin{rules}
+\EXTNT{simple-tactic}
+       \TERM{rewrite} ~\NT{orient} ~\NT{constr-with-bindings}
+         ~\OPTGR{\KWD{in}~\NT{ident}}
+\nlsep \TERM{replace} ~\tacconstr ~\KWD{with} ~\tacconstr
+         ~\OPTGR{\KWD{in}~\NT{ident}}
+\nlsep \TERM{replace} ~\OPT{\NT{orient}} ~\tacconstr
+         ~\OPTGR{\KWD{in}~\NT{ident}}
+\nlsep \TERM{symplify_eq} ~\OPT{\NT{quantified-hyp}}
+\nlsep \TERM{discriminate} ~\OPT{\NT{quantified-hyp}}
+\nlsep \TERM{injection} ~\OPT{\NT{quantified-hyp}}
+\nlsep \TERM{conditional}~\NT{tactic}~\TERM{rewrite}~\NT{orient}
+         ~\NT{constr-with-bindings}~\OPTGR{\KWD{in}~\NT{ident}}
+\nlsep \TERM{dependent}~\TERM{rewrite}~\NT{orient}~\NT{ident}
+\nlsep \TERM{cutrewrite}~\NT{orient}~\tacconstr
+         ~\OPTGR{\KWD{in}~\NT{ident}}
+\nlsep \TERM{absurd} ~\tacconstr
+\nlsep \TERM{contradiction}
+\nlsep \TERM{autorewrite}~\NT{hint-bases}~\OPTGR{\KWD{using}~\NT{tactic}}
+\nlsep \TERM{refine}~\tacconstr
+\nlsep \TERM{setoid_replace} ~\tacconstr ~\KWD{with} ~\tacconstr
+\nlsep \TERM{setoid_rewrite} ~\NT{orient} ~\tacconstr
+\nlsep \TERM{subst} ~\STAR{\NT{ident}}
+%% eqdecide.ml4
+\nlsep \TERM{decide}~\TERM{equality} ~\OPTGR{\tacconstr~\tacconstr}
+\nlsep \TERM{compare}~\tacconstr~\tacconstr
+%% eauto
+\nlsep \TERM{eexact}~\tacconstr
+\nlsep \TERM{eapply}~\NT{constr-with-bindings}
+\nlsep \TERM{prolog}~\TERM{[}~\STAR{\tacconstr}~\TERM{]}
+         ~\NT{quantified-hyp}
+\nlsep \TERM{eauto}~\OPT{\NT{quantified-hyp}}~\OPT{\NT{quantified-hyp}}
+         ~\NT{hint-bases}
+\nlsep \TERM{eautod}~\OPT{\NT{quantified-hyp}}~\OPT{\NT{quantified-hyp}}
+         ~\NT{hint-bases}
+%% tauto
+\nlsep \TERM{tauto}
+\nlsep \TERM{simplif}
+\nlsep \TERM{intuition}~\OPT{\NTL{tactic}{0}}
+\nlsep \TERM{linearintuition}~\OPT{\NT{num}}
+%% contrib/cc
+\nlsep \TERM{cc}
+%% contrib/field
+\nlsep \TERM{field}~\STAR{\tacconstr}
+%% contrib/first-order
+\nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}
+\nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}~\KWD{with}~\PLUS{\NT{reference}}
+\nlsep \TERM{ground}~\OPT{\NTL{tactic}{0}}~\KWD{using}~\PLUS{\NT{ident}}
+%%\nlsep \TERM{gtauto}
+\nlsep \TERM{gintuition}~\OPT{\NTL{tactic}{0}}
+%% contrib/fourier
+\nlsep \TERM{fourierZ}
+%% contrib/funind
+\nlsep \TERM{functional}~\TERM{induction}~\tacconstr~\PLUS{\tacconstr}
+%% contrib/jprover
+\nlsep \TERM{jp}~\OPT{\NT{num}}
+%% contrib/omega
+\nlsep \TERM{omega}
+%% contrib/ring
+\nlsep \TERM{quote}~\NT{ident}~\OPTGR{\KWD{[}~\PLUS{\NT{ident}}~\KWD{]}}
+\nlsep \TERM{ring}~\STAR{\tacconstr}
+%% contrib/romega
+\nlsep \TERM{romega}
+\SEPDEF
+\DEFNT{orient}
+       \KWD{$\rightarrow$}~\mid~\KWD{$\leftarrow$}
+\end{rules}
+
+\section{Grammar of commands}
+
+New symbols:
+$$ \TERM{.}
+~~ \TERM{..}
+~~ \TERM{\tt >->}
+~~ \TERM{:$>$}
+~~ \TERM{$<$:}
+$$
+
+New keyword:
+$$ \KWD{where}
+$$
+
+\subsection{Classification of commands}
+
+\begin{rules}
+\DEFNT{vernac}
+       \TERM{Time}~\NT{vernac}  &2~~ &\RNAME{Timing}
+%%
+\nlsep \NT{gallina}~\TERM{.}    &1
+\nlsep \NT{command}~\TERM{.}
+\nlsep \NT{syntax}~\TERM{.}
+\nlsep \TERM{[}~\PLUS{\NT{vernac}}~\TERM{]}~\TERM{.}
+%%
+\nlsep \OPTGR{\NT{num}~\KWD{:}}~\NT{subgoal-command}~\TERM{.} ~~~&0
+\SEPDEF
+\DEFNT{subgoal-command}
+       \NT{check-command}
+\nlsep %\OPT{\TERM{By}}~
+   \NT{tactic}~\OPT{\KWD{..}}
+\end{rules}
+
+\subsection{Gallina and extensions}
+
+\begin{rules}
+\DEFNT{gallina}
+       \NT{thm-token}~\NT{ident}~\STAR{\NT{binder-let}}~\KWD{:}~\NT{constr}
+\nlsep \NT{def-token}~\NT{ident}~\NT{def-body}
+\nlsep \NT{assum-token}~\NT{assum-list}
+\nlsep \NT{finite-token}~\NT{inductive-definition}
+      ~\STARGR{\KWD{with}~\NT{inductive-definition}}
+\nlsep \TERM{Fixpoint}~\NT{fix-decl}~\STARGR{\KWD{with}~\NT{fix-decl}}
+\nlsep \TERM{CoFixpoint}~\NT{fix-decl}~\STARGR{\KWD{with}~\NT{fix-decl}}
+\nlsep \TERM{Scheme}~\NT{scheme}~\STARGR{\KWD{with}~\NT{scheme}}
+%% Extension: record
+\nlsep \NT{record-tok}~\OPT{\TERM{$>$}}~\NT{ident}~\STAR{\NT{binder-let}}
+       ~\KWD{:}~\NT{constr}~\KWD{:=}
+       ~\OPT{\NT{ident}}~\KWD{\{}~\NT{field-list}~\KWD{\}}
+\nlsep \TERM{Ltac}~\NT{ltac-def}~\STARGR{~\TERM{with}~\NT{ltac-def}}
+\end{rules}
+
+\begin{rules}
+\DEFNT{thm-token}
+   \TERM{Theorem} ~\mid~ \TERM{Lemma} ~\mid~ \TERM{Fact} ~\mid~ \TERM{Remark}
+\SEPDEF
+\DEFNT{def-token}
+   \TERM{Definition} ~\mid~ \TERM{Let} ~\mid~
+   \OPT{\TERM{Local}}~\TERM{SubClass}
+\SEPDEF
+\DEFNT{assum-token}
+    \TERM{Hypothesis} ~\mid~ \TERM{Variable} ~\mid~ \TERM{Axiom} ~\mid~
+    \TERM{Parameter}
+\SEPDEF
+\DEFNT{finite-token}
+    \TERM{Inductive} ~\mid~ \TERM{CoInductive}
+\SEPDEF
+\DEFNT{record-tok}
+    \TERM{Record} ~\mid~ \TERM{Structure}
+\end{rules}
+
+
+\begin{rules}
+\DEFNT{def-body}
+       \STAR{\NT{binder-let}}~\NT{type-cstr}~\KWD{:=}
+       ~\OPT{\NT{reduce}}~\NT{constr}
+\nlsep \STAR{\NT{binder-let}}~\KWD{:}~\NT{constr}
+\SEPDEF
+\DEFNT{reduce}
+       \TERM{Eval}~\NT{red-expr}~\KWD{in}
+\SEPDEF
+\DEFNT{ltac-def}
+       \NT{ident}~\STAR{\NT{name}}~\KWD{:=}~\NT{tactic}
+\SEPDEF
+\DEFNT{rec-definition}
+       \NT{fix-decl}~\OPT{\NT{decl-notation}}
+\SEPDEF
+\DEFNT{inductive-definition}
+       \OPT{\NT{string}}~\NT{ident}~\STAR{\NT{binder-let}}~\KWD{:}
+       ~\NT{constr}~\KWD{:=}
+       ~\OPT{\TERMbar}~\OPT{\NT{constructor-list}}
+       ~\OPT{\NT{decl-notation}}
+\SEPDEF
+\DEFNT{constructor-list}
+       \NT{constructor}~\TERMbar~\NT{constructor-list}
+\nlsep \NT{constructor}
+\SEPDEF
+\DEFNT{constructor}
+       \NT{ident}~\STAR{\NT{binder-let}}\OPTGR{\NT{coerce-kwd}~\NT{constr}}
+\SEPDEF
+\DEFNT{decl-notation}
+       \TERM{where}~\NT{string}~\TERM{:=}~\NT{constr}
+\SEPDEF
+\DEFNT{field-list}
+       \NT{field}~\KWD{;}~\NT{field-list}
+\nlsep \NT{field}
+\SEPDEF
+\DEFNT{field}
+       \NT{ident}~\OPTGR{\NT{coerce-kwd}~\NT{constr}}
+\nlsep \NT{ident}~\NT{type-cstr-coe}~\KWD{:=}~\NT{constr}
+\SEPDEF
+\DEFNT{assum-list}
+       \PLUS{\GR{\KWD{(}~\NT{simple-assum-coe}~\KWD{)}}}
+\nlsep \NT{simple-assum-coe}
+\SEPDEF
+\DEFNT{simple-assum-coe}
+       \PLUS{\NT{ident}}~\NT{coerce-kwd}~\NT{constr}
+\SEPDEF
+\DEFNT{coerce-kwd} \TERM{:$>$} ~\mid~ \KWD{:}
+\SEPDEF
+\DEFNT{type-cstr-coe} \OPTGR{\NT{coerce-kwd}~\NT{constr}}
+\SEPDEF
+\DEFNT{scheme}
+       \NT{ident}~\KWD{:=}~\NT{dep-scheme}~\KWD{for}~\NT{reference}
+       ~\TERM{Sort}~\NT{sort}
+\SEPDEF
+\DEFNT{dep-scheme}
+       \TERM{Induction}~\mid~\TERM{Minimality}
+\end{rules}
+
+\subsection{Modules and sections}
+
+\begin{rules}
+\DEFNT{gallina}
+       \TERM{Module}~\NT{ident}~\STAR{\NT{mbinder}}~\OPT{\NT{of-mod-type}}
+       ~\OPTGR{\KWD{:=}~\NT{mod-expr}}
+\nlsep \TERM{Module}~\KWD{Type}~\NT{ident}~\STAR{\NT{mbinder}}
+       ~\OPTGR{\KWD{:=}~\NT{mod-type}}
+\nlsep \TERM{Declare}~\TERM{Module}~\NT{ident}~\STAR{\NT{mbinder}}
+       ~\OPT{\NT{of-mod-type}}
+       ~\OPTGR{\KWD{:=}~\NT{mod-expr}}
+\nlsep \TERM{Section}~\NT{ident}
+\nlsep \TERM{Chapter}~\NT{ident}
+\nlsep \TERM{End}~\NT{ident}
+%%
+\nlsep \TERM{Require}~\OPT{\NT{export-token}}~\OPT{\NT{specif-token}}
+       ~\PLUS{\NT{reference}}
+\nlsep \TERM{Require}~\OPT{\NT{export-token}}~\OPT{\NT{specif-token}}
+       ~\NT{string}
+\nlsep \TERM{Import}~\PLUS{\NT{reference}}
+\nlsep \TERM{Export}~\PLUS{\NT{reference}}
+\SEPDEF
+\DEFNT{export-token}
+       \TERM{Import} ~\mid~ \TERM{Export}
+\SEPDEF
+\DEFNT{specif-token}
+       \TERM{Implementation} ~\mid~ \TERM{Specification}
+\SEPDEF
+\DEFNT{mod-expr}
+       \NT{reference}
+\nlsep \NT{mod-expr}~\NT{mod-expr} & L
+\nlsep \KWD{(}~\NT{mod-expr}~\KWD{)}
+\SEPDEF
+\DEFNT{mod-type}
+       \NT{reference}
+\nlsep \NT{mod-type}~\KWD{with}~\NT{with-declaration}
+\SEPDEF
+\DEFNT{with-declaration}
+                                                          %on forcera les ( )
+                                                          %si exceptionnellemt
+                                                          %un fixpoint ici
+       \TERM{Definition}~\NT{ident}~\KWD{:=}~\NTL{constr}{} %{100}
+\nlsep \TERM{Module}~\NT{ident}~\KWD{:=}~\NT{reference}
+\SEPDEF
+\DEFNT{of-mod-type}
+       \KWD{:}~\NT{mod-type}
+\nlsep \TERM{$<$:}~\NT{mod-type}
+\SEPDEF
+\DEFNT{mbinder}
+       \KWD{(}~\PLUS{\NT{ident}}~\KWD{:}~\NT{mod-type}~\KWD{)}
+\end{rules}
+
+\begin{rules}
+\DEFNT{gallina}
+       \TERM{Transparent}~\PLUS{\NT{reference}}
+\nlsep \TERM{Opaque}~\PLUS{\NT{reference}}
+\nlsep \TERM{Canonical}~\TERM{Structure}~\NT{reference}~\OPT{\NT{def-body}}
+\nlsep \TERM{Coercion}~\OPT{\TERM{Local}}~\NT{reference}~\NT{def-body}
+\nlsep \TERM{Coercion}~\OPT{\TERM{Local}}~\NT{reference}~\KWD{:}
+       ~\NT{class-rawexpr}~\TERM{$>->$}~\NT{class-rawexpr}
+\nlsep \TERM{Identity}~\TERM{Coercion}~\OPT{\TERM{Local}}~\NT{ident}~\KWD{:}
+       ~\NT{class-rawexpr}~\TERM{$>->$}~\NT{class-rawexpr}
+\nlsep \TERM{Implicit}~\TERM{Arguments}~\NT{reference}~\TERM{[}~\STAR{\NT{num}}~\TERM{]}
+\nlsep \TERM{Implicit}~\TERM{Arguments}~\NT{reference}
+\nlsep \TERM{Implicit}~\KWD{Type}~\PLUS{\NT{ident}}~\KWD{:}~\NT{constr}
+\SEPDEF
+\DEFNT{command}
+       \TERM{Comments}~\STAR{\NT{comment}}
+\nlsep \TERM{Pwd}
+\nlsep \TERM{Cd}~\OPT{\NT{string}}
+\nlsep \TERM{Drop} ~\mid~ \TERM{ProtectedLoop} ~\mid~\TERM{Quit}
+%%
+\nlsep \TERM{Load}~\OPT{\TERM{Verbose}}~\NT{ident}
+\nlsep \TERM{Load}~\OPT{\TERM{Verbose}}~\NT{string}
+\nlsep \TERM{Declare}~\TERM{ML}~\TERM{Module}~\PLUS{\NT{string}}
+\nlsep \TERM{Dump}~\TERM{Universes}~\OPT{\NT{string}}
+\nlsep \TERM{Locate}~\NT{locatable}
+\nlsep \TERM{Add}~\OPT{\TERM{Rec}}~\TERM{LoadPath}~\NT{string}~\OPT{\NT{as-dirpath}}
+\nlsep \TERM{Remove}~\TERM{LoadPath}~\NT{string}
+\nlsep \TERM{Add}~\OPT{\TERM{Rec}}~\TERM{ML}~\TERM{Path}~\NT{string}
+%%
+\nlsep \KWD{Type}~\NT{constr}
+\nlsep \TERM{Print}~\NT{printable}
+\nlsep \TERM{Print}~\NT{reference}
+\nlsep \TERM{Inspect}~\NT{num}
+\nlsep \TERM{About}~\NT{reference}
+%%
+\nlsep \TERM{Search}~\NT{reference}~\OPT{\NT{in-out-modules}}
+\nlsep \TERM{SearchPattern}~\NT{constr-pattern}~\OPT{\NT{in-out-modules}}
+\nlsep \TERM{SearchRewrite}~\NT{constr-pattern}~\OPT{\NT{in-out-modules}}
+\nlsep \TERM{SearchAbout}~\NT{reference}~\OPT{\NT{in-out-modules}}
+\nlsep \TERM{SearchAbout}~\TERM{[}~\STAR{\NT{ref-or-string}}~\TERM{]}\OPT{\NT{in-out-modules}}
+\nlsep \KWD{Set}~\NT{ident}~\OPT{\NT{opt-value}}
+\nlsep \TERM{Unset}~\NT{ident}
+\nlsep \KWD{Set}~\NT{ident}~\NT{ident}~\OPT{\NT{opt-value}}
+\nlsep \KWD{Set}~\NT{ident}~\NT{ident}~\PLUS{\NT{opt-ref-value}}
+\nlsep \TERM{Unset}~\NT{ident}~\NT{ident}~\STAR{\NT{opt-ref-value}}
+%%
+\nlsep \TERM{Print}~\TERM{Table}~\NT{ident}~\NT{ident}
+\nlsep \TERM{Print}~\TERM{Table}~\NT{ident}
+\nlsep \TERM{Add}~\NT{ident}~\OPT{\NT{ident}}~\PLUS{\NT{opt-ref-value}}
+%%
+\nlsep \TERM{Test}~\NT{ident}~\OPT{\NT{ident}}~\STAR{\NT{opt-ref-value}}
+%%
+\nlsep \TERM{Remove}~\NT{ident}~\OPT{\NT{ident}}~\PLUS{\NT{opt-ref-value}}
+\SEPDEF
+\DEFNT{check-command}
+       \TERM{Eval}~\NT{red-expr}~\KWD{in}~\NT{constr}
+\nlsep \TERM{Check}~\NT{constr}
+\SEPDEF
+\DEFNT{ref-or-string}
+       \NT{reference}
+\nlsep \NT{string}
+\end{rules}
+
+\begin{rules}
+\DEFNT{printable}
+       \TERM{Term}~\NT{reference}
+\nlsep \TERM{All}
+\nlsep \TERM{Section}~\NT{reference}
+\nlsep \TERM{Grammar}~\NT{ident}
+\nlsep \TERM{LoadPath}
+\nlsep \TERM{Module}~\OPT{\KWD{Type}}~\NT{reference}
+\nlsep \TERM{Modules}
+\nlsep \TERM{ML}~\TERM{Path}
+\nlsep \TERM{ML}~\TERM{Modules}
+\nlsep \TERM{Graph}
+\nlsep \TERM{Classes}
+\nlsep \TERM{Coercions}
+\nlsep \TERM{Coercion}~\TERM{Paths}~\NT{class-rawexpr}~\NT{class-rawexpr}
+\nlsep \TERM{Tables}
+% \nlsep \TERM{Proof}~\NT{reference}  % Obsolete, useful in V6.3 ??
+\nlsep \TERM{Hint}~\OPT{\NT{reference}}
+\nlsep \TERM{Hint}~\TERM{*}
+\nlsep \TERM{HintDb}~\NT{ident}
+\nlsep \TERM{Scopes}
+\nlsep \TERM{Scope}~\NT{ident}
+\nlsep \TERM{Visibility}~\OPT{\NT{ident}}
+\nlsep \TERM{Implicit}~\NT{reference}
+\SEPDEF
+\DEFNT{class-rawexpr}
+       \TERM{Funclass}~\mid~\TERM{Sortclass}~\mid~\NT{reference}
+\SEPDEF
+\DEFNT{locatable}
+       \NT{reference}
+\nlsep \TERM{File}~\NT{string}
+\nlsep \TERM{Library}~\NT{reference}
+\nlsep \NT{string}
+\SEPDEF
+\DEFNT{opt-value}
+       \NT{ident} ~\mid~ \NT{string}
+\SEPDEF
+\DEFNT{opt-ref-value}
+       \NT{reference} ~\mid~ \NT{string}
+\SEPDEF
+\DEFNT{as-dirpath}
+       \KWD{as}~\NT{reference}
+\SEPDEF
+\DEFNT{in-out-modules}
+       \TERM{inside}~\PLUS{\NT{reference}}
+\nlsep \TERM{outside}~\PLUS{\NT{reference}}
+\SEPDEF
+\DEFNT{comment}
+       \NT{constr}
+\nlsep \NT{string}
+\end{rules}
+
+\subsection{Other commands}
+
+%% TODO: min/maj pas a jour
+\begin{rules}
+\EXTNT{command}
+       \TERM{Debug}~\TERM{On}
+\nlsep \TERM{Debug}~\TERM{Off}
+%% TODO: vernac
+\nlsep \TERM{Add}~\TERM{setoid}~\tacconstr~\tacconstr~\tacconstr
+\nlsep \TERM{Add}~\TERM{morphism}~\tacconstr~\KWD{:}~\NT{ident}
+\nlsep \TERM{Derive}~\TERM{inversion_clear}
+         ~\OPT{\NT{num}}~\NT{ident}~\NT{ident}
+\nlsep \TERM{Derive}~\TERM{inversion_clear}
+         ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}}
+\nlsep \TERM{Derive}~\TERM{inversion}
+         ~\OPT{\NT{num}}~\NT{ident}~\NT{ident}
+\nlsep \TERM{Derive}~\TERM{inversion}
+         ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}}
+\nlsep \TERM{Derive}~\TERM{dependent}~\TERM{inversion_clear}
+         ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}}
+\nlsep \TERM{Derive}~\TERM{dependent}~\TERM{inversion}
+         ~\NT{ident}~\KWD{with}~\tacconstr~\OPTGR{\TERM{Sort}~\NT{sort}}
+%% Correctness: obsolete ?
+%\nlsep Correctness
+%\nlsep Global Variable
+%% TODO: extraction
+\nlsep Extraction ...
+%% field
+\nlsep \TERM{Add}~\TERM{Field}~\tacconstr~\tacconstr~\tacconstr
+         ~\tacconstr~\tacconstr~\tacconstr
+\nlcont~~~~\tacconstr~\tacconstr~\OPT{\NT{minus-div}}
+%% funind
+\nlsep \TERM{Functional}~\TERM{Scheme}~\NT{ident}~\KWD{:=}
+         ~\TERM{Induction}~\KWD{for}~\tacconstr
+         ~\OPTGR{\KWD{with}~\PLUS{\tacconstr}}
+%% ring
+\nlsep \TERM{Add}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr
+         ~\tacconstr~\tacconstr~\tacconstr
+\nlcont~~~~\tacconstr~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]}
+\nlsep \TERM{Add}~\TERM{Semi}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr
+         ~\tacconstr~\tacconstr~\tacconstr
+\nlcont~~~~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]}
+\nlsep \TERM{Add}~\TERM{Abstract}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr
+         ~\tacconstr~\tacconstr~\tacconstr
+\nlcont~~~~\tacconstr~\tacconstr
+\nlsep \TERM{Add}~\TERM{Abstract}~\TERM{Semi}~\TERM{Ring}~\tacconstr
+         ~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr
+\nlcont~~~~\tacconstr
+\nlsep \TERM{Add}~\TERM{Setoid}~\TERM{Ring}~\tacconstr~\tacconstr~\tacconstr
+         ~\tacconstr~\tacconstr~\tacconstr
+\nlcont~~~~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr
+         ~\tacconstr~\KWD{[}~\PLUS{\tacconstr}~\KWD{]}
+\nlsep \TERM{Add}~\TERM{Setoid}~\TERM{Semi}~\TERM{Ring}~\tacconstr~\tacconstr
+         ~\tacconstr~\tacconstr~\tacconstr~\tacconstr
+\nlcont~~~~\tacconstr~\tacconstr~\tacconstr~\tacconstr~\tacconstr
+         ~\KWD{[}~\PLUS{tacconstr}~\KWD{]}
+\SEPDEF
+\DEFNT{minus-div}
+       \KWD{with}~\NT{minus-arg}~\NT{div-arg}
+\nlsep \KWD{with}~\NT{div-arg}~\NT{minus-arg}
+\SEPDEF
+\DEFNT{minus-arg}
+       \TERM{minus}~\KWD{:=}~\tacconstr
+\SEPDEF
+\DEFNT{div-arg}
+       \TERM{div}~\KWD{:=}~\tacconstr
+\end{rules}
+
+\begin{rules}
+\EXTNT{command}
+       \TERM{Write}~\TERM{State}~\NT{ident}
+\nlsep \TERM{Write}~\TERM{State}~\NT{string}
+\nlsep \TERM{Restore}~\TERM{State}~\NT{ident}
+\nlsep \TERM{Restore}~\TERM{State}~\NT{string}
+\nlsep \TERM{Reset}~\NT{ident}
+\nlsep \TERM{Reset}~\TERM{Initial}
+\nlsep \TERM{Back}~\OPT{\NT{num}}
+\end{rules}
+
+\subsection{Proof-editing commands}
+
+\begin{rules}
+\EXTNT{command}
+       \TERM{Goal}~\NT{constr}
+\nlsep \TERM{Proof}~\OPT{\NT{constr}}
+\nlsep \TERM{Proof}~\KWD{with}~\NT{tactic}
+\nlsep \TERM{Abort}~\OPT{\TERM{All}}
+\nlsep \TERM{Abort}~\NT{ident}
+\nlsep \TERM{Existential}~\NT{num}~\KWD{:=}~\NT{constr-body}
+\nlsep \TERM{Qed}
+\nlsep \TERM{Save}~\OPTGR{\NT{thm-token}~\NT{ident}}
+\nlsep \TERM{Defined}~\OPT{\NT{ident}}
+\nlsep \TERM{Suspend}
+\nlsep \TERM{Resume}~\OPT{\NT{ident}}
+\nlsep \TERM{Restart}
+\nlsep \TERM{Undo}~\OPT{\NT{num}}
+\nlsep \TERM{Focus}~\OPT{\NT{num}}
+\nlsep \TERM{Unfocus}
+\nlsep \TERM{Show}~\OPT{\NT{num}}
+\nlsep \TERM{Show}~\TERM{Implicit}~\TERM{Arguments}~\OPT{\NT{num}}
+\nlsep \TERM{Show}~\TERM{Node}
+\nlsep \TERM{Show}~\TERM{Script}
+\nlsep \TERM{Show}~\TERM{Existentials}
+\nlsep \TERM{Show}~\TERM{Tree}
+\nlsep \TERM{Show}~\TERM{Conjecture}
+\nlsep \TERM{Show}~\TERM{Proof}
+\nlsep \TERM{Show}~\TERM{Intro}
+\nlsep \TERM{Show}~\TERM{Intros}
+%% Correctness: obsolete ?
+%%\nlsep \TERM{Show}~\TERM{Programs}
+\nlsep \TERM{Explain}~\TERM{Proof}~\OPT{\TERM{Tree}}~\STAR{\NT{num}}
+%% Go not documented
+\nlsep \TERM{Hint}~\OPT{\TERM{Local}}~\NT{hint}~\OPT{\NT{inbases}}
+%% PrintConstr not documented
+\end{rules}
+
+
+\begin{rules}
+\DEFNT{constr-body}
+       \NT{type-cstr}~\KWD{:=}~\NT{constr}
+\SEPDEF
+\DEFNT{hint}
+       \TERM{Resolve}~\PLUS{\NTL{constr}{9}}
+\nlsep \TERM{Immediate}~\PLUS{\NTL{constr}{9}}
+\nlsep \TERM{Unfold}~\PLUS{\NT{reference}}
+\nlsep \TERM{Constructors}~\PLUS{\NT{reference}}
+\nlsep \TERM{Extern}~\NT{num}~\NT{constr}~\KWD{$\Rightarrow$}~\NT{tactic}
+\nlsep \TERM{Destruct}~\NT{ident}~\KWD{:=}~\NT{num}~\NT{destruct-loc}
+       ~\NT{constr}~\KWD{$\Rightarrow$}~\NT{tactic}
+\nlsep \TERM{Rewrite}~\NT{orient}~\PLUS{\NTL{constr}{9}}
+       ~\OPTGR{\KWD{using}~\NT{tactic}}
+\SEPDEF
+\DEFNT{inbases}
+       \KWD{:}~\PLUS{\NT{ident}}
+\SEPDEF
+\DEFNT{destruct-loc}
+       \TERM{Conclusion}
+\nlsep \OPT{\TERM{Discardable}}~\TERM{Hypothesis}
+\end{rules}
+
+
+\subsection{Syntax extensions}
+
+\begin{rules}
+\DEFNT{syntax}
+       \TERM{Open}~\TERM{Scope}~\NT{ident}
+\nlsep \TERM{Close}~\TERM{Scope}~\NT{ident}
+\nlsep \TERM{Delimit}~\TERM{Scope}~\NT{ident}~\KWD{with}~\NT{ident}
+\nlsep \TERM{Bind}~\TERM{Scope}~\NT{ident}~\KWD{with}~\PLUS{\NT{class-rawexpr}}
+\nlsep \TERM{Arguments}~\TERM{Scope}~\NT{reference}
+       ~\TERM{[}~\PLUS{\NT{name}}~\TERM{]}
+\nlsep \TERM{Infix}~\OPT{\TERM{Local}} %%% ~\NT{prec}~\OPT{\NT{num}}
+       ~\NT{string}~\KWD{:=}~\NT{reference}~\OPT{\NT{modifiers}}
+       ~\OPT{\NT{in-scope}}
+\nlsep \TERM{Notation}~\OPT{\TERM{Local}}~\NT{string}~\KWD{:=}~\NT{constr}
+       ~\OPT{\NT{modifiers}}~\OPT{\NT{in-scope}}
+\nlsep \TERM{Notation}~\OPT{\TERM{Local}}~\NT{ident}~\KWD{:=}~\NT{constr}
+       ~\OPT{\KWD{(}\TERM{only~\TERM{parsing}\KWD{)}}}
+\nlsep \TERM{Reserved}~\TERM{Notation}~\OPT{\TERM{Local}}~\NT{string}
+       ~\OPT{\NT{modifiers}}
+\nlsep \TERM{Tactic}~\TERM{Notation}~\NT{string}~\STAR{\NT{tac-production}}
+       ~\KWD{:=}~\NT{tactic}
+\SEPDEF
+\DEFNT{modifiers}
+       \KWD{(}~\NT{mod-list}~\KWD{)}
+\SEPDEF
+\DEFNT{mod-list}
+       \NT{modifier}
+\nlsep \NT{modifier}~\KWD{,}~\NT{mod-list}
+\SEPDEF
+\DEFNT{modifier}
+       \NT{ident}~\KWD{at}~\NT{num}
+\nlsep \NT{ident}~\STARGR{\KWD{,}~\NT{ident}}~\KWD{at}~\NT{num}
+\nlsep \KWD{at}~\TERM{next}~\TERM{level}
+\nlsep \KWD{at}~\TERM{level}~\NT{num}
+\nlsep \TERM{left}~\TERM{associativity}
+\nlsep \TERM{right}~\TERM{associativity}
+\nlsep \TERM{no}~\TERM{associativity}
+\nlsep \NT{ident}~\NT{syntax-entry}
+\nlsep \TERM{only}~\TERM{parsing}
+\nlsep \TERM{format}~\NT{string}
+\SEPDEF
+\DEFNT{in-scope}
+       \KWD{:}~\NT{ident}
+\SEPDEF
+\DEFNT{syntax-entry}
+       \TERM{ident}~\mid~\TERM{global}~\mid~\TERM{bigint}
+\SEPDEF
+\DEFNT{tac-production}
+       \NT{string}
+\nlsep \NT{ident}~\TERM{(}~\NT{ident}~\TERM{)}
+%%% \SEPDEF
+%%% \DEFNT{prec}
+%%%       \TERM{LeftA}~\mid~\TERM{RightA}~\mid~\TERM{NonA}
+\end{rules}
+
+\end{document}
diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml
new file mode 100644
index 00000000..1e114489
--- /dev/null
+++ b/dev/vm_printers.ml
@@ -0,0 +1,94 @@
+open Format
+open Term
+open Names
+open Cbytecodes
+open Cemitcodes
+open Vm
+
+let ppripos (ri,pos) =
+  (match ri with
+  | Reloc_annot a -> 
+      let sp,i = a.ci.ci_ind in
+      print_string 
+	("annot : MutInd("^(string_of_kn sp)^","^(string_of_int i)^")\n")
+  | Reloc_const _ ->
+      print_string "structured constant\n"
+  | Reloc_getglobal kn ->
+      print_string ("getglob "^(string_of_con kn)^"\n"));
+   print_flush ()
+
+let print_vfix () = print_string "vfix"
+let print_vfix_app () = print_string "vfix_app"
+let print_vswith () = print_string "switch"
+
+let ppsort = function
+  | Prop(Pos) -> print_string "Set"
+  | Prop(Null) -> print_string "Prop"
+  | Type u -> print_string "Type"
+
+
+
+let print_idkey idk =
+  match idk with 
+  | ConstKey sp -> 
+      print_string "Cons(";
+      print_string (string_of_con sp);
+      print_string ")"
+  | VarKey id -> print_string (string_of_id id)
+  | RelKey i -> print_string "~";print_int i
+
+let rec ppzipper z =
+  match z with 
+  | Zapp args -> 
+      let n = nargs args in
+      open_hbox ();
+      for i = 0 to n-2 do
+	ppvalues (arg args i);print_string ";";print_space()
+      done;
+      if n-1 >= 0 then ppvalues (arg args (n-1));
+      close_box()
+  | Zfix _ -> print_string "Zfix"
+  | Zswitch _ -> print_string "Zswitch"
+
+and ppstack s = 
+  open_hovbox 0;
+  print_string "[";
+  List.iter (fun z -> ppzipper z;print_string " | ") s;
+  print_string "]";
+  close_box()
+
+and ppatom a =
+  match a with
+  | Aid idk -> print_idkey idk
+  | Aiddef(idk,_) -> print_string "&";print_idkey idk
+  | Aind(sp,i) ->  print_string "Ind(";
+      print_string (string_of_kn sp);
+      print_string ","; print_int i;
+      print_string ")"
+
+and ppwhd whd =
+  match whd with 
+  | Vsort s -> ppsort s
+  | Vprod _ -> print_string "product"
+  | Vfun _ -> print_string "function"
+  | Vfix _ -> print_vfix()
+  | Vcofix _ -> print_string "cofix"
+  | Vconstr_const i -> print_string "C(";print_int i;print_string")"
+  | Vconstr_block b -> ppvblock b      
+  | Vatom_stk(a,s) ->
+      open_hbox();ppatom a;close_box();
+      print_string"@";ppstack s
+
+and ppvblock b =
+  open_hbox();
+  print_string "Cb(";print_int (btag b);
+  let n = bsize b in
+  for i = 0 to n -1 do
+    print_string ",";ppvalues (bfield b i)
+  done;
+  print_string")";
+  close_box()
+
+and ppvalues v =
+  open_hovbox 0;ppwhd (whd_val v);close_box();
+  print_flush()
diff --git a/doc/INSTALL b/doc/INSTALL
new file mode 100644
index 00000000..9223a41b
--- /dev/null
+++ b/doc/INSTALL
@@ -0,0 +1,65 @@
+                           The Coq documentation
+                           =====================
+
+The Coq documentation includes 
+
+- A Reference Manual
+- A Tutorial
+- A document presenting the Coq standard library
+- A list of questions/answers in the FAQ style
+
+The sources of the documents are mainly made of LaTeX code from which
+user-readable PostScript or PDF files, or a user-browsable bunch of
+html files are generated.
+
+Prerequisite
+------------
+
+To produce the documents, you need the coqtop, coq-tex, coqdoc and
+gallina tools, with same version number as the current
+documentation. These four tools normally come with any basic Coq
+installation.
+
+In addition, to produce the PostScript documents, the following tools
+are needed:
+
+  - latex (latex2e)
+  - dvips
+  - bibtex
+  - makeindex
+  - pngtopnm and pnmtops (for the Reference Manual and the FAQ)
+
+To produce the PDF documents, the following tools are needed:
+
+  - pdflatex
+  - bibtex
+
+To produce the html documents, the following tools are needed:
+
+  - hevea (e.g. 1.07 works)
+
+To produce the documentation of the standard library, a source copy of
+the coq distribution is needed.
+
+Compilation
+-----------
+
+To produce all PostScript documents, do:                make all-ps
+To produce all PDF documents, do:                       make all-pdf
+To produce all html documents, do:                      make all-html
+To produce all formats of the Reference Manual, do:     make refman
+To produce all formats of the Tutorial, do:             make tutorial
+To produce all formats of the Coq Standard Library, do: make stdlib
+To produce all formats of the FAQ, do:                  make faq
+
+Installation
+------------
+
+To install all produced documents, do:
+
+  make DOCDIR=/some/directory/for/documentation install
+
+DOCDIR defauts to /usr/share/doc/coq-x.y were x.y is the version number
+
+
+
diff --git a/doc/LICENCE b/doc/LICENCE
new file mode 100644
index 00000000..99087480
--- /dev/null
+++ b/doc/LICENCE
@@ -0,0 +1,630 @@
+The Coq Reference Manual is a collective work from the Coq Development
+Team whose members are listed in the file CREDITS of the Coq source
+package. All related documents (the LaTeX and BibTeX sources, the
+embedded png files, and the PostScript, PDF and html outputs) are
+copyright (c) INRIA 1999-2006. The material connected to the Reference
+Manual may be distributed only subject to the terms and conditions set
+forth in the Open Publication License, v1.0 or later (the latest
+version is presently available at http://www.opencontent.org/openpub/).
+Options A and B are *not* elected.
+
+The Coq Tutorial is a work by Gérard Huet, Gilles Kahn and Christine
+Paulin-Mohring. All documents (the LaTeX source and the PostScript,
+PDF and html outputs) are copyright (c) INRIA 1999-2006. The material
+connected to the Coq Tutorial may be distributed only subject to the
+terms and conditions set forth in the Open Publication License, v1.0
+or later (the latest version is presently available at
+http://www.opencontent.org/openpub/). Options A and B are *not*
+elected.
+
+The Coq Standard Library is a collective work from the Coq Development
+Team whose members are listed in the file CREDITS of the Coq source
+package. All related documents (the Coq vernacular source files and
+the PostScript, PDF and html outputs) are copyright (c) INRIA
+1999-2006. The material connected to the Standard Library is
+distributed under the terms of the Lesser General Public License
+version 2.1 or later. 
+
+The FAQ (Coq for the Clueless) is a work by Pierre Castéran, Hugo
+Herbelin, Florent Kirchner, Benjamin Monate, and Julien Narboux. All
+documents (the LaTeX source and the PostScript, PDF and html outputs)
+are copyright (c) INRIA 2004-2006. The material connected to the FAQ
+(Coq for the Clueless) may be distributed only subject to the terms
+and conditions set forth in the Open Publication License, v1.0 or
+later (the latest version is presently available at
+http://www.opencontent.org/openpub/). Options A and B are *not*
+elected.
+
+The Tutorial on [Co-]Inductive Types in Coq is a work by Pierre
+Castéran and Eduardo Gimenez. All related documents (the LaTeX and
+BibTeX sources and the PostScript, PDF and html outputs) are copyright
+(c) INRIA 1997-2006. The material connected to the Tutorial on
+[Co-]Inductive Types in Coq may be distributed only subject to the
+terms and conditions set forth in the Open Publication License, v1.0
+or later (the latest version is presently available at
+http://www.opencontent.org/openpub/).  Options A and B are
+*not* elected.
+
+----------------------------------------------------------------------
+
+                      *Open Publication License*
+                           v1.0, 8 June 1999
+
+
+*I. REQUIREMENTS ON BOTH UNMODIFIED AND MODIFIED VERSIONS*
+
+The Open Publication works may be reproduced and distributed in whole or
+in part, in any medium physical or electronic, provided that the terms
+of this license are adhered to, and that this license or an
+incorporation of it by reference (with any options elected by the
+author(s) and/or publisher) is displayed in the reproduction.
+
+Proper form for an incorporation by reference is as follows:
+
+    Copyright (c) <year> by <author's name or designee>. This material
+    may be distributed only subject to the terms and conditions set
+    forth in the Open Publication License, vX.Y or later (the latest
+    version is presently available at http://www.opencontent.org/openpub/).
+
+The reference must be immediately followed with any options elected by
+the author(s) and/or publisher of the document (see section VI).
+
+Commercial redistribution of Open Publication-licensed material is
+permitted.
+
+Any publication in standard (paper) book form shall require the citation
+of the original publisher and author. The publisher and author's names
+shall appear on all outer surfaces of the book. On all outer surfaces of
+the book the original publisher's name shall be as large as the title of
+the work and cited as possessive with respect to the title.
+
+
+*II. COPYRIGHT*
+
+The copyright to each Open Publication is owned by its author(s) or
+designee.
+
+
+*III. SCOPE OF LICENSE*
+
+The following license terms apply to all Open Publication works, unless
+otherwise explicitly stated in the document.
+
+Mere aggregation of Open Publication works or a portion of an Open
+Publication work with other works or programs on the same media shall
+not cause this license to apply to those other works. The aggregate work
+shall contain a notice specifying the inclusion of the Open Publication
+material and appropriate copyright notice.
+
+SEVERABILITY. If any part of this license is found to be unenforceable
+in any jurisdiction, the remaining portions of the license remain in force.
+
+NO WARRANTY. Open Publication works are licensed and provided "as is"
+without warranty of any kind, express or implied, including, but not
+limited to, the implied warranties of merchantability and fitness for a
+particular purpose or a warranty of non-infringement.
+
+
+*IV. REQUIREMENTS ON MODIFIED WORKS*
+
+All modified versions of documents covered by this license, including
+translations, anthologies, compilations and partial documents, must meet
+the following requirements:
+
+   1. The modified version must be labeled as such.
+   2. The person making the modifications must be identified and the
+      modifications dated.
+   3. Acknowledgement of the original author and publisher if applicable
+      must be retained according to normal academic citation practices.
+   4. The location of the original unmodified document must be identified.
+   5. The original author's (or authors') name(s) may not be used to
+      assert or imply endorsement of the resulting document without the
+      original author's (or authors') permission. 
+
+
+*V. GOOD-PRACTICE RECOMMENDATIONS *
+
+In addition to the requirements of this license, it is requested from
+and strongly recommended of redistributors that:
+
+   1. If you are distributing Open Publication works on hardcopy or
+      CD-ROM, you provide email notification to the authors of your
+      intent to redistribute at least thirty days before your manuscript
+      or media freeze, to give the authors time to provide updated
+      documents. This notification should describe modifications, if
+      any, made to the document.
+   2. All substantive modifications (including deletions) be either
+      clearly marked up in the document or else described in an
+      attachment to the document.
+   3. Finally, while it is not mandatory under this license, it is
+      considered good form to offer a free copy of any hardcopy and
+      CD-ROM expression of an Open Publication-licensed work to its
+      author(s). 
+
+
+*VI. LICENSE OPTIONS*
+
+The author(s) and/or publisher of an Open Publication-licensed document
+may elect certain options by appending language to the reference to or
+copy of the license. These options are considered part of the license
+instance and must be included with the license (or its incorporation by
+reference) in derived works.
+
+A. To prohibit distribution of substantively modified versions without
+the explicit permission of the author(s). "Substantive modification" is
+defined as a change to the semantic content of the document, and
+excludes mere changes in format or typographical corrections.
+
+To accomplish this, add the phrase `Distribution of substantively
+modified versions of this document is prohibited without the explicit
+permission of the copyright holder.' to the license reference or copy.
+
+B. To prohibit any publication of this work or derivative works in whole
+or in part in standard (paper) book form for commercial purposes is
+prohibited unless prior permission is obtained from the copyright holder.
+
+To accomplish this, add the phrase 'Distribution of the work or
+derivative of the work in any standard (paper) book form is prohibited
+unless prior permission is obtained from the copyright holder.' to the
+license reference or copy.
+
+----------------------------------------------------------------------
+
+		  GNU LESSER GENERAL PUBLIC LICENSE
+		       Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+			    Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+  This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it.  You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations below.
+
+  When we speak of free software, we are referring to freedom of use,
+not price.  Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+  To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights.  These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+  For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you.  You must make sure that they, too, receive or can get the source
+code.  If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it.  And you must show them these terms so they know their rights.
+
+  We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+  To protect each distributor, we want to make it very clear that
+there is no warranty for the free library.  Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+
+  Finally, software patents pose a constant threat to the existence of
+any free program.  We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder.  Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+  Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License.  This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License.  We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+  When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library.  The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom.  The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+  We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License.  It also provides other free software developers Less
+of an advantage over competing non-free programs.  These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries.  However, the Lesser license provides advantages in certain
+special circumstances.
+
+  For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it becomes
+a de-facto standard.  To achieve this, non-free programs must be
+allowed to use the library.  A more frequent case is that a free
+library does the same job as widely used non-free libraries.  In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+  In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software.  For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+  Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.  Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library".  The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+
+		  GNU LESSER GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+  A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+  The "Library", below, refers to any such software library or work
+which has been distributed under these terms.  A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language.  (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+  "Source code" for a work means the preferred form of the work for
+making modifications to it.  For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control compilation
+and installation of the library.
+
+  Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it).  Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+  
+  1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+  You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+
+  2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) The modified work must itself be a software library.
+
+    b) You must cause the files modified to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    c) You must cause the whole of the work to be licensed at no
+    charge to all third parties under the terms of this License.
+
+    d) If a facility in the modified Library refers to a function or a
+    table of data to be supplied by an application program that uses
+    the facility, other than as an argument passed when the facility
+    is invoked, then you must make a good faith effort to ensure that,
+    in the event an application does not supply such function or
+    table, the facility still operates, and performs whatever part of
+    its purpose remains meaningful.
+
+    (For example, a function in a library to compute square roots has
+    a purpose that is entirely well-defined independent of the
+    application.  Therefore, Subsection 2d requires that any
+    application-supplied function or table used by this function must
+    be optional: if the application does not supply it, the square
+    root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library.  To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License.  (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.)  Do not make any other change in
+these notices.
+
+  Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+  This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+  4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+  If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library".  Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+  However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library".  The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+  When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library.  The
+threshold for this to be true is not precisely defined by law.
+
+  If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work.  (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+  Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+
+  6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+  You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License.  You must supply a copy of this License.  If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License.  Also, you must do one
+of these things:
+
+    a) Accompany the work with the complete corresponding
+    machine-readable source code for the Library including whatever
+    changes were used in the work (which must be distributed under
+    Sections 1 and 2 above); and, if the work is an executable linked
+    with the Library, with the complete machine-readable "work that
+    uses the Library", as object code and/or source code, so that the
+    user can modify the Library and then relink to produce a modified
+    executable containing the modified Library.  (It is understood
+    that the user who changes the contents of definitions files in the
+    Library will not necessarily be able to recompile the application
+    to use the modified definitions.)
+
+    b) Use a suitable shared library mechanism for linking with the
+    Library.  A suitable mechanism is one that (1) uses at run time a
+    copy of the library already present on the user's computer system,
+    rather than copying library functions into the executable, and (2)
+    will operate properly with a modified version of the library, if
+    the user installs one, as long as the modified version is
+    interface-compatible with the version that the work was made with.
+
+    c) Accompany the work with a written offer, valid for at
+    least three years, to give the same user the materials
+    specified in Subsection 6a, above, for a charge no more
+    than the cost of performing this distribution.
+
+    d) If distribution of the work is made by offering access to copy
+    from a designated place, offer equivalent access to copy the above
+    specified materials from the same place.
+
+    e) Verify that the user has already received a copy of these
+    materials or that you have already sent this user a copy.
+
+  For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it.  However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+  It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system.  Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+
+  7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+    a) Accompany the combined library with a copy of the same work
+    based on the Library, uncombined with any other library
+    facilities.  This must be distributed under the terms of the
+    Sections above.
+
+    b) Give prominent notice with the combined library of the fact
+    that part of it is a work based on the Library, and explaining
+    where to find the accompanying uncombined form of the same work.
+
+  8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License.  Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License.  However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+  9. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Library or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+  10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+
+  11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any
+particular circumstance, the balance of the section is intended to apply,
+and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License may add
+an explicit geographical distribution limitation excluding those countries,
+so that distribution is permitted only in or among countries not thus
+excluded.  In such case, this License incorporates the limitation as if
+written in the body of this License.
+
+  13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation.  If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+
+  14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission.  For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this.  Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+			    NO WARRANTY
+
+  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+		     END OF TERMS AND CONDITIONS
diff --git a/doc/Makefile b/doc/Makefile
new file mode 100644
index 00000000..6209b0c8
--- /dev/null
+++ b/doc/Makefile
@@ -0,0 +1,307 @@
+# Makefile for the Coq documentation
+
+# COQTOP needs to be set to a coq source repository
+
+# To compile documentation, you need the following tools:
+# Dvi: latex (latex2e), bibtex, makeindex
+# Pdf: pdflatex
+# Html: hevea (http://hevea.inria.fr) >= 1.05
+
+include ../config/Makefile
+
+
+LATEX=latex
+BIBTEX=bibtex -min-crossrefs=10
+MAKEINDEX=makeindex
+PDFLATEX=pdflatex
+
+HEVEALIB=/usr/local/lib/hevea:/usr/lib/hevea
+TEXINPUTS=$(HEVEALIB):.:
+
+DOCCOQTOP=$(COQTOP)/bin/coqtop
+COQTEX=$(COQTOP)/bin/coq-tex -n 72 -image $(DOCCOQTOP) -v -sl -small
+COQDOC=$(COQTOP)/bin/coqdoc
+
+#VERSION=POSITIONNEZ-CETTE-VARIABLE
+
+######################################################################
+### General rules
+######################################################################
+
+all: all-html all-pdf all-ps
+
+all-html:\
+  tutorial/Tutorial.v.html refman/html/index.html \
+  faq/html/index.html stdlib/html/index.html RecTutorial/RecTutorial.v.html
+
+all-pdf:\
+  tutorial/Tutorial.v.pdf refman/Reference-Manual.pdf \
+  faq/FAQ.v.pdf stdlib/Library.pdf RecTutorial/RecTutorial.v.pdf
+
+all-ps:\
+  tutorial/Tutorial.v.ps refman/Reference-Manual.ps \
+  faq/FAQ.v.ps stdlib/Library.ps RecTutorial/RecTutorial.v.ps
+
+refman:\
+  refman/html/index.html refman/Reference-Manual.ps refman/Reference-Manual.pdf
+
+tutorial:\
+  tutorial/Tutorial.v.html tutorial/Tutorial.v.ps tutorial/Tutorial.v.pdf
+
+stdlib:\
+  stdlib/html/index.html stdlib/Library.ps stdlib/Library.pdf
+
+faq:\
+  faq/html/index.html faq/FAQ.v.ps faq/FAQ.v.pdf
+
+rectutorial:\
+  RecTutorial/RecTutorial.v.html \
+  RecTutorial/RecTutorial.v.ps RecTutorial/RecTutorial.v.pdf
+
+######################################################################
+### Implicit rules
+######################################################################
+
+.SUFFIXES: .dvi .tex .v.tex .ps .pdf .eps .png
+
+%.v.tex: %.tex
+	(cd `dirname $<`; $(COQTEX) `basename $<`)
+
+%.ps: %.dvi
+	(cd `dirname $<`; dvips -o `basename $@` `basename $<`)
+
+%.eps: %.png
+	pngtopnm $< | pnmtops -equalpixels -noturn -rle > $@
+
+clean:
+	rm -f */*.dvi */*.aux */*.log */*.bbl */*.blg */*.toc \
+	*/*.idx */*~ */*.ilg */*.ind */*.dvi.gz */*.ps.gz */*.pdf.gz\
+	*/*.???idx */*.???ind */*.v.tex */*.atoc */*.lof\
+	*/*.hatoc */*.haux */*.hcomind */*.herrind */*.hidx */*.hind \
+	*/*.htacind */*.htoc */*.v.html
+	rm -f stdlib/index-list.html stdlib/index-body.html \
+	  stdlib/Library.coqdoc.tex stdlib/library.files \
+	  stdlib/library.files.ls
+	rm -f refman/euclid.ml{,i} refman/heapsort.ml{,i}
+	rm -f common/version.tex
+	rm -f refman/*.eps refman/Reference-Manual.html
+
+cleanall: clean
+	rm -f */*.ps */*.pdf
+	rm -rf refman/html stdlib/html faq/html tutorial/tutorial.v.html
+
+######################################################################
+# Common
+######################################################################
+
+COMMON=common/version.tex common/title.tex common/macros.tex 
+
+### Version
+
+common/version.tex: Makefile
+	echo "\newcommand{\coqversion}{$(VERSION)}" > common/version.tex
+
+######################################################################
+# Reference Manual
+######################################################################
+
+REFMANCOQTEXFILES=\
+  refman/RefMan-gal.v.tex refman/RefMan-ext.v.tex \
+  refman/RefMan-mod.v.tex refman/RefMan-tac.v.tex \
+  refman/RefMan-cic.v.tex refman/RefMan-lib.v.tex \
+  refman/RefMan-tacex.v.tex refman/RefMan-syn.v.tex \
+  refman/RefMan-oth.v.tex refman/RefMan-ltac.v.tex \
+  refman/Cases.v.tex refman/Coercion.v.tex refman/Extraction.v.tex \
+  refman/Program.v.tex refman/Omega.v.tex refman/Polynom.v.tex \
+  refman/Setoid.v.tex refman/Helm.tex # refman/Natural.v.tex
+
+REFMANTEXFILES=\
+  refman/headers.tex \
+  refman/Reference-Manual.tex refman/RefMan-pre.tex \
+  refman/RefMan-int.tex refman/RefMan-pro.tex \
+  refman/RefMan-com.tex \
+  refman/RefMan-uti.tex refman/RefMan-ide.tex \
+  refman/RefMan-add.tex refman/RefMan-modr.tex \
+  $(REFMANCOQTEXFILES) \
+
+REFMANEPSFILES= refman/coqide.eps refman/coqide-queries.eps
+
+REFMANFILES=\
+  $(REFMANTEXFILES) $(COMMON) $(REFMANEPSFILES) refman/biblio.bib
+
+REFMANPNGFILES=$(REFMANEPSFILES:.eps=.png)
+
+### Reference Manual (printable format)
+
+# The second LATEX compilation is necessary otherwise the pages of the index
+# are not correct (don't know why...) - BB
+refman/Reference-Manual.dvi: $(REFMANFILES)
+	(cd refman;\
+	$(LATEX) Reference-Manual;\
+	$(BIBTEX) Reference-Manual;\
+	$(LATEX) Reference-Manual;\
+	$(MAKEINDEX) Reference-Manual;\
+	$(MAKEINDEX) Reference-Manual.tacidx -o Reference-Manual.tacind;\
+	$(MAKEINDEX) Reference-Manual.comidx -o Reference-Manual.comind;\
+	$(MAKEINDEX) Reference-Manual.erridx -o Reference-Manual.errind;\
+	$(LATEX) Reference-Manual;\
+	$(LATEX) Reference-Manual)
+
+refman/Reference-Manual.pdf: refman/Reference-Manual.tex
+	(cd refman; $(PDFLATEX) Reference-Manual.tex)
+
+### Reference Manual (browsable format)
+
+refman/Reference-Manual.html: refman/Reference-Manual.dvi # to ensure bbl file
+	(cd refman; hevea -fix -exec xxdate.exe ./Reference-Manual.tex)
+
+refman/html/index.html: refman/Reference-Manual.html $(REFMANPNGFILES) \
+                        refman/cover.html refman/index.html
+	- rm -rf refman/html
+	mkdir refman/html
+	cp $(REFMANPNGFILES) refman/html
+	(cd refman/html; hacha -o toc.html ../Reference-Manual.html)
+	cp refman/cover.html refman/menu.html refman/html
+	cp refman/index.html refman/html
+
+refman-quick:
+	(cd refman; \
+	 $(PDFLATEX) Reference-Manual.tex; \
+	 hevea -fix -exec xxdate.exe ./Reference-Manual.tex)
+
+
+######################################################################
+# Tutorial
+######################################################################
+
+tutorial/Tutorial.v.dvi: common/version.tex common/title.tex tutorial/Tutorial.v.tex
+	(cd tutorial; $(LATEX) Tutorial.v)
+
+tutorial/Tutorial.v.pdf: common/version.tex common/title.tex tutorial/Tutorial.v.dvi
+	(cd tutorial; $(PDFLATEX) Tutorial.v.tex)
+
+tutorial/Tutorial.v.html: tutorial/Tutorial.v.tex
+	(cd tutorial; hevea -exec xxdate.exe Tutorial.v)
+
+
+######################################################################
+# FAQ
+######################################################################
+
+faq/FAQ.v.dvi: common/version.tex common/title.tex faq/FAQ.v.tex
+	(cd faq;\
+	$(LATEX) FAQ.v;\
+	$(BIBTEX) FAQ.v;\
+	$(LATEX) FAQ.v;\
+	$(LATEX) FAQ.v)
+
+faq/FAQ.v.pdf: common/version.tex common/title.tex faq/FAQ.v.dvi faq/axioms.png
+	(cd faq; $(PDFLATEX) FAQ.v.tex)
+
+faq/FAQ.v.html: faq/FAQ.v.dvi # to ensure FAQ.v.bbl
+	(cd faq; hevea -fix FAQ.v.tex)
+
+faq/html/index.html: faq/FAQ.v.html
+	- rm -rf faq/html
+	mkdir faq/html
+	cp faq/interval_discr.v faq/axioms.png faq/html
+	cp faq/FAQ.v.html faq/html/index.html
+
+######################################################################
+# Standard library
+######################################################################
+
+GLOBDUMP=$(COQTOP)/glob.dump
+
+LIBDIRS= Logic Bool Arith ZArith QArith Reals Lists Sets Relations Sorting Wellfounded IntMap FSets
+
+### Standard library (browsable html format)
+
+stdlib/index-body.html: $(GLOBDUMP)
+	- rm -rf stdlib/html
+	mkdir stdlib/html
+	(cd stdlib/html;\
+	 $(COQDOC) -q --multi-index --html --glob-from $(GLOBDUMP)\
+	  -R $(COQTOP)/theories Coq $(COQTOP)/theories/*/*.v)
+	mv stdlib/html/index.html stdlib/index-body.html
+
+stdlib/index-list.html: stdlib/index-list.html.template
+	COQTOP=$(COQTOP) ./stdlib/make-library-index stdlib/index-list.html
+
+stdlib/html/index.html: stdlib/index-list.html stdlib/index-body.html stdlib/index-trailer.html
+	cat stdlib/index-list.html > $@
+	sed -n -e '/<table>/,/<\/table>/p' stdlib/index-body.html >> $@
+	cat stdlib/index-trailer.html >> $@
+
+### Standard library (printable format - produces > 350 pages)
+
+stdlib/Library.coqdoc.tex: 
+	(for dir in $(LIBDIRS) ; do \
+	  $(COQDOC) -q --gallina --body-only --latex --stdout \
+	    --coqlib_path $(COQTOP) \
+            -R $(COQTOP)/theories Coq "$(COQTOP)/theories/$$dir/"*.v >> $@ ; done)
+
+stdlib/Library.dvi: $(COMMON) stdlib/Library.coqdoc.tex stdlib/Library.tex
+	(cd stdlib;\
+	$(LATEX) Library;\
+	$(LATEX) Library)
+
+stdlib/Library.pdf: $(COMMON) stdlib/Library.coqdoc.tex stdlib/Library.dvi
+	(cd stdlib; $(PDFLATEX) Library)
+
+######################################################################
+# Tutorial on inductive types
+######################################################################
+
+RecTutorial/RecTutorial.v.dvi: common/version.tex common/title.tex RecTutorial/RecTutorial.v.tex
+	(cd RecTutorial;\
+	 $(LATEX) RecTutorial.v;\
+	 $(BIBTEX) RecTutorial.v;\
+	 $(LATEX) RecTutorial.v;\
+	 $(LATEX) RecTutorial.v)
+
+RecTutorial/RecTutorial.v.pdf: common/version.tex common/title.tex RecTutorial/RecTutorial.v.dvi
+	(cd RecTutorial; $(PDFLATEX) RecTutorial.v.tex)
+
+RecTutorial/RecTutorial.v.html: RecTutorial/RecTutorial.v.tex
+	(cd RecTutorial; hevea -exec xxdate.exe RecTutorial.v)
+
+
+######################################################################
+# Install all documentation files
+######################################################################
+
+COQINSTALLPREFIX=
+DOCDIR=/usr/local/share/doc/coq-8.0
+FULLDOCDIR=$(COQINSTALLPREFIX)$(DOCDIR)
+HTMLINSTALLDIR=$(FULLDOCDIR)/html
+PRINTABLEINSTALLDIR=$(FULLDOCDIR)/ps
+
+install-doc: install-meta install-doc-html install-doc-printable
+
+install-meta:
+	mkdir $(DOCDIC)
+	cp LICENCE $(DOCDIC)/LICENCE.doc
+#	cp $(COQTOP)/LICENCE $(COQTOP)/CREDITS $(COQTOP)/COPYRIGHT $(DOCDIC)
+#	cp $(COQTOP)/README $(COQTOP)/CHANGES $(DOCDIC)
+
+install-doc-html: all-html
+	mkdir $(HTMLINSTALLDIR)
+	cp -r refman/html $(HTMLINSTALLDIR)/refman
+	cp -r stdlib/html $(HTMLINSTALLDIR)/stdlib
+	cp -r tutorial/tutorial.html $(HTMLINSTALLDIR)/
+	cp -r RecTutorial/RecTutorial.html $(HTMLINSTALLDIR)/
+	cp -r faq/html $(HTMLINSTALLDIR)/faq
+
+install-doc-printable: all-pdf all-ps
+	mkdir $(PRINTABLEINSTALLDIR)
+	cp -r refman/Reference-manual.pdf $(PRINTABLEINSTALLDIR)
+	cp -r stdlib/Library.pdf $(PRINTABLEINSTALLDIR)
+	cp -r tutorial/Tutorial.v.pdf $(PRINTABLEINSTALLDIR)/Tutorial.pdf
+	cp -r RecTutorial/RecTutorial.v.pdf $(PRINTABLEINSTALLDIR)/RecTutorial.pdf
+	cp -r faq/FAQ.v.pdf $(PRINTABLEINSTALLDIR)/FAQ.pdf
+	cp -r refman/Reference-manual.ps $(PRINTABLEINSTALLDIR)
+	cp -r stdlib/Library.ps $(PRINTABLEINSTALLDIR)
+	cp -r tutorial/Tutorial.v.ps $(PRINTABLEINSTALLDIR)/Tutorial.ps
+	cp -r RecTutorial/RecTutorial.v.ps $(PRINTABLEINSTALLDIR)/RecTutorial.ps
+	cp -r faq/FAQ.v.ps $(PRINTABLEINSTALLDIR)/FAQ.ps
diff --git a/doc/Makefile.rt b/doc/Makefile.rt
new file mode 100644
index 00000000..6c328134
--- /dev/null
+++ b/doc/Makefile.rt
@@ -0,0 +1,43 @@
+# Makefile for building Coq Technical Reports
+
+# if coqc,coqtop,coq-tex are not in your PATH, you need the environment 
+# variable COQBIN to be correctly set  
+# (COQTOP is autodetected)
+# (some files are preprocessed using Coq and some part of the documentation
+# is automatically built from the theories sources)
+
+# To compile documentation, you need the following tools:
+# Dvi: latex (latex2e), bibtex, makeindex, dviselect (package RPM dviutils)
+# Ps: dvips, psutils (ftp://ftp.dcs.ed.ac.uk/pub/ajcd/psutils.tar.gz)
+# Pdf: pdflatex
+# Html:
+#   - hevea: http://para.inria.fr/~maranget/hevea/
+#   - htmlSplit: http://coq.inria.fr/~delahaye
+# Rapports INRIA: dviselect, rrkit (par Michel Mauny)
+
+include ./Makefile
+
+###################
+# RT
+###################
+# Fabrication d'un RT INRIA (utilise rrkit de Michel Mauny)
+rt/Reference-Manual-RT.dvi: refman/Reference-Manual.dvi rt/RefMan-cover.tex
+	dviselect -i refman/Reference-Manual.dvi -o rt/RefMan-body.dvi 3:
+	(cd rt; $(LATEX) RefMan-cover.tex)
+	set a=`tail -1 refman/Reference-Manual.log`;\
+	set a=expr \("$$a" : '.*(\(.*\) pages.*'\) % 2;\
+	(cd rt; if $(TEST) "$$a = 0";\
+	 then rrkit  RefMan-cover.dvi RefMan-body.dvi Reference-Manual-RT.dvi;\
+	 else rrkit -odd RefMan-cover.dvi RefMan-body.dvi Reference-Manual-RT.dvi;\
+	fi)
+
+# Fabrication d'un RT INRIA (utilise rrkit de Michel Mauny)
+rt/Tutorial-RT.dvi : tutorial/Tutorial.v.dvi rt/Tutorial-cover.tex
+	dviselect -i rt/Tutorial.v.dvi -o rt/Tutorial-body.dvi 3:
+	(cd rt; $(LATEX) Tutorial-cover.tex)
+	set a=`tail -1 tutorial/Tutorial.v.log`;\
+	set a=expr \("$$a" : '.*(\(.*\) pages.*'\) % 2;\
+	(cd rt; if $(TEST) "$$a = 0";\
+	 then rrkit      Tutorial-cover.dvi Tutorial-body.dvi Tutorial-RT.dvi;\
+	 else rrkit -odd Tutorial-cover.dvi Tutorial-body.dvi Tutorial-RT.dvi;\
+	fi)
diff --git a/doc/README b/doc/README
new file mode 100755
index 00000000..14cb6e44
--- /dev/null
+++ b/doc/README
@@ -0,0 +1,30 @@
+You can get the whole documentation of Coq in the tar file all-ps-docs.tar.
+
+You can also get separately each document. The documentation of Coq
+V8.0 is divided into the following documents :
+
+     * Tutorial.ps: An introduction to the use of the Coq Proof Assistant;
+
+     * Reference-Manual.ps:
+
+       Base chapters:
+       - the description of Gallina, the language of Coq
+       - the description of the Vernacular, the commands of Coq
+       - the description of each tactic
+       - index on tactics, commands and error messages
+
+       Additional chapters:
+       - the extended Cases (C.Cornes)
+       - the coercions (A. Saïbi)
+       - the tactic Omega (P. Crégut)
+       - the extraction features (J.-C. Filliâtre and P. Letouzey) 
+       - the tactic Ring (S. Boutin and P. Loiseleur)
+       - the Setoid_replace tactic (C. Renard)
+       - etc.
+
+     * Library.ps: A description of the Coq standard library;
+
+     * rectypes.ps : A tutorial on recursive types by Eduardo Gimenez
+
+Documentation is also available in the PDF format and HTML format
+(online at http://coq.inria.fr or by ftp in the file doc-html.tar.gz).
diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex
new file mode 100755
index 00000000..598943a4
--- /dev/null
+++ b/doc/stdlib/Library.tex
@@ -0,0 +1,62 @@
+\documentclass[11pt]{report}
+
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\usepackage{fullpage}
+\usepackage{coqdoc}
+
+\input{../common/version}
+\input{../common/title}
+\input{../common/macros}
+
+\begin{document}
+ 
+\coverpage{The standard library}%
+{\ }
+{This material is distributed under the terms of the GNU Lesser
+General Public License Version 2.1.}
+
+\tableofcontents
+
+\newpage
+% \section*{The \Coq\ standard library}
+
+This document is a short description of the \Coq\ standard library.
+This library comes with the system as a complement of the core library
+(the {\bf Init} library ; see the Reference Manual for a description
+of this library). It provides a set of modules directly available
+through the \verb!Require! command.
+
+The standard library is composed of the following subdirectories:
+\begin{description}
+  \item[Logic]  Classical logic and dependent equality
+  \item[Bool]   Booleans (basic functions and results)
+  \item[Arith]  Basic Peano arithmetic
+  \item[ZArith] Basic integer arithmetic
+  \item[Reals]  Classical Real Numbers and Analysis
+  \item[Lists]  Monomorphic and polymorphic lists (basic functions and
+                  results), Streams (infinite sequences defined 
+                  with co-inductive types)
+  \item[Sets]   Sets (classical, constructive, finite, infinite, power set,
+                  etc.)
+  \item[Relations] Relations (definitions and basic results).
+  \item[Sorting] Sorted list (basic definitions and heapsort
+                 correctness). 
+  \item[Wellfounded] Well-founded relations (basic results).
+  \item[IntMap]       Representation of finite sets by an efficient
+                     structure of map (trees indexed by binary integers).
+\end{description}
+
+
+Each of these subdirectories contains a set of modules, whose
+specifications (\gallina{} files) have
+been roughly, and automatically, pasted in the following pages. There
+is also a version of this document in HTML format on the WWW, which
+you can access from the \Coq\ home page at
+\texttt{http://coq.inria.fr/library}.
+
+\input{Library.coqdoc}
+
+\end{document}
+
+% $Id: Library.tex 9245 2006-10-17 12:53:34Z notin $ 
diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template
new file mode 100644
index 00000000..f63b6cf4
--- /dev/null
+++ b/doc/stdlib/index-list.html.template
@@ -0,0 +1,366 @@
+<html>
+
+<head>
+<link rel="stylesheet" href="coqdoc.css" type="text/css">
+<title>The Coq Standard Library
+</head>
+
+<body>
+
+<H1>The Coq Standard Library</H1>
+
+<p>Here is a short description of the Coq standard library, which is
+distributed with the system.
+It provides a set of modules directly available 
+through the <tt>Require Import</tt> command.</p>
+
+<p>The standard library is composed of the following subdirectories:</p>
+
+<dl>
+  <dt> <b>Init</b>:
+    The core library (automatically loaded when starting Coq)
+  </dt>
+  <dd> 
+    theories/Init/Notations.v
+    theories/Init/Datatypes.v
+    theories/Init/Logic.v
+    theories/Init/Logic_Type.v
+    theories/Init/Peano.v
+    theories/Init/Specif.v
+    theories/Init/Tactics.v
+    theories/Init/Wf.v
+    (theories/Init/Prelude.v)
+  </dd>
+  
+  <dt> <b>Logic</b>:
+      Classical logic and dependent equality
+  </dt>
+  <dd>
+    theories/Logic/Classical_Pred_Set.v
+    theories/Logic/Classical_Pred_Type.v
+    theories/Logic/Classical_Prop.v
+    theories/Logic/Classical_Type.v
+    (theories/Logic/Classical.v)
+    theories/Logic/ClassicalFacts.v
+    theories/Logic/Decidable.v
+    theories/Logic/DecidableType.v
+    theories/Logic/DecidableTypeEx.v
+    theories/Logic/Eqdep_dec.v
+    theories/Logic/EqdepFacts.v
+    theories/Logic/Eqdep.v
+    theories/Logic/JMeq.v
+    theories/Logic/ChoiceFacts.v
+    theories/Logic/RelationalChoice.v
+    theories/Logic/ClassicalChoice.v
+    theories/Logic/ClassicalDescription.v
+    theories/Logic/ClassicalEpsilon.v
+    theories/Logic/ClassicalUniqueChoice.v
+    theories/Logic/Berardi.v
+    theories/Logic/Diaconescu.v
+    theories/Logic/Hurkens.v
+    theories/Logic/ProofIrrelevance.v
+    theories/Logic/ProofIrrelevanceFacts.v
+  </dd>
+    
+  <dt> <b>Arith</b>:
+    Basic Peano arithmetic
+  </dt>
+  <dd> 
+    theories/Arith/Le.v
+    theories/Arith/Lt.v
+    theories/Arith/Plus.v
+    theories/Arith/Minus.v
+    theories/Arith/Mult.v
+    theories/Arith/Gt.v
+    theories/Arith/Between.v
+    theories/Arith/Peano_dec.v
+    theories/Arith/Compare_dec.v
+    (theories/Arith/Arith.v)
+    theories/Arith/Min.v
+    theories/Arith/Max.v
+    theories/Arith/Compare.v
+    theories/Arith/Div2.v
+    theories/Arith/Div.v
+    theories/Arith/EqNat.v
+    theories/Arith/Euclid.v
+    theories/Arith/Even.v
+    theories/Arith/Bool_nat.v
+    theories/Arith/Factorial.v
+    theories/Arith/Wf_nat.v
+  </dd>
+    
+  <dt> <b>NArith</b>:
+    Binary positive integers
+  </dt>
+  <dd> 
+    theories/NArith/BinPos.v
+    theories/NArith/BinNat.v
+    (theories/NArith/NArith.v)
+    theories/NArith/Pnat.v
+    theories/NArith/Nnat.v
+    theories/NArith/Ndigits.v
+    theories/NArith/Ndist.v
+    theories/NArith/Ndec.v
+.  </dd>
+
+  <dt> <b>ZArith</b>:
+       Binary integers
+  </dt>
+  <dd> 
+    theories/ZArith/BinInt.v
+    theories/ZArith/Zorder.v
+    theories/ZArith/Zcompare.v
+    theories/ZArith/Znat.v
+    theories/ZArith/Zmin.v
+    theories/ZArith/Zmax.v
+    theories/ZArith/Zminmax.v
+    theories/ZArith/Zabs.v
+    theories/ZArith/Zeven.v
+    theories/ZArith/auxiliary.v
+    theories/ZArith/ZArith_dec.v
+    theories/ZArith/Zbool.v
+    theories/ZArith/Zmisc.v
+    theories/ZArith/Wf_Z.v
+    theories/ZArith/Zhints.v
+    (theories/ZArith/ZArith_base.v)
+    theories/ZArith/Zcomplements.v
+    theories/ZArith/Zsqrt.v
+    theories/ZArith/Zpower.v
+    theories/ZArith/Zdiv.v
+    theories/ZArith/Zlogarithm.v
+    (theories/ZArith/ZArith.v)
+    theories/ZArith/Zwf.v
+    theories/ZArith/Zbinary.v
+    theories/ZArith/Znumtheory.v
+    theories/ZArith/Int.v
+  </dd>
+
+  <dt> <b>QArith</b>:
+    Rational numbers
+  </dt>
+  <dd>
+    theories/QArith/QArith_base.v
+    theories/QArith/Qreduction.v
+    theories/QArith/Qring.v
+    (theories/QArith/QArith.v)
+    theories/QArith/Qreals.v
+    theories/QArith/Qcanon.v
+  </dd>
+    
+  <dt> <b>Reals</b>:
+    Formalization of real numbers
+  </dt>
+  <dd> 
+    theories/Reals/Rdefinitions.v
+    theories/Reals/Raxioms.v
+    theories/Reals/RIneq.v
+    theories/Reals/DiscrR.v
+    (theories/Reals/Rbase.v)
+    theories/Reals/RList.v
+    theories/Reals/Ranalysis.v
+    theories/Reals/Rbasic_fun.v
+    theories/Reals/Rderiv.v
+    theories/Reals/Rfunctions.v
+    theories/Reals/Rgeom.v
+    theories/Reals/R_Ifp.v
+    theories/Reals/Rlimit.v
+    theories/Reals/Rseries.v
+    theories/Reals/Rsigma.v
+    theories/Reals/R_sqr.v
+    theories/Reals/Rtrigo_fun.v
+    theories/Reals/Rtrigo.v
+    theories/Reals/SplitAbsolu.v
+    theories/Reals/SplitRmult.v
+    theories/Reals/Alembert.v
+    theories/Reals/AltSeries.v
+    theories/Reals/ArithProp.v
+    theories/Reals/Binomial.v
+    theories/Reals/Cauchy_prod.v
+    theories/Reals/Cos_plus.v
+    theories/Reals/Cos_rel.v
+    theories/Reals/Exp_prop.v
+    theories/Reals/Integration.v
+    theories/Reals/MVT.v
+    theories/Reals/NewtonInt.v
+    theories/Reals/PSeries_reg.v
+    theories/Reals/PartSum.v
+    theories/Reals/R_sqrt.v
+    theories/Reals/Ranalysis1.v
+    theories/Reals/Ranalysis2.v
+    theories/Reals/Ranalysis3.v
+    theories/Reals/Ranalysis4.v
+    theories/Reals/Rcomplete.v
+    theories/Reals/RiemannInt.v
+    theories/Reals/RiemannInt_SF.v
+    theories/Reals/Rpower.v
+    theories/Reals/Rprod.v
+    theories/Reals/Rsqrt_def.v
+    theories/Reals/Rtopology.v
+    theories/Reals/Rtrigo_alt.v
+    theories/Reals/Rtrigo_calc.v
+    theories/Reals/Rtrigo_def.v
+    theories/Reals/Rtrigo_reg.v
+    theories/Reals/SeqProp.v
+    theories/Reals/SeqSeries.v
+    theories/Reals/Sqrt_reg.v
+    (theories/Reals/Reals.v)
+  </dd>
+    
+  <dt> <b>Sets</b>:
+       Sets (classical, constructive, finite, infinite, powerset, etc.)
+  </dt>
+  <dd> 
+    theories/Sets/Classical_sets.v
+    theories/Sets/Constructive_sets.v
+    theories/Sets/Cpo.v
+    theories/Sets/Ensembles.v
+    theories/Sets/Finite_sets_facts.v
+    theories/Sets/Finite_sets.v
+    theories/Sets/Image.v
+    theories/Sets/Infinite_sets.v
+    theories/Sets/Integers.v
+    theories/Sets/Multiset.v
+    theories/Sets/Partial_Order.v
+    theories/Sets/Permut.v
+    theories/Sets/Powerset_Classical_facts.v
+    theories/Sets/Powerset_facts.v
+    theories/Sets/Powerset.v
+    theories/Sets/Relations_1_facts.v
+    theories/Sets/Relations_1.v
+    theories/Sets/Relations_2_facts.v
+    theories/Sets/Relations_2.v
+    theories/Sets/Relations_3_facts.v
+    theories/Sets/Relations_3.v
+    theories/Sets/Uniset.v
+  </dd>
+    
+  <dt> <b>Relations</b>:
+       Relations (definitions and basic results)
+  </dt>
+  <dd> 
+    theories/Relations/Relation_Definitions.v
+    theories/Relations/Relation_Operators.v
+    theories/Relations/Relations.v
+    theories/Relations/Operators_Properties.v
+    theories/Relations/Rstar.v
+    theories/Relations/Newman.v
+  </dd>
+    
+  <dt> <b>Wellfounded</b>:
+       Well-founded Relations
+  </dt>
+  <dd> 
+    theories/Wellfounded/Disjoint_Union.v
+    theories/Wellfounded/Inclusion.v
+    theories/Wellfounded/Inverse_Image.v
+    theories/Wellfounded/Lexicographic_Exponentiation.v
+    theories/Wellfounded/Lexicographic_Product.v
+    theories/Wellfounded/Transitive_Closure.v
+    theories/Wellfounded/Union.v
+    theories/Wellfounded/Wellfounded.v
+    theories/Wellfounded/Well_Ordering.v
+  </dd>
+    
+  <dt> <b>Setoids</b>:
+  <dd> 
+    theories/Setoids/Setoid.v
+  </dd>
+    
+  <dt> <b>Bool</b>:
+       Booleans (basic functions and results)
+  </dt>
+  <dd> 
+    theories/Bool/Bool.v
+    theories/Bool/BoolEq.v
+    theories/Bool/DecBool.v
+    theories/Bool/IfProp.v
+    theories/Bool/Sumbool.v
+    theories/Bool/Zerob.v
+    theories/Bool/Bvector.v
+  </dd>
+    
+  <dt> <b>Lists</b>:
+    Polymorphic lists, Streams (infinite sequences)
+  </dt>
+  <dd> 
+    theories/Lists/List.v
+    theories/Lists/ListSet.v
+    theories/Lists/MonoList.v
+    theories/Lists/SetoidList.v
+    theories/Lists/Streams.v
+    theories/Lists/TheoryList.v
+  </dd>
+
+  <dt> <b>FSets</b>:
+    Modular implementation of finite sets/maps using lists
+  </dt>
+  <dd>
+    theories/FSets/OrderedType.v
+    theories/FSets/OrderedTypeAlt.v
+    theories/FSets/OrderedTypeEx.v
+    theories/FSets/FSetInterface.v
+    theories/FSets/FSetBridge.v
+    theories/FSets/FSetProperties.v
+    theories/FSets/FSetEqProperties.v
+    theories/FSets/FSetList.v
+    (theories/FSets/FSets.v)
+    theories/FSets/FSetFacts.v
+    theories/FSets/FSetAVL.v
+    theories/FSets/FSetToFiniteSet.v
+    theories/FSets/FSetWeakProperties.v
+    theories/FSets/FSetWeakInterface.v
+    theories/FSets/FSetWeakFacts.v
+    theories/FSets/FSetWeakList.v
+    theories/FSets/FSetWeak.v
+    theories/FSets/FMapInterface.v
+    theories/FSets/FMapList.v
+    theories/FSets/FMapPositive.v
+    theories/FSets/FMapIntMap.v
+    theories/FSets/FMapFacts.v
+    (theories/FSets/FMaps.v)
+    theories/FSets/FMapAVL.v
+    theories/FSets/FMapWeakInterface.v
+    theories/FSets/FMapWeakList.v
+    theories/FSets/FMapWeak.v
+    theories/FSets/FMapWeakFacts.v
+  </dd>
+
+  <dt> <b>IntMap</b>:
+    An implementation of finite sets/maps as trees indexed by addresses
+  </dt>
+  <dd> 
+    theories/IntMap/Adalloc.v
+    theories/IntMap/Map.v
+    theories/IntMap/Fset.v
+    theories/IntMap/Mapaxioms.v
+    theories/IntMap/Mapiter.v
+    theories/IntMap/Mapcanon.v
+    theories/IntMap/Mapsubset.v
+    theories/IntMap/Lsort.v
+    theories/IntMap/Mapfold.v
+    theories/IntMap/Mapcard.v
+    theories/IntMap/Mapc.v
+    theories/IntMap/Maplists.v
+    theories/IntMap/Allmaps.v
+  </dd>
+    
+  <dt> <b>Strings</b>
+    Implementation of string as list of ascii characters
+  </dt>
+  <dd>
+    theories/Strings/Ascii.v
+    theories/Strings/String.v
+  </dd>
+    
+  <dt> <b>Sorting</b>:
+    Axiomatizations of sorts
+  </dt>
+  <dd> 
+    theories/Sorting/Heap.v
+    theories/Sorting/Permutation.v
+    theories/Sorting/Sorting.v
+    theories/Sorting/PermutEq.v
+    theories/Sorting/PermutSetoid.v
+  </dd>
+
+</dl>
diff --git a/doc/stdlib/index-trailer.html b/doc/stdlib/index-trailer.html
new file mode 100644
index 00000000..308b1d01
--- /dev/null
+++ b/doc/stdlib/index-trailer.html
@@ -0,0 +1,2 @@
+</body>
+</html>
diff --git a/doc/stdlib/make-library-files b/doc/stdlib/make-library-files
new file mode 100755
index 00000000..91e3cc3f
--- /dev/null
+++ b/doc/stdlib/make-library-files
@@ -0,0 +1,36 @@
+#!/bin/sh
+
+# Needs COQTOP and GALLINA set
+
+# On garde la liste de tous les *.v avec dates dans library.files.ls
+# Si elle a change depuis la derniere fois ou library.files n'existe pas
+# on fabrique des .g (si besoin) et la liste library.files dans 
+# l'ordre de ls -tr des *.vo
+# Ce dernier trie les fichiers dans l'ordre inverse de leur date de création
+# En supposant que make fait son boulot, ca fait un tri topologique du
+# graphe des dépendances
+
+LIBDIRS="Arith NArith ZArith Reals Logic Bool Lists IntMap Relations Sets Sorting Wellfounded Setoids"
+
+rm -f library.files.ls.tmp
+(cd $COQTOP/theories; find $LIBDIR -name "*.v" -ls) > library.files.ls.tmp
+if ! test -e library.files || ! cmp library.files.ls library.files.ls.tmp; then
+  mv -f library.files.ls.tmp library.files.ls
+  rm -f library.files; touch library.files
+  ABSOLUTE=`pwd`/library.files
+  cd $COQTOP/theories
+  echo $LIBDIRS
+  for rep in $LIBDIRS ; do
+    (cd $rep
+     echo $rep/intro.tex >> $ABSOLUTE
+     VOFILES=`ls -tr *.vo`
+     for file in $VOFILES ; do
+       VF=`basename $file \.vo`
+       if [ \( ! -e $VF.g \) -o \( $VF.v -nt $VF.g \) ] ; then
+          $GALLINA $VF.v
+       fi
+       echo $rep/$VF.g >> $ABSOLUTE
+     done
+    )
+  done
+fi
diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index
new file mode 100755
index 00000000..ddbcd09f
--- /dev/null
+++ b/doc/stdlib/make-library-index
@@ -0,0 +1,35 @@
+#!/bin/sh
+
+# Instantiate links to library files in index template
+
+FILE=$1
+
+cp -f $FILE.template tmp
+echo -n Building file index-list.prehtml ...
+
+for i in ../theories/*; do
+    echo $i
+
+  d=`basename $i`
+  if [ "$d" != "Num" -a "$d" != "CVS" ]; then
+  for j in $i/*.v; do
+    b=`basename $j .v`
+    rm -f tmp2
+    grep -q theories/$d/$b.v tmp
+    a=$?
+    if [ $a = 0 ]; then
+      sed -e "s:theories/$d/$b.v:<a href=\"Coq.$d.$b.html\">$b</a>:g" tmp > tmp2
+      mv -f tmp2 tmp
+    else
+      echo Warning: theories/$d/$b.v is missing in the template file
+    fi
+  done
+  fi
+  rm -f tmp2
+  sed -e "s/#$d#//" tmp > tmp2
+  mv -f tmp2 tmp
+done
+a=`grep theories tmp`
+if [ $? = 0 ]; then echo Warning: extra files:; echo $a; fi
+mv tmp $FILE
+echo Done
diff --git a/ide/blaster_window.ml b/ide/blaster_window.ml
index cca788c2..f3cb1e60 100644
--- a/ide/blaster_window.ml
+++ b/ide/blaster_window.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: blaster_window.ml,v 1.5.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+(* $Id: blaster_window.ml 8912 2006-06-07 11:20:58Z notin $ *)
 
 open Gobject.Data
 open Ideutils
@@ -77,22 +77,17 @@ object(self)
   val blaster_killed = Condition.create () 
   method blaster_killed = blaster_killed
   method window = window
-  method set
-    root
-    name
-    (compute:unit -> Coq.tried_tactic) 
-    (on_click:unit -> unit) 
-    = 
+  method set root name (compute:unit -> Coq.tried_tactic) (on_click:unit -> unit) = 
     let root_iter = 
       try Hashtbl.find roots root 
       with Not_found -> 
 	let nr = new_arg root in
-	Hashtbl.add roots root nr;
-	nr
+	  Hashtbl.add roots root nr;
+	  nr
     in
     let nt = new_tac root_iter name in
     let old_val = try MyMap.find root tbl with Not_found -> MyMap.empty in
-    tbl <- MyMap.add root (MyMap.add name (nt,compute,on_click) old_val) tbl
+      tbl <- MyMap.add root (MyMap.add name (nt,compute,on_click) old_val) tbl
 
   method clear () = 
     model#clear ();      
@@ -107,20 +102,20 @@ object(self)
 	   MyMap.iter 
 	     (fun name (nt,compute,on_click) ->  
 		match compute () with 
-		| Coq.Interrupted -> 
-		    prerr_endline "Interrupted";
-		    raise Stop
-		| Coq.Failed -> 
-		    prerr_endline "Failed";
-		    ignore (model#remove nt)
-		      (*	       model#set ~row:nt ~column:status false;
+		  | Coq.Interrupted -> 
+		      prerr_endline "Interrupted";
+		      raise Stop
+		  | Coq.Failed -> 
+		      prerr_endline "Failed";
+		      ignore (model#remove nt)
+			(*	       model#set ~row:nt ~column:status false;
 				       model#set ~row:nt ~column:nb_goals "N/A"
-		      *)
-		| Coq.Success n -> 
-		    prerr_endline "Success";
-		    model#set ~row:nt ~column:status true;
-		    model#set ~row:nt ~column:nb_goals (string_of_int n);
-		    if n= -1 then raise Done 
+			*)
+		  | Coq.Success n -> 
+		      prerr_endline "Success";
+		      model#set ~row:nt ~column:status true;
+		      model#set ~row:nt ~column:nb_goals (string_of_int n);
+		      if n= -1 then raise Done 
 	     )
 	     l
 	 with Done -> ())
diff --git a/ide/command_windows.ml b/ide/command_windows.ml
index 42b65048..768d125c 100644
--- a/ide/command_windows.ml
+++ b/ide/command_windows.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: command_windows.ml,v 1.13.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+(* $Id: command_windows.ml 9189 2006-09-29 12:39:24Z notin $ *)
 
 class command_window () = 
   let window = GWindow.window 
@@ -15,7 +15,7 @@ class command_window () =
 		 ~position:`CENTER
 		 ~title:"CoqIde queries" ~show:false ()
   in
-  let accel_group = GtkData.AccelGroup.create () in
+  let _ = GtkData.AccelGroup.create () in
   let vbox = GPack.vbox ~homogeneous:false ~packing:window#add () in
   let toolbar = GButton.toolbar 
 		  ~orientation:`HORIZONTAL 
@@ -52,7 +52,7 @@ class command_window () =
       ()
   in
 
-  let kill_page_menu = 
+  let _ = 
     toolbar#insert_button
       ~tooltip:"Kill Page"
       ~text:"Kill Page"
diff --git a/ide/command_windows.mli b/ide/command_windows.mli
index 6028c818..3a5f0d60 100644
--- a/ide/command_windows.mli
+++ b/ide/command_windows.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: command_windows.mli,v 1.1.2.2 2005/01/21 17:21:33 herbelin Exp $ i*)
+(*i $Id: command_windows.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 class command_window :
   unit ->
diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll
index 1c0720d1..7722e99a 100644
--- a/ide/config_lexer.mll
+++ b/ide/config_lexer.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: config_lexer.mll,v 1.4.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+(* $Id: config_lexer.mll 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 {
 
diff --git a/ide/config_parser.mly b/ide/config_parser.mly
index 48005efe..80cba27b 100644
--- a/ide/config_parser.mly
+++ b/ide/config_parser.mly
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (***********************************************************************/
 
-/* $Id: config_parser.mly,v 1.2.2.1 2004/07/16 19:30:20 herbelin Exp $ */
+/* $Id: config_parser.mly 5920 2004-07-16 20:01:26Z herbelin $ */
 
 %{
 
diff --git a/ide/coq.ico b/ide/coq.ico
index 390065bc..b99f6399 100644
--- a/ide/coq.ico
+++ b/ide/coq.ico
diff --git a/ide/coq.ml b/ide/coq.ml
index 31f9829b..6059f065 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq.ml,v 1.38.2.2 2005/11/16 17:22:38 barras Exp $ *)
+(* $Id: coq.ml 9537 2007-01-26 10:05:04Z corbinea $ *)
 
 open Vernac
 open Vernacexpr
@@ -19,6 +19,7 @@ open Printer
 open Environ
 open Evarutil
 open Evd
+open Decl_mode
 open Hipattern
 open Tacmach
 open Reductionops
@@ -53,41 +54,41 @@ let version () =
   let date =
     if Glib.Utf8.validate Coq_config.date
     then Coq_config.date
-    else "<date not printable>"
-  in
-  Printf.sprintf 
-    "The Coq Proof Assistant, version %s (%s)\
-   \nConfigured on %s\
-   \nArchitecture %s running %s operating system\
-   \nGtk version is %s\
-   \nThis is the %s version (%s is the best one for this architecture and OS)\
-   \n"
-    Coq_config.version date Coq_config.compile_date
-    Coq_config.arch Sys.os_type
-    (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z)
+    else "<date not printable>" in
+  let get_version_date () =
+    try
+      let ch = open_in (Coq_config.coqtop^"/revision") in
+      let ver = input_line ch in
+      let rev = input_line ch in
+	(ver,rev)
+    with _ -> (Coq_config.version,date) in
+  let (rev,ver) = get_version_date () in
+    Printf.sprintf 
+      "The Coq Proof Assistant, version %s (%s)\
+       \nArchitecture %s running %s operating system\
+       \nGtk version is %s\
+       \nThis is the %s version (%s is the best one for this architecture and OS)\
+       \n"
+      rev ver
+      Coq_config.arch Sys.os_type
+      (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z)
     (if Mltop.get () = Mltop.Native then "native" else "bytecode") 
     (if Coq_config.best="opt" then "native" else "bytecode") 
 
 let is_in_coq_lib dir = 
   prerr_endline ("Is it a coq theory ? : "^dir);
-  try
-    let stat = Unix.stat dir in
-    List.exists 
-      (fun s -> 
-	 try
-	   let fdir = Filename.concat 
-			Coq_config.coqlib 
-			(Filename.concat "theories" s) 
-	   in
-	   prerr_endline (" Comparing to: "^fdir);
-	   let fstat = Unix.stat fdir in 
-	   (fstat.Unix.st_dev = stat.Unix.st_dev) &&
-	   (fstat.Unix.st_ino = stat.Unix.st_ino) && 
-           (prerr_endline " YES";true)
-	 with _ -> prerr_endline " No(because of a local exn)";false
-      )
-      Coq_config.theories_dirs
-  with _ -> prerr_endline " No(because of a global exn)";false
+  let is_same_file = same_file dir in
+  List.exists 
+    (fun s -> 
+      let fdir =
+        Filename.concat Coq_config.coqlib (Filename.concat "theories" s) in
+      prerr_endline (" Comparing to: "^fdir);
+      if is_same_file fdir then (prerr_endline " YES";true)
+      else (prerr_endline"NO";false))
+    Coq_config.theories_dirs
+
+let is_in_loadpath dir =
+  Library.is_in_load_paths (System.physical_path_of_string dir)
 
 let is_in_coq_path f = 
   try 
@@ -102,7 +103,9 @@ let is_in_coq_path f =
     false  
 
 let is_in_proof_mode () = 
-  try ignore (get_pftreestate ()); true with _ -> false
+  match Decl_mode.get_current_mode () with
+      Decl_mode.Mode_none -> false
+    | _ -> true
 
 let user_error_loc l s =
   raise (Stdpp.Exc_located (l, Util.UserError ("CoqIde", s)))
@@ -122,7 +125,7 @@ let interp verbosely s =
 	  | VernacDeclareTacticDefinition _
 		when is_in_proof_mode () -> 
 		  user_error_loc loc (str "CoqIDE do not support nested goals")
-	  | VernacDebug _ ->
+	  | VernacSetOption (Goptions.SecondaryTable ("Ltac","Debug"), _) ->
 	      user_error_loc loc (str "Debug mode not available within CoqIDE")
 	  | VernacResetName _
 	  | VernacResetInitial 
@@ -244,12 +247,13 @@ type hyp = env * evar_map *
            ((identifier * string) * constr option * constr) * 
            (string * string)
 type concl = env * evar_map * constr * string
+type meta = env * evar_map * string
 type goal = hyp list * concl
 
 let prepare_hyp sigma env ((i,c,d) as a) =
   env, sigma,
   ((i,string_of_id i),c,d), 
-  (msg (pr_var_decl env a), msg (prterm_env_at_top env d))
+  (msg (pr_var_decl env a), msg (pr_ltype_env env d))
 
 let prepare_hyps sigma env =
   assert (rel_context env = []);
@@ -263,7 +267,26 @@ let prepare_hyps sigma env =
 let prepare_goal sigma g =
   let env = evar_env g in
   (prepare_hyps sigma env,
-   (env, sigma, g.evar_concl, msg (prterm_env_at_top env g.evar_concl)))
+   (env, sigma, g.evar_concl, msg (pr_ltype_env_at_top env g.evar_concl)))
+
+let prepare_meta sigma env (m,typ)  =
+  env, sigma, 
+  (msg (str " ?" ++ int m ++ str " : " ++ pr_ltype_env_at_top env typ))
+
+let prepare_metas info sigma env =
+  List.fold_right 
+    (fun cpl acc ->  
+      let meta = prepare_meta sigma env cpl in meta :: acc)
+    info.pm_subgoals [] 
+
+let get_current_pm_goal () =
+  let pfts = get_pftreestate ()  in
+  let gls = try nth_goal_of_pftreestate 1 pfts with _ -> raise Not_found in
+  let info = Decl_mode.get_info gls.it in
+  let env = pf_env gls in
+  let sigma= sig_sig gls in
+    (prepare_hyps sigma env,
+     prepare_metas info sigma env)
 
 let get_current_goals () = 
     let pfts = get_pftreestate () in
@@ -273,14 +296,13 @@ let get_current_goals () =
 
 let get_current_goals_nb () = 
   try List.length (get_current_goals ()) with _ -> 0
-
   
 let print_no_goal () =
     let pfts = get_pftreestate () in
     let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in 
     assert (gls = []);
     let sigma = Tacmach.project (Tacmach.top_goal_of_pftreestate pfts) in
-    msg (Proof_trees.pr_subgoals_existential sigma gls)
+    msg (Printer.pr_subgoals (Decl_mode.get_end_command pfts) sigma gls)
 
 
 type word_class = Normal | Kwd | Reserved
@@ -329,11 +351,11 @@ type reset_info = NoReset | Reset of Names.identifier * bool ref
 let compute_reset_info = function 
   | VernacDefinition (_, (_,id), DefineBody _, _) 
   | VernacBeginSection (_,id) 
-  | VernacDefineModule ((_,id), _, _, _) 
-  | VernacDeclareModule ((_,id), _, _, _)
+  | VernacDefineModule (_,(_,id), _, _, _) 
+  | VernacDeclareModule (_,(_,id), _, _)
   | VernacDeclareModuleType ((_,id), _, _)
   | VernacAssumption (_, (_,((_,id)::_,_))::_)
-  | VernacInductive (_, ((_,id),_,_,_,_) :: _) ->
+  | VernacInductive (_, (((_,id),_,_,_),_) :: _) ->
       Reset (id, ref true)
   | VernacDefinition (_, (_,id), ProveBody _, _)
   | VernacStartTheoremProof (_, (_,id), _, _, _) ->
@@ -432,10 +454,8 @@ let make_cases s =
   let glob_ref = Nametab.locate qualified_name in
   match glob_ref with
     | Libnames.IndRef i -> 
-	let _,
-	{
-	  Declarations.mind_nparams = np ;
-	  Declarations.mind_consnames = carr ;
+	let {Declarations.mind_nparams = np},
+	{Declarations.mind_consnames = carr ;
 	 Declarations.mind_nf_lc = tarr } 
 	= Global.lookup_inductive i 
 	in
diff --git a/ide/coq.mli b/ide/coq.mli
index c1dfd847..4b4c3267 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq.mli,v 1.14.2.3 2005/01/21 17:21:33 herbelin Exp $ i*)
+(*i $Id: coq.mli 9154 2006-09-20 17:18:18Z corbinea $ i*)
 
 open Names
 open Term
@@ -27,11 +27,14 @@ val is_state_preserving : Vernacexpr.vernac_expr -> bool
 
 type hyp = env * evar_map * 
            ((identifier*string) * constr option * constr) * (string * string)
+type meta = env * evar_map * string
 type concl = env * evar_map * constr * string
 type goal = hyp list * concl
 
 val get_current_goals : unit -> goal list
 
+val get_current_pm_goal : unit -> hyp list * meta list
+
 val get_current_goals_nb : unit -> int
 
 val print_no_goal : unit -> string
@@ -50,6 +53,7 @@ val concl_menu : concl -> (string * string) list
 
 val is_in_coq_lib : string -> bool
 val is_in_coq_path : string -> bool
+val is_in_loadpath : string -> bool
 
 val make_cases : string -> string list list
 
diff --git a/ide/coq.png b/ide/coq.png
index 011203f7..2e5bdcd6 100644
--- a/ide/coq.png
+++ b/ide/coq.png
diff --git a/ide/coq2.ico b/ide/coq2.ico
index 36964902..bc1732fd 100755
--- a/ide/coq2.ico
+++ b/ide/coq2.ico
diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml
index 1169d438..30d99f5b 100644
--- a/ide/coq_commands.ml
+++ b/ide/coq_commands.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq_commands.ml,v 1.15.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+(* $Id: coq_commands.ml 7102 2005-06-03 13:14:27Z coq $ *)
 
 let commands = [
   [(* "Abort"; *)
@@ -22,6 +22,7 @@ let commands = [
    "Add Rec ML Path";
    "Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. ";
    "Add Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ].";
+   "Add Relation";
    "Add Setoid";
    "Axiom";];
   [(* "Back"; *) ];
@@ -63,7 +64,7 @@ let commands = [
    "Hint Unfold";
    "Hypothesis";];
   ["Identity Coercion";
-   "Implicits";
+   "Implicit Arguments";
    "Inductive";
    "Infix";
    ];
@@ -173,6 +174,8 @@ let state_preserving = [
   "Print Module Type";
   "Print Modules";
   "Print Proof";
+  "Print Rewrite HintDb";
+  "Print Setoids";
   "Print Scope";
   "Print Scopes.";
   "Print Section";
@@ -196,6 +199,7 @@ let state_preserving = [
 
   "Show";
   "Show Conjectures";
+  "Show Existentials";
   "Show Implicits";
   "Show Intro";
   "Show Intros";
@@ -207,6 +211,9 @@ let state_preserving = [
   "Test Printing Let";
   "Test Printing Synth";
   "Test Printing Wildcard";
+
+  "Whelp Hint";
+  "Whelp Locate";
 ]
 
 
diff --git a/ide/coq_tactics.ml b/ide/coq_tactics.ml
index 4dd20b47..92d2de78 100644
--- a/ide/coq_tactics.ml
+++ b/ide/coq_tactics.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq_tactics.ml,v 1.2.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+(* $Id: coq_tactics.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 let tactics = [
   "Abstract";
diff --git a/ide/coq_tactics.mli b/ide/coq_tactics.mli
index 962b4d27..05e233eb 100644
--- a/ide/coq_tactics.mli
+++ b/ide/coq_tactics.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coq_tactics.mli,v 1.1.2.2 2005/01/21 17:21:33 herbelin Exp $ i*)
+(*i $Id: coq_tactics.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 val tactics : string list
 
diff --git a/ide/coqide.ml b/ide/coqide.ml
index a8179fb9..fb650cbf 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -6,83 +6,82 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqide.ml,v 1.99.2.6 2006/01/06 13:22:36 barras Exp $ *)
+(* $Id: coqide.ml 9307 2006-10-28 18:48:48Z herbelin $ *)
 
 open Preferences
 open Vernacexpr
 open Coq
 open Ideutils
-
+  
 let out_some s = match s with 
   | None -> failwith "Internal error in out_some" | Some f -> f
-
+      
 let cb_ = ref None
 let cb () = ((out_some !cb_):GData.clipboard)
 let last_cb_content = ref ""
-
+  
 let (message_view:GText.view option ref) = ref None
 let (proof_view:GText.view option ref) = ref None
-
+  
 let (_notebook:GPack.notebook option ref) = ref None
 let notebook () = out_some !_notebook
-
-
+  
 (* Tabs contain the name of the edited file and 2 status informations: 
    Saved state + Focused proof buffer *)
 let decompose_tab w = 
   let vbox = new GPack.box ((Gobject.try_cast w "GtkBox"):Gtk.box Gtk.obj) in
   let l = vbox#children in
-  match l with 
-    | [img;lbl] -> 
-	let img = new GMisc.image 
-		    ((Gobject.try_cast img#as_widget "GtkImage"):
-		       Gtk.image Gtk.obj) 
-	in
-	let lbl = GMisc.label_cast lbl in
-	vbox,img,lbl
-    | _ -> assert false
-	
+    match l with 
+      | [img;lbl] -> 
+	  let img = new GMisc.image 
+	    ((Gobject.try_cast img#as_widget "GtkImage"):
+	       Gtk.image Gtk.obj) 
+	  in
+	  let lbl = GMisc.label_cast lbl in
+	    vbox,img,lbl
+      | _ -> assert false
+	  
 let set_tab_label i n =
   let nb = notebook () in
   let _,_,lbl = decompose_tab (nb#get_tab_label(nb#get_nth_page i))#as_widget 
   in
-  lbl#set_use_markup true;
-  (* lbl#set_text n *) lbl#set_label n
-
-
+    lbl#set_use_markup true;
+    (* lbl#set_text n *) lbl#set_label n
+    
+    
 let set_tab_image ~icon i = 
   let nb = notebook () in
   let _,img,_ = decompose_tab (nb#get_tab_label(nb#get_nth_page i))#as_widget
   in
-  img#set_icon_size `SMALL_TOOLBAR;
-  img#set_stock icon
-
+    img#set_icon_size `SMALL_TOOLBAR;
+    img#set_stock icon
+      
 let set_current_tab_image ~icon = set_tab_image ~icon (notebook())#current_page
   
 let set_current_tab_label n = set_tab_label (notebook())#current_page n 
-
+  
 let get_tab_label i =
   let nb = notebook () in
   let _,_,lbl = decompose_tab (nb#get_tab_label(nb#get_nth_page i))#as_widget 
   in
-  lbl#text
-
+    lbl#text
+      
 let get_full_tab_label i = 
   let nb = notebook () in
   let _,_,lbl = decompose_tab (nb#get_tab_label(nb#get_nth_page i))#as_widget 
   in
-  lbl
-
+    lbl
+      
 let get_current_tab_label () = get_tab_label (notebook())#current_page
-
+  
 let get_current_page () = 
   let i = (notebook())#current_page in
-  (notebook())#get_nth_page i
-
+    (notebook())#get_nth_page i
+      
 (* This function must remove "focused proof" decoration *)				      
 let reset_tab_label i = 
   set_tab_label i (get_tab_label i)
-
+    
 let to_do_on_page_switch = ref []
   
 module Vector = struct 
@@ -97,14 +96,14 @@ module Vector = struct
   let iter f t =  Array.iter (function | None -> () | Some x -> f x) !t
   let find_or_fail f t = 
     let test i = function | None -> () | Some e -> if f e then raise (Found i) in 
-    Array.iteri test t
+      Array.iteri test t
 	
   let exists f t =
     let l = Array.length !t in
     let rec test i = 
       (i < l) && (((!t.(i) <> None) && f (out_some !t.(i))) || test (i+1)) 
     in 
-    test 0
+      test 0
 end
 
 type 'a viewable_script =
@@ -115,107 +114,108 @@ type 'a viewable_script =
 
 class type analyzed_views= 
 object('self)
-    val mutable act_id : GtkSignal.id option
-    val current_all : 'self viewable_script
-    val mutable deact_id : GtkSignal.id option
-    val input_buffer : GText.buffer
-    val input_view : Undo.undoable_view
-    val last_array : string array
-    val mutable last_index : bool
-    val message_buffer : GText.buffer
-    val message_view : GText.view
-    val proof_buffer : GText.buffer
-    val proof_view : GText.view
-    val mutable is_active : bool
-    val mutable read_only : bool
-    val mutable filename : string option
-    val mutable stats : Unix.stats option
-    val mutable detached_views : GWindow.window list
-    method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b
-    method set_auto_complete : bool -> unit
-
-    method kill_detached_views : unit -> unit
-    method add_detached_view : GWindow.window -> unit
-    method remove_detached_view : GWindow.window -> unit
-
-    method view : Undo.undoable_view
-    method filename : string option
-    method stats :  Unix.stats option
-    method set_filename : string option -> unit
-    method update_stats : unit
-    method revert : unit
-    method auto_save : unit
-    method save : string -> bool
-    method save_as : string -> bool
-    method read_only : bool
-    method set_read_only : bool -> unit
-    method is_active : bool
-    method activate : unit -> unit
-    method active_keypress_handler : GdkEvent.Key.t -> bool
-    method backtrack_to : GText.iter -> unit
-    method backtrack_to_no_lock : GText.iter -> unit
-    method clear_message : unit
-    method deactivate : unit -> unit
-    method disconnected_keypress_handler : GdkEvent.Key.t -> bool
-    method electric_handler : GtkSignal.id
-    method find_phrase_starting_at :
-      GText.iter -> (GText.iter * GText.iter) option
-    method get_insert : GText.iter
-    method get_start_of_input : GText.iter
-    method go_to_insert : unit
-    method indent_current_line : unit
-    method insert_command : string -> string -> unit
-    method tactic_wizard : string list -> unit
-    method insert_message : string -> unit
-    method insert_this_phrase_on_success :
-      bool -> bool -> bool -> string -> string -> bool
-    method process_next_phrase : bool -> bool -> bool -> bool
-    method process_until_iter_or_error : GText.iter -> unit
-    method process_until_end_or_error : unit
-    method recenter_insert : unit
-    method reset_initial : unit
-    method send_to_coq :
-      bool -> bool -> string ->
-      bool -> bool -> bool -> (Util.loc * Vernacexpr.vernac_expr) option
-    method set_message : string -> unit
-    method show_goals : unit
-    method show_goals_full : unit
-    method undo_last_step : unit
-    method help_for_keyword : unit -> unit
-    method complete_at_offset : int -> bool
-
-    method blaster : unit -> unit
+  val mutable act_id : GtkSignal.id option
+  val current_all : 'self viewable_script
+  val mutable deact_id : GtkSignal.id option
+  val input_buffer : GText.buffer
+  val input_view : Undo.undoable_view
+  val last_array : string array
+  val mutable last_index : bool
+  val message_buffer : GText.buffer
+  val message_view : GText.view
+  val proof_buffer : GText.buffer
+  val proof_view : GText.view
+  val mutable is_active : bool
+  val mutable read_only : bool
+  val mutable filename : string option
+  val mutable stats : Unix.stats option
+  val mutable detached_views : GWindow.window list
+  method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b
+  method set_auto_complete : bool -> unit
+
+  method kill_detached_views : unit -> unit
+  method add_detached_view : GWindow.window -> unit
+  method remove_detached_view : GWindow.window -> unit
+
+  method view : Undo.undoable_view
+  method filename : string option
+  method stats :  Unix.stats option
+  method set_filename : string option -> unit
+  method update_stats : unit
+  method revert : unit
+  method auto_save : unit
+  method save : string -> bool
+  method save_as : string -> bool
+  method read_only : bool
+  method set_read_only : bool -> unit
+  method is_active : bool
+  method activate : unit -> unit
+  method active_keypress_handler : GdkEvent.Key.t -> bool
+  method backtrack_to : GText.iter -> unit
+  method backtrack_to_no_lock : GText.iter -> unit
+  method clear_message : unit
+  method deactivate : unit -> unit
+  method disconnected_keypress_handler : GdkEvent.Key.t -> bool
+  method electric_handler : GtkSignal.id
+  method find_phrase_starting_at :
+    GText.iter -> (GText.iter * GText.iter) option
+  method get_insert : GText.iter
+  method get_start_of_input : GText.iter
+  method go_to_insert : unit
+  method indent_current_line : unit
+  method insert_command : string -> string -> unit
+  method tactic_wizard : string list -> unit
+  method insert_message : string -> unit
+  method insert_this_phrase_on_success :
+    bool -> bool -> bool -> string -> string -> bool
+  method process_next_phrase : bool -> bool -> bool -> bool
+  method process_until_iter_or_error : GText.iter -> unit
+  method process_until_end_or_error : unit
+  method recenter_insert : unit
+  method reset_initial : unit
+  method send_to_coq :
+    bool -> bool -> string ->
+    bool -> bool -> bool -> (bool*(Util.loc * Vernacexpr.vernac_expr)) option
+  method set_message : string -> unit
+  method show_pm_goal : unit
+  method show_goals : unit
+  method show_goals_full : unit
+  method undo_last_step : unit
+  method help_for_keyword : unit -> unit
+  method complete_at_offset : int -> bool
+
+  method blaster : unit -> unit
 end
 
 let (input_views:analyzed_views viewable_script Vector.t) = Vector.create ()
 
 
 let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; 
-			  Sys.sigill; Sys.sigpipe; Sys.sigquit; 
-			  (* Sys.sigsegv; Sys.sigterm;*) Sys.sigusr2]
+			Sys.sigill; Sys.sigpipe; Sys.sigquit; 
+			(* Sys.sigsegv; Sys.sigterm;*) Sys.sigusr2]
 
 let crash_save i =
-(*  ignore (Unix.sigprocmask Unix.SIG_BLOCK signals_to_crash);*)
+  (*  ignore (Unix.sigprocmask Unix.SIG_BLOCK signals_to_crash);*)
   Pervasives.prerr_endline "Trying to save all buffers in .crashcoqide files";
   let count = ref 0 in 
-  Vector.iter 
-    (function {view=view; analyzed_view = Some av } -> 
-       (let filename = match av#filename with 
-	 | None -> 
-	     incr count; 
-	     "Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide"
-	 | Some f -> f^".crashcoqide"
-       in
-       try 
-	 if try_export filename (view#buffer#get_text ()) then
-	   Pervasives.prerr_endline ("Saved "^filename)
-	 else Pervasives.prerr_endline ("Could not save "^filename)
-       with _ -> Pervasives.prerr_endline ("Could not save "^filename))
-       | _ -> Pervasives.prerr_endline "Unanalyzed view found. Please report."
-    )
-    input_views;
-  Pervasives.prerr_endline "Done. Please report.";
-  if i <> 127 then exit i
+    Vector.iter 
+      (function {view=view; analyzed_view = Some av } -> 
+	 (let filename = match av#filename with 
+	    | None -> 
+		incr count; 
+		"Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide"
+	    | Some f -> f^".crashcoqide"
+	  in
+	    try 
+	      if try_export filename (view#buffer#get_text ()) then
+		Pervasives.prerr_endline ("Saved "^filename)
+	      else Pervasives.prerr_endline ("Could not save "^filename)
+	    with _ -> Pervasives.prerr_endline ("Could not save "^filename))
+	 | _ -> Pervasives.prerr_endline "Unanalyzed view found. Please report."
+      )
+      input_views;
+    Pervasives.prerr_endline "Done. Please report.";
+    if i <> 127 then exit i
 
 let ignore_break () =
   List.iter
@@ -237,53 +237,57 @@ let break () =
     begin
       prerr_endline " trying to stop computation:";
       if Mutex.try_lock coq_may_stop then begin
-	Util.interrupt := true;
-	prerr_endline " interrupt flag set. Computation should stop soon...";
-	Mutex.unlock coq_may_stop
-      end else prerr_endline " interruption refused (may not stop now)";
+	  Util.interrupt := true;
+	  prerr_endline " interrupt flag set. Computation should stop soon...";
+	  Mutex.unlock coq_may_stop
+	end else prerr_endline " interruption refused (may not stop now)";
     end
   else begin
-    Mutex.unlock coq_computing;
-    prerr_endline " ignored (not computing)"
-  end
+      Mutex.unlock coq_computing;
+      prerr_endline " ignored (not computing)"
+    end
 
 let do_if_not_computing text f x = 
   let threaded_task () =
     if Mutex.try_lock coq_computing 
     then 
       begin
-	prerr_endline ("Launching thread " ^ text);
 	let w = Blaster_window.blaster_window () in
-	if not (Mutex.try_lock w#lock) then begin 
-	  break ();
-	  let lck = Mutex.create () in
-	  Mutex.lock lck;
-	  prerr_endline "Waiting on blaster...";
-	  Condition.wait w#blaster_killed lck;
-	  prerr_endline "Waiting on blaster ok";
-	  Mutex.unlock lck
-	end else Mutex.unlock w#lock;
-	let idle = 
-	  Glib.Timeout.add ~ms:300
-	    ~callback:(fun () -> async !pulse ();true) in
-	begin
-	  prerr_endline "Getting lock";
-	  try
-	    f x;
-	    Glib.Timeout.remove idle;
-	    prerr_endline "Releasing lock";
-	    Mutex.unlock coq_computing;
-	  with e -> 
-	    Glib.Timeout.remove idle;
-	    prerr_endline "Releasing lock (on error)";
-	    Mutex.unlock coq_computing;
-	    raise e
-	end
+	  if not (Mutex.try_lock w#lock) then 
+	    begin 
+	      break ();
+	      let lck = Mutex.create () in
+		Mutex.lock lck;
+		prerr_endline "Waiting on blaster...";
+		Condition.wait w#blaster_killed lck;
+		prerr_endline "Waiting on blaster ok";
+		Mutex.unlock lck
+	    end 
+	  else 
+	    Mutex.unlock w#lock;
+	  let idle = 
+	    Glib.Timeout.add ~ms:300
+	      ~callback:(fun () -> async !pulse ();true) in
+	    begin
+	      prerr_endline "Getting lock";
+	      try
+		f x;
+		Glib.Timeout.remove idle;
+		prerr_endline "Releasing lock";
+		Mutex.unlock coq_computing;
+	      with e ->
+		Glib.Timeout.remove idle;
+		prerr_endline "Releasing lock (on error)";
+		Mutex.unlock coq_computing;
+		raise e
+	    end
       end 
     else 
       prerr_endline 
-	"Discarded order (computations are ongoing)" in
-  ignore (Thread.create threaded_task ())
+	"Discarded order (computations are ongoing)" 
+  in
+    prerr_endline ("Launching thread " ^ text);
+    ignore (Thread.create threaded_task ())
 
 let add_input_view tv = 
   Vector.append input_views tv
@@ -303,48 +307,48 @@ let set_active_view i =
      reset_tab_label i);
   (notebook ())#goto_page i; 
   let txt = get_current_tab_label () in
-  set_current_tab_label ("<span background=\"light green\">"^txt^"</span>");
-  active_view := Some i
+    set_current_tab_label ("<span background=\"light green\">"^txt^"</span>");
+    active_view := Some i
 
 let set_current_view i = (notebook ())#goto_page i
 
 let kill_input_view i = 
   let v = Vector.get input_views i in
-  (match v.analyzed_view with 
-    | Some v -> v#kill_detached_views ()
-    | None -> ());
-  v.view#destroy ();
-  v.analyzed_view <- None;
-  Vector.remove input_views i
+    (match v.analyzed_view with 
+       | Some v -> v#kill_detached_views ()
+       | None -> ());
+    v.view#destroy ();
+    v.analyzed_view <- None;
+    Vector.remove input_views i
 
 let get_current_view_page () = (notebook ())#current_page
 let get_current_view () = Vector.get input_views (notebook ())#current_page
 let remove_current_view_page () = 
   let c =  (notebook ())#current_page in
-  kill_input_view c;
-  ((notebook ())#get_nth_page c)#misc#hide ()
+    kill_input_view c;
+    ((notebook ())#get_nth_page c)#misc#hide ()
 
+let is_word_char c =
+  (* TODO: avoid num and prime at the head of a word *)
+  Glib.Unichar.isalnum c || c = underscore || c = prime
 
-let is_word_char c = 
-  Glib.Unichar.isalnum c || c = underscore || c = prime || c = arobase
-  
 let starts_word it = 
   prerr_endline ("Starts word ? '"^(Glib.Utf8.from_unichar it#char)^"'");
   (not it#copy#nocopy#backward_char ||
-    (let c = it#backward_char#char in
-     not (is_word_char c)))
+     (let c = it#backward_char#char in
+	not (is_word_char c)))
 
 let ends_word it = 
   (not it#copy#nocopy#forward_char ||
-  let c = it#forward_char#char in
-    not (Glib.Unichar.isalnum c || c = underscore || c = prime || c = arobase)
+     let c = it#forward_char#char in
+       not (is_word_char c)
   )
 
 let inside_word it = 
   let c = it#char in
-  not (starts_word it) &&
-  not (ends_word it) &&
-  (Glib.Unichar.isalnum c || c = underscore || c = prime || c = arobase)
+    not (starts_word it) &&
+      not (ends_word it) &&
+      is_word_char c
 
 let is_on_word_limit it = inside_word it || ends_word it 
 
@@ -362,31 +366,31 @@ let rec find_word_end it =
   prerr_endline "Find word end";
   if let c = it#char in c<>0 && is_word_char c
   then begin 
-    ignore (it#nocopy#forward_char);
-    find_word_end it
-  end else (prerr_endline ("Word end at: "^(string_of_int it#offset));it)
+      ignore (it#nocopy#forward_char);
+      find_word_end it
+    end else (prerr_endline ("Word end at: "^(string_of_int it#offset));it)
 let find_word_end it = find_word_end it#copy
 
 
 let get_word_around it = 
   let start = find_word_start it in
   let stop =  find_word_end it in
-  start,stop
+    start,stop
 
 
 let rec complete_backward w (it:GText.iter) = 
   prerr_endline "Complete backward...";
-	  match it#backward_search w with 
-	    | None -> (prerr_endline "backward_search failed";None)
-	    | Some (start,stop) -> 
-		prerr_endline ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset));
-		if starts_word start then 
-		  let ne = find_word_end stop in
-		  if ne#compare stop = 0
-		  then complete_backward w start
-		  else Some (start,stop,ne)
-		else complete_backward w start
-		  
+  match it#backward_search w with 
+    | None -> (prerr_endline "backward_search failed";None)
+    | Some (start,stop) -> 
+	prerr_endline ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset));
+	if starts_word start then 
+	  let ne = find_word_end stop in
+	    if ne#compare stop = 0
+	    then complete_backward w start
+	    else Some (start,stop,ne)
+	else complete_backward w start
+	  
 let rec complete_forward w (it:GText.iter) = 
   prerr_endline "Complete forward...";
   match it#forward_search w with 
@@ -394,16 +398,16 @@ let rec complete_forward w (it:GText.iter) =
     | Some (start,stop) -> 
 	if starts_word start then 	
 	  let ne = find_word_end stop in
-	  if ne#compare stop = 0 then 
-	    complete_forward w stop
-	  else Some (stop,stop,ne)
+	    if ne#compare stop = 0 then 
+	      complete_forward w stop
+	    else Some (stop,stop,ne)
 	else complete_forward w stop
 
 (* Reset this to None on page change ! *)
 let (last_completion:(string*int*int*bool) option ref) = ref None
 
 let () = to_do_on_page_switch := 
-	 (fun i -> last_completion := None)::!to_do_on_page_switch
+  (fun i -> last_completion := None)::!to_do_on_page_switch
 
 let rec complete input_buffer w (offset:int) =
   match !last_completion with 
@@ -411,68 +415,68 @@ let rec complete input_buffer w (offset:int) =
 	when lw=w && loffset=offset ->
 	begin
 	  let iter = input_buffer#get_iter (`OFFSET lpos) in
-	  if backward then 
-	    match complete_backward w iter with
-	      | None -> 
-		  last_completion := 
-		Some (lw,loffset,
-		      (find_word_end 
-			 (input_buffer#get_iter (`OFFSET loffset)))#offset ,
-		      false); 
-		  None
-	      | Some (ss,start,stop) as result -> 
-		  last_completion := 
-		Some (w,offset,ss#offset,true);
-		  result
-	  else
-	    match complete_forward w iter with
-	      | None -> 
-		  last_completion := None;
-		  None
-	      | Some (ss,start,stop) as result -> 
-		  last_completion := 
-		Some (w,offset,ss#offset,false);
-		  result
+	    if backward then 
+	      match complete_backward w iter with
+		| None -> 
+		    last_completion := 
+		      Some (lw,loffset,
+			    (find_word_end 
+			       (input_buffer#get_iter (`OFFSET loffset)))#offset ,
+			    false); 
+		    None
+		| Some (ss,start,stop) as result -> 
+		    last_completion := 
+		      Some (w,offset,ss#offset,true);
+		    result
+	    else
+	      match complete_forward w iter with
+		| None -> 
+		    last_completion := None;
+		    None
+		| Some (ss,start,stop) as result -> 
+		    last_completion := 
+		      Some (w,offset,ss#offset,false);
+		    result
 	end
     | _ -> begin
-	match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with
-	  | None -> 
-	      last_completion := 
-	    Some (w,offset,(find_word_end (input_buffer#get_iter
-					     (`OFFSET offset)))#offset,false);
-	      complete input_buffer w offset
-	  | Some (ss,start,stop) as result -> 
-	      last_completion := Some (w,offset,ss#offset,true);
-	      result
+	  match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with
+	    | None -> 
+		last_completion := 
+		  Some (w,offset,(find_word_end (input_buffer#get_iter
+						   (`OFFSET offset)))#offset,false);
+		complete input_buffer w offset
+	    | Some (ss,start,stop) as result -> 
+		last_completion := Some (w,offset,ss#offset,true);
+		result
       end
-	  
+	
 let get_current_word () =
   let av = out_some ((get_current_view ()).analyzed_view) in 
-  match GtkBase.Clipboard.wait_for_text (cb ())#as_clipboard with
-    | None -> 
-	prerr_endline "None selected";
-	let it = av#get_insert in
-	let start = find_word_start it in
-	let stop = find_word_end start in
-	av#view#buffer#move_mark `SEL_BOUND start;
-	av#view#buffer#move_mark `INSERT stop;
-	av#view#buffer#get_text ~slice:true ~start ~stop ()
-    | Some t ->
- 	prerr_endline "Some selected";
-	prerr_endline t;
-	t
-	  
+    match GtkBase.Clipboard.wait_for_text (cb ())#as_clipboard with
+      | None -> 
+	  prerr_endline "None selected";
+	  let it = av#get_insert in
+	  let start = find_word_start it in
+	  let stop = find_word_end start in
+	    av#view#buffer#move_mark `SEL_BOUND start;
+	    av#view#buffer#move_mark `INSERT stop;
+	    av#view#buffer#get_text ~slice:true ~start ~stop ()
+      | Some t ->
+ 	  prerr_endline "Some selected";
+	  prerr_endline t;
+	  t
+	    
 
 let input_channel b ic =
   let buf = String.create 1024 and len = ref 0 in
-  while len := input ic buf 0 1024; !len > 0 do
-    Buffer.add_substring b buf 0 !len
-  done
+    while len := input ic buf 0 1024; !len > 0 do
+      Buffer.add_substring b buf 0 !len
+    done
 
 let with_file name ~f =
   let ic = open_in_gen [Open_rdonly;Open_creat] 0o644 name in
-  try f ic; close_in ic with exn -> 
-    close_in ic; !flash_info ("Error: "^Printexc.to_string exn)
+    try f ic; close_in ic with exn -> 
+      close_in ic; !flash_info ("Error: "^Printexc.to_string exn)
 
 type info =  {start:GText.mark;
 	      stop:GText.mark;
@@ -492,34 +496,34 @@ let is_empty () = Stack.is_empty processed_stack
 
 let update_on_end_of_proof id =
   let lookup_lemma = function
-  | { ast = _, ( VernacDefinition (_, _, ProveBody _, _)
-	       | VernacDeclareTacticDefinition _
-	       | VernacStartTheoremProof _) ; 
-      reset_info = Reset (_, r) } -> 
-      if not !r then begin 
-	prerr_endline "Toggling Reset info to true";
-	r := true; raise Exit end
-      else begin
-	prerr_endline "Toggling Changing Reset id"; 
-	r := false
-      end
-  | { ast = _, (VernacAbort _ | VernacAbortAll | VernacGoal _) } -> raise Exit
-  | _ -> ()
+    | { ast = _, ( VernacDefinition (_, _, ProveBody _, _)
+	| VernacDeclareTacticDefinition _
+	| VernacStartTheoremProof _) ; 
+	reset_info = Reset (_, r) } -> 
+	if not !r then begin 
+	    prerr_endline "Toggling Reset info to true";
+	    r := true; raise Exit end
+	else begin
+	    prerr_endline "Toggling Changing Reset id"; 
+	    r := false
+	  end
+    | { ast = _, (VernacAbort _ | VernacAbortAll | VernacGoal _) } -> raise Exit
+    | _ -> ()
   in
-  try Stack.iter lookup_lemma processed_stack with Exit -> ()
+    try Stack.iter lookup_lemma processed_stack with Exit -> ()
 
 let update_on_end_of_segment id =
   let lookup_section = function 
     | { ast = _, ( VernacBeginSection id'
-		 | VernacDefineModule (id',_,_,None)
-		 | VernacDeclareModule (id',_,_,None)
-		 | VernacDeclareModuleType (id',_,None)); 
+	| VernacDefineModule (_,id',_,_,None)
+	| VernacDeclareModule (_,id',_,_)
+	| VernacDeclareModuleType (id',_,None)); 
 	reset_info = Reset (_, r) } 
-       when id = id' -> raise Exit
+	when id = id' -> raise Exit
     | { reset_info = Reset (_, r) } -> r := false
     | _ -> ()
   in
-  try Stack.iter lookup_section processed_stack with Exit -> ()
+    try Stack.iter lookup_section processed_stack with Exit -> ()
 
 let push_phrase start_of_phrase_mark end_of_phrase_mark ast = 
   let x = {start = start_of_phrase_mark;
@@ -528,19 +532,19 @@ let push_phrase start_of_phrase_mark end_of_phrase_mark ast =
 	   reset_info = Coq.compute_reset_info (snd ast)
 	  } 
   in
-  push x;
-  match snd ast with
-    | VernacEndProof (Proved (_, None)) -> update_on_end_of_proof ()
-    | VernacEndSegment id -> update_on_end_of_segment id
-    | _ -> ()
+    push x;
+    match snd ast with
+      | VernacEndProof (Proved (_, None)) -> update_on_end_of_proof ()
+      | VernacEndSegment id -> update_on_end_of_segment id
+      | _ -> ()
 
 let repush_phrase x =
   let x = { x with reset_info = Coq.compute_reset_info (snd x.ast) } in
-  push x;
-  match snd x.ast with
-    | VernacEndProof (Proved (_, None)) -> update_on_end_of_proof ()
-    | VernacEndSegment id -> update_on_end_of_segment id
-    | _ -> ()
+    push x;
+    match snd x.ast with
+      | VernacEndProof (Proved (_, None)) -> update_on_end_of_proof ()
+      | VernacEndSegment id -> update_on_end_of_segment id
+      | _ -> ()
 
 (* For electric handlers *)
 exception Found
@@ -553,19 +557,19 @@ let activate_input i =
      | None -> () 
      | Some n ->
 	 let a_v = out_some (Vector.get input_views n).analyzed_view in
-	 a_v#deactivate ();
-	 a_v#reset_initial
+	   a_v#deactivate ();
+	   a_v#reset_initial
   );
   let activate_function = (out_some (Vector.get input_views i).analyzed_view)#activate in
-  activate_function ();
-  set_active_view i
+    activate_function ();
+    set_active_view i
 
 let warning msg = 
   GToolbox.message_box ~title:"Warning"
     ~icon:(let img = GMisc.image () in
-		img#set_stock `DIALOG_WARNING;
-		img#set_icon_size `DIALOG;
-		img#coerce)
+	     img#set_stock `DIALOG_WARNING;
+	     img#set_icon_size `DIALOG;
+	     img#coerce)
     msg
 
 
@@ -596,10 +600,10 @@ object(self)
   method set_auto_complete t = auto_complete_on <- t
   method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b = fun f x ->
     let old = auto_complete_on in
-    self#set_auto_complete false;
-    let y = f x in
-    self#set_auto_complete old;
-    y
+      self#set_auto_complete false;
+      let y = f x in
+	self#set_auto_complete old;
+	y
   method add_detached_view (w:GWindow.window) = 
     detached_views <- w::detached_views
   method remove_detached_view (w:GWindow.window) = 
@@ -615,99 +619,99 @@ object(self)
   method set_filename f = 
     filename <- f;
     match f with 
-    | Some f -> stats <- my_stat f
-    | None -> ()
+      | Some f -> stats <- my_stat f
+      | None -> ()
 
   method update_stats = 
     match filename with 
-    | Some f -> stats <- my_stat f 
-    | _ -> ()
+      | Some f -> stats <- my_stat f 
+      | _ -> ()
 
   method revert = 
     match filename with 
-    | Some f -> begin
-	let do_revert () = begin
-	  !push_info "Reverting buffer";
-	  try
-	    if is_active then self#reset_initial;
-	    let b = Buffer.create 1024 in
-	    with_file f ~f:(input_channel b);
-	    let s = try_convert (Buffer.contents b) in
-	    input_buffer#set_text s;
-	    self#update_stats;
-	    input_buffer#place_cursor input_buffer#start_iter;
-	    input_buffer#set_modified false;
-	    !pop_info ();
-	    !flash_info "Buffer reverted";
-	    Highlight.highlight_all input_buffer;
-	  with _  -> 
-	    !pop_info ();
-	    !flash_info "Warning: could not revert buffer";
+      | Some f -> begin
+	    let do_revert () = begin
+		!push_info "Reverting buffer";
+		try
+		  if is_active then self#reset_initial;
+		  let b = Buffer.create 1024 in
+		    with_file f ~f:(input_channel b);
+		    let s = try_convert (Buffer.contents b) in
+		      input_buffer#set_text s;
+		      self#update_stats;
+		      input_buffer#place_cursor input_buffer#start_iter;
+		      input_buffer#set_modified false;
+		      !pop_info ();
+		      !flash_info "Buffer reverted";
+		      Highlight.highlight_all input_buffer;
+		with _  -> 
+		  !pop_info ();
+		  !flash_info "Warning: could not revert buffer";
+	      end
+	    in
+	      if input_buffer#modified then 
+		match (GToolbox.question_box 
+			 ~title:"Modified buffer changed on disk"
+			 ~buttons:["Revert from File";
+				   "Overwrite File";
+				   "Disable Auto Revert"] 
+			 ~default:0
+			 ~icon:(stock_to_widget `DIALOG_WARNING)
+			 "Some unsaved buffers changed on disk"
+		      )
+		with 1 -> do_revert ()
+		  | 2 -> if self#save f then !flash_info "Overwritten" else
+			!flash_info "Could not overwrite file"
+		  | _ -> 
+		      prerr_endline "Auto revert set to false";
+		      !current.global_auto_revert <- false;
+		      disconnect_revert_timer ()
+	      else do_revert () 
 	end
-	in
-	if input_buffer#modified then 
-	  match (GToolbox.question_box 
-		   ~title:"Modified buffer changed on disk"
-		   ~buttons:["Revert from File";
-			     "Overwrite File";
-			     "Disable Auto Revert"] 
-		   ~default:0
-		   ~icon:(stock_to_widget `DIALOG_WARNING)
-		   "Some unsaved buffers changed on disk"
-		)
-	  with 1 -> do_revert ()
-	  | 2 -> if self#save f then !flash_info "Overwritten" else
-	      !flash_info "Could not overwrite file"
-	  | _ -> 
-	      prerr_endline "Auto revert set to false";
-	      !current.global_auto_revert <- false;
-	      disconnect_revert_timer ()
-	else do_revert () 
-      end
-    | None -> ()
-	
+      | None -> ()
+	  
   method save f = 
     if try_export f (input_buffer#get_text ()) then begin
-      filename <- Some f;
-      input_buffer#set_modified false;
-      stats <- my_stat f;
-      (match self#auto_save_name with 
-       | None -> ()
-       | Some fn -> try Sys.remove fn with _ -> ());
-      true
-    end
+	filename <- Some f;
+	input_buffer#set_modified false;
+	stats <- my_stat f;
+	(match self#auto_save_name with 
+	   | None -> ()
+	   | Some fn -> try Sys.remove fn with _ -> ());
+	true
+      end
     else false
 
   method private auto_save_name = 
     match filename with 
-    | None -> None
-    | Some f -> 
-	let dir = Filename.dirname f in
-	let base = (fst !current.auto_save_name) ^ 
-		   (Filename.basename f) ^ 
-		   (snd !current.auto_save_name) 
-	in Some (Filename.concat dir base)
-	     
+      | None -> None
+      | Some f -> 
+	  let dir = Filename.dirname f in
+	  let base = (fst !current.auto_save_name) ^ 
+	    (Filename.basename f) ^ 
+	    (snd !current.auto_save_name) 
+	  in Some (Filename.concat dir base)
+	    
   method private need_auto_save = 
     input_buffer#modified &&
-    last_modification_time > last_auto_save_time
+      last_modification_time > last_auto_save_time
       
   method auto_save =
     if self#need_auto_save then begin
-      match self#auto_save_name with 
-      | None -> () 
-      | Some fn -> 
-	  try 
-	    last_auto_save_time <- Unix.time();
-	    prerr_endline ("Autosave time : "^(string_of_float (Unix.time())));
-	    if try_export fn (input_buffer#get_text ()) then begin
-	      !flash_info ~delay:1000 "Autosaved"
-	    end
-	    else warning 
-	      ("Autosave failed (check if " ^ fn ^ " is writable)")
-	  with _ -> 
-	    warning ("Autosave: unexpected error while writing "^fn)
-    end	      
+	match self#auto_save_name with 
+	  | None -> () 
+	  | Some fn -> 
+	      try 
+		last_auto_save_time <- Unix.time();
+		prerr_endline ("Autosave time : "^(string_of_float (Unix.time())));
+		if try_export fn (input_buffer#get_text ()) then begin
+		    !flash_info ~delay:1000 "Autosaved"
+		  end
+		else warning 
+		  ("Autosave failed (check if " ^ fn ^ " is writable)")
+	      with _ -> 
+		warning ("Autosave: unexpected error while writing "^fn)
+      end	      
       
   method save_as f =
     if Sys.file_exists f then 
@@ -717,13 +721,13 @@ object(self)
 	       ~default:1
 	       ~icon:
 	       (let img = GMisc.image () in
-		img#set_stock `DIALOG_WARNING;
-		img#set_icon_size `DIALOG;
-		img#coerce)
+		  img#set_stock `DIALOG_WARNING;
+		  img#set_icon_size `DIALOG;
+		  img#coerce)
 	       ("File "^f^"already exists")
 	    )
       with 1 -> self#save f
-      | _ -> false
+	| _ -> false
     else self#save f
 
   method set_read_only b = read_only<-b
@@ -750,10 +754,10 @@ object(self)
        PLUS : GTK BUG ??? Cannot be called from a thread...
        ADDITION: using sync instead of async causes deadlock...*)
     ignore (GtkThread.async (
-	      input_view#scroll_to_mark 
-			       ~use_align:false
-			       ~yalign:0.75
-			       ~within_margin:0.25)
+			      input_view#scroll_to_mark 
+				~use_align:false
+				~yalign:0.75
+				~within_margin:0.25)
 	      `INSERT)
 
 
@@ -762,74 +766,112 @@ object(self)
       let it = it#copy in
       let nb_sep = ref 0 in
       let continue = ref true in
-      while !continue do 
-	if it#char = space then begin 
-	  incr nb_sep;
-	  if not it#nocopy#forward_char then continue := false;
-	end else continue := false
-      done;
-      !nb_sep
+	while !continue do 
+	  if it#char = space then begin 
+	      incr nb_sep;
+	      if not it#nocopy#forward_char then continue := false;
+	    end else continue := false
+	done;
+	!nb_sep
     in
     let previous_line = self#get_insert in
-    if previous_line#nocopy#backward_line then begin
-      let previous_line_spaces = get_nb_space previous_line in
-      let current_line_start = self#get_insert#set_line_offset 0 in
-      let current_line_spaces = get_nb_space current_line_start in
-      if input_buffer#delete_interactive 
-	~start:current_line_start 
-	~stop:(current_line_start#forward_chars current_line_spaces)
-	()
-      then 
-	let current_line_start = self#get_insert#set_line_offset 0 in
-	input_buffer#insert 
-	  ~iter:current_line_start
-	  (String.make previous_line_spaces ' ')
-    end
+      if previous_line#nocopy#backward_line then begin
+	  let previous_line_spaces = get_nb_space previous_line in
+	  let current_line_start = self#get_insert#set_line_offset 0 in
+	  let current_line_spaces = get_nb_space current_line_start in
+	    if input_buffer#delete_interactive 
+	      ~start:current_line_start 
+	      ~stop:(current_line_start#forward_chars current_line_spaces)
+	      ()
+	    then 
+	      let current_line_start = self#get_insert#set_line_offset 0 in
+		input_buffer#insert 
+		  ~iter:current_line_start
+		  (String.make previous_line_spaces ' ')
+	end
 
+  method show_pm_goal = 
+      proof_buffer#insert 
+	(Printf.sprintf "    *** Declarative Mode ***\n");
+      try 
+	let (hyps,metas) = get_current_pm_goal () in
+	List.iter
+	  (fun ((_,_,_,(s,_)) as _hyp) -> 
+	     proof_buffer#insert (s^"\n"))
+	  hyps;
+	proof_buffer#insert 
+	  (String.make 38 '_' ^ "\n");
+	List.iter
+	  (fun (_,_,m) -> 
+	     proof_buffer#insert (m^"\n"))
+	  metas;
+	let my_mark = `NAME "end_of_conclusion" in
+	  proof_buffer#move_mark
+	    ~where:((proof_buffer#get_iter_at_mark `INSERT)) 
+	    my_mark;
+	  ignore (proof_view#scroll_to_mark my_mark) 
+    with Not_found ->  
+      match Decl_mode.get_end_command (Pfedit.get_pftreestate ()) with
+	  Some endc ->
+	    proof_buffer#insert 
+	      ("Subproof completed, now type "^endc^".") 
+	| None ->
+	    proof_buffer#insert "Proof completed."
 
   method show_goals = 
     try
       proof_view#buffer#set_text "";
-      let s = Coq.get_current_goals () in
-      match s with 
-      | [] -> proof_buffer#insert (Coq.print_no_goal ())
-      | (hyps,concl)::r -> 
-	  let goal_nb = List.length s in
-	  proof_buffer#insert (Printf.sprintf "%d subgoal%s\n" 
-				 goal_nb
-				 (if goal_nb<=1 then "" else "s"));
-	  List.iter
-	    (fun ((_,_,_,(s,_)) as hyp) -> 
-	       proof_buffer#insert (s^"\n"))
-	    hyps;
-	  proof_buffer#insert (String.make 38 '_' ^ "(1/"^
-			       (string_of_int goal_nb)^
-			       ")\n") 
-	  ;
-	  let _,_,_,sconcl = concl in
-	  proof_buffer#insert sconcl;
-	  proof_buffer#insert "\n";
-	  let my_mark = `NAME "end_of_conclusion" in
-	  proof_buffer#move_mark
-	    ~where:((proof_buffer#get_iter_at_mark `INSERT)) my_mark;
-	  proof_buffer#insert "\n\n";
-	  let i = ref 1 in
-	  List.iter 
-	    (function (_,(_,_,_,concl)) -> 
-	       incr i;
-	       proof_buffer#insert (String.make 38 '_' ^"("^
-				    (string_of_int !i)^
-				    "/"^
-				    (string_of_int goal_nb)^
-				    ")\n");
-	       proof_buffer#insert concl;
-	       proof_buffer#insert "\n\n";
-	    )
-	    r;
-	  ignore (proof_view#scroll_to_mark my_mark) 
-      with e -> prerr_endline ("Don't worry be happy despite: "^Printexc.to_string e)
+      match Decl_mode.get_current_mode () with
+	  Decl_mode.Mode_none ->  proof_buffer#insert (Coq.print_no_goal ())
+	| Decl_mode.Mode_tactic ->   
+	    begin
+	      let s = Coq.get_current_goals () in
+		match s with 
+		  | [] -> proof_buffer#insert (Coq.print_no_goal ())
+		  | (hyps,concl)::r -> 
+		      let goal_nb = List.length s in
+			proof_buffer#insert 
+			  (Printf.sprintf "%d subgoal%s\n" 
+			     goal_nb
+			     (if goal_nb<=1 then "" else "s"));
+			List.iter
+			  (fun ((_,_,_,(s,_)) as _hyp) -> 
+			     proof_buffer#insert (s^"\n"))
+			  hyps;
+			proof_buffer#insert 
+			  (String.make 38 '_' ^ "(1/"^
+			     (string_of_int goal_nb)^
+			     ")\n") ;
+			let _,_,_,sconcl = concl in
+			  proof_buffer#insert sconcl;
+			  proof_buffer#insert "\n";
+			  let my_mark = `NAME "end_of_conclusion" in
+			    proof_buffer#move_mark
+			      ~where:((proof_buffer#get_iter_at_mark `INSERT)) 
+			      my_mark;
+			    proof_buffer#insert "\n\n";
+			    let i = ref 1 in
+			      List.iter 
+				(function (_,(_,_,_,concl)) -> 
+				   incr i;
+				   proof_buffer#insert 
+				     (String.make 38 '_' ^"("^
+					(string_of_int !i)^
+					"/"^
+					(string_of_int goal_nb)^
+					")\n");
+				   proof_buffer#insert concl;
+				   proof_buffer#insert "\n\n";
+				)
+				r;
+			      ignore (proof_view#scroll_to_mark my_mark) 
+	    end
+	| Decl_mode.Mode_proof -> 
+	    self#show_pm_goal
+    with e -> 
+      prerr_endline ("Don't worry be happy despite: "^Printexc.to_string e)
 	
-
+	      
   val mutable full_goal_done = true
 
   method show_goals_full = 
@@ -837,33 +879,39 @@ object(self)
       begin
 	try
 	  proof_view#buffer#set_text "";
-	  let s = Coq.get_current_goals () in
-	  let last_shown_area = proof_buffer#create_tag [`BACKGROUND "light green"]
-	  in
-	  match s with 
-	  | [] -> proof_buffer#insert (Coq.print_no_goal ())
-	  | (hyps,concl)::r -> 
-	      let goal_nb = List.length s in
-	      proof_buffer#insert (Printf.sprintf "%d subgoal%s\n" 
-				     goal_nb
-				     (if goal_nb<=1 then "" else "s"));
-	      let coq_menu commands = 
-		let tag = proof_buffer#create_tag []
-		in 
-		ignore
-		  (tag#connect#event ~callback:
-		     (fun ~origin ev it ->
-			begin match GdkEvent.get_type ev with 
-			| `BUTTON_PRESS -> 
-			    let ev = (GdkEvent.Button.cast ev) in
-			    if (GdkEvent.Button.button ev) = 3
-			    then begin 
-			      let loc_menu = GMenu.menu () in
-			      let factory = new GMenu.factory loc_menu in
-			      let add_coq_command (cp,ip) = 
-				ignore 
-				  (factory#add_item cp 
-				     ~callback:
+	  match Decl_mode.get_current_mode () with
+	      Decl_mode.Mode_none ->  
+		proof_buffer#insert (Coq.print_no_goal ())
+	    | Decl_mode.Mode_tactic ->   
+		begin
+		  match Coq.get_current_goals () with 
+		      [] -> Util.anomaly "show_goals_full"
+		  | ((hyps,concl)::r) as s ->
+		      let last_shown_area = 
+			proof_buffer#create_tag [`BACKGROUND "light green"]
+		      in
+		      let goal_nb = List.length s in
+			proof_buffer#insert (Printf.sprintf "%d subgoal%s\n" 
+					 goal_nb
+					 (if goal_nb<=1 then "" else "s"));
+		  let coq_menu commands = 
+		    let tag = proof_buffer#create_tag []
+		    in 
+		      ignore
+			(tag#connect#event ~callback:
+			   (fun ~origin ev it ->
+			      begin match GdkEvent.get_type ev with 
+				| `BUTTON_PRESS -> 
+				    let ev = (GdkEvent.Button.cast ev) in
+				      if (GdkEvent.Button.button ev) = 3
+				      then begin 
+					let loc_menu = GMenu.menu () in
+					let factory = 
+					  new GMenu.factory loc_menu in
+					let add_coq_command (cp,ip) = 
+					  ignore 
+					    (factory#add_item cp 
+					       ~callback:
 				     (fun () -> ignore
 					(self#insert_this_phrase_on_success 
 					   true
@@ -935,8 +983,11 @@ object(self)
 		   proof_buffer#insert "\n\n";
 		)
 		r;
-	      ignore (proof_view#scroll_to_mark my_mark) ;
-	      full_goal_done <- true;
+		ignore (proof_view#scroll_to_mark my_mark) ;
+		full_goal_done <- true
+		end
+	    | Decl_mode.Mode_proof ->
+		self#show_pm_goal
 	  with e -> prerr_endline (Printexc.to_string e)
       end
       
@@ -944,37 +995,40 @@ object(self)
     let display_output msg =
       self#insert_message (if show_output then msg else "") in
     let display_error e =
-	 let (s,loc) = Coq.process_exn e in
-	 assert (Glib.Utf8.validate s);
-	 self#set_message s;
-	 message_view#misc#draw None;
-	 if localize then 
-	   (match Util.option_app Util.unloc loc with 
-	    | None -> ()
-	    | Some (start,stop) ->
-		let convert_pos = byte_offset_to_char_offset phrase in
-		let start = convert_pos start in
-		let stop = convert_pos stop in
-		let i = self#get_start_of_input in 
-		let starti = i#forward_chars start in
-		let stopi = i#forward_chars stop in
-		input_buffer#apply_tag_by_name "error"
-   		  ~start:starti
-		  ~stop:stopi;
-		input_buffer#place_cursor starti) in
+      let (s,loc) = Coq.process_exn e in
+      assert (Glib.Utf8.validate s);
+      self#insert_message s;
+      message_view#misc#draw None;
+      if localize then 
+	(match Util.option_map Util.unloc loc with 
+	  | None -> ()
+	  | Some (start,stop) ->
+	      let convert_pos = byte_offset_to_char_offset phrase in
+	      let start = convert_pos start in
+	      let stop = convert_pos stop in
+	      let i = self#get_start_of_input in 
+	      let starti = i#forward_chars start in
+	      let stopi = i#forward_chars stop in
+	      input_buffer#apply_tag_by_name "error"
+   		~start:starti
+		~stop:stopi;
+	      input_buffer#place_cursor starti) in
     try 
       full_goal_done <- false;
       prerr_endline "Send_to_coq starting now";
+      Decl_mode.clear_daimon_flag ();
       if replace then begin
 	let r,info = Coq.interp_and_replace ("info " ^ phrase) in
-	let msg = read_stdout () in 
-	sync display_output msg;
-	Some r
+	let complete = not (Decl_mode.get_daimon_flag ()) in 
+	let msg = read_stdout () in
+        sync display_output msg;
+	Some (complete,r)	
       end else begin
 	let r = Coq.interp verbosely phrase in
-	let msg = read_stdout () in 
-	sync display_output msg;
-	Some r
+	let complete = not (Decl_mode.get_daimon_flag ()) in 
+	let msg = read_stdout () in
+        sync display_output msg;
+        Some (complete,r)
       end
     with e ->
       if show_error then sync display_error e;
@@ -987,219 +1041,231 @@ object(self)
     let lexbuf_function s count =
       let i = ref 0 in
       let n_trash = String.length !trash_bytes in
-      String.blit !trash_bytes 0 s 0 n_trash;
-      i := n_trash;
-      try
-	while !i <= count - 1 do
-	  let c = end_iter#char in
-	  if c = 0 then raise (Stop !i);
-	  let c' = Glib.Utf8.from_unichar c in
-	  let n = String.length c' in
-	  if (n<=0) then exit (-2);
-	  if n > count - !i  then 
-	    begin
-	      let ri = count - !i in
-	      String.blit c' 0 s !i ri;
-	      trash_bytes := String.sub c' ri (n-ri);
-	      i := count ;
-	    end else begin
-	      String.blit c' 0 s !i n;
-	      i:= !i + n
-	    end;
-	  if not end_iter#nocopy#forward_char then 
-	    raise (Stop !i)
-	done;
-	count
-      with Stop x ->
-	x
+	String.blit !trash_bytes 0 s 0 n_trash;
+	i := n_trash;
+	try
+	  while !i <= count - 1 do
+	    let c = end_iter#char in
+	      if c = 0 then raise (Stop !i);
+	      let c' = Glib.Utf8.from_unichar c in
+	      let n = String.length c' in
+		if (n<=0) then exit (-2);
+		if n > count - !i  then 
+		  begin
+		    let ri = count - !i in
+		      String.blit c' 0 s !i ri;
+		      trash_bytes := String.sub c' ri (n-ri);
+		      i := count ;
+		  end else begin
+		      String.blit c' 0 s !i n;
+		      i:= !i + n
+		    end;
+		if not end_iter#nocopy#forward_char then 
+		  raise (Stop !i)
+	  done;
+	  count
+	with Stop x ->
+	  x
     in
-    try
-      trash_bytes := "";
-      let phrase = Find_phrase.get (Lexing.from_function lexbuf_function) 
-      in
-      end_iter#nocopy#set_offset (start#offset + !Find_phrase.length);
-      Some (start,end_iter)
-    with
-(*
-    | Find_phrase.EOF s -> 
-	(* Phrase is at the end of the buffer*)
-	let si = start#offset in
-	let ei = si + !Find_phrase.length in
-	end_iter#nocopy#set_offset (ei - 1);
-	input_buffer#insert ~iter:end_iter "\n";
-	Some (input_buffer#get_iter (`OFFSET si),
-	      input_buffer#get_iter (`OFFSET ei))
-*)
-    | _ -> None
+      try
+	trash_bytes := "";
+	let _ = Find_phrase.get (Lexing.from_function lexbuf_function) 
+	in
+	  end_iter#nocopy#set_offset (start#offset + !Find_phrase.length);
+	  Some (start,end_iter)
+      with
+	  (*
+	    | Find_phrase.EOF s -> 
+	  (* Phrase is at the end of the buffer*)
+	    let si = start#offset in
+	    let ei = si + !Find_phrase.length in
+	    end_iter#nocopy#set_offset (ei - 1);
+	    input_buffer#insert ~iter:end_iter "\n";
+	    Some (input_buffer#get_iter (`OFFSET si),
+	    input_buffer#get_iter (`OFFSET ei))
+	  *)
+	| _ -> None
 
   method complete_at_offset (offset:int) = 
     prerr_endline ("Completion at offset : " ^ string_of_int offset);
     let it () = input_buffer#get_iter (`OFFSET offset) in
     let iit = it () in
     let start = find_word_start iit in
-    if ends_word iit then 
-      let w = input_buffer#get_text 
-		~start
-		~stop:iit
-		()
-      in
-      if String.length w <> 0 then begin
-      prerr_endline ("Completion of prefix : '" ^ w^"'");
-      match complete input_buffer w start#offset with 
-      | None -> false
-      | Some (ss,start,stop) -> 
-	  let completion = input_buffer#get_text ~start ~stop () in
-	  ignore (input_buffer#delete_selection ());
-	  ignore (input_buffer#insert_interactive completion);
-	  input_buffer#move_mark `SEL_BOUND (it())#backward_char;
-	  true
-      end else false
-    else false
+      if ends_word iit then 
+	let w = input_buffer#get_text 
+	  ~start
+	  ~stop:iit
+	  ()
+	in
+	  if String.length w <> 0 then begin
+	      prerr_endline ("Completion of prefix : '" ^ w^"'");
+	      match complete input_buffer w start#offset with 
+		| None -> false
+		| Some (ss,start,stop) -> 
+		    let completion = input_buffer#get_text ~start ~stop () in
+		      ignore (input_buffer#delete_selection ());
+		      ignore (input_buffer#insert_interactive completion);
+		      input_buffer#move_mark `SEL_BOUND (it())#backward_char;
+		      true
+	    end else false
+      else false
 
-	  
+	
   method process_next_phrase verbosely display_goals do_highlight = 
     let get_next_phrase () =
       self#clear_message;
       prerr_endline "process_next_phrase starting now";
       if do_highlight then begin
-	!push_info "Coq is computing";
-	input_view#set_editable false;
-      end;
-      match self#find_phrase_starting_at self#get_start_of_input with
-        | None ->
+	  !push_info "Coq is computing";
+	  input_view#set_editable false;
+	end;
+      match self#find_phrase_starting_at self#get_start_of_input with 
+	| None ->
 	    if do_highlight then begin
-	      input_view#set_editable true;
-	      !pop_info ();
-	    end;
+		input_view#set_editable true;
+		!pop_info ();
+	      end;
             None
 	| Some(start,stop) ->
 	    prerr_endline "process_next_phrase : to_process highlight";
 	    if do_highlight then begin
-	      input_buffer#apply_tag_by_name ~start ~stop "to_process";
-	      prerr_endline "process_next_phrase : to_process applied";
-	    end;
+		input_buffer#apply_tag_by_name ~start ~stop "to_process";
+		prerr_endline "process_next_phrase : to_process applied";
+	      end;
 	    prerr_endline "process_next_phrase : getting phrase";
-	    Some((start,stop),start#get_slice ~stop) in
+            Some((start,stop),start#get_slice ~stop) in
     let remove_tag (start,stop) =
       if do_highlight then begin
-	input_buffer#remove_tag_by_name ~start ~stop "to_process" ;
-	input_view#set_editable true;
-	!pop_info ();
-      end in
-    let mark_processed (start,stop) ast =
-      let b = input_buffer in
-      b#move_mark ~where:stop (`NAME "start_of_input");
-      b#apply_tag_by_name "processed" ~start ~stop;
-      if (self#get_insert#compare) stop <= 0 then 
-	begin
-	  b#place_cursor stop;
-	  self#recenter_insert
-	end;
-      let start_of_phrase_mark = `MARK (b#create_mark start) in
-      let end_of_phrase_mark = `MARK (b#create_mark stop) in
-      push_phrase 
-	start_of_phrase_mark 
-	end_of_phrase_mark ast;
-      if display_goals then self#show_goals;
-      remove_tag (start,stop) in
-    begin
-      match sync get_next_phrase () with
-        | None -> false
-        | Some (loc,phrase) ->
-	    (match self#send_to_coq verbosely false phrase true true true with
-	      | Some ast -> sync (mark_processed loc) ast; true
+	  input_buffer#remove_tag_by_name ~start ~stop "to_process" ;
+	  input_view#set_editable true;
+	  !pop_info ();
+	end in
+      let mark_processed complete (start,stop) ast =
+        let b = input_buffer in
+	b#move_mark ~where:stop (`NAME "start_of_input");
+	b#apply_tag_by_name 
+	  (if complete then "processed" else "unjustified") ~start ~stop;
+	if (self#get_insert#compare) stop <= 0 then 
+	  begin
+	    b#place_cursor stop;
+	    self#recenter_insert
+	  end;
+	let start_of_phrase_mark = `MARK (b#create_mark start) in
+	let end_of_phrase_mark = `MARK (b#create_mark stop) in
+	push_phrase 
+	  start_of_phrase_mark 
+	  end_of_phrase_mark ast;
+	if display_goals then self#show_goals;
+        remove_tag (start,stop) in
+      begin
+        match sync get_next_phrase () with
+            None -> false
+          | Some (loc,phrase) ->
+            (match self#send_to_coq verbosely false phrase true true true with
+	      | Some (complete,ast) -> 
+		  sync (mark_processed complete) loc ast; true
 	      | None -> sync remove_tag loc; false)
-    end
+      end
     
   method insert_this_phrase_on_success 
     show_output show_msg localize coqphrase insertphrase = 
-    let mark_processed ast =
+    let mark_processed complete ast =
       let stop = self#get_start_of_input in
       if stop#starts_line then
 	input_buffer#insert ~iter:stop insertphrase
       else input_buffer#insert ~iter:stop ("\n"^insertphrase); 
       let start = self#get_start_of_input in
       input_buffer#move_mark ~where:stop (`NAME "start_of_input");
-      input_buffer#apply_tag_by_name "processed" ~start ~stop;
+      input_buffer#apply_tag_by_name 
+	(if complete then "processed" else "unjustified") ~start ~stop;
       if (self#get_insert#compare) stop <= 0 then 
 	input_buffer#place_cursor stop;
       let start_of_phrase_mark = `MARK (input_buffer#create_mark start) in
       let end_of_phrase_mark = `MARK (input_buffer#create_mark stop) in
       push_phrase start_of_phrase_mark end_of_phrase_mark ast;
       self#show_goals;
-      (*Auto insert save on success...
+      (*Auto insert save on success... 
       try (match Coq.get_current_goals () with 
-	  | [] ->  
+	| [] ->  
 	    (match self#send_to_coq "Save.\n" true true true with
-	    | Some ast -> 
-	      begin
-	        let stop = self#get_start_of_input in
-	        if stop#starts_line then
-	          input_buffer#insert ~iter:stop "Save.\n"
-	        else input_buffer#insert ~iter:stop "\nSave.\n"; 
-	        let start = self#get_start_of_input in
-	        input_buffer#move_mark ~where:stop (`NAME "start_of_input");
-	        input_buffer#apply_tag_by_name "processed" ~start ~stop;
-	        if (self#get_insert#compare) stop <= 0 then 
-	          input_buffer#place_cursor stop;
-	        let start_of_phrase_mark =
-                  `MARK (input_buffer#create_mark start) in
-	        let end_of_phrase_mark =
-                  `MARK (input_buffer#create_mark stop) in
-	        push_phrase start_of_phrase_mark end_of_phrase_mark ast
-	      end
-	    | None -> ())
-	  | _ -> ())
-	with _ -> ()*) in
+	      | Some ast -> 
+	          begin
+                    let stop = self#get_start_of_input in
+	            if stop#starts_line then
+	              input_buffer#insert ~iter:stop "Save.\n"
+	            else input_buffer#insert ~iter:stop "\nSave.\n"; 
+	            let start = self#get_start_of_input in
+	            input_buffer#move_mark ~where:stop (`NAME"start_of_input");
+	            input_buffer#apply_tag_by_name "processed" ~start ~stop;
+	            if (self#get_insert#compare) stop <= 0 then 
+	              input_buffer#place_cursor stop;
+	            let start_of_phrase_mark =
+                      `MARK (input_buffer#create_mark start) in
+	            let end_of_phrase_mark =
+                      `MARK (input_buffer#create_mark stop) in
+	            push_phrase start_of_phrase_mark end_of_phrase_mark ast
+	          end
+	      | None -> ())
+	| _ -> ())
+      with _ -> ()*) in
     match self#send_to_coq false false coqphrase show_output show_msg localize with
-    | Some ast -> sync mark_processed ast; true
-    | None ->
-        sync 
-          (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase))
-          ();
-	false
+      | Some (complete,ast) -> sync (mark_processed complete) ast; true
+      | None ->
+          sync
+            (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase))
+            ();
+	  false
 
   method process_until_iter_or_error stop =
     let stop' = `OFFSET stop#offset in
     let start = self#get_start_of_input#copy in
     let start' = `OFFSET start#offset in
-    sync (fun _ ->
-      input_buffer#apply_tag_by_name ~start ~stop "to_process";
-      input_view#set_editable false) ();
-    !push_info "Coq is computing";
-(*    process_pending ();*)
-    (try 
-       while ((stop#compare self#get_start_of_input>=0) 
-	      && (self#process_next_phrase false false false))
-       do Util.check_for_interrupt () done
-     with Sys.Break -> 
-       prerr_endline "Interrupted during process_until_iter_or_error");
-    sync (fun _ ->
-      self#show_goals;
-      (* Start and stop might be invalid if an eol was added at eof *)
-      let start = input_buffer#get_iter start' in
-      let stop =  input_buffer#get_iter stop' in
-      input_buffer#remove_tag_by_name ~start ~stop "to_process" ;
-      input_view#set_editable true) ();
-    !pop_info()
+      sync (fun _ ->
+	      input_buffer#apply_tag_by_name ~start ~stop "to_process";
+	      input_view#set_editable false) ();
+      !push_info "Coq is computing";
+      let get_current () =
+	if !current.stop_before then
+          match self#find_phrase_starting_at self#get_start_of_input with
+            | None -> self#get_start_of_input
+            | Some (_, stop2) -> stop2
+	else begin
+            self#get_start_of_input
+	  end
+      in   
+	(try 
+	    while ((stop#compare (get_current())>=0) 
+		    && (self#process_next_phrase false false false))
+	    do Util.check_for_interrupt () done
+	  with Sys.Break -> 
+	    prerr_endline "Interrupted during process_until_iter_or_error");
+	sync (fun _ ->
+	  self#show_goals;
+	  (* Start and stop might be invalid if an eol was added at eof *)
+	  let start = input_buffer#get_iter start' in
+	  let stop =  input_buffer#get_iter stop' in
+	    input_buffer#remove_tag_by_name ~start ~stop "to_process" ;
+	    input_view#set_editable true) ();
+	!pop_info()
 
   method process_until_end_or_error = 
     self#process_until_iter_or_error input_buffer#end_iter
 
   method reset_initial =
     sync (fun _ ->
-      Stack.iter 
-        (function inf -> 
-	  let start = input_buffer#get_iter_at_mark inf.start in
-	  let stop = input_buffer#get_iter_at_mark inf.stop in
-	  input_buffer#move_mark ~where:start (`NAME "start_of_input");
-	  input_buffer#remove_tag_by_name "processed" ~start ~stop;
-	  input_buffer#delete_mark inf.start;
-	  input_buffer#delete_mark inf.stop;
-        ) 
-        processed_stack;
-      Stack.clear processed_stack;
-      self#clear_message) ();
+	    Stack.iter 
+              (function inf -> 
+		 let start = input_buffer#get_iter_at_mark inf.start in
+		 let stop = input_buffer#get_iter_at_mark inf.stop in
+		   input_buffer#move_mark ~where:start (`NAME "start_of_input");
+		   input_buffer#remove_tag_by_name "processed" ~start ~stop;
+		   input_buffer#remove_tag_by_name "unjustified" ~start ~stop;
+		   input_buffer#delete_mark inf.start;
+		   input_buffer#delete_mark inf.stop;
+              ) 
+              processed_stack;
+	    Stack.clear processed_stack;
+	    self#clear_message)();
     Coq.reset_initial ()
 
 
@@ -1211,61 +1277,65 @@ object(self)
       if is_empty () then
 	Coq.reset_initial ()
       else begin
-	let t = pop () in
-	begin match t.reset_info with
-	| Reset (id, ({contents=true} as v)) -> v:=false; 
-	    (match snd t.ast with
-	     | VernacBeginSection _ | VernacDefineModule _ 
-	     | VernacDeclareModule _ | VernacDeclareModuleType _
-	     | VernacEndSegment _ 
-	       -> reset_to_mod id
-	     | _ ->  reset_to id)
-	| _ -> synchro ()
-	end;
-	interp_last t.ast;
-	repush_phrase t
-      end
+	  let t = pop () in
+	    begin match t.reset_info with
+	      | Reset (id, ({contents=true} as v)) -> v:=false; 
+		  (match snd t.ast with
+		     | VernacBeginSection _ | VernacDefineModule _ 
+		     | VernacDeclareModule _ | VernacDeclareModuleType _
+		     | VernacEndSegment _ 
+		       -> reset_to_mod id
+		     | _ ->  reset_to id)
+	      | _ -> synchro ()
+	    end;
+	    interp_last t.ast;
+	    repush_phrase t
+	end
     in
     let add_undo t = match t with | Some n -> Some (succ n) | None -> None
     in
-    (* pop Coq commands until we reach iterator [i] *)
+      (* pop Coq commands until we reach iterator [i] *)
     let  rec pop_commands done_smthg undos =
       if is_empty () then 
 	done_smthg, undos
       else
 	let t = top () in 
-	if i#compare (input_buffer#get_iter_at_mark t.stop) < 0 then begin
-	  ignore (pop ());
-	  let undos = if is_tactic (snd t.ast) then add_undo undos else None in
-	  pop_commands true undos
-	end else
-	  done_smthg, undos
+	  if i#compare (input_buffer#get_iter_at_mark t.stop) < 0 then begin
+	      ignore (pop ());
+	      let undos = if is_tactic (snd t.ast) then add_undo undos else None in
+		pop_commands true undos
+	    end else
+	    done_smthg, undos
     in
     let done_smthg, undos = pop_commands false (Some 0) in
-    prerr_endline "Popped commands";
-    if done_smthg then
-      begin 
-	try 
-	  (match undos with 
-	   | None -> synchro () 
-	   | Some n -> try Pfedit.undo n with _ -> synchro ());
-          sync (fun _ ->
-	    let start = if is_empty () then input_buffer#start_iter 
-	    else input_buffer#get_iter_at_mark (top ()).stop 
-	    in
-	    prerr_endline "Removing (long) processed tag...";
-	    input_buffer#remove_tag_by_name 
-	      ~start 
-	      ~stop:self#get_start_of_input
-	      "processed";
-	    prerr_endline "Moving (long) start_of_input...";
-	    input_buffer#move_mark ~where:start (`NAME "start_of_input");
-	    self#show_goals;
-	    clear_stdout ();
-	    self#clear_message)
-            ();
-	with _ -> 
-	  !push_info "WARNING: undo failed badly -> Coq might be in an inconsistent state.
+      prerr_endline "Popped commands";
+      if done_smthg then
+	begin 
+	  try 
+	    (match undos with 
+	       | None -> synchro () 
+	       | Some n -> try Pfedit.undo n with _ -> synchro ());
+            sync (fun _ ->
+		    let start =
+		      if is_empty () then input_buffer#start_iter 
+		      else input_buffer#get_iter_at_mark (top ()).stop in
+		      prerr_endline "Removing (long) processed tag...";
+		      input_buffer#remove_tag_by_name 
+			~start 
+			~stop:self#get_start_of_input
+			"processed";
+		      input_buffer#remove_tag_by_name 
+			~start 
+			~stop:self#get_start_of_input
+			"unjustified";
+		      prerr_endline "Moving (long) start_of_input...";
+		      input_buffer#move_mark ~where:start (`NAME "start_of_input");
+		      self#show_goals;
+		      clear_stdout ();
+		      self#clear_message)
+              ();
+	  with _ -> 
+	    !push_info "WARNING: undo failed badly -> Coq might be in an inconsistent state.
 Please restart and report NOW.";
       end
     else prerr_endline "backtrack_to : discarded (...)"
@@ -1278,68 +1348,72 @@ Please restart and report NOW.";
 
   method go_to_insert =
     let point = self#get_insert in
-    if point#compare self#get_start_of_input>=0
-    then self#process_until_iter_or_error point
-    else self#backtrack_to point
+      if point#compare self#get_start_of_input>=0
+      then self#process_until_iter_or_error point
+      else self#backtrack_to point
 
   method undo_last_step =
     if Mutex.try_lock coq_may_stop then  
       (!push_info "Undoing last step...";
        (try
-	  let last_command = top () in
-	  let start = input_buffer#get_iter_at_mark last_command.start in
-	  let update_input () =
-	    prerr_endline "Removing processed tag...";
-	    input_buffer#remove_tag_by_name 
-	      ~start
-	      ~stop:(input_buffer#get_iter_at_mark last_command.stop) 
-	      "processed";
-	    prerr_endline "Moving start_of_input";
-	    input_buffer#move_mark
-	      ~where:start
-	      (`NAME "start_of_input");
-	    input_buffer#place_cursor start;
-	    self#recenter_insert;
-	    self#show_goals;
-	    self#clear_message
-	  in
-	  begin match last_command with 
-	  | {ast=_, (VernacSolve _ | VernacTime (VernacSolve _))} -> 
-	      begin 
-		try Pfedit.undo 1; ignore (pop ()); sync update_input () 
-		with _ -> self#backtrack_to_no_lock start
-	      end
-	  | {ast=_,t;reset_info=Reset (id, {contents=true})} ->
-	      ignore (pop ());
-	      (match t with 
-	       | VernacBeginSection _ | VernacDefineModule _ 
-	       | VernacDeclareModule _ | VernacDeclareModuleType _
-	       | VernacEndSegment _
-		 -> reset_to_mod id
-	       | _ ->  reset_to id);
-	      sync update_input ()
-	  | { ast = _, ( VernacStartTheoremProof _ 
-		       | VernacGoal _
-		       | VernacDeclareTacticDefinition _
-		       | VernacDefinition (_,_,ProveBody _,_));
-	      reset_info=Reset(id,{contents=false})} ->
-	      ignore (pop ());
-	      (try 
-		 Pfedit.delete_current_proof () 
-	       with e ->
-		 begin 
-		   prerr_endline "WARNING : found a closed environment";
-		   raise e
-		 end);
-	      sync update_input ()
-	  | { ast = (_, a) } when is_state_preserving a ->
-	      ignore (pop ());
-	      sync update_input ()
-	  | _ -> 
-	      self#backtrack_to_no_lock start
-	  end;
+	    let last_command = top () in
+	    let start = input_buffer#get_iter_at_mark last_command.start in
+	    let update_input () =
+	      prerr_endline "Removing processed tag...";
+	      input_buffer#remove_tag_by_name 
+		~start
+		~stop:(input_buffer#get_iter_at_mark last_command.stop) 
+		"processed";
+	      input_buffer#remove_tag_by_name 
+	        ~start
+	        ~stop:(input_buffer#get_iter_at_mark last_command.stop) 
+	      "unjustified";
+	      prerr_endline "Moving start_of_input";
+	      input_buffer#move_mark
+		~where:start
+		(`NAME "start_of_input");
+	      input_buffer#place_cursor start;
+	      self#recenter_insert;
+	      self#show_goals;
+	      self#clear_message
+	    in
+	      begin match last_command with 
+		| {ast=_, (VernacSolve _ | VernacTime (VernacSolve _))} -> 
+		    begin 
+		      try Pfedit.undo 1; ignore (pop ()); sync update_input () 
+		      with _ -> self#backtrack_to_no_lock start
+		    end
+		| {ast=_,t;reset_info=Reset (id, {contents=true})} ->
+		    ignore (pop ());
+		    (match t with 
+		       | VernacBeginSection _ | VernacDefineModule _ 
+		       | VernacDeclareModule _ | VernacDeclareModuleType _
+		       | VernacEndSegment _
+			 -> reset_to_mod id
+		       | _ ->  reset_to id);
+		    sync update_input ()
+		| { ast = _, ( VernacStartTheoremProof _ 
+		    | VernacGoal _
+		    | VernacDeclareTacticDefinition _
+		    | VernacDefinition (_,_,ProveBody _,_));
+		    reset_info=Reset(id,{contents=false})} ->
+		    ignore (pop ());
+		    (try 
+			 Pfedit.delete_current_proof () 
+		     with e ->
+		       begin 
+			 prerr_endline "WARNING : found a closed environment";
+			 raise e
+		       end);
+		    sync update_input ()
+		| { ast = (_, a) } when is_state_preserving a ->
+		    ignore (pop ());
+		    sync update_input ()
+		| _ -> 
+		    self#backtrack_to_no_lock start
+	      end;
 	with
-	| Size 0 -> (* !flash_info "Nothing to Undo"*)()
+	  | Size 0 -> (* !flash_info "Nothing to Undo"*)()
        );
        !pop_info ();
        Mutex.unlock coq_may_stop)
@@ -1347,51 +1421,52 @@ Please restart and report NOW.";
 
       
   method blaster () = 
+    
     ignore (Thread.create 
 	      (fun () ->  
 		 prerr_endline "Blaster called";
 		 let c = Blaster_window.present_blaster_window () in
-		 if Mutex.try_lock c#lock then begin
-		   c#clear ();
-		   let current_gls = try get_current_goals () with _ -> [] in
-		   let gls_nb = List.length current_gls in
-		   
-		   let set_goal i (s,t) = 
-		     let gnb = string_of_int i in
-		     let s = gnb ^":"^s in
-		     let t' = gnb ^": progress "^t in
-		     let t'' = gnb ^": "^t in
-		     c#set
-		       ("Goal "^gnb)
-		       s 
-		       (fun () -> try_interptac t')
-		       (sync(fun () -> self#insert_command t'' t''))
-		   in
-		   let set_current_goal (s,t) = 
-		     c#set
-		       "Goal 1"
-		       s 
-		       (fun () -> try_interptac ("progress "^t))
-		       (sync(fun () -> self#insert_command t t))
-		   in
-		   begin match current_gls with 
-		   | [] -> ()
-		   | (hyp_l,current_gl)::r ->
-		       List.iter set_current_goal (concl_menu current_gl);
-		       List.iter 
-			 (fun hyp -> 
-			    List.iter set_current_goal (hyp_menu hyp))
-			 hyp_l;
-		       let i = ref 2 in
-		       List.iter 
-			 (fun (hyp_l,gl) -> 
-			    List.iter (set_goal !i) (concl_menu gl);
-			    incr i)
-			 r
-		   end;
-		   let _ =  c#blaster () in
-		   Mutex.unlock c#lock
-		 end else prerr_endline "Blaster discarded")
+		   if Mutex.try_lock c#lock then begin
+		       c#clear ();
+                      Decl_mode.check_not_proof_mode "No blaster in Proof mode";
+		       let current_gls = try get_current_goals () with _ -> [] in
+			 
+		       let set_goal i (s,t) = 
+			 let gnb = string_of_int i in
+			 let s = gnb ^":"^s in
+			 let t' = gnb ^": progress "^t in
+			 let t'' = gnb ^": "^t in
+			   c#set
+			     ("Goal "^gnb)
+			     s 
+			     (fun () -> try_interptac t')
+			     (sync(fun () -> self#insert_command t'' t''))
+		       in
+		       let set_current_goal (s,t) = 
+			 c#set
+			   "Goal 1"
+			   s 
+			   (fun () -> try_interptac ("progress "^t))
+			   (sync(fun () -> self#insert_command t t))
+		       in
+			 begin match current_gls with 
+			   | [] -> ()
+			   | (hyp_l,current_gl)::r ->
+			       List.iter set_current_goal (concl_menu current_gl);
+			       List.iter 
+				 (fun hyp -> 
+				    List.iter set_current_goal (hyp_menu hyp))
+				 hyp_l;
+			       let i = ref 2 in
+				 List.iter 
+				   (fun (hyp_l,gl) -> 
+				      List.iter (set_goal !i) (concl_menu gl);
+				      incr i)
+				   r
+			 end;
+			 let _ =  c#blaster () in
+			   Mutex.unlock c#lock
+		     end else prerr_endline "Blaster discarded")
 	      ())
       
   method insert_command cp ip = 
@@ -1405,43 +1480,43 @@ Please restart and report NOW.";
 	 (fun p -> 
 	    self#insert_this_phrase_on_success true false false 
 	      ("progress "^p^".\n") (p^".\n")) l)
-  
+      
   method active_keypress_handler k = 
     let state = GdkEvent.Key.state k in
-    begin
-      match  state with
-      | l when List.mem `MOD1 l ->
-	  let k = GdkEvent.Key.keyval k in
-	  if GdkKeysyms._Return=k
-	  then ignore(
-	    if (input_buffer#insert_interactive "\n") then
-	      begin
-		let i= self#get_insert#backward_word_start in
-		prerr_endline "active_kp_hf: Placing cursor";
-		self#process_until_iter_or_error i
-	      end);
-	  true
-      | l when List.mem `CONTROL l -> 
-	  let k = GdkEvent.Key.keyval k in
-	  if GdkKeysyms._Break=k
-	  then break ();
-	  false
-      | l -> 
-	  if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin
-	    prerr_endline "active_kp_handler for Tab";
-	    self#indent_current_line;
-	    true
-	  end else false
-    end
+      begin
+	match  state with
+	  | l when List.mem `MOD1 l ->
+	      let k = GdkEvent.Key.keyval k in
+		if GdkKeysyms._Return=k
+		then ignore(
+			     if (input_buffer#insert_interactive "\n") then
+			       begin
+				 let i= self#get_insert#backward_word_start in
+				   prerr_endline "active_kp_hf: Placing cursor";
+				   self#process_until_iter_or_error i
+			       end);
+		true
+	  | l when List.mem `CONTROL l -> 
+	      let k = GdkEvent.Key.keyval k in
+		if GdkKeysyms._Break=k
+		then break ();
+		false
+	  | l -> 
+	      if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin
+		  prerr_endline "active_kp_handler for Tab";
+		  self#indent_current_line;
+		  true
+		end else false
+      end
   method disconnected_keypress_handler k = 
     match GdkEvent.Key.state k with
-    | l when List.mem `CONTROL l -> 
-	let k = GdkEvent.Key.keyval k in
-	if GdkKeysyms._c=k
-	then break ();
-	false
-    | l -> false
-	
+      | l when List.mem `CONTROL l -> 
+	  let k = GdkEvent.Key.keyval k in
+	    if GdkKeysyms._c=k
+	    then break ();
+	    false
+      | l -> false
+	  
 
   val mutable deact_id = None
   val mutable act_id = None
@@ -1449,11 +1524,11 @@ Please restart and report NOW.";
   method deactivate () = 
     is_active <- false;
     (match act_id with None -> () 
-     | Some id ->
-	 reset_initial ();
-	 input_view#misc#disconnect id;
-	 prerr_endline "DISCONNECTED old active : ";
-	 print_id id;
+       | Some id ->
+	   reset_initial ();
+	   input_view#misc#disconnect id;
+	   prerr_endline "DISCONNECTED old active : ";
+	   print_id id;
     );
     deact_id <- Some 
       (input_view#event#connect#key_press self#disconnected_keypress_handler);
@@ -1463,79 +1538,74 @@ Please restart and report NOW.";
   method activate () =
     is_active <- true;
     (match deact_id with None -> () 
-     | Some id -> input_view#misc#disconnect id;
-	 prerr_endline "DISCONNECTED old inactive : ";
-	 print_id id
+       | Some id -> input_view#misc#disconnect id;
+	   prerr_endline "DISCONNECTED old inactive : ";
+	   print_id id
     );
     act_id <- Some 
       (input_view#event#connect#key_press self#active_keypress_handler);
     prerr_endline "CONNECTED active : ";
     print_id (out_some act_id);
-    let dir = (match 
-		 (out_some ((Vector.get input_views index).analyzed_view))
-		 #filename 
-	       with
-	       | None -> ()
-	       | Some f ->     
-		   if not (is_in_coq_path f) then 
-		     begin
-		       let dir = Filename.dirname f in
-		       ignore (Coq.interp false
-				 (Printf.sprintf "Add LoadPath \"%s\". "  dir))
-		     end)
-    in ()
-
-      
-      
+    match 
+      (out_some ((Vector.get input_views index).analyzed_view)) #filename 
+    with
+      | None -> ()
+      | Some f -> let dir = Filename.dirname f in
+		    if not (is_in_loadpath dir) then
+		      begin
+			ignore (Coq.interp false
+				  (Printf.sprintf "Add LoadPath \"%s\". "  dir))
+		      end
+			
   method electric_handler = 
     input_buffer#connect#insert_text ~callback:
       (fun it x -> 
 	 begin try
-	   if last_index then begin
-	     last_array.(0)<-x;
-	     if (last_array.(1) ^ last_array.(0) = ".\n") then raise Found
-	   end else begin
-	     last_array.(1)<-x;
-	     if (last_array.(0) ^ last_array.(1) = ".\n") then raise Found
-	   end
-	 with Found -> 
-	   begin
-	     ignore (self#process_next_phrase false true true)
-	   end;
+	     if last_index then begin
+		 last_array.(0)<-x;
+		 if (last_array.(1) ^ last_array.(0) = ".\n") then raise Found
+	       end else begin
+		   last_array.(1)<-x;
+		   if (last_array.(0) ^ last_array.(1) = ".\n") then raise Found
+		 end
+	   with Found -> 
+	     begin
+	       ignore (self#process_next_phrase false true true)
+	     end;
 	 end;
 	 last_index <- not last_index;)
 
   method private electric_paren tag =
     let oparen_code = Glib.Utf8.to_unichar "("  (ref 0) in
     let cparen_code = Glib.Utf8.to_unichar ")"  (ref 0) in
-    ignore (input_buffer#connect#insert_text ~callback:
-	      (fun it x ->
-		 input_buffer#remove_tag
-		 ~start:input_buffer#start_iter
-		 ~stop:input_buffer#end_iter
-		 tag;
-		 if x = "" then () else
-		   match x.[String.length x - 1] with 
-		   | ')' -> 
-		       let hit = self#get_insert in
-		       let count = ref 0 in
-		       if hit#nocopy#backward_find_char 
-			 (fun c -> 
-			    if c = oparen_code && !count = 0 then true 
-			    else if c = cparen_code then 
-			      (incr count;false)
-			    else if c = oparen_code then 
-			      (decr count;false)
-			    else false
-			 )
-		       then
-			 begin
-			   prerr_endline "Found matching parenthesis";
-			   input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char
-			 end
-		       else ()
-		   | _ -> ())
-	   )
+      ignore (input_buffer#connect#insert_text ~callback:
+		(fun it x ->
+		   input_buffer#remove_tag
+		     ~start:input_buffer#start_iter
+		     ~stop:input_buffer#end_iter
+		     tag;
+		   if x = "" then () else
+		     match x.[String.length x - 1] with 
+		       | ')' -> 
+			   let hit = self#get_insert in
+			   let count = ref 0 in
+			     if hit#nocopy#backward_find_char 
+			       (fun c -> 
+				  if c = oparen_code && !count = 0 then true 
+				  else if c = cparen_code then 
+				    (incr count;false)
+				  else if c = oparen_code then 
+				    (decr count;false)
+				  else false
+			       )
+			     then
+			       begin
+				 prerr_endline "Found matching parenthesis";
+				 input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char
+			       end
+			     else ()
+		       | _ -> ())
+	     )
 
   method help_for_keyword () = 
     
@@ -1558,40 +1628,46 @@ Please restart and report NOW.";
 	      ~callback:(fun tag ~start ~stop ->
 			   if (start#compare self#get_start_of_input)>=0
 			   then 
-			     input_buffer#remove_tag_by_name 
-			       ~start
-			       ~stop
-			       "processed"
+			     begin
+			       input_buffer#remove_tag_by_name 
+				 ~start
+				 ~stop
+				 "processed";
+			       input_buffer#remove_tag_by_name 
+				 ~start
+				 ~stop
+				 "unjustified"
+			     end
 			)
 	   );
     ignore (input_buffer#connect#after#insert_text
-		~callback:(fun it s ->
-			     if auto_complete_on && 
-			       String.length s = 1 && s <> " " && s <> "\n" 
-			     then 
-			       let v = out_some (get_current_view ()).analyzed_view 
-			       in 
-			       let has_completed = 
-				 v#complete_at_offset 
-				   ((v#view#buffer#get_iter `SEL_BOUND)#offset)
-			       in
+	      ~callback:(fun it s ->
+			   if auto_complete_on && 
+			     String.length s = 1 && s <> " " && s <> "\n" 
+			   then 
+			     let v = out_some (get_current_view ()).analyzed_view 
+			     in 
+			     let has_completed = 
+			       v#complete_at_offset 
+				 ((v#view#buffer#get_iter `SEL_BOUND)#offset)
+			     in
 			       if has_completed then 
 				 input_buffer#move_mark `SEL_BOUND (input_buffer#get_iter `SEL_BOUND)#forward_char;
-		
 			       
-			  )
-	     );
-      ignore (input_buffer#connect#modified_changed
-	 ~callback:
-	 (fun () ->
-	    if input_buffer#modified then 
-	      set_tab_image index 
-		~icon:(match (out_some (current_all.analyzed_view))#filename with 
-		 | None -> `SAVE_AS
-		 | Some _ -> `SAVE
-		)
-	    else set_tab_image index ~icon:`YES;
-	 ));
+			       
+			)
+	   );
+    ignore (input_buffer#connect#modified_changed
+	      ~callback:
+	      (fun () ->
+		 if input_buffer#modified then 
+		   set_tab_image index 
+		     ~icon:(match (out_some (current_all.analyzed_view))#filename with 
+			      | None -> `SAVE_AS
+			      | Some _ -> `SAVE
+			   )
+		 else set_tab_image index ~icon:`YES;
+	      ));
     ignore (input_buffer#connect#changed
 	      ~callback:(fun () -> 
 			   last_modification_time <- Unix.time ();
@@ -1601,106 +1677,110 @@ Please restart and report NOW.";
 			       ~x:(Gdk.Rectangle.x r + Gdk.Rectangle.width r)
 			       ~y:(Gdk.Rectangle.y r + Gdk.Rectangle.height r)
 			   in
-			   input_buffer#remove_tag_by_name 
-			     ~start:self#get_start_of_input
-			     ~stop
-			     "error";
-			   Highlight.highlight_around_current_line
-			     input_buffer 
+			     input_buffer#remove_tag_by_name 
+			       ~start:self#get_start_of_input
+			       ~stop
+			       "error";
+			     Highlight.highlight_around_current_line
+			       input_buffer 
 			)
 	   );
     ignore (input_buffer#add_selection_clipboard (cb()));
     let paren_highlight_tag = input_buffer#create_tag ~name:"paren" [`BACKGROUND "purple"]  in
-    self#electric_paren paren_highlight_tag;
-    ignore (input_buffer#connect#after#mark_set 
-	      ~callback:(fun it (m:Gtk.text_mark) ->
-			   !set_location 
-			   (Printf.sprintf 
-			      "Line: %5d Char: %3d" (self#get_insert#line + 1)
-			      (self#get_insert#line_offset + 1));
-			   match GtkText.Mark.get_name m  with
-			   | Some "insert" ->		 
-			       input_buffer#remove_tag
-			       ~start:input_buffer#start_iter
-			       ~stop:input_buffer#end_iter
-			       paren_highlight_tag;
-			   | Some s -> 
-			       prerr_endline (s^" moved")
-			   | None -> () )
-	   );
-    ignore (input_buffer#connect#insert_text
-	      (fun it s -> 
-		 prerr_endline "Should recenter ?";
-		 if String.contains s '\n' then begin
-		   prerr_endline "Should recenter : yes";
-		   self#recenter_insert
-		 end))
+      self#electric_paren paren_highlight_tag;
+      ignore (input_buffer#connect#after#mark_set 
+		~callback:(fun it (m:Gtk.text_mark) ->
+			     !set_location 
+			       (Printf.sprintf 
+				  "Line: %5d Char: %3d" (self#get_insert#line + 1)
+				  (self#get_insert#line_offset + 1));
+			     match GtkText.Mark.get_name m  with
+			       | Some "insert" ->		 
+				   input_buffer#remove_tag
+				     ~start:input_buffer#start_iter
+				     ~stop:input_buffer#end_iter
+				     paren_highlight_tag;
+			       | Some s -> 
+				   prerr_endline (s^" moved")
+			       | None -> () )
+	     );
+      ignore (input_buffer#connect#insert_text
+		(fun it s -> 
+		   prerr_endline "Should recenter ?";
+		   if String.contains s '\n' then begin
+		       prerr_endline "Should recenter : yes";
+		       self#recenter_insert
+		     end))
 end
 
 let create_input_tab filename =
   let b = GText.buffer () in 
-  let tablabel = GMisc.label () in 
+  let _ = GMisc.label () in 
   let v_box = GPack.hbox ~homogeneous:false () in
-  let image = GMisc.image ~packing:v_box#pack () in
-  let label = GMisc.label ~text:filename ~packing:v_box#pack () in
+  let _ = GMisc.image ~packing:v_box#pack () in
+  let _ = GMisc.label ~text:filename ~packing:v_box#pack () in
   let fr1 = GBin.frame ~shadow_type:`ETCHED_OUT
-	      ~packing:((notebook ())#append_page
-			  ~tab_label:v_box#coerce) () 
+    ~packing:((notebook ())#append_page
+		~tab_label:v_box#coerce) () 
   in 
   let sw1 = GBin.scrolled_window
-	      ~vpolicy:`AUTOMATIC 
-	      ~hpolicy:`AUTOMATIC
-	      ~packing:fr1#add () 
+    ~vpolicy:`AUTOMATIC 
+    ~hpolicy:`AUTOMATIC
+    ~packing:fr1#add () 
   in
   let tv1 = Undo.undoable_view ~buffer:b ~packing:(sw1#add) () in
-  prerr_endline ("Language: "^ b#start_iter#language);
-  tv1#misc#set_name "ScriptWindow";
-  let _ = tv1#set_editable true in
-  let _ = tv1#set_wrap_mode `NONE in
-  b#place_cursor ~where:(b#start_iter);
-  ignore (tv1#event#connect#button_press ~callback:
-	    (fun ev -> GdkEvent.Button.button ev = 3));
-(*  ignore (tv1#event#connect#button_press ~callback:
-	    (fun ev -> 
-	       if (GdkEvent.Button.button ev=2) then
-		 (try 
-		    prerr_endline "Paste invoked";
-		    GtkSignal.emit_unit 
-		      (get_current_view()).view#as_view 
-		      GtkText.View.Signals.paste_clipboard;
-		    true
-		  with _ -> false)
-	       else false
-	    ));*)
-  tv1#misc#grab_focus ();
-  ignore (tv1#buffer#create_mark 
-	    ~name:"start_of_input" 
-	    tv1#buffer#start_iter);
-  ignore (tv1#buffer#create_tag 
-	    ~name:"kwd" 
-	    [`FOREGROUND "blue"]);
-  ignore (tv1#buffer#create_tag 
-	    ~name:"decl" 
-	    [`FOREGROUND "orange red"]);
-  ignore (tv1#buffer#create_tag 
-	    ~name:"comment" 
-	    [`FOREGROUND "brown"]);
-  ignore (tv1#buffer#create_tag 
-	    ~name:"reserved" 
-	    [`FOREGROUND "dark red"]);
-  ignore (tv1#buffer#create_tag 
-	    ~name:"error" 
-	    [`UNDERLINE `DOUBLE ; `FOREGROUND "red"]);
-  ignore (tv1#buffer#create_tag 
-	    ~name:"to_process" 
-	    [`BACKGROUND "light blue" ;`EDITABLE false]);
-  ignore (tv1#buffer#create_tag 
-	    ~name:"processed" 
-	    [`BACKGROUND "light green" ;`EDITABLE false]);
-  ignore (tv1#buffer#create_tag 
-	    ~name:"found" 
-	    [`BACKGROUND "blue"; `FOREGROUND "white"]);
-  tv1
+    prerr_endline ("Language: "^ b#start_iter#language);
+    tv1#misc#set_name "ScriptWindow";
+    let _ = tv1#set_editable true in
+    let _ = tv1#set_wrap_mode `NONE in
+      b#place_cursor ~where:(b#start_iter);
+      ignore (tv1#event#connect#button_press ~callback:
+		(fun ev -> GdkEvent.Button.button ev = 3));
+      (*  ignore (tv1#event#connect#button_press ~callback:
+	  (fun ev -> 
+	  if (GdkEvent.Button.button ev=2) then
+	  (try 
+	  prerr_endline "Paste invoked";
+	  GtkSignal.emit_unit 
+	  (get_current_view()).view#as_view 
+	  GtkText.View.Signals.paste_clipboard;
+	  true
+	  with _ -> false)
+	  else false
+	  ));*)
+      tv1#misc#grab_focus ();
+      ignore (tv1#buffer#create_mark 
+		~name:"start_of_input" 
+		tv1#buffer#start_iter);
+      ignore (tv1#buffer#create_tag 
+		~name:"kwd" 
+		[`FOREGROUND "blue"]);
+      ignore (tv1#buffer#create_tag 
+		~name:"decl" 
+		[`FOREGROUND "orange red"]);
+      ignore (tv1#buffer#create_tag 
+		~name:"comment" 
+		[`FOREGROUND "brown"]);
+      ignore (tv1#buffer#create_tag 
+		~name:"reserved" 
+		[`FOREGROUND "dark red"]);
+      ignore (tv1#buffer#create_tag 
+		~name:"error" 
+		[`UNDERLINE `DOUBLE ; `FOREGROUND "red"]);
+      ignore (tv1#buffer#create_tag 
+		~name:"to_process" 
+		[`BACKGROUND "light blue" ;`EDITABLE false]);
+      ignore (tv1#buffer#create_tag 
+		~name:"processed" 
+		[`BACKGROUND "light green" ;`EDITABLE false]);
+      ignore (tv1#buffer#create_tag (* Proof mode *)
+	        ~name:"unjustified" 
+               [`UNDERLINE `SINGLE ; `FOREGROUND "red";
+	         `BACKGROUND "gold" ;`EDITABLE false]);
+      ignore (tv1#buffer#create_tag 
+		~name:"found" 
+		[`BACKGROUND "blue"; `FOREGROUND "white"]);
+      tv1
 
 
 let last_make = ref "";;
@@ -1717,9 +1797,9 @@ let search_next_error () =
   and e = int_of_string (Str.matched_group 4 !last_make)
   and msg_index = Str.match_beginning ()
   in 
-  last_make_index := Str.group_end 4; 
-  (f,l,b,e,
-   String.sub !last_make msg_index (String.length !last_make - msg_index))
+    last_make_index := Str.group_end 4; 
+    (f,l,b,e,
+     String.sub !last_make msg_index (String.length !last_make - msg_index))
 
 let main files = 
   (* Statup preferences *)
@@ -1727,1506 +1807,1508 @@ let main files =
 
   (* Main window *)
   let w = GWindow.window 
-	    ~wm_class:"CoqIde" ~wm_name:"CoqIde"
-	    ~allow_grow:true ~allow_shrink:true 
-	    ~width:!current.window_width ~height:!current.window_height 
-	    ~title:"CoqIde" ()
-  in
-  (try
-    let icon_image = lib_ide_file "coq2.ico" in
-    let icon = GdkPixbuf.from_file icon_image in
-    w#set_icon (Some icon)
-  with _ -> ());
-  let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
-
-
-  (* Menu bar *)
-  let menubar = GMenu.menu_bar ~packing:vbox#pack () in
-
-  (* Toolbar *)
-  let toolbar = GButton.toolbar 
-		  ~orientation:`HORIZONTAL 
-		  ~style:`ICONS
-		  ~tooltips:true 
-		  ~packing:(* handle#add *)
-		     (vbox#pack ~expand:false ~fill:false)
-		  ()
-  in
-  show_toolbar := 
-  (fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ());
-
-  let factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/" menubar in
-  let accel_group = factory#accel_group in
-
-  (* File Menu *)
-  let file_menu = factory#add_submenu "_File" in
-
-  let file_factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/File/" file_menu ~accel_group in
-
-  (* File/Load Menu *)
-  let load f =
-    let f = absolute_filename f in		
-    try
-      prerr_endline "Loading file starts";
-      Vector.find_or_fail 
-	(function 
-	   | {analyzed_view=Some av} -> 
-	       (match av#filename with 
-		| None -> false 
-		| Some fn -> same_file f fn)
-	   | _ -> false) 
-	!input_views;
-      prerr_endline "Loading: must open";
-      let b = Buffer.create 1024 in
-      prerr_endline "Loading: get raw content";
-      with_file f ~f:(input_channel b);
-      prerr_endline "Loading: convert content";
-      let s = do_convert (Buffer.contents b) in
-      prerr_endline "Loading: create view";
-      let view = create_input_tab (Glib.Convert.filename_to_utf8 
-				     (Filename.basename f)) 
-      in
-      prerr_endline "Loading: change font";
-      view#misc#modify_font !current.text_font;
-      prerr_endline "Loading: adding view";
-      let index = add_input_view {view = view;
-				  analyzed_view = None;
-				 }
-      in
-      let av = (new analyzed_view index) in 
-      prerr_endline "Loading: register view";
-      (get_input_view index).analyzed_view <- Some av;
-      prerr_endline "Loading: set filename";
-      av#set_filename (Some f);
-      prerr_endline "Loading: stats";
-      av#update_stats;
-      let input_buffer = view#buffer in
-      prerr_endline "Loading: fill buffer";
-      input_buffer#set_text s;
-      input_buffer#place_cursor input_buffer#start_iter;
-      prerr_endline ("Loading: switch to view "^ string_of_int index);
-      set_current_view index;
-      set_tab_image index ~icon:`YES;
-      prerr_endline "Loading: highlight";
-      Highlight.highlight_all input_buffer;
-      input_buffer#set_modified false;
-      prerr_endline "Loading: clear undo";
-      av#view#clear_undo;
-      prerr_endline "Loading: success"
-    with       
-    | Vector.Found i -> set_current_view i
-    | e -> !flash_info ("Load failed: "^(Printexc.to_string e))
-  in
-  let load_m = file_factory#add_item "_Open/Create" 
-		 ~key:GdkKeysyms._O in
-  let load_f () = 	  
-    match select_file ~title:"Load file" () with 
-    | None -> ()
-    | (Some f) as fn -> load f
-  in
-  ignore (load_m#connect#activate (load_f));
+    ~wm_class:"CoqIde" ~wm_name:"CoqIde"
+    ~allow_grow:true ~allow_shrink:true 
+    ~width:!current.window_width ~height:!current.window_height 
+    ~title:"CoqIde" ()
+  in
+    (try
+	 let icon_image = lib_ide_file "coq.ico" in
+	 let icon = GdkPixbuf.from_file icon_image in
+	   w#set_icon (Some icon)
+     with _ -> ());
 
-  (* File/Save Menu *)
-  let save_m = file_factory#add_item "_Save" 
-		 ~key:GdkKeysyms._S in
+    let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
 
-  
-  let save_f () = 
-    let current = get_current_view () in
-    try
-      (match (out_some current.analyzed_view)#filename with 
-       | None ->
-	   begin match GToolbox.select_file ~title:"Save file" ()
-	   with
-	   | None -> ()
-	   | Some f -> 
-	       if (out_some current.analyzed_view)#save_as f then begin
-		 set_current_tab_label (Filename.basename f);
-		 !flash_info ("File " ^ f ^ " saved")
-	       end
-	       else warning ("Save Failed (check if " ^ f ^ " is writable)")
-	   end
-       | Some f -> 
-	   if (out_some current.analyzed_view)#save f then 
-	     !flash_info ("File " ^ f ^ " saved")
-	   else warning  ("Save Failed (check if " ^ f ^ " is writable)")
-	     
-      )
-    with 
-    | e -> warning "Save: unexpected error"
-  in   
-  ignore (save_m#connect#activate save_f);
 
-  (* File/Save As Menu *)
-  let saveas_m = file_factory#add_item "S_ave as" 
-  in
-  let saveas_f () = 
-    let current = get_current_view () in
-    try (match (out_some current.analyzed_view)#filename with 
-	 | None -> 
-	     begin match GToolbox.select_file ~title:"Save file as" ()
-	     with
-	     | None -> ()
-	     | Some f -> 
-		 if (out_some current.analyzed_view)#save_as f then begin
-		   set_current_tab_label (Filename.basename f);
-		   !flash_info "Saved"
-		 end
-		 else !flash_info "Save Failed"
-	     end
-	 | Some f -> 
-	     begin match GToolbox.select_file 
-	       ~dir:(ref (Filename.dirname f)) 
-	       ~filename:(Filename.basename f)
-	       ~title:"Save file as" ()
-	     with
-	     | None -> ()
-	     | Some f -> 
-		 if (out_some current.analyzed_view)#save_as f then begin
-		   set_current_tab_label (Filename.basename f);
-		   !flash_info "Saved"
-		 end else !flash_info "Save Failed"
-	     end);
-    with e -> !flash_info "Save Failed"
-  in   
-  ignore (saveas_m#connect#activate saveas_f);
-  
-  (* File/Save All Menu *)
-  let saveall_m = file_factory#add_item "Sa_ve All" in
-  let saveall_f () = 
-    Vector.iter
-      (function 
-	 | {view = view ; analyzed_view = Some av} as full -> 
-	     begin match av#filename with 
-	     | None -> ()
-	     | Some f ->
-		 ignore (av#save f)
-	     end
-	 | _ -> ()
-      )  input_views
-  in
-  let has_something_to_save () = 
-    Vector.exists
-      (function 
-	 | {view=view} -> view#buffer#modified        
-      )
-      input_views
-  in
-  ignore (saveall_m#connect#activate saveall_f);
+    (* Menu bar *)
+    let menubar = GMenu.menu_bar ~packing:vbox#pack () in
 
-  (* File/Revert Menu *)
-  let revert_m = file_factory#add_item "_Revert All Buffers" in
-  let revert_f () = 
-    Vector.iter 
-      (function 
-	   {view = view ; analyzed_view = Some av} as full -> 
-	     (try 
-		match av#filename,av#stats with 
-		| Some f,Some stats -> 
-		    let new_stats = Unix.stat f in
-		    if new_stats.Unix.st_mtime > stats.Unix.st_mtime 
-		    then av#revert
-		| Some _, None -> av#revert
-		| _ -> ()
-		with _ -> av#revert)
-	 | _ -> ()
-      )  input_views
-  in
-  ignore (revert_m#connect#activate revert_f);
-
-  (* File/Close Menu *)
-  let close_m = file_factory#add_item "_Close Buffer" in
-  let close_f () = 
-    let v = out_some !active_view in
-    let act = get_current_view_page () in
-    if v = act then !flash_info "Cannot close an active view"
-    else remove_current_view_page ()
-  in
-  ignore (close_m#connect#activate close_f);
-
-  (* File/Print Menu *)
-  let print_f () =
-    let v = get_current_view () in
-    let av = out_some v.analyzed_view in
-    match av#filename with
-    | None -> 
-	!flash_info "Cannot print: this buffer has no name"
-    | Some f ->
-	let cmd = 
-	  "cd " ^ Filename.dirname f ^ "; " ^
-	  !current.cmd_coqdoc ^ " -ps " ^ Filename.basename f ^ 
-	  " | " ^ !current.cmd_print
-	in
-	let s,_ = run_command av#insert_message cmd in
-	!flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
-  in
-  let print_m = file_factory#add_item "_Print" ~callback:print_f in
-
-  (* File/Export to Menu *)
-  let export_f kind () =
-    let v = get_current_view () in
-    let av = out_some v.analyzed_view in
-    match av#filename with
-    | None -> 
-	!flash_info "Cannot print: this buffer has no name"
-    | Some f ->
-	let basef = Filename.basename f in
-	let output = 
-	  let basef_we = try Filename.chop_extension basef with _ -> basef in
-	  match kind with
-	  | "latex" -> basef_we ^ ".tex"
-	  | "dvi" | "ps" | "html" -> basef_we ^ "." ^ kind
-	  | _ -> assert false
-	in
-	let cmd = 
-	  "cd " ^ Filename.dirname f ^ "; " ^
-	  !current.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^ output ^ " " ^ basef
-	in
-	let s,_ = run_command av#insert_message cmd in
-	!flash_info (cmd ^ 
-		     if s = Unix.WEXITED 0 
-		     then " succeeded" 
-		     else " failed")
-  in
-  let file_export_m =  file_factory#add_submenu "E_xport to" in
-
-  let file_export_factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/Export/" file_export_m ~accel_group in
-  let export_html_m = 
-    file_export_factory#add_item "_Html" ~callback:(export_f "html") 
-  in
-  let export_latex_m = 
-    file_export_factory#add_item "_LaTeX" ~callback:(export_f "latex")
-  in
-  let export_dvi_m = 
-    file_export_factory#add_item "_Dvi" ~callback:(export_f "dvi") 
-  in
-  let export_ps_m = 
-    file_export_factory#add_item "_Ps" ~callback:(export_f "ps") 
-  in
-
-  (* File/Rehighlight Menu *)
-  let rehighlight_m = file_factory#add_item "Reh_ighlight" ~key:GdkKeysyms._L in
-  ignore (rehighlight_m#connect#activate 
-	    (fun () -> 
-	       Highlight.highlight_all 
-	       (get_current_view()).view#buffer;
-	       (out_some (get_current_view()).analyzed_view)#recenter_insert));
-
-  (* File/Quit Menu *)
-  let quit_f () =
-    save_pref();
-    if has_something_to_save () then 
-      match (GToolbox.question_box ~title:"Quit"
-	       ~buttons:["Save Named Buffers and Quit";
-			 "Quit without Saving";
-			 "Don't Quit"] 
-	       ~default:0
-	       ~icon:
-	       (let img = GMisc.image () in
-		img#set_stock `DIALOG_WARNING;
-		img#set_icon_size `DIALOG;
-		img#coerce)
-	       "There are unsaved buffers"
-	    )
-      with 1 -> saveall_f () ; exit 0
-      | 2 -> exit 0
-      | _ -> ()
-    else exit 0
-  in
-  let quit_m = file_factory#add_item "_Quit" ~key:GdkKeysyms._Q 
-		 ~callback:quit_f
-  in
-  ignore (w#event#connect#delete (fun _ -> quit_f (); true));
-
-  (* Edit Menu *)
-  let edit_menu = factory#add_submenu "_Edit" in
-  let edit_f = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/Edit/" edit_menu ~accel_group in
-  ignore(edit_f#add_item "_Undo" ~key:GdkKeysyms._u ~callback:
-	   (do_if_not_computing "undo"
-	      (fun () -> 
-		 ignore ((out_some ((get_current_view()).analyzed_view))#
-			   without_auto_complete 
-			   (fun () -> (get_current_view()).view#undo) ()))));
-  ignore(edit_f#add_item "_Clear Undo Stack" 
-	   (* ~key:GdkKeysyms._exclam *)
-	   ~callback:
-	   (fun () -> 
-	      ignore (get_current_view()).view#clear_undo));
-  ignore(edit_f#add_separator ());
-  ignore(edit_f#add_item "Cut" ~key:GdkKeysyms._X ~callback:
-	   (do_if_not_computing "cut" (sync
-	      (fun () -> GtkSignal.emit_unit
-		 (get_current_view()).view#as_view 
-		 GtkText.View.S.cut_clipboard))));
-  ignore(edit_f#add_item "Copy" ~key:GdkKeysyms._C ~callback:
-	   (fun () -> GtkSignal.emit_unit
-	      (get_current_view()).view#as_view 
-	      GtkText.View.S.copy_clipboard));
-  ignore(edit_f#add_item "Paste" ~key:GdkKeysyms._V ~callback:
-	   (do_if_not_computing "paste" (sync 
-	      (fun () -> 
-		 try GtkSignal.emit_unit
-		   (get_current_view()).view#as_view 
-		   GtkText.View.S.paste_clipboard
-		 with _ -> prerr_endline "EMIT PASTE FAILED"))));
-  ignore (edit_f#add_separator ());
-
-
-(*
-   let toggle_auto_complete_i = 
-    edit_f#add_check_item "_Auto Completion" 
-      ~active:!current.auto_complete
-      ~callback:
-   in
-*)
-(*
-   auto_complete := 
-   (fun b -> match (get_current_view()).analyzed_view with
-      | Some av -> av#set_auto_complete b
-      | None -> ());
-*)
-
-  let last_found = ref None in
-  let search_backward = ref false in
-  let find_w = GWindow.window 
-		 (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *)
-		 (* ~allow_grow:true ~allow_shrink:true *)
-		 (* ~width:!current.window_width ~height:!current.window_height *)
-		 ~position:`CENTER
-		 ~title:"CoqIde search/replace" ()
-  in
-  let find_box = GPack.table
-		   ~columns:3 ~rows:5
-		   ~col_spacings:10 ~row_spacings:10 ~border_width:10
-		   ~homogeneous:false ~packing:find_w#add () in
-  
-  let find_lbl = 
-    GMisc.label ~text:"Find:"
-      ~xalign:1.0
-      ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) () 
-  in
-  let find_entry = GEdit.entry
-		     ~editable: true
-		     ~packing: (find_box#attach ~left:1 ~top:0 ~expand:`X)
-		     ()
-  in
-  let replace_lbl = 
-    GMisc.label ~text:"Replace with:"
-      ~xalign:1.0
-      ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) () 
-  in
-  let replace_entry = GEdit.entry
-			~editable: true
-			~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X)
-			()
-  in
-  let case_sensitive_check = 
-    GButton.check_button
-      ~label:"case sensitive"
-      ~active:true
-      ~packing: (find_box#attach ~left:1 ~top:2)
+    (* Toolbar *)
+    let toolbar = GButton.toolbar 
+      ~orientation:`HORIZONTAL 
+      ~style:`ICONS
+      ~tooltips:true 
+      ~packing:(* handle#add *)
+      (vbox#pack ~expand:false ~fill:false)
       ()
-  in
-(*
-  let find_backwards_check = 
-    GButton.check_button
-      ~label:"search backwards"
-      ~active:false
-      ~packing: (find_box#attach ~left:1 ~top:3)
-      ()
-  in
-*)
-  let close_find_button =
-    GButton.button
-      ~label:"Close"
-      ~packing: (find_box#attach ~left:2 ~top:0)
-      ()
-  in
-  let replace_button =
-    GButton.button
-      ~label:"Replace"
-      ~packing: (find_box#attach ~left:2 ~top:1)
-      ()
-  in
-  let replace_find_button =
-    GButton.button
-      ~label:"Replace and find"
-      ~packing: (find_box#attach ~left:2 ~top:2)
-      ()
-  in
-  let find_again_button =
-    GButton.button
-      ~label:"_Find again"
-      ~packing: (find_box#attach ~left:2 ~top:3)
-      ()
-  in
-  let find_again_backward_button =
-    GButton.button
-      ~label:"Find _backward"
-      ~packing: (find_box#attach ~left:2 ~top:4)
-      ()
-  in
-  let last_find () =
-    let v = (get_current_view()).view in
-    let b = v#buffer in
-    let start,stop =
-      match !last_found with 
-	| None -> let i = b#get_iter_at_mark `INSERT in (i,i)
-	| Some(start,stop) ->
-	    let start = b#get_iter_at_mark start
-	    and stop = b#get_iter_at_mark stop
-	    in
-	    b#remove_tag_by_name ~start ~stop "found";
-	    last_found:=None;
-	    start,stop
     in
-    (v,b,start,stop)
-  in
-  let do_replace () =
-    let v = (get_current_view()).view in
-    let b = v#buffer in
-    match !last_found with 
-      | None -> ()
-      | Some(start,stop) ->
-	  let start = b#get_iter_at_mark start
-	  and stop = b#get_iter_at_mark stop
-	  in
-	  b#delete ~start ~stop;
-	  b#insert ~iter:start replace_entry#text;
-	  last_found:=None
-  in
-  let find_from (v : Undo.undoable_view)
-    (b : GText.buffer) (starti : GText.iter) text =
-    prerr_endline ("Searching for " ^ text);
-    match (if !search_backward then starti#backward_search text
-	   else starti#forward_search text)
-    with
-      | None -> ()
-      | Some(start,stop) ->
-	  b#apply_tag_by_name "found" ~start ~stop;
-	  let start = `MARK (b#create_mark start)
-	  and stop = `MARK (b#create_mark stop)
-	  in
-	  v#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25
-	    stop;
-	  last_found := Some(start,stop)
-  in
-  let do_find () =
-    let (v,b,starti,_) = last_find () in
-    find_from v b starti find_entry#text 
-  in
-  let do_replace_find () =
-    do_replace();
-    do_find()
-  in
-  let close_find () =
-    let (v,b,_,stop) = last_find () in
-    b#place_cursor stop;
-    find_w#misc#hide();
-    v#coerce#misc#grab_focus()
-  in
-  to_do_on_page_switch := 
-  (fun i -> if find_w#misc#visible then close_find()):: 
-    !to_do_on_page_switch;
-  let find_again_forward () =
-    search_backward := false;
-    let (v,b,start,_) = last_find () in
-    let start = start#forward_chars 1 in
-    find_from v b start find_entry#text
-  in
-  let find_again_backward () =
-    search_backward := true;
-    let (v,b,start,_) = last_find () in
-    let start = start#backward_chars 1 in
-    find_from v b start find_entry#text
-  in
-  let key_find ev =
-    let s = GdkEvent.Key.state ev and k = GdkEvent.Key.keyval ev in
-    if k = GdkKeysyms._Escape then
-      begin
-	let (v,b,_,stop) = last_find () in
-	find_w#misc#hide();
-	v#coerce#misc#grab_focus();
-	true
-      end 
-    else if k = GdkKeysyms._Return then
-      begin
-	close_find();
-	true
-      end 
-    else if List.mem `CONTROL s && k = GdkKeysyms._f then
-      begin
-	find_again_forward ();
-	true
-      end
-    else if List.mem `CONTROL s && k = GdkKeysyms._b then
-      begin
-	find_again_backward ();
-	true
-      end
-    else false (* to let default callback execute *)
-  in
-  let find_f ~backward () = 
-    search_backward := backward;
-    find_w#show ();
-    find_w#present ();
-    find_entry#misc#grab_focus ()
-  in
-  let find_i = edit_f#add_item "_Find in buffer"
-		 ~key:GdkKeysyms._F
-		 ~callback:(find_f ~backward:false)
-  in
-  let find_back_i = edit_f#add_item "Find _backwards"
-		 ~key:GdkKeysyms._B
-		 ~callback:(find_f ~backward:true)
-  in
-  let _ = close_find_button#connect#clicked close_find in
-  let _ = replace_button#connect#clicked do_replace in
-  let _ = replace_find_button#connect#clicked do_replace_find in
-  let _ = find_again_button#connect#clicked find_again_forward in
-  let _ = find_again_backward_button#connect#clicked find_again_backward in
-  let _ = find_entry#connect#changed do_find in
-  let _ = find_entry#event#connect#key_press ~callback:key_find in
-  let _ = find_w#event#connect#delete (fun _ -> find_w#misc#hide(); true) in
-(*
-  let search_if = edit_f#add_item "Search _forward"
-		    ~key:GdkKeysyms._greater
-  in
-  let search_ib = edit_f#add_item "Search _backward"
-		    ~key:GdkKeysyms._less
-  in
-*)
-(*
-  let complete_i = edit_f#add_item "_Complete"
-		     ~key:GdkKeysyms._comma
-		     ~callback:
-		     (do_if_not_computing 
-			(fun b -> 
-			   let v = out_some (get_current_view ()).analyzed_view 
-				    
-			   in v#complete_at_offset 
-				((v#view#buffer#get_iter `SEL_BOUND)#offset)
-			))
-  in
-  complete_i#misc#set_state `INSENSITIVE;
-*)
-  
-  ignore(edit_f#add_item "Complete Word" ~key:GdkKeysyms._slash ~callback:
-	 (do_if_not_computing "complete word" (sync 
-	    (fun () -> 
-	       ignore (
-		 let av = out_some ((get_current_view()).analyzed_view) in 
-		 av#complete_at_offset (av#get_insert)#offset
-	    )))));
-
-  ignore(edit_f#add_separator ());
-  (* external editor *)
-  let _ = 
-    edit_f#add_item "External editor" ~callback:
-      (fun () -> 	 
-	 let av = out_some ((get_current_view()).analyzed_view) in 
-	 match av#filename with
-	   | None -> ()
-	   | Some f ->
-	       save_f ();
-	       let l,r = !current.cmd_editor in
-	       let _ = run_command av#insert_message (l ^ f ^ r) in
-	       av#revert)
-  in
-  let _ = edit_f#add_separator () in
-  (* Preferences *)
-  let reset_revert_timer () =
-    disconnect_revert_timer ();
-    if !current.global_auto_revert then 
-      revert_timer := Some
-	(GMain.Timeout.add ~ms:!current.global_auto_revert_delay 
-	   ~callback:
-	   (fun () -> 
-	      do_if_not_computing "revert" (sync revert_f) ();
-	      true))
-  in reset_revert_timer (); (* to enable statup preferences timer *)
-
-  let auto_save_f () = 
-    Vector.iter 
-      (function 
-	   {view = view ; analyzed_view = Some av} as full -> 
-	     (try 
-		av#auto_save
-	      with _ -> ())
-	 | _ -> ()
-      )  
-      input_views
-  in
+      show_toolbar := 
+	(fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ());
 
-  let reset_auto_save_timer () =
-    disconnect_auto_save_timer ();
-    if !current.auto_save then 
-      auto_save_timer := Some
-	(GMain.Timeout.add ~ms:!current.auto_save_delay 
-	   ~callback:
-	   (fun () -> 
-	      do_if_not_computing "autosave" (sync auto_save_f) ();
-	      true))
-  in reset_auto_save_timer (); (* to enable statup preferences timer *)
-
-
-  let edit_prefs_m =
-    edit_f#add_item "_Preferences"
-      ~callback:(fun () -> configure ();reset_revert_timer ())
-  in
-(*
-  let save_prefs_m =
-    configuration_factory#add_item "_Save preferences"
-      ~callback:(fun () -> save_pref ())
-  in
-*)
-  (* Navigation Menu *)
-  let navigation_menu =  factory#add_submenu "_Navigation" in
-  let navigation_factory = 
-    new GMenu.factory navigation_menu 
-      ~accel_path:"<CoqIde MenuBar>/Navigation/"
-      ~accel_group 
-      ~accel_modi:!current.modifier_for_navigation 
-  in
-  let do_or_activate f () = 
-    let current = get_current_view () in
-    let analyzed_view = out_some current.analyzed_view in
-    if analyzed_view#is_active then 
-      ignore (f analyzed_view)
-    else
-      begin
-	!flash_info "New proof started";
-	activate_input (notebook ())#current_page;
-	ignore (f analyzed_view)
-      end
-  in
+      let factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/" menubar in
+      let accel_group = factory#accel_group in
 
-  let do_or_activate f = 
-    do_if_not_computing "do_or_activate" (do_or_activate (fun av -> f av ; !pop_info();!push_info (Coq.current_status())))
-  in
+      (* File Menu *)
+      let file_menu = factory#add_submenu "_File" in
 
-  let add_to_menu_toolbar text ~tooltip ?key ~callback icon = 
-    begin
-      match key with None -> () 
-	| Some key -> ignore (navigation_factory#add_item text ~key ~callback)
-    end;
-    ignore (toolbar#insert_button
-	      ~tooltip
-	      ~text:tooltip
-	      ~icon:(stock_to_widget ~size:`LARGE_TOOLBAR icon)
-	      ~callback
-	      ())
-  in
-  add_to_menu_toolbar 
-    "_Save" 
-    ~tooltip:"Save current buffer" 
-    (* ~key:GdkKeysyms._Down *)
-    ~callback:save_f
-    `SAVE;
-  add_to_menu_toolbar 
-    "_Forward" 
-    ~tooltip:"Forward one command" 
-    ~key:GdkKeysyms._Down 
-    ~callback:(do_or_activate (fun a -> a#process_next_phrase true true true))
-    `GO_DOWN;
-  add_to_menu_toolbar "_Backward"
-    ~tooltip:"Backward one command" 
-    ~key:GdkKeysyms._Up
-    ~callback:(do_or_activate (fun a -> a#undo_last_step))
-    `GO_UP;
-  add_to_menu_toolbar 
-    "_Go to" 
-    ~tooltip:"Go to cursor" 
-    ~key:GdkKeysyms._Right
-    ~callback:(do_or_activate (fun a-> a#go_to_insert))
-    `JUMP_TO;
-  add_to_menu_toolbar 
-    "_Start" 
-    ~tooltip:"Go to start" 
-    ~key:GdkKeysyms._Home
-    ~callback:(do_or_activate (fun a -> a#reset_initial))
-    `GOTO_TOP;
-  add_to_menu_toolbar 
-    "_End" 
-    ~tooltip:"Go to end" 
-    ~key:GdkKeysyms._End
-    ~callback:(do_or_activate (fun a -> a#process_until_end_or_error))
-    `GOTO_BOTTOM;
-  add_to_menu_toolbar "_Interrupt"
-    ~tooltip:"Interrupt computations"    
-    ~key:GdkKeysyms._Break 
-    ~callback:break
-    `STOP
-  ;
-
-  (* Tactics Menu *)
-  let tactics_menu =  factory#add_submenu "_Try Tactics" in
-  let tactics_factory = 
-    new GMenu.factory tactics_menu 
-      ~accel_path:"<CoqIde MenuBar>/Tactics/"
-      ~accel_group 
-      ~accel_modi:!current.modifier_for_tactics
-  in
-  let do_if_active_raw f () = 
-    let current = get_current_view () in
-    let analyzed_view = out_some current.analyzed_view in
-    if analyzed_view#is_active then ignore (f analyzed_view)
-  in
-  let do_if_active f = do_if_not_computing "do_if_active" (do_if_active_raw f) in
-
-(*
-  let blaster_i = 
-    tactics_factory#add_item "_Blaster"
-	    ~key:GdkKeysyms._b
-	    ~callback: (do_if_active_raw (fun a -> a#blaster ()))
-	    (* Custom locking mechanism! *)
-  in
-  blaster_i#misc#set_state `INSENSITIVE;
-*)
- 
-  ignore (tactics_factory#add_item "_auto" 
-	    ~key:GdkKeysyms._a
-	    ~callback:(do_if_active (fun a -> a#insert_command "progress auto.\n" "auto.\n"))
-	 );
-  ignore (tactics_factory#add_item "_auto with *"
-	    ~key:GdkKeysyms._asterisk
-	    ~callback:(do_if_active (fun a -> a#insert_command 
-				       "progress auto with *.\n"
-				       "auto with *.\n")));
-  ignore (tactics_factory#add_item "_eauto"
-	    ~key:GdkKeysyms._e
-	    ~callback:(do_if_active (fun a -> a#insert_command 
-				       "progress eauto.\n"
-				       "eauto.\n"))
-	 );
-  ignore (tactics_factory#add_item "_eauto with *"
-	    ~key:GdkKeysyms._ampersand
-	    ~callback:(do_if_active (fun a -> a#insert_command 
-				       "progress eauto with *.\n" 
-				       "eauto with *.\n"))
-	 );
-  ignore (tactics_factory#add_item "_intuition"
-	    ~key:GdkKeysyms._i
-	    ~callback:(do_if_active (fun a -> a#insert_command 
-					 "progress intuition.\n" 
-					 "intuition.\n"))
-	 );
-  ignore (tactics_factory#add_item "_omega"
-	    ~key:GdkKeysyms._o
-	    ~callback:(do_if_active (fun a -> a#insert_command 
-					 "omega.\n" "omega.\n"))
-	 );
-  ignore (tactics_factory#add_item "_simpl"
-	    ~key:GdkKeysyms._s
-	    ~callback:(do_if_active (fun a -> a#insert_command "progress simpl.\n" "simpl.\n" ))
-	 );
-  ignore (tactics_factory#add_item "_tauto"
-	    ~key:GdkKeysyms._p
-	    ~callback:(do_if_active (fun a -> a#insert_command "tauto.\n" "tauto.\n" ))
-	 );
-  ignore (tactics_factory#add_item "_trivial"
-	    ~key:GdkKeysyms._v
-	    ~callback:(do_if_active( fun a -> a#insert_command "progress trivial.\n"  "trivial.\n" ))
-	 );
-
-
-  ignore (toolbar#insert_button
-	    ~tooltip:"Proof Wizard"
-	    ~text:"Wizard"
-	    ~icon:(stock_to_widget ~size:`LARGE_TOOLBAR `DIALOG_INFO)
-	    ~callback:(do_if_active (fun a -> a#tactic_wizard
-				       !current.automatic_tactics
-				    ))
-	    ());
-
-  ignore (tactics_factory#add_item "<Proof _Wizard>"
-	    ~key:GdkKeysyms._dollar
-	    ~callback:(do_if_active (fun a -> a#tactic_wizard 
-				       !current.automatic_tactics
-				    ))
-	 );
-  
-  ignore (tactics_factory#add_separator ());
-  let add_simple_template (factory: GMenu.menu GMenu.factory) 
-    (menu_text, text) =
-    let text = 
-      let l = String.length text - 1 in
-      if String.get text l = '.'
-      then text ^"\n"
-      else text ^" "
-    in
-    ignore (factory#add_item menu_text
-	      ~callback:
-	      (do_if_not_computing "simple template" (sync
-		 (fun () -> let {view = view } = get_current_view () in
-		  ignore (view#buffer#insert_interactive text)))))
-  in
-  List.iter 
-    (fun l -> 
-       match l with 
-       | [] -> ()
-       | [s] -> add_simple_template tactics_factory ("_"^s, s) 
-       | s::_ -> 
-	   let a = "_@..." in
-	   a.[1] <- s.[0];
-	   let f = tactics_factory#add_submenu a in 
-	   let ff = new GMenu.factory f ~accel_group in
-	   List.iter 
-	     (fun x -> 
-		add_simple_template
-		ff 
-		((String.sub x 0 1)^
-		 "_"^
-		 (String.sub x 1 (String.length x - 1)),
-		 x))
-	     l
-    ) 
-    Coq_commands.tactics;
-  
-  (* Templates Menu *)
-  let templates_menu =  factory#add_submenu "Te_mplates" in
-  let templates_factory = new GMenu.factory templates_menu 
-			    ~accel_path:"<CoqIde MenuBar>/Templates/"
-			    ~accel_group 
-			    ~accel_modi:!current.modifier_for_templates
-  in
-  let add_complex_template (menu_text, text, offset, len, key) =
-    (* Templates/Lemma *)
-    let callback = do_if_not_computing "complex template" (sync
-		     (fun () ->
-			let {view = view } = get_current_view () in
-			if view#buffer#insert_interactive text then begin
-			  let iter = view#buffer#get_iter_at_mark `INSERT in
-			  ignore (iter#nocopy#backward_chars offset);
-			  view#buffer#move_mark `INSERT iter;
-			  ignore (iter#nocopy#backward_chars len);
-			  view#buffer#move_mark `SEL_BOUND iter;
-			end))
-    in
-    ignore (templates_factory#add_item menu_text ~callback ?key)
-  in
-  add_complex_template 
-    ("_Lemma __", "Lemma new_lemma : .\nProof.\n\nSave.\n", 
-     19, 9, Some GdkKeysyms._L);
-  add_complex_template 
-    ("_Theorem __", "Theorem new_theorem : .\nProof.\n\nSave.\n", 
-     19, 11, Some GdkKeysyms._T);
-  add_complex_template 
-    ("_Definition __", "Definition ident := .\n",
-     6, 5, Some GdkKeysyms._D);
-  add_complex_template 
-    ("_Inductive __", "Inductive ident : :=\n  | : .\n",
-     14, 5, Some GdkKeysyms._I);
-  add_complex_template 
-    ("_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n",
-     29, 5, Some GdkKeysyms._F);
-  add_complex_template("_Scheme __",
-		       "Scheme new_scheme := Induction for _ Sort _
-with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
+      let file_factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/File/" file_menu ~accel_group in
 
-  (* Template for match *)
-  let callback () = 
-    let w = get_current_word () in
-    try 
-      let cases = Coq.make_cases w
-      in
-      let print c = function
-	| [x] -> Format.fprintf c "  | %s => _@\n" x
-	| x::l -> Format.fprintf c "  | (%s%a) => _@\n" x 
-	      (print_list (fun c s -> Format.fprintf c " %s" s)) l
-	| [] -> assert false
+      (* File/Load Menu *)
+      let load f =
+	let f = absolute_filename f in		
+	  try
+	    prerr_endline "Loading file starts";
+	    Vector.find_or_fail 
+	      (function 
+		 | {analyzed_view=Some av} -> 
+		     (match av#filename with 
+			| None -> false 
+			| Some fn -> same_file f fn)
+		 | _ -> false) 
+	      !input_views;
+	    prerr_endline "Loading: must open";
+	    let b = Buffer.create 1024 in
+	      prerr_endline "Loading: get raw content";
+	      with_file f ~f:(input_channel b);
+	      prerr_endline "Loading: convert content";
+	      let s = do_convert (Buffer.contents b) in
+		prerr_endline "Loading: create view";
+		let view = create_input_tab (Glib.Convert.filename_to_utf8 
+					       (Filename.basename f)) 
+		in
+		  prerr_endline "Loading: change font";
+		  view#misc#modify_font !current.text_font;
+		  prerr_endline "Loading: adding view";
+		  let index = add_input_view {view = view;
+					      analyzed_view = None;
+					     }
+		  in
+		  let av = (new analyzed_view index) in 
+		    prerr_endline "Loading: register view";
+		    (get_input_view index).analyzed_view <- Some av;
+		    prerr_endline "Loading: set filename";
+		    av#set_filename (Some f);
+		    prerr_endline "Loading: stats";
+		    av#update_stats;
+		    let input_buffer = view#buffer in
+		      prerr_endline "Loading: fill buffer";
+		      input_buffer#set_text s;
+		      input_buffer#place_cursor input_buffer#start_iter;
+		      prerr_endline ("Loading: switch to view "^ string_of_int index);
+		      set_current_view index;
+		      set_tab_image index ~icon:`YES;
+		      prerr_endline "Loading: highlight";
+		      Highlight.highlight_all input_buffer;
+		      input_buffer#set_modified false;
+		      prerr_endline "Loading: clear undo";
+		      av#view#clear_undo;
+		      prerr_endline "Loading: success"
+	  with       
+	    | Vector.Found i -> set_current_view i
+	    | e -> !flash_info ("Load failed: "^(Printexc.to_string e))
       in
-      let b = Buffer.create 1024 in
-      let fmt = Format.formatter_of_buffer b in
-      Format.fprintf fmt "@[match var with@\n%aend@]@."
-	(print_list print) cases;
-      let s = Buffer.contents b in
-      prerr_endline s;
-      let {view = view } = get_current_view () in
-      ignore (view#buffer#delete_selection ());
-      let m = view#buffer#create_mark 
-		(view#buffer#get_iter `INSERT)
+      let load_m = file_factory#add_item "_Open/Create" 
+	~key:GdkKeysyms._O in
+      let load_f () = 	  
+	match select_file ~title:"Load file" () with 
+	  | None -> ()
+	  | Some f -> load f
       in
-      if view#buffer#insert_interactive s then 
-	let i = view#buffer#get_iter (`MARK m) in
-      let _ = i#nocopy#forward_chars 9 in
-      view#buffer#place_cursor i;
-      view#buffer#move_mark ~where:(i#backward_chars 3)
-	`SEL_BOUND 
-    with Not_found -> !flash_info "Not an inductive type"
-  in
-  ignore (templates_factory#add_item "match ..."
-	    ~key:GdkKeysyms._C
-	    ~callback
-	 );
-  
-(*
-  let add_simple_template (factory: GMenu.menu GMenu.factory) 
-    (menu_text, text) =
-    let text = 
-      let l = String.length text - 1 in
-      if String.get text l = '.'
-      then text ^"\n"
-      else text ^" "
-    in
-    ignore (factory#add_item menu_text
-	      ~callback:
-	      (do_if_not_computing "simple template" (sync
-		 (fun () -> let {view = view } = get_current_view () in
-		  ignore (view#buffer#insert_interactive text)))))
-  in
-*)
-  ignore (templates_factory#add_separator ());
-(*
-  List.iter (add_simple_template templates_factory)
-    [ "_auto", "auto ";
-      "_auto with *", "auto with * ";
-      "_eauto", "eauto ";
-      "_eauto with *", "eauto with * ";
-      "_intuition", "intuition ";
-      "_omega", "omega ";
-      "_simpl", "simpl ";
-      "_tauto", "tauto ";
-      "tri_vial", "trivial ";
-    ];
-  ignore (templates_factory#add_separator ());
-*)
-  List.iter 
-    (fun l -> 
-       match l with 
-       | [] -> ()
-       | [s] -> add_simple_template templates_factory ("_"^s, s) 
-       | s::_ -> 
-	   let a = "_@..." in
-	   a.[1] <- s.[0];
-	   let f = templates_factory#add_submenu a in 
-	   let ff = new GMenu.factory f ~accel_group in
-	   List.iter 
-	     (fun x -> 
-		add_simple_template 
-		ff 
-		((String.sub x 0 1)^
-		 "_"^
-		 (String.sub x 1 (String.length x - 1)),
-		 x))
-	     l
-    ) 
-    Coq_commands.commands;
-  
-  (* Queries Menu *)
-  let queries_menu =  factory#add_submenu "_Queries" in
-  let queries_factory = new GMenu.factory queries_menu ~accel_group
-			   ~accel_path:"<CoqIde MenuBar>/Queries"
-			   ~accel_modi:[]
-  in
-  
-  (* Command/Show commands *)
-  let _ = 
-    queries_factory#add_item "_SearchAbout " ~key:GdkKeysyms._F2
-      ~callback:(fun () -> let term = get_current_word () in
-		 (Command_windows.command_window ())#new_command
-		 ~command:"SearchAbout"
-		   ~term 
-		   ())
-  in
-  let _ = 
-    queries_factory#add_item "_Check " ~key:GdkKeysyms._F3
-      ~callback:(fun () -> let term = get_current_word () in
-		 (Command_windows.command_window ())#new_command
-		 ~command:"Check"
-		   ~term 
-		   ())
-  in
-  let _ = 
-    queries_factory#add_item "_Print " ~key:GdkKeysyms._F4
-      ~callback:(fun () -> let term = get_current_word () in
-		 (Command_windows.command_window ())#new_command
-		 ~command:"Print"
-		   ~term 
-		   ())
-  in
+	ignore (load_m#connect#activate (load_f));
 
-  (* Externals *)
-  let externals_menu =  factory#add_submenu "_Compile" in
-  let externals_factory = new GMenu.factory externals_menu 
-			    ~accel_path:"<CoqIde MenuBar>/Compile/"
-			    ~accel_group 
-			   ~accel_modi:[]
-  in
-  
-  (* Command/Compile Menu *)
-  let compile_f () =
-    let v = get_current_view () in
-    let av = out_some v.analyzed_view in
-    save_f ();
-    match av#filename with
-    | None -> 
-	!flash_info "Active buffer has no name"
-    | Some f ->
-	let s,res = run_command 
-		      av#insert_message 
-		      (!current.cmd_coqc ^ " " ^ f) 
-	in
-	if s = Unix.WEXITED 0 then
-	  !flash_info (f ^ " successfully compiled")
-	else begin
-	  !flash_info (f ^ " failed to compile");
-	  activate_input (notebook ())#current_page;
-	  av#process_until_end_or_error;
-	  av#insert_message "Compilation output:\n";
-	  av#insert_message res
-	end
-  in
-  let compile_m = 
-    externals_factory#add_item "_Compile Buffer" ~callback:compile_f 
-  in
+	(* File/Save Menu *)
+	let save_m = file_factory#add_item "_Save" 
+	  ~key:GdkKeysyms._S in
 
-  (* Command/Make Menu *)
-  let make_f () =
-    let v = get_active_view () in
-    let av = out_some v.analyzed_view in
-(*
-    save_f ();
-*)
-    av#insert_message "Command output:\n";
-    let s,res = run_command av#insert_message !current.cmd_make in
-    last_make := res;
-    last_make_index := 0;
-    !flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
-  in
-  let make_m = externals_factory#add_item "_Make" 
-		 ~key:GdkKeysyms._F6
-		 ~callback:make_f 
-  in
-  
-
-  (* Compile/Next Error *)
-  let next_error () = 
-    try
-      let file,line,start,stop,error_msg = search_next_error () in
-      load file;
-      let v = get_current_view () in
-      let av = out_some v.analyzed_view in
-      let input_buffer = v.view#buffer in
-(*
-      let init = input_buffer#start_iter in
-      let i = init#forward_lines (line-1) in
-*)
-(*
-  let convert_pos = byte_offset_to_char_offset phrase in
-  let start = convert_pos start in
-  let stop = convert_pos stop in
-*)
-(*
-      let starti = i#forward_chars start in
-      let stopi = i#forward_chars stop in
-*)
-      let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in
-      let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in
-      input_buffer#apply_tag_by_name "error"
-   	~start:starti
-	~stop:stopi;
-      input_buffer#place_cursor starti;
-      av#set_message error_msg;
-      v.view#misc#grab_focus ()
-    with Not_found ->
-      last_make_index := 0;
-      let v = get_current_view () in
-      let av = out_some v.analyzed_view in
-      av#set_message "No more errors.\n"
-  in
-  let next_error_m = 
-    externals_factory#add_item "_Next error" 
-      ~key:GdkKeysyms._F7
-      ~callback:next_error in
-  
+	  
+	let save_f () = 
+	  let current = get_current_view () in
+	    try
+	      (match (out_some current.analyzed_view)#filename with 
+		 | None ->
+		     begin match GToolbox.select_file ~title:"Save file" ()
+		       with
+			 | None -> ()
+			 | Some f -> 
+			     if (out_some current.analyzed_view)#save_as f then begin
+				 set_current_tab_label (Filename.basename f);
+				 !flash_info ("File " ^ f ^ " saved")
+			       end
+			     else warning ("Save Failed (check if " ^ f ^ " is writable)")
+		     end
+		 | Some f -> 
+		     if (out_some current.analyzed_view)#save f then 
+		       !flash_info ("File " ^ f ^ " saved")
+		     else warning  ("Save Failed (check if " ^ f ^ " is writable)")
+		       
+	      )
+	    with 
+	      | e -> warning "Save: unexpected error"
+	in   
+	  ignore (save_m#connect#activate save_f);
+
+	  (* File/Save As Menu *)
+	  let saveas_m = file_factory#add_item "S_ave as" 
+	  in
+	  let saveas_f () = 
+	    let current = get_current_view () in
+	      try (match (out_some current.analyzed_view)#filename with 
+		     | None -> 
+			 begin match GToolbox.select_file ~title:"Save file as" ()
+			   with
+			     | None -> ()
+			     | Some f -> 
+				 if (out_some current.analyzed_view)#save_as f then begin
+				     set_current_tab_label (Filename.basename f);
+				     !flash_info "Saved"
+				   end
+				 else !flash_info "Save Failed"
+			 end
+		     | Some f -> 
+			 begin match GToolbox.select_file 
+			     ~dir:(ref (Filename.dirname f)) 
+			     ~filename:(Filename.basename f)
+			     ~title:"Save file as" ()
+			   with
+			     | None -> ()
+			     | Some f -> 
+				 if (out_some current.analyzed_view)#save_as f then begin
+				     set_current_tab_label (Filename.basename f);
+				     !flash_info "Saved"
+				   end else !flash_info "Save Failed"
+			 end);
+	      with e -> !flash_info "Save Failed"
+	  in   
+	    ignore (saveas_m#connect#activate saveas_f);
+	    
+	    (* File/Save All Menu *)
+	    let saveall_m = file_factory#add_item "Sa_ve All" in
+	    let saveall_f () = 
+	      Vector.iter
+		(function 
+		   | {view = view ; analyzed_view = Some av} -> 
+		       begin match av#filename with 
+			 | None -> ()
+			 | Some f ->
+			     ignore (av#save f)
+		       end
+		   | _ -> ()
+		)  input_views
+	    in
+	    let has_something_to_save () = 
+	      Vector.exists
+		(function 
+		   | {view=view} -> view#buffer#modified        
+		)
+		input_views
+	    in
+	      ignore (saveall_m#connect#activate saveall_f);
+	      
+	      (* File/Revert Menu *)
+	      let revert_m = file_factory#add_item "_Revert All Buffers" in
+	      let revert_f () = 
+		Vector.iter 
+		  (function 
+		       {view = view ; analyzed_view = Some av} -> 
+			 (try 
+			      match av#filename,av#stats with 
+				| Some f,Some stats -> 
+				    let new_stats = Unix.stat f in
+				      if new_stats.Unix.st_mtime > stats.Unix.st_mtime 
+				      then av#revert
+				| Some _, None -> av#revert
+				| _ -> ()
+			  with _ -> av#revert)
+		     | _ -> ()
+		  )  input_views
+	      in
+		ignore (revert_m#connect#activate revert_f);
+		
+		(* File/Close Menu *)
+		let close_m =
+                  file_factory#add_item "_Close Buffer" ~key:GdkKeysyms._W in
+		let close_f () = 
+		  let v = out_some !active_view in
+		  let act = get_current_view_page () in
+		    if v = act then !flash_info "Cannot close an active view"
+		    else remove_current_view_page ()
+		in
+		  ignore (close_m#connect#activate close_f);
+		  
+		  (* File/Print Menu *)
+		  let print_f () =
+		    let v = get_current_view () in
+		    let av = out_some v.analyzed_view in
+		      match av#filename with
+			| None -> 
+			    !flash_info "Cannot print: this buffer has no name"
+			| Some f ->
+			    let cmd = 
+			      "cd " ^ Filename.dirname f ^ "; " ^
+				!current.cmd_coqdoc ^ " -ps " ^ Filename.basename f ^ 
+				" | " ^ !current.cmd_print
+			    in
+			    let s,_ = run_command av#insert_message cmd in
+			      !flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+		  in
+		  let _ = file_factory#add_item "_Print"
+	            ~key:GdkKeysyms._P
+                    ~callback:print_f in
+
+		  (* File/Export to Menu *)
+		  let export_f kind () =
+		    let v = get_current_view () in
+		    let av = out_some v.analyzed_view in
+		      match av#filename with
+			| None -> 
+			    !flash_info "Cannot print: this buffer has no name"
+			| Some f ->
+			    let basef = Filename.basename f in
+			    let output = 
+			      let basef_we = try Filename.chop_extension basef with _ -> basef in
+				match kind with
+				  | "latex" -> basef_we ^ ".tex"
+				  | "dvi" | "ps" | "html" -> basef_we ^ "." ^ kind
+				  | _ -> assert false
+			    in
+			    let cmd = 
+			      "cd " ^ Filename.dirname f ^ "; " ^
+				!current.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^ output ^ " " ^ basef
+			    in
+			    let s,_ = run_command av#insert_message cmd in
+			      !flash_info (cmd ^ 
+					     if s = Unix.WEXITED 0 
+					     then " succeeded" 
+					     else " failed")
+		  in
+		  let file_export_m =  file_factory#add_submenu "E_xport to" in
 
-  (* Command/CoqMakefile Menu*)
-  let coq_makefile_f () =
-    let v = get_active_view () in
-    let av = out_some v.analyzed_view in
-    let s,res = run_command av#insert_message !current.cmd_coqmakefile in
-    !flash_info 
-      (!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
-  in
-  let _ = externals_factory#add_item "_Make makefile" ~callback:coq_makefile_f 
-  in
-  (* Windows Menu *)
-  let configuration_menu = factory#add_submenu "_Windows" in
-  let configuration_factory = new GMenu.factory configuration_menu ~accel_path:"<CoqIde MenuBar>/Windows" ~accel_group
-  in
-  let queries_show_m = 
-    configuration_factory#add_item 
-      "Show _Query Window"
-      (*
-	~key:GdkKeysyms._F12
-      *)
-      ~callback:(Command_windows.command_window ())#window#present
-  in  
-  let toolbar_show_m = 
-    configuration_factory#add_item 
-      "Show/Hide _Toolbar"	       
-      ~callback:(fun () ->  
-		   !current.show_toolbar <- not !current.show_toolbar; 
-		   !show_toolbar !current.show_toolbar) 
-  in
-  let detach_menu = configuration_factory#add_item 
-		      "Detach _Script Window"
-		      ~callback:
-		      (do_if_not_computing "detach script window" (sync
-			 (fun () -> 
-			    let nb = notebook () in
-			    if nb#misc#toplevel#get_oid=w#coerce#get_oid then
-			      begin  
-				let nw = GWindow.window ~show:true () in
-				let parent = out_some nb#misc#parent in
-				ignore (nw#connect#destroy 
-					  ~callback:
-					  (fun () -> nb#misc#reparent parent));
-				nw#add_accel_group accel_group;
-				nb#misc#reparent nw#coerce
-			      end	      
-			 )))
-  in
-  let detach_current_view = 
-    configuration_factory#add_item 
-      "Detach _View"
-      ~callback:
-      (do_if_not_computing "detach view"
-	 (fun () -> 
-	    match get_current_view () with  
-	      | {view=v;analyzed_view=Some av} -> 
-		  let w = GWindow.window ~show:true 
-			    ~width:(!current.window_width/2)
-			    ~height:(!current.window_height)
-			    ~title:(match av#filename with
-				      | None -> "*Unnamed*"
-				      | Some f -> f) 
-			    () 
+		  let file_export_factory = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/Export/" file_export_m ~accel_group in
+		  let _ = 
+		    file_export_factory#add_item "_Html" ~callback:(export_f "html") 
 		  in
-		  let sb = GBin.scrolled_window 
-			     ~packing:w#add () 
+		  let _ = 
+		    file_export_factory#add_item "_LaTeX" ~callback:(export_f "latex")
 		  in
-		  let nv = GText.view 
-			     ~buffer:v#buffer 
-			     ~packing:sb#add 
-			     ()
+		  let _ = 
+		    file_export_factory#add_item "_Dvi" ~callback:(export_f "dvi") 
+		  in
+		  let _ = 
+		    file_export_factory#add_item "_Ps" ~callback:(export_f "ps") 
 		  in
-		  nv#misc#modify_font 
-		    !current.text_font; 
-		  ignore (w#connect#destroy 
-			    ~callback:
-			    (fun () -> av#remove_detached_view w));
-		  av#add_detached_view w
-	      | _ -> ()
-		  
-	 ))
-  in
-  (* Help Menu *)
-
-  let help_menu = factory#add_submenu "_Help" in
-  let help_factory = new GMenu.factory help_menu  
-		       ~accel_path:"<CoqIde MenuBar>/Help/"
-		       ~accel_modi:[]
-		       ~accel_group in
-  let _ = help_factory#add_item "Browse Coq _Manual" 
-	    ~callback:
-	    (fun () -> 
-	       let av = out_some ((get_current_view ()).analyzed_view) in 
-	       browse av#insert_message (!current.doc_url ^ "main.html")) in
-  let _ = help_factory#add_item "Browse Coq _Library" 
-	    ~callback:
-	    (fun () -> 
-	       let av = out_some ((get_current_view ()).analyzed_view) in 
-	       browse av#insert_message !current.library_url) in
-  let _ = 
-    help_factory#add_item "Help for _keyword" ~key:GdkKeysyms._F1
-      ~callback:(fun () -> 
-		   let av = out_some ((get_current_view ()).analyzed_view) in 
-		   av#help_for_keyword ())
-  in
-  let _ = help_factory#add_separator () in
-(*
-  let faq_m = help_factory#add_item "_FAQ" in
-*)
-  let about_m = help_factory#add_item "_About" in
-
-  (* End of menu *)
-
-  (* The vertical Separator between Scripts and Goals *)
-  let hb = GPack.paned `HORIZONTAL  ~border_width:3 ~packing:vbox#add () in
-  _notebook := Some (GPack.notebook ~scrollable:true 
-		       ~packing:hb#add1
-		       ());
-  let nb = notebook () in
-  let fr2 = GBin.frame ~shadow_type:`ETCHED_OUT ~packing:hb#add2 () in 
-  let hb2 = GPack.paned `VERTICAL  ~border_width:3 ~packing:fr2#add () in
-  let sw2 = GBin.scrolled_window 
-	      ~vpolicy:`AUTOMATIC 
-	      ~hpolicy:`AUTOMATIC
-	      ~packing:(hb2#add) () in
-  let sw3 = GBin.scrolled_window 
-	      ~vpolicy:`AUTOMATIC 
-	      ~hpolicy:`AUTOMATIC
-	      ~packing:(hb2#add) () in
-  let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
-  let status_bar = GMisc.statusbar ~packing:(lower_hbox#pack ~expand:true) () 
-  in
-  let search_lbl = GMisc.label ~text:"Search:"
-		     ~show:false
-		     ~packing:(lower_hbox#pack ~expand:false) () 
-  in
-  let search_history = ref [] in
-  let search_input = GEdit.combo ~popdown_strings:!search_history
-		       ~enable_arrow_keys:true
-		       ~show:false
-		       ~packing:(lower_hbox#pack ~expand:false) () 
-  in
-  search_input#disable_activate ();
-  let ready_to_wrap_search = ref false in
-
-  let start_of_search = ref None in
-  let start_of_found = ref None in
-  let end_of_found = ref None in
-  let search_forward = ref true in
-  let matched_word = ref None in
-
-  let memo_search () = 
-    matched_word := Some search_input#entry#text
-
-(*     if not (List.mem search_input#entry#text !search_history) then
-      (search_history := 
-      search_input#entry#text::!search_history;
-       search_input#set_popdown_strings !search_history);
-    start_of_search := None;
-    ready_to_wrap_search := false
-*)
 
-  in
-  let end_search () = 
-    prerr_endline "End Search";
-    memo_search ();
-    let v = (get_current_view ()).view in
-    v#buffer#move_mark `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT);
-    v#coerce#misc#grab_focus ();
-    search_input#entry#set_text "";
-    search_lbl#misc#hide ();
-    search_input#misc#hide ()
-  in
-  let end_search_focus_out () = 
-    prerr_endline "End Search(focus out)";
-    memo_search ();
-    let v = (get_current_view ()).view in
-    v#buffer#move_mark `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT);
-    search_input#entry#set_text "";
-    search_lbl#misc#hide ();
-    search_input#misc#hide ()
-  in
-  ignore (search_input#entry#connect#activate ~callback:end_search);
-  ignore (search_input#entry#event#connect#key_press 
-	    ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in
-		       if 
-			 kv = GdkKeysyms._Right
-			 || kv = GdkKeysyms._Up 
-			 || kv = GdkKeysyms._Left
-			 || (kv = GdkKeysyms._g 
-			     && (List.mem `CONTROL (GdkEvent.Key.state k)))
-		       then end_search (); 
-		       false));
-  ignore (search_input#entry#event#connect#focus_out
-	    ~callback:(fun _ -> end_search_focus_out (); false));
-  to_do_on_page_switch := 
-  (fun i -> 
-     start_of_search := None;
-     ready_to_wrap_search:=false)::!to_do_on_page_switch;
-
-(* TODO : make it work !!! *)
-  let rec search_f () = 
-    search_lbl#misc#show ();
-    search_input#misc#show ();
-
-    prerr_endline "search_f called";
-    if !start_of_search = None then begin
-      (* A full new search is starting *)
-      start_of_search := 
-      Some ((get_current_view ()).view#buffer#create_mark 
-	      ((get_current_view ()).view#buffer#get_iter_at_mark `INSERT));
-      start_of_found := !start_of_search;
-      end_of_found := !start_of_search;
-      matched_word := Some "";
-    end;
-    let txt = search_input#entry#text in 
-    let v = (get_current_view ()).view in
-    let iit = v#buffer#get_iter_at_mark `SEL_BOUND 
-    and insert_iter = v#buffer#get_iter_at_mark `INSERT
-    in
-    prerr_endline ("SELBOUND="^(string_of_int iit#offset));
-    prerr_endline ("INSERT="^(string_of_int insert_iter#offset));
-    
-    (match
-       if !search_forward then iit#forward_search txt 
-       else let npi = iit#forward_chars (Glib.Utf8.length txt) in
-       match 
-	 (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset),
-	 (let t = iit#get_text ~stop:npi in 
-	  !flash_info (t^"\n"^txt);
-	  t = txt)
-       with 
-       | true,true -> 
-	   (!flash_info "T,T";iit#backward_search txt)
-       | false,true -> !flash_info "F,T";Some (iit,npi)
-       | _,false ->
-	   (iit#backward_search txt)
-
-       with 
-       | None -> 
-	   if !ready_to_wrap_search then begin
-	     ready_to_wrap_search := false;
-	     !flash_info "Search wrapped";
-	     v#buffer#place_cursor 
-	       (if !search_forward then v#buffer#start_iter else
-		  v#buffer#end_iter);
-	     search_f ()
-	   end else begin
-	     if !search_forward then !flash_info "Search at end"
-	     else !flash_info "Search at start";
-	     ready_to_wrap_search := true
-	   end
-       | Some (start,stop) -> 
-	   prerr_endline "search: before moving marks";
-	   prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
-	   prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
-
-	   v#buffer#move_mark `SEL_BOUND start;
-	   v#buffer#move_mark `INSERT stop;
-	   prerr_endline "search: after moving marks";
-	   prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
-	   prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
-	   v#scroll_to_mark `SEL_BOUND
-    )
-  in
-  ignore (search_input#entry#event#connect#key_release 
-	    ~callback:
-	    (fun ev ->
-	       if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin
-		 let v = (get_current_view ()).view in
-		 (match !start_of_search with 
-		  | None -> 
-		      prerr_endline "search_key_rel: Placing sel_bound";
-		      v#buffer#move_mark 
-			`SEL_BOUND 
-			(v#buffer#get_iter_at_mark `INSERT)
-		  | Some mk -> let it = v#buffer#get_iter_at_mark 
-					  (`MARK mk) in
-		    prerr_endline "search_key_rel: Placing cursor";
-		    v#buffer#place_cursor it;
-		    start_of_search := None
-		 );
-		 search_input#entry#set_text ""; 
-		 v#coerce#misc#grab_focus ();
-	       end; 
-	       false
-	    ));
-  ignore (search_input#entry#connect#changed search_f);
-  
-(*
-  ignore (search_if#connect#activate
-	    ~callback:(fun b -> 
-			 search_forward:= true;
-			 search_input#entry#coerce#misc#grab_focus ();
-			 search_f ();
-		      )
-	 );
-  ignore (search_ib#connect#activate
-	    ~callback:(fun b ->
-			 search_forward:= false;
-
-			 (* Must restore the SEL_BOUND mark after 
-			    grab_focus ! *)
-			 let v = (get_current_view ()).view in
-			 let old_sel = v#buffer#get_iter_at_mark `SEL_BOUND 
-			 in
-			 search_input#entry#coerce#misc#grab_focus ();
-			 v#buffer#move_mark `SEL_BOUND old_sel;
-			 search_f ();
-		      ));
-*)
-  let status_context = status_bar#new_context "Messages" in
-  let flash_context = status_bar#new_context "Flash" in
-  ignore (status_context#push "Ready");
-  status := Some status_bar;
-  push_info := (fun s -> ignore (status_context#push s));
-  pop_info := (fun () -> status_context#pop ());
-  flash_info := (fun ?(delay=5000) s -> flash_context#flash ~delay s);
-
-  (* Location display *)
-  let l = GMisc.label
-	    ~text:"Line:     1 Char:   1" 
-	    ~packing:lower_hbox#pack () in 
-  l#coerce#misc#set_name "location";
-  set_location := l#set_text;
-
-  (* Progress Bar *)
-  pulse := 
-  (let pb = GRange.progress_bar ~pulse_step:0.2 ~packing:lower_hbox#pack ()
-   in pb#set_text "CoqIde started";pb)#pulse;
-  let tv2 = GText.view ~packing:(sw2#add) () in
-  tv2#misc#set_name "GoalWindow";
-  let _ = tv2#set_editable false in
-  let tb2 = tv2#buffer in
-  let tv3 = GText.view ~packing:(sw3#add) () in
-  tv2#misc#set_name "MessageWindow";
-  let _ = tv2#set_wrap_mode `CHAR in
-  let _ = tv3#set_wrap_mode `WORD in
-  let _ = tv3#set_editable false in
-  let _ = GtkBase.Widget.add_events tv2#as_widget
-	    [`ENTER_NOTIFY;`POINTER_MOTION] in
-  let _ = tv2#event#connect#motion_notify
-	    ~callback:
-	    (fun e -> 
-	       (do_if_not_computing "motion notify" (sync
-		  (fun e -> 
-		     let win = match tv2#get_window `WIDGET with
-		       | None -> assert false
-		       | Some w -> w
-		     in
-		     let x,y = Gdk.Window.get_pointer_location win in
-		     let b_x,b_y = tv2#window_to_buffer_coords 
-				     ~tag:`WIDGET 
-				     ~x 
-				     ~y 
-		     in
-		     let it = tv2#get_iter_at_location ~x:b_x ~y:b_y in
-		     let tags = it#tags in
-		     List.iter 
-		       ( fun t ->
-			   ignore (GtkText.Tag.event 
-				     t#as_tag
-				     tv2#as_widget
-				     e 
-				     it#as_iter))
-		       tags;
-		     false)) e;
-	       false))
-  in
-  change_font := 
-  (fun fd -> 
-     tv2#misc#modify_font fd;
-     tv3#misc#modify_font fd;
-     Vector.iter 
-       (fun {view=view} -> view#misc#modify_font fd)
-       input_views;
-  );
-  let about (b:GText.buffer) =
-    (try 
-       let image = lib_ide_file "coq.ico" in
-       let startup_image = GdkPixbuf.from_file image in
-       b#insert_pixbuf ~iter:b#start_iter 
-	 ~pixbuf:startup_image;
-       b#insert ~iter:b#start_iter "\t\t";
-     with _ -> ());
-    let about_string =
-      "\nCoqIDE: an Integrated Development Environment for Coq\n\
+		  (* File/Rehighlight Menu *)
+		  let rehighlight_m = file_factory#add_item "Reh_ighlight" ~key:GdkKeysyms._L in
+		    ignore (rehighlight_m#connect#activate 
+			      (fun () -> 
+				 Highlight.highlight_all 
+				   (get_current_view()).view#buffer;
+				 (out_some (get_current_view()).analyzed_view)#recenter_insert));
+
+		    (* File/Quit Menu *)
+		    let quit_f () =
+		      save_pref();
+		      if has_something_to_save () then 
+			match (GToolbox.question_box ~title:"Quit"
+				 ~buttons:["Save Named Buffers and Quit";
+					   "Quit without Saving";
+					   "Don't Quit"] 
+				 ~default:0
+				 ~icon:
+				 (let img = GMisc.image () in
+				    img#set_stock `DIALOG_WARNING;
+				    img#set_icon_size `DIALOG;
+				    img#coerce)
+				 "There are unsaved buffers"
+			      )
+			with 1 -> saveall_f () ; exit 0
+			  | 2 -> exit 0
+			  | _ -> ()
+		      else exit 0
+		    in
+		    let _ = file_factory#add_item "_Quit" ~key:GdkKeysyms._Q 
+		      ~callback:quit_f
+		    in
+		      ignore (w#event#connect#delete (fun _ -> quit_f (); true));
+
+		      (* Edit Menu *)
+		      let edit_menu = factory#add_submenu "_Edit" in
+		      let edit_f = new GMenu.factory ~accel_path:"<CoqIde MenuBar>/Edit/" edit_menu ~accel_group in
+			ignore(edit_f#add_item "_Undo" ~key:GdkKeysyms._u ~callback:
+				 (do_if_not_computing "undo"
+				    (fun () -> 
+				       ignore ((out_some ((get_current_view()).analyzed_view))#
+						 without_auto_complete 
+						 (fun () -> (get_current_view()).view#undo) ()))));
+			ignore(edit_f#add_item "_Clear Undo Stack" 
+				 (* ~key:GdkKeysyms._exclam *)
+				 ~callback:
+				 (fun () -> 
+				    ignore (get_current_view()).view#clear_undo));
+			ignore(edit_f#add_separator ());
+			ignore(edit_f#add_item "Cut" ~key:GdkKeysyms._X ~callback:
+				 (fun () -> GtkSignal.emit_unit
+				    (get_current_view()).view#as_view 
+				    GtkText.View.S.cut_clipboard));
+			ignore(edit_f#add_item "Copy" ~key:GdkKeysyms._C ~callback:
+				 (fun () -> GtkSignal.emit_unit
+				    (get_current_view()).view#as_view 
+				    GtkText.View.S.copy_clipboard));
+			ignore(edit_f#add_item "Paste" ~key:GdkKeysyms._V ~callback:
+				 (fun () -> 
+				    try GtkSignal.emit_unit
+				      (get_current_view()).view#as_view 
+				      GtkText.View.S.paste_clipboard
+				    with _ -> prerr_endline "EMIT PASTE FAILED"));
+			ignore (edit_f#add_separator ());
+
+
+			(*
+			  let toggle_auto_complete_i = 
+			  edit_f#add_check_item "_Auto Completion" 
+			  ~active:!current.auto_complete
+			  ~callback:
+			  in
+			*)
+			(*
+			  auto_complete := 
+			  (fun b -> match (get_current_view()).analyzed_view with
+			  | Some av -> av#set_auto_complete b
+			  | None -> ());
+			*)
+
+			let last_found = ref None in
+			let search_backward = ref false in
+			let find_w = GWindow.window 
+			  (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *)
+			  (* ~allow_grow:true ~allow_shrink:true *)
+			  (* ~width:!current.window_width ~height:!current.window_height *)
+			  ~position:`CENTER
+			  ~title:"CoqIde search/replace" ()
+			in
+			let find_box = GPack.table
+			  ~columns:3 ~rows:5
+			  ~col_spacings:10 ~row_spacings:10 ~border_width:10
+			  ~homogeneous:false ~packing:find_w#add () in
+			  
+			let _ = 
+			  GMisc.label ~text:"Find:"
+			    ~xalign:1.0
+			    ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) () 
+			in
+			let find_entry = GEdit.entry
+			  ~editable: true
+			  ~packing: (find_box#attach ~left:1 ~top:0 ~expand:`X)
+			  ()
+			in
+			let _ = 
+			  GMisc.label ~text:"Replace with:"
+			    ~xalign:1.0
+			    ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) () 
+			in
+			let replace_entry = GEdit.entry
+			  ~editable: true
+			  ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X)
+			  ()
+			in
+			let _ = 
+			  GButton.check_button
+			    ~label:"case sensitive"
+			    ~active:true
+			    ~packing: (find_box#attach ~left:1 ~top:2)
+			    ()
+			in
+			  (*
+			    let find_backwards_check = 
+			    GButton.check_button
+			    ~label:"search backwards"
+			    ~active:false
+			    ~packing: (find_box#attach ~left:1 ~top:3)
+			    ()
+			    in
+			  *)
+			let close_find_button =
+			  GButton.button
+			    ~label:"Close"
+			    ~packing: (find_box#attach ~left:2 ~top:0)
+			    ()
+			in
+			let replace_button =
+			  GButton.button
+			    ~label:"Replace"
+			    ~packing: (find_box#attach ~left:2 ~top:1)
+			    ()
+			in
+			let replace_find_button =
+			  GButton.button
+			    ~label:"Replace and find"
+			    ~packing: (find_box#attach ~left:2 ~top:2)
+			    ()
+			in
+			let find_again_button =
+			  GButton.button
+			    ~label:"_Find again"
+			    ~packing: (find_box#attach ~left:2 ~top:3)
+			    ()
+			in
+			let find_again_backward_button =
+			  GButton.button
+			    ~label:"Find _backward"
+			    ~packing: (find_box#attach ~left:2 ~top:4)
+			    ()
+			in
+			let last_find () =
+			  let v = (get_current_view()).view in
+			  let b = v#buffer in
+			  let start,stop =
+			    match !last_found with 
+			      | None -> let i = b#get_iter_at_mark `INSERT in (i,i)
+			      | Some(start,stop) ->
+				  let start = b#get_iter_at_mark start
+				  and stop = b#get_iter_at_mark stop
+				  in
+				    b#remove_tag_by_name ~start ~stop "found";
+				    last_found:=None;
+				    start,stop
+			  in
+			    (v,b,start,stop)
+			in
+			let do_replace () =
+			  let v = (get_current_view()).view in
+			  let b = v#buffer in
+			    match !last_found with 
+			      | None -> ()
+			      | Some(start,stop) ->
+				  let start = b#get_iter_at_mark start
+				  and stop = b#get_iter_at_mark stop
+				  in
+				    b#delete ~start ~stop;
+				    b#insert ~iter:start replace_entry#text;
+				    last_found:=None
+			in
+			let find_from (v : Undo.undoable_view)
+			    (b : GText.buffer) (starti : GText.iter) text =
+			  prerr_endline ("Searching for " ^ text);
+			  match (if !search_backward then starti#backward_search text
+				 else starti#forward_search text)
+			  with
+			    | None -> ()
+			    | Some(start,stop) ->
+				b#apply_tag_by_name "found" ~start ~stop;
+				let start = `MARK (b#create_mark start)
+				and stop = `MARK (b#create_mark stop)
+				in
+				  v#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25
+				    stop;
+				  last_found := Some(start,stop)
+			in
+			let do_find () =
+			  let (v,b,starti,_) = last_find () in
+			    find_from v b starti find_entry#text 
+			in
+			let do_replace_find () =
+			  do_replace();
+			  do_find()
+			in
+			let close_find () =
+			  let (v,b,_,stop) = last_find () in
+			    b#place_cursor stop;
+			    find_w#misc#hide();
+			    v#coerce#misc#grab_focus()
+			in
+			  to_do_on_page_switch := 
+			    (fun i -> if find_w#misc#visible then close_find()):: 
+			      !to_do_on_page_switch;
+			  let find_again_forward () =
+			    search_backward := false;
+			    let (v,b,start,_) = last_find () in
+			    let start = start#forward_chars 1 in
+			      find_from v b start find_entry#text
+			  in
+			  let find_again_backward () =
+			    search_backward := true;
+			    let (v,b,start,_) = last_find () in
+			    let start = start#backward_chars 1 in
+			      find_from v b start find_entry#text
+			  in
+			  let key_find ev =
+			    let s = GdkEvent.Key.state ev and k = GdkEvent.Key.keyval ev in
+			      if k = GdkKeysyms._Escape then
+				begin
+				  let (v,b,_,stop) = last_find () in
+				    find_w#misc#hide();
+				    v#coerce#misc#grab_focus();
+				    true
+				end 
+			      else if k = GdkKeysyms._Return then
+				begin
+				  close_find();
+				  true
+				end 
+			      else if List.mem `CONTROL s && k = GdkKeysyms._f then
+				begin
+				  find_again_forward ();
+				  true
+				end
+			      else if List.mem `CONTROL s && k = GdkKeysyms._b then
+				begin
+				  find_again_backward ();
+				  true
+				end
+			      else false (* to let default callback execute *)
+			  in
+			  let find_f ~backward () = 
+			    search_backward := backward;
+			    find_w#show ();
+			    find_w#present ();
+			    find_entry#misc#grab_focus ()
+			  in
+			  let _ = edit_f#add_item "_Find in buffer"
+			    ~key:GdkKeysyms._F
+			    ~callback:(find_f ~backward:false)
+			  in
+			  let _ = edit_f#add_item "Find _backwards"
+			    ~key:GdkKeysyms._B
+			    ~callback:(find_f ~backward:true)
+			  in
+			  let _ = close_find_button#connect#clicked close_find in
+			  let _ = replace_button#connect#clicked do_replace in
+			  let _ = replace_find_button#connect#clicked do_replace_find in
+			  let _ = find_again_button#connect#clicked find_again_forward in
+			  let _ = find_again_backward_button#connect#clicked find_again_backward in
+			  let _ = find_entry#connect#changed do_find in
+			  let _ = find_entry#event#connect#key_press ~callback:key_find in
+			  let _ = find_w#event#connect#delete (fun _ -> find_w#misc#hide(); true) in
+			    (*
+			      let search_if = edit_f#add_item "Search _forward"
+			      ~key:GdkKeysyms._greater
+			      in
+			      let search_ib = edit_f#add_item "Search _backward"
+			      ~key:GdkKeysyms._less
+			      in
+			    *)
+			    (*
+			      let complete_i = edit_f#add_item "_Complete"
+			      ~key:GdkKeysyms._comma
+			      ~callback:
+			      (do_if_not_computing 
+			      (fun b -> 
+			      let v = out_some (get_current_view ()).analyzed_view 
+			      
+			      in v#complete_at_offset 
+			      ((v#view#buffer#get_iter `SEL_BOUND)#offset)
+			      ))
+			      in
+			      complete_i#misc#set_state `INSENSITIVE;
+			    *)
+			    
+			    ignore(edit_f#add_item "Complete Word" ~key:GdkKeysyms._slash ~callback:
+				     (fun () -> 
+					ignore (
+						 let av = out_some ((get_current_view()).analyzed_view) in 
+						   av#complete_at_offset (av#get_insert)#offset
+					       )));
+
+			    ignore(edit_f#add_separator ());
+			    (* external editor *)
+			    let _ = 
+			      edit_f#add_item "External editor" ~callback:
+				(fun () -> 	 
+				   let av = out_some ((get_current_view()).analyzed_view) in 
+				     match av#filename with
+				       | None -> ()
+				       | Some f ->
+					   save_f ();
+					   let l,r = !current.cmd_editor in
+					   let _ = run_command av#insert_message (l ^ f ^ r) in
+					     av#revert)
+			    in
+			    let _ = edit_f#add_separator () in
+			      (* Preferences *)
+			    let reset_revert_timer () =
+			      disconnect_revert_timer ();
+			      if !current.global_auto_revert then 
+				revert_timer := Some
+				  (GMain.Timeout.add ~ms:!current.global_auto_revert_delay 
+				     ~callback:
+				     (fun () -> 
+					do_if_not_computing "revert" (sync revert_f) ();
+					true))
+			    in reset_revert_timer (); (* to enable statup preferences timer *)
+
+			      let auto_save_f () = 
+				Vector.iter 
+				  (function 
+				       {view = view ; analyzed_view = Some av} -> 
+					 (try 
+					      av#auto_save
+					  with _ -> ())
+				     | _ -> ()
+				  )  
+				  input_views
+			      in
+
+			      let reset_auto_save_timer () =
+				disconnect_auto_save_timer ();
+				if !current.auto_save then 
+				  auto_save_timer := Some
+				    (GMain.Timeout.add ~ms:!current.auto_save_delay 
+				       ~callback:
+				       (fun () -> 
+					  do_if_not_computing "autosave" (sync auto_save_f) ();
+					  true))
+			      in reset_auto_save_timer (); (* to enable statup preferences timer *)
+
+
+				let _ =
+				  edit_f#add_item "_Preferences"
+				    ~callback:(fun () -> configure ();reset_revert_timer ())
+				in
+				  (*
+				    let save_prefs_m =
+				    configuration_factory#add_item "_Save preferences"
+				    ~callback:(fun () -> save_pref ())
+				    in
+				  *)
+				  (* Navigation Menu *)
+				let navigation_menu =  factory#add_submenu "_Navigation" in
+				let navigation_factory = 
+				  new GMenu.factory navigation_menu 
+				    ~accel_path:"<CoqIde MenuBar>/Navigation/"
+				    ~accel_group 
+				    ~accel_modi:!current.modifier_for_navigation 
+				in
+				let do_or_activate f () = 
+				  let current = get_current_view () in
+				  let analyzed_view = out_some current.analyzed_view in
+				    if analyzed_view#is_active then 
+				      ignore (f analyzed_view)
+				    else
+				      begin
+					!flash_info "New proof started";
+					activate_input (notebook ())#current_page;
+					ignore (f analyzed_view)
+				      end
+				in
+
+				let do_or_activate f = 
+				  do_if_not_computing "do_or_activate"
+				    (do_or_activate
+				       (fun av -> f av ; !pop_info();!push_info (Coq.current_status())))
+				in
+
+				let add_to_menu_toolbar text ~tooltip ?key ~callback icon = 
+				  begin
+				    match key with None -> () 
+				      | Some key -> ignore (navigation_factory#add_item text ~key ~callback)
+				  end;
+				  ignore (toolbar#insert_button
+					    ~tooltip
+					    ~text:tooltip
+					    ~icon:(stock_to_widget ~size:`LARGE_TOOLBAR icon)
+					    ~callback
+					    ())
+				in
+				  add_to_menu_toolbar 
+				    "_Save" 
+				    ~tooltip:"Save current buffer" 
+				    ~callback:save_f
+				    `SAVE;
+				  add_to_menu_toolbar 
+				    "_Close" 
+				    ~tooltip:"Close current buffer" 
+				    ~callback:close_f
+				    `CLOSE;
+				  add_to_menu_toolbar 
+				    "_Forward" 
+				    ~tooltip:"Forward one command" 
+				    ~key:GdkKeysyms._Down 
+				    ~callback:(do_or_activate (fun a -> a#process_next_phrase true true true))
+				    `GO_DOWN;
+				  add_to_menu_toolbar "_Backward"
+				    ~tooltip:"Backward one command" 
+				    ~key:GdkKeysyms._Up
+				    ~callback:(do_or_activate (fun a -> a#undo_last_step))
+				    `GO_UP;
+				  add_to_menu_toolbar 
+				    "_Go to" 
+				    ~tooltip:"Go to cursor" 
+				    ~key:GdkKeysyms._Right
+				    ~callback:(do_or_activate (fun a-> a#go_to_insert))
+				    `JUMP_TO;
+				  add_to_menu_toolbar 
+				    "_Start" 
+				    ~tooltip:"Go to start" 
+				    ~key:GdkKeysyms._Home
+				    ~callback:(do_or_activate (fun a -> a#reset_initial))
+				    `GOTO_TOP;
+				  add_to_menu_toolbar 
+				    "_End" 
+				    ~tooltip:"Go to end" 
+				    ~key:GdkKeysyms._End
+				    ~callback:(do_or_activate (fun a -> a#process_until_end_or_error))
+				    `GOTO_BOTTOM;
+				  add_to_menu_toolbar "_Interrupt"
+				    ~tooltip:"Interrupt computations"    
+				    ~key:GdkKeysyms._Break 
+				    ~callback:break
+				    `STOP
+				  ;
+
+				  (* Tactics Menu *)
+				  let tactics_menu =  factory#add_submenu "_Try Tactics" in
+				  let tactics_factory = 
+				    new GMenu.factory tactics_menu 
+				      ~accel_path:"<CoqIde MenuBar>/Tactics/"
+				      ~accel_group 
+				      ~accel_modi:!current.modifier_for_tactics
+				  in
+				  let do_if_active_raw f () = 
+				    let current = get_current_view () in
+				    let analyzed_view = out_some current.analyzed_view in
+				      if analyzed_view#is_active then ignore (f analyzed_view)
+				  in
+				  let do_if_active f =
+				    do_if_not_computing "do_if_active" (do_if_active_raw f) in
+
+				    (*
+				      let blaster_i = 
+				      tactics_factory#add_item "_Blaster"
+				      ~key:GdkKeysyms._b
+				      ~callback: (do_if_active_raw (fun a -> a#blaster ()))
+				    (* Custom locking mechanism! *)
+				      in
+				      blaster_i#misc#set_state `INSENSITIVE;
+				    *)
+				    
+				    ignore (tactics_factory#add_item "_auto" 
+					      ~key:GdkKeysyms._a
+					      ~callback:(do_if_active (fun a -> a#insert_command "progress auto.\n" "auto.\n"))
+					   );
+				    ignore (tactics_factory#add_item "_auto with *"
+					      ~key:GdkKeysyms._asterisk
+					      ~callback:(do_if_active (fun a -> a#insert_command 
+									 "progress auto with *.\n"
+									 "auto with *.\n")));
+				    ignore (tactics_factory#add_item "_eauto"
+					      ~key:GdkKeysyms._e
+					      ~callback:(do_if_active (fun a -> a#insert_command 
+									 "progress eauto.\n"
+									 "eauto.\n"))
+					   );
+				    ignore (tactics_factory#add_item "_eauto with *"
+					      ~key:GdkKeysyms._ampersand
+					      ~callback:(do_if_active (fun a -> a#insert_command 
+									 "progress eauto with *.\n" 
+									 "eauto with *.\n"))
+					   );
+				    ignore (tactics_factory#add_item "_intuition"
+					      ~key:GdkKeysyms._i
+					      ~callback:(do_if_active (fun a -> a#insert_command 
+									 "progress intuition.\n" 
+									 "intuition.\n"))
+					   );
+				    ignore (tactics_factory#add_item "_omega"
+					      ~key:GdkKeysyms._o
+					      ~callback:(do_if_active (fun a -> a#insert_command 
+									 "omega.\n" "omega.\n"))
+					   );
+				    ignore (tactics_factory#add_item "_simpl"
+					      ~key:GdkKeysyms._s
+					      ~callback:(do_if_active (fun a -> a#insert_command "progress simpl.\n" "simpl.\n" ))
+					   );
+				    ignore (tactics_factory#add_item "_tauto"
+					      ~key:GdkKeysyms._p
+					      ~callback:(do_if_active (fun a -> a#insert_command "tauto.\n" "tauto.\n" ))
+					   );
+				    ignore (tactics_factory#add_item "_trivial"
+					      ~key:GdkKeysyms._v
+					      ~callback:(do_if_active( fun a -> a#insert_command "progress trivial.\n"  "trivial.\n" ))
+					   );
+
+
+				    ignore (toolbar#insert_button
+					      ~tooltip:"Proof Wizard"
+					      ~text:"Wizard"
+					      ~icon:(stock_to_widget ~size:`LARGE_TOOLBAR `DIALOG_INFO)
+					      ~callback:(do_if_active (fun a -> a#tactic_wizard
+									 !current.automatic_tactics
+								      ))
+					      ());
+
+				    ignore (tactics_factory#add_item "<Proof _Wizard>"
+					      ~key:GdkKeysyms._dollar
+					      ~callback:(do_if_active (fun a -> a#tactic_wizard 
+									 !current.automatic_tactics
+								      ))
+					   );
+				    
+				    ignore (tactics_factory#add_separator ());
+				    let add_simple_template (factory: GMenu.menu GMenu.factory) 
+					(menu_text, text) =
+				      let text = 
+					let l = String.length text - 1 in
+					  if String.get text l = '.'
+					  then text ^"\n"
+					  else text ^" "
+				      in
+					ignore (factory#add_item menu_text
+						  ~callback:
+						  (fun () -> let {view = view } = get_current_view () in
+							       ignore (view#buffer#insert_interactive text)))
+				    in
+				      List.iter 
+					(fun l -> 
+					   match l with 
+					     | [] -> ()
+					     | [s] -> add_simple_template tactics_factory ("_"^s, s) 
+					     | s::_ -> 
+						 let a = "_@..." in
+						   a.[1] <- s.[0];
+						   let f = tactics_factory#add_submenu a in 
+						   let ff = new GMenu.factory f ~accel_group in
+						     List.iter 
+						       (fun x -> 
+							  add_simple_template
+							    ff 
+							    ((String.sub x 0 1)^
+							       "_"^
+							       (String.sub x 1 (String.length x - 1)),
+							     x))
+						       l
+					) 
+					Coq_commands.tactics;
+				      
+				      (* Templates Menu *)
+				      let templates_menu =  factory#add_submenu "Te_mplates" in
+				      let templates_factory = new GMenu.factory templates_menu 
+					~accel_path:"<CoqIde MenuBar>/Templates/"
+					~accel_group 
+					~accel_modi:!current.modifier_for_templates
+				      in
+				      let add_complex_template (menu_text, text, offset, len, key) =
+					(* Templates/Lemma *)
+					let callback () =
+					  let {view = view } = get_current_view () in
+					    if view#buffer#insert_interactive text then begin
+						let iter = view#buffer#get_iter_at_mark `INSERT in
+						  ignore (iter#nocopy#backward_chars offset);
+						  view#buffer#move_mark `INSERT iter;
+						  ignore (iter#nocopy#backward_chars len);
+						  view#buffer#move_mark `SEL_BOUND iter;
+					      end in
+					  ignore (templates_factory#add_item menu_text ~callback ?key)
+				      in
+					add_complex_template 
+					  ("_Lemma __", "Lemma new_lemma : .\nProof.\n\nSave.\n", 
+					   19, 9, Some GdkKeysyms._L);
+					add_complex_template 
+					  ("_Theorem __", "Theorem new_theorem : .\nProof.\n\nSave.\n", 
+					   19, 11, Some GdkKeysyms._T);
+					add_complex_template 
+					  ("_Definition __", "Definition ident := .\n",
+					   6, 5, Some GdkKeysyms._D);
+					add_complex_template 
+					  ("_Inductive __", "Inductive ident : :=\n  | : .\n",
+					   14, 5, Some GdkKeysyms._I);
+					add_complex_template 
+					  ("_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n",
+					   29, 5, Some GdkKeysyms._F);
+					add_complex_template("_Scheme __",
+							     "Scheme new_scheme := Induction for _ Sort _
+with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
+
+					(* Template for match *)
+					let callback () = 
+					  let w = get_current_word () in
+					    try 
+					      let cases = Coq.make_cases w
+					      in
+					      let print c = function
+						| [x] -> Format.fprintf c "  | %s => _@\n" x
+						| x::l -> Format.fprintf c "  | (%s%a) => _@\n" x 
+						    (print_list (fun c s -> Format.fprintf c " %s" s)) l
+						| [] -> assert false
+					      in
+					      let b = Buffer.create 1024 in
+					      let fmt = Format.formatter_of_buffer b in
+						Format.fprintf fmt "@[match var with@\n%aend@]@."
+						  (print_list print) cases;
+						let s = Buffer.contents b in
+						  prerr_endline s;
+						  let {view = view } = get_current_view () in
+						    ignore (view#buffer#delete_selection ());
+						    let m = view#buffer#create_mark 
+						      (view#buffer#get_iter `INSERT)
+						    in
+						      if view#buffer#insert_interactive s then 
+							let i = view#buffer#get_iter (`MARK m) in
+							let _ = i#nocopy#forward_chars 9 in
+							  view#buffer#place_cursor i;
+							  view#buffer#move_mark ~where:(i#backward_chars 3)
+							    `SEL_BOUND 
+					    with Not_found -> !flash_info "Not an inductive type"
+					in
+					  ignore (templates_factory#add_item "match ..."
+						    ~key:GdkKeysyms._C
+						    ~callback
+						 );
+					  
+					  (*
+					    let add_simple_template (factory: GMenu.menu GMenu.factory) 
+					    (menu_text, text) =
+					    let text = 
+					    let l = String.length text - 1 in
+					    if String.get text l = '.'
+					    then text ^"\n"
+					    else text ^" "
+					    in
+					    ignore (factory#add_item menu_text
+					    ~callback:
+					    (fun () -> let {view = view } = get_current_view () in
+					    ignore (view#buffer#insert_interactive text)))
+					    in
+					  *)
+					  ignore (templates_factory#add_separator ());
+					  (*
+					    List.iter (add_simple_template templates_factory)
+					    [ "_auto", "auto ";
+					    "_auto with *", "auto with * ";
+					    "_eauto", "eauto ";
+					    "_eauto with *", "eauto with * ";
+					    "_intuition", "intuition ";
+					    "_omega", "omega ";
+					    "_simpl", "simpl ";
+					    "_tauto", "tauto ";
+					    "tri_vial", "trivial ";
+					    ];
+					    ignore (templates_factory#add_separator ());
+					  *)
+					  List.iter 
+					    (fun l -> 
+					       match l with 
+						 | [] -> ()
+						 | [s] -> add_simple_template templates_factory ("_"^s, s) 
+						 | s::_ -> 
+						     let a = "_@..." in
+						       a.[1] <- s.[0];
+						       let f = templates_factory#add_submenu a in 
+						       let ff = new GMenu.factory f ~accel_group in
+							 List.iter 
+							   (fun x -> 
+							      add_simple_template 
+								ff 
+								((String.sub x 0 1)^
+								   "_"^
+								   (String.sub x 1 (String.length x - 1)),
+								 x))
+							   l
+					    ) 
+					    Coq_commands.commands;
+					  
+					  (* Queries Menu *)
+					  let queries_menu =  factory#add_submenu "_Queries" in
+					  let queries_factory = new GMenu.factory queries_menu ~accel_group
+					    ~accel_path:"<CoqIde MenuBar>/Queries"
+					    ~accel_modi:[]
+					  in
+					    
+					  (* Command/Show commands *)
+					  let _ = 
+					    queries_factory#add_item "_SearchAbout " ~key:GdkKeysyms._F2
+					      ~callback:(fun () -> let term = get_current_word () in
+								     (Command_windows.command_window ())#new_command
+								       ~command:"SearchAbout"
+								       ~term 
+								       ())
+					  in
+					  let _ = 
+					    queries_factory#add_item "_Check " ~key:GdkKeysyms._F3
+					      ~callback:(fun () -> let term = get_current_word () in
+								     (Command_windows.command_window ())#new_command
+								       ~command:"Check"
+								       ~term 
+								       ())
+					  in
+					  let _ = 
+					    queries_factory#add_item "_Print " ~key:GdkKeysyms._F4
+					      ~callback:(fun () -> let term = get_current_word () in
+								     (Command_windows.command_window ())#new_command
+								       ~command:"Print"
+								       ~term 
+								       ())
+					  in
+					  let _ = 
+					    queries_factory#add_item "_Whelp Locate" 
+					      ~callback:(fun () -> let term = get_current_word () in
+								     (Command_windows.command_window ())#new_command
+								       ~command:"Whelp Locate"
+								       ~term 
+								       ())
+					  in
+
+					  (* Externals *)
+					  let externals_menu =  factory#add_submenu "_Compile" in
+					  let externals_factory = new GMenu.factory externals_menu 
+					    ~accel_path:"<CoqIde MenuBar>/Compile/"
+					    ~accel_group 
+					    ~accel_modi:[]
+					  in
+					    
+					  (* Command/Compile Menu *)
+					  let compile_f () =
+					    let v = get_current_view () in
+					    let av = out_some v.analyzed_view in
+					      save_f ();
+					      match av#filename with
+						| None -> 
+						    !flash_info "Active buffer has no name"
+						| Some f ->
+						    let s,res = run_command 
+						      av#insert_message 
+						      (!current.cmd_coqc ^ " " ^ f) 
+						    in
+						      if s = Unix.WEXITED 0 then
+							!flash_info (f ^ " successfully compiled")
+						      else begin
+							  !flash_info (f ^ " failed to compile");
+							  activate_input (notebook ())#current_page;
+							  av#process_until_end_or_error;
+							  av#insert_message "Compilation output:\n";
+							  av#insert_message res
+							end
+					  in
+					  let _ = 
+					    externals_factory#add_item "_Compile Buffer" ~callback:compile_f 
+					  in
+
+					  (* Command/Make Menu *)
+					  let make_f () =
+					    let v = get_active_view () in
+					    let av = out_some v.analyzed_view in
+					      (*
+						save_f ();
+					      *)
+					      av#insert_message "Command output:\n";
+					      let s,res = run_command av#insert_message !current.cmd_make in
+						last_make := res;
+						last_make_index := 0;
+						!flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+					  in
+					  let _ = externals_factory#add_item "_Make" 
+					    ~key:GdkKeysyms._F6
+					    ~callback:make_f 
+					  in
+					    
+
+					  (* Compile/Next Error *)
+					  let next_error () = 
+					    try
+					      let file,line,start,stop,error_msg = search_next_error () in
+						load file;
+						let v = get_current_view () in
+						let av = out_some v.analyzed_view in
+						let input_buffer = v.view#buffer in
+						  (*
+						    let init = input_buffer#start_iter in
+						    let i = init#forward_lines (line-1) in
+						  *)
+						  (*
+						    let convert_pos = byte_offset_to_char_offset phrase in
+						    let start = convert_pos start in
+						    let stop = convert_pos stop in
+						  *)
+						  (*
+						    let starti = i#forward_chars start in
+						    let stopi = i#forward_chars stop in
+						  *)
+						let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in
+						let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in
+						  input_buffer#apply_tag_by_name "error"
+   						    ~start:starti
+						    ~stop:stopi;
+						  input_buffer#place_cursor starti;
+						  av#set_message error_msg;
+						  v.view#misc#grab_focus ()
+					    with Not_found ->
+					      last_make_index := 0;
+					      let v = get_current_view () in
+					      let av = out_some v.analyzed_view in
+						av#set_message "No more errors.\n"
+					  in
+					  let _ = 
+					    externals_factory#add_item "_Next error" 
+					      ~key:GdkKeysyms._F7
+					      ~callback:next_error in
+					    
+
+					  (* Command/CoqMakefile Menu*)
+					  let coq_makefile_f () =
+					    let v = get_active_view () in
+					    let av = out_some v.analyzed_view in
+					    let s,res = run_command av#insert_message !current.cmd_coqmakefile in
+					      !flash_info 
+						(!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+					  in
+					  let _ = externals_factory#add_item "_Make makefile" ~callback:coq_makefile_f 
+					  in
+					    (* Windows Menu *)
+					  let configuration_menu = factory#add_submenu "_Windows" in
+					  let configuration_factory = new GMenu.factory configuration_menu ~accel_path:"<CoqIde MenuBar>/Windows" ~accel_group
+					  in
+					  let _ = 
+					    configuration_factory#add_item 
+					      "Show _Query Window"
+					      (*
+						~key:GdkKeysyms._F12
+					      *)
+					      ~callback:(Command_windows.command_window ())#window#present
+					  in  
+					  let _ = 
+					    configuration_factory#add_item 
+					      "Show/Hide _Toolbar"	       
+					      ~callback:(fun () ->  
+							   !current.show_toolbar <- not !current.show_toolbar; 
+							   !show_toolbar !current.show_toolbar) 
+					  in
+					  let _ = configuration_factory#add_item 
+					    "Detach _Script Window"
+					    ~callback:
+					    (do_if_not_computing "detach script window" (sync
+											   (fun () -> 
+											      let nb = notebook () in
+												if nb#misc#toplevel#get_oid=w#coerce#get_oid then
+												  begin  
+												    let nw = GWindow.window ~show:true () in
+												    let parent = out_some nb#misc#parent in
+												      ignore (nw#connect#destroy 
+														~callback:
+														(fun () -> nb#misc#reparent parent));
+												      nw#add_accel_group accel_group;
+												      nb#misc#reparent nw#coerce
+												  end	      
+											   )))
+					  in
+					  let _ = 
+					    configuration_factory#add_item 
+					      "Detach _View"
+					      ~callback:
+					      (do_if_not_computing "detach view"
+						 (fun () -> 
+						    match get_current_view () with  
+						      | {view=v;analyzed_view=Some av} -> 
+							  let w = GWindow.window ~show:true 
+							    ~width:(!current.window_width/2)
+							    ~height:(!current.window_height)
+							    ~title:(match av#filename with
+								      | None -> "*Unnamed*"
+								      | Some f -> f) 
+							    () 
+							  in
+							  let sb = GBin.scrolled_window 
+							    ~packing:w#add () 
+							  in
+							  let nv = GText.view 
+							    ~buffer:v#buffer 
+							    ~packing:sb#add 
+							    ()
+							  in
+							    nv#misc#modify_font 
+							      !current.text_font; 
+							    ignore (w#connect#destroy 
+								      ~callback:
+								      (fun () -> av#remove_detached_view w));
+							    av#add_detached_view w
+						      | _ -> ()
+							  
+						 ))
+					  in
+					    (* Help Menu *)
+
+					  let help_menu = factory#add_submenu "_Help" in
+					  let help_factory = new GMenu.factory help_menu  
+					    ~accel_path:"<CoqIde MenuBar>/Help/"
+					    ~accel_modi:[]
+					    ~accel_group in
+					  let _ = help_factory#add_item "Browse Coq _Manual" 
+					    ~callback:
+					    (fun () -> 
+					       let av = out_some ((get_current_view ()).analyzed_view) in 
+						 browse av#insert_message (!current.doc_url ^ "main.html")) in
+					  let _ = help_factory#add_item "Browse Coq _Library" 
+					    ~callback:
+					    (fun () -> 
+					       let av = out_some ((get_current_view ()).analyzed_view) in 
+						 browse av#insert_message !current.library_url) in
+					  let _ = 
+					    help_factory#add_item "Help for _keyword" ~key:GdkKeysyms._F1
+					      ~callback:(fun () -> 
+							   let av = out_some ((get_current_view ()).analyzed_view) in 
+							     av#help_for_keyword ())
+					  in
+					  let _ = help_factory#add_separator () in
+					    (*
+					      let faq_m = help_factory#add_item "_FAQ" in
+					    *)
+					  let about_m = help_factory#add_item "_About" in
+
+					  (* End of menu *)
+
+					  (* The vertical Separator between Scripts and Goals *)
+					  let hb = GPack.paned `HORIZONTAL  ~border_width:5 ~packing:vbox#add () in
+					  let fr_notebook = GBin.frame ~shadow_type:`IN ~packing:hb#add1 () in
+					    _notebook := Some (GPack.notebook ~border_width:2 ~show_border:false ~scrollable:true 
+								 ~packing:fr_notebook#add
+								 ());
+					    let nb = notebook () in
+					    let hb2 = GPack.paned `VERTICAL ~packing:hb#add2 () in
+					    let fr_a = GBin.frame ~shadow_type:`IN ~packing:hb2#add () in
+					    let fr_b = GBin.frame ~shadow_type:`IN ~packing:hb2#add () in
+					    let sw2 = GBin.scrolled_window 
+					      ~vpolicy:`AUTOMATIC 
+					      ~hpolicy:`AUTOMATIC
+					      ~packing:(fr_a#add) () in
+					    let sw3 = GBin.scrolled_window 
+					      ~vpolicy:`AUTOMATIC 
+					      ~hpolicy:`AUTOMATIC
+					      ~packing:(fr_b#add) () in
+					    let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
+					    let status_bar = GMisc.statusbar ~packing:(lower_hbox#pack ~expand:true) () 
+					    in
+					    let search_lbl = GMisc.label ~text:"Search:"
+					      ~show:false
+					      ~packing:(lower_hbox#pack ~expand:false) () 
+					    in
+					    let search_history = ref [] in
+					    let search_input = GEdit.combo ~popdown_strings:!search_history
+					      ~enable_arrow_keys:true
+					      ~show:false
+					      ~packing:(lower_hbox#pack ~expand:false) () 
+					    in
+					      search_input#disable_activate ();
+					      let ready_to_wrap_search = ref false in
+
+					      let start_of_search = ref None in
+					      let start_of_found = ref None in
+					      let end_of_found = ref None in
+					      let search_forward = ref true in
+					      let matched_word = ref None in
+
+					      let memo_search () = 
+						matched_word := Some search_input#entry#text
+
+					      (*     if not (List.mem search_input#entry#text !search_history) then
+						     (search_history := 
+						     search_input#entry#text::!search_history;
+						     search_input#set_popdown_strings !search_history);
+						     start_of_search := None;
+						     ready_to_wrap_search := false
+					      *)
+
+					      in
+					      let end_search () = 
+						prerr_endline "End Search";
+						memo_search ();
+						let v = (get_current_view ()).view in
+						  v#buffer#move_mark `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT);
+						  v#coerce#misc#grab_focus ();
+						  search_input#entry#set_text "";
+						  search_lbl#misc#hide ();
+						  search_input#misc#hide ()
+					      in
+					      let end_search_focus_out () = 
+						prerr_endline "End Search(focus out)";
+						memo_search ();
+						let v = (get_current_view ()).view in
+						  v#buffer#move_mark `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT);
+						  search_input#entry#set_text "";
+						  search_lbl#misc#hide ();
+						  search_input#misc#hide ()
+					      in
+						ignore (search_input#entry#connect#activate ~callback:end_search);
+						ignore (search_input#entry#event#connect#key_press 
+							  ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in
+										if 
+										  kv = GdkKeysyms._Right
+										  || kv = GdkKeysyms._Up 
+										  || kv = GdkKeysyms._Left
+										  || (kv = GdkKeysyms._g 
+										      && (List.mem `CONTROL (GdkEvent.Key.state k)))
+										then end_search (); 
+								       false));
+						ignore (search_input#entry#event#connect#focus_out
+							  ~callback:(fun _ -> end_search_focus_out (); false));
+						to_do_on_page_switch := 
+						  (fun i -> 
+						     start_of_search := None;
+						     ready_to_wrap_search:=false)::!to_do_on_page_switch;
+
+						(* TODO : make it work !!! *)
+						let rec search_f () = 
+						  search_lbl#misc#show ();
+						  search_input#misc#show ();
+
+						  prerr_endline "search_f called";
+						  if !start_of_search = None then begin
+						      (* A full new search is starting *)
+						      start_of_search := 
+							Some ((get_current_view ()).view#buffer#create_mark 
+								((get_current_view ()).view#buffer#get_iter_at_mark `INSERT));
+						      start_of_found := !start_of_search;
+						      end_of_found := !start_of_search;
+						      matched_word := Some "";
+						    end;
+						  let txt = search_input#entry#text in 
+						  let v = (get_current_view ()).view in
+						  let iit = v#buffer#get_iter_at_mark `SEL_BOUND 
+						  and insert_iter = v#buffer#get_iter_at_mark `INSERT
+						  in
+						    prerr_endline ("SELBOUND="^(string_of_int iit#offset));
+						    prerr_endline ("INSERT="^(string_of_int insert_iter#offset));
+						    
+						    (match
+							 if !search_forward then iit#forward_search txt 
+							 else let npi = iit#forward_chars (Glib.Utf8.length txt) in
+								match 
+								  (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset),
+								  (let t = iit#get_text ~stop:npi in 
+								     !flash_info (t^"\n"^txt);
+								     t = txt)
+								with 
+								  | true,true -> 
+								      (!flash_info "T,T";iit#backward_search txt)
+								  | false,true -> !flash_info "F,T";Some (iit,npi)
+								  | _,false ->
+								      (iit#backward_search txt)
+
+						     with 
+						       | None -> 
+							   if !ready_to_wrap_search then begin
+							       ready_to_wrap_search := false;
+							       !flash_info "Search wrapped";
+							       v#buffer#place_cursor 
+								 (if !search_forward then v#buffer#start_iter else
+								      v#buffer#end_iter);
+							       search_f ()
+							     end else begin
+								 if !search_forward then !flash_info "Search at end"
+								 else !flash_info "Search at start";
+								 ready_to_wrap_search := true
+							       end
+						       | Some (start,stop) -> 
+							   prerr_endline "search: before moving marks";
+							   prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
+							   prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
+
+							   v#buffer#move_mark `SEL_BOUND start;
+							   v#buffer#move_mark `INSERT stop;
+							   prerr_endline "search: after moving marks";
+							   prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
+							   prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
+							   v#scroll_to_mark `SEL_BOUND
+						    )
+						in
+						  ignore (search_input#entry#event#connect#key_release 
+							    ~callback:
+							    (fun ev ->
+							       if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin
+								   let v = (get_current_view ()).view in
+								     (match !start_of_search with 
+									| None -> 
+									    prerr_endline "search_key_rel: Placing sel_bound";
+									    v#buffer#move_mark 
+									      `SEL_BOUND 
+									      (v#buffer#get_iter_at_mark `INSERT)
+									| Some mk -> let it = v#buffer#get_iter_at_mark 
+									    (`MARK mk) in
+										       prerr_endline "search_key_rel: Placing cursor";
+									    v#buffer#place_cursor it;
+									    start_of_search := None
+								     );
+								     search_input#entry#set_text ""; 
+								     v#coerce#misc#grab_focus ();
+								 end; 
+							       false
+							    ));
+						  ignore (search_input#entry#connect#changed search_f);
+						  
+						  (*
+						    ignore (search_if#connect#activate
+						    ~callback:(fun b -> 
+						    search_forward:= true;
+						    search_input#entry#coerce#misc#grab_focus ();
+						    search_f ();
+						    )
+						    );
+						    ignore (search_ib#connect#activate
+						    ~callback:(fun b ->
+						    search_forward:= false;
+
+						  (* Must restore the SEL_BOUND mark after 
+						    grab_focus ! *)
+						    let v = (get_current_view ()).view in
+						    let old_sel = v#buffer#get_iter_at_mark `SEL_BOUND 
+						    in
+						    search_input#entry#coerce#misc#grab_focus ();
+						    v#buffer#move_mark `SEL_BOUND old_sel;
+						    search_f ();
+						    ));
+						  *)
+						  let status_context = status_bar#new_context "Messages" in
+						  let flash_context = status_bar#new_context "Flash" in
+						    ignore (status_context#push "Ready");
+						    status := Some status_bar;
+						    push_info := (fun s -> ignore (status_context#push s));
+						    pop_info := (fun () -> status_context#pop ());
+						    flash_info := (fun ?(delay=5000) s -> flash_context#flash ~delay s);
+
+						    (* Location display *)
+						    let l = GMisc.label
+						      ~text:"Line:     1 Char:   1" 
+						      ~packing:lower_hbox#pack () in 
+						      l#coerce#misc#set_name "location";
+						      set_location := l#set_text;
+
+						      (* Progress Bar *)
+						      pulse := 
+							(let pb = GRange.progress_bar ~pulse_step:0.2 ~packing:lower_hbox#pack ()
+							 in pb#set_text "CoqIde started";pb)#pulse;
+						      let tv2 = GText.view ~packing:(sw2#add) () in
+							tv2#misc#set_name "GoalWindow";
+							let _ = tv2#set_editable false in
+							let _ = tv2#buffer in
+							let tv3 = GText.view ~packing:(sw3#add) () in
+							  tv2#misc#set_name "MessageWindow";
+							  let _ = tv2#set_wrap_mode `CHAR in
+							  let _ = tv3#set_wrap_mode `WORD in
+							  let _ = tv3#set_editable false in
+							  let _ = GtkBase.Widget.add_events tv2#as_widget
+							    [`ENTER_NOTIFY;`POINTER_MOTION] in
+							  let _ =
+							    tv2#event#connect#motion_notify
+							      ~callback:
+							      (fun e -> 
+								 let win = match tv2#get_window `WIDGET with
+								   | None -> assert false
+								   | Some w -> w in
+								 let x,y = Gdk.Window.get_pointer_location win in
+								 let b_x,b_y = tv2#window_to_buffer_coords ~tag:`WIDGET ~x ~y in
+								 let it = tv2#get_iter_at_location ~x:b_x ~y:b_y in
+								 let tags = it#tags in
+								   List.iter 
+								     (fun t ->
+									ignore(GtkText.Tag.event t#as_tag tv2#as_widget e it#as_iter))
+								     tags;
+								   false) in
+							    change_font := 
+							      (fun fd -> 
+								 tv2#misc#modify_font fd;
+								 tv3#misc#modify_font fd;
+								 Vector.iter 
+								   (fun {view=view} -> view#misc#modify_font fd)
+								   input_views;
+							      );
+							    let about (b:GText.buffer) =
+							      (try 
+								   let image = lib_ide_file "coq.png" in
+								   let startup_image = GdkPixbuf.from_file image in
+								     b#insert_pixbuf ~iter:b#start_iter 
+								       ~pixbuf:startup_image;
+								     b#insert ~iter:b#start_iter "\t\t";
+							       with _ -> ());
+							      let about_string =
+								"\nCoqIDE: an Integrated Development Environment for Coq\n\
        \nMain author  : Benjamin Monate\
        \nContributors : Jean-Christophe Filliâtre\
        \n               Pierre Letouzey, Claude Marché\n\
@@ -3234,131 +3316,156 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S);
        \n\thttp://coq.inria.fr/bin/coq-bugs\n\
        \nVersion information\
        \n-------------------\n"
-    in
-    if Glib.Utf8.validate about_string
-    then b#insert about_string;
-    let coq_version = Coq.version () in
-    if Glib.Utf8.validate coq_version
-    then b#insert coq_version;
-      
-  in
-  about  tv2#buffer;
-  w#add_accel_group accel_group;
-  (* Remove default pango menu for textviews *)
-  ignore (tv2#event#connect#button_press ~callback:
-	    (fun ev -> GdkEvent.Button.button ev = 3));
-  ignore (tv3#event#connect#button_press ~callback:
-	    (fun ev -> GdkEvent.Button.button ev = 3));
-  tv2#misc#set_can_focus true;
-  tv3#misc#set_can_focus true;
-  ignore (tv2#buffer#create_mark 
-	    ~name:"end_of_conclusion" 
-	    tv2#buffer#start_iter);
-  ignore (tv3#buffer#create_tag 
-	    ~name:"error" 
-	    [`FOREGROUND "red"]);
-  w#show ();
-  message_view := Some tv3;
-  proof_view := Some tv2;
-  tv2#misc#modify_font !current.text_font; 
-  tv3#misc#modify_font !current.text_font;
-  ignore (about_m#connect#activate 
-	    ~callback:(fun () -> tv2#buffer#set_text ""; about tv2#buffer));
-(*
-  ignore (faq_m#connect#activate 
-	    ~callback:(fun () -> 
-			 load (lib_ide_file "FAQ")));
-  
-*)
-  resize_window := (fun () -> 
-		      w#resize 
-		      ~width:!current.window_width
-		      ~height:!current.window_height);
-
-  ignore (w#misc#connect#size_allocate 
-	    (let old_w = ref 0 
-	     and old_h = ref 0 in
-	     fun {Gtk.width=w;Gtk.height=h} -> 
-	       if !old_w <> w or !old_h <> h then
-		 begin
-		   old_h := h;
-		   old_w := w;
-		   hb#set_position (w/2);
-		   hb2#set_position (h/2);
-		   !current.window_height <- h;
-		   !current.window_width <- w;
-		 end
-	    ));
-  ignore(nb#connect#switch_page
-	   ~callback:
-	   (fun i -> 
-	      prerr_endline ("switch_page: starts " ^ string_of_int i);
-	      List.iter (function f -> f i) !to_do_on_page_switch;
-	      prerr_endline "switch_page: success")
-	);
-  ignore(tv2#event#connect#enter_notify
-	   (fun _ -> 
-	      if !current.contextual_menus_on_goal then
-		begin
-		  let w = (out_some (get_active_view ()).analyzed_view) in
-		  !push_info "Computing advanced goal's menus";
-		  prerr_endline "Entering Goal Window. Computing Menus....";
-		  w#show_goals_full;
-		  prerr_endline "....Done with Goal menu";
-		  !pop_info();
-		end;
-	      false;
-	   ));
-  if List.length files >=1 then
-    begin
-      List.iter (fun f -> 
-		   if Sys.file_exists f then load f else 
-		     if Filename.check_suffix f ".v" 
-		     then load f 
-		     else load (f^".v")) files;
-      activate_input 0
-    end
-  else
-    begin
-      let view = create_input_tab "*Unnamed Buffer*" in
-      let index = add_input_view {view = view;
-				  analyzed_view = None;
-				 }
-      in
-      (get_input_view index).analyzed_view <- Some (new analyzed_view index);
-      activate_input index;
-      set_tab_image index ~icon:`YES;
-      view#misc#modify_font !current.text_font
-    end;
+							      in
+								if Glib.Utf8.validate about_string
+								then b#insert about_string;
+								let coq_version = Coq.version () in
+								  if Glib.Utf8.validate coq_version
+								  then b#insert coq_version;
+								  
+							    in
+							      about  tv2#buffer;
+							      w#add_accel_group accel_group;
+							      (* Remove default pango menu for textviews *)
+							      ignore (tv2#event#connect#button_press ~callback:
+									(fun ev -> GdkEvent.Button.button ev = 3));
+							      ignore (tv3#event#connect#button_press ~callback:
+									(fun ev -> GdkEvent.Button.button ev = 3));
+							      tv2#misc#set_can_focus true;
+							      tv3#misc#set_can_focus true;
+							      ignore (tv2#buffer#create_mark 
+									~name:"end_of_conclusion" 
+									tv2#buffer#start_iter);
+							      ignore (tv3#buffer#create_tag 
+									~name:"error" 
+									[`FOREGROUND "red"]);
+							      w#show ();
+							      message_view := Some tv3;
+							      proof_view := Some tv2;
+							      tv2#misc#modify_font !current.text_font; 
+							      tv3#misc#modify_font !current.text_font;
+							      ignore (about_m#connect#activate 
+									~callback:(fun () -> tv2#buffer#set_text ""; about tv2#buffer));
+							      (*
+								ignore (faq_m#connect#activate 
+								~callback:(fun () -> 
+								load (lib_ide_file "FAQ")));
+								
+							      *)
+							      resize_window := (fun () -> 
+										  w#resize 
+										    ~width:!current.window_width
+										    ~height:!current.window_height);
+
+							      ignore (w#misc#connect#size_allocate 
+									(let old_w = ref 0 
+									 and old_h = ref 0 in
+									   fun {Gtk.width=w;Gtk.height=h} -> 
+									     if !old_w <> w or !old_h <> h then
+									       begin
+										 old_h := h;
+										 old_w := w;
+										 hb#set_position (w/2);
+										 hb2#set_position (h/2);
+										 !current.window_height <- h;
+										 !current.window_width <- w;
+									       end
+									));
+							      ignore(nb#connect#switch_page
+								       ~callback:
+								       (fun i -> 
+									  prerr_endline ("switch_page: starts " ^ string_of_int i);
+									  List.iter (function f -> f i) !to_do_on_page_switch;
+									  prerr_endline "switch_page: success")
+								    );
+							      ignore(tv2#event#connect#enter_notify
+								       (fun _ -> 
+									  if !current.contextual_menus_on_goal then
+									    begin
+									      let w = (out_some (get_active_view ()).analyzed_view) in
+										!push_info "Computing advanced goal's menus";
+										prerr_endline "Entering Goal Window. Computing Menus....";
+										w#show_goals_full;
+										prerr_endline "....Done with Goal menu";
+										!pop_info();
+									    end;
+									  false;
+								       ));
+							      if List.length files >=1 then
+								begin
+								  List.iter (fun f -> 
+									       if Sys.file_exists f then load f else 
+										 if Filename.check_suffix f ".v" 
+										 then load f 
+										 else load (f^".v")) files;
+								  activate_input 0
+								end
+							      else
+								begin
+								  let view = create_input_tab "*Unnamed Buffer*" in
+								  let index = add_input_view {view = view;
+											      analyzed_view = None;
+											     }
+								  in
+								    (get_input_view index).analyzed_view <- Some (new analyzed_view index);
+								    activate_input index;
+								    set_tab_image index ~icon:`YES;
+								    view#misc#modify_font !current.text_font
+								end;
 
 ;;
 
+(* This function check every half of second if GeoProof has send 
+   something on his private clipboard *)
+
+let rec check_for_geoproof_input () = 
+  let cb_Dr = GData.clipboard (Gdk.Atom.intern "_GeoProof") in
+    while true do
+      Thread.delay 0.1;
+      let s = cb_Dr#text in
+	(match s with 
+	     Some s -> 
+	       if s <> "Ack" then
+		 (get_current_view()).view#buffer#insert (s^"\n");
+	       cb_Dr#set_text "Ack"
+	   | None -> ()
+	);
+	(* cb_Dr#clear does not work so i use : *)
+	(* cb_Dr#set_text "Ack" *) 
+    done
+      
+      
 let start () = 
   let files = Coq.init () in
-  ignore_break ();
-  GtkMain.Rc.add_default_file (lib_ide_file ".coqide-gtk2rc");
-  (try 
-     GtkMain.Rc.add_default_file (Filename.concat System.home ".coqide-gtk2rc");
-  with Not_found -> ());
-  ignore (GtkMain.Main.init ());
-  GtkData.AccelGroup.set_default_mod_mask 
-    (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);
-  cb_ := Some (GData.clipboard Gdk.Atom.primary);
-  ignore (
-    Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL;
-							`WARNING;`CRITICAL]
-	    (fun ~level msg -> failwith ("Coqide internal error: " ^ msg)));
-  Command_windows.main ();
-  Blaster_window.main 9;
-  main files;
-  while true do 
-    try 
-      GtkThread.main ()
-    with
-      | Sys.Break -> prerr_endline "Interrupted." ; flush stderr
-      | e -> 
-	  Pervasives.prerr_endline ("CoqIde unexpected error:" ^ (Printexc.to_string e));
-	  flush stderr;
-	  crash_save 127
-  done
-
+    ignore_break ();
+    GtkMain.Rc.add_default_file (lib_ide_file ".coqide-gtk2rc");
+    (try 
+	 GtkMain.Rc.add_default_file (Filename.concat System.home ".coqide-gtk2rc");
+     with Not_found -> ());
+    ignore (GtkMain.Main.init ());
+    GtkData.AccelGroup.set_default_mod_mask 
+      (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);
+    cb_ := Some (GData.clipboard Gdk.Atom.primary);
+    ignore (
+	     Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL;
+								 `WARNING;`CRITICAL]
+	       (fun ~level msg -> 
+		  if level land Glib.Message.log_level `WARNING <> 0
+		  then Pp.warning msg
+		  else failwith ("Coqide internal error: " ^ msg)));
+    Command_windows.main ();
+    Blaster_window.main 9;
+    main files;
+    if !Coq_config.with_geoproof then ignore (Thread.create check_for_geoproof_input ()); 
+    while true do 
+      try 
+	GtkThread.main ()	
+      with
+	| Sys.Break -> prerr_endline "Interrupted." ; flush stderr
+	| e -> 
+	    Pervasives.prerr_endline ("CoqIde unexpected error:" ^ (Printexc.to_string e));
+	    flush stderr;
+	    crash_save 127
+    done
+      
+      
diff --git a/ide/coqide.mli b/ide/coqide.mli
index 553426f1..f904c730 100644
--- a/ide/coqide.mli
+++ b/ide/coqide.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqide.mli,v 1.1.2.2 2005/01/21 17:21:33 herbelin Exp $ i*)
+(*i $Id: coqide.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 (* The CoqIde main module. The following function [start] will parse the
    command line, initialize the load path, load the input 
diff --git a/ide/extract_index.mll b/ide/extract_index.mll
index 4a8c37f1..152ad715 100644
--- a/ide/extract_index.mll
+++ b/ide/extract_index.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: extract_index.mll,v 1.2.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+(* $Id: extract_index.mll 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 {
   open Lexing 
diff --git a/ide/find_phrase.mll b/ide/find_phrase.mll
index 7b65bd94..23019185 100644
--- a/ide/find_phrase.mll
+++ b/ide/find_phrase.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: find_phrase.mll,v 1.8.2.2 2004/10/15 14:50:13 coq Exp $ *)
+(* $Id: find_phrase.mll 9240 2006-10-13 17:51:11Z notin $ *)
 
 {
   exception Lex_error of string
@@ -28,7 +28,11 @@ rule next_phrase = parse
 		 next_phrase lexbuf
 	       }
   | phrase_sep[' ''\n''\t''\r'] {
-      length := !length + 2; 
+	begin 
+	  if !Preferences.current.Preferences.lax_syntax 
+	  then length := !length + 1
+	  else length := !length + 2
+	end;
       Buffer.add_string buff (Lexing.lexeme lexbuf);
       Buffer.contents buff}
 
@@ -36,10 +40,12 @@ rule next_phrase = parse
       length := !length + 1; 
       Buffer.add_string buff (Lexing.lexeme lexbuf);
       Buffer.contents buff}
-  | phrase_sep phrase_sep {
-      length := !length + 2; 
-      Buffer.add_string buff (Lexing.lexeme lexbuf);
-      next_phrase lexbuf}
+  | phrase_sep phrase_sep
+      { 
+	length := !length + 2; 
+	Buffer.add_string buff (Lexing.lexeme lexbuf);
+	next_phrase lexbuf
+      }
   | _ 
       { 
 	let c = Lexing.lexeme_char lexbuf 0 in 
diff --git a/ide/highlight.mll b/ide/highlight.mll
index e2a1d0cd..27ead696 100644
--- a/ide/highlight.mll
+++ b/ide/highlight.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: highlight.mll,v 1.14.2.2 2004/11/27 14:41:43 herbelin Exp $ *)
+(* $Id: highlight.mll 8880 2006-05-31 10:52:08Z notin $ *)
 
 {
 
@@ -18,6 +18,39 @@
 
   let comment_start = ref 0
 
+  let is_keyword =
+    let h = Hashtbl.create 97 in
+    List.iter (fun s -> Hashtbl.add h s ())
+      [  "Add" ; "Check"; "Defined" ; 
+	 "End" ; "Eval"; "Export" ; "Extraction" ; "Hint" ; "Hints" ;
+	 "Implicits" ; "Import" ; 
+	 "Infix" ; "Load" ; "Module" ;
+	 "Notation"; "Proof" ; "Print"; "Qed" ;
+	 "Require" ; "Reset"; "Undo"; "Save" ;
+	 "Section" ; "Unset" ;
+	 "Set" ; "Notation"
+      ];
+    Hashtbl.mem h
+
+  let is_constr_kw =
+    let h = Hashtbl.create 97 in
+      List.iter (fun s -> Hashtbl.add h s ())
+	[ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for"; 
+	  "end"; "as"; "let"; "if"; "then"; "else"; "return";
+	  "Prop"; "Set"; "Type"]; 
+      Hashtbl.mem h
+
+  let is_declaration =
+    let h = Hashtbl.create 97 in
+      List.iter (fun s -> Hashtbl.add h s ())
+	[ "Theorem" ; "Lemma" ; "Fact" ; "Remark" ; "Corollary" ; "Proposition" ; "Property" ;
+	  "Definition" ; "Let" ; "Example" ; "SubClass" ; "Inductive" ; "CoInductive" ; 
+	  "Record" ; "Structure" ; "Fixpoint" ; "CoFixpoint";  
+	  "Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ;
+	  "Hypotheses" ; "Variables" ; "Axioms" ; "Parameters"
+	];
+      Hashtbl.mem h
+
 }
 
 let space = 
@@ -28,30 +61,41 @@ let identchar =
   ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 let ident = firstchar identchar*
 
-let keyword = 
-  "Add" | "Defined" | 
-  "End" | "Export" | "Extraction" | "Hint" |
-  "Implicits" | "Import" | 
-  "Infix" | "Load" | "match" | "Module" | "Module Type" |
-  "Proof" | "Qed" |
-  "Require" | "Save" | "Scheme" |
-  "Section" | "Unset" |
-  "Set"  
+let thm_token = "Theorem" | "Lemma" | "Fact" | "Remark" | "Corollary" | "Proposition" | "Property"
+
+let def_token = "Definition" | "Let" | "Example" | "SubClass"
+
+let assumption = "Hypothesis" | "Variable" | "Axiom" | "Parameter" | "Conjecture" |
+  "Hypotheses" | "Variables" | "Axioms" | "Parameters"
 
 let declaration = 
-  "Lemma" | "Axiom" | "CoFixpoint" | "Definition"  |
-  "Fixpoint" | "Hypothesis" | 
-  "Hypotheses" | "Axioms" | "Parameters" | "Subclass" |
-  "Remark" | "Fact" | "Conjecture" | "Let" |
-  "CoInductive" | "Record" | "Structure" |
-  "Inductive" | "Parameter" | "Theorem" | 
-  "Variable" | "Variables" 
+  "Theorem" | "Lemma" | "Fact" | "Remark" | "Corollary" | "Proposition" | "Property" |
+  "Definition" | "Let" | "Example" | "SubClass" |
+  "Inductive" | "CoInductive" | 
+  "Record" | "Structure" |
+  "Fixpoint" | "CoFixpoint"
 
 rule next_order = parse
-  | "(*" { comment_start := lexeme_start lexbuf; comment lexbuf }
-  | keyword { lexeme_start lexbuf,lexeme_end lexbuf, "kwd" }
-  | declaration space+ ident (space* ',' space* ident)* 
-            { lexeme_start lexbuf, lexeme_end lexbuf, "decl" } 
+  | "(*" 
+      { comment_start := lexeme_start lexbuf; comment lexbuf }
+  | "Module Type"
+      { lexeme_start lexbuf, lexeme_end lexbuf, "kwd" }
+  | ident as id 
+      { if is_keyword id then 
+	    lexeme_start lexbuf, lexeme_end lexbuf, "kwd" 
+	else 
+	    begin
+	      if is_constr_kw id then
+		lexeme_start lexbuf, lexeme_end lexbuf, "kwd"
+	      else
+		begin
+		  if is_declaration id then
+		    lexeme_start lexbuf, lexeme_end lexbuf, "decl"
+		  else
+		    next_order lexbuf 
+		end
+	    end
+      }
   | _    { next_order lexbuf}
   | eof  { raise End_of_file }
 
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index dc3bcf71..df4594a7 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ideutils.ml,v 1.30.2.4 2006/01/06 15:40:37 barras Exp $ *)
+(* $Id: ideutils.ml 9263 2006-10-23 12:08:08Z barras $ *)
 
 
 open Preferences
@@ -34,9 +34,9 @@ let prerr_string s =
 
 let lib_ide_file f =
   let coqlib =
-    if !Options.boot then Coq_config.coqtop
-    else
-      System.getenv_else "COQLIB" Coq_config.coqlib in
+    System.getenv_else "COQLIB"
+      (if Coq_config.local || !Options.boot then Coq_config.coqtop
+       else Coq_config.coqlib) in
   Filename.concat (Filename.concat coqlib "ide") f
   
 let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT
@@ -61,17 +61,6 @@ let byte_offset_to_char_offset s byte_offset =
     byte_offset - !count_delta
   end
 
-let process_pending () =
-  prerr_endline "Pending process";()
-(*  try 
-    while Glib.Main.pending () do 
-      ignore (Glib.Main.iteration false)
-    done
-  with e -> 
-    prerr_endline "Pending problems : expect a crash very soon";
-    raise e
-*)
-
 let print_id id =
   prerr_endline ("GOT sig id :"^(string_of_int (Obj.magic id)))
 
@@ -225,6 +214,25 @@ let async =
 let sync = 
   if Sys.os_type = "Win32" then GtkThread.sync else (fun x -> x)
 
+let mutex text f =
+  let m = Mutex.create() in
+  fun x ->
+    if Mutex.try_lock m
+    then 
+      (try
+        prerr_endline ("Got lock on "^text);
+        f x;
+        Mutex.unlock m;
+        prerr_endline ("Released lock on "^text)
+      with e ->
+        Mutex.unlock m;
+        prerr_endline ("Released lock on "^text^" (on error)");
+        raise e)
+    else
+      prerr_endline
+        ("Discarded call for "^text^": computations ongoing")
+
+
 let stock_to_widget ?(size=`DIALOG) s = 
   let img = GMisc.image () 
   in img#set_stock s;
@@ -235,7 +243,8 @@ let rec print_list print fmt = function
   | [x] -> print fmt x
   | x :: r -> print fmt x; print_list print fmt r
 
-
+(* TODO: allow to report output as soon as it comes (user-fiendlier
+   for long commands like make...) *)
 let run_command f c =
   let result = Buffer.create 127 in
   let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
@@ -258,7 +267,7 @@ let run_command f c =
 
 let browse f url =
   let l,r = !current.cmd_browse in
-  let (s,res) = run_command f (l ^ url ^ r) in
+  let (_s,_res) = run_command f (l ^ url ^ r) in
   ()
 
 let url_for_keyword =
@@ -297,18 +306,27 @@ let tab = Glib.Utf8.to_unichar "\t" (ref 0)
 
 
 (*
-  checks if two file names refer to the same (existing) file
-*)
+  checks if two file names refer to the same (existing) file by
+  comparing their device and inode. 
+  It seems that under Windows, inode is always 0, so we cannot
+  accurately check if 
 
-let same_file f1 f2 =
+*)
+(* Optimised for partial application (in case many candidates must be
+   compared to f1). *)
+let same_file f1 =
   try
-    let s1 = Unix.stat f1
-    and s2 = Unix.stat f2 
-    in
-    (s1.Unix.st_dev = s2.Unix.st_dev) &&
-    (s1.Unix.st_ino = s2.Unix.st_ino) 
+    let s1 = Unix.stat f1 in
+    (fun f2 ->
+      try
+        let s2 = Unix.stat f2 in
+        s1.Unix.st_dev = s2.Unix.st_dev &&
+          if Sys.os_type = "Win32" then f1 = f2 
+          else s1.Unix.st_ino = s2.Unix.st_ino
+      with
+          Unix.Unix_error _ -> false)
   with
-      Unix.Unix_error _ -> false
+      Unix.Unix_error _ -> (fun _ -> false)
 
 let absolute_filename f =
   if Filename.is_relative f then 
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index cbdaefb9..3af80f47 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -6,10 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ideutils.mli,v 1.6.2.4 2005/11/25 17:18:28 barras Exp $ i*)
+(*i $Id: ideutils.mli 7608 2005-11-25 17:09:25Z barras $ i*)
 
 val async : ('a -> unit) -> 'a -> unit
 val sync  : ('a -> 'b) -> 'a -> 'b
+
+(* avoid running two instances of a function concurrently *)
+val mutex : string -> ('a -> unit) -> 'a -> unit
+
 val browse : (string -> unit) -> string -> unit
 val browse_keyword : (string -> unit) -> string -> unit
 val byte_offset_to_char_offset : string -> int -> int
@@ -32,7 +36,6 @@ val prerr_endline : string -> unit
 val prerr_string : string -> unit
 val print_id : 'a -> unit
 
-val process_pending : unit -> unit
 val read_stdout : unit -> string
 val revert_timer : GMain.Timeout.id option ref
 val auto_save_timer : GMain.Timeout.id option ref
diff --git a/ide/preferences.ml b/ide/preferences.ml
index 8743b99b..c01fa602 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: preferences.ml,v 1.27.2.2 2004/07/16 19:30:20 herbelin Exp $ *)
+(* $Id: preferences.ml 9350 2006-11-07 15:04:42Z notin $ *)
 
 open Configwin
 open Printf
@@ -93,7 +93,9 @@ type pref =
       mutable use_utf8_notation : bool;
 *)
       mutable auto_complete : bool;
-    }
+      mutable stop_before : bool;
+      mutable lax_syntax : bool;
+}
 
 let (current:pref ref) = 
   ref {
@@ -118,15 +120,12 @@ let (current:pref ref) =
 			 "auto with *"; "intuition" ];
     
     modifier_for_navigation = [`CONTROL; `MOD1];
-    modifier_for_templates = [`MOD4];
+    modifier_for_templates = [`CONTROL; `SHIFT];
     modifier_for_tactics = [`CONTROL; `MOD1];
-    modifiers_valid = [`SHIFT; `CONTROL; `MOD1; `MOD4];
+    modifiers_valid = [`SHIFT; `CONTROL; `MOD1];
 
     
-    cmd_browse = 
-	 if Sys.os_type = "Win32"
-	 then "C:\\PROGRA~1\\INTERN~1\\IEXPLORE ", ""
-	 else "netscape -remote \"OpenURL(", ")\"";
+    cmd_browse = Options.browser_cmd_fmt;
     cmd_editor = 
 	 if Sys.os_type = "Win32"
 	 then "NOTEPAD ", ""
@@ -146,7 +145,9 @@ let (current:pref ref) =
 (*
     use_utf8_notation = false;
 *)
-    auto_complete = false
+    auto_complete = false;
+    stop_before = true;
+    lax_syntax = true
   }
 
 
@@ -183,8 +184,7 @@ let save_pref () =
     add "encoding_use_utf8" [string_of_bool p.encoding_use_utf8] ++
     add "encoding_manual" [p.encoding_manual] ++
 
-    add "automatic_tactics" 
-      (List.rev p.automatic_tactics) ++
+    add "automatic_tactics" p.automatic_tactics ++
     add "cmd_print" [p.cmd_print] ++
     add "modifier_for_navigation" 
       (List.map mod_to_str p.modifier_for_navigation) ++
@@ -209,9 +209,11 @@ let save_pref () =
     add "query_window_height" [string_of_int p.query_window_height] ++
     add "query_window_width" [string_of_int p.query_window_width] ++
     add "auto_complete" [string_of_bool p.auto_complete] ++
+    add "stop_before" [string_of_bool p.stop_before] ++
+    add "lax_syntax" [string_of_bool p.lax_syntax] ++
     Config_lexer.print_file pref_file
   with _ -> prerr_endline "Could not save preferences."
-  
+ 
 
 let load_pref () =
   (try GtkData.AccelMap.load accel_file with _ -> ());
@@ -261,6 +263,8 @@ let load_pref () =
     set_int "query_window_width" (fun v -> np.query_window_width <- v);
     set_int "query_window_height" (fun v -> np.query_window_height <- v);
     set_bool "auto_complete" (fun v -> np.auto_complete <- v);
+    set_bool "stop_before" (fun v -> np.stop_before <- v);
+    set_bool "lax_syntax" (fun v -> np.lax_syntax <- v);
     current := np;
 (*
     Format.printf "in laod_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
@@ -269,6 +273,13 @@ let load_pref () =
     prerr_endline ("Could not load preferences ("^
 		   (Printexc.to_string e)^").")
     
+let split_string_format s =
+  try 
+    let i = Util.string_index_from s 0 "%s" in
+    let pre = (String.sub s 0 i) in
+    let post = String.sub s (i+2) (String.length s - i - 2) in
+    pre,post
+  with Not_found -> s,""
 
 let configure () = 
   let cmd_coqc = 
@@ -382,6 +393,18 @@ let configure () =
       (string_of_int !current.auto_save_delay)
   in  
 
+  let stop_before =
+    bool
+      ~f:(fun s -> !current.stop_before <- s)
+      "Stop interpreting before the current point" !current.stop_before
+  in
+    
+  let lax_syntax =
+    bool
+      ~f:(fun s -> !current.lax_syntax <- s)
+      "Relax read-only constraint at end of command" !current.lax_syntax
+  in
+
   let encodings = 
     combo 
       "File charset encoding "
@@ -439,40 +462,14 @@ let configure () =
 
   let cmd_editor = 
     string
-      ~f:(fun s -> 
-	    !current.cmd_editor <- 
-	    try 
-	      let i = String.index s '%' in
-	      let pre = (String.sub s 0 i) in
-	      if String.length s - 1 = i then 
-		pre,""
-	      else
-		let post = String.sub s (i+2) (String.length s - i - 2) in
-		prerr_endline pre;
-		prerr_endline post;
-		pre,post
-	    with Not_found -> s,""
-	    )
+      ~f:(fun s -> !current.cmd_editor <- split_string_format s)
       ~help:"(%s for file name)" 
       "External editor"
       ((fst !current.cmd_editor)^"%s"^(snd !current.cmd_editor))
   in    
   let cmd_browse = 
     string
-      ~f:(fun s -> 
-	    !current.cmd_browse <- 
-	    try 
-	      let i = String.index s '%' in
-	      let pre = (String.sub s 0 i) in
-	      if String.length s - 1 = i then 
-		pre,""
-	      else
-		let post = String.sub s (i+2) (String.length s - i - 2) in
-		prerr_endline pre;
-		prerr_endline post;
-		pre,post
-	    with Not_found -> s,""
-	    )
+      ~f:(fun s -> !current.cmd_browse <- split_string_format s)
       ~help:"(%s for url)" 
       "    Browser"
       ((fst !current.cmd_browse)^"%s"^(snd !current.cmd_browse))
@@ -499,7 +496,7 @@ let configure () =
       "Contextual menus on goal" !current.contextual_menus_on_goal
   in 
 
-  let misc = [contextual_menus_on_goal;auto_complete] in
+  let misc = [contextual_menus_on_goal;auto_complete;stop_before;lax_syntax] in
    
 (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!
    (shame on Benjamin) *)
diff --git a/ide/preferences.mli b/ide/preferences.mli
index 048707a3..c3e26f50 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: preferences.mli,v 1.8.2.2 2005/01/21 17:21:33 herbelin Exp $ i*)
+(*i $Id: preferences.mli 9240 2006-10-13 17:51:11Z notin $ i*)
 
 type pref =
     {
@@ -52,6 +52,8 @@ type pref =
       mutable use_utf8_notation : bool;
 *)
       mutable auto_complete : bool;
+      mutable stop_before : bool;
+      mutable lax_syntax : bool;
     }
 
 val save_pref : unit -> unit
diff --git a/ide/undo.ml b/ide/undo.ml
index 6f740667..f617d289 100644
--- a/ide/undo.ml
+++ b/ide/undo.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: undo.ml,v 1.8.2.2 2005/11/16 17:22:39 barras Exp $ *)
+(* $Id: undo.ml 7603 2005-11-23 17:21:53Z barras $ *)
 
 open GText
 open Ideutils
@@ -71,7 +71,6 @@ object(self)
 	      (self#buffer#insert_interactive ~iter s) or
 	      (Stack.push act history; false)
       in if r then begin
-	process_pending ();
 	let act = Stack.pop history in
 	Queue.push act redo;
 	Stack.push act nredo
@@ -107,8 +106,8 @@ object(self)
 		   Queue.iter (fun e -> Stack.push e history) redo;
 		   Queue.clear redo;
 		 end;
-		 let pos = it#offset in
-(*		 if Stack.is_empty history or 
+(*		 let pos = it#offset in
+		 if Stack.is_empty history or 
 		   s=" " or s="\t" or s="\n" or
 					(match Stack.top history with 
 					   | Insert(old,opos,olen) -> 
diff --git a/ide/undo_lablgtk_ge26.mli b/ide/undo_lablgtk_ge26.mli
index d81d08d5..b87f6559 100644
--- a/ide/undo_lablgtk_ge26.mli
+++ b/ide/undo_lablgtk_ge26.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: undo_lablgtk_ge26.mli,v 1.1.2.1 2005/11/18 16:37:28 herbelin Exp $ i*)
+(*i $Id: undo_lablgtk_ge26.mli 7580 2005-11-18 17:09:10Z herbelin $ i*)
 
 (* An undoable view class *)
 
diff --git a/ide/undo_lablgtk_lt26.mli b/ide/undo_lablgtk_lt26.mli
index 9c2176b0..ddee31d2 100644
--- a/ide/undo_lablgtk_lt26.mli
+++ b/ide/undo_lablgtk_lt26.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: undo_lablgtk_lt26.mli,v 1.1.2.1 2005/11/18 16:37:28 herbelin Exp $ i*)
+(*i $Id: undo_lablgtk_lt26.mli 7580 2005-11-18 17:09:10Z herbelin $ i*)
 
 (* An undoable view class *)
 
diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll
index 4c88adc5..7e6484e1 100644
--- a/ide/utf8_convert.mll
+++ b/ide/utf8_convert.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: utf8_convert.mll,v 1.1.2.1 2004/07/16 19:30:21 herbelin Exp $ *)
+(* $Id: utf8_convert.mll 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 {
   open Lexing 
diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml
new file mode 100644
index 00000000..30eb0111
--- /dev/null
+++ b/ide/utils/config_file.ml
@@ -0,0 +1,642 @@
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
+
+(* $Id: config_file.ml 8618 2006-03-08 11:44:47Z notin $ *)
+
+(* TODO *)
+(* section comments *)
+(* better obsoletes: no "{}", line cuts *)
+
+(* possible improvements: *)
+(* use lex/yacc instead of genlex to be more robust, efficient, allow arrays and other types, read comments. *)
+(* description and help, level (beginner/advanced/...) for each cp *)
+(* find an option from its name and group *)
+(* class hooks *)
+(* get the sections of a group / of a file *)
+(* read file format from inifiles and ConfigParser *)
+
+
+(* Read the mli before reading this file! *)
+
+
+(* ******************************************************************************** *)
+(* ******************************** misc utilities ******************************** *)
+(* ******************************************************************************** *)
+(* This code is intended to be usable without any dependencies. *)
+
+(* pipeline style, see for instance Raw.of_channel. *)
+let (|>) x f  = f x
+
+(* as List.assoc, but applies f to the element matching [key] and returns the list
+where this element has been replaced by the result of f. *)
+let rec list_assoc_remove key f = function
+  | [] -> raise Not_found
+  | (key',value) as elt :: tail ->
+      if key <> key'
+      then elt :: list_assoc_remove key f tail
+      else match f value with
+        | None -> tail
+        | Some a -> (key',a) :: tail
+
+(* reminiscent of String.concat. Same as [Queue.iter f1 queue]
+   but calls [f2 ()] between each calls to f1.
+   Does not call f2 before the first call nor after the last call to f2.
+   Could be more efficient with a richer module interface of Queue.
+*)
+let queue_iter_between f1 f2 queue =
+(*   let f flag elt = if flag then f2 (); (f1 elt:unit); true in *)
+  let f flag elt = if flag then f2 (); f1 elt; true in
+  ignore (Queue.fold f false queue)
+
+let list_iter_between f1 f2 = function
+    [] -> ()
+  | a::[] -> f1 a
+  | a::tail -> f1 a; List.iter (fun elt -> (f2 ():unit); f1 elt) tail
+(*   | a::tail -> f1 a; List.iter (fun elt -> f2 (); f1 elt) tail *)
+(* !! types ??? *)
+
+(* to ensure that strings will be parsed correctly by Genlex.
+It's more comfortable not to have quotes around the string, but sometimes it's necessary. *)
+exception Unsafe_string
+let safe_string s =
+  if s = ""
+  then "\"\""
+  else if (
+    try match s.[0] with
+      | 'a'..'z' | 'A'..'Z' ->
+          for i = 1 to String.length s - 1 do
+            match s.[i] with
+                'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> ()
+              | _ -> raise Unsafe_string
+          done;
+        false
+      | _ ->
+          try
+            string_of_int (int_of_string s) <> s ||
+            string_of_float (float_of_string s) <> s
+          with Failure "int_of_string" | Failure "float_of_string" -> true
+    with Unsafe_string -> true)
+  then Printf.sprintf "\"%s\"" (String.escaped s)
+  else s
+
+
+(* ******************************************************************************** *)
+(* ************************************* core ************************************* *)
+(* ******************************************************************************** *)
+
+module Raw = struct
+  type cp =
+    | String of string
+    | Int of int
+    | Float of float
+    | List of cp list
+    | Tuple of cp list
+    | Section of (string * cp) list
+
+(* code generated by
+camlp4 pa_o.cmo pa_op.cmo pr_o.cmo -- -o config_file_parser.ml -impl config_file_parser.ml4
+Unreadable on purpose, edit the file config_file_parser.ml4 rather than editing this (huge) lines. Then manually copy-paste here the content of config_file_parser.ml.
+Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allow arrays, read comments...*)
+  module Parse = struct
+    let lexer = Genlex.make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","]
+    let rec file l (strm__ : _ Stream.t) = match try Some (ident strm__) with Stream.Failure -> None with Some id -> begin match Stream.peek strm__ with Some (Genlex.Kwd "=") -> Stream.junk strm__; let v = try value strm__ with Stream.Failure -> raise (Stream.Error "") in begin try file ((id, v) :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> raise (Stream.Error "") end | _ -> List.rev l
+    and value (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd "{") -> Stream.junk strm__; let v = try file [] strm__ with Stream.Failure -> raise (Stream.Error "") in begin match Stream.peek strm__ with Some (Genlex.Kwd "}") -> Stream.junk strm__; Section v | _ -> raise (Stream.Error "") end | Some (Genlex.Ident s) -> Stream.junk strm__; String s | Some (Genlex.String s) -> Stream.junk strm__; String s | Some (Genlex.Int i) -> Stream.junk strm__; Int i | Some (Genlex.Float f) -> Stream.junk strm__; Float f | Some (Genlex.Char c) -> Stream.junk strm__; String (String.make 1 c) | Some (Genlex.Kwd "[") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in List v | Some (Genlex.Kwd "(") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in Tuple v | _ -> raise Stream.Failure
+    and ident (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Ident s) -> Stream.junk strm__; s | Some (Genlex.String s) -> Stream.junk strm__; s | _ -> raise Stream.Failure
+    and list l (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd ";") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | Some (Genlex.Kwd ",") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match try Some (value strm__) with Stream.Failure -> None with Some v -> begin try list (v :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match Stream.peek strm__ with Some (Genlex.Kwd "]") -> Stream.junk strm__; List.rev l | Some (Genlex.Kwd ")") -> Stream.junk strm__; List.rev l | _ -> raise Stream.Failure
+  end
+
+  open Format
+  (* formating convention: the caller has to open the box, close it and flush the output *)
+  (* remarks on Format:
+     set_margin impose un appel à set_max_indent
+     sprintf et bprintf sont flushées à chaque appel*)
+
+  (* pretty print a Raw.cp *)
+  let rec save formatter = function
+    | String s -> fprintf formatter "%s" (safe_string s) (* How can I cut lines and *)
+    | Int i -> fprintf formatter "%d" i             (* print backslashes just before the \n? *)
+    | Float f -> fprintf formatter "%g" f
+    | List l ->
+        fprintf formatter "[@[<b0>";
+        list_iter_between
+          (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]")
+          (fun () -> fprintf formatter ";@ ")
+          l;
+        fprintf formatter "@]]"
+    | Tuple l ->
+        fprintf formatter "(@[<b0>";
+        list_iter_between
+          (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]")
+          (fun () -> fprintf formatter ",@ ")
+          l;
+        fprintf formatter "@])"
+    | Section l ->
+        fprintf formatter "{@;<0 2>@[<hv0>";
+        list_iter_between
+          (fun (name,value) ->
+             fprintf formatter "@[<hov2>%s =@ @[<b2>" name;
+             save formatter value;
+             fprintf formatter "@]@]";)
+          (fun () -> fprintf formatter "@;<2 0>")
+          l;
+        fprintf formatter "@]}"
+
+(*   let to_string r = save str_formatter r; flush_str_formatter () *)
+  let to_channel out_channel r =
+    let f = formatter_of_out_channel out_channel in
+    fprintf f "@[<b2>"; save f r; fprintf f "@]@?"
+
+  let of_string s = s |> Stream.of_string |> Parse.lexer |> Parse.value
+
+  let of_channel in_channel =
+    let result = in_channel |> Stream.of_channel |> Parse.lexer |> Parse.file [] in
+    close_in in_channel;
+    result
+end
+
+(* print the given string in a way compatible with Format.
+   Truncate the lines when needed, indent the newlines.*)
+let print_help formatter =
+  String.iter (function
+   | ' ' -> Format.pp_print_space formatter ()
+   | '\n' -> Format.pp_force_newline formatter ()
+   | c -> Format.pp_print_char formatter c)
+
+type 'a wrappers = {
+ to_raw : 'a -> Raw.cp;
+ of_raw : Raw.cp -> 'a}
+
+class type ['a] cp = object
+(*   method private to_raw = wrappers.to_raw *)
+(*   method private of_raw = wrappers.of_raw *)
+(*   method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set *)
+  method add_hook : ('a -> 'a -> unit) -> unit
+  method get : 'a
+  method get_default : 'a
+  method set : 'a -> unit
+  method reset : unit
+
+  method get_formatted : Format.formatter -> unit
+  method get_default_formatted : Format.formatter -> unit
+  method get_help_formatted : Format.formatter -> unit
+
+  method get_name : string list
+  method get_short_name : string option
+  method set_short_name : string -> unit
+  method get_help : string
+  method get_spec : Arg.spec
+
+  method set_raw : Raw.cp -> unit
+end
+
+type groupable_cp = <
+  get_name : string list;
+  get_short_name : string option;
+  get_help : string;
+
+  get_formatted : Format.formatter -> unit;
+  get_default_formatted : Format.formatter -> unit;
+  get_help_formatted : Format.formatter -> unit;
+  get_spec : Arg.spec;
+
+  reset : unit;
+  set_raw : Raw.cp -> unit; >
+
+exception Double_name
+exception Missing_cp of groupable_cp
+exception Wrong_type of (out_channel -> unit)
+
+(* Two exceptions to stop the iteration on queues. *)
+exception Found
+exception Found_cp of groupable_cp
+
+(* The data structure to store the cps.
+It's a tree, each node is a section, and a queue of sons with their name.
+Each leaf contains a cp. *)
+type 'a nametree =
+  | Immediate of 'a
+  | Subsection of ((string * 'a nametree) Queue.t)
+      (* this Queue must be nonempty for group.read.choose *)
+
+class group = object (self)
+  val mutable cps = Queue.create () (* hold all the added cps, in a nametree. *)
+
+  method add : 'a. 'a cp -> unit = fun original_cp ->
+    let cp = (original_cp :> groupable_cp) in
+    (* function called when we reach the end of the list cp#get_name. *)
+    let add_immediate name cp queue =
+      Queue.iter (fun (name',_) -> if name = name' then raise Double_name) queue;
+      Queue.push (name, Immediate cp) queue in
+    (* adds the cp with name [first_name::last_name] in section [section]. *)
+    let rec add_in_section section first_name last_name cp queue =
+      let sub_add = match last_name with (* what to do once we have find the correct section *)
+        | [] -> add_immediate first_name
+        | middle_name :: last_name -> add_in_section first_name middle_name last_name in
+      try
+        Queue.iter
+          (function
+             | name, Subsection subsection when name = section ->
+                 sub_add cp subsection; raise Found
+             | _ -> ())
+          queue;
+        let sub_queue = Queue.create () in
+        sub_add cp sub_queue;
+        Queue.push (section, Subsection sub_queue) queue
+      with Found -> () in
+    (match cp#get_name with
+      | [] -> failwith "empty name"
+      | first_name :: [] -> add_immediate first_name cp cps
+      | first_name :: middle_name :: last_name ->
+          add_in_section first_name middle_name last_name cp cps)
+
+  method write ?(with_help=true) filename =
+    let out_channel = open_out filename in
+    let formatter = Format.formatter_of_out_channel out_channel in
+    let print = Format.fprintf formatter in
+    print "@[<v>";
+    let rec save_queue formatter =
+      queue_iter_between
+        (fun (name,nametree) -> save_nametree name nametree)
+        (Format.pp_print_cut formatter)
+    and save_nametree name = function
+      | Immediate cp ->
+          if with_help && cp#get_help <> "" then
+            (print "@[<hov3>(* "; cp#get_help_formatted formatter;
+             print "@ *)@]@,");
+          Format.fprintf formatter "@[<hov2>%s =@ @[<b2>" (safe_string name);
+          cp#get_formatted formatter;
+          print "@]@]"
+      | Subsection queue ->
+          Format.fprintf formatter "%s = {@;<0 2>@[<v>" (safe_string name);
+          save_queue formatter queue;
+          print "@]@,}" in
+    save_queue formatter cps;
+    print "@]@."; close_out out_channel
+
+  method read ?obsoletes ?(no_default=false)
+      ?(on_type_error = fun groupable_cp raw_cp output filename in_channel ->
+          close_in in_channel;
+          Printf.eprintf
+            "Type error while loading configuration parameter %s from file %s.\n%!"
+            (String.concat "." groupable_cp#get_name) filename;
+          output stderr;
+          exit 1)
+      filename =
+    (* [filename] is created if it doesn't exist. In this case there is no need to read it. *)
+    match Sys.file_exists filename with false -> self#write filename | true ->
+    let in_channel = open_in filename in
+    (* what to do when a cp is missing: *)
+    let missing cp default = if no_default then raise (Missing_cp cp) else default in
+    (* returns a cp contained in the nametree queue, which must be nonempty *)
+    let choose queue =
+      let rec iter q = Queue.iter (function
+        | _, Immediate cp -> raise (Found_cp cp)
+        | _, Subsection q -> iter q) q in
+      try iter queue; failwith "choose" with Found_cp cp -> cp in
+    (* [set_and_remove raw_cps nametree] sets the cp of [nametree] to their value
+       defined in [raw_cps] and returns the remaining raw_cps. *)
+    let set_cp cp value =
+      try cp#set_raw value
+      with Wrong_type output -> on_type_error cp value output filename in_channel in
+    let rec set_and_remove raw_cps = function
+      | name, Immediate cp ->
+          (try list_assoc_remove name (fun value -> set_cp cp value; None) raw_cps
+           with Not_found -> missing cp raw_cps)
+      | name, Subsection queue ->
+          (try list_assoc_remove name
+             (function
+                | Raw.Section l ->
+                    (match remainings l queue with
+                       | [] -> None
+                       | l -> Some (Raw.Section l))
+                | r -> missing (choose queue) (Some r))
+             raw_cps
+           with Not_found -> missing (choose queue) raw_cps)
+    and remainings raw_cps queue = Queue.fold set_and_remove raw_cps queue in
+    let remainings = remainings (Raw.of_channel in_channel) cps in
+    (* Handling of cps defined in filename but not belonging to self. *)
+    if remainings <> [] then match obsoletes with
+      | Some filename ->
+          let out_channel =
+            open_out filename in
+(*             open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] 0o666 filename in *)
+          let formatter = Format.formatter_of_out_channel out_channel in
+          Format.fprintf formatter "@[<v>";
+          Raw.save formatter (Raw.Section remainings);
+          Format.fprintf formatter "@]@.";
+          close_out out_channel
+      | None -> ()
+
+  method command_line_args ~section_separator =
+    let print = Format.fprintf Format.str_formatter in (* shortcut *)
+    let result = ref [] in let push x = result := x :: !result in
+    let rec iter = function
+      | _, Immediate cp ->
+          let key = "-" ^ String.concat section_separator cp#get_name in
+          let spec = cp#get_spec in
+          let doc = (
+            print "@[<hv5>";
+            Format.pp_print_as Format.str_formatter (String.length key +3) "";
+            if cp#get_help <> ""
+            then (print "@,@[<b2>"; cp#get_help_formatted Format.str_formatter; print "@]@ ")
+            else print "@,";
+            print "@[<hv>@[current:@;<1 2>@[<hov1>"; cp#get_formatted Format.str_formatter;
+            print "@]@],@ @[default:@;<1 2>@[<b2>"; cp#get_default_formatted Format.str_formatter;
+            print "@]@]@]@]";
+            Format.flush_str_formatter ()) in
+          (match cp#get_short_name with
+            | None -> ()
+            | Some short_name -> push ("-" ^ short_name,spec,""));
+          push (key,spec,doc)
+      | _, Subsection queue -> Queue.iter iter queue in
+    Queue.iter iter cps;
+    List.rev !result
+end
+
+
+(* Given wrappers for the type 'a, cp_custom_type defines a class 'a cp. *)
+class ['a] cp_custom_type wrappers
+  ?group:(group:group option) name ?short_name default help =
+object (self)
+  method private to_raw = wrappers.to_raw
+  method private of_raw = wrappers.of_raw
+
+  val mutable value = default
+    (* output *)
+  method get = value
+  method get_default = default
+  method get_formatted formatter = self#get |> self#to_raw |> Raw.save formatter
+  method get_default_formatted formatter = self#get_default |> self#to_raw |> Raw.save formatter
+    (* input *)
+  method set v = let v' = value in value <- v; self#exec_hooks v' v
+  method set_raw v = self#of_raw v |> self#set
+  method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set
+  method reset = self#set self#get_default
+
+  (* name *)
+  val mutable shortname = short_name
+  method get_name = name
+  method get_short_name = shortname
+  method set_short_name s = shortname <- Some s
+
+  (* help *)
+  method get_help = help
+  method get_help_formatted formatter = print_help formatter self#get_help
+  method get_spec = Arg.String self#set_string
+
+  (* hooks *)
+  val mutable hooks = []
+  method add_hook f = hooks <- (f:'a->'a->unit) :: hooks
+  method private exec_hooks v' v = List.iter (fun f -> f v' v) hooks
+
+  initializer match group with Some g -> g#add (self :> 'a cp) | None -> ()
+end
+
+
+(* ******************************************************************************** *)
+(* ****************************** predefined classes ****************************** *)
+(* ******************************************************************************** *)
+
+let int_wrappers = {
+  to_raw = (fun v -> Raw.Int v);
+  of_raw = function
+    | Raw.Int v -> v
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.Int expected, got %a\n%!" Raw.to_channel r))}
+class int_cp ?group name ?short_name default help = object (self)
+  inherit [int] cp_custom_type int_wrappers ?group name ?short_name default help
+  method get_spec = Arg.Int self#set
+end
+
+let float_wrappers = {
+  to_raw = (fun v -> Raw.Float v);
+  of_raw = function
+    | Raw.Float v -> v
+    | Raw.Int v -> float v
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.Float expected, got %a\n%!" Raw.to_channel r))
+}
+class float_cp ?group name ?short_name default help = object (self)
+  inherit [float] cp_custom_type float_wrappers ?group name ?short_name default help
+  method get_spec = Arg.Float self#set
+end
+
+(* The Pervasives version is too restrictive *)
+let bool_of_string s =
+  match String.lowercase s with
+    | "false" | "no" | "n" | "0" -> false (* "0" and "1" aren't used. *)
+    | "true" | "yes" | "y" | "1" -> true
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.Bool expected, got %s\n%!" r))
+let bool_wrappers = {
+  to_raw = (fun v -> Raw.String (string_of_bool v));
+  of_raw = function
+    | Raw.String v -> bool_of_string v
+    | Raw.Int v -> v <> 0
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.Bool expected, got %a\n%!" Raw.to_channel r))
+}
+class bool_cp ?group name ?short_name default help = object (self)
+  inherit [bool] cp_custom_type bool_wrappers ?group name ?short_name default help
+  method get_spec = Arg.Bool self#set
+end
+
+let string_wrappers = {
+  to_raw = (fun v -> Raw.String v);
+  of_raw = function
+    | Raw.String v -> v
+    | Raw.Int v -> string_of_int v
+    | Raw.Float v -> string_of_float v
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.String expected, got %a\n%!" Raw.to_channel r))
+}
+class string_cp ?group name ?short_name default help = object (self)
+  inherit [string] cp_custom_type string_wrappers ?group name ?short_name default help
+  method private of_string s = s
+  method get_spec = Arg.String self#set
+end
+
+let list_wrappers wrappers = {
+  to_raw = (fun l -> Raw.List (List.map wrappers.to_raw l));
+  of_raw = function
+    | Raw.List l -> List.map wrappers.of_raw l
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.List expected, got %a\n%!" Raw.to_channel r))
+}
+class ['a] list_cp wrappers = ['a list] cp_custom_type (list_wrappers wrappers)
+
+let option_wrappers wrappers = {
+  to_raw = (function
+    | Some v -> wrappers.to_raw v
+    | None -> Raw.String "");
+  of_raw = function
+    | Raw.String s as v -> (
+        if s = "" || s = "None" then None
+        else if String.length s >= 5 && String.sub s 0 5 = "Some "
+        then Some (wrappers.of_raw (Raw.String (String.sub s 5 (String.length s -5))))
+        else Some (wrappers.of_raw v))
+    | r -> Some (wrappers.of_raw r)}
+class ['a] option_cp wrappers = ['a option] cp_custom_type (option_wrappers wrappers)
+
+let enumeration_wrappers enum =
+  let switched = List.map (fun (string,cons) -> cons,string) enum in
+  {to_raw = (fun v -> Raw.String (List.assq v switched));
+   of_raw = function
+     | Raw.String s ->
+         (try List.assoc s enum
+          with Not_found -> failwith (Printf.sprintf "%s isn't a known constructor" s))
+     | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw enumeration expected, got %a\n%!" Raw.to_channel r))
+}
+class ['a] enumeration_cp enum ?group name ?short_name default help = object (self)
+  inherit ['a] cp_custom_type (enumeration_wrappers enum)
+    ?group name ?short_name default help
+  method get_spec = Arg.Symbol (List.map fst enum, (fun s -> self#set (List.assoc s enum)))
+end
+
+let tuple2_wrappers wrapa wrapb = {
+  to_raw = (fun (a,b) -> Raw.Tuple [wrapa.to_raw a; wrapb.to_raw b]);
+  of_raw = function
+    | Raw.Tuple [a;b] -> wrapa.of_raw a, wrapb.of_raw b
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.Tuple 2 expected, got %a\n%!" Raw.to_channel r))
+}
+class ['a, 'b] tuple2_cp wrapa wrapb = ['a*'b] cp_custom_type (tuple2_wrappers wrapa wrapb)
+
+let tuple3_wrappers wrapa wrapb wrapc = {
+  to_raw = (fun (a,b,c) -> Raw.Tuple[wrapa.to_raw a; wrapb.to_raw b; wrapc.to_raw c]);
+  of_raw = function
+    | Raw.Tuple [a;b;c] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.Tuple 3 expected, got %a\n%!" Raw.to_channel r))
+}
+class ['a,'b,'c] tuple3_cp wrapa wrapb wrapc =
+  ['a*'b*'c] cp_custom_type (tuple3_wrappers wrapa wrapb wrapc)
+
+let tuple4_wrappers wrapa wrapb wrapc wrapd = {
+  to_raw=(fun (a,b,c,d)->Raw.Tuple[wrapa.to_raw a;wrapb.to_raw b;wrapc.to_raw c;wrapd.to_raw d]);
+  of_raw = function
+    | Raw.Tuple [a;b;c;d] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c, wrapd.of_raw d
+    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
+                                "Raw.Tuple 4 expected, got %a\n%!" Raw.to_channel r))
+}
+class ['a,'b,'c,'d] tuple4_cp wrapa wrapb wrapc wrapd =
+  ['a*'b*'c*'d] cp_custom_type (tuple4_wrappers wrapa wrapb wrapc wrapd)
+
+class string2_cp = [string,string] tuple2_cp string_wrappers string_wrappers
+(* class color_cp = string_cp *)
+class font_cp = string_cp
+class filename_cp = string_cp
+
+
+(* ******************************************************************************** *)
+(******************** Backward compatibility with module Options ****************** *)
+(* ******************************************************************************** *)
+
+type 'a option_class = 'a wrappers
+type 'a option_record = 'a cp
+type options_file = {mutable filename:string; group:group}
+
+let create_options_file filename = {filename = filename; group = new group}
+let set_options_file options_file filename = options_file.filename <- filename
+let load {filename=f; group = g} = g#read f
+let append {group=g} filename = g#read filename
+let save {filename=f; group = g} = g#write ~with_help:false f
+let save_with_help {filename=f; group = g} = g#write ~with_help:true f
+let define_option {group=group} name help option_class default =
+  (new cp_custom_type option_class ~group name default help)
+let option_hook cp f = cp#add_hook (fun _ _ -> f ())
+
+let  string_option = string_wrappers
+let   color_option = string_wrappers
+let    font_option = string_wrappers
+let     int_option =    int_wrappers
+let    bool_option =   bool_wrappers
+let   float_option =  float_wrappers
+let string2_option = tuple2_wrappers string_wrappers string_wrappers
+
+let option_option = option_wrappers
+let list_option = list_wrappers
+let sum_option = enumeration_wrappers
+let tuple2_option (a,b) = tuple2_wrappers a b
+let tuple3_option (a,b,c) = tuple3_wrappers a b c
+let tuple4_option (a,b,c,d) = tuple4_wrappers a b c d
+
+let ( !! ) cp = cp#get
+let ( =:= ) cp value = cp#set value
+
+let shortname cp = String.concat ":" cp#get_name
+let get_help cp = cp#get_help
+
+type option_value =
+  Module of option_module
+| StringValue of  string
+| IntValue of int
+| FloatValue of float
+| List of option_value list
+| SmallList of option_value list
+and option_module = (string * option_value) list
+
+let rec value_to_raw = function
+  | Module a -> Raw.Section (List.map (fun (name,value) -> name, value_to_raw value) a)
+  | StringValue a -> Raw.String a
+  | IntValue a -> Raw.Int a
+  | FloatValue a -> Raw.Float a
+  | List a -> Raw.List (List.map value_to_raw a)
+  | SmallList a -> Raw.Tuple (List.map value_to_raw a)
+let rec raw_to_value = function
+  | Raw.String a -> StringValue a
+  | Raw.Int a -> IntValue a
+  | Raw.Float a -> FloatValue a
+  | Raw.List a -> List (List.map raw_to_value a)
+  | Raw.Tuple a -> SmallList (List.map raw_to_value a)
+  | Raw.Section a -> Module (List.map (fun (name,value) -> name, raw_to_value value) a)
+
+let define_option_class _ of_option_value to_option_value =
+  {to_raw = (fun a -> a |> to_option_value |> value_to_raw);
+   of_raw = (fun a -> a |> raw_to_value |> of_option_value)}
+
+let to_value {to_raw = to_raw} a = a |> to_raw |> raw_to_value
+let from_value {of_raw = of_raw} a = a |> value_to_raw |> of_raw
+
+let of_value_w wrappers a = a |> value_to_raw |> wrappers.of_raw
+let to_value_w wrappers a = a |> wrappers.to_raw |> raw_to_value
+(* fancy indentation when finishing this stub code, not good style :-) *)
+let value_to_string : option_value -> string = of_value_w string_option
+let  string_to_value = to_value_w  string_option
+let value_to_int     = of_value_w     int_option
+let     int_to_value = to_value_w     int_option
+let value_to_bool    = of_value_w    bool_option
+let    bool_to_value = to_value_w    bool_option
+let value_to_float   = of_value_w   float_option
+let   float_to_value = to_value_w   float_option
+let value_to_string2 = of_value_w string2_option
+let string2_to_value = to_value_w string2_option
+let value_to_list of_value =
+  let wrapper = define_option_class "" of_value (fun _ -> failwith "value_to_list") in
+  of_value_w (list_option wrapper)
+let list_to_value to_value =
+  let wrapper = define_option_class "" (fun _ -> failwith "value_to_list") to_value in
+  to_value_w (list_option wrapper)
diff --git a/ide/utils/config_file.mli b/ide/utils/config_file.mli
new file mode 100644
index 00000000..b9c77682
--- /dev/null
+++ b/ide/utils/config_file.mli
@@ -0,0 +1,352 @@
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
+
+(**
+  This module implements a mechanism to handle configuration files.
+  A configuration file is defined as a set of [variable = value] lines,
+  where value can be
+    a simple string (types int, string, bool...),
+    a list of values between brackets (lists) or parentheses (tuples),
+    or a set of [variable = value] lines between braces.
+  The configuration file is automatically loaded and saved,
+  and configuration parameters are manipulated inside the program as easily as references.
+
+  Object implementation by Jean-Baptiste Rouquier.
+*)
+
+(** {1:lowlevelinterface Low level interface} *)
+(** Skip this section on a first reading... *)
+
+(** The type of cp freshly parsed from configuration file,
+not yet wrapped in their proper type. *)
+module Raw : sig
+  type cp =
+    | String of string (** base types, reproducing the tokens of Genlex *)
+    | Int of int
+    | Float of float
+    | List of cp list (** compound types *)
+    | Tuple of cp list
+    | Section of (string * cp) list
+
+  (** A parser. *)
+  val of_string : string -> cp
+
+  (** Used to print the values into a log file for instance. *)
+  val to_channel : out_channel -> cp -> unit
+end
+
+(** A type used to specialize polymorphics classes and define new classes.
+  {!Config_file.predefinedwrappers} are provided.
+ *)
+type 'a wrappers = { to_raw : 'a -> Raw.cp; of_raw : Raw.cp -> 'a; }
+
+(** An exception raised by {!Config_file.cp.set_raw}
+  when the argument doesn't have a suitable {!Config_file.Raw.cp} type.
+  The function explains the problem and flush the output.*)
+exception Wrong_type of (out_channel -> unit)
+
+(* (\** {2 Miscellaneous functions} *\) *)
+
+(* val bool_of_string : string -> bool *)
+
+(** {1 High level interface} *)
+(** {2 The two main classes} *)
+
+(** A Configuration Parameter, in short cp, ie
+  a value we can store in and read from a configuration file. *)
+class type ['a] cp = object
+  (** {1 Accessing methods} *)
+
+  method get : 'a
+  method set : 'a -> unit
+  method get_default : 'a
+  method get_help : string
+  method get_name : string list
+
+  (** Resets to the default value. *)
+  method reset : unit
+
+  (** {1 Miscellaneous} *)
+
+  (** All the hooks are executed each time the method set is called,
+    just after setting the new value.*)
+  method add_hook : ('a -> 'a -> unit) -> unit
+
+  (** Used to generate command line arguments in {!Config_file.group.command_line_args} *)
+  method set_short_name : string -> unit
+
+  (** [None] if no optional short_name was provided during object creation
+    and [set_short_name] was never called.*)
+  method get_short_name : string option
+
+  (** {1 Methods for internal use} *)
+
+  method get_formatted : Format.formatter -> unit
+  method get_default_formatted : Format.formatter -> unit
+  method get_help_formatted : Format.formatter -> unit
+
+  method get_spec : Arg.spec
+  method set_raw : Raw.cp -> unit
+end
+
+(** Unification over all possible ['a cp]:
+  contains the main methods of ['a cp] except the methods using the type ['a].
+  A [group] manipulates only [groupable_cp] for homogeneity. *)
+type groupable_cp = <
+  get_name : string list;
+  get_short_name : string option;
+  get_help : string;
+
+  get_formatted : Format.formatter -> unit;
+  get_default_formatted : Format.formatter -> unit;
+  get_help_formatted : Format.formatter -> unit;
+  get_spec : Arg.spec;
+
+  reset : unit;
+  set_raw : Raw.cp -> unit; >
+
+(** Raised in case a name is already used.
+  See {!Config_file.group.add} *)
+exception Double_name
+
+(** An exception possibly raised if we want to check that
+  every cp is defined in a configuration file.
+  See {!Config_file.group.read}.
+*)
+exception Missing_cp of groupable_cp
+
+(** A group of cps, that can be loaded and saved,
+or used to generate command line arguments.
+
+The basic usage is to have only one group and one configuration file,
+but this mechanism allows to have more,
+for instance to have another smaller group for the options to pass on the command line.
+*)
+class group : object
+  (** Adds a cp to the group.
+    Note that the type ['a] must be lost
+    to allow cps of different types to belong to the same group.
+    @raise Double_name if [cp#get_name] is already used. *)
+(*     method add : 'a cp -> 'a cp *)
+    method add : 'a cp -> unit
+
+    (**[write filename] saves all the cps into the configuration file [filename].*)
+    method write : ?with_help:bool -> string -> unit
+
+    (** [read filename] reads [filename]
+      and stores the values it specifies into the cps belonging to this group.
+      The file is created (and not read) if it doesn't exists.
+      In the default behaviour, no warning is issued
+      if not all cps are updated or if some values of [filename] aren't used.
+
+      If [obsoletes] is specified,
+      then prints in this file all the values that are
+      in [filename] but not in this group.
+      Those cps are likely to be erroneous or obsolete.
+      Opens this file only if there is something to write in it.
+
+      If [no_default] is [true], then raises [Missing_cp foo] if
+      the cp [foo] isn't defined in [filename] but belongs to this group.
+
+      [on_type_error groupable_cp value output filename in_channel]
+      is called if the file doesn't give suitable value
+      (string instead of int for instance, or a string not belonging to the expected enumeration)
+      for the cp [groupable_cp].
+      [value] is the value read from the file,
+      [output] is the argument of {!Config_file.Wrong_type},
+      [filename] is the same argument as the one given to read,
+      and [in_channel] refers to [filename] to allow a function to close it if needed.
+      Default behaviour is to print an error message and call [exit 1].
+*)
+    method read : ?obsoletes:string -> ?no_default:bool ->
+      ?on_type_error : (groupable_cp -> Raw.cp -> (out_channel -> unit) ->
+                          string -> in_channel -> unit) ->
+      string -> unit
+
+    (** Interface with module Arg.
+      @param section_separator the string used to concatenate the name of a cp,
+      to get the command line option name.
+      ["-"] is a good default.
+      @return a list that can be used with [Arg.parse] and [Arg.usage].*)
+    method command_line_args : section_separator:string -> (string * Arg.spec * string) list
+  end
+
+(** {2 Predefined cp classes} *)
+
+(** The last three non-optional arguments are always
+  [name] (of type string list), [default_value] and [help] (of type string).
+
+  [name] is the path to the cp: [["section";"subsection"; ...; "foo"]].
+  It can consists of a single element but must not be empty.
+
+  [short_name] will be added a "-" and used in
+  {!Config_file.group.command_line_args}.
+
+  [group], if provided, adds the freshly defined option to it
+  (something like [initializer group#add self]).
+
+  [help] needs not contain newlines, it will be automatically truncated where needed.
+  It is mandatory but can be [""].
+*)
+
+class int_cp : ?group:group -> string list -> ?short_name:string -> int -> string -> [int] cp
+class float_cp : ?group:group -> string list -> ?short_name:string -> float -> string -> [float] cp
+class bool_cp : ?group:group -> string list -> ?short_name:string -> bool -> string -> [bool] cp
+class string_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> [string] cp
+class ['a] list_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a list -> string -> ['a list] cp
+class ['a] option_cp : 'a wrappers -> ?group:group -> string list -> ?short_name:string -> 'a option -> string -> ['a option] cp
+class ['a] enumeration_cp : (string * 'a) list -> ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp
+class ['a, 'b] tuple2_cp : 'a wrappers -> 'b wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b -> string -> ['a * 'b] cp
+class ['a, 'b, 'c] tuple3_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c -> string -> ['a * 'b * 'c] cp
+class ['a, 'b, 'c, 'd] tuple4_cp : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ?group:group -> string list -> ?short_name:string -> 'a * 'b * 'c * 'd -> string -> ['a * 'b * 'c * 'd] cp
+class string2_cp : ?group:group -> string list -> ?short_name:string -> string * string -> string -> [string, string] tuple2_cp
+(* class color_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp *)
+class font_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp
+class filename_cp : ?group:group -> string list -> ?short_name:string -> string -> string -> string_cp
+
+(** {2:predefinedwrappers Predefined wrappers} *)
+
+val int_wrappers : int wrappers
+val float_wrappers : float wrappers
+val bool_wrappers : bool wrappers
+val string_wrappers : string wrappers
+val list_wrappers : 'a wrappers -> 'a list wrappers
+val option_wrappers : 'a wrappers -> 'a option wrappers
+
+(** If you have a [type suit = Spades | Hearts | Diamond | Clubs], then
+{[enumeration_wrappers ["spades",Spades; "hearts",Hearts; "diamond",Diamond; "clubs",Clubs]]}
+will allow you to use cp of this type.
+For sum types with not only constant constructors,
+you will need to define your own cp class. *)
+val enumeration_wrappers : (string * 'a) list -> 'a wrappers
+val tuple2_wrappers : 'a wrappers -> 'b wrappers -> ('a * 'b) wrappers
+val tuple3_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> ('a * 'b * 'c) wrappers
+val tuple4_wrappers : 'a wrappers -> 'b wrappers -> 'c wrappers -> 'd wrappers -> ('a * 'b * 'c * 'd) wrappers
+
+(** {2 Defining new cp classes} *)
+
+(** To define a new cp class, you just have to provide an implementation for the wrappers
+between your type [foo] and the type [Raw.cp].
+Once you have your wrappers [w], write
+{[class foo_cp = [foo] cp_custom_type w]}
+
+For further details, have a look at the commented .ml file,
+section "predefined cp classes".
+*)
+class ['a] cp_custom_type : 'a wrappers ->
+  ?group:group -> string list -> ?short_name:string -> 'a -> string -> ['a] cp
+
+
+(** {1 Backward compatibility}
+
+Deprecated.
+
+All the functions from the module Options are available, except:
+
+- [prune_file]: use [group#write ?obsoletes:"foo.ml"].
+- [smalllist_to_value], [smalllist_option]: use lists or tuples.
+- [get_class].
+- [class_hook]: hooks are local to a cp.
+  If you want hooks global to a class,
+  define a new class that inherit from {!Config_file.cp_custom_type}.
+- [set_simple_option], [get_simple_option], [simple_options], [simple_args]:
+  use {!Config_file.group.write}.
+- [set_option_hook]: use {!Config_file.cp.add_hook}.
+- [set_string_wrappers]: define a new class with {!Config_file.cp_custom_type}.
+
+The old configurations files are readable by this module.
+*)
+
+
+
+
+
+(**/**)
+type 'a option_class
+type 'a option_record
+type options_file
+
+val create_options_file : string -> options_file
+val set_options_file : options_file -> string -> unit
+val load : options_file -> unit
+val append : options_file -> string -> unit
+val save : options_file -> unit
+val save_with_help : options_file -> unit
+(* val define_option : options_file -> *)
+(*   string list ->  string -> 'a option_class -> 'a -> 'a option_record *)
+val option_hook : 'a option_record -> (unit -> unit) -> unit
+
+val string_option : string option_class
+val color_option : string option_class
+val font_option : string option_class
+val int_option : int option_class
+val bool_option : bool option_class
+val float_option : float option_class
+val string2_option : (string * string) option_class
+
+val option_option : 'a option_class -> 'a option option_class
+val list_option : 'a option_class -> 'a list option_class
+val sum_option : (string * 'a) list -> 'a option_class
+val tuple2_option :
+  'a option_class * 'b option_class -> ('a * 'b) option_class
+val tuple3_option : 'a option_class * 'b option_class * 'c option_class ->
+  ('a * 'b * 'c) option_class
+val tuple4_option :
+    'a option_class * 'b option_class * 'c option_class * 'd option_class ->
+  ('a * 'b * 'c * 'd) option_class
+
+val ( !! ) : 'a option_record -> 'a
+val ( =:= ) : 'a option_record -> 'a -> unit
+val shortname : 'a option_record -> string
+val get_help : 'a option_record -> string
+
+type option_value =
+  Module of option_module
+| StringValue of  string
+| IntValue of int
+| FloatValue of float
+| List of option_value list
+| SmallList of option_value list
+and option_module = (string * option_value) list
+
+val define_option_class :
+  string -> (option_value -> 'a) -> ('a -> option_value) -> 'a option_class
+
+val to_value : 'a option_class -> 'a -> option_value
+val from_value : 'a option_class -> option_value -> 'a
+
+val value_to_string : option_value -> string
+val string_to_value : string -> option_value
+val value_to_int : option_value -> int
+val int_to_value : int -> option_value
+val bool_of_string : string -> bool
+val value_to_bool : option_value -> bool
+val bool_to_value : bool -> option_value
+val value_to_float : option_value -> float
+val float_to_value : float -> option_value
+val value_to_string2 : option_value -> string * string
+val string2_to_value : string * string -> option_value
+val value_to_list : (option_value -> 'a) -> option_value -> 'a list
+val list_to_value : ('a -> option_value) -> 'a list -> option_value
diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml
index de6a7c57..275d8616 100644
--- a/ide/utils/configwin.ml
+++ b/ide/utils/configwin.ml
@@ -1,26 +1,27 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
 
 type parameter_kind = Configwin_types.parameter_kind
 
@@ -35,10 +36,16 @@ type return_button =
   | Return_ok
   | Return_cancel
 
-module KeyOption = Configwin_types.KeyOption
+let string_to_key = Configwin_types.string_to_key
+let key_to_string = Configwin_types.key_to_string
+let key_cp_wrapper = Configwin_types.key_cp_wrapper
+class key_cp = Configwin_types.key_cp
+
 
 let string = Configwin_ihm.string
+let custom_string = Configwin_ihm.custom_string
 let text = Configwin_ihm.text
+let custom_text = Configwin_ihm.custom_text
 let strings = Configwin_ihm.strings
 let list = Configwin_ihm.list
 let bool = Configwin_ihm.bool
@@ -53,20 +60,20 @@ let hotkey = Configwin_ihm.hotkey
 let modifiers = Configwin_ihm.modifiers
 let html = Configwin_ihm.html
 
-let edit 
+let edit
     ?(apply=(fun () -> ()))
-    title ?(width=400) ?(height=400) 
-    conf_struct_list = 
+    title ?(width=400) ?(height=400)
+    conf_struct_list =
   Configwin_ihm.edit ~with_apply: true ~apply title ~width ~height conf_struct_list
 
 let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ())
 
-let simple_edit 
+let simple_edit
     ?(apply=(fun () -> ()))
-    title ?width ?height 
+    title ?width ?height
     param_list = Configwin_ihm.simple_edit ~with_apply: true ~apply title ?width ?height param_list
 
-let simple_get = Configwin_ihm.simple_edit 
+let simple_get = Configwin_ihm.simple_edit
     ~with_apply: false ~apply: (fun () -> ())
 
 let box = Configwin_ihm.box
diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli
index 078befc6..2d4dd4a7 100644
--- a/ide/utils/configwin.mli
+++ b/ide/utils/configwin.mli
@@ -1,26 +1,27 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
 
 (** This module is the interface of the Configwin library. *)
 
@@ -30,8 +31,8 @@
 type parameter_kind;;
 
 (** This type represents the structure of the configuration window. *)
-type configuration_structure = 
-  | Section of string * parameter_kind list 
+type configuration_structure =
+  | Section of string * parameter_kind list
        (** label of the section, parameters *)
   | Section_list of string * configuration_structure list
        (** label of the section, list of the sub sections *)
@@ -50,13 +51,20 @@ type return_button =
 	 on the apply button.*)
 
 
-(** {2 The key option class (to use with the {!Uoptions} library)} *)
+(** {2 The key option class (to use with the {!Config_file} library)} *)
 
-module KeyOption : sig
-  val string_to_key : string -> (Gdk.Tags.modifier list * int) 
-  val key_to_string : (Gdk.Tags.modifier list * int) -> string
-  val t : (Gdk.Tags.modifier list * int) Uoptions.option_class
-end
+val string_to_key : string -> Gdk.Tags.modifier list * int
+
+val key_to_string : Gdk.Tags.modifier list * int -> string
+
+val key_cp_wrapper : (Gdk.Tags.modifier list * int) Config_file.wrappers
+
+class key_cp :
+  ?group:Config_file.group ->
+  string list ->
+  ?short_name:string ->
+  Gdk.Tags.modifier list * int ->
+  string -> [Gdk.Tags.modifier list * int] Config_file.cp_custom_type
 
 (** {2 Functions to create parameters} *)
 
@@ -69,6 +77,13 @@ end
 val string : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?f: (string -> unit) -> string -> string -> parameter_kind
 
+(** Same as {!Configwin.string} but for values which are not strings. *)
+val custom_string : ?editable: bool -> ?expand: bool -> ?help: string ->
+  ?f: ('a -> unit) ->
+    to_string: ('a -> string) ->
+      of_string: (string -> 'a) ->
+	string -> 'a -> parameter_kind
+
 (** [bool label value] creates a boolean parameter.
    @param editable indicate if the value is editable (default is [true]).
    @param help an optional help message.
@@ -88,12 +103,12 @@ val bool : ?editable: bool -> ?help: string ->
    always returning false.
 *)
 val strings : ?editable: bool -> ?help: string ->
-  ?f: (string list -> unit) -> 
+  ?f: (string list -> unit) ->
     ?eq: (string -> string -> bool) ->
-      ?add: (unit -> string list) -> 
+      ?add: (unit -> string list) ->
 	string -> string list -> parameter_kind
-	
-(** [list label f_strings value] creates a list parameter. 
+
+(** [list label f_strings value] creates a list parameter.
    [f_strings] is a function taking a value and returning a list
    of strings to display it. The list length should be the same for
    any value, and the same as the titles list length. The [value]
@@ -117,15 +132,15 @@ val strings : ?editable: bool -> ?help: string ->
    no color for any element.
 *)
 val list : ?editable: bool -> ?help: string ->
-  ?f: ('a list -> unit) -> 
+  ?f: ('a list -> unit) ->
     ?eq: ('a -> 'a -> bool) ->
       ?edit: ('a -> 'a) ->
-	?add: (unit -> 'a list) -> 
+	?add: (unit -> 'a list) ->
 	  ?titles: string list ->
 	    ?color: ('a -> string option) ->
-	      string -> 
+	      string ->
 		('a -> string list) ->
-		  'a list -> 
+		  'a list ->
 		    parameter_kind
 
 (** [color label value] creates a color parameter.
@@ -134,7 +149,7 @@ val list : ?editable: bool -> ?help: string ->
    @param help an optional help message.
    @param f the function called to apply the value (default function does nothing).
 *)
-val color : ?editable: bool -> ?expand: bool -> ?help: string -> 
+val color : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?f: (string -> unit) -> string -> string -> parameter_kind
 
 (** [font label value] creates a font parameter.
@@ -143,7 +158,7 @@ val color : ?editable: bool -> ?expand: bool -> ?help: string ->
    @param help an optional help message.
    @param f the function called to apply the value (default function does nothing).
 *)
-val font : ?editable: bool -> ?expand: bool -> ?help: string -> 
+val font : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?f: (string -> unit) -> string -> string -> parameter_kind
 
 (** [combo label choices value] creates a combo parameter.
@@ -156,8 +171,8 @@ val font : ?editable: bool -> ?expand: bool -> ?help: string ->
    @param blank_allowed indicate if the empty selection [""] is accepted
    (default is [false]).
 *)
-val combo : ?editable: bool -> ?expand: bool -> ?help: string -> 
-  ?f: (string -> unit) -> 
+val combo : ?editable: bool -> ?expand: bool -> ?help: string ->
+  ?f: (string -> unit) ->
     ?new_allowed: bool -> ?blank_allowed: bool ->
       string -> string list -> string -> parameter_kind
 
@@ -167,14 +182,21 @@ val combo : ?editable: bool -> ?expand: bool -> ?help: string ->
    @param help an optional help message.
    @param f the function called to apply the value (default function does nothing).
 *)
-val text : ?editable: bool -> ?expand: bool -> ?help: string -> 
+val text : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?f: (string -> unit) -> string -> string -> parameter_kind
 
-(** Same as {!Configwin.text} but html bindings are available 
-   in the text widget. Use the [configwin_html_config] utility 
+(** Same as {!Configwin.text} but for values which are not strings. *)
+val custom_text : ?editable: bool -> ?expand: bool -> ?help: string ->
+  ?f: ('a -> unit) ->
+    to_string: ('a -> string) ->
+      of_string: (string -> 'a) ->
+	string -> 'a -> parameter_kind
+
+(** Same as {!Configwin.text} but html bindings are available
+   in the text widget. Use the [configwin_html_config] utility
    to edit your bindings.
 *)
-val html : ?editable: bool -> ?expand: bool -> ?help: string -> 
+val html : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?f: (string -> unit) -> string -> string -> parameter_kind
 
 (** [filename label value] creates a filename parameter.
@@ -194,8 +216,8 @@ val filename : ?editable: bool -> ?expand: bool -> ?help: string ->
    is [Pervasives.(=)]. If you want to allow doubles in the list, give a function
    always returning false.
 *)
-val filenames : ?editable: bool -> ?help: string -> 
-  ?f: (string list -> unit) -> 
+val filenames : ?editable: bool -> ?help: string ->
+  ?f: (string list -> unit) ->
     ?eq: (string -> string -> bool) ->
       string -> string list -> parameter_kind
 
@@ -208,8 +230,8 @@ val filenames : ?editable: bool -> ?help: string ->
    is a tupe [(day,month,year)], where [month] is between [0] and [11]. The default
    function creates the string [year/month/day].
 *)
-val date : ?editable: bool -> ?expand: bool -> ?help: string -> 
-  ?f: ((int * int * int) -> unit) -> 
+val date : ?editable: bool -> ?expand: bool -> ?help: string ->
+  ?f: ((int * int * int) -> unit) ->
     ?f_string: ((int * int * int -> string)) ->
       string -> (int * int * int) -> parameter_kind
 
@@ -221,7 +243,7 @@ val date : ?editable: bool -> ?expand: bool -> ?help: string ->
    @param f the function called to apply the value (default function does nothing).
 *)
 val hotkey : ?editable: bool -> ?expand: bool -> ?help: string ->
-  ?f: ((Gdk.Tags.modifier list * int) -> unit) -> 
+  ?f: ((Gdk.Tags.modifier list * int) -> unit) ->
     string -> (Gdk.Tags.modifier list * int) -> parameter_kind
 
 val modifiers : ?editable: bool -> ?expand: bool -> ?help: string ->
@@ -229,7 +251,6 @@ val modifiers : ?editable: bool -> ?expand: bool -> ?help: string ->
   ?f: (Gdk.Tags.modifier list -> unit) -> 
     string -> Gdk.Tags.modifier list -> parameter_kind
 
-
 (** [custom box f expand] creates a custom parameter, with
    the given [box], the [f] function is called when the user
    wants to apply his changes, and [expand] indicates if the box
@@ -241,8 +262,8 @@ val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_
 (** {2 Functions creating configuration windows and boxes} *)
 
 (** This function takes a configuration structure and creates a window
-   to configure the various parameters. 
-   @param apply this function is called when the apply button is clicked, after 
+   to configure the various parameters.
+   @param apply this function is called when the apply button is clicked, after
    giving new values to parameters.
 *)
 val edit :
@@ -263,9 +284,9 @@ val get :
   configuration_structure list ->
   return_button
 
-(** This function takes a list of parameter specifications and 
+(** This function takes a list of parameter specifications and
    creates a window to configure the various parameters.
-   @param apply this function is called when the apply button is clicked, after 
+   @param apply this function is called when the apply button is clicked, after
    giving new values to parameters.*)
 val simple_edit :
   ?apply: (unit -> unit) ->
@@ -274,7 +295,7 @@ val simple_edit :
   ?height:int ->
   parameter_kind list -> return_button
 
-(** This function takes a list of parameter specifications and 
+(** This function takes a list of parameter specifications and
    creates a window to configure the various parameters,
    without Apply button.*)
 val simple_get :
@@ -284,17 +305,14 @@ val simple_get :
   parameter_kind list -> return_button
 
 (** Create a [GPack.box] with the list of given parameters,
-   and the given list of buttons (defined by their label and callback).
-   Before calling the callback of a button, the [apply] function
-   of each parameter is called.
+   Return the box and the function to call to apply new values to parameters.
 *)
-val box : parameter_kind list -> 
-  (string * (unit -> unit)) list -> GPack.box
+val box : parameter_kind list -> GData.tooltips -> GPack.box * (unit -> unit)
 
 (** Create a [GPack.box] with the list of given configuration structure list,
    and the given list of buttons (defined by their label and callback).
    Before calling the callback of a button, the [apply] function
    of each parameter is called.
 *)
-val tabbed_box : configuration_structure list -> 
-  (string * (unit -> unit)) list -> GPack.box
+val tabbed_box : configuration_structure list ->
+  (string * (unit -> unit)) list -> GData.tooltips -> GPack.box
diff --git a/ide/utils/configwin_html_config.ml b/ide/utils/configwin_html_config.ml
index fc2913d1..fe39de0a 100644
--- a/ide/utils/configwin_html_config.ml
+++ b/ide/utils/configwin_html_config.ml
@@ -1,38 +1,39 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
 
 (** The HTML editor bindings configurator. *)
 
 module C = Configwin_ihm
 open Configwin_types
-open Uoptions
+open Config_file
 
-let simple_get = C.simple_edit 
+let simple_get = C.simple_edit
     ~with_apply: false ~apply: (fun () -> ())
 
 let params_hb hb =
-  let p_key = C.hotkey 
+  let p_key = C.hotkey
       ~f: (fun k -> hb.html_key <- k) Configwin_messages.mKey
       hb.html_key
   in
@@ -53,10 +54,10 @@ let edit_hb hb =
   hb
 
 let add () =
-  let hb = { html_key = KeyOption.string_to_key "C-a" ;
+  let hb = { html_key = Configwin_types.string_to_key "C-a" ;
 	     html_begin = "" ;
 	     html_end = "" ;
-	   } 
+	   }
   in
   match simple_get Configwin_messages.mAdd (params_hb hb) with
     Return_ok -> [hb]
@@ -66,18 +67,18 @@ let main () =
   ignore (GMain.Main.init ());
   let (ini, bindings) = C.html_config_file_and_option () in
   let param = C.list
-      ~f: (fun l -> bindings =:= l ; Uoptions.save_with_help ini)
+      ~f: (fun l -> bindings#set l ; ini#write Configwin_ihm.file_html_config )
       ~eq: (fun hb1 hb2 -> hb1.html_key = hb2.html_key)
       ~edit: edit_hb
       ~add: add
       ~titles: [ Configwin_messages.mKey ; Configwin_messages.html_begin ;
 		 Configwin_messages.html_end ]
       Configwin_messages.shortcuts
-      (fun hb -> [ KeyOption.key_to_string hb.html_key ;
+      (fun hb -> [ Configwin_types.key_to_string hb.html_key ;
 		   hb.html_begin ; hb.html_end ])
-      !!bindings
+      bindings#get
   in
-  ignore (simple_get ~width: 300 ~height: 400 
+  ignore (simple_get ~width: 300 ~height: 400
 	    Configwin_messages.html_config [param])
 
 let _ = main ()
diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml
index 03ca706c..e9ba9789 100644
--- a/ide/utils/configwin_ihm.ml
+++ b/ide/utils/configwin_ihm.ml
@@ -1,68 +1,73 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
-
-(** This module contains the gui functions of Confgiwin.*)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
+
+(** This module contains the gui functions of Configwin.*)
 
 open Configwin_types
 
-module O = Uoptions
+module O = Config_file
 
-
-(** The file where the html config is. *)
 let file_html_config = Filename.concat Configwin_messages.home ".configwin_html"
-  
-(** Return the ini file for the html config, and the option for bindings. *)
+
+let debug = false
+let dbg = if debug then prerr_endline else (fun _ -> ())
+
+(** Return the config group for the html config file,
+   and the option for bindings. *)
 let html_config_file_and_option () =
-  let ini = O.create_options_file file_html_config in
-  let bindings = O.define_option ini ["bindings"]
-      ""
-      (O.list_option Configwin_types.Html_binding.t)
-      [ { html_key = KeyOption.string_to_key "A-b" ;
+  let ini = new O.group in
+  let bindings = new O.list_cp
+      Configwin_types.htmlbinding_cp_wrapper
+      ~group: ini
+      ["bindings"]
+      ~short_name: "bd"
+      [ { html_key = Configwin_types.string_to_key "A-b" ;
 	  html_begin = "<b>";
 	  html_end = "</b>" ;
 	} ;
-	{ html_key = KeyOption.string_to_key "A-i" ;
+	{ html_key = Configwin_types.string_to_key "A-i" ;
 	  html_begin = "<i>";
 	  html_end = "</i>" ;
-	} 
-      ]	
+	}
+      ]
+      ""
   in
-  O.load ini ;
+  ini#read file_html_config ;
   (ini, bindings)
 
-
 (** This variable contains the last directory where the user selected a file.*)
 let last_dir = ref "";;
 
 (** This function allows the user to select a file and returns the
-   selected file name. An optional function allows to change the 
+   selected file name. An optional function allows to change the
    behaviour of the ok button.
    A VOIR : mutli-selection ? *)
 let select_files ?dir
     ?(fok : (string -> unit) option)
     the_title =
-  let files = ref ([] : string list) in 
+  let files = ref ([] : string list) in
   let fs = GWindow.file_selection ~modal:true
       ~title: the_title () in
   (* we set the previous directory, if no directory is given *)
@@ -78,7 +83,7 @@ let select_files ?dir
       let _ = fs#set_filename !last_dir in
       ()
   );
- 
+
   let _ = fs # connect#destroy ~callback: GMain.Main.quit in
   let _ = fs # ok_button # connect#clicked ~callback:
       (match fok with
@@ -134,52 +139,55 @@ let select_date title (day,mon,year) =
    one to add items and one to remove the selected items.
    The class takes in parameter a function used to add items and
    a string list ref which is used to store the content of the clist.
-   At last, a title for the frame  is also in parameter, so that     
+   At last, a title for the frame  is also in parameter, so that
    each instance of the class creates a frame. *)
-class ['a] list_selection_box (listref : 'a list ref) 
+class ['a] list_selection_box
+    (listref : 'a list ref)
     titles_opt
     help_opt
     f_edit_opt
     f_strings
     f_color
     (eq : 'a -> 'a -> bool)
-    add_function title editable =
+    add_function title editable
+    (tt:GData.tooltips)
+    =
+  let _ = dbg "list_selection_box" in
   let wev = GBin.event_box () in
   let wf = GBin.frame ~label: title ~packing: wev#add () in
   let hbox = GPack.hbox ~packing: wf#add () in
   (* the scroll window and the clist *)
   let wscroll = GBin.scrolled_window
-      	~vpolicy: `AUTOMATIC
-	~hpolicy: `AUTOMATIC
-      ~packing: (hbox#pack ~expand: true) () 
+      ~vpolicy: `AUTOMATIC
+      ~hpolicy: `AUTOMATIC
+      ~packing: (hbox#pack ~expand: true) ()
   in
   let wlist = match titles_opt with
-    None -> 
+    None ->
       GList.clist ~selection_mode: `MULTIPLE
 	~titles_show: false
 	~packing: wscroll#add ()
-  | Some l -> 
-      GList.clist ~selection_mode: `MULTIPLE 
+  | Some l ->
+      GList.clist ~selection_mode: `MULTIPLE
 	~titles: l
 	~titles_show: true
 	~packing: wscroll#add ()
   in
-  let _ = 
+  let _ =
     match help_opt with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (wf#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wev#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wev#coerce
   in  (* the vbox for the buttons *)
   let vbox_buttons = GPack.vbox () in
-  let _ = 
+  let _ =
     if editable then
       let _ = hbox#pack ~expand: false vbox_buttons#coerce in
       ()
     else
-      () 
+      ()
   in
+  let _ = dbg "list_selection_box: wb_add" in
   let wb_add = GButton.button
       ~label: Configwin_messages.mAdd
       ~packing: (vbox_buttons#pack ~expand:false ~padding:2)
@@ -203,6 +211,7 @@ class ['a] list_selection_box (listref : 'a list ref)
       ~packing: (vbox_buttons#pack ~expand:false ~padding:2)
       ()
   in
+  let _ = dbg "list_selection_box: object(self)" in
   object (self)
     (** the list of selected rows *)
     val mutable list_select = []
@@ -216,17 +225,17 @@ class ['a] list_selection_box (listref : 'a list ref)
       (* insert the elements in the clist *)
       wlist#freeze ();
       wlist#clear ();
-      List.iter 
-	(fun ele -> 
+      List.iter
+	(fun ele ->
 	  ignore (wlist#append (f_strings ele));
 	  match f_color ele with
 	    None -> ()
 	  | Some c ->
 	      try wlist#set_row ~foreground: (`NAME c) (wlist#rows - 1)
 	      with _ -> ()
-	) 
+	)
 	!listref;
-      
+
       (match titles_opt with
 	None -> wlist#columns_autosize ()
       |	Some _ -> GToolbox.autosize_clist wlist);
@@ -280,10 +289,10 @@ class ['a] list_selection_box (listref : 'a list ref)
 
     initializer
       (** create the functions called when the buttons are clicked *)
-      let f_add () = 
+      let f_add () =
         (* get the files to add with the function provided *)
         let l = add_function () in
-        (* remove from the list the ones which are already in 
+        (* remove from the list the ones which are already in
            the listref, using the eq predicate *)
         let l2 = List.fold_left
             (fun acc -> fun ele ->
@@ -293,7 +302,7 @@ class ['a] list_selection_box (listref : 'a list ref)
                 acc @ [ele])
             !listref
             l
-        in    
+        in
         self#update l2
       in
       let f_remove () =
@@ -309,14 +318,19 @@ class ['a] list_selection_box (listref : 'a list ref)
         let new_list = iter 0 !listref in
         self#update new_list
       in
+      let _ = dbg "list_selection_box: connecting wb_add" in
       (* connect the functions to the buttons *)
       ignore (wb_add#connect#clicked f_add);
+      let _ = dbg "list_selection_box: connecting wb_remove" in
       ignore (wb_remove#connect#clicked f_remove);
+      let _ = dbg "list_selection_box: connecting wb_up" in
       ignore (wb_up#connect#clicked (fun () -> self#up_selected));
       (
        match f_edit_opt with
 	 None -> ()
-       | Some f -> ignore (wb_edit#connect#clicked (fun () -> self#edit_selected f))
+       | Some f ->
+	   let _ = dbg "list_selection_box: connecting wb_edit" in
+	   ignore (wb_edit#connect#clicked (fun () -> self#edit_selected f))
       );
       (* connect the selection and deselection of items in the clist *)
       let f_select ~row ~column ~event =
@@ -335,7 +349,9 @@ class ['a] list_selection_box (listref : 'a list ref)
             ()
       in
       (* connect the select and deselect events *)
+      let _ = dbg "list_selection_box: connecting select_row" in
       ignore(wlist#connect#select_row f_select);
+      let _ = dbg "list_selection_box: connecting unselect_row" in
       ignore(wlist#connect#unselect_row f_unselect);
 
       (* initialize the clist with the listref *)
@@ -344,7 +360,8 @@ class ['a] list_selection_box (listref : 'a list ref)
 
 
 (** This class is used to build a box for a string parameter.*)
-class string_param_box param =
+class string_param_box param (tt:GData.tooltips) =
+  let _ = dbg "string_param_box" in
   let hbox = GPack.hbox () in
   let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
   let wl = GMisc.label ~text: param.string_label ~packing: wev#add () in
@@ -353,22 +370,20 @@ class string_param_box param =
       ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2)
       ()
   in
-  let _ = 
+  let _ =
     match param.string_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wev#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wev#coerce
   in
-  let _ = we#set_text param.string_value in
+  let _ = we#set_text (param.string_to_string param.string_value) in
 
   object (self)
     (** This method returns the main box ready to be packed. *)
     method box = hbox#coerce
     (** This method applies the new value of the parameter. *)
     method apply =
-      let new_value = we#text in
+      let new_value = param.string_of_string we#text in
       if new_value <> param.string_value then
 	let _ = param.string_f_apply new_value in
 	param.string_value <- new_value
@@ -377,24 +392,23 @@ class string_param_box param =
   end ;;
 
 (** This class is used to build a box for a combo parameter.*)
-class combo_param_box param =
+class combo_param_box param (tt:GData.tooltips) =
+  let _ = dbg "combo_param_box" in
   let hbox = GPack.hbox () in
   let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
   let wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in
   let wc = GEdit.combo
       ~popdown_strings: param.combo_choices
       ~value_in_list: (not param.combo_new_allowed)
-(*      ~ok_if_empty: param.combo_blank_allowed*)
+      (* ~allow_empty: param.combo_blank_allowed *)
       ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
       ()
   in
-  let _ = 
+  let _ =
     match param.combo_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback:tooltips#destroy);
-	tooltips#set_tip wev#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wev#coerce
   in
   let _ = wc#entry#set_editable param.combo_editable in
   let _ = wc#entry#set_text param.combo_value in
@@ -413,8 +427,9 @@ class combo_param_box param =
   end ;;
 
 (** Class used to pack a custom box. *)
-class custom_param_box param =
-  let top = 
+class custom_param_box param (tt:GData.tooltips) =
+  let _ = dbg "custom_param_box" in
+  let top =
     match param.custom_framed with
       None -> param.custom_box#coerce
     | Some l ->
@@ -428,40 +443,39 @@ class custom_param_box param =
   end
 
 (** This class is used to build a box for a color parameter.*)
-class color_param_box param =
+class color_param_box param (tt:GData.tooltips) =
+  let _ = dbg "color_param_box" in
   let v = ref param.color_value in
   let hbox = GPack.hbox () in
-  let wb = GButton.button ~label: param.color_label 
-      ~packing: (hbox#pack ~expand: false ~padding: 2) () 
+  let wb = GButton.button ~label: param.color_label
+      ~packing: (hbox#pack ~expand: false ~padding: 2) ()
   in
-  let w_test = GMisc.arrow 
+  let w_test = GMisc.arrow
       ~kind: `RIGHT
       ~shadow: `OUT
       ~width: 20
       ~height: 20
       ~packing: (hbox#pack ~expand: false ~padding: 2 )
-      () 
+      ()
   in
   let we = GEdit.entry
       ~editable: param.color_editable
       ~packing: (hbox#pack ~expand: param.color_expand ~padding: 2)
       ()
   in
-  let _ = 
+  let _ =
     match param.color_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wb#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wb#coerce
   in
   let set_color s =
     let style = w_test#misc#style#copy in
     (
-     try style#set_bg [ (`NORMAL, `NAME s) ; ]
+     try style#set_fg [ (`NORMAL, `NAME s) ; ]
      with _ -> ()
     );
-    w_test#misc#set_style style 
+    w_test#misc#set_style style;
   in
   let _ = set_color !v in
   let _ = we#set_text !v in
@@ -476,26 +490,25 @@ class color_param_box param =
     let wb_cancel = dialog#cancel_button in
     let _ = dialog#connect#destroy GMain.Main.quit in
     let _ = wb_ok#connect#clicked
-	(fun () -> 
-	  (* let color = dialog#colorsel#get_color in
-	  let r = int_of_float (ceil (color.Gtk.red *. 255.)) in
-	  let g = int_of_float (ceil (color.Gtk.green *. 255.)) in
-	  let b = int_of_float (ceil (color.Gtk.blue *. 255.)) in
-	  let s = Printf.sprintf "#%2X%2X%2X" r g b in
-	  let _ = 
+	(fun () ->
+(*	  let color = dialog#colorsel#color in
+	  let r = (Gdk.Color.red color) in
+	  let g = (Gdk.Color.green color)in
+	  let b = (Gdk.Color.blue color) in
+	  let s = Printf.sprintf "#%4X%4X%4X" r g b in
+	  let _ =
 	    for i = 1 to (String.length s) - 1 do
 	      if s.[i] = ' ' then s.[i] <- '0'
 	    done
 	  in
-	  we#set_text s ;
-	  set_color s;*)
+	  we#set_text s ; *)
 	  dialog#destroy ()
 	)
     in
     let _ = wb_cancel#connect#clicked dialog#destroy in
     GMain.Main.main ()
   in
-  let _ = 
+  let _ =
     if param.color_editable then ignore (wb#connect#clicked f_sel)
   in
 
@@ -510,27 +523,30 @@ class color_param_box param =
 	param.color_value <- new_value
       else
 	()
+
+    initializer
+      ignore (we#connect#changed (fun () -> set_color we#text));
+
   end ;;
 
 (** This class is used to build a box for a font parameter.*)
-class font_param_box param =
+class font_param_box param (tt:GData.tooltips) =
+  let _ = dbg "font_param_box" in
   let v = ref param.font_value in
   let hbox = GPack.hbox () in
-  let wb = GButton.button ~label: param.font_label 
-      ~packing: (hbox#pack ~expand: false ~padding: 2) () 
+  let wb = GButton.button ~label: param.font_label
+      ~packing: (hbox#pack ~expand: false ~padding: 2) ()
   in
   let we = GEdit.entry
       ~editable: false
       ~packing: (hbox#pack ~expand: param.font_expand ~padding: 2)
       ()
   in
-  let _ = 
+  let _ =
     match param.font_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wb#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wb#coerce
   in
   let set_entry_font font_opt =
     match font_opt with
@@ -538,7 +554,7 @@ class font_param_box param =
     | Some s ->
 	let style = we#misc#style#copy in
 	(
-	 try 
+	 try
 	   let font = Gdk.Font.load_fontset s in
 	   style#set_font font
 	 with _ -> ()
@@ -559,10 +575,10 @@ class font_param_box param =
     let wb_cancel = dialog#cancel_button in
     let _ = dialog#connect#destroy GMain.Main.quit in
     let _ = wb_ok#connect#clicked
-	(fun () -> 
-	  let font_opt = dialog#selection#font_name in
-(*	  we#set_text (match font_opt with None -> "" | Some s -> s) ;
-	  set_entry_font font_opt;*)
+	(fun () ->
+	  let font = dialog#selection#font_name in
+	  we#set_text font ;
+	  set_entry_font (Some font);
 	  dialog#destroy ()
 	)
     in
@@ -585,79 +601,89 @@ class font_param_box param =
   end ;;
 
 (** This class is used to build a box for a text parameter.*)
-class text_param_box param =
-  let hbox = GPack.hbox ~height: 100 () in
-  let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
-  let wl = GMisc.label ~text: param.string_label ~packing: wev#add () in
+class text_param_box param (tt:GData.tooltips) =
+  let _ = dbg "text_param_box" in
+  let wf = GBin.frame ~label: param.string_label ~height: 100 () in
+  let wev = GBin.event_box ~packing: wf#add () in
   let wscroll = GBin.scrolled_window
       ~vpolicy: `AUTOMATIC
       ~hpolicy: `AUTOMATIC
-      ~packing: (hbox#pack ~expand: true ~padding: 2) () 
+      ~packing: wev#add ()
   in
-  let wt = GText.view ~packing:wscroll#add () in
-(*   let _ = wt#coerce#misc#set_size_request ~height:100 in *)
-  let _ = wt#set_editable param.string_editable in
-  let _ = 
+  let wview = GText.view
+      ~editable: param.string_editable
+      ~packing: wscroll#add
+      ()
+  in
+  let _ =
     match param.string_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wev#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wev#coerce
   in
-  let _ = wt#buffer#insert param.string_value in
+  let _ = dbg "text_param_box: buffer creation" in
+  let buffer = GText.buffer () in
 
+  let _ = wview#set_buffer buffer in
+  let _ = buffer#insert (param.string_to_string param.string_value) in
+  let _ = dbg "text_param_box: object(self)" in
   object (self)
-    val wt = wt
+    val wview = wview
     (** This method returns the main box ready to be packed. *)
-    method box = hbox#coerce
+    method box = wf#coerce
     (** This method applies the new value of the parameter. *)
     method apply =
-      let new_value = wt#buffer#get_text () in
-      if new_value <> param.string_value then
-	let _ = param.string_f_apply new_value in
-	param.string_value <- new_value
+      let v = param.string_of_string (buffer#get_text ()) in
+      if v <> param.string_value then
+	(
+	 dbg "apply new value !";
+	 let _ = param.string_f_apply v in
+	 param.string_value <- v
+	)
       else
 	()
   end ;;
 
 (** This class is used to build a box a html parameter. *)
-class html_param_box param =
+class html_param_box param (tt:GData.tooltips) =
+  let _ = dbg "html_param_box" in
   object (self)
-    inherit text_param_box param
+    inherit text_param_box param tt
 
     method private exec html_start html_end () =
-      let s,e = wt#buffer#selection_bounds in
-      if s#compare e = 0 then 
-	wt#buffer#insert (html_start^html_end)
-      else begin
-	ignore (wt#buffer#insert ~iter:e html_end);
-	ignore (wt#buffer#insert ~iter:s html_start);
-	wt#buffer#place_cursor 
-	  (e#forward_chars (String.length (html_start^html_end)))
-      end
+      let (i1,i2) = wview#buffer#selection_bounds in
+      let s = i1#get_text ~stop: i2 in
+      match s with
+	"" ->
+	  wview#buffer#insert (html_start^html_end)
+      |	_ ->
+	  ignore (wview#buffer#insert ~iter: i2 html_end);
+	  ignore (wview#buffer#insert ~iter: i1 html_start);
+	  wview#buffer#place_cursor ~where: i2
+
     initializer
+      dbg "html_param_box:initializer";
       let (_,html_bindings) = html_config_file_and_option () in
+      dbg "html_param_box:connecting key press events";
       let add_shortcut hb =
 	let (mods, k) = hb.html_key in
-	Okey.add wt ~mods k (self#exec hb.html_begin hb.html_end)
+	Okey.add wview ~mods k (self#exec hb.html_begin hb.html_end)
       in
-      List.iter add_shortcut (O.(!!) html_bindings)      
+      List.iter add_shortcut html_bindings#get;
+      dbg "html_param_box:end"
   end
 
 (** This class is used to build a box for a boolean parameter.*)
-class bool_param_box param =
+class bool_param_box param (tt:GData.tooltips) =
+  let _ = dbg "bool_param_box" in
   let wchk = GButton.check_button
       ~label: param.bool_label
       ()
   in
-  let _ = 
+  let _ =
     match param.bool_help with
       None -> ()
-    | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (wchk#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wchk#coerce ~text: help ~privat: help 
+    | Some help -> tt#set_tip ~text: help ~privat: help wchk#coerce
   in
   let _ = wchk#set_active param.bool_value in
   let _ = wchk#misc#set_sensitive param.bool_editable in
@@ -676,25 +702,24 @@ class bool_param_box param =
   end ;;
 
 (** This class is used to build a box for a file name parameter.*)
-class filename_param_box param =
+class filename_param_box param (tt:GData.tooltips) =
+  let _ = dbg "filename_param_box" in
   let hbox = GPack.hbox () in
-  let wb = GButton.button ~label: param.string_label 
-      ~packing: (hbox#pack ~expand: false ~padding: 2) () 
+  let wb = GButton.button ~label: param.string_label
+      ~packing: (hbox#pack ~expand: false ~padding: 2) ()
   in
   let we = GEdit.entry
       ~editable: param.string_editable
       ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2)
       ()
   in
-  let _ = 
+  let _ =
     match param.string_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wb#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wb#coerce
   in
-  let _ = we#set_text param.string_value in
+  let _ = we#set_text (param.string_to_string param.string_value) in
 
   let f_click () =
     match select_files param.string_label with
@@ -703,7 +728,7 @@ class filename_param_box param =
     | f :: _ ->
         we#set_text f
   in
-  let _ = 
+  let _ =
     if param.string_editable then
       let _ = wb#connect#clicked f_click in
       ()
@@ -716,7 +741,7 @@ class filename_param_box param =
     method box = hbox#coerce
     (** This method applies the new value of the parameter. *)
     method apply =
-      let new_value = we#text in
+      let new_value = param.string_of_string we#text in
       if new_value <> param.string_value then
 	let _ = param.string_f_apply new_value in
 	param.string_value <- new_value
@@ -725,11 +750,12 @@ class filename_param_box param =
   end ;;
 
 (** This class is used to build a box for a hot key parameter.*)
-class hotkey_param_box param =
+class hotkey_param_box param (tt:GData.tooltips) =
+  let _ = dbg "hotkey_param_box" in
   let hbox = GPack.hbox () in
   let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
-  let wl = GMisc.label ~text: param.hk_label 
-      ~packing: wev#add () 
+  let wl = GMisc.label ~text: param.hk_label
+      ~packing: wev#add ()
   in
   let we = GEdit.entry
       ~editable: false
@@ -737,15 +763,13 @@ class hotkey_param_box param =
       ()
   in
   let value = ref param.hk_value in
-  let _ = 
+  let _ =
     match param.hk_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wev#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wev#coerce
   in
-  let _ = we#set_text (KeyOption.key_to_string param.hk_value) in
+  let _ = we#set_text (Configwin_types.key_to_string param.hk_value) in
   let mods_we_dont_care = [`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] in
   let capture ev =
     let key = GdkEvent.Key.keyval ev in
@@ -755,10 +779,10 @@ class hotkey_param_box param =
 	modifiers
     in
     value := (mods, key);
-    we#set_text (KeyOption.key_to_string !value);
+    we#set_text (Glib.Convert.locale_to_utf8 (Configwin_types.key_to_string !value));
     false
   in
-  let _ = 
+  let _ =
     if param.hk_editable then
       ignore (we#event#connect#key_press capture)
     else
@@ -798,7 +822,7 @@ class modifiers_param_box param =
 	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
 	tooltips#set_tip wev#coerce ~text: help ~privat: help 
   in
-  let _ = we#set_text (KeyOption.modifiers_to_string param.md_value) in
+  let _ = we#set_text (Configwin_types.modifiers_to_string param.md_value) in
   let mods_we_care = param.md_allow in
   let capture ev =
     let modifiers = GdkEvent.Key.state ev in
@@ -807,7 +831,7 @@ class modifiers_param_box param =
 	modifiers
     in
     value := mods;
-    we#set_text (KeyOption.modifiers_to_string !value);
+    we#set_text (Configwin_types.modifiers_to_string !value);
     false
   in
   let _ = 
@@ -831,35 +855,35 @@ class modifiers_param_box param =
   end ;;
 
 (** This class is used to build a box for a date parameter.*)
-class date_param_box param =
+class date_param_box param (tt:GData.tooltips) =
+  let _ = dbg "date_param_box" in
   let v = ref param.date_value in
   let hbox = GPack.hbox () in
-  let wb = GButton.button ~label: param.date_label 
-      ~packing: (hbox#pack ~expand: false ~padding: 2) () 
+  let wb = GButton.button ~label: param.date_label
+      ~packing: (hbox#pack ~expand: false ~padding: 2) ()
   in
   let we = GEdit.entry
       ~editable: false
       ~packing: (hbox#pack ~expand: param.date_expand ~padding: 2)
       ()
   in
-  let _ = 
+
+  let _ =
     match param.date_help with
       None -> ()
     | Some help ->
-	let tooltips = GData.tooltips () in
-	ignore (hbox#connect#destroy ~callback: tooltips#destroy);
-	tooltips#set_tip wb#coerce ~text: help ~privat: help 
+	tt#set_tip ~text: help ~privat: help wb#coerce
   in
-  let _ = we#set_text (param.date_f_string param.date_value) in
 
+  let _ = we#set_text (param.date_f_string param.date_value) in
   let f_click () =
     match select_date param.date_label !v with
       None -> ()
-    | Some (y,m,d) -> 
+    | Some (y,m,d) ->
 	v := (d,m,y) ;
 	we#set_text (param.date_f_string (d,m,y))
   in
-  let _ = 
+  let _ =
     if param.date_editable then
       let _ = wb#connect#clicked f_click in
       ()
@@ -880,7 +904,8 @@ class date_param_box param =
   end ;;
 
 (** This class is used to build a box for a parameter whose values are a list.*)
-class ['a] list_param_box (param : 'a list_param) =
+class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) =
+  let _ = dbg "list_param_box" in
   let listref = ref param.list_value in
   let frame_selection = new list_selection_box
       listref
@@ -891,8 +916,9 @@ class ['a] list_param_box (param : 'a list_param) =
       param.list_color
       param.list_eq
       param.list_f_add param.list_label param.list_editable
+      tt
   in
-      
+
   object (self)
     (** This method returns the main box ready to be packed. *)
     method box = frame_selection#box#coerce
@@ -902,75 +928,75 @@ class ['a] list_param_box (param : 'a list_param) =
       param.list_value <- !listref
   end ;;
 
-(** This class is used to build a box from a configuration structure 
+(** This class is used to build a box from a configuration structure
    and adds the page to the given notebook. *)
-class configuration_box conf_struct (notebook : GPack.notebook) =
+class configuration_box (tt:GData.tooltips) conf_struct (notebook : GPack.notebook) =
   (* we build different widgets, according to the conf_struct parameter *)
   let main_box = GPack.vbox () in
-  let (label, child_boxes) = 
+  let (label, child_boxes) =
     match conf_struct with
       Section (label, param_list) ->
 	let f parameter =
-	      match parameter with
-		String_param p ->
-		  let box = new string_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	Combo_param p ->
-		  let box = new combo_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	Text_param p ->
-		  let box = new text_param_box p in
-		  let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
-		  box
-	      | Bool_param p ->
-		  let box = new bool_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	Filename_param p ->
-		  let box = new filename_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	List_param f ->
-		  let box = f () in
-		  let _ = main_box#pack ~expand: true ~padding: 2 box#box in
-		  box
-	      |	Custom_param p ->
-		  let box = new custom_param_box p in
-		  let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in
-		  box
-	      |	Color_param p ->
-		  let box = new color_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	Font_param p ->
-		  let box = new font_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	Date_param p ->
-		  let box = new date_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	Hotkey_param p ->
-		  let box = new hotkey_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	Modifiers_param p ->
-		  let box = new modifiers_param_box p in
-		  let _ = main_box#pack ~expand: false ~padding: 2 box#box in
-		  box
-	      |	Html_param p ->
-		  let box = new html_param_box p in
-		  let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
-		  box
+	  match parameter with
+	    String_param p ->
+	      let box = new string_param_box p tt in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+	      box
+	  | Combo_param p ->
+	      let box = new combo_param_box p tt in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+	      box
+	  | Text_param p ->
+	      let box = new text_param_box p tt in
+	      let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
+	      box
+	  | Bool_param p ->
+	      let box = new bool_param_box p tt in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+	      box
+	  | Filename_param p ->
+	      let box = new filename_param_box p tt in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+	      box
+	  | List_param f ->
+	      let box = f tt in
+	      let _ = main_box#pack ~expand: true ~padding: 2 box#box in
+	      box
+	  | Custom_param p ->
+	      let box = new custom_param_box p tt in
+	      let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in
+	      box
+	  | Color_param p ->
+	      let box = new color_param_box p tt in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+	      box
+	  | Font_param p ->
+	      let box = new font_param_box p tt in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+	      box
+	  | Date_param p ->
+	      let box = new date_param_box p tt in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+	      box
+	  | Hotkey_param p ->
+	      let box = new hotkey_param_box p tt in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+	      box
+	  | Modifiers_param p ->
+	      let box = new modifiers_param_box p in
+	      let _ = main_box#pack ~expand: false ~padding: 2 box#box in
+		box
+	  | Html_param p ->
+	      let box = new html_param_box p tt in
+	      let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
+	      box
 	in
 	let list_children_boxes = List.map f param_list in
-	
+
 	(label, list_children_boxes)
 
     | Section_list (label, struct_list) ->
-	let wnote = GPack.notebook 
+	let wnote = GPack.notebook
             (*homogeneous_tabs: true*)
 	    ~scrollable: true
 	    ~show_tabs: true
@@ -980,15 +1006,15 @@ class configuration_box conf_struct (notebook : GPack.notebook) =
 	in
 	(* we create all the children boxes *)
 	let f structure =
-	  let new_box = new configuration_box structure wnote in
+	  let new_box = new configuration_box tt structure wnote in
 	  new_box
 	in
 	let list_child_boxes = List.map f struct_list in
 	(label, list_child_boxes)
-	
+
   in
   let page_label = GMisc.label ~text: label () in
-  let _ = notebook#append_page 
+  let _ = notebook#append_page
       ~tab_label: page_label#coerce
       main_box#coerce
   in
@@ -1008,9 +1034,9 @@ class configuration_box conf_struct (notebook : GPack.notebook) =
    Before calling the callback of a button, the [apply] function
    of each parameter is called.
 *)
-let tabbed_box conf_struct_list buttons =
+let tabbed_box conf_struct_list buttons tooltips =
   let vbox = GPack.vbox () in
-  let wnote = GPack.notebook 
+  let wnote = GPack.notebook
       (*homogeneous_tabs: true*)
       ~scrollable: true
       ~show_tabs: true
@@ -1018,18 +1044,19 @@ let tabbed_box conf_struct_list buttons =
       ~packing: (vbox#pack ~expand: true)
       ()
   in
-  let list_param_box = 
-    List.map (fun conf_struct -> new configuration_box conf_struct wnote)
+  let list_param_box =
+    List.map
+      (fun conf_struct -> new configuration_box tooltips conf_struct wnote)
       conf_struct_list
   in
-  let f_apply () = 
+  let f_apply () =
     List.iter (fun param_box -> param_box#apply) list_param_box  ;
   in
   let hbox_buttons = GPack.hbox ~packing: (vbox#pack ~expand: false ~padding: 4) () in
   let rec iter_buttons ?(grab=false) = function
       [] ->
         ()
-    | (label, callb) :: q ->    
+    | (label, callb) :: q ->
         let b = GButton.button ~label: label
             ~packing:(hbox_buttons#pack ~expand:true ~fill: true ~padding:4) ()
         in
@@ -1046,127 +1073,110 @@ let tabbed_box conf_struct_list buttons =
 
 (** This function takes a configuration structure list and creates a window
    to configure the various parameters. *)
-let edit ?(with_apply=true)  
+let edit ?(with_apply=true)
     ?(apply=(fun () -> ()))
-    title ?(width=400) ?(height=400) 
+    title ?(width=400) ?(height=400)
     conf_struct_list =
-  let return = ref Return_cancel in
-  let window = GWindow.window
-		 ~position:`CENTER
-      ~modal: true ~title: title
-      ~width: width ~height: height ()
-  in
-  let _ = window#connect#destroy ~callback: GMain.Main.quit in
-  let vbox = GPack.vbox ~packing: window#add () in
-  let wnote = GPack.notebook 
-      (*homogeneous_tabs: true*)
-      ~scrollable: true
-      ~show_tabs: true
-      ~tab_border: 3
-      ~packing: (vbox#pack ~expand: true)
-      ()
-  in
-  let list_param_box = 
-    List.map (fun conf_struct -> new configuration_box conf_struct wnote)
+  let dialog = GWindow.dialog
+    ~position:`CENTER
+    ~modal: true ~title: title
+    ~height ~width
+    ()
+  in
+  let tooltips = GData.tooltips () in
+  let wnote = GPack.notebook
+    (*homogeneous_tabs: true*)
+    ~scrollable: true
+    ~show_tabs: true
+    ~tab_border: 3
+    ~packing: (dialog#vbox#pack ~expand: true)
+    ()
+  in
+  let list_param_box =
+    List.map
+      (fun conf_struct -> new configuration_box tooltips conf_struct wnote)
       conf_struct_list
   in
+    
+    if with_apply then
+      dialog#add_button Configwin_messages.mApply `APPLY;
+    
+    dialog#add_button Configwin_messages.mOk `OK;
+    dialog#add_button Configwin_messages.mCancel `CANCEL;
+    
+    let f_apply () =
+      List.iter (fun param_box -> param_box#apply) list_param_box  ;
+      apply ()
+    in
+    let f_ok () =
+      List.iter (fun param_box -> param_box#apply) list_param_box  ;
+      Return_ok
+    in
+    let destroy () =
+      tooltips#destroy () ;
+      dialog#destroy ();
+    in
+    let rec iter rep =
+      try
+	match dialog#run () with
+	  | `APPLY  -> f_apply (); iter Return_apply
+	  | `OK -> destroy (); f_ok ()
+	  | _ -> destroy (); rep
+      with
+	  Failure s ->
+	    GToolbox.message_box "Error" s; iter rep
+	| e ->
+	    GToolbox.message_box "Error" (Printexc.to_string e); iter rep
+    in
+      iter Return_cancel
 
-  let hbox_buttons = GPack.hbox ~packing: (vbox#pack ~expand: false ~padding: 4) () in
-  let bApply = GButton.button
-		 ~stock:`APPLY
-		 ~label: Configwin_messages.mApply
-		 ()
-  in
-  if with_apply then hbox_buttons#pack ~expand: true ~padding: 3 bApply#coerce;
-  let bOk = GButton.button
-	      ~stock:`OK
-      ~label: Configwin_messages.mOk
-      ~packing: (hbox_buttons#pack ~expand: true ~padding: 3)
-      ()
-  in
-  let bCancel = GButton.button
-		  ~stock:`CANCEL
-      ~label: Configwin_messages.mCancel
-      ~packing: (hbox_buttons#pack ~expand: true ~padding: 3)
-      ()
-  in
-  (* we connect the click on the apply button *)
-  let f_apply () = 
-    List.iter (fun param_box -> param_box#apply) list_param_box  ;
-    apply ();
-    return := Return_apply
-  in
-  let _ = bApply#connect#clicked f_apply in
-  (* we connect the click on the ok button : the same than apply but we then close the window *)
-  let f_ok () = 
-    List.iter (fun param_box -> param_box#apply) list_param_box  ;
-    return := Return_ok ;
-    window#destroy () 
-  in
-  let _ = bOk#connect#clicked f_ok in
-  (* we connect the click on the cancel button : close the window *)
-  let f_cancel () = window#destroy () in
-  let _ = bCancel#connect#clicked f_cancel in
-
-  let _ = window#event#connect#key_press ~callback:
-	    (fun k -> if GdkEvent.Key.keyval k = GdkKeysyms._Escape then f_cancel ();false)
-  in
-  let _ = window#show () in
-  GMain.Main.main () ;
-  !return
-
-
-(** Create a vbox with the list of given parameters,
-   and the given list of buttons (defined by their label and callback).
-   Before calling the callback of a button, the [apply] function
-   of each parameter is called.
-*)
-let box param_list buttons =
+(** Create a vbox with the list of given parameters. *)
+let box param_list tt =
   let main_box = GPack.vbox  () in
   let f parameter =
     match parameter with
       String_param p ->
-	let box = new string_param_box p in
+	let box = new string_param_box p tt in
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | Combo_param p ->
-	let box = new combo_param_box p in
+	let box = new combo_param_box p tt in
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | Text_param p ->
-	let box = new text_param_box p in
+	let box = new text_param_box p tt in
 	let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
 	box
     | Bool_param p ->
-	let box = new bool_param_box p in
+	let box = new bool_param_box p tt in
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | Filename_param p ->
-	let box = new filename_param_box p in
+	let box = new filename_param_box p tt in
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | List_param f ->
-	let box = f () in
+	let box = f tt in
 	let _ = main_box#pack ~expand: true ~padding: 2 box#box in
 	box
     | Custom_param p ->
-	let box = new custom_param_box p in
+	let box = new custom_param_box p tt in
 	let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in
 	box
     | Color_param p ->
-	let box = new color_param_box p in
+	let box = new color_param_box p tt in
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | Font_param p ->
-	let box = new font_param_box p in
+	let box = new font_param_box p tt in
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | Date_param p ->
-	let box = new date_param_box p in
+	let box = new date_param_box p tt in
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | Hotkey_param p ->
-	let box = new hotkey_param_box p in
+	let box = new hotkey_param_box p tt in
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | Modifiers_param p ->
@@ -1174,70 +1184,61 @@ let box param_list buttons =
 	let _ = main_box#pack ~expand: false ~padding: 2 box#box in
 	box
     | Html_param p ->
-	let box = new html_param_box p in
+	let box = new html_param_box p tt in
 	let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in
 	box
   in
   let list_param_box = List.map f param_list in
-  let f_apply () = 
-    List.iter (fun param_box -> param_box#apply) list_param_box 
+  let f_apply () =
+    List.iter (fun param_box -> param_box#apply) list_param_box
   in
-  let hbox_buttons = GPack.hbox ~packing: (main_box#pack ~expand: false ~padding: 4) () in
-  let rec iter_buttons ?(grab=false) = function
-      [] ->
-        ()
-    | (label, callb) :: q ->    
-        let b = GButton.button ~label: label
-            ~packing:(hbox_buttons#pack ~expand:true ~fill: true ~padding:4) ()
-        in
-        ignore (b#connect#clicked ~callback:
-		  (fun () -> f_apply (); callb ()));
-        (* If it's the first button then give it the focus *)
-        if grab then b#grab_default ();
+  (main_box, f_apply)
 
-        iter_buttons q
+(** This function takes a list of parameter specifications and
+   creates a window to configure the various parameters.*)
+let simple_edit ?(with_apply=true)
+    ?(apply=(fun () -> ()))
+    title ?width ?height
+    param_list =
+  let dialog = GWindow.dialog
+      ~modal: true ~title: title
+      ?height ?width
+      ()
   in
-  iter_buttons ~grab: true buttons;
+  let tooltips = GData.tooltips () in
+  if with_apply then
+    dialog#add_button Configwin_messages.mApply `APPLY;
 
-  main_box
+  dialog#add_button Configwin_messages.mOk `OK;
+  dialog#add_button Configwin_messages.mCancel `CANCEL;
 
+  let (box, f_apply) = box param_list tooltips in
+  dialog#vbox#pack ~expand: true ~fill: true box#coerce;
 
-(** This function takes a list of parameter specifications and 
-   creates a window to configure the various parameters.*)
-let simple_edit ?(with_apply=true)  
-    ?(apply=(fun () -> ()))
-    title ?width ?height 
-    param_list =
-  let return = ref Return_cancel in
-  let window = GWindow.window ~modal: true ~title: title () in
-  let _ = match width, height with
-    None, None -> ()
-  | Some w, None -> window#misc#set_size_request ~width: w ()
-  | None, Some h -> window#misc#set_size_request ~height: h ()
-  | Some w, Some h -> window#misc#set_size_request ~width: w ~height: h ()
-  in
-  let _ = window#connect#destroy ~callback: GMain.Main.quit in
-  let buttons = 
-    (if with_apply then
-      [Configwin_messages.mApply, fun () -> apply (); return := Return_apply]
-    else
-      []
-    ) @ [
-	(Configwin_messages.mOk, fun () -> return := Return_ok ; window#destroy ()) ;
-	(Configwin_messages.mCancel, window#destroy) ;
-      ]	
+  let destroy () =
+    tooltips#destroy () ;
+    dialog#destroy ();
   in
-  let box = box param_list buttons in
-  window#add box#coerce;
-  let _ = window#show () in
-  GMain.Main.main () ;
-  !return
+  let rec iter rep =
+    try
+      match dialog#run () with
+      | `APPLY  -> f_apply (); apply (); iter Return_apply
+      | `OK -> f_apply () ; destroy () ; Return_ok
+      | _ -> destroy (); rep
+    with
+      Failure s ->
+	GToolbox.message_box "Error" s; iter rep
+    | e ->
+	GToolbox.message_box "Error" (Printexc.to_string e); iter rep
+  in
+  iter Return_cancel
+
 
 let edit_string l s =
   match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with
     None -> s
   | Some s2 -> s2
-  
+
 (** Create a string param. *)
 let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
   String_param
@@ -1248,7 +1249,25 @@ let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
       string_editable = editable ;
       string_f_apply = f ;
       string_expand = expand ;
-    } 
+      string_to_string = (fun x -> x) ;
+      string_of_string = (fun x -> x) ;
+    }
+
+(** Create a custom string param. *)
+let custom_string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ~to_string ~of_string label v =
+  String_param
+    (Configwin_types.mk_custom_text_string_param
+       {
+	 string_label = label ;
+	 string_help = help ;
+	 string_value = v ;
+	 string_editable = editable ;
+	 string_f_apply = f ;
+	 string_expand = expand ;
+	 string_to_string = to_string;
+	 string_of_string = of_string ;
+       }
+    )
 
 (** Create a bool param. *)
 let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v =
@@ -1263,14 +1282,14 @@ let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v =
 
 (** Create a list param. *)
 let list ?(editable=true) ?help
-    ?(f=(fun (_:'a list) -> ())) 
+    ?(f=(fun (_:'a list) -> ()))
     ?(eq=Pervasives.(=))
     ?(edit:('a -> 'a) option)
     ?(add=(fun () -> ([] : 'a list)))
     ?titles ?(color=(fun (_:'a) -> (None : string option)))
     label (f_strings : 'a -> string list) v =
   List_param
-    (fun () ->
+    (fun tt ->
       Obj.magic
 	(new list_param_box
 	   {
@@ -1285,13 +1304,14 @@ let list ?(editable=true) ?help
 	     list_f_edit = edit ;
 	     list_f_add = add ;
 	     list_f_apply = f ;
-	   } 
+	   }
+	   tt
 	)
     )
 
 (** Create a strings param. *)
 let strings ?(editable=true) ?help
-    ?(f=(fun _ -> ())) 
+    ?(f=(fun _ -> ()))
     ?(eq=Pervasives.(=))
     ?(add=(fun () -> [])) label v =
   list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v
@@ -1321,8 +1341,8 @@ let font ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
     }
 
 (** Create a combo param. *)
-let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) 
-    ?(new_allowed=false) 
+let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ()))
+    ?(new_allowed=false)
     ?(blank_allowed=false) label choices v =
   Combo_param
     {
@@ -1338,7 +1358,7 @@ let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ()))
     }
 
 (** Create a text param. *)
-let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = 
+let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
   Text_param
     {
       string_label = label ;
@@ -1347,10 +1367,28 @@ let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
       string_editable = editable ;
       string_f_apply = f ;
       string_expand = expand ;
-    } 
+      string_to_string = (fun x -> x) ;
+      string_of_string = (fun x -> x) ;
+    }
+
+(** Create a custom text param. *)
+let custom_text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) ~to_string ~of_string label v =
+  Text_param
+    (Configwin_types.mk_custom_text_string_param
+       {
+	 string_label = label ;
+	 string_help = help ;
+	 string_value = v ;
+	 string_editable = editable ;
+	 string_f_apply = f ;
+	 string_expand = expand ;
+	 string_to_string = to_string;
+	 string_of_string = of_string ;
+       }
+    )
 
 (** Create a html param. *)
-let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = 
+let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
   Html_param
     {
       string_label = label ;
@@ -1359,10 +1397,12 @@ let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
       string_editable = editable ;
       string_f_apply = f ;
       string_expand = expand ;
-    } 
+      string_to_string = (fun x -> x) ;
+      string_of_string = (fun x -> x) ;
+    }
 
 (** Create a filename param. *)
-let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = 
+let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v =
   Filename_param
     {
       string_label = label ;
@@ -1371,17 +1411,19 @@ let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v =
       string_editable = editable ;
       string_f_apply = f ;
       string_expand = expand ;
-    } 
+      string_to_string = (fun x -> x) ;
+      string_of_string = (fun x -> x) ;
+    }
 
 (** Create a filenames param.*)
-let filenames ?(editable=true) ?help ?(f=(fun _ -> ())) 
+let filenames ?(editable=true) ?help ?(f=(fun _ -> ()))
     ?(eq=Pervasives.(=))
     label v =
   let add () = select_files label in
-  list ~editable ?help ~f ~eq ~add label (fun s -> [s]) v
+  list ~editable ?help ~f ~eq ~add label (fun s -> [Glib.Convert.locale_to_utf8 s]) v
 
 (** Create a date param. *)
-let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) 
+let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ()))
     ?(f_string=(fun(d,m,y)-> Printf.sprintf "%d/%d/%d" y (m+1) d))
     label v =
   Date_param
@@ -1393,7 +1435,7 @@ let date ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ()))
       date_f_string = f_string ;
       date_f_apply = f ;
       date_expand = expand ;
-    } 
+    }
 
 (** Create a hot key param. *)
 let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
@@ -1405,7 +1447,7 @@ let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
       hk_editable = editable ;
       hk_f_apply = f ;
       hk_expand = expand ;
-    } 
+    }
 
 let modifiers 
   ?(editable=true) 
@@ -1432,4 +1474,4 @@ let custom ?label box f expand =
       custom_f_apply = f ;
       custom_expand = expand ;
       custom_framed = label ;
-    } 
+    }
diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml
index 9c867845..e1d7f33b 100644
--- a/ide/utils/configwin_keys.ml
+++ b/ide/utils/configwin_keys.ml
@@ -1,26 +1,27 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
 
 (** Key codes
 
diff --git a/ide/utils/configwin_messages.ml b/ide/utils/configwin_messages.ml
index a6085138..f8984462 100644
--- a/ide/utils/configwin_messages.ml
+++ b/ide/utils/configwin_messages.ml
@@ -1,31 +1,32 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
 
 (** Module containing the messages of Configwin.*)
 
 let software = "Configwin";;
-let version = "1.3";;
+let version = "1.2";;
 
 let html_config = "Configwin bindings configurator for html parameters"
 
diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml
index ee8ec70c..0def0b25 100644
--- a/ide/utils/configwin_types.ml
+++ b/ide/utils/configwin_types.ml
@@ -1,140 +1,148 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
 
 (** This module contains the types used in Configwin. *)
 
-open Uoptions
+open Config_file
 
-(** A module to define key options, with the {!Uoptions} module. *)
-module KeyOption = struct
-  let name_to_keysym = 
-    ("Button1", Configwin_keys.xk_Pointer_Button1) ::
-    ("Button2", Configwin_keys.xk_Pointer_Button2) ::
-    ("Button3", Configwin_keys.xk_Pointer_Button3) ::
-    ("Button4", Configwin_keys.xk_Pointer_Button4) ::
-    ("Button5", Configwin_keys.xk_Pointer_Button5) ::
-    Configwin_keys.name_to_keysym
-      
-  let string_to_key s =
-    let mask = ref [] in
-    let key = try
-      let pos = String.rindex s '-' in
-      for i = 0 to pos - 1 do 
-        let m = match s.[i] with
-          'C' -> `CONTROL
-        | 'S' -> `SHIFT
-        | 'L' -> `LOCK 
-        | 'M' -> `MOD1
-        | 'A' -> `MOD1
-        | '1' -> `MOD1
-        | '2' -> `MOD2
-        | '3' -> `MOD3
-        | '4' -> `MOD4
-        | '5' -> `MOD5
-        | _ -> 
-	    prerr_endline s;
-	    raise Not_found
-        in
-        mask := m :: !mask
-      done;
-      String.sub s (pos+1) (String.length s - pos - 1)
-    with _ -> 
-      s
-    in
-    try
-      !mask, List.assoc key name_to_keysym
-    with
-      e -> 
-	prerr_endline s;
-	raise e
-      
-  let key_to_string (m, k) =
-    let s = List.assoc k Configwin_keys.keysym_to_name in
-    match m with
-      [] -> s
-    | _ ->
-        let rec iter m s =
-          match m with
-            [] -> s
-          | c :: m ->
-              iter m ((
-                      match c with
-			`CONTROL -> "C"
-                      | `SHIFT -> "S"
-                      | `LOCK -> "L"
-                      | `MOD1 -> "A"
-                      | `MOD2 -> "2"
-                      | `MOD3 -> "3"
-                      | `MOD4 -> "4"
-                      | `MOD5 -> "5"
-                      | _  -> raise Not_found
-                     ) ^ s)
-        in
-        iter m ("-" ^ s)
+let name_to_keysym =
+  ("Button1", Configwin_keys.xk_Pointer_Button1) ::
+  ("Button2", Configwin_keys.xk_Pointer_Button2) ::
+  ("Button3", Configwin_keys.xk_Pointer_Button3) ::
+  ("Button4", Configwin_keys.xk_Pointer_Button4) ::
+  ("Button5", Configwin_keys.xk_Pointer_Button5) ::
+  Configwin_keys.name_to_keysym
+
+let string_to_key s =
+  let mask = ref [] in
+  let key = try
+    let pos = String.rindex s '-' in
+    for i = 0 to pos - 1 do
+      let m = match s.[i] with
+        'C' -> `CONTROL
+      | 'S' -> `SHIFT
+      | 'L' -> `LOCK
+      | 'M' -> `MOD1
+      | 'A' -> `MOD1
+      | '1' -> `MOD1
+      | '2' -> `MOD2
+      | '3' -> `MOD3
+      | '4' -> `MOD4
+      | '5' -> `MOD5
+      | _ ->
+	  prerr_endline s;
+	  raise Not_found
+      in
+      mask := m :: !mask
+    done;
+    String.sub s (pos+1) (String.length s - pos - 1)
+  with _ ->
+    s
+  in
+  try
+    !mask, List.assoc key name_to_keysym
+  with
+    e ->
+      prerr_endline s;
+      raise e
 
-  let modifiers_to_string m =
-    let rec iter m s =
-      match m with
+let key_to_string (m, k) =
+  let s = List.assoc k Configwin_keys.keysym_to_name in
+  match m with
+    [] -> s
+  | _ ->
+      let rec iter m s =
+        match m with
           [] -> s
         | c :: m ->
             iter m ((
-                      match c with
-			  `CONTROL -> "<ctrl>"
-			| `SHIFT -> "<shft>"
-			| `LOCK -> "<lock>"
-			| `MOD1 -> "<alt>"
-			| `MOD2 -> "<mod2>"
-			| `MOD3 -> "<mod3>"
-			| `MOD4 -> "<mod4>"
-			| `MOD5 -> "<mod5>"
-			| _  -> raise Not_found
-                    ) ^ s)
-    in
+                    match c with
+		      `CONTROL -> "C"
+                    | `SHIFT -> "S"
+                    | `LOCK -> "L"
+                    | `MOD1 -> "A"
+                    | `MOD2 -> "2"
+                    | `MOD3 -> "3"
+                    | `MOD4 -> "4"
+                    | `MOD5 -> "5"
+                    | _  -> raise Not_found
+                   ) ^ s)
+      in
+      iter m ("-" ^ s)
+
+let modifiers_to_string m =
+  let rec iter m s =
+    match m with
+        [] -> s
+      | c :: m ->
+          iter m ((
+                    match c with
+			`CONTROL -> "<ctrl>"
+		      | `SHIFT -> "<shft>"
+		      | `LOCK -> "<lock>"
+		      | `MOD1 -> "<alt>"
+		      | `MOD2 -> "<mod2>"
+		      | `MOD3 -> "<mod3>"
+		      | `MOD4 -> "<mod4>"
+		      | `MOD5 -> "<mod5>"
+		      | _  -> raise Not_found
+                  ) ^ s)
+  in
     iter m ""
-	  
-  let value_to_key v =
-    match v with
-      StringValue s -> string_to_key s
-    | _ -> 
-	prerr_endline "value_to_key";
-	raise Not_found
-	  
-  let key_to_value k =
-    StringValue (key_to_string k)
       
-  let (t : (Gdk.Tags.modifier list * int) option_class) = 
-    define_option_class "Key" value_to_key key_to_value
-end
+let value_to_key v =
+  match v with
+    Raw.String s -> string_to_key s
+  | _ ->
+      prerr_endline "value_to_key";
+      raise Not_found
+
+let key_to_value k =
+  Raw.String (key_to_string k)
+
+let key_cp_wrapper =
+  {
+    to_raw = key_to_value ;
+    of_raw = value_to_key ;
+  }
 
-(** This type represents a string or filename parameter. *)
-type string_param = {
+(** A class to define key options, with the {!Config_file} module. *)
+class key_cp =
+  [(Gdk.Tags.modifier list * int)] Config_file.cp_custom_type key_cp_wrapper
+
+(** This type represents a string or filename parameter, or
+   any other type, depending on the given conversion functions. *)
+type 'a string_param = {
     string_label : string; (** the label of the parameter *)
-    mutable string_value : string; (** the current value of the parameter *)
+    mutable string_value : 'a; (** the current value of the parameter *)
     string_editable : bool ; (** indicates if the value can be changed *)
-    string_f_apply : (string -> unit) ; (** the function to call to apply the new value of the parameter *)
+    string_f_apply : ('a -> unit) ; (** the function to call to apply the new value of the parameter *)
     string_help : string option ; (** optional help string *)
     string_expand : bool ; (** expand or not *)
+    string_to_string : 'a -> string ;
+    string_of_string : string -> 'a ;
   } ;;
 
 (** This type represents a boolean parameter. *)
@@ -214,14 +222,14 @@ type font_param = {
 
 type hotkey_param = {
     hk_label : string ; (** the label of the parameter *)
-    mutable hk_value : (Gdk.Tags.modifier list * int) ; 
+    mutable hk_value : (Gdk.Tags.modifier list * int) ;
              (** The value, as a list of modifiers and a key code *)
     hk_editable : bool ; (** indicates if the value can be changed *)
     hk_f_apply : ((Gdk.Tags.modifier list * int) -> unit) ;
              (** the function to call to apply the new value of the paramter *)
     hk_help : string option ; (** optional help string *)
     hk_expand : bool ; (** expand or not *)
-  } 
+  }
 
 type modifiers_param = {
     md_label : string ; (** the label of the parameter *)
@@ -235,13 +243,18 @@ type modifiers_param = {
     md_allow : Gdk.Tags.modifier list
   } 
 
+
+let mk_custom_text_string_param (a : 'a string_param) : string string_param =
+  Obj.magic a
+
+
 (** This type represents the different kinds of parameters. *)
 type parameter_kind =
-    String_param of string_param
-  | List_param of (unit -> <box: GObj.widget ; apply : unit>)
-  | Filename_param of string_param
+    String_param of string string_param
+  | List_param of (GData.tooltips -> <box: GObj.widget ; apply : unit>)
+  | Filename_param of string string_param
   | Bool_param of bool_param
-  | Text_param of string_param
+  | Text_param of string string_param
   | Combo_param of combo_param
   | Custom_param of custom_param
   | Color_param of color_param
@@ -249,7 +262,7 @@ type parameter_kind =
   | Font_param of font_param
   | Hotkey_param of hotkey_param
   | Modifiers_param of modifiers_param
-  | Html_param of string_param
+  | Html_param of string string_param
 ;;
 
 (** This type represents the structure of the configuration window. *)
@@ -273,27 +286,21 @@ type html_binding = {
     mutable html_key :  (Gdk.Tags.modifier list * int) ;
     mutable html_begin : string ;
     mutable html_end : string ;
-  } 
-
-module Html_binding = struct
-  let value_to_hb v =
-    match v with
-      List [StringValue hk ; StringValue debut; StringValue fin ]
-    | SmallList [StringValue hk ; StringValue debut; StringValue fin ] ->
-        { html_key = KeyOption.string_to_key hk ;
-	  html_begin = debut ;
-	  html_end = fin ;
-        }
-    | _ ->
-        prerr_endline "Html_binding.value_to_hb";
-        raise Not_found
+  }
 
-  let hb_to_value hb =
-    SmallList [ StringValue (KeyOption.key_to_string hb.html_key) ;
-                StringValue hb.html_begin ;
-                StringValue hb.html_end ;
-	      ]	
+let htmlbinding_cp_wrapper =
+  let w = Config_file.tuple3_wrappers
+      key_cp_wrapper
+      Config_file.string_wrappers
+      Config_file.string_wrappers
+  in
+  {
+    to_raw = (fun v -> w.to_raw (v.html_key, v.html_begin, v.html_end)) ;
+    of_raw =
+      (fun r -> let (k,b,e) = w.of_raw r in
+       { html_key = k ; html_begin = b ; html_end = e }
+      ) ;
+  }
 
-  let (t : html_binding option_class) =
-    define_option_class "html_binding" value_to_hb hb_to_value
-end
+class htmlbinding_cp =
+  [html_binding] Config_file.option_cp htmlbinding_cp_wrapper
diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml
index e6d2f4d4..5441f4ab 100644
--- a/ide/utils/editable_cells.ml
+++ b/ide/utils/editable_cells.ml
@@ -85,7 +85,7 @@ let create l =
 			   | [] -> ()
 			   | path::_ ->
 			       let iter = store#get_iter path in
-			       GtkTree.TreePath.prev path;
+			       ignore (GtkTree.TreePath.prev path);
 			       let upiter = store#get_iter path in
 			       ignore (store#swap iter upiter);
 		      ));
diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml
index 17e371f5..57939266 100644
--- a/ide/utils/okey.ml
+++ b/ide/utils/okey.ml
@@ -1,33 +1,34 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
 
 type modifier = Gdk.Tags.modifier
 
 type handler = {
     cond : (unit -> bool) ;
     cback : (unit -> unit) ;
-  } 
+  }
 
 type handler_spec = int * int * Gdk.keysym
       (** mods * mask * key *)
@@ -49,9 +50,9 @@ let int_of_modifier = function
 
 let print_modifier l =
   List.iter
-    (fun m -> 
+    (fun m ->
       print_string
-	(((function 
+	(((function
 	    `SHIFT -> "SHIFT"
 	  | `LOCK -> "LOCK"
 	  | `CONTROL -> "CONTROL"
@@ -69,11 +70,11 @@ let print_modifier l =
     )
     l;
   print_newline ()
-  
+
 let int_of_modifiers l =
   List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l
 
-module H = 
+module H =
   struct
     type t = handler_spec * handler
     let equal (m,k) (mods, mask, key) =
@@ -85,7 +86,7 @@ module H =
     let find_handlers mods key l =
       List.map snd
         (List.filter
-	   (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k)) 
+	   (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k))
 	   l
 	)
 
@@ -97,23 +98,25 @@ let key_press w ev =
   let key = GdkEvent.Key.keyval ev in
   let modifiers = GdkEvent.Key.state ev in
   try
-    let (r : H.t list ref) = Hashtbl.find table w#get_oid in
+    let (r : H.t list ref) = Hashtbl.find table (Oo.id w) in
     let l = H.find_handlers (int_of_modifiers modifiers) key !r in
-    let b = ref true in
-    List.iter
-      (fun h ->
-	if h.cond () then
-	  (h.cback () ; b := false)
-	else
-	  ()
-      )
-      l;
-    !b
+    match l with
+      [] -> false
+    | _ ->
+	List.iter
+	  (fun h ->
+	    if h.cond () then
+	      try h.cback ()
+	      with e -> prerr_endline (Printexc.to_string e)
+	    else ()
+	  )
+	  l;
+	true
   with
     Not_found ->
-      true
+      false
 
-let associate_key_press w = 
+let associate_key_press w =
   ignore ((w#event#connect#key_press ~callback: (key_press w)) : GtkSignal.id)
 
 let default_modifiers = ref ([] : modifier list)
@@ -122,24 +125,25 @@ let default_mask = ref ([`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK] : modifier list)
 let set_default_modifiers l = default_modifiers := l
 let set_default_mask l = default_mask := l
 
-let remove_widget  (w : < event : GObj.event_ops ; get_oid : int ; ..>) () =
-  try 
-    let r = Hashtbl.find table w#get_oid in
+let remove_widget  (w : < event : GObj.event_ops ; ..>) () =
+  try
+    let r = Hashtbl.find table (Oo.id w) in
     r := []
-  with 
+  with
     Not_found ->
       ()
 
 let add1 ?(remove=false) w
-    ?(cond=(fun () -> true)) 
+    ?(cond=(fun () -> true))
     ?(mods= !default_modifiers)
     ?(mask= !default_mask)
     k callback =
+
   let r =
-    try Hashtbl.find table w#get_oid
-    with Not_found -> 
+    try Hashtbl.find table (Oo.id w)
+    with Not_found ->
       let r = ref [] in
-      Hashtbl.add table w#get_oid r;
+      Hashtbl.add table (Oo.id w) r;
       ignore (w#connect#destroy ~callback: (remove_widget w));
       associate_key_press w;
       r
@@ -147,7 +151,7 @@ let add1 ?(remove=false) w
   let n_mods = int_of_modifiers mods in
   let n_mask = lnot (int_of_modifiers mask) in
   let new_h = { cond = cond ; cback = callback } in
-  if remove then 
+  if remove then
     (
      let l = H.filter_with_mask n_mods n_mask k !r in
      r := ((n_mods, n_mask, k), new_h) :: l
@@ -156,30 +160,29 @@ let add1 ?(remove=false) w
     r := ((n_mods, n_mask, k), new_h) :: !r
 
 let add w
-    ?(cond=(fun () -> true)) 
+    ?(cond=(fun () -> true))
     ?(mods= !default_modifiers)
     ?(mask= !default_mask)
     k callback =
   add1 w ~cond ~mods ~mask k callback
 
 let add_list w
-    ?(cond=(fun () -> true)) 
+    ?(cond=(fun () -> true))
     ?(mods= !default_modifiers)
     ?(mask= !default_mask)
     k_list callback =
   List.iter (fun k -> add w ~cond ~mods ~mask k callback) k_list
 
 let set w
-    ?(cond=(fun () -> true)) 
+    ?(cond=(fun () -> true))
     ?(mods= !default_modifiers)
     ?(mask= !default_mask)
     k callback =
   add1 ~remove: true w ~cond ~mods ~mask k callback
 
 let set_list w
-    ?(cond=(fun () -> true)) 
+    ?(cond=(fun () -> true))
     ?(mods= !default_modifiers)
     ?(mask= !default_mask)
     k_list callback =
   List.iter (fun k -> set w ~cond ~mods ~mask k callback) k_list
-
diff --git a/ide/utils/okey.mli b/ide/utils/okey.mli
index a0effe72..c8d48389 100644
--- a/ide/utils/okey.mli
+++ b/ide/utils/okey.mli
@@ -1,26 +1,27 @@
-(**************************************************************************)
-(*                   Cameleon                                             *)
-(*                                                                        *)
-(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
-(*      en Automatique. All rights reserved.                              *)
-(*                                                                        *)
-(*      This program is free software; you can redistribute it and/or modify  *)
-(*      it under the terms of the GNU General Public License as published by  *)
-(*      the Free Software Foundation; either version 2 of the License, or  *)
-(*      any later version.                                                *)
-(*                                                                        *)
-(*      This program is distributed in the hope that it will be useful,   *)
-(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
-(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
-(*      GNU General Public License for more details.                      *)
-(*                                                                        *)
-(*      You should have received a copy of the GNU General Public License  *)
-(*      along with this program; if not, write to the Free Software       *)
-(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
-(*      02111-1307  USA                                                   *)
-(*                                                                        *)
-(*      Contact: Maxence.Guesdon@inria.fr                                *)
-(**************************************************************************)
+(*********************************************************************************)
+(*                Cameleon                                                       *)
+(*                                                                               *)
+(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
+(*    en Automatique. All rights reserved.                                       *)
+(*                                                                               *)
+(*    This program is free software; you can redistribute it and/or modify       *)
+(*    it under the terms of the GNU Library General Public License as            *)
+(*    published by the Free Software Foundation; either version 2 of the         *)
+(*    License, or  any later version.                                            *)
+(*                                                                               *)
+(*    This program is distributed in the hope that it will be useful,            *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
+(*    GNU Library General Public License for more details.                       *)
+(*                                                                               *)
+(*    You should have received a copy of the GNU Library General Public          *)
+(*    License along with this program; if not, write to the Free Software        *)
+(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
+(*    02111-1307  USA                                                            *)
+(*                                                                               *)
+(*    Contact: Maxence.Guesdon@inria.fr                                          *)
+(*                                                                               *)
+(*********************************************************************************)
 
 (** Okey interface. 
 
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index 25167865..ffedcfff 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: constrextern.ml,v 1.85.2.7 2006/01/05 12:00:35 herbelin Exp $ *)
+(* $Id: constrextern.ml 9226 2006-10-09 16:11:01Z herbelin $ *)
 
 (*i*)
 open Pp
@@ -25,8 +25,9 @@ open Topconstr
 open Rawterm
 open Pattern
 open Nametab
-open Symbols
+open Notation
 open Reserve
+open Detyping
 (*i*)
 
 (* Translation from rawconstr to front constr *)
@@ -54,7 +55,7 @@ let print_coercions = ref false
 (* This forces printing universe names of Type{.} *)
 let print_universes = ref false
 
-(* This suppresses printing of numeral and symbols *)
+(* This suppresses printing of primitive tokens (e.g. numeral) and symbols *)
 let print_no_symbol = ref false
 
 (* This governs printing of projections using the dot notation symbols *)
@@ -69,13 +70,6 @@ let with_universes f = Options.with_option print_universes f
 let without_symbols f = Options.with_option print_no_symbol f
 let with_meta_as_hole f = Options.with_option print_meta_as_hole f
 
-(* For the translator *)
-let temporary_implicits_out = ref []
-let set_temporary_implicits_out l = temporary_implicits_out := l
-let get_temporary_implicits_out id =
-  try List.assoc id !temporary_implicits_out
-  with Not_found -> []
-
 (**********************************************************************)
 (* Various externalisation functions *)
 
@@ -83,9 +77,13 @@ let insert_delimiters e = function
   | None -> e
   | Some sc -> CDelimiters (dummy_loc,sc,e)
 
-let insert_pat_delimiters e = function
-  | None -> e
-  | Some sc -> CPatDelimiters (dummy_loc,sc,e)
+let insert_pat_delimiters loc p = function
+  | None -> p
+  | Some sc -> CPatDelimiters (loc,sc,p)
+
+let insert_pat_alias loc p = function
+  | Anonymous -> p
+  | Name id -> CPatAlias (loc,p,id)
 
 (**********************************************************************)
 (* conversion of references                                           *)
@@ -96,8 +94,7 @@ let ids_of_ctxt ctxt =
        (function c -> match kind_of_term c with
 	  | Var id -> id
 	  | _ ->
-       error
-       "Termast: arbitrary substitution of references not yet implemented")
+       error "arbitrary substitution of references not implemented")
      ctxt)
 
 let idopt_of_name = function 
@@ -114,7 +111,7 @@ let extern_evar loc n =
 
 let raw_string_of_ref = function
   | ConstRef kn -> 
-      "CONST("^(string_of_kn kn)^")"
+      "CONST("^(string_of_con kn)^")"
   | IndRef (kn,i) ->
       "IND("^(string_of_kn kn)^","^(string_of_int i)^")"
   | ConstructRef ((kn,i),j) -> 
@@ -123,863 +120,8 @@ let raw_string_of_ref = function
   | VarRef id -> 
       "SECVAR("^(string_of_id id)^")"
 
-(* v7->v8 translation *)
-
-let name_app f = function
-  | Name id -> Name (f id)
-  | Anonymous -> Anonymous
-
-let rec translate_ident_string = function
-    (* translate keyword *)
-  | ("at" | "IF" | "forall" | "fun" | "match" | "fix" | "cofix" | "for" | "let"
-    | "if"  | "then" | "else" | "return" | "mod" | "where" 
-    | "exists" | "exists2" | "using" as s) ->
-      let s' = s^"_" in
-      msgerrnl
-      (str ("Warning: '"^
-          s^"' is now a keyword; it has been translated to '"^s'^"'"));
-      s'
-(* Le conflit est en fait surtout avec Eval dans Definition et c'est gere dans
-   Ppconstrnew
-  | "eval" as s ->
-      let s' = s^"_" in
-      msgerrnl
-      (str ("Warning: '"^
-          s^"' is a conflicting ident; it has been translated to '"^s'^"'"));
-      s'
-*)
-
-  (* avoid _ *)
-  | "_" -> 
-      msgerrnl (str 
-        "Warning: '_' is no longer an ident; it has been translated to 'x_'");
-      "x_"
-  (* avoid @ *)
-  | s when String.contains s '@' ->
-      let n = String.index s '@' in 
-      translate_ident_string
-      (String.sub s 0 n ^ "'at'" ^ String.sub s (n+1) (String.length s -n-1))
-  | s -> s
-
-let translate_ident id =
-  id_of_string (translate_ident_string (string_of_id id))
-
-let is_coq_root d =
-  let d = repr_dirpath d in d <> [] & string_of_id (list_last d) = "Coq"
-
-let is_dir dir s =
-  let d = repr_dirpath dir in
-  d <> [] & string_of_id (List.hd d) = s
-
-let is_module m = is_dir (Lib.library_dp()) m
-
-let bp = ["BinPos"]
-let bz = ["BinInt"]
-let bn = ["BinNat"]
-let pn = ["nat"]
-let zc = ["Zcompare"]
-let lo = ["Logic"]
-let da = ["Datatypes"]
-let zabs = ["Zabs"]
-let zo = ["Zorder"]
-let zn = ["Znat"]
-let wz = ["Wf_Z"]
-let mu = ["Mult"]
-let pl = ["Plus"]
-let mi = ["Minus"]
-let le = ["Le"]
-let gt = ["Gt"]
-let lt = ["Lt"]
-let be = ["Between"]
-let bo = ["Bool"]
-let c dir = 
-  let d = repr_dirpath dir in
-  if d = [] then [] else [string_of_id (List.hd d)]
-
-let translation_table = [
-  (* ZArith *)
-"double_moins_un", (bp,"Pdouble_minus_one");
-"double_moins_deux", (bp,"Pdouble_minus_two");
-"is_double_moins_un", (bp,"Psucc_o_double_minus_one_eq_xO");
-"double_moins_un_add_un_xI", (bp,"Pdouble_minus_one_o_succ_eq_xI");
-"add_un_Zs", (bz,"Zpos_succ_morphism");
-"entier", (bn,"N");
-"entier_of_Z", (bz,"Zabs_N");
-"Z_of_entier", (bz,"Z_of_N");
-"SUPERIEUR", (da,"Gt");
-"EGAL", (da,"Eq");
-"INFERIEUR", (da,"Lt");
-"add", (bp,"Pplus");
-"add_carry", (bp,"Pplus_carry");
-"add_assoc", (bp,"Pplus_assoc");
-"add_sym", (bp,"Pplus_comm");
-"add_x_x", (bp,"Pplus_diag");
-"add_carry_add", (bp,"Pplus_carry_plus");
-"simpl_add_r", (bp,"Pplus_reg_r");
-"simpl_add_l", (bp,"Pplus_reg_l");
-"simpl_add_carry_r", (bp,"Pplus_carry_reg_r");
-"simpl_add_carry_l", (bp,"Pplus_carry_reg_l");
-"simpl_times_r", (bp,"Pmult_reg_r");
-"simpl_times_l", (bp,"Pmult_reg_l");
-(*
-"xO_xI_add_double_moins_un", (bp,"xO_xI_plus_double_minus_one");
-*)
-"double_moins_un_plus_xO_double_moins_un",
-  (bp,"Pdouble_minus_one_plus_xO_double_minus_one");
-"add_xI_double_moins_un", (bp,"Pplus_xI_double_minus_one");
-"add_xO_double_moins_un", (bp,"Pplus_xO_double_minus_one");
-"iter_pos_add", (bp,"iter_pos_plus");
-"add_no_neutral", (bp,"Pplus_no_neutral");
-"add_carry_not_add_un", (bp,"Pplus_carry_no_neutral");
-"times_add_distr", (bp,"Pmult_plus_distr_l");
-"times_add_distr_l", (bp,"Pmult_plus_distr_r");
-"times_true_sub_distr", (bp,"Pmult_minus_distr_l");
-"times_sym", (bp,"Pmult_comm");
-"times_assoc", (bp,"Pmult_assoc");
-"times_convert", (bp,"nat_of_P_mult_morphism");
-"true_sub", (bp,"Pminus");
-"times_x_1", (bp,"Pmult_1_r");
-"times_x_double", (bp,"Pmult_xO_permute_r"); 
-   (* Changer en Pmult_xO_distrib_r_reverse *)
-"times_x_double_plus_one", (bp,"Pmult_xI_permute_r"); (* Changer ? *)
-"times_discr_xO_xI", (bp,"Pmult_xI_mult_xO_discr");
-"times_discr_xO", (bp,"Pmult_xO_discr");
-"times_one_inversion_l", (bp,"Pmult_1_inversion_l");
-"true_sub_convert", (bp,"nat_of_P_minus_morphism");
-"compare_true_sub_right", (bp,"Pcompare_minus_r");
-"compare_true_sub_left", (bp,"Pcompare_minus_l");
-"sub_add", (bp,"Pplus_minus" (* similar to le_plus_minus in Arith *));
-"sub_add_one", (bp,"Ppred_succ");
-"add_sub_one", (bp,"Psucc_pred");
-"add_un", (bp,"Psucc");
-"add_un_discr", (bp,"Psucc_discr");
-"add_un_not_un", (bp,"Psucc_not_one");
-"add_un_inj", (bp,"Psucc_inj");
-"xI_add_un_xO", (bp,"xI_succ_xO");
-"ZL12", (bp,"Pplus_one_succ_r");
-"ZL12bis", (bp,"Pplus_one_succ_l");
-"ZL13", (bp,"Pplus_carry_spec");
-      (* Changer en Pplus_succ_distrib_r_reverse ? *)
-"ZL14", (bp,"Pplus_succ_permute_r");
-      (* Changer en Plus_succ_distrib_l_reverse *)
-"ZL14bis", (bp,"Pplus_succ_permute_l");
-"sub_un", (bp,"Ppred");
-"sub_pos", (bp,"Pminus_mask");
-"sub_pos_x_x", (bp,"Pminus_mask_diag");
-(*"sub_pos_x_x", (bp,"Pminus_mask_diag");*)
-"sub_pos_SUPERIEUR", (bp,"Pminus_mask_Gt");
-"sub_neg", (bp,"Pminus_mask_carry");
-"Zdiv2_pos", (bp,"Pdiv2");
-"Pdiv2", (["Zbinary"],"Zdiv2_ge_compat");
-"ZERO", (bz,"Z0");
-"POS", (bz,"Zpos");
-"NEG", (bz,"Zneg");
-"Nul", (bn,"N0");
-"Pos", (bn,"Npos");
-"Un_suivi_de", (bn,"Ndouble_plus_one");
-"Zero_suivi_de", (bn,"Ndouble");
-"Un_suivi_de_mask", (bp,"Pdouble_plus_one_mask");
-"Zero_suivi_de_mask", (bp,"Pdouble_mask");
-"ZS", (bp,"double_eq_zero_inversion");
-"US", (bp,"double_plus_one_zero_discr");
-"USH", (bp,"double_plus_one_eq_one_inversion");
-"ZSH", (bp,"double_eq_one_discr");
-"ZPminus_add_un_permute", (bz,"ZPminus_succ_permute");
-"ZPminus_add_un_permute_Zopp", (bz,"ZPminus_succ_permute_opp");
-"ZPminus_double_moins_un_xO_add_un", (bz,"ZPminus_double_minus_one_xO_succ");
-"ZL1", (bp,"xO_succ_permute");  (* ?? *)
-"Zplus_assoc_r", (bz,"Zplus_assoc_reverse");
-"Zplus_sym", (bz,"Zplus_comm");
-"Zero_left", (bz,"Zplus_0_l");
-"Zero_right", (bz,"Zplus_0_r");
-"Zplus_n_O", (bz,"Zplus_0_r_reverse");
-"Zplus_unit_left", (bz,"Zplus_0_simpl_l");
-"Zplus_unit_right", (bz,"Zplus_0_simpl_l_reverse");
-"Zplus_Zopp_expand", (bz,"Zplus_opp_expand");
-"Zn_Sn", (bz,"Zsucc_discr");
-"Zs", (bz,"Zsucc");
-"Psucc_Zs", (bz,"Zpos_succ_permute");
-"Zs_pred", (bz,"Zsucc_pred");
-"Zpred_Sn", (bz,"Zpred_succ");
-"Zminus_n_O", (bz,"Zminus_0_l_reverse");
-"Zminus_n_n", (bz,"Zminus_diag_reverse");
-"Zminus_Sn_m", (bz,"Zminus_succ_l");
-"Zeq_Zminus", (bz,"Zeq_minus");
-"Zminus_Zeq", (bz,"Zminus_eq");
-"Zplus_minus", (bz,"Zplus_minus_eq");
-"Zminus_plus", (bz,"Zminus_plus");
-"Zminus_plus_simpl", (bz,"Zminus_plus_simpl_l_reverse");
-"Zminus_Zplus_compatible", (bz,"Zminus_plus_simpl_r");
-"Zle_plus_minus", (bz,"Zplus_minus");
-"Zopp_Zplus", (bz,"Zopp_plus_distr");
-"Zopp_Zopp", (bz,"Zopp_involutive");
-"Zopp_NEG", (bz,"Zopp_neg");
-"Zopp_Zdouble", (bz,"Zopp_double");
-"Zopp_Zdouble_plus_one", (bz,"Zopp_double_plus_one");
-"Zopp_Zdouble_minus_one", (bz,"Zopp_double_minus_one");
-"Zplus_inverse_r", (bz,"Zplus_opp_r");
-"Zplus_inverse_l", (bz,"Zplus_opp_l");
-"Zplus_S_n", (bz,"Zplus_succ_l");
-"Zplus_n_Sm", (bz,"Zplus_succ_r");
-"Zplus_Snm_nSm", (bz,"Zplus_succ_comm");
-"Zmult_assoc_r", (bz,"Zmult_assoc_reverse");
-"Zmult_sym", (bz,"Zmult_comm");
-"Zmult_eq", (bz,"Zmult_integral_l");
-"Zmult_zero", (bz,"Zmult_integral");
-"Zero_mult_left", (bz,"Zmult_0_l");
-"Zero_mult_right", (bz,"Zmult_0_r");
-"Zmult_1_n", (bz,"Zmult_1_l");
-"Zmult_n_1", (bz,"Zmult_1_r");
-"Zmult_n_O", (bz,"Zmult_0_r_reverse");
-"Zopp_one", (bz,"Zopp_eq_mult_neg_1");
-"Zopp_Zmult", (bz,"Zopp_mult_distr_l_reverse");
-"Zopp_Zmult_r", (bz,"Zopp_mult_distr_r");
-"Zopp_Zmult_l", (bz,"Zopp_mult_distr_l");
-"Zmult_Zopp_Zopp", (bz,"Zmult_opp_opp");
-"Zmult_Zopp_left", (bz,"Zmult_opp_comm");
-"Zmult_Zplus_distr", (bz,"Zmult_plus_distr_r");
-"Zmult_plus_distr", (bz,"Zmult_plus_distr_r");
-"Zmult_Zminus_distr_r", (bz,"Zmult_minus_distr_l");
-"Zmult_Zminus_distr_l", (bz,"Zmult_minus_distr_r");
-"Zcompare_Zplus_compatible", (zc,"Zcompare_plus_compat");
-"Zcompare_Zplus_compatible2", (zc,"Zplus_compare_compat");
-"Zcompare_Zmult_compatible", (zc,"Zcompare_mult_compat");
-"inject_nat", (bz,"Z_of_nat");
-"inject_nat_complete", (wz,"Z_of_nat_complete");
-"inject_nat_complete_inf", (wz,"Z_of_nat_complete_inf");
-"inject_nat_prop", (wz,"Z_of_nat_prop");
-"inject_nat_set", (wz,"Z_of_nat_set");
-"convert", (bp,"nat_of_P");
-"anti_convert", (bp,"P_of_succ_nat");
-"positive_to_nat", (bp,"Pmult_nat");
-"Zopp_intro", (bz,"Zopp_inj");
-"plus_iter_add", (bp,"plus_iter_eq_plus");
-"compare", (bp,"Pcompare");
-"iter_convert", (["Zmisc"],"iter_nat_of_P");
-"ZLSI", (bp,"Pcompare_Gt_Lt");
-"ZLIS", (bp,"Pcompare_Lt_Gt");
-"ZLII", (bp,"Pcompare_Lt_Lt");
-"ZLSS", (bp,"Pcompare_Gt_Gt");
-  (* Pnat *)
-"convert_intro", (pn,"nat_of_P_inj");
-"convert_add", (pn,"nat_of_P_plus_morphism");
-"convert_add_un", (pn,"Pmult_nat_succ_morphism");
-"cvt_add_un", (pn,"nat_of_P_succ_morphism");
-"convert_add_carry", (pn,"Pmult_nat_plus_carry_morphism");
-"compare_convert_O", (pn,"lt_O_nat_of_P");
-"add_verif", (pn,"Pmult_nat_l_plus_morphism");
-"ZL2", (pn,"Pmult_nat_r_plus_morphism");
-"compare_positive_to_nat_O", (pn,"le_Pmult_nat");
-(* Trop spécifique ?
-"ZL6", (pn,"Pmult_nat_plus_shift_morphism");
-*)
-"ZL15", (pn,"Pplus_carry_pred_eq_plus");
-"cvt_carry", (pn,"nat_of_P_plus_carry_morphism");
-"compare_convert1", (pn,"Pcompare_not_Eq");
-"compare_convert_INFERIEUR", (pn,"nat_of_P_lt_Lt_compare_morphism");
-"compare_convert_SUPERIEUR", (pn,"nat_of_P_gt_Gt_compare_morphism");
-"compare_convert_EGAL", (pn,"Pcompare_Eq_eq");
-"convert_compare_INFERIEUR", (pn,"nat_of_P_lt_Lt_compare_complement_morphism");
-"convert_compare_SUPERIEUR", (pn,"nat_of_P_gt_Gt_compare_complement_morphism");
-"convert_compare_EGAL", (pn,"Pcompare_refl");
-"bij1", (pn,"nat_of_P_o_P_of_succ_nat_eq_succ");
-"bij2", (pn,"P_of_succ_nat_o_nat_of_P_eq_succ");
-"bij3", (pn,"pred_o_P_of_succ_nat_o_nat_of_P_eq_id");
-  (* Zcompare *)
-"Zcompare_EGAL", (zc,"Zcompare_Eq_iff_eq");
-"Zcompare_EGAL_eq", (zc,"Zcompare_Eq_eq");
-"Zcompare_x_x", (zc,"Zcompare_refl");
-"Zcompare_et_un", (zc,"Zcompare_Gt_not_Lt");
-"Zcompare_trans_SUPERIEUR", (zc,"Zcompare_Gt_trans");
-"Zcompare_n_S", (zc,"Zcompare_succ_compat");
-"SUPERIEUR_POS", (zc,"Zcompare_Gt_spec");
-"Zcompare_ANTISYM", (zc,"Zcompare_Gt_Lt_antisym");
-"Zcompare_Zs_SUPERIEUR", (zc,"Zcompare_succ_Gt");
-"Zcompare_Zopp", (zc,"Zcompare_opp");
-"POS_inject", (zn,"Zpos_eq_Z_of_nat_o_nat_of_P");
-"absolu", (bz,"Zabs_nat");
-"absolu_lt", (zabs,"Zabs_nat_lt" (* "Zabs_nat_lt_morphism_pos" ? *));
-"Zeq_add_S", (bz,"Zsucc_inj");
-"Znot_eq_S", (bz,"Zsucc_inj_contrapositive");
-"Zeq_S", (bz,"Zsucc_eq_compat");
-"Zsimpl_plus_l", (bz,"Zplus_reg_l");
-"Zplus_simpl", (bz,"Zplus_eq_compat");
-"POS_gt_ZERO", (zo,"Zgt_pos_0");
-"ZERO_le_POS", (zo,"Zle_0_pos");
-"ZERO_le_inj", (zo,"Zle_0_nat");
-"NEG_lt_ZERO", (zo,"Zlt_neg_0");
-"Zlt_ZERO_pred_le_ZERO", (zo,"Zlt_0_le_0_pred");
-"POS_xI", (bz,"Zpos_xI");
-"POS_xO", (bz,"Zpos_xO");
-"NEG_xI", (bz,"Zneg_xI");
-"NEG_xO", (bz,"Zneg_xO");
-"POS_add", (bz,"Zpos_plus_distr");
-"NEG_add", (bz,"Zneg_plus_distr");
-  (* Z Orders *)
-"not_Zge", (zo,"Znot_ge_lt");
-"not_Zlt", (zo,"Znot_lt_ge");
-"not_Zle", (zo,"Znot_le_gt");
-"not_Zgt", (zo,"Znot_gt_le");
-"Zgt_not_sym", (zo,"Zgt_asym");
-"Zlt_not_sym", (zo,"Zlt_asym");
-"Zlt_n_n", (zo,"Zlt_irrefl");
-"Zgt_antirefl", (zo,"Zgt_irrefl");
-"Zgt_reg_l", (zo,"Zplus_gt_compat_l");
-"Zgt_reg_r", (zo,"Zplus_gt_compat_r");
-"Zlt_reg_l", (zo,"Zplus_lt_compat_l");
-"Zlt_reg_r", (zo,"Zplus_lt_compat_r");
-"Zle_reg_l", (zo,"Zplus_le_compat_l");
-"Zle_reg_r", (zo,"Zplus_le_compat_r");
-"Zlt_le_reg", (zo,"Zplus_lt_le_compat");
-"Zle_lt_reg", (zo,"Zplus_le_lt_compat");
-"Zle_plus_plus", (zo,"Zplus_le_compat");
-"Zlt_Zplus", (zo,"Zplus_lt_compat");
-"Zle_O_plus", (zo,"Zplus_le_0_compat");
-"Zle_mult_simpl", (zo,"Zmult_le_reg_r");
-"Zge_mult_simpl", (zo,"Zmult_ge_reg_r");
-"Zgt_mult_simpl", (zo,"Zmult_gt_reg_r");
-"Zsimpl_gt_plus_l", (zo,"Zplus_gt_reg_l");
-"Zsimpl_gt_plus_r", (zo,"Zplus_gt_reg_r");
-"Zsimpl_le_plus_l", (zo,"Zplus_le_reg_l");
-"Zsimpl_le_plus_r", (zo,"Zplus_le_reg_r");
-"Zsimpl_lt_plus_l", (zo,"Zplus_lt_reg_l");
-"Zsimpl_lt_plus_r", (zo,"Zplus_lt_reg_r");
-"Zlt_Zmult_right2", (zo,"Zmult_gt_0_lt_reg_r");
-"Zlt_Zmult_right", (zo,"Zmult_gt_0_lt_compat_r");
-"Zle_Zmult_right2", (zo,"Zmult_gt_0_le_reg_r");
-"Zle_Zmult_right", (zo,"Zmult_gt_0_le_compat_r");
-"Zgt_Zmult_right", (zo,"Zmult_gt_compat_r");
-"Zgt_Zmult_left", (zo,"Zmult_gt_compat_l");
-"Zlt_Zmult_left", (zo,"Zmult_gt_0_lt_compat_l");
-"Zcompare_Zmult_right", (zc,"Zmult_compare_compat_r");
-"Zcompare_Zmult_left", (zc,"Zmult_compare_compat_l");
-"Zplus_Zmult_2", (bz,"Zplus_diag_eq_mult_2");
-"Zmult_Sm_n", (bz,"Zmult_succ_l_reverse");
-"Zmult_n_Sm", (bz,"Zmult_succ_r_reverse");
-"Zmult_le", (zo,"Zmult_le_0_reg_r");
-"Zmult_reg_left", (bz,"Zmult_reg_l");
-"Zmult_reg_right", (bz,"Zmult_reg_r");
-"Zle_ZERO_mult", (zo,"Zmult_le_0_compat");
-"Zgt_ZERO_mult", (zo,"Zmult_gt_0_compat");
-"Zle_mult", (zo,"Zmult_gt_0_le_0_compat");
-"Zmult_lt", (zo,"Zmult_gt_0_lt_0_reg_r");
-"Zmult_gt", (zo,"Zmult_gt_0_reg_l");
-"Zle_Zmult_pos_right", (zo,"Zmult_le_compat_r");
-"Zle_Zmult_pos_left", (zo,"Zmult_le_compat_l");
-"Zge_Zmult_pos_right", (zo,"Zmult_ge_compat_r");
-"Zge_Zmult_pos_left", (zo,"Zmult_ge_compat_l");
-"Zge_Zmult_pos_compat", (zo,"Zmult_ge_compat");
-"Zlt_Zcompare", (zo,"Zlt_compare");
-"Zle_Zcompare", (zo,"Zle_compare");
-"Zgt_Zcompare", (zo,"Zgt_compare");
-"Zge_Zcompare", (zo,"Zge_compare");
-  (* ex-IntMap *)
-"convert_xH", (pn,"nat_of_P_xH");
-"convert_xO", (pn,"nat_of_P_xO");
-"convert_xI", (pn,"nat_of_P_xI");
-"positive_to_nat_mult", (pn,"Pmult_nat_mult_permute");
-"positive_to_nat_2", (pn,"Pmult_nat_2_mult_2_permute");
-"positive_to_nat_4", (pn,"Pmult_nat_4_mult_2_permute");
-  (* ZArith and Arith orders *)
-"Zle_refl", (zo,"Zeq_le");
-"Zle_n", (zo,"Zle_refl");
-"Zle_trans_S", (zo,"Zle_succ_le");
-"Zgt_trans_S", (zo,"Zge_trans_succ");
-"Zgt_S", (zo,"Zgt_succ_gt_or_eq");
-"Zle_Sn_n", (zo,"Znot_le_succ");
-"Zlt_n_Sn", (zo,"Zlt_succ");
-"Zlt_S", (zo,"Zlt_lt_succ");
-"Zlt_n_S", (zo,"Zsucc_lt_compat");
-"Zle_n_S", (zo,"Zsucc_le_compat");
-"Zgt_n_S", (zo,"Zsucc_gt_compat");
-"Zlt_S_n", (zo,"Zsucc_lt_reg");
-"Zgt_S_n", (zo,"Zsucc_gt_reg");
-"Zle_S_n", (zo,"Zsucc_le_reg");
-"Zle_0_plus", (zo,"Zplus_le_0_compat");
-"Zgt_Sn_n", (zo,"Zgt_succ");
-"Zgt_le_S", (zo,"Zgt_le_succ");
-"Zgt_S_le", (zo,"Zgt_succ_le");
-"Zle_S_gt", (zo,"Zlt_succ_gt");
-"Zle_gt_S", (zo,"Zlt_gt_succ");
-"Zgt_pred", (zo,"Zgt_succ_pred");
-"Zlt_pred", (zo,"Zlt_succ_pred");
-"Zgt0_le_pred", (zo,"Zgt_0_le_0_pred");
-"Z_O_1", (zo,"Zlt_0_1");
-"Zle_NEG_POS", (zo,"Zle_neg_pos");
-"Zle_n_Sn", (zo,"Zle_succ");
-"Zle_pred_n", (zo,"Zle_pred");
-"Zlt_pred_n_n", (zo,"Zlt_pred");
-"Zlt_le_S", (zo,"Zlt_le_succ");
-"Zlt_n_Sm_le", (zo,"Zlt_succ_le");
-"Zle_lt_n_Sm", (zo,"Zle_lt_succ");
-"Zle_le_S", (zo,"Zle_le_succ");
-"Zlt_minus", (zo,"Zlt_minus_simpl_swap");
-"le_trans_S", (le,"le_Sn_le");
-(* Znumtheory *)
-"Zdivide_Zmod", ([],"Zdivide_mod");
-"Zmod_Zdivide", ([],"Zmod_divide");
-"Zdivide_mult_left", ([],"Zmult_divide_compat_l");
-"Zdivide_mult_right", ([],"Zmult_divide_compat_r");
-"Zdivide_opp", ([],"Zdivide_opp_r");
-"Zdivide_opp_rev", ([],"Zdivide_opp_r_rev");
-"Zdivide_opp_left", ([],"Zdivide_opp_l");
-"Zdivide_opp_left_rev", ([],"Zdivide_opp_l_rev");
-"Zdivide_right", ([],"Zdivide_mult_r");
-"Zdivide_left", ([],"Zdivide_mult_l");
-"Zdivide_plus", ([],"Zdivide_plus_r");
-"Zdivide_minus", ([],"Zdivide_minus_l");
-"Zdivide_a_ab", ([],"Zdivide_factor_r");
-"Zdivide_a_ba", ([],"Zdivide_factor_l");
-(* Arith *)
-(* Peano.v
-"plus_n_O", ("plus_0_r_reverse");
-"plus_O_n", ("plus_0_l");
-*)
-"plus_assoc_l", (pl,"plus_assoc");
-"plus_assoc_r", (pl,"plus_assoc_reverse");
-"plus_sym", (pl,"plus_comm");
-"mult_sym", (mu,"mult_comm");
-"max_sym", (["Max"],"max_comm");
-"min_sym", (["Min"],"min_comm");
-"gt_not_sym", (gt,"gt_asym");
-"lt_not_sym", (lt,"lt_asym");
-"gt_antirefl", (gt,"gt_irrefl");
-"lt_n_n", (lt,"lt_irrefl");
-(* Trop utilisé dans CoqBook | "le_n" -> "le_refl"*)
-"simpl_plus_l", (pl,"plus_reg_l");
-"simpl_plus_r", (pl,"plus_reg_r");
-"fact_growing", (["Factorial"],"fact_le");
-"mult_assoc_l", (mu,"mult_assoc");
-"mult_assoc_r", (mu,"mult_assoc_reverse");
-"mult_plus_distr", (mu,"mult_plus_distr_r");
-"mult_plus_distr_r", (mu,"mult_plus_distr_l");
-"mult_minus_distr", (mu,"mult_minus_distr_r");
-"mult_1_n", (mu,"mult_1_l");
-"mult_n_1", (mu,"mult_1_r");
-(* Peano.v
-"mult_n_O", ("mult_O_r_reverse");
-"mult_n_Sm", ("mult_S_r_reverse");
-*)
-"mult_le", (mu,"mult_le_compat_l");
-"le_mult_right", (mu,"mult_le_compat_r");
-"le_mult_mult", (mu,"mult_le_compat");
-"mult_lt", (mu,"mult_S_lt_compat_l");
-"lt_mult_right", (mu,"mult_lt_compat_r");
-"mult_le_conv_1", (mu,"mult_S_le_reg_l");
-"exists", (be,"exists_between");
-"IHexists", ([],"IHexists_between");
-(* Peano.v
-"pred_Sn", ("pred_S");
-*)
-"inj_minus_aux", (mi,"not_le_minus_0");
-"minus_x_x", (mi,"minus_diag");
-"minus_plus_simpl", (mi,"minus_plus_simpl_l_reverse");
-"gt_reg_l", (gt,"plus_gt_compat_l");
-"le_reg_l", (pl,"plus_le_compat_l");
-"le_reg_r", (pl,"plus_le_compat_r");
-"lt_reg_l", (pl,"plus_lt_compat_l");
-"lt_reg_r", (pl,"plus_lt_compat_r");
-"le_plus_plus", (pl,"plus_le_compat");
-"le_lt_plus_plus", (pl,"plus_le_lt_compat");
-"lt_le_plus_plus", (pl,"plus_lt_le_compat");
-"lt_plus_plus", (pl,"plus_lt_compat");
-"plus_simpl_l", (pl,"plus_reg_l");
-"simpl_gt_plus_l", (pl,"plus_gt_reg_l");
-"simpl_le_plus_l", (pl,"plus_le_reg_l");
-"simpl_lt_plus_l", (pl,"plus_lt_reg_l");
-(* Noms sur le principe de ceux de Z
-"le_n_S", ("S_le_compat");
-"le_n_Sn", ("le_S");
-(*"le_O_n", ("??" *));
-"le_pred_n", ("le_pred");
-"le_trans_S", ("le_S_le");
-"le_S_n", ("S_le_reg");
-"le_Sn_O", ("not_le_S_O");
-"le_Sn_n", ("not_le_S");
-*)
-  (* Init *)
-"IF", (lo,"IF_then_else");
-  (* Lists *)
-"idempot_rev", (["List"],"rev_involutive");
-"forall", (["Streams"],"HereAndFurther");
-  (* Bool *)
-"orb_sym", (bo,"orb_comm");
-"andb_sym", (bo,"andb_comm");
-  (* Ring *)
-"SR_plus_sym", (["Ring_theory"],"SR_plus_comm");
-"SR_mult_sym", (["Ring_theory"],"SR_mult_comm");
-"Th_plus_sym", (["Ring_theory"],"Th_plus_comm");
-"Th_mul_sym", (["Ring_theory"],"Th_mult_comm");
-"SSR_plus_sym", (["Setoid_ring_theory"],"SSR_plus_comm");
-"SSR_mult_sym", (["Setoid_ring_theory"],"SSR_mult_comm");
-"STh_plus_sym", (["Setoid_ring_theory"],"STh_plus_comm");
-"STh_mul_sym", (["Setoid_ring_theory"],"STh_mult_comm");
-  (* Reals *)
-(*
-"Rabsolu", ("Rabs");
-"Rabsolu_pos_lt", ("Rabs_pos_lt");
-"Rabsolu_no_R0", ("Rabs_no_R0");
-"Rabsolu_Rabsolu", ("Rabs_Rabs");
-"Rabsolu_mult", ("Rabs_mult");
-"Rabsolu_triang", ("Rabs_triang");
-"Rabsolu_Ropp", ("Rabs_Ropp");
-"Rabsolu_right", ("Rabs_right");
-...
-"case_Rabsolu", ("case_Rabs");
-"Pow_Rabsolu", ("Pow_Rabs");
-...
-*)
-(* Raxioms *)
-"complet", ([],"completeness");
-"complet_weak", ([],"completeness_weak");
-"Rle_sym1", ([],"Rle_ge");
-"Rmin_sym", ([],"Rmin_comm");
-"Rplus_sym", ([],"Rplus_comm");
-"Rmult_sym", ([],"Rmult_comm");
-"Rsqr_times", ([],"Rsqr_mult");
-"sqrt_times", ([],"sqrt_mult");
-"Rmult_1l", ([],"Rmult_1_l");
-"Rplus_Ol", ([],"Rplus_0_l");
-"Rplus_Ropp_r", ([],"Rplus_opp_r");
-"Rmult_Rplus_distr", ([],"Rmult_plus_distr_l");
-"Rlt_antisym", ([],"Rlt_asym");
-(* RIneq *)
-"Rlt_antirefl", ([],"Rlt_irrefl");
-"Rlt_compatibility", ([],"Rplus_lt_compat_l");
-"Rgt_plus_plus_r", ([],"Rplus_gt_compat_l");
-"Rgt_r_plus_plus", ([],"Rplus_gt_reg_l");
-"Rge_plus_plus_r", ([],"Rplus_ge_compat_l");
-"Rge_r_plus_plus", ([],"Rplus_ge_reg_l");
-(* Si on en change un, il faut changer tous les autres R*_monotony *)
-"Rlt_monotony", ([],"Rmult_lt_compat_l");
-"Rlt_monotony_r", ([],"Rmult_lt_compat_r");
-"Rlt_monotony_contra", ([],"Rmult_lt_reg_l");
-(*"Rlt_monotony_rev", ([],"Rmult_lt_reg_l");*)
-"Rlt_anti_monotony", ([],"Rmult_lt_gt_compat_neg_l");
-"Rle_monotony", ([],"Rmult_le_compat_l");
-"Rle_monotony_r", ([],"Rmult_le_compat_r");
-"Rle_monotony_contra", ([],"Rmult_le_reg_l");
-"Rle_anti_monotony1", ([],"Rmult_le_compat_neg_l");
-"Rle_anti_monotony", ([],"Rmult_le_ge_compat_neg_l");
-"Rge_monotony", ([],"Rmult_ge_compat_r");
-"Rge_ge_eq", ([],"Rge_antisym");
-(* Le reste de RIneq *)
-"imp_not_Req", ([],"Rlt_dichotomy_converse");
-"Req_EM", ([],"Req_dec");
-"total_order", ([],"Rtotal_order");
-"not_Req", ([],"Rdichotomy");
-(* "Rlt_le" -> c dir,"Rlt_le_weak" ? *)
-"not_Rle", ([],"Rnot_le_lt");
-"not_Rge", ([],"Rnot_ge_lt");
-"Rlt_le_not", ([],"Rlt_not_le");
-"Rle_not", ([],"Rgt_not_le");
-"Rle_not_lt", ([],"Rle_not_lt");
-"Rlt_ge_not", ([],"Rlt_not_ge");
-"eq_Rle", ([],"Req_le");
-"eq_Rge", ([],"Req_ge");
-"eq_Rle_sym", ([],"Req_le_sym");
-"eq_Rge_sym", ([],"Req_ge_sym");
-(* "Rle_le_eq" -> ?   x<=y/\y<=x <-> x=y *)
-"Rlt_rew", ([],"Rlt_eq_compat");
-"total_order_Rlt", ([],"Rlt_dec");
-"total_order_Rle", ([],"Rle_dec");
-"total_order_Rgt", ([],"Rgt_dec");
-"total_order_Rge", ([],"Rge_dec");
-"total_order_Rlt_Rle", ([],"Rlt_le_dec");
-(* "Rle_or_lt" -> c dir,"Rle_or_lt"*)
-"total_order_Rle_Rlt_eq", ([],"Rle_lt_or_eq_dec");
-(* "inser_trans_R" -> c dir,"Rle_lt_inser_trans" ?*)
-(* "Rplus_ne" -> c dir,"Rplus_0_r_l" ? *)
-"Rplus_Or", ([],"Rplus_0_r");
-"Rplus_Ropp_l", ([],"Rplus_opp_l");
-"Rplus_Ropp", ([],"Rplus_opp_r_uniq");
-"Rplus_plus_r", ([],"Rplus_eq_compat_l");
-"r_Rplus_plus", ([],"Rplus_eq_reg_l");
-"Rplus_ne_i", ([],"Rplus_0_r_uniq");
-"Rmult_Or", ([],"Rmult_0_r");
-"Rmult_Ol", ([],"Rmult_0_l");
-(* "Rmult_ne" -> c dir,"Rmult_1_l_r" ? *)
-"Rmult_1r", ([],"Rmult_1_r");
-"Rmult_mult_r", ([],"Rmult_eq_compat_l");
-"r_Rmult_mult", ([],"Rmult_eq_reg_l");
-"without_div_Od", ([],"Rmult_integral");
-"without_div_Oi", ([],"Rmult_eq_0_compat");
-"without_div_Oi1", ([],"Rmult_eq_0_compat_r");
-"without_div_Oi2", ([],"Rmult_eq_0_compat_l");
-"without_div_O_contr", ([],"Rmult_neq_0_reg");
-"mult_non_zero", ([],"Rmult_integral_contrapositive");
-"Rmult_Rplus_distrl", ([],"Rmult_plus_distr_r");
-"Rsqr_O", ([],"Rsqr_0");
-"Rsqr_r_R0", ([],"Rsqr_0_uniq");
-"eq_Ropp", ([],"Ropp_eq_compat");
-"Ropp_O", ([],"Ropp_0");
-"eq_RoppO", ([],"Ropp_eq_0_compat");
-"Ropp_Ropp", ([],"Ropp_involutive");
-"Ropp_neq", ([],"Ropp_neq_0_compat");
-"Ropp_distr1", ([],"Ropp_plus_distr");
-"Ropp_mul1", ([],"Ropp_mult_distr_l_reverse");
-"Ropp_mul2", ([],"Rmult_opp_opp");
-"Ropp_mul3", ([],"Ropp_mult_distr_r_reverse");
-"minus_R0", ([],"Rminus_0_r");
-"Rminus_Ropp", ([],"Rminus_0_l");
-"Ropp_distr2", ([],"Ropp_minus_distr");
-"Ropp_distr3", ([],"Ropp_minus_distr'");
-"eq_Rminus", ([],"Rminus_diag_eq");
-"Rminus_eq", ([],"Rminus_diag_uniq");
-"Rminus_eq_right", ([],"Rminus_diag_uniq_sym");
-"Rplus_Rminus", ([],"Rplus_minus");
-(*
-"Rminus_eq_contra", ([],"Rminus_diag_neq");
-"Rminus_not_eq", ([],"Rminus_neq_diag_sym");
- "Rminus_not_eq_right" -> ?
-*)
-"Rminus_distr", ([],"Rmult_minus_distr_l");
-"Rinv_R1", ([],"Rinv_1");
-"Rinv_neq_R0", ([],"Rinv_neq_0_compat");
-"Rinv_Rinv", ([],"Rinv_involutive");
-"Rinv_Rmult", ([],"Rinv_mult_distr");
-"Ropp_Rinv", ([],"Ropp_inv_permute");
-(* "Rinv_r_simpl_r" -> OK ? *)
-(* "Rinv_r_simpl_l" -> OK ? *)
-(* "Rinv_r_simpl_m" -> OK ? *)
-"Rinv_Rmult_simpl", ([],"Rinv_mult_simpl"); (* ? *)
-"Rlt_compatibility_r", ([],"Rplus_lt_compat_r");
-"Rlt_anti_compatibility", ([],"Rplus_lt_reg_r");
-"Rle_compatibility", ([],"Rplus_le_compat_l");
-"Rle_compatibility_r", ([],"Rplus_le_compat_r");
-"Rle_anti_compatibility", ([],"Rplus_le_reg_l");
-(* "sum_inequa_Rle_lt" -> ? *)
-"Rplus_lt", ([],"Rplus_lt_compat");
-"Rplus_le", ([],"Rplus_le_compat");
-"Rplus_lt_le_lt", ([],"Rplus_lt_le_compat");
-"Rplus_le_lt_lt", ([],"Rplus_le_lt_compat");
-"Rgt_Ropp", ([],"Ropp_gt_lt_contravar");
-"Rlt_Ropp", ([],"Ropp_lt_gt_contravar");
-"Ropp_Rlt", ([],"Ropp_lt_cancel");  (* ?? *)
-"Rlt_Ropp1", ([],"Ropp_lt_contravar");
-"Rle_Ropp", ([],"Ropp_le_ge_contravar");
-"Ropp_Rle", ([],"Ropp_le_cancel");
-"Rle_Ropp1", ([],"Ropp_le_contravar");
-"Rge_Ropp", ([],"Ropp_ge_le_contravar");
-"Rlt_RO_Ropp", ([],"Ropp_0_lt_gt_contravar");
-"Rgt_RO_Ropp", ([],"Ropp_0_gt_lt_contravar");
-"Rle_RO_Ropp", ([],"Ropp_0_le_ge_contravar");
-"Rge_RO_Ropp", ([],"Ropp_0_ge_le_contravar");
-(* ... cf plus haut pour les lemmes intermediaires *)
-"Rle_Rmult_comp", ([],"Rmult_le_compat");
-   (* Expliciter que la contrainte est r2>0 dans r1<r2 et non 0<r1 ce
-      qui est plus général mais différent de Rmult_le_compat ? *)
-"Rmult_lt", ([],"Rmult_gt_0_lt_compat"); (* Hybride aussi *)
-"Rmult_lt_0", ([],"Rmult_ge_0_gt_0_lt_compat"); (* Un truc hybride *)
-(*
- "Rlt_minus" -> 
- "Rle_minus" -> 
- "Rminus_lt" -> 
- "Rminus_le" -> 
- "tech_Rplus" -> 
-*)
-"pos_Rsqr", ([],"Rle_0_sqr");
-"pos_Rsqr1", ([],"Rlt_0_sqr");
-"Rlt_R0_R1", ([],"Rlt_0_1");
-"Rle_R0_R1", ([],"Rle_0_1");
-"Rlt_Rinv", ([],"Rinv_0_lt_compat");
-"Rlt_Rinv2", ([],"Rinv_lt_0_compat");
-"Rinv_lt", ([],"Rinv_lt_contravar");
-"Rlt_Rinv_R1", ([],"Rinv_1_lt_contravar");
-"Rlt_not_ge", ([],"Rnot_lt_ge");
-"Rgt_not_le", ([],"Rnot_gt_le");
-(*
- "Rgt_ge" -> "Rgt_ge_weak" ?
-*)
-"Rlt_sym", ([],"Rlt_gt_iff");
-(* | "Rle_sym1" -> c dir,"Rle_ge" OK *)
-"Rle_sym2", ([],"Rge_le");
-"Rle_sym", ([],"Rle_ge_iff");
-(*
- "Rge_gt_trans" -> OK
- "Rgt_ge_trans" -> OK
- "Rgt_trans" -> OK
- "Rge_trans" -> OK
-*)
-"Rgt_RoppO", ([],"Ropp_lt_gt_0_contravar");
-"Rlt_RoppO", ([],"Ropp_gt_lt_0_contravar");
-"Rlt_r_plus_R1", ([],"Rle_lt_0_plus_1");
-"Rlt_r_r_plus_R1", ([],"Rlt_plus_1");
-(* "tech_Rgt_minus" -> ? *)
-(* OK, cf plus haut
-"Rgt_r_plus_plus", ([],"Rplus_gt_reg_l");
-"Rgt_plus_plus_r", ([],"Rplus_gt_compat_l");
-"Rge_plus_plus_r", ([],"Rplus_ge_compat_l");
-"Rge_r_plus_plus", ([],"Rplus_ge_reg_l");
-"Rge_monotony" ->  *)
-(*
- "Rgt_minus" -> 
- "minus_Rgt" -> 
- "Rge_minus" -> 
- "minus_Rge" -> 
-*)
-"Rmult_gt", ([],"Rmult_gt_0_compat");
-"Rmult_lt_pos", ([],"Rmult_lt_0_compat");  (* lt_0 ou 0_lt ?? *)
-"Rplus_eq_R0_l", ([],"Rplus_eq_0_l"); (* ? *)
-"Rplus_eq_R0", ([],"Rplus_eq_R0");
-"Rplus_Rsr_eq_R0_l", ([],"Rplus_sqr_eq_0_l");
-"Rplus_Rsr_eq_R0", ([],"Rplus_sqr_eq_0");
-(*
- "S_INR" -> 
- "S_O_plus_INR" -> 
- "plus_INR" -> 
- "minus_INR" -> 
- "mult_INR" -> 
- "lt_INR_0" -> 
- "lt_INR" -> 
- "INR_lt_1" -> 
- "INR_pos" -> 
- "pos_INR" -> 
- "INR_lt" -> 
- "le_INR" -> 
- "not_INR_O" -> 
- "not_O_INR" -> 
- "not_nm_INR" -> 
- "INR_eq" -> 
- "INR_le" -> 
- "not_1_INR" -> 
- "IZN" -> 
- "INR_IZR_INZ" -> 
- "plus_IZR_NEG_POS" -> 
- "plus_IZR" -> 
- "mult_IZR" -> 
- "Ropp_Ropp_IZR" -> 
- "Z_R_minus" -> 
- "lt_O_IZR" -> 
- "lt_IZR" -> 
- "eq_IZR_R0" -> 
- "eq_IZR" -> 
- "not_O_IZR" -> 
- "le_O_IZR" -> 
- "le_IZR" -> 
- "le_IZR_R1" -> 
- "IZR_ge" -> 
- "IZR_le" -> 
- "IZR_lt" -> 
- "one_IZR_lt1" -> 
- "one_IZR_r_R1" -> 
- "single_z_r_R1" -> 
- "tech_single_z_r_R1" -> 
- "prod_neq_R0" -> 
- "Rmult_le_pos" -> 
- "double" -> 
- "double_var" -> 
-*)
-"gt0_plus_gt0_is_gt0", ([],"Rplus_lt_0_compat");
-"ge0_plus_gt0_is_gt0", ([],"Rplus_le_lt_0_compat");
-"gt0_plus_ge0_is_gt0", ([],"Rplus_lt_le_0_compat");
-"ge0_plus_ge0_is_ge0", ([],"Rplus_le_le_0_compat");
-(*
- "plus_le_is_le" -> ?
- "plus_lt_is_lt" -> ?
-*)
-"Rmult_lt2", ([],"Rmult_le_0_lt_compat");
-(* "Rge_ge_eq" -> c dir,"Rge_antisym" OK *)
-]
-
-let translate_v7_string dir s =
-  try
-    let d,s' = List.assoc s translation_table in
-    (if d=[] then c dir else d),s'
-  with Not_found ->
-  (* Special cases *)
-  match s with
-  (* Init *)
-  | "relation" when is_module "Datatypes" or is_dir dir "Datatypes"
-      -> da,"comparison"
-  | "Op" when is_module "Datatypes" or is_dir dir "Datatypes"
-      -> da,"CompOpp"
-  (* BinPos *)
-  | "times" when not (is_module "Mapfold") -> bp,"Pmult"
-  (* Reals *)
-  | s when String.length s >= 7 & (String.sub s 0 7 = "Rabsolu") ->
-      c dir,
-      "Rabs"^(String.sub s 7 (String.length s - 7))
-  | s when String.length s >= 7 &
-      (String.sub s (String.length s - 7) 7 = "Rabsolu") -> c dir,
-      "R"^(String.sub s 0 (String.length s - 7))^"abs"
-  | s when String.length s >= 7 & 
-      let s' = String.sub s 0 7 in
-      (s' = "unicite" or s' = "unicity") -> c dir,
-      "uniqueness"^(String.sub s 7 (String.length s - 7))
-  | s when String.length s >= 3 &
-      let s' = String.sub s 0 3 in
-      s' = "gcd" -> c dir, "Zis_gcd"^(String.sub s 3 (String.length s - 3))
-  (* Default *)
-  | x -> [],x
-
-
-let id_of_v7_string s =
-  id_of_string (if !Options.v7 then s else snd (translate_v7_string empty_dirpath s))
-
-let v7_to_v8_dir_id dir id =
-  if Options.do_translate() then
-    let s = string_of_id id in
-    let dir',s =
-      if (is_coq_root (Lib.library_dp()) or is_coq_root dir)
-      then translate_v7_string dir s else [], s in
-    dir',id_of_string (translate_ident_string s)
-  else [],id
-
-let v7_to_v8_id id = snd (v7_to_v8_dir_id empty_dirpath id)
-
-let short_names =
-  List.map (fun x -> snd (snd x)) translation_table
-
-let is_new_name s =
-  Options.do_translate () &
-  (List.mem s short_names or
-  s = "comparison" or s = "CompOpp" or s = "Pmult" or
-  (String.length s >= 4 & String.sub s 0 4 = "Rabs") or
-  (String.length s >= 4 & String.sub s (String.length s - 3) 3 = "abs"
-                        & s.[0] = 'R') or
-  (String.length s >= 10 & String.sub s 0 10 = "uniqueness"))
-
-let v7_to_v8_dir fulldir dir =
-  if Options.do_translate () & dir <> empty_dirpath then
-    let update s =
-      let l = List.map string_of_id (repr_dirpath dir) in
-      make_dirpath (List.map id_of_string (s :: List.tl l))
-    in
-    let l = List.map string_of_id (repr_dirpath fulldir) in
-    if l = [ "List"; "Lists"; "Coq" ] then update "MonoList"
-    else if l = [ "PolyList"; "Lists"; "Coq" ] then update "List"
-    else dir
-  else dir
-
-let shortest_qualid_of_v7_global ctx ref =
-  let fulldir,_ = repr_path (sp_of_global ref) in
-  let dir,id = repr_qualid (shortest_qualid_of_global ctx ref) in
-  let dir',id = v7_to_v8_dir_id fulldir id in
-  let dir'' =
-    if dir' = [] then
-      (* A name that is not renamed *)
-      if dir = empty_dirpath & is_new_name (string_of_id id)
-      then 
-        (* An unqualified name that is not renamed but which coincides *)
-        (* with a new name: force qualification unless it is a variable *)
-        if fulldir <> empty_dirpath & not (is_coq_root fulldir)
-        then make_dirpath [List.hd (repr_dirpath fulldir)] 
-        else empty_dirpath
-      else v7_to_v8_dir fulldir dir
-    else
-      (* A stdlib name that has been renamed *)
-      try
-        let d,_ = repr_path (Nametab.full_name_cci (make_short_qualid id)) in
-        if not (is_coq_root d) then 
-          (* The user has defined id, then we qualify the new name *)
-          v7_to_v8_dir fulldir (make_dirpath (List.map id_of_string dir'))
-        else empty_dirpath
-      with Not_found -> v7_to_v8_dir fulldir dir in
-  make_qualid dir'' id
-
 let extern_reference loc vars r =
-  try Qualid (loc,shortest_qualid_of_v7_global vars r)
+  try Qualid (loc,shortest_qualid_of_global vars r)
   with Not_found ->
     (* happens in debugger *)
     Ident (loc,id_of_string (raw_string_of_ref r))
@@ -994,7 +136,7 @@ let rec check_same_pattern p1 p2 =
     | CPatCstr(_,c1,a1), CPatCstr(_,c2,a2) when c1=c2 ->
         List.iter2 check_same_pattern a1 a2
     | CPatAtom(_,r1), CPatAtom(_,r2) when r1=r2 -> ()
-    | CPatNumeral(_,i1), CPatNumeral(_,i2) when i1=i2 -> ()
+    | CPatPrim(_,i1), CPatPrim(_,i2) when i1=i2 -> ()
     | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) when s1=s2 ->
         check_same_pattern e1 e2
     | _ -> failwith "not same pattern"
@@ -1044,20 +186,17 @@ let rec check_same_type ty1 ty2 =
   | CCases(_,_,a1,brl1), CCases(_,_,a2,brl2) ->
       List.iter2 (fun (tm1,_) (tm2,_) -> check_same_type tm1 tm2) a1 a2;
       List.iter2 (fun (_,pl1,r1) (_,pl2,r2) ->
-        List.iter2 check_same_pattern pl1 pl2;
+        List.iter2 (List.iter2 check_same_pattern) pl1 pl2;
         check_same_type r1 r2) brl1 brl2
-  | COrderedCase(_,_,_,a1,bl1), COrderedCase(_,_,_,a2,bl2) ->
-      check_same_type a1 a2;
-      List.iter2 check_same_type bl1 bl2
   | CHole _, CHole _ -> ()
   | CPatVar(_,i1), CPatVar(_,i2) when i1=i2 -> ()
   | CSort(_,s1), CSort(_,s2) when s1=s2 -> ()
-  | CCast(_,a1,b1), CCast(_,a2,b2) ->
+  | CCast(_,a1,_,b1), CCast(_,a2,_,b2) ->
       check_same_type a1 a2;
       check_same_type b1 b2
   | CNotation(_,n1,e1), CNotation(_,n2,e2) when n1=n2 ->
       List.iter2 check_same_type e1 e2
-  | CNumeral(_,i1), CNumeral(_,i2) when i1=i2 -> ()
+  | CPrim(_,i1), CPrim(_,i2) when i1=i2 -> ()
   | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) when s1=s2 ->
       check_same_type e1 e2
   | _ when ty1=ty2 -> ()
@@ -1118,17 +257,14 @@ let rec same_raw c d =
       same_raw t1 t2; same_raw m1 m2
   | RCases(_,_,c1,b1), RCases(_,_,c2,b2) ->
       List.iter2
-        (fun (t1,{contents=(al1,oind1)}) (t2,{contents=(al2,oind2)}) ->
+        (fun (t1,(al1,oind1)) (t2,(al2,oind2)) ->
           same_raw t1 t2;
           if al1 <> al2 then failwith "RCases";
-          option_iter2(fun (_,i1,nl1) (_,i2,nl2) ->
+          option_iter2(fun (_,i1,_,nl1) (_,i2,_,nl2) ->
             if i1<>i2 || nl1 <> nl2 then failwith "RCases") oind1 oind2) c1 c2;
       List.iter2 (fun (_,_,pl1,b1) (_,_,pl2,b2) ->
         List.iter2 same_patt pl1 pl2;
         same_raw b1 b2) b1 b2
-  | ROrderedCase(_,_,_,c1,v1,_), ROrderedCase(_,_,_,c2,v2,_) ->
-      same_raw c1 c2;
-      array_iter2 same_raw v1 v2
   | RLetTuple(_,nl1,_,b1,c1), RLetTuple(_,nl2,_,b2,c2) ->
       if nl1<>nl2 then failwith "RLetTuple";
       same_raw b1 b2;
@@ -1147,8 +283,8 @@ let rec same_raw c d =
   | RSort(_,s1), RSort(_,s2) -> if s1<>s2 then failwith "RSort"
   | RHole _, _ -> ()
   | _, RHole _ -> ()
-  | RCast(_,c1,_),r2 -> same_raw c1 r2
-  | r1, RCast(_,c2,_) -> same_raw r1 c2
+  | RCast(_,c1,_,_),r2 -> same_raw c1 r2
+  | r1, RCast(_,c2,_,_) -> same_raw r1 c2
   | RDynamic(_,d1), RDynamic(_,d2) -> if d1<>d2 then failwith"RDynamic"
   | _ -> failwith "same_raw"
      
@@ -1159,9 +295,6 @@ let same_rawconstr c d =
 (**********************************************************************)
 (* mapping patterns to cases_pattern_expr                                *)
 
-let make_current_scopes (scopt,scopes) = 
-  option_fold_right push_scope scopt scopes
-
 let has_curly_brackets ntn =
   String.length ntn >= 6 & (String.sub ntn 0 6 = "{ _ } " or
     String.sub ntn (String.length ntn - 6) 6 = " { _ }" or
@@ -1174,7 +307,7 @@ and spaces ntn n =
   if n = String.length ntn then []
   else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1)
 
-let expand_curly_brackets make_ntn ntn l =
+let expand_curly_brackets loc mknot ntn l =
   let ntn' = ref ntn in
   let rec expand_ntn i =
     function
@@ -1187,58 +320,45 @@ let expand_curly_brackets make_ntn ntn l =
             ntn' := 
               String.sub !ntn' 0 p ^ "_" ^ 
               String.sub !ntn' (p+5) (String.length !ntn' -p-5);
-            make_ntn "{ _ }" [a] end
+            mknot (loc,"{ _ }",[a]) end
           else a in
         a' :: expand_ntn (i+1) l in
   let l = expand_ntn 0 l in
   (* side effect *)
-  make_ntn !ntn' l
+  mknot (loc,!ntn',l)
 
-let make_notation loc ntn l =
-  if has_curly_brackets ntn
-  then expand_curly_brackets (fun n l -> CNotation (loc,n,l)) ntn l
-  else match ntn,l with
-    (* Special case to avoid writing "- 3" for e.g. (Zopp 3) *)
-    | "- _", [CNumeral(_,Bignat.POS p)] ->
-        CNotation (loc,ntn,[CNotation(loc,"( _ )",l)])
-    | _ -> CNotation (loc,ntn,l)
+let destPrim = function CPrim(_,t) -> Some t | _ -> None
+let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None
 
-let make_pat_notation loc ntn l =
+let make_notation_gen loc ntn mknot mkprim destprim l =
   if has_curly_brackets ntn
-  then expand_curly_brackets (fun n l -> CPatNotation (loc,n,l)) ntn l
-  else match ntn,l with
+  then expand_curly_brackets loc mknot ntn l
+  else match ntn,List.map destprim l with
     (* Special case to avoid writing "- 3" for e.g. (Zopp 3) *)
-    | "- _", [CPatNumeral(_,Bignat.POS p)] ->
-        CPatNotation (loc,ntn,[CPatNotation(loc,"( _ )",l)])
-    | _ -> CPatNotation (loc,ntn,l)
+    | "- _", [Some (Numeral p)] when Bigint.is_strictly_pos p ->
+        mknot (loc,ntn,[mknot (loc,"( _ )",l)])
+    | _ -> 
+	match decompose_notation_key ntn, l with
+	| [Terminal "-"; Terminal x], [] ->
+	    (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x)))
+ 	     with _ -> mknot (loc,ntn,[]))
+	| [Terminal x], [] ->
+	    (try mkprim (loc, Numeral (Bigint.of_string x))
+ 	     with _ -> mknot (loc,ntn,[]))
+	| _ ->
+	    mknot (loc,ntn,l)
 
+let make_notation loc ntn l =
+  make_notation_gen loc ntn
+    (fun (loc,ntn,l) -> CNotation (loc,ntn,l))
+    (fun (loc,p) -> CPrim (loc,p))
+    destPrim l
 
-(*
-let rec cases_pattern_expr_of_constr_expr = function
-  | CRef r -> CPatAtom (dummy_loc,Some r)
-  | CHole loc -> CPatAtom (loc,None)
-  | CApp (loc,(proj,CRef c),l) when proj = None ->
-      let l,e = List.split l in
-      if not (List.for_all ((=) None) e) then
-	anomaly "Unexpected explicitation in pattern";
-      CPatCstr (loc,c,List.map cases_pattern_expr_of_constr_expr l)
-  | CNotation (loc,ntn,l) ->
-      CPatNotation (loc,ntn,List.map cases_pattern_expr_of_constr_expr l)
-  | CNumeral (loc,n) -> CPatNumeral (loc,n)
-  | CDelimiters (loc,s,e) -> 
-      CPatDelimiters (loc,s,cases_pattern_expr_of_constr_expr e)	
-  | _ -> anomaly "Constrextern: not a pattern"
-
-let rec rawconstr_of_cases_pattern = function
-  | PatVar (loc,Name id) -> RVar (loc,id)
-  | PatVar (loc,Anonymous) -> RHole (loc,InternalHole)
-  | PatCstr (loc,(ind,_ as c),args,_) -> 
-      let nparams = (snd (Global.lookup_inductive ind)).Declarations.mind_nparams in
-      let params = list_tabulate (fun _ -> RHole (loc,InternalHole)) nparams in
-      let args = params @ List.map rawconstr_of_cases_pattern args in
-      let f = RRef (loc,ConstructRef c) in
-      if args = [] then f else RApp (loc,f,args)
-*)
+let make_pat_notation loc ntn l =
+  make_notation_gen loc ntn
+    (fun (loc,ntn,l) -> CPatNotation (loc,ntn,l))
+    (fun (loc,p) -> CPatPrim (loc,p))
+    destPatPrim l
 
 let bind_env sigma var v =
   try
@@ -1251,10 +371,10 @@ let bind_env sigma var v =
 let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with
   | r1, AVar id2 when List.mem id2 metas -> bind_env sigma id2 r1
   | PatVar (_,Anonymous), AHole _ -> sigma
-  | a, AHole _ when not(Options.do_translate()) -> sigma
+  | a, AHole _ -> sigma
   | PatCstr (loc,(ind,_ as r1),args1,Anonymous), _ ->
       let nparams =
-	(snd (Global.lookup_inductive ind)).Declarations.mind_nparams in
+	(fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
       let l2 =
         match a2 with
 	  | ARef (ConstructRef r2) when r1 = r2 -> []
@@ -1278,35 +398,33 @@ let match_aconstr_cases_pattern c (metas_scl,pat) =
   List.map (fun (x,scl) -> (find x subst,scl)) metas_scl
 
  (* Better to use extern_rawconstr composed with injection/retraction ?? *)
-let rec extern_cases_pattern_in_scope scopes vars pat =
+let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
   try 
     if !Options.raw_print or !print_no_symbol then raise No_match;
-    let (sc,n) = Symbols.uninterp_cases_numeral pat in
-    match Symbols.availability_of_numeral sc (make_current_scopes scopes) with
+    let (na,sc,p) = uninterp_prim_token_cases_pattern pat in
+    match availability_of_prim_token sc scopes with
     | None -> raise No_match
     | Some key ->
-        let loc = pattern_loc pat in
-        insert_pat_delimiters (CPatNumeral (loc,n)) key
+      let loc = cases_pattern_loc pat in
+      insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na
   with No_match ->
   try 
     if !Options.raw_print or !print_no_symbol then raise No_match;
     extern_symbol_pattern scopes vars pat
-      (Symbols.uninterp_cases_pattern_notations pat)
+      (uninterp_cases_pattern_notations pat)
   with No_match ->
   match pat with
-  | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,v7_to_v8_id id)))
+  | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id)))
   | PatVar (loc,Anonymous) -> CPatAtom (loc, None) 
   | PatCstr(loc,cstrsp,args,na) ->
       let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
       let p = CPatCstr
         (loc,extern_reference loc vars (ConstructRef cstrsp),args) in
-      (match na with
-	| Name id -> CPatAlias (loc,p,v7_to_v8_id id)
-	| Anonymous -> p)
+      insert_pat_alias loc p na
 	
 and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
-  | (keyrule,pat,n as rule)::rules ->
+  | (keyrule,pat,n as _rule)::rules ->
       try
 	(* Check the number of arguments expected by the notation *)
 	let loc = match t,n with
@@ -1319,25 +437,26 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function
 	(* Try availability of interpretation ... *)
         match keyrule with
           | NotationRule (sc,ntn) ->
-	      let scopes' = make_current_scopes (tmp_scope, scopes) in
-	      (match Symbols.availability_of_notation (sc,ntn) scopes' with
+	      (match availability_of_notation (sc,ntn) allscopes with
                   (* Uninterpretation is not allowed in current context *)
               | None -> raise No_match
                   (* Uninterpretation is allowed in current context *)
 	      | Some (scopt,key) ->
-	          let scopes = make_current_scopes (scopt, scopes) in
+	          let scopes' = option_cons scopt scopes in
 	          let l =
 		    List.map (fun (c,(scopt,scl)) ->
-		      extern_cases_pattern_in_scope 
-		        (scopt,List.fold_right push_scope scl scopes) vars c)
+		      extern_cases_pattern_in_scope (scopt,scl@scopes') vars c)
                       subst in
-		  insert_pat_delimiters (make_pat_notation loc ntn l) key)
+		  insert_pat_delimiters loc (make_pat_notation loc ntn l) key)
           | SynDefRule kn ->
 	      let qid = shortest_qualid_of_syndef vars kn in
- 	      CPatAtom (loc,Some (Qualid (loc, qid)))
+              CPatAtom (loc,Some (Qualid (loc, qid)))
       with
 	  No_match -> extern_symbol_pattern allscopes vars t rules
 
+let extern_cases_pattern vars p = 
+  extern_cases_pattern_in_scope (None,[]) vars p
+
 (**********************************************************************)
 (* Externalising applications *)
 
@@ -1354,24 +473,6 @@ let is_projection nargs = function
       with Not_found -> None)
   | _ -> None
 
-let is_nil = function
-  | [CRef ref] -> snd (repr_qualid (snd (qualid_of_reference ref))) = id_of_string "nil"
-  | _ -> false
-
-let stdlib_but_length args = function
-  | Some r -> 
-      let dir,id = repr_path (sp_of_global r) in
-      (is_coq_root (Lib.library_dp()) or is_coq_root dir)
-      && not (List.mem (string_of_id id) ["Zlength";"length"] && is_nil args)
-      && not (List.mem (string_of_id id) ["In"] && List.length args >= 2
-              && is_nil (List.tl args))
-  | None -> false
-
-let explicit_code imp q =
-  dummy_loc,
-  if !Options.v7 & not (Options.do_translate()) then ExplByPos q
-  else ExplByName (name_of_implicit imp)
-
 let is_hole = function CHole _ -> true | _ -> false
 
 let is_significant_implicit a impl tail =
@@ -1388,10 +489,12 @@ let explicitize loc inctx impl (cf,f) args =
           !Options.raw_print or
           (!print_implicits & !print_implicits_explicit_args) or 
 	  (is_significant_implicit a impl tail &
-	  (not (is_inferable_implicit inctx n imp) or
-	    (Options.do_translate() & not (stdlib_but_length args cf))))
+	  (not (is_inferable_implicit inctx n imp)))
 	in
-        if visible then (a,Some (explicit_code imp q)) :: tail else tail
+        if visible then 
+	  (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail 
+	else
+	  tail
     | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl)
     | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*)
     | [], _ -> [] in
@@ -1440,9 +543,7 @@ let rec extern_args extern scopes env args subscopes =
 
 let rec remove_coercions inctx = function
   | RApp (loc,RRef (_,r),args) as c
-      when
-        inctx &
-        not (!Options.raw_print or !print_coercions or Options.do_translate ())
+      when inctx & not (!Options.raw_print or !print_coercions)
       ->
       (try match Classops.hide_coercion r with
 	  | Some n when n < List.length args ->
@@ -1498,18 +599,18 @@ let rec share_fix_binders n rbl ty def =
 (* mapping rawterms to numerals (in presence of coercions, choose the *)
 (* one with no delimiter if possible)                                 *)
 
-let extern_possible_numeral scopes r =
+let extern_possible_prim_token scopes r =
   try
-    let (sc,n) = uninterp_numeral r in
-    match Symbols.availability_of_numeral sc (make_current_scopes scopes) with
+    let (sc,n) = uninterp_prim_token r in
+    match availability_of_prim_token sc scopes with
     | None -> None
-    | Some key -> Some (insert_delimiters (CNumeral(loc_of_rawconstr r,n)) key)
+    | Some key -> Some (insert_delimiters (CPrim (loc_of_rawconstr r,n)) key)
   with No_match ->
     None
 
-let extern_optimal_numeral scopes r r' =
-  let c = extern_possible_numeral scopes r in
-  let c' = if r==r' then None else extern_possible_numeral scopes r' in
+let extern_optimal_prim_token scopes r r' =
+  let c = extern_possible_prim_token scopes r in
+  let c' = if r==r' then None else extern_possible_prim_token scopes r' in
   match c,c' with
   | Some n, (Some (CDelimiters _) | None) | _, Some n -> n
   | _ -> raise No_match
@@ -1517,21 +618,28 @@ let extern_optimal_numeral scopes r r' =
 (**********************************************************************)
 (* mapping rawterms to constr_expr                                    *)
 
+let extern_rawsort = function
+  | RProp _ as s -> s
+  | RType (Some _) as s when !print_universes -> s
+  | RType _ -> RType None
+
 let rec extern inctx scopes vars r =
   let r' = remove_coercions inctx r in
   try 
     if !Options.raw_print or !print_no_symbol then raise No_match;
-    extern_optimal_numeral scopes r r'
+    extern_optimal_prim_token scopes r r'
   with No_match ->
   try 
     if !Options.raw_print or !print_no_symbol then raise No_match;
-    extern_symbol scopes vars r' (Symbols.uninterp_notations r')
+    extern_symbol scopes vars r' (uninterp_notations r')
   with No_match -> match r' with
   | RRef (loc,ref) ->
-      extern_global loc (implicits_of_global_out ref)
+      extern_global loc (implicits_of_global ref)
         (extern_reference loc vars ref)
 
-  | RVar (loc,id) -> CRef (Ident (loc,v7_to_v8_id id))
+  | RVar (loc,id) -> CRef (Ident (loc,id))
+
+  | REvar (loc,n,None) when !print_meta_as_hole -> CHole loc
 
   | REvar (loc,n,_) -> (* we drop args *) extern_evar loc n
 
@@ -1540,98 +648,70 @@ let rec extern inctx scopes vars r =
   | RApp (loc,f,args) ->
       (match f with
 	 | RRef (rloc,ref) ->
-	     let subscopes = Symbols.find_arguments_scope ref in
+	     let subscopes = find_arguments_scope ref in
 	     let args =
 	       extern_args (extern true) (snd scopes) vars args subscopes in
-	     extern_app loc inctx (implicits_of_global_out ref)
+	     extern_app loc inctx (implicits_of_global ref)
                (Some ref,extern_reference rloc vars ref)
 	       args
-	 | RVar (rloc,id) -> (* useful for translation of inductive *)
-	     let args = List.map (sub_extern true scopes vars) args in
-	     extern_app loc inctx (get_temporary_implicits_out id)
-	       (None,Ident (rloc,v7_to_v8_id id))
-	       args
 	 | _       -> 
 	     explicitize loc inctx [] (None,sub_extern false scopes vars f)
                (List.map (sub_extern true scopes vars) args))
 
   | RProd (loc,Anonymous,t,c) ->
       (* Anonymous product are never factorized *)
-      CArrow (loc,extern_type scopes vars t, extern_type scopes vars c)
+      CArrow (loc,extern_typ scopes vars t, extern_typ scopes vars c)
 
   | RLetIn (loc,na,t,c) ->
-      let na = name_app translate_ident na in
       CLetIn (loc,(loc,na),sub_extern false scopes vars t,
               extern inctx scopes (add_vname vars na) c)
 
   | RProd (loc,na,t,c) ->
-      let t = extern_type scopes vars (anonymize_if_reserved na t) in
+      let t = extern_typ scopes vars (anonymize_if_reserved na t) in
       let (idl,c) = factorize_prod scopes (add_vname vars na) t c in
       CProdN (loc,[(dummy_loc,na)::idl,t],c)
 
   | RLambda (loc,na,t,c) ->
-      let t = extern_type scopes vars (anonymize_if_reserved na t) in
+      let t = extern_typ scopes vars (anonymize_if_reserved na t) in
       let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) t c in
       CLambdaN (loc,[(dummy_loc,na)::idl,t],c)
 
-  | RCases (loc,(typopt,rtntypopt),tml,eqns) ->
-      let pred = option_app (extern_type scopes vars) typopt in
+  | RCases (loc,rtntypopt,tml,eqns) ->
       let vars' = 
 	List.fold_right (name_fold Idset.add)
 	  (cases_predicate_names tml) vars in
-      let rtntypopt' = option_app (extern_type scopes vars') !rtntypopt in
-      let tml = List.map (fun (tm,{contents=(na,x)}) ->
+      let rtntypopt' = option_map (extern_typ scopes vars') rtntypopt in
+      let tml = List.map (fun (tm,(na,x)) ->
         let na' = match na,tm with
             Anonymous, RVar (_,id) when 
-              !rtntypopt<>None & occur_rawconstr id (out_some !rtntypopt)
+              rtntypopt<>None & occur_rawconstr id (out_some rtntypopt)
               -> Some Anonymous
           | Anonymous, _ -> None
           | Name id, RVar (_,id') when id=id' -> None
           | Name _, _ -> Some na in
 	(sub_extern false scopes vars tm,
-	(na',option_app (fun (loc,ind,nal) ->
+	(na',option_map (fun (loc,ind,n,nal) ->
+	  let params = list_tabulate
+	    (fun _ -> RHole (dummy_loc,Evd.InternalHole)) n in
 	  let args = List.map (function
-	    | Anonymous -> RHole (dummy_loc,InternalHole) 
+	    | Anonymous -> RHole (dummy_loc,Evd.InternalHole) 
 	    | Name id -> RVar (dummy_loc,id)) nal in
-	  let t = RApp (dummy_loc,RRef (dummy_loc,IndRef ind),args) in
-	  (extern_type scopes vars t)) x))) tml in
-      let eqns = List.map (extern_eqn (typopt<>None) scopes vars) eqns in 
-      CCases (loc,(pred,rtntypopt'),tml,eqns)
-
-  | ROrderedCase (loc,cs,typopt,tm,bv,{contents = Some x}) ->
-      extern false scopes vars x
-
-  | ROrderedCase (loc,IfStyle,typopt,tm,bv,_) when Options.do_translate () ->
-      let rec strip_branches = function
-        | (RLambda (_,_,_,c1), RLambda (_,_,_,c2)) -> strip_branches (c1,c2)
-        | x -> x in
-      let c1,c2 = strip_branches (bv.(0),bv.(1)) in
-      msgerrnl (str "Warning: unable to ensure the correctness of the translation of an if-then-else");
-      let bv = Array.map (sub_extern (typopt<>None) scopes vars) [|c1;c2|] in
-      COrderedCase
-	(loc,IfStyle,option_app (extern_type scopes vars) typopt,
-         sub_extern false scopes vars tm,Array.to_list bv)
-      (* We failed type-checking If and to translate it to CIf *)
-      (* try to remove the dependances in branches anyway *)
-
-
-  | ROrderedCase (loc,cs,typopt,tm,bv,_) ->
-      let bv = Array.map (sub_extern (typopt<>None) scopes vars) bv in
-      COrderedCase
-	(loc,cs,option_app (extern_type scopes vars) typopt,
-         sub_extern false scopes vars tm,Array.to_list bv)
+	  let t = RApp (dummy_loc,RRef (dummy_loc,IndRef ind),params@args) in
+	  (extern_typ scopes vars t)) x))) tml in
+      let eqns = List.map (extern_eqn (rtntypopt<>None) scopes vars) eqns in 
+      CCases (loc,rtntypopt',tml,eqns)
 
   | RLetTuple (loc,nal,(na,typopt),tm,b) ->
       CLetTuple (loc,nal,
-        (option_app (fun _ -> na) typopt,
-         option_app (extern_type scopes (add_vname vars na)) typopt),
+        (option_map (fun _ -> na) typopt,
+         option_map (extern_typ scopes (add_vname vars na)) typopt),
         sub_extern false scopes vars tm,
         extern false scopes (List.fold_left add_vname vars nal) b)
 
   | RIf (loc,c,(na,typopt),b1,b2) ->
       CIf (loc,sub_extern false scopes vars c,
-        (option_app (fun _ -> na) typopt,
-         option_app (extern_type scopes (add_vname vars na)) typopt),
+        (option_map (fun _ -> na) typopt,
+         option_map (extern_typ scopes (add_vname vars na)) typopt),
         sub_extern false scopes vars b1, sub_extern false scopes vars b2)
 
   | RRec (loc,fk,idv,blv,tyv,bv) ->
@@ -1640,17 +720,12 @@ let rec extern inctx scopes vars r =
 	 | RFix (nv,n) ->
 	     let listdecl = 
 	       Array.mapi (fun i fi ->
-                 let (bl,ty,def) =
-                   if Options.do_translate() then
-                     let n = List.fold_left
-                       (fun n (_,obd,_) -> if obd=None then n-1 else n)
-                       nv.(i) blv.(i) in
-                     share_fix_binders n (List.rev blv.(i)) tyv.(i) bv.(i)
-                   else blv.(i), tyv.(i), bv.(i) in
+                 let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in
                  let (ids,bl) = extern_local_binder scopes vars bl in
                  let vars0 = List.fold_right (name_fold Idset.add) ids vars in
                  let vars1 = List.fold_right (name_fold Idset.add) ids vars' in
-		 (fi,nv.(i), bl, extern_type scopes vars0 ty,
+		 let n, ro = fst nv.(i), extern_recursion_order scopes vars (snd nv.(i)) in
+		 (fi, (n, ro), bl, extern_typ scopes vars0 ty,
                   extern false scopes vars1 def)) idv
 	     in 
 	     CFix (loc,(loc,idv.(n)),Array.to_list listdecl)
@@ -1660,44 +735,46 @@ let rec extern inctx scopes vars r =
                  let (ids,bl) = extern_local_binder scopes vars blv.(i) in
                  let vars0 = List.fold_right (name_fold Idset.add) ids vars in
                  let vars1 = List.fold_right (name_fold Idset.add) ids vars' in
-		 (fi,bl,extern_type scopes vars0 tyv.(i),
+		 (fi,bl,extern_typ scopes vars0 tyv.(i),
                   sub_extern false scopes vars1 bv.(i))) idv
 	     in
 	     CCoFix (loc,(loc,idv.(n)),Array.to_list listdecl))
 
-  | RSort (loc,s) ->
-      let s = match s with
-	 | RProp _ -> s
-	 | RType (Some _) when !print_universes -> s
-	 | RType _ -> RType None in
-      CSort (loc,s)
+  | RSort (loc,s) -> CSort (loc,extern_rawsort s)
 
   | RHole (loc,e) -> CHole loc
 
-  | RCast (loc,c,t) ->
-      CCast (loc,sub_extern true scopes vars c,extern_type scopes vars t)
+  | RCast (loc,c,k,t) ->
+      CCast (loc,sub_extern true scopes vars c,k,extern_typ scopes vars t)
 
   | RDynamic (loc,d) -> CDynamic (loc,d)
 
-and extern_type (_,scopes) = extern true (Some Symbols.type_scope,scopes)
+and extern_typ (_,scopes) = 
+  extern true (Some Notation.type_scope,scopes)
 
 and sub_extern inctx (_,scopes) = extern inctx (None,scopes)
 
-and factorize_prod scopes vars aty = function
+and factorize_prod scopes vars aty c =
+  try 
+    if !Options.raw_print or !print_no_symbol then raise No_match;
+    ([],extern_symbol scopes vars c (uninterp_notations c))
+  with No_match -> match c with
   | RProd (loc,(Name id as na),ty,c)
-      when same aty (extern_type scopes vars (anonymize_if_reserved na ty))
+      when same aty (extern_typ scopes vars (anonymize_if_reserved na ty))
 	& not (occur_var_constr_expr id aty) (* avoid na in ty escapes scope *)
-	-> let id = translate_ident id in
-           let (nal,c) = factorize_prod scopes (Idset.add id vars) aty c in
+	-> let (nal,c) = factorize_prod scopes (Idset.add id vars) aty c in
            ((loc,Name id)::nal,c)
-  | c -> ([],extern_type scopes vars c)
+  | c -> ([],extern_typ scopes vars c)
 
-and factorize_lambda inctx scopes vars aty = function
+and factorize_lambda inctx scopes vars aty c =
+  try 
+    if !Options.raw_print or !print_no_symbol then raise No_match;
+    ([],extern_symbol scopes vars c (uninterp_notations c))
+  with No_match -> match c with
   | RLambda (loc,na,ty,c)
-      when same aty (extern_type scopes vars (anonymize_if_reserved na ty))
+      when same aty (extern_typ scopes vars (anonymize_if_reserved na ty))
 	& not (occur_name na aty) (* To avoid na in ty' escapes scope *)
-	-> let na = name_app translate_ident na in
-           let (nal,c) =
+	-> let (nal,c) =
 	     factorize_lambda inctx scopes (add_vname vars na) aty c in
            ((loc,na)::nal,c)
   | c -> ([],sub_extern inctx scopes vars c)
@@ -1705,15 +782,13 @@ and factorize_lambda inctx scopes vars aty = function
 and extern_local_binder scopes vars = function
     [] -> ([],[])
   | (na,Some bd,ty)::l ->
-      let na = name_app translate_ident na in
       let (ids,l) =
         extern_local_binder scopes (name_fold Idset.add na vars) l in
       (na::ids,
        LocalRawDef((dummy_loc,na), extern false scopes vars bd) :: l)
       
   | (na,None,ty)::l ->
-      let na = name_app translate_ident na in
-      let ty = extern_type scopes vars (anonymize_if_reserved na ty) in
+      let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in
       (match extern_local_binder scopes (name_fold Idset.add na vars) l with
           (ids,LocalRawAssum(nal,ty')::l)
             when same ty ty' &
@@ -1726,12 +801,12 @@ and extern_local_binder scopes vars = function
              LocalRawAssum([(dummy_loc,na)],ty) :: l))
 
 and extern_eqn inctx scopes vars (loc,ids,pl,c) =
-  (loc,List.map (extern_cases_pattern_in_scope scopes vars) pl,
+  (loc,[List.map (extern_cases_pattern_in_scope scopes vars) pl],
    extern inctx scopes vars c)
 
 and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
-  | (keyrule,pat,n as rule)::rules ->
+  | (keyrule,pat,n as _rule)::rules ->
       let loc = Rawterm.loc_of_rawconstr t in
       try
 	(* Adjusts to the number of arguments expected by the notation *)
@@ -1746,17 +821,16 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
         let e =
           match keyrule with
           | NotationRule (sc,ntn) ->
-	      let scopes' = make_current_scopes (tmp_scope, scopes) in
-	      (match Symbols.availability_of_notation (sc,ntn) scopes' with
+	      (match availability_of_notation (sc,ntn) allscopes with
                   (* Uninterpretation is not allowed in current context *)
               | None -> raise No_match
                   (* Uninterpretation is allowed in current context *)
 	      | Some (scopt,key) ->
-	          let scopes = make_current_scopes (scopt, scopes) in
+	          let scopes' = option_cons scopt scopes in
 	          let l =
 		    List.map (fun (c,(scopt,scl)) ->
 		      extern (* assuming no overloading: *) true
-		        (scopt,List.fold_right push_scope scl scopes) vars c)
+		        (scopt,scl@scopes') vars c)
                       subst in
 	          insert_delimiters (make_notation loc ntn l) key)
           | SynDefRule kn ->
@@ -1769,14 +843,17 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
       with
 	  No_match -> extern_symbol allscopes vars t rules
 
-let extern_rawconstr vars c = 
-  extern false (None,Symbols.current_scopes()) vars c
+and extern_recursion_order scopes vars = function
+    RStructRec -> CStructRec
+  | RWfRec c -> CWfRec (extern true scopes vars c)
+  | RMeasureRec c -> CMeasureRec (extern true scopes vars c)
 
-let extern_rawtype vars c =
-  extern_type (None,Symbols.current_scopes()) vars c
 
-let extern_cases_pattern vars p = 
-  extern_cases_pattern_in_scope (None,Symbols.current_scopes()) vars p
+let extern_rawconstr vars c =
+  extern false (None,[]) vars c
+
+let extern_rawtype vars c =
+  extern_typ (None,[]) vars c
 
 (******************************************************************)
 (* Main translation function from constr -> constr_expr *)
@@ -1784,10 +861,10 @@ let extern_cases_pattern vars p =
 let loc = dummy_loc (* for constr and pattern, locations are lost *)
 
 let extern_constr_gen at_top scopt env t =
-  let vars = vars_of_env env in
   let avoid = if at_top then ids_of_context env else [] in
-  extern (not at_top) (scopt,Symbols.current_scopes()) vars
-    (Detyping.detype (at_top,env) avoid (names_of_rel_context env) t)
+  let r = Detyping.detype at_top avoid (names_of_rel_context env) t in
+  let vars = vars_of_env env in
+  extern (not at_top) (scopt,[]) vars r
 
 let extern_constr_in_scope at_top scope env t =
   extern_constr_gen at_top (Some scope) env t
@@ -1795,13 +872,27 @@ let extern_constr_in_scope at_top scope env t =
 let extern_constr at_top env t =
   extern_constr_gen at_top None env t
 
+let extern_type at_top env t =
+  let avoid = if at_top then ids_of_context env else [] in
+  let r = Detyping.detype at_top avoid (names_of_rel_context env) t in
+  extern_rawtype (vars_of_env env) r
+
+let extern_sort s = extern_rawsort (detype_sort s)
+
 (******************************************************************)
 (* Main translation function from pattern -> constr_expr *)
 
-let rec raw_of_pat tenv env = function
+let it_destPLambda n c =
+  let rec aux n nal c =
+    if n=0 then (nal,c) else match c with
+      | PLambda (na,_,c) -> aux (n-1) (na::nal) c
+      | _ -> anomaly "it_destPLambda" in
+  aux n [] c
+
+let rec raw_of_pat env = function
   | PRef ref -> RRef (loc,ref)
   | PVar id -> RVar (loc,id)
-  | PEvar (n,l) -> REvar (loc,n,Some (array_map_to_list (raw_of_pat tenv env) l))
+  | PEvar (n,l) -> REvar (loc,n,Some (array_map_to_list (raw_of_pat env) l))
   | PRel n ->
       let id = try match lookup_name_of_rel n env with
 	| Name id   -> id
@@ -1809,37 +900,45 @@ let rec raw_of_pat tenv env = function
 	    anomaly "rawconstr_of_pattern: index to an anonymous variable"
       with Not_found -> id_of_string ("[REL "^(string_of_int n)^"]") in
       RVar (loc,id)
-  | PMeta None -> RHole (loc,InternalHole)
+  | PMeta None -> RHole (loc,Evd.InternalHole)
   | PMeta (Some n) -> RPatVar (loc,(false,n))
   | PApp (f,args) ->
-      RApp (loc,raw_of_pat tenv env f,array_map_to_list (raw_of_pat tenv env) args)
+      RApp (loc,raw_of_pat env f,array_map_to_list (raw_of_pat env) args)
   | PSoApp (n,args) ->
       RApp (loc,RPatVar (loc,(true,n)),
-        List.map (raw_of_pat tenv env) args)
+        List.map (raw_of_pat env) args)
   | PProd (na,t,c) ->
-      RProd (loc,na,raw_of_pat tenv env t,raw_of_pat tenv (na::env) c)
+      RProd (loc,na,raw_of_pat env t,raw_of_pat (na::env) c)
   | PLetIn (na,t,c) ->
-      RLetIn (loc,na,raw_of_pat tenv env t, raw_of_pat tenv (na::env) c)
+      RLetIn (loc,na,raw_of_pat env t, raw_of_pat (na::env) c)
   | PLambda (na,t,c) ->
-      RLambda (loc,na,raw_of_pat tenv env t, raw_of_pat tenv (na::env) c)
-  | PCase ((_,(IfStyle|LetStyle as cs)),typopt,tm,bv) ->
-      ROrderedCase (loc,cs,option_app (raw_of_pat tenv env) typopt,
-         raw_of_pat tenv env tm,Array.map (raw_of_pat tenv env) bv, ref None)
-  | PCase ((_,cs),typopt,tm,[||]) ->
-      RCases (loc,(option_app (raw_of_pat tenv env) typopt,ref None (* TODO *)),
-         [raw_of_pat tenv env tm,ref (Anonymous,None)],[])
-  | PCase ((Some ind,cs),typopt,tm,bv) ->
-      let avoid = List.fold_right (name_fold (fun x l -> x::l)) env [] in
-      let k = (snd (lookup_mind_specif (Global.env()) ind)).Declarations.mind_nrealargs in
-      Detyping.detype_case false (raw_of_pat tenv env)(raw_of_eqn tenv env)
-	(fun _ _ -> false (* lazy: don't try to display pattern with "if" *))
-	tenv avoid ind cs typopt k tm bv
-  | PCase _ -> error "Unsupported case-analysis while printing pattern"
-  | PFix f -> Detyping.detype (false,tenv) [] env (mkFix f)
-  | PCoFix c -> Detyping.detype (false,tenv) [] env (mkCoFix c)
+      RLambda (loc,na,raw_of_pat env t, raw_of_pat (na::env) c)
+  | PIf (c,b1,b2) ->
+      RIf (loc, raw_of_pat env c, (Anonymous,None), 
+           raw_of_pat env b1, raw_of_pat env b2)
+  | PCase ((LetStyle,[|n|],ind,None),PMeta None,tm,[|b|]) ->
+      let nal,b = it_destRLambda_or_LetIn_names n (raw_of_pat env b) in
+      RLetTuple (loc,nal,(Anonymous,None),raw_of_pat env tm,b)
+  | PCase ((_,cstr_nargs,indo,ind_nargs),p,tm,bv) ->
+      let brs = Array.to_list (Array.map (raw_of_pat env) bv) in
+      let brns = Array.to_list cstr_nargs in
+        (* ind is None only if no branch and no return type *)
+      let ind = out_some indo in
+      let mat = simple_cases_matrix_of_branches ind brns brs in
+      let indnames,rtn =
+	if p = PMeta None then (Anonymous,None),None
+	else 
+	  let nparams,n = out_some ind_nargs in
+	  return_type_of_predicate ind nparams n (raw_of_pat env p) in
+      RCases (loc,rtn,[raw_of_pat env tm,indnames],mat)
+  | PFix f -> Detyping.detype false [] env (mkFix f)
+  | PCoFix c -> Detyping.detype false [] env (mkCoFix c)
   | PSort s -> RSort (loc,s)
 
-and raw_of_eqn tenv env constr construct_nargs branch =
+and raw_of_eqns env constructs consnargsl bl =
+  Array.to_list (array_map3 (raw_of_eqn env) constructs consnargsl bl)
+
+and raw_of_eqn env constr construct_nargs branch =
   let make_pat x env b ids =
     let avoid = List.fold_right (name_fold (fun x l -> x::l)) env [] in
     let id = next_name_away_with_default "x" x avoid in
@@ -1849,7 +948,7 @@ and raw_of_eqn tenv env constr construct_nargs branch =
     if n=0 then
       (dummy_loc, ids, 
        [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
-       raw_of_pat tenv env b)
+       raw_of_pat env b)
     else
       match b with
 	| PLambda (x,_,b) -> 
@@ -1865,6 +964,5 @@ and raw_of_eqn tenv env constr construct_nargs branch =
   in 
   buildrec [] [] env construct_nargs branch
 
-let extern_pattern tenv env pat =
-  extern true (None,Symbols.current_scopes()) Idset.empty
-    (raw_of_pat tenv env pat)
+let extern_constr_pattern env pat =
+  extern true (None,[]) Idset.empty (raw_of_pat env pat)
diff --git a/interp/constrextern.mli b/interp/constrextern.mli
index 0dcdffeb..ca145dd9 100644
--- a/interp/constrextern.mli
+++ b/interp/constrextern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: constrextern.mli,v 1.11.2.3 2005/01/21 16:41:50 herbelin Exp $ i*)
+(*i $Id: constrextern.mli 8831 2006-05-19 09:29:54Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -20,13 +20,10 @@ open Nametab
 open Rawterm
 open Pattern
 open Topconstr
-open Symbols
+open Notation
 (*i*)
 
 (* v7->v8 translation *)
-val id_of_v7_string : string -> identifier
-val v7_to_v8_id : identifier -> identifier (* v7->v8 translation *)
-val shortest_qualid_of_v7_global : Idset.t -> global_reference -> qualid
 val check_same_type : constr_expr -> constr_expr -> unit
 
 (* Translation of pattern, cases pattern, rawterm and term into syntax
@@ -35,7 +32,7 @@ val check_same_type : constr_expr -> constr_expr -> unit
 val extern_cases_pattern : Idset.t -> cases_pattern -> cases_pattern_expr
 val extern_rawconstr : Idset.t -> rawconstr -> constr_expr
 val extern_rawtype : Idset.t -> rawconstr -> constr_expr
-val extern_pattern : env -> names_context -> constr_pattern -> constr_expr
+val extern_constr_pattern : names_context -> constr_pattern -> constr_expr
 
 (* If [b=true] in [extern_constr b env c] then the variables in the first 
    level of quantification clashing with the variables in [env] are renamed *)
@@ -43,6 +40,8 @@ val extern_pattern : env -> names_context -> constr_pattern -> constr_expr
 val extern_constr : bool -> env -> constr -> constr_expr
 val extern_constr_in_scope : bool -> scope_name -> env -> constr -> constr_expr
 val extern_reference : loc -> Idset.t -> global_reference -> reference
+val extern_type : bool -> env -> types -> constr_expr
+val extern_sort : sorts -> rawsort
 
 (* Printing options *)
 val print_implicits : bool ref
@@ -71,7 +70,3 @@ val without_symbols : ('a -> 'b) -> 'a -> 'b
 
 (* This prints metas as anonymous holes *)
 val with_meta_as_hole : ('a -> 'b) -> 'a -> 'b
-
-(* For v8 translation *)
-val set_temporary_implicits_out :
-  (identifier * Impargs.implicits_list) list -> unit
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index bacdb387..4550518d 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: constrintern.ml,v 1.58.2.7 2005/11/19 10:34:35 herbelin Exp $ *)
+(* $Id: constrintern.ml 9611 2007-02-07 15:51:01Z herbelin $ *)
 
 open Pp
 open Util
@@ -18,9 +18,11 @@ open Impargs
 open Rawterm
 open Pattern
 open Pretyping
+open Cases
 open Topconstr
 open Nametab
-open Symbols
+open Notation
+open Inductiveops
 
 (* To interpret implicits and arg scopes of recursive variables in
    inductive types and recursive definitions *)
@@ -37,15 +39,11 @@ let interning_grammar = ref false
 let for_grammar f x =
   interning_grammar := true;
   let a = f x in
-  interning_grammar := false;
-  a
+    interning_grammar := false;
+    a
 
 let variables_bind = ref false
 
-(* For the translator *)
-let temporary_implicits_in = ref []
-let set_temporary_implicits_in l = temporary_implicits_in := l
-
 (**********************************************************************)
 (* Internalisation errors                                             *)
 
@@ -83,9 +81,8 @@ let explain_non_linear_pattern id =
   str "The variable " ++ pr_id id ++ str " is bound several times in pattern"
 
 let explain_bad_patterns_number n1 n2 =
-  let s = if n1 > 1 then "s" else "" in
-  str "Expecting " ++ int n1 ++ str " pattern" ++ str s ++ str " but found "
-    ++ int n2
+  str "Expecting " ++ int n1 ++ str (plural n1 " pattern") ++
+  str " but found " ++ int n2
 
 let explain_bad_explicitation_number n po =
   match n with
@@ -121,6 +118,11 @@ let error_bad_inductive_type loc =
   user_err_loc (loc,"",str 
     "This should be an inductive type applied to names or \"_\"")
 
+let error_inductive_parameter_not_implicit loc =
+  user_err_loc (loc,"", str
+   ("The parameters of inductive types do not bind in\n"^
+    "the 'return' clauses; they must be replaced by '_' in the 'in' clauses."))
+
 (**********************************************************************)
 (* Dump of globalization (to be used by coqdoc)                       *)
 let token_number = ref 0
@@ -131,9 +133,9 @@ type coqdoc_state = Lexer.location_table * int * int
 let coqdoc_freeze () =
   let lt = Lexer.location_table() in
   let state = (lt,!token_number,!last_pos) in
-  token_number := 0;
-  last_pos := 0;
-  state
+    token_number := 0;
+    last_pos := 0;
+    state
 
 let coqdoc_unfreeze (lt,tn,lp) =
   Lexer.restore_location_table lt;
@@ -141,45 +143,34 @@ let coqdoc_unfreeze (lt,tn,lp) =
   last_pos := lp
 
 let add_glob loc ref = 
-(*i
-  let sp = Nametab.sp_of_global (Global.env ()) ref in
-  let dir,_ = repr_path sp in
-  let rec find_module d = 
-    try 
-      let qid = let dir,id = split_dirpath d in make_qualid dir id in
-      let _ = Nametab.locate_loaded_library qid in d
-    with Not_found -> find_module (dirpath_prefix d) 
-  in
-  let s = string_of_dirpath (find_module dir) in
-  i*)
   let sp = Nametab.sp_of_global ref in
-  let id = let _,id = repr_path sp in string_of_id id in
-  let dir = Lib.file_part ref in
-  if dir <> None then
-    let dp = string_of_dirpath (out_some dir) in
-    dump_string (Printf.sprintf "R%d %s.%s\n" (fst (unloc loc)) dp id)
+  let lib_dp = Lib.library_part ref in
+  let mod_dp,id = repr_path sp in
+  let mod_dp_trunc =  drop_dirpath_prefix lib_dp mod_dp in
+  let filepath = string_of_dirpath lib_dp in
+  let fullname = string_of_qualid (make_qualid mod_dp_trunc id) in
+    dump_string (Printf.sprintf "R%d %s %s\n" (fst (unloc loc)) filepath fullname)
 
 let loc_of_notation f loc args ntn =
   if args=[] or ntn.[0] <> '_' then fst (unloc loc)
   else snd (unloc (f (List.hd args)))
 
 let ntn_loc = loc_of_notation constr_loc
-let patntn_loc = loc_of_notation cases_pattern_loc
+let patntn_loc = loc_of_notation cases_pattern_expr_loc
 
-let dump_notation_location =
-  fun pos ntn ((path,df),sc) ->
-    let rec next growing =
-      let loc = Lexer.location_function !token_number in
-      let (bp,_) = unloc loc in
+let dump_notation_location pos ((path,df),sc) =
+  let rec next growing =
+    let loc = Lexer.location_function !token_number in
+    let (bp,_) = unloc loc in
       if growing then if bp >= pos then loc else (incr token_number;next true)
       else if bp = pos then loc
       else if bp > pos then (decr token_number;next false)
       else (incr token_number;next true) in
-    let loc = next (pos >= !last_pos) in
+  let loc = next (pos >= !last_pos) in
     last_pos := pos;
     let path = string_of_dirpath path in
     let sc = match sc with Some sc -> " "^sc | None -> "" in
-    dump_string (Printf.sprintf "R%d %s \"%s\"%s\n" (fst (unloc loc)) path df sc)
+      dump_string (Printf.sprintf "R%d %s \"%s\"%s\n" (fst (unloc loc)) path df sc)
 
 (**********************************************************************)
 (* Contracting "{ _ }" in notations *)
@@ -230,7 +221,7 @@ let contract_pat_notation ntn l =
 (**********************************************************************)
 (* Remembering the parsing scope of variables in notations            *)
 
-let make_current_scope (scopt,scopes) = option_cons scopt scopes
+let make_current_scope (tmp_scope,scopes) = option_cons tmp_scope scopes
 
 let set_var_scope loc id (_,scopt,scopes) varscopes =
   let idscopes = List.assoc id varscopes in
@@ -249,15 +240,14 @@ let set_var_scope loc id (_,scopt,scopes) varscopes =
    [vars2] is the set of global variables, env is the set of variables
    abstracted until this point *)
 
-let intern_var (env,_,_ as genv) (ltacvars,vars2,vars3,_,impls) loc id =
+let intern_var (env,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) loc id =
   let (vars1,unbndltacvars) = ltacvars in
   (* Is [id] an inductive type potentially with implicit *)
   try
     let l,impl,argsc = List.assoc id impls in
     let l = List.map 
       (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) l in
-    RVar (loc,id), impl, argsc,
-    (if !Options.v7 & !interning_grammar then [] else l)
+    RVar (loc,id), impl, argsc, l
   with Not_found ->
   (* Is [id] bound in current env or is an ltac var bound to constr *)
   if Idset.mem id env or List.mem id vars1
@@ -273,7 +263,7 @@ let intern_var (env,_,_ as genv) (ltacvars,vars2,vars3,_,impls) loc id =
   try
     match List.assoc id unbndltacvars with
       | None -> user_err_loc (loc,"intern_var",
-	  pr_id id ++ str " ist not bound to a term")
+	  str "variable " ++ pr_id id ++ str " should be bound to a term")
       | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
   with Not_found ->
   (* Is [id] a goal or section variable *)
@@ -287,7 +277,7 @@ let intern_var (env,_,_ as genv) (ltacvars,vars2,vars3,_,impls) loc id =
     (* [id] a goal variable *)
     RVar (loc,id), [], [], []
 
-let find_appl_head_data (_,_,_,_,impls) = function
+let find_appl_head_data (_,_,_,(_,impls)) = function
   | RRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[]
   | x -> x,[],[],[]
 
@@ -302,6 +292,12 @@ let intern_qualid loc qid =
   with Not_found ->
     error_global_not_found_loc loc qid
 
+(* Rule out section vars since these should have been found by intern_var *)
+let intern_non_secvar_qualid loc qid =
+  match intern_qualid loc qid with
+    | RRef (loc, VarRef id) -> error_global_not_found_loc loc qid
+    | r -> r
+
 let intern_inductive r =
   let loc,qid = qualid_of_reference r in
   try match Nametab.extended_locate qid with
@@ -320,26 +316,20 @@ let intern_reference env lvar = function
   | Qualid (loc, qid) ->
       find_appl_head_data lvar (intern_qualid loc qid)
   | Ident (loc, id) ->
-      (* For old ast syntax compatibility *)
-      if (string_of_id id).[0] = '$' then RVar (loc,id),[],[],[] else
-      (* End old ast syntax compatibility *)
-      (* Pour traduction des implicites d'inductifs et points-fixes *)
-      try RVar (loc,id), List.assoc id !temporary_implicits_in, [], []
-      with Not_found ->
-      (* Fin pour traduction *)
       try intern_var env lvar loc id
       with Not_found -> 
-      try find_appl_head_data lvar (intern_qualid loc (make_short_qualid id))
+      let qid = make_short_qualid id in
+      try find_appl_head_data lvar (intern_non_secvar_qualid loc qid)
       with e ->
 	(* Extra allowance for non globalizing functions *)
 	if !interning_grammar then RVar (loc,id), [], [], []
 	else raise e
 
 let interp_reference vars r =
-  let (r,_,_,_) = intern_reference (Idset.empty,None,[]) (vars,[],[],[],[]) r 
+  let r,_,_,_ = intern_reference (Idset.empty,None,[]) (vars,[],[],([],[])) r 
   in r
 
-let apply_scope_env (ids,_,scopes as env) = function
+let apply_scope_env (ids,_,scopes) = function
   | [] -> (ids,None,scopes), []
   | sc::scl -> (ids,sc,scopes), scl
 
@@ -357,13 +347,29 @@ let rec simple_adjust_scopes = function
 (**********************************************************************)
 (* Cases                                                              *)
 
+let product_of_cases_patterns ids idspl =
+  List.fold_right (fun (ids,pl) (ids',ptaill) ->
+    (ids@ids',
+    (* Cartesian prod of the or-pats for the nth arg and the tail args *)
+    List.flatten (
+    List.map (fun (subst,p) ->
+      List.map (fun (subst',ptail) -> (subst@subst',p::ptail)) ptaill) pl)))
+    idspl (ids,[[],[]])
+
+let simple_product_of_cases_patterns pl =
+  List.fold_right (fun pl ptaill ->
+    List.flatten (List.map (fun (subst,p) ->
+      List.map (fun (subst',ptail) -> (subst@subst',p::ptail)) ptaill) pl))
+    pl [[],[]]
+
 (* Check linearity of pattern-matching *)
 let rec has_duplicate = function 
   | [] -> None
   | x::l -> if List.mem x l then (Some x) else has_duplicate l
 
 let loc_of_lhs lhs = 
- join_loc (cases_pattern_loc (List.hd lhs)) (cases_pattern_loc (list_last lhs))
+ join_loc (cases_pattern_expr_loc (List.hd (List.hd lhs)))
+          (cases_pattern_expr_loc (list_last (list_last lhs)))
 
 let check_linearity lhs ids =
   match has_duplicate ids with
@@ -372,32 +378,28 @@ let check_linearity lhs ids =
     | None ->
 	()
 
-(* Warns if some pattern variable starts with uppercase *)
-let check_uppercase loc ids =
-(* A quoi ça sert ? Pour l'extraction vers ML ? Maintenant elle est externe
-  let is_uppercase_var v =
-    match (string_of_id v).[0] with 'A'..'Z' -> true | _  -> false
-  in
-  let warning_uppercase loc uplid =
-    let vars = h 0 (prlist_with_sep pr_coma pr_id uplid) in
-    let (s1,s2) = if List.length uplid = 1 then (" ","s ") else ("s "," ") in
-    warn (str ("the variable"^s1) ++ vars ++
-	  str (" start"^s2^"with an upper case letter in pattern")) in
-  let uplid = List.filter is_uppercase_var ids in
-  if uplid <> [] then warning_uppercase loc uplid
-*)
-  ()
-
 (* Match the number of pattern against the number of matched args *)
 let check_number_of_pattern loc n l =
   let p = List.length l in
   if n<>p then raise (InternalisationError (loc,BadPatternsNumber (n,p)))
 
+let check_or_pat_variables loc ids idsl =
+  if List.exists ((<>) ids) idsl then
+    user_err_loc (loc, "", str 
+    "The components of this disjunctive pattern must bind the same variables")
+
+let check_constructor_length env loc cstr pl pl0 =
+  let n = List.length pl + List.length pl0 in
+  let nargs = Inductiveops.constructor_nrealargs env cstr in
+  let nhyps = Inductiveops.constructor_nrealhyps env cstr in
+  if n <> nargs && n <> nhyps (* i.e. with let's *) then
+    error_wrong_numarg_constructor_loc loc env cstr nargs
+
 (* Manage multiple aliases *)
 
   (* [merge_aliases] returns the sets of all aliases encountered at this
      point and a substitution mapping extra aliases to the first one *)
-let merge_aliases (ids,subst as aliases) id =
+let merge_aliases (ids,subst as _aliases) id =
   ids@[id], if ids=[] then subst else (id, List.hd ids)::subst
 
 let alias_of = function
@@ -414,13 +416,15 @@ let decode_patlist_value = function
   | CPatCstr (_,_,l) -> l
   | _ -> anomaly "Ill-formed list argument of notation"
 
-let rec subst_pat_iterator y t = function
+let rec subst_pat_iterator y t (subst,p) = match p with
   | PatVar (_,id) as x ->
-      if id = Name y then t else x
+      if id = Name y then t else [subst,x]
   | PatCstr (loc,id,l,alias) ->
-      PatCstr (loc,id,List.map (subst_pat_iterator y t) l,alias)
+      let l' = List.map (fun a -> (subst_pat_iterator y t ([],a))) l in
+      let pl = simple_product_of_cases_patterns l' in
+      List.map (fun (subst',pl) -> subst'@subst,PatCstr (loc,id,pl,alias)) pl
 
-let subst_cases_pattern loc aliases intern subst scopes a =
+let subst_cases_pattern loc (ids,asubst as aliases) intern subst scopes a =
   let rec aux aliases subst = function
   | AVar id ->
       begin
@@ -430,7 +434,7 @@ let subst_cases_pattern loc aliases intern subst scopes a =
 	  let (a,(scopt,subscopes)) = List.assoc id subst in
 	  intern (subscopes@scopes) ([],[]) scopt a
 	with Not_found -> 
-	  if id = ldots_var then [[],[]], PatVar (loc,Name id) else
+	  if id = ldots_var then [],[[], PatVar (loc,Name id)] else
 	  anomaly ("Unbound pattern notation variable: "^(string_of_id id))
 	  (*
 	  (* Happens for local notation joint with inductive/fixpoint defs *)
@@ -440,24 +444,28 @@ let subst_cases_pattern loc aliases intern subst scopes a =
 	  *)
       end
   | ARef (ConstructRef c) ->
-      [aliases], PatCstr (loc,c, [], alias_of aliases)
+      (ids,[asubst, PatCstr (loc,c, [], alias_of aliases)])
   | AApp (ARef (ConstructRef (ind,_ as c)),args) ->
-      let nparams = (snd (Global.lookup_inductive ind)).Declarations.mind_nparams in
+      let nparams = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
       let _,args = list_chop nparams args in
-      let (idsl,pl) = List.split (List.map (aux ([],[]) subst) args) in
-      aliases::List.flatten idsl, PatCstr (loc,c,pl,alias_of aliases)
+      let idslpll = List.map (aux ([],[]) subst) args in
+      let ids',pll = product_of_cases_patterns ids idslpll in
+      let pl' = List.map (fun (subst,pl) -> 
+        subst,PatCstr (loc,c,pl,alias_of aliases)) pll in
+      ids', pl'
   | AList (x,_,iter,terminator,lassoc) ->
       (try 
         (* All elements of the list are in scopes (scopt,subscopes) *)
 	let (a,(scopt,subscopes)) = List.assoc x subst in
-        let idslt,termin = aux ([],[]) subst terminator in
+        let termin = aux ([],[]) subst terminator in
         let l = decode_patlist_value a in
         let idsl,v =
-	  List.fold_right (fun a (allidsl,t) -> 
-            let idsl,u = aux ([],[]) ((x,(a,(scopt,subscopes)))::subst) iter in
-            idsl::allidsl, subst_pat_iterator ldots_var t u)
-            (if lassoc then List.rev l else l) ([idslt],termin) in
-        aliases::List.flatten idsl, v
+	  List.fold_right (fun a (tids,t) -> 
+            let uids,u = aux ([],[]) ((x,(a,(scopt,subscopes)))::subst) iter in
+            let pll = List.map (subst_pat_iterator ldots_var t) u in
+            tids@uids, List.flatten pll)
+            (if lassoc then List.rev l else l) termin in
+        ids@idsl, v
       with Not_found -> 
           anomaly "Inconsistent substitution of recursive notation")
   | t -> user_err_loc (loc,"",str "Invalid notation for pattern")
@@ -476,7 +484,7 @@ let rec patt_of_rawterm loc cstr =
     | RApp (_,RApp(_,h,l1),l2) -> patt_of_rawterm loc (RApp(loc,h,l1@l2))
     | RApp (_,RRef(_,(ConstructRef c as x)),pl) ->
         if !dump then add_glob loc x;
-        let (_,mib) = Inductive.lookup_mind_specif (Global.env()) (fst c) in
+        let (mib,_) = Inductive.lookup_mind_specif (Global.env()) (fst c) in
         let npar = mib.Declarations.mind_nparams in
         let (params,args) =
           if List.length pl <= npar then (pl,[]) else
@@ -498,20 +506,20 @@ let find_constructor ref =
     try extended_locate qid
     with Not_found ->
       raise (InternalisationError (loc,NotAConstructor ref)) in
-  match gref with
-    | SyntacticDef sp ->
-        let sdef = Syntax_def.search_syntactic_definition loc sp in
-        patt_of_rawterm loc sdef
-    | TrueGlobal r ->
-        let rec unf = function
-          | ConstRef cst ->
-	      let v = Environ.constant_value (Global.env()) cst in
-              unf (reference_of_constr v)
-          | ConstructRef c -> 
-	      if !dump then add_glob loc r; 
-	      c, []
-          | _ -> raise Not_found
-        in unf r
+    match gref with
+      | SyntacticDef sp ->
+          let sdef = Syntax_def.search_syntactic_definition loc sp in
+            patt_of_rawterm loc sdef
+      | TrueGlobal r ->
+          let rec unf = function
+            | ConstRef cst ->
+		let v = Environ.constant_value (Global.env()) cst in
+		  unf (global_of_constr v)
+            | ConstructRef c -> 
+		if !dump then add_glob loc r; 
+		c, []
+            | _ -> raise Not_found
+          in unf r
 
 let find_pattern_variable = function
   | Ident (loc,id) -> id
@@ -524,7 +532,7 @@ let maybe_constructor ref =
     | InternalisationError _ -> VarPat (find_pattern_variable ref)
       (* patt var also exists globally but does not satisfy preconditions *)
     | (Environ.NotEvaluableConst _ | Not_found) ->
-        warn (str "pattern " ++ pr_reference ref ++
+        if_verbose msg_warning (str "pattern " ++ pr_reference ref ++
               str " is understood as a pattern variable");
         VarPat (find_pattern_variable ref)
 
@@ -533,48 +541,62 @@ let mustbe_constructor loc ref =
   with (Environ.NotEvaluableConst _ | Not_found) ->
     raise (InternalisationError (loc,NotAConstructor ref))
 
-let rec intern_cases_pattern scopes aliases tmp_scope = function
+let rec intern_cases_pattern genv scopes (ids,subst as aliases) tmp_scope = 
+  function
   | CPatAlias (loc, p, id) ->
       let aliases' = merge_aliases aliases id in
-      intern_cases_pattern scopes aliases' tmp_scope p
+      intern_cases_pattern genv scopes aliases' tmp_scope p
   | CPatCstr (loc, head, pl) ->
       let c,pl0 = mustbe_constructor loc head in
       let argscs =
 	simple_adjust_scopes (find_arguments_scope (ConstructRef c), pl) in
-      let (idsl,pl') =
-	List.split (List.map2 (intern_cases_pattern scopes ([],[])) argscs pl)
-      in
-      (aliases::(List.flatten idsl), PatCstr (loc,c,pl0@pl',alias_of aliases))
-  | CPatNotation (loc,"- _",[CPatNumeral(_,Bignat.POS p)]) ->
-      let scopes = option_cons tmp_scope scopes in
-      ([aliases],
-      Symbols.interp_numeral_as_pattern loc (Bignat.NEG p)
-        (alias_of aliases) scopes)
+      check_constructor_length genv loc c pl0 pl;
+      let idslpl =
+	List.map2 (intern_cases_pattern genv scopes ([],[])) argscs pl in
+      let (ids',pll) = product_of_cases_patterns ids idslpl in
+      let pl' = List.map (fun (subst,pl) ->
+        (subst, PatCstr (loc,c,pl0@pl,alias_of aliases))) pll in
+      ids',pl'
+  | CPatNotation (loc,"- _",[CPatPrim(_,Numeral p)]) 
+      when Bigint.is_strictly_pos p ->
+      let np = Numeral (Bigint.neg p) in
+      intern_cases_pattern genv scopes aliases tmp_scope (CPatPrim(loc,np))
   | CPatNotation (_,"( _ )",[a]) ->
-      intern_cases_pattern scopes aliases tmp_scope a
+      intern_cases_pattern genv scopes aliases tmp_scope a
   | CPatNotation (loc, ntn, args) ->
       let ntn,args = contract_pat_notation ntn args in
-      let scopes = option_cons tmp_scope scopes in
-      let ((ids,c),df) = Symbols.interp_notation loc ntn scopes in
-      if !dump then dump_notation_location (patntn_loc loc args ntn) ntn df;
+      let ((ids,c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in
+      if !dump then dump_notation_location (patntn_loc loc args ntn) df;
       let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in
-      subst_cases_pattern loc aliases intern_cases_pattern subst scopes c
-  | CPatNumeral (loc, n) ->
-      let scopes = option_cons tmp_scope scopes in
-      ([aliases],
-      Symbols.interp_numeral_as_pattern loc n (alias_of aliases) scopes)
+      subst_cases_pattern loc aliases (intern_cases_pattern genv) subst scopes 
+	c
+  | CPatPrim (loc, p) ->
+      let a = alias_of aliases in
+      let (c,df) = Notation.interp_prim_token_cases_pattern loc p a 
+	(tmp_scope,scopes) in
+      if !dump then dump_notation_location (fst (unloc loc)) df;
+      (ids,[subst,c])
   | CPatDelimiters (loc, key, e) ->
-      intern_cases_pattern (find_delimiters_scope loc key::scopes)
+      intern_cases_pattern genv (find_delimiters_scope loc key::scopes)
         aliases None e
   | CPatAtom (loc, Some head) ->
       (match maybe_constructor head with
 	 | ConstrPat (c,args) ->
-	     ([aliases], PatCstr (loc,c,args,alias_of aliases))
+	     check_constructor_length genv loc c [] [];
+	     (ids,[subst, PatCstr (loc,c,args,alias_of aliases)])
 	 | VarPat id ->
-	     let aliases = merge_aliases aliases id in
-	     ([aliases], PatVar (loc,alias_of aliases)))
+	     let ids,subst = merge_aliases aliases id in
+	     (ids,[subst, PatVar (loc,alias_of (ids,subst))]))
   | CPatAtom (loc, None) ->
-      ([aliases], PatVar (loc,alias_of aliases))
+      (ids,[subst, PatVar (loc,alias_of aliases)])
+  | CPatOr (loc, pl) ->
+      assert (pl <> []);
+      let pl' = 
+	List.map (intern_cases_pattern genv scopes aliases tmp_scope) pl in
+      let (idsl,pl') = List.split pl' in
+      let ids = List.hd idsl in
+      check_or_pat_variables loc ids (List.tl idsl);
+      (ids,List.flatten pl')
 
 (**********************************************************************)
 (* Fix and CoFix                                                      *)
@@ -593,10 +615,10 @@ let locate_if_isevar loc na = function
       (try match na with
 	| Name id ->  Reserve.find_reserved_type id
 	| Anonymous -> raise Not_found 
-      with Not_found -> RHole (loc, BinderType na))
+      with Not_found -> RHole (loc, Evd.BinderType na))
   | x -> x
 
-let check_hidden_implicit_parameters id (_,_,_,indnames,_) =
+let check_hidden_implicit_parameters id (_,_,_,(indnames,_)) =
   if List.mem id indnames then
     errorlabstrm "" (str "A parameter or name of an inductive type " ++
     pr_id id ++ str " must not be used as a bound variable in the type \
@@ -624,8 +646,8 @@ let check_projection isproj nargs r =
   | RRef (loc, ref), Some _ ->
       (try
 	let n = Recordops.find_projection_nparams ref + 1 in
-	if nargs < n then 
-	  user_err_loc (loc,"",str "Projection has not enough parameters");
+	if nargs <> n then
+	  user_err_loc (loc,"",str "Projection has not the right number of explicit parameters");
       with Not_found -> 
 	user_err_loc
 	(loc,"",pr_global_env Idset.empty ref ++ str " is not a registered projection"))
@@ -633,12 +655,11 @@ let check_projection isproj nargs r =
   | _, None -> ()
 
 let get_implicit_name n imps =
-  if !Options.v7 then None
-  else Some (Impargs.name_of_implicit (List.nth imps (n-1)))
+  Some (Impargs.name_of_implicit (List.nth imps (n-1)))
 
 let set_hole_implicit i = function
-  | RRef (loc,r) -> (loc,ImplicitArg (r,i))
-  | RVar (loc,id) -> (loc,ImplicitArg (VarRef id,i))
+  | RRef (loc,r) -> (loc,Evd.ImplicitArg (r,i))
+  | RVar (loc,id) -> (loc,Evd.ImplicitArg (VarRef id,i))
   | _ -> anomaly "Only refs have implicits"
 
 let exists_implicit_name id =
@@ -679,21 +700,20 @@ let extract_explicit_arg imps args =
 (**********************************************************************)
 (* Syntax extensions                                                  *)
 
-let coerce_to_id = function
-  | CRef (Ident (_,id)) -> id 
-  | c ->
-      user_err_loc (constr_loc c, "subst_rawconstr",
-        str"This expression should be a simple identifier")
-
-let traverse_binder subst id (ids,tmpsc,scopes as env) =
+let traverse_binder subst (renaming,(ids,tmpsc,scopes as env)) id =
   try
-    (* Binders bound in the notation are consider first-order object *)
-    (* and binders not bound in the notation do not capture variables *)
-    (* outside the notation *)
-    let id' = coerce_to_id (fst (List.assoc id subst)) in
-    id', (Idset.add id' ids,tmpsc,scopes)
+    (* Binders bound in the notation are considered first-order objects *)
+    let _,id' = coerce_to_id (fst (List.assoc id subst)) in
+    (renaming,(Idset.add id' ids,tmpsc,scopes)), id'
   with Not_found ->
-    id, env
+    (* Binders not bound in the notation do not capture variables *)
+    (* outside the notation (i.e. in the substitution) *)
+    let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) subst in
+    let fvs2 = List.map snd renaming in
+    let fvs = List.flatten (List.map Idset.elements fvs1) @ fvs2 in
+    let id' = next_ident_away id fvs in
+    let renaming' = if id=id' then renaming else (id,id')::renaming in
+    (renaming',env), id'
 
 let decode_constrlist_value = function
   | CAppExpl (_,_,l) -> l
@@ -703,7 +723,7 @@ let rec subst_iterator y t = function
   | RVar (_,id) as x -> if id = y then t else x
   | x -> map_rawconstr (subst_iterator y t) x
 
-let rec subst_aconstr_in_rawconstr loc interp subst (ids,_,scopes as env) =
+let rec subst_aconstr_in_rawconstr loc interp subst (renaming,(ids,_,scopes)) =
   function
   | AVar id ->
       begin
@@ -713,6 +733,9 @@ let rec subst_aconstr_in_rawconstr loc interp subst (ids,_,scopes as env) =
 	  let (a,(scopt,subscopes)) = List.assoc id subst in
 	  interp (ids,scopt,subscopes@scopes) a
 	with Not_found -> 
+	try 
+	  RVar (loc,List.assoc id renaming)
+	with Not_found -> 
 	  (* Happens for local notation joint with inductive/fixpoint defs *)
 	  RVar (loc,id)
       end
@@ -721,31 +744,31 @@ let rec subst_aconstr_in_rawconstr loc interp subst (ids,_,scopes as env) =
         (* All elements of the list are in scopes (scopt,subscopes) *)
 	let (a,(scopt,subscopes)) = List.assoc x subst in
         let termin = 
-          subst_aconstr_in_rawconstr loc interp subst (ids,None,scopes) 
-            terminator in
+          subst_aconstr_in_rawconstr loc interp subst 
+	    (renaming,(ids,None,scopes)) terminator in
         let l = decode_constrlist_value a in
 	List.fold_right (fun a t -> 
           subst_iterator ldots_var t
             (subst_aconstr_in_rawconstr loc interp 
               ((x,(a,(scopt,subscopes)))::subst)
-              (ids,None,scopes) iter))
+	      (renaming,(ids,None,scopes)) iter))
             (if lassoc then List.rev l else l) termin
       with Not_found -> 
           anomaly "Inconsistent substitution of recursive notation")
   | t ->
       rawconstr_of_aconstr_with_binders loc (traverse_binder subst)
-      (subst_aconstr_in_rawconstr loc interp subst) (ids,None,scopes) t
+      (subst_aconstr_in_rawconstr loc interp subst)
+      (renaming,(ids,None,scopes)) t
 
 let intern_notation intern (_,tmp_scope,scopes as env) loc ntn args =
   let ntn,args = contract_notation ntn args in
-  let scopes = option_cons tmp_scope scopes in
-  let ((ids,c),df) = Symbols.interp_notation loc ntn scopes in
-  if !dump then dump_notation_location (ntn_loc loc args ntn) ntn df;
+  let ((ids,c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in
+  if !dump then dump_notation_location (ntn_loc loc args ntn) df;
   let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in
-  subst_aconstr_in_rawconstr loc intern subst env c
+  subst_aconstr_in_rawconstr loc intern subst ([],env) c
 
 let set_type_scope (ids,tmp_scope,scopes) =
-  (ids,Some Symbols.type_scope,scopes)
+  (ids,Some Notation.type_scope,scopes)
 
 let reset_tmp_scope (ids,tmp_scope,scopes) =
   (ids,None,scopes)
@@ -753,7 +776,7 @@ let reset_tmp_scope (ids,tmp_scope,scopes) =
 (**********************************************************************)
 (* Main loop                                                          *)
 
-let internalise sigma env allow_soapp lvar c =
+let internalise sigma globalenv env allow_soapp lvar c =
   let rec intern (ids,tmp_scope,scopes as env) = function
     | CRef ref as x ->
 	let (c,imp,subscopes,l) = intern_reference env lvar ref in
@@ -769,20 +792,35 @@ let internalise sigma env allow_soapp lvar c =
           with Not_found ->
 	    raise (InternalisationError (locid,UnboundFixName (false,iddef)))
 	in
-	let ids' = List.fold_right Idset.add lf ids in
         let idl = Array.map
-          (fun (id,n,bl,ty,bd) ->
-            let ((ids'',_,_),rbl) =
-              List.fold_left intern_local_binder (env,[]) bl in
-	    let ids''' = List.fold_right Idset.add lf ids'' in
-            (List.rev rbl,
-             intern_type (ids'',tmp_scope,scopes) ty,
-             intern (ids''',None,scopes) bd)) dl in
-	RRec (loc,RFix (Array.map (fun (_,n,_,_,_) -> n) dl,n),
+          (fun (id,(n,order),bl,ty,bd) ->
+	     let intern_ro_arg c f =
+	       let before, after = list_chop (succ (out_some n)) bl in
+	       let ((ids',_,_),rafter) =
+		 List.fold_left intern_local_binder (env,[]) after in
+	       let ro = (intern (ids', tmp_scope, scopes) c) in
+		 f ro, List.fold_left intern_local_binder (env,rafter) before
+	     in
+	     let ro, ((ids',_,_),rbl) =
+	       (match order with
+		    CStructRec -> 
+		      RStructRec,
+		      List.fold_left intern_local_binder (env,[]) bl
+		  | CWfRec c ->
+		      intern_ro_arg c (fun r -> RWfRec r)
+		  | CMeasureRec c ->
+		      intern_ro_arg c (fun r -> RMeasureRec r))
+	    in
+	    let ids'' = List.fold_right Idset.add lf ids' in
+	     ((n, ro), List.rev rbl, 
+             intern_type (ids',tmp_scope,scopes) ty,
+             intern (ids'',None,scopes) bd)) dl in
+	RRec (loc,RFix 
+	      (Array.map (fun (ro,_,_,_) -> ro) idl,n),
               Array.of_list lf,
-              Array.map (fun (bl,_,_) -> bl) idl,
-              Array.map (fun (_,ty,_) -> ty) idl,
-              Array.map (fun (_,_,bd) -> bd) idl)
+              Array.map (fun (_,bl,_,_) -> bl) idl,
+              Array.map (fun (_,_,ty,_) -> ty) idl,
+              Array.map (fun (_,_,_,bd) -> bd) idl)
     | CCoFix (loc, (locid,iddef), dl) ->
         let lf = List.map (fun (id,_,_,_) -> id) dl in
         let dl = Array.of_list dl in
@@ -792,15 +830,14 @@ let internalise sigma env allow_soapp lvar c =
           with Not_found ->
 	    raise (InternalisationError (locid,UnboundFixName (true,iddef)))
 	in
-	let ids' = List.fold_right Idset.add lf ids in
         let idl = Array.map
           (fun (id,bl,ty,bd) ->
-            let ((ids'',_,_),rbl) =
+            let ((ids',_,_),rbl) =
               List.fold_left intern_local_binder (env,[]) bl in
-	    let ids''' = List.fold_right Idset.add lf ids'' in
+	    let ids'' = List.fold_right Idset.add lf ids' in
             (List.rev rbl,
-             intern_type (ids'',tmp_scope,scopes) ty,
-             intern (ids''',None,scopes) bd)) dl in
+             intern_type (ids',tmp_scope,scopes) ty,
+             intern (ids'',None,scopes) bd)) dl in
 	RRec (loc,RCoFix n,
               Array.of_list lf,
               Array.map (fun (bl,_,_) -> bl) idl,
@@ -819,15 +856,16 @@ let internalise sigma env allow_soapp lvar c =
     | CLetIn (loc,(_,na),c1,c2) ->
 	RLetIn (loc, na, intern (reset_tmp_scope env) c1,
           intern (push_name_env lvar env na) c2)
-    | CNotation (loc,"- _",[CNumeral(_,Bignat.POS p)]) ->
-        let scopes = option_cons tmp_scope scopes in
-        Symbols.interp_numeral loc (Bignat.NEG p) scopes
+    | CNotation (loc,"- _",[CPrim (_,Numeral p)])
+	when Bigint.is_strictly_pos p -> 
+	intern env (CPrim (loc,Numeral (Bigint.neg p)))
     | CNotation (_,"( _ )",[a]) -> intern env a
     | CNotation (loc,ntn,args) ->
         intern_notation intern env loc ntn args
-    | CNumeral (loc, n) ->
-	let scopes = option_cons tmp_scope scopes in
-	Symbols.interp_numeral loc n scopes
+    | CPrim (loc, p) ->
+	let c,df = Notation.interp_prim_token loc p (tmp_scope,scopes) in
+	if !dump then dump_notation_location (fst (unloc loc)) df;
+	c
     | CDelimiters (loc, key, e) ->
 	intern (ids,None,find_delimiters_scope loc key::scopes) e
     | CAppExpl (loc, (isproj,ref), args) ->
@@ -847,115 +885,122 @@ let internalise sigma env allow_soapp lvar c =
                 let c = intern_notation intern env loc ntn [] in
                 find_appl_head_data lvar c
             | x -> (intern env f,[],[],[]) in
-	let args = intern_impargs c env impargs args_scopes (merge_impargs l args) in
+	let args = 
+	  intern_impargs c env impargs args_scopes (merge_impargs l args) in
 	check_projection isproj (List.length args) c;
 	(match c with 
           (* Now compact "(f args') args" *)
 	  | RApp (loc', f', args') -> RApp (join_loc loc' loc, f',args'@args)
 	  | _ -> RApp (loc, c, args))
-    | CCases (loc, (po,rtnpo), tms, eqns) ->
+    | CCases (loc, rtnpo, tms, eqns) ->
         let tms,env' = List.fold_right
           (fun citm (inds,env) ->
 	    let (tm,ind),nal = intern_case_item env citm in
-	    (tm,ref ind)::inds,List.fold_left (push_name_env lvar) env nal)
+	    (tm,ind)::inds,List.fold_left (push_name_env lvar) env nal)
 	  tms ([],env) in
-        let rtnpo = option_app (intern_type env') rtnpo in
-	RCases (loc, (option_app (intern_type env) po, ref rtnpo), tms,
-		List.map (intern_eqn (List.length tms) env) eqns)
-    | COrderedCase (loc, tag, po, c, cl) ->
-	let env = reset_tmp_scope env in
-	ROrderedCase (loc, tag, option_app (intern_type env) po,
-	          intern env c,
-		  Array.of_list (List.map (intern env) cl),ref None)
+        let rtnpo = option_map (intern_type env') rtnpo in
+        let eqns' = List.map (intern_eqn (List.length tms) env) eqns in
+	RCases (loc, rtnpo, tms, List.flatten eqns')
     | CLetTuple (loc, nal, (na,po), b, c) ->
 	let env' = reset_tmp_scope env in
         let ((b',(na',_)),ids) = intern_case_item env' (b,(na,None)) in
         let env'' = List.fold_left (push_name_env lvar) env ids in
-        let p' = option_app (intern_type env'') po in
+        let p' = option_map (intern_type env'') po in
         RLetTuple (loc, nal, (na', p'), b',
                    intern (List.fold_left (push_name_env lvar) env nal) c)
     | CIf (loc, c, (na,po), b1, b2) ->
 	let env' = reset_tmp_scope env in
         let ((c',(na',_)),ids) = intern_case_item env' (c,(na,None)) in
         let env'' = List.fold_left (push_name_env lvar) env ids in
-        let p' = option_app (intern_type env'') po in
+        let p' = option_map (intern_type env'') po in
         RIf (loc, c', (na', p'), intern env b1, intern env b2)
     | CHole loc -> 
-	RHole (loc, QuestionMark)
+	RHole (loc, Evd.QuestionMark)
     | CPatVar (loc, n) when allow_soapp ->
 	RPatVar (loc, n)
-    | CPatVar (loc, (false,n)) when Options.do_translate () ->
-	RVar (loc, n)
-    | CPatVar (loc, (false,n as x)) ->
-        if List.mem n (fst (let (a,_,_,_,_) = lvar in a)) & !Options.v7 then
-	  RVar (loc, n)
-	else
-          error_unbound_patvar loc n
+    | CPatVar (loc, (false,n)) ->
+        error_unbound_patvar loc n
     | CPatVar (loc, _) ->
 	raise (InternalisationError (loc,NegativeMetavariable))
     | CEvar (loc, n) ->
 	REvar (loc, n, None)
     | CSort (loc, s) ->
 	RSort(loc,s)
-    | CCast (loc, c1, c2) ->
-	RCast (loc,intern env c1,intern_type env c2)
+    | CCast (loc, c1, k, c2) ->
+	RCast (loc,intern env c1,k,intern_type env c2)
 
     | CDynamic (loc,d) -> RDynamic (loc,d)
 
-  and intern_type (ids,_,scopes) =
-    intern (ids,Some Symbols.type_scope,scopes)
+  and intern_type env = intern (set_type_scope env)
 
   and intern_local_binder ((ids,ts,sc as env),bl) = function
-      LocalRawAssum(nal,ty) ->
-        let (loc,na) = List.hd nal in
-        (* TODO: fail if several names with different implicit types *)
-        let ty = locate_if_isevar loc na (intern_type env ty) in
+    | LocalRawAssum(nal,ty) ->
+	let (loc,na) = List.hd nal in
+	(* TODO: fail if several names with different implicit types *)
+	let ty = locate_if_isevar loc na (intern_type env ty) in
         List.fold_left
           (fun ((ids,ts,sc),bl) (_,na) ->
             ((name_fold Idset.add na ids,ts,sc), (na,None,ty)::bl))
           (env,bl) nal
     | LocalRawDef((loc,na),def) ->
         ((name_fold Idset.add na ids,ts,sc),
-         (na,Some(intern env def),RHole(loc,BinderType na))::bl)
-
-  and intern_eqn n (ids,tmp_scope,scopes as env) (loc,lhs,rhs) =
-	let (idsl_substl_list,pl) =
-	  List.split 
-	    (List.map (intern_cases_pattern scopes ([],[]) None) lhs) in
-	let idsl, substl = List.split (List.flatten idsl_substl_list) in
-	let eqn_ids = List.flatten idsl in
-	let subst = List.flatten substl in 
-	(* Linearity implies the order in ids is irrelevant *)
-	check_linearity lhs eqn_ids;
-	check_uppercase loc eqn_ids;
-	check_number_of_pattern loc n pl;
-	let rhs = replace_vars_constr_expr subst rhs in
-	List.iter message_redundant_alias subst;
-	let env_ids = List.fold_right Idset.add eqn_ids ids in
-	(loc, eqn_ids,pl,intern (env_ids,tmp_scope,scopes) rhs)
+         (na,Some(intern env def),RHole(loc,Evd.BinderType na))::bl)
+
+  (* Expands a multiple pattern into a disjunction of multiple patterns *)
+  and intern_multiple_pattern scopes pl =
+    let idsl_pll = 
+      List.map (intern_cases_pattern globalenv scopes ([],[]) None) pl in
+    product_of_cases_patterns [] idsl_pll
+
+  (* Expands a disjunction of multiple pattern *)
+  and intern_disjunctive_multiple_pattern scopes loc mpl =
+    assert (mpl <> []);
+    let mpl' = List.map (intern_multiple_pattern scopes) mpl in
+    let (idsl,mpl') = List.split mpl' in
+    let ids = List.hd idsl in
+    check_or_pat_variables loc ids (List.tl idsl);
+    (ids,List.flatten mpl')
+
+  (* Expands a pattern-matching clause [lhs => rhs] *)
+  and intern_eqn n (ids,tmp_scope,scopes) (loc,lhs,rhs) =
+    let eqn_ids,pll = intern_disjunctive_multiple_pattern scopes loc lhs in
+    (* Linearity implies the order in ids is irrelevant *)
+    check_linearity lhs eqn_ids;
+    check_number_of_pattern loc n (snd (List.hd pll));
+    let env_ids = List.fold_right Idset.add eqn_ids ids in
+    List.map (fun (subst,pl) ->
+      let rhs = replace_vars_constr_expr subst rhs in
+      List.iter message_redundant_alias subst;
+      let rhs' = intern (env_ids,tmp_scope,scopes) rhs in
+      (loc,eqn_ids,pl,rhs')) pll
 
   and intern_case_item (vars,_,scopes as env) (tm,(na,t)) =
     let tm' = intern env tm in
     let ids,typ = match t with
     | Some t -> 
-	let tids = names_of_cases_indtype t in
+	let tids = ids_of_cases_indtype t in
 	let tids = List.fold_right Idset.add tids Idset.empty in
 	let t = intern_type (tids,None,scopes) t in
-	begin match t with
-	  | RRef (loc,IndRef ind) -> [],Some (loc,ind,[])
-	  | RApp (loc,RRef (_,IndRef ind),l) ->
-	      let nal = List.map (function
-		| RHole _ -> Anonymous
-		| RVar (_,id) -> Name id
-		| c ->
-		    user_err_loc (loc_of_rawconstr c,"",str "Not a name")) l in
-	      nal, Some (loc,ind,nal)
-	  | _ -> error_bad_inductive_type (loc_of_rawconstr t)
-	end
+	let loc,ind,l = match t with
+	    | RRef (loc,IndRef ind) -> (loc,ind,[])
+	    | RApp (loc,RRef (_,IndRef ind),l) -> (loc,ind,l)
+	    | _ -> error_bad_inductive_type (loc_of_rawconstr t) in
+	let nparams, nrealargs = inductive_nargs globalenv ind in
+	let nindargs = nparams + nrealargs in
+	if List.length l <> nindargs then
+	  error_wrong_numarg_inductive_loc loc globalenv ind nindargs;
+	let nal = List.map (function
+	  | RHole loc -> Anonymous
+	  | RVar (_,id) -> Name id
+	  | c -> user_err_loc (loc_of_rawconstr c,"",str "Not a name")) l in
+	let parnal,realnal = list_chop nparams nal in
+	if List.exists ((<>) Anonymous) parnal then
+	  error_inductive_parameter_not_implicit loc;
+	realnal, Some (loc,ind,nparams,realnal)
     | None -> 
 	[], None in
     let na = match tm', na with
-      | RVar (_,id), None when Idset.mem id vars & not !Options.v7 -> Name id
+      | RVar (_,id), None when Idset.mem id vars -> Name id
       | _, None -> Anonymous
       | _, Some na -> na in
     (tm',(na,typ)), na::ids
@@ -1032,114 +1077,77 @@ let extract_ids env =
     (Termops.ids_of_rel_context (Environ.rel_context env))
     Idset.empty
 
-let interp_rawconstr_gen_with_implicits isarity sigma env (indpars,impls) allow_soapp ltacvar c =
-  let tmp_scope = if isarity then Some Symbols.type_scope else None in
-  internalise sigma (extract_ids env, tmp_scope,[])
-    allow_soapp (ltacvar,Environ.named_context env, [], indpars, impls) c
+let intern_gen isarity sigma env
+               ?(impls=([],[])) ?(allow_soapp=false) ?(ltacvars=([],[]))
+               c =
+  let tmp_scope = 
+    if isarity then Some Notation.type_scope else None in
+  internalise sigma env (extract_ids env, tmp_scope,[])
+    allow_soapp (ltacvars,Environ.named_context env, [], impls) c
 
-let interp_rawconstr_gen isarity sigma env allow_soapp ltacvar c =
-  interp_rawconstr_gen_with_implicits isarity sigma env ([],[]) allow_soapp ltacvar c
+let intern_constr sigma env c = intern_gen false sigma env c 
 
-let interp_rawconstr sigma env c =
-  interp_rawconstr_gen false sigma env false ([],[]) c
-
-let interp_rawtype sigma env c =
-  interp_rawconstr_gen true sigma env false ([],[]) c
-
-let interp_rawtype_with_implicits sigma env impls c =
-  interp_rawconstr_gen_with_implicits true sigma env impls false ([],[]) c
-
-let interp_rawconstr_with_implicits sigma env vars impls c =
-  interp_rawconstr_gen_with_implicits false sigma env ([],impls) false
-    (vars,[]) c
+let intern_pattern env patt =
+  try
+    intern_cases_pattern env [] ([],[]) None patt 
+  with 
+      InternalisationError (loc,e) ->
+	user_err_loc (loc,"internalize",explain_internalisation_error e)
 
-(*
-(* The same as interp_rawconstr but with a list of variables which must not be
-   globalized *)
 
-let interp_rawconstr_wo_glob sigma env lvar c =
-  interp_rawconstr_gen sigma env [] (Some []) lvar c
-*)
+let intern_ltac isarity ltacvars sigma env c =
+  intern_gen isarity sigma env ~ltacvars:ltacvars c
 
 (*********************************************************************)
 (* Functions to parse and interpret constructions *)
 
-let interp_constr sigma env c =
-  understand sigma env (interp_rawconstr sigma env c)
-
-let interp_openconstr sigma env c =
-  understand_gen_tcc sigma env [] None (interp_rawconstr sigma env c)
-
-let interp_casted_openconstr sigma env c typ =
-  understand_gen_tcc sigma env [] (Some typ) (interp_rawconstr sigma env c)
+let interp_gen kind sigma env 
+               ?(impls=([],[])) ?(allow_soapp=false) ?(ltacvars=([],[]))
+               c =
+  Default.understand_gen kind sigma env 
+    (intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars sigma env c)
 
-let interp_type sigma env c =
-  understand_type sigma env (interp_rawtype sigma env c)
-
-let interp_binder sigma env na t =
-  let t = interp_rawtype sigma env t in
-  understand_type sigma env (locate_if_isevar (loc_of_rawconstr t) na t)
-
-let interp_type_with_implicits sigma env impls c =
-  understand_type sigma env (interp_rawtype_with_implicits sigma env impls c)
-
-let judgment_of_rawconstr sigma env c =
-  understand_judgment sigma env (interp_rawconstr sigma env c)
+let interp_constr sigma env c =
+  interp_gen (OfType None) sigma env c 
 
-let type_judgment_of_rawconstr sigma env c =
-  understand_type_judgment sigma env (interp_rawconstr sigma env c)
+let interp_type sigma env ?(impls=([],[])) c =
+  interp_gen IsType sigma env ~impls c
 
-(* To retype a list of key*constr with undefined key *)
-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 sigma env ?(impls=([],[])) c typ =
+  interp_gen (OfType (Some typ)) sigma env ~impls c 
 
-(*  List.map (fun (x,csr) -> (x,Retyping.get_judgment_of env sigma csr)) lst*)
+let interp_open_constr sigma env c =
+  Default.understand_tcc sigma env (intern_constr sigma env c)
 
-type ltac_sign = 
-  identifier list * (identifier * identifier option) list
+let interp_constr_judgment sigma env c =
+  Default.understand_judgment sigma env (intern_constr sigma env c)
 
-type ltac_env = 
-  (identifier * Term.constr) list * (identifier * identifier option) list
 
-(* Interprets a constr according to two lists *)
-(* of instantiations (variables and metas)    *)
-(* Note: typ is retyped *)
-let interp_constr_gen sigma env (ltacvars,unbndltacvars) c exptyp =
-  let c = interp_rawconstr_gen false sigma env false
-    (List.map fst ltacvars,unbndltacvars) c in
-  let typs = retype_list sigma env ltacvars in
-  understand_gen sigma env typs exptyp c
+let interp_constr_evars_gen isevars env ?(impls=([],[])) kind c =
+  Default.understand_tcc_evars isevars env kind
+    (intern_gen (kind=IsType) ~impls (Evd.evars_of !isevars) env c)
 
-(*Interprets a casted constr according to two lists of instantiations
-  (variables and metas)*)
-let interp_openconstr_gen sigma env (ltacvars,unbndltacvars) c exptyp =
-  let c = interp_rawconstr_gen false sigma env false
-    (List.map fst ltacvars,unbndltacvars) c in
-  let typs = retype_list sigma env ltacvars in
-  understand_gen_tcc sigma env typs exptyp c
+let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ =
+  interp_constr_evars_gen isevars env ~impls (OfType (Some typ)) c
 
-let interp_casted_constr sigma env c typ = 
-  understand_gen sigma env [] (Some typ) (interp_rawconstr sigma env c)
+let interp_type_evars isevars env ?(impls=([],[])) c =
+  interp_constr_evars_gen isevars env IsType ~impls c
 
-let interp_casted_constr_with_implicits sigma env impls c typ =
-  understand_gen sigma env [] (Some typ) 
-    (interp_rawconstr_with_implicits sigma env [] impls c)
+let interp_constr_judgment_evars isevars env c =
+  Default.understand_judgment_tcc isevars env
+    (intern_constr (Evd.evars_of !isevars) env c)
 
-let interp_constrpattern_gen sigma env ltacvar c =
-  let c = interp_rawconstr_gen false sigma env true (ltacvar,[]) c in
-  pattern_of_rawconstr c
+type ltac_sign = identifier list * unbound_ltac_var_map
 
 let interp_constrpattern sigma env c =
-  interp_constrpattern_gen sigma env [] c
+  pattern_of_rawconstr (intern_gen false sigma env ~allow_soapp:true c)
 
 let interp_aconstr impls vars a =
   let env = Global.env () in
   (* [vl] is intended to remember the scope of the free variables of [a] *)
   let vl = List.map (fun id -> (id,ref None)) vars in
-  let c = internalise Evd.empty (extract_ids env, None, [])
-    false (([],[]),Environ.named_context env,vl,[],impls) a in
+  let c = internalise Evd.empty (Global.env()) (extract_ids env, None, [])
+    false (([],[]),Environ.named_context env,vl,([],impls)) a in
   (* Translate and check that [c] has all its free variables bound in [vars] *)
   let a = aconstr_of_rawconstr vars c in
   (* Returns [a] and the ordered list of variables with their scopes *)
@@ -1148,6 +1156,57 @@ let interp_aconstr impls vars a =
     (fun (id,r) -> (id,match !r with None -> None,[] | Some (a,l) -> a,l)) vl,
   a
 
+(* Interpret binders and contexts  *)
+
+let interp_binder sigma env na t =
+  let t = intern_gen true sigma env t in
+  let t' = locate_if_isevar (loc_of_rawconstr t) na t in
+  Default.understand_type sigma env t'
+
+let interp_binder_evars isevars env na t =
+  let t = intern_gen true (Evd.evars_of !isevars) env t in
+  let t' = locate_if_isevar (loc_of_rawconstr t) na t in
+  Default.understand_tcc_evars isevars env IsType t'
+
+open Environ
+open Term
+
+let interp_context sigma env params = 
+  List.fold_left
+    (fun (env,params) d -> match d with
+      | LocalRawAssum ([_,na],(CHole _ as t)) ->
+	  let t = interp_binder sigma env na t in
+	  let d = (na,None,t) in
+	  (push_rel d env, d::params)
+      | LocalRawAssum (nal,t) ->
+	  let t = interp_type sigma env t in
+	  let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
+	  let ctx = List.rev ctx in
+	  (push_rel_context ctx env, ctx@params)
+      | LocalRawDef ((_,na),c) ->
+	  let c = interp_constr_judgment sigma env c in
+	  let d = (na, Some c.uj_val, c.uj_type) in
+	  (push_rel d env,d::params))
+    (env,[]) params
+
+let interp_context_evars isevars env params =
+  List.fold_left
+    (fun (env,params) d -> match d with
+      | LocalRawAssum ([_,na],(CHole _ as t)) ->
+	  let t = interp_binder_evars isevars env na t in
+	  let d = (na,None,t) in
+	  (push_rel d env, d::params)
+      | LocalRawAssum (nal,t) ->
+	  let t = interp_type_evars isevars env t in
+	  let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
+	  let ctx = List.rev ctx in
+	  (push_rel_context ctx env, ctx@params)
+      | LocalRawDef ((_,na),c) ->
+	  let c = interp_constr_judgment_evars isevars env c in
+	  let d = (na, Some c.uj_val, c.uj_type) in
+	  (push_rel d env,d::params))
+    (env,[]) params
+
 (**********************************************************************)
 (* Locating reference, possibly via an abbreviation *)
 
@@ -1166,7 +1225,7 @@ let is_global id =
     false
 
 let global_reference id = 
-  constr_of_reference (locate_reference (make_short_qualid id))
+  constr_of_global (locate_reference (make_short_qualid id))
 
 let construct_reference ctx id =
   try
@@ -1175,5 +1234,5 @@ let construct_reference ctx id =
     global_reference id
 
 let global_reference_in_absolute_module dir id = 
-  constr_of_reference (Nametab.absolute_reference (Libnames.make_path dir id))
+  constr_of_global (Nametab.absolute_reference (Libnames.make_path dir id))
 
diff --git a/interp/constrintern.mli b/interp/constrintern.mli
index 06039da7..d88a058d 100644
--- a/interp/constrintern.mli
+++ b/interp/constrintern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: constrintern.mli,v 1.15.2.2 2005/01/21 16:41:50 herbelin Exp $ i*)
+(*i $Id: constrintern.mli 9154 2006-09-20 17:18:18Z corbinea $ i*)
 
 (*i*)
 open Names
@@ -17,9 +17,9 @@ open Environ
 open Libnames
 open Rawterm
 open Pattern
-open Coqast
 open Topconstr
 open Termops
+open Pretyping
 (*i*)
 
 (*s Translation from front abstract syntax of term to untyped terms (rawconstr)
@@ -34,73 +34,84 @@ open Termops
 *)
 
 (* To interpret implicits and arg scopes of recursive variables in
-   inductive types and recursive definitions *)
+   inductive types and recursive definitions; mention of a list of
+   implicits arguments in the ``rel'' part of [env]; the second
+   argument associates a list of implicit positions and scopes to
+   identifiers declared in the [rel_context] of [env] *)
+
 type var_internalisation_data =
     identifier list * Impargs.implicits_list * scope_name option list
 
 type implicits_env = (identifier * var_internalisation_data) list
 type full_implicits_env = identifier list * implicits_env
 
-type ltac_sign = 
-  identifier list * (identifier * identifier option) list
-
-type ltac_env = 
-  (identifier * constr) list * (identifier * identifier option) list
-
-(* Interprets global names, including syntactic defs and section variables *)
-val interp_rawconstr     : evar_map -> env -> constr_expr -> rawconstr
-val interp_rawconstr_gen : bool -> evar_map -> env -> 
-    bool -> ltac_sign -> constr_expr -> rawconstr
-
-(*s Composing the translation with typing *)
-val interp_constr        : evar_map -> env -> constr_expr -> constr
-val interp_casted_constr : evar_map -> env -> constr_expr -> types -> constr
-val interp_type          : evar_map -> env -> constr_expr -> types
-val interp_binder        : evar_map -> env -> name -> constr_expr -> types
-val interp_openconstr    : evar_map -> env -> constr_expr -> evar_map * constr
-val interp_casted_openconstr    :
-  evar_map -> env -> constr_expr -> constr -> evar_map * constr
-
-(* [interp_type_with_implicits] extends [interp_type] by allowing
-   implicits arguments in the ``rel'' part of [env]; the extra
-   argument associates a list of implicit positions to identifiers
-   declared in the [rel_context] of [env] *)
-val interp_type_with_implicits : 
-  evar_map -> env -> full_implicits_env -> constr_expr -> types
-
-val interp_casted_constr_with_implicits :
-  evar_map -> env -> implicits_env -> constr_expr -> types -> constr
-
-val interp_rawconstr_with_implicits :
-  evar_map -> env -> identifier list -> implicits_env -> constr_expr -> 
-    rawconstr
-
-(*s Build a judgement from *)
-val judgment_of_rawconstr : evar_map -> env -> constr_expr -> unsafe_judgment
-val type_judgment_of_rawconstr :
-  evar_map -> env -> constr_expr -> unsafe_type_judgment
-
-(* Interprets a constr according to two lists of instantiations (variables and
-  metas), possibly casting it*)
-val interp_constr_gen     :
-  evar_map -> env -> ltac_env -> constr_expr -> constr option -> constr
-
-(* Interprets a constr according to two lists of instantiations (variables and
-  metas), possibly casting it, and turning unresolved evar into metas*)
-val interp_openconstr_gen     :
-  evar_map -> env -> ltac_env ->
-    constr_expr -> constr option -> evar_map * constr
-
-(* Interprets constr patterns according to a list of instantiations
-  (variables)*)
-val interp_constrpattern_gen : evar_map -> env -> identifier list ->
-  constr_expr -> patvar list * constr_pattern
+type ltac_sign = identifier list * unbound_ltac_var_map
+
+(*s Internalisation performs interpretation of global names and notations *)
+
+val intern_constr : evar_map -> env -> constr_expr -> rawconstr
+
+val intern_gen : bool -> evar_map -> env ->
+  ?impls:full_implicits_env -> ?allow_soapp:bool -> ?ltacvars:ltac_sign ->
+  constr_expr -> rawconstr
+
+val intern_pattern : env -> cases_pattern_expr ->
+  Names.identifier list *
+    ((Names.identifier * Names.identifier) list * Rawterm.cases_pattern) list
+
+val intern_pattern : env -> cases_pattern_expr ->
+  Names.identifier list *
+    ((Names.identifier * Names.identifier) list * Rawterm.cases_pattern) list
+
+(*s Composing internalisation with pretyping *)
+
+(* Main interpretation function *)
+
+val interp_gen : typing_constraint -> evar_map -> env ->
+  ?impls:full_implicits_env -> ?allow_soapp:bool -> ?ltacvars:ltac_sign ->
+  constr_expr -> constr
+
+(* Particular instances *)
+
+val interp_constr : evar_map -> env -> 
+  constr_expr -> constr
+
+val interp_casted_constr : evar_map -> env -> ?impls:full_implicits_env -> 
+  constr_expr -> types -> constr
+
+val interp_type : evar_map -> env -> ?impls:full_implicits_env -> 
+  constr_expr -> types
+
+val interp_open_constr   : evar_map -> env -> constr_expr -> evar_map * constr
+
+val interp_casted_constr_evars : evar_defs ref -> env -> 
+  ?impls:full_implicits_env -> constr_expr -> types -> constr
+
+val interp_type_evars : evar_defs ref -> env -> ?impls:full_implicits_env ->
+  constr_expr -> types
+
+(*s Build a judgment  *)
+
+val interp_constr_judgment : evar_map -> env -> constr_expr -> unsafe_judgment
+
+(* Interprets constr patterns *)
 
 val interp_constrpattern : 
   evar_map -> env -> constr_expr -> patvar list * constr_pattern
 
 val interp_reference : ltac_sign -> reference -> rawconstr
 
+(* Interpret binders *)
+
+val interp_binder  : evar_map -> env -> name -> constr_expr -> types
+
+(* Interpret contexts: returns extended env and context *)
+
+val interp_context : evar_map -> env -> local_binder list -> env * rel_context
+
+val interp_context_evars : 
+  evar_defs ref -> env -> local_binder list -> env * rel_context
+
 (* Locating references of constructions, possibly via a syntactic definition *)
 
 val locate_reference : qualid -> global_reference
@@ -110,6 +121,7 @@ val global_reference : identifier -> constr
 val global_reference_in_absolute_module : dir_path -> identifier -> constr
 
 (* Interprets into a abbreviatable constr *)
+
 val interp_aconstr : implicits_env -> identifier list -> constr_expr ->
   interpretation
 
@@ -120,7 +132,3 @@ val for_grammar : ('a -> 'b) -> 'a -> 'b
 type coqdoc_state
 val coqdoc_freeze : unit -> coqdoc_state
 val coqdoc_unfreeze : coqdoc_state -> unit
-
-(* For v8 translation *)
-val set_temporary_implicits_in :
-  (identifier * Impargs.implicits_list) list -> unit
diff --git a/interp/coqlib.ml b/interp/coqlib.ml
index 8ce9bfaf..79a217a1 100644
--- a/interp/coqlib.ml
+++ b/interp/coqlib.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqlib.ml,v 1.14.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+(* $Id: coqlib.ml 8866 2006-05-28 16:21:04Z herbelin $ *)
 
 open Util
 open Pp
@@ -16,19 +16,25 @@ open Libnames
 open Pattern
 open Nametab
 
+(************************************************************************)
+(* Generic functions to find Coq objects *)
+
+type message = string
+
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
 
-let gen_reference locstr dir s =
-  let dir = make_dir ("Coq"::dir) in
-  let id = Constrextern.id_of_v7_string s in
-  let sp = Libnames.make_path dir id in
+let find_reference locstr dir s =
+  let sp = Libnames.make_path (make_dir dir) (id_of_string s) in
   try
     Nametab.absolute_reference sp
   with Not_found ->
     anomaly (locstr^": cannot find "^(string_of_path sp))
-    
-let gen_constant locstr dir s = 
-  constr_of_reference (gen_reference locstr dir s)
+
+let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s
+let coq_constant locstr dir s = constr_of_global (coq_reference locstr dir s)
+
+let gen_reference = coq_reference
+let gen_constant = coq_constant
 
 let list_try_find f = 
   let rec try_find_f = function
@@ -43,11 +49,11 @@ let has_suffix_in_dirs dirs ref =
 
 let gen_constant_in_modules locstr dirs s =
   let dirs = List.map make_dir dirs in
-  let id = Constrextern.id_of_v7_string s in
+  let id = id_of_string s in
   let all = Nametab.locate_all (make_short_qualid id) in
   let these = List.filter (has_suffix_in_dirs dirs) all in
   match these with
-    | [x] -> constr_of_reference x
+    | [x] -> constr_of_global x
     | [] ->
 	anomalylabstrm "" (str (locstr^": cannot find "^s^
 	" in module"^(if List.length dirs > 1 then "s " else " ")) ++
@@ -58,9 +64,27 @@ let gen_constant_in_modules locstr dirs s =
 	" in module"^(if List.length dirs > 1 then "s " else " ")) ++
 	prlist_with_sep pr_coma pr_dirpath dirs)
 
-let init_reference dir s=gen_reference "Coqlib" ("Init"::dir) s
 
-let init_constant dir s=gen_constant "Coqlib" ("Init"::dir) s  
+(* For tactics/commands requiring vernacular libraries *)
+
+let check_required_library d =
+  let d' = List.map id_of_string d in
+  let dir = make_dirpath (List.rev d') in
+  if not (Library.library_is_loaded dir) then
+(* Loading silently ...
+    let m, prefix = list_sep_last d' in
+    read_library 
+     (dummy_loc,make_qualid (make_dirpath (List.rev prefix)) m)
+*)
+(* or failing ...*)
+    error ("Library "^(list_last d)^" has to be required first")
+
+(************************************************************************)
+(* Specific Coq objects *)
+
+let init_reference dir s = gen_reference "Coqlib" ("Init"::dir) s
+
+let init_constant dir s = gen_constant "Coqlib" ("Init"::dir) s  
 
 let arith_dir = ["Coq";"Arith"]
 let arith_modules = [arith_dir]
@@ -91,22 +115,33 @@ let datatypes_module = make_dir ["Coq";"Init";"Datatypes"]
 let arith_module = make_dir ["Coq";"Arith";"Arith"]
 
 (* TODO: temporary hack *)
-let make_path dir id = Libnames.encode_kn dir id
+let make_kn dir id = Libnames.encode_kn dir id
 
-let nat_path = make_path datatypes_module (id_of_string "nat")
+(** Natural numbers *)
+let nat_kn = make_kn datatypes_module (id_of_string "nat")
+let nat_path = Libnames.make_path datatypes_module (id_of_string "nat")
 
-let glob_nat = IndRef (nat_path,0)
+let glob_nat = IndRef (nat_kn,0)
 
-let path_of_O = ((nat_path,0),1)
-let path_of_S = ((nat_path,0),2)
+let path_of_O = ((nat_kn,0),1)
+let path_of_S = ((nat_kn,0),2)
 let glob_O = ConstructRef path_of_O
 let glob_S = ConstructRef path_of_S
 
-let eq_path = make_path logic_module (id_of_string "eq")
-let eqT_path = make_path logic_module (id_of_string "eq")
+(** Booleans *)
+let bool_kn = make_kn datatypes_module (id_of_string "bool")
+
+let glob_bool = IndRef (bool_kn,0)
 
-let glob_eq = IndRef (eq_path,0)
-let glob_eqT = IndRef (eqT_path,0)
+let path_of_true = ((bool_kn,0),1)
+let path_of_false = ((bool_kn,0),2)
+let glob_true  = ConstructRef path_of_true
+let glob_false  = ConstructRef path_of_false
+
+(** Equality *)
+let eq_kn = make_kn logic_module (id_of_string "eq")
+
+let glob_eq = IndRef (eq_kn,0)
 
 type coq_sigma_data = {
   proj1 : constr;
@@ -117,12 +152,7 @@ type coq_sigma_data = {
 
 type 'a delayed = unit -> 'a
 
-let build_sigma_set () =
-  { proj1 = init_constant ["Specif"] "projS1";
-    proj2 = init_constant ["Specif"] "projS2";
-    elim = init_constant ["Specif"] "sigS_rec";
-    intro = init_constant ["Specif"] "existS";
-    typ = init_constant ["Specif"] "sigS" }
+let build_sigma_set () = anomaly "Use build_sigma_type"
 
 let build_sigma_type () =
   { proj1 = init_constant ["Specif"] "projT1";
@@ -131,6 +161,13 @@ let build_sigma_type () =
     intro = init_constant ["Specif"] "existT";
     typ = init_constant ["Specif"] "sigT" }
 
+let build_prod () =
+  { proj1 = init_constant ["Datatypes"] "fst";
+    proj2 = init_constant ["Datatypes"] "snd";
+    elim = init_constant ["Datatypes"] "prod_rec";
+    intro = init_constant ["Datatypes"] "pair";
+    typ = init_constant ["Datatypes"] "prod" }
+
 (* Equalities *)
 type coq_leibniz_eq_data = {
   eq   : constr;
@@ -160,9 +197,10 @@ let build_coq_eq_data () = {
   rrec = Some (Lazy.force coq_eq_rec);
   rect = Some (Lazy.force coq_eq_rect);
   congr = Lazy.force coq_eq_congr;
-  sym  = Lazy.force coq_eq_sym }
+  sym = Lazy.force coq_eq_sym }
 
 let build_coq_eq () = Lazy.force coq_eq_eq
+let build_coq_sym_eq () = Lazy.force coq_eq_sym
 let build_coq_f_equal2 () = Lazy.force coq_f_equal2
 
 (* Specif *)
@@ -170,56 +208,23 @@ let coq_sumbool  = lazy_init_constant ["Specif"] "sumbool"
 
 let build_coq_sumbool () = Lazy.force coq_sumbool
 
-(* Equality on Type *)
-
-let coq_eqT_eq = lazy_init_constant ["Logic"] "eq"
-let coq_eqT_refl = lazy_init_constant ["Logic"] "refl_equal"
-let coq_eqT_ind = lazy_init_constant ["Logic"] "eq_ind"
-let coq_eqT_congr =lazy_init_constant ["Logic"] "f_equal"
-let coq_eqT_sym  = lazy_init_constant ["Logic"] "sym_eq"
-
-let build_coq_eqT_data () = {
-  eq = Lazy.force coq_eqT_eq;
-  refl = Lazy.force coq_eqT_refl;
-  ind = Lazy.force coq_eqT_ind;
-  rrec = None;
-  rect = None;
-  congr = Lazy.force coq_eqT_congr;
-  sym  = Lazy.force coq_eqT_sym }
-
-let build_coq_eqT () = Lazy.force coq_eqT_eq
-let build_coq_sym_eqT () = Lazy.force coq_eqT_sym
-
 (* Equality on Type as a Type *)
-let coq_idT_eq = lazy_init_constant ["Datatypes"] "identity"
-let coq_idT_refl = lazy_init_constant ["Datatypes"] "refl_identity"
-let coq_idT_ind = lazy_init_constant ["Datatypes"] "identity_ind"
-let coq_idT_rec = lazy_init_constant ["Datatypes"] "identity_rec"
-let coq_idT_rect = lazy_init_constant ["Datatypes"] "identity_rect"
-let coq_idT_congr = lazy_init_constant ["Logic_Type"] "congr_id"
-let coq_idT_sym = lazy_init_constant ["Logic_Type"] "sym_id"
-
-let build_coq_idT_data () = {
-  eq = Lazy.force coq_idT_eq;
-  refl = Lazy.force coq_idT_refl;
-  ind = Lazy.force coq_idT_ind;
-  rrec = Some (Lazy.force coq_idT_rec);
-  rect = Some (Lazy.force coq_idT_rect);
-  congr = Lazy.force coq_idT_congr;
-  sym  = Lazy.force coq_idT_sym }
-
-let lazy_init_constant_v7 d id id7 =
-  if !Options.v7 then lazy_init_constant d id else 
-  lazy (anomaly
-   (id7^" does no longer exist in V8 new syntax, use "^id
-    ^" instead (probably an error in ML contributed code)"))
-
-(* Empty Type *)
-let coq_EmptyT = lazy_init_constant_v7 ["Logic"] "False" "EmptyT"
-
-(* Unit Type and its unique inhabitant *)
-let coq_UnitT  = lazy_init_constant_v7 ["Datatypes"] "unit" "UnitT"
-let coq_IT     = lazy_init_constant_v7 ["Datatypes"] "tt" "IT"
+let coq_identity_eq = lazy_init_constant ["Datatypes"] "identity"
+let coq_identity_refl = lazy_init_constant ["Datatypes"] "refl_identity"
+let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind"
+let coq_identity_rec = lazy_init_constant ["Datatypes"] "identity_rec"
+let coq_identity_rect = lazy_init_constant ["Datatypes"] "identity_rect"
+let coq_identity_congr = lazy_init_constant ["Logic_Type"] "congr_id"
+let coq_identity_sym = lazy_init_constant ["Logic_Type"] "sym_id"
+
+let build_coq_identity_data () = {
+  eq = Lazy.force coq_identity_eq;
+  refl = Lazy.force coq_identity_refl;
+  ind = Lazy.force coq_identity_ind;
+  rrec = Some (Lazy.force coq_identity_rec);
+  rect = Some (Lazy.force coq_identity_rect);
+  congr = Lazy.force coq_identity_congr;
+  sym = Lazy.force coq_identity_sym }
 
 (* The False proposition *)
 let coq_False  = lazy_init_constant ["Logic"] "False"
@@ -235,10 +240,6 @@ let coq_or = lazy_init_constant ["Logic"] "or"
 let coq_ex = lazy_init_constant ["Logic"] "ex"
 
 (* Runtime part *)
-let build_coq_EmptyT () = Lazy.force coq_EmptyT
-let build_coq_UnitT () = Lazy.force coq_UnitT
-let build_coq_IT ()    = Lazy.force coq_IT
-
 let build_coq_True ()  = Lazy.force coq_True
 let build_coq_I ()     = Lazy.force coq_I
 
@@ -248,47 +249,14 @@ let build_coq_and ()   = Lazy.force coq_and
 let build_coq_or ()   = Lazy.force coq_or
 let build_coq_ex ()   = Lazy.force coq_ex
 
-(****************************************************************************)
-(*                             Patterns                                     *)
-(* This needs to have interp_constrpattern available ... 
-
-let parse_constr s =
-  try 
-    Pcoq.parse_string Pcoq.Constr.constr_eoi s 
-  with Stdpp.Exc_located (_ , (Stream.Failure | Stream.Error _)) ->
-    error "Syntax error : not a construction"
-
-let parse_pattern s =
-  Constrintern.interp_constrpattern Evd.empty (Global.env()) (parse_constr s)
-let coq_eq_pattern =
-  lazy (snd (parse_pattern "(Coq.Init.Logic.eq ?1 ?2 ?3)"))
-let coq_eqT_pattern =
-  lazy (snd (parse_pattern "(Coq.Init.Logic.eq ?1 ?2 ?3)"))
-let coq_idT_pattern =
-  lazy (snd (parse_pattern "(Coq.Init.Logic_Type.identityT ?1 ?2 ?3)"))
-let coq_existS_pattern =
-  lazy (snd (parse_pattern "(Coq.Init.Specif.existS ?1 ?2 ?3 ?4)"))
-let coq_existT_pattern = 
-  lazy (snd (parse_pattern "(Coq.Init.Specif.existT ?1 ?2 ?3 ?4)"))
-let coq_not_pattern =
-  lazy (snd (parse_pattern "(Coq.Init.Logic.not ?)"))
-let coq_imp_False_pattern =
-  lazy (snd (parse_pattern "? -> Coq.Init.Logic.False"))
-let coq_imp_False_pattern =
-  lazy (snd (parse_pattern "? -> Coq.Init.Logic.False"))
-let coq_eqdec_partial_pattern =
-  lazy (snd (parse_pattern "(sumbool (eq ?1 ?2 ?3) ?4)"))
-let coq_eqdec_pattern =
-  lazy (snd (parse_pattern "(x,y:?1){<?1>x=y}+{~(<?1>x=y)}"))
-*)
-
 (* The following is less readable but does not depend on parsing *)
 let coq_eq_ref      = lazy (init_reference ["Logic"] "eq")
-let coq_eqT_ref     = coq_eq_ref
-let coq_idT_ref     = lazy (init_reference ["Datatypes"] "identity")
-let coq_existS_ref  = lazy (init_reference ["Specif"] "existS")
+let coq_identity_ref     = lazy (init_reference ["Datatypes"] "identity")
+let coq_existS_ref  = lazy (anomaly "use coq_existT_ref")
 let coq_existT_ref  = lazy (init_reference ["Specif"] "existT")
 let coq_not_ref     = lazy (init_reference ["Logic"] "not")
 let coq_False_ref   = lazy (init_reference ["Logic"] "False")
 let coq_sumbool_ref = lazy (init_reference ["Specif"] "sumbool")
 let coq_sig_ref = lazy (init_reference ["Specif"] "sig")
+let coq_or_ref     = lazy (init_reference ["Logic"] "or")
+
diff --git a/interp/coqlib.mli b/interp/coqlib.mli
index 3b377f29..c81d72de 100644
--- a/interp/coqlib.mli
+++ b/interp/coqlib.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqlib.mli,v 1.5.2.3 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: coqlib.mli 8688 2006-04-07 15:08:12Z msozeau $ i*)
 
 (*i*)
 open Names
@@ -19,11 +19,29 @@ open Pattern
 (*s This module collects the global references, constructions and
     patterns of the standard library used in ocaml files *)
 
-(*s Some utilities, the first argument is used for error messages.
-    Must be used lazyly. s*)
+(*s [find_reference caller_message [dir;subdir;...] s] returns a global
+   reference to the name dir.subdir.(...).s; the corresponding module
+   must have been required or in the process of being compiled so that
+   it must be used lazyly; it raises an anomaly with the given message
+   if not found *)
 
-val gen_reference : string->string list -> string -> global_reference
-val gen_constant : string->string list -> string -> constr
+type message = string
+
+val find_reference : message -> string list -> string -> global_reference
+
+(* [coq_reference caller_message [dir;subdir;...] s] returns a
+   global reference to the name Coq.dir.subdir.(...).s *)
+
+val coq_reference : message -> string list -> string -> global_reference
+
+(* idem but return a term *)
+
+val coq_constant : message -> string list -> string -> constr
+
+(* Synonyms of [coq_constant] and [coq_reference] *)
+
+val gen_constant : message -> string list -> string -> constr
+val gen_reference :  message -> string list -> string -> global_reference
 
 (* Search in several modules (not prefixed by "Coq") *)
 val gen_constant_in_modules : string->string list list-> string -> constr
@@ -31,6 +49,9 @@ val arith_modules : string list list
 val zarith_base_modules : string list list
 val init_modules : string list list
 
+(* For tactics/commands requiring vernacular libraries *)
+val check_required_library : string list -> unit
+
 (*s Global references *)
 
 (* Modules *)
@@ -38,15 +59,22 @@ val logic_module : dir_path
 val logic_type_module : dir_path
 
 (* Natural numbers *)
+val nat_path : section_path
 val glob_nat : global_reference
 val path_of_O : constructor
 val path_of_S : constructor
 val glob_O : global_reference
 val glob_S : global_reference
 
+(* Booleans *)
+val glob_bool : global_reference
+val path_of_true : constructor
+val path_of_false : constructor
+val glob_true : global_reference
+val glob_false : global_reference
+
 (* Equality *)
 val glob_eq : global_reference
-val glob_eqT : global_reference
 
 (*s Constructions and patterns related to Coq initial state are unknown
    at compile time. Therefore, we can only provide methods to build
@@ -66,6 +94,8 @@ type coq_sigma_data = {
 
 val build_sigma_set : coq_sigma_data delayed
 val build_sigma_type : coq_sigma_data delayed
+(* Non-dependent pairs in Set from Datatypes *)
+val build_prod : coq_sigma_data delayed
 
 type coq_leibniz_eq_data = {
   eq   : constr;
@@ -77,20 +107,11 @@ type coq_leibniz_eq_data = {
   sym  : constr }
 
 val build_coq_eq_data : coq_leibniz_eq_data delayed
-val build_coq_eqT_data : coq_leibniz_eq_data delayed
-val build_coq_idT_data : coq_leibniz_eq_data delayed
+val build_coq_identity_data : coq_leibniz_eq_data delayed
 
-val build_coq_eq : constr delayed (* = [(build_coq_eq_data()).eq] *)
+val build_coq_eq       : constr delayed (* = [(build_coq_eq_data()).eq] *)
+val build_coq_sym_eq   : constr delayed (* = [(build_coq_eq_data()).sym] *)
 val build_coq_f_equal2 : constr delayed
-val build_coq_eqT : constr delayed
-val build_coq_sym_eqT : constr delayed
-
-(* Empty Type *)
-val build_coq_EmptyT : constr delayed
-
-(* Unit Type and its unique inhabitant *)
-val build_coq_UnitT : constr delayed
-val build_coq_IT : constr delayed
 
 (* Specif *)
 val build_coq_sumbool : constr delayed
@@ -116,11 +137,12 @@ val build_coq_or : constr delayed
 val build_coq_ex : constr delayed
 
 val coq_eq_ref : global_reference lazy_t
-val coq_eqT_ref : global_reference lazy_t
-val coq_idT_ref : global_reference lazy_t
+val coq_identity_ref : global_reference lazy_t
 val coq_existS_ref : global_reference lazy_t
 val coq_existT_ref : global_reference lazy_t
 val coq_not_ref : global_reference lazy_t
 val coq_False_ref : global_reference lazy_t
 val coq_sumbool_ref : global_reference lazy_t
 val coq_sig_ref : global_reference lazy_t
+
+val coq_or_ref : global_reference lazy_t
diff --git a/interp/genarg.ml b/interp/genarg.ml
index 7facebcc..77ed1fe6 100644
--- a/interp/genarg.ml
+++ b/interp/genarg.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: genarg.ml,v 1.9.2.2 2005/01/15 14:56:54 herbelin Exp $ *)
+(* $Id: genarg.ml 8926 2006-06-08 20:23:17Z herbelin $ *)
 
 open Pp
 open Util
@@ -26,16 +26,14 @@ type argument_type =
   | PreIdentArgType
   | IntroPatternArgType
   | IdentArgType
-  | HypArgType
+  | VarArgType
   | RefArgType
   (* Specific types *)
   | SortArgType
   | ConstrArgType
   | ConstrMayEvalArgType
   | QuantHypArgType
-  | TacticArgType
-  | OpenConstrArgType
-  | CastedOpenConstrArgType
+  | OpenConstrArgType of bool
   | ConstrWithBindingsArgType
   | BindingsArgType
   | RedExprArgType
@@ -45,7 +43,6 @@ type argument_type =
   | PairArgType of argument_type * argument_type
   | ExtraArgType of string
 
-type 'a or_var = ArgArg of 'a | ArgVar of identifier located
 type 'a and_short_name = 'a * identifier located option
 type rawconstr_and_expr = rawconstr * constr_expr option
 
@@ -55,6 +52,10 @@ type ('a,'b) generic_argument = argument_type * Obj.t
 
 let dyntab = ref ([] : string list)
 
+type rlevel = constr_expr
+type glevel = rawconstr_and_expr
+type tlevel = constr
+
 type ('a,'b,'c) abstract_argument_type = argument_type
 
 let create_arg s =
@@ -70,15 +71,17 @@ type intro_pattern_expr =
   | IntroOrAndPattern of case_intro_pattern_expr
   | IntroWildcard
   | IntroIdentifier of identifier
+  | IntroAnonymous
 and case_intro_pattern_expr = intro_pattern_expr list list
 
 let rec pr_intro_pattern = function
   | IntroOrAndPattern pll -> pr_case_intro_pattern pll
   | IntroWildcard -> str "_"
   | IntroIdentifier id -> pr_id id
+  | IntroAnonymous -> str "?"
 
 and pr_case_intro_pattern = function
-  | [_::_ as pl] ->
+  | [pl] ->
       str "(" ++ hv 0 (prlist_with_sep pr_coma pr_intro_pattern pl) ++ str ")"
   | pll ->
       str "[" ++
@@ -117,9 +120,9 @@ let rawwit_ident = IdentArgType
 let globwit_ident = IdentArgType
 let wit_ident = IdentArgType
 
-let rawwit_var = HypArgType
-let globwit_var = HypArgType
-let wit_var = HypArgType
+let rawwit_var = VarArgType
+let globwit_var = VarArgType
+let wit_var = VarArgType
 
 let rawwit_ref = RefArgType
 let globwit_ref = RefArgType
@@ -141,17 +144,17 @@ let rawwit_constr_may_eval = ConstrMayEvalArgType
 let globwit_constr_may_eval = ConstrMayEvalArgType
 let wit_constr_may_eval = ConstrMayEvalArgType
 
-let rawwit_tactic = TacticArgType
-let globwit_tactic = TacticArgType
-let wit_tactic = TacticArgType
+let rawwit_open_constr_gen b = OpenConstrArgType b
+let globwit_open_constr_gen b = OpenConstrArgType b 
+let wit_open_constr_gen b = OpenConstrArgType b
 
-let rawwit_open_constr = OpenConstrArgType
-let globwit_open_constr = OpenConstrArgType
-let wit_open_constr = OpenConstrArgType
+let rawwit_open_constr = rawwit_open_constr_gen false
+let globwit_open_constr = globwit_open_constr_gen false
+let wit_open_constr = wit_open_constr_gen false
 
-let rawwit_casted_open_constr = CastedOpenConstrArgType
-let globwit_casted_open_constr = CastedOpenConstrArgType
-let wit_casted_open_constr = CastedOpenConstrArgType
+let rawwit_casted_open_constr = rawwit_open_constr_gen true
+let globwit_casted_open_constr = globwit_open_constr_gen true
+let wit_casted_open_constr = wit_open_constr_gen true
 
 let rawwit_constr_with_bindings = ConstrWithBindingsArgType
 let globwit_constr_with_bindings = ConstrWithBindingsArgType
@@ -178,24 +181,24 @@ let out_gen t (t',o) = if t = t' then Obj.magic o else failwith "out_gen"
 let genarg_tag (s,_) = s
 
 let fold_list0 f = function
-  | (List0ArgType t as u, l) ->
+  | (List0ArgType t, l) ->
       List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l)
   | _ -> failwith "Genarg: not a list0"
 
 let fold_list1 f = function
-  | (List1ArgType t as u, l) ->
+  | (List1ArgType t, l) ->
       List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l)
   | _ -> failwith "Genarg: not a list1"
 
 let fold_opt f a = function
-  | (OptArgType t as u, l) ->
+  | (OptArgType t, l) ->
       (match Obj.magic l with
 	| None -> a
 	| Some x -> f (in_gen t x))
   | _ -> failwith "Genarg: not a opt"
 
 let fold_pair f = function
-  | (PairArgType (t1,t2) as u, l) ->
+  | (PairArgType (t1,t2), l) ->
       let (x1,x2) = Obj.magic l in
       f (in_gen t1 x1) (in_gen t2 x2)
   | _ -> failwith "Genarg: not a pair"
@@ -215,7 +218,7 @@ let app_list1 f = function
 let app_opt f = function
   | (OptArgType t as u, l) ->
       let o = Obj.magic l in
-      (u, Obj.repr (option_app (fun x -> out_gen t (f (in_gen t x))) o))
+      (u, Obj.repr (option_map (fun x -> out_gen t (f (in_gen t x))) o))
   | _ -> failwith "Genarg: not an opt"
 
 let app_pair f1 f2 = function
diff --git a/interp/genarg.mli b/interp/genarg.mli
index 967d5050..c4275589 100644
--- a/interp/genarg.mli
+++ b/interp/genarg.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: genarg.mli,v 1.9.2.4 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: genarg.mli 8983 2006-06-23 13:21:49Z herbelin $ i*)
 
 open Util
 open Names
@@ -16,7 +16,6 @@ open Rawterm
 open Topconstr
 open Term
 
-type 'a or_var = ArgArg of 'a | ArgVar of identifier located
 type 'a and_short_name = 'a * identifier located option
 
 (* In globalize tactics, we need to keep the initial [constr_expr] to recompute*)
@@ -32,6 +31,7 @@ type intro_pattern_expr =
   | IntroOrAndPattern of case_intro_pattern_expr
   | IntroWildcard
   | IntroIdentifier of identifier
+  | IntroAnonymous
 and case_intro_pattern_expr = intro_pattern_expr list list
 
 val pr_intro_pattern : intro_pattern_expr -> Pp.std_ppcmds
@@ -60,21 +60,21 @@ Transformation for each type :
 \begin{verbatim}
 tag                            raw open type            cooked closed type
 
-BoolArgType                    bool                     bool
-IntArgType                     int                      int
-IntOrVarArgType                int or_var               int
-StringArgType                  string (parsed w/ "")    string
-PreIdentArgType                string (parsed w/o "")   (vernac only)
-IdentArgType                   identifier               identifier
-IntroPatternArgType            intro_pattern_expr       intro_pattern_expr
-VarArgType                     identifier               constr
-RefArgType                     reference                global_reference
-ConstrArgType                  constr_expr              constr
-ConstrMayEvalArgType           constr_expr may_eval     constr
-QuantHypArgType                quantified_hypothesis    quantified_hypothesis
-TacticArgType                  raw_tactic_expr          tactic
-OpenConstrArgType              constr_expr              open_constr
-ConstrBindingsArgType      constr_expr with_bindings constr with_bindings
+BoolArgType                    bool                      bool
+IntArgType                     int                       int
+IntOrVarArgType                int or_var                int
+StringArgType                  string (parsed w/ "")     string
+PreIdentArgType                string (parsed w/o "")    (vernac only)
+IdentArgType                   identifier                identifier
+IntroPatternArgType            intro_pattern_expr        intro_pattern_expr
+VarArgType                     identifier located        identifier
+RefArgType                     reference                 global_reference
+QuantHypArgType                quantified_hypothesis     quantified_hypothesis
+ConstrArgType                  constr_expr               constr
+ConstrMayEvalArgType           constr_expr may_eval      constr
+OpenConstrArgType              open_constr_expr          open_constr
+ConstrWithBindingsArgType      constr_expr with_bindings constr with_bindings
+BindingsArgType                constr_expr bindings      constr bindings
 List0ArgType of argument_type
 List1ArgType of argument_type
 OptArgType of argument_type
@@ -82,84 +82,94 @@ ExtraArgType of string         '_a                      '_b
 \end{verbatim}
 *)
 
+(* All of [rlevel], [glevel] and [tlevel] must be non convertible 
+   to ensure the injectivity of the type inference from type
+   [('co,'ta) generic_argument] to [('a,'co,'ta) abstract_argument_type]
+   is injective; this guarantees that, for 'b fixed, the type of
+   out_gen is monomorphic over 'a, hence type-safe 
+*)
+
+type rlevel = constr_expr
+type glevel = rawconstr_and_expr
+type tlevel = constr
+
 type ('a,'co,'ta) abstract_argument_type
 
-val rawwit_bool : (bool,'co,'ta) abstract_argument_type
-val globwit_bool : (bool,'co,'ta) abstract_argument_type
-val wit_bool : (bool,'co,'ta) abstract_argument_type
+val rawwit_bool : (bool,rlevel,'ta) abstract_argument_type
+val globwit_bool : (bool,glevel,'ta) abstract_argument_type
+val wit_bool : (bool,tlevel,'ta) abstract_argument_type
 
-val rawwit_int : (int,'co,'ta) abstract_argument_type
-val globwit_int : (int,'co,'ta) abstract_argument_type
-val wit_int : (int,'co,'ta) abstract_argument_type
+val rawwit_int : (int,rlevel,'ta) abstract_argument_type
+val globwit_int : (int,glevel,'ta) abstract_argument_type
+val wit_int : (int,tlevel,'ta) abstract_argument_type
 
-val rawwit_int_or_var : (int or_var,'co,'ta) abstract_argument_type
-val globwit_int_or_var : (int or_var,'co,'ta) abstract_argument_type
-val wit_int_or_var : (int or_var,'co,'ta) abstract_argument_type
+val rawwit_int_or_var : (int or_var,rlevel,'ta) abstract_argument_type
+val globwit_int_or_var : (int or_var,glevel,'ta) abstract_argument_type
+val wit_int_or_var : (int or_var,tlevel,'ta) abstract_argument_type
 
-val rawwit_string : (string,'co,'ta) abstract_argument_type
-val globwit_string : (string,'co,'ta) abstract_argument_type
-val wit_string : (string,'co,'ta) abstract_argument_type
+val rawwit_string : (string,rlevel,'ta) abstract_argument_type
+val globwit_string : (string,glevel,'ta) abstract_argument_type
+val wit_string : (string,tlevel,'ta) abstract_argument_type
 
-val rawwit_pre_ident : (string,'co,'ta) abstract_argument_type
-val globwit_pre_ident : (string,'co,'ta) abstract_argument_type
-val wit_pre_ident : (string,'co,'ta) abstract_argument_type
+val rawwit_pre_ident : (string,rlevel,'ta) abstract_argument_type
+val globwit_pre_ident : (string,glevel,'ta) abstract_argument_type
+val wit_pre_ident : (string,tlevel,'ta) abstract_argument_type
 
-val rawwit_intro_pattern : (intro_pattern_expr,'co,'ta) abstract_argument_type
-val globwit_intro_pattern : (intro_pattern_expr,'co,'ta) abstract_argument_type
-val wit_intro_pattern : (intro_pattern_expr,'co,'ta) abstract_argument_type
+val rawwit_intro_pattern : (intro_pattern_expr,rlevel,'ta) abstract_argument_type
+val globwit_intro_pattern : (intro_pattern_expr,glevel,'ta) abstract_argument_type
+val wit_intro_pattern : (intro_pattern_expr,tlevel,'ta) abstract_argument_type
 
-val rawwit_ident : (identifier,'co,'ta) abstract_argument_type
-val globwit_ident : (identifier,'co,'ta) abstract_argument_type
-val wit_ident : (identifier,'co,'ta) abstract_argument_type
+val rawwit_ident : (identifier,rlevel,'ta) abstract_argument_type
+val globwit_ident : (identifier,glevel,'ta) abstract_argument_type
+val wit_ident : (identifier,tlevel,'ta) abstract_argument_type
 
-val rawwit_var : (identifier located,'co,'ta) abstract_argument_type
-val globwit_var : (identifier located,'co,'ta) abstract_argument_type
-val wit_var : ('co,'co,'ta) abstract_argument_type
+val rawwit_var : (identifier located,rlevel,'ta) abstract_argument_type
+val globwit_var : (identifier located,glevel,'ta) abstract_argument_type
+val wit_var : (identifier,tlevel,'ta) abstract_argument_type
 
-val rawwit_ref : (reference,constr_expr,'ta) abstract_argument_type
-val globwit_ref : (global_reference located or_var,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_ref : (global_reference,constr,'ta) abstract_argument_type
+val rawwit_ref : (reference,rlevel,'ta) abstract_argument_type
+val globwit_ref : (global_reference located or_var,glevel,'ta) abstract_argument_type
+val wit_ref : (global_reference,tlevel,'ta) abstract_argument_type
 
-val rawwit_quant_hyp : (quantified_hypothesis,'co,'ta) abstract_argument_type
-val globwit_quant_hyp : (quantified_hypothesis,'co,'ta) abstract_argument_type
-val wit_quant_hyp : (quantified_hypothesis,'co,'ta) abstract_argument_type
+val rawwit_quant_hyp : (quantified_hypothesis,rlevel,'ta) abstract_argument_type
+val globwit_quant_hyp : (quantified_hypothesis,glevel,'ta) abstract_argument_type
+val wit_quant_hyp : (quantified_hypothesis,tlevel,'ta) abstract_argument_type
 
-val rawwit_sort : (rawsort,constr_expr,'ta) abstract_argument_type
-val globwit_sort : (rawsort,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_sort : (sorts,constr,'ta) abstract_argument_type
+val rawwit_sort : (rawsort,rlevel,'ta) abstract_argument_type
+val globwit_sort : (rawsort,glevel,'ta) abstract_argument_type
+val wit_sort : (sorts,tlevel,'ta) abstract_argument_type
 
-val rawwit_constr : (constr_expr,constr_expr,'ta) abstract_argument_type
-val globwit_constr : (rawconstr_and_expr,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_constr : (constr,constr,'ta) abstract_argument_type
+val rawwit_constr : (constr_expr,rlevel,'ta) abstract_argument_type
+val globwit_constr : (rawconstr_and_expr,glevel,'ta) abstract_argument_type
+val wit_constr : (constr,tlevel,'ta) abstract_argument_type
 
-val rawwit_constr_may_eval : ((constr_expr,reference) may_eval,constr_expr,'ta) abstract_argument_type
-val globwit_constr_may_eval : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var) may_eval,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_constr_may_eval : (constr,constr,'ta) abstract_argument_type
+val rawwit_constr_may_eval : ((constr_expr,reference) may_eval,rlevel,'ta) abstract_argument_type
+val globwit_constr_may_eval : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var) may_eval,glevel,'ta) abstract_argument_type
+val wit_constr_may_eval : (constr,tlevel,'ta) abstract_argument_type
 
-val rawwit_open_constr : (open_constr_expr,constr_expr,'ta) abstract_argument_type
-val globwit_open_constr : (open_rawconstr,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_open_constr : (open_constr,constr,'ta) abstract_argument_type
+val rawwit_open_constr_gen : bool -> (open_constr_expr,rlevel,'ta) abstract_argument_type
+val globwit_open_constr_gen : bool -> (open_rawconstr,glevel,'ta) abstract_argument_type
+val wit_open_constr_gen : bool -> (open_constr,tlevel,'ta) abstract_argument_type
 
-val rawwit_casted_open_constr : (open_constr_expr,constr_expr,'ta) abstract_argument_type
-val globwit_casted_open_constr : (open_rawconstr,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_casted_open_constr : (open_constr,constr,'ta) abstract_argument_type
+val rawwit_open_constr : (open_constr_expr,rlevel,'ta) abstract_argument_type
+val globwit_open_constr : (open_rawconstr,glevel,'ta) abstract_argument_type
+val wit_open_constr : (open_constr,tlevel,'ta) abstract_argument_type
 
-val rawwit_constr_with_bindings : (constr_expr with_bindings,constr_expr,'ta) abstract_argument_type
-val globwit_constr_with_bindings : (rawconstr_and_expr with_bindings,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_constr_with_bindings : (constr with_bindings,constr,'ta) abstract_argument_type
+val rawwit_casted_open_constr : (open_constr_expr,rlevel,'ta) abstract_argument_type
+val globwit_casted_open_constr : (open_rawconstr,glevel,'ta) abstract_argument_type
+val wit_casted_open_constr : (open_constr,tlevel,'ta) abstract_argument_type
 
-val rawwit_bindings : (constr_expr bindings,constr_expr,'ta) abstract_argument_type
-val globwit_bindings : (rawconstr_and_expr bindings,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_bindings : (constr bindings,constr,'ta) abstract_argument_type
+val rawwit_constr_with_bindings : (constr_expr with_bindings,rlevel,'ta) abstract_argument_type
+val globwit_constr_with_bindings : (rawconstr_and_expr with_bindings,glevel,'ta) abstract_argument_type
+val wit_constr_with_bindings : (constr with_bindings,tlevel,'ta) abstract_argument_type
 
-val rawwit_red_expr : ((constr_expr,reference) red_expr_gen,constr_expr,'ta) abstract_argument_type
-val globwit_red_expr : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var) red_expr_gen,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_red_expr : ((constr,evaluable_global_reference) red_expr_gen,constr,'ta) abstract_argument_type
+val rawwit_bindings : (constr_expr bindings,rlevel,'ta) abstract_argument_type
+val globwit_bindings : (rawconstr_and_expr bindings,glevel,'ta) abstract_argument_type
+val wit_bindings : (constr bindings,tlevel,'ta) abstract_argument_type
 
-(* TODO: transformer tactic en extra arg *)
-val rawwit_tactic : ('ta,constr_expr,'ta) abstract_argument_type
-val globwit_tactic : ('ta,rawconstr_and_expr,'ta) abstract_argument_type
-val wit_tactic : ('ta,constr,'ta) abstract_argument_type
+val rawwit_red_expr : ((constr_expr,reference) red_expr_gen,rlevel,'ta) abstract_argument_type
+val globwit_red_expr : ((rawconstr_and_expr,evaluable_global_reference and_short_name or_var) red_expr_gen,glevel,'ta) abstract_argument_type
+val wit_red_expr : ((constr,evaluable_global_reference) red_expr_gen,tlevel,'ta) abstract_argument_type
 
 val wit_list0 :
   ('a,'co,'ta) abstract_argument_type -> ('a list,'co,'ta) abstract_argument_type
@@ -212,9 +222,9 @@ val app_pair :
    polymorphism, on aimerait que 'b et 'c restent polymorphes à l'appel
    de create *)
 val create_arg : string ->
-      ('a,'co,'ta) abstract_argument_type
-      * ('globa,'globco,'globta) abstract_argument_type
-      * ('rawa,'rawco,'rawta) abstract_argument_type
+      ('a,tlevel,'ta) abstract_argument_type
+      * ('globa,glevel,'globta) abstract_argument_type
+      * ('rawa,rlevel,'rawta) abstract_argument_type
 
 val exists_argtype : string -> bool
 
@@ -227,16 +237,14 @@ type argument_type =
   | PreIdentArgType
   | IntroPatternArgType
   | IdentArgType
-  | HypArgType
+  | VarArgType
   | RefArgType
   (* Specific types *)
   | SortArgType
   | ConstrArgType
   | ConstrMayEvalArgType
   | QuantHypArgType
-  | TacticArgType
-  | OpenConstrArgType
-  | CastedOpenConstrArgType
+  | OpenConstrArgType of bool
   | ConstrWithBindingsArgType
   | BindingsArgType
   | RedExprArgType
@@ -268,4 +276,3 @@ val in_gen :
   ('a,'co,'ta) abstract_argument_type -> 'a -> ('co,'ta) generic_argument
 val out_gen :
   ('a,'co,'ta) abstract_argument_type -> ('co,'ta) generic_argument -> 'a 
-
diff --git a/interp/modintern.ml b/interp/modintern.ml
index 0929119c..71bd431d 100644
--- a/interp/modintern.ml
+++ b/interp/modintern.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: modintern.ml,v 1.2.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+(* $Id: modintern.ml 6582 2005-01-13 14:28:56Z sacerdot $ *)
 
 open Pp
 open Util
@@ -79,10 +79,10 @@ let lookup_modtype (loc,qid) =
 	Modops.error_not_a_modtype_loc loc (string_of_qualid qid)
 
 let transl_with_decl env = function 
-  | CWith_Module ((_,id),qid) ->
-      With_Module (id,lookup_module qid)
-  | CWith_Definition ((_,id),c) ->
-      With_Definition (id,interp_constr Evd.empty env c)
+  | CWith_Module ((_,fqid),qid) ->
+      With_Module (fqid,lookup_module qid)
+  | CWith_Definition ((_,fqid),c) ->
+      With_Definition (fqid,interp_constr Evd.empty env c)
 
 let rec interp_modtype env = function 
   | CMTEident qid ->
diff --git a/interp/modintern.mli b/interp/modintern.mli
index 050d9f94..844450ac 100644
--- a/interp/modintern.mli
+++ b/interp/modintern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modintern.mli,v 1.1.6.1 2004/07/16 19:30:22 herbelin Exp $ i*)
+(*i $Id: modintern.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Declarations
diff --git a/interp/symbols.ml b/interp/notation.ml
index d1abb084..7d70b296 100644
--- a/interp/symbols.ml
+++ b/interp/notation.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: symbols.ml,v 1.31.2.2 2004/11/17 09:33:38 herbelin Exp $ *)
+(* $Id: notation.ml 9481 2007-01-11 19:17:56Z herbelin $ *)
 
 (*i*)
 open Util
 open Pp
-open Bignat
+open Bigint
 open Names
+open Term
 open Nametab
 open Libnames
 open Summary
@@ -30,7 +31,7 @@ open Ppextend
     terms and patterns can be set; these interpreters are in permanent table
     [numeral_interpreter_tab]
   - a set of ML printers for expressions denoting numbers parsable in 
-    this scope (permanently declared in [Esyntax.primitive_printer_tab])
+    this scope
   - a set of interpretations for infix (more generally distfix) notations
   - an optional pair of delimiters which, when occurring in a syntactic
     expression, set this scope to be the current scope
@@ -41,20 +42,21 @@ open Ppextend
 
 type level = precedence * tolerability list
 type delimiters = string
+type notation_location = dir_path * string
 
 type scope = {
-  notations: (interpretation * (dir_path * string) * bool) Stringmap.t;
+  notations: (string, interpretation * notation_location) Gmap.t;
   delimiters: delimiters option
 }
 
 (* Uninterpreted notation map: notation -> level * dir_path *)
-let notation_level_map = ref Stringmap.empty
+let notation_level_map = ref Gmap.empty
 
 (* Scopes table: scope_name -> symbol_interpretation *)
-let scope_map = ref Stringmap.empty
+let scope_map = ref Gmap.empty
 
 let empty_scope = {
-  notations = Stringmap.empty;
+  notations = Gmap.empty;
   delimiters = None
 }
 
@@ -62,20 +64,20 @@ let default_scope = "" (* empty name, not available from outside *)
 let type_scope = "type_scope" (* special scope used for interpreting types *)
 
 let init_scope_map () =
-  scope_map := Stringmap.add default_scope empty_scope !scope_map;
-  scope_map := Stringmap.add type_scope empty_scope !scope_map
+  scope_map := Gmap.add default_scope empty_scope !scope_map;
+  scope_map := Gmap.add type_scope empty_scope !scope_map
 
 (**********************************************************************)
 (* Operations on scopes *)
 
 let declare_scope scope =
-  try let _ = Stringmap.find scope !scope_map in ()
+  try let _ = Gmap.find scope !scope_map in ()
   with Not_found ->
 (*    Options.if_verbose message ("Creating scope "^scope);*)
-    scope_map := Stringmap.add scope empty_scope !scope_map
+    scope_map := Gmap.add scope empty_scope !scope_map
 
 let find_scope scope =
-  try Stringmap.find scope !scope_map
+  try Gmap.find scope !scope_map
   with Not_found -> error ("Scope "^scope^" is not declared")
 
 let check_scope sc = let _ = find_scope sc in ()
@@ -93,9 +95,14 @@ let current_scopes () = !scope_stack
 (* TODO: push nat_scope, z_scope, ... in scopes summary *)
 
 (* Exportation of scopes *)
-let cache_scope (_,(local,op,sc)) =
+let open_scope i (_,(local,op,sc)) =
+  if i=1 then begin
   (match sc with Scope sc -> check_scope sc | _ -> ());
   scope_stack := if op then sc :: !scope_stack else list_except sc !scope_stack
+  end
+
+let cache_scope o =
+  open_scope 1 o
 
 let subst_scope (_,subst,sc) = sc
 
@@ -109,7 +116,7 @@ let export_scope (local,_,_ as x) = if local then None else Some x
 let (inScope,outScope) = 
   declare_object {(default_object "SCOPE") with
       cache_function = cache_scope;
-      open_function = (fun i o -> if i=1 then cache_scope o);
+      open_function = open_scope;
       subst_function = subst_scope;
       classify_function = classify_scope;
       export_function = export_scope }
@@ -121,10 +128,17 @@ let empty_scope_stack = []
 
 let push_scope sc scopes = Scope sc :: scopes
 
+let push_scopes = List.fold_right push_scope
+
+type local_scopes = tmp_scope_name option * scope_name list
+
+let make_current_scopes (tmp_scope,scopes) =
+  option_fold_right push_scope tmp_scope (push_scopes scopes !scope_stack)
+
 (**********************************************************************)
 (* Delimiters *)
 
-let delimiters_map = ref Stringmap.empty
+let delimiters_map = ref Gmap.empty
 
 let declare_delimiters scope key =
   let sc = find_scope scope in
@@ -134,15 +148,15 @@ let declare_delimiters scope key =
       warning ("Overwritting previous delimiting key "^old^" in scope "^scope)
   end;
   let sc = { sc with delimiters = Some key } in
-  scope_map := Stringmap.add scope sc !scope_map;
-  if Stringmap.mem key !delimiters_map then begin
-    let oldsc = Stringmap.find key !delimiters_map in
-    Options.if_verbose warning ("Hidding binding of key "^key^" to "^oldsc)
+  scope_map := Gmap.add scope sc !scope_map;
+  if Gmap.mem key !delimiters_map then begin
+    let oldsc = Gmap.find key !delimiters_map in
+    Options.if_verbose warning ("Hiding binding of key "^key^" to "^oldsc)
   end;
-  delimiters_map := Stringmap.add key scope !delimiters_map
+  delimiters_map := Gmap.add key scope !delimiters_map
 
 let find_delimiters_scope loc key = 
-  try Stringmap.find key !delimiters_map
+  try Gmap.find key !delimiters_map
   with Not_found -> 
     user_err_loc 
     (loc, "find_delimiters", str ("Unknown scope delimiting key "^key))
@@ -162,7 +176,7 @@ type key =
 
 (* Scopes table : interpretation -> scope_name *)
 let notations_key_table = ref Gmapl.empty
-let numeral_key_table = Hashtbl.create 7
+let prim_token_key_table = Hashtbl.create 7
 
 let rawconstr_key = function
   | RApp (_,RRef (_,ref),_) -> RefKey ref
@@ -186,50 +200,66 @@ let pattern_key = function
 (**********************************************************************)
 (* Interpreting numbers (not in summary because functional objects)   *)
 
-type num_interpreter =
-    (loc -> bigint -> rawconstr)
-    * (loc -> bigint -> name -> cases_pattern) option
+type required_module = section_path * string list 
+
+type 'a prim_token_interpreter =
+    loc -> 'a -> rawconstr
 
-type num_uninterpreter =
-    rawconstr list * (rawconstr -> bigint option)
-    * (cases_pattern -> bigint option) option
+type cases_pattern_status = bool (* true = use prim token in patterns *)
 
-type required_module = global_reference * string list 
+type 'a prim_token_uninterpreter =
+    rawconstr list * (rawconstr -> 'a option) * cases_pattern_status
 
-let numeral_interpreter_tab =
-  (Hashtbl.create 7 : (scope_name,required_module*num_interpreter) Hashtbl.t)
+type internal_prim_token_interpreter =
+    loc -> prim_token -> required_module * (unit -> rawconstr)
 
-let declare_numeral_interpreter sc dir interp (patl,uninterp,uninterpc) =
+let prim_token_interpreter_tab =
+  (Hashtbl.create 7 : (scope_name, internal_prim_token_interpreter) Hashtbl.t)
+
+let add_prim_token_interpreter sc interp =
+  try 
+    let cont = Hashtbl.find prim_token_interpreter_tab sc in
+    Hashtbl.replace prim_token_interpreter_tab sc (interp cont)
+  with Not_found ->
+    let cont = (fun _loc _p -> raise Not_found) in
+    Hashtbl.add prim_token_interpreter_tab sc (interp cont)
+
+let declare_prim_token_interpreter sc interp (patl,uninterp,b) =
   declare_scope sc;
-  Hashtbl.add numeral_interpreter_tab sc (dir,interp);
-  List.iter
-    (fun pat -> Hashtbl.add numeral_key_table (rawconstr_key pat)
-      (sc,uninterp,uninterpc))
+  add_prim_token_interpreter sc interp;
+  List.iter (fun pat -> 
+      Hashtbl.add prim_token_key_table (rawconstr_key pat) (sc,uninterp,b))
     patl
 
-let check_required_module loc sc (ref,d) =
-  let d' = List.map id_of_string d in
-  let dir = make_dirpath (List.rev d') in
-  try let _ = sp_of_global ref in ()
+let mkNumeral n = Numeral n
+let mkString s = String s
+
+let delay dir int loc x = (dir, (fun () -> int loc x))
+
+let declare_numeral_interpreter sc dir interp (patl,uninterp,inpat) =
+  declare_prim_token_interpreter sc
+    (fun cont loc -> function Numeral n-> delay dir interp loc n | p -> cont loc p)
+    (patl, (fun r -> option_map mkNumeral (uninterp r)), inpat)
+
+let declare_string_interpreter sc dir interp (patl,uninterp,inpat) =
+  declare_prim_token_interpreter sc
+    (fun cont loc -> function String s -> delay dir interp loc s | p -> cont loc p)
+    (patl, (fun r -> option_map mkString (uninterp r)), inpat)
+
+let check_required_module loc sc (sp,d) =
+  try let _ = Nametab.absolute_reference sp in ()
   with Not_found ->
-    user_err_loc (loc,"numeral_interpreter",
-    str ("Cannot interpret numbers in "^sc^" without requiring first module "
+    user_err_loc (loc,"prim_token_interpreter",
+    str ("Cannot interpret in "^sc^" without requiring first module "
     ^(list_last d)))
 
-let lookup_numeral_interpreter loc = function
-  | Scope sc ->
-      let (dir,interpreter) = Hashtbl.find numeral_interpreter_tab sc in
-      check_required_module loc sc dir;
-      interpreter
-  | SingleNotation _ -> raise Not_found
-
 (* Look if some notation or numeral printer in [scope] can be used in
    the scope stack [scopes], and if yes, using delimiters or not *)
 
 let find_with_delimiters = function
   | None -> None
   | Some scope ->
-      match (Stringmap.find scope !scope_map).delimiters with
+      match (Gmap.find scope !scope_map).delimiters with
 	| Some key -> Some (Some scope, Some key)
 	| None -> None
 
@@ -257,48 +287,81 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function
 (* Uninterpreted notation levels *)
 
 let declare_notation_level ntn level =
-  if not !Options.v7 & Stringmap.mem ntn !notation_level_map then
+  if Gmap.mem ntn !notation_level_map then
     error ("Notation "^ntn^" is already assigned a level");
-  notation_level_map := Stringmap.add ntn level !notation_level_map
+  notation_level_map := Gmap.add ntn level !notation_level_map
 
 let level_of_notation ntn =
-  Stringmap.find ntn !notation_level_map
+  Gmap.find ntn !notation_level_map
 
 (* The mapping between notations and their interpretation *)
 
-let declare_notation_interpretation ntn scopt pat df pp8only =
+let declare_notation_interpretation ntn scopt pat df =
   let scope = match scopt with Some s -> s | None -> default_scope in
   let sc = find_scope scope in
-  if Stringmap.mem ntn sc.notations && Options.is_verbose () then
-    warning ("Notation "^ntn^" was already used"^
-    (if scopt = None then "" else " in scope "^scope));
-  let sc = { sc with notations = Stringmap.add ntn (pat,df,pp8only) sc.notations } in
-  scope_map := Stringmap.add scope sc !scope_map;
+  if Gmap.mem ntn sc.notations && Options.is_verbose () then
+    msg_warning (str ("Notation "^ntn^" was already used"^
+    (if scopt = None then "" else " in scope "^scope)));
+  let sc = { sc with notations = Gmap.add ntn (pat,df) sc.notations } in
+  scope_map := Gmap.add scope sc !scope_map;
   if scopt = None then scope_stack := SingleNotation ntn :: !scope_stack
 
 let declare_uninterpretation rule (metas,c as pat) =
   let (key,n) = aconstr_key c in
   notations_key_table := Gmapl.add key (rule,pat,n) !notations_key_table
 
-let rec find_interpretation f = function
-  | sce :: scopes ->
-      let scope = match sce with
-	| Scope s -> s 
-	| SingleNotation _ -> default_scope in
-      (try f scope
-      with Not_found -> find_interpretation f scopes)
+let rec find_interpretation find = function
   | [] -> raise Not_found
+  | sce :: scopes ->
+      let sc,sco = match sce with
+	| Scope sc -> sc, Some sc
+	| SingleNotation _ -> default_scope, None in
+      try
+	let (pat,df) = find sc in
+	pat,(df,sco)
+      with Not_found ->
+	find_interpretation find scopes
 
-let rec interp_notation loc ntn scopes =
-  let f sc =
-    let scope = find_scope sc in
-    let (pat,df,pp8only) = Stringmap.find ntn scope.notations in
-    if pp8only then raise Not_found;
-    pat,(df,if sc = default_scope then None else Some sc) in
-  try find_interpretation f (List.fold_right push_scope scopes !scope_stack)
-  with Not_found -> 
+let find_notation ntn sc =
+  Gmap.find ntn (find_scope sc).notations
+
+let notation_of_prim_token = function
+  | Numeral n when is_pos_or_zero n -> to_string n
+  | Numeral n -> "- "^(to_string (neg n))
+  | String _ -> raise Not_found
+
+let find_prim_token g loc p sc =
+  (* Try for a user-defined numerical notation *)
+  try
+    let (_,c),df = find_notation (notation_of_prim_token p) sc in
+    g (rawconstr_of_aconstr loc c),df
+  with Not_found ->
+  (* Try for a primitive numerical notation *)
+  let (spdir,interp) = Hashtbl.find prim_token_interpreter_tab sc loc p in
+  check_required_module loc sc spdir;
+  g (interp ()), (dirpath (fst spdir),"")
+
+let interp_prim_token_gen g loc p local_scopes =
+  let scopes = make_current_scopes local_scopes in
+  try find_interpretation (find_prim_token g loc p) scopes
+  with Not_found ->
+    user_err_loc (loc,"interp_prim_token",
+    (match p with
+      | Numeral n -> str "No interpretation for numeral " ++ pr_bigint n
+      | String s -> str "No interpretation for string " ++ qs s))
+
+let interp_prim_token =
+  interp_prim_token_gen (fun x -> x)
+
+let interp_prim_token_cases_pattern loc p name =
+  interp_prim_token_gen (cases_pattern_of_rawconstr name) loc p
+
+let rec interp_notation loc ntn local_scopes =
+  let scopes = make_current_scopes local_scopes in
+  try find_interpretation (find_notation ntn) scopes
+  with Not_found ->
     user_err_loc
-      (loc,"",str ("Unknown interpretation for notation \""^ntn^"\""))
+    (loc,"",str ("Unknown interpretation for notation \""^ntn^"\""))
 
 let uninterp_notations c =
   Gmapl.find (rawconstr_key c) !notations_key_table
@@ -308,83 +371,42 @@ let uninterp_cases_pattern_notations c =
 
 let availability_of_notation (ntn_scope,ntn) scopes =
   let f scope =
-    Stringmap.mem ntn (Stringmap.find scope !scope_map).notations in
-  find_without_delimiters f (ntn_scope,Some ntn) scopes
-
-let rec interp_numeral_gen loc f n = function
-  | scope :: scopes ->
-      (try f (lookup_numeral_interpreter loc scope)
-       with Not_found -> interp_numeral_gen loc f n scopes)
-  | [] ->
-      user_err_loc (loc,"interp_numeral",
-      str "No interpretation for numeral " ++ pr_bigint n)
-
-let interp_numeral loc n scopes =
-  interp_numeral_gen loc (fun x -> fst x loc n) n
-    (List.fold_right push_scope scopes !scope_stack)
-
-let interp_numeral_as_pattern loc n name scopes =
-  let f x = match snd x with
-    | None -> raise Not_found
-    | Some g -> g loc n name in
-  interp_numeral_gen loc f n (List.fold_right push_scope scopes !scope_stack)
+    Gmap.mem ntn (Gmap.find scope !scope_map).notations in
+  find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes)
 
-let uninterp_numeral c =
+let uninterp_prim_token c =
   try 
-    let (sc,numpr,_) = Hashtbl.find numeral_key_table (rawconstr_key c) in
+    let (sc,numpr,_) = Hashtbl.find prim_token_key_table (rawconstr_key c) in
     match numpr c with
       | None -> raise No_match
       | Some n -> (sc,n)
   with Not_found -> raise No_match
 
-let uninterp_cases_numeral c =
+let uninterp_prim_token_cases_pattern c =
   try 
-    match Hashtbl.find numeral_key_table (pattern_key c) with
-      | (_,_,None) -> raise No_match
-      | (sc,_,Some numpr) ->
-	  match numpr c with
-	    | None -> raise No_match
-	    | Some n -> (sc,n)
+    let k = cases_pattern_key c in
+    let (sc,numpr,b) = Hashtbl.find prim_token_key_table k in
+    if not b then raise No_match;
+    let na,c = rawconstr_of_closed_cases_pattern c in
+    match numpr c with
+      | None -> raise No_match
+      | Some n -> (na,sc,n)
   with Not_found -> raise No_match
 
-let availability_of_numeral printer_scope scopes =
-  let f scope = Hashtbl.mem numeral_interpreter_tab scope in
-  option_app snd (find_without_delimiters f (Some printer_scope,None) scopes)
+let availability_of_prim_token printer_scope local_scopes =
+  let f scope = Hashtbl.mem prim_token_interpreter_tab scope in
+  let scopes = make_current_scopes local_scopes in
+  option_map snd (find_without_delimiters f (Some printer_scope,None) scopes)
 
 (* Miscellaneous *)
 
 let exists_notation_in_scope scopt ntn r =
   let scope = match scopt with Some s -> s | None -> default_scope in
   try
-    let sc = Stringmap.find scope !scope_map in
-    let (r',_,pp8only) = Stringmap.find ntn sc.notations in
-    r' = r, pp8only
-  with Not_found -> false, false
-
-(* Special scopes associated to arguments of a global reference *)
-
-let arguments_scope = ref Refmap.empty
-
-let cache_arguments_scope (_,(r,scl)) =
-  List.iter (option_iter check_scope) scl;
-  arguments_scope := Refmap.add r scl !arguments_scope
-
-let subst_arguments_scope (_,subst,(r,scl)) = (subst_global subst r,scl)
-
-let (inArgumentsScope,outArgumentsScope) = 
-  declare_object {(default_object "ARGUMENTS-SCOPE") with
-      cache_function = cache_arguments_scope;
-      load_function = (fun _ o -> cache_arguments_scope o);
-      subst_function = subst_arguments_scope;
-      classify_function = (fun (_,o) -> Substitute o);
-      export_function = (fun x -> Some x) }
-
-let declare_arguments_scope r scl =
-  Lib.add_anonymous_leaf (inArgumentsScope (r,scl))
-
-let find_arguments_scope r =
-  try Refmap.find r !arguments_scope
-  with Not_found -> []
+    let sc = Gmap.find scope !scope_map in
+    let (r',_) = Gmap.find ntn sc.notations in
+    r' = r
+  with Not_found -> false
 
 (**********************************************************************)
 (* Mapping classes to scopes *)
@@ -401,8 +423,6 @@ let declare_class_scope sc cl =
 let find_class_scope cl =
   Gmap.find cl !class_scope_map
 
-open Term
-
 let find_class t =
   let t, _ = decompose_app (Reductionops.whd_betaiotazeta t) in
   match kind_of_term t with
@@ -413,6 +433,9 @@ let find_class t =
     | Sort _ -> CL_SORT
     |  _ -> raise Not_found
 
+(**********************************************************************)
+(* Special scopes associated to arguments of a global reference *)
+
 let rec compute_arguments_scope t =
   match kind_of_term (Reductionops.whd_betaiotazeta t) with
     | Prod (_,t,u) ->
@@ -421,9 +444,65 @@ let rec compute_arguments_scope t =
 	sc :: compute_arguments_scope u
     | _ -> []
 
+let arguments_scope = ref Refmap.empty
+
+type arguments_scope_discharge_request =
+  | ArgsScopeAuto
+  | ArgsScopeManual
+  | ArgsScopeNoDischarge
+
+let load_arguments_scope _ (_,(_,r,scl)) =
+  List.iter (option_iter check_scope) scl;
+  arguments_scope := Refmap.add r scl !arguments_scope
+
+let cache_arguments_scope o =
+  load_arguments_scope 1 o
+
+let subst_arguments_scope (_,subst,(req,r,scl)) =
+  (ArgsScopeNoDischarge,fst (subst_global subst r),scl)
+
+let discharge_arguments_scope (_,(req,r,l)) =
+  if req = ArgsScopeNoDischarge then None
+  else Some (req,pop_global_reference r,l)
+
+let rebuild_arguments_scope (req,r,l) =
+  match req with
+    | ArgsScopeNoDischarge -> assert false
+    | ArgsScopeAuto ->
+	(req,r,compute_arguments_scope (Global.type_of_global r))
+    | ArgsScopeManual ->
+	(* Add to the manually given scopes the one found automatically
+           for the extra parameters of the section *)
+	let l' = compute_arguments_scope (Global.type_of_global r) in
+	let l1,_ = list_chop (List.length l' - List.length l) l' in
+	(req,r,l1@l)
+
+let (inArgumentsScope,outArgumentsScope) = 
+  declare_object {(default_object "ARGUMENTS-SCOPE") with
+      cache_function = cache_arguments_scope;
+      load_function = load_arguments_scope;
+      subst_function = subst_arguments_scope;
+      classify_function = (fun (_,o) -> Substitute o);
+      discharge_function = discharge_arguments_scope;
+      rebuild_function = rebuild_arguments_scope;
+      export_function = (fun x -> Some x) }
+
+let declare_arguments_scope_gen req r scl =
+  Lib.add_anonymous_leaf (inArgumentsScope (req,r,scl))
+
+let declare_arguments_scope local ref scl =
+  let req =
+    if local or isVarRef ref then ArgsScopeNoDischarge else ArgsScopeManual in
+  declare_arguments_scope_gen req ref scl
+
+let find_arguments_scope r =
+  try Refmap.find r !arguments_scope
+  with Not_found -> []
+
 let declare_ref_arguments_scope ref =
   let t = Global.type_of_global ref in
-  declare_arguments_scope ref (compute_arguments_scope t)
+  let req = if isVarRef ref then ArgsScopeNoDischarge else ArgsScopeAuto in
+  declare_arguments_scope_gen req ref (compute_arguments_scope t)
 
 (********************************)
 (* Encoding notations as string *)
@@ -447,7 +526,7 @@ let make_notation_key symbols =
 let decompose_notation_key s =
   let len = String.length s in
   let rec decomp_ntn dirs n =
-    if n>=len then dirs else
+    if n>=len then List.rev dirs else
     let pos =
       try
 	String.index_from s n ' ' 
@@ -478,36 +557,33 @@ let pr_scope_classes sc =
     hov 0 (str ("Bound to class"^(if List.tl l=[] then "" else "es")) ++
       spc() ++ prlist_with_sep spc pr_class l) ++ fnl()
 
-let rec rawconstr_of_aconstr () x =
-  rawconstr_of_aconstr_with_binders dummy_loc (fun id () -> (id,())) 
-    rawconstr_of_aconstr () x
-
 let pr_notation_info prraw ntn c =
-  str "\"" ++ str ntn ++ str "\" := " ++ prraw (rawconstr_of_aconstr () c)
+  str "\"" ++ str ntn ++ str "\" := " ++ 
+  prraw (rawconstr_of_aconstr dummy_loc c)
 
 let pr_named_scope prraw scope sc =
  (if scope = default_scope then
-   match Stringmap.fold (fun _ _ x -> x+1) sc.notations 0 with
+   match Gmap.fold (fun _ _ x -> x+1) sc.notations 0 with
      | 0 -> str "No lonely notation"
      | n -> str "Lonely notation" ++ (if n=1 then mt() else str"s")
   else 
     str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters)
   ++ fnl ()
   ++ pr_scope_classes scope
-  ++ Stringmap.fold
-       (fun ntn ((_,r),(_,df),_) strm ->
+  ++ Gmap.fold
+       (fun ntn ((_,r),(_,df)) strm ->
 	 pr_notation_info prraw df r ++ fnl () ++ strm)
        sc.notations (mt ())
 
 let pr_scope prraw scope = pr_named_scope prraw scope (find_scope scope)
 
 let pr_scopes prraw =
- Stringmap.fold 
+ Gmap.fold 
    (fun scope sc strm -> pr_named_scope prraw scope sc ++ fnl () ++ strm)
    !scope_map (mt ())
 
 let rec find_default ntn = function
-  | Scope scope::_ when Stringmap.mem ntn (find_scope scope).notations ->
+  | Scope scope::_ when Gmap.mem ntn (find_scope scope).notations ->
       Some scope
   | SingleNotation ntn'::_ when ntn = ntn' -> Some default_scope
   | _::scopes -> find_default ntn scopes
@@ -531,9 +607,9 @@ let browse_notation ntn map =
     if String.contains ntn ' ' then (=) ntn
     else fun ntn' -> List.mem (Terminal ntn) (decompose_notation_key ntn') in
   let l =
-    Stringmap.fold 
+    Gmap.fold 
       (fun scope_name sc ->
-	Stringmap.fold (fun ntn ((_,r),df,_) l ->
+	Gmap.fold (fun ntn ((_,r),df) l ->
 	  if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations)
       map [] in
   let l = List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) l in
@@ -560,8 +636,8 @@ let locate_notation prraw ntn =
 
 let collect_notation_in_scope scope sc known =
   assert (scope <> default_scope);
-  Stringmap.fold
-    (fun ntn ((_,r),(_,df),_) (l,known as acc) ->
+  Gmap.fold
+    (fun ntn ((_,r),(_,df)) (l,known as acc) ->
       if List.mem ntn known then acc else ((df,r)::l,ntn::known))
     sc.notations ([],known)
 
@@ -577,8 +653,8 @@ let collect_notations stack =
       | SingleNotation ntn ->
 	  if List.mem ntn knownntn then (all,knownntn)
 	  else
-	    let ((_,r),(_,df),_) =
-	      Stringmap.find ntn (find_scope default_scope).notations in
+	    let ((_,r),(_,df)) =
+	      Gmap.find ntn (find_scope default_scope).notations in
 	    let all' = match all with
 	      | (s,lonelyntn)::rest when s = default_scope ->
 		  (s,(df,r)::lonelyntn)::rest
@@ -614,13 +690,13 @@ type unparsing_rule = unparsing list * precedence
 
 (* Concrete syntax for symbolic-extension table *)
 let printing_rules = 
-  ref (Stringmap.empty : unparsing_rule Stringmap.t)
+  ref (Gmap.empty : (string,unparsing_rule) Gmap.t)
 
 let declare_notation_printing_rule ntn unpl =
-  printing_rules := Stringmap.add ntn unpl !printing_rules
+  printing_rules := Gmap.add ntn unpl !printing_rules
 
 let find_notation_printing_rule ntn =
-  try Stringmap.find ntn !printing_rules
+  try Gmap.find ntn !printing_rules
   with Not_found -> anomaly ("No printing rule found for "^ntn)
 
 (**********************************************************************)
@@ -644,13 +720,13 @@ let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) =
 let init () =
   init_scope_map ();
 (*
-  scope_stack := Stringmap.empty
+  scope_stack := Gmap.empty
   arguments_scope := Refmap.empty
 *)
-  notation_level_map := Stringmap.empty;
-  delimiters_map := Stringmap.empty;
+  notation_level_map := Gmap.empty;
+  delimiters_map := Gmap.empty;
   notations_key_table := Gmapl.empty;
-  printing_rules := Stringmap.empty;
+  printing_rules := Gmap.empty;
   class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty
 
 let _ = 
diff --git a/interp/symbols.mli b/interp/notation.mli
index 5401ae77..7be1f9fe 100644
--- a/interp/symbols.mli
+++ b/interp/notation.mli
@@ -6,12 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: symbols.mli,v 1.22.2.3 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: notation.mli 9481 2007-01-11 19:17:56Z herbelin $ i*)
 
 (*i*)
 open Util
 open Pp
-open Bignat
+open Bigint
 open Names
 open Nametab
 open Libnames
@@ -32,12 +32,15 @@ type delimiters = string
 type scope
 type scopes (* = [scope_name list] *)
 
+type local_scopes = tmp_scope_name option * scope_name list
+
 val type_scope : scope_name
 val declare_scope : scope_name -> unit
 
+val current_scopes : unit -> scopes
+
 (* Open scope *)
 
-val current_scopes : unit -> scopes
 val open_close_scope : 
   (* locality *) bool * (* open *) bool * scope_name -> unit
 
@@ -50,36 +53,47 @@ val push_scope : scope_name -> scopes -> scopes
 val declare_delimiters : scope_name -> delimiters -> unit
 val find_delimiters_scope : loc -> delimiters -> scope_name
 
-(*s Declare and uses back and forth a numeral interpretation *)
+(*s Declare and uses back and forth an interpretation of primitive token *)
 
 (* A numeral interpreter is the pair of an interpreter for **integer**
    numbers in terms and an optional interpreter in pattern, if
    negative numbers are not supported, the interpreter must fail with
    an appropriate error message *)
 
-type num_interpreter =
-    (loc -> bigint -> rawconstr)
-    * (loc -> bigint -> name -> cases_pattern) option
+type notation_location = dir_path * string
+type required_module = section_path * string list 
+type cases_pattern_status = bool (* true = use prim token in patterns *)
+
+type 'a prim_token_interpreter =
+    loc -> 'a -> rawconstr
 
-type num_uninterpreter =
-    rawconstr list * (rawconstr -> bigint option)
-    * (cases_pattern -> bigint option) option
+type 'a prim_token_uninterpreter =
+    rawconstr list * (rawconstr -> 'a option) * cases_pattern_status
 
-type required_module = global_reference * string list 
 val declare_numeral_interpreter : scope_name -> required_module ->
-  num_interpreter -> num_uninterpreter -> unit
+  bigint prim_token_interpreter -> bigint prim_token_uninterpreter -> unit
 
-(* Return the [term]/[cases_pattern] bound to a numeral in a given scope context*)
-val interp_numeral : loc -> bigint -> scope_name list -> rawconstr
-val interp_numeral_as_pattern : loc -> bigint -> name -> scope_name list ->
-  cases_pattern
+val declare_string_interpreter : scope_name -> required_module ->
+  string prim_token_interpreter -> string prim_token_uninterpreter -> unit
 
-(* Return the numeral bound to a [term]/[cases_pattern]; raise [No_match] if no *)
-(* such numeral *)
-val uninterp_numeral : rawconstr -> scope_name * bigint
-val uninterp_cases_numeral : cases_pattern -> scope_name * bigint
+(* Return the [term]/[cases_pattern] bound to a primitive token in a
+   given scope context*)
 
-val availability_of_numeral : scope_name -> scopes -> delimiters option option
+val interp_prim_token : loc -> prim_token -> local_scopes ->
+  rawconstr * (notation_location * scope_name option)
+val interp_prim_token_cases_pattern : loc -> prim_token -> name -> 
+  local_scopes -> cases_pattern * (notation_location * scope_name option)
+
+(* Return the primitive token associated to a [term]/[cases_pattern];
+   raise [No_match] if no such token *)
+
+val uninterp_prim_token : 
+  rawconstr -> scope_name * prim_token
+val uninterp_prim_token_cases_pattern : 
+  cases_pattern -> name * scope_name * prim_token
+
+val availability_of_prim_token : 
+  scope_name -> local_scopes -> delimiters option option
 
 (*s Declare and interpret back and forth a notation *)
 
@@ -87,14 +101,15 @@ val availability_of_numeral : scope_name -> scopes -> delimiters option option
 type interp_rule =
   | NotationRule of scope_name option * notation
   | SynDefRule of kernel_name
+
 val declare_notation_interpretation : notation -> scope_name option ->
-      interpretation -> dir_path * string -> bool -> unit
+      interpretation -> notation_location -> unit
 
 val declare_uninterpretation : interp_rule -> interpretation -> unit
 
 (* Return the interpretation bound to a notation *)
-val interp_notation : loc -> notation -> scope_name list -> 
-      interpretation * ((dir_path * string) * scope_name option)
+val interp_notation : loc -> notation -> local_scopes ->
+      interpretation * (notation_location * scope_name option)
 
 (* Return the possible notations for a given term *)
 val uninterp_notations : rawconstr ->
@@ -103,26 +118,26 @@ val uninterp_cases_pattern_notations : cases_pattern ->
       (interp_rule * interpretation * int option) list
 
 (* Test if a notation is available in the scopes *)
-(* context [scopes] if available, the result is not None; the first *)
-(* argument is itself not None if a delimiters is needed; the second *)
-(* argument is a numeral printer if the *)
-val availability_of_notation : scope_name option * notation -> scopes -> 
+(* context [scopes]; if available, the result is not None; the first *)
+(* argument is itself not None if a delimiters is needed *)
+val availability_of_notation : scope_name option * notation -> local_scopes -> 
   (scope_name option * delimiters option) option
 
 (*s Declare and test the level of a (possibly uninterpreted) notation *)
 
-val declare_notation_level : notation -> level option * level -> unit
-val level_of_notation : notation -> level option * level 
-      (* raise [Not_found] if no level *)
+val declare_notation_level : notation -> level -> unit
+val level_of_notation : notation -> level (* raise [Not_found] if no level *)
 
 (*s** Miscellaneous *)
 
 (* Checks for already existing notations *)
 val exists_notation_in_scope : scope_name option -> notation ->
-      interpretation -> bool * bool
+      interpretation -> bool
 
 (* Declares and looks for scopes associated to arguments of a global ref *)
-val declare_arguments_scope: global_reference -> scope_name option list -> unit
+val declare_arguments_scope : 
+  bool (* true=local *) -> global_reference -> scope_name option list -> unit
+
 val find_arguments_scope : global_reference -> scope_name option list
 
 val declare_class_scope : scope_name -> Classops.cl_typ -> unit
@@ -157,4 +172,4 @@ val declare_notation_printing_rule : notation -> unparsing_rule -> unit
 val find_notation_printing_rule : notation -> unparsing_rule
 
 (**********************************************************************)
-(* Rem: printing rules for numerals are trivial *)
+(* Rem: printing rules for primitive token are canonical *)
diff --git a/interp/ppextend.ml b/interp/ppextend.ml
index 29fb7cc7..34e93624 100644
--- a/interp/ppextend.ml
+++ b/interp/ppextend.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ppextend.ml,v 1.4.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+(*i $Id: ppextend.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (*i*)
 open Pp
diff --git a/interp/ppextend.mli b/interp/ppextend.mli
index bc0a83ec..3d49c210 100644
--- a/interp/ppextend.mli
+++ b/interp/ppextend.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ppextend.mli,v 1.4.2.2 2005/01/21 16:41:50 herbelin Exp $ i*)
+(*i $Id: ppextend.mli 6616 2005-01-21 17:18:23Z herbelin $ i*)
 
 (*i*)
 open Pp
diff --git a/interp/reserve.ml b/interp/reserve.ml
index 72899676..aee981bd 100644
--- a/interp/reserve.ml
+++ b/interp/reserve.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reserve.ml,v 1.10.2.1 2004/07/16 19:30:22 herbelin Exp $ i*)
+(*i $Id: reserve.ml 8752 2006-04-27 19:37:33Z herbelin $ i*)
 
 (* Reserved names *)
 
@@ -57,26 +57,23 @@ let rec unloc = function
   | RLambda (_,na,ty,c) -> RLambda (dummy_loc,na,unloc ty,unloc c)
   | RProd (_,na,ty,c) -> RProd (dummy_loc,na,unloc ty,unloc c)
   | RLetIn (_,na,b,c) -> RLetIn (dummy_loc,na,unloc b,unloc c)
-  | RCases (_,(tyopt,rtntypopt),tml,pl) ->
+  | RCases (_,rtntypopt,tml,pl) ->
       RCases (dummy_loc,
-        (option_app unloc tyopt,ref (option_app unloc !rtntypopt)),
+        (option_map unloc rtntypopt),
 	List.map (fun (tm,x) -> (unloc tm,x)) tml,
         List.map (fun (_,idl,p,c) -> (dummy_loc,idl,p,unloc c)) pl)
-  | ROrderedCase (_,b,tyopt,tm,bv,x) ->
-      ROrderedCase 
-      (dummy_loc,b,option_app unloc tyopt,unloc tm, Array.map unloc bv,x)
   | RLetTuple (_,nal,(na,po),b,c) ->
-      RLetTuple (dummy_loc,nal,(na,option_app unloc po),unloc b,unloc c)
+      RLetTuple (dummy_loc,nal,(na,option_map unloc po),unloc b,unloc c)
   | RIf (_,c,(na,po),b1,b2) ->
-      RIf (dummy_loc,unloc c,(na,option_app unloc po),unloc b1,unloc b2)
+      RIf (dummy_loc,unloc c,(na,option_map unloc po),unloc b1,unloc b2)
   | RRec (_,fk,idl,bl,tyl,bv) ->
       RRec (dummy_loc,fk,idl,
             Array.map (List.map 
-              (fun (na,obd,ty) -> (na,option_app unloc obd, unloc ty)))
+              (fun (na,obd,ty) -> (na,option_map unloc obd, unloc ty)))
               bl,
             Array.map unloc tyl,
             Array.map unloc bv)
-  | RCast (_,c,t) -> RCast (dummy_loc,unloc c,unloc t)
+  | RCast (_,c,k,t) -> RCast (dummy_loc,unloc c,k,unloc t)
   | RSort (_,x) -> RSort (dummy_loc,x)
   | RHole (_,x)  -> RHole (dummy_loc,x)
   | RRef (_,x) -> RRef (dummy_loc,x)
@@ -86,10 +83,9 @@ let rec unloc = function
 
 let anonymize_if_reserved na t = match na with
   | Name id as na ->
-      if !Options.v7 & id = id_of_string "_" then t else
       (try 
 	if unloc t = find_reserved_type id
-	then RHole (dummy_loc,BinderType na)
+	then RHole (dummy_loc,Evd.BinderType na)
 	else t
       with Not_found -> t)
   | Anonymous -> t
diff --git a/interp/reserve.mli b/interp/reserve.mli
index a79e2c25..13349ee9 100644
--- a/interp/reserve.mli
+++ b/interp/reserve.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reserve.mli,v 1.2.2.1 2004/07/16 19:30:22 herbelin Exp $ i*)
+(*i $Id: reserve.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 open Util
 open Names
diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml
index ceda2b47..3389cd8a 100644
--- a/interp/syntax_def.ml
+++ b/interp/syntax_def.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: syntax_def.ml,v 1.6.2.2 2006/01/03 20:33:31 herbelin Exp $ *)
+(* $Id: syntax_def.ml 7779 2006-01-03 20:33:47Z herbelin $ *)
 
 open Util
 open Pp
@@ -39,21 +39,21 @@ let load_syntax_constant i ((sp,kn),(local,c,onlyparse)) =
   add_syntax_constant kn c;
   Nametab.push_syntactic_definition (Nametab.Until i) sp kn;
   if not onlyparse then
-    (* Declare it to be used as (long) name *)
-    Symbols.declare_uninterpretation (Symbols.SynDefRule kn) ([],c)
+    (* Declare it to be used as long name *)
+    Notation.declare_uninterpretation (Notation.SynDefRule kn) ([],c)
 
 let open_syntax_constant i ((sp,kn),(_,c,onlyparse)) =
   Nametab.push_syntactic_definition (Nametab.Exactly i) sp kn;
   if not onlyparse then
     (* Redeclare it to be used as (short) name in case an other (distfix)
        notation was declared inbetween *)
-    Symbols.declare_uninterpretation (Symbols.SynDefRule kn) ([],c)
+    Notation.declare_uninterpretation (Notation.SynDefRule kn) ([],c)
 
 let cache_syntax_constant d =
   load_syntax_constant 1 d
 
 let subst_syntax_constant ((sp,kn),subst,(local,c,onlyparse)) =
-  (local,subst_aconstr subst c,onlyparse)
+  (local,subst_aconstr subst [] c,onlyparse)
 
 let classify_syntax_constant (_,(local,_,_ as o)) =
   if local then Dispose else Substitute o
@@ -78,3 +78,15 @@ let rec set_loc loc _ a =
 
 let search_syntactic_definition loc kn =
   set_loc loc () (KNmap.find kn !syntax_table)
+
+exception BoundToASyntacticDefThatIsNotARef
+
+let locate_global qid =
+  match Nametab.extended_locate qid with
+  | TrueGlobal ref -> ref
+  | SyntacticDef kn -> 
+  match search_syntactic_definition dummy_loc kn with
+  | Rawterm.RRef (_,ref) -> ref
+  | _ -> 
+      errorlabstrm "" (pr_qualid qid ++ 
+        str " is bound to a notation that does not denote a reference")
diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli
index 0aec03c2..ac7318b5 100644
--- a/interp/syntax_def.mli
+++ b/interp/syntax_def.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: syntax_def.mli,v 1.3.2.2 2004/07/16 19:30:23 herbelin Exp $ i*)
+(*i $Id: syntax_def.mli 7051 2005-05-20 15:45:51Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -23,3 +23,10 @@ val declare_syntactic_definition : bool -> identifier -> bool -> aconstr
 val search_syntactic_definition : loc -> kernel_name -> rawconstr
 
 
+(* [locate_global] locates global reference possibly following a chain of 
+   syntactic aliases; raise Not_found if not bound in the global env; 
+   raise an error if bound to a syntactic def that does not denote a
+   reference *)
+
+val locate_global : Libnames.qualid -> Libnames.global_reference
+
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index a2b6e8b7..936b6830 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: topconstr.ml,v 1.35.2.3 2004/11/17 09:51:41 herbelin Exp $ *)
+(* $Id: topconstr.ml 9226 2006-10-09 16:11:01Z herbelin $ *)
 
 (*i*)
 open Pp
@@ -16,6 +16,7 @@ open Nameops
 open Libnames
 open Rawterm
 open Term
+open Mod_subst
 (*i*)
 
 (**********************************************************************)
@@ -36,20 +37,26 @@ type aconstr =
   | ALambda of name * aconstr * aconstr
   | AProd of name * aconstr * aconstr
   | ALetIn of name * aconstr * aconstr
-  | ACases of aconstr option * aconstr option *
-      (aconstr * (name * (inductive * name list) option)) list *
-      (identifier list * cases_pattern list * aconstr) list
-  | AOrderedCase of case_style * aconstr option * aconstr * aconstr array
+  | ACases of aconstr option *
+      (aconstr * (name * (inductive * int * name list) option)) list *
+      (cases_pattern list * aconstr) list
   | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr
   | AIf of aconstr * (name * aconstr option) * aconstr * aconstr
   | ASort of rawsort
-  | AHole of hole_kind
+  | AHole of Evd.hole_kind
   | APatVar of patvar
-  | ACast of aconstr * aconstr
-  
-let name_app f e = function
-  | Name id -> let (id, e) = f id e in (Name id, e)
-  | Anonymous -> Anonymous, e
+  | ACast of aconstr * cast_type * aconstr
+
+(**********************************************************************)
+(* Re-interpret a notation as a rawconstr, taking care of binders     *)
+
+let rec cases_pattern_fold_map loc g e = function
+  | PatVar (_,na) ->
+      let e',na' = name_fold_map g e na in e', PatVar (loc,na')
+  | PatCstr (_,cstr,patl,na) ->
+      let e',na' = name_fold_map g e na in
+      let e',patl' = list_fold_map (cases_pattern_fold_map loc g) e patl in
+      e', PatCstr (loc,cstr,patl',na')
 
 let rec subst_rawvars l = function
   | RVar (_,id) as r -> (try List.assoc id l with Not_found -> r)
@@ -67,142 +74,47 @@ let rawconstr_of_aconstr_with_binders loc g f e = function
       let outerl = (ldots_var,inner)::(if swap then [x,RVar(loc,y)] else []) in
       subst_rawvars outerl it
   | ALambda (na,ty,c) ->
-      let na,e = name_app g e na in RLambda (loc,na,f e ty,f e c)
+      let e,na = name_fold_map g e na in RLambda (loc,na,f e ty,f e c)
   | AProd (na,ty,c) ->
-      let na,e = name_app g e na in RProd (loc,na,f e ty,f e c)
+      let e,na = name_fold_map g e na in RProd (loc,na,f e ty,f e c)
   | ALetIn (na,b,c) ->
-      let na,e = name_app g e na in RLetIn (loc,na,f e b,f e c)
-  | ACases (tyopt,rtntypopt,tml,eqnl) ->
-      let cases_predicate_names tml =
-	List.flatten (List.map (function
-	  | (tm,(na,None)) -> [na]
-	  | (tm,(na,Some (_,nal))) -> na::nal) tml) in
-      (* TODO: apply g to na (in fact not used) *)
-      let e' = List.fold_right
-	(fun na e -> snd (name_app g e na)) (cases_predicate_names tml) e in
-      let fold id (idl,e) = let (id,e) = g id e in (id::idl,e) in
-      let eqnl = List.map (fun (idl,pat,rhs) ->
-        let (idl,e) = List.fold_right fold idl ([],e) in (loc,idl,pat,f e rhs)) eqnl in
-      RCases (loc,(option_app (f e) tyopt, ref (option_app (f e') rtntypopt)),
-        List.map (fun (tm,(na,x)) -> 
-	  (f e tm,ref (na,option_app (fun (x,y) -> (loc,x,y)) x))) tml,eqnl)
-  | AOrderedCase (b,tyopt,tm,bv) ->
-      ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv,ref None)
+      let e,na = name_fold_map g e na in RLetIn (loc,na,f e b,f e c)
+  | ACases (rtntypopt,tml,eqnl) ->
+      let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') ->
+	let e',t' = match t with
+	| None -> e',None
+	| Some (ind,npar,nal) -> 
+	  let e',nal' = List.fold_right (fun na (e',nal) -> 
+	      let e',na' = name_fold_map g e' na in e',na'::nal) nal (e',[]) in
+	  e',Some (loc,ind,npar,nal') in
+	let e',na' = name_fold_map g e' na in
+	(e',(f e tm,(na',t'))::tml')) tml (e,[]) in
+      let fold (idl,e) id = let (e,id) = g e id in ((id::idl,e),id) in
+      let eqnl' = List.map (fun (patl,rhs) ->
+	let ((idl,e),patl) =
+	  list_fold_map (cases_pattern_fold_map loc fold) ([],e) patl in
+	(loc,idl,patl,f e rhs)) eqnl in
+      RCases (loc,option_map (f e') rtntypopt,tml',eqnl')
   | ALetTuple (nal,(na,po),b,c) ->
-      let e,nal = list_fold_map (fun e na -> let (na,e) = name_app g e na in e,na) e nal in 
-      let na,e = name_app g e na in
-      RLetTuple (loc,nal,(na,option_app (f e) po),f e b,f e c)
+      let e,nal = list_fold_map (name_fold_map g) e nal in 
+      let e,na = name_fold_map g e na in
+      RLetTuple (loc,nal,(na,option_map (f e) po),f e b,f e c)
   | AIf (c,(na,po),b1,b2) ->
-      let na,e = name_app g e na in
-      RIf (loc,f e c,(na,option_app (f e) po),f e b1,f e b2)
-  | ACast (c,t) -> RCast (loc,f e c,f e t)
+      let e,na = name_fold_map g e na in
+      RIf (loc,f e c,(na,option_map (f e) po),f e b1,f e b2)
+  | ACast (c,k,t) -> RCast (loc,f e c, k,f e t)
   | ASort x -> RSort (loc,x)
   | AHole x  -> RHole (loc,x)
   | APatVar n -> RPatVar (loc,(false,n))
   | ARef x -> RRef (loc,x)
 
-let rec subst_pat subst pat = 
-  match pat with
-  | PatVar _ -> pat
-  | PatCstr (loc,((kn,i),j),cpl,n) -> 
-      let kn' = subst_kn subst kn 
-      and cpl' = list_smartmap (subst_pat subst) cpl in
-        if kn' == kn && cpl' == cpl then pat else
-          PatCstr (loc,((kn',i),j),cpl',n)
-
-let rec subst_aconstr subst raw =
-  match raw with
-  | ARef ref -> 
-      let ref' = subst_global subst ref in 
-	if ref' == ref then raw else
-	  ARef ref'
-
-  | AVar _ -> raw
+let rec rawconstr_of_aconstr loc x =
+  let rec aux () x = 
+    rawconstr_of_aconstr_with_binders loc (fun () id -> ((),id)) aux () x
+  in aux () x
 
-  | AApp (r,rl) -> 
-      let r' = subst_aconstr subst r 
-      and rl' = list_smartmap (subst_aconstr subst) rl in
-	if r' == r && rl' == rl then raw else
-	  AApp(r',rl')
-
-  | AList (id1,id2,r1,r2,b) -> 
-      let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  AList (id1,id2,r1',r2',b)
-
-  | ALambda (n,r1,r2) -> 
-      let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  ALambda (n,r1',r2')
-
-  | AProd (n,r1,r2) -> 
-      let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  AProd (n,r1',r2')
-
-  | ALetIn (n,r1,r2) -> 
-      let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  ALetIn (n,r1',r2')
-
-  | ACases (ro,rtntypopt,rl,branches) -> 
-      let ro' = option_smartmap (subst_aconstr subst) ro 
-      and rtntypopt' = option_smartmap (subst_aconstr subst) rtntypopt
-      and rl' = list_smartmap
-        (fun (a,(n,signopt) as x) -> 
-	  let a' = subst_aconstr subst a in
-	  let signopt' = option_app (fun ((indkn,i),nal as z) ->
-	    let indkn' = subst_kn subst indkn in
-	    if indkn == indkn' then z else ((indkn',i),nal)) signopt in
-	  if a' == a && signopt' == signopt then x else (a',(n,signopt')))
-        rl
-      and branches' = list_smartmap 
-                        (fun (idl,cpl,r as branch) ->
-                           let cpl' = list_smartmap (subst_pat subst) cpl
-                           and r' = subst_aconstr subst r in
-                             if cpl' == cpl && r' == r then branch else
-                               (idl,cpl',r'))
-                        branches
-      in
-        if ro' == ro && rtntypopt == rtntypopt' &
-          rl' == rl && branches' == branches then raw else
-          ACases (ro',rtntypopt',rl',branches')
-
-  | AOrderedCase (b,ro,r,ra) -> 
-      let ro' = option_smartmap (subst_aconstr subst) ro
-      and r' = subst_aconstr subst r 
-      and ra' = array_smartmap (subst_aconstr subst) ra in
-	if ro' == ro && r' == r && ra' == ra then raw else
-	  AOrderedCase (b,ro',r',ra')
-
-  | ALetTuple (nal,(na,po),b,c) ->
-      let po' = option_smartmap (subst_aconstr subst) po
-      and b' = subst_aconstr subst b 
-      and c' = subst_aconstr subst c in
-	if po' == po && b' == b && c' == c then raw else
-	  ALetTuple (nal,(na,po'),b',c')
-
-  | AIf (c,(na,po),b1,b2) ->
-      let po' = option_smartmap (subst_aconstr subst) po
-      and b1' = subst_aconstr subst b1
-      and b2' = subst_aconstr subst b2 
-      and c' = subst_aconstr subst c in
-	if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else
-	  AIf (c',(na,po'),b1',b2')
-
-  | APatVar _ | ASort _ -> raw
-
-  | AHole (ImplicitArg (ref,i)) ->
-      let ref' = subst_global subst ref in 
-	if ref' == ref then raw else
-	  AHole (ImplicitArg (ref',i))
-  | AHole (BinderType _ | QuestionMark | CasesType |
-      InternalHole | TomatchTypeParameter _) -> raw
-
-  | ACast (r1,r2) -> 
-      let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  ACast (r1',r2')
+(****************************************************************************)
+(* Translating a rawconstr into a notation, interpreting recursive patterns *)
 
 let add_name r = function
   | Anonymous -> ()
@@ -222,9 +134,9 @@ let compare_rawconstr f t1 t2 = match t1,t2 with
       f ty1 ty2 & f c1 c2
   | RHole _, RHole _ -> true
   | RSort (_,s1), RSort (_,s2) -> s1 = s2
-  | (RLetIn _ | RCases _ | ROrderedCase _ | RRec _ | RDynamic _
+  | (RLetIn _ | RCases _ | RRec _ | RDynamic _
     | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _),_
-  | _,(RLetIn _ | RCases _ | ROrderedCase _ | RRec _ | RDynamic _
+  | _,(RLetIn _ | RCases _ | RRec _ | RDynamic _
       | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _)
       -> error "Unsupported construction in recursive notations"
   | (RRef _ | RVar _ | RApp _ | RLambda _ | RProd _ | RHole _ | RSort _), _
@@ -232,7 +144,7 @@ let compare_rawconstr f t1 t2 = match t1,t2 with
 
 let rec eq_rawconstr t1 t2 = compare_rawconstr eq_rawconstr t1 t2
 
-let discriminate_patterns nl l1 l2 =
+let discriminate_patterns foundvars nl l1 l2 =
   let diff = ref None in
   let rec aux n c1 c2 = match c1,c2 with
   | RVar (_,v1), RVar (_,v2) when v1<>v2 ->
@@ -245,42 +157,46 @@ let discriminate_patterns nl l1 l2 =
   let l = list_map2_i aux 0 l1 l2 in
   if not (List.for_all ((=) true) l) then
     error "Both ends of the recursive pattern differ";
-  !diff
+  match !diff with
+    | None ->  error "Both ends of the recursive pattern are the same"
+    | Some (x,y,_ as discr) ->
+	List.iter (fun id ->
+          if List.mem id !foundvars
+          then error "Variables used in the recursive part of a pattern are not allowed to occur outside of the recursive part";
+          foundvars := id::!foundvars) [x;y];
+	discr
 
 let aconstr_and_vars_of_rawconstr a =
   let found = ref [] in
-  let bound_binders = ref [] in
   let rec aux = function
-  | RVar (_,id) -> 
-      if not (List.mem id !bound_binders) then found := id::!found;
-      AVar id
+  | RVar (_,id) -> found := id::!found; AVar id
   | RApp (_,f,args) when has_ldots args -> make_aconstr_list f args 
+  | RApp (_,RVar (_,f),[RApp (_,t,[c]);d]) when f = ldots_var ->
+      (* Special case for alternative (recursive) notation of application *)
+      let x,y,lassoc = discriminate_patterns found 0 [c] [d] in
+      found := ldots_var :: !found; assert lassoc;
+      AList (x,y,AApp (AVar ldots_var,[AVar x]),aux t,lassoc)
   | RApp (_,g,args) -> AApp (aux g, List.map aux args)
-  | RLambda (_,na,ty,c) -> add_name bound_binders na; ALambda (na,aux ty,aux c)
-  | RProd (_,na,ty,c) -> add_name bound_binders na; AProd (na,aux ty,aux c)
-  | RLetIn (_,na,b,c) -> add_name bound_binders na; ALetIn (na,aux b,aux c)
-  | RCases (_,(tyopt,rtntypopt),tml,eqnl) ->
-      let f (_,idl,pat,rhs) =
-        bound_binders := idl@(!bound_binders);
-        (idl,pat,aux rhs) in
-      ACases (option_app aux tyopt,
-        option_app aux !rtntypopt,
-        List.map (fun (tm,{contents = (na,x)}) ->
-	  add_name bound_binders na;
+  | RLambda (_,na,ty,c) -> add_name found na; ALambda (na,aux ty,aux c)
+  | RProd (_,na,ty,c) -> add_name found na; AProd (na,aux ty,aux c)
+  | RLetIn (_,na,b,c) -> add_name found na; ALetIn (na,aux b,aux c)
+  | RCases (_,rtntypopt,tml,eqnl) ->
+      let f (_,idl,pat,rhs) = found := idl@(!found); (pat,aux rhs) in
+      ACases (option_map aux rtntypopt,
+        List.map (fun (tm,(na,x)) ->
+	  add_name found na;
 	  option_iter
-	    (fun (_,_,nl) -> List.iter (add_name bound_binders) nl) x;
-          (aux tm,(na,option_app (fun (_,ind,nal) -> (ind,nal)) x))) tml,
+	    (fun (_,_,_,nl) -> List.iter (add_name found) nl) x;
+          (aux tm,(na,option_map (fun (_,ind,n,nal) -> (ind,n,nal)) x))) tml,
         List.map f eqnl)
-  | ROrderedCase (_,b,tyopt,tm,bv,_) ->
-      AOrderedCase (b,option_app aux tyopt,aux tm, Array.map aux bv)
   | RLetTuple (loc,nal,(na,po),b,c) ->
-      add_name bound_binders na;
-      List.iter (add_name bound_binders) nal;
-      ALetTuple (nal,(na,option_app aux po),aux b,aux c)
+      add_name found na;
+      List.iter (add_name found) nal;
+      ALetTuple (nal,(na,option_map aux po),aux b,aux c)
   | RIf (loc,c,(na,po),b1,b2) ->
-      add_name bound_binders na;
-      AIf (aux c,(na,option_app aux po),aux b1,aux b2)
-  | RCast (_,c,t) -> ACast (aux c,aux t)
+      add_name found na;
+      AIf (aux c,(na,option_map aux po),aux b1,aux b2)
+  | RCast (_,c,k,t) -> ACast (aux c,k,aux t)
   | RSort (_,s) -> ASort s
   | RHole (_,w) -> AHole w
   | RRef (_,r) -> ARef r
@@ -300,13 +216,7 @@ allowed in abbreviatable expressions"
 	error "Both ends of the recursive pattern have different lengths";
       let ll2,l2' = list_chop nl l2 in
       let t = List.hd l2' and lr2 = List.tl l2' in
-      let discr = discriminate_patterns nl (ll1@lr1) (ll2@lr2) in
-      let x,y,order = match discr with Some z -> z | None -> 
-	error "Both ends of the recursive pattern are the same" in
-      List.iter (fun id ->
-        if List.mem id !bound_binders or List.mem id !found 
-        then error "Variables used in the recursive part of a pattern are not allowed to occur outside of the recursive part";
-        found := id::!found) [x;y];
+      let x,y,order = discriminate_patterns found nl (ll1@lr1) (ll2@lr2) in
       let iter =
         if order then RApp (loc,f2,ll2@RVar (loc,ldots_var)::lr2)
         else RApp (loc,f1,ll1@RVar (loc,ldots_var)::lr1) in
@@ -326,20 +236,142 @@ allowed in abbreviatable expressions"
   in
   let t = aux a in
   (* Side effect *)
-  t, !found, !bound_binders
+  t, !found
 
 let aconstr_of_rawconstr vars a =
-  let a,notbindingvars,binders = aconstr_and_vars_of_rawconstr a in
+  let a,foundvars = aconstr_and_vars_of_rawconstr a in
   let check_type x =
-    if not (List.mem x notbindingvars or List.mem x binders) then
+    if not (List.mem x foundvars) then
       error ((string_of_id x)^" is unbound in the right-hand-side") in
   List.iter check_type vars;
   a
 
+(* Substitution of kernel names, avoiding a list of bound identifiers *)
+
+let aconstr_of_constr avoiding t =
+ aconstr_of_rawconstr [] (Detyping.detype false avoiding [] t)
+
+let rec subst_pat subst pat = 
+  match pat with
+  | PatVar _ -> pat
+  | PatCstr (loc,((kn,i),j),cpl,n) -> 
+      let kn' = subst_kn subst kn 
+      and cpl' = list_smartmap (subst_pat subst) cpl in
+        if kn' == kn && cpl' == cpl then pat else
+          PatCstr (loc,((kn',i),j),cpl',n)
+
+let rec subst_aconstr subst bound raw =
+  match raw with
+  | ARef ref -> 
+      let ref',t = subst_global subst ref in 
+	if ref' == ref then raw else
+	  aconstr_of_constr bound t
+
+  | AVar _ -> raw
+
+  | AApp (r,rl) -> 
+      let r' = subst_aconstr subst bound r 
+      and rl' = list_smartmap (subst_aconstr subst bound) rl in
+	if r' == r && rl' == rl then raw else
+	  AApp(r',rl')
+
+  | AList (id1,id2,r1,r2,b) -> 
+      let r1' = subst_aconstr subst bound r1
+      and r2' = subst_aconstr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  AList (id1,id2,r1',r2',b)
+
+  | ALambda (n,r1,r2) -> 
+      let r1' = subst_aconstr subst bound r1
+      and r2' = subst_aconstr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  ALambda (n,r1',r2')
+
+  | AProd (n,r1,r2) -> 
+      let r1' = subst_aconstr subst bound r1
+      and r2' = subst_aconstr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  AProd (n,r1',r2')
+
+  | ALetIn (n,r1,r2) -> 
+      let r1' = subst_aconstr subst bound r1 
+      and r2' = subst_aconstr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  ALetIn (n,r1',r2')
+
+  | ACases (rtntypopt,rl,branches) -> 
+      let rtntypopt' = option_smartmap (subst_aconstr subst bound) rtntypopt
+      and rl' = list_smartmap
+        (fun (a,(n,signopt) as x) -> 
+	  let a' = subst_aconstr subst bound a in
+	  let signopt' = option_map (fun ((indkn,i),n,nal as z) ->
+	    let indkn' = subst_kn subst indkn in
+	    if indkn == indkn' then z else ((indkn',i),n,nal)) signopt in
+	  if a' == a && signopt' == signopt then x else (a',(n,signopt')))
+        rl
+      and branches' = list_smartmap 
+                        (fun (cpl,r as branch) ->
+                           let cpl' = list_smartmap (subst_pat subst) cpl
+                           and r' = subst_aconstr subst bound r in
+                             if cpl' == cpl && r' == r then branch else
+                               (cpl',r'))
+                        branches
+      in
+        if rtntypopt' == rtntypopt && rtntypopt == rtntypopt' &
+          rl' == rl && branches' == branches then raw else
+          ACases (rtntypopt',rl',branches')
+
+  | ALetTuple (nal,(na,po),b,c) ->
+      let po' = option_smartmap (subst_aconstr subst bound) po
+      and b' = subst_aconstr subst bound b 
+      and c' = subst_aconstr subst bound c in
+	if po' == po && b' == b && c' == c then raw else
+	  ALetTuple (nal,(na,po'),b',c')
+
+  | AIf (c,(na,po),b1,b2) ->
+      let po' = option_smartmap (subst_aconstr subst bound) po
+      and b1' = subst_aconstr subst bound b1
+      and b2' = subst_aconstr subst bound b2 
+      and c' = subst_aconstr subst bound c in
+	if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else
+	  AIf (c',(na,po'),b1',b2')
+
+  | APatVar _ | ASort _ -> raw
+
+  | AHole (Evd.ImplicitArg (ref,i)) ->
+      let ref',t = subst_global subst ref in 
+	if ref' == ref then raw else
+	  AHole (Evd.InternalHole)
+  | AHole (Evd.BinderType _ | Evd.QuestionMark | Evd.CasesType |
+      Evd.InternalHole | Evd.TomatchTypeParameter _) -> raw
+
+  | ACast (r1,k,r2) -> 
+      let r1' = subst_aconstr subst bound r1 
+      and r2' = subst_aconstr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  ACast (r1',k,r2')
+
+
 let encode_list_value l = RApp (dummy_loc,RVar (dummy_loc,ldots_var),l)
 
 (* Pattern-matching rawconstr and aconstr *)
 
+let abstract_return_type_context pi mklam tml rtno =
+  option_map (fun rtn ->
+    let nal =
+      List.flatten (List.map (fun (_,(na,t)) ->
+	match t with Some x -> (pi x)@[na] | None -> [na]) tml) in
+    List.fold_right mklam nal rtn)
+    rtno
+
+let abstract_return_type_context_rawconstr =
+  abstract_return_type_context (fun (_,_,_,nal) -> nal)
+    (fun na c -> RLambda(dummy_loc,na,RHole(dummy_loc,Evd.InternalHole),c))
+
+let abstract_return_type_context_aconstr =
+  abstract_return_type_context pi3
+    (fun na c -> ALambda(na,AHole Evd.InternalHole,c))
+
 let rec adjust_scopes = function
   | _,[] -> []
   | [],a::args -> (None,a) :: adjust_scopes ([],args)
@@ -366,6 +398,27 @@ let bind_env alp sigma var v =
     (* TODO: handle the case of multiple occs in different scopes *)
     (var,v)::sigma
 
+let match_opt f sigma t1 t2 = match (t1,t2) with
+  | None, None -> sigma
+  | Some t1, Some t2 -> f sigma t1 t2
+  | _ -> raise No_match
+
+let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with
+  | (Name id1,Name id2) when List.mem id2 metas ->
+      alp, bind_env alp sigma id2 (RVar (dummy_loc,id1))
+  | (Name id1,Name id2) -> (id1,id2)::alp,sigma
+  | (Anonymous,Anonymous) -> alp,sigma
+  | _ -> raise No_match
+
+let rec match_cases_pattern metas acc pat1 pat2 =
+  match (pat1,pat2) with
+  | PatVar (_,na1), PatVar (_,na2) -> match_names metas acc na1 na2
+  | PatCstr (_,c1,patl1,na1), PatCstr (_,c2,patl2,na2)
+      when c1 = c2 & List.length patl1 = List.length patl2 ->
+      List.fold_left2 (match_cases_pattern metas)
+	(match_names metas acc na1 na2) patl1 patl2
+  | _ -> raise No_match
+
 let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
   | r1, AVar id2 when List.mem id2 metas -> bind_env alp sigma id2 r1
   | RVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma
@@ -377,28 +430,35 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
       when List.length l1 = List.length l2 ->
       match_alist alp metas sigma (f1::l1) (f2::l2) x iter termin lassoc
   | RLambda (_,na1,t1,b1), ALambda (na2,t2,b2) ->
-     match_binders alp metas (match_ alp metas sigma t1 t2) b1 b2 na1 na2
+     match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2
   | RProd (_,na1,t1,b1), AProd (na2,t2,b2) ->
-     match_binders alp metas (match_ alp metas sigma t1 t2) b1 b2 na1 na2
+     match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2
   | RLetIn (_,na1,t1,b1), ALetIn (na2,t2,b2) ->
-     match_binders alp metas (match_ alp metas sigma t1 t2) b1 b2 na1 na2
-  | RCases (_,(po1,rtno1),tml1,eqnl1), ACases (po2,rtno2,tml2,eqnl2) 
-      when List.length tml1 = List.length tml2 ->
-     let sigma = option_fold_left2 (match_ alp metas) sigma po1 po2 in
-     (* TODO: match rtno' with their contexts *)
-     let sigma = List.fold_left2 
+     match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2
+  | RCases (_,rtno1,tml1,eqnl1), ACases (rtno2,tml2,eqnl2) 
+      when List.length tml1 = List.length tml2
+	 & List.length eqnl1 = List.length eqnl2 ->
+      let rtno1' = abstract_return_type_context_rawconstr tml1 rtno1 in
+      let rtno2' = abstract_return_type_context_aconstr tml2 rtno2 in
+      let sigma = option_fold_left2 (match_ alp metas) sigma rtno1' rtno2' in
+      let sigma = List.fold_left2 
        (fun s (tm1,_) (tm2,_) -> match_ alp metas s tm1 tm2) sigma tml1 tml2 in
-     List.fold_left2 (match_equations alp metas) sigma eqnl1 eqnl2
-  | ROrderedCase (_,st,po1,c1,bl1,_), AOrderedCase (st2,po2,c2,bl2) 
-      when Array.length bl1 = Array.length bl2 ->
-     let sigma = option_fold_left2 (match_ alp metas) sigma po1 po2 in
-     array_fold_left2 (match_ alp metas) (match_ alp metas sigma c1 c2) bl1 bl2
-  | RCast(_,c1,t1), ACast(c2,t2) ->
+      List.fold_left2 (match_equations alp metas) sigma eqnl1 eqnl2
+  | RIf (_,a1,(na1,to1),b1,c1), AIf (a2,(na2,to2),b2,c2) ->
+      let sigma = match_opt (match_binders alp metas na1 na2) sigma to1 to2 in
+      List.fold_left2 (match_ alp metas) sigma [a1;b1;c1] [a2;b2;c2]
+  | RLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2) 
+      when List.length nal1 = List.length nal2 ->
+      let sigma = match_opt (match_binders alp metas na1 na2) sigma to1 to2 in
+      let sigma = match_ alp metas sigma b1 b2 in
+      let (alp,sigma) =
+	List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in
+      match_ alp metas sigma c1 c2
+  | RCast(_,c1,_,t1), ACast(c2,_,t2) ->
       match_ alp metas (match_ alp metas sigma c1 c2) t1 t2
   | RSort (_,s1), ASort s2 when s1 = s2 -> sigma
   | RPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match
-  | a, AHole _ when not(Options.do_translate()) -> sigma
-  | RHole _, AHole _ -> sigma
+  | a, AHole _ -> sigma
   | (RDynamic _ | RRec _ | REvar _), _ 
   | _,_ -> raise No_match
 
@@ -423,23 +483,23 @@ and match_alist alp metas sigma l1 l2 x iter termin lassoc =
   let tl,sigma = match_alist_tail alp metas sigma [t1] rest in
   (x,encode_list_value (if lassoc then List.rev tl else tl))::sigma
 
-and match_binders alp metas sigma b1 b2 na1 na2 = match (na1,na2) with
-  | (Name id1,Name id2) when List.mem id2 metas ->
-      let sigma = bind_env alp sigma id2 (RVar (dummy_loc,id1)) in 
-      match_ alp metas sigma b1 b2
-  | (Name id1,Name id2) -> match_ ((id1,id2)::alp) metas sigma b1 b2
-  | (Anonymous,Anonymous) -> match_  alp metas sigma b1 b2
-  | _ -> raise No_match
+and match_binders alp metas na1 na2 sigma b1 b2 =
+  let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in
+  match_ alp metas sigma b1 b2
 
-and match_equations alp metas sigma (_,idl1,pat1,rhs1) (idl2,pat2,rhs2) =
-  if idl1 = idl2 & pat1 = pat2 (* Useful to reason up to alpha ?? *) then
-    match_ alp metas sigma rhs1 rhs2
-  else raise No_match
+and match_equations alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) =
+  (* patl1 and patl2 have the same length because they respectively
+     correspond to some tml1 and tml2 that have the same length *)
+  let (alp,sigma) = 
+    List.fold_left2 (match_cases_pattern metas) (alp,sigma) patl1 patl2 in
+  match_ alp metas sigma rhs1 rhs2
 
 type scope_name = string
 
+type tmp_scope_name = scope_name
+
 type interpretation = 
-    (identifier * (scope_name option * scope_name list)) list * aconstr
+    (identifier * (tmp_scope_name option * scope_name list)) list * aconstr
 
 let match_aconstr c (metas_scl,pat) =
   let subst = match_ [] (List.map fst metas_scl) [] c pat in
@@ -461,12 +521,15 @@ type explicitation = ExplByPos of int | ExplByName of identifier
 
 type proj_flag = int option (* [Some n] = proj of the n-th visible argument *)
 
+type prim_token = Numeral of Bigint.bigint | String of string
+
 type cases_pattern_expr =
   | CPatAlias of loc * cases_pattern_expr * identifier
   | CPatCstr of loc * reference * cases_pattern_expr list
   | CPatAtom of loc * reference option
+  | CPatOr of loc * cases_pattern_expr list
   | CPatNotation of loc * notation * cases_pattern_expr list
-  | CPatNumeral of loc * Bignat.bigint
+  | CPatPrim of loc * prim_token
   | CPatDelimiters of loc * string * cases_pattern_expr
 
 type constr_expr =
@@ -480,11 +543,9 @@ type constr_expr =
   | CAppExpl of loc * (proj_flag * reference) * constr_expr list
   | CApp of loc * (proj_flag * constr_expr) * 
       (constr_expr * explicitation located option) list
-  | CCases of loc * (constr_expr option * constr_expr option) *
+  | CCases of loc * constr_expr option *
       (constr_expr * (name option * constr_expr option)) list *
-      (loc * cases_pattern_expr list * constr_expr) list
-  | COrderedCase of loc * case_style * constr_expr option * constr_expr
-      * constr_expr list
+      (loc * cases_pattern_expr list list * constr_expr) list
   | CLetTuple of loc * name list * (name option * constr_expr option) *
       constr_expr * constr_expr
   | CIf of loc * constr_expr * (name option * constr_expr option)
@@ -493,14 +554,15 @@ type constr_expr =
   | CPatVar of loc * (bool * patvar)
   | CEvar of loc * existential_key
   | CSort of loc * rawsort
-  | CCast of loc * constr_expr * constr_expr
+  | CCast of loc * constr_expr * cast_type * constr_expr
   | CNotation of loc * notation * constr_expr list
-  | CNumeral of loc * Bignat.bigint
+  | CPrim of loc * prim_token
   | CDelimiters of loc * string * constr_expr
   | CDynamic of loc * Dyn.t
 
+
 and fixpoint_expr =
-    identifier * int * local_binder list * constr_expr * constr_expr
+    identifier * (int option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
 
 and local_binder =
   | LocalRawDef of name located * constr_expr
@@ -509,6 +571,11 @@ and local_binder =
 and cofixpoint_expr =
     identifier * local_binder list * constr_expr * constr_expr
 
+and recursion_order_expr = 
+  | CStructRec
+  | CWfRec of constr_expr
+  | CMeasureRec of constr_expr
+
 (***********************)
 (* For binders parsing *)
 
@@ -517,9 +584,17 @@ let rec local_binders_length = function
   | LocalRawDef _::bl -> 1 + local_binders_length bl
   | LocalRawAssum (idl,_)::bl -> List.length idl + local_binders_length bl
 
+let rec local_assums_length = function
+  | [] -> 0
+  | LocalRawDef _::bl -> local_binders_length bl
+  | LocalRawAssum (idl,_)::bl -> List.length idl + local_binders_length bl
+
 let names_of_local_assums bl =
   List.flatten (List.map (function LocalRawAssum(l,_)->l|_->[]) bl)
 
+let names_of_local_binders bl =
+  List.flatten (List.map (function LocalRawAssum(l,_)->l|LocalRawDef(l,_)->[l]) bl)
+
 (**********************************************************************)
 (* Functions on constr_expr *)
 
@@ -535,84 +610,153 @@ let constr_loc = function
   | CAppExpl (loc,_,_) -> loc
   | CApp (loc,_,_) -> loc
   | CCases (loc,_,_,_) -> loc
-  | COrderedCase (loc,_,_,_,_) -> loc
   | CLetTuple (loc,_,_,_,_) -> loc
   | CIf (loc,_,_,_,_) -> loc
   | CHole loc -> loc
   | CPatVar (loc,_) -> loc
   | CEvar (loc,_) -> loc
   | CSort (loc,_) -> loc
-  | CCast (loc,_,_) -> loc
+  | CCast (loc,_,_,_) -> loc
   | CNotation (loc,_,_) -> loc
-  | CNumeral (loc,_) -> loc
+  | CPrim (loc,_) -> loc
   | CDelimiters (loc,_,_) -> loc
   | CDynamic _ -> dummy_loc
 
-let cases_pattern_loc = function
+let cases_pattern_expr_loc = function
   | CPatAlias (loc,_,_) -> loc
   | CPatCstr (loc,_,_) -> loc
   | CPatAtom (loc,_) -> loc
+  | CPatOr (loc,_) -> loc
   | CPatNotation (loc,_,_) -> loc
-  | CPatNumeral (loc,_) -> loc
+  | CPatPrim (loc,_) -> loc
   | CPatDelimiters (loc,_,_) -> loc
 
 let occur_var_constr_ref id = function
   | Ident (loc,id') -> id = id'
   | Qualid _ -> false
 
-let rec occur_var_constr_expr id = function
-  | CRef r -> occur_var_constr_ref id r
-  | CArrow (loc,a,b) -> occur_var_constr_expr id a or occur_var_constr_expr id b
-  | CAppExpl (loc,(_,r),l) ->
-      occur_var_constr_ref id r or List.exists (occur_var_constr_expr id) l
-  | CApp (loc,(_,f),l) ->
-      occur_var_constr_expr id f or
-      List.exists (fun (a,_) -> occur_var_constr_expr id a) l
-  | CProdN (_,l,b) -> occur_var_binders id b l
-  | CLambdaN (_,l,b) -> occur_var_binders id b l
-  | CLetIn (_,na,a,b) -> occur_var_binders id b [[na],a]
-  | CCast (loc,a,b) -> occur_var_constr_expr id a or occur_var_constr_expr id b
-  | CNotation (_,_,l) -> List.exists (occur_var_constr_expr id) l
-  | CDelimiters (loc,_,a) -> occur_var_constr_expr id a
-  | CHole _ | CEvar _ | CPatVar _ | CSort _ | CNumeral _ | CDynamic _ -> false
-  | CCases (loc,_,_,_) 
-  | COrderedCase (loc,_,_,_,_) 
-  | CLetTuple (loc,_,_,_,_) 
-  | CIf (loc,_,_,_,_) 
-  | CFix (loc,_,_) 
+let ids_of_cases_indtype =
+  let add_var ids = function CRef (Ident (_,id)) -> id::ids | _ -> ids in
+  let rec vars_of = function
+    (* We deal only with the regular cases *)
+    | CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l)
+    | CNotation (_,_,l)
+    (* assume the ntn is applicative and does not instantiate the head !! *)
+    | CAppExpl (_,_,l) -> List.fold_left add_var [] l
+    | CDelimiters(_,_,c) -> vars_of c
+    | _ -> [] in
+  vars_of
+
+let ids_of_cases_tomatch tms =
+  List.fold_right
+    (fun (_,(ona,indnal)) l ->
+      option_fold_right (fun t -> (@) (ids_of_cases_indtype t))
+      indnal (option_fold_right name_cons ona l))
+    tms []
+
+let is_constructor id =
+  try ignore (Nametab.extended_locate (make_short_qualid id)); true
+  with Not_found -> true
+ 
+let rec cases_pattern_fold_names f a = function
+  | CPatAlias (_,pat,id) -> f id a
+  | CPatCstr (_,_,patl) | CPatOr (_,patl) | CPatNotation (_,_,patl) ->
+      List.fold_left (cases_pattern_fold_names f) a patl
+  | CPatDelimiters (_,_,pat) -> cases_pattern_fold_names f a pat
+  | CPatAtom (_,Some (Ident (_,id))) when not (is_constructor id) -> f id a
+  | CPatPrim _ | CPatAtom _ -> a
+
+let ids_of_pattern_list =
+  List.fold_left (List.fold_left (cases_pattern_fold_names Idset.add))
+    Idset.empty
+
+let rec fold_constr_expr_binders g f n acc b = function
+  | (nal,t)::l ->
+      let nal = snd (List.split nal) in
+      let n' = List.fold_right (name_fold g) nal n in
+      f n (fold_constr_expr_binders g f n' acc b l) t
+  | [] ->
+      f n acc b
+
+let rec fold_local_binders g f n acc b = function
+  | LocalRawAssum (nal,t)::l ->
+      let nal = snd (List.split nal) in
+      let n' = List.fold_right (name_fold g) nal n in
+      f n (fold_local_binders g f n' acc b l) t
+  | LocalRawDef ((_,na),t)::l ->
+      f n (fold_local_binders g f (name_fold g na n) acc b l) t
+  | _ ->
+      f n acc b
+
+let fold_constr_expr_with_binders g f n acc = function
+  | CArrow (loc,a,b) -> f n (f n acc a) b
+  | CAppExpl (loc,(_,_),l) -> List.fold_left (f n) acc l
+  | CApp (loc,(_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l)
+  | CProdN (_,l,b) | CLambdaN (_,l,b) -> fold_constr_expr_binders g f n acc b l
+  | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],a]
+  | CCast (loc,a,_,b) -> f n (f n acc a) b
+  | CNotation (_,_,l) -> List.fold_left (f n) acc l
+  | CDelimiters (loc,_,a) -> f n acc a
+  | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CDynamic _  | CRef _ ->
+      acc
+  | CCases (loc,rtnpo,al,bl) ->
+      let ids = ids_of_cases_tomatch al in
+      let acc = option_fold_left (f (List.fold_right g ids n)) acc rtnpo in
+      let acc = List.fold_left (f n) acc (List.map fst al) in
+      List.fold_right (fun (loc,patl,rhs) acc ->
+	let ids = ids_of_pattern_list patl in
+	f (Idset.fold g ids n) acc rhs) bl acc
+  | CLetTuple (loc,nal,(ona,po),b,c) ->
+      let n' = List.fold_right (name_fold g) nal n in
+      f (option_fold_right (name_fold g) ona n') (f n acc b) c
+  | CIf (_,c,(ona,po),b1,b2) ->
+      let acc = f n (f n (f n acc b1) b2) c in
+      option_fold_left (f (option_fold_right (name_fold g) ona n)) acc po
+  | CFix (loc,_,l) ->
+      let n' = List.fold_right (fun (id,_,_,_,_) -> g id) l n in
+      List.fold_right (fun (_,(_,o),lb,t,c) acc ->
+	fold_local_binders g f n' 
+	  (fold_local_binders g f n acc t lb) c lb) l acc
   | CCoFix (loc,_,_) -> 
-      Pp.warning "Capture check in multiple binders not done"; false
+      Pp.warning "Capture check in multiple binders not done"; acc
+
+let free_vars_of_constr_expr c = 
+  let rec aux bdvars l = function
+  | CRef (Ident (_,id)) -> if List.mem id bdvars then l else Idset.add id l
+  | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c
+  in aux [] Idset.empty c
 
-and occur_var_binders id b = function
-  | (idl,a)::l -> 
-      occur_var_constr_expr id a or
-      (not (List.mem (Name id) (snd (List.split idl)))
-      & occur_var_binders id b l)
-  | [] -> occur_var_constr_expr id b
+let occur_var_constr_expr id c = Idset.mem id (free_vars_of_constr_expr c)
 
 let mkIdentC id  = CRef (Ident (dummy_loc, id))
 let mkRefC r     = CRef r
 let mkAppC (f,l) = CApp (dummy_loc, (None,f), List.map (fun x -> (x,None)) l)
-let mkCastC (a,b)  = CCast (dummy_loc,a,b)
+let mkCastC (a,k,b)  = CCast (dummy_loc,a,k,b)
 let mkLambdaC (idl,a,b) = CLambdaN (dummy_loc,[idl,a],b)
 let mkLetInC (id,a,b)   = CLetIn (dummy_loc,id,a,b)
 let mkProdC (idl,a,b)   = CProdN (dummy_loc,[idl,a],b)
 
-(* Used in correctness and interface *)
-
+let rec abstract_constr_expr c = function
+  | [] -> c
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl)
+  | LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> mkLambdaC([x],t,b)) idl
+      (abstract_constr_expr c bl)
+      
+let rec prod_constr_expr c = function
+  | [] -> c
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl)
+  | LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> mkProdC([x],t,b)) idl
+      (prod_constr_expr c bl)
+
+let coerce_to_id = function
+  | CRef (Ident (loc,id)) -> (loc,id)
+  | a -> user_err_loc
+        (constr_loc a,"coerce_to_id",
+         str "This expression should be a simple identifier")
 
-let names_of_cases_indtype =
-  let rec vars_of ids t =
-    match t with
-      (* We deal only with the regular cases *)
-      | CApp (_,_,l) -> List.fold_left (fun ids (a,_) -> vars_of ids a) [] l
-      | CRef (Ident (_,id)) -> id::ids
-      | CNotation (_,_,l)
-      (* assume the ntn is applicative and does not instantiate the head !! *)
-      | CAppExpl (_,_,l) -> List.fold_left vars_of [] l
-      | CDelimiters(_,_,c) -> vars_of ids c
-      | _ -> ids in
-  vars_of []
+(* Used in correctness and interface *)
 
 let map_binder g e nal = List.fold_right (fun (_,na) -> name_fold g na) nal e
 
@@ -632,7 +776,7 @@ let map_local_binders f g e bl =
   let (e,rbl) = List.fold_left h (e,[]) bl in
   (e, List.rev rbl)
 
-let map_constr_expr_with_binders f g e = function
+let map_constr_expr_with_binders g f e = function
   | CArrow (loc,a,b) -> CArrow (loc,f e a,f e b)
   | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l) 
   | CApp (loc,(p,a),l) -> 
@@ -642,35 +786,24 @@ let map_constr_expr_with_binders f g e = function
   | CLambdaN (loc,bl,b) ->
       let (e,bl) = map_binders f g e bl in CLambdaN (loc,bl,f e b)
   | CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b)
-  | CCast (loc,a,b) -> CCast (loc,f e a,f e b)
+  | CCast (loc,a,k,b) -> CCast (loc,f e a,k,f e b)
   | CNotation (loc,n,l) -> CNotation (loc,n,List.map (f e) l)
   | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a)
   | CHole _ | CEvar _ | CPatVar _ | CSort _ 
-  | CNumeral _ | CDynamic _ | CRef _ as x -> x
-  | CCases (loc,(po,rtnpo),a,bl) ->
+  | CPrim _ | CDynamic _ | CRef _ as x -> x
+  | CCases (loc,rtnpo,a,bl) ->
       (* TODO: apply g on the binding variables in pat... *)
       let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in
-      let e' = 
-	List.fold_right
-	  (fun (tm,(na,indnal)) e ->
-	    option_fold_right
-	      (fun t ->
-		let ids = names_of_cases_indtype t in
-		List.fold_right g ids)
-            indnal (option_fold_right (name_fold g) na e))
-	  a e
-      in
-      CCases (loc,(option_app (f e) po, option_app (f e') rtnpo),
-         List.map (fun (tm,x) -> (f e tm,x)) a,bl)
-  | COrderedCase (loc,s,po,a,bl) ->
-      COrderedCase (loc,s,option_app (f e) po,f e a,List.map (f e) bl)
+      let ids = ids_of_cases_tomatch a in
+      let po = option_map (f (List.fold_right g ids e)) rtnpo in
+      CCases (loc, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl)
   | CLetTuple (loc,nal,(ona,po),b,c) ->
       let e' = List.fold_right (name_fold g) nal e in
       let e'' = option_fold_right (name_fold g) ona e in
-      CLetTuple (loc,nal,(ona,option_app (f e'') po),f e b,f e' c)
+      CLetTuple (loc,nal,(ona,option_map (f e'') po),f e b,f e' c)
   | CIf (loc,c,(ona,po),b1,b2) ->
       let e' = option_fold_right (name_fold g) ona e in
-      CIf (loc,f e c,(ona,option_app (f e') po),f e b1,f e b2)
+      CIf (loc,f e c,(ona,option_map (f e') po),f e b1,f e b2)
   | CFix (loc,id,dl) ->
       CFix (loc,id,List.map (fun (id,n,bl,t,d) -> 
         let (e',bl') = map_local_binders f g e bl in
@@ -691,15 +824,15 @@ let map_constr_expr_with_binders f g e = function
 let rec replace_vars_constr_expr l = function
   | CRef (Ident (loc,id)) as x ->
       (try CRef (Ident (loc,List.assoc id l)) with Not_found -> x)
-  | c -> map_constr_expr_with_binders replace_vars_constr_expr 
-      (fun id l -> List.remove_assoc id l) l c
+  | c -> map_constr_expr_with_binders List.remove_assoc 
+           replace_vars_constr_expr l c
 
 (**********************************************************************)
 (* Concrete syntax for modules and modules types *)
 
 type with_declaration_ast = 
-  | CWith_Module of identifier located * qualid located
-  | CWith_Definition of identifier located * constr_expr
+  | CWith_Module of identifier list located * qualid located
+  | CWith_Definition of identifier list located * constr_expr
 
 type module_type_ast = 
   | CMTEident of qualid located
diff --git a/interp/topconstr.mli b/interp/topconstr.mli
index 54547352..131e4170 100644
--- a/interp/topconstr.mli
+++ b/interp/topconstr.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: topconstr.mli,v 1.23.2.3 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: topconstr.mli 9226 2006-10-09 16:11:01Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -15,6 +15,7 @@ open Names
 open Libnames
 open Rawterm
 open Term
+open Mod_subst
 (*i*)
 
 (*s This is the subtype of rawconstr allowed in syntactic extensions *)
@@ -32,37 +33,60 @@ type aconstr =
   | ALambda of name * aconstr * aconstr
   | AProd of name * aconstr * aconstr
   | ALetIn of name * aconstr * aconstr
-  | ACases of aconstr option * aconstr option *
-      (aconstr * (name * (inductive * name list) option)) list *
-      (identifier list * cases_pattern list * aconstr) list
-  | AOrderedCase of case_style * aconstr option * aconstr * aconstr array
+  | ACases of aconstr option *
+      (aconstr * (name * (inductive * int * name list) option)) list *
+      (cases_pattern list * aconstr) list
   | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr
   | AIf of aconstr * (name * aconstr option) * aconstr * aconstr
   | ASort of rawsort
-  | AHole of hole_kind
+  | AHole of Evd.hole_kind
   | APatVar of patvar
-  | ACast of aconstr * aconstr
+  | ACast of aconstr * cast_type * aconstr
+
+(**********************************************************************)
+(* Translate a rawconstr into a notation given the list of variables  *)
+(* bound by the notation; also interpret recursive patterns           *) 
+
+val aconstr_of_rawconstr : identifier list -> rawconstr -> aconstr
+
+(* Name of the special identifier used to encode recursive notations  *)
+val ldots_var : identifier
+
+(* Equality of rawconstr (warning: only partially implemented) *)
+val eq_rawconstr : rawconstr -> rawconstr -> bool
+
+(**********************************************************************)
+(* Re-interpret a notation as a rawconstr, taking care of binders     *)
 
 val rawconstr_of_aconstr_with_binders : loc -> 
-  (identifier -> 'a -> identifier * 'a) ->
+  ('a -> identifier -> 'a * identifier) ->
   ('a -> aconstr -> rawconstr) -> 'a -> aconstr -> rawconstr
 
-val subst_aconstr : Names.substitution -> aconstr -> aconstr
+val rawconstr_of_aconstr : loc -> aconstr -> rawconstr
 
-val aconstr_of_rawconstr : identifier list -> rawconstr -> aconstr
+(**********************************************************************)
+(* Substitution of kernel names, avoiding a list of bound identifiers *)
+
+val subst_aconstr : substitution -> identifier list -> aconstr -> aconstr
+
+(**********************************************************************)
+(* [match_aconstr metas] matches a rawconstr against an aconstr with  *)
+(* metavariables in [metas]; raise [No_match] if the matching fails   *)
 
-(* [match_aconstr metas] match a rawconstr against an aconstr with
-   metavariables in [metas]; it raises [No_match] if the matching fails *)
 exception No_match
 
 type scope_name = string
+
+type tmp_scope_name = scope_name
+
 type interpretation = 
-    (identifier * (scope_name option * scope_name list)) list * aconstr
+    (identifier * (tmp_scope_name option * scope_name list)) list * aconstr
 
-val match_aconstr : (*i scope_name option -> i*) rawconstr -> interpretation ->
-      (rawconstr * (scope_name option * scope_name list)) list
+val match_aconstr : rawconstr -> interpretation ->
+      (rawconstr * (tmp_scope_name option * scope_name list)) list
 
-(*s Concrete syntax for terms *)
+(**********************************************************************)
+(*s Concrete syntax for terms                                         *)
 
 type notation = string
 
@@ -70,12 +94,15 @@ type explicitation = ExplByPos of int | ExplByName of identifier
 
 type proj_flag = int option (* [Some n] = proj of the n-th visible argument *)
 
+type prim_token = Numeral of Bigint.bigint | String of string
+
 type cases_pattern_expr =
   | CPatAlias of loc * cases_pattern_expr * identifier
   | CPatCstr of loc * reference * cases_pattern_expr list
   | CPatAtom of loc * reference option
+  | CPatOr of loc * cases_pattern_expr list
   | CPatNotation of loc * notation * cases_pattern_expr list
-  | CPatNumeral of loc * Bignat.bigint
+  | CPatPrim of loc * prim_token
   | CPatDelimiters of loc * string * cases_pattern_expr
 
 type constr_expr =
@@ -89,11 +116,9 @@ type constr_expr =
   | CAppExpl of loc * (proj_flag * reference) * constr_expr list
   | CApp of loc * (proj_flag * constr_expr) * 
         (constr_expr * explicitation located option) list
-  | CCases of loc * (constr_expr option * constr_expr option) *
+  | CCases of loc * constr_expr option *
       (constr_expr * (name option * constr_expr option)) list *
-      (loc * cases_pattern_expr list * constr_expr) list
-  | COrderedCase of loc * case_style * constr_expr option * constr_expr
-      * constr_expr list
+      (loc * cases_pattern_expr list list * constr_expr) list
   | CLetTuple of loc * name list * (name option * constr_expr option) *
       constr_expr * constr_expr
   | CIf of loc * constr_expr * (name option * constr_expr option)
@@ -102,63 +127,83 @@ type constr_expr =
   | CPatVar of loc * (bool * patvar)
   | CEvar of loc * existential_key
   | CSort of loc * rawsort
-  | CCast of loc * constr_expr * constr_expr
+  | CCast of loc * constr_expr * cast_type * constr_expr
   | CNotation of loc * notation * constr_expr list
-  | CNumeral of loc * Bignat.bigint
+  | CPrim of loc * prim_token
   | CDelimiters of loc * string * constr_expr
   | CDynamic of loc * Dyn.t
 
 and fixpoint_expr =
-    identifier * int * local_binder list * constr_expr * constr_expr
+    identifier * (int option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
 
 and cofixpoint_expr =
     identifier * local_binder list * constr_expr * constr_expr
 
+and recursion_order_expr = 
+  | CStructRec
+  | CWfRec of constr_expr
+  | CMeasureRec of constr_expr
+
 and local_binder =
   | LocalRawDef of name located * constr_expr
   | LocalRawAssum of name located list * constr_expr
 
+(**********************************************************************)
+(* Utilities on constr_expr                                           *)
 
 val constr_loc : constr_expr -> loc
 
-val cases_pattern_loc : cases_pattern_expr -> loc
+val cases_pattern_expr_loc : cases_pattern_expr -> loc
 
 val replace_vars_constr_expr :
   (identifier * identifier) list -> constr_expr -> constr_expr
 
+val free_vars_of_constr_expr : constr_expr -> Idset.t
 val occur_var_constr_expr : identifier -> constr_expr -> bool
 
 (* Specific function for interning "in indtype" syntax of "match" *)
-val names_of_cases_indtype : constr_expr -> identifier list
+val ids_of_cases_indtype : constr_expr -> identifier list
 
 val mkIdentC : identifier -> constr_expr
 val mkRefC : reference -> constr_expr
 val mkAppC : constr_expr * constr_expr list -> constr_expr
-val mkCastC : constr_expr * constr_expr -> constr_expr
+val mkCastC : constr_expr * cast_type * constr_expr -> constr_expr
 val mkLambdaC : name located list * constr_expr * constr_expr -> constr_expr
 val mkLetInC : name located * constr_expr * constr_expr -> constr_expr
 val mkProdC : name located list * constr_expr * constr_expr -> constr_expr
 
+val coerce_to_id : constr_expr -> identifier located
+
+val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr
+val prod_constr_expr : constr_expr -> local_binder list -> constr_expr
+
 (* For binders parsing *)
 
 (* Includes let binders *)
 val local_binders_length : local_binder list -> int
 
+(* Excludes let binders *)
+val local_assums_length : local_binder list -> int
+
 (* Does not take let binders into account *)
 val names_of_local_assums : local_binder list -> name located list
 
+(* With let binders *)
+val names_of_local_binders : local_binder list -> name located list
+
 (* Used in correctness and interface; absence of var capture not guaranteed *)
 (* in pattern-matching clauses and in binders of the form [x,y:T(x)] *)
 
 val map_constr_expr_with_binders :
-  ('a -> constr_expr -> constr_expr) ->
-      (identifier -> 'a -> 'a) -> 'a -> constr_expr -> constr_expr
+  (identifier -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) ->
+      'a -> constr_expr -> constr_expr
 
-(* Concrete syntax for modules and modules types *)
+(**********************************************************************)
+(* Concrete syntax for modules and module types                       *)
 
 type with_declaration_ast = 
-  | CWith_Module of identifier located * qualid located
-  | CWith_Definition of identifier located * constr_expr
+  | CWith_Module of identifier list located * qualid located
+  | CWith_Definition of identifier list located * constr_expr
 
 type module_type_ast = 
   | CMTEident of qualid located
@@ -167,6 +212,3 @@ type module_type_ast =
 type module_ast = 
   | CMEident of qualid located
   | CMEapply of module_ast * module_ast
-
-(* Special identifier to encode recursive notations *)
-val ldots_var : identifier
diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c
new file mode 100644
index 00000000..affcccb3
--- /dev/null
+++ b/kernel/byterun/coq_fix_code.c
@@ -0,0 +1,166 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h> 
+#include <config.h>
+#include <misc.h>
+#include <mlvalues.h>
+#include <fail.h>
+#include <memory.h>
+#include "coq_instruct.h"
+#include "coq_fix_code.h"
+
+#ifdef THREADED_CODE
+char ** coq_instr_table;
+char * coq_instr_base;
+int arity[STOP+1];
+
+void init_arity () {
+  /* instruction with zero operand */
+  arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]=
+    arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]=
+    arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]=
+    arity[PUSHACC6]=arity[PUSHACC7]=arity[ENVACC1]=arity[ENVACC2]=
+    arity[ENVACC3]=arity[ENVACC4]=arity[PUSHENVACC1]=arity[PUSHENVACC2]=
+    arity[PUSHENVACC3]=arity[PUSHENVACC4]=arity[APPLY1]=arity[APPLY2]=
+    arity[APPLY3]=arity[RESTART]=arity[OFFSETCLOSUREM2]=
+    arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE2]=arity[PUSHOFFSETCLOSUREM2]=
+    arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE2]=
+    arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]=
+    arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]=
+    arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]=
+    arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= 0;
+  /* instruction with one operand */
+  arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]=
+    arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]=
+    arity[APPTERM3]=arity[RETURN]=arity[GRAB]=arity[OFFSETCLOSURE]=
+    arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]=
+    arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]=
+    arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]=
+    arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=arity[ACCUMULATECOND]= 1;
+  /* instruction with two operands */
+  arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=2;
+  /* instruction with four operands */ 
+  arity[MAKESWITCHBLOCK]=4;
+  /* instruction with arbitrary operands */
+  arity[CLOSUREREC]=arity[CLOSURECOFIX]=arity[SWITCH]=0;
+}
+
+#endif /*  THREADED_CODE */
+
+
+void * coq_stat_alloc (asize_t sz)
+{
+  void * result = malloc (sz);
+  if (result == NULL) raise_out_of_memory ();
+  return result;
+}
+
+value coq_makeaccu (value i) {
+  code_t q;
+  code_t res = coq_stat_alloc(8);
+  q = res;
+  *q++ = VALINSTR(MAKEACCU);
+  *q = (opcode_t)Int_val(i);
+  return (value)res;
+}
+
+value coq_accucond (value i) {
+  code_t q;
+  code_t res = coq_stat_alloc(8);
+  q = res;
+  *q++ = VALINSTR(ACCUMULATECOND);
+  *q = (opcode_t)Int_val(i);
+  return (value)res;
+}
+
+value coq_pushpop (value i) {
+  code_t res;
+  int n;
+  n = Int_val(i);
+  if (n == 0) {
+    res = coq_stat_alloc(4);
+    *res = VALINSTR(STOP);
+    return (value)res;
+  }
+  else {
+    code_t q;
+    res = coq_stat_alloc(12);
+    q = res;
+    *q++ = VALINSTR(POP);
+    *q++ = (opcode_t)n;
+    *q = VALINSTR(STOP);
+    return (value)res;
+  }
+}
+
+value coq_is_accumulate_code(value code){
+  code_t q;
+  int res;
+  q = (code_t)code;
+  res = Is_instruction(q,ACCUMULATECOND) || Is_instruction(q,ACCUMULATE);
+  return Val_bool(res);
+}
+
+#ifdef ARCH_BIG_ENDIAN
+#define Reverse_32(dst,src) {                                               \
+  char * _p, * _q;							    \
+  char _a, _b;                                                              \
+  _p = (char *) (src);                                                      \
+  _q = (char *) (dst);                                                      \
+  _a = _p[0];                                                               \
+  _b = _p[1];                                                               \
+  _q[0] = _p[3];                                                            \
+  _q[1] = _p[2];                                                            \
+  _q[3] = _a;                                                               \
+  _q[2] = _b;                                                               \
+}
+#define COPY32(dst,src) Reverse_32(dst,src)
+#else
+#define COPY32(dst,src) (*dst=*src)
+#endif /* ARCH_BIG_ENDIAN */
+
+value coq_tcode_of_code (value code, value size) {
+  code_t p, q, res; 
+  asize_t len = (asize_t) Long_val(size);
+  res = coq_stat_alloc(len);
+  q = res;
+  len /= sizeof(opcode_t);
+  for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) {  
+    opcode_t instr;
+    COPY32(&instr,p); 
+    p++;
+    if (instr < 0 || instr > STOP){
+      instr = STOP;
+    };
+    *q++ = VALINSTR(instr);
+    if (instr == SWITCH) {
+      uint32 i, sizes, const_size, block_size;
+      COPY32(q,p); p++;
+      sizes=*q++;
+      const_size = sizes & 0xFFFF;
+      block_size = sizes >> 16;
+      sizes = const_size + block_size;
+      for(i=0; i<sizes; i++) { COPY32(q,p); p++; q++; };
+    } else if (instr == CLOSUREREC || instr==CLOSURECOFIX) {
+      uint32 i, n;
+      COPY32(q,p); p++; /* ndefs */
+      n = 3 + 2*(*q);  /* ndefs, nvars, start, typlbls,lbls*/
+      q++;
+      for(i=1; i<n; i++) { COPY32(q,p); p++; q++; };
+    } else {
+      uint32 i, ar;
+      ar = arity[instr]; 
+      for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; };
+    }
+  }
+  return (value)res;
+}
diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h
new file mode 100644
index 00000000..d1dac80f
--- /dev/null
+++ b/kernel/byterun/coq_fix_code.h
@@ -0,0 +1,34 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+
+#ifndef _COQ_FIX_CODE_
+#define _COQ_FIX_CODE_
+
+#include <mlvalues.h>
+void * coq_stat_alloc (asize_t sz);
+
+#ifdef THREADED_CODE
+extern char ** coq_instr_table;
+extern char * coq_instr_base;
+void init_arity();
+#define VALINSTR(instr) ((opcode_t)(coq_instr_table[instr] - coq_instr_base))
+#else
+#define VALINSTR(instr) instr
+#endif /*  THREADED_CODE */
+
+#define Is_instruction(pc,instr) (*pc == VALINSTR(instr))
+
+value coq_tcode_of_code(value code, value len);
+value coq_makeaccu (value i);
+value coq_pushpop (value i);
+value coq_accucond (value i);
+value coq_is_accumulate_code(value code);
+#endif /* _COQ_FIX_CODE_ */
diff --git a/kernel/byterun/coq_gc.h b/kernel/byterun/coq_gc.h
new file mode 100644
index 00000000..ccccbe78
--- /dev/null
+++ b/kernel/byterun/coq_gc.h
@@ -0,0 +1,48 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#ifndef _COQ_CAML_GC_
+#define _COQ_CAML_GC_
+#include <mlvalues.h>
+#include <alloc.h>
+
+typedef void (*scanning_action) (value, value *);
+
+
+CAMLextern char *young_ptr;
+CAMLextern char *young_limit;
+CAMLextern void (*scan_roots_hook) (scanning_action);
+CAMLextern void minor_collection (void);
+
+#define Caml_white (0 << 8)
+#define Caml_black (3 << 8)
+
+#define Make_header(wosize, tag, color)                                 \
+  (((header_t) (((header_t) (wosize) << 10)                             \
+		+ (color)                                               \
+		+ (tag_t) (tag)))   					\
+   )
+
+
+#define Alloc_small(result, wosize, tag) do{                            \
+  young_ptr -= Bhsize_wosize (wosize);                                  \
+  if (young_ptr < young_limit){                                         \
+    young_ptr += Bhsize_wosize (wosize);                                \
+    Setup_for_gc;                                                       \
+    minor_collection ();                                                \
+    Restore_after_gc;                                                   \
+    young_ptr -= Bhsize_wosize (wosize);                                \
+  }                                                                     \
+  Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black);        \
+  (result) = Val_hp (young_ptr);                                        \
+  }while(0) 
+
+
+#endif /*_COQ_CAML_GC_ */
diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h
new file mode 100644
index 00000000..89616c5f
--- /dev/null
+++ b/kernel/byterun/coq_instruct.h
@@ -0,0 +1,41 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#ifndef _COQ_INSTRUCT_
+#define _COQ_INSTRUCT_
+
+enum instructions {
+  ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC,
+  PUSH, 
+  PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, PUSHACC4,
+  PUSHACC5, PUSHACC6, PUSHACC7, PUSHACC, 
+  POP,
+  ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC,
+  PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC,
+  PUSH_RETADDR,
+  APPLY, APPLY1, APPLY2, APPLY3,
+  APPTERM, APPTERM1, APPTERM2, APPTERM3,
+  RETURN, RESTART, GRAB, GRABREC, 
+  CLOSURE, CLOSUREREC, CLOSURECOFIX,
+  OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE,
+  PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, PUSHOFFSETCLOSURE2, 
+  PUSHOFFSETCLOSURE,
+  GETGLOBAL, PUSHGETGLOBAL,
+  MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEBLOCK4,
+  SWITCH, PUSHFIELDS, 
+  GETFIELD0, GETFIELD1, GETFIELD, 
+  SETFIELD0, SETFIELD1, SETFIELD,
+  CONST0, CONST1, CONST2, CONST3, CONSTINT,
+  PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,
+  ACCUMULATE, ACCUMULATECOND, 
+  MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, STOP
+};
+
+#endif /* _COQ_INSTRUCT_ */
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
new file mode 100644
index 00000000..8f9c10e6
--- /dev/null
+++ b/kernel/byterun/coq_interp.c
@@ -0,0 +1,1098 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+/* The bytecode interpreter */
+
+#include <stdio.h>
+#include "coq_gc.h"
+#include "coq_instruct.h"
+#include "coq_fix_code.h"
+#include "coq_memory.h"  
+#include "coq_values.h"
+
+
+/* Registers for the abstract machine:
+        pc         the code pointer
+        sp         the stack pointer (grows downward)
+        accu       the accumulator
+        env        heap-allocated environment
+        trapsp     pointer to the current trap frame
+        extra_args number of extra arguments provided by the caller
+
+sp is a local copy of the global variable extern_sp. */
+
+
+
+/* Instruction decoding */
+
+
+#ifdef THREADED_CODE
+#  define Instruct(name) coq_lbl_##name: 
+#  if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+#    define coq_Jumptbl_base ((char *) &&coq_lbl_ACC0)
+#  else
+#    define coq_Jumptbl_base ((char *) 0)
+#    define coq_jumptbl_base ((char *) 0)
+#  endif
+#  ifdef DEBUG
+#    define Next goto next_instr
+#  else
+#    define Next goto *(void *)(coq_jumptbl_base + *pc++)  
+#  endif
+#else 
+#  define Instruct(name) case name:
+#  define Next break
+#endif 
+
+/* #define _COQ_DEBUG_ */
+
+#ifdef _COQ_DEBUG_ 
+#   define print_instr(s) /*if (drawinstr)*/ printf("%s\n",s)
+#   define print_int(i)   /*if (drawinstr)*/ printf("%d\n",i)
+# else 
+#   define print_instr(s) 
+#   define print_int(i) 
+#endif
+
+/* Wrapper pour caml_modify */
+#ifdef OCAML_307
+#define CAML_MODIFY(a,b) modify(a,b)
+#else
+#define CAML_MODIFY(a,b) caml_modify(a,b)
+#endif
+
+/* GC interface */
+#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; }
+#define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; }
+
+
+/* Register optimization.
+   Some compilers underestimate the use of the local variables representing
+   the abstract machine registers, and don't put them in hardware registers,
+   which slows down the interpreter considerably.
+   For GCC, Xavier Leroy have hand-assigned hardware registers for 
+   several architectures.
+*/
+
+#if defined(__GNUC__) && !defined(DEBUG)
+#ifdef __mips__
+#define PC_REG asm("$16")
+#define SP_REG asm("$17")
+#define ACCU_REG asm("$18")
+#endif
+#ifdef __sparc__
+#define PC_REG asm("%l0")
+#define SP_REG asm("%l1")
+#define ACCU_REG asm("%l2")
+#endif
+#ifdef __alpha__
+#ifdef __CRAY__
+#define PC_REG asm("r9")
+#define SP_REG asm("r10")
+#define ACCU_REG asm("r11")
+#define JUMPTBL_BASE_REG asm("r12")
+#else
+#define PC_REG asm("$9")
+#define SP_REG asm("$10")
+#define ACCU_REG asm("$11")
+#define JUMPTBL_BASE_REG asm("$12")
+#endif
+#endif
+#ifdef __i386__
+#define PC_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define ACCU_REG
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define PC_REG asm("26")
+#define SP_REG asm("27")
+#define ACCU_REG asm("28")
+#endif
+#ifdef __hppa__
+#define PC_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define ACCU_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define PC_REG asm("a5")
+#define SP_REG asm("a4")
+#define ACCU_REG asm("d7")
+#endif
+#ifdef __arm__
+#define PC_REG asm("r9")
+#define SP_REG asm("r8")
+#define ACCU_REG asm("r7")
+#endif
+#ifdef __ia64__
+#define PC_REG asm("36")
+#define SP_REG asm("37")
+#define ACCU_REG asm("38")
+#define JUMPTBL_BASE_REG asm("39")
+#endif
+#endif
+
+/* The interpreter itself */
+
+value coq_interprete
+(code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args)
+{
+  /*Declaration des variables */
+#ifdef PC_REG
+  register code_t pc PC_REG;
+  register value * sp SP_REG;
+  register value accu ACCU_REG;
+#else
+  register code_t pc;
+  register value * sp;
+  register value accu;
+#endif
+#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+#ifdef JUMPTBL_BASE_REG
+  register char * coq_jumptbl_base JUMPTBL_BASE_REG;
+#else
+  register char * coq_jumptbl_base;
+#endif
+#endif
+#ifdef THREADED_CODE
+  static void * coq_jumptable[] = {
+#    include "coq_jumptbl.h"
+  };
+#else 
+  opcode_t curr_instr;
+#endif
+  print_instr("Enter Interpreter");
+  if (coq_pc == NULL) {           /* Interpreter is initializing */
+    print_instr("Interpreter is initializing");
+#ifdef THREADED_CODE
+    coq_instr_table = (char **) coq_jumptable;
+    coq_instr_base = coq_Jumptbl_base;
+#endif
+    return Val_unit;
+  }
+#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
+  coq_jumptbl_base = coq_Jumptbl_base;
+#endif
+
+  /* Initialisation */
+  sp = coq_sp;
+  pc = coq_pc;
+  accu = coq_accu;
+#ifdef THREADED_CODE
+  goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */
+#else
+  while(1) {
+    curr_instr = *pc++;
+    switch(curr_instr) {
+#endif
+/* Basic stack operations */
+      
+      Instruct(ACC0){
+	print_instr("ACC0");
+	accu = sp[0]; Next;
+      }
+      Instruct(ACC1){
+	print_instr("ACC1");
+	accu = sp[1]; Next;
+      }
+      Instruct(ACC2){
+	print_instr("ACC2");
+	accu = sp[2]; Next;
+      }
+      Instruct(ACC3){
+	print_instr("ACC3");
+	accu = sp[3]; Next;
+      }
+      Instruct(ACC4){
+	print_instr("ACC4");
+	accu = sp[4]; Next;
+      }
+      Instruct(ACC5){
+	print_instr("ACC5");
+	accu = sp[5]; Next;
+      }
+      Instruct(ACC6){
+	print_instr("ACC6");
+	accu = sp[6]; Next;
+      }
+      Instruct(ACC7){
+	print_instr("ACC7");
+        accu = sp[7]; Next;
+      }      
+      Instruct(PUSH){
+	print_instr("PUSH");
+	*--sp = accu; Next;
+      }
+      Instruct(PUSHACC0) {
+	print_instr("PUSHACC0");
+        *--sp = accu; Next;
+      }
+      Instruct(PUSHACC1){
+	print_instr("PUSHACC1");
+        *--sp = accu; accu = sp[1]; Next;
+      }
+      Instruct(PUSHACC2){
+	print_instr("PUSHACC2");
+        *--sp = accu; accu = sp[2]; Next;
+      }
+      Instruct(PUSHACC3){
+	print_instr("PUSHACC3");
+	*--sp = accu; accu = sp[3]; Next;
+      }
+      Instruct(PUSHACC4){
+	print_instr("PUSHACC4");
+	*--sp = accu; accu = sp[4]; Next;
+      }
+      Instruct(PUSHACC5){
+	print_instr("PUSHACC5");
+	*--sp = accu; accu = sp[5]; Next;
+      }
+      Instruct(PUSHACC6){
+	print_instr("PUSHACC5");
+	*--sp = accu; accu = sp[6]; Next;
+      }
+      Instruct(PUSHACC7){
+	print_instr("PUSHACC7");
+	*--sp = accu; accu = sp[7]; Next;
+      }
+      Instruct(PUSHACC){
+	print_instr("PUSHACC");
+	*--sp = accu;
+      }
+      /* Fallthrough */
+      
+      Instruct(ACC){
+	print_instr("ACC");
+	accu = sp[*pc++];
+        Next;
+      }
+      
+      Instruct(POP){
+	print_instr("POP");
+	sp += *pc++;
+	Next;
+      }
+      /* Access in heap-allocated environment */
+      
+      Instruct(ENVACC1){
+	print_instr("ENVACC1");
+	accu = Field(coq_env, 1); Next;
+      }
+      Instruct(ENVACC2){
+	print_instr("ENVACC2");
+	accu = Field(coq_env, 2); Next;
+      }
+      Instruct(ENVACC3){
+	print_instr("ENVACC3");
+	accu = Field(coq_env, 3); Next;
+      }
+      Instruct(ENVACC4){
+	print_instr("ENVACC4");
+	accu = Field(coq_env, 4); Next;
+      }
+      Instruct(PUSHENVACC1){
+	print_instr("PUSHENVACC1");
+	*--sp = accu; accu = Field(coq_env, 1); Next;
+      }
+      Instruct(PUSHENVACC2){
+	print_instr("PUSHENVACC2");
+	*--sp = accu; accu = Field(coq_env, 2); Next;
+      }
+      Instruct(PUSHENVACC3){
+	print_instr("PUSHENVACC3");
+	*--sp = accu; accu = Field(coq_env, 3); Next;
+      }
+      Instruct(PUSHENVACC4){
+	print_instr("PUSHENVACC4");
+	*--sp = accu; accu = Field(coq_env, 4); Next;
+      }
+      Instruct(PUSHENVACC){
+	print_instr("PUSHENVACC");
+	*--sp = accu;
+      }
+      /* Fallthrough */
+      Instruct(ENVACC){
+	print_instr("ENVACC");
+	accu = Field(coq_env, *pc++);
+        Next;
+      }
+      /* Function application */
+      
+      Instruct(PUSH_RETADDR) {
+	print_instr("PUSH_RETADDR");
+	sp -= 3;
+	sp[0] = (value) (pc + *pc);
+	sp[1] = coq_env;
+	sp[2] = Val_long(coq_extra_args);
+	coq_extra_args = 0;
+	pc++;
+	Next;
+      }
+      Instruct(APPLY) {
+	print_instr("APPLY");
+	coq_extra_args = *pc - 1;
+	pc = Code_val(accu);
+	coq_env = accu;
+	goto check_stacks;
+      }
+      Instruct(APPLY1) {
+	value arg1 = sp[0];
+	print_instr("APPLY1");
+	sp -= 3;
+	sp[0] = arg1;
+	sp[1] = (value)pc;
+	sp[2] = coq_env;
+	sp[3] = Val_long(coq_extra_args);
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args = 0;
+	goto check_stacks;
+      }
+      Instruct(APPLY2) {
+	value arg1 = sp[0];
+	value arg2 = sp[1];
+	print_instr("APPLY2");
+	sp -= 3;
+	sp[0] = arg1;
+	sp[1] = arg2;
+	sp[2] = (value)pc;
+	sp[3] = coq_env;
+	sp[4] = Val_long(coq_extra_args);
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args = 1;
+	goto check_stacks;
+      }
+      Instruct(APPLY3) {
+	value arg1 = sp[0];
+	value arg2 = sp[1];
+	value arg3 = sp[2];
+	print_instr("APPLY3");
+	sp -= 3;
+	sp[0] = arg1;
+	sp[1] = arg2;
+	sp[2] = arg3;
+	sp[3] = (value)pc;
+	sp[4] = coq_env;
+	sp[5] = Val_long(coq_extra_args);
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args = 2;
+	goto check_stacks;
+      }
+      /* Stack checks */
+      
+    check_stacks:
+      print_instr("check_stacks");
+      if (sp < coq_stack_threshold) {
+	coq_sp = sp;
+	realloc_coq_stack(Coq_stack_threshold);
+	sp = coq_sp;
+      }
+      Next;
+      /* Fall through CHECK_SIGNALS */
+
+      Instruct(APPTERM) {
+	int nargs = *pc++;
+	int slotsize = *pc;
+	value * newsp;
+	int i;
+	print_instr("APPTERM");
+	/* Slide the nargs bottom words of the current frame to the top
+	   of the frame, and discard the remainder of the frame */
+	newsp = sp + slotsize - nargs;
+	for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i];
+	sp = newsp;
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args += nargs - 1;
+	goto check_stacks;
+      }
+      Instruct(APPTERM1) {
+	value arg1 = sp[0];
+	print_instr("APPTERM1");
+	sp = sp + *pc - 1;
+	sp[0] = arg1;
+	pc = Code_val(accu);
+	coq_env = accu;
+	goto check_stacks;
+      }
+      Instruct(APPTERM2) {
+	value arg1 = sp[0];
+	value arg2 = sp[1];
+	print_instr("APPTERM2");
+	sp = sp + *pc - 2;
+	sp[0] = arg1;
+	sp[1] = arg2;
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args += 1;
+	goto check_stacks;
+      }
+      Instruct(APPTERM3) {
+	value arg1 = sp[0];
+	value arg2 = sp[1];
+	value arg3 = sp[2];
+	print_instr("APPTERM3");
+	sp = sp + *pc - 3;
+	sp[0] = arg1;
+	sp[1] = arg2;
+	sp[2] = arg3;
+	pc = Code_val(accu);
+	coq_env = accu;
+	coq_extra_args += 2;
+	goto check_stacks;
+      }
+      
+      Instruct(RETURN) {
+	print_instr("RETURN");
+	print_int(*pc);
+	sp += *pc++;
+	if (coq_extra_args > 0) {
+	  coq_extra_args--;
+	  pc = Code_val(accu);
+	  coq_env = accu;
+	} else {
+	  pc = (code_t)(sp[0]);
+	  coq_env = sp[1];
+	  coq_extra_args = Long_val(sp[2]);
+	  sp += 3;
+	}
+	Next;
+      }
+      
+      Instruct(RESTART) {
+	int num_args = Wosize_val(coq_env) - 2;
+	int i;
+	print_instr("RESTART");
+	sp -= num_args;
+	for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2);
+	coq_env = Field(coq_env, 1);
+	coq_extra_args += num_args;
+	Next;
+      }
+      
+      Instruct(GRAB) {
+	int required = *pc++;
+	print_instr("GRAB");
+	/*	printf("GRAB %d\n",required); */
+	if (coq_extra_args >= required) {
+	  coq_extra_args -= required;
+	} else {
+	  mlsize_t num_args, i;
+	  num_args = 1 + coq_extra_args; /* arg1 + extra args */
+          Alloc_small(accu, num_args + 2, Closure_tag); 
+	  Field(accu, 1) = coq_env;
+	  for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
+	  Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */
+	  sp += num_args;
+	  pc = (code_t)(sp[0]);
+	  coq_env = sp[1];
+	  coq_extra_args = Long_val(sp[2]);
+	  sp += 3;
+	}
+	Next;
+      }
+
+      Instruct(GRABREC) { 
+	int rec_pos = *pc++; /* commence a zero */
+	print_instr("GRABREC");
+	if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) {
+	  pc++;/* On saute le Restart */
+	} else {
+	  if (coq_extra_args < rec_pos) {
+	    mlsize_t num_args, i;
+	    num_args = 1 + coq_extra_args; /* arg1 + extra args */
+	    Alloc_small(accu, num_args + 2, Closure_tag); 
+	    Field(accu, 1) = coq_env;
+	    for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i];
+	    Code_val(accu) = pc - 3; 
+	    sp += num_args;
+	    pc = (code_t)(sp[0]);
+	    coq_env = sp[1];
+	    coq_extra_args = Long_val(sp[2]);
+	    sp += 3;
+	  } else {
+	    /* L'argument recursif est un accumulateur */
+	    mlsize_t num_args, i;
+	    /* Construction du PF partiellement appliqué */ 
+	    Alloc_small(accu, rec_pos + 2, Closure_tag); 
+	    Field(accu, 1) = coq_env;
+	    for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i];
+	    Code_val(accu) = pc;
+	    sp += rec_pos;
+	    *--sp = accu;
+	      /* Construction de l'atom */
+	    Alloc_small(accu, 2, ATOM_FIX_TAG);
+	    Field(accu,1) = sp[0];
+	    Field(accu,0)  = sp[1];
+	    sp++; sp[0] = accu;
+	      /* Construction de l'accumulateur */
+	    num_args = coq_extra_args - rec_pos;
+	    Alloc_small(accu, 2+num_args, Accu_tag);
+	    Code_val(accu) = accumulate;
+	    Field(accu,1) = sp[0]; sp++;
+	    for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i];
+	    sp += num_args;
+	    pc = (code_t)(sp[0]);
+	    coq_env = sp[1];
+	    coq_extra_args = Long_val(sp[2]);
+	    sp += 3;
+	  }
+	}
+	Next;
+      }
+	
+      Instruct(CLOSURE) {
+	int nvars = *pc++;
+	int i;
+	print_instr("CLOSURE");
+	print_int(nvars);
+	if (nvars > 0) *--sp = accu;
+	Alloc_small(accu, 1 + nvars, Closure_tag);
+	Code_val(accu) = pc + *pc;
+	pc++;
+	for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i];
+	sp += nvars;
+	Next;
+      }
+
+      Instruct(CLOSUREREC) {
+	int nfuncs = *pc++;
+	int nvars = *pc++;
+	int start = *pc++;
+	int i;
+	value * p;
+	print_instr("CLOSUREREC");
+	if (nvars > 0) *--sp = accu;
+	/* construction du vecteur de type */
+	Alloc_small(accu, nfuncs, 0);
+	for(i = 0; i < nfuncs; i++) {
+	  Field(accu,i) = (value)(pc+pc[i]);
+	}
+	pc += nfuncs;
+	*--sp=accu;
+	Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag);
+	Field(accu, nfuncs * 2 + nvars - 1) = *sp++;
+	/* On remplie la partie pour les variables libres */
+	p = &Field(accu, nfuncs * 2 - 1);
+	for (i = 0; i < nvars; i++) {
+	  *p++ = *sp++;
+	}
+	p = &Field(accu, 0);
+	*p = (value) (pc + pc[0]);
+	p++;
+	for (i = 1; i < nfuncs; i++) {
+	  *p = Make_header(i * 2, Infix_tag, Caml_white);
+	  p++;                                /* color irrelevant. */
+	  *p = (value) (pc + pc[i]);
+	  p++;
+	}
+	pc += nfuncs;
+	accu = accu + 2 * start * sizeof(value);
+	Next;
+      }
+
+      Instruct(CLOSURECOFIX){ 
+	int nfunc = *pc++;
+	int nvars = *pc++;
+	int start = *pc++;
+	int i, j , size;
+	value * p;
+	print_instr("CLOSURECOFIX");
+	if (nvars > 0) *--sp = accu;
+	/* construction du vecteur de type */
+	Alloc_small(accu, nfunc, 0);
+	for(i = 0; i < nfunc; i++) {
+	  Field(accu,i) = (value)(pc+pc[i]);
+	}
+	pc += nfunc;
+	*--sp=accu;
+
+        /* Creation des blocks accumulate */
+        for(i=0; i < nfunc; i++) {
+	  Alloc_small(accu, 2, Accu_tag);
+	  Code_val(accu) = accumulate;
+	  Field(accu,1) = Val_int(1);
+	  *--sp=accu;
+	}
+	/* creation des fonction cofix */
+
+        p = sp;
+	size = nfunc + nvars + 2;
+	for (i=0; i < nfunc; i++) {
+
+	  Alloc_small(accu, size, Closure_tag);
+	  Code_val(accu) = pc+pc[i];
+	  for (j = 0; j < nfunc; j++) Field(accu, j+1) = p[j];
+	  Field(accu, size - 1) = p[nfunc];
+	  for (j = nfunc+1; j <= nfunc+nvars; j++) Field(accu, j) = p[j];
+	  *--sp = accu;
+          /* creation du block contenant le cofix */
+
+	  Alloc_small(accu,1, ATOM_COFIX_TAG);
+	  Field(accu, 0) = sp[0];
+	  *sp = accu;
+	  /* mise a jour du block accumulate */
+	  CAML_MODIFY(&Field(p[i], 1),*sp);
+	  sp++;
+	}
+	pc += nfunc;
+	accu = p[start];
+        sp = p + nfunc + 1 + nvars;
+	print_instr("ici4");
+	Next;
+      }
+
+    
+      Instruct(PUSHOFFSETCLOSURE) {
+	print_instr("PUSHOFFSETCLOSURE");
+	*--sp = accu;
+      } /* fallthrough */
+      Instruct(OFFSETCLOSURE) {
+	print_instr("OFFSETCLOSURE");
+	accu = coq_env + *pc++ * sizeof(value); Next;
+      }
+      Instruct(PUSHOFFSETCLOSUREM2) {
+	print_instr("PUSHOFFSETCLOSUREM2");
+	*--sp = accu;
+      } /* fallthrough */
+      Instruct(OFFSETCLOSUREM2) {
+	print_instr("OFFSETCLOSUREM2");
+	accu = coq_env - 2 * sizeof(value); Next;
+      }
+      Instruct(PUSHOFFSETCLOSURE0) {
+	print_instr("PUSHOFFSETCLOSURE0");
+	*--sp = accu; 
+      }/* fallthrough */
+      Instruct(OFFSETCLOSURE0) {
+	print_instr("OFFSETCLOSURE0");
+	accu = coq_env; Next;
+      }
+      Instruct(PUSHOFFSETCLOSURE2){
+	print_instr("PUSHOFFSETCLOSURE2");
+	*--sp = accu; /* fallthrough */
+      }
+      Instruct(OFFSETCLOSURE2) {
+	print_instr("OFFSETCLOSURE2");
+	accu = coq_env + 2 * sizeof(value); Next;
+      }
+
+/* Access to global variables */
+
+      Instruct(PUSHGETGLOBAL) {
+	print_instr("PUSH");
+	*--sp = accu;
+      }
+      /* Fallthrough */
+      Instruct(GETGLOBAL){
+	print_instr("GETGLOBAL");
+	accu = Field(coq_global_data, *pc);
+        pc++;
+        Next;
+      }    
+
+/* Allocation of blocks */
+
+      Instruct(MAKEBLOCK) {
+	mlsize_t wosize = *pc++;
+	tag_t tag = *pc++;
+	mlsize_t i;
+	value block;
+	print_instr("MAKEBLOCK");
+	Alloc_small(block, wosize, tag);
+	Field(block, 0) = accu;
+	for (i = 1; i < wosize; i++) Field(block, i) = *sp++;
+	accu = block;
+	Next;
+      }
+      Instruct(MAKEBLOCK1) {
+	
+	tag_t tag = *pc++;
+	value block;
+	print_instr("MAKEBLOCK1");
+	Alloc_small(block, 1, tag);
+	Field(block, 0) = accu;
+	accu = block;
+	Next;
+      }
+      Instruct(MAKEBLOCK2) {
+	
+	tag_t tag = *pc++;
+	value block;
+	print_instr("MAKEBLOCK2");
+	Alloc_small(block, 2, tag);
+	Field(block, 0) = accu;
+	Field(block, 1) = sp[0];
+	sp += 1;
+	accu = block;
+	Next;
+      }
+      Instruct(MAKEBLOCK3) {
+	tag_t tag = *pc++;
+	value block;
+	print_instr("MAKEBLOCK3");
+	Alloc_small(block, 3, tag);
+	Field(block, 0) = accu;
+	Field(block, 1) = sp[0];
+	Field(block, 2) = sp[1];
+	sp += 2;
+	accu = block;
+	Next;
+      }
+      Instruct(MAKEBLOCK4) {
+	tag_t tag = *pc++;
+	value block;
+	print_instr("MAKEBLOCK4");
+	Alloc_small(block, 4, tag);
+	Field(block, 0) = accu;
+	Field(block, 1) = sp[0];
+	Field(block, 2) = sp[1];
+	Field(block, 3) = sp[2];
+	sp += 3;
+	accu = block;
+	Next;
+      }
+
+  
+/* Access to components of blocks */
+        
+      Instruct(SWITCH) {
+	uint32 sizes = *pc++;
+	print_instr("SWITCH");
+	print_int(sizes & 0xFFFF);
+	if (Is_block(accu)) {
+	  long index = Tag_val(accu);
+	  print_instr("block");
+	  print_int(index);
+	  pc += pc[(sizes & 0xFFFF) + index];
+	} else {
+	  long index = Long_val(accu);
+	  print_instr("constant");
+	  print_int(index);
+	  pc += pc[index];
+	}
+	  Next;
+      }
+
+      Instruct(PUSHFIELDS){
+	int i;
+	int size = *pc++;
+	print_instr("PUSHFIELDS");
+	sp -= size;
+	for(i=0;i<size;i++)sp[i] = Field(accu,i);
+	Next;
+      }
+      
+      Instruct(GETFIELD0){
+	print_instr("GETFIELD0");
+	accu = Field(accu, 0); 
+	Next;
+      }
+
+      Instruct(GETFIELD1){
+	print_instr("GETFIELD1");
+	accu = Field(accu, 1);
+	Next;
+      }
+
+      Instruct(GETFIELD){
+	print_instr("GETFIELD");
+	accu = Field(accu, *pc); 
+	pc++; 
+	Next;
+      }
+      
+      Instruct(SETFIELD0){
+	print_instr("SETFIELD0");
+	CAML_MODIFY(&Field(accu, 0),*sp);
+	sp++;
+	Next;
+      }
+	
+      Instruct(SETFIELD1){
+        int i, j, size, size_aux;
+	print_instr("SETFIELD1");
+	CAML_MODIFY(&Field(accu, 1),*sp);
+       	sp++;
+	Next; 
+      }
+  
+      /* *sp = accu;
+	* Netoyage des cofix *
+        size = Wosize_val(accu);
+        for (i = 2; i < size; i++) {
+ 	  accu = Field(*sp, i);
+          if (IS_EVALUATED_COFIX(accu)) {
+            size_aux = Wosize_val(accu);
+            *--sp = accu;
+	    Alloc_small(accu, size_aux, Accu_tag);
+	    for(j = 0; j < size_aux; j++) Field(accu, j) = Field(*sp, j);
+	    *sp = accu;
+	    Alloc_small(accu, 1, ATOM_COFIX_TAG);
+	    Field(accu, 0) = Field(Field(*sp, 1), 0);
+	    CAML_MODIFY(&Field(*sp, 1), accu);
+	    accu = *sp; sp++;
+            CAML_MODIFY(&Field(*sp, i), accu);
+	  }
+	}
+	sp++;
+	Next; 
+	} */
+      
+      Instruct(SETFIELD){
+	print_instr("SETFIELD");
+	CAML_MODIFY(&Field(accu, *pc),*sp);
+	sp++; pc++;
+	Next;
+      }	
+   
+/* Integer constants */
+
+      Instruct(CONST0){
+	print_instr("CONST0");
+	accu = Val_int(0); Next;}
+      Instruct(CONST1){
+	print_instr("CONST1");
+	accu = Val_int(1); Next;}
+      Instruct(CONST2){
+	print_instr("CONST2");
+	accu = Val_int(2); Next;}
+      Instruct(CONST3){
+	print_instr("CONST3");
+	accu = Val_int(3); Next;}
+      
+      Instruct(PUSHCONST0){
+	print_instr("PUSHCONST0");
+	*--sp = accu; accu = Val_int(0); Next;
+      }
+      Instruct(PUSHCONST1){
+	print_instr("PUSHCONST1");
+	*--sp = accu; accu = Val_int(1); Next;
+      }
+      Instruct(PUSHCONST2){
+	print_instr("PUSHCONST2");
+	*--sp = accu; accu = Val_int(2); Next;
+      }
+      Instruct(PUSHCONST3){
+	print_instr("PUSHCONST3");
+	*--sp = accu; accu = Val_int(3); Next;
+      }
+
+      Instruct(PUSHCONSTINT){
+	print_instr("PUSHCONSTINT");
+	*--sp = accu;
+      }
+      /* Fallthrough */
+      Instruct(CONSTINT) {
+	print_instr("CONSTINT");
+	accu = Val_int(*pc);
+	pc++;
+	Next;
+      }
+
+      /* Special operations for reduction of open term */
+      Instruct(ACCUMULATECOND) {
+	int i, num;
+	print_instr("ACCUMULATECOND");
+	num = *pc;
+	pc++;
+	if (Field(coq_global_boxed, num) == Val_false || coq_all_transp) {
+	  /*	  printf ("false\n");
+		  printf ("tag = %d", Tag_val(Field(accu,1))); */
+	  num = Wosize_val(coq_env);
+	  for(i = 2; i < num; i++) *--sp = Field(accu,i);
+	  coq_extra_args = coq_extra_args + (num - 2);
+	  coq_env = Field(Field(accu,1),1);
+	  pc = Code_val(coq_env);
+	  accu = coq_env;
+	  /*	  printf ("end\n"); */
+	  Next;
+	};
+	/*	printf ("true\n"); */
+      }
+      
+      Instruct(ACCUMULATE) {
+	mlsize_t i, size;
+	print_instr("ACCUMULATE");
+	size = Wosize_val(coq_env);
+	Alloc_small(accu, size + coq_extra_args + 1, Accu_tag);
+	for(i = 0; i < size; i++) Field(accu, i) = Field(coq_env, i);
+	for(i = size; i <= coq_extra_args + size; i++) 
+	  Field(accu, i) = *sp++;
+	pc = (code_t)(sp[0]);
+	coq_env = sp[1];
+	coq_extra_args = Long_val(sp[2]);
+	sp += 3;
+	Next;
+      }  
+      Instruct(MAKESWITCHBLOCK) {
+	print_instr("MAKESWITCHBLOCK");
+	*--sp = accu;
+	accu = Field(accu,1);
+	switch (Tag_val(accu)) {
+	case ATOM_COFIX_TAG: 
+	  {
+	    mlsize_t i, nargs;
+	    print_instr("COFIX_TAG");
+	    sp-=2;
+	    pc++;
+	    sp[0] = (value) (pc + *pc);
+	    sp[1] = coq_env;
+	    coq_env = Field(accu,0);
+	    accu = sp[2];
+	    sp[2] = Val_long(coq_extra_args);
+	    nargs = Wosize_val(accu) - 2;
+	    sp -= nargs;
+	    for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2);
+	    *--sp = accu;
+	    print_int(nargs);
+	    coq_extra_args = nargs;
+	    pc = Code_val(coq_env);
+	    goto check_stacks;
+	  }
+	case ATOM_COFIXEVALUATED_TAG: 
+	  {
+	    print_instr("COFIX_EVAL_TAG");
+	    accu = Field(accu,1);
+	    pc++;
+	    pc = pc + *pc;
+	    sp++;
+	    Next;
+	  }
+	default: 
+	  {  
+	    mlsize_t sz;
+	    int i, annot;
+	    code_t typlbl,swlbl;
+	    print_instr("MAKESWITCHBLOCK");
+	    
+	    typlbl = (code_t)pc + *pc; 
+	    pc++;
+	    swlbl = (code_t)pc + *pc; 
+	    pc++;
+	    annot = *pc++;
+	    sz = *pc++;
+	    *--sp=Field(coq_global_data, annot);
+	    /* On sauve la pile */
+	    if (sz == 0) accu = Atom(0);
+	    else {
+	      Alloc_small(accu, sz, Default_tag);
+	      if (Field(*sp, 2) == Val_true) {
+		for (i = 0; i < sz; i++) Field(accu, i) = sp[i+2];
+	      }else{
+		for (i = 0; i < sz; i++) Field(accu, i) = sp[i+5];
+	      }
+	    }
+	    *--sp = accu;
+	    /* On cree le zipper switch */
+	    Alloc_small(accu, 5, Default_tag);
+	    Field(accu, 0) =  (value)typlbl; Field(accu, 1) = (value)swlbl; 
+	    Field(accu, 2) = sp[1]; Field(accu, 3) = sp[0]; 
+	    Field(accu, 4) = coq_env;
+	    sp++;sp[0] = accu;
+	    /* On cree l'atome */
+	    Alloc_small(accu, 2, ATOM_SWITCH_TAG);
+	    Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0];
+	    sp++;sp[0] = accu;
+	    /* On cree l'accumulateur */
+	    Alloc_small(accu, 2, Accu_tag);
+	    Code_val(accu) = accumulate; 
+	    Field(accu,1) = *sp++;
+	  }
+	}
+	Next;
+      }
+
+	
+         
+      Instruct(MAKEACCU) {
+	int i;
+	print_instr("MAKEACCU");
+	Alloc_small(accu, coq_extra_args + 3, Accu_tag);
+	Code_val(accu) = accumulate;
+	Field(accu,1) = Field(coq_atom_tbl, *pc);
+	for(i = 2; i < coq_extra_args + 3; i++) Field(accu, i) = *sp++;
+	pc = (code_t)(sp[0]);
+	coq_env = sp[1];
+	coq_extra_args = Long_val(sp[2]);
+	sp += 3;
+	Next;
+      }
+     
+      Instruct(MAKEPROD) {
+	print_instr("MAKEPROD");
+	*--sp=accu;
+	Alloc_small(accu,2,0);
+	Field(accu, 0) = sp[0];
+	Field(accu, 1) = sp[1];
+	sp += 2;
+	Next;
+      }
+      
+/* Debugging and machine control */
+
+      Instruct(STOP){
+	print_instr("STOP");
+	coq_sp = sp;
+	return accu;
+      }
+      
+  
+#ifndef THREADED_CODE
+    default:
+      /*fprintf(stderr, "%d\n", *pc);*/
+      failwith("Coq VM: Fatal error: bad opcode");
+    }
+  }
+#endif
+}
+
+value coq_push_ra(value tcode) { 
+  print_instr("push_ra");
+  coq_sp -= 3;
+  coq_sp[0] = (value) tcode;
+  coq_sp[1] = Val_unit;
+  coq_sp[2] = Val_long(0);
+  return Val_unit;
+}
+
+value coq_push_val(value v) {
+  print_instr("push_val");
+  *--coq_sp = v;
+  return Val_unit;
+}
+
+value coq_push_arguments(value args) {
+  int nargs,i;
+  nargs = Wosize_val(args) - 2;
+  coq_sp -= nargs;
+  print_instr("push_args");print_int(nargs);
+  for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2);
+  return Val_unit;
+}
+
+value coq_push_vstack(value stk) {
+  int len,i;
+  len = Wosize_val(stk);
+  coq_sp -= len;
+  print_instr("push_vstack");print_int(len);
+   for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i);
+  return Val_unit;
+}
+
+value  coq_interprete_ml(value tcode, value a, value e, value ea) {
+  print_instr("coq_interprete");
+  return coq_interprete((code_t)tcode, a, e, Long_val(ea));
+   print_instr("end coq_interprete");
+}
+
+value coq_eval_tcode (value tcode, value e) {
+  return coq_interprete_ml(tcode, Val_unit, e, 0);
+}
diff --git a/kernel/byterun/coq_interp.h b/kernel/byterun/coq_interp.h
new file mode 100644
index 00000000..60865c32
--- /dev/null
+++ b/kernel/byterun/coq_interp.h
@@ -0,0 +1,27 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+
+value coq_push_ra(value tcode);
+
+value coq_push_val(value v);
+
+value coq_push_arguments(value args);
+
+value coq_push_vstack(value stk);
+
+value  coq_interprete_ml(value tcode, value a, value e, value ea);
+
+value coq_interprete
+    (code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args);
+
+value coq_eval_tcode (value tcode, value e);
+
+
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
new file mode 100644
index 00000000..91342108
--- /dev/null
+++ b/kernel/byterun/coq_memory.c
@@ -0,0 +1,267 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#include <stdio.h>
+#include <string.h> 
+#include "coq_gc.h"
+#include "coq_instruct.h"
+#include "coq_fix_code.h"
+#include "coq_memory.h"
+#include "coq_interp.h"
+
+/* stack */
+
+value * coq_stack_low;
+value * coq_stack_high;
+value * coq_stack_threshold;
+asize_t coq_max_stack_size = Coq_max_stack_size;
+/* global_data */
+
+
+value coq_global_data;
+value coq_global_boxed;
+int coq_all_transp;
+value coq_atom_tbl;
+
+int drawinstr;
+/* interp state */
+
+long coq_saved_sp_offset;
+value * coq_sp;
+/* Some predefined pointer code */ 
+code_t accumulate;
+
+/* functions over global environment */
+
+void coq_stat_free (void * blk)
+{
+  free (blk);
+}
+
+value coq_static_alloc(value size) /* ML */
+{
+  return (value) coq_stat_alloc((asize_t) Long_val(size));
+}
+
+value coq_static_free(value blk)  /* ML */
+{
+  coq_stat_free((void *) blk);
+  return Val_unit;
+}
+
+value accumulate_code(value unit) /* ML */
+{
+  return (value) accumulate;
+}
+
+static void (*coq_prev_scan_roots_hook) (scanning_action);
+
+static void coq_scan_roots(scanning_action action)
+{
+  register value * i;
+  /* Scan the global variables */
+  (*action)(coq_global_data, &coq_global_data);
+  (*action)(coq_global_boxed, &coq_global_boxed);
+  (*action)(coq_atom_tbl, &coq_atom_tbl);
+  /* Scan the stack */
+  for (i = coq_sp; i < coq_stack_high; i++) {
+    (*action) (*i, i);
+  };
+  /* Hook */
+  if (coq_prev_scan_roots_hook != NULL) (*coq_prev_scan_roots_hook)(action);
+
+
+}
+
+void init_coq_stack()
+{
+  coq_stack_low = (value *) coq_stat_alloc(Coq_stack_size);
+  coq_stack_high = coq_stack_low + Coq_stack_size / sizeof (value);
+  coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value);
+  coq_max_stack_size = Coq_max_stack_size;
+}  
+
+void init_coq_global_data(long requested_size)
+{
+  int i;
+  coq_global_data = alloc_shr(requested_size, 0);
+  for (i = 0; i < requested_size; i++) 
+    Field (coq_global_data, i) = Val_unit;
+}
+
+void init_coq_global_boxed(long requested_size)
+{
+  int i;
+  coq_global_boxed = alloc_shr(requested_size, 0);
+  for (i = 0; i < requested_size; i++) 
+    Field (coq_global_boxed, i) = Val_true;
+}
+
+void init_coq_atom_tbl(long requested_size){
+  int i;
+  coq_atom_tbl = alloc_shr(requested_size, 0);
+  for (i = 0; i < requested_size; i++) Field (coq_atom_tbl, i) = Val_unit;
+}
+
+void init_coq_interpreter()
+{
+  coq_sp = coq_stack_high;
+  coq_interprete(NULL, Val_unit, Val_unit, 0);
+}
+
+static int coq_vm_initialized = 0;
+
+value init_coq_vm(value unit) /* ML */
+{
+  int i;
+  if (coq_vm_initialized == 1) {
+    fprintf(stderr,"already open \n");fflush(stderr);}
+  else {
+    drawinstr=0;
+#ifdef THREADED_CODE   
+    init_arity();
+#endif /* THREADED_CODE */
+    /* Allocate the table of global and the stack */
+    init_coq_stack();
+    init_coq_global_data(Coq_global_data_Size);
+    init_coq_global_boxed(40);
+    init_coq_atom_tbl(40);
+    /* Initialing the interpreter */
+    coq_all_transp = 0;
+    init_coq_interpreter();
+    
+    /* Some predefined pointer code */
+    accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t));
+    *accumulate = VALINSTR(ACCUMULATE);
+
+  /* Initialize GC */
+    if (coq_prev_scan_roots_hook == NULL)
+      coq_prev_scan_roots_hook = scan_roots_hook;
+    scan_roots_hook = coq_scan_roots;
+    coq_vm_initialized = 1;
+  } 
+  return Val_unit;;
+}
+
+void realloc_coq_stack(asize_t required_space)
+{
+  asize_t size;
+  value * new_low, * new_high, * new_sp;
+  value * p;
+  size = coq_stack_high - coq_stack_low;
+  do {
+    size *= 2;
+  } while (size < coq_stack_high - coq_sp + required_space);
+  new_low = (value *) coq_stat_alloc(size * sizeof(value));
+  new_high = new_low + size;
+
+#define shift(ptr) \
+    ((char *) new_high - ((char *) coq_stack_high - (char *) (ptr)))
+
+  new_sp = (value *) shift(coq_sp);
+  memmove((char *) new_sp,
+        (char *) coq_sp,
+        (coq_stack_high - coq_sp) * sizeof(value));
+  coq_stat_free(coq_stack_low);
+  coq_stack_low = new_low;
+  coq_stack_high = new_high;
+  coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value);
+  coq_sp = new_sp;
+#undef shift
+}
+
+value get_coq_global_data(value unit)                /* ML */
+{
+  return coq_global_data;
+}
+
+value get_coq_atom_tbl(value unit)                  /* ML */
+{
+  return coq_atom_tbl;
+}
+
+value get_coq_global_boxed(value unit)        /* ML */
+{
+  return coq_global_boxed;
+}
+
+value realloc_coq_global_data(value size)           /* ML */
+{
+  mlsize_t requested_size, actual_size, i;
+  value new_global_data;
+  requested_size = Long_val(size);
+  actual_size = Wosize_val(coq_global_data);
+  if (requested_size >= actual_size) {
+    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
+    new_global_data = alloc_shr(requested_size, 0);
+    for (i = 0; i < actual_size; i++)
+      initialize(&Field(new_global_data, i), Field(coq_global_data, i));
+    for (i = actual_size; i < requested_size; i++){
+      Field (new_global_data, i) = Val_long (0);
+    }
+    coq_global_data = new_global_data;
+  }
+  return Val_unit;
+}
+
+value realloc_coq_global_boxed(value size)           /* ML */
+{
+  mlsize_t requested_size, actual_size, i;
+  value new_global_boxed;
+  requested_size = Long_val(size);
+  actual_size = Wosize_val(coq_global_boxed);
+  if (requested_size >= actual_size) {
+    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
+    new_global_boxed = alloc_shr(requested_size, 0);
+    for (i = 0; i < actual_size; i++)
+      initialize(&Field(new_global_boxed, i), Field(coq_global_boxed, i));
+    for (i = actual_size; i < requested_size; i++)
+      Field (new_global_boxed, i) = Val_long (0);
+    coq_global_boxed = new_global_boxed;
+  }
+  return Val_unit;
+}
+
+value realloc_coq_atom_tbl(value size)            /* ML */
+{
+  mlsize_t requested_size, actual_size, i;
+  value new_atom_tbl;
+  requested_size = Long_val(size);
+  actual_size = Wosize_val(coq_atom_tbl);
+  if (requested_size >= actual_size) {
+    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
+    new_atom_tbl = alloc_shr(requested_size, 0);
+    for (i = 0; i < actual_size; i++)
+      initialize(&Field(new_atom_tbl, i), Field(coq_atom_tbl, i));
+    for (i = actual_size; i < requested_size; i++)
+      Field (new_atom_tbl, i) = Val_long (0);
+    coq_atom_tbl = new_atom_tbl;
+  }
+  return Val_unit;
+}
+
+
+value coq_set_transp_value(value transp)
+{
+  coq_all_transp = (transp == Val_true);
+  return Val_unit;
+}
+
+value get_coq_transp_value(value unit)
+{
+  return Val_bool(coq_all_transp);
+}
+
+value coq_set_drawinstr(value unit)
+{
+  drawinstr = 1;
+  return Val_unit;
+}
+
diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h
new file mode 100644
index 00000000..edd05948
--- /dev/null
+++ b/kernel/byterun/coq_memory.h
@@ -0,0 +1,69 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#ifndef _COQ_MEMORY_
+#define _COQ_MEMORY_
+
+#include <config.h>
+#include <fail.h>
+#include <misc.h>
+#include <memory.h>
+#include <mlvalues.h>
+
+
+#define Coq_stack_size (4096 * sizeof(value))
+#define Coq_stack_threshold (256 * sizeof(value))
+#define Coq_global_data_Size (4096 * sizeof(value))
+#define Coq_max_stack_size (256 * 1024)
+
+#define TRANSP 0
+#define BOXED 1
+
+/* stack */
+
+extern value * coq_stack_low;
+extern value * coq_stack_high;
+extern value * coq_stack_threshold;
+
+/* global_data */
+
+extern value coq_global_data;
+extern value coq_global_boxed;
+extern int coq_all_transp;
+extern value coq_atom_tbl;
+
+extern int drawinstr;
+/* interp state */
+
+extern value * coq_sp;
+/* Some predefined pointer code */ 
+extern code_t accumulate;
+
+/* functions over global environment */
+
+value coq_static_alloc(value size);  /* ML */
+value coq_static_free(value string); /* ML */
+
+value init_coq_vm(value unit); /* ML */
+value re_init_coq_vm(value unit); /* ML */
+
+void  realloc_coq_stack(asize_t required_space); 
+value get_coq_global_data(value unit); /* ML */
+value realloc_coq_global_data(value size); /* ML */
+value get_coq_global_boxed(value unit);
+value realloc_coq_global_boxed(value size); /* ML */
+value get_coq_atom_tbl(value unit); /* ML */
+value realloc_coq_atom_tbl(value size); /* ML */
+value coq_set_transp_value(value transp); /* ML */
+value get_coq_transp_value(value unit); /* ML */
+#endif /* _COQ_MEMORY_ */
+
+
+value coq_set_drawinstr(value unit);
diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c
new file mode 100644
index 00000000..007f61b2
--- /dev/null
+++ b/kernel/byterun/coq_values.c
@@ -0,0 +1,68 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#include <stdio.h>
+#include "coq_fix_code.h"
+#include "coq_instruct.h"
+#include "coq_memory.h"
+#include "coq_values.h"
+#include <memory.h>
+/* KIND OF VALUES */
+
+#define Setup_for_gc
+#define Restore_after_gc
+
+value coq_kind_of_closure(value v) {
+  opcode_t * c;
+  int res;
+  int is_app = 0;
+  c = Code_val(v);
+  if (Is_instruction(c, GRAB)) return Val_int(0);
+  if (Is_instruction(c, RESTART)) {is_app = 1; c++;}
+  if (Is_instruction(c, GRABREC)) return Val_int(1+is_app);
+  if (Is_instruction(c, MAKEACCU)) return Val_int(3);
+  return Val_int(0);
+}
+
+
+/* DESTRUCT ACCU */
+
+value coq_closure_arity(value clos) {
+  opcode_t * c = Code_val(clos);
+  if (Is_instruction(c,RESTART)) {
+    c++;
+    if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos));
+    else { 
+      if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity");
+      return Val_int(1);
+    }
+  }
+  if (Is_instruction(c,GRAB)) return Val_int(1 + c[1]);
+  return Val_int(1);
+}
+
+/* Fonction sur les  fix */
+
+value coq_offset(value v) {
+  if (Tag_val(v) == Closure_tag) return Val_int(0);
+  else return Val_long(-Wsize_bsize(Infix_offset_val(v)));
+}
+
+value coq_offset_closure(value v, value offset){
+  return (value)&Field(v, Int_val(offset));
+}
+
+value coq_offset_tcode(value code,value offset){
+  return((value)((code_t)code + Int_val(offset)));
+}
+
+value coq_int_tcode(value code, value offset) {
+  return Val_int(*((code_t) code + Int_val(offset)));
+}
diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h
new file mode 100644
index 00000000..4c631fce
--- /dev/null
+++ b/kernel/byterun/coq_values.h
@@ -0,0 +1,38 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Coq Compiler                              */
+/*                                                                     */
+/*        Benjamin Gregoire, projets Logical and Cristal               */
+/*                        INRIA Rocquencourt                           */
+/*                                                                     */
+/*                                                                     */
+/***********************************************************************/
+
+#ifndef _COQ_VALUES_
+#define _COQ_VALUES_
+
+#include <alloc.h>
+#include <mlvalues.h>
+
+#define Default_tag 0
+#define Accu_tag 0
+
+
+
+#define ATOM_ID_TAG 0
+#define ATOM_IDDEF_TAG 1
+#define ATOM_INDUCTIVE_TAG 2
+#define ATOM_FIX_TAG 3
+#define ATOM_SWITCH_TAG 4
+#define ATOM_COFIX_TAG 5
+#define ATOM_COFIXEVALUATED_TAG 6
+
+
+
+/* Les blocs accumulate */
+#define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag))
+
+#define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG))
+#endif /* _COQ_VALUES_ */
+
+
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
new file mode 100644
index 00000000..a9b16f29
--- /dev/null
+++ b/kernel/cbytecodes.ml
@@ -0,0 +1,135 @@
+open Names
+open Term
+
+type tag = int 
+
+let id_tag = 0
+let iddef_tag = 1
+let ind_tag = 2
+let fix_tag = 3
+let switch_tag = 4
+let cofix_tag = 5
+let cofix_evaluated_tag = 6
+
+type structured_constant =
+  | Const_sorts of sorts
+  | Const_ind of inductive
+  | Const_b0 of tag                
+  | Const_bn of tag * structured_constant array
+
+type reloc_table = (tag * int) array 
+
+type annot_switch = 
+   {ci : case_info; rtbl : reloc_table; tailcall : bool}
+ 
+module Label = 
+  struct
+    type t = int
+    let no = -1
+    let counter = ref no
+    let create () = incr counter; !counter
+    let reset_label_counter () = counter := no 
+  end
+
+
+type instruction =
+  | Klabel of Label.t
+  | Kacc of int
+  | Kenvacc of int
+  | Koffsetclosure of int
+  | Kpush
+  | Kpop of int
+  | Kpush_retaddr of Label.t
+  | Kapply of int                       (*  number of arguments *)
+  | Kappterm of int * int               (* number of arguments, slot size *)
+  | Kreturn of int                      (* slot size *)
+  | Kjump
+  | Krestart
+  | Kgrab of int                        (* number of arguments *)
+  | Kgrabrec of int                     (* rec arg *)
+  | Kclosure of Label.t * int           (* label, number of free variables *)
+  | Kclosurerec of int * int * Label.t array * Label.t array 
+                   (* nb fv, init, lbl types, lbl bodies *)
+  | Kclosurecofix of int * int * Label.t array * Label.t array 
+                   (* nb fv, init, lbl types, lbl bodies *)
+  | Kgetglobal of constant
+  | Kconst of structured_constant
+  | Kmakeblock of int * tag             (* size, tag *)
+  | Kmakeprod 
+  | Kmakeswitchblock of Label.t * Label.t * annot_switch * int
+  | Kswitch of Label.t array * Label.t array (* consts,blocks *)
+  | Kpushfields of int 
+  | Kfield of int
+  | Ksetfield of int
+  | Kstop
+  | Ksequence of bytecodes * bytecodes
+
+and bytecodes = instruction list
+
+type fv_elem = FVnamed of identifier | FVrel of int
+
+type fv = fv_elem array
+
+
+(* --- Pretty print *)
+open Format
+let rec instruction ppf = function
+  | Klabel lbl -> fprintf ppf "L%i:" lbl
+  | Kacc n -> fprintf ppf "\tacc %i" n
+  | Kenvacc n -> fprintf ppf "\tenvacc %i" n
+  | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n
+  | Kpush -> fprintf ppf "\tpush"
+  | Kpop n -> fprintf ppf "\tpop %i" n
+  | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl
+  | Kapply n -> fprintf ppf "\tapply %i" n
+  | Kappterm(n, m) ->
+      fprintf ppf "\tappterm %i, %i" n m
+  | Kreturn n -> fprintf ppf "\treturn %i" n
+  | Kjump -> fprintf ppf "\tjump"
+  | Krestart -> fprintf ppf "\trestart"
+  | Kgrab n -> fprintf ppf "\tgrab %i" n
+  | Kgrabrec n -> fprintf ppf "\tgrabrec %i" n
+  | Kclosure(lbl, n) ->
+      fprintf ppf "\tclosure L%i, %i" lbl n
+  | Kclosurerec(fv,init,lblt,lblb) ->
+      fprintf ppf "\tclosurerec";
+      fprintf ppf "%i , %i, " fv init;
+      print_string "types = ";
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt;
+      print_string " bodies = ";
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb;
+  | Kclosurecofix (fv,init,lblt,lblb) ->
+      fprintf ppf "\tclosurecofix";
+      fprintf ppf " %i , %i, " fv init;
+      print_string "types = ";
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt;
+      print_string " bodies = ";
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb;
+  | Kgetglobal id -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id)
+  | Kconst cst ->
+      fprintf ppf "\tconst"
+  | Kmakeblock(n, m) ->
+      fprintf ppf "\tmakeblock %i, %i" n m
+  | Kmakeprod -> fprintf ppf "\tmakeprod"
+  | Kmakeswitchblock(lblt,lbls,_,sz) ->
+      fprintf ppf "\tmakeswitchblock %i, %i, %i" lblt lbls sz
+  | Kswitch(lblc,lblb) -> 
+      fprintf ppf "\tswitch";
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblc;
+      Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb;
+  | Kpushfields n -> fprintf ppf "\tpushfields %i" n
+  | Ksetfield n -> fprintf ppf "\tsetfield %i" n
+  | Kfield  n -> fprintf ppf "\tgetfield %i" n
+  | Kstop -> fprintf ppf "\tstop"
+  | Ksequence (c1,c2) ->
+      fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 
+
+and instruction_list ppf = function
+    [] -> ()
+  | Klabel lbl :: il ->
+      fprintf ppf "L%i:%a" lbl instruction_list il
+  | instr :: il ->
+      fprintf ppf "%a@ %a" instruction instr instruction_list il
+ 
+let draw_instr c =
+  fprintf std_formatter "@[<v 0>%a@]" instruction_list c
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
new file mode 100644
index 00000000..215b6ad4
--- /dev/null
+++ b/kernel/cbytecodes.mli
@@ -0,0 +1,73 @@
+open Names
+open Term
+
+type tag = int 
+
+val id_tag : tag
+val iddef_tag : tag
+val ind_tag : tag
+val fix_tag : tag
+val switch_tag : tag
+val cofix_tag : tag
+val cofix_evaluated_tag : tag
+
+type structured_constant =
+  | Const_sorts of sorts
+  | Const_ind of inductive
+  | Const_b0 of tag                
+  | Const_bn of tag * structured_constant array
+
+type reloc_table = (tag * int) array 
+
+type annot_switch = 
+   {ci : case_info; rtbl : reloc_table; tailcall : bool}
+
+module Label : 
+  sig
+    type t = int
+    val no : t
+    val create : unit -> t
+    val reset_label_counter : unit -> unit
+  end 
+
+type instruction =
+  | Klabel of Label.t
+  | Kacc of int
+  | Kenvacc of int
+  | Koffsetclosure of int
+  | Kpush
+  | Kpop of int
+  | Kpush_retaddr of Label.t
+  | Kapply of int                       (*  number of arguments *)
+  | Kappterm of int * int               (* number of arguments, slot size *)
+  | Kreturn of int                      (* slot size *)
+  | Kjump
+  | Krestart
+  | Kgrab of int                        (* number of arguments *)
+  | Kgrabrec of int                     (* rec arg *)
+  | Kclosure of Label.t * int           (* label, number of free variables *)
+  | Kclosurerec of int * int * Label.t array * Label.t array 
+                   (* nb fv, init, lbl types, lbl bodies *)
+  | Kclosurecofix of int * int * Label.t array * Label.t array 
+                   (* nb fv, init, lbl types, lbl bodies *)
+  | Kgetglobal of constant
+  | Kconst of structured_constant
+  | Kmakeblock of int * tag             (* size, tag *)
+  | Kmakeprod 
+  | Kmakeswitchblock of Label.t * Label.t * annot_switch * int
+  | Kswitch of Label.t array * Label.t array (* consts,blocks *)
+  | Kpushfields of int 
+  | Kfield of int
+  | Ksetfield of int
+  | Kstop
+  | Ksequence of bytecodes * bytecodes
+
+
+and bytecodes = instruction list
+
+type fv_elem = FVnamed of identifier | FVrel of int
+
+type fv = fv_elem array
+
+val draw_instr : bytecodes -> unit
+
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
new file mode 100644
index 00000000..e1f89fad
--- /dev/null
+++ b/kernel/cbytegen.ml
@@ -0,0 +1,627 @@
+open Util
+open Names
+open Cbytecodes
+open Cemitcodes
+open Term
+open Declarations
+open Pre_env
+
+
+(* Compilation des variables + calcul des variables libres               *)
+
+(* Dans la machine virtuel il n'y a pas de difference entre les           *)
+(* fonctions et leur environnement                                        *)
+
+(* Representation de l'environnements des fonctions :                     *)
+(*        [clos_t | code | fv1 | fv2 | ... | fvn ]                        *)
+(*                ^                                                       *)
+(*  l'offset pour l'acces au variable libre est 1 (il faut passer le      *)
+(*  pointeur de code).                                                    *)
+(*  Lors de la compilation, les variables libres sont stock'ees dans      *)
+(*  [in_env] dans l'ordre inverse de la representation machine, ceci      *)
+(* permet de rajouter des nouvelles variables dans l'environnememt        *)
+(* facilement.                                                            *)
+(* Les arguments de la fonction arrive sur la pile dans l'ordre de        *)
+(* l'application :  f arg1 ... argn                                       *)
+(*   - la pile est alors :                                                *)
+(*        arg1 : ... argn : extra args : return addr : ...                *)
+(* Dans le corps de la fonction [arg1] est repr'esent'e par le de Bruijn  *)
+(*  [n], [argn] par le de Bruijn [1]                                      *)
+
+(* Representation des environnements des points fix mutuels :             *)
+(* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *)
+(*                ^<----------offset--------->                            *)
+(* type = [Ct1 | .... | Ctn]                                              *)
+(* Ci est le code correspondant au corps du ieme point fix                *)
+(* Lors de l'evaluation d'un point fix l'environnement est un pointeur    *)
+(* sur la position correspondante a son code.                             *)
+(* Dans le corps de chaque point fix le de Bruijn [nbr] represente,       *)
+(* le 1er point fix de la declaration mutuelle, le de Bruijn [1] le       *)
+(* nbr-ieme.                                                              *)
+(* L'acces a ces variables se fait par l'instruction [Koffsetclosure]     *)
+(*  (decalage de l'environnement)                                         *)
+
+(* Ceci permet de representer tout les point fix mutuels en un seul bloc  *)
+(* [Ct1 | ... | Ctn] est un tableau contant le code d'evaluation des      *)
+(* types des points fixes, ils sont utilises pour tester la conversion    *)
+(* Leur environnement d'execution est celui du dernier point fix :        *)
+(* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *)
+(*                                ^                                       *)
+
+
+(* Representation des cofix mutuels :                                     *)
+(*  a1 =   [A_t | accumulate | [Cfx_t | fcofix1 ] ]                       *)
+(*                ...                                                     *)
+(*  anbr = [A_t | accumulate | [Cfx_t | fcofixnbr ] ]                     *)
+(*                                                                        *)
+(*  fcofix1 = [clos_t   | code1   | a1 |...| anbr | fv1 |...| fvn | type] *)
+(*                      ^                                                 *)
+(*                ...                                                     *)
+(*  fcofixnbr = [clos_t | codenbr | a1 |...| anbr | fv1 |...| fvn | type] *)
+(*                      ^                                                 *)
+(*  Les block [ai] sont des fonctions qui accumulent leurs arguments :    *)
+(*           ai arg1  argp --->                                           *)
+(*    ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ]   *)
+(* Si un tel bloc arrive sur un [match] il faut forcer l'evaluation,      *)
+(* la fonction [fcofixi] est alors appliqu'ee a [ai'] [arg1] ... [argp]   *)
+(* A la fin de l'evaluation [ai'] est mis a jour avec le resultat de      *)
+(* l'evaluation :                                                         *)
+(*  ai' <--                                                               *)
+(*   [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ]   *)
+(* L'avantage de cette representation est qu'elle permet d'evaluer qu'une *)
+(* fois l'application d'un cofix (evaluation lazy)                        *)
+(* De plus elle permet de creer facilement des cycles quand les cofix ne  *)
+(* n'ont pas d'aruments, ex:                                              *)
+(*   cofix one := cons 1 one                                              *)
+(*   a1 = [A_t | accumulate | [Cfx_t|fcofix1] ]                           *)
+(*   fcofix1 = [clos_t | code | a1]                                       *)
+(*  Quand on force l'evaluation de [a1] le resultat est                   *)
+(*    [cons_t | 1 | a1]                                                   *)
+(*  [a1] est mis a jour :                                                 *)
+(*  a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ]     *)
+(* Le cycle est cree ...                                                  *)
+   
+(* On conserve la fct de cofix pour la conversion                         *)
+   
+type vm_env = {
+    size : int;              (* longueur de la liste [n] *)
+    fv_rev : fv_elem list    (* [fvn; ... ;fv1] *)
+  }    
+   
+let empty_fv = { size= 0;  fv_rev = [] }
+   
+type comp_env = { 
+    nb_stack : int;              (* nbre de variables sur la pile          *)
+    in_stack : int list;         (* position dans la pile                  *)
+    nb_rec : int;                (* nbre de fonctions mutuellement         *)
+                                 (* recursives =  nbr                      *)
+    pos_rec  : instruction list; (* instruction d'acces pour les variables *)
+                                 (*  de point fix ou de cofix              *)
+    offset : int;                 
+    in_env : vm_env ref 
+  } 
+
+let fv r = !(r.in_env)
+   
+let empty_comp_env ()= 
+  { nb_stack = 0; 
+    in_stack = [];
+    nb_rec = 0;
+    pos_rec = [];
+    offset = 0; 
+    in_env = ref empty_fv;
+  } 
+
+(*i Creation functions for comp_env *)
+
+let rec add_param n sz l =
+  if n = 0 then l else add_param (n - 1) sz (n+sz::l) 
+   
+let comp_env_fun arity = 
+  { nb_stack = arity; 
+    in_stack = add_param arity 0 [];
+    nb_rec = 0;
+    pos_rec = [];
+    offset = 1; 
+    in_env = ref empty_fv 
+  } 
+    
+
+let comp_env_type rfv = 
+  { nb_stack = 0; 
+    in_stack = [];
+    nb_rec = 0;
+    pos_rec = [];
+    offset = 1; 
+    in_env = rfv 
+  }
+   
+let comp_env_fix ndef curr_pos arity rfv =
+   let prec = ref [] in
+   for i = ndef downto 1 do
+     prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec 
+   done;
+   { nb_stack = arity; 
+     in_stack = add_param arity 0 [];
+     nb_rec = ndef; 
+     pos_rec = !prec;
+     offset = 2 * (ndef - curr_pos - 1)+1;
+     in_env = rfv 
+   } 
+
+let comp_env_cofix ndef arity rfv =
+   let prec = ref [] in
+   for i = 1 to ndef do
+     prec := Kenvacc i :: !prec
+   done;
+   { nb_stack = arity; 
+     in_stack = add_param arity 0 [];
+     nb_rec = ndef; 
+     pos_rec = !prec;
+     offset = ndef+1;
+     in_env = rfv 
+   }
+
+(* [push_param ] ajoute les parametres de fonction dans la pile *)
+let push_param n sz r =
+  { r with
+    nb_stack = r.nb_stack + n;
+    in_stack = add_param n sz r.in_stack }
+
+(* [push_local e sz] ajoute une nouvelle variable dans la pile a la *)
+(* position [sz]                                                    *)
+let push_local sz r = 
+  { r with 
+    nb_stack = r.nb_stack + 1;
+    in_stack = (sz + 1) :: r.in_stack }
+
+
+
+(*i Compilation of variables *)
+let find_at el l = 
+  let rec aux n = function
+    | [] -> raise Not_found
+    | hd :: tl -> if hd = el then n else aux (n+1) tl
+  in aux 1 l
+
+let pos_named id r =
+  let env = !(r.in_env) in
+  let cid = FVnamed id in
+  try Kenvacc(r.offset + env.size - (find_at cid env.fv_rev))
+  with Not_found ->
+    let pos = env.size in
+    r.in_env := { size = pos+1; fv_rev =  cid:: env.fv_rev};
+    Kenvacc (r.offset + pos)
+
+let pos_rel i r sz = 
+  if i <= r.nb_stack then
+    Kacc(sz - (List.nth r.in_stack (i-1)))
+  else
+    let i = i - r.nb_stack in
+    if i <= r.nb_rec then 
+      try List.nth r.pos_rec (i-1)
+      with _ -> assert false
+    else
+      let i = i - r.nb_rec in
+      let db = FVrel(i) in
+      let env = !(r.in_env) in
+      try Kenvacc(r.offset + env.size - (find_at db env.fv_rev))
+      with Not_found ->
+	let pos = env.size in
+	r.in_env := { size = pos+1; fv_rev =  db:: env.fv_rev};
+	Kenvacc(r.offset + pos)
+
+(*i  Examination of the continuation *)
+
+(* Discard all instructions up to the next label.                        *)
+(* This function is to be applied to the continuation before adding a    *)
+(* non-terminating instruction (branch, raise, return, appterm)          *)
+(* in front of it.                                                       *)
+
+let rec discard_dead_code cont = cont
+(*function
+    [] -> []
+  | (Klabel _ | Krestart ) :: _ as cont -> cont
+  | _ :: cont -> discard_dead_code cont
+*)
+
+(* Return a label to the beginning of the given continuation.            *)
+(*   If the sequence starts with a branch, use the target of that branch *)
+(*   as the label, thus avoiding a jump to a jump.                       *)
+
+let label_code = function
+  | Klabel lbl :: _ as cont -> (lbl, cont)
+  | cont -> let lbl = Label.create() in (lbl, Klabel lbl :: cont)
+
+(* Return a branch to the continuation. That is, an instruction that,
+   when executed, branches to the continuation or performs what the
+   continuation performs. We avoid generating branches to returns. *)
+
+let make_branch cont =
+  match cont with
+  | (Kreturn _ as return) :: cont' -> return, cont'
+  | Klabel lbl as b :: _ -> b, cont
+  | _ -> let b = Klabel(Label.create()) in b,b::cont
+
+(* Check if we're in tailcall position *)
+
+let rec is_tailcall = function
+  | Kreturn k :: _ -> Some k
+  | Klabel _ :: c -> is_tailcall c
+  | _ -> None
+
+(* Extention of the continuation *)
+	
+(* Add a Kpop n instruction in front of a continuation *)
+let rec add_pop n = function
+  | Kpop m :: cont -> add_pop (n+m) cont
+  | Kreturn m:: cont -> Kreturn (n+m) ::cont
+  | cont -> if n = 0 then cont else Kpop n :: cont
+
+let add_grab arity lbl cont =
+  if arity = 1 then Klabel lbl :: cont
+  else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont
+ 
+let add_grabrec rec_arg arity lbl cont =
+  if arity = 1 then 
+    Klabel lbl :: Kgrabrec 0 :: Krestart :: cont
+  else
+    Krestart :: Klabel lbl :: Kgrabrec rec_arg ::
+    Krestart :: Kgrab (arity - 1) :: cont
+
+(* continuation of a cofix *)
+
+let cont_cofix arity =
+    (* accu = res                                                         *)
+    (* stk  = ai::args::ra::...                                           *)
+    (* ai   = [At|accumulate|[Cfx_t|fcofix]|args]                         *)
+  [ Kpush;
+    Kpush;        (*                 stk = res::res::ai::args::ra::...    *)
+    Kacc 2;
+    Kfield 1;
+    Kfield 0;
+    Kmakeblock(2, cofix_evaluated_tag); 
+    Kpush;        (*  stk = [Cfxe_t|fcofix|res]::res::ai::args::ra::...*)
+    Kacc 2;
+    Ksetfield 1;  (*   ai = [At|accumulate|[Cfxe_t|fcofix|res]|args]      *)
+                  (*  stk = res::ai::args::ra::...                        *)   
+    Kacc 0;       (* accu = res                                           *)
+    Kreturn (arity+2) ]
+
+
+(*i Global environment global *)
+
+let global_env = ref empty_env
+
+let set_global_env env = global_env := env
+
+
+(* Code des fermetures *)
+let fun_code = ref []
+
+let init_fun_code () = fun_code := []
+
+(* Compilation des constructeurs et des inductifs *)
+
+(* Inv : nparam + arity > 0 *)
+let code_construct tag nparams arity cont =
+  let f_cont =
+      add_pop nparams
+      (if arity = 0 then 
+	[Kconst (Const_b0 tag); Kreturn 0]
+       else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0])
+    in 
+    let lbl = Label.create() in
+    fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)];
+    Kclosure(lbl,0) :: cont
+
+type block = 
+  | Bconstr of constr
+  | Bstrconst of structured_constant
+  | Bmakeblock of int * block array
+  | Bconstruct_app of int * int * int * block array
+                  (* tag , nparams, arity *)
+
+let get_strcst = function
+  | Bstrconst sc -> sc
+  | _ -> raise Not_found 
+
+let rec str_const c =
+  match kind_of_term c with
+  | Sort s -> Bstrconst (Const_sorts s)
+  | Cast(c,_,_) -> str_const c 
+  | App(f,args) -> 
+      begin
+	match kind_of_term f with
+	| Construct((kn,j),i) -> 
+	    let oib = lookup_mind kn !global_env in
+	    let oip = oib.mind_packets.(j) in
+	    let num,arity = oip.mind_reloc_tbl.(i-1) in
+	    let nparams = oib.mind_nparams in
+	    if nparams + arity = Array.length args then
+	      if arity = 0 then Bstrconst(Const_b0 num)
+	      else
+		let rargs = Array.sub args nparams arity in
+		let b_args = Array.map str_const rargs in
+		try 
+		  let sc_args = Array.map get_strcst b_args in
+		  Bstrconst(Const_bn(num, sc_args))
+		with Not_found ->
+		  Bmakeblock(num,b_args)
+	    else  
+	      let b_args = Array.map str_const args in
+	      Bconstruct_app(num, nparams, arity, b_args)
+	| _ -> Bconstr c
+      end
+  | Ind ind -> Bstrconst (Const_ind ind)
+  | Construct ((kn,j),i) ->  
+      let oib = lookup_mind kn !global_env in 
+      let oip = oib.mind_packets.(j) in
+      let num,arity = oip.mind_reloc_tbl.(i-1) in
+      let nparams = oib.mind_nparams in
+      if nparams + arity = 0 then Bstrconst(Const_b0 num)
+      else Bconstruct_app(num,nparams,arity,[||])
+  | _ -> Bconstr c
+
+(* compilation des applications *)
+let comp_args comp_expr reloc args sz cont =
+  let nargs_m_1 = Array.length args - 1 in  
+  let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in
+  for i = 1 to nargs_m_1 do
+    c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c)
+  done; 
+  !c
+  
+let comp_app comp_fun comp_arg reloc f args sz cont =
+  let nargs = Array.length args in
+  match is_tailcall cont with
+  | Some k -> 
+      comp_args comp_arg reloc args sz
+	(Kpush ::
+	 comp_fun reloc f (sz + nargs)
+	   (Kappterm(nargs, k + nargs) :: (discard_dead_code cont)))
+  | None ->
+      if nargs < 4 then
+	comp_args comp_arg reloc args sz
+	  (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont)))
+      else 
+	let lbl,cont1 = label_code cont in
+	Kpush_retaddr lbl ::
+	(comp_args comp_arg reloc args (sz + 3)
+	   (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1))))
+
+(* Compilation des variables libres *)
+  
+let compile_fv_elem reloc fv sz cont =
+  match fv with
+  | FVrel i -> pos_rel i reloc sz :: cont
+  | FVnamed id -> pos_named id reloc :: cont
+
+let rec compile_fv reloc l sz cont =
+  match l with
+  | [] -> cont
+  | [fvn] -> compile_fv_elem reloc fvn sz cont
+  | fvn :: tl ->
+      compile_fv_elem reloc fvn sz 
+	(Kpush :: compile_fv reloc tl (sz + 1) cont)
+
+(* compilation des constantes *)
+
+let rec get_allias env kn =
+  let tps = (lookup_constant kn env).const_body_code in
+  match Cemitcodes.force tps with
+  | BCallias kn' -> get_allias env kn'
+  | _ -> kn
+
+(* compilation des expressions *)
+ 
+let rec compile_constr reloc c sz cont =
+  match kind_of_term c with
+  | Meta _ -> raise (Invalid_argument "Cbytegen.compile_constr : Meta")
+  | Evar _ -> raise (Invalid_argument "Cbytegen.compile_constr : Evar")
+ 
+  | Cast(c,_,_) -> compile_constr reloc c sz cont
+
+  | Rel i -> pos_rel i reloc sz :: cont
+  | Var id -> pos_named id reloc :: cont
+  | Const kn -> Kgetglobal (get_allias !global_env kn) :: cont
+  
+  | Sort _  | Ind _ | Construct _ ->
+      compile_str_cst reloc (str_const c) sz cont
+  
+  | LetIn(_,xb,_,body) ->
+      compile_constr reloc xb sz 
+	(Kpush :: 
+	(compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont)))
+  | Prod(id,dom,codom) ->
+      let cont1 = 
+	Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in
+      compile_constr reloc (mkLambda(id,dom,codom)) sz cont1
+  | Lambda _ ->
+      let params, body = decompose_lam c in
+      let arity = List.length params in
+      let r_fun = comp_env_fun arity in
+      let lbl_fun = Label.create() in
+      let cont_fun = 
+	compile_constr r_fun body arity [Kreturn arity] in
+      fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)];
+      let fv = fv r_fun in
+      compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont)
+ 
+  | App(f,args) -> 
+      begin 
+	match kind_of_term f with
+	| Construct _ -> compile_str_cst reloc (str_const c) sz cont
+	| _ -> comp_app compile_constr compile_constr reloc f args sz cont 
+      end
+  | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) ->
+      let ndef = Array.length type_bodies in
+      let rfv = ref empty_fv in
+      let lbl_types = Array.create ndef Label.no in
+      let lbl_bodies = Array.create ndef Label.no in
+      (* Compilation des types *)
+      let env_type = comp_env_type rfv in
+      for i = 0 to ndef - 1 do
+	let lbl,fcode = 
+	  label_code 
+	    (compile_constr env_type type_bodies.(i) 0 [Kstop]) in 
+	lbl_types.(i) <- lbl; 
+	fun_code := [Ksequence(fcode,!fun_code)]
+      done;
+      (* Compilation des corps *)
+      for i = 0 to ndef - 1 do
+	let params,body = decompose_lam rec_bodies.(i) in
+	let arity = List.length params in
+	let env_body = comp_env_fix ndef i arity rfv in
+	let cont1 = 
+	  compile_constr env_body body arity [Kreturn arity] in
+	let lbl = Label.create () in
+	lbl_bodies.(i) <- lbl;
+	let fcode =  add_grabrec rec_args.(i) arity lbl cont1 in
+	fun_code := [Ksequence(fcode,!fun_code)]
+      done;
+      let fv = !rfv in
+      compile_fv reloc fv.fv_rev sz 
+	(Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont)
+  
+  | CoFix(init,(_,type_bodies,rec_bodies)) ->
+      let ndef = Array.length type_bodies in
+      let lbl_types = Array.create ndef Label.no in
+      let lbl_bodies = Array.create ndef Label.no in
+      (* Compilation des types *)
+      let rfv = ref empty_fv in
+      let env_type = comp_env_type rfv in
+      for i = 0 to ndef - 1 do
+	let lbl,fcode = 
+	  label_code 
+	    (compile_constr env_type type_bodies.(i) 0 [Kstop]) in
+	lbl_types.(i) <- lbl; 
+	fun_code := [Ksequence(fcode,!fun_code)]
+      done;
+      (* Compilation des corps *)
+      for i = 0 to ndef - 1 do
+	let params,body = decompose_lam rec_bodies.(i) in
+	let arity = List.length params in
+	let env_body = comp_env_cofix ndef arity rfv in
+	let lbl = Label.create () in
+	let cont1 = 
+	  compile_constr env_body body (arity+1) (cont_cofix arity) in
+	let cont2 = 
+	  add_grab (arity+1) lbl cont1 in
+	lbl_bodies.(i) <- lbl;
+	fun_code := [Ksequence(cont2,!fun_code)];
+      done;
+      let fv = !rfv in
+      compile_fv reloc fv.fv_rev sz 
+	(Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont)
+  
+  | Case(ci,t,a,branchs) ->
+      let ind = ci.ci_ind in
+      let mib = lookup_mind (fst ind) !global_env in
+      let oib = mib.mind_packets.(snd ind) in
+      let tbl = oib.mind_reloc_tbl in
+      let lbl_consts = Array.create oib.mind_nb_constant Label.no in
+      let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in
+      let branch1,cont = make_branch cont in
+      (* Compilation du type *)
+      let lbl_typ,fcode = 	
+	label_code (compile_constr reloc t sz [Kpop sz; Kstop])
+      in fun_code := [Ksequence(fcode,!fun_code)];
+      (* Compilation des branches *) 
+      let lbl_sw = Label.create () in
+      let sz_b,branch,is_tailcall =
+	match branch1 with 
+	| Kreturn k -> assert (k = sz); sz, branch1, true
+	| _ -> sz+3, Kjump, false
+      in
+      let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in
+     (* Compilation de la branche accumulate *)
+      let lbl_accu, code_accu = 
+	label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) 
+      in
+      lbl_blocks.(0) <- lbl_accu;
+      let c = ref code_accu in
+      (* Compilation des branches constructeurs *)
+      for i = 0 to Array.length tbl - 1 do
+	let tag, arity = tbl.(i) in
+	if arity = 0 then
+	  let lbl_b,code_b = 
+	    label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in
+	  lbl_consts.(tag) <- lbl_b; 
+	  c := code_b
+	else 
+	  let args, body = decompose_lam branchs.(i) in
+	  let nargs = List.length args in
+	  let lbl_b,code_b = 
+	    label_code(
+	    if nargs = arity then
+	      Kpushfields arity ::
+	      compile_constr (push_param arity sz_b reloc)
+		body (sz_b+arity) (add_pop arity (branch :: !c))
+	    else
+	      let sz_appterm = if is_tailcall then sz_b + arity else arity in
+	      Kpushfields arity :: 
+	      compile_constr reloc branchs.(i) (sz_b+arity)
+		(Kappterm(arity,sz_appterm) :: !c))
+	  in
+	  lbl_blocks.(tag) <- lbl_b;
+	  c := code_b
+      done;
+      c :=  Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c;
+      let code_sw = 
+	match branch1 with
+	| Klabel lbl -> Kpush_retaddr lbl ::  !c
+	| _ -> !c 
+      in
+      compile_constr reloc a sz code_sw
+       
+and compile_str_cst reloc sc sz cont =
+  match sc with
+  | Bconstr c -> compile_constr reloc c sz cont
+  | Bstrconst sc -> Kconst sc :: cont
+  | Bmakeblock(tag,args) ->
+      let nargs = Array.length args in
+      comp_args compile_str_cst reloc args sz (Kmakeblock(nargs,tag) :: cont)
+  | Bconstruct_app(tag,nparams,arity,args) ->
+      if Array.length args = 0 then code_construct tag nparams arity cont
+      else
+	comp_app 
+	  (fun _ _ _ cont -> code_construct tag nparams arity cont) 
+	  compile_str_cst reloc () args sz cont
+      
+let compile env c =
+  set_global_env env;
+  init_fun_code ();
+  Label.reset_label_counter ();
+  let reloc = empty_comp_env () in
+  let init_code = compile_constr reloc c 0 [Kstop] in
+  let fv = List.rev (!(reloc.in_env).fv_rev) in
+(*  draw_instr init_code;
+  draw_instr !fun_code;
+  Format.print_string "fv = ";
+  List.iter (fun v ->
+    match v with
+    | FVnamed id -> Format.print_string ((string_of_id id)^"; ")
+    | FVrel i -> Format.print_string ((string_of_int i)^"; ")) fv;  Format
+    .print_string "\n";
+  Format.print_flush();  *)
+  init_code,!fun_code, Array.of_list fv
+
+let compile_constant_body env body opaque boxed =
+  if opaque then BCconstant
+  else match body with
+  | None -> BCconstant
+  | Some sb ->
+      let body = Declarations.force sb in
+      if boxed then
+	let res = compile env body in
+	let to_patch = to_memory res in
+	BCdefined(true, to_patch)
+      else
+	match kind_of_term body with
+	| Const kn' -> BCallias (get_allias env kn')
+	| _ -> 
+	    let res = compile env body in
+	    let to_patch = to_memory res in
+	    BCdefined (false, to_patch)
+
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
new file mode 100644
index 00000000..f761e4f6
--- /dev/null
+++ b/kernel/cbytegen.mli
@@ -0,0 +1,17 @@
+open Names
+open Cbytecodes
+open Cemitcodes 
+open Term
+open Declarations
+open Pre_env
+
+
+
+val compile : env -> constr -> bytecodes * bytecodes * fv
+                              (* init, fun, fv *)
+
+val compile_constant_body : 
+    env -> constr_substituted option -> bool -> bool -> body_code
+                                 (* opaque *) (* boxed *)
+
+
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
new file mode 100644
index 00000000..71a9aa0e
--- /dev/null
+++ b/kernel/cemitcodes.ml
@@ -0,0 +1,312 @@
+open Names
+open Term
+open Cbytecodes
+open Copcodes
+open Mod_subst
+
+(* Relocation information *)
+type reloc_info =
+  | Reloc_annot of annot_switch 
+  | Reloc_const of structured_constant
+  | Reloc_getglobal of constant
+
+type patch = reloc_info * int 
+
+let patch_int buff pos n =
+  String.unsafe_set buff pos (Char.unsafe_chr n);
+  String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
+  String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
+  String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
+
+
+(* Buffering of bytecode *)
+
+let out_buffer = ref(String.create 1024)
+and out_position = ref 0
+
+let out_word b1 b2 b3 b4 =
+  let p = !out_position in
+  if p >= String.length !out_buffer then begin
+    let len = String.length !out_buffer in
+    let new_buffer = String.create (2 * len) in
+    String.blit !out_buffer 0 new_buffer 0 len;
+    out_buffer := new_buffer
+  end;
+  String.unsafe_set !out_buffer p (Char.unsafe_chr b1);
+  String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2);
+  String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3);
+  String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
+  out_position := p + 4
+
+let out opcode =
+  out_word opcode 0 0 0
+
+let out_int n =
+  out_word n (n asr 8) (n asr 16) (n asr 24)
+
+(* Handling of local labels and backpatching *)
+
+type label_definition =
+    Label_defined of int
+  | Label_undefined of (int * int) list
+
+let label_table  = ref ([| |] : label_definition array)
+(* le ieme element de la table = Label_defined n signifie que l'on a 
+   deja rencontrer le label i et qu'il est a l'offset n.
+                               = Label_undefined l signifie que l'on a 
+   pas encore rencontrer ce label, le premier entier indique ou est l'entier 
+   a patcher dans la string, le deuxieme son origine  *)
+
+let extend_label_table needed =
+  let new_size = ref(Array.length !label_table) in
+  while needed >= !new_size do new_size := 2 * !new_size done;
+  let new_table = Array.create !new_size (Label_undefined []) in
+  Array.blit !label_table 0 new_table 0 (Array.length !label_table);
+  label_table := new_table
+
+let backpatch (pos, orig) =
+  let displ = (!out_position - orig) asr 2 in
+  !out_buffer.[pos] <- Char.unsafe_chr displ;
+  !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
+  !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
+  !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
+
+let define_label lbl =
+  if lbl >= Array.length !label_table then extend_label_table lbl;
+  match (!label_table).(lbl) with
+    Label_defined _ ->
+      raise(Failure "CEmitcode.define_label")
+  | Label_undefined patchlist ->
+      List.iter backpatch patchlist;
+      (!label_table).(lbl) <- Label_defined !out_position
+
+let out_label_with_orig orig lbl =
+  if lbl >= Array.length !label_table then extend_label_table lbl;
+  match (!label_table).(lbl) with
+    Label_defined def ->
+      out_int((def - orig) asr 2)
+  | Label_undefined patchlist ->
+      if patchlist = [] then
+	(!label_table).(lbl) <-
+          Label_undefined((!out_position, orig) :: patchlist);
+      out_int 0
+
+let out_label l = out_label_with_orig !out_position l
+
+(* Relocation information *)
+
+let reloc_info = ref ([] : (reloc_info * int) list)
+
+let enter info =
+  reloc_info := (info, !out_position) :: !reloc_info
+
+let slot_for_const c =
+  enter (Reloc_const c);
+  out_int 0
+
+and slot_for_annot a =
+  enter (Reloc_annot a);
+  out_int 0
+
+and slot_for_getglobal id =
+  enter (Reloc_getglobal id);
+  out_int 0
+
+
+(* Emission of one instruction *)
+
+
+let emit_instr = function
+  | Klabel lbl -> define_label lbl
+  | Kacc n ->
+      if n < 8 then out(opACC0 + n) else (out opACC; out_int n)
+  | Kenvacc n ->
+      if n >= 1 && n <= 4
+      then out(opENVACC1 + n - 1)
+      else (out opENVACC; out_int n)
+  | Koffsetclosure ofs ->
+      if ofs = -2 || ofs = 0 || ofs = 2
+      then out (opOFFSETCLOSURE0 + ofs / 2)
+      else (out opOFFSETCLOSURE; out_int ofs)
+  | Kpush ->      
+      out opPUSH
+  | Kpop n ->      
+      out opPOP; out_int n
+  | Kpush_retaddr lbl -> 
+      out opPUSH_RETADDR; out_label lbl
+  | Kapply n ->
+      if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n)
+  | Kappterm(n, sz) ->
+      if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz)
+               else (out opAPPTERM; out_int n; out_int sz)
+  | Kreturn n ->
+      out opRETURN; out_int n
+  | Kjump ->
+      out opRETURN; out_int 0
+  | Krestart ->
+      out opRESTART
+  | Kgrab n -> 
+      out opGRAB; out_int n
+  | Kgrabrec(rec_arg) -> 
+      out opGRABREC; out_int rec_arg
+  | Kclosure(lbl, n) -> 
+      out opCLOSURE; out_int n; out_label lbl
+  | Kclosurerec(nfv,init,lbl_types,lbl_bodies) ->
+      out opCLOSUREREC;out_int (Array.length lbl_bodies);
+      out_int nfv; out_int init;
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) lbl_types;
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) lbl_bodies
+  | Kclosurecofix(nfv,init,lbl_types,lbl_bodies) ->
+      out opCLOSURECOFIX;out_int (Array.length lbl_bodies);
+      out_int nfv; out_int init;
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) lbl_types;
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) lbl_bodies
+  | Kgetglobal q -> 
+      out opGETGLOBAL; slot_for_getglobal q
+  | Kconst((Const_b0 i)) -> 
+      if i >= 0 && i <= 3
+          then out (opCONST0 + i)
+          else (out opCONSTINT; out_int i) 
+  | Kconst c ->
+      out opGETGLOBAL; slot_for_const c
+  | Kmakeblock(n, t) ->
+      if n = 0 then raise (Invalid_argument "emit_instr : block size = 0")
+      else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
+      else (out opMAKEBLOCK; out_int n; out_int t)
+  | Kmakeprod ->
+      out opMAKEPROD
+  | Kmakeswitchblock(typlbl,swlbl,annot,sz) ->
+      out opMAKESWITCHBLOCK;
+      out_label typlbl; out_label swlbl;
+      slot_for_annot annot;out_int sz
+  | Kswitch (tbl_const, tbl_block) ->
+      out opSWITCH;
+      out_int (Array.length tbl_const + (Array.length tbl_block lsl 16));
+      let org = !out_position in
+      Array.iter (out_label_with_orig org) tbl_const;
+      Array.iter (out_label_with_orig org) tbl_block
+  | Kpushfields n ->
+      out opPUSHFIELDS;out_int n
+  | Kfield n ->
+      if n <= 1 then out (opGETFIELD0+n)
+      else (out opGETFIELD;out_int n)
+  | Ksetfield n ->
+      if n <= 1 then out (opSETFIELD0+n) 
+      else (out opSETFIELD;out_int n)
+  | Kstop -> 
+      out opSTOP
+  | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr")
+
+(* Emission of a list of instructions. Include some peephole optimization. *)
+
+let rec emit = function
+  | [] -> ()
+  (* Peephole optimizations *)
+  | Kpush :: Kacc n :: c ->
+      if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
+      emit c
+  | Kpush :: Kenvacc n :: c -> 
+      if n >= 1 && n <= 4
+      then out(opPUSHENVACC1 + n - 1)
+      else (out opPUSHENVACC; out_int n);
+      emit c
+  | Kpush :: Koffsetclosure ofs :: c -> 
+      if ofs = -2 || ofs = 0 || ofs = 2
+      then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
+      else (out opPUSHOFFSETCLOSURE; out_int ofs);
+      emit c
+  | Kpush :: Kgetglobal id :: c ->
+      out opPUSHGETGLOBAL; slot_for_getglobal id; emit c 
+  | Kpush :: Kconst (Const_b0 i) :: c -> 
+      if i >= 0 && i <= 3
+      then out (opPUSHCONST0 + i)
+      else (out opPUSHCONSTINT; out_int i);
+      emit c
+  | Kpush :: Kconst const :: c ->
+      out opPUSHGETGLOBAL; slot_for_const const;
+      emit c 
+  | Kpop n :: Kjump :: c ->
+      out opRETURN; out_int n; emit c
+  | Ksequence(c1,c2)::c ->
+      emit c1; emit c2;emit c
+  (* Default case *)
+  | instr :: c ->
+      emit_instr instr; emit c
+
+(* Initialization *)
+
+let init () =
+  out_position := 0;
+  label_table := Array.create 16 (Label_undefined []);
+  reloc_info := []
+
+type emitcodes = string
+
+let length = String.length
+
+type to_patch = emitcodes * (patch list) * fv
+
+(* Substitution *)
+let rec subst_strcst s sc =
+  match sc with
+  | Const_sorts _ | Const_b0 _ -> sc
+  | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args)
+  | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_kn s kn, i))
+
+let subst_patch s (ri,pos) = 
+  match ri with
+  | Reloc_annot a ->
+      let (kn,i) = a.ci.ci_ind in
+      let ci = {a.ci with ci_ind = (subst_kn s kn,i)} in
+      (Reloc_annot {a with ci = ci},pos)
+  | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos)
+  | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos)
+
+let subst_to_patch s (code,pl,fv) = 
+  code,List.rev_map (subst_patch s) pl,fv
+
+type body_code =
+  | BCdefined of bool * to_patch
+  | BCallias of constant
+  | BCconstant
+
+let subst_body_code s = function
+  | BCdefined (b,tp) -> BCdefined (b,subst_to_patch s tp)
+  | BCallias kn -> BCallias (fst (subst_con s kn))
+  | BCconstant -> BCconstant
+
+type to_patch_substituted = body_code substituted
+
+let from_val = from_val
+
+let force = force subst_body_code
+
+let subst_to_patch_subst = subst_substituted 
+
+let is_boxed tps =
+  match force tps with
+  | BCdefined(b,_) -> b
+  | _ -> false
+
+let to_memory (init_code, fun_code, fv) =
+  init();
+  emit init_code;
+  emit fun_code;
+  let code = String.create !out_position in
+  String.unsafe_blit !out_buffer 0 code 0 !out_position;
+  let reloc = List.rev !reloc_info in
+  Array.iter (fun lbl -> 
+    (match lbl with
+      Label_defined _ -> assert true
+    | Label_undefined patchlist -> 
+	assert (patchlist = []))) !label_table;
+  (code, reloc, fv)
+
+
+
+
+
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
new file mode 100644
index 00000000..ca6da65e
--- /dev/null
+++ b/kernel/cemitcodes.mli
@@ -0,0 +1,40 @@
+open Names
+open Cbytecodes
+
+type reloc_info =
+  | Reloc_annot of annot_switch 
+  | Reloc_const of structured_constant
+  | Reloc_getglobal of constant
+
+type patch = reloc_info * int 
+(* A virer *)
+val subst_patch : Mod_subst.substitution -> patch -> patch
+ 
+type emitcodes 
+
+val length : emitcodes -> int 
+
+val patch_int : emitcodes -> (*pos*)int -> int -> unit
+
+type to_patch = emitcodes * (patch list) * fv
+
+val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch
+
+type body_code =
+  | BCdefined of bool*to_patch
+  | BCallias of constant
+  | BCconstant
+
+
+type to_patch_substituted 
+
+val from_val : body_code -> to_patch_substituted 
+
+val force : to_patch_substituted -> body_code
+
+val is_boxed : to_patch_substituted -> bool
+
+val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted
+
+val to_memory : bytecodes * bytecodes * fv -> to_patch
+               (* init code, fun code, fv *) 
diff --git a/kernel/closure.ml b/kernel/closure.ml
index 1a635ccf..41fe8750 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: closure.ml,v 1.54.2.1 2004/07/16 19:30:23 herbelin Exp $ *)
+(* $Id: closure.ml 9215 2006-10-05 15:40:31Z herbelin $ *)
 
 open Util
 open Pp
@@ -16,7 +16,6 @@ open Declarations
 open Environ
 open Esubst
 
-
 let stats = ref false
 let share = ref true
 
@@ -52,10 +51,8 @@ let with_stats c =
   end else
     Lazy.force c
 
-type transparent_state = Idpred.t * KNpred.t
-
-let all_opaque = (Idpred.empty, KNpred.empty)
-let all_transparent = (Idpred.full, KNpred.full)
+let all_opaque = (Idpred.empty, Cpred.empty)
+let all_transparent = (Idpred.full, Cpred.full)
 
 module type RedFlagsSig = sig
   type reds
@@ -110,7 +107,7 @@ module RedFlags = (struct
     | DELTA -> { red with r_delta = true; r_const = all_transparent }
     | CONST kn ->
 	let (l1,l2) = red.r_const in
-	{ red with r_const = l1, KNpred.add kn l2 }
+	{ red with r_const = l1, Cpred.add kn l2 }
     | IOTA -> { red with r_iota = true }
     | ZETA -> { red with r_zeta = true }
     | VAR id ->
@@ -122,7 +119,7 @@ module RedFlags = (struct
     | DELTA -> { red with r_delta = false }
     | CONST kn ->
  	let (l1,l2) = red.r_const in
-	{ red with r_const = l1, KNpred.remove kn l2 }
+	{ red with r_const = l1, Cpred.remove kn l2 }
     | IOTA -> { red with r_iota = false }
     | ZETA -> { red with r_zeta = false }
     | VAR id ->
@@ -138,7 +135,7 @@ module RedFlags = (struct
     | BETA -> incr_cnt red.r_beta beta
     | CONST kn -> 
 	let (_,l) = red.r_const in
-	let c = KNpred.mem kn l in
+	let c = Cpred.mem kn l in
 	incr_cnt c delta
     | VAR id -> (* En attendant d'avoir des kn pour les Var *)
 	let (l,_) = red.r_const in
@@ -152,7 +149,7 @@ module RedFlags = (struct
   let red_get_const red =
     let p1,p2 = red.r_const in
     let (b1,l1) = Idpred.elements p1 in
-    let (b2,l2) = KNpred.elements p2 in
+    let (b2,l2) = Cpred.elements p2 in
     if b1=b2 then
       let l1' = List.map (fun x -> EvalVarRef x) l1 in
       let l2' = List.map (fun x -> EvalConstRef x) l2 in
@@ -326,11 +323,7 @@ fin obsolète **************)
  * instantiations (cbv or lazy) are.
  *)
 
-type table_key =
-  | ConstKey of constant
-  | VarKey of identifier
-  | FarRelKey of int
-   (* FarRel: index in the rel_context part of _initial_ environment *)
+type table_key = id_key
 
 type 'a infos = {
   i_flags : reds;
@@ -349,7 +342,7 @@ let ref_value_cache info ref =
   try
     let body =
       match ref with
-	| FarRelKey n ->
+	| RelKey n ->
 	    let (s,l) = info.i_rels in lift n (List.assoc (s-n) l)
 	| VarKey id -> List.assoc id info.i_vars
 	| ConstKey cst -> constant_value info.i_env cst
@@ -364,32 +357,35 @@ let ref_value_cache info ref =
 
 let defined_vars flags env =
 (*  if red_local_const (snd flags) then*)
-    fold_named_context 
-      (fun env (id,b,t) e ->
+    Sign.fold_named_context 
+      (fun (id,b,_) e ->
 	 match b with
 	   | None -> e
 	   | Some body -> (id, body)::e)
-      env ~init:[]
+       (named_context env) ~init:[]
 (*  else []*)
 
 let defined_rels flags env =
 (*  if red_local_const (snd flags) then*)
-  fold_rel_context 
-      (fun env (id,b,t) (i,subs) ->
+  Sign.fold_rel_context 
+      (fun (id,b,t) (i,subs) ->
 	 match b with
 	   | None -> (i+1, subs)
 	   | Some body -> (i+1, (i,body) :: subs))
-      env ~init:(0,[])
+      (rel_context env) ~init:(0,[])
 (*  else (0,[])*)
 
+let rec mind_equiv env (kn1,i1) (kn2,i2) =
+  let rec equiv kn1 kn2 =
+    kn1 = kn2 ||
+      match (lookup_mind kn1 env).mind_equiv with
+	  Some kn1' -> equiv kn2 kn1'
+	| None -> match (lookup_mind kn2 env).mind_equiv with
+	      Some kn2' -> equiv kn2' kn1
+	    | None -> false in
+  i1 = i2 && equiv kn1 kn2
 
-let rec mind_equiv info kn1 kn2 = 
-  kn1 = kn2 ||
-	match (lookup_mind kn1 info.i_env).mind_equiv with
-	    Some kn1' -> mind_equiv info kn2 kn1'
-	  | None -> match (lookup_mind kn2 info.i_env).mind_equiv with
-		Some kn2' -> mind_equiv info kn2' kn1
-	      | None -> false
+let mind_equiv_infos info = mind_equiv info.i_env
 
 let create mk_cl flgs env =
   { i_flags = flgs;
@@ -401,90 +397,6 @@ let create mk_cl flgs env =
 
 
 (**********************************************************************)
-(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *) 
-
-type 'a stack_member =
-  | Zapp of 'a list
-  | Zcase of case_info * 'a * 'a array
-  | Zfix of 'a * 'a stack
-  | Zshift of int
-  | Zupdate of 'a
-
-and 'a stack = 'a stack_member list
-
-let empty_stack = []
-let append_stack_list = function
-  | ([],s) -> s
-  | (l1, Zapp l :: s) -> Zapp (l1@l) :: s
-  | (l1, s) -> Zapp l1 :: s
-let append_stack v s = append_stack_list (Array.to_list v, s)
-
-(* Collapse the shifts in the stack *)
-let zshift n s =
-  match (n,s) with
-      (0,_) -> s
-    | (_,Zshift(k)::s) -> Zshift(n+k)::s
-    | _ -> Zshift(n)::s
-
-let rec stack_args_size = function
-  | Zapp l::s -> List.length l + stack_args_size s
-  | Zshift(_)::s -> stack_args_size s
-  | Zupdate(_)::s -> stack_args_size s
-  | _ -> 0
-
-(* When used as an argument stack (only Zapp can appear) *)
-let rec decomp_stack = function
-  | Zapp[v]::s -> Some (v, s)
-  | Zapp(v::l)::s -> Some (v, (Zapp l :: s))
-  | Zapp [] :: s -> decomp_stack s
-  | _ -> None
-let rec decomp_stackn = function
-  | Zapp [] :: s -> decomp_stackn s
-  | Zapp l :: s -> (Array.of_list l, s)
-  | _ -> assert false
-let array_of_stack s =
-  let rec stackrec = function
-  | [] -> []
-  | Zapp args :: s -> args :: (stackrec s)
-  | _ -> assert false
-  in Array.of_list (List.concat (stackrec s))
-let rec list_of_stack = function
-  | [] -> []
-  | Zapp args :: s -> args @ (list_of_stack s)
-  | _ -> assert false
-let rec app_stack = function
-  | f, [] -> f
-  | f, (Zapp [] :: s) -> app_stack (f, s)
-  | f, (Zapp args :: s) -> 
-      app_stack (applist (f, args), s)
-  | _ -> assert false
-let rec stack_assign s p c = match s with
-  | Zapp args :: s ->
-      let q = List.length args in 
-      if p >= q then
-	Zapp args :: stack_assign s (p-q) c
-      else
-        (match list_chop p args with
-            (bef, _::aft) -> Zapp (bef@c::aft) :: s
-          | _ -> assert false)
-  | _ -> s
-let rec stack_tail p s =
-  if p = 0 then s else
-    match s with
-      | Zapp args :: s ->
-	  let q = List.length args in
-	  if p >= q then stack_tail (p-q) s
-	  else Zapp (list_skipn p args) :: s
-      | _ -> failwith "stack_tail"
-let rec stack_nth s p = match s with
-  | Zapp args :: s ->
-      let q = List.length args in
-      if p >= q then stack_nth s (p-q)
-      else List.nth args p
-  | _ -> raise Not_found
-
-
-(**********************************************************************)
 (* Lazy reduction: the one used in kernel operations                  *)
 
 (* type of shared terms. fconstr and frterm are mutually recursive.
@@ -519,7 +431,7 @@ type fconstr = {
 and fterm =
   | FRel of int
   | FAtom of constr (* Metas and Sorts *)
-  | FCast of fconstr * fconstr
+  | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
   | FInd of inductive
   | FConstruct of constructor
@@ -539,6 +451,8 @@ let fterm_of v = v.term
 let set_norm v = v.norm <- Norm
 let is_val v = v.norm = Norm
 
+let mk_atom c = {norm=Norm;term=FAtom c}
+
 (* Could issue a warning if no is still Red, pointing out that we loose
    sharing. *)
 let update v1 (no,t) =
@@ -548,18 +462,93 @@ let update v1 (no,t) =
      v1)
   else {norm=no;term=t}
 
+(**********************************************************************)
+(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *) 
+
+type stack_member =
+  | Zapp of fconstr array
+  | Zcase of case_info * fconstr * fconstr array
+  | Zfix of fconstr * stack
+  | Zshift of int
+  | Zupdate of fconstr
+
+and stack = stack_member list
+
+let empty_stack = []
+let append_stack v s =
+  if Array.length v = 0 then s else
+  match s with
+  | Zapp l :: s -> Zapp (Array.append v l) :: s
+  | _ -> Zapp v :: s
+
+(* Collapse the shifts in the stack *)
+let zshift n s =
+  match (n,s) with
+      (0,_) -> s
+    | (_,Zshift(k)::s) -> Zshift(n+k)::s
+    | _ -> Zshift(n)::s
+
+let rec stack_args_size = function
+  | Zapp v :: s -> Array.length v + stack_args_size s
+  | Zshift(_)::s -> stack_args_size s
+  | Zupdate(_)::s -> stack_args_size s
+  | _ -> 0
+
+(* When used as an argument stack (only Zapp can appear) *)
+let rec decomp_stack = function
+  | Zapp v :: s ->
+      (match Array.length v with
+          0 -> decomp_stack s
+        | 1 -> Some (v.(0), s)
+        | _ ->
+            Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s)))
+  | _ -> None
+let rec decomp_stackn = function
+  | Zapp v :: s -> if Array.length v = 0 then decomp_stackn s else (v, s)
+  | _ -> assert false
+let array_of_stack s =
+  let rec stackrec = function
+  | [] -> []
+  | Zapp args :: s -> args :: (stackrec s)
+  | _ -> assert false
+  in Array.concat (stackrec s)
+let rec stack_assign s p c = match s with
+  | Zapp args :: s ->
+      let q = Array.length args in 
+      if p >= q then
+	Zapp args :: stack_assign s (p-q) c
+      else
+        (let nargs = Array.copy args in
+         nargs.(p) <- c;
+         Zapp nargs :: s)
+  | _ -> s
+let rec stack_tail p s = 
+  if p = 0 then s else
+    match s with
+      | Zapp args :: s ->
+	  let q = Array.length args in
+	  if p >= q then stack_tail (p-q) s
+	  else Zapp (Array.sub args p (q-p)) :: s
+      | _ -> failwith "stack_tail"
+let rec stack_nth s p = match s with
+  | Zapp args :: s ->
+      let q = Array.length args in
+      if p >= q then stack_nth s (p-q)
+      else args.(p)
+  | _ -> raise Not_found
+
 (* Lifting. Preserves sharing (useful only for cell with norm=Red).
    lft_fconstr always create a new cell, while lift_fconstr avoids it
    when the lift is 0. *)
 let rec lft_fconstr n ft =
   match ft.term with
-    | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FAtom _) -> ft
+    | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft
     | FRel i -> {norm=Norm;term=FRel(i+n)}
     | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))}
     | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))}
     | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))}
     | FLIFT(k,m) -> lft_fconstr (n+k) m
-    | FLOCKED -> anomaly "lft_constr found locked term"
+    | FLOCKED -> assert false
     | _ -> {norm=ft.norm; term=FLIFT(n,ft)}
 let lift_fconstr k f =
   if k=0 then f else lft_fconstr k f
@@ -573,7 +562,7 @@ let clos_rel e i =
     | Inl(n,mt) -> lift_fconstr n mt
     | Inr(k,None) -> {norm=Norm; term= FRel k}
     | Inr(k,Some p) ->
-        lift_fconstr (k-p) {norm=Norm;term=FFlex(FarRelKey p)}
+        lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)}
 
 (* since the head may be reducible, we might introduce lifts of 0 *)
 let compact_stack head stk =
@@ -608,10 +597,10 @@ let rec compact_constr (lg, subs as s) c k =
     | Evar(ev,v) ->
         let (v',s) = compact_vect s v k in
         if v==v' then c,s else mkEvar(ev,v'),s
-    | Cast(a,b) ->
+    | Cast(a,ck,b) ->
         let (a',s) = compact_constr s a k in
         let (b',s) = compact_constr s b k in
-        if a==a' && b==b' then c,s else mkCast(a',b'), s
+        if a==a' && b==b' then c,s else mkCast(a', ck, b'), s
     | App(f,v) ->
         let (f',s) = compact_constr s f k in
         let (v',s) = compact_vect s v k in
@@ -659,12 +648,12 @@ and compact_v acc s v k i =
 let optimise_closure env c =
   if is_subs_id env then (env,c) else
     let (c',(_,s)) = compact_constr (0,[]) c 1 in
-    let env' = List.fold_left
-      (fun subs i -> subs_cons (clos_rel env i, subs)) (ESID 0) s in
-    (env',c')
+    let env' =
+      Array.map (fun i -> clos_rel env i) (Array.of_list s) in
+    (subs_cons (env', ESID 0),c')
 
 let mk_lambda env t =
-(*  let (env,t) = optimise_closure env t in*)
+  let (env,t) = optimise_closure env t in
   let (rvars,t') = decompose_lam t in
   FLambda(List.length rvars, List.rev rvars, t', env)
 
@@ -698,9 +687,9 @@ let mk_clos_deep clos_fun env t =
   match kind_of_term t with
     | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) ->
         mk_clos env t
-    | Cast (a,b) ->
+    | Cast (a,k,b) ->
         { norm = Red;
-          term = FCast (clos_fun env a, clos_fun env b)}
+          term = FCast (clos_fun env a, k, clos_fun env b)}
     | App (f,v) ->
         { norm = Red;
 	  term = FApp (clos_fun env f, Array.map (clos_fun env) v) }
@@ -730,15 +719,11 @@ let mk_clos2 = mk_clos_deep mk_clos
 let rec to_constr constr_fun lfts v =
   match v.term with
     | FRel i -> mkRel (reloc_rel i lfts)
-    | FFlex (FarRelKey p) -> mkRel (reloc_rel p lfts)
+    | FFlex (RelKey p) -> mkRel (reloc_rel p lfts)
     | FFlex (VarKey x) -> mkVar x
-    | FAtom c ->
-        (match kind_of_term c with
-          | Sort s -> mkSort s
-          | Meta m -> mkMeta m
-          | _ -> assert false)
-    | FCast (a,b) ->
-        mkCast (constr_fun lfts a, constr_fun lfts b)
+    | FAtom c -> exliftn lfts c
+    | FCast (a,k,b) ->
+        mkCast (constr_fun lfts a, k, constr_fun lfts b)
     | FFlex (ConstKey op) -> mkConst op
     | FInd op -> mkInd op
     | FConstruct op -> mkConstruct op
@@ -781,8 +766,7 @@ let rec to_constr constr_fun lfts v =
         let fr = mk_clos2 env t in
         let unfv = update v (fr.norm,fr.term) in
         to_constr constr_fun lfts unfv
-    | FLOCKED -> (*anomaly "Closure.to_constr: found locked term"*)
-mkVar(id_of_string"_LOCK_")
+    | FLOCKED -> assert false (*mkVar(id_of_string"_LOCK_")*)
 
 (* This function defines the correspondance between constr and
    fconstr. When we find a closure whose substitution is the identity,
@@ -808,23 +792,21 @@ let rec fstrong unfreeze_fun lfts v =
   to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v)
 *)
 
-let rec zip zfun m stk =
+let rec zip m stk =
   match stk with
     | [] -> m
-    | Zapp args :: s ->
-        let args = Array.of_list args in
-        zip zfun {norm=neutr m.norm; term=FApp(m, Array.map zfun args)} s
+    | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s
     | Zcase(ci,p,br)::s ->
-        let t = FCases(ci, zfun p, m, Array.map zfun br) in
-        zip zfun {norm=neutr m.norm; term=t} s
+        let t = FCases(ci, p, m, br) in
+        zip {norm=neutr m.norm; term=t} s
     | Zfix(fx,par)::s ->
-        zip zfun fx (par @ append_stack_list ([m], s))
+        zip fx (par @ append_stack [|m|] s)
     | Zshift(n)::s ->
-        zip zfun (lift_fconstr n m) s
+        zip (lift_fconstr n m) s
     | Zupdate(rf)::s ->
-        zip zfun (update rf (m.norm,m.term)) s
+        zip (update rf (m.norm,m.term)) s
 
-let fapp_stack (m,stk) = zip (fun x -> x) m stk
+let fapp_stack (m,stk) = zip m stk
 
 (*********************************************************************)
 
@@ -849,33 +831,32 @@ let strip_update_shift_app head stk =
   let rec strip_rec rstk h depth = function
     | Zshift(k) as e :: s ->
         strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s
-    | (Zapp args :: s) as stk ->
+    | (Zapp args :: s) ->
         strip_rec (Zapp args :: rstk)
-          {norm=h.norm;term=FApp(h,Array.of_list args)} depth s
+          {norm=h.norm;term=FApp(h,args)} depth s
     | Zupdate(m)::s ->
         strip_rec rstk (update m (h.norm,h.term)) depth s
     | stk -> (depth,List.rev rstk, stk) in
   strip_rec [] head 0 stk
 
 
-let rec get_nth_arg head n stk =
+let get_nth_arg head n stk =
   assert (head.norm <> Red);
   let rec strip_rec rstk h depth n = function
     | Zshift(k) as e :: s ->
         strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s
     | Zapp args::s' ->
-        let q = List.length args in
+        let q = Array.length args in
         if n >= q
         then
           strip_rec (Zapp args::rstk)
-            {norm=h.norm;term=FApp(h,Array.of_list args)} depth (n-q) s'
+            {norm=h.norm;term=FApp(h,args)} depth (n-q) s'
         else
-          (match list_chop n args with
-              (bef, v::aft) -> 
-                let stk' =
-                  List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
-                (Some (stk', v), append_stack_list (aft,s'))
-            | _ -> assert false)
+          let bef = Array.sub args 0 n in
+          let aft = Array.sub args (n+1) (q-n-1) in
+          let stk' =
+            List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
+          (Some (stk', args.(n)), append_stack aft s')
     | Zupdate(m)::s ->
         strip_rec rstk (update m (h.norm,h.term)) depth n s
     | s -> (None, List.rev rstk @ s) in
@@ -892,23 +873,20 @@ let get_arg h stk =
 let rec get_args n tys f e stk =
   match stk with
       Zupdate r :: s ->
-        let hd = update r (Cstr,FLambda(n,tys,f,e)) in
+        let _hd = update r (Cstr,FLambda(n,tys,f,e)) in
         get_args n tys f e s
     | Zshift k :: s ->
         get_args n tys f (subs_shft (k,e)) s
     | Zapp l :: s ->
-        let na = List.length l in
-        if n == na then
-          let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e l in
-          (Inl e',s)
+        let na = Array.length l in
+        if n == na then (Inl (subs_cons(l,e)),s)
         else if n < na then (* more arguments *)
-          let (args,eargs) = list_chop n l in
-          let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e args in
-          (Inl e', Zapp eargs :: s)
+          let args = Array.sub l 0 n in
+          let eargs = Array.sub l n (na-n) in
+          (Inl (subs_cons(args,e)), Zapp eargs :: s)
         else (* more lambdas *)
-          let (_,etys) = list_chop na tys in
-          let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e l in
-          get_args (n-na) etys f e' s
+          let etys = list_skipn na tys in
+          get_args (n-na) etys f (subs_cons(l,e)) s
     | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk)
 
 
@@ -917,7 +895,7 @@ let rec get_args n tys f e stk =
 let rec reloc_rargs_rec depth stk =
   match stk with
       Zapp args :: s ->
-        Zapp (lift_fconstr_list depth args) :: reloc_rargs_rec depth s
+        Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s
     | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s
     | _ -> stk
 
@@ -927,12 +905,12 @@ let reloc_rargs depth stk =
 let rec drop_parameters depth n stk =
   match stk with
       Zapp args::s ->
-        let q = List.length args in
+        let q = Array.length args in
         if n > q then drop_parameters depth (n-q) s
         else if n = q then reloc_rargs depth s
         else
-          let aft = list_skipn n args in
-          reloc_rargs depth (append_stack_list (aft,s))
+          let aft = Array.sub args n (q-n) in
+          reloc_rargs depth (append_stack aft s)
     | Zshift(k)::s -> drop_parameters (depth-k) n s
     | [] -> assert (n=0); []
     | _ -> assert false (* we know that n < stack_args_size(stk) *)
@@ -958,15 +936,9 @@ let contract_fix_vect fix =
           (bds.(i),
 	   (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }),
 	   env, Array.length bds)
-      | _ -> anomaly "Closure.contract_fix_vect: not a (co)fixpoint" 
+      | _ -> assert false
   in
-  let rec subst_bodies_from_i i env =
-    if i = nfix then
-      (env, thisbody)
-    else
-      subst_bodies_from_i (i+1) (subs_cons (make_body i, env))
-  in       
-  subst_bodies_from_i 0 env
+  (subs_cons(Array.init nfix make_body, env), thisbody)
 
 
 (*********************************************************************)
@@ -978,14 +950,14 @@ let rec knh m stk =
   match m.term with
     | FLIFT(k,a) -> knh a (zshift k stk)
     | FCLOS(t,e) -> knht e t (zupdate m stk)
-    | FLOCKED -> anomaly "Closure.knh: found lock"
+    | FLOCKED -> assert false
     | FApp(a,b) -> knh a (append_stack b (zupdate m stk))
     | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk)
     | FFix(((ri,n),(_,_,_)),_) ->
         (match get_nth_arg m ri.(n) stk with
              (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk')
            | (None, stk') -> (m,stk'))
-    | FCast(t,_) -> knh t stk
+    | FCast(t,_,_) -> knh t stk
 (* cases where knh stops *)
     | (FFlex _|FLetIn _|FConstruct _|FEvar _|
        FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) ->
@@ -999,7 +971,7 @@ and knht e t stk =
     | Case(ci,p,t,br) ->
         knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk)
     | Fix _ -> knh (mk_clos2 e t) stk
-    | Cast(a,b) -> knht e a stk
+    | Cast(a,_,_) -> knht e a stk
     | Rel n -> knh (clos_rel e n) stk
     | (Lambda _|Prod _|Construct _|CoFix _|Ind _|
        LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
@@ -1023,8 +995,8 @@ let rec knr info m stk =
       (match ref_value_cache info (VarKey id) with
           Some v -> kni info v stk
         | None -> (set_norm m; (m,stk)))
-  | FFlex(FarRelKey k) when red_set info.i_flags fDELTA ->
-      (match ref_value_cache info (FarRelKey k) with
+  | FFlex(RelKey k) when red_set info.i_flags fDELTA ->
+      (match ref_value_cache info (RelKey k) with
           Some v -> kni info v stk
         | None -> (set_norm m; (m,stk)))
   | FConstruct(ind,c) when red_set info.i_flags fIOTA ->
@@ -1046,7 +1018,7 @@ let rec knr info m stk =
             knit info fxe fxbd (args@stk')
         | (_,args,s) -> (m,args@s))
   | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA ->
-      knit info (subs_cons(v,e)) bd stk
+      knit info (subs_cons([|v|],e)) bd stk
   | _ -> (m,stk)
 
 (* Computes the weak head normal form of a term *)
@@ -1065,7 +1037,6 @@ let rec zip_term zfun m stk =
   match stk with
     | [] -> m
     | Zapp args :: s ->
-        let args = Array.of_list args in
         zip_term zfun (mkApp(m, Array.map zfun args)) s
     | Zcase(ci,p,br)::s ->
         let t = mkCase(ci, zfun p, m, Array.map zfun br) in
diff --git a/kernel/closure.mli b/kernel/closure.mli
index e58b91eb..924da0a5 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: closure.mli,v 1.42.2.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+(*i $Id: closure.mli 9215 2006-10-05 15:40:31Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -27,7 +27,7 @@ val with_stats: 'a Lazy.t -> 'a
   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
   a LetIn expression is Letin reduction *)
 
-type transparent_state = Idpred.t * KNpred.t
+
 
 val all_opaque      : transparent_state
 val all_transparent : transparent_state
@@ -82,13 +82,8 @@ val betadeltaiotanolet : reds
 
 val unfold_red : evaluable_global_reference -> reds
 
-(************************************************************************)
-
-type table_key =
-  | ConstKey of constant
-  | VarKey of identifier
-  | FarRelKey of int
-   (* FarRel: index in the [rel_context] part of {\em initial} environment *)
+(***********************************************************************)
+type table_key = id_key
 
 type 'a infos
 val ref_value_cache: 'a infos -> table_key -> 'a option
@@ -96,32 +91,6 @@ val info_flags: 'a infos -> reds
 val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos
 
 (************************************************************************)
-(*s A [stack] is a context of arguments, arguments are pushed by
-   [append_stack] one array at a time but popped with [decomp_stack]
-   one by one *)
-
-type 'a stack_member =
-  | Zapp of 'a list
-  | Zcase of case_info * 'a * 'a array
-  | Zfix of 'a * 'a stack
-  | Zshift of int
-  | Zupdate of 'a
-
-and 'a stack = 'a stack_member list
-
-val empty_stack : 'a stack
-val append_stack : 'a array -> 'a stack -> 'a stack
-
-val decomp_stack : 'a stack -> ('a * 'a stack) option
-val list_of_stack : 'a stack -> 'a list
-val array_of_stack : 'a stack -> 'a array
-val stack_assign : 'a stack -> int -> 'a -> 'a stack
-val stack_args_size : 'a stack -> int
-val app_stack : constr * constr stack -> constr
-val stack_tail : int -> 'a stack -> 'a stack
-val stack_nth : 'a stack -> int -> 'a
-
-(************************************************************************)
 (*s Lazy reduction. *)
 
 (* [fconstr] is the type of frozen constr *)
@@ -134,7 +103,7 @@ type fconstr
 type fterm =
   | FRel of int
   | FAtom of constr (* Metas and Sorts *)
-  | FCast of fconstr * fconstr
+  | FCast of fconstr * cast_kind * fconstr 
   | FFlex of table_key
   | FInd of inductive
   | FConstruct of constructor
@@ -150,11 +119,39 @@ type fterm =
   | FCLOS of constr * fconstr subs
   | FLOCKED
 
+(************************************************************************)
+(*s A [stack] is a context of arguments, arguments are pushed by
+   [append_stack] one array at a time but popped with [decomp_stack]
+   one by one *)
+
+type stack_member =
+  | Zapp of fconstr array
+  | Zcase of case_info * fconstr * fconstr array
+  | Zfix of fconstr * stack
+  | Zshift of int
+  | Zupdate of fconstr
+
+and stack = stack_member list
+
+val empty_stack : stack
+val append_stack : fconstr array -> stack -> stack
+
+val decomp_stack : stack -> (fconstr * stack) option
+val array_of_stack : stack -> fconstr array
+val stack_assign : stack -> int -> fconstr -> stack
+val stack_args_size : stack -> int
+val stack_tail : int -> stack -> stack
+val stack_nth : stack -> int -> fconstr
+val zip_term : (fconstr -> constr) -> constr -> stack -> constr
+
 (* To lazy reduce a constr, create a [clos_infos] with
    [create_clos_infos], inject the term to reduce with [inject]; then use
    a reduction function *)
 
 val inject : constr -> fconstr
+(* mk_atom: prevents a term from being evaluated *)
+val mk_atom : constr -> fconstr
+
 val fterm_of : fconstr -> fterm
 val term_of_fconstr : fconstr -> constr
 val destFLambda :
@@ -175,15 +172,16 @@ val whd_val : clos_infos -> fconstr -> constr
 (* [whd_stack] performs weak head normalization in a given stack. It
    stops whenever a reduction is blocked. *)
 val whd_stack :
-  clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack
+  clos_infos -> fconstr -> stack -> fconstr * stack
 
 (* Conversion auxiliary functions to do step by step normalisation *)
 
 (* [unfold_reference] unfolds references in a [fconstr] *)
 val unfold_reference : clos_infos -> table_key -> fconstr option
 
-(* [mind_equiv] checks whether two mutual inductives are intentionally equal *)
-val mind_equiv : clos_infos -> mutual_inductive -> mutual_inductive -> bool
+(* [mind_equiv] checks whether two inductive types are intentionally equal *)
+val mind_equiv : env -> inductive -> inductive -> bool
+val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool
 
 (************************************************************************)
 (*i This is for lazy debug *)
@@ -197,8 +195,8 @@ val mk_clos_deep :
   (fconstr subs -> constr -> fconstr) ->
    fconstr subs -> constr -> fconstr
 
-val kni: clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack
-val knr: clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack
+val kni: clos_infos -> fconstr -> stack -> fconstr * stack
+val knr: clos_infos -> fconstr -> stack -> fconstr * stack
 val kl : clos_infos -> fconstr -> constr
 
 val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index dba373ce..4c692308 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -6,18 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: conv_oracle.ml,v 1.2.8.2 2004/07/16 19:30:24 herbelin Exp $ *)
+(* $Id: conv_oracle.ml 6303 2004-11-16 12:37:40Z sacerdot $ *)
 
 open Names
-open Closure
 
 (* Opaque constants *)
-let cst_transp = ref KNpred.full
+let cst_transp = ref Cpred.full
 
-let set_opaque_const kn = cst_transp := KNpred.remove kn !cst_transp
-let set_transparent_const kn = cst_transp := KNpred.add kn !cst_transp
+let set_opaque_const kn = cst_transp := Cpred.remove kn !cst_transp
+let set_transparent_const kn = cst_transp := Cpred.add kn !cst_transp
 
-let is_opaque_cst kn = not (KNpred.mem kn !cst_transp)
+let is_opaque_cst kn = not (Cpred.mem kn !cst_transp)
 
 (* Opaque variables *)
 let var_transp = ref Idpred.full
@@ -31,13 +30,13 @@ let is_opaque_var kn = not (Idpred.mem kn !var_transp)
 let is_opaque = function
   | ConstKey cst -> is_opaque_cst cst
   | VarKey id -> is_opaque_var id
-  | FarRelKey _ -> false
+  | RelKey _ -> false
 
 (* Unfold the first only if it is not opaque and the second is opaque *)
 let oracle_order k1 k2 = is_opaque k2 & not (is_opaque k1)
 
 (* summary operations *)
-
-let init() = (cst_transp := KNpred.full; var_transp := Idpred.full)
+type transparent_state = Idpred.t * Cpred.t
+let init() = (cst_transp := Cpred.full; var_transp := Idpred.full)
 let freeze () = (!var_transp, !cst_transp)
 let unfreeze (vo,co) = (cst_transp := co; var_transp := vo)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index 8d0c12bb..966edd1d 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -6,16 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: conv_oracle.mli,v 1.3.8.3 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: conv_oracle.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 open Names
-open Closure
+
 
 (* Order on section paths for unfolding.
    If [oracle_order kn1 kn2] is true, then unfold kn1 first.
    Note: the oracle does not introduce incompleteness, it only
    tries to postpone unfolding of "opaque" constants. *)
-val oracle_order : table_key -> table_key -> bool
+val oracle_order : 'a tableKey -> 'a tableKey -> bool
 
 (* Changing the oracle *)
 val set_opaque_const      : constant -> unit
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index d69efe3a..6b2a6245 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.ml,v 1.17.8.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+(*i $Id: cooking.ml 9320 2006-10-30 16:53:43Z barras $ i*)
 
 open Pp
 open Util
@@ -19,154 +19,116 @@ open Reduction
 
 (*s Cooking the constants. *)
 
-type 'a modification =
-  | NOT_OCCUR
-  | DO_ABSTRACT of 'a * constr array
-  | DO_REPLACE of constant_body
+type work_list = identifier array Cmap.t * identifier array KNmap.t
 
-type work_list =
-    (constant * constant modification) list
-    * (inductive * inductive modification) list
-    * (constructor * constructor modification) list
+let dirpath_prefix p = match repr_dirpath p with
+  | [] -> anomaly "dirpath_prefix: empty dirpath"
+  | _::l -> make_dirpath l
 
-type recipe = {
-  d_from : constant_body;
-  d_abstract : identifier list;
-  d_modlist : work_list }
+let pop_kn kn =
+  let (mp,dir,l) = Names.repr_kn kn in
+  Names.make_kn mp (dirpath_prefix dir) l
+
+let pop_con con = 
+  let (mp,dir,l) = Names.repr_con con in
+  Names.make_con mp (dirpath_prefix dir) l
+
+type my_global_reference =
+  | ConstRef of constant
+  | IndRef of inductive
+  | ConstructRef of constructor
+
+let cache = (Hashtbl.create 13 : (my_global_reference, constr) Hashtbl.t)
+
+let clear_cooking_sharing () = Hashtbl.clear cache
+
+let share r (cstl,knl) =
+  try Hashtbl.find cache r
+  with Not_found ->
+  let f,l =
+    match r with
+    | IndRef (kn,i) -> 
+	mkInd (pop_kn kn,i), KNmap.find kn knl
+    | ConstructRef ((kn,i),j) -> 
+	mkConstruct ((pop_kn kn,i),j), KNmap.find kn knl
+    | ConstRef cst ->
+	mkConst (pop_con cst), Cmap.find cst cstl in
+  let c = mkApp (f, Array.map mkVar l) in
+  Hashtbl.add cache r c;
+  (* has raised Not_found if not in work_list *)
+  c
 
-let failure () =
-  anomalylabstrm "generic__modify_opers"
-    (str"An oper which was never supposed to appear has just appeared" ++
-     spc () ++ str"Either this is in system code, and you need to" ++ spc () ++
-     str"report this error," ++ spc () ++
-     str"Or you are using a user-written tactic which calls" ++ spc () ++
-     str"generic__modify_opers, in which case the user-written code" ++
-     spc () ++ str"is broken - this function is an internal system" ++
-     spc () ++ str"for internal system use only")
-
-let modify_opers replfun (constl,indl,cstrl) =
+let update_case_info ci modlist =
+  try
+    let ind, n = 
+      match kind_of_term (share (IndRef ci.ci_ind) modlist) with
+      | App (f,l) -> (destInd f, Array.length l)
+      | Ind ind -> ind, 0
+      | _ -> assert false in
+    { ci with ci_ind = ind; ci_npar = ci.ci_npar + n }
+  with Not_found ->
+    ci
+
+let empty_modlist = (Cmap.empty, KNmap.empty)
+
+let expmod_constr modlist c =
   let rec substrec c =
-    let c' = map_constr substrec c in
-    match kind_of_term c' with
+    match kind_of_term c with
       | Case (ci,p,t,br) ->
+	  map_constr substrec (mkCase (update_case_info ci modlist,p,t,br))
+
+      | Ind ind ->
 	  (try
-	     match List.assoc ci.ci_ind indl with
-	       | DO_ABSTRACT (ind,abs_vars) ->
-		   let n' = Array.length abs_vars + ci.ci_npar in
-                   let ci' = { ci with
-                               ci_ind = ind;
-                               ci_npar = n' } in
-		   mkCase (ci',p,t,br)
-	       | _ -> raise Not_found
-	   with
-	     | Not_found -> c')
-
-      | Ind spi ->
-	  (try
-	     (match List.assoc spi indl with
-		| NOT_OCCUR -> failure ()
-		| DO_ABSTRACT (oper',abs_vars) ->
-                    mkApp (mkInd oper', abs_vars)
-		| DO_REPLACE _ -> assert false)
+	    share (IndRef ind) modlist
 	   with 
-	     | Not_found -> c')
-
-      | Construct spi ->
+	    | Not_found -> map_constr substrec c)
+	  
+      | Construct cstr ->
 	  (try
-	     (match List.assoc spi cstrl with
-		| NOT_OCCUR -> failure ()
-		| DO_ABSTRACT (oper',abs_vars) ->
-		    mkApp (mkConstruct oper', abs_vars)
-		| DO_REPLACE _ -> assert false)
+	    share (ConstructRef cstr) modlist
 	   with 
-	     | Not_found -> c')
-
-      | Const kn ->
+	    | Not_found -> map_constr substrec c)
+	  
+      | Const cst ->
 	  (try
-	     (match List.assoc kn constl with
-		| NOT_OCCUR -> failure ()
-		| DO_ABSTRACT (oper',abs_vars) ->
-		    mkApp (mkConst oper', abs_vars)
-		| DO_REPLACE cb -> substrec (replfun (kn,cb)))
+	    share (ConstRef cst) modlist
 	   with 
-	     | Not_found -> c')
-  
-    | _ -> c'
-  in 
-  if (constl,indl,cstrl) = ([],[],[]) then fun x -> x else substrec
+	    | Not_found -> map_constr substrec c)
+
+  | _ -> map_constr substrec c
 
-let expmod_constr modlist c =
-  let simpfun = 
-    if modlist = ([],[],[]) then fun x -> x else nf_betaiota in
-  let expfun (kn,cb) = 
-    if cb.const_opaque then
-      errorlabstrm "expmod_constr"
-	(str"Cannot unfold the value of " ++
-        str(string_of_kn kn) ++ spc () ++
-        str"You cannot declare local lemmas as being opaque" ++ spc () ++
-        str"and then require that theorems which use them" ++ spc () ++
-        str"be transparent");
-    match cb.const_body with
-      | Some body -> Declarations.force body
-      | None -> assert false
-  in
-  let c' = modify_opers expfun modlist c in
-  match kind_of_term c' with
-    | Cast (value,typ) -> mkCast (simpfun value,simpfun typ)
-    | _ -> simpfun c'
-
-let expmod_type modlist c =
-  type_app (expmod_constr modlist) c
-
-let abstract_constant ids_to_abs hyps (body,typ) =
-  let abstract_once_typ ((hyps,typ) as sofar) id =
-    match hyps with
-      | (hyp,c,t as decl)::rest when hyp = id ->
-	  let typ' = mkNamedProd_wo_LetIn decl typ in
-	  (rest, typ')
-      | _ -> 
-	  sofar
-  in
-  let abstract_once_body ((hyps,body) as sofar) id =
-    match hyps with
-      | (hyp,c,t as decl)::rest when hyp = id ->
-	  let body' = mkNamedLambda_or_LetIn decl body in
-	  (rest, body')
-      | _ -> 
-	  sofar
-  in
-  let (_,typ') =
-    List.fold_left abstract_once_typ (hyps,typ) ids_to_abs 
-  in
-  let body' = match body with
-      None -> None
-    | Some l_body -> 
-	Some (Declarations.from_val
-		(let body = Declarations.force l_body in
-		 let (_,body') = 
-		   List.fold_left abstract_once_body (hyps,body) ids_to_abs
-		 in
-		   body'))
   in
-    (body',typ')
+  if modlist = empty_modlist then c
+  else under_outer_cast nf_betaiota (substrec c)
+
+let abstract_constant_type =
+   List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c)
+
+let abstract_constant_body =
+  List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c)
+
+type recipe = {
+  d_from : constant_body;
+  d_abstract : named_context;
+  d_modlist : work_list }
+
+let on_body f = 
+  option_map (fun c -> Declarations.from_val (f (Declarations.force c)))
 
 let cook_constant env r =
   let cb = r.d_from in
-  let typ = expmod_type r.d_modlist cb.const_type in
-  let body = 
-    option_app 
-      (fun lconstr -> 
-	 Declarations.from_val 
-	   (expmod_constr r.d_modlist (Declarations.force lconstr))) 
-      cb.const_body
-  in
-  let hyps =
-    Sign.fold_named_context
-      (fun d ctxt ->
-        Sign.add_named_decl
-          (map_named_declaration (expmod_constr r.d_modlist) d)
-          ctxt)
-      cb.const_hyps
-      ~init:empty_named_context in
-  let body,typ = abstract_constant r.d_abstract hyps (body,typ) in
-  (body, typ, cb.const_constraints, cb.const_opaque)
+  let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in
+  let body =
+    on_body (fun c ->
+      abstract_constant_body (expmod_constr r.d_modlist c) hyps) 
+      cb.const_body in
+  let typ = match cb.const_type with
+    | NonPolymorphicType t ->
+	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
+	NonPolymorphicType typ
+    | PolymorphicArity (ctx,s) ->
+	let t = mkArity (ctx,Type s.poly_level) in
+	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
+	Typeops.make_polymorphic_if_arity env typ in
+  let boxed = Cemitcodes.is_boxed cb.const_body_code in
+  (body, typ, cb.const_constraints, cb.const_opaque, boxed)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index 54526e99..93c2ccc9 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cooking.mli,v 1.9.8.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+(*i $Id: cooking.mli 9310 2006-10-28 19:35:09Z herbelin $ i*)
 
 open Names
 open Term
@@ -16,27 +16,22 @@ open Univ
 
 (*s Cooking the constants. *)
 
-type 'a modification =
-  | NOT_OCCUR
-  | DO_ABSTRACT of 'a * constr array
-  | DO_REPLACE of constant_body
-
-type work_list =
-    (constant * constant modification) list
-    * (inductive * inductive modification) list
-    * (constructor * constructor modification) list
+type work_list = identifier array Cmap.t * identifier array KNmap.t
 
 type recipe = {
   d_from : constant_body;
-  d_abstract : identifier list;
+  d_abstract : Sign.named_context;
   d_modlist : work_list }
 
 val cook_constant :
-  env -> recipe -> constr_substituted option * constr * constraints * bool
+  env -> recipe -> 
+    constr_substituted option * constant_type * constraints * bool * bool
 
 (*s Utility functions used in module [Discharge]. *)
 
 val expmod_constr : work_list -> constr -> constr
-val expmod_type : work_list -> types -> types
+
+val clear_cooking_sharing : unit -> unit
+
 
 
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
new file mode 100644
index 00000000..fc2d0925
--- /dev/null
+++ b/kernel/csymtable.ml
@@ -0,0 +1,179 @@
+open Names
+open Term
+open Vm
+open Cemitcodes
+open Cbytecodes
+open Declarations
+open Pre_env
+open Cbytegen
+
+
+external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code"
+external free_tcode : tcode -> unit = "coq_static_free"
+external eval_tcode : tcode -> values array -> values = "coq_eval_tcode"
+ 
+(*******************)
+(* Linkage du code *)
+(*******************)
+
+(* Table des globaux *)
+
+(* [global_data] contient les valeurs des constantes globales 
+   (axiomes,definitions), les annotations des switch et les structured 
+   constant *)
+external global_data : unit -> values array = "get_coq_global_data"
+
+(* [realloc_global_data n] augmente de n la taille de [global_data] *)
+external realloc_global_data : int -> unit = "realloc_coq_global_data"
+
+let check_global_data n =
+  if n >= Array.length (global_data()) then realloc_global_data n
+  
+let num_global = ref 0
+
+let set_global v = 
+  let n = !num_global in
+  check_global_data n;
+  (global_data()).(n) <- v;
+  incr num_global;
+  n
+
+(* [global_transp],[global_boxed] contiennent les valeurs des 
+   definitions gelees. Les deux versions sont maintenues en //. 
+   [global_transp] contient la version transparente.
+   [global_boxed] contient la version gelees. *)
+
+external global_boxed : unit -> bool array = "get_coq_global_boxed"
+
+(* [realloc_global_data n] augmente de n la taille de [global_data] *)
+external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed"
+
+let check_global_boxed n =
+  if n >= Array.length (global_boxed()) then realloc_global_boxed n
+  
+let num_boxed = ref 0
+
+let boxed_tbl = Hashtbl.create 53
+
+let cst_opaque = ref Cpred.full
+
+let is_opaque kn = Cpred.mem kn !cst_opaque
+
+let set_global_boxed kn v = 
+  let n = !num_boxed in
+  check_global_boxed n;
+  (global_boxed()).(n) <- (is_opaque kn);
+  Hashtbl.add boxed_tbl kn n ;
+  incr num_boxed;
+  set_global (val_of_constant_def n kn v)
+
+(* table pour les structured_constant et les annotations des switchs *)
+
+let str_cst_tbl = Hashtbl.create 31
+    (* (structured_constant * int) Hashtbl.t*)
+
+let annot_tbl = Hashtbl.create 31
+    (* (annot_switch * int) Hashtbl.t  *)
+
+(*************************************************************)
+(*** Mise a jour des valeurs des variables et des constantes *)
+(*************************************************************)
+
+exception NotEvaluated
+
+let key rk =
+  match !rk with
+  | Some k -> k
+  | _ -> raise NotEvaluated
+
+(************************)
+(* traduction des patch *)
+
+(* slot_for_*, calcul la valeur de l'objet, la place
+   dans la table global, rend sa position dans la table *)
+ 
+let slot_for_str_cst key =
+  try Hashtbl.find str_cst_tbl key 
+  with Not_found -> 
+    let n = set_global (val_of_str_const key) in
+    Hashtbl.add str_cst_tbl key n;
+    n
+
+let slot_for_annot key =
+  try Hashtbl.find annot_tbl key 
+  with Not_found -> 
+    let n =  set_global (Obj.magic key) in
+    Hashtbl.add annot_tbl key n;
+    n
+
+let rec slot_for_getglobal env kn =
+  let (cb,rk) = lookup_constant_key kn env in
+  try key rk
+  with NotEvaluated ->
+    let pos =
+      match Cemitcodes.force cb.const_body_code with
+      | BCdefined(boxed,(code,pl,fv)) -> 
+	let v = eval_to_patch env (code,pl,fv) in
+  	if boxed then set_global_boxed kn v 
+	else set_global v 
+    | BCallias kn' -> slot_for_getglobal env kn' 
+    | BCconstant -> set_global (val_of_constant kn) in
+    rk := Some pos;
+    pos
+
+and slot_for_fv env fv=
+  match fv with
+  | FVnamed id -> 
+      let nv = lookup_named_val id env in
+      begin
+	match !nv with
+	| VKvalue v -> v
+	| VKaxiom id ->
+	    let v = val_of_named id in
+	    nv := VKvalue v; v
+	| VKdef c ->
+	    let v = val_of_constr (env_of_named id env) c in
+	    nv := VKvalue v; v
+      end
+  | FVrel i ->
+      let rv = lookup_rel_val i env in
+      begin
+	match !rv with
+	| VKvalue v -> v
+	| VKaxiom k ->
+	    let v = val_of_rel k in
+	    rv := VKvalue v; v
+	| VKdef c ->
+	    let v = val_of_constr (env_of_rel i env) c in
+	    rv := VKvalue v; v
+      end
+ 
+and eval_to_patch env (buff,pl,fv) = 
+  let patch = function
+    | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a)
+    | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc)
+    | Reloc_getglobal kn, pos -> 
+	patch_int buff pos (slot_for_getglobal env kn)
+  in 
+  List.iter patch pl;
+  let vm_env = Array.map (slot_for_fv env) fv in 
+  let tc = tcode_of_code buff (length buff) in
+  eval_tcode tc vm_env
+
+and val_of_constr env c = 
+  let (_,fun_code,_ as ccfv) = 
+    try compile env c 
+    with e -> print_string "can not compile \n";Format.print_flush();raise e in
+  eval_to_patch env (to_memory ccfv)
+ 
+let set_transparent_const kn =
+  cst_opaque := Cpred.remove kn !cst_opaque;
+  List.iter (fun n -> (global_boxed()).(n) <- false) 
+    (Hashtbl.find_all boxed_tbl kn)
+
+let set_opaque_const kn =
+  cst_opaque := Cpred.add kn !cst_opaque;
+  List.iter (fun n -> (global_boxed()).(n) <- true) 
+    (Hashtbl.find_all boxed_tbl kn)
+
+
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
new file mode 100644
index 00000000..2640a4df
--- /dev/null
+++ b/kernel/csymtable.mli
@@ -0,0 +1,8 @@
+open Names
+open Term
+open Pre_env
+
+val val_of_constr : env -> constr -> values 
+
+val set_opaque_const      : constant -> unit
+val set_transparent_const : constant -> unit
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index ac2c52cc..e5e05eb3 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.ml,v 1.31.2.2 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: declarations.ml 9310 2006-10-28 19:35:09Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -14,44 +14,53 @@ open Names
 open Univ
 open Term
 open Sign
+open Mod_subst
 (*i*)
 
 (* This module defines the types of global declarations. This includes
    global constants/axioms and mutual inductive definitions *)
 
+type engagement = ImpredicativeSet
+
+
 (*s Constants (internal representation) (Definition/Axiom) *)
 
-type subst_internal = 
-  | Constr of constr 
-  | LazyConstr of substitution * constr
+type polymorphic_arity = {
+  poly_param_levels : universe option list;
+  poly_level : universe;
+}
+
+type constant_type =
+  | NonPolymorphicType of types
+  | PolymorphicArity of rel_context * polymorphic_arity
 
-type constr_substituted = subst_internal ref
+type constr_substituted = constr substituted
 
-let from_val c = ref (Constr c)
+let from_val = from_val
 
-let force cs = match !cs with
-    Constr c -> c
-  | LazyConstr (subst,c) -> 
-      let c' = subst_mps subst c in
-	cs := Constr c';
-	c'
+let force = force subst_mps 
 
-let subst_constr_subst subst cs = match !cs with
-    Constr c -> ref (LazyConstr (subst,c))
-  | LazyConstr (subst',c) -> 
-      let subst'' = join subst' subst in
-	ref (LazyConstr (subst'',c))
+let subst_constr_subst = subst_substituted
 
 type constant_body = {
-  const_hyps : section_context; (* New: younger hyp at top *)
-  const_body : constr_substituted option;
-  const_type : types;
-  const_constraints : constraints;
-  const_opaque : bool }
+    const_hyps : section_context; (* New: younger hyp at top *)
+    const_body : constr_substituted option;
+    const_type : constant_type;
+    const_body_code : Cemitcodes.to_patch_substituted;
+   (* const_type_code : Cemitcodes.to_patch; *)
+    const_constraints : constraints;
+    const_opaque : bool }
 
 (*s Inductive types (internal representation with redundant
     information). *)
 
+let subst_rel_declaration sub (id,copt,t as x) =
+  let copt' = option_smartmap (subst_mps sub) copt in
+  let t' = subst_mps sub t in
+  if copt == copt' & t == t' then x else (id,copt',t')
+
+let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
+
 type recarg = 
   | Norec 
   | Mrec of int 
@@ -82,72 +91,155 @@ let recarg_length p j =
 
 let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
 
-(* [mind_typename] is the name of the inductive; [mind_arity] is
-   the arity generalized over global parameters; [mind_lc] is the list
-   of types of constructors generalized over global parameters and
-   relative to the global context enriched with the arities of the
-   inductives *) 
+(**********************************************************************)
+(* Representation of mutual inductive types in the kernel             *)
+(*
+   Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
+   ...
+   with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
+*)
 
-type one_inductive_body = {
-  mind_typename : identifier;
-  mind_nparams : int;
-  mind_params_ctxt : rel_context;
-  mind_nrealargs : int;
-  mind_nf_arity : types;
-  mind_user_arity : types;
+type monomorphic_inductive_arity = {
+  mind_user_arity : constr;
   mind_sort : sorts;
-  mind_kelim : sorts_family list;
-  mind_consnames : identifier array;
-  mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *)
-  mind_user_lc : types array;
-  mind_recargs : wf_paths;
- }
+}
+
+type inductive_arity = 
+| Monomorphic of monomorphic_inductive_arity
+| Polymorphic of polymorphic_arity
+
+type one_inductive_body = {
+
+(* Primitive datas *)
+
+ (* Name of the type: [Ii] *)
+    mind_typename : identifier;
+
+ (* Arity context of [Ii] with parameters: [forall params, Ui] *)
+    mind_arity_ctxt : rel_context;
+
+ (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *)
+    mind_arity : inductive_arity;
+
+ (* Names of the constructors: [cij] *)
+    mind_consnames : identifier array;
+
+ (* Types of the constructors with parameters: [forall params, Tij],
+    where the Ik are replaced by de Bruijn index in the context
+    I1:forall params, U1 ..  In:forall params, Un *)
+    mind_user_lc : types array;
+
+(* Derived datas *)
+
+ (* Number of expected real arguments of the type (no let, no params) *)
+    mind_nrealargs : int;
+
+ (* List of allowed elimination sorts *)
+    mind_kelim : sorts_family list;
+
+ (* Head normalized constructor types so that their conclusion is atomic *)
+    mind_nf_lc : types array;
+
+ (* Length of the signature of the constructors (with let, w/o params) *)
+    mind_consnrealdecls : int array;
+
+ (* Signature of recursive arguments in the constructors *)
+    mind_recargs : wf_paths;
+
+(* Datas for bytecode compilation *)
+
+ (* number of constant constructor *)
+    mind_nb_constant : int;
+
+ (* number of no constant constructor *)
+    mind_nb_args : int;
+
+    mind_reloc_tbl :  Cbytecodes.reloc_table; 
+  }
 
 type mutual_inductive_body = {
-  mind_record : bool;
-  mind_finite : bool;
-  mind_ntypes : int;
-  mind_hyps : section_context;
-  mind_packets : one_inductive_body array;
-  mind_constraints : constraints;
-  mind_equiv : kernel_name option
- }
+
+  (* The component of the mutual inductive block *)
+    mind_packets : one_inductive_body array;
+
+  (* Whether the inductive type has been declared as a record *)
+    mind_record : bool;
+
+  (* Whether the type is inductive or coinductive *)
+    mind_finite : bool;
+
+  (* Number of types in the block *)
+    mind_ntypes : int;
+
+  (* Section hypotheses on which the block depends *)
+    mind_hyps : section_context;
+
+  (* Number of expected parameters *)
+    mind_nparams : int;
+
+  (* Number of recursively uniform (i.e. ordinary) parameters *)
+    mind_nparams_rec : int;
+
+  (* The context of parameters (includes let-in declaration) *)
+    mind_params_ctxt : rel_context;
+
+  (* Universes constraints enforced by the inductive declaration *)
+    mind_constraints : constraints;
+
+  (* Source of the inductive block when aliased in a module *)
+    mind_equiv : kernel_name option
+  }
+
+let subst_arity sub = function
+| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
+| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
 
 (* TODO: should be changed to non-coping after Term.subst_mps *)
-let subst_const_body sub cb = 
-  { const_body = option_app (subst_constr_subst sub) cb.const_body;
-    const_type = type_app (Term.subst_mps sub) cb.const_type;
+let subst_const_body sub cb = {
     const_hyps = (assert (cb.const_hyps=[]); []);
+    const_body = option_map (subst_constr_subst sub) cb.const_body;
+    const_type = subst_arity sub cb.const_type;
+    const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
+    (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*)
     const_constraints = cb.const_constraints;
-    const_opaque = cb.const_opaque}
-  
+    const_opaque = cb.const_opaque } 
+
+let subst_arity sub = function
+| Monomorphic s ->
+    Monomorphic {
+      mind_user_arity = subst_mps sub s.mind_user_arity;
+      mind_sort = s.mind_sort;
+    }
+| Polymorphic s as x -> x
+
 let subst_mind_packet sub mbp = 
   { mind_consnames = mbp.mind_consnames;
+    mind_consnrealdecls = mbp.mind_consnrealdecls;
     mind_typename = mbp.mind_typename;
-    mind_nf_lc = 
-      array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_nf_lc;
-    mind_nf_arity = type_app (Term.subst_mps sub) mbp.mind_nf_arity;
-    mind_user_lc = 
-      array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_user_lc;
-    mind_user_arity = type_app (Term.subst_mps sub) mbp.mind_user_arity;
-    mind_sort = mbp.mind_sort;
+    mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
+    mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
+    mind_arity = subst_arity sub mbp.mind_arity;
+    mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
     mind_nrealargs = mbp.mind_nrealargs;
     mind_kelim = mbp.mind_kelim;
-    mind_nparams = mbp.mind_nparams;
-    mind_params_ctxt = 
-      map_rel_context (Term.subst_mps sub) mbp.mind_params_ctxt;
-    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
-}
+    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); 
+    mind_nb_constant = mbp.mind_nb_constant;
+    mind_nb_args = mbp.mind_nb_args;
+    mind_reloc_tbl = mbp.mind_reloc_tbl }
+
 
 let subst_mind sub mib = 
   { mind_record = mib.mind_record ; 
     mind_finite = mib.mind_finite ;
     mind_ntypes = mib.mind_ntypes ;
     mind_hyps = (assert (mib.mind_hyps=[]); []) ;
+    mind_nparams = mib.mind_nparams;
+    mind_nparams_rec = mib.mind_nparams_rec;
+    mind_params_ctxt = 
+      map_rel_context (subst_mps sub) mib.mind_params_ctxt;
     mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
     mind_constraints = mib.mind_constraints ;
-    mind_equiv = option_app (subst_kn sub) mib.mind_equiv;
-}
+    mind_equiv = option_map (subst_kn sub) mib.mind_equiv }
 
 
 (*s Modules: signature component specifications, module types, and
@@ -171,7 +263,6 @@ and module_specification_body =
       msb_equiv : module_path option; 
       msb_constraints : constraints }
 
-
 type structure_elem_body = 
   | SEBconst of constant_body
   | SEBmind of mutual_inductive_body
@@ -193,3 +284,4 @@ and module_body =
       mod_type : module_type_body;
       mod_equiv : module_path option;
       mod_constraints : constraints }
+
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index 6cff3936..1eaeecb9 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -6,20 +6,34 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declarations.mli,v 1.33.2.3 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: declarations.mli 9310 2006-10-28 19:35:09Z herbelin $ i*)
 
 (*i*)
 open Names
 open Univ
 open Term
+open Cemitcodes
 open Sign
+open Mod_subst
 (*i*)
 
 (* This module defines the internal representation of global
    declarations. This includes global constants/axioms, mutual
    inductive definitions, modules and module types *)
 
-(*s Constants (Definition/Axiom) *)
+type engagement = ImpredicativeSet
+
+(**********************************************************************)
+(*s Representation of constants (Definition/Axiom)                    *)
+
+type polymorphic_arity = {
+  poly_param_levels : universe option list;
+  poly_level : universe;
+}
+
+type constant_type =
+  | NonPolymorphicType of types
+  | PolymorphicArity of rel_context * polymorphic_arity
 
 type constr_substituted
 
@@ -27,16 +41,18 @@ val from_val : constr -> constr_substituted
 val force : constr_substituted -> constr
 
 type constant_body = {
-  const_hyps : section_context; (* New: younger hyp at top *)
-  const_body : constr_substituted option;
-  const_type : types;
-  const_constraints : constraints;
-  const_opaque : bool }
+    const_hyps : section_context; (* New: younger hyp at top *)
+    const_body : constr_substituted option;
+    const_type : constant_type;
+    const_body_code : to_patch_substituted;
+   (*i const_type_code : to_patch;i*)
+    const_constraints : constraints;
+    const_opaque : bool }
 
 val subst_const_body : substitution -> constant_body -> constant_body
 
-(*s Inductive types (internal representation with redundant
-    information). *)
+(**********************************************************************)
+(*s Representation of mutual inductive types in the kernel            *)
 
 type recarg = 
   | Norec 
@@ -55,41 +71,108 @@ val recarg_length : wf_paths -> int -> int
 
 val subst_wf_paths : substitution -> wf_paths -> wf_paths
 
-(* [mind_typename] is the name of the inductive; [mind_arity] is
-   the arity generalized over global parameters; [mind_lc] is the list
-   of types of constructors generalized over global parameters and
-   relative to the global context enriched with the arities of the
-   inductives *) 
+(*
+\begin{verbatim}
+   Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
+   ...
+   with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
+\end{verbatim}
+*)
 
-type one_inductive_body = {
-  mind_typename : identifier;
-  mind_nparams : int;
-  mind_params_ctxt : rel_context;
-  mind_nrealargs : int;
-  mind_nf_arity : types;
-  mind_user_arity : types;
+type monomorphic_inductive_arity = {
+  mind_user_arity : constr;
   mind_sort : sorts;
-  mind_kelim : sorts_family list;
-  mind_consnames : identifier array;
-  mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *)
-  mind_user_lc : types array;
-  mind_recargs : wf_paths;
- }
+}
+
+type inductive_arity = 
+| Monomorphic of monomorphic_inductive_arity
+| Polymorphic of polymorphic_arity
+
+type one_inductive_body = {
+
+(* Primitive datas *)
+
+ (* Name of the type: [Ii] *)
+    mind_typename : identifier;
+
+ (* Arity context of [Ii] with parameters: [forall params, Ui] *)
+    mind_arity_ctxt : rel_context;
+
+ (* Arity sort and original user arity if monomorphic *)
+    mind_arity : inductive_arity;
+
+ (* Names of the constructors: [cij] *)
+    mind_consnames : identifier array;
+
+ (* Types of the constructors with parameters: [forall params, Tij],
+    where the Ik are replaced by de Bruijn index in the context
+    I1:forall params, U1 ..  In:forall params, Un *)
+    mind_user_lc : types array;
+
+(* Derived datas *)
+
+ (* Number of expected real arguments of the type (no let, no params) *)
+    mind_nrealargs : int;
+
+ (* List of allowed elimination sorts *)
+    mind_kelim : sorts_family list;
+
+ (* Head normalized constructor types so that their conclusion is atomic *)
+    mind_nf_lc : types array;
+
+ (* Length of the signature of the constructors (with let, w/o params) *)
+    mind_consnrealdecls : int array;
+
+ (* Signature of recursive arguments in the constructors *)
+    mind_recargs : wf_paths;
+
+(* Datas for bytecode compilation *)
+
+ (* number of constant constructor *)
+    mind_nb_constant : int;
+
+ (* number of no constant constructor *)
+    mind_nb_args : int;
+
+    mind_reloc_tbl :  Cbytecodes.reloc_table; 
+  }
 
 type mutual_inductive_body = {
-  mind_record : bool;
-  mind_finite : bool;
-  mind_ntypes : int;
-  mind_hyps : section_context;
-  mind_packets : one_inductive_body array;
-  mind_constraints : constraints;
-  mind_equiv : kernel_name option;
- }
 
+  (* The component of the mutual inductive block *)
+    mind_packets : one_inductive_body array;
 
-val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
+  (* Whether the inductive type has been declared as a record *)
+    mind_record : bool;
+
+  (* Whether the type is inductive or coinductive *)
+    mind_finite : bool;
 
+  (* Number of types in the block *)
+    mind_ntypes : int;
+
+  (* Section hypotheses on which the block depends *)
+    mind_hyps : section_context;
+
+  (* Number of expected parameters *)
+    mind_nparams : int;
+
+  (* Number of recursively uniform (i.e. ordinary) parameters *)
+    mind_nparams_rec : int;
+
+  (* The context of parameters (includes let-in declaration) *)
+    mind_params_ctxt : rel_context;
+
+  (* Universes constraints enforced by the inductive declaration *)
+    mind_constraints : constraints;
+
+  (* Source of the inductive block when aliased in a module *)
+    mind_equiv : kernel_name option
+  }
+
+val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
 
+(**********************************************************************)
 (*s Modules: signature component specifications, module types, and
   module declarations *)
 
diff --git a/kernel/entries.ml b/kernel/entries.ml
index a3d3d336..56b198c3 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.ml,v 1.3.8.2 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: entries.ml 8647 2006-03-18 15:33:09Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -32,9 +32,9 @@ type local_entry =
 
 (* Assume the following definition in concrete syntax:
 \begin{verbatim}
-Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1
+Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
 ...
-with  Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
+with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
 \end{verbatim}
 then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
 [mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
@@ -42,7 +42,6 @@ then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
 *)
 
 type one_inductive_entry = {
-  mind_entry_params : (identifier * local_entry) list;
   mind_entry_typename : identifier;
   mind_entry_arity : constr;
   mind_entry_consnames : identifier list;
@@ -51,6 +50,7 @@ type one_inductive_entry = {
 type mutual_inductive_entry = {
   mind_entry_record : bool;
   mind_entry_finite : bool;
+  mind_entry_params : (identifier * local_entry) list;
   mind_entry_inds : one_inductive_entry list }
 
 
@@ -59,7 +59,8 @@ type mutual_inductive_entry = {
 type definition_entry = {
   const_entry_body   : constr;
   const_entry_type   : types option;
-  const_entry_opaque : bool }
+  const_entry_opaque : bool;
+  const_entry_boxed  : bool}
 
 type parameter_entry = types
 
@@ -84,8 +85,8 @@ and module_type_entry =
 and module_signature_entry = (label * specification_entry) list
 
 and with_declaration = 
-    With_Module of identifier * module_path
-  | With_Definition of identifier * constr
+    With_Module of identifier list * module_path
+  | With_Definition of identifier list * constr
 
 and module_expr = 
     MEident of module_path
diff --git a/kernel/entries.mli b/kernel/entries.mli
index e9bc420e..b9a95d44 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: entries.mli,v 1.3.8.2 2005/11/29 21:40:51 letouzey Exp $ i*)
+(*i $Id: entries.mli 8647 2006-03-18 15:33:09Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -32,9 +32,9 @@ type local_entry =
 
 (* Assume the following definition in concrete syntax:
 \begin{verbatim}
-Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1
+Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
 ...
-with  Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
+with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
 \end{verbatim}
 then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
 [mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
@@ -42,7 +42,6 @@ then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
 *)
 
 type one_inductive_entry = {
-  mind_entry_params : (identifier * local_entry) list;
   mind_entry_typename : identifier;
   mind_entry_arity : constr;
   mind_entry_consnames : identifier list;
@@ -51,15 +50,16 @@ type one_inductive_entry = {
 type mutual_inductive_entry = {
   mind_entry_record : bool;
   mind_entry_finite : bool;
+  mind_entry_params : (identifier * local_entry) list;
   mind_entry_inds : one_inductive_entry list }
 
-
 (*s Constants (Definition/Axiom) *)
 
 type definition_entry = {
   const_entry_body   : constr;
   const_entry_type   : types option;
-  const_entry_opaque : bool }
+  const_entry_opaque : bool;
+  const_entry_boxed  : bool }
 
 type parameter_entry = types
 
@@ -84,8 +84,8 @@ and module_type_entry =
 and module_signature_entry = (label * specification_entry) list
 
 and with_declaration = 
-    With_Module of identifier * module_path
-  | With_Definition of identifier * constr
+    With_Module of identifier list * module_path
+  | With_Definition of identifier list * constr
 
 and module_expr = 
     MEident of module_path
diff --git a/kernel/environ.ml b/kernel/environ.ml
index ec3c903d..87a6e485 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: environ.ml,v 1.89.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+(* $Id: environ.ml 9573 2007-01-31 20:18:18Z notin $ *)
 
 open Util
 open Names
@@ -14,49 +14,25 @@ open Sign
 open Univ
 open Term
 open Declarations
+open Pre_env
+open Csymtable
 
 (* The type of environments. *)
 
-type checksum = int
+type named_context_val = Pre_env.named_context_val
 
-type compilation_unit_name = dir_path * checksum
+type env = Pre_env.env
 
-type global = Constant | Inductive
+let pre_env env = env
 
-type engagement = ImpredicativeSet
+let empty_named_context_val = empty_named_context_val
 
-type globals = {
-  env_constants : constant_body KNmap.t;
-  env_inductives : mutual_inductive_body KNmap.t;
-  env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body KNmap.t }
-
-type stratification = {
-  env_universes : universes;
-  env_engagement : engagement option
-}
-
-type env = {
-  env_globals        : globals;
-  env_named_context  : named_context;
-  env_rel_context    : rel_context;
-  env_stratification : stratification }
-
-let empty_env = { 
-  env_globals = {
-    env_constants = KNmap.empty;
-    env_inductives = KNmap.empty;
-    env_modules = MPmap.empty;
-    env_modtypes = KNmap.empty };
-  env_named_context = empty_named_context;
-  env_rel_context = empty_rel_context;
-  env_stratification = {
-    env_universes = initial_universes;
-    env_engagement = None } }
+let empty_env = empty_env
 
 let engagement env = env.env_stratification.env_engagement
 let universes env = env.env_stratification.env_universes
 let named_context env = env.env_named_context
+let named_context_val env = env.env_named_context,env.env_named_vals
 let rel_context env = env.env_rel_context
 
 let empty_context env = 
@@ -75,68 +51,109 @@ let evaluable_rel n env =
   with Not_found -> 
     false
 
-let push_rel d env =
-  { env with
-      env_rel_context = add_rel_decl d env.env_rel_context }
+let nb_rel env = env.env_nb_rel
+
+let push_rel = push_rel
 
 let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x
+    
 let push_rec_types (lna,typarray,_) env =
   let ctxt =
     array_map2_i
       (fun i na t -> (na, None, type_app (lift i) t)) lna typarray in
   Array.fold_left (fun e assum -> push_rel assum e) env ctxt
-
+    
 let reset_rel_context env =
   { env with
-      env_rel_context = empty_rel_context }
+    env_rel_context = empty_rel_context;
+    env_rel_val = [];
+    env_nb_rel = 0 }
 
 let fold_rel_context f env ~init =
-  snd (Sign.fold_rel_context
-	 (fun d (env,e) -> (push_rel d env, f env d e))
-         (rel_context env) ~init:(reset_rel_context env,init))
-
+  let rec fold_right env =
+    match env.env_rel_context with
+    | [] -> init
+    | rd::rc ->
+	let env = 
+	  { env with
+	    env_rel_context = rc;
+	    env_rel_val = List.tl env.env_rel_val;
+	    env_nb_rel = env.env_nb_rel - 1 } in
+	f env rd (fold_right env) 
+  in fold_right env
 
 (* Named context *)
-let lookup_named id env =
-  Sign.lookup_named id env.env_named_context
 
-(* A local const is evaluable if it is defined and not opaque *)
-let evaluable_named id env =
-  try 
-    match lookup_named id env with
-        (_,Some _,_) -> true
-      | _ -> false
-  with Not_found -> 
-    false
+let named_context_of_val = fst
 
-let push_named d env =
-  { env with
-      env_named_context = Sign.add_named_decl d env.env_named_context }
+(* [map_named_val f ctxt] apply [f] to the body and the type of
+   each declarations.
+   *** /!\ ***   [f t] should be convertible with t *)  
+let map_named_val f (ctxt,ctxtv) = 
+  let ctxt =
+    List.map (fun (id,body,typ) -> (id, option_map f body, f typ)) ctxt in
+  (ctxt,ctxtv)
 
-let reset_context env =
-  { env with
-      env_named_context = empty_named_context;
-      env_rel_context = empty_rel_context }
+let empty_named_context = empty_named_context 
 
-let reset_with_named_context ctxt env =
-  { env with
-      env_named_context = ctxt;
-      env_rel_context = empty_rel_context }
+let push_named = push_named
+let push_named_context_val = push_named_context_val
+
+let val_of_named_context ctxt =
+  List.fold_right push_named_context_val ctxt empty_named_context_val
 
+
+let lookup_named id env = Sign.lookup_named id env.env_named_context
+let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt
+
+let eq_named_context_val c1 c2 =
+   c1 == c2 || named_context_of_val c1 = named_context_of_val c2
+
+(* A local const is evaluable if it is defined  *)
+
+let named_type id env =
+  let (_,_,t) = lookup_named id env in t
+
+let named_body id env =
+  let (_,b,_) = lookup_named id env in b
+
+let evaluable_named id env =
+  try 
+    match named_body id env with
+    |Some _      -> true
+    | _          -> false
+  with Not_found -> false
+      
+let reset_with_named_context (ctxt,ctxtv) env =
+  { env with
+    env_named_context = ctxt;
+    env_named_vals = ctxtv;
+    env_rel_context = empty_rel_context;
+    env_rel_val = [];
+    env_nb_rel = 0 }
+
+let reset_context = reset_with_named_context empty_named_context_val
+ 
 let fold_named_context f env ~init =
-  snd (Sign.fold_named_context
-	 (fun d (env,e) -> (push_named d env, f env d e))
-         (named_context env) ~init:(reset_context env,init))
+  let rec fold_right env =
+    match env.env_named_context with
+    | [] -> init
+    | d::ctxt ->
+	let env = 
+	  reset_with_named_context (ctxt,List.tl env.env_named_vals) env in
+	f env d (fold_right env) 
+  in fold_right env
 
 let fold_named_context_reverse f ~init env =
-  Sign.fold_named_context_reverse f ~init:init (named_context env) 
-
+  Sign.fold_named_context_reverse f ~init:init (named_context env)
+ 
 (* Global constants *)
-let lookup_constant kn env =
-  KNmap.find kn env.env_globals.env_constants
 
-let add_constant kn cb env =
-  let new_constants = KNmap.add kn cb env.env_globals.env_constants in
+let lookup_constant = lookup_constant
+
+let add_constant kn cs env =
+  let new_constants = 
+    Cmap.add kn (cs,ref None) env.env_globals.env_constants in
   let new_globals = 
     { env.env_globals with 
 	env_constants = new_constants } in 
@@ -168,8 +185,9 @@ let evaluable_constant cst env =
   with Not_found | NotEvaluableConst _ -> false
 
 (* Mutual Inductives *)
-let lookup_mind kn env =
-  KNmap.find kn env.env_globals.env_inductives
+let lookup_mind = lookup_mind
+let scrape_mind = scrape_mind
+
 
 let add_mind kn mib env =
   let new_inds = KNmap.add kn mib env.env_globals.env_inductives in
@@ -223,9 +241,34 @@ let global_vars_set env constr =
   let rec filtrec acc c =
     let vl = vars_of_global env c in
     let acc = List.fold_right Idset.add vl acc in
-    fold_constr filtrec acc c
+      fold_constr filtrec acc c
   in 
-  filtrec Idset.empty constr
+    filtrec Idset.empty constr
+
+(* like [global_vars] but don't get through evars *)
+let global_vars_set_drop_evar env constr = 
+  let fold_constr_drop_evar f acc c = match kind_of_term c with
+    | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+      | Construct _) -> acc
+    | Cast (c,_,t) -> f (f acc c) t
+    | Prod (_,t,c) -> f (f acc t) c
+    | Lambda (_,t,c) -> f (f acc t) c
+    | LetIn (_,b,t,c) -> f (f (f acc b) t) c
+    | App (c,l) -> Array.fold_left f (f acc c) l
+    | Evar (_,l) -> acc
+    | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
+    | Fix (_,(lna,tl,bl)) ->
+	let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
+	  Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd
+    | CoFix (_,(lna,tl,bl)) ->
+	let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
+	  Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd in
+  let rec filtrec acc c =
+    let vl = vars_of_global env c in
+    let acc = List.fold_right Idset.add vl acc in
+      fold_constr_drop_evar filtrec acc c
+  in 
+    filtrec Idset.empty constr
 
 (* [keep_hyps env ids] keeps the part of the section context of [env] which 
    contains the variables of the set [ids], and recursively the variables 
@@ -253,7 +296,6 @@ let keep_hyps env needed =
     (named_context env)
     ~init:empty_named_context
 
-
 (* Modules *)
 
 let add_modtype ln mtb env = 
@@ -293,3 +335,62 @@ type unsafe_type_judgment = {
   utj_val : constr;
   utj_type : sorts }
 
+(*s Compilation of global declaration *)
+
+let compile_constant_body = Cbytegen.compile_constant_body  
+
+exception Hyp_not_found
+
+let rec apply_to_hyp (ctxt,vals) id f =
+  let rec aux rtail ctxt vals =
+    match ctxt, vals with
+    | (idc,c,ct as d)::ctxt, v::vals ->
+	if idc = id then
+	  (f ctxt d rtail)::ctxt, v::vals
+	else 
+	  let ctxt',vals' = aux (d::rtail) ctxt vals in
+	  d::ctxt', v::vals'
+    | [],[] -> raise Hyp_not_found
+    | _, _ -> assert false
+  in aux [] ctxt vals
+
+let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g =
+  let rec aux ctxt vals =
+    match ctxt,vals with
+    | (idc,c,ct as d)::ctxt, v::vals ->
+	if idc = id then
+	  let sign = ctxt,vals in
+	  push_named_context_val (f d sign) sign 
+	else 
+	  let (ctxt,vals as sign) = aux ctxt vals in
+	  push_named_context_val (g d sign) sign
+    | [],[] -> raise Hyp_not_found
+    | _,_ -> assert false
+  in aux ctxt vals
+
+let insert_after_hyp (ctxt,vals) id d check =
+  let rec aux ctxt vals =
+    match  ctxt, vals with
+    | (idc,c,ct)::ctxt', v::vals' ->
+	if idc = id then begin
+	  check ctxt; 
+	  push_named_context_val d (ctxt,vals) 
+	end else 
+	  let ctxt,vals = aux ctxt vals in
+	  d::ctxt, v::vals
+    | [],[] -> raise Hyp_not_found
+    | _, _ -> assert false
+  in aux ctxt vals
+
+(* To be used in Logic.clear_hyps *)
+let remove_hyps ids check (ctxt, vals) =
+  let ctxt,vals,rmv = 
+    List.fold_right2 (fun (id,_,_ as d) v (ctxt,vals,rmv) ->
+      if List.mem id ids then 
+	(ctxt,vals,id::rmv)
+      else 	  
+	let nd = check d in
+	  (nd::ctxt,v::vals,rmv))
+		     ctxt vals ([],[],[])
+  in ((ctxt,vals),rmv)
+
diff --git a/kernel/environ.mli b/kernel/environ.mli
index a2a66cb7..478357d7 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: environ.mli,v 1.66.2.2 2005/01/21 16:41:49 herbelin Exp $ i*)
+(*i $Id: environ.mli 9573 2007-01-31 20:18:18Z notin $ i*)
 
 (*i*)
 open Names
@@ -22,21 +22,30 @@ open Sign
 
 (* Environments have the following components:
    - a context for de Bruijn variables
+   - a context for de Bruijn variables vm values
    - a context for section variables and goal assumptions
+   - a context for section variables and goal assumptions vm values 
    - a context for global constants and axioms
    - a context for inductive definitions
    - a set of universe constraints
    - a flag telling if Set is, can be, or cannot be set impredicative *)
 
+
+
+
 type env
+val pre_env : env -> Pre_env.env
+
+type named_context_val
+val eq_named_context_val : named_context_val -> named_context_val -> bool
 
 val empty_env : env
 
 val universes     : env -> Univ.universes
 val rel_context   : env -> rel_context
 val named_context : env -> named_context
+val named_context_val : env -> named_context_val
 
-type engagement = ImpredicativeSet
 
 val engagement    : env -> engagement option
 
@@ -45,6 +54,7 @@ val empty_context : env -> bool
 
 (************************************************************************)
 (*s Context of de Bruijn variables ([rel_context]) *)
+val nb_rel           : env -> int 
 val push_rel         : rel_declaration -> env -> env
 val push_rel_context :     rel_context -> env -> env
 val push_rec_types   : rec_declaration -> env -> env
@@ -60,14 +70,35 @@ val fold_rel_context :
 
 (************************************************************************)
 (* Context of variables (section variables and goal assumptions) *)
+
+val named_context_of_val : named_context_val -> named_context
+val val_of_named_context : named_context -> named_context_val
+val empty_named_context_val : named_context_val
+
+
+(* [map_named_val f ctxt] apply [f] to the body and the type of
+   each declarations.
+   *** /!\ ***   [f t] should be convertible with t *)  
+val map_named_val : 
+   (constr -> constr) -> named_context_val -> named_context_val
+
 val push_named : named_declaration -> env -> env
+val push_named_context_val  : 
+    named_declaration -> named_context_val -> named_context_val
+
+
 
 (* Looks up in the context of local vars referred by names ([named_context]) *)
 (* raises [Not_found] if the identifier is not found *)
-val lookup_named    : variable -> env -> named_declaration
-val evaluable_named : variable -> env -> bool
 
+val lookup_named     : variable -> env -> named_declaration
+val lookup_named_val : variable -> named_context_val -> named_declaration
+val evaluable_named  : variable -> env -> bool
+val named_type : variable -> env -> types
+val named_body : variable -> env -> constr option
+ 
 (*s Recurrence on [named_context]: older declarations processed first *)
+
 val fold_named_context :
   (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
 
@@ -78,7 +109,7 @@ val fold_named_context_reverse :
 (* This forgets named and rel contexts *)
 val reset_context : env -> env
 (* This forgets rel context and sets a new named context *)
-val reset_with_named_context : named_context -> env -> env
+val reset_with_named_context : named_context_val -> env -> env
 
 (************************************************************************)
 (*s Global constants *)
@@ -87,6 +118,7 @@ val add_constant : constant -> constant_body -> env -> env
 
 (* Looks up in the context of global constant names *)
 (* raises [Not_found] if the required path is not found *)
+
 val lookup_constant    : constant -> env -> constant_body
 val evaluable_constant : constant -> env -> bool
 
@@ -97,7 +129,7 @@ type const_evaluation_result = NoBody | Opaque
 exception NotEvaluableConst of const_evaluation_result
 
 val constant_value     : env -> constant -> constr
-val constant_type      : env -> constant -> types
+val constant_type      : env -> constant -> constant_type
 val constant_opt_value : env -> constant -> constr option
 
 (************************************************************************)
@@ -108,6 +140,9 @@ val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env
 (* raises [Not_found] if the required path is not found *)
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
+(* Find the ultimate inductive in the [mind_equiv] chain *)
+val scrape_mind : env -> mutual_inductive -> mutual_inductive
+
 (************************************************************************)
 (*s Modules *)
 val add_modtype : kernel_name -> module_type_body -> env -> env
@@ -130,6 +165,7 @@ val set_engagement : engagement -> env -> env
 (* [global_vars_set env c] returns the list of [id]'s occurring as
    [VAR id] in [c] *)
 val global_vars_set : env -> constr -> Idset.t
+val global_vars_set_drop_evar : env -> constr -> Idset.t
 (* the constr must be an atomic construction *)
 val vars_of_global : env -> constr -> identifier list
 
@@ -153,7 +189,33 @@ type unsafe_type_judgment = {
   utj_type : sorts }
 
 
+(*s Compilation of global declaration *)
+
+val compile_constant_body : 
+    env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code
+                                 (* opaque *) (* boxed *)
+
+exception Hyp_not_found
+
+(* [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
+   return [tail::(f head (id,_,_) (rev tail))::head].
+   the value associated to id should not change *)
+
+val apply_to_hyp : named_context_val -> variable -> 
+  (named_context -> named_declaration -> named_context -> named_declaration) ->
+    named_context_val
 
+(* [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
+   [tail::(id,_,_)::head] and
+   return [(g tail)::(f (id,_,_))::head]. *)
+val apply_to_hyp_and_dependent_on : named_context_val -> variable ->
+  (named_declaration -> named_context_val -> named_declaration) ->
+    (named_declaration -> named_context_val -> named_declaration) ->
+      named_context_val
 
+val insert_after_hyp : named_context_val -> variable ->
+  named_declaration -> 
+    (named_context -> unit) -> named_context_val
 
+val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> named_context_val -> named_context_val * identifier list
 
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index 38db01fc..e32fc963 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: esubst.ml,v 1.4.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+(* $Id: esubst.ml 8799 2006-05-09 21:15:07Z barras $ *)
 
 open Util
 
@@ -55,7 +55,10 @@ let rec is_lift_id = function
 (* (bounded) explicit substitutions of type 'a *)
 type 'a subs =
   | ESID of int            (* ESID(n)    = %n END   bounded identity *)
-  | CONS of 'a * 'a subs   (* CONS(t,S)  = (S.t)    parallel substitution *)
+  | CONS of 'a array * 'a subs
+                           (* CONS([|t1..tn|],S)  =
+                              (S.t1...tn)    parallel substitution
+                              beware of the order *)
   | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *)
                            (*                        with n vars *)
   | LIFT of int * 'a subs  (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *)
@@ -64,7 +67,7 @@ type 'a subs =
  * Needn't be recursive if we always use these functions
  *)
 
-let subs_cons(x,s) = CONS(x,s)
+let subs_cons(x,s) = if Array.length x = 0 then s else CONS(x,s)
 
 let subs_liftn n = function
   | ESID p        -> ESID (p+n) (* bounded identity lifted extends by p *)
@@ -85,11 +88,12 @@ let subs_shift_cons = function
 | (k, SHIFT(n,s1), t) -> CONS(t,SHIFT(k+n, s1))
 | (k, s, t)           -> CONS(t,SHIFT(k, s));;
 
-(* Tests whether a substitution is extensionnaly equal to the identity *)
+(* Tests whether a substitution is equal to the identity *)
 let rec is_subs_id = function
     ESID _     -> true
   | LIFT(_,s)  -> is_subs_id s
   | SHIFT(0,s) -> is_subs_id s
+  | CONS(x,s)  -> Array.length x = 0 && is_subs_id s
   | _          -> false
 
 (* Expands de Bruijn k in the explicit substitution subs
@@ -108,14 +112,15 @@ let rec is_subs_id = function
  * variable points k bindings beyond subs.
  *) 
 let rec exp_rel lams k subs =
-  match (k,subs) with
-    | (1, CONS (def,_))         -> Inl(lams,def)
-    | (_, CONS (_,l))           -> exp_rel lams (pred k) l
-    | (_, LIFT (n,_)) when k<=n -> Inr(lams+k,None)
-    | (_, LIFT (n,l))           -> exp_rel (n+lams) (k-n) l
-    | (_, SHIFT (n,s))          -> exp_rel (n+lams) k s
-    | (_, ESID n) when k<=n     -> Inr(lams+k,None)
-    | (_, ESID n)               -> Inr(lams+k,Some (k-n))
+  match subs with
+    | CONS (def,_) when k <= Array.length def
+                           -> Inl(lams,def.(Array.length def - k))
+    | CONS (v,l)           -> exp_rel lams (k - Array.length v) l
+    | LIFT (n,_) when k<=n -> Inr(lams+k,None)
+    | LIFT (n,l)           -> exp_rel (n+lams) (k-n) l
+    | SHIFT (n,s)          -> exp_rel (n+lams) k s
+    | ESID n when k<=n     -> Inr(lams+k,None)
+    | ESID n               -> Inr(lams+k,Some (k-n))
 
 let expand_rel k subs = exp_rel 0 k subs
 
@@ -124,9 +129,20 @@ let rec comp mk_cl s1 s2 =
     | _, ESID _ -> s1
     | ESID _, _ -> s2
     | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2)
-    | _, CONS(x,s') -> CONS(mk_cl(s1,x), comp mk_cl s1 s')
-    | CONS(x,s), SHIFT(k,s') -> comp mk_cl s (subs_shft(k-1, s'))
-    | CONS(x,s), LIFT(k,s') -> CONS(x,comp mk_cl s (subs_liftn (k-1) s'))
+    | _, CONS(x,s') ->
+        CONS(Array.map (fun t -> mk_cl(s1,t)) x, comp mk_cl s1 s')
+    | CONS(x,s), SHIFT(k,s') ->
+        let lg = Array.length x in
+        if k == lg then comp mk_cl s s'
+        else if k > lg then comp mk_cl s (SHIFT(k-lg, s'))
+        else comp mk_cl (CONS(Array.sub x 0 (lg-k), s)) s'
+    | CONS(x,s), LIFT(k,s') ->
+        let lg = Array.length x in
+        if k == lg then CONS(x, comp mk_cl s s')
+        else if k > lg then CONS(x, comp mk_cl s (LIFT(k-lg, s')))
+        else
+          CONS(Array.sub x (lg-k) k,
+               comp mk_cl (CONS(Array.sub x 0 (lg-k),s)) s')
     | LIFT(k,s), SHIFT(k',s') ->
         if k<k'
         then subs_shft(k, comp mk_cl s (subs_shft(k'-k, s')))
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index 2fe981f7..3b40bdfc 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: esubst.mli,v 1.3.2.2 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: esubst.mli 8799 2006-05-09 21:15:07Z barras $ i*)
 
 (*s Compact representation of explicit relocations. \\
    [ELSHFT(l,n)] == lift of [n], then apply [lift l].
@@ -22,21 +22,22 @@ val el_lift : lift -> lift
 val reloc_rel : int -> lift -> int
 val is_lift_id : lift -> bool
 
-(*s Explicit substitutions of type ['a]. [ESID n] = %n~END = bounded identity. 
-  [CONS(t,S)] = $S.t$ i.e. parallel substitution. [SHIFT(n,S)] = 
-  $(\uparrow n~o~S)$ i.e. terms in S are relocated with n vars. 
-  [LIFT(n,S)] = $(\%n~S)$ stands for $((\uparrow n~o~S).n...1)$. *)
+(*s Explicit substitutions of type ['a]. *)
 type 'a subs =
-  | ESID of int
-  | CONS of 'a * 'a subs
-  | SHIFT of int * 'a subs
-  | LIFT of int * 'a subs
+  | ESID of int            (* ESID(n)    = %n END   bounded identity *)
+  | CONS of 'a array * 'a subs
+                           (* CONS([|t1..tn|],S)  =
+                              (S.t1...tn)    parallel substitution
+                              beware of the order *)
+  | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *)
+                           (*                        with n vars *)
+  | LIFT of int * 'a subs  (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *)
 
-val subs_cons: 'a * 'a subs -> 'a subs
+val subs_cons: 'a array * 'a subs -> 'a subs
 val subs_shft: int * 'a subs -> 'a subs
 val subs_lift: 'a subs -> 'a subs
 val subs_liftn: int -> 'a subs -> 'a subs
-val subs_shift_cons: int * 'a subs * 'a -> 'a subs
+val subs_shift_cons: int * 'a subs * 'a array -> 'a subs
 val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union
 val is_subs_id: 'a subs -> bool
-val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs
\ No newline at end of file
+val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 0b1d49f5..4fe90ffd 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indtypes.ml,v 1.59.2.4 2005/12/30 15:58:59 barras Exp $ *)
+(* $Id: indtypes.ml 9633 2007-02-09 18:40:26Z herbelin $ *)
 
 open Util
 open Names
@@ -26,14 +26,14 @@ let weaker_noccur_between env x nvars t =
   if noccur_between x nvars t then Some t
   else
    let t' = whd_betadeltaiota env t in
-   if noccur_between x nvars t then Some t'
+   if noccur_between x nvars t' then Some t'
    else None
 
 (************************************************************************)
 (* Various well-formedness check for inductive declarations            *)
 
+(* Errors related to inductive constructions *)
 type inductive_error =
-  (* These are errors related to inductive constructions in this module *)
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
   | NotConstructor of env * constr * constr
@@ -43,10 +43,6 @@ type inductive_error =
   | SameNamesOverlap of identifier list
   | NotAnArity of identifier
   | BadEntry
-  (* These are errors related to recursors building in Indrec *)
-  | NotAllowedCaseAnalysis of bool * sorts * inductive
-  | BadInduction of bool * identifier * sorts
-  | NotMutualInScheme
 
 exception InductiveError of inductive_error
 
@@ -101,31 +97,17 @@ let mind_check_arities env mie =
 
 (* Typing the arities and constructor types *)
 
-let is_info_arity env c =
-  match dest_arity env c with
-    | (_,Prop Null) -> false 
-    | (_,Prop Pos)  -> true 
-    | (_,Type _)    -> true
-
-let is_info_type env t =
-  let s = t.utj_type in
-  if s = mk_Set then true
-  else if s = mk_Prop then false
-  else
-    try is_info_arity env t.utj_val
-    with UserError _ -> true
+let is_logic_type t = (t.utj_type = mk_Prop)
 
 (* [infos] is a sequence of pair [islogic,issmall] for each type in
    the product of a constructor or arity *)
 
 let is_small infos = List.for_all (fun (logic,small) -> small) infos
 let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos
-let is_logic_arity infos =
-  List.for_all (fun (logic,small) -> logic || small) infos
 
 (* An inductive definition is a "unit" if it has only one constructor
    and that all arguments expected by this constructor are 
-   logical, this is the case for equality, conjonction of logical properties 
+   logical, this is the case for equality, conjunction of logical properties 
 *)
 let is_unit constrsinfos =
   match constrsinfos with  (* One info = One constructor *)
@@ -138,10 +120,10 @@ let rec infos_and_sort env t =
     | Prod (name,c1,c2) ->
         let (varj,_) = infer_type env c1 in
 	let env1 = Environ.push_rel (name,None,varj.utj_val) env in
-	let logic = not (is_info_type env varj) in
+	let logic = is_logic_type varj in
 	let small = Term.is_small varj.utj_type in
 	(logic,small) :: (infos_and_sort env1 c2)
-    | Cast (c,_) -> infos_and_sort env c
+    | Cast (c,_,_) -> infos_and_sort env c
     | _ -> []
 
 let small_unit constrsinfos =
@@ -149,45 +131,58 @@ let small_unit constrsinfos =
   and isunit = is_unit constrsinfos in
   issmall, isunit
 
-(* This (re)computes informations relevant to extraction and the sort of an
-   arity or type constructor; we do not to recompute universes constraints *)
+(* Computing the levels of polymorphic inductive types
 
-(* [smax] is the max of the sorts of the products of the constructor type *)
+   For each inductive type of a block that is of level u_i, we have
+   the constraints that u_i >= v_i where v_i is the type level of the
+   types of the constructors of this inductive type. Each v_i depends
+   of some of the u_i and of an extra (maybe non variable) universe,
+   say w_i that summarize all the other constraints. Typically, for
+   three inductive types, we could have
 
-let enforce_type_constructor env arsort smax cst =
-  match smax, arsort with
-    | Type uc, Type ua -> enforce_geq ua uc cst
-    | Type uc, Prop Pos when engagement env <> Some ImpredicativeSet ->
-        error "Large non-propositional inductive types must be in Type"
-    | _,_ -> cst
+   u1,u2,u3,w1 <= u1
+   u1       w2 <= u2
+      u2,u3,w3 <= u3
 
-let type_one_constructor env_ar_par params arsort c =
-  let infos = infos_and_sort env_ar_par c in
+   From this system of inequations, we shall deduce
 
-  (* Each constructor is typed-checked here *)
-  let (j,cst) = infer_type env_ar_par c in
-  let full_cstr_type = it_mkProd_or_LetIn j.utj_val params in
+   w1,w2,w3 <= u1
+   w1,w2 <= u2
+   w1,w2,w3 <= u3
+*)   
 
-  (* If the arity is at some level Type arsort, then the sort of the
-     constructor must be below arsort; here we consider constructors with the
-     global parameters (which add a priori more constraints on their sort) *)
-  let cst2 = enforce_type_constructor env_ar_par arsort j.utj_type cst in
+let extract_level (_,_,_,lc,lev) =
+  (* Enforce that the level is not in Prop if more than two constructors *)
+  if Array.length lc >= 2 then sup base_univ lev else lev
+
+let inductive_levels arities inds =
+  let levels = Array.map pi3 arities in
+  let cstrs_levels = Array.map extract_level inds in
+  (* Take the transitive closure of the system of constructors *)
+  (* level constraints and remove the recursive dependencies *)
+  solve_constraints_system levels cstrs_levels
+
+(* This (re)computes informations relevant to extraction and the sort of an
+   arity or type constructor; we do not to recompute universes constraints *)
 
-  (infos, full_cstr_type, cst2)
+let constraint_list_union =
+  List.fold_left Constraint.union Constraint.empty
 
-let infer_constructor_packet env_ar params arsort vc =
+let infer_constructor_packet env_ar params lc =
+  (* builds the typing context "Gamma, I1:A1, ... In:An, params" *)
   let env_ar_par = push_rel_context params env_ar in
-  let (constrsinfos,jlc,cst) = 
-    List.fold_right
-      (fun c (infosl,l,cst) ->
-	 let (infos,ct,cst') =
-	   type_one_constructor env_ar_par params arsort c in
-	 (infos::infosl,ct::l, Constraint.union cst cst'))
-      vc
-      ([],[],Constraint.empty) in
-  let vc' = Array.of_list jlc in
-  let issmall,isunit = small_unit constrsinfos in
-  (issmall,isunit,vc', cst)
+  (* type-check the constructors *)
+  let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in
+  let cst = constraint_list_union cstl in
+  let jlc = Array.of_list jlc in
+  (* generalize the constructor over the parameters *)
+  let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in
+  (* compute the max of the sorts of the products of the constructor type *)
+  let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in
+  (* compute *)
+  let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in
+
+  (info,lc'',level,cst)
 
 (* Type-check an inductive definition. Does not check positivity
    conditions. *)
@@ -196,51 +191,82 @@ let typecheck_inductive env mie =
   (* Check unicity of names *)
   mind_check_names mie;
   mind_check_arities env mie;
-  (* We first type params and arity of each inductive definition *)
+  (* Params are typed-checked here *)
+  let env_params, params, cst1 = infer_local_decls env mie.mind_entry_params in
+  (* We first type arity of each inductive definition *)
   (* This allows to build the environment of arities and to share *)
   (* the set of constraints *)
-  let cst, arities, rev_params_arity_list =
+  let cst, env_arities, rev_arity_list =
     List.fold_left
-      (fun (cst,arities,l) ind ->
-         (* Params are typed-checked here *)
-	 let params = ind.mind_entry_params in
-	 let env_params, params, cst1 =
-           infer_local_decls env params in
+      (fun (cst,env_ar,l) ind ->
          (* Arities (without params) are typed-checked here *)
-	 let arity, cst2 =
-           infer_type env_params ind.mind_entry_arity in
+	 let arity, cst2 = infer_type env_params ind.mind_entry_arity in
 	 (* We do not need to generate the universe of full_arity; if
 	    later, after the validation of the inductive definition,
 	    full_arity is used as argument or subject to cast, an
 	    upper universe will be generated *)
-	 let id = ind.mind_entry_typename in
 	 let full_arity = it_mkProd_or_LetIn arity.utj_val params in
-	 Constraint.union cst (Constraint.union cst1 cst2),
-	 Sign.add_rel_decl (Name id, None, full_arity) arities,
-         (params, id, full_arity, arity.utj_val)::l)
-      (Constraint.empty,empty_rel_context,[])
+	 let cst = Constraint.union cst cst2 in
+	 let id = ind.mind_entry_typename in
+	 let env_ar' = push_rel (Name id, None, full_arity) env_ar in
+	 let lev =
+	   (* Decide that if the conclusion is not explicitly Type *)
+	   (* then the inductive type is not polymorphic *)
+	   match kind_of_term (snd (decompose_prod_assum arity.utj_val)) with
+	   | Sort (Type u) -> Some u
+	   | _ -> None in
+         (cst,env_ar',(id,full_arity,lev)::l))
+      (cst1,env,[])
       mie.mind_entry_inds in
 
-  let env_arities = push_rel_context arities env in
-
-  let params_arity_list = List.rev rev_params_arity_list in
+  let arity_list = List.rev rev_arity_list in
 
   (* Now, we type the constructors (without params) *)
   let inds,cst =
     List.fold_right2
-      (fun ind (params,id,full_arity,short_arity) (inds,cst) ->
-	 let (_,arsort) = dest_arity env full_arity in
-	 let lc = ind.mind_entry_lc in
-	 let (issmall,isunit,lc',cst') =
-	   infer_constructor_packet env_arities params arsort lc in
+      (fun ind arity_data (inds,cst) ->
+	 let (info,lc',cstrs_univ,cst') =
+	   infer_constructor_packet env_arities params ind.mind_entry_lc in
 	 let consnames = ind.mind_entry_consnames in
-	 let ind' = (params,id,full_arity,consnames,issmall,isunit,lc')
-	 in
+	 let ind' = (arity_data,consnames,info,lc',cstrs_univ) in
 	 (ind'::inds, Constraint.union cst cst'))
       mie.mind_entry_inds
-      params_arity_list
+      arity_list
       ([],cst) in
-  (env_arities, Array.of_list inds, cst)
+
+  let inds = Array.of_list inds in
+  let arities = Array.of_list arity_list in
+  let param_ccls = List.fold_left (fun l (_,b,p) ->
+    if b = None then 
+      let _,c = dest_prod_assum env p in
+      let u = match kind_of_term c with Sort (Type u) -> Some u | _ -> None in
+      u::l
+    else 
+      l) [] params in
+
+  (* Compute/check the sorts of the inductive types *)
+  let ind_min_levels = inductive_levels arities inds in
+  let inds, cst =
+    array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst ->
+      let sign, s = dest_arity env full_arity in
+      let status,cst = match s with
+      | Type _ when ar_level <> None (* Explicitly polymorphic *) ->
+	  (* The polymorphic level is a function of the level of the *)
+	  (* conclusions of the parameters *)
+	  Inr (param_ccls, lev), cst
+      | Type u (* Not an explicit occurrence of Type *) ->
+	  Inl (info,full_arity,s), enforce_geq u lev cst
+      | Prop Pos when engagement env <> Some ImpredicativeSet ->
+	  (* Predicative set: check that the content is indeed predicative *)
+	  if not (is_empty_univ lev) & not (is_base_univ lev) then
+	    error "Large non-propositional inductive types must be in Type";
+	  Inl (info,full_arity,s), cst
+      | Prop _ ->
+	  Inl (info,full_arity,s), cst in
+      (id,cn,lc,(sign,status)),cst)
+      inds ind_min_levels cst in
+
+  (env_arities, params, inds, cst)
 
 (************************************************************************)
 (************************************************************************)
@@ -276,13 +302,18 @@ let explain_ind_err ntyp env0 nbpar c err =
 	raise (InductiveError 
 		 (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar))))
 
+let failwith_non_pos n ntypes c =
+  for k = n to n + ntypes - 1 do
+    if not (noccurn k c) then raise (IllFormedInd (LocalNonPos (k-n+1)))
+  done
+
 let failwith_non_pos_vect n ntypes v =
-  for i = 0 to Array.length v - 1 do
-    for k = n to n + ntypes - 1 do
-      if not (noccurn k v.(i)) then raise (IllFormedInd (LocalNonPos (k-n+1)))
-    done
-  done;
-  anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur in v"
+  Array.iter (failwith_non_pos n ntypes) v;
+  anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur"
+
+let failwith_non_pos_list n ntypes l =
+  List.iter (failwith_non_pos n ntypes) l;
+  anomaly "failwith_non_pos_list: some k in [n;n+ntypes-1] should occur"
 
 (* Check the inductive type is called with the expected parameters *)
 let check_correct_par (env,n,ntypes,_) hyps l largs =
@@ -303,6 +334,26 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
   if not (array_for_all (noccur_between n ntypes) largs') then 
     failwith_non_pos_vect n ntypes largs'
 
+(* Computes the maximum number of recursive parameters : 
+    the first parameters which are constant in recursive arguments 
+    n is the current depth, nmr is the maximum number of possible 
+    recursive parameters *)
+
+let compute_rec_par (env,n,_,_) hyps nmr largs = 
+if nmr = 0 then 0 else
+(* start from 0, hyps will be in reverse order *)
+  let (lpar,_) = list_chop nmr largs in
+  let rec find k index = 
+      function 
+	  ([],_) -> nmr
+	| (_,[]) -> assert false (* |hyps|>=nmr *)
+	| (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps)
+	| (p::lp,_::hyps) ->
+       ( match kind_of_term (whd_betadeltaiota env p) with
+	  | Rel w when w = index -> find (k+1) (index-1) (lp,hyps)
+          | _ -> k)
+  in find 0 (n-1) (lpar,List.rev hyps)
+
 (* This removes global parameters of the inductive types in lc (for
    nested inductive types only ) *)
 let abstract_mind_lc env ntyps npars lc = 
@@ -326,9 +377,10 @@ let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
 
 let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
   let auxntyp = 1 in
+  let specif = lookup_mind_specif env mi in
   let env' =
     push_rel (Anonymous,None,
-              hnf_prod_applist env (type_of_inductive env mi) lpar) env in
+              hnf_prod_applist env (type_of_inductive env specif) lpar) env in
   let ra_env' = 
     (Imbr mi,Rtree.mk_param 0) ::
     List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in
@@ -336,46 +388,50 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
   let newidx = n + auxntyp in
   (env', newidx, ntypes, ra_env')
 
+let array_min nmr a = if nmr = 0 then 0 else
+  Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a
+
 (* The recursive function that checks positivity and builds the list
    of recursive arguments *)
 let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
-  let nparams = rel_context_length hyps in
+  let lparams = rel_context_length hyps in
+  let nmr = rel_context_nhyps hyps in
   (* check the inductive types occur positively in [c] *)
-  let rec check_pos (env, n, ntypes, ra_env as ienv) c = 
+  let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = 
     let x,largs = decompose_app (whd_betadeltaiota env c) in
     match kind_of_term x with
       | Prod (na,b,d) ->
 	  assert (largs = []);
           (match weaker_noccur_between env n ntypes b with
-              None -> raise (IllFormedInd (LocalNonPos n));
+              None -> failwith_non_pos_list n ntypes [b]
             | Some b ->
-	        check_pos (ienv_push_var ienv (na, b, mk_norec)) d)
+	        check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d)
       | Rel k ->
-          let (ra,rarg) =
-            try List.nth ra_env (k-1)
-            with Failure _ | Invalid_argument _ -> (Norec,mk_norec) in
-          (match ra with
-              Mrec _ -> check_correct_par ienv hyps (k-n+1) largs
-            | _ ->
-                if not (List.for_all (noccur_between n ntypes) largs)
-	        then raise (IllFormedInd (LocalNonPos n)));
-          rarg
+           (try let (ra,rarg) = List.nth ra_env (k-1) in 
+		let nmr1 =
+	       (match ra with
+                 Mrec _ -> compute_rec_par ienv hyps nmr largs
+		  |  _ -> nmr)
+		in 
+		  if not (List.for_all (noccur_between n ntypes) largs)
+	          then failwith_non_pos_list n ntypes largs
+		  else (nmr1,rarg)
+            with Failure _ | Invalid_argument _ -> (nmr,mk_norec))
       | Ind ind_kn ->
           (* If the inductive type being defined appears in a
              parameter, then we have an imbricated type *)
-          if List.for_all (noccur_between n ntypes) largs then mk_norec
-          else check_positive_imbr ienv (ind_kn, largs)
+          if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec)
+          else check_positive_imbr ienv nmr (ind_kn, largs)
       | err -> 
 	  if noccur_between n ntypes x &&
              List.for_all (noccur_between n ntypes) largs 
-	  then mk_norec
-	  else raise (IllFormedInd (LocalNonPos n))
+	  then (nmr,mk_norec)
+	  else failwith_non_pos_list n ntypes (x::largs)
 
-  (* accesses to the environment are not factorised, but does it worth
-     it? *)
-  and check_positive_imbr (env,n,ntypes,ra_env as ienv) (mi, largs) =
+  (* accesses to the environment are not factorised, but is it worth? *)
+  and check_positive_imbr (env,n,ntypes,ra_env as ienv) nmr (mi, largs) =
     let (mib,mip) = lookup_mind_specif env mi in
-    let auxnpar = mip.mind_nparams in
+    let auxnpar = mib.mind_nparams_rec in
     let (lpar,auxlargs) =
       try list_chop auxnpar largs 
       with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in 
@@ -393,31 +449,34 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
     let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in
     (* Parameters expressed in env' *)
     let lpar' = List.map (lift auxntyp) lpar in
-    let irecargs = 
+    let irecargs_nmr = 
       (* fails if the inductive type occurs non positively *)
       (* when substituted *) 
       Array.map 
 	(function c -> 
 	  let c' = hnf_prod_applist env' c lpar' in 
-	  check_constructors ienv' false c') 
+	  check_constructors ienv' false nmr c') 
 	auxlcvect
+    in
+    let irecargs = Array.map snd irecargs_nmr
+    and nmr' = array_min nmr irecargs_nmr
     in 
-    (Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)
+    (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0))
   
   (* check the inductive types occur positively in the products of C, if
      check_head=true, also check the head corresponds to a constructor of
      the ith type *) 
 
-  and check_constructors ienv check_head c = 
-    let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = 
+  and check_constructors ienv check_head nmr c = 
+    let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = 
       let x,largs = decompose_app (whd_betadeltaiota env c) in
       match kind_of_term x with
 
         | Prod (na,b,d) -> 
 	    assert (largs = []);
-            let recarg = check_pos ienv b in 
+            let nmr',recarg = check_pos ienv nmr b in 
             let ienv' = ienv_push_var ienv (na,b,mk_norec) in
-	    check_constr_rec ienv' (recarg::lrec) d
+	    check_constr_rec ienv' nmr' (recarg::lrec) d
 
 	| hd ->
 	    if check_head then
@@ -428,32 +487,39 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc =
 	    else
 	      if not (List.for_all (noccur_between n ntypes) largs)
               then raise (IllFormedInd (LocalNonPos n));
-	    List.rev lrec
-    in check_constr_rec ienv [] c
+	    (nmr,List.rev lrec)
+    in check_constr_rec ienv nmr [] c
   in
-  mk_paths (Mrec i)
-    (Array.map
+  let irecargs_nmr =
+     Array.map
       (fun c ->
-        let c = body_of_type c in
-        let sign, rawc = mind_extract_params nparams c in
-        let env' = push_rel_context sign env in
+        let _,rawc = mind_extract_params lparams c in
         try
-	  check_constructors ienv true rawc
+	  check_constructors ienv true nmr rawc
         with IllFormedInd err -> 
-	  explain_ind_err (ntypes-i) env nparams c err)
-      indlc)
+	  explain_ind_err (ntypes-i) env lparams c err)
+      indlc
+  in
+  let irecargs = Array.map snd irecargs_nmr
+  and nmr' = array_min nmr irecargs_nmr
+  in (nmr', mk_paths (Mrec i) irecargs)
 
-let check_positivity env_ar inds =
+let check_positivity env_ar params inds =
   let ntypes = Array.length inds in
   let lra_ind =
     List.rev (list_tabulate (fun j -> (Mrec j, Rtree.mk_param j)) ntypes) in
-  let check_one i (params,_,_,_,_,_,lc) =
-    let nparams = rel_context_length params in
+  let lparams = rel_context_length params in
+  let nmr = rel_context_nhyps params in
+  let check_one i (_,_,lc,_) =
     let ra_env =
-      list_tabulate (fun _ -> (Norec,mk_norec)) nparams @ lra_ind in
-    let ienv = (env_ar, 1+nparams, ntypes, ra_env) in
-    check_positivity_one ienv params i lc in
-  Rtree.mk_rec (Array.mapi check_one inds)
+      list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in
+    let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
+    check_positivity_one ienv params i lc 
+  in
+  let irecargs_nmr = Array.mapi check_one inds in 
+  let irecargs = Array.map snd irecargs_nmr
+  and nmr' = array_min nmr irecargs_nmr
+  in (nmr',Rtree.mk_rec irecargs)
 
 
 (************************************************************************)
@@ -470,77 +536,106 @@ let is_recursive = Rtree.is_infinite
   array_exists one_is_rec
 *)
 
+(* Allowed eliminations *)
+
 let all_sorts = [InProp;InSet;InType]
-let impredicative_sorts = [InProp;InSet]
+let small_sorts = [InProp;InSet]
 let logical_sorts = [InProp]
 
-let allowed_sorts env issmall isunit = function
-  | Type _ -> all_sorts
-  | Prop Pos -> 
-      if issmall then all_sorts
-      else impredicative_sorts
-  | Prop Null -> 
-(* Added InType which is derivable :when the type is unit and small *)
-(* unit+small types have all elimination 
-   In predicative system, the 
-   other inductive definitions have only Prop elimination.
-   In impredicative system, large unit type have also Set elimination
-*)   if isunit then 
-	if issmall then all_sorts
-	else if Environ.engagement env = None 
-        then logical_sorts else impredicative_sorts
-      else logical_sorts
-
-let build_inductive env env_ar record finite inds recargs cst =
+let allowed_sorts issmall isunit s =
+  match family_of_sort s with
+  (* Type: all elimination allowed *)
+  | InType -> all_sorts
+
+  (* Small Set is predicative: all elimination allowed *)
+  | InSet when issmall -> all_sorts
+
+  (* Large Set is necessarily impredicative: forbids large elimination *)
+  | InSet -> small_sorts
+
+  (* Unitary/empty Prop: elimination to all sorts are realizable *)
+  (* unless the type is large. If it is large, forbids large elimination *)
+  (* which otherwise allows to simulate the inconsistent system Type:Type *)
+  | InProp when isunit -> if issmall then all_sorts else small_sorts
+
+  (* Other propositions: elimination only to Prop *)
+  | InProp -> logical_sorts
+
+let fold_inductive_blocks f =
+  Array.fold_left (fun acc (_,_,lc,(arsign,_)) ->
+    f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (* dummy *) mkSet arsign))
+
+let used_section_variables env inds =
+  let ids = fold_inductive_blocks
+    (fun l c -> Idset.union (Environ.global_vars_set env c) l)
+      Idset.empty inds in
+  keep_hyps env ids
+
+let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
   let ntypes = Array.length inds in
   (* Compute the set of used section variables *)
-  let ids = 
-    Array.fold_left 
-      (fun acc (_,_,ar,_,_,_,lc) -> 
-	 Idset.union (Environ.global_vars_set env (body_of_type ar))
-	   (Array.fold_left
-	      (fun acc c ->
-                Idset.union (global_vars_set env (body_of_type c)) acc)
-	      acc
-	      lc))
-      Idset.empty inds in
-  let hyps = keep_hyps env ids in
+  let hyps =  used_section_variables env inds in
+  let nparamargs = rel_context_nhyps params in
   (* Check one inductive *)
-  let build_one_packet (params,id,ar,cnames,issmall,isunit,lc) recarg =
-    (* Arity in normal form *)
-    let nparamargs = rel_context_nhyps params in
-    let (ar_sign,ar_sort) = dest_arity env ar in
-    let nf_ar =
-      if isArity (body_of_type ar) then ar
-      else it_mkProd_or_LetIn (mkSort ar_sort) ar_sign in
+  let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg =
     (* Type of constructors in normal form *)
     let splayed_lc = Array.map (dest_prod_assum env_ar) lc in
-    let nf_lc =
-      array_map2 (fun (d,b) c -> it_mkProd_or_LetIn b d) splayed_lc lc in
+    let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in
     let nf_lc = if nf_lc = lc then lc else nf_lc in
+    let consnrealargs =
+      Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
+	splayed_lc in
     (* Elimination sorts *)
-    let isunit = isunit && ntypes = 1 && (not (is_recursive recargs.(0))) in
-    let kelim = allowed_sorts env issmall isunit ar_sort in
+    let arkind,kelim = match ar_kind with
+    | Inr (param_levels,lev) ->
+	Polymorphic {
+	  poly_param_levels = param_levels;
+	  poly_level = lev; 
+	}, all_sorts
+    | Inl ((issmall,isunit),ar,s) ->
+	let isunit = isunit && ntypes = 1 && not (is_recursive recargs.(0)) in
+	let kelim = allowed_sorts issmall isunit s in
+	Monomorphic {
+	  mind_user_arity = ar;
+	  mind_sort = s; 
+	}, kelim in
+    let nconst, nblock = ref 0, ref 0 in 
+    let transf num =
+      let arity = List.length (dest_subterms recarg).(num) in
+      if arity = 0 then 
+	let p  = (!nconst, 0) in
+	incr nconst; p
+      else 
+	let p = (!nblock + 1, arity) in
+	incr nblock; p
+     (* les tag des constructeur constant commence a 0,
+	les tag des constructeur non constant a 1 (0 => accumulator) *)
+    in 
+    let rtbl = Array.init (List.length cnames) transf in
     (* Build the inductive packet *)
     { mind_typename = id;
-      mind_nparams = nparamargs;
-      mind_params_ctxt = params;
-      mind_user_arity  = ar;
-      mind_nf_arity = nf_ar;
+      mind_arity = arkind;
+      mind_arity_ctxt = ar_sign;
       mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
-      mind_sort = ar_sort;
       mind_kelim = kelim;
       mind_consnames = Array.of_list cnames;
+      mind_consnrealdecls = consnrealargs;
       mind_user_lc = lc;
       mind_nf_lc = nf_lc;
       mind_recargs = recarg;
+      mind_nb_constant = !nconst;
+      mind_nb_args = !nblock;
+      mind_reloc_tbl = rtbl;
     } in
   let packets = array_map2 build_one_packet inds recargs in
   (* Build the mutual inductive *)
-  { mind_record = record;
+  { mind_record = isrecord;
     mind_ntypes = ntypes;
-    mind_finite = finite;
+    mind_finite = isfinite;
     mind_hyps = hyps;
+    mind_nparams = nparamargs;
+    mind_nparams_rec = nmr;  
+    mind_params_ctxt = params;
     mind_packets = packets;
     mind_constraints = cst;
     mind_equiv = None;
@@ -551,10 +646,9 @@ let build_inductive env env_ar record finite inds recargs cst =
 
 let check_inductive env mie =
   (* First type-check the inductive definition *)
-  let (env_arities, inds, cst) = typecheck_inductive env mie in
+  let (env_ar, params, inds, cst) = typecheck_inductive env mie in
   (* Then check positivity conditions *)
-  let recargs = check_positivity env_arities inds in
+  let (nmr,recargs) = check_positivity env_ar params inds in
   (* Build the inductive packets *)
-  build_inductive env env_arities mie.mind_entry_record mie.mind_entry_finite 
-    inds recargs cst
-
+  build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite
+    inds nmr recargs cst
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index f5e6d047..67d11f56 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indtypes.mli,v 1.23.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+(*i $Id: indtypes.mli 7660 2005-12-17 21:13:48Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -22,8 +22,8 @@ open Typeops
 (*s The different kinds of errors that may result of a malformed inductive
   definition. *)
 
+(* Errors related to inductive constructions *)
 type inductive_error =
-  (* These are errors related to inductive constructions in this module *)
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
   | NotConstructor of env * constr * constr
@@ -33,10 +33,6 @@ type inductive_error =
   | SameNamesOverlap of identifier list
   | NotAnArity of identifier
   | BadEntry
-  (* These are errors related to recursors building in Indrec *)
-  | NotAllowedCaseAnalysis of bool * sorts * inductive
-  | BadInduction of bool * identifier * sorts
-  | NotMutualInScheme
 
 exception InductiveError of inductive_error
 
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 07e9b8ea..2f17d659 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductive.ml,v 1.74.2.2 2004/07/16 19:30:25 herbelin Exp $ *)
+(* $Id: inductive.ml 9421 2006-12-08 16:00:53Z barras $ *)
 
 open Util
 open Names
@@ -18,6 +18,8 @@ open Environ
 open Reduction
 open Type_errors
 
+type mind_specif = mutual_inductive_body * one_inductive_body
+
 (* raise Not_found if not an inductive type *)
 let lookup_mind_specif env (kn,tyi) =
   let mib = Environ.lookup_mind kn env in
@@ -28,8 +30,8 @@ let lookup_mind_specif env (kn,tyi) =
 let find_rectype env c =
   let (t, l) = decompose_app (whd_betadeltaiota env c) in
   match kind_of_term t with
-    | Ind ind -> (ind, l)
-    | _ -> raise Not_found
+  | Ind ind -> (ind, l)
+  | _ -> raise Not_found
 
 let find_inductive env c =
   let (t, l) = decompose_app (whd_betadeltaiota env c) in
@@ -45,6 +47,8 @@ let find_coinductive env c =
         when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
     | _ -> raise Not_found
 
+let inductive_params (mib,_) = mib.mind_nparams
+
 (************************************************************************)
 
 (* Build the substitution that replaces Rels by the appropriate *)
@@ -57,13 +61,10 @@ let ind_subst mind mib =
 (* Instantiate inductives in constructor type *)
 let constructor_instantiate mind mib c =
   let s = ind_subst mind mib in
-  type_app (substl s) c
+  substl s c
 
-(* Instantiate the parameters of the inductive type *)
-(* TODO: verify the arg of LetIn correspond to the value in the
-   signature ? *)
-let instantiate_params t args sign =
-  let fail () =
+let instantiate_params full t args sign =
+  let fail () = 
     anomaly "instantiate_params: type, ctxt and args mismatch" in
   let (rem_args, subs, ty) =
     Sign.fold_rel_context
@@ -71,38 +72,146 @@ let instantiate_params t args sign =
         match (copt, largs, kind_of_term ty) with
           | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t)
           | (Some b,_,LetIn(_,_,_,t))    -> (largs, (substl subs b)::subs, t)
-	  | _                            -> fail())
+	  | (_,[],_)                -> if full then fail() else ([], subs, ty)
+	  | _                       -> fail ())
       sign
       ~init:(args,[],t) 
   in
   if rem_args <> [] then fail();
-  type_app (substl subs) ty
+  substl subs ty
 
-let full_inductive_instantiate mip params t =
-  instantiate_params t params mip.mind_params_ctxt
+let instantiate_partial_params = instantiate_params false
 
-let full_constructor_instantiate (((mind,_),mib,mip),params) =
+let full_inductive_instantiate mib params sign =
+  let dummy = mk_Prop in
+  let t = mkArity (sign,dummy) in
+  fst (destArity (instantiate_params true t params mib.mind_params_ctxt))
+
+let full_constructor_instantiate ((mind,_),(mib,_),params) =
   let inst_ind = constructor_instantiate mind mib in
   (fun t ->
-    instantiate_params (inst_ind t) params mip.mind_params_ctxt)
+    instantiate_params true (inst_ind t) params mib.mind_params_ctxt)
 
 (************************************************************************)
 (************************************************************************)
 
 (* Functions to build standard types related to inductive *)
 
-(* Type of an inductive type *)
 
-let type_of_inductive env i =
-  let (_,mip) = lookup_mind_specif env i in
-  mip.mind_user_arity
+let number_of_inductives mib = Array.length mib.mind_packets
+let number_of_constructors mip = Array.length mip.mind_consnames
+
+(* 
+Computing the actual sort of an applied or partially applied inductive type:
+
+I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a)
+uniformargs : utyps 
+otherargs : otyps
+I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj
+s'_k = max(..s_kj..)
+merge(..s'_k..) = ..s''_k..
+--------------------------------------------------------------------
+Gamma |- I_i uniformargs otherargs : phi(s''_i)
+
+where
+
+- if p=0, phi() = Prop
+- if p=1, phi(s) = s
+- if p<>1, phi(s) = sup(Set,s)
+
+Remark: Set (predicative) is encoded as Type(0)
+*)
+
+let sort_as_univ = function
+| Type u -> u
+| Prop Null -> neutral_univ
+| Prop Pos -> base_univ
+
+let cons_subst u su subst =
+  try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst
+  with Not_found -> (u, su) :: subst
+
+let actualize_decl_level env lev t =
+  let sign,s = dest_arity env t in
+  mkArity (sign,lev)
+
+let polymorphism_on_non_applied_parameters = false
+
+(* Bind expected levels of parameters to actual levels *)
+(* Propagate the new levels in the signature *)
+let rec make_subst env = function
+  | (_,Some _,_ as t)::sign, exp, args ->
+      let ctx,subst = make_subst env (sign, exp, args) in
+      t::ctx, subst
+  | d::sign, None::exp, args ->
+      let args = match args with _::args -> args | [] -> [] in
+      let ctx,subst = make_subst env (sign, exp, args) in
+      d::ctx, subst
+  | d::sign, Some u::exp, a::args ->
+      (* We recover the level of the argument, but we don't change the *)
+      (* level in the corresponding type in the arity; this level in the *)
+      (* arity is a global level which, at typing time, will be enforce *)
+      (* to be greater than the level of the argument; this is probably *)
+      (* a useless extra constraint *)
+      let s = sort_as_univ (snd (dest_arity env a)) in
+      let ctx,subst = make_subst env (sign, exp, args) in
+      d::ctx, cons_subst u s subst
+  | (na,None,t as d)::sign, Some u::exp, [] ->
+      (* No more argument here: we instantiate the type with a fresh level *)
+      (* which is first propagated to the corresponding premise in the arity *)
+      (* (actualize_decl_level), then to the conclusion of the arity (via *)
+      (* the substitution) *)
+      let ctx,subst = make_subst env (sign, exp, []) in
+      if polymorphism_on_non_applied_parameters then
+	let s = fresh_local_univ () in
+	let t = actualize_decl_level env (Type s) t in
+	(na,None,t)::ctx, cons_subst u s subst
+      else
+	d::ctx, subst
+  | sign, [], _ ->
+      (* Uniform parameters are exhausted *)
+      sign,[]
+  | [], _, _ ->
+      assert false
+
+let instantiate_universes env ctx ar argsorts =
+  let args = Array.to_list argsorts in
+  let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in
+  let level = subst_large_constraints subst ar.poly_level in
+  ctx,
+  if is_empty_univ level then mk_Prop
+  else if is_base_univ level then mk_Set
+  else Type level
+
+let type_of_inductive_knowing_parameters env mip paramtyps =
+  match mip.mind_arity with
+  | Monomorphic s ->
+      s.mind_user_arity
+  | Polymorphic ar ->
+      let ctx = List.rev mip.mind_arity_ctxt in
+      let ctx,s = instantiate_universes env ctx ar paramtyps in
+      mkArity (List.rev ctx,s)
+
+(* Type of a (non applied) inductive type *)
+
+let type_of_inductive env (_,mip) =
+  type_of_inductive_knowing_parameters env mip [||]
+
+(* The max of an array of universes *)
+
+let cumulate_constructor_univ u = function
+  | Prop Null -> u
+  | Prop Pos -> sup base_univ u
+  | Type u' -> sup u u'
+
+let max_inductive_sort =
+  Array.fold_left cumulate_constructor_univ neutral_univ
 
 (************************************************************************)
 (* Type of a constructor *)
 
-let type_of_constructor env cstr =
+let type_of_constructor cstr (mib,mip) =
   let ind = inductive_of_constructor cstr in
-  let (mib,mip) = lookup_mind_specif env ind in
   let specif = mip.mind_user_lc in
   let i = index_of_constructor cstr in
   let nconstr = Array.length mip.mind_consnames in
@@ -113,26 +222,18 @@ let arities_of_specif kn (mib,mip) =
   let specif = mip.mind_nf_lc in
   Array.map (constructor_instantiate kn mib) specif
 
-let arities_of_constructors env ind = 
-  arities_of_specif (fst ind) (lookup_mind_specif env ind)
+let arities_of_constructors ind specif = 
+  arities_of_specif (fst ind) specif
 
 
 
 (************************************************************************)
 
-let is_info_arity env c =
-  match dest_arity env c with
-    | (_,Prop Null) -> false 
-    | (_,Prop Pos)  -> true 
-    | (_,Type _)    -> true
-
-let error_elim_expln env kp ki =
-  if is_info_arity env kp && not (is_info_arity env ki) then
-    NonInformativeToInformative
-  else 
-    match (kind_of_term kp,kind_of_term ki) with 
-      | Sort (Type _), Sort (Prop _) -> StrongEliminationOnNonSmallType
-      | _ -> WrongArity
+let error_elim_expln kp ki =
+  match kp,ki with
+  | (InType | InSet), InProp -> NonInformativeToInformative
+  | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
+  | _ -> WrongArity
 
 (* Type of case predicates *)
 
@@ -149,69 +250,69 @@ let local_rels ctxt =
   rels
 
 (* Get type of inductive, with parameters instantiated *)
-let get_arity mip params =
-  let arity = mip.mind_nf_arity in
-  destArity (full_inductive_instantiate mip params arity)
 
-let build_dependent_inductive ind mip params =
-  let arsign,_ = get_arity mip params in
+let inductive_sort_family mip =
+  match mip.mind_arity with
+   | Monomorphic s -> family_of_sort s.mind_sort 
+   | Polymorphic _ -> InType
+
+let mind_arity mip =
+  mip.mind_arity_ctxt, inductive_sort_family mip
+
+let get_instantiated_arity (mib,mip) params =
+  let sign, s = mind_arity mip in
+  full_inductive_instantiate mib params sign, s
+
+let elim_sorts (_,mip) = mip.mind_kelim
+
+let rel_list n m = 
+  let rec reln l p = 
+    if p>m then l else reln (mkRel(n+p)::l) (p+1)
+  in 
+  reln [] 1
+
+let build_dependent_inductive ind (_,mip) params =
   let nrealargs = mip.mind_nrealargs in
   applist 
-    (mkInd ind, (List.map (lift nrealargs) params)@(local_rels arsign))
-
+    (mkInd ind, (List.map (lift nrealargs) params)@(rel_list 0 nrealargs))
 
 (* This exception is local *)
-exception LocalArity of (constr * constr * arity_error) option
+exception LocalArity of (sorts_family * sorts_family * arity_error) option
+
+let check_allowed_sort ksort specif =
+  if not (List.exists ((=) ksort) (elim_sorts specif)) then 
+    let s = inductive_sort_family (snd specif) in
+    raise (LocalArity (Some(ksort,s,error_elim_expln ksort s)))
 
-let is_correct_arity env c pj ind mip params = 
-  let kelim = mip.mind_kelim in
-  let arsign,s = get_arity mip params in
-  let nodep_ar = it_mkProd_or_LetIn (mkSort s) arsign in
-  let rec srec env pt t u =
+let is_correct_arity env c pj ind specif params = 
+  let arsign,_ = get_instantiated_arity specif params in
+  let rec srec env pt ar u =
     let pt' = whd_betadeltaiota env pt in
-    let t' = whd_betadeltaiota env t in
-    match kind_of_term pt', kind_of_term t' with
-      | Prod (na1,a1,a2), Prod (_,a1',a2') ->
+    match kind_of_term pt', ar with
+      | Prod (na1,a1,t), (_,None,a1')::ar' ->
           let univ =
             try conv env a1 a1'
             with NotConvertible -> raise (LocalArity None) in
-          srec (push_rel (na1,None,a1) env) a2 a2' (Constraint.union u univ)
-      | Prod (_,a1,a2), _ -> 
-          let k = whd_betadeltaiota env a2 in 
-          let ksort = match kind_of_term k with
+          srec (push_rel (na1,None,a1) env) t ar' (Constraint.union u univ)
+      | Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *)
+          let ksort = match kind_of_term (whd_betadeltaiota env a2) with
             | Sort s -> family_of_sort s 
 	    | _ -> raise (LocalArity None) in
-	  let dep_ind = build_dependent_inductive ind mip params in
+	  let dep_ind = build_dependent_inductive ind specif params in 
           let univ =
             try conv env a1 dep_ind
             with NotConvertible -> raise (LocalArity None) in
-          if List.exists ((=) ksort) kelim then
-	    (true, Constraint.union u univ)
-          else 
-	    raise (LocalArity (Some(k,t',error_elim_expln env k t')))
-      | k, Prod (_,_,_) ->
+	  check_allowed_sort ksort specif;
+	  (true, Constraint.union u univ)
+      | Sort s', [] ->
+	  check_allowed_sort (family_of_sort s') specif;
+	  (false, u)
+      | _ ->
 	  raise (LocalArity None)
-      | k, ki -> 
-	  let ksort = match k with
-            | Sort s -> family_of_sort s 
-            | _ ->  raise (LocalArity None) in
-          if List.exists ((=) ksort) kelim then 
-	    (false, u)
-          else 
-	    raise (LocalArity (Some(pt',t',error_elim_expln env pt' t')))
   in 
-  try srec env pj.uj_type nodep_ar Constraint.empty
+  try srec env pj.uj_type (List.rev arsign) Constraint.empty
   with LocalArity kinds ->
-    let create_sort = function 
-      | InProp -> mkProp
-      | InSet -> mkSet
-      | InType -> mkSort type_0 in
-    let listarity = List.map create_sort kelim
-(*    let listarity =
-      (List.map (fun s -> make_arity env true indf (create_sort s)) kelim)
-      @(List.map (fun s -> make_arity env false indf (create_sort s)) kelim)*)
-    in 
-    error_elim_arity env ind listarity c pj kinds
+    error_elim_arity env ind (elim_sorts specif) c pj kinds
 
 
 (************************************************************************)
@@ -219,13 +320,13 @@ let is_correct_arity env c pj ind mip params =
 
 (* [p] is the predicate, [i] is the constructor number (starting from 0),
    and [cty] is the type of the constructor (params not instantiated) *)
-let build_branches_type ind mib mip params dep p =
+let build_branches_type ind (_,mip as specif) params dep p =
   let build_one_branch i cty =
-    let typi = full_constructor_instantiate ((ind,mib,mip),params) cty in
+    let typi = full_constructor_instantiate (ind,specif,params) cty in
     let (args,ccl) = decompose_prod_assum typi in
     let nargs = rel_context_length args in
     let (_,allargs) = decompose_app ccl in
-    let (lparams,vargs) = list_chop mip.mind_nparams allargs in
+    let (lparams,vargs) = list_chop (inductive_params specif) allargs in
     let cargs =
       if dep then
         let cstr = ith_constructor_of_inductive ind (i+1) in
@@ -244,12 +345,12 @@ let build_case_type dep p c realargs =
   beta_appvect p (Array.of_list args)
 
 let type_case_branches env (ind,largs) pj c =
-  let (mib,mip) = lookup_mind_specif env ind in 
-  let nparams = mip.mind_nparams in
+  let specif = lookup_mind_specif env ind in 
+  let nparams = inductive_params specif in
   let (params,realargs) = list_chop nparams largs in
   let p = pj.uj_val in
-  let (dep,univ) = is_correct_arity env c pj ind mip params in
-  let lc = build_branches_type ind mib mip params dep p in
+  let (dep,univ) = is_correct_arity env c pj ind specif params in
+  let lc = build_branches_type ind specif params dep p in
   let ty = build_case_type dep p c realargs in
   (lc, ty, univ)
 
@@ -257,11 +358,22 @@ let type_case_branches env (ind,largs) pj c =
 (************************************************************************)
 (* Checking the case annotation is relevent *)
 
+let rec inductive_kn_equiv env kn1 kn2 =
+  match (lookup_mind kn1 env).mind_equiv with
+    | Some kn1' -> inductive_kn_equiv env kn2 kn1'
+    | None -> match (lookup_mind kn2 env).mind_equiv with
+        | Some kn2' -> inductive_kn_equiv env kn2' kn1
+	| None -> false
+
+let inductive_equiv env (kn1,i1) (kn2,i2) =
+  i1=i2 & inductive_kn_equiv env kn1 kn2
+
 let check_case_info env indsp ci =
   let (mib,mip) = lookup_mind_specif env indsp in
   if
-    (indsp <> ci.ci_ind) or
-    (mip.mind_nparams <> ci.ci_npar)
+    not (Closure.mind_equiv env indsp ci.ci_ind) or
+    (mib.mind_nparams <> ci.ci_npar) or
+    (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
   then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
 
 (************************************************************************)
@@ -286,24 +398,27 @@ let check_case_info env indsp ci =
    first argument.
 *)
 
-(*************************)
-(* Environment annotated with marks on recursive arguments:
-   it is a triple (env,lst,n) where
-   - env is the typing environment
-   - lst is a mapping from de Bruijn indices to list of recargs
-     (tells which subterms of that variable are recursive)
-   - n is the de Bruijn index of the fixpoint for which we are
-     checking the guard condition.
+(*************************************************************)
+(* Environment annotated with marks on recursive arguments *)
 
-   Below are functions to handle such environment.
- *)
+(* tells whether it is a strict or loose subterm *)
 type size = Large | Strict
 
+(* merging information *)
 let size_glb s1 s2 =
   match s1,s2 with
       Strict, Strict -> Strict
     | _ -> Large
 
+(* possible specifications for a term:
+   - Not_subterm: when the size of a term is not related to the
+     recursive argument of the fixpoint
+   - Subterm: when the term is a subterm of the recursive argument
+       the wf_paths argument specifies which subterms are recursive
+   - Dead_code: when the term has been built by elimination over an
+       empty type
+ *)
+
 type subterm_spec =
     Subterm of (size * wf_paths)
   | Dead_code
@@ -404,31 +519,43 @@ let lookup_subterms env ind =
 
 (*********************************)
 
-(* finds the inductive type of the recursive argument of a fixpoint *)
-let inductive_of_fix env recarg body =
-  let (ctxt,b) = decompose_lam_n_assum recarg body in
-  let env' = push_rel_context ctxt env in
-  let (_,ty,_) = destLambda(whd_betadeltaiota env' b) in
-  let (i,_) = decompose_app (whd_betadeltaiota env' ty) in 
-  destInd i
+(* Propagation of size information through Cases: if the matched
+   object is a recursive subterm then compute the information
+   associated to its own subterms.
+   Rq: if branch is not eta-long, then the recursive information
+   is not propagated to the missing abstractions *)
+let case_branches_specif renv c_spec ind lbr = 
+  let rec push_branch_args renv lrec c = 
+    match lrec with
+        ra::lr ->
+          let c' = whd_betadeltaiota renv.env c in
+          (match kind_of_term c' with
+              Lambda(x,a,b) ->
+                let renv' = push_var renv (x,a,ra) in
+                push_branch_args renv' lr b
+            | _ -> (* branch not in eta-long form: cannot perform rec. calls *)
+                (renv,c'))
+      | [] -> (renv, c) in
+  match c_spec with
+      Subterm (_,t) ->
+        let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in
+        assert (Array.length sub_spec = Array.length lbr);
+        array_map2 (push_branch_args renv) sub_spec lbr
+    | Dead_code -> 
+        let t = dest_subterms (lookup_subterms renv.env ind) in
+        let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in
+        assert (Array.length sub_spec = Array.length lbr);
+        array_map2 (push_branch_args renv) sub_spec lbr
+    | Not_subterm -> Array.map (fun c -> (renv,c)) lbr
 
-(* 
-   subterm_specif env c ind 
-
-   subterm_specif should test if [c] (building objects of inductive
-   type [ind], not necassarily the same as that of the recursive
-   argument) is a subterm of the recursive argument of the fixpoint we
-   are checking and fails with Not_found if not. In case it is, it
-   should send its recursive specification (i.e. on which arguments we
-   are allowed to make recursive calls). This recursive spec should be
-   the same size as the number of constructors of the type of c.
-
-   Returns:
-   - [Some lc] if [c] is a strict subterm of the rec. arg. (or a Meta) 
-   - [None] otherwise
+(* [subterm_specif renv t] computes the recursive structure of [t] and
+   compare its size with the size of the initial recursive argument of
+   the fixpoint we are checking. [renv] collects such information
+   about variables.
 *)
 
-let rec subterm_specif renv t ind = 
+let rec subterm_specif renv t = 
+  (* maybe reduction is not always necessary! *)
   let f,l = decompose_app (whd_betadeltaiota renv.env t) in
   match kind_of_term f with 
     | Rel k -> subterm_var k renv
@@ -436,9 +563,10 @@ let rec subterm_specif renv t ind =
     | Case (ci,_,c,lbr) ->
         if Array.length lbr = 0 then Dead_code
         else
-          let lbr_spec = case_branches_specif renv c ci.ci_ind lbr in
+          let c_spec = subterm_specif renv c in
+          let lbr_spec = case_branches_specif renv c_spec ci.ci_ind lbr in
           let stl  =
-            Array.map (fun (renv',br') -> subterm_specif renv' br' ind)
+            Array.map (fun (renv',br') -> subterm_specif renv' br')
               lbr_spec in
           subterm_spec_glb stl
 	       
@@ -448,65 +576,50 @@ let rec subterm_specif renv t ind =
    furthermore when f is applied to a term which is strictly less than
    n, one may assume that x itself is strictly less than n
 *)
-        let nbfix = Array.length typarray in
-        let recargs = lookup_subterms renv.env ind in
-        (* pushing the fixpoints *)
-        let renv' = push_fix_renv renv recdef in
-        let renv' =
-          assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in
-        let decrArg = recindxs.(i) in 
-        let theBody = bodies.(i)   in
-        let nbOfAbst = decrArg+1 in
-        let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
-        (* pushing the fix parameters *)
-        let renv'' = push_ctxt_renv renv' sign in
-        let renv'' =
-          if List.length l < nbOfAbst then renv''
-          else
-            let decrarg_ind = inductive_of_fix renv''.env decrArg theBody in
-            let theDecrArg  = List.nth l decrArg in
-	    let arg_spec    = subterm_specif renv theDecrArg decrarg_ind in
-            assign_var_spec renv'' (1, arg_spec) in
-	subterm_specif renv'' strippedBody ind
-	    
+        let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
+        let oind =
+          let env' = push_rel_context ctxt renv.env in
+          try Some(fst(find_inductive env' clfix))
+          with Not_found -> None in
+        (match oind with
+            None -> Not_subterm (* happens if fix is polymorphic *)
+          | Some ind ->
+              let nbfix = Array.length typarray in
+              let recargs = lookup_subterms renv.env ind in
+              (* pushing the fixpoints *)
+              let renv' = push_fix_renv renv recdef in
+              let renv' =
+                (* Why Strict here ? To be general, it could also be
+                   Large... *)
+                assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in
+              let decrArg = recindxs.(i) in 
+              let theBody = bodies.(i)   in
+              let nbOfAbst = decrArg+1 in
+              let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
+              (* pushing the fix parameters *)
+              let renv'' = push_ctxt_renv renv' sign in
+              let renv'' =
+                if List.length l < nbOfAbst then renv''
+                else
+                  let theDecrArg  = List.nth l decrArg in
+	          let arg_spec    = subterm_specif renv theDecrArg in
+                  assign_var_spec renv'' (1, arg_spec) in
+	      subterm_specif renv'' strippedBody)
+
     | Lambda (x,a,b) -> 
         assert (l=[]);
-        subterm_specif (push_var_renv renv (x,a)) b ind
+        subterm_specif (push_var_renv renv (x,a)) b
+
+    (* Metas and evars are considered OK *)
+    | (Meta _|Evar _) -> Dead_code
 
-    (* A term with metas is considered OK *)
-    | Meta _ -> Dead_code
     (* Other terms are not subterms *)
     | _ -> Not_subterm
 
-(* Propagation of size information through Cases: if the matched
-   object is a recursive subterm then compute the information
-   associated to its own subterms.
-   Rq: if branch is not eta-long, then the recursive information
-   is not propagated *)
-and case_branches_specif renv c ind lbr = 
-  let c_spec = subterm_specif renv c ind in
-  let rec push_branch_args renv lrec c = 
-    let c' = strip_outer_cast (whd_betadeltaiota renv.env c) in 
-    match lrec, kind_of_term c' with 
-      |	(ra::lr,Lambda (x,a,b)) ->
-          let renv' = push_var renv (x,a,ra) in
-          push_branch_args renv' lr b
-      | (_,_) -> (renv,c') in
-  match c_spec with
-      Subterm (_,t) ->
-        let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in
-        assert (Array.length sub_spec = Array.length lbr);
-        array_map2 (push_branch_args renv) sub_spec lbr
-    | Dead_code -> 
-        let t = dest_subterms (lookup_subterms renv.env ind) in
-        let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in
-        assert (Array.length sub_spec = Array.length lbr);
-        array_map2 (push_branch_args renv) sub_spec lbr
-    | Not_subterm -> Array.map (fun c -> (renv,c)) lbr
 
 (* Check term c can be applied to one of the mutual fixpoints. *)
-let check_is_subterm renv c ind = 
-  match subterm_specif renv c ind with
+let check_is_subterm renv c = 
+  match subterm_specif renv c with
     Subterm (Strict,_) | Dead_code -> true
   |  _ -> false
 
@@ -529,119 +642,107 @@ let error_illegal_rec_call renv fx arg =
 let error_partial_apply renv fx =
   raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
 
-
 (* Check if [def] is a guarded fixpoint body with decreasing arg.
    given [recpos], the decreasing arguments of each mutually defined
    fixpoint. *)
 let check_one_fix renv recpos def =
   let nfi = Array.length recpos in 
+
+  (* Checks if [t] only make valid recursive calls *)
   let rec check_rec_call renv t = 
     (* if [t] does not make recursive calls, it is guarded: *)
-    noccur_with_meta renv.rel_min nfi t or 
-    (* Rq: why not try and expand some definitions ? *)
-    let f,l = decompose_app (whd_betaiotazeta renv.env t) in
-    match kind_of_term f with
-      | Rel p -> 
-          (* Test if it is a recursive call: *) 
-	  if renv.rel_min <= p & p < renv.rel_min+nfi then
-            (* the position of the invoked fixpoint: *) 
-	    let glob = renv.rel_min+nfi-1-p in
-            (* the decreasing arg of the rec call: *)
-	    let np = recpos.(glob) in
-            if List.length l <= np then error_partial_apply renv glob;
-	    match list_chop np l with
-		(la,(z::lrest)) -> 
-                  (* Check the decreasing arg is smaller *)
-	          if not (check_is_subterm renv z renv.inds.(glob)) then
-                    error_illegal_rec_call renv glob z;
-                  List.for_all (check_rec_call renv) (la@lrest)
-		| _ -> assert false
-          (* otherwise check the arguments are guarded: *)
-	  else List.for_all (check_rec_call renv) l        
-
-      | Case (ci,p,c_0,lrest) ->
-          List.for_all (check_rec_call renv) (c_0::p::l) &&
-          (* compute the recarg information for the arguments of
-             each branch *)
-          let lbr = case_branches_specif renv c_0 ci.ci_ind lrest in
-          array_for_all (fun (renv',br') -> check_rec_call renv' br') lbr
-
-  (* Enables to traverse Fixpoint definitions in a more intelligent
-     way, ie, the rule :
-
-     if - g = Fix g/1 := [y1:T1]...[yp:Tp]e &
-        - f is guarded with respect to the set of pattern variables S 
-          in a1 ... am        &
-        - f is guarded with respect to the set of pattern variables S 
-          in T1 ... Tp        &
-        - ap is a sub-term of the formal argument of f &
-        - f is guarded with respect to the set of pattern variables S+{yp}
-          in e
-     then f is guarded with respect to S in (g a1 ... am).
-
-     Eduardo 7/9/98 *)
-
-      | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
-          List.for_all (check_rec_call renv) l &&
-          array_for_all (check_rec_call renv) typarray && 
-	  let nbfix = Array.length typarray in
-          let decrArg = recindxs.(i) in
-          let renv' = push_fix_renv renv recdef in 
-          if (List.length l < (decrArg+1)) then
-	    array_for_all (check_rec_call renv') bodies
-          else 
-            let ok_vect =
-              Array.mapi
+    if noccur_with_meta renv.rel_min nfi t then ()
+    else
+      let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in
+      match kind_of_term f with
+        | Rel p -> 
+            List.iter (check_rec_call renv) l;
+            (* Test if [p] is a fixpoint (recursive call) *) 
+	    if renv.rel_min <= p & p < renv.rel_min+nfi then
+              (* the position of the invoked fixpoint: *) 
+	      let glob = renv.rel_min+nfi-1-p in
+              (* the decreasing arg of the rec call: *)
+	      let np = recpos.(glob) in
+              if List.length l <= np then error_partial_apply renv glob
+              else
+	        (match list_chop np l with
+		    (la,(z::lrest)) -> 
+                      (* Check the decreasing arg is smaller *)
+	              if not (check_is_subterm renv z) then
+                        error_illegal_rec_call renv glob z
+	          | _ -> assert false)
+
+        | Case (ci,p,c_0,lrest) ->
+            List.iter (check_rec_call renv) (c_0::p::l);
+            (* compute the recarg information for the arguments of
+               each branch *)
+            let c_spec = subterm_specif renv c_0 in
+            let lbr = case_branches_specif renv c_spec ci.ci_ind lrest in
+            Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr
+
+        (* Enables to traverse Fixpoint definitions in a more intelligent
+           way, ie, the rule :
+           if - g = Fix g/p := [y1:T1]...[yp:Tp]e &
+              - f is guarded with respect to the set of pattern variables S 
+                in a1 ... am        &
+              - f is guarded with respect to the set of pattern variables S 
+                in T1 ... Tp        &
+              - ap is a sub-term of the formal argument of f &
+              - f is guarded with respect to the set of pattern variables
+                S+{yp} in e
+           then f is guarded with respect to S in (g a1 ... am).
+           Eduardo 7/9/98 *)
+
+        | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+            List.iter (check_rec_call renv) l;
+            Array.iter (check_rec_call renv) typarray;
+            let decrArg = recindxs.(i) in
+            let renv' = push_fix_renv renv recdef in 
+            if (List.length l < (decrArg+1)) then
+	      Array.iter (check_rec_call renv') bodies
+            else 
+              Array.iteri
                 (fun j body ->
                   if i=j then
-                    let decrarg_ind =
-                      inductive_of_fix renv'.env decrArg body in
                     let theDecrArg  = List.nth l decrArg in
-	            let arg_spec =
-                      subterm_specif renv theDecrArg decrarg_ind in
+	            let arg_spec = subterm_specif renv theDecrArg in
 	            check_nested_fix_body renv' (decrArg+1) arg_spec body
                   else check_rec_call renv' body)
-                bodies in
-            array_for_all (fun b -> b) ok_vect
-
-      | Const kn as c -> 
-          (try List.for_all (check_rec_call renv) l
-           with (FixGuardError _ ) as e ->
-             if evaluable_constant kn renv.env then 
-	       check_rec_call renv
-                 (applist(constant_value renv.env kn, l))
-	     else raise e)
+                bodies
 
-      (* The cases below simply check recursively the condition on the
-         subterms *)
-      | Cast (a,b) -> 
-          List.for_all (check_rec_call renv) (a::b::l)
+        | Const kn -> 
+            if evaluable_constant kn renv.env then 
+              try List.iter (check_rec_call renv) l
+              with (FixGuardError _ ) ->
+	        check_rec_call renv(applist(constant_value renv.env kn, l))
+	    else List.iter (check_rec_call renv) l
 
-      | Lambda (x,a,b) ->
-          check_rec_call (push_var_renv renv (x,a)) b &&
-          List.for_all (check_rec_call renv) (a::l)
+        (* The cases below simply check recursively the condition on the
+           subterms *)
+        | Cast (a,_, b) -> 
+            List.iter (check_rec_call renv) (a::b::l)
 
-      | Prod (x,a,b) -> 
-          check_rec_call (push_var_renv renv (x,a)) b &&
-          List.for_all (check_rec_call renv) (a::l)
+        | Lambda (x,a,b) ->
+            List.iter (check_rec_call renv) (a::l);
+            check_rec_call (push_var_renv renv (x,a)) b
 
-      | CoFix (i,(_,typarray,bodies as recdef)) ->
-	  array_for_all (check_rec_call renv) typarray &&
-          List.for_all (check_rec_call renv) l &&
-	  let renv' = push_fix_renv renv recdef in
-	  array_for_all (check_rec_call renv') bodies
+        | Prod (x,a,b) -> 
+            List.iter (check_rec_call renv) (a::l);
+            check_rec_call (push_var_renv renv (x,a)) b
 
-      | Evar (_,la) -> 
-	  array_for_all (check_rec_call renv) la &&
-          List.for_all (check_rec_call renv) l
+        | CoFix (i,(_,typarray,bodies as recdef)) ->
+            List.iter (check_rec_call renv) l;
+	    Array.iter (check_rec_call renv) typarray;
+	    let renv' = push_fix_renv renv recdef in
+	    Array.iter (check_rec_call renv') bodies
 
-      | Meta _ -> true
+        | (Ind _ | Construct _ | Var _ | Sort _) ->
+            List.iter (check_rec_call renv) l
 
-      | (App _ | LetIn _) -> 
-	  anomaly "check_rec_call: should have been reduced"
+        (* l is not checked because it is considered as the meta's context *)
+        | (Evar _ | Meta _) -> ()
 
-      | (Ind _ | Construct _ | Var _ | Sort _) ->
-          List.for_all (check_rec_call renv) l
+        | (App _ | LetIn _) -> assert false (* beta zeta reduction *)
 
   and check_nested_fix_body renv decr recArgsDecrArg body =
     if decr = 0 then
@@ -649,11 +750,11 @@ let check_one_fix renv recpos def =
     else
       match kind_of_term body with
 	| Lambda (x,a,b) ->
+	    check_rec_call renv a;
             let renv' = push_var_renv renv (x,a) in
-	    check_rec_call renv a &&
 	    check_nested_fix_body renv' (decr-1) recArgsDecrArg b
 	| _ -> anomaly "Not enough abstractions in fix body"
-    
+
   in
   check_rec_call renv def
 
@@ -668,11 +769,10 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
     or bodynum >= nbfix
   then anomaly "Ill-formed fix term";
   let fixenv = push_rec_types recdef env in
-  let raise_err i err =
-    error_ill_formed_rec_body fixenv err names i in
+  let raise_err env i err =
+    error_ill_formed_rec_body env err names i in
   (* Check the i-th definition with recarg k *)
   let find_ind i k def = 
-    if k < 0 then anomaly "negative recarg position";
     (* check fi does not appear in the k+1 first abstractions, 
        gives the type of the k+1-eme abstraction (must be an inductive)  *)
     let rec check_occur env n def = 
@@ -684,24 +784,24 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
                 (* get the inductive type of the fixpoint *)
                 let (mind, _) = 
                   try find_inductive env a 
-                  with Not_found -> raise_err i RecursionNotOnInductiveType in
+                  with Not_found ->
+		    raise_err env i (RecursionNotOnInductiveType a) in
                 (mind, (env', b))
 	      else check_occur env' (n+1) b
             else anomaly "check_one_fix: Bad occurrence of recursive call"
-        | _ -> raise_err i NotEnoughAbstractionInFixBody in
+        | _ -> raise_err env i NotEnoughAbstractionInFixBody in
     check_occur fixenv 1 def in
   (* Do it on every fixpoint *)
   let rv = array_map2_i find_ind nvect bodies in
   (Array.map fst rv, Array.map snd rv)
 
 
-let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) =
+let check_fix env ((nvect,_),(names,_,bodies as _recdef) as fix) =
   let (minds, rdef) = inductive_of_mutfix env fix in
   for i = 0 to Array.length bodies - 1 do
     let (fenv,body) = rdef.(i) in
     let renv = make_renv fenv minds nvect.(i) minds.(i) in
-    try
-      let _ = check_one_fix renv nvect body in ()
+    try check_one_fix renv nvect body
     with FixGuardError (fixenv,err) ->
       error_ill_formed_rec_body fixenv err names i
   done
@@ -712,14 +812,6 @@ let check_fix env fix = Profile.profile3 cfkey check_fix env fix;;
 *)
 
 (************************************************************************)
-(* Scrape *)
-
-let rec scrape_mind env kn = 
-  match (Environ.lookup_mind kn env).mind_equiv with
-    | None -> kn
-    | Some kn' -> scrape_mind env kn'
-
-(************************************************************************)
 (* Co-fixpoints. *)
 
 exception CoFixGuardError of env * guard_error
@@ -739,28 +831,22 @@ let rec codomain_is_coind env c =
 
 let check_one_cofix env nbfix def deftype = 
   let rec check_rec_call env alreadygrd n vlra  t =
-    if noccur_with_meta n nbfix t then
-      true 
-    else
+    if not (noccur_with_meta n nbfix t) then
       let c,args = decompose_app (whd_betadeltaiota env t) in
       match kind_of_term c with 
-	| Meta _ -> true
-	      
 	| Rel p when  n <= p && p < n+nbfix ->
-	    (* recursive call *)
-            if alreadygrd then
-	      if List.for_all (noccur_with_meta n nbfix) args then
-		true
-	      else 
-		raise (CoFixGuardError (env,NestedRecursiveOccurrences))
-            else 
+	    (* recursive call: must be guarded and no nested recursive
+               call allowed *)
+            if not alreadygrd then
 	      raise (CoFixGuardError (env,UnguardedRecursiveCall t))
+            else if not(List.for_all (noccur_with_meta n nbfix) args) then
+	      raise (CoFixGuardError (env,NestedRecursiveOccurrences))
 		 
 	| Construct (_,i as cstr_kn)  ->
-            let lra =vlra.(i-1) in 
+            let lra = vlra.(i-1) in 
             let mI = inductive_of_constructor cstr_kn in
 	    let (mib,mip) = lookup_mind_specif env mI in
-            let realargs = list_skipn mip.mind_nparams args in
+            let realargs = list_skipn mib.mind_nparams args in
             let rec process_args_of_constr = function
               | (t::lr), (rar::lrar) -> 
                   if rar = mk_norec then
@@ -770,17 +856,17 @@ let check_one_cofix env nbfix def deftype =
 		                 (env,RecCallInNonRecArgOfConstructor t))
                   else
                     let spec = dest_subterms rar in
-                    check_rec_call env true n spec t &&
+                    check_rec_call env true n spec t;
                     process_args_of_constr (lr, lrar)
-              | [],_ -> true 
+              | [],_ -> ()
               | _ -> anomaly_ill_typed () 
             in process_args_of_constr (realargs, lra)
 		 
 	| Lambda (x,a,b) ->
 	     assert (args = []);
-            if (noccur_with_meta n nbfix a) then
-              check_rec_call (push_rel (x, None, a) env)
-		alreadygrd (n+1)  vlra b
+            if noccur_with_meta n nbfix a then
+              let env' = push_rel (x, None, a) env in
+              check_rec_call env' alreadygrd (n+1)  vlra b
             else 
 	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
 	      
@@ -790,10 +876,8 @@ let check_one_cofix env nbfix def deftype =
               let nbfix = Array.length vdefs in
 	      if (array_for_all (noccur_with_meta n nbfix) varit) then
 		let env' = push_rec_types recdef env in
-		(array_for_all
-		   (check_rec_call env' alreadygrd (n+1) vlra) vdefs)
-		&&
-		(List.for_all (check_rec_call env alreadygrd (n+1) vlra) args) 
+		(Array.iter (check_rec_call env' alreadygrd (n+1) vlra) vdefs;
+		 List.iter (check_rec_call env alreadygrd n vlra) args)
               else 
 		raise (CoFixGuardError (env,RecCallInTypeOfDef c))
 	    else
@@ -803,7 +887,7 @@ let check_one_cofix env nbfix def deftype =
             if (noccur_with_meta n nbfix p) then
               if (noccur_with_meta n nbfix tm) then
 		if (List.for_all (noccur_with_meta n nbfix) args) then
-		  (array_for_all (check_rec_call env alreadygrd n vlra) vrest)
+		  Array.iter (check_rec_call env alreadygrd n vlra) vrest
 		else 
 		  raise (CoFixGuardError (env,RecCallInCaseFun c))
               else 
@@ -811,7 +895,12 @@ let check_one_cofix env nbfix def deftype =
             else 
 	      raise (CoFixGuardError (env,RecCallInCasePred c))
               
+	| Meta _ -> ()
+        | Evar _ ->
+	    List.iter (check_rec_call env alreadygrd n vlra) args
+	      
 	| _    -> raise (CoFixGuardError (env,NotGuardedForm t)) in 
+
   let (mind, _) = codomain_is_coind env deftype in
   let vlra = lookup_subterms env mind in
   check_rec_call env false 1 (dest_subterms vlra) def
@@ -823,9 +912,7 @@ let check_cofix env (bodynum,(names,types,bodies as recdef)) =
   let nbfix = Array.length bodies in 
   for i = 0 to nbfix-1 do
     let fixenv = push_rec_types recdef env in
-    try 
-      let _ = check_one_cofix fixenv nbfix bodies.(i) types.(i)
-      in ()
+    try check_one_cofix fixenv nbfix bodies.(i) types.(i)
     with CoFixGuardError (errenv,err) -> 
       error_ill_formed_rec_body errenv err names i
   done
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index 04345621..58343dab 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductive.mli,v 1.57.8.2 2005/01/21 16:41:49 herbelin Exp $ i*)
+(*i $Id: inductive.mli 9421 2006-12-08 16:00:53Z barras $ i*)
 
 (*i*)
 open Names
@@ -28,24 +28,28 @@ val find_rectype     : env -> types -> inductive * constr list
 val find_inductive   : env -> types -> inductive * constr list
 val find_coinductive : env -> types -> inductive * constr list
 
+type mind_specif = mutual_inductive_body * one_inductive_body
+
 (*s Fetching information in the environment about an inductive type.
     Raises [Not_found] if the inductive type is not found. *)
-val lookup_mind_specif :
-  env -> inductive -> mutual_inductive_body * one_inductive_body
+val lookup_mind_specif : env -> inductive -> mind_specif
 
 (*s Functions to build standard types related to inductive *)
+val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list
+
+val type_of_inductive : env -> mind_specif -> types
 
-val type_of_inductive    : env -> inductive -> types
+val elim_sorts : mind_specif -> sorts_family list
 
 (* Return type as quoted by the user *)
-val type_of_constructor  : env -> constructor -> types
+val type_of_constructor : constructor -> mind_specif -> types
 
 (* Return constructor types in normal form *)
-val arities_of_constructors : env -> inductive -> types array
+val arities_of_constructors : inductive -> mind_specif -> types array
 
 (* Transforms inductive specification into types (in nf) *)
-val arities_of_specif : mutual_inductive -> 
-  mutual_inductive_body * one_inductive_body -> types array 
+val arities_of_specif : mutual_inductive -> mind_specif -> types array 
+
 
 (* [type_case_branches env (I,args) (p:A) c] computes useful types
    about the following Cases expression:
@@ -58,14 +62,49 @@ val type_case_branches :
   env -> inductive * constr list -> unsafe_judgment -> constr
     -> types array * types * constraints
 
+(* Return the arity of an inductive type *)
+val mind_arity : one_inductive_body -> Sign.rel_context * sorts_family
+
+val inductive_sort_family : one_inductive_body -> sorts_family
+
 (* Check a [case_info] actually correspond to a Case expression on the
    given inductive type. *)
 val check_case_info : env -> inductive -> case_info -> unit
 
-(* Find the ultimate inductive in the [mind_equiv] chain *)
-
-val scrape_mind : env -> mutual_inductive -> mutual_inductive
-
 (*s Guard conditions for fix and cofix-points. *)
 val check_fix : env -> fixpoint -> unit
 val check_cofix : env -> cofixpoint -> unit
+
+(*s Support for sort-polymorphic inductive types *)
+
+val type_of_inductive_knowing_parameters :
+  env -> one_inductive_body -> types array -> types
+
+val max_inductive_sort : sorts array -> universe
+
+val instantiate_universes : env -> Sign.rel_context ->
+    polymorphic_arity -> types array -> Sign.rel_context * sorts
+
+(***************************************************************)
+(* Debug *)
+
+type size = Large | Strict
+type subterm_spec =
+    Subterm of (size * wf_paths)
+  | Dead_code
+  | Not_subterm
+type guard_env =
+  { env     : env;
+    (* dB of last fixpoint *)
+    rel_min : int;
+    (* inductive of recarg of each fixpoint *)
+    inds    : inductive array;
+    (* the recarg information of inductive family *)
+    recvec  : wf_paths array;
+    (* dB of variables denoting subterms *)
+    genv    : subterm_spec list;
+  }
+
+val subterm_specif : guard_env -> constr -> subterm_spec
+val case_branches_specif : guard_env -> subterm_spec -> inductive ->
+  constr array -> (guard_env * constr) array
diff --git a/kernel/make-opcodes b/kernel/make-opcodes
new file mode 100644
index 00000000..c8f573c6
--- /dev/null
+++ b/kernel/make-opcodes
@@ -0,0 +1,2 @@
+$1=="enum" {n=0; next; }
+           {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}}
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
new file mode 100644
index 00000000..6d2064bf
--- /dev/null
+++ b/kernel/mod_subst.ml
@@ -0,0 +1,260 @@
+(************************************************************************)
+(*  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: mod_subst.ml 7538 2005-11-08 17:14:52Z herbelin $ *)
+
+open Pp
+open Util
+open Names
+open Term
+
+(* WARNING: not every constant in the associative list domain used to exist
+   in the environment. This allows a simple implementation of the join
+   operation. However, iterating over the associative list becomes a non-sense
+*)
+type resolver = (constant * constr option) list
+
+let make_resolver resolve = resolve
+
+let apply_opt_resolver resolve kn =
+ match resolve with
+    None -> None
+  | Some resolve ->
+     try List.assoc kn resolve with Not_found -> assert false
+
+type substitution_domain = MSI of mod_self_id | MBI of mod_bound_id
+
+let string_of_subst_domain = function
+   MSI msid -> debug_string_of_msid msid
+ | MBI mbid -> debug_string_of_mbid mbid
+
+module Umap = Map.Make(struct 
+			 type t = substitution_domain
+			 let compare = Pervasives.compare
+		       end)
+
+type substitution = (module_path * resolver option) Umap.t
+
+let empty_subst = Umap.empty
+
+let add_msid msid mp =
+  Umap.add (MSI msid) (mp,None)
+let add_mbid mbid mp resolve =
+  Umap.add (MBI mbid) (mp,resolve)
+
+let map_msid msid mp = add_msid msid mp empty_subst
+let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst
+
+let list_contents sub = 
+  let one_pair uid (mp,_) l =
+    (string_of_subst_domain uid, string_of_mp mp)::l
+  in
+    Umap.fold one_pair sub []
+
+let debug_string_of_subst sub = 
+  let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in
+    "{" ^ String.concat "; " l ^ "}"
+
+let debug_pr_subst sub = 
+  let l = list_contents sub in
+  let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) 
+  in
+    str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" 
+
+let subst_mp0 sub mp = (* 's like subst *)
+ let rec aux mp =
+  match mp with
+    | MPself sid -> 
+        let mp',resolve = Umap.find (MSI sid) sub in
+         mp',resolve
+    | MPbound bid ->
+        let mp',resolve = Umap.find (MBI bid) sub in
+         mp',resolve
+    | MPdot (mp1,l) -> 
+	let mp1',resolve = aux mp1 in
+	 MPdot (mp1',l),resolve
+    | _ -> raise Not_found
+ in
+  try Some (aux mp) with Not_found -> None
+
+let subst_mp sub mp =
+ match subst_mp0 sub mp with
+    None -> mp
+  | Some (mp',_) -> mp'
+
+
+let subst_kn0 sub kn =
+ let mp,dir,l = repr_kn kn in
+  match subst_mp0 sub mp with
+     Some (mp',_) ->
+      Some (make_kn mp' dir l)
+   | None -> None
+
+let subst_kn sub kn =
+ match subst_kn0 sub kn with
+    None -> kn
+  | Some kn' -> kn'
+
+let subst_con sub con =
+ let mp,dir,l = repr_con con in
+  match subst_mp0 sub mp with
+     None -> con,mkConst con
+   | Some (mp',resolve) ->
+      let con' = make_con mp' dir l in
+       match apply_opt_resolver resolve con with
+          None -> con',mkConst con'
+        | Some t -> con',t
+
+(* Here the semantics is completely unclear.
+   What does "Hint Unfold t" means when "t" is a parameter?
+   Does the user mean "Unfold X.t" or does she mean "Unfold y"
+   where X.t is later on instantiated with y? I choose the first
+   interpretation (i.e. an evaluable reference is never expanded). *)
+let subst_evaluable_reference subst = function
+  | EvalVarRef id -> EvalVarRef id
+  | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn))
+
+(* 
+This should be rewritten to prevent duplication of constr's when not
+necessary.
+For now, it uses map_constr and is rather ineffective
+*)
+
+let rec map_kn f f' c = 
+  let func = map_kn f f' in
+    match kind_of_term c with
+      | Const kn -> f' kn
+      | Ind (kn,i) -> 
+         (match f kn with
+             None -> c
+           | Some kn' ->
+	      mkInd (kn',i))
+      | Construct ((kn,i),j) -> 
+         (match f kn with
+             None -> c
+           | Some kn' ->
+	      mkConstruct ((kn',i),j))
+      | Case (ci,p,c,l) ->
+	  let ci' =
+           { ci with
+              ci_ind =
+               let (kn,i) = ci.ci_ind in
+                match f kn with None -> ci.ci_ind | Some kn' -> kn',i } in
+	  mkCase (ci', func p, func c, array_smartmap func l) 
+      | _ -> map_constr func c
+
+let subst_mps sub = 
+  map_kn (subst_kn0 sub) (fun con -> snd (subst_con sub con))
+
+let rec replace_mp_in_mp mpfrom mpto mp =
+  match mp with
+    | _ when mp = mpfrom -> mpto
+    | MPdot (mp1,l) -> 
+	let mp1' = replace_mp_in_mp mpfrom mpto mp1 in
+	  if mp1==mp1' then mp
+	  else MPdot (mp1',l)
+    | _ -> mp
+
+let replace_mp_in_con mpfrom mpto kn =
+ let mp,dir,l = repr_con kn in
+  let mp'' = replace_mp_in_mp mpfrom mpto mp in
+    if mp==mp'' then kn
+    else make_con mp'' dir l
+
+exception BothSubstitutionsAreIdentitySubstitutions
+exception ChangeDomain of resolver
+
+let join (subst1 : substitution) (subst2 : substitution) = 
+  let apply_subst (sub : substitution) key (mp,resolve) =
+   let mp',resolve' =
+    match subst_mp0 sub mp with
+       None -> mp, None
+     | Some (mp',resolve') -> mp',resolve' in
+   let resolve'' : resolver option =
+    try
+     let res =
+      match resolve with
+         Some res -> res
+       | None ->
+          match resolve' with
+             None -> raise BothSubstitutionsAreIdentitySubstitutions
+           | Some res -> raise (ChangeDomain res)
+     in
+      Some
+       (List.map
+         (fun (kn,topt) ->
+           kn,
+           match topt with
+              None ->
+               (match key with
+                   MSI msid ->
+                    let kn' = replace_mp_in_con (MPself msid) mp kn in
+                     apply_opt_resolver resolve' kn'
+                 | MBI mbid ->
+                    let kn' = replace_mp_in_con (MPbound mbid) mp kn in
+                     apply_opt_resolver resolve' kn')
+            | Some t -> Some (subst_mps sub t)) res)
+    with
+       BothSubstitutionsAreIdentitySubstitutions -> None
+     | ChangeDomain res ->
+        Some
+         ((List.map
+            (fun (kn,topt) ->
+              let key' =
+               match key with
+                  MSI msid -> MPself msid
+                | MBI mbid -> MPbound mbid in
+              (* let's replace mp with key in kn *)
+              let kn' = replace_mp_in_con mp key' kn in
+               kn',topt)) res)
+   in
+    mp',resolve'' in
+  let subst = Umap.mapi (apply_subst subst2) subst1 in
+  Umap.fold Umap.add subst2 subst
+
+let rec occur_in_path uid path =
+ match uid,path with
+  | MSI sid,MPself sid' -> sid = sid'
+  | MBI bid,MPbound bid' -> bid = bid'
+  | _,MPdot (mp1,_) -> occur_in_path uid mp1
+  | _ -> false
+    
+let occur_uid uid sub = 
+  let check_one uid' (mp,_) =
+    if uid = uid' || occur_in_path uid mp then raise Exit
+  in
+    try 
+      Umap.iter check_one sub;
+      false
+    with Exit -> true
+
+let occur_msid uid = occur_uid (MSI uid)
+let occur_mbid uid = occur_uid (MBI uid)
+    
+type 'a lazy_subst =
+  | LSval of 'a
+  | LSlazy of substitution * 'a
+	
+type 'a substituted = 'a lazy_subst ref
+      
+let from_val a = ref (LSval a)
+    
+let force fsubst r = 
+  match !r with
+  | LSval a -> a
+  | LSlazy(s,a) -> 
+      let a' = fsubst s a in
+      r := LSval a';
+      a' 
+
+let subst_substituted s r =
+  match !r with
+  | LSval a -> ref (LSlazy(s,a))
+  | LSlazy(s',a) ->
+      let s'' = join s' s in
+      ref (LSlazy(s'',a))
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
new file mode 100644
index 00000000..a7915a24
--- /dev/null
+++ b/kernel/mod_subst.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: mod_subst.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
+
+(*s [Mod_subst] *)
+
+open Names
+open Term
+
+type resolver
+type substitution
+
+val make_resolver :  (constant * constr option) list -> resolver
+
+val empty_subst : substitution
+
+val add_msid : 
+  mod_self_id -> module_path -> substitution -> substitution
+val add_mbid : 
+  mod_bound_id -> module_path -> resolver option -> substitution -> substitution
+
+val map_msid :
+  mod_self_id -> module_path -> substitution
+val map_mbid :
+  mod_bound_id -> module_path -> resolver option -> substitution
+
+(* sequential composition: 
+   [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
+*)
+val join : substitution -> substitution -> substitution
+
+type 'a substituted
+val from_val : 'a -> 'a substituted
+val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a
+val subst_substituted : substitution -> 'a substituted -> 'a substituted
+
+(*i debugging *)
+val debug_string_of_subst : substitution -> string
+val debug_pr_subst : substitution -> Pp.std_ppcmds
+(*i*)
+
+(* [subst_mp sub mp] guarantees that whenever the result of the
+   substitution is structutally equal [mp], it is equal by pointers 
+   as well [==] *) 
+
+val subst_mp : 
+  substitution -> module_path -> module_path
+
+val subst_kn :
+  substitution -> kernel_name -> kernel_name
+
+val subst_con :
+  substitution -> constant -> constant * constr
+
+(* Here the semantics is completely unclear.
+   What does "Hint Unfold t" means when "t" is a parameter?
+   Does the user mean "Unfold X.t" or does she mean "Unfold y"
+   where X.t is later on instantiated with y? I choose the first
+   interpretation (i.e. an evaluable reference is never expanded). *)
+val subst_evaluable_reference :
+  substitution -> evaluable_global_reference -> evaluable_global_reference
+
+(* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
+val replace_mp_in_con : module_path -> module_path -> constant -> constant
+
+(* [subst_mps sub c] performs the substitution [sub] on all kernel
+   names appearing in [c] *)
+val subst_mps : substitution -> constr -> constr
+
+(* [occur_*id id sub] returns true iff [id] occurs in [sub] 
+   on either side *)
+
+val occur_msid : mod_self_id -> substitution -> bool
+val occur_mbid : mod_bound_id -> substitution -> bool
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 5e8c7001..352a1e46 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.ml,v 1.11.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: mod_typing.ml 9558 2007-01-30 14:58:42Z soubiran $ i*)
 
 open Util
 open Names
@@ -17,6 +17,7 @@ open Environ
 open Term_typing
 open Modops
 open Subtyping
+open Mod_subst
 
 exception Not_path
 
@@ -65,8 +66,9 @@ and merge_with env mtb with_decl =
     | MTBsig(msid,sig_b) -> msid,sig_b 
     | _ -> error_signature_expected mtb
   in
-  let id = match with_decl with 
-    | With_Definition (id,_) | With_Module (id,_) -> id
+  let id,idl = match with_decl with 
+    | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl
+    | With_Definition ([],_) | With_Module ([],_) -> assert false
   in
   let l = label_of_id id in
     try
@@ -74,7 +76,9 @@ and merge_with env mtb with_decl =
       let before = List.rev rev_before in
       let env' = Modops.add_signature (MPself msid) before env in
       let new_spec = match with_decl with
-	| With_Definition (id,c) -> 
+        | With_Definition ([],_)
+        | With_Module ([],_) -> assert false
+	| With_Definition ([id],c) -> 
 	    let cb = match spec with
 		SPBconst cb -> cb
 	      | _ -> error_not_a_constant l
@@ -83,26 +87,30 @@ and merge_with env mtb with_decl =
 		match cb.const_body with
 		  | None -> 
 		      let (j,cst1) = Typeops.infer env' c in
-		      let cst2 = 
-			Reduction.conv_leq env' j.uj_type cb.const_type in
+		      let typ = Typeops.type_of_constant_type env' cb.const_type in
+		      let cst2 = Reduction.conv_leq env' j.uj_type typ in
 		      let cst = 
 			Constraint.union 
 			  (Constraint.union cb.const_constraints cst1)
-			  cst2
-		      in
+			  cst2 in
+                      let body = Some (Declarations.from_val j.uj_val) in
 			SPBconst {cb with 
-				    const_body = 
-				      Some (Declarations.from_val j.uj_val);
-				    const_constraints = cst}
+				    const_body = body;
+			            const_body_code = Cemitcodes.from_val
+                        (compile_constant_body env' body false false);
+                                    const_constraints = cst}
 		  | Some b -> 
 		      let cst1 = Reduction.conv env' c (Declarations.force b) in
 		      let cst = Constraint.union cb.const_constraints cst1 in
+                      let body = Some (Declarations.from_val c) in
 			SPBconst {cb with 
-				    const_body = Some (Declarations.from_val c);
-				    const_constraints = cst}
+				    const_body = body;
+				    const_body_code = Cemitcodes.from_val
+                        (compile_constant_body env' body false false);
+                                    const_constraints = cst}
 	      end	
 (* and what about msid's ????? Don't they clash ? *)
-	| With_Module (id, mp) ->
+	| With_Module ([id], mp) ->
 	    let old = match spec with
 		SPBmodule msb -> msb
 	      | _ -> error_not_a_module (string_of_label l)
@@ -115,7 +123,7 @@ and merge_with env mtb with_decl =
 		let _ = subst_modtype (map_msid msid (MPself msid)) mtb in
 		  ()
 	      with
-		  Failure _ -> error_circular_with_module id
+		  Circularity _ -> error_circular_with_module id
 	    end;
 	    let cst =
               try check_subtypes env' mtb old.msb_modtype
@@ -133,6 +141,29 @@ and merge_with env mtb with_decl =
 	       msb_constraints = Constraint.union old.msb_constraints cst }
 	    in
 	      SPBmodule msb
+	| With_Definition (_::_,_)
+        | With_Module (_::_,_) -> 
+	    let old = match spec with
+		SPBmodule msb -> msb
+	      | _ -> error_not_a_module (string_of_label l)
+	    in
+	      begin
+		match old.msb_equiv with
+                   None ->
+                    let new_with_decl = match with_decl with
+                       With_Definition (_,c) -> With_Definition (idl,c)
+                     | With_Module (_,c) -> With_Module (idl,c) in
+                    let modtype = 
+                     merge_with env' old.msb_modtype new_with_decl in
+                    let msb =
+	              {msb_modtype = modtype; 
+	               msb_equiv = None; 
+	               msb_constraints = old.msb_constraints }
+	            in
+	             SPBmodule msb
+                 | Some mp ->
+                    error_a_generative_module_expected l
+              end
       in
 	MTBsig(msid,  before@(l,new_spec)::after)
     with
@@ -143,13 +174,14 @@ and translate_entry_list env msid is_definition sig_e =
   let mp = MPself msid in
   let do_entry env (l,e) = 
     let kn = make_kn mp empty_dirpath l in
+    let con = make_con mp empty_dirpath l in
     match e with
       | SPEconst ce ->
-	  let cb = translate_constant env ce in
+	  let cb = translate_constant env con ce in
 	    begin match cb.const_hyps with
 	      |	(_::_) -> error_local_context (Some l)
 	      | [] ->
-		  add_constant kn cb env, (l, SEBconst cb), (l, SPBconst cb)
+		  add_constant con cb env, (l, SEBconst cb), (l, SPBconst cb)
 	    end
       | SPEmind mie -> 
 	  let mib = translate_mind env mie in
@@ -215,10 +247,8 @@ and translate_module env is_definition me =
 	    | None -> mtb1, None, Constraint.empty
 	    | Some mte -> 
 		let mtb2 = translate_modtype env mte in
-                let cst =
-                  try check_subtypes env mtb1 mtb2
-                  with Failure _ -> error "not subtype" in
-		mtb2, Some mtb2, cst
+                let cst = check_subtypes env mtb1 mtb2 in
+		    mtb2, Some mtb2, cst
 	in
 	  { mod_type = mtb;
 	    mod_user_type = mod_user_type;
@@ -242,10 +272,7 @@ and translate_mexpr env mexpr = match mexpr with
       let ftb = scrape_modtype env ftb in
       let farg_id, farg_b, fbody_b = destr_functor ftb in
       let meb,mtb = translate_mexpr env mexpr in
-      let cst =
-        try check_subtypes env mtb farg_b
-        with Failure _ ->
-          error "" in
+      let cst = check_subtypes env mtb farg_b in
       let mp = 
 	try
 	  path_of_mexpr mexpr 
@@ -253,8 +280,13 @@ and translate_mexpr env mexpr = match mexpr with
 	  | Not_path -> error_application_to_not_path mexpr
 	      (* place for nondep_supertype *)
       in
+       let resolve = Modops.resolver_of_environment farg_id farg_b mp env in
 	MEBapply(feb,meb,cst),
-	subst_modtype (map_mbid farg_id mp) fbody_b
+        (* This is the place where the functor formal parameter is
+           substituted by the given argument to compute the type of the
+           functor application. *)
+	subst_modtype
+         (map_mbid farg_id mp (Some resolve)) fbody_b
   | MEstruct (msid,structure) ->
       let structure,signature = translate_entry_list env msid true structure in
 	MEBstruct (msid,structure),
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index fdf39c56..706c617c 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mod_typing.mli,v 1.2.8.2 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: mod_typing.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 (*i*)
 open Declarations
@@ -19,6 +19,8 @@ val translate_modtype : env -> module_type_entry -> module_type_body
 
 val translate_module : env -> module_entry -> module_body
 
+val translate_mexpr : env -> module_expr -> module_expr_body * module_type_body
+
 val add_modtype_constraints : env -> module_type_body -> env
 
 val add_module_constraints : env -> module_body -> env
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 84845af5..8bab3c9d 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.ml,v 1.12.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: modops.ml 9558 2007-01-30 14:58:42Z soubiran $ i*)
 
 (*i*)
 open Util
@@ -17,8 +17,11 @@ open Term
 open Declarations
 open Environ
 open Entries
+open Mod_subst
 (*i*)
 
+exception Circularity of string
+
 let error_existing_label l = 
   error ("The label "^string_of_label l^" is already declared")
 
@@ -40,7 +43,7 @@ let error_incompatible_labels l l' =
   error ("Opening and closing labels are not the same: "
 	 ^string_of_label l^" <> "^string_of_label l'^" !")
 
-let error_result_must_be_signature mtb = 
+let error_result_must_be_signature () = 
   error "The result module type must be a signature"
 
 let error_signature_expected mtb =
@@ -66,6 +69,11 @@ let error_not_a_constant l =
 let error_with_incorrect l =
   error ("Incorrect constraint for label \""^(string_of_label l)^"\"")
 
+let error_a_generative_module_expected l =
+  error ("The module " ^ string_of_label l ^ " is not generative. Only " ^
+         "component of generative modules can be changed using the \"with\" " ^
+         "construct.")
+
 let error_local_context lo = 
   match lo with
       None -> 
@@ -77,6 +85,13 @@ let error_local_context lo =
 let error_circular_with_module l =
   error ("The construction \"with Module "^(string_of_id l)^":=...\" is about to create\na circular module type. Their resolution is not implemented yet.\nIf you really need that feature, please report.")
 
+let error_circularity_in_subtyping l l1 l2 =
+  error ("An occurrence of "^l^" creates a circularity\n during the subtyping verification between "^l1^" and "^l2^".")
+
+let error_no_such_label_sub l l1 l2 =
+  error (l1^" is not a subtype of "^l2^".\nThe field "^(string_of_label l)^" is missing (or invisible) in "^l1^".")
+
+
 let rec scrape_modtype env = function
   | MTBident kn -> scrape_modtype env (lookup_modtype kn env)
   | mtb -> mtb
@@ -123,14 +138,17 @@ let rec check_modpath_equiv env mp1 mp2 =
 
 
 let rec subst_modtype sub = function
+    (* This is the case in which I am substituting a whole module.
+       For instance "Module M(X). Module N := X. End M". When I apply
+       M to M' I must substitute M' for X in "Module N := X". *)
   | MTBident ln -> MTBident (subst_kn sub ln)
   | MTBfunsig (arg_id, arg_b, body_b) ->
-      if occur_mbid arg_id sub then failwith "capture";
+      if occur_mbid arg_id sub then raise (Circularity (string_of_mbid arg_id));
       MTBfunsig (arg_id, 
 		 subst_modtype sub arg_b, 
 		 subst_modtype sub body_b)
   | MTBsig (sid1, msb) -> 
-      if occur_msid sid1 sub then failwith "capture";
+      if occur_msid sid1 sub then raise (Circularity (string_of_msid sid1));
       MTBsig (sid1, subst_signature sub msb)
 
 and subst_signature sub sign = 
@@ -148,13 +166,16 @@ and subst_signature sub sign =
 
 and subst_module sub mb =
   let mtb' = subst_modtype sub mb.msb_modtype in
+  (* This is similar to the previous case. In this case we have
+     a module M in a signature that is knows to be equivalent to a module M'
+     (because the signature is "K with Module M := M'") and we are substituting
+     M' with some M''. *)
   let mpo' = option_smartmap (subst_mp sub) mb.msb_equiv in
     if mtb'==mb.msb_modtype && mpo'==mb.msb_equiv then mb else
       { msb_modtype=mtb'; 
 	msb_equiv=mpo'; 
 	msb_constraints=mb.msb_constraints}
 
-
 let subst_signature_msid msid mp = 
   subst_signature (map_msid msid mp)
 
@@ -163,8 +184,9 @@ let subst_signature_msid msid mp =
 let rec add_signature mp sign env = 
   let add_one env (l,elem) =
     let kn = make_kn mp empty_dirpath l in
+    let con = make_con mp empty_dirpath l in
       match elem with
-	| SPBconst cb -> Environ.add_constant kn cb env
+	| SPBconst cb -> Environ.add_constant con cb env
 	| SPBmind mib -> Environ.add_mind kn mib env
 	| SPBmodule mb -> 
 	    add_module (MPdot (mp,l)) (module_body_of_spec mb) env 
@@ -180,20 +202,68 @@ and add_module mp mb env =
       | MTBident _ -> anomaly "scrape_modtype does not work!"
       | MTBsig (msid,sign) -> 
 	  add_signature mp (subst_signature_msid msid mp sign) env
-
       | MTBfunsig _ -> env
 
 
+let rec constants_of_specification env mp sign =
+ let aux (env,res) (l,elem) =
+  match elem with
+   | SPBconst cb -> env,((make_con mp empty_dirpath l),cb)::res
+   | SPBmind _ -> env,res
+   | SPBmodule mb ->
+       let new_env =  add_module (MPdot (mp,l)) (module_body_of_spec mb) env in 
+       new_env,(constants_of_modtype env (MPdot (mp,l))
+		  (module_body_of_spec mb).mod_type) @ res
+   | SPBmodtype mtb -> 
+       (* module type dans un module type. 
+	  Il faut au moins mettre mtb dans l'environnement (avec le bon 
+	  kn pour pouvoir continuer aller deplier les modules utilisant ce 
+	  mtb
+	  ex: 
+	  Module Type T1. 
+	  Module Type T2.
+	     ....
+    	    End T2.
+	  .....
+            Declare Module M : T2.
+         End T2 
+	  si on ne rajoute pas T2 dans l'environement de typage 
+	  on va exploser au moment du Declare Module
+       *)
+       let new_env = Environ.add_modtype (make_kn mp empty_dirpath l) mtb env in 
+       new_env, constants_of_modtype env (MPdot(mp,l)) mtb @ res
+ in
+ snd (List.fold_left aux (env,[]) sign)
+
+and constants_of_modtype env mp modtype =
+ match scrape_modtype env modtype with
+    MTBident _ -> anomaly "scrape_modtype does not work!"
+  | MTBsig (msid,sign) ->
+     constants_of_specification env mp
+      (subst_signature_msid msid mp sign)
+  | MTBfunsig _ -> []
+
+(* returns a resolver for kn that maps mbid to mp *)
+(* Nota: Some delta-expansions used to happen here. 
+    Browse SVN if you want to know more. *)
+let resolver_of_environment mbid modtype mp env =
+ let constants = constants_of_modtype env (MPbound mbid) modtype in
+ let resolve = List.map (fun (con,_) -> con,None) constants in 
+ Mod_subst.make_resolver resolve
+
+
 let strengthen_const env mp l cb = 
   match cb.const_opaque, cb.const_body with
   | false, Some _ -> cb
   | true, Some _ 
   | _, None -> 
-      let const = mkConst (make_kn mp empty_dirpath l) in 
+      let const = mkConst (make_con mp empty_dirpath l) in 
       let const_subs = Some (Declarations.from_val const) in
 	{cb with 
       	   const_body = const_subs;
-	   const_opaque = false
+	   const_opaque = false;
+           const_body_code = Cemitcodes.from_val
+             (compile_constant_body env const_subs false false)
 	}
 
 let strengthen_mind env mp l mib = match mib.mind_equiv with
@@ -243,3 +313,4 @@ and strengthen_sig env msid sign mp = match sign with
 	item::rest'
 
 let strengthen env mtb mp = strengthen_mtb env mp mtb
+
diff --git a/kernel/modops.mli b/kernel/modops.mli
index cca2d315..55f81079 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: modops.mli,v 1.7.6.2 2005/01/21 16:41:50 herbelin Exp $ i*)
+(*i $Id: modops.mli 9558 2007-01-30 14:58:42Z soubiran $ i*)
 
 (*i*)
 open Util
@@ -15,10 +15,13 @@ open Univ
 open Environ
 open Declarations
 open Entries
+open Mod_subst
 (*i*)
 
 (* Various operations on modules and module types *)
 
+exception Circularity of string
+
 (* recursively unfold MTBdent module types *)
 val scrape_modtype : env -> module_type_body -> module_type_body
 
@@ -73,7 +76,7 @@ val error_incompatible_labels : label -> label -> 'a
 
 val error_no_such_label : label -> 'a
 
-val error_result_must_be_signature : module_type_body -> 'a
+val error_result_must_be_signature : unit -> 'a
 
 val error_signature_expected : module_type_body -> 'a
 
@@ -91,6 +94,15 @@ val error_not_a_constant : label -> 'a
 
 val error_with_incorrect : label -> 'a
 
+val error_a_generative_module_expected : label -> 'a
+
 val error_local_context : label option -> 'a
 
 val error_circular_with_module : identifier -> 'a
+
+val error_circularity_in_subtyping : string->string->string-> 'a
+
+val error_no_such_label_sub : label->string->string->'a
+
+val resolver_of_environment :
+ mod_bound_id -> module_type_body -> module_path -> env -> resolver
diff --git a/kernel/names.ml b/kernel/names.ml
index df3a012f..383d7879 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: names.ml,v 1.53.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+(* $Id: names.ml 9558 2007-01-30 14:58:42Z soubiran $ *)
 
 open Pp
 open Util
@@ -19,13 +19,7 @@ let id_ord = Pervasives.compare
 
 let id_of_string s = String.copy s
 
-let map_ident id =
-  if Options.do_translate() then
-    match id with
-        "fix" -> "Fix"
-      | _ -> id
-  else id
-let string_of_id id = String.copy (map_ident id)
+let string_of_id id = String.copy id
 
 (* Hash-consing of identifier *)
 module Hident = Hashcons.Make(
@@ -79,8 +73,10 @@ let string_of_dirpath = function
 let u_number = ref 0 
 type uniq_ident = int * string * dir_path
 let make_uid dir s = incr u_number;(!u_number,String.copy s,dir)
-let string_of_uid (i,s,p) = 
+let debug_string_of_uid (i,s,p) = 
   "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
+let string_of_uid (i,s,p) = 
+  string_of_dirpath p ^"."^s
 
 module Umap = Map.Make(struct 
 			 type t = uniq_ident 
@@ -90,12 +86,14 @@ module Umap = Map.Make(struct
 
 type mod_self_id = uniq_ident
 let make_msid = make_uid
-let debug_string_of_msid = string_of_uid
+let debug_string_of_msid = debug_string_of_uid
+let string_of_msid = string_of_uid
 let id_of_msid (_,s,_) = s
 
 type mod_bound_id = uniq_ident
 let make_mbid = make_uid
-let debug_string_of_mbid = string_of_uid
+let debug_string_of_mbid = debug_string_of_uid
+let string_of_mbid = string_of_uid
 let id_of_mbid (_,s,_) = s
 
 type label = string
@@ -138,74 +136,6 @@ end
 module MPset = Set.Make(MPord)
 module MPmap = Map.Make(MPord)
 
-
-(* this is correct under the condition that bound and struct
-   identifiers can never be identical (i.e. get the same stamp)! *) 
-
-type substitution = module_path Umap.t
-
-let empty_subst = Umap.empty
-
-let add_msid = Umap.add 
-let add_mbid = Umap.add
-
-let map_msid msid mp = add_msid msid mp empty_subst
-let map_mbid mbid mp = add_msid mbid mp empty_subst
-
-let list_contents sub = 
-  let one_pair uid mp l =
-    (string_of_uid uid, string_of_mp mp)::l
-  in
-    Umap.fold one_pair sub []
-
-let debug_string_of_subst sub = 
-  let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in
-    "{" ^ String.concat "; " l ^ "}"
-
-let debug_pr_subst sub = 
-  let l = list_contents sub in
-  let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) 
-  in
-    str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" 
-
-let rec subst_mp sub mp = (* 's like subst *)
-  match mp with
-    | MPself sid -> 
-	(try Umap.find sid sub with Not_found -> mp)
-    | MPbound bid ->
-	(try Umap.find bid sub with Not_found -> mp)
-    | MPdot (mp1,l) -> 
-	let mp1' = subst_mp sub mp1 in
-	  if mp1==mp1' then 
-	    mp
-	  else
-	    MPdot (mp1',l)
-    | _ -> mp
-
-let join subst1 subst2 = 
-  let subst = Umap.map (subst_mp subst2) subst1 in
-  Umap.fold Umap.add subst2 subst
-
-let rec occur_in_path uid = function
-  | MPself sid -> sid = uid
-  | MPbound bid -> bid = uid
-  | MPdot (mp1,_) -> occur_in_path uid mp1
-  | _ -> false
-    
-let occur_uid uid sub = 
-  let check_one uid' mp =
-    if uid = uid' || occur_in_path uid mp then raise Exit
-  in
-    try 
-      Umap.iter check_one sub;
-      false
-    with Exit -> true
-
-let occur_msid = occur_uid
-let occur_mbid = occur_uid
-
-
-
 (* Kernel names *)
 
 type kernel_name = module_path * dir_path * label
@@ -225,11 +155,6 @@ let string_of_kn (mp,dir,l) =
 let pr_kn kn = str (string_of_kn kn)
 
 
-let subst_kn sub (mp,dir,l as kn) = 
-  let mp' = subst_mp sub mp in
-    if mp==mp' then kn else (mp',dir,l)
-
-
 let kn_ord kn1 kn2 = 
     let mp1,dir1,l1 = kn1 in
     let mp2,dir2,l2 = kn2 in
@@ -252,7 +177,9 @@ end
 module KNmap = Map.Make(KNord)
 module KNpred = Predicate.Make(KNord)
 module KNset = Set.Make(KNord)
-
+module Cmap = KNmap
+module Cpred = KNpred
+module Cset = KNset
 
 let default_module_name = id_of_string "If you see this, it's a bug"
 
@@ -267,11 +194,39 @@ type mutual_inductive = kernel_name
 type inductive = mutual_inductive * int
 type constructor = inductive * int
 
+let constant_of_kn kn = kn
+let make_con mp dir l = (mp,dir,l)
+let repr_con con = con
+let string_of_con = string_of_kn
+let con_label = label
+let pr_con = pr_kn
+let con_modpath = modpath
+
+let mind_modpath = modpath
+let ind_modpath ind = mind_modpath (fst ind)
+let constr_modpath c = ind_modpath (fst c)
+
 let ith_mutual_inductive (kn,_) i = (kn,i)
 let ith_constructor_of_inductive ind i = (ind,i)
 let inductive_of_constructor (ind,i) = ind
 let index_of_constructor (ind,i) = i
 
+module InductiveOrdered = struct
+  type t = inductive
+  let compare (spx,ix) (spy,iy) = 
+    let c = ix - iy in if c = 0 then KNord.compare spx spy else c
+end
+
+module Indmap = Map.Make(InductiveOrdered)
+
+module ConstructorOrdered = struct
+  type t = constructor
+  let compare (indx,ix) (indy,iy) = 
+    let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c
+end
+
+module Constrmap = Map.Make(ConstructorOrdered)
+
 (* Better to have it here that in closure, since used in grammar.cma *)
 type evaluable_global_reference =
   | EvalVarRef of identifier
@@ -352,4 +307,24 @@ let hcons_names () =
   let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in
   let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in
   let hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in
-  (hkn,hdir,hname,hident,hstring)
+  (hkn,hkn,hdir,hname,hident,hstring)
+
+
+(*******)
+
+type transparent_state = Idpred.t * Cpred.t
+
+type 'a tableKey =
+  | ConstKey of constant
+  | VarKey of identifier
+  | RelKey of 'a 
+
+
+type inv_rel_key = int (* index in the [rel_context] part of environment
+			  starting by the end, {\em inverse} 
+			  of de Bruijn indice *)
+
+type id_key = inv_rel_key tableKey
+
+
+
diff --git a/kernel/names.mli b/kernel/names.mli
index 07c19841..c9fef60a 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: names.mli,v 1.46.6.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: names.mli 9558 2007-01-30 14:58:42Z soubiran $ i*)
 
 (*s Identifiers *)
 
@@ -50,6 +50,7 @@ type mod_self_id
 val make_msid : dir_path -> string -> mod_self_id
 val id_of_msid : mod_self_id -> identifier
 val debug_string_of_msid : mod_self_id -> string
+val string_of_msid : mod_self_id -> string
 
 (*s Unique names for bound modules *)
 type mod_bound_id
@@ -57,12 +58,14 @@ type mod_bound_id
 val make_mbid : dir_path -> string -> mod_bound_id
 val id_of_mbid : mod_bound_id -> identifier
 val debug_string_of_mbid : mod_bound_id -> string
+val string_of_mbid : mod_bound_id -> string
 
 (*s Names of structure elements *)
 type label
 val mk_label : string -> label
 val string_of_label : label -> string
 
+
 val label_of_id : identifier -> label
 val id_of_label : label -> identifier
 
@@ -83,45 +86,6 @@ val string_of_mp : module_path -> string
 module MPset : Set.S with type elt = module_path
 module MPmap : Map.S with type key = module_path
 
-
-(*s Substitutions *)
-
-type substitution
-
-val empty_subst : substitution
-
-val add_msid : 
-  mod_self_id -> module_path -> substitution -> substitution
-val add_mbid : 
-  mod_bound_id -> module_path -> substitution -> substitution
-
-val map_msid : mod_self_id -> module_path -> substitution
-val map_mbid : mod_bound_id -> module_path -> substitution
-
-(* sequential composition: 
-   [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
-*)
-val join : substitution -> substitution -> substitution
-
-(*i debugging *)
-val debug_string_of_subst : substitution -> string
-val debug_pr_subst : substitution -> Pp.std_ppcmds
-(*i*)
-
-(* [subst_mp sub mp] guarantees that whenever the result of the
-   substitution is structutally equal [mp], it is equal by pointers 
-   as well [==] *) 
-
-val subst_mp : 
-  substitution -> module_path -> module_path
-
-(* [occur_*id id sub] returns true iff [id] occurs in [sub] 
-   on either side *)
-
-val occur_msid : mod_self_id -> substitution -> bool
-val occur_mbid : mod_bound_id -> substitution -> bool
-     
-
 (* Name of the toplevel structure *)
 val initial_msid : mod_self_id
 val initial_path : module_path (* [= MPself initial_msid] *)
@@ -142,7 +106,6 @@ val label : kernel_name -> label
 
 val string_of_kn : kernel_name -> string
 val pr_kn : kernel_name -> Pp.std_ppcmds
-val subst_kn : substitution -> kernel_name -> kernel_name
 
 
 module KNset  : Set.S with type elt = kernel_name
@@ -153,13 +116,31 @@ module KNmap  : Map.S with type key = kernel_name
 (*s Specific paths for declarations *)
 
 type variable = identifier
-type constant = kernel_name
+type constant
 type mutual_inductive = kernel_name
 (* Beware: first inductive has index 0 *)
 type inductive = mutual_inductive * int
 (* Beware: first constructor has index 1 *)
 type constructor = inductive * int
 
+module Cmap  : Map.S with type key = constant
+module Cpred  : Predicate.S with type elt = constant
+module Cset  : Set.S with type elt = constant
+module Indmap : Map.S with type key = inductive
+module Constrmap : Map.S with type key = constructor
+
+val constant_of_kn : kernel_name -> constant
+val make_con : module_path -> dir_path -> label -> constant
+val repr_con : constant -> module_path * dir_path * label
+val string_of_con : constant -> string
+val con_label : constant -> label
+val con_modpath : constant -> module_path
+val pr_con : constant -> Pp.std_ppcmds
+
+val mind_modpath : mutual_inductive -> module_path
+val ind_modpath : inductive -> module_path
+val constr_modpath : constructor -> module_path
+
 val ith_mutual_inductive : inductive -> int -> inductive
 val ith_constructor_of_inductive : inductive -> int -> constructor
 val inductive_of_constructor : constructor -> inductive
@@ -172,5 +153,22 @@ type evaluable_global_reference =
 
 (* Hash-consing *)
 val hcons_names : unit ->
+  (constant -> constant) *
   (kernel_name -> kernel_name) * (dir_path -> dir_path) *
   (name -> name) * (identifier -> identifier) * (string -> string)
+
+
+(******)
+
+type 'a tableKey =
+  | ConstKey of constant
+  | VarKey of identifier
+  | RelKey of 'a 
+
+type transparent_state = Idpred.t * Cpred.t
+
+type inv_rel_key = int (* index in the [rel_context] part of environment
+			  starting by the end, {\em inverse} 
+			  of de Bruijn indice *)
+
+type id_key = inv_rel_key tableKey
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
new file mode 100644
index 00000000..947e4675
--- /dev/null
+++ b/kernel/pre_env.ml
@@ -0,0 +1,151 @@
+(************************************************************************)
+(*  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: pre_env.ml 8810 2006-05-12 18:50:21Z barras $ *)
+
+open Util
+open Names
+open Sign
+open Univ
+open Term
+open Declarations
+
+(* The type of environments. *)
+
+
+type key = int option ref 
+
+type constant_key = constant_body * key
+ 
+type globals = {
+  env_constants : constant_key Cmap.t;
+  env_inductives : mutual_inductive_body KNmap.t;
+  env_modules : module_body MPmap.t;
+  env_modtypes : module_type_body KNmap.t }
+
+type stratification = {
+  env_universes : universes;
+  env_engagement : engagement option
+}
+
+type 'a val_kind =   
+  | VKvalue of values
+  | VKaxiom of 'a
+  | VKdef of constr
+
+type 'a lazy_val = 'a val_kind ref
+
+type rel_val = inv_rel_key lazy_val
+
+type named_val = identifier lazy_val
+
+type named_vals = (identifier * named_val) list
+
+type env = {
+  env_globals       : globals;
+  env_named_context : named_context;
+  env_named_vals    : named_vals;
+  env_rel_context   : rel_context;
+  env_rel_val       : rel_val list;
+  env_nb_rel        : int;
+  env_stratification : stratification }
+
+type named_context_val = named_context * named_vals
+
+let empty_named_context_val = [],[]
+
+let empty_env = { 
+  env_globals = {
+    env_constants = Cmap.empty;
+    env_inductives = KNmap.empty;
+    env_modules = MPmap.empty;
+    env_modtypes = KNmap.empty };
+  env_named_context = empty_named_context;
+  env_named_vals = [];
+  env_rel_context = empty_rel_context;
+  env_rel_val = [];
+  env_nb_rel = 0;
+  env_stratification = {
+    env_universes = initial_universes;
+    env_engagement = None } }
+
+
+(* Rel context *)
+
+let nb_rel env = env.env_nb_rel
+
+let push_rel d env =
+  let _,body,_ = d in
+  let rval =
+    match body with
+    | None -> ref (VKaxiom env.env_nb_rel)
+    | Some c -> ref (VKdef c)
+  in     
+  { env with
+    env_rel_context = add_rel_decl d env.env_rel_context;
+    env_rel_val = rval :: env.env_rel_val;
+    env_nb_rel = env.env_nb_rel + 1 }
+ 
+let lookup_rel_val n env =
+  try List.nth env.env_rel_val (n - 1)
+  with _ -> raise Not_found
+    
+let env_of_rel n env =
+  { env with
+    env_rel_context = Util.list_skipn n env.env_rel_context;
+    env_rel_val = Util.list_skipn n env.env_rel_val;
+    env_nb_rel = env.env_nb_rel - n
+  }
+
+(* Named context *)
+
+let push_named_context_val d (ctxt,vals) =
+  let id,body,_ = d in
+  let rval =
+    match body with
+    | None -> ref (VKaxiom id)
+    | Some c -> ref (VKdef c)
+  in Sign.add_named_decl d ctxt, (id,rval)::vals
+
+exception ASSERT of Sign.rel_context
+
+let push_named d env = 
+(*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
+  assert (env.env_rel_context = []); *)
+  let id,body,_ = d in
+  let rval =
+    match body with
+    | None -> ref (VKaxiom id)
+    | Some c -> ref (VKdef c)
+  in
+  { env with  
+    env_named_context = Sign.add_named_decl d env.env_named_context;
+    env_named_vals =  (id,rval):: env.env_named_vals }
+
+let lookup_named_val id env =
+   snd(List.find (fun (id',_) -> id = id') env.env_named_vals)
+  
+(* Warning all the names should be different *)
+let env_of_named id env = env
+ 
+(* Global constants *)
+
+let lookup_constant_key kn env =
+  Cmap.find kn env.env_globals.env_constants
+
+let lookup_constant kn env =
+  fst (Cmap.find kn env.env_globals.env_constants)
+
+(* Mutual Inductives *)
+let lookup_mind kn env =
+  KNmap.find kn env.env_globals.env_inductives
+
+let rec scrape_mind env kn = 
+  match (lookup_mind kn env).mind_equiv with
+    | None -> kn
+    | Some kn' -> scrape_mind env kn'
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
new file mode 100644
index 00000000..2642bc92
--- /dev/null
+++ b/kernel/pre_env.mli
@@ -0,0 +1,89 @@
+(************************************************************************)
+(*  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: pre_env.mli 8810 2006-05-12 18:50:21Z barras $ *)
+
+open Util
+open Names
+open Sign
+open Univ
+open Term
+open Declarations
+
+(* The type of environments. *)
+
+
+type key = int option ref 
+
+type constant_key = constant_body * key
+ 
+type globals = {
+  env_constants : constant_key Cmap.t;
+  env_inductives : mutual_inductive_body KNmap.t;
+  env_modules : module_body MPmap.t;
+  env_modtypes : module_type_body KNmap.t }
+
+type stratification = {
+  env_universes : universes;
+  env_engagement : engagement option
+}
+
+type 'a val_kind =   
+  | VKvalue of values
+  | VKaxiom of 'a
+  | VKdef of constr
+
+type 'a lazy_val = 'a val_kind ref
+
+type rel_val = inv_rel_key lazy_val
+
+type named_val = identifier lazy_val
+
+type named_vals = (identifier * named_val) list
+
+type env = {
+  env_globals       : globals;
+  env_named_context : named_context;
+  env_named_vals    : named_vals;
+  env_rel_context   : rel_context;
+  env_rel_val       : rel_val list;
+  env_nb_rel        : int;
+  env_stratification : stratification }
+
+type named_context_val = named_context * named_vals
+
+val empty_named_context_val : named_context_val
+
+val empty_env : env
+
+(* Rel context *)
+
+val nb_rel         : env -> int
+val push_rel       : rel_declaration -> env -> env
+val lookup_rel_val : int -> env -> rel_val
+val env_of_rel     : int -> env -> env       
+(* Named context *)
+
+val push_named_context_val  : 
+    named_declaration -> named_context_val -> named_context_val
+val push_named       : named_declaration -> env -> env
+val lookup_named_val : identifier -> env -> named_val
+val env_of_named     : identifier -> env -> env  
+(* Global constants *)
+
+
+val lookup_constant_key : constant -> env -> constant_key
+val lookup_constant : constant -> env -> constant_body
+
+(* Mutual Inductives *)
+val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
+
+(* Find the ultimate inductive in the [mind_equiv] chain *)
+val scrape_mind : env -> mutual_inductive -> mutual_inductive
+
+
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 5428a40d..701020d0 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reduction.ml,v 1.91.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+(* $Id: reduction.ml 9215 2006-10-05 15:40:31Z herbelin $ *)
 
 open Util
 open Names
@@ -41,8 +41,8 @@ let compare_stack_shape stk1 stk2 =
       ([],[]) -> bal=0
     | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2
     | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2
-    | (Zapp l1::s1, _) -> compare_rec (bal+List.length l1) s1 stk2
-    | (_, Zapp l2::s2) -> compare_rec (bal-List.length l2) stk1 s2
+    | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2
+    | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2
     | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) ->
         bal=0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
     | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) ->
@@ -50,6 +50,16 @@ let compare_stack_shape stk1 stk2 =
     | (_,_) -> false in
   compare_rec 0 stk1 stk2
 
+type lft_constr_stack_elt =
+    Zlapp of (lift * fconstr) array
+  | Zlfix of (lift * fconstr) * lft_constr_stack
+  | Zlcase of case_info * lift * fconstr * fconstr array
+and lft_constr_stack = lft_constr_stack_elt list
+
+let rec zlapp v = function
+    Zlapp v2 :: s -> zlapp (Array.append v v2) s
+  | s -> Zlapp v :: s
+
 let pure_stack lfts stk =
   let rec pure_rec lfts stk =
     match stk with
@@ -58,15 +68,13 @@ let pure_stack lfts stk =
           (match (zi,pure_rec lfts s) with
               (Zupdate _,lpstk)  -> lpstk
             | (Zshift n,(l,pstk)) -> (el_shft n l, pstk)
-            | (Zapp a1,(l,Zapp a2::pstk)) ->
-                (l,Zapp (List.map (fun t -> (l,t)) a1 @ a2)::pstk)
             | (Zapp a, (l,pstk)) ->
-                (l,Zapp (List.map (fun t -> (l,t)) a)::pstk)
+                (l,zlapp (Array.map (fun t -> (l,t)) a) pstk)
             | (Zfix(fx,a),(l,pstk)) ->
                 let (lfx,pa) = pure_rec l a in
-                (l, Zfix((lfx,fx),pa)::pstk)
+                (l, Zlfix((lfx,fx),pa)::pstk)
             | (Zcase(ci,p,br),(l,pstk)) ->
-                (l,Zcase(ci,(l,p),Array.map (fun t -> (l,t)) br)::pstk)) in
+                (l,Zlcase(ci,l,p,br)::pstk)) in
   snd (pure_rec lfts stk)
 
 (****************************************************************************)
@@ -98,10 +106,10 @@ let whd_betadeltaiota_nolet env t =
 
 let beta_appvect c v =
   let rec stacklam env t stack =
-    match (decomp_stack stack,kind_of_term t) with
-      | Some (h,stacktl), Lambda (_,_,c) -> stacklam (h::env) c stacktl
-      | _ -> app_stack (substl env t, stack) in
-  stacklam [] c (append_stack v empty_stack)
+    match kind_of_term t, stack with
+        Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl
+      | _ -> applist (substl env t, stack) in
+  stacklam [] c (Array.to_list v)
 
 (********************************************************************)
 (*                         Conversion                               *)
@@ -117,17 +125,17 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
   let rec cmp_rec pstk1 pstk2 cuniv =
     match (pstk1,pstk2) with
       | (z1::s1, z2::s2) ->
-          let c1 = cmp_rec s1 s2 cuniv in
+          let cu1 = cmp_rec s1 s2 cuniv in
           (match (z1,z2) with
-            | (Zapp a1,Zapp a2) -> List.fold_right2 f a1 a2 c1
-            | (Zfix(fx1,a1),Zfix(fx2,a2)) ->
-                let c2 = f fx1 fx2 c1 in
-                cmp_rec a1 a2 c2
-            | (Zcase(ci1,p1,br1),Zcase(ci2,p2,br2)) ->
+            | (Zlapp a1,Zlapp a2) -> array_fold_right2 f a1 a2 cu1
+            | (Zlfix(fx1,a1),Zlfix(fx2,a2)) ->
+                let cu2 = f fx1 fx2 cu1 in
+                cmp_rec a1 a2 cu2
+            | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) ->
                 if not (fmind ci1.ci_ind ci2.ci_ind) then
 		  raise NotConvertible;
-		let c2 = f p1 p2 c1 in
-                array_fold_right2 f br1 br2 c2
+		let cu2 = f (l1,p1) (l2,p2) cu1 in
+                array_fold_right2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 cu2
             | _ -> assert false)
       | _ -> cuniv in
   if compare_stack_shape stk1 stk2 then
@@ -249,14 +257,14 @@ and eqappr cv_pb infos appr1 appr2 cuniv =
 
     (* Inductive types:  MutInd MutConstruct Fix Cofix *)
 
-     | (FInd (kn1,i1), FInd (kn2,i2)) ->
-         if i1 = i2 && mind_equiv infos kn1 kn2
+     | (FInd ind1, FInd ind2) ->
+         if mind_equiv_infos infos ind1 ind2
 	 then
            convert_stacks infos lft1 lft2 v1 v2 cuniv
          else raise NotConvertible
 
-     | (FConstruct ((kn1,i1),j1), FConstruct ((kn2,i2),j2)) ->
-	 if i1 = i2 && j1 = j2 && mind_equiv infos kn1 kn2
+     | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
+	 if j1 = j2 && mind_equiv_infos infos ind1 ind2
 	 then
            convert_stacks infos lft1 lft2 v1 v2 cuniv
          else raise NotConvertible
@@ -291,17 +299,25 @@ and eqappr cv_pb infos appr1 appr2 cuniv =
            convert_stacks infos lft1 lft2 v1 v2 u2
          else raise NotConvertible
 
-    | ( (FLetIn _, _) | (_, FLetIn _) | (FCases _,_) | (_,FCases _)
-      | (FApp _,_) | (_,FApp _) | (FCLOS _, _) | (_,FCLOS _)
-      | (FLIFT _, _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED)) ->
-        anomaly "Unexpected term returned by fhnf"
+    (* Can happen because whd_stack on one arg may have side-effects
+       on the other arg and coulb be no more in hnf... *)
+    | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_)
+      | (FCLOS _, _) | (FLIFT _, _)) ->
+        eqappr cv_pb infos (lft1, whd_stack infos hd1 v1) appr2 cuniv
+
+    | ( (_, FLetIn _) | (_,FCases _) | (_,FApp _)
+      | (_,FCLOS _) | (_,FLIFT _)) ->
+        eqappr cv_pb infos (lft1, whd_stack infos hd1 v1) appr2 cuniv
+
+    (* Should not happen because whd_stack unlocks references *)
+    | ((FLOCKED,_) | (_,FLOCKED)) -> assert false
 
      | _ -> raise NotConvertible
 
 and convert_stacks infos lft1 lft2 stk1 stk2 cuniv =
   compare_stacks
     (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c)
-    (fun (mind1,i1) (mind2,i2) -> i1=i2 && mind_equiv infos mind1 mind2)
+    (mind_equiv_infos infos)
     lft1 stk1 lft2 stk2 cuniv
 
 and convert_vect infos lft1 lft2 v1 v2 cuniv =
@@ -317,16 +333,15 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv =
     fold 0 cuniv
   else raise NotConvertible
 
-
+let clos_fconv cv_pb env t1 t2 =
+  let infos = create_clos_infos betaiotazeta env in
+  ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty
 
 let fconv cv_pb env t1 t2 =
-  if eq_constr t1 t2 then 
-    Constraint.empty
-  else
-    let infos = create_clos_infos betaiotazeta env in
-    ccnv cv_pb infos ELID ELID (inject t1) (inject t2)
-      Constraint.empty
+  if eq_constr t1 t2 then Constraint.empty
+  else clos_fconv cv_pb env t1 t2
 
+let conv_cmp = fconv
 let conv = fconv CONV
 let conv_leq = fconv CUMUL
 
@@ -341,6 +356,30 @@ let conv_leq_vecti env v1 v2 =
     v1
     v2
 
+(* option for conversion *)
+
+let vm_conv = ref fconv
+let set_vm_conv f = vm_conv := f
+let vm_conv cv_pb env t1 t2 = 
+  try 
+    !vm_conv cv_pb env t1 t2
+  with Not_found | Invalid_argument _ ->
+      (* If compilation fails, fall-back to closure conversion *)
+      clos_fconv cv_pb env t1 t2
+  
+
+let default_conv = ref fconv 
+
+let set_default_conv f = default_conv := f
+
+let default_conv cv_pb env t1 t2 = 
+  try 
+    !default_conv cv_pb env t1 t2
+  with Not_found | Invalid_argument _ ->
+      (* If compilation fails, fall-back to closure conversion *)
+      clos_fconv cv_pb env t1 t2
+  
+let default_conv_leq = default_conv CUMUL
 (*
 let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";;
 let conv_leq env t1 t2 =
@@ -393,13 +432,13 @@ let dest_prod_assum env =
     | LetIn (x,b,t,c) ->
         let d = (x,Some b,t) in
 	prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c
-    | Cast (c,_)    -> prodec_rec env l c
+    | Cast (c,_,_)    -> prodec_rec env l c
     | _               -> l,rty
   in
   prodec_rec env Sign.empty_rel_context
 
 let dest_arity env c =
-  let l, c = dest_prod env c in
+  let l, c = dest_prod_assum env c in
   match kind_of_term c with
     | Sort s -> l,s
     | _ -> error "not an arity"
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index c516ea70..a68e8697 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reduction.mli,v 1.56.8.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: reduction.mli 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 (*i*)
 open Term
@@ -29,13 +29,28 @@ exception NotConvertible
 exception NotConvertibleVect of int
 type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
 
+type conv_pb = CONV | CUMUL
+
+val sort_cmp : 
+    conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints
+
 val conv_sort      : sorts conversion_function
 val conv_sort_leq  : sorts conversion_function
 
-val conv           : types conversion_function
+val conv_cmp       : conv_pb -> constr conversion_function
+
+val conv           : constr conversion_function
 val conv_leq       : types conversion_function
 val conv_leq_vecti : types array conversion_function
 
+(* option for conversion *)
+val set_vm_conv : (conv_pb -> types conversion_function) -> unit
+val vm_conv : conv_pb -> types conversion_function
+
+val set_default_conv : (conv_pb -> types conversion_function) -> unit
+val default_conv     : conv_pb -> types conversion_function
+val default_conv_leq : types conversion_function
+
 (************************************************************************)
 
 (* Builds an application node, reducing beta redexes it may produce. *) 
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 0f8c0d54..c4d9c991 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: safe_typing.ml,v 1.76.2.2 2005/11/23 14:46:08 barras Exp $ *)
+(* $Id: safe_typing.ml 9310 2006-10-28 19:35:09Z herbelin $ *)
 
 open Util
 open Names
@@ -30,7 +30,6 @@ type modvariant =
   | NONE 
   | SIG of (* funsig params *) (mod_bound_id * module_type_body) list 
   | STRUCT of (* functor params *) (mod_bound_id * module_type_body) list
-      * (* optional result type *) module_type_body option
   | LIBRARY of dir_path
 
 type module_info = 
@@ -120,6 +119,12 @@ type global_declaration =
   | ConstantEntry of constant_entry
   | GlobalRecipe of Cooking.recipe
 
+let hcons_constant_type = function
+  | NonPolymorphicType t ->
+      NonPolymorphicType (hcons1_constr t)
+  | PolymorphicArity (ctx,s) ->
+      PolymorphicArity (map_rel_context hcons1_constr ctx,s)
+
 let hcons_constant_body cb =
   let body = match cb.const_body with
       None -> None
@@ -128,28 +133,28 @@ let hcons_constant_body cb =
   in
     { cb with
 	const_body = body;
-	const_type = hcons1_constr cb.const_type }
+	const_type = hcons_constant_type cb.const_type }
 
 let add_constant dir l decl senv =
   check_label l senv.labset;
-  let cb = match decl with 
-      ConstantEntry ce -> translate_constant senv.env ce
-    | GlobalRecipe r ->
-        let cb = translate_recipe senv.env r in
-        if dir = empty_dirpath then hcons_constant_body cb else cb
+  let kn = make_con senv.modinfo.modpath dir l in
+  let cb = 
+    match decl with 
+      | ConstantEntry ce -> translate_constant senv.env kn ce
+      | GlobalRecipe r ->
+	  let cb = translate_recipe senv.env kn r in
+	    if dir = empty_dirpath then hcons_constant_body cb else cb
   in
-(*  let cb = if dir = empty_dirpath then hcons_constant_body cb else cb in*)
   let env' = Environ.add_constraints cb.const_constraints senv.env in
-  let kn = make_kn senv.modinfo.modpath dir l in
   let env'' = Environ.add_constant kn cb env' in
-  kn, { old = senv.old;
-	env = env'';
-	modinfo = senv.modinfo;
-	labset = Labset.add l senv.labset;
-	revsign = (l,SPBconst cb)::senv.revsign;
-	revstruct = (l,SEBconst cb)::senv.revstruct;
-	imports = senv.imports;
-	loads = senv.loads }
+    kn, { old = senv.old;
+	  env = env'';
+	  modinfo = senv.modinfo;
+	  labset = Labset.add l senv.labset;
+	  revsign = (l,SPBconst cb)::senv.revsign;
+	  revstruct = (l,SEBconst cb)::senv.revstruct;
+	  imports = senv.imports;
+	  loads = senv.loads }
     
 
 (* Insertion of inductive types. *)
@@ -224,36 +229,18 @@ let add_module l me senv =
 
 (* Interactive modules *)
 
-let start_module l params result senv = 
+let start_module l senv = 
   check_label l senv.labset; 
-  let rec trans_params env = function 
-    | [] -> env,[] 
-    | (mbid,mte)::rest -> 
-	let mtb = translate_modtype env mte in
-	let env = 
-	  full_add_module (MPbound mbid) (module_body_of_type mtb) env 
-	in
-	let env,transrest = trans_params env rest in
-	env, (mbid,mtb)::transrest
-  in
-  let env,params_body = trans_params senv.env params in
-  let check_sig mtb = match scrape_modtype env mtb with
-    | MTBsig _ -> ()
-    | MTBfunsig _ -> error_result_must_be_signature mtb 
-    | _ -> anomaly "start_module: modtype not scraped"
-  in
-  let result_body = option_app (translate_modtype env) result in
-  ignore (option_app check_sig result_body);
   let msid = make_msid senv.modinfo.seed (string_of_label l) in
   let mp = MPself msid in
   let modinfo = { msid = msid;
 		  modpath = mp;
 		  seed = senv.modinfo.seed;
 		  label = l;
-		  variant = STRUCT(params_body,result_body) }
+		  variant = STRUCT [] }
   in
   mp, { old = senv;
-	env = env;
+	env = senv.env;
 	modinfo = modinfo;
 	labset = Labset.empty;
 	revsign = [];
@@ -261,21 +248,21 @@ let start_module l params result senv =
 	imports = senv.imports;
 	loads = [] }
 
-
-
-let end_module l senv = 
+let end_module l restype senv = 
   let oldsenv = senv.old in
   let modinfo = senv.modinfo in
-  let params, restype = 
+  let restype = option_map (translate_modtype senv.env) restype in
+  let params = 
     match modinfo.variant with
       | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end ()
-      | STRUCT(params,restype) -> (params,restype)
+      | STRUCT params -> params
   in
   if l <> modinfo.label then error_incompatible_labels l modinfo.label;
   if not (empty_context senv.env) then error_local_context None;
-  let functorize_type = 
-    List.fold_right 
-      (fun (arg_id,arg_b) mtb -> MTBfunsig (arg_id,arg_b,mtb))
+  let functorize_type tb = 
+    List.fold_left
+      (fun mtb (arg_id,arg_b) -> MTBfunsig (arg_id,arg_b,mtb))
+      tb
       params
   in
   let auto_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in
@@ -288,10 +275,10 @@ let end_module l senv =
 	    mtb, Some mtb, cst
   in
   let mexpr = 
-    List.fold_right
-      (fun (arg_id,arg_b) mtb -> MEBfunctor (arg_id,arg_b,mtb))
-      params
+    List.fold_left
+      (fun mtb (arg_id,arg_b) -> MEBfunctor (arg_id,arg_b,mtb))
       (MEBstruct (modinfo.msid, List.rev senv.revstruct)) 
+      params
   in
   let mb = 
     { mod_expr = Some mexpr;
@@ -326,31 +313,44 @@ let end_module l senv =
 	loads = senv.loads@oldsenv.loads }
 
 
+(* Adding parameters to modules or module types *)
+
+let add_module_parameter mbid mte senv =
+  if senv.revsign <> [] or senv.revstruct <> [] or senv.loads <> [] then
+    anomaly "Cannot add a module parameter to a non empty module";
+  let mtb = translate_modtype senv.env mte in
+  let env = full_add_module (MPbound mbid) (module_body_of_type mtb) senv.env 
+  in
+  let new_variant = match senv.modinfo.variant with
+    | STRUCT params -> STRUCT ((mbid,mtb) :: params)
+    | SIG params -> SIG ((mbid,mtb) :: params)
+    | _ -> 
+	anomaly "Module parameters can only be added to modules or signatures"
+  in
+  { old = senv.old;
+    env = env;
+    modinfo = { senv.modinfo with variant = new_variant };
+    labset = senv.labset;
+    revsign = [];
+    revstruct = [];
+    imports = senv.imports;
+    loads = [] }
+
+
 (* Interactive module types *)
 
-let start_modtype l params senv = 
+let start_modtype l senv = 
   check_label l senv.labset; 
-  let rec trans_params env = function 
-    | [] -> env,[] 
-    | (mbid,mte)::rest -> 
-	let mtb = translate_modtype env mte in
-	let env = 
-	  full_add_module (MPbound mbid) (module_body_of_type mtb) env 
-	in
-	let env,transrest = trans_params env rest in
-	env, (mbid,mtb)::transrest
-  in
-  let env,params_body = trans_params senv.env params in
   let msid = make_msid senv.modinfo.seed (string_of_label l) in
   let mp = MPself msid in
   let modinfo = { msid = msid;
 		  modpath = mp;
 		  seed = senv.modinfo.seed;
 		  label = l;
-		  variant = SIG params_body }
+		  variant = SIG [] }
   in
   mp, { old = senv;
-	env = env;
+	env = senv.env;
 	modinfo = modinfo;
 	labset = Labset.empty;
 	revsign = [];
@@ -370,10 +370,10 @@ let end_modtype l senv =
   if not (empty_context senv.env) then error_local_context None;
   let res_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in
   let mtb = 
-    List.fold_right 
-      (fun (arg_id,arg_b) mtb -> MTBfunsig (arg_id,arg_b,mtb))
-      params
+    List.fold_left
+      (fun mtb (arg_id,arg_b) -> MTBfunsig (arg_id,arg_b,mtb))
       res_tb
+      params
   in
   let kn = make_kn oldsenv.modinfo.modpath empty_dirpath l in
   let newenv = oldsenv.env in
@@ -417,7 +417,6 @@ let check_engagement env c =
 let set_engagement c senv =
   {senv with env = Environ.set_engagement c senv.env}
 
-
 (* Libraries = Compiled modules *)
 
 type compiled_library = 
@@ -517,13 +516,13 @@ let import (dp,mb,depends,engmt) digest senv =
 	  loads = (mp,mb)::senv.loads }
 
 
-(** Remove the body of opaque constants in modules *)
+(* Remove the body of opaque constants in modules *)
  
 let rec lighten_module mb =
   { mb with
-    mod_expr = option_app lighten_modexpr mb.mod_expr;
+    mod_expr = option_map lighten_modexpr mb.mod_expr;
     mod_type = lighten_modtype mb.mod_type;
-    mod_user_type = option_app lighten_modtype mb.mod_user_type }
+    mod_user_type = option_map lighten_modtype mb.mod_user_type }
 
 and lighten_modtype = function
   | MTBident kn as x -> x
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index b973fcde..c3d0abde 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: safe_typing.mli,v 1.33.2.2 2005/11/23 14:46:08 barras Exp $ i*)
+(*i $Id: safe_typing.mli 8723 2006-04-16 15:51:02Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -28,7 +28,6 @@ type safe_environment
 val env_of_safe_env : safe_environment -> Environ.env
 
 val empty_environment : safe_environment
-
 val is_empty : safe_environment -> bool
 
 (* Adding and removing local declarations (Local or Variables) *)
@@ -46,7 +45,7 @@ type global_declaration =
 
 val add_constant : 
   dir_path -> label -> global_declaration -> safe_environment -> 
-      kernel_name * safe_environment
+      constant * safe_environment
 
 (* Adding an inductive type *)
 val add_mind : 
@@ -68,22 +67,22 @@ val add_constraints :
   Univ.constraints -> safe_environment -> safe_environment
 
 (* Settin the strongly constructive or classical logical engagement *)
-val set_engagement : Environ.engagement -> safe_environment -> safe_environment
+val set_engagement : engagement -> safe_environment -> safe_environment
 
 
 (*s Interactive module functions *)
 val start_module : 
-  label -> (mod_bound_id * module_type_entry) list 
-    -> module_type_entry option 
-      -> safe_environment -> module_path * safe_environment
+  label -> safe_environment -> module_path * safe_environment
 
 val end_module :
-  label -> safe_environment -> module_path * safe_environment 
+  label -> module_type_entry option 
+      -> safe_environment -> module_path * safe_environment 
 
+val add_module_parameter :
+  mod_bound_id -> module_type_entry -> safe_environment -> safe_environment
 
 val start_modtype :
-  label -> (mod_bound_id * module_type_entry) list
-    -> safe_environment -> module_path * safe_environment
+  label -> safe_environment -> module_path * safe_environment
 
 val end_modtype :
   label -> safe_environment -> kernel_name * safe_environment
diff --git a/kernel/sign.ml b/kernel/sign.ml
index a4b2a2ea..b42ca581 100644
--- a/kernel/sign.ml
+++ b/kernel/sign.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: sign.ml,v 1.37.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+(* $Id: sign.ml 9103 2006-09-01 11:02:52Z herbelin $ *)
 
 open Names
 open Util
@@ -53,13 +53,11 @@ let empty_rel_context = []
 
 let add_rel_decl d ctxt = d::ctxt
 
-let lookup_rel n sign =
-  let rec lookrec = function
-    | (1, decl :: _) -> decl
-    | (n, _ :: sign) -> lookrec (n-1,sign)
-    | (_, [])        -> raise Not_found
-  in 
-  lookrec (n,sign)
+let rec lookup_rel n sign =
+  match n, sign with
+  | 1, decl :: _ -> decl
+  | n, _ :: sign -> lookup_rel (n-1) sign
+  | _, []        -> raise Not_found
 
 let rel_context_length = List.length
 
@@ -73,7 +71,7 @@ let rel_context_nhyps hyps =
 let fold_rel_context f l ~init:x = List.fold_right f l x
 let fold_rel_context_reverse f ~init:x l = List.fold_left f x l
 
-let map_rel_context f l = 
+let map_context f l =
   let map_decl (n, body_o, typ as decl) =
     let body_o' = option_smartmap f body_o in
     let typ' = f typ in
@@ -82,13 +80,19 @@ let map_rel_context f l =
   in
     list_smartmap map_decl l
 
+let map_rel_context = map_context
+let map_named_context = map_context
+
+let iter_rel_context f = List.iter (fun (_,b,t) -> f t; option_iter f b)
+let iter_named_context f = List.iter (fun (_,b,t) -> f t; option_iter f b)
+
 (* Push named declarations on top of a rel context *)
 (* Bizarre. Should be avoided. *)
 let push_named_to_rel_context hyps ctxt =
   let rec push = function
     | (id,b,t) :: l ->
 	let s, hyps = push l in
-	let d = (Name id, option_app (subst_vars s) b, type_app (subst_vars s) t) in
+	let d = (Name id, option_map (subst_vars s) b, type_app (subst_vars s) t) in
 	id::s, d::hyps
     | [] -> [],[] in
   let s, hyps = push hyps in
@@ -121,7 +125,7 @@ let destArity =
     match kind_of_term c with
     | Prod (x,t,c)    -> prodec_rec ((x,None,t)::l) c
     | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c
-    | Cast (c,_)      -> prodec_rec l c
+    | Cast (c,_,_)      -> prodec_rec l c
     | Sort s          -> l,s
     | _               -> anomaly "destArity: not an arity"
   in 
@@ -133,7 +137,7 @@ let rec isArity c =
   match kind_of_term c with
   | Prod (_,_,c)    -> isArity c
   | LetIn (_,b,_,c) -> isArity (subst1 b c)
-  | Cast (c,_)      -> isArity c
+  | Cast (c,_,_)      -> isArity c
   | Sort _          -> true
   | _               -> false
 
@@ -144,7 +148,7 @@ let decompose_prod_assum =
     match kind_of_term c with
     | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) c
     | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c
-    | Cast (c,_)      -> prodec_rec l c
+    | Cast (c,_,_)      -> prodec_rec l c
     | _               -> l,c
   in 
   prodec_rec empty_rel_context
@@ -156,7 +160,7 @@ let decompose_lam_assum =
     match kind_of_term c with
     | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) c
     | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c
-    | Cast (c,_)      -> lamdec_rec l c
+    | Cast (c,_,_)      -> lamdec_rec l c
     | _               -> l,c
   in 
   lamdec_rec empty_rel_context
@@ -171,7 +175,7 @@ let decompose_prod_n_assum n =
     else match kind_of_term c with 
     | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c
     | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
-    | Cast (c,_)      -> prodec_rec l n c
+    | Cast (c,_,_)      -> prodec_rec l n c
     | c -> error "decompose_prod_n_assum: not enough assumptions"
   in 
   prodec_rec empty_rel_context n
@@ -186,7 +190,8 @@ let decompose_lam_n_assum n =
     else match kind_of_term c with 
     | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c
     | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
-    | Cast (c,_)      -> lamdec_rec l n c
+    | Cast (c,_,_)      -> lamdec_rec l n c
     | c -> error "decompose_lam_n_assum: not enough abstractions"
   in 
   lamdec_rec empty_rel_context n 
+
diff --git a/kernel/sign.mli b/kernel/sign.mli
index 3f0549cc..88e9dbf0 100644
--- a/kernel/sign.mli
+++ b/kernel/sign.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: sign.mli,v 1.40.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: sign.mli 9103 2006-09-01 11:02:52Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -62,6 +62,15 @@ val fold_rel_context_reverse :
 (*s Map function of [rel_context] *)
 val map_rel_context : (constr -> constr) -> rel_context -> rel_context
 
+(*s Map function of [named_context] *)
+val map_named_context : (constr -> constr) -> named_context -> named_context
+
+(*s Map function of [rel_context] *)
+val iter_rel_context : (constr -> unit) -> rel_context -> unit
+
+(*s Map function of [named_context] *)
+val iter_named_context : (constr -> unit) -> named_context -> unit
+
 (*s Term constructors *)
 
 val it_mkLambda_or_LetIn : constr -> rel_context -> constr
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 835226fb..d1a10651 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.ml,v 1.11.2.2 2005/11/29 21:40:52 letouzey Exp $ i*)
+(*i $Id: subtyping.ml 9558 2007-01-30 14:58:42Z soubiran $ i*)
 
 (*i*)
 open Util
@@ -18,6 +18,8 @@ open Environ
 open Reduction
 open Inductive
 open Modops
+open Mod_subst
+open Entries
 (*i*)
 
 (* This local type is used to subtype a constant with a constructor or
@@ -26,7 +28,6 @@ open Modops
 
 type namedobject = 
   | Constant of constant_body
-  | Mind of mutual_inductive_body
   | IndType of inductive * mutual_inductive_body
   | IndConstr of constructor * mutual_inductive_body
   | Module of module_specification_body
@@ -40,31 +41,27 @@ let add_nameobjects_of_mib ln mib map =
     let ip = (ln,j) in
     let map = 
       array_fold_right_i 
-	(fun i id map -> Idmap.add id (IndConstr ((ip,i), mib)) map)
-	oib.mind_consnames
-	map
+      (fun i id map ->
+        Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map)
+      oib.mind_consnames
+      map
     in
-      Idmap.add oib.mind_typename (IndType (ip, mib)) map
+      Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map
   in
     array_fold_right_i add_nameobjects_of_one mib.mind_packets map
 
+
 (* creates namedobject map for the whole signature *)
 
-let make_label_map msid list = 
+let make_label_map mp list = 
   let add_one (l,e) map = 
-    let obj = 
-      match e with
-	| SPBconst cb -> Constant cb
-	| SPBmind mib -> Mind mib
-	| SPBmodule mb -> Module mb
-	| SPBmodtype mtb -> Modtype mtb
-    in
-(*    let map = match obj with
-      | Mind mib -> 
-	  add_nameobjects_of_mib (make_ln (MPself msid) l) mib map
-      | _ -> map
-    in *)
-      Labmap.add l obj map
+   let add_map obj = Labmap.add l obj map in
+   match e with
+    | SPBconst cb -> add_map (Constant cb)
+    | SPBmind mib ->
+       add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map
+    | SPBmodule mb -> add_map (Module mb)
+    | SPBmodtype mtb -> add_map (Modtype mtb)
   in
     List.fold_right add_one list Labmap.empty
 
@@ -81,10 +78,44 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
   let check_conv cst f = check_conv_error error cst f in
   let mib1 = 
     match info1 with
-      | Mind mib -> mib
-    (*  | IndType (_,mib) -> mib   we will enable this later*)
+      | IndType ((_,0), mib) -> mib
       | _ -> error ()
   in
+  let check_inductive_type cst env t1 t2 =
+
+    (* Due to sort-polymorphism in inductive types, the conclusions of
+       t1 and t2, if in Type, are generated as the least upper bounds
+       of the types of the constructors. 
+
+       By monotonicity of the infered l.u.b.  wrt subtyping (i.e.  if X:U
+       |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each
+       universe in the conclusion of t1 has an bounding universe in
+       the conclusion of t2, so that we don't need to check the
+       subtyping of the conclusions of t1 and t2.
+
+       Even if we'd like to recheck it, the inference of constraints
+       is not designed to deal with algebraic constraints of the form
+       max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy
+       to recheck it (in short, we would need the actual graph of
+       constraints as input while type checking is currently designed
+       to output a set of constraints instead) *)
+
+    (* So we cheat and replace the subtyping problem on algebraic
+       constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n)
+       (that we know are necessary true) by trivial constraints that
+       the constraint generator knows how to deal with *)
+
+    let (ctx1,s1) = dest_arity env t1 in
+    let (ctx2,s2) = dest_arity env t2 in
+    let s1,s2 =
+      match s1, s2 with
+      | Type _, Type _ -> (* shortcut here *) mk_Prop, mk_Prop
+      | (Prop _, Type _) | (Type _,Prop _) -> error ()
+      | _ -> (s1, s2) in
+    check_conv cst conv_leq env 
+      (Sign.mkArity (ctx1,s1)) (Sign.mkArity (ctx2,s2))
+  in
+
   let check_packet cst p1 p2 =
     let check f = if f p1 <> f p2 then error () in
       check (fun p -> p.mind_consnames);
@@ -93,14 +124,15 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
       (* nf_arity later *)
       (* user_lc ignored *)
       (* user_arity ignored *)
-      let cst = check_conv cst conv_sort env p1.mind_sort p2.mind_sort in
       check (fun p -> p.mind_nrealargs);
       (* kelim ignored *)
       (* listrec ignored *)
       (* finite done *)
       (* nparams done *)
-      (* params_ctxt done *)
-      let cst = check_conv cst conv env p1.mind_nf_arity p2.mind_nf_arity in
+      (* params_ctxt done because part of the inductive types *)
+      (* Don't check the sort of the type if polymorphic *)
+      let cst = check_inductive_type cst env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
+      in
 	cst
   in
   let check_cons_types i cst p1 p2 =
@@ -117,9 +149,12 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
   assert (Array.length mib1.mind_packets >= 1 
 	    && Array.length mib2.mind_packets >= 1);
 
-       (* TODO: we should allow renaming of parameters at least ! *)
-  check (fun mib -> mib.mind_packets.(0).mind_nparams);
-  check (fun mib -> mib.mind_packets.(0).mind_params_ctxt); 
+  (* Check that the expected numbers of uniform parameters are the same *)
+  (* No need to check the contexts of parameters: it is checked *)
+  (* at the time of checking the inductive arities in check_packet. *)
+  (* Notice that we don't expect the local definitions to match: only *)
+  (* the inductive types and constructors types have to be convertible *)
+  check (fun mib -> mib.mind_nparams);
 
   begin 
     match mib2.mind_equiv with
@@ -133,32 +168,19 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
 	    if kn1 <> kn2 then error ()
   end;
   (* we check that records and their field names are preserved. *)
-  (* To stay compatible, we don't fail but only issue a warning. *)
-  if mib1.mind_record <> mib2.mind_record then begin
-    let sid = string_of_id mib1.mind_packets.(0).mind_typename in 
-    Pp.warning 
-      (sid^": record is implemented as an inductive type or conversely.\n"^
-	 "Beware that extraction cannot handle this situation.\n")
-  end; 
+  check (fun mib -> mib.mind_record);
   if mib1.mind_record then begin 
     let rec names_prod_letin t = match kind_of_term t with 
       | Prod(n,_,t) -> n::(names_prod_letin t)
       | LetIn(n,_,_,t) -> n::(names_prod_letin t)
-      | Cast(t,_) -> names_prod_letin t
+      | Cast(t,_,_) -> names_prod_letin t
       | _ -> []
     in 
     assert (Array.length mib1.mind_packets = 1);
     assert (Array.length mib2.mind_packets = 1);
     assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); 
     assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); 
-    let fields1 = names_prod_letin mib1.mind_packets.(0).mind_user_lc.(0)
-    and fields2 = names_prod_letin mib2.mind_packets.(0).mind_user_lc.(0) in  
-    if fields1 <> fields2 then 
-      let sid = string_of_id mib1.mind_packets.(0).mind_typename in 
-      Pp.warning 
-	(sid^": record has different field names in its signature and "^
-	   "implemantation.\n"^
-	   "Beware that extraction cannot handle this situation.\n");
+    check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
   end;
   (* we first check simple things *)
   let cst = 
@@ -173,23 +195,96 @@ let check_inductive cst env msid1 l info1 mib2 spec2 =
 let check_constant cst env msid1 l info1 cb2 spec2 = 
   let error () = error_not_match l spec2 in
   let check_conv cst f = check_conv_error error cst f in
-  let cb1 = 
-    match info1 with
-      | Constant cb -> cb
-      | _ -> error ()
-  in 
-    assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
-  (*Start by checking types*)
-    let cst = check_conv cst conv_leq env cb1.const_type cb2.const_type in
-    match cb2.const_body with
-      | None -> cst
-      | Some lc2 ->
-	  let c2 = Declarations.force lc2 in
-	  let c1 = match cb1.const_body with
-	    | Some lc1 -> Declarations.force lc1
-	    | None -> mkConst (make_kn (MPself msid1) empty_dirpath l)
-	  in
-	    check_conv cst conv env c1 c2
+  let check_type cst env t1 t2 = 
+
+    (* If the type of a constant is generated, it may mention
+       non-variable algebraic universes that the general conversion
+       algorithm is not ready to handle. Anyway, generated types of
+       constants are functions of the body of the constant. If the
+       bodies are the same in environments that are subtypes one of
+       the other, the types are subtypes too (i.e. if Gamma <= Gamma',
+       Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T').
+       Hence they don't have to be checked again *)
+
+    let t1,t2 = 
+      if Sign.isArity t2 then
+        let (ctx2,s2) = Sign.destArity t2 in
+        match s2 with
+        | Type v when not (is_univ_variable v) ->
+          (* The type in the interface is inferred and is made of algebraic
+             universes *)
+          begin try
+            let (ctx1,s1) = dest_arity env t1 in
+            match s1 with
+            | Type u when not (is_univ_variable u) ->
+              (* Both types are inferred, no need to recheck them. We
+                 cheat and collapse the types to Prop *)
+                Sign.mkArity (ctx1,mk_Prop), Sign.mkArity (ctx2,mk_Prop)
+            | Prop _ ->
+              (* The type in the interface is inferred, it may be the case
+                 that the type in the implementation is smaller because
+                 the body is more reduced. We safely collapse the upper
+                 type to Prop *)
+                Sign.mkArity (ctx1,mk_Prop), Sign.mkArity (ctx2,mk_Prop)
+            | Type _ ->
+              (* The type in the interface is inferred and the type in the
+                 implementation is not inferred or is inferred but from a
+                 more reduced body so that it is just a variable. Since
+                 constraints of the form "univ <= max(...)" are not
+                 expressible in the system of algebraic universes: we fail
+                 (the user has to use an explicit type in the interface *)
+                error ()
+          with UserError _ (* "not an arity" *) ->
+            error () end
+        | _ -> t1,t2
+      else
+        (t1,t2) in
+    check_conv cst conv_leq env t1 t2
+  in
+
+  match info1 with
+   | Constant cb1 ->
+      assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+      (*Start by checking types*)
+      let typ1 = Typeops.type_of_constant_type env cb1.const_type in
+      let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+      let cst = check_type cst env typ1 typ2 in
+      let con = make_con (MPself msid1) empty_dirpath l in
+      let cst =
+       match cb2.const_body with
+         | None -> cst
+         | Some lc2 ->
+	     let c2 = Declarations.force lc2 in
+	     let c1 = match cb1.const_body with
+	       | Some lc1 -> Declarations.force lc1
+	       | None -> mkConst con
+	     in
+	       check_conv cst conv env c1 c2
+      in
+       cst
+   | IndType ((kn,i),mind1) ->
+      ignore (Util.error (
+       "The kernel does not recognize yet that a parameter can be " ^
+       "instantiated by an inductive type. Hint: you can rename the " ^
+       "inductive type and give a definition to map the old name to the new " ^
+       "name."));
+      assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
+      if cb2.const_body <> None then error () ;
+      let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
+      let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+       check_conv cst conv_leq env arity1 typ2
+   | IndConstr (((kn,i),j) as cstr,mind1) ->
+      ignore (Util.error (
+       "The kernel does not recognize yet that a parameter can be " ^
+       "instantiated by a constructor. Hint: you can rename the " ^
+       "constructor and give a definition to map the old name to the new " ^
+       "name."));
+      assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
+      if cb2.const_body <> None then error () ;
+      let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
+      let ty2 = Typeops.type_of_constant_type env cb2.const_type in
+       check_conv cst conv env ty1 ty2
+   | _ -> error ()
 	      
 let rec check_modules cst env msid1 l msb1 msb2 =
   let mp = (MPdot(MPself msid1,l)) in
@@ -206,17 +301,21 @@ let rec check_modules cst env msid1 l msb1 msb2 =
   cst
 	
 
-and check_signatures cst env' (msid1,sig1) (msid2,sig2') = 
+and check_signatures cst env (msid1,sig1) (msid2,sig2') = 
   let mp1 = MPself msid1 in
-  let env = add_signature mp1 sig1 env' in 
-  let sig2 = subst_signature_msid msid2 mp1 sig2' in
-  let map1 = make_label_map msid1 sig1 in
+  let env = add_signature mp1 sig1 env in 
+  let sig2 = try
+    subst_signature_msid msid2 mp1 sig2' 
+    with
+    | Circularity l -> 
+	error_circularity_in_subtyping l (string_of_msid msid1) (string_of_msid msid2) in
+  let map1 = make_label_map mp1 sig1 in
   let check_one_body cst (l,spec2) = 
     let info1 = 
       try 
 	Labmap.find l map1 
       with 
-	  Not_found -> error_no_such_label l 
+	  Not_found -> error_no_such_label_sub l (string_of_msid msid1) (string_of_msid msid2)
     in
       match spec2 with
 	| SPBconst cb2 ->
@@ -241,10 +340,10 @@ and check_signatures cst env' (msid1,sig1) (msid2,sig2') =
     List.fold_left check_one_body cst sig2
     
 and check_modtypes cst env mtb1 mtb2 equiv = 
-  if mtb1==mtb2 then (); (* just in case  :) *)
+  if mtb1==mtb2 then cst else (* just in case  :) *)
   let mtb1' = scrape_modtype env mtb1 in
   let mtb2' = scrape_modtype env mtb2 in
-    if mtb1'==mtb2' then ();
+    if mtb1'==mtb2' then cst else
     match mtb1', mtb2' with
       | MTBsig (msid1,list1), 
 	MTBsig (msid2,list2) -> 
@@ -257,15 +356,17 @@ and check_modtypes cst env mtb1 mtb2 equiv =
 	MTBfunsig (arg_id2,arg_t2,body_t2) ->
 	  let cst = check_modtypes cst env arg_t2 arg_t1 equiv in 
 	    (* contravariant *)
-	  let env' = 
+	  let env = 
 	    add_module (MPbound arg_id2) (module_body_of_type arg_t2) env 
 	  in
 	  let body_t1' = 
+            (* since we are just checking well-typedness we do not need
+               to expand any constant. Hence the identity resolver. *)
 	    subst_modtype 
-	      (map_mbid arg_id1 (MPbound arg_id2)) 
+              (map_mbid arg_id1 (MPbound arg_id2) None)
 	      body_t1
 	  in
-	  check_modtypes cst env' body_t1' body_t2 equiv
+	  check_modtypes cst env body_t1' body_t2 equiv
       | MTBident _ , _ -> anomaly "Subtyping: scrape failed"
       | _ , MTBident _ -> anomaly "Subtyping: scrape failed"
       | _ , _ -> error_incompatible_modtypes mtb1 mtb2
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index af09dafc..8bc25464 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: subtyping.mli,v 1.2.8.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: subtyping.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Univ
diff --git a/kernel/term.ml b/kernel/term.ml
index 30e73e4f..456a29e4 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term.ml,v 1.95.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+(* $Id: term.ml 9303 2006-10-27 21:50:17Z herbelin $ *)
 
-(* This module instanciates the structure of generic deBruijn terms to Coq *)
+(* This module instantiates the structure of generic deBruijn terms to Coq *)
 
 open Util
 open Pp
@@ -21,6 +21,8 @@ open Esubst
 type existential_key = int
 type metavariable = int
 
+(* This defines the strategy to use for verifiying a Cast *)
+
 (* This defines Cases annotations *)
 type pattern_source = DefaultPat of int | RegularPat
 type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle
@@ -31,6 +33,7 @@ type case_printing =
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
+    ci_cstr_nargs : int array; (* number of real args of each constructor *)
     ci_pp_info    : case_printing (* not interpreted by the kernel *)
   }
 
@@ -56,6 +59,8 @@ let family_of_sort = function
 (*       Constructions as implemented                               *)
 (********************************************************************)
 
+type cast_kind = VMcast | DEFAULTcast 
+
 (* [constr array] is an instance matching definitional [named_context] in
    the same order (i.e. last argument first) *)
 type 'constr pexistential = existential_key * 'constr array
@@ -74,7 +79,7 @@ type ('constr, 'types) kind_of_term =
   | Meta      of metavariable
   | Evar      of 'constr pexistential
   | Sort      of sorts
-  | Cast      of 'constr * 'types
+  | Cast      of 'constr * cast_kind * 'types
   | Prod      of name * 'types * 'types
   | Lambda    of name * 'types * 'constr
   | LetIn     of name * 'constr * 'types * 'constr
@@ -89,14 +94,14 @@ type ('constr, 'types) kind_of_term =
 (* Experimental *)
 type ('constr, 'types) kind_of_type =
   | SortType   of sorts
-  | CastType   of 'types * 'types
+  | CastType   of 'types * 'types 
   | ProdType   of name * 'types * 'types
   | LetInType  of name * 'constr * 'types * 'types
   | AtomicType of 'constr * 'constr array
 
 let kind_of_type = function
   | Sort s -> SortType s
-  | Cast (c,t) -> CastType (c, t)
+  | Cast (c,_,t) -> CastType (c, t)
   | Prod (na,t,c) -> ProdType (na, t, c)
   | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
   | App (c,l) -> AtomicType (c, l)
@@ -123,7 +128,7 @@ let comp_term t1 t2 =
   | Meta m1, Meta m2 -> m1 == m2
   | Var id1, Var id2 -> id1 == id2
   | Sort s1, Sort s2 -> s1 == s2
-  | Cast (c1,t1), Cast (c2,t2) -> c1 == c2 & t1 == t2
+  | Cast (c1,_,t1), Cast (c2,_,t2) -> c1 == c2 & t1 == t2
   | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
   | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
   | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
@@ -148,19 +153,19 @@ let comp_term t1 t2 =
       & array_for_all2 (==) bl1 bl2
   | _ -> false
 
-let hash_term (sh_rec,(sh_sort,sh_kn,sh_na,sh_id)) t =
+let hash_term (sh_rec,(sh_sort,sh_con,sh_kn,sh_na,sh_id)) t =
   match t with
   | Rel _ -> t
   | Meta x -> Meta x
   | Var x -> Var (sh_id x)
   | Sort s -> Sort (sh_sort s)
-  | Cast (c,t) -> Cast (sh_rec c, sh_rec t)
+  | Cast (c, k, t) -> Cast (sh_rec c, k, (sh_rec t))
   | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c)
   | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c)
   | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c)
   | App (c,l) -> App (sh_rec c, Array.map sh_rec l)
   | Evar (e,l) -> Evar (e, Array.map sh_rec l)
-  | Const c -> Const (sh_kn c)
+  | Const c -> Const (sh_con c)
   | Ind (kn,i) -> Ind (sh_kn kn,i)
   | Construct ((kn,i),j) -> Construct ((sh_kn kn,i),j)
   | Case (ci,p,c,bl) -> (* TO DO: extract ind_kn *)
@@ -179,15 +184,16 @@ module Hconstr =
     struct
       type t = constr
       type u = (constr -> constr) *
-               ((sorts -> sorts) * (kernel_name -> kernel_name)
-		* (name -> name) * (identifier -> identifier))
+               ((sorts -> sorts) * (constant -> constant) *
+               (kernel_name -> kernel_name) * (name -> name) *
+               (identifier -> identifier))
       let hash_sub = hash_term
       let equal = comp_term
       let hash = Hashtbl.hash
     end)
 
-let hcons_term (hsorts,hkn,hname,hident) =
-  Hashcons.recursive_hcons Hconstr.f (hsorts,hkn,hname,hident)
+let hcons_term (hsorts,hcon,hkn,hname,hident) =
+  Hashcons.recursive_hcons Hconstr.f (hsorts,hcon,hkn,hname,hident)
 
 (* Constructs a DeBrujin index with number n *)
 let rels =
@@ -206,11 +212,12 @@ let mkVar id = Var id
 let mkSort s = Sort s
 
 (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1) *)
-let mkCast (t1,t2) =
+(* (that means t2 is declared as the type of t1) 
+   [s] is the strategy to use when *)
+let mkCast (t1,k2,t2) =
   match t1 with
-    | Cast (t,_) -> Cast (t,t2)
-    | _ -> Cast (t1,t2)
+  | Cast (c,k1, _) when k1 = k2 -> Cast (c,k1,t2)
+  | _ -> Cast (t1,k2,t2)
 
 (* Constructs the product (x:t1)t2 *)
 let mkProd (x,t1,t2) = Prod (x,t1,t2)
@@ -225,7 +232,7 @@ let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
 (* We ensure applicative terms have at least one argument and the
    function is not itself an applicative term *)
 let mkApp (f, a) = 
-  if a=[||] then f else
+  if Array.length a = 0 then f else
     match f with
       | App (g, cl) -> App (g, Array.append cl a)
       | _ -> App (f, a)
@@ -309,22 +316,22 @@ let destSort c = match kind_of_term c with
 
 let rec isprop c = match kind_of_term c with
   | Sort (Prop _) -> true
-  | Cast (c,_) -> isprop c
+  | Cast (c,_,_) -> isprop c
   | _ -> false
 
 let rec is_Prop c = match kind_of_term c with
   | Sort (Prop Null) -> true
-  | Cast (c,_) -> is_Prop c
+  | Cast (c,_,_) -> is_Prop c
   | _ -> false
 
 let rec is_Set c = match kind_of_term c with
   | Sort (Prop Pos) -> true
-  | Cast (c,_) -> is_Set c
+  | Cast (c,_,_) -> is_Set c
   | _ -> false
 
 let rec is_Type c = match kind_of_term c with
   | Sort (Type _) -> true
-  | Cast (c,_) -> is_Type c
+  | Cast (c,_,_) -> is_Type c
   | _ -> false
 
 let isType = function
@@ -344,10 +351,11 @@ let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false
 
 (* Destructs a casted term *)
 let destCast c = match kind_of_term c with 
-  | Cast (t1, t2) -> (t1,t2)
+  | Cast (t1,k,t2) -> (t1,k,t2)
   | _ -> invalid_arg "destCast"
 
-let isCast c = match kind_of_term c with Cast (_,_) -> true | _ -> false
+let isCast c = match kind_of_term c with Cast _ -> true | _ -> false
+
 
 (* Tests if a de Bruijn index *)
 let isRel c = match kind_of_term c with Rel _ -> true | _ -> false
@@ -374,12 +382,16 @@ let destLetIn c = match kind_of_term c with
   | _ -> invalid_arg "destProd"
 
 (* Destructs an application *)
-let destApplication c = match kind_of_term c with
+let destApp c = match kind_of_term c with
   | App (f,a) -> (f, a)
   | _ -> invalid_arg "destApplication"
 
+let destApplication = destApp
+
 let isApp c = match kind_of_term c with App _ -> true | _ -> false
 
+let isProd c = match kind_of_term c with | Prod(_) -> true | _ -> false
+
 (* Destructs a constant *)
 let destConst c = match kind_of_term c with
   | Const kn -> kn
@@ -423,24 +435,41 @@ let destCoFix c = match kind_of_term c with
   | _ -> invalid_arg "destCoFix"
 
 (******************************************************************)
+(* Cast management                                                *)
+(******************************************************************)
+
+let rec strip_outer_cast c = match kind_of_term c with
+  | Cast (c,_,_) -> strip_outer_cast c
+  | _ -> c
+
+(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
+
+let under_outer_cast f c =  match kind_of_term c with
+  | Cast (b,k,t) -> mkCast (f b, k, f t)
+  | _ -> f c
+
+let rec under_casts f c = match kind_of_term c with
+  | Cast (c,k,t) -> mkCast (under_casts f c, k, t)
+  | _            -> f c
+
+(******************************************************************)
 (* Flattening and unflattening of embedded applications and casts *)
 (******************************************************************)
 
-(* flattens application lists *)
+(* flattens application lists throwing casts in-between *)
 let rec collapse_appl c = match kind_of_term c with
   | App (f,cl) -> 
-      let rec collapse_rec f cl2 = match kind_of_term f with
+      let rec collapse_rec f cl2 =
+        match kind_of_term (strip_outer_cast f) with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
-	| Cast (c,_) when isApp c -> collapse_rec c cl2
-	| _ -> if cl2 = [||] then f else mkApp (f,cl2)
-      in 
+	| _ -> mkApp (f,cl2)
+      in
       collapse_rec f cl
   | _ -> c
 
-let rec decompose_app c =
-  match kind_of_term (collapse_appl c) with
+let decompose_app c =
+  match kind_of_term c with
     | App (f,cl) -> (f, Array.to_list cl)
-    | Cast (c,t) -> decompose_app c
     | _ -> (c,[])
 
 (* strips head casts and flattens head applications *)
@@ -448,11 +477,11 @@ let rec strip_head_cast c = match kind_of_term c with
   | App (f,cl) -> 
       let rec collapse_rec f cl2 = match kind_of_term f with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
-	| Cast (c,_) -> collapse_rec c cl2
-	| _ -> if cl2 = [||] then f else mkApp (f,cl2)
+	| Cast (c,_,_) -> collapse_rec c cl2
+	| _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2)
       in 
       collapse_rec f cl
-  | Cast (c,t) -> strip_head_cast c
+  | Cast (c,_,_) -> strip_head_cast c
   | _ -> c
 
 (****************************************************************************)
@@ -466,7 +495,7 @@ let rec strip_head_cast c = match kind_of_term c with
 let fold_constr f acc c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> acc
-  | Cast (c,t) -> f (f acc c) t
+  | Cast (c,_,t) -> f (f acc c) t
   | Prod (_,t,c) -> f (f acc t) c
   | Lambda (_,t,c) -> f (f acc t) c
   | LetIn (_,b,t,c) -> f (f (f acc b) t) c
@@ -487,7 +516,7 @@ let fold_constr f acc c = match kind_of_term c with
 let iter_constr f c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> ()
-  | Cast (c,t) -> f c; f t
+  | Cast (c,_,t) -> f c; f t
   | Prod (_,t,c) -> f t; f c
   | Lambda (_,t,c) -> f t; f c
   | LetIn (_,b,t,c) -> f b; f t; f c
@@ -506,7 +535,7 @@ let iter_constr f c = match kind_of_term c with
 let iter_constr_with_binders g f n c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> ()
-  | Cast (c,t) -> f n c; f n t
+  | Cast (c,_,t) -> f n c; f n t
   | Prod (_,t,c) -> f n t; f (g n) c
   | Lambda (_,t,c) -> f n t; f (g n) c
   | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
@@ -527,7 +556,7 @@ let iter_constr_with_binders g f n c = match kind_of_term c with
 let map_constr f c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> c
-  | Cast (c,t) -> mkCast (f c, f t)
+  | Cast (c,k,t) -> mkCast (f c, k, f t)
   | Prod (na,t,c) -> mkProd (na, f t, f c)
   | Lambda (na,t,c) -> mkLambda (na, f t, f c)
   | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c)
@@ -548,7 +577,7 @@ let map_constr f c = match kind_of_term c with
 let map_constr_with_binders g f l c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> c
-  | Cast (c,t) -> mkCast (f l c, f l t)
+  | Cast (c,k,t) -> mkCast (f l c, k, f l t)
   | Prod (na,t,c) -> mkProd (na, f l t, f (g l) c)
   | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c)
   | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c)
@@ -573,8 +602,8 @@ let compare_constr f t1 t2 =
   | Meta m1, Meta m2 -> m1 = m2
   | Var id1, Var id2 -> id1 = id2
   | Sort s1, Sort s2 -> s1 = s2
-  | Cast (c1,_), _ -> f c1 t2
-  | _, Cast (c2,_) -> f t1 c2
+  | Cast (c1,_,_), _ -> f c1 t2
+  | _, Cast (c2,_,_) -> f t1 c2
   | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2
   | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2
   | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2
@@ -605,6 +634,8 @@ let compare_constr f t1 t2 =
 
 type types = constr
 
+type strategy = types option 
+
 let type_app f tt = f tt
 
 let body_of_type ty = ty
@@ -612,9 +643,12 @@ let body_of_type ty = ty
 type named_declaration = identifier * constr option * types
 type rel_declaration = name * constr option * types
 
-let map_named_declaration f (id, v, ty) = (id, option_app f v, f ty)
+let map_named_declaration f (id, v, ty) = (id, option_map f v, f ty)
 let map_rel_declaration = map_named_declaration
 
+let fold_named_declaration f (_, v, ty) a = f ty (option_fold_right f v a)
+let fold_rel_declaration = fold_named_declaration
+
 (****************************************************************************)
 (*              Functions for dealing with constr terms                     *)
 (****************************************************************************)
@@ -628,17 +662,16 @@ exception LocalOccur
 (* (closedn n M) raises FreeVar if a variable of height greater than n
    occurs in M, returns () otherwise *)
 
-let closedn = 
+let closedn n c = 
   let rec closed_rec n c = match kind_of_term c with
     | Rel m -> if m>n then raise LocalOccur
     | _ -> iter_constr_with_binders succ closed_rec n c
   in 
-  closed_rec
+  try closed_rec n c; true with LocalOccur -> false
 
 (* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
 
-let closed0 term =
-  try closedn 0 term; true with LocalOccur -> false
+let closed0 = closedn 0
 
 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
 
@@ -671,7 +704,7 @@ let noccur_with_meta n m term =
     | Rel p -> if n<=p & p<n+m then raise LocalOccur
     | App(f,cl) ->
 	(match kind_of_term f with
-           | Cast (c,_) when isMeta c -> ()
+           | Cast (c,_,_) when isMeta c -> ()
            | Meta _ -> ()
 	   | _ -> iter_constr_with_binders succ occur_rec n c)
     | Evar (_, _) -> ()
@@ -721,36 +754,34 @@ let rec lift_substituend depth s =
 
 let make_substituend c = { sinfo=Unknown; sit=c }
 
-let substn_many lamv n =
+let substn_many lamv n c =
   let lv = Array.length lamv in 
-  let rec substrec depth c = match kind_of_term c with
-    | Rel k     ->
-        if k<=depth then 
-	  c
-        else if k-depth <= lv then
-          lift_substituend depth lamv.(k-depth-1)
-        else 
-	  mkRel (k-lv)
-    | _ -> map_constr_with_binders succ substrec depth c
-  in 
-  substrec n
+  if lv = 0 then c
+  else 
+    let rec substrec depth c = match kind_of_term c with
+      | Rel k     ->
+          if k<=depth then c
+          else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1)
+          else mkRel (k-lv)
+      | _ -> map_constr_with_binders succ substrec depth c in 
+    substrec n c
 
 (*
 let substkey = Profile.declare_profile "substn_many";;
 let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;;
 *)
 
-let substnl laml k =
-  substn_many (Array.map make_substituend (Array.of_list laml)) k
-let substl laml =
-  substn_many (Array.map make_substituend (Array.of_list laml)) 0
+let substnl laml n =
+  substn_many (Array.map make_substituend (Array.of_list laml)) n
+let substl laml = substnl laml 0
 let subst1 lam = substl [lam]
 
-let substl_decl laml (id,bodyopt,typ as d) =
-  match bodyopt with
-    | None -> (id,None,substl laml typ)
-    | Some body -> (id, Some (substl laml body), type_app (substl laml) typ)
+let substnl_decl laml k (id,bodyopt,typ) =
+  (id,option_map (substnl laml k) bodyopt,substnl laml k typ)
+let substl_decl laml = substnl_decl laml 0
 let subst1_decl lam = substl_decl [lam]
+let subst1_named_decl = subst1_decl
+let substl_named_decl = substl_decl
 
 (* (thin_val sigma) removes identity substitutions from sigma *)
 
@@ -789,32 +820,6 @@ let substn_vars p vars =
 
 let subst_vars = substn_vars 1
 
-(* 
-map_kn : (kernel_name -> kernel_name) -> constr -> constr
-
-This should be rewritten to prevent duplication of constr's when not
-necessary.
-For now, it uses map_constr and is rather ineffective
-*)
-
-let rec map_kn f c = 
-  let func = map_kn f in
-    match kind_of_term c with
-      | Const kn -> 
-	  mkConst (f kn)
-      | Ind (kn,i) -> 
-	  mkInd (f kn,i)
-      | Construct ((kn,i),j) -> 
-	  mkConstruct ((f kn,i),j)
-      | Case (ci,p,c,l) ->
-	  let ci' = { ci with ci_ind = let (kn,i) = ci.ci_ind in f kn, i } in
-	  mkCase (ci', func p, func c, array_smartmap func l) 
-      | _ -> map_constr func c
-
-let subst_mps sub = 
-  map_kn (subst_kn sub)
-
-
 (*********************)
 (* Term constructors *)
 (*********************)
@@ -965,20 +970,6 @@ let mkCoFix = mkCoFix
 let implicit_sort = Type (make_univ(make_dirpath[id_of_string"implicit"],0))
 let mkImplicit = mkSort implicit_sort
 
-let rec strip_outer_cast c = match kind_of_term c with
-  | Cast (c,_) -> strip_outer_cast c
-  | _ -> c
-
-(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
-
-let under_outer_cast f c =  match kind_of_term c with
-  | Cast (b,t) -> mkCast (f b,f t)
-  | _ -> f c
-
-let rec under_casts f c = match kind_of_term c with
-  | Cast (c,t) -> mkCast (under_casts f c, t)
-  | _            -> f c
-
 (***************************)
 (* Other term constructors *)
 (***************************)
@@ -1027,7 +1018,7 @@ let rec to_lambda n prod =
   else 
     match kind_of_term prod with 
       | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd)
-      | Cast (c,_) -> to_lambda n c
+      | Cast (c,_,_) -> to_lambda n c
       | _   -> errorlabstrm "to_lambda" (mt ())                      
 
 let rec to_prod n lam =
@@ -1036,7 +1027,7 @@ let rec to_prod n lam =
   else   
     match kind_of_term lam with 
       | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd)
-      | Cast (c,_) -> to_prod n c
+      | Cast (c,_,_) -> to_prod n c
       | _   -> errorlabstrm "to_prod" (mt ())                      
 	    
 (* pseudo-reduction rule:
@@ -1066,7 +1057,7 @@ let prod_applist t nL = List.fold_left prod_app t nL
 let decompose_prod = 
   let rec prodec_rec l c = match kind_of_term c with
     | Prod (x,t,c) -> prodec_rec ((x,t)::l) c
-    | Cast (c,_)   -> prodec_rec l c
+    | Cast (c,_,_)   -> prodec_rec l c
     | _              -> l,c
   in 
   prodec_rec []
@@ -1076,7 +1067,7 @@ let decompose_prod =
 let decompose_lam = 
   let rec lamdec_rec l c = match kind_of_term c with
     | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c
-    | Cast (c,_)     -> lamdec_rec l c
+    | Cast (c,_,_)     -> lamdec_rec l c
     | _                -> l,c
   in 
   lamdec_rec []
@@ -1089,7 +1080,7 @@ let decompose_prod_n n =
     if n=0 then l,c 
     else match kind_of_term c with 
       | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c
-      | Cast (c,_)   -> prodec_rec l n c
+      | Cast (c,_,_)   -> prodec_rec l n c
       | _ -> error "decompose_prod_n: not enough products"
   in 
   prodec_rec [] n 
@@ -1102,7 +1093,7 @@ let decompose_lam_n n =
     if n=0 then l,c 
     else match kind_of_term c with 
       | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
-      | Cast (c,_)     -> lamdec_rec l n c
+      | Cast (c,_,_)     -> lamdec_rec l n c
       | _ -> error "decompose_lam_n: not enough abstractions"
   in 
   lamdec_rec [] n 
@@ -1112,7 +1103,7 @@ let decompose_lam_n n =
 let nb_lam = 
   let rec nbrec n c = match kind_of_term c with
     | Lambda (_,_,c) -> nbrec (n+1) c
-    | Cast (c,_) -> nbrec n c
+    | Cast (c,_,_) -> nbrec n c
     | _ -> n
   in 
   nbrec 0
@@ -1121,7 +1112,7 @@ let nb_lam =
 let nb_prod = 
   let rec nbrec n c = match kind_of_term c with
     | Prod (_,_,c) -> nbrec (n+1) c
-    | Cast (c,_) -> nbrec n c
+    | Cast (c,_,_) -> nbrec n c
     | _ -> n
   in 
   nbrec 0
@@ -1137,6 +1128,7 @@ let nb_prod =
 let rec eq_constr m n = 
   (m==n) or
   compare_constr eq_constr m n
+
 let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
 
 (*******************)
@@ -1177,10 +1169,18 @@ module Hsorts =
 
 let hsort = Hsorts.f
 
-let hcons_constr (hkn,hdir,hname,hident,hstr) =
+let hcons_constr (hcon,hkn,hdir,hname,hident,hstr) =
   let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in
-  let hcci = hcons_term (hsortscci,hkn,hname,hident) in
+  let hcci = hcons_term (hsortscci,hcon,hkn,hname,hident) in
   let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in
   (hcci,htcci)
 
 let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names())
+
+
+(*******)
+(* Type of abstract machine values *)
+type values
+
+
+
diff --git a/kernel/term.mli b/kernel/term.mli
index a5e5c081..d6244f5b 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -6,12 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term.mli,v 1.101.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+(*i $Id: term.mli 9303 2006-10-27 21:50:17Z herbelin $ i*)
 
 (*i*)
 open Names
 (*i*)
 
+
 (*s The sorts of CCI. *)
 
 type contents = Pos | Null
@@ -49,6 +50,7 @@ type case_printing =
 type case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
+    ci_cstr_nargs : int array; (* number of real args of each constructor *)
     ci_pp_info    : case_printing (* not interpreted by the kernel *)
   }
 
@@ -99,9 +101,13 @@ val mkProp : types
 val mkSet  : types
 val mkType : Univ.universe -> types
 
+
+(* This defines the strategy to use for verifiying a Cast *)
+type cast_kind = VMcast | DEFAULTcast 
+
 (* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the 
    type $t_2$ (that means t2 is declared as the type of t1). *)
-val mkCast : constr * types -> constr
+val mkCast : constr * cast_kind * constr -> constr
 
 (* Constructs the product [(x:t1)t2] *)
 val mkProd : name * types * types -> types
@@ -192,7 +198,7 @@ type ('constr, 'types) kind_of_term =
   | Meta      of metavariable
   | Evar      of 'constr pexistential
   | Sort      of sorts
-  | Cast      of 'constr * 'types
+  | Cast      of 'constr * cast_kind * 'types
   | Prod      of name * 'types * 'types
   | Lambda    of name * 'types * 'constr
   | LetIn     of name * 'constr * 'types * 'constr
@@ -213,7 +219,7 @@ val kind_of_term : constr -> (constr, types) kind_of_term
 (* Experimental *)
 type ('constr, 'types) kind_of_type =
   | SortType   of sorts
-  | CastType   of 'types * 'types
+  | CastType   of 'types * 'types 
   | ProdType   of name * 'types * 'types
   | LetInType  of name * 'constr * 'types * 'types
   | AtomicType of 'constr * 'constr array
@@ -230,6 +236,7 @@ val isMeta : constr -> bool
 val isSort : constr -> bool
 val isCast : constr -> bool
 val isApp : constr -> bool
+val isProd : constr -> bool
 val isConst : constr -> bool
 val isConstruct : constr -> bool
 
@@ -258,7 +265,7 @@ val destVar : constr -> identifier
 val destSort : constr -> sorts
 
 (* Destructs a casted term *)
-val destCast : constr -> constr * types
+val destCast : constr -> constr * cast_kind * constr
 
 (* Destructs the product $(x:t_1)t_2$ *)
 val destProd : types -> name * types * types
@@ -270,8 +277,12 @@ val destLambda : constr -> name * types * constr
 val destLetIn : constr -> name * constr * types * constr
 
 (* Destructs an application *)
+val destApp : constr -> constr * constr array
+
+(* Obsolete synonym of destApp *)
 val destApplication : constr -> constr * constr array
-(* ... removing casts *)
+
+(* Decompose any term as an applicative term; the list of args can be empty *)
 val decompose_app : constr -> constr * constr list
 
 (* Destructs a constant *)
@@ -316,6 +327,11 @@ val map_named_declaration :
 val map_rel_declaration :
   (constr -> constr) -> rel_declaration -> rel_declaration
 
+val fold_named_declaration :
+  (constr -> 'a -> 'a) -> named_declaration -> 'a -> 'a
+val fold_rel_declaration :
+  (constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
+
 (* Constructs either [(x:t)c] or [[x=b:t]c] *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
 val mkNamedProd_or_LetIn : named_declaration -> types -> types
@@ -410,8 +426,14 @@ val strip_outer_cast : constr -> constr
 (* Apply a function letting Casted types in place *)
 val under_casts : (constr -> constr) -> constr -> constr
 
+(* Apply a function under components of Cast if any *)
+val under_outer_cast : (constr -> constr) -> constr -> constr
+
 (*s Occur checks *)
 
+(* [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
+val closedn : int -> constr -> bool
+
 (* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
 val closed0 : constr -> bool
 
@@ -446,8 +468,12 @@ val substnl : constr list -> int -> constr -> constr
 val substl : constr list -> constr -> constr
 val subst1 : constr -> constr -> constr
 
-val substl_decl : constr list -> named_declaration -> named_declaration
-val subst1_decl : constr -> named_declaration -> named_declaration
+val substnl_decl : constr list -> int -> rel_declaration -> rel_declaration
+val substl_decl : constr list -> rel_declaration -> rel_declaration
+val subst1_decl : constr -> rel_declaration -> rel_declaration
+
+val subst1_named_decl : constr -> named_declaration -> named_declaration
+val substl_named_decl : constr list -> named_declaration -> named_declaration
 
 val replace_vars : (identifier * constr) list -> constr -> constr
 val subst_var : identifier -> constr -> constr
@@ -460,11 +486,6 @@ val subst_vars : identifier list -> constr -> constr
 val substn_vars : int -> identifier list -> constr -> constr
 
 
-(* [subst_mps sub c] performs the substitution [sub] on all kernel
-   names appearing in [c] *)
-val subst_mps : substitution -> constr -> constr
-
-
 (*s Functionals working on the immediate subterm of a construction *)
 
 (* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
@@ -512,6 +533,7 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
 (*********************************************************************)
 
 val hcons_constr:
+  (constant -> constant) *
   (kernel_name -> kernel_name) *
   (dir_path -> dir_path) *
   (name -> name) *
@@ -523,3 +545,7 @@ val hcons_constr:
 
 val hcons1_constr : constr -> constr
 val hcons1_types : types -> types
+
+(**************************************)
+
+type values
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 5347583f..575330a4 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: term_typing.ml,v 1.5.6.1 2004/07/16 19:30:27 herbelin Exp $ *)
+(* $Id: term_typing.ml 9323 2006-10-30 23:05:29Z herbelin $ *)
 
 open Util
 open Names
@@ -23,22 +23,29 @@ open Indtypes
 open Typeops
 
 let constrain_type env j cst1 = function
-  | None -> j.uj_type, cst1
+  | None ->
+(* To have definitions in Type polymorphic
+      make_polymorphic_if_arity env j.uj_type, cst1
+*) 
+      NonPolymorphicType j.uj_type, cst1
   | Some t -> 
       let (tj,cst2) = infer_type env t in
-      let cst3 =
-	try conv_leq env j.uj_type tj.utj_val
-	with NotConvertible -> error_actual_type env j tj.utj_val in
-      let typ = 
-        if t = tj.utj_val then t else
-          (error "Kernel built a type different from its input\n";
-           flush stdout; tj.utj_val) in
-      typ, Constraint.union (Constraint.union cst1 cst2) cst3
+      let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
+      assert (t = tj.utj_val);
+      NonPolymorphicType t, Constraint.union (Constraint.union cst1 cst2) cst3
 
+let local_constrain_type env j cst1 = function
+  | None ->
+      j.uj_type, cst1
+  | Some t -> 
+      let (tj,cst2) = infer_type env t in
+      let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
+      assert (t = tj.utj_val);
+      t, Constraint.union (Constraint.union cst1 cst2) cst3
 
 let translate_local_def env (b,topt) =
   let (j,cst) = infer env b in
-  let (typ,cst) = constrain_type env j cst topt in
+  let (typ,cst) = local_constrain_type env j cst topt in
     (j.uj_val,typ,cst)
 
 let translate_local_assum env t =
@@ -85,33 +92,47 @@ let infer_declaration env dcl =
   | DefinitionEntry c ->
       let (j,cst) = infer env c.const_entry_body in
       let (typ,cst) = constrain_type env j cst c.const_entry_type in
-      Some (Declarations.from_val j.uj_val), typ, cst, c.const_entry_opaque
+      Some (Declarations.from_val j.uj_val), typ, cst,
+        c.const_entry_opaque, c.const_entry_boxed
   | ParameterEntry t ->
       let (j,cst) = infer env t in
-      None, Typeops.assumption_of_judgment env j, cst, false
-
-let build_constant_declaration env (body,typ,cst,op) =
-  let ids = match body with 
-    | None -> global_vars_set env typ
+      None, NonPolymorphicType (Typeops.assumption_of_judgment env j), cst,
+        false, false
+
+let global_vars_set_constant_type env = function
+  | NonPolymorphicType t -> global_vars_set env t
+  | PolymorphicArity (ctx,_) ->
+      Sign.fold_rel_context 
+        (fold_rel_declaration
+	  (fun t c -> Idset.union (global_vars_set env t) c))
+      ctx ~init:Idset.empty
+
+let build_constant_declaration env kn (body,typ,cst,op,boxed) =
+  let ids =
+    match body with 
+    | None -> global_vars_set_constant_type env typ
     | Some b ->
         Idset.union 
 	  (global_vars_set env (Declarations.force b)) 
-	  (global_vars_set env typ) 
+	  (global_vars_set_constant_type env typ)
   in
+  let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in
   let hyps = keep_hyps env ids in
-    { const_body = body;
+    { const_hyps = hyps;
+      const_body = body;
       const_type = typ;
-      const_hyps = hyps;
+      const_body_code = tps;
+     (* const_type_code = to_patch env typ;*)
       const_constraints = cst;
       const_opaque = op }
 
 (*s Global and local constant declaration. *)
 
-let translate_constant env ce =
-  build_constant_declaration env (infer_declaration env ce)
+let translate_constant env kn ce =
+  build_constant_declaration env kn (infer_declaration env ce)
 
-let translate_recipe env r = 
-  build_constant_declaration env (Cooking.cook_constant env r)
+let translate_recipe env kn r = 
+  build_constant_declaration env kn (Cooking.cook_constant env r)
 
 (* Insertion of inductive types. *)
 
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index 67d479ba..c102d01b 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term_typing.mli,v 1.2.8.1 2004/07/16 19:30:27 herbelin Exp $ i*)
+(*i $Id: term_typing.mli 9310 2006-10-28 19:35:09Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -25,10 +25,17 @@ val translate_local_def : env -> constr * types option ->
 val translate_local_assum : env -> types ->
   types * Univ.constraints
 
-val translate_constant : env -> constant_entry -> constant_body
+val infer_declaration : env -> constant_entry -> 
+   constr_substituted option * constant_type * constraints * bool * bool
+
+val build_constant_declaration : env -> 'a ->
+    constr_substituted option * constant_type * constraints * bool * bool ->
+      constant_body
+
+val translate_constant : env -> constant -> constant_entry -> constant_body
 
 val translate_mind : 
   env -> mutual_inductive_entry -> mutual_inductive_body
 
 val translate_recipe : 
-  env -> Cooking.recipe -> constant_body
+  env -> constant -> Cooking.recipe -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index c3d4726f..87de6698 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: type_errors.ml,v 1.31.2.1 2004/07/16 19:30:27 herbelin Exp $ *)
+(* $Id: type_errors.ml 8845 2006-05-23 07:41:58Z herbelin $ *)
 
 open Names
 open Term
@@ -19,7 +19,7 @@ open Reduction
 type guard_error =
   (* Fixpoints *)
   | NotEnoughAbstractionInFixBody
-  | RecursionNotOnInductiveType
+  | RecursionNotOnInductiveType of constr
   | RecursionOnIllegalTerm of int * constr * int list * int list
   | NotEnoughArgumentsForFixCall of int
   (* CoFixpoints *)
@@ -45,8 +45,8 @@ type type_error =
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
   | ReferenceVariables of constr
-  | ElimArity of inductive * types list * constr * unsafe_judgment
-      * (constr * constr * arity_error) option
+  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+      * (sorts_family * sorts_family * arity_error) option
   | CaseNotInductive of unsafe_judgment
   | WrongCaseInfo of inductive * case_info
   | NumberBranches of unsafe_judgment * int
@@ -103,7 +103,7 @@ let error_cant_apply_not_functional env rator randl =
   raise (TypeError (env, CantApplyNonFunctional (rator,randl)))
 
 let error_cant_apply_bad_type env t rator randl =
-  raise(TypeError (env, CantApplyBadType (t,rator,randl)))
+  raise (TypeError (env, CantApplyBadType (t,rator,randl)))
 
 let error_ill_formed_rec_body env why lna i =
   raise (TypeError (env, IllFormedRecBody (why,lna,i)))
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 2e8a7138..138c313c 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: type_errors.mli,v 1.36.2.1 2004/07/16 19:30:27 herbelin Exp $ i*)
+(*i $Id: type_errors.mli 8845 2006-05-23 07:41:58Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -21,7 +21,7 @@ open Environ
 type guard_error =
   (* Fixpoints *)
   | NotEnoughAbstractionInFixBody
-  | RecursionNotOnInductiveType
+  | RecursionNotOnInductiveType of constr
   | RecursionOnIllegalTerm of int * constr * int list * int list
   | NotEnoughArgumentsForFixCall of int
   (* CoFixpoints *)
@@ -47,8 +47,8 @@ type type_error =
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
   | ReferenceVariables of constr
-  | ElimArity of inductive * types list * constr * unsafe_judgment
-      * (constr * constr * arity_error) option
+  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+      * (sorts_family * sorts_family * arity_error) option
   | CaseNotInductive of unsafe_judgment
   | WrongCaseInfo of inductive * case_info
   | NumberBranches of unsafe_judgment * int
@@ -75,8 +75,8 @@ val error_assumption : env -> unsafe_judgment -> 'a
 val error_reference_variables : env -> constr -> 'a
 
 val error_elim_arity : 
-  env -> inductive -> types list -> constr 
-    -> unsafe_judgment -> (constr * constr * arity_error) option -> 'a
+  env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> 
+      (sorts_family * sorts_family * arity_error) option -> 'a
 
 val error_case_not_inductive : env -> unsafe_judgment -> 'a
 
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 66b2e24d..2a0dd526 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typeops.ml,v 1.89.2.1 2004/07/16 19:30:28 herbelin Exp $ *)
+(* $Id: typeops.ml 9314 2006-10-29 20:11:08Z herbelin $ *)
 
 open Util
 open Names
@@ -19,11 +19,24 @@ open Entries
 open Reduction
 open Inductive
 open Type_errors
-
+  
+let conv = default_conv CONV
+let conv_leq = default_conv CUMUL
+
+let conv_leq_vecti env v1 v2 =
+  array_fold_left2_i 
+    (fun i c t1 t2 ->
+      let c' =
+        try default_conv CUMUL env t1 t2 
+        with NotConvertible -> raise (NotConvertibleVect i) in
+      Constraint.union c c')
+    Constraint.empty
+    v1
+    v2
 
 (* This should be a type (a priori without intension to be an assumption) *)
 let type_judgment env j =
-  match kind_of_term(whd_betadeltaiota env (body_of_type j.uj_type)) with
+  match kind_of_term(whd_betadeltaiota env j.uj_type) with
     | Sort s -> {utj_val = j.uj_val; utj_type = s }
     | _ -> error_not_type env j
 
@@ -34,11 +47,7 @@ let assumption_of_judgment env j =
   with TypeError _ ->
     error_assumption env j
 
-(*
-let aojkey = Profile.declare_profile "assumption_of_judgment";;
-let assumption_of_judgment env j
-  = Profile.profile2 aojkey assumption_of_judgment env j;;
-*)
+let sort_judgment env j = (type_judgment env j).utj_type
 
 (************************************************)
 (* Incremental typing rules: builds a typing judgement given the *)
@@ -49,11 +58,11 @@ let assumption_of_judgment env j
 (* Prop and Set *)
 
 let judge_of_prop =
-  { uj_val = body_of_type mkProp;
+  { uj_val = mkProp;
     uj_type = mkSort type_0 }
 
 let judge_of_set =
-  { uj_val = body_of_type mkSet;
+  { uj_val = mkSet;
     uj_type = mkSort type_0 }
 
 let judge_of_prop_contents = function
@@ -64,7 +73,7 @@ let judge_of_prop_contents = function
 
 let judge_of_type u =
   let uu = super u in
-  { uj_val = body_of_type (mkType u);
+  { uj_val = mkType u;
     uj_type = mkType uu }
 
 (*s Type of a de Bruijn index. *)
@@ -77,30 +86,23 @@ let judge_of_relative env n =
   with Not_found -> 
     error_unbound_rel env n
 
-(*
-let relativekey = Profile.declare_profile "judge_of_relative";;
-let judge_of_relative env n =
-  Profile.profile2 relativekey judge_of_relative env n;;
-*)
-
 (* Type of variables *)
 let judge_of_variable env id =
   try
-    let (_,_,ty) = lookup_named id env in
+    let ty = named_type id env in
     make_judge (mkVar id) ty
   with Not_found -> 
     error_unbound_var env id
 
 (* Management of context of variables. *)
 
-(* Checks if a context of variable can be instanciated by the
+(* Checks if a context of variable can be instantiated by the
    variables of the current env *)
 (* TODO: check order? *)
 let rec check_hyps_inclusion env sign =
-  let env_sign = named_context env in
   Sign.fold_named_context
     (fun (id,_,ty1) () ->
-      let (_,_,ty2) = Sign.lookup_named id env_sign in
+      let ty2 = named_type id env in
       if not (eq_constr ty2 ty1) then
         error "types do not match")
     sign
@@ -108,7 +110,6 @@ let rec check_hyps_inclusion env sign =
 
 
 let check_args env c hyps =
-  let hyps' = named_context env in
   try check_hyps_inclusion env hyps
   with UserError _ | Not_found ->
     error_reference_variables env c
@@ -124,19 +125,52 @@ let check_hyps id env hyps =
 *)
 (* Instantiation of terms on real arguments. *)
 
+(* Make a type polymorphic if an arity *)
+
+let extract_level env p =
+  let _,c = dest_prod_assum env p in
+  match kind_of_term c with Sort (Type u) -> Some u | _ -> None
+
+let extract_context_levels env =
+  List.fold_left
+    (fun l (_,b,p) -> if b=None then extract_level env p::l else l) []
+
+let make_polymorphic_if_arity env t =
+  let params, ccl = dest_prod_assum env t in
+  match kind_of_term ccl with
+  | Sort (Type u) -> 
+      let param_ccls = extract_context_levels env params in
+      let s = { poly_param_levels = param_ccls; poly_level = u} in
+      PolymorphicArity (params,s)
+  | _ ->
+      NonPolymorphicType t
+
 (* Type of constants *)
-let judge_of_constant env cst =
-  let constr = mkConst cst in
-  let _ =
-    let ce = lookup_constant cst env in
-    check_args env constr ce.const_hyps in 
-  make_judge constr (constant_type env cst)
 
-(*
-let tockey = Profile.declare_profile "type_of_constant";;
-let type_of_constant env c 
-  = Profile.profile3 tockey type_of_constant env c;;
-*)
+let type_of_constant_knowing_parameters env t paramtyps =
+  match t with
+  | NonPolymorphicType t -> t
+  | PolymorphicArity (sign,ar) ->
+      let ctx = List.rev sign in
+      let ctx,s = instantiate_universes env ctx ar paramtyps in
+      mkArity (List.rev ctx,s)
+
+let type_of_constant_type env t =
+  type_of_constant_knowing_parameters env t [||]
+
+let type_of_constant env cst =
+  type_of_constant_type env (constant_type env cst)
+
+let judge_of_constant_knowing_parameters env cst jl =
+  let c = mkConst cst in
+  let cb = lookup_constant cst env in
+  let _ = check_args env c cb.const_hyps in 
+  let paramstyp = Array.map (fun j -> j.uj_type) jl in
+  let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in
+  make_judge c t
+
+let judge_of_constant env cst =
+  judge_of_constant_knowing_parameters env cst [||]
 
 (* Type of a lambda-abstraction. *)
 
@@ -203,9 +237,11 @@ let sort_of_product env domsort rangsort =
           rangsort
         else
           (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
-          domsort
+          Type (sup u1 base_univ)
     (* Product rule (Prop,Type_i,Type_i) *)
-    | (Prop _,  Type _)  -> rangsort
+    | (Prop Pos,  Type u2)  -> Type (sup base_univ u2)
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop Null, Type _)  -> rangsort
     (* Product rule (Type_i,Type_i,Type_i) *) 
     | (Type u1, Type u2) -> Type (sup u1 u2)
 
@@ -231,11 +267,14 @@ let judge_of_product env name t1 t2 =
          env |- c:typ2
 *)
 
-let judge_of_cast env cj tj =
+let judge_of_cast env cj k tj =
   let expected_type = tj.utj_val in
   try 
-    let cst = conv_leq env cj.uj_type expected_type in
-    { uj_val = mkCast (j_val cj, expected_type);
+    let cst = 
+      match k with
+      | VMcast -> vm_conv CUMUL env cj.uj_type expected_type
+      | DEFAULTcast -> conv_leq env cj.uj_type expected_type in
+    { uj_val = mkCast (cj.uj_val, k, expected_type);
       uj_type = expected_type },
     cst
   with NotConvertible ->
@@ -243,19 +282,28 @@ let judge_of_cast env cj tj =
 
 (* Inductive types. *)
 
-let judge_of_inductive env i =
-  let constr = mkInd i in
-  let _ =
-    let (kn,_) = i in
-    let mib = lookup_mind kn env in
-    check_args env constr mib.mind_hyps in 
-  make_judge constr (type_of_inductive env i)
-
-(*
-let toikey = Profile.declare_profile "judge_of_inductive";;
-let judge_of_inductive env i
-  = Profile.profile2 toikey judge_of_inductive env i;;
-*)
+(* The type is parametric over the uniform parameters whose conclusion
+   is in Type; to enforce the internal constraints between the
+   parameters and the instances of Type occurring in the type of the
+   constructors, we use the level variables _statically_ assigned to
+   the conclusions of the parameters as mediators: e.g. if a parameter
+   has conclusion Type(alpha), static constraints of the form alpha<=v
+   exist between alpha and the Type's occurring in the constructor
+   types; when the parameters is finally instantiated by a term of
+   conclusion Type(u), then the constraints u<=alpha is computed in
+   the App case of execute; from this constraints, the expected
+   dynamic constraints of the form u<=v are enforced *)
+
+let judge_of_inductive_knowing_parameters env ind jl =
+  let c = mkInd ind in
+  let (mib,mip) = lookup_mind_specif env ind in
+  check_args env c mib.mind_hyps;
+  let paramstyp = Array.map (fun j -> j.uj_type) jl in
+  let t = Inductive.type_of_inductive_knowing_parameters env mip paramstyp in
+  make_judge c t
+
+let judge_of_inductive env ind =
+  judge_of_inductive_knowing_parameters env ind [||]
 
 (* Constructors. *)
 
@@ -265,21 +313,16 @@ let judge_of_constructor env c =
     let ((kn,_),_) = c in
     let mib = lookup_mind kn env in
     check_args env constr mib.mind_hyps in 
-  make_judge constr (type_of_constructor env c)
-
-(*
-let tockey = Profile.declare_profile "judge_of_constructor";;
-let judge_of_constructor env cstr
-  = Profile.profile2 tockey judge_of_constructor env cstr;;
-*)
+  let specif = lookup_mind_specif env (inductive_of_constructor c) in
+  make_judge constr (type_of_constructor c specif)
 
 (* Case. *)
 
-let check_branch_types env cj (lft,explft) = 
-  try conv_leq_vecti env lft explft
+let check_branch_types env cj (lfj,explft) = 
+  try conv_leq_vecti env (Array.map j_type lfj) explft
   with
       NotConvertibleVect i ->
-        error_ill_formed_branch env cj.uj_val i lft.(i) explft.(i)
+        error_ill_formed_branch env cj.uj_val i lfj.(i).uj_type explft.(i)
     | Invalid_argument _ ->
         error_number_branches env cj (Array.length explft)
 
@@ -290,20 +333,12 @@ let judge_of_case env ci pj cj lfj =
   let _ = check_case_info env (fst indspec) ci in
   let (bty,rslty,univ) =
     type_case_branches env indspec pj cj.uj_val in
-  let (_,kind) = dest_arity env pj.uj_type in
-  let lft = Array.map j_type lfj in
-  let univ' = check_branch_types env cj (lft,bty) in
+  let univ' = check_branch_types env cj (lfj,bty) in
   ({ uj_val  = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val,
                        Array.map j_val lfj);
      uj_type = rslty },
   Constraint.union univ univ')
 
-(*
-let tocasekey = Profile.declare_profile "judge_of_case";;
-let judge_of_case env ci pj cj lfj
-  = Profile.profile6 tocasekey judge_of_case env ci pj cj lfj;;
-*)
-
 (* Fixpoints. *)
 
 (* Checks the type of a general (co)fixpoint, i.e. without checking *)
@@ -313,9 +348,7 @@ let type_fixpoint env lna lar vdefj =
   let lt = Array.length vdefj in
   assert (Array.length lar = lt);
   try
-    conv_leq_vecti env
-      (Array.map (fun j -> body_of_type j.uj_type) vdefj)
-      (Array.map (fun ty -> lift lt ty) lar)
+    conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar)
   with NotConvertibleVect i ->
     error_ill_typed_rec_body env i lna vdefj lar
 
@@ -352,10 +385,20 @@ let rec execute env cstr cu =
 
     (* Lambda calculus operators *)
     | App (f,args) ->
-	let (j,cu1) = execute env f cu in
-        let (jl,cu2) = execute_array env args cu1 in
-	univ_combinator cu2
-	  (judge_of_apply env j jl)
+        let (jl,cu1) = execute_array env args cu in
+	let (j,cu2) =
+	  match kind_of_term f with
+	    | Ind ind ->
+		(* Sort-polymorphism of inductive types *)
+		judge_of_inductive_knowing_parameters env ind jl, cu1
+	    | Const cst -> 
+		(* Sort-polymorphism of constant *)
+		judge_of_constant_knowing_parameters env cst jl, cu1
+	    | _ -> 
+		(* No sort-polymorphism *)
+		execute env f cu1
+	in
+	univ_combinator cu2 (judge_of_apply env j jl)
 	    
     | Lambda (name,c1,c2) -> 
         let (varj,cu1) = execute_type env c1 cu in
@@ -372,16 +415,17 @@ let rec execute env cstr cu =
     | LetIn (name,c1,c2,c3) ->
         let (j1,cu1) = execute env c1 cu in
         let (j2,cu2) = execute_type env c2 cu1 in
-        let (_,cu3) = univ_combinator cu2 (judge_of_cast env j1 j2) in
+        let (_,cu3) = 
+	  univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in
         let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
         let (j',cu4) = execute env1 c3 cu3 in
         (judge_of_letin env name j1 j2 j', cu4)
 	  
-    | Cast (c,t) ->
+    | Cast (c,k, t) ->
         let (cj,cu1) = execute env c cu in
         let (tj,cu2) = execute_type env t cu1 in
 	univ_combinator cu2
-          (judge_of_cast env cj tj)
+          (judge_of_cast env cj k tj)
 
     (* Inductive types *)
     | Ind ind ->
@@ -430,27 +474,16 @@ and execute_recdef env (names,lar,vdef) i cu =
   univ_combinator cu2
     ((lara.(i),(names,lara,vdefv)),cst)
 
-and execute_array env v cu =
-  let (jl,cu1) = execute_list env (Array.to_list v) cu in
-  (Array.of_list jl, cu1)
+and execute_array env = array_fold_map' (execute env)
 
-and execute_list env l cu =
-  match l with
-  | [] -> 
-      ([], cu)
-  | c::r -> 
-      let (j,cu1) = execute env c cu in 
-      let (jr,cu2) = execute_list env r cu1 in
-      (j::jr, cu2)
+and execute_list env = list_fold_map' (execute env) 
 
 (* Derived functions *)
 let infer env constr =
   let (j,(cst,_)) =
     execute env constr (Constraint.empty, universes env) in
-  let j = if j.uj_val = constr then { j with uj_val = constr } else
-    (error "Kernel built a body different from its input\n";
-     flush stdout; j) in
-  (j, cst)
+  assert (j.uj_val = constr);
+  ({ j with uj_val = constr }, cst)
 
 let infer_type env constr =
   let (j,(cst,_)) =
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index ffe9d861..1e73725f 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeops.mli,v 1.44.8.1 2004/07/16 19:30:28 herbelin Exp $ i*)
+(*i $Id: typeops.mli 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 (*i*)
 open Names
@@ -14,6 +14,7 @@ open Univ
 open Term
 open Environ
 open Entries
+open Declarations
 (*i*)
 
 (*s Typing functions (not yet tagged as safe) *)
@@ -47,6 +48,9 @@ val judge_of_variable : env -> variable -> unsafe_judgment
 (*s type of a constant *)
 val judge_of_constant : env -> constant -> unsafe_judgment
 
+val judge_of_constant_knowing_parameters :
+  env -> constant -> unsafe_judgment array -> unsafe_judgment
+
 (*s Type of application. *)
 val judge_of_apply : 
   env -> unsafe_judgment -> unsafe_judgment array
@@ -69,13 +73,16 @@ val judge_of_letin :
 
 (*s Type of a cast. *)
 val judge_of_cast :
-  env -> unsafe_judgment -> unsafe_type_judgment
-    -> unsafe_judgment * constraints
+  env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment ->
+    unsafe_judgment * constraints
 
 (*s Inductive types. *)
 
 val judge_of_inductive : env -> inductive -> unsafe_judgment
 
+val judge_of_inductive_knowing_parameters : 
+  env -> inductive -> unsafe_judgment array -> unsafe_judgment
+
 val judge_of_constructor : env -> constructor -> unsafe_judgment
 
 (*s Type of Cases. *)
@@ -90,3 +97,13 @@ val type_fixpoint : env -> name array -> types array
 (* Kernel safe typing but applicable to partial proofs *)
 val typing : env -> constr -> unsafe_judgment
 
+val type_of_constant : env -> constant -> types
+
+val type_of_constant_type : env -> constant_type -> types
+
+val type_of_constant_knowing_parameters : 
+  env -> constant_type -> constr array -> types
+
+(* Make a type polymorphic if an arity *)
+val make_polymorphic_if_arity : env -> types -> constant_type
+
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 5e9fbd81..df06e9af 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -6,29 +6,45 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: univ.ml,v 1.17.10.3 2005/09/08 12:27:46 herbelin Exp $ *)
+(* $Id: univ.ml 9507 2007-01-20 08:09:54Z herbelin $ *)
 
-(* Universes are stratified by a partial ordering $\ge$.
+(* Initial Caml version originates from CoC 4.8 [Dec 1988] *)
+(* Extension with algebraic universes by HH [Sep 2001] *)
+(* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *)
+
+(* Universes are stratified by a partial ordering $\le$.
    Let $\~{}$ be the associated equivalence. We also have a strict ordering
-   $>$ between equivalence classes, and we maintain that $>$ is acyclic,
-   and contained in $\ge$ in the sense that $[U]>[V]$ implies $U\ge V$.
+   $<$ between equivalence classes, and we maintain that $<$ is acyclic,
+   and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$.
 
    At every moment, we have a finite number of universes, and we
-   maintain the ordering in the presence of assertions $U>V$ and $U\ge V$.
+   maintain the ordering in the presence of assertions $U<V$ and $U\le V$.
 
    The equivalence $\~{}$ is represented by a tree structure, as in the
-   union-find algorithm. The assertions $>$ and $\ge$ are represented by
+   union-find algorithm. The assertions $<$ and $\le$ are represented by
    adjacency lists *)
 
 open Pp
 open Util
 
+(* An algebraic universe [universe] is either a universe variable
+   [universe_level] or a formal universe known to be greater than some
+   universe variables and strictly greater than some (other) universe
+   variables
+
+   Universes variables denote universes initially present in the term
+   to type-check and non variable algebraic universes denote the
+   universes inferred while type-checking: it is either the successor
+   of a universe present in the initial term to type-check or the
+   maximum of two algebraic universes
+ *)
+
 type universe_level =
-    { u_mod : Names.dir_path;
-      u_num : int }
+  | Base
+  | Level of Names.dir_path * int
 
 type universe =
-  | Variable of universe_level
+  | Atom of universe_level
   | Max of universe_level list * universe_level list
   
 module UniverseOrdered = struct
@@ -36,61 +52,60 @@ module UniverseOrdered = struct
   let compare = Pervasives.compare
 end
 
-let string_of_univ_level u =
-  Names.string_of_dirpath u.u_mod^"."^string_of_int u.u_num
+let string_of_univ_level = function
+  | Base -> "0"
+  | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
 
-let make_univ (m,n) = Variable { u_mod=m; u_num=n }
-
-let string_of_univ = function
-  | Variable u -> string_of_univ_level u
-  | Max (gel,gtl) -> 
-      "max("^
-      (String.concat ","
-	 ((List.map string_of_univ_level gel)@
-	  (List.map (fun u -> "("^(string_of_univ_level u)^")+1") gtl)))^")"
+let make_univ (m,n) = Atom (Level (m,n))
 
 let pr_uni_level u = str (string_of_univ_level u)
 
 let pr_uni = function
-  | Variable u -> 
+  | Atom u -> 
       pr_uni_level u
+  | Max ([],[u]) ->
+      str "(" ++ pr_uni_level u ++ str ")+1"
   | Max (gel,gtl) ->
-      str "max(" ++ 
-      prlist_with_sep pr_coma pr_uni_level gel ++
-      (if gel <> [] & gtl <> [] then pr_coma () else mt ()) ++
-      prlist_with_sep pr_coma
-	(fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl ++
+      str "max(" ++ hov 0
+       (prlist_with_sep pr_coma pr_uni_level gel ++
+	  (if gel <> [] & gtl <> [] then pr_coma () else mt ()) ++
+	prlist_with_sep pr_coma
+	  (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++
       str ")"
 
-(* Returns a fresh universe, juste above u. Does not create new universes
-   for Type_0 (the sort of Prop and Set).
+(* Returns the formal universe that lies juste above the universe variable u.
    Used to type the sort u. *)
 let super = function
-  | Variable u -> 
+  | Atom u -> 
       Max ([],[u])
   | Max _ ->
-      anomaly ("Cannot take the successor of a non variable universes\n"^
+      anomaly ("Cannot take the successor of a non variable universes:\n"^
                "(maybe a bugged tactic)")
 
-(* returns the least upper bound of universes u and v. If they are not
-   constrained, then a new universe is created.
+(* Returns the formal universe that is greater than the universes u and v.
    Used to type the products. *)
-let sup u v = 
+let sup u v =
   match u,v with
-    | Variable u, Variable v -> Max ((if u = v then [u] else [u;v]),[])
-    | Variable u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
-    | Max (gel,gtl), Variable v -> Max (list_add_set v gel,gtl)
+    | Atom u, Atom v -> if u = v then Atom u else Max ([u;v],[])
+    | u, Max ([],[]) -> u
+    | Max ([],[]), v -> v
+    | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
+    | Max (gel,gtl), Atom v -> Max (list_add_set v gel,gtl)
     | Max (gel,gtl), Max (gel',gtl') ->
-	Max (list_union gel gel',list_union gtl gtl')
+	let gel'' = list_union gel gel' in
+	let gtl'' = list_union gtl gtl' in
+	Max (list_subtract gel'' gtl'',gtl'')
+
+let neutral_univ = Max ([],[])
 
 (* Comparison on this type is pointer equality *)
 type canonical_arc =
-    { univ: universe_level; gt: universe_level list; ge: universe_level list }
+    { univ: universe_level; lt: universe_level list; le: universe_level list }
 
-let terminal u = {univ=u; gt=[]; ge=[]}
+let terminal u = {univ=u; lt=[]; le=[]}
 
-(* A universe is either an alias for another one, or a canonical one,
-   for which we know the universes that are smaller *)
+(* A universe_level is either an alias for another one, or a canonical one,
+   for which we know the universes that are above *)
 type univ_entry =
     Canonical of canonical_arc
   | Equiv of universe_level * universe_level
@@ -111,15 +126,27 @@ let declare_univ u g =
   else
     g
 
-(* When typing Prop and Set, there is no constraint on the level,
-   hence the definition of prop_univ *)
+(* The level of Set *)
+let base_univ = Atom Base
+
+let is_base_univ = function
+  | Atom Base -> true
+  | Max ([Base],[]) -> warning "Non canonical Set"; true
+  | u -> false
+
+let is_univ_variable = function
+  | Atom a when a<>Base -> true
+  | _ -> false
+
+(* When typing [Prop] and [Set], there is no constraint on the level,
+   hence the definition of [prop_univ], the type of [Prop] *)
 
 let initial_universes = UniverseMap.empty
-let prop_univ = Max ([],[])
+let prop_univ = Max ([],[Base])
 
-(* Every universe has a unique canonical arc representative *)
+(* Every universe_level has a unique canonical arc representative *)
 
-(* repr : universes -> universe -> canonical_arc *)
+(* repr : universes -> universe_level -> canonical_arc *)
 (* canonical representative : we follow the Equiv links *)
 let repr g u = 
   let rec repr_rec u =
@@ -136,30 +163,30 @@ let repr g u =
 
 let can g = List.map (repr g)
 
-(* transitive closure : we follow the Greater links *)
+(* transitive closure : we follow the Less links *)
 
 (* collect : canonical_arc -> canonical_arc list * canonical_arc list *)
-(* collect u = (V,W) iff V={v canonical | u>v} W={w canonical | u>=w}-V *)
-(* i.e. collect does the transitive closure of what is known about u *)
-let collect g arcu = 
-  let rec coll_rec gt ge = function
-    | [],[] -> (gt, list_subtractq ge gt)
-    | arcv::gt', ge' ->
-	if List.memq arcv gt then 
-	  coll_rec gt ge (gt',ge')
+(* collect u = (V,W) iff V={v canonical | u<v} W={w canonical | u<=w}-V *)
+(* i.e. collect does the transitive upward closure of what is known about u *)
+let collect g arcu =
+  let rec coll_rec lt le = function
+    | [],[] -> (lt, list_subtractq le lt)
+    | arcv::lt', le' ->
+	if List.memq arcv lt then 
+	  coll_rec lt le (lt',le')
 	else
-          coll_rec (arcv::gt) ge ((can g (arcv.gt@arcv.ge))@gt',ge')
-    | [], arcw::ge' -> 
-	if (List.memq arcw gt) or (List.memq arcw ge) then 
-	  coll_rec gt ge ([],ge')
+          coll_rec (arcv::lt) le ((can g (arcv.lt@arcv.le))@lt',le')
+    | [], arcw::le' -> 
+	if (List.memq arcw lt) or (List.memq arcw le) then 
+	  coll_rec lt le ([],le')
 	else
-          coll_rec gt (arcw::ge) (can g arcw.gt, (can g arcw.ge)@ge')
+          coll_rec lt (arcw::le) (can g arcw.lt, (can g arcw.le)@le')
   in 
   coll_rec [] [] ([],[arcu])
 
-(* reprgeq : canonical_arc -> canonical_arc list *)
-(* All canonical arcv such that arcu>=arcc with arcv#arcu *)
-let reprgeq g arcu =
+(* reprleq : canonical_arc -> canonical_arc list *)
+(* All canonical arcv such that arcu<=arcv with arcv#arcu *)
+let reprleq g arcu =
   let rec searchrec w = function
     | [] -> w
     | v :: vl ->
@@ -169,17 +196,17 @@ let reprgeq g arcu =
         else 
 	  searchrec (arcv :: w) vl
   in 
-  searchrec [] arcu.ge
+  searchrec [] arcu.le
 
 
-(* between : universe -> canonical_arc -> canonical_arc list *)
-(* between u v = {w|u>=w>=v, w canonical}          *)     
+(* between : universe_level -> canonical_arc -> canonical_arc list *)
+(* between u v = {w|u<=w<=v, w canonical}          *)     
 (* between is the most costly operation *)
 
 let between g u arcv = 
-  (* good are all w | u >= w >= v  *)
-  (* bad are all w | u >= w ~>= v *)
-    (* find good and bad nodes in {w | u >= w} *)
+  (* good are all w | u <= w <= v  *)
+  (* bad are all w | u <= w ~<= v *)
+    (* find good and bad nodes in {w | u <= w} *)
     (* explore b u = (b or "u is good") *)
   let rec explore ((good, bad, b) as input) arcu =
     if List.memq arcu good then
@@ -187,12 +214,12 @@ let between g u arcv =
     else if List.memq arcu bad then
       input    (* (good, bad, b or false) *)
     else 
-      let childs = reprgeq g arcu in 
-	(* are any children of u good ? *)
-      let good, bad, b_childs = 
-	List.fold_left explore (good, bad, false) childs 
+      let leq = reprleq g arcu in 
+	(* is some universe >= u good ? *)
+      let good, bad, b_leq = 
+	List.fold_left explore (good, bad, false) leq
       in
-	if b_childs then
+	if b_leq then
 	  arcu::good, bad, true (* b or true *)
 	else 
 	  good, arcu::bad, b    (* b or false *)
@@ -200,64 +227,64 @@ let between g u arcv =
   let good,_,_ = explore ([arcv],[],false) (repr g u) in
     good
       
-(* We assume  compare(u,v) = GE with v canonical (see compare below).
+(* We assume  compare(u,v) = LE with v canonical (see compare below).
    In this case List.hd(between g u v) = repr u
    Otherwise, between g u v = [] 
  *)
 
 
-type order = EQ | GT | GE | NGE
+type order = EQ | LT | LE | NLE
 
-(* compare : universe -> universe -> order *)
+(* compare : universe_level -> universe_level -> order *)
 let compare g u v = 
   let arcu = repr g u 
   and arcv = repr g v in
   if arcu==arcv then 
     EQ
   else 
-    let (gt,geq) = collect g arcu in
-    if List.memq arcv gt then 
-      GT
-    else if List.memq arcv geq then 
-      GE
+    let (lt,leq) = collect g arcu in
+    if List.memq arcv lt then 
+      LT
+    else if List.memq arcv leq then 
+      LE
     else 
-      NGE
+      NLE
 
 (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
-                compare(u,v) = GT or GE => compare(v,u) = NGE
-                compare(u,v) = NGE => compare(v,u) = NGE or GE or GT
+                compare(u,v) = LT or LE => compare(v,u) = NLE
+                compare(u,v) = NLE => compare(v,u) = NLE or LE or LT
 
-   Adding u>=v is consistent iff compare(v,u) # GT 
-    and then it is redundant iff compare(u,v) # NGE
-   Adding u>v is consistent iff compare(v,u) = NGE 
-    and then it is redundant iff compare(u,v) = GT *)
+   Adding u>=v is consistent iff compare(v,u) # LT 
+    and then it is redundant iff compare(u,v) # NLE
+   Adding u>v is consistent iff compare(v,u) = NLE 
+    and then it is redundant iff compare(u,v) = LT *)
 
 
-(* setgt : universe -> universe -> unit *)
+(* setlt : universe_level -> universe_level -> unit *)
 (* forces u > v *)
-let setgt g u v =
+let setlt g u v =
   let arcu = repr g u in
-  enter_arc {arcu with gt=v::arcu.gt} g
+  enter_arc {arcu with lt=v::arcu.lt} g
 
-(* checks that non-redondant *)
-let setgt_if g u v = match compare g u v with
-  | GT -> g
-  | _ -> setgt g u v
+(* checks that non-redundant *)
+let setlt_if g u v = match compare g u v with
+  | LT -> g
+  | _ -> setlt g u v
 
-(* setgeq : universe -> universe -> unit *)
+(* setleq : universe_level -> universe_level -> unit *)
 (* forces u >= v *)
-let setgeq g u v =
+let setleq g u v =
   let arcu = repr g u in
-  enter_arc {arcu with ge=v::arcu.ge} g
+  enter_arc {arcu with le=v::arcu.le} g
 
 
-(* checks that non-redondant *)
-let setgeq_if g u v = match compare g u v with
-  | NGE -> setgeq g u v
+(* checks that non-redundant *)
+let setleq_if g u v = match compare g u v with
+  | NLE -> setleq g u v
   | _ -> g
 
-(* merge : universe -> universe -> unit *)
-(* we assume  compare(u,v) = GE *)
+(* merge : universe_level -> universe_level -> unit *)
+(* we assume  compare(u,v) = LE *)
 (* merge u v  forces u ~ v with repr u as canonical repr *)
 let merge g u v =
   match between g u (repr g v) with
@@ -265,23 +292,23 @@ let merge g u v =
                  (* redirected to it *)
 	let redirect (g,w,w') arcv =
  	  let g' = enter_equiv_arc arcv.univ arcu.univ g in
- 	  (g',list_unionq arcv.gt w,arcv.ge@w') 
+ 	  (g',list_unionq arcv.lt w,arcv.le@w') 
 	in
 	let (g',w,w') = List.fold_left redirect (g,[],[]) v in
-	let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' w in
-	let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' w' in
+	let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' w in
+	let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' w' in
 	g'''
     | [] -> anomaly "Univ.between"
 
-(* merge_disc : universe -> universe -> unit *)
-(* we assume  compare(u,v) = compare(v,u) = NGE *)
+(* merge_disc : universe_level -> universe_level -> unit *)
+(* we assume  compare(u,v) = compare(v,u) = NLE *)
 (* merge_disc u v  forces u ~ v with repr u as canonical repr *)
 let merge_disc g u v =
   let arcu = repr g u in
   let arcv = repr g v in
   let g' = enter_equiv_arc arcv.univ arcu.univ g in
-  let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' arcv.gt in
-  let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' arcv.ge in
+  let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' arcv.lt in
+  let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' arcv.le in
   g'''
 
 (* Universe inconsistency: error raised when trying to enforce a relation
@@ -291,55 +318,55 @@ exception UniverseInconsistency
 
 let error_inconsistency () = raise UniverseInconsistency
 
-(* enforcegeq : universe -> universe -> unit *)
-(* enforcegeq u v will force u>=v if possible, will fail otherwise *)
-let enforce_univ_geq u v g =
+(* enforce_univ_leq : universe_level -> universe_level -> unit *)
+(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
+let enforce_univ_leq u v g =
   let g = declare_univ u g in
   let g = declare_univ v g in
   match compare g u v with
-    | NGE -> 
+    | NLE -> 
 	(match compare g v u with
-           | GT -> error_inconsistency()
-           | GE -> merge g v u
-           | NGE -> setgeq g u v
+           | LT -> error_inconsistency()
+           | LE -> merge g v u
+           | NLE -> setleq g u v
            | EQ -> anomaly "Univ.compare")
     | _ -> g
 
-(* enforceq : universe -> universe -> unit *)
-(* enforceq u v will force u=v if possible, will fail otherwise *)
+(* enforc_univ_eq : universe_level -> universe_level -> unit *)
+(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
 let enforce_univ_eq u v g =
   let g = declare_univ u g in
   let g = declare_univ v g in
   match compare g u v with
     | EQ -> g
-    | GT -> error_inconsistency()
-    | GE -> merge g u v
-    | NGE -> 
+    | LT -> error_inconsistency()
+    | LE -> merge g u v
+    | NLE -> 
 	(match compare g v u with
-           | GT -> error_inconsistency()
-           | GE -> merge g v u
-           | NGE -> merge_disc g u v
+           | LT -> error_inconsistency()
+           | LE -> merge g v u
+           | NLE -> merge_disc g u v
            | EQ -> anomaly "Univ.compare")
 
-(* enforcegt u v will force u>v if possible, will fail otherwise *)
-let enforce_univ_gt u v g =
+(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
+let enforce_univ_lt u v g =
   let g = declare_univ u g in
   let g = declare_univ v g in
   match compare g u v with
-    | GT -> g
-    | GE -> setgt g u v
+    | LT -> g
+    | LE -> setlt g u v
     | EQ -> error_inconsistency()
-    | NGE -> 
+    | NLE -> 
 	(match compare g v u with
-           | NGE -> setgt g u v
+           | NLE -> setlt g u v
            | _ -> error_inconsistency())
 
 (*
 let enforce_univ_relation g = function 
   | Equiv (u,v) -> enforce_univ_eq u v g
-  | Canonical {univ=u; gt=gt; ge=ge} ->
-      let g' = List.fold_right (enforce_univ_gt u) gt g in
-      List.fold_right (enforce_univ_geq u) ge g'
+  | Canonical {univ=u; lt=lt; le=le} ->
+      let g' = List.fold_right (enforce_univ_lt u) lt g in
+      List.fold_right (enforce_univ_leq u) le g'
 *)
 
 (* Merging 2 universe graphs *)
@@ -351,14 +378,14 @@ let merge_universes sp u1 u2 =
 
 (* Constraints and sets of consrtaints. *)
 
-type constraint_type = Gt | Geq | Eq
+type constraint_type = Lt | Leq | Eq
 
 type univ_constraint = universe_level * constraint_type * universe_level
 
 let enforce_constraint cst g =
   match cst with
-    | (u,Gt,v) -> enforce_univ_gt u v g
-    | (u,Geq,v) -> enforce_univ_geq u v g
+    | (u,Lt,v) -> enforce_univ_lt u v g
+    | (u,Leq,v) -> enforce_univ_leq u v g
     | (u,Eq,v) -> enforce_univ_eq u v g
 
 
@@ -373,25 +400,102 @@ type constraints = Constraint.t
 type constraint_function = 
     universe -> universe -> constraints -> constraints
 
-let enforce_gt u v c = Constraint.add (u,Gt,v) c
+let constraint_add_leq v u c =
+  if v = Base then c else Constraint.add (v,Leq,u) c
 
 let enforce_geq u v c =
-  match u with
-    | Variable u -> (match v with
-	| Variable v -> Constraint.add (u,Geq,v) c
-	| Max (l1, l2) ->
-	    let d = List.fold_right (fun v -> Constraint.add (u,Geq,v)) l1 c in
-	    List.fold_right (fun v -> Constraint.add (u,Gt,v)) l2 d) 
-    | Max _ -> anomaly "A universe bound can only be a variable"
+  match u, v with
+  | Atom u, Atom v -> constraint_add_leq v u c
+  | Atom u, Max (gel,gtl) ->
+      let d = List.fold_right (fun v -> constraint_add_leq v u) gel c in
+      List.fold_right (fun v -> Constraint.add (v,Lt,u)) gtl d
+  | _ -> anomaly "A universe bound can only be a variable"
 
 let enforce_eq u v c =
   match (u,v) with
-    | Variable u, Variable v -> Constraint.add (u,Eq,v) c
+    | Atom u, Atom v -> Constraint.add (u,Eq,v) c
     | _ -> anomaly "A universe comparison can only happen between variables"
 
 let merge_constraints c g =
   Constraint.fold enforce_constraint c g
 
+(**********************************************************************)
+(* Tools for sort-polymorphic inductive types                         *)
+
+(* Temporary inductive type levels *)
+
+let fresh_level =
+  let n = ref 0 in fun () -> incr n; Level (Names.make_dirpath [],!n)
+
+let fresh_local_univ () = Atom (fresh_level ())
+
+(* Miscellaneous functions to remove or test local univ assumed to
+   occur only in the le constraints *)
+
+let make_max = function
+  | ([u],[]) -> Atom u
+  | (le,lt) -> Max (le,lt)
+
+let remove_large_constraint u = function
+  | Atom u' as x -> if u = u' then Max ([],[]) else x
+  | Max (le,lt) -> make_max (list_remove u le,lt)
+
+let is_empty_univ = function
+  | Max ([],[]) -> true
+  | _ -> false
+
+let is_direct_constraint u = function
+  | Atom u' -> u = u'
+  | Max (le,lt) -> List.mem u le
+
+(* 
+   Solve a system of universe constraint of the form
+
+   u_s11, ..., u_s1p1, w1 <= u1
+   ...
+   u_sn1, ..., u_snpn, wn <= un
+
+where 
+
+  - the ui (1 <= i <= n) are universe variables,
+  - the sjk select subsets of the ui for each equations, 
+  - the wi are arbitrary complex universes that do not mention the ui.
+*)
+
+let is_direct_sort_constraint s v = match s with
+  | Some u -> is_direct_constraint u v
+  | None -> false
+
+let solve_constraints_system levels level_bounds =
+  let levels = 
+    Array.map (option_map (function Atom u -> u | _ -> anomaly "expects Atom"))
+      levels in
+  let v = Array.copy level_bounds in
+  let nind = Array.length v in
+  for i=0 to nind-1 do
+    for j=0 to nind-1 do
+      if i<>j & is_direct_sort_constraint levels.(j) v.(i) then
+	v.(i) <- sup v.(i) level_bounds.(j)
+    done;
+    for j=0 to nind-1 do
+      match levels.(j) with
+      | Some u -> v.(i) <- remove_large_constraint u v.(i)
+      | None -> ()
+    done
+  done;
+  v
+
+let subst_large_constraint u u' v =
+  match u with 
+  | Atom u ->
+      if is_direct_constraint u v then sup u' (remove_large_constraint u v)
+      else v
+  | _ ->
+      anomaly "expect a universe level"
+
+let subst_large_constraints =
+  List.fold_right (fun (u,u') -> subst_large_constraint u u')
+
 (* Pretty-printing *)
 
 let num_universes g =
@@ -400,19 +504,19 @@ let num_universes g =
 let num_edges g =
   let reln_len = function
     | Equiv _ -> 1
-    | Canonical {gt=gt;ge=ge} -> List.length gt + List.length ge
+    | Canonical {lt=lt;le=le} -> List.length lt + List.length le
   in
   UniverseMap.fold (fun _ a n -> n + (reln_len a)) g 0
     
 let pr_arc = function 
-  | Canonical {univ=u; gt=[]; ge=[]} ->
+  | Canonical {univ=u; lt=[]; le=[]} ->
       mt ()
-  | Canonical {univ=u; gt=gt; ge=ge} ->
+  | Canonical {univ=u; lt=lt; le=le} ->
       pr_uni_level u ++ str " " ++
       v 0
-        (prlist_with_sep pr_spc (fun v -> str "> " ++ pr_uni_level v) gt ++
-	(if ge <> [] & gt <> [] then spc () else mt ()) ++
-         prlist_with_sep pr_spc (fun v -> str ">= " ++ pr_uni_level v) ge) ++
+        (prlist_with_sep pr_spc (fun v -> str "< " ++ pr_uni_level v) lt ++
+	 (if lt <> [] & le <> [] then spc () else mt()) ++
+         prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++
       fnl ()
   | Equiv (u,v) -> 
       pr_uni_level u  ++ str " = " ++ pr_uni_level v ++ fnl ()
@@ -426,44 +530,48 @@ let pr_universes g =
 
 let dump_universes output g = 
   let dump_arc _ = function
-    | Canonical {univ=u; gt=gt; ge=ge} -> 
+    | Canonical {univ=u; lt=lt; le=le} -> 
 	let u_str = string_of_univ_level u in
 	  List.iter 
 	    (fun v -> 
 	       Printf.fprintf output "%s > %s ;\n" u_str
 		 (string_of_univ_level v)) 
-	    gt;
+	    lt;
 	  List.iter 
 	    (fun v -> 
 	       Printf.fprintf output "%s >= %s ;\n" u_str
 		 (string_of_univ_level v)) 
-	    ge
+	    le
     | Equiv (u,v) ->
 	Printf.fprintf output "%s = %s ;\n"
 	  (string_of_univ_level u) (string_of_univ_level v)
   in
     UniverseMap.iter dump_arc g 
 
+(* Hash-consing *)
+
 module Huniv =
   Hashcons.Make(
     struct
       type t = universe
       type u = Names.dir_path -> Names.dir_path
-      let hash_aux hdir u = { u with u_mod=hdir u.u_mod }
+      let hash_aux hdir = function
+	| Base -> Base
+	| Level (d,n) -> Level (hdir d,n)
       let hash_sub hdir = function
-	| Variable u -> Variable (hash_aux hdir u)
+	| Atom u -> Atom (hash_aux hdir u)
 	| Max (gel,gtl) ->
 	    Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl)
       let equal u v =
 	match u, v with
-	  | Variable u, Variable v -> u == v
+	  | Atom u, Atom v -> u == v
 	  | Max (gel,gtl), Max (gel',gtl') ->
-	      (List.for_all2 (==) gel gel') && (List.for_all2 (==) gtl gtl')
+	      (list_for_all2eq (==) gel gel') &&
+              (list_for_all2eq (==) gtl gtl')
 	  | _ -> false
       let hash = Hashtbl.hash
     end)
 
 let hcons1_univ u =
-  let _,hdir,_,_,_ = Names.hcons_names() in
+  let _,_,hdir,_,_,_ = Names.hcons_names() in
   Hashcons.simple_hcons Huniv.f hdir u
-
diff --git a/kernel/univ.mli b/kernel/univ.mli
index e15971eb..5f562a1d 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -6,17 +6,23 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: univ.mli,v 1.21.14.1 2004/07/16 19:30:28 herbelin Exp $ i*)
+(*i $Id: univ.mli 9507 2007-01-20 08:09:54Z herbelin $ i*)
 
 (* Universes. *)
 
 type universe
 
+val base_univ : universe
 val prop_univ : universe
+val neutral_univ : universe
 val make_univ : Names.dir_path * int -> universe
 
+val is_base_univ : universe -> bool
+val is_univ_variable : universe -> bool
+
 (* The type of a universe *)
 val super : universe -> universe
+
 (* The max of 2 universes *)
 val sup   : universe -> universe -> universe
 
@@ -47,13 +53,25 @@ exception UniverseInconsistency
 
 val merge_constraints : constraints -> universes -> universes
 
+(*s Support for sort-polymorphic inductive types *)
+
+val fresh_local_univ : unit -> universe
+
+val solve_constraints_system : universe option array -> universe array -> 
+  universe array
+
+val is_empty_univ : universe -> bool
+
+val subst_large_constraint : universe -> universe -> universe -> universe
+
+val subst_large_constraints : 
+  (universe * universe) list -> universe -> universe
+
 (*s Pretty-printing of universes. *)
 
 val pr_uni : universe -> Pp.std_ppcmds
 val pr_universes : universes -> Pp.std_ppcmds
 
-val string_of_univ : universe -> string
-
 (*s Dumping to a file *)
 
 val dump_universes : out_channel -> universes -> unit
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
new file mode 100644
index 00000000..7c515735
--- /dev/null
+++ b/kernel/vconv.ml
@@ -0,0 +1,242 @@
+open Names
+open Declarations
+open Term
+open Environ
+open Conv_oracle
+open Reduction 
+open Closure
+open Vm
+open Csymtable 
+open Univ
+
+let val_of_constr env c =
+  val_of_constr (pre_env env) c
+
+(* Test la structure des piles *)
+
+let compare_zipper z1 z2 =
+  match z1, z2 with
+  | Zapp args1, Zapp args2 -> nargs args1 = nargs args2
+  | Zfix(f1,args1), Zfix(f2,args2) ->  nargs args1 = nargs args2
+  | Zswitch _, Zswitch _ -> true
+  | _ , _ -> false
+
+let rec compare_stack stk1 stk2 =
+  match stk1, stk2 with
+  | [], [] -> true
+  | z1::stk1, z2::stk2 ->
+      if compare_zipper z1 z2 then compare_stack stk1 stk2
+      else false
+  | _, _ -> false 
+
+(* Conversion *)
+let conv_vect fconv vect1 vect2 cu =
+  let n = Array.length vect1 in
+  if n = Array.length vect2 then
+    let rcu = ref cu in
+    for i = 0 to n - 1 do
+      rcu := fconv vect1.(i) vect2.(i) !rcu
+    done;
+    !rcu
+  else raise NotConvertible
+
+let infos = ref (create_clos_infos betaiotazeta Environ.empty_env)
+
+let rec conv_val pb k v1 v2 cu = 
+  if v1 == v2 then cu 
+  else conv_whd pb k (whd_val v1) (whd_val v2) cu
+    
+and conv_whd pb k whd1 whd2 cu =  
+  match whd1, whd2 with
+  | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu 
+  | Vprod p1, Vprod p2 ->
+      let cu = conv_val CONV k (dom p1) (dom p2) cu in
+      conv_fun pb k (codom p1) (codom p2) cu
+  | Vfun f1, Vfun f2 -> conv_fun CONV k f1 f2 cu
+  | Vfix (f1,None), Vfix (f2,None) -> conv_fix k f1 f2 cu
+  | Vfix (f1,Some args1), Vfix(f2,Some args2) ->
+      if nargs args1 <> nargs args2 then raise NotConvertible
+      else conv_arguments k args1 args2 (conv_fix k f1 f2 cu)
+  | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix k cf1 cf2 cu
+  | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) ->	
+      if nargs args1 <> nargs args2 then raise NotConvertible
+      else conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu)
+  | Vconstr_const i1, Vconstr_const i2 -> 
+      if i1 = i2 then cu else raise NotConvertible 
+  | Vconstr_block b1, Vconstr_block b2 ->
+      let sz = bsize b1 in
+      if btag b1 = btag b2 && sz = bsize b2 then
+	let rcu = ref cu in
+	for i = 0 to sz - 1 do
+	  rcu := conv_val CONV k (bfield b1 i) (bfield b2 i) !rcu
+	done;
+	!rcu
+      else raise NotConvertible
+  | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> 
+      conv_atom pb k a1 stk1 a2 stk2 cu
+  | _, Vatom_stk(Aiddef(_,v),stk) -> 
+      conv_whd pb k whd1 (force_whd v stk) cu
+  | Vatom_stk(Aiddef(_,v),stk), _ -> 
+      conv_whd pb k (force_whd v stk) whd2 cu
+  | _, _ -> raise NotConvertible
+
+and conv_atom pb k a1 stk1 a2 stk2 cu =
+  match a1, a2 with
+  | Aind (kn1,i1), Aind(kn2,i2) ->
+      if mind_equiv_infos !infos (kn1,i1) (kn2,i2) && compare_stack stk1 stk2
+      then
+	conv_stack k stk1 stk2 cu
+      else raise NotConvertible
+  | Aid ik1, Aid ik2 -> 
+      if ik1 = ik2 && compare_stack stk1 stk2 then 
+	conv_stack k stk1 stk2 cu 
+      else raise NotConvertible
+  | Aiddef(ik1,v1), Aiddef(ik2,v2) ->
+      begin
+	try
+	  if ik1 = ik2 && compare_stack stk1 stk2 then
+	    conv_stack k stk1 stk2 cu 
+	  else raise NotConvertible
+	with NotConvertible ->
+	  if oracle_order ik1 ik2 then             
+            conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
+          else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
+      end
+  | Aiddef(ik1,v1), _ ->
+      conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu
+  | _, Aiddef(ik2,v2) ->
+      conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu
+  | _, _ -> raise NotConvertible 
+	
+and conv_stack k stk1 stk2 cu =
+  match stk1, stk2 with
+  | [], [] -> cu
+  | Zapp args1 :: stk1, Zapp args2 :: stk2 ->
+      conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) 
+  | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 ->
+      conv_stack k stk1 stk2 
+	(conv_arguments k args1 args2 (conv_fix k f1 f2 cu))
+  | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 ->
+      if check_switch sw1 sw2 then
+	let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in
+	let rcu = ref (conv_val CONV k vt1 vt2 cu) in
+	let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in
+	for i = 0 to Array.length b1 - 1 do
+	  rcu := 
+	    conv_val CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu
+	done;
+	conv_stack k stk1 stk2 !rcu
+      else raise NotConvertible
+  | _, _ -> raise NotConvertible
+
+and conv_fun pb k f1 f2 cu =
+  if f1 == f2 then cu
+  else
+    let arity,b1,b2 = decompose_vfun2 k f1 f2 in
+    conv_val pb (k+arity) b1 b2 cu
+
+and conv_fix k f1 f2 cu =
+  if f1 == f2 then cu 
+  else
+    if check_fix f1 f2 then
+      let bf1, tf1 = reduce_fix k f1 in
+      let bf2, tf2 = reduce_fix k f2 in
+      let cu = conv_vect (conv_val CONV k) tf1 tf2 cu in
+      conv_vect (conv_fun CONV (k + Array.length tf1)) bf1 bf2 cu
+    else raise NotConvertible
+
+and conv_cofix k cf1 cf2 cu =
+  if cf1 == cf2 then cu
+  else
+    if check_cofix cf1 cf2 then
+      let bcf1, tcf1 = reduce_cofix k cf1 in
+      let bcf2, tcf2 = reduce_cofix k cf2 in
+      let cu = conv_vect (conv_val CONV k) tcf1 tcf2 cu in
+      conv_vect (conv_val CONV (k + Array.length tcf1)) bcf1 bcf2 cu
+    else raise NotConvertible
+
+and conv_arguments k args1 args2 cu =
+  if args1 == args2 then cu
+  else
+    let n = nargs args1 in
+    if n = nargs args2 then
+      let rcu = ref cu in
+      for i = 0 to n - 1 do
+	rcu := conv_val CONV k (arg args1 i) (arg args2 i) !rcu
+      done;
+      !rcu
+    else raise NotConvertible
+
+let rec conv_eq pb t1 t2 cu =
+  if t1 == t2 then cu 
+  else
+    match kind_of_term t1, kind_of_term t2 with
+    | Rel n1, Rel n2 -> 
+	if n1 = n2 then cu else raise NotConvertible
+    | Meta m1, Meta m2 ->
+	if m1 = m2 then cu else raise NotConvertible
+    | Var id1, Var id2 -> 
+	if id1 = id2 then cu else raise NotConvertible
+    | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu
+    | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu
+    | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu
+    | Prod (_,t1,c1), Prod (_,t2,c2) -> 
+	conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu)
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> 
+	conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu)
+    | App (c1,l1), App (c2,l2) ->
+	conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu)
+    | Evar (e1,l1), Evar (e2,l2) ->
+	if e1 = e2 then conv_eq_vect l1 l2 cu
+	else raise NotConvertible
+    | Const c1, Const c2 -> 
+	if c1 = c2 then cu else raise NotConvertible
+    | Ind c1, Ind c2 -> 
+	if c1 = c2 then cu else raise NotConvertible
+    | Construct c1, Construct c2 -> 
+	if c1 = c2 then cu else raise NotConvertible
+    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+	let pcu = conv_eq CONV p1 p2 cu in
+	let ccu = conv_eq CONV c1 c2 pcu in
+	conv_eq_vect bl1 bl2 ccu
+    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
+	else raise NotConvertible
+    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->	
+	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
+	else raise NotConvertible
+    | _ -> raise NotConvertible
+
+and conv_eq_vect vt1 vt2 cu =
+  let len = Array.length vt1 in
+  if len = Array.length vt2 then
+    let rcu = ref cu in
+    for i = 0 to len-1 do
+      rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu
+    done; !rcu
+  else raise NotConvertible
+      
+let vconv pb env t1 t2 =
+  let cu =
+    try conv_eq pb t1 t2 Constraint.empty
+    with NotConvertible ->
+      infos := create_clos_infos betaiotazeta env;
+      let v1 = val_of_constr env t1 in
+      let v2 = val_of_constr env t2 in
+      let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in
+      cu
+  in cu
+    
+let _ = Reduction.set_vm_conv vconv
+
+let use_vm = ref false
+
+let set_use_vm b =
+  use_vm := b;
+  if b then Reduction.set_default_conv vconv
+  else Reduction.set_default_conv Reduction.conv_cmp
+      
+let use_vm _ = !use_vm
+
+
diff --git a/contrib7/correctness/ProgInt.v b/kernel/vconv.mli
index 0ca830c2..551615aa 100644
--- a/contrib7/correctness/ProgInt.v
+++ b/kernel/vconv.mli
@@ -6,14 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+(*i*)
+open Names
+open Term
+open Environ
+open Reduction
+(*i*)
 
-(* $Id: ProgInt.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
+(***********************************************************************)
+(*s conversion functions *)
+val use_vm : unit -> bool
+val set_use_vm : bool -> unit
+val vconv : conv_pb -> types conversion_function
 
-Require Export ZArith.
-Require Export ZArith_dec.
+val val_of_constr : env -> constr -> values
 
-Theorem Znotzero : (x:Z){`x<>0`}+{`x=0`}.
-Proof.
-Intro x. Elim (Z_eq_dec x `0`) ; Auto.
-Save.
diff --git a/kernel/vm.ml b/kernel/vm.ml
new file mode 100644
index 00000000..c1d3ca56
--- /dev/null
+++ b/kernel/vm.ml
@@ -0,0 +1,599 @@
+open Names
+open Term
+open Conv_oracle
+open Cbytecodes
+
+external set_drawinstr : unit -> unit = "coq_set_drawinstr"
+
+(******************************************)
+(* Fonctions en plus du module Obj ********)
+(******************************************)
+
+external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure"
+external offset : Obj.t -> int = "coq_offset"
+
+let accu_tag = 0
+
+(*******************************************)
+(* Initalisation de la machine abstraite ***)
+(*******************************************)
+
+external init_vm : unit -> unit = "init_coq_vm"
+
+let _ = init_vm ()
+
+external transp_values : unit -> bool = "get_coq_transp_value"
+external set_transp_values : bool -> unit = "coq_set_transp_value"
+
+(*******************************************)
+(* Le code machine  ************************)
+(*******************************************)
+
+type tcode 
+let tcode_of_obj v = ((Obj.obj v):tcode)
+let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) 
+
+  
+
+external mkAccuCode : int -> tcode = "coq_makeaccu"
+external mkPopStopCode : int -> tcode = "coq_pushpop"
+external mkAccuCond : int -> tcode = "coq_accucond"
+
+external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode"
+external int_tcode : tcode -> int -> int = "coq_int_tcode"
+
+external accumulate : unit -> tcode = "accumulate_code"
+let accumulate = accumulate ()
+
+external is_accumulate : tcode -> bool = "coq_is_accumulate_code"
+
+let popstop_tbl =  ref (Array.init 30 mkPopStopCode) 
+
+let popstop_code i =
+  let len = Array.length !popstop_tbl in
+  if i < len then !popstop_tbl.(i) 
+  else
+    begin
+      popstop_tbl :=
+	Array.init (i+10)
+	  (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j);
+      !popstop_tbl.(i) 
+    end
+
+let stop = popstop_code 0
+ 
+(******************************************************)
+(* Types de donnees abstraites et fonctions associees *)
+(******************************************************)
+
+(* Values of the abstract machine *)
+let val_of_obj v = ((Obj.obj v):values)
+let crasy_val = (val_of_obj (Obj.repr 0))
+
+(* Abstract data *)
+type vprod 
+type vfun
+type vfix
+type vcofix
+type vblock
+type arguments
+
+type vm_env      
+type vstack = values array
+
+type vswitch = {
+    sw_type_code : tcode; 
+    sw_code : tcode; 
+    sw_annot : annot_switch;
+    sw_stk : vstack;
+    sw_env : vm_env
+  } 
+
+(* Representation des types abstraits:                                    *)
+(* + Les produits :                                                       *)
+(*   -   vprod = 0_[ dom | codom]                                         *)
+(*             dom : values, codom : vfun                                 *)
+(*                                                                        *)
+(* + Les fonctions ont deux representations possibles :                   *)
+(*   - fonction non applique :  vf = Ct_[ C | fv1 | ... | fvn]            *) 
+(*                                       C:tcode, fvi : values            *)
+(*     Remarque : il n'y a pas de difference entre la fct et son          *)
+(*                environnement.                                          *) 
+(*   - Application partielle  : Ct_[Restart:C| vf | arg1 | ... argn]      *)
+(*                                                                        *)
+(* + Les points fixes :                                                   *)
+(*   -        Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn]               *)
+(*     Remarque il n'y a qu'un seul block pour representer tout les       *)
+(*     points fixes d'une declaration mutuelle, chaque point fixe         *)
+(*     pointe sur la position de son code dans le block.                  *)
+(*   - L'application partielle d'un point fixe suit le meme schema        *)
+(*     que celui des fonctions                                            *)
+(*     Remarque seul les points fixes qui n'ont pas encore recu leur      *)
+(*     argument recursif sont encode de cette maniere (si l'argument      *)
+(*     recursif etait un constructeur le point fixe se serait reduit      *)
+(*     sinon il est represente par un accumulateur)                       *)
+(*                                                                        *)
+(* + Les cofix sont expliques dans cbytegen.ml                            *)
+(*                                                                        *)
+(* + Les vblock encodent les constructeurs (non constant) de caml,        *)
+(*   la difference est que leur tag commence a 1 (0 est reserve pour les  *)
+(*   accumulateurs : accu_tag)                                            *)
+(*                                                                        *)
+(* + vm_env est le type des environnement machine (une fct ou un pt fixe) *)
+(*                                                                        *)
+(* + Les accumulateurs : At_[accumulate| accu | arg1 | ... | argn ]       *)
+(*   - representation des [accu] : tag_[....]                             *)
+(*     -- tag <= 2 : encodage du type atom                                *)
+(*     -- 3_[accu|fix_app] : un point fixe bloque par un accu             *)
+(*     -- 4_[accu|vswitch] : un case bloque par un accu                   *)
+(*     -- 5_[fcofix]       : une fonction de cofix                        *)
+(*     -- 6_[fcofix|val]   : une fonction de cofix, val represente        *)
+(*        la valeur de la reduction de la fct applique a arg1 ... argn    *) 
+(* Le type [arguments] est utiliser de maniere abstraite comme un         *)
+(* tableau, il represente la structure de donnee suivante :               *)
+(*          tag[ _ | _ |v1|... | vn]                                      *)
+(* Generalement le 1er champs est un pointeur de code                     *)
+
+(* Ne pas changer ce type sans modifier le code C, *)
+(* en particulier le fichier "coq_values.h"        *)
+type atom = 
+  | Aid of id_key
+  | Aiddef of id_key * values
+  | Aind of inductive
+
+(* Les zippers *)
+
+type zipper =
+  | Zapp of arguments
+  | Zfix of vfix*arguments  (* Peut-etre vide *)
+  | Zswitch of vswitch
+
+type stack = zipper list
+
+type to_up = values
+
+type whd =
+  | Vsort of sorts
+  | Vprod of vprod 
+  | Vfun of vfun
+  | Vfix of vfix * arguments option
+  | Vcofix of vcofix * to_up * arguments option
+  | Vconstr_const of int
+  | Vconstr_block of vblock
+  | Vatom_stk of atom * stack
+
+(*************************************************)
+(* Destructors ***********************************)
+(*************************************************)
+
+let rec whd_accu a stk =
+  let stk = 
+    if Obj.size a = 2 then stk
+    else Zapp (Obj.obj a) :: stk in
+  let at = Obj.field a 1 in
+  match Obj.tag at with
+  | i when i <= 2 -> 
+      Vatom_stk(Obj.magic at, stk)
+  | 3 (* fix_app tag *) ->
+      let fa = Obj.field at 1 in
+      let zfix  = 
+	Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in
+      whd_accu (Obj.field at 0) (zfix :: stk)
+  | 4 (* switch tag  *) ->
+      let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in
+      whd_accu (Obj.field at 0) (zswitch :: stk)
+  | 5 (* cofix_tag *) ->
+      begin match stk with
+      | [] -> 
+	  let vcfx = Obj.obj (Obj.field at 0) in
+	  let to_up = Obj.obj a in
+	  Vcofix(vcfx, to_up, None)
+      | [Zapp args] ->
+	  let vcfx = Obj.obj (Obj.field at 0) in
+	  let to_up = Obj.obj a in
+	  Vcofix(vcfx, to_up, Some args)
+      | _           -> assert false
+      end
+  | 6 (* cofix_evaluated_tag *) ->
+      begin match stk with
+      | [] ->
+	  let vcofix = Obj.obj (Obj.field at 0) in
+	  let res = Obj.obj a in
+	  Vcofix(vcofix, res, None)
+      | [Zapp args] -> 
+	  let vcofix = Obj.obj (Obj.field at 0) in
+	  let res = Obj.obj a in
+	  Vcofix(vcofix, res, Some args)
+      | _ -> assert false
+      end
+  | _ -> assert false
+
+external kind_of_closure : Obj.t -> int = "coq_kind_of_closure"
+
+let whd_val : values -> whd =
+  fun v -> 
+    let o = Obj.repr v in 
+    if Obj.is_int o then Vconstr_const (Obj.obj o)
+    else 
+      let tag = Obj.tag o in
+      if tag = accu_tag then
+	(
+	if Obj.size o = 1 then Obj.obj o (* sort *)
+	else 
+	  if is_accumulate (fun_code o) then whd_accu o []
+	  else (Vprod(Obj.obj o)))
+      else 
+	if tag = Obj.closure_tag || tag = Obj.infix_tag then
+	  (	   match kind_of_closure o with
+	   | 0 -> Vfun(Obj.obj o)
+	   | 1 -> Vfix(Obj.obj o, None)
+	   | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o))
+	   | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), [])
+	   | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work")
+	else Vconstr_block(Obj.obj o)
+	
+
+
+(************************************************)
+(* La machine abstraite *************************)
+(************************************************)
+
+(* gestion de la pile *)
+external push_ra : tcode -> unit = "coq_push_ra"
+external push_val : values -> unit = "coq_push_val"
+external push_arguments : arguments -> unit = "coq_push_arguments"
+external push_vstack : vstack -> unit = "coq_push_vstack"
+
+
+(* interpreteur *)
+external interprete : tcode -> values -> vm_env -> int -> values =
+  "coq_interprete_ml"
+
+
+
+(* Functions over arguments *)
+let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2
+let arg args i = 
+  if  0 <= i && i < (nargs args) then 
+    val_of_obj (Obj.field (Obj.repr args) (i+2))
+  else raise (Invalid_argument 
+		("Vm.arg size = "^(string_of_int (nargs args))^
+		 " acces "^(string_of_int i)))
+
+let apply_arguments vf vargs =
+  let n = nargs vargs in
+  if n = 0 then vf 
+  else
+   begin
+     push_ra stop;
+     push_arguments vargs;
+     interprete (fun_code vf) vf (Obj.magic vf) (n - 1)
+   end
+
+let apply_vstack vf vstk =
+  let n = Array.length vstk in
+  if n = 0 then vf
+  else 
+    begin
+      push_ra stop;
+      push_vstack vstk;
+      interprete (fun_code vf) vf (Obj.magic vf) (n - 1)
+    end
+
+(**********************************************)
+(* Constructeurs ******************************)
+(**********************************************)
+
+let obj_of_atom : atom -> Obj.t =
+  fun a -> 
+    let res = Obj.new_block accu_tag 2 in
+    Obj.set_field res 0 (Obj.repr accumulate);
+    Obj.set_field res 1 (Obj.repr a);
+    res 
+
+(* obj_of_str_const : structured_constant -> Obj.t *)
+let rec obj_of_str_const str =
+  match str with 
+  | Const_sorts s -> Obj.repr (Vsort s)
+  | Const_ind ind -> obj_of_atom (Aind ind)
+  | Const_b0 tag -> Obj.repr tag
+  | Const_bn(tag, args) ->
+      let len = Array.length args in
+      let res = Obj.new_block tag len in
+      for i = 0 to len - 1 do 
+	Obj.set_field res i (obj_of_str_const args.(i)) 
+      done;
+      res
+
+let val_of_obj o = ((Obj.obj o) : values)
+
+let val_of_str_const str = val_of_obj (obj_of_str_const str)
+
+let val_of_atom a = val_of_obj (obj_of_atom a)
+
+let idkey_tbl = Hashtbl.create 31
+
+let val_of_idkey key =
+  try Hashtbl.find idkey_tbl key 
+  with Not_found -> 
+    let v = val_of_atom (Aid key) in
+    Hashtbl.add idkey_tbl key v;
+    v
+
+let val_of_rel k = val_of_idkey (RelKey k)
+let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v))
+
+let val_of_named id = val_of_idkey (VarKey id)
+let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v))
+  
+let val_of_constant c = val_of_idkey (ConstKey c)
+let val_of_constant_def n c v = 
+  let res = Obj.new_block accu_tag 2 in
+  Obj.set_field res 0 (Obj.repr (mkAccuCond n));
+  Obj.set_field res 1 (Obj.repr (Aiddef(ConstKey c, v)));
+  val_of_obj res
+
+let mkrel_vstack k arity =
+  let max = k + arity - 1 in
+  Array.init arity (fun i -> val_of_rel (max - i))
+
+(*************************************************)
+(** Operations pour la manipulation des donnees **)
+(*************************************************)
+
+
+(* Functions over products *)
+
+let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) 
+let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1))
+
+(* Functions over vfun *)
+
+external closure_arity : vfun -> int = "coq_closure_arity"
+
+let body_of_vfun k vf =
+  let vargs = mkrel_vstack k 1 in
+  apply_vstack (Obj.magic vf) vargs
+
+let decompose_vfun2 k vf1 vf2 =
+  let arity = min (closure_arity vf1) (closure_arity vf2) in
+  assert (0 < arity && arity < Sys.max_array_length);
+  let vargs = mkrel_vstack k arity in
+  let v1 = apply_vstack (Obj.magic vf1) vargs in
+  let v2 = apply_vstack (Obj.magic vf2) vargs in
+  arity, v1, v2
+
+(* Functions over fixpoint *)
+
+let first o = (offset_closure o (offset o))
+let last o = (Obj.field o (Obj.size o - 1))
+
+let current_fix vf = - (offset (Obj.repr vf) / 2)
+
+let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i))
+
+let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1
+  
+let rec_args vf =
+  let fb = first (Obj.repr vf) in
+  let size = Obj.size (last fb) in
+  Array.init size (unsafe_rec_arg fb)
+
+exception FALSE
+
+let check_fix f1 f2 = 
+  let i1, i2 = current_fix f1, current_fix f2 in
+  (* Verification du point de depart *)
+  if i1 = i2 then
+    let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in
+    let n = Obj.size (last fb1) in
+    (* Verification du nombre de definition *)
+    if n = Obj.size (last fb2) then
+      (* Verification des arguments recursifs *)
+      try
+	for i = 0 to n - 1 do
+	  if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i
+	  then raise FALSE
+	done;
+	true
+      with FALSE -> false
+    else false 
+  else false
+
+(* Functions over vfix *)
+external atom_rel : unit -> atom array = "get_coq_atom_tbl"
+external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl"
+
+let relaccu_tbl =  
+  let atom_rel = atom_rel() in
+  let len = Array.length atom_rel in
+  for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done;
+  ref (Array.init len mkAccuCode) 
+
+let relaccu_code i =
+  let len = Array.length !relaccu_tbl in
+  if i < len then !relaccu_tbl.(i) 
+  else
+    begin
+      realloc_atom_rel i;
+      let atom_rel = atom_rel () in
+      let nl = Array.length atom_rel in
+      for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done;
+      relaccu_tbl :=
+	Array.init nl
+	  (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j);
+      !relaccu_tbl.(i) 
+    end
+
+let reduce_fix k vf =
+  let fb = first (Obj.repr vf) in
+  (* calcul des types *)
+  let fc_typ = ((Obj.obj (last fb)) : tcode array) in
+  let ndef = Array.length fc_typ in
+  let et = offset_closure fb (2*(ndef - 1)) in
+  let ftyp =  
+    Array.map 
+      (fun c -> interprete c crasy_val (Obj.magic et) 0) fc_typ in
+  (* Construction de l' environnement des corps des points fixes *)
+  let e = Obj.dup fb in
+  for i = 0 to ndef - 1 do
+    Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i)))
+  done;
+  let fix_body i =
+    let jump_grabrec c = offset_tcode c 2 in
+    let c = jump_grabrec (unsafe_fb_code fb i)  in
+    let res = Obj.new_block Obj.closure_tag 2 in
+    Obj.set_field res 0 (Obj.repr c);
+    Obj.set_field res 1 (offset_closure e (2*i));
+    ((Obj.obj res) : vfun)  in 
+  (Array.init ndef fix_body, ftyp)
+ 
+(* Functions over vcofix *)
+
+let get_fcofix vcf i = 
+  match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with
+  | Vcofix(vcfi, _, _) -> vcfi
+  | _ -> assert false
+
+let current_cofix vcf =
+  let ndef = Obj.size (last (Obj.repr vcf)) in
+  let rec find_cofix pos =
+    if pos < ndef then
+      if get_fcofix vcf pos == vcf then pos
+      else find_cofix (pos+1)
+    else raise Not_found in
+  try find_cofix 0
+  with _ -> assert false
+
+let check_cofix vcf1 vcf2 =
+  (current_cofix vcf1 = current_cofix vcf2) &&
+  (Obj.size (last (Obj.repr vcf1)) = Obj.size (last (Obj.repr vcf2)))
+
+let reduce_cofix k vcf =
+  let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in
+  let ndef = Array.length fc_typ in
+  let ftyp =  
+    Array.map (fun c -> interprete c crasy_val (Obj.magic vcf) 0) fc_typ in
+  (* Construction de l'environnement des corps des cofix *)
+
+  let e = Obj.dup (Obj.repr vcf) in 
+  for i = 0 to ndef - 1 do
+    Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) 
+  done;
+   
+  let cofix_body i =
+    let vcfi = get_fcofix vcf i in
+    let c = Obj.field (Obj.repr vcfi) 0 in
+    Obj.set_field e 0 c; 
+    let atom = Obj.new_block cofix_tag 1 in
+    let self = Obj.new_block accu_tag 2 in
+    Obj.set_field self 0 (Obj.repr accumulate);
+    Obj.set_field self 1 (Obj.repr atom);
+    apply_vstack (Obj.obj e) [|Obj.obj self|] in  
+  (Array.init ndef cofix_body, ftyp)
+
+
+(* Functions over vblock *)
+  
+let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b)
+let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b)
+let bfield b i =
+  if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i)
+  else raise (Invalid_argument "Vm.bfield")
+
+
+(* Functions over vswitch *)
+
+let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl 
+    
+let case_info sw = sw.sw_annot.ci
+    
+let type_of_switch sw = 
+  push_vstack sw.sw_stk;
+  interprete sw.sw_type_code crasy_val sw.sw_env 0 
+    
+let branch_arg k (tag,arity) = 
+  if arity = 0 then  ((Obj.magic tag):values)
+  else
+    let b = Obj.new_block tag arity in
+    for i = 0 to arity - 1 do
+      Obj.set_field b i (Obj.repr (val_of_rel (k+i)))
+    done;
+    val_of_obj b
+
+let apply_switch sw arg =
+  let tc = sw.sw_annot.tailcall in
+  if tc then 
+    (push_ra stop;push_vstack sw.sw_stk)
+  else 
+    (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk)));
+  interprete sw.sw_code arg sw.sw_env 0
+        
+let branch_of_switch k sw =
+  let eval_branch (_,arity as ta) =
+    let arg = branch_arg k ta in
+    let v = apply_switch sw arg in
+    (arity, v)
+  in 
+  Array.map eval_branch sw.sw_annot.rtbl
+	
+
+(* Evaluation *)
+
+
+let is_accu v = 
+  let o = Obj.repr v in
+  Obj.is_block o && Obj.tag o = accu_tag && 
+  fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag 
+
+let rec whd_stack v stk =  
+  match stk with
+  | [] -> whd_val v
+  | Zapp args :: stkt -> whd_stack (apply_arguments v args) stkt
+  | Zfix (f,args) :: stkt -> 
+      let o = Obj.repr v in
+      if Obj.is_block o && Obj.tag o = accu_tag then
+	whd_accu (Obj.repr v) stk
+      else 
+	let v', stkt =
+	  match stkt with
+	  | Zapp args' :: stkt ->
+	      push_ra stop;
+	      push_arguments args';
+	      push_val v;
+	      push_arguments args;
+	      let v' =
+		interprete (fun_code f) (Obj.magic f) (Obj.magic f) 
+		  (nargs args+ nargs args') in
+	      v', stkt
+	  | _ -> 
+	      push_ra stop;
+	      push_val v;
+	      push_arguments args;
+	      let v' =
+		interprete (fun_code f) (Obj.magic f) (Obj.magic f) 
+		  (nargs args) in
+	      v', stkt
+	in
+	whd_stack v' stkt
+  | Zswitch sw :: stkt -> 
+      let o = Obj.repr v in
+      if Obj.is_block o && Obj.tag o = accu_tag then
+	if Obj.tag (Obj.field o 1) < cofix_tag then whd_accu (Obj.repr v) stk
+	else
+	  let to_up = 
+	    match whd_accu (Obj.repr v) [] with
+	    | Vcofix (_, to_up, _) -> to_up
+	    | _ -> assert false in
+	  whd_stack (apply_switch sw to_up) stkt
+      else whd_stack (apply_switch sw v) stkt 
+
+let rec force_whd v stk =
+  match whd_stack v stk with
+  | Vatom_stk(Aiddef(_,v),stk) -> force_whd v stk
+  | res -> res
+
+
+
+
+
diff --git a/kernel/vm.mli b/kernel/vm.mli
new file mode 100644
index 00000000..279ac937
--- /dev/null
+++ b/kernel/vm.mli
@@ -0,0 +1,104 @@
+open Names
+open Term
+open Cbytecodes
+open Cemitcodes
+
+
+val set_drawinstr : unit -> unit
+
+val transp_values : unit -> bool
+val set_transp_values : bool -> unit
+(* le code machine *)
+type tcode 
+
+(* Les valeurs ***********)
+
+type vprod 
+type vfun
+type vfix
+type vcofix
+type vblock
+type vswitch
+type arguments
+
+type atom = 
+  | Aid of id_key
+  | Aiddef of id_key * values
+  | Aind of inductive
+
+(* Les zippers *)
+
+type zipper =
+  | Zapp of arguments
+  | Zfix of vfix*arguments  (* Peut-etre vide *)
+  | Zswitch of vswitch
+
+type stack = zipper list
+
+type to_up
+
+type whd =
+  | Vsort of sorts
+  | Vprod of vprod 
+  | Vfun of vfun
+  | Vfix of vfix * arguments option
+  | Vcofix of vcofix * to_up * arguments option
+  | Vconstr_const of int
+  | Vconstr_block of vblock
+  | Vatom_stk of atom * stack
+ 
+(** Constructors *)
+val val_of_str_const : structured_constant -> values
+
+val val_of_rel : int -> values 
+val val_of_rel_def : int -> values -> values 
+
+val val_of_named : identifier -> values
+val val_of_named_def : identifier -> values -> values
+
+val val_of_constant : constant -> values 
+val val_of_constant_def : int -> constant -> values -> values
+
+(** Destructors *)
+val whd_val : values -> whd
+
+(* Arguments *)  
+val nargs : arguments -> int
+val arg : arguments -> int -> values
+
+(* Product *)
+val dom : vprod -> values
+val codom : vprod -> vfun
+
+(* Function *)
+val body_of_vfun : int -> vfun -> values 
+val decompose_vfun2  : int -> vfun -> vfun -> int * values * values
+
+(* Fix *)
+val current_fix : vfix -> int
+val check_fix : vfix -> vfix -> bool
+val rec_args : vfix -> int array 
+val reduce_fix : int -> vfix -> vfun array * values array
+                              (* bodies ,  types *)
+
+(* CoFix *)
+val current_cofix : vcofix -> int 
+val check_cofix : vcofix -> vcofix -> bool
+val reduce_cofix : int -> vcofix -> values array * values array
+                                      (* bodies , types *)
+(* Block *)
+val btag : vblock -> int
+val bsize : vblock -> int
+val bfield : vblock -> int -> values
+
+(* Switch *)
+val check_switch : vswitch -> vswitch -> bool
+val case_info : vswitch -> case_info
+val type_of_switch : vswitch -> values
+val branch_of_switch : int -> vswitch -> (int * values) array
+
+(* Evaluation *)
+val whd_stack : values -> stack -> whd
+val force_whd : values -> stack -> whd
+
+
diff --git a/lib/bigint.ml b/lib/bigint.ml
new file mode 100644
index 00000000..5bcceb5c
--- /dev/null
+++ b/lib/bigint.ml
@@ -0,0 +1,392 @@
+(************************************************************************)
+(*  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: bigint.ml 7305 2005-08-19 19:51:02Z letouzey $ *)
+
+(*i*)
+open Pp
+(*i*)
+
+(***************************************************)
+(* Basic operations on (unbounded) integer numbers *)
+(***************************************************)
+
+(* An integer is canonically represented as an array of k-digits blocs.
+
+   0 is represented by the empty array and -1 by the singleton [|-1|].
+   The first bloc is in the range ]0;10^k[ for positive numbers. 
+   The first bloc is in the range ]-10^k;-1[ for negative ones. 
+   All other blocs are numbers in the range [0;10^k[.
+
+   Negative numbers are represented using 2's complementation. For instance,
+   with 4-digits blocs, [-9655;6789] denotes -96543211
+*)
+
+(* The base is a power of 10 in order to facilitate the parsing and printing
+   of numbers in digital notation.
+
+   All functions, to the exception of to_string and of_string should work
+   with an arbitrary base, even if not a power of 10.
+
+   In practice, we set k=4 so that no overflow in ocaml machine words
+   (i.e. the interval [-2^30;2^30-1]) occur when multiplying two
+   numbers less than (10^k)
+*)
+
+(* The main parameters *)
+
+let size =
+  let rec log10 n = if n < 10 then 0 else 1 + log10 (n / 10) in
+  (log10 max_int) / 2
+
+let format_size =
+  (* How to parametrize a printf format *)
+  if size = 4 then Printf.sprintf "%04d"
+  else fun n ->
+    let rec aux j l n =
+      if j=size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10)
+    in String.concat "" (aux 0 [] n)
+
+(* The base is 10^size *)
+let base =
+  let rec exp10 = function 0 -> 1 | n -> 10 * exp10 (n-1) in exp10 size
+
+(* Basic numbers *)
+let zero = [||]
+let neg_one = [|-1|]
+
+(* Sign of an integer *)
+let is_strictly_neg n = n<>[||] && n.(0) < 0
+let is_strictly_pos n = n<>[||] && n.(0) > 0
+let is_neg_or_zero n = n=[||] or n.(0) < 0
+let is_pos_or_zero n = n=[||] or n.(0) > 0
+
+let normalize_pos n =
+  let k = ref 0 in
+  while !k < Array.length n & n.(!k) = 0 do incr k done;
+  Array.sub n !k (Array.length n - !k)
+
+let normalize_neg n =
+  let k = ref 1 in
+  while !k < Array.length n & n.(!k) = base - 1 do incr k done;
+  let n' = Array.sub n !k (Array.length n - !k) in
+  if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
+
+let rec normalize n =
+  if Array.length n = 0 then n else 
+    if n.(0) = -1 then normalize_neg n else normalize_pos n
+
+let neg m =
+  if m = zero then zero else
+  let n = Array.copy m in
+  let i = ref (Array.length m - 1) in
+  while !i > 0 & n.(!i) = 0 do decr i done;
+  if !i > 0 then begin
+    n.(!i) <- base - n.(!i); decr i;
+    while !i > 0 do n.(!i) <- base - 1 - n.(!i); decr i done;
+    n.(0) <- - n.(0) - 1;
+    if n.(0) < -1 then (n.(0) <- n.(0) + base; Array.append [| -1 |] n) else
+    if n.(0) = - base then (n.(0) <- 0; Array.append [| -1 |] n)
+    else normalize n
+  end else (n.(0) <- - n.(0); n)
+
+let push_carry r j =
+  let j = ref j in
+  while !j > 0 & r.(!j) < 0 do
+    r.(!j) <- r.(!j) + base; decr j; r.(!j) <- r.(!j) - 1
+  done;
+  while !j > 0 & r.(!j) >= base do
+    r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1
+  done;
+  if r.(0) >= base then (r.(0) <- r.(0) - base; Array.append [| 1 |] r)
+  else if r.(0) < -base then (r.(0) <- r.(0) + 2*base; Array.append [| -2 |] r)
+  else if r.(0) = -base then (r.(0) <- 0; Array.append [| -1 |] r)
+  else normalize r
+
+let add_to r a j =
+  if a = zero then r else begin
+  for i = Array.length r - 1 downto j+1 do
+    r.(i) <- r.(i) + a.(i-j);
+    if r.(i) >= base then (r.(i) <- r.(i) - base; r.(i-1) <- r.(i-1) + 1)
+  done;
+  r.(j) <- r.(j) + a.(0);
+  push_carry r j
+  end
+
+let add n m =
+  let d = Array.length n - Array.length m in
+  if d > 0 then add_to (Array.copy n) m d else add_to (Array.copy m) n (-d)
+
+let sub_to r a j =
+  if a = zero then r else begin
+  for i = Array.length r - 1 downto j+1 do
+    r.(i) <- r.(i) - a.(i-j);
+    if r.(i) < 0 then (r.(i) <- r.(i) + base; r.(i-1) <- r.(i-1) - 1)
+  done;
+  r.(j) <- r.(j) - a.(0);
+  push_carry r j
+  end
+
+let sub n m =
+  let d = Array.length n - Array.length m in
+  if d >= 0 then sub_to (Array.copy n) m d
+  else let r = neg m in add_to r n (Array.length r - Array.length n)
+
+let rec mult m n =
+  if m = zero or n = zero then zero else
+  let l = Array.length m + Array.length n in
+  let r = Array.create l 0 in
+  for i = Array.length m - 1 downto 0 do
+    for j = Array.length n - 1 downto 0 do
+      let p = m.(i) * n.(j) + r.(i+j+1) in
+      let (q,s) =
+        if p < 0
+        then (p + 1) / base - 1, (p + 1) mod base + base - 1
+        else p / base, p mod base in
+      r.(i+j+1) <- s;
+      if q <> 0 then r.(i+j) <- r.(i+j) + q;
+    done
+  done;
+  normalize r
+
+let rec less_than_same_size m n i j =
+  i < Array.length m &&
+  (m.(i) < n.(j) or (m.(i) = n.(j) && less_than_same_size m n (i+1) (j+1)))
+
+let less_than m n =
+  if is_strictly_neg m then
+    is_pos_or_zero n or Array.length m > Array.length n
+      or (Array.length m = Array.length n && less_than_same_size m n 0 0)
+  else
+    is_strictly_pos n && (Array.length m < Array.length n or
+    (Array.length m = Array.length n && less_than_same_size m n 0 0))
+
+let equal m n = (m = n)
+  
+let less_or_equal_than m n = equal m n or less_than m n
+
+let less_than_shift_pos k m n =
+  (Array.length m - k < Array.length n)
+  or (Array.length m - k = Array.length n && less_than_same_size m n k 0)
+
+let rec can_divide k m d i =
+  (i = Array.length d) or
+  (m.(k+i) > d.(i)) or
+  (m.(k+i) = d.(i) && can_divide k m d (i+1))
+
+(* computes m - d * q * base^(|m|-k) in-place on positive numbers *)
+let sub_mult m d q k =
+  if q <> 0 then
+  for i = Array.length d - 1 downto 0 do
+    let v = d.(i) * q in
+    m.(k+i) <- m.(k+i) - v mod base;
+    if m.(k+i) < 0 then (m.(k+i) <- m.(k+i) + base; m.(k+i-1) <- m.(k+i-1) -1);
+    if v >= base then m.(k+i-1) <- m.(k+i-1) - v / base;
+  done
+
+let euclid m d =
+  let isnegm, m =
+    if is_strictly_neg m then (-1),neg m else 1,Array.copy m in
+  let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in
+  if d = zero then raise Division_by_zero;
+  let q,r = 
+    if less_than m d then (zero,m) else
+    let ql = Array.length m - Array.length d in
+    let q = Array.create (ql+1) 0 in
+    let i = ref 0 in
+    while not (less_than_shift_pos !i m d) do
+      if m.(!i)=0 then incr i else
+      if can_divide !i m d 0 then begin
+        let v = 
+          if Array.length d > 1 && d.(0) <> m.(!i) then
+            (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1)
+          else
+            m.(!i) / d.(0) in
+        q.(!i) <- q.(!i) + v;
+	sub_mult m d v !i
+      end else begin
+        let v = (m.(!i) * base + m.(!i+1)) / (d.(0) + 1) in
+        q.(!i) <- q.(!i) + v / base;
+	sub_mult m d (v / base) !i;
+        q.(!i+1) <- q.(!i+1) + v mod base;
+	if q.(!i+1) >= base then
+	  (q.(!i+1) <- q.(!i+1)-base; q.(!i) <- q.(!i)+1);
+	sub_mult m d (v mod base) (!i+1)
+      end
+    done;
+    (normalize q, normalize m) in
+  (if isnegd * isnegm = -1 then neg q else q),
+  (if isnegm = -1 then neg r else r)
+
+(* Parsing/printing ordinary 10-based numbers *)
+
+let of_string s =
+  let isneg = String.length s > 1 & s.[0] = '-' in
+  let n = if isneg then 1 else 0 in
+  let d = ref n in
+  while !d < String.length s && s.[!d] = '0' do incr d done;
+  if !d = String.length s then zero else
+  let r = (String.length s - !d) mod size in
+  let h = String.sub s (!d) r in
+  if !d = String.length s - 1 && isneg && h="1" then neg_one else
+  let e = if h<>"" then 1 else 0 in 
+  let l = (String.length s - !d) / size in
+  let a = Array.create (l + e + n) 0 in
+  if isneg then begin
+    a.(0) <- (-1); 
+    let carry = ref 0 in
+    for i=l downto 1 do
+      let v = int_of_string (String.sub s ((i-1)*size + !d +r) size)+ !carry in
+      if v <> 0 then (a.(i+e)<- base - v; carry := 1) else carry := 0
+    done;
+    if e=1 then a.(1) <- base - !carry - int_of_string h;
+  end
+  else begin
+    if e=1 then a.(0) <- int_of_string h;
+    for i=1 to l do
+      a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size)
+    done
+  end;
+  a
+
+let to_string_pos sgn n =
+   if Array.length n = 0 then "0" else
+     sgn ^
+     String.concat ""
+      (string_of_int n.(0) :: List.map format_size (List.tl (Array.to_list n)))
+
+let to_string n =
+  if is_strictly_neg n then to_string_pos "-" (neg n)
+  else to_string_pos "" n
+
+(******************************************************************)
+(* Optimized operations on (unbounded) integer numbers            *)
+(* integers smaller than base are represented as machine integers *)
+(******************************************************************)
+
+type bigint = Obj.t
+
+let ints_of_int n =
+  if n >= base then [| n / base; n mod base |]
+  else if n <= - base then [| n / base - 1; n mod base + base |]
+  else if n = 0 then [| |] else [| n |]
+
+let big_of_int n =
+  if n >= base then Obj.repr [| n / base; n mod base |]
+  else if n <= - base then Obj.repr [| n / base - 1; n mod base + base |]
+  else Obj.repr n
+
+let big_of_ints n =
+  let n = normalize n in
+  if n = zero then Obj.repr 0 else
+  if Array.length n = 1 then Obj.repr n.(0) else
+  Obj.repr n
+
+let coerce_to_int = (Obj.magic : Obj.t -> int)
+let coerce_to_ints = (Obj.magic : Obj.t -> int array)
+
+let ints_of_z n =
+  if Obj.is_int n then ints_of_int (coerce_to_int n)
+  else coerce_to_ints n
+
+let app_pair f (m, n) =
+  (f m, f n)
+
+let add m n =
+  if Obj.is_int m & Obj.is_int n 
+  then big_of_int (coerce_to_int m + coerce_to_int n)
+  else big_of_ints (add (ints_of_z m) (ints_of_z n))
+
+let sub m n =
+  if Obj.is_int m & Obj.is_int n
+  then big_of_int (coerce_to_int m - coerce_to_int n)
+  else big_of_ints (sub (ints_of_z m) (ints_of_z n))
+
+let mult m n =
+  if Obj.is_int m & Obj.is_int n
+  then big_of_int (coerce_to_int m * coerce_to_int n)
+  else big_of_ints (mult (ints_of_z m) (ints_of_z n))
+
+let euclid m n =
+  if Obj.is_int m & Obj.is_int n 
+  then app_pair big_of_int 
+    (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n)
+  else app_pair big_of_ints (euclid (ints_of_z m) (ints_of_z n))
+
+let less_than m n =
+  if Obj.is_int m & Obj.is_int n
+  then coerce_to_int m < coerce_to_int n
+  else less_than (ints_of_z m) (ints_of_z n)
+
+let neg n =
+  if Obj.is_int n then big_of_int (- (coerce_to_int n))
+  else big_of_ints (neg (ints_of_z n))
+
+let of_string m = big_of_ints (of_string m)
+let to_string m = to_string (ints_of_z m)
+
+let zero = big_of_int 0
+let one = big_of_int 1
+let sub_1 n = sub n one
+let add_1 n = add n one
+let two = big_of_int 2
+let neg_two = big_of_int (-2)
+let mult_2 n = add n n
+let is_zero n = n=zero
+
+let div2_with_rest n =
+  let (q,b) = euclid n two in
+  (q, b = one)
+
+let is_strictly_neg n = is_strictly_neg (ints_of_z n)
+let is_strictly_pos n = is_strictly_pos (ints_of_z n)
+let is_neg_or_zero n = is_neg_or_zero (ints_of_z n)
+let is_pos_or_zero n = is_pos_or_zero (ints_of_z n)
+
+let pr_bigint n = str (to_string n)
+
+(* Testing suite *)
+
+let check () =
+  let numbers = [
+  "1";"2";"99";"100";"101";"9999";"10000";"10001";
+  "999999";"1000000";"1000001";"99999999";"100000000";"100000001";
+  "1234";"5678";"12345678";"987654321";
+  "-1";"-2";"-99";"-100";"-101";"-9999";"-10000";"-10001";
+  "-999999";"-1000000";"-1000001";"-99999999";"-100000000";"-100000001";
+  "-1234";"-5678";"-12345678";"-987654321";"0"
+  ]
+  in
+  let eucl n m =
+    let n' = abs_float n and m' = abs_float m in
+    let q' = floor (n' /. m') in let r' = n' -. m' *. q' in
+    (if n *. m < 0. & q' <> 0. then -. q' else q'),
+    (if n < 0. then -. r' else r') in
+  let round f = floor (abs_float f +. 0.5) *. (if f < 0. then -1. else 1.) in
+  let i = ref 0 in
+  let compare op n n' =
+    incr i;
+    let s = Printf.sprintf "%30s" (to_string n) in
+    let s' = Printf.sprintf "% 30.0f" (round n') in
+    if s <> s' then Printf.printf "%s: %s <> %s\n" op s s' in
+List.iter (fun a -> List.iter (fun b ->  
+  let n = of_string a and m = of_string b in
+  let n' = float_of_string a and m' = float_of_string b in
+  let a = add n m and a' = n' +. m' in
+  let s = sub n m and s' = n' -. m' in
+  let p = mult n m and p' = n' *. m' in
+  let q,r = try euclid n m with Division_by_zero -> zero,zero
+  and q',r' = eucl n' m' in
+  compare "+" a a';
+  compare "-" s s';
+  compare "*" p p';
+  compare "/" q q';
+  compare "%" r r') numbers) numbers;
+  Printf.printf "%i tests done\n" !i
+
+
diff --git a/lib/bigint.mli b/lib/bigint.mli
new file mode 100644
index 00000000..7a835a49
--- /dev/null
+++ b/lib/bigint.mli
@@ -0,0 +1,45 @@
+(************************************************************************)
+(*  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: bigint.mli 6616 2005-01-21 17:18:23Z herbelin $ i*)
+
+(*i*)
+open Pp
+(*i*)
+
+(* Arbitrary large integer numbers *)
+
+type bigint
+
+val of_string : string -> bigint
+val to_string : bigint -> string
+
+val zero : bigint
+val one : bigint
+val two : bigint
+
+val div2_with_rest : bigint -> bigint * bool (* true=odd; false=even *)
+val add_1 : bigint -> bigint
+val sub_1 : bigint -> bigint
+val mult_2 : bigint -> bigint
+
+val add : bigint -> bigint -> bigint
+val sub : bigint -> bigint -> bigint
+val mult : bigint -> bigint -> bigint
+val euclid : bigint -> bigint -> bigint * bigint
+
+val less_than : bigint -> bigint -> bool
+val equal : bigint -> bigint -> bool
+
+val is_strictly_pos : bigint -> bool
+val is_strictly_neg : bigint -> bool
+val is_pos_or_zero : bigint -> bool
+val is_neg_or_zero : bigint -> bool
+val neg : bigint -> bigint
+
+val pr_bigint : bigint -> std_ppcmds
diff --git a/lib/bignat.ml b/lib/bignat.ml
deleted file mode 100644
index 583a027f..00000000
--- a/lib/bignat.ml
+++ /dev/null
@@ -1,116 +0,0 @@
-(************************************************************************)
-(*  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: bignat.ml,v 1.5.6.1 2004/07/16 19:30:29 herbelin Exp $ *)
-
-(*i*)
-open Pp
-(*i*)
-
-(* Arbitrary big natural numbers *)
-
-type bignat = int array
-
-let digits =            8
-let base =      100000000 (* let enough room for multiplication by 2 *)
-let base_div_2 = 50000000
-let base_to_string x = Printf.sprintf "%08d" x
-
-let of_string s =
-  let a = Array.create (String.length s / digits + 1) 0 in
-  let r = String.length s mod digits in
-  if r<>0 then a.(0) <- int_of_string (String.sub s 0 r);
-  for i = 1 to String.length s / digits do
-    a.(i) <- int_of_string (String.sub s ((i-1)*digits+r) digits)
-  done;
-  a
-
-let rec to_string s =
-  if s = [||] then "0" else
-    if s.(0) = 0 then to_string (Array.sub s 1 (Array.length s - 1))
-    else 
-      String.concat ""
-        ((string_of_int (s.(0)))
-        ::(List.tl (Array.to_list (Array.map base_to_string s))))
-  
-let is_nonzero a =
-  let b = ref false in Array.iter (fun x -> b := x <> 0 || !b) a; !b
-
-let zero = [|0|]
-let one = [|1|]
-
-let is_one a =
-  let rec leading_zero i = i<0 || (a.(i) = 0 && leading_zero (i-1)) in
-  (a.(Array.length a - 1) = 1) && leading_zero (Array.length a - 2)
-      
-let div2_with_rest n =
-  let len = Array.length n in
-  let q = Array.create len 0 in
-  for i = 0 to len - 2 do
-    q.(i) <- q.(i) + n.(i) / 2; q.(i + 1) <- base_div_2 * (n.(i) mod 2)
-  done;
-  q.(len - 1) <- q.(len - 1) + n.(len - 1) / 2;
-  q, (n.(len - 1) mod 2) = 1
-
-let add_1 n =
-  let m = Array.copy n
-  and i = ref (Array.length n - 1) in
-  while !i >= 0 && m.(!i) = base-1 do
-    m.(!i) <- 0; decr i; 
-  done;
-  if !i < 0 then begin
-    m.(0) <- 0; Array.concat [[| 1 |]; m] 
-  end else begin
-    m.(!i) <- m.(!i) + 1; m
-  end
-
-let sub_1 n =
-  if is_nonzero n then
-    let m = Array.copy n
-    and i = ref (Array.length n - 1) in
-    while m.(!i) = 0 && !i > 0 do
-      m.(!i) <- base-1; decr i;
-    done;
-    m.(!i) <- m.(!i) - 1;
-    m
-  else n
-
-let rec mult_2 n =
-  let m = Array.copy n in
-  m.(Array.length n - 1) <- 2 * m.(Array.length n - 1);
-  for i = Array.length n - 2 downto 0 do
-    m.(i) <- 2 * m.(i);
-    if m.(i + 1) >= base then begin
-      m.(i + 1) <- m.(i + 1) - base; m.(i) <- m.(i) + 1 
-    end
-  done;
-  if m.(0) >= base then begin
-    m.(0) <- m.(0) - base; Array.concat [[| 1 |]; m] 
-  end else 
-    m
-
-let less_than m n =
-  let lm = ref 0 in
-  while !lm < Array.length m && m.(!lm) = 0 do incr lm done;
-  let ln = ref 0 in
-  while !ln < Array.length n && n.(!ln) = 0 do incr ln done;
-  let um = Array.length m - !lm and un = Array.length n - !ln in
-  let rec lt d =
-    d < um && (m.(!lm+d) < n.(!ln+d) || (m.(!lm+d) = n.(!ln+d) && lt (d+1)))
-  in
-  (um < un) || (um = un && lt 0)
-
-type bigint = POS of bignat | NEG of bignat
-
-let pr_bigint = function
-  | POS n -> str (to_string n)
-  | NEG n -> str "-" ++ str (to_string n)
-
-let bigint_to_string = function
-  | POS n -> to_string n
-  | NEG n -> "-" ^ (to_string n);;
diff --git a/lib/bignat.mli b/lib/bignat.mli
deleted file mode 100644
index 860bcf29..00000000
--- a/lib/bignat.mli
+++ /dev/null
@@ -1,37 +0,0 @@
-(************************************************************************)
-(*  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: bignat.mli,v 1.4.6.3 2005/01/21 17:14:11 herbelin Exp $ i*)
-
-(*i*)
-open Pp
-(*i*)
-
-(* Arbitrary big natural numbers *)
-
-type bignat
-
-val of_string : string -> bignat
-val to_string : bignat -> string
-
-val is_nonzero : bignat -> bool
-val zero : bignat
-val one : bignat
-val is_one : bignat -> bool
-val div2_with_rest : bignat -> bignat * bool (* true=odd; false=even *)
-
-val add_1 : bignat -> bignat
-val sub_1 : bignat -> bignat (* Remark: [sub_1 0]=0 *)
-val mult_2 : bignat -> bignat
-
-val less_than : bignat -> bignat -> bool
-
-type bigint = POS of bignat | NEG of bignat
-
-val bigint_to_string : bigint -> string
-val pr_bigint : bigint -> std_ppcmds
diff --git a/lib/bstack.ml b/lib/bstack.ml
index d4b995fb..b86dccf9 100644
--- a/lib/bstack.ml
+++ b/lib/bstack.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: bstack.ml,v 1.3.2.1 2004/07/16 19:30:29 herbelin Exp $ *)
+(* $Id: bstack.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* Queues of a given length *)
 
diff --git a/lib/bstack.mli b/lib/bstack.mli
index 617f7df1..f018d155 100644
--- a/lib/bstack.mli
+++ b/lib/bstack.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: bstack.mli,v 1.4.2.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+(*i $Id: bstack.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Bounded stacks. If the depth is [None], then there is no depth limit. *)
 
diff --git a/lib/dyn.ml b/lib/dyn.ml
index 63f00365..94979835 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dyn.ml,v 1.3.16.1 2004/07/16 19:30:29 herbelin Exp $ *)
+(* $Id: dyn.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Util
 
diff --git a/lib/dyn.mli b/lib/dyn.mli
index 7f46c7e6..86a1560a 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dyn.mli,v 1.3.16.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+(*i $Id: dyn.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Dynamics. Use with extreme care. Not for kids. *)
 
diff --git a/lib/edit.ml b/lib/edit.ml
index 5020ef5c..03420992 100644
--- a/lib/edit.ml
+++ b/lib/edit.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: edit.ml,v 1.8.2.1 2004/07/16 19:30:29 herbelin Exp $ *)
+(* $Id: edit.ml 6947 2005-04-20 16:18:41Z coq $ *)
 
 open Pp
 open Util
@@ -84,6 +84,28 @@ let undo e n =
 	  errorlabstrm "Edit.undo" (str"Undo stack exhausted");
         repeat n Bstack.pop bs
 
+(* Return the depth of the focused proof of [e] stack, this is used to
+   put informations in coq prompt (in emacs mode). *)
+let depth e =
+  match e.focus with
+    | None -> invalid_arg "Edit.depth"
+    | Some d ->
+	let (bs,_) = Hashtbl.find e.buf d in
+	Bstack.depth bs
+
+(* Undo focused proof of [e] to reach depth [n] *)
+let undo_todepth e n =
+  match e.focus with
+    | None -> 
+	if n <> 0 
+	then errorlabstrm "Edit.undo_todepth" (str"No proof in progress")
+	else () (* if there is no proof in progress, then n must be zero *)
+    | Some d ->
+	let (bs,_) = Hashtbl.find e.buf d in
+	if Bstack.depth bs < n then
+	  errorlabstrm "Edit.undo_todepth" (str"Undo stack would be exhausted");
+        repeat (Bstack.depth bs - n) Bstack.pop bs
+
 let create e (d,b,c,udepth) =
   if Hashtbl.mem e.buf d then
     errorlabstrm "Edit.create" 
diff --git a/lib/edit.mli b/lib/edit.mli
index edf0f67b..ab82c1f9 100644
--- a/lib/edit.mli
+++ b/lib/edit.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: edit.mli,v 1.5.2.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+(*i $Id: edit.mli 6947 2005-04-20 16:18:41Z coq $ i*)
 
 (* The type of editors.
  * An editor is a finite map, ['a -> 'b], which knows how to apply
@@ -54,3 +54,10 @@ val delete : ('a,'b,'c) t -> 'a -> unit
 val dom : ('a,'b,'c) t -> 'a list
 
 val clear : ('a,'b,'c) t -> unit
+
+(* [depth e] Returns the depth of the focused proof stack of [e], this
+   is used to put informations in coq prompt (in emacs mode). *)
+val depth : ('a,'b,'c) t -> int
+
+(* [undo_todepth e n] Undoes focused proof of [e] to reach depth [n] *)
+val undo_todepth : ('a,'b,'c) t -> int -> unit
diff --git a/lib/explore.ml b/lib/explore.ml
index 2eaabef8..7e6de0c4 100644
--- a/lib/explore.ml
+++ b/lib/explore.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: explore.ml,v 1.3.16.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+(*i $Id: explore.ml 6066 2004-09-06 22:54:50Z barras $ i*)
 
 open Format
 
@@ -37,6 +37,7 @@ module Make = functor(S : SearchProblem) -> struct
     if S.success s then s else depth_first_many (S.branching s)
   and depth_first_many = function
     | [] -> raise Not_found
+    | [s] -> depth_first s
     | s :: l -> try depth_first s with Not_found -> depth_first_many l
 
   let debug_depth_first s = 
@@ -44,8 +45,8 @@ module Make = functor(S : SearchProblem) -> struct
       pp_position p; S.pp s;
       if S.success s then s else explore_many 1 p (S.branching s)
     and explore_many i p = function
-      | [] -> 
-	  raise Not_found
+      | [] -> raise Not_found
+      | [s] -> explore (i::p) s
       | s :: l -> 
 	  try explore (i::p) s with Not_found -> explore_many (succ i) p l
     in
@@ -67,10 +68,8 @@ module Make = functor(S : SearchProblem) -> struct
 
   let breadth_first s = 
     let rec explore q =
-      try 
-	let (s, q') = pop q in enqueue q' (S.branching s)
-      with Empty ->
-	raise Not_found
+      let (s, q') = try pop q with Empty -> raise Not_found in
+      enqueue q' (S.branching s)
     and enqueue q = function
       | [] -> explore q
       | s :: l -> if S.success s then s else enqueue (push s q) l
@@ -79,11 +78,8 @@ module Make = functor(S : SearchProblem) -> struct
 
   let debug_breadth_first s = 
     let rec explore q =
-      try 
-	let ((p,s), q') = pop q in 
-	enqueue 1 p q' (S.branching s)
-      with Empty ->
-	raise Not_found
+      let ((p,s), q') = try pop q with Empty -> raise Not_found in 
+      enqueue 1 p q' (S.branching s)
     and enqueue i p q = function
       | [] -> 
 	  explore q
diff --git a/lib/explore.mli b/lib/explore.mli
index 1236f06b..07f95e8a 100644
--- a/lib/explore.mli
+++ b/lib/explore.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: explore.mli,v 1.2.16.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+(*i $Id: explore.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*s Search strategies. *)
 
diff --git a/lib/gmap.ml b/lib/gmap.ml
index e5d41034..884305d9 100644
--- a/lib/gmap.ml
+++ b/lib/gmap.ml
@@ -5,10 +5,10 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: gmap.ml,v 1.3.16.1 2004/07/16 19:30:29 herbelin Exp $ *)
+(* $Id: gmap.ml 7925 2006-01-24 23:20:39Z herbelin $ *)
 
 (* Maps using the generic comparison function of ocaml. Code borrowed from
-   the ocaml standard library. *)
+   the ocaml standard library (Copyright 1996, INRIA). *)
 
     type ('a,'b) t =
         Empty
@@ -57,7 +57,7 @@
     let rec add x data = function
         Empty ->
           Node(Empty, x, data, Empty, 1)
-      | Node(l, v, d, r, h) as t ->
+      | Node(l, v, d, r, h) ->
           let c = Pervasives.compare x v in
           if c = 0 then
             Node(l, x, data, r, h)
@@ -81,17 +81,28 @@
           let c = Pervasives.compare x v in
           c = 0 || mem x (if c < 0 then l else r)
 
-    let rec merge t1 t2 =
+    let rec min_binding = function
+        Empty -> raise Not_found
+      | Node(Empty, x, d, r, _) -> (x, d)
+      | Node(l, x, d, r, _) -> min_binding l
+
+    let rec remove_min_binding = function
+        Empty -> invalid_arg "Map.remove_min_elt"
+      | Node(Empty, x, d, r, _) -> r
+      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
+
+    let merge t1 t2 =
       match (t1, t2) with
         (Empty, t) -> t
       | (t, Empty) -> t
-      | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
-          bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)
+      | (_, _) ->
+          let (x, d) = min_binding t2 in
+          bal t1 x d (remove_min_binding t2)
 
     let rec remove x = function
         Empty ->
           Empty
-      | Node(l, v, d, r, h) as t ->
+      | Node(l, v, d, r, h) ->
           let c = Pervasives.compare x v in
           if c = 0 then
             merge l r
@@ -109,6 +120,9 @@
         Empty               -> Empty
       | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
 
+    (* Maintien de fold_right par compatibilité (changé en fold_left dans
+       ocaml-3.09.0) *)
+
     let rec fold f m accu =
       match m with
         Empty -> accu
diff --git a/lib/gmap.mli b/lib/gmap.mli
index 7415a395..79958fab 100644
--- a/lib/gmap.mli
+++ b/lib/gmap.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: gmap.mli,v 1.4.16.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+(*i $Id: gmap.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Maps using the generic comparison function of ocaml. Same interface as
    the module [Map] from the ocaml standard library. *)
diff --git a/lib/gmapl.ml b/lib/gmapl.ml
index 5eb4e110..0974909d 100644
--- a/lib/gmapl.ml
+++ b/lib/gmapl.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gmapl.ml,v 1.2.16.2 2006/01/03 20:31:16 herbelin Exp $ *)
+(* $Id: gmapl.ml 7780 2006-01-03 20:33:53Z herbelin $ *)
 
 open Util
 
diff --git a/lib/gmapl.mli b/lib/gmapl.mli
index f8855ae4..db8f4358 100644
--- a/lib/gmapl.mli
+++ b/lib/gmapl.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: gmapl.mli,v 1.4.16.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+(*i $Id: gmapl.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Maps from ['a] to lists of ['b]. *)
 
diff --git a/lib/gset.ml b/lib/gset.ml
index 5ea2f82b..e90386a0 100644
--- a/lib/gset.ml
+++ b/lib/gset.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gset.ml,v 1.2.16.1 2004/07/16 19:30:30 herbelin Exp $ *)
+(* $Id: gset.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* Sets using the generic comparison function of ocaml. Code borrowed from
    the ocaml standard library. *)
diff --git a/lib/gset.mli b/lib/gset.mli
index 32d798cc..0f14368f 100644
--- a/lib/gset.mli
+++ b/lib/gset.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: gset.mli,v 1.3.16.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+(*i $Id: gset.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Sets using the generic comparison function of ocaml. Same interface as
    the module [Set] from the ocaml standard library. *)
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
index 5f083459..50be0ec4 100644
--- a/lib/hashcons.ml
+++ b/lib/hashcons.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hashcons.ml,v 1.3.16.1 2004/07/16 19:30:30 herbelin Exp $ *)
+(* $Id: hashcons.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* Hash consing of datastructures *)
 
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
index 2e32323a..f1e55ba1 100644
--- a/lib/hashcons.mli
+++ b/lib/hashcons.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hashcons.mli,v 1.5.16.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+(*i $Id: hashcons.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Generic hash-consing. *)
 
diff --git a/lib/heap.ml b/lib/heap.ml
index f0db2943..92aa0070 100644
--- a/lib/heap.ml
+++ b/lib/heap.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: heap.ml,v 1.1.2.1 2004/07/16 19:30:30 herbelin Exp $ *)
+(* $Id: heap.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (*s Heaps *)
 
diff --git a/lib/heap.mli b/lib/heap.mli
index 46e72728..d351edd0 100644
--- a/lib/heap.mli
+++ b/lib/heap.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: heap.mli,v 1.1.2.2 2005/01/21 17:14:11 herbelin Exp $ i*)
+(*i $Id: heap.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 (* Heaps *)
 
diff --git a/lib/options.ml b/lib/options.ml
index b5c5efda..c46857e3 100644
--- a/lib/options.ml
+++ b/lib/options.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: options.ml,v 1.27.2.1 2004/07/16 19:30:30 herbelin Exp $ *)
+(* $Id: options.ml 9191 2006-09-29 15:45:42Z courtieu $ *)
 
 open Util
 
@@ -22,8 +22,7 @@ let batch_mode = ref false
 let debug = ref false
 
 let print_emacs = ref false
-
-let emacs_str s = if !print_emacs then s else "" 
+let print_emacs_safechar = ref false
 
 let term_quality = ref false
 
@@ -33,22 +32,11 @@ let dont_load_proofs = ref false
 
 let raw_print = ref false
 
-let v7 =
-  let transl = array_exists ((=) "-translate") Sys.argv in
-  let v7 = array_exists ((=) "-v7") Sys.argv in
-  let v8 = array_exists ((=) "-v8") Sys.argv in
-  if v8 & transl then error "Options -translate and -v8 are incompatible";
-  if v8 & v7 then error "Options -v7 and -v8 are incompatible";
-  ref (v7 or transl)
-
-let v7_only = ref false
-
 (* Translate *)
 let translate = ref false
-let make_translate f = translate := f; v7 := f; ()
+let make_translate f = translate := f
 let do_translate () = !translate
 let translate_file = ref false
-let translate_strict_impargs = ref true
 
 (* True only when interning from pp*new.ml *)
 let translate_syntax = ref false
@@ -73,6 +61,8 @@ let silently f x =
 let if_silent f x = if !silent then f x
 let if_verbose f x = if not !silent then f x
 
+let hash_cons_proofs = ref true
+
 (* The number of printed hypothesis in a goal *)
 
 let print_hyps_limit = ref (None : int option)
@@ -81,11 +71,11 @@ let print_hyps_limit () = !print_hyps_limit
 
 (* A list of the areas of the system where "unsafe" operation
  * has been requested *)
+
 let unsafe_set = ref Stringset.empty
 let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set
 let is_unsafe s = Stringset.mem s !unsafe_set
 
-
 (* Dump of globalization (to be used by coqdoc) *)
 
 let dump = ref false
@@ -105,3 +95,30 @@ let dump_it () =
   end
 
 let _ = at_exit dump_it
+
+(* Options for the virtual machine *)
+
+let boxed_definitions = ref true
+let set_boxed_definitions b = boxed_definitions := b
+let boxed_definitions _ = !boxed_definitions 
+ 
+(* Options for external tools *)
+
+let browser_cmd_fmt =
+ try
+  let coq_netscape_remote_var = "COQREMOTEBROWSER" in
+  let coq_netscape_remote = Sys.getenv coq_netscape_remote_var in
+  let i = Util.string_index_from coq_netscape_remote 0 "%s" in
+  let pre = String.sub coq_netscape_remote 0 i in
+  let post = String.sub coq_netscape_remote (i + 2)
+              (String.length coq_netscape_remote - (i + 2)) in
+   if Util.string_string_contains ~where:post ~what:"%s" then
+    error ("The environment variable \"" ^
+           coq_netscape_remote_var ^
+           "\" must contain exactly one placeholder \"%s\".")
+   else pre,post
+ with
+  Not_found ->
+   if Sys.os_type = "Win32"
+   then "C:\\PROGRA~1\\INTERN~1\\IEXPLORE ", ""
+   else "netscape -remote \"OpenURL(", ")\""
diff --git a/lib/options.mli b/lib/options.mli
index 731b7da4..30d585fb 100644
--- a/lib/options.mli
+++ b/lib/options.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: options.mli,v 1.25.2.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+(*i $Id: options.mli 9191 2006-09-29 15:45:42Z courtieu $ i*)
 
 (* Global options of the system. *)
 
@@ -17,7 +17,7 @@ val batch_mode : bool ref
 val debug : bool ref
 
 val print_emacs : bool ref
-val emacs_str : string -> string
+val print_emacs_safechar : bool ref
 
 val term_quality : bool ref
 
@@ -27,15 +27,11 @@ val dont_load_proofs : bool ref
 
 val raw_print : bool ref
 
-val v7 : bool ref
-val v7_only : bool ref
-
 val translate : bool ref
 val make_translate : bool -> unit
 val do_translate : unit -> bool
 val translate_file : bool ref
 val translate_syntax : bool ref
-val translate_strict_impargs : bool ref
 
 val make_silent : bool -> unit
 val is_silent : unit -> bool
@@ -44,6 +40,8 @@ val silently : ('a -> 'b) -> 'a -> 'b
 val if_silent : ('a -> unit) -> 'a -> unit
 val if_verbose : ('a -> unit) -> 'a -> unit
 
+val hash_cons_proofs : bool ref
+
 (* Temporary activate an option ('c must be an atomic type) *)
 val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b
 
@@ -60,3 +58,14 @@ val dump : bool ref
 val dump_into_file : string -> unit
 val dump_string : string -> unit
 
+(* Options for the virtual machine *)
+
+val set_boxed_definitions : bool -> unit
+val boxed_definitions : unit -> bool
+
+(* Options for external tools *)
+
+(* Returns head and tail of printf string format *)
+(* ocaml doesn't allow not applied formats *)
+val browser_cmd_fmt : string * string
+ 
diff --git a/lib/pp.ml4 b/lib/pp.ml4
index 25ab9ce8..88efc5f2 100644
--- a/lib/pp.ml4
+++ b/lib/pp.ml4
@@ -6,10 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pp.ml4,v 1.5.2.1 2004/07/16 19:30:30 herbelin Exp $ *)
+(* $Id: pp.ml4 8747 2006-04-27 16:00:49Z courtieu $ *)
 
 open Pp_control
 
+(* This should not be used outside of this file. Use
+   Options.print_emacs instead. This one is updated when reading
+   command line options. This was the only way to make [Pp] depend on
+   an option without creating a circularity: [Options] -> [Util] ->
+   [Pp] -> [Options] *)
+let print_emacs = ref false
+let make_pp_emacs() = print_emacs:=true
+
 (* The different kinds of blocks are: 
    \begin{description}
    \item[hbox:] Horizontal block no line breaking;
@@ -122,17 +130,17 @@ let int n = str (string_of_int n)
 let real r = str (string_of_float r)
 let bool b = str (string_of_bool b)
 
+(* In new syntax only double quote char is escaped by repeating it *)
 let rec escape_string s =
   let rec escape_at s i =
     if i<0 then s
-    else if s.[i] == '\\' || s.[i] == '"' then
-      let s' = String.sub s 0 i^"\\"^String.sub s i (String.length s - i) in
+    else if s.[i] == '"' then
+      let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in
       escape_at s' (i-1)
     else escape_at s (i-1) in
   escape_at s (String.length s - 1)
 
-
-let qstring s = str ("\""^(escape_string s)^"\"")
+let qstring s = str ("\""^escape_string s^"\"")
 let qs = qstring
 
 (* boxing commands *)
@@ -183,7 +191,6 @@ let rec pr_com ft s =
 
 (* pretty printing functions *)
 let pp_dirs ft = 
-  let maxbox = (get_gp ft).max_depth in
   let pp_open_box = function
     | Pp_hbox n   -> Format.pp_open_hbox ft ()
     | Pp_vbox n   -> Format.pp_open_vbox ft n
@@ -239,6 +246,17 @@ let pp_err_dirs = pp_dirs err_ft
 
 let ppcmds x = Ppdir_ppcmds x
 
+(* Special chars for emacs, to detect warnings inside goal output *)
+let emacs_warning_start_string = String.make 1 (Char.chr 254)
+let emacs_warning_end_string = String.make 1 (Char.chr 255)
+
+let warnstart() = 
+  if not !print_emacs then str "" else str emacs_warning_start_string
+
+let warnend() = 
+  if not !print_emacs then str "" else str emacs_warning_end_string
+  
+
 (* pretty printing functions WITHOUT FLUSH *)
 let pp_with ft strm =
   pp_dirs ft [< 'Ppdir_ppcmds strm >]
@@ -247,10 +265,10 @@ let ppnl_with ft strm =
   pp_dirs ft [< 'Ppdir_ppcmds [< strm ; 'Ppcmd_force_newline >] >]
 
 let warning_with ft string =
-  ppnl_with ft [< str "Warning: " ; str string >]
+  ppnl_with ft [< warnstart() ; str "Warning: " ; str string ; warnend() >]
 
 let warn_with ft pps =
-  ppnl_with ft [< str "Warning: " ; pps >]
+  ppnl_with ft [< warnstart() ; str "Warning: " ; pps ; warnend() >]
 
 let pp_flush_with ft =
   Format.pp_print_flush ft
@@ -264,7 +282,7 @@ let msgnl_with ft strm =
   pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_newline >]
 
 let msg_warning_with ft strm=
-  pp_dirs ft [< 'Ppdir_ppcmds [< str "Warning: "; strm>]; 
+  pp_dirs ft [< 'Ppdir_ppcmds [< warnstart() ; str "Warning: "; strm ; warnend() >]; 
 		'Ppdir_print_newline >]
 
 
diff --git a/lib/pp.mli b/lib/pp.mli
index 417ea107..e240fd2d 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -6,12 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pp.mli,v 1.8.2.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+(*i $Id: pp.mli 8748 2006-04-27 16:01:26Z courtieu $ i*)
 
 (*i*)
 open Pp_control
 (*i*)
 
+(* Modify pretty printing functions behavior for emacs ouput (special
+   chars inserted at some places). This function should called once in
+   module [Options], that's all. *)
+val make_pp_emacs:unit -> unit
+
 (* Pretty-printers. *)
 
 type ppcmd
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
index 85303f74..7632d736 100644
--- a/lib/pp_control.ml
+++ b/lib/pp_control.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pp_control.ml,v 1.8.2.1 2004/07/16 19:30:31 herbelin Exp $ *)
+(* $Id: pp_control.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* Parameters of pretty-printing *)
 
diff --git a/lib/pp_control.mli b/lib/pp_control.mli
index 3588847d..7e25e561 100644
--- a/lib/pp_control.mli
+++ b/lib/pp_control.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pp_control.mli,v 1.7.2.1 2004/07/16 19:30:31 herbelin Exp $ i*)
+(*i $Id: pp_control.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Parameters of pretty-printing. *)
 
diff --git a/lib/predicate.ml b/lib/predicate.ml
index 1eaa20ce..93b74463 100644
--- a/lib/predicate.ml
+++ b/lib/predicate.ml
@@ -10,7 +10,7 @@
 (*                                                                     *)
 (************************************************************************)
 
-(* $Id: predicate.ml,v 1.1.14.1 2004/07/16 19:30:31 herbelin Exp $ *)
+(* $Id: predicate.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* Sets over ordered types *)
 
diff --git a/lib/predicate.mli b/lib/predicate.mli
index 2dc7d85c..85596fea 100644
--- a/lib/predicate.mli
+++ b/lib/predicate.mli
@@ -1,5 +1,5 @@
 
-(*i $Id: predicate.mli,v 1.1.14.1 2005/01/21 17:14:11 herbelin Exp $ i*)
+(*i $Id: predicate.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 (* Module [Pred]: sets over infinite ordered types with complement. *)
 
diff --git a/lib/profile.ml b/lib/profile.ml
index f55388f8..dd7e977e 100644
--- a/lib/profile.ml
+++ b/lib/profile.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: profile.ml,v 1.13.16.1 2004/07/16 19:30:31 herbelin Exp $ *)
+(* $Id: profile.ml 7538 2005-11-08 17:14:52Z herbelin $ *)
 
 open Gc
 
@@ -259,9 +259,9 @@ let time_overhead_B_C () =
   for i=1 to loops do
     try
       dummy_last_alloc := get_alloc ();
-      let r = dummy_f dummy_x in
-      let dw = dummy_spent_alloc () in
-      let dt = get_time () in
+      let _r = dummy_f dummy_x in
+      let _dw = dummy_spent_alloc () in
+      let _dt = get_time () in
       ()
     with _ -> assert false
   done;
@@ -328,7 +328,7 @@ let close_profile print =
 	outside.owntime <- outside.owntime + t;
 	ajoute_ownalloc outside dw;
 	ajoute_totalloc outside dw;
-	if List.length !prof_table <> 0 then begin
+	if !prof_table <> [] then begin
 	  let ov_bc = time_overhead_B_C () (* B+C overhead *) in
 	  let ov_ad = time_overhead_A_D () (* A+D overhead *) in
 	  let adjust (n,e) = (n, adjust_time ov_bc ov_ad e) in
diff --git a/lib/profile.mli b/lib/profile.mli
index e8ce8994..0937e9e3 100644
--- a/lib/profile.mli
+++ b/lib/profile.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: profile.mli,v 1.7.16.2 2005/01/21 17:14:11 herbelin Exp $ i*)
+(*i $Id: profile.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
 (*s This program is a small time and allocation profiler for Objective Caml *)
 
diff --git a/lib/rtree.ml b/lib/rtree.ml
index 53cc372f..ab689be1 100644
--- a/lib/rtree.ml
+++ b/lib/rtree.ml
@@ -6,16 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rtree.ml,v 1.2.8.1 2004/07/16 19:30:31 herbelin Exp $ i*)
+(*i $Id: rtree.ml 8648 2006-03-18 15:37:14Z herbelin $ i*)
 
 
 (* Type of regular trees:
    - Param denotes tree variables (like de Bruijn indices)
-   - Node denotes the usual tree node, labelles with 'a
+   - Node denotes the usual tree node, labelled with 'a
    - Rec(j,v1..vn) introduces infinite tree. It denotes
      v(j+1) with parameters 0..n-1 replaced by
      Rec(0,v1..vn)..Rec(n-1,v1..vn) respectively.
-     Parameters n and higher denote parameters globals to the
+     Parameters n and higher denote parameters global to the
      current Rec node (as usual in de Bruijn binding system)
  *)
 type 'a t =
diff --git a/lib/rtree.mli b/lib/rtree.mli
index 79b57586..7be96652 100644
--- a/lib/rtree.mli
+++ b/lib/rtree.mli
@@ -6,10 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rtree.mli,v 1.2.8.2 2005/01/21 16:41:52 herbelin Exp $ i*)
+(*i $Id: rtree.mli 7493 2005-11-02 22:12:16Z mohring $ i*)
 
 (* Type of regular tree with nodes labelled by values of type 'a *)
-type 'a t
+
+type 'a t 
 
 (* Building trees *)
 (* build a recursive call *) 
diff --git a/lib/stamps.ml b/lib/stamps.ml
deleted file mode 100644
index 1697c309..00000000
--- a/lib/stamps.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-(************************************************************************)
-(*  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: stamps.ml,v 1.2.16.1 2004/07/16 19:30:31 herbelin Exp $ *)
-
-let new_stamp = 
-  let stamp_ctr = ref 0 in
-  fun () -> incr stamp_ctr; !stamp_ctr
-
-type 'a timestamped = { stamp : int; ed : 'a }
-
-let ts_stamp st = st.stamp
-let ts_mod f st = { stamp = new_stamp(); ed = f st.ed }
-let ts_it st = st.ed
-let ts_mk v = { stamp = new_stamp(); ed = v}
-let ts_eq st1 st2 = st1.stamp = st2.stamp
-
-type 'a idstamped = 'a timestamped
-
-let ids_mod f st = { stamp = st.stamp; ed = f st.ed}
-let ids_it = ts_it
-let ids_mk = ts_mk
-let ids_eq = ts_eq
diff --git a/lib/stamps.mli b/lib/stamps.mli
deleted file mode 100644
index 36f238b9..00000000
--- a/lib/stamps.mli
+++ /dev/null
@@ -1,28 +0,0 @@
-(************************************************************************)
-(*  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: stamps.mli,v 1.3.16.1 2004/07/16 19:30:31 herbelin Exp $ i*)
-
-(* Time stamps. *)
-
-type 'a timestamped
-
-(* [ts_mod] gives a ['b timestamped] with a new stamp *)
-val ts_mod : ('a -> 'b) -> 'a timestamped -> 'b timestamped
-val ts_it : 'a timestamped -> 'a
-val ts_mk : 'a -> 'a timestamped
-val ts_eq : 'a timestamped -> 'a timestamped -> bool
-val ts_stamp : 'a timestamped -> int
-
-type 'a idstamped
-
-(* [ids_mod] gives a ['b stamped] with the same stamp *)
-val ids_mod : ('a -> 'b) -> 'a idstamped -> 'b idstamped
-val ids_it : 'a idstamped -> 'a
-val ids_mk : 'a -> 'a idstamped
-val ids_eq : 'a idstamped -> 'a idstamped -> bool
diff --git a/lib/system.ml b/lib/system.ml
index 9bbcc308..c92e87f1 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: system.ml,v 1.31.8.3 2006/01/10 17:06:23 barras Exp $ *)
+(* $Id: system.ml 9397 2006-11-21 21:50:54Z herbelin $ *)
 
 open Pp
 open Util
@@ -34,7 +34,7 @@ let rec expand_atom s i =
   then expand_atom s (i+1)
   else i
 
-let rec expand_macros b s i =
+let rec expand_macros s i =
   let l = String.length s in
   if i=l then s else
     match s.[i] with
@@ -42,53 +42,26 @@ let rec expand_macros b s i =
 	  let n = expand_atom s (i+1) in
 	  let v = safe_getenv (String.sub s (i+1) (n-i-1)) in
 	  let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in
-	  expand_macros false s (i + String.length v)
-      | '/' ->
-	  expand_macros true s (i+1)
-      | '~' ->
+	  expand_macros s (i + String.length v)
+      | '~' when i = 0 ->
 	  let n = expand_atom s (i+1) in
 	  let v =
 	    if n=i+1 then home
 	    else (getpwnam (String.sub s (i+1) (n-i-1))).pw_dir
 	  in
 	  let s = v^(String.sub s n (l-n)) in
-	  expand_macros false s (String.length v)
-      | c -> expand_macros false s (i+1)
+	  expand_macros s (String.length v)
+      | c -> expand_macros s (i+1)
 
-let glob s = expand_macros true s 0
+let expand_path_macros s = expand_macros s 0
 
 (* Files and load path. *)
 
 type physical_path = string
 type load_path = physical_path list
 
-(* Hints to partially detects if two paths refer to the same repertory *)
-let rec remove_path_dot p = 
-  let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
-  let n = String.length curdir in
-  if String.length p > n && String.sub p 0 n = curdir then
-    remove_path_dot (String.sub p n (String.length p - n))
-  else
-    p
-
-let strip_path p =
-  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
-  let n = String.length cwd in
-  if String.length p > n && String.sub p 0 n = cwd then
-    remove_path_dot (String.sub p n (String.length p - n))
-  else
-    remove_path_dot p
-
-let canonical_path_name p =
-  let current = Sys.getcwd () in
-  try 
-    Sys.chdir p;
-    let p' = Sys.getcwd () in
-    Sys.chdir current;
-    p'
-  with Sys_error _ ->
-    (* We give up to find a canonical name and just simplify it... *)
-    strip_path p
+let physical_path_of_string s = s
+let string_of_physical_path p = p
 
 (* All subdirectories, recursively *)
 
@@ -124,51 +97,44 @@ let all_subdirs ~unix_path:root =
    end ;
   List.rev !l
 
-let search_in_path path filename =
+let where_in_path path filename =
   let rec search = function
     | lpe :: rem ->
-	let f = glob (Filename.concat lpe filename) in
+	let f = Filename.concat lpe filename in
 	if Sys.file_exists f then (lpe,f) else search rem
     | [] ->
 	raise Not_found
   in
   search path
 
-let where_in_path = search_in_path
-
-let find_file_in_path paths name =
-  let globname = glob name in
-  if not (Filename.is_implicit globname) then
-    let root = Filename.dirname globname in
-    root, globname
+let find_file_in_path paths filename =
+  if not (Filename.is_implicit filename) then
+    let root = Filename.dirname filename in
+    root, filename
   else 
-    try 
-      search_in_path paths name
+    try where_in_path paths filename
     with Not_found ->
       errorlabstrm "System.find_file_in_path"
-	(hov 0 (str "Can't find file" ++ spc () ++ str name ++ spc () ++ 
+	(hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ 
 		str "on loadpath"))
 
 let is_in_path lpath filename =
-  try
-    let _ = search_in_path lpath filename in true
-  with
-    Not_found -> false
+  try ignore (where_in_path lpath filename); true
+  with Not_found -> false
 
 let make_suffix name suffix =
   if Filename.check_suffix name suffix then name else (name ^ suffix)
 
-let file_readable_p na =
-  try access (glob na) [R_OK];true with Unix_error (_, _, _) -> false
+let file_readable_p name =
+  try access name [R_OK];true with Unix_error (_, _, _) -> false
 
-let open_trapping_failure open_fun name suffix =
-  let rname = glob (make_suffix name suffix) in
-  try open_fun rname with _ -> error ("Can't open " ^ rname)
+let open_trapping_failure name =
+  try open_out_bin name with _ -> error ("Can't open " ^ name)
 
-let try_remove f =
-  try Sys.remove f
+let try_remove filename =
+  try Sys.remove filename
   with _ -> msgnl (str"Warning: " ++ str"Could not remove file " ++
-                   str f ++ str" which is corrupted!" )
+                   str filename ++ str" which is corrupted!" )
 
 let marshal_out ch v = Marshal.to_channel ch v []
 let marshal_in ch =
@@ -179,14 +145,14 @@ exception Bad_magic_number of string
 
 let raw_extern_intern magic suffix =
   let extern_state name = 
-    let (_,channel) as filec =
-      open_trapping_failure (fun n -> n,open_out_bin n) name suffix in
+    let filename = make_suffix name suffix in
+    let channel = open_trapping_failure filename in
     output_binary_int channel magic;
-    filec
-  and intern_state fname = 
-    let channel = open_in_bin fname in
+    filename,channel
+  and intern_state filename = 
+    let channel = open_in_bin filename in
     if input_binary_int channel <> magic then
-      raise (Bad_magic_number fname);
+      raise (Bad_magic_number filename);
     channel
   in 
   (extern_state,intern_state)
@@ -195,17 +161,17 @@ let extern_intern magic suffix =
   let (raw_extern,raw_intern) = raw_extern_intern magic suffix in
   let extern_state name val_0 = 
     try
-      let (fname,channel) = raw_extern name in
+      let (filename,channel) = raw_extern name in
       try
         marshal_out channel val_0;
         close_out channel
       with e -> 
-	begin try_remove fname; raise e end
+	begin try_remove filename; raise e end
     with Sys_error s -> error ("System error: " ^ s)
   and intern_state paths name = 
     try
-      let _,fname = find_file_in_path paths (make_suffix name suffix) in
-      let channel = raw_intern fname in
+      let _,filename = find_file_in_path paths (make_suffix name suffix) in
+      let channel = raw_intern filename in
       let v = marshal_in channel in
       close_in channel; 
       v
@@ -214,6 +180,61 @@ let extern_intern magic suffix =
   in 
   (extern_state,intern_state)
 
+(* Communication through files with another executable *)
+
+let connect writefun readfun com =
+  let name = Filename.basename com in
+  let tmp_to = Filename.temp_file ("coq-"^name^"-in") ".xml" in
+  let tmp_from = Filename.temp_file ("coq-"^name^"-out") ".xml" in
+  let ch_to_in,ch_to_out =
+    try open_in tmp_to, open_out tmp_to
+    with Sys_error s -> error ("Cannot set connection to "^com^"("^s^")") in
+  let ch_from_in,ch_from_out = 
+    try open_in tmp_from, open_out tmp_from
+    with Sys_error s ->
+      close_out ch_to_out; close_in ch_to_in; 
+      error ("Cannot set connection from "^com^"("^s^")") in
+  writefun ch_to_out;
+  close_out ch_to_out;
+  let pid = 
+    let ch_to' = Unix.descr_of_in_channel ch_to_in in
+    let ch_from' = Unix.descr_of_out_channel ch_from_out in
+    try Unix.create_process com [||] ch_to' ch_from' Unix.stdout
+    with Unix.Unix_error (err,_,_) ->
+      close_in ch_to_in; close_in ch_from_in; close_out ch_from_out;
+      unlink tmp_from; unlink tmp_to;
+      error ("Cannot execute "^com^"("^(Unix.error_message err)^")") in
+  close_in ch_to_in;
+  close_out ch_from_out;
+  (match snd (Unix.waitpid [] pid) with
+    | Unix.WEXITED 127 -> error (com^": cannot execute")
+    | Unix.WEXITED 0 -> ()
+    | _ -> error (com^" exited abnormally"));
+  let a = readfun ch_from_in in
+  close_in ch_from_in;
+  unlink tmp_from;
+  unlink tmp_to;
+  a
+
+let run_command converter f c =
+  let result = Buffer.create 127 in
+  let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
+  let buff = String.make 127 ' ' in
+  let buffe = String.make 127 ' ' in
+  let n = ref 0 in
+  let ne = ref 0 in
+
+  while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; 
+    !n+ !ne <> 0
+  do 
+    let r = converter (String.sub buff 0 !n) in 
+    f r;
+    Buffer.add_string result r;
+    let r = converter (String.sub buffe 0 !ne) in 
+    f r;
+    Buffer.add_string result r 
+  done;
+  (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
 
 (* Time stamps. *)
 
diff --git a/lib/system.mli b/lib/system.mli
index dc172b70..a58308a8 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: system.mli,v 1.17.16.3 2006/01/10 17:06:23 barras Exp $ i*)
+(*i $Id: system.mli 9397 2006-11-21 21:50:54Z herbelin $ i*)
 
 (*s Files and load paths. Load path entries remember the original root
     given by the user. For efficiency, we keep the full path (field
@@ -16,16 +16,17 @@
 type physical_path = string
 type load_path = physical_path list
 
-val canonical_path_name : string -> physical_path
-
 val all_subdirs : unix_path:string -> (physical_path * string list) list
 val is_in_path : load_path -> string -> bool
 val where_in_path : load_path -> string -> physical_path * string
 
+val physical_path_of_string : string -> physical_path
+val string_of_physical_path : physical_path -> string
+
 val make_suffix : string -> string -> string
 val file_readable_p : string -> bool
 
-val glob : string -> string
+val expand_path_macros : string -> string
 val getenv_else : string -> string -> string
 val home : string
 
@@ -48,6 +49,18 @@ val raw_extern_intern : int -> string ->
 val extern_intern : 
   int -> string -> (string -> 'a -> unit) * (load_path -> string -> 'a)
 
+(*s Sending/receiving once with external executable *)
+
+val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a 
+
+(*s [run_command converter f com] launches command [com], and returns
+    the contents of stdout and stderr that have been processed with
+    [converter]; the processed contents of stdout and stderr is also
+    passed to [f] *)
+
+val run_command : (string -> string) -> (string -> unit) -> string -> 
+  Unix.process_status * string
+
 (*s Time stamps. *)
 
 type time
@@ -56,5 +69,3 @@ val process_time : unit -> float * float
 val get_time : unit -> time
 val time_difference : time -> time -> float (* in seconds *)
 val fmt_time_difference : time -> time -> Pp.std_ppcmds
-
-
diff --git a/lib/tlm.ml b/lib/tlm.ml
index 23021be4..2939e91a 100644
--- a/lib/tlm.ml
+++ b/lib/tlm.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tlm.ml,v 1.3.16.1 2004/07/16 19:30:31 herbelin Exp $ *)
+(* $Id: tlm.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 type ('a,'b) t = Node of 'b Gset.t * ('a, ('a,'b) t) Gmap.t
 
diff --git a/lib/tlm.mli b/lib/tlm.mli
index a3011932..982bb5ed 100644
--- a/lib/tlm.mli
+++ b/lib/tlm.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tlm.mli,v 1.5.16.1 2004/07/16 19:30:31 herbelin Exp $ i*)
+(*i $Id: tlm.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Tries. This module implements a data structure [('a,'b) t] mapping lists
    of values of type ['a] to sets (as lists) of values of type ['b]. *)
diff --git a/lib/util.ml b/lib/util.ml
index b5470e58..89cfd6fc 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -1,12 +1,12 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
 
-(* $Id: util.ml,v 1.84.2.3 2004/07/29 15:00:04 herbelin Exp $ *)
+(* $Id: util.ml 9225 2006-10-09 15:59:23Z herbelin $ *)
 
 open Pp
 
@@ -32,8 +32,9 @@ type 'a located = loc * 'a
 let anomaly_loc (loc,s,strm) = Stdpp.raise_with_loc loc (Anomaly (s,strm))
 let user_err_loc (loc,s,strm) = Stdpp.raise_with_loc loc (UserError (s,strm))
 let invalid_arg_loc (loc,s) = Stdpp.raise_with_loc loc (Invalid_argument s)
-let join_loc (deb1,_ as loc1) (_,fin2 as loc2) = 
-  if loc1 = dummy_loc or loc2 = dummy_loc then dummy_loc else (deb1,fin2)
+let join_loc loc1 loc2 =
+  if loc1 = dummy_loc or loc2 = dummy_loc then dummy_loc
+  else (fst loc1, snd loc2)
 
 (* Like Exc_located, but specifies the outermost file read, the filename
    associated to the location of the error, and the error itself. *)
@@ -98,6 +99,8 @@ let string_string_contains ~where ~what =
   with
       Not_found -> false
 
+let plural n s = if n>1 then s^"s" else s
+
 (* string parsing *)
 
 let parse_loadpath s =
@@ -118,10 +121,6 @@ module Stringset = Set.Make(struct type t = string let compare = compare end)
 
 module Stringmap = Map.Make(struct type t = string let compare = compare end)
 
-let stringmap_to_list m = Stringmap.fold (fun s y l -> (s,y)::l) m []
-
-let stringmap_dom m = Stringmap.fold (fun s _ l -> s::l) m []
-
 (* Lists *)
 
 let list_add_set x l = if List.mem x l then l else x::l
@@ -195,7 +194,7 @@ let list_map_i f =
 let list_map2_i f i l1 l2 =  
   let rec map_i i = function
     | ([], []) -> []
-    | ((h1::t1), (h2::t2)) -> (f i h1 h2) :: (map_i (succ i) (t1,t2))
+    | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
     | (_, _) -> invalid_arg "map2_i"
   in 
   map_i i (l1,l2)
@@ -203,7 +202,7 @@ let list_map2_i f i l1 l2 =
 let list_map3 f l1 l2 l3 =
   let rec map = function
     | ([], [], []) -> []
-    | ((h1::t1), (h2::t2), (h3::t3)) -> (f h1 h2 h3) :: (map (t1,t2,t3))
+    | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
     | (_, _, _) -> invalid_arg "map3"
   in 
   map (l1,l2,l3)
@@ -215,6 +214,16 @@ let list_index x =
   in 
   index_x 1
 
+let list_unique_index x = 
+  let rec index_x n = function
+    | y::l -> 
+	if x = y then 
+	  if List.mem x l then raise Not_found
+	  else n 
+	else index_x (succ n) l
+    | [] -> raise Not_found 
+  in index_x 1
+
 let list_fold_left_i f = 
   let rec it_list_f i a = function
     | [] -> a 
@@ -251,6 +260,13 @@ let list_for_all_i p =
 
 let list_except x l = List.filter (fun y -> not (x = y)) l
 
+let list_remove = list_except (* Alias *)
+
+let rec list_remove_first a = function
+  | b::l when a = b -> l
+  | b::l -> b::list_remove_first a l
+  | [] -> raise Not_found
+
 let list_for_all2eq f l1 l2 = try List.for_all2 f l1 l2 with Failure _ -> false
 
 let list_map_i f = 
@@ -279,9 +295,11 @@ let list_try_find f =
   in 
   try_find_f
 
-let rec list_uniquize = function
-  | [] -> []
-  | h::t -> if List.mem h t then list_uniquize t else h::(list_uniquize t)
+let list_uniquize l =
+  let rec aux acc = function
+  | [] -> List.rev acc
+  | h::t -> if List.mem h acc then aux acc t else aux (h::acc) t
+  in aux [] l
 
 let rec list_distinct = function
   | h::t -> (not (List.mem h t)) && list_distinct t
@@ -347,7 +365,19 @@ let list_prefix_of prefl l =
     | ([], _) -> true
     | (_, _) -> false
   in 
-  prefrec (prefl,l)
+    prefrec (prefl,l)
+
+let list_drop_prefix p l =
+(* if l=p++t then return t else l *)
+  let rec list_drop_prefix_rec = function
+    | ([], tl) -> Some tl
+    | (_, []) -> None
+    | (h1::tp, h2::tl) -> 
+	if h1 = h2 then list_drop_prefix_rec (tp,tl) else None
+  in
+    match list_drop_prefix_rec (p,l) with
+      | Some r -> r
+      | None -> l
 
 let list_map_append f l = List.flatten (List.map f l)
 
@@ -362,12 +392,12 @@ let list_share_tails l1 l2 =
 
 let list_join_map f l = List.flatten (List.map f l)
 
-let rec list_fold_map f e = function 
+let rec list_fold_map f e = function
   |  []  -> (e,[])
-  |  h::t -> 
+  |  h::t ->
        let e',h' = f e h in
        let e'',t' = list_fold_map f e' t in
-	 e'',h'::t'
+         e'',h'::t'
 
 (* (* tail-recursive version of the above function *)
 let list_fold_map f e l = 
@@ -379,6 +409,10 @@ let list_fold_map f e l =
     (e',List.rev lrev)
 *)
 
+(* The same, based on fold_right, with the effect accumulated on the right *)
+let list_fold_map' f l e =
+  List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e)
+
 let list_map_assoc f = List.map (fun (x,a) -> (x,f a))
 
 (* Arrays *)
@@ -441,6 +475,17 @@ let array_last v =
 
 let array_cons e v = Array.append [|e|] v
 
+let array_rev t = 
+  let n=Array.length t in
+    if n <=0 then () 
+    else
+      let tmp=ref t.(0) in
+      for i=0 to pred (n/2) do 
+	tmp:=t.((pred n)-i);
+	t.((pred n)-i)<- t.(i);
+	t.(i)<- !tmp
+      done
+
 let array_fold_right_i f v a =
   let rec fold a n =
     if n=0 then a
@@ -596,6 +641,38 @@ let array_map_left_pair f a g b =
     r, s
   end
 
+let pure_functional = false
+
+let array_fold_map' f v e =
+if pure_functional then
+  let (l,e) =
+    Array.fold_right 
+      (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
+      v ([],e) in
+  (Array.of_list l,e)
+else
+  let e' = ref e in
+  let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in
+  (v',!e')
+
+let array_fold_map2' f v1 v2 e =
+  let e' = ref e in
+  let v' = 
+    array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 
+  in
+  (v',!e')
+
+let array_distinct v =
+  try
+    for i=0 to Array.length v-1 do
+      for j=i+1 to Array.length v-1 do
+	if v.(i)=v.(j) then raise Exit
+      done
+    done;
+    true
+  with Exit ->
+    false
+
 (* Matrices *)
 
 let matrix_transpose mat =
@@ -648,7 +725,7 @@ let out_some = function
   | Some x -> x
   | None -> failwith "out_some"
 
-let option_app f = function
+let option_map f = function
   | None -> None
   | Some x -> Some (f x)
 
@@ -660,6 +737,10 @@ let option_fold_left2 f e a b = match (a,b) with
   | Some x, Some y -> f e x y
   | _ -> e
 
+let option_fold_left f e a = match a with
+  | Some x -> f e x
+  | _ -> e
+
 let option_fold_right f a e = match a with
   | Some x -> f x e
   | _ -> e
@@ -693,6 +774,8 @@ let pr_str = str
 let pr_coma () = str "," ++ spc ()
 let pr_semicolon () = str ";" ++ spc ()
 let pr_bar () = str "|" ++ spc ()
+let pr_arg pr x = spc () ++ pr x
+let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x
 
 let pr_ord n =
   let suff = match n mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in
@@ -734,6 +817,8 @@ let prvect_with_sep sep elem v =
   let n = Array.length v in
   if n = 0 then mt () else pr (n - 1)
 
+let surround p = hov 1 (str"(" ++ p ++ str")")
+
 (*s Size of ocaml values. *)
 
 module Size = struct
diff --git a/lib/util.mli b/lib/util.mli
index 19f05ea4..b2d8f135 100644
--- a/lib/util.mli
+++ b/lib/util.mli
@@ -1,12 +1,12 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
 
-(*i $Id: util.mli,v 1.84.2.2 2004/07/16 20:43:46 herbelin Exp $ i*)
+(*i $Id: util.mli 9225 2006-10-09 15:59:23Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -68,16 +68,13 @@ val explode : string -> string list
 val implode : string list -> string
 val string_index_from : string -> int -> string -> int
 val string_string_contains : where:string -> what:string -> bool
+val plural : int -> string -> string
 
 val parse_loadpath : string -> string list
 
 module Stringset : Set.S with type elt = string
-
 module Stringmap : Map.S with type key = string
 
-val stringmap_to_list : 'a Stringmap.t -> (string * 'a) list 
-val stringmap_dom : 'a Stringmap.t -> string list
-
 (*s Lists. *)
 
 val list_add_set : 'a -> 'a list -> 'a list
@@ -103,12 +100,16 @@ val list_map2_i :
 val list_map3 :
   ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
 val list_index : 'a -> 'a list -> int
+(* [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *)
+val list_unique_index : 'a -> 'a list -> int 
 val list_iter_i :  (int -> 'a -> unit) -> 'a list -> unit
 val list_fold_left_i :  (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
 val list_fold_right_and_left :
     ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
 val list_for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
 val list_except : 'a -> 'a list -> 'a list
+val list_remove : 'a -> 'a list -> 'a list
+val list_remove_first : 'a -> 'a list -> 'a list
 val list_for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
 val list_sep_last : 'a list -> 'a * 'a list
 val list_try_find_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b
@@ -122,6 +123,7 @@ val list_last : 'a list -> 'a
 val list_lastn : int -> 'a list -> 'a list
 val list_skipn : int -> 'a list -> 'a list 
 val list_prefix_of : 'a list -> 'a list -> bool
+val list_drop_prefix : 'a list -> 'a list -> 'a list
 (* [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)] *)
 val list_map_append : ('a -> 'b list) -> 'a list -> 'b list
 (* raises [Invalid_argument] if the two lists don't have the same length *)
@@ -130,8 +132,8 @@ val list_share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
 val list_join_map : ('a -> 'b list) -> 'a list -> 'b list
 (* [list_fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
    where [(e_i,k_i)=f e_{i-1} l_i] *)
-val list_fold_map : 
-  ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list 
+val list_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+val list_fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
 val list_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
 
 (*s Arrays. *)
@@ -147,6 +149,7 @@ val array_hd : 'a array -> 'a
 val array_tl : 'a array -> 'a array
 val array_last : 'a array -> 'a
 val array_cons : 'a -> 'a array -> 'a array
+val array_rev : 'a array -> unit
 val array_fold_right_i : 
   (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
 val array_fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
@@ -170,6 +173,10 @@ val array_map3 :
 val array_map_left : ('a -> 'b) -> 'a array -> 'b array
 val array_map_left_pair : ('a -> 'b) -> 'a array -> ('c -> 'd) -> 'c array ->
   'b array * 'd array
+val array_fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
+val array_fold_map2' :
+  ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
+val array_distinct : 'a array -> bool
 
 (*s Matrices *)
 
@@ -199,9 +206,10 @@ val interval : int -> int -> int list
 
 val in_some : 'a -> 'a option
 val out_some : 'a option -> 'a
-val option_app : ('a -> 'b) -> 'a option -> 'b option
+val option_map : ('a -> 'b) -> 'a option -> 'b option
 val option_cons : 'a option -> 'a list -> 'a list
 val option_fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
+val option_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a
 val option_fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option ->
   'c option -> 'a
 val option_iter : ('a -> unit) -> 'a option -> unit
@@ -223,6 +231,8 @@ val pr_coma : unit -> std_ppcmds
 val pr_semicolon : unit -> std_ppcmds
 val pr_bar : unit -> std_ppcmds
 val pr_ord : int -> std_ppcmds
+val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
+val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
 
 val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
 val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
@@ -231,6 +241,8 @@ val prlist_with_sep :
 val prvect_with_sep :
    (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b array -> std_ppcmds
 val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds
+val surround : std_ppcmds -> std_ppcmds
+
 
 (*s Size of an ocaml value (in words, bytes and kilobytes). *)
 
diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml
index a030284c..af54df2f 100644
--- a/library/decl_kinds.ml
+++ b/library/decl_kinds.ml
@@ -6,7 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: decl_kinds.ml,v 1.6.2.1 2004/07/16 19:30:33 herbelin Exp $ *)
+(* $Id: decl_kinds.ml 7944 2006-01-29 16:01:32Z herbelin $ *)
+
+open Util
 
 (* Informal mathematical status of declarations *)
 
@@ -14,23 +16,32 @@ type locality_flag = (*bool (* local = true; global = false *)*)
   | Local
   | Global
 
-(* Kinds used at parsing time *)
+type boxed_flag = bool
 
 type theorem_kind =
   | Theorem
   | Lemma
   | Fact
   | Remark
+  | Property
+  | Proposition
+  | Corollary
 
 type definition_object_kind =
   | Definition
   | Coercion
   | SubClass
   | CanonicalStructure
+  | Example
+  | Fixpoint
+  | CoFixpoint
+  | Scheme
+  | StructureComponent
+  | IdentityCoercion
 
 type strength = locality_flag (* For compatibility *)
 
-type type_as_formula_kind = Definitional | Logical | Conjectural
+type assumption_object_kind = Definitional | Logical | Conjectural
 
 (* [assumption_kind] 
 
@@ -40,36 +51,51 @@ type type_as_formula_kind = Definitional | Logical | Conjectural
    Logical      |  Hypothesis | Axiom
 
 *)
-type assumption_kind = locality_flag * type_as_formula_kind
+type assumption_kind = locality_flag * assumption_object_kind
 
-type definition_kind = locality_flag * definition_object_kind
+type definition_kind = locality_flag * boxed_flag * definition_object_kind
 
 (* Kinds used in proofs *)
 
-type global_goal_kind =
-  | DefinitionBody
+type goal_object_kind =
+  | DefinitionBody of definition_object_kind
   | Proof of theorem_kind
 
-type goal_kind =
-  | IsGlobal of global_goal_kind
-  | IsLocal
+type goal_kind = locality_flag * goal_object_kind
 
 (* Kinds used in library *)
 
-type local_theorem_kind = LocalStatement
-
-type 'a mathematical_kind =
-  | IsAssumption of type_as_formula_kind
-  | IsDefinition
-  | IsConjecture
-  | IsProof of 'a
-
-type global_kind = theorem_kind mathematical_kind
-type local_kind = local_theorem_kind mathematical_kind
+type logical_kind =
+  | IsAssumption of assumption_object_kind
+  | IsDefinition of definition_object_kind
+  | IsProof of theorem_kind
 
 (* Utils *)
 
-let theorem_kind_of_goal_kind = function
-  | DefinitionBody -> IsDefinition
+let logical_kind_of_goal_kind = function
+  | DefinitionBody d -> IsDefinition d
   | Proof s -> IsProof s
 
+let string_of_theorem_kind = function
+  | Theorem -> "Theorem"
+  | Lemma -> "Lemma"
+  | Fact -> "Fact"
+  | Remark -> "Remark"
+  | Property -> "Property"
+  | Proposition -> "Proposition"
+  | Corollary -> "Corollary"
+
+let string_of_definition_kind (l,boxed,d) =
+  match (l,d) with
+  | Local, Coercion -> "Coercion Local"
+  | Global, Coercion -> "Coercion"
+  | Local, Definition -> "Let"
+  | Global, Definition -> if boxed then "Boxed Definition" else "Definition"
+  | Local, SubClass -> "Local SubClass"
+  | Global, SubClass -> "SubClass"
+  | Global, CanonicalStructure -> "Canonical Structure"
+  | Global, Example -> "Example"
+  | Local, (CanonicalStructure|Example) ->
+      anomaly "Unsupported local definition kind"
+  | _, (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion)
+      -> anomaly "Internal definition kind"
diff --git a/library/declare.ml b/library/declare.ml
index cfa8890a..02bdb1cf 100644
--- a/library/declare.ml
+++ b/library/declare.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: declare.ml,v 1.128.2.2 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: declare.ml 9488 2007-01-17 11:11:58Z herbelin $ *)
 
 open Pp
 open Util
@@ -31,11 +31,7 @@ open Decl_kinds
 
 (**********************************************)
 
-(* For [DischargeAt (dir,n)], [dir] is the minimum prefix that a
-   construction keeps in its name (if persistent), or the section name
-   beyond which it is discharged (if volatile); the integer [n]
-   (useful only for persistent constructions), is the length of the section
-   part in [dir] *)
+(* Strength *)
 
 open Nametab
 
@@ -47,9 +43,9 @@ let string_of_strength = function
   | Global -> "(global)"
 
 (* XML output hooks *)
-let xml_declare_variable = ref (fun sp -> ())
-let xml_declare_constant = ref (fun sp -> ())
-let xml_declare_inductive = ref (fun sp -> ())
+let xml_declare_variable = ref (fun (sp:object_name) -> ())
+let xml_declare_constant = ref (fun (sp:bool * constant)-> ())
+let xml_declare_inductive = ref (fun (sp:bool * object_name) -> ())
 
 let if_xml f x = if !Options.xml_export then f x else ()
 
@@ -63,25 +59,28 @@ type section_variable_entry =
   | SectionLocalDef of constr * types option * bool (* opacity *)
   | SectionLocalAssum of types
 
-type variable_declaration = dir_path * section_variable_entry * local_kind
+type variable_declaration = dir_path * section_variable_entry * logical_kind
 
 type checked_section_variable =
   | CheckedSectionLocalDef of constr * types * Univ.constraints * bool
   | CheckedSectionLocalAssum of types * Univ.constraints
 
 type checked_variable_declaration = 
-    dir_path * checked_section_variable * local_kind
+    dir_path * checked_section_variable * logical_kind
 
 let vartab = ref (Idmap.empty : checked_variable_declaration Idmap.t)
 
 let _ = Summary.declare_summary "VARIABLE"
-	  { Summary.freeze_function = (fun () -> !vartab);
-	    Summary.unfreeze_function = (fun ft -> vartab := ft);
-	    Summary.init_function = (fun () -> vartab := Idmap.empty);
-	    Summary.survive_module = false;
-	    Summary.survive_section = false }
-
-let cache_variable ((sp,_),(id,(p,d,mk))) =
+  { Summary.freeze_function = (fun () -> !vartab);
+    Summary.unfreeze_function = (fun ft -> vartab := ft);
+    Summary.init_function = (fun () -> vartab := Idmap.empty);
+    Summary.survive_module = false;
+    Summary.survive_section = false }
+
+let cache_variable ((sp,_),o) =
+  match o with
+  | Inl cst -> Global.add_constraints cst
+  | Inr (id,(p,d,mk)) ->
   (* Constr raisonne sur les noms courts *)
   if Idmap.mem id !vartab then
     errorlabstrm "cache_variable" (pr_id id ++ str " already exists");
@@ -95,36 +94,38 @@ let cache_variable ((sp,_),(id,(p,d,mk))) =
         let (_,bd,ty) = Global.lookup_named id in
         CheckedSectionLocalDef (out_some bd,ty,cst,opaq) in
   Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id);
+  add_section_variable id;
+  Dischargedhypsmap.set_discharged_hyps sp [];
   vartab := Idmap.add id (p,vd,mk) !vartab
 
+let get_variable_constraints id = 
+  match pi2 (Idmap.find id !vartab) with
+  | CheckedSectionLocalDef (c,ty,cst,opaq) -> cst
+  | CheckedSectionLocalAssum (ty,cst) -> cst
+
+let discharge_variable (_,o) = match o with
+  | Inr (id,_) -> Some (Inl (get_variable_constraints id))
+  | Inl _ -> Some o
+
 let (in_variable, out_variable) =
   declare_object { (default_object "VARIABLE") with
     cache_function = cache_variable;
+    discharge_function = discharge_variable;
     classify_function = (fun _ -> Dispose) }
 
-let declare_variable_common id obj =
-  let oname = add_leaf id (in_variable (id,obj)) in
-  declare_var_implicits id;
-  Symbols.declare_ref_arguments_scope (VarRef id);
-  oname
-
 (* for initial declaration *)
 let declare_variable id obj =
-  let (sp,kn as oname) = declare_variable_common id obj in
+  let oname = add_leaf id (in_variable (Inr (id,obj))) in
+  declare_var_implicits id;
+  Notation.declare_ref_arguments_scope (VarRef id);
   !xml_declare_variable oname;
-  Dischargedhypsmap.set_discharged_hyps sp [];
   oname
 
-(* when coming from discharge: no xml output *)
-let redeclare_variable id discharged_hyps obj =
-  let oname = declare_variable_common id obj in
-  Dischargedhypsmap.set_discharged_hyps (fst oname) discharged_hyps
-
 (* Globals: constants and parameters *)
 
-type constant_declaration = constant_entry * global_kind
+type constant_declaration = constant_entry * logical_kind
 
-let csttab = ref (Spmap.empty : global_kind Spmap.t)
+let csttab = ref (Spmap.empty : logical_kind Spmap.t)
 
 let _ = Summary.declare_summary "CONSTANT"
 	  { Summary.freeze_function = (fun () -> !csttab);
@@ -133,37 +134,52 @@ let _ = Summary.declare_summary "CONSTANT"
 	    Summary.survive_module = false;
 	    Summary.survive_section = false }
 
-let cache_constant ((sp,kn),(cdt,kind)) =
-  (if Idmap.mem (basename sp) !vartab then
-    errorlabstrm "cache_constant" 
-      (pr_id (basename sp) ++ str " already exists"));
-  (if Nametab.exists_cci sp then
-    let (_,id) = repr_path sp in
-    errorlabstrm "cache_constant" (pr_id id ++ str " already exists"));
-  let _,dir,_ = repr_kn kn in
-  let kn' = Global.add_constant dir (basename sp) cdt in
-    if kn' <> kn then
-      anomaly "Kernel and Library names do not match";
-  Nametab.push (Nametab.Until 1) sp (ConstRef kn);
-  csttab := Spmap.add sp kind !csttab
-
 (* At load-time, the segment starting from the module name to the discharge *)
 (* section (if Remark or Fact) is needed to access a construction *)
-let load_constant i ((sp,kn),(_,kind)) =
-  (if Nametab.exists_cci sp then
-    let (_,id) = repr_path sp in
-    errorlabstrm "cache_constant" (pr_id id ++ str " already exists"));
-  csttab := Spmap.add sp kind !csttab;
-  Nametab.push (Nametab.Until i) sp (ConstRef kn)
+let load_constant i ((sp,kn),(_,_,kind)) =
+  if Nametab.exists_cci sp then
+    errorlabstrm "cache_constant" 
+      (pr_id (basename sp) ++ str " already exists");
+  Nametab.push (Nametab.Until i) sp (ConstRef (constant_of_kn kn));
+  csttab := Spmap.add sp kind !csttab
 
 (* Opening means making the name without its module qualification available *)
 let open_constant i ((sp,kn),_) =
-  Nametab.push (Nametab.Exactly i) sp (ConstRef kn)
+  Nametab.push (Nametab.Exactly i) sp (ConstRef (constant_of_kn kn))
+
+let cache_constant ((sp,kn),(cdt,dhyps,kind)) =
+  let id = basename sp in
+  let _,dir,_ = repr_kn kn in
+  if Idmap.mem id !vartab or Nametab.exists_cci sp then
+    errorlabstrm "cache_constant" (pr_id id ++ str " already exists");
+  let kn' = Global.add_constant dir id cdt in
+  assert (kn' = constant_of_kn kn);
+  Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn));
+  add_section_constant kn' (Global.lookup_constant kn').const_hyps;
+  Dischargedhypsmap.set_discharged_hyps sp dhyps;
+  csttab := Spmap.add sp kind !csttab
+
+(*s Registration as global tables and rollback. *)
+
+open Cooking
+
+let discharged_hyps kn sechyps =
+  let (_,dir,_) = repr_kn kn in
+  let args = array_map_to_list destVar (instance_from_named_context sechyps) in
+  List.rev (List.map (Libnames.make_path dir) args)
+
+let discharge_constant ((sp,kn),(cdt,dhyps,kind)) =
+  let con = constant_of_kn kn in
+  let cb = Global.lookup_constant con in
+  let repl = replacement_context () in
+  let sechyps = section_segment_of_constant con in
+  let recipe = { d_from=cb; d_modlist=repl; d_abstract=sechyps } in
+  Some (GlobalRecipe recipe,(discharged_hyps kn sechyps)@dhyps,kind)
 
 (* Hack to reduce the size of .vo: we keep only what load/open needs *)
 let dummy_constant_entry = ConstantEntry (ParameterEntry mkProp)
 
-let dummy_constant (ce,mk) = dummy_constant_entry,mk
+let dummy_constant (ce,_,mk) = dummy_constant_entry,[],mk
 
 let export_constant cst = Some (dummy_constant cst)
 
@@ -176,40 +192,44 @@ let (in_constant, out_constant) =
     open_function = open_constant;
     classify_function = classify_constant;
     subst_function = ident_subst_function;
+    discharge_function = discharge_constant;
     export_function = export_constant } 
 
 let hcons_constant_declaration = function
-  | DefinitionEntry ce ->
+  | DefinitionEntry ce when !Options.hash_cons_proofs ->
       let (hcons1_constr,_) = hcons_constr (hcons_names()) in
       DefinitionEntry
        { const_entry_body = hcons1_constr ce.const_entry_body;
-	 const_entry_type = option_app hcons1_constr ce.const_entry_type;
-         const_entry_opaque = ce.const_entry_opaque }
+	 const_entry_type = option_map hcons1_constr ce.const_entry_type;
+         const_entry_opaque = ce.const_entry_opaque; 
+         const_entry_boxed = ce.const_entry_boxed }
   | cd -> cd
 
-let declare_constant_common id discharged_hyps (cd,kind) =
-  let (sp,kn as oname) = add_leaf id (in_constant (cd,kind)) in
+let declare_constant_common id dhyps (cd,kind) =
+  let (sp,kn) = add_leaf id (in_constant (cd,dhyps,kind)) in
+  let kn = constant_of_kn kn in
   declare_constant_implicits kn;
-  Symbols.declare_ref_arguments_scope (ConstRef kn);
-  Dischargedhypsmap.set_discharged_hyps sp discharged_hyps;
-  oname
+  Notation.declare_ref_arguments_scope (ConstRef kn);
+  kn
 
 let declare_constant_gen internal id (cd,kind) =
   let cd = hcons_constant_declaration cd in
-  let oname = declare_constant_common id [] (ConstantEntry cd,kind) in
-  !xml_declare_constant (internal,oname);
-  oname
+  let kn = declare_constant_common id [] (ConstantEntry cd,kind) in
+  !xml_declare_constant (internal,kn);
+  kn
 
 let declare_internal_constant = declare_constant_gen true
 let declare_constant = declare_constant_gen false
 
-(* when coming from discharge *)
-let redeclare_constant id discharged_hyps (cd,kind) =
-  let _ = declare_constant_common id discharged_hyps (GlobalRecipe cd,kind) in
-  ()
-
 (* Inductives. *)
 
+let declare_inductive_argument_scopes kn mie =
+  list_iter_i (fun i {mind_entry_consnames=lc} ->
+    Notation.declare_ref_arguments_scope (IndRef (kn,i));
+    for j=1 to List.length lc do
+      Notation.declare_ref_arguments_scope (ConstructRef ((kn,i),j));
+    done) mie.mind_entry_inds
+
 let inductive_names sp kn mie =
   let (dp,_) = repr_path sp in
   let names, _ = 
@@ -230,39 +250,42 @@ let inductive_names sp kn mie =
       ([], 0) mie.mind_entry_inds
   in names
 
-
 let check_exists_inductive (sp,_) =
   (if Idmap.mem (basename sp) !vartab then
-    errorlabstrm "cache_inductive" 
+    errorlabstrm ""
       (pr_id (basename sp) ++ str " already exists"));
   if Nametab.exists_cci sp then
     let (_,id) = repr_path sp in
-    errorlabstrm "cache_inductive" (pr_id id ++ str " already exists")
+    errorlabstrm "" (pr_id id ++ str " already exists")
 
-let cache_inductive ((sp,kn),mie) =
-  let names = inductive_names sp kn mie in
-  List.iter check_exists_inductive names;
-  let _,dir,_ = repr_kn kn in
-  let kn' = Global.add_mind dir (basename sp) mie in
-    if kn' <> kn then
-      anomaly "Kernel and Library names do not match";
-
-  List.iter 
-    (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref)
-    names
-
-let load_inductive i ((sp,kn),mie) =
+let load_inductive i ((sp,kn),(_,mie)) =
   let names = inductive_names sp kn mie in
   List.iter check_exists_inductive names;
   List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref) names
 
-let open_inductive i ((sp,kn),mie) =
+let open_inductive i ((sp,kn),(_,mie)) =
   let names = inductive_names sp kn mie in
-(*  List.iter (fun (sp, ref) -> Nametab.push 0 (restrict_path 0 sp) ref) names*)
   List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names
 
+let cache_inductive ((sp,kn),(dhyps,mie)) =
+  let names = inductive_names sp kn mie in
+  List.iter check_exists_inductive names;
+  let id = basename sp in
+  let _,dir,_ = repr_kn kn in
+  let kn' = Global.add_mind dir id mie in
+  assert (kn'=kn);
+  add_section_kn kn (Global.lookup_mind kn').mind_hyps;
+  Dischargedhypsmap.set_discharged_hyps sp dhyps;
+  List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names
+
+let discharge_inductive ((sp,kn),(dhyps,mie)) =
+  let mie = Global.lookup_mind kn in
+  let repl = replacement_context () in
+  let sechyps = section_segment_of_mutual_inductive kn in
+  Some (discharged_hyps kn sechyps,
+        Discharge.process_inductive sechyps repl mie)
+
 let dummy_one_inductive_entry mie = {
-  mind_entry_params = [];
   mind_entry_typename = mie.mind_entry_typename;
   mind_entry_arity = mkProp;
   mind_entry_consnames = mie.mind_entry_consnames;
@@ -270,10 +293,11 @@ let dummy_one_inductive_entry mie = {
 }
 
 (* Hack to reduce the size of .vo: we keep only what load/open needs *)
-let dummy_inductive_entry m = {
+let dummy_inductive_entry (_,m) = ([],{
+  mind_entry_params = [];
   mind_entry_record = false;
   mind_entry_finite = true;
-  mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds }
+  mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds })
 
 let export_inductive x = Some (dummy_inductive_entry x)
 
@@ -284,38 +308,20 @@ let (in_inductive, out_inductive) =
     open_function = open_inductive;
     classify_function = (fun (_,a) -> Substitute (dummy_inductive_entry a));
     subst_function = ident_subst_function;
+    discharge_function = discharge_inductive;
     export_function = export_inductive } 
 
-let declare_inductive_argument_scopes kn mie =
-  list_iter_i (fun i {mind_entry_consnames=lc} ->
-    Symbols.declare_ref_arguments_scope (IndRef (kn,i));
-    for j=1 to List.length lc do
-      Symbols.declare_ref_arguments_scope (ConstructRef ((kn,i),j));
-    done) mie.mind_entry_inds
-
-let declare_inductive_common mie =
-  let id = match mie.mind_entry_inds with
-    | ind::_ -> ind.mind_entry_typename
-    | [] -> anomaly "cannot declare an empty list of inductives"
-  in
-  let oname = add_leaf id (in_inductive mie) in
-  declare_mib_implicits (snd oname);
-  declare_inductive_argument_scopes (snd oname) mie;
-  oname
-
 (* for initial declaration *)
 let declare_mind isrecord mie =
-  let (sp,kn as oname) = declare_inductive_common mie in
-  Dischargedhypsmap.set_discharged_hyps sp [] ;
+  let id = match mie.mind_entry_inds with
+    | ind::_ -> ind.mind_entry_typename
+    | [] -> anomaly "cannot declare an empty list of inductives" in
+  let (sp,kn as oname) = add_leaf id (in_inductive ([],mie)) in
+  declare_mib_implicits kn;
+  declare_inductive_argument_scopes kn mie;
   !xml_declare_inductive (isrecord,oname);
   oname
 
-(* when coming from discharge: no xml output *)
-let redeclare_inductive discharged_hyps mie =
- let oname = declare_inductive_common mie in
- Dischargedhypsmap.set_discharged_hyps (fst oname) discharged_hyps ;
- oname
-
 (*s Test and access functions. *)
 
 let is_constant sp = 
@@ -330,12 +336,6 @@ let get_variable id =
     | CheckedSectionLocalDef (c,ty,cst,opaq) -> (id,Some c,ty)
     | CheckedSectionLocalAssum (ty,cst) -> (id,None,ty)
 
-let get_variable_with_constraints id = 
-  let (p,x,_) = Idmap.find id !vartab in
-  match x with
-    | CheckedSectionLocalDef (c,ty,cst,opaq) -> ((id,Some c,ty),cst)
-    | CheckedSectionLocalAssum (ty,cst) -> ((id,None,ty),cst)
-
 let variable_strength _ = Local
 
 let find_section_variable id =
@@ -351,8 +351,10 @@ let variable_kind id =
   pi3 (Idmap.find id !vartab)
 
 let clear_proofs sign =
-  List.map
-    (fun (id,c,t as d) -> if variable_opacity id then (id,None,t) else d) sign
+  List.fold_right
+    (fun (id,c,t as d) signv -> 
+      let d = if variable_opacity id then (id,None,t) else d in
+      Environ.push_named_context_val d signv) sign Environ.empty_named_context_val
 
 (* Global references. *)
 
@@ -378,12 +380,6 @@ let mind_oper_of_id sp id mib =
 	   mip.mind_consnames)
     mib.mind_packets
 
-let context_of_global_reference = function
-  | VarRef id -> []
-  | ConstRef sp -> (Global.lookup_constant sp).const_hyps
-  | IndRef (sp,_) -> (Global.lookup_mind sp).mind_hyps
-  | ConstructRef ((sp,_),_) -> (Global.lookup_mind sp).mind_hyps
-
 let last_section_hyps dir =
   fold_named_context
     (fun (id,_,_) sec_ids ->
diff --git a/library/declare.mli b/library/declare.mli
index 968be059..938bfd06 100644
--- a/library/declare.mli
+++ b/library/declare.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declare.mli,v 1.74.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+(*i $Id: declare.mli 7941 2006-01-28 23:07:59Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -36,42 +36,29 @@ type section_variable_entry =
   | SectionLocalDef of constr * types option * bool (* opacity *)
   | SectionLocalAssum of types
 
-type variable_declaration = dir_path * section_variable_entry * local_kind
+type variable_declaration = dir_path * section_variable_entry * logical_kind
 
 val declare_variable : variable -> variable_declaration -> object_name
 
-(* Declaration from Discharge *)
-val redeclare_variable :
- variable -> Dischargedhypsmap.discharged_hyps -> variable_declaration -> unit
-
 (* Declaration of global constructions *)
 (* i.e. Definition/Theorem/Axiom/Parameter/... *)
 
-type constant_declaration = constant_entry * global_kind
+type constant_declaration = constant_entry * logical_kind
 
 (* [declare_constant id cd] declares a global declaration
    (constant/parameter) with name [id] in the current section; it returns
    the full path of the declaration *)
-val declare_constant : identifier -> constant_declaration -> object_name
+val declare_constant :
+ identifier -> constant_declaration -> constant
 
 val declare_internal_constant :
-  identifier -> constant_declaration -> object_name
-
-val redeclare_constant :
- identifier -> Dischargedhypsmap.discharged_hyps -> 
-      Cooking.recipe * global_kind -> unit
+  identifier -> constant_declaration -> constant
 
 (* [declare_mind me] declares a block of inductive types with
    their constructors in the current section; it returns the path of
    the whole block (boolean must be true iff it is a record) *)
 val declare_mind : bool -> mutual_inductive_entry -> object_name
 
-(* Declaration from Discharge *)
-val redeclare_inductive :
- Dischargedhypsmap.discharged_hyps -> mutual_inductive_entry -> object_name
-
-val out_inductive : Libobject.obj -> mutual_inductive_entry 
-
 val strength_min : strength * strength -> strength
 val string_of_strength : strength -> string
 
@@ -79,24 +66,20 @@ val string_of_strength : strength -> string
 
 val is_constant : section_path -> bool
 val constant_strength : section_path -> strength
-val constant_kind : section_path -> global_kind
+val constant_kind : section_path -> logical_kind
 
-val out_variable : Libobject.obj -> identifier * variable_declaration
 val get_variable : variable -> named_declaration
-val get_variable_with_constraints : 
-  variable -> named_declaration * Univ.constraints
 val variable_strength : variable -> strength 
-val variable_kind : variable -> local_kind
+val variable_kind : variable -> logical_kind
 val find_section_variable : variable -> section_path
 val last_section_hyps : dir_path -> identifier list
-val clear_proofs : named_context -> named_context
+val clear_proofs : named_context -> Environ.named_context_val
 
 (*s Global references *)
 
-val context_of_global_reference : global_reference -> section_context
 val strength_of_global : global_reference -> strength
 
 (* hooks for XML output *)
 val set_xml_declare_variable : (object_name -> unit) -> unit
-val set_xml_declare_constant : (bool * object_name -> unit) -> unit
+val set_xml_declare_constant : (bool * constant -> unit) -> unit
 val set_xml_declare_inductive : (bool * object_name -> unit) -> unit
diff --git a/library/declaremods.ml b/library/declaremods.ml
index 2e8fb0a7..aac2b599 100644
--- a/library/declaremods.ml
+++ b/library/declaremods.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declaremods.ml,v 1.18.2.2 2005/12/30 11:08:56 herbelin Exp $ i*)
+(*i $Id: declaremods.ml 8752 2006-04-27 19:37:33Z herbelin $ i*)
 
 open Pp
 open Util
@@ -17,6 +17,7 @@ open Libnames
 open Libobject
 open Lib
 open Nametab
+open Mod_subst
 
 (* modules and components *)
 
@@ -121,6 +122,18 @@ let msid_of_prefix (_,(mp,sec)) =
     anomaly ("Non-empty section in module name!" ^ 
 	     string_of_mp mp ^ "." ^ string_of_dirpath sec)
 
+(* Check that a module type is not functorial *)
+
+let rec check_sig env = function
+  | MTBident kn -> check_sig env (Environ.lookup_modtype kn env)
+  | MTBsig _ -> ()
+  | MTBfunsig _ -> Modops.error_result_must_be_signature ()
+
+let rec check_sig_entry env = function
+  | MTEident kn -> check_sig env (Environ.lookup_modtype kn env)
+  | MTEsig _ -> ()
+  | MTEfunsig _ -> Modops.error_result_must_be_signature ()
+  | MTEwith (mte,_) -> check_sig_entry env mte
 
 (* This function checks if the type calculated for the module [mp] is
    a subtype of [sub_mtb]. Uses only the global environment. *)
@@ -372,19 +385,25 @@ let (in_modtype,out_modtype) =
 
 
 
-let replace_module_object id (subst, mbids, msid, lib_stack) modobjs =
+let rec replace_module_object idl (subst, mbids, msid, lib_stack) modobjs =
   if mbids<>[] then 
     error "Unexpected functor objects"
   else
-    let rec replace_id = function 
-      | [] -> [] 
-      | (id',obj)::tail when id = id' ->
+    let rec replace_idl = function 
+      | _,[] -> [] 
+      | id::idl,(id',obj)::tail when id = id' ->
 	  if object_tag obj = "MODULE" then
-	    (id, in_module (None,modobjs,None))::tail
+           (match idl with
+               [] -> (id, in_module (None,modobjs,None))::tail
+             | _ ->
+               let (_,substobjs,_) = out_module obj in
+                let substobjs' = replace_module_object idl substobjs modobjs in
+                 (id, in_module (None,substobjs',None))::tail
+           )
 	  else error "MODULE expected!"
-      | lobj::tail -> lobj::replace_id tail
+      | idl,lobj::tail -> lobj::replace_idl (idl,tail)
     in
-      (subst, mbids, msid, replace_id lib_stack)
+      (subst, mbids, msid, replace_idl (idl,lib_stack))
 
 let abstract_substobjs mbids1 (subst, mbids2, msid, lib_stack) =
   (subst, mbids1@mbids2, msid, lib_stack)
@@ -396,10 +415,10 @@ let rec get_modtype_substobjs = function
       let (subst, mbids, msid, objs) = get_modtype_substobjs mte in
 	(subst, mbid::mbids, msid, objs)
   | MTEwith (mty, With_Definition _) -> get_modtype_substobjs mty
-  | MTEwith (mty, With_Module (id,mp)) -> 
+  | MTEwith (mty, With_Module (idl,mp)) -> 
       let substobjs = get_modtype_substobjs mty in
       let modobjs = MPmap.find mp !modtab_substobjs in
-	replace_module_object id substobjs modobjs
+	replace_module_object idl substobjs modobjs
   | MTEsig (msid,_) -> 
       todo "Anonymous module types"; (empty_subst, [], msid, [])
 
@@ -427,61 +446,50 @@ let rec get_some_body mty env = match mty with
       replace_module (get_some_body mty env) id (Environ.lookup_module mp env)
 
 
-let intern_args interp_modtype (env,oldargs) (idl,arg) = 
+let intern_args interp_modtype (idl,arg) = 
   let lib_dir = Lib.library_dp() in
   let mbids = List.map (fun (_,id) -> make_mbid lib_dir (string_of_id id)) idl in
-  let mty = interp_modtype env arg in
+  let mty = interp_modtype (Global.env()) arg in
   let dirs = List.map (fun (_,id) -> make_dirpath [id]) idl in
-  let mps = List.map (fun mbid -> MPbound mbid) mbids in
   let substobjs = get_modtype_substobjs mty in
-  let substituted's = 
-    List.map2 
-      (fun dir mp -> dir, mp, subst_substobjs dir mp substobjs) 
-      dirs mps  
-  in
-    List.iter 
-      (fun (dir, mp, substituted) -> 
-	 do_module false "interp" load_objects 1 dir mp substobjs substituted)
-      substituted's;
-    let body = Modops.module_body_of_type (get_some_body mty env) in
-    let env = 
-      List.fold_left (fun env mp -> Modops.add_module mp body env) env mps
-    in
-    env, List.map (fun mbid -> mbid,mty) mbids :: oldargs
-      
-let start_module interp_modtype id args res_o =
+  List.map2
+    (fun dir mbid -> 
+      Global.add_module_parameter mbid mty;
+      let mp = MPbound mbid in
+      let substituted = subst_substobjs dir mp substobjs in
+      do_module false "interp" load_objects 1 dir mp substobjs substituted;
+      (mbid,mty))
+    dirs mbids
+
+let start_module interp_modtype export id args res_o =
   let fs = Summary.freeze_summaries () in
-  let env = Global.env () in
-  let env,arg_entries_revlist = 
-    List.fold_left (intern_args interp_modtype) (env,[]) args 
-  in
-  let arg_entries = List.concat (List.rev arg_entries_revlist) in
+
+  let mp = Global.start_module id in
+  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
 
   let res_entry_o, sub_body_o = match res_o with
       None -> None, None
-    | Some (res, true) ->
-	Some (interp_modtype env res), None
-    | Some (res, false) ->
-	(* If the module type is non-restricting, we must translate it
-	   here to catch errors as early as possible. If it is
-	   estricting, the kernel takes care of it.  *)
-	let sub_mte = 
-	  List.fold_right 
-	    (fun (arg_id,arg_t) mte -> MTEfunsig(arg_id,arg_t,mte))
-	    arg_entries 
-	    (interp_modtype env res)
-	in
-	let sub_mtb = 
-	  Mod_typing.translate_modtype (Global.env()) sub_mte
-	in
+    | Some (res, restricted) ->
+	(* we translate the module here to catch errors as early as possible *)
+	let mte = interp_modtype (Global.env()) res in
+	check_sig_entry (Global.env()) mte;
+	if restricted then
+	  Some mte, None
+	else
+	  let mtb = Mod_typing.translate_modtype (Global.env()) mte in
+	  let sub_mtb = 
+	    List.fold_right 
+	      (fun (arg_id,arg_t) mte -> 
+		let arg_t = Mod_typing.translate_modtype (Global.env()) arg_t
+		in MTBfunsig(arg_id,arg_t,mte))
+	      arg_entries mtb
+	  in
 	  None, Some sub_mtb
   in
 
-  let mp = Global.start_module id arg_entries res_entry_o in
-
   let mbids = List.map fst arg_entries in
   openmod_info:=(mbids,res_entry_o,sub_body_o);
-  let prefix = Lib.start_module id mp fs in
+  let prefix = Lib.start_module export id mp fs in
   Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix);
   Lib.add_frozen_state ()
 
@@ -489,8 +497,8 @@ let start_module interp_modtype id args res_o =
 let end_module id =
 
   let oldoname,oldprefix,fs,lib_stack = Lib.end_module id in
-  let mp = Global.end_module id in
   let mbids, res_o, sub_o = !openmod_info in
+  let mp = Global.end_module id res_o in
     
   begin match sub_o with
       None -> ()
@@ -565,7 +573,6 @@ let library_cache = Hashtbl.create 17
 
 let register_library dir cenv objs digest =
   let mp = MPfile dir in
-  let prefix = dir, (mp, empty_dirpath) in
   let substobjs, objects =
     try 
       ignore(Global.lookup_module mp);
@@ -578,7 +585,7 @@ let register_library dir cenv objs digest =
 	  let msid,substitute,keep = objs in
 	  let substobjs = empty_subst, [], msid, substitute in
 	  let substituted = subst_substobjs dir mp substobjs in
-	  let objects = option_app (fun seg -> seg@keep) substituted in
+	  let objects = option_map (fun seg -> seg@keep) substituted in
 	  let modobjs = substobjs, objects in
 	    Hashtbl.add library_cache dir modobjs;
 	    modobjs
@@ -638,13 +645,9 @@ let import_module export mp =
 
 let start_modtype interp_modtype id args =
   let fs = Summary.freeze_summaries () in
-  let env = Global.env () in
-  let env,arg_entries_revlist = 
-    List.fold_left (intern_args interp_modtype) (env,[]) args 
-  in
-  let arg_entries = List.concat (List.rev arg_entries_revlist) in
 
-  let mp = Global.start_modtype id arg_entries in
+  let mp = Global.start_modtype id in
+  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
 
   let mbids = List.map fst arg_entries in
   openmodtype_info := mbids;
@@ -679,12 +682,11 @@ let end_modtype id =
 
 let declare_modtype interp_modtype id args mty = 
   let fs = Summary.freeze_summaries () in
-  let env = Global.env () in
-  let env,arg_entries_revlist = 
-    List.fold_left (intern_args interp_modtype) (env,[]) args 
-  in
-  let arg_entries = List.concat (List.rev arg_entries_revlist) in
-  let base_mty = interp_modtype env mty in
+
+  let _ = Global.start_modtype id in
+  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
+
+  let base_mty = interp_modtype (Global.env()) mty in
   let entry = 
     List.fold_right 
       (fun (arg_id,arg_t) mte -> MTEfunsig(arg_id,arg_t,mte))
@@ -697,21 +699,25 @@ let declare_modtype interp_modtype id args mty =
   ignore (add_leaf id (in_modtype (Some entry, substobjs)))
 			       
 
-
-let rec get_module_substobjs = function
+let rec get_module_substobjs env = function
   | MEident mp -> MPmap.find mp !modtab_substobjs 
   | MEfunctor (mbid,mty,mexpr) ->
-      let (subst, mbids, msid, objs) = 
-	get_module_substobjs mexpr 
-      in
+       let (subst, mbids, msid, objs) = get_module_substobjs env mexpr in
 	(subst, mbid::mbids, msid, objs)
   | MEstruct (msid,_) ->
       (empty_subst, [], msid, [])
   | MEapply (mexpr, MEident mp) ->
-      let (subst, mbids, msid, objs) = get_module_substobjs mexpr in
+      let feb,ftb = Mod_typing.translate_mexpr env mexpr in
+      let ftb = Modops.scrape_modtype env ftb in
+      let farg_id, farg_b, fbody_b = Modops.destr_functor ftb in
+      let (subst, mbids, msid, objs) = get_module_substobjs env mexpr in
 	(match mbids with
 	   | mbid::mbids ->
-	       (add_mbid mbid mp subst, mbids, msid, objs)
+              let resolve =
+               Modops.resolver_of_environment farg_id farg_b mp env in
+               (* application outside the kernel, only for substitutive
+                  objects (that are all non-logical objects) *)
+	       (add_mbid mbid mp (Some resolve) subst, mbids, msid, objs)
 	   | [] -> match mexpr with
 	       | MEident _ | MEstruct _ -> error "Application of a non-functor"
 	       | _ -> error "Application of a functor with too few arguments")
@@ -720,27 +726,25 @@ let rec get_module_substobjs = function
 
 
 let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o =
-
   let fs = Summary.freeze_summaries () in
-  let env = Global.env () in
-  let env,arg_entries_revlist = 
-    List.fold_left (intern_args interp_modtype) (env,[]) args 
-  in
-  let arg_entries = List.concat (List.rev arg_entries_revlist) in
+
+  let _ = Global.start_module id in
+  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
+
   let mty_entry_o, mty_sub_o = match mty_o with
       None -> None, None
     | (Some (mty, true)) -> 
 	Some (List.fold_right 
 		(fun (arg_id,arg_t) mte -> MTEfunsig(arg_id,arg_t,mte))
 		arg_entries 
-		(interp_modtype env mty)), 
+		(interp_modtype (Global.env()) mty)), 
 	None
     | (Some (mty, false)) -> 
 	None, 
 	Some (List.fold_right 
 		(fun (arg_id,arg_t) mte -> MTEfunsig(arg_id,arg_t,mte))
 		arg_entries 
-		(interp_modtype env mty))
+		(interp_modtype (Global.env()) mty))
   in
   let mexpr_entry_o = match mexpr_o with
       None -> None
@@ -748,16 +752,17 @@ let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o =
 	Some (List.fold_right 
 		(fun (mbid,mte) me -> MEfunctor(mbid,mte,me))
 		arg_entries
-		(interp_modexpr env mexpr))
+		(interp_modexpr (Global.env()) mexpr))
   in
   let entry = 
     {mod_entry_type = mty_entry_o;	    
      mod_entry_expr = mexpr_entry_o }
   in
+  let env = Global.env() in
   let substobjs =
     match entry with
       | {mod_entry_type = Some mte} -> get_modtype_substobjs mte
-      | {mod_entry_expr = Some mexpr} -> get_module_substobjs mexpr
+      | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mexpr
       | _ -> anomaly "declare_module: No type, no body ..."
   in
     Summary.unfreeze_summaries fs;
@@ -772,23 +777,7 @@ let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o =
 
 (*s Iterators. *)
 
-let fold_all_segments insec f x =
-  let acc' = 
-    MPmap.fold 
-      (fun _ (prefix,objects) acc -> 
-	 let apply_obj acc (id,obj) = f acc (make_oname prefix id) obj in
-	   List.fold_left apply_obj acc objects)
-      !modtab_objects x
-  in
-  let rec apply_node acc = function
-    | sp, Leaf o -> f acc sp o
-    | _, ClosedSection (_,_,seg) -> 
-	if insec then List.fold_left apply_node acc seg else acc
-    | _ -> acc
-  in
-    List.fold_left apply_node acc' (Lib.contents_after None)
-
-let iter_all_segments insec f =
+let iter_all_segments f =
   let _ = 
     MPmap.iter 
       (fun _ (prefix,objects) -> 
@@ -798,13 +787,11 @@ let iter_all_segments insec f =
   in
   let rec apply_node = function
     | sp, Leaf o -> f sp o
-    | _, ClosedSection (_,_,seg) -> if insec then List.iter apply_node seg
     | _ -> ()
   in
     List.iter apply_node (Lib.contents_after None)
 
 
-
 let debug_print_modtab _ =
   let pr_seg = function
     | [] -> str "[]"
@@ -816,5 +803,3 @@ let debug_print_modtab _ =
   in
   let modules = MPmap.fold pr_modinfo !modtab_objects (mt ()) in
     hov 0 modules
-
-
diff --git a/library/declaremods.mli b/library/declaremods.mli
index f896310a..481809fc 100644
--- a/library/declaremods.mli
+++ b/library/declaremods.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: declaremods.mli,v 1.8.2.2 2005/01/21 16:41:50 herbelin Exp $ i*)
+(*i $Id: declaremods.mli 6758 2005-02-20 18:13:28Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -43,9 +43,8 @@ val declare_module :
   'modexpr option -> unit
  
 val start_module : (env -> 'modtype -> module_type_entry) -> 
-  identifier -> 
-  (identifier located list * 'modtype) list -> ('modtype * bool) option -> 
-  unit
+  bool option -> identifier -> (identifier located list * 'modtype) list ->
+   ('modtype * bool) option -> unit
 
 val end_module : identifier -> unit
 
@@ -97,14 +96,12 @@ val really_import_module : module_path -> unit
 val import_module : bool -> module_path -> unit
 
 
-(*s [fold_all_segments] and [iter_all_segments] iterate over all
-    segments, the modules' segments first and then the current
-    segment. Modules are presented in an arbitrary order. The given
-    function is applied to all leaves (together with their section
-    path). The boolean indicates if we must enter closed sections. *)
+(*s [iter_all_segments] iterate over all segments, the modules'
+    segments first and then the current segment. Modules are presented
+    in an arbitrary order. The given function is applied to all leaves
+    (together with their section path). *)
 
-val fold_all_segments : bool -> ('a -> object_name -> obj -> 'a) -> 'a -> 'a
-val iter_all_segments : bool -> (object_name -> obj -> unit) -> unit
+val iter_all_segments : (object_name -> obj -> unit) -> unit
 
 
 val debug_print_modtab : unit -> Pp.std_ppcmds
diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml
index 59a01d81..255f5e75 100644
--- a/library/dischargedhypsmap.ml
+++ b/library/dischargedhypsmap.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dischargedhypsmap.ml,v 1.3.2.1 2004/07/16 19:30:35 herbelin Exp $ *)
+(* $Id: dischargedhypsmap.ml 9488 2007-01-17 11:11:58Z herbelin $ *)
 
 open Util
 open Libnames
@@ -24,18 +24,9 @@ type discharged_hyps = section_path list
 
 let discharged_hyps_map = ref Spmap.empty
 
-let cache_discharged_hyps_map (_,(sp,hyps)) = 
+let set_discharged_hyps sp hyps = 
   discharged_hyps_map := Spmap.add sp hyps !discharged_hyps_map
 
-let (in_discharged_hyps_map, _) =
-  declare_object { (default_object "DISCHARGED-HYPS-MAP") with
-    cache_function = cache_discharged_hyps_map;
-    load_function = (fun _ -> cache_discharged_hyps_map);
-    export_function = (fun x -> Some x) }
-
-let set_discharged_hyps sp hyps =
- add_anonymous_leaf (in_discharged_hyps_map (sp,hyps))
-
 let get_discharged_hyps sp =
   try
    Spmap.find sp !discharged_hyps_map
diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli
index 8851e5a3..9a3259ce 100644
--- a/library/dischargedhypsmap.mli
+++ b/library/dischargedhypsmap.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: dischargedhypsmap.mli,v 1.2.8.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+(*i $Id: dischargedhypsmap.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Libnames
diff --git a/library/global.ml b/library/global.ml
index 8694d7af..ab5d8956 100644
--- a/library/global.ml
+++ b/library/global.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: global.ml,v 1.43.2.2 2005/11/23 14:46:17 barras Exp $ *)
+(* $Id: global.ml 9310 2006-10-28 19:35:09Z herbelin $ *)
 
 open Util
 open Names
@@ -39,6 +39,7 @@ let _ =
 
 let universes () = universes (env())
 let named_context () = named_context (env())
+let named_context_val () = named_context_val (env())
 
 let push_named_assum a =
   let (cst,env) = push_named_assum a !global_env in
@@ -72,22 +73,27 @@ let add_constraints c = global_env := add_constraints c !global_env
 
 let set_engagement c = global_env := set_engagement c !global_env
 
-let start_module id params mtyo =
+let start_module id =
   let l = label_of_id id in
-  let mp,newenv = start_module l params mtyo !global_env in
+  let mp,newenv = start_module l !global_env in
     global_env := newenv;
     mp
-  
-let end_module id =
+
+let end_module id mtyo =
   let l = label_of_id id in
-  let mp,newenv = end_module l !global_env in
+  let mp,newenv = end_module l mtyo !global_env in
     global_env := newenv;
     mp
 
 
-let start_modtype id params = 
+let add_module_parameter mbid mte =
+  let newenv = add_module_parameter mbid mte !global_env in
+    global_env := newenv
+
+
+let start_modtype id =
   let l = label_of_id id in
-  let mp,newenv = start_modtype l params !global_env in
+  let mp,newenv = start_modtype l !global_env in
     global_env := newenv;
     mp
 
@@ -134,14 +140,14 @@ let env_of_context hyps =
 open Libnames
 
 let type_of_reference env = function
-  | VarRef id -> let (_,_,t) = Environ.lookup_named id env in t
-  | ConstRef c -> Environ.constant_type env c
-  | IndRef ind -> Inductive.type_of_inductive env ind
-  | ConstructRef cstr -> Inductive.type_of_constructor env cstr
+  | VarRef id -> Environ.named_type id env 
+  | ConstRef c -> Typeops.type_of_constant env c
+  | IndRef ind ->
+     let specif = Inductive.lookup_mind_specif env ind in
+      Inductive.type_of_inductive env specif
+  | ConstructRef cstr ->
+     let specif =
+      Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+       Inductive.type_of_constructor cstr specif
 
 let type_of_global t = type_of_reference (env ()) t
-
-
-(*let get_kn dp l = 
-  make_kn (current_modpath !global_env) dp l
-*)
diff --git a/library/global.mli b/library/global.mli
index 007986d1..96965465 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: global.mli,v 1.40.2.2 2005/11/23 14:46:17 barras Exp $ i*)
+(*i $Id: global.mli 8723 2006-04-16 15:51:02Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -29,7 +29,10 @@ open Safe_typing
 val safe_env : unit -> safe_environment
 val env : unit -> Environ.env
 
+val env_is_empty : unit -> bool
+
 val universes : unit -> universes
+val named_context_val : unit -> Environ.named_context_val
 val named_context : unit -> Sign.named_context
 
 val env_is_empty : unit -> bool
@@ -42,7 +45,7 @@ val push_named_def   : (identifier * constr * types option) -> Univ.constraints
   functions verify that given names match those generated by kernel *)
 
 val add_constant : 
-  dir_path -> identifier -> global_declaration -> kernel_name
+  dir_path -> identifier -> global_declaration -> constant
 val add_mind        : 
   dir_path -> identifier -> mutual_inductive_entry -> kernel_name
 
@@ -51,7 +54,7 @@ val add_modtype     : identifier -> module_type_entry -> kernel_name
 
 val add_constraints : constraints -> unit
 
-val set_engagement : Environ.engagement -> unit
+val set_engagement : engagement -> unit
 
 (*s Interactive modules and module types *)
 (* Both [start_*] functions take the [dir_path] argument to create a 
@@ -60,20 +63,13 @@ val set_engagement : Environ.engagement -> unit
 (* [start_*] functions return the [module_path] valid for components
    of the started module / module type *)
 
-val start_module : 
-  identifier -> (mod_bound_id * module_type_entry) list 
-    -> module_type_entry option 
-      -> module_path
-
-val end_module :
-  identifier -> module_path
+val start_module : identifier -> module_path
+val end_module : identifier -> module_type_entry option -> module_path
 
-val start_modtype :
-  identifier -> (mod_bound_id * module_type_entry) list
-    -> module_path
+val add_module_parameter : mod_bound_id -> module_type_entry -> unit
 
-val end_modtype :
-  identifier -> kernel_name
+val start_modtype : identifier -> module_path
+val end_modtype : identifier -> kernel_name
 
 
 (* Queries *)
@@ -93,5 +89,5 @@ val import : compiled_library -> Digest.t -> module_path
  * environment and a given context. *)
   
 val type_of_global : Libnames.global_reference -> types
-val env_of_context : Sign.named_context -> Environ.env
+val env_of_context : Environ.named_context_val -> Environ.env
 
diff --git a/library/goptions.ml b/library/goptions.ml
index bcb4fb79..4d36e1c5 100644
--- a/library/goptions.ml
+++ b/library/goptions.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: goptions.ml,v 1.22.2.1 2004/07/16 19:30:35 herbelin Exp $ *)
+(* $Id: goptions.ml 9060 2006-07-27 15:30:35Z notin $ *)
 
 (* This module manages customization parameters at the vernacular level     *)
 
@@ -17,6 +17,7 @@ open Names
 open Libnames
 open Term
 open Nametab
+open Mod_subst
 
 (****************************************************************************)
 (* 0- Common things                                                         *)
@@ -252,7 +253,7 @@ let declare_option cast uncast
 	       unfreeze_function = write;
 	       init_function = (fun () -> write default);
 	       survive_module = false;
-	       survive_section = true}
+	       survive_section = false}
     in 
     fun v -> add_anonymous_leaf (decl_obj v)
   else write
diff --git a/library/goptions.mli b/library/goptions.mli
index bbf5357a..16744ec4 100644
--- a/library/goptions.mli
+++ b/library/goptions.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: goptions.mli,v 1.10.6.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+(*i $Id: goptions.mli 6304 2004-11-16 15:49:08Z sacerdot $ i*)
 
 (* This module manages customization parameters at the vernacular level     *)
 
@@ -59,6 +59,7 @@ open Names
 open Libnames
 open Term
 open Nametab
+open Mod_subst
 (*i*)
 
 (*s Things common to tables and options. *)
diff --git a/library/impargs.ml b/library/impargs.ml
index 8a9429a4..8cea4737 100644
--- a/library/impargs.ml
+++ b/library/impargs.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: impargs.ml,v 1.59.2.1 2004/07/16 19:30:35 herbelin Exp $ *)
+(* $Id: impargs.ml 9488 2007-01-17 11:11:58Z herbelin $ *)
 
 open Util
 open Names
@@ -27,63 +27,44 @@ open Topconstr
 
 (* les implicites sont stricts par défaut en v8 *)
 let implicit_args = ref false
-let strict_implicit_args = ref (not !Options.v7)
+let strict_implicit_args = ref true
 let contextual_implicit_args = ref false
 
-let implicit_args_out = ref false
-let strict_implicit_args_out = ref true
-let contextual_implicit_args_out = ref false
-
 let make_implicit_args flag =
-  implicit_args := flag;
-  if not !Options.v7_only then implicit_args_out := flag;
-  if !Options.translate_strict_impargs then
-    strict_implicit_args_out := not flag
+  implicit_args := flag
 
 let make_strict_implicit_args flag =
-  strict_implicit_args := flag;
-  if not !Options.v7_only then strict_implicit_args_out := flag
+  strict_implicit_args := flag
 
 let make_contextual_implicit_args flag =
-  contextual_implicit_args := flag;
-  if not !Options.v7_only then contextual_implicit_args_out := flag
+  contextual_implicit_args := flag
 
 let is_implicit_args () = !implicit_args
-let is_implicit_args_out () = !implicit_args_out
 let is_strict_implicit_args () = !strict_implicit_args
 let is_contextual_implicit_args () = !contextual_implicit_args
 
-type implicits_flags = (bool * bool * bool) * (bool * bool * bool)
+type implicits_flags = bool * bool * bool
+
+let implicit_flags () = 
+  (!implicit_args, !strict_implicit_args, !contextual_implicit_args)
 
-let with_implicits ((a,b,c),(d,e,g)) f x =
+let with_implicits (a,b,c) f x =
   let oa = !implicit_args in
   let ob = !strict_implicit_args in
   let oc = !contextual_implicit_args in
-  let od = !implicit_args_out in
-  let oe = !strict_implicit_args_out in
-  let og = !contextual_implicit_args_out in
   try 
     implicit_args := a;
     strict_implicit_args := b;
     contextual_implicit_args := c;
-    implicit_args_out := d;
-    strict_implicit_args_out := e;
-    contextual_implicit_args_out := g;
     let rslt = f x in 
     implicit_args := oa;
     strict_implicit_args := ob;
     contextual_implicit_args := oc;
-    implicit_args_out := od;
-    strict_implicit_args_out := oe;
-    contextual_implicit_args_out := og;
     rslt
   with e -> begin
     implicit_args := oa;
     strict_implicit_args := ob;
     contextual_implicit_args := oc;
-    implicit_args_out := od;
-    strict_implicit_args_out := oe;
-    contextual_implicit_args_out := og;
     raise e
   end
 
@@ -135,7 +116,7 @@ let update pos rig (na,st) =
       | Some (DepFlexAndRigid (fpos,rpos) as x) ->
           if argument_less (pos,fpos) or pos=fpos then DepRigid pos else
           if argument_less (pos,rpos) then DepFlexAndRigid (fpos,pos) else x
-      | Some (DepFlex fpos as x) ->
+      | Some (DepFlex fpos) ->
           if argument_less (pos,fpos) or pos=fpos then DepRigid pos
           else DepFlexAndRigid (fpos,pos)
       | Some Manual -> assert false
@@ -186,12 +167,6 @@ let add_free_rels_until strict bound env m pos acc =
 
 (* calcule la liste des arguments implicites *)
 
-let my_concrete_name avoid names t = function
-  | Anonymous -> Anonymous, avoid, Anonymous::names
-  | na -> 
-      let id = Termops.next_name_not_occuring false na avoid names t in
-      Name id, id::avoid, Name id::names
-  
 let compute_implicits_gen strict contextual env t =
   let rec aux env avoid n names t =
     let t = whd_betadeltaiota env t in
@@ -213,19 +188,50 @@ let compute_implicits_gen strict contextual env t =
 	Array.to_list v
     | _ -> []
 
-let compute_implicits output env t =
-  let strict =
-    (not output & !strict_implicit_args) or
-    (output & !strict_implicit_args_out) in 
-  let contextual =
-    (not output & !contextual_implicit_args) or
-    (output & !contextual_implicit_args_out) in
+let compute_implicits_auto env (_,strict,contextual) t =
   let l = compute_implicits_gen strict contextual env t in
   List.map (function
     | (Name id, Some imp) -> Some (id,imp)
     | (Anonymous, Some _) -> anomaly "Unnamed implicit"
     | _ -> None) l
 
+let compute_implicits env t = compute_implicits_auto env (implicit_flags()) t
+
+let set_implicit id imp =
+  Some (id,match imp with None -> Manual | Some imp -> imp)
+
+let compute_manual_implicits flags ref l =
+  let t = Global.type_of_global ref in
+  let autoimps = compute_implicits_gen false true (Global.env()) t in
+  let n = List.length autoimps in
+  if not (list_distinct l) then 
+    error ("Some parameters are referred more than once");
+  (* Compare with automatic implicits to recover printing data and names *)
+  let rec merge k l = function
+    | (Name id,imp)::imps ->
+	let l',imp =
+	  try list_remove_first (ExplByPos k) l, set_implicit id imp
+	  with Not_found ->
+	  try list_remove_first (ExplByName id) l, set_implicit id imp
+	  with Not_found ->
+	  l, None in
+	imp :: merge (k+1) l' imps
+    | (Anonymous,imp)::imps -> 
+	None :: merge (k+1) l imps
+    | [] when l = [] -> []
+    | _ ->
+	match List.hd l with
+	| ExplByName id ->
+	    error ("Wrong or not dependent implicit argument name: "^(string_of_id id))
+	| ExplByPos i ->
+	    if i<1 or i>n then 
+	      error ("Bad implicit argument number: "^(string_of_int i))
+	    else
+	      errorlabstrm ""
+		(str "Cannot set implicit argument number " ++ int i ++
+		 str ": it has no name") in
+  merge 1 l autoimps
+
 type implicit_status =
     (* None = Not implicit *)
     (identifier * implicit_explanation) option
@@ -261,255 +267,168 @@ let positions_of_implicits =
 type strict_flag = bool     (* true = strict *)
 type contextual_flag = bool (* true = contextual *)
 
-type implicits =
-  | Impl_auto of strict_flag * contextual_flag * implicits_list
-  | Impl_manual of implicits_list
-  | No_impl
-
-let auto_implicits env ty =
-  let impl = 
-    if !implicit_args then
-      let l = compute_implicits false env ty in
-      Impl_auto (!strict_implicit_args,!contextual_implicit_args,l)
-    else
-      No_impl in
-  if Options.do_translate () then
-    impl, 
-    if !implicit_args_out then 
-      (let l = compute_implicits true env ty in
-      Impl_auto (!strict_implicit_args_out,!contextual_implicit_args_out,l))
-    else No_impl
-  else 
-    impl, impl
-
-let list_of_implicits = function 
-  | Impl_auto (_,_,l) -> l
-  | Impl_manual l -> l
-  | No_impl -> []
-
 (*s Constants. *)
 
-let constants_table = ref KNmap.empty
-
-let compute_constant_implicits kn =
+let compute_constant_implicits flags cst =
   let env = Global.env () in
-  let cb = lookup_constant kn env in
-  auto_implicits env (body_of_type cb.const_type)
-
-let constant_implicits sp =
-  try KNmap.find sp !constants_table with Not_found -> No_impl,No_impl
+  compute_implicits_auto env flags (Typeops.type_of_constant env cst)
 
 (*s Inductives and constructors. Their implicit arguments are stored
    in an array, indexed by the inductive number, of pairs $(i,v)$ where
    $i$ are the implicit arguments of the inductive and $v$ the array of 
    implicit arguments of the constructors. *)
 
-let inductives_table = ref Indmap.empty
-
-let constructors_table = ref Constrmap.empty
-
-let compute_mib_implicits kn =
+let compute_mib_implicits flags kn =
   let env = Global.env () in
   let mib = lookup_mind kn env in
   let ar =
     Array.to_list
       (Array.map  (* No need to lift, arities contain no de Bruijn *)
-        (fun mip -> (Name mip.mind_typename, None, mip.mind_user_arity))
+        (fun mip ->
+	  (Name mip.mind_typename, None, type_of_inductive env (mib,mip)))
         mib.mind_packets) in
   let env_ar = push_rel_context ar env in
   let imps_one_inductive i mip =
     let ind = (kn,i) in
-    ((IndRef ind,auto_implicits env (body_of_type mip.mind_user_arity)),
-     Array.mapi (fun j c -> (ConstructRef (ind,j+1),auto_implicits env_ar c))
-       mip.mind_user_lc)
+    let ar = type_of_inductive env (mib,mip) in
+    ((IndRef ind,compute_implicits_auto env flags ar),
+     Array.mapi (fun j c ->
+       (ConstructRef (ind,j+1),compute_implicits_auto env_ar flags c))
+       mip.mind_nf_lc)
   in
   Array.mapi imps_one_inductive mib.mind_packets
 
-let inductive_implicits indp =
-  try Indmap.find indp !inductives_table with Not_found -> No_impl,No_impl
+let compute_all_mib_implicits flags kn =
+  let imps = compute_mib_implicits flags kn in
+  List.flatten 
+    (array_map_to_list (fun (ind,cstrs) -> ind::Array.to_list cstrs) imps)
 
-let constructor_implicits consp =
-  try Constrmap.find consp !constructors_table with Not_found -> No_impl,No_impl
 (*s Variables. *)
 
-let var_table = ref Idmap.empty
-
-let compute_var_implicits id =
+let compute_var_implicits flags id =
   let env = Global.env () in
   let (_,_,ty) = lookup_named id env in
-  auto_implicits env ty
+  compute_implicits_auto env flags ty
+
+(* Implicits of a global reference. *)
 
-let var_implicits id = 
-  try Idmap.find id !var_table with Not_found -> No_impl,No_impl
+let compute_global_implicits flags = function
+  | VarRef id -> compute_var_implicits flags id
+  | ConstRef kn -> compute_constant_implicits flags kn
+  | IndRef (kn,i) -> 
+      let ((_,imps),_) = (compute_mib_implicits flags kn).(i) in imps
+  | ConstructRef ((kn,i),j) -> 
+      let (_,cimps) = (compute_mib_implicits flags kn).(i) in snd cimps.(j-1)
 
 (* Caching implicits *)
 
-let cache_implicits_decl (r,imps) =
-  match r with
-  | VarRef id -> 
-      var_table := Idmap.add id imps !var_table
-  | ConstRef kn ->
-      constants_table := KNmap.add kn imps !constants_table
-  | IndRef indp ->
-      inductives_table := Indmap.add indp imps !inductives_table;
-  | ConstructRef consp -> 
-      constructors_table := Constrmap.add consp imps !constructors_table
+type implicit_interactive_request = ImplAuto | ImplManual of explicitation list
 
-let cache_implicits (_,l) = List.iter cache_implicits_decl l
+type implicit_discharge_request =
+  | ImplNoDischarge
+  | ImplConstant of constant * implicits_flags
+  | ImplMutualInductive of kernel_name * implicits_flags
+  | ImplInteractive of global_reference * implicits_flags * 
+      implicit_interactive_request
 
-let subst_implicits_decl subst (r,imps as o) =
-  let r' = subst_global subst r in if r==r' then o else (r',imps)
+let implicits_table = ref Refmap.empty
 
-let subst_implicits (_,subst,l) =
-  list_smartmap (subst_implicits_decl subst) l
+let implicits_of_global ref =
+  try Refmap.find ref !implicits_table with Not_found -> []
 
-let (in_implicits, _) =
+let cache_implicits_decl (ref,imps) =
+  implicits_table := Refmap.add ref imps !implicits_table
+
+let load_implicits _ (_,(_,l)) = List.iter cache_implicits_decl l
+
+let cache_implicits o =
+  load_implicits 1 o
+
+let subst_implicits_decl subst (r,imps as o) =
+  let r' = fst (subst_global subst r) in if r==r' then o else (r',imps)
+
+let subst_implicits (_,subst,(req,l)) =
+  (ImplNoDischarge,list_smartmap (subst_implicits_decl subst) l)
+
+let discharge_implicits (_,(req,l)) =
+  match req with
+  | ImplNoDischarge -> None
+  | ImplInteractive (ref,flags,exp) -> 
+      Some (ImplInteractive (pop_global_reference ref,flags,exp),l)
+  | ImplConstant (con,flags) ->
+      Some (ImplConstant (pop_con con,flags),l)
+  | ImplMutualInductive (kn,flags) ->
+      Some (ImplMutualInductive (pop_kn kn,flags),l)
+
+let rebuild_implicits (req,l) =
+  let l' = match req with
+  | ImplNoDischarge -> assert false
+  | ImplConstant (con,flags) -> 
+      [ConstRef con,compute_constant_implicits flags con]
+  | ImplMutualInductive (kn,flags) ->
+      compute_all_mib_implicits flags kn
+  | ImplInteractive (ref,flags,o) ->
+      match o with
+      | ImplAuto -> [ref,compute_global_implicits flags ref]
+      | ImplManual l ->
+	  error "Discharge of global manually given implicit arguments not implemented" in
+  (req,l')
+
+
+let (inImplicits, _) =
   declare_object {(default_object "IMPLICITS") with 
     cache_function = cache_implicits;
-    load_function = (fun _ -> cache_implicits);
+    load_function = load_implicits;
     subst_function = subst_implicits;
     classify_function = (fun (_,x) -> Substitute x);
+    discharge_function = discharge_implicits;
+    rebuild_function = rebuild_implicits;
     export_function = (fun x -> Some x) }
 
-(* Implicits of a global reference. *)
+let declare_implicits_gen req flags ref =
+  let imps = compute_global_implicits flags ref in
+  add_anonymous_leaf (inImplicits (req,[ref,imps]))
 
-let compute_global_implicits = function
-  | VarRef id -> compute_var_implicits id
-  | ConstRef kn -> compute_constant_implicits kn
-  | IndRef (kn,i) -> 
-      let ((_,imps),_) = (compute_mib_implicits kn).(i) in imps
-  | ConstructRef ((kn,i),j) -> 
-      let (_,cimps) = (compute_mib_implicits kn).(i) in snd cimps.(j-1)
-
-let declare_implicits_gen r = 
-  add_anonymous_leaf (in_implicits [r,compute_global_implicits r])
-
-let declare_implicits r =
-  with_implicits
-    ((true,!strict_implicit_args,!contextual_implicit_args),
-     (true,!strict_implicit_args_out,!contextual_implicit_args_out))
-    declare_implicits_gen r
+let declare_implicits local ref =
+  let flags = (true,!strict_implicit_args,!contextual_implicit_args) in
+  let req = 
+    if local then ImplNoDischarge else ImplInteractive(ref,flags,ImplAuto) in
+  declare_implicits_gen req flags ref
 
 let declare_var_implicits id =
-  if !implicit_args or !implicit_args_out then
-    declare_implicits_gen (VarRef id)
+  if !implicit_args then
+    declare_implicits_gen ImplNoDischarge (implicit_flags ()) (VarRef id)
 
-let declare_constant_implicits kn =
-  if !implicit_args or !implicit_args_out then
-    declare_implicits_gen (ConstRef kn)
+let declare_constant_implicits con =
+  if !implicit_args then
+    let flags = implicit_flags () in
+    declare_implicits_gen (ImplConstant (con,flags)) flags (ConstRef con)
 
 let declare_mib_implicits kn =
-  if !implicit_args or !implicit_args_out then
-  let imps = compute_mib_implicits kn in
-  let imps = array_map_to_list
-    (fun (ind,cstrs) -> ind::(Array.to_list cstrs)) imps in
-  add_anonymous_leaf (in_implicits (List.flatten imps))
-
-let implicits_of_global_gen = function
-  | VarRef id -> var_implicits id
-  | ConstRef sp -> constant_implicits sp
-  | IndRef isp -> inductive_implicits isp
-  | ConstructRef csp ->	constructor_implicits csp
-
-let implicits_of_global r =
-  let (imp_in,imp_out) = implicits_of_global_gen r in
-  list_of_implicits imp_in
-
-let implicits_of_global_out r =
-  let (imp_in,imp_out) = implicits_of_global_gen r in
-  list_of_implicits imp_out
+  if !implicit_args then
+    let flags = implicit_flags () in
+    let imps = array_map_to_list
+      (fun (ind,cstrs) -> ind::(Array.to_list cstrs))
+      (compute_mib_implicits flags kn) in
+    add_anonymous_leaf
+      (inImplicits (ImplMutualInductive (kn,flags),List.flatten imps))
 
 (* Declare manual implicits *)
 
-(*
-let check_range n = function
-  | loc,ExplByPos i ->
-      if i<1 or i>n then error ("Bad argument number: "^(string_of_int i))
-  | loc,ExplByName id ->
-()
-*)
-
-let rec list_remove a = function
-  | b::l when a = b -> l
-  | b::l -> b::list_remove a l
-  | [] -> raise Not_found
-
-let set_implicit id imp =
-  Some (id,match imp with None -> Manual | Some imp -> imp)
-
-let declare_manual_implicits r l =
-  let t = Global.type_of_global r in
-  let autoimps = compute_implicits_gen false true (Global.env()) t in
-  let n = List.length autoimps in
-  if not (list_distinct l) then 
-    error ("Some parameters are referred more than once");
-(*  List.iter (check_range n) l;*)
-(*  let l = List.sort (-) l in*)
-  (* Compare with automatic implicits to recover printing data and names *)
-  let rec merge k l = function
-    | (Name id,imp)::imps ->
-	let l',imp =
-	  try list_remove (ExplByPos k) l, set_implicit id imp
-	  with Not_found ->
-	  try list_remove (ExplByName id) l, set_implicit id imp
-	  with Not_found ->
-	  l, None in
-	imp :: merge (k+1) l' imps
-    | (Anonymous,imp)::imps -> 
-	None :: merge (k+1) l imps
-    | [] when l = [] -> []
-    | _ ->
-	match List.hd l with
-	| ExplByName id ->
-	    error ("Wrong or not dependent implicit argument name: "^(string_of_id id))
-	| ExplByPos i ->
-	    if i<1 or i>n then 
-	      error ("Bad implicit argument number: "^(string_of_int i))
-	    else
-	      errorlabstrm ""
-		(str "Cannot set implicit argument number " ++ int i ++
-		 str ": it has no name") in
-  let l = Impl_manual (merge 1 l autoimps) in
-  let (_,oimp_out) = implicits_of_global_gen r in
-  let l = l, if !Options.v7_only then oimp_out else l in
-  add_anonymous_leaf (in_implicits [r,l])
-
-(* Tests if declared implicit *)
-
-let test = function
-  | No_impl | Impl_manual _ -> false,false,false
-  | Impl_auto (s,c,_) -> true,s,c
-
-let test_if_implicit find a =
-  try let b,c = find a in test b, test c
-  with Not_found -> (false,false,false),(false,false,false)
-    
-let is_implicit_constant sp =
-  test_if_implicit (KNmap.find sp) !constants_table
-
-let is_implicit_inductive_definition indp =
-  test_if_implicit (Indmap.find (indp,0)) !inductives_table
-
-let is_implicit_var id =
-  test_if_implicit (Idmap.find id) !var_table
+let declare_manual_implicits local ref l =
+  let flags = !implicit_args,!strict_implicit_args,!contextual_implicit_args in
+  let l' = compute_manual_implicits flags ref l in
+  let req =
+    if local or isVarRef ref then ImplNoDischarge
+    else ImplInteractive(ref,flags,ImplManual l)
+  in
+  add_anonymous_leaf (inImplicits (req,[ref,l']))
 
 (*s Registration as global tables *)
 
-let init () =
-  constants_table := KNmap.empty;
-  inductives_table := Indmap.empty;
-  constructors_table := Constrmap.empty;
-  var_table := Idmap.empty
-
-let freeze () =
-  (!constants_table, !inductives_table, 
-   !constructors_table, !var_table)
-
-let unfreeze (ct,it,const,vt) =
-  constants_table := ct;
-  inductives_table := it;
-  constructors_table := const;
-  var_table := vt
+let init () = implicits_table := Refmap.empty
+let freeze () = !implicits_table
+let unfreeze t = implicits_table := t
 
 let _ = 
   Summary.declare_summary "implicits"
@@ -518,34 +437,3 @@ let _ =
       Summary.init_function = init;
       Summary.survive_module = false;
       Summary.survive_section = false }
-
-(* Remark: flags implicit_args, contextual_implicit_args
-   are synchronized by the general options mechanism - see Vernacentries *)
-
-let init () =
-  (* strict_implicit_args_out must be not !Options.v7 
-     but init is done before parsing *)
-  strict_implicit_args:=not !Options.v7;
-  implicit_args_out:=false;
-  (* strict_implicit_args_out needs to be not !Options.v7 or
-     Options.do_translate() but init is done before parsing *)
-  strict_implicit_args_out:=true;
-  contextual_implicit_args_out:=false
-
-let freeze () =
-  (!strict_implicit_args,
-   !implicit_args_out,!strict_implicit_args_out,!contextual_implicit_args_out)
-
-let unfreeze (b,d,e,f) =
-  strict_implicit_args := b;
-  implicit_args_out := d;
-  strict_implicit_args_out := e;
-  contextual_implicit_args_out := f
-
-let _ = 
-  Summary.declare_summary "implicits-out-options"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = true }
diff --git a/library/impargs.mli b/library/impargs.mli
index 8db04ee7..64ce0360 100644
--- a/library/impargs.mli
+++ b/library/impargs.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: impargs.mli,v 1.26.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+(*i $Id: impargs.mli 9488 2007-01-17 11:11:58Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -43,7 +43,7 @@ val positions_of_implicits : implicits_list -> int list
 
 (* Computation of the positions of arguments automatically inferable
    for an object of the given type in the given env *)
-val compute_implicits : bool -> env -> types -> implicits_list
+val compute_implicits : env -> types -> implicits_list
 
 (*s Computation of implicits (done using the global environment). *)
 
@@ -51,19 +51,10 @@ val declare_var_implicits : variable -> unit
 val declare_constant_implicits : constant -> unit
 val declare_mib_implicits : mutual_inductive -> unit
 
-val declare_implicits : global_reference -> unit
+val declare_implicits : bool -> global_reference -> unit
 
 (* Manual declaration of which arguments are expected implicit *)
-val declare_manual_implicits : global_reference -> 
+val declare_manual_implicits : bool -> global_reference -> 
   Topconstr.explicitation list -> unit
 
-(* Get implicit arguments *)
-val is_implicit_constant : constant -> implicits_flags
-val is_implicit_inductive_definition : mutual_inductive -> implicits_flags
-val is_implicit_var : variable -> implicits_flags
-
 val implicits_of_global : global_reference -> implicits_list
-
-(* For translator *)
-val implicits_of_global_out : global_reference -> implicits_list
-val is_implicit_args_out : unit -> bool
diff --git a/library/lib.ml b/library/lib.ml
index c46634f4..213a1d19 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: lib.ml,v 1.63.2.4 2005/11/04 09:02:38 herbelin Exp $ *)
+(* $Id: lib.ml 9488 2007-01-17 11:11:58Z herbelin $ *)
 
 open Pp
 open Util
@@ -21,11 +21,10 @@ open Summary
 type node = 
   | Leaf of obj
   | CompilingLibrary of object_prefix
-  | OpenedModule of object_prefix * Summary.frozen
+  | OpenedModule of bool option * object_prefix * Summary.frozen
   | OpenedModtype of object_prefix * Summary.frozen
   | OpenedSection of object_prefix * Summary.frozen
-  (* bool is to tell if the section must be opened automatically *)
-  | ClosedSection of bool * dir_path * library_segment
+  | ClosedSection
   | FrozenState of Summary.frozen
 
 and library_entry = object_name * node
@@ -51,7 +50,7 @@ let subst_objects prefix subst seg =
 let classify_segment seg =
   let rec clean ((substl,keepl,anticipl) as acc) = function
     | (_,CompilingLibrary _) :: _ | [] -> acc
-    | ((sp,kn as oname),Leaf o) as node :: stk -> 
+    | ((sp,kn as oname),Leaf o) :: stk -> 
 	let id = id_of_label (label kn) in
 	  (match classify_object (oname,o) with 
 	     | Dispose -> clean acc stk
@@ -61,7 +60,7 @@ let classify_segment seg =
 		 clean ((id,o')::substl, keepl, anticipl) stk
 	     | Anticipate o' ->
 		 clean (substl, keepl, o'::anticipl) stk)
-    | (oname,ClosedSection _ as item) :: stk -> clean acc stk
+    | (oname,ClosedSection) :: stk -> clean acc stk
     | (_,OpenedSection _) :: _ -> error "there are still opened sections"
     | (_,OpenedModule _) :: _ -> error "there are still opened modules"
     | (_,OpenedModtype _) :: _ -> error "there are still opened module types"
@@ -105,6 +104,10 @@ let make_kn id =
   let mp,dir = current_prefix () in
     Names.make_kn mp dir (label_of_id id)
 
+let make_con id = 
+  let mp,dir = current_prefix () in
+    Names.make_con mp dir (label_of_id id)
+
 
 let make_oname id = make_path id, make_kn id
 
@@ -121,7 +124,7 @@ let sections_are_opened () =
 let recalc_path_prefix () =
   let rec recalc = function
     | (sp, OpenedSection (dir,_)) :: _ -> dir
-    | (sp, OpenedModule (dir,_)) :: _ -> dir
+    | (sp, OpenedModule (_,dir,_)) :: _ -> dir
     | (sp, OpenedModtype (dir,_)) :: _ -> dir
     | (sp, CompilingLibrary dir) :: _ -> dir
     | _::l -> recalc l
@@ -180,11 +183,19 @@ let add_absolutely_named_leaf sp obj =
   add_entry sp (Leaf obj)
 
 let add_leaf id obj =
+  if fst (current_prefix ()) = initial_path then 
+    error ("No session module started (use -top dir)");
   let oname = make_oname id in
   cache_object (oname,obj);
   add_entry oname (Leaf obj);
   oname
 
+let add_discharged_leaf id obj =
+  let oname = make_oname id in
+  let newobj = rebuild_object obj in
+  cache_object (oname,newobj);
+  add_entry oname (Leaf newobj)
+
 let add_leaves id objs =
   let oname = make_oname id in
   let add_obj obj = 
@@ -211,29 +222,13 @@ let is_something_opened = function
   | (_,OpenedModtype _) -> true
   | _ -> false
 
-let export_segment seg =
-  let rec clean acc = function
-    | (_,CompilingLibrary _) :: _ | [] -> acc
-    | (oname,Leaf o) as node :: stk ->
-	(match export_object o with
-	   | None -> clean acc stk
-	   | Some o' -> clean ((oname,Leaf o') :: acc) stk)
-    | (oname,ClosedSection _ as item) :: stk -> clean (item :: acc) stk
-    | (_,OpenedSection _) :: _ -> error "there are still opened sections"
-    | (_,OpenedModule _) :: _ -> error "there are still opened modules"
-    | (_,OpenedModtype _) :: _ -> error "there are still opened module types"
-    | (_,FrozenState _) :: stk -> clean acc stk
-  in
-    clean [] seg
-
-
-let start_module id mp nametab = 
+let start_module export id mp nametab = 
   let dir = extend_dirpath (fst !path_prefix) id in
   let prefix = dir,(mp,empty_dirpath) in
   let oname = make_path id, make_kn id in
   if Nametab.exists_module dir then
     errorlabstrm "open_module" (pr_id id ++ str " already exists") ;
-  add_entry oname (OpenedModule (prefix,nametab));
+  add_entry oname (OpenedModule (export,prefix,nametab));
   path_prefix := prefix;
   prefix
 (*  add_frozen_state () must be called in declaremods *)
@@ -241,7 +236,7 @@ let start_module id mp nametab =
 let end_module id = 
   let oname,nametab = 
     try match find_entry_p is_something_opened with
-      | oname,OpenedModule (_,nametab) -> 
+      | oname,OpenedModule (_,_,nametab) -> 
 	  let sp = fst oname in
 	  let id' = basename sp in
 	  if id<>id' then error "this is not the last opened module"; 
@@ -330,7 +325,7 @@ let end_compilation dir =
       | _, OpenedModtype _ -> error "There are some open module types"
       | _ -> assert false
     with
-	Not_found -> ()
+	Not_found -> () 
   in
   let module_p =
     function (_,CompilingLibrary _) -> true | x -> is_something_opened x
@@ -342,16 +337,17 @@ let end_compilation dir =
     with
 	Not_found -> anomaly "No module declared"
   in
-  let _ =  match !comp_name with
+  let _ =  
+    match !comp_name with
       | None -> anomaly "There should be a module name..."
       | Some m ->
 	  if m <> dir then anomaly 
 	    ("The current open module has name "^ (string_of_dirpath m) ^ 
-	     " and not " ^ (string_of_dirpath m));
+	       " and not " ^ (string_of_dirpath m));
   in
   let (after,_,before) = split_lib oname in
-  comp_name := None;
-  !path_prefix,after
+    comp_name := None;
+    !path_prefix,after
 
 (* Returns true if we are inside an opened module type *)
 let is_modtype () = 
@@ -379,6 +375,79 @@ let is_module () =
 (* Returns the most recent OpenedThing node *)
 let what_is_opened () = find_entry_p is_something_opened
 
+(* Discharge tables *)
+
+(* At each level of section, we remember
+   - the list of variables in this section
+   - the list of variables on which each constant depends in this section
+   - the list of variables on which each inductive depends in this section
+   - the list of substitution to do at section closing 
+*)
+
+type abstr_list = Sign.named_context Cmap.t * Sign.named_context KNmap.t
+
+let sectab =
+  ref ([] : (identifier list * Cooking.work_list * abstr_list) list)
+
+let add_section () =
+  sectab := ([],(Cmap.empty,KNmap.empty),(Cmap.empty,KNmap.empty)) :: !sectab
+
+let add_section_variable id =
+  match !sectab with
+    | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *)
+    | (vars,repl,abs)::sl -> sectab := (id::vars,repl,abs)::sl
+
+let rec extract_hyps = function
+  | (id::idl,(id',_,_ as d)::hyps) when id=id' -> d :: extract_hyps (idl,hyps)
+  | (id::idl,hyps) -> extract_hyps (idl,hyps)
+  | [], _ -> []
+
+let add_section_replacement f g hyps =
+  match !sectab with
+  | [] -> ()
+  | (vars,exps,abs)::sl ->
+    let sechyps = extract_hyps (vars,hyps) in
+    let args = Sign.instance_from_named_context (List.rev sechyps) in
+    sectab := (vars,f (Array.map Term.destVar args) exps,g sechyps abs)::sl
+	
+let add_section_kn kn =
+  let f = (fun x (l1,l2) -> (l1,KNmap.add kn x l2)) in
+  add_section_replacement f f
+
+let add_section_constant kn =
+  let f = (fun x (l1,l2) -> (Cmap.add kn x l1,l2)) in
+  add_section_replacement f f
+
+let replacement_context () = pi2 (List.hd !sectab)
+
+let section_segment_of_constant con =
+  Cmap.find con (fst (pi3 (List.hd !sectab)))
+
+let section_segment_of_mutual_inductive kn =
+  KNmap.find kn (snd (pi3 (List.hd !sectab)))
+
+let section_instance = function
+  | VarRef id -> [||]
+  | ConstRef con ->
+      Cmap.find con (fst (pi2 (List.hd !sectab)))
+  | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
+      KNmap.find kn (snd (pi2 (List.hd !sectab)))
+
+let init () = sectab := []
+let freeze () = !sectab
+let unfreeze s = sectab := s
+
+let _ = 
+  Summary.declare_summary "section-context"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+(*************)
+(* Sections. *)
+
 (* XML output hooks *)
 let xml_open_section = ref (fun id -> ())
 let xml_close_section = ref (fun id -> ())
@@ -386,27 +455,35 @@ let xml_close_section = ref (fun id -> ())
 let set_xml_open_section f = xml_open_section := f
 let set_xml_close_section f = xml_close_section := f
 
-(* Sections. *)
-
 let open_section id =
   let olddir,(mp,oldsec) = !path_prefix in
   let dir = extend_dirpath olddir id in
   let prefix = dir, (mp, extend_dirpath oldsec id) in
   let name = make_path id, make_kn id (* this makes little sense however *) in
-  if Nametab.exists_section dir then
-    errorlabstrm "open_section" (pr_id id ++ str " already exists");
-  let sum = freeze_summaries() in
-  add_entry name (OpenedSection (prefix, sum));
-  (*Pushed for the lifetime of the section: removed by unfrozing the summary*)
-  Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix);
-  path_prefix := prefix;
-  if !Options.xml_export then !xml_open_section id;
-  prefix
+    if Nametab.exists_section dir then
+      errorlabstrm "open_section" (pr_id id ++ str " already exists");
+    let sum = freeze_summaries() in
+      add_entry name (OpenedSection (prefix, sum));
+      (*Pushed for the lifetime of the section: removed by unfrozing the summary*)
+      Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix);
+      path_prefix := prefix;
+      if !Options.xml_export then !xml_open_section id;
+      add_section ()
 
 
 (* Restore lib_stk and summaries as before the section opening, and
    add a ClosedSection object. *)
-let close_section ~export id =
+
+let discharge_item ((sp,_ as oname),e) =
+  match e with
+  | Leaf lobj ->
+      option_map (fun o -> (basename sp,o)) (discharge_object (oname,lobj))
+  | FrozenState _ -> None
+  | ClosedSection -> None
+  | OpenedSection _ | OpenedModtype _ | OpenedModule _ | CompilingLibrary _ ->
+      anomaly "discharge_item"
+
+let close_section id =
   let oname,fs = 
     try match find_entry_p is_something_opened with
       | oname,OpenedSection (_,fs) -> 
@@ -417,25 +494,26 @@ let close_section ~export id =
     with Not_found ->
       error "no opened section"
   in
-  let (after,_,before) = split_lib oname in
+  let (secdecls,_,before) = split_lib oname in
   lib_stk := before;
-  let prefix = !path_prefix in
+  let full_olddir = fst !path_prefix in
   pop_path_prefix ();
-  let closed_sec = 
-    ClosedSection (export, (fst prefix), export_segment after)
-  in
-  let name = make_path id, make_kn id in
-  add_entry name closed_sec;
+  add_entry (make_oname id) ClosedSection;
   if !Options.xml_export then !xml_close_section id;
-  (prefix, after, fs)
+  let newdecls = List.map discharge_item secdecls in
+  Summary.section_unfreeze_summaries fs;
+  List.iter (option_iter (fun (id,o) -> add_discharged_leaf id o)) newdecls;
+  Cooking.clear_cooking_sharing ();
+  Nametab.push_dir (Nametab.Until 1) full_olddir (DirClosedSection full_olddir)
 
+(*****************)
 (* Backtracking. *)
 
 let recache_decl = function
   | (sp, Leaf o) -> cache_object (sp,o)
+  | (_,OpenedSection _) -> add_section ()
   | _ -> ()
 
-
 let recache_context ctx =
   List.iter recache_decl ctx
 
@@ -463,7 +541,7 @@ let reset_name (loc,id) =
 
 let is_mod_node = function 
   | OpenedModule _ | OpenedModtype _ | OpenedSection _ 
-  | ClosedSection _ -> true 
+  | ClosedSection -> true 
   | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE"
   | _ -> false
 
@@ -471,7 +549,7 @@ let is_mod_node = function
    the same name *) 
 
 let reset_mod (loc,id) =
-  let (ent,before) = 
+  let (_,before) = 
     try
       find_split_p (fun (sp,node) -> 
                     let (_,spi) = repr_path (fst sp) in id = spi 
@@ -489,15 +567,29 @@ let reset_mod (loc,id) =
   recache_context after
 
 
-let point_obj =
-  let (f,_) = declare_object {(default_object "DOT") with
-				classify_function = (fun _ -> Dispose)} in
-    f()
+let (inLabel,outLabel) =
+  declare_object {(default_object "DOT") with
+				classify_function = (fun _ -> Dispose)}
+
+let mark_end_of_command, current_command_label, set_command_label =
+  let n = ref 0 in
+  (fun () ->
+    match !lib_stk with
+        (_,Leaf o)::_ when object_tag o = "DOT" -> ()
+      | _ -> incr n;add_anonymous_leaf (inLabel !n)),
+  (fun () -> !n),
+  (fun x -> n:=x)
+
+let rec reset_label_stk n stk =
+  match stk with
+      (sp,Leaf o)::tail when object_tag o = "DOT" && n = outLabel o -> sp
+    | _::tail -> reset_label_stk n tail
+    | [] -> error "Unknown state number"
 
-let mark_end_of_command () =
-  match !lib_stk with
-      (_,Leaf o)::_ when object_tag o = "DOT" -> ()
-    | _ -> add_anonymous_leaf point_obj
+let reset_label n = 
+  let res = reset_label_stk n !lib_stk in
+  set_command_label (n-1); (* forget state numbers after n only if reset succeeded *)
+  reset_to res
 
 let rec back_stk n stk =
   match stk with
@@ -543,6 +635,7 @@ let reset_initial () =
 	  | (_,[_,FrozenState fs as hd],before) ->
 	      lib_stk := hd::before;
 	      recalc_path_prefix ();
+			set_command_label 0;
 	      unfreeze_summaries fs
 	  | _ -> assert false
 	end
@@ -550,12 +643,30 @@ let reset_initial () =
 
 (* Misc *)
 
+let mp_of_global ref = 
+  match ref with
+    | VarRef id -> fst (current_prefix ())
+    | ConstRef cst -> con_modpath cst
+    | IndRef ind -> ind_modpath ind
+    | ConstructRef constr -> constr_modpath constr
+
+let rec dp_of_mp modp =
+  match modp with
+    | MPfile dp -> dp
+    | MPbound _ | MPself _ -> library_dp ()
+    | MPdot (mp,_) -> dp_of_mp mp
+
 let library_part ref =
+  match ref with 
+    | VarRef id -> library_dp ()
+    | _ -> dp_of_mp (mp_of_global ref)
+
+let remove_section_part ref =
   let sp = Nametab.sp_of_global ref in
   let dir,_ = repr_path sp in
   match ref with
   | VarRef id -> 
-      anomaly "library_part not supported on local variables"
+      anomaly "remove_section_part not supported on local variables"
   | _ ->
       if is_dirpath_prefix_of dir (cwd ()) then
         (* Not yet (fully) discharged *)
@@ -564,14 +675,31 @@ let library_part ref =
 	(* Theorem/Lemma outside its outer section of definition *)
 	dir
 
+(************************)
+(* Discharging names *)
+
+let con_defined_in_sec kn = 
+  let _,dir,_ = repr_con kn in
+  dir <> empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ())
+
+let defined_in_sec kn = 
+  let _,dir,_ = repr_kn kn in
+  dir <> empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ())
+
+let discharge_global = function
+  | ConstRef kn when con_defined_in_sec kn ->
+      ConstRef (pop_con kn)
+  | IndRef (kn,i) when defined_in_sec kn ->
+      IndRef (pop_kn kn,i)
+  | ConstructRef ((kn,i),j) when defined_in_sec kn ->
+      ConstructRef ((pop_kn kn,i),j)
+  | r -> r
+
+let discharge_kn kn = 
+  if defined_in_sec kn then pop_kn kn else kn
 
-let rec file_of_mp = function
-  | MPfile dir -> Some dir
-  | MPself _ -> Some (library_dp ())
-  | MPbound _ -> None
-  | MPdot (mp,_) -> file_of_mp mp
+let discharge_con cst = 
+  if con_defined_in_sec cst then pop_con cst else cst
 
-let file_part = function
-  | VarRef id -> anomaly "TODO";
-  | ConstRef kn | ConstructRef ((kn,_),_) | IndRef (kn,_) -> 
-      file_of_mp (modpath kn)
+let discharge_inductive (kn,i) =
+  (discharge_kn kn,i)
diff --git a/library/lib.mli b/library/lib.mli
index aa874470..ec896de5 100644
--- a/library/lib.mli
+++ b/library/lib.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lib.mli,v 1.41.2.3 2005/01/21 16:41:50 herbelin Exp $ i*)
+(*i $Id: lib.mli 9488 2007-01-17 11:11:58Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -14,6 +14,7 @@ open Names
 open Libnames
 open Libobject
 open Summary
+open Mod_subst
 (*i*)
 
 (*s This module provides a general mechanism to keep a trace of all operations
@@ -23,10 +24,10 @@ open Summary
 type node = 
   | Leaf of obj
   | CompilingLibrary of object_prefix
-  | OpenedModule of object_prefix * Summary.frozen
+  | OpenedModule of bool option * object_prefix * Summary.frozen
   | OpenedModtype of object_prefix * Summary.frozen
   | OpenedSection of object_prefix * Summary.frozen
-  | ClosedSection of bool * dir_path * library_segment
+  | ClosedSection
   | FrozenState of Summary.frozen
 
 and library_segment = (object_name * node) list
@@ -65,7 +66,8 @@ val add_leaves : identifier -> obj list -> object_name
 
 val add_frozen_state : unit -> unit
 val mark_end_of_command : unit -> unit
-
+val current_command_label : unit -> int
+val reset_label : int -> unit
 
 (*s The function [contents_after] returns the current library segment, 
   starting from a given section path. If not given, the entire segment
@@ -82,6 +84,7 @@ val make_path : identifier -> section_path
 (* Kernel-side names *)
 val current_prefix : unit -> module_path * dir_path
 val make_kn : identifier -> kernel_name
+val make_con : identifier -> constant
 
 (* Are we inside an opened section *)
 val sections_are_opened : unit -> bool
@@ -99,7 +102,7 @@ val what_is_opened : unit -> object_name * node
 (*s Modules and module types *)
 
 val start_module : 
-  module_ident -> module_path -> Summary.frozen -> object_prefix
+  bool option -> module_ident -> module_path -> Summary.frozen -> object_prefix
 val end_module : module_ident 
   -> object_name * object_prefix * Summary.frozen * library_segment
 
@@ -119,17 +122,13 @@ val end_compilation : dir_path -> object_prefix * library_segment
 val library_dp : unit -> dir_path
 
 (* Extract the library part of a name even if in a section *)
-val library_part : global_reference -> dir_path
-
-(* Extract the library part of a name if not in a functor *)
-val file_part : global_reference -> dir_path option
+val library_part :  global_reference -> dir_path
+val remove_section_part : global_reference -> dir_path
 
 (*s Sections *)
 
-val open_section : identifier -> object_prefix
-
-val close_section : export:bool -> identifier -> 
-  object_prefix * library_segment * Summary.frozen
+val open_section : identifier -> unit
+val close_section : identifier -> unit
 
 (*s Backtracking (undo). *)
 
@@ -157,3 +156,26 @@ val reset_initial : unit -> unit
 (* XML output hooks *)
 val set_xml_open_section : (identifier -> unit) -> unit
 val set_xml_close_section : (identifier -> unit) -> unit
+
+
+(*s Section management for discharge *)
+
+val section_segment_of_constant : constant -> Sign.named_context
+val section_segment_of_mutual_inductive: mutual_inductive -> Sign.named_context
+
+val section_instance : global_reference -> identifier array
+
+val add_section_variable : identifier -> unit
+val add_section_constant : constant -> Sign.named_context -> unit
+val add_section_kn : kernel_name -> Sign.named_context -> unit
+val replacement_context : unit ->
+  (identifier array Cmap.t * identifier array KNmap.t)
+
+(*s Discharge: decrease the section level if in the current section *)
+
+val discharge_kn :  kernel_name -> kernel_name
+val discharge_con : constant -> constant
+val discharge_global : global_reference -> global_reference
+val discharge_inductive : inductive -> inductive
+
+
diff --git a/library/libnames.ml b/library/libnames.ml
index 16f5a917..07c9ad23 100644
--- a/library/libnames.ml
+++ b/library/libnames.ml
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libnames.ml,v 1.11.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+(*i $Id: libnames.ml 9488 2007-01-17 11:11:58Z herbelin $ i*)
 
 open Pp
 open Util
 open Names
 open Nameops
 open Term
+open Mod_subst
 
 type global_reference =
   | VarRef of variable
@@ -20,31 +21,37 @@ type global_reference =
   | IndRef of inductive
   | ConstructRef of constructor
 
+let isVarRef = function VarRef _ -> true | _ -> false
+
 let subst_global subst ref = match ref with
-  | VarRef _ -> ref
+  | VarRef var -> ref, mkVar var
   | ConstRef kn ->
-      let kn' = subst_kn subst kn in if kn==kn' then ref else
-          ConstRef kn'
+     let kn',t = subst_con subst kn in
+      if kn==kn' then ref, mkConst kn else ConstRef kn', t
   | IndRef (kn,i) ->
-      let kn' = subst_kn subst kn in if kn==kn' then ref else
-          IndRef(kn',i)
+      let kn' = subst_kn subst kn in
+      if kn==kn' then ref, mkInd (kn,i) else IndRef(kn',i), mkInd (kn',i)
   | ConstructRef ((kn,i),j) ->
-      let kn' = subst_kn subst kn in if kn==kn' then ref else
-          ConstructRef ((kn',i),j)
+      let kn' = subst_kn subst kn in 
+      if kn==kn' then ref, mkConstruct ((kn,i),j)
+      else ConstructRef ((kn',i),j), mkConstruct ((kn',i),j)
 
-let reference_of_constr c = match kind_of_term c with
+let global_of_constr c = match kind_of_term c with
   | Const sp -> ConstRef sp
   | Ind ind_sp -> IndRef ind_sp
   | Construct cstr_cp -> ConstructRef cstr_cp
   | Var id -> VarRef id
   |  _ -> raise Not_found
 
-let constr_of_reference = function
+let constr_of_global = function
   | VarRef id -> mkVar id
   | ConstRef sp -> mkConst sp
   | ConstructRef sp -> mkConstruct sp
   | IndRef sp -> mkInd sp
 
+let constr_of_reference = constr_of_global
+let reference_of_constr = global_of_constr
+
 module RefOrdered =
   struct
     type t = global_reference
@@ -54,24 +61,8 @@ module RefOrdered =
 module Refset = Set.Make(RefOrdered)
 module Refmap = Map.Make(RefOrdered)
 
-module InductiveOrdered = struct
-  type t = inductive
-  let compare (spx,ix) (spy,iy) = 
-    let c = ix - iy in if c = 0 then compare spx spy else c
-end
-
-module Indmap = Map.Make(InductiveOrdered)
-
 let inductives_table = ref Indmap.empty
 
-module ConstructorOrdered = struct
-  type t = constructor
-  let compare (indx,ix) (indy,iy) = 
-    let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c
-end
-
-module Constrmap = Map.Make(ConstructorOrdered)
-
 (**********************************************)
 
 let pr_dirpath sl = (str (string_of_dirpath sl))
@@ -89,6 +80,14 @@ let dirpath_prefix p = match repr_dirpath p with
 let is_dirpath_prefix_of d1 d2 =
   list_prefix_of (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2))
 
+let chop_dirpath n d =
+  let d1,d2 = list_chop n (List.rev (repr_dirpath d)) in
+    make_dirpath (List.rev d1), make_dirpath (List.rev d2)
+
+let drop_dirpath_prefix d1 d2 =
+  let d = Util.list_drop_prefix (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2)) in
+    make_dirpath (List.rev d)
+
 (* To know how qualified a name should be to be understood in the current env*)
 let add_dirpath_prefix id d = make_dirpath (repr_dirpath d @ [id])
 
@@ -188,18 +187,10 @@ type extended_global_reference =
   | TrueGlobal of global_reference
   | SyntacticDef of kernel_name
 
-let subst_ext subst glref = match glref with
-  | TrueGlobal ref -> 
-      let ref' = subst_global subst ref in
-	if ref' == ref then glref else
-	  TrueGlobal ref'
-  | SyntacticDef kn ->
-      let kn' = subst_kn subst kn in
-	if kn' == kn then glref else
-	  SyntacticDef kn'
-
 let encode_kn dir id = make_kn (MPfile dir) empty_dirpath (label_of_id id)
 
+let encode_con dir id = make_con (MPfile dir) empty_dirpath (label_of_id id)
+
 let decode_kn kn = 
   let mp,sec_dir,l = repr_kn kn in
     match mp,(repr_dirpath sec_dir) with
@@ -207,6 +198,13 @@ let decode_kn kn =
       | _ , [] -> anomaly "MPfile expected!"
       | _ -> anomaly "Section part should be empty!"
 
+let decode_con kn = 
+  let mp,sec_dir,l = repr_con kn in
+    match mp,(repr_dirpath sec_dir) with
+	MPfile dir,[] -> (dir,id_of_label l)
+      | _ , [] -> anomaly "MPfile expected!"
+      | _ -> anomaly "Section part should be empty!"
+
 (*s qualified names *)
 type qualid = section_path
 
@@ -267,3 +265,19 @@ let pr_reference = function
 let loc_of_reference = function
   | Qualid (loc,qid) -> loc
   | Ident (loc,id) -> loc
+
+(* popping one level of section in global names *)
+
+let pop_con con =
+  let (mp,dir,l) = repr_con con in
+  Names.make_con mp (dirpath_prefix dir) l
+
+let pop_kn kn =
+  let (mp,dir,l) = repr_kn kn in
+  Names.make_kn mp (dirpath_prefix dir) l
+
+let pop_global_reference = function
+  | ConstRef con -> ConstRef (pop_con con)
+  | IndRef (kn,i) -> IndRef (pop_kn kn,i)
+  | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j)
+  | VarRef id -> anomaly "VarRef not poppable"
diff --git a/library/libnames.mli b/library/libnames.mli
index a6055428..9bf6918e 100644
--- a/library/libnames.mli
+++ b/library/libnames.mli
@@ -6,13 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libnames.mli,v 1.8.2.2 2005/01/21 16:41:51 herbelin Exp $ i*)
+(*i $Id: libnames.mli 9488 2007-01-17 11:11:58Z herbelin $ i*)
 
 (*i*)
 open Pp
 open Util
 open Names
 open Term
+open Mod_subst
 (*i*)
 
 (*s Global reference is a kernel side type for all references together *)
@@ -22,21 +23,24 @@ type global_reference =
   | IndRef of inductive
   | ConstructRef of constructor
 
-val subst_global : substitution -> global_reference -> global_reference
+val isVarRef : global_reference -> bool
+
+val subst_global : substitution -> global_reference -> global_reference * constr
 
 (* Turn a global reference into a construction *)
-val constr_of_reference : global_reference -> constr
+val constr_of_global : global_reference -> constr
 
-(* Turn a construction denoting a global into a reference;
-   raise [Not_found] if not a global *)
+(* Turn a construction denoting a global reference into a global reference;
+   raise [Not_found] if not a global reference *)
+val global_of_constr : constr -> global_reference
+
+(* Obsolete synonyms for constr_of_global and global_of_constr *)
+val constr_of_reference : global_reference -> constr
 val reference_of_constr : constr -> global_reference
 
 module Refset : Set.S with type elt = global_reference 
 module Refmap : Map.S with type key = global_reference
 
-module Indmap : Map.S with type key = inductive
-module Constrmap : Map.S with type key = constructor
-
 (*s Dirpaths *)
 val pr_dirpath : dir_path -> Pp.std_ppcmds
 
@@ -51,6 +55,8 @@ val split_dirpath : dir_path -> dir_path * identifier
 val extend_dirpath : dir_path -> module_ident -> dir_path
 val add_dirpath_prefix : module_ident -> dir_path -> dir_path
 
+val chop_dirpath : int -> dir_path -> dir_path * dir_path
+val drop_dirpath_prefix : dir_path -> dir_path -> dir_path
 val extract_dirpath_prefix : int -> dir_path -> dir_path
 val is_dirpath_prefix_of : dir_path -> dir_path -> bool
 
@@ -82,13 +88,12 @@ type extended_global_reference =
   | TrueGlobal of global_reference
   | SyntacticDef of kernel_name
 
-val subst_ext : 
-  substitution -> extended_global_reference -> extended_global_reference
-
 (*s Temporary function to brutally form kernel names from section paths *)
 
 val encode_kn : dir_path -> identifier -> kernel_name
 val decode_kn : kernel_name -> dir_path * identifier
+val encode_con : dir_path -> identifier -> constant
+val decode_con : constant -> dir_path * identifier
 
 
 (*s A [qualid] is a partially qualified ident; it includes fully
@@ -138,3 +143,9 @@ val qualid_of_reference : reference -> qualid located
 val string_of_reference : reference -> string
 val pr_reference : reference -> std_ppcmds
 val loc_of_reference : reference -> loc
+
+(* popping one level of section in global names *)
+
+val pop_con : constant -> constant
+val pop_kn : kernel_name -> kernel_name
+val pop_global_reference : global_reference -> global_reference
diff --git a/library/libobject.ml b/library/libobject.ml
index 2e531e05..eaaa1be1 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -6,11 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: libobject.ml,v 1.8.8.1 2004/07/16 19:30:35 herbelin Exp $ *)
+(* $Id: libobject.ml 9488 2007-01-17 11:11:58Z herbelin $ *)
 
 open Util
 open Names
 open Libnames
+open Mod_subst
 
 (* The relax flag is used to make it possible to load files while ignoring
    failures to incorporate some objects.  This can be useful when one
@@ -35,6 +36,8 @@ type 'a object_declaration = {
   open_function : int -> object_name * 'a -> unit;
   classify_function : object_name * 'a -> 'a substitutivity;
   subst_function : object_name * substitution * 'a -> 'a;
+  discharge_function : object_name * 'a -> 'a option;
+  rebuild_function : 'a -> 'a;
   export_function : 'a -> 'a option }
 
 let yell s = anomaly s
@@ -47,6 +50,8 @@ let default_object s = {
   subst_function = (fun _ -> 
     yell ("The object "^s^" does not know how to substitute!"));
   classify_function = (fun (_,obj) -> Keep obj);
+  discharge_function = (fun _ -> None);
+  rebuild_function = (fun x -> x);
   export_function = (fun _ -> None)} 
 
 
@@ -71,6 +76,8 @@ type dynamic_object_declaration = {
   dyn_open_function : int -> object_name * obj -> unit;
   dyn_subst_function : object_name * substitution * obj -> obj;
   dyn_classify_function : object_name * obj -> obj substitutivity;
+  dyn_discharge_function : object_name * obj -> obj option;
+  dyn_rebuild_function : obj -> obj;
   dyn_export_function : obj -> obj option }
 
 let object_tag lobj = Dyn.tag lobj
@@ -103,9 +110,17 @@ let declare_object odecl =
 	| Anticipate (obj) -> Anticipate (infun obj)
     else 
       anomaly "somehow we got the wrong dynamic object in the classifyfun"
+  and discharge (oname,lobj) = 
+    if Dyn.tag lobj = na then 
+      option_map infun (odecl.discharge_function (oname,outfun lobj))
+    else 
+      anomaly "somehow we got the wrong dynamic object in the dischargefun"
+  and rebuild lobj = 
+    if Dyn.tag lobj = na then infun (odecl.rebuild_function (outfun lobj))
+    else anomaly "somehow we got the wrong dynamic object in the rebuildfun"
   and exporter lobj = 
     if Dyn.tag lobj = na then 
-      option_app infun (odecl.export_function (outfun lobj))
+      option_map infun (odecl.export_function (outfun lobj))
     else 
       anomaly "somehow we got the wrong dynamic object in the exportfun"
 
@@ -115,6 +130,8 @@ let declare_object odecl =
                              dyn_open_function = opener;
 			     dyn_subst_function = substituter;
 			     dyn_classify_function = classifier;
+			     dyn_discharge_function = discharge;
+			     dyn_rebuild_function = rebuild;
                              dyn_export_function = exporter };
   (infun,outfun)
 
@@ -134,7 +151,7 @@ let apply_dyn_fun deflt f lobj =
 	  else
 	    anomaly
 	      ("Cannot find library functions for an object with tag "^tag) in 
-  	f dodecl
+	f dodecl
     with
 	Failure "local to_apply_dyn_fun" -> deflt;;
 
@@ -153,5 +170,11 @@ let subst_object ((_,_,lobj) as node) =
 let classify_object ((_,lobj) as node) = 
   apply_dyn_fun Dispose (fun d -> d.dyn_classify_function node) lobj
 
+let discharge_object ((_,lobj) as node) = 
+  apply_dyn_fun None (fun d -> d.dyn_discharge_function node) lobj
+
+let rebuild_object lobj =
+  apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function lobj) lobj
+
 let export_object lobj =
   apply_dyn_fun None (fun d -> d.dyn_export_function lobj) lobj
diff --git a/library/libobject.mli b/library/libobject.mli
index b9070f5d..376da1f5 100644
--- a/library/libobject.mli
+++ b/library/libobject.mli
@@ -6,11 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: libobject.mli,v 1.9.8.2 2005/01/21 16:41:51 herbelin Exp $ i*)
+(*i $Id: libobject.mli 9488 2007-01-17 11:11:58Z herbelin $ i*)
 
 (*i*)
 open Names
 open Libnames
+open Mod_subst
 (*i*)
 
 (* [Libobject] declares persistent objects, given with methods:
@@ -69,6 +70,8 @@ type 'a object_declaration = {
   open_function : int -> object_name * 'a -> unit;
   classify_function : object_name * 'a -> 'a substitutivity;
   subst_function : object_name * substitution * 'a -> 'a;
+  discharge_function : object_name * 'a -> 'a option;
+  rebuild_function : 'a -> 'a;
   export_function : 'a -> 'a option }
 
 (* The default object is a "Keep" object with empty methods. 
@@ -102,4 +105,6 @@ val open_object : int -> object_name * obj -> unit
 val subst_object : object_name * substitution * obj -> obj
 val classify_object : object_name * obj -> obj substitutivity
 val export_object : obj -> obj option
+val discharge_object : object_name * obj -> obj option
+val rebuild_object : obj -> obj
 val relax : bool -> unit
diff --git a/library/library.ml b/library/library.ml
index aaed4545..b68c3eb5 100644
--- a/library/library.ml
+++ b/library/library.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: library.ml,v 1.79.2.5 2006/01/10 17:06:23 barras Exp $ *)
+(* $Id: library.ml 9637 2007-02-10 08:32:28Z notin $ *)
 
 open Pp
 open Util
@@ -25,52 +25,84 @@ open Declaremods
 
 type logical_path = dir_path
 
-let load_path = ref ([],[] : System.physical_path list * logical_path list)
+let load_paths = ref ([],[] : System.physical_path list * logical_path list)
 
-let get_load_path () = fst !load_path
+let get_load_paths () = fst !load_paths
 
+(* Hints to partially detects if two paths refer to the same repertory *)
+let rec remove_path_dot p = 
+  let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
+  let n = String.length curdir in
+  if String.length p > n && String.sub p 0 n = curdir then
+    remove_path_dot (String.sub p n (String.length p - n))
+  else
+    p
+
+let strip_path p =
+  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
+  let n = String.length cwd in
+  if String.length p > n && String.sub p 0 n = cwd then
+    remove_path_dot (String.sub p n (String.length p - n))
+  else
+    remove_path_dot p
+
+let canonical_path_name p =
+  let current = Sys.getcwd () in
+  try 
+    Sys.chdir p;
+    let p' = Sys.getcwd () in
+    Sys.chdir current;
+    p'
+  with Sys_error _ ->
+    (* We give up to find a canonical name and just simplify it... *)
+    strip_path p
 
 let find_logical_path phys_dir = 
-  let phys_dir = System.canonical_path_name phys_dir in
-  match list_filter2 (fun p d -> p = phys_dir) !load_path with
+  let phys_dir = canonical_path_name phys_dir in
+  match list_filter2 (fun p d -> p = phys_dir) !load_paths with
   | _,[dir] -> dir
   | _,[] -> Nameops.default_root_prefix
   | _,l -> anomaly ("Two logical paths are associated to "^phys_dir)
 
-let remove_path dir =
-  let dir = System.canonical_path_name dir in
-  load_path := list_filter2 (fun p d -> p <> dir) !load_path
-
-let add_load_path_entry (phys_path,coq_path) =
-  let phys_path = System.canonical_path_name phys_path in
-  match list_filter2 (fun p d -> p = phys_path) !load_path with
-  | _,[dir] ->
-      if coq_path <> dir 
-        (* If this is not the default -I . to coqtop *)
-        && not
-        (phys_path = System.canonical_path_name Filename.current_dir_name
-         && coq_path = Nameops.default_root_prefix)
-      then
-	begin
-          (* Assume the user is concerned by library naming *)
-	  if dir <> Nameops.default_root_prefix then
-	    (Options.if_verbose warning (phys_path^" was previously bound to "
-	    ^(string_of_dirpath dir)
-	    ^("\nIt is remapped to "^(string_of_dirpath coq_path)));
-             flush_all ());
-	  remove_path phys_path;
-	  load_path := (phys_path::fst !load_path, coq_path::snd !load_path)
-	end
-  | _,[] ->
-      load_path := (phys_path :: fst !load_path, coq_path :: snd !load_path)
-  | _ -> anomaly ("Two logical paths are associated to "^phys_path)
+let is_in_load_paths phys_dir =
+  let dir = canonical_path_name phys_dir in
+  let lp = get_load_paths () in
+  let check_p = fun p -> (String.compare dir p) == 0 in
+    List.exists check_p lp 
+
+let remove_load_path dir =
+  load_paths := list_filter2 (fun p d -> p <> dir) !load_paths
+
+let add_load_path (phys_path,coq_path) =
+  let phys_path = canonical_path_name phys_path in
+    match list_filter2 (fun p d -> p = phys_path) !load_paths with
+      | _,[dir] ->
+	  if coq_path <> dir 
+            (* If this is not the default -I . to coqtop *)
+            && not
+            (phys_path = canonical_path_name Filename.current_dir_name
+		&& coq_path = Nameops.default_root_prefix)
+	  then
+	    begin
+              (* Assume the user is concerned by library naming *)
+	      if dir <> Nameops.default_root_prefix then
+		(Options.if_verbose warning (phys_path^" was previously bound to "
+					     ^(string_of_dirpath dir)
+					     ^("\nIt is remapped to "^(string_of_dirpath coq_path)));
+		 flush_all ());
+	      remove_load_path phys_path;
+	      load_paths := (phys_path::fst !load_paths, coq_path::snd !load_paths)
+	    end
+      | _,[] ->
+	  load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths)
+      | _ -> anomaly ("Two logical paths are associated to "^phys_path)
 
 let physical_paths (dp,lp) = dp
 
-let load_path_of_logical_path dir =
-  fst (list_filter2 (fun p d -> d = dir) !load_path)
-
-let get_full_load_path () = List.combine (fst !load_path) (snd !load_path)
+let load_paths_of_dir_path dir =
+  fst (list_filter2 (fun p d -> d = dir) !load_paths)
+    
+let get_full_load_paths () = List.combine (fst !load_paths) (snd !load_paths)
 
 (************************************************************************)
 (*s Modules on disk contain the following informations (after the magic 
@@ -97,7 +129,7 @@ type library_t = {
   library_imports : compilation_unit_name list;
   library_digest : Digest.t }
 
-module CompilingLibraryOrdered = 
+module LibraryOrdered = 
   struct
     type t = dir_path
     let compare d1 d2 =
@@ -105,12 +137,12 @@ module CompilingLibraryOrdered =
         (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2))
   end
 
-module CompilingLibraryMap = Map.Make(CompilingLibraryOrdered)
+module LibraryMap = Map.Make(LibraryOrdered)
 
-(* This is a map from names to libraries *)
-let libraries_table = ref CompilingLibraryMap.empty
+(* This is a map from names to loaded libraries *)
+let libraries_table = ref LibraryMap.empty
 
-(* These are the _ordered_ lists of loaded, imported and exported libraries *)
+(* These are the _ordered_ sets of loaded, imported and exported libraries *)
 let libraries_loaded_list = ref []
 let libraries_imports_list = ref []
 let libraries_exports_list = ref []
@@ -128,7 +160,7 @@ let unfreeze (mt,mo,mi,me) =
   libraries_exports_list := me
 
 let init () =
-  libraries_table := CompilingLibraryMap.empty;
+  libraries_table := LibraryMap.empty;
   libraries_loaded_list := [];
   libraries_imports_list := [];
   libraries_exports_list := []
@@ -141,18 +173,20 @@ let _ =
       Summary.survive_module = false;
       Summary.survive_section = false }
 
-let find_library s =
-  CompilingLibraryMap.find s !libraries_table
+(* various requests to the tables *)
+
+let find_library dir =
+  LibraryMap.find dir !libraries_table
 
-let try_find_library s =
-  try find_library s
+let try_find_library dir =
+  try find_library dir
   with Not_found ->
-    error ("Unknown library " ^ (string_of_dirpath s))
+    error ("Unknown library " ^ (string_of_dirpath dir))
 
-let library_full_filename m = (find_library m).library_filename
+let library_full_filename dir = (find_library dir).library_filename
 
 let library_is_loaded dir =
-  try let _ = CompilingLibraryMap.find dir !libraries_table in true
+  try let _ = find_library dir in true
   with Not_found -> false
 
 let library_is_opened dir = 
@@ -176,7 +210,7 @@ let register_loaded_library m =
     | m'::_ as l when m'.library_name = m.library_name -> l
     | m'::l' -> m' :: aux l' in
   libraries_loaded_list := aux !libraries_loaded_list;
-  libraries_table := CompilingLibraryMap.add m.library_name m !libraries_table
+  libraries_table := LibraryMap.add m.library_name m !libraries_table
 
   (* ... while if a library is imported/exported several time, then
      only the last occurrence is really needed - though the imported
@@ -198,10 +232,8 @@ let register_open_library export m =
 (************************************************************************)
 (*s Opening libraries *)
 
-(*s [open_library s] opens a library. The library [s] and all
-  libraries needed by [s] are assumed to be already loaded. When
-  opening [s] we recursively open all the libraries needed by [s]
-  and tagged [exported]. *)
+(* [open_library export explicit m] opens library [m] if not already
+   opened _or_ if explicitly asked to be (re)opened *)
 
 let eq_lib_name m1 m2 = m1.library_name = m2.library_name
 
@@ -219,7 +251,10 @@ let open_library export explicit_libs m =
     if export then 
       libraries_exports_list := remember_last_of_each !libraries_exports_list m
 
-let open_libraries export modl = 
+(* open_libraries recursively open a list of libraries but opens only once 
+   a library that is re-exported many times *)
+
+let open_libraries export modl =
   let to_open_list = 
     List.fold_left
       (fun l m ->
@@ -261,77 +296,94 @@ let (in_import, out_import) =
 
 
 (************************************************************************)
-(*s Loading from disk to cache (preparation phase) *)
-
-let vo_magic_number7 = 07993 (* V8.0pl3 final old syntax *)
-let vo_magic_number8 = 08003 (* V8.0pl3 final new syntax *)
-
-let (raw_extern_library7, raw_intern_library7) =
-  System.raw_extern_intern vo_magic_number7 ".vo"
+(*s Low-level interning/externing of libraries to files *)
 
-let (raw_extern_library8, raw_intern_library8) =
-  System.raw_extern_intern vo_magic_number8 ".vo"
+(*s Loading from disk to cache (preparation phase) *)
 
-let raw_intern_library a =
-  if !Options.v7 then
-    try raw_intern_library7 a
-    with System.Bad_magic_number fname ->
-      let _= raw_intern_library8 a in
-      error "Inconsistent compiled files: you probably want to use Coq in new syntax and remove the option -v7 or -translate"
-  else
-    try raw_intern_library8 a
-    with System.Bad_magic_number fname ->
-      let _= raw_intern_library7 a in
-      error "Inconsistent compiled files: you probably want to use Coq in old syntax by setting options -v7 or -translate"
+let vo_magic_number = 080100 (* V8.1 *)
 
-let raw_extern_library =
-  if !Options.v7 then raw_extern_library7 else raw_extern_library8
+let (raw_extern_library, raw_intern_library) =
+  System.raw_extern_intern vo_magic_number ".vo"
 
-(* cache for loaded libraries *)
-let compunit_cache = ref CompilingLibraryMap.empty
+let with_magic_number_check f a =
+  try f a
+  with System.Bad_magic_number fname ->
+    errorlabstrm "with_magic_number_check"
+    (str"file " ++ str fname ++ spc () ++ str"has bad magic number." ++
+    spc () ++ str"It is corrupted" ++ spc () ++
+    str"or was compiled with another version of Coq.")
 
-let _ = 
-  Summary.declare_summary "MODULES-CACHE"
-    { Summary.freeze_function = (fun () -> !compunit_cache);
-      Summary.unfreeze_function = (fun cu -> compunit_cache := cu);
-      Summary.init_function = 
-	(fun () -> compunit_cache := CompilingLibraryMap.empty);
-      Summary.survive_module = true;
-      Summary.survive_section = true }
-
-(*s [load_library s] loads the library [s] from the disk, and [find_library s]
-   returns the library of name [s], loading it if necessary. 
-   The boolean [doexp] specifies if we open the libraries which are declared
-   exported in the dependencies (it is [true] at the highest level;
-   then same value as for caller is reused in recursive loadings). *)
+(************************************************************************)
+(*s Locate absolute or partially qualified library names in the path *)
 
 exception LibUnmappedDir
 exception LibNotFound
 type library_location = LibLoaded | LibInPath
 
 let locate_absolute_library dir =
-  (* Look if loaded in current environment *)
+  (* Search in loadpath *)
+  let pref, base = split_dirpath dir in
+  let loadpath = load_paths_of_dir_path pref in
+  if loadpath = [] then raise LibUnmappedDir;
   try
-    let m = CompilingLibraryMap.find dir !libraries_table in
-    (dir, m.library_filename)
-  with Not_found ->
-  (* Look if in loadpath *)
-  try
-    let pref, base = split_dirpath dir in
-    let loadpath = load_path_of_logical_path pref in
-    if loadpath = [] then raise LibUnmappedDir;
     let name = (string_of_id base)^".vo" in
     let _, file = System.where_in_path loadpath name in
     (dir, file)
-  with Not_found ->  raise LibNotFound
+  with Not_found ->
+  (* Last chance, removed from the file system but still in memory *)
+  try
+    (dir, library_full_filename dir)
+  with Not_found ->
+    raise LibNotFound
 
-let with_magic_number_check f a =
-  try f a
-  with System.Bad_magic_number fname ->
-    errorlabstrm "with_magic_number_check"
-    (str"file " ++ str fname ++ spc () ++ str"has bad magic number." ++
-    spc () ++ str"It is corrupted" ++ spc () ++
-    str"or was compiled with another version of Coq.")
+let locate_qualified_library qid =
+  try
+    (* Search library in loadpath *)
+    let dir, base = repr_qualid qid in 
+    let loadpath =
+      if repr_dirpath dir = [] then get_load_paths ()
+      else 
+        (* we assume dir is an absolute dirpath *)
+	load_paths_of_dir_path dir
+    in
+    if loadpath = [] then raise LibUnmappedDir;
+    let name =  (string_of_id base)^".vo" in
+    let path, file = System.where_in_path loadpath name in
+    let dir = extend_dirpath (find_logical_path path) base in
+    (* Look if loaded *)
+    try 
+      (LibLoaded, dir, library_full_filename dir)      
+    with Not_found ->
+      (LibInPath, dir, file)
+  with Not_found -> raise LibNotFound
+
+let explain_locate_library_error qid = function
+  | LibUnmappedDir ->
+      let prefix, _ = repr_qualid qid in
+      errorlabstrm "load_absolute_library_from"
+      (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ 
+      str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ())
+  | LibNotFound ->
+      errorlabstrm "load_absolute_library_from"
+      (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath")
+  | e -> raise e
+
+let try_locate_absolute_library dir =
+  try
+    locate_absolute_library dir
+  with e ->
+    explain_locate_library_error (qualid_of_dirpath dir) e
+
+let try_locate_qualified_library (loc,qid) =
+  try
+    let (_,dir,f) = locate_qualified_library qid in
+    dir,f
+  with e -> 
+    explain_locate_library_error qid e
+
+
+(************************************************************************)
+(* Internalise libraries *)
 
 let lighten_library m = 
   if !Options.dont_load_proofs then lighten_library m else m
@@ -352,55 +404,35 @@ let intern_from_file f =
   close_in ch;
   mk_library md f digest
 
-let rec intern_library (dir, f) =
-  try
-    (* Look if in the current logical environment *)
-    CompilingLibraryMap.find dir !libraries_table
+let rec intern_library needed (dir, f) =
+  (* Look if in the current logical environment *)
+  try find_library dir, needed
   with Not_found ->
-  try
-    (* Look if already loaded in cache and consequently its dependencies *)
-    CompilingLibraryMap.find dir !compunit_cache
+  (* Look if already listed and consequently its dependencies too *)
+  try List.assoc dir needed, needed
   with Not_found ->
-    (* [dir] is an absolute name which matches [f] which must be in loadpath *)
-    let m = intern_from_file f in
-    if dir <> m.library_name then
-      errorlabstrm "load_physical_library"
-	(str ("The file " ^ f ^ " contains library") ++ spc () ++
-	 pr_dirpath m.library_name ++ spc () ++ str "and not library" ++
-         spc() ++ pr_dirpath dir);
-    intern_and_cache_library dir m
-
-and intern_and_cache_library dir m =
-  compunit_cache := CompilingLibraryMap.add dir m !compunit_cache;
-  try
-    List.iter (intern_mandatory_library dir) m.library_deps;
-    m
-  with e ->
-    compunit_cache := CompilingLibraryMap.remove dir !compunit_cache; 
-    raise e
+  (* [dir] is an absolute name which matches [f] which must be in loadpath *)
+  let m = intern_from_file f in
+  if dir <> m.library_name then
+    errorlabstrm "load_physical_library"
+      (str ("The file " ^ f ^ " contains library") ++ spc () ++
+       pr_dirpath m.library_name ++ spc () ++ str "and not library" ++
+       spc() ++ pr_dirpath dir);
+  m, intern_library_deps needed dir m
+
+and intern_library_deps needed dir m =
+  (dir,m)::List.fold_left (intern_mandatory_library dir) needed m.library_deps
 
-and intern_mandatory_library caller (dir,d) =
-  let m = intern_absolute_library_from dir in
+and intern_mandatory_library caller needed (dir,d) =
+  let m,needed = intern_library needed (try_locate_absolute_library dir) in
   if d <> m.library_digest then
     error ("compiled library "^(string_of_dirpath caller)^
 	   " makes inconsistent assumptions over library "
-	   ^(string_of_dirpath dir))
-
-and intern_absolute_library_from dir =
-  try
-    intern_library (locate_absolute_library dir)
-  with
-  | LibUnmappedDir ->
-      let prefix, dir = fst (split_dirpath dir), string_of_dirpath dir in
-      errorlabstrm "load_absolute_library_from"
-      (str ("Cannot load "^dir^":") ++ spc () ++ 
-      str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ())
-  | LibNotFound ->
-      errorlabstrm "load_absolute_library_from"
-      (str"Cannot find library " ++ pr_dirpath dir ++ str" in loadpath")
-  | e -> raise e
+	   ^(string_of_dirpath dir));
+  needed
 
-let rec_intern_library mref = let _ = intern_library mref in ()
+let rec_intern_library needed mref =
+  let _,needed = intern_library needed mref in needed
 
 let check_library_short_name f dir = function
   | Some id when id <> snd (split_dirpath dir) ->
@@ -416,55 +448,18 @@ let rec_intern_by_filename_only id f =
   check_library_short_name f m.library_name id;
   (* We check no other file containing same library is loaded *)
   try
-    let m' = CompilingLibraryMap.find m.library_name !libraries_table in
+    let m' = find_library m.library_name in
     Options.if_verbose warning 
       ((string_of_dirpath m.library_name)^" is already loaded from file "^
        m'.library_filename);
-    m.library_name
+    m.library_name, []
   with Not_found ->
-    let m = intern_and_cache_library m.library_name m in
-    m.library_name
-
-let locate_qualified_library qid =
-  try
-    (* Search library in loadpath *)
-    let dir, base = repr_qualid qid in 
-    let loadpath =
-      if repr_dirpath dir = [] then get_load_path ()
-      else 
-        (* we assume dir is an absolute dirpath *)
-	load_path_of_logical_path dir
-    in
-    if loadpath = [] then raise LibUnmappedDir;
-    let name =  (string_of_id base)^".vo" in
-    let path, file = System.where_in_path loadpath name in
-    let dir = extend_dirpath (find_logical_path path) base in
-    (* Look if loaded *)
-    try 
-      (LibLoaded, dir, library_full_filename dir)      
-    with Not_found ->
-      (LibInPath, dir, file)
-  with Not_found -> raise LibNotFound
-
-let rec_intern_qualified_library (loc,qid) =
-  try
-    let (_,dir,f) = locate_qualified_library qid in
-    rec_intern_library (dir,f);
-    dir
-  with
-  | LibUnmappedDir ->
-      let prefix, id = repr_qualid qid in
-      user_err_loc (loc, "rec_intern_qualified_library",
-        str ("Cannot load "^(string_of_id id)^":") ++ spc () ++ 
-        str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++
-        fnl ())
-  | LibNotFound ->
-      user_err_loc (loc, "rec_intern_qualified_library",
-        str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath")
+    let needed = intern_library_deps [] m.library_name m in
+    m.library_name, needed
 
 let rec_intern_library_from_file idopt f =
   (* A name is specified, we have to check it contains library id *)
-  let _, f = System.find_file_in_path (get_load_path ()) (f^".vo") in
+  let _, f = System.find_file_in_path (get_load_paths ()) (f^".vo") in
   rec_intern_by_filename_only idopt f
 
 (**********************************************************************)
@@ -472,8 +467,11 @@ let rec_intern_library_from_file idopt f =
     operation. It is performed as follows:
 
   preparation phase: (functions require_library* ) the library and its 
-    dependencies are read from to disk to the compunit_cache 
-    (using intern_* )
+    dependencies are read from to disk (using intern_* )
+    [they are read from disk to ensure that at section/module
+     discharging time, the physical library referred to outside the
+     section/module is the one that was used at type-checking time in
+     the section/module]
 
   execution phase: (through add_leaf and cache_require)
     the library is loaded in the environment and Nametab, the objects are 
@@ -487,117 +485,83 @@ let rec_intern_library_from_file idopt f =
 
 type library_reference = dir_path list * bool option
 
-let string_of_library (_,dir,_) = string_of_id (List.hd (repr_dirpath dir))
+let register_library (dir,m) =
+  Declaremods.register_library
+    m.library_name 
+    m.library_compiled 
+    m.library_objects 
+    m.library_digest;
+  register_loaded_library m
 
-let rec load_library dir =
-  try
-    (* Look if loaded in current env (and consequently its dependencies) *)
-    CompilingLibraryMap.find dir !libraries_table
-  with Not_found ->
-    (* [dir] is an absolute name matching [f] which must be in loadpath *)
-    let m =
-      try CompilingLibraryMap.find dir !compunit_cache
-      with Not_found ->
-        anomaly ((string_of_dirpath dir)^" should be in cache")
-    in
-    List.iter (fun (dir,_) -> ignore (load_library dir)) m.library_deps;
-    Declaremods.register_library
-      m.library_name 
-      m.library_compiled 
-      m.library_objects 
-      m.library_digest;
-    register_loaded_library m;
-    m
-
-let cache_require (_,(modl,export)) =
-  let ml = list_map_left load_library modl in
-  match export with
-    | None -> ()
-    | Some export -> open_libraries export ml
-
-let load_require  _ (_,(modl,_)) =
-  ignore(list_map_left load_library modl)
+  (* [needed] is the ordered list of libraries not already loaded *)
+let cache_require (_,(needed,modl,export)) =
+  List.iter register_library needed;
+  option_iter (fun exp -> open_libraries exp (List.map find_library modl))
+    export
+
+let load_require  _ (_,(needed,modl,_)) =
+  List.iter register_library needed
 
   (* keeps the require marker for closed section replay but removes
      OS dependent fields from .vo files for cross-platform compatibility *)
-let export_require (l,e) = Some (l,e)
+let export_require (_,l,e) = Some ([],l,e)
+
+let discharge_require (_,o) = Some o
 
 let (in_require, out_require) =
   declare_object {(default_object "REQUIRE") with
        cache_function = cache_require;
        load_function = load_require;
        export_function = export_require;
+       discharge_function = discharge_require;
        classify_function = (fun (_,o) -> Anticipate o) }
 
+(* Require libraries, import them if [export <> None], mark them for export
+   if [export = Some true] *)
+
+(* read = require without opening *)
+
 let xml_require = ref (fun d -> ())
 let set_xml_require f = xml_require := f
 
-let require_library spec qidl export =
-(*
-  if sections_are_opened () && Options.verbose () then
-    warning ("Objets of "^(string_of_library modref)^
-             " not surviving sections (e.g. Grammar \nand Hints)\n"^
-             "will be removed at the end of the section");
-*)
-  let modrefl = List.map rec_intern_qualified_library qidl in
+let require_library qidl export =
+  let modrefl = List.map try_locate_qualified_library qidl in
+  let needed = List.rev (List.fold_left rec_intern_library [] modrefl) in
+  let modrefl = List.map fst modrefl in
     if Lib.is_modtype () || Lib.is_module () then begin
-      add_anonymous_leaf (in_require (modrefl,None));
-      List.iter
-	(fun dir ->
-	   add_anonymous_leaf (in_import (dir, export)))
-	modrefl
+      add_anonymous_leaf (in_require (needed,modrefl,None));
+      option_iter (fun exp ->
+	List.iter (fun dir -> add_anonymous_leaf (in_import(dir,exp))) modrefl)
+	export
     end
     else
-      add_anonymous_leaf (in_require (modrefl,Some export));
+      add_anonymous_leaf (in_require (needed,modrefl,export));
   if !Options.xml_export then List.iter !xml_require modrefl;
   add_frozen_state ()
 
-let require_library_from_file spec idopt file export =
-  let modref = rec_intern_library_from_file idopt file in
-    if Lib.is_modtype () || Lib.is_module () then begin
-      add_anonymous_leaf (in_require ([modref],None));
-      add_anonymous_leaf (in_import (modref, export))
-    end
-    else
-      add_anonymous_leaf (in_require ([modref],Some export));
-    if !Options.xml_export then !xml_require modref;
-    add_frozen_state ()
-
-
-(* read = require without opening *)
-
-let read_library qid =
-  let modref = rec_intern_qualified_library qid in
-  add_anonymous_leaf (in_require ([modref],None));
-  if !Options.xml_export then !xml_require modref;
-  add_frozen_state ()
-
-let read_library_from_file f =
-  let _, f = System.find_file_in_path (get_load_path ()) (f^".vo") in
-  let modref = rec_intern_by_filename_only None f in
-  add_anonymous_leaf (in_require ([modref],None));
+let require_library_from_file idopt file export =
+  let modref,needed = rec_intern_library_from_file idopt file in
+  let needed = List.rev needed in
+  if Lib.is_modtype () || Lib.is_module () then begin
+    add_anonymous_leaf (in_require (needed,[modref],None));
+    option_iter (fun exp -> add_anonymous_leaf (in_import (modref,exp)))
+      export
+  end
+  else
+    add_anonymous_leaf (in_require (needed,[modref],export));
   if !Options.xml_export then !xml_require modref;
   add_frozen_state ()
 
-
-(* called at end of section *)
-
-let reload_library modrefl =
-  add_anonymous_leaf (in_require modrefl);
-  add_frozen_state ()
-
-
-
 (* the function called by Vernacentries.vernac_import *)
 
-let import_library export (loc,qid) =
+let import_module export (loc,qid) =
   try
     match Nametab.locate_module qid with
 	MPfile dir -> 
 	  if Lib.is_modtype () || Lib.is_module () || not export then
 	    add_anonymous_leaf (in_import (dir, export))
 	  else
-	    add_anonymous_leaf (in_require ([dir], Some export))
+	    add_anonymous_leaf (in_require ([],[dir], Some export))
       | mp ->
 	  import_module export mp
   with
@@ -607,31 +571,42 @@ let import_library export (loc,qid) =
 	 str ((string_of_qualid qid)^" is not a module"))
   
 (************************************************************************)
-(*s [save_library s] saves the library [m] to the disk. *)
+(*s Initializing the compilation of a library. *)
 
 let start_library f = 
   let _,longf = 
-    System.find_file_in_path (get_load_path ()) (f^".v") in
+    System.find_file_in_path (get_load_paths ()) (f^".v") in
   let ldir0 = find_logical_path (Filename.dirname longf) in
   let id = id_of_string (Filename.basename f) in
   let ldir = extend_dirpath ldir0 id in
   Declaremods.start_library ldir;
   ldir,longf
 
+(************************************************************************)
+(*s [save_library dir] ends library [dir] and save it to the disk. *)
+
 let current_deps () =
   List.map (fun m -> (m.library_name, m.library_digest)) !libraries_loaded_list
 
 let current_reexports () =
   List.map (fun m -> m.library_name) !libraries_exports_list
 
-let save_library_to s f =
-  let cenv, seg = Declaremods.end_library s in
+let error_recursively_dependent_library dir =
+  errorlabstrm ""
+    (str "Unable to use logical name" ++ spc() ++ pr_dirpath dir ++ spc() ++ 
+     str "to save current library" ++ spc() ++ str"because" ++ spc() ++ 
+     str "it already depends on a library of this name.")
+
+let save_library_to dir f =
+  let cenv, seg = Declaremods.end_library dir in
   let md = { 
-    md_name = s;
+    md_name = dir;
     md_compiled = cenv;
     md_objects = seg;
     md_deps = current_deps ();
     md_imports = current_reexports () } in
+  if List.mem_assoc dir md.md_deps then
+    error_recursively_dependent_library dir;
   let (f',ch) = raw_extern_library f in
   try
     System.marshal_out ch md;
@@ -639,35 +614,9 @@ let save_library_to s f =
     let di = Digest.file f' in
     System.marshal_out ch di;
     close_out ch
-  with e -> (warning ("Removed file "^f');close_out ch; Sys.remove f'; raise e)
-
-(*s Pretty-printing of libraries state. *)
- 
-(* this function is not used... *)
-let fmt_libraries_state () =
-  let opened = opened_libraries ()
-  and loaded = loaded_libraries () in
-  (str "Imported (open) Modules: " ++
-     prlist_with_sep pr_spc pr_dirpath opened ++ fnl () ++
-     str "Loaded Modules: " ++
-     prlist_with_sep pr_spc pr_dirpath loaded ++ fnl ())
-
-
-(*s For tactics/commands requiring vernacular libraries *)
-
-let check_required_library d =
-  let d' = List.map id_of_string d in
-  let dir = make_dirpath (List.rev d') in
-  if not (library_is_loaded dir) then
-(* Loading silently ...
-    let m, prefix = list_sep_last d' in
-    read_library 
-     (dummy_loc,make_qualid (make_dirpath (List.rev prefix)) m)
-*)
-(* or failing ...*)
-    error ("Library "^(list_last d)^" has to be required first")
-
+  with e -> (warning ("Removed file "^f'); close_out ch; Sys.remove f'; raise e)
 
+(************************************************************************)
 (*s Display the memory use of a library. *)
 
 open Printf
diff --git a/library/library.mli b/library/library.mli
index 18be1671..27ace544 100644
--- a/library/library.mli
+++ b/library/library.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: library.mli,v 1.23.2.1 2004/07/16 19:30:36 herbelin Exp $ i*)
+(*i $Id: library.mli 8877 2006-05-30 16:37:04Z notin $ i*)
 
 (*i*)
 open Util
@@ -15,65 +15,59 @@ open Libnames
 open Libobject
 (*i*)
 
-(*s This module is the heart of the library. It provides low level
-  functions to load, open and save libraries. Libraries are saved
-  onto the disk with checksums (obtained with the [Digest] module),
-  which are checked at loading time to prevent inconsistencies
-  between files written at various dates. It also provides a high
-  level function [require] which corresponds to the vernacular
-  command [Require]. *)
+(*s This module provides functions to load, open and save
+  libraries. Libraries correspond to the subclass of modules that
+  coincide with a file on disk (the ".vo" files). Libraries on the
+  disk comes with checksums (obtained with the [Digest] module), which
+  are checked at loading time to prevent inconsistencies between files
+  written at various dates.
+*)
+
+(*s Require = load in the environment + open (if the optional boolean
+    is not [None]); mark also for export if the boolean is [Some true] *)
+val require_library : qualid located list -> bool option -> unit
+val require_library_from_file :
+  identifier option -> System.physical_path -> bool option -> unit
+
+(*s Open a module (or a library); if the boolean is true then it's also
+   an export otherwise just a simple import *)
+val import_module : bool -> qualid located -> unit
 
-val read_library : qualid located -> unit
+(*s Start the compilation of a library *)
+val start_library : string -> dir_path * string
 
-val read_library_from_file : System.physical_path -> unit
+(*s End the compilation of a library and save it to a ".vo" file *)
+val save_library_to : dir_path -> string -> unit
 
-(* [import_library true qid] = [export qid] *)
- 
-val import_library : bool -> qualid located -> unit
+(*s Interrogate the status of libraries *)
 
+  (* - Tell if a library is loaded or opened *)
 val library_is_loaded : dir_path -> bool
 val library_is_opened : dir_path -> bool
 
+  (* - Tell which libraries are loaded or imported *)
 val loaded_libraries : unit -> dir_path list
 val opened_libraries : unit -> dir_path list
 
-val fmt_libraries_state : unit -> Pp.std_ppcmds
-
-(*s Require. The command [require_library spec m file export] loads and opens
-  a library [m]. [file] specifies the filename, if not [None]. [spec]
-  specifies to look for a specification ([true]) or for an implementation
-  ([false]), if not [None]. And [export] specifies if the library must be 
-  exported. *)
-
-val require_library :
-  bool option -> qualid located list -> bool -> unit
-
-val require_library_from_file :
-  bool option -> identifier option -> System.physical_path -> bool -> unit
-
-val set_xml_require : (dir_path -> unit) -> unit
-
-(*s [save_library_to s f] saves the current environment as a library [s]
-  in the file [f]. *)
-
-val start_library : string -> dir_path * string
-val save_library_to : dir_path -> string -> unit
-
-(* [library_full_filename] returns the full filename of a loaded library. *)
-
+  (* - Return the full filename of a loaded library. *)
 val library_full_filename : dir_path -> string
 
+(*s Hook for the xml exportation of libraries *)
+val set_xml_require : (dir_path -> unit) -> unit
 
-(*s Global load path *)
-type logical_path = dir_path
+(*s Global load paths: a load path is a physical path in the file
+    system; to each load path is associated a Coq [dir_path] (the "logical"
+    path of the physical path) *)
 
-val get_load_path : unit -> System.physical_path list
-val get_full_load_path : unit -> (System.physical_path * logical_path) list
-val add_load_path_entry : System.physical_path * logical_path -> unit
-val remove_path : System.physical_path -> unit
-val find_logical_path : System.physical_path -> logical_path
-val load_path_of_logical_path : dir_path -> System.physical_path list
+val get_load_paths : unit -> System.physical_path list
+val get_full_load_paths : unit -> (System.physical_path * dir_path) list
+val add_load_path : System.physical_path * dir_path -> unit
+val remove_load_path : System.physical_path -> unit
+val find_logical_path : System.physical_path -> dir_path
+val is_in_load_paths : System.physical_path -> bool
+val load_paths_of_dir_path : dir_path -> System.physical_path list
 
+(*s Locate a library in the load paths *)
 exception LibUnmappedDir
 exception LibNotFound
 type library_location = LibLoaded | LibInPath
@@ -81,14 +75,5 @@ type library_location = LibLoaded | LibInPath
 val locate_qualified_library :
   qualid -> library_location * dir_path * System.physical_path
 
-
-val check_required_library : string list -> unit
-
-(*s Displays the memory use of a library. *)
+(*s Statistics: display the memory use of a library. *)
 val mem : dir_path -> Pp.std_ppcmds
-
-(* For discharge *)
-type library_reference
-
-val out_require : Libobject.obj -> library_reference
-val reload_library : library_reference -> unit
diff --git a/library/nameops.ml b/library/nameops.ml
index 35b707a7..6d0ad8ef 100644
--- a/library/nameops.ml
+++ b/library/nameops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nameops.ml,v 1.21.2.2 2004/10/12 10:12:31 herbelin Exp $ *)
+(* $Id: nameops.ml 9429 2006-12-12 08:01:03Z herbelin $ *)
 
 open Pp
 open Util
@@ -16,7 +16,9 @@ open Names
 
 let pr_id id = str (string_of_id id)
 
-let wildcard = id_of_string "_"
+let pr_name = function
+  | Anonymous -> str "_"
+  | Name id -> pr_id id
 
 (* Utilities *)
 
@@ -134,7 +136,7 @@ let next_ident_away_from id avoid =
 
 let out_name = function
   | Name id -> id
-  | Anonymous -> anomaly "out_name: expects a defined name"
+  | Anonymous -> failwith "out_name: expects a defined name"
 
 let name_fold f na a =
   match na with
@@ -150,15 +152,16 @@ let name_app f = function
   | Name id -> Name (f id)
   | Anonymous -> Anonymous
 
+let name_fold_map f e = function
+  | Name id -> let (e,id) = f e id in (e,Name id)
+  | Anonymous -> e,Anonymous
+
 let next_name_away_with_default default name l = 
   match name with
     | Name str  -> next_ident_away str l
     | Anonymous -> next_ident_away (id_of_string default) l
 
-let next_name_away name l = 
-  match name with
-    | Name str  -> next_ident_away str l
-    | Anonymous -> id_of_string "_"
+let next_name_away = next_name_away_with_default "H"
 
 let pr_lab l = str (string_of_label l)
 
diff --git a/library/nameops.mli b/library/nameops.mli
index 71dbf040..25c4ea56 100644
--- a/library/nameops.mli
+++ b/library/nameops.mli
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nameops.mli,v 1.12.2.3 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: nameops.mli 9429 2006-12-12 08:01:03Z herbelin $ i*)
 
 open Names
 
 (* Identifiers and names *)
 val pr_id : identifier -> Pp.std_ppcmds
-val wildcard : identifier
+val pr_name : name -> Pp.std_ppcmds
 
 val make_ident : string -> int option -> identifier
 val repr_ident : identifier -> string * int option
@@ -36,6 +36,8 @@ val out_name : name -> identifier
 val name_fold : (identifier -> 'a -> 'a) -> name -> 'a -> 'a
 val name_cons : name -> identifier list -> identifier list
 val name_app : (identifier -> identifier) -> name -> name
+val name_fold_map : ('a -> identifier -> 'a * identifier) -> 'a -> name -> 'a * name
+
 
 val pr_lab : label -> Pp.std_ppcmds
 
diff --git a/library/nametab.ml b/library/nametab.ml
index 4bd0cb3f..96280e8b 100755..100644
--- a/library/nametab.ml
+++ b/library/nametab.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nametab.ml,v 1.48.2.2 2005/11/21 09:16:27 herbelin Exp $ *)
+(* $Id: nametab.ml 8642 2006-03-17 10:09:02Z notin $ *)
 
 open Util
 open Pp
@@ -96,7 +96,7 @@ struct
      [push_exactly] to [Exactly vis] and [push_tree] chooses the right one*)
 
   let rec push_until uname o level (current,dirmap) = function
-    | modid :: path as dir ->
+    | modid :: path ->
 	let mc = 
 	  try ModIdmap.find modid dirmap
 	  with Not_found -> (Nothing, ModIdmap.empty)
@@ -135,7 +135,7 @@ struct
 
 
 let rec push_exactly uname o level (current,dirmap) = function
-  | modid :: path as dir ->
+  | modid :: path ->
       let mc = 
 	try ModIdmap.find modid dirmap
 	with Not_found -> (Nothing, ModIdmap.empty)
diff --git a/library/nametab.mli b/library/nametab.mli
index 4cea1d40..a05b7415 100755
--- a/library/nametab.mli
+++ b/library/nametab.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: nametab.mli,v 1.43.2.3 2005/11/21 09:16:27 herbelin Exp $ i*)
+(*i $Id: nametab.mli 7596 2005-11-21 09:17:07Z herbelin $ i*)
 
 (*i*)
 open Util
diff --git a/library/states.ml b/library/states.ml
index 7a7f1e06..169a3857 100644
--- a/library/states.ml
+++ b/library/states.ml
@@ -6,16 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: states.ml,v 1.8.14.1 2004/07/16 19:30:36 herbelin Exp $ *)
+(* $Id: states.ml 9100 2006-08-31 18:04:26Z herbelin $ *)
 
 open System
 
 type state = Lib.frozen * Summary.frozen
 
-let get_state () =
+let freeze () =
   (Lib.freeze(), Summary.freeze_summaries())
 
-let set_state (fl,fs) =
+let unfreeze (fl,fs) =
   Lib.unfreeze fl;
   Summary.unfreeze_summaries fs
 
@@ -23,17 +23,14 @@ let state_magic_number = 19764
 
 let (extern_state,intern_state) =
   let (raw_extern, raw_intern) = extern_intern state_magic_number ".coq" in
-  (fun s -> raw_extern s (get_state())),
-  (fun s -> set_state (raw_intern (Library.get_load_path ()) s))
+  (fun s -> raw_extern s (freeze())),
+  (fun s -> unfreeze (raw_intern (Library.get_load_paths ()) s))
 
 (* Rollback. *)
 
-let freeze = get_state
-let unfreeze = set_state
-
 let with_heavy_rollback f x =
-  let st = get_state () in
+  let st = freeze () in
   try 
     f x
   with reraise ->
-    (set_state st; raise reraise)
+    (unfreeze st; raise reraise)
diff --git a/library/states.mli b/library/states.mli
index 70018180..eff046ef 100644
--- a/library/states.mli
+++ b/library/states.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: states.mli,v 1.6.16.1 2004/07/16 19:30:36 herbelin Exp $ i*)
+(*i $Id: states.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*s States of the system. In that module, we provide functions to get
   and set the state of the whole system. Internally, it is done by
diff --git a/library/summary.ml b/library/summary.ml
index fc88350a..455ee264 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: summary.ml,v 1.7.2.1 2004/07/16 19:30:36 herbelin Exp $ *)
+(* $Id: summary.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Util
diff --git a/library/summary.mli b/library/summary.mli
index 7e691f0b..ba527bdf 100644
--- a/library/summary.mli
+++ b/library/summary.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: summary.mli,v 1.8.2.1 2004/07/16 19:30:36 herbelin Exp $ i*)
+(*i $Id: summary.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* This module registers the declaration of global tables, which will be kept
    in synchronization during the various backtracks of the system. *)
diff --git a/man/coqc.1 b/man/coqc.1
index 741b3dcb..7113d504 100644
--- a/man/coqc.1
+++ b/man/coqc.1
@@ -32,10 +32,13 @@ For interactive use of Coq, see
 
 .SH OPTIONS
 
-.TP
-.BI \-h
-Will give you a description of the whole list of options of coqc and
-coqtop.
+.B coqc
+is a script that simply runs
+.B coqtop
+with option 
+.B \-compile
+it accepts the same options as
+.B coqtop.
 
 .SH SEE ALSO
 
diff --git a/man/coqdep.1 b/man/coqdep.1
index 01d080fc..6ae89f8b 100644
--- a/man/coqdep.1
+++ b/man/coqdep.1
@@ -23,6 +23,9 @@ coqdep \- Compute inter-module dependencies for Coq and Caml programs
 [
 .BI \-D
 ]
+[
+.BI \-slash
+]
 .I filename ...
 .I directory ...
 
@@ -37,10 +40,11 @@ When a directory is given as argument, it is recursively looked at.
 Dependencies of Coq modules are computed by looking at
 .IR Require \&
 commands (Require, Require Export, Require Import, Require Implementation),
-and
 .IR Declare \& 
 .IR ML \& 
 .IR Module \&
+commands and
+.IR Load \&
 commands. Dependencies relative to modules from the Coq library are not
 printed.
 
@@ -54,8 +58,7 @@ directives and the dot notation
 .TP
 .BI \-c
 Prints the dependencies of Caml modules.
-(On Caml modules, the behaviour is exactly the same as cldepend,
-except that nested comments and strings are correctly handled).
+(On Caml modules, the behaviour is exactly the same as ocamldep).
 .TP
 .BI \-w
 Prints a warning if a Coq command
@@ -78,6 +81,10 @@ of each Coq file given as argument and complete (if needed)
 the list of Caml modules. The new command is printed on
 the standard output. No dependency is computed with this option.
 .TP 
+.BI \-slash
+Prints paths using a slash instead of the OS specific separator. This
+option is useful when developping under Cygwin.
+.TP
 .BI \-I \ directory
 The files .v .ml .mli of the directory
 .IR directory \&
@@ -87,7 +94,7 @@ but their own dependencies are not printed.
 .BI \-coqlib \ directory
 Indicates where is the Coq library. The default value has been
 determined at installation time, and therefore this option should not
-be used.
+be used under normal circumstances.
 
 
 .SH SEE ALSO
@@ -120,7 +127,7 @@ Consider the files (in the same directory):
 where
 .TP
 .BI \+ 
-D.ml contains the commands `#open "A"', `#open "B"' and `type t = C__t' ;
+D.ml contains the commands `open A', `open B' and `type t = C.t' ;
 .TP
 .BI \+
 Y.v contains the command `Require X' ;
@@ -135,7 +142,7 @@ example% coqdep -I . *.v
 .RS
 .sp .5
 .nf
-.B Z.vo: Z.v ./X.vo ./D.zo
+.B Z.vo: Z.v ./X.vo ./D.cmo
 .B Y.vo: Y.v ./X.vo
 .B X.vo: X.v
 .fi
@@ -150,7 +157,7 @@ example% coqdep -w -I . *.v
 .RS
 .sp .5
 .nf
-.B Z.vo: Z.v ./X.vo ./D.zo
+.B Z.vo: Z.v ./X.vo ./D.cmo
 .B Y.vo: Y.v ./X.vo
 .B X.vo: X.v
 ### Warning : In file Z.v, the ML modules declaration should be
@@ -167,10 +174,14 @@ example% coqdep -c -I . *.ml
 .RS
 .sp .5
 .nf
-.B D.zo: D.ml ./A.zo ./B.zo ./C.zo
-.B C.zo: C.ml
-.B B.zo: B.ml
-.B A.zo: A.ml
+.B D.cmo: D.ml ./A.cmo ./B.cmo ./C.cmo
+.B D.cmx: D.ml ./A.cmx ./B.cmx ./C.cmx
+.B C.cmo: C.ml
+.B C.cmx: C.ml
+.B B.cmo: B.ml
+.B B.cmx: B.ml
+.B A.cmo: A.ml
+.B A.cmx: A.ml
 .fi
 .RE
 .br
diff --git a/man/coqdoc.1 b/man/coqdoc.1
index c325d221..c443e8b0 100644
--- a/man/coqdoc.1
+++ b/man/coqdoc.1
@@ -1,4 +1,4 @@
-.TH coqdoc 1 "February, 2002"
+.TH coqdoc 1 "April, 2006"
 
 .SH NAME
 coqdoc \- A documentation tool for the Coq proof assistant
@@ -22,12 +22,165 @@ See the Coq reference manual for documentation (url below).
 
 .SH OPTIONS
 
+.SS Overall options
+
 .TP
-.B \-h
+.BI \-h
 Help. Will give you the complete list of options accepted by coqdoc.
+.TP
+.B \-\-html
+Select a HTML output.
+.TP
+.B \-\-latex
+Select a LATEX output.
+.TP
+.B \-\-dvi
+Select a DVI output.
+.TP
+.B \-\-ps
+Select a PostScript output.
+.TP
+.B \-\-texmacs
+Select a TeXmacs output.
+.TP
+.B \-\-stdout
+Redirect the output to stdout
+.TP
+.BI \-o \ file, \-\-output \ file
+Redirect the output into the file 
+.I file.
+.TP
+.BI \-d \ dir, \ \-\-directory \ dir
+Output files into directory 
+.I dir 
+instead of current directory (option
+-d does not change the filename specified with option -o, if any).
+.TP
+.B \-s, \ \-\-short
+Do not insert titles for the files. The default behavior is to insert
+a title like ``Library Foo'' for each file.
+.TP
+.BI \-t \ string, \ \-\-title \ string
+Set the document title.
+.TP
+.B \-\-body\-only
+Suppress the header and trailer of the final document. Thus, you can
+insert the resulting document into a larger one.
+.TP
+.BI \-p \ string, \ \-\-preamble \ string
+Insert some material in the LATEX preamble, right before \\begin{document} (meaningless with -html).
+.TP
+.BI \-\-vernac\-file \ file, \ \-\-tex\-file \ file
+Considers the file `file' respectively as a .v (or .g) file or a .tex file.
+.TP
+.BI \-\-files\-from \ file
+Read file names to process in file `file' as if they were given on the
+command line. Useful for program sources splitted in several
+directories.
+.TP
+.B \-q, \ \-\-quiet
+Be quiet. Do not print anything except errors.
+.TP
+.B \-h, \ \-\-help
+Give a short summary of the options and exit.
+.TP
+.B
+\-v, \ \-\-version
+Print the version and exit.
+
+.SS Index options
+
+Default behavior is to build an index, for the HTML output only, into
+index.html.
+
+.TP
+.B \-\-no\-index
+Do not output the index.
+.TP
+.B \-\-multi\-index
+Generate one page for each category and each letter in the index,
+together with a top page index.html.
+
+.SS Table of contents option
+ 
+.TP
+.B \-toc, \ \-\-table\-of\-contents
+Insert a table of contents. For a LATEX output, it inserts a
+\\tableofcontents at the beginning of the document. For a HTML output,
+it builds a table of contents into toc.html.
+
+.SS Hyperlinks options
+
+.TP
+.B \-\-glob\-from \ file
+Make references using Coq globalizations from file file. (Such
+globalizations are obtained with Coq option -dump-glob).
+
+.TP
+.B \-\-no\-externals
+Do not insert links to the Coq standard library.
+
+.TP
+.BI \-\-coqlib \ url
+Set base URL for the Coq standard library (default is http://coq.inria.fr/library/).
+
+.TP
+.BI \-\-coqlib_path \ dir
+Set the base path where the Coq files are installed, especially style files coqdoc.sty and coqdoc.css.
+
+.TP
+.BI -R \ dir \  coqdir
+Map physical directory dir to Coq logical directory coqdir (similarly
+to Coq option -R).
+.B Note: 
+option -R only has effect on the files following it on the command
+line, so you will probably need to put this option first.
+
+.SS Contents options
+
+.TP
+.B -g, \ --gallina
+Do not print proofs.
+
+.TP
+.B -l, \ --light
+Light mode. Suppress proofs (as with -g) and the following commands:
+
+        * [Recursive] Tactic Definition
+        * Hint / Hints
+        * Require
+        * Transparent / Opaque
+        * Implicit Argument / Implicits
+        * Section / Variable / Hypothesis / End 
+
+The behavior of options -g and -l can be locally overridden using the (* begin show *) ... (* end show *) environment (see above).
+
+.SS Language options
+ 
+Default behavior is to assume ASCII 7 bits input files.
+
+.TP 
+.B -latin1, \ --latin1
+Select ISO-8859-1 input files. It is equivalent to --inputenc latin1
+--charset iso-8859-1.
+
+.TP 
+.B -utf8, \ --utf8
+Select UTF-8 (Unicode) input files. It is equivalent to --inputenc
+utf8 --charset utf-8. LATEX UTF-8 support can be found at
+http://www.ctan.org/tex-archive/macros/latex/contrib/supported/unicode/.
+
+.TP 
+.BI --inputenc \ string
+Give a LATEX input encoding, as an option to LATEX package inputenc.
+
+.TP
+.BI --charset \ string
+Specify the HTML character set, to be inserted in the HTML header.
 
 
 .SH SEE ALSO
 
 .I
-The Coq web site: http://coq.inria.fr/
+The Coq Reference Manual from http://coq.inria.fr/
+
diff --git a/man/coqmktop.1 b/man/coqmktop.1
index 05e73d75..3640d439 100644
--- a/man/coqmktop.1
+++ b/man/coqmktop.1
@@ -28,6 +28,44 @@ directly or through coqc(1), using the -image option.
 .BI \-h
 Help. List the available options.
 
+.TP
+.BI \-srcdir \ dir
+Specify where the Coq source files are
+
+.TP
+.BI \-o \ exec\-file
+Specify the name of the resulting toplevel
+
+.TP
+.B \-opt
+Compile in native code
+
+.TP
+.B \-full
+Link high level tactics
+
+.TP
+.B \-top
+Build Coq on a ocaml toplevel (incompatible with
+.BR \-opt )
+
+.TP
+.B \-searchisos
+Build a toplevel for SearchIsos
+
+.TP
+.B \-ide
+Build a toplevel for the Coq IDE
+
+.TP
+.BI \-R \ dir
+Specify recursively directories for Ocaml
+
+.TP
+.B \-v8
+Link with V8 grammar
+
+
 .SH SEE ALSO
 
 .BR coqtop (1),
diff --git a/man/coqtop.1 b/man/coqtop.1
index d75b283f..a3b3aac4 100644
--- a/man/coqtop.1
+++ b/man/coqtop.1
@@ -1,4 +1,4 @@
-.TH COQ 1 "April 25, 2001"
+.TH COQ 1 "October 11, 2006"
 
 .SH NAME
 coqtop \- The Coq Proof Assistant toplevel system
@@ -24,9 +24,169 @@ For batch-oriented use of Coq, see
 .SH OPTIONS
 
 .TP
-.B \-h
+.B \-h, \-\-help
 Help. Will give you the complete list of options accepted by coqtop.
 
+.TP
+.BI \-I \ dir, \ \-\-include \ dir
+add directory 
+.I dir
+in the include path
+
+.TP
+.BI \-R \ dir\ coqdir          
+recursively map physical
+.I dir
+to logical
+.I coqdir
+
+.TP
+.BI \-top \ coqdir
+set the toplevel name to be
+.I coqdir
+instead of Top
+
+.TP
+.BI \-inputstate \ filename, \ \-is \ filename 
+read state from file
+.I filename.coq
+
+.TP
+.B \-nois
+start with an empty intial state
+
+.TP
+.BI \-outputstate filename
+write state in file
+.I filename.coq
+
+.TP
+.BI \-load\-ml\-object \ filename
+load ML object file
+.I filenname
+
+.TP
+.BI \-load\-ml\-source \ filename
+load ML file
+.I filename
+
+.TP
+.BI \-load\-vernac\-source \ filename, \ \-l \ filename
+load Coq file
+.I filename.v
+(Load filename.)
+
+.TP
+.BI \-load\-vernac\-source\-verbose \ filename, \ \-lv \ filename 
+load verbosely Coq file
+.I filename.v
+(Load Verbose filename.)
+
+.TP
+.BI \-load\-vernac\-object \ filename
+load Coq object file
+.I filename.vo
+
+.TP
+.BI \-require \ filename
+load Coq object file
+.I filename.vo
+and import it (Require Import filename.)
+
+.TP
+.BI \-compile \ filename
+compile Coq file
+.I filename.v 
+(implies 
+.B \-batch
+)
+
+.TP
+.BI \-compile\-verbose \ filename
+verbosely compile Coq file
+.I filename.v
+(implies 
+.B \-batch
+)
+
+.TP
+.B \-opt
+run the native\-code version of Coq
+
+.TP
+.B \-byte
+run the bytecode version of Coq
+
+.TP
+.B \-where
+print Coq's standard library location and exit
+
+.TP
+.B \-v
+print Coq version and exit
+
+.TP
+.B \-q
+skip loading of rcfile
+
+.TP
+.BI \-init\-file \ filename
+set the rcfile to
+.I filename
+
+.TP
+.BI \-user \ uid
+use the rcfile of user
+.I uid
+
+
+.TP
+.B \-batch
+batch mode (exits just after arguments parsing)
+
+.TP
+.B \-boot
+boot mode (implies
+.B \-q
+and
+.B \-batch
+)
+
+.TP
+.B \-emacs
+tells Coq it is executed under Emacs
+
+.TP
+.BI \-dump\-glob \ filename
+dump globalizations in file f (to be used by
+.B coqdoc(1)
+)
+
+.TP
+.BI \-with\-geoproof \ (yes|no)
+to (de)activate special functions for Geoproof within Coqide (default is
+.I yes
+)
+
+.TP
+.B \-impredicative\-set
+set sort Set impredicative
+
+.TP
+.B \-dont\-load\-proofs
+don't load opaque proofs in memory
+
+.TP
+.B \-xml
+export XML files either to the hierarchy rooted in
+the directory $COQ_XML_LIBRARY_ROOT (if set) or to
+stdout (if unset)
+
+.TP
+.B \-quality
+improve the legibility of the proof terms produced by
+some tactics
+
 .SH SEE ALSO
 
 .BR coqc (1),
diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4
index e6d9f99d..12c0ea1d 100644
--- a/parsing/argextend.ml4
+++ b/parsing/argextend.ml4
@@ -6,12 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: argextend.ml4,v 1.9.2.4 2005/01/15 14:56:53 herbelin Exp $ *)
+(* $Id: argextend.ml4 9265 2006-10-24 08:35:38Z herbelin $ *)
 
 open Genarg
 open Q_util
 open Q_coqast
-open Ast
 
 let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
 let loc = Util.dummy_loc
@@ -25,16 +24,14 @@ let rec make_rawwit loc = function
   | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >>
   | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >>
   | IdentArgType -> <:expr< Genarg.rawwit_ident >>
-  | HypArgType -> <:expr< Genarg.rawwit_var >>
+  | VarArgType -> <:expr< Genarg.rawwit_var >>
   | RefArgType -> <:expr< Genarg.rawwit_ref >>
   | SortArgType -> <:expr< Genarg.rawwit_sort >>
   | ConstrArgType -> <:expr< Genarg.rawwit_constr >>
   | ConstrMayEvalArgType -> <:expr< Genarg.rawwit_constr_may_eval >>
   | QuantHypArgType -> <:expr< Genarg.rawwit_quant_hyp >>
-  | TacticArgType -> <:expr< Genarg.rawwit_tactic >>
   | RedExprArgType -> <:expr< Genarg.rawwit_red_expr >>
-  | OpenConstrArgType -> <:expr< Genarg.rawwit_open_constr >>
-  | CastedOpenConstrArgType -> <:expr< Genarg.rawwit_casted_open_constr >>
+  | OpenConstrArgType b -> <:expr< Genarg.rawwit_open_constr_gen $mlexpr_of_bool b$ >>
   | ConstrWithBindingsArgType -> <:expr< Genarg.rawwit_constr_with_bindings >>
   | BindingsArgType -> <:expr< Genarg.rawwit_bindings >>
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >>
@@ -52,16 +49,14 @@ let rec make_globwit loc = function
   | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >>
   | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >>
   | IdentArgType -> <:expr< Genarg.globwit_ident >>
-  | HypArgType -> <:expr< Genarg.globwit_var >>
+  | VarArgType -> <:expr< Genarg.globwit_var >>
   | RefArgType -> <:expr< Genarg.globwit_ref >>
   | QuantHypArgType -> <:expr< Genarg.globwit_quant_hyp >>
   | SortArgType -> <:expr< Genarg.globwit_sort >>
   | ConstrArgType -> <:expr< Genarg.globwit_constr >>
   | ConstrMayEvalArgType -> <:expr< Genarg.globwit_constr_may_eval >>
-  | TacticArgType -> <:expr< Genarg.globwit_tactic >>
   | RedExprArgType -> <:expr< Genarg.globwit_red_expr >>
-  | OpenConstrArgType -> <:expr< Genarg.globwit_open_constr >>
-  | CastedOpenConstrArgType -> <:expr< Genarg.globwit_casted_open_constr >>
+  | OpenConstrArgType b -> <:expr< Genarg.globwit_open_constr_gen $mlexpr_of_bool b$ >>
   | ConstrWithBindingsArgType -> <:expr< Genarg.globwit_constr_with_bindings >>
   | BindingsArgType -> <:expr< Genarg.globwit_bindings >>
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >>
@@ -79,16 +74,14 @@ let rec make_wit loc = function
   | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >>
   | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >>
   | IdentArgType -> <:expr< Genarg.wit_ident >>
-  | HypArgType -> <:expr< Genarg.wit_var >>
+  | VarArgType -> <:expr< Genarg.wit_var >>
   | RefArgType -> <:expr< Genarg.wit_ref >>
   | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >>
   | SortArgType -> <:expr< Genarg.wit_sort >>
   | ConstrArgType -> <:expr< Genarg.wit_constr >>
   | ConstrMayEvalArgType -> <:expr< Genarg.wit_constr_may_eval >>
-  | TacticArgType -> <:expr< Genarg.wit_tactic >>
   | RedExprArgType -> <:expr< Genarg.wit_red_expr >>
-  | OpenConstrArgType -> <:expr< Genarg.wit_open_constr >>
-  | CastedOpenConstrArgType -> <:expr< Genarg.wit_casted_open_constr >>
+  | OpenConstrArgType b -> <:expr< Genarg.wit_open_constr_gen $mlexpr_of_bool b$ >>
   | ConstrWithBindingsArgType -> <:expr< Genarg.wit_constr_with_bindings >>
   | BindingsArgType -> <:expr< Genarg.wit_bindings >>
   | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >>
@@ -105,7 +98,8 @@ let make_act loc act pil =
     | Some (p, t) :: tl ->
 	<:expr<
           Gramext.action 
-            (fun $lid:p$ -> let _ = in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
+            (fun $lid:p$ ->
+               let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
         >> in
   make (List.rev pil)
 
@@ -113,22 +107,34 @@ let make_rule loc (prods,act) =
   let (symbs,pil) = List.split prods in
   <:expr< ($mlexpr_of_list (fun x -> x) symbs$,$make_act loc act pil$) >>
 
-let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl =
-  let interp = match f with
-    | None -> <:expr< Tacinterp.interp_genarg >>
-    | Some f -> <:expr< $lid:f$>> in
-  let glob = match g with
-    | None -> <:expr< Tacinterp.intern_genarg >>
-    | Some f -> <:expr< $lid:f$>> in
-  let substitute = match h with
-    | None -> <:expr< Tacinterp.subst_genarg >>
-    | Some f -> <:expr< $lid:f$>> in
+let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl =
   let rawtyp, rawpr = match rawtyppr with
     | None -> typ,pr
     | Some (t,p) -> t,p in
   let globtyp, globpr = match globtyppr with
     | None -> typ,pr
     | Some (t,p) -> t,p in
+  let glob = match g with
+    | None ->
+	<:expr< fun e x ->
+          out_gen $make_globwit loc typ$
+            (Tacinterp.intern_genarg e
+               (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >>
+    | Some f -> <:expr< $lid:f$>> in
+  let interp = match f with
+    | None -> 
+	<:expr< fun ist gl x ->
+          out_gen $make_wit loc typ$
+            (Tacinterp.interp_genarg ist gl
+               (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
+    | Some f -> <:expr< $lid:f$>> in
+  let substitute = match h with
+    | None -> 
+	<:expr< fun s x ->
+          out_gen $make_globwit loc globtyp$
+	    (Tacinterp.subst_genarg s
+               (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
+    | Some f -> <:expr< $lid:f$>> in
   let se = mlexpr_of_string s in
   let wit = <:expr< $lid:"wit_"^s$ >> in
   let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
@@ -141,36 +147,22 @@ let declare_tactic_argument for_v8 loc s typ pr f g h rawtyppr globtyppr cl =
       value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
       Tacinterp.add_interp_genarg $se$
         ((fun e x ->
-          (in_gen $globwit$
-             (out_gen $make_globwit loc typ$
-          	($glob$ e
-         	  (in_gen $make_rawwit loc rawtyp$
-	             (out_gen $rawwit$ x)))))),
+          (Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))),
         (fun ist gl x ->
-          (in_gen $wit$
-             (out_gen $make_wit loc typ$
-          	($interp$ ist gl
-         	  (in_gen $make_globwit loc rawtyp$
-	             (out_gen $globwit$ x)))))),
+          (Genarg.in_gen $wit$ ($interp$ ist gl (out_gen $globwit$ x)))),
         (fun subst x ->
-          (in_gen $globwit$
-             (out_gen $make_globwit loc typ$
-          	($substitute$ subst
-         	  (in_gen $make_globwit loc rawtyp$
-	             (out_gen $globwit$ x)))))));
+          (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x)))));
       Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None 
         [(None, None, $rules$)];
       Pptactic.declare_extra_genarg_pprule
-        $mlexpr_of_bool for_v8$
         ($rawwit$, $lid:rawpr$)
         ($globwit$, $lid:globpr$)
         ($wit$, $lid:pr$);
     end
   >>
 
-let declare_vernac_argument for_v8 loc s cl =
+let declare_vernac_argument loc s cl =
   let se = mlexpr_of_string s in
-  let typ = ExtraArgType s in
   let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
   let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
   <:str_item<
@@ -184,38 +176,6 @@ let declare_vernac_argument for_v8 loc s cl =
 
 open Vernacexpr
 open Pcoq
-
-let rec interp_entry_name loc s =
-  let l = String.length s in
-  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in
-    List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
-  else if l > 5 & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in
-    List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
-  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in
-    OptArgType t, <:expr< Gramext.Sopt $g$ >>
-  else 
-    let t, se =
-      match Pcoq.entry_type (Pcoq.get_univ "prim") s with
-	| Some _ as x -> x, <:expr< Prim. $lid:s$ >>
-	| None -> 
-      match Pcoq.entry_type (Pcoq.get_univ "constr") s with
-	| Some _ as x -> x, <:expr< Constr. $lid:s$ >>
-	| None -> 
-      match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
-	| Some _ as x -> x, <:expr< Tactic. $lid:s$ >>
-	| None -> None, <:expr< $lid:s$ >> in
-    let t =
-      match t with
-	| Some t -> t
-	| None ->
-(*	    Pp.warning_with Pp_control.err_ft
-            ("Unknown primitive grammar entry: "^s);*)
-	    ExtraArgType s
-    in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
-
 open Pcaml
 
 EXTEND
@@ -238,45 +198,22 @@ EXTEND
         "END" ->
 	  if String.capitalize s = s then
 	    failwith "Argument entry names must be lowercase";
-         declare_tactic_argument true loc s typ pr f g h rawtyppr globtyppr l
+         declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr l
       | "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
         OPT "|"; l = LIST1 argrule SEP "|";
         "END" ->
 	  if String.capitalize s = s then
 	    failwith "Argument entry names must be lowercase";
-         declare_vernac_argument true loc s l
-      | "V7"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
-        "TYPED"; "AS"; typ = argtype;
-        "PRINTED"; "BY"; pr = LIDENT;
-        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
-        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
-        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ];
-        rawtyppr =
-          OPT [ "GLOB_TYPED"; "AS"; t = argtype; 
-                "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
-        globtyppr =
-          OPT [ "GLOB_TYPED"; "AS"; t = argtype; 
-                "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ];
-        OPT "|"; l = LIST1 argrule SEP "|";
-        "END" ->
-	  if String.capitalize s = s then
-	    failwith "Argument entry names must be lowercase";
-         declare_tactic_argument false loc s typ pr f g h rawtyppr globtyppr l
-      | "V7"; "VERNAC"; "ARGUMENT"; "EXTEND"; s = [ UIDENT | LIDENT ];
-        OPT "|"; l = LIST1 argrule SEP "|";
-        "END" ->
-	  if String.capitalize s = s then
-	    failwith "Argument entry names must be lowercase";
-         declare_vernac_argument false loc s l ] ]
+         declare_vernac_argument loc s l ] ]
   ;
   argtype:
-    [ "2" RIGHTA
-      [ e1 = argtype; "*"; e2 = NEXT -> PairArgType (e1, e2) ]
+    [ "2" 
+      [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ]
     | "1"
       [ e = argtype; LIDENT "list" -> List0ArgType e
       | e = argtype; LIDENT "option" -> OptArgType e ]
     | "0"
-      [ e = LIDENT -> fst (interp_entry_name loc e) 
+      [ e = LIDENT -> fst (interp_entry_name loc e "")
       | "("; e = argtype; ")" -> e ] ]
   ;
   argrule:
@@ -284,11 +221,14 @@ EXTEND
   ;
   genarg:
     [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name loc e in (g, Some (s,t))
+        let t, g = interp_entry_name loc e "" in (g, Some (s,t))
+      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
+        let t, g = interp_entry_name loc e sep in (g, Some (s,t))
       | s = STRING ->
 	  if String.length s > 0 && Util.is_letter s.[0] then
 	    Pcoq.lexer.Token.using ("", s);
-        (<:expr< (Gramext.Stoken (Extend.terminal $str:s$)) >>, None)
+        (<:expr< (Gramext.Stoken (Lexer.terminal $str:s$)) >>, None)
     ] ]
   ;
   END
+
diff --git a/parsing/ast.ml b/parsing/ast.ml
deleted file mode 100755
index b2a30f9c..00000000
--- a/parsing/ast.ml
+++ /dev/null
@@ -1,600 +0,0 @@
-(************************************************************************)
-(*  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: ast.ml,v 1.29.2.1 2004/07/16 19:30:37 herbelin Exp $ *)
-
-open Pp
-open Util
-open Names
-open Libnames
-open Coqast
-open Topconstr
-open Genarg
-
-let isMeta s = String.length s <> 0 & s.[0]='$'
-
-let loc = function
-  | Node (loc,_,_) -> loc
-  | Nvar (loc,_) -> loc
-  | Nmeta (loc,_) -> loc
-  | Slam (loc,_,_) -> loc
-  | Smetalam (loc,_,_) -> loc
-  | Num (loc,_) -> loc
-  | Id (loc,_) -> loc
-  | Str (loc,_) -> loc
-  | Path (loc,_) -> loc
-  | Dynamic (loc,_) -> loc
-
-(* patterns of ast *)
-type astpat =
-  | Pquote of t
-  | Pmeta of string * tok_kind
-  | Pnode of string * patlist
-  | Pslam of identifier option * astpat
-  | Pmeta_slam of string * astpat
-
-and patlist =
-  | Pcons of astpat * patlist
-  | Plmeta of string
-  | Pnil
-
-and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist
-
-type pat =
-  | AstListPat of patlist
-  | PureAstPat of astpat
-
-(* building a node with dummy location *)
-
-let ope(op,l) = Node(dummy_loc,op,l)
-let slam(idl,b) = Slam(dummy_loc,idl,b)
-let ide s = Id(dummy_loc,s)
-let nvar s = Nvar(dummy_loc,s)
-let num n = Num(dummy_loc,n)
-let string s = Str(dummy_loc,s)
-let path sl = Path(dummy_loc,sl)
-let dynamic d = Dynamic(dummy_loc,d)
-
-let rec set_loc loc = function
-  | Node(_,op,al) -> Node(loc, op, List.map (set_loc loc) al)
-  | Slam(_,idl,b) -> Slam(loc,idl, set_loc loc b)
-  | Smetalam(_,idl,b) -> Smetalam(loc,idl, set_loc loc b)
-  | Nvar(_,s) -> Nvar(loc,s)
-  | Nmeta(_,s) -> Nmeta(loc,s)
-  | Id(_,s) -> Id(loc,s)
-  | Str(_,s) -> Str(loc,s)
-  | Num(_,s) -> Num(loc,s)
-  | Path(_,sl) -> Path(loc,sl)
-  | Dynamic(_,d) -> Dynamic(loc,d)
-
-let path_section loc sp = Coqast.Path(loc, sp)
-
-let section_path sp = sp
-
-(* ast destructors *)
-let num_of_ast = function
-  | Num(_,n) -> n
-  | ast -> invalid_arg_loc (loc ast, "Ast.num_of_ast")
-
-let nvar_of_ast = function
-  | Nvar(_,s) -> s
-  | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast")
-
-let meta_of_ast = function
-  | Nmeta(_,s) -> s
-  | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast")
-
-let id_of_ast =  function
-  | Id(_,s) -> s
-  | ast -> invalid_arg_loc (loc ast, "Ast.nvar_of_ast")
-
-(* semantic actions of grammar rules *)
-type act =
-  | Act of constr_expr
-  | ActCase of act * (pat * act) list
-  | ActCaseList of act * (pat * act) list
-
-(* values associated to variables *)
-(*
-type typed_ast =
-  | AstListNode of Coqast.t list
-  | PureAstNode of Coqast.t
-*)
-type typed_ast =
-  | AstListNode of Coqast.t list
-  | PureAstNode of Coqast.t
-
-type ast_action_type = ETast | ETastl
-
-type dynamic_grammar =
-  | ConstrNode of constr_expr
-  | CasesPatternNode of cases_pattern_expr
-
-type grammar_action =
-  | SimpleAction of loc * dynamic_grammar
-  | CaseAction of
-      loc * grammar_action * ast_action_type * (t list * grammar_action) list
-
-type env = (string * typed_ast) list
-
-let string_of_dirpath = function
-  | [] -> "<empty>"
-  | sl ->
-      String.concat "." (List.map string_of_id (List.rev sl))
-
-let pr_id id = str (string_of_id id)
-
-let print_kn kn =
-  let (mp,dp,l) = repr_kn kn in
-  let dpl = repr_dirpath dp in
-  str (string_of_mp mp) ++ str "." ++
-  prlist_with_sep (fun _ -> str".") pr_id dpl ++
-  str (string_of_label l)
-
-(* Pretty-printing *)
-let rec print_ast ast =
-  match ast with
-    | Num(_,n) -> int n
-    | Str(_,s) -> qs s
-    | Path(_,sl) -> print_kn sl
-    | Id (_,s) -> str "{" ++ str s ++ str "}"
-    | Nvar(_,s) -> pr_id s
-    | Nmeta(_,s) -> str s
-    | Node(_,op,l) ->
-        hov 3 (str "(" ++ str op ++ spc () ++ print_astl l ++ str ")")
-    | Slam(_,None,ast) -> hov 1 (str "[<>]" ++ print_ast ast)
-    | Slam(_,Some x,ast) ->
-        hov 1
-          (str "[" ++ pr_id x ++ str "]" ++ cut () ++ 
-	   print_ast ast)
-    | Smetalam(_,id,ast) -> hov 1 (str id ++ print_ast ast)
-    | Dynamic(_,d) ->
-	hov 0 (str "<dynamic: " ++ str (Dyn.tag d) ++ str ">")
-
-and print_astl astl =
-  prlist_with_sep pr_spc print_ast astl
-
-let print_ast_cast = function
-  | Tany -> (mt ())
-  | Tvar -> (str":var")
-  | Tid -> (str":id")
-  | Tstr -> (str":str")
-  | Tpath -> (str":path")
-  | Tnum -> (str":num")
-  | Tlist -> (str":list")
-
-let rec print_astpat = function
-  | Pquote ast -> 
-      str"'" ++ print_ast ast 
-  | Pmeta(s,tk) -> 
-      str s ++ print_ast_cast tk 
-  | Pmeta_slam(s,b) ->
-      hov 1 (str "[" ++ str s ++ str"]" ++ cut () ++ print_astpat b)
-  | Pnode(op,al) ->
-      hov 2 (str"("  ++ str op ++ spc () ++ print_astlpat al ++ str")" )
-  | Pslam(None,b) -> 
-      hov 1 (str"[<" ++ cut () ++ print_astpat b)
-  | Pslam(Some id,b) ->
-      hov 1
-        (str"[" ++ str(string_of_id id) ++ str"]" ++ cut () ++ print_astpat b)
-
-and print_astlpat = function
-  | Pnil -> mt ()
-  | Pcons(h,Pnil) -> hov 1 (print_astpat h)
-  | Pcons(h,t) -> hov 1 (print_astpat h ++ spc () ++ print_astlpat t)
-  | Plmeta(s) -> str"| " ++ str s
-
-
-let print_val = function
-  | PureAstNode a -> print_ast a
-  | AstListNode al -> 
-      hov 1 (str"[" ++ prlist_with_sep pr_spc print_ast al ++ str"]")
-
-(* Ast values environments *)
-
-let grammar_type_error (loc,s) =
-  anomaly_loc (loc,s,(str"grammar type error: " ++ str s))
-
-
-(* Coercions enforced by the user *)
-let check_cast loc a k =
-  match (k,a) with
-    | (Tany, _) -> ()
-    | (Tid, Id _) -> ()
-    | (Tvar, Nvar _) -> ()
-    | (Tpath, Path _) -> ()
-    | (Tstr, Str _) -> ()
-    | (Tnum, Num _) -> ()
-    | (Tlist, _) -> grammar_type_error (loc,"Ast.cast_val")
-    | _ -> user_err_loc (loc,"Ast.cast_val",
-                         (str"cast _" ++ print_ast_cast k ++ str"failed"))
-
-let rec coerce_to_var = function
-  | Nvar(_,id) as var -> var
-  | Nmeta(_,id) as var -> var
-  | Node(_,"QUALID",[Nvar(_,id) as var]) -> var
-  | ast -> user_err_loc
-        (loc ast,"Ast.coerce_to_var",
-         (str"This expression should be a simple identifier"))
-
-let coerce_to_id_ast a = match coerce_to_var a with
-  | Nvar (_,id) -> id
-  | ast -> user_err_loc
-        (loc ast,"Ast.coerce_to_id",
-         str"This expression should be a simple identifier")
-
-let coerce_to_id = function
-  | CRef (Ident (loc,id)) -> (loc,id)
-  | a -> user_err_loc
-        (constr_loc a,"Ast.coerce_to_id",
-         str"This expression should be a simple identifier")
-
-let coerce_reference_to_id = function
-  | Ident (_,id) -> id
-  | Qualid (loc,_) ->
-      user_err_loc (loc, "Ast.coerce_reference_to_id",
-        str"This expression should be a simple identifier")
-
-let coerce_global_to_id = coerce_reference_to_id
-
-(* Pattern-matching on ast *)
-
-let env_assoc_value loc v env =
-  try 
-    List.assoc v env
-  with Not_found -> 
-    anomaly_loc
-      (loc,"Ast.env_assoc_value",
-       (str"metavariable " ++ str v ++ str" is unbound"))
-
-let env_assoc_list sigma (loc,v) =
-  match env_assoc_value loc v sigma with
-    | AstListNode al -> al
-    | PureAstNode a -> [a]
-
-let env_assoc sigma k (loc,v) =
-  match env_assoc_value loc v sigma with
-    | PureAstNode a -> check_cast loc a k; a
-    | _ -> grammar_type_error (loc,"Ast.env_assoc: "^v^" is an ast list")
-
-let env_assoc_nvars sigma (dloc,v) =
-  match env_assoc_value dloc v sigma with
-    | AstListNode al -> List.map coerce_to_id_ast al
-    | PureAstNode ast -> [coerce_to_id_ast ast]
-
-let build_lams dloc idl ast =
-  List.fold_right (fun id lam -> Slam(dloc,Some id,lam)) idl ast
-
-(* Alpha-conversion *)
-	  
-let rec alpha_var id1 id2 = function
-  | (i1,i2)::_ when i1=id1 -> i2 = id2
-  | (i1,i2)::_ when i2=id2 -> i1 = id1
-  | _::idl -> alpha_var id1 id2 idl
-  | [] -> id1 = id2
-
-let rec alpha alp a1 a2 =
-  match (a1,a2) with
-    | (Node(_,op1,tl1),Node(_,op2,tl2)) ->
-        (op1 = op2) & (List.length tl1 = List.length tl2)
-        & (List.for_all2 (alpha alp) tl1 tl2)
-    | (Nvar(_,id1),Nvar(_,id2)) -> alpha_var id1 id2 alp
-    | (Slam(_,None,body1),Slam(_,None,body2)) -> alpha alp body1 body2
-    | (Slam(_,Some s1,body1),Slam(_,Some s2,body2)) ->
-        alpha ((s1,s2)::alp) body1 body2
-    | (Id(_,s1),Id(_,s2)) -> s1=s2
-    | (Str(_,s1),Str(_,s2)) -> s1=s2
-    | (Num(_,n1),Num(_,n2)) -> n1=n2
-    | (Path(_,sl1),Path(_,sl2)) -> sl1=sl2
-    | ((Smetalam _ | Nmeta _ | Dynamic _), _) -> false
-    | (_, (Smetalam _ | Nmeta _ | Dynamic _)) -> false
-    | _ -> false
-
-let alpha_eq (a1,a2)= alpha [] a1 a2
-
-let alpha_eq_val (x,y) = x = y
-(*
-let alpha_eq_val = function
-  | (Vast a1, Vast a2) -> alpha_eq (a1,a2)
-  | (Vastlist al1, Vastlist al2) ->
-      (List.length al1 = List.length al2)
-      & List.for_all2 (fun x y -> alpha_eq (x,y)) al1 al2
-  | _ ->  false
-*)
-
-exception No_match of string
-
-let no_match_loc (loc,s) = Stdpp.raise_with_loc loc (No_match s)
-
-(* Binds value v to variable var. If var is already bound, checks if
-   its value is alpha convertible with v. This allows non-linear patterns.
-
-   Important note: The Metavariable $_ is a special case; it cannot be
-   bound, which is like _ in the ML matching. *)
-
-let bind_env sigma var v =
-  if var = "$_" then 
-    sigma
-  else
-    try
-      let vvar = List.assoc var sigma in
-      if alpha_eq_val (v,vvar) then sigma
-      else raise (No_match "Ast.bind_env: values do not match")
-    with Not_found -> 
-      (var,v)::sigma
-
-let bind_env_ast sigma var ast =
-  try 
-    bind_env sigma var (PureAstNode ast)
-  with e -> 
-    Stdpp.raise_with_loc (loc ast) e
-
-let alpha_define sigma loc ps s =
-  try 
-    let _ = List.assoc ps sigma in sigma
-  with Not_found ->
-    if ps = "$_" then sigma else (ps, PureAstNode(Nvar(loc,s)))::sigma
-
-
-(* Match an ast with an ast pattern. Returns the new environnement. *)
-
-let rec amatch alp sigma spat ast =
-  match (spat,ast) with
-    | (Pquote a, _) ->
-        if alpha alp a ast then 
-	  sigma
-        else 
-	  no_match_loc (loc ast,"quote does not match")
-    | (Pmeta(pv,Tany), _) -> bind_env_ast sigma pv ast
-    | (Pmeta(pv,Tvar), Nvar _) -> bind_env_ast sigma pv ast
-    | (Pmeta(pv,Tid), Id _) -> bind_env_ast sigma pv ast
-    | (Pmeta(pv,Tnum), Num _) -> bind_env_ast sigma pv ast
-    | (Pmeta(pv,Tstr), Str _) -> bind_env_ast sigma pv ast
-    | (Pmeta(pv,Tpath), Path _) -> bind_env_ast sigma pv ast
-    | (Pmeta(pv,Tlist),_) -> grammar_type_error (loc ast,"Ast.amatch")
-    | (Pmeta_slam(pv,pb), Slam(loc, Some s, b)) ->
-        amatch alp (bind_env_ast sigma pv (Nvar(loc,s))) pb b
-    | (Pmeta_slam(pv,pb), Slam(loc, None, b)) ->
-        amatch alp (bind_env_ast sigma pv (Nvar(loc,id_of_string "_"))) pb b
-    | (Pmeta_slam(pv,pb), Smetalam(loc, s, b)) ->
-	anomaly "amatch: match a pattern with an open ast"
-    | (Pnode(nodp,argp), Node(loc,op,args)) when nodp = op ->
-        (try amatchl alp sigma argp args
-         with e -> Stdpp.raise_with_loc loc e)
-    | (Pslam(None,bp), Slam(_,None,b)) -> amatch alp sigma bp b
-    | (Pslam(Some ps,bp), Slam(_,Some s,b)) -> amatch ((ps,s)::alp) sigma bp b
-    | _ -> no_match_loc (loc ast, "Ast.amatch")
-
-and amatchl alp sigma spatl astl =
-  match (spatl,astl) with
-    | (Pnil, []) -> sigma
-    | (Pcons(pat,patl), ast::asttl) ->
-        amatchl alp (amatch alp sigma pat ast) patl asttl
-    | (Plmeta pv, _) -> bind_env sigma pv (AstListNode astl)
-    | _ -> raise (No_match "Ast.amatchl")
-
-let ast_match = amatch []
-
-let typed_ast_match env p a = match (p,a) with
-  | PureAstPat p, PureAstNode a -> amatch [] env p a
-  | AstListPat pl, AstListNode al -> amatchl [] env pl al
-  | _ -> failwith "Ast.typed_ast_match: TODO"
-
-let astl_match = amatchl []
-
-let first_match pat_of_fun env ast sl =
-  let rec aux = function
-    | [] -> None
-    | h::t ->
-        (try Some (h, ast_match env (pat_of_fun h) ast)
-         with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t)
-  in 
-  aux sl
-
-let find_all_matches pat_of_fun env ast sl =
-  let rec aux = function
-    | [] -> []
-    | (h::t) ->
-        let l = aux t in
-        (try (h, ast_match env (pat_of_fun h) ast)::l
-         with (No_match _| Stdpp.Exc_located (_,No_match _)) -> l)
-  in 
-  aux sl
-
-let first_matchl patl_of_fun env astl sl =
-  let rec aux = function
-    | [] -> None
-    | (h::t) ->
-        (try Some (h, astl_match env (patl_of_fun h) astl)
-         with (No_match _| Stdpp.Exc_located (_,No_match _)) -> aux t)
-  in 
-  aux sl
-    
-let bind_patvar env loc v etyp =
-  try
-    if List.assoc v env = etyp then 
-      env
-    else 
-      user_err_loc
-	(loc,"Ast.bind_patvar",
-	 (str"variable " ++ str v ++
-            str" is bound several times with different types"))
-  with Not_found -> 
-    if v="$_" then env else (v,etyp)::env
-      
-let make_astvar env loc v cast =
-  let env' = bind_patvar env loc v ETast in
-  (Pmeta(v,cast), env')
-
-(* Note: no metavar in operator position. necessary ? *)
-let rec pat_of_ast env ast =
-  match ast with
-    | Nmeta(loc,pv) -> make_astvar env loc pv Tany
-(* Obsolète
-    | Id(loc,pv) when isMeta pv -> make_astvar env loc pv Tid
-*)
-    | Smetalam(loc,s,a) ->
-        let senv = bind_patvar env loc s ETast in
-        let (pa,env') = pat_of_ast senv a in
-        (Pmeta_slam(s, pa), env')
-    | Node(_,"$VAR",[Nmeta(loc,pv)]) ->
-        make_astvar env loc pv Tvar
-    | Node(_,"$ID",[Nmeta(loc,pv)]) ->
-        make_astvar env loc pv Tid
-    | Node(_,"$NUM",[Nmeta(loc,pv)]) ->
-        make_astvar env loc pv Tnum
-    | Node(_,"$STR",[Nmeta(loc,pv)]) ->
-        make_astvar env loc pv Tstr
-    | Node(_,"$PATH",[Nmeta(loc,pv)]) ->
-        make_astvar env loc pv Tpath
-    | Node(_,"$QUOTE",[qast]) -> (Pquote (set_loc dummy_loc qast), env)
-
-   (* This may occur when the meta is not textual but bound by coerce_to_id*)
-    | Slam(loc,Some id,b) when isMeta (string_of_id id) ->
-	let s = string_of_id id in
-        let senv = bind_patvar env loc s ETast in
-        let (pb,env') = pat_of_ast senv b in
-        (Pmeta_slam(s, pb), env')
-
-    | Slam(_,os,b) ->
-        let (pb,env') = pat_of_ast env b in
-        (Pslam(os,pb), env')
-    | Node(loc,op,_) when isMeta op ->
-        user_err_loc(loc,"Ast.pat_of_ast",
-                     (str"no patvar in operator position."))
-    | Node(_,op,args) ->
-        let (pargs, env') = patl_of_astl env args in
-        (Pnode(op,pargs), env')
-(* Compatibility with new parsing mode *)
-    | Nvar(loc,id) when (string_of_id id).[0] = '$' -> make_astvar env loc (string_of_id id) Tany
-    | (Path _|Num _|Id _|Str _ |Nvar _) -> (Pquote (set_loc dummy_loc ast), env)
-    | Dynamic(loc,_) ->
-        invalid_arg_loc(loc,"pat_of_ast: dynamic")
-	  
-and patl_of_astl env astl =
-  match astl with
-    | [Node(_,"$LIST",[Nmeta(loc,pv)])] ->
-        let penv = bind_patvar env loc pv ETastl in
-        (Plmeta pv, penv)
-    | [] -> (Pnil,env)
-    | ast::asttl ->
-        let (p1,env1) = pat_of_ast env ast in
-        let (ptl,env2) = patl_of_astl env1 asttl in
-        (Pcons (p1,ptl), env2)
-
-type entry_env = (string * ast_action_type) list
-	
-let to_pat = pat_of_ast
-
-(* Substitution *)
-
-(* Locations in quoted ast are wrong (they refer to the right hand
-   side of a grammar rule). A default location dloc is used whenever
-   we create an ast constructor. Locations in the binding list are trusted. *)
-
-(* For old ast printer *)
-let rec pat_sub dloc sigma pat =
-  match pat with
-    | Pmeta(pv,c) -> env_assoc sigma c (dloc,pv) 
-    | Pmeta_slam(pv,p) ->
-        let idl = env_assoc_nvars sigma (dloc,pv) in
-        build_lams dloc idl (pat_sub dloc sigma p)
-    | Pquote a -> set_loc dloc a
-    | Pnode(op,pl) -> Node(dloc, op, patl_sub dloc sigma pl)
-    | Pslam(os,p) -> Slam(dloc, os, pat_sub dloc sigma p)
-	  
-and patl_sub dloc sigma pl =
-  match pl with
-    | Pnil -> 
-	[]
-    | Plmeta pv -> 
-	env_assoc_list sigma (dloc,pv)
-    | Pcons(Pmeta(pv,Tlist), ptl) ->
-        (env_assoc_list sigma (dloc,pv))@(patl_sub dloc sigma ptl)
-    | Pcons(p1,ptl) -> 
-	(pat_sub dloc sigma p1)::(patl_sub dloc sigma ptl)
-
-(* Converting and checking free meta-variables *)
-
-(* For old ast printer *)
-let type_of_meta env loc pv =
-  try 
-    List.assoc pv env
-  with Not_found ->
-    user_err_loc (loc,"Ast.type_of_meta",
-                  (str"variable " ++ str pv ++ str" is unbound"))
-
-(* For old ast printer *)
-let check_ast_meta env loc pv =
-  match type_of_meta env loc pv with
-    | ETast -> ()
-    | _ ->
-	user_err_loc (loc,"Ast.check_ast_meta",
-                      (str"variable " ++ str pv ++ str" is not of ast type"))
-
-(* For old ast printer *)
-let rec val_of_ast env = function
-  | Nmeta(loc,pv) -> 
-      check_ast_meta env loc pv;
-      Pmeta(pv,Tany)
-  | Node(_,"$QUOTE",[qast]) -> Pquote (set_loc dummy_loc qast)
-  | Smetalam(loc,s,a) ->
-    let _ = type_of_meta env loc s in (* ids are coerced to id lists *)
-    Pmeta_slam(s, val_of_ast env a)
-  | (Path _|Num _|Id _|Str _|Nvar _ as ast) -> Pquote (set_loc dummy_loc ast)
-  | Slam(_,os,b) -> Pslam(os, val_of_ast env b)
-  | Node(loc,op,_) when isMeta op ->
-      user_err_loc(loc,"Ast.val_of_ast",
-                   (str"no patvar in operator position."))
-  | Node(_,op,args) -> Pnode(op, vall_of_astl env args)
-  | Dynamic(loc,_) ->
-      invalid_arg_loc(loc,"val_of_ast: dynamic")
-	  
-and vall_of_astl env = function
-  | (Node(loc,"$LIST",[Nmeta(locv,pv)]))::asttl ->
-      if type_of_meta env locv pv = ETastl then
-	if asttl = [] then 
-	  Plmeta pv
-	else 
-	  Pcons(Pmeta(pv,Tlist), vall_of_astl env asttl)
-      else
-	user_err_loc
-	  (loc,"Ast.vall_of_astl",
-	    str"variable " ++ str pv ++ str" is not a List")
-  | ast::asttl -> Pcons (val_of_ast env ast, vall_of_astl env asttl)
-  | [] -> Pnil
-
-(* For old ast printer *)
-let rec occur_var_ast s = function
-  | Node(_,"QUALID",_::_::_) -> false
-  | Node(_,"QUALID",[Nvar(_,s2)]) -> s = s2
-  | Nvar(_,s2) -> s = s2
-  | Node(loc,op,args) -> List.exists (occur_var_ast s) args
-  | Smetalam _ | Nmeta _ -> anomaly "occur_var: metas should not occur here"
-  | Slam(_,sopt,body) -> (Some s <> sopt) & occur_var_ast s body
-  | Id _ | Str _ | Num _ | Path _ -> false
-  | Dynamic _ -> (* Hum... what to do here *) false
-
-
-(**********************************************************************)
-(* Object substitution in modules *)
-
-let rec subst_astpat subst = function
-  | Pquote a -> Pquote (subst_ast subst a)
-  | Pmeta _ as p -> p
-  | Pnode (s,pl) -> Pnode (s,subst_astpatlist subst pl)
-  | Pslam (ido,p) -> Pslam (ido,subst_astpat subst p)
-  | Pmeta_slam (s,p) -> Pmeta_slam (s,subst_astpat subst p)
-
-and subst_astpatlist subst = function
-  | Pcons (p,pl) -> Pcons (subst_astpat subst p, subst_astpatlist subst pl)
-  | (Plmeta _ | Pnil) as pl -> pl
-
-let subst_pat subst = function
-  | AstListPat pl -> AstListPat (subst_astpatlist subst pl)
-  | PureAstPat p -> PureAstPat (subst_astpat subst p)
diff --git a/parsing/ast.mli b/parsing/ast.mli
deleted file mode 100755
index 7bc0b607..00000000
--- a/parsing/ast.mli
+++ /dev/null
@@ -1,123 +0,0 @@
-(************************************************************************)
-(*  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: ast.mli,v 1.17.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
-
-(*i*)
-open Pp
-open Util
-open Names
-open Libnames
-open Coqast
-open Topconstr
-open Genarg
-(*i*)
-
-(* Abstract syntax trees. *)
-
-val loc : Coqast.t -> loc
-
-(* ast constructors with dummy location *)
-val ope : string * Coqast.t list -> Coqast.t
-val slam : identifier option * Coqast.t -> Coqast.t
-val nvar : identifier -> Coqast.t
-val ide : string -> Coqast.t
-val num : int -> Coqast.t
-val string : string -> Coqast.t
-val path : kernel_name -> Coqast.t
-val dynamic : Dyn.t -> Coqast.t
-
-val set_loc : loc -> Coqast.t -> Coqast.t
-
-val path_section : loc -> kernel_name -> Coqast.t
-val section_path : kernel_name -> kernel_name
-
-(* ast destructors *)
-val num_of_ast : Coqast.t -> int
-val id_of_ast : Coqast.t -> string
-val nvar_of_ast : Coqast.t -> identifier
-val meta_of_ast : Coqast.t -> string
-
-(* patterns of ast *)
-type astpat =
-  | Pquote of t
-  | Pmeta of string * tok_kind
-  | Pnode of string * patlist
-  | Pslam of identifier option * astpat
-  | Pmeta_slam of string * astpat
-
-and patlist =
-  | Pcons of astpat * patlist
-  | Plmeta of string
-  | Pnil
-
-and tok_kind = Tnum | Tid | Tstr | Tpath | Tvar | Tany | Tlist
-
-type pat =
-  | AstListPat of patlist
-  | PureAstPat of astpat
-
-(* semantic actions of grammar rules *)
-type act =
-  | Act of constr_expr
-  | ActCase of act * (pat * act) list
-  | ActCaseList of act * (pat * act) list
-
-(* values associated to variables *)
-type typed_ast =
-  | AstListNode of Coqast.t list
-  | PureAstNode of Coqast.t
-
-type ast_action_type = ETast | ETastl
-
-type dynamic_grammar =
-  | ConstrNode of constr_expr
-  | CasesPatternNode of cases_pattern_expr
-
-type grammar_action =
-  | SimpleAction of loc * dynamic_grammar
-  | CaseAction of
-      loc * grammar_action * ast_action_type * (t list * grammar_action) list
-
-type env = (string * typed_ast) list
-
-val coerce_to_id : constr_expr -> identifier located
-
-val coerce_global_to_id : reference -> identifier
-val coerce_reference_to_id : reference -> identifier
-
-exception No_match of string
-
-val isMeta : string -> bool
-
-val print_ast : Coqast.t -> std_ppcmds
-val print_astl : Coqast.t list -> std_ppcmds
-val print_astpat : astpat -> std_ppcmds
-val print_astlpat : patlist -> std_ppcmds
-
-(* Meta-syntax operations: matching and substitution *)
-
-type entry_env = (string * ast_action_type) list
-
-val grammar_type_error : loc * string -> 'a
- 
-(* Converting and checking free meta-variables *)
-
-(* For old ast printer *)
-val pat_sub : loc -> env -> astpat -> Coqast.t
-val val_of_ast : entry_env -> Coqast.t -> astpat
-val alpha_eq : Coqast.t * Coqast.t -> bool
-val alpha_eq_val : typed_ast * typed_ast -> bool
-val occur_var_ast : identifier -> Coqast.t -> bool
-val find_all_matches : ('a -> astpat) -> env -> t -> 'a list -> ('a * env) list
-val first_matchl : ('a -> patlist) -> env -> Coqast.t list -> 'a list ->
-  ('a * env) option
-val to_pat : entry_env -> Coqast.t -> (astpat * entry_env)
-
-(* Object substitution in modules *)
-val subst_astpat : Names.substitution -> astpat -> astpat
diff --git a/parsing/coqast.ml b/parsing/coqast.ml
deleted file mode 100644
index 0f447766..00000000
--- a/parsing/coqast.ml
+++ /dev/null
@@ -1,123 +0,0 @@
-(************************************************************************)
-(*  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: coqast.ml,v 1.9.6.1 2004/07/16 19:30:37 herbelin Exp $ *)
-
-(*i*)
-open Util
-open Names
-open Libnames
-(*i*)
-
-type t =
-  | Node of loc * string * t list
-  | Nmeta of loc * string
-  | Nvar of loc * identifier
-  | Slam of loc * identifier option * t
-  | Smetalam of loc * string * t
-  | Num of loc * int
-  | Str of loc * string
-  | Id of loc * string
-  | Path of loc * kernel_name
-  | Dynamic of loc * Dyn.t
-
-type the_coq_ast = t
-
-let subst_meta bl ast =
-  let rec aux = function
-    | Node (_,"META", [Num(_, n)]) -> List.assoc n bl
-    | Node(loc, node_name, args) -> 
-	Node(loc, node_name, List.map aux args)
-    | Slam(loc, var, arg) -> Slam(loc, var, aux arg)
-    | Smetalam(loc, var, arg) -> Smetalam(loc, var, aux arg)
-    | other -> other
-  in 
-  aux ast
-
-let rec collect_metas = function
-  | Node (_,"META", [Num(_, n)]) -> [n]
-  | Node(_, _, args) -> List.concat (List.map collect_metas args)
-  | Slam(loc, var, arg) -> collect_metas arg
-  | Smetalam(loc, var, arg) -> collect_metas arg
-  | _ -> []
-
-(* Hash-consing *)
-module Hloc = Hashcons.Make(
-  struct
-    type t = loc
-    type u = unit
-    let equal (b1,e1) (b2,e2) = b1=b2 & e1=e2
-    let hash_sub () x = x
-    let hash = Hashtbl.hash
-  end)
-
-module Hast = Hashcons.Make(
-  struct
-    type t = the_coq_ast
-    type u = 
-	(the_coq_ast -> the_coq_ast) *
-	((loc -> loc) * (string -> string)
-	 * (identifier -> identifier) * (kernel_name -> kernel_name))
-    let hash_sub (hast,(hloc,hstr,hid,hsp)) = function
-      | Node(l,s,al) -> Node(hloc l, hstr s, List.map hast al)
-      | Nmeta(l,s) -> Nmeta(hloc l, hstr s)
-      | Nvar(l,s) -> Nvar(hloc l, hid s)
-      | Slam(l,None,t) -> Slam(hloc l, None, hast t)
-      | Slam(l,Some s,t) -> Slam(hloc l, Some (hid s), hast t)
-      | Smetalam(l,s,t) -> Smetalam(hloc l, hstr s, hast t)
-      | Num(l,n) -> Num(hloc l, n)
-      | Id(l,s) -> Id(hloc l, hstr s)
-      | Str(l,s) -> Str(hloc l, hstr s)
-      | Path(l,d) -> Path(hloc l, hsp d)
-      | Dynamic(l,d) -> Dynamic(hloc l, d)
-    let equal a1 a2 =
-      match (a1,a2) with
-        | (Node(l1,s1,al1), Node(l2,s2,al2)) ->
-            (l1==l2 & s1==s2 & List.length al1 = List.length al2)
-            & List.for_all2 (==) al1 al2
-        | (Nmeta(l1,s1), Nmeta(l2,s2)) -> l1==l2 & s1==s2
-        | (Nvar(l1,s1), Nvar(l2,s2)) -> l1==l2 & s1==s2
-        | (Slam(l1,None,t1), Slam(l2,None,t2)) -> l1==l2 & t1==t2
-        | (Slam(l1,Some s1,t1), Slam(l2,Some s2,t2)) ->l1==l2 & s1==s2 & t1==t2
-        | (Smetalam(l1,s1,t1), Smetalam(l2,s2,t2)) -> l1==l2 & s1==s2 & t1==t2
-        | (Num(l1,n1), Num(l2,n2)) -> l1==l2 & n1=n2
-        | (Id(l1,s1), Id(l2,s2)) -> l1==l2 & s1==s2
-        | (Str(l1,s1),Str(l2,s2)) -> l1==l2 & s1==s2
-        | (Path(l1,d1), Path(l2,d2)) -> (l1==l2 & d1==d2)
-        | _ -> false
-    let hash = Hashtbl.hash
-  end)
-
-let hcons_ast (hstr,hid,hpath) =
-  let hloc = Hashcons.simple_hcons Hloc.f () in
-  let hast = Hashcons.recursive_hcons Hast.f (hloc,hstr,hid,hpath) in
-  (hast,hloc)
-
-let rec subst_ast subst ast = match ast with
-  | Node (l,s,astl) ->
-      let astl' = Util.list_smartmap (subst_ast subst) astl in
-	if astl' == astl then ast else
-	  Node (l,s,astl')
-  | Slam (l,ido,ast1) ->
-      let ast1' = subst_ast subst ast1 in
-	if ast1' == ast1 then ast else
-	  Slam (l,ido,ast1')
-  | Smetalam (l,s,ast1) ->
-      let ast1' = subst_ast subst ast1 in
-	if ast1' == ast1 then ast else
-	  Smetalam (l,s,ast1')
-  | Path (loc,kn) -> 
-      let kn' = Names.subst_kn subst kn in
-	if kn' == kn then ast else
-	  Path(loc,kn')
-  | Nmeta _
-  | Nvar _ -> ast
-  | Num _
-  | Str _
-  | Id _
-  | Dynamic _ -> ast
diff --git a/parsing/coqast.mli b/parsing/coqast.mli
deleted file mode 100644
index 0b1138f2..00000000
--- a/parsing/coqast.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-(************************************************************************)
-(*  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: coqast.mli,v 1.10.6.2 2005/01/21 16:42:36 herbelin Exp $ i*)
-
-(*i*)
-open Util
-open Names
-open Libnames
-(*i*)
-
-(* Abstract syntax trees. *)
-
-type t =
-  | Node of loc * string * t list
-  | Nmeta of loc * string
-  | Nvar of loc * identifier
-  | Slam of loc * identifier option * t
-  | Smetalam of loc * string * t
-  | Num of loc * int
-  | Str of loc * string
-  | Id of loc * string
-  | Path of loc * kernel_name
-  | Dynamic of loc * Dyn.t
-
-(* returns the list of metas occuring in the ast *)
-val collect_metas : t -> int list
-
-(* [subst_meta bl ast]: for each binding [(i,c_i)] in [bl], 
-   replace the metavar [?i] by [c_i] in [ast] *)
-val subst_meta : (int * t) list -> t -> t
-
-(* hash-consing function *)
-val hcons_ast: 
-  (string -> string) * (Names.identifier -> Names.identifier)
-  * (kernel_name -> kernel_name)
-  -> (t -> t) * (loc -> loc)
-
-val subst_ast: Names.substitution -> t -> t
-
-(*i
-val map_tactic_expr : (t -> t) -> (tactic_expr -> tactic_expr) -> tactic_expr -> tactic_expr
-val fold_tactic_expr :
-  ('a -> t -> 'a) -> ('a -> tactic_expr -> 'a) -> 'a -> tactic_expr -> 'a
-val iter_tactic_expr : (tactic_expr -> unit) -> tactic_expr -> unit
-i*)
diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml
index 09889d40..07a0a65f 100644
--- a/parsing/egrammar.ml
+++ b/parsing/egrammar.ml
@@ -6,64 +6,31 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: egrammar.ml,v 1.48.2.4 2005/12/23 22:16:46 herbelin Exp $ *)
+(* $Id: egrammar.ml 9333 2006-11-02 13:59:14Z barras $ *)
 
 open Pp
 open Util
-open Ppextend
-open Extend
 open Pcoq
+open Extend
 open Topconstr
-open Ast
 open Genarg
 open Libnames
 open Nameops
-
-(* State of the grammar extensions *)
-
-type notation_grammar = 
-    int * Gramext.g_assoc option * notation * prod_item list * int list option
-
-type all_grammar_command =
-  | Notation of (precedence * tolerability list) * notation_grammar
-  | Grammar of grammar_command
-  | TacticGrammar of
-      (string * (string * grammar_production list) * 
-      (Names.dir_path * Tacexpr.raw_tactic_expr))
-      list * (string * Genarg.argument_type list *
-              (string * Pptactic.grammar_terminals)) list
-
-let subst_all_grammar_command subst = function
-  | Notation _ -> anomaly "Notation not in GRAMMAR summary"
-  | Grammar gc -> Grammar (subst_grammar_command subst gc)
-  | TacticGrammar (g,p) -> TacticGrammar (g,p) (* TODO ... *)
-
-let (grammar_state : all_grammar_command list ref) = ref []
-
+open Tacexpr
+open Names
+open Vernacexpr
 
 (**************************************************************************)
-(* Interpretation of the right hand side of grammar rules *)
-
-(* When reporting errors, we add the name of the grammar rule that failed *)
-let specify_name name e =
-  match e with
-    | UserError(lab,strm) ->
-        UserError(lab, (str"during interpretation of grammar rule " ++
-                          str name ++ str"," ++ spc () ++ strm))
-    | Anomaly(lab,strm) ->
-        Anomaly(lab, (str"during interpretation of grammar rule " ++
-                        str name ++ str"," ++ spc () ++ strm))
-    | Failure s ->
-        Failure("during interpretation of grammar rule "^name^", "^s)
-    | e -> e
-
-(* Translation of environments: a production
+(*  
+ * --- Note on the mapping of grammar productions to camlp4 actions ---
+ *  
+ * Translation of environments: a production
  *   [ nt1(x1) ... nti(xi) ] -> act(x1..xi)
  * is written (with camlp4 conventions):
  *   (fun vi -> .... (fun v1 -> act(v1 .. vi) )..)
  * where v1..vi are the values generated by non-terminals nt1..nti.
  * Since the actions are executed by substituting an environment,
- * make_act builds the following closure:
+ * the make_*_action family build the following closure:
  *
  *      ((fun env ->
  *          (fun vi -> 
@@ -77,11 +44,18 @@ let specify_name name e =
  *         [])
  *)
 
-open Names
+(**********************************************************************)
+(** Declare Notations grammar rules                                   *)
+
+type prod_item =
+  | Term of Token.pattern
+  | NonTerm of constr_production_entry * 
+      (Names.identifier * constr_production_entry) option
 
 type 'a action_env = (identifier * 'a) list
 
-let make_act (f : loc -> constr_expr action_env -> constr_expr) pil =
+let make_constr_action
+  (f : loc -> constr_expr action_env -> constr_expr) pil =
   let rec make (env : constr_expr action_env) = function
     | [] ->
 	Gramext.action (fun loc -> f loc env)
@@ -95,8 +69,8 @@ let make_act (f : loc -> constr_expr action_env -> constr_expr) pil =
         Gramext.action (fun (v:identifier) ->
 	  make ((p,CRef (Ident (dummy_loc,v))) :: env) tl)
     | Some (p, ETBigint) :: tl -> (* non-terminal *)
-        Gramext.action (fun (v:Bignat.bigint) ->
-	  make ((p,CNumeral (dummy_loc,v)) :: env) tl)
+        Gramext.action (fun (v:Bigint.bigint) ->
+	  make ((p,CPrim (dummy_loc,Numeral v)) :: env) tl)
     | Some (p, ETConstrList _) :: tl ->
         Gramext.action (fun (v:constr_expr list) ->
           let dummyid = Ident (dummy_loc,id_of_string "") in
@@ -105,7 +79,7 @@ let make_act (f : loc -> constr_expr action_env -> constr_expr) pil =
 	failwith "Unexpected entry of type cases pattern" in
   make [] (List.rev pil)
 
-let make_act_in_cases_pattern (* For Notations *)
+let make_cases_pattern_action
   (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil =
   let rec make (env : cases_pattern_expr action_env) = function
     | [] ->
@@ -121,8 +95,8 @@ let make_act_in_cases_pattern (* For Notations *)
         Gramext.action (fun (v:identifier) ->
 	  make ((p,CPatAtom (dummy_loc,Some (Ident (dummy_loc,v)))) :: env) tl)
     | Some (p, ETBigint) :: tl -> (* non-terminal *)
-        Gramext.action (fun (v:Bignat.bigint) ->
-	  make ((p,CPatNumeral (dummy_loc,v)) :: env) tl)
+        Gramext.action (fun (v:Bigint.bigint) ->
+	  make ((p,CPatPrim (dummy_loc,Numeral v)) :: env) tl)
     | Some (p, ETConstrList _) :: tl ->
         Gramext.action (fun (v:cases_pattern_expr list) ->
           let dummyid = Ident (dummy_loc,id_of_string "") in
@@ -131,183 +105,37 @@ let make_act_in_cases_pattern (* For Notations *)
 	failwith "Unexpected entry of type cases pattern or other" in
   make [] (List.rev pil)
 
-(* For V7 Grammar only *)
-let make_cases_pattern_act
-  (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil =
-  let rec make (env : cases_pattern_expr action_env) = function
-    | [] ->
-	Gramext.action (fun loc -> f loc env)
-    | None :: tl -> (* parse a non-binding item *)
-        Gramext.action (fun _ -> make env tl)
-    | Some (p, ETPattern) :: tl -> (* non-terminal *)
-        Gramext.action (fun v -> make ((p,v) :: env) tl)
-    | Some (p, ETReference) :: tl -> (* non-terminal *)
-	Gramext.action (fun v -> make ((p,CPatAtom(dummy_loc,Some v)) :: env)
-	  tl)
-    | Some (p, ETBigint) :: tl -> (* non-terminal *)
-	Gramext.action (fun v -> make ((p,CPatNumeral(dummy_loc,v)) :: env) tl)
-    | Some (p, (ETConstrList _ | ETIdent | ETConstr _ | ETOther _)) :: tl ->
-	error "ident and constr entry not admitted in patterns cases syntax extensions" in
-  make [] (List.rev pil)
-
-(* Grammar extension command. Rules are assumed correct.
- * Type-checking of grammar rules is done during the translation of
- * ast to the type grammar_command.  We only check that the existing
- * entries have the type assumed in the grammar command (these types
- * annotations are added when type-checking the command, function
- * Extend.of_ast) *)
-
-let symbol_of_prod_item univ assoc from forpat = function
+let make_constr_prod_item univ assoc from forpat = function
   | Term tok -> (Gramext.Stoken tok, None)
   | NonTerm (nt, ovar) ->
       let eobj = symbol_of_production assoc from forpat nt in
       (eobj, ovar)
 
-let coerce_to_id = function
-  | CRef (Ident (_,id)) -> id 
-  | c ->
-      user_err_loc (constr_loc c, "subst_rawconstr",
-        str"This expression should be a simple identifier")
-
-let coerce_to_ref = function
-  | CRef r -> r
-  | c ->
-      user_err_loc (constr_loc c, "subst_rawconstr",
-        str"This expression should be a simple reference")
-
-let subst_ref loc subst id =
-  try coerce_to_ref (List.assoc id subst) with Not_found -> Ident (loc,id)
-
-let subst_pat_id loc subst id =
-  try List.assoc id subst
-  with Not_found -> CPatAtom (loc,Some (Ident (loc,id)))
-
-let subst_id subst id =
-  try coerce_to_id (List.assoc id subst) with Not_found -> id
-
-(*
-let subst_cases_pattern_expr a loc subs =
-  let rec subst = function
-  | CPatAlias (_,p,x) -> CPatAlias (loc,subst p,x)
-    (* No subst in compound pattern ? *)
-  | CPatCstr (_,ref,pl) -> CPatCstr (loc,ref,List.map subst pl)
-  | CPatAtom (_,Some (Ident (_,id))) -> subst_pat_id loc subs id
-  | CPatAtom (_,x) -> CPatAtom (loc,x)
-  | CPatNotation (_,ntn,l) -> CPatNotation 
-  | CPatNumeral (_,n) -> CPatNumeral (loc,n)
-  | CPatDelimiters (_,key,p) -> CPatDelimiters (loc,key,subst p)
-  in subst a
-*)
-
-let subst_constr_expr a loc subs =
-  let rec subst = function
-  | CRef (Ident (_,id)) ->
-      (try List.assoc id subs with Not_found -> CRef (Ident (loc,id)))
-  (* Temporary: no robust treatment of substituted binders *)
-  | CLambdaN (_,[],c) -> subst c
-  | CLambdaN (_,([],t)::bl,c) -> subst (CLambdaN (loc,bl,c))
-  | CLambdaN (_,((_,na)::bl,t)::bll,c) -> 
-      let na = name_app (subst_id subs) na in
-      CLambdaN (loc,[[loc,na],subst t], subst (CLambdaN (loc,(bl,t)::bll,c)))
-  | CProdN (_,[],c) -> subst c
-  | CProdN (_,([],t)::bl,c) -> subst (CProdN (loc,bl,c))
-  | CProdN (_,((_,na)::bl,t)::bll,c) -> 
-      let na = name_app (subst_id subs) na in
-      CProdN (loc,[[loc,na],subst t], subst (CProdN (loc,(bl,t)::bll,c)))
-  | CLetIn (_,(_,na),b,c) ->
-      let na = name_app (subst_id subs) na in
-      CLetIn (loc,(loc,na),subst b,subst c)
-  | CArrow (_,a,b) -> CArrow (loc,subst a,subst b)
-  | CAppExpl (_,(p,Ident (_,id)),l) ->
-      CAppExpl (loc,(p,subst_ref loc subs id),List.map subst l) 
-  | CAppExpl (_,r,l) -> CAppExpl (loc,r,List.map subst l) 
-  | CApp (_,(p,a),l) ->
-      CApp (loc,(p,subst a),List.map (fun (a,i) -> (subst a,i)) l)
-  | CCast (_,a,b) -> CCast (loc,subst a,subst b)
-  | CNotation (_,n,l) -> CNotation (loc,n,List.map subst l)
-  | CDelimiters (_,s,a) -> CDelimiters (loc,s,subst a)
-  | CHole _ | CEvar _ | CPatVar _ | CSort _ 
-  | CNumeral _ | CDynamic _ | CRef _ as x -> x
-  | CCases (_,(po,rtntypo),a,bl) ->
-      (* TODO: apply g on the binding variables in pat... *)
-      let bl = List.map (fun (_,pat,rhs) -> (loc,pat,subst rhs)) bl in
-      CCases (loc,(option_app subst po,option_app subst rtntypo),
-        List.map (fun (tm,x) -> subst tm,x) a,bl)
-  | COrderedCase (_,s,po,a,bl) ->
-      COrderedCase (loc,s,option_app subst po,subst a,List.map subst bl)
-  | CLetTuple (_,nal,(na,po),a,b) ->
-      let na = option_app (name_app (subst_id subs)) na in
-      let nal = List.map (name_app (subst_id subs)) nal in
-      CLetTuple (loc,nal,(na,option_app subst po),subst a,subst b)
-  | CIf (_,c,(na,po),b1,b2) ->
-      let na = option_app (name_app (subst_id subs)) na in
-      CIf (loc,subst c,(na,option_app subst po),subst b1,subst b2)
-  | CFix (_,id,dl) ->
-      CFix (loc,id,List.map (fun (id,n,bl, t,d) ->
-        (id,n,
-         List.map(function
-             LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty)
-           | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl,
-         subst t,subst d)) dl)
-  | CCoFix (_,id,dl) ->
-      CCoFix (loc,id,List.map (fun (id,bl,t,d) ->
-        (id,
-         List.map(function
-             LocalRawAssum(nal,ty) -> LocalRawAssum(nal,subst ty)
-           | LocalRawDef(na,def) -> LocalRawDef(na,subst def)) bl,
-         subst t,subst d)) dl)
-  in subst a
-
-(* For V7 Grammar only *)
-let make_rule univ assoc etyp rule =
-  if not !Options.v7 then anomaly "No Grammar in new syntax";
-  let pil = List.map (symbol_of_prod_item univ assoc etyp false) rule.gr_production in
+let extend_constr entry (n,assoc,pos,p4assoc,name) mkact (forpat,pt) =
+  let univ = get_univ "constr" in
+  let pil = List.map (make_constr_prod_item univ assoc n forpat) pt in
   let (symbs,ntl) = List.split pil in
-  let act = match etyp with
-    | ETPattern ->
-        (* Ugly *)
-        let f loc env = match rule.gr_action, env with
-          | CRef (Ident(_,p)), [p',a] when p=p' -> a
-          | CDelimiters (_,s,CRef (Ident(_,p))), [p',a] when p=p' ->
-	      CPatDelimiters (loc,s,a)
-          | _ -> error "Unable to handle this grammar extension of pattern" in
-	make_cases_pattern_act f ntl
-    | ETConstrList _ | ETIdent | ETBigint | ETReference -> error "Cannot extend"
-    | ETConstr _ | ETOther _ -> 
-	make_act (subst_constr_expr rule.gr_action) ntl in
-  (symbs, act)
+  grammar_extend entry pos [(name, p4assoc, [symbs, mkact ntl])]
 
-(* Rules of a level are entered in reverse order, so that the first rules
-   are applied before the last ones *)
-(* For V7 Grammar only *)
-let extend_entry univ (te, etyp, pos, name, ass, p4ass, rls) =
-  let rules = List.rev (List.map (make_rule univ ass etyp) rls) in
-  grammar_extend te pos [(name, p4ass, rules)]
-
-(* Defines new entries. If the entry already exists, check its type *)
-let define_entry univ {ge_name=typ; gl_assoc=ass; gl_rules=rls} =
-  let e,lev,keepassoc = get_constr_entry false typ in
-  let pos,p4ass,name = find_position false keepassoc ass lev in
-  (e,typ,pos,name,ass,p4ass,rls)
-
-(* Add a bunch of grammar rules. Does not check if it is well formed *)
-(* For V7 Grammar only *)
-let extend_grammar_rules gram =
-  let univ = get_univ gram.gc_univ in
-  let tl = List.map (define_entry univ) gram.gc_entries in
-  List.iter (extend_entry univ) tl
-
-(* Add a grammar rules for tactics *)
-type grammar_tactic_production =
-  | TacTerm of string
-  | TacNonTerm of loc * (Gram.te Gramext.g_symbol * argument_type) * string option
+let extend_constr_notation (n,assoc,ntn,rule) =
+  (* Add the notation in constr *)
+  let mkact loc env = CNotation (loc,ntn,List.map snd env) in
+  let (e,level,keepassoc) = get_constr_entry false (ETConstr (n,())) in
+  let pos,p4assoc,name = find_position false keepassoc assoc level in
+  extend_constr e (ETConstr(n,()),assoc,pos,p4assoc,name)
+    (make_constr_action mkact) (false,rule);
+  (* Add the notation in cases_pattern *)
+  let mkact loc env = CPatNotation (loc,ntn,List.map snd env) in
+  let (e,level,keepassoc) = get_constr_entry true (ETConstr (n,())) in
+  let pos,p4assoc,name = find_position true keepassoc assoc level in
+  extend_constr e (ETConstr (n,()),assoc,pos,p4assoc,name)
+    (make_cases_pattern_action mkact) (true,rule)
 
-let make_prod_item = function
-  | TacTerm s -> (Gramext.Stoken (Extend.terminal s), None)
-  | TacNonTerm (_,(nont,t), po) ->
-      (nont, option_app (fun p -> (p,t)) po)
+(**********************************************************************)
+(** Making generic actions in type generic_argument                   *)
 
-let make_gen_act f pil =
+let make_generic_action
+  (f:loc -> ('b * raw_generic_argument) list -> 'a) pil =
   let rec make env = function
     | [] -> 
 	Gramext.action (fun loc -> f loc env)
@@ -317,73 +145,78 @@ let make_gen_act f pil =
         Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in
   make [] (List.rev pil)
 
-let extend_constr entry (n,assoc,pos,p4assoc,name) make_act (forpat,pt) =
-  let univ = get_univ "constr" in
-  let pil = List.map (symbol_of_prod_item univ assoc n forpat) pt in
-  let (symbs,ntl) = List.split pil in
-  let act = make_act ntl in
-  grammar_extend entry pos [(name, p4assoc, [symbs, act])]
-
-let extend_constr_notation (n,assoc,ntn,rule,permut) =
-  let mkact =
-    match permut with
-        None -> (fun loc env -> CNotation (loc,ntn,List.map snd env))
-      | Some p -> (fun loc env ->
-          CNotation (loc,ntn,List.map (fun i -> snd (List.nth env i)) p)) in
-  let (e,level,keepassoc) = get_constr_entry false (ETConstr (n,())) in
-  let pos,p4assoc,name = find_position false keepassoc assoc level in
-  extend_constr e (ETConstr(n,()),assoc,pos,p4assoc,name)
-    (make_act mkact) (false,rule);
-  if not !Options.v7 then
-  let mkact loc env = CPatNotation (loc,ntn,List.map snd env) in
-  let (e,level,keepassoc) = get_constr_entry true (ETConstr (n,())) in
-  let pos,p4assoc,name = find_position true keepassoc assoc level in
-  extend_constr e (ETConstr (n,()),assoc,pos,p4assoc,name)
-    (make_act_in_cases_pattern mkact) (true,rule)
-    
-(* These grammars are not a removable *)
-let make_rule univ f g (s,pt) =
-  let hd = Gramext.Stoken ("IDENT", s) in
-  let pil = (hd,None) :: List.map g pt in
-  let (symbs,ntl) = List.split pil in
-  let act = make_gen_act f ntl in
+let make_rule univ f g pt =
+  let (symbs,ntl) = List.split (List.map g pt) in
+  let act = make_generic_action f ntl in
   (symbs, act)
 
+(**********************************************************************)
+(** Grammar extensions declared at ML level                           *) 
+
+type grammar_tactic_production =
+  | TacTerm of string
+  | TacNonTerm of
+      loc * (Gram.te Gramext.g_symbol * argument_type) * string option
+
+let make_prod_item = function
+  | TacTerm s -> (Gramext.Stoken (Lexer.terminal s), None)
+  | TacNonTerm (_,(nont,t), po) -> (nont, option_map (fun p -> (p,t)) po)
+
+(* Tactic grammar extensions *)
+
 let tac_exts = ref []
 let get_extend_tactic_grammars () = !tac_exts
 
 let extend_tactic_grammar s gl =
   tac_exts := (s,gl) :: !tac_exts;
   let univ = get_univ "tactic" in
-  let make_act loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in
-  let rules = List.map (make_rule univ make_act make_prod_item) gl in
+  let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in
+  let rules = List.map (make_rule univ mkact make_prod_item) gl in
   Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)]
 
+(* Vernac grammar extensions *)
+
 let vernac_exts = ref []
 let get_extend_vernac_grammars () = !vernac_exts
 
 let extend_vernac_command_grammar s gl =
   vernac_exts := (s,gl) :: !vernac_exts;
   let univ = get_univ "vernac" in
-  let make_act loc l = Vernacexpr.VernacExtend (s,List.map snd l) in
-  let rules = List.map (make_rule univ make_act make_prod_item) gl in
+  let mkact loc l = VernacExtend (s,List.map snd l) in
+  let rules = List.map (make_rule univ mkact make_prod_item) gl in
   Gram.extend Vernac_.command None [(None, None, List.rev rules)]
 
-let rec interp_entry_name u s =
+(**********************************************************************)
+(** Grammar declaration for Tactic Notation (Coq level)               *) 
+
+(* Interpretation of the grammar entry names *)
+
+let find_index s t =
+  let t,n = repr_ident (id_of_string t) in
+  if s <> t or n = None then raise Not_found;
+  out_some n
+
+let rec interp_entry_name up_level s =
   let l = String.length s in
   if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name u (String.sub s 3 (l-8)) in
+    let t, g = interp_entry_name up_level (String.sub s 3 (l-8)) in
     List1ArgType t, Gramext.Slist1 g
   else if l > 5 & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name u (String.sub s 0 (l-5)) in
+    let t, g = interp_entry_name up_level (String.sub s 0 (l-5)) in
     List0ArgType t, Gramext.Slist0 g
   else if l > 4 & String.sub s (l-4) 4 = "_opt" then
-    let t, g = interp_entry_name u (String.sub s 0 (l-4)) in
+    let t, g = interp_entry_name up_level (String.sub s 0 (l-4)) in
     OptArgType t, Gramext.Sopt g
   else
+    let s = if s = "hyp" then "var" else s in
+    try 
+      let i = find_index "tactic" s in
+      ExtraArgType s, 
+      if up_level<>5 && i=up_level then Gramext.Sself else
+      if up_level<>5 && i=up_level-1 then Gramext.Snext else
+      Gramext.Snterml(Pcoq.Gram.Entry.obj Tactic.tactic_expr,string_of_int i)
+    with Not_found ->
     let e = 
-    if !Options.v7 then get_entry (get_univ u) s
-    else
       (* Qualified entries are no longer in use *)
       try get_entry (get_univ "tactic") s
       with _ -> 
@@ -396,31 +229,63 @@ let rec interp_entry_name u s =
     let t = type_of_typed_entry e in
     t,Gramext.Snterm (Pcoq.Gram.Entry.obj o)
 
-let qualified_nterm current_univ = function
-  | NtQual (univ, en) -> if !Options.v7 then (univ, en) else assert false
-  | NtShort en -> (current_univ, en)
-
-let make_vprod_item univ = function
-  | VTerm s -> (Gramext.Stoken (Extend.terminal s), None)
+let make_vprod_item n = function
+  | VTerm s -> (Gramext.Stoken (Lexer.terminal s), None)
   | VNonTerm (loc, nt, po) ->
-      let (u,nt) = qualified_nterm univ nt in
-      let (etyp, e) = interp_entry_name u nt in
-      e, option_app (fun p -> (p,etyp)) po
+      let (etyp, e) = interp_entry_name n nt in
+      e, option_map (fun p -> (p,etyp)) po
+
+let get_tactic_entry n =
+  if n = 0 then
+    weaken_entry Tactic.simple_tactic, None
+  else if n = 5 then
+    weaken_entry Tactic.binder_tactic, None
+  else if 1<=n && n<5 then
+    weaken_entry Tactic.tactic_expr, Some (Gramext.Level (string_of_int n))
+  else 
+    error ("Invalid Tactic Notation level: "^(string_of_int n))
+
+(* Declaration of the tactic grammar rule *)
+
+let head_is_ident = function VTerm _::_ -> true | _ -> false
 
-let add_tactic_entries gl =
+let add_tactic_entry (key,lev,prods,tac) =
   let univ = get_univ "tactic" in
-  let make_act s tac loc l = Tacexpr.TacAlias (loc,s,l,tac) in
-  let f (s,l,tac) =
-    make_rule univ (make_act s tac) (make_vprod_item "tactic") l in
-  let rules = List.map f gl in
+  let entry, pos = get_tactic_entry lev in
+  let mkprod = make_vprod_item lev in
+  let rules = 
+    if lev = 0 then begin
+      if not (head_is_ident prods) then
+	error "Notation for simple tactic must start with an identifier";
+      let mkact s tac loc l =
+	(TacAlias(loc,s,l,tac):raw_atomic_tactic_expr) in
+      make_rule univ (mkact key tac) mkprod prods
+    end
+    else
+      let mkact s tac loc l = 
+	(TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in
+      make_rule univ (mkact key tac) mkprod prods in
   let _ = find_position true true None None (* to synchronise with remove *) in
-  grammar_extend Tactic.simple_tactic None [(None, None, List.rev rules)]
+  grammar_extend entry pos [(None, None, List.rev [rules])]
+
+(**********************************************************************)
+(** State of the grammar extensions                                   *)
+
+type notation_grammar = 
+    int * Gramext.g_assoc option * notation * prod_item list
+
+type all_grammar_command =
+  | Notation of Notation.level * notation_grammar
+  | TacticGrammar of
+      (string * int * grammar_production list * 
+        (Names.dir_path * Tacexpr.glob_tactic_expr))
+
+let (grammar_state : all_grammar_command list ref) = ref []
 
 let extend_grammar gram =
   (match gram with
   | Notation (_,a) -> extend_constr_notation a
-  | Grammar g -> extend_grammar_rules g
-  | TacticGrammar (l,_) -> add_tactic_entries l);
+  | TacticGrammar g -> add_tactic_entry g);
   grammar_state := gram :: !grammar_state
 
 let reset_extend_grammars_v8 () =
@@ -428,12 +293,12 @@ let reset_extend_grammars_v8 () =
   let tv = List.rev !vernac_exts in
   tac_exts := [];
   vernac_exts := [];
-  List.iter (fun (s,gl) -> extend_tactic_grammar s gl) te;
+  List.iter (fun (s,gl) -> print_string ("Resinstalling "^s); flush stdout; extend_tactic_grammar s gl) te;
   List.iter (fun (s,gl) -> extend_vernac_command_grammar s gl) tv
 
 let recover_notation_grammar ntn prec =
   let l = map_succeed (function
-    | Notation (prec',(_,_,ntn',_,_ as x)) when prec = prec' & ntn = ntn' -> x
+    | Notation (prec',(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' -> x
     | _ -> failwith "") !grammar_state in
   assert (List.length l = 1);
   List.hd l
@@ -453,11 +318,7 @@ let factorize_grams l1 l2 =
 let number_of_entries gcl =
   List.fold_left
     (fun n -> function
-      | Notation _ -> 
-          if !Options.v7 then n + 1
-	  else n + 2 (* 1 for operconstr, 1 for pattern *)
-      | Grammar gc ->
-          n + (List.length gc.gc_entries)
+      | Notation _ -> n + 2 (* 1 for operconstr, 1 for pattern *)
       | TacticGrammar _ -> n + 1)
     0 gcl
 
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
index ade91453..5dda69ba 100644
--- a/parsing/egrammar.mli
+++ b/parsing/egrammar.mli
@@ -6,55 +6,62 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: egrammar.mli,v 1.14.2.6 2005/12/23 22:16:46 herbelin Exp $ i*)
+(*i $Id: egrammar.mli 9147 2006-09-15 21:49:56Z herbelin $ i*)
 
 (*i*)
 open Util
 open Topconstr
-open Ast
-open Coqast
+open Pcoq
+open Extend
 open Vernacexpr
 open Ppextend
-open Extend
 open Rawterm
+open Mod_subst
 (*i*)
 
+(** Mapping of grammar productions to camlp4 actions
+    Used for Coq-level Notation and Tactic Notation, 
+    and for ML-level tactic and vernac extensions
+ *)
+
+type prod_item =
+  | Term of Token.pattern
+  | NonTerm of constr_production_entry * 
+      (Names.identifier * constr_production_entry) option
+
 type notation_grammar = 
-    int * Gramext.g_assoc option * notation * prod_item list * int list option
+    int * Gramext.g_assoc option * notation * prod_item list
 
 type all_grammar_command =
   | Notation of (precedence * tolerability list) * notation_grammar
-  | Grammar of grammar_command
   | TacticGrammar of
-      (string * (string * grammar_production list) * 
-      (Names.dir_path * Tacexpr.raw_tactic_expr))
-      list * (string * Genarg.argument_type list *
-              (string * Pptactic.grammar_terminals)) list
+      (string * int * grammar_production list * 
+        (Names.dir_path * Tacexpr.glob_tactic_expr))
 
 val extend_grammar : all_grammar_command -> unit
 
 (* Add grammar rules for tactics *)
+
 type grammar_tactic_production =
   | TacTerm of string
-  | TacNonTerm of loc * (Token.t Gramext.g_symbol * Genarg.argument_type) * string option
+  | TacNonTerm of
+      loc * (Token.t Gramext.g_symbol * Genarg.argument_type) * string option
 
 val extend_tactic_grammar :
-  string -> (string * grammar_tactic_production list) list -> unit
+  string -> grammar_tactic_production list list -> unit
 
 val extend_vernac_command_grammar :
-  string -> (string * grammar_tactic_production list) list -> unit
-
+  string -> grammar_tactic_production list list -> unit
+(*
 val get_extend_tactic_grammars :
- unit -> (string * (string * grammar_tactic_production list) list) list
+ unit -> (string * grammar_tactic_production list list) list
+*)
 val get_extend_vernac_grammars :
- unit -> (string * (string * grammar_tactic_production list) list) list
+ unit -> (string * grammar_tactic_production list list) list
+(*
 val reset_extend_grammars_v8 : unit -> unit
-
-val subst_all_grammar_command :
-  Names.substitution -> all_grammar_command -> all_grammar_command
-
-val interp_entry_name : string -> string -> 
-  entry_type * Token.t Gramext.g_symbol
+*)
+val interp_entry_name : int -> string -> entry_type * Token.t Gramext.g_symbol
 
 val recover_notation_grammar :
   notation -> (precedence * tolerability list) -> notation_grammar
diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml
deleted file mode 100644
index 6a4758ab..00000000
--- a/parsing/esyntax.ml
+++ /dev/null
@@ -1,276 +0,0 @@
-(************************************************************************)
-(*  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: esyntax.ml,v 1.21.2.1 2004/07/16 19:30:37 herbelin Exp $ *)
-
-open Pp
-open Util
-open Names
-open Libnames
-open Coqast
-open Ast
-open Extend
-open Ppextend
-open Names
-open Nametab
-open Topconstr
-open Symbols
- 
-(*** Syntax keys ***)
-
-(* We define keys for ast and astpats. This is a kind of hash
- * function.  An ast may have several keys, but astpat only one. The
- * idea is that if an ast A matches a pattern P, then the key of P
- * is in the set of keys of A. Thus, we can split the syntax entries
- * according to the key of the pattern. *)
-
-type key =
-  | Cst of Names.constant (* keys for global constants rules *)
-  | SecVar of Names.variable
-  | Ind of Names.inductive
-  | Cstr of Names.constructor
-  | Nod of string      (* keys for other constructed asts rules *)
-  | Oth                (* key for other syntax rules *)
-  | All     (* key for catch-all rules (i.e. with a pattern such as $x .. *)
-
-let warning_verbose = ref true
-
-let ast_keys = function
-  | Node(_,"APPLIST", Node(_,"CONST", [Path (_,sl)]) ::_) ->
-      [Cst sl; Nod "APPLIST"; All]
-  | Node(_,"APPLIST", Node(_,"SECVAR", [Nvar (_,s)]) ::_) ->
-      [SecVar s; Nod "APPLIST"; All]
-  | Node(_,"APPLIST", Node(_,"MUTIND", [Path (_,sl); Num (_,tyi)]) ::_) ->
-      [Ind (sl,tyi); Nod "APPLIST"; All]
-  | Node(_,"APPLIST", Node(_,"MUTCONSTRUCT",
-			   [Path (_,sl); Num (_,tyi); Num (_,i)]) ::_) ->
-      [Cstr ((sl,tyi),i); Nod "APPLIST"; All]
-  | Node(_,s,_) -> [Nod s; All]
-  | _ -> [Oth; All]
-
-let spat_key astp =
-  match astp with
-    | Pnode("APPLIST",
-            Pcons(Pnode("CONST",
-                        Pcons(Pquote(Path (_,sl)),_)), _))
-      -> Cst sl
-    | Pnode("APPLIST",
-            Pcons(Pnode("SECVAR",
-                        Pcons(Pquote(Nvar (_,s)),_)), _))
-      -> SecVar s
-    | Pnode("APPLIST",
-            Pcons(Pnode("MUTIND",
-                        Pcons(Pquote(Path (_,sl)),
-			      Pcons(Pquote(Num (_,tyi)),_))), _))
-      -> Ind (sl,tyi)
-    | Pnode("APPLIST",
-            Pcons(Pnode("MUTCONSTRUCT",
-                        Pcons(Pquote(Path (_,sl)),
-			      Pcons(Pquote(Num (_,tyi)),
-				    Pcons(Pquote(Num (_,i)),_)))), _))
-      -> Cstr ((sl,tyi),i)
-    | Pnode(na,_) -> Nod na
-    | Pquote ast -> List.hd (ast_keys ast)
-    | Pmeta _ -> All
-    | _ -> Oth
-
-let se_key se = spat_key se.syn_astpat
-
-(** Syntax entry tables (state of the pretty_printer) **)
-let from_name_table = ref Gmap.empty
-let from_key_table = ref Gmapl.empty
-
-(* Summary operations *)
-type frozen_t = (string * string, astpat syntax_entry) Gmap.t * 
-                (string * key, astpat syntax_entry) Gmapl.t
-
-let freeze () =
-  (!from_name_table, !from_key_table)
-
-let unfreeze (fnm,fkm) =
-  from_name_table := fnm;
-  from_key_table := fkm
-
-let init () =
-  from_name_table := Gmap.empty;
-  from_key_table := Gmapl.empty
-
-let find_syntax_entry whatfor gt =
-  let gt_keys = ast_keys gt in
-  let entries =
-    List.flatten
-      (List.map (fun k -> Gmapl.find (whatfor,k) !from_key_table) gt_keys)
-  in 
-  find_all_matches (fun se -> se.syn_astpat) [] gt entries
-
-let remove_with_warning name =
-  if Gmap.mem name !from_name_table then begin
-    let se = Gmap.find name !from_name_table in
-    let key = (fst name, se_key se) in
-    if !warning_verbose then
-      (Options.if_verbose
-    	warning ("overriding syntax rule "^(fst name)^":"^(snd name)^"."));
-    from_name_table := Gmap.remove name !from_name_table;
-    from_key_table := Gmapl.remove key se !from_key_table
-  end
-
-let add_rule whatfor se =
-  let name = (whatfor,se.syn_id) in
-  let key = (whatfor, se_key se) in
-  remove_with_warning name;
-  from_name_table := Gmap.add name se !from_name_table;
-  from_key_table := Gmapl.add key se !from_key_table
-
-let add_ppobject {sc_univ=wf;sc_entries=sel} = List.iter (add_rule wf) sel
-
-
-(* Pretty-printing machinery *)
-
-type std_printer = Coqast.t -> std_ppcmds
-type unparsing_subfunction = string -> tolerability option -> std_printer
-type primitive_printer = Coqast.t -> std_ppcmds option
-
-(* Module of primitive printers *)
-module Ppprim =
-  struct
-    type t = std_printer -> std_printer
-    let tab = ref ([] : (string * t) list)
-    let map a = List.assoc a !tab
-    let add (a,ppr) = tab := (a,ppr)::!tab
-  end
-
-(**********************************************************************)
-(* Primitive printers (e.g. for numerals)                             *)
-
-(* This is the map associating to a printer the scope it belongs to   *)
-(* and its ML code                                                    *)
-
-let primitive_printer_tab = 
-  ref (Stringmap.empty : (scope_name * primitive_printer) Stringmap.t)
-let declare_primitive_printer s sc pp =
-  primitive_printer_tab := Stringmap.add s (sc,pp) !primitive_printer_tab
-let lookup_primitive_printer s =
-  Stringmap.find s !primitive_printer_tab
-
-(* Register the primitive printer for "token". It is not used in syntax/PP*.v,
- * but any ast matching no PP rule is printed with it. *)
-(*
-let _ = declare_primitive_printer "token" token_printer
-*)
-
-(* A printer for the tokens. *)
-let token_printer stdpr = function
-  | (Id _ | Num _ | Str _ | Path _ as ast) -> print_ast ast
-  | a -> stdpr a
-
-(* Unused ??
-(* A primitive printer to do "print as" (to specify a length for a string) *)
-let print_as_printer = function
-  | Node (_, "AS", [Num(_,n); Str(_,s)]) -> Some (stras (n,s))
-  | ast                                  -> None
-
-let _ = declare_primitive_printer "print_as" default_scope print_as_printer
-*)
-
-(* Handle infix symbols *)
-
-let pr_parenthesis inherited se strm =
-  if tolerable_prec inherited se.syn_prec then
-    strm
-  else 
-    (str"(" ++ strm ++ str")")
-    
-let print_delimiters inh se strm = function
-  | None -> pr_parenthesis inh se strm
-  | Some key ->
-      let left = "'"^key^":" and right = "'" in
-      let lspace =
-	if is_letter (left.[String.length left -1]) then str " " else mt () in
-      let rspace =
-        let c = right.[0] in
-	if is_ident_tail c then str " " else mt () in
-      hov 0 (str left ++ lspace ++ strm ++ rspace ++ str right)
-
-(* Print the syntax entry. In the unparsing hunks, the tokens are
- * printed using the token_printer, unless another primitive printer
- * is specified. *)
-
-let print_syntax_entry sub_pr scopes env se = 
-  let rec print_hunk rule_prec scopes = function
-    | PH(e,externpr,reln) ->
-	let node = Ast.pat_sub dummy_loc env e in
-	let printer =
-	  match externpr with (* May branch to an other printer *)
-	    | Some c ->
-                (try (* Test for a primitive printer *) Ppprim.map c
-                with Not_found -> token_printer)
-	    | _ -> token_printer in
-	printer (sub_pr scopes (Some(rule_prec,reln))) node
-    | RO s -> str s
-    | UNP_TAB -> tab ()
-    | UNP_FNL -> fnl ()
-    | UNP_BRK(n1,n2) -> brk(n1,n2)
-    | UNP_TBRK(n1,n2) -> tbrk(n1,n2)
-    | UNP_BOX (b,sub) -> ppcmd_of_box b (prlist (print_hunk rule_prec scopes) sub)
-    | UNP_SYMBOLIC _ -> anomaly "handled by call_primitive_parser"
-  in 
-  prlist (print_hunk se.syn_prec scopes) se.syn_hunks
-
-let call_primitive_parser rec_pr otherwise inherited scopes (se,env) =
-  try (
-  match se.syn_hunks with
-    | [PH(e,Some c,reln)] ->
-	  (* Test for a primitive printer; may raise Not_found *)
-	  let sc,pr = lookup_primitive_printer c in
-	  (* Look if scope [sc] associated to this printer is OK *)
-	  (match Symbols.availability_of_numeral sc scopes with
-	    | None -> otherwise ()
-	    | Some key ->
-	        (* We can use this printer *)
-	        let node = Ast.pat_sub dummy_loc env e in
-	        match pr node with
-		  | Some strm -> print_delimiters inherited se strm key
-		  | None -> otherwise ())
-    | [UNP_SYMBOLIC (sc,pat,sub)] ->
-	(match Symbols.availability_of_notation (sc,pat) scopes with
-	  | None -> otherwise ()
-	  | Some (scopt,key) ->
-	      print_delimiters inherited se
-		(print_syntax_entry rec_pr
-		  (option_fold_right Symbols.push_scope scopt scopes) env 
-		  {se with syn_hunks = [sub]}) key)
-    | _ ->
-	pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se)
-  )
-  with Not_found -> (* To handle old style printer *)
-	pr_parenthesis inherited se (print_syntax_entry rec_pr scopes env se)
-
-(* [genprint whatfor dflt inhprec ast] prints out the ast of
- * 'universe' whatfor. If the term is not matched by any
- * pretty-printing rule, then it will call dflt on it, which is
- * responsible for printing out the term (usually #GENTERM...).
- * In the case of tactics and commands, dflt also prints 
- * global constants basenames. *)
-
-let genprint dflt whatfor inhprec ast =
-  let rec rec_pr scopes inherited gt =
-    let entries = find_syntax_entry whatfor gt in
-    let rec test_rule = function
-      | se_env::rules ->
-	  call_primitive_parser
-	    rec_pr 
-	    (fun () -> test_rule rules) 
-	    inherited scopes se_env
-      | [] -> dflt gt (* No rule found *)
-    in test_rule entries
-  in
-  try 
-    rec_pr (Symbols.current_scopes ()) inhprec ast
-  with
-    | Failure _ -> (str"<PP failure: " ++ dflt ast ++ str">")
-    | Not_found -> (str"<PP search failure: " ++ dflt ast ++ str">")
diff --git a/parsing/esyntax.mli b/parsing/esyntax.mli
deleted file mode 100644
index 88d1a0e2..00000000
--- a/parsing/esyntax.mli
+++ /dev/null
@@ -1,61 +0,0 @@
-(************************************************************************)
-(*  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: esyntax.mli,v 1.10.2.2 2005/01/21 16:42:36 herbelin Exp $ i*)
-
-(*i*)
-open Pp
-open Extend
-open Symbols
-open Ppextend
-open Topconstr
-(*i*)
-
-(* Syntax entry tables. *)
-
-type frozen_t
-
-(* pretty-printer summary operations *)
-val init : unit -> unit
-val freeze : unit -> frozen_t
-val unfreeze : frozen_t -> unit
-
-(* Search and add a PP rule for an ast in the summary *)
-val find_syntax_entry :
-  string -> Coqast.t -> (Ast.astpat syntax_entry * Ast.env) list
-val add_rule : string -> Ast.astpat syntax_entry -> unit
-val add_ppobject : Ast.astpat syntax_command -> unit
-val warning_verbose : bool ref
-
-(* Pretty-printing *)
-
-type std_printer = Coqast.t -> std_ppcmds
-type unparsing_subfunction = string -> tolerability option -> std_printer
-type primitive_printer = Coqast.t -> std_ppcmds option
-
-(* Module of constr primitive printers [old style - no scope] *)
-module Ppprim :
-  sig
-    type t = std_printer -> std_printer
-    val add : string * t -> unit
-  end
-
-val declare_primitive_printer : 
-  string -> scope_name -> primitive_printer -> unit
-
-(*i
-val declare_infix_symbol : Libnames.section_path -> string -> unit
-i*)
-
-(* Generic printing functions *) 
-(*i
-val token_printer: std_printer -> std_printer
-val print_syntax_entry : 
-  string -> unparsing_subfunction -> Ast.env -> Ast.astpat syntax_entry -> std_ppcmds
-i*)
-val genprint : std_printer -> unparsing_subfunction
diff --git a/parsing/extend.ml b/parsing/extend.ml
index 2778de44..f4c98291 100644
--- a/parsing/extend.ml
+++ b/parsing/extend.ml
@@ -7,21 +7,23 @@
 (************************************************************************)
 
 
-(*i $Id: extend.ml,v 1.20.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+(*i $Id: extend.ml 7761 2005-12-30 10:52:19Z herbelin $ i*)
 
 open Util
 open Pp
 open Gramext
 open Names
-open Ast
 open Ppextend
 open Topconstr
 open Genarg
 
-type entry_type = argument_type
+(**********************************************************************)
+(* constr entry keys                                                  *)
+
+type side = Left | Right
 
 type production_position =
-  | BorderProd of bool * Gramext.g_assoc option  (* true=left; false=right *)
+  | BorderProd of side * Gramext.g_assoc option  (* true=left; false=right *)
   | InternalProd
 
 type production_level =
@@ -37,54 +39,13 @@ type ('lev,'pos) constr_entry_key =
 
 type constr_production_entry =
     (production_level,production_position) constr_entry_key
-type constr_entry = (int,unit) constr_entry_key
-type simple_constr_production_entry = (production_level,unit) constr_entry_key
-
-type nonterm_prod =
-  | ProdList0 of nonterm_prod
-  | ProdList1 of nonterm_prod * Token.pattern list
-  | ProdOpt of nonterm_prod
-  | ProdPrimitive of constr_production_entry
-
-type prod_item =
-  | Term of Token.pattern
-  | NonTerm of constr_production_entry *
-      (Names.identifier * constr_production_entry) option
-
-type grammar_rule = {
-  gr_name : string; 
-  gr_production : prod_item list; 
-  gr_action : constr_expr }
-
-type grammar_entry = { 
-  ge_name : constr_entry;
-  gl_assoc : Gramext.g_assoc option;
-  gl_rules : grammar_rule list }
-
-type grammar_command = { 
-  gc_univ : string; 
-  gc_entries : grammar_entry list }
-
-type grammar_associativity = Gramext.g_assoc option
+type constr_entry =
+    (int,unit) constr_entry_key
+type simple_constr_production_entry =
+    (production_level,unit) constr_entry_key
 
 (**********************************************************************)
-(* Globalisation and type-checking of Grammar actions *)
-
-type entry_context = identifier list
-
-open Rawterm
-open Libnames
-
-let globalizer = ref (fun _ _ -> CHole dummy_loc)
-let set_constr_globalizer f = globalizer := f
-
-let act_of_ast vars = function
-  | SimpleAction (loc,ConstrNode a) -> !globalizer vars a
-  | SimpleAction (loc,CasesPatternNode a) -> 
-      failwith "TODO:act_of_ast: cases_pattern"
-  | CaseAction _ -> failwith "case/let not supported"
-
-let to_act_check_vars = act_of_ast
+(* syntax modifiers                                                   *)
 
 type syntax_modifier =
   | SetItemLevel of string list * production_level
@@ -94,285 +55,3 @@ type syntax_modifier =
   | SetOnlyParsing
   | SetFormat of string located
 
-type nonterm =
-  | NtShort of string
-  | NtQual of string * string
-type grammar_production =
-  | VTerm of string
-  | VNonTerm of loc * nonterm * Names.identifier option
-type raw_grammar_rule = string * grammar_production list * grammar_action
-type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list
-
-(* No kernel names in Grammar's *)
-let subst_constr_expr _ a = a
-
-let subst_grammar_rule subst gr =
-  { gr with gr_action = subst_constr_expr subst gr.gr_action }
-
-let subst_grammar_entry subst ge =
-  { ge with gl_rules = List.map (subst_grammar_rule subst) ge.gl_rules }
-
-let subst_grammar_command subst gc =
-  { gc with gc_entries = List.map (subst_grammar_entry subst) gc.gc_entries }
-
-
-(*s Terminal symbols interpretation *)
-
-let is_ident_not_keyword s =
-  match s.[0] with
-    | 'a'..'z' | 'A'..'Z' | '_' -> not (Lexer.is_keyword s)
-    | _ -> false
-
-let is_number s =
-  match s.[0] with
-    | '0'..'9' -> true
-    | _ -> false
-
-let strip s =
-  let len =
-    let rec loop i len =
-      if i = String.length s then len
-      else if s.[i] == ' ' then loop (i + 1) len
-      else loop (i + 1) (len + 1)
-    in
-    loop 0 0
-  in
-  if len == String.length s then s
-  else
-    let s' = String.create len in
-    let rec loop i i' =
-      if i == String.length s then s'
-      else if s.[i] == ' ' then loop (i + 1) i'
-      else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end
-    in
-    loop 0 0
-
-let terminal s =
-  let s = strip s in
-  if s = "" then failwith "empty token";
-  if is_ident_not_keyword s then ("IDENT", s)
-  else if is_number s then ("INT", s)
-  else ("", s)
-
-(*s Non-terminal symbols interpretation *)
-
-(* For compatibility *)
-let warn nt nt' =
-  warning ("'"^nt^"' grammar entry is obsolete; use name '"^nt'^"' instead");
-  nt'
-
-let rename_command_entry nt =
-  if String.length nt >= 7 & String.sub nt 0 7 = "command"
-  then warn nt ("constr"^(String.sub nt 7 (String.length nt - 7)))
-  else if nt = "lcommand" then warn nt "lconstr"
-  else if nt = "lassoc_command4" then warn nt "lassoc_constr4"
-  else nt
-
-(* This translates constr0, constr1, ... level into camlp4 levels of constr *)
-
-let explicitize_prod_entry inj pos univ nt =
-  if univ = "prim" & nt = "var" then ETIdent else
-  if univ = "prim" & nt = "bigint" then ETBigint else
-  if univ <> "constr" then ETOther (univ,nt) else
-  match nt with
-  | "constr0" -> ETConstr (inj 0,pos)
-  | "constr1" -> ETConstr (inj 1,pos)
-  | "constr2" -> ETConstr (inj 2,pos)
-  | "constr3" -> ETConstr (inj 3,pos)
-  | "lassoc_constr4" -> ETConstr (inj 4,pos)
-  | "constr5" -> ETConstr (inj 5,pos)
-  | "constr6" -> ETConstr (inj 6,pos)
-  | "constr7" -> ETConstr (inj 7,pos)
-  | "constr8" -> ETConstr (inj 8,pos)
-  | "constr" when !Options.v7 -> ETConstr (inj 8,pos)
-  | "constr9" -> ETConstr (inj 9,pos)
-  | "constr10" | "lconstr" -> ETConstr (inj 10,pos)
-  | "pattern" -> ETPattern
-  | "ident" -> ETIdent
-  | "global" -> ETReference
-  | _ -> ETOther (univ,nt)
-
-let explicitize_entry = explicitize_prod_entry (fun x -> x) ()
-
-(* Express border sub entries in function of the from level and an assoc *)
-(* We're cheating: not necessarily the same assoc on right and left *)
-let clever_explicitize_prod_entry pos univ from en =
-  let t = explicitize_prod_entry (fun x -> NumLevel x) pos univ en in
-  match from with
-    | ETConstr (from,()) ->
-	(match t with
-	  | ETConstr (n,BorderProd (left,None))
-              when (n=NumLevel from & left) ->
-	      ETConstr (n,BorderProd (left,Some Gramext.LeftA))
-	  | ETConstr (NumLevel n,BorderProd (left,None))
-              when (n=from-1 & not left) ->
-	      ETConstr
-                (NumLevel (n+1),BorderProd (left,Some Gramext.LeftA))
-	  | ETConstr (NumLevel n,BorderProd (left,None))
-              when (n=from-1 & left) ->
-	      ETConstr
-                (NumLevel (n+1),BorderProd (left,Some Gramext.RightA))
-	  | ETConstr (n,BorderProd (left,None))
-              when (n=NumLevel from & not left) ->
-	      ETConstr (n,BorderProd (left,Some Gramext.RightA))
-	  | t -> t)
-    | _ -> t
-
-let qualified_nterm current_univ pos from = function
-  | NtQual (univ, en) ->
-      clever_explicitize_prod_entry pos univ from en
-  | NtShort en ->
-      clever_explicitize_prod_entry pos current_univ from en
-
-let check_entry check_entry_type = function
-  | ETOther (u,n) -> check_entry_type (u,n)
-  | _ -> ()
-
-let nterm loc (((check_entry_type,univ),from),pos) nont =
-  let typ = qualified_nterm univ pos from nont in
-  check_entry check_entry_type typ;
-  typ
-
-let prod_item univ env = function
-  | VTerm s -> env, Term (terminal s)
-  | VNonTerm (loc, nt, Some p) ->
-     let typ = nterm loc univ nt in
-      (p :: env, NonTerm (typ, Some (p,typ)))
-  | VNonTerm (loc, nt, None) ->
-      let typ = nterm loc univ nt in 
-      env, NonTerm (typ, None)
-
-let rec prod_item_list univ penv pil current_pos =
-  match pil with
-    | [] -> [], penv
-    | pi :: pitl ->
-	let pos = if pitl=[] then (BorderProd (false,None)) else current_pos in
-	let (env, pic) = prod_item (univ,pos) penv pi in
-	let (pictl, act_env) = prod_item_list univ env pitl InternalProd in
-        (pic :: pictl, act_env)
-
-let gram_rule univ (name,pil,act) =
-  let (pilc, act_env) = prod_item_list univ [] pil (BorderProd (true,None)) in
-  let a = to_act_check_vars act_env act in
-  { gr_name = name; gr_production = pilc; gr_action = a }
-
-let border = function
-  | NonTerm (ETConstr(_,BorderProd (_,a)),_) :: _ -> a
-  | _ -> None
-
-let clever_assoc ass g =
-  if g.gr_production <> [] then
-    (match border g.gr_production, border (List.rev g.gr_production) with
-      | Some LeftA, Some RightA -> ass (* Untractable; we cheat *)
-      | Some LeftA, _ -> Some LeftA
-      | _, Some RightA -> Some RightA
-      | _ -> Some NonA)
-  else ass
-
-let gram_entry univ (nt, ass, rl) =
-  let from = explicitize_entry (snd univ) nt in
-  let l = List.map (gram_rule (univ,from)) rl in
-  let ass = List.fold_left clever_assoc ass l in
-  { ge_name = from;
-    gl_assoc = ass;
-    gl_rules = l }
-
-let interp_grammar_command univ ge entryl =
-  { gc_univ = univ;
-    gc_entries = List.map (gram_entry (ge,univ)) entryl }
-
-(* unparsing objects *)
-
-type 'pat unparsing_hunk = 
-  | PH of 'pat * string option * parenRelation
-  | RO of string
-  | UNP_BOX of ppbox * 'pat unparsing_hunk list
-  | UNP_BRK of int * int
-  | UNP_TBRK of int * int
-  | UNP_TAB
-  | UNP_FNL
-  | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk
-
-let rec subst_hunk subst_pat subst hunk = match hunk with
-  | PH (pat,so,pr) ->
-      let pat' = subst_pat subst pat in
-	if pat'==pat then hunk else
-	  PH (pat',so,pr)
-  | RO _ -> hunk
-  | UNP_BOX (ppbox, hunkl) ->
-      let hunkl' = list_smartmap (subst_hunk subst_pat subst) hunkl in
-	if hunkl' == hunkl then hunk else
-	  UNP_BOX (ppbox, hunkl')
-  | UNP_BRK _
-  | UNP_TBRK _
-  | UNP_TAB
-  | UNP_FNL -> hunk
-  | UNP_SYMBOLIC (s1, s2, pat) ->
-      let pat' = subst_hunk subst_pat subst pat in
-	if pat' == pat then hunk else
-	  UNP_SYMBOLIC (s1, s2, pat')
-
-(* Checks if the precedence of the parent printer (None means the
-   highest precedence), and the child's one, follow the given
-   relation. *)
-
-let tolerable_prec oparent_prec_reln child_prec =
-  match oparent_prec_reln with
-    | Some (pprec, L) -> child_prec < pprec
-    | Some (pprec, E) -> child_prec <= pprec
-    | Some (_, Prec level) -> child_prec <= level
-    | _ -> true
-
-type 'pat syntax_entry = {
-  syn_id : string;
-  syn_prec: precedence;
-  syn_astpat : 'pat;
-  syn_hunks : 'pat unparsing_hunk list }
-
-let subst_syntax_entry subst_pat subst sentry = 
-  let syn_astpat' = subst_pat subst sentry.syn_astpat in
-  let syn_hunks' = list_smartmap (subst_hunk subst_pat subst) sentry.syn_hunks 
-  in
-    if syn_astpat' == sentry.syn_astpat 
-      && syn_hunks' == sentry.syn_hunks then sentry 
-    else
-      { sentry with
-	  syn_astpat = syn_astpat' ;
-	  syn_hunks = syn_hunks' ;
-      }
-      
-type 'pat syntax_command = { 
-  sc_univ : string; 
-  sc_entries : 'pat syntax_entry list }
-
-let subst_syntax_command subst_pat subst scomm = 
-  let sc_entries' = 
-    list_smartmap (subst_syntax_entry subst_pat subst) scomm.sc_entries 
-  in
-    if sc_entries' == scomm.sc_entries then scomm else
-      { scomm with sc_entries = sc_entries' }
-      
-type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list
-type raw_syntax_entry = precedence * syntax_rule list
-
-let rec interp_unparsing env = function
-  | PH (ast,ext,pr) -> PH (Ast.val_of_ast env ast,ext,pr)
-  | UNP_BOX (b,ul) -> UNP_BOX (b,List.map (interp_unparsing env) ul)
-  | UNP_BRK _ | RO _ | UNP_TBRK _ | UNP_TAB | UNP_FNL as x -> x
-  | UNP_SYMBOLIC (x,y,u) -> UNP_SYMBOLIC (x,y,interp_unparsing env u)
-
-let rule_of_ast univ prec (s,spat,unp) =
-  let (astpat,meta_env) = Ast.to_pat [] spat in
-  let hunks = List.map (interp_unparsing meta_env) unp in
-  { syn_id = s;
-    syn_prec = prec;
-    syn_astpat = astpat;
-    syn_hunks = hunks }
-
-let level_of_ast univ (prec,rl) = List.map (rule_of_ast univ prec) rl
-
-let interp_syntax_entry univ sel =
-  { sc_univ = univ;
-    sc_entries = List.flatten (List.map (level_of_ast univ) sel)}
-
-
diff --git a/parsing/extend.mli b/parsing/extend.mli
index c5417649..80de7108 100644
--- a/parsing/extend.mli
+++ b/parsing/extend.mli
@@ -6,23 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extend.mli,v 1.19.2.2 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: extend.mli 7761 2005-12-30 10:52:19Z herbelin $ i*)
 
-(*i*)
-open Pp
 open Util
-open Names
-open Ast
-open Coqast
-open Ppextend
-open Topconstr
-open Genarg
-(*i*)
 
-type entry_type = argument_type
+(**********************************************************************)
+(* constr entry keys                                                  *)
+
+type side = Left | Right
 
 type production_position =
-  | BorderProd of bool * Gramext.g_assoc option  (* true=left; false=right *)
+  | BorderProd of side * Gramext.g_assoc option  (* true=left; false=right *)
   | InternalProd
 
 type production_level =
@@ -38,41 +32,13 @@ type ('lev,'pos) constr_entry_key =
 
 type constr_production_entry =
     (production_level,production_position) constr_entry_key
-type constr_entry = (int,unit) constr_entry_key
-type simple_constr_production_entry = (production_level,unit) constr_entry_key
-
-type nonterm_prod =
-  | ProdList0 of nonterm_prod
-  | ProdList1 of nonterm_prod * Token.pattern list
-  | ProdOpt of nonterm_prod
-  | ProdPrimitive of constr_production_entry
-
-type prod_item =
-  | Term of Token.pattern
-  | NonTerm of constr_production_entry * 
-      (Names.identifier * constr_production_entry) option
-
-type grammar_rule = {
-  gr_name : string; 
-  gr_production : prod_item list; 
-  gr_action : constr_expr }
-
-type grammar_entry = { 
-  ge_name : constr_entry;
-  gl_assoc : Gramext.g_assoc option;
-  gl_rules : grammar_rule list }
-
-type grammar_command = { 
-  gc_univ : string; 
-  gc_entries : grammar_entry list }
-
-type grammar_associativity = Gramext.g_assoc option
+type constr_entry =
+    (int,unit) constr_entry_key
+type simple_constr_production_entry =
+    (production_level,unit) constr_entry_key
 
-(* Globalisation and type-checking of Grammar actions *)
-type entry_context = identifier list
-
-val set_constr_globalizer : 
-  (entry_context -> constr_expr -> constr_expr) -> unit
+(**********************************************************************)
+(* syntax modifiers                                                   *)
 
 type syntax_modifier =
   | SetItemLevel of string list * production_level
@@ -82,73 +48,3 @@ type syntax_modifier =
   | SetOnlyParsing
   | SetFormat of string located
 
-type nonterm =
-  | NtShort of string
-  | NtQual of string * string
-type grammar_production =
-  | VTerm of string
-  | VNonTerm of loc * nonterm * Names.identifier option
-type raw_grammar_rule = string * grammar_production list * grammar_action
-type raw_grammar_entry = string * grammar_associativity * raw_grammar_rule list
-
-val terminal : string -> string * string
-
-val rename_command_entry : string -> string
-
-val explicitize_entry : string -> string -> constr_entry
-
-val subst_grammar_command : 
-  Names.substitution -> grammar_command -> grammar_command
-
-(* unparsing objects *)
-
-type 'pat unparsing_hunk = 
-  | PH of 'pat * string option * parenRelation
-  | RO of string
-  | UNP_BOX of ppbox * 'pat unparsing_hunk list
-  | UNP_BRK of int * int
-  | UNP_TBRK of int * int
-  | UNP_TAB
-  | UNP_FNL
-  | UNP_SYMBOLIC of string option * string * 'pat unparsing_hunk
-
-(*i
-val subst_unparsing_hunk : 
-  Names.substitution -> (Names.substitution -> 'pat -> 'pat) -> 
-  'pat unparsing_hunk -> 'pat unparsing_hunk
-i*)
-
-(* Checks if the precedence of the parent printer (None means the
-   highest precedence), and the child's one, follow the given
-   relation. *)
-
-val tolerable_prec : tolerability option -> precedence -> bool
-
-type 'pat syntax_entry = {
-  syn_id : string;
-  syn_prec: precedence;
-  syn_astpat : 'pat;
-  syn_hunks : 'pat unparsing_hunk list }
-
-val subst_syntax_entry : 
-  (Names.substitution -> 'pat -> 'pat) -> 
-  Names.substitution -> 'pat syntax_entry -> 'pat syntax_entry
-
-
-type 'pat syntax_command = { 
-  sc_univ : string; 
-  sc_entries : 'pat syntax_entry list }
-
-val subst_syntax_command : 
-  (Names.substitution -> 'pat -> 'pat) -> 
-  Names.substitution -> 'pat syntax_command -> 'pat syntax_command
-
-type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list
-type raw_syntax_entry = precedence * syntax_rule list
-
-val interp_grammar_command :
-  string -> (string * string -> unit) -> 
-      raw_grammar_entry list -> grammar_command
-
-val interp_syntax_entry :
-  string -> raw_syntax_entry list -> Ast.astpat syntax_command
diff --git a/parsing/g_ascii_syntax.ml b/parsing/g_ascii_syntax.ml
new file mode 100644
index 00000000..ac54fc63
--- /dev/null
+++ b/parsing/g_ascii_syntax.ml
@@ -0,0 +1,81 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Rawterm
+open Topconstr
+open Libnames
+open Coqlib
+open Bigint
+
+exception Non_closed_ascii
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let make_kn dir id = Libnames.encode_kn (make_dir dir) (id_of_string id)
+let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+
+let ascii_module = ["Coq";"Strings";"Ascii"]
+
+let ascii_path = make_path ascii_module "ascii"
+
+let ascii_kn = make_kn ascii_module "ascii"
+let path_of_Ascii = ((ascii_kn,0),1)
+let static_glob_Ascii  = ConstructRef path_of_Ascii
+
+let make_reference id = find_reference "Ascii interpretation" ascii_module id
+let glob_Ascii = lazy (make_reference "Ascii")
+
+open Lazy
+
+let interp_ascii dloc p =
+  let rec aux n p = 
+     if n = 0 then [] else
+     let mp = p mod 2 in
+     RRef (dloc,if mp = 0 then glob_false else glob_true)
+     :: (aux (n-1) (p/2)) in
+  RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p)
+
+let interp_ascii_string dloc s =
+  let p = 
+    if String.length s = 1 then int_of_char s.[0]
+    else
+      if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2]
+      then int_of_string s
+      else
+	user_err_loc (dloc,"interp_ascii_string",
+	  str "Expects a single character or a three-digits ascii code") in
+  interp_ascii dloc p
+
+let uninterp_ascii r =
+  let rec uninterp_bool_list n = function
+    | [] when n = 0 -> 0
+    | RRef (_,k)::l when k = glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
+    | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l)
+    | _ -> raise Non_closed_ascii in
+  try 
+    let rec aux = function
+    | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
+    | _ -> raise Non_closed_ascii in
+    Some (aux r)
+  with 
+   Non_closed_ascii -> None
+
+let make_ascii_string n =
+  if n>=32 && n<=126 then String.make 1 (char_of_int n)
+  else Printf.sprintf "%03d" n
+
+let uninterp_ascii_string r = option_map make_ascii_string (uninterp_ascii r)
+
+let _ =
+  Notation.declare_string_interpreter "char_scope"
+    (ascii_path,ascii_module)
+    interp_ascii_string
+    ([RRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true)
diff --git a/parsing/g_basevernac.ml4 b/parsing/g_basevernac.ml4
deleted file mode 100644
index c4badbc3..00000000
--- a/parsing/g_basevernac.ml4
+++ /dev/null
@@ -1,524 +0,0 @@
-(************************************************************************)
-(*  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: g_basevernac.ml4,v 1.83.2.2 2004/07/16 19:30:37 herbelin Exp $ *)
-
-open Coqast
-open Extend
-open Ppextend
-open Vernacexpr
-open Pcoq
-open Vernac_
-open Goptions
-open Constr
-open Prim
-
-let vernac_kw =
-  [ "Quit"; "Load"; "Compile"; "Fixpoint"; "CoFixpoint";
-    "Definition"; "Inductive"; "CoInductive"; 
-    "Theorem"; "Variable"; "Axiom"; "Parameter"; "Hypothesis";
-    "."; ">->" ]
-let _ = 
-  if !Options.v7 then
-    List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw
-
-let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr"
-let lstring = Gram.Entry.create "lstring"
-
-
-if !Options.v7 then
-GEXTEND Gram
-  GLOBAL: class_rawexpr;
-
-  class_rawexpr:
-    [ [ IDENT "FUNCLASS" -> FunClass
-      | IDENT "SORTCLASS" -> SortClass
-      | qid = global -> RefClass qid ] ]
-  ;
-END;
-
-if !Options.v7 then
-GEXTEND Gram
-  GLOBAL: command lstring;
-
-  lstring:
-    [ [ s = STRING -> s ] ]
-  ;
-  comment:
-    [ [ c = constr -> CommentConstr c
-      | s = STRING -> CommentString s
-      | n = natural -> CommentInt n ] ]
-  ;
-  command:
-    [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l
-
-      (* System directory *)
-      | IDENT "Pwd" -> VernacChdir None
-      | IDENT "Cd" -> VernacChdir None
-      | IDENT "Cd"; dir = lstring -> VernacChdir (Some dir)
-
-      (* Toplevel control *)
-      | IDENT "Drop" -> VernacToplevelControl Drop
-      | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop
-      | "Quit" -> VernacToplevelControl Quit
-
-      (* Dump of the universe graph - to file or to stdout *) 
-      | IDENT "Dump"; IDENT "Universes"; fopt = OPT lstring ->
-	  VernacPrint (PrintUniverses fopt)
-
-      | IDENT "Locate"; l = locatable -> VernacLocate l
-
-      (* Managing load paths *)
-      | IDENT "Add"; IDENT "LoadPath"; dir = lstring; alias = as_dirpath ->
-	  VernacAddLoadPath (false, dir, alias)
-      | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = lstring; 
-	  alias = as_dirpath -> VernacAddLoadPath (true, dir, alias)
-      | IDENT "Remove"; IDENT "LoadPath"; dir = lstring ->
-	  VernacRemoveLoadPath dir
-
-       (* For compatibility *)
-      | IDENT "AddPath"; dir = lstring; alias = as_dirpath ->
-	  VernacAddLoadPath (false, dir, alias)
-      | IDENT "AddRecPath"; dir = lstring; alias = as_dirpath ->
-	  VernacAddLoadPath (true, dir, alias)
-      | IDENT "DelPath"; dir = lstring ->
-	  VernacRemoveLoadPath dir
-
-      (* Printing (careful factorization of entries) *)
-      | IDENT "Print"; p = printable -> VernacPrint p
-      | IDENT "Print"; qid = global -> VernacPrint (PrintName qid)
-      | IDENT "Print" -> VernacPrint PrintLocalContext 
-      | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> 
-	  VernacPrint (PrintModuleType qid)
-      | IDENT "Print"; IDENT "Module"; qid = global -> 
-	  VernacPrint (PrintModule qid)
-      | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n)
-      | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid)
-
-      (* Searching the environment *)
-      | IDENT "Search"; qid = global; l = in_or_out_modules -> 
-	  VernacSearch (SearchHead qid, l)
-      | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules ->
-	  VernacSearch (SearchPattern c, l)
-      | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
-	  VernacSearch (SearchRewrite c, l)
-      | IDENT "SearchAbout"; 
-	  sl = [ "["; l = LIST1 [ r = global -> SearchRef r
-                                  | s = lstring -> SearchString s ]; "]" -> l 
-   		 | qid = global -> [SearchRef qid] ];
-	  l = in_or_out_modules -> 
-	  VernacSearch (SearchAbout sl, l)
-
-      (* TODO: rapprocher Eval et Check *)
-      | IDENT "Eval"; r = Tactic.red_expr; "in";
-	  c = constr -> VernacCheckMayEval (Some r, None, c)
-      | IDENT "Check"; c = constr ->
-	  VernacCheckMayEval (None, None, c)
-      | "Type"; c = constr -> VernacGlobalCheck c      (* pas dans le RefMan *)
-
-      | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = lstring ->
-	  VernacAddMLPath (false, dir)
-      | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = lstring ->
-	  VernacAddMLPath (true, dir)
-(*
-      | IDENT "SearchIsos"; c = constr -> VernacSearch (SearchIsos c)
-*)
-
-      (* Pour intervenir sur les tables de paramètres *)
-
-      | "Set"; table = IDENT; field = IDENT; v = option_value ->
-  	  VernacSetOption (SecondaryTable (table,field),v)
-      | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
-  	  VernacAddOption (SecondaryTable (table,field),lv)
-      | "Set"; table = IDENT; field = IDENT ->
-  	  VernacSetOption (SecondaryTable (table,field),BoolValue true)
-      | IDENT "Unset"; table = IDENT; field = IDENT ->
-  	  VernacUnsetOption (SecondaryTable (table,field))
-      | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
-  	  VernacRemoveOption (SecondaryTable (table,field),lv)
-      | "Set"; table = IDENT; value = option_value ->
-  	  VernacSetOption (PrimaryTable table, value)
-      | "Set"; table = IDENT ->
-  	  VernacSetOption (PrimaryTable table, BoolValue true)
-      | IDENT "Unset"; table = IDENT ->
-  	  VernacUnsetOption (PrimaryTable table)
-
-      | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT ->
-	  VernacPrintOption (SecondaryTable (table,field))
-      | IDENT "Print"; IDENT "Table"; table = IDENT ->
-	  VernacPrintOption (PrimaryTable table)
-
-      | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
-        -> VernacAddOption (SecondaryTable (table,field), v)
-
-      (* Un value global ci-dessous va être caché par un field au dessus! *)
-      | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value ->
-          VernacAddOption (PrimaryTable table, v)
-
-      | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
-        -> VernacMemOption (SecondaryTable (table,field), v)
-      | IDENT "Test"; table = IDENT; field = IDENT ->
-          VernacPrintOption (SecondaryTable (table,field))
-      | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value ->
-          VernacMemOption (PrimaryTable table, v)
-      | IDENT "Test"; table = IDENT ->
-          VernacPrintOption (PrimaryTable table)
-
-      | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value
-        -> VernacRemoveOption (SecondaryTable (table,field), v)
-      | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
-	  VernacRemoveOption (PrimaryTable table, v) ] ]
-  ;
-  printable:
-    [ [ IDENT "Term"; qid = global -> PrintOpaqueName qid
-      | IDENT "All" -> PrintFullContext
-      | IDENT "Section"; s = global -> PrintSectionContext s
-      | IDENT "Grammar"; uni = IDENT; ent = IDENT ->
-          (* This should be in "syntax" section but is here for factorization*)
-	  PrintGrammar (uni, ent)
-      | IDENT "LoadPath" -> PrintLoadPath
-      | IDENT "Modules" -> PrintModules
-
-      | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath
-      | IDENT "ML"; IDENT "Modules" -> PrintMLModules
-      | IDENT "Graph" -> PrintGraph
-      | IDENT "Classes" ->  PrintClasses
-      | IDENT "Coercions" -> PrintCoercions
-      | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr
-         -> PrintCoercionPaths (s,t)
-      | IDENT "Tables" -> PrintTables
-      | "Proof"; qid = global -> PrintOpaqueName qid
-      | IDENT "Hint" -> PrintHintGoal
-      | IDENT "Hint"; qid = global -> PrintHint qid
-      | IDENT "Hint"; "*" -> PrintHintDb
-      | IDENT "HintDb"; s = IDENT -> PrintHintDbName s
-      | IDENT "Scopes" -> PrintScopes
-      | IDENT "Scope"; s = IDENT -> PrintScope s
-      | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s
-      | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ]
-  ;
-  locatable:
-    [ [ qid = global -> LocateTerm qid
-      | IDENT "File"; f = lstring -> LocateFile f
-      | IDENT "Library"; qid = global -> LocateLibrary  qid
-      | s = lstring -> LocateNotation s ] ]
-  ;
-  option_value:
-    [ [ n  = integer   -> IntValue n
-      | s  = lstring    -> StringValue s ] ]
-  ;
-  option_ref_value:
-    [ [ id = global   -> QualidRefValue id
-      | s  = lstring   -> StringRefValue s ] ]
-  ;
-  as_dirpath:
-    [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ]
-  ;
-  in_or_out_modules:
-    [ [ IDENT "inside"; l = LIST1 global -> SearchInside l
-      | IDENT "outside"; l = LIST1 global -> SearchOutside l
-      | -> SearchOutside [] ] ]
-  ;
-END
-
-(* Grammar extensions *)
-
-(* automatic translation of levels *)
-let adapt_level n =
-  if n >= 10 then n*10 else
-    [| 0; 20; 30; 40; 50; 70; 80; 85; 90; 95; 100|].(n)
-
-let map_modl = function
-  | SetItemLevel(ids,NumLevel n) -> SetItemLevel(ids,NumLevel (adapt_level n))
-  | SetLevel n -> SetLevel(adapt_level n)
-  | m -> m
-	  
-if !Options.v7 then
-GEXTEND Gram
-  GLOBAL: syntax;
-
-  univ:
-  [ [ univ = IDENT ->
-        set_default_action_parser (parser_type_from_name univ); univ ] ]
-  ;
-  syntax:
-   [ [ IDENT "Token"; s = lstring ->
-       Pp.warning "Token declarations are now useless"; VernacNop
-
-     | IDENT "Grammar"; IDENT "tactic"; IDENT "simple_tactic";
-        OPT [ ":"; IDENT "tactic" ]; ":=";
-        OPT "|"; tl = LIST0 grammar_tactic_rule SEP "|" -> 
-	  VernacTacticGrammar tl
-
-     | IDENT "Grammar"; u = univ;
-         tl = LIST1 grammar_entry SEP "with" -> 
-	   VernacGrammar (rename_command_entry u,tl)
-
-     | IDENT "Syntax"; u = univ; el = LIST1 syntax_entry SEP ";" ->
-         VernacSyntax (u,el)
-
-     | IDENT "Uninterpreted"; IDENT "Notation"; local = locality; s = lstring; 
-	 modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
-         (s8,mv8) =
-             [IDENT "V8only";
-              s8=OPT lstring;
-              mv8=OPT["(";mv8=LIST1 syntax_modifier SEP ","; ")" -> mv8] ->
-                (s8,mv8)
-             | -> (None,None)] ->
-               let s8 = match s8 with Some s -> s | _ -> s in
-               let mv8 = match mv8 with
-                   Some mv8 -> mv8
-                 | _ -> List.map map_modl modl in
-	       VernacSyntaxExtension (local,Some (s,modl),Some(s8,mv8))
-
-     | IDENT "Uninterpreted"; IDENT "V8Notation"; local = locality; s = lstring; 
-	 modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] ->
-	   VernacSyntaxExtension (local,None,Some(s,modl))
-
-     | IDENT "Open"; local = locality; IDENT "Scope"; 
-	 sc = IDENT -> VernacOpenCloseScope (local,true, sc)
-
-     | IDENT "Close"; local = locality; IDENT "Scope"; 
-	 sc = IDENT -> VernacOpenCloseScope (local,false,sc)
-
-     | IDENT "Delimits"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT ->
-	 VernacDelimiters (sc,key)
-
-     | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; 
-       refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
-
-     | IDENT "Arguments"; IDENT "Scope"; qid = global;
-         "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl)
-
-     | IDENT "Infix"; local = locality; a = entry_prec; n = OPT natural;
-         op = lstring; 
-         p = global;
-         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
-	 sc = OPT [ ":"; sc = IDENT -> sc];
-         mv8 =
-              [IDENT "V8only";
-               a8=entry_prec;
-               n8=OPT natural;
-	       op8=OPT lstring;
-               mv8=["("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> []]
-		->
-		 (match (a8,n8,mv8,op8) with
-		   | None,None,[],None -> None
-		   | _,_,mv8,_ ->
-		       Some(op8,Metasyntax.merge_modifiers a8 n8 mv8))
-              | -> (* Means: rules are based on V7 rules *)
-		  Some (None,[]) ] ->
-		let mv = Metasyntax.merge_modifiers a n modl in
-		let v8 = Util.option_app (function (op8,mv8) ->
-		  let op8 = match op8 with None -> op | Some op -> op in
-		  let mv8 =
-		    if mv8=[] then
-		      let mv8 = List.map map_modl mv in
-		      let mv8 =	if List.for_all
-			(function SetLevel _ -> false | _ -> true) mv8
-		      then SetLevel 10 :: mv8 else mv8 in
-		      let mv8 = if List.for_all
-			(function SetAssoc _ -> false | _ -> true) mv8
-		      then SetAssoc Gramext.LeftA :: mv8 else mv8 in
-		      mv8
-		  else mv8 in
-		  (op8,mv8)) mv8 in
-		VernacInfix (local,(op,mv),p,v8,sc)
-     | IDENT "Distfix"; local = locality; a = entry_prec; n = natural; 
-	   s = lstring; p = global; sc = OPT [ ":"; sc = IDENT -> sc ] ->
-             let (a,s,c) = Metasyntax.translate_distfix a s p in
-	     let mv = Some(s,[SetLevel n;SetAssoc a]) in
-             VernacNotation (local,c,mv,mv,sc)
-(*
-	     VernacDistfix (local,a,n,s,p,sc)
-*)
-     | IDENT "Notation"; local = locality; id = ident; ":="; c = constr;
-         b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] ->
-	 VernacSyntacticDefinition (id,c,local,b)
-     | IDENT "Notation"; local = locality; s = lstring; ":="; c = constr;
-         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
-	 sc = OPT [ ":"; sc = IDENT -> sc ];
-         (s8,mv8) =
-             [IDENT "V8only";
-              s8=OPT lstring;
-              mv8=OPT["(";mv8=LIST1 syntax_modifier SEP ","; ")" -> mv8] ->
-		(s8,mv8)
-             | -> (* Means: rules are based on V7 rules *)
-		 None, Some [] ] ->
-	       let smv8 = match s8,mv8 with
-		 | None, None -> None   (* = only interpretation *)
-		 | Some s8, None -> Some (s8,[]) (* = only interp, new s *)
-		 | None, Some [] -> Some (s,List.map map_modl modl) (*like v7*)
-		 | None, Some mv8 -> Some (s,mv8) (* s like v7 *)
-		 | Some s8, Some mv8 -> Some (s8,mv8) in
-               VernacNotation (local,c,Some(s,modl),smv8,sc)
-     | IDENT "V8Notation"; local = locality; s = lstring; ":="; c = constr;
-         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
-	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
-         VernacNotation (local,c,None,Some(s,modl),sc)
-
-     | IDENT "V8Infix"; local = locality; op8 = lstring; p = global;
-         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
-	 sc = OPT [ ":"; sc = IDENT -> sc] ->
-           let mv8 = Metasyntax.merge_modifiers None None modl in
-           VernacInfix (local,("",[]),p,Some (op8,mv8),sc)
-
-     (* "Print" "Grammar" should be here but is in "command" entry in order 
-        to factorize with other "Print"-based vernac entries *)
-  ] ]
-  ;
-  locality:
-    [ [ IDENT "Local" -> true | -> false ] ]
-  ;
-  level:
-    [ [ IDENT "level"; n = natural -> NumLevel n
-      | IDENT "next"; IDENT "level" -> NextLevel ] ]
-  ;
-  syntax_modifier:
-    [ [ x = IDENT; IDENT "at"; lev = level -> SetItemLevel ([x],lev)
-      | x = IDENT; ","; l = LIST1 IDENT SEP ","; IDENT "at"; lev = level ->
-          SetItemLevel (x::l,lev)
-      | IDENT "at"; IDENT "level"; n = natural -> SetLevel n
-      | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA
-      | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA
-      | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA
-      | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ)
-      | IDENT "only"; IDENT "parsing" -> SetOnlyParsing
-      | IDENT "format"; s = [s = lstring -> (loc,s)] -> SetFormat s ] ]
-  ;
-  syntax_extension_type:
-    [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference
-      | IDENT "bigint" -> ETBigint
-      | i=IDENT -> ETOther ("constr",i)
-    ] ]
-  ;
-  opt_scope:
-    [ [ IDENT "_" -> None | sc = IDENT -> Some sc ] ]
-  ;
-  (* Syntax entries for Grammar. Only grammar_entry is exported *)
-  grammar_entry:
-    [[ nont = IDENT; set_entry_type; ":=";
-       ep = entry_prec; OPT "|"; rl = LIST0 grammar_rule SEP "|" ->
-	 (rename_command_entry nont,ep,rl) ]]
-  ;
-  entry_prec:
-    [[ IDENT "LEFTA" -> Some Gramext.LeftA
-     | IDENT "RIGHTA" -> Some Gramext.RightA
-     | IDENT "NONA" -> Some Gramext.NonA
-     | -> None ]]
-  ;
-  grammar_tactic_rule:
-    [[ name = rule_name; "["; s = lstring; pil = LIST0 production_item; "]";
-       "->"; "["; t = Tactic.tactic; "]"  -> (name, (s,pil), t) ]]
-  ;
-  grammar_rule:
-    [[ name = rule_name; "["; pil = LIST0 production_item; "]"; "->";
-       a = action -> (name, pil, a) ]]
-  ;
-  rule_name:
-    [[ name = IDENT -> name ]]
-  ;
-  production_item:
-    [[ s = lstring -> VTerm s
-     | nt = non_terminal; po = OPT [ "("; p = METAIDENT; ")" -> p ] ->
-         match po with
-           | Some p -> VNonTerm (loc,nt,Some (Names.id_of_string p))
-           | _ -> VNonTerm (loc,nt,None) ]]
-  ;
-  non_terminal:
-    [[ u = IDENT; ":"; nt = IDENT ->
-        NtQual(rename_command_entry u, rename_command_entry nt)
-     | nt = IDENT -> NtShort (rename_command_entry nt) ]]
-  ;
-
-
-  (* Syntax entries for Syntax. Only syntax_entry is exported *)
-  syntax_entry:
-    [ [ IDENT "level"; p = precedence; ":";
-	OPT "|"; rl = LIST1 syntax_rule SEP "|" -> (p,rl) ] ]
-  ;
-  syntax_rule:
-    [ [ nm = IDENT; "["; s = astpat; "]"; "->"; u = unparsing -> (nm,s,u) ] ]
-  ;
-  precedence:
-    [ [ a = natural -> a
-(*      | "["; a1 = natural; a2 = natural; a3 = natural; "]" -> (a1,a2,a3)*)
-    ] ]
-  ;
-  unparsing:
-    [ [ "["; ll = LIST0 next_hunks; "]" -> ll ] ]
-  ;
-  next_hunks:
-    [ [ IDENT "FNL" -> UNP_FNL
-      | IDENT "TAB" -> UNP_TAB
-      | c = lstring -> RO c
-      | "[";
-        x =
-          [ b = box; ll = LIST0 next_hunks -> UNP_BOX (b,ll)
-          | n = natural; m = natural -> UNP_BRK (n, m)
-          | IDENT "TBRK"; n = natural; m = natural -> UNP_TBRK (n, m) ];
-        "]" -> x
-      | e = Prim.ast; oprec = OPT [ ":"; pr = paren_reln_or_extern -> pr ] ->
-          match oprec with
-	    | Some (ext,pr) -> PH (e,ext,pr)
-            | None -> PH (e,None,Any)
- ]]
-  ;
-  box:
-    [ [ "<"; bk = box_kind; ">" -> bk ] ]
-  ;
-  box_kind:
-    [ [ IDENT "h"; n = natural -> PpHB n
-      | IDENT "v"; n = natural -> PpVB n
-      | IDENT "hv"; n = natural -> PpHVB n
-      | IDENT "hov"; n = natural -> PpHOVB n
-      | IDENT "t" -> PpTB ] ]
-  ;
-  paren_reln_or_extern:
-    [ [ IDENT "L" -> None, L
-      | IDENT "E" -> None, E
-      | pprim = lstring; precrec = OPT [ ":"; p = precedence -> p ] ->
-	  match precrec with
-	    | Some p -> Some pprim, Prec p
-            | None -> Some pprim, Any ] ]
-  ;
-  (* meta-syntax entries *)
-  astpat:
-    [ [ "<<" ; a = Prim.ast; ">>" -> a 
-      | a = Constr.constr -> 
-	  Termast.ast_of_rawconstr 
-	  (Constrintern.interp_rawconstr Evd.empty (Global.env()) a)
-    ] ]
-  ; 
-  action:
-    [ [ IDENT "let"; p = Prim.astlist; et = set_internal_entry_type;
-        "="; e1 = action; "in"; e = action -> Ast.CaseAction (loc,e1,et,[p,e])
-      | IDENT "case"; a = action; et = set_internal_entry_type; "of";
-        cl = LIST1 case SEP "|"; IDENT "esac" -> Ast.CaseAction (loc,a,et,cl)
-      | "["; a = default_action_parser; "]" -> Ast.SimpleAction (loc,a) ] ]
-  ;
-  case:
-    [[ p = Prim.astlist; "->"; a = action -> (p,a) ]]
-  ;
-  set_internal_entry_type:
-    [[ ":"; IDENT "ast"; IDENT "list" -> Ast.ETastl
-     | [ ":"; IDENT "ast" -> () | -> () ] -> Ast.ETast ]]
-  ;
-  set_entry_type:
-    [[ ":"; et = entry_type -> set_default_action_parser et
-     | -> () ]]
-  ;
-  entry_type:
-    [[ IDENT "ast"; IDENT "list" -> Util.error "type ast list no longer supported"
-     | IDENT "ast" -> Util.error "type ast no longer supported"
-     | IDENT "constr" -> ConstrParser
-     | IDENT "pattern" -> CasesPatternParser
-     | IDENT "tactic" -> assert false
-     | IDENT "vernac" -> Util.error "vernac extensions no longer supported" ] ]
-  ;
-END
diff --git a/parsing/g_cases.ml4 b/parsing/g_cases.ml4
deleted file mode 100644
index b952305d..00000000
--- a/parsing/g_cases.ml4
+++ /dev/null
@@ -1,73 +0,0 @@
-(************************************************************************)
-(*  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: g_cases.ml4,v 1.27.2.1 2004/07/16 19:30:38 herbelin Exp $ *)
-
-open Pcoq
-open Constr
-open Topconstr
-open Term
-open Libnames
-
-open Prim
-
-let pair loc =
-  Qualid (loc, Libnames.qualid_of_string "Coq.Init.Datatypes.pair")
-
-if !Options.v7 then
-GEXTEND Gram
-  GLOBAL: operconstr pattern;
-
-  pattern:
-    [ [ r = Prim.reference -> CPatAtom (loc,Some r)
-      | IDENT "_" -> CPatAtom (loc,None)
-      (* Hack to parse syntax "(n)" as a natural number *)
-      | "("; G_constr.test_int_rparen; n = bigint; ")" ->
-	  (* Delimiter "N" moved to "nat" in V7 *)
-          CPatDelimiters (loc,"nat",CPatNumeral (loc,n))
-      | "("; p = compound_pattern; ")" -> p
-      | n = bigint -> CPatNumeral (loc,n)
-      | "'"; G_constr.test_ident_colon; key = IDENT; ":"; c = pattern; "'" -> 
-          CPatDelimiters (loc,key,c)
-    ] ]
-  ;
-  compound_pattern:
-    [ [ p = pattern ; lp = LIST1 pattern ->
-        (match p with
-          | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
-          | _ -> Util.user_err_loc 
-              (loc, "compound_pattern", Pp.str "Constructor expected"))
-      | p = pattern; "as"; id = base_ident ->
-	  CPatAlias (loc, p, id)
-      | p1 = pattern; ","; p2 = pattern ->
-	  CPatCstr (loc, pair loc, [p1; p2])
-      | p = pattern -> p ] ]
-  ;
-  equation:
-    [ [ lhs = LIST1 pattern; "=>"; rhs = operconstr LEVEL "9" -> (loc,lhs,rhs) ] ]
-  ;
-  ne_eqn_list:
-    [ [ leqn = LIST1 equation SEP "|" -> leqn ] ]
-  ;
-  operconstr: LEVEL "1"
-    [ [ "<"; p = annot; ">"; "Cases"; lc = LIST1 constr; "of";
-        OPT "|"; eqs = ne_eqn_list; "end" ->
-          let lc = List.map (fun c -> c,(None,None)) lc in
-	  CCases (loc, (Some p,None), lc, eqs)
-      | "Cases"; lc = LIST1 constr; "of";
-	OPT "|"; eqs = ne_eqn_list; "end" ->
-          let lc = List.map (fun c -> c,(None,None)) lc in
-	  CCases (loc, (None,None), lc, eqs)
-      | "<"; p = annot; ">"; "Cases"; lc = LIST1 constr; "of"; "end" ->
-          let lc = List.map (fun c -> c,(None,None)) lc in
-	  CCases (loc, (Some p,None), lc, [])
-      | "Cases"; lc = LIST1 constr; "of"; "end" -> 
-          let lc = List.map (fun c -> c,(None,None)) lc in
-	  CCases (loc, (None,None), lc, []) ] ]
-  ;
-END;
diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4
index 80dc69f1..9163f3c1 100644
--- a/parsing/g_constr.ml4
+++ b/parsing/g_constr.ml4
@@ -6,129 +6,128 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_constr.ml4,v 1.52.2.2 2004/11/17 12:48:35 herbelin Exp $ *)
+(* $Id: g_constr.ml4 9562 2007-01-31 09:00:36Z msozeau $ *)
 
 open Pcoq
 open Constr
+open Prim
 open Rawterm
 open Term
 open Names
 open Libnames
-open Prim
 open Topconstr
 
-(* Initialize the lexer *)
+open Util
+
 let constr_kw =
-  [ "Cases"; "of"; "with"; "end"; "as"; "in"; "Prop"; "Set"; "Type";
-    ":"; "("; ")"; "["; "]"; "{"; "}"; ","; ";"; "->"; "="; ":="; "!";
-    "::"; "<:"; ":<"; "=>"; "<"; ">"; "|"; "?"; "/";
-    "<->"; "\\/"; "/\\"; "`"; "``"; "&"; "*"; "+"; "@"; "^"; "#"; "-";
-    "~"; "'"; "<<"; ">>"; "<>"; ".."
-  ]
-let _ =
-  if !Options.v7 then
-  List.iter (fun s -> Lexer.add_token ("",s)) constr_kw
-(* "let" is not a keyword because #Core#let.cci would not parse.
-   Is it still accurate ? *)
+  [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; 
+    "end"; "as"; "let"; "if"; "then"; "else"; "return";
+    "Prop"; "Set"; "Type"; ".("; "_"; ".." ]
 
+let _ = List.iter (fun s -> Lexer.add_token("",s)) constr_kw
 
-let coerce_to_var = function
-  | CRef (Ident (_,id)) -> id
-  | ast -> Util.user_err_loc
-        (constr_loc ast,"Ast.coerce_to_var",
-         (Pp.str"This expression should be a simple identifier"))
+let mk_cast = function
+    (c,(_,None)) -> c
+  | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv DEFAULTcast, ty)
 
-let coerce_to_name = function
-  | CRef (Ident (loc,id)) -> (loc, Name id)
-  | ast -> Util.user_err_loc
-        (constr_loc ast,"Ast.coerce_to_var",
-         (Pp.str"This expression should be a simple identifier"))
+let mk_lam = function
+    ([],c) -> c
+  | (bl,c) -> CLambdaN(constr_loc c, bl,c)
 
-let set_loc loc = function
-  | CRef(Ident(_,i)) -> CRef(Ident(loc,i))
-  | CRef(Qualid(_,q)) -> CRef(Qualid(loc,q))
-  | CFix(_,x,a) -> CFix(loc,x,a)
-  | CCoFix(_,x,a) -> CCoFix(loc,x,a)
-  | CArrow(_,a,b) -> CArrow(loc,a,b)
-  | CProdN(_,bl,a) -> CProdN(loc,bl,a)
-  | CLambdaN(_,bl,a) -> CLambdaN(loc,bl,a)
-  | CLetIn(_,x,a,b) -> CLetIn(loc,x,a,b)
-  | CAppExpl(_,f,a) -> CAppExpl(loc,f,a)
-  | CApp(_,f,a) -> CApp(loc,f,a)
-  | CCases(_,p,a,br) -> CCases(loc,p,a,br)
-  | COrderedCase(_,s,p,a,br) -> COrderedCase(loc,s,p,a,br)
-  | CLetTuple(_,ids,p,a,b) -> CLetTuple(loc,ids,p,a,b)
-  | CIf(_,e,p,a,b) -> CIf(loc,e,p,a,b)
-  | CHole _ -> CHole loc
-  | CPatVar(_,v) -> CPatVar(loc,v)
-  | CEvar(_,ev) -> CEvar(loc,ev)
-  | CSort(_,s) -> CSort(loc,s)
-  | CCast(_,a,b) -> CCast(loc,a,b)
-  | CNotation(_,n,l) -> CNotation(loc,n,l)
-  | CNumeral(_,i) -> CNumeral(loc,i)
-  | CDelimiters(_,s,e) -> CDelimiters(loc,s,e)
-  | CDynamic(_,d) -> CDynamic(loc,d)
+let loc_of_binder_let = function
+  | LocalRawAssum ((loc,_)::_,_)::_ -> loc
+  | LocalRawDef ((loc,_),_)::_ -> loc
+  | _ -> dummy_loc
 
-open Util
+let rec mkCProdN loc bll c =
+  match bll with
+  | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> 
+      CProdN (loc,[idl,t],mkCProdN (join_loc loc1 loc) bll c)
+  | LocalRawDef ((loc1,_) as id,b) :: bll -> 
+      CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c)
+  | [] -> c
+  | LocalRawAssum ([],_) :: bll -> mkCProdN loc bll c
 
-let rec abstract_constr loc c = function
+let rec mkCLambdaN loc bll c =
+  match bll with
+  | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> 
+      CLambdaN (loc,[idl,t],mkCLambdaN (join_loc loc1 loc) bll c)
+  | LocalRawDef ((loc1,_) as id,b) :: bll -> 
+      CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c)
   | [] -> c
-  | LocalRawDef ((loc',x),b)::bl ->
-      CLetIn (join_loc loc' loc, (loc', x), b, abstract_constr loc c bl)
-  | LocalRawAssum (nal,t)::bl ->
-      let loc' = join_loc (fst (List.hd nal)) loc in
-      CLambdaN(loc', [nal, t], abstract_constr loc c bl)
+  | LocalRawAssum ([],_) :: bll -> mkCLambdaN loc bll c
 
-(* Hack to parse "(n)" as nat without conflicts with the (useless) *)
-(* admissible notation "(n)" *)
-let test_int_rparen =
-  Gram.Entry.of_parser "test_int_rparen"
-    (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("INT", _)] ->
-            begin match Stream.npeek 2 strm with
-              | [_; ("", ")")] -> ()
-              | _ -> raise Stream.Failure
-            end
-        | _ -> raise Stream.Failure)
+let rec index_and_rec_order_of_annot loc bl ann =
+  match names_of_local_assums bl,ann with
+    | [_], (None, r) -> Some 0, r
+    | lids, (Some x, ro) ->
+        let ids = List.map snd lids in
+        (try Some (list_index (snd x) ids - 1), ro
+        with Not_found ->
+          user_err_loc(fst x,"index_of_annot", Pp.str"no such fix variable"))
+    | _, (None, r) -> None, r
 
-(* Hack to parse "n" at level 0 without conflicting with "n!" at level 91 *)
-(* admissible notation "(n)" *)
-let test_int_bang =
-  Gram.Entry.of_parser "test_int_bang"
-    (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("INT", n)] ->
-            begin match Stream.npeek 2 strm with
-              | [_; ("", "!")] -> ()
-              | _ -> raise Stream.Failure
-            end
-        | _ -> raise Stream.Failure)
+let mk_fixb (id,bl,ann,body,(loc,tyc)) =
+  let n,ro = index_and_rec_order_of_annot (fst id) bl ann in
+  let ty = match tyc with
+      Some ty -> ty
+    | None -> CHole loc in
+  (snd id,(n,ro),bl,ty,body)
+
+let mk_cofixb (id,bl,ann,body,(loc,tyc)) =
+  let _ = option_map (fun (aloc,_) ->
+    Util.user_err_loc
+      (aloc,"Constr:mk_cofixb",
+       Pp.str"Annotation forbidden in cofix expression")) (fst ann) in
+  let ty = match tyc with
+      Some ty -> ty
+    | None -> CHole loc in
+  (snd id,bl,ty,body)
+
+let mk_fix(loc,kw,id,dcls) =
+  if kw then 
+    let fb = List.map mk_fixb dcls in
+    CFix(loc,id,fb)
+  else
+    let fb = List.map mk_cofixb dcls in
+    CCoFix(loc,id,fb)
+
+let mk_single_fix (loc,kw,dcl) =
+  let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl])
 
-(* Hack to parse "`id:...`" at level 0 without conflicting with
-   "`...`" from ZArith *)
-let test_ident_colon =
-  Gram.Entry.of_parser "test_ident_colon"
+let binder_constr =
+  create_constr_entry (get_univ "constr") "binder_constr"
+
+(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
+(* admissible notation "(x t)" *)
+let lpar_id_coloneq =
+  Gram.Entry.of_parser "test_lpar_id_coloneq"
     (fun strm ->
       match Stream.npeek 1 strm with
-        | [("IDENT", _)] ->
-            begin match Stream.npeek 2 strm with
-              | [_; ("", ":")] -> ()
-              | _ -> raise Stream.Failure
-            end
+        | [("","(")] ->
+            (match Stream.npeek 2 strm with
+	      | [_; ("IDENT",s)] ->
+                  (match Stream.npeek 3 strm with
+                    | [_; _; ("", ":=")] ->
+                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
+                        Names.id_of_string s
+	            | _ -> raise Stream.Failure)
+              | _ -> raise Stream.Failure)
         | _ -> raise Stream.Failure)
 
 
-if !Options.v7 then
 GEXTEND Gram
-  GLOBAL: operconstr lconstr constr sort global constr_pattern Constr.ident annot
-          (*ne_name_comma_list*);
+  GLOBAL: binder_constr lconstr constr operconstr sort global
+  constr_pattern lconstr_pattern Constr.ident binder binder_let pattern;
   Constr.ident:
     [ [ id = Prim.ident -> id
 
       (* This is used in quotations and Syntax *)
       | id = METAIDENT -> id_of_string id ] ]
   ;
+  Prim.name:
+    [ [ "_" -> (loc, Anonymous) ] ]
+  ;
   global:
     [ [ r = Prim.reference -> r
 
@@ -138,231 +137,205 @@ GEXTEND Gram
   constr_pattern:
     [ [ c = constr -> c ] ]
   ;
-  ne_constr_list:
-    [ [ cl = LIST1 constr -> cl ] ]
+  lconstr_pattern:
+    [ [ c = lconstr -> c ] ]
   ;
   sort:
     [ [ "Set"  -> RProp Pos
       | "Prop" -> RProp Null
       | "Type" -> RType None ] ]
   ;
-  constr:
-    [ [ c = operconstr LEVEL "8" -> c ] ]
-  ;
   lconstr:
-    [ [ c = operconstr LEVEL "10" -> c ] ]
+    [ [ c = operconstr LEVEL "200" -> c ] ]
+  ;
+  constr:
+    [ [ c = operconstr LEVEL "9" -> c ] ]
   ;
   operconstr:
-    [ "10" RIGHTA
-      [ "!"; f = global; args = LIST0 (operconstr LEVEL "9") ->
-          CAppExpl (loc, (None,f), args)
-(*
-      | "!"; f = global; "with"; b = binding_list ->
-	  <:ast< (APPLISTWITH $f $b) >>
-*)
-      | f = operconstr; args = LIST1 constr91 -> CApp (loc, (None,f), args) ]
-    | "9" RIGHTA
-      [ c1 = operconstr; "::"; c2 = operconstr LEVEL "9" -> CCast (loc, c1, c2) ]
-    | "8" RIGHTA
-      [ c1 = operconstr; "->"; c2 = operconstr LEVEL "8"-> CArrow (loc, c1, c2) ]
-    | "1" RIGHTA
-      [ "<"; p = annot; ">"; IDENT "Match"; c = constr; "with";
-        cl = LIST0 constr; "end" ->
-	  COrderedCase (loc, MatchStyle, Some p, c, cl)
-      | "<"; p = annot; ">"; IDENT "Case"; c = constr; "of";
-        cl = LIST0 constr; "end" ->
-	  COrderedCase (loc, RegularStyle, Some p, c, cl)
-      | IDENT "Case"; c = constr; "of"; cl = LIST0 constr; "end" ->
-          COrderedCase (loc, RegularStyle, None, c, cl)
-      | IDENT "Match"; c = constr; "with"; cl = LIST1 constr; "end" ->
-          COrderedCase (loc, MatchStyle, None, c, cl)
-      | IDENT "let"; "("; b = ne_name_comma_list; ")"; "=";
-        c = constr; "in"; c1 = constr ->
-          (* TODO: right loc *)
-	  COrderedCase
-            (loc, LetStyle, None, c, [CLambdaN (loc, [b, CHole loc], c1)])
-      | IDENT "let"; na = name; "="; c = opt_casted_constr; 
-	"in"; c1 = constr ->
-          CLetIn (loc, na, c, c1)
-      | IDENT "if"; c1 = constr;
-        IDENT "then"; c2 = constr;
-        IDENT "else"; c3 = constr ->
-	  COrderedCase (loc, IfStyle, None, c1, [c2; c3])
-      | "<"; p = annot; ">";
-        IDENT "let"; "("; b = ne_name_comma_list; ")"; "="; c = constr; 
-        "in"; c1 = constr ->
-          (* TODO: right loc *)
-	  COrderedCase (loc, LetStyle, Some p, c,
-            [CLambdaN (loc, [b, CHole loc], c1)])
-      | "<"; p = annot; ">";
-        IDENT "if"; c1 = constr;
-        IDENT "then"; c2 = constr; 
-        IDENT "else"; c3 = constr ->
-	  COrderedCase (loc, IfStyle, Some p, c1, [c2; c3])
-      | ".."; c = operconstr LEVEL "0"; ".." ->
+    [ "200" RIGHTA
+      [ c = binder_constr -> c ]
+    | "100" RIGHTA
+      [ c1 = operconstr; "<:"; c2 = binder_constr -> 
+                 CCast(loc,c1, CastConv VMcast,c2)
+      | c1 = operconstr; "<:"; c2 = SELF -> 
+                 CCast(loc,c1, CastConv VMcast,c2)
+      | c1 = operconstr; ":";c2 = binder_constr -> 
+                 CCast(loc,c1, CastConv DEFAULTcast,c2)
+      | c1 = operconstr; ":"; c2 = SELF -> 
+                 CCast(loc,c1, CastConv DEFAULTcast,c2) ]
+    | "99" RIGHTA [ ]
+    | "90" RIGHTA
+      [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2)
+      | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)]
+    | "10" LEFTA
+      [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args)
+      | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args) ]
+    | "9"
+        [ ".."; c = operconstr LEVEL "0"; ".." ->
           CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ]
-    | "0" RIGHTA
-      [ "?" -> CHole loc
-      | "?"; n = Prim.natural -> CPatVar (loc, (false,Pattern.patvar_of_int n))
-      | bll = binders; c = constr -> abstract_constr loc c bll
-      (* Hack to parse syntax "(n)" as a natural number *)
-      | "("; test_int_rparen; n = bigint; ")" ->
-	  (* Delimiter "N" moved to "nat" in V7 *)
-          CDelimiters (loc,"nat",CNumeral (loc,n))
-      | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_tail ->
-          let id = coerce_to_name lc1 in
-	  CProdN (loc, ([id], c)::bl, body)
-(* TODO: Syntaxe (_:t...)t et (_,x...)t *)
-      | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr;
-        (bl,body) = product_tail ->
-          let id1 = coerce_to_name lc1 in
-          let id2 = coerce_to_name lc2 in
-	  CProdN (loc, ([id1; id2], c)::bl, body)
-      | "("; lc1 = lconstr; ","; lc2 = lconstr; ",";
-        idl = ne_name_comma_list; ":"; c = constr; (bl,body) = product_tail ->
-          let id1 = coerce_to_name lc1 in
-          let id2 = coerce_to_name lc2 in
-	  CProdN (loc, (id1::id2::idl, c)::bl, body)
-      | "("; lc1 = lconstr; ")" ->
-          if Options.do_translate() then set_loc loc lc1 else lc1
-      | "("; lc1 = lconstr; ")"; "@"; "["; cl = ne_constr_list; "]" ->
-	  (match lc1 with
-	    | CPatVar (loc2,(false,n)) -> 
-                CApp (loc,(None,CPatVar (loc2, (true,n))), List.map (fun c -> c, None) cl)
-	    | _ ->
-	    Util.error "Second-order pattern-matching expects a head metavariable")
-      | IDENT "Fix"; id = identref; "{"; fbinders = fixbinders; "}" ->
-	  CFix (loc, id, fbinders)
-      | IDENT "CoFix"; id = identref; "{"; fbinders = cofixbinders; "}" ->
-	  CCoFix (loc, id, fbinders)
-      | IDENT "Prefix" ; "(" ;  s = STRING ; cl = LIST0 constr ; ")" ->
-	  CNotation(loc, s, cl)
-      | s = sort -> CSort (loc, s)
-      | v = global -> CRef v
-      | n = bigint -> CNumeral (loc,n)
-      | "!"; f = global -> CAppExpl (loc,(None,f),[])
-      | "'"; test_ident_colon; key = IDENT; ":"; c = constr; "'" -> 
-	  (* Delimiter "N" implicitly moved to "nat" in V7 *)
-	  let key = if key = "N" then "nat" else key in
-	  let key = if key = "P" then "positive" else key in
-	  let key = if key = "T" then "type" else key in
-	  CDelimiters (loc,key,c) ] ]
+    | "1" LEFTA
+      [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" ->
+	CApp(loc,(Some (List.length args+1),CRef f),args@[c,None])
+      | c=operconstr; ".("; "@"; f=global;
+        args=LIST0 (operconstr LEVEL "9"); ")" ->
+        CAppExpl(loc,(Some (List.length args+1),f),args@[c]) 
+      | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ]
+    | "0"
+      [ c=atomic_constr -> c
+      | c=match_constr -> c
+      | "("; c = operconstr LEVEL "200"; ")" ->
+          (match c with
+              CPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
+                CNotation(loc,"( _ )",[c])
+            | _ -> c) ] ]
   ;
-  constr91:
-    [ [ test_int_bang; n = INT; "!"; c = operconstr LEVEL "9" ->
-        (c, Some (loc,ExplByPos (int_of_string n)))
-      | c = operconstr LEVEL "9" -> (c, None) ] ]
+  binder_constr:
+    [ [ "forall"; bl = binder_list; ","; c = operconstr LEVEL "200" ->
+          mkCProdN loc bl c
+      | "fun"; bl = binder_list; "=>"; c = operconstr LEVEL "200" ->
+          mkCLambdaN loc bl c
+      | "let"; id=name; bl = LIST0 binder_let; ty = type_cstr; ":=";
+        c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" ->
+          let loc1 = loc_of_binder_let bl in
+          CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2)
+      | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" ->
+          let fixp = mk_single_fix fx in
+          let (li,id) = match fixp with
+              CFix(_,id,_) -> id
+            | CCoFix(_,id,_) -> id
+            | _ -> assert false in
+          CLetIn(loc,(li,Name id),fixp,c)
+      | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []];
+	  po = return_type;
+	  ":="; c1 = operconstr LEVEL "200"; "in";
+          c2 = operconstr LEVEL "200" ->
+          CLetTuple (loc,List.map snd lb,po,c1,c2)
+      | "if"; c=operconstr LEVEL "200"; po = return_type;
+	"then"; b1=operconstr LEVEL "200";
+        "else"; b2=operconstr LEVEL "200" ->
+          CIf (loc, c, po, b1, b2)
+      | c=fix_constr -> c ] ]
   ;
-  (* annot and product_annot_tail are hacks to forbid concrete syntax *)
-  (* ">" (e.g. for gt, Zgt, ...) in annotations *)
-  annot:
-    [ RIGHTA
-      [ bll = binders; c = annot -> abstract_constr loc c bll 
-      | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_annot_tail ->
-          let id = coerce_to_name lc1 in
-	  CProdN (loc, ([id], c)::bl, body)
-      | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr;
-        (bl,body) = product_annot_tail ->
-          let id1 = coerce_to_name lc1 in
-          let id2 = coerce_to_name lc2 in
-	  CProdN (loc, ([id1; id2], c)::bl, body)
-      | "("; lc1 = lconstr; ","; lc2 = lconstr; ",";
-        idl = ne_name_comma_list; ":"; c = constr;
-	(bl,body) = product_annot_tail ->
-          let id1 = coerce_to_name lc1 in
-          let id2 = coerce_to_name lc2 in
-	  CProdN (loc, (id1::id2::idl, c)::bl, body)
-      | "("; lc1 = lconstr; ")" -> lc1
-      | c1 = annot; "->"; c2 = annot -> CArrow (loc, c1, c2) ]
-    | RIGHTA 
-      [ c1 = annot; "\\/"; c2 = annot -> CNotation (loc, "_ \\/ _", [c1;c2]) ]
-    | RIGHTA
-      [ c1 = annot; "/\\"; c2 = annot -> CNotation (loc, "_ /\\ _", [c1;c2]) ]
-    | RIGHTA
-      [ "~"; c = SELF -> CNotation (loc, "~ _", [c]) ]
-    | RIGHTA
-      [ c1 = SELF; "=="; c2 = NEXT -> CNotation (loc, "_ == _", [c1;c2]) ]
-    | RIGHTA
-      [ c1 = SELF; "="; c2 = NEXT -> CNotation (loc, "_ = _", [c1;c2]) ]
-    | [ c = operconstr LEVEL "4L" -> c ] ]
+  appl_arg:
+    [ [ id = lpar_id_coloneq; c=lconstr; ")" ->
+	  (c,Some (loc,ExplByName id))
+      | c=constr -> (c,None) ] ]
   ;
-  product_annot_tail:
-    [ [ ";"; idl = ne_name_comma_list; ":"; c = constr;
-        (bl,c2) = product_annot_tail -> ((idl, c)::bl, c2)
-      | ";"; idl = ne_name_comma_list; (bl,c2) = product_annot_tail ->
-          ((idl, CHole (fst (List.hd idl)))::bl, c2)
-      | ")"; c = annot -> ([], c) ] ]
+  atomic_constr:
+    [ [ g=global -> CRef g
+      | s=sort -> CSort (loc,s)
+      | n=INT -> CPrim (loc, Numeral (Bigint.of_string n))
+      | s=string -> CPrim (loc, String s)
+      | "_" -> CHole loc
+      | "?"; id=ident -> CPatVar(loc,(false,id)) ] ]
   ;
-  ne_name_comma_list:
-    [ [ nal = LIST1 name SEP "," -> nal ] ]
+  fix_constr:
+    [ [ fx1=single_fix -> mk_single_fix fx1
+      | (_,kw,dcl1)=single_fix; "with"; dcls=LIST1 fix_decl SEP "with";
+        "for"; id=identref ->
+          mk_fix(loc,kw,id,dcl1::dcls)
+    ] ]
   ;
-  name_comma_list_tail:
-    [ [ ","; idl = ne_name_comma_list -> idl
-      | -> [] ] ]
+  single_fix:
+    [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ]
   ;
-  opt_casted_constr:
-    [ [ c = constr;  ":"; t = constr -> CCast (loc, c, t)
-      | c = constr -> c ] ]
+  fix_kw:
+    [ [ "fix" -> true
+      | "cofix" -> false ] ]
   ;
-  vardecls:
-    [ [ na = name; nal = name_comma_list_tail; c = type_option ->
-          LocalRawAssum (na::nal,c)
-      | na = name; "="; c = opt_casted_constr ->
-          LocalRawDef (na, c)
-      | na = name; ":="; c = opt_casted_constr ->
-          LocalRawDef (na, c)
-
-      (* This is used in quotations *)
-      | id = METAIDENT; c = type_option -> LocalRawAssum ([loc, Name (id_of_string id)], c)
-    ] ]
+  fix_decl:
+    [ [ id=identref; bl=LIST0 binder_let; ann=fixannot; ty=type_cstr; ":=";
+        c=operconstr LEVEL "200" -> (id,bl,ann,c,ty) ] ]
   ;
-  ne_vardecls_list:
-    [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl
-      | id = vardecls -> [id] ] ]
+  fixannot:
+    [ [ "{"; IDENT "struct"; id=name; "}" -> (Some id, CStructRec)
+      | "{"; IDENT "wf"; rel=constr; id=name; "}" -> (Some id, CWfRec rel)
+      | "{"; IDENT "measure"; rel=constr; id=name; "}" -> (Some id, CMeasureRec rel)
+      | ->  (None, CStructRec)
+      ] ]
   ;
-  binders:
-    [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ]
+  match_constr:
+    [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with";
+        br=branches; "end" -> CCases(loc,ty,ci,br) ] ]
   ;
-  simple_params:
-    [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c)
-      | idl = LIST1 name SEP "," -> (idl, CHole loc)
-    ] ]
+  case_item:
+    [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ]
   ;
-  simple_binders:
-    [ [ "["; bll = LIST1 simple_params SEP ";"; "]" -> bll ] ]
+  pred_pattern:
+    [ [ ona = OPT ["as"; id=name -> snd id];
+        ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ]
   ;
-  ne_simple_binders_list:
-    [ [ bll = LIST1 simple_binders -> List.flatten bll ] ]
+  case_type:
+    [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ]
   ;
-  type_option:
-    [ [ ":"; c = constr -> c 
-      | -> CHole loc ] ]
+  return_type:
+    [ [ a = OPT [ na = OPT["as"; id=name -> snd id];
+                  ty = case_type -> (na,ty) ] -> 
+        match a with 
+          | None -> None, None
+          | Some (na,t) -> (na, Some t)
+    ] ]
   ;
-  fixbinder:
-    [ [ id = base_ident; "/"; recarg = natural; ":"; type_ = constr;
-        ":="; def = constr ->
-          (id, recarg-1, [], type_, def)
-      | id = base_ident; bl = ne_simple_binders_list; ":"; type_ = constr;
-	":="; def = constr ->
-          let ni = List.length (List.flatten (List.map fst bl)) -1 in
-          let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in
-	  (id, ni, bl, type_, def) ] ]
+  branches:
+    [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ]
   ;
-  fixbinders:
-    [ [ fbs = LIST1 fixbinder SEP "with" -> fbs ] ]
+  eqn:
+    [ [ pll = LIST0 LIST1 pattern LEVEL "99" SEP "," SEP "|"; 
+        "=>"; rhs = lconstr -> (loc,pll,rhs) ] ]
   ;
-  cofixbinder:
-    [ [ id = base_ident; ":"; type_ = constr; ":="; def = constr ->
-          (id, [],type_, def) ] ]
+  pattern:
+    [ "200" RIGHTA [ ]
+    | "100" RIGHTA
+      [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ]
+    | "99" RIGHTA [ ]
+    | "10" LEFTA
+      [ p = pattern; lp = LIST1 NEXT ->
+        (match p with
+          | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
+          | _ -> Util.user_err_loc 
+              (cases_pattern_expr_loc p, "compound_pattern",
+               Pp.str "Constructor expected"))
+      | p = pattern; "as"; id = ident ->
+	  CPatAlias (loc, p, id) ]
+    | "1" LEFTA
+      [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ]
+    | "0"
+      [ r = Prim.reference -> CPatAtom (loc,Some r)
+      | "_" -> CPatAtom (loc,None)
+      | "("; p = pattern LEVEL "200"; ")" ->
+          (match p with
+              CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
+                CPatNotation(loc,"( _ )",[p])
+            | _ -> p)
+      | n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n))
+      | s = string -> CPatPrim (loc, String s) ] ]
+  ;
+  binder_list:
+    [ [ idl=LIST1 name; bl=LIST0 binder_let -> 
+          LocalRawAssum (idl,CHole loc)::bl
+      | idl=LIST1 name; ":"; c=lconstr -> 
+          [LocalRawAssum (idl,c)]
+      | "("; idl=LIST1 name; ":"; c=lconstr; ")"; bl=LIST0 binder_let ->
+          LocalRawAssum (idl,c)::bl ] ]
+  ;
+  binder_let:
+    [ [ id=name ->
+          LocalRawAssum ([id],CHole loc)
+      | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> 
+          LocalRawAssum (id::idl,c)
+      | "("; id=name; ":"; c=lconstr; ")" -> 
+          LocalRawAssum ([id],c)
+      | "("; id=name; ":="; c=lconstr; ")" ->
+          LocalRawDef (id,c)
+      | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> 
+          LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv DEFAULTcast,t))
+    ] ]
   ;
-  cofixbinders:
-    [ [ fbs = LIST1 cofixbinder SEP "with" -> fbs ] ]
+  binder:
+    [ [ id=name -> ([id],CHole loc)
+      | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,c) ] ]
   ;
-  product_tail:
-    [ [ ";"; idl = ne_name_comma_list; ":"; c = constr;
-        (bl,c2) = product_tail -> ((idl, c)::bl, c2)
-      | ";"; idl = ne_name_comma_list; (bl,c2) = product_tail ->
-          ((idl, CHole (fst (List.hd idl)))::bl, c2)
-      | ")"; c = constr -> ([], c) ] ]
+  type_cstr:
+    [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ]
   ;
-END;;
+  END;;
diff --git a/parsing/g_constrnew.ml4 b/parsing/g_constrnew.ml4
deleted file mode 100644
index fe579e98..00000000
--- a/parsing/g_constrnew.ml4
+++ /dev/null
@@ -1,338 +0,0 @@
-(************************************************************************)
-(*  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: g_constrnew.ml4,v 1.41.2.4 2005/09/21 14:47:33 herbelin Exp $ *)
-
-open Pcoq
-open Constr
-open Prim
-open Rawterm
-open Term
-open Names
-open Libnames
-open Topconstr
-
-open Util
-
-let constr_kw =
-  [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; 
-    "end"; "as"; "let"; "if"; "then"; "else"; "return";
-    "Prop"; "Set"; "Type"; ".("; "_"; ".." ]
-
-let _ = 
-  if not !Options.v7 then
-    List.iter (fun s -> Lexer.add_token("",s)) constr_kw
-
-(* For Correctness syntax; doesn't work if in psyntax (freeze pb?)  *)
-let _ = Lexer.add_token ("","!")
-
-let mk_cast = function
-    (c,(_,None)) -> c
-  | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, ty)
-
-let mk_lam = function
-    ([],c) -> c
-  | (bl,c) -> CLambdaN(constr_loc c, bl,c)
-
-let mk_match (loc,cil,rty,br) =
-  CCases(loc,(None,rty),cil,br)
-
-let loc_of_binder_let = function
-  | LocalRawAssum ((loc,_)::_,_)::_ -> loc
-  | LocalRawDef ((loc,_),_)::_ -> loc
-  | _ -> dummy_loc
-
-let rec mkCProdN loc bll c =
-  match bll with
-  | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> 
-      CProdN (loc,[idl,t],mkCProdN (join_loc loc1 loc) bll c)
-  | LocalRawDef ((loc1,_) as id,b) :: bll -> 
-      CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c)
-  | [] -> c
-  | LocalRawAssum ([],_) :: bll -> mkCProdN loc bll c
-
-let rec mkCLambdaN loc bll c =
-  match bll with
-  | LocalRawAssum ((loc1,_)::_ as idl,t) :: bll -> 
-      CLambdaN (loc,[idl,t],mkCLambdaN (join_loc loc1 loc) bll c)
-  | LocalRawDef ((loc1,_) as id,b) :: bll -> 
-      CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c)
-  | [] -> c
-  | LocalRawAssum ([],_) :: bll -> mkCLambdaN loc bll c
-
-let rec index_of_annot loc bl ann =
-  match names_of_local_assums bl,ann with
-    | [_], None -> 0
-    | lids, Some x ->
-        let ids = List.map snd lids in
-        (try list_index (snd x) ids - 1
-        with Not_found ->
-          user_err_loc(fst x,"index_of_annot", Pp.str"no such fix variable"))
-    | _ -> user_err_loc(loc,"index_of_annot",
-      Pp.str "cannot guess decreasing argument of fix")
-
-let mk_fixb (id,bl,ann,body,(loc,tyc)) =
-  let n = index_of_annot (fst id) bl ann in
-  let ty = match tyc with
-      Some ty -> ty
-    | None -> CHole loc in
-  (snd id,n,bl,ty,body)
-
-let mk_cofixb (id,bl,ann,body,(loc,tyc)) =
-  let _ = option_app (fun (aloc,_) ->
-    Util.user_err_loc
-      (aloc,"Constr:mk_cofixb",
-       Pp.str"Annotation forbidden in cofix expression")) ann in
-  let ty = match tyc with
-      Some ty -> ty
-    | None -> CHole loc in
-  (snd id,bl,ty,body)
-
-let mk_fix(loc,kw,id,dcls) =
-  if kw then 
-    let fb = List.map mk_fixb dcls in
-    CFix(loc,id,fb)
-  else
-    let fb = List.map mk_cofixb dcls in
-    CCoFix(loc,id,fb)
-
-let mk_single_fix (loc,kw,dcl) =
-  let (id,_,_,_,_) = dcl in mk_fix(loc,kw,id,[dcl])
-
-let binder_constr =
-  create_constr_entry (get_univ "constr") "binder_constr"
-
-(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
-(* admissible notation "(x t)" *)
-let lpar_id_coloneq =
-  Gram.Entry.of_parser "test_lpar_id_coloneq"
-    (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("","(")] ->
-            (match Stream.npeek 2 strm with
-	      | [_; ("IDENT",s)] ->
-                  (match Stream.npeek 3 strm with
-                    | [_; _; ("", ":=")] ->
-                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
-                        Names.id_of_string s
-	            | _ -> raise Stream.Failure)
-              | _ -> raise Stream.Failure)
-        | _ -> raise Stream.Failure)
-
-
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: binder_constr lconstr constr operconstr sort global
-  constr_pattern lconstr_pattern Constr.ident binder binder_let pattern;
-  Constr.ident:
-    [ [ id = Prim.ident -> id
-
-      (* This is used in quotations and Syntax *)
-      | id = METAIDENT -> id_of_string id ] ]
-  ;
-  Prim.name:
-    [ [ "_" -> (loc, Anonymous) ] ]
-  ;
-  Prim.ast:
-    [ [ "_" -> Coqast.Nvar(loc,id_of_string"_") ] ]
-  ;
-  global:
-    [ [ r = Prim.reference -> r
-
-      (* This is used in quotations *)
-      | id = METAIDENT -> Ident (loc,id_of_string id) ] ]
-  ;
-  constr_pattern:
-    [ [ c = constr -> c ] ]
-  ;
-  lconstr_pattern:
-    [ [ c = lconstr -> c ] ]
-  ;
-  sort:
-    [ [ "Set"  -> RProp Pos
-      | "Prop" -> RProp Null
-      | "Type" -> RType None ] ]
-  ;
-  lconstr:
-    [ [ c = operconstr LEVEL "200" -> c ] ]
-  ;
-  constr:
-    [ [ c = operconstr LEVEL "9" -> c ] ]
-  ;
-  operconstr:
-    [ "200" RIGHTA
-      [ c = binder_constr -> c ]
-    | "100" RIGHTA
-      [ c1 = operconstr; ":"; c2 = binder_constr -> CCast(loc,c1,c2)
-      | c1 = operconstr; ":"; c2 = SELF -> CCast(loc,c1,c2) ]
-    | "99" RIGHTA [ ]
-    | "90" RIGHTA
-      [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2)
-      | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)]
-    | "10" LEFTA
-      [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args)
-      | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args) ]
-    | "9"
-        [ ".."; c = operconstr LEVEL "0"; ".." ->
-          CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ]
-    | "1" LEFTA
-      [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" ->
-	CApp(loc,(Some (List.length args+1),CRef f),args@[c,None])
-      | c=operconstr; ".("; "@"; f=global;
-        args=LIST0 (operconstr LEVEL "9"); ")" ->
-        CAppExpl(loc,(Some (List.length args+1),f),args@[c]) 
-      | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ]
-    | "0"
-      [ c=atomic_constr -> c
-      | c=match_constr -> c
-      | "("; c = operconstr LEVEL "200"; ")" ->
-          (match c with
-              CNumeral(_,Bignat.POS _) -> CNotation(loc,"( _ )",[c])
-            | _ -> c) ] ]
-  ;
-  binder_constr:
-    [ [ "forall"; bl = binder_list; ","; c = operconstr LEVEL "200" ->
-          mkCProdN loc bl c
-      | "fun"; bl = binder_list; "=>"; c = operconstr LEVEL "200" ->
-          mkCLambdaN loc bl c
-      | "let"; id=name; bl = LIST0 binder_let; ty = type_cstr; ":=";
-        c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" ->
-          let loc1 = loc_of_binder_let bl in
-          CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2)
-      | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" ->
-          let fixp = mk_single_fix fx in
-          let (li,id) = match fixp with
-              CFix(_,id,_) -> id
-            | CCoFix(_,id,_) -> id
-            | _ -> assert false in
-          CLetIn(loc,(li,Name id),fixp,c)
-      | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []];
-	  po = return_type;
-	  ":="; c1 = operconstr LEVEL "200"; "in";
-          c2 = operconstr LEVEL "200" ->
-          CLetTuple (loc,List.map snd lb,po,c1,c2)
-      | "if"; c=operconstr LEVEL "200"; po = return_type;
-	"then"; b1=operconstr LEVEL "200";
-        "else"; b2=operconstr LEVEL "200" ->
-          CIf (loc, c, po, b1, b2)
-      | c=fix_constr -> c ] ]
-  ;
-  appl_arg:
-    [ [ id = lpar_id_coloneq; c=lconstr; ")" ->
-	  (c,Some (loc,ExplByName id))
-      | c=constr -> (c,None) ] ]
-  ;
-  atomic_constr:
-    [ [ g=global -> CRef g
-      | s=sort -> CSort(loc,s)
-      | n=INT -> CNumeral (loc,Bignat.POS (Bignat.of_string n))
-      | "_" -> CHole loc
-      | "?"; id=ident -> CPatVar(loc,(false,id)) ] ]
-  ;
-  fix_constr:
-    [ [ fx1=single_fix -> mk_single_fix fx1
-      | (_,kw,dcl1)=single_fix; "with"; dcls=LIST1 fix_decl SEP "with";
-        "for"; id=identref ->
-          mk_fix(loc,kw,id,dcl1::dcls)
-    ] ]
-  ;
-  single_fix:
-    [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ]
-  ;
-  fix_kw:
-    [ [ "fix" -> true
-      | "cofix" -> false ] ]
-  ;
-  fix_decl:
-    [ [ id=identref; bl=LIST0 binder_let; ann=fixannot; ty=type_cstr; ":=";
-        c=operconstr LEVEL "200" -> (id,bl,ann,c,ty) ] ]
-  ;
-  fixannot:
-    [ [ "{"; IDENT "struct"; id=name; "}" -> Some id
-      | -> None ] ]
-  ;
-  match_constr:
-    [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with";
-        br=branches; "end" -> mk_match (loc,ci,ty,br) ] ]
-  ;
-  case_item:
-    [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ]
-  ;
-  pred_pattern:
-    [ [ ona = OPT ["as"; id=name -> snd id];
-        ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ]
-  ;
-  case_type:
-    [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ]
-  ;
-  return_type:
-    [ [ a = OPT [ na = OPT["as"; id=name -> snd id];
-                  ty = case_type -> (na,ty) ] -> 
-        match a with 
-          | None -> None, None
-          | Some (na,t) -> (na, Some t)
-    ] ]
-  ;
-  branches:
-    [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ]
-  ;
-  eqn:
-    [ [ pl = LIST1 pattern SEP ","; "=>"; rhs = lconstr -> (loc,pl,rhs) ] ]
-  ;
-  pattern:
-    [ "200" RIGHTA [ ]
-    | "99" RIGHTA [ ]
-    | "10" LEFTA
-      [ p = pattern ; lp = LIST1 (pattern LEVEL "0") ->
-        (match p with
-          | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
-          | _ -> Util.user_err_loc 
-              (cases_pattern_loc p, "compound_pattern",
-               Pp.str "Constructor expected"))
-      | p = pattern; "as"; id = base_ident ->
-	  CPatAlias (loc, p, id)
-      | c = pattern; "%"; key=IDENT -> 
-          CPatDelimiters (loc,key,c) ]
-    | "0"
-      [ r = Prim.reference -> CPatAtom (loc,Some r)
-      | "_" -> CPatAtom (loc,None)
-      | "("; p = pattern LEVEL "200"; ")" ->
-          (match p with
-              CPatNumeral(_,Bignat.POS _) -> CPatNotation(loc,"( _ )",[p])
-            | _ -> p)
-      | n = INT -> CPatNumeral (loc,Bignat.POS(Bignat.of_string n)) ] ]
-  ;
-  binder_list:
-    [ [ idl=LIST1 name; bl=LIST0 binder_let -> 
-          LocalRawAssum (idl,CHole loc)::bl
-      | idl=LIST1 name; ":"; c=lconstr -> 
-          [LocalRawAssum (idl,c)]
-      | "("; idl=LIST1 name; ":"; c=lconstr; ")"; bl=LIST0 binder_let ->
-          LocalRawAssum (idl,c)::bl ] ]
-  ;
-  binder_let:
-    [ [ id=name ->
-          LocalRawAssum ([id],CHole loc)
-      | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> 
-          LocalRawAssum (id::idl,c)
-      | "("; id=name; ":"; c=lconstr; ")" -> 
-          LocalRawAssum ([id],c)
-      | "("; id=name; ":="; c=lconstr; ")" ->
-          LocalRawDef (id,c)
-      | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> 
-          LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c,t))
-    ] ]
-  ;
-  binder:
-    [ [ id=name -> ([id],CHole loc)
-      | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,c) ] ]
-  ;
-  type_cstr:
-    [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ]
-  ;
-  END;;
diff --git a/parsing/g_decl_mode.ml4 b/parsing/g_decl_mode.ml4
new file mode 100644
index 00000000..5c7b40af
--- /dev/null
+++ b/parsing/g_decl_mode.ml4
@@ -0,0 +1,250 @@
+(************************************************************************)
+(*  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$ *)
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Decl_expr
+open Names
+open Term
+open Genarg
+open Pcoq
+
+open Pcoq.Constr
+open Pcoq.Tactic
+open Pcoq.Vernac_
+
+let none_is_empty = function
+    None -> []
+  | Some l -> l
+
+GEXTEND Gram
+GLOBAL: proof_instr;
+  thesis :
+    [[ "thesis" -> Plain 
+     | "thesis"; "for"; i=ident -> (For i)
+     | "thesis"; "["; n=INT ;"]" -> (Sub (int_of_string n))
+     ]];
+  statement :
+    [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c}
+     | i=ident -> {st_label=Anonymous;
+		   st_it=Topconstr.CRef (Libnames.Ident (loc, i))}
+     | c=constr -> {st_label=Anonymous;st_it=c}
+     ]];
+  constr_or_thesis :
+     [[ t=thesis -> Thesis t ] |
+      [ c=constr -> This c
+      ]];
+  statement_or_thesis : 
+    [
+      [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] 
+    |
+      [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot}
+      | i=ident -> {st_label=Anonymous;
+		    st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))}
+      | c=constr -> {st_label=Anonymous;st_it=This c}
+      ]
+    ];
+  justification_items : 
+    [[ -> Some [] 
+     | IDENT "by"; l=LIST1 constr SEP "," -> Some l
+     | IDENT "by"; "*"                    -> None ]]
+  ;
+  justification_method : 
+    [[ -> None 
+     | "using";  tac = tactic -> Some tac ]]
+  ;
+  simple_cut_or_thesis :
+    [[ ls = statement_or_thesis;
+       j = justification_items;
+       taco = justification_method 	
+	 -> {cut_stat=ls;cut_by=j;cut_using=taco} ]]
+  ;
+  simple_cut :
+    [[ ls = statement;
+       j = justification_items;
+       taco = justification_method 	
+	 -> {cut_stat=ls;cut_by=j;cut_using=taco} ]]
+  ;
+  elim_type:
+    [[ IDENT "induction" -> ET_Induction
+     | IDENT "cases" -> ET_Case_analysis ]]
+  ;
+  block_type :
+    [[ IDENT "claim" -> B_claim
+     | IDENT "focus" -> B_focus
+     | IDENT "proof" -> B_proof
+     | et=elim_type -> B_elim et ]]
+  ;    
+  elim_obj:
+    [[ IDENT "on"; c=constr -> Real c
+     | IDENT "of"; c=simple_cut -> Virtual c ]]
+  ;  
+  elim_step:
+    [[ IDENT "consider" ; 
+       h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h)
+     | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj)
+     | IDENT "suffices"; ls=suff_clause;
+       j = justification_items;
+       taco = justification_method 	
+	-> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] 
+  ;
+  rew_step :
+    [[ "~=" ;         c=simple_cut -> (Rhs,c)       
+     | "=~" ;         c=simple_cut -> (Lhs,c)]]
+  ;
+  cut_step:
+    [[ "then"; tt=elim_step -> Pthen tt
+     | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c)
+     | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) 
+     | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c)
+     | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c)
+     | tt=elim_step -> tt
+     | tt=rew_step -> let s,c=tt in Prew (s,c); 
+     | IDENT "have"; c=simple_cut_or_thesis -> Pcut c;
+     | IDENT "claim"; c=statement -> Pclaim c;
+     | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c;    
+     | "end"; bt = block_type -> Pend bt;
+     | IDENT "escape" -> Pescape ]]
+  ;
+  (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*)
+  loc_id: 
+    [[ id=ident -> fun x -> (loc,(id,x)) ]];
+  hyp:
+    [[ id=loc_id -> id None ;
+     | id=loc_id ; ":" ; c=constr -> id (Some c)]]
+  ;
+  consider_vars:
+    [[ name=hyp -> [Hvar name]
+     | name=hyp; ","; v=consider_vars -> (Hvar name) :: v
+     | name=hyp; 
+       IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h
+     ]]
+  ;
+  consider_hyps:  
+    [[ st=statement; IDENT "and"; h=consider_hyps  -> Hprop st::h
+     | st=statement; IDENT "and"; 
+       IDENT "consider" ; v=consider_vars  -> Hprop st::v
+     | st=statement -> [Hprop st]
+     ]]
+  ;  
+  assume_vars:
+    [[ name=hyp -> [Hvar name]
+     | name=hyp; ","; v=assume_vars -> (Hvar name) :: v
+     | name=hyp; 
+       IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h
+     ]]
+  ;
+  assume_hyps:  
+    [[ st=statement; IDENT "and"; h=assume_hyps  -> Hprop st::h
+     | st=statement; IDENT "and"; 
+       IDENT "we"; IDENT "have" ; v=assume_vars  -> Hprop st::v
+     | st=statement -> [Hprop st]
+     ]]
+  ;
+  assume_clause:
+    [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v
+    |  h=assume_hyps -> h ]]
+  ; 
+  suff_vars:
+    [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis ->
+      [Hvar name],c
+     | name=hyp; ","; v=suff_vars -> 
+	 let (q,c) = v in ((Hvar name) :: q),c
+     | name=hyp; 
+       IDENT "such"; IDENT "that"; h=suff_hyps -> 
+	 let (q,c) = h in ((Hvar name) :: q),c
+     ]];
+  suff_hyps:  
+    [[ st=statement; IDENT "and"; h=suff_hyps  ->	 
+	 let (q,c) = h in (Hprop st::q),c
+     | st=statement; IDENT "and"; 
+       IDENT "to" ; IDENT "have" ; v=suff_vars -> 
+	 let (q,c) = v in (Hprop st::q),c
+     | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> 
+	 [Hprop st],c
+     ]]
+  ;
+  suff_clause:
+    [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v
+    |  h=suff_hyps -> h ]]
+  ; 
+  let_vars:
+    [[ name=hyp -> [Hvar name]
+     | name=hyp; ","; v=let_vars -> (Hvar name) :: v
+     | name=hyp; IDENT "be"; 
+       IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h
+     ]]
+  ;
+  let_hyps:  
+    [[ st=statement; IDENT "and"; h=let_hyps  -> Hprop st::h
+    |  st=statement; IDENT "and"; "let"; v=let_vars  -> Hprop st::v
+    |  st=statement -> [Hprop st]
+    ]];
+  given_vars:
+    [[ name=hyp -> [Hvar name]
+     | name=hyp; ","; v=given_vars -> (Hvar name) :: v
+     | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h
+     ]]
+  ;
+  given_hyps:  
+    [[ st=statement; IDENT "and"; h=given_hyps  -> Hprop st::h
+    |  st=statement; IDENT "and"; IDENT "given"; v=given_vars  -> Hprop st::v
+    |  st=statement -> [Hprop st]
+    ]];
+  suppose_vars:
+    [[name=hyp -> [Hvar name] 
+     |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v
+     |name=hyp; OPT[IDENT "be"]; 
+      IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h
+     ]]
+  ;
+  suppose_hyps:  
+    [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h
+     | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have";
+          v=suppose_vars -> Hprop st::v
+     | st=statement_or_thesis -> [Hprop st]
+     ]]
+  ;
+  suppose_clause:
+    [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v;
+     |  h=suppose_hyps -> h ]]
+  ;
+  intro_step:
+    [[ IDENT "suppose" ; h=assume_clause -> Psuppose h
+     | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ;
+       po=OPT[ IDENT "with"; p=LIST1 hyp -> p ] ; 
+       ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> 
+	 Pcase (none_is_empty po,c,none_is_empty ho)
+     | "let" ; v=let_vars -> Plet v	 
+     | IDENT "take"; witnesses = LIST1 constr SEP ","  -> Ptake witnesses
+     | IDENT "assume"; h=assume_clause -> Passume h
+     | IDENT "given"; h=given_vars -> Pgiven h
+     | IDENT "define"; id=ident; args=LIST0 hyp; 
+       "as"; body=constr -> Pdefine(id,args,body)
+     | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ)
+     | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ)
+     ]]
+  ;
+  emphasis : 
+    [[ -> 0
+     | "*" -> 1
+     | "**" -> 2
+     | "***" -> 3
+     ]]
+  ;
+  bare_proof_instr:
+    [[ c = cut_step -> c ;
+     | i = intro_step -> i ]]
+  ;
+  proof_instr :
+    [[ e=emphasis;i=bare_proof_instr -> {emph=e;instr=i}]]
+  ;
+END;;
+
+ 
diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4
index 7349a6f8..27ff8140 100644
--- a/parsing/g_ltac.ml4
+++ b/parsing/g_ltac.ml4
@@ -6,16 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_ltac.ml4,v 1.28.2.2 2004/07/16 19:30:38 herbelin Exp $ *)
+(* $Id: g_ltac.ml4 9333 2006-11-02 13:59:14Z barras $ *)
 
 open Pp
 open Util
-open Ast
 open Topconstr
 open Rawterm
 open Tacexpr
 open Vernacexpr
-open Ast
 open Pcoq
 open Prim
 open Tactic
@@ -25,7 +23,7 @@ type let_clause_kind =
   | LETCLAUSE of
       (Names.identifier Util.located * raw_tactic_expr option * raw_tactic_arg)
 
-let fail_default_value = Genarg.ArgArg 0
+let fail_default_value = ArgArg 0
 
 let out_letin_clause loc = function
   | LETTOPCLAUSE _ -> user_err_loc (loc, "", (str "Syntax Error"))
@@ -37,163 +35,166 @@ let arg_of_expr = function
     TacArg a -> a
   | e -> Tacexp (e:raw_tactic_expr)
     
+let tacarg_of_expr = function
+  | TacArg (Reference r) -> TacCall (dummy_loc,r,[])
+  | TacArg a -> a
+  | e -> Tacexp (e:raw_tactic_expr)
+
 (* Tactics grammar rules *)
 
-if !Options.v7 then
 GEXTEND Gram
-  GLOBAL: tactic Vernac_.command tactic_arg;
+  GLOBAL: tactic Vernac_.command tactic_expr binder_tactic tactic_arg
+          constr_may_eval;
 
-(*
-  GLOBAL: tactic_atom tactic_atom0 tactic_expr input_fun;
-*)
+  tactic_expr:
+    [ "5" RIGHTA
+      [ te = binder_tactic -> te ]
+    | "4" LEFTA
+      [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1)
+      | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, ta1)
+      | ta = tactic_expr; ";"; 
+	"["; lta = LIST0 OPT tactic_expr SEP "|"; "]" ->
+	  let lta = List.map (function None -> TacId [] | Some t -> t) lta in 
+	  TacThens (ta, lta) ]
+    | "3" RIGHTA
+      [ IDENT "try"; ta = tactic_expr -> TacTry ta
+      | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta)
+      | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta
+      | IDENT "progress"; ta = tactic_expr -> TacProgress ta
+(*To do: put Abstract in Refiner*)
+      | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None)
+      | IDENT "abstract"; tc = NEXT; "using";  s = ident ->
+          TacAbstract (tc,Some s) ]
+(*End of To do*)
+    | "2" RIGHTA
+      [ ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1)
+      | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ]
+    | "1" RIGHTA
+      [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" ->
+          TacMatchContext (b,false,mrl)
+      | b = match_key; IDENT "reverse"; IDENT "goal"; "with";
+        mrl = match_context_list; "end" ->
+          TacMatchContext (b,true,mrl)
+      |	b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" ->
+          TacMatch (b,c,mrl)
+      | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacFirst l
+      | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
+	  TacSolve l
+      | IDENT "complete" ; ta = tactic_expr -> TacComplete ta
+      | IDENT "idtac"; l = LIST0 message_token -> TacId l
+      | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
+	  l = LIST0 message_token -> TacFail (n,l)
+      | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg ->
+	  TacArg (TacExternal (loc,com,req,la))
+      | st = simple_tactic -> TacAtom (loc,st)
+      | a = may_eval_arg -> TacArg(a)
+      | IDENT "constr"; ":"; c = Constr.constr ->
+          TacArg(ConstrMayEval(ConstrTerm c))
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> 
+	  TacArg(IntroPattern ipat)
+      | r = reference; la = LIST1 tactic_arg ->
+          TacArg(TacCall (loc,r,la))
+      | r = reference -> TacArg (Reference r) ]
+    | "0"
+      [ "("; a = tactic_expr; ")" -> a
+      | a = tactic_atom -> TacArg a ] ]
+  ;
+  (* binder_tactic: level 5 of tactic_expr *)
+  binder_tactic:
+    [ RIGHTA
+      [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" ->
+          TacFun (it,body)
+      | "let"; IDENT "rec"; rcl = LIST1 rec_clause SEP "with"; "in";
+          body = tactic_expr LEVEL "5" -> TacLetRecIn (rcl,body)
+      | "let"; llc = LIST1 let_clause SEP "with"; "in";
+          u = tactic_expr LEVEL "5" -> TacLetIn (make_letin_clause loc llc,u)
+      | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ]
+  ;
+  (* Tactic arguments *)
+  tactic_arg:
+    [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> tacarg_of_expr a
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
+      | a = may_eval_arg -> a
+      | r = reference -> Reference r
+      | a = tactic_atom -> a
+      | c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ]
+  ;
+  may_eval_arg:
+    [ [ c = constr_eval -> ConstrMayEval c
+      | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l ] ]
+  ;
+  fresh_id:
+    [ [ s = STRING -> ArgArg s | id = ident -> ArgVar (loc,id) ] ]
+  ;
+  constr_eval:
+    [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
+          ConstrEval (rtc,c)
+      | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" ->
+          ConstrContext (id,c)
+      | IDENT "type"; IDENT "of"; c = Constr.constr ->
+          ConstrTypeOf c ] ]
+  ;
+  constr_may_eval: (* For extensions *)
+    [ [ c = constr_eval -> c
+      | c = Constr.constr -> ConstrTerm c ] ]
+  ;
+  tactic_atom:
+    [ [ id = METAIDENT -> MetaIdArg (loc,id)
+      | "()" -> TacVoid ] ]
+  ;
+  match_key:
+    [ [ "match" -> false | "lazymatch" -> true ] ]
+  ;
   input_fun:
-    [ [ l = base_ident -> Some l
-      | "()" -> None ] ]
+    [ [ "_" -> None 
+      | l = ident -> Some l ] ]
   ;
   let_clause:
-    [ [ id = identref; "="; te = tactic_letarg -> LETCLAUSE (id, None, te)
-      | id = base_ident; ":"; c = Constr.constr; ":="; "Proof" ->
-          LETTOPCLAUSE (id, c)
-      | id = identref; ":"; c = constrarg; ":="; te = tactic_letarg ->
-          LETCLAUSE (id, Some (TacArg(ConstrMayEval c)), te)
-      |	id = base_ident; ":"; c = Constr.constr ->
-	  LETTOPCLAUSE (id, c) ] ]
+    [ [ id = identref; ":="; te = tactic_expr ->
+          LETCLAUSE (id, None, arg_of_expr te)
+      | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr ->
+          LETCLAUSE (id, None, arg_of_expr (TacFun(args,te))) ] ]
   ;
   rec_clause:
-    [ [ name = identref; it = LIST1 input_fun; "->"; body = tactic_expr ->
+    [ [ name = identref; it = LIST1 input_fun; ":="; body = tactic_expr ->
           (name,(it,body)) ] ]
   ;
   match_pattern:
-    [ [ id = Constr.constr_pattern; "["; pc = Constr.constr_pattern; "]" ->
-        let (_,s) = coerce_to_id id in Subterm (Some s, pc)
-      | "["; pc = Constr.constr_pattern; "]" -> Subterm (None,pc)
-      | pc = Constr.constr_pattern -> Term pc ] ]
+    [ [ IDENT "context";  oid = OPT Constr.ident;
+          "["; pc = Constr.lconstr_pattern; "]" ->
+        Subterm (oid, pc)
+      | pc = Constr.lconstr_pattern -> Term pc ] ]
   ;
   match_hyps:
     [ [ na = name; ":"; mp =  match_pattern -> Hyp (na, mp) ] ]
   ;
   match_context_rule:
-    [ [ "["; largs = LIST0 match_hyps SEP ";"; "|-"; mp = match_pattern; "]";
-        "->"; te = tactic_expr -> Pat (largs, mp, te)
-      | IDENT "_"; "->"; te = tactic_expr -> All te ] ]
+    [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern;
+        "=>"; te = tactic_expr -> Pat (largs, mp, te)
+      | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern;
+        "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te)
+      | "_"; "=>"; te = tactic_expr -> All te ] ]
   ;
   match_context_list:
     [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl
       | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ]
   ;
   match_rule:
-    [ [ "["; mp = match_pattern; "]"; "->"; te = tactic_expr -> Pat ([],mp,te)
-      | IDENT "_"; "->"; te = tactic_expr -> All te ] ]
+    [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te)
+      | "_"; "=>"; te = tactic_expr -> All te ] ]
   ;
   match_list:
     [ [ mrl = LIST1 match_rule SEP "|" -> mrl
       | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ]
   ;
-  tactic_expr:
-    [ [ ta = tactic_expr5 -> ta ] ]
-  ;
-  tactic_expr5:
-    [ [ ta0 = tactic_expr5; ";"; ta1 = tactic_expr4 -> TacThen (ta0, ta1)
-      | ta = tactic_expr5; ";"; "["; lta = LIST0 tactic_expr SEP "|"; "]" ->
-          TacThens (ta, lta)
-      | y = tactic_expr4 -> y ] ]
-  ;
-  tactic_expr4:
-    [ [ ta = tactic_expr3 -> ta ] ]
-  ;
-  tactic_expr3:
-    [ [ IDENT "Try"; ta = tactic_expr3 -> TacTry ta
-      | IDENT "Do"; n = int_or_var; ta = tactic_expr3 -> TacDo (n,ta)
-      | IDENT "Repeat"; ta = tactic_expr3 -> TacRepeat ta
-      | IDENT "Progress"; ta = tactic_expr3 -> TacProgress ta
-      | IDENT "Info"; tc = tactic_expr3 -> TacInfo tc
-      | ta = tactic_expr2 -> ta ] ]
-  ;
-  tactic_expr2:
-    [ [ ta0 = tactic_atom; "Orelse"; ta1 = tactic_expr3 -> TacOrelse (ta0,ta1)
-      | ta = tactic_atom -> ta ] ]
-  ;
-  tactic_atom:
-    [ [ IDENT "Fun"; it = LIST1 input_fun ; "->"; body = tactic_expr ->
-          TacFun (it,body)
-      | IDENT "Rec"; rc = rec_clause ->
-	  warning "'Rec f ...' is obsolete; use 'Rec f ... In f' instead";
-	  TacLetRecIn ([rc],TacArg (Reference (Libnames.Ident (fst rc))))
-      | IDENT "Rec"; rc = rec_clause; rcl = LIST0 rec_clause SEP "And";
-	  [IDENT "In" | "in"]; body = tactic_expr -> TacLetRecIn (rc::rcl,body)
-      | IDENT "Let"; llc = LIST1 let_clause SEP "And"; IDENT "In";
-          u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u)
-
-      | IDENT "Match"; IDENT "Context"; IDENT "With"; mrl = match_context_list
-        -> TacMatchContext (false,mrl)
-      | IDENT "Match"; IDENT "Reverse"; IDENT "Context"; IDENT "With"; mrl = match_context_list
-        -> TacMatchContext (true,mrl)
-      |	IDENT "Match"; c = constrarg; IDENT "With"; mrl = match_list ->
-        TacMatch (TacArg(ConstrMayEval c),mrl)
-(*To do: put Abstract in Refiner*)
-      | IDENT "Abstract"; tc = tactic_expr -> TacAbstract (tc,None)
-      | IDENT "Abstract"; tc = tactic_expr; "using";  s = base_ident ->
-          TacAbstract (tc,Some s)
-(*End of To do*)
-      | IDENT "First" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
-	  TacFirst l
-      | IDENT "Solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
-	  TacSolve l
-      | IDENT "Idtac" ; s = [ s = STRING -> s | -> ""] -> TacId s
-      | IDENT "Fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
-	  s = [ s = STRING -> s | -> ""] -> TacFail (n,s)
-      | st = simple_tactic -> TacAtom (loc,st)
-      | "("; a = tactic_expr; ")" -> a
-      | a = tactic_arg -> TacArg a
-    ] ]
-  ;
-  (* Tactic arguments *)
-  tactic_arg:
-    [ [ ta = tactic_arg1 -> ta ] ]
-  ;
-  tactic_letarg:
-    (* Cannot be merged with tactic_arg1, since then "In"/"And" are 
-       parsed as lqualid! *)
-    [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr ->
-	  ConstrMayEval (ConstrEval (rtc,c))
-      | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" ->
-	  ConstrMayEval (ConstrContext (id,c))
-      | IDENT "Check"; c = Constr.constr ->
-	  ConstrMayEval (ConstrTypeOf c)
-      | IDENT "FreshId"; s = OPT STRING -> TacFreshId s
-      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
-      | r = reference -> Reference r
-      | ta = tactic_arg0 -> ta ] ]
-  ;
-  tactic_arg1:
-    [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr ->
-	  ConstrMayEval (ConstrEval (rtc,c))
-      | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" ->
-	  ConstrMayEval (ConstrContext (id,c))
-      | IDENT "Check"; c = Constr.constr ->
-	  ConstrMayEval (ConstrTypeOf c)
-      | IDENT "FreshId"; s = OPT STRING -> TacFreshId s
-      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
-      | r = reference; la = LIST1 tactic_arg0 -> TacCall (loc,r,la)
-      | r = reference -> Reference r
-      | ta = tactic_arg0 -> ta ] ]
-  ;
-  tactic_arg0:
-    [ [ "("; a = tactic_expr; ")" -> arg_of_expr a
-      | "()" -> TacVoid
-      | r = reference -> Reference r
-      | n = integer -> Integer n
-      | id = METAIDENT -> MetaIdArg (loc,id)
-      |	"?" -> ConstrMayEval (ConstrTerm (CHole loc))
-      | "?"; n = natural -> ConstrMayEval (ConstrTerm (CPatVar (loc,(false,Pattern.patvar_of_int n))))
-      |	"'"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ]
+  message_token:
+    [ [ id = identref -> MsgIdent (AI id)
+      | s = STRING -> MsgString s
+      | n = integer -> MsgInt n ] ]
   ;
 
   (* Definitions for tactics *)
-  deftok:
-    [ [ IDENT "Meta"
-      | IDENT "Tactic" ] ]
-  ;
   tacdef_body:
     [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr ->
 	  (name, TacFun (it, body))
@@ -204,10 +205,8 @@ GEXTEND Gram
     [ [ tac = tactic_expr -> tac ] ]
   ;
   Vernac_.command: 
-    [ [ deftok; "Definition"; b = tacdef_body ->
-          VernacDeclareTacticDefinition (false, [b])
-      | IDENT "Recursive"; deftok; "Definition"; 
-        l = LIST1 tacdef_body SEP "And" ->
+    [ [ IDENT "Ltac";
+        l = LIST1 tacdef_body SEP "with" ->
           VernacDeclareTacticDefinition (true, l) ] ]
   ;
   END
diff --git a/parsing/g_ltacnew.ml4 b/parsing/g_ltacnew.ml4
deleted file mode 100644
index 7492ac8c..00000000
--- a/parsing/g_ltacnew.ml4
+++ /dev/null
@@ -1,195 +0,0 @@
-(************************************************************************)
-(*  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: g_ltacnew.ml4,v 1.22.2.3 2005/06/21 15:31:12 herbelin Exp $ *)
-
-open Pp
-open Util
-open Ast
-open Topconstr
-open Rawterm
-open Tacexpr
-open Vernacexpr
-open Ast
-open Pcoq
-open Prim
-open Tactic
-
-type let_clause_kind =
-  | LETTOPCLAUSE of Names.identifier * constr_expr
-  | LETCLAUSE of
-      (Names.identifier Util.located * raw_tactic_expr option * raw_tactic_arg)
-
-let fail_default_value = Genarg.ArgArg 0
-
-let out_letin_clause loc = function
-  | LETTOPCLAUSE _ -> user_err_loc (loc, "", (str "Syntax Error"))
-  | LETCLAUSE (id,c,d) -> (id,c,d)
-
-let make_letin_clause loc = List.map (out_letin_clause loc)
-
-let arg_of_expr = function
-    TacArg a -> a
-  | e -> Tacexp (e:raw_tactic_expr)
-    
-(* Tactics grammar rules *)
-
-let tactic_expr = Gram.Entry.create "tactic:tactic_expr"
-
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: tactic Vernac_.command tactic_expr tactic_arg constr_may_eval;
-
-  tactic_expr:
-    [ "5" LEFTA
-      [ ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, ta1)
-      | ta = tactic_expr; ";"; "["; lta = LIST0 tactic_expr SEP "|"; "]" ->
-          TacThens (ta, lta) ]
-    | "4"
-      [ ]
-    | "3" RIGHTA
-      [ IDENT "try"; ta = tactic_expr -> TacTry ta
-      | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta)
-      | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta
-      | IDENT "progress"; ta = tactic_expr -> TacProgress ta
-      | IDENT "info"; tc = tactic_expr -> TacInfo tc
-(*To do: put Abstract in Refiner*)
-      | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None)
-      | IDENT "abstract"; tc = NEXT; "using";  s = base_ident ->
-          TacAbstract (tc,Some s) ]
-(*End of To do*)
-    | "2" RIGHTA
-      [ ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ]
-    | "1" RIGHTA
-      [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr ->
-          TacFun (it,body)
-      | "let"; IDENT "rec"; rcl = LIST1 rec_clause SEP "with"; "in";
-          body = tactic_expr -> TacLetRecIn (rcl,body)
-      | "let"; llc = LIST1 let_clause SEP "with"; "in";
-          u = tactic_expr -> TacLetIn (make_letin_clause loc llc,u)
-      | "match"; IDENT "goal"; "with"; mrl = match_context_list; "end" ->
-          TacMatchContext (false,mrl)
-      | "match"; IDENT "reverse"; IDENT "goal"; "with";
-        mrl = match_context_list; "end" ->
-          TacMatchContext (true,mrl)
-      |	"match"; c = tactic_expr; "with"; mrl = match_list; "end" ->
-          TacMatch (c,mrl)
-      | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
-	  TacFirst l
-      | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
-	  TacSolve l
-      | IDENT "idtac"; s = [ s = STRING -> s | -> ""] -> TacId s		
-      | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
-	  s = [ s = STRING -> s | -> ""] -> TacFail (n,s)
-      | st = simple_tactic -> TacAtom (loc,st)
-      | a = may_eval_arg -> TacArg(a)
-      | IDENT "constr"; ":"; c = Constr.constr ->
-          TacArg(ConstrMayEval(ConstrTerm c))
-      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> 
-	  TacArg(IntroPattern ipat)
-      | r = reference; la = LIST1 tactic_arg ->
-          TacArg(TacCall (loc,r,la))
-      | r = reference -> TacArg (Reference r) ]
-    | "0"
-      [ "("; a = tactic_expr; ")" -> a
-      | a = tactic_atom -> TacArg a ] ]
-  ;
-  (* Tactic arguments *)
-  tactic_arg:
-    [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a
-      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
-      | a = may_eval_arg -> a
-      | a = tactic_atom -> a
-      | c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ]
-  ;
-  may_eval_arg:
-    [ [ c = constr_eval -> ConstrMayEval c
-      | IDENT "fresh"; s = OPT STRING -> TacFreshId s ] ]
-  ;
-  constr_eval:
-    [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
-	  ConstrEval (rtc,c)
-      | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" ->
-	  ConstrContext (id,c)
-      | IDENT "type"; IDENT "of"; c = Constr.constr ->
-	  ConstrTypeOf c ] ]
-  ;
-  constr_may_eval: (* For extensions *)
-    [ [ c = constr_eval -> c
-      | c = Constr.constr -> ConstrTerm c ] ]
-  ;
-  tactic_atom:
-    [ [ id = METAIDENT -> MetaIdArg (loc,id)
-      | r = reference -> Reference r
-      | "()" -> TacVoid ] ]
-  ;
-  input_fun:
-    [ [ "_" -> None 
-      | l = base_ident -> Some l ] ]
-  ;
-  let_clause:
-    [ [ id = identref; ":="; te = tactic_expr ->
-          LETCLAUSE (id, None, arg_of_expr te)
-      | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr ->
-          LETCLAUSE (id, None, arg_of_expr (TacFun(args,te))) ] ]
-  ;
-  rec_clause:
-    [ [ name = identref; it = LIST1 input_fun; ":="; body = tactic_expr ->
-          (name,(it,body)) ] ]
-  ;
-  match_pattern:
-    [ [ IDENT "context";  oid = OPT Constr.ident;
-          "["; pc = Constr.lconstr_pattern; "]" ->
-        Subterm (oid, pc)
-      | pc = Constr.lconstr_pattern -> Term pc ] ]
-  ;
-  match_hyps:
-    [ [ na = name; ":"; mp =  match_pattern -> Hyp (na, mp) ] ]
-  ;
-  match_context_rule:
-    [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern;
-        "=>"; te = tactic_expr -> Pat (largs, mp, te)
-      | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern;
-        "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te)
-      | "_"; "=>"; te = tactic_expr -> All te ] ]
-  ;
-  match_context_list:
-    [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl
-      | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ]
-  ;
-  match_rule:
-    [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te)
-      | "_"; "=>"; te = tactic_expr -> All te ] ]
-  ;
-  match_list:
-    [ [ mrl = LIST1 match_rule SEP "|" -> mrl
-      | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ]
-  ;
-
-  (* Definitions for tactics *)
-(*
-  deftok:
-    [ [ IDENT "Meta"
-      | IDENT "Tactic" ] ]
-  ;
-*)
-  tacdef_body:
-    [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr ->
-	  (name, TacFun (it, body))
-      | name = identref; ":="; body = tactic_expr ->
-	  (name, body) ] ]
-  ;
-  tactic:
-    [ [ tac = tactic_expr -> tac ] ]
-  ;
-  Vernac_.command: 
-    [ [ IDENT "Ltac";
-        l = LIST1 tacdef_body SEP "with" ->
-          VernacDeclareTacticDefinition (true, l) ] ]
-  ;
-  END
diff --git a/parsing/g_minicoq.ml4 b/parsing/g_minicoq.ml4
index dd4ef517..ed8dda5c 100644
--- a/parsing/g_minicoq.ml4
+++ b/parsing/g_minicoq.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_minicoq.ml4,v 1.17.6.1 2004/07/16 19:30:38 herbelin Exp $ *)
+(* $Id: g_minicoq.ml4 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Util
diff --git a/parsing/g_minicoq.mli b/parsing/g_minicoq.mli
index e19b1163..345d9575 100644
--- a/parsing/g_minicoq.mli
+++ b/parsing/g_minicoq.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_minicoq.mli,v 1.8.16.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+(*i $Id: g_minicoq.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Pp
diff --git a/parsing/g_module.ml4 b/parsing/g_module.ml4
deleted file mode 100644
index 0b542608..00000000
--- a/parsing/g_module.ml4
+++ /dev/null
@@ -1,47 +0,0 @@
-(************************************************************************)
-(*  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: g_module.ml4,v 1.6.2.1 2004/07/16 19:30:39 herbelin Exp $ *) 
-
-open Pp
-open Ast
-open Pcoq
-open Prim
-open Module
-open Util
-open Topconstr
-
-(* Grammar rules for module expressions and types *)
-
-if !Options.v7 then
-GEXTEND Gram
-  GLOBAL: module_expr module_type;
- 
-  module_expr:
-    [ [ qid = qualid -> CMEident qid
-      | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2)
-      | "("; me = module_expr; ")" -> me
-(* ... *)
-      ] ]
-  ;
-
-  with_declaration:
-    [ [ "Definition"; id = identref; ":="; c = Constr.constr ->
-          CWith_Definition (id,c)
-      | IDENT "Module"; id = identref; ":="; qid = qualid ->
-	  CWith_Module (id,qid)
-      ] ]
-  ;
-  
-  module_type:
-    [ [ qid = qualid -> CMTEident qid
-(* ... *)
-      | mty = module_type; "with"; decl = with_declaration -> 
-	  CMTEwith (mty,decl) ] ]
-  ;
-END
diff --git a/parsing/g_natsyntax.ml b/parsing/g_natsyntax.ml
index 46ef81f3..f764bc28 100644
--- a/parsing/g_natsyntax.ml
+++ b/parsing/g_natsyntax.ml
@@ -6,112 +6,21 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_natsyntax.ml,v 1.19.2.2 2004/09/08 13:47:51 herbelin Exp $ *)
+(* $Id: g_natsyntax.ml 7988 2006-02-04 20:28:29Z herbelin $ *)
 
-(* This file to allow writing (3) for (S (S (S O))) 
-   and still write (S y) for (S y) *)
+(* This file defines the printer for natural numbers in [nat] *)
 
+(*i*)
 open Pcoq
 open Pp
 open Util
 open Names
-open Coqast
-open Ast
 open Coqlib
-open Termast
-open Extend
-
-let ast_O = ast_of_ref glob_O
-let ast_S = ast_of_ref glob_S
-
-(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
-let nat_of_int n dloc =
-  let ast_O = set_loc dloc ast_O in
-  let ast_S = set_loc dloc ast_S in
-  let rec mk_nat n =
-    if n <= 0 then 
-      ast_O
-    else 
-      Node(dloc,"APPLIST", [ast_S; mk_nat (n-1)])
-  in 
-  mk_nat n
-
-let pat_nat_of_int n dloc =
-  let ast_O = set_loc dloc ast_O in
-  let ast_S = set_loc dloc ast_S in
-  let rec mk_nat n =
-    if n <= 0 then 
-      ast_O
-    else 
-      Node(dloc,"PATTCONSTRUCT", [ast_S; mk_nat (n-1)])
-  in 
-  mk_nat n
-
-let nat_of_string s dloc = 
-  nat_of_int (int_of_string s) dloc
-
-let pat_nat_of_string s dloc = 
-  pat_nat_of_int (int_of_string s) dloc
-    
-exception Non_closed_number
-
-let rec int_of_nat_rec astS astO p =
-  match p with
-    | Node (_,"APPLIST", [b; a]) when alpha_eq(b,astS) ->
-	(int_of_nat_rec astS astO a)+1
-    | a when alpha_eq(a,astO) -> 1  
-          (***** YES, 1, non 0 ... to print the successor of p *)
-    | _ -> raise Non_closed_number
-	  
-let int_of_nat p =
-  try 
-    Some (int_of_nat_rec ast_S ast_O p)
-  with
-    Non_closed_number -> None
-
-let pr_S a = hov 0 (str "S" ++ brk (1,1) ++ a)
-
-let rec pr_external_S std_pr = function
-  | Node (l,"APPLIST", [b; a]) when alpha_eq (b,ast_S) ->
-      str"(" ++ pr_S (pr_external_S std_pr a) ++ str")"
-  | p -> std_pr p
-
-(* Declare the primitive printer *)
-
-(* Prints not p, but the SUCCESSOR of p !!!!! *)
-let nat_printer std_pr p =
-  match (int_of_nat p) with
-    | Some i -> str "(" ++ str (string_of_int i) ++ str ")"
-    | None -> str "(" ++ pr_S (pr_external_S std_pr p) ++ str ")"
-
-let _ = Esyntax.Ppprim.add ("nat_printer", nat_printer)
-(*
-(* Declare the primitive parser *)
-
-let unat = create_univ_if_new "nat"
-
-let number = create_constr_entry unat "number" 
-let pat_number = create_constr_entry unat "pat_number"
- 
-let _ = 
-  Gram.extend number None
-    [None, None,
-     [[Gramext.Stoken ("INT", "")],
-      Gramext.action nat_of_string]]
-
-let _ = 
-  Gram.extend pat_number None
-    [None, None,
-     [[Gramext.Stoken ("INT", "")],
-      Gramext.action pat_nat_of_string]]
-*)
-
-(*i*)
 open Rawterm
 open Libnames
-open Bignat
+open Bigint
 open Coqlib
-open Symbols
+open Notation
 open Pp
 open Util
 open Names
@@ -122,8 +31,7 @@ open Names
 (* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
 
 let nat_of_int dloc n =
-  match n with
-  | POS n ->
+  if is_pos_or_zero n then begin
       if less_than (of_string "5000") n & Options.is_verbose () then begin
 	warning ("You may experience stack overflow and segmentation fault\
                   \nwhile parsing numbers in nat greater than 5000");
@@ -132,30 +40,17 @@ let nat_of_int dloc n =
       let ref_O = RRef (dloc, glob_O) in
       let ref_S = RRef (dloc, glob_S) in
       let rec mk_nat acc n =
-	if is_nonzero n then 
+	if n <> zero then 
 	  mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
 	else 
 	  acc
       in 
       mk_nat ref_O n
-  | NEG n ->
+    end
+  else
       user_err_loc (dloc, "nat_of_int",
         str "Cannot interpret a negative number as a number of type nat")
 
-let pat_nat_of_int dloc n name =
-  match n with
-  | POS n -> 
-      let rec mk_nat n name =
-	if is_nonzero n then 
-	  PatCstr (dloc,path_of_S,[mk_nat (sub_1 n) Anonymous],name)
-	else 
-	  PatCstr (dloc,path_of_O,[],name)
-      in 
-      mk_nat n name
-  | NEG n ->
-      user_err_loc (dloc, "pat_nat_of_int",
-        str "Unable to interpret a negative number in type nat")
-
 (************************************************************************)
 (* Printing via scopes *)
 
@@ -168,19 +63,7 @@ let rec int_of_nat = function
 	  
 let uninterp_nat p =
   try 
-    Some (POS (int_of_nat p))
-  with
-    Non_closed_number -> None
-
-let rec int_of_nat_pattern = function
-  | PatCstr (_,s,[a],_) when ConstructRef s = glob_S ->
-      add_1 (int_of_nat_pattern a)
-  | PatCstr (_,z,[],_) when ConstructRef z = glob_O -> zero
-  | _ -> raise Non_closed_number
-	  
-let uninterp_nat_pattern p =
-  try 
-    Some (POS (int_of_nat_pattern p))
+    Some (int_of_nat p)
   with
     Non_closed_number -> None
 
@@ -188,42 +71,7 @@ let uninterp_nat_pattern p =
 (* Declare the primitive parsers and printers *)
 
 let _ =
-  Symbols.declare_numeral_interpreter "nat_scope"
-    (glob_nat,["Coq";"Init";"Datatypes"])
-    (nat_of_int,Some pat_nat_of_int)
-    ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, None)
-
-(************************************************************************)
-(* Old ast printing *)
-
-open Coqast
-open Ast
-open Termast
-
-let _ = if !Options.v7 then
-let ast_O = ast_of_ref glob_O in
-let ast_S = ast_of_ref glob_S in
-
-let rec int_of_nat = function
-  | Node (_,"APPLIST", [b; a]) when alpha_eq(b,ast_S) -> (int_of_nat a) + 1
-  | a when alpha_eq(a,ast_O) -> 0
-  | _ -> raise Non_closed_number
-in
-(* Prints not p, but the SUCCESSOR of p !!!!! *)
-let nat_printer_S p =
-  try 
-    Some (int (int_of_nat p + 1))
-  with
-    Non_closed_number -> None
-in
-let nat_printer_O _ =
-  Some (int 0)
-in
-(* Declare the primitive printers *)
-let _ =
-  Esyntax.declare_primitive_printer "nat_printer_S" "nat_scope" nat_printer_S
-in
-let _ = 
-  Esyntax.declare_primitive_printer "nat_printer_O" "nat_scope" nat_printer_O
-in
-()
+  Notation.declare_numeral_interpreter "nat_scope"
+    (nat_path,["Coq";"Init";"Datatypes"])
+    nat_of_int
+    ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, true)
diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli
index 1471aed2..174be771 100644
--- a/parsing/g_natsyntax.mli
+++ b/parsing/g_natsyntax.mli
@@ -6,6 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_natsyntax.mli,v 1.3.16.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+(*i $Id: g_natsyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Nice syntax for naturals. *)
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
index ce6d4e2f..d5ca5e0c 100644
--- a/parsing/g_prim.ml4
+++ b/parsing/g_prim.ml4
@@ -6,133 +6,89 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_prim.ml4,v 1.22.2.2 2004/07/16 19:30:39 herbelin Exp $ i*)
+(*i $Id: g_prim.ml4 7922 2006-01-23 19:11:11Z herbelin $ i*)
 
-open Coqast
 open Pcoq
 open Names
 open Libnames
 open Topconstr
-open Prim
 
-let _ = reset_all_grammars()
+let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"]
+let _ = List.iter (fun s -> Lexer.add_token("",s)) prim_kw
 
+open Prim
 open Nametab
-let local_id_of_string = id_of_string
-let local_make_dirpath = make_dirpath
-let local_make_qualid l id' = make_qualid (local_make_dirpath l) id'
-let local_make_short_qualid id = make_short_qualid id
-let local_make_posint = int_of_string
-let local_make_negint n = - int_of_string n
-let local_make_path l a = encode_kn (local_make_dirpath l) a
-let local_make_binding loc a b =
-  match a with
-    | Nvar (_,id) -> Slam(loc,Some id,b)
-    | Nmeta (_,s) -> Smetalam(loc,s,b)
-    | _ -> failwith "Slam expects a var or a metavar"
-let local_append l id = l@[id]
 
-GEXTEND Gram
-  GLOBAL: ident natural integer bigint string preident ast
-    astlist qualid reference dirpath identref name base_ident var hyp;
+let local_make_qualid l id = make_qualid (make_dirpath l) id
 
- (* Compatibility: Prim.var is a synonym of Prim.ident *)
-  var:
-    [ [ id = ident -> id ] ]
-  ;
-  hyp:
-    [ [ id = ident -> id ] ]
-  ;
-  metaident:
-    [ [ s = METAIDENT -> Nmeta (loc,s) ] ]
-  ;
+GEXTEND Gram
+  GLOBAL: 
+    bigint natural integer identref name ident var preident
+    fullyqualid qualid reference dirpath
+    ne_string string;
   preident:
     [ [ s = IDENT -> s ] ]
   ;
-  base_ident:
-    [ [ s = IDENT -> local_id_of_string s ] ]
-  ;
-  name:
-    [ [ IDENT "_" -> (loc, Anonymous)
-      | id = base_ident -> (loc, Name id) ] ]
-  ;
-  identref:
-    [ [ id = base_ident -> (loc,id) ] ]
-  ;
   ident:
-    [ [ id = base_ident -> id ] ]
+    [ [ s = IDENT -> id_of_string s ] ]
   ;
-  natural:
-    [ [ i = INT -> local_make_posint i ] ]
+  var: (* as identref, but interpret as a term identifier in ltac *)
+    [ [ id = ident -> (loc,id) ] ]
   ;
-  bigint:
-    [ [ i = INT -> Bignat.POS (Bignat.of_string i)
-      | "-"; i = INT -> Bignat.NEG (Bignat.of_string i) ] ]
-  ;
-  integer:
-    [ [ i = INT      -> local_make_posint i
-      | "-"; i = INT -> local_make_negint i ] ]
+  identref:
+    [ [ id = ident -> (loc,id) ] ]
   ;
   field:
-    [ [ s = FIELD -> local_id_of_string s ] ]
-  ;
-  dirpath:
-    [ [ id = base_ident; l = LIST0 field ->
-        local_make_dirpath (local_append l id) ] ]
+    [ [ s = FIELD -> id_of_string s ] ]
   ;
   fields:
-    [ [ id = field; (l,id') = fields -> (local_append l id,id')
+    [ [ id = field; (l,id') = fields -> (l@[id],id')
       | id = field -> ([],id)
       ] ]
   ;
+  fullyqualid:
+    [ [ id = ident; (l,id')=fields -> loc,id::List.rev (id'::l)
+      | id = ident -> loc,[id]
+      ] ]
+  ;
   basequalid:
-    [ [ id = base_ident; (l,id')=fields -> local_make_qualid (local_append l id) id'
-      | id = base_ident -> local_make_short_qualid id
+    [ [ id = ident; (l,id')=fields -> local_make_qualid (l@[id]) id'
+      | id = ident -> make_short_qualid id
       ] ]
   ;
-  qualid:
-    [ [ qid = basequalid -> loc, qid ] ]
+  name:
+    [ [ IDENT "_" -> (loc, Anonymous)
+      | id = ident -> (loc, Name id) ] ]
   ;
   reference:
-    [ [ id = base_ident; (l,id') = fields ->
-        Qualid (loc, local_make_qualid (local_append l id) id')
-      | id = base_ident -> Ident (loc,id)
+    [ [ id = ident; (l,id') = fields ->
+        Qualid (loc, local_make_qualid (l@[id]) id')
+      | id = ident -> Ident (loc,id)
       ] ]
   ;
+  qualid:
+    [ [ qid = basequalid -> loc, qid ] ]
+  ;
+  ne_string:
+    [ [ s = STRING -> 
+        if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string"); s
+    ] ]
+  ;
+  dirpath:
+    [ [ id = ident; l = LIST0 field ->
+        make_dirpath (l@[id]) ] ]
+  ;
   string:
     [ [ s = STRING -> s ] ]
   ;
-  astpath:
-    [ [ id = base_ident; (l,a) = fields ->
-          Path(loc, local_make_path (local_append l id) a)
-      | id = base_ident -> Nvar(loc, id)
-      ] ]
+  integer:
+    [ [ i = INT      -> int_of_string i
+      | "-"; i = INT -> - int_of_string i ] ]
   ;
-  (* ast *)
-  ast:
-    [ [ id = metaident -> id
-      | p = astpath -> p
-      | s = INT -> Num(loc, local_make_posint s)
-      | s = STRING -> Str(loc, s)
-      | "{"; s = METAIDENT; "}" -> Id(loc,s)
-      | "("; nname = IDENT; l = LIST0 ast; ")" -> Node(loc,nname,l)
-      | "("; METAIDENT "$LIST"; id = metaident; ")" -> Node(loc,"$LIST",[id])
-      | "("; METAIDENT "$STR"; id = metaident; ")" -> Node(loc,"$STR",[id])
-      | "("; METAIDENT "$VAR"; id = metaident; ")" -> Node(loc,"$VAR",[id])
-      | "("; METAIDENT "$ID"; id = metaident; ")" -> Node(loc,"$ID",[id])
-      | "("; METAIDENT "$ABSTRACT"; l = LIST0 ast;")"->Node(loc,"$ABSTRACT",l)
-      | "("; METAIDENT "$PATH"; id = metaident; ")" -> Node(loc,"$PATH",[id])
-      | "("; METAIDENT "$NUM"; id = metaident; ")" -> Node(loc,"$NUM",[id])
-      | "["; "<>"; "]"; b = ast -> Slam(loc,None,b)
-      | "["; a = ast; "]"; b = ast -> local_make_binding loc a b
-
-(*
-      | "["; ido = astidoption; "]"; b = ast -> Slam(loc,ido,b)
-      | "["; id = METAIDENT; "]"; b = ast -> Smetalam(loc,id,b)
-*)
-      | "'"; a = ast -> Node(loc,"$QUOTE",[a]) ] ]
-  ;
-  astlist:
-    [ [ l = LIST0 ast -> l ] ]
+  natural:
+    [ [ i = INT -> int_of_string i ] ]
+  ;
+  bigint: (* Negative numbers are dealt with specially *)
+    [ [ i = INT -> (Bigint.of_string i) ] ]
   ;
 END
diff --git a/parsing/g_primnew.ml4 b/parsing/g_primnew.ml4
deleted file mode 100644
index c1875634..00000000
--- a/parsing/g_primnew.ml4
+++ /dev/null
@@ -1,84 +0,0 @@
-(************************************************************************)
-(*  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: g_primnew.ml4,v 1.4.2.2 2004/07/16 19:30:39 herbelin Exp $ i*)
-
-open Coqast
-open Pcoq
-open Names
-open Libnames
-open Topconstr
-
-let _ =
-  if not !Options.v7 then
-    Pcoq.reset_all_grammars()
-let _ =
-  if not !Options.v7 then
-  let f = Gram.Unsafe.clear_entry in
-  f Prim.bigint;
-  f Prim.qualid;
-  f Prim.ast;
-  f Prim.reference
-
-let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "<>"; "<<"; ">>"; "'"]
-let _ = 
-  if not !Options.v7 then
-    List.iter (fun s -> Lexer.add_token("",s)) prim_kw
-
-open Prim
-
-open Nametab
-let local_id_of_string = id_of_string
-let local_make_dirpath = make_dirpath
-let local_make_qualid l id' = make_qualid (local_make_dirpath l) id'
-let local_make_short_qualid id = make_short_qualid id
-let local_make_posint = int_of_string
-let local_make_negint n = - int_of_string n
-let local_make_path l a = encode_kn (local_make_dirpath l) a
-let local_make_binding loc a b =
-  match a with
-    | Nvar (_,id) -> Slam(loc,Some id,b)
-    | Nmeta (_,s) -> Smetalam(loc,s,b)
-    | _ -> failwith "Slam expects a var or a metavar"
-let local_append l id = l@[id]
-
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: bigint qualid reference ne_string;
-  field:
-    [ [ s = FIELD -> local_id_of_string s ] ]
-  ;
-  fields:
-    [ [ id = field; (l,id') = fields -> (local_append l id,id')
-      | id = field -> ([],id)
-      ] ]
-  ;
-  basequalid:
-    [ [ id = base_ident; (l,id')=fields ->
-          local_make_qualid (local_append l id) id'
-      | id = base_ident -> local_make_short_qualid id
-      ] ]
-  ;
-  reference:
-    [ [ id = base_ident; (l,id') = fields ->
-        Qualid (loc, local_make_qualid (local_append l id) id')
-      | id = base_ident -> Ident (loc,id)
-      ] ]
-  ;
-  qualid:
-    [ [ qid = basequalid -> loc, qid ] ]
-  ;
-  ne_string:
-    [ [ s = STRING -> 
-        if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string"); s
-    ] ]
-  ;
-  bigint: (* Negative numbers are dealt with specially *)
-    [ [ i = INT -> Bignat.POS (Bignat.of_string i) ] ]
-  ;
-END
diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4
index 5262b785..2f515a81 100644
--- a/parsing/g_proofs.ml4
+++ b/parsing/g_proofs.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_proofs.ml4,v 1.33.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
+(* $Id: g_proofs.ml4 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Pcoq
 open Pp
@@ -18,10 +18,9 @@ open Vernacexpr
 open Prim
 open Constr
 
-let thm_token = Gram.Entry.create "vernac:thm_token"
+let thm_token = G_vernac.thm_token
 
 (* Proof commands *)
-if !Options.v7 then
 GEXTEND Gram
   GLOBAL: command;
 
@@ -35,27 +34,29 @@ GEXTEND Gram
     | ":"; l = LIST1 IDENT -> l ] ]
   ;
   command:
-    [ [ IDENT "Goal"; c = Constr.constr -> VernacGoal c
-      | "Proof" -> VernacProof (Tacexpr.TacId "")
-      | "Proof"; "with"; ta = tactic -> VernacProof ta
+    [ [ IDENT "Goal"; c = lconstr -> VernacGoal c
+      | IDENT "Proof" -> VernacProof (Tacexpr.TacId [])
+      | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta
       | IDENT "Abort" -> VernacAbort None
       | IDENT "Abort"; IDENT "All" -> VernacAbortAll
       | IDENT "Abort"; id = identref -> VernacAbort (Some id)
+      | IDENT "Existential"; n = natural; c = constr_body ->
+	  VernacSolveExistential (n,c)
       | IDENT "Admitted" -> VernacEndProof Admitted
-      | "Qed" -> VernacEndProof (Proved (true,None))
+      | IDENT "Qed" -> VernacEndProof (Proved (true,None))
       | IDENT "Save" -> VernacEndProof (Proved (true,None))
-      | IDENT "Defined" -> VernacEndProof (Proved (false,None))
-      |	IDENT "Defined"; id=identref -> 
-	  VernacEndProof (Proved (false,Some (id,None)))
       | IDENT "Save"; tok = thm_token; id = identref ->
 	  VernacEndProof (Proved (true,Some (id,Some tok)))
       | IDENT "Save"; id = identref ->
 	  VernacEndProof (Proved (true,Some (id,None)))
+      | IDENT "Defined" -> VernacEndProof (Proved (false,None))
+      |	IDENT "Defined"; id=identref -> 
+	  VernacEndProof (Proved (false,Some (id,None)))
       | IDENT "Suspend" -> VernacSuspend
       | IDENT "Resume" -> VernacResume None
       | IDENT "Resume"; id = identref -> VernacResume (Some id)
       | IDENT "Restart" -> VernacRestart
-      | "Proof"; c = Constr.constr -> VernacExactProof c
+      | IDENT "Proof"; c = lconstr -> VernacExactProof c
       | IDENT "Undo" -> VernacUndo 1
       | IDENT "Undo"; n = natural -> VernacUndo n
       | IDENT "Focus" -> VernacFocus None
@@ -63,20 +64,21 @@ GEXTEND Gram
       | IDENT "Unfocus" -> VernacUnfocus
       | IDENT "Show" -> VernacShow (ShowGoal None)
       | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n))
-      | IDENT "Show"; IDENT "Implicits"; n = natural ->
-	  VernacShow (ShowGoalImplicitly (Some n))
-      | IDENT "Show"; IDENT "Implicits" -> VernacShow (ShowGoalImplicitly None)
+      | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural ->
+	  VernacShow (ShowGoalImplicitly n)
       | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode
       | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript
       | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials
       | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree
       | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames
-      | IDENT "Show"; "Proof" -> VernacShow ShowProof
+      | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof
       | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false)
       | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true)
-      | IDENT "Explain"; "Proof"; l = LIST0 integer ->
+      | IDENT "Show"; IDENT "Match"; id = identref -> VernacShow (ShowMatch id)
+      | IDENT "Show"; IDENT "Thesis" -> VernacShow ShowThesis
+      | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer ->
 	  VernacShow (ExplainProof l)
-      | IDENT "Explain"; "Proof"; IDENT "Tree"; l = LIST0 integer -> 
+      | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> 
 	  VernacShow (ExplainTree l)
       | IDENT "Go"; n = natural -> VernacGo (GoTo n)
       | IDENT "Go"; IDENT "top" -> VernacGo GoTop
@@ -84,26 +86,13 @@ GEXTEND Gram
       | IDENT "Go"; IDENT "next" -> VernacGo GoNext
       | IDENT "Guarded" -> VernacCheckGuard
 (* Hints for Auto and EAuto *)
-
-      | IDENT "HintDestruct"; 
-	  local = locality;
-          dloc = destruct_location;
-          id  = base_ident;
-          hyptyp = Constr.constr_pattern;
-          pri = natural;
-          "["; tac = tactic; "]" -> 
-	    VernacHints(local,[],HintsDestruct (id,pri,dloc,hyptyp,tac))
-
-      | IDENT "Hint"; local = locality; hintname = base_ident; 
-	  dbnames = opt_hintbases; ":="; h = hint
-          -> VernacHints (local,dbnames, h hintname)
-	  
-      | IDENT "Hints"; local = locality; 
-	  (dbnames,h) = hints -> VernacHints (local,dbnames, h)
+      | IDENT "Hint"; local = locality; h = hint;
+        dbnames = opt_hintbases ->
+	  VernacHints (local,dbnames, h)
 	  
 
 (*This entry is not commented, only for debug*)
-      | IDENT "PrintConstr"; c = Constr.constr -> 
+      | IDENT "PrintConstr"; c = constr -> 
 	  VernacExtend ("PrintConstr",
 	    [Genarg.in_gen Genarg.rawwit_constr c])
       ] ];
@@ -112,24 +101,23 @@ GEXTEND Gram
     [ [ IDENT "Local" -> true | -> false ] ]
   ;
   hint:
-    [ [ IDENT "Resolve"; c = Constr.constr -> fun name -> HintsResolve [Some name, c]
-      | IDENT "Immediate"; c = Constr.constr -> fun name -> HintsImmediate [Some name, c]
-      | IDENT "Unfold"; qid = global -> fun name -> HintsUnfold [Some name,qid]
-      | IDENT "Constructors"; c = global -> fun n ->
-          HintsConstructors (Some n,[c])
-      | IDENT "Extern"; n = natural; c = Constr.constr ; tac = tactic ->
-	  fun name -> HintsExtern (Some name,n,c,tac) ] ]
-  ;
-  hints:
-    [ [ IDENT "Resolve"; l = LIST1 global; dbnames = opt_hintbases ->
-         (dbnames, 
-	  HintsResolve
-	    (List.map (fun qid -> (None, CAppExpl(loc,(None,qid),[]))) l))
-      | IDENT "Immediate"; l = LIST1 global; dbnames = opt_hintbases ->
-        (dbnames, 
-	 HintsImmediate
-	   (List.map (fun qid-> (None, CAppExpl (loc,(None,qid),[]))) l))
-      | IDENT "Unfold"; l = LIST1 global; dbnames = opt_hintbases ->
-        (dbnames, HintsUnfold (List.map (fun qid -> (None,qid)) l)) ] ]
+    [ [ IDENT "Resolve"; lc = LIST1 constr -> HintsResolve lc
+      | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc
+      | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid
+      | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc
+      | IDENT "Extern"; n = natural; c = constr_pattern ; "=>";
+          tac = tactic ->
+	  HintsExtern (n,c,tac)
+      | IDENT "Destruct"; 
+          id = ident; ":=";
+          pri = natural;
+          dloc = destruct_location;
+          hyptyp = constr_pattern;
+          "=>"; tac = tactic ->
+            HintsDestruct(id,pri,dloc,hyptyp,tac) ] ]
     ;
-  END
+  constr_body:
+    [ [ ":="; c = lconstr -> c
+      | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Rawterm.CastConv Term.DEFAULTcast,t) ] ]
+  ;
+END
diff --git a/parsing/g_proofsnew.ml4 b/parsing/g_proofsnew.ml4
deleted file mode 100644
index 04bf7a8b..00000000
--- a/parsing/g_proofsnew.ml4
+++ /dev/null
@@ -1,126 +0,0 @@
-(************************************************************************)
-(*  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: g_proofsnew.ml4,v 1.9.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
-
-open Pcoq
-open Pp
-open Tactic
-open Util
-open Vernac_
-open Topconstr
-open Vernacexpr
-open Prim
-open Constr
-
-let thm_token = G_vernacnew.thm_token
-
-(* Proof commands *)
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: command;
-
-  destruct_location :
-  [ [ IDENT "Conclusion"  -> Tacexpr.ConclLocation ()
-    | discard = [ IDENT "Discardable" -> true | -> false ]; "Hypothesis"
-	-> Tacexpr.HypLocation discard ] ]
-  ;
-  opt_hintbases:
-  [ [ -> []
-    | ":"; l = LIST1 IDENT -> l ] ]
-  ;
-  command:
-    [ [ IDENT "Goal"; c = Constr.lconstr -> VernacGoal c
-      | IDENT "Proof" -> VernacNop
-      | IDENT "Proof"; "with"; ta = tactic -> VernacProof ta
-      | IDENT "Abort" -> VernacAbort None
-      | IDENT "Abort"; IDENT "All" -> VernacAbortAll
-      | IDENT "Abort"; id = identref -> VernacAbort (Some id)
-      | IDENT "Existential"; n = natural; c = constr_body ->
-	  VernacSolveExistential (n,c)
-      | IDENT "Admitted" -> VernacEndProof Admitted
-      | IDENT "Qed" -> VernacEndProof (Proved (true,None))
-      | IDENT "Save" -> VernacEndProof (Proved (true,None))
-      | IDENT "Save"; tok = thm_token; id = identref ->
-	  VernacEndProof (Proved (true,Some (id,Some tok)))
-      | IDENT "Save"; id = identref ->
-	  VernacEndProof (Proved (true,Some (id,None)))
-      | IDENT "Defined" -> VernacEndProof (Proved (false,None))
-      |	IDENT "Defined"; id=identref -> 
-	  VernacEndProof (Proved (false,Some (id,None)))
-      | IDENT "Suspend" -> VernacSuspend
-      | IDENT "Resume" -> VernacResume None
-      | IDENT "Resume"; id = identref -> VernacResume (Some id)
-      | IDENT "Restart" -> VernacRestart
-      | IDENT "Proof"; c = Constr.lconstr -> VernacExactProof c
-      | IDENT "Undo" -> VernacUndo 1
-      | IDENT "Undo"; n = natural -> VernacUndo n
-      | IDENT "Focus" -> VernacFocus None
-      | IDENT "Focus"; n = natural -> VernacFocus (Some n)
-      | IDENT "Unfocus" -> VernacUnfocus
-      | IDENT "Show" -> VernacShow (ShowGoal None)
-      | IDENT "Show"; n = natural -> VernacShow (ShowGoal (Some n))
-      | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural ->
-	  VernacShow (ShowGoalImplicitly n)
-      | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode
-      | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript
-      | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials
-      | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree
-      | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames
-      | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof
-      | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false)
-      | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true)
-      | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer ->
-	  VernacShow (ExplainProof l)
-      | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> 
-	  VernacShow (ExplainTree l)
-      | IDENT "Go"; n = natural -> VernacGo (GoTo n)
-      | IDENT "Go"; IDENT "top" -> VernacGo GoTop
-      | IDENT "Go"; IDENT "prev" -> VernacGo GoPrev
-      | IDENT "Go"; IDENT "next" -> VernacGo GoNext
-      | IDENT "Guarded" -> VernacCheckGuard
-(* Hints for Auto and EAuto *)
-      | IDENT "Hint"; local = locality; h = hint;
-        dbnames = opt_hintbases ->
-	  VernacHints (local,dbnames, h)
-	  
-
-(*This entry is not commented, only for debug*)
-      | IDENT "PrintConstr"; c = Constr.constr -> 
-	  VernacExtend ("PrintConstr",
-	    [Genarg.in_gen Genarg.rawwit_constr c])
-      ] ];
-
-  locality:
-    [ [ IDENT "Local" -> true | -> false ] ]
-  ;
-  hint:
-    [ [ IDENT "Resolve"; lc = LIST1 Constr.constr ->
-          HintsResolve (List.map (fun c -> (None, c)) lc)
-      | IDENT "Immediate"; lc = LIST1 Constr.constr ->
-          HintsImmediate (List.map (fun c -> (None,c)) lc)
-      | IDENT "Unfold"; lqid = LIST1 global ->
-          HintsUnfold (List.map (fun g -> (None,g)) lqid)
-      | IDENT "Constructors"; lc = LIST1 global ->
-          HintsConstructors (None,lc)
-      | IDENT "Extern"; n = natural; c = Constr.constr_pattern ; "=>";
-          tac = tactic ->
-	  HintsExtern (None,n,c,tac)
-      | IDENT"Destruct"; 
-          id = base_ident; ":=";
-          pri = natural;
-          dloc = destruct_location;
-          hyptyp = Constr.constr_pattern;
-          "=>"; tac = tactic ->
-            HintsDestruct(id,pri,dloc,hyptyp,tac) ] ]
-    ;
-  constr_body:
-    [ [ ":="; c = lconstr -> c
-      | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c,t) ] ]
-  ;
-END
diff --git a/parsing/g_rsyntax.ml b/parsing/g_rsyntax.ml
index 8f5aad33..45647903 100644
--- a/parsing/g_rsyntax.ml
+++ b/parsing/g_rsyntax.ml
@@ -6,215 +6,47 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Coqast
-open Ast
 open Pp
 open Util
 open Names
 open Pcoq
-open Extend
 open Topconstr
 open Libnames
 
-(**********************************************************************)
-(* Parsing with Grammar                                               *)
-(**********************************************************************)
-
-let get_r_sign loc =
-  let mkid id =
-    mkRefC (Qualid (loc,Libnames.make_short_qualid id))
-  in
-  ((mkid (id_of_string "R0"),
-    mkid (id_of_string "R1"),
-    mkid (id_of_string "Rplus"),
-    mkid (id_of_string "Rmult"),
-    mkid (id_of_string "NRplus"),
-    mkid (id_of_string "NRmult")))
-
-let get_r_sign_ast loc =
-  let mkid id =
-    Termast.ast_of_ref (Nametab.locate (Libnames.make_short_qualid id))
-  in
-  ((mkid (id_of_string "R0"),
-    mkid (id_of_string "R1"),
-    mkid (id_of_string "Rplus"), 
-    mkid (id_of_string "Rmult"),
-    mkid (id_of_string "NRplus"),
-    mkid (id_of_string "NRmult")))
-
-(* We have the following interpretation:
-  [| 0 |] = 0
-  [| 1 |] = 1
-  [| 2 |] = 1 + 1
-  [| 3 |] = 1 + (1 + 1)
-  [| 2n |] = 2 * [| n |]         for n >= 2
-  [| 2n+1 |] = 1 + 2 * [| n |]   for n >= 2
-  [| -n |] = - [| n |]           for n >= 0
-*)
-
-let int_decomp n = 
-let div2 k = 
-let x = k mod 2 in
-let y = k - x in (x,y/2) in
-let rec list_ch m =
-if m< 2 then [m]
-else let (x1,x2) = div2 m in x1::(list_ch x2)
-in list_ch n
-
-let _ = if !Options.v7 then
-let r_of_int n dloc =
-  let (a0,a1,plus,mult,_,_) = get_r_sign dloc in
-  let list_ch = int_decomp n in
-  let a2 = mkAppC (plus, [a1; a1]) in
-  let rec mk_r l =
-    match l with
-    | [] -> failwith "Error r_of_int"
-    | [a] -> if a=1 then a1 else a0
-    | [a;b] -> if a==1 then mkAppC (plus, [a1; a2]) else a2
-    | a::l' -> if a=1 then mkAppC (plus, [a1; mkAppC (mult, [a2; mk_r l'])]) else mkAppC (mult, [a2; mk_r l'])
-  in mk_r list_ch
-in
-let r_of_string s dloc = 
-  r_of_int (int_of_string s) dloc
-in
-let rsyntax_create name =
-  let e =
-    Pcoq.create_constr_entry (Pcoq.get_univ "rnatural") name in
-  Pcoq.Gram.Unsafe.clear_entry e;
-  e
-in
-let rnumber = rsyntax_create "rnumber"
-in
-let _ = 
-  Gram.extend rnumber None
-    [None, None,
-     [[Gramext.Stoken ("INT", "")],
-      Gramext.action r_of_string]]
-in ()
-
-(**********************************************************************)
-(* Old ast printing                                                   *)
-(**********************************************************************)
-
 exception Non_closed_number
 
-let _ = if !Options.v7 then
-let int_of_r p =
-  let (a0,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in
-  let rec int_of_r_rec p = 
-    match p with
-  | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) & alpha_eq(c,a1) -> 2
-  | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,plus) & alpha_eq(a,a1) ->
-      (match c with
-      |	Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,mult) -> 1 + int_of_r_rec c
-      |	Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) -> 3
-      |	_ -> raise Non_closed_number)
-  | Node (_,"APPLIST", [b;a;c]) when alpha_eq(b,mult) ->
-      (match a with
-      |	Node (_,"APPLIST", [e;d;f]) when alpha_eq(e,plus) & alpha_eq(d,a1) & alpha_eq(f,a1) ->
-	  (match c with
-	  | g when alpha_eq(g,a1) -> raise Non_closed_number
-	  | g when alpha_eq(g,a0) -> raise Non_closed_number
-	  | _ -> 2 * int_of_r_rec c)
-      |	_ -> raise Non_closed_number)
-  | a when alpha_eq(a,a0) -> 0
-  | a when alpha_eq(a,a1) -> 1
-  | _ -> raise Non_closed_number in
-  try 
-    Some (int_of_r_rec p)
-  with
-    Non_closed_number -> None
-in
-let replace_plus p = 
-  let (_,_,_,_,astnrplus,_) = get_r_sign_ast dummy_loc in
-  ope ("REXPR",[ope("APPLIST",[astnrplus;p])])
-in
-let replace_mult p = 
-  let (_,_,_,_,_,astnrmult) = get_r_sign_ast dummy_loc in
-  ope ("REXPR",[ope("APPLIST",[astnrmult;p])])
-in
-let rec r_printer_odd std_pr p =
-  let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in
-  match (int_of_r (ope("APPLIST",[plus;a1;p]))) with
-    | Some i -> str (string_of_int i)
-    | None -> std_pr (replace_plus p)
-in
-let rec r_printer_odd_outside std_pr p =
-  let (_,a1,plus,_,_,_) = get_r_sign_ast dummy_loc in
-  match (int_of_r (ope("APPLIST",[plus;a1;p]))) with
-    | Some i -> str"``" ++ str (string_of_int i) ++ str"``"
-    | None -> std_pr (replace_plus p)
-in
-let rec r_printer_even std_pr p =
-  let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in
-  match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with
-    | Some i -> str (string_of_int i)
-    | None -> std_pr (replace_mult p)
-in
-let rec r_printer_even_outside std_pr p =
-  let (_,a1,plus,mult,_,_) = get_r_sign_ast dummy_loc in
-  match (int_of_r (ope("APPLIST",[mult;(ope("APPLIST",[plus;a1;a1]));p]))) with
-    | Some i -> str"``" ++ str (string_of_int i) ++ str"``"
-    | None -> std_pr (replace_mult p)
-in
-let _ = Esyntax.Ppprim.add ("r_printer_odd", r_printer_odd) in
-let _ = Esyntax.Ppprim.add ("r_printer_odd_outside", r_printer_odd_outside) in
-let _ = Esyntax.Ppprim.add ("r_printer_even", r_printer_even) in
-let _ = Esyntax.Ppprim.add ("r_printer_even_outside", r_printer_even_outside)
-in ()
-
 (**********************************************************************)
 (* Parsing R via scopes                                               *)
 (**********************************************************************)
 
 open Libnames
 open Rawterm
-open Bignat
+open Bigint
 
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
 let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
+let make_path dir id = Libnames.make_path dir (id_of_string id)
+
+let r_path = make_path rdefinitions "R"
 
 (* TODO: temporary hack *)
-let make_path dir id = Libnames.encode_kn dir (id_of_string id)
+let make_path dir id = Libnames.encode_con dir (id_of_string id)
 
-let glob_R = ConstRef (make_path rdefinitions "R")
+let r_kn = make_path rdefinitions "R"
+let glob_R = ConstRef r_kn
 let glob_R1 = ConstRef (make_path rdefinitions "R1")
 let glob_R0 = ConstRef (make_path rdefinitions "R0")
 let glob_Ropp = ConstRef (make_path rdefinitions "Ropp")
 let glob_Rplus = ConstRef (make_path rdefinitions "Rplus")
 let glob_Rmult = ConstRef (make_path rdefinitions "Rmult")
 
-(* V7 *)
-let r_of_posint dloc n =
-  let ref_R0 = RRef (dloc, glob_R0) in
-  let ref_R1 = RRef (dloc, glob_R1) in
-  let ref_Rplus = RRef (dloc, glob_Rplus) in
-  let ref_Rmult = RRef (dloc, glob_Rmult) in
-  let a2 = RApp(dloc, ref_Rplus, [ref_R1; ref_R1]) in
-  let list_ch = int_decomp n in
-  let rec mk_r l =
-    match l with
-    | [] -> failwith "Error r_of_posint"
-    | [a] -> if a=1 then ref_R1 else ref_R0
-    | a::[b] -> if a==1 then RApp (dloc, ref_Rplus, [ref_R1; a2]) else a2
-    | a::l' -> if a=1 then RApp (dloc, ref_Rplus, [ref_R1; RApp (dloc, ref_Rmult, [a2; mk_r l'])]) else RApp (dloc, ref_Rmult, [a2; mk_r l'])
-  in mk_r list_ch
-
-(* int_of_string o bigint_to_string : temporary hack ... *)
-(* utiliser les bigint de caml ? *)
-let r_of_int2 dloc z =
-  match z with
-  | NEG n -> RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (int_of_string (bigint_to_string (POS n)))]) 
-  | POS n -> r_of_posint dloc (int_of_string (bigint_to_string z))
-
-(* V8 *)
 let two = mult_2 one
 let three = add_1 two
 let four = mult_2 two
 
 (* Unary representation of strictly positive numbers *)
 let rec small_r dloc n =
-  if is_one n then RRef (dloc, glob_R1)
+  if equal one n then RRef (dloc, glob_R1)
   else RApp(dloc,RRef (dloc,glob_Rplus),
             [RRef (dloc, glob_R1);small_r dloc (sub_1 n)])
 
@@ -227,12 +59,13 @@ let r_of_posint dloc n =
       let (q,r) = div2_with_rest n in
       let b = RApp(dloc,RRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
       if r then RApp(dloc,RRef(dloc,glob_Rplus),[r1;b]) else b in
-  if is_nonzero n then r_of_pos n else RRef(dloc,glob_R0)
+  if n <> zero then r_of_pos n else RRef(dloc,glob_R0)
 
 let r_of_int dloc z =
-  match z with
-  | NEG n -> RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc n]) 
-  | POS n -> r_of_posint dloc n
+  if is_strictly_neg z then
+    RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) 
+  else
+    r_of_posint dloc z
 
 (**********************************************************************)
 (* Printing R via scopes                                              *)
@@ -268,8 +101,11 @@ in
 bignat_of_r
 
 let bigint_of_r = function
-  | RApp (_,RRef (_,o), [a]) when o = glob_Ropp -> NEG (bignat_of_r a)
-  | a -> POS (bignat_of_r a)
+  | RApp (_,RRef (_,o), [a]) when o = glob_Ropp ->
+      let n = bignat_of_r a in
+      if n = zero then raise Non_closed_number;
+      neg n
+  | a -> bignat_of_r a
 
 let uninterp_r p =
   try
@@ -277,56 +113,11 @@ let uninterp_r p =
   with Non_closed_number ->
     None
 
-let _ = Symbols.declare_numeral_interpreter "R_scope"
-  (glob_R,["Coq";"Reals";"Rdefinitions"])
-  ((if !Options.v7 then r_of_int2 else r_of_int),None)
+let _ = Notation.declare_numeral_interpreter "R_scope"
+  (r_path,["Coq";"Reals";"Rdefinitions"])
+  r_of_int
   ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0);
-    RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);RRef(dummy_loc,glob_R1)],
+    RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);
+    RRef(dummy_loc,glob_R1)],
     uninterp_r,
-    None)
-
-(************************************************************************)
-(* Old ast printers via scope *)
-
-let _ = if !Options.v7 then
-let bignat_of_pos p =
-  let (_,one,plus,_,_,_) = get_r_sign_ast dummy_loc in
-  let rec transl = function
-    | Node (_,"APPLIST",[p; o; a]) when alpha_eq(p,plus) & alpha_eq(o,one)
-        -> add_1(transl a)
-    | a when alpha_eq(a,one) -> Bignat.one
-    | _ -> raise Non_closed_number
-  in transl p
-in
-let bignat_option_of_pos p =
-  try 
-    Some (bignat_of_pos p)
-  with Non_closed_number -> 
-    None
-in
-let r_printer_Rplus1 p =
-  match bignat_option_of_pos p with
-    | Some n -> Some (str (Bignat.to_string (add_1 n)))
-    | None -> None
-in
-let r_printer_Ropp p =
-  match bignat_option_of_pos p with
-    | Some n -> Some (str "-" ++ str (Bignat.to_string n))
-    | None -> None
-in
-let r_printer_R1 _ =
-  Some (int 1)
-in
-let r_printer_R0 _ =
-  Some (int 0)
-in
-(* Declare pretty-printers for integers *)
-let _ =
-  Esyntax.declare_primitive_printer "r_printer_Ropp" "R_scope" (r_printer_Ropp)
-in let _ =
-  Esyntax.declare_primitive_printer "r_printer_Rplus1" "R_scope" (r_printer_Rplus1)
-in let _ =
-  Esyntax.declare_primitive_printer "r_printer_R1" "R_scope" (r_printer_R1)
-in let _ =
-  Esyntax.declare_primitive_printer "r_printer_R0" "R_scope" r_printer_R0
-in ()
+    false)
diff --git a/parsing/g_string_syntax.ml b/parsing/g_string_syntax.ml
new file mode 100644
index 00000000..6d879fb2
--- /dev/null
+++ b/parsing/g_string_syntax.ml
@@ -0,0 +1,67 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Libnames
+open Topconstr
+open G_ascii_syntax
+open Rawterm
+open Coqlib
+
+exception Non_closed_string
+
+(* make a string term from the string s *)
+
+let string_module = ["Coq";"Strings";"String"]
+
+let string_path = make_path string_module "string"
+
+let string_kn = make_kn string_module "string"
+let static_glob_EmptyString  = ConstructRef ((string_kn,0),1)
+let static_glob_String  = ConstructRef ((string_kn,0),2)
+
+let make_reference id = find_reference "String interpretation" string_module id
+let glob_String = lazy (make_reference "String")
+let glob_EmptyString = lazy (make_reference "EmptyString")
+
+open Lazy
+
+let interp_string dloc s =
+  let le = String.length s in
+  let rec aux n = 
+     if n = le then RRef (dloc, force glob_EmptyString) else
+     RApp (dloc,RRef (dloc, force glob_String),
+       [interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
+  in aux 0
+
+let uninterp_string r =
+  try 
+    let b = Buffer.create 16 in
+    let rec aux = function
+    | RApp (_,RRef (_,k),[a;s]) when k = force glob_String ->
+	(match uninterp_ascii a with
+	  | Some c -> Buffer.add_char b (Char.chr c); aux s
+	  | _ -> raise Non_closed_string)
+    | RRef (_,z) when z = force glob_EmptyString ->
+	Some (Buffer.contents b)
+    | _ ->
+	raise Non_closed_string
+    in aux r
+  with 
+   Non_closed_string -> None
+
+let _ =
+  Notation.declare_string_interpreter "string_scope"
+    (string_path,["Coq";"Strings";"String"])
+    interp_string
+    ([RRef (dummy_loc,static_glob_String); 
+      RRef (dummy_loc,static_glob_EmptyString)],
+     uninterp_string, true)
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
index fd64defc..a80d3075 100644
--- a/parsing/g_tactic.ml4
+++ b/parsing/g_tactic.ml4
@@ -6,74 +6,123 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_tactic.ml4,v 1.83.2.5 2005/05/15 12:47:04 herbelin Exp $ *)
+(* $Id: g_tactic.ml4 9551 2007-01-29 15:13:35Z bgregoir $ *)
 
 open Pp
-open Ast
 open Pcoq
 open Util
 open Tacexpr
 open Rawterm
 open Genarg
+open Topconstr
+
+let compute = Cbv all_flags
+
+let tactic_kw = [ "->"; "<-" ]
+let _ = List.iter (fun s -> Lexer.add_token("",s)) tactic_kw
+
+(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
+(* admissible notation "(x t)" *)
+let lpar_id_coloneq =
+  Gram.Entry.of_parser "lpar_id_coloneq"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("","(")] ->
+            (match Stream.npeek 2 strm with
+              | [_; ("IDENT",s)] ->
+                  (match Stream.npeek 3 strm with
+	            | [_; _; ("", ":=")] ->
+                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
+                        Names.id_of_string s
+	            | _ -> raise Stream.Failure)
+	      | _ -> raise Stream.Failure)
+	| _ -> raise Stream.Failure)
+
+(* idem for (x:=t) and (1:=t) *)
+let test_lpar_idnum_coloneq =
+  Gram.Entry.of_parser "test_lpar_idnum_coloneq"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("","(")] ->
+            (match Stream.npeek 2 strm with
+              | [_; (("IDENT"|"INT"),_)] ->
+                  (match Stream.npeek 3 strm with
+                    | [_; _; ("", ":=")] -> ()
+                    | _ -> raise Stream.Failure)
+              | _ -> raise Stream.Failure)
+        | _ -> raise Stream.Failure)
+
+(* idem for (x:t) *)
+let lpar_id_colon =
+  Gram.Entry.of_parser "lpar_id_colon"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("","(")] ->
+            (match Stream.npeek 2 strm with
+              | [_; ("IDENT",id)] ->
+                  (match Stream.npeek 3 strm with
+                    | [_; _; ("", ":")] ->
+                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
+                        Names.id_of_string id
+                    | _ -> raise Stream.Failure)
+              | _ -> raise Stream.Failure)
+        | _ -> raise Stream.Failure)
+
+let guess_lpar_ipat s strm =
+  match Stream.npeek 1 strm with
+    | [("","(")] ->
+        (match Stream.npeek 2 strm with
+          | [_; ("",("("|"["))] -> ()
+          | [_; ("IDENT",_)] ->
+              (match Stream.npeek 3 strm with
+                | [_; _; ("", s')] when s = s' -> ()
+                | _ -> raise Stream.Failure)
+          | _ -> raise Stream.Failure)
+    | _ -> raise Stream.Failure
+
+let guess_lpar_coloneq =
+  Gram.Entry.of_parser "guess_lpar_coloneq" (guess_lpar_ipat ":=")
+
+let guess_lpar_colon =
+  Gram.Entry.of_parser "guess_lpar_colon" (guess_lpar_ipat ":")
+
 open Constr
 open Prim
 open Tactic
 
-let tactic_kw =
-  [ "using"; "Orelse"; "Proof"; "Qed"; "And"; "()"; "|-" ]
-let _ =
-  if !Options.v7 then
-    List.iter (fun s -> Lexer.add_token ("",s)) tactic_kw
+let mk_fix_tac (loc,id,bl,ann,ty) =
+  let n =
+    match bl,ann with
+        [([_],_)], None -> 1
+      | _, Some x ->
+          let ids = List.map snd (List.flatten (List.map fst bl)) in
+          (try list_index (snd x) ids
+          with Not_found -> error "no such fix variable")
+      | _ -> error "cannot guess decreasing argument of fix" in
+  (id,n,CProdN(loc,bl,ty))
 
-(* Functions overloaded by quotifier *)
+let mk_cofix_tac (loc,id,bl,ann,ty) =
+  let _ = option_map (fun (aloc,_) ->
+    Util.user_err_loc
+      (aloc,"Constr:mk_cofix_tac",
+       Pp.str"Annotation forbidden in cofix expression")) ann in
+  (id,CProdN(loc,bl,ty))
 
+(* Functions overloaded by quotifier *)
 let induction_arg_of_constr c =
-  try ElimOnIdent (Topconstr.constr_loc c,snd (coerce_to_id c))
+  try ElimOnIdent (constr_loc c,snd(coerce_to_id c))
   with _ -> ElimOnConstr c
 
-let local_compute = [FBeta;FIota;FDeltaBut [];FZeta]
-
-let error_oldelim _ = error "OldElim no longer supported"
-
-let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2)
-
 (* Auxiliary grammar rules *)
 
-if !Options.v7 then
 GEXTEND Gram
-  GLOBAL: simple_tactic constrarg bindings constr_with_bindings 
-  quantified_hypothesis red_expr int_or_var castedopenconstr open_constr
+  GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis
+  bindings red_expr int_or_var open_constr casted_open_constr 
   simple_intropattern;
 
   int_or_var:
-    [ [ n = integer  -> Genarg.ArgArg n
-      | id = identref -> Genarg.ArgVar id ] ]
-  ;
-  autoarg_depth:
-  [ [ n = OPT natural -> n ] ]
-  ;
-  autoarg_adding:
-  [ [ IDENT "Adding" ; "["; l = LIST1 global; "]" -> l | -> [] ] ]
-  ;
-  autoarg_destructing:
-  [ [ IDENT "Destructing" -> true | -> false ] ]
-  ;
-  autoarg_usingTDB:
-  [ [ "Using"; "TDB"  -> true | -> false ] ]
-  ;
-  autoargs:
-  [ [ a0 = autoarg_depth; l = autoarg_adding; 
-      a2 = autoarg_destructing; a3 = autoarg_usingTDB -> (a0,l,a2,a3) ] ]
-  ;
-  (* Either an hypothesis or a ltac ref (variable or pattern patvar) *)
-  id_or_ltac_ref:
-    [ [ id = base_ident -> AI (loc,id)
-      | "?"; n = natural -> AI (loc,Pattern.patvar_of_int n) ] ]
-  ;
-  (* Either a global ref or a ltac ref (variable or pattern patvar) *)
-  global_or_ltac_ref:
-    [ [ qid = global -> qid
-      | "?"; n = natural -> Libnames.Ident (loc,Pattern.patvar_of_int n) ] ]
+    [ [ n = integer  -> Rawterm.ArgArg n
+      | id = identref -> Rawterm.ArgVar id ] ]
   ;
   (* An identifier or a quotation meta-variable *)
   id_or_meta:
@@ -88,18 +137,10 @@ GEXTEND Gram
       |	id = METAIDENT -> MetaId (loc,id)
       ] ]
   ;
-  constrarg:
-    [ [ IDENT "Inst"; id = identref; "["; c = constr; "]" ->
-        ConstrContext (id, c)
-      | IDENT "Eval"; rtc = Tactic.red_expr; "in"; c = constr ->
-        ConstrEval (rtc,c) 
-      | IDENT "Check"; c = constr -> ConstrTypeOf c
-      | c = constr -> ConstrTerm c ] ]
-  ;
   open_constr:
     [ [ c = constr -> ((),c) ] ]
-   ;
-  castedopenconstr:
+  ;
+  casted_open_constr:
     [ [ c = constr -> ((),c) ] ]
   ;
   induction_arg:
@@ -108,40 +149,45 @@ GEXTEND Gram
     ] ]
   ;
   quantified_hypothesis:
-    [ [ id = base_ident -> NamedHyp id
+    [ [ id = ident -> NamedHyp id
       | n = natural -> AnonHyp n ] ]
   ;
   conversion:
-    [ [ nl = LIST1 integer; c1 = constr; "with"; c2 = constr ->
-         (Some (nl,c1), c2)
-      |	c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2)
-      | c = constr -> (None, c) ] ]
+    [ [ c = constr -> (None, c)
+      | c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2)
+      | c1 = constr; "at"; nl = LIST1 int_or_var; "with"; c2 = constr ->
+	  (Some (nl,c1), c2) ] ]
+  ;
+  occurrences:
+    [ [ "at"; nl = LIST1 int_or_var -> nl
+      | -> [] ] ]
   ;
   pattern_occ:
-    [ [ nl = LIST0 integer; c = constr -> (nl,c) ] ]
+    [ [ c = constr; nl = occurrences -> (nl,c) ] ]
+  ;
+  unfold_occ:
+    [ [ c = global; nl = occurrences -> (nl,c) ] ]
   ;
   intropatterns:
     [ [ l = LIST0 simple_intropattern -> l ]]
   ;
   simple_intropattern:
     [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc
-      | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc]
-      | IDENT "_" -> IntroWildcard
-      | id = base_ident -> IntroIdentifier id
+      | "("; tc = LIST0 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc]
+      | "()" -> IntroOrAndPattern [[]]
+      | "_" -> IntroWildcard
+      | "?" -> IntroAnonymous
+      | id = ident -> IntroIdentifier id
       ] ]
   ;
   simple_binding:
-    [ [ id = base_ident; ":="; c = constr -> (loc, NamedHyp id, c)
-      | n = natural; ":="; c = constr -> (loc, AnonHyp n, c) ] ]
+    [ [ "("; id = ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c)
+      | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ]
   ;
   bindings:
-    [ [ c1 = constr; ":="; c2 = constr; bl = LIST0 simple_binding ->
-          ExplicitBindings
-            ((join_to_constr loc c2,NamedHyp (snd(coerce_to_id c1)), c2) :: bl)
-      | n = natural; ":="; c = constr; bl = LIST0 simple_binding ->
-	  ExplicitBindings ((join_to_constr loc c,AnonHyp n, c) :: bl)
-      | c1 = constr; bl = LIST0 constr ->
-	  ImplicitBindings (c1 :: bl) ] ]
+    [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding ->
+          ExplicitBindings bl
+      | bl = LIST1 constr -> ImplicitBindings bl ] ]
   ;
   constr_with_bindings:
     [ [ c = constr; l = with_bindings -> (c, l) ] ]
@@ -149,222 +195,255 @@ GEXTEND Gram
   with_bindings:
     [ [ "with"; bl = bindings -> bl | -> NoBindings ] ]
   ;
-  unfold_occ:
-    [ [ nl = LIST0 integer; c = global_or_ltac_ref -> (nl,c) ] ]
-  ;
   red_flag:
-    [ [ IDENT "Beta" -> FBeta
-      | IDENT "Delta" -> FDeltaBut []
-      | IDENT "Iota" -> FIota
-      | IDENT "Zeta" -> FZeta
-      | IDENT "Delta"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FConst idl
-      | IDENT "Delta"; "-"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FDeltaBut idl
+    [ [ IDENT "beta" -> FBeta
+      | IDENT "delta" -> FDeltaBut []
+      | IDENT "iota" -> FIota
+      | IDENT "zeta" -> FZeta
+      | IDENT "delta"; "["; idl = LIST1 global; "]" -> FConst idl
+      | IDENT "delta"; "-"; "["; idl = LIST1 global; "]" -> FDeltaBut idl
     ] ]
   ;
   red_tactic:
-    [ [ IDENT "Red" -> Red false
-      | IDENT "Hnf" -> Hnf
-      | IDENT "Simpl"; po = OPT pattern_occ -> Simpl po
-      | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
-      | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
-      | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta])
-      | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul
-      | IDENT "Fold"; cl = LIST1 constr -> Fold cl
-      | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl ] ]
+    [ [ IDENT "red" -> Red false
+      | IDENT "hnf" -> Hnf
+      | IDENT "simpl"; po = OPT pattern_occ -> Simpl po
+      | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
+      | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
+      | IDENT "compute" -> compute
+      | IDENT "vm_compute" -> CbvVm
+      | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul
+      | IDENT "fold"; cl = LIST1 constr -> Fold cl
+      | IDENT "pattern"; pl = LIST1 pattern_occ SEP","-> Pattern pl ] ]
   ;
   (* This is [red_tactic] including possible extensions *)
   red_expr:
-    [ [ IDENT "Red" -> Red false
-      | IDENT "Hnf" -> Hnf
-      | IDENT "Simpl"; po = OPT pattern_occ -> Simpl po
-      | IDENT "Cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
-      | IDENT "Lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
-      | IDENT "Compute" -> Cbv (make_red_flag [FBeta;FIota;FDeltaBut [];FZeta])
-      | IDENT "Unfold"; ul = LIST1 unfold_occ -> Unfold ul
-      | IDENT "Fold"; cl = LIST1 constr -> Fold cl
-      | IDENT "Pattern"; pl = LIST1 pattern_occ -> Pattern pl
+    [ [ IDENT "red" -> Red false
+      | IDENT "hnf" -> Hnf
+      | IDENT "simpl"; po = OPT pattern_occ -> Simpl po
+      | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
+      | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
+      | IDENT "compute" -> compute
+      | IDENT "vm_compute" -> CbvVm
+      | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul
+      | IDENT "fold"; cl = LIST1 constr -> Fold cl
+      | IDENT "pattern"; pl = LIST1 pattern_occ -> Pattern pl
       | s = IDENT -> ExtraRedExpr s ] ]
   ;
   hypident:
-    [ [ id = id_or_meta -> id,[],(InHyp,ref None)
-      | "("; "Type"; "of"; id = id_or_meta; ")" ->
-          id,[],(InHypTypeOnly,ref None)
+    [ [ id = id_or_meta ->
+          id,InHyp
+      | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" ->
+	  id,InHypTypeOnly
+      | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" ->
+	  id,InHypValueOnly
     ] ]
   ;
+  hypident_occ:
+    [ [ (id,l)=hypident; occs=occurrences -> ((occs,id),l) ] ]
+  ;
   clause:
-    [ [ "in"; idl = LIST1 hypident ->
-        {onhyps=Some idl;onconcl=false; concl_occs=[]}
-      | -> {onhyps=Some[];onconcl=true;concl_occs=[]} ] ]
+    [ [ "in"; "*"; occs=occurrences ->
+        {onhyps=None;onconcl=true;concl_occs=occs}
+      | "in"; "*"; "|-"; (b,occs)=concl_occ ->
+          {onhyps=None; onconcl=b; concl_occs=occs}
+      | "in"; hl=LIST0 hypident_occ SEP","; "|-"; (b,occs)=concl_occ ->
+          {onhyps=Some hl; onconcl=b; concl_occs=occs}
+      | "in"; hl=LIST0 hypident_occ SEP"," ->
+          {onhyps=Some hl; onconcl=false; concl_occs=[]}
+      | -> {onhyps=Some[];onconcl=true; concl_occs=[]} ] ]
+  ;
+  concl_occ:
+    [ [ "*"; occs = occurrences -> (true,occs)
+      | -> (false, []) ] ]
   ;
   simple_clause:
     [ [ "in"; idl = LIST1 id_or_meta -> idl
       | -> [] ] ]
   ;
-  pattern_occ_hyp_tail_list:
-    [ [ pl = pattern_occ_hyp_list -> pl
-      | -> {onhyps=Some[];onconcl=false; concl_occs=[]} ] ]
-  ;
-  pattern_occ_hyp_list:
-    [ [ nl = LIST1 natural; IDENT "Goal" ->
-          {onhyps=Some[];onconcl=true;concl_occs=nl}
-      | nl = LIST1 natural; id = id_or_meta; cls = pattern_occ_hyp_tail_list
-        -> {cls with
-            onhyps=option_app(fun l -> (id,nl,(InHyp,ref None))::l)
-              cls.onhyps} 
-      | IDENT "Goal" -> {onhyps=Some[];onconcl=true;concl_occs=[]}
-      | id = id_or_meta; cls = pattern_occ_hyp_tail_list ->
-         {cls with
-          onhyps=option_app(fun l -> (id,[],(InHyp,ref None))::l)
-            cls.onhyps} ] ]
-  ;
-  clause_pattern:
-    [ [ "in"; p = pattern_occ_hyp_list -> p 
-      | -> {onhyps=None; onconcl=true; concl_occs=[] } ] ]
-  ;
+  orient: 
+    [ [ "->" -> true 
+      | "<-" -> false
+      | -> true ]]
+  ; 
   fixdecl:
-    [ [ id = base_ident; "/"; n = natural; ":"; c = constr -> (id,n,c) ] ]
+    [ [ "("; id = ident; bl=LIST0 Constr.binder; ann=fixannot;
+        ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ]
   ;
-  cofixdecl:
-    [ [ id = base_ident; ":"; c = constr -> (id,c) ] ]
+  fixannot:
+    [ [ "{"; IDENT "struct"; id=name; "}" -> Some id
+      | -> None ] ]
   ;
   hintbases:
     [ [ "with"; "*" -> None
       | "with"; l = LIST1 IDENT -> Some l
       | -> Some [] ] ]
   ;
+  auto_using:
+    [ [ "using"; l = LIST1 constr SEP "," -> l
+      | -> [] ] ]
+  ;
   eliminator:
     [ [ "using"; el = constr_with_bindings -> el ] ]
   ;
   with_names:
-    [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ]
+    [ [ "as"; ipat = simple_intropattern -> ipat | -> IntroAnonymous ] ]
+  ;
+  by_tactic:
+    [ [ IDENT "by"; tac = tactic_expr LEVEL "3" -> TacComplete tac
+      | -> TacId [] ] ]
   ;
   simple_tactic:
     [ [ 
       (* Basic tactics *)
-        IDENT "Intros"; IDENT "until"; id = quantified_hypothesis -> 
+        IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> 
 	  TacIntrosUntil id
-      | IDENT "Intros"; pl = intropatterns -> TacIntroPattern pl
-      | IDENT "Intro"; id = base_ident; IDENT "after"; id2 = identref ->
+      | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl
+      | IDENT "intro"; id = ident; IDENT "after"; id2 = identref ->
 	  TacIntroMove (Some id, Some id2)
-      | IDENT "Intro"; IDENT "after"; id2 = identref ->
+      | IDENT "intro"; IDENT "after"; id2 = identref ->
 	  TacIntroMove (None, Some id2)
-      | IDENT "Intro"; id = base_ident -> TacIntroMove (Some id,None)
-      | IDENT "Intro" -> TacIntroMove (None, None)
+      | IDENT "intro"; id = ident -> TacIntroMove (Some id, None)
+      | IDENT "intro" -> TacIntroMove (None, None)
 
-      | IDENT "Assumption" -> TacAssumption
-      | IDENT "Exact"; c = constr -> TacExact c
+      | IDENT "assumption" -> TacAssumption
+      | IDENT "exact"; c = constr -> TacExact c
+      | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c
+      | IDENT "vm_cast_no_check"; c = constr -> TacVmCastNoCheck c
 
-      | IDENT "Apply"; cl = constr_with_bindings -> TacApply cl
-      | IDENT "Elim"; cl = constr_with_bindings; el = OPT eliminator ->
+      | IDENT "apply"; cl = constr_with_bindings -> TacApply cl
+      | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator ->
           TacElim (cl,el)
-      | IDENT "OldElim"; c = constr ->
-	  (* TacOldElim c *) error_oldelim ()
-      | IDENT "ElimType"; c = constr -> TacElimType c
-      | IDENT "Case"; cl = constr_with_bindings -> TacCase cl
-      | IDENT "CaseType"; c = constr -> TacCaseType c
-      | IDENT "Fix"; n = natural -> TacFix (None,n)
-      | IDENT "Fix"; id = base_ident; n = natural -> TacFix (Some id,n)
-      | IDENT "Fix"; id = base_ident; n = natural; "with"; fd = LIST0 fixdecl ->
-	  TacMutualFix (id,n,fd)
-      | IDENT "Cofix" -> TacCofix None
-      | IDENT "Cofix"; id = base_ident -> TacCofix (Some id)
-      | IDENT "Cofix"; id = base_ident; "with"; fd = LIST0 cofixdecl ->
-	  TacMutualCofix (id,fd)
-
-      | IDENT "Cut"; c = constr -> TacCut c
-      | IDENT "Assert"; c = constr -> TacTrueCut (Names.Anonymous,c)
-      | IDENT "Assert"; c = constr; ":"; t = constr ->
-          TacTrueCut (Names.Name (snd(coerce_to_id c)),t)
-      | IDENT "Assert"; c = constr; ":="; b = constr ->
-          TacForward (false,Names.Name (snd (coerce_to_id c)),b)
-      | IDENT "Pose"; c = constr; ":="; b = constr ->
-	  TacForward (true,Names.Name (snd(coerce_to_id c)),b)
-      | IDENT "Pose"; b = constr -> TacForward (true,Names.Anonymous,b)
-      | IDENT "Generalize"; lc = LIST1 constr -> TacGeneralize lc
-      | IDENT "Generalize"; IDENT "Dependent"; c = constr -> TacGeneralizeDep c
-      | IDENT "LetTac"; (_,na) = name; ":="; c = constr; p = clause_pattern
-        -> TacLetTac (na,c,p)
-      | IDENT "Instantiate"; n = natural; c = constr; cls = clause -> 
-	    TacInstantiate (n,c,cls)
-      | IDENT "Specialize"; n = OPT natural; lcb = constr_with_bindings ->
+      | IDENT "elimtype"; c = constr -> TacElimType c
+      | IDENT "case"; cl = constr_with_bindings -> TacCase cl
+      | IDENT "casetype"; c = constr -> TacCaseType c
+      | "fix"; n = natural -> TacFix (None,n)
+      | "fix"; id = ident; n = natural -> TacFix (Some id,n)
+      | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl ->
+	  TacMutualFix (id,n,List.map mk_fix_tac fd)
+      | "cofix" -> TacCofix None
+      | "cofix"; id = ident -> TacCofix (Some id)
+      | "cofix"; id = ident; "with"; fd = LIST1 fixdecl ->
+	  TacMutualCofix (id,List.map mk_cofix_tac fd)
+
+      | IDENT "pose"; id = lpar_id_coloneq; b = lconstr; ")" ->
+	  TacLetTac (Names.Name id,b,nowhere)
+      | IDENT "pose"; b = constr ->
+	  TacLetTac (Names.Anonymous,b,nowhere)
+      | IDENT "set"; id = lpar_id_coloneq; c = lconstr; ")"; p = clause ->
+	  TacLetTac (Names.Name id,c,p)
+      | IDENT "set"; c = constr; p = clause ->
+          TacLetTac (Names.Anonymous,c,p)
+
+      (* Begin compatibility *)
+      | IDENT "assert"; id = lpar_id_coloneq; c = lconstr; ")" -> 
+	  TacAssert (None,IntroIdentifier id,c)
+      | IDENT "assert"; id = lpar_id_colon; c = lconstr; ")"; tac=by_tactic -> 
+	  TacAssert (Some tac,IntroIdentifier id,c)
+      (* End compatibility *)
+
+      | IDENT "assert"; c = constr; ipat = with_names; tac = by_tactic ->
+	  TacAssert (Some tac,ipat,c)
+      | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = with_names ->
+	  TacAssert (None,ipat,c)
+
+      | IDENT "cut"; c = constr -> TacCut c
+      | IDENT "generalize"; lc = LIST1 constr -> TacGeneralize lc
+      | IDENT "generalize"; IDENT "dependent"; c = constr -> TacGeneralizeDep c
+    (*  | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")"; "in";
+	  hid = hypident ->
+	    let (id,(hloc,_)) = hid in
+              TacInstantiate (n,c,HypLocation (id,hloc))
+      | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")" ->
+            TacInstantiate (n,c,ConclLocation ()) *)
+
+      | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings ->
 	  TacSpecialize (n,lcb)
-      | IDENT "LApply"; c = constr -> TacLApply c
+      | IDENT "lapply"; c = constr -> TacLApply c
 
       (* Derived basic tactics *)
-      | IDENT "Induction"; h = quantified_hypothesis -> TacSimpleInduction (h,ref [])
-      | IDENT "NewInduction"; c = induction_arg; el = OPT eliminator;
-          ids = with_names -> TacNewInduction (c,el,(ids,ref []))
-      | IDENT "Double"; IDENT "Induction"; h1 = quantified_hypothesis;
+      | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis ->
+          TacSimpleInduction h
+      | IDENT "induction"; lc = LIST1 induction_arg; ids = with_names; 
+	  el = OPT eliminator -> TacNewInduction (lc,el,ids)
+      | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis;
 	  h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2)
-      | IDENT "Destruct"; h = quantified_hypothesis -> TacSimpleDestruct h
-      | IDENT "NewDestruct"; c = induction_arg; el = OPT eliminator; 
-          ids = with_names -> TacNewDestruct (c,el,(ids,ref []))
-      | IDENT "Decompose"; IDENT "Record" ; c = constr -> TacDecomposeAnd c
-      | IDENT "Decompose"; IDENT "Sum"; c = constr -> TacDecomposeOr c
-      | IDENT "Decompose"; "["; l = LIST1 global_or_ltac_ref; "]"; c = constr
+      | IDENT "simple"; IDENT"destruct"; h = quantified_hypothesis ->
+          TacSimpleDestruct h
+      | IDENT "destruct"; lc = LIST1 induction_arg; ids = with_names; 
+	  el = OPT eliminator -> TacNewDestruct (lc,el,ids)
+      | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c
+      | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c
+      | IDENT "decompose"; "["; l = LIST1 global; "]"; c = constr
         -> TacDecompose (l,c)
 
       (* Automation tactic *)
-      | IDENT "Trivial"; db = hintbases -> TacTrivial db
-      | IDENT "Auto"; n = OPT int_or_var; db = hintbases -> TacAuto (n, db)
-
-      | IDENT "AutoTDB"; n = OPT natural -> TacAutoTDB n
-      | IDENT "CDHyp"; id = identref -> TacDestructHyp (true,id)
-      | IDENT "DHyp";  id = identref -> TacDestructHyp (false,id)
-      | IDENT "DConcl"  -> TacDestructConcl
-      | IDENT "SuperAuto"; l = autoargs -> TacSuperAuto l
-      | IDENT "Auto"; n = OPT int_or_var; IDENT "Decomp"; p = OPT natural ->
+      | IDENT "trivial"; lems = auto_using; db = hintbases ->
+	  TacTrivial (lems,db)
+      | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases ->
+	  TacAuto (n,lems,db)
+
+(* Obsolete since V8.0
+      | IDENT "autotdb"; n = OPT natural -> TacAutoTDB n
+      | IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id)
+      | IDENT "dhyp";  id = identref -> TacDestructHyp (false,id)
+      | IDENT "dconcl"  -> TacDestructConcl
+      | IDENT "superauto"; l = autoargs -> TacSuperAuto l
+*)
+      | IDENT "auto"; n = OPT int_or_var; IDENT "decomp"; p = OPT natural ->
 	  TacDAuto (n, p)
 
       (* Context management *)
-      | IDENT "Clear"; l = LIST1 id_or_ltac_ref -> TacClear l
-      | IDENT "ClearBody"; l = LIST1 id_or_ltac_ref -> TacClearBody l
-      | IDENT "Move"; id1 = id_or_ltac_ref; IDENT "after"; 
-	  id2 = id_or_ltac_ref -> TacMove (true,id1,id2)
-      | IDENT "Rename"; id1 = id_or_ltac_ref; IDENT "into"; 
-	  id2 = id_or_ltac_ref -> TacRename (id1,id2)
+      | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l)
+      | IDENT "clear"; l = LIST0 id_or_meta -> TacClear (l=[], l)
+      | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l
+      | IDENT "move"; id1 = id_or_meta; IDENT "after"; id2 = id_or_meta -> 
+	  TacMove (true,id1,id2)
+      | IDENT "rename"; id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> 
+	  TacRename (id1,id2)
 
       (* Constructors *)
-      | IDENT "Left"; bl = with_bindings -> TacLeft bl
-      | IDENT "Right"; bl = with_bindings -> TacRight bl
-      | IDENT "Split"; bl = with_bindings -> TacSplit (false,bl)
-      | IDENT "Exists"; bl = bindings -> TacSplit (true,bl)
-      | IDENT "Exists" -> TacSplit (true,NoBindings)
-      | IDENT "Constructor"; n = num_or_meta; l = with_bindings ->
+      | IDENT "left"; bl = with_bindings -> TacLeft bl
+      | IDENT "right"; bl = with_bindings -> TacRight bl
+      | IDENT "split"; bl = with_bindings -> TacSplit (false,bl)
+      | "exists"; bl = bindings -> TacSplit (true,bl)
+      | "exists" -> TacSplit (true,NoBindings)
+      | IDENT "constructor"; n = num_or_meta; l = with_bindings ->
 	  TacConstructor (n,l)
-      | IDENT "Constructor"; t = OPT tactic -> TacAnyConstructor t
+      | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor t
 
       (* Equivalence relations *)
-      | IDENT "Reflexivity" -> TacReflexivity
-      | IDENT "Symmetry"; cls = clause -> TacSymmetry cls
-      | IDENT "Transitivity"; c = constr -> TacTransitivity c
+      | IDENT "reflexivity" -> TacReflexivity
+      | IDENT "symmetry"; cls = clause -> TacSymmetry cls
+      | IDENT "transitivity"; c = constr -> TacTransitivity c
 
       (* Equality and inversion *)
-      | IDENT "Dependent"; k =
-	  [ IDENT "Simple"; IDENT "Inversion" -> SimpleInversion
-	  | IDENT "Inversion" -> FullInversion
-	  | IDENT "Inversion_clear" -> FullInversionClear ];
+      | IDENT "rewrite"; b = orient; c = constr_with_bindings ; cl = clause -> 
+	  TacRewrite (b,c,cl)
+      | IDENT "dependent"; k =
+	  [ IDENT "simple"; IDENT "inversion" -> SimpleInversion
+	  | IDENT "inversion" -> FullInversion
+	  | IDENT "inversion_clear" -> FullInversionClear ];
 	  hyp = quantified_hypothesis; 
 	  ids = with_names; co = OPT ["with"; c = constr -> c] ->
 	    TacInversion (DepInversion (k,co,ids),hyp)
-      | IDENT "Simple"; IDENT "Inversion";
+      | IDENT "simple"; IDENT "inversion";
 	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
 	    TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)
-      | IDENT "Inversion"; 
+      | IDENT "inversion"; 
 	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
 	    TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)
-      | IDENT "Inversion_clear"; 
+      | IDENT "inversion_clear"; 
 	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
 	    TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)
-      | IDENT "Inversion"; hyp = quantified_hypothesis; 
+      | IDENT "inversion"; hyp = quantified_hypothesis; 
 	  "using"; c = constr; cl = simple_clause ->
 	    TacInversion (InversionUsing (c,cl), hyp)
 
       (* Conversion *)
       | r = red_tactic; cl = clause -> TacReduce (r, cl)
       (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *)
-      | IDENT "Change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl)
-
+      | IDENT "change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl)
     ] ]
   ;
 END;;
diff --git a/parsing/g_tacticnew.ml4 b/parsing/g_tacticnew.ml4
deleted file mode 100644
index 5ffd2fd7..00000000
--- a/parsing/g_tacticnew.ml4
+++ /dev/null
@@ -1,405 +0,0 @@
-(************************************************************************)
-(*  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: g_tacticnew.ml4,v 1.35.2.7 2005/05/15 12:47:05 herbelin Exp $ *)
-
-open Pp
-open Ast
-open Pcoq
-open Util
-open Tacexpr
-open Rawterm
-open Genarg
-
-let compute = Cbv all_flags
-
-let tactic_kw =
-  [ "->"; "<-" ]
-let _ = 
-  if not !Options.v7 then
-    List.iter (fun s -> Lexer.add_token("",s)) tactic_kw
-
-(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *)
-(* admissible notation "(x t)" *)
-let lpar_id_coloneq =
-  Gram.Entry.of_parser "lpar_id_coloneq"
-    (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("","(")] ->
-            (match Stream.npeek 2 strm with
-              | [_; ("IDENT",s)] ->
-                  (match Stream.npeek 3 strm with
-	            | [_; _; ("", ":=")] ->
-                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
-                        Names.id_of_string s
-	            | _ -> raise Stream.Failure)
-	      | _ -> raise Stream.Failure)
-	| _ -> raise Stream.Failure)
-
-(* idem for (x:=t) and (1:=t) *)
-let test_lpar_idnum_coloneq =
-  Gram.Entry.of_parser "test_lpar_idnum_coloneq"
-    (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("","(")] ->
-            (match Stream.npeek 2 strm with
-              | [_; (("IDENT"|"INT"),_)] ->
-                  (match Stream.npeek 3 strm with
-                    | [_; _; ("", ":=")] -> ()
-                    | _ -> raise Stream.Failure)
-              | _ -> raise Stream.Failure)
-        | _ -> raise Stream.Failure)
-
-(* idem for (x:t) *)
-let lpar_id_colon =
-  Gram.Entry.of_parser "lpar_id_colon"
-    (fun strm ->
-      match Stream.npeek 1 strm with
-        | [("","(")] ->
-            (match Stream.npeek 2 strm with
-              | [_; ("IDENT",id)] ->
-                  (match Stream.npeek 3 strm with
-                    | [_; _; ("", ":")] ->
-                        Stream.junk strm; Stream.junk strm; Stream.junk strm;
-                        Names.id_of_string id
-                    | _ -> raise Stream.Failure)
-              | _ -> raise Stream.Failure)
-        | _ -> raise Stream.Failure)
-
-open Constr
-open Prim
-open Tactic
-
-let mk_fix_tac (loc,id,bl,ann,ty) =
-  let n =
-    match bl,ann with
-        [([_],_)], None -> 1
-      | _, Some x ->
-          let ids = List.map snd (List.flatten (List.map fst bl)) in
-          (try list_index (snd x) ids
-          with Not_found -> error "no such fix variable")
-      | _ -> error "cannot guess decreasing argument of fix" in
-  (id,n,Topconstr.CProdN(loc,bl,ty))
-
-let mk_cofix_tac (loc,id,bl,ann,ty) =
-  let _ = option_app (fun (aloc,_) ->
-    Util.user_err_loc
-      (aloc,"Constr:mk_cofix_tac",
-       Pp.str"Annotation forbidden in cofix expression")) ann in
-  (id,Topconstr.CProdN(loc,bl,ty))
-
-(* Functions overloaded by quotifier *)
-let induction_arg_of_constr c =
-  try ElimOnIdent (Topconstr.constr_loc c,snd(coerce_to_id c))
-  with _ -> ElimOnConstr c
-
-let local_compute = [FBeta;FIota;FDeltaBut [];FZeta]
-
-let error_oldelim _ = error "OldElim no longer supported"
-
-let join_to_constr loc c2 = (fst loc), snd (Topconstr.constr_loc c2)
-
-(* Auxiliary grammar rules *)
-
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis
-  bindings red_expr int_or_var open_constr castedopenconstr 
-  simple_intropattern;
-
-  int_or_var:
-    [ [ n = integer  -> Genarg.ArgArg n
-      | id = identref -> Genarg.ArgVar id ] ]
-  ;
-  (* An identifier or a quotation meta-variable *)
-  id_or_meta:
-    [ [ id = identref -> AI id 
-
-      (* This is used in quotations *)
-      | id = METAIDENT -> MetaId (loc,id) ] ]
-  ;
-  (* A number or a quotation meta-variable *)
-  num_or_meta:
-    [ [ n = integer -> AI n
-      |	id = METAIDENT -> MetaId (loc,id)
-      ] ]
-  ;
-  open_constr:
-    [ [ c = constr -> ((),c) ] ]
-   ;
-  castedopenconstr:
-    [ [ c = constr -> ((),c) ] ]
-  ;
-  induction_arg:
-    [ [ n = natural -> ElimOnAnonHyp n
-      | c = constr -> induction_arg_of_constr c
-    ] ]
-  ;
-  quantified_hypothesis:
-    [ [ id = base_ident -> NamedHyp id
-      | n = natural -> AnonHyp n ] ]
-  ;
-  conversion:
-    [ [ c = constr -> (None, c)
-      | c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2)
-      | c1 = constr; "at"; nl = LIST1 integer; "with"; c2 = constr ->
-	  (Some (nl,c1), c2) ] ]
-  ;
-  occurrences:
-    [ [ "at"; nl = LIST1 integer -> nl
-      | -> [] ] ]
-  ;
-  pattern_occ:
-    [ [ c = constr; nl = occurrences -> (nl,c) ] ]
-  ;
-  unfold_occ:
-    [ [ c = global; nl = occurrences -> (nl,c) ] ]
-  ;
-  intropatterns:
-    [ [ l = LIST0 simple_intropattern -> l ]]
-  ;
-  simple_intropattern:
-    [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc
-      | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc]
-      | "_" -> IntroWildcard
-      | id = base_ident -> IntroIdentifier id
-      ] ]
-  ;
-  simple_binding:
-    [ [ "("; id = base_ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c)
-      | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ]
-  ;
-  bindings:
-    [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding ->
-          ExplicitBindings bl
-      | bl = LIST1 constr -> ImplicitBindings bl ] ]
-  ;
-  constr_with_bindings:
-    [ [ c = constr; l = with_bindings -> (c, l) ] ]
-  ;
-  with_bindings:
-    [ [ "with"; bl = bindings -> bl | -> NoBindings ] ]
-  ;
-  red_flag:
-    [ [ IDENT "beta" -> FBeta
-      | IDENT "delta" -> FDeltaBut []
-      | IDENT "iota" -> FIota
-      | IDENT "zeta" -> FZeta
-      | IDENT "delta"; "["; idl = LIST1 global; "]" -> FConst idl
-      | IDENT "delta"; "-"; "["; idl = LIST1 global; "]" -> FDeltaBut idl
-    ] ]
-  ;
-  red_tactic:
-    [ [ IDENT "red" -> Red false
-      | IDENT "hnf" -> Hnf
-      | IDENT "simpl"; po = OPT pattern_occ -> Simpl po
-      | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
-      | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
-      | IDENT "compute" -> compute
-      | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul
-      | IDENT "fold"; cl = LIST1 constr -> Fold cl
-      | IDENT "pattern"; pl = LIST1 pattern_occ SEP","-> Pattern pl ] ]
-  ;
-  (* This is [red_tactic] including possible extensions *)
-  red_expr:
-    [ [ IDENT "red" -> Red false
-      | IDENT "hnf" -> Hnf
-      | IDENT "simpl"; po = OPT pattern_occ -> Simpl po
-      | IDENT "cbv"; s = LIST1 red_flag -> Cbv (make_red_flag s)
-      | IDENT "lazy"; s = LIST1 red_flag -> Lazy (make_red_flag s)
-      | IDENT "compute" -> compute
-      | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul
-      | IDENT "fold"; cl = LIST1 constr -> Fold cl
-      | IDENT "pattern"; pl = LIST1 pattern_occ -> Pattern pl
-      | s = IDENT; OPT [ (* compat V8.0pl1 *) constr ] -> ExtraRedExpr s ] ]
-  ;
-  hypident:
-    [ [ id = id_or_meta -> id,(InHyp,ref None)
-      | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" ->
-          id,(InHypTypeOnly,ref None)
-      | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" ->
-          id,(InHypValueOnly,ref None)
-    ] ]
-  ;
-  hypident_occ:
-    [ [ (id,l)=hypident; occs=occurrences -> (id,occs,l) ] ]
-  ;
-  clause:
-    [ [ "in"; "*"; occs=occurrences ->
-        {onhyps=None;onconcl=true;concl_occs=occs}
-      | "in"; "*"; "|-"; (b,occs)=concl_occ ->
-          {onhyps=None; onconcl=b; concl_occs=occs}
-      | "in"; hl=LIST0 hypident_occ SEP","; "|-"; (b,occs)=concl_occ ->
-          {onhyps=Some hl; onconcl=b; concl_occs=occs}
-      | "in"; hl=LIST0 hypident_occ SEP"," ->
-          {onhyps=Some hl; onconcl=false; concl_occs=[]}
-      | -> {onhyps=Some[];onconcl=true; concl_occs=[]} ] ]
-  ;
-  concl_occ:
-    [ [ "*"; occs = occurrences -> (true,occs)
-      | -> (false, []) ] ]
-  ;
-  simple_clause:
-    [ [ "in"; idl = LIST1 id_or_meta -> idl
-      | -> [] ] ]
-  ;
-  fixdecl:
-    [ [ "("; id = base_ident; bl=LIST0 Constr.binder; ann=fixannot;
-        ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ]
-  ;
-  fixannot:
-    [ [ "{"; IDENT "struct"; id=name; "}" -> Some id
-      | -> None ] ]
-  ;
-  hintbases:
-    [ [ "with"; "*" -> None
-      | "with"; l = LIST1 IDENT -> Some l
-      | -> Some [] ] ]
-  ;
-  eliminator:
-    [ [ "using"; el = constr_with_bindings -> el ] ]
-  ;
-  with_names:
-    [ [ "as"; ipat = simple_intropattern -> Some ipat | -> None ] ]
-  ;
-  simple_tactic:
-    [ [ 
-      (* Basic tactics *)
-        IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> 
-	  TacIntrosUntil id
-      | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl
-      | IDENT "intro"; id = base_ident; IDENT "after"; id2 = identref ->
-	  TacIntroMove (Some id, Some id2)
-      | IDENT "intro"; IDENT "after"; id2 = identref ->
-	  TacIntroMove (None, Some id2)
-      | IDENT "intro"; id = base_ident -> TacIntroMove (Some id, None)
-      | IDENT "intro" -> TacIntroMove (None, None)
-
-      | IDENT "assumption" -> TacAssumption
-      | IDENT "exact"; c = constr -> TacExact c
-
-      | IDENT "apply"; cl = constr_with_bindings -> TacApply cl
-      | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator ->
-          TacElim (cl,el)
-      | IDENT "elimtype"; c = constr -> TacElimType c
-      | IDENT "case"; cl = constr_with_bindings -> TacCase cl
-      | IDENT "casetype"; c = constr -> TacCaseType c
-      | "fix"; n = natural -> TacFix (None,n)
-      | "fix"; id = base_ident; n = natural -> TacFix (Some id,n)
-      | "fix"; id = base_ident; n = natural; "with"; fd = LIST1 fixdecl ->
-	  TacMutualFix (id,n,List.map mk_fix_tac fd)
-      | "cofix" -> TacCofix None
-      | "cofix"; id = base_ident -> TacCofix (Some id)
-      | "cofix"; id = base_ident; "with"; fd = LIST1 fixdecl ->
-	  TacMutualCofix (id,List.map mk_cofix_tac fd)
-
-      | IDENT "cut"; c = constr -> TacCut c
-      | IDENT "assert"; id = lpar_id_colon; t = lconstr; ")" ->
-          TacTrueCut (Names.Name id,t)
-      | IDENT "assert"; id = lpar_id_coloneq; b = lconstr; ")" ->
-          TacForward (false,Names.Name id,b)
-      | IDENT "assert"; c = constr -> TacTrueCut (Names.Anonymous,c)
-      | IDENT "pose"; id = lpar_id_coloneq; b = lconstr; ")" ->
-	  TacForward (true,Names.Name id,b)
-      | IDENT "pose"; b = constr -> TacForward (true,Names.Anonymous,b)
-      | IDENT "generalize"; lc = LIST1 constr -> TacGeneralize lc
-      | IDENT "generalize"; IDENT "dependent"; c = constr ->
-          TacGeneralizeDep c
-      | IDENT "set"; id = lpar_id_coloneq; c = lconstr; ")";
-          p = clause -> TacLetTac (Names.Name id,c,p)
-      | IDENT "set"; c = constr; p = clause ->
-          TacLetTac (Names.Anonymous,c,p)
-      | IDENT "instantiate"; "("; n = natural; ":="; c = lconstr; ")";
-	  cls = clause ->
-            TacInstantiate (n,c,cls)
-	    
-      | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings ->
-	  TacSpecialize (n,lcb)
-      | IDENT "lapply"; c = constr -> TacLApply c
-
-      (* Derived basic tactics *)
-      | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis ->
-          TacSimpleInduction (h,ref [])
-      | IDENT "induction"; c = induction_arg; ids = with_names; 
-	  el = OPT eliminator -> TacNewInduction (c,el,(ids,ref []))
-      | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis;
-	  h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2)
-      | IDENT "simple"; IDENT"destruct"; h = quantified_hypothesis ->
-          TacSimpleDestruct h
-      | IDENT "destruct"; c = induction_arg; ids = with_names; 
-	  el = OPT eliminator -> TacNewDestruct (c,el,(ids,ref []))
-      | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c
-      | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c
-      | IDENT "decompose"; "["; l = LIST1 global; "]"; c = constr
-        -> TacDecompose (l,c)
-
-      (* Automation tactic *)
-      | IDENT "trivial"; db = hintbases -> TacTrivial db
-      | IDENT "auto"; n = OPT int_or_var; db = hintbases -> TacAuto (n, db)
-
-(* Obsolete since V8.0
-      | IDENT "autotdb"; n = OPT natural -> TacAutoTDB n
-      | IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id)
-      | IDENT "dhyp";  id = identref -> TacDestructHyp (false,id)
-      | IDENT "dconcl"  -> TacDestructConcl
-      | IDENT "superauto"; l = autoargs -> TacSuperAuto l
-*)
-      | IDENT "auto"; n = OPT int_or_var; IDENT "decomp"; p = OPT natural ->
-	  TacDAuto (n, p)
-
-      (* Context management *)
-      | IDENT "clear"; l = LIST1 id_or_meta -> TacClear l
-      | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l
-      | IDENT "move"; id1 = id_or_meta; IDENT "after"; id2 = id_or_meta -> 
-	  TacMove (true,id1,id2)
-      | IDENT "rename"; id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> 
-	  TacRename (id1,id2)
-
-      (* Constructors *)
-      | IDENT "left"; bl = with_bindings -> TacLeft bl
-      | IDENT "right"; bl = with_bindings -> TacRight bl
-      | IDENT "split"; bl = with_bindings -> TacSplit (false,bl)
-      | "exists"; bl = bindings -> TacSplit (true,bl)
-      | "exists" -> TacSplit (true,NoBindings)
-      | IDENT "constructor"; n = num_or_meta; l = with_bindings ->
-	  TacConstructor (n,l)
-      | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor t
-
-      (* Equivalence relations *)
-      | IDENT "reflexivity" -> TacReflexivity
-      | IDENT "symmetry"; cls = clause -> TacSymmetry cls
-      | IDENT "transitivity"; c = constr -> TacTransitivity c
-
-      (* Equality and inversion *)
-      | IDENT "dependent"; k =
-	  [ IDENT "simple"; IDENT "inversion" -> SimpleInversion
-	  | IDENT "inversion" -> FullInversion
-	  | IDENT "inversion_clear" -> FullInversionClear ];
-	  hyp = quantified_hypothesis; 
-	  ids = with_names; co = OPT ["with"; c = constr -> c] ->
-	    TacInversion (DepInversion (k,co,ids),hyp)
-      | IDENT "simple"; IDENT "inversion";
-	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
-	    TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)
-      | IDENT "inversion"; 
-	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
-	    TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)
-      | IDENT "inversion_clear"; 
-	  hyp = quantified_hypothesis; ids = with_names; cl = simple_clause ->
-	    TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)
-      | IDENT "inversion"; hyp = quantified_hypothesis; 
-	  "using"; c = constr; cl = simple_clause ->
-	    TacInversion (InversionUsing (c,cl), hyp)
-
-      (* Conversion *)
-      | r = red_tactic; cl = clause -> TacReduce (r, cl)
-      (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *)
-      | IDENT "change"; (oc,c) = conversion; cl = clause -> TacChange (oc,c,cl)
-    ] ]
-  ;
-END;;
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
index 87183e18..9a98df80 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -6,37 +6,57 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_vernac.ml4,v 1.93.2.3 2004/10/12 10:11:28 herbelin Exp $ *)
+(* $Id: g_vernac.ml4 9562 2007-01-31 09:00:36Z msozeau $ *)
+(*i camlp4deps: "parsing/grammar.cma" i*)
 
+open Pp
+open Util
 open Names
 open Topconstr
 open Vernacexpr
 open Pcoq
-open Pp
+open Decl_mode
 open Tactic
-open Util
-open Constr
-open Vernac_
-open Prim
 open Decl_kinds
-
 open Genarg
+open Extend
+open Ppextend
+open Goptions
 
-let evar_constr loc = CHole loc
+open Prim
+open Constr
+open Vernac_
+open Module
 
-let class_rawexpr = G_basevernac.class_rawexpr
-let thm_token = G_proofs.thm_token
+let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ]
+let _ = List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw
 
 (* Rem: do not join the different GEXTEND into one, it breaks native *)
 (* compilation on PowerPC and Sun architectures *)
 
-let filter_com (b,e) =
-  let (b,e) = unloc (b,e) in
-  Pp.comments := List.filter (fun ((b',e'),s) -> b'<b || e'>e) !Pp.comments 
+let check_command = Gram.Entry.create "vernac:check_command"
+
+let tactic_mode = Gram.Entry.create "vernac:tactic_command"
+let proof_mode = Gram.Entry.create "vernac:proof_command"
+let noedit_mode = Gram.Entry.create "vernac:noedit_command"
+
+let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr"
+let thm_token = Gram.Entry.create "vernac:thm_token"
+let def_body = Gram.Entry.create "vernac:def_body"
+
+let get_command_entry () =
+  match Decl_mode.get_current_mode () with
+      Mode_proof -> proof_mode
+    | Mode_tactic -> tactic_mode
+    | Mode_none -> noedit_mode
 
-if !Options.v7 then
+let default_command_entry =
+  Gram.Entry.of_parser "command_entry" 
+    (fun strm -> Gram.Entry.parse_token (get_command_entry ()) strm)
+
+let no_hook _ _ = ()
 GEXTEND Gram
-  GLOBAL: vernac gallina_ext;
+  GLOBAL: vernac gallina_ext tactic_mode proof_mode noedit_mode;
   vernac:
     (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *)
     (* "." is still in the stream and discard_to_dot works correctly         *)
@@ -44,163 +64,133 @@ GEXTEND Gram
       | g = gallina_ext; "." -> g
       | c = command; "." -> c 
       | c = syntax; "." -> c
-      | n = natural; ":"; tac = Tactic.tactic; "." -> VernacSolve (n,tac,true) 
-      | n = natural; ":"; tac = Tactic.tactic; "!!" -> VernacSolve (n,tac,false)
-      | n = natural; ":"; v = check_command; "." -> v (Some n)
-      | "["; l = vernac_list_tail -> VernacList l
-
-      (* For translation from V7 to V8 *)
-      | IDENT "V7only"; v = vernac ->
-          filter_com loc; VernacV7only v
-      | IDENT "V8only"; v = vernac -> VernacV8only v
-
-(*
-      (* This is for "Grammar vernac" rules *)
-      | id = METAIDENT -> VernacVar (Names.id_of_string id)
-*)
+      | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l
     ] ]
   ;
-    
-  check_command:
-    [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = constr ->
-          fun g -> VernacCheckMayEval (Some r, g, c)
-      | IDENT "Check"; c = constr ->
-	  fun g -> VernacCheckMayEval (None, g, c) ] ]
-  ;
   vernac: FIRST
     [ [ IDENT "Time"; v = vernac  -> VernacTime v ] ]
   ;
-  vernac: LAST
-    [ [ tac = Tactic.tactic; "." -> VernacSolve (1,tac,true)
-      | tac = Tactic.tactic; "!!" -> VernacSolve (1,tac,false)
-      | IDENT "Existential"; n = natural; c = constr_body ->
-	  VernacSolveExistential (n,c)
-    ] ]
+  vernac: LAST  
+    [ [ prfcom = default_command_entry -> prfcom ] ]
+  ;
+  noedit_mode:
+    [ [ c = subgoal_command -> c None] ]
   ;
-  constr_body:
-    [ [ ":="; c = constr; ":"; t = constr -> CCast(loc,c,t)
-      | ":"; t = constr; ":="; c = constr -> CCast(loc,c,t)
-      | ":="; c = constr -> c ] ]
+  tactic_mode:
+  [ [ gln = OPT[n=natural; ":" -> n];
+      tac = subgoal_command -> tac gln ] ]
   ;
-  vernac_list_tail:
-    [ [ v = located_vernac; l = vernac_list_tail -> v :: l
-      | "]"; "." -> [] ] ]
+  subgoal_command:
+    [ [ c = check_command; "." -> c
+      | tac = Tactic.tactic;
+        use_dft_tac = [ "." -> false | "..." -> true ] ->
+          (fun g ->
+            let g = match g with Some gl -> gl | _ -> 1 in
+            VernacSolve(g,tac,use_dft_tac)) ] ]
   ;
+  proof_mode:
+    [ [ instr = proof_instr; "." -> VernacProofInstr instr ] ] 
+  ;
+  proof_mode: LAST
+    [ [ c=subgoal_command -> c (Some 1) ] ]
+  ; 
   located_vernac:
     [ [ v = vernac -> loc, v ] ]
   ;
 END
 
+
 let test_plurial_form = function
-  | [_,([_],_)] ->
+  | [(_,([_],_))] ->
       Options.if_verbose warning
-      "Keywords Variables/Hypotheses/Parameters expect more than one assumption"
+   "Keywords Variables/Hypotheses/Parameters expect more than one assumption"
   | _ -> ()
 
+let no_coercion loc (c,x) =
+  if c then Util.user_err_loc
+    (loc,"no_coercion",Pp.str"no coercion allowed here");
+  x
+
 (* Gallina declarations *)
-if !Options.v7 then
 GEXTEND Gram
-  GLOBAL: gallina gallina_ext thm_token;
+  GLOBAL: gallina gallina_ext thm_token def_body;
 
+  gallina:
+      (* Definition, Theorem, Variable, Axiom, ... *)
+    [ [ thm = thm_token; id = identref; bl = LIST0 binder_let; ":";
+        c = lconstr ->
+          VernacStartTheoremProof (thm, id, (bl, c), false, no_hook)
+      | stre = assumption_token; bl = assum_list -> 
+	  VernacAssumption (stre, bl)
+      | stre = assumptions_token; bl = assum_list ->
+	  test_plurial_form bl;
+	  VernacAssumption (stre, bl)
+      | IDENT "Boxed";"Definition";id = identref; b = def_body -> 
+	  VernacDefinition ((Global,true,Definition), id, b, no_hook)
+      | IDENT "Unboxed";"Definition";id = identref; b = def_body -> 
+	  VernacDefinition ((Global,false,Definition), id, b, no_hook)
+      | (f,d) = def_token; id = identref; b = def_body -> 
+          VernacDefinition (d, id, b, f)
+      (* Gallina inductive declarations *)
+      | f = finite_token;
+        indl = LIST1 inductive_definition SEP "with" ->
+          VernacInductive (f,indl)
+      | IDENT "Boxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint (recs,true)
+      | IDENT "Unboxed";"Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint (recs,false)
+       | "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint (recs,Options.boxed_definitions())
+      | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
+          VernacCoFixpoint (corecs,false)
+      | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l ] ]
+  ;
+  gallina_ext:
+    [ [ b = record_token; oc = opt_coercion; name = identref;
+        ps = LIST0 binder_let; ":";
+	s = lconstr; ":="; cstr = OPT identref; "{";
+        fs = LIST0 record_field SEP ";"; "}" ->
+	  VernacRecord (b,(oc,name),ps,s,cstr,fs)
+(* Non port�é ?
+      | f = finite_token; s = csort; id = identref;
+        indpar = LIST0 simple_binder; ":="; lc = constructor_list -> 
+          VernacInductive (f,[id,None,indpar,s,lc])
+*)
+    ] ]
+  ;
   thm_token:
     [ [ "Theorem" -> Theorem
       | IDENT "Lemma" -> Lemma
       | IDENT "Fact" -> Fact
-      | IDENT "Remark" -> Remark ] ]
+      | IDENT "Remark" -> Remark
+      | IDENT "Corollary" -> Corollary
+      | IDENT "Proposition" -> Proposition
+      | IDENT "Property" -> Property ] ]
   ;
   def_token:
-    [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition)
-      | IDENT "Local" -> (fun _ _ -> ()), (Local, Definition)
-      | IDENT "SubClass"  -> Class.add_subclass_hook, (Global, SubClass)
+    [ [ "Definition" -> 
+	no_hook, (Global, Options.boxed_definitions(), Definition)
+      | IDENT "Let" -> 
+	no_hook, (Local, Options.boxed_definitions(), Definition)
+      | IDENT "Example" -> 
+	no_hook, (Global, Options.boxed_definitions(), Example)
+      | IDENT "SubClass"  -> Class.add_subclass_hook, (Global, false, SubClass)
       | IDENT "Local"; IDENT "SubClass"  ->
-	  Class.add_subclass_hook, (Local, SubClass) ] ] 
+          Class.add_subclass_hook, (Local, false, SubClass) ] ] 
   ;
   assumption_token:
     [ [ "Hypothesis" -> (Local, Logical)
       | "Variable" -> (Local, Definitional)
       | "Axiom" -> (Global, Logical)
       | "Parameter" -> (Global, Definitional)
-      | IDENT "Conjecture" -> (Global,Conjectural) ] ]
+      | IDENT "Conjecture" -> (Global, Conjectural) ] ]
   ;
   assumptions_token:
     [ [ IDENT "Hypotheses" -> (Local, Logical)
       | IDENT "Variables" -> (Local, Definitional)
+      | IDENT "Axioms" -> (Global, Logical)
       | IDENT "Parameters" -> (Global, Definitional) ] ]
   ;
-  of_type_with_opt_coercion:
-    [ [ ":>" -> true
-      | ":"; ">" -> true
-      | ":" -> false ] ]
-  ;
-  params:
-    [ [ idl = LIST1 identref SEP ","; coe = of_type_with_opt_coercion; 
-        c = constr -> (coe,(idl,c))
-    ] ]
-  ;
-  ne_params_list:
-    [ [ ll = LIST1 params SEP ";" -> ll ] ]
-  ;
-  name_comma_list_tail:
-    [ [ ","; nal = LIST1 name SEP "," -> nal | -> [] ] ]
-  ;
-  ident_comma_list_tail:
-    [ [ ","; nal = LIST1 identref SEP "," -> nal | -> [] ] ]
-  ;
-  decl_notation:
-    [ [ "where"; ntn = STRING; ":="; c = constr; 
-         scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ]
-  ;
-  type_option:
-    [ [ ":"; c = constr -> c 
-      | -> evar_constr loc ] ]
-  ;
-  opt_casted_constr:
-    [ [ c = constr;  ":"; t = constr -> CCast(loc,c,t)
-      | c = constr -> c ] ]
-  ;
-  vardecls:
-    [ [ na = name; nal = name_comma_list_tail; c = type_option
-          -> LocalRawAssum (na::nal,c)
-      | na = name; "="; c = opt_casted_constr ->
-          LocalRawDef (na,c)
-      | na = name; ":="; c = opt_casted_constr ->
-          LocalRawDef (na,c)
-    ] ]
-  ;
-  binders:
-    [ [ "["; bl = LIST1 vardecls SEP ";"; "]" -> bl ] ]
-  ;
-  binders_list:
-    [ [ bls = LIST0 binders -> List.flatten bls ] ]
-  ;
-  reduce:
-    [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r
-      | -> None ] ]
-  ;
-  def_body:
-    [ [ bl = binders_list; ":="; red = reduce; c = constr; ":"; t = constr ->
-          DefineBody (bl, red, c, Some t)
-      | bl = binders_list; ":"; t = constr; ":="; red = reduce; c = constr ->
-          DefineBody (bl, red, c, Some t)
-      | bl = binders_list; ":="; red = reduce; c = constr ->
-          DefineBody (bl, red, c, None)
-      | bl = binders_list; ":"; t = constr ->
-          ProveBody (bl, t) ] ]
-  ;
-  gallina:
-    (* Definition, Theorem, Variable, Axiom, ... *)
-    [ [ thm = thm_token; id = identref; bl = binders_list; ":"; c = constr ->
-         VernacStartTheoremProof (thm, id, (bl, c), false, (fun _ _ -> ()))
-      | (f,d) = def_token; id = identref; b = def_body -> 
-          VernacDefinition (d, id, b, f)
-      | stre = assumption_token; bl = ne_params_list -> 
-	  VernacAssumption (stre, bl)
-      | stre = assumptions_token; bl = ne_params_list ->
-	  test_plurial_form bl;
-	  VernacAssumption (stre, bl)
-      ] ]
-  ;
-  (* Gallina inductive declarations *)
   finite_token:
     [ [ "Inductive" -> true
       | "CoInductive" -> false ] ]
@@ -208,192 +198,250 @@ GEXTEND Gram
   record_token:
     [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ]
   ;
-  constructor:
-    [ [ idl = LIST1 identref SEP ","; coe = of_type_with_opt_coercion;
-        c = constr -> List.map (fun id -> (coe,(id,c))) idl ] ]
-  ;
-  constructor_list:
-    [ [ "|"; l = LIST1 constructor SEP "|" -> List.flatten l
-      | l = LIST1 constructor SEP "|" -> List.flatten l
-      |  -> [] ] ]
-  ;
-  block_old_style:
-    [ [ ind = oneind_old_style; "with"; indl = block_old_style -> ind :: indl
-      | ind = oneind_old_style -> [ind] ] ]
+  (* Simple definitions *)
+  def_body:
+    [ [ bl = LIST0 binder_let; ":="; red = reduce; c = lconstr ->
+      (match c with
+          CCast(_,c,k,t) -> DefineBody (bl, red, c, Some t)
+        | _ -> DefineBody (bl, red, c, None))
+      | bl = LIST0 binder_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr ->
+          DefineBody (bl, red, c, Some t)
+      | bl = LIST0 binder_let; ":"; t = lconstr ->
+          ProveBody (bl, t) ] ]
   ;
-  oneind_old_style:
-    [ [ id = identref; ":"; c = constr; ":="; lc = constructor_list ->
-          (id,c,lc) ] ]
+  reduce:
+    [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r
+      | -> None ] ]
   ;
-  oneind:
-    [ [ id = identref; indpar = simple_binders_list; ":"; c = constr; 
-        ":="; lc = constructor_list; ntn = OPT decl_notation ->
-	  (id,ntn,indpar,c,lc) ] ]
+  decl_notation:
+    [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; 
+         scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ]
+    ;
+  (* Inductives and records *)
+  inductive_definition:
+    [ [ id = identref; indpar = LIST0 binder_let; ":"; c = lconstr;
+        ":="; lc = constructor_list; ntn = decl_notation ->
+	  ((id,indpar,c,lc),ntn) ] ]
   ;
-  simple_binders_list:
-    [ [ bl = ne_simple_binders_list -> bl
+  constructor_list:
+    [ [ "|"; l = LIST1 constructor SEP "|" -> l
+      | l = LIST1 constructor SEP "|" -> l
       |  -> [] ] ]
   ;
+(*
+  csort:
+    [ [ s = sort -> CSort (loc,s) ] ]
+  ;
+*)
   opt_coercion:
     [ [ ">" -> true
       |  -> false ] ]
   ;
-  onescheme:
-    [ [ id = identref; ":="; dep = dep; ind = global; IDENT "Sort";
-        s = sort -> (id,dep,ind,s) ] ]
-  ;
-  schemes:
-    [ [ recl = LIST1 onescheme SEP "with" -> recl ] ]
-  ;
-  dep:
-    [ [ IDENT "Induction"; IDENT "for" -> true
-      | IDENT "Minimality"; IDENT "for" -> false ] ]
+  (* (co)-fixpoints *)
+  rec_definition:
+    [ [ id = ident; bl = LIST1 binder_let;
+        annot = rec_annotation; ty = type_cstr; 
+	":="; def = lconstr; ntn = decl_notation ->
+          let names = List.map snd (names_of_local_assums bl) in
+          let ni =
+            match fst annot with
+                Some id ->
+                  (try Some (list_index (Name id) names - 1)
+                   with Not_found ->  Util.user_err_loc
+                     (loc,"Fixpoint",
+                      Pp.str "No argument named " ++ Nameops.pr_id id))
+              | None -> 
+		  (* If there is only one argument, it is the recursive one, 
+		     otherwise, we search the recursive index later *)
+		  if List.length names = 1 then Some 0 else None	  
+	  in 
+	  ((id,(ni,snd annot),bl,ty,def),ntn) ] ]
+  ;
+  corec_definition:
+    [ [ id = ident; bl = LIST0 binder_let; ty = type_cstr; ":=";
+        def = lconstr; ntn = decl_notation ->
+          ((id,bl,ty,def),ntn) ] ]
+  ;
+  rec_annotation:
+    [ [ "{"; IDENT "struct"; id=IDENT; "}" -> (Some (id_of_string id), CStructRec)
+      | "{"; IDENT "wf"; rel=constr; id=IDENT; "}" -> (Some (id_of_string id), CWfRec rel) 
+      | "{"; IDENT "measure"; rel=constr; id=IDENT; "}" -> (Some (id_of_string id), CMeasureRec rel) 
+      | ->  (None, CStructRec)
+      ] ]
   ;
-  onerec:
-    [ [ id = base_ident; bl = ne_fix_binders; ":"; type_ = constr;
-        ":="; def = constr; ntn = OPT decl_notation ->
-          let ni = List.length (List.flatten (List.map fst bl)) - 1 in
-          let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in
-	  ((id, ni, bl, type_, def), ntn) ] ]
+  type_cstr:
+    [ [ ":"; c=lconstr -> c 
+      | -> CHole loc ] ]
   ;
-  specifrec:
-    [ [ l = LIST1 onerec SEP "with" -> l ] ]
+  (* Inductive schemes *)
+  scheme:
+    [ [ id = identref; ":="; dep = dep_scheme; "for"; ind = global;
+        IDENT "Sort"; s = sort ->
+          (id,dep,ind,s) ] ]
   ;
-  onecorec:
-    [ [ id = base_ident; ":"; c = constr; ":="; def = constr ->
-          (id,[],c,def) ] ]
+  dep_scheme:
+    [ [ IDENT "Induction" -> true
+      | IDENT "Minimality" -> false ] ]
   ;
-  specifcorec:
-    [ [ l = LIST1 onecorec SEP "with" -> l ] ]
+  (* Various Binders *)
+(*
+  (* ... without coercions *)
+  binder_nodef:
+    [ [ b = binder_let ->
+      (match b with
+          LocalRawAssum(l,ty) -> (l,ty)
+        | LocalRawDef _ ->
+            Util.user_err_loc
+              (loc,"fix_param",Pp.str"defined binder not allowed here")) ] ]
   ;
+*)
+  (* ... with coercions *)
   record_field:
-    [ [ id = name; oc = of_type_with_opt_coercion; t = constr ->
-          (oc,AssumExpr (id,t))
-      | id = name; oc = of_type_with_opt_coercion; t = constr;
-	":="; b = constr ->
-	  (oc,DefExpr (id,b,Some t))
-      | id = name; ":="; b = constr ->
-	  (false,DefExpr (id,b,None)) ] ]
-  ;
-  fields:
-    [ [ fs = LIST0 record_field SEP ";" -> fs ] ]
-  ;
-  simple_binders:
-    [ [ "["; bll = LIST1 vardecls SEP ";"; "]" -> bll ] ]
-  ;
-  ne_simple_binders_list:
-    [ [ bll = LIST1 simple_binders -> (List.flatten bll) ] ]
-  ;
-  fix_params:
-    [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c)
-      | idl = LIST1 name SEP "," -> (idl, evar_constr dummy_loc)
-    ] ]
-  ;
-  fix_binders:
-    [ [ "["; bll = LIST1 fix_params SEP ";"; "]" -> bll ] ]
+    [ [ id = name -> (false,AssumExpr(id,CHole loc))
+      | id = name; oc = of_type_with_opt_coercion; t = lconstr ->
+         (oc,AssumExpr (id,t))
+      | id = name; oc = of_type_with_opt_coercion;
+             t = lconstr; ":="; b = lconstr -> (oc,DefExpr (id,b,Some t))
+      | id = name; ":="; b = lconstr ->
+         match b with
+             CCast(_,b,_,t) -> (false,DefExpr(id,b,Some t))
+           | _ -> (false,DefExpr(id,b,None)) ] ]
+  ;
+  assum_list:
+    [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ]
+  ;
+  assum_coe:
+    [ [ "("; a = simple_assum_coe; ")" -> a ] ]
+  ;
+  simple_assum_coe:
+    [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> 
+        (oc,(idl,c)) ] ]
   ;
-  ne_fix_binders:
-    [ [ bll = LIST1 fix_binders -> List.flatten bll ] ]
-  ;
-  rec_constructor:
-    [ [ c = identref -> Some c
-      |  -> None ] ]
-  ;
-  gallina_ext:
-    [ [ IDENT "Mutual"; bl = ne_simple_binders_list ; f = finite_token;
-        indl = block_old_style ->
-	  let indl' = List.map (fun (id,ar,c) -> (id,None,bl,ar,c)) indl in
-	  VernacInductive (f,indl')
-      | b = record_token; oc = opt_coercion; name = identref;
-	ps = simple_binders_list; ":";
-	s = constr; ":="; c = rec_constructor; "{"; fs = fields; "}" ->
-	  VernacRecord (b,(oc,name),ps,s,c,fs)
-    ] ]
-  ;
-  gallina:
-    [ [ IDENT "Mutual"; f = finite_token; indl = LIST1 oneind SEP "with" ->
-          VernacInductive (f,indl)
-      | f = finite_token; indl = LIST1 oneind SEP "with" ->
-          VernacInductive (f,indl)
-      | "Fixpoint"; recs = specifrec -> VernacFixpoint recs
-      | "CoFixpoint"; corecs = specifcorec -> VernacCoFixpoint corecs
-      | IDENT "Scheme"; l = schemes -> VernacScheme l
-      | f = finite_token; s = csort; id = identref;
-	indpar = simple_binders_list; ":="; lc = constructor_list -> 
-          VernacInductive (f,[id,None,indpar,s,lc]) ] ]
+  constructor:
+    [ [ id = identref; l = LIST0 binder_let; 
+        coe = of_type_with_opt_coercion; c = lconstr ->
+	  (coe,(id,G_constr.mkCProdN loc l c))
+      | id = identref; l = LIST0 binder_let ->
+	  (false,(id,G_constr.mkCProdN loc l (CHole loc))) ] ]
   ;
-  csort:
-    [ [ s = sort -> CSort (loc,s) ] ]
+  of_type_with_opt_coercion:
+    [ [ ":>" -> true
+      | ":"; ">" -> true
+      | ":" -> false ] ]
   ;
+END
+
+
+(* Modules and Sections *)
+GEXTEND Gram
+  GLOBAL: gallina_ext module_expr module_type;
+
   gallina_ext:
-    [ [ 
-(* Sections *)
-	IDENT "Section"; id = identref -> VernacBeginSection id
-      | IDENT "Chapter"; id = identref -> VernacBeginSection id ] ]
-  ;
-  module_vardecls:
-    [ [ id = identref; idl = ident_comma_list_tail; ":";
-        mty = Module.module_type -> (id::idl,mty) ] ]
+    [ [ (* Interactive module declaration *)
+        IDENT "Module"; export = export_token; id = identref; 
+	bl = LIST0 module_binder; mty_o = OPT of_module_type; 
+	mexpr_o = OPT is_module_expr ->
+	  VernacDefineModule (export, id, bl, mty_o, mexpr_o)
+	  
+      | IDENT "Module"; "Type"; id = identref; 
+	bl = LIST0 module_binder; mty_o = OPT is_module_type ->
+	  VernacDeclareModuleType (id, bl, mty_o)
+	  
+      | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref; 
+	bl = LIST0 module_binder; ":"; mty = module_type ->
+	  VernacDeclareModule (export, id, bl, (mty,true))
+      (* Section beginning *)
+      | IDENT "Section"; id = identref -> VernacBeginSection id
+      | IDENT "Chapter"; id = identref -> VernacBeginSection id
+
+      (* This end a Section a Module or a Module Type *)
+      | IDENT "End"; id = identref -> VernacEndSegment id
+
+      (* Requiring an already compiled module *)
+      | IDENT "Require"; export = export_token; specif = specif_token;
+        qidl = LIST1 global ->
+          VernacRequire (export, specif, qidl)
+      | IDENT "Require"; export = export_token; specif = specif_token;
+        filename = ne_string -> 
+	  VernacRequireFrom (export, specif, filename)
+      | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
+      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) ] ]
   ;
-  module_binders:
-    [ [ "["; bl = LIST1 module_vardecls SEP ";"; "]" -> bl ] ]
+  export_token:
+    [ [ IDENT "Import" -> Some false
+      | IDENT "Export" -> Some true
+      |  -> None ] ]
   ;
-  module_binders_list:
-    [ [ bls = LIST0 module_binders -> List.flatten bls ] ]
+  specif_token:
+    [ [ IDENT "Implementation" -> Some false
+      | IDENT "Specification" -> Some true
+      |  -> None ] ]
   ;
   of_module_type:
-    [ [ ":"; mty = Module.module_type -> (mty, true) 
-      | "<:"; mty = Module.module_type -> (mty, false) ] ]
+    [ [ ":"; mty = module_type -> (mty, true) 
+      | "<:"; mty = module_type -> (mty, false) ] ]
   ;
   is_module_type:
-    [ [ ":="; mty = Module.module_type -> mty ] ]
+    [ [ ":="; mty = module_type -> mty ] ]
   ;
   is_module_expr:
-    [ [ ":="; mexpr = Module.module_expr -> mexpr ] ]
+    [ [ ":="; mexpr = module_expr -> mexpr ] ]
   ;
-  gallina_ext:
-    [ [ 
-	  (* Interactive module declaration *)
-	IDENT "Module"; id = identref; 
-	bl = module_binders_list; mty_o = OPT of_module_type; 
-	mexpr_o = OPT is_module_expr ->
-	  VernacDefineModule (id, bl, mty_o, mexpr_o)
-	  
-      | IDENT "Module"; "Type"; id = identref; 
-	bl = module_binders_list; mty_o = OPT is_module_type ->
-	  VernacDeclareModuleType (id, bl, mty_o)
-	  
-      | IDENT "Declare"; IDENT "Module"; id = identref; 
-	bl = module_binders_list; mty_o = OPT of_module_type; 
-	mexpr_o = OPT is_module_expr ->
-	  VernacDeclareModule (id, bl, mty_o, mexpr_o)
 
-	  (* This end a Section a Module or a Module Type *)
+  (* Module binder  *)
+  module_binder:
+    [ [ "("; export = export_token; idl = LIST1 identref; ":";
+         mty = module_type; ")" -> (export,idl,mty) ] ]
+  ;
 
-      | IDENT "End"; id = identref -> VernacEndSegment id
+  (* Module expressions *)
+  module_expr:
+    [ [ qid = qualid -> CMEident qid
+      | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2)
+      | "("; me = module_expr; ")" -> me
+(* ... *)
+      ] ]
+  ;
+  with_declaration:
+    [ [ "Definition"; fqid = fullyqualid; ":="; c = Constr.lconstr ->
+          CWith_Definition (fqid,c)
+      | IDENT "Module"; fqid = fullyqualid; ":="; qid = qualid ->
+	  CWith_Module (fqid,qid)
+      ] ]
+  ;
+  module_type:
+    [ [ qid = qualid -> CMTEident qid
+(* ... *)
+      | mty = module_type; "with"; decl = with_declaration -> 
+	  CMTEwith (mty,decl) ] ]
+  ;
+END
 
+(* Extensions: implicits, coercions, etc. *)   
+GEXTEND Gram
+  GLOBAL: gallina_ext;
 
-(* Transparent and Opaque *)
-      | IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l)
+  gallina_ext:
+    [ [ (* Transparent and Opaque *)
+        IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l)
       | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l)
 
-(* Canonical structure *)
+      (* Canonical structure *)
       | IDENT "Canonical"; IDENT "Structure"; qid = global ->
 	  VernacCanonical qid
       | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body ->
-          let s = Ast.coerce_global_to_id qid in
+          let s = coerce_global_to_id qid in
 	  VernacDefinition 
-	    ((Global,CanonicalStructure),(dummy_loc,s),d,Recordobj.add_object_hook)
-      (* Rem: LOBJECT, OBJCOERCION, LOBJCOERCION have been removed
-         (they were unused and undocumented) *)
+	    ((Global,false,CanonicalStructure),(dummy_loc,s),d,
+	     (fun _ -> Recordops.declare_canonical_structure))
 
-(* Coercions *)
+      (* Coercions *)
       | IDENT "Coercion"; qid = global; d = def_body ->
-          let s = Ast.coerce_global_to_id qid in
-	  VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+          let s = coerce_global_to_id qid in
+	  VernacDefinition ((Global,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
       | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body ->
-           let s = Ast.coerce_global_to_id qid in
-	  VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+           let s = coerce_global_to_id qid in
+	  VernacDefinition ((Local,false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
       | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref;
          ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> 
 	   VernacIdentityCoercion (Local, f, s, t)
@@ -406,119 +454,323 @@ GEXTEND Gram
       | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->";
          t = class_rawexpr ->
 	  VernacCoercion (Global, qid, s, t)
-      | IDENT "Class"; IDENT "Local"; c = global ->
-	  Pp.warning "Class is obsolete"; VernacNop
-      | IDENT "Class"; c = global ->
-	  Pp.warning "Class is obsolete"; VernacNop
 
-(* Implicit *)
-(*
-      | IDENT "Syntactic"; "Definition"; id = identref; ":="; c = constr;
-         n = OPT [ "|"; n = natural -> n ] ->
-	   VernacSyntacticDefinition (id,c,n)
-*)
-      | IDENT "Syntactic"; "Definition"; id = ident; ":="; c = constr;
-         n = OPT [ "|"; n = natural -> n ] ->
-	   let c = match n with
-	     | Some n ->
-		 let l = list_tabulate (fun _ -> (CHole (loc),None)) n in
-		 CApp (loc,(None,c),l)
-	     | None -> c in
-	   VernacSyntacticDefinition (id,c,false,true)
-      | IDENT "Implicits"; qid = global; "["; l = LIST0 natural; "]" ->
-	  let l = List.map (fun n -> ExplByPos n) l in
-	  VernacDeclareImplicits (qid,Some l)
-      | IDENT "Implicits"; qid = global -> VernacDeclareImplicits (qid,None)
-
-      | IDENT "Implicit"; ["Variable"; "Type" | IDENT "Variables"; "Type"];
-	   idl = LIST1 identref SEP ","; ":"; c = constr -> VernacReserve (idl,c)
-
-      (* For compatibility *)
-      | IDENT "Implicit"; IDENT "Arguments"; IDENT "On" ->
-	  VernacSetOption
-	    (Goptions.SecondaryTable ("Implicit","Arguments"), BoolValue true)
-      | IDENT "Implicit"; IDENT "Arguments"; IDENT "Off" ->
-	  VernacSetOption
-	    (Goptions.SecondaryTable ("Implicit","Arguments"), BoolValue false)
-  ] ]
+      (* Implicit *)
+      | IDENT "Implicit"; IDENT "Arguments"; qid = global; 
+         pos = OPT [ "["; l = LIST0 ident; "]" -> l ] ->
+	   let pos = option_map (List.map (fun id -> ExplByName id)) pos in
+	   VernacDeclareImplicits (true,qid,pos)
+
+      | IDENT "Implicit"; ["Type" | IDENT "Types"];
+	   idl = LIST1 identref; ":"; c = lconstr -> VernacReserve (idl,c) ] ]
   ;
 END
 
-(* Modules management *)   
-if !Options.v7 then
 GEXTEND Gram
-  GLOBAL: command;
+  GLOBAL: command check_command class_rawexpr;
 
-  export_token:
-    [ [ IDENT "Import" -> false
-      | IDENT "Export" -> true
-      |  -> false ] ]
-  ;
-  specif_token:
-    [ [ IDENT "Implementation" -> Some false
-      | IDENT "Specification" -> Some true
-      |  -> None ] ]
-  ;
   command:
-    [ [ "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ];
-	s = [ s = STRING -> s | s = IDENT -> s ] ->
+    [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l
+
+      (* System directory *)
+      | IDENT "Pwd" -> VernacChdir None
+      | IDENT "Cd" -> VernacChdir None
+      | IDENT "Cd"; dir = ne_string -> VernacChdir (Some dir)
+
+      (* Toplevel control *)
+      | IDENT "Drop" -> VernacToplevelControl Drop
+      | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop
+      | IDENT "Quit" -> VernacToplevelControl Quit
+
+      | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ];
+	s = [ s = ne_string -> s | s = IDENT -> s ] ->
 	  VernacLoad (verbosely, s)
-(*      | "Compile";
-	verbosely =
-          [ IDENT "Verbose" -> "Verbose"
-          | -> "" ];
-	IDENT "Module";
-	only_spec =
-          [ IDENT "Specification" -> "Specification"
-          | -> "" ];
-	mname = [ s = STRING -> s | s = IDENT -> s ];
-	fname = OPT [ s = STRING -> s | s = IDENT -> s ] -> ExtraVernac
-          let fname = match fname with Some s -> s | None -> mname in
-            <:ast< (CompileFile ($STR $verbosely) ($STR $only_spec)
-                      ($STR $mname) ($STR $fname))>>
-*)
-      | IDENT "Read"; IDENT "Module"; qidl = LIST1 global ->
-	  VernacRequire (None, None, qidl)
-      | IDENT "Require"; export = export_token; specif = specif_token;
-        qidl = LIST1 global -> VernacRequire (Some export, specif, qidl)
-(*      | IDENT "Require"; export = export_token; specif = specif_token;
-        id = identref; filename = STRING -> 
-	  VernacRequireFrom (export, specif, id, filename) *)
-      | IDENT "Require"; export = export_token; specif = specif_token;
-        filename = STRING -> 
-	  VernacRequireFrom (Some export, specif, filename)
-      | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 STRING ->
+      | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string ->
 	  VernacDeclareMLModule l
-      | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
-      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl)
-  ] 
-]
+
+      | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string ->
+	  error "This command is deprecated, use Print Universes"
+
+      | IDENT "Locate"; l = locatable -> VernacLocate l
+
+      (* Managing load paths *)
+      | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath ->
+	  VernacAddLoadPath (false, dir, alias)
+      | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; 
+	  alias = as_dirpath -> VernacAddLoadPath (true, dir, alias)
+      | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string ->
+	  VernacRemoveLoadPath dir
+
+       (* For compatibility *)
+      | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath ->
+	  VernacAddLoadPath (false, dir, alias)
+      | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath ->
+	  VernacAddLoadPath (true, dir, alias)
+      | IDENT "DelPath"; dir = ne_string ->
+	  VernacRemoveLoadPath dir
+
+      (* Type-Checking (pas dans le refman) *)
+      | "Type"; c = lconstr -> VernacGlobalCheck c
+
+      (* Printing (careful factorization of entries) *)
+      | IDENT "Print"; p = printable -> VernacPrint p
+      | IDENT "Print"; qid = global -> VernacPrint (PrintName qid)
+      | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> 
+	  VernacPrint (PrintModuleType qid)
+      | IDENT "Print"; IDENT "Module"; qid = global -> 
+	  VernacPrint (PrintModule qid)
+      | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n)
+      | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid)
+
+      (* Searching the environment *)
+      | IDENT "Search"; qid = global; l = in_or_out_modules -> 
+	  VernacSearch (SearchHead qid, l)
+      | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules ->
+	  VernacSearch (SearchPattern c, l)
+      | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
+	  VernacSearch (SearchRewrite c, l)
+      | IDENT "SearchAbout"; 
+	  sl = [ "["; l = LIST1 [ r = global -> SearchRef r
+                                | s = ne_string -> SearchString s ]; "]" -> l 
+   		 | qid = global -> [SearchRef qid] ];
+	  l = in_or_out_modules -> 
+	  VernacSearch (SearchAbout sl, l)
+
+      | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
+	  VernacAddMLPath (false, dir)
+      | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
+	  VernacAddMLPath (true, dir)
+
+      (* Pour intervenir sur les tables de param�ètres *)
+      | "Set"; table = IDENT; field = IDENT; v = option_value ->
+  	  VernacSetOption (SecondaryTable (table,field),v)
+      | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
+  	  VernacAddOption (SecondaryTable (table,field),lv)
+      | "Set"; table = IDENT; field = IDENT ->
+  	  VernacSetOption (SecondaryTable (table,field),BoolValue true)
+      | IDENT "Unset"; table = IDENT; field = IDENT ->
+  	  VernacUnsetOption (SecondaryTable (table,field))
+      | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
+  	  VernacRemoveOption (SecondaryTable (table,field),lv)
+      | "Set"; table = IDENT; value = option_value ->
+  	  VernacSetOption (PrimaryTable table, value)
+      | "Set"; table = IDENT ->
+  	  VernacSetOption (PrimaryTable table, BoolValue true)
+      | IDENT "Unset"; table = IDENT ->
+  	  VernacUnsetOption (PrimaryTable table)
+
+      | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT ->
+	  VernacPrintOption (SecondaryTable (table,field))
+      | IDENT "Print"; IDENT "Table"; table = IDENT ->
+	  VernacPrintOption (PrimaryTable table)
+
+      | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
+        -> VernacAddOption (SecondaryTable (table,field), v)
+
+      (* Un value global ci-dessous va �être cach�é par un field au dessus! *)
+      | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value ->
+          VernacAddOption (PrimaryTable table, v)
+
+      | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
+        -> VernacMemOption (SecondaryTable (table,field), v)
+      | IDENT "Test"; table = IDENT; field = IDENT ->
+          VernacPrintOption (SecondaryTable (table,field))
+      | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value ->
+          VernacMemOption (PrimaryTable table, v)
+      | IDENT "Test"; table = IDENT ->
+          VernacPrintOption (PrimaryTable table)
+
+      | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value
+        -> VernacRemoveOption (SecondaryTable (table,field), v)
+      | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
+	  VernacRemoveOption (PrimaryTable table, v) 
+      | IDENT "proof" -> VernacDeclProof
+      | "return" -> VernacReturn ]]
+  ;
+  check_command: (* TODO: rapprocher Eval et Check *)
+    [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr ->
+          fun g -> VernacCheckMayEval (Some r, g, c)
+      | IDENT "Check"; c = lconstr ->
+	  fun g -> VernacCheckMayEval (None, g, c) ] ]
   ;
-END
+  printable:
+    [ [ IDENT "Term"; qid = global -> PrintName qid
+      | IDENT "All" -> PrintFullContext
+      | IDENT "Section"; s = global -> PrintSectionContext s
+      | IDENT "Grammar"; ent = IDENT ->
+          (* This should be in "syntax" section but is here for factorization*)
+	  PrintGrammar ("", ent)
+      | IDENT "LoadPath" -> PrintLoadPath
+      | IDENT "Modules" -> PrintModules
 
-if !Options.v7 then
-GEXTEND Gram
-  GLOBAL: command;
+      | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath
+      | IDENT "ML"; IDENT "Modules" -> PrintMLModules
+      | IDENT "Graph" -> PrintGraph
+      | IDENT "Classes" ->  PrintClasses
+      | IDENT "Ltac"; qid = global -> PrintLtac qid
+      | IDENT "Coercions" -> PrintCoercions
+      | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr
+         -> PrintCoercionPaths (s,t)
+      | IDENT "Canonical"; IDENT "Projections" -> PrintCanonicalConversions
+      | IDENT "Tables" -> PrintTables
+(* Obsolete: was used for cooking V6.3 recipes ??
+      | IDENT "Proof"; qid = global -> PrintOpaqueName qid
+*)
+      | IDENT "Hint" -> PrintHintGoal
+      | IDENT "Hint"; qid = global -> PrintHint qid
+      | IDENT "Hint"; "*" -> PrintHintDb
+      | IDENT "HintDb"; s = IDENT -> PrintHintDbName s
+      | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s
+      | IDENT "Setoids" -> PrintSetoids
+      | IDENT "Scopes" -> PrintScopes
+      | IDENT "Scope"; s = IDENT -> PrintScope s
+      | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s
+      | IDENT "Implicit"; qid = global -> PrintImplicit qid
+      | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses fopt ] ]
+  ;
+  class_rawexpr:
+    [ [ IDENT "Funclass" -> FunClass
+      | IDENT "Sortclass" -> SortClass
+      | qid = global -> RefClass qid ] ]
+  ;
+  locatable:
+    [ [ qid = global -> LocateTerm qid
+      | IDENT "File"; f = ne_string -> LocateFile f
+      | IDENT "Library"; qid = global -> LocateLibrary qid
+      | IDENT "Module"; qid = global -> LocateModule qid
+      | s = ne_string -> LocateNotation s ] ]
+  ;
+  option_value:
+    [ [ n  = integer   -> IntValue n
+      | s  = STRING    -> StringValue s ] ]
+  ;
+  option_ref_value:
+    [ [ id = global   -> QualidRefValue id
+      | s  = STRING   -> StringRefValue s ] ]
+  ;
+  as_dirpath:
+    [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ]
+  ;
+  in_or_out_modules:
+    [ [ IDENT "inside"; l = LIST1 global -> SearchInside l
+      | IDENT "outside"; l = LIST1 global -> SearchOutside l
+      | -> SearchOutside [] ] ]
+  ;
+  comment:
+    [ [ c = constr -> CommentConstr c
+      | s = STRING -> CommentString s
+      | n = natural -> CommentInt n ] ]
+  ;
+END;
 
+GEXTEND Gram
   command:
     [ [ 
-
 (* State management *)
         IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s
-      | IDENT "Write"; IDENT "State"; s = STRING -> VernacWriteState s
+      | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s
       | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s
-      | IDENT "Restore"; IDENT "State"; s = STRING -> VernacRestoreState s
+      | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s
 
 (* Resetting *)
       | IDENT "Reset"; id = identref -> VernacResetName id
       | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial
       | IDENT "Back" -> VernacBack 1
       | IDENT "Back"; n = natural -> VernacBack n
+      | IDENT "BackTo"; n = natural -> VernacBackTo n
+      | IDENT "Backtrack"; n = natural ; m = natural ; p = natural -> 
+	  VernacBacktrack (n,m,p)
 
 (* Tactic Debugger *)
-      |	IDENT "Debug"; IDENT "On" -> VernacDebug true
-      |	IDENT "Debug"; IDENT "Off" -> VernacDebug false
+      |	IDENT "Debug"; IDENT "On" -> 
+          VernacSetOption (SecondaryTable ("Ltac","Debug"), BoolValue true)
+
+      |	IDENT "Debug"; IDENT "Off" ->
+          VernacSetOption (SecondaryTable ("Ltac","Debug"), BoolValue false)
 
  ] ];
     END
 ;;
+
+(* Grammar extensions *)
+	  
+GEXTEND Gram
+  GLOBAL: syntax;
+
+  syntax:
+   [ [ IDENT "Open"; local = locality; IDENT "Scope"; sc = IDENT -> 
+         VernacOpenCloseScope (local,true,sc)
+
+     | IDENT "Close"; local = locality; IDENT "Scope"; sc = IDENT -> 
+         VernacOpenCloseScope (local,false,sc)
+
+     | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT ->
+	 VernacDelimiters (sc,key)
+
+     | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; 
+       refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
+
+     | IDENT "Arguments"; IDENT "Scope"; qid = global;
+       "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (true,qid,scl)
+
+     | IDENT "Infix"; local = locality;
+	 op = ne_string; ":="; p = global; 
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
+         VernacInfix (local,(op,modl),p,sc)
+     | IDENT "Notation"; local = locality; id = ident; ":="; c = constr;
+	 b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] ->
+           VernacSyntacticDefinition (id,c,local,b)
+     | IDENT "Notation"; local = locality; s = ne_string; ":="; c = constr;
+         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
+	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
+           VernacNotation (local,c,(s,modl),sc)
+
+     | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; 
+	 pil = LIST1 production_item; ":="; t = Tactic.tactic
+         -> VernacTacticNotation (n,pil,t)
+
+     | IDENT "Reserved"; IDENT "Notation"; local = locality; s = ne_string; 
+	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]
+	 -> VernacSyntaxExtension (local,(s,l))
+
+     (* "Print" "Grammar" should be here but is in "command" entry in order 
+        to factorize with other "Print"-based vernac entries *)
+  ] ]
+  ;
+  tactic_level:
+    [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ]
+  ;
+  locality:
+    [ [ IDENT "Local" -> true | -> false ] ]
+  ;
+  level:
+    [ [ IDENT "level"; n = natural -> NumLevel n
+      | IDENT "next"; IDENT "level" -> NextLevel ] ]
+  ;
+  syntax_modifier:
+    [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev)
+      | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; 
+        lev = level -> SetItemLevel (x::l,lev)
+      | "at"; IDENT "level"; n = natural -> SetLevel n
+      | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA
+      | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA
+      | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA
+      | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ)
+      | IDENT "only"; IDENT "parsing" -> SetOnlyParsing
+      | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ]
+  ;
+  syntax_extension_type:
+    [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference
+      | IDENT "bigint" -> ETBigint
+    ] ]
+  ;
+  opt_scope:
+    [ [ "_" -> None | sc = IDENT -> Some sc ] ]
+  ;
+  production_item:
+    [ [ s = ne_string -> VTerm s
+      | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] -> 
+	  VNonTerm (loc,nt,po) ] ]
+  ;
+END
diff --git a/parsing/g_vernacnew.ml4 b/parsing/g_vernacnew.ml4
deleted file mode 100644
index 976cc259..00000000
--- a/parsing/g_vernacnew.ml4
+++ /dev/null
@@ -1,728 +0,0 @@
-(************************************************************************)
-(*  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: g_vernacnew.ml4,v 1.63.2.2 2004/10/12 10:10:29 herbelin Exp $ *)
-
-open Pp
-open Util
-open Names
-open Coqast
-open Topconstr
-open Vernacexpr
-open Pcoq
-open Tactic
-open Decl_kinds
-open Genarg
-open Extend
-open Ppextend
-open Goptions
-
-open Prim
-open Constr
-open Vernac_
-open Module
-
-
-let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ]
-let _ = 
-  if not !Options.v7 then
-    List.iter (fun s -> Lexer.add_token ("",s)) vernac_kw
-
-(* Rem: do not join the different GEXTEND into one, it breaks native *)
-(* compilation on PowerPC and Sun architectures *)
-
-let check_command = Gram.Entry.create "vernac:check_command"
-let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr"
-let thm_token = Gram.Entry.create "vernac:thm_token"
-let def_body = Gram.Entry.create "vernac:def_body"
-
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: vernac gallina_ext;
-  vernac:
-    (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *)
-    (* "." is still in the stream and discard_to_dot works correctly         *)
-    [ [ g = gallina; "." -> g 
-      | g = gallina_ext; "." -> g
-      | c = command; "." -> c 
-      | c = syntax; "." -> c
-      | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l
-    ] ]
-  ;
-  vernac: FIRST
-    [ [ IDENT "Time"; v = vernac  -> VernacTime v ] ]
-  ;
-  vernac: LAST
-    [ [ gln = OPT[n=natural; ":" -> n];
-        tac = subgoal_command -> tac gln ] ]
-  ;
-  subgoal_command:
-    [ [ c = check_command; "." -> c
-      | tac = Tactic.tactic;
-        use_dft_tac = [ "." -> false | "..." -> true ] ->
-          (fun g ->
-            let g = match g with Some gl -> gl | _ -> 1 in
-            VernacSolve(g,tac,use_dft_tac)) ] ]
-  ;
-  located_vernac:
-    [ [ v = vernac -> loc, v ] ]
-  ;
-END
-
-
-let test_plurial_form = function
-  | [(_,([_],_))] ->
-      Options.if_verbose warning
-   "Keywords Variables/Hypotheses/Parameters expect more than one assumption"
-  | _ -> ()
-
-let no_coercion loc (c,x) =
-  if c then Util.user_err_loc
-    (loc,"no_coercion",Pp.str"no coercion allowed here");
-  x
-
-(* Gallina declarations *)
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: gallina gallina_ext thm_token def_body;
-
-  gallina:
-      (* Definition, Theorem, Variable, Axiom, ... *)
-    [ [ thm = thm_token; id = identref; bl = LIST0 binder_let; ":";
-        c = lconstr ->
-          VernacStartTheoremProof (thm, id, (bl, c), false, (fun _ _ -> ()))
-      | (f,d) = def_token; id = identref; b = def_body -> 
-          VernacDefinition (d, id, b, f)
-      | stre = assumption_token; bl = assum_list -> 
-	  VernacAssumption (stre, bl)
-      | stre = assumptions_token; bl = assum_list ->
-	  test_plurial_form bl;
-	  VernacAssumption (stre, bl)
-      (* Gallina inductive declarations *)
-      | f = finite_token;
-        indl = LIST1 inductive_definition SEP "with" ->
-          VernacInductive (f,indl)
-      | "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
-          VernacFixpoint recs
-      | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
-          VernacCoFixpoint corecs
-      | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l ] ]
-  ;
-  gallina_ext:
-    [ [ b = record_token; oc = opt_coercion; name = identref;
-        ps = LIST0 binder_let; ":";
-	s = lconstr; ":="; cstr = OPT identref; "{";
-        fs = LIST0 record_field SEP ";"; "}" ->
-	  VernacRecord (b,(oc,name),ps,s,cstr,fs)
-(* Non port�é ?
-      | f = finite_token; s = csort; id = identref;
-        indpar = LIST0 simple_binder; ":="; lc = constructor_list -> 
-          VernacInductive (f,[id,None,indpar,s,lc])
-*)
-    ] ]
-  ;
-  thm_token:
-    [ [ "Theorem" -> Theorem
-      | IDENT "Lemma" -> Lemma
-      | IDENT "Fact" -> Fact
-      | IDENT "Remark" -> Remark ] ]
-  ;
-  def_token:
-    [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition)
-      | IDENT "Let" -> (fun _ _ -> ()), (Local, Definition)
-      | IDENT "SubClass"  -> Class.add_subclass_hook, (Global, SubClass)
-      | IDENT "Local"; IDENT "SubClass"  ->
-          Class.add_subclass_hook, (Local, SubClass) ] ] 
-  ;
-  assumption_token:
-    [ [ "Hypothesis" -> (Local, Logical)
-      | "Variable" -> (Local, Definitional)
-      | "Axiom" -> (Global, Logical)
-      | "Parameter" -> (Global, Definitional)
-      | IDENT "Conjecture" -> (Global, Conjectural) ] ]
-  ;
-  assumptions_token:
-    [ [ IDENT "Hypotheses" -> (Local, Logical)
-      | IDENT "Variables" -> (Local, Definitional)
-      | IDENT "Axioms" -> (Global, Logical)
-      | IDENT "Parameters" -> (Global, Definitional) ] ]
-  ;
-  finite_token:
-    [ [ "Inductive" -> true
-      | "CoInductive" -> false ] ]
-  ;
-  record_token:
-    [ [ IDENT "Record" -> true | IDENT "Structure" -> false ] ]
-  ;
-  (* Simple definitions *)
-  def_body:
-    [ [ bl = LIST0 binder_let; ":="; red = reduce; c = lconstr ->
-      (match c with
-          CCast(_,c,t) -> DefineBody (bl, red, c, Some t)
-        | _ -> DefineBody (bl, red, c, None))
-      | bl = LIST0 binder_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr ->
-          DefineBody (bl, red, c, Some t)
-      | bl = LIST0 binder_let; ":"; t = lconstr ->
-          ProveBody (bl, t) ] ]
-  ;
-  reduce:
-    [ [ IDENT "Eval"; r = Tactic.red_expr; "in" -> Some r
-      | -> None ] ]
-  ;
-  decl_notation:
-    [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; 
-         scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ]
-    ;
-  (* Inductives and records *)
-  inductive_definition:
-    [ [ id = identref; indpar = LIST0 binder_let; ":"; c = lconstr; 
-        ":="; lc = constructor_list; ntn = decl_notation ->
-	  (id,ntn,indpar,c,lc) ] ]
-  ;
-  constructor_list:
-    [ [ "|"; l = LIST1 constructor SEP "|" -> l
-      | l = LIST1 constructor SEP "|" -> l
-      |  -> [] ] ]
-  ;
-(*
-  csort:
-    [ [ s = sort -> CSort (loc,s) ] ]
-  ;
-*)
-  opt_coercion:
-    [ [ ">" -> true
-      |  -> false ] ]
-  ;
-  (* (co)-fixpoints *)
-  rec_definition:
-    [ [ id = base_ident; bl = LIST1 binder_let;
-        annot = OPT rec_annotation; type_ = type_cstr; 
-	":="; def = lconstr; ntn = decl_notation ->
-          let names = List.map snd (names_of_local_assums bl) in
-          let ni =
-            match annot with
-                Some id ->
-                  (try list_index (Name id) names - 1
-                  with Not_found ->  Util.user_err_loc
-                      (loc,"Fixpoint",
-                       Pp.str "No argument named " ++ Nameops.pr_id id))
-              | None -> 
-                  if List.length names > 1 then
-                    Util.user_err_loc
-                      (loc,"Fixpoint",
-                       Pp.str "the recursive argument needs to be specified");
-                  0 in
-	  ((id, ni, bl, type_, def),ntn) ] ]
-  ;
-  corec_definition:
-    [ [ id = base_ident; bl = LIST0 binder_let; c = type_cstr; ":=";
-        def = lconstr ->
-          (id,bl,c ,def) ] ]
-  ;
-  rec_annotation:
-    [ [ "{"; IDENT "struct"; id=IDENT; "}" -> id_of_string id ] ]
-  ;
-  type_cstr:
-    [ [ ":"; c=lconstr -> c 
-      | -> CHole loc ] ]
-  ;
-  (* Inductive schemes *)
-  scheme:
-    [ [ id = identref; ":="; dep = dep_scheme; "for"; ind = global;
-        IDENT "Sort"; s = sort ->
-          (id,dep,ind,s) ] ]
-  ;
-  dep_scheme:
-    [ [ IDENT "Induction" -> true
-      | IDENT "Minimality" -> false ] ]
-  ;
-  (* Various Binders *)
-(*
-  (* ... without coercions *)
-  binder_nodef:
-    [ [ b = binder_let ->
-      (match b with
-          LocalRawAssum(l,ty) -> (l,ty)
-        | LocalRawDef _ ->
-            Util.user_err_loc
-              (loc,"fix_param",Pp.str"defined binder not allowed here")) ] ]
-  ;
-*)
-  (* ... with coercions *)
-  record_field:
-    [ [ id = name -> (false,AssumExpr(id,CHole loc))
-      | id = name; oc = of_type_with_opt_coercion; t = lconstr ->
-         (oc,AssumExpr (id,t))
-      | id = name; oc = of_type_with_opt_coercion;
-             t = lconstr; ":="; b = lconstr -> (oc,DefExpr (id,b,Some t))
-      | id = name; ":="; b = lconstr ->
-         match b with
-             CCast(_,b,t) -> (false,DefExpr(id,b,Some t))
-           | _ -> (false,DefExpr(id,b,None)) ] ]
-  ;
-  assum_list:
-    [ [ bl = LIST1 assum_coe -> bl | b = simple_assum_coe -> [b] ] ]
-  ;
-  assum_coe:
-    [ [ "("; a = simple_assum_coe; ")" -> a ] ]
-  ;
-  simple_assum_coe:
-    [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> 
-        (oc,(idl,c)) ] ]
-  ;
-  constructor:
-    [ [ id = identref; l = LIST0 binder_let; 
-        coe = of_type_with_opt_coercion; c = lconstr ->
-	  (coe,(id,G_constrnew.mkCProdN loc l c))
-      | id = identref; l = LIST0 binder_let ->
-	  (false,(id,G_constrnew.mkCProdN loc l (CHole loc))) ] ]
-  ;
-  of_type_with_opt_coercion:
-    [ [ ":>" -> true
-      | ":"; ">" -> true
-      | ":" -> false ] ]
-  ;
-END
-
-
-(* Modules and Sections *)
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: gallina_ext module_expr module_type;
-
-  gallina_ext:
-    [ [ (* Interactive module declaration *)
-	IDENT "Module"; id = identref; 
-	bl = LIST0 module_binder; mty_o = OPT of_module_type; 
-	mexpr_o = OPT is_module_expr ->
-	  VernacDefineModule (id, bl, mty_o, mexpr_o)
-	  
-      | IDENT "Module"; "Type"; id = identref; 
-	bl = LIST0 module_binder; mty_o = OPT is_module_type ->
-	  VernacDeclareModuleType (id, bl, mty_o)
-	  
-      | IDENT "Declare"; IDENT "Module"; id = identref; 
-	bl = LIST0 module_binder; mty_o = OPT of_module_type; 
-	mexpr_o = OPT is_module_expr ->
-	  VernacDeclareModule (id, bl, mty_o, mexpr_o)
-      (* Section beginning *)
-      | IDENT "Section"; id = identref -> VernacBeginSection id
-      | IDENT "Chapter"; id = identref -> VernacBeginSection id
-
-      (* This end a Section a Module or a Module Type *)
-      | IDENT "End"; id = identref -> VernacEndSegment id
-
-      (* Requiring an already compiled module *)
-      | IDENT "Require"; export = export_token; specif = specif_token;
-        qidl = LIST1 global ->
-          VernacRequire (export, specif, qidl)
-      | IDENT "Require"; export = export_token; specif = specif_token;
-        filename = ne_string -> 
-	  VernacRequireFrom (export, specif, filename)
-      | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
-      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) ] ]
-  ;
-  export_token:
-    [ [ IDENT "Import" -> Some false
-      | IDENT "Export" -> Some true
-      |  -> None ] ]
-  ;
-  specif_token:
-    [ [ IDENT "Implementation" -> Some false
-      | IDENT "Specification" -> Some true
-      |  -> None ] ]
-  ;
-  of_module_type:
-    [ [ ":"; mty = module_type -> (mty, true) 
-      | "<:"; mty = module_type -> (mty, false) ] ]
-  ;
-  is_module_type:
-    [ [ ":="; mty = module_type -> mty ] ]
-  ;
-  is_module_expr:
-    [ [ ":="; mexpr = module_expr -> mexpr ] ]
-  ;
-
-  (* Module binder  *)
-  module_binder:
-    [ [ "("; idl = LIST1 identref; ":"; mty = module_type; ")" ->
-          (idl,mty) ] ]
-  ;
-
-  (* Module expressions *)
-  module_expr:
-    [ [ qid = qualid -> CMEident qid
-      | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2)
-      | "("; me = module_expr; ")" -> me
-(* ... *)
-      ] ]
-  ;
-  with_declaration:
-    [ [ "Definition"; id = identref; ":="; c = Constr.lconstr ->
-          CWith_Definition (id,c)
-      | IDENT "Module"; id = identref; ":="; qid = qualid ->
-	  CWith_Module (id,qid)
-      ] ]
-  ;
-  module_type:
-    [ [ qid = qualid -> CMTEident qid
-(* ... *)
-      | mty = module_type; "with"; decl = with_declaration -> 
-	  CMTEwith (mty,decl) ] ]
-  ;
-END
-
-(* Extensions: implicits, coercions, etc. *)   
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: gallina_ext;
-
-  gallina_ext:
-    [ [ (* Transparent and Opaque *)
-        IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l)
-      | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l)
-
-      (* Canonical structure *)
-      | IDENT "Canonical"; IDENT "Structure"; qid = global ->
-	  VernacCanonical qid
-      | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body ->
-          let s = Ast.coerce_global_to_id qid in
-	  VernacDefinition 
-	    ((Global,CanonicalStructure),(dummy_loc,s),d,Recordobj.add_object_hook)
-
-      (* Coercions *)
-      | IDENT "Coercion"; qid = global; d = def_body ->
-          let s = Ast.coerce_global_to_id qid in
-	  VernacDefinition ((Global,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
-      | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body ->
-           let s = Ast.coerce_global_to_id qid in
-	  VernacDefinition ((Local,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
-      | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref;
-         ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> 
-	   VernacIdentityCoercion (Local, f, s, t)
-      | IDENT "Identity"; IDENT "Coercion"; f = identref; ":";
-         s = class_rawexpr; ">->"; t = class_rawexpr -> 
-	   VernacIdentityCoercion (Global, f, s, t)
-      | IDENT "Coercion"; IDENT "Local"; qid = global; ":";
-	 s = class_rawexpr; ">->"; t = class_rawexpr -> 
-	  VernacCoercion (Local, qid, s, t)
-      | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->";
-         t = class_rawexpr ->
-	  VernacCoercion (Global, qid, s, t)
-
-      (* Implicit *)
-      | IDENT "Implicit"; IDENT "Arguments"; qid = global; 
-         pos = OPT [ "["; l = LIST0 ident; "]" -> l ] ->
-	   let pos = option_app (List.map (fun id -> ExplByName id)) pos in
-	   VernacDeclareImplicits (qid,pos)
-
-      | IDENT "Implicit"; ["Type" | IDENT "Types"];
-	   idl = LIST1 identref; ":"; c = lconstr -> VernacReserve (idl,c) ] ]
-  ;
-END
-
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: command check_command class_rawexpr;
-
-  command:
-    [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l
-
-      (* System directory *)
-      | IDENT "Pwd" -> VernacChdir None
-      | IDENT "Cd" -> VernacChdir None
-      | IDENT "Cd"; dir = ne_string -> VernacChdir (Some dir)
-
-      (* Toplevel control *)
-      | IDENT "Drop" -> VernacToplevelControl Drop
-      | IDENT "ProtectedLoop" -> VernacToplevelControl ProtectedLoop
-      | IDENT "Quit" -> VernacToplevelControl Quit
-
-      | IDENT "Load"; verbosely = [ IDENT "Verbose" -> true | -> false ];
-	s = [ s = ne_string -> s | s = IDENT -> s ] ->
-	  VernacLoad (verbosely, s)
-      | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string ->
-	  VernacDeclareMLModule l
-
-      (* Dump of the universe graph - to file or to stdout *) 
-      | IDENT "Dump"; IDENT "Universes"; fopt = OPT ne_string ->
-	  VernacPrint (PrintUniverses fopt)
-
-      | IDENT "Locate"; l = locatable -> VernacLocate l
-
-      (* Managing load paths *)
-      | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath ->
-	  VernacAddLoadPath (false, dir, alias)
-      | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; 
-	  alias = as_dirpath -> VernacAddLoadPath (true, dir, alias)
-      | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string ->
-	  VernacRemoveLoadPath dir
-
-       (* For compatibility *)
-      | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath ->
-	  VernacAddLoadPath (false, dir, alias)
-      | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath ->
-	  VernacAddLoadPath (true, dir, alias)
-      | IDENT "DelPath"; dir = ne_string ->
-	  VernacRemoveLoadPath dir
-
-      (* Type-Checking (pas dans le refman) *)
-      | "Type"; c = lconstr -> VernacGlobalCheck c
-
-      (* Printing (careful factorization of entries) *)
-      | IDENT "Print"; p = printable -> VernacPrint p
-      | IDENT "Print"; qid = global -> VernacPrint (PrintName qid)
-      | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> 
-	  VernacPrint (PrintModuleType qid)
-      | IDENT "Print"; IDENT "Module"; qid = global -> 
-	  VernacPrint (PrintModule qid)
-      | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n)
-      | IDENT "About"; qid = global -> VernacPrint (PrintAbout qid)
-
-      (* Searching the environment *)
-      | IDENT "Search"; qid = global; l = in_or_out_modules -> 
-	  VernacSearch (SearchHead qid, l)
-      | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules ->
-	  VernacSearch (SearchPattern c, l)
-      | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
-	  VernacSearch (SearchRewrite c, l)
-      | IDENT "SearchAbout"; 
-	  sl = [ "["; l = LIST1 [ r = global -> SearchRef r
-                                | s = ne_string -> SearchString s ]; "]" -> l 
-   		 | qid = global -> [SearchRef qid] ];
-	  l = in_or_out_modules -> 
-	  VernacSearch (SearchAbout sl, l)
-
-      | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
-	  VernacAddMLPath (false, dir)
-      | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
-	  VernacAddMLPath (true, dir)
-
-      (* Pour intervenir sur les tables de param�ètres *)
-      | "Set"; table = IDENT; field = IDENT; v = option_value ->
-  	  VernacSetOption (SecondaryTable (table,field),v)
-      | "Set"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
-  	  VernacAddOption (SecondaryTable (table,field),lv)
-      | "Set"; table = IDENT; field = IDENT ->
-  	  VernacSetOption (SecondaryTable (table,field),BoolValue true)
-      | IDENT "Unset"; table = IDENT; field = IDENT ->
-  	  VernacUnsetOption (SecondaryTable (table,field))
-      | IDENT "Unset"; table = IDENT; field = IDENT; lv = LIST1 option_ref_value ->
-  	  VernacRemoveOption (SecondaryTable (table,field),lv)
-      | "Set"; table = IDENT; value = option_value ->
-  	  VernacSetOption (PrimaryTable table, value)
-      | "Set"; table = IDENT ->
-  	  VernacSetOption (PrimaryTable table, BoolValue true)
-      | IDENT "Unset"; table = IDENT ->
-  	  VernacUnsetOption (PrimaryTable table)
-
-      | IDENT "Print"; IDENT "Table"; table = IDENT; field = IDENT ->
-	  VernacPrintOption (SecondaryTable (table,field))
-      | IDENT "Print"; IDENT "Table"; table = IDENT ->
-	  VernacPrintOption (PrimaryTable table)
-
-      | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
-        -> VernacAddOption (SecondaryTable (table,field), v)
-
-      (* Un value global ci-dessous va �être cach�é par un field au dessus! *)
-      | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value ->
-          VernacAddOption (PrimaryTable table, v)
-
-      | IDENT "Test"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
-        -> VernacMemOption (SecondaryTable (table,field), v)
-      | IDENT "Test"; table = IDENT; field = IDENT ->
-          VernacPrintOption (SecondaryTable (table,field))
-      | IDENT "Test"; table = IDENT; v = LIST1 option_ref_value ->
-          VernacMemOption (PrimaryTable table, v)
-      | IDENT "Test"; table = IDENT ->
-          VernacPrintOption (PrimaryTable table)
-
-      | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value
-        -> VernacRemoveOption (SecondaryTable (table,field), v)
-      | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
-	  VernacRemoveOption (PrimaryTable table, v) ] ]
-  ;
-  check_command: (* TODO: rapprocher Eval et Check *)
-    [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr ->
-          fun g -> VernacCheckMayEval (Some r, g, c)
-      | IDENT "Check"; c = lconstr ->
-	  fun g -> VernacCheckMayEval (None, g, c) ] ]
-  ;
-  printable:
-    [ [ IDENT "Term"; qid = global -> PrintName qid
-      | IDENT "All" -> PrintFullContext
-      | IDENT "Section"; s = global -> PrintSectionContext s
-      | IDENT "Grammar"; ent = IDENT ->
-          (* This should be in "syntax" section but is here for factorization*)
-	  PrintGrammar ("", ent)
-      | IDENT "LoadPath" -> PrintLoadPath
-      | IDENT "Modules" -> PrintModules
-
-      | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath
-      | IDENT "ML"; IDENT "Modules" -> PrintMLModules
-      | IDENT "Graph" -> PrintGraph
-      | IDENT "Classes" ->  PrintClasses
-      | IDENT "Coercions" -> PrintCoercions
-      | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr
-         -> PrintCoercionPaths (s,t)
-      | IDENT "Tables" -> PrintTables
-(* Obsolete: was used for cooking V6.3 recipes ??
-      | IDENT "Proof"; qid = global -> PrintOpaqueName qid
-*)
-      | IDENT "Hint" -> PrintHintGoal
-      | IDENT "Hint"; qid = global -> PrintHint qid
-      | IDENT "Hint"; "*" -> PrintHintDb
-      | IDENT "HintDb"; s = IDENT -> PrintHintDbName s
-      | IDENT "Scopes" -> PrintScopes
-      | IDENT "Scope"; s = IDENT -> PrintScope s
-      | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s
-      | IDENT "Implicit"; qid = global -> PrintImplicit qid ] ]
-  ;
-  class_rawexpr:
-    [ [ IDENT "Funclass" -> FunClass
-      | IDENT "Sortclass" -> SortClass
-      | qid = global -> RefClass qid ] ]
-  ;
-  locatable:
-    [ [ qid = global -> LocateTerm qid
-      | IDENT "File"; f = ne_string -> LocateFile f
-      | IDENT "Library"; qid = global -> LocateLibrary  qid
-      | s = ne_string -> LocateNotation s ] ]
-  ;
-  option_value:
-    [ [ n  = integer   -> IntValue n
-      | s  = STRING    -> StringValue s ] ]
-  ;
-  option_ref_value:
-    [ [ id = global   -> QualidRefValue id
-      | s  = STRING   -> StringRefValue s ] ]
-  ;
-  as_dirpath:
-    [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ]
-  ;
-  in_or_out_modules:
-    [ [ IDENT "inside"; l = LIST1 global -> SearchInside l
-      | IDENT "outside"; l = LIST1 global -> SearchOutside l
-      | -> SearchOutside [] ] ]
-  ;
-  comment:
-    [ [ c = constr -> CommentConstr c
-      | s = STRING -> CommentString s
-      | n = natural -> CommentInt n ] ]
-  ;
-END;
-
-if not !Options.v7 then
-GEXTEND Gram
-  command:
-    [ [ 
-(* State management *)
-        IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s
-      | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s
-      | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s
-      | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s
-
-(* Resetting *)
-      | IDENT "Reset"; id = identref -> VernacResetName id
-      | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial
-      | IDENT "Back" -> VernacBack 1
-      | IDENT "Back"; n = natural -> VernacBack n
-
-(* Tactic Debugger *)
-      |	IDENT "Debug"; IDENT "On" -> VernacDebug true
-      |	IDENT "Debug"; IDENT "Off" -> VernacDebug false
-
- ] ];
-    END
-;;
-
-(* Grammar extensions *)
-	  
-if not !Options.v7 then
-GEXTEND Gram
-  GLOBAL: syntax;
-
-  syntax:
-   [ [ IDENT "Open"; local = locality; IDENT "Scope"; sc = IDENT -> 
-         VernacOpenCloseScope (local,true,sc)
-
-     | IDENT "Close"; local = locality; IDENT "Scope"; sc = IDENT -> 
-         VernacOpenCloseScope (local,false,sc)
-
-     | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT ->
-	 VernacDelimiters (sc,key)
-
-     | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; 
-       refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
-
-     | IDENT "Arguments"; IDENT "Scope"; qid = global;
-         "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl)
-
-     | IDENT "Infix"; local = locality;
-	 op = ne_string; ":="; p = global; 
-         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
-	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
-         VernacInfix (local,(op,modl),p,None,sc)
-     | IDENT "Notation"; local = locality; id = ident; ":="; c = constr;
-	 b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] ->
-           VernacSyntacticDefinition (id,c,local,b)
-     | IDENT "Notation"; local = locality; s = ne_string; ":="; c = constr;
-         modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
-	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
-           VernacNotation (local,c,Some(s,modl),None,sc)
-
-     | IDENT "Tactic"; IDENT "Notation"; s = ne_string; 
-	 pil = LIST0 production_item; ":="; t = Tactic.tactic -> 
-	   VernacTacticGrammar ["",(s,pil),t]
-
-     | IDENT "Reserved"; IDENT "Notation"; local = locality; s = ne_string; 
-	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]
-	 -> VernacSyntaxExtension (local,Some(s,l),None)
-
-     (* "Print" "Grammar" should be here but is in "command" entry in order 
-        to factorize with other "Print"-based vernac entries *)
-  ] ]
-  ;
-  locality:
-    [ [ IDENT "Local" -> true | -> false ] ]
-  ;
-  level:
-    [ [ IDENT "level"; n = natural -> NumLevel n
-      | IDENT "next"; IDENT "level" -> NextLevel ] ]
-  ;
-  syntax_modifier:
-    [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev)
-      | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; 
-        lev = level -> SetItemLevel (x::l,lev)
-      | "at"; IDENT "level"; n = natural -> SetLevel n
-      | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA
-      | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA
-      | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA
-      | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ)
-      | IDENT "only"; IDENT "parsing" -> SetOnlyParsing
-      | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s ] ]
-  ;
-  syntax_extension_type:
-    [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference
-      | IDENT "bigint" -> ETBigint
-    ] ]
-  ;
-  opt_scope:
-    [ [ "_" -> None | sc = IDENT -> Some sc ] ]
-  ;
-  production_item:
-    [[ s = ne_string -> VTerm s
-     | nt = IDENT; po = OPT [ "("; p = ident; ")" -> p ] ->
-	 VNonTerm (loc,NtShort nt,po) ]]
-  ;
-END
-
-(* Reinstall tactic and vernac extensions *)
-let _ = 
-  if not !Options.v7 then
-    Egrammar.reset_extend_grammars_v8()
diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4
new file mode 100644
index 00000000..c13532cc
--- /dev/null
+++ b/parsing/g_xml.ml4
@@ -0,0 +1,272 @@
+(************************************************************************)
+(*  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: g_xml.ml4 9200 2006-10-03 14:11:08Z herbelin $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Pcoq
+open Rawterm
+open Genarg
+open Tacexpr
+open Libnames
+
+open Nametab
+open Detyping
+
+(* Generic xml parser without raw data *)
+
+type attribute = string * (loc * string)
+type xml = XmlTag of loc * string * attribute list * xml list
+
+let check_tags loc otag ctag =
+  if otag <> ctag then
+    user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ 
+      str "does not match open xml tag " ++ str otag)
+
+let xml_eoi = (Gram.Entry.create "xml_eoi" : xml Gram.Entry.e)
+
+GEXTEND Gram
+  GLOBAL: xml_eoi;
+
+  xml_eoi:
+    [ [ x = xml; EOI -> x ] ]
+  ;
+  xml:
+    [ [ "<"; otag = IDENT; attrs = LIST0 attr; ">"; l = LIST1 xml;
+        "<"; "/"; ctag = IDENT; ">"  ->
+	  check_tags loc otag ctag;
+	  XmlTag (loc,ctag,attrs,l)
+      | "<"; tag = IDENT; attrs = LIST0 attr; "/"; ">" ->
+	  XmlTag (loc,tag,attrs,[])
+    ] ]
+  ;
+  attr:
+    [ [ name = IDENT; "="; data = STRING -> (name, (loc, data)) ] ]
+  ;
+END
+
+(* Interpreting attributes *)
+
+let nmtoken (loc,a) =
+  try int_of_string a
+  with Failure _ -> user_err_loc (loc,"",str "nmtoken expected")
+  
+let interp_xml_attr_qualid = function
+  | "uri", s -> qualid_of_string s
+  | _ -> error "Ill-formed xml attribute"
+
+let get_xml_attr s al = 
+  try List.assoc s al
+  with Not_found -> error ("No attribute "^s)
+
+(* Interpreting specific attributes *)
+
+let ident_of_cdata (loc,a) = id_of_string a
+
+let uri_of_data s =
+  let n = String.index s ':' in
+  let p = String.index s '.' in
+  let s = String.sub s (n+2) (p-n-2) in
+  for i=0 to String.length s - 1 do if s.[i]='/' then s.[i]<-'.' done;
+  qualid_of_string s
+
+let constant_of_cdata (loc,a) = Nametab.locate_constant (uri_of_data a)
+
+let global_of_cdata (loc,a) = Nametab.locate (uri_of_data a)
+
+let inductive_of_cdata a = match global_of_cdata a with
+    | IndRef (kn,_) -> kn
+    | _ -> anomaly "XML parser: not an inductive"
+
+let ltacref_of_cdata (loc,a) = (loc,locate_tactic (uri_of_data a))
+
+let sort_of_cdata (loc,a) = match a with
+  | "Prop" -> RProp Null
+  | "Set" -> RProp Pos
+  | "Type" -> RType None
+  | _ -> user_err_loc (loc,"",str "sort expected")
+
+let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al)
+
+let get_xml_inductive_kn al =
+  inductive_of_cdata (* uriType apparent synonym of uri *)
+    (try get_xml_attr "uri" al with _ -> get_xml_attr "uriType" al)
+
+let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al)
+
+let get_xml_inductive al =
+  (get_xml_inductive_kn al, nmtoken (get_xml_attr "noType" al))
+
+let get_xml_constructor al =
+  (get_xml_inductive al, nmtoken (get_xml_attr "noConstr" al))
+
+let get_xml_binder al =
+  try Name (ident_of_cdata (List.assoc "binder" al))
+  with Not_found -> Anonymous
+
+let get_xml_ident al = ident_of_cdata (get_xml_attr "binder" al)
+
+let get_xml_name al = ident_of_cdata (get_xml_attr "name" al)
+
+let get_xml_noFun al = nmtoken (get_xml_attr "noFun" al)
+
+let get_xml_no al = nmtoken (get_xml_attr "no" al)
+
+(* A leak in the xml dtd: arities of constructor need to know global env *)
+
+let compute_branches_lengths ind =
+  let (_,mip) = Inductive.lookup_mind_specif (Global.env()) ind in
+  mip.Declarations.mind_consnrealdecls
+
+let compute_inductive_nargs ind =
+  Inductiveops.inductive_nargs (Global.env()) ind
+
+(* Interpreting constr as a rawconstr *)
+
+let rec interp_xml_constr = function
+  | XmlTag (loc,"REL",al,[]) ->
+      RVar (loc, get_xml_ident al)
+  | XmlTag (loc,"VAR",al,[]) -> 
+      error "XML parser: unable to interp free variables"
+  | XmlTag (loc,"LAMBDA",al,(_::_ as xl)) ->
+      let body,decls = list_sep_last xl in
+      let ctx = List.map interp_xml_decl decls in
+      List.fold_right (fun (na,t) b -> RLambda (loc, na, t, b))
+	ctx (interp_xml_target body)
+  | XmlTag (loc,"PROD",al,(_::_ as xl)) ->
+      let body,decls = list_sep_last xl in
+      let ctx = List.map interp_xml_decl decls in
+      List.fold_right (fun (na,t) b -> RProd (loc, na, t, b))
+	ctx (interp_xml_target body)
+  | XmlTag (loc,"LETIN",al,(_::_ as xl)) ->
+      let body,defs = list_sep_last xl in
+      let ctx = List.map interp_xml_def defs in
+      List.fold_right (fun (na,t) b -> RLetIn (loc, na, t, b))
+        ctx (interp_xml_target body)
+  | XmlTag (loc,"APPLY",_,x::xl) ->
+      RApp (loc, interp_xml_constr x, List.map interp_xml_constr xl)
+  | XmlTag (loc,"instantiate",_,
+      (XmlTag (_,("CONST"|"MUTIND"|"MUTCONSTRUCT"),_,_) as x)::xl) ->
+      RApp (loc, interp_xml_constr x, List.map interp_xml_arg xl)
+  | XmlTag (loc,"META",al,xl) ->
+      REvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl))
+  | XmlTag (loc,"CONST",al,[]) ->
+      RRef (loc, ConstRef (get_xml_constant al))
+  | XmlTag (loc,"MUTCASE",al,x::y::yl) ->
+      let ind = get_xml_inductive al in
+      let p = interp_xml_patternsType x in
+      let tm = interp_xml_inductiveTerm y in
+      let brs = List.map interp_xml_pattern yl in
+      let brns = Array.to_list (compute_branches_lengths ind) in
+      let mat = simple_cases_matrix_of_branches ind brns brs in
+      let nparams,n = compute_inductive_nargs ind in
+      let nal,rtn = return_type_of_predicate ind nparams n p in
+      RCases (loc,rtn,[tm,nal],mat)
+  | XmlTag (loc,"MUTIND",al,[]) ->
+      RRef (loc, IndRef (get_xml_inductive al))
+  | XmlTag (loc,"MUTCONSTRUCT",al,[]) ->
+      RRef (loc, ConstructRef (get_xml_constructor al))
+  | XmlTag (loc,"FIX",al,xl) ->
+      let li,lnct = List.split (List.map interp_xml_FixFunction xl) in
+      let ln,lc,lt = list_split3 lnct in
+      let lctx = List.map (fun _ -> []) ln in
+      RRec (loc, RFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt)
+  | XmlTag (loc,"COFIX",al,xl) ->
+      let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in
+      RRec (loc, RCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt)
+  | XmlTag (loc,"CAST",al,[x1;x2]) ->
+      RCast (loc, interp_xml_term x1, CastConv DEFAULTcast, interp_xml_type x2)
+  | XmlTag (loc,"SORT",al,[]) ->
+      RSort (loc, get_xml_sort al)
+  | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s)
+
+and interp_xml_tag s = function
+  | XmlTag (loc,tag,al,xl) when tag=s -> (loc,al,xl)
+  | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", 
+    str "Expect tag " ++ str s ++ str " but find " ++ str s)
+
+and interp_xml_constr_alias s x =
+  match interp_xml_tag s x with
+    | (_,_,[x]) -> interp_xml_constr x
+    | (loc,_,_) -> 
+        user_err_loc (loc,"",str "wrong number of arguments (expect one)")
+
+and interp_xml_term x = interp_xml_constr_alias "term" x
+and interp_xml_type x = interp_xml_constr_alias "type" x
+and interp_xml_target x = interp_xml_constr_alias "target" x
+and interp_xml_body x = interp_xml_constr_alias "body" x
+and interp_xml_pattern x = interp_xml_constr_alias "pattern" x
+and interp_xml_patternsType x = interp_xml_constr_alias "patternsType" x
+and interp_xml_inductiveTerm x = interp_xml_constr_alias "inductiveTerm" x
+and interp_xml_arg x = interp_xml_constr_alias "arg" x
+and interp_xml_substitution x = interp_xml_constr_alias "substitution" x
+                     (* no support for empty substitution from official dtd *)
+
+and interp_xml_decl_alias s x =
+  match interp_xml_tag s x with
+    | (_,al,[x]) -> (get_xml_binder al, interp_xml_constr x)
+    | (loc,_,_) -> 
+        user_err_loc (loc,"",str "wrong number of arguments (expect one)")
+
+and interp_xml_def x = interp_xml_decl_alias "def" x
+and interp_xml_decl x = interp_xml_decl_alias "decl" x
+
+and interp_xml_recursionOrder x =
+  let (loc, al, l) = interp_xml_tag "RecursionOrder" x in
+  let (locs, s) = get_xml_attr "type" al in
+    match s with
+	"Structural" -> 
+	  (match l with [] -> RStructRec
+	     | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected none)"))
+      | "WellFounded" -> 
+	  (match l with
+	       [c] -> RWfRec (interp_xml_type c)
+	     | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected one)"))
+      | "Measure" -> 
+	  (match l with
+	       [c] -> RMeasureRec (interp_xml_type c)
+	     | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected one)"))
+      | _ ->
+          user_err_loc (locs,"",str "invalid recursion order")
+
+and interp_xml_FixFunction x =
+  match interp_xml_tag "FixFunction" x with
+  | (loc,al,[x1;x2;x3]) -> (* Not in official cic.dtd, not in constr *)
+      ((Some (nmtoken (get_xml_attr "recIndex" al)),
+	interp_xml_recursionOrder x1),
+       (get_xml_name al, interp_xml_type x2, interp_xml_body x3))
+  | (loc,al,[x1;x2]) ->
+      ((Some (nmtoken (get_xml_attr "recIndex" al)), RStructRec),
+       (get_xml_name al, interp_xml_type x1, interp_xml_body x2))
+  | (loc,_,_) -> 
+        user_err_loc (loc,"",str "wrong number of arguments (expect one)")
+
+and interp_xml_CoFixFunction x =
+  match interp_xml_tag "CoFixFunction" x with
+  | (loc,al,[x1;x2]) ->
+      (get_xml_name al, interp_xml_type x1, interp_xml_body x2)
+    | (loc,_,_) -> 
+        user_err_loc (loc,"",str "wrong number of arguments (expect one)")
+
+(* Interpreting tactic argument *)
+
+let rec interp_xml_tactic_arg = function
+  | XmlTag (loc,"TERM",[],[x]) ->
+      ConstrMayEval (ConstrTerm (interp_xml_constr x,None))
+  | XmlTag (loc,"CALL",al,xl) ->
+      let ltacref = ltacref_of_cdata (get_xml_attr "uri" al) in
+      TacCall(loc,ArgArg ltacref,List.map interp_xml_tactic_arg xl)
+  | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s)
+
+let parse_tactic_arg ch =
+  interp_xml_tactic_arg
+    (Pcoq.Gram.Entry.parse xml_eoi
+        (Pcoq.Gram.parsable (Stream.of_channel ch)))
diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml
index 2d8d2ddd..554040d1 100644
--- a/parsing/g_zsyntax.ml
+++ b/parsing/g_zsyntax.ml
@@ -6,148 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: g_zsyntax.ml,v 1.16.2.2 2004/11/10 13:00:44 herbelin Exp $ *)
+(* $Id: g_zsyntax.ml 7988 2006-02-04 20:28:29Z herbelin $ *)
 
-open Coqast
 open Pcoq
 open Pp
 open Util
 open Names
-open Ast
-open Extend
 open Topconstr
 open Libnames
-open Bignat
-
-(**********************************************************************)
-(* V7 parsing via Grammar *)
-
-let get_z_sign loc =
-  let mkid id =
-    mkRefC (Qualid (loc,Libnames.make_short_qualid id))
-  in
-  ((mkid (id_of_string "xI"),
-    mkid (id_of_string "xO"),
-    mkid (id_of_string "xH")),
-   (mkid (id_of_string "ZERO"), 
-    mkid (id_of_string "POS"),
-    mkid (id_of_string "NEG")))
-
-let pos_of_bignat xI xO xH x =
-  let rec pos_of x =
-    match div2_with_rest x with
-      | (q, true) when is_nonzero q -> mkAppC (xI, [pos_of q])
-      | (q, false) -> mkAppC (xO, [pos_of q])
-      | (_, true) -> xH
-  in 
-  pos_of x
-    
-let z_of_string pos_or_neg s dloc = 
-  let ((xI,xO,xH),(aZERO,aPOS,aNEG)) = get_z_sign dloc in
-  let v = Bignat.of_string s in
-  if is_nonzero v then
-    if pos_or_neg then
-      mkAppC (aPOS, [pos_of_bignat xI xO xH v])
-    else 
-      mkAppC (aNEG, [pos_of_bignat xI xO xH v])
-  else 
-    aZERO
-
-(* Declare the primitive parser with Grammar and without the scope mechanism *)
-let zsyntax_create name =
-  let e =
-    Pcoq.create_constr_entry (Pcoq.get_univ "znatural") name in
-  Pcoq.Gram.Unsafe.clear_entry e;
-  e
-
-let number = zsyntax_create "number" 
-
-let negnumber = zsyntax_create "negnumber"
- 
-let _ =
-  Gram.extend number None
-    [None, None,
-     [[Gramext.Stoken ("INT", "")],
-      Gramext.action (z_of_string true)]]
-    
-let _ =
-  Gram.extend negnumber None
-    [None, None,
-     [[Gramext.Stoken ("INT", "")],
-      Gramext.action (z_of_string false)]]
-
-(**********************************************************************)
-(* Old v7 ast printing *)
-
-open Coqlib
+open Bigint
 
 exception Non_closed_number
 
-let get_z_sign_ast loc =
-  let ast_of_id id = 
-    Termast.ast_of_ref
-      (reference_of_constr
-	(gen_constant_in_modules "Z-printer" zarith_base_modules id))
-  in
-  ((ast_of_id "xI",
-    ast_of_id "xO",
-    ast_of_id "xH"),
-   (ast_of_id "ZERO", 
-    ast_of_id "POS",
-    ast_of_id "NEG"))
-
-let _ = if !Options.v7 then
-let rec bignat_of_pos c1 c2 c3 p =
-  match p with
-    | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c1) ->
-        mult_2 (bignat_of_pos c1 c2 c3 a)
-    | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c2) ->
-        add_1 (mult_2 (bignat_of_pos c1 c2 c3 a))
-    | a when alpha_eq(a,c3) -> Bignat.one
-    | _ -> raise Non_closed_number
-in
-let bignat_option_of_pos xI xO xH p =
-  try 
-    Some (bignat_of_pos xO xI xH p)
-  with Non_closed_number -> 
-    None
-in
-let pr_pos a = hov 0 (str "POS" ++ brk (1,1) ++ a) in
-let pr_neg a = hov 0 (str "NEG" ++ brk (1,1) ++ a) in
-
-let inside_printer posneg std_pr p =
-  let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in
-  match (bignat_option_of_pos xI xO xH p) with
-    | Some n -> 
-	if posneg then 
-	  (str (Bignat.to_string n))
-	else 
-	  (str "(-" ++ str (Bignat.to_string n) ++ str ")")
-    | None -> 
-	let pr = if posneg then pr_pos else pr_neg in
-	str "(" ++ pr (std_pr (ope("ZEXPR",[p]))) ++ str ")"
-in
-let outside_zero_printer std_pr p = str "`0`"
-in
-let outside_printer posneg std_pr p =
-  let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in
-  match (bignat_option_of_pos xI xO xH p) with
-    | Some n -> 
-	if posneg then 
-	  (str "`" ++ str (Bignat.to_string n) ++ str "`")
-	else 
-	  (str "`-" ++ str (Bignat.to_string n) ++ str "`")
-      | None -> 
-	  let pr = if posneg then pr_pos else pr_neg in
-	  str "(" ++ pr (std_pr p) ++ str ")"
-in
-(* For printing with Syntax and without the scope mechanism *)
-let _ = Esyntax.Ppprim.add ("positive_printer", (outside_printer true)) in
-let _ = Esyntax.Ppprim.add ("negative_printer", (outside_printer false)) in
-let _ = Esyntax.Ppprim.add ("positive_printer_inside", (inside_printer true))in
-let _ = Esyntax.Ppprim.add ("negative_printer_inside", (inside_printer false))
-in ()
-
 (**********************************************************************)
 (* Parsing positive via scopes                                        *)
 (**********************************************************************)
@@ -156,16 +26,19 @@ open Libnames
 open Rawterm
 let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
 let positive_module = ["Coq";"NArith";"BinPos"]
+let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+
+let positive_path = make_path positive_module "positive"
 
 (* TODO: temporary hack *)
-let make_path dir id = Libnames.encode_kn dir id
-
-let positive_path = 
-  make_path (make_dir positive_module) (id_of_string "positive")
-let glob_positive = IndRef (positive_path,0)
-let path_of_xI = ((positive_path,0),1)
-let path_of_xO = ((positive_path,0),2)
-let path_of_xH = ((positive_path,0),3)
+let make_kn dir id = Libnames.encode_kn dir id
+
+let positive_kn = 
+  make_kn (make_dir positive_module) (id_of_string "positive")
+let glob_positive = IndRef (positive_kn,0)
+let path_of_xI = ((positive_kn,0),1)
+let path_of_xO = ((positive_kn,0),2)
+let path_of_xH = ((positive_kn,0),3)
 let glob_xI = ConstructRef path_of_xI
 let glob_xO = ConstructRef path_of_xO
 let glob_xH = ConstructRef path_of_xH
@@ -177,34 +50,18 @@ let pos_of_bignat dloc x =
   let rec pos_of x =
     match div2_with_rest x with
       | (q,false) -> RApp (dloc, ref_xO,[pos_of q])
-      | (q,true) when is_nonzero q -> RApp (dloc,ref_xI,[pos_of q])
+      | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q])
       | (q,true) -> ref_xH
   in 
   pos_of x
 
-let interp_positive dloc = function
-  | POS n when is_nonzero n -> pos_of_bignat dloc n
-  | _ ->
-      user_err_loc (dloc, "interp_positive",
-        str "Only strictly positive numbers in type \"positive\"!")
-
-let rec pat_pos_of_bignat dloc x name =
-  match div2_with_rest x with
-    | (q,false) -> 
-        PatCstr (dloc,path_of_xO,[pat_pos_of_bignat dloc q Anonymous],name)
-    | (q,true) when is_nonzero q -> 
-        PatCstr (dloc,path_of_xI,[pat_pos_of_bignat dloc q Anonymous],name)
-    | (q,true) ->
-        PatCstr (dloc,path_of_xH,[],name)
-
 let error_non_positive dloc = 
   user_err_loc (dloc, "interp_positive",
-    str "No non-positive numbers in type \"positive\"!")
+    str "Only strictly positive numbers in type \"positive\"")
 
-let pat_interp_positive dloc = function
-  | NEG n -> error_non_positive dloc
-  | POS n ->
-     if is_nonzero n then pat_pos_of_bignat dloc n else error_non_positive dloc
+let interp_positive dloc n =
+  if is_strictly_pos n then pos_of_bignat dloc n
+  else error_non_positive dloc
 
 (**********************************************************************)
 (* Printing positive via scopes                                       *)
@@ -213,12 +70,12 @@ let pat_interp_positive dloc = function
 let rec bignat_of_pos = function
   | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
   | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
-  | RRef (_, a) when a = glob_xH -> Bignat.one
+  | RRef (_, a) when a = glob_xH -> Bigint.one
   | _ -> raise Non_closed_number
 
 let uninterp_positive p =
   try 
-    Some (POS (bignat_of_pos p))
+    Some (bignat_of_pos p)
   with Non_closed_number -> 
     None
 
@@ -226,61 +83,49 @@ let uninterp_positive p =
 (* Declaring interpreters and uninterpreters for positive *)
 (************************************************************************)
 
-let _ = Symbols.declare_numeral_interpreter "positive_scope"
-  (glob_positive,positive_module)
-  (interp_positive,Some pat_interp_positive)
-  ([RRef (dummy_loc, glob_xI); 
+let _ = Notation.declare_numeral_interpreter "positive_scope"
+  (positive_path,positive_module)
+  interp_positive
+  ([RRef (dummy_loc, glob_xI);
     RRef (dummy_loc, glob_xO); 
     RRef (dummy_loc, glob_xH)],
    uninterp_positive,
-   None)
+   true)
 
 (**********************************************************************)
 (* Parsing N via scopes                                               *)
 (**********************************************************************)
 
 let binnat_module = ["Coq";"NArith";"BinNat"]
-let n_path = make_path (make_dir binnat_module)
-  (id_of_string (if !Options.v7 then "entier" else "N"))
-let glob_n = IndRef (n_path,0)
-let path_of_N0 = ((n_path,0),1)
-let path_of_Npos = ((n_path,0),2)
+let n_kn = make_kn (make_dir binnat_module) (id_of_string "N")
+let glob_n = IndRef (n_kn,0)
+let path_of_N0 = ((n_kn,0),1)
+let path_of_Npos = ((n_kn,0),2)
 let glob_N0 = ConstructRef path_of_N0
 let glob_Npos = ConstructRef path_of_Npos
 
-let n_of_posint dloc pos_or_neg n = 
-  if is_nonzero n then
+let n_path = make_path binnat_module "N"
+
+let n_of_binnat dloc pos_or_neg n = 
+  if n <> zero then
     RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n])
   else 
     RRef (dloc, glob_N0)
 
-let n_of_int dloc n =
-  match n with
-  | POS n -> n_of_posint dloc true n 
-  | NEG n -> 
-      user_err_loc (dloc, "",
-        str "No negative number in type N")
-
-let pat_n_of_binnat dloc n name = 
-  if is_nonzero n then
-    PatCstr (dloc, path_of_Npos, [pat_pos_of_bignat dloc n Anonymous], name)
-  else 
-    PatCstr (dloc, path_of_N0, [], name)
+let error_negative dloc =
+  user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\"")
 
-let pat_n_of_int dloc n name =
-  match n with
-  | POS n -> pat_n_of_binnat dloc n name
-  | NEG n ->
-      user_err_loc (dloc, "",
-        str "No negative number in type N")
+let n_of_int dloc n =
+  if is_pos_or_zero n then n_of_binnat dloc true n
+  else error_negative dloc
 
 (**********************************************************************)
 (* Printing N via scopes                                              *)
 (**********************************************************************)
 
 let bignat_of_n = function
-  | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> POS (bignat_of_pos a)
-  | RRef (_, a) when a = glob_N0 -> POS (Bignat.zero)
+  | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
+  | RRef (_, a) when a = glob_N0 -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_n p =
@@ -290,60 +135,45 @@ let uninterp_n p =
 (************************************************************************)
 (* Declaring interpreters and uninterpreters for N *)
 
-let _ = Symbols.declare_numeral_interpreter "N_scope"
-  (glob_n,binnat_module)
-  (n_of_int,Some pat_n_of_int)
+let _ = Notation.declare_numeral_interpreter "N_scope"
+  (n_path,binnat_module)
+  n_of_int
   ([RRef (dummy_loc, glob_N0); 
     RRef (dummy_loc, glob_Npos)],
   uninterp_n,
-  None)
+  true)
    
 (**********************************************************************)
 (* Parsing Z via scopes                                               *)
 (**********************************************************************)
 
-let fast_integer_module = ["Coq";"ZArith";"BinInt"]
-let z_path = make_path (make_dir fast_integer_module) (id_of_string "Z")
-let glob_z = IndRef (z_path,0)
-let path_of_ZERO = ((z_path,0),1)
-let path_of_POS = ((z_path,0),2)
-let path_of_NEG = ((z_path,0),3)
+let binint_module = ["Coq";"ZArith";"BinInt"]
+let z_path = make_path binint_module "Z"
+let z_kn = make_kn (make_dir binint_module) (id_of_string "Z")
+let glob_z = IndRef (z_kn,0)
+let path_of_ZERO = ((z_kn,0),1)
+let path_of_POS = ((z_kn,0),2)
+let path_of_NEG = ((z_kn,0),3)
 let glob_ZERO = ConstructRef path_of_ZERO
 let glob_POS = ConstructRef path_of_POS
 let glob_NEG = ConstructRef path_of_NEG
 
-let z_of_posint dloc pos_or_neg n = 
-  if is_nonzero n then
-    let sgn = if pos_or_neg then glob_POS else glob_NEG in
+let z_of_int dloc n = 
+  if n <> zero then
+    let sgn, n =
+      if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in
     RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n])
   else 
     RRef (dloc, glob_ZERO)
 
-let z_of_int dloc z =
-  match z with
-  | POS n -> z_of_posint dloc true n 
-  | NEG n -> z_of_posint dloc false n 
-
-let pat_z_of_posint dloc pos_or_neg n name = 
-  if is_nonzero n then
-    let sgn = if pos_or_neg then path_of_POS else path_of_NEG in
-    PatCstr (dloc, sgn, [pat_pos_of_bignat dloc n Anonymous], name)
-  else 
-    PatCstr (dloc, path_of_ZERO, [], name)
-
-let pat_z_of_int dloc n name =
-  match n with
-  | POS n -> pat_z_of_posint dloc true n name
-  | NEG n -> pat_z_of_posint dloc false n name
-
 (**********************************************************************)
 (* Printing Z via scopes                                              *)
 (**********************************************************************)
 
 let bigint_of_z = function
-  | RApp (_, RRef (_,b),[a]) when b = glob_POS -> POS (bignat_of_pos a)
-  | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> NEG (bignat_of_pos a)
-  | RRef (_, a) when a = glob_ZERO -> POS (Bignat.zero)
+  | RApp (_, RRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
+  | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
+  | RRef (_, a) when a = glob_ZERO -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_z p =
@@ -354,56 +184,11 @@ let uninterp_z p =
 (************************************************************************)
 (* Declaring interpreters and uninterpreters for Z *)
 
-let _ = Symbols.declare_numeral_interpreter "Z_scope"
-  (glob_z,fast_integer_module)
-  (z_of_int,Some pat_z_of_int)
+let _ = Notation.declare_numeral_interpreter "Z_scope"
+  (z_path,binint_module)
+  z_of_int
   ([RRef (dummy_loc, glob_ZERO); 
     RRef (dummy_loc, glob_POS); 
     RRef (dummy_loc, glob_NEG)],
   uninterp_z,
-  None)
-   
-(************************************************************************)
-(* Old V7 ast Printers *)
-
-open Esyntax
-
-let _ = if !Options.v7 then
-let bignat_of_pos p =
-  let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in
-  let c1 = xO in
-  let c2 = xI in
-  let c3 = xH in
-  let rec transl = function
-    | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c1) -> mult_2(transl a)
-    | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c2) -> add_1(mult_2(transl a))
-    | a when alpha_eq(a,c3) -> Bignat.one
-    | _ -> raise Non_closed_number
-  in transl p
-in
-let bignat_option_of_pos p =
-  try 
-    Some (bignat_of_pos p)
-  with Non_closed_number -> 
-    None
-in
-let z_printer posneg p =
-  match bignat_option_of_pos p with
-    | Some n -> 
-	if posneg then 
-	  Some (str (Bignat.to_string n))
-	else 
-	  Some (str "-" ++ str (Bignat.to_string n))
-    | None -> None
-in
-let z_printer_ZERO _ =
-  Some (int 0)
-in
-(* Declare pretty-printers for integers *)
-let _ =
-  declare_primitive_printer "z_printer_POS" "Z_scope" (z_printer true) in
-let _ =
-  declare_primitive_printer "z_printer_NEG" "Z_scope" (z_printer false) in
-let _ =
-  declare_primitive_printer "z_printer_ZERO" "Z_scope" z_printer_ZERO in
-()
+  true)
diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli
index 6a7aeb14..11e0b6ac 100644
--- a/parsing/g_zsyntax.mli
+++ b/parsing/g_zsyntax.mli
@@ -6,6 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_zsyntax.mli,v 1.6.6.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+(*i $Id: g_zsyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Nice syntax for integers. *)
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
index bf5f3bfe..80eaf7f0 100644
--- a/parsing/lexer.ml4
+++ b/parsing/lexer.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lexer.ml4,v 1.24.2.6 2004/07/16 20:51:12 herbelin Exp $ i*)
+(*i $Id: lexer.ml4 9015 2006-07-05 17:19:22Z herbelin $ i*)
 
 open Pp
 open Token
@@ -54,7 +54,7 @@ let ttree_find ttree str =
   in 
   proc_rec ttree 0
 
-(* Lexer conventions on tokens *)
+(* Errors occuring while lexing (explained as "Lexer error: ...") *)
 
 type error =
   | Illegal_character
@@ -65,8 +65,165 @@ type error =
 
 exception Error of error
 
+let err loc str = Stdpp.raise_with_loc (Util.make_loc loc) (Error str)
+
 let bad_token str = raise (Error (Bad_token str))
 
+(* Lexer conventions on tokens *)
+
+type utf8_token =
+    Utf8Letter of int | Utf8IdentPart of int | Utf8Symbol | AsciiChar
+
+let error_unsupported_unicode_character n cs =
+  let bp = Stream.count cs in
+  err (bp,bp+n) (Bad_token "Unsupported Unicode character")
+
+let error_utf8 cs =
+  let bp = Stream.count cs in
+  err (bp, bp+1) Illegal_character
+
+let njunk n = Util.repeat n Stream.junk
+
+let check_utf8_trailing_byte cs c =
+  if Char.code c land 0xC0 <> 0x80 then error_utf8 cs
+
+(* Recognize utf8 blocks (of length less than 4 bytes) *)
+(* but don't certify full utf8 compliance (e.g. no emptyness check) *)
+let lookup_utf8_tail c cs =
+  let c1 = Char.code c in
+  if c1 land 0x40 = 0 or c1 land 0x38 = 0x38 then error_utf8 cs 
+  else
+    let n, unicode =
+      if c1 land 0x20 = 0 then
+      match Stream.npeek 2 cs with
+      | [_;c2] ->
+	  check_utf8_trailing_byte cs c2;
+	  2, (c1 land 0x1F) lsl 6 + (Char.code c2 land 0x3F)
+      | _ -> error_utf8 cs
+      else if c1 land 0x10 = 0 then
+      match Stream.npeek 3 cs with
+      | [_;c2;c3] ->
+	  check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3;
+	  3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 + 
+	  (Char.code c3 land 0x3F)
+      | _ -> error_utf8 cs
+      else match Stream.npeek 4 cs with
+      | [_;c2;c3;c4] ->
+	  check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3;
+	  check_utf8_trailing_byte cs c4; 
+	  4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 +
+	  (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F)
+      | _ -> error_utf8 cs
+    in
+    match unicode land 0x1F000 with
+    | 0x0 ->
+    begin match unicode with
+    (* utf-8 Latin-1 non breaking space U00A0 *)
+    | 0x00A0 -> Utf8Letter n
+    (* utf-8 Latin-1 symbols U00A1-00BF *)
+    | x when 0x00A0 <= x & x <= 0x00BF -> Utf8Symbol
+    (* utf-8 Latin-1 letters U00C0-00D6 *)
+    | x when 0x00C0 <= x & x <= 0x00D6 -> Utf8Letter n
+    (* utf-8 Latin-1 symbol U00D7 *)
+    | 0x00D7 -> Utf8Symbol
+    (* utf-8 Latin-1 letters U00D8-00F6 *)
+    | x when 0x00D8 <= x & x <= 0x00F6 -> Utf8Letter n
+    (* utf-8 Latin-1 symbol U00F7 *)
+    | 0x00F7 -> Utf8Symbol
+    (* utf-8 Latin-1 letters U00F8-00FF *)
+    | x when 0x00F8 <= x & x <= 0x00FF -> Utf8Letter n
+    (* utf-8 Latin Extended A U0100-017F and Latin Extended B U0180-U0241 *)
+    | x when 0x0100 <= x & x <= 0x0241 -> Utf8Letter n
+    (* utf-8 Phonetic letters U0250-02AF *)
+    | x when 0x0250 <= x & x <= 0x02AF -> Utf8Letter n
+    (* utf-8 what do to with diacritics U0300-U036F ? *)
+    (* utf-8 Greek letters U0380-03FF *)
+    | x when 0x0380 <= x & x <= 0x03FF -> Utf8Letter n
+    (* utf-8 Cyrillic letters U0400-0481 *)
+    | x when 0x0400 <= x & x <= 0x0481 -> Utf8Letter n
+    (* utf-8 Cyrillic symbol U0482 *)
+    | 0x0482 -> Utf8Symbol
+    (* utf-8 what do to with diacritics U0483-U0489 \ U0487 ? *)
+    (* utf-8 Cyrillic letters U048A-U4F9 (Warning: 04CF) *)
+    | x when 0x048A <= x & x <= 0x04F9 -> Utf8Letter n
+    (* utf-8 Cyrillic supplement letters U0500-U050F *)
+    | x when 0x0500 <= x & x <= 0x050F -> Utf8Letter n
+    (* utf-8 Hebrew letters U05D0-05EA *)
+    | x when 0x05D0 <= x & x <= 0x05EA -> Utf8Letter n
+    (* utf-8 Arabic letters U0621-064A *)
+    | x when 0x0621 <= x & x <= 0x064A -> Utf8Letter n
+    (* utf-8 Arabic supplement letters U0750-076D *)
+    | x when 0x0750 <= x & x <= 0x076D -> Utf8Letter n
+    | _ -> error_unsupported_unicode_character n cs
+    end
+    | 0x1000 ->
+    begin match unicode with
+    (* utf-8 Georgian U10A0-10FF (has holes) *)
+    | x when 0x10A0 <= x & x <= 0x10FF -> Utf8Letter n
+    (* utf-8 Hangul Jamo U1100-11FF (has holes) *)
+    | x when 0x1100 <= x & x <= 0x11FF -> Utf8Letter n
+    (* utf-8 Latin additional letters U1E00-1E9B and U1EA0-1EF9 *)
+    | x when 0x1E00 <= x & x <= 0x1E9B -> Utf8Letter n
+    | x when 0x1EA0 <= x & x <= 0x1EF9 -> Utf8Letter n
+    | _ -> error_unsupported_unicode_character n cs
+    end
+    | 0x2000 ->
+    begin match unicode with
+    (* utf-8 general punctuation U2080-2089 *)
+    (* Hyphens *)
+    | x when 0x2010 <= x & x <= 0x2011 -> Utf8Letter n 
+    (* Dashes and other symbols *)
+    | x when 0x2012 <= x & x <= 0x2027 -> Utf8Symbol
+    (* Per mille and per ten thousand signs *)
+    | x when 0x2030 <= x & x <= 0x2031 -> Utf8Symbol
+    (* Prime letters *)
+    | x when 0x2032 <= x & x <= 0x2034 or x = 0x2057 -> Utf8IdentPart n
+    (* Miscellaneous punctuation *)
+    | x when 0x2039 <= x & x <= 0x2056 -> Utf8Symbol
+    | x when 0x2058 <= x & x <= 0x205E -> Utf8Symbol
+    (* Invisible mathematical operators *)
+    | x when 0x2061 <= x & x <= 0x2063 -> Utf8Symbol
+
+    (* utf-8 subscript U2080-2089 *) 
+    | x when 0x2080 <= x & x <= 0x2089 -> Utf8IdentPart n
+    (* utf-8 letter-like U2100-214F *)
+    | x when 0x2100 <= x & x <= 0x214F -> Utf8Letter n
+    (* utf-8 number-forms U2153-2183 *)
+    | x when 0x2153 <= x & x <= 0x2183 -> Utf8Symbol
+    (* utf-8 arrows A U2190-21FF *)
+    (* utf-8 mathematical operators U2200-22FF *)
+    (* utf-8 miscellaneous technical U2300-23FF *)
+    | x when 0x2190 <= x & x <= 0x23FF -> Utf8Symbol
+    (* utf-8 box drawing U2500-257F has ceiling, etc. *)
+    (* utf-8 block elements U2580-259F *)
+    (* utf-8 geom. shapes U25A0-25FF (has triangles, losange, etc) *)
+    (* utf-8 miscellaneous symbols U2600-26FF *)
+    | x when 0x2500 <= x & x <= 0x26FF -> Utf8Symbol
+    (* utf-8 arrows B U2900-297F *)
+    | x when 0x2900 <= x & x <= 0x297F -> Utf8Symbol
+    (* utf-8 mathematical operators U2A00-2AFF *)
+    | x when 0x2A00 <= x & x <= 0x2AFF -> Utf8Symbol
+    | _ -> error_unsupported_unicode_character n cs
+    end
+    | _ ->
+    begin match unicode with
+    (* utf-8 Hiragana U3040-309F and Katakana U30A0-30FF *)
+    | x when 0x3040 <= x & x <= 0x30FF -> Utf8Letter n
+    (* utf-8 Unified CJK Ideographs U4E00-9FA5 *)
+    | x when 0x4E00 <= x & x <= 0x9FA5 -> Utf8Letter n
+    (* utf-8 Hangul syllables UAC00-D7AF *)
+    | x when 0xAC00 <= x & x <= 0xD7AF -> Utf8Letter n
+    (* utf-8 Gothic U10330-1034A *)
+    | x when 0x10330 <= x & x <= 0x1034A -> Utf8Letter n
+    | _ -> error_unsupported_unicode_character n cs
+    end
+	
+let lookup_utf8 cs =
+  match Stream.peek cs with
+    | Some ('\x00'..'\x7F') -> Some AsciiChar
+    | Some ('\x80'..'\xFF' as c) -> Some (lookup_utf8_tail c cs)
+    | None -> None
+
 let check_special_token str =
   let rec loop_symb = parser
     | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str
@@ -76,36 +233,19 @@ let check_special_token str =
   loop_symb (Stream.of_string str)
 
 let check_ident str =
-  let first_letter = function
-      (''' | '0'..'9') -> false
-    | _ -> true in
-  let rec loop_id = parser
-    | [< ' ('$' | 'a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_'); s >] ->
-        loop_id s
-    (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
-    | [< ' ('\206' | '\207'); ' ('\128'..'\191'); s >] -> loop_id s
-    | [< ''\226'; 'c2; 'c3; s >] ->
-	  (match c2, c3 with
-	      (* utf8 letter-like unicode 2100-214F *) 
-	    | (('\132', '\128'..'\191') | ('\133', '\128'..'\143')) ->
-                loop_id s 
-		(* utf8 symbols (see [parse_226_tail]) *)
-	    | (('\134'..'\143' | '\152'..'\155' | '\159'
-               | '\164'..'\171'),_) ->
-		bad_token str
-	    | _ -> (* default to iso 8859-1 "â" *)
-		if !Options.v7 then loop_id [< 'c2; 'c3; s >]
-                else bad_token str)
-	(* iso 8859-1 accentuated letters *)
-    | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255'); s >] ->
-        if !Options.v7 then loop_id s else bad_token str
-    | [< _ = Stream.empty >] -> ()
-    | [< >] -> bad_token str
+  let rec loop_id intail = parser
+    | [< ' ('$' | 'a'..'z' | 'A'..'Z' | '_'); s >] ->
+        loop_id true s
+    | [< ' ('0'..'9' | ''') when intail; s >] ->
+        loop_id true s
+    | [< s >] ->
+	match lookup_utf8 s with
+	| Some (Utf8Letter n) -> njunk n s; loop_id true s
+	| Some (Utf8IdentPart n) when intail -> njunk n s; loop_id true s
+	| Some _ -> bad_token str
+	| None -> ()
   in
-  if String.length str > 0 && first_letter str.[0] then
-    loop_id (Stream.of_string str)
-  else
-    bad_token str
+  loop_id false (Stream.of_string str)
 
 let check_keyword str =
   try check_special_token str
@@ -146,9 +286,6 @@ let init () =
 
 let _ = init()
 
-(* Errors occuring while lexing (explained as "Lexer error: ...") *)
-let err loc str = Stdpp.raise_with_loc (Util.make_loc loc) (Error str)
-
 (* The string buffering machinery *)
 
 let buff = ref (String.create 80)
@@ -159,38 +296,21 @@ let store len x =
   !buff.[len] <- x;
   succ len
 
-let mstore len s =
-  let rec add_rec len i =
-    if i == String.length s then len else add_rec (store len s.[i]) (succ i)
-  in
-  add_rec len 0
+let rec nstore n len cs =
+  if n>0 then nstore (n-1) (store len (Stream.next cs)) cs else len
 
 let get_buff len = String.sub !buff 0 len
 
-
 (* The classical lexer: idents, numbers, quoted strings, comments *)
 
-let rec ident_tail len strm =
-  if !Options.v7 then
-    match strm with parser
-      | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' | '@' as c); s >] ->
-          ident_tail (store len c) s
-      (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
-      | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] ->
-          ident_tail (store (store len c1) c2) s
-      (* iso 8859-1 accentuated letters *)
-      | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c); s >] -> 
-          ident_tail (store len c) s
-      | [< >] -> len
-  else
-    match strm with parser
-      | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] ->
-          ident_tail (store len c) s
-      (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
-      | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2) ; s >] ->
-          ident_tail (store (store len c1) c2) s
-      | [< >] -> len
-
+let rec ident_tail len = parser
+  | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] ->
+      ident_tail (store len c) s
+  | [< s >] ->
+      match lookup_utf8 s with
+      | Some (Utf8IdentPart n | Utf8Letter n) ->
+	  ident_tail (nstore n len s) s
+      | _ -> len
 
 let rec number len = parser
   | [< ' ('0'..'9' as c); s >] -> number (store len c) s
@@ -198,21 +318,11 @@ let rec number len = parser
 
 let escape len c = store len c
 
-let rec string_v8 bp len = parser
+let rec string bp len = parser
   | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] ->
-      if esc then string_v8 bp (store len '"') s else len
-  | [< 'c; s >] -> string_v8 bp (store len c) s 
-  | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string
-
-let rec string_v7 bp len = parser
-  | [< ''"' >] -> len
-  | [< ''\\'; c = (parser [< ' ('"' | '\\' as c) >] -> c | [< >] -> '\\'); s >]
-     -> string_v7 bp (escape len c) s
+      if esc then string bp (store len '"') s else len
+  | [< 'c; s >] -> string bp (store len c) s 
   | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string
-  | [< 'c; s >] -> string_v7 bp (store len c) s 
-
-let string bp len s =
-  if !Options.v7 then string_v7 bp len s else string_v8 bp len s
 
 (* Hook for exporting comment into xml theory files *)
 let xml_output_comment = ref (fun _ -> ())
@@ -293,163 +403,87 @@ let rec comment bp = parser bp2
        s >] -> comment bp s
   | [< ''*';
        _ = parser
-         | [< '')' >] ep -> push_string "*)";
+         | [< '')' >] -> push_string "*)";
          | [< s >] -> real_push_char '*'; comment bp s >] -> ()
   | [< ''"'; s >] ->
       if Options.do_translate() then (push_string"\"";comm_string bp2 s)
       else ignore (string bp2 0 s);
       comment bp s
   | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_comment
-  | [< '_ as z; s >] ep -> real_push_char z; comment bp s
+  | [< 'z; s >] -> real_push_char z; comment bp s
 
 (* Parse a special token, using the [token_tree] *)
 
-let progress_special c = function
-  | None -> None
-  | Some tt -> try Some (CharMap.find c tt.branch) with Not_found -> None
-
-let rec special tt cs = match tt with
-  | None -> None
-  | Some tt ->
-      match
-	match Stream.peek cs with
-	  | Some c -> 
-	      (try Some (CharMap.find c tt.branch) with Not_found -> None)
-	  | None -> None
-      with
-	| Some _ as tt' -> Stream.junk cs; special tt' cs
-	| None -> tt.node
-
+(* Peek as much utf-8 lexemes as possible *)
+(* then look if a special token is obtained *)
+let rec special tt cs =
+  match Stream.peek cs with
+    | Some c -> progress_from_byte 0 tt cs c
+    | None -> tt.node
+
+  (* nr is the number of char peeked; n the number of char in utf8 block *)
+and progress_utf8 nr n c tt cs =
+  try
+    let tt = CharMap.find c tt.branch in
+    let tt =
+      if n=1 then tt else
+	match Stream.npeek (n-nr) cs with
+	| l when List.length l = n-nr ->
+	    let l = Util.list_skipn (1-nr) l in
+	    List.iter (check_utf8_trailing_byte cs) l;
+	    List.fold_left (fun tt c -> CharMap.find c tt.branch) tt l
+	| _ -> 
+	    error_utf8 cs
+    in
+    for i=1 to n-nr do Stream.junk cs done;
+    special tt cs
+  with Not_found ->
+    tt.node
+
+and progress_from_byte nr tt cs = function
+  (* Utf8 leading byte *)
+  | '\x00'..'\x7F' as c -> progress_utf8 nr 1 c tt cs
+  | '\xC0'..'\xDF' as c -> progress_utf8 nr 2 c tt cs
+  | '\xE0'..'\xEF' as c -> progress_utf8 nr 3 c tt cs
+  | '\xF0'..'\xF7' as c -> progress_utf8 nr 4 c tt cs
+  | _ (* '\x80'..\xBF'|'\xF8'..'\xFF' *) ->
+      error_utf8 cs
+
+(* Must be a special token *)
 let process_chars bp c cs =
-  let t =
-    try special (Some (CharMap.find c !token_tree.branch)) cs
-    with Not_found -> !token_tree.node
-  in
+  let t = progress_from_byte 1 !token_tree cs c in
   let ep = Stream.count cs in
   match t with
     | Some t -> (("", t), (bp, ep))
     | None -> err (bp, ep) Undefined_token
 
-type token_226_tail =
-  | TokSymbol of string option
-  | TokIdent of string
-
-let parse_226_tail tk = parser
-  | [< ''\132' as c2; ' ('\128'..'\191' as c3);
-      (* utf8 letter-like unicode 2100-214F *)
-      len = ident_tail (store (store (store 0 '\226') c2) c3) >] ->
-      TokIdent (get_buff len) 
-  | [< ''\133' as c2; ' ('\128'..'\143' as c3);
-      (* utf8 letter-like unicode 2100-214F *)
-      len = ident_tail (store (store (store 0 '\226') c2) c3) >] ->
-      TokIdent (get_buff len) 
-  | [< ' ('\134'..'\143' | '\152'..'\155' | '\159' 
-         | '\164'..'\171' as c2); 'c3;
-      (* utf8 arrows A unicode 2190-21FF *)
-      (* utf8 mathematical operators unicode 2200-22FF *)
-      (* utf8 miscellaneous technical unicode 2300-23FF *)
-      (* utf8 miscellaneous symbols unicode 2600-26FF *)
-      (* utf8 Miscellaneous Mathematical Symbols-A unicode 27C0-27DF *)
-      (* utf8 Supplemental Arrows-A unicode 27E0-27FF *)
-      (* utf8 Supplemental Arrows-B unicode 2900-297F *)
-      (* utf8 Miscellaneous Mathematical Symbols-B unicode 2980-29FF *)
-      (* utf8 mathematical operators unicode 2A00-2AFF *)
-      t = special (progress_special c3 (progress_special c2 
-	(progress_special '\226' tk))) >] ->
-      TokSymbol t
-  | [< len = ident_tail (store 0 '\226') >] ->
-      TokIdent (get_buff len)
-
-
 (* Parse what follows a dot *)
-let parse_after_dot bp c strm =
-  if !Options.v7 then 
-    match strm with parser
-	 | [< ' ('_' | 'a'..'z' | 'A'..'Z' as c);
-              len = ident_tail (store 0 c) >] ->
-	     ("FIELD", get_buff len)
-	 (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
-	 | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); 
-	   len = ident_tail (store (store 0 c1) c2) >] ->
-	     ("FIELD", get_buff len)
-         (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *)
-	 | [< ''\226' as c1; t = parse_226_tail 
-	     (progress_special '.' (Some !token_tree)) >] ep ->
-	     (match t with
-	       | TokSymbol (Some t) -> ("", t)
-	       | TokSymbol None -> err (bp, ep) Undefined_token
-	       | TokIdent t -> ("FIELD", t))
-	 (* iso 8859-1 accentuated letters *)
-	 | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c);
-	   len = ident_tail (store 0 c) >] ->
-	     ("FIELD", get_buff len)
-	 | [< (t,_) = process_chars bp c >] -> t
-  else
-    match strm with parser
-	 | [< ' ('a'..'z' | 'A'..'Z' | '_' as c);
-              len = ident_tail (store 0 c) >] ->
-	     ("FIELD", get_buff len)
-	 (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
-	 | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); 
-	   len = ident_tail (store (store 0 c1) c2) >] ->
-	     ("FIELD", get_buff len)
-         (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *)
-	 | [< ''\226' as c1; t = parse_226_tail 
-	     (progress_special '.' (Some !token_tree)) >] ep ->
-	     (match t with
-	       | TokSymbol (Some t) -> ("", t)
-	       | TokSymbol None -> err (bp, ep) Undefined_token
-	       | TokIdent t -> ("FIELD", t))
-	 | [< (t,_) = process_chars bp c >] -> t
-
+let parse_after_dot bp c = parser
+  | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] ->
+      ("FIELD", get_buff len)
+  | [< s >] ->
+      match lookup_utf8 s with
+      | Some (Utf8Letter n) -> 
+	  ("FIELD", get_buff (ident_tail (nstore n 0 s) s))
+      | Some (Utf8IdentPart _ | AsciiChar | Utf8Symbol) | None -> 
+	  fst (process_chars bp c s)
 
 (* Parse a token in a char stream *)
-
 let rec next_token = parser bp
-  | [< '' ' | '\t' | '\n' |'\r' as c; s >] ep ->
+  | [< '' ' | '\t' | '\n' |'\r' as c; s >] ->
       comm_loc bp; push_char c; next_token s
   | [< ''$'; len = ident_tail (store 0 '$') >] ep -> 
       comment_stop bp;
       (("METAIDENT", get_buff len), (bp,ep))
   | [< ''.' as c; t = parse_after_dot bp c >] ep ->
       comment_stop bp;
-      if !Options.v7 & t=("",".") then between_com := true;
+      if Options.do_translate() & t=("",".") then between_com := true;
       (t, (bp,ep))
   | [< ' ('a'..'z' | 'A'..'Z' | '_' as c);
        len = ident_tail (store 0 c) >] ep ->
       let id = get_buff len in 
       comment_stop bp;
       (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)
-  (* Greek utf-8 letters [CE80-CEBF and CF80-CFBF] (CE=206; BF=191) *)
-  | [< ' ('\206' | '\207' as c1); ' ('\128'..'\191' as c2); 
-	   len = ident_tail (store (store 0 c1) c2) >] ep ->
-      let id = get_buff len in
-      comment_stop bp;
-      (try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)
-  (* utf-8 mathematical symbols have format E2 xx xx [E2=226] *)
-  | [< ''\226' as c1; t = parse_226_tail (Some !token_tree) >] ep ->
-      comment_stop bp;
-      (match t with
-	| TokSymbol (Some t) -> ("", t), (bp, ep)
-	| TokSymbol None -> err (bp, ep) Undefined_token
-	| TokIdent id ->
-	    (try ("", find_keyword id) with Not_found -> ("IDENT", id)),
-	    (bp, ep))
-  (* iso 8859-1 accentuated letters *)
-  | [< ' ('\192'..'\214' | '\216'..'\246' | '\248'..'\255' as c) ; s >] ->
-      if !Options.v7 then
-	begin
-	  match s with parser
-	      [< len = ident_tail (store 0 c) >] ep ->
-		let id = get_buff len in
-		comment_stop bp;
-		(try ("", find_keyword id) with Not_found -> ("IDENT", id)), (bp, ep)
-	end
-      else
-	begin
-	  match s with parser
-	      [< t = process_chars bp c >] -> comment_stop bp; t
-	end
   | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep ->
       comment_stop bp;
       (("INT", get_buff len), (bp, ep))
@@ -465,8 +499,19 @@ let rec next_token = parser bp
 	    next_token s
         | [< t = process_chars bp c >] -> comment_stop bp; t >] ->
       t
-  | [< 'c; t = process_chars bp c >] -> comment_stop bp; t
-  | [< _ = Stream.empty >] -> comment_stop bp; (("EOI", ""), (bp, bp + 1))
+  | [< s >] ->
+      match lookup_utf8 s with
+	| Some (Utf8Letter n) ->
+	    let len = ident_tail (nstore n 0 s) s in
+	    let id = get_buff len in
+	    let ep = Stream.count s in
+	    comment_stop bp;
+	    (try ("",find_keyword id) with Not_found -> ("IDENT",id)), (bp, ep)
+	| Some (Utf8Symbol | AsciiChar | Utf8IdentPart _) -> 
+	    let t = process_chars bp (Stream.next s) s in
+	    comment_stop bp; t
+	| None ->
+	    comment_stop bp; (("EOI", ""), (bp, bp + 1))
 
 (* Location table system for creating tables associating a token count
    to its location in a char stream (the source) *)
@@ -507,10 +552,10 @@ let func cs =
     Stream.from
       (fun i ->
          let (tok, loc) = next_token cs in
-	 loct_add loct i loc; Some tok)
+	   loct_add loct i loc; Some tok)
   in
-  current_location_table := loct;
-  (ts, loct_func loct)
+    current_location_table := loct;
+    (ts, loct_func loct)
 
 type location_table = (int * int) option array array ref
 let location_table () = !current_location_table
@@ -537,3 +582,42 @@ let tparse (p_con, p_prm) =
   else
     (parser [< '(con, prm) when con = p_con && prm = p_prm >] -> prm)
   i*)
+
+(* Terminal symbols interpretation *)
+
+let is_ident_not_keyword s =
+  match s.[0] with
+    | 'a'..'z' | 'A'..'Z' | '_' -> not (is_keyword s)
+    | _ -> false
+
+let is_number s =
+  let rec aux i =
+    String.length s = i or 
+    match s.[i] with '0'..'9' -> aux (i+1) | _ -> false
+  in aux 0
+
+let strip s =
+  let len =
+    let rec loop i len =
+      if i = String.length s then len
+      else if s.[i] == ' ' then loop (i + 1) len
+      else loop (i + 1) (len + 1)
+    in
+    loop 0 0
+  in
+  if len == String.length s then s
+  else
+    let s' = String.create len in
+    let rec loop i i' =
+      if i == String.length s then s'
+      else if s.[i] == ' ' then loop (i + 1) i'
+      else begin s'.[i'] <- s.[i]; loop (i + 1) (i' + 1) end
+    in
+    loop 0 0
+
+let terminal s =
+  let s = strip s in
+  if s = "" then failwith "empty token";
+  if is_ident_not_keyword s then ("IDENT", s)
+  else if is_number s then ("INT", s)
+  else ("", s)
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 133bca65..f1ab6446 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: lexer.mli,v 1.20.2.2 2004/07/16 19:30:39 herbelin Exp $ i*)
+(*i $Id: lexer.mli 7732 2005-12-26 13:51:24Z herbelin $ i*)
 
 open Pp
 open Util
@@ -48,3 +48,5 @@ val com_state: unit -> com_state
 val restore_com_state: com_state -> unit
 
 val set_xml_output_comment : (string -> unit) -> unit
+
+val terminal : string -> string * string
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
index a8922536..f7adfdd8 100644
--- a/parsing/pcoq.ml4
+++ b/parsing/pcoq.ml4
@@ -6,19 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pcoq.ml4,v 1.80.2.4 2005/06/21 15:31:12 herbelin Exp $ i*)
+(*i $Id: pcoq.ml4 9333 2006-11-02 13:59:14Z barras $ i*)
 
 open Pp
 open Util
 open Names
+open Extend
 open Libnames
 open Rawterm
 open Topconstr
-open Ast
 open Genarg
 open Tacexpr
 open Ppextend
-open Extend
 
 (* The lexer of Coq *)
 
@@ -52,7 +51,7 @@ let grammar_delete e rls =
        List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev))
     (List.rev rls)
 
-(* grammar_object is the superclass of all grammar entry *)
+(* grammar_object is the superclass of all grammar entries *)
 module type Gramobj =
 sig
   type grammar_object
@@ -65,8 +64,9 @@ struct
   let weaken_entry e = Obj.magic e
 end
 
+type entry_type = argument_type
 type grammar_object = Gramobj.grammar_object
-type typed_entry = entry_type * grammar_object G.Entry.e
+type typed_entry = argument_type * grammar_object G.Entry.e
 let in_typed_entry t e = (t,Gramobj.weaken_entry e)
 let type_of_typed_entry (t,e) = t
 let object_of_typed_entry (t,e) = e
@@ -182,7 +182,6 @@ let create_univ s =
 
 let uprim   = create_univ "prim"
 let uconstr = create_univ "constr"
-let umodule = create_univ "module"
 let utactic = create_univ "tactic"
 let uvernac = create_univ "vernac"
 
@@ -287,6 +286,55 @@ let force_entry_type (u, utab) s etyp =
   with Not_found -> 
     new_entry etyp (u, utab) s
 
+(* Tactics as arguments *)
+
+let tactic_main_level = 5
+
+let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg "tactic0"
+let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg "tactic1"
+let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg "tactic2"
+let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg "tactic3"
+let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg "tactic4"
+let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg "tactic5"
+
+let wit_tactic = function
+  | 0 -> wit_tactic0
+  | 1 -> wit_tactic1
+  | 2 -> wit_tactic2
+  | 3 -> wit_tactic3
+  | 4 -> wit_tactic4
+  | 5 -> wit_tactic5
+  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
+
+let globwit_tactic = function
+  | 0 -> globwit_tactic0
+  | 1 -> globwit_tactic1
+  | 2 -> globwit_tactic2
+  | 3 -> globwit_tactic3
+  | 4 -> globwit_tactic4
+  | 5 -> globwit_tactic5
+  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
+
+let rawwit_tactic = function
+  | 0 -> rawwit_tactic0
+  | 1 -> rawwit_tactic1
+  | 2 -> rawwit_tactic2
+  | 3 -> rawwit_tactic3
+  | 4 -> rawwit_tactic4
+  | 5 -> rawwit_tactic5
+  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
+
+let tactic_genarg_level s =
+  if String.length s = 7 && String.sub s 0 6 = "tactic" then
+    let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48)
+    else None
+  else None
+
+let is_tactic_genarg = function
+| ExtraArgType s -> tactic_genarg_level s <> None
+| _ -> false
+
+
 (* [make_gen_entry] builds entries extensible by giving its name (a string) *)
 (* For entries extensible only via the ML name, Gram.Entry.create is enough *)
 
@@ -311,10 +359,7 @@ module Prim =
     let reference = make_gen_entry uprim rawwit_ref "reference"
 
     (* parsed like ident but interpreted as a term *)
-    let hyp = gec_gen rawwit_ident "hyp"
-
-    (* synonym of hyp/ident (before semantics split) for v7 compatibility *)
-    let var = gec_gen rawwit_ident "var"
+    let var = gec_gen rawwit_var "var"
 
     let name = Gram.Entry.create "Prim.name"
     let identref = Gram.Entry.create "Prim.identref"
@@ -323,16 +368,11 @@ module Prim =
     let base_ident = Gram.Entry.create "Prim.base_ident"
 
     let qualid = Gram.Entry.create "Prim.qualid"
+    let fullyqualid = Gram.Entry.create "Prim.fullyqualid"
     let dirpath = Gram.Entry.create "Prim.dirpath"
 
     let ne_string = Gram.Entry.create "Prim.ne_string"
 
-    (* For old ast printer *)
-    let astpat = Gram.Entry.create "Prim.astpat"
-    let ast = Gram.Entry.create "Prim.ast"
-    let astlist = Gram.Entry.create "Prim.astlist"
-    let ast_eoi = eoi_entry ast
-    let astact = Gram.Entry.create "Prim.astact"
   end
 
 
@@ -372,15 +412,14 @@ module Tactic =
     (* Entries that can be refered via the string -> Gram.Entry.e table *)
     (* Typically for tactic user extensions *)
     let open_constr = 
-      make_gen_entry utactic rawwit_open_constr "open_constr"
-    let castedopenconstr = 
-      make_gen_entry utactic rawwit_casted_open_constr "castedopenconstr"
+      make_gen_entry utactic (rawwit_open_constr_gen false) "open_constr"
+    let casted_open_constr =
+      make_gen_entry utactic (rawwit_open_constr_gen true) "casted_open_constr"
     let constr_with_bindings =
       make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings"
     let bindings =
       make_gen_entry utactic rawwit_bindings "bindings"
-(*v7*) let constrarg = make_gen_entry utactic rawwit_constr_may_eval "constrarg"
-(*v8*) let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval"
+    let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval"
     let quantified_hypothesis =
       make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis"
     let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var"
@@ -390,13 +429,18 @@ module Tactic =
 
     (* Main entries for ltac *)
     let tactic_arg = Gram.Entry.create "tactic:tactic_arg"
-    let tactic = make_gen_entry utactic rawwit_tactic "tactic"
+    let tactic_expr = Gram.Entry.create "tactic:tactic_expr"
+    let binder_tactic = Gram.Entry.create "tactic:binder_tactic"
+
+    let tactic = make_gen_entry utactic (rawwit_tactic tactic_main_level) "tactic"
 
     (* Main entry for quotations *)
     let tactic_eoi = eoi_entry tactic
+
   end
 
 
+
 module Vernac_ =
   struct
     let gec_vernac s = Gram.Entry.create ("vernac:" ^ s)
@@ -408,34 +452,14 @@ module Vernac_ =
     let syntax = gec_vernac "syntax_command"
     let vernac = gec_vernac "Vernac_.vernac"
 
-    let vernac_eoi = eoi_entry vernac
-  end
+    (* MMode *)
 
+    let proof_instr = Gram.Entry.create "proofmode:instr"
 
-(* Prim is not re-initialized *)
-let reset_all_grammars () =
-  let f = Gram.Unsafe.clear_entry in
-  List.iter f
-    [Constr.constr;Constr.operconstr;Constr.lconstr;Constr.annot;
-     Constr.constr_pattern;Constr.lconstr_pattern];
-  f Constr.ident; f Constr.global; f Constr.sort; f Constr.pattern;
-  f Module.module_expr; f Module.module_type;
-  f Tactic.simple_tactic;
-  f Tactic.castedopenconstr;
-  f Tactic.constr_with_bindings;
-  f Tactic.bindings;
-  f Tactic.constrarg;
-  f Tactic.quantified_hypothesis;
-  f Tactic.int_or_var;
-  f Tactic.red_expr;
-  f Tactic.tactic_arg;
-  f Tactic.tactic;
-  f Vernac_.gallina;
-  f Vernac_.gallina_ext;
-  f Vernac_.command;
-  f Vernac_.syntax;
-  f Vernac_.vernac;
-  Lexer.init()
+    (* /MMode *)
+
+    let vernac_eoi = eoi_entry vernac
+  end
 
 let main_entry = Gram.Entry.create "vernac"
 
@@ -445,88 +469,6 @@ GEXTEND Gram
   ;
 END
 
-(* Quotations *)
-
-open Prim
-open Constr
-open Tactic
-open Vernac_
-
-(* current file and toplevel/vernac.ml *)
-let globalizer = ref (fun x -> failwith "No globalizer")
-let set_globalizer f = globalizer := f
-
-let define_ast_quotation default s (e:Coqast.t G.Entry.e) =
-  (if default then
-    GEXTEND Gram
-      ast: [ [ "<<"; c = e; ">>" -> c ] ];
-     (* Uncomment this to keep compatibility with old grammar syntax
-     constr: [ [ "<<"; c = e; ">>" -> c ] ];
-     vernac: [ [ "<<"; c = e; ">>" -> c ] ];
-     tactic: [ [ "<<"; c = e; ">>" -> c ] ];
-     *)
-   END);
-  (GEXTEND Gram
-     GLOBAL: ast constr command tactic;
-     ast:
-       [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ];
-     (* Uncomment this to keep compatibility with old grammar syntax
-     constr:
-       [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ];
-     command:
-       [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ];
-     tactic:
-       [ [ "<:"; IDENT $s$; ":<"; c = e; ">>" -> c ] ];
-     *)
-   END)
-
-(*
-let _ = define_ast_quotation false "ast" ast in ()
-*)
-
-let dynconstr = Gram.Entry.create "Constr.dynconstr"
-let dyncasespattern = Gram.Entry.create "Constr.dyncasespattern"
-
-GEXTEND Gram
-  dynconstr:
-  [ [ a = Constr.constr -> ConstrNode a 
-    (* For compatibility *)
-    | "<<"; a = Constr.lconstr; ">>" -> ConstrNode a ] ]
-  ;
-  dyncasespattern: [ [ a = Constr.pattern -> CasesPatternNode a ] ];
-END
-
-(**********************************************************************)
-(* The following is to dynamically set the parser in Grammar actions  *)
-(* and Syntax pattern, according to the universe of the rule defined  *)
-
-type parser_type =
-  | ConstrParser
-  | CasesPatternParser
-
-let default_action_parser_ref = ref dynconstr
-
-let get_default_action_parser () = !default_action_parser_ref
-
-let entry_type_of_parser =  function
-  | ConstrParser -> Some ConstrArgType
-  | CasesPatternParser -> failwith "entry_type_of_parser: cases_pattern, TODO"
-
-let parser_type_from_name =  function
-  | "constr" -> ConstrParser
-  | "cases_pattern" -> CasesPatternParser
-  | "tactic" -> assert false
-  | "vernac" -> error "No longer supported"
-  | s -> ConstrParser
-
-let set_default_action_parser = function
-  | ConstrParser  -> default_action_parser_ref := dynconstr
-  | CasesPatternParser  -> default_action_parser_ref := dyncasespattern
-
-let default_action_parser =
-  Gram.Entry.of_parser "default_action_parser" 
-    (fun strm -> Gram.Entry.parse_token (get_default_action_parser ()) strm)
-
 (**********************************************************************)
 (* This determines (depending on the associativity of the current
    level and on the expected associativity) if a reference to constr_n is
@@ -536,24 +478,9 @@ let default_action_parser =
    translated in camlp4 into "constr" without level) or to another level
    (to be translated into "constr LEVEL n") *)
 
-let assoc_level = function
-  | Some Gramext.LeftA when !Options.v7 -> "L"
-  | _ -> ""
-
-let constr_level = function
-  | n,assoc -> (string_of_int n)^(assoc_level assoc)
-
-let constr_level2 = function
-  | n,assoc -> (string_of_int n)^(assoc_level (Some assoc))
-
-let default_levels_v7 =
-  [10,Gramext.RightA;
-   9,Gramext.RightA;
-   8,Gramext.RightA;
-   1,Gramext.RightA;
-   0,Gramext.RightA]
+let constr_level = string_of_int
 
-let default_levels_v8 =
+let default_levels =
   [200,Gramext.RightA;
    100,Gramext.RightA;
    99,Gramext.RightA;
@@ -563,20 +490,20 @@ let default_levels_v8 =
    1,Gramext.LeftA;
    0,Gramext.RightA]
 
-let default_pattern_levels_v8 =
-  [10,Gramext.LeftA;
+let default_pattern_levels =
+  [200,Gramext.RightA;
+   100,Gramext.RightA;
+   99,Gramext.RightA;
+   10,Gramext.LeftA;
+   1,Gramext.LeftA;
    0,Gramext.RightA]
 
 let level_stack = 
-  ref 
-    [if !Options.v7 then (default_levels_v7, default_levels_v7)
-     else (default_levels_v8, default_pattern_levels_v8)]
+  ref [(default_levels, default_pattern_levels)]
 
 (* At a same level, LeftA takes precedence over RightA and NoneA *)
 (* In case, several associativity exists for a level, we make two levels, *)
 (* first LeftA, then RightA and NoneA together *)
-exception Found of Gramext.g_assoc
-
 open Ppextend
 
 let admissible_assoc = function
@@ -599,48 +526,35 @@ let error_level_assoc p current expected =
      pr_assoc expected ++ str " associative")
 
 let find_position forpat other assoc lev =
-  let default = if !Options.v7 then Some (10,Gramext.RightA) else None in
   let ccurrent,pcurrent as current = List.hd !level_stack in 
   match lev with
   | None ->
       level_stack := current :: !level_stack;
       None, (if other then assoc else None), None
   | Some n ->
-      if !Options.v7 & n = 8 & assoc = Some Gramext.LeftA then 
-	error "Left associativity not allowed at level 8";
-      let after = ref default in
+      let after = ref None in
       let rec add_level q = function
-        | (p,_ as pa)::l when p > n -> pa :: add_level (Some pa) l
-        | (p,a as pa)::l as l' when p = n ->
-	    if admissible_assoc (a,assoc) then raise (Found a);
-	    (* No duplication of levels in v8 *)
-	    if not !Options.v7 then error_level_assoc p a (out_some assoc);
-	    (* Maybe this was (p,Left) and p occurs a second time *)
-	    if a = Gramext.LeftA then
-	      match l with
-		| (p,a)::_ as l' when p = n -> raise (Found a)
-		| _ -> after := Some pa; pa::(n,create_assoc assoc)::l
-	    else
-	      (* This was not (p,LeftA) hence assoc is RightA *)
-	      (after := q; (n,create_assoc assoc)::l')
-	| l ->
-	    after := q; (n,create_assoc assoc)::l
+        | (p,_ as pa)::l when p > n -> pa :: add_level (Some p) l
+        | (p,a)::l when p = n ->
+	    if admissible_assoc (a,assoc) then raise Exit;
+	    error_level_assoc p a (out_some assoc)
+	| l -> after := q; (n,create_assoc assoc)::l
       in
       try
 	(* Create the entry *)
 	let updated =
-	  if forpat then (ccurrent, add_level default pcurrent)
-	  else (add_level default ccurrent, pcurrent) in
+	  if forpat then (ccurrent, add_level None pcurrent)
+	  else (add_level None ccurrent, pcurrent) in
         level_stack := updated:: !level_stack;
 	let assoc = create_assoc assoc in
 	(if !after = None then Some Gramext.First
-	else Some (Gramext.After (constr_level2 (out_some !after)))),
-	Some assoc, Some (constr_level2 (n,assoc))
+	else Some (Gramext.After (constr_level (out_some !after)))),
+	Some assoc, Some (constr_level n)
       with
-          Found a ->
+          Exit ->
             level_stack := current :: !level_stack;
 	    (* Just inherit the existing associativity and name (None) *)
-	    Some (Gramext.Level (constr_level2 (n,a))), None, None
+	    Some (Gramext.Level (constr_level n)), None, None
 
 let remove_levels n =
   level_stack := list_skipn n !level_stack
@@ -663,19 +577,19 @@ let adjust_level assoc from = function
   | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true))
 (* Compute production name on the right side *)
   (* If NonA or LeftA on the right-hand side, set to NEXT *)
-  | (NumLevel n,BorderProd (false,Some (Gramext.NonA|Gramext.LeftA))) ->
+  | (NumLevel n,BorderProd (Right,Some (Gramext.NonA|Gramext.LeftA))) ->
       Some None
   (* If RightA on the right-hand side, set to the explicit (current) level *)
-  | (NumLevel n,BorderProd (false,Some Gramext.RightA)) ->
+  | (NumLevel n,BorderProd (Right,Some Gramext.RightA)) ->
       Some (Some (n,true))
 (* Compute production name on the left side *)
   (* If NonA on the left-hand side, adopt the current assoc ?? *)
-  | (NumLevel n,BorderProd (true,Some Gramext.NonA)) -> None
+  | (NumLevel n,BorderProd (Left,Some Gramext.NonA)) -> None
   (* If the expected assoc is the current one, set to SELF *)
-  | (NumLevel n,BorderProd (true,Some a)) when a = camlp4_assoc assoc ->
+  | (NumLevel n,BorderProd (Left,Some a)) when a = camlp4_assoc assoc ->
       None
   (* Otherwise, force the level, n or n-1, according to expected assoc *)
-  | (NumLevel n,BorderProd (true,Some a)) ->
+  | (NumLevel n,BorderProd (Left,Some a)) ->
       if a = Gramext.LeftA then Some (Some (n,true)) else Some None
   (* None means NEXT *)
   | (NextLevel,_) -> Some None
@@ -686,39 +600,11 @@ let adjust_level assoc from = function
 	| ETConstr (p,()) -> Some (Some (n,n=p))
 	| _ -> Some (Some (n,false))
 
-(*
-  (* If NonA on the right-hand side, set to NEXT *)
-  | (n,BorderProd (false,Some Gramext.NonA)) -> Some None
-  (* If NonA on the left-hand side, adopt the current assoc ?? *)
-  | (n,BorderProd (true,Some Gramext.NonA)) -> None
-  (* Associativity is None means force the level *)
-  | (n,BorderProd (_,None)) -> Some (Some (n,true))
-  (* If left assoc at a left level, set NEXT on the right *)
-  | (n,BorderProd (false,Some (Gramext.LeftA as a)))
-      when Gramext.LeftA = camlp4_assoc assoc -> Some None
-  (* If right or none assoc expected is the current assoc, set explicit 
-     level on the right side *)
-  | (n,BorderProd (false,Some a)) when a = camlp4_assoc assoc ->
-      Some (Some (n,true))
-  (* If the expected assoc is the current one, SELF on the left sides *)
-  | (n,BorderProd (true,Some a)) when a = camlp4_assoc assoc -> None
-  (* Otherwise, force the level, n or n-1, according to expected assoc *)
-  | (n,BorderProd (left,Some a)) ->
-      if (left & a = Gramext.LeftA) or ((not left) & a = Gramext.RightA)
-      then Some (Some (n,true)) else Some (Some (n-1,false))
-(*  | (8,InternalProd) -> None (* Or (Some 8) for factorization ? *)*)
-  | (n,InternalProd) ->
-      match from with
-	| ETConstr (p,()) when p = n+1 -> Some None
-	| ETConstr (p,()) -> Some (Some (n,n=p))
-	| _ -> Some (Some (n,false))
-*)
-
 let compute_entry allow_create adjust forpat = function
   | ETConstr (n,q) ->
       (if forpat then weaken_entry Constr.pattern
        else weaken_entry Constr.operconstr),
-      (if forpat & !Options.v7 then None else adjust (n,q)), false
+      adjust (n,q), false
   | ETIdent -> weaken_entry Constr.ident, None, false
   | ETBigint -> weaken_entry Prim.bigint, None, false
   | ETReference -> weaken_entry Constr.global, None, false
@@ -734,42 +620,22 @@ let compute_entry allow_create adjust forpat = function
       object_of_typed_entry e, None, true
 
 (* This computes the name of the level where to add a new rule *)
-let get_constr_entry forpat en =
-  match en with
-      ETConstr(200,()) when not !Options.v7 & not forpat ->
-	snd (get_entry (get_univ "constr") "binder_constr"),
-        None,
-        false
-    | _ -> compute_entry true (fun (n,()) -> Some n) forpat en
+let get_constr_entry forpat = function
+  | ETConstr(200,()) when not forpat ->
+      weaken_entry Constr.binder_constr, None, false
+  | e ->
+      compute_entry true (fun (n,()) -> Some n) forpat e
 
 (* This computes the name to give to a production knowing the name and
    associativity of the level where it must be added *)
 let get_constr_production_entry ass from forpat en =
-  (* first 2 cases to help factorisation *)
-  match en with
-    | ETConstr (NumLevel 10,q) when !Options.v7 & not forpat ->
-        weaken_entry Constr.lconstr, None, false
-(*
-    | ETConstr (8,q) when !Options.v7 ->
-        weaken_entry Constr.constr, None, false
-*)
-    | _ -> compute_entry false (adjust_level ass from) forpat en
-
-let constr_prod_level assoc cur lev =
-  if !Options.v7 then
-    if cur then constr_level (lev,assoc) else
-      match lev with
-	| 4 when !Options.v7 -> "4L"
-	| n -> string_of_int n
-  else
-    (* No duplication L/R of levels in v8 *)
-    constr_level (lev,assoc)
+  compute_entry false (adjust_level ass from) forpat en
 
 let is_self from e =
   match from, e with
       ETConstr(n,()), ETConstr(NumLevel n',
-        BorderProd(false, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false
-    | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(true,_)) -> n=n'
+        BorderProd(Right, _ (* Some(Gramext.NonA|Gramext.LeftA) *))) -> false
+    | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> n=n'
     | (ETIdent,ETIdent | ETReference, ETReference | ETBigint,ETBigint
       | ETPattern, ETPattern) -> true
     | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2'
@@ -778,15 +644,14 @@ let is_self from e =
 let is_binder_level from e =
   match from, e with
       ETConstr(200,()),
-      ETConstr(NumLevel 200,(BorderProd(false,_)|InternalProd)) ->
-        not !Options.v7
+      ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true
     | _ -> false
 
 let rec symbol_of_production assoc from forpat typ =
   if is_binder_level from typ then
-    let eobj = snd (get_entry (get_univ "constr") "operconstr") in
-    Gramext.Snterml (Gram.Entry.obj eobj,"200")
-  else if is_self from typ then Gramext.Sself
+    Gramext.Snterml (Gram.Entry.obj Constr.operconstr,"200")
+  else if is_self from typ then
+    Gramext.Sself
   else
     match typ with
     | ETConstrList (typ',[]) ->
@@ -803,4 +668,15 @@ let rec symbol_of_production assoc from forpat typ =
       | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj)
       | (eobj,Some None,_) -> Gramext.Snext
       | (eobj,Some (Some (lev,cur)),_) -> 
-          Gramext.Snterml (Gram.Entry.obj eobj,constr_prod_level assoc cur lev)
+          Gramext.Snterml (Gram.Entry.obj eobj,constr_level lev)
+
+(*****************************)
+(* Coercions between entries *)
+
+let coerce_reference_to_id = function
+  | Ident (_,id) -> id
+  | Qualid (loc,_) ->
+      user_err_loc (loc, "coerce_reference_to_id",
+        str "This expression should be a simple identifier")
+
+let coerce_global_to_id = coerce_reference_to_id
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index 15a2c2cc..1fe8c122 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -6,18 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pcoq.mli,v 1.63.2.3 2005/06/21 15:31:12 herbelin Exp $ i*)
+(*i $Id: pcoq.mli 9333 2006-11-02 13:59:14Z barras $ i*)
 
 open Util
 open Names
 open Rawterm
-open Ast
+open Extend
 open Genarg
 open Topconstr
 open Tacexpr
 open Vernacexpr
 open Libnames
-open Extend
 
 (* The lexer and parser of Coq. *)
 
@@ -25,21 +24,23 @@ val lexer : Token.lexer
 
 module Gram : Grammar.S with type te = Token.t
 
+(* The superclass of all grammar entries *)
 type grammar_object
+
+(* The type of typed grammar objects *)
 type typed_entry
 
-val type_of_typed_entry : typed_entry -> Extend.entry_type
+type entry_type = argument_type
+
+val type_of_typed_entry : typed_entry -> entry_type
 val object_of_typed_entry : typed_entry -> grammar_object Gram.Entry.e
 val weaken_entry : 'a Gram.Entry.e -> grammar_object Gram.Entry.e
 
 val get_constr_entry :
   bool -> constr_entry -> grammar_object Gram.Entry.e * int option * bool
 
-val symbol_of_production : Gramext.g_assoc option -> constr_entry ->
-  bool -> constr_production_entry -> Token.t Gramext.g_symbol
-
 val grammar_extend :
-  'a Gram.Entry.e -> Gramext.position option ->
+  grammar_object Gram.Entry.e -> Gramext.position option ->
     (string option * Gramext.g_assoc option *
      (Token.t Gramext.g_symbol list * Gramext.g_action) list) list
     -> unit
@@ -76,25 +77,45 @@ val force_entry_type :
 
 val create_constr_entry :
   string * gram_universe -> string -> constr_expr Gram.Entry.e
-val create_generic_entry : string -> ('a, constr_expr,raw_tactic_expr) abstract_argument_type -> 'a Gram.Entry.e
+val create_generic_entry : string -> ('a, rlevel,raw_tactic_expr) abstract_argument_type -> 'a Gram.Entry.e
 val get_generic_entry : string -> grammar_object Gram.Entry.e
 val get_generic_entry_type : string * gram_universe -> string -> Genarg.argument_type
 
-type parser_type =
-  | ConstrParser
-  | CasesPatternParser
+(* Tactics as arguments *)
+
+val tactic_main_level : int
+
+val rawwit_tactic : int -> (raw_tactic_expr,rlevel,raw_tactic_expr) abstract_argument_type
+val globwit_tactic : int -> (glob_tactic_expr,glevel,glob_tactic_expr) abstract_argument_type
+val wit_tactic : int -> (glob_tactic_expr,tlevel,glob_tactic_expr) abstract_argument_type
+
+val rawwit_tactic0 : (raw_tactic_expr,rlevel,raw_tactic_expr) abstract_argument_type
+val globwit_tactic0 : (glob_tactic_expr,glevel,glob_tactic_expr) abstract_argument_type
+val wit_tactic0 : (glob_tactic_expr,tlevel,glob_tactic_expr) abstract_argument_type
 
-val entry_type_of_parser : parser_type -> entry_type option
-val parser_type_from_name : string -> parser_type
+val rawwit_tactic1 : (raw_tactic_expr,rlevel,raw_tactic_expr) abstract_argument_type
+val globwit_tactic1 : (glob_tactic_expr,glevel,glob_tactic_expr) abstract_argument_type
+val wit_tactic1 : (glob_tactic_expr,tlevel,glob_tactic_expr) abstract_argument_type
 
-(* Quotations in ast parser *)
-val define_ast_quotation : bool -> string -> (Coqast.t Gram.Entry.e) -> unit
-val set_globalizer : (constr_expr -> Coqast.t) -> unit
+val rawwit_tactic2 : (raw_tactic_expr,rlevel,raw_tactic_expr) abstract_argument_type
+val globwit_tactic2 : (glob_tactic_expr,glevel,glob_tactic_expr) abstract_argument_type
+val wit_tactic2 : (glob_tactic_expr,tlevel,glob_tactic_expr) abstract_argument_type
 
-(* The default parser for actions in grammar rules *)
+val rawwit_tactic3 : (raw_tactic_expr,rlevel,raw_tactic_expr) abstract_argument_type
+val globwit_tactic3 : (glob_tactic_expr,glevel,glob_tactic_expr) abstract_argument_type
+val wit_tactic3 : (glob_tactic_expr,tlevel,glob_tactic_expr) abstract_argument_type
 
-val default_action_parser : dynamic_grammar Gram.Entry.e
-val set_default_action_parser : parser_type -> unit
+val rawwit_tactic4 : (raw_tactic_expr,rlevel,raw_tactic_expr) abstract_argument_type
+val globwit_tactic4 : (glob_tactic_expr,glevel,glob_tactic_expr) abstract_argument_type
+val wit_tactic4 : (glob_tactic_expr,tlevel,glob_tactic_expr) abstract_argument_type
+
+val rawwit_tactic5 : (raw_tactic_expr,rlevel,raw_tactic_expr) abstract_argument_type
+val globwit_tactic5 : (glob_tactic_expr,glevel,glob_tactic_expr) abstract_argument_type
+val wit_tactic5 : (glob_tactic_expr,tlevel,glob_tactic_expr) abstract_argument_type
+
+val is_tactic_genarg : argument_type -> bool
+
+val tactic_genarg_level : string -> int option
 
 (* The main entry: reads an optional vernac command *)
 
@@ -113,20 +134,15 @@ module Prim :
     val identref : identifier located Gram.Entry.e
     val base_ident : identifier Gram.Entry.e
     val natural : int Gram.Entry.e
-    val bigint : Bignat.bigint Gram.Entry.e
+    val bigint : Bigint.bigint Gram.Entry.e
     val integer : int Gram.Entry.e
     val string : string Gram.Entry.e
     val qualid : qualid located Gram.Entry.e
+    val fullyqualid : identifier list located Gram.Entry.e
     val reference : reference Gram.Entry.e
     val dirpath : dir_path Gram.Entry.e
     val ne_string : string Gram.Entry.e
-    val hyp : identifier Gram.Entry.e
-    (* v7 only entries *)
-    val astpat: typed_ast Gram.Entry.e
-    val ast : Coqast.t Gram.Entry.e
-    val astlist : Coqast.t list Gram.Entry.e
-    val ast_eoi : Coqast.t Gram.Entry.e
-    val var : identifier Gram.Entry.e
+    val var : identifier located Gram.Entry.e
   end
 
 module Constr :
@@ -157,17 +173,18 @@ module Tactic :
   sig
     open Rawterm
     val open_constr : open_constr_expr Gram.Entry.e
-    val castedopenconstr : open_constr_expr Gram.Entry.e
+    val casted_open_constr : open_constr_expr Gram.Entry.e
     val constr_with_bindings : constr_expr with_bindings Gram.Entry.e
     val bindings : constr_expr bindings Gram.Entry.e
-(*v7*) val constrarg : (constr_expr,reference) may_eval Gram.Entry.e
-(*v8*) val constr_may_eval : (constr_expr,reference) may_eval Gram.Entry.e
+    val constr_may_eval : (constr_expr,reference) may_eval Gram.Entry.e
     val quantified_hypothesis : quantified_hypothesis Gram.Entry.e
     val int_or_var : int or_var Gram.Entry.e
     val red_expr : raw_red_expr Gram.Entry.e
     val simple_tactic : raw_atomic_tactic_expr Gram.Entry.e
     val simple_intropattern : Genarg.intro_pattern_expr Gram.Entry.e
     val tactic_arg : raw_tactic_arg Gram.Entry.e
+    val tactic_expr : raw_tactic_expr Gram.Entry.e
+    val binder_tactic : raw_tactic_expr Gram.Entry.e
     val tactic : raw_tactic_expr Gram.Entry.e
     val tactic_eoi : raw_tactic_expr Gram.Entry.e
   end
@@ -180,10 +197,20 @@ module Vernac_ :
     val command : vernac_expr Gram.Entry.e
     val syntax : vernac_expr Gram.Entry.e
     val vernac : vernac_expr Gram.Entry.e
+    
+  (* MMode *)
+
+    val proof_instr : Decl_expr.raw_proof_instr Gram.Entry.e
+
+  (*/ MMode *)
+
     val vernac_eoi : vernac_expr Gram.Entry.e
   end
 
-val reset_all_grammars : unit -> unit
+(* Binding entry names to campl4 entries *)
+
+val symbol_of_production : Gramext.g_assoc option -> constr_entry ->
+  bool -> constr_production_entry -> Token.t Gramext.g_symbol
 
 (* Registering/resetting the level of an entry *)
 
@@ -192,3 +219,5 @@ val find_position :
     Gramext.position option * Gramext.g_assoc option * string option
 
 val remove_levels : int -> unit 
+
+val coerce_global_to_id : reference -> identifier
diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml
index ddf008cb..349d5df8 100644
--- a/parsing/ppconstr.ml
+++ b/parsing/ppconstr.ml
@@ -6,44 +6,64 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppconstr.ml,v 1.32.2.2 2004/12/29 10:17:11 herbelin Exp $ *)
+(* $Id: ppconstr.ml 9304 2006-10-28 09:58:16Z herbelin $ *)      
 
 (*i*)
-open Ast
 open Util
 open Pp
 open Nametab
 open Names
 open Nameops
 open Libnames
-open Coqast
 open Ppextend
 open Topconstr
 open Term
 open Pattern
+open Rawterm
+open Constrextern
+open Termops
 (*i*)
 
+let sep_p = fun _ -> str"."
+let sep_v = fun _ -> str"," ++ spc()
+let sep_pp = fun _ -> str":"
+let sep_bar = fun _ -> spc() ++ str"| "
+let pr_tight_coma () = str "," ++ cut ()
+
 let latom = 0
-let lannot = 1
-let lprod = 8 (* not 1 because the scope extends to 8 on the right *)
-let llambda = 8 (* not 1 *)
-let lif = 8 (* not 1 *)
-let lletin = 8 (* not 1 *)
-let lcases = 1
-let larrow = 8
-let lcast = 9
+let lannot = 100
+let lprod = 200
+let llambda = 200
+let lif = 200
+let lletin = 200
+let lfix = 200
+let larrow = 90
+let lcast = 100
+let larg = 9
 let lapp = 10
-let ltop = (8,E)
+let lposint = 0
+let lnegint = 35 (* must be consistent with Notation "- x" *)
+let ltop = (200,E)
+let lproj = 1
+let lsimple = (1,E)
+
+let prec_less child (parent,assoc) =
+  if parent < 0 && child = lprod then true
+  else
+    let parent = abs parent in
+    match assoc with
+      | E -> (<=) child parent
+      | L -> (<) child parent
+      | Prec n -> child<=n
+      | Any -> true
 
-let prec_less child (parent,assoc) = match assoc with
-  | E -> child <= parent
-  | L -> child < parent
-  | Prec n -> child <= n
-  | Any -> true
+let prec_of_prim_token = function
+  | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint
+  | String _ -> latom
 
 let env_assoc_value v env =
   try List.nth env (v-1)
-  with Not_found -> anomaly "Inconsistent environment for pretty-print rule"
+  with Not_found -> anomaly ("Inconsistent environment for pretty-print rule")
 
 let decode_constrlist_value = function
   | CAppExpl (_,_,l) -> l
@@ -54,7 +74,7 @@ let decode_patlist_value = function
   | CPatCstr (_,_,l) -> l
   | _ -> anomaly "Ill-formed list argument of notation"
 
-open Symbols
+open Notation
 
 let rec print_hunk n decode pr env = function
   | UnpMetaVar (e,prec) -> pr (n,prec) (env_assoc_value e env)
@@ -73,315 +93,596 @@ let pr_notation = pr_notation_gen decode_constrlist_value
 let pr_patnotation = pr_notation_gen decode_patlist_value
 
 let pr_delimiters key strm =
-  let left = "'"^key^":" and right = "'" in
-  let lspace =
-    if is_letter (left.[String.length left -1]) then str " " else mt () in
-  let rspace =
-    let c = right.[0] in
-    if is_letter c or is_digit c or c = '\'' then str " " else mt () in
-  str left ++ lspace ++ strm ++ rspace ++ str right
+  strm ++ str ("%"^key)
 
-open Rawterm
+let pr_located pr ((b,e),x) =
+  if Options.do_translate() && (b,e)<>dummy_loc then
+    let (b,e) = unloc (b,e) in
+    comment b ++ pr x ++ comment e
+  else pr x
+
+let pr_com_at n =
+  if Options.do_translate() && n <> 0 then comment n 
+  else mt()
+
+let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
+
+let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
 
-let pr_opt pr = function
+let pr_optc pr = function
   | None -> mt ()
-  | Some x -> spc () ++ pr x
+  | Some x -> pr_sep_com spc pr x
 
-let pr_universe u = str "<univ>"
+let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)"
 
-let pr_sort = function
+let pr_universe = Univ.pr_uni 
+
+let pr_rawsort = function
   | RProp Term.Null -> str "Prop"
   | RProp Term.Pos -> str "Set"
-  | RType u -> str "Type" ++ pr_opt pr_universe u
+  | RType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u)
 
-let pr_explicitation = function
-  | None -> mt ()
-  | Some (_,ExplByPos n) -> int n ++ str "!"
-  | Some (_,ExplByName n) -> anomaly "Argument made explicit by name"
+let pr_id = pr_id
+let pr_name = pr_name
+let pr_qualid = pr_qualid
 
 let pr_expl_args pr (a,expl) =
-  pr_explicitation expl ++ pr (lapp,L) a
+  match expl with
+  | None -> pr (lapp,L) a
+  | Some (_,ExplByPos n) ->
+      anomaly("Explicitation by position not implemented")
+  | Some (_,ExplByName id) -> 
+      str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")"
 
 let pr_opt_type pr = function
   | CHole _ -> mt ()
-  | t -> str ":" ++ pr ltop t
-
-let pr_tight_coma () = str "," ++ cut ()
+  | t -> cut () ++ str ":" ++ pr t
 
-let pr_name = function
-  | Anonymous -> str "_"
-  | Name id -> pr_id id
-
-let pr_located pr (loc,x) = pr x
+let pr_opt_type_spc pr = function
+  | CHole _ -> mt ()
+  | t ->  str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t
+
+let pr_lident (b,_ as loc,id) =
+  if loc <> dummy_loc then
+    let (b,_) = unloc loc in
+    pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id)
+  else pr_id id
+
+let pr_lname = function
+    (loc,Name id) -> pr_lident (loc,id)
+  | lna -> pr_located pr_name lna
+
+let pr_or_var pr = function
+  | ArgArg x -> pr x
+  | ArgVar (loc,s) -> pr_lident (loc,s)
+
+let pr_prim_token = function
+  | Numeral n -> Bigint.pr_bigint n
+  | String s -> qs s
+
+let las = lapp
+let lpator = 100
+
+let rec pr_patt sep inh p =
+  let (strm,prec) = match p with
+  | CPatAlias (_,p,id) ->
+      pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
+  | CPatCstr (_,c,[]) -> pr_reference c, latom
+  | CPatCstr (_,c,args) ->
+      pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
+  | CPatAtom (_,None) -> str "_", latom
+  | CPatAtom (_,Some r) -> pr_reference r, latom
+  | CPatOr (_,pl) ->
+      hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator
+  | CPatNotation (_,"( _ )",[p]) ->
+      pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom
+  | CPatNotation (_,s,env) -> pr_patnotation (pr_patt mt) s env
+  | CPatPrim (_,p) -> pr_prim_token p, latom
+  | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1
+  in
+  let loc = cases_pattern_expr_loc p in
+  pr_with_comments loc
+    (sep() ++ if prec_less prec inh then strm else surround strm)
+
+let pr_patt = pr_patt mt
+
+let pr_eqn pr (loc,pl,rhs) =
+  spc() ++ hov 4
+    (pr_with_comments loc
+      (str "| " ++
+      hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl 
+             ++ str " =>") ++
+      pr_sep_com spc (pr ltop) rhs))
+
+let begin_of_binder = function
+    LocalRawDef((loc,_),_) -> fst (unloc loc)
+  | LocalRawAssum((loc,_)::_,_) -> fst (unloc loc)
+  | _ -> assert false
+
+let begin_of_binders = function
+  | b::_ -> begin_of_binder b
+  | _ -> 0
+
+let pr_binder many pr (nal,t) =
+  match t with
+  | CHole _ -> prlist_with_sep spc pr_lname nal
+  | _ ->
+    let s = prlist_with_sep spc pr_lname nal ++ str" : " ++ pr t in
+    hov 1 (if many then surround s else s)
+
+let pr_binder_among_many pr_c = function
+  | LocalRawAssum (nal,t) ->
+      pr_binder true pr_c (nal,t)
+  | LocalRawDef (na,c) ->
+      let c,topt = match c with
+        | CCast(_,c,_,t) -> c, t
+        | _ -> c, CHole dummy_loc in
+      hov 1 (surround
+        (pr_lname na ++ pr_opt_type pr_c topt ++
+         str":=" ++ cut() ++ pr_c c))
+
+let pr_undelimited_binders pr_c =
+  prlist_with_sep spc (pr_binder_among_many pr_c)
+
+let pr_delimited_binders kw pr_c bl =
+  let n = begin_of_binders bl in
+  match bl with
+  | [LocalRawAssum (nal,t)] ->
+      pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,t)
+  | LocalRawAssum _ :: _ as bdl ->
+      pr_com_at n ++ kw() ++ pr_undelimited_binders pr_c bdl
+  | _ -> assert false
 
 let pr_let_binder pr x a =
-  hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++ brk(0,1) ++ pr ltop a)
-
-let pr_binder pr (nal,t) =
-  hov 0 (
-    prlist_with_sep pr_tight_coma (pr_located pr_name) nal ++
-    pr_opt_type pr t)
-
-let pr_binders pr bl =
-  hv 0 (prlist_with_sep pr_semicolon (pr_binder pr) bl)
-
-let pr_local_binder pr = function
-    LocalRawAssum(nal,t) -> pr_binder pr (nal,t)
-  | LocalRawDef((_,na),t) -> pr_let_binder pr na t
-
-let pr_local_binders pr bl =
-  hv 0 (prlist_with_sep pr_semicolon (pr_local_binder pr) bl)
-
-let pr_global vars ref = pr_global_env vars ref
-
-let rec pr_lambda_tail pr bll = function
-  | CLambdaN (_,bl,a) ->
-      pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_binders pr bl) a
-  | CLetIn (_,x,a,b) ->
-      pr_lambda_tail pr (bll ++ pr_semicolon() ++ pr_let_binder pr (snd x) a) b
-  | a ->
-      bll, pr ltop a
-
-let rec pr_prod_tail pr bll = function
-  | CProdN (_,bl,a) ->
-      pr_prod_tail pr (bll ++ pr_semicolon () ++ pr_binders pr bl) a
-  | a -> bll, pr ltop a
-
-let pr_recursive_decl pr id binders t c =
-  pr_id id ++ binders ++
-  brk (1,2) ++ str ": " ++ pr ltop t ++ str " :=" ++
-  brk (1,2) ++ pr ltop c
-
+  hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++
+         pr_sep_com (fun () -> brk(0,1)) (pr ltop) a)
+
+let rec extract_prod_binders = function
+(*  | CLetIn (loc,na,b,c) as x ->
+      let bl,c = extract_prod_binders c in
+      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
+  | CProdN (loc,[],c) ->
+      extract_prod_binders c
+  | CProdN (loc,(nal,t)::bl,c) ->
+      let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in
+      LocalRawAssum (nal,t) :: bl, c
+  | c -> [], c
+
+let rec extract_lam_binders = function
+(*  | CLetIn (loc,na,b,c) as x ->
+      let bl,c = extract_lam_binders c in
+      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
+  | CLambdaN (loc,[],c) ->
+      extract_lam_binders c
+  | CLambdaN (loc,(nal,t)::bl,c) ->
+      let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
+      LocalRawAssum (nal,t) :: bl, c
+  | c -> [], c
+    
 let split_lambda = function
   | CLambdaN (loc,[[na],t],c) -> (na,t,c)
   | CLambdaN (loc,([na],t)::bl,c) -> (na,t,CLambdaN(loc,bl,c))
   | CLambdaN (loc,(na::nal,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,t)::bl,c))
   | _ -> anomaly "ill-formed fixpoint body"
 
-let split_product = function
-  | CArrow (loc,t,c) -> ((loc,Anonymous),t,c)
-  | CProdN (loc,[[na],t],c) -> (na,t,c)
-  | CProdN (loc,([na],t)::bl,c) -> (na,t,CProdN(loc,bl,c))
-  | CProdN (loc,(na::nal,t)::bl,c) -> (na,t,CProdN(loc,(nal,t)::bl,c))
+let rename na na' t c =
+  match (na,na') with
+    | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c)
+    | (_,Name id), (_,Anonymous) -> (na,t,c)
+    | _ -> (na',t,c)
+  
+let split_product na' = function
+  | CArrow (loc,t,c) -> (na',t,c)
+  | CProdN (loc,[[na],t],c) -> rename na na' t c
+  | CProdN (loc,([na],t)::bl,c) -> rename na na' t (CProdN(loc,bl,c))
+  | CProdN (loc,(na::nal,t)::bl,c) ->
+      rename na na' t (CProdN(loc,(nal,t)::bl,c))
   | _ -> anomaly "ill-formed fixpoint body"
 
-let concat_binder na t = function
-  | [] -> [[na],t]
-  | (nal,u)::bl' as bl -> if t=u then (na::nal,t)::bl' else ([na],t)::bl
+let merge_binders (na1,ty1) cofun (na2,ty2) codom =
+  let na =
+    match snd na1, snd na2 with
+        Anonymous, Name id ->
+          if occur_var_constr_expr id cofun then
+            failwith "avoid capture"
+          else na2
+      | Name id, Anonymous ->
+          if occur_var_constr_expr id codom then
+            failwith "avoid capture"
+          else na1
+      | Anonymous, Anonymous -> na1
+      | Name id1, Name id2 ->
+          if id1 <> id2 then failwith "not same name" else na1 in
+  let ty =
+    match ty1, ty2 with
+        CHole _, _ -> ty2
+      | _, CHole _ -> ty1
+      | _ ->
+          Constrextern.check_same_type ty1 ty2;
+          ty2 in
+  (LocalRawAssum ([na],ty), codom)
+            
+let rec strip_domain bvar cofun c =
+  match c with
+    | CArrow(loc,a,b) ->
+        merge_binders bvar cofun ((dummy_loc,Anonymous),a) b
+    | CProdN(loc,[([na],ty)],c') ->
+        merge_binders bvar cofun (na,ty) c'
+    | CProdN(loc,([na],ty)::bl,c') ->
+        merge_binders bvar cofun (na,ty) (CProdN(loc,bl,c'))
+    | CProdN(loc,(na::nal,ty)::bl,c') ->
+        merge_binders bvar cofun (na,ty) (CProdN(loc,(nal,ty)::bl,c'))
+    | _ -> failwith "not a product"
+
+(* Note: binder sharing is lost *)
+let rec strip_domains (nal,ty) cofun c =
+  match nal with
+      [] -> assert false
+    | [na] ->
+        let bnd, c' = strip_domain (na,ty) cofun c in
+        ([bnd],None,c')
+    | na::nal ->
+        let f = CLambdaN(dummy_loc,[(nal,ty)],cofun) in
+        let bnd, c1 = strip_domain (na,ty) f c in
+        (try
+          let bl, rest, c2 = strip_domains (nal,ty) cofun c1 in
+          (bnd::bl, rest, c2)
+        with Failure _ -> ([bnd],Some (nal,ty), c1))
+
+(* Re-share binders *)
+let rec factorize_binders = function
+  | ([] | [_] as l) -> l
+  | LocalRawAssum (nal,ty) as d :: (LocalRawAssum (nal',ty')::l as l') ->
+      (try
+	let _ = Constrextern.check_same_type ty ty' in
+	factorize_binders (LocalRawAssum (nal@nal',ty)::l)
+      with _ ->
+	d :: factorize_binders l')
+  | d :: l -> d :: factorize_binders l
+
+(* Extract lambdas when a type constraint occurs *)
+let rec extract_def_binders c ty =
+  match c with
+    | CLambdaN(loc,bvar::lams,b) ->
+        (try
+          let f = CLambdaN(loc,lams,b) in
+          let bvar', rest, ty' = strip_domains bvar f ty in
+          let c' =
+            match rest, lams with
+                None,[] -> b
+              | None, _ -> f
+              | Some bvar,_ -> CLambdaN(loc,bvar::lams,b) in
+          let (bl,c2,ty2) = extract_def_binders c' ty' in
+          (factorize_binders (bvar'@bl), c2, ty2)
+        with Failure _ ->
+          ([],c,ty))
+    | _ -> ([],c,ty)
 
 let rec split_fix n typ def =
   if n = 0 then ([],typ,def)
   else
     let (na,_,def) = split_lambda def in
-    let (_,t,typ) = split_product typ in
+    let (na,t,typ) = split_product na typ in
     let (bl,typ,def) = split_fix (n-1) typ def in
-    (concat_binder na t bl,typ,def)
-
-let pr_fixdecl pr (id,n,bl,t,c) =
-  pr_recursive_decl pr id 
-    (brk (1,2) ++ str "[" ++ pr_local_binders pr bl ++ str "]") t c
+    (LocalRawAssum ([na],t)::bl,typ,def)
+
+let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
+  let pr_body =
+    if dangling_with_for then pr_dangling else pr in
+  pr_id id ++ str" " ++
+  hov 0 (pr_undelimited_binders (pr ltop) bl ++ annot) ++
+  pr_opt_type_spc pr t ++ str " :=" ++
+  pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
+
+let pr_fixdecl pr prd dangling_with_for (id,(n,ro),bl,t,c) =
+  let annot =
+    let ids = names_of_local_assums bl in
+      match ro with
+	  CStructRec ->
+	    if List.length ids > 1 && n <> None then 
+	      spc() ++ str "{struct " ++ pr_name (snd (List.nth ids (out_some n))) ++ str"}"
+	    else mt() 
+	| CWfRec c ->
+	    spc () ++ str "{wf " ++ pr lsimple c ++ pr_name (snd (List.nth ids (out_some n))) ++ str"}"
+	| CMeasureRec c ->
+	    spc () ++ str "{measure " ++ pr lsimple c ++ pr_name (snd (List.nth ids (out_some n))) ++ str"}"
+  in
+    pr_recursive_decl pr prd dangling_with_for id bl annot t c
 
-let pr_cofixdecl pr (id,bl,t,c) =
-  let  b =
-    if bl=[] then mt() else
-      brk(1,2) ++ str"[" ++ pr_local_binders pr bl ++ str "]" in
-  pr_recursive_decl pr id b t c
+let pr_cofixdecl pr prd dangling_with_for (id,bl,t,c) =
+  pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c
 
-let pr_recursive fix pr_decl id = function
+let pr_recursive pr_decl id = function
   | [] -> anomaly "(co)fixpoint with no definition"
-  | d1::dl ->
-      hov 0 (
-	str fix ++ spc () ++ pr_id id ++ brk (1,2) ++ str "{" ++
-	(v 0 (
-	  (hov 0 (pr_decl d1)) ++
-	  (prlist (fun fix -> fnl () ++ hov 0 (str "with" ++ pr_decl fix))
-	    dl))) ++
-	str "}")
+  | [d1] -> pr_decl false d1
+  | dl ->
+      prlist_with_sep (fun () -> fnl() ++ str "with ")
+        (pr_decl true) dl ++
+      fnl() ++ str "for " ++ pr_id id
+
+let is_var id = function
+  | CRef (Ident (_,id')) when id=id' -> true
+  | _ -> false
+
+let tm_clash = function
+  | (CRef (Ident (_,id)), Some (CApp (_,_,nal))) 
+      when List.exists (function CRef (Ident (_,id')),_ -> id=id' | _ -> false)
+	nal
+      -> Some id
+  | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal))) 
+      when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false)
+	nal
+      -> Some id
+  | _ -> None
+
+let pr_case_item pr (tm,(na,indnalopt)) =
+  hov 0 (pr (lcast,E) tm ++
+(*
+  (match na with
+    | Name id when not (is_var id tm) -> spc () ++ str "as " ++  pr_id id
+    | Anonymous when tm_clash (tm,indnalopt) <> None ->
+	(* hide [tm] name to avoid conflicts *)
+	spc () ++ str "as _" (* ++ pr_id (out_some (tm_clash (tm,indnalopt)))*)
+    | _ -> mt ()) ++
+*)
+  (match na with (* Decision of printing "_" or not moved to constrextern.ml *)
+    | Some na -> spc () ++ str "as " ++  pr_name na
+    | None -> mt ()) ++
+  (match indnalopt with
+    | None -> mt ()
+(*
+    | Some (_,ind,nal) ->
+        spc () ++ str "in " ++ 
+        hov 0 (pr_reference ind ++ prlist (pr_arg pr_name) nal))
+*)
+    | Some t -> spc () ++ str "in " ++ pr lsimple t))
 
-let pr_fix pr = pr_recursive "Fix" (pr_fixdecl pr)
-let pr_cofix pr = pr_recursive "CoFix" (pr_cofixdecl pr)
+let pr_case_type pr po =
+  match po with
+    | None | Some (CHole _) -> mt()
+    | Some p ->
+        spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimple) p)
 
-let rec pr_arrow pr = function
-  | CArrow (_,a,b) -> pr (larrow,L) a ++ cut () ++ str "->" ++ pr_arrow pr b
-  | a -> pr (larrow,E) a
+let pr_return_type pr po = pr_case_type pr po
 
-let pr_annotation pr = function
-  | None -> mt ()
-  | Some t -> str "<" ++ pr ltop t ++ str ">" ++ brk (0,2)
-
-let rec pr_cases_pattern _inh = function
-  | CPatAlias (_,p,x) ->
-      pr_cases_pattern _inh p ++ spc () ++ str "as" ++ spc () ++ pr_id x
-  | CPatCstr (_,c,[]) -> pr_reference c
-  | CPatCstr (_,c,pl) ->
-      hov 0 (
-	str "(" ++ pr_reference c ++ spc () ++ 
-	prlist_with_sep spc (pr_cases_pattern _inh) pl ++ str ")")
-  | CPatAtom (_,Some c) -> pr_reference c
-  | CPatAtom (_,None) -> str "_"
-  | CPatNotation (_,"( _ )",[p]) ->
-      str"("++ pr_cases_pattern _inh p ++ str")"
-  | CPatNotation (_,s,env) -> fst (pr_patnotation pr_cases_pattern s env)
-  | CPatNumeral (_,n) -> Bignat.pr_bigint n
-  | CPatDelimiters (_,key,p) -> pr_delimiters key (pr_cases_pattern _inh p)
-
-let pr_cases_pattern = pr_cases_pattern (0,E) (* level unused *)
-
-let pr_eqn pr (_,patl,rhs) =
-  hov 0 (
-    prlist_with_sep spc pr_cases_pattern patl ++ spc () ++
-    str "=>" ++
-    brk (1,1) ++ pr ltop rhs) ++ spc ()
-
-let pr_cases pr (po,_) tml eqns =
-  hov 0 (
-    pr_annotation pr po ++
-    hv 0 (
-      hv 0 (
-	str "Cases" ++ brk (1,2) ++
-	prlist_with_sep spc (fun (tm,_) -> pr ltop tm) tml ++ spc() ++ str "of") ++ brk(1,2) ++
-      prlist_with_sep (fun () -> str "| ") (pr_eqn pr) eqns ++
-      str "end"))
+let pr_simple_return_type pr na po =
+  (match na with
+    | Some (Name id) ->
+        spc () ++ str "as " ++  pr_id id
+    | _ -> mt ()) ++
+  pr_case_type pr po
 
 let pr_proj pr pr_app a f l =
-  hov 0 (pr (latom,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
+  hov 0 (pr lsimple a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
 
-let pr_explapp pr f l =
-  hov 0 (
-    str "!" ++ pr_reference f ++ 
-    prlist (fun a -> brk (1,1) ++ pr (lapp,L) a) l)
+let pr_appexpl pr f l =
+      hov 2 (
+	str "@" ++ pr_reference f ++
+	prlist (pr_sep_com spc (pr (lapp,L))) l)
 
 let pr_app pr a l =
-  hov 0 (
-    pr (lapp,L) a ++ 
-    prlist (fun a -> brk (1,1) ++ pr_expl_args pr a) l)
+  hov 2 (
+    pr (lapp,L) a  ++ 
+    prlist (fun a -> spc () ++ pr_expl_args pr a) l)
 
-let rec pr inherited a =
+let rec pr sep inherited a =
   let (strm,prec) = match a with
   | CRef r -> pr_reference r, latom
-  | CFix (_,id,fix) -> pr_fix pr (snd id) fix, latom
-  | CCoFix (_,id,cofix) -> pr_cofix pr (snd id) cofix, latom
-  | CArrow _ -> hv 0 (pr_arrow pr a), larrow
-  | CProdN (_,bl,a) ->
-      let bll, a = pr_prod_tail pr (mt()) a in
-      hv 1 (
-	hv 1 (str "(" ++ pr_binders pr bl ++ bll ++ str ")") ++
-	brk (0,1) ++ a), lprod
-  | CLambdaN (_,bl,a) ->
-      let bll, a = pr_lambda_tail pr (mt()) a in
-      hv 1 (
-	hv 1 (str "[" ++ pr_binders pr bl ++ bll ++ str "]") ++
-      brk (0,1) ++ a), llambda
-  | CLetIn (_,x,a,b) ->
-      let bll, b = pr_lambda_tail pr (mt()) b in
-      hv 1 (
-	hv 1 (str "[" ++ pr_let_binder pr (snd x) a ++ bll ++ str "]") ++
-	brk (0,1) ++ b), lletin
-  | CAppExpl (_,((* V7 don't know about projections *)_,f),l) ->
-      pr_explapp pr f l, lapp
-  | CApp (_,(_,a),l) ->
-      pr_app pr a l, lapp
-  | CCases (_,po,tml,eqns) ->
-      pr_cases pr po tml eqns, lcases
-  | COrderedCase (_,IfStyle,po,c,[b1;b2]) ->
-      (* On force les parenthèses autour d'un "if" sous-terme (même si le
-	 parsing est lui plus tolérant) *)
+  | CFix (_,id,fix) ->
+      hov 0 (str"fix " ++
+             pr_recursive
+               (pr_fixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) fix),
+      lfix
+  | CCoFix (_,id,cofix) ->
+      hov 0 (str "cofix " ++
+             pr_recursive
+              (pr_cofixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) cofix),
+      lfix
+  | CArrow (_,a,b) ->
+      hov 0 (pr mt (larrow,L) a ++ str " ->" ++
+             pr (fun () ->brk(1,0)) (-larrow,E) b),
+      larrow
+  | CProdN _ ->
+      let (bl,a) = extract_prod_binders a in
       hov 0 (
-	pr_annotation pr po ++
-	hv 0 (
-	  str "if " ++ pr ltop c ++ spc () ++
-	  hov 0 (str "then" ++ brk (1,1) ++ pr ltop b1) ++ spc () ++
-	  hov 0 (str "else" ++ brk (1,1) ++ pr ltop b2))), lif
-  | CLetTuple _ | CIf _ ->
-      error "Let tuple not supported in v7"
-
-  | COrderedCase (_,(MatchStyle|RegularStyle as style),po,c,bl) ->
+	hov 2 (pr_delimited_binders (fun () -> str"forall" ++ spc())
+                 (pr mt ltop) bl) ++
+        str "," ++ pr spc ltop a),
+      lprod
+  | CLambdaN _ ->
+      let (bl,a) = extract_lam_binders a in
       hov 0 (
-	hov 0 (
-	pr_annotation pr po ++
+        hov 2 (pr_delimited_binders (fun () -> str"fun" ++ spc())
+                 (pr mt ltop) bl) ++
+
+        str " =>" ++ pr spc ltop a),
+      llambda
+  | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b)
+      when x=x' ->
+      hv 0 (
+        hov 2 (str "let " ++ pr mt ltop fx ++ str " in") ++
+        pr spc ltop b),
+      lletin
+  | CLetIn (_,x,a,b) ->
+      hv 0 (
+        hov 2 (str "let " ++ pr_lname x ++ str " :=" ++
+               pr spc ltop a ++ str " in") ++
+        pr spc ltop b),
+      lletin
+  | CAppExpl (_,(Some i,f),l) ->
+      let l1,l2 = list_chop i l in
+      let c,l1 = list_sep_last l1 in
+      let p = pr_proj (pr mt) pr_appexpl c f l1 in
+      if l2<>[] then
+	p ++ prlist (pr spc (lapp,L)) l2, lapp
+      else
+	p, lproj
+  | CAppExpl (_,(None,Ident (_,var)),[t])
+  | CApp (_,(_,CRef(Ident(_,var))),[t,None])
+        when var = Topconstr.ldots_var ->
+      hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg
+  | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp
+  | CApp (_,(Some i,f),l) ->
+      let l1,l2 = list_chop i l in
+      let c,l1 = list_sep_last l1 in
+      assert (snd c = None);
+      let p = pr_proj (pr mt) pr_app (fst c) f l1 in
+      if l2<>[] then 
+	p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp
+      else
+	p, lproj
+  | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp
+  | CCases (_,rtntypopt,c,eqns) ->
+      v 0
+        (hv 0 (str "match" ++ brk (1,2) ++
 	  hov 0 (
-	    str (if style=RegularStyle then "Case" else "Match") ++ 
-	    brk (1,1) ++ pr ltop c ++ spc () ++
-	    str (if style=RegularStyle then "of" else "with") ++
-	    brk (1,3) ++
-	    fnl () ++ hov 0 (prlist (fun b -> pr ltop b ++ fnl ()) bl) ++
-	    str "end"))), lcases
-  | COrderedCase (_,_,_,_,_) -> 
-      anomaly "malformed if or destructuring let"
-  | CHole _ -> str "?", latom
-(*
-  | CEvar (_,n) -> str "?" ++ int n, latom
-*)
+	    prlist_with_sep sep_v
+              (pr_case_item (pr_dangling_with_for mt)) c
+            ++ pr_case_type (pr_dangling_with_for mt) rtntypopt) ++
+	spc () ++ str "with") ++
+        prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"),
+      latom
+  | CLetTuple (_,nal,(na,po),c,b) ->
+      hv 0 (
+        str "let " ++
+	hov 0 (str "(" ++
+               prlist_with_sep sep_v pr_name nal ++
+               str ")" ++
+	       pr_simple_return_type (pr mt) na po ++ str " :=" ++
+               pr spc ltop c ++ str " in") ++
+        pr spc ltop b),
+      lletin
+  | CIf (_,c,(na,po),b1,b2) ->
+      (* On force les parenthèses autour d'un "if" sous-terme (même si le
+	 parsing est lui plus tolérant) *)
+      hv 0 (
+	hov 1 (str "if " ++ pr mt ltop c ++ pr_simple_return_type (pr mt) na po) ++
+	spc () ++
+	hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++
+	hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)),
+      lif
+     
+  | CHole _ -> str "_", latom
   | CEvar (_,n) -> str (Evd.string_of_existential n), latom
   | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom
-  | CSort (_,s) -> pr_sort s, latom
-  | CCast (_,a,b) ->
-      hv 0 (pr (lcast,L) a ++ cut () ++ str "::" ++ pr (lcast,E) b), lcast
+  | CSort (_,s) -> pr_rawsort s, latom
+  | CCast (_,a,k,b) ->
+      let s = match k with CastConv  VMcast -> "<:" | _ -> ":" in
+      hv 0 (pr mt (lcast,L) a ++ cut () ++ str s ++ pr mt (-lcast,E) b),
+      lcast
   | CNotation (_,"( _ )",[t]) ->
-      str"("++ pr (max_int,E) t ++ str")", latom
-  | CNotation (_,s,env) -> pr_notation pr s env
-  | CNumeral (_,p) -> Bignat.pr_bigint p, latom
-  | CDelimiters (_,sc,a) -> pr_delimiters sc (pr ltop a), latom
+      pr (fun()->str"(") (max_int,L) t ++ str")", latom
+  | CNotation (_,s,env) -> pr_notation (pr mt) s env
+  | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p
+  | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1
   | CDynamic _ -> str "<dynamic>", latom
   in
-  if prec_less prec inherited then strm
-  else str"(" ++ strm ++ str")"
-  
-let pr_constr = pr ltop
-
-let pr_pattern = pr_constr
-
-let pr_qualid qid = str (string_of_qualid qid)
-
-open Rawterm
-
-let pr_arg pr x = spc () ++ pr x
+  let loc = constr_loc a in
+  pr_with_comments loc
+    (sep() ++ if prec_less prec inherited then strm else surround strm)
+
+and pr_dangling_with_for sep inherited a =
+  match a with
+  | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a
+  | _ -> pr sep inherited a
+
+let pr = pr mt
+
+let rec strip_context n iscast t =
+  if n = 0 then
+    [], if iscast then match t with CCast (_,c,_,_) -> c | _ -> t else t
+  else match t with
+    | CLambdaN (loc,(nal,t)::bll,c) ->
+	let n' = List.length nal in
+	if n' > n then
+	  let nal1,nal2 = list_chop n nal in
+	  [LocalRawAssum (nal1,t)], CLambdaN (loc,(nal2,t)::bll,c)
+	else
+	let bl', c = strip_context (n-n') iscast
+	  (if bll=[] then c else CLambdaN (loc,bll,c)) in
+	LocalRawAssum (nal,t) :: bl', c 
+    | CProdN (loc,(nal,t)::bll,c) ->
+	let n' = List.length nal in
+	if n' > n then
+	  let nal1,nal2 = list_chop n nal in
+	  [LocalRawAssum (nal1,t)], CProdN (loc,(nal2,t)::bll,c)
+	else
+	let bl', c = strip_context (n-n') iscast
+	  (if bll=[] then c else CProdN (loc,bll,c)) in
+	LocalRawAssum (nal,t) :: bl', c 
+    | CArrow (loc,t,c) ->
+	let bl', c = strip_context (n-1) iscast c in
+	LocalRawAssum ([loc,Anonymous],t) :: bl', c 
+    | CCast (_,c,_,_) -> strip_context n false c
+    | CLetIn (_,na,b,c) -> 
+	let bl', c = strip_context (n-1) iscast c in
+	LocalRawDef (na,b) :: bl', c
+    | _ -> anomaly "strip_context"
+
+let pr_constr_expr c = pr lsimple c
+let pr_lconstr_expr c = pr ltop c
+let pr_pattern_expr c = pr lsimple c
+let pr_lpattern_expr c = pr ltop c
+
+let pr_cases_pattern_expr = pr_patt ltop
+
+let pr_binders = pr_undelimited_binders (pr ltop)
+
+let pr_with_occurrences pr = function
+    ([],c) -> pr c
+  | (nl,c) -> hov 1 (pr c ++ spc() ++ str"at " ++
+                     hov 0 (prlist_with_sep spc (pr_or_var int) nl))
 
 let pr_red_flag pr r =
-  (if r.rBeta then pr_arg str "Beta" else mt ()) ++
-  (if r.rIota then pr_arg str "Iota" else mt ()) ++
-  (if r.rZeta then pr_arg str "Zeta" else mt ()) ++
+  (if r.rBeta then pr_arg str "beta" else mt ()) ++
+  (if r.rIota then pr_arg str "iota" else mt ()) ++
+  (if r.rZeta then pr_arg str "zeta" else mt ()) ++
   (if r.rConst = [] then
-     if r.rDelta then pr_arg str "Delta"
+     if r.rDelta then pr_arg str "delta"
      else mt ()
    else
-     pr_arg str "Delta" ++ (if r.rDelta then str "-" else mt ()) ++
+     pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++
      hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]"))
 
 open Genarg
 
-let pr_occurrences prc (nl,c) = prlist (fun n -> int n ++ spc ()) nl ++ prc c
+let pr_metaid id = str"?" ++ pr_id id
 
-let pr_red_expr (pr_constr,pr_ref) = function
-  | Red false -> str "Red"
-  | Hnf -> str "Hnf"
-  | Simpl o -> str "Simpl" ++ pr_opt (pr_occurrences pr_constr) o
+let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function
+  | Red false -> str "red"
+  | Hnf -> str "hnf"
+  | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_constr) o  
   | Cbv f ->
       if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then
-	str "Compute"
+	str "compute"
       else
-	hov 1 (str "Cbv" ++ spc () ++ pr_red_flag pr_ref f)
+	hov 1 (str "cbv" ++ pr_red_flag pr_ref f)
   | Lazy f -> 
-      hov 1 (str "Lazy" ++ spc () ++ pr_red_flag pr_ref f)
+      hov 1 (str "lazy" ++ pr_red_flag pr_ref f)
   | Unfold l ->
-      hov 1 (str "Unfold" ++
-        prlist (fun (nl,qid) ->
-	  prlist (pr_arg int) nl ++ spc () ++ pr_ref qid) l)
-  | Fold l -> hov 1 (str "Fold" ++ prlist (pr_arg pr_constr) l)
-  | Pattern l -> hov 1 (str "Pattern " ++ prlist (pr_occurrences pr_constr) l)
+      hov 1 (str "unfold" ++ spc() ++
+             prlist_with_sep pr_coma (pr_with_occurrences pr_ref) l)
+  | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l)
+  | Pattern l ->
+      hov 1 (str "pattern" ++
+        pr_arg (prlist_with_sep pr_coma (pr_with_occurrences pr_constr)) l)
+        
   | Red true -> error "Shouldn't be accessible from user"
   | ExtraRedExpr s -> str s
+  | CbvVm -> str "vm_compute"
 
-let rec pr_may_eval pr pr2 = function
+let rec pr_may_eval test prc prlc pr2 = function
   | ConstrEval (r,c) ->
       hov 0
-        (str "Eval" ++ brk (1,1) ++ pr_red_expr (pr,pr2) r ++
-	 spc () ++ str "in" ++ brk (1,1) ++ pr c)
+        (str "eval" ++ brk (1,1) ++
+         pr_red_expr (prc,prlc,pr2) r ++
+	 str " in" ++ spc() ++ prc c)
   | ConstrContext ((_,id),c) ->
       hov 0
-	(str "Inst " ++ brk (1,1) ++ pr_id id ++ spc () ++
-	 str "[" ++ pr c ++ str "]")
-  | ConstrTypeOf c -> hov 0 (str "Check " ++ brk (1,1) ++ pr c)
-  | ConstrTerm c -> pr c
+	(str "context " ++ pr_id id ++ spc () ++
+	 str "[" ++ prlc c ++ str "]")
+  | ConstrTypeOf c -> hov 1 (str "type of" ++ spc() ++ prc c)
+  | ConstrTerm c when test c -> h 0 (str "(" ++ prc c ++ str ")")
+  | ConstrTerm c -> prc c
 
-let pr_rawconstr c = pr_constr (Constrextern.extern_rawconstr Idset.empty c)
+let pr_may_eval a = pr_may_eval (fun _ -> false) a
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
index 039cd745..8f965d9b 100644
--- a/parsing/ppconstr.mli
+++ b/parsing/ppconstr.mli
@@ -1,3 +1,4 @@
+
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -5,8 +6,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-
-(*i $Id: ppconstr.mli,v 1.7.2.2 2005/01/21 17:19:37 herbelin Exp $ i*)
+ 
+(*i $Id: ppconstr.mli 8878 2006-05-30 16:44:25Z herbelin $ i*)
 
 open Pp
 open Environ
@@ -14,28 +15,58 @@ open Term
 open Libnames
 open Pcoq
 open Rawterm
-open Extend
-open Coqast
 open Topconstr
 open Names
 open Util
+open Genarg
+
+val extract_lam_binders :
+  constr_expr -> local_binder list * constr_expr
+val extract_prod_binders :
+  constr_expr -> local_binder list * constr_expr
+val extract_def_binders :
+  constr_expr -> constr_expr ->
+  local_binder list * constr_expr * constr_expr
+val split_fix :
+  int -> constr_expr -> constr_expr -> 
+  local_binder list *  constr_expr * constr_expr
+
+val prec_less : int -> int * Ppextend.parenRelation -> bool
+ 
+val pr_tight_coma : unit -> std_ppcmds
 
-val split_fix : int -> constr_expr -> constr_expr -> 
-  (name located list * constr_expr) list * constr_expr * constr_expr
+val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds
+val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
+val pr_metaid : identifier -> std_ppcmds
 
-val pr_global : Idset.t -> global_reference -> std_ppcmds
+val pr_lident : identifier located -> std_ppcmds
+val pr_lname : name located -> std_ppcmds
 
-val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+val pr_with_comments : loc -> std_ppcmds -> std_ppcmds
+val pr_com_at : int -> std_ppcmds
+val pr_sep_com :
+  (unit -> std_ppcmds) ->
+  (constr_expr -> std_ppcmds) ->
+  constr_expr -> std_ppcmds
+
+val pr_id : identifier -> std_ppcmds
 val pr_name : name -> std_ppcmds
 val pr_qualid : qualid -> std_ppcmds
+
+val pr_with_occurrences :
+  ('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds
 val pr_red_expr :
-  ('a -> std_ppcmds) * ('b -> std_ppcmds) ->
+  ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) ->
     ('a,'b) red_expr_gen -> std_ppcmds
-val pr_occurrences : ('a -> std_ppcmds) -> 'a occurrences -> std_ppcmds
-
-val pr_sort : rawsort -> std_ppcmds
-val pr_pattern : Tacexpr.pattern_expr -> std_ppcmds
-val pr_constr : constr_expr -> std_ppcmds
-val pr_cases_pattern : cases_pattern_expr -> std_ppcmds
-val pr_may_eval : ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('a,'b) may_eval -> std_ppcmds
-val pr_rawconstr : rawconstr -> std_ppcmds
+val pr_may_eval :
+  ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> 
+    ('a,'b) may_eval -> std_ppcmds
+
+val pr_rawsort : rawsort -> std_ppcmds
+
+val pr_binders : local_binder list -> std_ppcmds
+val pr_pattern_expr : Tacexpr.pattern_expr -> std_ppcmds
+val pr_lpattern_expr : Tacexpr.pattern_expr -> std_ppcmds
+val pr_constr_expr : constr_expr -> std_ppcmds
+val pr_lconstr_expr : constr_expr -> std_ppcmds
+val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds
diff --git a/parsing/ppdecl_proof.ml b/parsing/ppdecl_proof.ml
new file mode 100644
index 00000000..bb0662da
--- /dev/null
+++ b/parsing/ppdecl_proof.ml
@@ -0,0 +1,191 @@
+(************************************************************************)
+(*  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$ *)
+
+open Util 
+open Pp
+open Decl_expr
+open Names 
+open Nameops
+
+let pr_constr = Printer.pr_constr_env
+let pr_tac = Pptactic.pr_glob_tactic
+let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr 
+
+let pr_label = function
+    Anonymous -> mt ()
+  | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () 
+
+let pr_justification_items env = function
+    Some [] -> mt ()
+  | Some (_::_ as l) -> 
+      spc () ++ str "by" ++ spc () ++  
+	prlist_with_sep (fun () -> str ",") (pr_constr env) l
+  | None -> spc () ++ str "by *"
+
+let pr_justification_method env = function
+    None -> mt ()
+  | Some tac -> 
+      spc () ++ str "using" ++  pr_tac env tac
+
+let pr_statement pr_it env st = 
+  pr_label st.st_label ++ pr_it env st.st_it
+
+let pr_or_thesis pr_this env = function
+    Thesis Plain -> str "thesis"
+  | Thesis (For id) -> 
+      str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id 
+  | Thesis (Sub n) -> str "thesis[" ++ int n ++ str "]"
+  | This c -> pr_this env c
+
+let pr_cut pr_it env c = 
+  hov 1 (pr_it env c.cut_stat) ++ 
+    pr_justification_items env c.cut_by ++
+    pr_justification_method env c.cut_using
+
+let type_or_thesis = function
+    Thesis _ -> Term.mkProp
+  | This c -> c
+
+let _I x = x
+
+let rec print_hyps pconstr gtyp env sep _be _have hyps = 
+  let pr_sep = if sep then str "and" ++ spc () else mt () in
+    match hyps with 
+	(Hvar _ ::_) as rest -> 
+	  spc () ++ pr_sep ++ str _have ++ 
+	    print_vars pconstr gtyp env false _be _have rest
+      | Hprop st :: rest -> 
+	  begin
+	    let nenv =
+	      match st.st_label with
+		  Anonymous -> env
+		| Name id -> Environ.push_named (id,None,gtyp st.st_it) env in
+	      spc() ++ pr_sep ++ pr_statement pconstr env st ++ 
+		print_hyps pconstr gtyp nenv true _be _have rest
+	  end
+      | [] -> mt ()
+
+and print_vars pconstr gtyp env sep _be _have vars =
+  match vars with
+    Hvar st :: rest -> 
+      begin
+	let nenv = 
+	  match st.st_label with
+	      Anonymous -> anomaly "anonymous variable"
+	    | Name id -> Environ.push_named (id,None,st.st_it) env in
+	let pr_sep = if sep then pr_coma () else mt () in
+		spc() ++ pr_sep ++
+		   pr_statement pr_constr env st ++
+		  print_vars pconstr gtyp nenv true _be _have rest
+      end
+   | (Hprop _ :: _) as rest ->
+      let _st =  if _be then 
+	str "be such that" 
+      else 
+	str "such that" in
+	spc() ++ _st ++  print_hyps pconstr gtyp env false _be _have rest
+  | [] -> mt ()
+
+let pr_suffices_clause env (hyps,c) = 
+    print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++
+       str "to show" ++ spc () ++ pr_or_thesis pr_constr env c
+
+let pr_elim_type = function
+    ET_Case_analysis -> str "cases"
+  | ET_Induction -> str "induction"
+
+let pr_casee env =function
+    Real c -> str "on" ++ spc () ++ pr_constr env c
+  | Virtual cut -> str "of" ++ spc () ++ pr_cut (pr_statement pr_constr) env cut
+
+let pr_side = function
+    Lhs -> str "=~"
+  | Rhs -> str "~="
+
+let rec pr_bare_proof_instr _then _thus env = function
+  | Pescape -> str "escape"
+  | Pthen i -> pr_bare_proof_instr true _thus env i 
+  | Pthus i -> pr_bare_proof_instr _then true env i 
+  | Phence i -> pr_bare_proof_instr true true env i
+  | Pcut c -> 
+      begin
+	match _then,_thus with
+	    false,false -> str "have" ++ spc () ++ 
+	      pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
+	  | false,true  -> str "thus" ++ spc () ++ 
+	      pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
+	  | true,false  -> str "then" ++ spc () ++
+	      pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
+	  | true,true   -> str "hence" ++ spc () ++ 
+	      pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
+      end
+  | Psuffices c ->
+      str "suffices" ++  pr_cut pr_suffices_clause env c 
+  | Prew (sid,c) ->
+      (if _thus then str "thus" else str "    ") ++ spc () ++
+	pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c
+  | Passume hyps -> 
+      str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps
+  | Plet hyps -> 
+      str "let" ++ print_vars pr_constr _I env false true "let" hyps
+  | Pclaim st ->
+      str "claim" ++ spc () ++ pr_statement pr_constr env st
+  | Pfocus st ->
+      str "focus on" ++ spc () ++ pr_statement pr_constr env st
+  | Pconsider (id,hyps) ->
+      str "consider" ++ print_vars pr_constr _I env false false "consider" hyps 
+      ++ spc () ++ str "from " ++ pr_constr env id 
+  | Pgiven hyps ->
+      str "given" ++ print_vars pr_constr _I env false false "given" hyps
+  | Ptake witl -> 
+      str "take" ++ spc () ++ 
+	prlist_with_sep pr_coma (pr_constr env) witl
+  | Pdefine (id,args,body) ->
+      str "define" ++ spc () ++ pr_id id ++ spc () ++ 
+	prlist_with_sep spc 
+	(fun st -> str "(" ++ 
+	   pr_statement pr_constr env st ++ str ")") args ++ spc () ++ 
+	str "as" ++ (pr_constr env body) 
+  | Pcast (id,typ) -> 
+      str "reconsider" ++ spc () ++ 
+	pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ 
+	str "as" ++ (pr_constr env typ)  
+  | Psuppose hyps -> 
+      str "suppose" ++ 
+	print_hyps pr_constr _I env false false "we have" hyps
+  | Pcase (params,pat,hyps) ->
+      str "suppose it is" ++ spc () ++ pr_pat pat ++
+	(if params = [] then mt () else 
+	   (spc () ++ str "with" ++ spc () ++ 
+	      prlist_with_sep spc 
+	      (fun st -> str "(" ++ 
+		 pr_statement pr_constr env st ++ str ")") params ++ spc ())) 
+      ++
+	(if hyps = [] then mt () else 
+	   (spc () ++ str "and" ++ 
+	      print_hyps (pr_or_thesis pr_constr) type_or_thesis
+	      env false false "we have" hyps))
+  | Pper (et,c) -> 
+      str "per" ++ spc () ++ pr_elim_type et ++ spc () ++
+      pr_casee env c
+  | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et
+  | _ -> anomaly "unprintable instruction"
+
+let pr_emph = function
+    0 -> str "    "
+  | 1 -> str "*   "
+  | 2 -> str "**  "
+  | 3 -> str "*** "
+  | _ -> anomaly "unknown emphasis"
+
+let pr_proof_instr env instr = 
+  pr_emph instr.emph ++ spc () ++ 
+    pr_bare_proof_instr false false env instr.instr
+
diff --git a/parsing/ppdecl_proof.mli b/parsing/ppdecl_proof.mli
new file mode 100644
index 00000000..b0f0e110
--- /dev/null
+++ b/parsing/ppdecl_proof.mli
@@ -0,0 +1,2 @@
+
+val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds  
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
index 4103ea00..c68a2d6f 100644
--- a/parsing/pptactic.ml
+++ b/parsing/pptactic.ml
@@ -6,69 +6,64 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pptactic.ml,v 1.54.2.5 2005/12/23 22:16:46 herbelin Exp $ *)
+(* $Id: pptactic.ml 9551 2007-01-29 15:13:35Z bgregoir $ *)
 
 open Pp
 open Names
 open Nameops
 open Util
-open Extend
 open Tacexpr
 open Rawterm
 open Topconstr
 open Genarg
 open Libnames
 open Pattern
+open Ppextend
+open Ppconstr
+open Printer
 
-let pr_red_expr = Ppconstr.pr_red_expr
-let pr_may_eval = Ppconstr.pr_may_eval
-let pr_sort = Ppconstr.pr_sort
-let pr_global x =
-  if Options.do_translate () then (* for pr_gen *)
-    Ppconstrnew.pr_global Idset.empty x
-  else
-    Ppconstr.pr_global Idset.empty x
-let pr_name = Ppconstr.pr_name
-let pr_opt = Ppconstr.pr_opt
-let pr_occurrences = Ppconstr.pr_occurrences
+let pr_global x = Nametab.pr_global_env Idset.empty x
 
 type grammar_terminals = string option list
 
   (* Extensions *)
-let prtac_tab_v7 = Hashtbl.create 17
 let prtac_tab = Hashtbl.create 17
 
-let declare_extra_tactic_pprule for_v8 s (tags,prods) =
-  Hashtbl.add prtac_tab_v7 (s,tags) prods;
-  if for_v8 then Hashtbl.add prtac_tab (s,tags) prods
+let declare_extra_tactic_pprule (s,tags,prods) =
+  Hashtbl.add prtac_tab (s,tags) prods
 
-let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab_v7 (s,tags)
+let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab (s,tags)
 
 type 'a raw_extra_genarg_printer =
-    (constr_expr -> std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) ->
-      'a -> std_ppcmds
+    (constr_expr -> std_ppcmds) -> 
+    (constr_expr -> std_ppcmds) -> 
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
 type 'a glob_extra_genarg_printer =
-    (rawconstr_and_expr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) ->
-      'a -> std_ppcmds
+    (rawconstr_and_expr -> std_ppcmds) ->
+    (rawconstr_and_expr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
 type 'a extra_genarg_printer =
-    (Term.constr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) ->
-      'a -> std_ppcmds
+    (Term.constr -> std_ppcmds) -> 
+    (Term.constr -> std_ppcmds) -> 
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
 
-let genarg_pprule_v7 = ref Stringmap.empty
 let genarg_pprule = ref Stringmap.empty
 
-let declare_extra_genarg_pprule for_v8 (rawwit, f) (globwit, g) (wit, h) =
+let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) =
   let s = match unquote wit with
     | ExtraArgType s -> s 
     | _ -> error
 	"Can declare a pretty-printing rule only for extra argument types"
   in
-  let f prc prtac x = f prc prtac (out_gen rawwit x) in
-  let g prc prtac x = g prc prtac (out_gen globwit x) in
-  let h prc prtac x = h prc prtac (out_gen wit x) in
-  genarg_pprule_v7 := Stringmap.add s (f,g,h) !genarg_pprule_v7;
-  if for_v8 then
-    genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule 
+  let f prc prlc prtac x = f prc prlc prtac (out_gen rawwit x) in
+  let g prc prlc prtac x = g prc prlc prtac (out_gen globwit x) in
+  let h prc prlc prtac x = h prc prlc prtac (out_gen wit x) in
+  genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule
 
 let pr_arg pr x = spc () ++ pr x
 
@@ -84,14 +79,10 @@ let pr_and_short_name pr (c,_) = pr c
 
 let pr_located pr (loc,x) = pr x
 
-let pr_ltac_constant sp = pr_qualid (Nametab.shortest_qualid_of_tactic sp)
-
 let pr_evaluable_reference = function 
   | EvalVarRef id -> pr_id id
   | EvalConstRef sp -> pr_global (Libnames.ConstRef sp)
 
-let pr_inductive ind = pr_global (Libnames.IndRef ind)
-
 let pr_quantified_hypothesis = function
   | AnonHyp n -> int n
   | NamedHyp id -> pr_id id 
@@ -108,12 +99,7 @@ let pr_bindings prc prlc = function
       prlist_with_sep spc prc l
   | ExplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++ 
-        prlist_with_sep spc
-          (fun b -> if Options.do_translate () or not !Options.v7 then
-	    str"(" ++ pr_binding prlc b ++ str")" 
-	   else
-	    pr_binding prc b)
-        l
+        prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
   | NoBindings -> mt ()
 
 let pr_bindings_no_with prc prlc = function
@@ -122,21 +108,11 @@ let pr_bindings_no_with prc prlc = function
       prlist_with_sep spc prc l
   | ExplicitBindings l ->
       brk (1,1) ++ 
-        prlist_with_sep spc
-          (fun b -> if Options.do_translate () or not !Options.v7 then
-	    str"(" ++ pr_binding prlc b ++ str")" 
-	   else
-	    pr_binding prc b)
-        l
+        prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
   | NoBindings -> mt ()
 
 let pr_with_bindings prc prlc (c,bl) =
-  if Options.do_translate () then
-    (* translator calls pr_with_bindings on rawconstr: we cast it! *)
-    let bl' = Ppconstrnew.translate_with_bindings (fst (Obj.magic c) : rawconstr) bl in
-    prc c ++ hv 0 (pr_bindings prc prlc bl')
-  else
-    prc c ++ hv 0 (pr_bindings prc prlc bl)
+  prc c ++ hv 0 (pr_bindings prc prlc bl)
 
 let pr_with_constr prc = function
   | None -> mt ()
@@ -146,111 +122,14 @@ let pr_with_names = function
   | None -> mt ()
   | Some ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat)
 
-let pr_hyp_location pr_id = function
-  | id, _, (InHyp,_) -> spc () ++ pr_id id
-  | id, _, (InHypTypeOnly,_) ->
-      spc () ++ str "(Type of " ++ pr_id id ++ str ")"
-  | id, _, _ -> error "Unsupported hyp location in v7"
-
-let pr_clause pr_id = function
-  | [] -> mt ()
-  | l -> spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l)
-
-
-let pr_clauses pr_id cls =
-  match cls with
-      { onhyps = Some l; onconcl = false } ->
-        spc () ++ hov 0 (str "in" ++ prlist (pr_hyp_location pr_id) l)
-    | { onhyps = Some []; onconcl = true } -> mt()
-    | _ -> error "this clause has both hypothesis and conclusion"
-
-let pr_simple_clause pr_id = function
-  | [] -> mt ()
-  | l -> spc () ++
-      hov 0 (str "in" ++ spc () ++ prlist_with_sep spc pr_id l)
-
-let pr_clause_pattern pr_id cls =
-  pr_opt
-    (prlist (fun (id,occs,_) ->
-      prlist (pr_arg int) occs ++ spc () ++ pr_id id)) cls.onhyps ++
-  if cls.onconcl then
-    prlist (pr_arg int) cls.concl_occs ++ spc() ++ str"Goal"
-  else mt()
-
-let pr_subterms pr occl =
-  hov 0 (pr_occurrences pr occl ++ spc () ++ str "with")
-
-let pr_induction_arg prc = function
-  | ElimOnConstr c -> prc c
-  | ElimOnIdent (_,id) -> pr_id id
-  | ElimOnAnonHyp n -> int n
-
-let pr_induction_kind = function
-  | SimpleInversion -> str "Simple Inversion"
-  | FullInversion -> str "Inversion"
-  | FullInversionClear -> str "Inversion_clear"
-
-let pr_match_pattern pr_pat = function
-  | Term a -> pr_pat a
-  | Subterm (None,a) -> str "[" ++ pr_pat a ++ str "]"
-  | Subterm (Some id,a) -> pr_id id ++ str "[" ++ pr_pat a ++ str "]"
-
-let pr_match_hyps pr_pat = function
-  | Hyp ((_,na),mp) -> pr_name na ++ str ":" ++ pr_match_pattern pr_pat mp
-
-let pr_match_rule m pr_pat pr = function
-  | Pat ([],mp,t) when m ->
-      str "[" ++ pr_match_pattern pr_pat mp ++ str "]"
-      ++ spc () ++ str "->" ++ brk (1,2) ++ pr t
-  | Pat (rl,mp,t) ->
-      str "[" ++ prlist_with_sep pr_semicolon
-                   (pr_match_hyps pr_pat) rl ++ spc () ++ 
-      str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "]" ++
-      spc () ++ str "->" ++ brk (1,2) ++ pr t
-  | All t -> str "_" ++ spc () ++ str "->" ++ brk (1,2) ++ pr t
-
-let pr_funvar = function
-  | None -> spc () ++ str "()"
-  | Some id -> spc () ++ pr_id id
-
-let pr_let_clause k pr = function
-  | ((_,id),None,t) -> hv 0(str k ++ pr_id id ++ str " =" ++ brk (1,1) ++ pr t)
-  | ((_,id),Some c,t) -> str "TODO(LETCLAUSE)"
-
-let pr_let_clauses pr = function
-  | hd::tl ->
-      hv 0
-        (pr_let_clause "Let " pr hd ++
-         prlist (fun t -> spc () ++ pr_let_clause "And " pr t) tl)
-  | [] -> anomaly "LetIn must declare at least one binding"
-
-let pr_rec_clause pr ((_,id),(l,t)) =
-  pr_id id ++ prlist pr_funvar l ++ str "->" ++ spc () ++ pr t
-
-let pr_rec_clauses pr l = 
-  prlist_with_sep (fun () -> fnl () ++ str "And ") (pr_rec_clause pr) l
-
-let pr_hintbases = function
-  | None -> spc () ++ str "with *"
-  | Some [] -> mt ()
-  | Some l ->
-      spc () ++ str "with" ++ hv 0 (prlist (fun s -> spc () ++ str s) l)
-
-let pr_autoarg_adding = function
-  | [] -> mt ()
-  | l ->
-      spc () ++ str "Adding [" ++
-        hv 0 (prlist_with_sep spc pr_reference l) ++ str "]"
-
-let pr_autoarg_destructing = function
-  | true -> spc () ++ str "Destructing"
-  | false -> mt ()
+let rec pr_message_token prid = function
+  | MsgString s -> qs s
+  | MsgInt n -> int n
+  | MsgIdent id -> prid id
 
-let pr_autoarg_usingTDB = function
-  | true -> spc () ++ str "Using TDB"
-  | false -> mt ()
+let pr_fresh_ids = prlist (fun s -> spc() ++ pr_or_var qs s)
 
-let rec pr_raw_generic prc prlc prtac prref x =
+let rec pr_raw_generic prc prlc prtac prref (x:(Genarg.rlevel, Tacexpr.raw_tactic_expr) Genarg.generic_argument) =
   match Genarg.genarg_tag x with
   | BoolArgType -> pr_arg str (if out_gen rawwit_bool x then "true" else "false")
   | IntArgType -> pr_arg int (out_gen rawwit_int x)
@@ -259,24 +138,18 @@ let rec pr_raw_generic prc prlc prtac prref x =
   | PreIdentArgType -> pr_arg str (out_gen rawwit_pre_ident x)
   | IntroPatternArgType -> pr_arg pr_intro_pattern 
       (out_gen rawwit_intro_pattern x)
-  | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen rawwit_ident x))
-  | HypArgType -> pr_arg
-      (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen rawwit_var x)
+  | IdentArgType -> pr_arg pr_id (out_gen rawwit_ident x)
+  | VarArgType -> pr_arg (pr_located pr_id) (out_gen rawwit_var x)
   | RefArgType -> pr_arg prref (out_gen rawwit_ref x)
-  | SortArgType -> pr_arg pr_sort (out_gen rawwit_sort x)
+  | SortArgType -> pr_arg pr_rawsort (out_gen rawwit_sort x)
   | ConstrArgType -> pr_arg prc (out_gen rawwit_constr x)
   | ConstrMayEvalArgType ->
-      pr_arg (pr_may_eval prc prref)
-        (out_gen rawwit_constr_may_eval x)
+      pr_arg (pr_may_eval prc prlc prref) (out_gen rawwit_constr_may_eval x)
   | QuantHypArgType ->
       pr_arg pr_quantified_hypothesis (out_gen rawwit_quant_hyp x)
   | RedExprArgType ->
-      pr_arg (pr_red_expr 
-        (prc,prref)) (out_gen rawwit_red_expr x)
-  | TacticArgType -> pr_arg prtac (out_gen rawwit_tactic x)
-  | OpenConstrArgType -> pr_arg prc (snd (out_gen rawwit_open_constr x))
-  | CastedOpenConstrArgType ->
-      pr_arg prc (snd (out_gen rawwit_casted_open_constr x))
+      pr_arg (pr_red_expr (prc,prlc,prref)) (out_gen rawwit_red_expr x)
+  | OpenConstrArgType b -> pr_arg prc (snd (out_gen (rawwit_open_constr_gen b) x))
   | ConstrWithBindingsArgType -> 
       pr_arg (pr_with_bindings prc prlc) (out_gen rawwit_constr_with_bindings x)
   | BindingsArgType -> 
@@ -293,10 +166,7 @@ let rec pr_raw_generic prc prlc prtac prref x =
             pr_raw_generic prc prlc prtac prref b)
 	  x)
   | ExtraArgType s -> 
-      let tab =
-	if Options.do_translate() or not !Options.v7 then !genarg_pprule
-        else !genarg_pprule_v7 in
-      try pi1 (Stringmap.find s tab) prc prtac x
+      try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str " [no printer for " ++ str s ++ str "] "
 
 
@@ -309,23 +179,22 @@ let rec pr_glob_generic prc prlc prtac x =
   | PreIdentArgType -> pr_arg str (out_gen globwit_pre_ident x)
   | IntroPatternArgType ->
       pr_arg pr_intro_pattern (out_gen globwit_intro_pattern x)
-  | IdentArgType -> pr_arg pr_id ((*Constrextern.v7_to_v8_id*) (out_gen globwit_ident x))
-  | HypArgType -> pr_arg (pr_located (fun id -> pr_id (Constrextern.v7_to_v8_id id))) (out_gen globwit_var x)
+  | IdentArgType -> pr_arg pr_id (out_gen globwit_ident x)
+  | VarArgType -> pr_arg (pr_located pr_id) (out_gen globwit_var x)
   | RefArgType -> pr_arg (pr_or_var (pr_located pr_global)) (out_gen globwit_ref x)
-  | SortArgType -> pr_arg pr_sort (out_gen globwit_sort x)
+  | SortArgType -> pr_arg pr_rawsort (out_gen globwit_sort x)
   | ConstrArgType -> pr_arg prc (out_gen globwit_constr x)
   | ConstrMayEvalArgType ->
-      pr_arg (pr_may_eval prc
-        (pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_constr_may_eval x)
+      pr_arg (pr_may_eval prc prlc
+        (pr_or_var (pr_and_short_name pr_evaluable_reference)))
+        (out_gen globwit_constr_may_eval x)
   | QuantHypArgType ->
       pr_arg pr_quantified_hypothesis (out_gen globwit_quant_hyp x)
   | RedExprArgType ->
       pr_arg (pr_red_expr 
-        (prc,pr_or_var (pr_and_short_name pr_evaluable_reference))) (out_gen globwit_red_expr x)
-  | TacticArgType -> pr_arg prtac (out_gen globwit_tactic x)
-  | OpenConstrArgType -> pr_arg prc (snd (out_gen globwit_open_constr x))
-  | CastedOpenConstrArgType ->
-      pr_arg prc (snd (out_gen globwit_casted_open_constr x))
+        (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference)))
+        (out_gen globwit_red_expr x)
+  | OpenConstrArgType b -> pr_arg prc (snd (out_gen (globwit_open_constr_gen b) x))
   | ConstrWithBindingsArgType -> 
       pr_arg (pr_with_bindings prc prlc) (out_gen globwit_constr_with_bindings x)
   | BindingsArgType -> 
@@ -342,10 +211,7 @@ let rec pr_glob_generic prc prlc prtac x =
             pr_glob_generic prc prlc prtac b)
 	  x)
   | ExtraArgType s -> 
-      let tab =
-	if Options.do_translate() or not !Options.v7 then !genarg_pprule
-        else !genarg_pprule_v7 in
-      try pi2 (Stringmap.find s tab) prc prtac x
+      try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str " [no printer for " ++ str s ++ str "] "
 
 open Closure
@@ -359,21 +225,19 @@ let rec pr_generic prc prlc prtac x =
   | PreIdentArgType -> pr_arg str (out_gen wit_pre_ident x)
   | IntroPatternArgType -> 
       pr_arg pr_intro_pattern (out_gen wit_intro_pattern x)
-  | IdentArgType -> pr_arg pr_id (Constrextern.v7_to_v8_id (out_gen wit_ident x))
-  | HypArgType -> pr_arg prc (out_gen wit_var x)
+  | IdentArgType -> pr_arg pr_id (out_gen wit_ident x)
+  | VarArgType -> pr_arg pr_id (out_gen wit_var x)
   | RefArgType -> pr_arg pr_global (out_gen wit_ref x)
-  | SortArgType -> pr_arg prc (Term.mkSort (out_gen wit_sort x))
+  | SortArgType -> pr_arg pr_sort (out_gen wit_sort x)
   | ConstrArgType -> pr_arg prc (out_gen wit_constr x)
   | ConstrMayEvalArgType ->
       pr_arg prc (out_gen wit_constr_may_eval x)
   | QuantHypArgType ->
       pr_arg pr_quantified_hypothesis (out_gen wit_quant_hyp x)
   | RedExprArgType ->
-      pr_arg (pr_red_expr (prc,pr_evaluable_reference)) (out_gen wit_red_expr x)
-  | TacticArgType -> pr_arg prtac (out_gen wit_tactic x)
-  | OpenConstrArgType -> pr_arg prc (snd (out_gen wit_open_constr x))
-  | CastedOpenConstrArgType ->
-      pr_arg prc (snd (out_gen wit_casted_open_constr x))
+      pr_arg (pr_red_expr (prc,prlc,pr_evaluable_reference)) 
+        (out_gen wit_red_expr x)
+  | OpenConstrArgType b -> pr_arg prc (snd (out_gen (wit_open_constr_gen b) x))
   | ConstrWithBindingsArgType -> 
       pr_arg (pr_with_bindings prc prlc) (out_gen wit_constr_with_bindings x)
   | BindingsArgType -> 
@@ -390,10 +254,7 @@ let rec pr_generic prc prlc prtac x =
             pr_generic prc prlc prtac b)
 	  x)
   | ExtraArgType s -> 
-      let tab = 
-	if Options.do_translate() or not !Options.v7 then !genarg_pprule
-        else !genarg_pprule_v7 in
-      try pi3 (Stringmap.find s tab) prc prtac x
+      try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x
       with Not_found -> str " [no printer for " ++ str s ++ str "]"
 
 let rec pr_tacarg_using_rule pr_gen = function
@@ -402,197 +263,542 @@ let rec pr_tacarg_using_rule pr_gen = function
   | [], [] -> mt ()
   | _ -> failwith "Inconsistent arguments of extended tactic"
 
-let pr_extend_gen prgen s l =
-  let tab = 
-    if Options.do_translate() or not !Options.v7 then prtac_tab
-    else prtac_tab_v7
-  in
+let pr_extend_gen prgen lev s l =
   try 
     let tags = List.map genarg_tag l in
-    (* Hack pour les syntaxes changeant non uniformément en passant a la V8 *)
-    let s =
-      let n = String.length s in
-      if Options.do_translate() & n > 2 & String.sub s (n-2) 2 = "v7"
-      then String.sub s 0 (n-2) ^ "v8"
-      else s in
-    let (s,pl) = Hashtbl.find tab (s,tags) in
-    str s ++ pr_tacarg_using_rule prgen (pl,l)
+    let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in
+    let p = pr_tacarg_using_rule prgen (pl,l) in
+    if lev' > lev then surround p else p
   with Not_found ->
     str s ++ prlist prgen l ++ str " (* Generic printer *)"
 
-let make_pr_tac (pr_tac,pr_tac0,pr_constr,pr_pat,pr_cst,pr_ind,pr_ref,pr_ident,pr_extend) =
+let pr_raw_extend prc prlc prtac = 
+  pr_extend_gen (pr_raw_generic prc prlc prtac pr_reference)
+let pr_glob_extend prc prlc prtac =
+  pr_extend_gen (pr_glob_generic prc prlc prtac)
+let pr_extend prc prlc prtac =
+  pr_extend_gen (pr_generic prc prlc prtac)
+
+(**********************************************************************)
+(* The tactic printer                                                 *)
+
+let sep_v = fun _ -> str"," ++ spc()
+
+let strip_prod_binders_expr n ty =
+  let rec strip_ty acc n ty =
+    match ty with
+        Topconstr.CProdN(_,bll,a) ->
+          let nb =
+            List.fold_left (fun i (nal,_) -> i + List.length nal) 0 bll in
+          if nb >= n then (List.rev (bll@acc), a)
+          else strip_ty (bll@acc) (n-nb) a
+      | Topconstr.CArrow(_,a,b) ->
+          if n=1 then
+            (List.rev (([(dummy_loc,Anonymous)],a)::acc), b)
+          else strip_ty (([(dummy_loc,Anonymous)],a)::acc) (n-1) b
+      | _ -> error "Cannot translate fix tactic: not enough products" in
+  strip_ty [] n ty
+
+let pr_ltac_or_var pr = function
+  | ArgArg x -> pr x
+  | ArgVar (loc,id) -> pr_with_comments loc (pr_id id)
+
+let pr_arg pr x = spc () ++ pr x
+
+let pr_ltac_constant sp =
+  pr_qualid (Nametab.shortest_qualid_of_tactic sp)
+
+let pr_evaluable_reference_env env = function 
+  | EvalVarRef id -> pr_id id
+  | EvalConstRef sp -> 
+      Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp)
+
+let pr_inductive env ind =
+  Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.IndRef ind)
+
+let pr_quantified_hypothesis = function
+  | AnonHyp n -> int n
+  | NamedHyp id -> pr_id id 
+
+let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
+
+let pr_esubst prc l =
+  let pr_qhyp = function
+      (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
+    | (_,NamedHyp id,c) ->
+        str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")"
+  in
+  prlist_with_sep spc pr_qhyp l
+
+let pr_bindings_gen for_ex prlc prc = function
+  | ImplicitBindings l ->
+      spc () ++
+      hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
+            prlist_with_sep spc prc l)
+  | ExplicitBindings l ->
+      spc () ++
+      hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
+            pr_esubst prlc l)
+  | NoBindings -> mt ()
+
+let pr_bindings prlc prc = pr_bindings_gen false prlc prc
+
+let pr_with_bindings prlc prc (c,bl) =
+  hov 1 (prc c ++ pr_bindings prlc prc bl)
+
+let pr_with_constr prc = function
+  | None -> mt ()
+  | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
+
+let pr_with_names = function
+  | IntroAnonymous -> mt ()
+  | ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat)
+
+let pr_pose prlc prc na c = match na with
+  | Anonymous -> spc() ++ prc c
+  | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c)
+
+let pr_assertion _prlc prc ipat c = match ipat with
+(* Use this "optimisation" or use only the general case ?
+  | IntroIdentifier id ->
+      spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
+*)
+  | ipat ->
+      spc() ++ prc c ++ pr_with_names ipat
+
+let pr_assumption prlc prc ipat c = match ipat with
+(* Use this "optimisation" or use only the general case ?
+  | IntroIdentifier id ->
+      spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
+*)
+  | ipat ->
+      spc() ++ prc c ++ pr_with_names ipat
+
+let pr_by_tactic prt = function
+  | TacId [] -> mt ()
+  | tac -> spc() ++ str "by " ++ prt tac
+
+let pr_hyp_location pr_id = function
+  | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs
+  | occs, InHypTypeOnly ->
+      spc () ++ 
+      pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs
+  | occs, InHypValueOnly ->
+      spc () ++ 
+      pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs
+
+let pr_in pp = spc () ++ hov 0 (str "in" ++ pp)
+
+let pr_simple_clause pr_id = function
+  | [] -> mt ()
+  | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
+
+let pr_clauses pr_id = function
+    { onhyps=None; onconcl=true; concl_occs=nl } ->
+      pr_in (pr_with_occurrences (fun () -> str " *") (nl,()))
+  | { onhyps=None; onconcl=false } -> pr_in (str " * |-")
+  | { onhyps=Some l; onconcl=true; concl_occs=nl } -> 
+      pr_in (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l
+             ++ pr_with_occurrences (fun () -> str" |- *") (nl,()))
+  | { onhyps=Some l; onconcl=false } ->
+      pr_in (prlist_with_sep (fun()->str",") (pr_hyp_location pr_id) l)
+
+let pr_clause_pattern pr_id = function
+  | (None, []) -> mt ()
+  | (glopt,l) ->
+      str " in" ++
+      prlist
+        (fun (id,nl) -> prlist (pr_arg int) nl 
+	  ++ spc () ++ pr_id id) l ++
+        pr_opt (fun nl -> prlist_with_sep spc int nl ++ str " Goal") glopt
+
+let pr_orient b = if b then mt () else str " <-"
+
+let pr_induction_arg prc = function
+  | ElimOnConstr c -> prc c
+  | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id)
+  | ElimOnAnonHyp n -> int n
+
+let pr_induction_kind = function
+  | SimpleInversion -> str "simple inversion"
+  | FullInversion -> str "inversion"
+  | FullInversionClear -> str "inversion_clear"
+
+let pr_lazy lz = if lz then str "lazy " else mt ()
+
+let pr_match_pattern pr_pat = function
+  | Term a -> pr_pat a
+  | Subterm (None,a) -> str "context [" ++ pr_pat a ++ str "]"
+  | Subterm (Some id,a) ->
+      str "context " ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]"
+
+let pr_match_hyps pr_pat (Hyp (nal,mp)) =
+  pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp
+
+let pr_match_rule m pr pr_pat = function
+  | Pat ([],mp,t) when m ->
+      pr_match_pattern pr_pat mp ++
+      spc () ++ str "=>" ++ brk (1,4) ++ pr t
+(*
+  | Pat (rl,mp,t) ->
+      hv 0 (prlist_with_sep pr_coma (pr_match_hyps pr_pat) rl ++
+        (if rl <> [] then spc () else mt ()) ++ 
+         hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
+	 str "=>" ++ brk (1,4) ++ pr t))
+*)
+  | Pat (rl,mp,t) ->
+      hov 0 (
+	hv 0 (prlist_with_sep pr_coma (pr_match_hyps pr_pat) rl) ++
+        (if rl <> [] then spc () else mt ()) ++ 
+        hov 0 (
+	  str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
+	  str "=>" ++ brk (1,4) ++ pr t))
+  | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t
+
+let pr_funvar = function
+  | None -> spc () ++ str "_"
+  | Some id -> spc () ++ pr_id id
+
+let pr_let_clause k pr = function
+  | (id,None,t) ->
+      hov 0 (str k ++ pr_lident id ++ str " :=" ++ brk (1,1) ++
+             pr (TacArg t))
+  | (id,Some c,t) ->
+      hv 0 (str k ++ pr_lident id ++ str" :" ++ brk(1,2) ++
+      pr c ++
+      str " :=" ++ brk (1,1) ++ pr (TacArg t))
+
+let pr_let_clauses pr = function
+  | hd::tl ->
+      hv 0
+        (pr_let_clause "let " pr hd ++
+         prlist (fun t -> spc () ++ pr_let_clause "with " pr t) tl)
+  | [] -> anomaly "LetIn must declare at least one binding"
+
+let pr_rec_clause pr (id,(l,t)) =
+  hov 0
+    (pr_lident id ++ prlist pr_funvar l ++ str " :=") ++ spc () ++ pr t
+
+let pr_rec_clauses pr l = 
+  prlist_with_sep (fun () -> fnl () ++ str "with ") (pr_rec_clause pr) l
+
+let pr_seq_body pr tl =
+  hv 0 (str "[ " ++
+        prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
+        str " ]")
+
+let pr_hintbases = function
+  | None -> spc () ++ str "with *"
+  | Some [] -> mt ()
+  | Some l ->
+      spc () ++ hov 2 (str "with" ++ prlist (fun s -> spc () ++ str s) l)
+
+let pr_auto_using prc = function
+  | [] -> mt ()
+  | l -> spc () ++ 
+      hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_coma prc l)
+
+let pr_autoarg_adding = function
+  | [] -> mt ()
+  | l ->
+      spc () ++ str "adding [" ++
+        hv 0 (prlist_with_sep spc pr_reference l) ++ str "]"
+
+let pr_autoarg_destructing = function
+  | true -> spc () ++ str "destructing"
+  | false -> mt ()
+
+let pr_autoarg_usingTDB = function
+  | true -> spc () ++ str "using tdb"
+  | false -> mt ()
+
+let rec pr_tacarg_using_rule pr_gen = function
+  | Egrammar.TacTerm s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al)
+  | Egrammar.TacNonTerm _ :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule pr_gen (l,al)
+  | [], [] -> mt ()
+  | _ -> failwith "Inconsistent arguments of extended tactic"
+
+let pr_then () = str ";"
+
+let ltop = (5,E)
+let lseq = 4
+let ltactical = 3
+let lorelse = 2
+let llet = 5
+let lfun = 5
+let lcomplete = 1
+let labstract = 3
+let lmatch = 1
+let latom = 0
+let lcall = 1
+let leval = 1
+let ltatom = 1
+let linfo = 5
+
+let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq
+
+open Closure
+
+(** A printer for tactics that polymorphically works on the three
+    "raw", "glob" and "typed" levels; in practice, the environment is
+    used only at the glob and typed level: it is used to feed the
+    constr printers *)
+
+let make_pr_tac 
+  (pr_tac_level,pr_constr,pr_lconstr,pr_pat,
+   pr_cst,pr_ind,pr_ref,pr_ident,
+   pr_extend,strip_prod_binders) env =
+
+(* The environment is not used by the tactic printer: it is passed to the
+   constr and cst printers; hence we can make some abbreviations *)
+let pr_constr = pr_constr env in
+let pr_lconstr = pr_lconstr env in
+let pr_cst = pr_cst env in
+let pr_ind = pr_ind env in
+let pr_tac_level = pr_tac_level env in
+
+(* Other short cuts *)
+let pr_bindings = pr_bindings pr_lconstr pr_constr in
+let pr_ex_bindings = pr_bindings_gen true pr_lconstr pr_constr in
+let pr_with_bindings = pr_with_bindings pr_lconstr pr_constr in
+let pr_extend = pr_extend pr_constr pr_lconstr pr_tac_level in
+let pr_red_expr = pr_red_expr (pr_constr,pr_lconstr,pr_cst) in
 
-let pr_bindings = pr_bindings pr_constr pr_constr in
-let pr_bindings_no_with = pr_bindings_no_with pr_constr pr_constr in
-let pr_with_bindings = pr_with_bindings pr_constr pr_constr in
-let pr_eliminator cb = str "using" ++ pr_arg (pr_with_bindings) cb in
 let pr_constrarg c = spc () ++ pr_constr c in
+let pr_lconstrarg c = spc () ++ pr_lconstr c in
 let pr_intarg n = spc () ++ int n in
 
+(* Some printing combinators *)
+let pr_eliminator cb = str "using" ++ pr_arg pr_with_bindings cb in
+
+let pr_binder_fix (nal,t) =
+(*  match t with
+  | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
+  | _ ->*)
+    let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr_lconstr t in
+    spc() ++ hov 1 (str"(" ++ s ++ str")") in
+
+let pr_fix_tac (id,n,c) =
+  let rec set_nth_name avoid n = function
+      (nal,ty)::bll ->
+        if n <= List.length nal then
+          match list_chop (n-1) nal with
+              _, (_,Name id) :: _ -> id, (nal,ty)::bll
+            | bef, (loc,Anonymous) :: aft ->
+                let id = next_ident_away_from (id_of_string"y") avoid in
+                id, ((bef@(loc,Name id)::aft, ty)::bll)
+            | _ -> assert false
+        else
+          let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
+          (id,(nal,ty)::bll')
+    | [] -> assert false in
+  let (bll,ty) = strip_prod_binders n c in
+  let names =
+    List.fold_left
+      (fun ln (nal,_) -> List.fold_left
+          (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
+          ln nal)
+      [] bll in
+  let idarg,bll = set_nth_name names n bll in
+  let annot =
+    if List.length names = 1 then mt()
+    else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in
+  hov 1 (str"(" ++ pr_id id ++ 
+        prlist pr_binder_fix bll ++ annot ++ str" :" ++
+        pr_lconstrarg ty ++ str")") in
+(*  spc() ++
+  hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg
+    c)
+*)
+let pr_cofix_tac (id,c) =
+  hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in
+
   (* Printing tactics as arguments *)
 let rec pr_atom0 = function
-  | TacIntroPattern [] -> str "Intros"
-  | TacIntroMove (None,None) -> str "Intro"
-  | TacAssumption -> str "Assumption"
-  | TacAnyConstructor None -> str "Constructor"
-  | TacTrivial (Some []) -> str "Trivial"
-  | TacAuto (None,Some []) -> str "Auto"
-  | TacAutoTDB None -> str "AutoTDB"
-  | TacDestructConcl -> str "DConcl"
-  | TacReflexivity -> str "Reflexivity"
+  | TacIntroPattern [] -> str "intros"
+  | TacIntroMove (None,None) -> str "intro"
+  | TacAssumption -> str "assumption"
+  | TacAnyConstructor None -> str "constructor"
+  | TacTrivial ([],Some []) -> str "trivial"
+  | TacAuto (None,[],Some []) -> str "auto"
+  | TacReflexivity -> str "reflexivity"
+  | TacClear (true,[]) -> str "clear"
   | t -> str "(" ++ pr_atom1 t ++ str ")"
 
   (* Main tactic printer *)
 and pr_atom1 = function
-  | TacExtend (_,s,l) -> pr_extend pr_constr pr_constr pr_tac s l
-  | TacAlias (_,s,l,_) ->
-      pr_extend pr_constr pr_constr pr_tac s (List.map snd l)
+  | TacAutoTDB _ | TacDestructHyp _ | TacDestructConcl
+  | TacSuperAuto _ | TacExtend (_,
+    ("GTauto"|"GIntuition"|"TSimplif"|
+     "LinearIntuition"),_) ->
+      errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0")
+  | TacExtend (loc,s,l) ->
+      pr_with_comments loc (pr_extend 1 s l)
+  | TacAlias (loc,s,l,_) ->
+      pr_with_comments loc (pr_extend 1 s (List.map snd l))
 
   (* Basic tactics *)
   | TacIntroPattern [] as t -> pr_atom0 t
   | TacIntroPattern (_::_ as p) -> 
-      hov 1 (str "Intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p)
+      hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p)
   | TacIntrosUntil h ->
-      hv 1 (str "Intros until" ++ pr_arg pr_quantified_hypothesis h)
+      hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h)
   | TacIntroMove (None,None) as t -> pr_atom0 t
-  | TacIntroMove (Some id1,None) -> str "Intro " ++ pr_id id1
-  | TacIntroMove (ido1,Some (_,id2)) ->
+  | TacIntroMove (Some id1,None) -> str "intro " ++ pr_id id1
+  | TacIntroMove (ido1,Some id2) ->
       hov 1
-      (str "Intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++ pr_id id2)
+      (str "intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++
+       pr_lident id2)
   | TacAssumption as t -> pr_atom0 t
-  | TacExact c -> hov 1 (str "Exact" ++ pr_arg pr_constr c)
-  | TacApply cb -> hov 1 (str "Apply" ++ spc () ++ pr_with_bindings cb)
+  | TacExact c -> hov 1 (str "exact" ++ pr_constrarg c)
+  | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg c)
+  | TacVmCastNoCheck c -> hov 1 (str "vm_cast_no_check" ++ pr_constrarg c)
+  | TacApply cb -> hov 1 (str "apply" ++ spc () ++ pr_with_bindings cb)
   | TacElim (cb,cbo) ->
-      hov 1 (str "Elim" ++ pr_arg pr_with_bindings cb ++ 
+      hov 1 (str "elim" ++ pr_arg pr_with_bindings cb ++ 
         pr_opt pr_eliminator cbo)
-  | TacElimType c -> hov 1 (str "ElimType" ++ pr_arg pr_constr c)
-  | TacCase cb -> hov 1 (str "Case" ++ spc () ++ pr_with_bindings cb)
-  | TacCaseType c -> hov 1 (str "CaseType" ++ pr_arg pr_constr c)
-  | TacFix (ido,n) -> hov 1 (str "Fix" ++ pr_opt pr_id ido ++ pr_intarg n)
+  | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg c)
+  | TacCase cb -> hov 1 (str "case" ++ spc () ++ pr_with_bindings cb)
+  | TacCaseType c -> hov 1 (str "casetype" ++ pr_constrarg c)
+  | TacFix (ido,n) -> hov 1 (str "fix" ++ pr_opt pr_id ido ++ pr_intarg n)
   | TacMutualFix (id,n,l) ->
-      hov 1 (str "Fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc () ++
-        hov 0 (str "with" ++ brk (1,1) ++
-          prlist_with_sep spc
-	    (fun (id,n,c) ->
-	      spc () ++ pr_id id ++ pr_intarg n ++ pr_arg pr_constr c)
-	  l))
-  | TacCofix ido -> hov 1 (str "Cofix" ++ pr_opt pr_id ido)
+      hov 1 (str "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++
+             str"with " ++ prlist_with_sep spc pr_fix_tac l)
+  | TacCofix ido -> hov 1 (str "cofix" ++ pr_opt pr_id ido)
   | TacMutualCofix (id,l) ->
-      hov 1 (str "Cofix" ++ spc () ++ pr_id id ++ spc () ++
-        hov 0 (str "with" ++ brk (1,1) ++
-          prlist (fun (id,c) -> spc () ++ pr_id id ++ pr_arg pr_constr c)
-	  l))
-  | TacCut c -> hov 1 (str "Cut" ++ pr_arg pr_constr c)
-  | TacTrueCut (Anonymous,c) -> 
-      hov 1 (str "Assert" ++ pr_arg pr_constr c)
-  | TacTrueCut (Name id,c) -> 
-      hov 1 (str "Assert" ++ spc () ++ pr_id id ++ str ":" ++ pr_constr c)
-  | TacForward (false,na,c) ->
-      hov 1 (str "Assert" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c)
-  | TacForward (true,na,c) ->
-      hov 1 (str "Pose" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c)
+      hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++
+             str"with " ++ prlist_with_sep spc pr_cofix_tac l)
+  | TacCut c -> hov 1 (str "cut" ++ pr_constrarg c)
+  | TacAssert (Some tac,ipat,c) -> 
+      hov 1 (str "assert" ++ 
+             pr_assumption pr_lconstr pr_constr ipat c ++ 
+             pr_by_tactic (pr_tac_level ltop) tac)
+  | TacAssert (None,ipat,c) -> 
+      hov 1 (str "pose proof" ++
+             pr_assertion pr_lconstr pr_constr ipat c)
   | TacGeneralize l ->
-      hov 1 (str "Generalize" ++ spc () ++ prlist_with_sep spc pr_constr l)
+      hov 1 (str "generalize" ++ spc () ++
+             prlist_with_sep spc pr_constr l)
   | TacGeneralizeDep c ->
-      hov 1 (str "Generalize" ++ spc () ++ str "Dependent" ++ spc () ++
-      pr_constr c)
+      hov 1 (str "generalize" ++ spc () ++ str "dependent" ++
+             pr_constrarg c)
+  | TacLetTac (na,c,cl) when cl = nowhere ->
+      hov 1 (str "pose" ++ pr_pose pr_lconstr pr_constr na c)
   | TacLetTac (na,c,cl) ->
-      let pcl = match cl with
-          {onhyps=None;onconcl=true;concl_occs=[]} -> mt()
-        | _ -> pr_clauses pr_ident cl in
-      hov 1 (str "LetTac" ++ spc () ++ pr_name na ++ str ":=" ++
-             pr_constr c ++ pcl)
-  | TacInstantiate (n,c,cls) ->
-      hov 1 (str "Instantiate" ++ pr_arg int n ++ pr_arg pr_constr c ++ 
-	     pr_clauses pr_ident cls)
+      hov 1 (str "set" ++ pr_pose pr_lconstr pr_constr na c ++
+             pr_clauses pr_ident cl)
+(*  | TacInstantiate (n,c,ConclLocation ()) ->
+      hov 1 (str "instantiate" ++ spc() ++
+             hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+                    pr_lconstrarg c ++ str ")" ))
+  | TacInstantiate (n,c,HypLocation (id,hloc)) ->
+      hov 1 (str "instantiate" ++ spc() ++
+             hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+                    pr_lconstrarg c ++ str ")" ) 
+	     ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None)))
+*)
   (* Derived basic tactics *)
-  | TacSimpleInduction (h,_) ->
-      hov 1 (str "Induction" ++ pr_arg pr_quantified_hypothesis h)
-  | TacNewInduction (h,e,(ids,_)) ->
-      hov 1 (str "NewInduction" ++ spc () ++ pr_induction_arg pr_constr h ++
-        pr_opt pr_eliminator e ++ pr_with_names ids)
+  | TacSimpleInduction h ->
+      hov 1 (str "simple induction" ++ pr_arg pr_quantified_hypothesis h)
+  | TacNewInduction (h,e,ids) ->
+      hov 1 (str "induction" ++ spc () ++
+	     prlist_with_sep spc (pr_induction_arg pr_constr) h ++
+	     pr_with_names ids ++
+             pr_opt pr_eliminator e)
   | TacSimpleDestruct h ->
-      hov 1 (str "Destruct" ++ pr_arg pr_quantified_hypothesis h)
-  | TacNewDestruct (h,e,(ids,_)) ->
-      hov 1 (str "NewDestruct" ++ spc () ++ pr_induction_arg pr_constr h ++
-        pr_opt pr_eliminator e ++ pr_with_names ids)
+      hov 1 (str "simple destruct" ++ pr_arg pr_quantified_hypothesis h)
+  | TacNewDestruct (h,e,ids) ->
+      hov 1 (str "destruct" ++ spc () ++
+             prlist_with_sep spc (pr_induction_arg pr_constr) h ++ 
+	     pr_with_names ids ++
+             pr_opt pr_eliminator e)
   | TacDoubleInduction (h1,h2) ->
       hov 1
-        (str "Double Induction" ++ 
+        (str "double induction" ++  
          pr_arg pr_quantified_hypothesis h1 ++
  	 pr_arg pr_quantified_hypothesis h2)
   | TacDecomposeAnd c ->
-      hov 1 (str "Decompose Record" ++ pr_arg pr_constr c)
+      hov 1 (str "decompose record" ++ pr_constrarg c)
   | TacDecomposeOr c ->
-      hov 1 (str "Decompose Sum" ++ pr_arg pr_constr c)
+      hov 1 (str "decompose sum" ++ pr_constrarg c)
   | TacDecompose (l,c) ->
-      hov 1 (str "Decompose" ++ spc () ++
+      hov 1 (str "decompose" ++ spc () ++
         hov 0 (str "[" ++ prlist_with_sep spc pr_ind l
-	  ++ str "]" ++ pr_arg pr_constr c))
+	  ++ str "]" ++ pr_constrarg c))
   | TacSpecialize (n,c) ->
-      hov 1 (str "Specialize" ++ pr_opt int n ++ pr_with_bindings c)
+      hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ 
+             pr_with_bindings c)
   | TacLApply c -> 
-      hov 1 (str "LApply" ++ pr_constr c)
+      hov 1 (str "lapply" ++ pr_constrarg c)
 
   (* Automation tactics *)
-  | TacTrivial (Some []) as x -> pr_atom0 x
-  | TacTrivial db -> hov 0 (str "Trivial" ++ pr_hintbases db)
-  | TacAuto (None,Some []) as x -> pr_atom0 x
-  | TacAuto (n,db) ->
-      hov 0 (str "Auto" ++ pr_opt (pr_or_var int) n ++ pr_hintbases db)
-  | TacAutoTDB None as x -> pr_atom0 x
-  | TacAutoTDB (Some n) -> hov 0 (str "AutoTDB" ++ spc () ++ int n)
-  | TacDestructHyp (true,(_,id)) -> hov 0 (str "CDHyp" ++ spc () ++ pr_id id)
-  | TacDestructHyp (false,(_,id)) -> hov 0 (str "DHyp" ++ spc () ++ pr_id id)
-  | TacDestructConcl as x -> pr_atom0 x
-  | TacSuperAuto (n,l,b1,b2) ->
-      hov 1 (str "SuperAuto" ++ pr_opt int n ++ pr_autoarg_adding l ++ 
-             pr_autoarg_destructing b1 ++ pr_autoarg_usingTDB b2)
+  | TacTrivial ([],Some []) as x -> pr_atom0 x
+  | TacTrivial (lems,db) ->
+      hov 0 (str "trivial" ++ 
+             pr_auto_using pr_constr lems ++ pr_hintbases db)
+  | TacAuto (None,[],Some []) as x -> pr_atom0 x
+  | TacAuto (n,lems,db) ->
+      hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ 
+             pr_auto_using pr_constr lems ++ pr_hintbases db)
   | TacDAuto (n,p) ->
-      hov 1 (str "Auto" ++ pr_opt (pr_or_var int) n ++ str "Decomp" ++ 
-      pr_opt int p)
+      hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ pr_opt int p)
 
   (* Context management *)
-  | TacClear l ->
-      hov 1 (str "Clear" ++ spc () ++ prlist_with_sep spc pr_ident l)
+  | TacClear (true,[]) as t -> pr_atom0 t
+  | TacClear (keep,l) ->
+      hov 1 (str "clear" ++ spc () ++ (if keep then str "- " else mt ()) ++
+             prlist_with_sep spc pr_ident l)
   | TacClearBody l ->
-      hov 1 (str "ClearBody" ++ spc () ++ prlist_with_sep spc pr_ident l)
+      hov 1 (str "clearbody" ++ spc () ++ prlist_with_sep spc pr_ident l)
   | TacMove (b,id1,id2) ->
       (* Rem: only b = true is available for users *)
       assert b;
       hov 1
-        (str "Move" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ 
+        (str "move" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ 
 	 str "after" ++ brk (1,1) ++ pr_ident id2)
   | TacRename (id1,id2) ->
       hov 1
-        (str "Rename" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ 
+        (str "rename" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ 
 	 str "into" ++ brk (1,1) ++ pr_ident id2)
 
   (* Constructors *)
-  | TacLeft l -> hov 1 (str "Left" ++ pr_bindings l)
-  | TacRight l -> hov 1 (str "Right" ++ pr_bindings l)
-  | TacSplit (_,l) -> hov 1 (str "Split" ++ pr_bindings l)
+  | TacLeft l -> hov 1 (str "left" ++ pr_bindings l)
+  | TacRight l -> hov 1 (str "right" ++ pr_bindings l)
+  | TacSplit (false,l) -> hov 1 (str "split" ++ pr_bindings l)
+  | TacSplit (true,l) -> hov 1 (str "exists" ++ pr_ex_bindings l)
   | TacAnyConstructor (Some t) ->
-      hov 1 (str "Constructor" ++ pr_arg pr_tac0 t)
+      hov 1 (str "constructor" ++ pr_arg (pr_tac_level (latom,E)) t)
   | TacAnyConstructor None as t -> pr_atom0 t
   | TacConstructor (n,l) ->
-      hov 1 (str "Constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings l)
+      hov 1 (str "constructor" ++ pr_or_metaid pr_intarg n ++ pr_bindings l)
 
   (* Conversion *)  
   | TacReduce (r,h) ->
-      hov 1 (pr_red_expr (pr_constr,pr_cst) r ++ pr_clauses pr_ident h)
-  | TacChange (occl,c,h) ->
-      hov 1 (str "Change" ++ pr_opt (pr_subterms pr_constr) occl ++ 
-        brk (1,1) ++ pr_constr c ++ pr_clauses pr_ident h)
+      hov 1 (pr_red_expr r ++
+             pr_clauses pr_ident h)
+  | TacChange (occ,c,h) ->
+      hov 1 (str "change" ++ brk (1,1) ++
+      (match occ with
+          None -> mt()
+        | Some([],c1) -> hov 1 (pr_constr c1 ++ spc() ++ str "with ")
+        | Some(ocl,c1) ->
+            hov 1 (pr_constr c1 ++ spc() ++
+	           str "at " ++ prlist_with_sep spc (pr_or_var int) ocl) ++
+                   spc() ++
+	           str "with ") ++
+      pr_constr c ++ pr_clauses pr_ident h)
 
   (* Equivalence relations *)
   | TacReflexivity as x -> pr_atom0 x
-  | TacSymmetry cls -> str "Symmetry " ++ pr_clauses pr_ident cls
-  | TacTransitivity c -> str "Transitivity" ++ pr_arg pr_constr c
+  | TacSymmetry cls -> str "symmetry " ++ pr_clauses pr_ident cls
+  | TacTransitivity c -> str "transitivity" ++ pr_constrarg c
 
   (* Equality and inversion *)
+  | TacRewrite (b,c,cl) -> 
+      hov 1 (str "rewrite" ++ pr_orient b ++ spc() ++ pr_with_bindings c ++ 
+             pr_clauses pr_ident cl) 
   | TacInversion (DepInversion (k,c,ids),hyp) ->
-      hov 1 (str "Dependent " ++ pr_induction_kind k ++ 
+      hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++
       pr_quantified_hypothesis hyp ++
       pr_with_names ids ++ pr_with_constr pr_constr c)
   | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
@@ -600,166 +806,227 @@ and pr_atom1 = function
       pr_quantified_hypothesis hyp ++
       pr_with_names ids ++ pr_simple_clause pr_ident cl)
   | TacInversion (InversionUsing (c,cl),hyp) ->
-      hov 1 (str "Inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ 
-      str "using" ++ spc () ++ pr_constr c ++ 
+      hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ 
+      spc () ++ str "using" ++ spc () ++ pr_constr c ++ 
       pr_simple_clause pr_ident cl)
 
-and pr_tactic_seq_body tl = 
-  hv 0 (str "[ " ++
-        prlist_with_sep (fun () -> spc () ++ str "| ") prtac tl ++ str " ]")
-
-  (* Strictly closed atomic tactic expressions *)
-and pr0 = function
-  | TacFirst tl -> str "First" ++ spc () ++ pr_tactic_seq_body tl
-  | TacSolve tl -> str "Solve" ++ spc () ++ pr_tactic_seq_body tl
-  | TacId "" -> str "Idtac" 
-  | TacFail (ArgArg 0,"") -> str "Fail"
-  | TacAtom (_,t) -> pr_atom0 t
-  | TacArg c -> pr_tacarg c
-  | t -> str "(" ++ prtac t ++ str ")"
-
-  (* Semi-closed atomic tactic expressions *)
-and pr1 = function
-  | TacAtom (_,t) -> pr_atom1 t
-  | TacId s -> str "Idtac \"" ++ str s ++ str "\""	
-  | TacFail (ArgArg 0,s) -> str "Fail \"" ++ str s ++ str "\""
-  | TacFail (n,"") -> str "Fail " ++ pr_or_var int n
-  | TacFail (n,s) -> str "Fail " ++ pr_or_var int n ++ str " \"" ++ str s ++ str "\""
-  | t -> pr0 t
-
-  (* Orelse tactic expressions (printed as if parsed associating on the right
-     though the semantics is purely associative) *)
-and pr2 = function
-  | TacOrelse (t1,t2) ->
-      hov 1 (pr1 t1 ++ str " Orelse" ++ brk (1,1) ++ pr3 t2)
-  | t -> pr1 t
-
-  (* Non closed prefix tactic expressions *)
-and pr3 = function
-  | TacTry t -> hov 1 (str "Try" ++ spc () ++ pr3 t)
-  | TacDo (n,t) -> hov 1 (str "Do " ++ pr_or_var int n ++ spc () ++ pr3 t)
-  | TacRepeat t -> hov 1 (str "Repeat" ++ spc () ++ pr3 t)
-  | TacProgress t -> hov 1 (str "Progress" ++ spc () ++ pr3 t)
-  | TacInfo t -> hov 1 (str "Info" ++ spc () ++ pr3 t)
-  | t -> pr2 t
-
-and pr4 = function
-  | t -> pr3 t
-
-  (* THEN and THENS tactic expressions (printed as if parsed
-     associating on the left though the semantics is purely associative) *)
-and pr5 = function
-  | TacThens (t,tl) -> 
-      hov 1 (pr5 t ++ str ";" ++ spc () ++ pr_tactic_seq_body tl)
-  | TacThen (t1,t2) ->
-      hov 1 (pr5 t1 ++ str ";" ++ spc () ++ pr4 t2)
-  | t -> pr4 t
-
-  (* Ltac tactic expressions *)
-and pr6 = function
-  |(TacAtom _
-  | TacThen _
-  | TacThens _
-  | TacFirst _
-  | TacSolve _
-  | TacTry _
-  | TacOrelse _
-  | TacDo _
-  | TacRepeat _
-  | TacProgress _
-  | TacId _
-  | TacFail _
-  | TacInfo _) as t -> pr5 t
-
-  | TacAbstract (t,None) -> str "Abstract " ++ pr6 t
+in
+
+let rec pr_tac inherited tac =
+  let (strm,prec) = match tac with
+  | TacAbstract (t,None) ->
+      str "abstract " ++ pr_tac (labstract,L) t, labstract
   | TacAbstract (t,Some s) -> 
       hov 0
-       (str "Abstract " ++ pr6 t ++ spc () ++ str "using" ++ spc () ++ pr_id s)
+       (str "abstract (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () ++
+        str "using " ++ pr_id s),
+      labstract
   | TacLetRecIn (l,t) -> 
       hv 0
-        (str "Rec " ++ pr_rec_clauses prtac l ++
-        spc () ++ str "In" ++ fnl () ++ prtac t)
+        (str "let rec " ++ pr_rec_clauses (pr_tac ltop) l ++ str " in" ++
+         fnl () ++ pr_tac (llet,E) t),
+      llet
   | TacLetIn (llc,u) ->
       v 0
-       (hv 0 (pr_let_clauses pr_tacarg0 llc ++ spc () ++ str "In") ++ fnl () ++ prtac u)
-  | TacMatch (t,lrul) ->
-      hov 0 (str "Match" ++ spc () ++ pr6 t ++ spc()
-        ++ str "With"
+       (hv 0 (pr_let_clauses (pr_tac ltop) llc
+       ++ str " in") ++
+       fnl () ++ pr_tac (llet,E) u),
+      llet
+  | TacMatch (lz,t,lrul) ->
+      hov 0 (pr_lazy lz ++ str "match " ++ pr_tac ltop t ++ str " with"
         ++ prlist
-	  (fun r -> fnl () ++ str "|" ++ spc () ++
-            pr_match_rule true pr_pat prtac r)
-	lrul)
-  | TacMatchContext (lr,lrul) ->
-      hov 0 (
-	str (if lr then "Match Reverse Context With" else "Match Context With")
+	  (fun r -> fnl () ++ str "| " ++
+            pr_match_rule true (pr_tac ltop) pr_pat r)
+	lrul
+        ++ fnl() ++ str "end"),
+      lmatch
+  | TacMatchContext (lz,lr,lrul) ->
+      hov 0 (pr_lazy lz ++ 
+	str (if lr then "match reverse goal with" else "match goal with")
 	++ prlist
-	  (fun r -> fnl () ++ str "|" ++ spc () ++
-            pr_match_rule false pr_pat prtac r)
-	lrul)
+	  (fun r -> fnl () ++ str "| " ++
+            pr_match_rule false (pr_tac ltop) pr_pat r)
+	lrul
+        ++ fnl() ++ str "end"),
+      lmatch
   | TacFun (lvar,body) ->
-      hov 0 (str "Fun" ++
-        prlist pr_funvar lvar ++ spc () ++ str "->" ++ spc () ++ prtac body)
-
-  | TacArg c -> pr_tacarg c
-
-and pr_tacarg0 = function
-  | TacDynamic (_,t) -> str ("<dynamic ["^(Dyn.tag t)^"]>")
-  | MetaIdArg (_,s) -> str ("$" ^ s)
-  | IntroPattern ipat -> pr_intro_pattern ipat
+      hov 2 (str "fun" ++
+        prlist pr_funvar lvar ++ str " =>" ++ spc () ++
+        pr_tac (lfun,E) body),
+      lfun
+  | TacThens (t,tl) -> 
+      hov 1 (pr_tac (lseq,E) t ++ pr_then () ++ spc () ++
+             pr_seq_body (pr_tac ltop) tl),
+      lseq
+  | TacThen (t1,t2) ->
+      hov 1 (pr_tac (lseq,E) t1 ++ pr_then () ++ spc () ++
+             pr_tac (lseq,L) t2),
+      lseq
+  | TacTry t ->
+      hov 1 (str "try" ++ spc () ++ pr_tac (ltactical,E) t),
+      ltactical
+  | TacDo (n,t) ->
+      hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ 
+             pr_tac (ltactical,E) t),
+      ltactical
+  | TacRepeat t ->
+      hov 1 (str "repeat" ++ spc () ++ pr_tac (ltactical,E) t),
+      ltactical
+  | TacProgress t ->
+      hov 1 (str "progress" ++ spc () ++ pr_tac (ltactical,E) t),
+      ltactical
+  | TacInfo t ->
+      hov 1 (str "info" ++ spc () ++ pr_tac (ltactical,E) t),
+      linfo
+  | TacOrelse (t1,t2) ->
+      hov 1 (pr_tac (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++
+             pr_tac (lorelse,E) t2),
+      lorelse
+  | TacFail (n,l) -> 
+      str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++
+      prlist (pr_arg (pr_message_token pr_ident)) l, latom
+  | TacFirst tl ->
+      str "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
+  | TacSolve tl ->
+      str "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
+  | TacComplete t ->
+      str "complete" ++ spc () ++ pr_tac (lcomplete,E) t, lcomplete
+  | TacId l ->
+      str "idtac" ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom
+  | TacAtom (loc,TacAlias (_,s,l,_)) ->
+      pr_with_comments loc
+        (pr_extend (level_of inherited) s (List.map snd l)),
+      latom
+  | TacAtom (loc,t) ->
+      pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom
+  | TacArg(Tacexp e) -> pr_tac_level (latom,E) e, latom
+  | TacArg(ConstrMayEval (ConstrTerm c)) ->
+      str "constr:" ++ pr_constr c, latom
+  | TacArg(ConstrMayEval c) ->
+      pr_may_eval pr_constr pr_lconstr pr_cst c, leval
+  | TacArg(TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom
+  | TacArg(Integer n) -> int n, latom
+  | TacArg(TacCall(loc,f,l)) ->
+      pr_with_comments loc
+        (hov 1 (pr_ref f ++ spc () ++
+         prlist_with_sep spc pr_tacarg l)),
+      lcall
+  | TacArg a -> pr_tacarg a, latom
+  in
+  if prec_less prec inherited then strm
+  else str"(" ++ strm ++ str")"
+
+and pr_tacarg = function
+  | TacDynamic (loc,t) ->
+      pr_with_comments loc (str ("<dynamic ["^(Dyn.tag t)^"]>"))
+  | MetaIdArg (loc,s) -> pr_with_comments loc (str ("$" ^ s))
+  | IntroPattern ipat -> str "ipattern:" ++ pr_intro_pattern ipat
   | TacVoid -> str "()"
   | Reference r -> pr_ref r
-  | ConstrMayEval (ConstrTerm c) -> str "'" ++ pr_constr c
-  | ConstrMayEval c -> pr_may_eval pr_constr pr_cst c
-  | Integer n -> int n
-  | TacFreshId sopt -> str "FreshId" ++ pr_opt qstring sopt
-  | (TacCall _ | Tacexp _) as t -> str "(" ++ pr_tacarg1 t ++ str ")"
-
-and pr_tacarg1 = function
-  | TacCall (_,f,l) ->
-      hov 0 (pr_ref f ++ spc () ++ prlist_with_sep spc pr_tacarg0 l)
-  | Tacexp t -> pr_tac t
-  | t -> pr_tacarg0 t
-
-and pr_tacarg x = pr_tacarg1 x
-
-and prtac x = pr6 x
-
-in (prtac,pr0,pr_match_rule false pr_pat pr_tac)
-
-let pr_raw_extend prc prlc prtac = 
-  pr_extend_gen (pr_raw_generic prc prlc prtac Ppconstrnew.pr_reference)
-let pr_glob_extend prc prlc prtac =
-  pr_extend_gen (pr_glob_generic prc prlc prtac)
-let pr_extend prc prlc prtac =
-  pr_extend_gen (pr_generic prc prlc prtac)
+  | ConstrMayEval c ->
+      pr_may_eval pr_constr pr_lconstr pr_cst c
+  | TacFreshId l -> str "fresh" ++ pr_fresh_ids l
+  | TacExternal (_,com,req,la) ->
+      str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ 
+      spc() ++ prlist_with_sep spc pr_tacarg la
+  | (TacCall _|Tacexp _|Integer _) as a ->
+      str "ltac:" ++ pr_tac (latom,E) (TacArg a)
+
+in (pr_tac, pr_match_rule)
+
+let strip_prod_binders_rawterm n (ty,_) =
+  let rec strip_ty acc n ty =
+    if n=0 then (List.rev acc, (ty,None)) else
+      match ty with
+          Rawterm.RProd(loc,na,a,b) ->
+            strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b
+        | _ -> error "Cannot translate fix tactic: not enough products" in
+  strip_ty [] n ty
+
+let strip_prod_binders_constr n ty =
+  let rec strip_ty acc n ty =
+    if n=0 then (List.rev acc, ty) else
+      match Term.kind_of_term ty with
+          Term.Prod(na,a,b) ->
+            strip_ty (([dummy_loc,na],a)::acc) (n-1) b
+        | _ -> error "Cannot translate fix tactic: not enough products" in
+  strip_ty [] n ty
+
+let drop_env f _env = f
+
+let rec raw_printers =
+    (pr_raw_tactic_level, 
+     drop_env pr_constr_expr,
+     drop_env pr_lconstr_expr,
+     pr_lpattern_expr,
+     drop_env pr_reference,
+     drop_env pr_reference,
+     pr_reference,
+     pr_or_metaid pr_lident,
+     pr_raw_extend,
+     strip_prod_binders_expr)
+
+and pr_raw_tactic_level env n (t:raw_tactic_expr) =
+  fst (make_pr_tac raw_printers env) n t
+
+and pr_raw_match_rule env t =
+  snd (make_pr_tac raw_printers env) t
 
 let pr_and_constr_expr pr (c,_) = pr c
 
 let rec glob_printers =
-    (pr_glob_tactic, 
-     pr_glob_tactic0,
-     pr_and_constr_expr Printer.pr_rawterm,
-     Printer.pr_pattern,
-     pr_or_var (pr_and_short_name pr_evaluable_reference),
-     pr_or_var pr_inductive,
-     pr_or_var (pr_located pr_ltac_constant),
-     pr_located pr_id,
-     pr_glob_extend)
-
-and pr_glob_tactic (t:glob_tactic_expr) = pi1 (make_pr_tac glob_printers) t
-
-and pr_glob_tactic0 t = pi2 (make_pr_tac glob_printers) t
-
-and pr_glob_match_context t = pi3 (make_pr_tac glob_printers) t
-
-let (pr_tactic,_,_) =
-  make_pr_tac
-    (pr_glob_tactic,
-     pr_glob_tactic0,
-     Printer.prterm,
-     Printer.pr_pattern,
-     pr_evaluable_reference,
+    (pr_glob_tactic_level, 
+     (fun env -> pr_and_constr_expr (pr_rawconstr_env env)),
+     (fun env -> pr_and_constr_expr (pr_lrawconstr_env env)),
+     (fun c -> pr_lconstr_pattern_env (Global.env()) c),
+     (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))),
+     (fun env -> pr_or_var (pr_inductive env)),
+     pr_ltac_or_var (pr_located pr_ltac_constant),
+     pr_lident,
+     pr_glob_extend,
+     strip_prod_binders_rawterm)
+
+and pr_glob_tactic_level env n (t:glob_tactic_expr) =
+  fst (make_pr_tac glob_printers env) n t
+
+and pr_glob_match_rule env t =
+  snd (make_pr_tac glob_printers env) t
+
+let typed_printers =
+    (pr_glob_tactic_level,
+     pr_constr_env,
+     pr_lconstr_env,
+     pr_lconstr_pattern,
+     pr_evaluable_reference_env,
      pr_inductive,
      pr_ltac_constant,
      pr_id,
-     pr_extend)
+     pr_extend,
+     strip_prod_binders_constr)
+
+let pr_tactic_level env = fst (make_pr_tac typed_printers env)
+
+let pr_raw_tactic env = pr_raw_tactic_level env ltop
+let pr_glob_tactic env = pr_glob_tactic_level env ltop
+let pr_tactic env = pr_tactic_level env ltop
+
+let _ = Tactic_debug.set_tactic_printer
+  (fun x -> pr_glob_tactic (Global.env()) x)
+
+let _ = Tactic_debug.set_match_pattern_printer
+  (fun env hyp -> pr_match_pattern (pr_constr_pattern_env env) hyp)
+
+let _ = Tactic_debug.set_match_rule_printer
+  (fun rl ->
+    pr_match_rule false (pr_glob_tactic (Global.env())) pr_constr_pattern rl)
+
+open Pcoq
+
+let pr_tac_polymorphic n _ _ prtac = prtac (n,E)
+
+let _ = for i=0 to 5 do
+  declare_extra_genarg_pprule
+  (rawwit_tactic i, pr_tac_polymorphic i)
+  (globwit_tactic i, pr_tac_polymorphic i)
+  (wit_tactic i, pr_tac_polymorphic i)
+done
diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli
index 5c3035ba..ccdf3776 100644
--- a/parsing/pptactic.mli
+++ b/parsing/pptactic.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pptactic.mli,v 1.9.2.3 2005/12/23 22:16:46 herbelin Exp $ i*)
+(*i $Id: pptactic.mli 7937 2006-01-28 19:58:11Z herbelin $ i*)
 
 open Pp
 open Genarg
@@ -15,27 +15,33 @@ open Pretyping
 open Proof_type
 open Topconstr
 open Rawterm
+open Ppextend
+open Environ
 
 val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
 val pr_or_metaid : ('a -> std_ppcmds) -> 'a or_metaid -> std_ppcmds
 val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
-val pr_located : ('a -> std_ppcmds) -> 'a Util.located -> std_ppcmds
 
 type 'a raw_extra_genarg_printer =
-    (constr_expr -> std_ppcmds) -> (raw_tactic_expr -> std_ppcmds) ->
-      'a -> std_ppcmds
+    (constr_expr -> std_ppcmds) -> 
+    (constr_expr -> std_ppcmds) -> 
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
 
 type 'a glob_extra_genarg_printer =
-    (rawconstr_and_expr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) ->
-      'a -> std_ppcmds
+    (rawconstr_and_expr -> std_ppcmds) ->
+    (rawconstr_and_expr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
 
 type 'a extra_genarg_printer =
-    (Term.constr -> std_ppcmds) -> (glob_tactic_expr -> std_ppcmds) ->
-      'a -> std_ppcmds
+    (Term.constr -> std_ppcmds) -> 
+    (Term.constr -> std_ppcmds) -> 
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
 
   (* if the boolean is false then the extension applies only to old syntax *)
 val declare_extra_genarg_pprule : 
-  bool ->
   ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) ->
   ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) ->
   ('b closed_abstract_argument_type * 'b extra_genarg_printer) -> unit
@@ -43,44 +49,42 @@ val declare_extra_genarg_pprule :
 type grammar_terminals = string option list
 
   (* if the boolean is false then the extension applies only to old syntax *)
-val declare_extra_tactic_pprule : bool -> string -> 
-  argument_type list * (string * grammar_terminals) -> unit
+val declare_extra_tactic_pprule : 
+  string * argument_type list * (int * grammar_terminals) -> unit
 
 val exists_extra_tactic_pprule : string -> argument_type list -> bool
 
-val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds
-
-val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
-  ('a,'b) match_rule -> std_ppcmds
-
-val pr_glob_tactic : glob_tactic_expr -> std_ppcmds
-
-val pr_tactic : Proof_type.tactic_expr -> std_ppcmds
-
-val pr_glob_generic:
-  (rawconstr_and_expr -> std_ppcmds) -> 
-  (rawconstr_and_expr -> std_ppcmds) -> 
-  (glob_tactic_expr -> std_ppcmds) ->
-    glob_generic_argument -> std_ppcmds
-
 val pr_raw_generic : 
   (constr_expr -> std_ppcmds) ->
   (constr_expr -> std_ppcmds) ->
-  (raw_tactic_expr -> std_ppcmds) ->
+  (tolerability -> raw_tactic_expr -> std_ppcmds) ->
   (Libnames.reference -> std_ppcmds) ->
     (constr_expr, raw_tactic_expr) generic_argument ->
       std_ppcmds
 
 val pr_raw_extend:
   (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) ->
-  (raw_tactic_expr -> std_ppcmds) -> string ->
-    raw_generic_argument list -> std_ppcmds
+  (tolerability -> raw_tactic_expr -> std_ppcmds) -> int ->
+    string -> raw_generic_argument list -> std_ppcmds
 
 val pr_glob_extend:
   (rawconstr_and_expr -> std_ppcmds) -> (rawconstr_and_expr -> std_ppcmds) ->
-  (glob_tactic_expr -> std_ppcmds) -> string ->
-    glob_generic_argument list -> std_ppcmds
+  (tolerability -> glob_tactic_expr -> std_ppcmds) -> int ->
+    string -> glob_generic_argument list -> std_ppcmds
 
 val pr_extend :
   (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) ->
-  (glob_tactic_expr -> std_ppcmds) -> string -> closed_generic_argument list -> std_ppcmds
+  (tolerability -> glob_tactic_expr -> std_ppcmds) -> int ->
+    string -> closed_generic_argument list -> std_ppcmds
+
+val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds
+
+val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds
+ 
+val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
+
+val pr_tactic : env -> Proof_type.tactic_expr -> std_ppcmds
+
+val pr_hintbases : string list option -> std_ppcmds
+
+val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds
diff --git a/translate/ppvernacnew.ml b/parsing/ppvernac.ml
index 2e921c4e..f9b8c425 100644
--- a/translate/ppvernacnew.ml
+++ b/parsing/ppvernac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppvernacnew.ml,v 1.95.2.4 2005/12/23 22:16:56 herbelin Exp $ *)  
+(* $Id: ppvernac.ml 9562 2007-01-31 09:00:36Z msozeau $ *)  
 
 open Pp
 open Names
@@ -15,20 +15,18 @@ open Nametab
 open Util
 open Extend
 open Vernacexpr
-open Ppconstrnew
-open Pptacticnew
+open Ppconstr
+open Pptactic
 open Rawterm
-open Coqast
 open Genarg
 open Pcoq
-open Ast
 open Libnames
 open Ppextend
 open Topconstr
 open Decl_kinds
 open Tacinterp
 
-let pr_spc_type = pr_sep_com spc pr_type
+let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
 
 let pr_lident (b,_ as loc,id) =
   if loc <> dummy_loc then
@@ -36,56 +34,42 @@ let pr_lident (b,_ as loc,id) =
     pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id)
   else pr_id id
 
+let string_of_fqid fqid =
+ String.concat "." (List.map string_of_id fqid)
+
+let pr_fqid fqid = str (string_of_fqid fqid)
+
+let pr_lfqid (_,_ as loc,fqid) =
+  if loc <> dummy_loc then
+   let (b,_) = unloc loc in
+    pr_located pr_fqid (make_loc (b,b+String.length(string_of_fqid fqid)),fqid)
+  else
+   pr_fqid fqid
+
 let pr_lname = function
     (loc,Name id) -> pr_lident (loc,id)
   | lna -> pr_located pr_name lna
 
-let pr_ltac_id id = Nameops.pr_id (id_of_ltac_v7_id id)
-
-let pr_module r =
-  let update_ref s = match r with
-    | Ident (loc,_) ->
-        Ident (loc,id_of_string s)
-    | Qualid (loc,qid) ->
-        Qualid (loc,make_qualid (fst (repr_qualid qid)) (id_of_string s)) in
-  let dir =
-    try
-      Nametab.full_name_module (snd (qualid_of_reference r))
-    with _ -> 
-    try
-      pi2 (Library.locate_qualified_library (snd (qualid_of_reference r)))
-    with _ -> 
-      errorlabstrm "" (str"Translator cannot find " ++ Libnames.pr_reference r)
-  in
-  let r = match List.rev (List.map string_of_id (repr_dirpath dir)) with
-    | [ "Coq"; "Lists"; "List" ] -> update_ref "MonoList"
-    | [ "Coq"; "Lists"; "PolyList" ] -> update_ref "List"
-    | _ -> r in
-  Libnames.pr_reference r
-
-let pr_import_module =
-  (* We assume List is never imported with "Import" ... *)
-  Libnames.pr_reference
-
-let pr_reference = Ppconstrnew.pr_reference
+let pr_ltac_id = Nameops.pr_id
+
+let pr_module = Libnames.pr_reference
+
+let pr_import_module = Libnames.pr_reference
 
 let sep_end () = str"."
 
 (* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *)
-(*
-let pr_raw_tactic_env l env t = 
-  Pptacticnew.pr_raw_tactic env t
-*)
+
 let pr_raw_tactic_env l env t = 
-  Pptacticnew.pr_glob_tactic env (Tacinterp.glob_tactic_env l env t)
+  pr_glob_tactic env (Tacinterp.glob_tactic_env l env t)
 
 let pr_gen env t =
-  Pptactic.pr_raw_generic (Ppconstrnew.pr_constr_env env)
-    (Ppconstrnew.pr_lconstr_env env)
-    (Pptacticnew.pr_raw_tactic env) pr_reference t
+  pr_raw_generic 
+    pr_constr_expr
+    pr_lconstr_expr
+    (pr_raw_tactic_level env) pr_reference t
 
-let pr_raw_tactic tac =
-  pr_raw_tactic_env [] (Global.env()) tac
+let pr_raw_tactic tac = pr_raw_tactic (Global.env()) tac
 
 let rec extract_signature = function
   | [] -> []
@@ -94,8 +78,8 @@ let rec extract_signature = function
 
 let rec match_vernac_rule tys = function
     [] -> raise Not_found
-  | (s,pargs)::rls ->
-      if extract_signature pargs = tys then (s,pargs)
+  | pargs::rls ->
+      if extract_signature pargs = tys then pargs
       else match_vernac_rule tys rls
 
 let sep = fun _ -> spc()
@@ -129,24 +113,19 @@ let pr_set_entry_type = function
   | ETBigint -> str "bigint"
   | ETConstrList _ -> failwith "Internal entry type"
 
-let pr_non_terminal = function
-  | NtQual (u,nt) -> (* no more qualified entries *) str nt
-  | NtShort "constrarg" -> str "constr"
-  | NtShort nt -> str nt
-
 let strip_meta id =
   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 pr_production_item = function
-  | VNonTerm (loc,nt,Some p) -> pr_non_terminal nt ++ str"(" ++ pr_id (strip_meta p) ++ str")"
-  | VNonTerm (loc,nt,None) -> pr_non_terminal nt
-  | VTerm s -> qsnew s
+  | VNonTerm (loc,nt,Some p) -> str nt ++ str"(" ++ pr_id (strip_meta p) ++ str")"
+  | VNonTerm (loc,nt,None) -> str nt
+  | VTerm s -> qs s
 
 let pr_comment pr_c = function
   | CommentConstr c -> pr_c c
-  | CommentString s -> qsnew s
+  | CommentString s -> qs s
   | CommentInt n -> int n
 
 let pr_in_out_modules = function
@@ -156,7 +135,7 @@ let pr_in_out_modules = function
 
 let pr_search_about = function
   | SearchRef r -> pr_reference r
-  | SearchString s -> qsnew s
+  | SearchString s -> qs s
 
 let pr_search a b pr_p = match a with
   | SearchHead qid -> str"Search" ++ spc() ++ pr_reference qid ++ pr_in_out_modules b
@@ -177,7 +156,7 @@ let pr_class_rawexpr = function
 
 let pr_option_ref_value = function
   | QualidRefValue id -> pr_reference id
-  | StringRefValue s -> qsnew s
+  | StringRefValue s -> qs s
 
 let pr_printoption a b = match a with
   | Goptions.PrimaryTable table -> str table ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b
@@ -202,24 +181,17 @@ let pr_opt_hintbases l = match l with
 
 let pr_hints local db h pr_c pr_pat = 
   let opth = pr_opt_hintbases db  in
-  let pr_aux = function
-    | CAppExpl (_,(_,qid),[]) -> pr_reference qid
-    | _ -> mt () in
   let pph =
     match h with
     | HintsResolve l ->
-        str "Resolve " ++
-        prlist_with_sep sep pr_c (List.map snd l)
+        str "Resolve " ++ prlist_with_sep sep pr_c l
     | HintsImmediate l ->
-        str"Immediate" ++ spc() ++
-        prlist_with_sep sep pr_c (List.map snd l)
+        str"Immediate" ++ spc() ++ prlist_with_sep sep pr_c l
     | HintsUnfold l ->
-        str "Unfold " ++
-	prlist_with_sep sep pr_reference (List.map snd l)
-    | HintsConstructors (n,c) ->
-        str"Constructors" ++ spc() ++
-        prlist_with_sep spc pr_reference c
-    | HintsExtern (name,n,c,tac) ->
+        str "Unfold " ++ prlist_with_sep sep pr_reference l
+    | HintsConstructors c ->
+        str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c
+    | HintsExtern (n,c,tac) ->
         str "Extern" ++ spc() ++ int n ++ spc() ++ pr_pat c ++ str" =>" ++
         spc() ++ pr_raw_tactic tac
     | HintsDestruct(name,i,loc,c,tac) ->
@@ -232,9 +204,9 @@ let pr_hints local db h pr_c pr_pat =
 let pr_with_declaration pr_c = function
   | CWith_Definition (id,c) ->
       let p = pr_c c in
-      str"Definition" ++ spc() ++ pr_lident id ++ str" := " ++ p
+      str"Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p
   | CWith_Module (id,qid) ->
-      str"Module" ++ spc() ++ pr_lident id ++ str" := " ++
+      str"Module" ++ spc() ++ pr_lfqid id ++ str" := " ++
       pr_located pr_qualid qid
 
 let rec pr_module_type pr_c = function
@@ -248,7 +220,12 @@ let pr_of_module_type prc (mty,b) =
   str (if b then ":" else "<:") ++
   pr_module_type prc mty
 
-let pr_module_vardecls pr_c (idl,mty) =
+let pr_require_token = function
+  | Some true -> str "Export "
+  | Some false -> str "Import "
+  | None -> mt()
+
+let pr_module_vardecls pr_c (export,idl,mty) =
   let m = pr_module_type pr_c mty in
   (* Update the Nametab for interpreting the body of module/modtype *)
   let lib_dir = Lib.library_dp() in
@@ -258,7 +235,8 @@ let pr_module_vardecls pr_c (idl,mty) =
        Modintern.interp_modtype (Global.env()) mty]) idl;
   (* Builds the stream *)
   spc() ++
-  hov 1 (str"(" ++ prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")")
+  hov 1 (str"(" ++ pr_require_token export ++
+   prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")")
 
 let pr_module_binders l pr_c = 
   (* Effet de bord complexe pour garantir la declaration des noms des
@@ -277,26 +255,13 @@ let rec pr_module_expr = function
       pr_module_expr me1 ++ spc() ++
       hov 1 (str"(" ++ pr_module_expr me2 ++ str")")
 
-(*
-let pr_opt_casted_constr pr_c = function
-  | CCast (loc,c,t) -> pr_c c ++ str":" ++ pr_c t
-  | _ as c -> pr_c c
-*)
-
 let pr_type_option pr_c = function
   | CHole loc -> mt()
   | _ as c -> brk(0,2) ++ str":" ++ pr_c c
 
-let without_translation f x =
-  let old = Options.do_translate () in
-  let oldv7 = !Options.v7 in
-  Options.make_translate false;
-  try let r = f x in Options.make_translate old; Options.v7:=oldv7; r
-  with e -> Options.make_translate old; Options.v7:=oldv7; raise e
-
 let pr_decl_notation prc =
   pr_opt (fun (ntn,c,scopt) -> fnl () ++
-    str "where " ++ qsnew ntn ++ str " := " ++ without_translation prc c ++
+    str "where " ++ qs ntn ++ str " := " ++ prc c ++
     pr_opt (fun sc -> str ": " ++ str sc) scopt)
 
 let pr_vbinders l =
@@ -306,14 +271,13 @@ let pr_binders_arg =
   pr_ne_sep spc pr_binders
 
 let pr_and_type_binders_arg bl =
-  let bl, _ = pr_lconstr_env_n (Global.env()) false bl (CHole dummy_loc) in
   pr_binders_arg bl
 
 let pr_onescheme (id,dep,ind,s) =
   hov 0 (pr_lident id ++ str" :=") ++ spc() ++
   hov 0 ((if dep then str"Induction for" else str"Minimality for")
   ++ spc() ++ pr_reference ind) ++ spc() ++ 
-  hov 0 (str"Sort" ++ spc() ++ pr_sort s)
+  hov 0 (str"Sort" ++ spc() ++ pr_rawsort s)
 
 let begin_of_inductive = function
     [] -> 0
@@ -359,16 +323,7 @@ let pr_ne_params_list pr_c l =
   prlist_with_sep pr_semicolon (pr_params pr_c)
 *)
 
-let pr_thm_token = function
-  | Theorem -> str"Theorem"
-  | Lemma -> str"Lemma"
-  | Fact -> str"Fact"
-  | Remark -> str"Remark"
-
-let pr_require_token = function
-  | Some true -> str " Export"
-  | Some false -> str " Import"
-  | None -> mt()
+let pr_thm_token k = str (string_of_theorem_kind k)
 
 let pr_syntax_modifier = function
   | SetItemLevel (l,NextLevel) ->
@@ -383,23 +338,19 @@ let pr_syntax_modifier = function
   | SetAssoc Gramext.NonA -> str"no associativity"
   | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ
   | SetOnlyParsing -> str"only parsing"
-  | SetFormat s -> str"format " ++ pr_located qsnew s
+  | SetFormat s -> str"format " ++ pr_located qs s
 
 let pr_syntax_modifiers = function
   | [] -> mt()
   | l -> spc() ++ 
       hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")")
 
-let pr_grammar_tactic_rule (name,(s,pil),t) =
-(*
-  hov 0 (
-  (* str name ++ spc() ++ *)
-  hov 0 (str"[" ++ qsnew s ++ spc() ++
-  prlist_with_sep sep pr_production_item pil ++ str"]") ++
-  spc() ++ hov 0 (str"->" ++ spc() ++ str"[" ++ pr_raw_tactic t ++ str"]"))
-*)
-  hov 2 (str "Tactic Notation" ++ spc() ++ 
-    hov 0 (qsnew s ++ spc() ++ prlist_with_sep sep pr_production_item pil ++
+let print_level n =
+  if n <> 0 then str " (at level " ++ int n ++ str ")" else mt ()
+
+let pr_grammar_tactic_rule n (_,pil,t) =
+  hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++ 
+    hov 0 (prlist_with_sep sep pr_production_item pil ++
     spc() ++ str":=" ++ spc() ++ pr_raw_tactic t))
 
 let pr_box b = let pr_boxkind = function
@@ -413,38 +364,10 @@ in str"<" ++ pr_boxkind b ++ str">"
 let pr_paren_reln_or_extern = function
   | None,L -> str"L"
   | None,E -> str"E"
-  | Some pprim,Any -> qsnew pprim
-  | Some pprim,Prec p -> qsnew pprim ++ spc() ++ str":" ++ spc() ++ int p
+  | Some pprim,Any -> qs pprim
+  | Some pprim,Prec p -> qs pprim ++ spc() ++ str":" ++ spc() ++ int p
   | _ -> mt()
 
-let rec pr_next_hunks = function 
-  | UNP_FNL -> str"FNL"
-  | UNP_TAB -> str"TAB"
-  | RO c -> qsnew c
-  | UNP_BOX (b,ll) -> str"[" ++ pr_box b ++ prlist_with_sep sep pr_next_hunks ll ++ str"]"
-  | UNP_BRK (n,m) -> str"[" ++ int n ++ spc() ++ int m ++ str"]"
-  | UNP_TBRK (n,m) -> str"[ TBRK" ++ int n ++ spc() ++ int m ++ str"]"
-  | PH (e,None,_) -> print_ast e
-  | PH (e,Some ext,pr) -> print_ast e ++ spc() ++ str":" ++ spc() ++ pr_paren_reln_or_extern (Some ext,pr)
-  | UNP_SYMBOLIC _ -> mt()
-
-let pr_unparsing u =
-  str "[ " ++ prlist_with_sep sep pr_next_hunks u ++ str " ]"
-
-let pr_astpat a = str"<<" ++ print_ast a ++ str">>"
-
-let pr_syntax_rule (nm,s,u) = str nm ++ spc() ++ str"[" ++ pr_astpat s ++ str"]" ++ spc() ++ str"->" ++ spc() ++ pr_unparsing u
-
-let pr_syntax_entry (p,rl) =
-  str"level" ++ spc() ++ int p ++ str" :" ++ fnl() ++
-  prlist_with_sep (fun _ -> fnl() ++ str"| ") pr_syntax_rule rl
-
-let pr_vernac_solve (i,env,tac,deftac) =
-  (if i = 1 then mt() else int i ++ str ": ") ++
-  Pptacticnew.pr_glob_tactic env tac
-  ++ (try if deftac & Pfedit.get_end_tac() <> None then str ".." else mt ()
-      with UserError _|Stdpp.Exc_located _ -> mt())
-
 (**************************************)
 (* Pretty printer for vernac commands *)
 (**************************************)
@@ -465,6 +388,8 @@ let rec pr_vernac = function
   | VernacAbort id -> str"Abort" ++ pr_opt pr_lident id
   | VernacResume id -> str"Resume" ++ pr_opt pr_lident id
   | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i
+  | VernacBacktrack (i,j,k) -> 
+      str "Backtrack" ++  spc() ++ prlist_with_sep sep int [i;j;k]
   | VernacFocus i -> str"Focus" ++ pr_opt int i
   | VernacGo g -> 
       let pr_goable = function
@@ -484,20 +409,22 @@ let rec pr_vernac = function
 	| ShowTree -> str"Show Tree"
 	| ShowProofNames -> str"Show Conjectures"
 	| ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro")
+	| ShowMatch id -> str"Show Match " ++ pr_lident id
+	| ShowThesis -> str "Show Thesis"
 	| ExplainProof l -> str"Explain Proof" ++ spc() ++ prlist_with_sep sep int l
 	| ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l 
       in pr_showable s
   | VernacCheckGuard -> str"Guarded"
-  | VernacDebug b -> pr_topcmd b
 
   (* Resetting *)
   | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id
   | VernacResetInitial -> str"Reset Initial"
   | VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i
+  | VernacBackTo i -> str"BackTo" ++ pr_intarg i
 
   (* State management *)
-  | VernacWriteState s -> str"Write State" ++ spc () ++ qsnew s
-  | VernacRestoreState s -> str"Restore State" ++ spc() ++ qsnew s
+  | VernacWriteState s -> str"Write State" ++ spc () ++ qs s
+  | VernacRestoreState s -> str"Restore State" ++ spc() ++ qs s
 
   (* Control *)
   | VernacList l ->
@@ -505,28 +432,12 @@ let rec pr_vernac = function
              prlist (fun v -> pr_located pr_vernac v ++ sep_end () ++ fnl()) l
              ++ spc() ++ str"]") 
   | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose"
-  ++ spc()) else spc()  ++ qsnew s
+  ++ spc()) else spc()  ++ qs s
   | VernacTime v -> str"Time" ++ spc() ++ pr_vernac v
   | VernacVar id -> pr_lident id
   
   (* Syntax *) 
-  | VernacGrammar _ -> 
-      msgerrnl (str"Warning : constr Grammar is discontinued; use Notation");
-      str"(* <Warning> : Grammar is replaced by Notation *)"
-  | VernacTacticGrammar l ->
-      prlist_with_sep (fun () -> sep_end() ++ fnl()) pr_grammar_tactic_rule l
-(*
-      hov 1 (str"Grammar tactic simple_tactic :=" ++ spc() ++ prlist_with_sep (fun _ -> brk(1,1) ++ str"|") pr_grammar_tactic_rule l) (***)
-*)      
-  | VernacSyntax (u,el) ->
-      msgerrnl (str"Warning : Syntax is discontinued; use Notation");
-      str"(* <Warning> : Syntax is discontinued" ++ 
-(*
-      fnl () ++
-      hov 1 (str"Syntax " ++ str u ++ spc() ++
-      prlist_with_sep sep_v2 pr_syntax_entry el) ++ 
-*)
-      str " *)"
+  | VernacTacticNotation (n,r,e) -> pr_grammar_tactic_rule n ("",r,e)
   | VernacOpenCloseScope (local,opening,sc) ->
       str (if opening then "Open " else "Close ") ++ pr_locality local ++
       str "Scope" ++ spc() ++ str sc
@@ -536,85 +447,52 @@ let rec pr_vernac = function
   | VernacBindScope (sc,cll) ->
       str"Bind Scope" ++ spc () ++ str sc ++
       spc() ++ str "with " ++ prlist_with_sep spc pr_class_rawexpr cll
-  | VernacArgumentsScope (q,scl) -> let pr_opt_scope = function 
+  | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function 
       |	None -> str"_"
       |	Some sc -> str sc in 
     str"Arguments Scope" ++ spc() ++ pr_reference q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]"
-  | VernacInfix (local,(s,_),q,ov8,sn) -> (* A Verifier *)
-      let s,mv8 = match ov8 with Some smv8 -> smv8 | None -> (s,[]) in
+  | VernacInfix (local,(s,mv),q,sn) -> (* A Verifier *)
       hov 0 (hov 0 (str"Infix " ++ pr_locality local
-      ++ qsnew s ++ str " :=" ++ spc() ++ pr_reference q) ++
-      pr_syntax_modifiers mv8 ++
+      ++ qs s ++ str " :=" ++ spc() ++ pr_reference q) ++
+      pr_syntax_modifiers mv ++
       (match sn with
     | None -> mt()
     | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
-  | VernacDistfix (local,a,p,s,q,sn) ->
-      hov 0 (str"Distfix " ++ pr_locality local ++ pr_entry_prec a ++ int p
-        ++ spc() ++ qsnew s ++ spc() ++ pr_reference q ++ (match sn with
-    | None -> mt()
-    | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
-  | VernacNotation (local,c,sl,mv8,opt) ->
-      let (s,l) = match mv8 with
-          None -> fst (out_some sl), []
-        | Some ml -> ml in
+  | VernacNotation (local,c,(s,l),opt) ->
       let ps =
 	let n = String.length s in
 	if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' 
 	then
           let s' = String.sub s 1 (n-2) in
-          if String.contains s' '\'' then qsnew s else str s'
-	else qsnew s in
+          if String.contains s' '\'' then qs s else str s'
+	else qs s in
       hov 2( str"Notation" ++ spc() ++ pr_locality local ++ ps ++
       str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++
       (match opt with
         | None -> mt()
         | Some sc -> str" :" ++ spc() ++ str sc))
-  | VernacSyntaxExtension (local,sl,mv8) ->
-      let (s,l) = match mv8 with
-          None -> out_some sl
-        | Some ml -> ml in
-      str"Reserved Notation" ++ spc() ++ pr_locality local ++ qsnew s ++
+  | VernacSyntaxExtension (local,(s,l)) ->
+      str"Reserved Notation" ++ spc() ++ pr_locality local ++ qs s ++
       pr_syntax_modifiers l
 
   (* Gallina *)
   | VernacDefinition (d,id,b,f) -> (* A verifier... *)
-      let pr_def_token = function
-        | Local, Coercion -> str"Coercion Local"
-        | Global, Coercion -> str"Coercion"
-        | Local, Definition -> str"Let"
-        | Global, Definition -> str"Definition"
-        | Local, SubClass -> str"Local SubClass"
-        | Global, SubClass -> str"SubClass"
-        | Global, CanonicalStructure -> str"Canonical Structure"
-        | Local, CanonicalStructure ->
-	   anomaly "Don't know how to translate a local canonical structure" in
+      let pr_def_token dk = str (string_of_definition_kind dk) in
       let pr_reduce = function
         | None -> mt()
         | Some r ->
             str"Eval" ++ spc() ++
             pr_red_expr (pr_constr, pr_lconstr, pr_reference) r ++
             str" in" ++ spc() in
-      let mkLambdaCit = List.fold_right (fun (x,a) b -> mkLambdaC(x,a,b)) in
-      let mkProdCit = List.fold_right (fun (x,a) b -> mkProdC(x,a,b)) in
       let pr_def_body = function
-        | DefineBody (bl,red,c,d) ->
-            let (bl2,body,ty) = match d with
-              | None ->
-                  let bl2,body = extract_lam_binders c in
-                  (bl2,body,mt())
-              | Some ty ->
-                  let bl2,body,ty' = extract_def_binders c ty in
-                  (bl2,CCast (dummy_loc,body,ty'),
-                   spc() ++ str":" ++
-                   pr_sep_com spc
-                     (pr_type_env_n (Global.env()) (bl@bl2)) ty') in
-	    let iscast = d <> None in
-            let bindings,ppred =
-	      pr_lconstr_env_n (Global.env()) iscast (bl@bl2) body in
-            (pr_binders_arg bindings,ty,Some (pr_reduce red ++ ppred))
+        | DefineBody (bl,red,body,d) ->
+            let ty = match d with
+              | None -> mt()
+              | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty
+	    in
+            (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body))
         | ProveBody (bl,t) ->
-            (pr_and_type_binders_arg bl, str" :" ++ pr_spc_type t, None)
-      in
+            (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in
       let (binds,typ,c) = pr_def_body b in
       hov 2 (pr_def_token d ++ spc() ++ pr_lident id ++ binds ++ typ ++
       (match c with
@@ -626,7 +504,7 @@ let rec pr_vernac = function
       (match bl with
         | [] -> mt()
         | _ -> pr_binders bl ++ spc())
-      ++ str":" ++ pr_spc_type (rename_bound_variables (snd id) c))
+      ++ str":" ++ pr_spc_lconstr c)
   | VernacEndProof Admitted -> str"Admitted"
   | VernacEndProof (Proved (opac,o)) -> (match o with
     | None -> if opac then str"Qed" else str"Defined"
@@ -636,75 +514,16 @@ let rec pr_vernac = function
   | VernacExactProof c ->
       hov 2 (str"Proof" ++ pr_lconstrarg c)
   | VernacAssumption (stre,l) ->
+      let n = List.length (List.flatten (List.map fst (List.map snd l))) in
       hov 2
-        (pr_assumption_token (List.length l > 1) stre ++ spc() ++ 
-	 pr_ne_params_list pr_type l)
+        (pr_assumption_token (n > 1) stre ++ spc() ++ 
+	 pr_ne_params_list pr_lconstr_expr l)
   | VernacInductive (f,l) ->
 
-      (* Copie simplifiée de command.ml pour recalculer les implicites, *)
-      (* les notations, et le contexte d'evaluation *)
-      let lparams = match l with [] -> assert false | (_,_,la,_,_)::_ -> la in
-      let nparams = local_binders_length lparams
-      and sigma = Evd.empty 
-      and env0 = Global.env() in
-      let (env_params,params) =
-	List.fold_left
-	  (fun (env,params) d -> match d with
-	    | LocalRawAssum (nal,t) ->
-		let t = Constrintern.interp_type sigma env t in
-		let ctx = list_map_i (fun i (_,na) -> (na,None,Term.lift i t)) 0 nal
-		in let ctx = List.rev ctx in
-		(Environ.push_rel_context ctx env, ctx@params)
-	    | LocalRawDef ((_,na),c) ->
-		let c = Constrintern.judgment_of_rawconstr sigma env c in
-		let d = (na, Some c.Environ.uj_val, c.Environ.uj_type) in
-		(Environ.push_rel d env,d::params))
-	  (env0,[]) lparams in
-
-      let (ind_env,ind_impls,arityl) =
-        List.fold_left
-          (fun (env, ind_impls, arl) ((_,recname), _, _, arityc, _) ->
-            let arity = Constrintern.interp_type sigma env_params arityc in
-	    let fullarity = Termops.it_mkProd_or_LetIn arity params in
-	    let env' = Termops.push_rel_assum (Name recname,fullarity) env in
-	    let impls = 
-	      if Impargs.is_implicit_args()
-	      then Impargs.compute_implicits false env_params fullarity
-	      else [] in
-	    (env', (recname,impls)::ind_impls, (arity::arl)))
-          (env0, [], []) l
-      in
-      let lparnames = List.map (fun (na,_,_) -> na) params in
-      let notations = 
-	List.fold_right (fun (_,ntnopt,_,_,_) l ->option_cons ntnopt l) l [] in
-      let ind_env_params = Environ.push_rel_context params ind_env in
-
-      let lparnames = List.map (fun (na,_,_) -> na) params in
-      let impl = List.map
-	(fun ((_,recname),_,_,arityc,_) ->
-	  let arity = Constrintern.interp_type sigma env_params arityc in
-	  let fullarity =
-            Termops.prod_it arity (List.map (fun (id,_,ty) -> (id,ty)) params)
-	  in
-	  let impl_in =
-	    if Impargs.is_implicit_args()
-	    then Impargs.compute_implicits false env_params fullarity
-	    else [] in
-	  let impl_out =
-	    if Impargs.is_implicit_args_out()
-	    then Impargs.compute_implicits true env_params fullarity
-	    else [] in
-	  (recname,impl_in,impl_out)) l in
-      let impls_in = List.map (fun (id,a,_) -> (id,a)) impl in
-      let impls_out = List.map (fun (id,_,a) -> (id,a)) impl in
-      Constrintern.set_temporary_implicits_in impls_in;
-      Constrextern.set_temporary_implicits_out impls_out;
-      (* Fin calcul implicites *)
-
       let pr_constructor (coe,(id,c)) =
         hov 2 (pr_lident id ++ str" " ++
                (if coe then str":>" else str":") ++
-                pr_sep_com spc (pr_type_env_n ind_env_params []) c) in
+                pr_spc_lconstr c) in
       let pr_constructor_list l = match l with
         | [] -> mt()
         | _ ->
@@ -712,102 +531,73 @@ let rec pr_vernac = function
             fnl() ++
             str (if List.length l = 1 then "   " else " | ") ++
             prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l in
-      let pr_oneind key (id,ntn,indpar,s,lc) =
+      let pr_oneind key ((id,indpar,s,lc),ntn) =
 	hov 0 (
           str key ++ spc() ++
           pr_lident id ++ pr_and_type_binders_arg indpar ++ spc() ++ str":" ++ 
-	  spc() ++ pr_type s ++ 
+	  spc() ++ pr_lconstr_expr s ++ 
 	  str" :=") ++ pr_constructor_list lc ++ 
 	pr_decl_notation pr_constr ntn in
 
-      (* Copie simplifiée de command.ml pour déclarer les notations locales *)
-      List.iter (fun (df,c,scope) ->
- 	Metasyntax.add_notation_interpretation df [] c scope) notations;
-
       hov 1 (pr_oneind (if f then "Inductive" else "CoInductive") (List.hd l))
       ++ 
       (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
 
 
-  | VernacFixpoint recs ->
-
-      (* Copie simplifiée de command.ml pour recalculer les implicites *)
-      (* les notations, et le contexte d'evaluation *)
-      let sigma = Evd.empty
-      and env0 = Global.env() in
-      let notations = 
-	List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) recs [] in
-      let impl = List.map
-        (fun ((recname,_, bl, arityc,_),_) -> 
-          let arity =
-            Constrintern.interp_type sigma env0
-              (prod_constr_expr arityc bl) in
-	  let impl_in =
-	    if Impargs.is_implicit_args()
-	    then Impargs.compute_implicits false env0 arity
-	    else [] in
-	  let impl_out =
-	    if Impargs.is_implicit_args_out()
-	    then Impargs.compute_implicits true env0 arity
-	    else [] in
-	  (recname,impl_in,impl_out)) recs in
-      let impls_in = List.map (fun (id,a,_) -> (id,a)) impl in
-      let impls_out = List.map (fun (id,_,a) -> (id,a)) impl in
-      Constrintern.set_temporary_implicits_in impls_in;
-      Constrextern.set_temporary_implicits_out impls_out;
-
-      (* Copie simplifiée de command.ml pour déclarer les notations locales *)
-      List.iter (fun (df,c,scope) ->
-	Metasyntax.add_notation_interpretation df [] c None) notations;
-
-      let rec_sign = 
-        List.fold_left 
-          (fun env ((recname,_,bl,arityc,_),_) -> 
-            let arity =
-              Constrintern.interp_type sigma env0
-                (prod_constr_expr arityc bl) in
-            Environ.push_named (recname,None,arity) env)
-          (Global.env()) recs in
-      
+  | VernacFixpoint (recs,b) ->
       let name_of_binder = function
         | LocalRawAssum (nal,_) -> nal
         | LocalRawDef (_,_) -> [] in
       let pr_onerec = function
-        | (id,n,bl,type_,def),ntn ->
+        | (id,(n,ro),bl,type_,def),ntn ->
             let (bl',def,type_) =
               if Options.do_translate() then extract_def_binders def type_
               else ([],def,type_) in
             let bl = bl @ bl' in
             let ids = List.flatten (List.map name_of_binder bl) in
-            let name =
-              try snd (List.nth ids n)
-              with Failure _ ->
-                warn (str "non-printable fixpoint \""++pr_id id++str"\"");
-                Anonymous in
             let annot =
-              if List.length ids > 1 then 
-                spc() ++ str "{struct " ++ pr_name name ++ str"}"
-              else mt() in
-	    let bl,ppc =
-              pr_lconstr_env_n rec_sign true bl (CCast(dummy_loc,def,type_)) in
+	      match n with 
+		| None -> mt () 
+		| Some n -> 
+		    let name =
+		      try snd (List.nth ids n)
+		      with Failure _ ->
+			warn (str "non-printable fixpoint \""++pr_id id++str"\"");
+			Anonymous in
+		    match (ro : Topconstr.recursion_order_expr) with
+			CStructRec -> 
+			  if List.length ids > 1 then 
+			    spc() ++ str "{struct " ++ pr_name name ++ str"}"
+			  else mt()
+		      | CWfRec c -> 
+			  spc() ++ str "{wf " ++ pr_lconstr_expr c ++ spc() ++ 
+			    pr_name name ++ str"}"
+		      | CMeasureRec c -> 
+			  spc() ++ str "{measure " ++ pr_lconstr_expr c ++ spc() ++ 
+			    pr_name name ++ str"}"
+	    in
             pr_id id ++ pr_binders_arg bl ++ annot ++ spc()
-            ++ pr_type_option (fun c -> spc() ++ pr_type c) type_
-            ++ str" :=" ++ brk(1,1) ++ ppc ++ 
+            ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
+            ++ str" :=" ++ brk(1,1) ++ pr_lconstr def ++ 
 	    pr_decl_notation pr_constr ntn
       in
-      hov 1 (str"Fixpoint" ++ spc() ++
+      let start = if b then "Boxed Fixpoint" else "Fixpoint" in
+      hov 1 (str start ++ spc() ++
         prlist_with_sep (fun _ -> fnl() ++ fnl() ++ str"with ") pr_onerec recs)
 
-  | VernacCoFixpoint corecs ->
-      let pr_onecorec (id,bl,c,def) =
+  | VernacCoFixpoint (corecs,b) ->
+      let pr_onecorec ((id,bl,c,def),ntn) =
         let (bl',def,c) =
               if Options.do_translate() then extract_def_binders def c
               else ([],def,c) in
         let bl = bl @ bl' in
         pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
-        spc() ++ pr_type c ++
-        str" :=" ++ brk(1,1) ++ pr_lconstr def in
-      hov 1 (str"CoFixpoint" ++ spc() ++
+        spc() ++ pr_lconstr_expr c ++
+        str" :=" ++ brk(1,1) ++ pr_lconstr def  ++ 
+	pr_decl_notation pr_constr ntn
+      in
+      let start = if b then "Boxed CoFixpoint" else "CoFixpoint" in
+      hov 1 (str start ++ spc() ++
       prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs)  
   | VernacScheme l ->
       hov 2 (str"Scheme" ++ spc() ++
@@ -819,20 +609,20 @@ let rec pr_vernac = function
         | (oc,AssumExpr (id,t)) ->
             hov 1 (pr_lname id ++
             (if oc then str" :>" else str" :") ++ spc() ++
-            pr_type t)
+            pr_lconstr_expr t)
         | (oc,DefExpr(id,b,opt)) -> (match opt with
 	    | Some t ->
                 hov 1 (pr_lname id ++
                 (if oc then str" :>" else str" :") ++ spc() ++
-                pr_type t ++ str" :=" ++ pr_lconstr b)
+                pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
 	    | None ->
                 hov 1 (pr_lname id ++ str" :=" ++ spc() ++
                 pr_lconstr b)) in
       hov 2
         (str (if b then "Record" else "Structure") ++
          (if oc then str" > " else str" ") ++ pr_lident name ++ 
-          pr_and_type_binders_arg ps ++ str" :" ++ spc() ++ pr_type s ++ 
-	  str" := " ++
+          pr_and_type_binders_arg ps ++ str" :" ++ spc() ++ 
+	  pr_lconstr_expr s ++ str" := " ++
          (match c with
            | None -> mt()
            | Some sc -> pr_lident sc) ++
@@ -841,7 +631,7 @@ let rec pr_vernac = function
   | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id)
   | VernacEndSegment id -> hov 2 (str"End" ++ spc() ++ pr_lident id)
   | VernacRequire (exp,spe,l) -> hov 2
-      (str "Require" ++ pr_require_token exp ++ spc() ++
+      (str "Require" ++ spc() ++ pr_require_token exp ++
       (match spe with
       |	None -> mt()
       |	Some flag ->
@@ -866,16 +656,17 @@ let rec pr_vernac = function
 	spc() ++ pr_class_rawexpr c2)
 
   (* Modules and Module Types *)
-  | VernacDefineModule (m,bl,ty,bd) ->
+  | VernacDefineModule (export,m,bl,ty,bd) ->
       let b = pr_module_binders_list bl pr_lconstr in 
-      hov 2 (str"Module " ++ pr_lident m ++ b ++
+      hov 2 (str"Module" ++ spc() ++ pr_require_token export ++
+             pr_lident m ++ b ++
              pr_opt (pr_of_module_type pr_lconstr) ty ++
              pr_opt (fun me -> str ":= " ++ pr_module_expr me) bd)
-  | VernacDeclareModule (id,bl,m1,m2) ->
+  | VernacDeclareModule (export,id,bl,m1) ->
       let b = pr_module_binders_list bl pr_lconstr in 
-      hov 2 (str"Declare Module " ++ pr_lident id ++ b ++
-             pr_opt (pr_of_module_type pr_lconstr) m1 ++
-             pr_opt (fun me -> str ":= " ++ pr_module_expr me) m2)
+      hov 2 (str"Declare Module" ++ spc() ++ pr_require_token export ++
+             pr_lident id ++ b ++
+             pr_of_module_type pr_lconstr m1)
   | VernacDeclareModuleType (id,bl,m) ->
       let b = pr_module_binders_list bl pr_lconstr in 
       hov 2 (str"Module Type " ++ pr_lident id ++ b ++
@@ -883,39 +674,43 @@ let rec pr_vernac = function
 
   (* Solving *)
   | VernacSolve (i,tac,deftac) ->
-      (* Normally shunted by vernac.ml *)
-      let env =
-        try snd (Pfedit.get_goal_context i)
-        with UserError _ -> Global.env() in
-      let tac = 
-	Options.with_option Options.translate_syntax 
-	  (Constrintern.for_grammar (Tacinterp.glob_tactic_env [] env)) tac in
-      pr_vernac_solve (i,env,tac,deftac)
+      (if i = 1 then mt() else int i ++ str ": ") ++
+      pr_raw_tactic tac
+      ++ (try if deftac & Pfedit.get_end_tac() <> None then str ".." else mt ()
+      with UserError _|Stdpp.Exc_located _ -> mt())
 
   | VernacSolveExistential (i,c) ->
       str"Existential " ++ int i ++ pr_lconstrarg c
 
+  (* MMode *)
+ 
+  | VernacProofInstr instr -> anomaly "Not implemented"
+  | VernacDeclProof -> str "proof" 
+  | VernacReturn -> str "return"
+
+  (* /MMode *) 
+
   (* Auxiliary file and library management *)
   | VernacRequireFrom (exp,spe,f) -> hov 2
-      (str"Require " ++ pr_require_token exp ++ spc() ++
+      (str"Require" ++ spc() ++ pr_require_token exp ++
       (match spe with
         | None -> mt()
         | Some false -> str"Implementation" ++ spc()
         | Some true -> str"Specification" ++ spc ()) ++
-      qsnew f)
+      qs f)
   | VernacAddLoadPath (fl,s,d) -> hov 2
       (str"Add" ++
        (if fl then str" Rec " else spc()) ++
-       str"LoadPath" ++ spc() ++ qsnew s ++
+       str"LoadPath" ++ spc() ++ qs s ++
        (match d with 
          | None -> mt()
          | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) 
-  | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qsnew s
+  | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qs s
   | VernacAddMLPath (fl,s) ->
-      str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qsnew s
+      str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qs s
   | VernacDeclareMLModule l ->
-      hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qsnew l)
-  | VernacChdir s -> str"Cd" ++ pr_opt qsnew s
+      hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l)
+  | VernacChdir s -> str"Cd" ++ pr_opt qs s
 
   (* Commands *)
   | VernacDeclareTacticDefinition (rc,l) ->
@@ -940,47 +735,28 @@ let rec pr_vernac = function
 	    (* Rec by default *) str "Ltac ") ++
         prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l)
   | VernacHints (local,dbnames,h) ->
-      pr_hints local dbnames h pr_constr pr_pattern
+      pr_hints local dbnames h pr_constr pr_pattern_expr
   | VernacSyntacticDefinition (id,c,local,onlyparsing) ->
       hov 2
         (str"Notation " ++ pr_locality local ++ pr_id id ++ str" :=" ++
          pr_constrarg c ++
          pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else []))
-  | VernacDeclareImplicits (q,None) ->
+  | VernacDeclareImplicits (local,q,None) ->
       hov 2 (str"Implicit Arguments" ++ spc() ++ pr_reference q)
-  | VernacDeclareImplicits (q,Some l) ->
+  | VernacDeclareImplicits (local,q,Some l) ->
       let r = Nametab.global q in
-      Impargs.declare_manual_implicits r l;
+      Impargs.declare_manual_implicits local r l;
       let imps = Impargs.implicits_of_global r in
       hov 1 (str"Implicit Arguments" ++ spc() ++ pr_reference q ++ spc() ++
              str"[" ++ prlist_with_sep sep (pr_explanation imps) l ++ str"]")
   | VernacReserve (idl,c) ->
       hov 1 (str"Implicit Type" ++
         str (if List.length idl > 1 then "s " else " ") ++
-        prlist_with_sep spc pr_lident idl ++ str " :" ++ spc () ++ pr_type c)
+        prlist_with_sep spc pr_lident idl ++ str " :" ++ spc () ++
+        pr_lconstr c)
   | VernacSetOpacity (fl,l) ->
       hov 1 ((if fl then str"Opaque" else str"Transparent") ++
              spc() ++ prlist_with_sep sep pr_reference l)
-
-  | VernacSetOption (Goptions.SecondaryTable ("Implicit","Arguments"),BoolValue true) -> 
-      str"Set Implicit Arguments" 
-      ++
-      (if !Options.translate_strict_impargs then
-	sep_end () ++ fnl () ++ str"Unset Strict Implicit"
-      else mt ())
-  | VernacUnsetOption (Goptions.SecondaryTable ("Implicit","Arguments"))
-  | VernacSetOption (Goptions.SecondaryTable ("Implicit","Arguments"),BoolValue false) -> 
-      (if !Options.translate_strict_impargs then
-	str"Set Strict Implicit" ++ sep_end () ++ fnl ()
-      else mt ())
-      ++
-      str"Unset Implicit Arguments" 
-
-  | VernacSetOption (Goptions.SecondaryTable (a,"Implicits"),BoolValue true) ->
-      str("Set "^a^" Implicit")
-  | VernacUnsetOption (Goptions.SecondaryTable (a,"Implicits")) -> 
-      str("Unset "^a^" Implicit")
-
   | VernacUnsetOption na ->
       hov 1 (str"Unset" ++ spc() ++ pr_printoption na None)
   | VernacSetOption (na,v) -> hov 2 (str"Set" ++ spc() ++ pr_set_option na v)
@@ -1013,34 +789,37 @@ let rec pr_vernac = function
 	| PrintMLModules -> str"Print ML Modules"
 	| PrintGraph -> str"Print Graph"
 	| PrintClasses -> str"Print Classes"
+	| PrintLtac qid -> str"Print Ltac" ++ spc() ++ pr_reference qid
 	| PrintCoercions -> str"Print Coercions"
 	| PrintCoercionPaths (s,t) -> str"Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t
+	| PrintCanonicalConversions -> str"Print Canonical Structures"
 	| PrintTables -> str"Print Tables"
 	| PrintOpaqueName qid -> str"Print Term" ++ spc() ++ pr_reference qid
 	| PrintHintGoal -> str"Print Hint"
 	| PrintHint qid -> str"Print Hint" ++ spc() ++ pr_reference qid
 	| PrintHintDb -> str"Print Hint *"
 	| PrintHintDbName s -> str"Print HintDb" ++ spc() ++ str s
+	| PrintRewriteHintDbName s -> str"Print Rewrite HintDb" ++ spc() ++ str s
 	| PrintUniverses fopt -> str"Dump Universes" ++ pr_opt str fopt
 	| PrintName qid -> str"Print" ++ spc()  ++ pr_reference qid
-	| PrintLocalContext -> assert false
-            (* str"Print" *) 
 	| PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid
 	| PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid
 	| PrintInspect n -> str"Inspect" ++ spc() ++ int n
+  | PrintSetoids -> str"Print Setoids"
 	| PrintScopes -> str"Print Scopes"
 	| PrintScope s -> str"Print Scope" ++ spc() ++ str s 
 	| PrintVisibility s -> str"Print Visibility" ++ pr_opt str s 
 	| PrintAbout qid -> str"About" ++ spc()  ++ pr_reference qid
 	| PrintImplicit qid -> str"Print Implicit" ++ spc()  ++ pr_reference qid
       in pr_printable p
-  | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_pattern
-  | VernacLocate loc ->
+  | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_pattern_expr
+  | VernacLocate loc -> 
       let pr_locate =function
 	| LocateTerm qid ->  pr_reference qid
-	| LocateFile f -> str"File" ++ spc() ++ qsnew f
+	| LocateFile f -> str"File" ++ spc() ++ qs f
 	| LocateLibrary qid -> str"Library" ++ spc () ++ pr_module qid
-	| LocateNotation s -> qsnew s
+	| LocateModule qid -> str"Module" ++ spc () ++ pr_module qid
+	| LocateNotation s -> qs s
       in str"Locate" ++ spc() ++ pr_locate loc
   | VernacComments l ->
       hov 2
@@ -1052,9 +831,7 @@ let rec pr_vernac = function
 
   (* For extension *)
   | VernacExtend (s,c) -> pr_extend s c
-  | VernacV7only _ -> mt()
-  | VernacV8only com -> pr_vernac com
-  | VernacProof Tacexpr.TacId _ -> str "Proof"
+  | VernacProof (Tacexpr.TacId _) -> str "Proof"
   | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te 
 
 and pr_extend s cl =
@@ -1062,18 +839,15 @@ and pr_extend s cl =
     try pr_gen (Global.env()) a
     with Failure _ -> str ("<error in "^s^">") in
   try
-    (* Hack pour les syntaxes changeant non uniformément en passant a la V8 *)
-    let s =
-      let n = String.length s in
-      if Options.do_translate() & n > 2 & String.sub s (n-2) 2 = "V7"
-      then String.sub s 0 (n-2) ^ "V8"
-      else s in
-    (* "Hint Rewrite in using" changes the order of its args in v8 !! *)
-    let cl = match s, cl with
-      | "HintRewriteV8", [a;b;c;d] -> [a;b;d;c]
-      | _ -> cl in
     let rls = List.assoc s (Egrammar.get_extend_vernac_grammars()) in
-    let (hd,rl) = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in
+    let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in
+    let start,rl,cl =
+      match rl with
+	| Egrammar.TacTerm s :: rl -> str s, rl, cl
+	| Egrammar.TacNonTerm _ :: rl ->
+	    (* Will put an unnecessary extra space in front *)
+	    pr_gen (Global.env()) (List.hd cl), rl, List.tl cl 
+	| [] -> anomaly "Empty entry" in
     let (pp,_) =
       List.fold_left
         (fun (strm,args) pi ->
@@ -1082,45 +856,11 @@ and pr_extend s cl =
                 (strm ++ pr_gen (Global.env()) (List.hd args),
                 List.tl args)
             | Egrammar.TacTerm s -> (strm ++ spc() ++ str s, args))
-        (str hd,cl) rl in
+        (start,cl) rl in
     hov 1 pp
-    ++ (if s = "Correctness" then sep_end () ++ fnl() ++ str "Proof" else mt())
   with Not_found ->
     hov 1 (str ("TODO("^s) ++ prlist_with_sep sep pr_arg cl ++ str ")")
 
 in pr_vernac
 
-let pr_vernac = make_pr_vernac Ppconstrnew.pr_constr Ppconstrnew.pr_lconstr
-
-let pr_vernac = function
-  | VernacRequire (_,_,[Ident(_,r)]) when
-      (* Obsolete modules *)
-      List.mem (string_of_id r)
-	["Refine"; "Inv"; "Equality"; "EAuto"; "AutoRewrite"; "EqDecide"; 
-         "Xml"; "Extraction"; "Tauto"; "Setoid_replace";"Elimdep";
-	 "DatatypesSyntax"; "LogicSyntax"; "Logic_TypeSyntax";
-	 "SpecifSyntax"; "PeanoSyntax"; "TypeSyntax"; "PolyListSyntax";
-	 "Zsyntax"] ->
-      warning ("Forgetting obsolete module "^(string_of_id r));
-      mt()
-  | VernacRequire (exp,spe,[Ident(_,r)]) when
-      (* Renamed modules *)
-      List.mem (string_of_id r) ["zarith_aux";"fast_integer"] ->
-      warning ("Replacing obsolete module "^(string_of_id r)^" with ZArith");
-	(str "Require" ++ pr_require_token exp ++ spc() ++
-	(match spe with
-	  | None -> mt()
-	  | Some flag ->
-	      (if flag then str"Specification" else str"Implementation") ++
-	      spc ()) ++
-	str "ZArith.")
-  | VernacImport (false,[Libnames.Ident (_,a)]) when
-      (* Pour ceux qui ont utilisé la couche "Import *_scope" de compat *)
-      let a = Names.string_of_id a in
-      a = "nat_scope" or a = "Z_scope" or a = "R_scope" -> mt()
-  | VernacSyntax _  | VernacGrammar _ as x -> pr_vernac x
-  | VernacPrint PrintLocalContext -> 
-      warning ("\"Print.\" is discontinued");
-      mt ()
-  | x -> pr_vernac x ++ sep_end ()
-
+let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end ()
diff --git a/translate/ppvernacnew.mli b/parsing/ppvernac.mli
index 4506b811..21d983f5 100644
--- a/translate/ppvernacnew.mli
+++ b/parsing/ppvernac.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
  
-(*i $Id: ppvernacnew.mli,v 1.3.2.2 2005/01/21 17:17:20 herbelin Exp $ i*)
+(*i $Id: ppvernac.mli 7744 2005-12-27 09:16:06Z herbelin $ i*)
 
 open Pp
 open Genarg
@@ -15,13 +15,10 @@ open Names
 open Nameops
 open Nametab
 open Util
-open Extend
 open Ppconstr
 open Pptactic
 open Rawterm
-open Coqast
 open Pcoq
-open Ast
 open Libnames
 open Ppextend
 open Topconstr
@@ -29,6 +26,3 @@ open Topconstr
 val sep_end : unit -> std_ppcmds
 
 val pr_vernac : vernac_expr -> std_ppcmds
-
-val pr_vernac_solve : 
-  int * Environ.env * Tacexpr.glob_tactic_expr * bool -> std_ppcmds
diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml
index 1505745c..57028469 100644
--- a/parsing/prettyp.ml
+++ b/parsing/prettyp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: prettyp.ml,v 1.50.2.2 2005/11/21 09:16:28 herbelin Exp $ *)
+(* $Id: prettyp.ml 9314 2006-10-29 20:11:08Z herbelin $ *)
 
 open Pp
 open Util
@@ -20,7 +20,6 @@ open Inductiveops
 open Sign
 open Reduction
 open Environ
-open Instantiate
 open Declare
 open Impargs
 open Libobject
@@ -28,6 +27,7 @@ open Printer
 open Printmod
 open Libnames
 open Nametab
+open Recordops
 
 (*********************)
 (** Basic printing   *)
@@ -58,8 +58,7 @@ let print_impl_args_by_name = function
       str" are implicit" ++ fnl()
 
 let print_impl_args l = 
-  if !Options.v7 then print_impl_args_by_pos (positions_of_implicits l)
-  else print_impl_args_by_name (List.filter is_status_implicit l)
+  print_impl_args_by_name (List.filter is_status_implicit l)
 
 (*********************)
 (** Printing Scopes  *)
@@ -71,7 +70,7 @@ let print_ref reduce ref =
       let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ
       in it_mkProd_or_LetIn ccl ctx 
     else typ in
-  hov 0 (pr_global ref ++ str " :" ++ spc () ++ prtype typ) ++ fnl ()
+  hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ) ++ fnl ()
 
 let print_argument_scopes = function
   | [Some sc] -> str"Argument scope is [" ++ str sc ++ str"]" ++ fnl()
@@ -89,9 +88,32 @@ let need_expansion impl ref =
   impl <> [] & let _,lastimpl = list_chop nprods impl in
   List.filter is_status_implicit lastimpl <> []
 
+type opacity =
+  | FullyOpaque
+  | TransparentMaybeOpacified of bool
+
+let opacity env = function
+  | VarRef v when pi2 (Environ.lookup_named v env) <> None -> 
+      Some (TransparentMaybeOpacified (Conv_oracle.is_opaque_var v))
+  | ConstRef cst ->
+      let cb = Environ.lookup_constant cst env in
+      if cb.const_body = None then None
+      else if cb.const_opaque then Some FullyOpaque
+      else Some (TransparentMaybeOpacified (Conv_oracle.is_opaque_cst cst))
+  | _ -> None
+
+let print_opacity ref =
+  match opacity (Global.env()) ref with
+    | None -> mt ()
+    | Some s -> pr_global ref ++ str " is " ++ 
+        str (match s with
+          | FullyOpaque -> "opaque"
+          | TransparentMaybeOpacified true -> "basically transparent but considered opaque for reduction"
+          | TransparentMaybeOpacified false -> "transparent") ++ fnl()
+    
 let print_name_infos ref =
   let impl = implicits_of_global ref in
-  let scopes = Symbols.find_arguments_scope ref in
+  let scopes = Notation.find_arguments_scope ref in
   let type_for_implicit = 
     if need_expansion impl ref then
       (* Need to reduce since implicits are computed with products flattened *)
@@ -127,7 +149,7 @@ let print_inductive_implicit_args =
 
 let print_inductive_argument_scopes =
   print_args_data_of_inductive_ids 
-    Symbols.find_arguments_scope ((<>) None) print_argument_scopes
+    Notation.find_arguments_scope ((<>) None) print_argument_scopes
 
 (*********************)
 (* "Locate" commands *)
@@ -160,8 +182,7 @@ let pr_located_qualid = function
 	| VarRef _ -> "Variable" in
       str ref_str ++ spc () ++ pr_sp (Nametab.sp_of_global ref)
   | Syntactic kn ->
-      str (if !Options.v7 then "Syntactic Definition" else "Notation") ++ 
-      spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn)
+      str "Notation" ++ spc () ++ pr_sp (Nametab.sp_of_syntactic_definition kn)
   | Dir dir ->
       let s,dir = match dir with
 	| DirOpenModule (dir,_) -> "Open Module", dir
@@ -180,9 +201,9 @@ let print_located_qualid ref =
   let (loc,qid) = qualid_of_reference ref in
   let module N = Nametab in
   let expand = function
-    | TrueGlobal ref -> 
+    | TrueGlobal ref ->
 	Term ref, N.shortest_qualid_of_global Idset.empty ref
-    | SyntacticDef kn -> 
+    | SyntacticDef kn ->
 	Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in
   match List.map expand (N.extended_locate_all qid) with
     | [] -> 
@@ -196,7 +217,7 @@ let print_located_qualid ref =
 	(fun (o,oqid) ->
 	  hov 2 (pr_located_qualid o ++
 	  (if oqid <> qid then
-	    spc() ++ str "(visible as " ++ pr_qualid oqid ++ str")"
+	    spc() ++ str "(shorter name to refer to it in current context is " ++ pr_qualid oqid ++ str")"
 	  else
 	    mt ()))) l
 
@@ -204,8 +225,8 @@ let print_located_qualid ref =
 (**** Printing declarations and judgments *)
 
 let print_typed_value_in_env env (trm,typ) =
-  (prterm_env env trm ++ fnl () ++
-     str "     : " ++ prtype_env env typ ++ fnl ())
+  (pr_lconstr_env env trm ++ fnl () ++
+     str "     : " ++ pr_ltype_env env typ ++ fnl ())
 
 let print_typed_value x = print_typed_value_in_env (Global.env ()) x
 
@@ -218,20 +239,21 @@ let print_safe_judgment env j =
   print_typed_value_in_env env (trm, typ)
     
 (* To be improved; the type should be used to provide the types in the
-   abstractions. This should be done recursively inside prterm, so that
+   abstractions. This should be done recursively inside pr_lconstr, so that
    the pretty-print of a proposition (P:(nat->nat)->Prop)(P [u]u)
    synthesizes the type nat of the abstraction on u *)
 
 let print_named_def name body typ =
-  let pbody = prterm body in
-  let ptyp = prtype typ in
+  let pbody = pr_lconstr body in
+  let ptyp = pr_ltype typ in
+  let pbody = if isCast body then surround pbody else pbody in
   (str "*** [" ++ str name ++ str " " ++
      hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++
 	      str ":" ++ brk (1,2) ++ ptyp) ++
 	   str "]" ++ fnl ())
 
 let print_named_assum name typ =
-  (str "*** [" ++ str name ++ str " : " ++ prtype typ ++ str "]" ++ fnl ())
+  (str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" ++ fnl ())
 
 let print_named_decl (id,c,typ) =
   let s = string_of_id id in
@@ -246,28 +268,26 @@ let assumptions_for_print lna =
 (* *)
 
 let print_params env params =
-  if List.length params = 0 then 
-    (mt ()) 
-  else
-    if !Options.v7 then
-      (str "[" ++ pr_rel_context env params ++ str "]" ++ brk(1,2))
-    else 
-      (pr_rel_context env params ++ brk(1,2))
+  if params = [] then mt () else pr_rel_context env params ++ brk(1,2)
 
 let print_constructors envpar names types =
   let pc =
     prlist_with_sep (fun () -> brk(1,0) ++ str "| ")
-      (fun (id,c) -> pr_id id ++ str " : " ++ prterm_env envpar c)
+      (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c)
       (Array.to_list (array_map2 (fun n t -> (n,t)) names types))
   in 
   hv 0 (str "  " ++ pc)
 
 let build_inductive sp tyi =
   let (mib,mip) = Global.lookup_inductive (sp,tyi) in
-  let params = mip.mind_params_ctxt in
+  let params = mib.mind_params_ctxt in
   let args = extended_rel_list 0 params in
   let env = Global.env() in
-  let arity = hnf_prod_applist env mip.mind_user_arity args in
+  let fullarity = match mip.mind_arity with
+    | Monomorphic ar -> ar.mind_user_arity 
+    | Polymorphic ar ->
+	it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt in
+  let arity = hnf_prod_applist env fullarity args in
   let cstrtypes = arities_of_constructors env (sp,tyi) in
   let cstrtypes =
     Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
@@ -280,7 +300,7 @@ let print_one_inductive (sp,tyi) =
   let envpar = push_rel_context params env in
   hov 0 (
     pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ print_params env params ++
-    str ": " ++ prterm_env envpar arity ++ str " :=") ++
+    str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++
   brk(0,2) ++ print_constructors envpar cstrnames cstrtypes
 
 let pr_mutual_inductive finite indl =
@@ -304,25 +324,29 @@ let print_section_variable sp =
   print_name_infos (VarRef sp)
 
 let print_body = function
-  | Some lc  -> prterm (Declarations.force lc)
+  | Some lc  -> pr_lconstr (Declarations.force lc)
   | None -> (str"<no body>")
 
 let print_typed_body (val_0,typ) =
-  (print_body val_0 ++ fnl () ++ str "     : " ++ prtype typ ++ fnl ())
+  (print_body val_0 ++ fnl () ++ str "     : " ++ pr_ltype typ ++ fnl ())
+
+let ungeneralized_type_of_constant_type = function
+  | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level)
+  | NonPolymorphicType t -> t
 
 let print_constant with_values sep sp =
   let cb = Global.lookup_constant sp in
   let val_0 = cb.const_body in
-  let typ = cb.const_type in
+  let typ = ungeneralized_type_of_constant_type cb.const_type in
   hov 0 (
     match val_0 with 
     | None -> 
 	str"*** [ " ++ 
-	print_basename sp ++ str " : " ++ cut () ++ prtype typ ++ 
+	print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ 
 	str" ]" ++ fnl ()
     | _ -> 
 	print_basename sp ++ str sep ++ cut () ++
-	(if with_values then print_typed_body (val_0,typ) else prtype typ) ++
+	(if with_values then print_typed_body (val_0,typ) else pr_ltype typ) ++
 	fnl ())
 
 let print_constant_with_infos sp =
@@ -333,17 +357,18 @@ let print_inductive sp = (print_mutual sp)
 let print_syntactic_def sep kn =
   let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn in
   let c = Syntax_def.search_syntactic_definition dummy_loc kn in 
-  (str (if !Options.v7 then "Syntactic Definition " else "Notation ")
-   ++ pr_qualid qid ++ str sep ++ 
-  Constrextern.without_symbols pr_rawterm c ++ fnl ())
+  str "Notation " ++ pr_qualid qid ++ str sep ++ 
+  Constrextern.without_symbols pr_lrawconstr c ++ fnl ()
 
 let print_leaf_entry with_values sep ((sp,kn as oname),lobj) =
   let tag = object_tag lobj in
   match (oname,tag) with
     | (_,"VARIABLE") ->
-	Some (print_section_variable (basename sp))
+	(* Outside sections, VARIABLES still exist but only with universes 
+           constraints *)
+	(try Some(print_section_variable (basename sp)) with Not_found -> None)
     | (_,"CONSTANT") ->
-	Some (print_constant with_values sep kn)
+	Some (print_constant with_values sep (constant_of_kn kn))
     | (_,"INDUCTIVE") ->
 	Some (print_inductive kn)
     | (_,"MODULE") ->
@@ -369,7 +394,7 @@ let rec print_library_entry with_values ent =
 	print_leaf_entry with_values sep (oname,lobj)
     | (oname,Lib.OpenedSection (dir,_)) -> 
         Some (str " >>>>>>> Section " ++ pr_name oname)
-    | (oname,Lib.ClosedSection _) -> 
+    | (oname,Lib.ClosedSection) -> 
         Some (str " >>>>>>> Closed Section " ++ pr_name oname)
     | (_,Lib.CompilingLibrary (dir,_)) ->
 	Some (str " >>>>>>> Library " ++ pr_dirpath dir)
@@ -385,7 +410,7 @@ let print_context with_values =
     | h::rest when n = None or out_some n > 0 -> 
 	(match print_library_entry with_values h with
 	  | None -> prec n rest
-	  | Some pp -> prec (option_app ((+) (-1)) n) rest ++ pp ++ fnl ())
+	  | Some pp -> prec (option_map ((+) (-1)) n) rest ++ pp ++ fnl ())
     | _ -> mt ()
   in 
   prec
@@ -419,9 +444,9 @@ let read_sec_context r =
     with Not_found ->
       user_err_loc (loc,"read_sec_context", str "Unknown section") in
   let rec get_cxt in_cxt = function
-    | ((_,Lib.OpenedSection ((dir',_),_)) as hd)::rest ->
+    | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest ->
         if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest
-    | ((_,Lib.ClosedSection (_,_,ctxt)) as hd)::rest ->
+    | (_,Lib.ClosedSection)::rest ->
         error "Cannot print the contents of a closed section"
     | [] -> []
     | hd::rest -> get_cxt (hd::in_cxt) rest 
@@ -474,9 +499,7 @@ let print_name ref =
       "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object")
 
 let print_opaque_name qid = 
-  let sigma = Evd.empty in
   let env = Global.env () in
-  let sign = Global.named_context () in
   match global qid with
     | ConstRef cst ->
 	let cb = Global.lookup_constant cst in
@@ -487,19 +510,21 @@ let print_opaque_name qid =
     | IndRef (sp,_) ->
         print_mutual sp
     | ConstructRef cstr -> 
-	let ty = Inductive.type_of_constructor env cstr in
+	let ty = Inductiveops.type_of_constructor env cstr in
 	print_typed_value (mkConstruct cstr, ty)
     | VarRef id ->
         let (_,c,ty) = lookup_named id env in 
 	print_named_decl (id,c,ty)
 
 let print_about ref = 
-  let sigma = Evd.empty in
   let k = locate_any_name ref in
   begin match k with
-  | Term ref -> print_ref false ref ++ print_name_infos ref
-  | Syntactic kn -> print_syntactic_def " := " kn
-  | Dir _ | ModuleType _ | Undefined _ -> mt () end
+  | Term ref -> 
+      print_ref false ref ++ print_name_infos ref ++ print_opacity ref
+  | Syntactic kn ->
+      print_syntactic_def " := " kn
+  | Dir _ | ModuleType _ | Undefined _ ->
+      mt () end
   ++
   hov 0 (str "Expands to: " ++ pr_located_qualid k)
 
@@ -512,38 +537,6 @@ let print_impargs ref =
   (if has_impl then print_impl_args impl 
    else (str "No implicit arguments" ++ fnl ()))
 
-let print_local_context () =
-  let env = Lib.contents_after None in
-  let rec print_var_rec = function 
-    | [] -> (mt ())
-    | (oname,Lib.Leaf lobj)::rest ->
-	if "VARIABLE" = object_tag lobj then
-          let d = get_variable (basename (fst oname)) in 
-	  (print_var_rec rest ++
-             print_named_decl d)
-	else 
-	  print_var_rec rest
-    | _::rest -> print_var_rec rest
-
-  and print_last_const = function
-    | (oname,Lib.Leaf lobj)::rest -> 
-        (match object_tag lobj with
-           | "CONSTANT" -> 
-	       let kn = snd oname in
-               let {const_body=val_0;const_type=typ} = 
-		 Global.lookup_constant kn in
-		 (print_last_const rest ++
-                  print_basename kn ++str" = " ++
-                  print_typed_body (val_0,typ))
-           | "INDUCTIVE" -> 
-	       let kn = snd oname in
-               (print_last_const rest ++print_mutual kn ++ fnl ())
-           | "VARIABLE" ->  (mt ())
-           | _          ->  print_last_const rest)
-    | _ -> (mt ())
-  in 
-  (print_var_rec env ++  print_last_const env)
-
 let unfold_head_fconst = 
   let rec unfrec k = match kind_of_term k with
     | Const cst -> constant_value (Global.env ()) cst 
@@ -563,17 +556,17 @@ let inspect depth =
 
 open Classops
 
-let print_coercion_value v = prterm (get_coercion_value v)
+let print_coercion_value v = pr_lconstr (get_coercion_value v)
 
 let print_class i =
   let cl,_ = class_info_from_index i in
   pr_class cl
   
 let print_path ((i,j),p) = 
-  (str"[" ++ 
-     prlist_with_sep pr_semicolon print_coercion_value p ++
-     str"] : " ++ print_class i ++ str" >-> " ++
-     print_class j)
+  hov 2 (
+    str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++
+    str"] : ") ++
+  print_class i ++ str" >-> " ++ print_class j
 
 let _ = Classops.install_path_printer print_path
 
@@ -604,4 +597,9 @@ let print_path_between cls clt =
   in
   print_path ((i,j),p)
 
+let print_canonical_projections () =
+  prlist_with_sep pr_fnl (fun ((r1,r2),o) -> 
+    pr_global r2 ++ str " <- " ++ pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )")
+    (canonical_projections ())
+
 (*************************************************************************)
diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli
index c8471330..13c11db7 100644
--- a/parsing/prettyp.mli
+++ b/parsing/prettyp.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: prettyp.mli,v 1.12.2.1 2004/07/16 19:30:40 herbelin Exp $ i*)
+(*i $Id: prettyp.mli 7740 2005-12-26 20:07:21Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -42,7 +42,6 @@ val build_inductive : mutual_inductive -> int ->
 val print_mutual : mutual_inductive -> std_ppcmds
 val print_name : reference -> std_ppcmds
 val print_opaque_name : reference -> std_ppcmds
-val print_local_context : unit -> std_ppcmds
 val print_about : reference -> std_ppcmds
 val print_impargs : reference -> std_ppcmds
 
@@ -57,6 +56,7 @@ val print_graph : unit -> std_ppcmds
 val print_classes : unit -> std_ppcmds
 val print_coercions : unit -> std_ppcmds
 val print_path_between : Classops.cl_typ -> Classops.cl_typ -> std_ppcmds
+val print_canonical_projections : unit -> std_ppcmds
 
 val inspect : int -> std_ppcmds
 
diff --git a/parsing/printer.ml b/parsing/printer.ml
index dfacc764..6fb492ae 100644
--- a/parsing/printer.ml
+++ b/parsing/printer.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: printer.ml,v 1.58.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+(* $Id: printer.ml 9573 2007-01-31 20:18:18Z notin $ *)
 
 open Pp
 open Util
@@ -18,139 +18,120 @@ open Sign
 open Environ
 open Global
 open Declare
-open Coqast
-open Ast
-open Termast
 open Libnames
-open Extend
 open Nametab
 open Ppconstr
+open Evd
+open Proof_type
+open Decl_mode
+open Refiner
+open Pfedit
+open Ppconstr
+open Constrextern
 
-let emacs_str s = if !Options.print_emacs then s else "" 
+let emacs_str s alts = 
+  match !Options.print_emacs, !Options.print_emacs_safechar with
+    | true, true -> alts
+    | true , false -> s
+    | false,_ -> "" 
 
 (**********************************************************************)
-(* Old Ast printing *)
-
-let constr_syntax_universe = "constr"
-(* This is starting precedence for printing constructions or tactics *)
-(* Level 9 means no parentheses except for applicative terms (at level 10) *)
-let constr_initial_prec_v7 = Some (9,Ppextend.L)
-let constr_initial_prec = Some (200,Ppextend.E)
-
-let dfltpr ast = (str"#GENTERM " ++ print_ast ast);;
-
-let global_const_name kn =
-  try pr_global Idset.empty (ConstRef kn)
-  with Not_found -> (* May happen in debug *)
-    (str ("CONST("^(string_of_kn kn)^")"))
-
-let global_var_name id =
-  try pr_global Idset.empty (VarRef id)
-  with Not_found -> (* May happen in debug *)
-    (str ("SECVAR("^(string_of_id id)^")"))
-
-let global_ind_name (kn,tyi) =
-  try pr_global Idset.empty (IndRef (kn,tyi))
-  with Not_found -> (* May happen in debug *)
-    (str ("IND("^(string_of_kn kn)^","^(string_of_int tyi)^")"))
-
-let global_constr_name ((kn,tyi),i) =
-  try pr_global Idset.empty (ConstructRef ((kn,tyi),i))
-  with Not_found -> (* May happen in debug *)
-    (str ("CONSTRUCT("^(string_of_kn kn)^","^(string_of_int tyi)
-		  ^","^(string_of_int i)^")"))
-
-let globpr gt = match gt with
-  | Nvar(_,s) -> (pr_id s)
-  | Node(_,"EVAR", [Num (_,ev)]) -> (str ("?" ^ (string_of_int ev)))
-  | Node(_,"CONST",[Path(_,sl)]) ->
-      global_const_name (section_path sl)
-  | Node(_,"SECVAR",[Nvar(_,s)]) ->
-      global_var_name s
-  | Node(_,"MUTIND",[Path(_,sl); Num(_,tyi)]) ->
-      global_ind_name (section_path sl, tyi)
-  | Node(_,"MUTCONSTRUCT",[Path(_,sl); Num(_,tyi); Num(_,i)]) ->
-      global_constr_name ((section_path sl, tyi), i)
-  | Dynamic(_,d) ->
-    if (Dyn.tag d) = "constr" then (str"<dynamic [constr]>")
-    else dfltpr gt
-  | gt -> dfltpr gt
-
-
-let wrap_exception = function
-    Anomaly (s1,s2) ->
-      warning ("Anomaly ("^s1^")"); pp s2;
-      str"<PP error: non-printable term>"
-  | Failure _ | UserError _ | Not_found ->
-      str"<PP error: non-printable term>"
-  | s -> raise s
-
-let gentermpr_fail gt =
-  let prec =
-    if !Options.v7 then constr_initial_prec_v7 else constr_initial_prec in
-  Esyntax.genprint globpr constr_syntax_universe prec gt
-
-let gentermpr gt =
-  try gentermpr_fail gt
-  with s -> wrap_exception s
+(** Terms                                                             *)
 
-(**********************************************************************)
-(* Generic printing: choose old or new printers *)
+  (* [at_top] means ids of env must be avoided in bound variables *)
+let pr_constr_core at_top env t =
+  pr_constr_expr (extern_constr at_top env t)
+let pr_lconstr_core at_top env t =
+  pr_lconstr_expr (extern_constr at_top env t)
+
+let pr_lconstr_env_at_top env = pr_lconstr_core true env
+let pr_lconstr_env env = pr_lconstr_core false env
+let pr_constr_env env = pr_constr_core false env
+
+  (* NB do not remove the eta-redexes! Global.env() has side-effects... *)
+let pr_lconstr t = pr_lconstr_env (Global.env()) t
+let pr_constr t = pr_constr_env (Global.env()) t
+
+let pr_type_core at_top env t =
+  pr_constr_expr (extern_type at_top env t)
+let pr_ltype_core at_top env t =
+  pr_lconstr_expr (extern_type at_top env t)
+
+let pr_ltype_env_at_top env = pr_ltype_core true env
+let pr_ltype_env env = pr_ltype_core false env
+let pr_type_env env = pr_type_core false env
+
+let pr_ltype t = pr_ltype_env (Global.env()) t
+let pr_type t = pr_type_env (Global.env()) t
+
+let pr_ljudge_env env j =
+  (pr_lconstr_env env j.uj_val, pr_lconstr_env env j.uj_type)
+
+let pr_ljudge j = pr_ljudge_env (Global.env()) j
+
+let pr_lrawconstr_env env c =
+  pr_lconstr_expr (extern_rawconstr (vars_of_env env) c)
+let pr_rawconstr_env env c = 
+  pr_constr_expr (extern_rawconstr (vars_of_env env) c)
+
+let pr_lrawconstr c =
+  pr_lconstr_expr (extern_rawconstr Idset.empty c)
+let pr_rawconstr c =
+  pr_constr_expr (extern_rawconstr Idset.empty c)
 
-(* [at_top] means ids of env must be avoided in bound variables *)
-let gentermpr_core at_top env t =
-  if !Options.v7 then gentermpr (Termast.ast_of_constr at_top env t)
-  else Ppconstrnew.pr_lconstr (Constrextern.extern_constr at_top env t)
 let pr_cases_pattern t =
-  if !Options.v7 then gentermpr (Termast.ast_of_cases_pattern t)
-  else Ppconstrnew.pr_cases_pattern
-    (Constrextern.extern_cases_pattern Idset.empty t)
-let pr_pattern_env tenv env t =
-  if !Options.v7 then gentermpr (Termast.ast_of_pattern tenv env t)
-  else Ppconstrnew.pr_constr
-    (Constrextern.extern_pattern tenv env t)
+  pr_cases_pattern_expr (extern_cases_pattern Idset.empty t)
+
+let pr_lconstr_pattern_env env c =
+  pr_lconstr_expr (extern_constr_pattern (names_of_rel_context env) c)
+let pr_constr_pattern_env env c =
+  pr_constr_expr (extern_constr_pattern (names_of_rel_context env) c)
+
+let pr_lconstr_pattern t =
+  pr_lconstr_expr (extern_constr_pattern empty_names_context t)
+let pr_constr_pattern t =
+  pr_constr_expr (extern_constr_pattern empty_names_context t)
+
+let pr_sort s = pr_rawsort (extern_sort s)
+
+let _ = Termops.set_print_constr pr_lconstr_env
 
 (**********************************************************************)
-(* Derived printers *)
-  
-let prterm_env_at_top env = gentermpr_core true env
-let prterm_env env = gentermpr_core false env
-let prtype_env env typ = prterm_env env typ
-let prjudge_env env j =
-  (prterm_env env j.uj_val, prterm_env env j.uj_type)
-
-(* NB do not remove the eta-redexes! Global.env() has side-effects... *)
-let prterm t = prterm_env (Global.env()) t
-let prtype t = prtype_env (Global.env()) t
-let prjudge j = prjudge_env (Global.env()) j
-
-let pr_constant env cst = prterm_env env (mkConst cst)
-let pr_existential env ev = prterm_env env (mkEvar ev)
-let pr_inductive env ind = prterm_env env (mkInd ind)
-let pr_constructor env cstr = prterm_env env (mkConstruct cstr)
-let pr_global = pr_global Idset.empty
-
-let pr_rawterm t =
-  if !Options.v7 then gentermpr (Termast.ast_of_rawconstr t)
-  else Ppconstrnew.pr_lconstr (Constrextern.extern_rawconstr Idset.empty t)
-
-open Pattern
-let pr_ref_label = function (* On triche sur le contexte *)
-  | ConstNode sp -> pr_constant (Global.env()) sp
-  | IndNode sp -> pr_inductive (Global.env()) sp
-  | CstrNode sp -> pr_constructor (Global.env()) sp
-  | VarNode id -> pr_id id
-
-let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t
+(* Global references *)
+
+let pr_global_env = pr_global_env
+let pr_global = pr_global_env Idset.empty
+
+let pr_constant env cst = pr_global_env (vars_of_env env) (ConstRef cst)
+let pr_existential env ev = pr_lconstr_env env (mkEvar ev)
+let pr_inductive env ind = pr_lconstr_env env (mkInd ind)
+let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr)
+
+let pr_evaluable_reference ref =
+ let ref' = match ref with
+  | EvalConstRef const -> ConstRef const
+  | EvalVarRef sp -> VarRef sp in
+ pr_global ref'
+
+(*let pr_rawterm t =
+  pr_lconstr (Constrextern.extern_rawconstr Idset.empty t)*)
+
+(*open Pattern
+
+let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t*)
+
+(**********************************************************************)
+(* Contexts and declarations                                          *)
 
 let pr_var_decl env (id,c,typ) =
   let pbody = match c with
     | None ->  (mt ())
     | Some c ->
 	(* Force evaluation *) 
-	let pb = prterm_env env c in
+	let pb = pr_lconstr_env env c in
+	let pb = if isCast c then surround pb else pb in
 	(str" := " ++ pb ++ cut () ) in
-  let pt = prtype_env env typ in
+  let pt = pr_ltype_env env typ in
   let ptyp = (str" : " ++ pt) in
   (pr_id id ++ hov 0 (pbody ++ ptyp))
 
@@ -159,9 +140,10 @@ let pr_rel_decl env (na,c,typ) =
     | None -> mt ()
     | Some c ->
 	(* Force evaluation *) 
-	let pb = prterm_env env c in
+	let pb = pr_lconstr_env env c in
+	let pb = if isCast c then surround pb else pb in
 	(str":=" ++ spc () ++ pb ++ spc ()) in
-  let ptyp = prtype_env env typ in
+  let ptyp = pr_ltype_env env typ in
   match na with
   | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
   | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
@@ -177,22 +159,25 @@ let pr_named_context_of env =
 	  (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d)
           env ~init:(mt ()))
 
+let pr_named_context env ne_context = 
+  hv 0 (Sign.fold_named_context
+	  (fun d pps -> pps ++ ws 2 ++ pr_var_decl env d)
+          ne_context ~init:(mt ()))
+
 let pr_rel_context env rel_context =
   let rec prec env = function
     | [] -> (mt ()) 
-    | [b] -> 
-	if !Options.v7 then pr_rel_decl env b
-	else str "(" ++ pr_rel_decl env b ++ str")"
+    | [b] -> str "(" ++ pr_rel_decl env b ++ str")"
     | b::rest ->
         let pb = pr_rel_decl env b in
         let penvtl = prec (push_rel b env) rest in
-	if !Options.v7 then
-          (pb ++ str";" ++ spc () ++ penvtl)
-	else 
-          (str "(" ++ pb ++ str")" ++ spc () ++ penvtl)
+        str "(" ++ pb ++ str")" ++ spc () ++ penvtl
   in 
   hov 0 (prec env (List.rev rel_context))
 
+let pr_rel_context_of env =
+  pr_rel_context env (rel_context env)
+
 (* Prints an env (variables and de Bruijn). Separator: newline *)
 let pr_context_unlimited env =
   let sign_env =
@@ -229,7 +214,7 @@ let pr_context_limit n env =
 	   else
              let pidt = pr_var_decl env d in
 	     (i+1, (pps ++ fnl () ++
-		      str (emacs_str (String.make 1 (Char.chr 253))) ++
+		      str (emacs_str (String.make 1 (Char.chr 253)) "") ++
 		      pidt)))
         env ~init:(0,(mt ())) 
     in
@@ -238,7 +223,7 @@ let pr_context_limit n env =
         (fun env d pps ->
            let pnat = pr_rel_decl env d in
 	   (pps ++ fnl () ++
-	      str (emacs_str (String.make 1 (Char.chr 253))) ++
+	      str (emacs_str (String.make 1 (Char.chr 253)) "") ++
 	      pnat))
         env ~init:(mt ())
     in 
@@ -247,3 +232,201 @@ let pr_context_limit n env =
 let pr_context_of env = match Options.print_hyps_limit () with 
   | None -> hv 0 (pr_context_unlimited env)
   | Some n -> hv 0 (pr_context_limit n env)
+
+(* display goal parts (Proof mode) *)
+
+let pr_subgoal_metas metas env=
+  let pr_one (meta,typ) = 
+    str "?" ++ int meta ++ str " : " ++ 
+      hov 0 (pr_ltype_env_at_top env typ) ++ fnl () ++ 
+      str (emacs_str (String.make 1 (Char.chr 253)) "") in
+    hv 0 (prlist_with_sep mt pr_one metas)
+
+(* display complete goal *)
+
+let pr_goal g =
+  let env = evar_env g in
+  let preamb,penv,pc =
+    if g.evar_extra = None then
+          mt (),
+	  pr_context_of env,
+	  pr_ltype_env_at_top env g.evar_concl
+    else 
+      let {pm_subgoals=metas} = get_info g in
+	(str "     *** Declarative Mode ***" ++ fnl ()++fnl ()),
+    pr_context_of env,
+    pr_subgoal_metas metas env
+  in
+    preamb ++
+    str"  " ++ hv 0 (penv ++ fnl () ++
+		       str (emacs_str (String.make 1 (Char.chr 253)) "")  ++
+		       str "============================" ++ fnl ()  ++
+		       str" "  ++ pc) ++ fnl ()
+     
+(* display the conclusion of a goal *)
+let pr_concl n g =
+  let env = evar_env g in
+  let pc = pr_ltype_env_at_top env g.evar_concl in
+    str (emacs_str (String.make 1 (Char.chr 253)) "")  ++
+      str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" "  ++ pc
+
+
+(* display evar type: a context and a type *)
+let pr_evgl_sign gl = 
+  let ps = pr_named_context_of (evar_env gl) in
+  let pc = pr_lconstr gl.evar_concl in
+  hov 0 (str"["  ++ ps ++ spc () ++ str"|- "  ++ pc ++ str"]")
+
+(* Print an enumerated list of existential variables *)
+let rec pr_evars_int i = function
+  | [] -> (mt ())
+  | (ev,evd)::rest ->
+      let pegl = pr_evgl_sign evd in 
+      let pei = pr_evars_int (i+1) rest in
+      (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++
+              str (string_of_existential ev)  ++ str " : " ++ pegl)) ++ 
+      fnl () ++ pei
+
+let pr_subgoal n =
+  let rec prrec p = function
+    | [] -> error "No such goal"
+    | g::rest ->
+       	if p = 1 then
+          let pg = pr_goal g in
+          v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg)
+       	else 
+	  prrec (p-1) rest
+  in 
+  prrec n
+
+(* Print open subgoals. Checks for uninstantiated existential variables *)
+let pr_subgoals close_cmd sigma = function 
+  | [] -> 
+      begin
+	match close_cmd with
+	  Some cmd ->
+	    (str "Subproof completed, now type " ++ str cmd ++ 
+	       str "." ++ fnl ())
+	| None ->
+	    let exl = Evarutil.non_instantiated sigma in 
+	      if exl = [] then 
+		(str"Proof completed."  ++ fnl ())
+	      else
+		let pei = pr_evars_int 1 exl in
+		  (str "No more subgoals but non-instantiated existential " ++
+		     str "variables :"  ++fnl () ++ (hov 0 pei))
+      end
+  | [g] ->
+      let pg = pr_goal g in
+      v 0 (str ("1 "^"subgoal") ++cut () ++ pg)
+  | g1::rest ->
+      let rec pr_rec n = function
+        | [] -> (mt ())
+        | g::rest ->
+            let pc = pr_concl n g in
+            let prest = pr_rec (n+1) rest in
+            (cut () ++ pc ++ prest) 
+      in
+      let pg1 = pr_goal g1 in
+      let prest = pr_rec 2 rest in
+      v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () 
+	   ++ pg1 ++ prest ++ fnl ())
+
+let pr_subgoals_of_pfts pfts =
+  let close_cmd = Decl_mode.get_end_command pfts in
+  let gls = fst (Refiner.frontier (proof_of_pftreestate pfts)) in 
+  let sigma = (top_goal_of_pftreestate pfts).sigma in
+    pr_subgoals close_cmd sigma gls
+      
+let pr_open_subgoals () =
+  let pfts = get_pftreestate () in
+  match focus() with
+    | 0 -> 
+	pr_subgoals_of_pfts pfts
+    | n -> 
+	let pf = proof_of_pftreestate pfts in
+	let gls = fst (frontier pf) in 
+	assert (n > List.length gls);
+	if List.length gls < 2 then 
+	  pr_subgoal n gls
+	else 
+	  v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++
+	  pr_subgoal n gls)
+
+let pr_nth_open_subgoal n =
+  let pf = proof_of_pftreestate (get_pftreestate ()) in
+  pr_subgoal n (fst (frontier pf))
+
+(* Elementary tactics *)
+
+let pr_prim_rule = function
+  | Intro id -> 
+      str"intro " ++ pr_id id
+	
+  | Intro_replacing id -> 
+      (str"intro replacing "  ++ pr_id id)
+	
+  | Cut (b,id,t) ->
+      if b then
+        (str"assert " ++ pr_constr t)
+      else
+        (str"cut " ++ pr_constr t ++ str ";[intro " ++ pr_id id ++ str "|idtac]")
+	
+  | FixRule (f,n,[]) ->
+      (str"fix " ++ pr_id f ++ str"/" ++ int n)
+      
+  | FixRule (f,n,others) -> 
+      let rec print_mut = function
+	| (f,n,ar)::oth -> 
+           pr_id f ++ str"/" ++ int n ++ str" : " ++ pr_lconstr ar ++ print_mut oth
+        | [] -> mt () in
+      (str"fix " ++ pr_id f ++ str"/" ++ int n ++
+         str" with " ++ print_mut others)
+
+  | Cofix (f,[]) ->
+      (str"cofix " ++ pr_id f)
+
+  | Cofix (f,others) ->
+      let rec print_mut = function
+	| (f,ar)::oth ->
+	  (pr_id f ++ str" : " ++ pr_lconstr ar ++ print_mut oth)
+        | [] -> mt () in
+      (str"cofix " ++ pr_id f ++  str" with " ++ print_mut others)
+  | Refine c -> 
+      str(if occur_meta c then "refine " else "exact ") ++
+      Constrextern.with_meta_as_hole pr_constr c
+      
+  | Convert_concl (c,_) ->
+      (str"change "  ++ pr_constr c)
+      
+  | Convert_hyp (id,None,t) ->
+      (str"change "  ++ pr_constr t  ++ spc ()  ++ str"in "  ++ pr_id id)
+
+  | Convert_hyp (id,Some c,t) ->
+      (str"change "  ++ pr_constr c  ++ spc ()  ++ str"in "
+       ++ pr_id id ++ str" (type of "  ++ pr_id id ++ str ")")
+      
+  | Thin ids ->
+      (str"clear "  ++ prlist_with_sep pr_spc pr_id ids)
+      
+  | ThinBody ids ->
+      (str"clearbody "  ++ prlist_with_sep pr_spc pr_id ids)
+      
+  | Move (withdep,id1,id2) ->
+      (str (if withdep then "dependent " else "") ++
+	 str"move "  ++ pr_id id1 ++ str " after " ++ pr_id id2)
+
+  | Rename (id1,id2) ->
+      (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2)
+
+  | Change_evars ->
+      (* This is internal tactic and cannot be replayed at user-level.
+         Function pr_rule_dot below is used when we want to hide
+         Change_evars *)
+      str "Evar change"
+
+
+(* Backwards compatibility *)
+
+let prterm = pr_lconstr
+
diff --git a/parsing/printer.mli b/parsing/printer.mli
index c44be124..86af523f 100644
--- a/parsing/printer.mli
+++ b/parsing/printer.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: printer.mli,v 1.26.2.2 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: printer.mli 9385 2006-11-17 15:14:14Z courtieu $ i*)
 
 (*i*)
 open Pp
@@ -19,42 +19,91 @@ open Rawterm
 open Pattern
 open Nametab
 open Termops
+open Evd
+open Proof_type
+open Rawterm
 (*i*)
 
 (* These are the entry points for printing terms, context, tac, ... *)
-(*i
-val gentacpr  : Tacexpr.raw_tactic_expr -> std_ppcmds
-i*)
-
-val prterm_env      : env -> constr -> std_ppcmds
-val prterm_env_at_top : env -> constr -> std_ppcmds
-val prterm          : constr -> std_ppcmds
-val prtype_env      : env -> types -> std_ppcmds
-val prtype          : types -> std_ppcmds
-val prjudge_env     :
-  env -> Environ.unsafe_judgment -> std_ppcmds * std_ppcmds
-val prjudge         : Environ.unsafe_judgment -> std_ppcmds * std_ppcmds
-
-val pr_rawterm       : Rawterm.rawconstr -> std_ppcmds
-val pr_cases_pattern : Rawterm.cases_pattern -> std_ppcmds
-
-val pr_constant     : env -> constant -> std_ppcmds
-val pr_existential  : env -> existential -> std_ppcmds
-val pr_constructor  : env -> constructor -> std_ppcmds
-val pr_inductive    : env -> inductive -> std_ppcmds
-val pr_global       : global_reference -> std_ppcmds
-val pr_ref_label    : constr_label -> std_ppcmds
-val pr_pattern      : constr_pattern -> std_ppcmds
-val pr_pattern_env  : env -> names_context -> constr_pattern -> std_ppcmds
-
-val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds
-
-val pr_var_decl     : env -> named_declaration -> std_ppcmds
-val pr_rel_decl     : env -> rel_declaration -> std_ppcmds
-
-val pr_named_context_of : env -> std_ppcmds
-val pr_rel_context  : env -> rel_context -> std_ppcmds
-val pr_context_of   : env -> std_ppcmds
-
-val emacs_str       : string -> string
 
+(* Terms *)
+
+val pr_lconstr_env         : env -> constr -> std_ppcmds
+val pr_lconstr_env_at_top  : env -> constr -> std_ppcmds
+val pr_lconstr             : constr -> std_ppcmds
+
+val pr_constr_env          : env -> constr -> std_ppcmds
+val pr_constr              : constr -> std_ppcmds
+
+val pr_ltype_env_at_top    : env -> types -> std_ppcmds
+val pr_ltype_env           : env -> types -> std_ppcmds
+val pr_ltype               : types -> std_ppcmds
+
+val pr_type_env            : env -> types -> std_ppcmds
+val pr_type                : types -> std_ppcmds
+
+val pr_ljudge_env          : env -> unsafe_judgment -> std_ppcmds * std_ppcmds
+val pr_ljudge              : unsafe_judgment -> std_ppcmds * std_ppcmds
+
+val pr_lrawconstr_env      : env -> rawconstr -> std_ppcmds
+val pr_lrawconstr          : rawconstr -> std_ppcmds
+
+val pr_rawconstr_env       : env -> rawconstr -> std_ppcmds
+val pr_rawconstr           : rawconstr -> std_ppcmds
+
+val pr_lconstr_pattern_env : env -> constr_pattern -> std_ppcmds
+val pr_lconstr_pattern     : constr_pattern -> std_ppcmds
+
+val pr_constr_pattern_env  : env -> constr_pattern -> std_ppcmds
+val pr_constr_pattern      : constr_pattern -> std_ppcmds
+
+val pr_cases_pattern       : cases_pattern -> std_ppcmds
+
+val pr_sort                : sorts -> std_ppcmds
+
+(* Printing global references using names as short as possible *)
+
+val pr_global_env          : Idset.t -> global_reference -> std_ppcmds
+val pr_global              : global_reference -> std_ppcmds
+
+val pr_constant            : env -> constant -> std_ppcmds
+val pr_existential         : env -> existential -> std_ppcmds
+val pr_constructor         : env -> constructor -> std_ppcmds
+val pr_inductive           : env -> inductive -> std_ppcmds
+val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds
+
+(* Contexts *)
+
+val pr_ne_context_of       : std_ppcmds -> env -> std_ppcmds
+
+val pr_var_decl            : env -> named_declaration -> std_ppcmds
+val pr_rel_decl            : env -> rel_declaration -> std_ppcmds
+
+val pr_named_context       : env -> named_context -> std_ppcmds
+val pr_named_context_of    : env -> std_ppcmds
+val pr_rel_context         : env -> rel_context -> std_ppcmds
+val pr_rel_context_of      : env -> std_ppcmds
+val pr_context_of          : env -> std_ppcmds
+
+(* Proofs *)
+
+val pr_goal                : goal -> std_ppcmds
+val pr_subgoals            : string option -> evar_map -> goal list -> std_ppcmds
+val pr_subgoal             : int -> goal list -> std_ppcmds
+
+val pr_open_subgoals       : unit -> std_ppcmds
+val pr_nth_open_subgoal    : int -> std_ppcmds
+val pr_evars_int           : int -> (evar * evar_info) list -> std_ppcmds
+
+val pr_prim_rule           : prim_rule -> std_ppcmds
+
+(* Emacs/proof general support *)
+(* (emacs_str s alts) outputs 
+   - s if emacs mode & unicode allowed, 
+   - alts if emacs mode and & unicode not allowed
+   - nothing otherwise *)
+val emacs_str              : string -> string -> string
+
+(* Backwards compatibility *)
+
+val prterm                 : constr -> std_ppcmds (* = pr_lconstr *)
diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4
new file mode 100644
index 00000000..768bc45c
--- /dev/null
+++ b/parsing/q_constr.ml4
@@ -0,0 +1,124 @@
+(************************************************************************)
+(*  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: g_constr.ml4,v 1.58 2005/12/30 10:55:32 herbelin Exp $ *)
+
+open Rawterm
+open Term
+open Names
+open Pattern
+open Q_util
+open Util
+open Pcaml
+
+let loc = dummy_loc
+let dloc = <:expr< Util.dummy_loc >>
+
+let apply_ref f l = 
+  <:expr< 
+    Rawterm.RApp ($dloc$, Rawterm.RRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$)
+  >>
+
+EXTEND
+  GLOBAL: expr;
+  expr:
+    [ [ "PATTERN"; "["; c = constr; "]" ->
+      <:expr< snd (Pattern.pattern_of_rawconstr $c$) >> ] ]
+  ;
+  sort:
+    [ [ "Set"  -> RProp Pos
+      | "Prop" -> RProp Null
+      | "Type" -> RType None ] ]
+  ;
+  ident:
+    [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ]
+  ;
+  name:
+    [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ]
+  ;
+  string:
+    [ [ UIDENT | LIDENT ] ]
+  ;
+  constr:
+    [ "200" RIGHTA
+      [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr ->
+        <:expr< Rawterm.RProd ($dloc$,Name $id$,$c1$,$c2$) >>
+      | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr ->
+        <:expr< Rawterm.RLambda ($dloc$,Name $id$,$c1$,$c2$) >>
+      | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr ->
+        <:expr< Rawterm.RLetin ($dloc$,Name $id$,$c1$,$c2$) >>
+      (* fix todo *)
+      ]
+    | "100" RIGHTA
+      [ c1 = constr; ":"; c2 = SELF -> 
+        <:expr< Rawterm.RCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ]
+    | "90" RIGHTA
+      [ c1 = constr; "->"; c2 = SELF -> 
+        <:expr< Rawterm.RProd ($dloc$,Anonymous,$c1$,$c2$) >> ]
+    | "75" RIGHTA
+      [ "~"; c = constr -> 
+        apply_ref <:expr< coq_not_ref >> [c] ]
+    | "70" RIGHTA
+      [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT ->
+        apply_ref <:expr< coq_eq_ref >> [t;c1;c2] ]
+    | "10" LEFTA
+      [ f = constr; args = LIST1 NEXT ->
+        let args = mlexpr_of_list (fun x -> x) args in
+        <:expr< Rawterm.RApp ($dloc$,$f$,$args$) >> ]
+    | "0"
+      [ s = sort -> <:expr< Rawterm.RSort ($dloc$,s) >>
+      | id = ident -> <:expr< Rawterm.RVar ($dloc$,$id$) >>
+      | "_" -> <:expr< Rawterm.RHole ($dloc$,QuestionMark) >>
+      | "?"; id = ident -> <:expr< Rawterm.RPatVar($dloc$,(False,$id$)) >>
+      | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" ->
+          apply_ref <:expr< coq_sumbool_ref >> [c1;c2]
+      | "%"; e = string -> <:expr< Rawterm.RRef ($dloc$,Lazy.force $lid:e$) >>
+      | c = match_constr -> c
+      | "("; c = constr LEVEL "200"; ")" -> c ] ]
+  ;
+  match_constr:
+    [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type;
+        "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> 
+          let br = mlexpr_of_list (fun x -> x) br in
+     <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> 
+    ] ]
+  ;
+  match_type:
+    [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name;  
+        "return"; ty = constr LEVEL "100" -> 
+          let nal = mlexpr_of_list (fun x -> x) nal in
+          <:expr< Some $ty$ >>, 
+          <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >> 
+      | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ]
+  ;
+  eqn:
+    [ [ (lid,pl) = pattern; "=>"; rhs = constr -> 
+        let lid = mlexpr_of_list (fun x -> x) lid in
+        <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> 
+    ] ]
+  ;
+  pattern: 
+    [ [ "%"; e = string; lip = LIST0 patvar ->
+        let lp = mlexpr_of_list (fun (_,x) -> x) lip in
+        let lid = List.flatten (List.map fst lip) in
+        lid, <:expr< Rawterm.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >>
+      | p = patvar -> p
+      | "("; p = pattern; ")" -> p ] ]
+  ;
+  patvar:
+    [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >> 
+      | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >> 
+    ] ]
+  ;
+  END;;
+
+(* Example 
+open Coqlib
+let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ]
+*)
+
diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4
index e8e1830a..23787f4c 100644
--- a/parsing/q_coqast.ml4
+++ b/parsing/q_coqast.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: q_coqast.ml4,v 1.47.2.6 2005/05/15 12:47:05 herbelin Exp $ *)
+(* $Id: q_coqast.ml4 9551 2007-01-29 15:13:35Z bgregoir $ *)
 
 open Util
 open Names
@@ -21,7 +21,7 @@ let purge_str s =
 
 let anti loc x =
   let e =
-    let loc = 
+    let loc =
       ifdef OCAML_308 then
         loc
       else
@@ -30,87 +30,6 @@ let anti loc x =
   in
   <:expr< $anti:e$ >>
 
-(* [mlexpr_of_ast] contributes to translate g_*.ml4 files into g_*.ppo *)
-(* This is where $id's (and macros) in ast are translated in ML variables *)
-(* which will bind their actual ast value *)
-
-let rec mlexpr_of_ast = function
-  | Coqast.Nmeta (loc, id) -> anti loc id
-  | Coqast.Id (loc, id) when is_meta id -> <:expr< Coqast.Id loc $anti loc id$ >>
-  | Coqast.Node (_, "$VAR", [Coqast.Nmeta (loc, x)]) ->
-      <:expr< let s = $anti loc x$ in
-      if String.length s > 0 && String.sub s 0 1 = "$" then
-	failwith "Wrong ast: $VAR should not be bound to a meta variable"
-      else
-	Coqast.Nvar loc (Names.id_of_string s) >>
-  | Coqast.Node (_, "$PATH", [Coqast.Nmeta (loc, x)]) ->
-      <:expr< Coqast.Path loc $anti loc x$ >>
-  | Coqast.Node (_, "$ID", [Coqast.Nmeta (loc, x)]) ->
-      <:expr< Coqast.Id loc $anti loc x$ >>
-  | Coqast.Node (_, "$STR", [Coqast.Nmeta (loc, x)]) ->
-      <:expr< Coqast.Str loc $anti loc x$ >>
-(* Obsolète
-  | Coqast.Node _ "$SLAM" [Coqast.Nmeta loc idl; y] ->
-      <:expr<
-      List.fold_right (Pcoq.slam_ast loc) $anti loc idl$ $mlexpr_of_ast y$ >>
-*)
-  | Coqast.Node (loc, "$ABSTRACT", [Coqast.Str (_, s); x; y]) ->
-      let x = mlexpr_of_ast x in
-      let y = mlexpr_of_ast y in
-      <:expr< Ast.abstract_binders_ast loc $str:s$ $x$ $y$ >>
-  | Coqast.Node (loc, nn, al) ->
-      let e = expr_list_of_ast_list al in
-      <:expr< Coqast.Node loc $str:nn$ $e$ >>
-  | Coqast.Nvar (loc, id) ->
-      <:expr< Coqast.Nvar loc (Names.id_of_string $str:Names.string_of_id id$) >>
-  | Coqast.Slam (loc, None, a) ->
-      <:expr< Coqast.Slam loc None $mlexpr_of_ast a$ >>
-  | Coqast.Smetalam (loc, s, a) ->
-      <:expr< 
-      match $anti loc s$ with
-	[ Coqast.Nvar _ id -> Coqast.Slam loc (Some id) $mlexpr_of_ast a$
-	| Coqast.Nmeta _ s -> Coqast.Smetalam loc s $mlexpr_of_ast a$
-	| _ -> failwith "Slam expects a var or a metavar" ] >>
-  | Coqast.Slam (loc, Some s, a) ->
-      let se = <:expr< Names.id_of_string $str:Names.string_of_id s$ >> in
-      <:expr< Coqast.Slam loc (Some $se$) $mlexpr_of_ast a$ >>
-  | Coqast.Num (loc, i) -> <:expr< Coqast.Num loc $int:string_of_int i$ >>
-  | Coqast.Id (loc, id) -> <:expr< Coqast.Id loc $str:id$ >>
-  | Coqast.Str (loc, str) -> <:expr< Coqast.Str loc $str:str$ >>
-  | Coqast.Path (loc, kn) ->
-      let l,a = Libnames.decode_kn kn in
-      let mlexpr_of_modid id =
-	<:expr< Names.id_of_string $str:string_of_id id$ >> in
-      let e = List.map mlexpr_of_modid (repr_dirpath l) in
-      let e = expr_list_of_var_list e in
-      <:expr< Coqast.Path loc (Libnames.encode_kn (Names.make_dirpath $e$)
-                (Names.id_of_string $str:Names.string_of_id a$)) >> 
-  | Coqast.Dynamic (_, _) ->
-      failwith "Q_Coqast: dynamic: not implemented"
-
-and expr_list_of_ast_list al =
-  List.fold_right
-    (fun a e2 -> match a with
-       | (Coqast.Node (_, "$LIST", [Coqast.Nmeta (locv, pv)])) ->
-           let e1 = anti locv pv in
-           let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in
-	     if e2 = (let loc = dummy_loc in <:expr< [] >>)
-	     then <:expr< $e1$ >>
-	     else <:expr< ( $lid:"@"$ $e1$ $e2$) >>
-       | _ ->
-           let e1 = mlexpr_of_ast a in
-           let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in
-	   <:expr< [$e1$ :: $e2$] >> )
-    al (let loc = dummy_loc in <:expr< [] >>)
-
-and expr_list_of_var_list sl =
-  let loc = dummy_loc in
-  List.fold_right
-    (fun e1 e2 ->
-       let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in
-       <:expr< [$e1$ :: $e2$] >>)
-    sl <:expr< [] >>
-
 (* We don't give location for tactic quotation! *)
 let loc = dummy_loc
 
@@ -139,6 +58,7 @@ let mlexpr_of_reference = function
 let mlexpr_of_intro_pattern = function
   | Genarg.IntroOrAndPattern _ -> failwith "mlexpr_of_intro_pattern: TODO"
   | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >>
+  | Genarg.IntroAnonymous -> <:expr< Genarg.IntroAnonymous >>
   | Genarg.IntroIdentifier id ->
       <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >>
 
@@ -157,20 +77,22 @@ let mlexpr_of_located f (loc,x) = <:expr< ($dloc$, $f x$) >>
 let mlexpr_of_loc loc = <:expr< $dloc$ >>
 
 let mlexpr_of_or_var f = function
-  | Genarg.ArgArg x -> <:expr< Genarg.ArgArg $f x$ >>
-  | Genarg.ArgVar id -> <:expr< Genarg.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >>
+  | Rawterm.ArgArg x -> <:expr< Rawterm.ArgArg $f x$ >>
+  | Rawterm.ArgVar id -> <:expr< Rawterm.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >>
 
 let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident)
 
-let mlexpr_of_occs = mlexpr_of_list mlexpr_of_int
+let mlexpr_of_occs = mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int)
+
+let mlexpr_of_occurrences f = mlexpr_of_pair mlexpr_of_occs f
 
 let mlexpr_of_hyp_location = function
-  | id, occs, (Tacexpr.InHyp,_) ->
-      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHyp, ref None)) >>
-  | id, occs, (Tacexpr.InHypTypeOnly,_) ->
-      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypTypeOnly, ref None)) >>
-  | id, occs, (Tacexpr.InHypValueOnly,_) ->
-      <:expr< ($mlexpr_of_hyp id$, $mlexpr_of_occs occs$, (Tacexpr.InHypValueOnly,ref None)) >>
+  | occs, Tacexpr.InHyp ->
+      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Tacexpr.InHyp) >>
+  | occs, Tacexpr.InHypTypeOnly ->
+      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Tacexpr.InHypTypeOnly) >>
+  | occs, Tacexpr.InHypValueOnly ->
+      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Tacexpr.InHypValueOnly) >>
 
 let mlexpr_of_clause cl =
   <:expr< {Tacexpr.onhyps=
@@ -179,13 +101,6 @@ let mlexpr_of_clause cl =
            Tacexpr.onconcl= $mlexpr_of_bool cl.Tacexpr.onconcl$;
            Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >>
 
-(*
-let mlexpr_of_red_mode = function
-  | Closure.UNIFORM -> <:expr< Closure.UNIFORM >>
-  | Closure.SIMPL -> <:expr< Closure.SIMPL >>
-  | Closure.WITHBACK -> <:expr< Closure.WITHBACK >>
-*)
-
 let mlexpr_of_red_flags {
   Rawterm.rBeta = bb;
   Rawterm.rIota = bi;
@@ -218,7 +133,6 @@ let rec mlexpr_of_constr = function
   | Topconstr.CAppExpl (loc,a,l) -> <:expr< Topconstr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >>
   | Topconstr.CApp (loc,a,l) -> <:expr< Topconstr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >>
   | Topconstr.CCases (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO"
-  | Topconstr.COrderedCase (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO"
   | Topconstr.CHole loc -> <:expr< Topconstr.CHole $dloc$ >>
   | Topconstr.CNotation(_,ntn,l) ->
       <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$
@@ -228,7 +142,8 @@ let rec mlexpr_of_constr = function
   | _ -> failwith "mlexpr_of_constr: TODO"
 
 let mlexpr_of_occ_constr =
-  mlexpr_of_pair (mlexpr_of_list mlexpr_of_int) mlexpr_of_constr
+  mlexpr_of_pair (mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int))
+    mlexpr_of_constr
 
 let mlexpr_of_red_expr = function
   | Rawterm.Red b -> <:expr< Rawterm.Red $mlexpr_of_bool b$ >>
@@ -239,7 +154,7 @@ let mlexpr_of_red_expr = function
   | Rawterm.Lazy f ->
       <:expr< Rawterm.Lazy $mlexpr_of_red_flags f$ >>
   | Rawterm.Unfold l ->
-      let f1 = mlexpr_of_list mlexpr_of_int in
+      let f1 = mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int) in
       let f2 = mlexpr_of_reference in
       let f = mlexpr_of_list (mlexpr_of_pair f1 f2) in
       <:expr< Rawterm.Unfold $f l$ >>
@@ -248,6 +163,7 @@ let mlexpr_of_red_expr = function
   | Rawterm.Pattern l ->
       let f = mlexpr_of_list mlexpr_of_occ_constr in
       <:expr< Rawterm.Pattern $f l$ >>
+  | Rawterm.CbvVm -> <:expr< Rawterm.CbvVm >>
   | Rawterm.ExtraRedExpr s ->
       <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ >>
 
@@ -259,15 +175,13 @@ let rec mlexpr_of_argtype loc = function
   | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >>
   | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >>
   | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >>
-  | Genarg.HypArgType -> <:expr< Genarg.HypArgType >>
+  | Genarg.VarArgType -> <:expr< Genarg.VarArgType >>
   | Genarg.StringArgType -> <:expr< Genarg.StringArgType >>
   | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >>
-  | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >>
-  | Genarg.CastedOpenConstrArgType -> <:expr< Genarg.CastedOpenConstrArgType >>
+  | Genarg.OpenConstrArgType b -> <:expr< Genarg.OpenConstrArgType $mlexpr_of_bool b$ >>
   | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >>
   | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >>
   | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >>
-  | Genarg.TacticArgType -> <:expr< Genarg.TacticArgType >>
   | Genarg.SortArgType -> <:expr< Genarg.SortArgType >>
   | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >>
   | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >>
@@ -335,6 +249,11 @@ let mlexpr_of_match_rule f = function
   | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >>
   | Tacexpr.All t -> <:expr< Tacexpr.All $f t$ >>
 
+let mlexpr_of_message_token = function
+  | Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >>
+  | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >>
+  | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >>
+
 let rec mlexpr_of_atomic_tactic = function
   (* Basic tactics *)
   | Tacexpr.TacIntroPattern pl ->
@@ -350,6 +269,10 @@ let rec mlexpr_of_atomic_tactic = function
       <:expr< Tacexpr.TacAssumption >>
   | Tacexpr.TacExact c ->
       <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >>
+  | Tacexpr.TacExactNoCheck c ->
+      <:expr< Tacexpr.TacExactNoCheck $mlexpr_of_constr c$ >>
+  | Tacexpr.TacVmCastNoCheck c ->
+      <:expr< Tacexpr.TacVmCastNoCheck $mlexpr_of_constr c$ >>
   | Tacexpr.TacApply cb ->
       <:expr< Tacexpr.TacApply $mlexpr_of_constr_with_binding cb$ >>
   | Tacexpr.TacElim (cb,cbo) ->
@@ -384,11 +307,10 @@ let rec mlexpr_of_atomic_tactic = function
 
   | Tacexpr.TacCut c ->
       <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >>
-  | Tacexpr.TacTrueCut (na,c) ->
-      let na = mlexpr_of_name na in
-      <:expr< Tacexpr.TacTrueCut $na$ $mlexpr_of_constr c$ >>
-  | Tacexpr.TacForward (b,na,c) ->
-      <:expr< Tacexpr.TacForward $mlexpr_of_bool b$ $mlexpr_of_name na$ $mlexpr_of_constr c$ >>
+  | Tacexpr.TacAssert (t,ipat,c) ->
+      let ipat = mlexpr_of_intro_pattern ipat in
+      <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ 
+	      $mlexpr_of_constr c$ >>
   | Tacexpr.TacGeneralize cl ->
       <:expr< Tacexpr.TacGeneralize $mlexpr_of_list mlexpr_of_constr cl$ >>
   | Tacexpr.TacGeneralizeDep c ->
@@ -399,23 +321,25 @@ let rec mlexpr_of_atomic_tactic = function
       <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ >>
 
   (* Derived basic tactics *)
-  | Tacexpr.TacSimpleInduction (h,_) ->
-      <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$,ref []) >>
-  | Tacexpr.TacNewInduction (c,cbo,ids) ->
+  | Tacexpr.TacSimpleInduction h ->
+      <:expr< Tacexpr.TacSimpleInduction ($mlexpr_of_quantified_hypothesis h$) >>
+  | Tacexpr.TacNewInduction (cl,cbo,ids) ->
       let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in
-      let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in
-      <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref [])>>
+      let ids = mlexpr_of_intro_pattern ids in
+(*       let ids = mlexpr_of_option mlexpr_of_intro_pattern ids in *)
+(*       <:expr< Tacexpr.TacNewInduction $mlexpr_of_induction_arg c$ $cbo$ $ids$>> *)
+      <:expr< Tacexpr.TacNewInduction $mlexpr_of_list mlexpr_of_induction_arg cl$ $cbo$ $ids$>>
   | Tacexpr.TacSimpleDestruct h ->
       <:expr< Tacexpr.TacSimpleDestruct $mlexpr_of_quantified_hypothesis h$ >>
   | Tacexpr.TacNewDestruct (c,cbo,ids) ->
       let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in
-      let ids = mlexpr_of_option mlexpr_of_intro_pattern (fst ids) in
-      <:expr< Tacexpr.TacNewDestruct $mlexpr_of_induction_arg c$ $cbo$ ($ids$,ref []) >>
+      let ids = mlexpr_of_intro_pattern ids in
+      <:expr< Tacexpr.TacNewDestruct $mlexpr_of_list mlexpr_of_induction_arg c$ $cbo$ $ids$ >>
 
   (* Context management *)
-  | Tacexpr.TacClear l ->
+  | Tacexpr.TacClear (b,l) ->
       let l = mlexpr_of_list (mlexpr_of_hyp) l in
-      <:expr< Tacexpr.TacClear $l$ >>
+      <:expr< Tacexpr.TacClear $mlexpr_of_bool b$ $l$ >>
   | Tacexpr.TacClearBody l ->
       let l = mlexpr_of_list (mlexpr_of_hyp) l in
       <:expr< Tacexpr.TacClearBody $l$ >>
@@ -453,15 +377,15 @@ let rec mlexpr_of_atomic_tactic = function
   | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_constr c$ >>
 
   (* Automation tactics *)
-  | Tacexpr.TacAuto (n,l) ->
+  | Tacexpr.TacAuto (n,lems,l) ->
       let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in
+      let lems = mlexpr_of_list mlexpr_of_constr lems in
       let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
-      <:expr< Tacexpr.TacAuto $n$ $l$ >>
-(*
-  | Tacexpr.TacTrivial l ->
+      <:expr< Tacexpr.TacAuto $n$ $lems$ $l$ >>
+  | Tacexpr.TacTrivial (lems,l) ->
       let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
-      <:expr< Tacexpr.TacTrivial $l$ >>
-*)
+      let lems = mlexpr_of_list mlexpr_of_constr lems in
+      <:expr< Tacexpr.TacTrivial $lems$ $l$ >>
 
 (*
   | Tacexpr.TacExtend (s,l) ->
@@ -492,8 +416,10 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
       <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >>
   | Tacexpr.TacProgress t ->
       <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >>
-  | Tacexpr.TacId s -> <:expr< Tacexpr.TacId $str:s$ >>
-  | Tacexpr.TacFail (n,s) -> <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $str:s$ >>
+  | Tacexpr.TacId l -> 
+      <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >>
+  | Tacexpr.TacFail (n,l) ->
+      <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >>
 (*
   | Tacexpr.TacInfo t -> TacInfo (loc,f t)
 
@@ -507,16 +433,22 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
 	  (mlexpr_of_option mlexpr_of_tactic)
 	  mlexpr_of_tactic_arg in
       <:expr< Tacexpr.TacLetIn $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >>
-  | Tacexpr.TacMatch (t,l) ->
+  | Tacexpr.TacMatch (lz,t,l) ->
       <:expr< Tacexpr.TacMatch
+        $mlexpr_of_bool lz$
         $mlexpr_of_tactic t$
         $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
-  | Tacexpr.TacMatchContext (lr,l) ->
+  | Tacexpr.TacMatchContext (lz,lr,l) ->
       <:expr< Tacexpr.TacMatchContext 
+        $mlexpr_of_bool lz$
         $mlexpr_of_bool lr$
         $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
+
+  | Tacexpr.TacFun (idol,body) ->
+      <:expr< Tacexpr.TacFun
+        ($mlexpr_of_list mlexpr_of_ident_option idol$,
+         $mlexpr_of_tactic body$) >>
 (*
-  | Tacexpr.TacFun of $dloc$ * tactic_fun_ast
   | Tacexpr.TacFunRec of $dloc$ * identifier * tactic_fun_ast
 *)
 (*
@@ -539,14 +471,6 @@ and mlexpr_of_tactic_arg = function
       <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >>
   | _ -> failwith "mlexpr_of_tactic_arg: TODO"
 
-let f e =
-  let ee s =
-    mlexpr_of_ast (Pcoq.Gram.Entry.parse e
-                     (Pcoq.Gram.parsable (Stream.of_string s)))
-  in
-  let ep s = patt_of_expr (ee s) in
-  Quotation.ExAst (ee, ep)
-
 let fconstr e =
   let ee s =
     mlexpr_of_constr (Pcoq.Gram.Entry.parse e
@@ -566,6 +490,4 @@ let ftac e =
 let _ = 
   Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi);
   Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi);
-(*  Quotation.add "vernac" (f Pcoq.Vernac_.vernac_eoi);*)
-(*  Quotation.add "ast" (f Pcoq.Prim.ast_eoi);*)
   Quotation.default := "constr"
diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4
index b3f5393c..2ef56907 100644
--- a/parsing/q_util.ml4
+++ b/parsing/q_util.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: q_util.ml4,v 1.2.2.2 2004/07/16 19:30:41 herbelin Exp $ *)
+(* $Id: q_util.ml4 9333 2006-11-02 13:59:14Z barras $ *)
 
 (* This file defines standard combinators to build ml expressions *)
 
@@ -66,3 +66,69 @@ let mlexpr_of_string s = <:expr< $str:s$ >>
 let mlexpr_of_option f = function
   | None -> <:expr< None >>
   | Some e -> <:expr< Some $f e$ >>
+
+open Vernacexpr
+open Pcoq
+open Genarg
+
+let modifiers e =
+<:expr<  Gramext.srules
+    [([], Gramext.action(fun _loc -> []));
+     ([Gramext.Stoken ("", "(");
+       Gramext.Slist1sep ($e$, Gramext.Stoken ("", ","));
+       Gramext.Stoken ("", ")")],
+      Gramext.action (fun _ l _ _loc -> l))]
+ >>
+
+let rec interp_entry_name loc s sep =
+  let l = String.length s in
+  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name loc (String.sub s 3 (l-8)) "" in
+    List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
+  else if l > 12 & String.sub s 0 3 = "ne_" &
+                   String.sub s (l-9) 9 = "_list_sep" then
+    let t, g = interp_entry_name loc (String.sub s 3 (l-12)) "" in
+    let sep = <:expr< Gramext.Stoken("",$str:sep$) >> in
+    List1ArgType t, <:expr< Gramext.Slist1sep $g$ $sep$ >>
+  else if l > 5 & String.sub s (l-5) 5 = "_list" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-5)) "" in
+    List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
+  else if l > 9 & String.sub s (l-9) 9 = "_list_sep" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-9)) "" in
+    let sep = <:expr< Gramext.Stoken("",$str:sep$) >> in
+    List0ArgType t, <:expr< Gramext.Slist0sep $g$ $sep$ >>
+  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-4)) "" in
+    OptArgType t, <:expr< Gramext.Sopt $g$ >>
+  else if l > 5 & String.sub s (l-5) 5 = "_mods" then
+    let t, g = interp_entry_name loc (String.sub s 0 (l-1)) "" in
+    List0ArgType t, modifiers g
+  else
+    let s = if s = "hyp" then "var" else s in
+    let t, se, lev =
+      match tactic_genarg_level s with
+        | Some 5 ->
+            Some (ExtraArgType s), <:expr< Tactic. binder_tactic >>, None
+	| Some n ->
+            Some (ExtraArgType s), <:expr< Tactic. tactic_expr >>, Some n
+	| None ->
+      match Pcoq.entry_type (Pcoq.get_univ "prim") s with
+	| Some _ as x -> x, <:expr< Prim. $lid:s$ >>, None
+	| None -> 
+      match Pcoq.entry_type (Pcoq.get_univ "constr") s with
+	| Some _ as x -> x, <:expr< Constr. $lid:s$ >>, None
+	| None -> 
+      match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
+	| Some _ as x -> x, <:expr< Tactic. $lid:s$ >>, None
+	| None -> None, <:expr< $lid:s$ >>, None in
+    let t =
+      match t with
+	| Some t -> t
+	| None -> ExtraArgType s in
+    let entry = match lev with
+      | Some n ->
+	  let s = string_of_int n in
+	  <:expr< Gramext.Snterml (Pcoq.Gram.Entry.obj $se$, $str:s$) >>
+      | None -> 
+	  <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
+    in t, entry
diff --git a/parsing/q_util.mli b/parsing/q_util.mli
index a2c22bc3..901f9198 100644
--- a/parsing/q_util.mli
+++ b/parsing/q_util.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: q_util.mli,v 1.2.2.1 2004/07/16 19:30:41 herbelin Exp $ i*)
+(*i $Id: q_util.mli 9265 2006-10-24 08:35:38Z herbelin $ i*)
 
 val patt_of_expr : MLast.expr -> MLast.patt
 
@@ -28,3 +28,5 @@ val mlexpr_of_string : string -> MLast.expr
 
 val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
 
+val interp_entry_name : Util.loc -> string -> string -> 
+  Pcoq.entry_type * MLast.expr
diff --git a/parsing/search.ml b/parsing/search.ml
index a3d6e000..28362d72 100644
--- a/parsing/search.ml
+++ b/parsing/search.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: search.ml,v 1.30.2.1 2004/07/16 19:30:41 herbelin Exp $ *)
+(* $Id: search.ml 9310 2006-10-28 19:35:09Z herbelin $ *)
 
 open Pp
 open Util
@@ -17,7 +17,6 @@ open Rawterm
 open Declarations
 open Libobject
 open Declare
-open Coqast
 open Environ
 open Pattern
 open Matching
@@ -34,37 +33,36 @@ open Nametab
 
 let print_constructors indsp fn env nconstr =
   for i = 1 to nconstr do
-    fn (ConstructRef (indsp,i)) env (Inductive.type_of_constructor env (indsp,i))
+    fn (ConstructRef (indsp,i)) env (Inductiveops.type_of_constructor env (indsp,i))
   done
 
 let rec head_const c = match kind_of_term c with
   | Prod (_,_,d) -> head_const d
   | LetIn (_,_,_,d) -> head_const d
   | App (f,_)   -> head_const f
-  | Cast (d,_)   -> head_const d
+  | Cast (d,_,_)   -> head_const d
   | _            -> c
 
 (* General search, restricted to head constant if [only_head] *)
 
 let gen_crible refopt (fn : global_reference -> env -> constr -> unit) =
   let env = Global.env () in
-  let imported = Library.opened_libraries() in
   let crible_rec (sp,_) lobj = match object_tag lobj with
     | "VARIABLE" ->
 	(try 
 	   let (idc,_,typ) = get_variable (basename sp) in 
            if refopt = None
-	     || head_const typ = constr_of_reference (out_some refopt)
+	     || head_const typ = constr_of_global (out_some refopt)
 	   then
 	     fn (VarRef idc) env typ
 	 with Not_found -> (* we are in a section *) ())
     | "CONSTANT" ->
-	let kn = locate_constant (qualid_of_sp sp) in
-	let {const_type=typ} = Global.lookup_constant kn in
+	let cst = locate_constant (qualid_of_sp sp) in
+	let typ = Typeops.type_of_constant env cst in
         if refopt = None
-	  || head_const typ = constr_of_reference (out_some refopt)
+	  || head_const typ = constr_of_global (out_some refopt)
 	then
-	  fn (ConstRef kn) env typ
+	  fn (ConstRef cst) env typ
     | "INDUCTIVE" -> 
 	let kn = locate_mind (qualid_of_sp sp) in
         let mib = Global.lookup_mind kn in 
@@ -80,7 +78,7 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) =
     | _ -> ()
   in 
   try 
-    Declaremods.iter_all_segments false crible_rec
+    Declaremods.iter_all_segments crible_rec
   with Not_found -> 
     ()
 
@@ -104,7 +102,7 @@ let constr_to_section_path c = match kind_of_term c with
 let xor a b = (a or b) & (not (a & b))
 
 let plain_display ref a c =
-  let pc = prterm_env a c in
+  let pc = pr_lconstr_env a c in
   let pr = pr_global ref in
   msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ())
 
@@ -210,7 +208,7 @@ type glob_search_about_item =
   | GlobSearchString of string
 
 let search_about_item (itemref,typ) = function
-  | GlobSearchRef ref -> Termops.occur_term (constr_of_reference ref) typ
+  | GlobSearchRef ref -> Termops.occur_term (constr_of_global ref) typ
   | GlobSearchString s -> string_string_contains (name_of_reference itemref) s
 
 let raw_search_about filter_modules display_function l =
diff --git a/parsing/search.mli b/parsing/search.mli
index 62ba865d..8ee708bc 100644
--- a/parsing/search.mli
+++ b/parsing/search.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: search.mli,v 1.16.2.1 2004/07/16 19:30:41 herbelin Exp $ i*)
+(*i $Id: search.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 open Pp
 open Names
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
index bbacd013..73d41465 100644
--- a/parsing/tacextend.ml4
+++ b/parsing/tacextend.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacextend.ml4,v 1.10.2.2 2004/07/16 19:30:41 herbelin Exp $ *)
+(* $Id: tacextend.ml4 9265 2006-10-24 08:35:38Z herbelin $ *)
 
 open Genarg
 open Q_util
@@ -45,13 +45,13 @@ let rec make_let e = function
       let v = 
         (* Special case for tactics which must be stored in algebraic
            form to avoid marshalling closures and to be reprinted *)
-        if t = TacticArgType then
+        if Pcoq.is_tactic_genarg t then
           <:expr< ($v$, Tacinterp.eval_tactic $v$) >>
         else v in
       <:expr< let $lid:p$ = $v$ in $e$ >>
   | _::l -> make_let e l
 
-let add_clause s (_,pt,e) l =
+let add_clause s (pt,e) l =
   let p = make_patt pt in
   let w = Some (make_when (MLast.loc_of_expr e) pt) in
   (p, w, make_let e pt)::l
@@ -62,7 +62,7 @@ let rec extract_signature = function
   | _::l -> extract_signature l
 
 let check_unicity s l =
-  let l' = List.map (fun (_,l,_) -> extract_signature l) l in
+  let l' = List.map (fun (l,_) -> extract_signature l) l in
   if not (Util.list_distinct l') then
     Pp.warning_with Pp_control.err_ft
       ("Two distinct rules of tactic entry "^s^" have the same\n"^
@@ -82,7 +82,7 @@ let rec make_args = function
 
 let rec make_eval_tactic e = function
   | [] -> e
-  | TacNonTerm(loc,TacticArgType,_,Some p)::l ->
+  | TacNonTerm(loc,tag,_,Some p)::l when Pcoq.is_tactic_genarg tag ->
       let loc = join_loc loc (MLast.loc_of_expr e) in
       let e = make_eval_tactic e l in
         (* Special case for tactics which must be stored in algebraic
@@ -106,11 +106,8 @@ let mlexpr_terminals_of_grammar_production = function
   | TacTerm s -> <:expr< Some $mlexpr_of_string s$ >>
   | TacNonTerm (loc,nt,g,sopt) -> <:expr< None >>
 
-let mlexpr_of_semi_clause =
-  mlexpr_of_pair mlexpr_of_string (mlexpr_of_list mlexpr_of_grammar_production)
-
 let mlexpr_of_clause =
-  mlexpr_of_list (fun (a,b,c) -> mlexpr_of_semi_clause (a,b))
+  mlexpr_of_list (fun (a,b) -> mlexpr_of_list mlexpr_of_grammar_production a)
 
 let rec make_tags loc = function
   | [] -> <:expr< [] >>
@@ -121,44 +118,13 @@ let rec make_tags loc = function
       <:expr< [ $t$ :: $l$ ] >>
   | _::l -> make_tags loc l
 
-let make_one_printing_rule (s,pt,e) =
+let make_one_printing_rule se (pt,e) =
+  let level = mlexpr_of_int 0 in (* only level 0 supported here *)
   let loc = MLast.loc_of_expr e in
   let prods = mlexpr_of_list mlexpr_terminals_of_grammar_production pt in
-  <:expr< ($make_tags loc pt$, ($str:s$, $prods$)) >>
-
-let make_printing_rule = mlexpr_of_list make_one_printing_rule
+  <:expr< ($se$, $make_tags loc pt$, ($level$, $prods$)) >>
 
-let new_tac_ext (s,cl) =
-  (String.lowercase s, List.map 
-    (fun (s,l,e) ->
-      (String.lowercase s, List.map
-        (function TacTerm s -> TacTerm (String.lowercase s)
-          | t -> t) l,
-        e))
-    cl)
-
-let declare_tactic_v7 loc s cl =
-  let pp = make_printing_rule cl in
-  let gl = mlexpr_of_clause cl in
-  let hide_tac (_,p,e) =
-    (* reste a definir les fonctions cachees avec des noms frais *)
-    let stac = let s = "h_"^s in s.[2] <- Char.lowercase s.[2]; s in
-    let e = 
-      make_fun
-        <:expr<
-          Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$
-        >>
-      p in
-    <:str_item< value $lid:stac$ = $e$ >>
-  in
-  let se = mlexpr_of_string s in
-  <:str_item<
-    declare
-      open Pcoq;
-      Egrammar.extend_tactic_grammar $se$ $gl$;
-      List.iter (Pptactic.declare_extra_tactic_pprule False $se$) $pp$;
-    end
-  >>
+let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se)
 
 let rec contains_epsilon = function
   | List0ArgType _ -> true
@@ -167,89 +133,50 @@ let rec contains_epsilon = function
   | PairArgType(t1,t2) -> contains_epsilon t1 && contains_epsilon t2
   | ExtraArgType("hintbases") -> true
   | _ -> false
-let is_atomic =
-  List.for_all
-    (function
-        TacTerm _ -> false
-      | TacNonTerm(_,t,_,_) -> contains_epsilon t)
+let is_atomic = function
+  | TacTerm s :: l when 
+      List.for_all (function
+          TacTerm _ -> false
+	| TacNonTerm(_,t,_,_) -> contains_epsilon t) l
+	-> [s]
+  | _ -> []
 
 let declare_tactic loc s cl =
-  let (s',cl') = new_tac_ext (s,cl) in
-  let pp' = make_printing_rule cl' in
-  let gl' = mlexpr_of_clause cl' in
-  let se' = mlexpr_of_string s' in
-  let pp = make_printing_rule cl in
+  let se = mlexpr_of_string s in
+  let pp = make_printing_rule se cl in
   let gl = mlexpr_of_clause cl in
-  let hide_tac (_,p,e) =
+  let hide_tac (p,e) =
     (* reste a definir les fonctions cachees avec des noms frais *)
-    let stac = "h_"^s' in
+    let stac = "h_"^s in
     let e = 
       make_fun
         <:expr<
-          Refiner.abstract_extended_tactic $mlexpr_of_string s'$ $make_args p$ $make_eval_tactic e p$
+          Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$
         >>
       p in
     <:str_item< value $lid:stac$ = $e$ >>
   in
-  let hidden = if List.length cl = 1 then List.map hide_tac cl' else [] in
-  let se = mlexpr_of_string s in
+  let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in
   let atomic_tactics =
-    mlexpr_of_list (fun (s,_,_) -> mlexpr_of_string s)
-      (List.filter (fun (_,al,_) -> is_atomic al) cl') in
+    mlexpr_of_list mlexpr_of_string
+      (List.flatten (List.map (fun (al,_) -> is_atomic al) cl)) in
   <:str_item<
     declare
       open Pcoq;
       declare $list:hidden$ end;
       try
-        let _=Refiner.add_tactic $se'$ (fun [ $list:make_clauses s' cl'$ ]) in
+        let _=Tacinterp.add_tactic $se$ (fun [ $list:make_clauses s cl$ ]) in
         List.iter
           (fun s -> Tacinterp.add_primitive_tactic s
               (Tacexpr.TacAtom($default_loc$,
                  Tacexpr.TacExtend($default_loc$,s,[]))))
           $atomic_tactics$
       with e -> Pp.pp (Cerrors.explain_exn e);
-      if Options.v7.val then Egrammar.extend_tactic_grammar $se'$ $gl$
-      else Egrammar.extend_tactic_grammar $se'$ $gl'$;
-      List.iter (Pptactic.declare_extra_tactic_pprule True $se'$) $pp'$;
-      List.iter (Pptactic.declare_extra_tactic_pprule False $se'$) $pp$;
+      Egrammar.extend_tactic_grammar $se$ $gl$;
+      List.iter Pptactic.declare_extra_tactic_pprule $pp$;
     end
   >>
 
-open Vernacexpr
-open Pcoq
-
-let rec interp_entry_name loc s =
-  let l = String.length s in
-  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in
-    List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
-  else if l > 5 & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in
-    List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
-  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in
-    OptArgType t, <:expr< Gramext.Sopt $g$ >>
-  else
-    
-    let t, se =
-      match Pcoq.entry_type (Pcoq.get_univ "prim") s with
-	| Some _ as x -> x, <:expr< Prim. $lid:s$ >>
-	| None -> 
-      match Pcoq.entry_type (Pcoq.get_univ "constr") s with
-	| Some _ as x -> x, <:expr< Constr. $lid:s$ >>
-	| None -> 
-      match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
-	| Some _ as x -> x, <:expr< Tactic. $lid:s$ >>
-	| None -> None, <:expr< $lid:s$ >> in
-    let t =
-      match t with
-	| Some t -> t
-	| None ->
-(*	    Pp.warning_with Pp_control.err_ft
-            ("Unknown primitive grammar entry: "^s);*)
-	    ExtraArgType s
-    in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
-
 open Pcaml
 
 EXTEND
@@ -258,24 +185,26 @@ EXTEND
     [ [ "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ];
         OPT "|"; l = LIST1 tacrule SEP "|";
         "END" ->
-         declare_tactic loc s l
-      | "V7"; "TACTIC"; "EXTEND"; s = [ UIDENT | LIDENT ];
-        OPT "|"; l = LIST1 tacrule SEP "|";
-        "END" ->
-         declare_tactic_v7 loc s l ] ]
+         declare_tactic loc s l ] ]
   ;
   tacrule:
-    [ [ "["; s = STRING; l = LIST0 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]"
-        ->
-       if s = "" then Util.user_err_loc (loc,"",Pp.str "Tactic name is empty");
-       (s,l,e)
+    [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]"
+        -> 
+	  if match List.hd l with TacNonTerm _ -> true | _ -> false then
+	    (* En attendant la syntaxe de tacticielles *)
+	    failwith "Tactic syntax must start with an identifier";
+	  (l,e)
     ] ]
   ;
   tacargs:
     [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name loc e in
+        let t, g = Q_util.interp_entry_name loc e "" in
+        TacNonTerm (loc, t, g, Some s)
+      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
+        let t, g = Q_util.interp_entry_name loc e sep in
         TacNonTerm (loc, t, g, Some s)
       | s = STRING ->
+	if s = "" then Util.user_err_loc (loc,"",Pp.str "Empty terminal");
         TacTerm s
     ] ]
   ;
diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml
new file mode 100644
index 00000000..1fef688c
--- /dev/null
+++ b/parsing/tactic_printer.ml
@@ -0,0 +1,239 @@
+(************************************************************************)
+(*  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: tactic_printer.ml 9593 2007-02-05 13:58:52Z corbinea $ *)
+
+open Pp
+open Util
+open Sign
+open Evd
+open Tacexpr
+open Proof_type
+open Proof_trees
+open Decl_expr
+open Logic
+open Printer
+
+let pr_tactic = function
+  | TacArg (Tacexp t) ->
+      (*top tactic from tacinterp*)
+      Pptactic.pr_glob_tactic (Global.env()) t
+  | t -> 
+      Pptactic.pr_tactic (Global.env()) t
+
+let pr_proof_instr instr = 
+    Ppdecl_proof.pr_proof_instr (Global.env()) instr
+
+let pr_rule = function
+  | Prim r -> hov 0 (pr_prim_rule r)
+  | Nested(cmpd,_) ->
+      begin
+	match cmpd with 
+	    Tactic (texp,_) -> hov 0 (pr_tactic texp)
+	  | Proof_instr (_,instr) -> hov 0 (pr_proof_instr instr)
+      end
+  | Daimon -> str "<Daimon>"
+  | Decl_proof _ -> str "proof" 
+
+let uses_default_tac = function
+  | Nested(Tactic(_,dflt),_) -> dflt
+  | _ -> false
+
+(* Does not print change of evars *)
+let pr_rule_dot = function 
+  | Prim Change_evars -> mt ()
+  | r ->
+      pr_rule r ++ if uses_default_tac r then str "..." else str"."
+
+exception Different
+
+(* We remove from the var context of env what is already in osign *)
+let thin_sign osign sign =
+  Sign.fold_named_context
+    (fun (id,c,ty as d) sign ->
+       try 
+	 if Sign.lookup_named id osign = (id,c,ty) then sign
+	 else raise Different
+       with Not_found | Different -> Environ.push_named_context_val d sign)
+    sign ~init:Environ.empty_named_context_val
+
+let rec print_proof sigma osign pf =
+  let hyps = Environ.named_context_of_val pf.goal.evar_hyps in
+  let hyps' = thin_sign osign hyps in
+  match pf.ref with
+    | None -> 
+	hov 0 (pr_goal {pf.goal with evar_hyps=hyps'})
+    | Some(r,spfl) ->
+    	hov 0 
+	  (hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) ++
+	   spc () ++ str" BY " ++
+	   hov 0 (pr_rule r) ++ fnl () ++
+	   str"  " ++
+	   hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl))
+	  
+let pr_change gl = 
+  str"change " ++
+  pr_lconstr_env (Global.env_of_context gl.evar_hyps) gl.evar_concl ++ str"."
+
+let rec print_decl_script tac_printer nochange sigma pf =
+  match pf.ref with
+    | None ->
+	(if nochange then 
+	   (str"<Your Proof Text here>")
+	 else 
+	   pr_change pf.goal)
+	++ fnl ()
+    | Some (Daimon,[]) -> mt ()
+    | Some (Prim Change_evars,[next]) -> 
+      (* ignore evar changes *)
+        print_decl_script tac_printer nochange sigma next
+    | Some (Nested(Proof_instr (opened,instr),_) as rule,subprfs) ->
+	begin
+	  match instr.instr,subprfs with
+	    Pescape,[{ref=Some(_,subsubprfs)}] ->
+	      hov 7
+		(pr_rule_dot rule ++ fnl () ++
+		   prlist_with_sep pr_fnl tac_printer subsubprfs) ++ fnl () ++
+		if opened then mt () else str "return."
+	  | Pclaim _,[body;cont] ->
+	      hov 2
+		(pr_rule_dot rule ++ fnl () ++
+		   print_decl_script tac_printer nochange sigma body) ++ 
+		fnl () ++
+		if opened then mt () else str "end claim." ++ fnl () ++
+		  print_decl_script tac_printer nochange sigma cont
+	  | Pfocus _,[body;cont] ->
+	      hov 2 
+		(pr_rule_dot rule ++ fnl () ++
+		   print_decl_script tac_printer nochange sigma body) ++ 
+		fnl () ++
+		if opened then mt () else str "end focus." ++ fnl () ++
+		  print_decl_script tac_printer nochange sigma cont
+	  | (Psuppose _ |Pcase (_,_,_)),[body;cont] ->
+	      hov 2 
+		(pr_rule_dot rule ++ fnl () ++
+		   print_decl_script tac_printer nochange sigma body) ++ 
+		fnl () ++
+		print_decl_script tac_printer nochange sigma cont 
+	  | _,[next] ->
+	      pr_rule_dot rule ++ fnl () ++
+		print_decl_script tac_printer nochange sigma next
+	  | _,[] ->
+	      pr_rule_dot rule		
+	  | _,_ -> anomaly "unknown branching instruction"
+	end
+    | _ -> anomaly "Not Applicable"
+
+let rec print_script nochange sigma pf =
+  match pf.ref with
+    | None ->
+        (if nochange then 
+	   (str"<Your Tactic Text here>") 
+	 else 
+	   pr_change pf.goal)
+	++ fnl ()
+    | Some(Decl_proof opened,script) ->
+	assert (List.length script = 1);
+	begin
+	  if nochange then (mt ()) else (pr_change pf.goal ++ fnl ()) 
+	end ++
+	  begin
+	    hov 0 (str "proof." ++ fnl () ++ 
+		     print_decl_script (print_script nochange sigma) 
+		     nochange sigma (List.hd script))
+	  end ++ fnl () ++
+	  begin
+	    if opened then mt () else (str "end proof." ++ fnl ())
+	  end
+    | Some(Daimon,spfl) ->
+	((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++
+	   prlist_with_sep pr_fnl
+           (print_script nochange sigma) spfl )
+    | Some(rule,spfl) ->
+	((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++
+	   pr_rule_dot rule ++ fnl () ++
+	   prlist_with_sep pr_fnl
+           (print_script nochange sigma) spfl )	
+
+(* printed by Show Script command *)
+
+let print_treescript nochange sigma pf =
+  let rec aux top pf =
+    match pf.ref with
+    | None ->
+        if nochange then 
+	  if pf.goal.evar_extra=None then
+	    (str"<Your Tactic Text here>")
+	  else (str"<Your Proof Text here>")
+	else 
+	  (pr_change pf.goal)
+    | Some(Decl_proof opened,script) ->
+	assert (List.length script = 1);
+	begin
+	  if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())
+	end ++
+	  hov 0 
+	  begin str "proof." ++ fnl () ++
+	    print_decl_script (aux false)  
+	    nochange sigma (List.hd script) 
+	  end ++ fnl () ++ 
+	  begin
+	    if opened then mt () else (str "end proof." ++ fnl ())
+	  end
+    | Some(Daimon,spfl) ->
+	((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++
+	   prlist_with_sep pr_fnl
+           (print_script nochange sigma) spfl )
+    | Some(r,spfl) ->
+        (if nochange then mt () else (pr_change pf.goal ++ fnl ())) ++
+	  pr_rule_dot r ++
+	  begin
+	    if List.length spfl > 1 then
+	      fnl ()  ++ 
+		str " " ++  hov 0 (aux false (List.hd spfl)) ++ fnl () ++
+		hov 0 (prlist_with_sep fnl (aux false) (List.tl spfl))
+	    else
+	      match spfl with
+		| [] -> mt ()
+		| [spf] -> fnl () ++ 
+		    (if top then mt () else str "  ") ++ aux top spf
+		| _ -> fnl () ++ str " " ++
+		    hov 0 (prlist_with_sep fnl (aux false) spfl)
+	  end
+  in hov 0 (aux true pf)
+
+let rec print_info_script sigma osign pf =
+  let {evar_hyps=sign; evar_concl=cl} = pf.goal in
+  match pf.ref with
+    | None -> (mt ())
+    | Some(r,spfl) ->
+        (pr_rule r ++ 
+           match spfl with
+             | [pf1] ->
+                 if pf1.ref = None then 
+		   (str "." ++ fnl ())
+                 else 
+		   (str";" ++ brk(1,3) ++
+		      print_info_script sigma 
+		      (Environ.named_context_of_val sign) pf1)
+             | _ -> (str"." ++ fnl () ++
+                       prlist_with_sep pr_fnl
+                         (print_info_script sigma 
+			    (Environ.named_context_of_val sign)) spfl))
+
+let format_print_info_script sigma osign pf = 
+  hov 0 (print_info_script sigma osign pf)
+    
+let print_subscript sigma sign pf = 
+  if is_tactic_proof pf then 
+    format_print_info_script sigma sign (subproof_of_proof pf)
+  else 
+    format_print_info_script sigma sign pf
+
+let _ = Refiner.set_info_printer print_subscript
+
diff --git a/translate/pptacticnew.mli b/parsing/tactic_printer.mli
index b49b9e56..b1f6d41c 100644
--- a/translate/pptacticnew.mli
+++ b/parsing/tactic_printer.mli
@@ -5,26 +5,23 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: pptacticnew.mli,v 1.6.2.3 2005/01/21 17:17:20 herbelin Exp $ i*)
 
+(*i $Id: tactic_printer.mli 9154 2006-09-20 17:18:18Z corbinea $ i*)
+
+(*i*)
 open Pp
-open Genarg
+open Sign
+open Evd
 open Tacexpr
 open Proof_type
-open Topconstr
-open Names
-
-val qsnew : string -> std_ppcmds
-
-val pr_intro_pattern : intro_pattern_expr -> std_ppcmds
-
-val pr_raw_tactic : Environ.env -> raw_tactic_expr -> std_ppcmds
- 
-val pr_glob_tactic : Environ.env -> glob_tactic_expr -> std_ppcmds
-
-val pr_tactic : Environ.env -> Proof_type.tactic_expr -> std_ppcmds
-
-val id_of_ltac_v7_id : identifier -> identifier
+(*i*)
 
+(* These are the entry points for tactics, proof trees, ... *)
 
+val print_proof : evar_map -> named_context -> proof_tree -> std_ppcmds
+val pr_rule     : rule -> std_ppcmds
+val pr_tactic   : tactic_expr -> std_ppcmds
+val print_script :
+  bool -> evar_map -> proof_tree -> std_ppcmds
+val print_treescript :
+  bool -> evar_map -> proof_tree -> std_ppcmds
diff --git a/parsing/termast.ml b/parsing/termast.ml
deleted file mode 100644
index 47e45d42..00000000
--- a/parsing/termast.ml
+++ /dev/null
@@ -1,503 +0,0 @@
-(************************************************************************)
-(*  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: termast.ml,v 1.78.2.1 2004/07/16 19:30:42 herbelin Exp $ *)
-
-open Pp
-open Util
-open Univ
-open Names
-open Nameops
-open Term
-open Termops
-open Inductive
-open Sign
-open Environ
-open Libnames
-open Declare
-open Impargs
-open Coqast
-open Ast
-open Rawterm
-open Pattern
-open Nametab
-
-(* In this file, we translate rawconstr to ast, in order to print constr *)
-
-(**********************************************************************)
-(* Parametrization                                                    *)
-open Constrextern
-(*
-(* This governs printing of local context of references *)
-let print_arguments = ref false
-
-(* If true, prints local context of evars, whatever print_arguments *)
-let print_evar_arguments = ref false
-*)
-
-(* This forces printing of cast nodes *)
-let print_casts = ref true
-
-(*
-(* This governs printing of implicit arguments.  When
-   [print_implicits] is on then [print_implicits_explicit_args] tells
-   how implicit args are printed. If on, implicit args are printed
-   prefixed by "!" otherwise the function and not the arguments is
-   prefixed by "!" *)
-let print_implicits = ref false
-*)
-let print_implicits_explicit_args = ref false
-
-(*
-(* This forces printing of coercions *)
-let print_coercions = ref false
-
-(* This forces printing universe names of Type{.} *)
-let print_universes = ref false
-
-
-let with_option o f x =
-  let old = !o in o:=true;
-  try let r = f x in o := old; r
-  with e -> o := old; raise e
-
-let with_arguments f = with_option print_arguments f
-let with_casts f = with_option print_casts f
-let with_implicits f = with_option print_implicits f
-let with_coercions f = with_option print_coercions f
-let with_universes f = with_option print_universes f
-*)
-(**********************************************************************)
-(* conversion of references                                           *)
-
-let ids_of_ctxt ctxt =
-  Array.to_list
-    (Array.map
-       (function c -> match kind_of_term c with
-	  | Var id -> id
-	  | _ ->
-       error
-       "Termast: arbitrary substitution of references not yet implemented")
-     ctxt)
-
-let ast_of_ident id = nvar id
-
-let ast_of_name = function 
-  | Name id -> nvar id
-  | Anonymous -> nvar wildcard
-
-let idopt_of_name = function 
-  | Name id -> Some id
-  | Anonymous -> None
-
-let ast_of_binders bl =
-  List.map (fun (nal,isdef,ty) ->
-    if isdef then ope("LETBINDER",ty::List.map ast_of_name nal)
-    else ope("BINDER",ty::List.map ast_of_name nal)) bl
-
-let ast_type_of_binder bl t =
-  List.fold_right (fun (nal,isdef,ty) ast ->
-    if isdef then
-      ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)])
-    else
-      ope("PROD",[ty;List.fold_right
-        (fun na ast -> slam(idopt_of_name na,ast)) nal ast]))
-    bl t
-
-let ast_body_of_binder bl t =
-  List.fold_right (fun (nal,isdef,ty) ast ->
-    if isdef then
-      ope("LETIN",[ty;slam(idopt_of_name (List.hd nal),ast)])
-    else
-      ope("LAMBDA",[ty;List.fold_right
-        (fun na ast -> slam(idopt_of_name na,ast)) nal ast]))
-    bl t
-
-let ast_of_constant_ref sp =
-  ope("CONST", [path_section dummy_loc sp])
-
-let ast_of_existential_ref ev =
-(*
-  let ev = 
-    try int_of_string (string_of_id ev)
-    with _ -> warning "cannot find existential variable number"; 0 in
-*)
-  ope("EVAR", [num ev])
-
-let ast_of_constructor_ref ((sp,tyi),n) =
-  ope("MUTCONSTRUCT",[path_section dummy_loc sp; num tyi; num n])
-
-let ast_of_inductive_ref (sp,tyi) =
-  ope("MUTIND", [path_section dummy_loc sp; num tyi])
-
-let ast_of_section_variable_ref s =
-  ope("SECVAR", [nvar s])
-
-let ast_of_qualid p =
-  let dir, s = repr_qualid p in
-  let args = List.map nvar ((List.rev(repr_dirpath dir))@[s]) in
-  ope ("QUALID", args)
-
-let ast_of_ref = function
-  | ConstRef sp -> ast_of_constant_ref sp
-  | IndRef sp -> ast_of_inductive_ref sp
-  | ConstructRef sp -> ast_of_constructor_ref sp
-  | VarRef id -> ast_of_section_variable_ref id
-
-(**********************************************************************)
-(* conversion of patterns                                             *)
-
-let rec ast_of_cases_pattern = function   (* loc is thrown away for printing *)
-  | PatVar (loc,Name id) -> nvar id
-  | PatVar (loc,Anonymous) -> nvar wildcard
-  | PatCstr(loc,cstrsp,args,Name id) ->
-      let args = List.map ast_of_cases_pattern args in
-      ope("PATTAS",
-	  [nvar id;
-	   ope("PATTCONSTRUCT", (ast_of_constructor_ref cstrsp)::args)])
-  | PatCstr(loc,cstrsp,args,Anonymous) ->
-      ope("PATTCONSTRUCT",
-	  (ast_of_constructor_ref cstrsp)
-	  :: List.map ast_of_cases_pattern args)
-	
-let ast_dependent na aty =
-  match na with
-    | Name id -> occur_var_ast id aty
-    | Anonymous -> false
-
-let decompose_binder = function
-  | RProd(_,na,ty,c) -> Some (BProd,na,ty,c)
-  | RLambda(_,na,ty,c) -> Some (BLambda,na,ty,c)
-  | RLetIn(_,na,b,c) -> Some (BLetIn,na,b,c)
-  | _ -> None
-
-(* Implicit args indexes are in ascending order *)
-let explicitize impl args =
-  let n = List.length args in
-  let rec exprec q = function
-    | a::args, imp::impl when is_status_implicit imp ->
-        let tail = exprec (q+1) (args,impl) in
-        let visible =
-          (!print_implicits & !print_implicits_explicit_args)
-          or not (is_inferable_implicit false n imp) in
-        if visible then ope("EXPL", [num q; a]) :: tail else tail
-    | a::args, _::impl -> a :: exprec (q+1) (args,impl)
-    | args, [] -> args  (* In case of polymorphism *)
-    | [], _ -> []
-  in exprec 1 (args,impl)
-
-let rec skip_coercion dest_ref (f,args as app) =
-  if !print_coercions then app
-  else
-    try
-      match dest_ref f with
-	| Some r ->
-	    (match Classops.hide_coercion r with
-	       | Some n ->
-		   if n >= List.length args then app
-		   else (* We skip a coercion *)
-		     let fargs = list_skipn n args in
-	       	     skip_coercion dest_ref (List.hd fargs,List.tl fargs)
-	       | None -> app)
-	| None -> app
-    with Not_found -> app
-
-let ast_of_app impl f args =
-  if !print_implicits & not !print_implicits_explicit_args then 
-    ope("APPLISTEXPL", f::args)
-  else
-    let args = explicitize impl args in
-    if args = [] then f else ope("APPLIST", f::args)
-
-let rec ast_of_raw = function
-  | RRef (_,ref) -> ast_of_ref ref
-  | RVar (_,id) -> ast_of_ident id
-  | REvar (_,n,_) -> (* we drop args *) ast_of_existential_ref n
-  | RPatVar (_,(_,n)) -> ope("META",[ast_of_ident n])
-  | RApp (_,f,args) ->
-      let (f,args) =
-	skip_coercion (function RRef(_,r) -> Some r | _ -> None) (f,args) in
-      let astf = ast_of_raw f in
-      let astargs = List.map ast_of_raw args in
-      (match f with 
-	 | RRef (_,ref) -> ast_of_app (implicits_of_global ref) astf astargs
-	 | _       -> ast_of_app [] astf astargs)
-
-  | RProd (_,Anonymous,t,c) ->
-      (* Anonymous product are never factorized *)
-      ope("ARROW",[ast_of_raw t; slam(None,ast_of_raw c)])
-
-  | RLetIn (_,na,t,c) ->
-      ope("LETIN",[ast_of_raw t; slam(idopt_of_name na,ast_of_raw c)])
-
-  | RProd (_,na,t,c) ->
-      let (n,a) = factorize_binder 1 BProd na (ast_of_raw t) c in
-      (* PROD et PRODLIST doivent être distingués à cause du cas *)
-      (* non dépendant, pour isoler l'implication; peut-être un *)
-      (* constructeur ARROW serait-il plus justifié ? *) 
-      let tag = if n=1 then "PROD" else "PRODLIST" in
-      ope(tag,[ast_of_raw t;a])
-
-  | RLambda (_,na,t,c) ->
-      let (n,a) = factorize_binder 1 BLambda na (ast_of_raw t) c in
-      (* LAMBDA et LAMBDALIST se comportent pareil ... Non ! *)
-      (* Pour compatibilité des theories, il faut LAMBDALIST partout *)
-      ope("LAMBDALIST",[ast_of_raw t;a])
-
-  | RCases (_,(typopt,_),tml,eqns) ->
-      let pred = ast_of_rawopt typopt in
-      let tag = "CASES" in
-      let asttomatch =
-	ope("TOMATCH", List.map (fun (tm,_) -> ast_of_raw tm) tml) in
-      let asteqns = List.map ast_of_eqn eqns in 
-      ope(tag,pred::asttomatch::asteqns)
-	
-  | ROrderedCase (_,LetStyle,typopt,tm,[|bv|],_) ->
-      let nvar' = function Anonymous -> nvar wildcard | Name id -> nvar id in
-      let rec f l = function
-        | RLambda (_,na,RHole _,c) -> f (nvar' na :: l) c
-        | RLetIn (_,na,RHole _,c) -> f (nvar' na :: l) c
-        | c -> List.rev l, ast_of_raw c in
-      let l,c = f [] bv in
-      let eqn = ope ("EQN", [c;ope ("PATTCONSTRUCT",(nvar wildcard)::l)]) in
-      ope ("FORCELET",[(ast_of_rawopt typopt);(ast_of_raw tm);eqn])
-
-  | ROrderedCase (_,st,typopt,tm,bv,_) ->
-      let tag = match st with
-	| IfStyle -> "FORCEIF"
-	| RegularStyle -> "CASE"
-	| MatchStyle | LetStyle -> "MATCH"
-      in
-
-      (* warning "Old Case syntax"; *)
-      ope(tag,(ast_of_rawopt typopt)
-	    ::(ast_of_raw tm)
-	    ::(Array.to_list (Array.map ast_of_raw bv)))
-
-  | RLetTuple _ | RIf _ ->
-      error "Let tuple not supported in v7"
-
-  | RRec (_,fk,idv,blv,tyv,bv) ->
-      let alfi = Array.map ast_of_ident idv in
-      (match fk with
-	 | RFix (nv,n) ->
-             let rec split_lambda binds = function
-	       | (0, t) -> (List.rev binds,ast_of_raw t)
-	       | (n, RLetIn (_,na,b,c)) ->
-		   let bind = ope("LETBINDER",[ast_of_raw b;ast_of_name na]) in
-		   split_lambda (bind::binds) (n,c)
-	       | (n, RLambda (_,na,t,b)) ->
-		   let bind = ope("BINDER",[ast_of_raw t;ast_of_name na]) in
-		   split_lambda (bind::binds) (n-1,b)
-	       | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint body" in
-	     let rec split_product = function
-	       | (0, t) -> ast_of_raw t
-	       | (n, RLetIn (_,na,_,c)) -> split_product (n,c)
-	       | (n, RProd (_,na,t,b)) -> split_product (n-1,b)
-	       | _ -> anomaly "ast_of_rawconst: ill-formed fixpoint type" in
-	     let listdecl = 
-	       Array.mapi
-		 (fun i fi ->
-                   if List.length blv.(i) >= nv.(i)+1 then
-                     let (oldfixp,factb) = list_chop (nv.(i)+1) blv.(i) in
-                     let bl = factorize_local_binder oldfixp in
-                     let factb = factorize_local_binder factb in
-                     let asttyp = ast_type_of_binder factb
-                       (ast_of_raw tyv.(i)) in
-                     let astdef = ast_body_of_binder factb
-                       (ast_of_raw bv.(i)) in
-                     ope("FDECL",[fi;ope("BINDERS",ast_of_binders bl);
-                                  asttyp; astdef])
-                   else
-                     let n = nv.(i)+1 - List.length blv.(i) in
-		     let (lparams,astdef) =
-                       split_lambda [] (n,bv.(i)) in
-                     let bl = factorize_local_binder blv.(i) in
-                     let lparams = ast_of_binders bl @ lparams in
-		     let asttyp = split_product (n,tyv.(i)) in
-		     ope("FDECL",
-		         [fi; ope ("BINDERS",lparams); 
-		          asttyp; astdef]))
-		 alfi
-	     in 
-	     ope("FIX", alfi.(n)::(Array.to_list listdecl))
-	 | RCoFix n -> 
-	     let listdecl =
-               Array.mapi 
-		 (fun i fi ->
-                   let bl = factorize_local_binder blv.(i) in
-                   let asttyp = ast_type_of_binder bl (ast_of_raw tyv.(i)) in
-                   let astdef = ast_body_of_binder bl (ast_of_raw bv.(i)) in
-		   ope("CFDECL",[fi; asttyp; astdef]))
-		 alfi
-	     in 
-	     ope("COFIX", alfi.(n)::(Array.to_list listdecl)))
-
-  | RSort (_,s) ->
-      (match s with
-	 | RProp Null -> ope("PROP",[])
-	 | RProp Pos -> ope("SET",[])
-	 | RType (Some u) when !print_universes -> ope("TYPE",[ide(Univ.string_of_univ u)])
-	 | RType _ -> ope("TYPE",[]))
-  | RHole _ -> ope("ISEVAR",[])
-  | RCast (_,c,t) -> ope("CAST",[ast_of_raw c;ast_of_raw t])
-  | RDynamic (loc,d) -> Dynamic (loc,d)
-	
-and ast_of_eqn (_,ids,pl,c) =
-  ope("EQN", (ast_of_raw c)::(List.map ast_of_cases_pattern pl))
-
-and ast_of_rawopt = function
-  | None -> (string "SYNTH")
-  | Some p -> ast_of_raw p
-
-and factorize_binder n oper na aty c =
-  let (p,body) = match decompose_binder c with
-    | Some (oper',na',ty',c')
-	when (oper = oper') & (aty = ast_of_raw ty')
-	  & not (ast_dependent na aty) (* To avoid na in ty' escapes scope *)
-	  & not (na' = Anonymous & oper = BProd)
-	  -> factorize_binder (n+1) oper na' aty c'
-    | _ -> (n,ast_of_raw c)
-  in
-  (p,slam(idopt_of_name na, body))
-
-and factorize_local_binder = function
-    [] -> []
-  | (na,Some bd,ty)::l ->
-      ([na],true,ast_of_raw bd) :: factorize_local_binder l
-  | (na,None,ty)::l ->
-      let ty = ast_of_raw ty in
-      (match factorize_local_binder l with
-          (lna,false,ty') :: l when ty=ty' ->
-            (na::lna,false,ty') :: l
-        | l -> ([na],false,ty) :: l)
-
-
-let ast_of_rawconstr = ast_of_raw
-
-(******************************************************************)
-(* Main translation function from constr -> ast *)
-       
-let ast_of_constr at_top env t =
-  let t' =
-    if !print_casts then t
-    else Reductionops.local_strong strip_outer_cast t in
-  let avoid = if at_top then ids_of_context env else [] in
-  ast_of_raw 
-    (Detyping.detype (at_top,env) avoid (names_of_rel_context env) t')
-
-let ast_of_constant env sp =
-  let a = ast_of_constant_ref sp in
-  a
-
-let ast_of_existential env (ev,ids) =
-  let a = ast_of_existential_ref ev in
-  if !print_arguments or !print_evar_arguments then
-    ope("INSTANCE",a::(array_map_to_list (ast_of_constr false env) ids))
-  else a
-
-let ast_of_constructor env cstr_sp =
-  let a = ast_of_constructor_ref cstr_sp in
-  a
-
-let ast_of_inductive env ind_sp =
-  let a = ast_of_inductive_ref ind_sp in
-  a
-
-let decompose_binder_pattern = function
-  | PProd(na,ty,c) -> Some (BProd,na,ty,c)
-  | PLambda(na,ty,c) -> Some (BLambda,na,ty,c)
-  | PLetIn(na,b,c) -> Some (BLetIn,na,b,c)
-  | _ -> None
-
-let rec ast_of_pattern tenv env = function
-  | PRef ref -> ast_of_ref ref
-
-  | PVar id -> ast_of_ident id
-
-  | PEvar (n,_) -> ast_of_existential_ref n
-
-  | PRel n ->
-      (try match lookup_name_of_rel n env with
-	 | Name id   -> ast_of_ident id
-	 | Anonymous ->
-	     anomaly "ast_of_pattern: index to an anonymous variable"
-       with Not_found ->
-	 nvar (id_of_string ("[REL "^(string_of_int n)^"]")))
-
-  | PApp (f,args) ->
-      let (f,args) = 
-	skip_coercion (function PRef r -> Some r | _ -> None)
-	  (f,Array.to_list args) in
-      let astf = ast_of_pattern tenv env f in
-      let astargs = List.map (ast_of_pattern tenv env) args in
-      (match f with 
-	 | PRef ref -> ast_of_app (implicits_of_global ref) astf astargs
-	 | _        -> ast_of_app [] astf astargs)
-
-  | PSoApp (n,args) ->
-      ope("SOAPP",(ope ("META",[ast_of_ident n])):: 
-		  (List.map (ast_of_pattern tenv env) args))
-
-  | PLetIn (na,b,c) ->
-      let c' = ast_of_pattern tenv (add_name na env) c in
-      ope("LETIN",[ast_of_pattern tenv env b;slam(idopt_of_name na,c')])
-		
-  | PProd (Anonymous,t,c) ->
-      ope("PROD",[ast_of_pattern tenv env t;
-                  slam(None,ast_of_pattern tenv env c)])
-  | PProd (na,t,c) ->
-      let env' = add_name na env in
-      let (n,a) =
-	factorize_binder_pattern tenv env' 1 BProd na
-          (ast_of_pattern tenv env t) c in
-      (* PROD et PRODLIST doivent être distingués à cause du cas *)
-      (* non dépendant, pour isoler l'implication; peut-être un *)
-      (* constructeur ARROW serait-il plus justifié ? *) 
-      let tag = if n=1 then "PROD" else "PRODLIST" in
-      ope(tag,[ast_of_pattern tenv env t;a])
-  | PLambda (na,t,c) ->
-      let env' = add_name na env in
-      let (n,a) =
-	factorize_binder_pattern tenv env' 1 BLambda na
-          (ast_of_pattern tenv env t) c in
-      (* LAMBDA et LAMBDALIST se comportent pareil *)
-      let tag = if n=1 then "LAMBDA" else "LAMBDALIST" in
-      ope(tag,[ast_of_pattern tenv env t;a])
-
-  | PCase (st,typopt,tm,bv) ->
-      warning "Old Case syntax";
-      ope("MUTCASE",(ast_of_patopt tenv env typopt)
-	    ::(ast_of_pattern tenv env tm)
-	    ::(Array.to_list (Array.map (ast_of_pattern tenv env) bv)))
-
-  | PSort s ->
-      (match s with
-	 | RProp Null -> ope("PROP",[])
-	 | RProp Pos -> ope("SET",[])
-	 | RType _ -> ope("TYPE",[]))
-
-  | PMeta (Some n) -> ope("META",[ast_of_ident n])
-  | PMeta None -> ope("ISEVAR",[])
-  | PFix f -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkFix f))
-  | PCoFix c -> ast_of_raw (Detyping.detype (false,tenv) [] env (mkCoFix c))
-	
-and ast_of_patopt tenv env = function
-  | None -> (string "SYNTH")
-  | Some p -> ast_of_pattern tenv env p
-
-and factorize_binder_pattern tenv env n oper na aty c =
-  let (p,body) = match decompose_binder_pattern c with
-    | Some (oper',na',ty',c')
-	when (oper = oper') & (aty = ast_of_pattern tenv env ty')
-	  & not (na' = Anonymous & oper = BProd)
-	  ->
-	factorize_binder_pattern tenv (add_name na' env) (n+1) oper na' aty c'
-    | _ -> (n,ast_of_pattern tenv env c)
-  in
-  (p,slam(idopt_of_name na, body))
diff --git a/parsing/termast.mli b/parsing/termast.mli
deleted file mode 100644
index c66e8f0f..00000000
--- a/parsing/termast.mli
+++ /dev/null
@@ -1,55 +0,0 @@
-(************************************************************************)
-(*  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: termast.mli,v 1.24.2.1 2004/07/16 19:30:42 herbelin Exp $ i*)
-
-(*i*)
-open Names
-open Term
-open Termops
-open Sign
-open Environ
-open Libnames
-open Nametab
-open Rawterm
-open Pattern
-(*i*)
-
-(* Translation of pattern, cases pattern, rawterm and term into syntax
-   trees for printing *)
-
-val ast_of_cases_pattern : cases_pattern -> Coqast.t
-val ast_of_rawconstr : rawconstr -> Coqast.t
-val ast_of_pattern : env -> names_context -> constr_pattern -> Coqast.t
-
-(* If [b=true] in [ast_of_constr b env c] then the variables in the first 
-   level of quantification clashing with the variables in [env] are renamed *)
-
-val ast_of_constr : bool -> env -> constr -> Coqast.t
-
-val ast_of_constant     : env -> constant -> Coqast.t
-val ast_of_existential  : env -> existential -> Coqast.t
-val ast_of_constructor  : env -> constructor -> Coqast.t
-val ast_of_inductive    : env -> inductive -> Coqast.t
-val ast_of_ref          : global_reference -> Coqast.t
-val ast_of_qualid       : qualid -> Coqast.t
-
-(*i Now in constrextern.mli
-val print_implicits : bool ref
-val print_casts : bool ref
-val print_arguments : bool ref
-val print_evar_arguments : bool ref
-val print_coercions : bool ref
-val print_universes : bool ref
-
-val with_casts : ('a -> 'b) -> 'a -> 'b
-val with_implicits : ('a -> 'b) -> 'a -> 'b
-val with_arguments : ('a -> 'b) -> 'a -> 'b
-val with_coercions : ('a -> 'b) -> 'a -> 'b
-val with_universes : ('a -> 'b) -> 'a -> 'b
-i*)
diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4
index bdc1ea66..7cf542fe 100644
--- a/parsing/vernacextend.ml4
+++ b/parsing/vernacextend.ml4
@@ -6,12 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernacextend.ml4,v 1.5.2.2 2004/07/16 19:30:42 herbelin Exp $ *)
+(* $Id: vernacextend.ml4 9265 2006-10-24 08:35:38Z herbelin $ *)
 
 open Genarg
 open Q_util
 open Q_coqast
-open Ast
 open Argextend
 
 let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
@@ -81,11 +80,8 @@ let mlexpr_of_grammar_production = function
 
 let mlexpr_of_clause =
   mlexpr_of_list
-    (fun (a,b,c) ->
-      (mlexpr_of_pair
-	mlexpr_of_string
-	(mlexpr_of_list mlexpr_of_grammar_production)
-	(a,b)))
+    (fun (a,b,c) -> 
+      mlexpr_of_list mlexpr_of_grammar_production (VernacTerm a::b))
 
 let declare_command loc s cl =
   let gl = mlexpr_of_clause cl in
@@ -99,40 +95,6 @@ let declare_command loc s cl =
     end
   >>
 
-open Vernacexpr
-open Pcoq
-
-let rec interp_entry_name loc s =
-  let l = String.length s in
-  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in
-    List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
-  else if l > 5 & String.sub s (l-5) 5 = "_list" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in
-    List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
-  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
-    let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in
-    OptArgType t, <:expr< Gramext.Sopt $g$ >>
-  else
-    let t, se = 
-      match Pcoq.entry_type (Pcoq.get_univ "prim") s with
-	| Some _ as x -> x, <:expr< Prim. $lid:s$ >>
-	| None ->
-      match Pcoq.entry_type (Pcoq.get_univ "constr") s with
-	| Some _ as x -> x, <:expr< Constr. $lid:s$ >>
-	| None -> 
-      match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
-	| Some _ as x -> x, <:expr< Tactic. $lid:s$ >>
-	| None -> None, <:expr< $lid:s$ >> in
-    let t =
-      match t with
-	| Some t -> t
-	| None ->
-(*	    Pp.warning_with Pp_control.err_ft
-            ("Unknown primitive grammar entry: "^s);*)
-	    ExtraArgType s
-    in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
-
 open Pcaml
 
 EXTEND
@@ -152,7 +114,7 @@ EXTEND
   ;
   args:
     [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name loc e in
+        let t, g = Q_util.interp_entry_name loc e "" in
         VernacNonTerm (loc, t, g, Some s)
       | s = STRING ->
         VernacTerm s
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 4aff508f..58dda021 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cases.ml,v 1.111.2.5 2005/04/29 16:31:03 herbelin Exp $ *)
+(* $Id: cases.ml 9215 2006-10-05 15:40:31Z herbelin $ *)
 
 open Util
 open Names
@@ -33,6 +33,7 @@ type pattern_matching_error =
   | BadPattern of constructor * constr
   | BadConstructor of constructor * inductive
   | WrongNumargConstructor of constructor * int
+  | WrongNumargInductive of inductive * int
   | WrongPredicateArity of constr * constr * constr
   | NeedsInversion of constr * constr
   | UnusedClause of cases_pattern list
@@ -50,8 +51,11 @@ let error_bad_pattern_loc loc cstr ind =
 let error_bad_constructor_loc loc cstr ind =
   raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind))
 
-let error_wrong_numarg_constructor_loc loc c n =
-  raise_pattern_matching_error (loc, Global.env(), WrongNumargConstructor (c,n))
+let error_wrong_numarg_constructor_loc loc env c n =
+  raise_pattern_matching_error (loc, env, WrongNumargConstructor(c,n))
+
+let error_wrong_numarg_inductive_loc loc env c n =
+  raise_pattern_matching_error (loc, env, WrongNumargInductive(c,n))
 
 let error_wrong_predicate_arity_loc loc env c n1 n2 =
   raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2))
@@ -59,107 +63,15 @@ let error_wrong_predicate_arity_loc loc env c n1 n2 =
 let error_needs_inversion env x t =
   raise (PatternMatchingError (env, NeedsInversion (x,t)))
 
-(*********************************************************************)
-(* A) Typing old cases                                               *)
-(* This was previously in Indrec but creates existential holes       *)
-
-let mkExistential isevars env loc = new_isevar isevars env loc (new_Type ())
-
-let norec_branch_scheme env isevars cstr =
-  let rec crec env = function
-    | d::rea -> mkProd_or_LetIn d (crec (push_rel d env) rea)
-    | [] -> mkExistential isevars env (dummy_loc, InternalHole) in 
-  crec env (List.rev cstr.cs_args)
-
-let rec_branch_scheme env isevars (sp,j) recargs cstr =
-  let rec crec env (args,recargs) = 
-    match args, recargs with 
-      | (name,None,c as d)::rea,(ra::reca) -> 
-	  let d =
- 	    match dest_recarg ra with 
-	      | Mrec k when k=j ->
-		  let t = mkExistential isevars env (dummy_loc, InternalHole)
-		  in
-		  mkArrow t
-		    (crec (push_rel (Anonymous,None,t) env)
-		       (List.rev (lift_rel_context 1 (List.rev rea)),reca))
-              | _ -> crec (push_rel d env) (rea,reca) in
-          mkProd (name,  c, d)
-
-      | (name,Some b,c as d)::rea, reca -> 
-	  mkLetIn (name,b, c,crec (push_rel d env) (rea,reca))
-      | [],[] -> mkExistential isevars env (dummy_loc, InternalHole)
-      | _ -> anomaly "rec_branch_scheme"
-  in 
-  crec env (List.rev cstr.cs_args,recargs) 
-    
-let branch_scheme env isevars isrec indf =
-  let (ind,params) = dest_ind_family indf in
-  let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  let cstrs = get_constructors env indf in 
-  if isrec then
-    array_map2
-      (rec_branch_scheme env isevars ind)
-      (dest_subterms mip.mind_recargs) cstrs
-  else 
-    Array.map (norec_branch_scheme env isevars) cstrs
-
-(******************************************************)
-(* B) Building ML like case expressions without types *)
-
-let concl_n env sigma = 
-  let rec decrec m c = if m = 0 then (nf_evar sigma c) else 
-    match kind_of_term (whd_betadeltaiota env sigma c) with
-      | Prod (n,_,c_0) -> decrec (m-1) c_0
-      | _                -> failwith "Typing.concl_n"
-  in 
-  decrec
-
-let count_rec_arg j = 
-  let rec crec i = function 
-    | [] -> i 
-    | ra::l ->
-        (match dest_recarg ra with
-            Mrec k -> crec (if k=j then (i+1) else i) l
-          | _ -> crec i l)
-  in 
-  crec 0
-
-(* if arity of mispec is (p_bar:P_bar)(a_bar:A_bar)s where p_bar are the
- * K parameters. Then then build_notdep builds the predicate
- * [a_bar:A'_bar](lift k pred) 
- * where A'_bar = A_bar[p_bar <- globargs] *)
-
-let build_dep_pred env sigma indf pred =
-  let arsign,_ = get_arity env indf in
-  let psign = (Anonymous,None,build_dependent_inductive env indf)::arsign in
-  let nar = List.length psign in
-  it_mkLambda_or_LetIn_name env (lift nar pred) psign
-
-type ml_case_error =
-  | MlCaseAbsurd
-  | MlCaseDependent
-
-exception NotInferable of ml_case_error
-
-
-let pred_case_ml env sigma isrec (IndType (indf,realargs)) (i,ft) =
-  let pred =
-    let (ind,params) = dest_ind_family indf in
-    let (mib,mip) = Inductive.lookup_mind_specif env ind in
-    let recargs = dest_subterms mip.mind_recargs in
-    if Array.length recargs = 0 then raise (NotInferable MlCaseAbsurd);
-    let recargi = recargs.(i) in
-    let j = snd ind in (* index of inductive *)
-    let nbrec = if isrec then count_rec_arg j recargi else 0 in
-    let nb_arg = List.length (recargs.(i)) + nbrec in
-    let pred = Evarutil.refresh_universes (concl_n env sigma nb_arg ft) in
-    if noccur_between 1 nb_arg pred then 
-      lift (-nb_arg) pred
-    else 
-      raise (NotInferable MlCaseDependent)
-  in
-  build_dep_pred env sigma indf pred  
+module type S = sig
+  val compile_cases :
+    loc ->
+    (type_constraint -> env -> rawconstr -> unsafe_judgment) *
+      Evd.evar_defs ref ->
+    type_constraint -> 
+    env -> rawconstr option * tomatch_tuple * cases_clauses ->
+    unsafe_judgment
+end
 
 (************************************************************************)
 (*            Pattern-matching compilation (Cases)                      *)
@@ -223,14 +135,9 @@ type 'a lifted = int * 'a
 
 let insert_lifted a = (0,a);;
 
-(* The pattern variables for [it] are in [user_ids] and the variables
-   to avoid are in [other_ids]. 
-*)
-
 type rhs =
     { rhs_env    : env;
-      other_ids  : identifier list;
-      user_ids   : identifier list;
+      avoid_ids  : identifier list;
       rhs_lift   : int;
       it         : rawconstr }
 
@@ -259,8 +166,8 @@ type tomatch_stack = tomatch_status list
 
 (* The type [predicate_signature] types the terms to match and the rhs:
 
-   - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]), 
-     if dep<>Anonymous, the term is dependent, let n=|names|, if 
+   - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
+     if dep<>Anonymous, the term is dependent, let n=|names|, if
      n<>0 then the type of the pushed term is necessarily an
      inductive with n real arguments. Otherwise, it may be
      non inductive, or inductive without real arguments, or inductive
@@ -376,7 +283,7 @@ let push_history_pattern n current cont =
 *)
 type pattern_matching_problem =
     { env      : env;
-      isevars  : evar_defs;
+      isevars  : Evd.evar_defs ref;
       pred     : predicate_signature option;
       tomatch  : tomatch_stack;
       history  : pattern_continuation;
@@ -388,81 +295,128 @@ type pattern_matching_problem =
  * A few functions to infer the inductive type from the patterns instead of *
  * checking that the patterns correspond to the ind. type of the            *
  * destructurated object. Allows type inference of examples like            *
- *  [n]Cases n of O => true | _ => false end                                *
+ *  match n with O => true | _ => false end                                 *
+ *  match x in I with C => true | _ => false end                            *
  *--------------------------------------------------------------------------*)
 
 (* Computing the inductive type from the matrix of patterns *)
 
+(* We use the "in I" clause to coerce the terms to match and otherwise
+   use the constructor to know in which type is the matching problem
+
+   Note that insertion of coercions inside nested patterns is done
+   each time the matrix is expanded *)
+
 let rec find_row_ind = function
     [] -> None
   | PatVar _ :: l -> find_row_ind l
   | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
 
-exception NotCoercible
-
-let inh_coerce_to_ind isevars env tmloc ty tyi =
-  let (mib,mip) = Inductive.lookup_mind_specif env tyi in
-  let (ntys,_) = splay_prod env (evars_of isevars) mip.mind_nf_arity in
+let inductive_template isevars env tmloc ind =
+  let arsign = get_full_arity_sign env ind in
   let hole_source = match tmloc with 
-    | Some loc -> fun i -> (loc, TomatchTypeParameter (tyi,i))
-    | None -> fun _ -> (dummy_loc, InternalHole) in
-   let (evarl,_) =
+    | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
+    | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
+   let (_,evarl,_) =
     List.fold_right
-      (fun (na,ty) (evl,n) ->
-	(new_isevar isevars env (hole_source n) (substl evl ty))::evl,n+1)
-      ntys ([],1) in
-  let expected_typ = applist (mkInd tyi,evarl) in
+      (fun (na,b,ty) (subst,evarl,n) ->
+	match b with
+        | None ->
+	    let ty' = substl subst ty in
+	    let e = e_new_evar isevars env ~src:(hole_source n) ty' in
+	    (e::subst,e::evarl,n+1) 
+	| Some b ->
+	    (b::subst,evarl,n+1))
+      arsign ([],[],1) in
+   applist (mkInd ind,List.rev evarl)
+
+let inh_coerce_to_ind isevars env ty tyi =
+  let expected_typ = inductive_template isevars env None tyi in
      (* devrait être indifférent d'exiger leq ou pas puisque pour 
         un inductif cela doit être égal *)
-  if the_conv_x_leq env isevars expected_typ ty then ty
-  else raise NotCoercible
-
-(* We do the unification for all the rows that contain
- * constructor patterns. This is what we do at the higher level of patterns.
- * For nested patterns, we do this unif when we ``expand'' the matrix, and we
- * use the function above.
- *)
-
-let unify_tomatch_with_patterns isevars env tmloc typ = function
-  | Some (cloc,(cstr,_ as c)) ->
-      (let tyi = inductive_of_constructor c in
-       try 
-	 let indtyp = inh_coerce_to_ind isevars env tmloc typ tyi in
-	 IsInd (typ,find_rectype env (evars_of isevars) typ)
-       with NotCoercible ->
-	 (* 2 cases : Not the right inductive or not an inductive at all *)
-	 try
-	   IsInd (typ,find_rectype env (evars_of isevars) typ)
-             (* will try to coerce later in check_and_adjust_constructor.. *)
-	 with Not_found ->
-	   NotInd (None,typ))
-	     (* error will be detected in check_all_variables *)
-  | None -> 
-      try IsInd (typ,find_rectype env (evars_of isevars) typ)
-      with Not_found -> NotInd (None,typ)
-
-let coerce_row typing_fun isevars env cstropt tomatch =
-  let j = typing_fun empty_tycon env tomatch in
-  let typ = body_of_type j.uj_type in
-  let loc = loc_of_rawconstr tomatch in
-  let t = unify_tomatch_with_patterns isevars env (Some loc) typ cstropt in
+  let _ = e_cumul env isevars expected_typ ty in ()
+
+let unify_tomatch_with_patterns isevars env loc typ pats =
+  match find_row_ind pats with
+    | None -> NotInd (None,typ)
+    | Some (_,(ind,_)) ->
+	inh_coerce_to_ind isevars env typ ind;
+	try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+	with Not_found -> NotInd (None,typ)
+
+let find_tomatch_tycon isevars env loc = function
+  (* Try if some 'in I ...' is present and can be used as a constraint *)
+  | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind)
+  | None -> empty_tycon
+
+let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
+  let loc = Some (loc_of_rawconstr tomatch) in
+  let tycon = find_tomatch_tycon isevars env loc indopt in
+  let j = typing_fun tycon env tomatch in
+  let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in
+  let t =
+    try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+    with Not_found ->
+      unify_tomatch_with_patterns isevars env loc typ pats in
   (j.uj_val,t)
 
 let coerce_to_indtype typing_fun isevars env matx tomatchl =
   let pats = List.map (fun r ->  r.patterns) matx in
   let matx' = match matrix_transpose pats with
-    | [] -> List.map (fun _ -> None) tomatchl (* no patterns at all *)
-    | m -> List.map find_row_ind m in
+    | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
+    | m -> m in
   List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
 
 (************************************************************************)
 (* Utils *)
 
+let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
+  e_new_evar isevars env ~src:src (new_Type ())
+
+let evd_comb2 f isevars x y =
+  let (evd',y) = f !isevars x y in
+  isevars := evd';
+  y
+
+
+module Cases_F(Coercion : Coercion.S) : S = struct
+
+let adjust_tomatch_to_pattern pb ((current,typ),deps) =
+  (* Ideally, we could find a common inductive type to which both the
+     term to match and the patterns coerce *)
+  (* In practice, we coerce the term to match if it is not already an
+     inductive type and it is not dependent; moreover, we use only 
+     the first pattern type and forget about the others *)
+  let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
+  let typ =
+    try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ)
+    with Not_found -> NotInd (None,typ) in
+  let tomatch = ((current,typ),deps) in
+  match typ with
+  | NotInd (None,typ) ->
+      let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
+      (match find_row_ind tm1 with
+	| None -> tomatch
+	| Some (_,(ind,_)) ->
+	    let indt = inductive_template pb.isevars pb.env None ind in
+	    let current =
+	      if deps = [] & isEvar typ then
+	      (* Don't insert coercions if dependent; only solve evars *)
+		let _ = e_cumul pb.env pb.isevars indt typ in
+		current
+	      else
+		(evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
+		  pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
+	    let sigma = Evd.evars_of !(pb.isevars) in
+	    let typ = IsInd (indt,find_rectype pb.env sigma indt) in
+	    ((current,typ),deps))
+  | _ -> tomatch
+
    (* extract some ind from [t], possibly coercing from constructors in [tm] *)
 let to_mutind env isevars tm c t =
-  match c with
-    | Some body -> NotInd (c,t)
-    | None -> unify_tomatch_with_patterns isevars env None t (find_row_ind tm)
+(*  match c with
+    | Some body -> *) NotInd (c,t)
+(*    | None -> unify_tomatch_with_patterns isevars env t tm*)
 
 let type_of_tomatch = function
   | IsInd (t,_) -> t
@@ -474,7 +428,7 @@ let mkDeclTomatch na = function
 
 let map_tomatch_type f = function
   | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind)
-  | NotInd (c,t) -> NotInd (option_app f c, f t)
+  | NotInd (c,t) -> NotInd (option_map f c, f t)
 
 let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
 let lift_tomatch_type n = liftn_tomatch_type n 1
@@ -543,12 +497,12 @@ let rec adjust_local_defs loc = function
   | [], [] -> []
   | _ -> raise NotAdjustable
 
-let check_and_adjust_constructor ind cstrs = function 
+let check_and_adjust_constructor env ind cstrs = function 
   | PatVar _ as pat -> pat
   | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
       (* Check it is constructor of the right type *)
       let ind' = inductive_of_constructor cstr in
-      if ind' = ind then
+      if Closure.mind_equiv env ind' ind then
 	(* Check the constructor has the right number of args *)
 	let ci = cstrs.(i-1) in
 	let nb_args_constr = ci.cs_nargs in
@@ -558,7 +512,8 @@ let check_and_adjust_constructor ind cstrs = function
 	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
 	    in PatCstr (loc, cstr, args', alias)
 	  with NotAdjustable ->
-	    error_wrong_numarg_constructor_loc loc cstr nb_args_constr
+	    error_wrong_numarg_constructor_loc loc (Global.env())
+	      cstr nb_args_constr
       else
 	(* Try to insert a coercion *)
 	try
@@ -715,11 +670,11 @@ let lift_tomatch_stack n = liftn_tomatch_stack n 1
 (* Some heuristics to get names for variables pushed in pb environment *)
 (* Typical requirement:
 
-   [Cases y of (S (S x)) => x | x => x end] should be compiled into
-   [Cases y of O => y | (S n) => Cases n of O => y | (S x) => x end end]
+   [match y with (S (S x)) => x | x => x end] should be compiled into
+   [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
 
-   and [Cases y of (S (S n)) => n | n => n end] into 
-   [Cases y of O => y | (S n0) => Cases n0 of O => y | (S n) => n end end]
+   and [match y with (S (S n)) => n | n => n end] into 
+   [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
 
   i.e. user names should be preserved and created names should not
   interfere with user names *)
@@ -740,7 +695,7 @@ let get_names env sign eqns =
   (* Otherwise, we take names from the parameters of the constructor but
      avoiding conflicts with user ids *)
   let allvars =
-    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.other_ids) [] eqns in
+    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in
   let names4,_ =
     List.fold_left2
       (fun (l,avoid) d na ->
@@ -782,7 +737,6 @@ let build_aliases_context env sigma names allpats pats =
 	let newallpats =
 	  List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
 	let oldallpats = List.map List.tl oldallpats in
-	let u = Retyping.get_type_of env sigma deppat in
 	let decl = (na,Some deppat,t) in
 	let a = (deppat,nondeppat,d,t) in
 	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) 
@@ -833,7 +787,7 @@ let prepare_unif_pb typ cs =
   let typ' =
     if noccur_between_without_evar 1 n typ then lift (-n) typ
     else (* TODO4-1 *)
-      error "Inference of annotation not yet implemented in this case" in
+      error "Unable to infer return clause of this pattern-matching problem" in
   let args = extended_rel_list (-n) cs.cs_args in
   let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in
 
@@ -869,10 +823,10 @@ the following n+1 equations:
 
 Some hints:
 
-- Clearly, if xij occurs in Ti, then, a "Cases z of (Ci xi1..xipi) => ..."
+- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
   should be inserted somewhere in Ti.
 
-- If T is undefined, an easy solution is to insert a "Cases z of (Ci
+- If T is undefined, an easy solution is to insert a "match z with (Ci
   xi1..xipi) => ..." in front of each Ti
 
 - Otherwise, T1..Tn and T must be step by step unified, if some of them
@@ -902,7 +856,7 @@ let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
 
 let reloc_operator (k,n) = function OpRel p when p > k -> 
 let rec unify_clauses k pv =
-  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (evars_of isevars)) p) pv in
+  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in
   let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
   if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
   then
@@ -918,28 +872,30 @@ let abstract_conclusion typ cs =
   lam_it p sign
 
 let infer_predicate loc env isevars typs cstrs indf =
-  let (mis,_) = dest_ind_family indf in
   (* Il faudra substituer les isevars a un certain moment *)
   if Array.length cstrs = 0 then (* "TODO4-3" *)
     error "Inference of annotation for empty inductive types not implemented"
   else
     (* Empiric normalization: p may depend in a irrelevant way on args of the*)
-    (* cstr as in [c:{_:Alpha & Beta}] Cases c of (existS a b)=>(a,b) end *)
+    (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
     let typs =
-      Array.map (local_strong (whd_betaevar empty_env (evars_of isevars))) typs
+      Array.map (local_strong (whd_betaevar empty_env (Evd.evars_of !isevars))) typs
     in
     let eqns = array_map2 prepare_unif_pb typs cstrs in
     (* First strategy: no dependencies at all *)
-(*    let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in*)
+(*
+    let (mis,_) = dest_ind_family indf in
+    let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
+*)
     let (sign,_) = get_arity env indf in
     let mtyp =
       if array_exists is_Type typs then
 	(* Heuristic to avoid comparison between non-variables algebric univs*)
 	new_Type ()
       else
-	mkExistential isevars env (loc, CasesType)
+	mkExistential env ~src:(loc, Evd.CasesType) isevars
     in
-    if array_for_all (fun (_,_,typ) -> the_conv_x_leq env isevars typ mtyp) eqns
+    if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
     then
       (* Non dependent case -> turn it into a (dummy) dependent one *)
       let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
@@ -980,7 +936,7 @@ let rec map_predicate f k = function
 let rec noccurn_predicate k = function
   | PrCcl ccl -> noccurn k ccl
   | PrProd pred -> noccurn_predicate (k+1) pred
-  | PrLetIn ((names,dep as tm),pred) ->
+  | PrLetIn ((names,dep),pred) ->
       let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
       noccurn_predicate (k+k') pred
 
@@ -1066,8 +1022,8 @@ let abstract_predicate env sigma indf cur tms = function
          args or not, we lift it to make room for [sign] *)
       (* Even if not intrinsically dep, we move the predicate into a dep one *)
       let sign,k =
-        if names = [] & n <> 1 then 
-          (* Real args were not considered *) 
+        if names = [] & n <> 1 then
+          (* Real args were not considered *)
           (if dep<>Anonymous then
             ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1)
           else
@@ -1106,7 +1062,7 @@ let expand_arg n alreadydep (na,t) deps (k,pred) =
 (*****************************************************************************)
 (* pred = [X:=realargs;x:=c]P types the following problem:                   *)
 (*                                                                           *)
-(*  Gamma |- Cases Pushed(c:I(realargs)) rest of...end: pred                 *)
+(*  Gamma |- match Pushed(c:I(realargs)) rest with...end: pred               *)
 (*                                                                           *)
 (* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi)      *)
 (* is considered. Assume each Ti is some Ii(argsi).                          *)
@@ -1114,7 +1070,7 @@ let expand_arg n alreadydep (na,t) deps (k,pred) =
 (*                                                                           *)
 (* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
 (*                                                                           *)
-(* s.t Gamma,x1'..xn' |- Cases Pushed(x1')..Pushed(xn') rest of...end: pred' *)
+(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
 (*                                                                           *)
 (*****************************************************************************)
 let specialize_predicate tomatchs deps cs = function
@@ -1141,7 +1097,7 @@ let find_predicate loc env isevars p typs cstrs current
   (IndType (indf,realargs)) tms =
   let (dep,pred) =
     match p with
-      | Some p -> abstract_predicate env (evars_of isevars) indf current tms p
+      | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p
       | None -> infer_predicate loc env isevars typs cstrs indf in
   let typ = whd_beta (applist (pred, realargs)) in
   if dep then
@@ -1173,7 +1129,7 @@ let first_clause_irrefutable env = function
   | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
   | _ -> false
 
-let group_equations pb mind current cstrs mat =
+let group_equations pb ind current cstrs mat =
   let mat =
     if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
   let brs = Array.create (Array.length cstrs) [] in
@@ -1183,7 +1139,7 @@ let group_equations pb mind current cstrs mat =
       (fun eqn () ->
 	 let rest = remove_current_pattern eqn in
 	 let pat = current_pattern eqn in
-	 match check_and_adjust_constructor mind cstrs pat with 
+	 match check_and_adjust_constructor pb.env ind cstrs pat with 
 	   | PatVar (_,name) -> 
 	       (* This is a default clause that we expand *)
 	       for i=1 to Array.length cstrs do
@@ -1191,7 +1147,7 @@ let group_equations pb mind current cstrs mat =
 		 let rest = {rest with tag = lower_pattern_status rest.tag} in
 		 brs.(i-1) <- (args, rest) :: brs.(i-1)
 	       done
-	   | PatCstr (loc,((_,i) as cstr),args,_) as pat ->
+	   | PatCstr (loc,((_,i)),args,_) ->
 	       (* This is a regular clause *)
 	       only_default := false;
 	       brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
@@ -1210,7 +1166,7 @@ let rec generalize_problem pb current = function
       let tomatch = regeneralize_index_tomatch (i+1) tomatch in
       { pb with
 	  tomatch = Abstract d :: tomatch;
-          pred = option_app (generalize_predicate current i d) pb'.pred }
+          pred = option_map (generalize_predicate current i d) pb'.pred }
 
 (* No more patterns: typing the right-hand-side of equations *)
 let build_leaf pb =
@@ -1225,7 +1181,7 @@ let build_leaf pb =
 let shift_problem (current,t) pb =
   {pb with
      tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
-     pred = option_app (specialize_predicate_var (current,t)) pb.pred;
+     pred = option_map (specialize_predicate_var (current,t)) pb.pred;
      history = push_history_pattern 0 AliasLeaf pb.history;
      mat = List.map remove_current_pattern pb.mat }
 
@@ -1240,8 +1196,6 @@ let build_branch current deps pb eqns const_info =
     else 
       DepAlias
   in
-  let partialci =
-    applist (mkConstruct const_info.cs_cstr, const_info.cs_params) in
   let history = 
     push_history_pattern const_info.cs_nargs
       (AliasConstructor const_info.cs_cstr)
@@ -1297,7 +1251,7 @@ let build_branch current deps pb eqns const_info =
   { pb with
       env = push_rels sign pb.env;
       tomatch = List.rev_append currents tomatch;
-      pred = option_app (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred;
+      pred = option_map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred;
       history = history;
       mat = List.map (push_rels_eqn_with_names sign) submat }
 
@@ -1324,10 +1278,8 @@ let rec compile pb =
     | (Abstract d)::rest -> compile_generalization pb d rest
     | [] -> build_leaf pb
 
-and match_current pb ((current,typ as ct),deps) =
-  let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
-  let (_,c,t) = mkDeclTomatch Anonymous typ in
-  let typ = to_mutind pb.env pb.isevars tm1 c t in
+and match_current pb tomatch =
+  let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
   match typ with
     | NotInd (_,typ) ->
 	check_all_variables typ pb.mat;
@@ -1336,10 +1288,10 @@ and match_current pb ((current,typ as ct),deps) =
 	let mind,_ = dest_ind_family indf in
 	let cstrs = get_constructors pb.env indf in
 	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
-	if (cstrs <> [||] or not (initial_history pb.history)) & onlydflt then
+	if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt  then
 	  compile (shift_problem ct pb)
 	else
-          let constraints = Array.map (solve_constraints indt) cstrs in
+          let _constraints = Array.map (solve_constraints indt) cstrs in
 
 	  (* We generalize over terms depending on current term to match *)
 	  let pb = generalize_problem pb current deps in
@@ -1371,7 +1323,7 @@ and compile_generalization pb d rest =
     { pb with
        env = push_rel d pb.env;
        tomatch = rest;
-       pred = option_app ungeneralize_predicate pb.pred;
+       pred = option_map ungeneralize_predicate pb.pred;
        mat = List.map (push_rels_eqn [d]) pb.mat } in
   let patstat,j = compile pb in
   patstat, 
@@ -1381,7 +1333,7 @@ and compile_generalization pb d rest =
 and compile_alias pb (deppat,nondeppat,d,t) rest =
   let history = simplify_history pb.history in
   let sign, newenv, mat =
-    insert_aliases pb.env (evars_of pb.isevars) (deppat,nondeppat,d,t) pb.mat in
+    insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
   let n = List.length sign in
 
   (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
@@ -1397,7 +1349,7 @@ and compile_alias pb (deppat,nondeppat,d,t) rest =
     {pb with
        env = newenv;
        tomatch = tomatch;
-       pred = option_app (lift_predicate n) pb.pred;
+       pred = option_map (lift_predicate n) pb.pred;
        history = history;
        mat = mat } in
   let patstat,j = compile pb in
@@ -1410,78 +1362,16 @@ substituer après par les initiaux *)
 (**************************************************************************)
 (* Preparation of the pattern-matching problem                            *)
 
-(* Qu'est-ce qui faut pas faire pour traiter les alias ... *)
-
-(* On ne veut pas ajouter de primitive à Environ et le problème, c'est
-   donc de faire un renommage en se contraignant à parcourir l'env
-   dans le sens croissant. Ici, subst renomme des variables repérées
-   par leur numéro et seen_ids collecte celles dont on sait que les
-   variables de subst annule le scope *)
-let rename_env subst env =
-  let n = ref (rel_context_length (rel_context env)) in
-  let seen_ids = ref [] in
-  process_rel_context
-    (fun (na,c,t as d) env ->
-       let d =
-	 try
-	   let id = List.assoc !n subst in
-	   seen_ids := id :: !seen_ids;
-	   (Name id,c,t)
-	 with Not_found ->
-	   match na with
-	     | Name id when List.mem id !seen_ids -> (Anonymous,c,t)
-	     | _ -> d in
-       decr n;
-       push_rel d env) env
-
-let is_dependent_indtype = function
-  | NotInd _ -> false
-  | IsInd (_, IndType(_,realargs)) -> List.length realargs <> 0
-
-let prepare_initial_alias_eqn isdep tomatchl eqn =
-  let (subst, pats) = 
-  List.fold_right2
-    (fun pat (tm,tmtyp) (subst, stripped_pats) ->
-       match alias_of_pat pat with
-	 | Anonymous -> (subst, pat::stripped_pats)
-	 | Name idpat as na ->
-	     match kind_of_term tm with
-	       | Rel n when not (is_dependent_indtype tmtyp) & not isdep
-		   -> (n, idpat)::subst, (unalias_pat pat::stripped_pats)
-	       | _ -> (subst, pat::stripped_pats))
-    eqn.patterns tomatchl ([], []) in
-  let env = rename_env subst eqn.rhs.rhs_env in
-  { eqn with patterns = pats; rhs = { eqn.rhs with rhs_env = env } }
-
-let prepare_initial_aliases isdep tomatchl mat = mat
-(*  List.map (prepare_initial_alias_eqn isdep tomatchl) mat*)
-
-(*
-let prepare_initial_alias lpat tomatchl rhs =
-  List.fold_right2
-    (fun pat tm (stripped_pats, rhs) ->
-       match alias_of_pat pat with
-	 | Anonymous -> (pat::stripped_pats, rhs)
-	 | Name _ as na ->
-	     match tm with
-	       | RVar _ -> 
-		   (unalias_pat pat::stripped_pats, 
-		    RLetIn (dummy_loc, na, tm, rhs))
-	       | _ -> (pat::stripped_pats, rhs))
-    lpat tomatchl ([], rhs)
-*)
 (* builds the matrix of equations testing that each eqn has n patterns
  * and linearizing the _ patterns.
  * Syntactic correctness has already been done in astterm *)
 let matx_of_eqns env tomatchl eqns =
   let build_eqn (loc,ids,lpat,rhs) =
-(*    let initial_lpat,initial_rhs = prepare_initial_alias lpat tomatchl rhs in*)
     let initial_lpat,initial_rhs = lpat,rhs in
     let initial_rhs = rhs in
     let rhs =
       { rhs_env = env;
-	other_ids = ids@(ids_of_named_context (named_context env));
-	user_ids = ids;
+	avoid_ids = ids@(ids_of_named_context (named_context env));
 	rhs_lift = 0;
 	it = initial_rhs } in
     { dependencies = [];
@@ -1531,7 +1421,7 @@ let extract_predicate_conclusion isdep tomatchl pred =
     if n=0 then (l,p) else
     match kind_of_term p with
       | Lambda (na,_,c) -> decomp_lam_force (n-1) (na::l) c
-      | _ -> (* eta-expansion *) 
+      | _ -> (* eta-expansion *)
           let na = Name (id_of_string "x") in
           decomp_lam_force (n-1) (na::l) (applist (lift 1 p, [mkRel 1])) in
   let rec buildrec allnames p = function
@@ -1543,7 +1433,7 @@ let extract_predicate_conclusion isdep tomatchl pred =
                 (* adjust to a sign containing the NotInd's *)
                 if isdep then lift 1 p else p in
               let names = if isdep then [Anonymous] else [] in
-              buildrec (names::allnames) p ltm 
+              buildrec (names::allnames) p ltm
 	  | Some n ->
               let n = if isdep then n+1 else n in
               let names,p = decomp_lam_force n [] p in
@@ -1589,31 +1479,33 @@ let set_arity_signature dep n arsign tomatchl pred x =
   in
   decomp_block [] pred (tomatchl,arsign)
 
-let prepare_predicate_from_tycon loc dep env isevars tomatchs c =
-  let cook (n, l, signs) = function
+let prepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
+  let cook (n, l, env, signs) = function
     | c,IsInd (_,IndType(indf,realargs)) ->
 	let indf' = lift_inductive_family n indf in
-	let arsign = make_arity_signature env dep indf' in
+	let sign = make_arity_signature env dep indf' in
 	let p = List.length realargs in
 	if dep then
-	  (n + p + 1, c::(List.rev realargs)@l, arsign::signs)
+	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
 	else
-	  (n + p, (List.rev realargs)@l, arsign::signs)
+	  (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
     | c,NotInd _ ->
-	(n, l, []::signs) in
-  let n, allargs, signs = List.fold_left cook (0, [], []) tomatchs in
-  let env = List.fold_right push_rels signs env in
+	(n, l, env, []::signs) in
+  let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
+  let names = List.rev (List.map (List.map pi1) signs) in
   let allargs =
-    List.map (fun c -> lift n (nf_betadeltaiota env (evars_of isevars) c)) allargs in
+    List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in
   let rec build_skeleton env c =
     (* Don't put into normal form, it has effects on the synthesis of evars *)
  (* let c = whd_betadeltaiota env (evars_of isevars) c in *)
     (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
     if isEvar c or List.exists (eq_constr c) allargs then
-      mkExistential isevars env (loc, CasesType)
+      e_new_evar isevars env  ~src:(loc, Evd.CasesType)
+        (Retyping.get_type_of env (Evd.evars_of !isevars) c)
     else
-      map_constr_with_full_binders push_rel build_skeleton env c in
- List.rev (List.map (List.map pi1) signs), build_skeleton env (lift n c)
+      map_constr_with_full_binders push_rel build_skeleton env c 
+  in
+    names, build_skeleton env (lift n c)
   
 (* Here, [pred] is assumed to be in the context built from all *)
 (* realargs and terms to match *)
@@ -1629,7 +1521,7 @@ let build_initial_predicate isdep allnames pred =
             if dependent (mkRel (nar-n')) pred then pred, 1, 1
             else liftn (-1) (nar-n') pred, 0, 1
           else pred, 0, 0 in
-        let na = 
+        let na =
           if p=1 then
             let na = List.hd names in
             if na = Anonymous then
@@ -1637,16 +1529,16 @@ let build_initial_predicate isdep allnames pred =
               Name (id_of_string "x") (*Hum*)
             else na
           else Anonymous in
-	PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
+        PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
   in buildrec 0 pred allnames
 
 let extract_arity_signature env0 tomatchl tmsign =
-  let get_one_sign n tm {contents = (na,t)} =
+  let get_one_sign n tm (na,t) =
     match tm with
       | NotInd (bo,typ) -> 
 	  (match t with
-	    | None -> [na,option_app (lift n) bo,lift n typ]
-	    | Some (loc,_,_) -> 
+	    | None -> [na,option_map (lift n) bo,lift n typ]
+	    | Some (loc,_,_,_) -> 
  	    user_err_loc (loc,"",
 	    str "Unexpected type annotation for a term of non inductive type"))
       | IsInd (_,IndType(indf,realargs)) ->
@@ -1655,17 +1547,12 @@ let extract_arity_signature env0 tomatchl tmsign =
 	  let nrealargs = List.length realargs in
 	  let realnal =
 	    match t with
-	      | Some (loc,ind',nal) ->
-		  let nparams = List.length params in
+	      | Some (loc,ind',nparams,realnal) ->
 		  if ind <> ind' then
 		    user_err_loc (loc,"",str "Wrong inductive type");
-		  if List.length nal <> nparams + nrealargs then
-		    user_err_loc (loc,"",
-		    str "Wrong number of arguments for inductive type");
-		  let parnal,realnal = list_chop nparams nal in
-		  if List.exists ((<>) Anonymous) parnal then
-		    user_err_loc (loc,"",
-		    str "The parameters of inductive type must be implicit");
+		  if List.length params <> nparams
+		    or nrealargs <> List.length realnal then
+		      anomaly "Ill-formed 'in' clause in cases";
 		  List.rev realnal
 	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
 	  let arsign = fst (get_arity env0 indf') in
@@ -1679,101 +1566,72 @@ let extract_arity_signature env0 tomatchl tmsign =
     | _ -> assert false
   in List.rev (buildrec 0 (tomatchl,tmsign))
 
+let inh_conv_coerce_to_tycon loc env isevars j tycon =
+  match tycon with
+    | Some p ->
+	let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in
+          isevars := evd';
+          j
+    | None -> j
+
+
 (* Builds the predicate. If the predicate is dependent, its context is
  * made of 1+nrealargs assumptions for each matched term in an inductive
  * type and 1 assumption for each term not _syntactically_ in an
  * inductive type.
 
- * V7 case: determines whether the multiple case is dependent or not
- * - if its arity is made of nrealargs assumptions for each matched
- * term in an inductive type and nothing for terms not _syntactically_
- * in an inductive type, then it is non dependent
- * - if its arity is made of 1+nrealargs assumptions for each matched
- * term in an inductive type and nothing for terms not _syntactically_
- * in an inductive type, then it is dependent and needs an adjustement
- * to fulfill the criterion above that terms not in an inductive type
- * counts for 1 in the dependent case
-
- * V8 case: each matched terms are independently considered dependent
- * or not
+ * Each matched terms are independently considered dependent or not.
 
- * A type constraint but no annotation case: it is assumed non dependent
+ * A type constraint but no annotation case: it is assumed non dependent.
  *)
 
 let prepare_predicate loc typing_fun isevars env tomatchs sign tycon = function
-  (* No type annotation at all *)
-  | (None,{contents = None}) ->
+  (* No type annotation *)
+  | None ->
       (match tycon with
-       | None -> None
-       | Some t ->
-	 let names,pred = prepare_predicate_from_tycon loc false env isevars tomatchs t in
-	 Some (build_initial_predicate false names pred))
-
-  (* v8 style type annotation *)
-  | (None,{contents = Some rtntyp}) ->
-
+       | Some (None, t) ->
+	   let names,pred = 
+	     prepare_predicate_from_tycon loc false env isevars tomatchs sign t 
+	   in Some (build_initial_predicate false names pred)
+       | _ -> None)
+
+  (* Some type annotation *)
+  | Some rtntyp ->
       (* We extract the signature of the arity *)
-      let arsigns = extract_arity_signature env tomatchs sign in
-      let env = List.fold_right push_rels arsigns env in
-      let allnames = List.rev (List.map (List.map pi1) arsigns) in
-      let predccl = (typing_fun (mk_tycon (new_Type ())) env rtntyp).uj_val in
-      Some (build_initial_predicate true allnames predccl)
-
-  (* v7 style type annotation; set the v8 annotation by side effect *)
-  | (Some pred,x) ->
-      let loc = loc_of_rawconstr pred in
-      let dep, n, predj =
-	let isevars_copy = evars_of isevars in
-        (* We first assume the predicate is non dependent *)
-	let ndep_arity = build_expected_arity env isevars false tomatchs in
-        try
-	  false, nb_prod ndep_arity, typing_fun (mk_tycon ndep_arity) env pred
-	with PretypeError _ | TypeError _ |
-	    Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) ->
-        evars_reset_evd isevars_copy isevars;
-        (* We then assume the predicate is dependent *)
-	let dep_arity = build_expected_arity env isevars true tomatchs in
-	try
-	  true, nb_prod dep_arity, typing_fun (mk_tycon dep_arity) env pred
-	with PretypeError _ | TypeError _ |
-	  Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) ->
-        evars_reset_evd isevars_copy isevars;
-        (* Otherwise we attempt to type it without constraints, possibly *)
-        (* failing with an error message; it may also be well-typed *)
-	(* but fails to satisfy arity constraints in case_dependent *)
-        let predj = typing_fun empty_tycon env pred in
-	error_wrong_predicate_arity_loc
-	  loc env predj.uj_val ndep_arity dep_arity
+      let arsign = extract_arity_signature env tomatchs sign in
+      let env = List.fold_right push_rels arsign env in
+      let allnames = List.rev (List.map (List.map pi1) arsign) in
+      let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in
+      let _ = 
+	option_map (fun tycon -> 
+		      isevars := Coercion.inh_conv_coerces_to loc env !isevars predcclj.uj_val 
+		      (lift_tycon_type (List.length arsign) tycon))
+	  tycon
       in
-      let ln,predccl= extract_predicate_conclusion dep tomatchs predj.uj_val in
-      set_arity_signature dep n sign tomatchs pred x;
-      Some (build_initial_predicate dep ln predccl)
-
+      let predccl = (j_nf_isevar !isevars predcclj).uj_val in      
+	Some (build_initial_predicate true allnames predccl)
 
 (**************************************************************************)
 (* Main entry of the matching compilation                                 *)
-
-let compile_cases loc (typing_fun,isevars) tycon env (predopt, tomatchl, eqns)=
-
+  
+let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns)=
+  
   (* We build the matrix of patterns and right-hand-side *)
   let matx = matx_of_eqns env tomatchl eqns in
-
+    
   (* We build the vector of terms to match consistently with the *)
   (* constructors found in patterns *)
-  let rawtms, tmsign = List.split tomatchl in
-  let tomatchs = coerce_to_indtype typing_fun isevars env matx rawtms in
-
+  let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
+    
   (* We build the elimination predicate if any and check its consistency *)
   (* with the type of arguments to match *)
+  let tmsign = List.map snd tomatchl in
   let pred = prepare_predicate loc typing_fun isevars env tomatchs tmsign tycon predopt in
-
-  (* We deal with initial aliases *)
-  let matx = prepare_initial_aliases (known_dependent pred) tomatchs matx in 
-
+    
   (* We push the initial terms to match and push their alias to rhs' envs *)
   (* names of aliases will be recovered from patterns (hence Anonymous here) *)
   let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
- 
+    
   let pb =
     { env      = env;
       isevars  = isevars;
@@ -1783,12 +1641,10 @@ let compile_cases loc (typing_fun,isevars) tycon env (predopt, tomatchl, eqns)=
       mat      = matx;
       caseloc  = loc;
       typing_function = typing_fun } in
-  
+    
   let _, j = compile pb in
-
-  (* We check for unused patterns *)
-  List.iter (check_unused_pattern env) matx;
+    (* We check for unused patterns *)
+    List.iter (check_unused_pattern env) matx;
+    inh_conv_coerce_to_tycon loc env isevars j tycon
+end
   
-  match tycon with
-    | Some p ->	Coercion.inh_conv_coerce_to loc env isevars j p
-    | None -> j
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index 1d2f9025..9e902126 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cases.mli,v 1.22.2.2 2004/07/16 19:30:43 herbelin Exp $ i*)
+(*i $Id: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -23,6 +23,7 @@ type pattern_matching_error =
   | BadPattern of constructor * constr
   | BadConstructor of constructor * inductive
   | WrongNumargConstructor of constructor * int
+  | WrongNumargInductive of inductive * int
   | WrongPredicateArity of constr * constr * constr
   | NeedsInversion of constr * constr
   | UnusedClause of cases_pattern list
@@ -31,26 +32,19 @@ type pattern_matching_error =
 
 exception PatternMatchingError of env * pattern_matching_error
 
-(*s Used for old cases in pretyping *)
+val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a
 
-val branch_scheme : 
-  env -> evar_defs -> bool -> inductive_family -> constr array
-
-type ml_case_error =
-  | MlCaseAbsurd
-  | MlCaseDependent
-
-exception NotInferable of ml_case_error
-
-val pred_case_ml : (* raises [NotInferable] if not inferable *)
-  env -> evar_map -> bool -> inductive_type -> int * types -> constr 
+val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a
 
 (*s Compilation of pattern-matching. *)
 
-val compile_cases :
-  loc -> (type_constraint -> env -> rawconstr -> unsafe_judgment)
-  * evar_defs -> type_constraint -> env ->
-      (rawconstr option * rawconstr option ref) *
-      (rawconstr * (name * (loc * inductive * name list) option) ref) list *
-    (loc * identifier list * cases_pattern list * rawconstr) list ->
+module type S = sig
+  val compile_cases :
+    loc ->
+    (type_constraint -> env -> rawconstr -> unsafe_judgment) * evar_defs ref ->
+    type_constraint -> 
+    env -> rawconstr option * tomatch_tuple * cases_clauses ->
     unsafe_judgment
+end
+
+module Cases_F(C : Coercion.S) : S
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 88f59ded..2a01e901 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -6,16 +6,16 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cbv.ml,v 1.12.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+(* $Id: cbv.ml 8802 2006-05-10 20:47:28Z barras $ *)
 
 open Util
 open Pp
 open Term
 open Names
 open Environ
-open Instantiate
 open Univ
 open Evd
+open Conv_oracle
 open Closure
 open Esubst
 
@@ -45,10 +45,10 @@ open Esubst
  *)
 type cbv_value =
   | VAL of int * constr
-  | LAM of name * constr * constr * cbv_value subs
-  | FIXP of fixpoint * cbv_value subs * cbv_value list
-  | COFIXP of cofixpoint * cbv_value subs * cbv_value list
-  | CONSTR of constructor * cbv_value list
+  | LAM of int * (name * constr) list * constr * cbv_value subs
+  | FIXP of fixpoint * cbv_value subs * cbv_value array
+  | COFIXP of cofixpoint * cbv_value subs * cbv_value array
+  | CONSTR of constructor * cbv_value array
 
 (* les vars pourraient etre des constr,
    cela permet de retarder les lift: utile ?? *) 
@@ -58,14 +58,15 @@ type cbv_value =
  *)
 let rec shift_value n = function
   | VAL (k,v) -> VAL ((k+n),v)
-  | LAM (x,a,b,s) -> LAM (x,a,b,subs_shft (n,s))
+  | LAM (nlams,ctxt,b,s) -> LAM (nlams,ctxt,b,subs_shft (n,s))
   | FIXP (fix,s,args) ->
-      FIXP (fix,subs_shft (n,s), List.map (shift_value n) args)
+      FIXP (fix,subs_shft (n,s), Array.map (shift_value n) args)
   | COFIXP (cofix,s,args) ->
-      COFIXP (cofix,subs_shft (n,s), List.map (shift_value n) args)
+      COFIXP (cofix,subs_shft (n,s), Array.map (shift_value n) args)
   | CONSTR (c,args) ->
-      CONSTR (c, List.map (shift_value n) args)
-	
+      CONSTR (c, Array.map (shift_value n) args)
+let shift_value n v =
+  if n = 0 then v else shift_value n v
 
 (* Contracts a fixpoint: given a fixpoint and a bindings,
  * returns the corresponding fixpoint body, and the bindings in which
@@ -74,34 +75,28 @@ let rec shift_value n = function
  *    -> (S. [S]F0 . [S]F1 ... . [S]Fn-1, Ti)
  *)
 let contract_fixp env ((reci,i),(_,_,bds as bodies)) =
-  let make_body j = FIXP(((reci,j),bodies), env, []) in
+  let make_body j = FIXP(((reci,j),bodies), env, [||]) in
   let n = Array.length bds in
-  let rec subst_bodies_from_i i subs =
-    if i=n then subs
-    else subst_bodies_from_i (i+1) (subs_cons (make_body i, subs))
-  in       
-  subst_bodies_from_i 0 env, bds.(i)
+  subs_cons(Array.init n make_body, env), bds.(i)
 
 let contract_cofixp env (i,(_,_,bds as bodies)) =
-  let make_body j = COFIXP((j,bodies), env, []) in
+  let make_body j = COFIXP((j,bodies), env, [||]) in
   let n = Array.length bds in
-  let rec subst_bodies_from_i i subs =
-    if i=n then subs
-    else subst_bodies_from_i (i+1) (subs_cons (make_body i, subs))
-  in       
-  subst_bodies_from_i 0 env, bds.(i)
+  subs_cons(Array.init n make_body, env), bds.(i)
 
 let make_constr_ref n = function
-  | FarRelKey p -> mkRel (n+p)
+  | RelKey p -> mkRel (n+p)
   | VarKey id -> mkVar id
   | ConstKey cst -> mkConst cst
 
 
 (* type of terms with a hole. This hole can appear only under App or Case.
  *   TOP means the term is considered without context
- *   APP(l,stk) means the term is applied to l, and then we have the context st
+ *   APP(v,stk) means the term is applied to v, and then the context stk
+ *      (v.0 is the first argument).
  *      this corresponds to the application stack of the KAM.
- *      The members of l are values: we evaluate arguments before the function.
+ *      The members of l are values: we evaluate arguments before
+        calling the function.
  *   CASE(t,br,pat,S,stk) means the term is in a case (which is himself in stk
  *      t is the type of the case and br are the branches, all of them under
  *      the subs S, pat is information on the patterns of the Case
@@ -114,21 +109,21 @@ let make_constr_ref n = function
 
 type cbv_stack =
   | TOP
-  | APP of cbv_value list * cbv_stack
+  | APP of cbv_value array * cbv_stack
   | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
 
 (* Adds an application list. Collapse APPs! *)
 let stack_app appl stack =
-  match (appl, stack) with
-    | ([], _)            -> stack
-    | (_, APP(args,stk)) -> APP(appl@args,stk)
-    | _                  -> APP(appl, stack)
+  if Array.length appl = 0 then stack else
+    match stack with
+    | APP(args,stk) -> APP(Array.append appl args,stk)
+    | _             -> APP(appl, stack)
 
 
 open RedFlags
 
 let red_set_ref flags = function
-  | FarRelKey _ -> red_set flags fDELTA
+  | RelKey _ -> red_set flags fDELTA
   | VarKey id -> red_set flags (fVAR id)
   | ConstKey sp -> red_set flags (fCONST sp)
 
@@ -137,23 +132,21 @@ let red_set_ref flags = function
  *)
 let strip_appl head stack =
   match head with
-    | FIXP (fix,env,app) -> (FIXP(fix,env,[]), stack_app app stack)
-    | COFIXP (cofix,env,app) -> (COFIXP(cofix,env,[]), stack_app app stack)
-    | CONSTR (c,app) -> (CONSTR(c,[]), stack_app app stack)
+    | FIXP (fix,env,app) -> (FIXP(fix,env,[||]), stack_app app stack)
+    | COFIXP (cofix,env,app) -> (COFIXP(cofix,env,[||]), stack_app app stack)
+    | CONSTR (c,app) -> (CONSTR(c,[||]), stack_app app stack)
     | _ -> (head, stack)
 
 
-(* Tests if fixpoint reduction is possible. A reduction function is given as
-   argument *)
-let rec check_app_constr = function
-  | ([], _) -> false
-  | ((CONSTR _)::_, 0) -> true
-  | (_::l, n) -> check_app_constr (l,(pred n))
-	
+(* Tests if fixpoint reduction is possible. *)
 let fixp_reducible flgs ((reci,i),_) stk =
   if red_set flgs fIOTA then
-    match stk with               (* !!! for Acc_rec: reci.(i) = -2 *)
-      | APP(appl,_) -> reci.(i) >=0 & check_app_constr (appl, reci.(i))
+    match stk with
+      | APP(appl,_) ->
+          Array.length appl > reci.(i) &&
+          (match appl.(reci.(i)) with
+              CONSTR _ -> true
+            | _ -> false)
       | _ -> false
   else 
     false
@@ -166,6 +159,7 @@ let cofixp_reducible flgs _ stk =
   else 
     false
 
+
 (* The main recursive functions
  *
  * Go under applications and cases (pushed in the stack), expand head
@@ -184,9 +178,9 @@ let rec norm_head info env t stack =
   | App (head,args) -> (* Applied terms are normalized immediately;
                         they could be computed when getting out of the stack *)
       let nargs = Array.map (cbv_stack_term info TOP env) args in
-      norm_head info env head (stack_app (Array.to_list nargs) stack)
+      norm_head info env head (stack_app nargs stack)
   | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack))
-  | Cast (ct,_) -> norm_head info env ct stack
+  | Cast (ct,_,_) -> norm_head info env ct stack
 
   (* constants, axioms
    * the first pattern is CRUCIAL, n=0 happens very often:
@@ -196,7 +190,7 @@ let rec norm_head info env t stack =
         | Inl (0,v)      -> strip_appl v stack
         | Inl (n,v)      -> strip_appl (shift_value n v) stack
         | Inr (n,None)   -> (VAL(0, mkRel n), stack)
-        | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (FarRelKey p))
+        | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (RelKey p))
 
   | Var id -> norm_head_ref 0 info env stack (VarKey id)
 
@@ -212,7 +206,7 @@ let rec norm_head info env t stack =
           or red_set (info_flags info) fDELTA
           *)
         then 
-	  subs_cons (cbv_stack_term info TOP env b,env)
+	  subs_cons ([|cbv_stack_term info TOP env b|],env)
 	else
 	  subs_lift env in
       if zeta then
@@ -225,10 +219,12 @@ let rec norm_head info env t stack =
 	(VAL(0,normt), stack) (* Considérer une coupure commutative ? *)
 
   (* non-neutral cases *)
-  | Lambda (x,a,b) -> (LAM(x,a,b,env), stack)
-  | Fix fix -> (FIXP(fix,env,[]), stack)
-  | CoFix cofix -> (COFIXP(cofix,env,[]), stack)
-  | Construct c -> (CONSTR(c, []), stack)
+  | Lambda _ ->
+      let ctxt,b = decompose_lam t in
+      (LAM(List.length ctxt, List.rev ctxt,b,env), stack)
+  | Fix fix -> (FIXP(fix,env,[||]), stack)
+  | CoFix cofix -> (COFIXP(cofix,env,[||]), stack)
+  | Construct c -> (CONSTR(c, [||]), stack)
 
   (* neutral cases *)
   | (Sort _ | Meta _ | Ind _|Evar _) -> (VAL(0, t), stack)
@@ -253,10 +249,18 @@ and norm_head_ref k info env stack normt =
 and cbv_stack_term info stack env t =
   match norm_head info env t stack with
     (* a lambda meets an application -> BETA *)
-    | (LAM (x,a,b,env), APP (arg::args, stk))
+    | (LAM (nlams,ctxt,b,env), APP (args, stk))
       when red_set (info_flags info) fBETA ->
-        let subs = subs_cons (arg,env) in
-          cbv_stack_term info (stack_app args stk) subs b
+        let nargs = Array.length args in
+        if nargs == nlams then
+          cbv_stack_term info stk (subs_cons(args,env)) b
+        else if nlams < nargs then
+          let env' = subs_cons(Array.sub args 0 nlams, env) in
+          let eargs = Array.sub args nlams (nargs-nlams) in
+          cbv_stack_term info (APP(eargs,stk)) env' b
+        else
+          let ctxt' = list_skipn nargs ctxt in
+          LAM(nlams-nargs,ctxt', b, subs_cons(args,env))
 
     (* a Fix applied enough -> IOTA *)
     | (FIXP(fix,env,_), stk)
@@ -273,8 +277,9 @@ and cbv_stack_term info stack env t =
     (* constructor in a Case -> IOTA *)
     | (CONSTR((sp,n),_), APP(args,CASE(_,br,ci,env,stk)))
             when red_set (info_flags info) fIOTA ->
-	let real_args = list_skipn ci.ci_npar args in
-        cbv_stack_term info (stack_app real_args stk) env br.(n-1)
+	let cargs =
+          Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in
+        cbv_stack_term info (stack_app cargs stk) env br.(n-1)
          
     (* constructor of arity 0 in a Case -> IOTA *)
     | (CONSTR((_,n),_), CASE(_,br,_,env,stk))
@@ -287,6 +292,9 @@ and cbv_stack_term info stack env t =
     | (COFIXP(cofix,env,_), APP(appl,TOP)) -> COFIXP(cofix,env,appl) 
     | (CONSTR(c,_), APP(appl,TOP)) -> CONSTR(c,appl)
 
+    (* absurd cases (ill-typed) *)
+    | (LAM _, CASE _) -> assert false
+
     (* definitely a value *)
     | (head,stk) -> VAL(0,apply_stack info (cbv_norm_value info head) stk)
 
@@ -298,7 +306,7 @@ and cbv_stack_term info stack env t =
 and apply_stack info t = function
   | TOP -> t
   | APP (args,st) ->
-      apply_stack info (applistc t (List.map (cbv_norm_value info) args)) st
+      apply_stack info (mkApp(t,Array.map (cbv_norm_value info) args)) st
   | CASE (ty,br,ci,env,st) ->
       apply_stack info
         (mkCase (ci, cbv_norm_term info env ty, t,
@@ -314,28 +322,28 @@ and cbv_norm_term info env t =
 (* reduction of a cbv_value to a constr *)
 and cbv_norm_value info = function (* reduction under binders *)
   | VAL (n,v) -> lift n v
-  | LAM (x,a,b,env) ->
-      mkLambda (x, cbv_norm_term info env a,
-		cbv_norm_term info (subs_lift env) b)
+  | LAM (n,ctxt,b,env) ->
+      let nctxt =
+        list_map_i (fun i (x,ty) ->
+          (x,cbv_norm_term info (subs_liftn i env) ty)) 0 ctxt in
+      compose_lam (List.rev nctxt) (cbv_norm_term info (subs_liftn n env) b)
   | FIXP ((lij,(names,lty,bds)),env,args) ->
-      applistc
+      mkApp
         (mkFix (lij,
 		(names,
                  Array.map (cbv_norm_term info env) lty,
 		 Array.map (cbv_norm_term info 
-			      (subs_liftn (Array.length lty) env)) bds)))
-        (List.map (cbv_norm_value info) args)
+			      (subs_liftn (Array.length lty) env)) bds)),
+         Array.map (cbv_norm_value info) args)
   | COFIXP ((j,(names,lty,bds)),env,args) ->
-      applistc
+      mkApp
         (mkCoFix (j,
 		  (names,Array.map (cbv_norm_term info env) lty,
 		   Array.map (cbv_norm_term info 
-				(subs_liftn (Array.length lty) env)) bds)))
-        (List.map (cbv_norm_value info) args)
+				(subs_liftn (Array.length lty) env)) bds)),
+         Array.map (cbv_norm_value info) args)
   | CONSTR (c,args) ->
-      applistc
-        (mkConstruct c)
-        (List.map (cbv_norm_value info) args)
+      mkApp(mkConstruct c, Array.map (cbv_norm_value info) args)
 
 (* with profiling *)
 let cbv_norm infos constr =
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index bf8e03b3..8c969e2c 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cbv.mli,v 1.6.14.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: cbv.mli 8799 2006-05-09 21:15:07Z barras $ i*)
 
 (*i*)
 open Names
@@ -29,19 +29,19 @@ val cbv_norm         : cbv_infos -> constr -> constr
 (*i This is for cbv debug *)
 type cbv_value =
   | VAL of int * constr
-  | LAM of name * constr * constr * cbv_value subs
-  | FIXP of fixpoint * cbv_value subs * cbv_value list
-  | COFIXP of cofixpoint * cbv_value subs * cbv_value list
-  | CONSTR of constructor * cbv_value list
+  | LAM of int * (name * constr) list * constr * cbv_value subs
+  | FIXP of fixpoint * cbv_value subs * cbv_value array
+  | COFIXP of cofixpoint * cbv_value subs * cbv_value array
+  | CONSTR of constructor * cbv_value array
 
 val shift_value : int -> cbv_value -> cbv_value
 
 type cbv_stack =
   | TOP
-  | APP of cbv_value list * cbv_stack
+  | APP of cbv_value array * cbv_stack
   | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
 
-val stack_app : cbv_value list -> cbv_stack -> cbv_stack
+val stack_app : cbv_value array -> cbv_stack -> cbv_stack
 val strip_appl : cbv_value -> cbv_stack -> cbv_value * cbv_stack
 
 (* recursive functions... *)
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index 2d8fb951..bbad005c 100755..100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: classops.ml,v 1.48.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+(* $Id: classops.ml 9257 2006-10-21 17:28:28Z herbelin $ *)
 
 open Util
 open Pp
@@ -21,6 +21,7 @@ open Term
 open Termops
 open Rawterm
 open Decl_kinds
+open Mod_subst
 
 (* usage qque peu general: utilise aussi dans record *)
 
@@ -35,14 +36,14 @@ type cl_typ =
   | CL_IND of inductive
 
 type cl_info_typ = {
-  cl_strength : strength;
   cl_param : int
 }
 
 type coe_typ = global_reference
 
 type coe_info_typ = {
-  coe_value : unsafe_judgment;
+  coe_value : constr;
+  coe_type : types;
   coe_strength : strength;
   coe_is_identity : bool;
   coe_param : int }
@@ -91,11 +92,7 @@ let unfreeze (fcl,fco,fig) =
 (* ajout de nouveaux "objets" *)
 
 let add_new_class cl s =
-  try
-    let n,s' = Bijint.revmap cl !class_tab in
-    if s.cl_strength = Global & s'.cl_strength <> Global then
-      class_tab := Bijint.replace n cl s !class_tab
-  with Not_found ->
+  if not (Bijint.mem cl !class_tab) then
     class_tab := Bijint.add cl s !class_tab
 
 let add_new_coercion coe s = 
@@ -106,11 +103,19 @@ let add_new_path x y =
 
 let init () =
   class_tab:= Bijint.empty; 
-  add_new_class CL_FUN  { cl_param = 0; cl_strength = Global };
-  add_new_class CL_SORT { cl_param = 0; cl_strength = Global };
+  add_new_class CL_FUN  { cl_param = 0 };
+  add_new_class CL_SORT { cl_param = 0 };
   coercion_tab:= Gmap.empty;
   inheritance_graph:= Gmap.empty
 
+let _ = 
+  Summary.declare_summary "inh_graph"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
 let _ = init()
 
 (* class_info : cl_typ -> int * cl_info_typ *)
@@ -146,80 +151,45 @@ let lookup_pattern_path_between (s,t) =
     (fun coe ->
        let c, _ =
 	 Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty 
-	   coe.coe_value.uj_val
+	   coe.coe_value
        in 
        match kind_of_term c with
-	 | Construct sp -> (sp, coe.coe_param)
+	 | Construct cstr ->
+	     (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1)
 	 | _ -> raise Not_found) l
 
+(* find_class_type : constr -> cl_typ * int *)
+
+let find_class_type t =
+  let t', args = decompose_app (Reductionops.whd_betaiotazeta t) in
+  match kind_of_term t' with
+    | Var id -> CL_SECVAR id, args
+    | Const sp -> CL_CONST sp, args
+    | Ind ind_sp -> CL_IND ind_sp, args
+    | Prod (_,_,_) -> CL_FUN, []
+    | Sort _ -> CL_SORT, []
+    |  _ -> raise Not_found
+
 
 let subst_cl_typ subst ct = match ct with
     CL_SORT
   | CL_FUN
   | CL_SECVAR _ -> ct
   | CL_CONST kn -> 
-      let kn' = subst_kn subst kn in 
+      let kn',t = subst_con subst kn in 
 	if kn' == kn then ct else
-	  CL_CONST kn'
+         fst (find_class_type t)
   | CL_IND (kn,i) ->
       let kn' = subst_kn subst kn in 
 	if kn' == kn then ct else
 	  CL_IND (kn',i)
 
-let subst_coe_typ = subst_global
-
-let subst_coe_info subst info = 
-  let jud = info.coe_value in
-  let val' = subst_mps subst (j_val jud) in
-  let type' = subst_mps subst (j_type jud) in
-    if val' == j_val jud && type' == j_type jud then info else
-      {info with coe_value = make_judge val' type'}
-
-(* library, summary *)
-
-(*val inClass : (cl_typ * cl_info_typ) -> Libobject.object = <fun>
- val outClass : Libobject.object -> (cl_typ * cl_info_typ) = <fun> *)
-
-let cache_class (_,(x,y)) = add_new_class x y
-
-let subst_class (_,subst,(ct,ci as obj)) = 
-  let ct' = subst_cl_typ subst ct in
-    if ct' == ct then obj else
-      (ct',ci)
-
-let (inClass,outClass) =
-  declare_object {(default_object "CLASS") with 
-		    load_function = (fun _ o -> cache_class o);
-                    cache_function = cache_class;
-		    subst_function = subst_class;
-		    classify_function = (fun (_,x) -> Substitute x); 
-		    export_function = (function x -> Some x)  }
-
-let declare_class (cl,stre,p) = 
-  Lib.add_anonymous_leaf (inClass ((cl,{ cl_strength = stre; cl_param = p })))
-   
-let _ = 
-  Summary.declare_summary "inh_graph"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+(*CSC: here we should change the datatype for coercions: it should be possible
+       to declare any term as a coercion *)
+let subst_coe_typ subst t = fst (subst_global subst t)
 
 (* classe d'un terme *)
 
-(* find_class_type : constr -> cl_typ * int *)
-
-let find_class_type t =
-  let t', args = decompose_app (Reductionops.whd_betaiotazeta t) in
-  match kind_of_term t' with
-    | Var id -> CL_SECVAR id, args
-    | Const sp -> CL_CONST sp, args
-    | Ind ind_sp -> CL_IND ind_sp, args
-    | Prod (_,_,_) -> CL_FUN, []
-    | Sort _ -> CL_SORT, []
-    |  _ -> raise Not_found
-
 (* class_of : Term.constr -> int *)
 
 let class_of env sigma t = 
@@ -238,11 +208,11 @@ let class_of env sigma t =
 
 let inductive_class_of ind = fst (class_info (CL_IND ind))
 
-let class_args_of c = snd (decompose_app c)
+let class_args_of c = snd (find_class_type c)
 
 let string_of_class = function
-  | CL_FUN -> if !Options.v7 then "FUNCLASS" else "Funclass"
-  | CL_SORT -> if !Options.v7 then "SORTCLASS" else "Sortclass"
+  | CL_FUN -> "Funclass"
+  | CL_SORT -> "Sortclass"
   | CL_CONST sp ->
       string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp))
   | CL_IND sp ->
@@ -254,7 +224,8 @@ let pr_class x = str (string_of_class x)
 
 (* coercion_value : coe_index -> unsafe_judgment * bool *)
 
-let coercion_value { coe_value = j; coe_is_identity = b } = (j,b)
+let coercion_value { coe_value = c; coe_type = t; coe_is_identity = b } =
+  (make_judge c t, b)
 
 (* pretty-print functions are now in Pretty *)
 (* rajouter une coercion dans le graphe *)
@@ -319,49 +290,81 @@ let add_coercion_in_graph (ic,source,target) =
   if (!ambig_paths <> []) && is_verbose () then 
     ppnl (message_ambig !ambig_paths)
 
-type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ
+type coercion = coe_typ * strength * bool * cl_typ * cl_typ * int
+
+(* Calcul de l'arité d'une classe *)
 
-let cache_coercion (_,(coe,xf,cls,clt)) =
+let reference_arity_length ref =
+  let t = Global.type_of_global ref in
+  List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t))
+
+let class_params = function
+  | CL_FUN | CL_SORT -> 0
+  | CL_CONST sp -> reference_arity_length (ConstRef sp)
+  | CL_SECVAR sp -> reference_arity_length (VarRef sp)
+  | CL_IND sp  -> reference_arity_length (IndRef sp)
+
+(* add_class : cl_typ -> strength option -> bool -> unit *)
+
+let add_class cl =
+  add_new_class cl { cl_param = class_params cl }
+
+let load_coercion i (_,(coe,stre,isid,cls,clt,ps)) =
+  add_class cls;
+  add_class clt;
   let is,_ = class_info cls in
   let it,_ = class_info clt in
+  let xf = 
+    { coe_value = constr_of_global coe;
+      coe_type = Global.type_of_global coe;
+      coe_strength = stre;
+      coe_is_identity = isid;
+      coe_param = ps } in
   add_new_coercion coe xf;
   add_coercion_in_graph (xf,is,it)
 
-let subst_coercion (_,subst,(coe,xf,cls,clt as obj)) =
+let cache_coercion o =
+  load_coercion 1 o
+
+let subst_coercion (_,subst,(coe,stre,isid,cls,clt,ps as obj)) =
   let coe' = subst_coe_typ subst coe in
-  let xf' = subst_coe_info subst xf in
   let cls' = subst_cl_typ subst cls in
   let clt' = subst_cl_typ subst clt in
-    if coe' == coe && xf' == xf && cls' == cls & clt' == clt then obj else
-      (coe',xf',cls',clt')
-      
-    
-(* val inCoercion : coercion -> Libobject.object 
-   val outCoercion : Libobject.object -> coercion *)
+    if coe' == coe && cls' == cls & clt' == clt then obj else
+      (coe',stre,isid,cls',clt',ps)
+
+let discharge_cl = function
+  | CL_CONST kn -> CL_CONST (Lib.discharge_con kn)
+  | CL_IND ind -> CL_IND (Lib.discharge_inductive ind)
+  | cl -> cl
+
+let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) =
+  if stre = Local then None else 
+    let n = try Array.length (Lib.section_instance coe) with Not_found -> 0 in
+    Some (Lib.discharge_global coe,
+          stre,
+	  isid,
+          discharge_cl cls,
+	  discharge_cl clt,
+          n + ps)
 
 let (inCoercion,outCoercion) =
   declare_object {(default_object "COERCION") with 
-		    load_function = (fun _ o -> cache_coercion o);
-                    cache_function = cache_coercion;
-		    subst_function = subst_coercion;
-		    classify_function = (fun (_,x) -> Substitute x); 
-                    export_function = (function x -> Some x)  }
-
-let declare_coercion coef v stre ~isid ~src:cls ~target:clt ~params:ps =
-  Lib.add_anonymous_leaf
-    (inCoercion
-       (coef,
-	 { coe_value = v;
-	   coe_strength = stre;
-	   coe_is_identity = isid;
-	   coe_param = ps },
-	cls, clt))
+    load_function = load_coercion;
+    cache_function = cache_coercion;
+    subst_function = subst_coercion;
+    classify_function = (fun (_,x) -> Substitute x);
+    discharge_function = discharge_coercion;
+    export_function = (function x -> Some x)  }
+
+let declare_coercion coef stre ~isid ~src:cls ~target:clt ~params:ps =
+  Lib.add_anonymous_leaf (inCoercion (coef,stre,isid,cls,clt,ps))
 
 let coercion_strength v = v.coe_strength
 let coercion_identity v = v.coe_is_identity
 
 (* For printing purpose *)
-let get_coercion_value v = v.coe_value.uj_val
+let get_coercion_value v = v.coe_value
 
 let classes () = Bijint.dom !class_tab
 let coercions () = Gmap.rng !coercion_tab
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index f846a9e5..276b14d1 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: classops.mli,v 1.30.2.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: classops.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -15,6 +15,7 @@ open Term
 open Evd
 open Environ
 open Nametab
+open Mod_subst
 (*i*)
 
 (*s This is the type of class kinds *)
@@ -29,7 +30,6 @@ val subst_cl_typ : substitution -> cl_typ -> cl_typ
 
 (* This is the type of infos for declared classes *)
 type cl_info_typ = {
-  cl_strength : strength;
   cl_param : int }
 
 (* This is the type of coercion kinds *)
@@ -47,9 +47,6 @@ type coe_index
 (* This is the type of paths from a class to another *)
 type inheritance_path = coe_index list
 
-(*s [declare_class] adds a class to the set of declared classes *)
-val declare_class : cl_typ * strength * int -> unit
-
 (*s Access to classes infos *)
 val class_info : cl_typ -> (cl_index * cl_info_typ)
 val class_exists : cl_typ -> bool
@@ -69,7 +66,7 @@ val class_args_of : constr -> constr list
 
 (*s [declare_coercion] adds a coercion in the graph of coercion paths *)
 val declare_coercion : 
-  coe_typ -> unsafe_judgment -> strength -> isid:bool ->
+  coe_typ -> strength -> isid:bool ->
       src:cl_typ -> target:cl_typ -> params:int -> unit
 
 (*s Access to coercions infos *)
@@ -84,19 +81,6 @@ val lookup_path_to_sort_from : cl_index -> inheritance_path
 val lookup_pattern_path_between :
   cl_index * cl_index -> (constructor * int) list
 
-(*i Pour le discharge *)
-type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ
-
-open Libobject
-val inClass : (cl_typ * cl_info_typ) -> Libobject.obj
-val outClass : Libobject.obj -> (cl_typ * cl_info_typ)
-val inCoercion : coercion -> Libobject.obj
-val outCoercion : Libobject.obj -> coercion
-val coercion_strength : coe_info_typ -> strength
-val coercion_identity : coe_info_typ -> bool
-val coercion_params : coe_info_typ -> int
-(*i*)
-
 (*i Crade *)
 open Pp
 val install_path_printer : 
diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml
new file mode 100644
index 00000000..abe31e06
--- /dev/null
+++ b/pretyping/clenv.ml
@@ -0,0 +1,468 @@
+(************************************************************************)
+(*  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: clenv.ml 9279 2006-10-25 15:51:24Z herbelin $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Environ
+open Evd
+open Reduction
+open Reductionops
+open Rawterm
+open Pattern
+open Tacexpr
+open Tacred
+open Pretype_errors
+open Evarutil
+open Unification
+open Mod_subst
+
+(* *)
+let w_coerce env c ctyp target evd =
+  let j = make_judge c ctyp in
+  let (evd',j') = Coercion.Default.inh_conv_coerce_to dummy_loc env evd j (mk_tycon_type target) in
+  (evd',j'.uj_val)
+
+let pf_env gls = Global.env_of_context gls.it.evar_hyps
+let pf_type_of gls c  = Typing.type_of (pf_env gls) gls.sigma c
+let pf_hnf_constr gls c = hnf_constr (pf_env gls) gls.sigma c
+let pf_concl gl = gl.it.evar_concl
+
+(******************************************************************)
+(* Clausal environments *)
+
+type clausenv = {
+  templenv : env;
+  env      : evar_defs;
+  templval : constr freelisted;
+  templtyp : constr freelisted }
+
+let cl_env ce = ce.templenv
+let cl_sigma ce = evars_of ce.env
+
+let subst_clenv sub clenv = 
+  { templval = map_fl (subst_mps sub) clenv.templval;
+    templtyp = map_fl (subst_mps sub) clenv.templtyp;
+    env = subst_evar_defs sub clenv.env;
+    templenv = clenv.templenv }
+
+let clenv_nf_meta clenv c = nf_meta clenv.env c
+let clenv_meta_type clenv mv = Typing.meta_type clenv.env mv
+let clenv_value clenv = meta_instance clenv.env clenv.templval
+let clenv_type clenv = meta_instance clenv.env clenv.templtyp
+
+
+let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t
+
+let clenv_get_type_of ce c =
+  let metamap =
+    List.map 
+      (function
+	 | (n,Clval(_,_,typ)) -> (n,typ.rebus)
+         | (n,Cltyp (_,typ))    -> (n,typ.rebus))
+      (meta_list ce.env) in
+  Retyping.get_type_of_with_meta (cl_env ce) (cl_sigma ce) metamap c
+
+exception NotExtensibleClause
+
+let clenv_push_prod cl =
+  let typ = whd_betadeltaiota (cl_env cl) (cl_sigma cl) (clenv_type cl) in
+  let rec clrec typ = match kind_of_term typ with
+    | Cast (t,_,_) -> clrec t
+    | Prod (na,t,u) ->
+	let mv = new_meta () in
+	let dep = dependent (mkRel 1) u in
+	let na' = if dep then na else Anonymous in
+	let e' = meta_declare mv t ~name:na' cl.env in
+	let concl = if dep then subst1 (mkMeta mv) u else u in
+	let def = applist (cl.templval.rebus,[mkMeta mv]) in
+	{ templval = mk_freelisted def;
+	  templtyp = mk_freelisted concl;
+	  env = e';
+	  templenv = cl.templenv }
+    | _ -> raise NotExtensibleClause
+  in clrec typ
+
+let clenv_environments evd bound c =
+  let rec clrec (e,metas) n c =
+    match n, kind_of_term c with
+      | (Some 0, _) -> (e, List.rev metas, c)
+      | (n, Cast (c,_,_)) -> clrec (e,metas) n c
+      | (n, Prod (na,c1,c2)) ->
+	  let mv = new_meta () in
+	  let dep = dependent (mkRel 1) c2 in
+	  let na' = if dep then na else Anonymous in
+	  let e' = meta_declare mv c1 ~name:na' e in
+	  clrec (e', (mkMeta mv)::metas) (option_map ((+) (-1)) n)
+	    (if dep then (subst1 (mkMeta mv) c2) else c2)
+      | (n, LetIn (na,b,_,c)) ->
+	  clrec (e,metas) (option_map ((+) (-1)) n) (subst1 b c)
+      | (n, _) -> (e, List.rev metas, c)
+  in 
+  clrec (evd,[]) bound c
+
+let clenv_environments_evars env evd bound c =
+  let rec clrec (e,ts) n c =
+    match n, kind_of_term c with
+      | (Some 0, _) -> (e, List.rev ts, c)
+      | (n, Cast (c,_,_)) -> clrec (e,ts) n c
+      | (n, Prod (na,c1,c2)) ->
+          let e',constr = Evarutil.new_evar e env c1 in
+	  let dep = dependent (mkRel 1) c2 in
+	  clrec (e', constr::ts) (option_map ((+) (-1)) n)
+	    (if dep then (subst1 constr c2) else c2)
+      | (n, LetIn (na,b,_,c)) ->
+	  clrec (e,ts) (option_map ((+) (-1)) n) (subst1 b c)
+      | (n, _) -> (e, List.rev ts, c)
+  in 
+  clrec (evd,[]) bound c
+
+let mk_clenv_from_n gls n (c,cty) =
+  let evd = create_evar_defs gls.sigma in
+  let (env,args,concl) = clenv_environments evd n cty in
+  { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args));
+    templtyp = mk_freelisted concl;
+    env = env;
+    templenv = Global.env_of_context gls.it.evar_hyps }
+
+let mk_clenv_from gls = mk_clenv_from_n gls None
+
+let mk_clenv_rename_from gls (c,t) = 
+  mk_clenv_from gls (c,rename_bound_var (pf_env gls) [] t)
+
+let mk_clenv_rename_from_n gls n (c,t) = 
+  mk_clenv_from_n gls n (c,rename_bound_var (pf_env gls) [] t)
+
+let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t)
+
+(******************************************************************)
+
+(* [mentions clenv mv0 mv1] is true if mv1 is defined and mentions
+ * mv0, or if one of the free vars on mv1's freelist mentions
+ * mv0 *)
+
+let mentions clenv mv0 =
+  let rec menrec mv1 =
+    mv0 = mv1 ||
+    let mlist =
+      try (meta_fvalue clenv.env mv1).freemetas
+      with Anomaly _ | Not_found -> Metaset.empty in
+    meta_exists menrec mlist
+  in menrec
+
+let clenv_defined clenv mv = meta_defined clenv.env mv
+
+let error_incompatible_inst clenv mv  =
+  let na = meta_name clenv.env mv in
+  match na with
+      Name id ->
+        errorlabstrm "clenv_assign"
+          (str "An incompatible instantiation has already been found for " ++ 
+           pr_id id)
+    | _ ->
+        anomaly "clenv_assign: non dependent metavar already assigned"
+
+(* TODO: replace by clenv_unify (mkMeta mv) rhs ? *)		      
+let clenv_assign mv rhs clenv =
+  let rhs_fls = mk_freelisted rhs in 
+  if meta_exists (mentions clenv mv) rhs_fls.freemetas then
+    error "clenv_assign: circularity in unification";
+  try
+    if meta_defined clenv.env mv then
+      if not (eq_constr (meta_fvalue clenv.env mv).rebus rhs) then
+        error_incompatible_inst clenv mv
+      else
+	clenv
+    else {clenv with env = meta_assign mv rhs_fls.rebus clenv.env}
+  with Not_found -> 
+    error "clenv_assign: undefined meta"
+
+
+let clenv_wtactic f clenv = {clenv with env = f clenv.env }
+
+
+(* [clenv_dependent hyps_only clenv]
+ * returns a list of the metavars which appear in the template of clenv,
+ * and which are dependent, This is computed by taking the metavars in cval,
+ * in right-to-left order, and collecting the metavars which appear
+ * in their types, and adding in all the metavars appearing in the
+ * type of clenv.
+ * If [hyps_only] then metavariables occurring in the type are _excluded_ *)
+
+(* collects all metavar occurences, in left-to-right order, preserving
+ * repetitions and all. *)
+
+let collect_metas c = 
+  let rec collrec acc c =
+    match kind_of_term c with
+      | Meta mv -> mv::acc
+      | _         -> fold_constr collrec acc c
+  in
+  List.rev (collrec [] c)
+
+(* [clenv_metavars clenv mv]
+ * returns a list of the metavars which appear in the type of
+ * the metavar mv.  The list is unordered. *)
+
+let clenv_metavars clenv mv = (meta_ftype clenv mv).freemetas
+
+let dependent_metas clenv mvs conclmetas =
+  List.fold_right
+    (fun mv deps ->
+       Metaset.union deps (clenv_metavars clenv.env mv))
+    mvs conclmetas
+
+let clenv_dependent hyps_only clenv =
+  let mvs = collect_metas (clenv_value clenv) in
+  let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in
+  let deps = dependent_metas clenv mvs ctyp_mvs in
+  List.filter
+    (fun mv -> Metaset.mem mv deps &&
+               not (hyps_only && Metaset.mem mv ctyp_mvs))
+    mvs
+
+let clenv_missing ce = clenv_dependent true ce
+
+(******************************************************************)
+
+let clenv_unify allow_K cv_pb t1 t2 clenv =
+  { clenv with env = w_unify allow_K clenv.templenv cv_pb t1 t2 clenv.env }
+
+let clenv_unique_resolver allow_K clause gl =
+  clenv_unify allow_K CUMUL (clenv_type clause) (pf_concl gl) clause 
+
+
+(* [clenv_pose_dependent_evars clenv]
+ * For each dependent evar in the clause-env which does not have a value,
+ * pose a value for it by constructing a fresh evar.  We do this in
+ * left-to-right order, so that every evar's type is always closed w.r.t.
+ * metas. *)
+let clenv_pose_dependent_evars clenv =
+  let dep_mvs = clenv_dependent false clenv in
+  List.fold_left
+    (fun clenv mv ->
+      let ty = clenv_meta_type clenv mv in
+      let (evd,evar) = new_evar clenv.env (cl_env clenv) ty in
+      clenv_assign mv evar {clenv with env=evd})
+    clenv
+    dep_mvs
+
+let evar_clenv_unique_resolver clenv gls =
+  clenv_pose_dependent_evars (clenv_unique_resolver false clenv gls)
+
+
+(******************************************************************)
+
+let connect_clenv gls clenv =
+  { clenv with
+    env = evars_reset_evd gls.sigma clenv.env;
+    templenv = Global.env_of_context gls.it.evar_hyps }
+
+(* [clenv_fchain mv clenv clenv']
+ *
+ * Resolves the value of "mv" (which must be undefined) in clenv to be
+ * the template of clenv' be the value "c", applied to "n" fresh
+ * metavars, whose types are chosen by destructing "clf", which should
+ * be a clausale forme generated from the type of "c".  The process of
+ * resolution can cause unification of already-existing metavars, and
+ * of the fresh ones which get created.  This operation is a composite
+ * of operations which pose new metavars, perform unification on
+ * terms, and make bindings. 
+
+   Otherwise said, from 
+
+     [clenv] = [env;sigma;metas |- c:T]
+     [clenv'] = [env';sigma';metas' |- d:U]
+     [mv] = [mi] of type [Ti] in [metas]
+
+   then, if the unification of [Ti] and [U] produces map [rho], the
+   chaining is [env';sigma';rho'(metas),rho(metas') |- c:rho'(T)] for
+   [rho'] being [rho;mi:=d].
+
+   In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma].
+*)
+let clenv_fchain mv clenv nextclenv =
+  (* Add the metavars of [nextclenv] to [clenv], with their name-environment *)
+  let clenv' =
+    { templval = clenv.templval;
+      templtyp = clenv.templtyp;
+      env = meta_merge clenv.env nextclenv.env;
+      templenv = nextclenv.templenv } in
+  (* unify the type of the template of [nextclenv] with the type of [mv] *)
+  let clenv'' =
+    clenv_unify true CUMUL
+      (clenv_nf_meta clenv' nextclenv.templtyp.rebus)
+      (clenv_meta_type clenv' mv)
+      clenv' in
+  (* assign the metavar *)
+  let clenv''' =
+    clenv_assign mv (clenv_nf_meta clenv' nextclenv.templval.rebus) clenv''
+  in 
+  clenv'''
+
+(***************************************************************)
+(* Bindings *)
+
+type arg_bindings = (int * constr) list
+
+(* [clenv_independent clenv]
+ * returns a list of metavariables which appear in the term cval,
+ * and which are not dependent.  That is, they do not appear in
+ * the types of other metavars which are in cval, nor in the type
+ * of cval, ctyp. *)
+
+let clenv_independent clenv =
+  let mvs = collect_metas (clenv_value clenv) in
+  let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in
+  let deps = dependent_metas clenv mvs ctyp_mvs in
+  List.filter (fun mv -> not (Metaset.mem mv deps)) mvs
+
+let meta_of_binder clause loc b t mvs =
+  match b with
+    | NamedHyp s ->
+	if List.exists (fun (_,b',_) -> b=b') t then 
+	  errorlabstrm "clenv_match_args" 
+	    (str "The variable " ++ pr_id s ++ 
+	     str " occurs more than once in binding");
+        meta_with_name clause.env s
+    | AnonHyp n ->
+	if List.exists (fun (_,b',_) -> b=b') t then
+	  errorlabstrm "clenv_match_args"
+	    (str "The position " ++ int n ++
+	    str " occurs more than once in binding");
+	try List.nth mvs (n-1)
+	with (Failure _|Invalid_argument _) ->
+          errorlabstrm "clenv_match_args" (str "No such binder")
+
+let error_already_defined b =
+  match b with
+      NamedHyp id ->
+        errorlabstrm "clenv_match_args"
+          (str "Binder name \"" ++ pr_id id ++
+           str"\" already defined with incompatible value")
+    | AnonHyp n ->
+        anomalylabstrm "clenv_match_args"
+          (str "Position " ++ int n ++ str" already defined")
+
+let clenv_match_args s clause =
+  let mvs = clenv_independent clause in 
+  let rec matchrec clause = function
+    | [] -> clause
+    | (loc,b,c)::t ->
+	let k = meta_of_binder clause loc b t mvs in
+        if meta_defined clause.env k then
+          if eq_constr (meta_fvalue clause.env k).rebus c then
+            matchrec clause t
+          else error_already_defined b
+        else
+	  let k_typ = clenv_hnf_constr clause (clenv_meta_type clause k)
+	    (* nf_betaiota was before in type_of - useful to reduce
+               types like (x:A)([x]P u) *)
+	  and c_typ =
+            clenv_hnf_constr clause
+              (nf_betaiota (clenv_get_type_of clause c)) in
+	  let cl =
+	    (* Try to infer some Meta/Evar from the type of [c] *)
+	    try clenv_assign k c (clenv_unify true CUMUL c_typ k_typ clause)
+	    with e when precatchable_exception e ->
+	      (* Try to coerce to the type of [k]; cannot merge with the
+	         previous case because Coercion does not handle Meta *)
+              let (_,c') = w_coerce (cl_env clause) c c_typ k_typ clause.env in
+	      try clenv_unify true CONV (mkMeta k) c' clause
+	      with PretypeError (env,CannotUnify (m,n)) ->
+	        Stdpp.raise_with_loc loc
+ 	          (PretypeError (env,CannotUnifyBindingType (m,n)))
+	  in matchrec cl t
+  in 
+  matchrec clause s
+
+
+let clenv_constrain_with_bindings bl clause =
+  if bl = [] then 
+    clause 
+  else 
+    let all_mvs = collect_metas clause.templval.rebus in
+    let rec matchrec clause = function
+      | []       -> clause
+      | (n,c)::t ->
+          let k = 
+            (try
+              if n > 0 then 
+		List.nth all_mvs (n-1)
+              else if n < 0 then 
+		List.nth (List.rev all_mvs) (-n-1)
+              else error "clenv_constrain_with_bindings" 
+            with Failure _ ->
+              errorlabstrm "clenv_constrain_with_bindings"
+                (str"Clause did not have " ++ int n ++ str"-th" ++
+                str" absolute argument")) in
+	  let k_typ = nf_betaiota (clenv_meta_type clause k) in
+	  let c_typ = nf_betaiota (clenv_get_type_of clause c) in 
+	  matchrec
+            (clenv_assign k c (clenv_unify true CUMUL c_typ k_typ clause)) t
+    in 
+    matchrec clause bl
+
+
+(* not exported: maybe useful ? *)
+let clenv_constrain_dep_args hyps_only clause = function
+  | [] -> clause 
+  | mlist ->
+      let occlist = clenv_dependent hyps_only clause in
+      if List.length occlist = List.length mlist then
+	List.fold_left2
+          (fun clenv k c ->
+	    try
+	      let k_typ =
+                clenv_hnf_constr clause (clenv_meta_type clause k) in
+	      let c_typ =
+                clenv_hnf_constr clause (clenv_get_type_of clause c) in
+              (* faire quelque chose avec le sigma retourne ? *)
+	      let (_,c') = w_coerce (cl_env clenv) c c_typ k_typ clenv.env in
+	      clenv_unify true CONV (mkMeta k) c' clenv
+	    with _ ->
+              clenv_unify true CONV (mkMeta k) c clenv)
+          clause occlist mlist
+      else 
+	error ("Not the right number of missing arguments (expected "
+	       ^(string_of_int (List.length occlist))^")")
+
+let clenv_constrain_missing_args mlist clause =
+  clenv_constrain_dep_args true clause mlist
+
+
+(****************************************************************)
+(* Clausal environment for an application *)
+
+let make_clenv_binding_gen hyps_only n gls (c,t) = function
+  | ImplicitBindings largs ->
+      let clause = mk_clenv_from_n gls n (c,t) in
+      clenv_constrain_dep_args hyps_only clause largs
+  | ExplicitBindings lbind ->
+      let clause = mk_clenv_rename_from_n gls n (c,t) in
+      clenv_match_args lbind clause
+  | NoBindings ->
+      mk_clenv_from_n gls n (c,t)
+
+let make_clenv_binding_apply gls n = make_clenv_binding_gen true n gls
+let make_clenv_binding = make_clenv_binding_gen false None
+
+(****************************************************************)
+(* Pretty-print *)
+
+let pr_clenv clenv =
+  h 0
+    (str"TEMPL: " ++ print_constr clenv.templval.rebus ++
+     str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++
+     pr_evar_defs clenv.env)
diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli
new file mode 100644
index 00000000..b5433cac
--- /dev/null
+++ b/pretyping/clenv.mli
@@ -0,0 +1,135 @@
+(************************************************************************)
+(*  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: clenv.mli 9277 2006-10-25 13:02:22Z herbelin $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Evd
+open Evarutil
+open Mod_subst
+open Rawterm
+(*i*)
+
+(***************************************************************)
+(* The Type of Constructions clausale environments. *)
+
+(* [templenv] is the typing context
+ * [env] is the mapping from metavar and evar numbers to their types
+ *       and values.
+ * [templval] is the template which we are trying to fill out.
+ * [templtyp] is its type.
+ * [namenv] is a mapping from metavar numbers to names, for
+ *          use in instantiating metavars by name.
+ *)
+type clausenv = {
+  templenv : env;
+  env      : evar_defs;
+  templval : constr freelisted;
+  templtyp : constr freelisted }
+
+(* Substitution is not applied on templenv (because [subst_clenv] is
+   applied only on hints which typing env is overwritten by the
+   goal env) *)
+val subst_clenv : substitution -> clausenv -> clausenv
+
+(* subject of clenv (instantiated) *)
+val clenv_value     : clausenv -> constr
+(* type of clenv (instantiated) *)
+val clenv_type      : clausenv -> types
+(* substitute resolved metas *)
+val clenv_nf_meta   : clausenv -> constr -> constr
+(* type of a meta in clenv context *)
+val clenv_meta_type : clausenv -> metavariable -> types
+
+val mk_clenv_from : evar_info sigma -> constr * types -> clausenv
+val mk_clenv_from_n :
+  evar_info sigma -> int option -> constr * types -> clausenv
+val mk_clenv_rename_from : evar_info sigma -> constr * types -> clausenv
+val mk_clenv_rename_from_n :
+  evar_info sigma -> int option -> constr * types -> clausenv
+val mk_clenv_type_of : evar_info sigma -> constr -> clausenv
+
+(***************************************************************)
+(* linking of clenvs *)
+
+val connect_clenv : evar_info sigma -> clausenv -> clausenv
+val clenv_fchain : metavariable -> clausenv -> clausenv -> clausenv
+
+(***************************************************************)
+(* Unification with clenvs *)
+
+(* Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *)
+val clenv_unify : 
+  bool -> conv_pb -> constr -> constr -> clausenv -> clausenv
+
+(* unifies the concl of the goal with the type of the clenv *)
+val clenv_unique_resolver :
+  bool -> clausenv -> evar_info sigma -> clausenv
+
+(* same as above ([allow_K=false]) but replaces remaining metas
+   with fresh evars *)
+val evar_clenv_unique_resolver :
+  clausenv -> evar_info sigma -> clausenv
+
+(***************************************************************)
+(* Bindings *)
+
+(* bindings where the key is the position in the template of the
+   clenv (dependent or not). Positions can be negative meaning to
+   start from the rightmost argument of the template. *)
+type arg_bindings = (int * constr) list
+
+val clenv_independent : clausenv -> metavariable list
+val clenv_missing : clausenv -> metavariable list
+
+(* defines metas corresponding to the name of the bindings *)
+val clenv_match_args :
+  constr explicit_bindings -> clausenv -> clausenv
+val clenv_constrain_with_bindings : arg_bindings -> clausenv -> clausenv
+
+(* start with a clenv to refine with a given term with bindings *)
+
+(* the arity of the lemma is fixed *)
+(* the optional int tells how many prods of the lemma have to be used *)
+(* use all of them if None *)
+val make_clenv_binding_apply :
+  evar_info sigma -> int option -> constr * constr -> constr bindings ->
+   clausenv
+val make_clenv_binding :
+  evar_info sigma -> constr * constr -> constr bindings -> clausenv
+
+(* [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where
+   [lmetas] is a list of metas to be applied to a proof of [t] so that
+   it produces the unification pattern [ccl]; [sigma'] is [sigma]
+   extended with [lmetas]; if [n] is defined, it limits the size of
+   the list even if [ccl] is still a product; otherwise, it stops when
+   [ccl] is not a product; example: if [t] is [forall x y, x=y -> y=x]
+   and [n] is [None], then [lmetas] is [Meta n1;Meta n2;Meta n3] and
+   [ccl] is [Meta n1=Meta n2]; if [n] is [Some 1], [lmetas] is [Meta n1]
+   and [ccl] is [forall y, Meta n1=y -> y=Meta n1] *)
+val clenv_environments :
+ evar_defs -> int option -> types -> evar_defs * constr list * types
+
+(* [clenv_environments_evars env sigma n t] does the same but returns
+   a list of Evar's defined in [env] and extends [sigma] accordingly *)
+val clenv_environments_evars :
+ env -> evar_defs -> int option -> types -> evar_defs * constr list * types
+
+(* if the clause is a product, add an extra meta for this product *)
+exception NotExtensibleClause
+val clenv_push_prod : clausenv -> clausenv
+
+(***************************************************************)
+(* Pretty-print *)
+val pr_clenv : clausenv -> Pp.std_ppcmds
+
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index be78eb2c..cc74b0ad 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(* $Id: coercion.ml,v 1.38.6.2 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: coercion.ml 9257 2006-10-21 17:28:28Z herbelin $ *)
 
 open Util
 open Names
@@ -19,189 +19,266 @@ open Recordops
 open Evarutil
 open Evarconv
 open Retyping
+open Evd
+open Termops
 
-(* Typing operations dealing with coercions *)
-
-let class_of1 env sigma t = class_of env sigma (nf_evar sigma t)
-
-(* Here, funj is a coercion therefore already typed in global context *)
-let apply_coercion_args env argl funj =
-  let rec apply_rec acc typ = function
-    | [] -> { uj_val = applist (j_val funj,argl);
-              uj_type = typ }
-    | h::restl ->
-    (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
-  	match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
-	  | Prod (_,c1,c2) -> 
-              (* Typage garanti par l'appel à app_coercion*)
-	      apply_rec (h::acc) (subst1 h c2) restl
-	  | _ -> anomaly "apply_coercion_args"
-  in 
-  apply_rec [] funj.uj_type argl
-
-exception NoCoercion
-
-(* appliquer le chemin de coercions de patterns p *)
-
-let apply_pattern_coercion loc pat p =
-  List.fold_left
-    (fun pat (co,n) ->
-       let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
-       Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
-    pat p
-
-(* raise Not_found if no coercion found *)
-let inh_pattern_coerce_to loc pat ind1 ind2 =
-  let i1 = inductive_class_of ind1 in
-  let i2 = inductive_class_of ind2 in
-  let p = lookup_pattern_path_between (i1,i2) in
-  apply_pattern_coercion loc pat p
-
-(* appliquer le chemin de coercions p à hj *)
-
-let apply_coercion env p hj typ_cl =
-  try 
-    fst (List.fold_left
-           (fun (ja,typ_cl) i -> 
-              let fv,isid = coercion_value i in
-              let argl = (class_args_of typ_cl)@[ja.uj_val] in
-              let jres = apply_coercion_args env argl fv in
-              (if isid then 
-		 { uj_val = ja.uj_val; uj_type = jres.uj_type }
-               else 
-		 jres),
-	      jres.uj_type)
-           (hj,typ_cl) p)
-  with _ -> anomaly "apply_coercion"
-
-let inh_app_fun env isevars j = 
-  let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
-  match kind_of_term t with
-    | Prod (_,_,_) -> j
-    | Evar ev when not (is_defined_evar isevars ev) ->
-	let t = define_evar_as_arrow isevars ev in
-	{ uj_val = j.uj_val; uj_type = t }
-    | _ ->
-       	(try
- 	   let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
-      	   let p = lookup_path_to_fun_from i1 in
-           apply_coercion env p j t
-	 with Not_found -> j)
-
-let inh_tosort_force env isevars j =
-  try
-    let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
-    let p = lookup_path_to_sort_from i1 in
-    apply_coercion env p j t 
-  with Not_found -> 
-    j
-
-let inh_coerce_to_sort env isevars j =
-  let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
-  match kind_of_term typ with
-    | Sort s -> { utj_val = j.uj_val; utj_type = s }
-    | Evar ev when not (is_defined_evar isevars ev) ->
-	let s = define_evar_as_sort isevars ev in
-	{ utj_val = j.uj_val; utj_type = s }
-    | _ ->
-        let j1 = inh_tosort_force env isevars j in 
-	type_judgment env (j_nf_evar (evars_of isevars) j1) 
-
-let inh_coerce_to_fail env isevars c1 hj =
-  let hj' =
-    try 
-      let t1,i1 = class_of1 env (evars_of isevars) c1 in
-      let t2,i2 = class_of1 env (evars_of isevars) hj.uj_type in
-      let p = lookup_path_between (i2,i1) in
-      apply_coercion env p hj t2
-    with Not_found -> raise NoCoercion 
-  in
-  if the_conv_x_leq env isevars hj'.uj_type c1 then 
-    hj'
-  else
-    raise NoCoercion
-
-let rec inh_conv_coerce_to_fail env isevars hj c1 =
-  let {uj_val = v; uj_type = t} = hj in
-  if the_conv_x_leq env isevars t c1 then hj
-  else 
-    try 
-      inh_coerce_to_fail env isevars c1 hj
-    with NoCoercion ->  (* try ... with _ -> ... is BAD *)
-      (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
-	     kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with
-	 | Prod (_,t1,t2), Prod (name,u1,u2) -> 
-             let v' = whd_betadeltaiota env (evars_of isevars) v in
-             if (match kind_of_term v' with
-                   | Lambda (_,v1,v2) ->
-                       the_conv_x env isevars v1 u1 (* leq v1 u1? *)
-                   | _  -> false)
-             then 
-	       let (x,v1,v2) = destLambda v' in
-               let env1 = push_rel (x,None,v1) env in
-               let h2 = inh_conv_coerce_to_fail env1 isevars 
-			  {uj_val = v2; uj_type = t2 } u2 in
-               { uj_val = mkLambda (x, v1, h2.uj_val);
-                 uj_type = mkProd (x, v1, h2.uj_type) }
-             else 
-               (* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
-               (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
-               (* has type (name:u1)u2 (with v' recursively obtained) *)
-               let name = (match name with 
-			     | Anonymous -> Name (id_of_string "x")
-                             | _ -> name) in
-               let env1 = push_rel (name,None,u1) env in
-               let h1 =
-		 inh_conv_coerce_to_fail env1 isevars
-		   {uj_val = mkRel 1; uj_type = (lift 1 u1) }
-                   (lift 1 t1) in
-               let h2 = inh_conv_coerce_to_fail env1 isevars
-			 { uj_val = mkApp (lift 1 v, [|h1.uj_val|]);
-                           uj_type = subst1 h1.uj_val t2 }
-                          u2
-	       in
-               { uj_val = mkLambda (name, u1, h2.uj_val);
-                 uj_type = mkProd (name, u1, h2.uj_type) }
-	 | _ -> raise NoCoercion)
+module type S = sig
+  (*s Coercions. *)
+  
+  (* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
+     inserts a coercion into [j], if needed, in such a way it gets as
+     type a product; it returns [j] if no coercion is applicable *)
+  val inh_app_fun :
+    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
+    
+  (* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
+     inserts a coercion into [j], if needed, in such a way it gets as
+     type a sort; it fails if no coercion is applicable *)
+  val inh_coerce_to_sort : loc ->
+    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_type_judgment
+
+  (* [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
+     inserts a coercion into [j], if needed, in such a way it gets as
+     type its base type (the notion depends on the coercion system) *)
+  val inh_coerce_to_base : loc ->
+    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
+    
+  (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type 
+     [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
+     [j.uj_type] are convertible; it fails if no coercion is applicable *)
+  val inh_conv_coerce_to : loc -> 
+    env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
+    
+
+  (* [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
+     is coercible to an object of type [t'] adding evar constraints if needed;
+     it fails if no coercion exists *)
+  val inh_conv_coerces_to : loc -> 
+    env -> evar_defs -> types -> type_constraint_type -> evar_defs
+
+  (* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
+     pattern [pat] typed in [ind1] into a pattern typed in [ind2];
+     raises [Not_found] if no coercion found *)
+  val inh_pattern_coerce_to :
+    loc  -> Rawterm.cases_pattern -> inductive -> inductive -> Rawterm.cases_pattern
+end
+
+module Default = struct
+  (* Typing operations dealing with coercions *)
+  exception NoCoercion
+
+  let whd_app_evar sigma t =
+    match kind_of_term t with
+      | App (f,l) -> mkApp (whd_evar sigma f,l)
+      | _ -> whd_evar sigma t
+
+  let class_of1 env isevars t =
+    let sigma = evars_of isevars in
+    class_of env sigma (whd_app_evar sigma t)
+
+  (* Here, funj is a coercion therefore already typed in global context *)
+  let apply_coercion_args env argl funj =
+    let rec apply_rec acc typ = function
+      | [] -> { uj_val = applist (j_val funj,argl);
+		uj_type = typ }
+      | h::restl ->
+	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
+  	  match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
+	    | Prod (_,c1,c2) -> 
+		(* Typage garanti par l'appel à app_coercion*)
+		apply_rec (h::acc) (subst1 h c2) restl
+	    | _ -> anomaly "apply_coercion_args"
+    in 
+      apply_rec [] funj.uj_type argl
+
+  (* appliquer le chemin de coercions de patterns p *)
+  let apply_pattern_coercion loc pat p =
+    List.fold_left
+      (fun pat (co,n) ->
+	 let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
+	   Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
+      pat p
 
-(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
-let inh_conv_coerce_to loc env isevars cj t =
-  let cj' = 
+  (* raise Not_found if no coercion found *)
+  let inh_pattern_coerce_to loc pat ind1 ind2 =
+    let i1 = inductive_class_of ind1 in
+    let i2 = inductive_class_of ind2 in
+    let p = lookup_pattern_path_between (i1,i2) in
+      apply_pattern_coercion loc pat p
+
+  (* appliquer le chemin de coercions p à hj *)
+  let apply_coercion env p hj typ_cl =
     try 
-      inh_conv_coerce_to_fail env isevars cj t
+      fst (List.fold_left
+             (fun (ja,typ_cl) i -> 
+		let fv,isid = coercion_value i in
+		let argl = (class_args_of typ_cl)@[ja.uj_val] in
+		let jres = apply_coercion_args env argl fv in
+		  (if isid then 
+		     { uj_val = ja.uj_val; uj_type = jres.uj_type }
+		   else 
+		     jres),
+		jres.uj_type)
+             (hj,typ_cl) p)
+    with _ -> anomaly "apply_coercion"
+
+  let inh_app_fun env isevars j = 
+    let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+      match kind_of_term t with
+	| Prod (_,_,_) -> (isevars,j)
+	| Evar ev ->
+	    let (isevars',t) = define_evar_as_arrow isevars ev in
+	      (isevars',{ uj_val = j.uj_val; uj_type = t })
+	| _ ->
+       	    (try
+ 	       let t,i1 = class_of1 env isevars j.uj_type in
+      	       let p = lookup_path_to_fun_from i1 in
+		 (isevars,apply_coercion env p j t)
+	     with Not_found -> (isevars,j))
+
+  let inh_tosort_force loc env isevars j =
+    try
+      let t,i1 = class_of1 env isevars j.uj_type in
+      let p = lookup_path_to_sort_from i1 in
+      let j1 = apply_coercion env p j t in 
+      let j2 = on_judgment_type (whd_evar (evars_of isevars)) j1 in
+        (isevars,type_judgment env j2)
+    with Not_found ->
+      error_not_a_type_loc loc env (evars_of isevars) j
+
+  let inh_coerce_to_sort loc env isevars j =
+    let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+      match kind_of_term typ with
+	| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
+	| Evar ev when not (is_defined_evar isevars ev) ->
+	    let (isevars',s) = define_evar_as_sort isevars ev in
+	      (isevars',{ utj_val = j.uj_val; utj_type = s })
+	| _ ->
+	    inh_tosort_force loc env isevars j
+
+  let inh_coerce_to_base loc env isevars j = (isevars, j)
+
+  let inh_coerce_to_fail env isevars c1 v t =
+    let v', t' =
+      try 
+	let t1,i1 = class_of1 env isevars c1 in
+	let t2,i2 = class_of1 env isevars t in
+	let p = lookup_path_between (i2,i1) in
+	  match v with
+	      Some v -> 
+		let j = apply_coercion env p {uj_val = v; uj_type = t} t2 in
+		  Some j.uj_val, j.uj_type
+	    | None -> None, t
+      with Not_found -> raise NoCoercion 
+    in
+      try (the_conv_x_leq env t' c1 isevars, v', t')
+      with Reduction.NotConvertible -> raise NoCoercion
+
+  let rec inh_conv_coerce_to_fail loc env isevars v t c1 =
+    try (the_conv_x_leq env t c1 isevars, v, t)
+    with Reduction.NotConvertible ->
+    try inh_coerce_to_fail env isevars c1 v t
     with NoCoercion ->
-      let sigma = evars_of isevars in
-      error_actual_type_loc loc env sigma cj t
-  in
-  { uj_val = cj'.uj_val; uj_type = t }
-
-(* [inh_apply_rel_list loc env isevars args f tycon] tries to type [(f
-   args)] of type [tycon] (if any) by inserting coercions in front of
-   each arg$_i$, if necessary *)
-
-let inh_apply_rel_list apploc env isevars argjl (funloc,funj) tycon =
-  let rec apply_rec env n resj = function
-    | [] -> resj
-    | (loc,hj)::restjl ->
-        let sigma = evars_of isevars in
-	let resj = inh_app_fun env isevars resj in
-        let ntyp = whd_betadeltaiota env sigma resj.uj_type in
-      	match kind_of_term ntyp with
-          | Prod (na,c1,c2) ->
-              let hj' =
+    match
+      kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
+      kind_of_term (whd_betadeltaiota env (evars_of isevars) c1)
+    with
+    | Prod (_,t1,t2), Prod (name,u1,u2) -> 
+	let v' = option_map (whd_betadeltaiota env (evars_of isevars)) v in
+	let (evd',b) =
+	  match v' with 
+	  | Some v' ->
+	      (match kind_of_term v' with
+	       | Lambda (x,v1,v2) ->
+		   (* sous-typage non contravariant: pas de "leq v1 u1" *)
+		   (try the_conv_x env v1 u1 isevars, Some (x, v1, v2)
+		   with Reduction.NotConvertible -> (isevars, None))
+	       | _  -> (isevars, None))
+	  | None -> (isevars, None)
+	in
+	(match b with
+	 | Some (x, v1, v2) ->
+	     let env1 = push_rel (x,None,v1) env in
+	     let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd'
+	       (Some v2) t2 u2 in
+	     (evd'', option_map (fun v2' -> mkLambda (x, v1, v2')) v2', 
+	     mkProd (x, v1, t2'))
+	 | None ->
+	     (* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
+	     (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
+	     (* has type (name:u1)u2 (with v' recursively obtained) *)
+	     let name = match name with 
+	       | Anonymous -> Name (id_of_string "x")
+	       | _ -> name
+	     in
+	     let env1 = push_rel (name,None,u1) env in
+	     let (evd', v1', t1') =
+	       inh_conv_coerce_to_fail loc env1 isevars
+		 (Some (mkRel 1)) (lift 1 u1) (lift 1 t1)
+	     in
+	     let (evd'', v2', t2') = 
+	       let v2 =
+		 match v with 
+		 | Some v -> option_map (fun x -> mkApp(lift 1 v,[|x|])) v1'
+		 | None -> None
+	       and evd', t2 =
+		 match v1' with 
+		 | Some v1' -> evd', subst_term v1' t2
+		 | None -> 
+		     let evd', ev =
+		       new_evar evd' env ~src:(loc, InternalHole) t1' in
+		     evd', subst_term ev t2
+	       in
+	       inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2
+	     in
+	     (evd'', option_map (fun v2' -> mkLambda (name, u1, v2')) v2',
+	     mkProd (name, u1, t2')))
+    | _ -> raise NoCoercion
+
+  (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
+  let inh_conv_coerce_to loc env isevars cj (n, t) =
+    match n with
+	None ->
+	  let (evd', val', type') = 
+	    try 
+	      inh_conv_coerce_to_fail loc env isevars (Some cj.uj_val) cj.uj_type t
+	    with NoCoercion ->
+	      let sigma = evars_of isevars in
+		error_actual_type_loc loc env sigma cj t
+	  in
+	  let val' = match val' with Some v -> v | None -> assert(false) in
+	    (evd',{ uj_val = val'; uj_type = t })
+      | Some (init, cur) -> (isevars, cj)
+      
+    let inh_conv_coerces_to loc env (isevars : evar_defs) t (abs, t') = isevars
+      (* Still problematic, as it changes unification 
+      let nabsinit, nabs = 
+	match abs with
+	    None -> 0, 0
+	  | Some (init, cur) -> init, cur
+      in
+	try 
+	  let (rels, rng) = 
+	    (* a little more effort to get products is needed *) 
+	    try decompose_prod_n nabs t
+	    with _ -> 
+	      if !Options.debug then
+		msg_warning (str "decompose_prod_n failed");
+	      raise (Invalid_argument "Coercion.inh_conv_coerces_to")
+	  in
+	    (* The final range free variables must have been replaced by evars, we accept only that evars
+	       in rng are applied to free vars. *)
+	    if noccur_with_meta 0 (succ nabsinit) rng then (
+	      let env', t, t' = 
+		let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in
+		  env', rng, lift nabs t'
+	      in
 		try 
-		  inh_conv_coerce_to_fail env isevars hj c1
+		  pi1 (inh_conv_coerce_to_fail loc env' isevars None t t')
 		with NoCoercion ->
-                  error_cant_apply_bad_type_loc apploc env sigma
-		    (1,c1,hj.uj_type) resj (List.map snd restjl) in
-	      let newresj =
-      		{ uj_val = applist (j_val resj, [j_val hj']);
-		  uj_type = subst1 hj'.uj_val c2 } in
-	      apply_rec (push_rel (na,None,c1) env) (n+1) newresj restjl
-          | _ ->
-              error_cant_apply_not_functional_loc 
-		(join_loc funloc loc) env sigma resj
-                (List.map snd restjl)
-  in 
-  apply_rec env 1 funj argjl
-
+		  isevars) (* Maybe not enough information to unify *)
+	      (*let sigma = evars_of isevars in
+		error_cannot_coerce env' sigma (t, t'))*)
+	    else isevars
+	with Invalid_argument _ -> isevars	  *)
+end
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index 658844eb..42ce27fd 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coercion.mli,v 1.20.14.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: coercion.mli 8875 2006-05-29 19:59:11Z msozeau $ i*)
 
 (*i*)
 open Util
@@ -19,28 +19,44 @@ open Evarutil
 open Rawterm
 (*i*)
 
-(*s Coercions. *)
+module type S = sig
+  (*s Coercions. *)
+  
+  (* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
+     inserts a coercion into [j], if needed, in such a way it gets as
+     type a product; it returns [j] if no coercion is applicable *)
+  val inh_app_fun :
+    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
+    
+  (* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
+     inserts a coercion into [j], if needed, in such a way it gets as
+     type a sort; it fails if no coercion is applicable *)
+  val inh_coerce_to_sort : loc ->
+    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_type_judgment
 
-(* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
-   inserts a coercion into [j], if needed, in such a way it gets as
-   type a product; it returns [j] if no coercion is applicable *)
-val inh_app_fun :
-  env -> evar_defs -> unsafe_judgment -> unsafe_judgment
+  (* [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
+     inserts a coercion into [j], if needed, in such a way it gets as
+     type its base type (the notion depends on the coercion system) *)
+  val inh_coerce_to_base : loc ->
+    env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
+    
+  (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type 
+     [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
+     [j.uj_type] are convertible; it fails if no coercion is applicable *)
+  val inh_conv_coerce_to : loc -> 
+    env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
+    
+  (* [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
+     is coercible to an object of type [t'] adding evar constraints if needed;
+     it fails if no coercion exists *)
+  val inh_conv_coerces_to : loc -> 
+    env -> evar_defs -> types -> type_constraint_type -> evar_defs
+   
+  (* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
+     pattern [pat] typed in [ind1] into a pattern typed in [ind2];
+     raises [Not_found] if no coercion found *)
+  val inh_pattern_coerce_to :
+    loc  -> cases_pattern -> inductive -> inductive -> cases_pattern
+end
 
-(* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
-   inserts a coercion into [j], if needed, in such a way it gets as
-   type a sort; it fails if no coercion is applicable *)
-val inh_coerce_to_sort :
-  env -> evar_defs -> unsafe_judgment -> unsafe_type_judgment
-
-(* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type 
-   [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
-   [j.uj_type] are convertible; it fails if no coercion is applicable *)
-val inh_conv_coerce_to : loc -> 
-  env -> evar_defs -> unsafe_judgment -> constr -> unsafe_judgment
-
-(* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
-   pattern [pat] typed in [ind1] into a pattern typed in [ind2];
-   raises [Not_found] if no coercion found *)
-val inh_pattern_coerce_to :
-  loc  -> cases_pattern -> inductive -> inductive -> cases_pattern
+module Default : S
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 040a185e..ff435bfc 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: detyping.ml,v 1.75.2.5 2005/09/06 14:30:41 herbelin Exp $ *)
+(* $Id: detyping.ml 9535 2007-01-26 09:26:08Z jforest $ *)
 
 open Pp
 open Util
@@ -23,6 +23,10 @@ open Nameops
 open Termops
 open Libnames
 open Nametab
+open Evd
+open Mod_subst
+
+let dl = dummy_loc
 
 (****************************************************************************)
 (* Tools for printing of Cases                                              *)
@@ -130,11 +134,21 @@ let synthetize_type () = !synth_type_value
 
 let _ = declare_bool_option 
 	  { optsync  = true;
-	    optname  = "synthesizability";
+	    optname  = "pattern matching return type synthesizability";
 	    optkey   = SecondaryTable ("Printing","Synth");
 	    optread  = synthetize_type;
 	    optwrite = (:=) synth_type_value }
 
+let reverse_matching_value = ref true
+let reverse_matching () = !reverse_matching_value
+
+let _ = declare_bool_option 
+	  { optsync  = true;
+	    optname  = "pattern-matching reversibility";
+	    optkey   = SecondaryTable ("Printing","Matching");
+	    optread  = reverse_matching;
+	    optwrite = (:=) reverse_matching_value }
+
 (* Auxiliary function for MutCase printing *)
 (* [computable] tries to tell if the predicate typing the result is inferable*)
 
@@ -175,7 +189,7 @@ let lookup_name_as_renamed env t s =
 	       if id=s then (Some n) 
 	       else lookup avoid' (add_name (Name id) env_names) (n+1) c'
 	   | (Anonymous,avoid')    -> lookup avoid' env_names (n+1) (pop c'))
-    | Cast (c,_) -> lookup avoid env_names n c
+    | Cast (c,_,_) -> lookup avoid env_names n c
     | _ -> None
   in lookup (ids_of_named_context (named_context env)) empty_names_context 1 t
 
@@ -189,10 +203,65 @@ let lookup_index_as_renamed env t n =
 	  (match concrete_name true [] empty_names_context name c' with
              | (Name _,_) -> lookup n (d+1) c'
              | (Anonymous,_) -> if n=1 then Some d else lookup (n-1) (d+1) c')
-    | Cast (c,_) -> lookup n d c
+    | Cast (c,_,_) -> lookup n d c
     | _ -> None
   in lookup n 1 t
 
+(**********************************************************************)
+(* Fragile algorithm to reverse pattern-matching compilation          *)
+
+let update_name na ((_,e),c) =
+  match na with
+  | Name _ when force_wildcard () & noccurn (list_index na e) c ->
+      Anonymous
+  | _ ->
+      na
+
+let rec decomp_branch n nal b (avoid,env as e) c =
+  if n=0 then (List.rev nal,(e,c))
+  else
+    let na,c,f =
+      match kind_of_term (strip_outer_cast c) with
+	| Lambda (na,_,c) -> na,c,concrete_let_name
+	| LetIn (na,_,_,c) -> na,c,concrete_name
+	| _ -> 
+	    Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])), 
+	    concrete_name in
+    let na',avoid' = f b avoid env na c in
+    decomp_branch (n-1) (na'::nal) b (avoid',add_name na' env) c
+
+let rec build_tree na isgoal e ci cl =
+  let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name na rhs) in
+  let cnl = ci.ci_cstr_nargs in
+  List.flatten
+    (list_tabulate (fun i -> contract_branch isgoal e (cnl.(i),mkpat i,cl.(i)))
+       (Array.length cl))
+
+and align_tree nal isgoal (e,c as rhs) = match nal with
+  | [] -> [[],rhs]
+  | na::nal ->
+    match kind_of_term c with
+    | Case (ci,_,c,cl) when c = mkRel (list_index na (snd e)) ->
+	let clauses = build_tree na isgoal e ci cl in
+	List.flatten
+          (List.map (fun (pat,rhs) ->
+	      let lines = align_tree nal isgoal rhs in
+	      List.map (fun (hd,rest) -> pat::hd,rest) lines) 
+	    clauses)
+    | _ ->
+	let pat = PatVar(dl,update_name na rhs) in
+	let mat = align_tree nal isgoal rhs in
+	List.map (fun (hd,rest) -> pat::hd,rest) mat
+
+and contract_branch isgoal e (cn,mkpat,b) =
+  let nal,rhs = decomp_branch cn [] isgoal e b in
+  let mat = align_tree nal isgoal rhs in
+  List.map (fun (hd,rhs) -> (mkpat rhs hd,rhs)) mat
+
+(**********************************************************************)
+(* Transform internal representation of pattern-matching into list of *)
+(* clauses                                                            *)
+
 let is_nondep_branch c n =
   try
     let _,ccl = decompose_lam_n_assum n c in
@@ -208,55 +277,48 @@ let extract_nondep_branches test c b n =
       | _ -> assert false in
   if test c n then Some (strip n b) else None
 
-let detype_case computable detype detype_eqn testdep
-    tenv avoid indsp st p k c bl =
+let it_destRLambda_or_LetIn_names n c =
+  let rec aux n nal c =
+    if n=0 then (List.rev nal,c) else match c with
+      | RLambda (_,na,_,c) -> aux (n-1) (na::nal) c
+      | RLetIn (_,na,_,c) -> aux (n-1) (na::nal) c
+      | _ ->
+          (* eta-expansion *)
+	  let rec next l =
+	    let x = Nameops.next_ident_away (id_of_string "x") l in
+	    x
+	  in
+	  let x = next (free_rawvars c) in 
+	  let a = RVar (dl,x) in
+	  aux (n-1) (Name x :: nal) 
+            (match c with
+              | RApp (loc,p,l) -> RApp (loc,c,l@[a])
+              | _ -> (RApp (dl,c,[a])))
+  in aux n [] c
+
+let detype_case computable detype detype_eqns testdep avoid data p c bl =
+  let (indsp,st,nparams,consnargsl,k) = data in
   let synth_type = synthetize_type () in
   let tomatch = detype c in
-
-  (* Find constructors arity *)
-  let (mib,mip) = Inductive.lookup_mind_specif tenv indsp in
-  let get_consnarg j = 
-    let typi = mis_nf_constructor_type (indsp,mib,mip) (j+1) in
-    let _,t = decompose_prod_n_assum (List.length mip.mind_params_ctxt) typi in
-    List.rev (fst (decompose_prod_assum t)) in
-  let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in
-  let consnargsl = Array.map List.length consnargs in
-  let alias, aliastyp, newpred, pred = 
-    if (not !Options.raw_print) & synth_type & computable & bl <> [||] then
-      Anonymous, None, None, None
+  let alias, aliastyp, pred= 
+    if (not !Options.raw_print) & synth_type & computable & Array.length bl<>0 
+    then 
+      Anonymous, None, None
     else
-      let p = option_app detype p in
-      match p with
-        | None -> Anonymous, None, None, None
+      match option_map detype p with
+        | None -> Anonymous, None, None
         | Some p ->
-            let decompose_lam k c =
-              let rec lamdec_rec l avoid k c =
-                if k = 0 then List.rev l,c else match c with
-                  | RLambda (_,x,t,c) -> 
-                      lamdec_rec (x::l) (name_cons x avoid) (k-1) c
-                  | c -> 
-                      let x = next_ident_away (id_of_string "x") avoid in
-                      lamdec_rec ((Name x)::l) (x::avoid) (k-1)
-                        (let a = RVar (dummy_loc,x) in
-                          match c with
-                          | RApp (loc,p,l) -> RApp (loc,p,l@[a])
-                          | _ -> (RApp (dummy_loc,c,[a])))
-              in 
-              lamdec_rec [] [] k c in
-            let nl,typ = decompose_lam k p in
+            let nl,typ = it_destRLambda_or_LetIn_names k p in
 	    let n,typ = match typ with 
               | RLambda (_,x,t,c) -> x, c
 	      | _ -> Anonymous, typ in
 	    let aliastyp =
 	      if List.for_all ((=) Anonymous) nl then None
-	      else 
-		let pars = list_tabulate (fun _ -> Anonymous) mip.mind_nparams
-		in Some (dummy_loc,indsp,pars@nl) in
-            n, aliastyp, Some typ, Some p
+	      else Some (dl,indsp,nparams,nl) in
+            n, aliastyp, Some typ
   in
   let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in
-  let eqnv = array_map3 detype_eqn constructs consnargsl bl in
-  let eqnl = Array.to_list eqnv in
+  let eqnl = detype_eqns constructs consnargsl bl in
   let tag =
     try 
       if !Options.raw_print then
@@ -268,108 +330,78 @@ let detype_case computable detype detype_eqn testdep
       else 
 	st
     with Not_found -> st
-  in 
-  if tag = RegularStyle then
-    RCases (dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl)
-  else
-    let bl' = Array.map detype bl in
-    if not !Options.v7 && tag = LetStyle && aliastyp = None then
-      let rec decomp_lam_force n avoid l p =
-	if n = 0 then (List.rev l,p) else
-          match p with
-            | RLambda (_,na,_,c) -> 
-		decomp_lam_force (n-1) (name_cons na avoid) (na::l) c
-            | RLetIn (_,na,_,c) -> 
-		decomp_lam_force (n-1) (name_cons na avoid) (na::l) c
-            | _ ->
-		let x = Nameops.next_ident_away (id_of_string "x") avoid in
-		decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
-                  (* eta-expansion *)
-                  (let a = RVar (dummy_loc,x) in
-                  match p with
-                    | RApp (loc,p,l) -> RApp (loc,p,l@[a])
-                    | _ -> (RApp (dummy_loc,p,[a]))) in
-      let (nal,d) = decomp_lam_force consnargsl.(0) avoid [] bl'.(0) in
-      RLetTuple (dummy_loc,nal,(alias,newpred),tomatch,d)
-    else
-    let nondepbrs =
-      array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in
-    if not !Options.v7 && tag = IfStyle && aliastyp = None
-      && array_for_all ((<>) None) nondepbrs then
-      RIf (dummy_loc,tomatch,(alias,newpred),
-           out_some nondepbrs.(0),out_some nondepbrs.(1))
-    else if !Options.v7 then
-      let rec remove_type avoid args c =
-	match c,args with
-          | RLambda (loc,na,t,c), _::args ->
-              let h = RHole (dummy_loc,BinderType na) in
-              RLambda (loc,na,h,remove_type avoid args c)
-          | RLetIn (loc,na,b,c), _::args ->
-              RLetIn (loc,na,b,remove_type avoid args c)
-          | c, (na,None,t)::args ->
-              let id = next_name_away_with_default "x" na avoid in
-              let h = RHole (dummy_loc,BinderType na) in
-              let c = remove_type (id::avoid) args
-		(RApp (dummy_loc,c,[RVar (dummy_loc,id)])) in
-              RLambda (dummy_loc,Name id,h,c)
-          | c, (na,Some b,t)::args ->
-              let h = RHole (dummy_loc,BinderType na) in
-              let avoid = name_fold (fun x l -> x::l) na avoid in
-              RLetIn (dummy_loc,na,h,remove_type avoid args c)
-          | c, [] -> c in
-      let bl' = array_map2 (remove_type avoid) consnargs bl' in
-      ROrderedCase (dummy_loc,tag,pred,tomatch,bl',ref None)
-    else
-      RCases(dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl)
-
-
-let rec detype tenv avoid env t =
+  in
+  match tag with
+  | LetStyle when aliastyp = None -> 
+      let bl' = Array.map detype bl in
+      let (nal,d) = it_destRLambda_or_LetIn_names consnargsl.(0) bl'.(0) in
+      RLetTuple (dl,nal,(alias,pred),tomatch,d)
+  | IfStyle when aliastyp = None ->
+      let bl' = Array.map detype bl in
+      let nondepbrs =
+	array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in
+      if array_for_all ((<>) None) nondepbrs then
+	RIf (dl,tomatch,(alias,pred),
+             out_some nondepbrs.(0),out_some nondepbrs.(1))
+      else
+	RCases (dl,pred,[tomatch,(alias,aliastyp)],eqnl)
+  | _ ->
+      RCases (dl,pred,[tomatch,(alias,aliastyp)],eqnl)
+
+let detype_sort = function
+  | Prop c -> RProp c
+  | Type u -> RType (Some u)
+
+(**********************************************************************)
+(* Main detyping function                                             *)
+
+let rec detype isgoal avoid env t =
   match kind_of_term (collapse_appl t) with
     | Rel n ->
       (try match lookup_name_of_rel n env with
-	 | Name id   -> RVar (dummy_loc, id)
+	 | Name id   -> RVar (dl, id)
 	 | Anonymous -> anomaly "detype: index to an anonymous variable"
        with Not_found ->
 	 let s = "_UNBOUND_REL_"^(string_of_int n)
-	 in RVar (dummy_loc, id_of_string s))
+	 in RVar (dl, id_of_string s))
     | Meta n ->
 	(* Meta in constr are not user-parsable and are mapped to Evar *)
-	REvar (dummy_loc, n, None)
+	REvar (dl, n, None)
     | Var id ->
 	(try
-	  let _ = Global.lookup_named id in RRef (dummy_loc, VarRef id)
+	  let _ = Global.lookup_named id in RRef (dl, VarRef id)
 	 with _ ->
-	  RVar (dummy_loc, id))
-    | Sort (Prop c) -> RSort (dummy_loc,RProp c)
-    | Sort (Type u) -> RSort (dummy_loc,RType (Some u))
-    | Cast (c1,c2) ->
-	RCast(dummy_loc,detype tenv avoid env c1,
-              detype tenv avoid env c2)
-    | Prod (na,ty,c) -> detype_binder tenv BProd avoid env na ty c
-    | Lambda (na,ty,c) -> detype_binder tenv BLambda avoid env na ty c
-    | LetIn (na,b,_,c) -> detype_binder tenv BLetIn avoid env na b c
+	  RVar (dl, id))
+    | Sort s -> RSort (dl,detype_sort s)
+    | Cast (c1,k,c2) ->
+	RCast(dl,detype isgoal avoid env c1, CastConv k,
+              detype isgoal avoid env c2)
+    | Prod (na,ty,c) -> detype_binder isgoal BProd avoid env na ty c
+    | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c
+    | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c
     | App (f,args) ->
-	RApp (dummy_loc,detype tenv avoid env f,
-              array_map_to_list (detype tenv avoid env) args)
-    | Const sp -> RRef (dummy_loc, ConstRef sp)
+	RApp (dl,detype isgoal avoid env f,
+              array_map_to_list (detype isgoal avoid env) args)
+    | Const sp -> RRef (dl, ConstRef sp)
     | Evar (ev,cl) ->
-        REvar (dummy_loc, ev, 
-               Some (List.map (detype tenv avoid env) (Array.to_list cl)))
+        REvar (dl, ev, 
+               Some (List.map (detype isgoal avoid env) (Array.to_list cl)))
     | Ind ind_sp ->
-	RRef (dummy_loc, IndRef ind_sp)
+	RRef (dl, IndRef ind_sp)
     | Construct cstr_sp ->
-	RRef (dummy_loc, ConstructRef cstr_sp)
-    | Case (annot,p,c,bl) ->
-	let comp = computable p (annot.ci_pp_info.ind_nargs) in
-	let ind = annot.ci_ind in
-	let st = annot.ci_pp_info.style in
-	detype_case comp (detype tenv avoid env) (detype_eqn tenv avoid env)
-	  is_nondep_branch
-	  (snd tenv) avoid ind st (Some p) annot.ci_pp_info.ind_nargs c bl
-    | Fix (nvn,recdef) -> detype_fix tenv avoid env nvn recdef
-    | CoFix (n,recdef) -> detype_cofix tenv avoid env n recdef
-
-and detype_fix tenv avoid env (vn,_ as nvn) (names,tys,bodies) =
+	RRef (dl, ConstructRef cstr_sp)
+    | Case (ci,p,c,bl) ->
+	let comp = computable p (ci.ci_pp_info.ind_nargs) in
+	detype_case comp (detype isgoal avoid env)
+	  (detype_eqns isgoal avoid env ci comp)
+	  is_nondep_branch avoid 
+	  (ci.ci_ind,ci.ci_pp_info.style,ci.ci_npar,
+	   ci.ci_cstr_nargs,ci.ci_pp_info.ind_nargs)
+	  (Some p) c bl
+    | Fix (nvn,recdef) -> detype_fix isgoal avoid env nvn recdef
+    | CoFix (n,recdef) -> detype_cofix isgoal avoid env n recdef
+
+and detype_fix isgoal avoid env (vn,_ as nvn) (names,tys,bodies) =
   let def_avoid, def_env, lfi =
     Array.fold_left
       (fun (avoid, env, l) na ->
@@ -378,14 +410,14 @@ and detype_fix tenv avoid env (vn,_ as nvn) (names,tys,bodies) =
       (avoid, env, []) names in
   let n = Array.length tys in
   let v = array_map3
-    (fun c t i -> share_names tenv (i+1) [] def_avoid def_env c (lift n t))
+    (fun c t i -> share_names isgoal (i+1) [] def_avoid def_env c (lift n t))
     bodies tys vn in
-  RRec(dummy_loc,RFix nvn,Array.of_list (List.rev lfi),
+  RRec(dl,RFix (Array.map (fun i -> Some i, RStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi),
        Array.map (fun (bl,_,_) -> bl) v,
        Array.map (fun (_,_,ty) -> ty) v,
        Array.map (fun (_,bd,_) -> bd) v)
 
-and detype_cofix tenv avoid env n (names,tys,bodies) =
+and detype_cofix isgoal avoid env n (names,tys,bodies) =
   let def_avoid, def_env, lfi =
     Array.fold_left
       (fun (avoid, env, l) na ->
@@ -394,19 +426,14 @@ and detype_cofix tenv avoid env n (names,tys,bodies) =
       (avoid, env, []) names in
   let ntys = Array.length tys in
   let v = array_map2
-    (fun c t -> share_names tenv 0 [] def_avoid def_env c (lift ntys t))
+    (fun c t -> share_names isgoal 0 [] def_avoid def_env c (lift ntys t))
     bodies tys in
-  RRec(dummy_loc,RCoFix n,Array.of_list (List.rev lfi),
+  RRec(dl,RCoFix n,Array.of_list (List.rev lfi),
        Array.map (fun (bl,_,_) -> bl) v,
        Array.map (fun (_,_,ty) -> ty) v,
        Array.map (fun (_,bd,_) -> bd) v)
 
-and share_names tenv n l avoid env c t =
-  if !Options.v7 && n=0 then
-    let c = detype tenv avoid env c in
-    let t = detype tenv avoid env t in
-    (List.rev l,c,t)
-  else
+and share_names isgoal n l avoid env c t =
   match kind_of_term c, kind_of_term t with
     (* factorize even when not necessary to have better presentation *)
     | Lambda (na,t,c), Prod (na',t',c') ->
@@ -414,47 +441,57 @@ and share_names tenv n l avoid env c t =
             Name _, _ -> na
           | _, Name _ -> na'
           | _ -> na in 
-        let t = detype tenv avoid env t in
+        let t = detype isgoal avoid env t in
 	let id = next_name_away na avoid in 
         let avoid = id::avoid and env = add_name (Name id) env in
-        share_names tenv (n-1) ((Name id,None,t)::l) avoid env c c'
+        share_names isgoal (n-1) ((Name id,None,t)::l) avoid env c c'
     (* May occur for fix built interactively *)
     | LetIn (na,b,t',c), _ when n > 0 ->
-        let t' = detype tenv avoid env t' in
-        let b = detype tenv avoid env b in
+        let t' = detype isgoal avoid env t' in
+        let b = detype isgoal avoid env b in
 	let id = next_name_away na avoid in 
         let avoid = id::avoid and env = add_name (Name id) env in
-        share_names tenv n ((Name id,Some b,t')::l) avoid env c t
+        share_names isgoal n ((Name id,Some b,t')::l) avoid env c t
     (* Only if built with the f/n notation or w/o let-expansion in types *)
     | _, LetIn (_,b,_,t) when n > 0 ->
-	share_names tenv n l avoid env c (subst1 b t)
+	share_names isgoal n l avoid env c (subst1 b t)
     (* If it is an open proof: we cheat and eta-expand *)
     | _, Prod (na',t',c') when n > 0 ->
-        let t' = detype tenv avoid env t' in
+        let t' = detype isgoal avoid env t' in
 	let id = next_name_away na' avoid in 
         let avoid = id::avoid and env = add_name (Name id) env in
         let appc = mkApp (lift 1 c,[|mkRel 1|]) in
-        share_names tenv (n-1) ((Name id,None,t')::l) avoid env appc c'
+        share_names isgoal (n-1) ((Name id,None,t')::l) avoid env appc c'
     (* If built with the f/n notation: we renounce to share names *)
     | _ ->
         if n>0 then warning "Detyping.detype: cannot factorize fix enough";
-        let c = detype tenv avoid env c in
-        let t = detype tenv avoid env t in
+        let c = detype isgoal avoid env c in
+        let t = detype isgoal avoid env t in
         (List.rev l,c,t)
 
-and detype_eqn tenv avoid env constr construct_nargs branch =
+and detype_eqns isgoal avoid env ci computable constructs consnargsl bl =
+  try
+    if !Options.raw_print or not (reverse_matching ()) then raise Exit;
+    let mat = build_tree Anonymous isgoal (avoid,env) ci bl in
+    List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype isgoal avoid env c))
+      mat
+  with _ ->
+    Array.to_list
+      (array_map3 (detype_eqn isgoal avoid env) constructs consnargsl bl)
+
+and detype_eqn isgoal avoid env constr construct_nargs branch =
   let make_pat x avoid env b ids =
     if force_wildcard () & noccurn 1 b then
-      PatVar (dummy_loc,Anonymous),avoid,(add_name Anonymous env),ids
-    else
+      PatVar (dl,Anonymous),avoid,(add_name Anonymous env),ids
+    else 
       let id = next_name_away_with_default "x" x avoid in
-      PatVar (dummy_loc,Name id),id::avoid,(add_name (Name id) env),id::ids
+      PatVar (dl,Name id),id::avoid,(add_name (Name id) env),id::ids
   in
   let rec buildrec ids patlist avoid env n b =
     if n=0 then
-      (dummy_loc, ids, 
-       [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
-       detype tenv avoid env b)
+      (dl, ids, 
+       [PatCstr(dl, constr, List.rev patlist,Anonymous)],
+       detype isgoal avoid env b)
     else
       match kind_of_term b with
 	| Lambda (x,_,b) -> 
@@ -465,7 +502,7 @@ and detype_eqn tenv avoid env constr construct_nargs branch =
 	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in
             buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b
 
-	| Cast (c,_) ->    (* Oui, il y a parfois des cast *)
+	| Cast (c,_,_) ->    (* Oui, il y a parfois des cast *)
 	    buildrec ids patlist avoid env n c
 
 	| _ -> (* eta-expansion : n'arrivera plus lorsque tous les
@@ -479,14 +516,138 @@ and detype_eqn tenv avoid env constr construct_nargs branch =
   in 
   buildrec [] [] avoid env construct_nargs branch
 
-and detype_binder tenv bk avoid env na ty c =
+and detype_binder isgoal bk avoid env na ty c =
   let na',avoid' =
     if bk = BLetIn then
-      concrete_let_name (fst tenv) avoid env na c
+      concrete_let_name isgoal avoid env na c
     else
-      concrete_name (fst tenv) avoid env na c in
-  let r =  detype tenv avoid' (add_name na' env) c in
+      concrete_name isgoal avoid env na c in
+  let r =  detype isgoal avoid' (add_name na' env) c in
   match bk with
-    | BProd -> RProd (dummy_loc, na',detype tenv avoid env ty, r)
-    | BLambda -> RLambda (dummy_loc, na',detype tenv avoid env ty, r)
-    | BLetIn -> RLetIn (dummy_loc, na',detype tenv avoid env ty, r)
+  | BProd -> RProd (dl, na',detype isgoal avoid env ty, r)
+  | BLambda -> RLambda (dl, na',detype isgoal avoid env ty, r)
+  | BLetIn -> RLetIn (dl, na',detype isgoal avoid env ty, r)
+
+(**********************************************************************)
+(* Module substitution: relies on detyping                            *)
+
+let rec subst_cases_pattern subst pat = 
+  match pat with
+  | PatVar _ -> pat
+  | PatCstr (loc,((kn,i),j),cpl,n) -> 
+      let kn' = subst_kn subst kn 
+      and cpl' = list_smartmap (subst_cases_pattern subst) cpl in
+	if kn' == kn && cpl' == cpl then pat else
+	  PatCstr (loc,((kn',i),j),cpl',n)
+
+let rec subst_rawconstr subst raw = 
+  match raw with
+  | RRef (loc,ref) -> 
+      let ref',t = subst_global subst ref in 
+	if ref' == ref then raw else
+         detype false [] [] t
+
+  | RVar _ -> raw
+  | REvar _ -> raw
+  | RPatVar _ -> raw
+
+  | RApp (loc,r,rl) -> 
+      let r' = subst_rawconstr subst r 
+      and rl' = list_smartmap (subst_rawconstr subst) rl in
+	if r' == r && rl' == rl then raw else
+	  RApp(loc,r',rl')
+
+  | RLambda (loc,n,r1,r2) -> 
+      let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  RLambda (loc,n,r1',r2')
+
+  | RProd (loc,n,r1,r2) -> 
+      let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  RProd (loc,n,r1',r2')
+
+  | RLetIn (loc,n,r1,r2) -> 
+      let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  RLetIn (loc,n,r1',r2')
+
+  | RCases (loc,rtno,rl,branches) -> 
+      let rtno' = option_smartmap (subst_rawconstr subst) rtno
+      and rl' = list_smartmap (fun (a,x as y) ->
+        let a' = subst_rawconstr subst a in
+        let (n,topt) = x in 
+        let topt' = option_smartmap
+          (fun (loc,(sp,i),x,y as t) ->
+            let sp' = subst_kn subst sp in
+            if sp == sp' then t else (loc,(sp',i),x,y)) topt in
+        if a == a' && topt == topt' then y else (a',(n,topt'))) rl
+      and branches' = list_smartmap 
+			(fun (loc,idl,cpl,r as branch) ->
+			   let cpl' =
+			     list_smartmap (subst_cases_pattern subst) cpl
+			   and r' = subst_rawconstr subst r in
+			     if cpl' == cpl && r' == r then branch else
+			       (loc,idl,cpl',r'))
+			branches
+      in
+	if rtno' == rtno && rl' == rl && branches' == branches then raw else
+	  RCases (loc,rtno',rl',branches')
+
+  | RLetTuple (loc,nal,(na,po),b,c) ->
+      let po' = option_smartmap (subst_rawconstr subst) po
+      and b' = subst_rawconstr subst b 
+      and c' = subst_rawconstr subst c in
+	if po' == po && b' == b && c' == c then raw else
+          RLetTuple (loc,nal,(na,po'),b',c')
+      
+  | RIf (loc,c,(na,po),b1,b2) ->
+      let po' = option_smartmap (subst_rawconstr subst) po
+      and b1' = subst_rawconstr subst b1 
+      and b2' = subst_rawconstr subst b2 
+      and c' = subst_rawconstr subst c in
+	if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else
+          RIf (loc,c',(na,po'),b1',b2')
+
+  | RRec (loc,fix,ida,bl,ra1,ra2) -> 
+      let ra1' = array_smartmap (subst_rawconstr subst) ra1
+      and ra2' = array_smartmap (subst_rawconstr subst) ra2 in
+      let bl' = array_smartmap
+        (list_smartmap (fun (na,obd,ty as dcl) ->
+          let ty' = subst_rawconstr subst ty in
+          let obd' = option_smartmap (subst_rawconstr subst) obd in
+          if ty'==ty & obd'==obd then dcl else (na,obd',ty')))
+        bl in
+	if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
+	  RRec (loc,fix,ida,bl',ra1',ra2')
+
+  | RSort _ -> raw
+
+  | RHole (loc,ImplicitArg (ref,i)) ->
+      let ref',_ = subst_global subst ref in 
+	if ref' == ref then raw else
+	  RHole (loc,InternalHole)
+  | RHole (loc, (BinderType _ | QuestionMark | CasesType |
+      InternalHole | TomatchTypeParameter _)) -> raw
+
+  | RCast (loc,r1,k,r2) -> 
+      let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  RCast (loc,r1',k,r2')
+
+  | RDynamic _ -> raw
+
+(* Utilities to transform kernel cases to simple pattern-matching problem *)
+
+let simple_cases_matrix_of_branches ind brns brs =
+  list_map2_i (fun i n b ->
+      let nal,c = it_destRLambda_or_LetIn_names n b in
+      let mkPatVar na = PatVar (dummy_loc,na) in
+      let p = PatCstr (dummy_loc,(ind,i+1),List.map mkPatVar nal,Anonymous) in
+      let ids = map_succeed Nameops.out_name nal in
+      (dummy_loc,ids,[p],c))
+    0 brns brs
+
+let return_type_of_predicate ind nparams n pred =
+  let nal,p = it_destRLambda_or_LetIn_names (n+1) pred in
+  (List.hd nal, Some (dummy_loc, ind, nparams, List.tl nal)), Some p
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index c2a70928..bbe2fcc9 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: detyping.mli,v 1.13.2.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: detyping.mli 8831 2006-05-19 09:29:54Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -16,20 +16,29 @@ open Sign
 open Environ
 open Rawterm
 open Termops
+open Mod_subst
 (*i*)
 
-(* [detype env avoid nenv c] turns [c], typed in [env], into a rawconstr. *)
-(* De Bruijn indexes are turned to bound names, avoiding names in [avoid] *)
+val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern
 
-val detype : bool * env -> identifier list -> names_context -> constr -> 
-  rawconstr
+val subst_rawconstr : substitution -> rawconstr -> rawconstr
+
+(* [detype isgoal avoid ctx c] turns a closed [c], into a rawconstr *)
+(* de Bruijn indexes are turned to bound names, avoiding names in [avoid] *)
+(* [isgoal] tells if naming must avoid global-level synonyms as intro does *)
+(* [ctx] gives the names of the free variables *)
+
+val detype : bool -> identifier list -> names_context -> constr -> rawconstr
 
 val detype_case : 
   bool -> ('a -> rawconstr) ->
-  (constructor -> int -> 'a -> loc * identifier list * cases_pattern list *
-    rawconstr) -> ('a -> int -> bool) ->
-    env -> identifier list -> inductive -> case_style ->
-      'a option -> int -> 'a -> 'a array -> rawconstr
+  (constructor array -> int array -> 'a array -> 
+    (loc * identifier list * cases_pattern list * rawconstr) list) ->
+  ('a -> int -> bool) ->
+  identifier list -> inductive * case_style * int * int array * int ->
+    'a option -> 'a -> 'a array -> rawconstr
+
+val detype_sort : sorts -> rawsort
 
 (* look for the index of a named var or a nondep var as it is renamed *)
 val lookup_name_as_renamed  : env -> constr -> identifier -> int option
@@ -40,3 +49,12 @@ val force_wildcard : unit -> bool
 val synthetize_type : unit -> bool
 val force_if : case_info -> bool
 val force_let : case_info -> bool
+
+(* Utilities to transform kernel cases to simple pattern-matching problem *)
+
+val it_destRLambda_or_LetIn_names : int -> rawconstr -> name list * rawconstr
+val simple_cases_matrix_of_branches : 
+  inductive -> int list -> rawconstr list -> cases_clauses
+val return_type_of_predicate :
+  inductive -> int -> int -> rawconstr -> predicate_pattern * rawconstr option
+
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 2264f82b..3c4a23ec 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -6,20 +6,23 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evarconv.ml,v 1.44.6.3 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: evarconv.ml 9141 2006-09-15 10:07:01Z herbelin $ *)
 
+open Pp
 open Util
 open Names
 open Term
-open Reductionops
 open Closure
-open Instantiate
+open Reduction
+open Reductionops
+open Termops
 open Environ
 open Typing
 open Classops
 open Recordops 
 open Evarutil
 open Libnames
+open Evd
 
 type flex_kind_of_term =
   | Rigid of constr 
@@ -40,7 +43,7 @@ let eval_flexible_term env c =
   match kind_of_term c with
   | Const c -> constant_opt_value env c
   | Rel n ->
-      (try let (_,v,_) = lookup_rel n env in option_app (lift n) v
+      (try let (_,v,_) = lookup_rel n env in option_map (lift n) v
       with Not_found -> None)
   | Var id ->
       (try let (_,v,_) = lookup_named id env in v with Not_found -> None)
@@ -69,7 +72,7 @@ let evar_apprec_nobeta env isevars stack c =
     let (t,stack as s') = apprec_nobeta env (evars_of isevars) s in
     match kind_of_term t with
       | Evar (n,_ as ev) when Evd.is_defined (evars_of isevars) n ->
-	  aux (existential_value (evars_of isevars) ev, stack)
+	  aux (Evd.existential_value (evars_of isevars) ev, stack)
       | _ -> (t, list_of_stack stack)
   in aux (c, append_stack (Array.of_list stack) empty_stack)
 *)
@@ -77,12 +80,12 @@ let evar_apprec_nobeta env isevars stack c =
 let evar_apprec env isevars stack c =
   let sigma = evars_of isevars in
   let rec aux s =
-    let (t,stack as s') = Reductionops.apprec env sigma s in
+    let (t,stack) = Reductionops.apprec env sigma s in
     match kind_of_term t with
       | Evar (n,_ as ev) when Evd.is_defined sigma n ->
-	  aux (existential_value sigma ev, stack)
+	  aux (Evd.existential_value sigma ev, stack)
       | _ -> (t, list_of_stack stack)
-  in aux (c, append_stack (Array.of_list stack) empty_stack)
+  in aux (c, append_stack_list stack empty_stack)
 
 let apprec_nohdbeta env isevars c =
   let (t,stack as s) = Reductionops.whd_stack c in
@@ -99,11 +102,11 @@ let apprec_nohdbeta env isevars c =
      (t2 us2) = (cstr us)
      extra_args1 = extra_args2
 
-   by finding a record R and an object c := [xs:bs](Build_R a1..am v1..vn)
+   by finding a record R and an object c := [xs:bs](Build_R params v1..vn)
    with vi = (cstr us), for which we know that the i-th projection proji
    satisfies
 
-      (proji params c) = (cstr us)
+      (proji params (c xs)) = (cstr us)
 
    Rem: such objects, usable for conversion, are defined in the objdef
    table; practically, it amounts to "canonically" equip t2 into a
@@ -112,10 +115,10 @@ let apprec_nohdbeta env isevars c =
 
 let check_conv_record (t1,l1) (t2,l2) =
   try
-    let proji = reference_of_constr t1 in
-    let cstr = reference_of_constr t2 in
+    let proji = global_of_constr t1 in
+    let cstr = global_of_constr t2 in
     let { o_DEF = c; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } = 
-      objdef_info (proji, cstr) in
+      lookup_canonical_conversion (proji, cstr) in
     let params1, c1, extra_args1 =
       match list_chop (List.length params) l1 with 
 	| params1, c1::extra_args1 -> params1, c1, extra_args1
@@ -125,10 +128,47 @@ let check_conv_record (t1,l1) (t2,l2) =
   with _ -> 
     raise Not_found
 
-
-(* Precondition: one of the terms of the pb is an uninstanciated evar,
+(* Precondition: one of the terms of the pb is an uninstantiated evar,
  * possibly applied to arguments. *)
 
+let rec ise_try isevars = function
+    [] -> assert false
+  | [f] -> f isevars
+  | f1::l ->
+      let (isevars',b) = f1 isevars in
+      if b then (isevars',b) else ise_try isevars l
+
+let ise_and isevars l =
+  let rec ise_and i = function
+      [] -> assert false
+    | [f] -> f i
+    | f1::l ->
+        let (i',b) = f1 i in
+        if b then  ise_and i' l else (isevars,false) in
+  ise_and isevars l
+
+let ise_list2 isevars f l1 l2 =
+  let rec ise_list2 i l1 l2 =
+    match l1,l2 with
+        [], [] -> (i, true)
+      | [x], [y] -> f i x y
+      | x::l1, y::l2 ->
+          let (i',b) = f i x y in
+          if b then ise_list2 i' l1 l2 else (isevars,false)
+      | _ -> (isevars, false) in
+  ise_list2 isevars l1 l2
+
+let ise_array2 isevars f v1 v2 =
+  let rec allrec i = function
+    | -1 -> (i,true)
+    | n ->
+        let (i',b) = f i v1.(n) v2.(n) in
+        if b then allrec i' (n-1) else (isevars,false)
+  in 
+  let lv1 = Array.length v1 in
+  if lv1 = Array.length v2 then allrec isevars (pred lv1) 
+  else (isevars,false)
+
 let rec evar_conv_x env isevars pbty term1 term2 = 
   let sigma = evars_of isevars in
   let term1 = whd_castappevar sigma term1 in
@@ -138,91 +178,125 @@ let rec evar_conv_x env isevars pbty term1 term2 =
     true
   else 
 *)
-  (* Maybe convertible but since reducing can erase evars which [evar_apprec]*)
-  (* could have found, we do it only if the terms are free of evar  *)
-  (not (has_undefined_isevars isevars term1) &
-   not (has_undefined_isevars isevars term2) &
-   is_fconv pbty env (evars_of isevars) term1 term2) 
-  or
-  if ise_undefined isevars term1 then
+  (* Maybe convertible but since reducing can erase evars which [evar_apprec]
+     could have found, we do it only if the terms are free of evar.
+     Note: incomplete heuristic... *)
+  if is_ground_term isevars term1 && is_ground_term isevars term2 &
+     is_fconv pbty env (evars_of isevars) term1 term2 then
+      (isevars,true)
+  else if is_undefined_evar isevars term1 then
     solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term1,term2)
-  else if ise_undefined isevars term2 then
+  else if is_undefined_evar isevars term2 then
     solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term2,term1)
   else 
     let (t1,l1) = apprec_nohdbeta env isevars term1 in
     let (t2,l2) = apprec_nohdbeta env isevars term2 in
-    if (head_is_embedded_evar isevars t1 & not(is_eliminator t2))
-      or (head_is_embedded_evar isevars t2 & not(is_eliminator t1))
-    then 
-      (add_conv_pb isevars (pbty,applist(t1,l1),applist(t2,l2)); true)
-    else 
-      evar_eqappr_x env isevars pbty (t1,l1) (t2,l2)
+    evar_eqappr_x env isevars pbty (t1,l1) (t2,l2)
 
 and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
   (* Evar must be undefined since we have whd_ised *)
   match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with
     | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) ->
-	let f1 () =
+	let f1 i =
 	  if List.length l1 > List.length l2 then 
             let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
-            solve_simple_eqn evar_conv_x env isevars 
-	      (pbty,ev2,applist(term1,deb1))
-            & list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2
+            ise_and i
+              [(fun i -> solve_simple_eqn evar_conv_x env i
+	        (pbty,ev2,applist(term1,deb1)));
+              (fun i -> ise_list2 i
+                  (fun i -> evar_conv_x env i CONV) rest1 l2)]
 	  else
 	    let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
-	    solve_simple_eqn evar_conv_x env isevars
-	      (pbty,ev1,applist(term2,deb2))
-            & list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2
-	and f2 () =
-          (sp1 = sp2)
-	  & (array_for_all2 (evar_conv_x env isevars CONV) al1 al2)  
-	  & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+            ise_and i
+              [(fun i -> solve_simple_eqn evar_conv_x env i
+	          (pbty,ev1,applist(term2,deb2)));
+              (fun i -> ise_list2 i
+                  (fun i -> evar_conv_x env i CONV) l1 rest2)]
+	and f2 i =
+          if sp1 = sp2 then
+            ise_and i
+            [(fun i -> ise_array2 i
+                (fun i -> evar_conv_x env i CONV) al1 al2);
+             (fun i -> ise_list2 i
+                 (fun i -> evar_conv_x env i CONV) l1 l2)]
+          else (i,false)
 	in 
 	ise_try isevars [f1; f2]
 
     | Flexible ev1, MaybeFlexible flex2 ->
-	let f1 () =
-	  (List.length l1 <= List.length l2) &
-	  let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
-          (* First compare extra args for better failure message *)
-          list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 &
-	  evar_conv_x env isevars pbty term1 (applist(term2,deb2))
-	and f4 () =
+	let f1 i =
+	  if 
+	    is_unification_pattern_evar ev1 l1 & 
+	    not (occur_evar (fst ev1) (applist (term2,l2)))
+	  then
+	    (* Miller-Pfenning's patterns unification *)
+	    (* Preserve generality (except that CCI has no eta-conversion) *)
+	    let t2 = nf_evar (evars_of isevars) (applist(term2,l2)) in
+	    let t2 = solve_pattern_eqn env l1 t2 in
+	    solve_simple_eqn evar_conv_x env isevars (pbty,ev1,t2)
+	  else if
+            List.length l1 <= List.length l2
+	  then
+	    (* Try first-order unification *)
+	    (* (heuristic that gives acceptable results in practice) *)
+	    let (deb2,rest2) =
+              list_chop (List.length l2-List.length l1) l2 in
+            ise_and i
+              (* First compare extra args for better failure message *)
+              [(fun i -> ise_list2 i
+                  (fun i -> evar_conv_x env i CONV) l1 rest2);
+               (fun i -> evar_conv_x env i pbty term1 (applist(term2,deb2)))]
+          else (i,false)
+	and f4 i =
 	  match eval_flexible_term env flex2 with
 	    | Some v2 ->
-		evar_eqappr_x env isevars pbty
-		  appr1 (evar_apprec env isevars l2 v2)
-	    | None -> false
+		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
+	    | None -> (i,false)
 	in 
 	ise_try isevars [f1; f4]
 
     | MaybeFlexible flex1, Flexible ev2 ->
-	let f1 () =
-       	  (List.length l2 <= List.length l1) &
-       	  let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
-          (* First compare extra args for better failure message *)
-          list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 &
-	  evar_conv_x env isevars pbty (applist(term1,deb1)) term2
-	and f4 () =
+	let f1 i =
+	  if 
+	    is_unification_pattern_evar ev2 l2 & 
+	    not (occur_evar (fst ev2) (applist (term1,l1)))
+	  then
+	    (* Miller-Pfenning's patterns unification *)
+	    (* Preserve generality (except that CCI has no eta-conversion) *)
+	    let t1 = nf_evar (evars_of isevars) (applist(term1,l1)) in
+	    let t1 = solve_pattern_eqn env l2 t1 in
+	    solve_simple_eqn evar_conv_x env isevars (pbty,ev2,t1)
+	  else if
+       	    List.length l2 <= List.length l1
+	  then
+	    (* Try first-order unification *)
+	    (* (heuristic that gives acceptable results in practice) *)
+            let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
+            ise_and i
+            (* First compare extra args for better failure message *)
+              [(fun i -> ise_list2 i
+                  (fun i -> evar_conv_x env i CONV) rest1 l2);
+               (fun i -> evar_conv_x env i pbty (applist(term1,deb1)) term2)]
+          else (i,false)
+	and f4 i =
 	  match eval_flexible_term env flex1 with
 	    | Some v1 ->
-		evar_eqappr_x env isevars pbty
-		  (evar_apprec env isevars l1 v1) appr2
-	    | None -> false
+		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+	    | None -> (i,false)
 	in 
 	ise_try isevars [f1; f4]
 
     | MaybeFlexible flex1, MaybeFlexible flex2 ->
-	let f2 () =
-          (flex1 = flex2)
-	  & (List.length l1 = List.length l2)
-	  & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
-	and f3 () =
-	  (try conv_record env isevars 
+	let f2 i =
+          if flex1 = flex2 then
+            ise_list2 i (fun i -> evar_conv_x env i CONV) l1 l2
+          else (i,false)
+	and f3 i =
+	  (try conv_record env i
              (try check_conv_record appr1 appr2
 	      with Not_found -> check_conv_record appr2 appr1)
-           with _ -> false)
-	and f4 () =
+           with Not_found -> (i,false))
+	and f4 i =
           (* heuristic: unfold second argument first, exception made
              if the first argument is a beta-redex (expand a constant
              only if necessary) *)
@@ -232,87 +306,99 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
               | _ -> eval_flexible_term env flex2 in
 	  match val2 with
 	    | Some v2 ->
-		evar_eqappr_x env isevars pbty
-		  appr1 (evar_apprec env isevars l2 v2)
+		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
 	    | None ->
 		match eval_flexible_term env flex1 with
 		  | Some v1 ->
-		      evar_eqappr_x env isevars pbty
-			(evar_apprec env isevars l1 v1) appr2
-		  | None -> false
+		      evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+		  | None -> (i,false)
 	in 
 	ise_try isevars [f2; f3; f4]
 
     | Flexible ev1, Rigid _ ->
-       	(List.length l1 <= List.length l2) &
-       	let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
-        (* First compare extra args for better failure message *)
-        list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 &
-	solve_simple_eqn evar_conv_x env isevars
-	  (pbty,ev1,applist(term2,deb2))
+	if 
+	  is_unification_pattern_evar ev1 l1 & 
+	  not (occur_evar (fst ev1) (applist (term2,l2)))
+	then
+	  (* Miller-Pfenning's patterns unification *)
+	  (* Preserve generality (except that CCI has no eta-conversion) *)
+	  let t2 = nf_evar (evars_of isevars) (applist(term2,l2)) in
+	  let t2 = solve_pattern_eqn env l1 t2 in
+	  solve_simple_eqn evar_conv_x env isevars (pbty,ev1,t2)
+	else
+	  (* Postpone the use of an heuristic *)
+	  add_conv_pb (pbty,applist(term1,l1),applist(term2,l2)) isevars,
+	  true
 
     | Rigid _, Flexible ev2 ->
-       	(List.length l2 <= List.length l1) &
-       	let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
-        (* First compare extra args for better failure message *)
-        list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 &
-	solve_simple_eqn evar_conv_x env isevars
-	  (pbty,ev2,applist(term1,deb1))
-        
+	if 
+	  is_unification_pattern_evar ev2 l2 & 
+	  not (occur_evar (fst ev2) (applist (term1,l1)))
+	then
+	  (* Miller-Pfenning's patterns unification *)
+	  (* Preserve generality (except that CCI has no eta-conversion) *)
+	  let t1 = nf_evar (evars_of isevars) (applist(term1,l1)) in
+	  let t1 = solve_pattern_eqn env l2 t1 in
+	  solve_simple_eqn evar_conv_x env isevars (pbty,ev2,t1)
+	else
+	  (* Postpone the use of an heuristic *)
+	  add_conv_pb (pbty,applist(term1,l1),applist(term2,l2)) isevars,
+	  true
 
     | MaybeFlexible flex1, Rigid _ ->
-	let f3 () =
-	  (try conv_record env isevars (check_conv_record appr1 appr2)
-           with _ -> false)
-	and f4 () =
+	let f3 i =
+	  (try conv_record env i (check_conv_record appr1 appr2)
+           with Not_found -> (i,false))
+	and f4 i =
 	  match eval_flexible_term env flex1 with
 	    | Some v1 ->
- 		evar_eqappr_x env isevars pbty
-		  (evar_apprec env isevars l1 v1) appr2
-	    | None -> false
+ 		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+	    | None -> (i,false)
 	in 
 	ise_try isevars [f3; f4]
 	     
     | Rigid _ , MaybeFlexible flex2 -> 
-	let f3 () = 
-	  (try (conv_record env isevars (check_conv_record appr2 appr1))
-           with _ -> false)
-	and f4 () =
+	let f3 i = 
+	  (try conv_record env i (check_conv_record appr2 appr1)
+           with Not_found -> (i,false))
+	and f4 i =
 	  match eval_flexible_term env flex2 with
 	    | Some v2 ->
- 		evar_eqappr_x env isevars pbty
-		  appr1 (evar_apprec env isevars l2 v2)
-	    | None -> false
+ 		evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
+	    | None -> (i,false)
 	in 
 	ise_try isevars [f3; f4]
 
     | Rigid c1, Rigid c2 -> match kind_of_term c1, kind_of_term c2 with
 	  
-	| Cast (c1,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2
+	| Cast (c1,_,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2
 
-	| _, Cast (c2,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2)
+	| _, Cast (c2,_,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2)
 
-	| Sort s1, Sort s2 when l1=[] & l2=[] -> base_sort_cmp pbty s1 s2
+	| Sort s1, Sort s2 when l1=[] & l2=[] ->
+            (isevars,base_sort_cmp pbty s1 s2)
 
 	| Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] -> 
-	    evar_conv_x env isevars CONV c1 c2
-	    & 
-	    (let c = nf_evar (evars_of isevars) c1 in
-             evar_conv_x (push_rel (na,None,c) env) isevars CONV c'1 c'2)
+            ise_and isevars
+              [(fun i -> evar_conv_x env i CONV c1 c2);
+               (fun i ->
+                 let c = nf_evar (evars_of i) c1 in
+                 evar_conv_x (push_rel (na,None,c) env) i CONV c'1 c'2)]
 
 	| LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) ->
-	    let f1 () =
-	      evar_conv_x env isevars CONV b1 b2
-	      & 
-              (let b = nf_evar (evars_of isevars) b1 in
-	       let t = nf_evar (evars_of isevars) t1 in
-               evar_conv_x (push_rel (na,Some b,t) env) isevars pbty c'1 c'2)
-	      & (List.length l1 = List.length l2)
-	      & (List.for_all2 (evar_conv_x env isevars CONV) l1 l2)
-	    and f2 () =
-              let appr1 = evar_apprec env isevars l1 (subst1 b1 c'1)
-              and appr2 = evar_apprec env isevars l2 (subst1 b2 c'2)
-	      in evar_eqappr_x env isevars pbty appr1 appr2
+	    let f1 i =
+              ise_and i
+                [(fun i -> evar_conv_x env i CONV b1 b2);
+                 (fun i ->
+                   let b = nf_evar (evars_of i) b1 in
+	           let t = nf_evar (evars_of i) t1 in
+                   evar_conv_x (push_rel (na,Some b,t) env) i pbty c'1 c'2);
+                 (fun i -> ise_list2 i
+                     (fun i -> evar_conv_x env i CONV) l1 l2)]
+	    and f2 i =
+              let appr1 = evar_apprec env i l1 (subst1 b1 c'1)
+              and appr2 = evar_apprec env i l2 (subst1 b2 c'2)
+	      in evar_eqappr_x env i pbty appr1 appr2
 	    in 
 	    ise_try isevars [f1; f2]
 
@@ -325,71 +411,146 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
             in evar_eqappr_x env isevars pbty appr1 appr2
 
 	| Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> 
-            evar_conv_x env isevars CONV c1 c2
-            & 
-	    (let c = nf_evar (evars_of isevars) c1 in
-	     evar_conv_x (push_rel (n,None,c) env) isevars pbty c'1 c'2)
+            ise_and isevars
+              [(fun i -> evar_conv_x env i CONV c1 c2);
+               (fun i ->
+ 	         let c = nf_evar (evars_of i) c1 in
+	         evar_conv_x (push_rel (n,None,c) env) i pbty c'1 c'2)]
 
 	| Ind sp1, Ind sp2 ->
-	    sp1=sp2
-            & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2
-             
+	    if sp1=sp2 then
+              ise_list2 isevars (fun i -> evar_conv_x env i CONV) l1 l2
+            else (isevars, false)
+
 	| Construct sp1, Construct sp2 ->
-	    sp1=sp2
-            & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2
+	    if sp1=sp2 then
+              ise_list2 isevars (fun i -> evar_conv_x env i CONV) l1 l2
+            else (isevars, false)
 
 	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
-	    evar_conv_x env isevars CONV p1 p2
-	    & evar_conv_x env isevars CONV c1 c2
-	    & (array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2)
-	    & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+            ise_and isevars
+              [(fun i -> evar_conv_x env i CONV p1 p2);
+               (fun i -> evar_conv_x env i CONV c1 c2);
+	       (fun i -> ise_array2 i
+                   (fun i -> evar_conv_x env i CONV) cl1 cl2);
+               (fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) l1 l2)]
 
 	| Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) ->
-	    li1=li2
-	    & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2)
-	    & (array_for_all2
-		 (evar_conv_x (push_rec_types recdef1 env) isevars CONV)
-		 bds1 bds2)
-	    & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
-	     
+            if li1=li2 then
+              ise_and isevars
+                [(fun i -> ise_array2 i
+                    (fun i -> evar_conv_x env i CONV) tys1 tys2);
+                 (fun i -> ise_array2 i
+		     (fun i -> evar_conv_x (push_rec_types recdef1 env) i CONV)
+		     bds1 bds2);
+	         (fun i -> ise_list2 i
+                     (fun i -> evar_conv_x env i CONV) l1 l2)]
+	    else (isevars,false)
 	| CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) ->
-	    i1=i2 
-	    & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2)
-	    & (array_for_all2
-		 (evar_conv_x (push_rec_types recdef1 env) isevars CONV)
-		 bds1 bds2)
-	    & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
-
-	| (Meta _ | Lambda _), _ -> false
-	| _, (Meta _ | Lambda _) -> false
-
-	| (Ind _ | Construct _ | Sort _ | Prod _), _ -> false
-	| _, (Ind _ | Construct _ | Sort _ | Prod _) -> false
+            if i1=i2  then
+              ise_and isevars
+                [(fun i -> ise_array2 i
+                    (fun i -> evar_conv_x env i CONV) tys1 tys2);
+                 (fun i -> ise_array2 i
+		     (fun i -> evar_conv_x (push_rec_types recdef1 env) i CONV)
+		     bds1 bds2);
+                 (fun i -> ise_list2 i
+                     (fun i -> evar_conv_x env i CONV) l1 l2)]
+            else (isevars,false)
+
+	| (Meta _ | Lambda _), _ -> (isevars,false)
+	| _, (Meta _ | Lambda _) -> (isevars,false)
+
+	| (Ind _ | Construct _ | Sort _ | Prod _), _ -> (isevars,false)
+	| _, (Ind _ | Construct _ | Sort _ | Prod _) -> (isevars,false)
 
 	| (App _ | Case _ | Fix _ | CoFix _), 
-	  (App _ | Case _ | Fix _ | CoFix _) -> false
+	  (App _ | Case _ | Fix _ | CoFix _) -> (isevars,false)
 
 	| (Rel _ | Var _ | Const _ | Evar _), _ -> assert false
 	| _, (Rel _ | Var _ | Const _ | Evar _) -> assert false
 
 and conv_record env isevars (c,bs,(params,params1),(us,us2),(ts,ts1),c1) = 
-  let ks =
+  let (isevars',ks) =
     List.fold_left
-      (fun ks b ->
-	 let dloc = (dummy_loc,Rawterm.InternalHole) in
-	 (new_isevar isevars env dloc (substl ks b)) :: ks)
-      [] bs
+      (fun (i,ks) b ->
+	 let dloc = (dummy_loc,InternalHole) in
+         let (i',ev) = new_evar i env ~src:dloc (substl ks b) in
+	 (i', ev :: ks))
+      (isevars,[]) bs
   in
-  (list_for_all2eq 
-     (fun u1 u -> evar_conv_x env isevars CONV u1 (substl ks u))
-     us2 us)
-  &
-  (list_for_all2eq 
-     (fun x1 x -> evar_conv_x env isevars CONV x1 (substl ks x))
-     params1 params)
-  & (list_for_all2eq (evar_conv_x env isevars CONV) ts ts1)
-  & (evar_conv_x env isevars CONV c1 (applist (c,(List.rev ks))))
-    
-let the_conv_x     env isevars t1 t2 = evar_conv_x env isevars CONV  t1 t2
-let the_conv_x_leq env isevars t1 t2 = evar_conv_x env isevars CUMUL t1 t2
+  ise_and isevars'
+    [(fun i ->
+      ise_list2 i
+        (fun i u1 u -> evar_conv_x env i CONV u1 (substl ks u))
+        us2 us);
+     (fun i ->
+       ise_list2 i
+         (fun i x1 x -> evar_conv_x env i CONV x1 (substl ks x))
+         params1 params);
+     (fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) ts ts1);
+     (fun i -> evar_conv_x env i CONV c1 (applist (c,(List.rev ks))))]
+
+let first_order_unification env isevars pbty (term1,l1) (term2,l2) =
+  match kind_of_term term1, kind_of_term term2 with
+    | Evar ev1,_ when List.length l1 <= List.length l2 ->
+	let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
+	ise_and isevars
+          (* First compare extra args for better failure message *)
+        [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) rest2 l1);
+	(fun i ->
+          (* Then instantiate evar unless already done by unifying args *)
+	  let t2 = applist(term2,deb2) in
+	  if is_defined_evar i ev1 then
+	    evar_conv_x env i pbty t2 (mkEvar ev1)
+	  else
+	    solve_simple_eqn evar_conv_x env i (pbty,ev1,t2))]
+    | _,Evar ev2 when List.length l2 <= List.length l1 ->
+	let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
+	ise_and isevars
+          (* First compare extra args for better failure message *)
+        [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) rest1 l2);
+	(fun i ->
+          (* Then instantiate evar unless already done by unifying args *)
+	  let t1 = applist(term1,deb1) in
+	  if is_defined_evar i ev2 then
+	    evar_conv_x env i pbty t1 (mkEvar ev2)
+	  else
+	    solve_simple_eqn evar_conv_x env i (pbty,ev2,t1))]
+    | _ -> 
+	(* Some head evar have been instantiated *)
+	evar_conv_x env isevars pbty (applist(term1,l1)) (applist(term2,l2))
+
+let consider_remaining_unif_problems env isevars =
+  let (isevars,pbs) = get_conv_pbs isevars (fun _ -> true) in
+  List.fold_left
+    (fun (isevars,b as p) (pbty,t1,t2) ->
+      (* Pas le bon env pour le problème... *)
+      if b then first_order_unification env isevars pbty 
+	(apprec_nohdbeta env isevars (whd_castappevar (evars_of isevars) t1))
+	(apprec_nohdbeta env isevars (whd_castappevar (evars_of isevars) t2))
+      else p)
+    (isevars,true)
+    pbs
+
+(* Main entry points *)
+
+let the_conv_x     env t1 t2 isevars =
+  match evar_conv_x env isevars CONV  t1 t2 with
+      (evd',true) -> evd'
+    | _ -> raise Reduction.NotConvertible
+
+let the_conv_x_leq env t1 t2 isevars =
+  match evar_conv_x env isevars CUMUL t1 t2 with
+      (evd', true) -> evd'
+    | _ -> raise Reduction.NotConvertible
  
+let e_conv env isevars t1 t2 =
+  match evar_conv_x env !isevars CONV t1 t2 with
+      (evd',true) -> isevars := evd'; true
+    | _ -> false
+
+let e_cumul env isevars t1 t2 =
+  match evar_conv_x env !isevars CUMUL t1 t2 with
+      (evd',true) -> isevars := evd'; true
+    | _ -> false
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 8785d855..f92a6fdb 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -6,23 +6,32 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evarconv.mli,v 1.11.14.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: evarconv.mli 9141 2006-09-15 10:07:01Z herbelin $ i*)
 
 (*i*)
 open Term
 open Sign
 open Environ
 open Reductionops
-open Evarutil
+open Evd
 (*i*)
 
-val the_conv_x : env -> evar_defs -> constr -> constr -> bool
+(* returns exception Reduction.NotConvertible if not unifiable *)
+val the_conv_x     : env -> constr -> constr -> evar_defs -> evar_defs
+val the_conv_x_leq : env -> constr -> constr -> evar_defs -> evar_defs
 
-val the_conv_x_leq : env -> evar_defs -> constr -> constr -> bool
+(* The same function resolving evars by side-effect and 
+   catching the exception *)
+val e_conv  : env -> evar_defs ref -> constr -> constr -> bool
+val e_cumul : env -> evar_defs ref -> constr -> constr -> bool
 
 (*i For debugging *)
-val evar_conv_x : env -> evar_defs -> conv_pb -> constr -> constr -> bool
+val evar_conv_x :
+  env -> evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool
 val evar_eqappr_x : 
   env -> evar_defs ->
-    conv_pb -> constr * constr list -> constr * constr list -> bool
+    conv_pb -> constr * constr list -> constr * constr list ->
+      evar_defs * bool
 (*i*)
+
+val consider_remaining_unif_problems : env -> evar_defs -> evar_defs * bool
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 4337c0fc..b545bd38 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evarutil.ml,v 1.64.2.5 2004/12/09 14:45:38 herbelin Exp $ *)
+(* $Id: evarutil.ml 9573 2007-01-31 20:18:18Z notin $ *)
 
 open Util
 open Pp
@@ -18,18 +18,9 @@ open Termops
 open Sign
 open Environ
 open Evd
-open Instantiate
 open Reductionops
-open Indrec
 open Pretype_errors
 
-
-let rec filter_unique = function
-  | [] -> []
-  | x::l ->
-      if List.mem x l then filter_unique (List.filter (fun y -> x<>y) l)
-      else x::filter_unique l
-
 (* Expanding existential variables (pretyping.ml) *)
 (* 1- whd_ise fails if an existential is undefined *)
 
@@ -37,7 +28,7 @@ exception Uninstantiated_evar of existential_key
 
 let rec whd_ise sigma c =
   match kind_of_term c with
-    | Evar (ev,args) when Evd.in_dom sigma ev ->
+    | Evar (ev,args) when Evd.mem sigma ev ->
 	if Evd.is_defined sigma ev then
           whd_ise sigma (existential_value sigma (ev,args))
 	else raise (Uninstantiated_evar ev)
@@ -48,9 +39,9 @@ let rec whd_ise sigma c =
 let whd_castappevar_stack sigma c = 
   let rec whrec (c, l as s) =
     match kind_of_term c with
-      | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev -> 
+      | Evar (ev,args) when Evd.mem sigma ev & Evd.is_defined sigma ev -> 
 	  whrec (existential_value sigma (ev,args), l)
-      | Cast (c,_) -> whrec (c, l)
+      | Cast (c,_,_) -> whrec (c, l)
       | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
       | _ -> s
   in 
@@ -64,207 +55,122 @@ let jl_nf_evar = Pretype_errors.jl_nf_evar
 let jv_nf_evar = Pretype_errors.jv_nf_evar
 let tj_nf_evar = Pretype_errors.tj_nf_evar
 
-(**********************)
-(* Creating new evars *)
-(**********************)
-
-let evar_env evd = Global.env_of_context evd.evar_hyps
-
-(* Generator of existential names *)
-let new_evar =
-  let evar_ctr = ref 0 in
-  fun () -> incr evar_ctr; existential_of_int !evar_ctr
+let nf_evar_info evc info =
+  { info with 
+    evar_concl = Reductionops.nf_evar evc info.evar_concl;
+    evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps}
 
-let make_evar_instance env =
-  fold_named_context
-    (fun env (id, b, _) l -> (*if b=None then*) mkVar id :: l (*else l*))
-    env ~init:[]
+let nf_evars evm = Evd.fold (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
+		     evm Evd.empty
 
-(* create an untyped existential variable *)
-let new_evar_in_sign env =
-  let ev = new_evar () in
-  mkEvar (ev, Array.of_list (make_evar_instance env))
-
-(*------------------------------------*
- * functional operations on evar sets *
- *------------------------------------*)
-
-(* All ids of sign must be distincts! *)
-let new_isevar_sign env sigma typ instance =
-  let sign = named_context env in
-  if not (list_distinct (ids_of_named_context sign)) then 
-    error "new_isevar_sign: two vars have the same name";
-  let newev = new_evar() in
-  let info = { evar_concl = typ; evar_hyps = sign; 
-	       evar_body = Evar_empty } in
-  (Evd.add sigma newev info, mkEvar (newev,Array.of_list instance))
-
-(* We don't try to guess in which sort the type should be defined, since
-   any type has type Type. May cause some trouble, but not so far... *)
-let new_Type () = mkType (new_univ ())
+let nf_evar_defs isevars = Evd.evars_reset_evd (nf_evars (Evd.evars_of isevars)) isevars
 
-let new_Type_sort () = Type (new_univ ())
+let nf_isevar isevars = nf_evar (Evd.evars_of isevars)
+let j_nf_isevar isevars = j_nf_evar (Evd.evars_of isevars)
+let jl_nf_isevar isevars = jl_nf_evar (Evd.evars_of isevars)
+let jv_nf_isevar isevars = jv_nf_evar (Evd.evars_of isevars)
+let tj_nf_isevar isevars = tj_nf_evar (Evd.evars_of isevars)
 
-let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
-(*
-let new_Type () = mkType dummy_univ
-
-let new_Type_sort () = Type dummy_univ
-
-let judge_of_new_Type () = 
-  { uj_val = mkSort (Type dummy_univ);
-    uj_type = mkSort (Type dummy_univ) }
-*)
+(**********************)
+(* Creating new metas *)
+(**********************)
 
-(* This refreshes universes in types; works only for inferred types (i.e. for
-   types of the form (x1:A1)...(xn:An)B with B a sort or an atom in
-   head normal form) *)
-let refresh_universes t =
-  let modified = ref false in
-  let rec refresh t = match kind_of_term t with
-    | Sort (Type _) -> modified := true; new_Type ()
-    | Prod (na,u,v) -> mkProd (na,u,refresh v)
-    | _ -> t in
-  let t' = refresh t in
-  if !modified then t' else t
+(* Generator of metavariables *)
+let new_meta =
+  let meta_ctr = ref 0 in
+  fun () -> incr meta_ctr; !meta_ctr
 
-(* Declaring any type to be in the sort Type shouldn't be harmful since
-   cumulativity now includes Prop and Set in Type. *)
-let new_type_var env sigma =
-  let instance = make_evar_instance env in
-  new_isevar_sign env sigma (new_Type ()) instance
-
-let split_evar_to_arrow sigma (ev,args) =
-  let evd = Evd.map sigma ev in
-  let evenv = evar_env evd in
-  let (sigma1,dom) = new_type_var evenv sigma in
-  let hyps = evd.evar_hyps in
-  let nvar = next_ident_away (id_of_string "x") (ids_of_named_context hyps) in
-  let newenv = push_named (nvar, None, dom) evenv in
-  let (sigma2,rng) = new_type_var newenv sigma1 in
-  let x = named_hd newenv dom Anonymous in
-  let prod = mkProd (x, dom, subst_var nvar rng) in
-  let sigma3 = Evd.define sigma2 ev prod in
-  let evdom = fst (destEvar dom), args in
-  let evrng =
-    fst (destEvar rng), array_cons (mkRel 1) (Array.map (lift 1) args) in
-  let prod' = mkProd (x, mkEvar evdom, mkEvar evrng) in
-  (sigma3,prod', evdom, evrng)
+let mk_new_meta () = mkMeta(new_meta())
 
-(* Redefines an evar with a smaller context (i.e. it may depend on less
- * variables) such that c becomes closed.
- * Example: in [x:?1; y:(list ?2)] <?3>x=y /\ x=(nil bool)
- * ?3 <-- ?1          no pb: env of ?3 is larger than ?1's
- * ?1 <-- (list ?2)   pb: ?2 may depend on x, but not ?1.
- * What we do is that ?2 is defined by a new evar ?4 whose context will be
- * a prefix of ?2's env, included in ?1's env. *)
+let collect_evars emap c =
+  let rec collrec acc c =
+    match kind_of_term c with
+      | Evar (k,_) ->
+	  if Evd.mem emap k & not (Evd.is_defined emap k) then k::acc
+	  else (* No recursion on the evar instantiation *) acc
+      | _         ->
+	  fold_constr collrec acc c in
+  list_uniquize (collrec [] c)
+
+let push_dependent_evars sigma emap =
+  Evd.fold (fun ev {evar_concl = ccl} (sigma',emap') ->
+    List.fold_left 
+      (fun (sigma',emap') ev -> 
+	(Evd.add sigma' ev (Evd.find emap' ev),Evd.remove emap' ev))
+      (sigma',emap') (collect_evars emap' ccl))
+    emap (sigma,emap)
+
+(* replaces a mapping of existentials into a mapping of metas.
+   Problem if an evar appears in the type of another one (pops anomaly) *)
+let evars_to_metas sigma (emap, c) =
+  let emap = nf_evars emap in
+  let sigma',emap' = push_dependent_evars sigma emap in
+  let change_exist evar =
+    let ty = nf_betaiota (nf_evar emap (existential_type emap evar)) in
+    let n = new_meta() in
+    mkCast (mkMeta n, DEFAULTcast, ty) in
+  let rec replace c =
+    match kind_of_term c with
+        Evar (k,_ as ev) when Evd.mem emap' k -> change_exist ev
+      | _ -> map_constr replace c in
+  (sigma', replace c)
+
+(* The list of non-instantiated existential declarations *)
+
+let non_instantiated sigma = 
+  let listev = to_list sigma in
+  List.fold_left 
+    (fun l (ev,evd) -> 
+       if evd.evar_body = Evar_empty then 
+	 ((ev,nf_evar_info sigma evd)::l) else l)
+    [] listev
+
+(*************************************)
+(* Metas *)
+
+let meta_value evd mv = 
+  let rec valrec mv =
+    try
+      let b = meta_fvalue evd mv in
+      instance
+        (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
+        b.rebus
+    with Anomaly _ | Not_found -> 
+      mkMeta mv
+  in 
+  valrec mv
 
-let do_restrict_hyps sigma ev args =
-  let args = Array.to_list args in
-  let evd = Evd.map sigma ev in
-  let env = evar_env evd in
-  let hyps = evd.evar_hyps in
-  let (sign,ncargs) = list_filter2 (fun _ a -> closed0 a) (hyps,args) in
-  let env' = reset_with_named_context sign env in
-  let (sigma',nc) = new_isevar_sign env' sigma evd.evar_concl ncargs in
-  let nc = refresh_universes nc in (* needed only if nc is an inferred type *)
-  let sigma'' = Evd.define sigma' ev nc in
-  (sigma'', nc)
+let meta_instance env b =
+  let c_sigma =
+    List.map 
+      (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas)
+  in 
+  instance c_sigma b.rebus
 
+let nf_meta env c = meta_instance env (mk_freelisted c)
 
+(**********************)
+(* Creating new evars *)
+(**********************)
 
+(* Generator of existential names *)
+let new_untyped_evar =
+  let evar_ctr = ref 0 in
+  fun () -> incr evar_ctr; existential_of_int !evar_ctr
 
 (*------------------------------------*
- * operations on the evar constraints *
+ * functional operations on evar sets *
  *------------------------------------*)
 
-type evar_constraint = conv_pb * constr * constr
-type evar_defs =
-    { mutable evars : Evd.evar_map;
-      mutable conv_pbs : evar_constraint list;
-      mutable history : (existential_key * (loc * Rawterm.hole_kind)) list }
-
-let create_evar_defs evd = { evars=evd; conv_pbs=[]; history=[] }
-let evars_of d = d.evars
-let evars_reset_evd evd d = d.evars <- evd
-let add_conv_pb d pb = d.conv_pbs <- pb::d.conv_pbs
-let evar_source ev d =
-  try List.assoc ev d.history
-  with Failure _ -> (dummy_loc, Rawterm.InternalHole)
-
-(* ise_try [f1;...;fn] tries fi() for i=1..n, restoring the evar constraints
- * when fi returns false or an exception. Returns true if one of the fi
- * returns true, and false if every fi return false (in the latter case,
- * the evar constraints are restored).
- *)
-let ise_try isevars l =
-  let u = isevars.evars in
-  let rec test = function
-      [] -> isevars.evars <- u; false
-    | f::l ->
- 	  (try f() with reraise -> isevars.evars <- u; raise reraise)
-       or (isevars.evars <- u; test l)
-  in test l
-
-
-
-(* say if the section path sp corresponds to an existential *)
-let ise_in_dom isevars sp = Evd.in_dom isevars.evars sp
-
-(* map the given section path to the enamed_declaration *)
-let ise_map isevars sp = Evd.map isevars.evars sp
-
-(* define the existential of section path sp as the constr body *)
-let ise_define isevars sp body =
-  let body = refresh_universes body in (* needed only if an inferred type *)
-  isevars.evars <- Evd.define isevars.evars sp body
-
-let is_defined_evar isevars (n,_) = Evd.is_defined isevars.evars n
-
-(* Does k corresponds to an (un)defined existential ? *)
-let ise_undefined isevars c = match kind_of_term c with
-  | Evar ev -> not (is_defined_evar isevars ev)
-  | _ -> false
-
-let need_restriction isevars args = not (array_for_all closed0 args)
-    
-
-(* We try to instanciate the evar assuming the body won't depend
- * on arguments that are not Rels or Vars, or appearing several times.
- *)
-(* Note: error_not_clean should not be an error: it simply means that the
- * conversion test that lead to the faulty call to [real_clean] should return
- * false. The problem is that we won't get the right error message.
- *)
-
-let real_clean env isevars ev args rhs =
-  let subst = List.map (fun (x,y) -> (y,mkVar x)) (filter_unique args) in
-  let rec subs k t =
-    match kind_of_term t with
-      | Rel i ->
- 	 if i<=k then t
- 	 else (try List.assoc (mkRel (i-k)) subst with Not_found -> t)
-      | Evar (ev,args) ->
-	  let args' = Array.map (subs k) args in
-	  if need_restriction isevars args' then
-	    if Evd.is_defined isevars.evars ev then 
-	      subs k (existential_value isevars.evars (ev,args'))
-	    else begin
-	      let (sigma,rc) = do_restrict_hyps isevars.evars ev args' in
-	      isevars.evars <- sigma;
-              isevars.history <- 
-                (fst (destEvar rc),evar_source ev isevars)::isevars.history;
-	      rc
-	    end
-	  else
-	    mkEvar (ev,args')
-      | Var _ -> (try List.assoc t subst with Not_found -> t)
-      | _ -> map_constr_with_binders succ subs k t
-  in
-  let body = subs 0 rhs in
-  if not (closed0 body)
-  then error_not_clean env isevars.evars ev body (evar_source ev isevars);
-  body
+(* All ids of sign must be distincts! *)
+let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) instance =
+  let ctxt = named_context_of_val sign in
+    assert (List.length instance = named_context_length ctxt); 
+    if not (list_distinct (ids_of_named_context ctxt)) then 
+      anomaly "new_evar_instance: two vars have the same name";
+    let newev = new_untyped_evar() in
+      (evar_declare sign newev typ ~src:src evd,
+      mkEvar (newev,Array.of_list instance))
 
 let make_evar_instance_with_rel env =
   let n = rel_context_length (rel_context env) in
@@ -279,7 +185,7 @@ let make_evar_instance_with_rel env =
 
 let make_subst env args =
   snd (fold_named_context
-    (fun env (id,b,c) (args,l as g) ->
+    (fun env (id,b,c) (args,l) ->
        match b, args with
 	 | (* None *) _ , a::rest -> (rest, (id,a)::l)
 (*	 | Some _, _ -> g*)
@@ -290,28 +196,283 @@ let make_subst env args =
 (* Converting the env into the sign of the evar to define *)
 
 let push_rel_context_to_named_context env =
-  let sign0 = named_context env in
-  let (subst,_,sign) =
+  let (subst,_,env) =
   Sign.fold_rel_context
-    (fun (na,c,t) (subst,avoid,sign) ->
-       let na = if na = Anonymous then Name(id_of_string"_") else na in
+    (fun (na,c,t) (subst,avoid,env) ->
        let id = next_name_away na avoid in
        ((mkVar id)::subst,
         id::avoid,
-	add_named_decl (id,option_app (substl subst) c,
+	push_named (id,option_map (substl subst) c,
                         type_app (substl subst) t)
-	  sign))
-    (rel_context env) ~init:([],ids_of_named_context sign0,sign0)
-  in (subst, reset_with_named_context sign env)
+	  env))
+    (rel_context env) ~init:([],ids_of_named_context (named_context env),env)
+  in (subst, (named_context_val env))
 
-let new_isevar isevars env src typ =
-  let subst,env' = push_rel_context_to_named_context env in
+let new_evar evd env ?(src=(dummy_loc,InternalHole)) typ =
+  let subst,sign = push_rel_context_to_named_context env in
   let typ' = substl subst typ in
   let instance = make_evar_instance_with_rel env in
-  let (sigma',evar) = new_isevar_sign env' isevars.evars typ' instance in
-  isevars.evars <- sigma';
-  isevars.history <- (fst (destEvar evar),src)::isevars.history;
-  evar
+  new_evar_instance sign evd typ' ~src:src instance
+
+  (* The same using side-effect *)
+let e_new_evar evd env ?(src=(dummy_loc,InternalHole)) ty =
+  let (evd',ev) = new_evar !evd env ~src:src ty in
+    evd := evd';
+    ev
+
+(*------------------------------------*
+ * operations on the evar constraints *
+ *------------------------------------*)
+
+(* Pb: defined Rels and Vars should not be considered as a pattern... *)
+let is_pattern inst =
+  let rec is_hopat l = function
+      [] -> true
+    | t :: tl ->
+        (isRel t or isVar t) && not (List.mem t l) && is_hopat (t::l) tl in
+  is_hopat [] (Array.to_list inst)
+
+let evar_well_typed_body evd ev evi body =
+  try
+    let env = evar_env evi in
+    let ty = evi.evar_concl in
+    Typing.check env (evars_of evd) body ty;
+    true
+  with e ->
+    pperrnl
+      (str "Ill-typed evar instantiation: " ++ fnl() ++
+       pr_evar_defs evd ++ fnl() ++
+       str "----> " ++ int ev ++ str " := " ++
+       print_constr body);
+    false
+
+let strict_inverse = false
+
+let inverse_instance env isevars ev evi inst rhs =
+  let subst = make_subst (evar_env evi) (Array.to_list inst) in
+  let subst = List.map (fun (x,y) -> (y,mkVar x)) subst in
+  let evd = ref isevars in
+  let error () = 
+    error_not_clean env (evars_of !evd) ev rhs (evar_source ev !evd) in
+  let rec subs rigid k t =
+    match kind_of_term t with
+      | Rel i ->
+ 	  if i<=k then t
+ 	  else
+            (try List.assoc (mkRel (i-k)) subst
+             with Not_found ->
+               if rigid then error()
+               else if strict_inverse then
+                 failwith "cannot solve pb yet"
+               else t)
+      | Var id ->
+          (try List.assoc t subst
+           with Not_found ->
+             if rigid then error()
+             else if
+               not strict_inverse &&
+               List.exists (fun (id',_,_) -> id=id') (evar_context evi)
+             then
+               failwith "cannot solve pb yet"
+             else t)
+      | Evar (ev,args) ->
+          if Evd.is_defined_evar !evd (ev,args) then
+            subs rigid k (existential_value (evars_of !evd) (ev,args))
+          else
+	    let args' = Array.map (subs false k) args in
+	    mkEvar (ev,args')
+      | _ -> map_constr_with_binders succ (subs rigid) k t in
+  let body = subs true 0 (nf_evar (evars_of isevars) rhs) in
+  (!evd,body)
+
+
+let is_defined_equation env evd (ev,inst) rhs =
+  is_pattern inst &&
+  not (occur_evar ev rhs) &&
+  try
+    let evi = Evd.find (evars_of evd) ev in
+    let (evd',body) = inverse_instance env evd ev evi inst rhs in
+    evar_well_typed_body evd' ev evi body
+  with Failure _ -> false
+
+
+(* Redefines an evar with a smaller context (i.e. it may depend on less
+ * variables) such that c becomes closed.
+ * Example: in [x:?1; y:(list ?2)] <?3>x=y /\ x=(nil bool)
+ * ?3 <-- ?1          no pb: env of ?3 is larger than ?1's
+ * ?1 <-- (list ?2)   pb: ?2 may depend on x, but not ?1.
+ * What we do is that ?2 is defined by a new evar ?4 whose context will be
+ * a prefix of ?2's env, included in ?1's env.
+
+ Concretely, the assumptions are "env |- ev : T" and "Gamma |-
+ ev[hyps:=args]" for some Gamma whose de Bruijn context has length k.
+ We create "env' |- ev' : T" for some env' <= env and define ev:=ev'
+*)
+
+let do_restrict_hyps env k evd ev args =
+  let args = Array.to_list args in
+  let evi = Evd.find (evars_of !evd) ev in
+  let hyps = evar_context evi in
+  let (hyps',ncargs) = list_filter2 (fun _ a -> closedn k a) (hyps,args) in
+    (* No care is taken in case the evar type uses vars filtered out!
+       Assuming that the restriction comes from a well-typed Flex/Flex
+       unification problem (see real_clean), the type of the evar cannot
+       depend on variables that are not in the scope of the other evar,
+       since this other evar has the same type (up to unification).
+     Since moreover, the evar contexts uses names only, the
+       restriction raise no de Bruijn reallocation problem *)
+  let env' =
+    Sign.fold_named_context push_named hyps' ~init:(reset_context env) in
+  let nc = e_new_evar evd env' ~src:(evar_source ev !evd) evi.evar_concl in
+    evd := Evd.evar_define ev nc !evd;
+    let (evn,_) = destEvar nc in
+      mkEvar(evn,Array.of_list ncargs)
+	
+
+exception Dependency_error of identifier
+	
+let rec check_and_clear_in_constr evd c ids =
+  (* returns a new constr where all the evars have been 'cleaned'
+     (ie the hypotheses ids have been removed from the contexts of
+     evars *)
+  let check id' = 
+    if List.mem id' ids then
+      raise (Dependency_error id')
+  in 
+    match kind_of_term c with
+      | ( Rel _ | Meta _ | Sort _ ) -> c
+      | ( Const _ | Ind _ | Construct _ ) -> 
+	  let vars = Environ.vars_of_global (Global.env()) c in
+	    List.iter check vars; c
+      | Var id' ->  
+	  check id'; mkVar id'
+      | Evar (e,l) -> 
+	  if Evd.is_defined_evar !evd (e,l) then
+	    (* If e is already defined we replace it by its definition *)
+	    let nc = nf_evar (evars_of !evd) c in 
+	      (check_and_clear_in_constr evd nc ids)
+	  else
+	    (* We check for dependencies to elements of ids in the
+	       evar_info corresponding to e and in the instance of
+	       arguments. Concurrently, we build a new evar
+	       corresponding to e where hypotheses of ids have been
+	       removed *)
+	    let evi = Evd.find (evars_of !evd) e in
+	    let nconcl = check_and_clear_in_constr evd (evar_concl evi) ids in
+	    let (nhyps,nargs) = 
+	      List.fold_right2 
+		(fun (id,ob,c) i (hy,ar) ->
+		  if List.mem id ids then
+		    (hy,ar)
+		  else
+		    let d' = (id,
+			     (match ob with 
+				 None -> None
+			       | Some b -> Some (check_and_clear_in_constr evd b ids)),
+			     check_and_clear_in_constr evd c ids) in
+		    let i' = check_and_clear_in_constr evd i ids in
+		      (d'::hy, i'::ar)
+		) 	      
+		(evar_context evi) (Array.to_list l) ([],[]) in
+	    let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in
+	    let ev'= e_new_evar evd env ~src:(evar_source e !evd) nconcl in
+	      evd := Evd.evar_define e ev' !evd;
+	      let (e',_) = destEvar ev' in
+		mkEvar(e', Array.of_list nargs)
+      | _ -> map_constr (fun c -> check_and_clear_in_constr evd c ids) c
+
+and clear_hyps_in_evi evd evi ids =
+  (* clear_evar_hyps erases hypotheses ids in evi, checking if some
+     hypothesis does not depend on a element of ids, and erases ids in
+     the contexts of the evars occuring in evi *)
+  let nconcl = try check_and_clear_in_constr evd (evar_concl evi) ids 
+    with Dependency_error id' -> error (string_of_id id' ^ " is used in conclusion") in
+  let (nhyps,_) = 
+    let aux (id,ob,c) = 
+      try
+	(id,
+	(match ob with 
+	    None -> None
+	  | Some b -> Some (check_and_clear_in_constr evd b ids)),
+	check_and_clear_in_constr evd c ids)
+      with Dependency_error id' -> error (string_of_id id' ^ " is used in hypothesis "
+					   ^ string_of_id id)
+    in
+      remove_hyps ids aux (evar_hyps evi)
+  in    
+    { evi with
+      evar_concl = nconcl;
+      evar_hyps  = nhyps}
+      
+
+let need_restriction k args = not (array_for_all (closedn k) args)
+
+(* We try to instantiate the evar assuming the body won't depend
+ * on arguments that are not Rels or Vars, or appearing several times
+ * (i.e. we tackle only Miller-Pfenning patterns unification) 
+
+ * 1) Let a unification problem "env |- ev[hyps:=args] = rhs"
+ * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs"
+ * where only Rel's and Var's are relevant in subst
+ * 3) We recur on rhs, "imitating" the term failing if some Rel/Var not in scope
+
+ * Note: we don't assume rhs in normal form, it may fail while it would
+ * have succeeded after some reductions
+ *)
+(* Note: error_not_clean should not be an error: it simply means that the
+ * conversion test that lead to the faulty call to [real_clean] should return
+ * false. The problem is that we won't get the right error message.
+ *)
+
+let real_clean env isevars ev evi args rhs =
+  let evd = ref isevars in
+  let subst = List.map (fun (x,y) -> (y,mkVar x)) (list_uniquize args) in
+  let rec subs rigid k t =
+    match kind_of_term t with
+      | Rel i ->
+ 	 if i<=k then t
+ 	 else
+	   (* Flex/Rel problem: unifiable as a pattern iff Rel in ev scope *)
+	   (try List.assoc (mkRel (i-k)) subst 
+	    with Not_found -> if rigid then raise Exit else t)
+      | Evar (ev,args) ->
+          if Evd.is_defined_evar !evd (ev,args) then
+            subs rigid k (existential_value (evars_of !evd) (ev,args))
+          else
+	    (* Flex/Flex problem: restriction to a common scope *)
+	    let args' = Array.map (subs false k) args in
+	    if need_restriction k args' then
+              do_restrict_hyps (reset_context env) k evd ev args'
+	    else
+	      mkEvar (ev,args')
+      | Var id ->
+	  (* Flex/Var problem: unifiable as a pattern iff Var in scope of ev *)
+          (try List.assoc t subst
+           with Not_found ->
+             if
+               not rigid 
+	     (* I don't understand this line: vars from evar_context evi
+		are private (especially some of them are freshly
+		generated in push_rel_context_to_named_context). They
+		have a priori nothing to do with the vars in env. I
+		remove the test [HH 25/8/06]
+
+		 or List.exists (fun (id',_,_) -> id=id') (evar_context evi)
+	     *)
+             then t
+             else raise Exit)
+               
+      | _ ->
+	  (* Flex/Rigid problem (or assimilated if not normal): we "imitate" *)
+	  map_constr_with_binders succ (subs rigid) k t
+  in
+  let rhs = nf_evar (evars_of isevars) rhs in
+  let rhs = whd_beta rhs (* heuristic *) in
+  let body = 
+    try subs true 0 rhs
+    with Exit -> 
+      error_not_clean env (evars_of !evd) ev rhs (evar_source ev !evd) in
+  (!evd,body)
 
 (* [evar_define] solves the problem lhs = rhs when lhs is an uninstantiated
  * evar, i.e. tries to find the body ?sp for lhs=mkEvar (sp,args)
@@ -331,30 +492,56 @@ let new_isevar isevars env src typ =
  * ?1 would be instantiated by (le y y) but y is not in the scope of ?1
  *)
 
-let evar_define env isevars (ev,argsv) rhs =
+(* env needed for error messages... *)
+let evar_define env (ev,argsv) rhs isevars =
   if occur_evar ev rhs
   then error_occur_check env (evars_of isevars) ev rhs;
   let args = Array.to_list argsv in 
-  let evd = ise_map isevars ev in
+  let evi = Evd.find (evars_of isevars) ev in
   (* the bindings to invert *)
-  let worklist = make_subst (evar_env evd) args in
-  let body = real_clean env isevars ev worklist rhs in
-  ise_define isevars ev body;
-  [ev]
+  let worklist = make_subst (evar_env evi) args in
+  let (isevars',body) = real_clean env isevars ev evi worklist rhs in
+  if occur_meta body then error "Meta cannot occur in evar body"
+  else
+    (* needed only if an inferred type *)
+    let body = refresh_universes body in
+(* Cannot strictly type instantiations since the unification algorithm
+ * does not unifies applications from left to right.
+ * e.g problem f x == g y yields x==y and f==g (in that order) 
+ * Another problem is that type variables are evars of type Type
+   let _ =
+      try
+        let env = evar_env evi in
+        let ty = evi.evar_concl in
+        Typing.check env (evars_of isevars') body ty
+      with e ->
+        pperrnl
+          (str "Ill-typed evar instantiation: " ++ fnl() ++
+           pr_evar_defs isevars' ++ fnl() ++
+           str "----> " ++ int ev ++ str " := " ++
+           print_constr body);
+        raise e in*)
+    let isevars'' = Evd.evar_define ev body isevars' in
+    isevars'',[ev]
+
+
 
 (*-------------------*)
 (* Auxiliary functions for the conversion algorithms modulo evars
  *)
 
-let has_undefined_isevars isevars t = 
-  try let _ = local_strong (whd_ise isevars.evars) t in false
+let has_undefined_evars isevars t = 
+  try let _ = local_strong (whd_ise (evars_of isevars)) t in false
   with Uninstantiated_evar _ -> true
 
+let is_ground_term isevars t =
+  not (has_undefined_evars isevars t)
+
 let head_is_evar isevars = 
   let rec hrec k = match kind_of_term k with
-    | Evar (n,_)   -> not (Evd.is_defined isevars.evars n)
+    | Evar n   -> not (Evd.is_defined_evar isevars n)
     | App (f,_) -> hrec f
-    | Cast (c,_) -> hrec c
+    | Cast (c,_,_) -> hrec c
     | _ -> false
   in 
   hrec 
@@ -362,7 +549,7 @@ let head_is_evar isevars =
 let rec is_eliminator c = match kind_of_term c with
   | App _    -> true
   | Case _ -> true
-  | Cast (c,_) -> is_eliminator c
+  | Cast (c,_,_) -> is_eliminator c
   | _ -> false
 
 let head_is_embedded_evar isevars c =
@@ -373,11 +560,39 @@ let head_evar =
     | Evar (ev,_)       -> ev
     | Case (_,_,c,_) -> hrec c
     | App (c,_)        -> hrec c
-    | Cast (c,_)        -> hrec c
+    | Cast (c,_,_)        -> hrec c
     | _                   -> failwith "headconstant"
   in 
   hrec 
 
+(* Check if an applied evar "?X[args] l" is a Miller's pattern; note
+   that we don't care whether args itself contains Rel's or even Rel's
+   distinct from the ones in l *)
+
+let is_unification_pattern_evar (_,args) l =
+  let l' = Array.to_list args @ l in
+  List.for_all (fun a -> isRel a or isVar a) l' & list_distinct l'
+
+let is_unification_pattern f l =
+  match kind_of_term f with
+    | Meta _ -> array_for_all isRel l & array_distinct l
+    | Evar ev -> is_unification_pattern_evar ev (Array.to_list l)
+    | _ -> false
+
+(* From a unification problem "?X l1 = term1 l2" such that l1 is made
+   of distinct rel's, build "\x1...xn.(term1 l2)" (patterns unification) *)
+
+let solve_pattern_eqn env l1 c =
+  let c' = List.fold_right (fun a c ->
+    let c' = subst_term (lift 1 a) (lift 1 c) in
+    match kind_of_term a with
+      (* Rem: if [a] links to a let-in, do as if it were an assumption *)
+      | Rel n -> let (na,_,t) = lookup_rel n env in mkLambda (na,lift n t,c')
+      | Var id -> let (id,_,t) = lookup_named id env in mkNamedLambda id t c'
+      | _ -> assert false) 
+    l1 c in
+  whd_eta c'
+
 (* This code (i.e. solve_pb, etc.) takes a unification
  * problem, and tries to solve it. If it solves it, then it removes
  * all the conversion problems, and re-runs conversion on each one, in
@@ -410,75 +625,87 @@ let status_changed lev (pbty,t1,t2) =
   with Failure _ ->
     try List.mem (head_evar t2) lev with Failure _ -> false
 
-let get_changed_pb isevars lev =
-  let (pbs,pbs1) = 
-    List.fold_left
-      (fun (pbs,pbs1) pb ->
-    	 if status_changed lev pb then 
-	   (pb::pbs,pbs1)
-         else 
-	   (pbs,pb::pbs1))
-      ([],[])
-      isevars.conv_pbs
-  in
-  isevars.conv_pbs <- pbs1;
-  pbs
-
 (* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint
  * definitions. We try to unify the xi with the yi pairwise. The pairs
  * that don't unify are discarded (i.e. ?i is redefined so that it does not
  * depend on these args). *)
 
 let solve_refl conv_algo env isevars ev argsv1 argsv2 =
-  if argsv1 = argsv2 then [] else
-  let evd = Evd.map isevars.evars ev in
-  let hyps = evd.evar_hyps in
-  let (_,rsign) = 
+  if argsv1 = argsv2 then (isevars,[]) else
+  let evd = Evd.find (evars_of isevars) ev in
+  let hyps = evar_context evd in
+  let (isevars',_,rsign) = 
     array_fold_left2
-      (fun (sgn,rsgn) a1 a2 ->
-	 if conv_algo env isevars CONV a1 a2 then 
-	   (List.tl sgn, add_named_decl (List.hd sgn) rsgn)
+      (fun (isevars,sgn,rsgn) a1 a2 ->
+        let (isevars',b) = conv_algo env isevars Reduction.CONV a1 a2 in
+	 if b then 
+	   (isevars',List.tl sgn, add_named_decl (List.hd sgn) rsgn)
 	 else 
-	   (List.tl  sgn, rsgn))
-      (hyps,[]) argsv1 argsv2 
+	   (isevars,List.tl  sgn, rsgn))
+      (isevars,hyps,[]) argsv1 argsv2 
   in
   let nsign = List.rev rsign in
-  let nargs = (Array.of_list (List.map mkVar (ids_of_named_context nsign))) in
-  let newev = new_evar () in
-  let info = { evar_concl = evd.evar_concl; evar_hyps = nsign;
-	       evar_body = Evar_empty } in
-  isevars.evars <-
-    Evd.define (Evd.add isevars.evars newev info) ev (mkEvar (newev,nargs));
-  isevars.history <- (newev,evar_source ev isevars)::isevars.history;
-  [ev]
+  let (evd',newev) =
+    let env =
+      Sign.fold_named_context push_named nsign ~init:(reset_context env) in
+    new_evar isevars env ~src:(evar_source ev isevars) evd.evar_concl in
+  let evd'' = Evd.evar_define ev newev evd' in
+  evd'', [ev]
 
 
 (* Tries to solve problem t1 = t2.
- * Precondition: t1 is an uninstanciated evar
+ * Precondition: t1 is an uninstantiated evar
  * Returns an optional list of evars that were instantiated, or None
  * if the problem couldn't be solved. *)
 
 (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *)
 let solve_simple_eqn conv_algo env isevars (pbty,(n1,args1 as ev1),t2) =
-  let t2 = nf_evar isevars.evars t2 in
-  let lsp = match kind_of_term t2 with
-    | Evar (n2,args2 as ev2)
-        when not (Evd.is_defined isevars.evars n2) ->
-	if n1 = n2 then
-	  solve_refl conv_algo env isevars n1 args1 args2
-	else
-	  if Array.length args1 < Array.length args2 then 
-	    evar_define env isevars ev2 (mkEvar ev1)
-	  else 
-	    evar_define env isevars ev1 t2
-    | _ ->
-	evar_define env isevars ev1 t2 in
-  let pbs = get_changed_pb isevars lsp in
-  List.for_all (fun (pbty,t1,t2) -> conv_algo env isevars pbty t1 t2) pbs
+  try
+    let t2 = nf_evar (evars_of isevars) t2 in
+    let (isevars,lsp) = match kind_of_term t2 with
+      | Evar (n2,args2 as ev2) ->
+	  if n1 = n2 then
+	    solve_refl conv_algo env isevars n1 args1 args2
+	  else
+            (try evar_define env ev1 t2 isevars
+            with e when precatchable_exception e ->
+              evar_define env ev2 (mkEvar ev1) isevars)
+(*	    if Array.length args1 < Array.length args2 then
+	      evar_define env ev2 (mkEvar ev1) isevars
+	    else 
+	      evar_define env ev1 t2 isevars*)
+      | _ ->
+	  evar_define env ev1 t2 isevars in
+    let (isevars,pbs) = get_conv_pbs isevars (status_changed lsp) in
+    List.fold_left
+      (fun (isevars,b as p) (pbty,t1,t2) ->
+	if b then conv_algo env isevars pbty t1 t2 else p) (isevars,true)
+      pbs
+  with e when precatchable_exception e ->
+    (isevars,false)
+
+
+(* [check_evars] fails if some unresolved evar remains *)
+(* it assumes that the defined existentials have already been substituted *)
+
+let check_evars env initial_sigma isevars c =
+  let sigma = evars_of isevars in
+  let c = nf_evar sigma c in
+  let rec proc_rec c =
+    match kind_of_term c with
+      | Evar (ev,args) ->
+          assert (Evd.mem sigma ev);
+	  if not (Evd.mem initial_sigma ev) then
+            let (loc,k) = evar_source ev isevars in
+	    error_unsolvable_implicit loc env sigma k
+      | _ -> iter_constr proc_rec c
+  in proc_rec c
 
 (* Operations on value/type constraints *)
 
-type type_constraint = constr option
+type type_constraint_type = (int * int) option * constr
+type type_constraint = type_constraint_type option
+
 type val_constraint = constr option
 
 (* Old comment...
@@ -498,8 +725,14 @@ type val_constraint = constr option
 (* The empty type constraint *)
 let empty_tycon = None
 
+let mk_tycon_type c = (None, c)
+let mk_abstr_tycon_type n c = (Some (n, n), c) (* First component is initial abstraction, second
+						  is current abstraction *)
+
 (* Builds a type constraint *)
-let mk_tycon ty = Some ty
+let mk_tycon ty = Some (mk_tycon_type ty)
+
+let mk_abstr_tycon n ty = Some (mk_abstr_tycon_type n ty)
 
 (* Constrains the value of a type *)
 let empty_valcon = None
@@ -509,41 +742,98 @@ let mk_valcon c = Some c
 
 (* Refining an evar to a product or a sort *)
 
-let refine_evar_as_arrow isevars ev =
-  let (sigma,prod,evdom,evrng) = split_evar_to_arrow isevars.evars ev in
-  evars_reset_evd sigma isevars;
-  let hst = evar_source (fst ev) isevars in
-  isevars.history <- (fst evrng,hst)::(fst evdom, hst)::isevars.history;
-  (prod,evdom,evrng)
+(* Declaring any type to be in the sort Type shouldn't be harmful since
+   cumulativity now includes Prop and Set in Type...
+   It is, but that's not too bad *)
+let define_evar_as_abstraction abs evd (ev,args) =
+  let evi = Evd.find (evars_of evd) ev in
+  let evenv = evar_env evi in
+  let (evd1,dom) = new_evar evd evenv (new_Type()) in
+  let nvar =
+    next_ident_away (id_of_string "x")
+      (ids_of_named_context (evar_context evi)) in
+  let newenv = push_named (nvar, None, dom) evenv in
+  let (evd2,rng) =
+    new_evar evd1 newenv ~src:(evar_source ev evd1) (new_Type()) in
+  let prod = abs (Name nvar, dom, subst_var nvar rng) in
+  let evd3 = Evd.evar_define ev prod evd2 in
+  let evdom = fst (destEvar dom), args in
+  let evrng =
+    fst (destEvar rng), array_cons (mkRel 1) (Array.map (lift 1) args) in
+  let prod' = abs (Name nvar, mkEvar evdom, mkEvar evrng) in
+  (evd3,prod')
+
+let define_evar_as_arrow evd (ev,args) =
+  define_evar_as_abstraction (fun t -> mkProd t) evd (ev,args)
 
-let define_evar_as_arrow isevars ev =
-  let (prod,_,_) = refine_evar_as_arrow isevars ev in
-  prod
+let define_evar_as_lambda evd (ev,args) =
+  define_evar_as_abstraction (fun t -> mkLambda t) evd (ev,args)
 
 let define_evar_as_sort isevars (ev,args) =
   let s = new_Type () in
-  let sigma' = Evd.define isevars.evars ev s in
-  evars_reset_evd sigma' isevars;
-  destSort s
+  Evd.evar_define ev s isevars, destSort s
+
 
+(* We don't try to guess in which sort the type should be defined, since
+   any type has type Type. May cause some trouble, but not so far... *)
+
+let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
 
 (* Propagation of constraints through application and abstraction:
    Given a type constraint on a functional term, returns the type
    constraint on its domain and codomain. If the input constraint is
    an evar instantiate it with the product of 2 new evars. *)
 
-let split_tycon loc env isevars = function
-  | None -> Anonymous,None,None
-  | Some c ->
-      let sigma = evars_of isevars in
-      let t = whd_betadeltaiota env sigma c in
+let split_tycon loc env isevars tycon = 
+  let rec real_split c = 
+    let sigma = evars_of isevars in
+    let t = whd_betadeltaiota env sigma c in
       match kind_of_term t with
-        | Prod (na,dom,rng) -> na, Some dom, Some rng
-	| Evar (n,_ as ev) when not (Evd.is_defined isevars.evars n) ->
-	    let (_,evdom,evrng) = refine_evar_as_arrow isevars ev in
-	    Anonymous, Some (mkEvar evdom), Some (mkEvar evrng)
+	| Prod (na,dom,rng) -> isevars, (na, dom, rng)
+	| Evar ev when not (Evd.is_defined_evar isevars ev) ->
+	    let (isevars',prod) = define_evar_as_arrow isevars ev in
+	    let (_,dom,rng) = destProd prod in
+	      isevars',(Anonymous, dom, rng)
 	| _ -> error_not_product_loc loc env sigma c
+  in
+    match tycon with
+      | None -> isevars,(Anonymous,None,None)
+      | Some (abs, c) ->
+	  (match abs with
+	       None -> 
+		 let isevars', (n, dom, rng) = real_split c in
+		   isevars', (n, mk_tycon dom, mk_tycon rng)
+	     | Some (init, cur) ->
+		 if cur = 0 then 
+		   let isevars', (x, dom, rng) = real_split c in
+		     isevars, (Anonymous, 
+			       Some (Some (init, 0), dom), 
+			       Some (Some (init, 0), rng))
+		 else
+		   isevars, (Anonymous, None, Some (Some (init, pred cur), c)))
+
+let valcon_of_tycon x = 
+  match x with
+    | Some (None, t) -> Some t
+    | _ -> None
+	
+let lift_abstr_tycon_type n (abs, t) =
+  match abs with 
+      None -> raise (Invalid_argument "lift_abstr_tycon_type: not an abstraction")
+    | Some (init, abs) ->
+	let abs' = abs + n in 
+	  if abs' < 0 then raise (Invalid_argument "lift_abstr_tycon_type")
+	  else (Some (init, abs'), t)
+
+let lift_tycon_type n (abs, t) = (abs, lift n t)
+let lift_tycon n = option_map (lift_tycon_type n)
+
+let pr_tycon_type env (abs, t) =
+  match abs with 
+      None -> Termops.print_constr_env env t
+    | Some (init, cur) -> str "Abstract (" ++ int init ++ str ","  ++ int cur ++ str ") " ++ Termops.print_constr_env env t
+	
+let pr_tycon env = function
+    None -> str "None"
+  | Some t -> pr_tycon_type env t
 
-let valcon_of_tycon x = x
-
-let lift_tycon = option_app (lift 1)
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index 011d2a92..896bf26c 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evarutil.mli,v 1.33.2.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: evarutil.mli 9573 2007-01-31 20:18:18Z notin $ i*)
 
 (*i*)
 open Util
@@ -21,77 +21,145 @@ open Reductionops
 
 (*s This modules provides useful functions for unification modulo evars *)
 
-(* [whd_ise] raise [Uninstantiated_evar] if an evar remains uninstantiated; *)
-(* *[whd_evar]* and *[nf_evar]* leave uninstantiated evar as is *)
+(***********************************************************)
+(* Metas *)
 
-val nf_evar :  evar_map -> constr -> constr
-val j_nf_evar :  evar_map -> unsafe_judgment -> unsafe_judgment
-val jl_nf_evar :
-   evar_map -> unsafe_judgment list -> unsafe_judgment list
-val jv_nf_evar :
-   evar_map -> unsafe_judgment array -> unsafe_judgment array
-val tj_nf_evar :
-   evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+(* [new_meta] is a generator of unique meta variables *)
+val new_meta : unit -> metavariable
+val mk_new_meta : unit -> constr
 
-(* Replacing all evars *)
-exception Uninstantiated_evar of existential_key
-val whd_ise :  evar_map -> constr -> constr
-val whd_castappevar :  evar_map -> constr -> constr
+(* [new_untyped_evar] is a generator of unique evar keys *)
+val new_untyped_evar : unit -> existential_key
+
+(***********************************************************)
+(* Creating a fresh evar given their type and context *)
+val new_evar :
+  evar_defs -> env -> ?src:loc * hole_kind -> types -> evar_defs * constr
+(* the same with side-effects *)
+val e_new_evar :
+  evar_defs ref -> env -> ?src:loc * hole_kind -> types -> constr
 
-(* Creating new existential variables *)
-val new_evar : unit -> evar
-val new_evar_in_sign : env -> constr
+(* Create a fresh evar in a context different from its definition context:
+   [new_evar_instance sign evd ty inst] creates a new evar of context
+   [sign] and type [ty], [inst] is a mapping of the evar context to
+   the context where the evar should occur. This means that the terms 
+   of [inst] are typed in the occurrence context and their type (seen
+   as a telescope) is [sign] *)
+val new_evar_instance :
+ named_context_val -> evar_defs -> types -> ?src:loc * hole_kind ->
+   constr list -> evar_defs * constr
 
-val evar_env :  evar_info -> env
+(***********************************************************)
+(* Instanciate evars *)
 
-type evar_defs
-val evars_of :  evar_defs ->  evar_map
-val create_evar_defs :  evar_map ->  evar_defs
-val evars_reset_evd :  evar_map ->  evar_defs -> unit
-val evar_source : existential_key -> evar_defs -> loc * hole_kind
+(* suspicious env ? *)
+val evar_define :
+  env -> existential -> constr -> evar_defs -> evar_defs * evar list
 
-type evar_constraint = conv_pb * constr * constr
-val add_conv_pb :  evar_defs -> evar_constraint -> unit
 
-val is_defined_evar :  evar_defs -> existential -> bool
-val ise_try :  evar_defs -> (unit -> bool) list -> bool
-val ise_undefined :  evar_defs -> constr -> bool
-val has_undefined_isevars :  evar_defs -> constr -> bool
+(***********************************************************)
+(* Evars/Metas switching... *)
 
-val new_isevar_sign :
- Environ.env -> Evd.evar_map -> Term.constr -> Term.constr list ->
-  Evd.evar_map * Term.constr
+(* [evars_to_metas] generates new metavariables for each non dependent
+   existential and performs the replacement in the given constr; it also
+   returns the evar_map extended with dependent evars *)
+val evars_to_metas : evar_map -> open_constr -> (evar_map * constr)
 
-val new_isevar :  evar_defs -> env -> loc * hole_kind -> constr -> constr
+val non_instantiated : evar_map -> (evar * evar_info) list
 
+(***********************************************************)
+(* Unification utils *)
+
+val is_ground_term :  evar_defs -> constr -> bool
 val is_eliminator : constr -> bool
 val head_is_embedded_evar :  evar_defs -> constr -> bool
 val solve_simple_eqn :
-  (env ->  evar_defs -> conv_pb -> constr -> constr -> bool)
-  -> env ->  evar_defs -> conv_pb * existential * constr -> bool
+  (env ->  evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool)
+  -> env ->  evar_defs -> conv_pb * existential * constr ->
+    evar_defs * bool
+
+(* [check_evars env initial_sigma extended_sigma c] fails if some
+   new unresolved evar remains in [c] *)
+val check_evars : env -> evar_map -> evar_defs -> constr -> unit
+
+val define_evar_as_arrow : evar_defs -> existential -> evar_defs * types
+val define_evar_as_lambda : evar_defs -> existential -> evar_defs * types
+val define_evar_as_sort : evar_defs -> existential -> evar_defs * sorts
 
-val define_evar_as_arrow : evar_defs -> existential -> types
-val define_evar_as_sort : evar_defs -> existential -> sorts
+val is_unification_pattern_evar : existential -> constr list -> bool
+val is_unification_pattern : constr -> constr array -> bool
+val solve_pattern_eqn : env -> constr list -> constr -> constr
 
+(***********************************************************)
 (* Value/Type constraints *)
 
-val new_Type_sort : unit -> sorts
-val new_Type : unit -> constr
 val judge_of_new_Type : unit -> unsafe_judgment
-val refresh_universes : types -> types
 
-type type_constraint = constr option
+type type_constraint_type = (int * int) option * constr
+type type_constraint = type_constraint_type option
+
 type val_constraint = constr option
 
 val empty_tycon : type_constraint
+val mk_tycon_type : constr -> type_constraint_type
+val mk_abstr_tycon_type : int -> constr -> type_constraint_type
 val mk_tycon : constr -> type_constraint
+val mk_abstr_tycon : int -> constr -> type_constraint
 val empty_valcon : val_constraint
 val mk_valcon : constr -> val_constraint
 
 val split_tycon :
   loc -> env ->  evar_defs -> type_constraint -> 
-    name * type_constraint * type_constraint
+    evar_defs * (name * type_constraint * type_constraint)
 
 val valcon_of_tycon : type_constraint -> val_constraint
 
-val lift_tycon : type_constraint -> type_constraint
+val lift_abstr_tycon_type : int -> type_constraint_type -> type_constraint_type
+
+val lift_tycon_type : int -> type_constraint_type -> type_constraint_type
+val lift_tycon : int -> type_constraint -> type_constraint
+
+(***********************************************************)
+
+(* [whd_ise] raise [Uninstantiated_evar] if an evar remains uninstantiated; *)
+(* *[whd_evar]* and *[nf_evar]* leave uninstantiated evar as is *)
+
+val nf_evar :  evar_map -> constr -> constr
+val j_nf_evar :  evar_map -> unsafe_judgment -> unsafe_judgment
+val jl_nf_evar :
+   evar_map -> unsafe_judgment list -> unsafe_judgment list
+val jv_nf_evar :
+   evar_map -> unsafe_judgment array -> unsafe_judgment array
+val tj_nf_evar :
+   evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+
+val nf_evar_info : evar_map -> evar_info -> evar_info
+val nf_evars : evar_map -> evar_map
+
+(* Same for evar defs *)
+val nf_isevar :  evar_defs -> constr -> constr
+val j_nf_isevar :  evar_defs -> unsafe_judgment -> unsafe_judgment
+val jl_nf_isevar :
+   evar_defs -> unsafe_judgment list -> unsafe_judgment list
+val jv_nf_isevar :
+   evar_defs -> unsafe_judgment array -> unsafe_judgment array
+val tj_nf_isevar :
+   evar_defs -> unsafe_type_judgment -> unsafe_type_judgment
+
+val nf_evar_defs : evar_defs -> evar_defs
+
+(* Replacing all evars *)
+exception Uninstantiated_evar of existential_key
+val whd_ise :  evar_map -> constr -> constr
+val whd_castappevar :  evar_map -> constr -> constr
+
+(*********************************************************************)
+(* debug pretty-printer: *)
+
+val pr_tycon_type : env -> type_constraint_type -> Pp.std_ppcmds
+val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
+
+
+(**********************************)
+(* Removing hyps in evars'context *)
+val clear_hyps_in_evi : evar_defs ref -> evar_info -> identifier list -> evar_info
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 7a3e7c02..c68a7a73 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -6,12 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evd.ml,v 1.3.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+(* $Id: evd.ml 9573 2007-01-31 20:18:18Z notin $ *)
 
+open Pp
 open Util
 open Names
+open Nameops
 open Term
+open Termops
 open Sign
+open Environ
+open Libnames
+open Mod_subst
 
 (* The type of mappings for existential variables *)
 
@@ -23,52 +29,543 @@ type evar_body =
 
 type evar_info = {
   evar_concl : constr;
-  evar_hyps : named_context;
-  evar_body : evar_body}
+  evar_hyps : named_context_val;
+  evar_body : evar_body;
+  evar_extra : Dyn.t option}
+
+let evar_context evi = named_context_of_val evi.evar_hyps
+
+let eq_evar_info ei1 ei2 =
+  ei1 == ei2 || 
+    eq_constr ei1.evar_concl ei2.evar_concl && 
+    eq_named_context_val (ei1.evar_hyps) (ei2.evar_hyps) &&
+    ei1.evar_body = ei2.evar_body
 
 module Evarmap = Intmap
 
-type evar_map = evar_info Evarmap.t
+type evar_map1 = evar_info Evarmap.t
 
 let empty = Evarmap.empty
 
-let to_list evc = Evarmap.fold (fun ev x acc -> (ev,x)::acc) evc []
+let to_list evc = (* Workaround for change in Map.fold behavior *)
+  let l = ref [] in 
+    Evarmap.iter (fun ev x -> l:=(ev,x)::!l) evc;
+    !l
+
 let dom evc = Evarmap.fold (fun ev _ acc -> ev::acc) evc []
-let map evc k = Evarmap.find k evc
-let rmv evc k = Evarmap.remove k evc
-let remap evc k i = Evarmap.add k i evc
-let in_dom evc k = Evarmap.mem k evc
+let find evc k = Evarmap.find k evc
+let remove evc k = Evarmap.remove k evc
+let mem evc k = Evarmap.mem k evc
+let fold = Evarmap.fold
 
 let add evd ev newinfo =  Evarmap.add ev newinfo evd
 
 let define evd ev body = 
-  let oldinfo = map evd ev in
+  let oldinfo =
+    try find evd ev
+    with Not_found -> error "Evd.define: cannot define undeclared evar" in
   let newinfo =
-    { evar_concl = oldinfo.evar_concl;
-      evar_hyps = oldinfo.evar_hyps;
-      evar_body = Evar_defined body} 
-  in
+    { oldinfo with
+      evar_body = Evar_defined body } in
   match oldinfo.evar_body with
     | Evar_empty -> Evarmap.add ev newinfo evd
-    | _ -> anomaly "cannot define an isevar twice"
-
-(* The list of non-instantiated existential declarations *)
-
-let non_instantiated sigma = 
-  let listev = to_list sigma in
-  List.fold_left 
-    (fun l ((ev,evd) as d) -> 
-       if evd.evar_body = Evar_empty then (d::l) else l)
-    [] listev
+    | _ -> anomaly "Evd.define: cannot define an isevar twice"
     
-let is_evar sigma ev = in_dom sigma ev
+let is_evar sigma ev = mem sigma ev
 
 let is_defined sigma ev =
-  let info = map sigma ev in 
+  let info = find sigma ev in 
   not (info.evar_body = Evar_empty)
 
+let evar_concl ev = ev.evar_concl
+let evar_hyps ev = ev.evar_hyps
 let evar_body ev = ev.evar_body
+let evar_env evd = Global.env_of_context evd.evar_hyps
 
 let string_of_existential ev = "?" ^ string_of_int ev
 
 let existential_of_int ev = ev
+
+(*******************************************************************)
+(* Formerly Instantiate module *)
+
+let is_id_inst inst =
+  let is_id (id,c) = match kind_of_term c with
+    | Var id' -> id = id'
+    | _ -> false
+  in
+  List.for_all is_id inst
+
+(* Vérifier que les instances des let-in sont compatibles ?? *)
+let instantiate_sign_including_let sign args =
+  let rec instrec = function
+    | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args))
+    | ([],[])                        -> []
+    | ([],_) | (_,[]) ->
+    anomaly "Signature and its instance do not match"
+  in 
+  instrec (sign,args)
+
+let instantiate_evar sign c args =
+  let inst = instantiate_sign_including_let sign args in
+  if is_id_inst inst then
+    c
+  else
+    replace_vars inst c
+
+(* Existentials. *)
+
+let existential_type sigma (n,args) =
+  let info =
+    try find sigma n
+    with Not_found ->
+      anomaly ("Evar "^(string_of_existential n)^" was not declared") in
+  let hyps = evar_context info in
+  instantiate_evar hyps info.evar_concl (Array.to_list args)
+
+exception NotInstantiatedEvar
+
+let existential_value sigma (n,args) =
+  let info = find sigma n in
+  let hyps = evar_context info in
+  match evar_body info with
+    | Evar_defined c ->
+	instantiate_evar hyps c (Array.to_list args)
+    | Evar_empty ->
+	raise NotInstantiatedEvar
+
+let existential_opt_value sigma ev =
+  try Some (existential_value sigma ev)
+  with NotInstantiatedEvar -> None
+
+(*******************************************************************)
+(*                Constraints for sort variables                   *)
+(*******************************************************************)
+
+type sort_var = Univ.universe
+
+type sort_constraint =
+  | DefinedSort of sorts (* instantiated sort var *)
+  | SortVar of sort_var list * sort_var list (* (leq,geq) *)
+  | EqSort of sort_var
+
+module UniverseOrdered = struct
+  type t = Univ.universe
+  let compare = Pervasives.compare
+end
+module UniverseMap = Map.Make(UniverseOrdered)
+
+type sort_constraints = sort_constraint UniverseMap.t
+
+let rec canonical_find u scstr =
+  match UniverseMap.find u scstr with
+      EqSort u' -> canonical_find u' scstr
+    | c -> (u,c)
+
+let whd_sort_var scstr t =
+  match kind_of_term t with
+      Sort(Type u) ->
+        (try
+          match canonical_find u scstr with
+              _, DefinedSort s -> mkSort s
+            | _ -> t
+        with Not_found -> t)
+    | _ -> t
+
+let rec set_impredicative u s scstr =
+  match UniverseMap.find u scstr with
+    | DefinedSort s' ->
+        if family_of_sort s = family_of_sort s' then scstr
+        else failwith "sort constraint inconsistency"
+    | EqSort u' ->
+        UniverseMap.add u (DefinedSort s) (set_impredicative u' s scstr)
+    | SortVar(_,ul) ->
+        (* also set sorts lower than u as impredicative *)
+        UniverseMap.add u (DefinedSort s)
+          (List.fold_left (fun g u' -> set_impredicative u' s g) scstr ul)
+
+let rec set_predicative u s scstr =
+  match UniverseMap.find u scstr with
+    | DefinedSort s' ->
+        if family_of_sort s = family_of_sort s' then scstr
+        else failwith "sort constraint inconsistency"
+    | EqSort u' ->
+        UniverseMap.add u (DefinedSort s) (set_predicative u' s scstr)
+    | SortVar(ul,_) ->
+        UniverseMap.add u (DefinedSort s)
+          (List.fold_left (fun g u' -> set_impredicative u' s g) scstr ul)
+
+let var_of_sort = function
+    Type u -> u
+  | _ -> assert false
+
+let is_sort_var s scstr =
+  match s with
+      Type u ->
+        (try
+          match canonical_find u scstr with
+              _, DefinedSort _ -> false
+            | _ -> true
+        with Not_found -> false)
+    | _ -> false
+
+let new_sort_var cstr =
+  let u = Termops.new_univ() in
+  (u, UniverseMap.add u (SortVar([],[])) cstr)
+
+
+let set_leq_sort (u1,(leq1,geq1)) (u2,(leq2,geq2)) scstr =
+  let rec search_rec (is_b, betw, not_betw) u1 =
+    if List.mem u1 betw then (true, betw, not_betw)
+    else if List.mem u1 not_betw then (is_b, betw, not_betw)
+    else if u1 = u2 then (true, u1::betw,not_betw) else
+      match UniverseMap.find u1 scstr with
+          EqSort u1' -> search_rec (is_b,betw,not_betw) u1'
+        | SortVar(leq,_) ->
+            let (is_b',betw',not_betw') = 
+              List.fold_left search_rec (false,betw,not_betw) leq in
+            if is_b' then (true, u1::betw', not_betw')
+            else (false, betw', not_betw')
+        | DefinedSort _ -> (false,betw,u1::not_betw) in
+  let (is_betw,betw,_) = search_rec (false, [], []) u1 in
+  if is_betw then
+    UniverseMap.add u1 (SortVar(leq1@leq2,geq1@geq2))
+      (List.fold_left
+        (fun g u -> UniverseMap.add u (EqSort u1) g) scstr betw)
+  else
+    UniverseMap.add u1 (SortVar(u2::leq1,geq1))
+      (UniverseMap.add u2 (SortVar(leq2, u1::geq2)) scstr)
+
+let set_leq s1 s2 scstr =
+  let u1 = var_of_sort s1 in
+  let u2 = var_of_sort s2 in
+  let (cu1,c1) = canonical_find u1 scstr in
+  let (cu2,c2) = canonical_find u2 scstr in
+  if cu1=cu2 then scstr
+  else
+    match c1,c2 with
+        (EqSort _, _ | _, EqSort _) -> assert false
+      | SortVar(leq1,geq1), SortVar(leq2,geq2) ->
+          set_leq_sort (cu1,(leq1,geq1)) (cu2,(leq2,geq2)) scstr
+      | _, DefinedSort(Prop _ as s) -> set_impredicative u1 s scstr
+      | _, DefinedSort(Type _) -> scstr
+      | DefinedSort(Type _ as s), _ -> set_predicative u2 s scstr
+      | DefinedSort(Prop _), _ -> scstr
+
+let set_sort_variable s1 s2 scstr =
+  let u = var_of_sort s1 in
+  match s2 with
+      Prop _ -> set_impredicative u s2 scstr
+    | Type _ -> set_predicative u s2 scstr
+
+let pr_sort_cstrs g =
+  let l = UniverseMap.fold (fun u c l -> (u,c)::l) g [] in
+  str "SORT CONSTRAINTS:" ++ fnl() ++
+  prlist_with_sep fnl (fun (u,c) ->
+    match c with
+        EqSort u' -> Univ.pr_uni u ++ str" == " ++ Univ.pr_uni u'
+      | DefinedSort s -> Univ.pr_uni u ++ str " := " ++ print_sort s
+      | SortVar(leq,geq) ->
+          str"[" ++ hov 0 (prlist_with_sep spc Univ.pr_uni geq) ++
+          str"] <= "++ Univ.pr_uni u ++ brk(0,0) ++ str"<= [" ++
+          hov 0 (prlist_with_sep spc Univ.pr_uni leq) ++ str"]")
+    l
+
+type evar_map = evar_map1 * sort_constraints
+let empty = empty, UniverseMap.empty
+let add (sigma,sm) k v = (add sigma k v, sm)
+let dom (sigma,_) = dom sigma
+let find (sigma,_) = find sigma
+let remove (sigma,sm) k = (remove sigma k, sm)
+let mem (sigma,_) = mem sigma
+let to_list (sigma,_) = to_list sigma
+let fold f (sigma,_) = fold f sigma
+let define (sigma,sm) k v = (define sigma k v, sm)
+let is_evar (sigma,_) = is_evar sigma
+let is_defined (sigma,_) = is_defined sigma
+let existential_value (sigma,_) = existential_value sigma
+let existential_type (sigma,_) = existential_type sigma
+let existential_opt_value (sigma,_) = existential_opt_value sigma
+
+(*******************************************************************)
+type open_constr = evar_map * constr
+
+(*******************************************************************)
+(* The type constructor ['a sigma] adds an evar map to an object of
+  type ['a] *)
+type 'a sigma = {
+  it : 'a ;
+  sigma : evar_map}
+ 
+let sig_it x = x.it
+let sig_sig x = x.sigma
+ 
+(*******************************************************************)
+(* Metamaps *)
+
+(*******************************************************************)
+(*            Constraints for existential variables                *)
+(*******************************************************************)
+
+type 'a freelisted = {
+  rebus : 'a;
+  freemetas : Intset.t }
+
+(* Collects all metavars appearing in a constr *)
+let metavars_of c =
+  let rec collrec acc c =
+    match kind_of_term c with
+      | Meta mv -> Intset.add mv acc
+      | _         -> fold_constr collrec acc c
+  in
+  collrec Intset.empty c
+
+let mk_freelisted c =
+  { rebus = c; freemetas = metavars_of c }
+
+let map_fl f cfl = { cfl with rebus=f cfl.rebus }
+
+
+(* Clausal environments *)
+
+type clbinding =
+  | Cltyp of name * constr freelisted
+  | Clval of name * constr freelisted * constr freelisted
+
+let map_clb f = function
+  | Cltyp (na,cfl) -> Cltyp (na,map_fl f cfl)
+  | Clval (na,cfl1,cfl2) -> Clval (na,map_fl f cfl1,map_fl f cfl2)
+
+(* name of defined is erased (but it is pretty-printed) *)
+let clb_name = function
+    Cltyp(na,_) -> (na,false)
+  | Clval (na,_,_) -> (na,true)
+
+(***********************)
+                                                                               
+module Metaset = Intset
+                                                                               
+let meta_exists p s = Metaset.fold (fun x b -> b || (p x)) s false
+
+module Metamap = Intmap
+
+let metamap_to_list m =
+  Metamap.fold (fun n v l -> (n,v)::l) m []
+ 
+(*************************)
+(* Unification state *)
+
+type hole_kind =
+  | ImplicitArg of global_reference * (int * identifier option)
+  | BinderType of name
+  | QuestionMark
+  | CasesType
+  | InternalHole
+  | TomatchTypeParameter of inductive * int
+
+type conv_pb = Reduction.conv_pb
+type evar_constraint = conv_pb * constr * constr
+type evar_defs =
+    { evars : evar_map;
+      conv_pbs : evar_constraint list;
+      history : (existential_key * (loc * hole_kind)) list;
+      metas : clbinding Metamap.t }
+
+let subst_evar_defs sub evd =
+  { evd with
+    conv_pbs =
+      List.map (fun (k,t1,t2) ->(k,subst_mps sub t1,subst_mps sub t2))
+        evd.conv_pbs;
+    metas = Metamap.map (map_clb (subst_mps sub)) evd.metas }
+
+let create_evar_defs sigma =
+  { evars=sigma; conv_pbs=[]; history=[]; metas=Metamap.empty }
+let evars_of d = d.evars
+let evars_reset_evd evd d = {d with evars = evd}
+let reset_evd (sigma,mmap) d = {d with evars = sigma; metas=mmap}
+let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs}
+let evar_source ev d =
+  try List.assoc ev d.history
+  with Not_found -> (dummy_loc, InternalHole)
+
+(* define the existential of section path sp as the constr body *)
+let evar_define sp body isevars =
+  {isevars with evars = define isevars.evars sp body}
+
+let evar_declare hyps evn ty ?(src=(dummy_loc,InternalHole)) evd =
+  { evd with
+    evars = add evd.evars evn
+      {evar_hyps=hyps; 
+       evar_concl=ty; 
+       evar_body=Evar_empty; 
+       evar_extra=None};
+    history = (evn,src)::evd.history }
+
+let is_defined_evar isevars (n,_) = is_defined isevars.evars n
+
+(* Does k corresponds to an (un)defined existential ? *)
+let is_undefined_evar isevars c = match kind_of_term c with
+  | Evar ev -> not (is_defined_evar isevars ev)
+  | _ -> false
+
+let undefined_evars isevars = 
+  let evd = 
+    fold (fun ev evi sigma -> if evi.evar_body = Evar_empty then 
+	    add sigma ev evi else sigma) 
+      isevars.evars empty
+  in 
+    { isevars with evars = evd }
+
+(* extracts conversion problems that satisfy predicate p *)
+(* Note: conv_pbs not satisying p are stored back in reverse order *)
+let get_conv_pbs isevars p =
+  let (pbs,pbs1) = 
+    List.fold_left
+      (fun (pbs,pbs1) pb ->
+    	 if p pb then 
+	   (pb::pbs,pbs1)
+         else 
+	   (pbs,pb::pbs1))
+      ([],[])
+      isevars.conv_pbs
+  in
+  {isevars with conv_pbs = pbs1},
+  pbs
+
+
+(**********************************************************)
+(* Sort variables *)
+
+let new_sort_variable (sigma,sm) =
+  let (u,scstr) = new_sort_var sm in
+  (Type u,(sigma,scstr))
+let is_sort_variable (_,sm) s =
+  is_sort_var s sm
+let whd_sort_variable (_,sm) t = whd_sort_var sm t
+let set_leq_sort_variable (sigma,sm) u1 u2 =
+  (sigma, set_leq u1 u2 sm)
+let define_sort_variable (sigma,sm) u s =
+  (sigma, set_sort_variable u s sm)
+let pr_sort_constraints (_,sm) = pr_sort_cstrs sm
+
+(**********************************************************)
+(* Accessing metas *)
+
+let meta_list evd = metamap_to_list evd.metas
+
+let meta_defined evd mv =
+  match Metamap.find mv evd.metas with
+    | Clval _ -> true
+    | Cltyp _ -> false
+ 
+let meta_fvalue evd mv =
+  match Metamap.find mv evd.metas with
+    | Clval(_,b,_) -> b
+    | Cltyp _ -> anomaly "meta_fvalue: meta has no value"
+           
+let meta_ftype evd mv =
+  match Metamap.find mv evd.metas with
+    | Cltyp (_,b) -> b
+    | Clval(_,_,b) -> b
+ 
+let meta_declare mv v ?(name=Anonymous) evd =
+  { evd with metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas }
+  
+let meta_assign mv v evd =
+  match Metamap.find mv evd.metas with
+      Cltyp(na,ty) ->
+        { evd with
+          metas = Metamap.add mv (Clval(na,mk_freelisted v, ty)) evd.metas }
+    | _ -> anomaly "meta_assign: already defined"
+
+(* If the meta is defined then forget its name *)
+let meta_name evd mv =
+  try
+    let (na,def) = clb_name (Metamap.find mv evd.metas) in
+    if def then Anonymous else na
+  with Not_found -> Anonymous
+
+let meta_with_name evd id =
+  let na = Name id in
+  let (mvl,mvnodef) =
+    Metamap.fold
+      (fun n clb (l1,l2 as l) ->
+        let (na',def) = clb_name clb in
+        if na = na' then if def then (n::l1,l2) else (n::l1,n::l2)
+        else l)
+      evd.metas ([],[]) in
+  match mvnodef, mvl with
+    | _,[]  -> 
+	errorlabstrm "Evd.meta_with_name"
+          (str"No such bound variable " ++ pr_id id)
+    | ([n],_|_,[n]) -> 
+	n
+    | _  -> 
+	errorlabstrm "Evd.meta_with_name"
+          (str "Binder name \"" ++ pr_id id ++
+           str"\" occurs more than once in clause")
+
+
+let meta_merge evd1 evd2 =
+  {evd2 with
+    metas = List.fold_left (fun m (n,v) -> Metamap.add n v m) 
+      evd2.metas (metamap_to_list evd1.metas) }
+
+
+(**********************************************************)
+(* Pretty-printing *)
+
+let pr_meta_map mmap =
+  let pr_name = function
+      Name id -> str"[" ++ pr_id id ++ str"]"
+    | _ -> mt() in
+  let pr_meta_binding = function
+    | (mv,Cltyp (na,b)) ->
+      	hov 0 
+	  (pr_meta mv ++ pr_name na ++ str " : " ++
+           print_constr b.rebus ++ fnl ())
+    | (mv,Clval(na,b,_)) ->
+      	hov 0 
+	  (pr_meta mv ++ pr_name na ++ str " := " ++
+           print_constr b.rebus ++ fnl ())
+  in
+  prlist pr_meta_binding (metamap_to_list mmap)
+
+let pr_idl idl = prlist_with_sep pr_spc pr_id idl
+
+let pr_evar_info evi =
+  let phyps = pr_idl (List.rev (ids_of_named_context (evar_context evi))) in
+  let pty = print_constr evi.evar_concl in
+  let pb =
+    match evi.evar_body with
+      | Evar_empty -> mt ()
+      | Evar_defined c -> spc() ++ str"=> "  ++ print_constr c
+  in
+  hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
+
+let pr_evar_map sigma =
+  h 0 
+    (prlist_with_sep pr_fnl
+      (fun (ev,evi) ->
+        h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
+      (to_list sigma))
+
+let pr_constraints pbs =
+  h 0
+    (prlist_with_sep pr_fnl (fun (pbty,t1,t2) ->
+      print_constr t1 ++ spc() ++
+      str (match pbty with
+	| Reduction.CONV -> "=="
+	| Reduction.CUMUL -> "<=") ++ 
+      spc() ++ print_constr t2) pbs)
+
+let pr_evar_defs evd =
+  let pp_evm =
+    if evd.evars = empty then mt() else
+      str"EVARS:"++brk(0,1)++pr_evar_map evd.evars++fnl() in
+  let cstrs =
+    str"CONSTRAINTS:"++brk(0,1)++pr_constraints evd.conv_pbs++fnl() in
+  let pp_met =
+    if evd.metas = Metamap.empty then mt() else
+      str"METAS:"++brk(0,1)++pr_meta_map evd.metas in
+  v 0 (pp_evm ++ cstrs ++ pp_met)
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index f66667aa..e1fc425b 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -6,12 +6,15 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evd.mli,v 1.3.2.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: evd.mli 9573 2007-01-31 20:18:18Z notin $ i*)
 
 (*i*)
+open Util
 open Names
 open Term
 open Sign
+open Libnames
+open Mod_subst
 (*i*)
 
 (* The type of mappings for existential variables.
@@ -28,9 +31,12 @@ type evar_body =
 
 type evar_info = {
   evar_concl : constr;
-  evar_hyps : named_context;
-  evar_body : evar_body}
+  evar_hyps : Environ.named_context_val;
+  evar_body : evar_body;
+  evar_extra : Dyn.t option}
 
+val eq_evar_info : evar_info -> evar_info -> bool
+val evar_context : evar_info -> named_context
 type evar_map
 
 val empty : evar_map
@@ -38,20 +44,134 @@ val empty : evar_map
 val add : evar_map -> evar -> evar_info -> evar_map
 
 val dom : evar_map -> evar list
-val map : evar_map -> evar -> evar_info
-val rmv : evar_map -> evar -> evar_map
-val remap : evar_map -> evar -> evar_info -> evar_map
-val in_dom : evar_map -> evar -> bool
+val find : evar_map -> evar -> evar_info
+val remove : evar_map -> evar -> evar_map
+val mem : evar_map -> evar -> bool
 val to_list : evar_map -> (evar * evar_info) list
+val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
 
 val define : evar_map -> evar -> constr -> evar_map
 
-val non_instantiated : evar_map -> (evar * evar_info) list
 val is_evar : evar_map -> evar -> bool
 
 val is_defined : evar_map -> evar -> bool
 
+val evar_concl : evar_info -> constr
+val evar_hyps : evar_info -> Environ.named_context_val
 val evar_body : evar_info -> evar_body
+val evar_env :  evar_info -> Environ.env
 
 val string_of_existential : evar -> string
 val existential_of_int : int -> evar
+
+(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
+    no body and [Not_found] if it does not exist in [sigma] *)
+
+exception NotInstantiatedEvar
+val existential_value : evar_map -> existential -> constr
+val existential_type : evar_map -> existential -> types
+val existential_opt_value : evar_map -> existential -> constr option
+
+(*********************************************************************)
+(* constr with holes *)
+type open_constr = evar_map * constr
+
+(*********************************************************************)
+(* The type constructor ['a sigma] adds an evar map to an object of
+  type ['a] *)
+type 'a sigma = {
+  it : 'a ;
+  sigma : evar_map}
+
+val sig_it  : 'a sigma -> 'a
+val sig_sig : 'a sigma -> evar_map
+
+(*********************************************************************)
+(* Meta map *)
+
+module Metaset : Set.S with type elt = metavariable
+
+val meta_exists : (metavariable -> bool) -> Metaset.t -> bool
+
+type 'a freelisted = {
+  rebus : 'a;
+  freemetas : Metaset.t }
+
+val metavars_of : constr -> Metaset.t
+val mk_freelisted : constr -> constr freelisted
+val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
+
+type clbinding =
+  | Cltyp of name * constr freelisted
+  | Clval of name * constr freelisted * constr freelisted
+
+val map_clb : (constr -> constr) -> clbinding -> clbinding
+
+(*********************************************************************)
+(* Unification state *)
+type evar_defs
+
+(* Substitution is not applied to the [evar_map] *)
+val subst_evar_defs : substitution -> evar_defs -> evar_defs
+
+(* create an [evar_defs] with empty meta map: *)
+val create_evar_defs : evar_map -> evar_defs
+val evars_of         : evar_defs -> evar_map
+val evars_reset_evd  : evar_map ->  evar_defs -> evar_defs
+
+(* Evars *)
+type hole_kind =
+  | ImplicitArg of global_reference * (int * identifier option)
+  | BinderType of name
+  | QuestionMark
+  | CasesType
+  | InternalHole
+  | TomatchTypeParameter of inductive * int
+val is_defined_evar :  evar_defs -> existential -> bool
+val is_undefined_evar :  evar_defs -> constr -> bool
+val undefined_evars : evar_defs -> evar_defs
+val evar_declare :
+  Environ.named_context_val -> evar -> types -> ?src:loc * hole_kind ->
+  evar_defs -> evar_defs
+val evar_define : evar -> constr -> evar_defs -> evar_defs
+val evar_source : existential_key -> evar_defs -> loc * hole_kind
+
+(* Unification constraints *)
+type conv_pb = Reduction.conv_pb
+type evar_constraint = conv_pb * constr * constr
+val add_conv_pb :  evar_constraint -> evar_defs -> evar_defs
+val get_conv_pbs : evar_defs -> (evar_constraint -> bool) -> 
+  evar_defs * evar_constraint list
+
+(* Metas *)
+val meta_list : evar_defs -> (metavariable * clbinding) list
+val meta_defined : evar_defs -> metavariable -> bool
+(* [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if
+   meta has no value *)  
+val meta_fvalue    : evar_defs -> metavariable -> constr freelisted
+val meta_ftype     : evar_defs -> metavariable -> constr freelisted
+val meta_name      : evar_defs -> metavariable -> name
+val meta_with_name : evar_defs -> identifier -> metavariable
+val meta_declare   :
+  metavariable -> types -> ?name:name -> evar_defs -> evar_defs
+val meta_assign    : metavariable -> constr -> evar_defs -> evar_defs
+
+(* [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
+val meta_merge : evar_defs -> evar_defs -> evar_defs
+
+(**********************************************************)
+(* Sort variables *)
+
+val new_sort_variable : evar_map -> sorts * evar_map
+val is_sort_variable : evar_map -> sorts -> bool
+val whd_sort_variable : evar_map -> constr -> constr
+val set_leq_sort_variable : evar_map -> sorts -> sorts -> evar_map
+val define_sort_variable : evar_map -> sorts -> sorts -> evar_map
+
+(*********************************************************************)
+(* debug pretty-printer: *)
+
+val pr_evar_info : evar_info -> Pp.std_ppcmds
+val pr_evar_map  : evar_map -> Pp.std_ppcmds
+val pr_evar_defs : evar_defs -> Pp.std_ppcmds
+val pr_sort_constraints : evar_map -> Pp.std_ppcmds
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index 0b9283ae..eeddcb64 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: indrec.ml,v 1.20.2.3 2004/07/16 19:30:44 herbelin Exp $ *)
+(* $Id: indrec.ml 9519 2007-01-22 18:13:29Z notin $ *)
 
 open Pp
 open Util
@@ -19,14 +19,21 @@ open Declarations
 open Entries
 open Inductive
 open Inductiveops
-open Instantiate
 open Environ
 open Reductionops
 open Typeops
 open Type_errors
-open Indtypes (* pour les erreurs *)
 open Safe_typing
 open Nametab
+open Sign
+
+(* Errors related to recursors building *)
+type recursion_scheme_error =
+  | NotAllowedCaseAnalysis of bool * sorts * inductive
+  | BadInduction of bool * identifier * sorts
+  | NotMutualInScheme
+
+exception RecursionSchemeError of recursion_scheme_error
 
 let make_prod_dep dep env = if dep then prod_name env else mkProd
 let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
@@ -41,19 +48,19 @@ let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
    lift_constructor et lift_inductive_family qui ne se contentent pas de 
    lifter les paramètres globaux *)
 
-let mis_make_case_com depopt env sigma (ind,mib,mip) kind =
-  let lnamespar = mip.mind_params_ctxt in
+let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind =
+  let lnamespar = mib.mind_params_ctxt in
   let dep = match depopt with 
-    | None -> mip.mind_sort <> (Prop Null)
+    | None -> inductive_sort_family mip <> InProp
     | Some d -> d
   in
-  if not (List.exists ((=) kind) mip.mind_kelim) then
+  if not (List.mem kind (elim_sorts specif)) then
     raise
-      (InductiveError
+      (RecursionSchemeError
 	 (NotAllowedCaseAnalysis
 	    (dep,(new_sort_in_family kind),ind)));
 
-  let nbargsprod = mip.mind_nrealargs + 1 in
+  let ndepar = mip.mind_nrealargs + 1 in
 
   (* Pas génant car env ne sert pas à typer mais juste à renommer les Anonym *)
   (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
@@ -65,22 +72,28 @@ let mis_make_case_com depopt env sigma (ind,mib,mip) kind =
   let rec add_branch env k = 
     if k = Array.length mip.mind_consnames then
       let nbprod = k+1 in
-      let indf = make_ind_family(ind,extended_rel_list nbprod lnamespar) in
-      let lnamesar,_ = get_arity env indf in
+
+      let indf' = lift_inductive_family nbprod indf in
+      let arsign,_ = get_arity env indf' in
+      let depind = build_dependent_inductive env indf' in
+      let deparsign = (Anonymous,None,depind)::arsign in
+
       let ci = make_default_case_info env RegularStyle ind in
-      let depind = build_dependent_inductive env indf in
-      let deparsign = (Anonymous,None,depind)::lnamesar in
-      let p =
-      it_mkLambda_or_LetIn_name env'
-          (appvect
-            (mkRel ((if dep then nbargsprod else mip.mind_nrealargs) + nbprod),
-            if dep then extended_rel_vect 0 deparsign
-            else extended_rel_vect 0 lnamesar))
-          (if dep then deparsign else lnamesar) in
+      let pbody =
+        appvect
+          (mkRel (ndepar + nbprod),
+           if dep then extended_rel_vect 0 deparsign
+           else extended_rel_vect 1 arsign) in
+      let p = 
+	it_mkLambda_or_LetIn_name env'
+	  ((if dep then mkLambda_name env' else mkLambda)
+	   (Anonymous,depind,pbody))
+          arsign
+      in
       it_mkLambda_or_LetIn_name env'
-       	(mkCase (ci, lift nbargsprod p,
+       	(mkCase (ci, lift ndepar p,
 		     mkRel 1,
-		     rel_vect nbargsprod k))
+		     rel_vect ndepar k))
        	deparsign
     else
       let cs = lift_constructor (k+1) constrs.(k) in
@@ -186,7 +199,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
   let c = it_mkProd_or_LetIn base cs.cs_args in
   process_constr env 0 c recargs nhyps []
 
-let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs = 
+let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = 
   let process_pos env fk  =
     let rec prec env i hyps p =
       let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
@@ -198,7 +211,7 @@ let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs =
 	    let d = (n,Some b,t) in
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
      	| Ind _ -> 
-            let realargs = list_skipn nparams largs
+            let realargs = list_skipn nparrec largs
             and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in 
             applist(lift i fk,realargs@[arg])
      	| _ -> assert false
@@ -239,10 +252,24 @@ let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs =
   in
   process_constr env 0 f (List.rev cstr.cs_args, recargs)
 
+
+(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k 
+   variables *)
+let context_chop k ctx = 
+  let rec chop_aux acc = function
+    | (0, l2) -> (List.rev acc, l2)
+    | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
+    | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
+    | (_, []) -> failwith "context_chop"
+  in chop_aux [] (k,ctx)
+
+
 (* Main function *)
-let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
-  let nparams = mip.mind_nparams in
-  let lnamespar = mip.mind_params_ctxt in
+let mis_make_indrec env sigma listdepkind mib =
+  let nparams = mib.mind_nparams in
+  let nparrec = mib. mind_nparams_rec in
+  let lnonparrec,lnamesparrec = 
+    context_chop (nparams-nparrec) mib.mind_params_ctxt in
   let nrec = List.length listdepkind in
   let depPvec =
     Array.create mib.mind_ntypes (None : (bool * constr) option) in 
@@ -257,6 +284,11 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
     assign nrec listdepkind in 
   let recargsvec =
     Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+ (* recarg information for non recursive parameters *)
+  let rec recargparn l n = 
+    if n = 0 then l else recargparn (mk_norec::l) (n-1) 
+  in
+  let recargpar = recargparn [] (nparams-nparrec) in
   let make_one_rec p =
     let makefix nbconstruct =
       let rec mrec i ln ltyp ldef = function
@@ -267,59 +299,86 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
 
             (* arity in the context of the fixpoint, i.e.
                 P1..P_nrec f1..f_nbconstruct *)
-	    let args = extended_rel_list (nrec+nbconstruct) lnamespar in
+	    let args = extended_rel_list (nrec+nbconstruct) lnamesparrec in
 	    let indf = make_ind_family(indi,args) in
-	    let lnames,_ = get_arity env indf in
 
-	    let nar = mipi.mind_nrealargs in
-	    let dect = nar+nrec+nbconstruct in
+	    let arsign,_ = get_arity env indf in
+	    let depind = build_dependent_inductive env indf in
+	    let deparsign = (Anonymous,None,depind)::arsign in
+	    
+	    let nonrecpar = rel_context_length lnonparrec in
+	    let larsign = rel_context_length deparsign in
+	    let ndepar = larsign - nonrecpar in
+	    let dect = larsign+nrec+nbconstruct in
 
-	    let branches = 
               (* constructors in context of the Cases expr, i.e.
-                 P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
-	      let args' = extended_rel_list (dect+nrec+1) lnamespar in
-              let indf' = make_ind_family(indi,args') in
+         P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
+	    let args' = extended_rel_list (dect+nrec) lnamesparrec in
+	    let args'' = extended_rel_list ndepar lnonparrec in
+            let indf' = make_ind_family(indi,args'@args'') in
+
+	    let branches = 
 	      let constrs = get_constructors env indf' in
-	      let vecfi = rel_vect (dect+1-i-nctyi) nctyi in
+	      let fi = rel_vect (dect-i-nctyi) nctyi in
+	      let vecfi = Array.map 
+			    (fun f -> appvect (f,extended_rel_vect ndepar lnonparrec))
+			    fi 
+	      in
 	      array_map3
-		(make_rec_branch_arg env sigma (nparams,depPvec,nar+1))
-                vecfi constrs (dest_subterms recargsvec.(tyi)) in
+		(make_rec_branch_arg env sigma 
+		   (nparrec,depPvec,larsign))
+                vecfi constrs (dest_subterms recargsvec.(tyi)) 
+	    in
+
 	    let j = (match depPvec.(tyi) with 
 		       | Some (_,c) when isRel c -> destRel c 
-		       | _ -> assert false) in
+		       | _ -> assert false) 
+	    in
+
+	      (* Predicate in the context of the case *)
+
+	    let depind' = build_dependent_inductive env indf' in
+	    let arsign',_ = get_arity env indf' in
+	    let deparsign' = (Anonymous,None,depind')::arsign' in
+
+	    let pargs =
+	      let nrpar = extended_rel_list (2*ndepar) lnonparrec 
+	      and nrar = if dep then extended_rel_list 0 deparsign'
+	      else extended_rel_list 1 arsign'
+	      in nrpar@nrar
+
+	    in
+
+		(* body of i-th component of the mutual fixpoint *)
 	    let deftyi = 
 	      let ci = make_default_case_info env RegularStyle indi in
-	      let indf' = lift_inductive_family nrec indf in
-	      let depind = build_dependent_inductive env indf' in
-	      let lnames' = Termops.lift_rel_context nrec lnames in
-	      let p =
-		let arsign =
-		  if dep then (Anonymous,None,depind)::lnames' else lnames' in
-		it_mkLambda_or_LetIn_name env
-		  (appvect
-		    (mkRel ((if dep then 1 else 0) + dect + j),
-		    extended_rel_vect 0 arsign)) arsign
+	      let concl = applist (mkRel (dect+j+ndepar),pargs) in 
+	      let pred =
+		it_mkLambda_or_LetIn_name env 
+		  ((if dep then mkLambda_name env else mkLambda)
+		   (Anonymous,depind',concl))
+		  arsign'
 	      in
 	      it_mkLambda_or_LetIn_name env
-		(lambda_create env
-		  (depind,mkCase (ci, lift (nar+1) p, mkRel 1, branches)))
-		lnames'
+		(mkCase (ci, pred, 
+		             mkRel 1,
+			     branches))
+		(lift_rel_context nrec deparsign)
+	    in
+
+	    (* type of i-th component of the mutual fixpoint *)
+
+	    let typtyi =
+	    let concl = 
+	      let pargs = if dep then extended_rel_vect 0 deparsign
+	      else extended_rel_vect 1 arsign
+	      in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
+	    in it_mkProd_or_LetIn_name env
+		concl
+		deparsign
 	    in
-	    let typtyi = 
-	      let ind = build_dependent_inductive env indf in
-	      it_mkProd_or_LetIn_name env
-		(prod_create env
-		   (ind,
-		    (if dep then 
-		       let ext_lnames = (Anonymous,None,ind)::lnames in
-		       let args = extended_rel_list 0 ext_lnames in
-		       applist (mkRel (nbconstruct+nar+j+1), args)
-		     else
-		       let args = extended_rel_list 1 lnames in
-		       applist (mkRel (nbconstruct+nar+j+1), args))))
-          	lnames
-	    in 
-	    mrec (i+nctyi) (nar::ln) (typtyi::ltyp) (deftyi::ldef) rest
+	    mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp) 
+                 (deftyi::ldef) rest
         | [] -> 
 	    let fixn = Array.of_list (List.rev ln) in
             let fixtyi = Array.of_list (List.rev ltyp) in
@@ -327,7 +386,7 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
             let names = Array.create nrec (Name(id_of_string "F")) in
 	    mkFix ((fixn,p),(names,fixtyi,fixdef))
       in 
-      mrec 0 [] [] [] 
+	      mrec 0 [] [] [] 
     in 
     let rec make_branch env i = function 
       | (indi,mibi,mipi,dep,_)::rest ->
@@ -338,8 +397,8 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
 	      make_branch env (i+j) rest 
 	    else 
 	      let recarg = (dest_subterms recargsvec.(tyi)).(j) in
-	      let vargs = extended_rel_list (nrec+i+j) lnamespar in
-	      let indf = (indi, vargs) in
+	      let recarg = recargpar@recarg in
+	      let vargs = extended_rel_list (nrec+i+j) lnamesparrec in
 	      let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in
 	      let p_0 =
 		type_rec_branch
@@ -353,23 +412,27 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
     in 
     let rec put_arity env i = function 
       | (indi,_,_,dep,kinds)::rest -> 
-	  let indf = make_ind_family (indi,extended_rel_list i lnamespar) in
+	  let indf = make_ind_family (indi,extended_rel_list i lnamesparrec) in
 	  let typP = make_arity env dep indf (new_sort_in_family kinds) in
 	  mkLambda_string "P" typP
 	    (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
       | [] -> 
 	  make_branch env 0 listdepkind 
     in 
+
+      (* Body on make_one_rec *)
     let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in
-    let env' = push_rel_context lnamespar env in
-    if mis_is_recursive_subset
-      (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind)
-      mipi.mind_recargs
-    then 
-      it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamespar
-    else 
-      mis_make_case_com (Some dep) env sigma (indi,mibi,mipi) kind 
+      if (mis_is_recursive_subset
+	     (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind)
+	     mipi.mind_recargs) 
+      then 
+	let env' = push_rel_context lnamesparrec env in
+	  it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) 
+	    lnamesparrec
+      else 
+	mis_make_case_com (Some dep) env sigma indi (mibi,mipi) kind 
   in 
+      (* Body of mis_make_indrec *)
   list_tabulate make_one_rec nrec
 
 (**********************************************************************)
@@ -377,7 +440,7 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
 
 let make_case_com depopt env sigma ity kind =
   let (mib,mip) = lookup_mind_specif env ity in 
-  mis_make_case_com depopt env sigma (ity,mib,mip) kind
+  mis_make_case_com depopt env sigma ity (mib,mip) kind
 
 let make_case_dep env   = make_case_com (Some true) env
 let make_case_nodep env = make_case_com (Some false) env 
@@ -385,20 +448,21 @@ let make_case_gen env   = make_case_com None env
 
 
 (**********************************************************************)
-(* [instanciate_indrec_scheme s rec] replace the sort of the scheme
+(* [instantiate_indrec_scheme s rec] replace the sort of the scheme
    [rec] by [s] *)
 
 let change_sort_arity sort = 
   let rec drec a = match kind_of_term a with
-    | Cast (c,t) -> drec c 
+    | Cast (c,_,_) -> drec c 
     | Prod (n,t,c) -> mkProd (n, t, drec c)
+    | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c)
     | Sort _ -> mkSort sort
     | _ -> assert false
   in 
   drec 
 
 (* [npar] is the number of expected arguments (then excluding letin's) *)
-let instanciate_indrec_scheme sort =
+let instantiate_indrec_scheme sort =
   let rec drec npar elim =
     match kind_of_term elim with
       | Lambda (n,t,c) -> 
@@ -407,13 +471,13 @@ let instanciate_indrec_scheme sort =
 	  else 
 	    mkLambda (n, t, drec (npar-1) c)
       | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c)
-      | _ -> anomaly "instanciate_indrec_scheme: wrong elimination type"
+      | _ -> anomaly "instantiate_indrec_scheme: wrong elimination type"
   in
   drec
 
 (* Change the sort in the type of an inductive definition, builds the
    corresponding eta-expanded term *)
-let instanciate_type_indrec_scheme sort npars term =
+let instantiate_type_indrec_scheme sort npars term =
   let rec drec np elim =
     match kind_of_term elim with
       | Prod (n,t,c) -> 
@@ -426,22 +490,27 @@ let instanciate_type_indrec_scheme sort npars term =
 	    mkProd (n, t, c'), mkLambda (n, t, term')
       | LetIn (n,b,t,c) -> let c',term' = drec np c in
            mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') 
-      | _ -> anomaly "instanciate_type_indrec_scheme: wrong elimination type"
+      | _ -> anomaly "instantiate_type_indrec_scheme: wrong elimination type"
   in
   drec npars
 
 (**********************************************************************)
 (* Interface to build complex Scheme *)
+(* Check inductive types only occurs once 
+(otherwise we obtain a meaning less scheme) *)
 
 let check_arities listdepkind = 
-  List.iter 
-    (function (indi,mibi,mipi,dep,kind) -> 
+  let _ = List.fold_left
+    (fun ln ((_,ni),mibi,mipi,dep,kind) -> 
        let id = mipi.mind_typename  in
-       let kelim = mipi.mind_kelim in
-       if not (List.exists ((=) kind) kelim) then
-	 raise
-	   (InductiveError (BadInduction (dep, id, new_sort_in_family kind))))
-    listdepkind
+       let kelim = elim_sorts (mibi,mipi) in
+       if not (List.exists ((=) kind) kelim) then raise
+	 (RecursionSchemeError (BadInduction (dep,id,new_sort_in_family kind)))
+       else if List.mem ni ln then raise
+	 (RecursionSchemeError NotMutualInScheme)
+       else ni::ln)
+	    [] listdepkind
+  in true
 
 let build_mutual_indrec env sigma = function 
   | (mind,mib,mip,dep,s)::lrecspec ->
@@ -455,18 +524,18 @@ let build_mutual_indrec env sigma = function
                 let (mibi',mipi') = lookup_mind_specif env mind' in
 		(mind',mibi',mipi',dep',s') 
 	      else 
-		raise (InductiveError NotMutualInScheme))
+		raise (RecursionSchemeError NotMutualInScheme))
 	   lrecspec)
       in
       let _ = check_arities listdepkind in 
-      mis_make_indrec env sigma listdepkind (mind,mib,mip)
+      mis_make_indrec env sigma listdepkind mib
   | _ -> anomaly "build_indrec expects a non empty list of inductive types"
 
 let build_indrec env sigma ind =
   let (mib,mip) = lookup_mind_specif env ind in
-  let kind = family_of_sort mip.mind_sort in
+  let kind = inductive_sort_family mip in
   let dep = kind <> InProp in
-  List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] (ind,mib,mip))
+  List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib)
 
 (**********************************************************************)
 (* To handle old Case/Match syntax in Pretyping                       *)
@@ -483,7 +552,6 @@ let type_rec_branches recursive env sigma indt p c =
   let tyi = snd ind in
   let init_depPvec i = if i = tyi then Some(true,p) else None in
   let depPvec = Array.init mib.mind_ntypes init_depPvec in
-  let vargs = Array.of_list params in
   let constructors = get_constructors env indf in
   let lft =
     array_map2
@@ -513,21 +581,21 @@ let lookup_eliminator ind_sp s =
   let id = add_suffix ind_id (elimination_suffix s) in
   (* Try first to get an eliminator defined in the same section as the *)
   (* inductive type *)
-  let ref = ConstRef (make_kn mp dp (label_of_id id)) in
+  let ref = ConstRef (make_con mp dp (label_of_id id)) in
   try 
     let _ = sp_of_global ref in
-    constr_of_reference ref
+    constr_of_global ref
   with Not_found ->
   (* Then try to get a user-defined eliminator in some other places *)
   (* using short name (e.g. for "eq_rec") *)
-  try constr_of_reference (Nametab.locate (make_short_qualid id))
+  try constr_of_global (Nametab.locate (make_short_qualid id))
   with Not_found ->
     errorlabstrm "default_elim"
       (str "Cannot find the elimination combinator " ++
        pr_id id ++ spc () ++
        str "The elimination of the inductive definition " ++
        pr_id id ++ spc () ++ str "on sort " ++ 
-       spc () ++ print_sort_family s ++
+       spc () ++ pr_sort_family s ++
        str " is probably not allowed")
 
 
@@ -541,13 +609,13 @@ let lookup_eliminator ind_sp s =
   with Not_found ->
   (* Then try to get a user-defined eliminator in some other places *)
   (* using short name (e.g. for "eq_rec") *)
-    try constr_of_reference (Nametab.locate (make_short_qualid id))
+    try constr_of_global (Nametab.locate (make_short_qualid id))
     with Not_found ->
       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_family s ++
+           spc () ++ pr_sort_family s ++
 	   str " is probably not allowed")
 *)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index f6f76706..e5eb07f5 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: indrec.mli,v 1.6.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+(*i $Id: indrec.mli 7660 2005-12-17 21:13:48Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -17,7 +17,16 @@ open Environ
 open Evd
 (*i*)
 
-(* Eliminations. *)
+(* Errors related to recursors building *)
+
+type recursion_scheme_error =
+  | NotAllowedCaseAnalysis of bool * sorts * inductive
+  | BadInduction of bool * identifier * sorts
+  | NotMutualInScheme
+
+exception RecursionSchemeError of recursion_scheme_error
+
+(** Eliminations *)
 
 (* These functions build elimination predicate for Case tactic *)
 
@@ -29,11 +38,11 @@ val make_case_gen : env -> evar_map -> inductive -> sorts_family -> constr
    of the inductive) *)
 
 val build_indrec : env -> evar_map -> inductive -> constr
-val instanciate_indrec_scheme : sorts -> int -> constr -> constr
-val instanciate_type_indrec_scheme : sorts -> int -> constr -> types ->
+val instantiate_indrec_scheme : sorts -> int -> constr -> constr
+val instantiate_type_indrec_scheme : sorts -> int -> constr -> types ->
   constr * types
 
-(* This builds complex [Scheme] *)
+(** Complex recursion schemes [Scheme] *)
 
 val build_mutual_indrec : 
   env -> evar_map ->
@@ -41,7 +50,7 @@ val build_mutual_indrec :
     * bool * sorts_family) list
     -> constr list
 
-(* These are for old Case/Match typing *)
+(** Old Case/Match typing *)
 
 val type_rec_branches : bool -> env -> evar_map -> inductive_type
   -> constr -> constr -> constr array * constr
@@ -50,7 +59,11 @@ val make_rec_branch_arg :
     int * ('b * constr) option array * int ->
     constr -> constructor_summary -> wf_paths list -> constr
 
-(* *)
+(** Recursor names utilities *)
+
 val lookup_eliminator : inductive -> sorts_family -> constr
 val elimination_suffix : sorts_family -> string
 val make_elimination_ident : identifier -> sorts_family -> identifier
+
+
+
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index c33a261b..14136f61 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductiveops.ml,v 1.14.2.2 2004/12/29 12:15:00 herbelin Exp $ *)
+(* $Id: inductiveops.ml 9310 2006-10-28 19:35:09Z herbelin $ *)
 
 open Util
 open Names
@@ -18,6 +18,24 @@ open Declarations
 open Environ
 open Reductionops
 
+(* The following three functions are similar to the ones defined in
+   Inductive, but they expect an env *)
+
+let type_of_inductive env ind =
+ let specif = Inductive.lookup_mind_specif env ind in
+  Inductive.type_of_inductive env specif
+
+(* Return type as quoted by the user *)
+let type_of_constructor env cstr =
+ let specif =
+  Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+ Inductive.type_of_constructor cstr specif
+
+(* Return constructor types in normal form *)
+let arities_of_constructors env ind =
+ let specif = Inductive.lookup_mind_specif env ind in
+  Inductive.arities_of_constructors ind specif
+
 (* [inductive_family] = [inductive_instance] applied to global parameters *)
 type inductive_family = inductive * constr list
 
@@ -73,6 +91,7 @@ let mis_nf_constructor_type (ind,mib,mip) j =
   substl (list_tabulate make_Ik ntypes) specif.(j-1)
 
 (* Arity of constructors excluding parameters and local defs *)
+
 let mis_constr_nargs indsp =
   let (mib,mip) = Global.lookup_inductive indsp in
   let recargs = dest_subterms mip.mind_recargs in
@@ -87,7 +106,29 @@ let mis_constr_nargs_env env (kn,i) =
 let mis_constructor_nargs_env env ((kn,i),j) =
   let mib = Environ.lookup_mind kn env in
   let mip = mib.mind_packets.(i) in 
-  recarg_length mip.mind_recargs j + mip.mind_nparams
+  recarg_length mip.mind_recargs j + mib.mind_nparams
+
+let constructor_nrealargs env (ind,j) =
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  recarg_length mip.mind_recargs j
+
+let constructor_nrealhyps env (ind,j) =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_consnrealdecls.(j-1)
+
+let get_full_arity_sign env ind =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_arity_ctxt
+
+(* Length of arity (w/o local defs) *)
+
+let inductive_nargs env ind =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  mib.mind_nparams, mip.mind_nrealargs
+
+let allowed_sorts env (kn,i as ind) =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_kelim
 
 (* Annotation for cases *)
 let make_case_info env ind style pats_source =
@@ -97,7 +138,8 @@ let make_case_info env ind style pats_source =
       style     = style;
       source    = pats_source } in
   { ci_ind     = ind;
-    ci_npar    = mip.mind_nparams;
+    ci_npar    = mib.mind_nparams;
+    ci_cstr_nargs = mip.mind_consnrealdecls;
     ci_pp_info = print_info }
 
 let make_default_case_info env style ind =
@@ -122,6 +164,7 @@ let lift_constructor n cs = {
   cs_args = lift_rel_context n cs.cs_args;
   cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs
 }
+(* Accept less parameters than in the signature *)
 
 let instantiate_params t args sign =
   let rec inst s t = function
@@ -133,17 +176,17 @@ let instantiate_params t args sign =
 	(match kind_of_term t with
 	   | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args)
 	   | _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
-    | [], [] -> substl s t
+    | _, [] -> substl s t
     | _ -> anomaly"instantiate_params: type, ctxt and args mismatch"
   in inst [] t (List.rev sign,args)
 
 let get_constructor (ind,mib,mip,params) j =
   assert (j <= Array.length mip.mind_consnames);
   let typi = mis_nf_constructor_type (ind,mib,mip) j in
-  let typi = instantiate_params typi params mip.mind_params_ctxt in
+  let typi = instantiate_params typi params mib.mind_params_ctxt in
   let (args,ccl) = decompose_prod_assum typi in
   let (_,allargs) = decompose_app ccl in
-  let vargs = list_skipn mip.mind_nparams allargs in
+  let vargs = list_skipn (List.length params) allargs in
   { cs_cstr = ith_constructor_of_inductive ind j;
     cs_params = params;
     cs_nargs = rel_context_length args;
@@ -161,10 +204,40 @@ let rec instantiate args c = match kind_of_term c, args with
   | _, [] -> c
   | _ -> anomaly "too short arity"
 
+(* substitution in a signature *)
+
+let substnl_rel_context subst n sign =
+  let rec aux n = function
+  | d::sign -> substnl_decl subst n d :: aux (n+1) sign
+  | [] -> []
+  in List.rev (aux n (List.rev sign))
+
+let substl_rel_context subst = substnl_rel_context subst 0
+
+let rec instantiate_context sign args =
+  let rec aux subst = function
+  | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args)
+  | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args)
+  | [], [] -> subst
+  | _ -> anomaly "Signature/instance mismatch in inductive family"
+  in aux [] (List.rev sign,args)
+
 let get_arity env (ind,params) =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  let arity = mip.mind_nf_arity in
-  destArity (instantiate params arity)
+  let parsign =
+    (* Dynamically detect if called with an instance of recursively
+       uniform parameter only or also of non recursively uniform
+       parameters *)
+    let parsign = mib.mind_params_ctxt in
+    let nnonrecparams = mib.mind_nparams - mib.mind_nparams_rec in
+    if List.length params = rel_context_nhyps parsign - nnonrecparams then
+      snd (list_chop nnonrecparams mib.mind_params_ctxt)
+    else
+      parsign in
+  let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in
+  let arsign,_ = list_chop arproperlength mip.mind_arity_ctxt in
+  let subst = instantiate_context parsign params in
+  (substl_rel_context subst arsign, Inductive.inductive_sort_family mip)
 
 (* Functions to build standard types related to inductive *)
 let build_dependent_constructor cs =
@@ -175,8 +248,7 @@ let build_dependent_constructor cs =
 
 let build_dependent_inductive env ((ind, params) as indf) =
   let arsign,_ = get_arity env indf in
-  let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  let nrealargs = mip.mind_nrealargs in
+  let nrealargs = List.length arsign in
   applist 
     (mkInd ind,
      (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
@@ -189,7 +261,7 @@ let make_arity_signature env dep indf =
     (* We need names everywhere *)
     name_context env
       ((Anonymous,None,build_dependent_inductive env indf)::arsign)
-      (* Costly: would be better to name one for all at definition time *)
+      (* Costly: would be better to name once for all at definition time *)
   else
     (* No need to enforce names *)
     arsign
@@ -225,7 +297,7 @@ let find_rectype env sigma c =
   match kind_of_term t with
     | Ind ind ->
         let (mib,mip) = Inductive.lookup_mind_specif env ind in
-        let (par,rargs) = list_chop mip.mind_nparams l in
+        let (par,rargs) = list_chop mib.mind_nparams l in
         IndType((ind, par),rargs)
     | _ -> raise Not_found
 
@@ -247,59 +319,59 @@ let find_coinductive env sigma c =
 
 
 (***********************************************)
-(* find appropriate names for pattern variables. Useful in the
-   Case tactic. *)
+(* find appropriate names for pattern variables. Useful in the Case
+   and Inversion (case_then_using et case_nodep_then_using) tactics. *)
 
-let is_dep_predicate env kelim pred nodep_ar = 
-  let rec srec env pval pt nodep_ar =
-    let pt' = whd_betadeltaiota env Evd.empty pt in
+let is_predicate_explicitly_dep env pred arsign = 
+  let rec srec env pval arsign =
     let pv' = whd_betadeltaiota env Evd.empty pval in
-    match kind_of_term pv', kind_of_term pt', kind_of_term nodep_ar with
-      | Lambda (na,t,b), Prod (_,_,a), Prod (_,_,a') ->
-	  srec (push_rel_assum (na,t) env) b a a'
-      | _,              Prod (na,t,a), Prod (_,_,a') ->
-	  srec (push_rel_assum (na,t) env) (lift 1 pv') a a'
-      | Lambda (_,_,b), Prod (_,_,_), _ -> (*dependent (mkRel 1) b*) true
-      | _, Prod (_,_,_), _ -> true
-      | _ -> false in 
-  srec env pred.uj_val pred.uj_type nodep_ar
-
-let is_dependent_elimination_predicate env pred indf =
-  let (ind,params) = indf in
-  let (_,mip) = Inductive.lookup_mind_specif env ind in
-  let kelim = mip.mind_kelim in
-  let arsign,s = get_arity env indf in
-  let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in
-  is_dep_predicate env kelim pred glob_t
-
-let is_dep_arity env kelim predty nodep_ar = 
-  let rec srec pt nodep_ar =
-    let pt' = whd_betadeltaiota env Evd.empty pt in
-    match kind_of_term pt', kind_of_term nodep_ar with
-      | Prod (_,a1,a2), Prod (_,a1',a2') -> srec a2 a2'
-      | Prod (_,a1,a2), _ -> true
-      | _ -> false in 
-  srec predty nodep_ar
-
-let is_dependent_elimination env predty indf =
-  let (ind,params) = indf in
-  let (_,mip) = Inductive.lookup_mind_specif env ind in
-  let kelim = mip.mind_kelim in
-  let arsign,s = get_arity env indf in
-  let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in
-  is_dep_arity env kelim predty glob_t
+    match kind_of_term pv', arsign with
+      | Lambda (na,t,b), (_,None,_)::arsign ->
+	  srec (push_rel_assum (na,t) env) b arsign
+      | Lambda (na,_,_), _ ->
+
+       (* The following code has impact on the introduction names
+	  given by the tactics "case" and "inversion": when the
+	  elimination is not dependent, "case" uses Anonymous for
+	  inductive types in Prop and names created by mkProd_name for
+	  inductive types in Set/Type while "inversion" uses anonymous
+	  for inductive types both in Prop and Set/Type !!
+
+	  Previously, whether names were created or not relied on
+	  whether the predicate created in Indrec.make_case_com had a
+	  dependent arity or not. To avoid different predicates
+	  printed the same in v8, all predicates built in indrec.ml
+	  got a dependent arity (Aug 2004). The new way to decide
+	  whether names have to be created or not is to use an
+	  Anonymous or Named variable to enforce the expected
+	  dependency status (of course, Anonymous implies non
+	  dependent, but not conversely).
+
+          At the end, this is only to preserve the compatibility: a
+          check whether the predicate is actually dependent or not
+          would indeed be more natural! *)
+
+	  na <> Anonymous
+
+      | _ -> anomaly "Non eta-expanded dep-expanded \"match\" predicate"
+  in
+  srec env pred arsign
+
+let is_elim_predicate_explicitly_dependent env pred indf =
+  let arsign,_ = get_arity env indf in
+  is_predicate_explicitly_dep env pred arsign
 
 let set_names env n brty =
   let (ctxt,cl) = decompose_prod_n_assum n brty in
   it_mkProd_or_LetIn_name env cl ctxt
 
 let set_pattern_names env ind brv =
-  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
   let arities =
     Array.map
       (fun c ->
         rel_context_length (fst (decompose_prod_assum c)) -
-        mip.mind_nparams)
+        mib.mind_nparams)
       mip.mind_nf_lc in
   array_map2 (set_names env) arities brv
 
@@ -308,8 +380,8 @@ let type_case_branches_with_names env indspec pj c =
   let (ind,args) = indspec in
   let (lbrty,conclty,_) = Inductive.type_case_branches env indspec pj c in
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  let params = list_firstn mip.mind_nparams args in
-  if is_dependent_elimination_predicate env pj (ind,params) then
+  let params = list_firstn mib.mind_nparams args in
+  if is_elim_predicate_explicitly_dependent env pj.uj_val (ind,params) then
     (set_pattern_names env ind lbrty, conclty)
   else (lbrty, conclty)
 
@@ -342,11 +414,15 @@ let control_only_guard env =
 	Array.iter control_rec tys;
 	Array.iter control_rec bds;
     | Case(_,p,c,b) -> control_rec p;control_rec c;Array.iter control_rec b
-    | Evar (_,cl)         -> Array.iter control_rec cl
+    | Evar (_,cl)        -> Array.iter control_rec cl
     | App (c,cl)         -> control_rec c; Array.iter control_rec cl
-    | Cast (c1,c2)       -> control_rec c1; control_rec c2
+    | Cast (c1,_, c2)  -> control_rec c1; control_rec c2
     | Prod (_,c1,c2)     -> control_rec c1; control_rec c2
     | Lambda (_,c1,c2)   -> control_rec c1; control_rec c2
     | LetIn (_,c1,c2,c3) -> control_rec c1; control_rec c2; control_rec c3
   in 
   control_rec 
+
+let subst_inductive subst (kn,i as ind) = 
+  let kn' = Mod_subst.subst_kn subst kn in
+  if kn == kn' then ind else (kn',i)
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 8cfa9b3c..d49b64d9 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -6,13 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: inductiveops.mli,v 1.10.2.3 2005/01/21 17:19:37 herbelin Exp $ i*)
+(*i $Id: inductiveops.mli 9194 2006-10-01 09:25:19Z herbelin $ i*)
 
 open Names
 open Term
 open Declarations
 open Environ
 open Evd
+open Sign
+
+(* The following three functions are similar to the ones defined in
+   Inductive, but they expect an env *)
+
+val type_of_inductive    : env -> inductive -> types
+
+(* Return type as quoted by the user *)
+val type_of_constructor  : env -> constructor -> types
+
+(* Return constructor types in normal form *)
+val arities_of_constructors : env -> inductive -> types array
 
 (* An inductive type with its parameters *)
 type inductive_family
@@ -31,8 +43,7 @@ val dest_ind_type : inductive_type -> inductive_family * constr list
 val map_inductive_type : (constr -> constr) -> inductive_type -> inductive_type
 val liftn_inductive_type : int -> int -> inductive_type -> inductive_type
 val lift_inductive_type  : int -> inductive_type -> inductive_type
-val substnl_ind_type :
-  constr list -> int -> inductive_type -> inductive_type
+val substnl_ind_type : constr list -> int -> inductive_type -> inductive_type
 
 val mkAppliedInd : inductive_type -> constr
 val mis_is_recursive_subset : int list -> wf_paths -> bool
@@ -40,11 +51,24 @@ val mis_is_recursive :
   inductive * mutual_inductive_body * one_inductive_body -> bool
 val mis_nf_constructor_type :
   inductive * mutual_inductive_body * one_inductive_body -> int -> constr
-val mis_constr_nargs : inductive -> int array
 
+(* Extract information from an inductive name *)
+
+val mis_constr_nargs : inductive -> int array
 val mis_constr_nargs_env : env -> inductive -> int array
 
+(* Return number of expected parameters and of expected real arguments *)
+val inductive_nargs : env -> inductive -> int * int
+
 val mis_constructor_nargs_env : env -> constructor -> int
+val constructor_nrealargs : env -> constructor -> int
+val constructor_nrealhyps : env -> constructor -> int
+
+val get_full_arity_sign : env -> inductive -> rel_context
+
+val allowed_sorts : env -> inductive -> sorts_family list
+
+(* Extract information from an inductive family *)
 
 type constructor_summary = {
   cs_cstr : constructor;
@@ -52,17 +76,16 @@ type constructor_summary = {
   cs_nargs : int;
   cs_args : Sign.rel_context;
   cs_concl_realargs : constr array;
-} 
+}
 val lift_constructor : int -> constructor_summary -> constructor_summary
 val get_constructor :
   inductive * mutual_inductive_body * one_inductive_body * constr list ->
   int -> constructor_summary
-val get_arity        : env -> inductive_family -> Sign.arity
+val get_arity        : env -> inductive_family -> rel_context * sorts_family
 val get_constructors : env -> inductive_family -> constructor_summary array
 val build_dependent_constructor : constructor_summary -> constr
 val build_dependent_inductive   : env -> inductive_family -> constr
-val make_arity_signature :
-  env -> bool -> inductive_family -> Sign.rel_context
+val make_arity_signature : env -> bool -> inductive_family -> Sign.rel_context
 val make_arity : env -> bool -> inductive_family -> sorts -> types
 val build_branch_type : env -> bool -> constr -> constructor_summary -> types
 
@@ -74,9 +97,6 @@ val find_inductive   : env -> evar_map -> constr -> inductive * constr list
 val find_coinductive : env -> evar_map -> constr -> inductive * constr list
 
 (********************)
-(* Determines if a case predicate type corresponds to dependent elimination *)
-val is_dependent_elimination :
-  env -> types -> inductive_family -> bool
 
 (* Builds the case predicate arity (dependent or not) *)
 val arity_of_case_predicate :
@@ -91,3 +111,5 @@ val make_default_case_info : env -> case_style -> inductive -> case_info
 
 (********************)
 val control_only_guard : env -> types -> unit
+
+val subst_inductive : Mod_subst.substitution -> inductive -> inductive
diff --git a/pretyping/instantiate.ml b/pretyping/instantiate.ml
deleted file mode 100644
index 702cdfea..00000000
--- a/pretyping/instantiate.ml
+++ /dev/null
@@ -1,68 +0,0 @@
-(************************************************************************)
-(*  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: instantiate.ml,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
-
-open Pp
-open Util
-open Names
-open Term
-open Sign
-open Evd
-open Declarations
-open Environ
-
-let is_id_inst inst =
-  let is_id (id,c) = match kind_of_term c with
-    | Var id' -> id = id'
-    | _ -> false
-  in
-  List.for_all is_id inst
-
-(* Vérifier que les instances des let-in sont compatibles ?? *)
-let instantiate_sign_including_let sign args =
-  let rec instrec = function
-    | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args))
-    | ([],[])                        -> []
-    | ([],_) | (_,[]) ->
-    anomaly "Signature and its instance do not match"
-  in 
-  instrec (sign,args)
-
-let instantiate_evar sign c args =
-  let inst = instantiate_sign_including_let sign args in
-  if is_id_inst inst then
-    c
-  else
-    replace_vars inst c
-
-(* Existentials. *)
-
-let existential_type sigma (n,args) =
-  let info =
-    try Evd.map sigma n
-    with Not_found ->
-      anomaly ("Evar "^(string_of_existential n)^" was not declared") in
-  let hyps = info.evar_hyps in
-  instantiate_evar hyps info.evar_concl (Array.to_list args)
-
-exception NotInstantiatedEvar
-
-let existential_value sigma (n,args) =
-  let info = Evd.map sigma n in
-  let hyps = info.evar_hyps in
-  match evar_body info with
-    | Evar_defined c ->
-	instantiate_evar hyps c (Array.to_list args)
-    | Evar_empty ->
-	raise NotInstantiatedEvar
-
-let existential_opt_value sigma ev =
-  try Some (existential_value sigma ev)
-  with NotInstantiatedEvar -> None
-
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
index bdab3b5b..65ce2ef4 100644
--- a/pretyping/matching.ml
+++ b/pretyping/matching.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: matching.ml,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+(* $Id: matching.ml 9280 2006-10-25 21:37:37Z herbelin $ *)
 
 (*i*)
 open Util
@@ -17,6 +17,7 @@ open Termops
 open Reductionops
 open Term
 open Rawterm
+open Sign
 open Environ
 open Pattern
 (*i*)
@@ -70,6 +71,11 @@ let memb_metavars m n =
 
 let eq_context ctxt1 ctxt2 = array_for_all2 eq_constr ctxt1 ctxt2
 
+let same_case_structure (_,cs1,ind,_) ci2 br1 br2 =
+  match ind with
+  | Some ind -> ind = ci2.ci_ind
+  | None -> cs1 = ci2.ci_cstr_nargs
+
 let matches_core convert allow_partial_app pat c = 
   let rec sorec stk sigma p t =
     let cT = strip_outer_cast t in
@@ -79,7 +85,7 @@ let matches_core convert allow_partial_app pat c =
 	    List.map
 	      (function
 		 | PRel n -> n
-		 | _ -> error "Only bound indices are currently allowed in second order pattern matching")
+		 | _ -> error "Only bound indices allowed in second order pattern matching")
 	      args in
 	  let frels = Intset.elements (free_rels cT) in
 	  if list_subset frels relargs then
@@ -89,11 +95,15 @@ let matches_core convert allow_partial_app pat c =
 
       | PMeta (Some n), m ->
 	  let depth = List.length stk in
-	  let frels = Intset.elements (free_rels cT) in
-          if List.for_all (fun i -> i > depth) frels then
-	    constrain (n,lift (-depth) cT) sigma
-          else 
-	    raise PatternMatchingFailure
+          if depth = 0 then
+            (* Optimisation *)
+            constrain (n,cT) sigma
+          else
+	    let frels = Intset.elements (free_rels cT) in
+            if List.for_all (fun i -> i > depth) frels then
+	      constrain (n,lift (-depth) cT) sigma
+            else 
+	      raise PatternMatchingFailure
 
       | PMeta None, m -> sigma
 
@@ -101,7 +111,7 @@ let matches_core convert allow_partial_app pat c =
 
       | PVar v1, Var v2 when v1 = v2 -> sigma
 
-      | PRef ref, _ when constr_of_reference ref = cT -> sigma
+      | PRef ref, _ when constr_of_global ref = cT -> sigma
 
       | PRel n1, Rel n2 when n1 = n2 -> sigma
 
@@ -109,6 +119,11 @@ let matches_core convert allow_partial_app pat c =
 
       | PSort (RType _), Sort (Type _) -> sigma
 
+      | PApp (p, [||]), _ -> sorec stk sigma p t
+
+      | PApp (PApp (h, a1), a2), _ ->
+          sorec stk sigma (PApp(h,Array.append a1 a2)) t
+
       | PApp (PMeta (Some n),args1), App (c2,args2) when allow_partial_app ->
           let p = Array.length args2 - Array.length args1 in
           if p>=0 then
@@ -139,19 +154,31 @@ let matches_core convert allow_partial_app pat c =
 
       | PRef (ConstRef _ as ref), _ when convert <> None ->
 	  let (env,evars) = out_some convert in
-	  let c = constr_of_reference ref in
+	  let c = constr_of_global ref in
 	  if is_conv env evars c cT then sigma
 	  else raise PatternMatchingFailure
 
-      | PCase (_,_,a1,br1), Case (_,_,a2,br2) ->
-	  (* On ne teste pas le prédicat *)
-          if (Array.length br1) = (Array.length br2) then
-  	    array_fold_left2 (sorec stk) (sorec stk sigma a1 a2) br1 br2
+      | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
+	  let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_nargs.(0) b2 in
+	  let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_nargs.(1) b2' in
+	  let n = List.length ctx and n' = List.length ctx' in
+	  if noccur_between 1 n b2 & noccur_between 1 n' b2' then
+	    let s = List.fold_left (fun l (na,_,t) -> (na,t)::l) stk ctx in
+	    let s' = List.fold_left (fun l (na,_,t) -> (na,t)::l) stk ctx' in
+	    let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
+  	    sorec s' (sorec s (sorec stk sigma a1 a2) b1 b2) b1' b2'
           else
             raise PatternMatchingFailure
-      (* À faire *)
-      |	PFix f0, Fix f1 when f0 = f1 -> sigma
-      |	PCoFix c0, CoFix c1 when c0 = c1 -> sigma
+
+      | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) ->
+	  if same_case_structure ci1 ci2 br1 br2 then
+  	    array_fold_left2 (sorec stk) 
+	      (sorec stk (sorec stk sigma a1 a2) p1 p2) br1 br2
+          else
+            raise PatternMatchingFailure
+
+      |	PFix c1, Fix _ when eq_constr (mkFix c1) cT -> sigma
+      |	PCoFix c1, CoFix _ when eq_constr (mkCoFix c1) cT -> sigma
       | _ -> raise PatternMatchingFailure
 
   in 
@@ -176,15 +203,15 @@ let special_meta = (-1)
 (* Tries to match a subterm of [c] with [pat] *)
 let rec sub_match nocc pat c =
   match kind_of_term c with
-  | Cast (c1,c2) ->
+  | Cast (c1,k,c2) ->
     (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
     | PatternMatchingFailure ->
       let (lm,lc) = try_sub_match nocc pat [c1] in
-      (lm,mkCast (List.hd lc, c2))
+      (lm,mkCast (List.hd lc, k,c2))
     | NextOccurrence nocc ->
       let (lm,lc) = try_sub_match (nocc - 1) pat [c1] in
-      (lm,mkCast (List.hd lc, c2)))
-  | Lambda (x,c1,c2) ->
+      (lm,mkCast (List.hd lc, k,c2)))
+ | Lambda (x,c1,c2) ->
     (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
     | PatternMatchingFailure ->
       let (lm,lc) = try_sub_match nocc pat [c1;c2] in
@@ -242,6 +269,10 @@ and try_sub_match nocc pat lc =
       | NextOccurrence nocc -> try_sub_match_rec nocc pat (lacc@[c]) tl) in
   try_sub_match_rec nocc pat [] lc
 
+let match_subterm nocc pat c =
+  try sub_match nocc pat c
+  with NextOccurrence _ -> raise PatternMatchingFailure
+
 let is_matching pat n =
   try let _ = matches pat n in true
   with PatternMatchingFailure -> false
diff --git a/pretyping/matching.mli b/pretyping/matching.mli
index 2f666880..e6065c68 100644
--- a/pretyping/matching.mli
+++ b/pretyping/matching.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: matching.mli,v 1.3.2.2 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: matching.mli 6616 2005-01-21 17:18:23Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -39,11 +39,10 @@ val is_matching : constr_pattern -> constr -> bool
 
 val matches_conv :env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
 
-(* To skip to the next occurrence *)
-exception NextOccurrence of int
-
-(* Tries to match a **closed** subterm of [c] with [pat] *)
-val sub_match : int -> constr_pattern -> constr -> patvar_map * constr
+(* [match_subterm n pat c] returns the substitution and the context
+   corresponding to the [n+1]th **closed** subterm of [c] matching [pat];
+   It raises PatternMatchingFailure if no such matching exists *)
+val match_subterm : int -> constr_pattern -> constr -> patvar_map * constr
 
 (* [is_matching_conv env sigma pat c] tells if [c] matches against [pat]
    up to conversion for constants in patterns *)
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
index f58a12c6..eb8a25eb 100644
--- a/pretyping/pattern.ml
+++ b/pretyping/pattern.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pattern.ml,v 1.24.2.2 2004/11/26 17:51:52 herbelin Exp $ *)
+(* $Id: pattern.ml 8963 2006-06-19 18:54:49Z barras $ *)
 
 open Util
 open Names
@@ -17,18 +17,13 @@ open Rawterm
 open Environ
 open Nametab
 open Pp
+open Mod_subst
 
 (* Metavariables *)
 
 type patvar_map = (patvar * constr) list
-let patvar_of_int n =
-  let p = if !Options.v7 & not (Options.do_translate ()) then "?" else "X"
-  in
-  Names.id_of_string (p ^ string_of_int n)
 let pr_patvar = pr_id
 
-let patvar_of_int_v7 n = Names.id_of_string ("?" ^ string_of_int n)
-
 (* Patterns *)
 
 type constr_pattern =
@@ -43,8 +38,9 @@ type constr_pattern =
   | PLetIn of name * constr_pattern * constr_pattern
   | PSort of rawsort
   | PMeta of patvar option
-  | PCase of (inductive option * case_style)
-      * constr_pattern option * constr_pattern * constr_pattern array
+  | PIf of constr_pattern * constr_pattern * constr_pattern
+  | PCase of (case_style * int array * inductive option * (int * int) option)
+      * constr_pattern * constr_pattern * constr_pattern array
   | PFix of fixpoint
   | PCoFix of cofixpoint
 
@@ -54,65 +50,15 @@ let rec occur_meta_pattern = function
   | PLambda (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
   | PProd (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
   | PLetIn (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
-  | PCase(_,None,c,br)   ->
-      (occur_meta_pattern c) or (array_exists occur_meta_pattern br)
-  | PCase(_,Some p,c,br) ->
+  | PIf (c,c1,c2)  ->
+      (occur_meta_pattern c) or
+      (occur_meta_pattern c1) or (occur_meta_pattern c2)
+  | PCase(_,p,c,br) ->
       (occur_meta_pattern p) or
       (occur_meta_pattern c) or (array_exists occur_meta_pattern br)
   | PMeta _ | PSoApp _ -> true
   | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false
 
-let rec subst_pattern subst pat = match pat with
-  | PRef ref ->
-      let ref' = subst_global subst ref in
-	if ref' == ref then pat else 
-	  PRef ref'
-  | PVar _ 
-  | PEvar _
-  | PRel _ -> pat
-  | PApp (f,args) ->
-      let f' = subst_pattern subst f in 
-      let args' = array_smartmap (subst_pattern subst) args in
-	if f' == f && args' == args then pat else
-	  PApp (f',args')
-  | PSoApp (i,args) ->
-      let args' = list_smartmap (subst_pattern subst) args in
-	if args' == args then pat else
-	  PSoApp (i,args')
-  | PLambda (name,c1,c2) ->
-      let c1' = subst_pattern subst c1 in
-      let c2' = subst_pattern subst c2 in
-	if c1' == c1 && c2' == c2 then pat else
-	  PLambda (name,c1',c2')
-  | PProd (name,c1,c2) ->
-      let c1' = subst_pattern subst c1 in
-      let c2' = subst_pattern subst c2 in
-	if c1' == c1 && c2' == c2 then pat else
-	  PProd (name,c1',c2')
-  | PLetIn (name,c1,c2) ->
-      let c1' = subst_pattern subst c1 in
-      let c2' = subst_pattern subst c2 in
-	if c1' == c1 && c2' == c2 then pat else
-	  PLetIn (name,c1',c2')
-  | PSort _ 
-  | PMeta _ -> pat
-  | PCase (cs,typ, c, branches) -> 
-      let typ' = option_smartmap (subst_pattern subst) typ in 
-      let c' = subst_pattern subst c in
-      let branches' = array_smartmap (subst_pattern subst) branches in
-	if typ' == typ && c' == c && branches' == branches then pat else
-	  PCase(cs,typ', c', branches') 
-  | PFix fixpoint ->
-      let cstr = mkFix fixpoint in
-      let fixpoint' = destFix (subst_mps subst cstr) in
-	if fixpoint' == fixpoint then pat else
-	  PFix fixpoint'
-  | PCoFix cofixpoint ->
-      let cstr = mkCoFix cofixpoint in
-      let cofixpoint' = destCoFix (subst_mps subst cstr) in
-	if cofixpoint' == cofixpoint then pat else
-	  PCoFix cofixpoint'
-
 type constr_label =
   | ConstNode of constant
   | IndNode of inductive
@@ -121,33 +67,15 @@ type constr_label =
 
 exception BoundPattern;;
 
-let label_of_ref = function
-  | ConstRef sp     -> ConstNode sp
-  | IndRef sp       -> IndNode sp
-  | ConstructRef sp -> CstrNode sp
-  | VarRef id       -> VarNode id
-
-let ref_of_label = function
-  | ConstNode sp     -> ConstRef sp
-  | IndNode sp       -> IndRef sp
-  | CstrNode sp      -> ConstructRef sp
-  | VarNode id       -> VarRef id
-
-let subst_label subst cstl = 
-  let ref = ref_of_label cstl in
-  let ref' = subst_global subst ref in
-    if ref' == ref then cstl else
-      label_of_ref ref'
-      
-  
 let rec head_pattern_bound t =
   match t with
     | PProd (_,_,b)  -> head_pattern_bound b 
     | PLetIn (_,_,b) -> head_pattern_bound b 
     | PApp (c,args)  -> head_pattern_bound c
+    | PIf (c,_,_)  -> head_pattern_bound c
     | PCase (_,p,c,br) -> head_pattern_bound c
-    | PRef r         -> label_of_ref r
-    | PVar id        -> VarNode id
+    | PRef r         -> r
+    | PVar id        -> VarRef id
     | PEvar _ | PRel _ | PMeta _ | PSoApp _  | PSort _ | PFix _
 	-> raise BoundPattern
     (* Perhaps they were arguments, but we don't beta-reduce *)
@@ -155,10 +83,10 @@ let rec head_pattern_bound t =
     | PCoFix _ -> anomaly "head_pattern_bound: not a type"
 
 let head_of_constr_reference c = match kind_of_term c with
-  | Const sp -> ConstNode sp
-  | Construct sp -> CstrNode sp
-  | Ind sp -> IndNode sp
-  | Var id -> VarNode id
+  | Const sp -> ConstRef sp
+  | Construct sp -> ConstructRef sp
+  | Ind sp -> IndRef sp
+  | Var id -> VarRef id
   | _ -> anomaly "Not a rigid reference"
 
 let rec pattern_of_constr t =
@@ -168,7 +96,7 @@ let rec pattern_of_constr t =
     | Var id -> PVar id
     | Sort (Prop c) -> PSort (RProp c)
     | Sort (Type _) -> PSort (RType None)
-    | Cast (c,_)      -> pattern_of_constr c
+    | Cast (c,_,_)      -> pattern_of_constr c
     | LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b)
     | Prod (na,c,b)   -> PProd (na,pattern_of_constr c,pattern_of_constr b)
     | Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b)
@@ -178,30 +106,105 @@ let rec pattern_of_constr t =
     | Construct sp -> PRef (ConstructRef sp)
     | Evar (n,ctxt) -> PEvar (n,Array.map pattern_of_constr ctxt)
     | Case (ci,p,a,br) ->
-	PCase ((Some ci.ci_ind,ci.ci_pp_info.style),
-	       Some (pattern_of_constr p),pattern_of_constr a,
+	let cip = ci.ci_pp_info in
+	let no = Some (ci.ci_npar,cip.ind_nargs) in
+	PCase ((cip.style,ci.ci_cstr_nargs,Some ci.ci_ind,no),
+	       pattern_of_constr p,pattern_of_constr a,
 	       Array.map pattern_of_constr br)
     | Fix f -> PFix f
     | CoFix f -> PCoFix f
 
 (* To process patterns, we need a translation without typing at all. *)
 
-let rec inst lvar = function
-  | PVar id as x -> (try List.assoc id lvar with Not_found -> x)
-  | PApp (p,pl) -> PApp (inst lvar p, Array.map (inst lvar) pl)
-  | PSoApp (n,pl) -> PSoApp (n, List.map (inst lvar) pl)
-  | PLambda (n,a,b) -> PLambda (n,inst lvar a,inst lvar b)
-  | PProd (n,a,b) -> PProd (n,inst lvar a,inst lvar b)
-  | PLetIn (n,a,b) -> PLetIn (n,inst lvar a,inst lvar b)
-  | PCase (ci,po,p,pl) ->
-      PCase (ci,option_app (inst lvar) po,inst lvar p,Array.map (inst lvar) pl)
+let map_pattern_with_binders g f l = function
+  | PApp (p,pl) -> PApp (f l p, Array.map (f l) pl)
+  | PSoApp (n,pl) -> PSoApp (n, List.map (f l) pl)
+  | PLambda (n,a,b) -> PLambda (n,f l a,f (g l) b)
+  | PProd (n,a,b) -> PProd (n,f l a,f (g l) b)
+  | PLetIn (n,a,b) -> PLetIn (n,f l a,f (g l) b)
+  | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2)
+  | PCase (ci,po,p,pl) -> PCase (ci,f l po,f l p,Array.map (f l) pl)
   (* Non recursive *)
-  | (PEvar _ | PRel _ | PRef _  | PSort _  | PMeta _ as x) -> x 
+  | (PVar _ | PEvar _ | PRel _ | PRef _  | PSort _  | PMeta _
   (* Bound to terms *)
-  | (PFix _ | PCoFix _ as r) ->
-      error ("Not instantiable pattern")
+  | PFix _ | PCoFix _ as x) -> x
+
+let map_pattern f = map_pattern_with_binders (fun () -> ()) (fun () -> f) ()
+
+let rec instantiate_pattern lvar = function
+  | PVar id as x -> (try Lazy.force(List.assoc id lvar) with Not_found -> x)
+  | (PFix _ | PCoFix _) -> error ("Not instantiable pattern")
+  | c -> map_pattern (instantiate_pattern lvar) c
+
+let rec liftn_pattern k n = function
+  | PRel i as x -> if i >= n then PRel (i+k) else x
+  | PFix x -> PFix (destFix (liftn k n (mkFix x)))
+  | PCoFix x -> PCoFix (destCoFix (liftn k n (mkCoFix x)))
+  | c -> map_pattern_with_binders succ (liftn_pattern k) n c
+
+let lift_pattern k = liftn_pattern k 1
+
+let rec subst_pattern subst pat = match pat with
+  | PRef ref ->
+      let ref',t = subst_global subst ref in
+	if ref' == ref then pat else
+	 pattern_of_constr t
+  | PVar _ 
+  | PEvar _
+  | PRel _ -> pat
+  | PApp (f,args) ->
+      let f' = subst_pattern subst f in 
+      let args' = array_smartmap (subst_pattern subst) args in
+	if f' == f && args' == args then pat else
+	  PApp (f',args')
+  | PSoApp (i,args) ->
+      let args' = list_smartmap (subst_pattern subst) args in
+	if args' == args then pat else
+	  PSoApp (i,args')
+  | PLambda (name,c1,c2) ->
+      let c1' = subst_pattern subst c1 in
+      let c2' = subst_pattern subst c2 in
+	if c1' == c1 && c2' == c2 then pat else
+	  PLambda (name,c1',c2')
+  | PProd (name,c1,c2) ->
+      let c1' = subst_pattern subst c1 in
+      let c2' = subst_pattern subst c2 in
+	if c1' == c1 && c2' == c2 then pat else
+	  PProd (name,c1',c2')
+  | PLetIn (name,c1,c2) ->
+      let c1' = subst_pattern subst c1 in
+      let c2' = subst_pattern subst c2 in
+	if c1' == c1 && c2' == c2 then pat else
+	  PLetIn (name,c1',c2')
+  | PSort _ 
+  | PMeta _ -> pat
+  | PIf (c,c1,c2) ->
+      let c' = subst_pattern subst c in
+      let c1' = subst_pattern subst c1 in
+      let c2' = subst_pattern subst c2 in
+	if c' == c && c1' == c1 && c2' == c2 then pat else
+	  PIf (c',c1',c2')
+  | PCase ((a,b,ind,n as cs),typ,c,branches) ->
+      let ind' = option_smartmap (Inductiveops.subst_inductive subst) ind in
+      let typ' = subst_pattern subst typ in 
+      let c' = subst_pattern subst c in
+      let branches' = array_smartmap (subst_pattern subst) branches in
+      let cs' = if ind == ind' then cs else (a,b,ind',n) in
+	if typ' == typ && c' == c && branches' == branches then pat else
+	  PCase(cs',typ', c', branches') 
+  | PFix fixpoint ->
+      let cstr = mkFix fixpoint in
+      let fixpoint' = destFix (subst_mps subst cstr) in
+	if fixpoint' == fixpoint then pat else
+	  PFix fixpoint'
+  | PCoFix cofixpoint ->
+      let cstr = mkCoFix cofixpoint in
+      let cofixpoint' = destCoFix (subst_mps subst cstr) in
+	if cofixpoint' == cofixpoint then pat else
+	  PCoFix cofixpoint'
 
-let instantiate_pattern = inst
+let mkPLambda na b = PLambda(na,PMeta None,b)
+let rev_it_mkPLambda = List.fold_right mkPLambda 
 
 let rec pat_of_raw metas vars = function
   | RVar (_,id) ->
@@ -230,40 +233,48 @@ let rec pat_of_raw metas vars = function
       PSort s
   | RHole _ ->
       PMeta None
-  | RCast (_,c,t) ->
+  | RCast (_,c,_,t) ->
       Options.if_verbose
         Pp.warning "Cast not taken into account in constr pattern";
       pat_of_raw metas vars c
-  | ROrderedCase (_,st,po,c,br,_) ->
-      PCase ((None,st),option_app (pat_of_raw metas vars) po,
-             pat_of_raw metas vars c,
-             Array.map (pat_of_raw metas vars) br)
   | RIf (_,c,(_,None),b1,b2) ->
-      PCase ((None,IfStyle),None, pat_of_raw metas vars c,
-             [|pat_of_raw metas vars b1; pat_of_raw metas vars b2|])
-  | RCases (loc,(po,_),[c,_],brs) ->
-      let sp =
+      PIf (pat_of_raw metas vars c,
+           pat_of_raw metas vars b1,pat_of_raw metas vars b2)
+  | RLetTuple (loc,nal,(_,None),b,c) ->
+      let mkRLambda c na = RLambda (loc,na,RHole (loc,Evd.InternalHole),c) in
+      let c = List.fold_left mkRLambda c nal in
+      PCase ((LetStyle,[|1|],None,None),PMeta None,pat_of_raw metas vars b,
+             [|pat_of_raw metas vars c|])
+  | RCases (loc,p,[c,(na,indnames)],brs) ->
+      let pred,ind_nargs, ind = match p,indnames with
+	| Some p, Some (_,ind,n,nal) ->
+	    rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas vars p)),
+	    Some (n,List.length nal),Some ind
+	| _ -> PMeta None, None, None in
+      let ind = match ind with Some _ -> ind | None ->
 	match brs with
 	  | (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind
 	  | _ -> None in
-      (* When po disappears: switch to rtn type *)
-      PCase ((sp,Term.RegularStyle),option_app (pat_of_raw metas vars) po,
-             pat_of_raw metas vars c,
-             Array.init (List.length brs)
-	       (pat_of_raw_branch loc metas vars sp brs))
+      let cbrs =
+	Array.init (List.length brs) (pat_of_raw_branch loc metas vars ind brs)
+      in
+      let cstr_nargs,brs = (Array.map fst cbrs, Array.map snd cbrs) in
+      PCase ((RegularStyle,cstr_nargs,ind,ind_nargs), pred,
+             pat_of_raw metas vars c, brs)
+             
   | r ->
       let loc = loc_of_rawconstr r in
-      user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Not supported pattern")
+      user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Pattern not supported")
 
 and pat_of_raw_branch loc metas vars ind brs i =
   let bri = List.filter
     (function
-        (_,_,[PatCstr(_,c,lv,_)],_) -> snd c = i+1
+        (_,_,[PatCstr(_,c,lv,Anonymous)],_) -> snd c = i+1
       | (loc,_,_,_) ->
           user_err_loc (loc,"pattern_of_rawconstr",
                         Pp.str "Not supported pattern")) brs in
   match bri with
-      [(_,_,[PatCstr(_,(indsp,_),lv,_)],br)] ->
+    | [(_,_,[PatCstr(_,(indsp,_),lv,_)],br)] ->
 	if ind <> None & ind <> Some indsp then
           user_err_loc (loc,"pattern_of_rawconstr",
             Pp.str "All constructors must be in the same inductive type");
@@ -274,8 +285,7 @@ and pat_of_raw_branch loc metas vars ind brs i =
                   user_err_loc (loc,"pattern_of_rawconstr",
                                 Pp.str "Not supported pattern")) lv in
         let vars' = List.rev lna @ vars in 
-        List.fold_right (fun na b -> PLambda(na,PMeta None,b)) lna
-          (pat_of_raw metas vars' br)
+	List.length lv, rev_it_mkPLambda lna (pat_of_raw metas vars' br)
     | _ -> user_err_loc (loc,"pattern_of_rawconstr",
                          str "No unique branch for " ++ int (i+1) ++
                          str"-th constructor")
diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli
index cf0d4528..4102db9e 100644
--- a/pretyping/pattern.mli
+++ b/pretyping/pattern.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pattern.mli,v 1.17.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+(*i $Id: pattern.mli 8963 2006-06-19 18:54:49Z barras $ i*)
 
 (*i*)
 open Pp
@@ -17,6 +17,7 @@ open Environ
 open Libnames
 open Nametab
 open Rawterm
+open Mod_subst
 (*i*)
 
 (* Pattern variables *)
@@ -24,10 +25,6 @@ open Rawterm
 type patvar_map = (patvar * constr) list
 val pr_patvar : patvar -> std_ppcmds
 
-(* Only for v7 parsing/printing *)
-val patvar_of_int : int -> patvar
-val patvar_of_int_v7 : int -> patvar
-
 (* Patterns *)
 
 type constr_pattern =
@@ -42,8 +39,9 @@ type constr_pattern =
   | PLetIn of name * constr_pattern * constr_pattern
   | PSort of rawsort
   | PMeta of patvar option
-  | PCase of (inductive option * case_style)
-      * constr_pattern option * constr_pattern * constr_pattern array
+  | PIf of constr_pattern * constr_pattern * constr_pattern
+  | PCase of (case_style * int array * inductive option * (int * int) option)
+      * constr_pattern * constr_pattern * constr_pattern array
   | PFix of fixpoint
   | PCoFix of cofixpoint
 
@@ -51,28 +49,18 @@ val occur_meta_pattern : constr_pattern -> bool
 
 val subst_pattern : substitution -> constr_pattern -> constr_pattern
 
-type constr_label =
-  | ConstNode of constant
-  | IndNode of inductive
-  | CstrNode of constructor
-  | VarNode of identifier
-
-val label_of_ref : global_reference -> constr_label
-
-val subst_label : substitution -> constr_label -> constr_label
-
 exception BoundPattern
 
 (* [head_pattern_bound t] extracts the head variable/constant of the
    type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly
    if [t] is an abstraction *)
 
-val head_pattern_bound : constr_pattern -> constr_label
+val head_pattern_bound : constr_pattern -> global_reference
 
 (* [head_of_constr_reference c] assumes [r] denotes a reference and
    returns its label; raises an anomaly otherwise *)
 
-val head_of_constr_reference : Term.constr -> constr_label
+val head_of_constr_reference : Term.constr -> global_reference
 
 (* [pattern_of_constr c] translates a term [c] with metavariables into
    a pattern; currently, no destructor (Cases, Fix, Cofix) and no
@@ -88,4 +76,6 @@ val pattern_of_rawconstr : rawconstr ->
       patvar list * constr_pattern
 
 val instantiate_pattern :
-  (identifier * constr_pattern) list -> constr_pattern -> constr_pattern
+  (identifier * constr_pattern Lazy.t) list -> constr_pattern -> constr_pattern
+
+val lift_pattern : int -> constr_pattern -> constr_pattern
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index fee1522f..59cdad04 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretype_errors.ml,v 1.25.2.2 2004/07/16 19:30:45 herbelin Exp $ *)
+(* $Id: pretype_errors.ml 9217 2006-10-05 17:31:23Z notin $ *)
 
 open Util
 open Stdpp
@@ -24,8 +24,13 @@ type pretype_error =
   | CantFindCaseType of constr
   (* Unification *)
   | OccurCheck of existential_key * constr
-  | NotClean of existential_key * constr * hole_kind
-  | UnsolvableImplicit of hole_kind
+  | NotClean of existential_key * constr * Evd.hole_kind
+  | UnsolvableImplicit of Evd.hole_kind
+  | CannotUnify of constr * constr
+  | CannotUnifyLocal of Environ.env * constr * constr * constr
+  | CannotUnifyBindingType of constr * constr
+  | CannotGeneralize of constr
+  | NoOccurrenceFound of constr
   (* Pretyping *)
   | VarNotFound of identifier
   | UnexpectedType of constr * constr
@@ -33,6 +38,12 @@ type pretype_error =
 
 exception PretypeError of env * pretype_error
 
+let precatchable_exception = function
+  | Util.UserError _ | TypeError _ | PretypeError _
+  | Stdpp.Exc_located(_,(Util.UserError _ | TypeError _ |
+    Nametab.GlobalizationError _ | PretypeError _)) -> true
+  | _ -> false
+
 let nf_evar = Reductionops.nf_evar
 let j_nf_evar sigma j = 
   { uj_val = nf_evar sigma j.uj_val;
@@ -43,13 +54,13 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} =
   {utj_val=type_app (nf_evar sigma) v;utj_type=t}
 
 let env_ise sigma env =
-  let sign = named_context env in
+  let sign = named_context_val env in
   let ctxt = rel_context env in
   let env0 = reset_with_named_context sign env in
   Sign.fold_rel_context
     (fun (na,b,ty) e ->
       push_rel
-        (na, option_app (nf_evar sigma) b, nf_evar sigma ty)
+        (na, option_map (nf_evar sigma) b, nf_evar sigma ty)
         e)
     ctxt
     ~init:env0
@@ -65,7 +76,7 @@ let contract env lc =
 	  env
       | _ -> 
 	  let t' = substl !l t in
-	  let c' = option_app (substl !l) c in
+	  let c' = option_map (substl !l) c in
 	  let na' = named_hd env t' na in
 	  l := (mkRel 1) :: List.map (lift 1) !l;
 	  push_rel (na',c',t') env in
@@ -126,6 +137,9 @@ let error_ill_typed_rec_body_loc loc env sigma i na jl tys =
      IllTypedRecBody (i,na,jv_nf_evar sigma jl,
                       Array.map (nf_evar sigma) tys))
 
+let error_not_a_type_loc loc env sigma j =
+  raise_located_type_error (loc, env, sigma, NotAType (j_nf_evar sigma j))
+
 (*s Implicit arguments synthesis errors. It is hard to find
     a precise location. *)
 
@@ -141,6 +155,15 @@ let error_not_clean env sigma ev c (loc,k) =
 let error_unsolvable_implicit loc env sigma e =
   raise_with_loc loc (PretypeError (env_ise sigma env, UnsolvableImplicit e))
 
+let error_cannot_unify env sigma (m,n) =
+  raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
+
+let error_cannot_unify_local env sigma (e,m,n,sn) = 
+  raise (PretypeError (env_ise sigma env,CannotUnifyLocal (e,m,n,sn)))
+
+let error_cannot_coerce env sigma (m,n) =
+  raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
+
 (*s Ml Case errors *)
 
 let error_cant_find_case_type_loc loc env sigma expr =
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index ebeff99d..137ef639 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretype_errors.mli,v 1.25.2.3 2004/07/16 19:30:45 herbelin Exp $ i*)
+(*i $Id: pretype_errors.mli 9217 2006-10-05 17:31:23Z notin $ i*)
 
 (*i*)
 open Pp
@@ -26,8 +26,13 @@ type pretype_error =
   | CantFindCaseType of constr
   (* Unification *)
   | OccurCheck of existential_key * constr
-  | NotClean of existential_key * constr * hole_kind
-  | UnsolvableImplicit of hole_kind
+  | NotClean of existential_key * constr * Evd.hole_kind
+  | UnsolvableImplicit of Evd.hole_kind
+  | CannotUnify of constr * constr
+  | CannotUnifyLocal of Environ.env * constr * constr * constr
+  | CannotUnifyBindingType of constr * constr
+  | CannotGeneralize of constr
+  | NoOccurrenceFound of constr
   (* Pretyping *)
   | VarNotFound of identifier
   | UnexpectedType of constr * constr
@@ -35,6 +40,8 @@ type pretype_error =
 
 exception PretypeError of env * pretype_error
 
+val precatchable_exception : exn -> bool
+
 (* Presenting terms without solved evars *)
 val nf_evar :  Evd.evar_map -> constr -> constr
 val j_nf_evar :  Evd.evar_map -> unsafe_judgment -> unsafe_judgment
@@ -73,14 +80,24 @@ val error_ill_typed_rec_body_loc :
   loc -> env ->  Evd.evar_map ->
       int -> name array -> unsafe_judgment array -> types array -> 'b
 
+val error_not_a_type_loc :
+  loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b
+
+val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b
+
 (*s Implicit arguments synthesis errors *)
 
 val error_occur_check : env ->  Evd.evar_map -> existential_key -> constr -> 'b
 
 val error_not_clean :
-  env ->  Evd.evar_map -> existential_key -> constr -> loc * hole_kind -> 'b
+  env -> Evd.evar_map -> existential_key -> constr -> loc * Evd.hole_kind -> 'b
+
+val error_unsolvable_implicit :
+  loc -> env -> Evd.evar_map -> Evd.hole_kind -> 'b
+
+val error_cannot_unify : env -> Evd.evar_map -> constr * constr -> 'b
 
-val error_unsolvable_implicit : loc -> env -> Evd.evar_map -> hole_kind -> 'b
+val error_cannot_unify_local : env -> Evd.evar_map -> Environ.env * constr * constr * constr -> 'b
 
 (*s Ml Case errors *)
 
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index bb0e74bb..0b00c82c 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretyping.ml,v 1.123.2.5 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: pretyping.ml 9338 2006-11-03 13:09:53Z herbelin $ *)
 
 open Pp
 open Util
@@ -20,6 +20,7 @@ open Environ
 open Type_errors
 open Typeops
 open Libnames
+open Nameops
 open Classops
 open List
 open Recordops 
@@ -27,86 +28,18 @@ open Evarutil
 open Pretype_errors
 open Rawterm
 open Evarconv
-open Coercion
 open Pattern
 open Dyn
 
+type typing_constraint = OfType of types option | IsType
+type var_map = (identifier * unsafe_judgment) list
+type unbound_ltac_var_map = (identifier * identifier option) list
 
 (************************************************************************)
 (* This concerns Cases *)
 open Declarations
 open Inductive
 open Inductiveops
-open Instantiate
-
-let lift_context n l = 
-  let k = List.length l in 
-  list_map_i (fun i (name,c) -> (name,liftn n (k-i) c)) 0 l
-
-let transform_rec loc env sigma (pj,c,lf) indt = 
-  let p = pj.uj_val in
-  let (indf,realargs) = dest_ind_type indt in
-  let (ind,params) = dest_ind_family indf in
-  let (mib,mip) = lookup_mind_specif env ind in
-  let recargs = mip.mind_recargs in
-  let mI = mkInd ind in
-  let ci = make_default_case_info env (if Options.do_translate() then RegularStyle else MatchStyle) ind in
-  let nconstr = Array.length mip.mind_consnames in
-  if Array.length lf <> nconstr then 
-    (let cj = {uj_val=c; uj_type=mkAppliedInd indt} in
-     error_number_branches_loc loc env sigma cj nconstr);
-  let tyi = snd ind in
-  if mis_is_recursive_subset [tyi] recargs then
-    let dep =
-      is_dependent_elimination env (nf_evar sigma pj.uj_type) indf in 
-    let init_depFvec i = if i = tyi then Some(dep,mkRel 1) else None in
-    let depFvec = Array.init mib.mind_ntypes init_depFvec in
-    (* build now the fixpoint *)
-    let lnames,_ = get_arity env indf in
-    let nar = List.length lnames in
-    let nparams = mip.mind_nparams in
-    let constrs = get_constructors env (lift_inductive_family (nar+2) indf) in
-    let branches = 
-      array_map3
-	(fun f t reca -> 
-	   whd_beta
-             (Indrec.make_rec_branch_arg env sigma
-                (nparams,depFvec,nar+1)
-                f t reca))
-        (Array.map (lift (nar+2)) lf) constrs (dest_subterms recargs) 
-    in 
-    let deffix = 
-      it_mkLambda_or_LetIn_name env
-	(lambda_create env
-	   (applist (mI,List.append (List.map (lift (nar+1)) params)
-                       (extended_rel_list 0 lnames)),
-            mkCase (ci, lift (nar+2) p, mkRel 1, branches)))
-        (lift_rel_context 1 lnames) 
-    in
-    if noccurn 1 deffix then 
-      whd_beta (applist (pop deffix,realargs@[c]))
-    else
-      let ind = applist (mI,(List.append 
-			     (List.map (lift nar) params)
-			     (extended_rel_list 0 lnames))) in
-      let typPfix = 
-	it_mkProd_or_LetIn_name env
-	  (prod_create env 
-	     (ind,
-	      (if dep then
-		 let ext_lnames = (Anonymous,None,ind)::lnames in
-		 let args = extended_rel_list 0 ext_lnames in
-		 whd_beta (applist (lift (nar+1) p, args))
-	       else
-		 let args = extended_rel_list 1 lnames in
-		 whd_beta (applist (lift (nar+1) p, args)))))
-          lnames in
-      let fix =
-        mkFix (([|nar|],0),
-	       ([|Name(id_of_string "F")|],[|typPfix|],[|deffix|])) in
-      applist (fix,realargs@[c])
-  else
-    mkCase (ci, p, c, lf)
 
 (************************************************************************)
 
@@ -114,909 +47,647 @@ let transform_rec loc env sigma (pj,c,lf) indt =
 let ((constr_in : constr -> Dyn.t),
      (constr_out : Dyn.t -> constr)) = create "constr"
 
-let mt_evd = Evd.empty
-
-let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
-
-(* Utilisé pour inférer le prédicat des Cases *)
-(* Semble exagérement fort *)
-(* Faudra préférer une unification entre les types de toutes les clauses *)
-(* et autoriser des ? à rester dans le résultat de l'unification *)
-
-let evar_type_fixpoint loc env isevars lna lar vdefj =
-  let lt = Array.length vdefj in 
-    if Array.length lar = lt then 
-      for i = 0 to lt-1 do 
-        if not (the_conv_x_leq env isevars
-		  (vdefj.(i)).uj_type
-		  (lift lt lar.(i))) then
-          error_ill_typed_rec_body_loc loc env (evars_of isevars)
-            i lna vdefj lar
-      done
-
-let check_branches_message loc env isevars c (explft,lft) = 
-  for i = 0 to Array.length explft - 1 do
-    if not (the_conv_x_leq env isevars lft.(i) explft.(i)) then 
-      let sigma = evars_of isevars in
-      error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
-  done
-
-(* coerce to tycon if any *)
-let inh_conv_coerce_to_tycon loc env isevars j = function
-   | None -> j
-   | Some typ -> inh_conv_coerce_to loc env isevars j typ
-
-let push_rels vars env = List.fold_right push_rel vars env
-
-(*
-let evar_type_case isevars env ct pt lft p c =
-  let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c
-  in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty)
-*)
-
-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 pretype_id loc env (lvar,unbndltacvars) id =
-  let id = strip_meta id in (* May happen in tactics defined by Grammar *)
-  try
-    let (n,typ) = lookup_rel_id id (rel_context env) in
-    { uj_val  = mkRel n; uj_type = type_app (lift n) typ }
-  with Not_found ->
-  try
-    List.assoc id lvar
-  with Not_found ->
-  try
-    let (_,_,typ) = lookup_named id env in
-    { uj_val  = mkVar id; uj_type = typ }
-  with Not_found ->
-  try (* To build a nicer ltac error message *)
-    match List.assoc id unbndltacvars with
-      | None -> user_err_loc (loc,"",
-	  str (string_of_id id ^ " ist not bound to a term"))
-      | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
-  with Not_found ->
-    error_var_not_found_loc loc id
-
-(* make a dependent predicate from an undependent one *)
-
-let make_dep_of_undep env (IndType (indf,realargs)) pj =
-  let n = List.length realargs in
-  let rec decomp n p =
-    if n=0 then p else
-      match kind_of_term p with
-	| Lambda (_,_,c) -> decomp (n-1) c
-	| _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) 
-  in
-  let sign,s = decompose_prod_n n pj.uj_type in
-  let ind = build_dependent_inductive env indf in
-  let s' = mkProd (Anonymous, ind, s) in
-  let ccl = lift 1 (decomp n pj.uj_val) in
-  let ccl' = mkLambda (Anonymous, ind, ccl) in
-  {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} 
-
-(*************************************************************************)
-(* Main pretyping function                                               *)
-
-let pretype_ref isevars env ref = 
-  let c = constr_of_reference ref in
-  make_judge c (Retyping.get_type_of env Evd.empty c)
-
-let pretype_sort = function
-  | RProp c -> judge_of_prop_contents c
-  | RType _ -> judge_of_new_Type ()
-
-(* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
-(* in environment [env], with existential variables [(evars_of isevars)] and *)
-(* the type constraint tycon *)
-let rec pretype tycon env isevars lvar = function
-
-  | RRef (loc,ref) ->
-      inh_conv_coerce_to_tycon loc env isevars
-	(pretype_ref isevars env ref)
-	tycon
-
-  | RVar (loc, id) ->
-      inh_conv_coerce_to_tycon loc env isevars
-	(pretype_id loc env lvar id)
-	tycon
-
-  | REvar (loc, ev, instopt) ->
-      (* Ne faudrait-il pas s'assurer que hyps est bien un
-      sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-      let hyps = (Evd.map (evars_of isevars) ev).evar_hyps in
-      let args = match instopt with
-        | None -> instance_from_named_context hyps
-        | Some inst -> failwith "Evar subtitutions not implemented" in
-      let c = mkEvar (ev, args) in
-      let j = (Retyping.get_judgment_of env (evars_of isevars) c) in
-      inh_conv_coerce_to_tycon loc env isevars j tycon
-
-  | RPatVar (loc,(someta,n)) -> 
-      anomaly "Found a pattern variable in a rawterm to type"
-	   
-  | RHole (loc,k) ->
-      (match tycon with
-	 | Some ty ->
-	     { uj_val = new_isevar isevars env (loc,k) ty; uj_type = ty }
-	 | None -> error_unsolvable_implicit loc env (evars_of isevars) k)
-
-  | RRec (loc,fixkind,names,bl,lar,vdef) ->
-      let rec type_bl env ctxt = function
-          [] -> ctxt
-        | (na,None,ty)::bl ->
-            let ty' = pretype_type empty_valcon env isevars lvar ty in
-            let dcl = (na,None,ty'.utj_val) in
-            type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
-        | (na,Some bd,ty)::bl ->
-            let ty' = pretype_type empty_valcon env isevars lvar ty in
-            let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
-            let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
-            type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
-      let ctxtv = Array.map (type_bl env empty_rel_context) bl in
-      let larj =
-        array_map2
-          (fun e ar ->
-            pretype_type empty_valcon (push_rel_context e env) isevars lvar ar)
-          ctxtv lar in
-      let lara = Array.map (fun a -> a.utj_val) larj in
-      let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
-      let nbfix = Array.length lar in
-      let names = Array.map (fun id -> Name id) names in
-      (* Note: bodies are not used by push_rec_types, so [||] is safe *)
-      let newenv = push_rec_types (names,ftys,[||]) env in
-      let vdefj =
-	array_map2_i 
-	  (fun i ctxt def ->
-            (* we lift nbfix times the type in tycon, because of
-	     * the nbfix variables pushed to newenv *)
-            let (ctxt,ty) =
-              decompose_prod_n_assum (rel_context_length ctxt)
-                (lift nbfix ftys.(i)) in
-            let nenv = push_rel_context ctxt newenv in
-            let j = pretype (mk_tycon ty) nenv isevars lvar def in
-            { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
-              uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
-          ctxtv vdef in
-      evar_type_fixpoint loc env isevars names ftys vdefj;
-      let fixj =
-	match fixkind with
-	  | RFix (vn,i as vni) ->
-	      let fix = (vni,(names,ftys,Array.map j_val vdefj)) in
+(** Miscellaneous interpretation functions *)
+  
+let interp_sort = function
+  | RProp c -> Prop c
+  | RType _ -> new_Type_sort ()
+      
+let interp_elimination_sort = function
+  | RProp Null -> InProp
+  | RProp Pos  -> InSet
+  | RType _ -> InType
+
+module type S = 
+sig
+
+  module Cases : Cases.S
+  
+  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+  val allow_anonymous_refs : bool ref
+
+  (* Generic call to the interpreter from rawconstr to open_constr, leaving
+     unresolved holes as evars and returning the typing contexts of
+     these evars. Work as [understand_gen] for the rest. *)
+  
+  val understand_tcc :
+    evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
+
+  val understand_tcc_evars :
+    evar_defs ref -> env -> typing_constraint -> rawconstr -> constr
+    
+  (* More general entry point with evars from ltac *)
+    
+  (* Generic call to the interpreter from rawconstr to constr, failing
+     unresolved holes in the rawterm cannot be instantiated.
+     
+     In [understand_ltac sigma env ltac_env constraint c],
+     
+     sigma : initial set of existential variables (typically dependent subgoals)
+     ltac_env : partial substitution of variables (used for the tactic language)
+     constraint : tell if interpreted as a possibly constrained term or a type 
+  *)
+    
+  val understand_ltac :
+    evar_map -> env -> var_map * unbound_ltac_var_map ->
+    typing_constraint -> rawconstr -> evar_defs * constr
+    
+  (* Standard call to get a constr from a rawconstr, resolving implicit args *)
+    
+  val understand : evar_map -> env -> ?expected_type:Term.types ->
+    rawconstr -> constr
+    
+  (* Idem but the rawconstr is intended to be a type *)
+    
+  val understand_type : evar_map -> env -> rawconstr -> constr
+    
+  (* A generalization of the two previous case *)
+    
+  val understand_gen : typing_constraint -> evar_map -> env -> 
+    rawconstr -> constr
+    
+  (* Idem but returns the judgment of the understood term *)
+    
+  val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+
+  (* Idem but do not fail on unresolved evars *)
+
+  val understand_judgment_tcc : evar_defs ref -> env -> rawconstr -> unsafe_judgment
+
+  (*i*)
+  (* Internal of Pretyping...
+   * Unused outside, but useful for debugging
+   *)
+  val pretype : 
+    type_constraint -> env -> evar_defs ref -> 
+    var_map * (identifier * identifier option) list ->
+    rawconstr -> unsafe_judgment
+    
+  val pretype_type : 
+    val_constraint -> env -> evar_defs ref ->
+    var_map * (identifier * identifier option) list ->
+    rawconstr -> unsafe_type_judgment
+
+  val pretype_gen :
+    evar_defs ref -> env -> 
+    var_map * (identifier * identifier option) list ->
+    typing_constraint -> rawconstr -> constr
+
+    (*i*)
+end
+
+module Pretyping_F (Coercion : Coercion.S) = struct
+
+  module Cases = Cases.Cases_F(Coercion)
+
+  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+  let allow_anonymous_refs = ref false
+
+  let evd_comb0 f isevars =
+    let (evd',x) = f !isevars in
+      isevars := evd';
+      x
+
+  let evd_comb1 f isevars x =
+    let (evd',y) = f !isevars x in
+      isevars := evd';
+      y
+
+  let evd_comb2 f isevars x y =
+    let (evd',z) = f !isevars x y in
+      isevars := evd';
+      z
+
+  let evd_comb3 f isevars x y z =
+    let (evd',t) = f !isevars x y z in
+      isevars := evd';
+      t
+	
+  let mt_evd = Evd.empty
+    
+  let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
+      
+  (* Utilisé pour inférer le prédicat des Cases *)
+  (* Semble exagérement fort *)
+  (* Faudra préférer une unification entre les types de toutes les clauses *)
+  (* et autoriser des ? à rester dans le résultat de l'unification *)
+  
+  let evar_type_fixpoint loc env isevars lna lar vdefj =
+    let lt = Array.length vdefj in 
+      if Array.length lar = lt then 
+	for i = 0 to lt-1 do 
+          if not (e_cumul env isevars (vdefj.(i)).uj_type
+		    (lift lt lar.(i))) then
+            error_ill_typed_rec_body_loc loc env (evars_of !isevars)
+              i lna vdefj lar
+	done
+
+  let check_branches_message loc env isevars c (explft,lft) = 
+    for i = 0 to Array.length explft - 1 do
+      if not (e_cumul env isevars lft.(i) explft.(i)) then 
+	let sigma = evars_of !isevars in
+	  error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
+    done
+
+  (* coerce to tycon if any *)
+  let inh_conv_coerce_to_tycon loc env isevars j = function
+    | None -> j
+    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t
+
+  let push_rels vars env = List.fold_right push_rel vars env
+
+  (*
+    let evar_type_case isevars env ct pt lft p c =
+    let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c
+    in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty)
+  *)
+
+  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 pretype_id loc env (lvar,unbndltacvars) id =
+    let id = strip_meta id in (* May happen in tactics defined by Grammar *)
+      try
+	let (n,typ) = lookup_rel_id id (rel_context env) in
+	  { uj_val  = mkRel n; uj_type = type_app (lift n) typ }
+      with Not_found ->
+	try
+	  List.assoc id lvar
+	with Not_found ->
+	  try
+	    let (_,_,typ) = lookup_named id env in
+	      { uj_val  = mkVar id; uj_type = typ }
+	  with Not_found ->
+	    try (* To build a nicer ltac error message *)
+	      match List.assoc id unbndltacvars with
+		| None -> user_err_loc (loc,"",
+					str "variable " ++ pr_id id ++ str " should be bound to a term")
+		| Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
+	    with Not_found ->
+	      error_var_not_found_loc loc id
+
+  (* make a dependent predicate from an undependent one *)
+
+  let make_dep_of_undep env (IndType (indf,realargs)) pj =
+    let n = List.length realargs in
+    let rec decomp n p =
+      if n=0 then p else
+	match kind_of_term p with
+	  | Lambda (_,_,c) -> decomp (n-1) c
+	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) 
+    in
+    let sign,s = decompose_prod_n n pj.uj_type in
+    let ind = build_dependent_inductive env indf in
+    let s' = mkProd (Anonymous, ind, s) in
+    let ccl = lift 1 (decomp n pj.uj_val) in
+    let ccl' = mkLambda (Anonymous, ind, ccl) in
+      {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} 
+
+  let evar_kind_of_term sigma c =
+    kind_of_term (whd_evar (Evd.evars_of sigma) c)
+
+  (*************************************************************************)
+  (* Main pretyping function                                               *)
+
+  let pretype_ref isevars env ref = 
+    let c = constr_of_global ref in
+      make_judge c (Retyping.get_type_of env Evd.empty c)
+
+  let pretype_sort = function
+    | RProp c -> judge_of_prop_contents c
+    | RType _ -> judge_of_new_Type ()
+
+  (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
+  (* in environment [env], with existential variables [(evars_of isevars)] and *)
+  (* the type constraint tycon *)
+  let rec pretype (tycon : type_constraint) env isevars lvar = function
+    | RRef (loc,ref) ->
+	inh_conv_coerce_to_tycon loc env isevars
+	  (pretype_ref isevars env ref)
+	  tycon
+
+    | RVar (loc, id) ->
+	inh_conv_coerce_to_tycon loc env isevars
+	  (pretype_id loc env lvar id)
+	  tycon
+
+    | REvar (loc, ev, instopt) ->
+	(* Ne faudrait-il pas s'assurer que hyps est bien un
+	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
+	let hyps = evar_context (Evd.find (evars_of !isevars) ev) in
+	let args = match instopt with
+          | None -> instance_from_named_context hyps
+          | Some inst -> failwith "Evar subtitutions not implemented" in
+	let c = mkEvar (ev, args) in
+	let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
+	  inh_conv_coerce_to_tycon loc env isevars j tycon
+
+    | RPatVar (loc,(someta,n)) -> 
+	anomaly "Found a pattern variable in a rawterm to type"
+	  
+    | RHole (loc,k) ->
+	let ty =
+          match tycon with 
+            | Some (None, ty) -> ty
+            | None | Some _ ->
+		e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) in
+	  { uj_val = e_new_evar isevars env ~src:(loc,k) ty; uj_type = ty }
+
+    | RRec (loc,fixkind,names,bl,lar,vdef) ->
+	let rec type_bl env ctxt = function
+            [] -> ctxt
+          | (na,None,ty)::bl ->
+              let ty' = pretype_type empty_valcon env isevars lvar ty in
+              let dcl = (na,None,ty'.utj_val) in
+		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
+          | (na,Some bd,ty)::bl ->
+              let ty' = pretype_type empty_valcon env isevars lvar ty in
+              let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
+              let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
+		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
+	let ctxtv = Array.map (type_bl env empty_rel_context) bl in
+	let larj =
+          array_map2
+            (fun e ar ->
+               pretype_type empty_valcon (push_rel_context e env) isevars lvar ar)
+            ctxtv lar in
+	let lara = Array.map (fun a -> a.utj_val) larj in
+	let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
+	let nbfix = Array.length lar in
+	let names = Array.map (fun id -> Name id) names in
+	  (* Note: bodies are not used by push_rec_types, so [||] is safe *)
+	let newenv = push_rec_types (names,ftys,[||]) env in
+	let vdefj =
+	  array_map2_i 
+	    (fun i ctxt def ->
+               (* we lift nbfix times the type in tycon, because of
+		* the nbfix variables pushed to newenv *)
+               let (ctxt,ty) =
+		 decompose_prod_n_assum (rel_context_length ctxt)
+                   (lift nbfix ftys.(i)) in
+               let nenv = push_rel_context ctxt newenv in
+               let j = pretype (mk_tycon ty) nenv isevars lvar def in
+		 { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
+		   uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
+            ctxtv vdef in
+	evar_type_fixpoint loc env isevars names ftys vdefj;
+	let fixj = match fixkind with
+	  | RFix (vn,i) ->
+	      let guard_indexes = Array.mapi 
+		(fun i (n,_) -> match n with 
+		   | Some n -> n 
+		   | None -> 
+		       (* Recursive argument was not given by the user : We
+			  check that there is only one inductive argument *)
+		       let ctx = ctxtv.(i) in 
+		       let isIndApp t = 
+			 isInd (fst (decompose_app (strip_head_cast t))) in
+			 (* This could be more precise (e.g. do some delta) *)
+		       let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in
+		       try (list_unique_index true lb) - 1
+		       with Not_found -> 
+			 Util.user_err_loc
+			   (loc,"pretype",
+			    Pp.str "cannot guess decreasing argument of fix"))
+		vn 
+	      in
+	      let fix = ((guard_indexes, i),(names,ftys,Array.map j_val vdefj)) in
 	      (try check_fix env fix with e -> Stdpp.raise_with_loc loc e);
 	      make_judge (mkFix fix) ftys.(i)
 	  | RCoFix i -> 
 	      let cofix = (i,(names,ftys,Array.map j_val vdefj)) in
 	      (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
 	      make_judge (mkCoFix cofix) ftys.(i) in
-      inh_conv_coerce_to_tycon loc env isevars fixj tycon
-
-  | RSort (loc,s) ->
-      inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
-
-  | RApp (loc,f,args) -> 
-      let fj = pretype empty_tycon env isevars lvar f in
-      let floc = loc_of_rawconstr f in
-      let rec apply_rec env n resj = function
-	| [] -> resj
-	| c::rest ->
-	    let argloc = loc_of_rawconstr c in
-	    let resj = inh_app_fun env isevars resj in
-            let resty =
-              whd_betadeltaiota env (evars_of isevars) resj.uj_type in
-      	    match kind_of_term resty with
-	      | Prod (na,c1,c2) ->
-		  let hj = pretype (mk_tycon c1) env isevars lvar c in
-		  let newresj =
-      		    { uj_val = applist (j_val resj, [j_val hj]);
-		      uj_type = subst1 hj.uj_val c2 } in
-		  apply_rec env (n+1) newresj rest
-
-	      | _ ->
-		  let hj = pretype empty_tycon env isevars lvar c in
-		  error_cant_apply_not_functional_loc 
-		    (join_loc floc argloc) env (evars_of isevars)
-	      	    resj [hj]
-
-      in let resj = apply_rec env 1 fj args in
-      (*
-	let apply_one_arg (floc,tycon,jl) c =
-	let (dom,rng) = split_tycon floc env isevars tycon in
-	let cj = pretype dom env isevars lvar c in
-	let rng_tycon = option_app (subst1 cj.uj_val) rng in
-	let argloc = loc_of_rawconstr c in
-	(join_loc floc argloc,rng_tycon,(argloc,cj)::jl)  in
-	let _,_,jl =
-	List.fold_left apply_one_arg (floc,mk_tycon j.uj_type,[]) args in
-	let jl = List.rev jl in
-	let resj = inh_apply_rel_list loc env isevars jl (floc,j) tycon in
-      *)
-      inh_conv_coerce_to_tycon loc env isevars resj tycon
-
-  | RLambda(loc,name,c1,c2)      ->
-      let (name',dom,rng) = split_tycon loc env isevars tycon in
-      let dom_valcon = valcon_of_tycon dom in
-      let j = pretype_type dom_valcon env isevars lvar c1 in
-      let var = (name,None,j.utj_val) in
-      let j' = pretype rng (push_rel var env) isevars lvar c2 in 
-      judge_of_abstraction env name j j'
-
-  | RProd(loc,name,c1,c2)        ->
-      let j = pretype_type empty_valcon env isevars lvar c1 in
-      let var = (name,j.utj_val) in
-      let env' = push_rel_assum var env in
-      let j' = pretype_type empty_valcon env' isevars lvar c2 in
-      let resj =
-	try judge_of_product env name j j'
-	with TypeError _ as e -> Stdpp.raise_with_loc loc e in
-      inh_conv_coerce_to_tycon loc env isevars resj tycon
-	
-  | RLetIn(loc,name,c1,c2)      ->
-      let j = pretype empty_tycon env isevars lvar c1 in
-      let t = Evarutil.refresh_universes j.uj_type in
-      let var = (name,Some j.uj_val,t) in
-        let tycon = option_app (lift 1) tycon in
-      let j' = pretype tycon (push_rel var env) isevars lvar c2 in
-      { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
-	uj_type = type_app (subst1 j.uj_val) j'.uj_type }
-
-  | RLetTuple (loc,nal,(na,po),c,d) ->
-      let cj = pretype empty_tycon env isevars lvar c in
-      let (IndType (indf,realargs) as indt) = 
-	try find_rectype env (evars_of isevars) cj.uj_type
-	with Not_found ->
-	  let cloc = loc_of_rawconstr c in
-	  error_case_not_inductive_loc cloc env (evars_of isevars) cj 
-      in
-      let cstrs = get_constructors env indf in
-      if Array.length cstrs <> 1 then
-        user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
-      let cs = cstrs.(0) in
-      if List.length nal <> cs.cs_nargs then
-        user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
-      let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
-        (List.rev nal) cs.cs_args in
-      let env_f = push_rels fsign env in
-      (* Make dependencies from arity signature impossible *)
-      let arsgn,_ = get_arity env indf in
-      let arsgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn in
-      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-      let nar = List.length arsgn in
-      (match po with
-	 | Some p ->
-             let env_p = push_rels psign env in
-             let pj = pretype_type empty_valcon env_p isevars lvar p in
-             let ccl = nf_evar (evars_of isevars) pj.utj_val in
-	     let psign = make_arity_signature env true indf in (* with names *)
-	     let p = it_mkLambda_or_LetIn ccl psign in
-             let inst = 
-	       (Array.to_list cs.cs_concl_realargs)
-	       @[build_dependent_constructor cs] in
-	     let lp = lift cs.cs_nargs p in
-             let fty = hnf_lam_applist env (evars_of isevars) lp inst in
-	     let fj = pretype (mk_tycon fty) env_f isevars lvar d in
-	     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-	     let v =
-	       let mis,_ = dest_ind_family indf in
-	       let ci = make_default_case_info env LetStyle mis in
-	       mkCase (ci, p, cj.uj_val,[|f|]) in 
-             let cs = build_dependent_constructor cs in
-	     { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
-
-	 | None -> 
-             let tycon = option_app (lift cs.cs_nargs) tycon in
-	     let fj = pretype tycon env_f isevars lvar d in
-	     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-	     let ccl = nf_evar (evars_of isevars) fj.uj_type in
-             let ccl =
-               if noccur_between 1 cs.cs_nargs ccl then
-                 lift (- cs.cs_nargs) ccl 
-               else
-                 error_cant_find_case_type_loc loc env (evars_of isevars) 
-                   cj.uj_val in
-             let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
-	     let v =
-	       let mis,_ = dest_ind_family indf in
-	       let ci = make_default_case_info env LetStyle mis in
-	       mkCase (ci, p, cj.uj_val,[|f|] ) 
-	     in
-	     { uj_val = v; uj_type = ccl })
-
-  (* Special Case for let constructions to avoid exponential behavior *)      
-  | ROrderedCase (loc,st,po,c,[|f|],xx) when st <> MatchStyle ->
-      let cj = pretype empty_tycon env isevars lvar c in
-      let (IndType (indf,realargs) as indt) = 
-	try find_rectype env (evars_of isevars) cj.uj_type
-	with Not_found ->
-	  let cloc = loc_of_rawconstr c in
-	  error_case_not_inductive_loc cloc env (evars_of isevars) cj 
-      in
-      let j = match po with
-	 | Some p ->
-             let pj = pretype empty_tycon env isevars lvar p in
-             let dep = is_dependent_elimination env pj.uj_type indf in
-             let ar =
-               arity_of_case_predicate env indf dep (Type (new_univ())) in
-             let _ = the_conv_x_leq env isevars pj.uj_type ar in
-	     let pj = j_nf_evar (evars_of isevars) pj in
-	     let pj = if dep then pj else make_dep_of_undep env indt pj in
-	     let (bty,rsty) = 
-	       Indrec.type_rec_branches 
-		 false env (evars_of isevars) indt pj.uj_val cj.uj_val 
-	     in
-	     if Array.length bty <> 1 then
-	       error_number_branches_loc 
-		 loc env (evars_of isevars) cj (Array.length bty);
-	     let fj = 
-	       let tyc = bty.(0) in 
-	       pretype (mk_tycon tyc) env isevars lvar f 
-	     in
-	     let fv = j_val fj in
-	     let ft = fj.uj_type in
-	     check_branches_message loc env isevars cj.uj_val (bty,[|ft|]);
-	     let v =
-	       let mis,_ = dest_ind_family indf in
-	       let ci = make_default_case_info env st mis in
-	       mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,[|fv|])
-	     in 
-	     { uj_val = v;  uj_type = rsty }
-
-	 | None -> 
-             (* get type information from type of branches *)
-	     let expbr = Cases.branch_scheme env isevars false indf in
-	     if Array.length expbr <> 1 then
-	       error_number_branches_loc loc env (evars_of isevars) 
-		 cj (Array.length expbr);
-             let expti = expbr.(0) in
-	     let fj = pretype (mk_tycon expti) env isevars lvar f in
-	     let use_constraint () =
-               (* get type information from constraint *)
-               (* warning: if the constraint comes from an evar type, it *)
-               (* may be Type while Prop or Set would be expected *)
-	       match tycon with
-		 | Some pred ->
-		     let arsgn = make_arity_signature env true indf in
-                     let pred = lift (List.length arsgn) pred in
-  		     let pred = 
-                       it_mkLambda_or_LetIn (nf_evar (evars_of isevars) pred)
-			 arsgn in
-                     false, pred
-	         | None ->
-                     let sigma = evars_of isevars in
-                     error_cant_find_case_type_loc loc env sigma cj.uj_val
-	     in
-             let ok, p =
-	       try
-		 let pred = 
-		   Cases.pred_case_ml 
-		     env (evars_of isevars) false indt (0,fj.uj_type) 
-		 in 
-		 if has_undefined_isevars isevars pred then
-		   use_constraint ()
-		 else
-		   true, pred
-	       with Cases.NotInferable _ ->
-		 use_constraint ()
-	     in 
-	     let p = nf_evar (evars_of isevars) p in
-	     let (bty,rsty) =
-	       Indrec.type_rec_branches
-		 false env (evars_of isevars) indt p cj.uj_val 
-	     in
-	     let _ = option_app (the_conv_x_leq env isevars rsty) tycon in
-	     let fj = 
-	       if ok then fj 
-	       else pretype (mk_tycon bty.(0)) env isevars lvar f 
-	     in
-	     let fv = fj.uj_val in
-	     let ft = fj.uj_type in
-	     let v =
-	       let mis,_ = dest_ind_family indf in
-	       let ci = make_default_case_info env st mis in
-	       mkCase (ci, (nf_betaiota p), cj.uj_val,[|fv|] ) 
-	     in
-	     { uj_val = v; uj_type = rsty } in
-
-      (* Build the LetTuple form for v8 *)
-      let c =
-        let (ind,params) = dest_ind_family indf in
-        let rtntypopt, indnalopt = match po with
-          | None -> None, (Anonymous,None)
-          | Some p ->
-              let pj = pretype empty_tycon env isevars lvar p in
-              let dep = is_dependent_elimination env pj.uj_type indf in
-              let rec decomp_lam_force n avoid l p =
-                (* avoid is not exhaustive ! *)
-                if n = 0 then (List.rev l,p,avoid) else
-                  match p with
-                    | RLambda (_,(Name id as na),_,c) -> 
-                        decomp_lam_force (n-1) (id::avoid) (na::l) c
-                    | RLambda (_,(Anonymous as na),_,c) ->
-                        decomp_lam_force (n-1) avoid (na::l) c
-                    | _ ->
-                        let x = Nameops.next_ident_away (id_of_string "x") avoid in
-                        decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
-                          (* eta-expansion *)
-                          (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in
-              let (nal,p,avoid) = 
-                decomp_lam_force (List.length realargs) [] [] p in
-              let na,rtntyp,_ = 
-                if dep then decomp_lam_force 1 avoid [] p
-                else [Anonymous],p,[] in
-              let intyp =
-                if List.for_all
-                  (function
-                    | Anonymous -> true
-                    | Name id -> not (occur_rawconstr id rtntyp)) nal
-                then (* No dependency in realargs *)
-                  None
-                else
-                  let args = List.map (fun _ -> Anonymous) params @ nal in
-                  Some (dummy_loc,ind,args) in
-              (Some rtntyp,(List.hd na,intyp)) in
-        let cs = (get_constructors env indf).(0) in
-        match indnalopt with
-          | (na,None) -> (* Represented as a let *)
-              let rec decomp_lam_force n avoid l p =
-                if n = 0 then (List.rev l,p) else
-                  match p with
-                    | RLambda (_,(Name id as na),_,c) -> 
-                        decomp_lam_force (n-1) (id::avoid) (na::l) c
-                    | RLambda (_,(Anonymous as na),_,c) -> 
-                        decomp_lam_force (n-1) avoid (na::l) c
-                    | _ ->
-                        let x = Nameops.next_ident_away (id_of_string "x") avoid in
-                        decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
-                          (* eta-expansion *)
-                          (let a = RVar (dummy_loc,x) in
-                          match p with
-                            | RApp (loc,p,l) -> RApp (loc,p,l@[a])
-                            | _ -> (RApp (dummy_loc,p,[a]))) in
-              let (nal,d) = decomp_lam_force cs.cs_nargs [] [] f in
-              RLetTuple (loc,nal,(na,rtntypopt),c,d)
-          | _ -> (* Represented as a match *)
-            let detype_eqn constr construct_nargs branch =
-              let name_cons = function 
-                | Anonymous -> fun l -> l
-                | Name id -> fun l -> id::l in
-              let make_pat na avoid b ids =
-                PatVar (dummy_loc,na),
-                name_cons na avoid,name_cons na ids
-              in
-              let rec buildrec ids patlist avoid n b =
-                if n=0 then
-                  (dummy_loc, ids, 
-                  [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
-                  b)
-                else
-                  match b with
-	            | RLambda (_,x,_,b) -> 
-	                let pat,new_avoid,new_ids = make_pat x avoid b ids in
-                        buildrec new_ids (pat::patlist) new_avoid (n-1) b
-                          
-	            | RLetIn (_,x,_,b) -> 
-	                let pat,new_avoid,new_ids = make_pat x avoid b ids in
-                        buildrec new_ids (pat::patlist) new_avoid (n-1) b
-                          
-	            | RCast (_,c,_) ->    (* Oui, il y a parfois des cast *)
-	                buildrec ids patlist avoid n c
-                        
-	            | _ -> (* eta-expansion *)
-                        (* nommage de la nouvelle variable *)
-                        let id = Nameops.next_ident_away (id_of_string "x") avoid in
-	                let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in
-                        let pat,new_avoid,new_ids =
-	                  make_pat (Name id) avoid new_b ids in
-	                buildrec new_ids (pat::patlist) new_avoid (n-1) new_b
-	                  
-              in 
-              buildrec [] [] [] construct_nargs branch in
-            let eqn = detype_eqn (ind,1) cs.cs_nargs f in
-            RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],[eqn])
-      in
-      xx := Some c;
-      (* End building the v8 syntax *)
-      j
-
-  | RIf (loc,c,(na,po),b1,b2) ->
-      let cj = pretype empty_tycon env isevars lvar c in
-      let (IndType (indf,realargs) as indt) = 
-	try find_rectype env (evars_of isevars) cj.uj_type
-	with Not_found ->
-	  let cloc = loc_of_rawconstr c in
-	  error_case_not_inductive_loc cloc env (evars_of isevars) cj in
-      let cstrs = get_constructors env indf in 
-      if Array.length cstrs <> 2 then
-        user_err_loc (loc,"",
-	  str "If is only for inductive types with two constructors");
-
-      (* Make dependencies from arity signature impossible *)
-      let arsgn,_ = get_arity env indf in
-      let arsgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn in
-      let nar = List.length arsgn in
-      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-      let pred,p = match po with
-	| Some p ->
-	    let env_p = push_rels psign env in
-            let pj = pretype_type empty_valcon env_p isevars lvar p in
-            let ccl = nf_evar (evars_of isevars) pj.utj_val in
-	    let pred = it_mkLambda_or_LetIn ccl psign in
-	    pred, lift (- nar) (beta_applist (pred,[cj.uj_val]))
-	| None -> 
-	    let p = match tycon with
-	    | Some ty -> ty
-	    | None -> new_isevar isevars env (loc,InternalHole) (new_Type ())
+	inh_conv_coerce_to_tycon loc env isevars fixj tycon
+
+    | RSort (loc,s) ->
+	inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
+
+    | RApp (loc,f,args) -> 
+	let fj = pretype empty_tycon env isevars lvar f in
+ 	let floc = loc_of_rawconstr f in
+	let rec apply_rec env n resj = function
+	  | [] -> resj
+	  | c::rest ->
+	      let argloc = loc_of_rawconstr c in
+	      let resj = evd_comb1 (Coercion.inh_app_fun env) isevars resj in
+              let resty = whd_betadeltaiota env (evars_of !isevars) resj.uj_type in
+      		match kind_of_term resty with
+		  | Prod (na,c1,c2) ->
+		      let hj = pretype (mk_tycon c1) env isevars lvar c in
+		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
+			apply_rec env (n+1) 
+			  { uj_val = value;
+			    uj_type = typ }
+			  rest
+		  | _ ->
+		      let hj = pretype empty_tycon env isevars lvar c in
+			error_cant_apply_not_functional_loc 
+			  (join_loc floc argloc) env (evars_of !isevars)
+	      		  resj [hj]
+	in
+	let resj = apply_rec env 1 fj args in
+	let resj =
+	  match evar_kind_of_term !isevars resj.uj_val with
+	  | App (f,args) ->
+              let f = whd_evar (Evd.evars_of !isevars) f in
+              begin match kind_of_term f with
+              | Ind _ (* | Const _ *) ->
+	          let sigma = evars_of !isevars in
+		  let c = mkApp (f,Array.map (whd_evar sigma) args) in
+	          let t = Retyping.get_type_of env sigma c in
+		  make_judge c t
+              | _ -> resj end
+	  | _ -> resj in
+	inh_conv_coerce_to_tycon loc env isevars resj tycon
+
+    | RLambda(loc,name,c1,c2)      ->
+	let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in
+	let dom_valcon = valcon_of_tycon dom in
+	let j = pretype_type dom_valcon env isevars lvar c1 in
+	let var = (name,None,j.utj_val) in
+	let j' = pretype rng (push_rel var env) isevars lvar c2 in 
+	  judge_of_abstraction env name j j'
+
+    | RProd(loc,name,c1,c2)        ->
+	let j = pretype_type empty_valcon env isevars lvar c1 in
+	let var = (name,j.utj_val) in
+	let env' = push_rel_assum var env in
+	let j' = pretype_type empty_valcon env' isevars lvar c2 in
+	let resj =
+	  try judge_of_product env name j j'
+	  with TypeError _ as e -> Stdpp.raise_with_loc loc e in
+	  inh_conv_coerce_to_tycon loc env isevars resj tycon
+	    
+    | RLetIn(loc,name,c1,c2)      ->
+	let j = pretype empty_tycon env isevars lvar c1 in
+	let t = refresh_universes j.uj_type in
+	let var = (name,Some j.uj_val,t) in
+        let tycon = lift_tycon 1 tycon in
+	let j' = pretype tycon (push_rel var env) isevars lvar c2 in
+	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
+	    uj_type = subst1 j.uj_val j'.uj_type }
+
+    | RLetTuple (loc,nal,(na,po),c,d) ->
+	let cj = pretype empty_tycon env isevars lvar c in
+	let (IndType (indf,realargs)) = 
+	  try find_rectype env (evars_of !isevars) cj.uj_type
+	  with Not_found ->
+	    let cloc = loc_of_rawconstr c in
+	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj 
+	in
+	let cstrs = get_constructors env indf in
+	  if Array.length cstrs <> 1 then
+            user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
+	  let cs = cstrs.(0) in
+	    if List.length nal <> cs.cs_nargs then
+              user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
+	    let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
+              (List.rev nal) cs.cs_args in
+	    let env_f = push_rels fsign env in
+	      (* Make dependencies from arity signature impossible *)
+	    let arsgn =
+	      let arsgn,_ = get_arity env indf in
+		if not !allow_anonymous_refs then
+		  List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+		else arsgn
 	    in
-	    it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-      let f cs b =
-	let n = rel_context_length cs.cs_args in
-	let pi = liftn n 2 pred in
-	let pi = beta_applist (pi, [build_dependent_constructor cs]) in
-	let csgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args in
-	let env_c = push_rels csgn env in 
-	let bj = pretype (Some pi) env_c isevars lvar b in
-	it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
-      let b1 = f cstrs.(0) b1 in
-      let b2 = f cstrs.(1) b2 in
-      let pred = nf_evar (evars_of isevars) pred in
-      let p = nf_evar (evars_of isevars) p in
-      let v =
-	let mis,_ = dest_ind_family indf in
-	let ci = make_default_case_info env IfStyle mis in
-	mkCase (ci, pred, cj.uj_val, [|b1;b2|])
-      in
-      { uj_val = v; uj_type = p }
-
-  | ROrderedCase (loc,st,po,c,lf,x) ->
-      let isrec = (st = MatchStyle) in
-      let cj = pretype empty_tycon env isevars lvar c in
-      let (IndType (indf,realargs) as indt) = 
-	try find_rectype env (evars_of isevars) cj.uj_type
-	with Not_found ->
-	  let cloc = loc_of_rawconstr c in
-	  error_case_not_inductive_loc cloc env (evars_of isevars) cj in
-      let (dep,pj) = match po with
-	| Some p ->
-            let pj = pretype empty_tycon env isevars lvar p in
-            let dep = is_dependent_elimination env pj.uj_type indf in
-            let ar =
-              arity_of_case_predicate env indf dep (Type (new_univ())) in
-            let _ = the_conv_x_leq env isevars pj.uj_type ar in
-            (dep, pj)
-	| None -> 
-            (* get type information from type of branches *)
-	    let expbr = Cases.branch_scheme env isevars isrec indf in
-	    let rec findtype i =
-	      if i >= Array.length lf
-	      then
-                (* get type information from constraint *)
-                (* warning: if the constraint comes from an evar type, it *)
-                (* may be Type while Prop or Set would be expected *)
-	        match tycon with
-		  | Some pred ->
-		      let arsgn = make_arity_signature env true indf in
-                      let pred = lift (List.length arsgn) pred in
-  		      let pred = 
-			it_mkLambda_or_LetIn (nf_evar (evars_of isevars) pred)
-			  arsgn in
-                      (true, 
-                       Retyping.get_judgment_of env (evars_of isevars) pred)
-	          | None ->
-                      let sigma = evars_of isevars in
-                      error_cant_find_case_type_loc loc env sigma cj.uj_val
-	      else
-		try
-		  let expti = expbr.(i) in
-		  let fj =
-		    pretype (mk_tycon expti) env isevars lvar lf.(i) in
-		  let pred = 
-		    Cases.pred_case_ml (* eta-expanse *)
-                      env (evars_of isevars) isrec indt (i,fj.uj_type) in
-		  if has_undefined_isevars isevars pred then findtype (i+1)
-		  else 
-		    let pty =
-                      Retyping.get_type_of env (evars_of isevars) pred in
-		    let pj = { uj_val = pred; uj_type = pty } in
-(*
-                    let _ = option_app (the_conv_x_leq env isevars pred) tycon
-                    in
-*)
-                    (true,pj)
-		with Cases.NotInferable _ -> findtype (i+1) in
-	    findtype 0 
-      in
-      let pj = j_nf_evar (evars_of isevars) pj in
-      let pj = if dep then pj else make_dep_of_undep env indt pj in
-      let (bty,rsty) =
-	Indrec.type_rec_branches
-          isrec env (evars_of isevars) indt pj.uj_val cj.uj_val in
-      let _ = option_app (the_conv_x_leq env isevars rsty) tycon in
-      if Array.length bty <> Array.length lf then
-	error_number_branches_loc loc env (evars_of isevars) 
-	  cj (Array.length bty)
-      else
-	let lfj =
-	  array_map2
-            (fun tyc f -> pretype (mk_tycon tyc) env isevars lvar f) bty
-            lf in
-	let lfv = Array.map j_val lfj in
-	let lft = Array.map (fun j -> j.uj_type) lfj in
-	check_branches_message loc env isevars cj.uj_val (bty,lft);
-	let v =
-	  if isrec
-	  then 
-	    transform_rec loc env (evars_of isevars)(pj,cj.uj_val,lfv) indt
-	  else
+	    let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+	    let nar = List.length arsgn in
+	      (match po with
+		 | Some p ->
+		     let env_p = push_rels psign env in
+		     let pj = pretype_type empty_valcon env_p isevars lvar p in
+		     let ccl = nf_isevar !isevars pj.utj_val in
+		     let psign = make_arity_signature env true indf in (* with names *)
+		     let p = it_mkLambda_or_LetIn ccl psign in
+		     let inst = 
+		       (Array.to_list cs.cs_concl_realargs)
+		       @[build_dependent_constructor cs] in
+		     let lp = lift cs.cs_nargs p in
+		     let fty = hnf_lam_applist env (evars_of !isevars) lp inst in
+		     let fj = pretype (mk_tycon fty) env_f isevars lvar d in
+		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+		     let v =
+		       let mis,_ = dest_ind_family indf in
+		       let ci = make_default_case_info env LetStyle mis in
+			 mkCase (ci, p, cj.uj_val,[|f|]) in 
+		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
+
+		 | None -> 
+		     let tycon = lift_tycon cs.cs_nargs tycon in
+		     let fj = pretype tycon env_f isevars lvar d in
+		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+		     let ccl = nf_isevar !isevars fj.uj_type in
+		     let ccl =
+		       if noccur_between 1 cs.cs_nargs ccl then
+			 lift (- cs.cs_nargs) ccl 
+		       else
+			 error_cant_find_case_type_loc loc env (evars_of !isevars) 
+			   cj.uj_val in
+		     let ccl = refresh_universes ccl in
+		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
+		     let v =
+		       let mis,_ = dest_ind_family indf in
+		       let ci = make_default_case_info env LetStyle mis in
+			 mkCase (ci, p, cj.uj_val,[|f|] ) 
+		     in
+		       { uj_val = v; uj_type = ccl })
+
+    | RIf (loc,c,(na,po),b1,b2) ->
+	let cj = pretype empty_tycon env isevars lvar c in
+	let (IndType (indf,realargs)) = 
+	  try find_rectype env (evars_of !isevars) cj.uj_type
+	  with Not_found ->
+	    let cloc = loc_of_rawconstr c in
+	      error_case_not_inductive_loc cloc env (evars_of !isevars) cj in
+	let cstrs = get_constructors env indf in 
+	  if Array.length cstrs <> 2 then
+            user_err_loc (loc,"",
+			  str "If is only for inductive types with two constructors");
+
+	  let arsgn = 
+	    let arsgn,_ = get_arity env indf in
+	      if not !allow_anonymous_refs then
+		(* Make dependencies from arity signature impossible *)
+		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn 
+	      else arsgn
+	  in
+	  let nar = List.length arsgn in
+	  let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+	  let pred,p = match po with
+	    | Some p ->
+		let env_p = push_rels psign env in
+		let pj = pretype_type empty_valcon env_p isevars lvar p in
+		let ccl = nf_evar (evars_of !isevars) pj.utj_val in
+		let pred = it_mkLambda_or_LetIn ccl psign in
+		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
+		let jtyp = inh_conv_coerce_to_tycon loc env isevars {uj_val = pred;
+								     uj_type = typ} tycon 
+		in
+		  jtyp.uj_val, jtyp.uj_type
+	    | None -> 
+		let p = match tycon with
+		  | Some (None, ty) -> ty
+		  | None | Some _ ->
+                      e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ())
+		in
+		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
+	  let pred = nf_evar (evars_of !isevars) pred in
+	  let p = nf_evar (evars_of !isevars) p in
+	 (*   msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
+	  let f cs b =
+	    let n = rel_context_length cs.cs_args in
+	    let pi = lift n pred in (* liftn n 2 pred ? *)
+	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
+	    let csgn = 
+	      if not !allow_anonymous_refs then
+		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args 
+	      else 
+		List.map 
+		  (fun (n, b, t) ->
+		     match n with
+                         Name _ -> (n, b, t)
+                       | Anonymous -> (Name (id_of_string "H"), b, t))
+		cs.cs_args
+	    in
+	    let env_c = push_rels csgn env in 
+(* 	      msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
+	    let bj = pretype (mk_tycon pi) env_c isevars lvar b in
+	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
+	  let b1 = f cstrs.(0) b1 in
+	  let b2 = f cstrs.(1) b2 in
+	  let v =
 	    let mis,_ = dest_ind_family indf in
-	    let ci = make_default_case_info env st mis in
-	    mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,
-                       Array.map (fun j-> j.uj_val) lfj)
+	    let ci = make_default_case_info env IfStyle mis in
+	      mkCase (ci, pred, cj.uj_val, [|b1;b2|])
+	  in
+	    { uj_val = v; uj_type = p }
+
+    | RCases (loc,po,tml,eqns) ->
+	Cases.compile_cases loc
+	  ((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
+	  tycon env (* loc *) (po,tml,eqns)
+
+    | RCast(loc,c,k,t) ->
+	let cj =
+	  match k with
+	      CastCoerce ->
+		let cj = pretype empty_tycon env isevars lvar c in
+		  evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj
+	    | CastConv k ->
+		let tj = pretype_type empty_valcon env isevars lvar t in
+		let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
+		  (* User Casts are for helping pretyping, experimentally not to be kept*)
+		  (* ... except for Correctness *)
+		let v = mkCast (cj.uj_val, k, tj.utj_val) in
+		  { uj_val = v; uj_type = tj.utj_val }
 	in
-        (* Build the Cases form for v8 *)
-        let c =
-          let (ind,params) = dest_ind_family indf in
-          let (mib,mip) = lookup_mind_specif env ind in
-          let recargs = mip.mind_recargs in
-          let mI = mkInd ind in
-          let nconstr = Array.length mip.mind_consnames in
-          let tyi = snd ind in
-          if isrec && mis_is_recursive_subset [tyi] recargs then
-            Some (Detyping.detype (false,env)
-	      (ids_of_context env) (names_of_rel_context env)
-              (nf_evar (evars_of isevars) v))
-	  else
-	    (* Translate into a "match ... with" *)
-            let rtntypopt, indnalopt = match po with
-              | None -> None, (Anonymous,None)
-              | Some p ->
-                  let rec decomp_lam_force n avoid l p =
-                    (* avoid is not exhaustive ! *)
-                    if n = 0 then (List.rev l,p,avoid) else
-                      match p with
-                        | RLambda (_,(Name id as na),_,c) -> 
-                            decomp_lam_force (n-1) (id::avoid) (na::l) c
-                        | RLambda (_,(Anonymous as na),_,c) ->
-                            decomp_lam_force (n-1) avoid (na::l) c
-                        | _ ->
-                            let x = Nameops.next_ident_away (id_of_string "x") avoid in
-                            decomp_lam_force (n-1) (x::avoid) (Name x :: l) 
-                              (* eta-expansion *)
-                              (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in
-                  let (nal,p,avoid) = 
-                    decomp_lam_force (List.length realargs) [] [] p in
-                  let na,rtntyopt,_ = 
-                    if dep then decomp_lam_force 1 avoid [] p
-                    else [Anonymous],p,[] in
-		  let intyp =
-		    if nal=[] then None else
-                      let args = List.map (fun _ -> Anonymous) params @ nal in
-		      Some (dummy_loc,ind,args) in
-                  (Some rtntyopt,(List.hd na,intyp)) in
-	    let rawbranches =
-	      array_map3 (fun bj b cstr ->
-		let rec strip n r = if n=0 then r else
-		  match r with
-		    | RLambda (_,_,_,t) -> strip (n-1) t
-		    | RLetIn (_,_,_,t) -> strip (n-1) t
-		    | _ -> assert false in
-		let n = rel_context_length cstr.cs_args in
-		try
-		  let _,ccl = decompose_lam_n_assum n bj.uj_val in
-		  if noccur_between 1 n ccl then Some (strip n b) else None
-		with _ -> (* Not eta-expanded or not reduced *) None)
-		lfj lf (get_constructors env indf) in
-	    if st = IfStyle & snd indnalopt = None 
-	       & rawbranches.(0) <> None && rawbranches.(1) <> None then
-	      (* Translate into a "if ... then ... else" *)
-	      (* TODO: translate into a "if" even if po is dependent *)
-	      Some (RIf (loc,c,(fst indnalopt,rtntypopt),
-	          out_some rawbranches.(0),out_some rawbranches.(1)))
-	    else
-            let detype_eqn constr construct_nargs branch =
-              let name_cons = function 
-                | Anonymous -> fun l -> l
-                | Name id -> fun l -> id::l in
-              let make_pat na avoid b ids =
-                PatVar (dummy_loc,na),
-                name_cons na avoid,name_cons na ids
-              in
-              let rec buildrec ids patlist avoid n b =
-                if n=0 then
-                  (dummy_loc, ids, 
-                  [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
-                  b)
-                else
-                  match b with
-	            | RLambda (_,x,_,b) -> 
-	                let pat,new_avoid,new_ids = make_pat x avoid b ids in
-                        buildrec new_ids (pat::patlist) new_avoid (n-1) b
-                          
-	            | RLetIn (_,x,_,b) -> 
-	                let pat,new_avoid,new_ids = make_pat x avoid b ids in
-                        buildrec new_ids (pat::patlist) new_avoid (n-1) b
-                          
-	            | RCast (_,c,_) ->    (* Oui, il y a parfois des cast *)
-	                buildrec ids patlist avoid n c
-                        
-	            | _ -> (* eta-expansion *)
-                        (* nommage de la nouvelle variable *)
-                        let id = Nameops.next_ident_away (id_of_string "x") avoid in
-	                let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in
-                        let pat,new_avoid,new_ids =
-	                  make_pat (Name id) avoid new_b ids in
-	                buildrec new_ids (pat::patlist) new_avoid (n-1) new_b
-	                  
-              in 
-              buildrec [] [] [] construct_nargs branch in
-            let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in
-            let get_consnarg j = 
-              let typi = mis_nf_constructor_type (ind,mib,mip) (j+1) in
-              let _,t = decompose_prod_n_assum mip.mind_nparams typi in
-              List.rev (fst (decompose_prod_assum t)) in
-            let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in
-            let consnargsl = Array.map List.length consnargs in
-            let constructs = Array.init (Array.length lf) (fun i -> (ind,i+1)) in
-            let eqns = array_map3 detype_eqn constructs consnargsl lf in
-            Some (RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],Array.to_list eqns)) in
-        x := c;
-        (* End build the Cases form for v8 *)
-	{ uj_val = v;
-	  uj_type = rsty }
-
-  | RCases (loc,po,tml,eqns) ->
-      Cases.compile_cases loc
-	((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
-	tycon env (* loc *) (po,tml,eqns)
-
-  | RCast(loc,c,t) ->
-      let tj = pretype_type empty_tycon env isevars lvar t in
-      let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
-      (* User Casts are for helping pretyping, experimentally not to be kept*)
-      (* ... except for Correctness *)
-      let v = mkCast (cj.uj_val, tj.utj_val) in
-      let cj = { uj_val = v; uj_type = tj.utj_val } in
-      inh_conv_coerce_to_tycon loc env isevars cj tycon
-
-  | RDynamic (loc,d) ->
-    if (tag d) = "constr" then
-      let c = constr_out d in
-      let j = (Retyping.get_judgment_of env (evars_of isevars) c) in
+	  inh_conv_coerce_to_tycon loc env isevars cj tycon
+
+    | RDynamic (loc,d) ->
+	if (tag d) = "constr" then
+	  let c = constr_out d in
+	  let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
+	    j
+	      (*inh_conv_coerce_to_tycon loc env isevars j tycon*)
+	else
+	  user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic"))
+
+  (* [pretype_type valcon env isevars lvar c] coerces [c] into a type *)
+  and pretype_type valcon env isevars lvar = function
+    | RHole loc ->
+	(match valcon with
+	   | Some v ->
+               let s =
+		 let sigma = evars_of !isevars in
+		 let t = Retyping.get_type_of env sigma v in
+		   match kind_of_term (whd_betadeltaiota env sigma t) with
+                     | Sort s -> s
+                     | Evar v when is_Type (existential_type sigma v) -> 
+			 evd_comb1 (define_evar_as_sort) isevars v
+                     | _ -> anomaly "Found a type constraint which is not a type"
+               in
+		 { utj_val = v;
+		   utj_type = s }
+	   | None ->
+	       let s = new_Type_sort () in
+		 { utj_val = e_new_evar isevars env ~src:loc (mkSort s);
+		   utj_type = s})
+    | c ->
+	let j = pretype empty_tycon env isevars lvar c in
+	let loc = loc_of_rawconstr c in
+	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) isevars j in
+	  match valcon with
+	    | None -> tj
+	    | Some v ->
+		if e_cumul env isevars v tj.utj_val then tj
+		else
+		  error_unexpected_type_loc
+                    (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v
+
+  let pretype_gen isevars env lvar kind c =
+    let c' = match kind with
+      | OfType exptyp ->
+	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
+	    (pretype tycon env isevars lvar c).uj_val
+      | IsType ->
+	  (pretype_type empty_valcon env isevars lvar c).utj_val in
+      nf_evar (evars_of !isevars) c'
+
+  (* TODO: comment faire remonter l'information si le typage a resolu des
+     variables du sigma original. il faudrait que la fonction de typage
+     retourne aussi le nouveau sigma...
+  *)
+
+  let understand_judgment sigma env c =
+    let isevars = ref (create_evar_defs sigma) in
+    let j = pretype empty_tycon env isevars ([],[]) c in
+    let isevars,_ = consider_remaining_unif_problems env !isevars in
+    let j = j_nf_evar (evars_of isevars) j in
+      check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
       j
-      (*inh_conv_coerce_to_tycon loc env isevars j tycon*)
-    else
-      user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic"))
-
-(* [pretype_type valcon env isevars lvar c] coerces [c] into a type *)
-and pretype_type valcon env isevars lvar = function
-  | RHole loc ->
-      (match valcon with
-	 | Some v ->
-             let s =
-               let sigma = evars_of isevars in
-               let t = Retyping.get_type_of env sigma v in
-               match kind_of_term (whd_betadeltaiota env sigma t) with
-                 | Sort s -> s
-                 | Evar v when is_Type (existential_type sigma v) -> 
-                     define_evar_as_sort isevars v
-                 | _ -> anomaly "Found a type constraint which is not a type"
-             in
-	     { utj_val = v;
-	       utj_type = s }
-	 | None ->
-	     let s = new_Type_sort () in
-	     { utj_val = new_isevar isevars env loc (mkSort s);
-	       utj_type = s})
-  | c ->
-      let j = pretype empty_tycon env isevars lvar c in
-      let tj = inh_coerce_to_sort env isevars j in
-      match valcon with
-	| None -> tj
-	| Some v ->
-	    if the_conv_x_leq env isevars v tj.utj_val then tj
-	    else
-	      error_unexpected_type_loc
-                (loc_of_rawconstr c) env (evars_of isevars) tj.utj_val v
-
-
-let unsafe_infer tycon isevars env lvar constr =
-  let j = pretype tycon env isevars lvar constr in
-  j_nf_evar (evars_of isevars) j
-
-let unsafe_infer_type valcon isevars env lvar constr =
-  let tj = pretype_type valcon env isevars lvar constr in
-  tj_nf_evar (evars_of isevars) tj
-
-(* If fail_evar is false, [process_evars] builds a meta_map with the
-   unresolved Evar that were not in initial sigma; otherwise it fail
-   on the first unresolved Evar not already in the initial sigma. *)
-(* [fail_evar] says how to process unresolved evars:
- *   true -> raise an error message
- *   false -> convert them into new Metas (casted with their type)
- *)
-(* assumes the defined existentials have been replaced in c (should be
-   done in unsafe_infer and unsafe_infer_type) *)
-let check_evars fail_evar env initial_sigma isevars c =
-  let sigma = evars_of isevars in
-  let rec proc_rec c =
-    match kind_of_term c with
-      | Evar (ev,args as k) ->
-          assert (Evd.in_dom sigma ev);
-	  if not (Evd.in_dom initial_sigma ev) then
-	    (if fail_evar then
-              let (loc,k) = evar_source ev isevars in
-	       error_unsolvable_implicit loc env sigma k)
-      | _ -> iter_constr proc_rec c      
-  in
-  proc_rec c
-
-(* TODO: comment faire remonter l'information si le typage a resolu des
-       variables du sigma original. il faudrait que la fonction de typage
-       retourne aussi le nouveau sigma...
-*)
-
-(* constr with holes *)
-type open_constr = evar_map * constr
-
-let ise_resolve_casted_gen fail_evar sigma env lvar typ c =
-  let isevars = create_evar_defs sigma in
-  let j = unsafe_infer (mk_tycon typ) isevars env lvar c in
-  check_evars fail_evar env sigma isevars (mkCast(j.uj_val,j.uj_type));
-  (evars_of isevars, j)
-
-let ise_resolve_casted sigma env typ c =
-  ise_resolve_casted_gen true sigma env ([],[]) typ c
-
-(* Raw calls to the unsafe inference machine: boolean says if we must fail
-   on unresolved evars, or replace them by Metas; the unsafe_judgment list
-   allows us to extend env with some bindings *)
-let ise_infer_gen fail_evar sigma env lvar exptyp c =
-  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
-  let isevars = create_evar_defs sigma in
-  let j = unsafe_infer tycon isevars env lvar c in
-  check_evars fail_evar env sigma isevars (mkCast(j.uj_val,j.uj_type));
-  (evars_of isevars, j)
-
-let ise_infer_type_gen fail_evar sigma env lvar c =
-  let isevars = create_evar_defs sigma in
-  let tj = unsafe_infer_type empty_valcon isevars env lvar c in
-  check_evars fail_evar env sigma isevars tj.utj_val;
-  (evars_of isevars, tj)
 
-type var_map = (identifier * unsafe_judgment) list
+  let understand_judgment_tcc isevars env c =
+    let j = pretype empty_tycon env isevars ([],[]) c in
+    let sigma = evars_of !isevars in
+    let j = j_nf_evar sigma j in
+      j
 
-let understand_judgment sigma env c =
-  snd (ise_infer_gen true sigma env ([],[]) None c)
+  (* Raw calls to the unsafe inference machine: boolean says if we must
+     fail on unresolved evars; the unsafe_judgment list allows us to
+     extend env with some bindings *)
 
-let understand_type_judgment sigma env c =
-  snd (ise_infer_type_gen true sigma env ([],[]) c)
+  let ise_pretype_gen fail_evar sigma env lvar kind c =
+    let isevars = ref (Evd.create_evar_defs sigma) in
+    let c = pretype_gen isevars env lvar kind c in
+    let isevars,_ = consider_remaining_unif_problems env !isevars in
+    let c = nf_evar (evars_of isevars) c in
+      if fail_evar then check_evars env sigma isevars c;
+      isevars, c
 
-let understand sigma env c =
-  let _, c = ise_infer_gen true sigma env ([],[]) None c in
-  c.uj_val
+  (** Entry points of the high-level type synthesis algorithm *)
 
-let understand_type sigma env c =
-  let _,c = ise_infer_type_gen true sigma env ([],[]) c in
-  c.utj_val
+  let understand_gen kind sigma env c =
+    snd (ise_pretype_gen true sigma env ([],[]) kind c)
 
-let understand_gen_ltac sigma env lvar ~expected_type:exptyp c =
-  let _, c = ise_infer_gen true sigma env lvar exptyp c in
-  c.uj_val
+  let understand sigma env ?expected_type:exptyp c =
+    snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c)
 
-let understand_gen sigma env lvar ~expected_type:exptyp c =
-  let _, c = ise_infer_gen true sigma env (lvar,[]) exptyp c in
-  c.uj_val
+  let understand_type sigma env c =
+    snd (ise_pretype_gen true sigma env ([],[]) IsType c)
 
-let understand_gen_tcc sigma env lvar exptyp c =
-  let metamap, c = ise_infer_gen false sigma env (lvar,[]) exptyp c in
-  metamap, c.uj_val
+  let understand_ltac sigma env lvar kind c =
+    ise_pretype_gen false sigma env lvar kind c
+      
+  let understand_tcc_evars isevars env kind c =
+    pretype_gen isevars env ([],[]) kind c
 
-let interp_sort = function
-  | RProp c -> Prop c
-  | RType _ -> new_Type_sort ()
+  let understand_tcc sigma env ?expected_type:exptyp c =
+    let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c in
+      Evd.evars_of ev, t
+end
 
-let interp_elimination_sort = function
-  | RProp Null -> InProp
-  | RProp Pos  -> InSet
-  | RType _ -> InType
+module Default : S = Pretyping_F(Coercion.Default)
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index 4357e504..b1ed20c2 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretyping.mli,v 1.28.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+(*i $Id: pretyping.mli 9141 2006-09-15 10:07:01Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -18,69 +18,96 @@ open Rawterm
 open Evarutil
 (*i*)
 
-type var_map = (identifier * unsafe_judgment) list
-
-(* constr with holes *)
-type open_constr = evar_map * constr
-
-
-(* Generic call to the interpreter from rawconstr to constr, failing
-   unresolved holes in the rawterm cannot be instantiated.
-
-   In [understand_gen sigma env varmap typopt raw],
-
-   sigma : initial set of existential variables (typically dependent subgoals)
-   varmap : partial subtitution of variables (used for the tactic language)
-   metamap : partial subtitution of meta (used for the tactic language)
-   typopt : is not None, this is the expected type for raw (used to define evars)
-*)
-val understand_gen :
-  evar_map -> env -> var_map
-    -> expected_type:(constr option) -> rawconstr -> constr
+type typing_constraint = OfType of types option | IsType
 
-val understand_gen_ltac :
-  evar_map -> env -> var_map * (identifier * identifier option) list
-    -> expected_type:(constr option) -> rawconstr -> constr
-
-(* Generic call to the interpreter from rawconstr to constr, turning
-   unresolved holes into metas. Returns also the typing context of
-   these metas. Work as [understand_gen] for the rest. *)
-val understand_gen_tcc :
-  evar_map -> env -> var_map
-    -> constr option -> rawconstr -> open_constr
-
-(* Standard call to get a constr from a rawconstr, resolving implicit args *)
-val understand : evar_map -> env -> rawconstr -> constr
+type var_map = (identifier * unsafe_judgment) list
+type unbound_ltac_var_map = (identifier * identifier option) list
+
+module type S = 
+sig
+
+  module Cases : Cases.S
+    
+  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+  val allow_anonymous_refs : bool ref
+
+  (* Generic call to the interpreter from rawconstr to open_constr, leaving
+     unresolved holes as evars and returning the typing contexts of
+     these evars. Work as [understand_gen] for the rest. *)
+  
+  val understand_tcc :
+    evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
+    
+  val understand_tcc_evars :
+    evar_defs ref -> env -> typing_constraint -> rawconstr -> constr
+
+  (* More general entry point with evars from ltac *)
+    
+  (* Generic call to the interpreter from rawconstr to constr, failing
+     unresolved holes in the rawterm cannot be instantiated.
+     
+     In [understand_ltac sigma env ltac_env constraint c],
+     
+     sigma : initial set of existential variables (typically dependent subgoals)
+     ltac_env : partial substitution of variables (used for the tactic language)
+     constraint : tell if interpreted as a possibly constrained term or a type 
+  *)
+    
+  val understand_ltac :
+    evar_map -> env -> var_map * unbound_ltac_var_map ->
+    typing_constraint -> rawconstr -> evar_defs * constr
+    
+  (* Standard call to get a constr from a rawconstr, resolving implicit args *)
+    
+  val understand : evar_map -> env -> ?expected_type:Term.types ->
+    rawconstr -> constr
+    
+  (* Idem but the rawconstr is intended to be a type *)
+    
+  val understand_type : evar_map -> env -> rawconstr -> constr
+    
+  (* A generalization of the two previous case *)
+    
+  val understand_gen : typing_constraint -> evar_map -> env -> 
+    rawconstr -> constr
+    
+  (* Idem but returns the judgment of the understood term *)
+    
+  val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+
+  (* Idem but do not fail on unresolved evars *)
+  val understand_judgment_tcc : evar_defs ref -> env -> rawconstr -> unsafe_judgment
+
+  (*i*)
+  (* Internal of Pretyping...
+   *)
+  val pretype : 
+    type_constraint -> env -> evar_defs ref -> 
+    var_map * (identifier * identifier option) list ->
+    rawconstr -> unsafe_judgment
+    
+  val pretype_type : 
+    val_constraint -> env -> evar_defs ref ->
+    var_map * (identifier * identifier option) list ->
+    rawconstr -> unsafe_type_judgment
 
-(* Idem but the rawconstr is intended to be a type *)
-val understand_type : evar_map -> env -> rawconstr -> constr
+  val pretype_gen :
+    evar_defs ref -> env -> 
+    var_map * (identifier * identifier option) list ->
+    typing_constraint -> rawconstr -> constr
 
-(* Idem but returns the judgment of the understood term *)
-val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+  (*i*)
+    
+end
 
-(* Idem but returns the judgment of the understood type *)
-val understand_type_judgment : evar_map -> env -> rawconstr 
-  -> unsafe_type_judgment
+module Pretyping_F (C : Coercion.S) : S
+module Default : S
 
 (* To embed constr in rawconstr *)
+  
 val constr_in : constr -> Dyn.t
 val constr_out : Dyn.t -> constr
 
-(*i*)
-(* Internal of Pretyping...
- * Unused outside, but useful for debugging
- *)
-val pretype : 
-  type_constraint -> env -> evar_defs -> 
-    var_map * (identifier * identifier option) list ->
-    rawconstr -> unsafe_judgment
-
-val pretype_type : 
-  val_constraint -> env -> evar_defs ->
-    var_map * (identifier * identifier option) list ->
-    rawconstr -> unsafe_type_judgment
-(*i*)
-
-val interp_sort : rawsort -> sorts
-
+val interp_sort : rawsort -> sorts  
 val interp_elimination_sort : rawsort -> sorts_family
+
diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml
index ef4a4670..d7e3ac77 100644
--- a/pretyping/rawterm.ml
+++ b/pretyping/rawterm.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: rawterm.ml,v 1.43.2.4 2004/12/29 10:17:10 herbelin Exp $ *)
+(* $Id: rawterm.ml 9535 2007-01-26 09:26:08Z jforest $ *)
 
 (*i*)
 open Util
@@ -15,6 +15,7 @@ open Sign
 open Term
 open Libnames
 open Nametab
+open Evd
 (*i*)
 
 (* Untyped intermediate terms, after ASTs and before constr. *)
@@ -25,7 +26,7 @@ type cases_pattern =
   | PatVar of loc * name
   | PatCstr of loc * constructor * cases_pattern list * name
 
-let pattern_loc = function
+let cases_pattern_loc = function
     PatVar(loc,_) -> loc
   | PatCstr(loc,_,_,_) -> loc
 
@@ -33,8 +34,6 @@ type patvar = identifier
 
 type rawsort = RProp of Term.contents | RType of Univ.universe option
 
-type fix_kind = RFix of (int array * int) | RCoFix of int
-
 type binder_kind = BProd | BLambda | BLetIn
 
 type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
@@ -48,13 +47,9 @@ type 'a bindings =
 
 type 'a with_bindings = 'a * 'a bindings
 
-type hole_kind =
-  | ImplicitArg of global_reference * (int * identifier option)
-  | BinderType of name
-  | QuestionMark
-  | CasesType
-  | InternalHole
-  | TomatchTypeParameter of inductive * int
+type cast_type =
+  | CastConv of cast_kind
+  | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *)
 
 type rawconstr = 
   | RRef of (loc * global_reference)
@@ -65,11 +60,7 @@ type rawconstr =
   | RLambda of loc * name * rawconstr * rawconstr
   | RProd of loc * name * rawconstr * rawconstr
   | RLetIn of loc * name * rawconstr * rawconstr
-  | RCases of loc * (rawconstr option * rawconstr option ref) *
-      (rawconstr * (name * (loc * inductive * name list) option) ref) list * 
-      (loc * identifier list * cases_pattern list * rawconstr) list
-  | ROrderedCase of loc * case_style * rawconstr option * rawconstr * 
-      rawconstr array * rawconstr option ref
+  | RCases of loc * rawconstr option * tomatch_tuple * cases_clauses
   | RLetTuple of loc * name list * (name * rawconstr option) * 
       rawconstr * rawconstr
   | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
@@ -77,15 +68,29 @@ type rawconstr =
       rawconstr array * rawconstr array
   | RSort of loc * rawsort
   | RHole of (loc * hole_kind)
-  | RCast of loc * rawconstr * rawconstr
+  | RCast of loc * rawconstr * cast_type * rawconstr
   | RDynamic of loc * Dyn.t
 
 and rawdecl = name * rawconstr option * rawconstr
 
+and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr
+
+and fix_kind =
+  | RFix of ((int option * fix_recursion_order) array * int)
+  | RCoFix of int
+
+and predicate_pattern =
+    name * (loc * inductive * int * name list) option
+
+and tomatch_tuple = (rawconstr * predicate_pattern) list
+
+and cases_clauses =
+    (loc * identifier list * cases_pattern list * rawconstr) list
+
 let cases_predicate_names tml =
   List.flatten (List.map (function
-    | (tm,{contents=(na,None)}) -> [na]
-    | (tm,{contents=(na,Some (_,_,nal))}) -> na::nal) tml)
+    | (tm,(na,None)) -> [na]
+    | (tm,(na,Some (_,_,_,nal))) -> na::nal) tml)
 
 (*i - if PRec (_, names, arities, bodies) is in env then arities are
    typed in env too and bodies are typed in env enriched by the
@@ -96,7 +101,7 @@ let cases_predicate_names tml =
 
    - boolean in POldCase means it is recursive
 i*)
-let map_rawdecl f (na,obd,ty) = (na,option_app f obd,f ty)
+let map_rawdecl f (na,obd,ty) = (na,option_map f obd,f ty)
 
 let map_rawconstr f = function
   | RVar (loc,id) -> RVar (loc,id)
@@ -104,20 +109,18 @@ let map_rawconstr f = function
   | RLambda (loc,na,ty,c) -> RLambda (loc,na,f ty,f c)
   | RProd (loc,na,ty,c) -> RProd (loc,na,f ty,f c)
   | RLetIn (loc,na,b,c) -> RLetIn (loc,na,f b,f c)
-  | RCases (loc,(tyopt,rtntypopt),tml,pl) ->
-      RCases (loc,(option_app f tyopt,ref (option_app f !rtntypopt)),
+  | RCases (loc,rtntypopt,tml,pl) ->
+      RCases (loc,option_map f rtntypopt,
         List.map (fun (tm,x) -> (f tm,x)) tml,
         List.map (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl)
-  | ROrderedCase (loc,b,tyopt,tm,bv,x) ->
-      ROrderedCase (loc,b,option_app f tyopt,f tm, Array.map f bv,ref (option_app f !x))
   | RLetTuple (loc,nal,(na,po),b,c) ->
-      RLetTuple (loc,nal,(na,option_app f po),f b,f c)
+      RLetTuple (loc,nal,(na,option_map f po),f b,f c)
   | RIf (loc,c,(na,po),b1,b2) ->
-      RIf (loc,f c,(na,option_app f po),f b1,f b2)
+      RIf (loc,f c,(na,option_map f po),f b1,f b2)
   | RRec (loc,fk,idl,bl,tyl,bv) ->
       RRec (loc,fk,idl,Array.map (List.map (map_rawdecl f)) bl,
             Array.map f tyl,Array.map f bv)
-  | RCast (loc,c,t) -> RCast (loc,f c,f t)
+  | RCast (loc,c,k,t) -> RCast (loc,f c,k,f t)
   | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x
   
 
@@ -146,9 +149,7 @@ let map_rawconstr_with_binders_loc loc g f e = function
       let g' id e = snd (g id e) in
       let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in
       RCases
-	(loc,option_app (f e) tyopt,List.map (f e) tml, List.map h pl)
-  | ROrderedCase (_,b,tyopt,tm,bv) ->
-      ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv)
+	(loc,option_map (f e) tyopt,List.map (f e) tml, List.map h pl)
   | RRec (_,fk,idl,tyl,bv) ->
       let idl',e' = fold_ident g idl e in
       RRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv)
@@ -168,12 +169,10 @@ let occur_rawconstr id =
     | RLambda (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
     | RProd (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
     | RLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c))
-    | RCases (loc,(tyopt,rtntypopt),tml,pl) ->
-	(occur_option tyopt) or (occur_option !rtntypopt)
+    | RCases (loc,rtntypopt,tml,pl) ->
+	(occur_option rtntypopt)
         or (List.exists (fun (tm,_) -> occur tm) tml)
 	or (List.exists occur_pattern pl)
-    | ROrderedCase (loc,b,tyopt,tm,bv,_) -> 
-	(occur_option tyopt) or (occur tm) or (array_exists occur bv)
     | RLetTuple (loc,nal,rtntyp,b,c) -> 
 	occur_return_type rtntyp id
         or (occur b) or (not (List.mem (Name id) nal) & (occur c))
@@ -191,7 +190,7 @@ let occur_rawconstr id =
                 (na=Name id or not(occur_fix bl)) in
           occur_fix bl)
           idl bl tyl bv)
-    | RCast (loc,c,t) -> (occur c) or (occur t)
+    | RCast (loc,c,_,t) -> (occur c) or (occur t)
     | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> false
 
   and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c)
@@ -202,118 +201,69 @@ let occur_rawconstr id =
 
   in occur
 
-let rec subst_pat subst pat = 
-  match pat with
-  | PatVar _ -> pat
-  | PatCstr (loc,((kn,i),j),cpl,n) -> 
-      let kn' = subst_kn subst kn 
-      and cpl' = list_smartmap (subst_pat subst) cpl in
-	if kn' == kn && cpl' == cpl then pat else
-	  PatCstr (loc,((kn',i),j),cpl',n)
-
-let rec subst_raw subst raw = 
-  match raw with
-  | RRef (loc,ref) -> 
-      let ref' = subst_global subst ref in 
-	if ref' == ref then raw else
-	  RRef (loc,ref')
-
-  | RVar _ -> raw
-  | REvar _ -> raw
-  | RPatVar _ -> raw
-
-  | RApp (loc,r,rl) -> 
-      let r' = subst_raw subst r 
-      and rl' = list_smartmap (subst_raw subst) rl in
-	if r' == r && rl' == rl then raw else
-	  RApp(loc,r',rl')
-
-  | RLambda (loc,n,r1,r2) -> 
-      let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  RLambda (loc,n,r1',r2')
-
-  | RProd (loc,n,r1,r2) -> 
-      let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  RProd (loc,n,r1',r2')
-
-  | RLetIn (loc,n,r1,r2) -> 
-      let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  RLetIn (loc,n,r1',r2')
-
-  | RCases (loc,(ro,rtno),rl,branches) -> 
-      let ro' = option_smartmap (subst_raw subst) ro 
-      and rtno' = ref (option_smartmap (subst_raw subst) !rtno)
-      and rl' = list_smartmap (fun (a,x as y) ->
-        let a' = subst_raw subst a in
-        let (n,topt) = !x in 
-        let topt' = option_smartmap
-          (fun (loc,(sp,i),x as t) ->
-            let sp' = subst_kn subst sp in
-            if sp == sp' then t else (loc,(sp',i),x)) topt in
-        if a == a' && topt == topt' then y else (a',ref (n,topt'))) rl
-      and branches' = list_smartmap 
-			(fun (loc,idl,cpl,r as branch) ->
-			   let cpl' = list_smartmap (subst_pat subst) cpl
-			   and r' = subst_raw subst r in
-			     if cpl' == cpl && r' == r then branch else
-			       (loc,idl,cpl',r'))
-			branches
-      in
-	if ro' == ro && rl' == rl && branches' == branches then raw else
-	  RCases (loc,(ro',rtno'),rl',branches')
-
-  | ROrderedCase (loc,b,ro,r,ra,x) -> 
-      let ro' = option_smartmap (subst_raw subst) ro
-      and r' = subst_raw subst r 
-      and ra' = array_smartmap (subst_raw subst) ra in
-	if ro' == ro && r' == r && ra' == ra then raw else
-	  ROrderedCase (loc,b,ro',r',ra',x)
 
-  | RLetTuple (loc,nal,(na,po),b,c) ->
-      let po' = option_smartmap (subst_raw subst) po
-      and b' = subst_raw subst b 
-      and c' = subst_raw subst c in
-	if po' == po && b' == b && c' == c then raw else
-          RLetTuple (loc,nal,(na,po'),b',c')
-      
-  | RIf (loc,c,(na,po),b1,b2) ->
-      let po' = option_smartmap (subst_raw subst) po
-      and b1' = subst_raw subst b1 
-      and b2' = subst_raw subst b2 
-      and c' = subst_raw subst c in
-	if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else
-          RIf (loc,c',(na,po'),b1',b2')
-
-  | RRec (loc,fix,ida,bl,ra1,ra2) -> 
-      let ra1' = array_smartmap (subst_raw subst) ra1
-      and ra2' = array_smartmap (subst_raw subst) ra2 in
-      let bl' = array_smartmap
-        (list_smartmap (fun (na,obd,ty as dcl) ->
-          let ty' = subst_raw subst ty in
-          let obd' = option_smartmap (subst_raw subst) obd in
-          if ty'==ty & obd'==obd then dcl else (na,obd',ty')))
-        bl in
-	if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
-	  RRec (loc,fix,ida,bl',ra1',ra2')
-
-  | RSort _ -> raw
-
-  | RHole (loc,ImplicitArg (ref,i)) ->
-      let ref' = subst_global subst ref in 
-	if ref' == ref then raw else
-	  RHole (loc,ImplicitArg (ref',i))
-  | RHole (loc, (BinderType _ | QuestionMark | CasesType |
-      InternalHole | TomatchTypeParameter _)) -> raw
-
-  | RCast (loc,r1,r2) -> 
-      let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  RCast (loc,r1',r2')
-
-  | RDynamic _ -> raw
+let add_name_to_ids set na = 
+  match na with 
+    | Anonymous -> set 
+    | Name id -> Idset.add id set 
+
+let free_rawvars  =
+  let rec vars bounded vs = function
+    | RVar (loc,id') -> if Idset.mem id' bounded then vs else Idset.add id' vs
+    | RApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args)
+    | RLambda (loc,na,ty,c) | RProd (loc,na,ty,c) | RLetIn (loc,na,ty,c) -> 
+	let vs' = vars bounded vs ty in 
+	let bounded' = add_name_to_ids bounded na in 
+	vars bounded' vs' c
+    | RCases (loc,rtntypopt,tml,pl) ->
+	let vs1 = vars_option bounded vs rtntypopt in 
+	let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in 
+	List.fold_left (vars_pattern bounded) vs2 pl
+    | RLetTuple (loc,nal,rtntyp,b,c) ->
+	let vs1 = vars_return_type bounded vs rtntyp in 
+	let vs2 = vars bounded vs1 b in 
+	let bounded' = List.fold_left add_name_to_ids bounded nal in
+	vars bounded' vs2 c
+    | RIf (loc,c,rtntyp,b1,b2) -> 
+	let vs1 = vars_return_type bounded vs rtntyp in 
+	let vs2 = vars bounded vs1 c in 
+	let vs3 = vars bounded vs2 b1 in 
+	vars bounded vs3 b2
+    | RRec (loc,fk,idl,bl,tyl,bv) ->
+	let bounded' = Array.fold_right Idset.add idl bounded in 
+	let vars_fix i vs fid = 
+	  let vs1,bounded1 = 
+	    List.fold_left 
+	      (fun (vs,bounded) (na,bbd,bty) -> 
+		 let vs' = vars_option bounded vs bbd in 
+		 let vs'' = vars bounded vs' bty in
+		 let bounded' = add_name_to_ids bounded na in 
+		 (vs'',bounded')
+	      )
+	      (vs,bounded')
+	      bl.(i)
+	  in
+	  let vs2 = vars bounded1 vs1 tyl.(i) in 
+	  vars bounded1 vs2 bv.(i)
+	in
+	array_fold_left_i vars_fix vs idl
+    | RCast (loc,c,_,t) -> vars bounded (vars bounded vs c) t
+    | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> vs
+
+  and vars_pattern bounded vs (loc,idl,p,c) = 
+    let bounded' = List.fold_right Idset.add idl bounded  in 
+    vars bounded' vs c
+
+  and vars_option bounded vs = function None -> vs | Some p -> vars bounded vs p
+
+  and vars_return_type bounded vs (na,tyopt) = 
+    let bounded' = add_name_to_ids bounded na in 
+    vars_option bounded' vs tyopt
+  in 
+  fun rt -> 
+    let vs = vars Idset.empty Idset.empty rt in 
+    Idset.elements vs
+
 
 let loc_of_rawconstr = function
   | RRef (loc,_) -> loc
@@ -325,15 +275,47 @@ let loc_of_rawconstr = function
   | RProd (loc,_,_,_) -> loc
   | RLetIn (loc,_,_,_) -> loc
   | RCases (loc,_,_,_) -> loc
-  | ROrderedCase (loc,_,_,_,_,_) -> loc
   | RLetTuple (loc,_,_,_,_) -> loc
   | RIf (loc,_,_,_,_) -> loc
   | RRec (loc,_,_,_,_,_) -> loc
   | RSort (loc,_) -> loc
   | RHole (loc,_) -> loc
-  | RCast (loc,_,_) -> loc
+  | RCast (loc,_,_,_) -> loc
   | RDynamic (loc,_) -> loc
 
+(**********************************************************************)
+(* Conversion from rawconstr to cases pattern, if possible            *)
+
+let rec cases_pattern_of_rawconstr na = function
+  | RVar (loc,id) when na<>Anonymous ->
+      (* Unable to manage the presence of both an alias and a variable *)
+      raise Not_found
+  | RVar (loc,id) -> PatVar (loc,Name id)
+  | RHole (loc,_) -> PatVar (loc,na)
+  | RRef (loc,ConstructRef cstr) ->
+      PatCstr (loc,cstr,[],na)
+  | RApp (loc,RRef (_,ConstructRef cstr),l) ->
+      PatCstr (loc,cstr,List.map (cases_pattern_of_rawconstr Anonymous) l,na)
+  | _ -> raise Not_found
+
+(* Turn a closed cases pattern into a rawconstr *)
+let rec rawconstr_of_closed_cases_pattern_aux = function
+  | PatCstr (loc,cstr,[],Anonymous) ->
+      RRef (loc,ConstructRef cstr)
+  | PatCstr (loc,cstr,l,Anonymous) ->
+      let ref = RRef (loc,ConstructRef cstr) in
+      RApp (loc,ref, List.map rawconstr_of_closed_cases_pattern_aux l)
+  | _ -> raise Not_found
+
+let rawconstr_of_closed_cases_pattern = function
+  | PatCstr (loc,cstr,l,na) ->
+      na,rawconstr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous))
+  | _ ->
+      raise Not_found
+
+(**********************************************************************)
+(* Reduction expressions                                              *)
+
 type 'a raw_red_flag = {
   rBeta : bool;
   rIota : bool;
@@ -345,21 +327,24 @@ type 'a raw_red_flag = {
 let all_flags =
   {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []}
 
-type 'a occurrences = int list * 'a
+type 'a or_var = ArgArg of 'a | ArgVar of identifier located
+
+type 'a with_occurrences = int or_var list * 'a
 
 type ('a,'b) red_expr_gen =
   | Red of bool
   | Hnf
-  | Simpl of 'a occurrences option
+  | Simpl of 'a with_occurrences option
   | Cbv of 'b raw_red_flag
   | Lazy of 'b raw_red_flag
-  | Unfold of 'b occurrences list
+  | Unfold of 'b with_occurrences list
   | Fold of 'a list
-  | Pattern of 'a occurrences list
+  | Pattern of 'a with_occurrences list
   | ExtraRedExpr of string
+  | CbvVm
 
 type ('a,'b) may_eval =
   | ConstrTerm of 'a
-  | ConstrEval of ('a, 'b) red_expr_gen * 'a
+  | ConstrEval of ('a,'b) red_expr_gen * 'a
   | ConstrContext of (loc * identifier) * 'a
   | ConstrTypeOf of 'a
diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli
index 97e11af6..e5601705 100644
--- a/pretyping/rawterm.mli
+++ b/pretyping/rawterm.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: rawterm.mli,v 1.47.2.5 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: rawterm.mli 9535 2007-01-26 09:26:08Z jforest $ i*)
 
 (*i*)
 open Util
@@ -17,7 +17,8 @@ open Libnames
 open Nametab
 (*i*)
 
-(* Untyped intermediate terms, after ASTs and before constr. *)
+(**********************************************************************)
+(* The kind of patterns that occurs in "match ... with ... end"       *)
 
 (* locs here refers to the ident's location, not whole pat *)
 (* the last argument of PatCstr is a possible alias ident for the pattern *)
@@ -25,14 +26,18 @@ type cases_pattern =
   | PatVar of loc * name
   | PatCstr of loc * constructor * cases_pattern list * name
 
-val pattern_loc : cases_pattern -> loc
+val cases_pattern_loc : cases_pattern -> loc
+
+(**********************************************************************)
+(* Untyped intermediate terms, after constr_expr and before constr    *)
+(* Resolution of names, insertion of implicit arguments placeholder,  *)
+(* and notations are done, but coercions, inference of implicit       *)
+(* arguments and pattern-matching compilation are not                 *)
 
 type patvar = identifier
 
 type rawsort = RProp of Term.contents | RType of Univ.universe option
 
-type fix_kind = RFix of (int array * int) | RCoFix of int
-
 type binder_kind = BProd | BLambda | BLetIn
 
 type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
@@ -46,13 +51,9 @@ type 'a bindings =
 
 type 'a with_bindings = 'a * 'a bindings
 
-type hole_kind =
-  | ImplicitArg of global_reference * (int * identifier option)
-  | BinderType of name
-  | QuestionMark
-  | CasesType
-  | InternalHole
-  | TomatchTypeParameter of inductive * int
+type cast_type =
+  | CastConv of cast_kind
+  | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *)
 
 type rawconstr = 
   | RRef of (loc * global_reference)
@@ -63,26 +64,34 @@ type rawconstr =
   | RLambda of loc * name * rawconstr * rawconstr
   | RProd of loc * name * rawconstr * rawconstr
   | RLetIn of loc * name * rawconstr * rawconstr
-  | RCases of loc * (rawconstr option * rawconstr option ref) *
-      (rawconstr * (name * (loc * inductive * name list) option) ref) list * 
-      (loc * identifier list * cases_pattern list * rawconstr) list
-  | ROrderedCase of loc * case_style * rawconstr option * rawconstr * 
-      rawconstr array * rawconstr option ref
+  | RCases of loc * rawconstr option * tomatch_tuple * cases_clauses
   | RLetTuple of loc * name list * (name * rawconstr option) * 
       rawconstr * rawconstr
   | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
   | RRec of loc * fix_kind * identifier array * rawdecl list array *
       rawconstr array * rawconstr array
   | RSort of loc * rawsort
-  | RHole of (loc * hole_kind)
-  | RCast of loc * rawconstr * rawconstr
+  | RHole of (loc * Evd.hole_kind)
+  | RCast of loc * rawconstr * cast_type * rawconstr
   | RDynamic of loc * Dyn.t
 
 and rawdecl = name * rawconstr option * rawconstr
 
-val cases_predicate_names : 
-  (rawconstr * (name * (loc * inductive * name list) option) ref) list ->
-      name list
+and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr
+
+and fix_kind =
+  | RFix of ((int option * fix_recursion_order) array * int)
+  | RCoFix of int
+
+and predicate_pattern =
+    name * (loc * inductive * int * name list) option
+
+and tomatch_tuple = (rawconstr * predicate_pattern) list
+
+and cases_clauses =
+    (loc * identifier list * cases_pattern list * rawconstr) list
+
+val cases_predicate_names : tomatch_tuple -> name list
 
 (*i - if PRec (_, names, arities, bodies) is in env then arities are
    typed in env too and bodies are typed in env enriched by the
@@ -104,10 +113,21 @@ val map_rawconstr_with_binders_loc : loc ->
 i*)
 
 val occur_rawconstr : identifier -> rawconstr -> bool
-
+val free_rawvars : rawconstr -> identifier list
 val loc_of_rawconstr : rawconstr -> loc
 
-val subst_raw : Names.substitution -> rawconstr -> rawconstr
+(**********************************************************************)
+(* Conversion from rawconstr to cases pattern, if possible            *)
+
+(* Take the current alias as parameter, raise Not_found if *)
+(* translation is impossible *)
+
+val cases_pattern_of_rawconstr : name -> rawconstr -> cases_pattern
+
+val rawconstr_of_closed_cases_pattern : cases_pattern -> name * rawconstr
+
+(**********************************************************************)
+(* Reduction expressions                                              *)
 
 type 'a raw_red_flag = {
   rBeta : bool;
@@ -119,21 +139,24 @@ type 'a raw_red_flag = {
 
 val all_flags : 'a raw_red_flag
 
-type 'a occurrences = int list * 'a
+type 'a or_var = ArgArg of 'a | ArgVar of identifier located
+
+type 'a with_occurrences = int or_var list * 'a
 
 type ('a,'b) red_expr_gen =
   | Red of bool
   | Hnf
-  | Simpl of 'a occurrences option
+  | Simpl of 'a with_occurrences option
   | Cbv of 'b raw_red_flag
   | Lazy of 'b raw_red_flag
-  | Unfold of 'b occurrences list
+  | Unfold of 'b with_occurrences list
   | Fold of 'a list
-  | Pattern of 'a occurrences list
+  | Pattern of 'a with_occurrences list
   | ExtraRedExpr of string
+  | CbvVm
 
 type ('a,'b) may_eval =
   | ConstrTerm of 'a
-  | ConstrEval of ('a, 'b) red_expr_gen * 'a
+  | ConstrEval of ('a,'b) red_expr_gen * 'a
   | ConstrContext of (loc * identifier) * 'a
   | ConstrTypeOf of 'a
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 3e73cfee..5bbaa207 100755..100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: recordops.ml,v 1.26.2.2 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: recordops.ml 9166 2006-09-23 11:20:06Z herbelin $ *)
 
 open Util
 open Pp
@@ -19,133 +19,204 @@ open Typeops
 open Libobject
 open Library
 open Classops
+open Mod_subst
+open Reductionops
 
-(*s Une structure S est un type inductif non récursif à un seul
-   constructeur (de nom par défaut Build_S) *)
+(*s A structure S is a non recursive inductive type with a single
+   constructor (the name of which defaults to Build_S) *)
 
 (* Table des structures: le nom de la structure (un [inductive]) donne
    le nom du constructeur, le nombre de paramètres et pour chaque
-   argument réels du constructeur, le noms de la projection
-   correspondante, si valide *)
+   argument réel du constructeur, le nom de la projection
+   correspondante, si valide, et un booléen disant si c'est une vraie
+   projection ou bien une fonction constante (associée à un LetIn) *)
 
 type struc_typ = {
   s_CONST : identifier; 
-  s_PARAM : int;
+  s_EXPECTEDPARAM : int;
+  s_PROJKIND : bool list;
   s_PROJ : constant option list }
 
 let structure_table = ref (Indmap.empty : struc_typ Indmap.t)
-let projection_table = ref KNmap.empty
+let projection_table = ref Cmap.empty
 
 let option_fold_right f p e = match p with Some a -> f a e | None -> e
 
-let cache_structure (_,(ind,struc)) =
+let load_structure i (_,(ind,id,kl,projs)) =
+  let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
+  let struc =
+    { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in
   structure_table := Indmap.add ind struc !structure_table;
   projection_table := 
-    List.fold_right (option_fold_right (fun proj -> KNmap.add proj struc))
-      struc.s_PROJ !projection_table
+    List.fold_right (option_fold_right (fun proj -> Cmap.add proj struc))
+      projs !projection_table
 
-let subst_structure (_,subst,((kn,i),struc as obj)) = 
+let cache_structure o =
+  load_structure 1 o
+
+let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) = 
   let kn' = subst_kn subst kn in
-  let proj' = list_smartmap 
-		(option_smartmap (subst_kn subst)) 
-		struc.s_PROJ 
+  let projs' =
+   (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *)
+   (* the first component of subst_con.                                   *)
+   list_smartmap 
+     (option_smartmap (fun kn -> fst (subst_con subst kn)))
+    projs
   in
-    if proj' == struc.s_PROJ && kn' == kn then obj else
-      (kn',i),{struc with s_PROJ = proj'}
+    if projs' == projs && kn' == kn then obj else
+      ((kn',i),id,kl,projs')
+
+let discharge_structure (_,(ind,id,kl,projs)) =
+  Some (Lib.discharge_inductive ind, id, kl,
+        List.map (option_map Lib.discharge_con) projs)
 
 let (inStruc,outStruc) =
   declare_object {(default_object "STRUCTURE") with 
-                    cache_function = cache_structure;
-		    load_function = (fun _ o -> cache_structure o);
-                    subst_function = subst_structure;
-		    classify_function = (fun (_,x) -> Substitute x);
-		    export_function = (function x -> Some x)  }
+    cache_function = cache_structure;
+    load_function = load_structure;
+    subst_function = subst_structure;
+    classify_function = (fun (_,x) -> Substitute x);
+    discharge_function = discharge_structure;
+    export_function = (function x -> Some x) }
 
-let add_new_struc (s,c,n,l) = 
-  Lib.add_anonymous_leaf (inStruc (s,{s_CONST=c;s_PARAM=n;s_PROJ=l}))
+let declare_structure (s,c,kl,pl) = 
+  Lib.add_anonymous_leaf (inStruc (s,c,kl,pl))
 
-let find_structure indsp = Indmap.find indsp !structure_table
+let lookup_structure indsp = Indmap.find indsp !structure_table
+
+let lookup_projections indsp = (lookup_structure indsp).s_PROJ
 
 let find_projection_nparams = function
-  | ConstRef cst -> (KNmap.find cst !projection_table).s_PARAM
+  | ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM
   | _ -> raise Not_found
 
-(*s Un "object" est une fonction construisant une instance d'une structure *)
+
+(************************************************************************)
+(*s A canonical structure declares "canonical" conversion hints between *)
+(*  the effective components of a structure and the projections of the  *)
+(*  structure *)
 
 (* Table des definitions "object" : pour chaque object c,
 
   c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n)
 
-  avec ti = (ci ui1...uir)
+  If ti has the form (ci ui1...uir) where ci is a global reference and
+if the corresponding projection Li of the structure R is defined, one
+declare a "conversion" between ci and Li
+
+    x1:B1..xk:Bk |- (Li a1..am (c x1..xk)) =_conv (ci ui1...uir)
 
-  Pour tout ci, et Li, la ième projection de la structure R (si
-  définie), on déclare une "coercion"
+that maps the pair (Li,ci) to the following data
 
     o_DEF = c
     o_TABS = B1...Bk
     o_PARAMS = a1...am
     o_TCOMP = ui1...uir
+
 *)
 
 type obj_typ = {
   o_DEF : constr;
-  o_TABS : constr list;    (* dans l'ordre *)
-  o_TPARAMS : constr list; (* dans l'ordre *)
-  o_TCOMPS : constr list } (* dans l'ordre *)
-
-let subst_obj subst obj =
-  let o_DEF' = subst_mps subst obj.o_DEF in
-  let o_TABS' = list_smartmap (subst_mps subst) obj.o_TABS in    
-  let o_TPARAMS' = list_smartmap (subst_mps subst) obj.o_TPARAMS in 
-  let o_TCOMPS' = list_smartmap (subst_mps subst) obj.o_TCOMPS in 
-    if o_DEF' == obj.o_DEF
-      && o_TABS' == obj.o_TABS    
-      && o_TPARAMS' == obj.o_TPARAMS 
-      && o_TCOMPS' == obj.o_TCOMPS 
-    then 
-      obj
-    else
-      { o_DEF = o_DEF' ;
-	o_TABS = o_TABS' ;    
-	o_TPARAMS = o_TPARAMS' ; 
-	o_TCOMPS = o_TCOMPS' }
+  o_TABS : constr list;    (* ordered *)
+  o_TPARAMS : constr list; (* ordered *)
+  o_TCOMPS : constr list } (* ordered *)
 
 let object_table =
   (ref [] : ((global_reference * global_reference) * obj_typ) list ref)
 
-let cache_object (_,x) = object_table := x :: (!object_table)
-
-let subst_object (_,subst,((r1,r2),o as obj)) = 
-  let r1' = subst_global subst r1 in
-  let r2' = subst_global subst r2 in
-  let o' = subst_obj subst o in
-    if r1' == r1 && r2' == r2 && o' == o then obj else
-      (r1',r2'),o'
-
-let (inObjDef,outObjDef) =
-  declare_object {(default_object "OBJDEF") with 
-		    open_function = (fun i o -> if i=1 then cache_object o);
-                    cache_function = cache_object;
-		    subst_function = subst_object;
-		    classify_function = (fun (_,x) -> Substitute x);
-                    export_function = (function x -> Some x) }
-
-let add_new_objdef (o,c,la,lp,l) =
-  try 
-    let _ = List.assoc o !object_table in ()
-  with Not_found -> 
-    Lib.add_anonymous_leaf
-      (inObjDef (o,{o_DEF=c;o_TABS=la;o_TPARAMS=lp;o_TCOMPS=l}))
-
-let cache_objdef1 (_,sp) = ()
-
-let (inObjDef1,outObjDef1) =
-  declare_object {(default_object "OBJDEF1") with 
-		    open_function = (fun i o -> if i=1 then cache_objdef1 o);
-                    cache_function = cache_objdef1;
-                    export_function = (function x -> Some x) }
-
-let objdef_info o = List.assoc o !object_table
+let canonical_projections () = !object_table
+
+let keep_true_projections projs kinds =
+  map_succeed (function (p,true) -> p | _ -> failwith "")
+    (List.combine projs kinds)
+
+(* Intended to always success *)
+let compute_canonical_projections (con,ind) =
+  let v = mkConst con in
+  let c = Environ.constant_value (Global.env()) con in
+  let lt,t = Reductionops.splay_lambda (Global.env()) Evd.empty c in
+  let lt = List.rev (List.map snd lt) in
+  let args = snd (decompose_app t) in
+  let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in
+  let params, projs = list_chop p args in
+  let lpj = keep_true_projections lpj kl in
+  let lps = List.combine lpj projs in
+  let comp =
+    List.fold_left
+      (fun l (spopt,t) -> (* comp=components *)
+	 match spopt with
+           | Some proji_sp ->
+	       let c, args = decompose_app t in
+	       (try (ConstRef proji_sp, global_of_constr c, args) :: l
+                with Not_found -> l)
+	   | _ -> l)
+      [] lps in
+  List.map (fun (refi,c,argj) ->
+    (refi,c),{o_DEF=v; o_TABS=lt; o_TPARAMS=params; o_TCOMPS=argj})
+    comp
+
+let open_canonical_structure i (_,o) =
+  if i=1 then
+    let lo = compute_canonical_projections o in
+    List.iter (fun (o,_ as x) ->
+      if not (List.mem_assoc o !object_table) then
+	object_table := x :: (!object_table)) lo
+
+let cache_canonical_structure o =
+  open_canonical_structure 1 o
+
+let subst_canonical_structure (_,subst,(cst,ind as obj)) =
+  (* invariant: cst is an evaluable reference. Thus we can take *)
+  (* the first component of subst_con.                                   *)
+  let cst' = fst (subst_con subst cst) in
+  let ind' = Inductiveops.subst_inductive subst ind in
+  if cst' == cst & ind' == ind then obj else (cst',ind')
+
+let discharge_canonical_structure (_,(cst,ind)) =
+  Some (Lib.discharge_con cst,Lib.discharge_inductive ind)
+
+let (inCanonStruc,outCanonStruct) =
+  declare_object {(default_object "CANONICAL-STRUCTURE") with 
+    open_function = open_canonical_structure;
+    cache_function = cache_canonical_structure;
+    subst_function = subst_canonical_structure;
+    classify_function = (fun (_,x) -> Substitute x);
+    discharge_function = discharge_canonical_structure;
+    export_function = (function x -> Some x) }
+
+let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x)
+
+(*s High-level declaration of a canonical structure *)
+
+let error_not_structure ref =
+  errorlabstrm "object_declare"
+    (Nameops.pr_id (id_of_global ref) ++ str" is not a structure object")
+
+let check_and_decompose_canonical_structure ref =
+  let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in
+  let env = Global.env () in
+  let vc = match Environ.constant_opt_value env sp with
+    | Some vc -> vc
+    | None -> error_not_structure ref in
+  let body = snd (splay_lambda (Global.env()) Evd.empty vc) in
+  let f,args = match kind_of_term body with
+    | App (f,args) -> f,args
+    | _ -> error_not_structure ref in
+  let indsp = match kind_of_term f with
+    | Construct (indsp,1) -> indsp
+    | _ -> error_not_structure ref in
+  let s = try lookup_structure indsp with Not_found -> error_not_structure ref in
+  let ntrue_projs = List.length (List.filter (fun x -> x) s.s_PROJKIND) in
+  if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then
+    error_not_structure ref;
+  (sp,indsp)
+
+let declare_canonical_structure ref =
+  add_canonical_structure (check_and_decompose_canonical_structure ref)
+
+let outCanonicalStructure x = fst (outCanonStruct x)
+
+let lookup_canonical_conversion o = List.assoc o !object_table
 
 let freeze () =
   !structure_table, !projection_table, !object_table
@@ -154,7 +225,7 @@ let unfreeze (s,p,o) =
   structure_table := s; projection_table := p; object_table := o
 
 let init () =
-  structure_table := Indmap.empty; projection_table := KNmap.empty;
+  structure_table := Indmap.empty; projection_table := Cmap.empty;
   object_table:=[]
 
 let _ = init()
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index a458b7b3..0a05aef6 100755
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: recordops.mli,v 1.15.2.2 2005/11/29 21:40:52 letouzey Exp $ i*)
+(*i $Id: recordops.mli 9082 2006-08-24 17:03:28Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -18,34 +18,31 @@ open Libobject
 open Library
 (*i*)
 
-type struc_typ = {
-  s_CONST : identifier; 
-  s_PARAM : int;
-  s_PROJ : constant option list }
+(*s A structure S is a non recursive inductive type with a single
+   constructor (the name of which defaults to Build_S) *)
 
-val add_new_struc : 
-  inductive * identifier * int * constant option list -> unit
+val declare_structure : 
+  inductive * identifier * bool list * constant option list -> unit
 
-(* [find_structure isp] returns the infos associated to inductive path
-   [isp] if it corresponds to a structure, otherwise fails with [Not_found] *)
-val find_structure : inductive -> struc_typ
+(* [lookup_projections isp] returns the projections associated to the
+   inductive path [isp] if it corresponds to a structure, otherwise
+   it fails with [Not_found] *)
+val lookup_projections : inductive -> constant option list
 
 (* raise [Not_found] if not a projection *)
 val find_projection_nparams : global_reference -> int
 
+(*s A canonical structure declares "canonical" conversion hints between *)
+(*  the effective components of a structure and the projections of the  *)
+(*  structure *)
+
 type obj_typ = {
   o_DEF : constr;
-  o_TABS : constr list; (* dans l'ordre *)
-  o_TPARAMS : constr list; (* dans l'ordre *)
-  o_TCOMPS : constr list } (* dans l'ordre *)
+  o_TABS : constr list;    (* ordered *)
+  o_TPARAMS : constr list; (* ordered *)
+  o_TCOMPS : constr list } (* ordered *)
                
-val objdef_info : (global_reference * global_reference) -> obj_typ
-val add_new_objdef : 
-  (global_reference * global_reference) * Term.constr * Term.constr list *
-  Term.constr list * Term.constr list -> unit
-
-
-val inStruc : inductive * struc_typ -> obj
-val outStruc : obj -> inductive * struc_typ
-val inObjDef1 : kernel_name -> obj
-val outObjDef1 : obj -> kernel_name
+val lookup_canonical_conversion : (global_reference * global_reference) -> obj_typ
+val declare_canonical_structure : global_reference -> unit
+val canonical_projections : unit -> 
+  ((global_reference * global_reference) * obj_typ) list
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index a030dcf2..19f515d0 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: reductionops.ml,v 1.6.2.2 2004/07/16 19:30:46 herbelin Exp $ *)
+(* $Id: reductionops.ml 9106 2006-09-01 11:18:17Z herbelin $ *)
 
 open Pp
 open Util
@@ -17,13 +17,98 @@ open Univ
 open Evd
 open Declarations
 open Environ
-open Instantiate
 open Closure
 open Esubst
 open Reduction
 
 exception Elimconst
 
+
+(**********************************************************************)
+(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *) 
+
+type 'a stack_member =
+  | Zapp of 'a list
+  | Zcase of case_info * 'a * 'a array
+  | Zfix of 'a * 'a stack
+  | Zshift of int
+  | Zupdate of 'a
+
+and 'a stack = 'a stack_member list
+
+let empty_stack = []
+let append_stack_list l s =
+  match (l,s) with
+  | ([],s) -> s
+  | (l1, Zapp l :: s) -> Zapp (l1@l) :: s
+  | (l1, s) -> Zapp l1 :: s
+let append_stack v s = append_stack_list (Array.to_list v) s
+
+(* Collapse the shifts in the stack *)
+let zshift n s =
+  match (n,s) with
+      (0,_) -> s
+    | (_,Zshift(k)::s) -> Zshift(n+k)::s
+    | _ -> Zshift(n)::s
+
+let rec stack_args_size = function
+  | Zapp l::s -> List.length l + stack_args_size s
+  | Zshift(_)::s -> stack_args_size s
+  | Zupdate(_)::s -> stack_args_size s
+  | _ -> 0
+
+(* When used as an argument stack (only Zapp can appear) *)
+let rec decomp_stack = function
+  | Zapp[v]::s -> Some (v, s)
+  | Zapp(v::l)::s -> Some (v, (Zapp l :: s))
+  | Zapp [] :: s -> decomp_stack s
+  | _ -> None
+let rec decomp_stackn = function
+  | Zapp [] :: s -> decomp_stackn s
+  | Zapp l :: s -> (Array.of_list l, s)
+  | _ -> assert false
+let array_of_stack s =
+  let rec stackrec = function
+  | [] -> []
+  | Zapp args :: s -> args :: (stackrec s)
+  | _ -> assert false
+  in Array.of_list (List.concat (stackrec s))
+let rec list_of_stack = function
+  | [] -> []
+  | Zapp args :: s -> args @ (list_of_stack s)
+  | _ -> assert false
+let rec app_stack = function
+  | f, [] -> f
+  | f, (Zapp [] :: s) -> app_stack (f, s)
+  | f, (Zapp args :: s) -> 
+      app_stack (applist (f, args), s)
+  | _ -> assert false
+let rec stack_assign s p c = match s with
+  | Zapp args :: s ->
+      let q = List.length args in 
+      if p >= q then
+	Zapp args :: stack_assign s (p-q) c
+      else
+        (match list_chop p args with
+            (bef, _::aft) -> Zapp (bef@c::aft) :: s
+          | _ -> assert false)
+  | _ -> s
+let rec stack_tail p s =
+  if p = 0 then s else
+    match s with
+      | Zapp args :: s ->
+	  let q = List.length args in
+	  if p >= q then stack_tail (p-q) s
+	  else Zapp (list_skipn p args) :: s
+      | _ -> failwith "stack_tail"
+let rec stack_nth s p = match s with
+  | Zapp args :: s ->
+      let q = List.length args in
+      if p >= q then stack_nth s (p-q)
+      else List.nth args p
+  | _ -> raise Not_found
+
+(**************************************************************)
 (* The type of (machine) states (= lambda-bar-calculus' cuts) *) 
 type state = constr * constr stack
 
@@ -48,7 +133,7 @@ type local_state_reduction_function = state -> state
 let rec whd_state (x, stack as s) =
   match kind_of_term x with
     | App (f,cl) -> whd_state (f, append_stack cl stack)
-    | Cast (c,_)  -> whd_state (c, stack)
+    | Cast (c,_,_)  -> whd_state (c, stack)
     | _             -> s
 
 let appterm_of_stack (f,s) = (f,list_of_stack s)
@@ -143,6 +228,7 @@ open RedFlags
 
 (* Local *)
 let beta = mkflags [fbeta]
+let eta = mkflags [feta]
 let evar = mkflags [fevar]
 let betaevar = mkflags [fevar; fbeta]
 let betaiota = mkflags [fiota; fbeta]
@@ -167,7 +253,7 @@ let rec stacklam recfun env t stack =
     | _ -> recfun (substl env t, stack)
 
 let beta_applist (c,l) =
-  stacklam app_stack [] c (append_stack (Array.of_list l) empty_stack)
+  stacklam app_stack [] c (append_stack_list l empty_stack)
 
 (* Iota reduction tools *)
 
@@ -177,7 +263,7 @@ type 'a miota_args = {
   mci     : case_info;  (* special info to re-build pattern *)
   mcargs  : 'a list;    (* the constructor's arguments *)
   mlf     : 'a array }  (* the branch code vector *)
-		       
+
 let reducible_mind_case c = match kind_of_term c with
   | Construct _ | CoFix _ -> true
   | _  -> false
@@ -189,7 +275,7 @@ let contract_cofix (bodynum,(types,names,bodies as typedbodies)) =
 
 let reduce_mind_case mia =
   match kind_of_term mia.mconstr with
-    | Construct (ind_sp,i as cstr_sp) ->
+    | Construct (ind_sp,i) ->
 (*	let ncargs = (fst mia.mci).(i-1) in*)
 	let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
         applist (mia.mlf.(i-1),real_cargs)
@@ -255,7 +341,7 @@ let rec whd_state_gen flags env sigma =
 	     | Some  body -> whrec (body, stack)
 	     | None -> s)
       | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
-      | Cast (c,_) -> whrec (c, stack)
+      | Cast (c,_,_) -> whrec (c, stack)
       | App (f,cl)  -> whrec (f, append_stack cl stack)
       | Lambda (na,t,c) ->
           (match decomp_stack stack with
@@ -300,7 +386,7 @@ let local_whd_state_gen flags =
   let rec whrec (x, stack as s) =
     match kind_of_term x with
       | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
-      | Cast (c,_) -> whrec (c, stack)
+      | Cast (c,_,_) -> whrec (c, stack)
       | App (f,cl)  -> whrec (f, append_stack cl stack)
       | Lambda (_,_,c) ->
           (match decomp_stack stack with
@@ -339,6 +425,7 @@ let local_whd_state_gen flags =
   in 
   whrec
 
+
 (* 1. Beta Reduction Functions *)
 
 let whd_beta_state = local_whd_state_gen beta
@@ -420,6 +507,10 @@ let whd_betadeltaiota_nolet_stack env sigma x =
 let whd_betadeltaiota_nolet env sigma x = 
   app_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack))
 
+(* 3. Eta reduction Functions *)
+
+let whd_eta c = app_stack (local_whd_state_gen eta (c,empty_stack))
+
 (****************************************************************************)
 (*                   Reduction Functions                                    *)
 (****************************************************************************)
@@ -427,8 +518,10 @@ let whd_betadeltaiota_nolet env sigma x =
 (* Replacing defined evars for error messages *)
 let rec whd_evar sigma c =
   match kind_of_term c with
-    | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev ->
-	whd_evar sigma (Instantiate.existential_value sigma (ev,args))
+    | Evar (ev,args)
+        when Evd.mem sigma ev & Evd.is_defined sigma ev ->
+	whd_evar sigma (Evd.existential_value sigma (ev,args))
+    | Sort s when is_sort_variable sigma s -> whd_sort_variable sigma c
     | _ -> collapse_appl c
 
 let nf_evar sigma =
@@ -443,6 +536,56 @@ let nf_betaiota = clos_norm_flags Closure.betaiota empty_env Evd.empty
 let nf_betadeltaiota env sigma =
   clos_norm_flags Closure.betadeltaiota env sigma
 
+
+(* Attention reduire un beta-redexe avec un argument qui n'est pas 
+   une variable, peut changer enormement le temps de conversion lors
+   du type checking :
+     (fun x => x + x) M
+*)
+let rec whd_betaiotaevar_preserving_vm_cast env sigma t = 	 
+   let rec stacklam_var subst t stack = 	 
+     match (decomp_stack stack,kind_of_term t) with 	 
+     | Some (h,stacktl), Lambda (_,_,c) -> 	 
+         begin match kind_of_term h with 	 
+         | Rel i when not (evaluable_rel i env) -> 	 
+             stacklam_var (h::subst) c stacktl 	 
+         | Var id when  not (evaluable_named id env)-> 	 
+             stacklam_var (h::subst) c stacktl 	 
+         | _ -> whrec (substl subst t, stack) 	 
+         end 	 
+     | _ -> whrec (substl subst t, stack) 	 
+   and whrec (x, stack as s) = 	 
+     match kind_of_term x with 	 
+       | Evar ev -> 	 
+           (match existential_opt_value sigma ev with 	 
+              | Some body -> whrec (body, stack) 	 
+              | None -> s) 	 
+       | Cast (c,VMcast,t) -> 	 
+           let c = app_stack (whrec (c,empty_stack)) in 	 
+           let t = app_stack (whrec (t,empty_stack)) in 	 
+           (mkCast(c,VMcast,t),stack) 	 
+       | Cast (c,DEFAULTcast,_) -> 	 
+           whrec (c, stack) 	 
+       | App (f,cl)  -> whrec (f, append_stack cl stack) 	 
+       | Lambda (na,t,c) -> 	 
+           (match decomp_stack stack with 	 
+            | Some (a,m) -> stacklam_var [a] c m 	 
+            | _ -> s) 	 
+       | Case (ci,p,d,lf) -> 	 
+           let (c,cargs) = whrec (d, empty_stack) in 	 
+           if reducible_mind_case c then 	 
+             whrec (reduce_mind_case 	 
+                      {mP=p; mconstr=c; mcargs=list_of_stack cargs; 	 
+                       mci=ci; mlf=lf}, stack) 	 
+           else 	 
+             (mkCase (ci, p, app_stack (c,cargs), lf), stack) 	 
+       | x -> s 	 
+   in 	 
+   app_stack (whrec (t,empty_stack))
+
+let nf_betaiotaevar_preserving_vm_cast = 
+  strong whd_betaiotaevar_preserving_vm_cast
+
 (* lazy weak head reduction functions *)
 let whd_flags flgs env sigma t =
   whd_val (create_clos_infos flgs env) (inject (nf_evar sigma t))
@@ -462,10 +605,6 @@ let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;;
 
 type conversion_test = constraints -> constraints
 
-type conv_pb = 
-  | CONV 
-  | CUMUL
-
 let pb_is_equal pb = pb = CONV
 
 let pb_equal = function
@@ -508,34 +647,34 @@ let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq
 let whd_meta metamap c = match kind_of_term c with
   | Meta p -> (try List.assoc p metamap with Not_found -> c)
   | _ -> c
-	
+
 (* Try to replace all metas. Does not replace metas in the metas' values
  * Differs from (strong whd_meta). *)
 let plain_instance s c = 
   let rec irec u = match kind_of_term u with
     | Meta p -> (try List.assoc p s with Not_found -> u)
     | App (f,l) when isCast f ->
-        let (f,t) = destCast f in
+        let (f,_,t) = destCast f in
         let l' = Array.map irec l in 
         (match kind_of_term f with
-          | Meta p ->
-              (* Don't flatten application nodes: this is used to extract a
-                 proof-term from a proof-tree and we want to keep the structure
-                 of the proof-tree *)
-              (try let g = List.assoc p s in
-              match kind_of_term g with
-                | App _ -> 
-                    let h = id_of_string "H" in
-                    mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l'))
-                | _ -> mkApp (g,l')
-              with Not_found -> mkApp (f,l'))
-          | _ -> mkApp (irec f,l'))
-    | Cast (m,_) when isMeta m ->
+        | Meta p ->
+	    (* Don't flatten application nodes: this is used to extract a
+               proof-term from a proof-tree and we want to keep the structure
+               of the proof-tree *)
+	    (try let g = List.assoc p s in
+	    match kind_of_term g with
+            | App _ -> 
+                let h = id_of_string "H" in
+                mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l'))
+            | _ -> mkApp (g,l')
+	    with Not_found -> mkApp (f,l'))
+        | _ -> mkApp (irec f,l'))	
+    | Cast (m,_,_) when isMeta m ->
 	(try List.assoc (destMeta m) s with Not_found -> u)
     | _ -> map_constr irec u
   in 
   if s = [] then c else irec c
-    
+
 (* Pourquoi ne fait-on pas nf_betaiota si s=[] ? *)
 let instance s c = 
   if s = [] then c else local_strong whd_betaiota (plain_instance s c)
@@ -580,17 +719,28 @@ let splay_prod env sigma =
   in 
   decrec env []
 
+let splay_lambda env sigma = 
+  let rec decrec env m c =
+    let t = whd_betadeltaiota env sigma c in
+    match kind_of_term t with
+      | Lambda (n,a,c0) ->
+	  decrec (push_rel (n,None,a) env)
+	    ((n,a)::m) c0
+      | _ -> m,t
+  in 
+  decrec env []
+
 let splay_prod_assum env sigma = 
   let rec prodec_rec env l c =
     let t = whd_betadeltaiota_nolet env sigma c in
-    match kind_of_term c with
+    match kind_of_term t with
     | Prod (x,t,c)  ->
 	prodec_rec (push_rel (x,None,t) env)
 	  (Sign.add_rel_decl (x, None, t) l) c
     | LetIn (x,b,t,c) ->
 	prodec_rec (push_rel (x, Some b, t) env)
 	  (Sign.add_rel_decl (x, Some b, t) l) c
-    | Cast (c,_)    -> prodec_rec env l c
+    | Cast (c,_,_)    -> prodec_rec env l c
     | _               -> l,t
   in
   prodec_rec env Sign.empty_rel_context
@@ -602,7 +752,7 @@ let splay_arity env sigma c =
     | _ -> error "not an arity"
 
 let sort_of_arity env c = snd (splay_arity env Evd.empty c)
-  
+
 let decomp_n_prod env sigma n = 
   let rec decrec env m ln c = if m = 0 then (ln,c) else 
     match kind_of_term (whd_betadeltaiota env sigma c) with
@@ -613,7 +763,19 @@ let decomp_n_prod env sigma n =
   in 
   decrec env n Sign.empty_rel_context
 
-(* One step of approximation *)
+exception NotASort
+
+let decomp_sort env sigma t =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+  | Sort s -> s
+  | _ -> raise NotASort
+
+let is_sort env sigma arity =
+  try let _ = decomp_sort env sigma arity in true 
+  with NotASort -> false
+
+(* reduction to head-normal-form allowing delta/zeta only in argument
+   of case/fix (heuristic used by evar_conv) *)
 
 let rec apprec env sigma s =
   let (t, stack as s) = whd_betaiota_state s in
@@ -631,8 +793,6 @@ let rec apprec env sigma s =
 	     | NotReducible -> s)
     | _ -> s
 
-let hnf env sigma c = apprec env sigma (c, empty_stack)
-
 (* A reduction function like whd_betaiota but which keeps casts
  * and does not reduce redexes containing existential variables.
  * Used in Correctness.
@@ -695,23 +855,27 @@ let is_arity env sigma c =
   match find_conclusion env sigma c with
     | Sort _ -> true
     | _ -> false
- 
-let info_arity env sigma c =
-  match find_conclusion env sigma c with
-    | Sort (Prop Null) -> false 
-    | Sort (Prop Pos) -> true 
-    | _ -> raise IsType
-    
-let is_info_arity env sigma c =
-  try (info_arity env sigma c) with IsType -> true
-  
-let is_type_arity env sigma c = 
-  match find_conclusion env sigma c with
-    | Sort (Type _) -> true
-    | _ -> false
 
-let is_info_type env sigma t =
-  let s = t.utj_type in
-  (s = Prop Pos) ||
-  (s <> Prop Null && 
-   try info_arity env sigma t.utj_val with IsType -> true)
+(*************************************)
+(* Metas *)
+
+let meta_value evd mv = 
+  let rec valrec mv =
+    try
+      let b = meta_fvalue evd mv in
+      instance
+        (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
+        b.rebus
+    with Anomaly _ | Not_found -> 
+      mkMeta mv
+  in 
+  valrec mv
+
+let meta_instance env b =
+  let c_sigma =
+    List.map 
+      (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas)
+  in 
+  instance c_sigma b.rebus
+
+let nf_meta env c = meta_instance env (mk_freelisted c)
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 65cdd5cd..1e9b3b5b 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: reductionops.mli,v 1.8.2.2 2004/07/16 19:30:46 herbelin Exp $ i*)
+(*i $Id: reductionops.mli 9106 2006-09-01 11:18:17Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -21,6 +21,35 @@ open Closure
 
 exception Elimconst
 
+(************************************************************************)
+(*s A [stack] is a context of arguments, arguments are pushed by
+   [append_stack] one array at a time but popped with [decomp_stack]
+   one by one *)
+
+type 'a stack_member =
+  | Zapp of 'a list
+  | Zcase of case_info * 'a * 'a array
+  | Zfix of 'a * 'a stack
+  | Zshift of int
+  | Zupdate of 'a
+
+and 'a stack = 'a stack_member list
+
+val empty_stack : 'a stack
+val append_stack : 'a array -> 'a stack -> 'a stack
+val append_stack_list : 'a list -> 'a stack -> 'a stack
+
+val decomp_stack : 'a stack -> ('a * 'a stack) option
+val list_of_stack : 'a stack -> 'a list
+val array_of_stack : 'a stack -> 'a array
+val stack_assign : 'a stack -> int -> 'a -> 'a stack
+val stack_args_size : 'a stack -> int
+val app_stack : constr * constr stack -> constr
+val stack_tail : int -> 'a stack -> 'a stack
+val stack_nth : 'a stack -> int -> 'a
+
+(************************************************************************)
+
 type state = constr * constr stack
 
 type contextual_reduction_function = env -> evar_map -> constr -> constr
@@ -63,6 +92,7 @@ val nf_betaiota : local_reduction_function
 val nf_betadeltaiota : reduction_function
 val nf_evar : evar_map -> constr -> constr
 
+val nf_betaiotaevar_preserving_vm_cast : reduction_function
 (* Lazy strategy, weak head reduction *)
 val whd_evar :  evar_map -> constr -> constr
 val whd_beta : local_reduction_function
@@ -111,6 +141,11 @@ val whd_betadeltaiotaeta_stack :  stack_reduction_function
 val whd_betadeltaiotaeta_state :  state_reduction_function
 val whd_betadeltaiotaeta :  reduction_function
 
+val whd_eta : constr -> constr
+
+
+
+
 val beta_applist : constr * constr list -> constr
 
 val hnf_prod_app     : env ->  evar_map -> constr -> constr -> constr
@@ -121,12 +156,15 @@ val hnf_lam_appvect  : env ->  evar_map -> constr -> constr array -> constr
 val hnf_lam_applist  : env ->  evar_map -> constr -> constr list -> constr
 
 val splay_prod : env ->  evar_map -> constr -> (name * constr) list * constr
+val splay_lambda : env ->  evar_map -> constr -> (name * constr) list * constr
 val splay_arity : env ->  evar_map -> constr -> (name * constr) list * sorts
 val sort_of_arity : env -> constr -> sorts
 val decomp_n_prod : 
   env ->  evar_map -> int -> constr -> Sign.rel_context * constr
 val splay_prod_assum :
   env ->  evar_map -> constr -> Sign.rel_context * constr
+val decomp_sort : env -> evar_map -> types -> sorts
+val is_sort : env -> evar_map -> types -> bool
 
 type 'a miota_args = {
   mP      : constr;     (* the result type *)
@@ -140,13 +178,6 @@ val reduce_mind_case : constr miota_args -> constr
 
 val find_conclusion : env -> evar_map -> constr -> (constr,constr) kind_of_term
 val is_arity : env ->  evar_map -> constr -> bool
-val is_info_type : env ->  evar_map -> unsafe_type_judgment -> bool
-val is_info_arity : env ->  evar_map -> constr -> bool
-(*i Pour l'extraction
-val is_type_arity : env -> 'a evar_map -> constr -> bool
-val is_info_cast_type : env -> 'a evar_map -> constr -> bool
-val contents_of_cast_type : env -> 'a evar_map -> constr -> contents
-i*)
 
 val whd_programs :  reduction_function
 
@@ -162,10 +193,6 @@ val reduce_fix : local_state_reduction_function -> fixpoint
 
 type conversion_test = constraints -> constraints
 
-type conv_pb = 
-  | CONV 
-  | CUMUL
-
 val pb_is_equal : conv_pb -> bool
 val pb_equal : conv_pb -> conv_pb
 
@@ -182,9 +209,10 @@ val whd_meta : (metavariable * constr) list -> constr -> constr
 val plain_instance : (metavariable * constr) list -> constr -> constr
 val instance : (metavariable * constr) list -> constr -> constr
 
-(*s Obsolete Reduction Functions *)
+(*s Heuristic for Conversion with Evar *)
 
-(*i
-val hnf : env -> 'a evar_map -> constr -> constr * constr list
-i*)
 val apprec :  state_reduction_function
+
+(*s Meta-related reduction functions *)
+val meta_instance : evar_defs -> constr freelisted -> constr
+val nf_meta       : evar_defs -> constr -> constr
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index 061382f7..ecead438 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -6,22 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: retyping.ml,v 1.43.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+(* $Id: retyping.ml 9314 2006-10-29 20:11:08Z herbelin $ *)
 
 open Util
 open Term
 open Inductive
+open Inductiveops
 open Names
 open Reductionops
 open Environ
 open Typeops
 open Declarations
-open Instantiate
-
-let outsort env sigma t =
-  match kind_of_term (whd_betadeltaiota env sigma t) with
-    | Sort s -> s
-    | _ -> anomaly "Retyping: found a type of type which is not a sort"
+open Termops
 
 let rec subst_type env sigma typ = function
   | [] -> typ
@@ -38,11 +34,16 @@ let rec subst_type env sigma typ = function
 let sort_of_atomic_type env sigma ft args =
   let rec concl_of_arity env ar =
     match kind_of_term (whd_betadeltaiota env sigma ar) with
-      | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b
-      | Sort s -> s
-      | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
+    | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b
+    | Sort s -> s
+    | _ -> decomp_sort env sigma (subst_type env sigma ft (Array.to_list args))
   in concl_of_arity env ft
 
+let type_of_var env id =
+  try let (_,_,ty) = lookup_named id env in ty
+  with Not_found ->
+    anomaly ("type_of: variable "^(string_of_id id)^" unbound")
+
 let typeur sigma metamap =
   let rec type_of env cstr=
     match kind_of_term cstr with
@@ -52,18 +53,11 @@ let typeur sigma metamap =
     | Rel n ->
         let (_,_,ty) = lookup_rel n env in
         lift n ty
-    | Var id ->
-        (try
-          let (_,_,ty) = lookup_named id env in
-          body_of_type ty
-        with Not_found ->
-          anomaly ("type_of: variable "^(string_of_id id)^" unbound"))
-    | Const c ->
-        let cb = lookup_constant c env in
-        body_of_type cb.const_type
-    | Evar ev -> existential_type sigma ev
-    | Ind ind -> body_of_type (type_of_inductive env ind)
-    | Construct cstr -> body_of_type (type_of_constructor env cstr)
+    | Var id -> type_of_var env id
+    | Const cst -> Typeops.type_of_constant env cst
+    | Evar ev -> Evd.existential_type sigma ev
+    | Ind ind -> type_of_inductive env ind
+    | Construct cstr -> type_of_constructor env cstr
     | Case (_,p,c,lf) ->
         let Inductiveops.IndType(_,realargs) =
           try Inductiveops.find_rectype env sigma (type_of env c)
@@ -78,15 +72,18 @@ let typeur sigma metamap =
          subst1 b (type_of (push_rel (name,Some b,c1) env) c2)
     | Fix ((_,i),(_,tys,_)) -> tys.(i)
     | CoFix (i,(_,tys,_)) -> tys.(i)
-    | App(f,args)->
+    | App(f,args) when isGlobalRef f ->
+	let t = type_of_global_reference_knowing_parameters env f args in
+        strip_outer_cast (subst_type env sigma t (Array.to_list args))
+    | App(f,args) ->
         strip_outer_cast
           (subst_type env sigma (type_of env f) (Array.to_list args))
-    | Cast (c,t) -> t
+    | Cast (c,_, t) -> t
     | Sort _ | Prod _ -> mkSort (sort_of env cstr)
 
   and sort_of env t = 
     match kind_of_term t with
-    | Cast (c,s) when isSort s -> destSort s
+    | Cast (c,_, s) when isSort s -> destSort s
     | Sort (Prop c) -> type_0
     | Sort (Type u) -> Type (Univ.super u)
     | Prod (name,t,c2) ->
@@ -95,16 +92,21 @@ let typeur sigma metamap =
           | Prop _, (Prop Pos as s) -> s
           | Type _, (Prop Pos as s) when
               Environ.engagement env = Some ImpredicativeSet -> s
-          | Type _ as s, Prop Pos -> s
-	  | _, (Type u2 as s) -> s (*Type Univ.dummy_univ*))
+          | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.base_univ)
+	  | Prop Pos, (Type u2) -> Type (Univ.sup Univ.base_univ u2)
+	  | Prop Null, (Type _ as s) -> s
+	  | Type u1, Type u2 -> Type (Univ.sup u1 u2))
+    | App(f,args) when isGlobalRef f ->
+	let t = type_of_global_reference_knowing_parameters env f args in
+        sort_of_atomic_type env sigma t args
     | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
     | Lambda _ | Fix _ | Construct _ ->
         anomaly "sort_of: Not a type (1)"
-    | _ -> outsort env sigma (type_of env t)
+    | _ -> decomp_sort env sigma (type_of env t)
 
   and sort_family_of env t =
     match kind_of_term t with
-    | Cast (c,s) when isSort s -> family_of_sort (destSort s)
+    | Cast (c,_, s) when isSort s -> family_of_sort (destSort s)
     | Sort (Prop c) -> InType
     | Sort (Type u) -> InType
     | Prod (name,t,c2) -> sort_family_of (push_rel (name,None,t) env) c2
@@ -112,16 +114,32 @@ let typeur sigma metamap =
        family_of_sort (sort_of_atomic_type env sigma (type_of env f) args)
     | Lambda _ | Fix _ | Construct _ ->
         anomaly "sort_of: Not a type (1)"
-    | _ -> family_of_sort (outsort env sigma (type_of env t))
+    | _ -> family_of_sort (decomp_sort env sigma (type_of env t))
+
+  and type_of_global_reference_knowing_parameters env c args =
+    let argtyps = Array.map (fun c -> nf_evar sigma (type_of env c)) args in
+    match kind_of_term c with
+    | Ind ind ->
+      let (_,mip) = lookup_mind_specif env ind in
+      Inductive.type_of_inductive_knowing_parameters env mip argtyps
+    | Const cst ->
+      let t = constant_type env cst in
+      Typeops.type_of_constant_knowing_parameters env t argtyps
+    | Var id -> type_of_var env id
+    | Construct cstr -> type_of_constructor env cstr
+    | _ -> assert false
 
-  in type_of, sort_of, sort_family_of
+  in type_of, sort_of, sort_family_of,
+     type_of_global_reference_knowing_parameters
 
-let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c
-let get_sort_of env sigma t = let _,f,_ = typeur sigma [] in f env t
-let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c
+let get_type_of env sigma c = let f,_,_,_ = typeur sigma [] in f env c
+let get_sort_of env sigma t = let _,f,_,_ = typeur sigma [] in f env t
+let get_sort_family_of env sigma c = let _,_,f,_ = typeur sigma [] in f env c
+let type_of_global_reference_knowing_parameters env sigma c args =
+  let _,_,_,f = typeur sigma [] in f env c args
 
 let get_type_of_with_meta env sigma metamap = 
-  let f,_,_ = typeur sigma metamap in f env
+  let f,_,_,_ = typeur sigma metamap in f env
 
 (* Makes an assumption from a constr *)
 let get_assumption_of env evc c = c
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index f29ac8d8..733cb4b1 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -6,15 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: retyping.mli,v 1.16.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+(*i $Id: retyping.mli 9314 2006-10-29 20:11:08Z herbelin $ i*)
 
 (*i*)
 open Names
 open Term
 open Evd
 open Environ
-open Pattern
-open Termops
 (*i*)
 
 (* This family of functions assumes its constr argument is known to be
@@ -23,14 +21,19 @@ open Termops
    either produces a wrong result or raise an anomaly. Use with care.
    It doesn't handle predicative universes too. *)
 
-val get_type_of : env -> evar_map -> constr -> constr
+val get_type_of : env -> evar_map -> constr -> types
 val get_sort_of : env -> evar_map -> types -> sorts
 val get_sort_family_of : env -> evar_map -> types -> sorts_family
 
-val get_type_of_with_meta : env -> evar_map -> metamap -> constr -> constr
+val get_type_of_with_meta :
+  env -> evar_map -> Termops.metamap -> constr -> types
 
 (* Makes an assumption from a constr *)
 val get_assumption_of : env -> evar_map -> constr -> types
 
 (* Makes an unsafe judgment from a constr *)
 val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment
+
+val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> 
+  constr array -> types
+ 
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index e8bde1f3..006e14b3 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacred.ml,v 1.75.2.7 2005/11/02 13:18:43 herbelin Exp $ *)
+(* $Id: tacred.ml 8793 2006-05-05 17:41:41Z barras $ *)
 
 open Pp
 open Util
@@ -18,41 +18,28 @@ open Termops
 open Declarations
 open Inductive
 open Environ
-open Reductionops
 open Closure
-open Instantiate
+open Reductionops
 open Cbv
 open Rawterm
 
-exception Elimconst
-exception Redelimination
+(* Errors *)
 
-let set_opaque_const = Conv_oracle.set_opaque_const
-let set_transparent_const sp =
-  let cb = Global.lookup_constant sp in
-  if cb.const_body <> None & cb.const_opaque then
-    errorlabstrm "set_transparent_const"
-      (str "Cannot make" ++ spc () ++ 
-         Nametab.pr_global_env Idset.empty (ConstRef sp) ++
-         spc () ++ str "transparent because it was declared opaque.");
-  Conv_oracle.set_transparent_const sp
+type reduction_tactic_error = 
+    InvalidAbstraction of env * constr * (env * Type_errors.type_error)
 
-let set_opaque_var      = Conv_oracle.set_opaque_var
-let set_transparent_var = Conv_oracle.set_transparent_var
+exception ReductionTacticError of reduction_tactic_error
 
-let _ = 
-  Summary.declare_summary "Transparent constants and variables"
-    { Summary.freeze_function = Conv_oracle.freeze;
-      Summary.unfreeze_function = Conv_oracle.unfreeze;
-      Summary.init_function = Conv_oracle.init;
-      Summary.survive_module = false;
-      Summary.survive_section = false }
+(* Evaluable reference *)
+
+exception Elimconst
+exception Redelimination
 
 let is_evaluable env ref =
   match ref with
       EvalConstRef kn ->
         let (ids,kns) = Conv_oracle.freeze() in
-        KNpred.mem kn kns &
+        Cpred.mem kn kns &
         let cb = Environ.lookup_constant kn env in
         cb.const_body <> None & not cb.const_opaque
     | EvalVarRef id ->
@@ -84,7 +71,7 @@ let destEvalRef c = match kind_of_term c with
   | Var id  -> EvalVar id
   | Rel n -> EvalRel n
   | Evar ev -> EvalEvar ev
-  | _ -> anomaly "Not an evaluable reference"
+  | _ -> anomaly "Not an unfoldable reference"
 
 let reference_opt_value sigma env = function
   | EvalConst cst -> constant_opt_value env cst
@@ -93,8 +80,8 @@ let reference_opt_value sigma env = function
       v
   | EvalRel n ->
       let (_,v,_) = lookup_rel n env in
-      option_app (lift n) v
-  | EvalEvar ev -> existential_opt_value sigma ev
+      option_map (lift n) v
+  | EvalEvar ev -> Evd.existential_opt_value sigma ev
 
 exception NotEvaluable
 let reference_value sigma env c =
@@ -145,17 +132,21 @@ let _ =
       Summary.survive_module = false;
       Summary.survive_section = false }
 
-
 (* Check that c is an "elimination constant"
-   [xn:An]..[x1:A1](<P>MutCase (Rel i) of f1..fk end g1 ..gp)
-   or [xn:An]..[x1:A1](Fix(f|t) (Rel i1) ..(Rel ip)) 
-    with i1..ip distinct variables not occuring in t 
-   keep relevenant information ([i1,Ai1;..;ip,Aip],n,b)
-   with b = true in case of a fixpoint in order to compute 
-   an equivalent of Fix(f|t)[xi<-ai] as 
-   [yip:Bip]..[yi1:Bi1](F bn..b1) 
-   == [yip:Bip]..[yi1:Bi1](Fix(f|t)[xi<-ai] (Rel 1)..(Rel p))
-   with bj=aj if j<>ik and bj=(Rel c) and Bic=Aic[xn..xic-1 <- an..aic-1] *)
+
+   either [xn:An]..[x1:A1](<P>Case (Rel i) of f1..fk end g1 ..gp)
+
+   or     [xn:An]..[x1:A1](Fix(f|t) (Rel i1) ..(Rel ip))
+          with i1..ip distinct variables not occuring in t 
+
+   In the second case, keep relevenant information ([i1,Ai1;..;ip,Aip],n)
+   in order to compute an equivalent of Fix(f|t)[xi<-ai] as 
+
+      [yip:Bip]..[yi1:Bi1](F bn..b1) 
+   == [yip:Bip]..[yi1:Bi1](Fix(f|t)[xi<-ai] (Rel p)..(Rel 1))
+
+   with bj=aj if j<>ik and bj=(Rel c) and Bic=Aic[xn..xic-1 <- an..aic-1]
+*)
 
 let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
   let n = List.length labs in
@@ -199,8 +190,8 @@ let invert_name labs l na0 env sigma ref = function
 	  | EvalRel _ | EvalEvar _ -> None
 	  | EvalVar id' -> Some (EvalVar id)
 	  | EvalConst kn ->
-	      let (mp,dp,_) = repr_kn kn in
-	      Some (EvalConst (make_kn mp dp (label_of_id id))) in
+	      let (mp,dp,_) = repr_con kn in
+	      Some (EvalConst (make_con mp dp (label_of_id id))) in
 	match refi with
 	  | None -> None
 	  | Some ref ->
@@ -242,7 +233,7 @@ let compute_consteval_mutual_fix sigma env ref =
     match kind_of_term c' with
       | Lambda (na,t,g) when l=[] ->
 	  srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g
-      | Fix ((lv,i),(names,_,_) as fix) ->
+      | Fix ((lv,i),(names,_,_)) ->
 	  (* Last known constant wrapping Fix is ref = [labs](Fix l) *)
 	  (match compute_consteval_direct sigma env ref with
 	     | NotAnElimination -> (*Above const was eliminable but this not!*)
@@ -294,43 +285,49 @@ let rev_firstn_liftn fn ln =
   in 
   rfprec fn []
 
-(*  EliminationFix ([(yi1,Ti1);...;(yip,Tip)],n) means f is some
-   [y1:T1,...,yn:Tn](Fix(..) yi1 ... yip);
-   f is applied to largs and we need for recursive calls to build
-   [x1:Ti1',...,xp:Tip'](f a1..a(n-p) yi1 ... yip) 
-   where a1...an are the n first arguments of largs and Tik' is Tik[yil=al]
-   To check ... *)
+(* If f is bound to EliminationFix (n',infos), then n' is the minimal
+   number of args for starting the reduction and infos is
+   (nbfix,[(yi1,Ti1);...;(yip,Tip)],n) indicating that f converts
+   to some [y1:T1,...,yn:Tn](Fix(..) yip .. yi1) where we can remark that
+   yij = Rel(n+1-j)
+
+   f is applied to largs and we need for recursive calls to build the function
+      g := [xp:Tip',...,x1:Ti1'](f a1 ... an)
+
+   s.t. (g u1 ... up) reduces to (Fix(..) u1 ... up)
+
+   This is made possible by setting 
+      a_k:=z_j    if k=i_j
+      a_k:=y_k    otherwise
+
+   The type Tij' is Tij[yn..yi(j-1)..y1 <- ai(j-1)..a1]
+*)
+
+let x = Name (id_of_string "x")
 
 let make_elim_fun (names,(nbfix,lv,n)) largs =
-  let labs = list_firstn n (list_of_stack largs) in
+  let lu = list_firstn n (list_of_stack largs) in
   let p = List.length lv in
-  let ylv = List.map fst lv in
-  let la' = list_map_i 
-	      (fun q aq ->
-		 try (mkRel (p+1-(list_index (n-q) ylv))) 
-		 with Not_found -> aq) 0
-              (List.map (lift p) labs) 
+  let lyi = List.map fst lv in
+  let la =
+    list_map_i (fun q aq -> 
+      (* k from the comment is q+1 *) 
+      try mkRel (p+1-(list_index (n-q) lyi))
+      with Not_found -> aq)
+      0 (List.map (lift p) lu) 
   in 
   fun i ->
     match names.(i) with
       | None -> None
-      | Some ref -> Some (
-(*    let fi =
-      if nbfix = 1 then
-	mkEvalRef ref
-      else
-	match ref with
-	  | EvalConst (sp,args) ->
-	      mkConst (make_path (dirpath sp) id (kind_of_path sp),args)
-	  | _ -> anomaly "elimination of local fixpoints not implemented"
-    in
-*)
-      list_fold_left_i 
-	(fun i c (k,a) -> 
-	   mkLambda (Name(id_of_string"x"),
-		     substl (rev_firstn_liftn (n-k) (-i) la') a,
-		     c))
-	1 (applistc (mkEvalRef ref) la') (List.rev lv))
+      | Some ref ->
+          let body = applistc (mkEvalRef ref) la in
+          let g = 
+            list_fold_left_i (fun q (* j from comment is n+1-q *) c (ij,tij) ->
+              let subst = List.map (lift (-q)) (list_firstn (n-ij) la) in
+              let tij' = substl (List.rev subst) tij in
+	      mkLambda (x,tij',c)
+            ) 1 body (List.rev lv)
+          in Some g
 
 (* [f] is convertible to [Fix(recindices,bodynum),bodyvect)] make 
    the reduction using this extra information *)
@@ -372,7 +369,7 @@ let contract_cofix_use_function f (bodynum,(_,names,bodies as typedbodies)) =
 
 let reduce_mind_case_use_function func env mia =
   match kind_of_term mia.mconstr with 
-    | Construct(ind_sp,i as cstr_sp) ->
+    | Construct(ind_sp,i) ->
 	let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
 	applist (mia.mlf.(i-1), real_cargs)
     | CoFix (_,(names,_,_) as cofix) ->
@@ -380,8 +377,8 @@ let reduce_mind_case_use_function func env mia =
 	  match names.(i) with 
 	    | Name id ->
                 if isConst func then
-		  let (mp,dp,_) = repr_kn (destConst func) in
-		  let kn = make_kn mp dp (label_of_id id) in
+		  let (mp,dp,_) = repr_con (destConst func) in
+		  let kn = make_con mp dp (label_of_id id) in
 		  (match constant_opt_value env kn with
 		    | None -> None
 		    | Some _ -> Some (mkConst kn))
@@ -452,7 +449,7 @@ let rec red_elim_const env sigma ref largs =
 and construct_const env sigma = 
   let rec hnfstack (x, stack as s) =
     match kind_of_term x with
-      | Cast (c,_) -> hnfstack (c, stack)
+      | Cast (c,_,_) -> hnfstack (c, stack)
       | App (f,cl) -> hnfstack (f, append_stack cl stack)
       | Lambda (id,t,c) ->
           (match decomp_stack stack with 
@@ -491,7 +488,7 @@ and construct_const env sigma =
 
 (* Red reduction tactic: reduction to a product *)
 
-let internal_red_product env sigma c = 
+let try_red_product env sigma c = 
   let simpfun = clos_norm_flags betaiotazeta env sigma in
   let rec redrec env x =
     match kind_of_term x with
@@ -506,7 +503,7 @@ let internal_red_product env sigma c =
                         let stack' = stack_assign stack recargnum recarg' in
                         simpfun (app_stack (f,stack')))
              | _ -> simpfun (appvect (redrec env f, l)))
-      | Cast (c,_) -> redrec env c
+      | Cast (c,_,_) -> redrec env c
       | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b)
       | LetIn (x,a,b,t) -> redrec env (subst1 a t)
       | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf))
@@ -521,11 +518,9 @@ let internal_red_product env sigma c =
   in redrec env c
 
 let red_product env sigma c = 
-  try internal_red_product env sigma c
+  try try_red_product env sigma c
   with Redelimination -> error "Not reducible"
 
-(* Hnf reduction tactic: *)
-
 let hnf_constr env sigma c = 
   let rec redrec (x, largs as s) =
     match kind_of_term x with
@@ -536,7 +531,7 @@ let hnf_constr env sigma c =
 		 stacklam redrec [a] c rest)
       | LetIn (n,b,t,c) -> stacklam redrec [b] c largs
       | App (f,cl)   -> redrec (f, append_stack cl largs)
-      | Cast (c,_) -> redrec (c, largs)
+      | Cast (c,_,_) -> redrec (c, largs)
       | Case (ci,p,c,lf) ->
           (try
              redrec 
@@ -577,7 +572,7 @@ let whd_nf env sigma c =
 		 stacklam nf_app [a1] c2 rest)
       | LetIn (n,b,t,c) -> stacklam nf_app [b] c stack
       | App (f,cl) -> nf_app (f, append_stack cl stack)
-      | Cast (c,_) -> nf_app (c, stack)
+      | Cast (c,_,_) -> nf_app (c, stack)
       | Case (ci,p,d,lf) ->
           (try
              nf_app (special_red_case sigma env nf_app (ci,p,d,lf), stack)
@@ -598,9 +593,6 @@ let whd_nf env sigma c =
 
 let nf env sigma c = strong whd_nf env sigma c
 
-let is_reference c = 
-  try let r = reference_of_constr c in true with _ -> false
-
 let is_head c t =
   match kind_of_term t with
     | App (f,_) -> f = c
@@ -609,7 +601,6 @@ let is_head c t =
 let contextually byhead (locs,c) f env sigma t =
   let maxocc = List.fold_right max locs 0 in
   let pos = ref 1 in
-  let check = ref true in
   let except = List.exists (fun n -> n<0) locs in
   if except & (List.exists (fun n -> n>=0) locs) 
   then error "mixing of positive and negative occurences"
@@ -626,7 +617,7 @@ let contextually byhead (locs,c) f env sigma t =
 	f env sigma t
       else if byhead then
 	(* find other occurrences of c in t; TODO: ensure left-to-right *)
-        let (f,l) = destApplication t in
+        let (f,l) = destApp t in
 	mkApp (f, array_map_left (traverse envc) l)
       else
 	t
@@ -637,7 +628,7 @@ let contextually byhead (locs,c) f env sigma t =
   in
   let t' = traverse (env,c) t in
   if locs <> [] & List.exists (fun o -> o >= !pos or o <= - !pos) locs then
-    errorlabstrm "contextually" (str "Too few occurences");
+    error_invalid_occurrence locs;
   t'
 
 (* linear bindings (following pretty-printer) of the value of name in c.
@@ -652,7 +643,7 @@ let rec substlin env name n ol c =
           with
 	      NotEvaluableConst _ ->
 		errorlabstrm "substlin"
-		  (pr_kn kn ++ str " is not a defined constant")
+		  (pr_con kn ++ str " is not a defined constant")
         else 
 	  ((n+1), ol, c)
 
@@ -701,7 +692,7 @@ let rec substlin env name n ol c =
                let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
                (n2,ol2,mkProd (na,c1',c2')))
 	
-    | Case (ci,p,d,llf) -> 
+    | Case (ci,p,d,llf) ->
         let rec substlist nn oll = function
           | []     -> (nn,oll,[])
           | f::lfe ->
@@ -712,24 +703,25 @@ let rec substlin env name n ol c =
                      let (nn2,oll2,lfe') = substlist nn1 oll1 lfe in
                      (nn2,oll2,f'::lfe'))
 	in
-	let (n1,ol1,p') = substlin env name n ol p in  (* ATTENTION ERREUR *)
-        (match ol1 with                                 (* si P pas affiche *)
-           | [] -> (n1,[],mkCase (ci, p', d, llf))
+	(* p is printed after d in v8 syntax *)
+	let (n1,ol1,d') = substlin env name n ol d in
+        (match ol1 with
+           | [] -> (n1,[],mkCase (ci, p, d', llf))
            | _  ->
-               let (n2,ol2,d') = substlin env name n1 ol1 d in
+               let (n2,ol2,p') = substlin env name n1 ol1 p in
                (match ol2 with
 		  | [] -> (n2,[],mkCase (ci, p', d', llf))
 		  | _  -> 
 	              let (n3,ol3,lf') = substlist n2 ol2 (Array.to_list llf)
                       in (n3,ol3,mkCase (ci, p', d', Array.of_list lf'))))
         
-    | Cast (c1,c2)   ->
+    | Cast (c1,k,c2)   ->
         let (n1,ol1,c1') = substlin env name n ol c1 in
         (match ol1 with 
-           | [] -> (n1,[],mkCast (c1',c2))
-           | _  ->
-               let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
-               (n2,ol2,mkCast (c1',c2')))
+           | [] -> (n1,[],mkCast (c1',k,c2))
+           | _  -> 
+	       let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
+               (n2,ol2,mkCast (c1',k,c2')))
 
     | Fix _ -> 
         (warning "do not consider occurrences inside fixpoints"; (n,ol,c))
@@ -764,8 +756,8 @@ let unfoldoccs env sigma (occl,name) c =
           | (_,[],uc) -> nf_betaiota uc
           | (1,_,_) ->
               error ((string_of_evaluable_ref env name)^" does not occur")
-          | _ -> error ("bad occurrence numbers of "
-			^(string_of_evaluable_ref env name))
+          | (_,l,_) ->
+	      error_invalid_occurrence l
 
 (* Unfold reduction tactic: *)
 let unfoldn loccname env sigma c = 
@@ -797,78 +789,29 @@ let compute = cbv_betadeltaiota
 (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only
  * the specified occurrences. *)
 
-let abstract_scheme env sigma (locc,a) t =
+let abstract_scheme env sigma (locc,a) c =
   let ta = Retyping.get_type_of env sigma a in
   let na = named_hd env ta Anonymous in
   if occur_meta ta then error "cannot find a type for the generalisation";
   if occur_meta a then 
-    mkLambda (na,ta,t)
+    mkLambda (na,ta,c)
   else 
-    mkLambda (na, ta,subst_term_occ locc a t)
-
+    mkLambda (na,ta,subst_term_occ locc a c)
 
 let pattern_occs loccs_trm env sigma c =
   let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in
-  let _ = Typing.type_of env sigma abstr_trm in
-  applist(abstr_trm, List.map snd loccs_trm)
-
-(* Generic reduction: reduction functions used in reduction tactics *)
-
-type red_expr = (constr, evaluable_global_reference) red_expr_gen
-
-open RedFlags
-
-let make_flag_constant = function
-  | EvalVarRef id -> fVAR id
-  | EvalConstRef sp -> fCONST sp
-
-let make_flag f =
-  let red = no_red in
-  let red = if f.rBeta then red_add red fBETA else red in
-  let red = if f.rIota then red_add red fIOTA else red in
-  let red = if f.rZeta then red_add red fZETA else red in
-  let red =
-    if f.rDelta then (* All but rConst *)
-        let red = red_add red fDELTA in
-        let red = red_add_transparent red (Conv_oracle.freeze ()) in
-	List.fold_right
-	  (fun v red -> red_sub red (make_flag_constant v))
-	  f.rConst red
-    else (* Only rConst *)
-        let red = red_add_transparent (red_add red fDELTA) all_opaque in
-	List.fold_right
-	  (fun v red -> red_add red (make_flag_constant v))
-	  f.rConst red
-  in red
-
-let red_expr_tab = ref Stringmap.empty
-
-let declare_red_expr s f =
-  try 
-    let _ = Stringmap.find s !red_expr_tab in
-    error ("There is already a reduction expression of name "^s)
-  with Not_found ->
-    red_expr_tab := Stringmap.add s f !red_expr_tab
-
-let reduction_of_redexp = function
-  | Red internal -> if internal then internal_red_product else red_product
-  | Hnf -> hnf_constr
-  | Simpl (Some (_,c as lp)) -> contextually (is_reference c) lp nf
-  | Simpl None -> nf
-  | Cbv f -> cbv_norm_flags (make_flag f)
-  | Lazy f -> clos_norm_flags (make_flag f)
-  | Unfold ubinds -> unfoldn ubinds
-  | Fold cl -> fold_commands cl
-  | Pattern lp -> pattern_occs lp
-  | ExtraRedExpr s ->
-      (try Stringmap.find s !red_expr_tab
-      with Not_found -> error("unknown user-defined reduction \""^s^"\""))
+  try
+    let _ = Typing.type_of env sigma abstr_trm in
+    applist(abstr_trm, List.map snd loccs_trm)
+  with Type_errors.TypeError (env',t) ->
+    raise (ReductionTacticError (InvalidAbstraction (env,abstr_trm,(env',t))))
+
 (* Used in several tactics. *)
 
 exception NotStepReducible
 
 let one_step_reduce env sigma c = 
-  let rec redrec (x, largs as s) =
+  let rec redrec (x, largs) =
     match kind_of_term x with
       | Lambda (n,t,c)  ->
           (match decomp_stack largs with
@@ -885,7 +828,7 @@ let one_step_reduce env sigma c =
 	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with
              | Reduced s' -> s'
 	     | NotReducible -> raise NotStepReducible)
-      | Cast (c,_) -> redrec (c,largs)
+      | Cast (c,_,_) -> redrec (c,largs)
       | _ when isEvalRef env x ->
 	  let ref =
             try destEvalRef x
@@ -940,14 +883,14 @@ let reduce_to_ref_gen allow_product env sigma ref t =
 	       (str"Not an induction object of atomic type")
       | _ ->
 	  try 
-	    if reference_of_constr c = ref 
+	    if global_of_constr c = ref 
 	    then it_mkProd_or_LetIn t l
 	    else raise Not_found
 	  with Not_found ->
           try 
 	    let t' = nf_betaiota (one_step_reduce env sigma t) in 
 	    elimrec env t' l
-          with NotStepReducible -> 
+          with NotStepReducible ->
 	    errorlabstrm ""
 	    (str "Not a statement of conclusion " ++ 
 	     Nametab.pr_global_env Idset.empty ref)
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 7998a8fd..691fdf01 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacred.mli,v 1.21.2.2 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: tacred.mli 8878 2006-05-30 16:44:25Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -18,15 +18,23 @@ open Closure
 open Rawterm
 (*i*)
 
+type reduction_tactic_error = 
+    InvalidAbstraction of env * constr * (env * Type_errors.type_error)
+
+exception ReductionTacticError of reduction_tactic_error
+
 (*s Reduction functions associated to tactics. \label{tacred} *)
 
 val is_evaluable : env -> evaluable_global_reference -> bool
 
 exception Redelimination
 
-(* Red (raise Redelimination if nothing reducible) *)
+(* Red (raise user error if nothing reducible) *)
 val red_product : reduction_function
 
+(* Red (raise Redelimination if nothing reducible) *)
+val try_red_product : reduction_function
+
 (* Hnf *)
 val hnf_constr :  reduction_function
 
@@ -69,17 +77,5 @@ val reduce_to_quantified_ref :
 val reduce_to_atomic_ref :
   env ->  evar_map -> Libnames.global_reference -> types -> types
 
-type red_expr = (constr, evaluable_global_reference) red_expr_gen
-
-val contextually : bool -> constr occurrences -> reduction_function
+val contextually : bool -> int list * constr -> reduction_function
   -> reduction_function
-val reduction_of_redexp : red_expr -> reduction_function
-
-val declare_red_expr : string -> reduction_function -> unit
-
-(* Opaque and Transparent commands. *)
-val set_opaque_const      : constant -> unit
-val set_transparent_const : constant -> unit
-
-val set_opaque_var      : identifier -> unit
-val set_transparent_var : identifier -> unit
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index 8f12ca62..6b7e1fb7 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: termops.ml,v 1.29.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+(* $Id: termops.ml 9429 2006-12-12 08:01:03Z herbelin $ *)
 
 open Pp
 open Util
@@ -25,7 +25,7 @@ let print_sort = function
   | Prop Null -> (str "Prop")
   | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")")
 
-let print_sort_family = function
+let pr_sort_family = function
   | InSet -> (str "Set")
   | InProp -> (str "Prop")
   | InType -> (str "Type")
@@ -35,60 +35,116 @@ let pr_name = function
   | Anonymous -> str "_"
 
 let pr_sp sp = str(string_of_kn sp)
+let pr_con sp = str(string_of_con sp)
 
-let rec print_constr c = match kind_of_term c with
+let rec pr_constr c = match kind_of_term c with
   | Rel n -> str "#"++int n
   | Meta n -> str "Meta(" ++ int n ++ str ")"
   | Var id -> pr_id id
   | Sort s -> print_sort s
-  | Cast (c,t) -> hov 1 
-      (str"(" ++ print_constr c ++ cut() ++
-       str":" ++ print_constr t ++ str")")
+  | Cast (c,_, t) -> hov 1 
+      (str"(" ++ pr_constr c ++ cut() ++
+       str":" ++ pr_constr t ++ str")")
   | Prod (Name(id),t,c) -> hov 1
-      (str"forall " ++ pr_id id ++ str":" ++ print_constr t ++ str"," ++
-       spc() ++ print_constr c)
+      (str"forall " ++ pr_id id ++ str":" ++ pr_constr t ++ str"," ++
+       spc() ++ pr_constr c)
   | Prod (Anonymous,t,c) -> hov 0
-      (str"(" ++ print_constr t ++ str " ->" ++ spc() ++
-       print_constr c ++ str")")
+      (str"(" ++ pr_constr t ++ str " ->" ++ spc() ++
+       pr_constr c ++ str")")
   | Lambda (na,t,c) -> hov 1
       (str"fun " ++ pr_name na ++ str":" ++
-       print_constr t ++ str" =>" ++ spc() ++ print_constr c)
+       pr_constr t ++ str" =>" ++ spc() ++ pr_constr c)
   | LetIn (na,b,t,c) -> hov 0
-      (str"let " ++ pr_name na ++ str":=" ++ print_constr b ++
-       str":" ++ brk(1,2) ++ print_constr t ++ cut() ++
-       print_constr c)
+      (str"let " ++ pr_name na ++ str":=" ++ pr_constr b ++
+       str":" ++ brk(1,2) ++ pr_constr t ++ cut() ++
+       pr_constr c)
   | App (c,l) ->  hov 1
-      (str"(" ++ print_constr c ++ spc() ++
-       prlist_with_sep spc print_constr (Array.to_list l) ++ str")")
+      (str"(" ++ pr_constr c ++ spc() ++
+       prlist_with_sep spc pr_constr (Array.to_list l) ++ str")")
   | Evar (e,l) -> hov 1
       (str"Evar#" ++ int e ++ str"{" ++
-       prlist_with_sep spc print_constr (Array.to_list l) ++str"}")
-  | Const c -> str"Cst(" ++ pr_sp c ++ str")"
+       prlist_with_sep spc pr_constr (Array.to_list l) ++str"}")
+  | Const c -> str"Cst(" ++ pr_con c ++ str")"
   | Ind (sp,i) -> str"Ind(" ++ pr_sp sp ++ str"," ++ int i ++ str")"
   | Construct ((sp,i),j) ->
       str"Constr(" ++ pr_sp sp ++ str"," ++ int i ++ str"," ++ int j ++ str")"
   | Case (ci,p,c,bl) -> v 0
-      (hv 0 (str"<"++print_constr p++str">"++ cut() ++ str"Case " ++
-             print_constr c ++ str"of") ++ cut() ++
-       prlist_with_sep (fun _ -> brk(1,2)) print_constr (Array.to_list bl) ++
+      (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++
+             pr_constr c ++ str"of") ++ cut() ++
+       prlist_with_sep (fun _ -> brk(1,2)) pr_constr (Array.to_list bl) ++
       cut() ++ str"end")
   | Fix ((t,i),(lna,tl,bl)) ->
       let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in
       hov 1
         (str"fix " ++ int i ++ spc() ++  str"{" ++
          v 0 (prlist_with_sep spc (fun (na,i,ty,bd) ->
-           pr_name na ++ str"/" ++ int i ++ str":" ++ print_constr ty ++
-           cut() ++ str":=" ++ print_constr bd) (Array.to_list fixl)) ++
+           pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++
+           cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
          str"}")
   | CoFix(i,(lna,tl,bl)) ->
       let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in
       hov 1
         (str"cofix " ++ int i ++ spc() ++  str"{" ++
          v 0 (prlist_with_sep spc (fun (na,ty,bd) ->
-           pr_name na ++ str":" ++ print_constr ty ++
-           cut() ++ str":=" ++ print_constr bd) (Array.to_list fixl)) ++
+           pr_name na ++ str":" ++ pr_constr ty ++
+           cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
          str"}")
 
+let term_printer = ref (fun _ -> pr_constr)
+let print_constr_env t = !term_printer t
+let print_constr t = !term_printer (Global.env()) t
+let set_print_constr f = term_printer := f
+
+let pr_var_decl env (id,c,typ) =
+  let pbody = match c with
+    | None ->  (mt ())
+    | Some c ->
+	(* Force evaluation *) 
+	let pb = print_constr_env env c in
+	  (str" := " ++ pb ++ cut () ) in
+  let pt = print_constr_env env typ in
+  let ptyp = (str" : " ++ pt) in
+    (pr_id id ++ hov 0 (pbody ++ ptyp))
+
+let pr_rel_decl env (na,c,typ) =
+  let pbody = match c with
+    | None -> mt ()
+    | Some c ->
+	(* Force evaluation *) 
+	let pb = print_constr_env env c in
+	  (str":=" ++ spc () ++ pb ++ spc ()) in
+  let ptyp = print_constr_env env typ in
+    match na with
+      | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
+      | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
+
+let print_named_context env =
+  hv 0 (fold_named_context
+	  (fun env d pps -> 
+	    pps ++ ws 2 ++ pr_var_decl env d)
+          env ~init:(mt ()))
+
+let print_rel_context env = 
+  hv 0 (fold_rel_context
+	  (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d)
+          env ~init:(mt ()))
+    
+let print_env env =
+  let sign_env =
+    fold_named_context
+      (fun env d pps ->
+         let pidt =  pr_var_decl env d in
+	 (pps ++ fnl () ++ pidt))
+      env ~init:(mt ()) 
+  in
+  let db_env =
+    fold_rel_context
+      (fun env d pps ->
+         let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat))
+      env ~init:(mt ())
+  in 
+    (sign_env ++ db_env)
+    
 (*let current_module = ref empty_dirpath
 
 let set_module m = current_module := m*)
@@ -98,6 +154,20 @@ let new_univ =
   (fun sp ->
     incr univ_gen; 
     Univ.make_univ (Lib.library_dp(),!univ_gen))
+let new_Type () = mkType (new_univ ())
+let new_Type_sort () = Type (new_univ ())
+
+(* This refreshes universes in types; works only for inferred types (i.e. for
+   types of the form (x1:A1)...(xn:An)B with B a sort or an atom in
+   head normal form) *)
+let refresh_universes t =
+  let modified = ref false in
+  let rec refresh t = match kind_of_term t with
+    | Sort (Type _) -> modified := true; new_Type ()
+    | Prod (na,u,v) -> mkProd (na,u,refresh v)
+    | _ -> t in
+  let t' = refresh t in
+  if !modified then t' else t
 
 let new_sort_in_family = function 
   | InProp -> mk_Prop
@@ -185,6 +255,8 @@ let it_named_context_quantifier f ~init =
 let it_mkNamedProd_or_LetIn = it_named_context_quantifier mkNamedProd_or_LetIn
 let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn
 
+let it_mkNamedProd_wo_LetIn = it_named_context_quantifier mkNamedProd_wo_LetIn
+
 (* *)
 
 (* strips head casts and flattens head applications *)
@@ -192,11 +264,11 @@ let rec strip_head_cast c = match kind_of_term c with
   | App (f,cl) -> 
       let rec collapse_rec f cl2 = match kind_of_term f with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
-	| Cast (c,_) -> collapse_rec c cl2
-	| _ -> if cl2 = [||] then f else mkApp (f,cl2)
+	| Cast (c,_,_) -> collapse_rec c cl2
+	| _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2)
       in 
       collapse_rec f cl
-  | Cast (c,t) -> strip_head_cast c
+  | Cast (c,_,_) -> strip_head_cast c
   | _ -> c
 
 (* [map_constr_with_named_binders g f l c] maps [f l] on the immediate
@@ -208,7 +280,7 @@ let rec strip_head_cast c = match kind_of_term c with
 let map_constr_with_named_binders g f l c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> c
-  | Cast (c,t) -> mkCast (f l c, f l t)
+  | Cast (c,k,t) -> mkCast (f l c, k, f l t)
   | Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c)
   | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c)
   | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c)
@@ -243,7 +315,7 @@ let fold_rec_types g (lna,typarray,_) e =
 let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> c
-  | Cast (c,t) -> let c' = f l c in mkCast (c', f l t)
+  | Cast (c,k,t) -> let c' = f l c in mkCast (c',k,f l t)
   | Prod (na,t,c) ->
       let t' = f l t in
       mkProd (na, t', f (g (na,None,t) l) c)
@@ -263,7 +335,9 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
       mkApp (hd, [| f l a |])
   | Evar (e,al) -> mkEvar (e, array_map_left (f l) al)
   | Case (ci,p,c,bl) ->
-      let p' = f l p in let c' = f l c in
+      (* In v8 concrete syntax, predicate is after the term to match! *)
+      let c' = f l c in
+      let p' = f l p in
       mkCase (ci, p', c', array_map_left (f l) bl)
   | Fix (ln,(lna,tl,bl as fx)) ->
       let l' = fold_rec_types g fx l in
@@ -278,10 +352,10 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
 let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> cstr
-  | Cast (c,t) -> 
+  | Cast (c,k, t) -> 
       let c' = f l c in
       let t' = f l t in
-      if c==c' && t==t' then cstr else mkCast (c', t')
+      if c==c' && t==t' then cstr else mkCast (c', k, t')
   | Prod (na,t,c) ->
       let t' = f l t in
       let c' = f (g (na,None,t) l) c in
@@ -335,7 +409,7 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
 let fold_constr_with_binders g f n acc c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> acc
-  | Cast (c,t) -> f n (f n acc c) t
+  | Cast (c,_, t) -> f n (f n acc c) t
   | Prod (_,t,c) -> f (g n) (f n acc t) c
   | Lambda (_,t,c) -> f (g n) (f n acc t) c
   | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c
@@ -359,7 +433,7 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with
 let iter_constr_with_full_binders g f l c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> ()
-  | Cast (c,t) -> f l c; f l t
+  | Cast (c,_, t) -> f l c; f l t
   | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c
   | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c
   | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c
@@ -541,10 +615,14 @@ let replace_term = replace_term_gen eq_constr
    bindings is done. The list may contain only negative occurrences
    that will not be substituted. *)
 
+let error_invalid_occurrence l =
+  errorlabstrm ""
+    (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++ 
+     prlist_with_sep spc int l)
+
 let subst_term_occ_gen locs occ c t =
   let maxocc = List.fold_right max locs 0 in
   let pos = ref occ in
-  let check = ref true in
   let except = List.exists (fun n -> n<0) locs in
   if except & (List.exists (fun n -> n>=0) locs) 
   then error "mixing of positive and negative occurences"
@@ -573,8 +651,8 @@ let subst_term_occ locs c t =
     t
   else 
     let (nbocc,t') = subst_term_occ_gen locs 1 c t in
-    if List.exists (fun o -> o >= nbocc or o <= -nbocc) locs then
-      errorlabstrm "subst_term_occ" (str "Too few occurences");
+    let rest = List.filter (fun o -> o >= nbocc or o <= -nbocc) locs in
+    if rest <> [] then error_invalid_occurrence rest;
     t'
 
 let subst_term_occ_decl locs c (id,bodyopt,typ as d) =
@@ -588,8 +666,8 @@ let subst_term_occ_decl locs c (id,bodyopt,typ as d) =
 	else 
 	  let (nbocc,body') = subst_term_occ_gen locs 1 c body in
 	  let (nbocc',t') = subst_term_occ_gen locs nbocc c typ in
-	  if List.exists (fun o -> o >= nbocc' or o <= -nbocc') locs then
-	    errorlabstrm "subst_term_occ_decl" (str "Too few occurences");
+	  let rest = List.filter (fun o -> o >= nbocc' or o <= -nbocc') locs in
+	  if rest <> [] then error_invalid_occurrence rest;
 	  (id,Some body',t')
 
 
@@ -626,10 +704,10 @@ let hdchar env c =
     | Prod (_,_,c)       -> hdrec (k+1) c
     | Lambda (_,_,c)     -> hdrec (k+1) c
     | LetIn (_,_,_,c)    -> hdrec (k+1) c
-    | Cast (c,_)         -> hdrec k c
+    | Cast (c,_,_)         -> hdrec k c
     | App (f,l)         -> hdrec k f
     | Const kn       ->
-	let c = lowercase_first_char (id_of_label (label kn)) in
+	let c = lowercase_first_char (id_of_label (con_label kn)) in
 	if c = "?" then "y" else c
     | Ind ((kn,i) as x) ->
 	if i=0 then 
@@ -667,8 +745,11 @@ let named_hd env a = function
 
 let named_hd_type env a = named_hd env (body_of_type a)
 
-let prod_name   env (n,a,b) = mkProd (named_hd_type env a n, a, b)
-let lambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b)
+let mkProd_name   env (n,a,b) = mkProd (named_hd_type env a n, a, b)
+let mkLambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b)
+
+let lambda_name = mkLambda_name
+let prod_name = mkProd_name
 
 let prod_create   env (a,b) = mkProd (named_hd_type env a Anonymous, a, b)
 let lambda_create env (a,b) =  mkLambda (named_hd_type env a Anonymous, a, b)
@@ -714,6 +795,7 @@ let ids_of_rel_context sign =
   Sign.fold_rel_context
     (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l)
     sign ~init:[]
+
 let ids_of_named_context sign =
   Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
 
@@ -721,6 +803,7 @@ let ids_of_context env =
   (ids_of_rel_context (rel_context env))
   @ (ids_of_named_context (named_context env))
 
+
 let names_of_rel_context env =
   List.map (fun (na,_,_) -> na) (rel_context env)
 
@@ -734,7 +817,6 @@ let rec is_imported_modpath = function
 
 let is_imported_ref = function
   | VarRef _ -> false
-  | ConstRef kn 
   | IndRef (kn,_)
   | ConstructRef ((kn,_),_) 
 (*  | ModTypeRef ln  *) -> 
@@ -742,6 +824,8 @@ let is_imported_ref = function
 (*  | ModRef mp ->
       is_imported_modpath mp
 *)
+  | ConstRef kn ->
+      let (mp,_,_) = repr_con kn in is_imported_modpath mp
 
 let is_global id =
   try 
@@ -751,7 +835,7 @@ let is_global id =
     false
 
 let is_section_variable id =
-  try let _ = Sign.lookup_named id (Global.named_context()) in true
+  try let _ = Global.lookup_named id in true
   with Not_found -> false
 
 let next_global_ident_from allow_secvar id avoid = 
@@ -771,7 +855,12 @@ let next_global_ident_away allow_secvar id avoid =
   else  
     next_global_ident_from allow_secvar (lift_ident id) avoid
 
-(* Nouvelle version de renommage des variables (DEC 98) *)
+let isGlobalRef c = 
+  match kind_of_term c with
+  | Const _ | Ind _ | Construct _ | Var _ -> true
+  | _ -> false
+
+(* nouvelle version de renommage des variables (DEC 98) *)
 (* This is the algorithm to display distinct bound variables 
 
     - Règle 1 : un nom non anonyme, même non affiché, contribue à la liste
@@ -823,7 +912,7 @@ let next_name_not_occuring is_goal_ccl name l env_names t =
         (* Normally, an anonymous name is not dependent and will not be *)
         (* taken into account by the function concrete_name; just in case *)
         (* invent a valid name *)
-        id_of_string "H"
+        next (id_of_string "H")
 
 (* On reduit une serie d'eta-redex de tete ou rien du tout  *)
 (* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *)
@@ -861,7 +950,7 @@ let eta_eq_constr =
 
 (* iterator on rel context *)
 let process_rel_context f env =
-  let sign = named_context env in
+  let sign = named_context_val env in
   let rels = rel_context env in
   let env0 = reset_with_named_context sign env in
   Sign.fold_rel_context f rels ~init:env0
@@ -877,7 +966,7 @@ let assums_of_rel_context sign =
 let lift_rel_context n sign =
   let rec liftrec k = function
     | (na,c,t)::sign ->
-	(na,option_app (liftn n k) c,type_app (liftn n k) t)
+	(na,option_map (liftn n k) c,type_app (liftn n k) t)
 	::(liftrec (k-1) sign)
     | [] -> []
   in
@@ -933,6 +1022,12 @@ let rec rename_bound_var env l c =
   | Prod (Anonymous,c1,c2) ->
         let env' = push_rel (Anonymous,None,c1) env in
         mkProd (Anonymous, c1, rename_bound_var env' l c2)
-  | Cast (c,t) -> mkCast (rename_bound_var env l c, t)
+  | Cast (c,k,t) -> mkCast (rename_bound_var env l c, k,t)
   | x -> c
 
+(* Combinators on judgments *)
+
+let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type }
+let on_judgment_value f j = { j with uj_val = f j.uj_val }
+let on_judgment_type f j = { j with uj_type = f j.uj_type }
+
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
index 22bd0aba..e406b148 100644
--- a/pretyping/termops.mli
+++ b/pretyping/termops.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: termops.mli,v 1.21.2.3 2005/01/21 17:19:37 herbelin Exp $ i*)
+(*i $Id: termops.mli 9314 2006-10-29 20:11:08Z herbelin $ i*)
 
 open Util
 open Pp
@@ -16,14 +16,24 @@ open Sign
 open Environ
 
 (* Universes *)
-(*i val set_module : Names.dir_path -> unit i*)
 val new_univ : unit -> Univ.universe
 val new_sort_in_family : sorts_family -> sorts
+val new_Type : unit -> types
+val new_Type_sort : unit -> sorts
+val refresh_universes : types -> types
 
-(* iterators on terms *)
+(* printers *)
 val print_sort : sorts -> std_ppcmds
-val print_sort_family : sorts_family -> std_ppcmds
-val print_constr : constr -> std_ppcmds
+val pr_sort_family : sorts_family -> std_ppcmds
+(* debug printer: do not use to display terms to the casual user... *)
+val set_print_constr : (env -> constr -> std_ppcmds) -> unit
+val print_constr     : constr -> std_ppcmds
+val print_constr_env : env -> constr -> std_ppcmds
+val print_named_context : env -> std_ppcmds
+val print_rel_context : env -> std_ppcmds
+val print_env : env -> std_ppcmds
+
+(* iterators on terms *)
 val prod_it : init:types -> (name * types) list -> types
 val lam_it : init:constr -> (name * types) list -> constr
 val rel_vect : int -> int -> constr array
@@ -43,6 +53,7 @@ val it_named_context_quantifier :
   (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a
 val it_mkNamedProd_or_LetIn   : init:types -> named_context -> types
 val it_mkNamedLambda_or_LetIn : init:constr -> named_context -> constr
+val it_mkNamedProd_wo_LetIn   : init:types -> named_context -> types
 
 (**********************************************************************)
 (* Generic iterators on constr                                        *)
@@ -113,6 +124,8 @@ val subst_term_occ : int list -> constr -> types -> types
 val subst_term_occ_decl :
   int list -> constr -> named_declaration -> named_declaration
 
+val error_invalid_occurrence : int list -> 'a
+
 (* Alternative term equalities *)
 val eta_reduce_head : constr -> constr
 val eta_eq_constr : constr -> constr -> bool
@@ -126,8 +139,14 @@ val id_of_name_using_hdchar :
   env -> types -> name -> identifier
 val named_hd : env -> types -> name -> name
 val named_hd_type : env -> types -> name -> name
-val prod_name : env -> name * types * types -> constr
+
+val mkProd_name : env -> name * types * types -> types
+val mkLambda_name : env -> name * types * constr -> constr
+
+(* Deprecated synonyms of [mkProd_name] and [mkLambda_name] *)
+val prod_name : env -> name * types * types -> types
 val lambda_name : env -> name * types * constr -> constr
+
 val prod_create : env -> types * types -> constr
 val lambda_create : env -> types * constr -> constr
 val name_assumption : env -> rel_declaration -> rel_declaration
@@ -184,3 +203,11 @@ val global_vars_set_of_decl : env -> named_declaration -> Idset.t
 
 (* Test if an identifier is the basename of a global reference *)
 val is_section_variable : identifier -> bool
+
+val isGlobalRef : constr -> bool
+
+(* Combinators on judgments *)
+
+val on_judgment       : (types -> types) -> unsafe_judgment -> unsafe_judgment
+val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment
+val on_judgment_type  : (types -> types) -> unsafe_judgment -> unsafe_judgment
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index a84cd612..6fa05fa5 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: typing.ml,v 1.32.6.2 2004/07/16 19:30:46 herbelin Exp $ *)
+(* $Id: typing.ml 9511 2007-01-22 08:27:31Z herbelin $ *)
 
 open Util
 open Names
@@ -16,68 +16,76 @@ open Reductionops
 open Type_errors
 open Pretype_errors
 open Inductive
+open Inductiveops
 open Typeops
+open Evd
+
+let meta_type env mv =
+  let ty =
+    try Evd.meta_ftype env mv
+    with Not_found -> error ("unknown meta ?"^string_of_int mv) in
+  meta_instance env ty
 
 let vect_lift = Array.mapi lift
 let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
 
-type 'a mach_flags = {
-  fix : bool;
-  nocheck : bool }
+let constant_type_knowing_parameters env cst jl =
+  let paramstyp = Array.map (fun j -> j.uj_type) jl in
+  type_of_constant_knowing_parameters env (constant_type env cst) paramstyp
+
+let inductive_type_knowing_parameters env ind jl =
+  let (mib,mip) = lookup_mind_specif env ind in
+  let paramstyp = Array.map (fun j -> j.uj_type) jl in
+  Inductive.type_of_inductive_knowing_parameters env mip paramstyp
 
 (* The typing machine without information, without universes but with
    existential variables. *)
 
-let assumption_of_judgment env sigma j =
-  assumption_of_judgment env (j_nf_evar sigma j)
-
-let type_judgment env sigma j =
-  type_judgment env (j_nf_evar sigma j)
-
-
-let rec execute mf env sigma cstr =
+(* cstr must be in n.f. w.r.t. evars and execute returns a judgement
+   where both the term and type are in n.f. *)
+let rec execute env evd cstr =
   match kind_of_term cstr with
     | Meta n ->
-	error "execute: found a non-instanciated goal"
+        { uj_val = cstr; uj_type = nf_evar (evars_of evd) (meta_type evd n) }
 
     | Evar ev ->
-	let ty = Instantiate.existential_type sigma ev in
-	let jty = execute mf env sigma ty in
-	let jty = assumption_of_judgment env sigma jty in
+        let sigma = Evd.evars_of evd in
+	let ty = Evd.existential_type sigma ev in
+	let jty = execute env evd (nf_evar (evars_of evd) ty) in
+	let jty = assumption_of_judgment env jty in
 	{ uj_val = cstr; uj_type = jty }
 	
     | Rel n -> 
-	judge_of_relative env n
+	j_nf_evar (evars_of evd) (judge_of_relative env n)
 
     | Var id -> 
-        judge_of_variable env id
+        j_nf_evar (evars_of evd) (judge_of_variable env id)
 	  
     | Const c ->
-        make_judge cstr (constant_type env c)
+        make_judge cstr (nf_evar (evars_of evd) (type_of_constant env c))
 	  
     | Ind ind ->
-	make_judge cstr (type_of_inductive env ind)
+	make_judge cstr (nf_evar (evars_of evd) (type_of_inductive env ind))
 	  
     | Construct cstruct -> 
-	make_judge cstr (type_of_constructor env cstruct)
-	  
+	make_judge cstr
+          (nf_evar (evars_of evd) (type_of_constructor env cstruct))
+
     | Case (ci,p,c,lf) ->
-        let cj = execute mf env sigma c in
-        let pj = execute mf env sigma p in
-        let lfj = execute_array mf env sigma lf in
+        let cj = execute env evd c in
+        let pj = execute env evd p in
+        let lfj = execute_array env evd lf in
         let (j,_) = judge_of_case env ci pj cj lfj in
         j
   
     | Fix ((vn,i as vni),recdef) ->
-        if (not mf.fix) && array_exists (fun n -> n < 0) vn then
-          error "General Fixpoints not allowed";
-        let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in
+        let (_,tys,_ as recdef') = execute_recdef env evd recdef in
 	let fix = (vni,recdef') in
         check_fix env fix;
 	make_judge (mkFix fix) tys.(i)
 	  
     | CoFix (i,recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in
+        let (_,tys,_ as recdef') = execute_recdef env evd recdef in
         let cofix = (i,recdef') in
         check_cofix env cofix;
 	make_judge (mkCoFix cofix) tys.(i)
@@ -89,86 +97,95 @@ let rec execute mf env sigma cstr =
 	judge_of_type u
 	  
     | App (f,args) ->
-	let j = execute mf env sigma f in
-        let jl = execute_array mf env sigma args in
-	let (j,_) = judge_of_apply env j jl in
-	j
+        let jl = execute_array env evd args in
+	let j =
+	  match kind_of_term f with
+	    | Ind ind ->
+		(* Sort-polymorphism of inductive types *)
+		make_judge f
+		  (inductive_type_knowing_parameters env ind
+		    (jv_nf_evar (evars_of evd) jl))
+	    | Const cst -> 
+		(* Sort-polymorphism of inductive types *)
+		make_judge f
+		  (constant_type_knowing_parameters env cst
+		    (jv_nf_evar (evars_of evd) jl))
+	    | _ -> 
+		execute env evd f
+	in
+	fst (judge_of_apply env j jl)
 	    
     | Lambda (name,c1,c2) -> 
-        let j = execute mf env sigma c1 in
-	let var = type_judgment env sigma j in
+        let j = execute env evd c1 in
+	let var = type_judgment env j in
 	let env1 = push_rel (name,None,var.utj_val) env in
-        let j' = execute mf env1 sigma c2 in 
+        let j' = execute env1 evd c2 in 
         judge_of_abstraction env1 name var j'
 	  
     | Prod (name,c1,c2) ->
-        let j = execute mf env sigma c1 in
-        let varj = type_judgment env sigma j in
+        let j = execute env evd c1 in
+        let varj = type_judgment env j in
 	let env1 = push_rel (name,None,varj.utj_val) env in
-        let j' = execute mf env1 sigma c2 in
-        let varj' = type_judgment env1 sigma j' in
+        let j' = execute env1 evd c2 in
+        let varj' = type_judgment env1 j' in
 	judge_of_product env name varj varj'
 
      | LetIn (name,c1,c2,c3) ->
-        let j1 = execute mf env sigma c1 in
-        let j2 = execute mf env sigma c2 in
-        let j2 = type_judgment env sigma j2 in
-        let _ =  judge_of_cast env j1 j2 in
+        let j1 = execute env evd c1 in
+        let j2 = execute env evd c2 in
+        let j2 = type_judgment env j2 in
+        let _ =  judge_of_cast env j1 DEFAULTcast j2 in
         let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
-        let j3 = execute mf env1 sigma c3 in
+        let j3 = execute env1 evd c3 in
         judge_of_letin env name j1 j2 j3
   
-    | Cast (c,t) ->
-        let cj = execute mf env sigma c in
-        let tj = execute mf env sigma t in
-	let tj = type_judgment env sigma tj in
-        let j, _ = judge_of_cast env cj tj in
+    | Cast (c,k,t) ->
+        let cj = execute env evd c in
+        let tj = execute env evd t in
+	let tj = type_judgment env tj in
+        let j, _ = judge_of_cast env cj k tj in
 	j
 
-and execute_recdef mf env sigma (names,lar,vdef) =
-  let larj = execute_array mf env sigma lar in
-  let lara = Array.map (assumption_of_judgment env sigma) larj in
+and execute_recdef env evd (names,lar,vdef) =
+  let larj = execute_array env evd lar in
+  let lara = Array.map (assumption_of_judgment env) larj in
   let env1 = push_rec_types (names,lara,vdef) env in
-  let vdefj = execute_array mf env1 sigma vdef in
+  let vdefj = execute_array env1 evd vdef in
   let vdefv = Array.map j_val vdefj in
   let _ = type_fixpoint env1 names lara vdefj in
   (names,lara,vdefv)
 
-and execute_array mf env sigma v =
-  let jl = execute_list mf env sigma (Array.to_list v) in
-  Array.of_list jl
-
-and execute_list mf env sigma = function
-  | [] -> 
-      []
-  | c::r -> 
-      let j = execute mf env sigma c in 
-      let jr = execute_list mf env sigma r in
-      j::jr
-
+and execute_array env evd = Array.map (execute env evd)
 
-let safe_machine env sigma constr = 
-  let mf = { fix = false; nocheck = false } in
-  execute mf env sigma constr
+and execute_list env evd = List.map (execute env evd)
 
-let unsafe_machine env sigma constr =
-  let mf = { fix = false; nocheck = true } in
-  execute mf env sigma constr
+let mcheck env evd c t =
+  let sigma = Evd.evars_of evd in
+  let j = execute env evd (nf_evar sigma c) in
+  if not (is_conv_leq env sigma j.uj_type t) then
+    error_actual_type env j (nf_evar sigma t)
 
 (* Type of a constr *)
-
-let type_of env sigma c = 
-  let j = safe_machine env sigma c in 
+ 
+let mtype_of env evd c =
+  let j = execute env evd (nf_evar (evars_of evd) c) in
   (* No normalization: it breaks Pattern! *)
   (*nf_betaiota*) (body_of_type j.uj_type)
 
-(* The typed type of a judgment. *)
+let msort_of env evd c =
+  let j = execute env evd (nf_evar (evars_of evd) c) in
+  let a = type_judgment env j in
+  a.utj_type
 
-let execute_type env sigma constr = 
-  let j = execute { fix=false; nocheck=true } env sigma constr in
-  assumption_of_judgment env sigma j
+let type_of env sigma c =
+  mtype_of env (Evd.create_evar_defs sigma) c
+let sort_of env sigma c =
+  msort_of env (Evd.create_evar_defs sigma) c
+let check env sigma c   =
+  mcheck env (Evd.create_evar_defs sigma) c
 
-let execute_rec_type env sigma constr = 
-  let j = execute { fix=false; nocheck=false } env sigma constr in
-  assumption_of_judgment env sigma j
+(* The typed type of a judgment. *)
 
+let mtype_of_type env evd constr =
+  let j = execute env evd (nf_evar (evars_of evd) constr) in
+  assumption_of_judgment env j
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index 4ea74dcd..c9d7d572 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typing.mli,v 1.7.14.1 2004/07/16 19:30:47 herbelin Exp $ i*)
+(*i $Id: typing.mli 6113 2004-09-17 20:28:19Z barras $ i*)
 
 (*i*)
 open Term
@@ -17,11 +17,18 @@ open Evd
 (* This module provides the typing machine with existential variables
    (but without universes). *)
 
-val unsafe_machine : env -> evar_map -> constr -> unsafe_judgment
-
-val type_of : env -> evar_map -> constr -> constr
-
-val execute_type : env -> evar_map -> constr -> types
-
-val execute_rec_type : env -> evar_map -> constr -> types
-
+(* Typecheck a term and return its type *)
+val type_of : env -> evar_map -> constr -> types
+(* Typecheck a type and return its sort *)
+val sort_of : env -> evar_map -> types -> sorts
+(* Typecheck a term has a given type (assuming the type is OK *)
+val check   : env -> evar_map -> constr -> types -> unit
+ 
+(* The same but with metas... *)
+val mtype_of : env -> evar_defs -> constr -> types
+val msort_of : env -> evar_defs -> types -> sorts
+val mcheck   : env -> evar_defs -> constr -> types -> unit
+val meta_type : evar_defs -> metavariable -> types
+ 
+(* unused typing function... *)
+val mtype_of_type : env -> evar_defs -> types -> types
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
new file mode 100644
index 00000000..5fb8054f
--- /dev/null
+++ b/pretyping/unification.ml
@@ -0,0 +1,499 @@
+(************************************************************************)
+(*  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: unification.ml 9517 2007-01-22 17:37:58Z herbelin $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Environ
+open Evd
+open Reduction
+open Reductionops
+open Rawterm
+open Pattern
+open Evarutil
+open Pretype_errors
+
+(* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
+   gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *)
+
+let abstract_scheme env c l lname_typ =
+  List.fold_left2 
+    (fun t (locc,a) (na,_,ta) ->
+       let na = match kind_of_term a with Var id -> Name id | _ -> na in
+       if occur_meta ta then error "cannot find a type for the generalisation"
+       else if occur_meta a then lambda_name env (na,ta,t)
+       else lambda_name env (na,ta,subst_term_occ locc a t))
+    c
+    (List.rev l)
+    lname_typ
+
+let abstract_list_all env sigma typ c l =
+  let ctxt,_ = decomp_n_prod env sigma (List.length l) typ in
+  let p = abstract_scheme env c (List.map (function a -> [],a) l) ctxt in 
+  try 
+    if is_conv_leq env sigma (Typing.type_of env sigma p) typ then p
+    else error "abstract_list_all"
+  with UserError _ ->
+    raise (PretypeError (env,CannotGeneralize typ))
+
+(**)
+
+let solve_pattern_eqn_array env f l c (metasubst,evarsubst) =
+  match kind_of_term f with
+    | Meta k -> 
+	(k,solve_pattern_eqn env (Array.to_list l) c)::metasubst,evarsubst
+    | Evar ev ->
+      (* Currently unused: incompatible with eauto/eassumption backtracking *)
+	metasubst,(f,solve_pattern_eqn env (Array.to_list l) c)::evarsubst
+    | _ -> assert false
+
+(*******************************)
+
+(* Unification à l'ordre 0 de m et n: [unify_0 env sigma cv_pb m n]
+   renvoie deux listes:
+
+   metasubst:(int*constr)list    récolte les instances des (Meta k)
+   evarsubst:(constr*constr)list récolte les instances des (Const "?k")
+
+   Attention : pas d'unification entre les différences instances d'une
+   même meta ou evar, il peut rester des doublons *)
+
+(* Unification order: *)
+(* Left to right: unifies first argument and then the other arguments *)
+(*let unify_l2r x = List.rev x
+(* Right to left: unifies last argument and then the other arguments *)
+let unify_r2l x = x
+
+let sort_eqns = unify_r2l
+*)
+
+let unify_0 env sigma cv_pb mod_delta m n =
+  let trivial_unify pb substn m n =
+    if (not(occur_meta m)) && 
+      (if mod_delta then is_fconv pb env sigma m n else eq_constr m n) 
+    then substn
+    else error_cannot_unify env sigma (m,n) in
+  let rec unirec_rec curenv pb ((metasubst,evarsubst) as substn) curm curn =
+    let cM = Evarutil.whd_castappevar sigma curm
+    and cN = Evarutil.whd_castappevar sigma curn in 
+      match (kind_of_term cM,kind_of_term cN) with
+	| Meta k1, Meta k2 ->
+	    if k1 < k2 
+	    then (k1,cN)::metasubst,evarsubst
+	    else if k1 = k2 then substn else (k2,cM)::metasubst,evarsubst
+	| Meta k, _    -> 
+	    (* Here we check that [cN] does not contain any local variables *)
+	    if (closedn (nb_rel env) cN)
+	    then (k,cN)::metasubst,evarsubst
+	    else error_cannot_unify_local curenv sigma (curenv,m,n,cN)
+	| _, Meta k    -> 
+	    (* Here we check that [cM] does not contain any local variables *)
+	    if (closedn (nb_rel env) cM) 
+	    then (k,cM)::metasubst,evarsubst
+	    else error_cannot_unify_local curenv sigma (curenv,m,n,cM)
+	| Evar _, _ -> metasubst,((cM,cN)::evarsubst)
+	| _, Evar _ -> metasubst,((cN,cM)::evarsubst)
+	| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
+	    unirec_rec (push_rel_assum (na,t1) curenv) CONV 
+	      (unirec_rec curenv CONV substn t1 t2) c1 c2
+	| Prod (na,t1,c1), Prod (_,t2,c2) ->
+	    unirec_rec (push_rel_assum (na,t1) curenv) pb 
+	      (unirec_rec curenv CONV substn t1 t2) c1 c2
+	| LetIn (_,b,_,c), _ -> unirec_rec curenv  pb substn (subst1 b c) cN
+	| _, LetIn (_,b,_,c) -> unirec_rec curenv  pb substn cM (subst1 b c)
+	    
+	| App (f1,l1), _ when
+	    isMeta f1 & is_unification_pattern f1 l1 & not (dependent f1 cN) ->
+	      solve_pattern_eqn_array curenv f1 l1 cN substn
+
+	| _, App (f2,l2) when
+	    isMeta f2 & is_unification_pattern f2 l2 & not (dependent f2 cM) ->
+	      solve_pattern_eqn_array curenv f2 l2 cM substn
+
+	| App (f1,l1), App (f2,l2) ->
+	      let len1 = Array.length l1
+	      and len2 = Array.length l2 in
+              let (f1,l1,f2,l2) =
+		if len1 = len2 then (f1,l1,f2,l2)
+		else if len1 < len2 then
+		  let extras,restl2 = array_chop (len2-len1) l2 in 
+		    (f1, l1, appvect (f2,extras), restl2)
+		else 
+		  let extras,restl1 = array_chop (len1-len2) l1 in 
+		    (appvect (f1,extras), restl1, f2, l2) in
+		(try
+		    array_fold_left2 (unirec_rec curenv CONV)
+		      (unirec_rec curenv CONV substn f1 f2) l1 l2
+		  with ex when precatchable_exception ex ->
+		    trivial_unify pb substn cM cN)
+	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
+            array_fold_left2 (unirec_rec curenv CONV)
+	      (unirec_rec curenv CONV 
+		  (unirec_rec curenv CONV substn p1 p2) c1 c2) cl1 cl2
+	| _ -> trivial_unify pb substn cM cN
+  in
+    if (not(occur_meta m)) &&
+      (if mod_delta then is_fconv cv_pb env sigma m n else eq_constr m n)
+    then 
+      ([],[])
+    else 
+      let (mc,ec) = unirec_rec env cv_pb ([],[]) m n in
+	((*sort_eqns*) mc, (*sort_eqns*) ec)
+
+
+(* Unification
+ *
+ * Procedure:
+ * (1) The function [unify mc wc M N] produces two lists:
+ *     (a) a list of bindings Meta->RHS
+ *     (b) a list of bindings EVAR->RHS
+ *
+ * The Meta->RHS bindings cannot themselves contain
+ * meta-vars, so they get applied eagerly to the other
+ * bindings.  This may or may not close off all RHSs of
+ * the EVARs.  For each EVAR whose RHS is closed off,
+ * we can just apply it, and go on.  For each which
+ * is not closed off, we need to do a mimick step -
+ * in general, we have something like:
+ *
+ *      ?X == (c e1 e2 ... ei[Meta(k)] ... en)
+ *
+ * so we need to do a mimick step, converting ?X
+ * into
+ *
+ *      ?X -> (c ?z1 ... ?zn)
+ *
+ * of the proper types.  Then, we can decompose the
+ * equation into
+ *
+ *      ?z1 --> e1
+ *          ...
+ *      ?zi --> ei[Meta(k)]
+ *          ...
+ *      ?zn --> en
+ *
+ * and keep on going.  Whenever we find that a R.H.S.
+ * is closed, we can, as before, apply the constraint
+ * directly.  Whenever we find an equation of the form:
+ *
+ *      ?z -> Meta(n)
+ *
+ * we can reverse the equation, put it into our metavar
+ * substitution, and keep going.
+ *
+ * The most efficient mimick possible is, for each
+ * Meta-var remaining in the term, to declare a
+ * new EVAR of the same type.  This is supposedly
+ * determinable from the clausale form context -
+ * we look up the metavar, take its type there,
+ * and apply the metavar substitution to it, to
+ * close it off.  But this might not always work,
+ * since other metavars might also need to be resolved. *)
+
+let applyHead env evd n c  = 
+  let rec apprec n c cty evd =
+    if n = 0 then 
+      (evd, c)
+    else 
+      match kind_of_term (whd_betadeltaiota env (evars_of evd) cty) with
+        | Prod (_,c1,c2) ->
+            let (evd',evar) = Evarutil.new_evar evd env c1 in
+	    apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
+	| _ -> error "Apply_Head_Then"
+  in 
+  apprec n c (Typing.type_of env (evars_of evd) c) evd
+
+let is_mimick_head f =
+  match kind_of_term f with
+      (Const _|Var _|Rel _|Construct _|Ind _) -> true
+    | _ -> false
+ 
+(* [w_merge env sigma b metas evars] merges common instances in metas
+   or in evars, possibly generating new unification problems; if [b]
+   is true, unification of types of metas is required *)
+
+let w_merge env with_types mod_delta metas evars evd =
+  let ty_metas = ref [] in
+  let ty_evars = ref [] in
+  let rec w_merge_rec evd metas evars =
+    match (evars,metas) with
+      | ([], []) -> evd
+
+      | ((lhs,rhs)::t, metas) ->
+      (match kind_of_term rhs with
+
+	| Meta k -> w_merge_rec evd ((k,lhs)::metas) t
+
+	| krhs ->
+        (match kind_of_term lhs with
+
+	  | Evar (evn,_ as ev) ->
+    	      if is_defined_evar evd ev then
+		let (metas',evars') =
+                  unify_0 env (evars_of evd) CONV mod_delta rhs lhs in
+		w_merge_rec evd (metas'@metas) (evars'@t)
+    	      else begin
+		let rhs' = 
+		  if occur_meta rhs then subst_meta metas rhs else rhs 
+		in
+		if occur_evar evn rhs' then
+                  error "w_merge: recursive equation";
+                match krhs with
+		  | App (f,cl) when is_mimick_head f ->
+		      (try 
+		        w_merge_rec (fst (evar_define env ev rhs' evd)) metas t
+		      with ex when precatchable_exception ex ->
+                        let evd' =
+                          mimick_evar evd mod_delta f (Array.length cl) evn in
+			w_merge_rec evd' metas evars)
+                  | _ ->
+                      (* ensure tail recursion in non-mimickable case! *)
+		      w_merge_rec (fst (evar_define env ev rhs' evd)) metas t
+	      end
+
+	  | _ -> anomaly "w_merge_rec"))
+
+      | ([], (mv,n)::t) ->
+    	  if meta_defined evd mv then
+            let (metas',evars') =
+              unify_0 env (evars_of evd) CONV mod_delta
+               (meta_fvalue evd mv).rebus n in
+            w_merge_rec evd (metas'@t) evars'
+    	  else
+            begin
+	      if with_types (* or occur_meta mvty *) then
+	        (let mvty = Typing.meta_type evd mv in
+		try 
+                  let sigma = evars_of evd in
+                  (* why not typing with the metamap ? *)
+		  let nty = Typing.type_of env sigma (nf_meta evd n) in
+		  let (mc,ec) = unify_0 env sigma CUMUL mod_delta nty mvty in
+                  ty_metas := mc @ !ty_metas;
+                  ty_evars := ec @ !ty_evars
+		with e when precatchable_exception e -> ());
+              let evd' = meta_assign mv n evd in
+	      w_merge_rec evd' t []
+            end
+
+  and mimick_evar evd mod_delta hdc nargs sp =
+    let ev = Evd.find (evars_of evd) sp in
+    let sp_env = Global.env_of_context ev.evar_hyps in
+    let (evd', c) = applyHead sp_env evd nargs hdc in
+    let (mc,ec) =
+      unify_0 sp_env (evars_of evd') CUMUL mod_delta
+        (Retyping.get_type_of sp_env (evars_of evd') c) ev.evar_concl in
+    let evd'' = w_merge_rec evd' mc ec in
+    if (evars_of evd') == (evars_of evd'')
+    then Evd.evar_define sp c evd''
+    else Evd.evar_define sp (Evarutil.nf_evar (evars_of evd'') c) evd'' in
+
+  (* merge constraints *)
+  let evd' = w_merge_rec evd metas evars in
+  if with_types then
+    (* merge constraints about types: if they fail, don't worry *)
+    try w_merge_rec evd' !ty_metas !ty_evars
+    with e when precatchable_exception e -> evd'
+  else
+    evd'
+
+(* [w_unify env evd M N]
+   performs a unification of M and N, generating a bunch of
+   unification constraints in the process.  These constraints
+   are processed, one-by-one - they may either generate new
+   bindings, or, if there is already a binding, new unifications,
+   which themselves generate new constraints.  This continues
+   until we get failure, or we run out of constraints.
+   [clenv_typed_unify M N clenv] expects in addition that expected
+   types of metavars are unifiable with the types of their instances    *)
+
+let w_unify_core_0 env with_types cv_pb mod_delta m n evd =
+  let (mc,ec) = unify_0 env (evars_of evd) cv_pb mod_delta m n in 
+  w_merge env with_types mod_delta mc ec evd
+
+let w_unify_0 env = w_unify_core_0 env false
+let w_typed_unify env = w_unify_core_0 env true
+
+
+(* takes a substitution s, an open term op and a closed term cl
+   try to find a subterm of cl which matches op, if op is just a Meta
+   FAIL because we cannot find a binding *)
+
+let iter_fail f a =
+  let n = Array.length a in 
+  let rec ffail i =
+    if i = n then error "iter_fail" 
+    else
+      try f a.(i) 
+      with ex when precatchable_exception ex -> ffail (i+1)
+  in ffail 0
+
+(* Tries to find an instance of term [cl] in term [op].
+   Unifies [cl] to every subterm of [op] until it finds a match.
+   Fails if no match is found *)
+let w_unify_to_subterm env ?(mod_delta=true) (op,cl) evd =
+  let rec matchrec cl =
+    let cl = strip_outer_cast cl in
+    (try 
+       if closed0 cl 
+       then w_unify_0 env CONV mod_delta op cl evd,cl
+       else error "Bound 1"
+     with ex when precatchable_exception ex ->
+       (match kind_of_term cl with 
+	  | App (f,args) ->
+	      let n = Array.length args in
+	      assert (n>0);
+	      let c1 = mkApp (f,Array.sub args 0 (n-1)) in
+	      let c2 = args.(n-1) in
+	      (try 
+		 matchrec c1
+	       with ex when precatchable_exception ex -> 
+		 matchrec c2)
+          | Case(_,_,c,lf) -> (* does not search in the predicate *)
+	       (try 
+		 matchrec c
+	       with ex when precatchable_exception ex -> 
+		 iter_fail matchrec lf)
+	  | LetIn(_,c1,_,c2) -> 
+	       (try 
+		 matchrec c1
+	       with ex when precatchable_exception ex -> 
+		 matchrec c2)
+
+	  | Fix(_,(_,types,terms)) -> 
+	       (try 
+		 iter_fail matchrec types
+	       with ex when precatchable_exception ex -> 
+		 iter_fail matchrec terms)
+	
+	  | CoFix(_,(_,types,terms)) -> 
+	       (try 
+		 iter_fail matchrec types
+	       with ex when precatchable_exception ex -> 
+		 iter_fail matchrec terms)
+
+          | Prod (_,t,c) ->
+	      (try 
+		 matchrec t 
+	       with ex when precatchable_exception ex -> 
+		 matchrec c)
+          | Lambda (_,t,c) ->
+	      (try 
+		 matchrec t 
+	       with ex when precatchable_exception ex -> 
+		 matchrec c)
+          | _ -> error "Match_subterm")) 
+  in 
+  try matchrec cl
+  with ex when precatchable_exception ex ->
+    raise (PretypeError (env,NoOccurrenceFound op))
+
+let w_unify_to_subterm_list env mod_delta allow_K oplist t evd = 
+  List.fold_right 
+    (fun op (evd,l) ->
+      if isMeta op then
+	if allow_K then (evd,op::l)
+	else error "Match_subterm"
+      else if occur_meta op then
+        let (evd',cl) =
+          try 
+	    (* This is up to delta for subterms w/o metas ... *)
+	    w_unify_to_subterm env ~mod_delta (strip_outer_cast op,t) evd
+          with PretypeError (env,NoOccurrenceFound _) when allow_K -> (evd,op)
+        in 
+	(evd',cl::l)
+      else if allow_K or dependent op t then
+	(evd,op::l)
+      else
+	(* This is not up to delta ... *)
+	raise (PretypeError (env,NoOccurrenceFound op)))
+    oplist 
+    (evd,[])
+
+let secondOrderAbstraction env mod_delta allow_K typ (p, oplist) evd =
+  let sigma = evars_of evd in
+  let (evd',cllist) =
+    w_unify_to_subterm_list env mod_delta allow_K oplist typ evd in
+  let typp = Typing.meta_type evd' p in
+  let pred = abstract_list_all env sigma typp typ cllist in
+  w_unify_0 env CONV mod_delta (mkMeta p) pred evd'
+
+let w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd =
+  let c1, oplist1 = whd_stack ty1 in
+  let c2, oplist2 = whd_stack ty2 in
+  match kind_of_term c1, kind_of_term c2 with
+    | Meta p1, _ ->
+        (* Find the predicate *)
+	let evd' =
+          secondOrderAbstraction env mod_delta allow_K ty2 (p1,oplist1) evd in 
+        (* Resume first order unification *)
+	w_unify_0 env cv_pb mod_delta (nf_meta evd' ty1) ty2 evd'
+    | _, Meta p2 ->
+        (* Find the predicate *)
+	let evd' =
+          secondOrderAbstraction env mod_delta allow_K ty1 (p2, oplist2) evd in 
+        (* Resume first order unification *)
+	w_unify_0 env cv_pb mod_delta ty1 (nf_meta evd' ty2) evd'
+    | _ -> error "w_unify2"
+
+
+(* The unique unification algorithm works like this: If the pattern is
+   flexible, and the goal has a lambda-abstraction at the head, then
+   we do a first-order unification.
+
+   If the pattern is not flexible, then we do a first-order
+   unification, too.
+
+   If the pattern is flexible, and the goal doesn't have a
+   lambda-abstraction head, then we second-order unification. *)
+
+(* We decide here if first-order or second-order unif is used for Apply *)
+(* We apply a term of type (ai:Ai)C and try to solve a goal C'          *)
+(* The type C is in clenv.templtyp.rebus with a lot of Meta to solve    *)
+
+(* 3-4-99 [HH] New fo/so choice heuristic :
+   In case we have to unify (Meta(1) args) with ([x:A]t args')
+   we first try second-order unification and if it fails first-order.
+   Before, second-order was used if the type of Meta(1) and [x:A]t was
+   convertible and first-order otherwise. But if failed if e.g. the type of
+   Meta(1) had meta-variables in it. *)
+let w_unify allow_K env cv_pb ?(mod_delta=true) ty1 ty2 evd =
+  let hd1,l1 = whd_stack ty1 in
+  let hd2,l2 = whd_stack ty2 in
+    match kind_of_term hd1, l1<>[], kind_of_term hd2, l2<>[] with
+      (* Pattern case *)
+      | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true)
+	  when List.length l1 = List.length l2 ->
+	  (try 
+	      w_typed_unify env cv_pb mod_delta ty1 ty2 evd
+	    with ex when precatchable_exception ex -> 
+	      try 
+		w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd
+	      with PretypeError (env,NoOccurrenceFound c) as e -> raise e
+		| ex when precatchable_exception ex -> 
+		    error "Cannot solve a second-order unification problem")
+	    
+      (* Second order case *)
+      | (Meta _, true, _, _ | _, _, Meta _, true) -> 
+	  (try 
+	      w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd
+	    with PretypeError (env,NoOccurrenceFound c) as e -> raise e
+	      | ex when precatchable_exception ex -> 
+		  try 
+		    w_typed_unify env cv_pb mod_delta ty1 ty2 evd
+		  with ex when precatchable_exception ex -> 
+		    error "Cannot solve a second-order unification problem")
+	    
+      (* General case: try first order *)
+      | _ -> w_unify_0 env cv_pb mod_delta ty1 ty2 evd
+
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
new file mode 100644
index 00000000..6be530be
--- /dev/null
+++ b/pretyping/unification.mli
@@ -0,0 +1,33 @@
+(************************************************************************)
+(*  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: unification.mli 6142 2004-09-27 19:33:01Z sacerdot $ i*)
+
+(*i*)
+open Term
+open Environ
+open Evd
+(*i*)
+
+(* The "unique" unification fonction *)
+val w_unify :
+  bool -> env -> conv_pb -> ?mod_delta:bool -> constr -> constr -> evar_defs -> evar_defs
+
+(* [w_unify_to_subterm env (c,t) m] performs unification of [c] with a
+   subterm of [t]. Constraints are added to [m] and the matched
+   subterm of [t] is also returned. *)
+val w_unify_to_subterm :
+  env -> ?mod_delta:bool -> constr * constr -> evar_defs -> evar_defs * constr
+
+(*i This should be in another module i*)
+
+(* [abstract_list_all env sigma t c l]                     *)
+(* abstracts the terms in l over c to get a term of type t *)
+(* (exported for inv.ml) *)
+val abstract_list_all :
+  env -> evar_map -> constr -> constr -> constr list -> constr
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
new file mode 100644
index 00000000..46d67406
--- /dev/null
+++ b/pretyping/vnorm.ml
@@ -0,0 +1,270 @@
+open Names
+open Declarations
+open Term
+open Environ
+open Inductive
+open Reduction 
+open Vm
+
+(*******************************************)
+(* Calcul de la forme normal d'un terme    *)
+(*******************************************)
+
+let crazy_type = mkSet 
+
+let decompose_prod env t =
+  let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+  if name = Anonymous then (Name (id_of_string "x"),dom,codom)
+  else res
+
+exception Find_at of int
+
+(* rend le numero du constructeur correspondant au tag [tag],
+   [cst] = true si c'est un constructeur constant *)
+
+let invert_tag cst tag reloc_tbl =
+  try 
+    for j = 0 to Array.length reloc_tbl - 1 do
+      let tagj,arity = reloc_tbl.(j) in
+      if tag = tagj && (cst && arity = 0 || not(cst || arity = 0)) then
+	raise (Find_at j)
+      else ()
+    done;raise Not_found 
+  with Find_at j -> (j+1)   
+             (* Argggg, ces constructeurs de ... qui commencent a 1*)
+
+let find_rectype_a env c =
+  let (t, l) = 
+    let t = whd_betadeltaiota env c in
+    try destApp t with _ -> (t,[||]) in
+  match kind_of_term t with
+  | Ind ind -> (ind, l)
+  | _ -> raise Not_found
+
+(* Instantiate inductives and parameters in constructor type *)
+
+let type_constructor mind mib typ params = 
+  let s = ind_subst mind mib in
+  let ctyp = substl s typ in
+  let nparams = Array.length params in
+  if nparams = 0 then ctyp
+  else
+    let _,ctyp = decompose_prod_n nparams ctyp in   
+    substl (List.rev (Array.to_list params)) ctyp
+
+let construct_of_constr const env tag typ =
+  let (mind,_ as ind), allargs = find_rectype_a env typ in
+  let mib,mip = lookup_mind_specif env ind in
+  let nparams = mib.mind_nparams in
+  let i = invert_tag const tag mip.mind_reloc_tbl in
+  let params = Array.sub allargs 0 nparams in
+  let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in
+  (mkApp(mkConstruct(ind,i), params), ctyp)
+
+let construct_of_constr_const env tag typ = 
+  fst (construct_of_constr true env tag typ)
+
+let construct_of_constr_block = construct_of_constr false
+
+let constr_type_of_idkey env idkey =
+  match idkey with
+  | ConstKey cst ->
+      mkConst cst, Typeops.type_of_constant env cst
+  | VarKey id -> 
+      let (_,_,ty) = lookup_named id env in 
+      mkVar id, ty
+  | RelKey i -> 
+      let n = (nb_rel env - i) in
+      let (_,_,ty) = lookup_rel n env in
+      mkRel n, lift n ty
+
+let type_of_ind env ind = 
+  type_of_inductive env (Inductive.lookup_mind_specif env ind)
+
+let build_branches_type env (mind,_ as _ind) mib mip params dep p =
+  let rtbl = mip.mind_reloc_tbl in
+  (* [build_one_branch i cty] construit le type de la ieme branche (commence
+     a 0) et les lambda correspondant aux realargs *)
+  let build_one_branch i cty =
+    let typi = type_constructor mind mib cty params in
+    let decl,indapp = Term.decompose_prod typi in
+    let ind,cargs = find_rectype_a env indapp in
+    let nparams = Array.length params in
+    let carity = snd (rtbl.(i)) in
+    let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in
+    let codom = 
+      let papp = mkApp(p,crealargs) in
+      if dep then
+	let cstr = ith_constructor_of_inductive ind (i+1) in
+        let relargs = Array.init carity (fun i -> mkRel (carity-i)) in
+	let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in
+	mkApp(papp,[|dep_cstr|])
+      else papp
+    in 
+    decl, codom
+  in Array.mapi build_one_branch mip.mind_nf_lc
+
+let build_case_type dep p realargs c = 
+  if dep then mkApp(mkApp(p, realargs), [|c|])
+  else mkApp(p, realargs)
+
+(* La fonction de normalisation *)
+
+let rec nf_val env v t = nf_whd env (whd_val v) t 
+
+and nf_vtype env v =  nf_val env v crazy_type
+
+and nf_whd env whd typ =
+  match whd with
+  | Vsort s -> mkSort s
+  | Vprod p ->
+      let dom = nf_vtype env (dom p) in
+      let name = Name (id_of_string "x") in
+      let vc = body_of_vfun (nb_rel env) (codom p) in
+      let codom = nf_vtype (push_rel (name,None,dom) env) vc  in      
+      mkProd(name,dom,codom)	  
+  | Vfun f -> nf_fun env f typ
+  | Vfix(f,None) -> nf_fix env f
+  | Vfix(f,Some vargs) -> fst (nf_fix_app env f vargs)
+  | Vcofix(cf,_,None) -> nf_cofix env cf 
+  | Vcofix(cf,_,Some vargs) -> 
+      let cfd = nf_cofix env cf in
+      let i,(_,ta,_) = destCoFix cfd in
+      let t = ta.(i) in
+      let _, args = nf_args env vargs t in
+      mkApp(cfd,args) 
+  | Vconstr_const n -> construct_of_constr_const env n typ
+  | Vconstr_block b ->
+      let capp,ctyp = construct_of_constr_block env (btag b) typ in
+      let args = nf_bargs env b ctyp in
+      mkApp(capp,args)
+  | Vatom_stk(Aid idkey, stk) ->
+      let c,typ = constr_type_of_idkey env idkey in
+      nf_stk env c typ stk
+  | Vatom_stk(Aiddef(idkey,v), stk) ->
+      nf_whd env (whd_stack v stk) typ
+  | Vatom_stk(Aind ind, stk) ->
+      nf_stk env (mkInd ind) (type_of_ind env ind) stk 
+	
+and nf_stk env c t stk  =
+  match stk with
+  | [] -> c
+  | Zapp vargs :: stk ->
+      let t, args = nf_args env vargs t in
+      nf_stk env (mkApp(c,args)) t stk 
+  | Zfix (f,vargs) :: stk ->  
+      let fa, typ = nf_fix_app env f vargs in
+      let _,_,codom = decompose_prod env typ in
+      nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk
+  | Zswitch sw :: stk -> 
+      let (mind,_ as ind),allargs = find_rectype_a env t in
+      let (mib,mip) = Inductive.lookup_mind_specif env ind in
+      let nparams = mib.mind_nparams in
+      let params,realargs = Util.array_chop nparams allargs in
+      let pT = 
+	hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in
+      let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in
+      (* Calcul du type des branches *)
+      let btypes = build_branches_type env ind mib mip params dep p in
+      (* calcul des branches *)
+      let bsw = branch_of_switch (nb_rel env) sw in
+      let mkbranch i (n,v) =
+	let decl,codom = btypes.(i) in
+	let env = 
+	  List.fold_right 
+	    (fun (name,t) env -> push_rel (name,None,t) env) decl env in
+	let b = nf_val env v codom in
+	compose_lam decl b 
+      in 
+      let branchs = Array.mapi mkbranch bsw in
+      let tcase = build_case_type dep p realargs c in
+      let ci = case_info sw in
+      nf_stk env (mkCase(ci, p, c, branchs)) tcase stk
+
+and nf_predicate env ind mip params v pT =
+  match whd_val v, kind_of_term pT with
+  | Vfun f, Prod _ ->
+      let k = nb_rel env in
+      let vb = body_of_vfun k f in
+      let name,dom,codom = decompose_prod env pT in
+      let dep,body = 
+	nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
+      dep, mkLambda(name,dom,body)
+  | Vfun f, _ -> 
+      let k = nb_rel env in
+      let vb = body_of_vfun k f in
+      let name = Name (id_of_string "c") in
+      let n = mip.mind_nrealargs in
+      let rargs = Array.init n (fun i -> mkRel (n-i)) in
+      let dom = mkApp(mkApp(mkInd ind,params),rargs) in
+      let body = nf_vtype (push_rel (name,None,dom) env) vb in
+      true, mkLambda(name,dom,body)
+  | _, _ -> false, nf_val env v crazy_type
+	
+and nf_args env vargs t =
+  let t = ref t in
+  let len = nargs vargs in
+  let args = 
+    Array.init len 
+      (fun i ->
+	let _,dom,codom = decompose_prod env !t in
+	let c = nf_val env (arg vargs i) dom in
+	t := subst1 c codom; c) in
+  !t,args
+
+and nf_bargs env b t =
+  let t = ref t in
+  let len = bsize b in
+  let args =
+    Array.init len 
+      (fun i -> 
+	let _,dom,codom = decompose_prod env !t in
+	let c = nf_val env (bfield b i) dom in
+	t := subst1 c codom; c) in
+  args
+
+and nf_fun env f typ =
+  let k = nb_rel env in
+  let vb = body_of_vfun k f in
+  let name,dom,codom = decompose_prod env typ in
+  let body = nf_val (push_rel (name,None,dom) env) vb codom in
+  mkLambda(name,dom,body)
+
+and nf_fix env f =
+  let init = current_fix f in
+  let rec_args = rec_args f in
+  let k = nb_rel env in
+  let vb, vt = reduce_fix k f in
+  let ndef = Array.length vt in
+  let ft = Array.map (fun v -> nf_val env v crazy_type) vt in
+  let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in
+  let env = push_rec_types (name,ft,ft) env in 
+  let fb = Util.array_map2 (fun v t -> nf_fun env v t) vb ft in
+  mkFix ((rec_args,init),(name,ft,fb))
+      
+and nf_fix_app env f vargs =
+  let fd = nf_fix env f in
+  let (_,i),(_,ta,_) = destFix fd in
+  let t = ta.(i) in
+  let t, args = nf_args env vargs t in
+  mkApp(fd,args),t
+  
+and nf_cofix env cf =
+  let init = current_cofix cf in
+  let k = nb_rel env in
+  let vb,vt = reduce_cofix k cf in
+  let ndef = Array.length vt in
+  let cft = Array.map (fun v -> nf_val env v crazy_type) vt in
+  let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in
+  let env = push_rec_types (name,cft,cft) env in 
+  let cfb = Util.array_map2 (fun v t -> nf_val env v t) vb cft in
+  mkCoFix (init,(name,cft,cfb))
+  
+let cbv_vm env c t  =
+  let transp = transp_values () in
+  if not transp then set_transp_values true; 
+  let v = Vconv.val_of_constr env c in
+  let c = nf_val env v t in
+  if not transp then set_transp_values false; 
+  c
+  
diff --git a/parsing/g_zsyntaxnew.mli b/pretyping/vnorm.mli
index 51bb6d41..2ea94bfb 100644
--- a/parsing/g_zsyntaxnew.mli
+++ b/pretyping/vnorm.mli
@@ -6,6 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_zsyntaxnew.mli,v 1.1.2.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+(*i*)
+open Names
+open Term
+open Environ
+open Reduction
+(*i*)
+
+(*s Reduction functions *)
+val cbv_vm : env -> constr -> types -> constr
 
-(* Nice syntax for integers. *)
diff --git a/proofs/clenv.ml b/proofs/clenv.ml
deleted file mode 100644
index 999bb651..00000000
--- a/proofs/clenv.ml
+++ /dev/null
@@ -1,1175 +0,0 @@
-(************************************************************************)
-(*  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: clenv.ml,v 1.97.2.4 2004/12/06 12:59:11 herbelin Exp $ *)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Sign
-open Instantiate
-open Environ
-open Evd
-open Proof_type
-open Refiner
-open Proof_trees
-open Logic
-open Reductionops
-open Tacmach
-open Evar_refiner
-open Rawterm
-open Pattern
-open Tacexpr
-
-(* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
-   gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *)
-
-let abstract_scheme env c l lname_typ =
-  List.fold_left2 
-    (fun t (locc,a) (na,_,ta) ->
-       let na = match kind_of_term a with Var id -> Name id | _ -> na in
-       if occur_meta ta then error "cannot find a type for the generalisation"
-       else if occur_meta a then lambda_name env (na,ta,t)
-       else lambda_name env (na,ta,subst_term_occ locc a t))
-    c
-    (List.rev l)
-    lname_typ
-
-let abstract_list_all env sigma typ c l =
-  let ctxt,_ = decomp_n_prod env sigma (List.length l) typ in
-  let p = abstract_scheme env c (List.map (function a -> [],a) l) ctxt in 
-  try 
-    if is_conv_leq env sigma (Typing.type_of env sigma p) typ then p
-    else error "abstract_list_all"
-  with UserError _ ->
-    raise (RefinerError (CannotGeneralize typ))
-
-(* Generator of metavariables *)
-let new_meta =
-  let meta_ctr = ref 0 in
-  fun () -> incr meta_ctr; !meta_ctr
-
-(* replaces a mapping of existentials into a mapping of metas.
-   Problem if an evar appears in the type of another one (pops anomaly) *)
-let exist_to_meta sigma (emap, c) =
-  let metamap = ref [] in
-  let change_exist evar =
-    let ty = nf_betaiota (nf_evar emap (existential_type emap evar)) in
-    let n = new_meta() in
-    metamap := (n, ty) :: !metamap;
-    mkCast (mkMeta n, ty) in
-  let rec replace c =
-    match kind_of_term c with
-        Evar (k,_ as ev) when not (Evd.in_dom sigma k) -> change_exist ev
-      | _ -> map_constr replace c in
-  (!metamap, replace c)
-
-module Metaset = Intset
-
-module Metamap = Intmap
-
-let meta_exists p s = Metaset.fold (fun x b -> (p x) || b) s false
-
-let metamap_in_dom x m =
-  try let _ = Metamap.find x m in true with Not_found -> false
-
-let metamap_to_list m =
-  Metamap.fold (fun n v l -> (n,v)::l) m []
-
-let metamap_inv m b = 
-  Metamap.fold (fun n v l -> if v = b then n::l else l) m []
-
-type 'a freelisted = {
-  rebus : 'a;
-  freemetas : Metaset.t }
-
-(* collects all metavar occurences, in left-to-right order, preserving
- * repetitions and all. *)
-
-let collect_metas c = 
-  let rec collrec acc c =
-    match kind_of_term c with
-      | Meta mv -> mv::acc
-      | _         -> fold_constr collrec acc c
-  in
-  List.rev (collrec [] c)
-
-let metavars_of c =  
-  let rec collrec acc c =
-    match kind_of_term c with
-      | Meta mv -> Metaset.add mv acc
-      | _         -> fold_constr collrec acc c
-  in 
-  collrec Metaset.empty c
-
-let mk_freelisted c =
-  { rebus = c; freemetas = metavars_of c }
-
-
-(* Clausal environments *)
-
-type clbinding = 
-  | Cltyp of constr freelisted
-  | Clval of constr freelisted * constr freelisted
-
-type 'a clausenv = {
-  templval : constr freelisted;
-  templtyp : constr freelisted;
-  namenv : identifier Metamap.t;
-  env : clbinding Metamap.t;
-  hook : 'a }
-
-type wc = named_context sigma
-
-
-(* [mentions clenv mv0 mv1] is true if mv1 is defined and mentions
- * mv0, or if one of the free vars on mv1's freelist mentions
- * mv0 *)
-
-let mentions clenv mv0 = 
-  let rec menrec mv1 =
-    try
-     (match Metamap.find mv1 clenv.env with
-	 | Clval (b,_) -> 
-	     Metaset.mem mv0 b.freemetas || meta_exists menrec b.freemetas
-	 | Cltyp _ -> false)
-    with Not_found -> 
-      false
-  in 
-  menrec
-
-(* Creates a new clause-environment, whose template has a given
- * type, CTY.  This is not all that useful, since not very often
- * does one know the type of the clause - one usually only has
- * a clause which one wants to backchain thru. *)
-
-let mk_clenv wc cty =
-  let mv = new_meta () in
-  let cty_fls = mk_freelisted cty in 
-  { templval = mk_freelisted (mkMeta mv);
-    templtyp = cty_fls;
-    namenv = Metamap.empty;
-    env =  Metamap.add mv (Cltyp cty_fls) Metamap.empty ;
-    hook = wc }
-  
-let clenv_environments bound c =
-  let rec clrec (ne,e,metas) n c =
-    match n, kind_of_term c with
-      | (Some 0, _) -> (ne, e, List.rev metas, c)
-      | (n, Cast (c,_)) -> clrec (ne,e,metas) n c
-      | (n, Prod (na,c1,c2)) ->
-	  let mv = new_meta () in
-	  let dep = dependent (mkRel 1) c2 in
-	  let ne' =
-	    if dep then
-              match na with
-		| Anonymous -> ne
-		| Name id ->
-		    if metamap_in_dom mv ne then begin
-		      warning ("Cannot put metavar "^(string_of_meta mv)^
-			       " in name-environment twice");
-		      ne
-		    end else 
-		      Metamap.add mv id ne
-            else 
-	      ne 
-	  in
-	  let e' = Metamap.add mv (Cltyp (mk_freelisted c1)) e in 
-	  clrec (ne',e', (mkMeta mv)::metas) (option_app ((+) (-1)) n)
-	    (if dep then (subst1 (mkMeta mv) c2) else c2)
-      | (n, LetIn (na,b,_,c)) ->
-	  clrec (ne,e,metas) (option_app ((+) (-1)) n) (subst1 b c)
-      | (n, _) -> (ne, e, List.rev metas, c)
-  in 
-  clrec (Metamap.empty,Metamap.empty,[]) bound c
-
-let mk_clenv_from_n wc n (c,cty) =
-  let (namenv,env,args,concl) = clenv_environments n cty in
-  { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args));
-    templtyp = mk_freelisted concl;
-    namenv = namenv;
-    env = env;
-    hook = wc }
-
-let mk_clenv_from wc = mk_clenv_from_n wc None
-
-let map_fl f cfl = { cfl with rebus=f cfl.rebus }
-
-let map_clb f = function
-  | Cltyp cfl -> Cltyp (map_fl f cfl)
-  | Clval (cfl1,cfl2) -> Clval (map_fl f cfl1,map_fl f cfl2)
-
-let subst_clenv f sub clenv = 
-  { templval = map_fl (subst_mps sub) clenv.templval;
-    templtyp = map_fl (subst_mps sub) clenv.templtyp;
-    namenv = clenv.namenv;
-    env = Metamap.map (map_clb (subst_mps sub)) clenv.env;
-    hook = f sub clenv.hook }
-
-let connect_clenv wc clenv = { clenv with hook = wc }
-
-(* Was used in wcclausenv.ml
-(* Changes the head of a clenv with (templ,templty) *)
-let clenv_change_head (templ,templty) clenv =
-  { templval = mk_freelisted templ;
-    templtyp = mk_freelisted templty;
-    namenv   = clenv.namenv;
-    env      = clenv.env;
-    hook     = clenv.hook }
-*)
-
-let mk_clenv_hnf_constr_type_of wc t =
-  mk_clenv_from wc (t,w_hnf_constr wc (w_type_of wc t))
-
-let mk_clenv_rename_from wc (c,t) = 
-  mk_clenv_from wc (c,rename_bound_var (w_env wc) [] t)
-
-let mk_clenv_rename_from_n wc n (c,t) = 
-  mk_clenv_from_n wc n (c,rename_bound_var (w_env wc) [] t)
-    
-let mk_clenv_rename_type_of wc t =
-  mk_clenv_from wc (t,rename_bound_var (w_env wc) [] (w_type_of wc t))
-    
-let mk_clenv_rename_hnf_constr_type_of wc t =
-  mk_clenv_from wc
-    (t,rename_bound_var (w_env wc) [] (w_hnf_constr wc (w_type_of wc t)))
-
-let mk_clenv_type_of wc t = mk_clenv_from wc (t,w_type_of wc t)
-			      
-let clenv_assign mv rhs clenv =
-  let rhs_fls = mk_freelisted rhs in 
-  if meta_exists (mentions clenv mv) rhs_fls.freemetas then
-    error "clenv__assign: circularity in unification";
-  try
-    (match Metamap.find mv clenv.env with
-       | Clval (fls,ty) ->
-	   if not (eq_constr fls.rebus rhs) then
-	     try 
-	       (* Streams are lazy, force evaluation of id to catch Not_found*)
-	       let id = Metamap.find mv clenv.namenv in
-	       errorlabstrm "clenv_assign"
-		 (str "An incompatible instantiation has already been found for " ++ 
-		    pr_id id)
-	     with Not_found ->
-	       anomaly "clenv_assign: non dependent metavar already assigned"
-	   else
-	     clenv
-       | Cltyp bty -> 
-	   { templval = clenv.templval;
-	     templtyp = clenv.templtyp;
-	     namenv = clenv.namenv;
-	     env = Metamap.add mv (Clval (rhs_fls,bty)) clenv.env;
-	     hook = clenv.hook })
-  with Not_found -> 
-    error "clenv_assign"
-
-let clenv_val_of clenv mv = 
-  let rec valrec mv =
-    try
-      (match Metamap.find mv clenv.env with
-	 | Cltyp _ -> mkMeta mv
-	 | Clval(b,_) ->
-	     instance (List.map (fun mv' -> (mv',valrec mv')) 
-			       (Metaset.elements b.freemetas)) b.rebus)
-    with Not_found -> 
-      mkMeta mv
-  in 
-  valrec mv
-
-let clenv_instance clenv b =
-  let c_sigma =
-    List.map 
-      (fun mv -> (mv,clenv_val_of clenv mv)) (Metaset.elements b.freemetas)
-  in 
-  instance c_sigma b.rebus
-    
-let clenv_instance_term clenv c =
-  clenv_instance clenv (mk_freelisted c)
-
-
-(* This function put casts around metavariables whose type could not be
- * infered by the refiner, that is head of applications, predicates and
- * subject of Cases.
- * Does check that the casted type is closed. Anyway, the refiner would
- * fail in this case... *)
-
-let clenv_cast_meta clenv = 
-  let rec crec u =
-    match kind_of_term u with
-      | App _ | Case _ -> crec_hd u
-      | Cast (c,_) when isMeta c -> u
-      | _  -> map_constr crec u
-	    
-  and crec_hd u =
-    match kind_of_term (strip_outer_cast u) with
-      | Meta mv ->
-	  (try 
-	     match Metamap.find mv clenv.env with
-               | Cltyp b ->
-		   let b' = clenv_instance clenv b in 
-		   if occur_meta b' then u else mkCast (mkMeta mv, b')
-	       | Clval(_) -> u
-	   with Not_found -> 
-	     u)
-      | App(f,args) -> mkApp (crec_hd f, Array.map crec args)
-      | Case(ci,p,c,br) ->
-	  mkCase (ci, crec_hd p, crec_hd c, Array.map crec br)
-      | _ -> u
-  in 
-  crec
-
-
-(* [clenv_pose (na,mv,cty) clenv]
- * returns a new clausenv which has added to it the metavar MV,
- * with type CTY.  the name NA, if it is not ANONYMOUS, will
- * be entered into the name-map, as a way of accessing the new
- * metavar. *)
-
-let clenv_pose (na,mv,cty) clenv =
-  { templval = clenv.templval;
-    templtyp = clenv.templtyp;
-    env = Metamap.add mv (Cltyp (mk_freelisted cty)) clenv.env;
-    namenv = (match na with
-		| Anonymous -> clenv.namenv
-		| Name id -> Metamap.add mv id clenv.namenv);
-    hook = clenv.hook }
-
-let clenv_defined clenv mv =
-  match Metamap.find mv clenv.env with
-    | Clval _ -> true
-    | Cltyp _ -> false
-
-let clenv_value clenv mv =
-  match Metamap.find mv clenv.env with
-    | Clval(b,_) -> b
-    | Cltyp _ -> failwith "clenv_value"
-	  
-let clenv_type clenv mv =
-  match Metamap.find mv clenv.env with
-    | Cltyp b -> b
-    | Clval(_,b) -> b
-	  
-let clenv_template clenv = clenv.templval
-
-let clenv_template_type clenv = clenv.templtyp
-
-let clenv_instance_value clenv mv =
-  clenv_instance clenv (clenv_value clenv mv)
-    
-let clenv_instance_type clenv mv =
-  clenv_instance clenv (clenv_type clenv mv)
-    
-let clenv_instance_template clenv =
-  clenv_instance clenv (clenv_template clenv)
-    
-let clenv_instance_template_type clenv =
-  clenv_instance clenv (clenv_template_type clenv)
-    
-let clenv_wtactic wt clenv =
-  { templval = clenv.templval;
-    templtyp = clenv.templtyp;
-    namenv = clenv.namenv;
-    env = clenv.env;
-    hook = wt clenv.hook }
-
-let clenv_type_of ce c =
-  let metamap =
-    List.map 
-      (function
-	 | (n,Clval(_,typ)) -> (n,typ.rebus)
-         | (n,Cltyp typ)    -> (n,typ.rebus))
-      (metamap_to_list ce.env)
-  in
-    Retyping.get_type_of_with_meta (w_env ce.hook) (w_Underlying ce.hook) metamap c
-
-let clenv_instance_type_of ce c =
-  clenv_instance ce (mk_freelisted (clenv_type_of ce c))
-
-
-
-(* Unification à l'ordre 0 de m et n: [unify_0 mc wc m n] renvoie deux listes:
-
-   metasubst:(int*constr)list    récolte les instances des (Meta k)
-   evarsubst:(constr*constr)list récolte les instances des (Const "?k")
-
-   Attention : pas d'unification entre les différences instances d'une
-   même meta ou evar, il peut rester des doublons *)
-
-(* Unification order: *)
-(* Left to right: unifies first argument and then the other arguments *)
-(*let unify_l2r x = List.rev x
-(* Right to left: unifies last argument and then the other arguments *)
-let unify_r2l x = x
-
-let sort_eqns = unify_r2l
-*)
-
-let unify_0 cv_pb wc m n =
-  let env = w_env wc
-  and sigma = w_Underlying wc in
-  let trivial_unify pb substn m n =
-    if (not(occur_meta m)) & is_fconv pb env sigma m n then substn
-    else error_cannot_unify (m,n) in
-  let rec unirec_rec pb ((metasubst,evarsubst) as substn) m n =
-    let cM = Evarutil.whd_castappevar sigma m
-    and cN = Evarutil.whd_castappevar sigma n in 
-    match (kind_of_term cM,kind_of_term cN) with
-      | Meta k1, Meta k2 ->
-	  if k1 < k2 then (k1,cN)::metasubst,evarsubst
-	  else if k1 = k2 then substn
-	  else (k2,cM)::metasubst,evarsubst
-      | Meta k, _    -> (k,cN)::metasubst,evarsubst
-      | _, Meta k    -> (k,cM)::metasubst,evarsubst
-      | Evar _, _ -> metasubst,((cM,cN)::evarsubst)
-      | _, Evar _ -> metasubst,((cN,cM)::evarsubst)
-
-      | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
-	  unirec_rec CONV (unirec_rec CONV substn t1 t2) c1 c2
-      | Prod (_,t1,c1), Prod (_,t2,c2) ->
-	  unirec_rec pb (unirec_rec CONV substn t1 t2) c1 c2
-      | LetIn (_,b,_,c), _ -> unirec_rec pb substn (subst1 b c) cN
-      | _, LetIn (_,b,_,c) -> unirec_rec pb substn cM (subst1 b c)
-
-      | App (f1,l1), App (f2,l2) ->
-	  let len1 = Array.length l1
-	  and len2 = Array.length l2 in
-          let (f1,l1,f2,l2) =
-	    if len1 = len2 then (f1,l1,f2,l2)
-	    else if len1 < len2 then
-              let extras,restl2 = array_chop (len2-len1) l2 in 
-              (f1, l1, appvect (f2,extras), restl2)
-	    else 
-	      let extras,restl1 = array_chop (len1-len2) l1 in 
-              (appvect (f1,extras), restl1, f2, l2) in
-          (try
-            array_fold_left2 (unirec_rec CONV)
-	      (unirec_rec CONV substn f1 f2) l1 l2
-	  with ex when catchable_exception ex ->
-            trivial_unify pb substn cM cN)
-      | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
-          array_fold_left2 (unirec_rec CONV)
-	    (unirec_rec CONV (unirec_rec CONV substn p1 p2) c1 c2) cl1 cl2
-
-      | _ -> trivial_unify pb substn cM cN
-
-  in
-  if (not(occur_meta m)) & is_fconv cv_pb env sigma m n then 
-    ([],[])
-  else 
-    let (mc,ec) = unirec_rec cv_pb ([],[]) m n in
-    ((*sort_eqns*) mc, (*sort_eqns*) ec)
-
-
-(* Unification
- *
- * Procedure:
- * (1) The function [unify mc wc M N] produces two lists:
- *     (a) a list of bindings Meta->RHS
- *     (b) a list of bindings EVAR->RHS
- *
- * The Meta->RHS bindings cannot themselves contain
- * meta-vars, so they get applied eagerly to the other
- * bindings.  This may or may not close off all RHSs of
- * the EVARs.  For each EVAR whose RHS is closed off,
- * we can just apply it, and go on.  For each which
- * is not closed off, we need to do a mimick step -
- * in general, we have something like:
- *
- *      ?X == (c e1 e2 ... ei[Meta(k)] ... en)
- *
- * so we need to do a mimick step, converting ?X
- * into
- *
- *      ?X -> (c ?z1 ... ?zn)
- *
- * of the proper types.  Then, we can decompose the
- * equation into
- *
- *      ?z1 --> e1
- *          ...
- *      ?zi --> ei[Meta(k)]
- *          ...
- *      ?zn --> en
- *
- * and keep on going.  Whenever we find that a R.H.S.
- * is closed, we can, as before, apply the constraint
- * directly.  Whenever we find an equation of the form:
- *
- *      ?z -> Meta(n)
- *
- * we can reverse the equation, put it into our metavar
- * substitution, and keep going.
- *
- * The most efficient mimick possible is, for each
- * Meta-var remaining in the term, to declare a
- * new EVAR of the same type.  This is supposedly
- * determinable from the clausale form context -
- * we look up the metavar, take its type there,
- * and apply the metavar substitution to it, to
- * close it off.  But this might not always work,
- * since other metavars might also need to be resolved. *)
-
-let applyHead n c wc = 
-  let rec apprec n c cty wc =
-    if n = 0 then 
-      (wc,c)
-    else 
-      match kind_of_term (w_whd_betadeltaiota wc cty) with
-        | Prod (_,c1,c2) ->
-	    let evar = Evarutil.new_evar_in_sign (w_env wc) in
-            let (evar_n, _) = destEvar evar in
-	    (compose 
-	       (apprec (n-1) (applist(c,[evar])) (subst1 evar c2))
-	       (w_Declare evar_n c1))
-	    wc
-	| _ -> error "Apply_Head_Then"
-  in 
-  apprec n c (w_type_of wc c) wc
-
-let is_mimick_head f =
-  match kind_of_term f with
-      (Const _|Var _|Rel _|Construct _|Ind _) -> true
-    | _ -> false
-
-let rec mimick_evar hdc nargs sp wc =
-  let evd = Evd.map wc.sigma sp in
-  let wc' = extract_decl sp wc in
-  let (wc'', c) = applyHead nargs hdc wc' in
-  let (mc,ec) = unify_0 CONV wc'' (w_type_of wc'' c) (evd.evar_concl) in
-  let (wc''',_) = w_resrec mc ec wc'' in
-    if wc'== wc'''
-    then w_Define sp c wc
-    else  
-      let wc'''' = restore_decl sp evd wc''' in
-	w_Define sp (Evarutil.nf_evar wc''''.sigma c) {it = wc.it ; sigma = wc''''.sigma}
-
-and w_Unify cv_pb m n wc =
-  let (mc',ec') = unify_0 cv_pb wc m n in 
-  w_resrec mc' ec' wc
-
-and w_resrec metas evars wc =
-  match evars with
-    | [] -> (wc,metas)
-
-    | (lhs,rhs) :: t ->
-    match kind_of_term rhs with
-
-      | Meta k -> w_resrec ((k,lhs)::metas) t wc
-
-      | krhs ->
-      match kind_of_term lhs with
-
-	| Evar (evn,_) ->
-	    if w_defined_evar wc evn then
-	      let (wc',metas') = w_Unify CONV rhs lhs wc in 
-	      w_resrec (metas@metas') t wc'
-	    else
-	      (try 
-		 w_resrec metas t (w_Define evn rhs wc)
-               with ex when catchable_exception ex ->
-		 (match krhs with
-             	    | App (f,cl) when is_mimick_head f ->
-			let wc' = mimick_evar f (Array.length cl) evn wc in
-			w_resrec metas evars wc'
-		    | _ -> raise ex (*error "w_Unify" *)))
-	| _ -> anomaly "w_resrec"
-
-
-(* [unifyTerms] et [unify] ne semble pas gérer les Meta, en
-   particulier ne semblent pas vérifier que des instances différentes
-   d'une même Meta sont compatibles. D'ailleurs le "fst" jette les metas
-   provenant de w_Unify. (Utilisé seulement dans prolog.ml) *)
-
-(* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *)
-let unifyTerms m n gls = 
-  tclIDTAC {it = gls.it; 
-	    sigma = (get_gc (fst (w_Unify CONV m n (Refiner.project_with_focus gls))))}
-
-let unify m gls =
-  let n = pf_concl gls in unifyTerms m n gls
-
-(* [clenv_merge b metas evars clenv] merges common instances in metas
-   or in evars, possibly generating new unification problems; if [b]
-   is true, unification of types of metas is required *)
-
-let clenv_merge with_types metas evars clenv =
-  let ty_metas = ref [] in
-  let ty_evars = ref [] in
-  let rec clenv_resrec metas evars clenv =
-    match (evars,metas) with
-      | ([], []) -> clenv
-
-      | ((lhs,rhs)::t, metas) ->
-      (match kind_of_term rhs with
-
-	| Meta k -> clenv_resrec ((k,lhs)::metas) t clenv
-
-	| krhs ->
-        (match kind_of_term lhs with
-
-	  | Evar (evn,_) ->
-    	      if w_defined_evar clenv.hook evn then
-		let (metas',evars') = unify_0 CONV clenv.hook rhs lhs in
-		clenv_resrec (metas'@metas) (evars'@t) clenv
-    	      else begin
-		let rhs' = 
-		  if occur_meta rhs then subst_meta metas rhs else rhs 
-		in
-		if occur_evar evn rhs' then error "w_Unify";
-		try 
-		  clenv_resrec metas t 
-		    (clenv_wtactic (w_Define evn rhs') clenv) 
-		with ex when catchable_exception ex ->
-		  (match krhs with
-		     | App (f,cl) when is_mimick_head f ->
-			 clenv_resrec metas evars 
-			   (clenv_wtactic
-			      (mimick_evar f (Array.length cl) evn)
-			      clenv)
-           	     | _ -> raise ex (********* error "w_Unify" *))
-	      end
-
-	  | _ -> anomaly "clenv_resrec"))
-
-      | ([], (mv,n)::t) ->
-    	  if clenv_defined clenv mv then
-            let (metas',evars') =
-              unify_0 CONV clenv.hook (clenv_value clenv mv).rebus n in
-            clenv_resrec (metas'@t) evars' clenv
-    	  else
-            begin
-	      if with_types (* or occur_meta mvty *) then
-	        (let mvty = clenv_instance_type clenv mv in
-		try 
-		  let nty = clenv_type_of clenv 
-			      (clenv_instance clenv (mk_freelisted n)) in
-		  let (mc,ec) = unify_0 CUMUL clenv.hook nty mvty in
-                  ty_metas := mc @ !ty_metas;
-                  ty_evars := ec @ !ty_evars
-		with e when Logic.catchable_exception e -> ());
-	      clenv_resrec t [] (clenv_assign mv n clenv)
-            end in
-  (* merge constraints *)
-  let clenv' = clenv_resrec metas evars clenv in
-  if with_types then
-    (* merge constraints about types: if they fail, don't worry *)
-    try clenv_resrec !ty_metas !ty_evars clenv'
-    with e when Logic.catchable_exception e -> clenv'
-  else clenv'
-
-(* [clenv_unify M N clenv]
-   performs a unification of M and N, generating a bunch of
-   unification constraints in the process.  These constraints
-   are processed, one-by-one - they may either generate new
-   bindings, or, if there is already a binding, new unifications,
-   which themselves generate new constraints.  This continues
-   until we get failure, or we run out of constraints.
-   [clenv_typed_unify M N clenv] expects in addition that expected
-   types of metavars are unifiable with the types of their instances    *)
-
-let clenv_unify_core_0 with_types cv_pb m n clenv =
-  let (mc,ec) = unify_0 cv_pb clenv.hook m n in 
-  clenv_merge with_types mc ec clenv
-
-let clenv_unify_0 = clenv_unify_core_0 false
-let clenv_typed_unify = clenv_unify_core_0 true
-
-
-(* takes a substitution s, an open term op and a closed term cl
-   try to find a subterm of cl which matches op, if op is just a Meta
-   FAIL because we cannot find a binding *)
-
-let iter_fail f a =
-  let n = Array.length a in 
-  let rec ffail i =
-    if i = n then error "iter_fail" 
-    else
-      try f a.(i) 
-      with ex when catchable_exception ex -> ffail (i+1)
-  in ffail 0
-
-(* Tries to find an instance of term [cl] in term [op].
-   Unifies [cl] to every subterm of [op] until it finds a match.
-   Fails if no match is found *)
-let unify_to_subterm clause (op,cl) =
-  let rec matchrec cl =
-    let cl = strip_outer_cast cl in
-    (try 
-       if closed0 cl 
-       then clenv_unify_0 CONV op cl clause,cl
-       else error "Bound 1"
-     with ex when catchable_exception ex ->
-       (match kind_of_term cl with 
-	  | App (f,args) ->
-	      let n = Array.length args in
-	      assert (n>0);
-	      let c1 = mkApp (f,Array.sub args 0 (n-1)) in
-	      let c2 = args.(n-1) in
-	      (try 
-		 matchrec c1
-	       with ex when catchable_exception ex -> 
-		 matchrec c2)
-          | Case(_,_,c,lf) -> (* does not search in the predicate *)
-	       (try 
-		 matchrec c
-	       with ex when catchable_exception ex -> 
-		 iter_fail matchrec lf)
-	  | LetIn(_,c1,_,c2) -> 
-	       (try 
-		 matchrec c1
-	       with ex when catchable_exception ex -> 
-		 matchrec c2)
-
-	  | Fix(_,(_,types,terms)) -> 
-	       (try 
-		 iter_fail matchrec types
-	       with ex when catchable_exception ex -> 
-		 iter_fail matchrec terms)
-	
-	  | CoFix(_,(_,types,terms)) -> 
-	       (try 
-		 iter_fail matchrec types
-	       with ex when catchable_exception ex -> 
-		 iter_fail matchrec terms)
-
-          | Prod (_,t,c) ->
-	      (try 
-		 matchrec t 
-	       with ex when catchable_exception ex -> 
-		 matchrec c)
-          | Lambda (_,t,c) ->
-	      (try 
-		 matchrec t 
-	       with ex when catchable_exception ex -> 
-		 matchrec c)
-          | _ -> error "Match_subterm")) 
-  in 
-  try matchrec cl
-  with ex when catchable_exception ex ->
-    raise (RefinerError (NoOccurrenceFound op))
-
-let unify_to_subterm_list allow_K clause oplist t = 
-  List.fold_right 
-    (fun op (clause,l) ->
-      if isMeta op then
-	if allow_K then (clause,op::l)
-	else error "Match_subterm"
-      else if occur_meta op then
-        let (clause',cl) =
-          try 
-	    (* This is up to delta for subterms w/o metas ... *)
-	    unify_to_subterm clause (strip_outer_cast op,t)
-          with RefinerError (NoOccurrenceFound _) when allow_K -> (clause,op)
-        in 
-	(clause',cl::l)
-      else if not allow_K & not (dependent op t) then
-	(* This is not up to delta ... *)
-	raise (RefinerError (NoOccurrenceFound op))
-      else
-	(clause,op::l))
-    oplist 
-    (clause,[])
-
-let secondOrderAbstraction allow_K typ (p, oplist) clause =
-  let env = w_env clause.hook in
-  let sigma = w_Underlying clause.hook in
-  let (clause',cllist) = unify_to_subterm_list allow_K clause oplist typ in
-  let typp = clenv_instance_type clause' p in 
-  let pred = abstract_list_all env sigma typp typ cllist in
-  clenv_unify_0 CONV (mkMeta p) pred clause'
-
-let clenv_unify2 allow_K cv_pb ty1 ty2 clause =
-  let c1, oplist1 = whd_stack ty1 in
-  let c2, oplist2 = whd_stack ty2 in
-  match kind_of_term c1, kind_of_term c2 with
-    | Meta p1, _ ->
-        (* Find the predicate *)
-	let clause' =
-          secondOrderAbstraction allow_K ty2 (p1,oplist1) clause in 
-        (* Resume first order unification *)
-	clenv_unify_0 cv_pb (clenv_instance_term clause' ty1) ty2 clause'
-    | _, Meta p2 ->
-        (* Find the predicate *)
-	let clause' =
-          secondOrderAbstraction allow_K ty1 (p2, oplist2) clause in 
-        (* Resume first order unification *)
-	clenv_unify_0 cv_pb ty1 (clenv_instance_term clause' ty2) clause'
-    | _ -> error "clenv_unify2"
-
-
-(* The unique unification algorithm works like this: If the pattern is
-   flexible, and the goal has a lambda-abstraction at the head, then
-   we do a first-order unification.
-
-   If the pattern is not flexible, then we do a first-order
-   unification, too.
-
-   If the pattern is flexible, and the goal doesn't have a
-   lambda-abstraction head, then we second-order unification. *)
-
-(* We decide here if first-order or second-order unif is used for Apply *)
-(* We apply a term of type (ai:Ai)C and try to solve a goal C'          *)
-(* The type C is in clenv.templtyp.rebus with a lot of Meta to solve    *)
-
-(* 3-4-99 [HH] New fo/so choice heuristic :
-   In case we have to unify (Meta(1) args) with ([x:A]t args')
-   we first try second-order unification and if it fails first-order.
-   Before, second-order was used if the type of Meta(1) and [x:A]t was
-   convertible and first-order otherwise. But if failed if e.g. the type of
-   Meta(1) had meta-variables in it. *)
-let clenv_unify allow_K cv_pb ty1 ty2 clenv =
-  let hd1,l1 = whd_stack ty1 in
-  let hd2,l2 = whd_stack ty2 in
-  match kind_of_term hd1, l1<>[], kind_of_term hd2, l2<>[] with
-    (* Pattern case *)
-    | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true)
-      when List.length l1 = List.length l2 ->
-	(try 
-	   clenv_typed_unify cv_pb ty1 ty2 clenv
-	 with ex when catchable_exception ex -> 
-	   try 
-	     clenv_unify2 allow_K cv_pb ty1 ty2 clenv
-	   with RefinerError (NoOccurrenceFound c) as e -> raise e
-	     | ex when catchable_exception ex -> 
-	     error "Cannot solve a second-order unification problem")
-
-     (* Second order case *)
-     | (Meta _, true, _, _ | _, _, Meta _, true) -> 
-	(try 
-	   clenv_unify2 allow_K cv_pb ty1 ty2 clenv
-	with RefinerError (NoOccurrenceFound c) as e -> raise e
-	  | ex when catchable_exception ex -> 
-          try 
-	     clenv_typed_unify cv_pb ty1 ty2 clenv
-          with ex when catchable_exception ex -> 
-             error "Cannot solve a second-order unification problem")
-
-     (* General case: try first order *)
-     | _ -> clenv_unify_0 cv_pb ty1 ty2 clenv
-
-
-(* [clenv_bchain mv clenv' clenv]
- *
- * Resolves the value of "mv" (which must be undefined) in clenv to be
- * the template of clenv' be the value "c", applied to "n" fresh
- * metavars, whose types are chosen by destructing "clf", which should
- * be a clausale forme generated from the type of "c".  The process of
- * resolution can cause unification of already-existing metavars, and
- * of the fresh ones which get created.  This operation is a composite
- * of operations which pose new metavars, perform unification on
- * terms, and make bindings.  *)
-
-let clenv_bchain mv subclenv clenv =
-  (* Add the metavars of [subclenv] to [clenv], with their name-environment *)
-  let clenv' =
-    { templval = clenv.templval;
-      templtyp = clenv.templtyp;
-      namenv =
-	List.fold_left (fun ne (mv,id) ->
-			  if clenv_defined subclenv mv then 
-			    ne
-			  else if metamap_in_dom mv ne then begin
-			    warning ("Cannot put metavar "^(string_of_meta mv)^
-				     " in name-environment twice");
-			    ne
-			  end else 
-			    Metamap.add mv id ne)
-          clenv.namenv (metamap_to_list subclenv.namenv);
-      env = List.fold_left (fun m (n,v) -> Metamap.add n v m) 
-	       clenv.env (metamap_to_list subclenv.env);
-      hook = clenv.hook } 
-  in
-  (* unify the type of the template of [subclenv] with the type of [mv] *)
-  let clenv'' =
-    clenv_unify true CUMUL
-      (clenv_instance clenv' (clenv_template_type subclenv))
-      (clenv_instance_type clenv' mv)
-      clenv' 
-  in
-  (* assign the metavar *)
-  let clenv''' =
-    clenv_assign mv (clenv_instance clenv' (clenv_template subclenv)) clenv''
-  in 
-  clenv'''
-
-
-(* swaps the "hooks" in [clenv1] and [clenv2], so we can then use
-   backchain to hook them together *)
-
-let clenv_swap clenv1 clenv2 =
-  let clenv1' = { templval = clenv1.templval;
-		  templtyp = clenv1.templtyp;
-		  namenv = clenv1.namenv;
-		  env = clenv1.env;
-		  hook = clenv2.hook} 
-  and clenv2' = { templval = clenv2.templval;
-		  templtyp = clenv2.templtyp;
-		  namenv = clenv2.namenv;
-		  env = clenv2.env;
-		  hook = clenv1.hook}
-  in 
-  (clenv1',clenv2')
-
-let clenv_fchain mv nextclenv clenv =
-  let (clenv',nextclenv') = clenv_swap clenv nextclenv in 
-  clenv_bchain mv clenv' nextclenv'
-
-let clenv_refine kONT clenv gls =
-  tclTHEN
-    (kONT clenv.hook) 
-    (refine (clenv_instance_template clenv)) gls
-
-let clenv_refine_cast kONT clenv gls =
-  tclTHEN
-    (kONT clenv.hook) 
-    (refine (clenv_cast_meta clenv (clenv_instance_template clenv)))
-    gls
-
-(* [clenv_metavars clenv mv]
- * returns a list of the metavars which appear in the type of
- * the metavar mv.  The list is unordered. *)
-
-let clenv_metavars clenv mv =
-  match Metamap.find mv clenv.env with
-    | Clval(_,b) -> b.freemetas
-    | Cltyp b -> b.freemetas
-
-let clenv_template_metavars clenv = clenv.templval.freemetas
-
-(* [clenv_dependent hyps_only clenv]
- * returns a list of the metavars which appear in the template of clenv,
- * and which are dependent, This is computed by taking the metavars in cval,
- * in right-to-left order, and collecting the metavars which appear
- * in their types, and adding in all the metavars appearing in the
- * type of clenv.
- * If [hyps_only] then metavariables occurring in the type are _excluded_ *)
-
-let dependent_metas clenv mvs conclmetas =
-  List.fold_right
-    (fun mv deps ->
-       Metaset.union deps (clenv_metavars clenv mv))
-    mvs conclmetas
-
-let clenv_dependent hyps_only clenv =
-  let mvs = collect_metas (clenv_instance_template clenv) in
-  let ctyp_mvs = metavars_of (clenv_instance_template_type clenv) in
-  let deps = dependent_metas clenv mvs ctyp_mvs in
-  List.filter
-    (fun mv -> Metaset.mem mv deps && not (hyps_only && Metaset.mem mv ctyp_mvs))
-    mvs
-
-let clenv_missing c = clenv_dependent true c
-
-(* [clenv_independent clenv]
- * returns a list of metavariables which appear in the term cval,
- * and which are not dependent.  That is, they do not appear in
- * the types of other metavars which are in cval, nor in the type
- * of cval, ctyp. *)
-
-let clenv_independent clenv =
-  let mvs = collect_metas (clenv_instance_template clenv) in
-  let ctyp_mvs = metavars_of (clenv_instance_template_type clenv) in
-  let deps = dependent_metas clenv mvs ctyp_mvs in
-  List.filter (fun mv -> not (Metaset.mem mv deps)) mvs
-
-let w_coerce wc c ctyp target =
-  let j = make_judge c ctyp in
-  let env = w_env wc in
-  let isevars = Evarutil.create_evar_defs (w_Underlying wc) in
-  let j' = Coercion.inh_conv_coerce_to dummy_loc env isevars j target in
-  (* faire quelque chose avec isevars ? *)
-  j'.uj_val
-
-let clenv_constrain_dep_args hyps_only clause = function
-  | [] -> clause 
-  | mlist ->
-      let occlist = clenv_dependent hyps_only clause in
-      if List.length occlist = List.length mlist then
-	List.fold_left2
-          (fun clenv k c ->
-	    let wc = clause.hook in
-	    try
-	      let k_typ = w_hnf_constr wc (clenv_instance_type clause k) in
-	      let c_typ = w_hnf_constr wc (w_type_of wc c) in
-	      let c' = w_coerce wc c c_typ k_typ in
-	      clenv_unify true CONV (mkMeta k) c' clenv
-	    with _ ->
-              clenv_unify true CONV (mkMeta k) c clenv)
-          clause occlist mlist
-      else 
-	error ("Not the right number of missing arguments (expected "
-	       ^(string_of_int (List.length occlist))^")")
-
-let clenv_constrain_missing_args mlist clause =
-  clenv_constrain_dep_args true clause mlist
-
-let clenv_lookup_name clenv id =
-  match metamap_inv clenv.namenv id with
-    | []  -> 
-	errorlabstrm "clenv_lookup_name"
-          (str"No such bound variable " ++ pr_id id)
-    | [n] -> 
-	n
-    |  _  -> 
-	 anomaly "clenv_lookup_name: a name occurs more than once in clause"
-
-let clenv_match_args s clause =
-  let mvs = clenv_independent clause in 
-  let rec matchrec clause = function
-    | [] -> clause
-    | (loc,b,c)::t ->
-	let k =
-	  match b with
-            | NamedHyp s ->
-		if List.exists (fun (_,b',_) -> b=b') t then 
-		  errorlabstrm "clenv_match_args" 
-		    (str "The variable " ++ pr_id s ++ 
-		    str " occurs more than once in binding")
-		else
-		  clenv_lookup_name clause s
-	    | AnonHyp n ->
-		if List.exists (fun (_,b',_) -> b=b') t then
-		  errorlabstrm "clenv_match_args"
-		    (str "The position " ++ int n ++
-		    str " occurs more than once in binding");
-		try 
-		  List.nth mvs (n-1)
-		with (Failure _|Invalid_argument _) ->
-                  errorlabstrm "clenv_match_args" (str "No such binder")
-	in
-	let k_typ = w_hnf_constr clause.hook (clenv_instance_type clause k)
-	(* nf_betaiota was before in type_of - useful to reduce types like *)
-	(* (x:A)([x]P u) *)
-	and c_typ = w_hnf_constr clause.hook
-          (nf_betaiota (w_type_of clause.hook c)) in
-	let cl =
-	  (* Try to infer some Meta/Evar from the type of [c] *)
-	  try 
-            clenv_assign k c (clenv_unify true CUMUL c_typ k_typ clause)
-	  with _ ->
-	  (* Try to coerce to the type of [k]; cannot merge with the
-	     previous case because Coercion does not handle Meta *)
-          let c' = w_coerce clause.hook c c_typ k_typ in
-	  try clenv_unify true CONV (mkMeta k) c' clause
-	  with RefinerError (CannotUnify (m,n)) ->
-	    Stdpp.raise_with_loc loc
- 	      (RefinerError (CannotUnifyBindingType (m,n)))
-	in matchrec cl t
-  in 
-  matchrec clause s
-
-type arg_bindings = (int * constr) list
-
-let clenv_constrain_with_bindings bl clause =
-  if bl = [] then 
-    clause 
-  else 
-    let all_mvs = collect_metas (clenv_template clause).rebus in
-    let rec matchrec clause = function
-      | []       -> clause
-      | (n,c)::t ->
-          let k = 
-            (try
-              if n > 0 then 
-		List.nth all_mvs (n-1)
-              else if n < 0 then 
-		List.nth (List.rev all_mvs) (-n-1)
-              else error "clenv_constrain_with_bindings" 
-            with Failure _ ->
-              errorlabstrm "clenv_constrain_with_bindings"
-                (str"Clause did not have " ++ int n ++ str"-th" ++
-                str" absolute argument")) in
-	  let env = Global.env () in
-	  let sigma = Evd.empty in
-	  let k_typ = nf_betaiota (clenv_instance_type clause k) in
-	  let c_typ = nf_betaiota (w_type_of clause.hook c) in 
-	  matchrec
-            (clenv_assign k c (clenv_unify true CUMUL c_typ k_typ clause)) t
-    in 
-    matchrec clause bl
-
-
-(* [clenv_pose_dependent_evars clenv]
- * For each dependent evar in the clause-env which does not have a value,
- * pose a value for it by constructing a fresh evar.  We do this in
- * left-to-right order, so that every evar's type is always closed w.r.t.
- * metas. *)
-
-let clenv_pose_dependent_evars clenv =
-  let dep_mvs = clenv_dependent false clenv in
-  List.fold_left
-    (fun clenv mv ->
-       let evar = Evarutil.new_evar_in_sign (w_env clenv.hook) in
-       let (evar_n,_) = destEvar evar in
-       let tY = clenv_instance_type clenv mv in
-       let clenv' = clenv_wtactic (w_Declare evar_n tY) clenv in
-       clenv_assign mv evar clenv')
-    clenv
-    dep_mvs
-
-(***************************)
-
-let clenv_unique_resolver allow_K clause gl =
-  clenv_unify allow_K CUMUL
-    (clenv_instance_template_type clause) (pf_concl gl) clause 
-
-let res_pf kONT clenv gls =
-  clenv_refine kONT (clenv_unique_resolver false clenv gls) gls
-    
-let res_pf_cast kONT clenv gls =
-  clenv_refine_cast kONT (clenv_unique_resolver false clenv gls) gls
-
-let elim_res_pf kONT clenv allow_K gls =
-  clenv_refine_cast kONT (clenv_unique_resolver allow_K clenv gls) gls
-
-let elim_res_pf_THEN_i kONT clenv tac gls =  
-  let clenv' = (clenv_unique_resolver true clenv gls) in
-  tclTHENLASTn (clenv_refine kONT clenv') (tac clenv') gls
-
-let e_res_pf kONT clenv gls =
-  clenv_refine kONT
-    (clenv_pose_dependent_evars (clenv_unique_resolver false clenv gls)) gls
-
-(* Clausal environment for an application *)
-
-let make_clenv_binding_gen n wc (c,t) = function
-  | ImplicitBindings largs ->
-      let clause = mk_clenv_from_n wc n (c,t) in
-      clenv_constrain_dep_args (n <> None) clause largs
-  | ExplicitBindings lbind ->
-      let clause = mk_clenv_rename_from_n wc n (c,t) in
-      clenv_match_args lbind clause
-  | NoBindings ->
-      mk_clenv_from_n wc n (c,t)
-
-let make_clenv_binding_apply wc n = make_clenv_binding_gen (Some n) wc
-let make_clenv_binding = make_clenv_binding_gen None
-
-open Printer
-
-let pr_clenv clenv =
-  let pr_name mv =
-    try 
-      let id = Metamap.find mv clenv.namenv in
-      (str"[" ++ pr_id id ++ str"]")
-    with Not_found -> (mt ())
-  in
-  let pr_meta_binding = function
-    | (mv,Cltyp b) ->
-      	hov 0 
-	  (pr_meta mv ++ pr_name mv ++ str " : " ++ prterm b.rebus ++ fnl ())
-    | (mv,Clval(b,_)) ->
-      	hov 0 
-	  (pr_meta mv ++ pr_name mv ++ str " := " ++ prterm b.rebus ++ fnl ())
-  in
-  (str"TEMPL: " ++ prterm clenv.templval.rebus ++
-     str" : " ++ prterm clenv.templtyp.rebus ++ fnl () ++
-     (prlist pr_meta_binding (metamap_to_list clenv.env)))
diff --git a/proofs/clenv.mli b/proofs/clenv.mli
deleted file mode 100644
index 737fbea3..00000000
--- a/proofs/clenv.mli
+++ /dev/null
@@ -1,142 +0,0 @@
-(************************************************************************)
-(*  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: clenv.mli,v 1.32.2.2 2005/01/21 16:41:51 herbelin Exp $ i*)
-
-(*i*)
-open Util
-open Names
-open Term
-open Sign
-open Proof_type
-(*i*)
-
-(* [new_meta] is a generator of unique meta variables *)
-val new_meta : unit -> metavariable
-
-(* [exist_to_meta] generates new metavariables for each existential
-   and performs the replacement in the given constr *)
-val exist_to_meta :
-  Evd.evar_map -> Pretyping.open_constr -> (Termops.metamap * constr)
-
-(* The Type of Constructions clausale environments. *)
-
-module Metaset : Set.S with type elt = metavariable
-
-module Metamap : Map.S with type key = metavariable
-
-type 'a freelisted = {
-  rebus : 'a;
-  freemetas : Metaset.t }
-
-type clbinding = 
-  | Cltyp of constr freelisted
-  | Clval of constr freelisted * constr freelisted
-
-type 'a clausenv = {
-  templval : constr freelisted;
-  templtyp : constr freelisted;
-  namenv : identifier Metamap.t;
-  env : clbinding Metamap.t;
-  hook : 'a }
-
-type wc = named_context sigma (* for a better reading of the following *)
-
-(* [templval] is the template which we are trying to fill out.
- * [templtyp] is its type.
- * [namenv] is a mapping from metavar numbers to names, for
- *          use in instanciating metavars by name.
- * [env] is the mapping from metavar numbers to their types
- *       and values.
- * [hook] is the pointer to the current walking context, for
- *        integrating existential vars and metavars. *)
-
-val collect_metas : constr -> metavariable list
-val mk_clenv : 'a -> constr -> 'a clausenv
-val mk_clenv_from : 'a -> constr * constr -> 'a clausenv
-val mk_clenv_from_n : 'a -> int option -> constr * constr -> 'a clausenv
-val mk_clenv_rename_from : wc -> constr * constr -> wc clausenv
-val mk_clenv_rename_from_n : wc -> int option -> constr * constr -> wc clausenv
-val mk_clenv_hnf_constr_type_of : wc -> constr -> wc clausenv
-val mk_clenv_type_of : wc -> constr -> wc clausenv
-
-val subst_clenv : (substitution -> 'a -> 'a) -> 
-  substitution -> 'a clausenv -> 'a clausenv
-
-val connect_clenv : wc -> 'a clausenv -> wc clausenv
-(*i Was used in wcclausenv.ml
-val clenv_change_head : constr * constr -> 'a clausenv -> 'a clausenv
-i*)
-val clenv_assign : metavariable -> constr -> 'a clausenv -> 'a clausenv
-val clenv_instance_term : wc clausenv -> constr -> constr
-val clenv_pose : name * metavariable * constr -> 'a clausenv -> 'a clausenv
-val clenv_template : 'a clausenv -> constr freelisted
-val clenv_template_type : 'a clausenv -> constr freelisted
-val clenv_instance_type : wc clausenv -> metavariable -> constr
-val clenv_instance_template : wc clausenv -> constr
-val clenv_instance_template_type : wc clausenv -> constr
-val clenv_type_of : wc clausenv -> constr -> constr
-val clenv_fchain : metavariable -> 'a clausenv -> wc clausenv -> wc clausenv
-val clenv_bchain : metavariable -> 'a clausenv -> wc clausenv -> wc clausenv
-
-(* Unification with clenv *)
-type arg_bindings = (int * constr) list
-
-val unify_0 : 
-  Reductionops.conv_pb -> wc -> constr -> constr 
-    -> Termops.metamap * (constr * constr) list
-val clenv_unify : 
-  bool -> Reductionops.conv_pb -> constr -> constr ->
-  wc clausenv -> wc clausenv
-val clenv_match_args :
-  constr Rawterm.explicit_bindings -> wc clausenv -> wc clausenv
-val clenv_constrain_with_bindings : arg_bindings -> wc clausenv -> wc clausenv
-
-(* Bindings *)
-val clenv_independent : wc clausenv -> metavariable list
-val clenv_missing : 'a clausenv -> metavariable list
-val clenv_constrain_missing_args : (* Used in user contrib Lannion *)
-  constr list -> wc clausenv -> wc clausenv
-(*i
-val clenv_constrain_dep_args : constr list -> wc clausenv -> wc clausenv
-i*)
-val clenv_lookup_name : 'a clausenv -> identifier -> metavariable
-val clenv_unique_resolver : bool -> wc clausenv -> goal sigma -> wc clausenv
-
-val make_clenv_binding_apply :
-  wc -> int -> constr * constr -> types Rawterm.bindings -> wc clausenv
-val make_clenv_binding :
-  wc -> constr * constr -> types Rawterm.bindings -> wc clausenv
-
-(* Tactics *)
-val unify : constr -> tactic
-val clenv_refine : (wc -> tactic) -> wc clausenv -> tactic
-val res_pf      : (wc -> tactic) -> wc clausenv -> tactic
-val res_pf_cast : (wc -> tactic) -> wc clausenv -> tactic
-val elim_res_pf : (wc -> tactic) -> wc clausenv -> bool -> tactic
-val e_res_pf : (wc -> tactic) -> wc clausenv -> tactic
-val elim_res_pf_THEN_i : 
-  (wc -> tactic) -> wc clausenv -> (wc clausenv -> tactic array) -> tactic
-
-(* Pretty-print *)
-val pr_clenv : 'a clausenv -> Pp.std_ppcmds
-
-(* Exported for debugging *)
-val unify_to_subterm : 
-  wc clausenv -> constr * constr -> wc clausenv * constr
-val unify_to_subterm_list : 
-  bool -> wc clausenv -> constr list -> constr -> wc clausenv * constr list
-val clenv_typed_unify :
-  Reductionops.conv_pb -> constr -> constr -> wc clausenv -> wc clausenv
-
-(*i This should be in another module i*)
-
-(* [abstract_list_all env sigma t c l]                     *)
-(* abstracts the terms in l over c to get a term of type t *)
-val abstract_list_all :
-  Environ.env -> Evd.evar_map -> constr -> constr -> constr list -> constr
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
new file mode 100644
index 00000000..71538614
--- /dev/null
+++ b/proofs/clenvtac.ml
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  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: clenvtac.ml 8023 2006-02-10 18:34:51Z coq $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Environ
+open Evd
+open Evarutil
+open Proof_type
+open Refiner
+open Proof_trees
+open Logic
+open Reduction
+open Reductionops
+open Tacmach
+open Evar_refiner
+open Rawterm
+open Pattern
+open Tacexpr
+open Clenv
+
+    
+(* This function put casts around metavariables whose type could not be
+ * infered by the refiner, that is head of applications, predicates and
+ * subject of Cases.
+ * Does check that the casted type is closed. Anyway, the refiner would
+ * fail in this case... *)
+
+let clenv_cast_meta clenv = 
+  let rec crec u =
+    match kind_of_term u with
+      | App _ | Case _ -> crec_hd u
+      | Cast (c,_,_) when isMeta c -> u
+      | _  -> map_constr crec u
+	    
+  and crec_hd u =
+    match kind_of_term (strip_outer_cast u) with
+      | Meta mv ->
+	  (try 
+            let b = Typing.meta_type clenv.env mv in
+	    if occur_meta b then u
+            else mkCast (mkMeta mv, DEFAULTcast, b)
+	  with Not_found -> u)
+      | App(f,args) -> mkApp (crec_hd f, Array.map crec args)
+      | Case(ci,p,c,br) ->
+	  mkCase (ci, crec_hd p, crec_hd c, Array.map crec br)
+      | _ -> u
+  in 
+  crec
+
+let clenv_refine clenv gls =
+  tclTHEN
+    (tclEVARS (evars_of clenv.env)) 
+    (refine (clenv_cast_meta clenv (clenv_value clenv)))
+    gls
+
+
+let res_pf clenv ?(allow_K=false) gls =
+  clenv_refine (clenv_unique_resolver allow_K clenv gls) gls
+
+let elim_res_pf_THEN_i clenv tac gls =  
+  let clenv' = (clenv_unique_resolver true clenv gls) in
+  tclTHENLASTn (clenv_refine clenv') (tac clenv') gls
+
+
+let e_res_pf clenv gls =
+  clenv_refine (evar_clenv_unique_resolver clenv gls) gls
+
+
+
+
+(* [unifyTerms] et [unify] ne semble pas gérer les Meta, en
+   particulier ne semblent pas vérifier que des instances différentes
+   d'une même Meta sont compatibles. D'ailleurs le "fst" jette les metas
+   provenant de w_Unify. (Utilisé seulement dans prolog.ml) *)
+
+(* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *)
+let unifyTerms m n gls = 
+  let env = pf_env gls in
+  let evd = create_evar_defs (project gls) in
+  let evd' = Unification.w_unify false env CONV m n evd in
+  tclIDTAC {it = gls.it; sigma = evars_of evd'}
+
+let unify m gls =
+  let n = pf_concl gls in unifyTerms m n gls
diff --git a/contrib7/correctness/Correctness.v b/proofs/clenvtac.mli
index b0fde165..505826fa 100644
--- a/contrib7/correctness/Correctness.v
+++ b/proofs/clenvtac.mli
@@ -6,20 +6,21 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+(*i $Id: clenvtac.mli 6099 2004-09-12 11:38:09Z barras $ i*)
 
-(* $Id: Correctness.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Evd
+open Clenv
+open Proof_type
+(*i*)
 
-(* Correctness is base on the tactic Refine (developped on purpose) *)
-
-Require Export Tuples.
-
-Require Export ProgInt.
-Require Export ProgBool.
-Require Export Zwf.
-
-Require Export Arrays.
-
-(*
-Token "'".
-*)
+(* Tactics *)
+val unify : constr -> tactic
+val clenv_refine : clausenv -> tactic
+val res_pf : clausenv -> ?allow_K:bool -> tactic
+val e_res_pf : clausenv -> tactic
+val elim_res_pf_THEN_i : clausenv -> (clausenv -> tactic array) -> tactic
diff --git a/proofs/decl_expr.mli b/proofs/decl_expr.mli
new file mode 100644
index 00000000..a8b7c0d6
--- /dev/null
+++ b/proofs/decl_expr.mli
@@ -0,0 +1,106 @@
+(************************************************************************)
+(*  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$ *)
+
+open Names
+open Util
+open Tacexpr
+
+type 'it statement = 
+    {st_label:name;
+     st_it:'it}
+
+type thesis_kind =
+    Plain
+  | Sub of int
+  | For of identifier
+
+type 'this or_thesis =
+    This of 'this
+  | Thesis of thesis_kind
+
+type side = Lhs | Rhs
+
+type elim_type =
+    ET_Case_analysis
+  | ET_Induction
+
+type block_type =
+    B_proof
+  | B_claim
+  | B_focus
+  | B_elim of elim_type
+
+type ('it,'constr,'tac) cut =
+    {cut_stat: 'it;
+     cut_by: 'constr list option;
+     cut_using: 'tac option}
+
+type ('var,'constr) hyp = 
+    Hvar of 'var 
+  | Hprop of 'constr statement
+
+type ('constr,'tac) casee = 
+    Real of 'constr 
+  | Virtual of ('constr statement,'constr,'tac) cut
+
+type ('hyp,'constr,'pat,'tac) bare_proof_instr =
+  | Pthen of ('hyp,'constr,'pat,'tac) bare_proof_instr
+  | Pthus of ('hyp,'constr,'pat,'tac) bare_proof_instr
+  | Phence of ('hyp,'constr,'pat,'tac) bare_proof_instr
+  | Pcut of ('constr or_thesis statement,'constr,'tac) cut
+  | Prew of side * ('constr statement,'constr,'tac) cut
+  | Psuffices of ((('hyp,'constr) hyp list * 'constr or_thesis),'constr,'tac) cut
+  | Passume of ('hyp,'constr) hyp list
+  | Plet of ('hyp,'constr) hyp list
+  | Pgiven of ('hyp,'constr) hyp list
+  | Pconsider of 'constr*('hyp,'constr) hyp list
+  | Pclaim of 'constr statement
+  | Pfocus of 'constr statement
+  | Pdefine of identifier * 'hyp list * 'constr
+  | Pcast of identifier or_thesis * 'constr
+  | Psuppose of ('hyp,'constr) hyp list 
+  | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list) 
+  | Ptake of 'constr list 
+  | Pper of elim_type * ('constr,'tac) casee
+  | Pend of block_type
+  | Pescape
+
+type emphasis = int
+
+type ('hyp,'constr,'pat,'tac) gen_proof_instr=
+    {emph: emphasis;
+     instr: ('hyp,'constr,'pat,'tac) bare_proof_instr }
+
+
+type raw_proof_instr =
+    ((identifier*(Topconstr.constr_expr option)) located,
+     Topconstr.constr_expr,
+     Topconstr.cases_pattern_expr,
+     raw_tactic_expr) gen_proof_instr
+
+type glob_proof_instr =
+    ((identifier*(Genarg.rawconstr_and_expr option)) located,
+     Genarg.rawconstr_and_expr,  
+     Topconstr.cases_pattern_expr,
+     Tacexpr.glob_tactic_expr) gen_proof_instr
+
+type proof_pattern = 
+    {pat_vars: Term.types statement list;
+     pat_aliases: (Term.constr*Term.types) statement list;
+     pat_constr: Term.constr;
+     pat_typ: Term.types;
+     pat_pat: Rawterm.cases_pattern;
+     pat_expr: Topconstr.cases_pattern_expr}
+
+type proof_instr =
+    (Term.constr statement,
+     Term.constr, 
+     proof_pattern,
+     Tacexpr.glob_tactic_expr) gen_proof_instr
diff --git a/proofs/decl_mode.ml b/proofs/decl_mode.ml
new file mode 100644
index 00000000..8d8fb745
--- /dev/null
+++ b/proofs/decl_mode.ml
@@ -0,0 +1,120 @@
+(************************************************************************)
+(*  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$ *)
+
+open Names
+open Term
+open Evd
+open Util
+
+let daimon_flag = ref false
+
+let set_daimon_flag () = daimon_flag:=true 
+let clear_daimon_flag () = daimon_flag:=false
+let get_daimon_flag () = !daimon_flag 
+
+type command_mode =
+    Mode_tactic
+  | Mode_proof
+  | Mode_none
+
+let mode_of_pftreestate pts =
+  let goal = sig_it (Refiner.top_goal_of_pftreestate pts) in
+    if goal.evar_extra = None then
+      Mode_tactic 
+    else
+      Mode_proof
+	  
+let get_current_mode () =
+  try 
+    mode_of_pftreestate (Pfedit.get_pftreestate ())
+  with _ -> Mode_none
+
+let check_not_proof_mode str =
+ if get_current_mode () = Mode_proof then
+   error str
+
+type split_tree=
+    Push of (Idset.t * split_tree)
+  | Split of (Idset.t * inductive * (Idset.t * split_tree) option array)
+  | Pop of split_tree
+  | End_of_branch of (identifier * int)
+
+type elim_kind =
+    EK_dep of split_tree
+  | EK_nodep
+  | EK_unknown
+
+type per_info = 
+    {per_casee:constr;
+     per_ctype:types;
+     per_ind:inductive;
+     per_pred:constr;
+     per_args:constr list;
+     per_params:constr list;
+     per_nparams:int}
+
+type stack_info = 
+    Per of Decl_expr.elim_type * per_info * elim_kind * identifier list
+  | Suppose_case
+  | Claim
+  | Focus_claim
+
+type pm_info =
+    { pm_last: (Names.identifier * bool) option (* anonymous if none *);
+      pm_partial_goal : constr; (* partial goal construction *)
+      pm_subgoals : (metavariable*constr) list;
+      pm_stack : stack_info list}
+
+let pm_in,pm_out = Dyn.create "pm_info" 
+
+let get_info gl=
+  match gl.evar_extra with
+      None ->  invalid_arg "get_info"
+    | Some extra ->
+	try pm_out extra with _ -> invalid_arg "get_info"
+
+let get_stack pts = 
+  let info = get_info (sig_it (Refiner.nth_goal_of_pftreestate 1 pts)) in
+    info.pm_stack
+
+let get_top_stack pts = 
+  let info = get_info (sig_it (Refiner.top_goal_of_pftreestate pts)) in
+    info.pm_stack
+
+let get_end_command pts =
+  match mode_of_pftreestate pts with 
+      Mode_proof ->
+	Some 
+	  begin
+	    match get_top_stack pts with
+		[] -> "\"end proof\""
+	      | Claim::_ -> "\"end claim\""
+	      | Focus_claim::_-> "\"end focus\""
+	      | (Suppose_case :: Per (et,_,_,_) :: _ 
+		| Per (et,_,_,_) :: _ ) -> 
+		  begin
+		    match et with
+			Decl_expr.ET_Case_analysis -> 
+			  "\"end cases\" or start a new case"
+		      | Decl_expr.ET_Induction -> 
+			  "\"end induction\" or start a new case"
+		  end
+	      | _ -> anomaly "lonely suppose"
+	  end
+    | Mode_tactic ->
+	begin
+	  try
+	    ignore 
+	      (Refiner.up_until_matching_rule Proof_trees.is_proof_instr pts);
+	    Some "\"return\""
+	  with Not_found -> None
+	end
+    | Mode_none ->
+        error "no proof in progress"
diff --git a/proofs/decl_mode.mli b/proofs/decl_mode.mli
new file mode 100644
index 00000000..81fab168
--- /dev/null
+++ b/proofs/decl_mode.mli
@@ -0,0 +1,72 @@
+(************************************************************************)
+(*  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$ *)
+
+open Names
+open Term
+open Evd
+open Tacmach
+
+val set_daimon_flag : unit -> unit
+val clear_daimon_flag : unit -> unit
+val get_daimon_flag : unit -> bool
+
+type command_mode =
+    Mode_tactic
+  | Mode_proof
+  | Mode_none
+
+val mode_of_pftreestate : pftreestate -> command_mode
+    
+val get_current_mode : unit -> command_mode
+
+val check_not_proof_mode : string -> unit
+
+type split_tree=
+    Push of  (Idset.t * split_tree)
+  | Split of (Idset.t * inductive * (Idset.t*split_tree) option array)
+  | Pop of split_tree
+  | End_of_branch of (identifier * int)
+
+type elim_kind =
+    EK_dep of split_tree
+  | EK_nodep
+  | EK_unknown
+
+
+type per_info = 
+    {per_casee:constr;
+     per_ctype:types;
+     per_ind:inductive;
+     per_pred:constr;
+     per_args:constr list;
+     per_params:constr list;
+     per_nparams:int}
+
+type stack_info = 
+    Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list
+  | Suppose_case
+  | Claim
+  | Focus_claim
+
+type pm_info =
+    { pm_last: (Names.identifier * bool) option (* anonymous if none *);
+      pm_partial_goal : constr ; (* partial goal construction *)
+      pm_subgoals : (metavariable*constr) list;
+      pm_stack : stack_info list }
+
+val pm_in : pm_info -> Dyn.t
+
+val get_info : Proof_type.goal -> pm_info
+
+val get_end_command : pftreestate -> string option
+
+val get_stack : pftreestate -> stack_info list
+
+val get_top_stack : pftreestate -> stack_info list
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
index ac4dd43a..132fa2b9 100644
--- a/proofs/evar_refiner.ml
+++ b/proofs/evar_refiner.ml
@@ -6,183 +6,47 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: evar_refiner.ml,v 1.36.2.2 2004/08/03 21:37:27 herbelin Exp $ *)
+(* $Id: evar_refiner.ml 9583 2007-02-01 19:35:03Z notin $ *)
 
-open Pp
 open Util
 open Names
 open Term
-open Environ
 open Evd
 open Sign
-open Reductionops
-open Typing
-open Instantiate
-open Tacred
 open Proof_trees
-open Proof_type
-open Logic
 open Refiner
-open Tacexpr
-open Nameops
-
-
-type wc = named_context sigma (* for a better reading of the following *)
-
-let rc_of_pfsigma sigma = rc_of_gc sigma.sigma sigma.it.goal
-let rc_of_glsigma sigma = rc_of_gc sigma.sigma sigma.it
-
-type w_tactic = named_context sigma -> named_context sigma
-
-let startWalk gls =
-  let evc = project_with_focus gls in
-  (evc,
-   (fun wc' gls' ->
-      if not !Options.debug or (gls.it = gls'.it) then
-(*        if Intset.equal (get_lc gls.it) (get_focus (ids_it wc')) then*)
-          tclIDTAC {it=gls'.it; sigma = (get_gc wc')}
-(*        else
-          (local_Constraints (get_focus (ids_it wc'))
-             {it=gls'.it; sigma = get_gc (ids_it wc')})*)
-      else error "Walking"))
-
-let extract_decl sp evc =
-  let evdmap = evc.sigma in
-  let evd = Evd.map evdmap sp in 
-    { it = evd.evar_hyps;
-      sigma = Evd.rmv evdmap sp }
-
-let restore_decl sp evd evc =
-  (rc_add evc (sp,evd))
-
-
-(* [w_Focusing sp wt wc]
- *
- * Focuses the walking context WC onto the declaration SP, given that
- * this declaration is UNDEFINED.  Then, it runs the walking_tactic,
- * WT, on this new context.  When the result is returned, we recover
- * the resulting focus (access list) and restore it to SP's declaration.
- *
- * It is an error to cause SP to change state while we are focused on it. *)
-
-(* let w_Focusing_THEN sp (wt : 'a result_w_tactic) (wt' : 'a -> w_tactic)
-                       (wc : named_context sigma) =
-  let hyps  = wc.it
-  and evd   = Evd.map wc.sigma sp in
-  let (wc' : named_context sigma) = extract_decl sp wc in
-  let (wc'',rslt) = wt wc' in 
-(*  if not (ids_eq wc wc'') then error "w_saving_focus"; *)
-  if wc'==wc'' then 
-    wt' rslt wc
-  else 
-    let wc''' = restore_decl sp evd wc'' in 
-    wt' rslt {it = hyps; sigma = wc'''.sigma} *)
-      
-let w_add_sign (id,t) (wc : named_context sigma) =
-  { it = Sign.add_named_decl (id,None,t) wc.it;
-    sigma = wc.sigma }
-
-let w_Focus sp wc = extract_decl sp wc
-
-let w_Underlying wc = wc.sigma
-let w_whd wc c      = Evarutil.whd_castappevar (w_Underlying wc) c
-let w_type_of wc c  =
-  type_of (Global.env_of_context wc.it) wc.sigma c
-let w_env     wc    = get_env wc
-let w_hyps    wc    = named_context (get_env wc)
-let w_defined_evar wc k      = Evd.is_defined (w_Underlying wc) k
-let w_const_value wc         = constant_value (w_env wc)
-let w_conv_x wc m n          = is_conv (w_env wc) (w_Underlying wc) m n
-let w_whd_betadeltaiota wc c = whd_betadeltaiota (w_env wc) (w_Underlying wc) c
-let w_hnf_constr wc c        = hnf_constr (w_env wc) (w_Underlying wc) c
-
-
-let w_Declare sp ty (wc : named_context sigma) =
-  let _ = w_type_of wc ty in (* Utile ?? *)
-  let sign = get_hyps wc in
-  let newdecl = mk_goal sign ty in 
-  ((rc_add wc (sp,newdecl)): named_context sigma)
-
-let w_Define sp c wc =
-  let spdecl = Evd.map (w_Underlying wc) sp in
-  let cty = 
-    try 
-      w_type_of (w_Focus sp wc) (mkCast (c,spdecl.evar_concl))
-    with 
-	Not_found -> error "Instantiation contains unlegal variables"
-      | (Type_errors.TypeError (e, Type_errors.UnboundVar v))-> 
-      errorlabstrm "w_Define"
-      (str "Cannot use variable " ++ pr_id v ++ str " to define " ++ 
-       str (string_of_existential sp))
-  in 
-  match spdecl.evar_body with
-    | Evar_empty ->
-    	let spdecl' = { evar_hyps = spdecl.evar_hyps;
-                       	evar_concl = spdecl.evar_concl;
-                       	evar_body = Evar_defined c }
-    	in 
-	  Proof_trees.rc_add wc (sp,spdecl')
-    | _ -> error "define_evar"
-
 
 (******************************************)
 (* Instantiation of existential variables *)
 (******************************************)
 
-(* The instantiate tactic *)
+(* w_tactic pour instantiate *) 
 
-let evars_of evc c = 
-  let rec evrec acc c =
-    match kind_of_term c with
-    | Evar (n, _) when Evd.in_dom evc n -> c :: acc
-    | _ -> fold_constr evrec acc c
-  in 
-  evrec [] c
+let w_refine ev rawc evd =
+  if Evd.is_defined (evars_of evd) ev then 
+    error "Instantiate called on already-defined evar";
+  let e_info = Evd.find (evars_of evd) ev in
+  let env = Evd.evar_env e_info in
+  let sigma,typed_c = 
+    try Pretyping.Default.understand_tcc (evars_of evd) env 
+      ~expected_type:e_info.evar_concl rawc 
+    with _ -> error ("The term is not well-typed in the environment of " ^
+			string_of_existential ev)
+  in
+    evar_define ev typed_c (evars_reset_evd sigma evd)
 
-let instantiate n c ido gl = 
-  let wc = Refiner.project_with_focus gl in
-  let evl = 
-    match ido with
-	None -> evars_of wc.sigma gl.it.evar_concl 
-      | Some (id,_,_) -> 
-	  let (_,_,typ)=Sign.lookup_named id gl.it.evar_hyps in
-	    evars_of wc.sigma typ in
-    if List.length evl < n then error "not enough evars";
-    let (n,_) as k = destEvar (List.nth evl (n-1)) in 
-      if Evd.is_defined wc.sigma n then 
-	error "Instantiate called on already-defined evar";
-      let wc' = w_Define n c wc in 
-	tclIDTAC {it = gl.it ; sigma = wc'.sigma}
-
-let pfic gls c =
-  let evc = gls.sigma in 
-  Constrintern.interp_constr evc (Global.env_of_context gls.it.evar_hyps) c
-
-(*
-let instantiate_tac = function
-  | [Integer n; Command com] ->
-      (fun gl -> instantiate n (pfic gl com) gl)
-  | [Integer n; Constr c] ->
-      (fun gl -> instantiate n c gl)
-  | _ -> invalid_arg "Instantiate called with bad arguments"
-*)
-
-(* vernac command existential *)
+(* vernac command Existential *)
 
 let instantiate_pf_com n com pfts = 
   let gls = top_goal_of_pftreestate pfts in
-  let wc = project_with_focus gls in
-  let sigma = (w_Underlying wc) in 
-  let (sp,evd) = 
+  let sigma = gls.sigma in 
+  let (sp,evi) (* as evc *) = 
     try
-      List.nth (Evd.non_instantiated sigma) (n-1) 
+      List.nth (Evarutil.non_instantiated sigma) (n-1) 
     with Failure _ -> 
-      error "not so many uninstantiated existential variables"
-      | Invalid_argument _ -> error "incorrect existential variable index"
-  in 
-  let c = Constrintern.interp_constr sigma (Evarutil.evar_env evd) com in     
-  let wc' = w_Define sp c wc in
-  let newgc = (w_Underlying wc') in
-  change_constraints_pftreestate newgc pfts
-
-
+      error "not so many uninstantiated existential variables" in 
+  let env = Evd.evar_env evi in
+  let rawc = Constrintern.intern_constr sigma env com in 
+  let evd = create_evar_defs sigma in
+  let evd' = w_refine sp rawc evd in
+  change_constraints_pftreestate (evars_of evd') pfts
diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli
index d57e1b84..baa6b19a 100644
--- a/proofs/evar_refiner.mli
+++ b/proofs/evar_refiner.mli
@@ -6,52 +6,21 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: evar_refiner.mli,v 1.28.2.2 2005/01/21 16:41:51 herbelin Exp $ i*)
+(*i $Id: evar_refiner.mli 9154 2006-09-20 17:18:18Z corbinea $ i*)
 
 (*i*)
 open Names
 open Term
-open Sign
 open Environ
 open Evd
 open Refiner
-open Proof_type
 (*i*)
 
-type wc = named_context sigma (* for a better reading of the following *)
-
 (* Refinement of existential variables. *)
 
-val rc_of_pfsigma : proof_tree sigma -> wc
-val rc_of_glsigma : goal sigma -> wc
-
-(* A [w_tactic] is a tactic which modifies the a set of evars of which
-   a goal depend, either by instantiating one, or by declaring a new
-   dependent goal *)
-type w_tactic = wc -> wc
-
-val startWalk : goal sigma -> wc * (wc -> tactic)
-
-val extract_decl : evar -> w_tactic
-val restore_decl : evar -> evar_info -> w_tactic
-val w_Declare    : evar -> types -> w_tactic
-val w_Define     : evar -> constr -> w_tactic
-
-val w_Underlying : wc -> evar_map
-val w_env        : wc -> env
-val w_hyps       : wc -> named_context
-val w_whd        : wc -> constr -> constr
-val w_type_of    : wc -> constr -> constr
-val w_add_sign   : (identifier * types) -> w_tactic
+val w_refine : evar -> Rawterm.rawconstr  -> evar_defs -> evar_defs
 
-val w_whd_betadeltaiota : wc -> constr -> constr
-val w_hnf_constr        : wc -> constr -> constr
-val w_conv_x            : wc -> constr -> constr -> bool
-val w_const_value       : wc -> constant -> constr
-val w_defined_evar      : wc -> existential_key -> bool
+val instantiate_pf_com :
+  int -> Topconstr.constr_expr -> pftreestate -> pftreestate
 
-val instantiate : int -> constr -> identifier Tacexpr.gsimple_clause -> tactic
-(*i
-val instantiate_tac : tactic_arg list -> tactic
-i*)
-val instantiate_pf_com : int -> Topconstr.constr_expr -> pftreestate -> pftreestate
+(* the instantiate tactic was moved to [tactics/evar_tactics.ml] *) 
diff --git a/proofs/logic.ml b/proofs/logic.ml
index cefeb8ae..92225948 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: logic.ml,v 1.80.2.5 2005/12/17 21:15:52 herbelin Exp $ *)
+(* $Id: logic.ml 9601 2007-02-06 21:37:59Z herbelin $ *)
 
 open Pp
 open Util
@@ -25,7 +25,6 @@ open Proof_trees
 open Proof_type
 open Typeops
 open Type_errors
-open Coqast
 open Retyping
 open Evarutil
  
@@ -40,114 +39,56 @@ type refiner_error =
   | NonLinearProof of constr
 
   (* Errors raised by the tactics *)
-  | CannotUnify of constr * constr
-  | CannotUnifyBindingType of constr * constr
-  | CannotGeneralize of constr
   | IntroNeedsProduct
   | DoesNotOccurIn of constr * identifier
-  | NoOccurrenceFound of constr
 
 exception RefinerError of refiner_error
 
 open Pretype_errors
 
-let catchable_exception = function
-  | Util.UserError _ | TypeError _ | RefinerError _
-  | Stdpp.Exc_located(_,(Util.UserError _ | TypeError _ | RefinerError _ |
-    Nametab.GlobalizationError _ | PretypeError (_,VarNotFound _) | 
-    Indtypes.InductiveError (Indtypes.NotAllowedCaseAnalysis _ ))) -> true
+let rec catchable_exception = function
+  | Stdpp.Exc_located(_,e) -> catchable_exception e
+  | Util.UserError _ | TypeError _ 
+  | RefinerError _ | Indrec.RecursionSchemeError _
+  | Nametab.GlobalizationError _ | PretypeError (_,VarNotFound _)
+  (* unification errors *)
+  | PretypeError(_,(CannotUnify _|CannotGeneralize _|NoOccurrenceFound _|
+      CannotUnifyBindingType _|NotClean _)) -> true
   | _ -> false
 
-let error_cannot_unify (m,n) =
-  raise (RefinerError (CannotUnify (m,n)))
-
 (* Tells if the refiner should check that the submitted rules do not
    produce invalid subgoals *)
 let check = ref false
-
-let without_check tac gl =
-  let c = !check in
-  check := false;
-  try let r = tac gl in check := c; r with e -> check := c; raise e
-
 let with_check = Options.with_option check
-   
+
 (************************************************************************)
 (************************************************************************)
 (* Implementation of the structural rules (moving and deleting
    hypotheses around) *)
 
-let check_clear_forward cleared_ids used_ids whatfor =
-  if !check && cleared_ids<>[] then
-    Idset.iter
-      (fun id' ->
-        if List.mem id' cleared_ids then
-          error (string_of_id id'^" is used in "^whatfor))
-      used_ids
-
 (* The Clear tactic: it scans the context for hypotheses to be removed
    (instead of iterating on the list of identifier to be removed, which
    forces the user to give them in order). *)
-let clear_hyps ids gl =
-  let env = Global.env() in
-  let (nhyps,rmv) =
-    Sign.fold_named_context
-      (fun (id,c,ty as d) (hyps,rmv) ->
-        if List.mem id ids then
-          (hyps,id::rmv)
-        else begin
-          check_clear_forward rmv (global_vars_set_of_decl env d)
-            ("hypothesis "^string_of_id id);
-          (add_named_decl d hyps, rmv)
-        end)
-      gl.evar_hyps
-      ~init:(empty_named_context,[]) in
-  let ncl = gl.evar_concl in
-  check_clear_forward rmv (global_vars_set env ncl) "conclusion";
-  mk_goal nhyps ncl
+let clear_hyps sigma ids gl =
+  let evd = ref (Evd.create_evar_defs sigma) in
+  let ngl = Evarutil.clear_hyps_in_evi evd gl ids in
+    (ngl, evars_of !evd)
 
 (* The ClearBody tactic *)
 
 (* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and
-   returns [tail::(f head (id,_,_) tail)] *)
+   returns [tail::(f head (id,_,_) (rev tail))] *)
 let apply_to_hyp sign id f =
-  let found = ref false in
-  let sign' =
-    fold_named_context_both_sides
-      (fun head (idc,c,ct as d) tail ->
-	 if idc = id then begin
-	   found := true; f head d tail
-	 end else 
-	   add_named_decl d head)
-      sign ~init:empty_named_context
-  in
-  if (not !check) || !found then sign' else error "No such assumption"
-
-(* Same but with whole environment *)
-let apply_to_hyp2 env id f =
-  let found = ref false in
-  let env' =
-    fold_named_context_both_sides
-      (fun env (idc,c,ct as d) tail ->
-	 if idc = id then begin
-	   found := true; f env d tail
-	 end else 
-	   push_named d env)
-      (named_context env) ~init:(reset_context env)
-  in
-  if (not !check) || !found then env' else error "No such assumption"
+  try apply_to_hyp sign id f 
+  with Hyp_not_found -> 
+    if !check then error "No such assumption"
+    else sign
 
 let apply_to_hyp_and_dependent_on sign id f g =
-  let found = ref false in
-  let sign =
-    Sign.fold_named_context
-      (fun (idc,_,_ as d) oldest ->
-         if idc = id then (found := true; add_named_decl (f d) oldest)
-         else if !found then add_named_decl (g d) oldest
-         else add_named_decl d oldest)
-      sign ~init:empty_named_context
-  in
-  if (not !check) || !found then sign else error "No such assumption"
+  try apply_to_hyp_and_dependent_on sign id f g 
+  with Hyp_not_found -> 
+    if !check then error "No such assumption"
+    else sign
 
 let check_typability env sigma c =
   if !check then let _ = type_of env sigma c in () 
@@ -162,26 +103,24 @@ let recheck_typability (what,id) env sigma t =
       ("The correctness of "^s^" relies on the body of "^(string_of_id id))
   
 let remove_hyp_body env sigma id =
-  apply_to_hyp2 env id
-    (fun env (_,c,t) tail ->
-       match c with
-         | None -> error ((string_of_id id)^" is not a local definition")
-         | Some c ->
-             let env' = push_named (id,None,t) env in
-             if !check then 
-               ignore
-                 (Sign.fold_named_context 
-                    (fun (id',c,t as d) env'' ->
-                       (match c with
-                          | None -> 
-                              recheck_typability (Some id',id) env'' sigma t
-                          | Some b ->
-                              let b' = mkCast (b,t) in
-                              recheck_typability (Some id',id) env'' sigma b');
-                       push_named d env'')
-                    (List.rev tail) ~init:env');
-             env')
-
+  let sign =
+    apply_to_hyp_and_dependent_on (named_context_val env) id
+      (fun (_,c,t) _ ->
+	match c with
+	| None -> error ((string_of_id id)^" is not a local definition")
+	| Some c ->(id,None,t))
+      (fun (id',c,t as d) sign ->
+	(if !check then
+	  begin 
+	    let env = reset_with_named_context sign env in
+	    match c with
+	    | None ->  recheck_typability (Some id',id) env sigma t
+	    | Some b ->
+		let b' = mkCast (b,DEFAULTcast, t) in
+		recheck_typability (Some id',id) env sigma b'
+	  end;d))
+  in
+  reset_with_named_context sign env 
 
 (* Auxiliary functions for primitive MOVE tactic
  *
@@ -200,7 +139,7 @@ let split_sign hfrom hto l =
       	else 
 	  splitrec (d::left) (toleft or (hyp = hto)) right
   in 
-  splitrec [] false l
+    splitrec [] false l
 
 let move_after with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto =
   let env = Global.env() in
@@ -231,9 +170,16 @@ let move_after with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto =
 	  moverec first' middle' right
   in
   if toleft then 
-    List.rev_append (moverec [] [declfrom] left) right
+    let right = 
+      List.fold_right push_named_context_val right empty_named_context_val in
+    List.fold_left (fun sign d -> push_named_context_val d sign)
+      right (moverec [] [declfrom] left) 
   else 
-    List.rev_append left (moverec [] [declfrom] right)
+    let right = 
+      List.fold_right push_named_context_val
+	(moverec [] [declfrom] right) empty_named_context_val in
+    List.fold_left (fun sign d -> push_named_context_val d sign)
+      right left
 
 let check_backward_dependencies sign d =
   if not (Idset.for_all
@@ -252,25 +198,35 @@ let check_forward_dependencies id tail =
 		^ (string_of_id id')))
     tail
 
+let check_goal_dependency id cl =
+  let env = Global.env() in
+    if Idset.mem id (global_vars_set env cl) then
+      error (string_of_id id^" is used in conclusion")
 
 let rename_hyp id1 id2 sign =
   apply_to_hyp_and_dependent_on sign id1
-    (fun (_,b,t) -> (id2,b,t))
-    (map_named_declaration (replace_vars [id1,mkVar id2]))
+    (fun (_,b,t) _ -> (id2,b,t))
+    (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d)
 
-let replace_hyp sign id d =
+let replace_hyp sign id d cl =
+  if !check then
+    check_goal_dependency id cl;
   apply_to_hyp sign id
     (fun sign _ tail ->
-       if !check then
-	 (check_backward_dependencies sign d;
-	  check_forward_dependencies id tail);
-       add_named_decl d sign)
+      if !check then
+	(check_backward_dependencies sign d;
+	 check_forward_dependencies id tail); 
+      d)
 
+(* why we dont check that id does not appear in tail ??? *)
 let insert_after_hyp sign id d =
-  apply_to_hyp sign id
-    (fun sign d' _ ->
-       if !check then check_backward_dependencies sign d;
-       add_named_decl d (add_named_decl d' sign))
+  try 
+    insert_after_hyp sign id d 
+      (fun sign ->
+	if !check then check_backward_dependencies sign d)
+  with Hyp_not_found ->
+    if !check then error "No such assumption"
+    else sign
 
 (************************************************************************)
 (************************************************************************)
@@ -282,7 +238,7 @@ variables only in Application and Case *)
 let collect_meta_variables c = 
   let rec collrec acc c = match kind_of_term c with
     | Meta mv -> mv::acc
-    | Cast(c,_) -> collrec acc c
+    | Cast(c,_,_) -> collrec acc c
     | (App _| Case _) -> fold_constr collrec acc c
     | _ -> acc
   in 
@@ -298,6 +254,7 @@ let goal_type_of env sigma c =
 let rec mk_refgoals sigma goal goalacc conclty trm =
   let env = evar_env goal in
   let hyps = goal.evar_hyps in
+  let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in
 (*
    if  not (occur_meta trm) then
     let t'ty = (unsafe_machine env sigma trm).uj_type in 	
@@ -311,13 +268,22 @@ let rec mk_refgoals sigma goal goalacc conclty trm =
           raise (RefinerError (OccurMetaGoal conclty));
 	(mk_goal hyps (nf_betaiota conclty))::goalacc, conclty
 
-    | Cast (t,ty) ->
+    | Cast (t,_, ty) ->
 	check_typability env sigma ty;
 	check_conv_leq_goal env sigma trm ty conclty;
 	mk_refgoals sigma goal goalacc ty t
 
     | App (f,l) ->
-	let (acc',hdty) = mk_hdgoals sigma goal goalacc f in
+	let (acc',hdty) =
+	  match kind_of_term f with
+	    | (Ind _ (* needed if defs in Type are polymorphic: | Const _*))
+		when not (array_exists occur_meta l) (* we could be finer *) ->
+		(* Sort-polymorphism of definition and inductive types *)
+		goalacc, 
+		type_of_global_reference_knowing_parameters env sigma f l
+	    | _ -> 
+		mk_hdgoals sigma goal goalacc f
+	in
 	let (acc'',conclty') =
 	  mk_arggoals sigma goal acc' hdty (Array.to_list l) in
 	check_conv_leq_goal env sigma trm conclty' conclty;
@@ -345,13 +311,24 @@ let rec mk_refgoals sigma goal goalacc conclty trm =
 and mk_hdgoals sigma goal goalacc trm =
   let env = evar_env goal in
   let hyps = goal.evar_hyps in
+  let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in
   match kind_of_term trm with
-    | Cast (c,ty) when isMeta c ->
+    | Cast (c,_, ty) when isMeta c ->
 	check_typability env sigma ty;
 	(mk_goal hyps (nf_betaiota ty))::goalacc,ty
 
+    | Cast (t,_, ty) ->
+	check_typability env sigma ty;
+	mk_refgoals sigma goal goalacc ty t
+
     | App (f,l) ->
-	let (acc',hdty) = mk_hdgoals sigma goal goalacc f in
+	let (acc',hdty) = 
+	  if isInd f or isConst f 
+	     & not (array_exists occur_meta l) (* we could be finer *)
+	  then
+	    (goalacc,type_of_global_reference_knowing_parameters env sigma f l)
+	  else mk_hdgoals sigma goal goalacc f
+	in
 	mk_arggoals sigma goal acc' hdty (Array.to_list l)
 
     | Case (_,p,c,lf) ->
@@ -397,16 +374,26 @@ let error_use_instantiate () =
 
 let convert_hyp sign sigma (id,b,bt as d) =
   apply_to_hyp sign id
-    (fun sign (_,c,ct) _ ->
+    (fun _ (_,c,ct) _ ->
        let env = Global.env_of_context sign in
        if !check && not (is_conv env sigma bt ct) then
-	 (* Just a warning in V8.0bugfix for compatibility *)
-	 msgnl (str "Compatibility warning: Hazardeous change of the type of " ++ pr_id id ++ 
-	       str " (not well-typed in current signature)");
+	 error ("Incorrect change of the type of "^(string_of_id id));
        if !check && not (option_compare (is_conv env sigma) b c) then
-	 msgnl (str "Compatibility warning: Hazardeous change of the body of " ++ pr_id id ++
-	       str " (not well-typed in current signature)");
-       add_named_decl d sign)
+	 error ("Incorrect change of the body of "^(string_of_id id));
+       d)
+
+(* Normalizing evars in a goal. Called by tactic Local_constraints
+   (i.e. when the sigma of the proof tree changes). Detect if the
+   goal is unchanged *)
+let norm_goal sigma gl =
+  let red_fun = Evarutil.nf_evar sigma in
+  let ncl = red_fun gl.evar_concl in
+  let ngl =
+    { gl with 
+	evar_concl = ncl;
+	evar_hyps = map_named_val red_fun gl.evar_hyps } in
+    if Evd.eq_evar_info ngl gl then None else Some ngl
+
 
 
 (************************************************************************)
@@ -417,23 +404,24 @@ let prim_refiner r sigma goal =
   let env = evar_env goal in
   let sign = goal.evar_hyps in
   let cl = goal.evar_concl in
+  let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in
   match r with
     (* Logical rules *)
     | Intro id ->
-    	if !check && mem_named_context id sign then
+    	if !check && mem_named_context id (named_context_of_val sign) then
 	  error "New variable is already declared";
         (match kind_of_term (strip_outer_cast cl) with
 	   | Prod (_,c1,b) ->
 	       if occur_meta c1 then error_use_instantiate();
-	       let sg = mk_goal (add_named_decl (id,None,c1) sign)
+	       let sg = mk_goal (push_named_context_val (id,None,c1) sign)
 			  (subst1 (mkVar id) b) in
-	       [sg]
+	       ([sg], sigma)
 	   | LetIn (_,c1,t1,b) ->
 	       if occur_meta c1 or occur_meta t1 then error_use_instantiate();
 	       let sg =
-		 mk_goal (add_named_decl (id,Some c1,t1) sign)
+		 mk_goal (push_named_context_val (id,Some c1,t1) sign)
 		   (subst1 (mkVar id) b) in
-	       [sg]
+	       ([sg], sigma)
 	   | _ ->
 	       raise (RefinerError IntroNeedsProduct))
 	
@@ -441,24 +429,24 @@ let prim_refiner r sigma goal =
 	(match kind_of_term (strip_outer_cast cl) with
            | Prod (_,c1,b) ->
 	       if occur_meta c1 then error_use_instantiate();
-	       let sign' = replace_hyp sign id (id,None,c1) in
+	       let sign' = replace_hyp sign id (id,None,c1) cl in
 	       let sg = mk_goal sign' (subst1 (mkVar id) b) in
-	       [sg]
+	       ([sg], sigma)
            | LetIn (_,c1,t1,b) ->
 	       if occur_meta c1 then error_use_instantiate();
-	       let sign' = replace_hyp sign id (id,Some c1,t1) in
+	       let sign' = replace_hyp sign id (id,Some c1,t1) cl in
 	       let sg = mk_goal sign' (subst1 (mkVar id) b) in
-	       [sg]
+	       ([sg], sigma)
 	   | _ ->
 	       raise (RefinerError IntroNeedsProduct))
 	
     | Cut (b,id,t) ->
-    	if !check && mem_named_context id sign then
+    	if !check && mem_named_context id (named_context_of_val sign) then
 	  error "New variable is already declared";
         if occur_meta t then error_use_instantiate();
         let sg1 = mk_goal sign (nf_betaiota t) in
-        let sg2 = mk_goal (add_named_decl (id,None,t) sign) cl in
-        if b then [sg1;sg2] else [sg2;sg1]  
+        let sg2 = mk_goal (push_named_context_val (id,None,t) sign) cl in
+        if b then ([sg1;sg2],sigma) else ([sg2;sg1], sigma)
 
     | FixRule (f,n,rest) ->
      	let rec check_ind env k cl = 
@@ -481,13 +469,13 @@ let prim_refiner r sigma goal =
 	      if not (sp=sp') then 
 		error ("fixpoints should be on the same " ^ 
 		       "mutual inductive declaration");
-	      if !check && mem_named_context f sign then 
+	      if !check && mem_named_context f (named_context_of_val sign) then
 		error "name already used in the environment";
-	      mk_sign (add_named_decl (f,None,ar) sign) oth
+	      mk_sign (push_named_context_val (f,None,ar) sign) oth
 	  | [] -> 
 	      List.map (fun (_,_,c) -> mk_goal sign c) all
 	in 
-	mk_sign sign all
+	  (mk_sign sign all, sigma)
 	
     | Cofix (f,others) ->
      	let rec check_is_coind env cl = 
@@ -499,286 +487,195 @@ let prim_refiner r sigma goal =
 		  let _ = find_coinductive env sigma b in ()
                 with Not_found -> 
 		  error ("All methods must construct elements " ^
-			  "in coinductive types")
+			  "in coinductiv-> goal
+e types")
 	in
 	let all = (f,cl)::others in
      	List.iter (fun (_,c) -> check_is_coind env c) all;
         let rec mk_sign sign = function 
           | (f,ar)::oth ->
 	      (try
-                (let _ = Sign.lookup_named f sign in
+                (let _ = lookup_named_val f sign in
                 error "name already used in the environment")
               with
               |	Not_found ->
-                  mk_sign (add_named_decl (f,None,ar) sign) oth)
+                  mk_sign (push_named_context_val (f,None,ar) sign) oth)
 	  | [] -> List.map (fun (_,c) -> mk_goal sign c) all
      	in 
-	mk_sign sign all
+	  (mk_sign sign all, sigma)
 
     | Refine c ->
         if not (list_distinct (collect_meta_variables c)) then
           raise (RefinerError (NonLinearProof c));
 	let (sgl,cl') = mk_refgoals sigma goal [] cl c in
 	let sgl = List.rev sgl in
-	sgl
+	  (sgl, sigma)
 
     (* Conversion rules *)
-    | Convert_concl cl' ->
+    | Convert_concl (cl',_) ->
 	check_typability env sigma cl';
 	if (not !check) || is_conv_leq env sigma cl' cl then
           let sg = mk_goal sign cl' in
-          [sg]
+          ([sg], sigma)
 	else 
 	  error "convert-concl rule passed non-converting term"
 
     | Convert_hyp (id,copt,ty) ->
-	[mk_goal (convert_hyp sign sigma (id,copt,ty)) cl]
+	([mk_goal (convert_hyp sign sigma (id,copt,ty)) cl], sigma)
 
     (* And now the structural rules *)
     | Thin ids -> 
-	[clear_hyps ids goal]
-
+	let (ngl, nsigma) = clear_hyps sigma ids goal in
+	  ([ngl], nsigma)
+	
     | ThinBody ids ->
 	let clear_aux env id =
           let env' = remove_hyp_body env sigma id in
-          if !check then recheck_typability (None,id) env' sigma cl;
-          env'
+            if !check then recheck_typability (None,id) env' sigma cl;
+            env'
 	in
-	let sign' = named_context (List.fold_left clear_aux env ids) in
+	let sign' = named_context_val (List.fold_left clear_aux env ids) in
      	let sg = mk_goal sign' cl in
-     	[sg]
+     	  ([sg], sigma)
 
     | Move (withdep, hfrom, hto) ->
-  	let (left,right,declfrom,toleft) = split_sign hfrom hto sign in
+  	let (left,right,declfrom,toleft) = 
+	  split_sign hfrom hto (named_context_of_val sign) in
   	let hyps' = 
 	  move_after withdep toleft (left,declfrom,right) hto in
-  	[mk_goal hyps' cl]
+  	  ([mk_goal hyps' cl], sigma)
 
     | Rename (id1,id2) ->
-        if !check & id1 <> id2 & List.mem id2 (ids_of_named_context sign) then
+        if !check & id1 <> id2 &&
+	  List.mem id2 (ids_of_named_context (named_context_of_val sign)) then
           error ((string_of_id id2)^" is already used");
         let sign' = rename_hyp id1 id2 sign in
         let cl' = replace_vars [id1,mkVar id2] cl in
-        [mk_goal sign' cl']
+          ([mk_goal sign' cl'], sigma)
+
+    | Change_evars ->
+        match norm_goal sigma goal with
+	    Some ngl -> ([ngl],sigma)
+          | None -> ([goal], sigma)
 
 (************************************************************************)
 (************************************************************************)
 (* Extracting a proof term from the proof tree *)
 
 (* Util *)
+
+type variable_proof_status = ProofVar | SectionVar of identifier
+
+type proof_variable = name * variable_proof_status
+
+let subst_proof_vars = 
+  let rec aux p vars =
+    let _,subst =
+      List.fold_left (fun (n,l) var ->
+        let t = match var with
+          | Anonymous,_ -> l
+          | Name id, ProofVar -> (id,mkRel n)::l
+          | Name id, SectionVar id' -> (id,mkVar id')::l in
+        (n+1,t)) (p,[]) vars
+    in replace_vars (List.rev subst)
+  in aux 1
+         
 let rec rebind id1 id2 = function
-  | [] -> []
-  | id::l -> 
-      if id = id1 then id2::l else
+  | [] -> [Name id2,SectionVar id1]
+  | (na,_ as x)::l -> 
+      if na = Name id1 then (Name id2,ProofVar)::l else
         let l' = rebind id1 id2 l in
-        if id = id2 then
-          (* TODO: find a more elegant way to hide a variable *)
-          (id_of_string "_@")::l'
-        else id::l'
-
-let prim_extractor subfun vl pft =
-  let cl = pft.goal.evar_concl in
-  match pft.ref with
-    | Some (Prim (Intro id), [spf]) ->
-	(match kind_of_term (strip_outer_cast cl) with
-	   | Prod (_,ty,_) ->
-	       let cty = subst_vars vl ty in
-	       mkLambda (Name id, cty, subfun (id::vl) spf)
-	   | LetIn (_,b,ty,_) ->
-	       let cb = subst_vars vl b in
-	       let cty = subst_vars vl ty in
-	       mkLetIn (Name id, cb, cty, subfun (id::vl) spf)
-	   | _ -> error "incomplete proof!")
-	
-    | Some (Prim (Intro_replacing id),[spf]) ->
-	(match kind_of_term (strip_outer_cast cl) with
-	   | Prod (_,ty,_) ->
-	       let cty = subst_vars vl ty in
-	       mkLambda (Name id, cty, subfun (id::vl) spf)
-	   | LetIn (_,b,ty,_) ->
-	       let cb = subst_vars vl b in
-	       let cty = subst_vars vl ty in
-	       mkLetIn (Name id, cb, cty, subfun (id::vl) spf)
-	   | _ -> error "incomplete proof!")
-
-    | Some (Prim (Cut (b,id,t)),[spf1;spf2]) ->
-        let spf1, spf2 = if b then spf1, spf2 else spf2, spf1 in
-	mkLetIn (Name id,subfun vl spf1,subst_vars vl t,subfun (id::vl) spf2)
-
-    | Some (Prim (FixRule (f,n,others)),spfl) ->
-	let all = Array.of_list ((f,n,cl)::others) in
-	let lcty = Array.map (fun (_,_,ar) -> subst_vars vl ar) all in
-	let names = Array.map (fun (f,_,_) -> Name f) all in
-	let vn = Array.map (fun (_,n,_) -> n-1) all in
-	let newvl = List.fold_left (fun vl (id,_,_)->(id::vl)) (f::vl)others in
-	let lfix = Array.map (subfun newvl) (Array.of_list spfl) in
-	mkFix ((vn,0),(names,lcty,lfix))	
-
-    | Some (Prim (Cofix (f,others)),spfl) ->
-	let all = Array.of_list ((f,cl)::others) in
-	let lcty = Array.map (fun (_,ar) -> subst_vars vl ar) all in
-	let names  = Array.map (fun (f,_) -> Name f) all in
-	let newvl = List.fold_left (fun vl (id,_)->(id::vl)) (f::vl) others in 
-	let lfix = Array.map (subfun newvl) (Array.of_list spfl) in
-	mkCoFix (0,(names,lcty,lfix))
-	  
-    | Some (Prim (Refine c),spfl) ->
-	let mvl = collect_meta_variables c in
-	let metamap = List.combine mvl (List.map (subfun vl) spfl) in
-	let cc = subst_vars vl c in 
-	plain_instance metamap cc
-
-    (* Structural and conversion rules do not produce any proof *)
-    | Some (Prim (Convert_concl _),[pf]) ->
-	subfun vl pf
-	
-    | Some (Prim (Convert_hyp _),[pf]) ->
-	subfun vl pf
-
-    | Some (Prim (Thin _),[pf]) ->
-     (* No need to make ids Anonymous in vl: subst_vars take the more recent *)
-	subfun vl pf
-	
-    | Some (Prim (ThinBody _),[pf]) ->
-	subfun vl pf
-	
-    | Some (Prim (Move _),[pf]) ->
-	subfun vl pf
+        if na = Name id2 then (Anonymous,ProofVar)::l' else x::l'
 
-    | Some (Prim (Rename (id1,id2)),[pf]) ->
-	subfun (rebind id1 id2 vl) pf
+let add_proof_var id vl = (Name id,ProofVar)::vl
 
-    | Some _ -> anomaly "prim_extractor"
+let proof_variable_index x = 
+  let rec aux n = function
+    | (Name id,ProofVar)::l when x = id -> n
+    | _::l ->  aux (n+1) l
+    | [] -> raise Not_found
+  in 
+  aux 1
 
-    | None-> error "prim_extractor handed incomplete proof"
+let prim_extractor subfun vl pft =
+  let cl = pft.goal.evar_concl in
+    match pft.ref with
+      | Some (Prim (Intro id), [spf]) ->
+	  (match kind_of_term (strip_outer_cast cl) with
+	    | Prod (_,ty,_) ->
+		let cty = subst_proof_vars vl ty in
+		  mkLambda (Name id, cty, subfun (add_proof_var id vl) spf)
+	    | LetIn (_,b,ty,_) ->
+		let cb = subst_proof_vars vl b in
+		let cty = subst_proof_vars vl ty in
+		  mkLetIn (Name id, cb, cty, subfun (add_proof_var id vl) spf)
+	    | _ -> error "incomplete proof!")
+	    
+      | Some (Prim (Intro_replacing id),[spf]) ->
+	  (match kind_of_term (strip_outer_cast cl) with
+	    | Prod (_,ty,_) ->
+		let cty = subst_proof_vars vl ty in
+		  mkLambda (Name id, cty, subfun (add_proof_var id vl) spf)
+	    | LetIn (_,b,ty,_) ->
+		let cb = subst_proof_vars vl b in
+		let cty = subst_proof_vars vl ty in
+		  mkLetIn (Name id, cb, cty, subfun (add_proof_var id vl) spf)
+	    | _ -> error "incomplete proof!")
+
+      | Some (Prim (Cut (b,id,t)),[spf1;spf2]) ->
+          let spf1, spf2 = if b then spf1, spf2 else spf2, spf1 in
+	    mkLetIn (Name id,subfun vl spf1,subst_proof_vars vl t,
+                    subfun (add_proof_var id vl) spf2)
+
+      | Some (Prim (FixRule (f,n,others)),spfl) ->
+	  let all = Array.of_list ((f,n,cl)::others) in
+	  let lcty = Array.map (fun (_,_,ar) -> subst_proof_vars vl ar) all in
+	  let names = Array.map (fun (f,_,_) -> Name f) all in
+	  let vn = Array.map (fun (_,n,_) -> n-1) all in
+	  let newvl = List.fold_left (fun vl (id,_,_) -> add_proof_var id vl)
+            (add_proof_var f vl) others in
+	  let lfix = Array.map (subfun newvl) (Array.of_list spfl) in
+	    mkFix ((vn,0),(names,lcty,lfix))	
+
+      | Some (Prim (Cofix (f,others)),spfl) ->
+	  let all = Array.of_list ((f,cl)::others) in
+	  let lcty = Array.map (fun (_,ar) -> subst_proof_vars vl ar) all in
+	  let names  = Array.map (fun (f,_) -> Name f) all in
+	  let newvl = List.fold_left (fun vl (id,_)-> add_proof_var id vl)
+            (add_proof_var f vl) others in 
+	  let lfix = Array.map (subfun newvl) (Array.of_list spfl) in
+	    mkCoFix (0,(names,lcty,lfix))
+	      
+      | Some (Prim (Refine c),spfl) ->
+	  let mvl = collect_meta_variables c in
+	  let metamap = List.combine mvl (List.map (subfun vl) spfl) in
+	  let cc = subst_proof_vars vl c in 
+	    plain_instance metamap cc
+
+      (* Structural and conversion rules do not produce any proof *)
+      | Some (Prim (Convert_concl (t,k)),[pf]) ->
+	  if k = DEFAULTcast then subfun vl pf
+	  else mkCast (subfun vl pf,k,subst_proof_vars vl cl)
+      | Some (Prim (Convert_hyp _),[pf]) ->
+	  subfun vl pf
+
+      | Some (Prim (Thin _),[pf]) ->
+	  (* No need to make ids Anon in vl: subst_proof_vars take the most recent*)
+	  subfun vl pf
+	    
+      | Some (Prim (ThinBody _),[pf]) ->
+	  subfun vl pf
+	    
+      | Some (Prim (Move _),[pf]) ->
+	  subfun vl pf
+
+      | Some (Prim (Rename (id1,id2)),[pf]) ->
+	  subfun (rebind id1 id2 vl) pf
+
+      | Some (Prim Change_evars, [pf]) ->
+	  subfun vl pf
+
+      | Some _ -> anomaly "prim_extractor"
+
+      | None-> error "prim_extractor handed incomplete proof"
 	  
-(* Pretty-printer *)
-
-open Printer
-
-let prterm x = prterm_env (Global.env()) x
-
-let pr_prim_rule_v7 = function
-  | Intro id -> 
-      str"Intro " ++ pr_id id
-	
-  | Intro_replacing id -> 
-      (str"intro replacing "  ++ pr_id id)
-	
-  | Cut (b,id,t) ->
-      if b then
-        (str"Assert " ++ prterm t)
-      else
-        (str"Cut " ++ prterm t ++ str ";[Intro " ++ pr_id id ++ str "|Idtac]")
-	
-  | FixRule (f,n,[]) ->
-      (str"Fix " ++ pr_id f ++ str"/" ++ int n)
-      
-  | FixRule (f,n,others) -> 
-      let rec print_mut = function
-	| (f,n,ar)::oth -> 
-           pr_id f ++ str"/" ++ int n ++ str" : " ++ prterm ar ++ print_mut oth
-        | [] -> mt () in
-      (str"Fix " ++ pr_id f ++ str"/" ++ int n ++
-         str" with " ++ print_mut others)
-
-  | Cofix (f,[]) ->
-      (str"Cofix " ++ pr_id f)
-
-  | Cofix (f,others) ->
-      let rec print_mut = function
-	| (f,ar)::oth ->
-	  (pr_id f ++ str" : " ++ prterm ar ++ print_mut oth)
-        | [] -> mt () in
-      (str"Cofix " ++ pr_id f ++  str" with " ++ print_mut others)
-
-  | Refine c -> 
-      str(if occur_meta c then "Refine " else "Exact ") ++
-      Constrextern.with_meta_as_hole prterm c
-      
-  | Convert_concl c ->
-      (str"Change "  ++ prterm c)
-      
-  | Convert_hyp (id,None,t) ->
-      (str"Change "  ++ prterm t  ++ spc ()  ++ str"in "  ++ pr_id id)
-
-  | Convert_hyp (id,Some c,t) ->
-      (str"Change "  ++ prterm c  ++ spc ()  ++ str"in "
-       ++ pr_id id ++ str" (Type of "  ++ pr_id id ++ str ")")
-      
-  | Thin ids ->
-      (str"Clear "  ++ prlist_with_sep pr_spc pr_id ids)
-      
-  | ThinBody ids ->
-      (str"ClearBody "  ++ prlist_with_sep pr_spc pr_id ids)
-      
-  | Move (withdep,id1,id2) ->
-      (str (if withdep then "Dependent " else "") ++
-	 str"Move "  ++ pr_id id1 ++ str " after " ++ pr_id id2)
-
-  | Rename (id1,id2) ->
-      (str "Rename " ++ pr_id id1 ++ str " into " ++ pr_id id2)
-
-let pr_prim_rule_v8 = function
-  | Intro id -> 
-      str"intro " ++ pr_id id
-	
-  | Intro_replacing id -> 
-      (str"intro replacing "  ++ pr_id id)
-	
-  | Cut (b,id,t) ->
-      if b then
-        (str"assert " ++ prterm t)
-      else
-        (str"cut " ++ prterm t ++ str ";[intro " ++ pr_id id ++ str "|idtac]")
-	
-  | FixRule (f,n,[]) ->
-      (str"fix " ++ pr_id f ++ str"/" ++ int n)
-      
-  | FixRule (f,n,others) -> 
-      let rec print_mut = function
-	| (f,n,ar)::oth -> 
-           pr_id f ++ str"/" ++ int n ++ str" : " ++ prterm ar ++ print_mut oth
-        | [] -> mt () in
-      (str"fix " ++ pr_id f ++ str"/" ++ int n ++
-         str" with " ++ print_mut others)
-
-  | Cofix (f,[]) ->
-      (str"cofix " ++ pr_id f)
-
-  | Cofix (f,others) ->
-      let rec print_mut = function
-	| (f,ar)::oth ->
-	  (pr_id f ++ str" : " ++ prterm ar ++ print_mut oth)
-        | [] -> mt () in
-      (str"cofix " ++ pr_id f ++  str" with " ++ print_mut others)
-
-  | Refine c -> 
-      str(if occur_meta c then "refine " else "exact ") ++
-      Constrextern.with_meta_as_hole prterm c
-      
-  | Convert_concl c ->
-      (str"change "  ++ prterm c)
-      
-  | Convert_hyp (id,None,t) ->
-      (str"change "  ++ prterm t  ++ spc ()  ++ str"in "  ++ pr_id id)
-
-  | Convert_hyp (id,Some c,t) ->
-      (str"change "  ++ prterm c  ++ spc ()  ++ str"in "
-       ++ pr_id id ++ str" (type of "  ++ pr_id id ++ str ")")
-      
-  | Thin ids ->
-      (str"clear "  ++ prlist_with_sep pr_spc pr_id ids)
-      
-  | ThinBody ids ->
-      (str"clearbody "  ++ prlist_with_sep pr_spc pr_id ids)
-      
-  | Move (withdep,id1,id2) ->
-      (str (if withdep then "dependent " else "") ++
-	 str"move "  ++ pr_id id1 ++ str " after " ++ pr_id id2)
-
-  | Rename (id1,id2) ->
-      (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2)
-
-let pr_prim_rule t =
-  if! Options.v7 then pr_prim_rule_v7 t else pr_prim_rule_v8 t
diff --git a/proofs/logic.mli b/proofs/logic.mli
index 7eef22bd..2b6c6b4a 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: logic.mli,v 1.27.6.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+(*i $Id: logic.mli 9573 2007-01-31 20:18:18Z notin $ i*)
 
 (*i*)
 open Names
@@ -20,7 +20,6 @@ open Proof_type
 (* This suppresses check done in [prim_refiner] for the tactic given in
    argument; works by side-effect *)
 
-val without_check : tactic -> tactic
 val with_check    : tactic -> tactic
 
 (* [without_check] respectively means:\\
@@ -35,11 +34,15 @@ val with_check    : tactic -> tactic
 
 (* The primitive refiner. *)
 
-val prim_refiner : prim_rule -> evar_map -> goal -> goal list
+val prim_refiner : prim_rule -> evar_map -> goal -> goal list * evar_map
+
+type proof_variable
 
 val prim_extractor :
-  (identifier list -> proof_tree -> constr)
-  -> identifier list -> proof_tree -> constr
+  (proof_variable list -> proof_tree -> constr)
+  -> proof_variable list -> proof_tree -> constr
+
+val proof_variable_index : identifier -> proof_variable list -> int
 
 (*s Refiner errors. *)
 
@@ -54,20 +57,9 @@ type refiner_error =
   | NonLinearProof of constr
 
   (*i Errors raised by the tactics i*)
-  | CannotUnify of constr * constr
-  | CannotUnifyBindingType of constr * constr
-  | CannotGeneralize of constr
   | IntroNeedsProduct
   | DoesNotOccurIn of constr * identifier
-  | NoOccurrenceFound of constr
 
 exception RefinerError of refiner_error
 
-val error_cannot_unify : constr * constr -> 'a
-
 val catchable_exception : exn -> bool
-
-
-(*s Pretty-printer. *)
-
-val pr_prim_rule   : prim_rule -> Pp.std_ppcmds
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index f53ea870..565c9547 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pfedit.ml,v 1.47.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+(* $Id: pfedit.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Pp
 open Util
@@ -19,7 +19,7 @@ open Entries
 open Environ
 open Evd
 open Typing
-open Tacmach
+open Refiner
 open Proof_trees
 open Tacexpr
 open Proof_type
@@ -33,7 +33,6 @@ open Safe_typing
 
 type proof_topstate = {
   mutable top_end_tac : tactic option;
-  top_hyps : named_context * named_context;
   top_goal : goal;
   top_strength : Decl_kinds.goal_kind;
   top_hook : declaration_hook }
@@ -151,6 +150,14 @@ let subtree_solved () =
   is_complete_proof (proof_of_pftreestate pts) & 
   not (is_top_pftreestate pts)
 
+let tree_solved () = 
+  let pts = get_pftreestate () in
+  is_complete_proof (proof_of_pftreestate pts)
+
+let top_tree_solved () = 
+  let pts = get_pftreestate () in
+  is_complete_proof (proof_of_pftreestate (top_of_tree pts))
+
 (*********************************************************************)
 (*                 Undo functions                                    *)
 (*********************************************************************)
@@ -175,6 +182,21 @@ let undo n =
   with (Invalid_argument "Edit.undo") ->
     errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true)
 
+(* Undo current focused proof to reach depth [n]. This is used in
+   [vernac_backtrack]. *)
+let undo_todepth n =
+  try 
+    Edit.undo_todepth proof_edits n
+  with (Invalid_argument "Edit.undo") ->
+    errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true)
+
+(* Return the depth of the current focused proof stack, this is used
+   to put informations in coq prompt (in emacs mode). *)
+let current_proof_depth() = 
+  try
+    Edit.depth proof_edits
+  with (Invalid_argument "Edit.depth") -> -1
+
 (*********************************************************************)
 (*                  Proof cooking                                    *)
 (*********************************************************************)
@@ -192,7 +214,8 @@ let cook_proof () =
   (ident,
    ({ const_entry_body = pfterm;
       const_entry_type = Some concl;
-      const_entry_opaque = true },
+      const_entry_opaque = true;
+      const_entry_boxed = false},
     strength, ts.top_hook))
 
 let current_proof_statement () = 
@@ -228,10 +251,9 @@ let set_end_tac tac =
 (*********************************************************************)
 
 let start_proof na str sign concl hook =
-  let top_goal = mk_goal sign concl in
+  let top_goal = mk_goal sign concl None in
   let ts = { 
     top_end_tac = None;
-    top_hyps = (sign,empty_named_context);
     top_goal = top_goal;
     top_strength = str;
     top_hook = hook}
@@ -239,7 +261,6 @@ let start_proof na str sign concl hook =
   start(na,ts);
   set_current_proof na
 
-
 let solve_nth k tac =
   let pft = get_pftreestate () in
   if not (List.mem (-1) (cursor_of_pftreestate pft)) then
@@ -274,11 +295,11 @@ let common_ancestor l1 l2 =
       
 let rec traverse_up = function
   | 0 -> (function pf -> pf)
-  | n -> (function pf -> Tacmach.traverse 0 (traverse_up (n - 1) pf))
+  | n -> (function pf -> Refiner.traverse 0 (traverse_up (n - 1) pf))
 
 let rec traverse_down = function
   | [] -> (function pf -> pf)
-  | n::l -> (function pf -> Tacmach.traverse n (traverse_down l pf))
+  | n::l -> (function pf -> Refiner.traverse n (traverse_down l pf))
 
 let traverse_to path =
   let up_and_down path pfs =
@@ -295,7 +316,6 @@ let traverse_prev_unproven () = mutate prev_unproven
 
 let traverse_next_unproven () = mutate next_unproven
 
-
 (* The goal focused on *)
 let focus_n = ref 0
 let make_focus n = focus_n := n
@@ -303,31 +323,11 @@ let focus () = !focus_n
 let focused_goal () = let n = !focus_n in if n=0 then 1 else n
 
 let reset_top_of_tree () = 
-  let pts = get_pftreestate () in 
-  if not (is_top_pftreestate pts) then mutate top_of_tree
-
-(** Printers *)
-
-let pr_subgoals_of_pfts pfts = 
-  let gls = fst (Refiner.frontier (proof_of_pftreestate pfts)) in 
-  let sigma = project (top_goal_of_pftreestate pfts) in
-  pr_subgoals_existential sigma gls
-
-let pr_open_subgoals () =
-  let pfts = get_pftreestate () in
-  match focus() with
-    | 0 -> 
-	pr_subgoals_of_pfts pfts
-    | n -> 
-	let pf = proof_of_pftreestate pfts in
-	let gls = fst (frontier pf) in 
-	assert (n > List.length gls);
-	if List.length gls < 2 then 
-	  pr_subgoal n gls
-	else 
-	  v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++
-	  pr_subgoal n gls)
-
-let pr_nth_open_subgoal n =
-  let pf = proof_of_pftreestate (get_pftreestate ()) in
-  pr_subgoal n (fst (frontier pf))
+  mutate top_of_tree
+ 
+let reset_top_of_script () = 
+  mutate (fun pts -> 
+	try
+	 up_until_matching_rule is_proof_instr pts
+	with Not_found -> top_of_tree pts)
+
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index e95881ba..8c0c7f55 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pfedit.mli,v 1.35.2.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+(*i $Id: pfedit.mli 9154 2006-09-20 17:18:18Z corbinea $ i*)
 
 (*i*)
 open Util
@@ -57,6 +57,14 @@ val delete_all_proofs : unit -> unit
 
 val undo : int -> unit
 
+(* Same as undo, but undoes the current proof stack to reach depth
+   [n]. This is used in [vernac_backtrack]. *)
+val undo_todepth : int -> unit
+
+(* Returns the depth of the current focused proof stack, this is used
+   to put informations in coq prompt (in emacs mode). *)
+val current_proof_depth: unit -> int
+
 (* [set_undo (Some n)] sets the size of the ``undo'' stack; [set_undo None]
    sets the size to the default value (12) *)
 
@@ -68,7 +76,7 @@ val get_undo : unit -> int option
     declare the built constructions as a coercion or a setoid morphism) *)
 
 val start_proof : 
-  identifier -> goal_kind -> named_context -> constr
+  identifier -> goal_kind -> named_context_val -> constr
     -> declaration_hook -> unit
 
 (* [restart_proof ()] restarts the current focused proof from the beginning
@@ -164,8 +172,12 @@ val make_focus : int -> unit
 val focus : unit -> int
 val focused_goal : unit -> int
 val subtree_solved : unit -> bool
+val tree_solved : unit -> bool
+val top_tree_solved : unit -> bool
 
 val reset_top_of_tree : unit -> unit
+val reset_top_of_script : unit -> unit
+
 val traverse : int -> unit
 val traverse_nth_goal : int -> unit
 val traverse_next_unproven : unit -> unit
@@ -176,8 +188,3 @@ val traverse_prev_unproven : unit -> unit
    proof and goal management, as it is done, for instance in pcoq *)
 val traverse_to : int list -> unit
 val mutate : (pftreestate -> pftreestate) -> unit
-
-(** Printers *)
-
-val pr_open_subgoals    : unit -> std_ppcmds
-val pr_nth_open_subgoal : int -> std_ppcmds
diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml
index aaf54a36..9d70d012 100644
--- a/proofs/proof_trees.ml
+++ b/proofs/proof_trees.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: proof_trees.ml,v 1.53.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+(* $Id: proof_trees.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Closure
 open Util
@@ -18,6 +18,7 @@ open Sign
 open Evd
 open Environ
 open Evarutil
+open Decl_expr
 open Proof_type
 open Tacred
 open Typing
@@ -32,9 +33,9 @@ let is_bind = function
 
 (* Functions on goals *)
 
-let mk_goal hyps cl = 
+let mk_goal hyps cl extra = 
   { evar_hyps = hyps; evar_concl = cl; 
-    evar_body = Evar_empty}
+    evar_body = Evar_empty; evar_extra = extra }
 
 (* Functions on proof trees *)
 
@@ -52,7 +53,7 @@ let children_of_proof pf =
 let goal_of_proof pf = pf.goal
 
 let subproof_of_proof pf = match pf.ref with
-  | Some (Tactic (_,pf), _) -> pf
+  | Some (Nested (_,pf), _) -> pf
   | _ -> failwith "subproof_of_proof"
 
 let status_of_proof pf = pf.open_subgoals
@@ -62,192 +63,43 @@ let is_complete_proof pf = pf.open_subgoals = 0
 let is_leaf_proof pf = (pf.ref = None)
 
 let is_tactic_proof pf = match pf.ref with
-  | Some (Tactic _, _) -> true
+  | Some (Nested (Tactic _,_),_) -> true
   | _ -> false
 
 
-(*******************************************************************)
-(*            Constraints for existential variables                *)
-(*******************************************************************)
-
-(* A readable constraint is a global constraint plus a focus set
-   of existential variables and a signature. *)
+let pf_lookup_name_as_renamed env ccl s =
+  Detyping.lookup_name_as_renamed env ccl s
 
-(* Functions on readable constraints *)
-			     
-let mt_evcty gc = 
-  { it = empty_named_context; sigma = gc }
+let pf_lookup_index_as_renamed env ccl n =
+  Detyping.lookup_index_as_renamed env ccl n
 
-let rc_of_gc evds gl = 
-  { it = gl.evar_hyps; sigma = evds }
+(* Functions on rules (Proof mode) *) 
 
-let rc_add evc (k,v) = 
-  { it  = evc.it;
-    sigma = Evd.add evc.sigma k v }
+let is_dem_rule  = function
+    Decl_proof _  -> true
+  | _ -> false
 
-let get_hyps  evc = evc.it
-let get_env   evc = Global.env_of_context evc.it
-let get_gc    evc = evc.sigma
+let is_proof_instr = function
+    Nested(Proof_instr (_,_),_) -> true
+  | _ -> false
 
-let pf_lookup_name_as_renamed env ccl s =
-  Detyping.lookup_name_as_renamed env ccl s
+let is_focussing_command = function
+    Decl_proof b -> b 
+  | Nested (Proof_instr (b,_),_) -> b 
+  | _ -> false   
 
-let pf_lookup_index_as_renamed env ccl n =
-  Detyping.lookup_index_as_renamed env ccl n
 
 (*********************************************************************)
 (*                  Pretty printing functions                        *)
 (*********************************************************************)
 
 open Pp
-open Printer
-
-(* Il faudrait parametrer toutes les pr_term, term_env, etc. par la
-  strategie de renommage choisie pour Termast (en particulier, il
-  faudrait pouvoir etre sur que lookup_as_renamed qui est utilisé par
-  Intros Until fonctionne exactement comme on affiche le but avec
-  term_env *)
 
-let pf_lookup_name_as_renamed hyps ccl s =
-  Detyping.lookup_name_as_renamed hyps ccl s
-
-let pf_lookup_index_as_renamed ccl n =
-  Detyping.lookup_index_as_renamed ccl n
-
-let pr_idl idl = prlist_with_sep pr_spc pr_id idl
-
-let pr_goal g =
+let db_pr_goal g =
   let env = evar_env g in
-  let penv = pr_context_of env in
-  let pc = prterm_env_at_top env g.evar_concl in
+  let penv = print_named_context env in
+  let pc = print_constr_env env g.evar_concl in
   str"  " ++ hv 0 (penv ++ fnl () ++
-		   str (emacs_str (String.make 1 (Char.chr 253)))  ++
                    str "============================" ++ fnl ()  ++
                    str" "  ++ pc) ++ fnl ()
 
-let pr_concl n g =
-  let env = evar_env g in
-  let pc = prterm_env_at_top env g.evar_concl in
-  str (emacs_str (String.make 1 (Char.chr 253)))  ++
-  str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" "  ++ pc
-
-(* print the subgoals but write Subtree proved! even in case some existential 
-   variables remain unsolved, pr_subgoals_existential is a safer version 
-   of pr_subgoals *)
-
-let pr_subgoals = function
-  | [] -> (str"Proof completed." ++ fnl ())
-  | [g] ->
-      let pg = pr_goal g in v 0 (str ("1 "^"subgoal") ++cut () ++ pg)
-  | g1::rest ->
-      let rec pr_rec n = function
-        | [] -> (mt ())
-        | g::rest ->
-            let pg = pr_concl n g in
-            let prest = pr_rec (n+1) rest in
-            (cut () ++ pg ++ prest) 
-      in
-      let pg1 = pr_goal g1 in
-      let pgr = pr_rec 2 rest in
-      v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () ++ pg1 ++ pgr)
-
-let pr_subgoal n =
-  let rec prrec p = function
-    | [] -> error "No such goal"
-    | g::rest ->
-       	if p = 1 then
-          let pg = pr_goal g in
-          v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg)
-       	else 
-	  prrec (p-1) rest
-  in 
-  prrec n
-
-let pr_seq evd = 
-  let env = evar_env evd
-  and cl = evd.evar_concl
-  in
-  let pdcl = pr_named_context_of env in
-  let pcl = prterm_env_at_top env cl in
-  hov 0 (pdcl  ++ spc ()  ++ hov 0 (str"|- "  ++ pcl))
-
-let prgl gl =
-  let pgl = pr_seq gl in
-  (str"["  ++ pgl  ++ str"]"  ++ spc ())
-
-let pr_evgl gl =
-  let phyps = pr_idl (List.rev (ids_of_named_context gl.evar_hyps)) in
-  let pc = prterm gl.evar_concl in
-  hov 0 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pc ++ str"]")
-
-let pr_evgl_sign gl = 
-  let ps = pr_named_context_of (evar_env gl) in
-  let pc = prterm gl.evar_concl in
-  hov 0 (str"["  ++ ps ++ spc () ++ str"|- "  ++ pc ++ str"]")
-
-(*  evd.evgoal.lc seems to be printed twice *)
-let pr_decl evd =
-  let pevgl = pr_evgl evd in
-  let pb =
-    match evd.evar_body with
-      | Evar_empty -> (fnl ())
-      | Evar_defined c -> let pc = prterm c in (str" => "  ++ pc ++  fnl ())
-  in
-  h 0 (pevgl ++ pb)
-
-let pr_evd evd = 
-  prlist_with_sep pr_fnl
-    (fun (ev,evd) ->
-       let pe = pr_decl evd in 
-       h 0 (str (string_of_existential ev)  ++ str"=="  ++ pe))
-    (Evd.to_list evd)
-    
-let pr_decls decls = pr_evd decls
-		       
-let pr_evc evc =
-  let pe = pr_evd evc.sigma in
-  (pe)
-
-let pr_evars = 
-  prlist_with_sep pr_fnl
-    (fun (ev,evd) ->
-       let pegl = pr_evgl_sign evd in 
-       (str (string_of_existential ev) ++ str " : " ++ pegl))
-
-(* Print an enumerated list of existential variables *)
-let rec pr_evars_int i = function
-  | [] -> (mt ())
-  | (ev,evd)::rest ->
-      let pegl = pr_evgl_sign evd in 
-      let pei = pr_evars_int (i+1) rest in
-      (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++
-              str (string_of_existential ev)  ++ str " : " ++ pegl)) ++ 
-      fnl () ++ pei
-
-(* Equivalent to pr_subgoals but start from the prooftree and 
-   check for uninstantiated existential variables *)
-
-let pr_subgoals_existential sigma = function 
-  | [] -> 
-      let exl = Evd.non_instantiated sigma in 
-      if exl = [] then 
-	(str"Proof completed."  ++ fnl ())
-      else
-        let pei = pr_evars_int 1 exl in
-        (str "No more subgoals but non-instantiated existential " ++
-           str "variables :"  ++fnl () ++ (hov 0 pei))
-  | [g] ->
-      let pg = pr_goal g in
-      v 0 (str ("1 "^"subgoal") ++cut () ++ pg)
-  | g1::rest ->
-      let rec pr_rec n = function
-        | [] -> (mt ())
-        | g::rest ->
-            let pc = pr_concl n g in
-            let prest = pr_rec (n+1) rest in
-            (cut () ++ pc ++ prest) 
-      in
-      let pg1 = pr_goal g1 in
-      let prest = pr_rec 2 rest in
-      v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () 
-	   ++ pg1 ++ prest ++ fnl ())
diff --git a/proofs/proof_trees.mli b/proofs/proof_trees.mli
index c31d5207..f9b64f41 100644
--- a/proofs/proof_trees.mli
+++ b/proofs/proof_trees.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: proof_trees.mli,v 1.27.2.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+(*i $Id: proof_trees.mli 9154 2006-09-20 17:18:18Z corbinea $ i*)
 
 (*i*)
 open Util
@@ -21,7 +21,7 @@ open Proof_type
 (* This module declares readable constraints, and a few utilities on
    constraints and proof trees *)
 
-val mk_goal : named_context -> constr -> goal
+val mk_goal : named_context_val -> constr -> Dyn.t option -> goal
 
 val rule_of_proof     : proof_tree -> rule
 val ref_of_proof      : proof_tree -> (rule * proof_tree list)
@@ -33,19 +33,11 @@ val is_complete_proof : proof_tree -> bool
 val is_leaf_proof     : proof_tree -> bool
 val is_tactic_proof   : proof_tree -> bool
 
-(*s A readable constraint is a global constraint plus a focus set
-    of existential variables and a signature. *)
-
-val rc_of_gc  : evar_map -> goal -> named_context sigma
-val rc_add    : named_context sigma -> existential_key * goal -> 
-  named_context sigma
-val get_hyps  : named_context sigma -> named_context
-val get_env   : named_context sigma -> env
-val get_gc    : named_context sigma -> evar_map
-
 val pf_lookup_name_as_renamed  : env -> constr -> identifier -> int option
 val pf_lookup_index_as_renamed : env -> constr -> int -> int option
 
+val is_proof_instr : rule -> bool
+val is_focussing_command : rule -> bool
 
 (*s Pretty printing functions. *)
 
@@ -53,16 +45,4 @@ val pf_lookup_index_as_renamed : env -> constr -> int -> int option
 open Pp
 (*i*)
 
-val pr_goal      : goal -> std_ppcmds
-val pr_subgoals  : goal list -> std_ppcmds
-val pr_subgoal   : int -> goal list -> std_ppcmds
-
-val pr_decl      : goal -> std_ppcmds
-val pr_decls     : evar_map -> std_ppcmds
-val pr_evc       : named_context sigma -> std_ppcmds
-
-val prgl         : goal -> std_ppcmds
-val pr_seq       : goal -> std_ppcmds
-val pr_evars     : (existential_key * goal) list -> std_ppcmds
-val pr_evars_int : int -> (existential_key * goal) list -> std_ppcmds
-val pr_subgoals_existential : evar_map -> goal list -> std_ppcmds
+val db_pr_goal : goal -> std_ppcmds
diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml
index cbed5e27..6f8b0686 100644
--- a/proofs/proof_type.ml
+++ b/proofs/proof_type.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: proof_type.ml,v 1.29.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+(*i $Id: proof_type.ml 9573 2007-01-31 20:18:18Z notin $ *)
 
 (*i*)
 open Environ
@@ -16,6 +16,7 @@ open Libnames
 open Term
 open Util
 open Tacexpr
+open Decl_expr
 open Rawterm
 open Genarg
 open Nametab
@@ -32,25 +33,14 @@ type prim_rule =
   | FixRule of identifier * int * (identifier * int * constr) list
   | Cofix of identifier * (identifier * constr) list
   | Refine of constr
-  | Convert_concl of types
+  | Convert_concl of types * cast_kind
   | Convert_hyp of named_declaration
   | Thin of identifier list
   | ThinBody of identifier list
   | Move of bool * identifier * identifier
   | Rename of identifier * identifier
+  | Change_evars
 
-
-(* Signature useful to define the tactic type *)
-type 'a sigma = { 
-  it : 'a ; 
-  sigma : evar_map }
-
-(*s Proof trees. 
-  [ref] = [None] if the goal has still to be proved, 
-  and [Some (r,l)] if the rule [r] was applied to the goal
-  and gave [l] as subproofs to be completed. 
-  if [ref = (Some(Tactic (t,p),l))] then [p] is the proof 
-  that the goal can be proven if the goals in [l] are solved. *)
 type proof_tree = {
   open_subgoals : int;
   goal : goal;
@@ -58,8 +48,13 @@ type proof_tree = {
 
 and rule =
   | Prim of prim_rule
-  | Tactic of tactic_expr * proof_tree
-  | Change_evars
+  | Nested of compound_rule * proof_tree 
+  | Decl_proof of bool
+  | Daimon
+
+and compound_rule=  
+  | Tactic of tactic_expr * bool
+  | Proof_instr of bool*proof_instr (* the boolean is for focus restrictions *)
 
 and goal = evar_info
 
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
index 42606552..26d9eb2e 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: proof_type.mli,v 1.33.2.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+(*i $Id: proof_type.mli 9573 2007-01-31 20:18:18Z notin $ i*)
 
 (*i*)
 open Environ
@@ -16,6 +16,7 @@ open Libnames
 open Term
 open Util
 open Tacexpr
+open Decl_expr
 open Rawterm
 open Genarg
 open Nametab
@@ -32,12 +33,13 @@ type prim_rule =
   | FixRule of identifier * int * (identifier * int * constr) list
   | Cofix of identifier * (identifier * constr) list
   | Refine of constr
-  | Convert_concl of types
+  | Convert_concl of types * cast_kind 
   | Convert_hyp of named_declaration
   | Thin of identifier list
   | ThinBody of identifier list
   | Move of bool * identifier * identifier
   | Rename of identifier * identifier
+  | Change_evars
 
 (* The type [goal sigma] is the type of subgoal. It has the following form
 \begin{verbatim}
@@ -46,7 +48,7 @@ type prim_rule =
              evar_body = Evar_Empty;
              evar_info = { pgm    : [The Realizer pgm if any]
                            lc     : [Set of evar num occurring in subgoal] }}
-   sigma = { stamp = [an int characterizing the ed field, for quick compare]
+   sigma = { stamp = [an int chardacterizing the ed field, for quick compare]
              ed : [A set of existential variables depending in the subgoal]
                number of first evar,
                it = { evar_concl = [the type of first evar]
@@ -67,17 +69,11 @@ type prim_rule =
 \end{verbatim}
 *)
 
-(* The type constructor ['a sigma] adds an evar map to an object of
-  type ['a] (see below the form of a [goal sigma] *)
-type 'a sigma = { 
-  it : 'a ; 
-  sigma : evar_map}
-
 (*s Proof trees. 
   [ref] = [None] if the goal has still to be proved, 
   and [Some (r,l)] if the rule [r] was applied to the goal
   and gave [l] as subproofs to be completed. 
-  if [ref = (Some(Tactic (t,p),l))] then [p] is the proof 
+  if [ref = (Some(Nested(Tactic t,p),l))] then [p] is the proof 
   that the goal can be proven if the goals in [l] are solved. *)
 type proof_tree = {
   open_subgoals : int;
@@ -86,8 +82,14 @@ type proof_tree = {
 
 and rule =
   | Prim of prim_rule
-  | Tactic of tactic_expr * proof_tree
-  | Change_evars
+  | Nested of compound_rule * proof_tree 
+  | Decl_proof of bool
+  | Daimon
+
+and compound_rule= 
+  (* the boolean of Tactic tells if the default tactic is used *)
+  | Tactic of tactic_expr * bool
+  | Proof_instr of bool * proof_instr
 
 and goal = evar_info
 
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
new file mode 100644
index 00000000..ad277caa
--- /dev/null
+++ b/proofs/redexpr.ml
@@ -0,0 +1,119 @@
+(************************************************************************)
+(*  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: redexpr.ml 9058 2006-07-22 17:42:45Z bgregoir $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Declarations
+open Libnames
+open Rawterm
+open Reductionops
+open Tacred
+open Closure
+open RedFlags
+
+
+(* call by value normalisation function using the virtual machine *)
+let cbv_vm env _ c =
+  let ctyp = (fst (Typeops.infer env c)).Environ.uj_type in
+  Vnorm.cbv_vm env c ctyp
+
+
+let set_opaque_const sp = 
+  Conv_oracle.set_opaque_const sp;
+  Csymtable.set_opaque_const sp
+
+let set_transparent_const sp =
+  let cb = Global.lookup_constant sp in
+  if cb.const_body <> None & cb.const_opaque then
+    errorlabstrm "set_transparent_const"
+      (str "Cannot make" ++ spc () ++ 
+         Nametab.pr_global_env Idset.empty (ConstRef sp) ++
+         spc () ++ str "transparent because it was declared opaque.");
+  Conv_oracle.set_transparent_const sp;
+  Csymtable.set_transparent_const sp
+
+let set_opaque_var      = Conv_oracle.set_opaque_var
+let set_transparent_var = Conv_oracle.set_transparent_var
+
+let _ = 
+  Summary.declare_summary "Transparent constants and variables"
+    { Summary.freeze_function = Conv_oracle.freeze;
+      Summary.unfreeze_function = Conv_oracle.unfreeze;
+      Summary.init_function = Conv_oracle.init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+
+(* Generic reduction: reduction functions used in reduction tactics *)
+
+type red_expr = (constr, evaluable_global_reference) red_expr_gen
+
+
+let make_flag_constant = function
+  | EvalVarRef id -> fVAR id
+  | EvalConstRef sp -> fCONST sp
+
+let make_flag f =
+  let red = no_red in
+  let red = if f.rBeta then red_add red fBETA else red in
+  let red = if f.rIota then red_add red fIOTA else red in
+  let red = if f.rZeta then red_add red fZETA else red in
+  let red =
+    if f.rDelta then (* All but rConst *)
+        let red = red_add red fDELTA in
+        let red = red_add_transparent red (Conv_oracle.freeze ()) in
+	List.fold_right
+	  (fun v red -> red_sub red (make_flag_constant v))
+	  f.rConst red
+    else (* Only rConst *)
+        let red = red_add_transparent (red_add red fDELTA) all_opaque in
+	List.fold_right
+	  (fun v red -> red_add red (make_flag_constant v))
+	  f.rConst red
+  in red
+
+let is_reference c = 
+  try let _ref = global_of_constr c in true with _ -> false
+
+let red_expr_tab = ref Stringmap.empty
+
+let declare_red_expr s f =
+  try 
+    let _ = Stringmap.find s !red_expr_tab in
+    error ("There is already a reduction expression of name "^s)
+  with Not_found ->
+    red_expr_tab := Stringmap.add s f !red_expr_tab
+
+let out_arg = function
+  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgArg x -> x
+
+let out_with_occurrences (l,c) =
+  (List.map out_arg l, c)
+
+let reduction_of_red_expr = function
+  | Red internal -> 
+      if internal then (try_red_product,DEFAULTcast) 
+      else (red_product,DEFAULTcast)
+  | Hnf -> (hnf_constr,DEFAULTcast)
+  | Simpl (Some (_,c as lp)) ->
+      (contextually (is_reference c) (out_with_occurrences lp) nf,DEFAULTcast)
+  | Simpl None -> (nf,DEFAULTcast)
+  | Cbv f -> (cbv_norm_flags (make_flag f),DEFAULTcast)
+  | Lazy f -> (clos_norm_flags (make_flag f),DEFAULTcast)
+  | Unfold ubinds -> (unfoldn (List.map out_with_occurrences ubinds),DEFAULTcast)
+  | Fold cl -> (fold_commands cl,DEFAULTcast)
+  | Pattern lp -> (pattern_occs (List.map out_with_occurrences lp),DEFAULTcast)
+  | ExtraRedExpr s ->
+      (try (Stringmap.find s !red_expr_tab,DEFAULTcast)
+      with Not_found -> error("unknown user-defined reduction \""^s^"\""))
+  | CbvVm -> (cbv_vm ,VMcast)
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
new file mode 100644
index 00000000..cbac180a
--- /dev/null
+++ b/proofs/redexpr.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: redexpr.mli 8878 2006-05-30 16:44:25Z herbelin $ i*)
+
+open Names
+open Term
+open Closure
+open Rawterm
+open Reductionops
+
+
+type red_expr = (constr, evaluable_global_reference) red_expr_gen
+
+val out_with_occurrences : 'a with_occurrences -> int list * 'a
+
+val reduction_of_red_expr : red_expr -> reduction_function * cast_kind
+(* [true] if we should use the vm to verify the reduction *)
+
+val declare_red_expr : string -> reduction_function -> unit
+
+(* Opaque and Transparent commands. *)
+val set_opaque_const      : constant -> unit
+val set_transparent_const : constant -> unit
+
+val set_opaque_var      : identifier -> unit
+val set_transparent_var : identifier -> unit
+
+
+
+(* call by value normalisation function using the virtual machine *)
+val cbv_vm : reduction_function
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index 785e6dd4..a1d7e011 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refiner.ml,v 1.67.2.3 2005/11/04 08:59:30 herbelin Exp $ *)
+(* $Id: refiner.ml 9573 2007-01-31 20:18:18Z notin $ *)
 
 open Pp
 open Util
@@ -17,12 +17,10 @@ open Evd
 open Sign
 open Environ
 open Reductionops
-open Instantiate
 open Type_errors
 open Proof_trees
 open Proof_type
 open Logic
-open Printer
 
 type transformation_tactic = proof_tree -> (goal list * validation)
 
@@ -30,10 +28,7 @@ let hypotheses gl = gl.evar_hyps
 let conclusion gl = gl.evar_concl
 
 let sig_it x = x.it
-let sig_sig x = x.sigma
-
-
-let project_with_focus gls = rc_of_gc (gls.sigma) (gls.it)
+let project x = x.sigma
 
 let pf_status pf = pf.open_subgoals
 
@@ -43,21 +38,35 @@ let on_open_proofs f pf = if is_complete pf then pf else f pf
 
 let and_status = List.fold_left (+) 0
 
-(* Normalizing evars in a goal. Called by tactic Local_constraints
-   (i.e. when the sigma of the proof tree changes). Detect if the
-   goal is unchanged *)
-let norm_goal sigma gl =
-  let red_fun = Evarutil.nf_evar sigma in
-  let ncl = red_fun gl.evar_concl in
-  let ngl =
-    { evar_concl = ncl;
-      evar_hyps =
-      Sign.fold_named_context 
-        (fun (d,b,ty) sign ->
-          add_named_decl (d, option_app red_fun b, red_fun ty) sign)
-        gl.evar_hyps ~init:empty_named_context;
-      evar_body = gl.evar_body} in
-  if ngl = gl then None else Some ngl
+(* Getting env *)
+
+let pf_env gls = Global.env_of_context (sig_it gls).evar_hyps
+let pf_hyps gls = named_context_of_val (sig_it gls).evar_hyps
+
+
+let descend n p =
+  match p.ref with
+    | None        -> error "It is a leaf."
+    | Some(r,pfl) ->
+    	if List.length pfl >= n then
+	  (match list_chop (n-1) pfl with 
+	     | left,(wanted::right) ->
+		 (wanted,
+		  (fun pfl' ->
+                     if (List.length pfl' = 1) 
+		       & (List.hd pfl').goal = wanted.goal 
+		     then
+                       let pf'       = List.hd pfl' in
+                       let spfl      = left@(pf'::right) in
+                       let newstatus = and_status (List.map pf_status spfl) in
+                       { p with 
+			   open_subgoals = newstatus;
+			   ref           = Some(r,spfl) }
+                     else 
+		       error "descend: validation"))
+	     | _ -> assert false)
+    	else 
+	  error "Too few subproofs"
 
 
 (* [mapshape [ l1 ; ... ; lk ] [ v1 ; ... ; vk ] [ p_1 ; .... ; p_(l1+...+lk) ]]
@@ -85,7 +94,7 @@ let rec frontier p =
 	([p.goal],
 	 (fun lp' -> 
 	    let p' = List.hd lp' in
-            if p'.goal = p.goal then 
+            if Evd.eq_evar_info p'.goal p.goal then 
 	      p'
             else 
 	      errorlabstrm "Refiner.frontier"
@@ -95,9 +104,9 @@ let rec frontier p =
     	(List.flatten gll,
          (fun retpfl ->
             let pfl' = mapshape (List.map List.length gll) vl retpfl in
-            { open_subgoals = and_status (List.map pf_status pfl');
-              goal = p.goal;
-              ref = Some(r,pfl')}))
+              { p with
+		  open_subgoals = and_status (List.map pf_status pfl');
+		  ref = Some(r,pfl')}))
 
 
 let rec frontier_map_rec f n p =
@@ -105,7 +114,7 @@ let rec frontier_map_rec f n p =
   match p.ref with
     | None -> 
         let p' = f p in
-        if p'.goal == p.goal || p'.goal = p.goal then p'
+        if Evd.eq_evar_info p'.goal p.goal then p'
         else 
 	  errorlabstrm "Refiner.frontier_map"
             (str"frontier_map was handed back a ill-formed proof.")
@@ -115,9 +124,9 @@ let rec frontier_map_rec f n p =
             (fun (n,acc) p -> (n-p.open_subgoals,frontier_map_rec f n p::acc))
             (n,[]) pfl in
         let pfl' = List.rev rpfl' in
-        { open_subgoals = and_status (List.map pf_status pfl');
-          goal = p.goal;
-          ref = Some(r,pfl')}
+        { p with
+	    open_subgoals = and_status (List.map pf_status pfl');
+            ref = Some(r,pfl')}
 
 let frontier_map f n p =
   let nmax = p.open_subgoals in
@@ -131,7 +140,7 @@ let rec frontier_mapi_rec f i p =
   match p.ref with
     | None -> 
         let p' = f i p in
-        if p'.goal == p.goal || p'.goal = p.goal then p'
+        if Evd.eq_evar_info p'.goal p.goal then p'
         else 
 	  errorlabstrm "Refiner.frontier_mapi"
             (str"frontier_mapi was handed back a ill-formed proof.")
@@ -141,9 +150,9 @@ let rec frontier_mapi_rec f i p =
             (fun (n,acc) p -> (n+p.open_subgoals,frontier_mapi_rec f n p::acc))
             (i,[]) pfl in
         let pfl' = List.rev rpfl' in
-        { open_subgoals = and_status (List.map pf_status pfl');
-          goal = p.goal;
-          ref = Some(r,pfl')}
+        { p with 
+	    open_subgoals = and_status (List.map pf_status pfl');
+            ref = Some(r,pfl')}
 
 let frontier_mapi f p = frontier_mapi_rec f 1 p
 
@@ -156,124 +165,87 @@ let rec nb_unsolved_goals pf = pf.open_subgoals
 
 (* leaf g is the canonical incomplete proof of a goal g *)
 
-let leaf g = {
-  open_subgoals = 1;
-  goal = g;
-  ref = None }
+let leaf g = 
+  { open_subgoals = 1;
+    goal = g;
+    ref = None }
 
-(* Tactics table. *)
+(* refiner r is a tactic applying the rule r *)
 
-let tac_tab = Hashtbl.create 17
+let check_subproof_connection gl spfl =
+  list_for_all2eq (fun g pf -> Evd.eq_evar_info g pf.goal) gl spfl
 
-let add_tactic s t =
-  if Hashtbl.mem tac_tab s then
-    errorlabstrm ("Refiner.add_tactic: ") 
-      (str ("Cannot redeclare tactic "^s));
-  Hashtbl.add tac_tab s t
 
-let overwriting_add_tactic s t =
-  if Hashtbl.mem tac_tab s then begin
-    Hashtbl.remove tac_tab s;
-    warning ("Overwriting definition of tactic "^s)
-  end;
-  Hashtbl.add tac_tab s t
+let abstract_operation syntax semantics gls =
+  let (sgl_sigma,validation) = semantics gls in
+  let hidden_proof = validation (List.map leaf sgl_sigma.it) in
+  (sgl_sigma,
+  fun spfl ->
+    assert (check_subproof_connection sgl_sigma.it spfl);
+    { open_subgoals = and_status (List.map pf_status spfl);
+      goal = gls.it;
+      ref = Some(Nested(syntax,hidden_proof),spfl)})
 
-let lookup_tactic s =
-  try 
-    Hashtbl.find tac_tab s
-  with Not_found -> 
-    errorlabstrm "Refiner.lookup_tactic"
-      (str"The tactic " ++ str s ++ str" is not installed")
+let abstract_tactic_expr ?(dflt=false) te tacfun gls =
+  abstract_operation (Tactic(te,dflt)) tacfun gls	
 
+let abstract_tactic ?(dflt=false) te =
+  abstract_tactic_expr ~dflt (Tacexpr.TacAtom (dummy_loc,te))
 
-(* refiner r is a tactic applying the rule r *)
-
-let check_subproof_connection gl spfl =
-  list_for_all2eq (fun g pf -> g=pf.goal) gl spfl
-
-let abstract_tactic_expr te tacfun gls =
-  let (sgl_sigma,v) = tacfun gls in
-  let hidden_proof = v (List.map leaf sgl_sigma.it) in
-  (sgl_sigma,
-   fun spfl ->
-     assert (check_subproof_connection sgl_sigma.it spfl);
-     { open_subgoals = and_status (List.map pf_status spfl);
-       goal = gls.it;
-       ref = Some(Tactic(te,hidden_proof),spfl) })
+let abstract_extended_tactic ?(dflt=false) s args = 
+  abstract_tactic ~dflt (Tacexpr.TacExtend (dummy_loc, s, args))
 
 let refiner = function
   | Prim pr as r ->
       let prim_fun = prim_refiner pr in
-      (fun goal_sigma ->
-         let sgl = prim_fun goal_sigma.sigma goal_sigma.it in 
-	 ({it=sgl; sigma = goal_sigma.sigma},
-          (fun spfl ->
-	     assert (check_subproof_connection sgl spfl);
-             { open_subgoals = and_status (List.map pf_status spfl);
-               goal = goal_sigma.it;
-               ref = Some(r,spfl) })))
-
-  | Tactic _ -> failwith "Refiner: should not occur"
+	(fun goal_sigma ->
+          let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in 
+	    ({it=sgl; sigma = sigma'},
+            (fun spfl ->
+	      assert (check_subproof_connection sgl spfl);
+              { open_subgoals = and_status (List.map pf_status spfl);
+		goal = goal_sigma.it;
+		ref = Some(r,spfl) })))
+
+
+  | Nested (_,_) | Decl_proof _ -> 
+      failwith "Refiner: should not occur"
       
-   (* [Local_constraints lc] makes the local constraints be [lc] and
-      normalizes evars *)
-
-  | Change_evars as r ->
-      (fun goal_sigma ->
-         let gl = goal_sigma.it in
-         (match norm_goal goal_sigma.sigma gl with
-             Some ngl ->
-	       ({it=[ngl];sigma=goal_sigma.sigma},
-                (fun spfl -> 
-	          assert (check_subproof_connection [ngl] spfl);
-                  { open_subgoals = (List.hd spfl).open_subgoals;
-                    goal = gl;
-                    ref = Some(r,spfl) }))
-           (* if the evar change does not affect the goal, leave the
-              proof tree unchanged *)
-           | None -> ({it=[gl];sigma=goal_sigma.sigma},
-                      (fun spfl ->
-                        assert (List.length spfl = 1);
-                        List.hd spfl))))
-
-
-let local_Constraints gl = refiner Change_evars gl
-
-let norm_evar_tac = local_Constraints
+	(* Daimon is a canonical unfinished proof *)
 
-(*
-let vernac_tactic (s,args) =
-  let tacfun = lookup_tactic s args in
-  abstract_extra_tactic s args tacfun
-*)
-let abstract_tactic te = abstract_tactic_expr (Tacexpr.TacAtom (dummy_loc,te))
+  | Daimon -> 
+      fun gls -> 
+	({it=[];sigma=gls.sigma},  
+	 fun spfl -> 
+	   assert (spfl=[]);
+	   { open_subgoals = 0;
+             goal = gls.it;
+             ref = Some(Daimon,[])})
 
-let abstract_extended_tactic s args = 
-  abstract_tactic (Tacexpr.TacExtend (dummy_loc, s, args))
 
-let vernac_tactic (s,args) =
-  let tacfun = lookup_tactic s args in
-  abstract_extended_tactic s args tacfun
+let local_Constraints gl = refiner (Prim Change_evars) gl
 
-(* [rc_of_pfsigma : proof sigma -> readable_constraints] *)
-let rc_of_pfsigma sigma = rc_of_gc sigma.sigma sigma.it.goal
+let norm_evar_tac = local_Constraints
 
-(* [rc_of_glsigma : proof sigma -> readable_constraints] *)
-let rc_of_glsigma sigma = rc_of_gc sigma.sigma sigma.it
+let norm_evar_proof sigma pf =
+  let nf_subgoal i sgl =
+    let (gll,v) = norm_evar_tac {it=sgl.goal;sigma=sigma} in
+      v (List.map leaf gll.it) in
+    frontier_mapi nf_subgoal pf
 
 (* [extract_open_proof : proof_tree -> constr * (int * constr) list]
-  takes a (not necessarly complete) proof and gives a pair (pfterm,obl)
-  where pfterm is the constr corresponding to the proof
-  and [obl] is an [int*constr list] [ (m1,c1) ; ... ; (mn,cn)]
-  where the mi are metavariables numbers, and ci are their types.
-  Their proof should be completed in order to complete the initial proof *)
+   takes a (not necessarly complete) proof and gives a pair (pfterm,obl)
+   where pfterm is the constr corresponding to the proof
+   and [obl] is an [int*constr list] [ (m1,c1) ; ... ; (mn,cn)]
+   where the mi are metavariables numbers, and ci are their types.
+   Their proof should be completed in order to complete the initial proof *)
 
 let extract_open_proof sigma pf =
   let next_meta = 
     let meta_cnt = ref 0 in
     let rec f () =
       incr meta_cnt; 
-      if in_dom sigma (existential_of_int !meta_cnt) then f ()
+      if Evd.mem sigma (existential_of_int !meta_cnt) then f ()
       else !meta_cnt
     in f
   in
@@ -281,24 +253,24 @@ let extract_open_proof sigma pf =
   let rec proof_extractor vl = function
     | {ref=Some(Prim _,_)} as pf -> prim_extractor proof_extractor vl pf
 	  
-    | {ref=Some(Tactic (_,hidden_proof),spfl)} ->
+    | {ref=Some(Nested(_,hidden_proof),spfl)} ->
 	let sgl,v = frontier hidden_proof in
 	let flat_proof = v spfl in
 	proof_extractor vl flat_proof
+ 
+    | {ref=Some(Decl_proof _,[pf])} -> (proof_extractor vl) pf
 	  
-    | {ref=Some(Change_evars,[pf])} -> (proof_extractor vl) pf
-	  
-    | {ref=None;goal=goal} ->
+    | {ref=(None|Some(Daimon,[]));goal=goal} ->
 	let visible_rels =
           map_succeed
             (fun id ->
-               try let n = list_index id vl in (n,id)
+               try let n = proof_variable_index id vl in (n,id)
 	       with Not_found -> failwith "caught")
-            (ids_of_named_context goal.evar_hyps) in
+            (ids_of_named_context (named_context_of_val goal.evar_hyps)) in
 	let sorted_rels =
 	  Sort.list (fun (n1,_) (n2,_) -> n1 > n2 ) visible_rels in
         let sorted_env =
-          List.map (fun (n,id) -> (n,Sign.lookup_named id goal.evar_hyps))
+          List.map (fun (n,id) -> (n,lookup_named_val id goal.evar_hyps))
             sorted_rels in
 	let abs_concl =
           List.fold_right (fun (_,decl) c -> mkNamedProd_or_LetIn decl c)
@@ -308,7 +280,7 @@ let extract_open_proof sigma pf =
 	open_obligations := (meta,abs_concl):: !open_obligations;
 	applist (mkMeta meta, List.map (fun (n,_) -> mkRel n) inst) 
 	  
-    | _ -> anomaly "Bug : a case has been forgotten in proof_extractor"
+    | _ -> anomaly "Bug: a case has been forgotten in proof_extractor"
   in
   let pfterm = proof_extractor [] pf in
   (pfterm, List.rev !open_obligations)
@@ -345,17 +317,13 @@ let tclIDTAC gls = (goal_goal_list gls, idtac_valid)
 
 (* the message printing identity tactic *)
 let tclIDTAC_MESSAGE s gls = 
-  if s = "" then tclIDTAC gls
-  else 
-    begin
-      msgnl (str ("Idtac says : "^s)); tclIDTAC gls
-    end
+  msg (hov 0 s); tclIDTAC gls
 
 (* General failure tactic *)
 let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s)
 
 (* A special exception for levels for the Fail tactic *)
-exception FailError of int * string
+exception FailError of int * std_ppcmds
 
 (* The Fail tactic *)
 let tclFAIL lvl s g = raise (FailError (lvl,s))
@@ -469,7 +437,7 @@ let rec tclTHENLIST = function
 
 (* various progress criterions *)
 let same_goal gl subgoal = 
-  (hypotheses subgoal) = (hypotheses gl) &
+  eq_named_context_val (hypotheses subgoal) (hypotheses gl) &&
   eq_constr (conclusion subgoal) (conclusion gl)
 
 
@@ -569,6 +537,8 @@ let tclIFTHENSELSE=ite_gen tclTHENS
 
 let tclIFTHENSVELSE=ite_gen tclTHENSV
 
+let tclIFTHENTRYELSEMUST tac1 tac2 gl = 
+  tclIFTHENELSE tac1 (tclTRY tac2) tac2 gl
 
 (* Fails if a tactic did not solve the goal *)
 let tclCOMPLETE tac = tclTHEN tac (tclFAIL_s "Proof is not complete.")
@@ -647,7 +617,6 @@ let tactic_list_tactic tac gls =
 
 
 
-
 (* The type of proof-trees state and a few utilities 
    A proof-tree state is built from a proof-tree, a set of global
    constraints, and a stack which allows to navigate inside the
@@ -679,41 +648,19 @@ let nth_goal_of_pftreestate n pts =
   try {it = List.nth goals (n-1); sigma = pts.tpfsigma }
   with Invalid_argument _ | Failure _ -> non_existent_goal n
 
-let descend n p =
-  match p.ref with
-    | None        -> error "It is a leaf."
-    | Some(r,pfl) ->
-    	if List.length pfl >= n then
-	  (match list_chop (n-1) pfl with 
-	     | left,(wanted::right) ->
-		 (wanted,
-		  (fun pfl' ->
-                     if (List.length pfl' = 1) 
-		       & (List.hd pfl').goal = wanted.goal 
-		     then
-                       let pf'       = List.hd pfl' in
-                       let spfl      = left@(pf'::right) in
-                       let newstatus = and_status (List.map pf_status spfl) in
-                       { open_subgoals = newstatus;
-			 goal          = p.goal;
-			 ref           = Some(r,spfl) }
-                     else 
-		       error "descend: validation"))
-	     | _ -> assert false)
-    	else 
-	  error "Too few subproofs"
-
 let traverse n pts = match n with 
   | 0 -> (* go to the parent *)
       (match  pts.tstack with
 	 | [] -> error "traverse: no ancestors"
 	 | (_,v)::tl ->
-	     { tpf = v [pts.tpf];
+             let pf = v [pts.tpf] in
+             let pf = norm_evar_proof pts.tpfsigma pf in
+	     { tpf = pf;
 	       tstack = tl;
 	       tpfsigma = pts.tpfsigma })
   | -1 -> (* go to the hidden tactic-proof, if any, otherwise fail *)
       (match pts.tpf.ref with
-	 | Some (Tactic (_,spf),_) ->
+	 | Some (Nested (_,spf),_) ->
 	     let v = (fun pfl -> pts.tpf) in 
 	     { tpf = spf;
                tstack = (-1,v)::pts.tstack;
@@ -732,17 +679,23 @@ let app_tac sigr tac p =
   sigr := gll.sigma;
   v (List.map leaf gll.it)
 
-(* solve the nth subgoal with tactic tac *)
-let solve_nth_pftreestate n tac pts =
+(* modify proof state at current position *)
+
+let map_pftreestate f pts =
   let sigr = ref pts.tpfsigma in
-  let tpf' = frontier_map (app_tac sigr tac) n pts.tpf in
+  let tpf' = f sigr pts.tpf in
   let tpf'' =
-    if !sigr == pts.tpfsigma then tpf'
-    else frontier_mapi (fun _ g -> app_tac sigr norm_evar_tac g) tpf' in
+    if !sigr == pts.tpfsigma then tpf' else norm_evar_proof !sigr tpf' in
   { tpf      = tpf'';
     tpfsigma = !sigr;
     tstack   = pts.tstack }
 
+(* solve the nth subgoal with tactic tac *)
+
+let solve_nth_pftreestate n tac =
+  map_pftreestate 
+    (fun sigr pt -> frontier_map (app_tac sigr tac) n pt)
+ 
 let solve_pftreestate = solve_nth_pftreestate 1
 
 (* This function implements a poor man's undo at the current goal.
@@ -774,15 +727,16 @@ let extract_pftreestate pts =
       (str"Cannot extract from a proof-tree in which we have descended;" ++
          spc () ++ str"Please ascend to the root");
   let pfterm,subgoals = extract_open_pftreestate pts in
-  let exl = Evd.non_instantiated pts.tpfsigma in 
+  let exl = Evarutil.non_instantiated pts.tpfsigma in
   if subgoals <> [] or exl <> [] then
-   errorlabstrm "extract_proof"
-   (if subgoals <> [] then 
-     str "Attempt to save an incomplete proof"
-    else
-      str "Attempt to save a proof with existential variables still non-instantiated");
+    errorlabstrm "extract_proof"
+      (if subgoals <> [] then
+        str "Attempt to save an incomplete proof"
+      else
+        str "Attempt to save a proof with existential variables still non-instantiated");
   let env = Global.env_of_context pts.tpf.goal.evar_hyps in
-  strong whd_betaiotaevar env pts.tpfsigma pfterm
+  nf_betaiotaevar_preserving_vm_cast env pts.tpfsigma pfterm
+  (* strong whd_betaiotaevar env pts.tpfsigma pfterm *)
   (***
   local_strong (Evarutil.whd_ise (ts_it pts.tpfsigma)) pfterm
   ***)
@@ -893,137 +847,54 @@ let prev_unproven pts =
 let rec top_of_tree pts = 
   if is_top_pftreestate pts then pts else top_of_tree(traverse 0 pts)
 
+let change_rule f pts =
+  let mark_top _ pt =
+    match pt.ref with
+	Some (oldrule,l) -> 
+	  {pt with ref=Some (f oldrule,l)}
+      | _ -> invalid_arg "change_rule" in
+    map_pftreestate mark_top pts
+
+let match_rule p pts =
+  match (proof_of_pftreestate pts).ref with
+      Some (r,_) -> p r
+    | None -> false
+
+let rec up_until_matching_rule p pts = 
+  if is_top_pftreestate pts then 
+    raise Not_found
+  else
+    let one_up = traverse 0 pts in
+      if match_rule p one_up then 
+	pts
+      else
+	up_until_matching_rule p one_up
 
-(* Pretty-printers. *)
+let rec up_to_matching_rule p pts = 
+  if match_rule p pts then 
+    pts
+  else
+    if is_top_pftreestate pts then 
+      raise Not_found
+    else
+      let one_up = traverse 0 pts in
+      	up_to_matching_rule p one_up
 
-open Pp
+(* Change evars *)
+let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma}
 
-let pr_tactic = function
-  | Tacexpr.TacArg (Tacexpr.Tacexp t) ->
-      if !Options.v7 then
-	Pptactic.pr_glob_tactic t (*top tactic from tacinterp*)
-      else
-	Pptacticnew.pr_glob_tactic (Global.env()) t
-  | t -> 
-      if !Options.v7 then
-	Pptactic.pr_tactic t
-      else
-	Pptacticnew.pr_tactic (Global.env()) t
-
-let pr_rule = function
-  | Prim r -> hov 0 (pr_prim_rule r)
-  | Tactic (texp,_) -> hov 0 (pr_tactic texp)
-  | Change_evars ->
-      (* This is internal tactic and cannot be replayed at user-level.
-         Function pr_rule_dot below is used when we want to hide
-         Change_evars *)
-      str "Evar change"
-
-(* Does not print change of evars *)
-let pr_rule_dot = function 
-  | Change_evars -> mt ()
-  | r -> pr_rule r ++ str"."
-
-exception Different
-
-(* We remove from the var context of env what is already in osign *)
-let thin_sign osign sign =
-  Sign.fold_named_context
-    (fun (id,c,ty as d) sign ->
-       try 
-	 if Sign.lookup_named id osign = (id,c,ty) then sign
-	 else raise Different
-       with Not_found | Different -> add_named_decl d sign)
-    sign ~init:empty_named_context
-
-let rec print_proof sigma osign pf =
-  let {evar_hyps=hyps; evar_concl=cl; 
-       evar_body=body} = pf.goal in
-  let hyps' = thin_sign osign hyps in
-  match pf.ref with
-    | None -> 
-	hov 0 (pr_seq {evar_hyps=hyps'; evar_concl=cl; evar_body=body})
-    | Some(r,spfl) ->
-    	hov 0 
-	  (hov 0 (pr_seq {evar_hyps=hyps'; evar_concl=cl; evar_body=body}) ++
-	   spc () ++ str" BY " ++
-	   hov 0 (pr_rule r) ++ fnl () ++
-	   str"  " ++
-	   hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl)
-)
-	  
-let pr_change gl = 
-  (str"Change " ++ prterm_env (Global.env()) gl.evar_concl ++ str".")
-
-let rec print_script nochange sigma osign pf =
-  let {evar_hyps=sign; evar_concl=cl} = pf.goal in
-  match pf.ref with
-    | None ->
-        (if nochange then 
-	  (str"<Your Tactic Text here>") 
-	else 
-	  pr_change pf.goal)
-	++ fnl ()
-    | Some(r,spfl) ->
-        ((if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())) ++
-           pr_rule_dot r ++ fnl () ++
-           prlist_with_sep pr_fnl
-             (print_script nochange sigma sign) spfl)
-
-let print_treescript nochange sigma _osign pf =
-  let rec aux top pf =
-    let {evar_hyps=sign; evar_concl=cl} = pf.goal in
-    match pf.ref with
-    | None ->
-        if nochange then 
-	  (str"<Your Tactic Text here>") 
-	else 
-	  (pr_change pf.goal)
-    | Some(r,spfl) ->
-        (if nochange then mt () else (pr_change pf.goal ++ fnl ())) ++
-	pr_rule_dot r ++
-	match spfl with
-	| [] -> mt ()
-	| [spf] -> fnl () ++ (if top then mt () else str "  ") ++ aux top spf
-	| _ -> fnl () ++ str " " ++
-	    hov 0 (prlist_with_sep fnl (aux false) spfl)
-  in hov 0 (aux true pf)
-
-let rec print_info_script sigma osign pf =
-  let {evar_hyps=sign; evar_concl=cl} = pf.goal in
-  match pf.ref with
-    | None -> (mt ())
-    | Some(Change_evars,[spf]) ->
-        print_info_script sigma osign spf
-    | Some(r,spfl) ->
-        (pr_rule r ++ 
-           match spfl with
-             | [pf1] ->
-                 if pf1.ref = None then 
-		   (str "." ++ fnl ())
-                 else 
-		   (str";" ++ brk(1,3) ++
-		      print_info_script sigma sign pf1)
-             | _ -> (str"." ++ fnl () ++
-                       prlist_with_sep pr_fnl
-                         (print_info_script sigma sign) spfl))
-
-let format_print_info_script sigma osign pf = 
-  hov 0 (print_info_script sigma osign pf)
-    
-let print_subscript sigma sign pf = 
-  if is_tactic_proof pf then 
-    format_print_info_script sigma sign (subproof_of_proof pf)
-  else 
-    format_print_info_script sigma sign pf
+(* Pretty-printers. *)
+
+let pp_info = ref (fun _ _ _ -> assert false)
+let set_info_printer f = pp_info := f
 
 let tclINFO (tac : tactic) gls = 
   let (sgl,v) as res = tac gls in 
   begin try 
     let pf = v (List.map leaf (sig_it sgl)) in
-    let sign = (sig_it gls).evar_hyps in
+    let sign = named_context_of_val (sig_it gls).evar_hyps in
     msgnl (hov 0 (str" == " ++
-                  print_subscript (sig_sig gls) sign pf))
+                  !pp_info (project gls) sign pf))
   with e when catchable_exception e -> 
     msgnl (hov 0 (str "Info failed to apply validation"))
   end;
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index f6f2082e..d8b13dba 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: refiner.mli,v 1.31.2.2 2005/01/21 16:41:51 herbelin Exp $ i*)
+(*i $Id: refiner.mli 9244 2006-10-16 17:11:44Z barras $ i*)
 
 (*i*)
 open Term
@@ -20,9 +20,10 @@ open Tacexpr
 (* The refiner (handles primitive rules and high-level tactics). *)
 
 val sig_it  : 'a sigma -> 'a
-val sig_sig : 'a sigma -> evar_map
+val project : 'a sigma -> evar_map
 
-val project_with_focus : goal sigma -> named_context sigma
+val pf_env  : goal sigma -> Environ.env
+val pf_hyps : goal sigma -> named_context
 
 val unpackage : 'a sigma -> evar_map ref * 'a
 val repackage : evar_map ref -> 'a -> 'a sigma
@@ -31,20 +32,17 @@ val apply_sig_tac :
 
 type transformation_tactic = proof_tree -> (goal list * validation)
 
-val add_tactic             : string -> (closed_generic_argument list -> tactic) -> unit
-val overwriting_add_tactic : string -> (closed_generic_argument list -> tactic) -> unit
-val lookup_tactic          : string -> (closed_generic_argument list) -> tactic
-
 (*s Hiding the implementation of tactics. *)
 
 (* [abstract_tactic tac] hides the (partial) proof produced by [tac] under
-   a single proof node *)
-val abstract_tactic : atomic_tactic_expr -> tactic -> tactic
-val abstract_tactic_expr : tactic_expr -> tactic -> tactic
-val abstract_extended_tactic : string -> closed_generic_argument list -> tactic -> tactic
+   a single proof node. The boolean tells if the default tactic is used. *)
+val abstract_operation : compound_rule -> tactic -> tactic
+val abstract_tactic : ?dflt:bool -> atomic_tactic_expr -> tactic -> tactic
+val abstract_tactic_expr : ?dflt:bool -> tactic_expr -> tactic -> tactic
+val abstract_extended_tactic :
+  ?dflt:bool -> string -> closed_generic_argument list -> tactic -> tactic
 
 val refiner : rule -> tactic
-val vernac_tactic : string * closed_generic_argument list -> tactic
 val frontier : transformation_tactic
 val list_pf : proof_tree -> goal list
 val unTAC : tactic -> goal sigma -> proof_tree sigma
@@ -65,8 +63,10 @@ val frontier_mapi :
 
 (* [tclIDTAC] is the identity tactic without message printing*)
 val tclIDTAC          : tactic
-val tclIDTAC_MESSAGE  : string -> tactic
+val tclIDTAC_MESSAGE  : Pp.std_ppcmds -> tactic
 
+(* [tclEVARS sigma] changes the current evar map *)
+val tclEVARS : evar_map -> tactic
 
 (* [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
    [tac2] to every resulting subgoals *)
@@ -120,7 +120,7 @@ val tclTHENLASTn    : tactic -> tactic array -> tactic
 val tclTHENFIRSTn   : tactic -> tactic array -> tactic
 
 (* A special exception for levels for the Fail tactic *)
-exception FailError of int * string
+exception FailError of int * Pp.std_ppcmds
 
 val tclORELSE        : tactic -> tactic -> tactic
 val tclREPEAT        : tactic -> tactic
@@ -131,7 +131,7 @@ val tclTRY           : tactic -> tactic
 val tclTHENTRY       : tactic -> tactic -> tactic
 val tclCOMPLETE      : tactic -> tactic
 val tclAT_LEAST_ONCE : tactic -> tactic
-val tclFAIL          : int -> string -> tactic
+val tclFAIL          : int -> Pp.std_ppcmds -> tactic
 val tclDO            : int -> tactic -> tactic
 val tclPROGRESS      : tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
@@ -145,6 +145,12 @@ val tclIFTHENELSE    : tactic -> tactic -> tactic -> tactic
 val tclIFTHENSELSE   : tactic -> tactic list -> tactic ->tactic
 val tclIFTHENSVELSE   : tactic -> tactic array -> tactic ->tactic
 
+(* [tclIFTHENTRYELSEMUST tac1 tac2 gls] applies [tac1] then [tac2]. If [tac1]
+   has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed. 
+   Equivalent to [(tac1;try tac2)||tac2] *)
+
+val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
+
 (*s Tactics handling a list of goals. *)
 
 type validation_list = proof_tree list -> proof_tree list
@@ -167,11 +173,14 @@ type pftreestate
 val proof_of_pftreestate : pftreestate -> proof_tree
 val cursor_of_pftreestate : pftreestate -> int list
 val is_top_pftreestate : pftreestate -> bool
+val match_rule : (rule -> bool) -> pftreestate -> bool
 val evc_of_pftreestate : pftreestate -> evar_map
 val top_goal_of_pftreestate : pftreestate -> goal sigma
 val nth_goal_of_pftreestate : int -> pftreestate -> goal sigma
 
 val traverse : int -> pftreestate -> pftreestate
+val map_pftreestate : 
+  (evar_map ref -> proof_tree -> proof_tree) -> pftreestate -> pftreestate
 val solve_nth_pftreestate : int -> tactic -> pftreestate -> pftreestate
 val solve_pftreestate : tactic -> pftreestate -> pftreestate
 
@@ -190,6 +199,12 @@ val node_next_unproven : int -> pftreestate -> pftreestate
 val next_unproven : pftreestate -> pftreestate
 val prev_unproven : pftreestate -> pftreestate
 val top_of_tree : pftreestate -> pftreestate
+val match_rule : (rule -> bool) -> pftreestate -> bool
+val up_until_matching_rule : (rule -> bool) -> 
+  pftreestate -> pftreestate
+val up_to_matching_rule : (rule -> bool) -> 
+  pftreestate -> pftreestate
+val change_rule : (rule -> rule) -> pftreestate -> pftreestate
 val change_constraints_pftreestate 
   : evar_map -> pftreestate -> pftreestate
 
@@ -199,11 +214,5 @@ val change_constraints_pftreestate
 (*i*)
 open Pp
 (*i*)
-
-val print_proof : evar_map -> named_context -> proof_tree -> std_ppcmds
-val pr_rule     : rule -> std_ppcmds
-val pr_tactic   : tactic_expr -> std_ppcmds
-val print_script :
-  bool -> evar_map -> named_context -> proof_tree -> std_ppcmds
-val print_treescript :
-  bool -> evar_map -> named_context -> proof_tree -> std_ppcmds
+val set_info_printer :
+  (evar_map -> named_context -> proof_tree -> Pp.std_ppcmds) -> unit
diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml
index cd8d34db..0bcc7d16 100644
--- a/proofs/tacexpr.ml
+++ b/proofs/tacexpr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacexpr.ml,v 1.33.2.3 2005/05/15 12:47:04 herbelin Exp $ i*)
+(*i $Id: tacexpr.ml 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 open Names
 open Topconstr
@@ -20,6 +20,7 @@ open Pattern
 type 'a or_metaid = AI of 'a | MetaId of loc * string
 
 type direction_flag = bool (* true = Left-to-right    false = right-to-right *)
+type lazy_flag = bool      (* true = lazy             false = eager *)
 
 type raw_red_flag =
   | FBeta
@@ -55,8 +56,7 @@ type hyp_location_flag = (* To distinguish body and type of local defs *)
   | InHypTypeOnly
   | InHypValueOnly
 
-type 'a raw_hyp_location = 
-    'a * int list * (hyp_location_flag * hyp_location_flag option ref)
+type 'a raw_hyp_location = 'a with_occurrences * hyp_location_flag
 
 type 'a induction_arg =
   | ElimOnConstr of 'a
@@ -69,12 +69,18 @@ type inversion_kind =
   | FullInversionClear
 
 type ('c,'id) inversion_strength =
-  | NonDepInversion of inversion_kind * 'id list * intro_pattern_expr option
-  | DepInversion of inversion_kind * 'c option * intro_pattern_expr option
+  | NonDepInversion of inversion_kind * 'id list * intro_pattern_expr
+  | DepInversion of inversion_kind * 'c option * intro_pattern_expr
   | InversionUsing of 'c * 'id list
 
 type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b
 
+type 'id message_token =
+  | MsgString of string
+  | MsgInt of int
+  | MsgIdent of 'id
+
+
 type 'id gsimple_clause = ('id raw_hyp_location) option
 (* onhyps:
      [None] means *on every hypothesis*
@@ -82,7 +88,9 @@ type 'id gsimple_clause = ('id raw_hyp_location) option
 type 'id gclause =
   { onhyps : 'id raw_hyp_location list option;
     onconcl : bool;
-    concl_occs :int list }
+    concl_occs : int or_var list }
+
+let nowhere = {onhyps=Some[]; onconcl=false; concl_occs=[]}
 
 let simple_clause_of = function
     { onhyps = Some[scl]; onconcl = false } -> Some scl
@@ -112,6 +120,8 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
   | TacIntroMove of identifier option * identifier located option
   | TacAssumption
   | TacExact of 'constr
+  | TacExactNoCheck of 'constr
+  | TacVmCastNoCheck of 'constr
   | TacApply of 'constr with_bindings
   | TacElim of 'constr with_bindings * 'constr with_bindings option
   | TacElimType of 'constr
@@ -122,20 +132,19 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
   | TacCofix of identifier option
   | TacMutualCofix of identifier * (identifier * 'constr) list
   | TacCut of 'constr
-  | TacTrueCut of name * 'constr 
-  | TacForward of bool * name * 'constr
+  | TacAssert of 'tac option * intro_pattern_expr * 'constr
   | TacGeneralize of 'constr list
   | TacGeneralizeDep of 'constr
   | TacLetTac of name * 'constr * 'id gclause
-  | TacInstantiate of int * 'constr * 'id gclause
+(*  | TacInstantiate of int * 'constr * (('id * hyp_location_flag,unit) location) *)
 
   (* Derived basic tactics *)
-  | TacSimpleInduction of (quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref)
-  | TacNewInduction of 'constr induction_arg * 'constr with_bindings option
-      * (intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref)
+  | TacSimpleInduction of quantified_hypothesis
+  | TacNewInduction of 'constr induction_arg list * 'constr with_bindings option
+      * intro_pattern_expr
   | TacSimpleDestruct of quantified_hypothesis
-  | TacNewDestruct of 'constr induction_arg * 'constr with_bindings option
-      * (intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref)
+  | TacNewDestruct of 'constr induction_arg list * 'constr with_bindings option
+      * intro_pattern_expr
 
   | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis
   | TacDecomposeAnd of 'constr
@@ -145,8 +154,8 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
   | TacLApply of 'constr
 
   (* Automation tactics *)
-  | TacTrivial of string list option
-  | TacAuto of int or_var option * string list option
+  | TacTrivial of 'constr list * string list option
+  | TacAuto of int or_var option * 'constr list * string list option
   | TacAutoTDB of int option
   | TacDestructHyp of (bool * identifier located)
   | TacDestructConcl
@@ -154,7 +163,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
   | TacDAuto of int or_var option * int option
 
   (* Context management *)
-  | TacClear of 'id list
+  | TacClear of bool * 'id list
   | TacClearBody of 'id list
   | TacMove of bool * 'id * 'id
   | TacRename of 'id * 'id
@@ -168,8 +177,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
 
   (* Conversion *)
   | TacReduce of ('constr,'cst) red_expr_gen * 'id gclause
-  | TacChange of
-      'constr occurrences option * 'constr * 'id gclause
+  | TacChange of 'constr with_occurrences option * 'constr * 'id gclause
 
   (* Equivalence relations *)
   | TacReflexivity
@@ -177,6 +185,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
   | TacTransitivity of 'constr 
 
   (* Equality and inversion *)
+  | TacRewrite of bool * 'constr with_bindings * 'id gclause
   | TacInversion of ('constr,'id) inversion_strength * quantified_hypothesis
       
   (* For ML extensions *)
@@ -185,13 +194,14 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
   (* For syntax extensions *)
   | TacAlias of loc * string *
       (identifier * ('constr,'tac) generic_argument) list
-      * (dir_path * 'tac)
+      * (dir_path * glob_tactic_expr)
 
 and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr =
   | TacAtom of loc * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr
   | TacThen of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
   | TacThens of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr list
   | TacFirst of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr list
+  | TacComplete of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
   | TacSolve of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr list
   | TacTry of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
   | TacOrelse of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
@@ -199,14 +209,13 @@ and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr =
   | TacRepeat of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
   | TacProgress of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
   | TacAbstract of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * identifier option
-  | TacId of string
-  | TacFail of int or_var * string
+  | TacId of 'id message_token list
+  | TacFail of int or_var * 'id message_token list
   | TacInfo of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-
   | TacLetRecIn of (identifier located * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_fun_ast) list * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
   | TacLetIn of (identifier located * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr option * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg) list * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
-  | TacMatch of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr) match_rule list
-  | TacMatchContext of direction_flag * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr) match_rule list
+  | TacMatch of lazy_flag * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr) match_rule list
+  | TacMatchContext of lazy_flag * direction_flag * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr) match_rule list
   | TacFun of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_fun_ast
   | TacArg of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg
 
@@ -224,9 +233,21 @@ and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg =
   | Integer        of int
   | TacCall        of loc *
       'ref * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg list
-  | TacFreshId     of string option
+  | TacExternal of loc * string * string * 
+      ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg list
+  | TacFreshId     of string or_var list
   | Tacexp of 'tac
 
+(* Globalized tactics *)
+and glob_tactic_expr =
+    (rawconstr_and_expr,
+     constr_pattern,
+     evaluable_global_reference and_short_name or_var,
+     inductive or_var,
+     ltac_constant located or_var,
+     identifier located,
+     glob_tactic_expr) gen_tactic_expr
+
 type raw_tactic_expr =
     (constr_expr,
      pattern_expr,
@@ -259,16 +280,6 @@ type raw_generic_argument =
 
 type raw_red_expr = (constr_expr, reference) red_expr_gen
 
-(* Globalized tactics *)
-type glob_tactic_expr =
-    (rawconstr_and_expr,
-     constr_pattern,
-     evaluable_global_reference and_short_name or_var,
-     inductive or_var,
-     ltac_constant located or_var,
-     identifier located,
-     glob_tactic_expr) gen_tactic_expr
-
 type glob_atomic_tactic_expr =
     (rawconstr_and_expr,
      constr_pattern,
@@ -283,8 +294,8 @@ type glob_tactic_arg =
      constr_pattern,
      evaluable_global_reference and_short_name or_var,
      inductive or_var,
-     ltac_constant located,
-     identifier located or_var,
+     ltac_constant located or_var,
+     identifier located,
      glob_tactic_expr) gen_tactic_arg
 
 type glob_generic_argument =
@@ -297,10 +308,10 @@ type closed_raw_generic_argument =
     (constr_expr,raw_tactic_expr) generic_argument
 
 type 'a raw_abstract_argument_type =
-    ('a,constr_expr,raw_tactic_expr) abstract_argument_type
+    ('a,rlevel,raw_tactic_expr) abstract_argument_type
 
 type 'a glob_abstract_argument_type =
-    ('a,rawconstr_and_expr,glob_tactic_expr) abstract_argument_type
+    ('a,glevel,glob_tactic_expr) abstract_argument_type
 
 type open_generic_argument =
     (Term.constr,glob_tactic_expr) generic_argument
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index 0e3a49b0..baf8c859 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacmach.ml,v 1.61.2.1 2004/07/16 19:30:50 herbelin Exp $ *)
+(* $Id: tacmach.ml 9511 2007-01-22 08:27:31Z herbelin $ *)
 
 open Util
 open Names
@@ -14,11 +14,11 @@ open Nameops
 open Sign
 open Term
 open Termops
-open Instantiate
 open Environ
 open Reductionops
 open Evd
 open Typing
+open Redexpr
 open Tacred
 open Proof_trees
 open Proof_type
@@ -32,7 +32,7 @@ let re_sig it gc = { it = it; sigma = gc }
 (* Operations for handling terms under a local typing context *)
 (**************************************************************)
 
-type 'a sigma   = 'a Proof_type.sigma;;
+type 'a sigma   = 'a Evd.sigma;;
 type validation = Proof_type.validation;;
 type tactic     = Proof_type.tactic;;
 
@@ -40,10 +40,10 @@ let unpackage = Refiner.unpackage
 let repackage = Refiner.repackage
 let apply_sig_tac = Refiner.apply_sig_tac
 
-let sig_it     = Refiner.sig_it
-let project    = Refiner.sig_sig
-let pf_env gls = Global.env_of_context (sig_it gls).evar_hyps
-let pf_hyps gls = (sig_it gls).evar_hyps
+let sig_it   = Refiner.sig_it
+let project  = Refiner.project
+let pf_env   = Refiner.pf_env
+let pf_hyps  = Refiner.pf_hyps
 
 let pf_concl gls = (sig_it gls).evar_concl
 let pf_hyps_types gls  =
@@ -79,10 +79,6 @@ let pf_interp_constr gls c =
   let evc = project gls in 
   Constrintern.interp_constr evc (pf_env gls) c
 
-let pf_interp_openconstr gls c =
-  let evc = project gls in 
-  Constrintern.interp_openconstr evc (pf_env gls) c
-
 let pf_interp_type gls c =
   let evc = project gls in 
   Constrintern.interp_type evc (pf_env gls) c
@@ -91,12 +87,8 @@ let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id
 
 let pf_parse_const gls = compose (pf_global gls) id_of_string
 
-let pf_execute gls =
-  let evc = project gls in 
-  Typing.unsafe_machine (pf_env gls) evc
-
-let pf_reduction_of_redexp gls re c = 
-  reduction_of_redexp re (pf_env gls) (project gls) c 
+let pf_reduction_of_red_expr gls re c = 
+  (fst (reduction_of_red_expr re)) (pf_env gls) (project gls) c 
 
 let pf_apply f gls = f (pf_env gls) (project gls)
 let pf_reduce = pf_apply
@@ -110,6 +102,7 @@ let pf_nf_betaiota               = pf_reduce (fun _ _ -> nf_betaiota)
 let pf_compute                   = pf_reduce compute
 let pf_unfoldn ubinds            = pf_reduce (unfoldn ubinds)
 let pf_type_of                   = pf_reduce type_of
+let pf_get_type_of               = pf_reduce Retyping.get_type_of
 
 let pf_conv_x                   = pf_reduce is_conv
 let pf_conv_x_leq               = pf_reduce is_conv_leq
@@ -117,9 +110,10 @@ let pf_const_value              = pf_reduce (fun env _ -> constant_value env)
 let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind
 let pf_reduce_to_atomic_ind     = pf_reduce reduce_to_atomic_ind
 
-let hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_type_of gls)
+let hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls)
 
-let pf_check_type gls c1 c2 = ignore (pf_type_of gls (mkCast (c1, c2)))
+let pf_check_type gls c1 c2 = 
+  ignore (pf_type_of gls (mkCast (c1, DEFAULTcast, c2)))
 
 (************************************)
 (* Tactics handling a list of goals *)
@@ -194,8 +188,8 @@ let internal_cut_rev_no_check id t gl =
 let refine_no_check c gl = 
   refiner (Prim (Refine c)) gl
 
-let convert_concl_no_check c gl = 
-  refiner (Prim (Convert_concl c)) gl
+let convert_concl_no_check c sty gl = 
+  refiner (Prim (Convert_concl (c,sty))) gl
 
 let convert_hyp_no_check d gl =
   refiner (Prim (Convert_hyp d)) gl
@@ -221,9 +215,11 @@ let mutual_cofix f others gl =
   with_check (refiner (Prim (Cofix (f,others)))) gl
     
 let rename_bound_var_goal gls =
-  let { evar_hyps = sign; evar_concl = cl } as gl = sig_it gls in 
-  let ids = ids_of_named_context sign in
-  convert_concl_no_check (rename_bound_var (Global.env()) ids cl) gls
+  let { evar_hyps = sign; evar_concl = cl } = sig_it gls in 
+  let ids = ids_of_named_context (named_context_of_val sign) in
+  convert_concl_no_check 
+    (rename_bound_var (Global.env()) ids cl) DEFAULTcast gls 
+
 
 
 (* Versions with consistency checks *)
@@ -233,7 +229,7 @@ let intro_replacing id = with_check (intro_replacing_no_check id)
 let internal_cut d t     = with_check (internal_cut_no_check d t)
 let internal_cut_rev d t = with_check (internal_cut_rev_no_check d t)
 let refine c           = with_check (refine_no_check c)
-let convert_concl d    = with_check (convert_concl_no_check d)
+let convert_concl d sty = with_check (convert_concl_no_check d sty)
 let convert_hyp d      = with_check (convert_hyp_no_check d)
 let thin l             = with_check (thin_no_check l)
 let thin_body c        = with_check (thin_body_no_check c)
@@ -243,7 +239,6 @@ let rename_hyp id id'  = with_check (rename_hyp_no_check id id')
 (* Pretty-printers *)
 
 open Pp
-open Printer
 open Tacexpr
 open Rawterm
 
@@ -252,9 +247,9 @@ let rec pr_list f = function
   | a::l1 -> (f a) ++ pr_list f l1
 
 let pr_gls gls =
-  hov 0 (pr_decls (sig_sig gls) ++ fnl () ++ pr_seq (sig_it gls))
+  hov 0 (pr_evar_map (sig_sig gls) ++ fnl () ++ db_pr_goal (sig_it gls))
 
 let pr_glls glls =
-  hov 0 (pr_decls (sig_sig glls) ++ fnl () ++
-         prlist_with_sep pr_fnl pr_seq (sig_it glls))
+  hov 0 (pr_evar_map (sig_sig glls) ++ fnl () ++
+         prlist_with_sep pr_fnl db_pr_goal (sig_it glls))
   
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index 2990567e..9352cb5d 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacmach.mli,v 1.50.2.2 2005/01/21 16:41:52 herbelin Exp $ i*)
+(*i $Id: tacmach.mli 7639 2005-12-02 10:01:15Z gregoire $ i*)
 
 (*i*)
 open Names
@@ -18,14 +18,14 @@ open Reduction
 open Proof_trees
 open Proof_type
 open Refiner
-open Tacred
+open Redexpr
 open Tacexpr
 open Rawterm
 (*i*)
 
 (* Operations for handling terms under a local typing context. *)
 
-type 'a sigma   = 'a Proof_type.sigma;;
+type 'a sigma   = 'a Evd.sigma;;
 type validation = Proof_type.validation;;
 type tactic     = Proof_type.tactic;;
 
@@ -51,7 +51,6 @@ val pf_global             : goal sigma -> identifier -> constr
 val pf_parse_const        : goal sigma -> string -> constr
 val pf_type_of            : goal sigma -> constr -> types
 val pf_check_type         : goal sigma -> constr -> types -> unit
-val pf_execute            : goal sigma -> constr -> unsafe_judgment
 val hnf_type_of           : goal sigma -> constr -> types
 
 val pf_interp_constr      : goal sigma -> Topconstr.constr_expr -> constr
@@ -63,7 +62,7 @@ val pf_get_hyp_typ        : goal sigma -> identifier -> types
 val pf_get_new_id  : identifier      -> goal sigma -> identifier
 val pf_get_new_ids : identifier list -> goal sigma -> identifier list
 
-val pf_reduction_of_redexp : goal sigma -> red_expr -> constr -> constr
+val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> constr
 
 
 val pf_apply : (env -> evar_map -> 'a) -> goal sigma -> 'a
@@ -120,9 +119,6 @@ val top_of_tree             : pftreestate -> pftreestate
 val change_constraints_pftreestate :
   evar_map -> pftreestate -> pftreestate
 
-(*i
-val vernac_tactic : string * tactic_arg list -> tactic
-i*)
 (*s The most primitive tactics. *)
 
 val refiner                   : rule -> tactic
@@ -131,7 +127,7 @@ val intro_replacing_no_check  : identifier -> tactic
 val internal_cut_no_check     : identifier -> types -> tactic
 val internal_cut_rev_no_check : identifier -> types -> tactic
 val refine_no_check           : constr -> tactic
-val convert_concl_no_check    : types -> tactic
+val convert_concl_no_check    : types -> cast_kind -> tactic
 val convert_hyp_no_check      : named_declaration -> tactic
 val thin_no_check             : identifier list -> tactic
 val thin_body_no_check        : identifier list -> tactic
@@ -149,10 +145,7 @@ val intro_replacing  : identifier -> tactic
 val internal_cut     : identifier -> types -> tactic
 val internal_cut_rev : identifier -> types -> tactic
 val refine           : constr -> tactic
-val convert_concl    : constr -> tactic
-val convert_hyp      : named_declaration -> tactic
-val thin             : identifier list -> tactic
-val convert_concl    : types -> tactic
+val convert_concl    : types -> cast_kind -> tactic
 val convert_hyp      : named_declaration -> tactic
 val thin             : identifier list -> tactic
 val thin_body        : identifier list -> tactic
@@ -173,11 +166,6 @@ val tactic_list_tactic : tactic_list -> tactic
 val tclFIRSTLIST       : tactic_list list -> tactic_list
 val tclIDTAC_list      : tactic_list
 
-(*s Pretty-printing functions. *)
-
-(*i*)
-open Pp
-(*i*)
-
-val pr_gls    : goal sigma -> std_ppcmds
-val pr_glls   : goal list sigma -> std_ppcmds
+(*s Pretty-printing functions (debug only). *)
+val pr_gls    : goal sigma -> Pp.std_ppcmds
+val pr_glls   : goal list sigma -> Pp.std_ppcmds
diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml
index 1fa1101d..96df8f64 100644
--- a/proofs/tactic_debug.ml
+++ b/proofs/tactic_debug.ml
@@ -6,17 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Ast
 open Names
 open Constrextern
 open Pp
-open Pptactic
-open Printer
 open Tacexpr
 open Termops
 
-let pr_glob_tactic x =
-  (if !Options.v7 then pr_glob_tactic else Pptacticnew.pr_glob_tactic (Global.env())) x
+let prtac = ref (fun _ -> assert false)
+let set_tactic_printer f = prtac := f
+let prmatchpatt = ref (fun _ _ -> assert false)
+let set_match_pattern_printer f = prmatchpatt := f
+let prmatchrl = ref (fun _ -> assert false)
+let set_match_rule_printer f = prmatchrl := f
 
 (* This module intends to be a beginning of debugger for tactic expressions.
    Currently, it is quite simple and we can hope to have, in the future, a more
@@ -30,9 +31,11 @@ type debug_info =
 (* An exception handler *)
 let explain_logic_error = ref (fun e -> mt())
 
+let explain_logic_error_no_anomaly = ref (fun e -> mt())
+
 (* Prints the goal *)
 let db_pr_goal g =
-  msgnl (str "Goal:" ++ fnl () ++ Proof_trees.pr_goal (Tacmach.sig_it g))
+  msgnl (str "Goal:" ++ fnl () ++ Proof_trees.db_pr_goal (Refiner.sig_it g))
 
 (* Prints the commands *)
 let help () =
@@ -46,7 +49,7 @@ let help () =
 let goal_com g tac =
   begin
     db_pr_goal g;
-    msg (str "Going to execute:" ++ fnl () ++ pr_glob_tactic tac ++ fnl ())
+    msg (str "Going to execute:" ++ fnl () ++ !prtac tac ++ fnl ())
   end
 
 (* Gives the number of a run command *)
@@ -75,11 +78,12 @@ let rec prompt level =
   begin
     msg (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ");
     flush stdout;
-    let inst = read_line () in
+    let exit () = skip:=0;allskip:=0;raise Sys.Break in
+    let inst = try read_line () with End_of_file -> exit () in
     match inst with
     | ""  -> true
     | "s" -> false
-    | "x" -> print_char (Char.chr 8);skip:=0;allskip:=0;raise Sys.Break
+    | "x" -> print_char (Char.chr 8); exit ()
     | "h"| "?" ->
       begin
         help ();
@@ -107,15 +111,14 @@ let debug_prompt lev g tac f =
 (* Prints a constr *)
 let db_constr debug env c =
   if debug <> DebugOff & !skip = 0 then
-    msgnl (str "Evaluated term: " ++ prterm_env env c)
+    msgnl (str "Evaluated term: " ++ print_constr_env env c)
 
 (* Prints the pattern rule *)
 let db_pattern_rule debug num r =
   if debug <> DebugOff & !skip = 0 then
   begin
     msgnl (str "Pattern rule " ++ int num ++ str ":");
-    msgnl (str "|" ++ spc () ++ 
-      pr_match_rule false Printer.pr_pattern pr_glob_tactic r)
+    msgnl (str "|" ++ spc () ++ !prmatchrl r)
   end
 
 (* Prints the hypothesis pattern identifier if it exists *)
@@ -128,12 +131,12 @@ let db_matched_hyp debug env (id,c) ido =
   if debug <> DebugOff & !skip = 0 then
     msgnl (str "Hypothesis " ++
            str ((Names.string_of_id id)^(hyp_bound ido)^
-                " has been matched: ") ++ prterm_env env c)
+                " has been matched: ") ++ print_constr_env env c)
 
 (* Prints the matched conclusion *)
 let db_matched_concl debug env c =
   if debug <> DebugOff & !skip = 0 then
-    msgnl (str "Conclusion has been matched: " ++ prterm_env env c)
+    msgnl (str "Conclusion has been matched: " ++ print_constr_env env c)
 
 (* Prints a success message when the goal has been matched *)
 let db_mc_pattern_success debug =
@@ -142,18 +145,16 @@ let db_mc_pattern_success debug =
            str "Let us execute the right-hand side part..." ++ fnl())
 
 let pp_match_pattern env = function
-  | Term c -> Term (extern_pattern env (names_of_rel_context env) c)
+  | Term c -> Term (extern_constr_pattern (names_of_rel_context env) c)
   | Subterm (o,c) ->
-    Subterm (o,(extern_pattern env (names_of_rel_context env) c))
+    Subterm (o,(extern_constr_pattern (names_of_rel_context env) c))
 
 (* Prints a failure message for an hypothesis pattern *)
 let db_hyp_pattern_failure debug env (na,hyp) =
   if debug <> DebugOff & !skip = 0 then
     msgnl (str ("The pattern hypothesis"^(hyp_bound na)^
                 " cannot match: ") ++
-           pr_match_pattern
-             (Printer.pr_pattern_env env (names_of_rel_context env))
-             hyp)
+           !prmatchpatt env hyp)
 
 (* Prints a matching failure message for a rule *)
 let db_matching_failure debug =
@@ -164,10 +165,10 @@ let db_matching_failure debug =
 (* Prints an evaluation failure message for a rule *)
 let db_eval_failure debug s =
   if debug <> DebugOff & !skip = 0 then
-    let s = if s="" then "no message" else "message \""^s^"\"" in
+    let s = str "message \"" ++ s ++ str "\"" in
     msgnl 
       (str "This rule has failed due to \"Fail\" tactic (" ++
-       str s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...")
+       s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...")
 
 (* Prints a logic failure message for a rule *)
 let db_logic_failure debug err =
diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli
index 9ab263c4..6de8244d 100644
--- a/proofs/tactic_debug.mli
+++ b/proofs/tactic_debug.mli
@@ -6,10 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactic_debug.mli,v 1.12.2.1 2004/07/16 19:30:50 herbelin Exp $ i*)
+(*i $Id: tactic_debug.mli 9092 2006-08-28 11:42:14Z bertot $ i*)
 
 open Environ
 open Pattern
+open Evd
 open Proof_type
 open Names
 open Tacexpr
@@ -19,6 +20,13 @@ open Term
    Currently, it is quite simple and we can hope to have, in the future, a more
    complete panel of commands dedicated to a proof assistant framework *)
 
+val set_tactic_printer : (glob_tactic_expr ->Pp.std_ppcmds) -> unit
+val set_match_pattern_printer :
+  (env -> constr_pattern match_pattern -> Pp.std_ppcmds) -> unit
+val set_match_rule_printer :
+  ((constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) ->
+    unit
+
 (* Debug information *)
 type debug_info =
   | DebugOn of int
@@ -53,10 +61,16 @@ val db_hyp_pattern_failure :
 val db_matching_failure : debug_info -> unit
 
 (* Prints an evaluation failure message for a rule *)
-val db_eval_failure : debug_info -> string -> unit
+val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit
 
 (* An exception handler *)
 val explain_logic_error: (exn -> Pp.std_ppcmds) ref
 
+(* For use in the Ltac debugger: some exception that are usually
+   consider anomalies are acceptable because they are caught later in
+   the process that is being debugged.  One should not require
+   from users that they report these anomalies. *)
+val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref
+
 (* Prints a logic failure message for a rule *)
 val db_logic_failure : debug_info -> exn -> unit
diff --git a/scripts/coqc.ml b/scripts/coqc.ml
index 34025ec9..676e9e51 100644
--- a/scripts/coqc.ml
+++ b/scripts/coqc.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqc.ml,v 1.25.2.3 2004/09/04 10:34:56 herbelin Exp $ *)
+(* $Id: coqc.ml 7747 2005-12-28 10:28:41Z herbelin $ *)
 
 (* Afin de rendre Coq plus portable, ce programme Caml remplace le script
    coqc. 
@@ -148,10 +148,15 @@ let parse_args () =
 	    | []        -> usage ()
 	end
     | "-R" as o :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem
-    | ("-notactics"|"-debug"|"-nolib"|"-batch"|"-nois"
+
+    | ("-notactics"|"-debug"|"-nolib"
+      | "-debugVM"|"-alltransp"|"-VMno"
+      |"-batch"|"-nois"
       |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet"
-      |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-translate"|"-strict-implicit"
-      |"-dont-load-proofs"|"-impredicative-set" as o) :: rem ->
+      |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-translate" |"-strict-implicit"
+      |"-dont-load-proofs"|"-impredicative-set"|"-vm" 
+      | "-unboxed-values" | "-unboxed-definitions" | "-draw-vm-instr" 
+	  as o) :: rem ->
 	parse (cfiles,o::args) rem
     | ("-v"|"--version") :: _ ->
         Usage.version ()
diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml
index ccb06769..cb46ab19 100644
--- a/scripts/coqmktop.ml
+++ b/scripts/coqmktop.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqmktop.ml,v 1.28.2.2 2005/11/04 08:20:57 herbelin Exp $ *)
+(* $Id: coqmktop.ml 9496 2007-01-17 15:22:11Z herbelin $ *)
 
 (* coqmktop is a script to link Coq, analogous to ocamlmktop.
    The command line contains options specific to coqmktop, options for the
@@ -19,49 +19,26 @@ open Unix
 (* 1. Core objects *)
 let ocamlobjs = ["unix.cma"]
 let dynobjs = ["dynlink.cma"]
-let camlp4objs = [(*"odyl.cma"; "camlp4.cma";*) "gramlib.cma"]
-let configobjs = ["coq_config.cmo"]
-let libobjs = ocamlobjs @ camlp4objs @ configobjs
+let camlp4objs = ["gramlib.cma"]
+let libobjs = ocamlobjs @ camlp4objs
 
 let spaces = Str.regexp "[ \t\n]+"
-let split_cmo l = Str.split spaces l
+let split_list l = Str.split spaces l
 
-let lib = split_cmo Tolink.lib 
-let kernel = split_cmo Tolink.kernel
-let library = split_cmo Tolink.library 
-let pretyping = split_cmo Tolink.pretyping 
-let interp = split_cmo Tolink.interp
-let parsing = split_cmo Tolink.parsing 
-let proofs = split_cmo Tolink.proofs 
-let tactics = split_cmo Tolink.tactics 
-let toplevel = split_cmo Tolink.toplevel 
-let highparsing = split_cmo Tolink.highparsing 
-let highparsingnew = split_cmo Tolink.highparsingnew
-let ide = split_cmo Tolink.ide 
+let copts     = split_list Tolink.copts
+let core_objs = split_list Tolink.core_objs
+let core_libs = split_list Tolink.core_libs
+let ide       = split_list Tolink.ide 
 
-let core_objs = 
-  libobjs @ lib @ kernel @ library @ pretyping @ interp @ parsing @ 
-  proofs @ tactics
-
-let core_libs = 
-  libobjs @ [ "lib/lib.cma" ; "kernel/kernel.cma" ; "library/library.cma" ;
-  "pretyping/pretyping.cma" ; "interp/interp.cma" ; "parsing/parsing.cma" ;
-  "proofs/proofs.cma" ; "tactics/tactics.cma" ]
-
-(* 3. Files only in coqsearchisos (if option -searchisos is used) *)
-let coqsearch = ["version_searchisos.cmo"; "cmd_searchisos_line.cmo"]
-
-(* 4. Toplevel objects *)
-let camlp4objs =
-  ["camlp4_top.cma"; "pa_o.cmo"; "pa_op.cmo"; "pa_extend.cmo"; "q_util.cmo"; "q_coqast.cmo" ]
-let topobjs = camlp4objs
+(* 3. Toplevel objects *)
+let camlp4topobjs =
+  ["camlp4_top.cma"; "pa_o.cmo"; "pa_op.cmo"; "pa_extend.cmo"]
+let topobjs = camlp4topobjs
 
 let gramobjs = []
 let notopobjs = gramobjs
 
-(* 5. High-level tactics objects *)
-let hightactics = 
- (split_cmo Tolink.hightactics) @ (split_cmo Tolink.contrib) 
+(* 4. High-level tactics objects *)
 
 (* environment *)
 let src_coqtop = ref Coq_config.coqtop
@@ -72,15 +49,18 @@ let searchisos = ref false
 let coqide     = ref false
 let echo       = ref false
 
+(* Caml inline flag *)
+let caml_inline_0 = ref false
+
 let src_dirs () = 
-  [ []; [ "config" ]; [ "toplevel" ] ] @
+  [ []; ["kernel";"byterun"]; [ "config" ]; [ "toplevel" ] ] @
   if !coqide then [[ "ide" ]] else []
 
 let includes () = 
   List.fold_right
     (fun d l -> "-I" :: List.fold_left Filename.concat !src_coqtop d :: l)
     (src_dirs ())
-    (["-I"; Coq_config.camlp4lib] @ 
+    (["-I"; "\"" ^ Coq_config.camlp4lib ^ "\""] @ 
      (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else []))
 
 (* Transform bytecode object file names in native object file names *)
@@ -89,8 +69,10 @@ let native_suffix f =
     (Filename.chop_suffix f ".cmo") ^ ".cmx"
   else if Filename.check_suffix f ".cma" then 
     (Filename.chop_suffix f ".cma") ^ ".cmxa"
-  else 
-    failwith ("File "^f^" has not extension .cmo or .cma")
+  else  
+    if Filename.check_suffix f ".a" then f 
+    else
+      failwith ("File "^f^" has not extension .cmo, .cma or .a")
 
 (* Transforms a file name in the corresponding Caml module name. *)
 let rem_ext_regexpr = Str.regexp "\\(.*\\)\\.\\(cm..?\\|ml\\)"
@@ -102,7 +84,6 @@ let module_of_file name =
 (* Build the list of files to link and the list of modules names *)
 let files_to_link userfiles =
   let dyn_objs = if not !opt then dynobjs else [] in
-  let command_objs = if !searchisos then coqsearch else [] in
   let toplevel_objs =
     if !top then topobjs else if !opt then notopobjs else [] in
   let ide_objs = if !coqide then 
@@ -114,17 +95,8 @@ let files_to_link userfiles =
      "ide/ide.cma" ]
   else [] 
   in
-  let objs = 
-    core_objs @ dyn_objs @ toplevel @ highparsing @ highparsingnew @ 
-    command_objs @ hightactics @ toplevel_objs @ ide_objs
-  and libs =
-    core_libs @ dyn_objs @ 
-    [ "toplevel/toplevel.cma" ; "parsing/highparsing.cma" ;
-      "parsing/highparsingnew.cma" ] @ 
-    command_objs @ [ "tactics/hightactics.cma" ; "contrib/contrib.cma" ] @
-    toplevel_objs @ 
-    ide_libs      
-  in
+  let objs = dyn_objs @ libobjs @ core_objs @ toplevel_objs @ ide_objs
+  and libs = dyn_objs @ libobjs @ core_libs @ toplevel_objs @ ide_libs in
   let objstolink,libstolink =
     if !opt then 
       ((List.map native_suffix objs) @ userfiles,
@@ -183,8 +155,6 @@ let parse_args () =
     | "-opt" :: rem -> opt := true ; parse (op,fl) rem
     | "-full" :: rem -> full := true ; parse (op,fl) rem
     | "-top" :: rem -> top := true ; parse (op,fl) rem
-    | "-searchisos" :: rem ->
-        searchisos := true; parse (op,fl) rem
     | "-ide" :: rem ->
         coqide := true; parse (op,fl) rem
     | "-v8" :: rem -> parse (op,fl) rem
@@ -199,7 +169,9 @@ let parse_args () =
         parse ((List.rev(List.flatten (List.map (fun d -> ["-I";d])
 					 (all_subdirs a))))@op,fl) rem
     | "-R" :: [] -> usage ()
-    | ("-compact"|"-g"|"-p"|"-thread" as o) :: rem -> parse (o::op,fl) rem
+    | ("-noassert"|"-compact"|"-g"|"-p"|"-thread"|"-dtypes" as o) :: rem ->
+        parse (o::op,fl) rem
+    | "-inline" :: p :: rem -> caml_inline_0 := true; parse (op,fl) rem
     | ("-h"|"--help") :: _ -> usage ()
     | f :: rem ->
 	if Filename.check_suffix f ".ml" 
@@ -230,7 +202,6 @@ let clean file =
 let all_modules_in_dir dir =
   try
     let lst = ref []
-    and stg = ref ""
     and dh = Unix.opendir dir in
     try
       while true do
@@ -309,19 +280,22 @@ let main () =
   let (options, userfiles) = parse_args () in
   (* which ocaml command to invoke *)
   let prog =
-    if !opt then begin
-      (* native code *)
-      if !top then failwith "no custom toplevel in native code !";
-      "ocamlopt -linkall"
-    end else
+    if !opt then
+      begin
+	(* native code *)
+	if !top then failwith "no custom toplevel in native code !";
+	let ocamloptexec = Filename.concat Coq_config.camldir "ocamlopt" in
+          (if !caml_inline_0 then ocamloptexec^" -linkall"^" -inline 0" else ocamloptexec^" -linkall")
+      end else
       (* bytecode (we shunt ocamlmktop script which fails on win32) *)
       let ocamlmktoplib = " toplevellib.cma" in
-      let ocamlccustom = "ocamlc -custom -linkall" in
-      (if !top then ocamlccustom^ocamlmktoplib else ocamlccustom)
+      let ocamlcexec = Filename.concat Coq_config.camldir "ocamlc" in
+      let ocamlccustom = ocamlcexec^" -custom -linkall" in
+	(if !top then ocamlccustom^ocamlmktoplib else ocamlccustom)
   in
-  (* files to link *)
+    (* files to link *)
   let (modules, tolink) = files_to_link userfiles in
-  (*file for dynlink *)
+    (*file for dynlink *)
   let dynlink=
     if not (!opt || !top) then
       [tmp_dynlink()]
@@ -331,11 +305,12 @@ let main () =
   (* the list of the loaded modules *)
   let main_file = create_tmp_main_file modules in
   try
-    let args = options @ (includes ()) @ tolink @ dynlink @ [ main_file ] in
+    let args =
+      options @ (includes ()) @ copts @ tolink @ dynlink @ [ main_file ] in
     (* add topstart.cmo explicitly because we shunted ocamlmktop wrapper *)
     let args = if !top then args @ [ "topstart.cmo" ] else args in
     (* Now, with the .cma, we MUST use the -linkall option *)
-    let command = String.concat " " ((prog^" -linkall")::args) in
+    let command = String.concat " " (prog::args) in
     if !echo then 
       begin 
 	print_endline command; 
diff --git a/syntax/MakeBare.v b/syntax/MakeBare.v
deleted file mode 100644
index 28d9b5ea..00000000
--- a/syntax/MakeBare.v
+++ /dev/null
@@ -1,9 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-Load PPConstr.
-Load PPCases.
diff --git a/syntax/PPCases.v b/syntax/PPCases.v
deleted file mode 100644
index d0f75dcf..00000000
--- a/syntax/PPCases.v
+++ /dev/null
@@ -1,96 +0,0 @@
-(************************************************************************)
-(*  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: PPCases.v,v 1.11.6.1 2004/07/16 19:30:51 herbelin Exp $ *)
-
-Syntax constr
-  level 8:
-    tomatch_cons [ << (TOMATCH $c1 ($LIST $cl)) >> ]
-      -> [ $c1:L [1 0] (TOMATCH ($LIST $cl)) ]
-  | tomatch_one [ << (TOMATCH $c1) >> ] -> [$c1:L]
-  ;
-
-  level 10:
-    as_patt [ << (PATTAS $var $patt) >> ] -> [$patt:L" as "$var]
-  ;
-
-  level 0:
-    ne_pattlist_nil  [ << (PATTLIST) >> ] -> [ ]
-  | ne_pattlist_cons [ << (PATTLIST $patt ($LIST $lpatt)) >> ]
-      -> [$patt:E " " (PATTLIST ($LIST $lpatt))]
-  ;
-
-  level 8:
-    equation [ << (EQN $rhs ($LIST $lhs)) >> ]
-      -> [ [<hov 0> (PATTLIST ($LIST $lhs)) "=> " [0 1] $rhs:E] ]
-  ;
- 
-  level 0:
-    bar_eqnlist_nil [ << (BAREQNLIST) >> ] -> [ ]
-  | bar_eqnlist_cons [ << (BAREQNLIST $eqn ($LIST $leqn)) >> ]
-      -> [ "| " $eqn [1 0] (BAREQNLIST ($LIST $leqn)) ]
-  | bar_eqnlist_one [ << (BAREQNLIST $eqn) >> ]
-      -> [ "| " $eqn ]
-  ;
-
-  level 10:
-    pattconstruct [ << (PATTCONSTRUCT $C $D ($LIST $T)) >> ] ->
-	 [(APPLIST $C $D ($LIST $T))]
-  ;
-
-  level 0:
-    pattconstructatomic [ << (PATTCONSTRUCT $C) >> ] -> [ $C:E ]
-  ;
-
-  level 8:
-
-    cases_exp_none [ << (CASES $pred $tomatch) >> ]
-      -> [ [<hov 0> (ELIMPRED $pred)
-              [<hv 0> "Cases"[1 2] $tomatch:E [1 0] "of"] [1 0] "end"] ]
-
-  | cases_exp_one [ << (CASES $pred $tomatch $eqn) >> ]
-      -> [ [<hov 0> (ELIMPRED $pred)
-              [<hv 0> [<hv 0> "Cases"[1 2] $tomatch:E [1 0] "of"] [1 2]
-                     $eqn [1 0]
-                     "end"] ] ]
-
-  | cases_exp_many [ << (CASES $pred $tomatch $eqn1 $eqn2 ($LIST $eqns)) >> ]
-      -> [ [<hov 0> (ELIMPRED $pred)
-              [<v 0> [<hv 0> "Cases"[1 2] $tomatch:E [1 0] "of"] [1 2]
-                     $eqn1 [1 0]
-                     (BAREQNLIST $eqn2 ($LIST $eqns)) [1 0]
-                     "end"] ] ]
-
-  (* "level" indifférent pour ce qui suit *)
-  | let_binder_var [ << (LETBINDER ($VAR $id)) >> ] -> [ $id ]
-  | let_binder_app 
-	[<<(LETBINDER (PATTCONSTRUCT $toforget ($VAR $id) ($LIST $vars)))>>]
-      -> [ "(" $id (LETBINDERTAIL ($LIST $vars)) ")" ]
- 
-  | let_binder_tail_nil  [ << (LETBINDERTAIL) >> ] -> [ ]
-  | let_binder_tail_cons [ << (LETBINDERTAIL $var ($LIST $vars)) >> ]
-      -> [ "," [1 0] $var (LETBINDERTAIL ($LIST $vars)) ]
-
-  ;
-
-  (* On force les parenthèses autour d'un "if" sous-terme (même si le
-     parsing est lui plus tolérant) *)
-  level 10:
-    boolean_cases [ << (FORCEIF $pred $tomatch $c1 $c2) >> ]
-      -> [ [<hov 0> (ELIMPRED $pred)
-              [<hv 0> "if " [<hov 0> $tomatch:L ]
-                      [1 0] [<hov 0> "then" [1 1] $c1:L ]
-                      [1 0] [<hov 0> "else" [1 1] $c2:L ] ] ] ]
-
-  | let_cases [ << (FORCELET $pred $tomatch (EQN $c $pat)) >> ]
-      -> [ [<hov 0> (ELIMPRED $pred)
-              [<hv 0> "let " [<hov 0> (LETBINDER $pat) ] " ="
-                      [1 1] [<hov 0> $tomatch:L ] ]
-              [1 0] "in " [<hov 0> $c:L ] ] ]
-.
-
diff --git a/syntax/PPConstr.v b/syntax/PPConstr.v
deleted file mode 100755
index a4374c86..00000000
--- a/syntax/PPConstr.v
+++ /dev/null
@@ -1,264 +0,0 @@
-(************************************************************************)
-(*  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: PPConstr.v,v 1.25.2.1 2004/07/16 19:30:51 herbelin Exp $ *)
-
-(* Syntax for the Calculus of Constructions. *)
-
-Syntax constr
-  level 0:
-    ne_command_listcons [ << (NECOMMANDLIST $c1 ($LIST $cl)) >> ]
-       -> [ $c1 [1 0] (NECOMMANDLIST ($LIST $cl)) ]
-  | ne_command_listone [ << (NECOMMANDLIST $c1) >> ] -> [ $c1 ]
-  ;
-
-(* Things parsed in binder *)
-(* ======================= *)
-
-  level 0:
-    idbindercons [ << (IDBINDER ($VAR $id) ($LIST $L)) >> ] ->
-       [ $id ","[0 0] (IDBINDER ($LIST $L))]
-  | idbinderone  [ << (IDBINDER ($VAR $id)) >> ] -> [$id]
-  | idbindernil  [ << (IDBINDER) >> ] -> [ ]
-
-  | binderscons [ << (BINDERS (BINDER $c ($LIST $id)) ($LIST $b)) >> ] ->
-       [ [<hv 0> [<hov 0> (IDBINDER ($LIST $id))] ":"
-                 [0 1] $c:E] ";"[1 0]
-         (BINDERS ($LIST $b))  ]
-  | bindersone  [ << (BINDERS (BINDER $c ($LIST $id))) >> ] -> 
-       [ [<hov 0> (IDBINDER ($LIST $id))] ":" $c:E ]
-
-  | letbindercons [ << (BINDERS (LETBINDER $c $id) ($LIST $b)) >> ] ->
-       [ [<hov 0> id ":=" [0 1] $c:E ";" [1 0] (BINDERS ($LIST $b)) ] ]
-  | letbinderone  [ << (BINDERS (LETBINDER $c $id)) >> ] -> 
-       [ [<hov 0> id ":=" [0 1] $c:E ] ]
-  ;
-
-
-(* Things parsed in command0 *)
-  level 0:
-    prop [ Prop ] -> ["Prop"]
-  | set  [ Set ]  -> ["Set"]
-  | type [ Type ] -> ["Type"]
-  | type_sp [ << (TYPE $id) >> ] -> ["Type" $id]
-(* Note: Atomic constants (Nvar, CONST, MUTIND, MUTCONSTRUCT) are printed in
-   Printer to know if they must be qualified or not (and previously to
-   deal with the duality CCI/FW) *)
-
-  | evar [ ? ] -> ["?"]
-  | meta [ << (META $n) >> ] -> [ $n ]
-  | implicit [ << (IMPLICIT) >> ] -> ["<Implicit>"]
-  | indice [ << (REL ($NUM $n)) >> ] -> ["<Unbound ref: " $n ">"]
-  | instantiation [ << (INSTANCE $a ($LIST $l)) >> ] ->
-	 [ $a "{" (CONTEXT ($LIST $l)) "}"]
-  | instantiation_nil [ << (CONTEXT) >> ] -> [ ]
-  | instantiation_one [ << (CONTEXT $a) >> ] -> [ $a ]
-  | instantiation_many [ << (CONTEXT $a $b ($LIST $l)) >> ] ->
-	 [ (CONTEXT $b ($LIST $l)) ";" $a ]
-  | qualid [ << (QUALID $id ($LIST $l)) >> ] -> [ $id (FIELDS ($LIST $l)) ]
-  | fieldsnil [ << (FIELDS) >> ] -> [ ]
-  | fieldscons [ << (FIELDS $id ($LIST $l)) >> ] ->
-	 [ "." $id (FIELDS ($LIST $l)) ]
-  ;
-
-(* Things parsed in command1 *)
-  level 1:
-    soap [ << (SOAPP $lc1 ($LIST $cl)) >> ]
-      -> [ [<hov 0> "(" $lc1 ")@[" (NECOMMANDLIST ($LIST $cl)) "]"] ]
-
-  (* For debug *)
-  | abstpatnamed [ << [$id1]$c >> ] -> [ [<hov 0> "<<" $id1 ">>" [0 1] $c:E ] ]
-  | abstpatanon  [ << [ <> ]$c >> ] -> [ [<hov 0> "<<_>>" [0 1] $c:E ] ]
-  ;
-
-(* Things parsed in command2 *)
-
-(* Things parsed in command3 *)
-
-(* Things parsed in command4 *)
-
-(* Things parsed in command5 *)
-
-(* Things parsed in command6 *)
-
-(* Things parsed in command7 *)
-
-(* Things parsed in command8 *)
-  level 8:
-    lambda [ << (LAMBDA $Dom [$x]$Body) >> ]
-     -> [(LAMBOX (BINDERS (BINDER $Dom $x)) $Body)]
-  | lambda_anon [ << (LAMBDA $Dom [<>]$Body) >> ]
-     -> [(LAMBOX (BINDERS (BINDER $Dom _)) $Body)]
-  | lambdalist  [ << (LAMBDALIST $c [$x]$body) >> ]
-     -> [(LAMLBOX (BINDERS) $c (IDS $x) $body)]
-  | lambdalist_anon  [ << (LAMBDALIST $c [<>]$body) >> ]
-     -> [(LAMLBOX (BINDERS) $c (IDS _) $body)]
-
-  | formated_lambda [ << (LAMBOX $pbi $t) >> ]
-     -> [ [<hov 0> "[" [<hv 0> $pbi] "]" [0 1] $t:E ] ]
-
-  | lambda_cons [<<(LAMBOX (BINDERS ($LIST $acc)) (LAMBDA $Dom [$x]$body))>>]
-      -> [(LAMBOX (BINDERS ($LIST $acc) (BINDER $Dom $x)) $body) ]
-  | lambda_cons_anon
-      [ << (LAMBOX (BINDERS ($LIST $acc)) (LAMBDA $Dom [<>]$body)) >> ]
-      -> [(LAMBOX (BINDERS ($LIST $acc) (BINDER $Dom _)) $body)]
-  | lambdal_start [ << (LAMBOX $pbi (LAMBDALIST $Dom $Body)) >> ]
-      -> [(LAMLBOX $pbi $Dom (IDS) $Body)]
-
-  | lambdal_end [<<(LAMLBOX (BINDERS ($LIST $acc)) $c (IDS ($LIST $ids)) $t)>>]
-      -> [(LAMBOX (BINDERS ($LIST $acc) (BINDER $c ($LIST $ids))) $t)]
-  | lambdal_cons_anon [ << (LAMLBOX $pbi $c (IDS ($LIST $ids)) [<>]$body) >> ]
-      -> [(LAMLBOX $pbi $c (IDS ($LIST $ids) _) $body)]
-  | lambdal_cons [ << (LAMLBOX $pbi $c (IDS ($LIST $ids)) [$id]$body) >> ]
-      -> [(LAMLBOX $pbi $c (IDS ($LIST $ids) $id) $body)]
-
-  | pi [ << (PROD $A [$x]$B) >> ] -> [ (PRODBOX (BINDERS) (PROD $A [$x]$B)) ]
-  | prodlist  [ << (PRODLIST $c $b) >> ]
-       -> [(PRODBOX (BINDERS) (PRODLIST $c $b))]
-
-  | formated_prod [ << (PRODBOX $pbi $t) >> ]
-     -> [ [<hov 0> "(" [<hov 0> $pbi] ")" [0 1] $t:E ] ]
-
-  | prod_cons
-      [ << (PRODBOX (BINDERS ($LIST $acc)) (PROD $Dom [$x]$body)) >> ]
-      -> [(PRODBOX (BINDERS ($LIST $acc) (BINDER $Dom $x)) $body)]
-  | prodl_start_cons [ << (PRODBOX $pbi (PRODLIST $Dom $Body)) >> ]
-      -> [(PRODLBOX $pbi $Dom (IDS) $Body)]
-
-  | prodl_end [<<(PRODLBOX (BINDERS ($LIST $acc)) $c (IDS ($LIST $ids)) $t)>>]
-      -> [(PRODBOX (BINDERS ($LIST $acc) (BINDER $c ($LIST $ids))) $t)]
-  | prodl_cons_anon [ << (PRODLBOX $pbi $c (IDS ($LIST $ids)) [<>]$body) >> ]
-      -> [(PRODLBOX $pbi $c (IDS ($LIST $ids) _) $body)]
-  | prodl_cons [ << (PRODLBOX $pbi $c (IDS ($LIST $ids)) [$id]$body) >> ]
-      -> [(PRODLBOX $pbi $c (IDS ($LIST $ids) $id) $body)]
-
-
-  | arrow [ << (ARROW $A [<>]$B) >> ] ->
-       [ [<hv 0> $A:L " ->" [0 0] (ARROWBOX $B) ] ]
-  | arrow_stop [ << (ARROWBOX $c) >> ] -> [ $c:E ]
-  | arrow_again [ << (ARROWBOX (PROD $A [<>]$B)) >> ] ->
-	 [ $A:L " ->" [0 0] (ARROWBOX $B) ]
-
-(* These are synonymous *)
-(* redundant
-  | let [ [$x = $M]$N ] -> [ [<hov 0> "[" $x "=" $M:E "]" [0 1] $N:E ] ]
-*)
-  | letin [ << (LETIN $A [$x]$B) >> ] -> [ [ <hov 0> "[" $x ":=" [0 1] $A:E "]" [0 1] $B:E ] ]
-  | letincast [ << (LETIN (CAST $A $C) [$x]$B) >> ] -> [ [ <hov 0> "[" $x ":=" [0 1] $A:E ":" $C:E "]" [0 1] $B:E ] ]
-  ;
-
-(* Things parsed in command9 *)
-  level 9:
-    cast [ << (CAST $C $T) >> ] -> [ [<hv 0> $C:L [0 0] "::" $T:E] ]
-  ;
-
-(* Things parsed in command10 *)
-  level 10:
-    app_cons [ << (APPLIST $H ($LIST $T)) >> ]
-                 -> [ [<hov 0>  $H:E  (APPTAIL ($LIST $T)):E ] ]
-
-  | app_imp  [ << (APPLISTEXPL $H ($LIST $T)) >> ]
-                 -> [ [<hov 0>  "!" $H:E (APPTAIL ($LIST $T)):E ] ]
-
-(*
-  | app_imp  [ << (APPLISTEXPL $H ($LIST $T)) >> ]
-                 -> [ (APPLISTIMPL (ACC $H) ($LIST $T)):E ]
-
-  | app_imp_arg  [ << (APPLISTIMPL (ACC ($LIST $AC)) $a ($LIST $T)) >> ]
-        -> [ (APPLISTIMPL (ACC ($LIST $AC) $a) ($LIST $T)):E ]
-
-  | app_imp_imp_arg  [ << (APPLISTIMPL $AC (EXPL $_ $_) ($LIST $T)) >> ]
-       -> [ (APPLISTIMPL $AC ($LIST $T)):E ]
-
-  | app_imp_last [ << (APPLISTIMPL (ACC ($LIST $A)) $T) >> ]
-         -> [ (APPLIST ($LIST $A) $T):E ]
-*)
-
-  | apptailcons [ << (APPTAIL $H ($LIST $T)) >> ]
-	 -> [ [1 1] $H:L  (APPTAIL ($LIST $T)):E ]
-  | apptailnil [ << (APPTAIL) >> ] -> [ ]
-
-(* Implicits *)
-  | apptailcons1  [ << (APPTAIL (EXPL $n $c1) ($LIST $T)) >> ]
-         -> [ [1 1] $n "!" $c1:E  (APPTAIL ($LIST $T)):E ]
-  ;
-(*
-  level 8:
-    arg_implicit [ << (EXPL ($NUM $n) $c1) >> ] -> [ $n "!" $c1:L ]
-(*  | arg_implicit1 [(EXPL "EX" ($NUM $n) $c1)] -> [ $n "!" $c1:L ]
-  | fun_explicit [ << (EXPL $f) >> ] -> [ $f ]*)
-  ;
-*)
-
-  level 8:
-  recterm [ << (MATCH $P $c ($LIST $BL)) >> ] ->
-     [ [<hov 0> [<hov 0> (ELIMPRED $P)
-    		 [0 2] [<hov 0> "Match" [1 1] $c:E  [1 0] "with" ]]
-	         [1 3] [<hov 0> (MATCHBRANCHES ($LIST $BL)):E ] "end"] ]
-
-  | matchbranchescons [ << (MATCHBRANCHES $B ($LIST $T)) >> ]
-       -> [ [<hov 0> [<hov 0> $B:E ] FNL] (MATCHBRANCHES ($LIST $T)):E ]
-  | matchbranchesnil [ << (MATCHBRANCHES) >> ] -> [ ]
-
-  | caseterm [ << (CASE $P $c ($LIST $BL)) >> ] ->
-     [ [<hov 0> [<hov 0> (ELIMPRED $P)
-                  [0 2][<hov 0> "Case" [1 1] $c:E  [1 0] "of" ]]
-                  [1 3][<hov 0> (MATCHBRANCHES ($LIST $BL)):E ] "end"] ]
-
-  | ifterm [ << (IF $P $c $b1 $b2) >> ] ->
-     [ (FORCEIF $P $c (EQN $b1 JUNK) (EQN $b2 JUNK)):E ]
-
-  | letterm [ << (LET $P $c (LAMBDALIST $_ $b)) >> ] ->
-     [ (LETSLAM $P $c $b) ]
-  | letslamend [ << (LETSLAM $P $c $b ($LIST $IDL))>> ] ->
-     [ (FORCELET $P $c (EQN $b (PATTCONSTRUCT JUNK ($LIST $IDL)))):E ]
-  | letslam [ << (LETSLAM $P $c [$ID]$b ($LIST $IDL))>> ] ->
-     [ (LETSLAM $P $c $b ($LIST $IDL) $ID) ]
-  | letslamanon [ << (LETSLAM $P $c [<>]$b ($LIST $IDL))>> ] ->
-     [ (LETSLAM $P $c $b ($LIST $IDL) _) ]
-
-  | elim_pred      [ << (ELIMPRED $pred) >> ]          -> [ "<" $pred:E ">" [0 2] ]
-  | elim_pred_xtra [ << (ELIMPRED "SYNTH") >> ] -> [ ]
-  ;
-
-  level 0:
-    fix [ << (FIX $f $def ($LIST $lfs)) >> ] ->
-      [ [<hov 0> "Fix " $f
-           [0 2] "{" [<v 0> [<hov 0> $def]
-                            (FIXDECLS ($LIST $lfs)) ] "}"] ]
-
-  | cofix [ << (COFIX $f $def ($LIST $lfs)) >> ] ->
-      [ [<hov 0> "CoFix " $f
-           [0 2] "{" [<v 0> [<hov 0> $def]
-                            (FIXDECLS ($LIST $lfs)) ] "}"] ]
-
-  | nofixdefs [ << (FIXDECLS) >> ] -> [ ]
-  | fixdefs [ << (FIXDECLS $def1 ($LIST $defs)) >> ] ->
-      [ FNL [<hov 0> "with " $def1] (FIXDECLS ($LIST $defs)) ]
-  ;
-
-  level 8:
-    onefixnumdecl [ << (NUMFDECL $f ($NUM $x) $A $t) >> ] ->
-      [ $f "/" $x " :"
-        [1 2] $A:E " :="
-        [1 2] $t:E ]
-  | onefixdecl [ << (FDECL $f (BINDERS ($LIST $l)) $A $t) >> ] ->
-      [ $f
-        [1 2] "[" [<hv 0> (BINDERS ($LIST $l))] "]"
-        [1 2] ": " $A:E " :="
-        [1 2] $t:E ]
-  | onecofixdecl [ << (CFDECL $f $A $t) >> ] ->
-      [ $f " : "
-        [1 2] $A:E " :="
-        [1 2] $t:E ]
-  ;
-
-  level 8:
-    evalconstr [ << (EVAL $c $r) >> ] ->
-	 [ [<hv 0> "Eval" [1 1] $r [1 0] "in" [1 1] $c:E ] ].
-
diff --git a/tactics/auto.ml b/tactics/auto.ml
index d7130f35..3cd1591d 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: auto.ml,v 1.63.2.3 2005/05/15 12:47:04 herbelin Exp $ *)
+(* $Id: auto.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Pp
 open Util
@@ -15,6 +15,7 @@ open Nameops
 open Term
 open Termops
 open Sign
+open Environ
 open Inductive
 open Evd
 open Reduction
@@ -38,21 +39,21 @@ open Library
 open Printer
 open Declarations
 open Tacexpr
+open Mod_subst
 
 (****************************************************************************)
 (*            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 *)
+  | Res_pf     of constr * clausenv (* Hint Apply *)
+  | ERes_pf    of constr * 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 *)
+  | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *)
+  | Unfold_nth of evaluable_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 *)
@@ -103,7 +104,7 @@ let lookup_tacs (hdc,c) (l,l',dn) =
 
 
 module Constr_map = Map.Make(struct 
-			       type t = constr_label
+			       type t = global_reference
 			       let compare = Pervasives.compare 
 			     end)
 
@@ -134,24 +135,28 @@ module Hint_db = struct
 
 end
 
-type frozen_hint_db_table = Hint_db.t Stringmap.t 
+module Hintdbmap = Gmap
 
-type hint_db_table = Hint_db.t Stringmap.t ref
+type frozen_hint_db_table = (string,Hint_db.t) Hintdbmap.t 
+
+type hint_db_table = (string,Hint_db.t) Hintdbmap.t ref
 
 type hint_db_name = string
 
-let searchtable = (ref Stringmap.empty : hint_db_table)
+let searchtable = (ref Hintdbmap.empty : hint_db_table)
 
 let searchtable_map name = 
-  Stringmap.find name !searchtable
+  Hintdbmap.find name !searchtable
 let searchtable_add (name,db) = 
-  searchtable := Stringmap.add name db !searchtable
+  searchtable := Hintdbmap.add name db !searchtable
+let current_db_names () =
+  Hintdbmap.dom !searchtable
 
 (**************************************************************************)
 (*                       Definition of the summary                        *)
 (**************************************************************************)
 
-let init     () = searchtable := Stringmap.empty
+let init     () = searchtable := Hintdbmap.empty
 let freeze   () = !searchtable
 let unfreeze fs = searchtable := fs
 
@@ -177,21 +182,28 @@ let try_head_pattern c =
   try head_pattern_bound c
   with BoundPattern -> error "Bound head variable"
 
-let make_exact_entry name (c,cty) =
+let make_exact_entry (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 })
+	   { pri=0; pat=None; code=Give_exact c })
+
+let dummy_goal =
+  {it={evar_hyps=empty_named_context_val;
+       evar_concl=mkProp;
+       evar_body=Evar_empty;
+       evar_extra=None};
+   sigma=Evd.empty}
 
-let make_apply_entry env sigma (eapply,verbose) name (c,cty) =
+let make_apply_entry env sigma (eapply,verbose) (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 ce = mk_clenv_from dummy_goal (c,cty) in
+	let c' = clenv_type ce in
 	let pat = Pattern.pattern_of_constr c' in
         let hd = (try head_pattern_bound pat
                   with BoundPattern -> failwith "make_apply_entry") in
@@ -199,72 +211,66 @@ let make_apply_entry env sigma (eapply,verbose) name (c,cty) =
         in 
 	if eapply & (nmiss <> 0) then begin
           if verbose then 
-	    if !Options.v7 then
-	    warn (str "the hint: EApply " ++ prterm c ++
-		    str " will only be used by EAuto")
-	    else
-	    warn (str "the hint: eapply " ++ prterm c ++
-		    str " will only be used by eauto"); 
+	    warn (str "the hint: eapply " ++ pr_lconstr c ++
+		  str " will only be used by eauto"); 
           (hd,
-           { hname = name;
-	     pri = nb_hyp cty + nmiss;
+           { pri = nb_hyp cty + nmiss;
              pat = Some pat;
-             code = ERes_pf(c,ce) })
+             code = ERes_pf(c,{ce with templenv=empty_env}) })
         end else 
 	  (hd,
-           { hname = name;
-	     pri = nb_hyp cty;
+           { pri = nb_hyp cty;
              pat = Some pat;
-             code = Res_pf(c,ce) })
+             code = Res_pf(c,{ce with templenv=empty_env}) })
     | _ -> 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 make_resolves env sigma eap c =
+  let cty = type_of env sigma c in
   let ents = 
     map_succeed 
-      (fun f -> f name (c,cty)) 
-      [make_exact_entry; make_apply_entry env sigma eap]
+      (fun f -> f (c,cty)) 
+      [make_exact_entry; make_apply_entry env sigma (eap,Options.is_verbose())]
   in 
-  if ents = [] then 
-    errorlabstrm "Hint" (prterm c ++ spc () ++ str "cannot be used as a hint");
+  if ents = [] then
+    errorlabstrm "Hint" 
+      (pr_lconstr 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
+    [make_apply_entry env sigma (true, false)
        (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;
+let make_unfold (ref, eref) =
+  (ref,
+   { pri = 4;
      pat = None;
-     code = Unfold_nth ref })
+     code = Unfold_nth eref })
 
-let make_extern name pri pat tacast = 
+let make_extern pri pat tacast = 
   let hdconstr = try_head_pattern pat in 
   (hdconstr,
-   { hname = name;
-     pri=pri;
+   { pri=pri;
      pat = Some pat;
      code= Extern tacast })
 
-let make_trivial env sigma (name,c) =
+let make_trivial env sigma 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) })
+  let ce = mk_clenv_from dummy_goal (c,t) in
+  (hd, { pri=1;
+         pat = Some (Pattern.pattern_of_constr (clenv_type ce));
+         code=Res_pf_THEN_trivial_fail(c,{ce with templenv=empty_env}) })
 
 open Vernacexpr
 
@@ -291,7 +297,7 @@ let forward_subst_tactic =
 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_clenv clenv = Clenv.subst_clenv subst clenv in
   let trans_data data code = 	      
     { data with
 	pat = option_smartmap (subst_pattern subst) data.pat ;
@@ -299,29 +305,32 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) =
     }
   in
   let subst_hint (lab,data as hint) =
-    let lab' = subst_label subst lab in
+    let lab',elab' = subst_global subst lab in
+    let lab' =
+     try head_of_constr_reference (List.hd (head_constr_bound elab' []))
+     with Tactics.Bound -> lab' in
     let data' = match data.code with
       | Res_pf (c, clenv) ->
-	  let c' = Term.subst_mps subst c in
+	  let c' = 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
+	  let c' = 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
+	  let c' = 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
+	  let c' = 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')
+          let ref' = subst_evaluable_reference 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
@@ -353,19 +362,12 @@ let (inAutoHint,outAutoHint) =
 (*                     The "Hint" vernacular command                      *)
 (**************************************************************************)
 let add_resolves env sigma clist local dbnames =
-  List.iter 
+  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
-	       )
-	    )))
+     	     List.flatten (List.map (make_resolves env sigma true) clist))))
     dbnames
 
 
@@ -376,12 +378,9 @@ let add_unfolds l local dbnames =
     dbnames
 
 
-let add_extern name pri (patmetas,pat) tacast local dbname =
+let add_extern 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::_ ->
@@ -389,10 +388,10 @@ let add_extern name pri (patmetas,pat) tacast local dbname =
 	  (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound")
     | []  ->
 	Lib.add_anonymous_leaf
-	  (inAutoHint(local,dbname, [make_extern name pri pat tacast]))
+	  (inAutoHint(local,dbname, [make_extern pri pat tacast]))
 
-let add_externs name pri pat tacast local dbnames = 
-  List.iter (add_extern name pri pat tacast local) dbnames
+let add_externs pri pat tacast local dbnames = 
+  List.iter (add_extern pri pat tacast local) dbnames
 
 let add_trivials env sigma l local dbnames =
   List.iter
@@ -408,53 +407,39 @@ 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
+  let env = Global.env() and sigma = Evd.empty in
+  let f = Constrintern.interp_constr sigma env 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
+      let f qid =
+	let r = Nametab.global qid in
+        let r' = match r with
+         | ConstRef c -> EvalConstRef c
+         | VarRef c -> EvalVarRef c
+         | _ -> 
+           errorlabstrm "evalref_of_ref"
+            (str "Cannot coerce" ++ spc () ++ pr_global r ++ spc () ++
+             str "to an evaluable reference")
+        in
+	 (r,r') in
       add_unfolds (List.map f lhints) local dbnames
-  | HintsConstructors (hintname, lqid) ->
+  | HintsConstructors 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
+  | HintsExtern (pri, patcom, tacexp) ->
       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
+      add_externs pri pat tacexp local dbnames
   | HintsDestruct(na,pri,loc,pat,code) ->
       if dbnames0<>[] then
         warn (str"Database selection not implemented for destruct hints");
@@ -465,25 +450,15 @@ let add_hints local dbnames0 h =
 (**************************************************************************)
 
 let fmt_autotactic =
-  if !Options.v7 then
-  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)
-  else
   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 (c,clenv) -> (str"apply " ++ pr_lconstr c)
+  | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c)
+  | Give_exact c -> (str"exact " ++ pr_lconstr c)
   | Res_pf_THEN_trivial_fail (c,clenv) -> 
-      (str"apply " ++ prterm c ++ str" ; trivial")
-  | Unfold_nth c -> (str"unfold " ++  pr_global c)
+      (str"apply " ++ pr_lconstr c ++ str" ; trivial")
+  | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
   | Extern tac -> 
-      (str "(external) " ++ Pptacticnew.pr_glob_tactic (Global.env()) tac)
+      (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac)
 
 let fmt_hint v =
   (fmt_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ())
@@ -498,20 +473,20 @@ let fmt_hints_db (name,db,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 dbs = Hintdbmap.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)
+    (str "No hint declared for :" ++ pr_global c)
   else 
     hov 0 
-      (str"For " ++ pr_ref_label c ++ str" -> " ++ fnl () ++
+      (str"For " ++ pr_global 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)
+let fmt_hint_ref ref = fmt_hint_list_for_head ref
 
 (* Print all hints associated to head id in any database *)
 let print_hint_ref ref =  ppnl(fmt_hint_ref ref)
@@ -523,7 +498,7 @@ let fmt_hint_term cl =
       | [] -> assert false 
     in
     let hd = head_of_constr_reference hdc in
-    let dbs = stringmap_to_list !searchtable in
+    let dbs = Hintdbmap.to_list !searchtable in
     let valid_dbs = 
       if occur_existential cl then 
 	map_succeed 
@@ -556,7 +531,7 @@ let print_hint_db db =
   Hint_db.iter 
     (fun head hintlist ->
        msg (hov 0 
-	      (str "For " ++ pr_ref_label head ++ str " -> " ++
+	      (str "For " ++ pr_global head ++ str " -> " ++
 		 fmt_hint_list hintlist)))
     db
 
@@ -568,7 +543,7 @@ let print_hint_db_by_name dbname =
   
 (* displays all the hints of all databases *)
 let print_searchtable () =
-  Stringmap.iter
+  Hintdbmap.iter
     (fun name db ->
        msg (str "In the database " ++ str name ++ fnl ());
        print_hint_db db)
@@ -588,19 +563,18 @@ 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' = connect_clenv gls 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 make_local_hint_db lems 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
-
+  let hintlist = list_map_append (pf_apply make_resolve_hyp g) sign in
+  let hintlist' = list_map_append (pf_apply make_resolves g true) lems in
+  Hint_db.add_list hintlist' (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
@@ -654,7 +628,7 @@ and my_find_search db_list local_db hdc concl =
       	(local_db::db_list)
   in
   List.map 
-    (fun ({pri=b; pat=p; code=t} as patac) -> 
+    (fun {pri=b; pat=p; code=t} -> 
        (b,
 	match t with
 	  | Res_pf (term,cl)  -> unify_resolve (term,cl)
@@ -664,7 +638,7 @@ and my_find_search db_list local_db hdc concl =
 	      tclTHEN 
 		(unify_resolve (term,cl)) 
 		(trivial_fail_db db_list local_db)
-	  | Unfold_nth c -> unfold_constr c
+	  | Unfold_nth c -> unfold_in_concl [[],c]
 	  | Extern tacast -> 
 	      conclPattern concl (out_some p) tacast))
     tacl
@@ -677,32 +651,30 @@ and trivial_resolve db_list local_db cl =
   with Bound | Not_found -> 
     []
 
-let trivial dbnames gl =
+let trivial lems dbnames gl =
   let db_list = 
     List.map
       (fun x -> 
 	 try 
 	   searchtable_map x
 	 with Not_found -> 
-	   if !Options.v7 then
-	     error ("Trivial: "^x^": No such Hint database")
-	   else
-	     error ("trivial: "^x^": No such Hint database"))
+	   error ("trivial: "^x^": No such Hint database"))
       ("core"::dbnames) 
   in
-  tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl 
+  tclTRY (trivial_fail_db db_list (make_local_hint_db lems gl)) gl 
     
-let full_trivial gl =
-  let dbnames = stringmap_dom !searchtable in
+let full_trivial lems gl =
+  let dbnames = Hintdbmap.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
+  tclTRY (trivial_fail_db db_list (make_local_hint_db lems gl)) gl
 
-let gen_trivial = function
-  | None -> full_trivial
-  | Some l -> trivial l
+let gen_trivial lems = function
+  | None -> full_trivial lems
+  | Some l -> trivial lems l
 
-let h_trivial l = Refiner.abstract_tactic (TacTrivial l) (gen_trivial l)
+let h_trivial lems l =
+  Refiner.abstract_tactic (TacTrivial (lems,l)) (gen_trivial lems l)
 
 (**************************************************************************)
 (*                       The classical Auto tactic                        *)
@@ -760,7 +732,7 @@ let rec search_gen decomp n db_list local_db extra_sign goal =
 	   try 
 	     [make_apply_entry (pf_env g') (project g')
 		(true,false) 
-		hid (mkVar hid, htyp)]
+		(mkVar hid, htyp)]
 	   with Failure _ -> [] 
 	 in
          search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d] g') 
@@ -778,44 +750,41 @@ let rec search_gen decomp n db_list local_db extra_sign goal =
 let search = search_gen 0
 
 let default_search_depth = ref 5
-			     
-let auto n dbnames gl = 
+
+let auto n lems dbnames gl =
   let db_list = 
     List.map
       (fun x -> 
 	 try 
 	   searchtable_map x
 	 with Not_found -> 
-	   if !Options.v7 then
-	     error ("Auto: "^x^": No such Hint database")
-	   else
-	     error ("auto: "^x^": No such Hint database"))
+	   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
+  tclTRY (search n db_list (make_local_hint_db lems gl) hyps) gl
 
-let default_auto = auto !default_search_depth []
+let default_auto = auto !default_search_depth [] []
 
-let full_auto n gl = 
-  let dbnames = stringmap_dom !searchtable in
+let full_auto n lems gl = 
+  let dbnames = Hintdbmap.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
+  tclTRY (search n db_list (make_local_hint_db lems gl) hyps) gl
   
-let default_full_auto gl = full_auto !default_search_depth gl
+let default_full_auto gl = full_auto !default_search_depth [] gl
 
-let gen_auto n dbnames =
+let gen_auto n lems 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
+  | None -> full_auto n lems
+  | Some l -> auto n lems l
 
-let inj_or_var = option_app (fun n -> Genarg.ArgArg n)
+let inj_or_var = option_map (fun n -> ArgArg n)
 
-let h_auto n l =
-  Refiner.abstract_tactic (TacAuto (inj_or_var n,l)) (gen_auto n l)
+let h_auto n lems l =
+  Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l)) (gen_auto n lems l)
 
 (**************************************************************************)
 (*                  The "destructing Auto" from Eduardo                   *)
@@ -830,7 +799,7 @@ 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
+    (make_local_hint_db [] gl) hyps gl
     
 let dautomatic des_opt n = tclTRY (destruct_auto des_opt n)
 
@@ -842,13 +811,21 @@ let dauto = function
   | Some n, Some p -> dautomatic p n
   | None, Some p   -> dautomatic p !default_search_depth
 
-let h_dauto (n,p) = 
+let h_dauto (n,p) =
   Refiner.abstract_tactic (TacDAuto (inj_or_var n,p)) (dauto (n,p))
 
 (***************************************)
 (*** A new formulation of Auto *********)
 (***************************************)
 
+let make_resolve_any_hyp env sigma (id,_,ty) =
+  let ents = 
+    map_succeed
+      (fun f -> f (mkVar id,ty)) 
+      [make_exact_entry; make_apply_entry env sigma (true,false)]
+  in 
+  ents
+
 type autoArguments =
   | UsingTDB       
   | Destructing   
@@ -869,13 +846,13 @@ let compileAutoArg contac = function
 		 then 
 		   tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] 
                  else 
-		   tclFAIL 0 ((string_of_id id)^"is not a conjunction"))
+		   tclFAIL 0 (pr_id id ++ str" is not a conjunction"))
 	     ctx) g)
   | UsingTDB ->  
       (tclTHEN  
          (Tacticals.tryAllClauses 
             (function 
-               | Some (id,_,_) -> Dhyp.h_destructHyp false id
+               | Some ((_,id),_) -> Dhyp.h_destructHyp false id
                | None          -> Dhyp.h_destructConcl))
          contac)
 
@@ -888,10 +865,7 @@ let rec super_search n db_list local_db argl goal =
      ::
      (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
+	   let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in
 	   super_search n db_list (Hint_db.add_list hintl local_db)
 	     argl g))
      ::
@@ -910,8 +884,8 @@ let search_superauto n to_add argl g =
       (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 db = Hint_db.add_list db0 (make_local_hint_db [] g) in
+  super_search n [Hintdbmap.find "core" !searchtable] db argl g
 
 let superauto n to_add argl  = 
   tclTRY (tclCOMPLETE (search_superauto n to_add argl))
@@ -921,7 +895,7 @@ 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)
+  (next_ident_away id (pf_ids_of_hyps gl), constr_of_global r)
 
 let gen_superauto nopt l a b gl =
   let n = match nopt with Some n -> n | None -> !default_search_depth in
diff --git a/tactics/auto.mli b/tactics/auto.mli
index ec8c0d71..ecd20f0d 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auto.mli,v 1.22.2.2 2005/01/21 16:41:52 herbelin Exp $ i*)
+(*i $Id: auto.mli 7937 2006-01-28 19:58:11Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -21,20 +21,20 @@ open Environ
 open Evd
 open Libnames
 open Vernacexpr
+open Mod_subst
 (*i*)
   
 type auto_tactic = 
-  | Res_pf     of constr * unit clausenv    (* Hint Apply *)
-  | ERes_pf    of constr * unit clausenv    (* Hint EApply *)
+  | Res_pf     of constr * clausenv    (* Hint Apply *)
+  | ERes_pf    of constr * 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 *)
+  | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *)
+  | Unfold_nth of evaluable_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 *)
@@ -48,19 +48,19 @@ 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
+    val find : global_reference -> t -> search_entry
+    val map_all : global_reference -> t -> pri_auto_tactic list
+    val map_auto : global_reference * constr -> t -> pri_auto_tactic list
+    val add_one : global_reference * pri_auto_tactic -> t -> t
+    val add_list : (global_reference * pri_auto_tactic) list -> t -> t
+    val iter : (global_reference -> stored_data list -> unit) -> t -> unit
   end
 
-type frozen_hint_db_table = Hint_db.t Stringmap.t
+type hint_db_name = string
 
-type hint_db_table = Hint_db.t Stringmap.t ref
+val searchtable_map : hint_db_name -> Hint_db.t
 
-type hint_db_name = string
+val current_db_names : unit -> hint_db_name list
 
 val add_hints : locality_flag -> hint_db_name list -> hints -> unit
 
@@ -72,25 +72,20 @@ 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
+val make_exact_entry : constr * constr -> global_reference * pri_auto_tactic
 
-(* [make_apply_entry (eapply,verbose) name (c,cty)].
+(* [make_apply_entry (eapply,verbose) (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
+  env -> evar_map -> bool * bool -> constr * constr
+      -> global_reference * pri_auto_tactic
 
 (* A constr which is Hint'ed will be:
    (1) used as an Exact, if it does not start with a product
@@ -100,8 +95,8 @@ val make_apply_entry :
        has missing arguments. *)
 
 val make_resolves :
-  env -> evar_map -> identifier -> bool * bool -> constr * constr -> 
-    (constr_label * pri_auto_tactic) list
+  env -> evar_map -> bool -> constr -> 
+      (global_reference * pri_auto_tactic) list
 
 (* [make_resolve_hyp hname htyp].
    used to add an hypothesis to the local hint database;
@@ -110,13 +105,13 @@ val make_resolves :
 
 val make_resolve_hyp : 
   env -> evar_map -> named_declaration ->
-      (constr_label * pri_auto_tactic) list
+      (global_reference * pri_auto_tactic) list
 
-(* [make_extern name pri pattern tactic_expr] *)
+(* [make_extern pri pattern tactic_expr] *)
 
 val make_extern :
-  identifier -> int -> constr_pattern -> Tacexpr.glob_tactic_expr
-      -> constr_label * pri_auto_tactic
+  int -> constr_pattern -> Tacexpr.glob_tactic_expr
+      -> global_reference * pri_auto_tactic
 
 val set_extern_interp :
   (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit
@@ -126,20 +121,20 @@ val set_extern_intern_tac :
   -> unit
 
 val set_extern_subst_tactic :
-  (Names.substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr)
+  (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 make_local_hint_db : constr list -> 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
+val unify_resolve : (constr * clausenv) -> tactic
 
 (* [ConclPattern concl pat tacast]:
    if the term concl matches the pattern pat, (in sense of 
@@ -150,29 +145,29 @@ val conclPattern : constr -> constr_pattern -> Tacexpr.glob_tactic_expr -> tacti
 
 (* The Auto tactic *)
 
-val auto : int -> hint_db_name list -> tactic
+val auto : int -> constr list -> 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
+val full_auto : int -> constr list -> 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
+val gen_auto : int option -> constr list -> hint_db_name list option -> tactic
 
 (* The hidden version of auto *)
-val h_auto   : int option -> hint_db_name list option -> tactic
+val h_auto   : int option -> constr list -> 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 trivial : constr list -> hint_db_name list -> tactic
+val gen_trivial : constr list -> hint_db_name list option -> tactic
+val full_trivial : constr list -> tactic
+val h_trivial : constr list -> hint_db_name list option -> tactic
 
 val fmt_autotactic : auto_tactic -> Pp.std_ppcmds
 
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 5706e134..872b8697 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -6,8 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Ast
-open Coqast
+(* $Id: autorewrite.ml 9157 2006-09-21 15:10:08Z herbelin $ *)
+
 open Equality
 open Hipattern
 open Names
@@ -20,9 +20,11 @@ open Term
 open Util
 open Vernacinterp
 open Tacexpr
+open Mod_subst
 
 (* Rewriting rules *)
-type rew_rule = constr * bool * glob_tactic_expr
+(* the type is the statement of the lemma constr. Used to elim duplicates. *)
+type rew_rule = constr * types * bool * glob_tactic_expr
 
 (* Summary and Object declaration *)
 let rewtab =
@@ -39,35 +41,145 @@ let _ =
       Summary.survive_module = false;
       Summary.survive_section   = false }
 
+let print_rewrite_hintdb bas =
+ try
+  let hints = Stringmap.find bas !rewtab in
+   ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++
+    prlist_with_sep Pp.cut
+     (fun (c,typ,d,t) ->
+       str (if d then "rewrite -> " else "rewrite <- ") ++
+       Printer.pr_lconstr c ++ str " of type " ++ Printer.pr_lconstr typ ++
+       str " then use tactic " ++ 
+       Pptactic.pr_glob_tactic (Global.env()) t) hints)
+ with
+  Not_found -> 
+   errorlabstrm "AutoRewrite" 
+     (str ("Rewriting base "^(bas)^" does not exist"))
+
 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 
+let one_base general_rewrite_maybe_in tac_main bas =
+  let lrul =
+    try
       Stringmap.find bas !rewtab
-    with Not_found -> 
-      errorlabstrm "AutoRewrite" 
+    with Not_found ->
+      errorlabstrm "AutoRewrite"
         (str ("Rewriting base "^(bas)^" does not exist"))
   in
-  let lrul = List.map (fun (c,b,t) -> (c,b,Tacinterp.eval_tactic t)) lrul in
+  let lrul = List.map (fun (c,_,b,t) -> (c,b,Tacinterp.eval_tactic t)) lrul in
     tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) ->
       tclTHEN tac
         (tclREPEAT_MAIN 
-	  (tclTHENSFIRSTn (general_rewrite dir csr) [|tac_main|] tc)))
+	  (tclTHENSFIRSTn (general_rewrite_maybe_in 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))
+       tclTHEN tac (one_base general_rewrite tac_main bas)) tclIDTAC lbas))
+
+let autorewrite_mutlti_in idl tac_main lbas : tactic =
+  fun gl -> 
+ (* let's check at once if id exists (to raise the appropriate error) *)
+ let _ = List.map (Tacmach.pf_get_hyp gl) idl in
+ let general_rewrite_in id =
+  let id = ref id in
+  let to_be_cleared = ref false in
+   fun dir cstr gl ->
+    let last_hyp_id =
+     match (Environ.named_context_of_val gl.Evd.it.Evd.evar_hyps) with
+        (last_hyp_id,_,_)::_ -> last_hyp_id
+      | _ -> (* even the hypothesis id is missing *)
+             error ("No such hypothesis : " ^ (string_of_id !id))
+    in
+    let gl' = general_rewrite_in dir !id cstr gl in
+    let gls = (fst gl').Evd.it in
+    match gls with
+       g::_ ->
+        (match Environ.named_context_of_val g.Evd.evar_hyps with
+            (lastid,_,_)::_ ->
+              if last_hyp_id <> lastid then
+               begin
+                let gl'' =
+                  if !to_be_cleared then
+                   tclTHEN (fun _ -> gl') (tclTRY (clear [!id])) gl
+                  else gl' in
+                id := lastid ;
+                to_be_cleared := true ;
+                gl''
+               end
+              else
+               begin
+                to_be_cleared := false ;
+                gl'
+               end
+          | _ -> assert false) (* there must be at least an hypothesis *)
+     | _ -> assert false (* rewriting cannot complete a proof *)
+ in
+ tclMAP (fun id -> 
+  tclREPEAT_MAIN (tclPROGRESS
+    (List.fold_left (fun tac bas -> 
+       tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) tclIDTAC lbas)))
+   idl gl
+
+let autorewrite_in id = autorewrite_mutlti_in [id]
+
+let gen_auto_multi_rewrite tac_main lbas cl = 
+  let try_do_hyps treat_id l = 
+    autorewrite_mutlti_in (List.map treat_id l) tac_main lbas
+  in 
+  if cl.concl_occs <> [] then 
+    error "The \"at\" syntax isn't available yet for the autorewrite tactic"
+  else 
+    let compose_tac t1 t2 = 
+      match cl.onhyps with 
+	| Some [] -> t1 
+	| _ ->      tclTHENFIRST t1 t2
+    in
+    compose_tac
+	(if cl.onconcl then autorewrite tac_main lbas else tclIDTAC)
+	(match cl.onhyps with 
+	   | Some l -> try_do_hyps (fun ((_,id),_) -> id) l
+	   | None -> 
+	       fun gl -> 
+		 (* try to rewrite in all hypothesis 
+		    (except maybe the rewritten one) *)
+		 let ids =  Tacmach.pf_ids_of_hyps gl
+		 in try_do_hyps (fun id -> id)  ids gl)
+
+let auto_multi_rewrite = gen_auto_multi_rewrite Refiner.tclIDTAC
+
+let auto_multi_rewrite_with tac_main lbas cl gl = 
+  match cl.Tacexpr.onconcl,cl.Tacexpr.onhyps with 
+    | false,Some [_] | true,Some [] | false,Some [] ->   
+	(* autorewrite with .... in clause using tac n'est sur que 
+	   si clause reprensente soit le but soit UNE hypothse 
+	*)
+	gen_auto_multi_rewrite tac_main  lbas cl gl
+    | _ -> 
+	    Util.errorlabstrm "autorewrite" 
+	      (str "autorewrite .. in .. using can only be used either with a unique hypothesis or" ++
+		 str " on the conclusion")
+
 
 (* Functions necessary to the library object declaration *)
 let cache_hintrewrite (_,(rbase,lrl)) =
   let l = 
     try 
-      lrl @ Stringmap.find rbase !rewtab
+      let oldl = Stringmap.find rbase !rewtab in
+      let lrl =
+       List.map
+        (fun (c,dummy,b,t) ->
+          (* here we substitute the dummy value with the right one *)
+          c,Typing.type_of (Global.env ()) Evd.empty c,b,t) lrl in
+      (List.filter
+          (fun (_,typ,_,_) ->
+            not (List.exists (fun (_,typ',_,_) -> Term.eq_constr typ typ') oldl)
+          ) lrl) @ oldl
     with
       | Not_found -> lrl
   in
@@ -76,11 +188,16 @@ let cache_hintrewrite (_,(rbase,lrl)) =
 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 subst_first (cst,typ,b,t as pair) = 
+    let cst' = subst_mps subst cst in
+    let typ' =
+     (* here we do not have the environment and Global.env () is not the
+        one where cst' lives in. Thus we can just put a dummy value and
+        override it in cache_hintrewrite *)
+     typ (* dummy value, it will be recomputed by cache_hintrewrite *) in
     let t' = Tacinterp.subst_tactic subst t in
-      if cst == cst' & t == t' then pair else
-	(cst',b,t)
+      if cst == cst' && t == t' then pair else
+	(cst',typ',b,t')
   in
   let list' = list_smartmap subst_first list in
     if list' == list then node else
@@ -92,13 +209,18 @@ 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.load_function = (fun _ -> 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))
+  let lrul =
+   List.rev_map
+    (fun (c,b,t) ->
+      (c,mkProp (* dummy value *), 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
index e97cde83..f402a35d 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: autorewrite.mli 9073 2006-08-22 08:54:29Z jforest $ i*)
 
 (*i*)
 open Tacmach
@@ -20,3 +20,11 @@ val add_rew_rules : string -> raw_rew_rule list -> unit
 
 (* The AutoRewrite tactic *)
 val autorewrite : tactic -> string list -> tactic
+val autorewrite_in : Names.identifier -> tactic -> string list -> tactic
+
+
+val auto_multi_rewrite : string list -> Tacticals.clause -> tactic
+
+val auto_multi_rewrite_with : tactic -> string list -> Tacticals.clause -> tactic
+
+val print_rewrite_hintdb : string -> unit
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index c5cdd540..f0b23b8d 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -6,11 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: btermdn.ml,v 1.5.16.1 2004/07/16 19:30:52 herbelin Exp $ *)
+(* $Id: btermdn.ml 6427 2004-12-07 17:41:10Z sacerdot $ *)
 
 open Term
 open Termdn
 open Pattern
+open Libnames
 
 (* Discrimination nets with bounded depth.
    See the module dn.ml for further explanations.
@@ -34,7 +35,7 @@ let bounded_constr_val_discr (t,depth) =
       | 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
+type 'a t = (global_reference,constr_pattern * int,'a) Dn.t
 
 let create = Dn.create
 
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
index fe247495..1ac33557 100644
--- a/tactics/btermdn.mli
+++ b/tactics/btermdn.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: btermdn.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Term
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index c9d0ead5..eca16066 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: contradiction.ml,v 1.3.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+(* $Id: contradiction.ml 9269 2006-10-24 13:01:55Z herbelin $ *)
 
 open Util
 open Term
@@ -22,6 +22,10 @@ open Rawterm
 (* Absurd *)
 
 let absurd c gls =
+  let env = pf_env gls and sigma = project gls in
+  let _,j = Coercion.Default.inh_coerce_to_sort dummy_loc env
+    (Evd.create_evar_defs sigma) (Retyping.get_judgment_of env sigma c) in
+  let c = j.Environ.utj_val in
   (tclTHENS
      (tclTHEN (elim_type (build_coq_False ())) (cut c)) 
      ([(tclTHENS
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
index 90ec101c..d94a1ef2 100644
--- a/tactics/contradiction.mli
+++ b/tactics/contradiction.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: contradiction.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Names
diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml
new file mode 100644
index 00000000..f341580e
--- /dev/null
+++ b/tactics/decl_interp.ml
@@ -0,0 +1,481 @@
+(************************************************************************)
+(*  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$ *)
+
+open Util
+open Names
+open Topconstr
+open Tacinterp
+open Tacmach
+open Decl_expr
+open Decl_mode
+open Pretyping.Default
+open Rawterm
+open Term
+open Pp
+
+(* INTERN *)
+
+let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args) 
+
+let intern_justification_items globs = 
+  option_map (List.map (intern_constr globs))
+
+let intern_justification_method globs = 
+  option_map (intern_tactic globs)
+
+let intern_statement intern_it globs st =
+  {st_label=st.st_label;
+   st_it=intern_it globs st.st_it}
+    
+let intern_no_bind intern_it globs x =
+  globs,intern_it globs x
+
+let intern_constr_or_thesis globs = function
+    Thesis n -> Thesis n
+  | This c -> This (intern_constr globs c)
+
+let add_var id globs= 
+  let l1,l2=globs.ltacvars in
+    {globs with ltacvars= (id::l1),(id::l2)}
+
+let add_name nam globs=
+ match nam with 
+     Anonymous -> globs
+   | Name id -> add_var id globs
+
+let intern_hyp iconstr globs = function 
+    Hvar (loc,(id,topt)) -> add_var id globs,
+      Hvar (loc,(id,option_map (intern_constr globs) topt))
+  | Hprop st -> add_name st.st_label globs,
+      Hprop (intern_statement iconstr globs st)
+
+let intern_hyps iconstr globs hyps = 
+  snd (list_fold_map (intern_hyp iconstr) globs hyps)
+
+let intern_cut intern_it globs cut=
+  let nglobs,nstat=intern_it globs cut.cut_stat in
+    {cut_stat=nstat;
+     cut_by=intern_justification_items nglobs cut.cut_by;
+     cut_using=intern_justification_method nglobs cut.cut_using}
+
+let intern_casee globs = function 
+    Real c -> Real (intern_constr globs c)
+  | Virtual cut -> Virtual 
+      (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) 
+
+let intern_hyp_list args globs =
+  let intern_one globs (loc,(id,opttyp)) =
+    (add_var id globs),
+    (loc,(id,option_map (intern_constr globs) opttyp)) in
+  list_fold_map intern_one globs args 
+
+let intern_suffices_clause globs (hyps,c) = 
+  let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in
+    nglobs,(nhyps,intern_constr_or_thesis nglobs c) 
+
+let intern_fundecl args body globs= 
+  let nglobs,nargs = intern_hyp_list args globs in
+    nargs,intern_constr nglobs body
+          
+let rec add_vars_of_simple_pattern globs = function
+    CPatAlias (loc,p,id) ->
+      add_vars_of_simple_pattern (add_var id globs) p
+(*      Stdpp.raise_with_loc loc 
+	(UserError ("simple_pattern",str "\"as\" is not allowed here"))*)
+  | CPatOr (loc, _)->
+      Stdpp.raise_with_loc loc 
+	(UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here"))
+  | CPatDelimiters (_,_,p) ->
+      add_vars_of_simple_pattern globs p
+  | CPatCstr (_,_,pl) | CPatNotation(_,_,pl) ->
+      List.fold_left add_vars_of_simple_pattern globs pl
+  | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs
+  |  _  -> globs 
+
+let rec intern_bare_proof_instr globs = function
+    Pthus i -> Pthus (intern_bare_proof_instr globs i)
+  | Pthen i -> Pthen (intern_bare_proof_instr globs i)
+  | Phence i -> Phence (intern_bare_proof_instr globs i)
+  | Pcut c -> Pcut 
+      (intern_cut 
+	 (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c)
+  | Psuffices c -> 
+      Psuffices (intern_cut intern_suffices_clause globs c)
+  | Prew (s,c) -> Prew 
+      (s,intern_cut 
+	 (intern_no_bind  (intern_statement intern_constr)) globs c) 
+  | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps)
+  | Pcase (params,pat,hyps) -> 
+      let nglobs,nparams = intern_hyp_list params globs in
+      let nnglobs= add_vars_of_simple_pattern nglobs pat in
+      let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in
+	Pcase (nparams,pat,nhyps) 
+  | Ptake witl -> Ptake (List.map (intern_constr globs) witl)
+  | Pconsider (c,hyps) -> Pconsider (intern_constr globs c,
+				      intern_hyps intern_constr globs hyps)
+  | Pper (et,c) -> Pper (et,intern_casee globs c)
+  | Pend bt -> Pend bt
+  | Pescape -> Pescape
+  | Passume hyps -> Passume (intern_hyps intern_constr globs hyps)
+  | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps)
+  | Plet hyps -> Plet (intern_hyps intern_constr globs hyps)
+  | Pclaim st -> Pclaim (intern_statement intern_constr globs st)
+  | Pfocus st -> Pfocus (intern_statement intern_constr globs st)
+  | Pdefine (id,args,body) -> 
+      let nargs,nbody = intern_fundecl args body globs in
+	Pdefine (id,nargs,nbody)
+  | Pcast (id,typ) ->
+      Pcast (id,intern_constr globs typ)
+
+let rec intern_proof_instr globs instr=
+  {emph = instr.emph;
+   instr = intern_bare_proof_instr globs instr.instr}
+
+(* INTERP *)
+
+let interp_justification_items sigma env =
+    option_map (List.map (fun c ->understand sigma env (fst c)))
+
+let interp_constr check_sort sigma env c = 
+  if check_sort then 
+    understand_type sigma env (fst c) 
+  else 
+    understand sigma env (fst c)
+
+let special_whd env =
+  let infos=Closure.create_clos_infos Closure.betadeltaiota env in
+    (fun t -> Closure.whd_val infos (Closure.inject t))
+
+let _eq = Libnames.constr_of_reference (Coqlib.glob_eq)
+
+let decompose_eq env id =
+  let typ = Environ.named_type id env in
+  let whd = special_whd env typ in
+    match kind_of_term whd with
+	App (f,args)->
+	  if eq_constr f _eq && (Array.length args)=3 
+	  then args.(0)
+	  else error "previous step is not an equality"
+      | _ -> error "previous step is not an equality"
+
+let get_eq_typ info env =
+  let last_id = 	    
+    match info.pm_last with
+	None -> error "no previous equality"
+      | Some (id,_) -> id in
+  let typ = decompose_eq env last_id in  
+    typ
+
+let interp_constr_in_type typ sigma env c =
+  understand sigma env (fst c) ~expected_type:typ
+
+let interp_statement interp_it sigma env st =
+  {st_label=st.st_label;
+   st_it=interp_it sigma env st.st_it}
+	
+let interp_constr_or_thesis check_sort sigma env = function
+    Thesis n -> Thesis n
+  | This c -> This (interp_constr check_sort sigma env c)
+
+let type_tester_var body typ = 
+  raw_app(dummy_loc,
+       RLambda(dummy_loc,Anonymous,typ,
+	       RSort (dummy_loc,RProp Null)),body)
+
+let abstract_one_hyp inject h raw = 
+  match h with 
+      Hvar (loc,(id,None)) ->  
+	RProd (dummy_loc,Name id, RHole (loc,Evd.BinderType (Name id)), raw)
+    | Hvar (loc,(id,Some typ)) ->  
+	RProd (dummy_loc,Name id,fst typ, raw)
+    | Hprop st -> 
+	RProd (dummy_loc,st.st_label,inject st.st_it, raw)
+
+let rawconstr_of_hyps inject hyps head = 
+  List.fold_right (abstract_one_hyp inject) hyps head
+
+let raw_prop = RSort (dummy_loc,RProp Null)
+  
+let rec match_hyps blend names constr = function 
+    [] -> [],substl names constr
+  | hyp::q -> 
+      let (name,typ,body)=destProd constr in
+      let st= {st_label=name;st_it=substl names typ} in
+      let qnames=
+	match name with
+	    Anonymous -> mkMeta 0 :: names
+	  | Name id -> mkVar id :: names in
+      let qhyp = match hyp with
+	  Hprop st' -> Hprop (blend st st')
+	| Hvar _ -> Hvar st in
+      let rhyps,head = match_hyps blend qnames body q in
+	qhyp::rhyps,head
+
+let interp_hyps_gen inject blend sigma env hyps head = 
+  let constr=understand sigma env (rawconstr_of_hyps inject hyps head) in
+    match_hyps blend [] constr hyps
+
+let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps raw_prop)
+
+let dummy_prefix= id_of_string "__"
+
+let rec deanonymize ids = 
+  function 
+      PatVar (loc,Anonymous) -> 
+	let (found,known) = !ids in
+	let new_id=Nameops.next_ident_away dummy_prefix known in
+	let _= ids:= (loc,new_id) :: found , new_id :: known in
+	  PatVar (loc,Name new_id)
+    | PatVar (loc,Name id) as pat -> 
+	let (found,known) = !ids in
+	let _= ids:= (loc,id) :: found , known in
+	  pat
+    | PatCstr(loc,cstr,lpat,nam) -> 
+	PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam)
+
+let rec raw_of_pat =
+  function 
+      PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" 
+    | PatVar (loc,Name id) -> 
+	  RVar (loc,id)
+    | PatCstr(loc,((ind,_) as cstr),lpat,_) -> 
+	let mind= fst (Global.lookup_inductive ind) in
+	let rec add_params n q =
+	  if n<=0 then q else
+	    add_params (pred n) (RHole(dummy_loc,
+				       Evd.TomatchTypeParameter(ind,n))::q) in
+	    let args = List.map raw_of_pat lpat in 
+	      raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr),
+		   add_params mind.Declarations.mind_nparams args) 
+			 
+let prod_one_hyp = function
+    (loc,(id,None)) ->
+      (fun raw ->  
+	 RProd (dummy_loc,Name id, 
+		RHole (loc,Evd.BinderType (Name id)), raw))
+  | (loc,(id,Some typ)) -> 
+      (fun raw ->  
+	 RProd (dummy_loc,Name id,fst typ, raw))
+
+let prod_one_id (loc,id) raw =
+  RProd (dummy_loc,Name id,
+	 RHole (loc,Evd.BinderType (Name id)), raw)
+
+let let_in_one_alias (id,pat) raw =
+  RLetIn (dummy_loc,Name id,raw_of_pat pat, raw)
+
+let rec bind_primary_aliases map pat =
+  match pat with 
+      PatVar (_,_) -> map
+    | PatCstr(loc,_,lpat,nam) ->
+	let map1 =
+	  match nam with 
+	      Anonymous -> map
+	    | Name id -> (id,pat)::map 
+	in
+	  List.fold_left bind_primary_aliases map1 lpat
+
+let bind_secondary_aliases map subst =
+  List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst
+
+let bind_aliases patvars subst patt =
+  let map = bind_primary_aliases [] patt in
+  let map1 = bind_secondary_aliases map subst in
+  List.rev map1
+
+let interp_pattern env pat_expr = 
+  let patvars,pats = Constrintern.intern_pattern env pat_expr in
+    match pats with 
+	[] -> anomaly "empty pattern list"
+      | [subst,patt] ->
+	  (patvars,bind_aliases patvars subst patt,patt)
+      | _  -> anomaly "undetected disjunctive pattern"
+
+let rec match_args dest names constr = function 
+    [] -> [],names,substl names constr
+  | _::q -> 
+      let (name,typ,body)=dest constr in
+      let st={st_label=name;st_it=substl names typ} in
+      let qnames=
+	match name with
+	    Anonymous -> assert  false
+	  | Name id -> mkVar id :: names in
+      let args,bnames,body = match_args dest qnames body q in
+	st::args,bnames,body
+
+let rec match_aliases names constr = function 
+    [] -> [],names,substl names constr
+  | _::q -> 
+      let (name,c,typ,body)=destLetIn constr in
+      let st={st_label=name;st_it=(substl names c,substl names typ)} in
+      let qnames=
+	match name with
+	    Anonymous -> assert false
+	  | Name id -> mkVar id :: names in
+      let args,bnames,body = match_aliases qnames body q in
+	st::args,bnames,body
+
+let detype_ground c = Detyping.detype false [] [] c
+
+let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
+  let et,pinfo =
+    match info.pm_stack with
+	Per(et,pi,_,_)::_ -> et,pi
+      | _ -> error "No proof per cases/induction/inversion in progress." in
+  let mib,oib=Global.lookup_inductive  pinfo.per_ind in
+  let num_params = pinfo.per_nparams in
+  let _ = 
+    let expected = mib.Declarations.mind_nparams - num_params in
+      if List.length params <> expected then
+	errorlabstrm "suppose it is" 
+	  (str "Wrong number of extra arguments : " ++ 
+	     (if expected = 0 then str "none" else int expected) ++ 
+	     str "expected") in
+  let app_ind =
+    let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in
+    let rparams = List.map detype_ground pinfo.per_params in 
+    let rparams_rec = 
+      List.map 
+	(fun (loc,(id,_)) -> 
+	   RVar (loc,id)) params in 
+    let dum_args= 
+      list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark))
+	oib.Declarations.mind_nrealargs in
+      raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
+  let pat_vars,aliases,patt = interp_pattern env pat in
+  let inject = function
+      Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null)
+    | Thesis (Sub n) ->
+	error "thesis[_] is not allowed here"
+    | Thesis (For rec_occ) ->
+	if not (List.mem rec_occ pat_vars) then 
+	  errorlabstrm "suppose it is" 
+	    (str "Variable " ++ Nameops.pr_id rec_occ ++ 
+	       str " does not occur in pattern.");
+	Rawterm.RSort(dummy_loc,RProp Null)
+    | This (c,_) -> c in
+  let term1 = rawconstr_of_hyps inject hyps raw_prop in
+  let loc_ids,npatt =
+    let rids=ref ([],pat_vars) in
+    let npatt= deanonymize rids patt in 
+      List.rev (fst !rids),npatt in
+  let term2 =
+    RLetIn(dummy_loc,Anonymous,
+	   RCast(dummy_loc,raw_of_pat npatt,
+		 CastConv DEFAULTcast,app_ind),term1) in
+  let term3=List.fold_right let_in_one_alias aliases term2 in  
+  let term4=List.fold_right prod_one_id loc_ids term3 in
+  let term5=List.fold_right prod_one_hyp params term4 in
+  let constr = understand  sigma env term5 in
+  let tparams,nam4,rest4 = match_args destProd [] constr params in
+  let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in
+  let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in
+  let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in
+  let blend st st' =
+    match st'.st_it with 
+	Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} 
+      | This _ -> {st_it = This st.st_it;st_label=st.st_label} in
+  let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in
+    tparams,{pat_vars=tpatvars;
+	     pat_aliases=taliases;
+	     pat_constr=pat_pat;
+	     pat_typ=pat_typ;
+	     pat_pat=patt;
+	     pat_expr=pat},thyps
+
+let interp_cut interp_it sigma env cut=
+  let nenv,nstat = interp_it sigma env cut.cut_stat in
+    {cut with 
+       cut_stat=nstat;
+       cut_by=interp_justification_items sigma nenv cut.cut_by}
+
+let interp_no_bind interp_it sigma env x =
+  env,interp_it sigma env x
+
+let interp_suffices_clause sigma env (hyps,cot)=
+  let (locvars,_) as res =
+    match cot with
+	This (c,_) -> 
+	  let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in
+	  nhyps,This nc
+      | Thesis (Plain| Sub _) as th  -> interp_hyps sigma env hyps,th
+      | Thesis (For n) -> error "\"thesis for\" is not applicable here" in
+  let push_one hyp env0 =
+    match hyp with
+	(Hprop st | Hvar st) ->
+	  match st.st_label with
+	      Name id -> Environ.push_named (id,None,st.st_it) env0
+	    | _ -> env in
+  let nenv = List.fold_right push_one locvars env in 
+    nenv,res 
+	  
+let interp_casee sigma env = function 
+    Real c -> Real (understand sigma env (fst c))
+  | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) 
+
+let abstract_one_arg = function
+    (loc,(id,None)) ->
+      (fun raw ->  
+	 RLambda (dummy_loc,Name id, 
+		RHole (loc,Evd.BinderType (Name id)), raw))
+  | (loc,(id,Some typ)) -> 
+      (fun raw ->  
+	 RLambda (dummy_loc,Name id,fst typ, raw))
+
+let rawconstr_of_fun args body = 
+  List.fold_right abstract_one_arg args (fst body)
+
+let interp_fun sigma env args body = 
+  let constr=understand sigma env (rawconstr_of_fun args body) in
+    match_args destLambda [] constr args
+
+let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function
+    Pthus i -> Pthus (interp_bare_proof_instr info sigma env i)
+  | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i)
+  | Phence i -> Phence (interp_bare_proof_instr info sigma env i)
+  | Pcut c -> Pcut (interp_cut 
+		      (interp_no_bind (interp_statement 
+					 (interp_constr_or_thesis true))) 
+		      sigma env c) 
+  | Psuffices c ->  
+      Psuffices (interp_cut interp_suffices_clause sigma env c)
+  | Prew (s,c) -> Prew (s,interp_cut 
+			  (interp_no_bind (interp_statement 
+			     (interp_constr_in_type (get_eq_typ info env))))
+			  sigma env c) 
+
+  | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps)
+  | Pcase (params,pat,hyps) -> 
+      let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in 
+	Pcase (tparams,tpat,thyps)
+  | Ptake witl -> 
+      Ptake (List.map (fun c -> understand sigma env (fst c)) witl)
+  | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c,
+				     interp_hyps sigma env hyps)
+  | Pper (et,c) -> Pper (et,interp_casee sigma env c)
+  | Pend bt -> Pend bt
+  | Pescape -> Pescape
+  | Passume hyps -> Passume (interp_hyps sigma env hyps)
+  | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps)
+  | Plet hyps -> Plet (interp_hyps sigma env hyps)
+  | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st)
+  | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st)
+  | Pdefine (id,args,body) -> 
+      let nargs,_,nbody = interp_fun sigma env args body in
+	Pdefine (id,nargs,nbody)
+  | Pcast (id,typ) -> 
+      Pcast(id,interp_constr true sigma env typ)
+
+let rec interp_proof_instr info sigma env instr=
+  {emph = instr.emph;
+   instr = interp_bare_proof_instr info sigma env instr.instr}
+ 
+
+
diff --git a/contrib7/correctness/Programs_stuff.v b/tactics/decl_interp.mli
index 00beeaeb..bd085938 100644
--- a/contrib7/correctness/Programs_stuff.v
+++ b/tactics/decl_interp.mli
@@ -6,8 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+(* $Id$ *)
 
-(* $Id: Programs_stuff.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
+open Tacinterp
+open Decl_expr
+open Mod_subst
 
-Require Export Arrays_stuff.
+
+val intern_proof_instr : glob_sign -> raw_proof_instr -> glob_proof_instr
+val interp_proof_instr : Decl_mode.pm_info ->
+  Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr
diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml
new file mode 100644
index 00000000..b19d8c04
--- /dev/null
+++ b/tactics/decl_proof_instr.ml
@@ -0,0 +1,1561 @@
+(************************************************************************)
+(*  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$ *)
+
+open Util
+open Pp
+open Evd
+
+open Refiner
+open Proof_type
+open Proof_trees
+open Tacmach
+open Tacinterp
+open Decl_expr
+open Decl_mode
+open Decl_interp
+open Rawterm
+open Names
+open Declarations
+open Tactics
+open Tacticals
+open Term
+open Termops
+open Reductionops
+open Goptions
+
+(* Strictness option *)
+
+let get_its_info gls = get_info gls.it
+
+let get_strictness,set_strictness = 
+  let strictness = ref false in
+    (fun () -> (!strictness)),(fun b -> strictness:=b)
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "strict mode";
+      optkey   = (SecondaryTable ("Strict","Proofs"));
+      optread  = get_strictness;
+      optwrite = set_strictness }
+
+let tcl_change_info_gen info_gen = 
+  (fun gls ->
+  let gl =sig_it gls in  
+    {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls}, 
+  function 
+      [pftree] ->
+	{pftree with
+	   goal=gl;
+	   ref=Some (Prim Change_evars,[pftree])} 
+    | _ -> anomaly "change_info : Wrong number of subtrees")
+
+let tcl_change_info info gls =  tcl_change_info_gen (Some (pm_in info)) gls
+
+let tcl_erase_info gls =  tcl_change_info_gen None gls
+
+let special_whd gl=
+  let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
+    (fun t -> Closure.whd_val infos (Closure.inject t))
+
+let special_nf gl=
+  let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
+    (fun t -> Closure.norm_val infos (Closure.inject t))
+
+let is_good_inductive env ind =
+  let mib,oib = Inductive.lookup_mind_specif env ind in
+    oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib))
+
+let check_not_per pts =
+  if not (Proof_trees.is_complete_proof (proof_of_pftreestate pts)) then
+    match get_stack pts with
+	Per (_,_,_,_)::_ -> 
+	  error "You are inside a proof per cases/induction.\n\
+Please \"suppose\" something or \"end\" it now."
+      | _ -> ()
+
+let get_thesis gls0 = 
+ let info = get_its_info gls0 in  
+    match info.pm_subgoals with
+	[m,thesis] -> thesis
+      | _ -> error "Thesis is split"
+
+let mk_evd metalist gls =
+  let evd0= create_evar_defs (sig_sig gls) in
+  let add_one (meta,typ) evd = 
+    meta_declare meta typ evd in
+    List.fold_right add_one metalist evd0
+
+let set_last cpl gls = 
+  let info = get_its_info gls in
+    tclTHEN 
+      begin 
+	match info.pm_last with 
+	    Some (lid,false) when 
+	      not (occur_id [] lid info.pm_partial_goal) -> 
+		tclTRY (clear [lid])
+	  | _ -> tclIDTAC
+      end
+      begin
+	tcl_change_info 
+	  {info with 
+	    pm_last=Some cpl }
+      end gls
+	  
+(* start a proof *)
+
+let start_proof_tac gls=
+  let gl=sig_it gls in
+  let info={pm_last=None;
+	    pm_partial_goal=mkMeta 1; 
+	    pm_subgoals= [1,gl.evar_concl];
+	    pm_stack=[]} in
+    {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, 
+  function 
+      [pftree] ->
+	{pftree with
+	   goal=gl;
+	   ref=Some (Decl_proof true,[pftree])} 
+    | _ -> anomaly "Dem : Wrong number of subtrees"
+
+let go_to_proof_mode () = 
+  Pfedit.mutate 
+    (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts))
+
+(* closing gaps *)
+
+let daimon_tac gls =
+  set_daimon_flag ();
+  ({it=[];sigma=sig_sig gls}, 
+   function 
+       [] ->
+	 {open_subgoals=0;
+	    goal=sig_it gls;
+	    ref=Some (Daimon,[])} 
+     | _ -> anomaly "Daimon: Wrong number of subtrees")
+    
+let daimon _ pftree =
+  set_daimon_flag ();
+  {pftree with
+     open_subgoals=0;
+     ref=Some (Daimon,[])}
+
+let daimon_subtree = map_pftreestate (fun _ ->  frontier_mapi daimon )
+
+(* marking closed blocks *)
+
+let rec is_focussing_instr = function
+    Pthus i | Pthen i | Phence i -> is_focussing_instr i
+  | Pescape | Pper _ | Pclaim _ | Pfocus _ 
+  | Psuppose _ | Pcase (_,_,_)  -> true
+  | _ -> false
+
+let mark_rule_as_done = function
+    Decl_proof true -> Decl_proof false
+  | Decl_proof false ->
+      anomaly "already marked as done"
+  | Nested(Proof_instr (lock_focus,instr),spfl) -> 
+      if lock_focus then
+	Nested(Proof_instr (false,instr),spfl)
+      else
+	anomaly "already marked as done"
+  | _ -> anomaly "mark_rule_as_done"
+
+let mark_proof_tree_as_done pt =
+  match pt.ref with
+      None -> anomaly "mark_proof_tree_as_done"
+    | Some (r,spfl) -> 
+	{pt with ref= Some (mark_rule_as_done r,spfl)}
+
+let mark_as_done pts = 
+  map_pftreestate 
+    (fun _ -> mark_proof_tree_as_done) 
+    (traverse 0 pts) 
+
+(* post-instruction focus management *)
+
+let goto_current_focus pts = up_until_matching_rule is_focussing_command pts
+
+let goto_current_focus_or_top pts = 
+  try 
+    up_until_matching_rule is_focussing_command pts
+  with Not_found -> top_of_tree pts
+
+(* return *)
+
+let close_tactic_mode pts =
+    let pts1=  
+      try goto_current_focus pts 
+      with Not_found -> 
+	error "\"return\" cannot be used outside of Declarative Proof Mode" in
+    let pts2 = daimon_subtree pts1 in
+    let pts3 = mark_as_done pts2 in 
+      goto_current_focus pts3 
+	  
+let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode
+
+(* end proof/claim *)
+
+let close_block bt pts =
+  let stack =
+    if Proof_trees.is_complete_proof (proof_of_pftreestate pts) then
+      get_top_stack pts
+    else
+      get_stack pts in
+    match bt,stack with
+	B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> 
+	  daimon_subtree (goto_current_focus pts)
+      | _, Claim::_ -> 
+	  error "\"end claim\" expected" 
+      | _, Focus_claim::_ -> 
+	  error "\"end focus\" expected" 
+      | _, [] ->
+ 	  error "\"end proof\" expected" 
+      | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) ->
+	  begin
+	    match et with
+		ET_Case_analysis -> error "\"end cases\" expected"
+	      | ET_Induction ->  error "\"end induction\" expected"
+	  end
+      | _,_ -> anomaly "lonely suppose on stack"
+
+(* utility for suppose / suppose it is *)
+
+let close_previous_case pts = 
+  if 
+    Proof_trees.is_complete_proof (proof_of_pftreestate pts) 
+  then
+    match get_top_stack pts with
+	Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..."  
+      | Suppose_case :: Per (et,_,_,_) :: _ -> 
+	  goto_current_focus (mark_as_done pts)
+      | _ -> error "Not inside a proof per cases or induction."   
+  else
+    match get_stack pts with
+	Per (et,_,_,_) :: _ -> pts 
+      | Suppose_case :: Per (et,_,_,_) :: _ ->
+	  goto_current_focus (mark_as_done (daimon_subtree pts))
+      | _ -> error "Not inside a proof per cases or induction."
+
+(* Proof instructions *)
+
+(* automation *)
+
+let filter_hyps f gls =
+  let filter_aux (id,_,_) = 
+    if f id then 
+      tclIDTAC
+    else 
+      tclTRY (clear [id])  in
+    tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls
+
+let local_hyp_prefix = id_of_string "___"
+
+let add_justification_hyps keep items gls =
+  let add_aux c gls=
+    match kind_of_term c with 
+	Var id -> 
+	  keep:=Idset.add id !keep;
+	  tclIDTAC gls 
+      | _ -> 
+	  let id=pf_get_new_id local_hyp_prefix gls in 
+	    keep:=Idset.add id !keep; 
+	    letin_tac false (Names.Name id) c Tacexpr.nowhere gls in 
+    tclMAP add_aux items gls   
+
+let prepare_goal items gls =
+  let tokeep = ref Idset.empty in
+  let auxres = add_justification_hyps tokeep items gls in
+   tclTHENLIST
+     [ (fun _ -> auxres);
+       filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls
+
+let my_automation_tac = ref 
+  (fun gls -> anomaly "No automation registered")
+
+let register_automation_tac tac = my_automation_tac:= tac
+
+let automation_tac gls = !my_automation_tac gls
+
+let justification tac gls= 
+    tclORELSE 
+      (tclSOLVE [tclTHEN tac assumption]) 
+      (fun gls -> 
+	 if get_strictness () then 
+	   error "insufficient justification" 
+	 else
+	   begin
+	     msgnl (str "Warning: insufficient justification");  
+	     daimon_tac gls
+	   end) gls
+
+let default_justification elems gls=
+  justification (tclTHEN (prepare_goal elems) automation_tac) gls
+
+(* code for have/then/thus/hence *)
+
+type stackd_elt =
+{se_meta:metavariable;
+ se_type:types;
+ se_last_meta:metavariable;
+ se_meta_list:(metavariable*types) list;
+ se_evd: evar_defs}
+
+let rec replace_in_list m l = function
+    [] -> raise Not_found
+  | c::q -> if m=fst c then l@q else c::replace_in_list m l q
+
+let enstack_subsubgoals env se stack gls=
+  let hd,params = decompose_app (special_whd gls se.se_type) in
+    match kind_of_term hd with
+	Ind ind when is_good_inductive env ind ->
+	  let mib,oib=
+	    Inductive.lookup_mind_specif env ind in
+          let gentypes=
+            Inductive.arities_of_constructors ind (mib,oib) in
+	  let process i gentyp = 
+	    let constructor = mkConstruct(ind,succ i) 
+	      (* constructors numbering*) in
+	    let appterm = applist (constructor,params) in
+	    let apptype = Term.prod_applist gentyp params in
+	    let rc,_ = Reduction.dest_prod env apptype in
+	    let rec meta_aux last lenv = function 
+		[] -> (last,lenv,[])
+	      | (nam,_,typ)::q ->
+		  let nlast=succ last in
+		  let (llast,holes,metas) =
+		    meta_aux nlast (mkMeta nlast :: lenv) q in
+		    (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in
+	    let (nlast,holes,nmetas) = 
+		meta_aux se.se_last_meta [] (List.rev rc) in
+	    let refiner = applist (appterm,List.rev holes) in
+	    let evd = meta_assign se.se_meta refiner se.se_evd in
+	    let ncreated = replace_in_list 
+	      se.se_meta nmetas se.se_meta_list in
+	    let evd0 = List.fold_left 
+	      (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in  
+	      List.iter (fun (m,typ) -> 
+			   Stack.push 
+			     {se_meta=m;
+			      se_type=typ;
+			      se_evd=evd0;
+			      se_meta_list=ncreated;
+			      se_last_meta=nlast} stack) (List.rev nmetas) 
+	  in
+	    Array.iteri process gentypes
+      | _ -> ()
+
+let find_subsubgoal env c ctyp skip evd metas submetas gls =
+  let stack = Stack.create () in
+  let max_meta = 
+    let tmp = List.fold_left (fun a (m,_) -> max a m) 0 metas in
+      List.fold_left (fun a (m,_) -> max a m) tmp submetas in
+  let _ = 
+    List.iter (fun (m,typ) -> 
+		 Stack.push 
+		   {se_meta=m;
+		    se_type=typ;
+		    se_last_meta=max_meta;
+		    se_meta_list=metas;
+		    se_evd=evd} stack) (List.rev metas) in
+  let rec dfs n = 
+    let se = Stack.pop stack in
+      try 
+	let unifier = 
+	  Unification.w_unify true env Reduction.CUMUL 
+	    ctyp se.se_type se.se_evd in
+	  if n <= 0 then 
+	    {se with 
+	       se_evd=meta_assign se.se_meta c unifier;
+	       se_meta_list=replace_in_list 
+		se.se_meta submetas se.se_meta_list}
+	  else
+	      dfs (pred n)
+      with _ -> 
+	begin
+	  enstack_subsubgoals env se stack gls;
+	  dfs n
+	end in
+  let nse= try dfs skip with Stack.Empty -> raise Not_found in
+    nse.se_meta_list,nse.se_evd
+
+let rec nf_list evd = 
+  function
+      [] -> []  
+    | (m,typ)::others -> 
+	if meta_defined evd m then 
+	    nf_list evd others
+	else
+	  (m,nf_meta evd typ)::nf_list evd others
+
+let rec max_linear_context meta_one c =
+  if !meta_one = None then
+     if isMeta c then
+       	begin
+	  meta_one:= Some c;
+          mkMeta 1
+	end
+     else
+       try
+	 map_constr (max_linear_context meta_one) c
+       with Not_found -> 
+	 begin
+	   meta_one:= Some c;
+           mkMeta 1
+	 end
+  else   
+    if isMeta c then 
+      raise Not_found
+    else
+      map_constr (max_linear_context meta_one) c
+
+let thus_tac c ctyp submetas gls =  
+  let info = get_its_info gls in
+  let evd0 = mk_evd (info.pm_subgoals@submetas) gls in
+  let list,evd = 
+    try
+      find_subsubgoal (pf_env gls) c ctyp 0 evd0 info.pm_subgoals submetas gls
+    with Not_found -> 
+      error "I could not relate this statement to the thesis" in
+  let nflist = nf_list evd list in
+  let nfgoal = nf_meta evd info.pm_partial_goal in
+(*  let _ = msgnl (str "Partial goal : " ++ 
+		   print_constr_env (pf_env gls) nfgoal) in *)
+  let rgl = ref None in
+  let refiner = max_linear_context rgl nfgoal in
+    match !rgl with
+	None -> exact_check refiner gls
+      | Some pgl when not (isMeta refiner) ->
+	  let ninfo={info with
+		       pm_partial_goal = pgl;
+		       pm_subgoals = nflist} in
+	    tclTHEN
+	      (Tactics.refine refiner)
+	      (tcl_change_info ninfo) 
+	      gls
+      | _ -> 
+	  let ninfo={info with
+		       pm_partial_goal = nfgoal;
+		       pm_subgoals = nflist} in
+	    tcl_change_info ninfo gls
+
+let anon_id_base = id_of_string "__" 
+
+
+let mk_stat_or_thesis info = function  
+    This c -> c
+  | Thesis (For _ ) -> 
+      error "\"thesis for ...\" is not applicable here" 
+  | Thesis (Sub n) ->
+      begin
+	try List.assoc n info.pm_subgoals 
+	with Not_found -> error "No such part in thesis."
+      end
+  | Thesis Plain ->   
+      match info.pm_subgoals with
+	  [_,c] -> c
+	| _ -> error 
+	    "\"thesis\" is split, please specify which part you refer to."
+
+let just_tac _then cut info gls0 =
+  let items_tac gls =
+    match cut.cut_by with
+	None -> tclIDTAC gls
+      | Some items -> 
+	  let items_ = 
+	    if _then then
+	      match info.pm_last with
+		  None -> error "no previous statement to use"
+		| Some (id,_) -> (mkVar id)::items
+	    else items
+	  in prepare_goal items_ gls in
+  let method_tac gls = 
+    match cut.cut_using with
+        None ->	
+	  automation_tac gls
+      | Some tac -> 
+	  (Tacinterp.eval_tactic tac) gls in
+    justification (tclTHEN items_tac method_tac) gls0
+			
+let instr_cut mkstat _thus _then cut gls0 = 
+  let info = get_its_info gls0 in 
+  let stat = cut.cut_stat in
+  let (c_id,_) as cpl = match stat.st_label with 
+      Anonymous -> 
+	pf_get_new_id (id_of_string "_fact") gls0,false 
+    | Name id -> id,true in
+  let c_stat = mkstat info stat.st_it in
+  let thus_tac gls= 
+    if _thus then 
+      thus_tac (mkVar c_id) c_stat [] gls
+    else tclIDTAC gls in
+    tclTHENS (internal_cut c_id c_stat) 
+      [tclTHEN tcl_erase_info (just_tac _then cut info);
+       tclTHEN (set_last cpl) thus_tac] gls0
+
+
+
+(* iterated equality *)
+let _eq = Libnames.constr_of_reference (Coqlib.glob_eq)
+
+let decompose_eq id gls =
+  let typ = pf_get_hyp_typ gls id in
+  let whd =  (special_whd gls typ) in
+    match kind_of_term whd with
+	App (f,args)->
+	  if eq_constr f _eq && (Array.length args)=3 
+	  then (args.(0),
+		args.(1), 
+		args.(2)) 
+	  else error "previous step is not an equality"
+      | _ -> error "previous step is not an equality"
+	  
+let instr_rew _thus rew_side cut gls0 = 
+  let info = get_its_info gls0 in
+  let last_id = 	    
+    match info.pm_last with
+	None -> error "no previous equality"
+      | Some (id,_) -> id in
+  let typ,lhs,rhs = decompose_eq last_id gls0 in  
+  let items_tac gls =
+    match cut.cut_by with
+	None -> tclIDTAC gls
+      | Some items -> prepare_goal items gls in
+  let method_tac gls = 
+    match cut.cut_using with
+        None ->	
+	  automation_tac gls
+      | Some tac -> 
+	  (Tacinterp.eval_tactic tac) gls in
+  let just_tac gls =
+    justification (tclTHEN items_tac method_tac) gls in
+  let (c_id,_) as cpl = match cut.cut_stat.st_label with 
+      Anonymous -> 
+	pf_get_new_id (id_of_string "_eq") gls0,false 
+    | Name id -> id,true in
+  let thus_tac new_eq gls= 
+    if _thus then 
+      thus_tac (mkVar c_id) new_eq [] gls
+    else tclIDTAC gls in
+    match rew_side with 
+	Lhs ->
+	  let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in
+	    tclTHENS (internal_cut c_id new_eq) 
+	      [tclTHEN tcl_erase_info 
+		 (tclTHENS (transitivity lhs) 
+		    [just_tac;exact_check (mkVar last_id)]);
+	       tclTHEN (set_last cpl) (thus_tac new_eq)] gls0
+      | Rhs ->
+	  let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in
+	    tclTHENS (internal_cut c_id new_eq) 
+	      [tclTHEN tcl_erase_info 
+		 (tclTHENS (transitivity rhs) 
+		    [exact_check (mkVar last_id);just_tac]);
+	       tclTHEN (set_last cpl) (thus_tac new_eq)] gls0
+	      
+
+
+(* tactics for claim/focus *)
+
+let instr_claim _thus st gls0 = 
+  let info = get_its_info gls0 in  
+  let (id,_) as cpl = match st.st_label with 
+      Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false 
+    | Name id -> id,true in
+  let thus_tac gls= 
+    if _thus then 
+      thus_tac (mkVar id) st.st_it [] gls
+    else tclIDTAC gls in
+  let ninfo1 = {info with 
+		  pm_stack=
+      (if _thus then Focus_claim else Claim)::info.pm_stack;
+		  pm_partial_goal=mkMeta 1;
+	          pm_subgoals = [1,st.st_it]} in
+    tclTHENS (internal_cut id st.st_it) 
+      [tcl_change_info ninfo1;
+       tclTHEN (set_last cpl) thus_tac] gls0
+
+(* tactics for assume *)
+
+let reset_concl gls =
+  let info = get_its_info gls in
+    tcl_change_info 
+      {info with 
+	 pm_partial_goal=mkMeta 1;
+	 pm_subgoals= [1,gls.it.evar_concl]} gls
+
+
+let intro_pm id gls=
+  let info = get_its_info gls in
+    match info.pm_subgoals with
+	[(_,typ)] -> 
+	  tclTHEN (intro_mustbe_force id) reset_concl gls
+      | _ -> error "Goal is split"
+
+let push_intro_tac coerce nam gls = 
+      let (hid,_) as cpl =
+	match nam with 
+	    Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false 
+	  | Name id -> id,true in
+	tclTHENLIST 
+	  [intro_pm hid;
+	   coerce hid;
+	   set_last cpl]
+	  gls 
+
+let assume_tac hyps gls = 
+  List.fold_right 
+    (fun (Hvar st | Hprop st) -> 
+       tclTHEN 
+	 (push_intro_tac 
+	    (fun id -> 
+	       convert_hyp (id,None,st.st_it)) st.st_label))
+	 hyps tclIDTAC gls 
+
+let assume_hyps_or_theses hyps gls = 
+  List.fold_right 
+    (function 
+	 (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> 
+	   tclTHEN 
+	     (push_intro_tac 
+		(fun id -> 
+		   convert_hyp (id,None,c)) nam)
+       | Hprop {st_label=nam;st_it=Thesis (tk)} -> 
+	   tclTHEN 
+	     (push_intro_tac 
+		(fun id -> tclIDTAC) nam))
+    hyps tclIDTAC gls 
+
+let assume_st hyps gls = 
+  List.fold_right 
+    (fun st -> 
+       tclTHEN 
+	 (push_intro_tac 
+	    (fun id -> convert_hyp (id,None,st.st_it)) st.st_label))
+	 hyps tclIDTAC gls 
+
+let assume_st_letin hyps gls = 
+  List.fold_right 
+    (fun st -> 
+       tclTHEN 
+	 (push_intro_tac 
+	    (fun id -> 
+	       convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label))
+	 hyps tclIDTAC gls 
+
+(* suffices *)
+
+let free_meta info = 
+  let max_next (i,_) j  = if j <= i then succ i else j in
+  List.fold_right max_next info.pm_subgoals 1
+
+let rec metas_from n hyps = 
+  match hyps with
+      _ :: q -> n :: metas_from (succ n) q
+    | [] -> []
+ 
+let rec build_product args body =
+  match args with 
+      (Hprop st| Hvar st )::rest -> 
+	let pprod= lift 1 (build_product rest body) in
+	let lbody =
+	  match st.st_label with
+	      Anonymous -> pprod
+	    | Name id -> subst_term (mkVar id) pprod in
+	  mkProd (st.st_label, st.st_it, lbody)
+    | [] -> body 
+
+let rec build_applist prod = function
+    [] -> [],prod
+  | n::q -> 
+      let (_,typ,_) = destProd prod in
+      let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in
+	(n,typ)::ctx,head
+
+let instr_suffices _then cut gls0 = 
+  let info = get_its_info gls0 in 
+  let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in 
+  let ctx,hd = cut.cut_stat in
+  let c_stat = build_product ctx (mk_stat_or_thesis info hd) in
+  let metas = metas_from (free_meta info) ctx in
+  let c_ctx,c_head = build_applist c_stat metas in
+  let c_term = applist (mkVar c_id,List.map mkMeta metas) in  
+  let thus_tac gls= 
+    thus_tac c_term c_head c_ctx gls in
+   tclTHENS (internal_cut c_id c_stat) 
+     [tclTHENLIST 
+	 [ tcl_change_info 
+	     {info with 
+	       pm_partial_goal=mkMeta 1;
+	       pm_subgoals=[1,c_stat]};
+	   assume_tac ctx;   
+	   tcl_erase_info;
+	   just_tac _then cut info];
+      tclTHEN (set_last (c_id,false)) thus_tac] gls0
+
+(* tactics for consider/given *)
+
+let update_goal_info gls =
+  let info = get_its_info gls in
+    match info.pm_subgoals with
+	[m,_] -> tcl_change_info {info with pm_subgoals =[m,pf_concl gls]} gls
+      | _ -> error "thesis is split"
+
+let conjunction_arity id gls =
+  let typ = pf_get_hyp_typ gls id  in
+  let hd,params = decompose_app (special_whd gls typ) in
+  let env =pf_env gls in 
+    match kind_of_term hd with
+	Ind ind when is_good_inductive env ind ->
+	  let mib,oib=
+	    Inductive.lookup_mind_specif env ind in
+          let gentypes=
+            Inductive.arities_of_constructors ind (mib,oib) in
+	  let _ = if Array.length gentypes <> 1 then raise Not_found in
+	  let apptype = Term.prod_applist gentypes.(0) params in
+	  let rc,_ = Reduction.dest_prod env apptype in
+	    List.length rc
+      | _ -> raise Not_found
+
+let rec intron_then n ids ltac gls = 
+  if n<=0 then 
+    tclTHEN
+    (fun gls -> 
+       if List.exists (fun id -> occur_id [] id (pf_concl gls)) ids  then 
+	 update_goal_info gls
+       else 
+	 tclIDTAC gls)
+    (ltac ids)
+      gls
+  else  
+    let id = pf_get_new_id (id_of_string "_tmp") gls in 
+      tclTHEN 
+	(intro_mustbe_force id) 
+	(intron_then (pred n) (id::ids) ltac) gls 
+
+let pm_rename_hyp id hid gls =
+  if occur_id [] id (pf_concl gls) then
+    tclTHEN (rename_hyp id hid) update_goal_info gls
+  else
+    rename_hyp id hid gls 
+
+let rec consider_match may_intro introduced available expected gls =
+  match available,expected with 
+      [],[] ->
+	  set_last (List.hd introduced) gls
+    | _,[] -> error "last statements do not match a complete hypothesis" 
+	(* should tell which ones *)
+    | [],hyps -> 
+	if may_intro then
+	  begin
+ 	    let id = pf_get_new_id (id_of_string "_tmp") gls in
+	      tclIFTHENELSE 
+		(intro_pm id)
+		(consider_match true [] [id] hyps) 
+		(fun _ -> 
+		   error "not enough sub-hypotheses to match statements")
+		gls 
+          end 
+	else
+	  error "not enough sub-hypotheses to match statements" 
+	    (* should tell which ones *)
+    | id::rest_ids,(Hvar st | Hprop st)::rest ->
+	tclIFTHENELSE (convert_hyp (id,None,st.st_it))
+	  begin
+	    match st.st_label with 
+		Anonymous -> 
+		  consider_match may_intro ((id,false)::introduced) rest_ids rest
+	      | Name hid -> 
+		  tclTHENLIST 
+		    [pm_rename_hyp id hid;
+		     consider_match may_intro ((hid,true)::introduced) rest_ids rest]
+	  end
+	  begin
+	    (fun gls -> 
+	       let nhyps =
+		 try conjunction_arity id gls with 
+		     Not_found -> error "matching hypothesis not found" in 
+		 tclTHENLIST 
+		   [general_case_analysis (mkVar id,NoBindings);
+		    intron_then nhyps []
+		      (fun l -> consider_match may_intro introduced 
+			 (List.rev_append l rest_ids) expected)] gls)
+	  end
+	  gls
+	  
+let consider_tac c hyps gls =
+  match kind_of_term (strip_outer_cast c) with
+      Var id ->
+	consider_match false [] [id] hyps gls 
+    | _ -> 
+	let id = pf_get_new_id (id_of_string "_tmp") gls in
+	tclTHEN 
+	  (forward None (Genarg.IntroIdentifier id) c)
+ 	  (consider_match false [] [id] hyps) gls 
+	  
+
+let given_tac hyps gls =
+  consider_match true [] [] hyps gls
+
+(* tactics for take *)
+
+let rec take_tac wits gls =
+  match wits with
+      [] -> tclIDTAC gls
+    | wit::rest ->  
+	let typ = pf_type_of gls wit in  
+	  tclTHEN (thus_tac wit typ []) (take_tac rest)  gls
+
+
+(* tactics for define *)
+
+let rec build_function args body =
+  match args with 
+      st::rest -> 
+	let pfun= lift 1 (build_function rest body) in
+	let id = match st.st_label with
+	    Anonymous -> assert false
+	  | Name id -> id in
+	  mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun)
+    | [] -> body 
+
+let define_tac id args body gls =
+  let t = build_function args body in
+    letin_tac true (Name id) t Tacexpr.nowhere gls
+
+(* tactics for reconsider *)
+
+let cast_tac id_or_thesis typ gls = 
+  let info = get_its_info gls in
+  match id_or_thesis with
+      This id ->
+	let (_,body,_) = pf_get_hyp gls id in
+	  convert_hyp (id,body,typ) gls
+    | Thesis (For _ ) -> 
+	error "\"thesis for ...\" is not applicable here" 
+    | Thesis (Sub n) ->
+	begin
+	  let old_typ = 
+	    try List.assoc n info.pm_subgoals 
+	    with Not_found -> error "No such part in thesis." in
+	  if is_conv_leq (pf_env gls) (sig_sig gls) typ old_typ then
+	    let new_sg = List.merge  
+	      (fun (n,_) (p,_) -> Pervasives.compare n p) 
+	      [n,typ] (List.remove_assoc n info.pm_subgoals) in
+	      tcl_change_info {info with pm_subgoals=new_sg} gls
+	  else 
+	    error "not convertible"
+	end
+    | Thesis Plain ->   
+	match info.pm_subgoals with 
+	    [m,c] -> 
+	      tclTHEN 
+		(convert_concl typ DEFAULTcast) 
+	        (tcl_change_info {info with pm_subgoals= [m,typ]}) gls
+	  | _ -> error 
+	      "\"thesis\" is split, please specify which part you refer to."
+  
+      
+(* per cases *)
+
+let start_tree env ind = 
+  let constrs = (snd (Inductive.lookup_mind_specif env ind)).mind_consnames in
+    Split (Idset.empty,ind,Array.map (fun _ -> None) constrs)
+
+let build_per_info etype casee gls = 
+  let concl=get_thesis gls in
+  let env=pf_env gls in
+  let ctyp=pf_type_of gls casee in
+  let is_dep = dependent casee concl in 
+  let hd,args = decompose_app (special_whd gls ctyp) in
+  let ind = 
+    try
+      destInd hd 
+    with _ -> 
+      error "Case analysis must be done on an inductive object" in
+  let nparams =
+    let mind = fst (Global.lookup_inductive ind) in
+     match etype with
+	 ET_Induction -> mind.mind_nparams_rec
+       | _ -> mind.mind_nparams in
+  let params,real_args = list_chop nparams args in
+  let abstract_obj body c = 
+    let typ=pf_type_of gls c in 
+      lambda_create env (typ,subst_term c body) in
+  let pred= List.fold_left abstract_obj    
+    (lambda_create env (ctyp,subst_term casee concl)) real_args in
+    is_dep,
+  {per_casee=casee;
+   per_ctype=ctyp;
+   per_ind=ind;
+   per_pred=pred;
+   per_args=real_args;
+   per_params=params;
+   per_nparams=nparams}
+
+let per_tac etype casee gls=
+  let env=pf_env gls in
+  let info = get_its_info gls in
+    match casee with
+	Real c ->
+	  let is_dep,per_info = build_per_info etype c gls in
+	  let ek = 
+	    if is_dep then
+	      EK_dep (start_tree env per_info.per_ind)
+	    else EK_unknown in
+	    tcl_change_info 
+	      {info with 
+		 pm_stack=
+		  Per(etype,per_info,ek,[])::info.pm_stack} gls
+      | Virtual cut ->
+	  assert (cut.cut_stat.st_label=Anonymous);
+	  let id = pf_get_new_id (id_of_string "_matched") gls in
+	  let c = mkVar id in
+	  let modified_cut = 
+	    {cut with cut_stat={cut.cut_stat with st_label=Name id}} in
+	    tclTHEN 
+	      (instr_cut (fun _ c -> c) false false modified_cut)
+	      (fun gls0 ->
+		 let is_dep,per_info = build_per_info etype c gls0 in
+		   assert (not is_dep);
+		   tcl_change_info 
+		     {info with pm_stack=
+			 Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0)
+	      gls
+
+(* suppose *)
+
+let register_nodep_subcase id= function
+    Per(et,pi,ek,clauses)::s ->
+      begin
+	match ek with
+	    EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s
+	  | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s
+	  | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"."
+      end
+  | _ -> anomaly "wrong stack state"
+
+let suppose_tac hyps gls0 = 
+  let info = get_its_info gls0 in
+  let thesis = get_thesis gls0 in
+  let id = pf_get_new_id (id_of_string "_subcase") gls0 in
+  let clause = build_product hyps thesis in
+  let ninfo1 = {info with 
+		  pm_stack=Suppose_case::info.pm_stack;
+		  pm_partial_goal=mkMeta 1;
+		  pm_subgoals = [1,clause]} in
+  let old_clauses,stack = register_nodep_subcase id info.pm_stack in
+  let ninfo2 = {info with 
+		  pm_stack=stack} in
+    tclTHENS (internal_cut id clause) 
+      [tclTHENLIST [tcl_change_info ninfo1;
+		    assume_tac hyps;
+		    clear old_clauses];
+       tcl_change_info ninfo2] gls0
+
+(* suppose it is ... *) 
+
+(* pattern matching compiling *)
+
+let rec nb_prod_after n c=
+  match kind_of_term c with
+    | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else 
+	1+(nb_prod_after 0 b)
+    | _ -> 0
+
+let constructor_arities env ind =
+  let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
+  let constr_types = Inductiveops.arities_of_constructors env ind in 
+  let hyp = nb_prod_after nparams in	
+    Array.map hyp constr_types
+
+let rec n_push rest ids n = 
+  if n<=0 then Pop rest else Push (ids,n_push rest ids (pred n)) 
+
+let explode_branches ids env ind rest=
+  Array.map (fun n -> Some (Idset.empty,n_push rest ids n)) (constructor_arities env ind)
+
+let rec tree_of_pats env ((id,_) as cpl) pats =
+  match pats with 
+      [] -> End_of_branch cpl
+    | args::stack ->
+	match args with
+	    [] -> Pop (tree_of_pats env cpl stack)
+	  | patt :: rest_args ->
+	      match patt with
+		  PatVar (_,v) -> 
+		    Push (Idset.singleton id,
+			  tree_of_pats env cpl (rest_args::stack))
+		|  PatCstr (_,(ind,cnum),args,nam) ->
+		     let _,mind = Inductive.lookup_mind_specif env ind in
+		     let br= Array.map (fun _ -> None) mind.mind_consnames in
+		       br.(pred cnum) <- 
+			 Some (Idset.singleton id,
+			       tree_of_pats env cpl (args::rest_args::stack));
+		       Split(Idset.empty,ind,br)
+
+let rec add_branch env ((id,_) as cpl) pats tree=
+  match pats with 
+      [] -> 
+	begin
+	  match tree with
+	      End_of_branch cpl0 -> End_of_branch cpl0 
+		(* this ensures precedence *) 
+	    | _ -> anomaly "tree is expected to end here"
+	end
+    | args::stack ->
+	match args with 
+	    [] ->
+	      begin
+		match tree with 
+		    Pop t -> Pop (add_branch env cpl stack t)
+		  | _ -> anomaly "we should pop here" 
+	      end
+	  | patt :: rest_args ->
+	      match patt with
+		  PatVar (_,v) ->
+		    begin
+		      match tree with 
+			  Push (ids,t) -> 
+			    Push (Idset.add id ids,
+				  add_branch env cpl (rest_args::stack) t)
+			| Split (ids,ind,br) ->
+			    Split (Idset.add id ids,
+				   ind,array_map2 
+				     (append_branch env cpl 1 
+					(rest_args::stack)) 
+				     (constructor_arities env ind) br)
+			| _ -> anomaly "No pop/stop expected here"  
+		    end
+		| PatCstr (_,(ind,cnum),args,nam) ->
+		    match tree with
+			Push (ids,t) ->
+			  let br = explode_branches ids env ind t in
+			  let _ =
+			    br.(pred cnum)<- 
+			      option_map
+			      (fun (ids,tree) -> 
+				 Idset.add id ids,
+				 add_branch env cpl 
+				   (args::rest_args::stack) tree) 
+			      br.(pred cnum) in
+			    Split (ids,ind,br)
+		      | Split (ids,ind0,br0) ->
+			  if (ind <> ind0) then error
+			    (* this can happen with coercions *)
+	                      "Case pattern belongs to wrong inductive type";
+			  let br=Array.copy br0 in
+			  let ca = constructor_arities env ind in
+			  let _= br.(pred cnum)<-
+			    append_branch env cpl 0 (args::rest_args::stack) 
+			    ca.(pred cnum) br.(pred cnum) in 
+			    Split (ids,ind,br)
+		      | _ -> anomaly "No pop/stop expected here"
+and append_branch env ((id,_) as cpl) depth pats nargs = function
+    Some (ids,tree) -> 
+      Some (Idset.add id ids,append_tree env cpl depth pats tree)
+  | None ->
+      Some (* (n_push (tree_of_pats env cpl pats) 
+	      (Idset.singleton id) nargs) *)
+	   (Idset.singleton id,tree_of_pats env cpl pats)
+and append_tree env ((id,_) as cpl) depth pats tree =
+  if depth<=0 then add_branch env cpl pats tree
+  else match tree with
+      Pop t -> Pop (append_tree env cpl (pred depth) pats t)
+    | Push (ids,t) -> Push (Idset.add id ids,
+				   append_tree env cpl depth pats t)
+    | End_of_branch _ -> anomaly "Premature end of branch"
+    | Split (ids,ind,branches) -> 
+	Split (Idset.add id ids,ind,
+	       array_map2 
+		 (append_branch env cpl (succ depth) pats) 
+		 (constructor_arities env ind)
+		 branches)
+
+(* suppose it is *)
+
+let rec st_assoc id = function
+    [] -> raise Not_found
+  | st::_ when st.st_label = id  -> st.st_it
+  | _ :: rest -> st_assoc id rest
+
+let thesis_for obj typ per_info env=
+  let rc,hd1=decompose_prod typ in
+  let cind,all_args=decompose_app typ in
+  let ind = destInd cind in
+  let _ = if ind <> per_info.per_ind then
+    errorlabstrm "thesis_for" 
+      ((Printer.pr_constr_env env obj) ++ spc () ++ 
+	 str "cannot give an induction hypothesis (wrong inductive type)") in  
+  let params,args = list_chop per_info.per_nparams all_args in
+  let _ = if not (List.for_all2 eq_constr params per_info.per_params) then
+    errorlabstrm "thesis_for" 
+      ((Printer.pr_constr_env env obj) ++ spc () ++ 
+	 str "cannot give an induction hypothesis (wrong parameters)") in
+  let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in
+    compose_prod rc (whd_beta hd2)
+
+let rec build_product_dep pat_info per_info args body gls =
+  match args with 
+      (Hprop {st_label=nam;st_it=This c} 
+      | Hvar {st_label=nam;st_it=c})::rest -> 
+	let pprod= 
+	  lift 1 (build_product_dep pat_info per_info rest body gls) in
+	let lbody =
+	  match nam with
+	      Anonymous -> body
+	    | Name id -> subst_var id pprod in
+	  mkProd (nam,c,lbody)
+    | Hprop ({st_it=Thesis tk} as st)::rest ->
+	let pprod= 
+	  lift 1 (build_product_dep pat_info per_info rest body gls) in
+	let lbody =
+	  match st.st_label with
+	      Anonymous -> body
+	    | Name id -> subst_var id pprod in
+	let ptyp =
+	  match tk with
+	      For id ->
+		let obj = mkVar id in
+		let typ = 
+		  try st_assoc (Name id) pat_info.pat_vars 
+		  with Not_found -> 
+		    snd (st_assoc (Name id) pat_info.pat_aliases) in
+		  thesis_for obj typ per_info (pf_env gls)
+	    | Plain -> get_thesis gls 
+	    | Sub n -> anomaly "Subthesis in cases" in
+	  mkProd (st.st_label,ptyp,lbody)
+    | [] -> body 
+
+let build_dep_clause params pat_info per_info hyps gls =
+  let concl=
+    thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in
+  let open_clause =
+    build_product_dep pat_info per_info hyps concl gls in
+  let prod_one st body =
+    match st.st_label with
+	Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body)
+      | Name id -> mkNamedProd id st.st_it (lift 1 body) in
+  let let_one_in st body =
+    match st.st_label with
+	Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body)
+      | Name id -> 
+	  mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in
+  let aliased_clause = 
+    List.fold_right let_one_in pat_info.pat_aliases open_clause in
+    List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause
+
+let rec register_dep_subcase id env per_info pat = function
+    EK_nodep -> error  "Only \"suppose it is\" can be used here."
+  | EK_unknown -> 
+      register_dep_subcase id env per_info pat
+	(EK_dep (start_tree env per_info.per_ind))
+  | EK_dep tree -> EK_dep (add_branch env id [[pat]] tree)
+  
+let case_tac params pat_info hyps gls0 =
+  let info = get_its_info gls0 in
+  let id = pf_get_new_id (id_of_string "_subcase") gls0 in
+  let et,per_info,ek,old_clauses,rest =
+    match info.pm_stack with
+	Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) 
+      | _ -> anomaly "wrong place for cases" in
+  let clause = build_dep_clause params pat_info per_info hyps gls0 in
+  let ninfo1 = {info with 
+		  pm_stack=Suppose_case::info.pm_stack;
+		  pm_partial_goal=mkMeta 1;
+		  pm_subgoals = [1,clause]} in
+  let nek = 
+    register_dep_subcase (id,List.length hyps) (pf_env gls0) per_info 
+      pat_info.pat_pat ek in  
+  let ninfo2 = {info with 
+		  pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in
+    tclTHENS (internal_cut id clause) 
+      [tclTHENLIST 
+	 [tcl_change_info ninfo1; 
+	  assume_st (params@pat_info.pat_vars);
+	  assume_st_letin pat_info.pat_aliases;
+	  assume_hyps_or_theses hyps;
+	  clear old_clauses];
+       tcl_change_info ninfo2] gls0
+
+(* end cases *)
+
+type instance_stack =
+    (constr option*bool*(constr list) list) list
+
+let initial_instance_stack ids =
+  List.map (fun id -> id,[None,false,[]]) ids
+
+let push_one_arg arg = function 
+    [] -> anomaly "impossible"
+  | (head,is_rec,args) :: ctx -> 
+      ((head,is_rec,(arg::args)) :: ctx)
+
+let push_arg arg stacks =
+  List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks
+  
+
+let push_one_head c is_rec ids (id,stack) = 
+  let head = if Idset.mem id ids then Some c else None in
+    id,(head,is_rec,[]) :: stack
+
+let push_head c is_rec ids stacks =
+  List.map (push_one_head c is_rec ids) stacks
+
+let pop_one rec_flag (id,stack) =  
+  let nstack=
+    match stack with
+	[] -> anomaly "impossible"
+      | [c] as l -> l
+      | (Some head,is_rec,args)::(head0,is_rec0,args0)::ctx ->
+	  let arg = applist (head,(List.rev args)) in
+	    rec_flag:= !rec_flag || is_rec;
+	    (head0,is_rec0,(arg::args0))::ctx
+     | (None,is_rec,args)::(head0,is_rec0,args0)::ctx ->
+	 rec_flag:= !rec_flag || is_rec;
+	 (head0,is_rec0,(args@args0))::ctx
+  in id,nstack
+
+let pop_stacks stacks =
+  let rec_flag= ref false in 
+  let nstacks = List.map (pop_one rec_flag) stacks in
+    !rec_flag , nstacks
+
+let patvar_base = id_of_string "__"
+
+let test_fun (str:string) = ()
+
+let hrec_for obj_id fix_id per_info gls=
+  let obj=mkVar obj_id in
+  let typ=pf_get_hyp_typ gls obj_id in
+  let rc,hd1=decompose_prod typ in
+  let cind,all_args=decompose_app typ in
+    match kind_of_term cind with
+	Ind ind when ind=per_info.per_ind ->
+	  let params,args= list_chop per_info.per_nparams all_args in 
+	    if try 
+	      (List.for_all2 eq_constr params per_info.per_params)
+	    with Invalid_argument _ -> false then
+	      let hd2 = applist (mkVar fix_id,args@[obj]) in
+		Some (compose_lam rc (whd_beta hd2))
+	    else None
+      | _ -> None
+
+
+(* custom elim performs the case analysis of hypothesis id from the local 
+context, 
+
+- generalizing hypotheses below id
+- computing the elimination predicate (abstract inductive predicate) 
+- build case analysis term 
+- generalize rec_calls (use wf_paths)
+- vector of introduced identifiers per branch 
+
+match id in t return p with
+ C1 ... => ?1 
+|C2 ... => ?2
+...
+end*)
+
+
+    
+
+
+
+
+
+
+let rec execute_cases at_top fix_name per_info kont0 stacks tree gls = 
+  match tree with
+      Pop t ->  
+	let is_rec,nstacks =  pop_stacks stacks in
+	  if is_rec then
+	    let _ = test_fun "is_rec=true" in
+	     let c_id = pf_get_new_id (id_of_string "_hrec") gls in
+	       tclTHEN 
+		 (intro_mustbe_force c_id)
+		 (execute_cases false fix_name per_info kont0 nstacks t) gls
+	  else
+	    execute_cases false fix_name per_info kont0 nstacks t gls
+    | Push (_,t) -> 
+	let id = pf_get_new_id patvar_base gls in
+	let nstacks = push_arg (mkVar id) stacks in
+	let kont = execute_cases false fix_name per_info kont0 nstacks t in
+	  tclTHEN
+	    (intro_mustbe_force id)
+	    begin
+	      match fix_name with
+		  Anonymous -> kont
+		| Name fix_id ->  
+		    (fun gls -> 
+		       if at_top then
+			 kont gls
+		       else
+			 match hrec_for id fix_id per_info gls with
+			     None -> kont gls
+			   | Some c_obj ->
+			       let c_id = 
+				 pf_get_new_id (id_of_string "_hrec") gls in
+				 tclTHENLIST 
+				   [generalize [c_obj];
+				    intro_mustbe_force c_id;
+				    kont] gls)
+	    end gls
+    | Split(ids,ind,br) ->
+	let (_,typ,_)=destProd (pf_concl gls) in
+	let hd,args=decompose_app (special_whd gls typ) in
+	let _ = assert (ind = destInd hd) in
+	let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
+	let params = list_firstn nparams args in
+	let constr i =applist (mkConstruct(ind,succ i),params) in
+	let next_tac is_rec i = function
+	    Some (sub_ids,tree) ->
+	      let br_stacks =
+		List.filter (fun (id,_) -> Idset.mem id sub_ids) stacks in
+	      let p_stacks = 
+		push_head (constr i) is_rec ids br_stacks in
+		execute_cases false fix_name per_info kont0 p_stacks tree 
+	  | None -> 
+	      msgnl (str "Warning : missing case");
+	      kont0 (mkMeta 1) 
+	in
+	let id = pf_get_new_id patvar_base gls in
+	let kont is_rec = 			
+	  tclTHENSV
+	    (general_case_analysis (mkVar id,NoBindings))
+	    (Array.mapi (next_tac is_rec) br) in
+	  tclTHEN 
+	    (intro_mustbe_force id)
+	    begin
+	      match fix_name with
+		  Anonymous -> kont false
+		| Name fix_id ->  
+		    (fun gls -> 
+		       if at_top then
+			 kont false gls
+		       else
+			 match hrec_for id fix_id per_info gls with
+			     None -> kont false gls
+			   | Some c_obj ->
+			       tclTHENLIST 
+				 [generalize [c_obj];
+				  kont true] gls)
+	    end gls
+    | End_of_branch (id,nhyps) -> 
+	  match List.assoc id stacks with
+	      [None,_,args] -> 
+		let metas = list_tabulate (fun n -> mkMeta (succ n)) nhyps in
+		  kont0 (applist (mkVar id,List.rev_append args metas)) gls
+	    | _ -> anomaly "wrong stack size"
+
+let end_tac et2 gls =
+  let info = get_its_info gls in
+  let et1,pi,ek,clauses = 
+    match info.pm_stack with
+	Suppose_case::_ -> 
+	  anomaly "This case should already be trapped"
+      | Claim::_ ->  
+	  error "\"end claim\" expected."
+      | Focus_claim::_ ->
+	  error "\"end focus\" expected."
+      | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) 
+      | [] -> 
+	  anomaly "This case should already be trapped" in
+  let et = 
+    if et1 <> et2 then
+      match et1 with 
+	  ET_Case_analysis -> 
+	    error "\"end cases\" expected."
+	| ET_Induction ->
+	    error "\"end induction\" expected."
+    else et1 in
+    tclTHEN 
+      tcl_erase_info
+      begin
+	match et,ek with
+	    _,EK_unknown -> 
+	      tclSOLVE [simplest_elim pi.per_casee]	
+	  | ET_Case_analysis,EK_nodep ->
+	      tclTHEN 
+		(general_case_analysis (pi.per_casee,NoBindings))
+		(default_justification (List.map mkVar clauses))
+	  | ET_Induction,EK_nodep ->
+	      tclTHENLIST
+		[generalize (pi.per_args@[pi.per_casee]); 
+		 simple_induct (AnonHyp (succ (List.length pi.per_args)));
+		 default_justification (List.map mkVar clauses)]
+	  | ET_Case_analysis,EK_dep tree ->
+	      tclTHENLIST 
+		[generalize (pi.per_args@[pi.per_casee]);
+		 execute_cases true Anonymous pi 
+		   (fun c -> tclTHENLIST 
+		      [refine c;
+		       clear clauses;
+		       justification assumption])
+		   (initial_instance_stack clauses) tree]	
+	  | ET_Induction,EK_dep tree ->
+	      tclTHEN (generalize (pi.per_args@[pi.per_casee]))
+		begin
+		  fun gls0 -> 
+		    let fix_id = pf_get_new_id (id_of_string "_fix") gls0 in
+		      tclTHEN 
+			(fix (Some fix_id) (succ (List.length pi.per_args))) 
+			(execute_cases true (Name fix_id) pi 
+			   (fun c ->
+			      tclTHENLIST 
+				[clear [fix_id];
+				 refine c;
+				 clear clauses;
+				 justification assumption
+				 (* justification automation_tac *)])
+			   (initial_instance_stack clauses) tree) gls0
+		end	
+      end gls
+
+(* escape *)
+
+let rec abstract_metas n avoid head = function
+    [] -> 1,head,[]
+  | (meta,typ)::rest -> 
+      let id = Nameops.next_ident_away (id_of_string "_sbgl") avoid in
+      let p,term,args = abstract_metas (succ n) (id::avoid) head rest in 
+	succ p,mkLambda(Name id,typ,subst_meta [meta,mkRel p] term),
+      (mkMeta n)::args 
+
+let build_refining_context gls =
+  let info = get_its_info gls in
+  let avoid=pf_ids_of_hyps gls in
+  let _,fn,args=abstract_metas 1 avoid info.pm_partial_goal info.pm_subgoals in
+    applist (fn,args)
+    
+let escape_command pts =
+  let pts1 = nth_unproven 1 pts in
+  let gls = top_goal_of_pftreestate pts1 in
+  let term = build_refining_context gls in
+  let tac = tclTHEN 
+    (abstract_operation (Proof_instr (true,{emph=0;instr=Pescape})) tcl_erase_info)
+    (Tactics.refine term) in
+    traverse 1 (solve_pftreestate tac pts1)
+
+(* General instruction engine *)
+
+let rec do_proof_instr_gen _thus _then instr = 
+  match instr with 
+      Pthus i -> 
+	assert (not _thus);
+	do_proof_instr_gen true _then i
+    | Pthen i -> 	
+	assert (not _then);
+	do_proof_instr_gen _thus true i
+    | Phence i -> 
+	assert (not (_then || _thus));
+	do_proof_instr_gen true true i
+    | Pcut c ->
+	instr_cut mk_stat_or_thesis _thus _then c
+    | Psuffices c ->
+	instr_suffices _then c 
+    | Prew (s,c) ->
+	assert (not _then);
+	instr_rew _thus s c
+    | Pconsider (c,hyps)    -> consider_tac c hyps
+    | Pgiven hyps            -> given_tac hyps
+    | Passume hyps           -> assume_tac hyps
+    | Plet hyps              -> assume_tac hyps
+    | Pclaim st              -> instr_claim false st 
+    | Pfocus st              -> instr_claim true st
+    | Ptake witl             -> take_tac witl
+    | Pdefine (id,args,body) -> define_tac id args body
+    | Pcast (id,typ)         -> cast_tac id typ 
+    | Pper (et,cs)           -> per_tac et cs 
+    | Psuppose hyps      -> suppose_tac hyps
+    | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps
+    | Pend (B_elim et) -> end_tac et
+    | Pend _ | Pescape -> anomaly "Not applicable"
+ 
+let eval_instr {instr=instr} =
+  do_proof_instr_gen false false instr   
+
+let rec preprocess pts instr =
+  match instr with
+    Phence i |Pthus i | Pthen i -> preprocess pts i
+  | Psuffices _ | Pcut _ |  Passume _ | Plet _ | Pclaim _ | Pfocus _ 
+  | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ 
+  | Pdefine (_,_,_) | Pper _ | Prew _ ->
+      check_not_per pts;
+      true,pts
+  | Pescape -> 
+      check_not_per pts;
+      false,pts
+  | Pcase _ | Psuppose _ | Pend (B_elim _) -> 
+      true,close_previous_case pts
+  | Pend bt -> 
+      false,close_block bt pts 
+      
+let rec postprocess pts instr = 
+  match instr with
+      Phence i | Pthus i | Pthen i -> postprocess pts i
+    | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_)
+    | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> pts
+    | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ -> nth_unproven 1 pts
+    | Pescape -> escape_command pts
+    | Pend (B_elim ET_Induction) ->
+  	begin
+	  let pf = proof_of_pftreestate pts in
+	  let (pfterm,_) = extract_open_pftreestate pts in
+	  let env =  Evd.evar_env (goal_of_proof pf) in
+	    try 
+	      Inductiveops.control_only_guard env pfterm;
+	      goto_current_focus_or_top (mark_as_done pts)
+ 	    with 
+		Type_errors.TypeError(env,
+				      Type_errors.IllFormedRecBody(_,_,_)) ->
+		  anomaly "\"end induction\" generated an ill-formed fixpoint"
+	end
+    | Pend _ -> 
+	goto_current_focus_or_top (mark_as_done pts)
+
+let do_instr raw_instr pts =
+  let has_tactic,pts1 = preprocess pts raw_instr.instr in
+  let pts2 = 
+    if has_tactic then
+      let gl = nth_goal_of_pftreestate 1 pts1 in
+      let env=  pf_env gl in
+      let sigma= project gl in
+      let ist = {ltacvars = ([],[]); ltacrecvars = []; 
+		 gsigma = sigma; genv = env} in
+      let glob_instr = intern_proof_instr ist raw_instr in
+      let instr = 
+	interp_proof_instr (get_its_info gl) sigma env glob_instr in
+      let lock_focus = is_focussing_instr instr.instr in
+      let marker= Proof_instr (lock_focus,instr) in
+	solve_nth_pftreestate 1 
+	  (abstract_operation marker (eval_instr instr)) pts1
+    else pts1 in
+      postprocess pts2 raw_instr.instr
+
+let proof_instr raw_instr =
+  Pfedit.mutate (do_instr raw_instr)
+
+(*
+
+(* STUFF FOR ITERATED RELATIONS *)
+let decompose_bin_app t= 
+  let hd,args = destApp 
+
+let identify_transitivity_lemma c =
+  let varx,tx,c1 = destProd c in
+  let vary,ty,c2 = destProd (pop c1) in
+  let varz,tz,c3 = destProd (pop c2) in
+  let _,p1,c4 = destProd (pop c3) in
+  let _,lp2,lp3 = destProd (pop c4) in
+  let p2=pop lp2 in
+  let p3=pop lp3 in
+*)
+    
diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli
new file mode 100644
index 00000000..642f2755
--- /dev/null
+++ b/tactics/decl_proof_instr.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        *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Refiner
+open Names
+open Term
+open Tacmach
+
+val go_to_proof_mode: unit -> unit
+val return_from_tactic_mode: unit -> unit
+
+val register_automation_tac: tactic -> unit
+
+val automation_tac : tactic
+
+val daimon_subtree: pftreestate -> pftreestate
+
+val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate
+val proof_instr: Decl_expr.raw_proof_instr -> unit
+
+val tcl_change_info : Decl_mode.pm_info -> tactic
+
+val mark_proof_tree_as_done : Proof_type.proof_tree -> Proof_type.proof_tree
+
+val mark_as_done : pftreestate -> pftreestate
+
+val execute_cases : bool ->
+    Names.name ->
+    Decl_mode.per_info ->
+    (Term.constr -> Proof_type.tactic) ->
+    (Names.Idset.elt * (Term.constr option * bool * Term.constr list) list) 
+      list ->
+    Decl_mode.split_tree -> Proof_type.tactic
+
+val tree_of_pats :
+    Environ.env ->
+    Names.Idset.elt * int ->
+    Rawterm.cases_pattern list list -> Decl_mode.split_tree
+val add_branch :
+    Environ.env ->
+    Names.Idset.elt * int ->
+    Rawterm.cases_pattern list list ->
+    Decl_mode.split_tree -> Decl_mode.split_tree
+val append_branch :
+    Environ.env ->
+    Names.Idset.elt * int ->
+    int ->
+    Rawterm.cases_pattern list list ->
+    int ->
+    (Names.Idset.t * Decl_mode.split_tree) option ->
+    (Names.Idset.t * Decl_mode.split_tree) option
+
+val append_tree :   Environ.env ->
+    Names.Idset.elt * int ->
+    int ->
+    Rawterm.cases_pattern list list ->
+    Decl_mode.split_tree -> Decl_mode.split_tree
+
+val build_dep_clause :   Term.types Decl_expr.statement list ->
+    Decl_expr.proof_pattern ->
+    Decl_mode.per_info ->
+    (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis)
+    Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types
+
+val register_dep_subcase :    
+    Names.identifier * int ->
+    Environ.env ->
+    Decl_mode.per_info ->
+    Rawterm.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind
+
+val thesis_for :     Term.constr ->
+    Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr
+
+val close_previous_case : pftreestate -> pftreestate
+
+val test_fun : string -> unit
+
+
+val pop_stacks :
+  (Names.identifier * 
+     (Term.constr option * bool * Term.constr list) list) list ->
+  bool * 
+    (Names.identifier * 
+       (Term.constr option * bool * Term.constr list) list) list
+
+
+val push_head :   Term.constr ->
+  bool ->
+  Names.Idset.t ->
+  (Names.identifier * 
+     (Term.constr option * bool * Term.constr list) list) list ->
+  (Names.identifier * 
+     (Term.constr option * bool * Term.constr list) list) list
+
+val push_arg : Term.constr ->
+  (Names.identifier * 
+     (Term.constr option * bool * Term.constr list) list) list ->
+  (Names.identifier * 
+     (Term.constr option * bool * Term.constr list) list) list
+
+val hrec_for: 
+    Names.identifier ->
+    Names.identifier ->
+    Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> Term.constr option
+
+val consider_match :
+   bool ->
+    (Names.Idset.elt*bool) list ->
+    Names.Idset.elt list ->
+    (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list ->
+    Proof_type.tactic
+
+val thus_tac : constr -> constr -> (metavariable * types) list ->
+  tactic
+
+val build_applist :    Term.types ->
+    Term.metavariable list ->
+    (Term.metavariable * Term.types) list * Term.types
+
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
index fb672d0b..f82b1f82 100644
--- a/tactics/dhyp.ml
+++ b/tactics/dhyp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dhyp.ml,v 1.30.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+(* $Id: dhyp.ml 8878 2006-05-30 16:44:25Z herbelin $ *)
 
 (* Chet's comments about this tactic :
  
@@ -129,7 +129,6 @@ open Libobject
 open Library
 open Pattern
 open Matching
-open Ast
 open Pcoq
 open Tacexpr
 open Libnames
@@ -266,11 +265,10 @@ let match_dpat dp cls gls =
     | ({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
+          | None -> List.map (fun id -> (([],id),InHyp)) (pf_ids_of_hyps gls) in
         if not
           (List.for_all
-            (fun (id,_,(hl,_)) ->
+            (fun ((_,id),hl) ->
               let cltyp = pf_get_hyp_typ gls id in
               let cl = pf_concl gls in
               (hl=InHyp) &
@@ -299,7 +297,7 @@ let applyDestructor cls discard dd gls =
   let tacl =
     List.map (fun cl ->
       match cl, dd.d_code with
-        | Some (id,_,_), (Some x, tac) -> 
+        | Some ((_,id),_), (Some x, tac) -> 
 	    let arg =
               ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in
             TacLetIn ([(dummy_loc, x), None, arg], tac)
@@ -310,7 +308,7 @@ let applyDestructor cls discard dd gls =
   let discard_0 =
     List.map (fun cl ->
       match (cl,dd.d_pat) with
-        | (Some (id,_,_),HypLocation(discardable,_,_)) ->
+        | (Some ((_,id),_),HypLocation(discardable,_,_)) ->
             if discard & discardable then thin [id] else tclIDTAC
         | (None,ConclLocation _) -> tclIDTAC
         | _ -> error "ApplyDestructor" ) cll in
@@ -358,7 +356,7 @@ let rec search n =
      (tclTHEN  
         (Tacticals.tryAllClauses 
            (function 
-              | Some (id,_,_) -> (dHyp id)
+              | Some ((_,id),_) -> (dHyp id)
               | None    ->  dConcl ))
         (search (n-1)))]
     
diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli
index a0cef679..630092f0 100644
--- a/tactics/dhyp.mli
+++ b/tactics/dhyp.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: dhyp.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Names
diff --git a/tactics/dn.ml b/tactics/dn.ml
index 55116831..ab908ff9 100644
--- a/tactics/dn.ml
+++ b/tactics/dn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: dn.ml,v 1.5.16.1 2004/07/16 19:30:52 herbelin Exp $ *)
+(* $Id: dn.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 (* This file implements the basic structure of what Chet called
    ``discrimination nets''. If my understanding is right, it serves
diff --git a/tactics/dn.mli b/tactics/dn.mli
index a54007d8..f8efd053 100644
--- a/tactics/dn.mli
+++ b/tactics/dn.mli
@@ -6,7 +6,7 @@
 (*         *       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*)
+(*i $Id: dn.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Discrimination nets. *)
 
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index 31d79948..6da0dd49 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -8,7 +8,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eauto.ml4,v 1.11.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+(* $Id: eauto.ml4 9277 2006-10-25 13:02:22Z herbelin $ *)
 
 open Pp
 open Util
@@ -32,7 +32,7 @@ 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
+     tclTHEN (Clenvtac.unify t1) (exact_check c) gl
   else exact_check c gl
 
 let assumption id = e_give_exact (mkVar id)
@@ -40,19 +40,19 @@ let assumption id = e_give_exact (mkVar id)
 let e_assumption gl = 
   tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl
 
+TACTIC EXTEND eassumption
+| [ "eassumption" ] -> [ e_assumption ]
+END
+
 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 t = pf_hnf_constr gl (pf_type_of gl c) in 
+  let clause = make_clenv_binding_apply gl None (c,t) lbind in 
+  Clenvtac.e_res_pf clause gl
 
 let e_resolve_constr c gls = e_resolve_with_bindings_tac (c,NoBindings) gls
 			     
-(* V8 TACTIC EXTEND eexact
+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
@@ -62,11 +62,8 @@ let registered_e_assumption 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 ]
+  [ "eapply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ]
 END
 
 let vernac_e_resolve_constr c = h_eapply (c,NoBindings)
@@ -75,8 +72,7 @@ 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
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames 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 
@@ -87,7 +83,8 @@ let e_constructor_tac boundopt i lbind gl =
   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
+  (tclTHENLIST [convert_concl_no_check redcl DEFAULTcast
+; intros; apply_tac]) gl
 
 let e_one_constructor i = e_constructor_tac None i
 
@@ -107,33 +104,30 @@ 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) ] 
+  [ "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_map Tacinterp.eval_tactic t) ] 
       END
 
 TACTIC EXTEND eleft
-  [ "ELeft" "with" bindings(l) ] -> [e_left l]
-  | [ "ELeft"] -> [e_left NoBindings]
+  [ "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]
+  [ "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]
+  [ "esplit" "with" bindings(l) ] -> [e_split l]
+| [ "esplit"] -> [e_split NoBindings]
 END
 
 
 TACTIC EXTEND eexists
-  [ "EExists" bindings(l) ] -> [e_split l]
+  [ "eexists" bindings(l) ] -> [e_split l]
 END
 
 
@@ -155,36 +149,17 @@ let rec prolog l n gl =
 let prolog_tac l n gl =
   let n =
     match n with
-      |  Genarg.ArgArg n -> n
+      |  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
+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
 
 (***************************************************************************)
@@ -192,8 +167,7 @@ open Auto
 (***************************************************************************)
 
 let unify_e_resolve  (c,clenv) gls = 
-  let (wc,kONT) = startWalk gls in
-  let clenv' = connect_clenv wc clenv in
+  let clenv' = connect_clenv gls clenv in
   let _ = clenv_unique_resolver false clenv' gls in
   vernac_e_resolve_constr c gls
 
@@ -219,7 +193,7 @@ and e_my_find_search db_list local_db hdc concl =
       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) -> 
+    fun {pri=b; pat = p; code=t} -> 
       (b, 
        let tac =
 	 match t with
@@ -229,7 +203,7 @@ and e_my_find_search db_list local_db hdc concl =
 	   | 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
+	   | Unfold_nth c -> unfold_in_concl [[],c]
 	   | Extern tacast -> conclPattern concl 
 	       (out_some p) tacast
        in 
@@ -309,7 +283,7 @@ module SearchProblem = struct
 	  filter_tactics s.tacres
 	    (List.map 
 	       (fun id -> (e_give_exact_constr (mkVar id),
-			   (str "Exact" ++ spc () ++ pr_id id)))
+			   (str "exact" ++ spc () ++ pr_id id)))
 	       (pf_ids_of_hyps g))
 	in
 	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
@@ -327,7 +301,7 @@ module SearchProblem = struct
 	     { 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")])
+	  (filter_tactics s.tacres [Tactics.intro,(str "intro")])
       in
       let rec_tacs = 
 	let l = 
@@ -380,52 +354,48 @@ let e_breadth_search debug n db_list local_db gl =
     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 
+let e_search_auto debug (in_depth,p) lems db_list gl = 
+  let local_db = make_local_hint_db lems 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 eauto debug np lems dbnames =
   let db_list =
     List.map
       (fun x -> 
-	 try Stringmap.find x !searchtable
+	 try searchtable_map x
 	 with Not_found -> error ("EAuto: "^x^": No such Hint database"))
       ("core"::dbnames) 
   in
-  tclTRY (e_search_auto debug np db_list)
+  tclTRY (e_search_auto debug np lems db_list)
 
-let full_eauto debug n gl = 
-  let dbnames = stringmap_dom !searchtable in
+let full_eauto debug n lems gl = 
+  let dbnames = current_db_names () 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 db_list = List.map searchtable_map dbnames in
+  tclTRY (e_search_auto debug n lems db_list) gl
 
-let gen_eauto d np = function
-  | None -> full_eauto d np
-  | Some l -> eauto d np l
+let gen_eauto d np lems = function
+  | None -> full_eauto d np lems
+  | Some l -> eauto d np lems l
 
 let make_depth = function
   | None -> !default_search_depth 
-  | Some (Genarg.ArgArg d) -> d
+  | Some (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)
+  | Some (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
+let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases
 
 ARGUMENT EXTEND hintbases
   TYPED AS preident_list_opt
@@ -435,14 +405,26 @@ ARGUMENT EXTEND hintbases
 | [ ] -> [ 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
+let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_coma prc
 
-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 ]
+ARGUMENT EXTEND constr_coma_sequence
+  TYPED AS constr_list
+  PRINTED BY pr_constr_coma_sequence
+| [ constr(c) "," constr_coma_sequence(l) ] -> [ c::l ]
+| [ constr(c) ] -> [ [c] ]
 END
 
+let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
 
+ARGUMENT EXTEND auto_using
+  TYPED AS constr_list
+  PRINTED BY pr_auto_using
+| [ "using" constr_coma_sequence(l) ] -> [ l ]
+| [ ] -> [ [] ]
+END
+
+TACTIC EXTEND eauto
+| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) 
+    hintbases(db) ] ->
+    [ gen_eauto false (make_dimension n p) lems db ]
+END
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index c3084e65..4621088e 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -10,9 +10,13 @@
 open Term
 open Proof_type
 open Tacexpr
+open Auto
+open Topconstr
 (*i*)
 
-val rawwit_hintbases : string list option raw_abstract_argument_type
+val rawwit_hintbases : hint_db_name list option raw_abstract_argument_type
+
+val rawwit_auto_using : constr_expr list raw_abstract_argument_type
 
 val e_assumption : tactic
 
@@ -23,3 +27,7 @@ val e_resolve_constr :  constr -> tactic
 val vernac_e_resolve_constr :  constr -> tactic
 
 val e_give_exact_constr : constr -> tactic
+
+val gen_eauto : bool -> bool * int -> constr list -> 
+  hint_db_name list option -> tactic
+
diff --git a/tactics/elim.ml b/tactics/elim.ml
index 5573f9ea..2e079567 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: elim.ml,v 1.37.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+(* $Id: elim.ml 7538 2005-11-08 17:14:52Z herbelin $ *)
 
 open Pp
 open Util
@@ -181,7 +181,6 @@ let double_ind h1 h2 gls =
     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 ->
diff --git a/tactics/elim.mli b/tactics/elim.mli
index a891cd9d..d01d3027 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: elim.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Names
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
index 8edfcb3e..0a33164e 100644
--- a/tactics/eqdecide.ml4
+++ b/tactics/eqdecide.ml4
@@ -14,7 +14,7 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: eqdecide.ml4,v 1.6.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+(* $Id: eqdecide.ml4 8780 2006-05-02 21:58:58Z letouzey $ *)
 
 open Util
 open Names
@@ -46,11 +46,11 @@ open Coqlib
    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.
+      then analyse one by one the corresponding 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 
+   4. Once all the arguments have been rewritten, solve the remaining half 
       of the disjunction by reflexivity.
 
    Eduardo Gimenez (30/3/98).
@@ -58,35 +58,36 @@ open Coqlib
 
 let clear_last = (tclLAST_HYP (fun c -> (clear [destVar c])))
 
-let mkBranches = 
+let choose_eq eqonleft = 
+  if eqonleft then h_simplest_left else h_simplest_right
+let choose_noteq eqonleft =
+  if eqonleft then h_simplest_right else h_simplest_left
+
+let mkBranches c1 c2 = 
   tclTHENSEQ
-    [intro; 
-     tclLAST_HYP h_simplest_elim;
-     clear_last;
-     intros ;
+    [generalize [c2];
+     h_simplest_elim c1;
+     intros;
      tclLAST_HYP h_simplest_case;
      clear_last;
      intros]
 
-let solveRightBranch  = 
-  tclTHEN h_simplest_right
+let solveNoteqBranch side = 
+  tclTHEN (choose_noteq side)
     (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
-*)
+let h_solveNoteqBranch side =
+  Refiner.abstract_extended_tactic "solveNoteqBranch" [] 
+    (solveNoteqBranch side)
 
 (* Constructs the type {c1=c2}+{~c1=c2} *)
 
-let mkDecideEqGoal rectype c1 c2 g = 
+let mkDecideEqGoal eqonleft op 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 |])
+  if eqonleft then mkApp(op, [|equality; disequality |])
+  else mkApp(op, [|disequality; equality |])
 
 
 (* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *)
@@ -97,42 +98,45 @@ let mkGenDecideEqGoal rectype g =
   and yname    = next_ident_away (id_of_string "y") hypnames in
   (mkNamedProd xname rectype 
      (mkNamedProd yname rectype 
-        (mkDecideEqGoal rectype (mkVar xname) (mkVar yname) g)))
+        (mkDecideEqGoal true (build_coq_sumbool ())
+          rectype (mkVar xname) (mkVar yname) g)))
 
-let eqCase  tac = 
+let eqCase tac = 
   (tclTHEN intro  
-  (tclTHEN (tclLAST_HYP Extratactics.h_rewriteLR)
+  (tclTHEN (tclLAST_HYP Equality.rewriteLR)
   (tclTHEN clear_last 
   tac)))
 
-let diseqCase = 
+let diseqCase eqonleft =
   let diseq  = id_of_string "diseq" in
   let absurd = id_of_string "absurd" in 
   (tclTHEN (intro_using diseq)
-  (tclTHEN  h_simplest_right
+  (tclTHEN (choose_noteq eqonleft)
   (tclTHEN  red_in_concl
   (tclTHEN  (intro_using absurd)
   (tclTHEN  (h_simplest_apply (mkVar diseq))
   (tclTHEN  (Extratactics.h_injHyp (Rawterm.NamedHyp absurd))
-            full_trivial))))))
+            (full_trivial [])))))))
 
-let solveArg a1 a2 tac  g = 
+let solveArg eqonleft op 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 decide  = mkDecideEqGoal eqonleft op rectype a1 a2 g in
+  let subtacs = 
+    if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] 
+    else [diseqCase eqonleft;eqCase tac;default_auto] in
+  (tclTHENS (h_elim_type decide) subtacs) g
 
-let solveLeftBranch rectype g =
+let solveEqBranch rectype g =
   try
-    let (lhs,rhs) = match_eqdec_partial (pf_concl g) in
+    let (eqonleft,op,lhs,rhs,_) = match_eqdec (pf_concl g) in
     let (mib,mip) = Global.lookup_inductive rectype in
-    let nparams   = mip.mind_nparams in
+    let nparams   = mib.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
+      (solveArg eqonleft op) largs rargs
+      (tclTHEN (choose_eq eqonleft) h_reflexivity) g
   with PatternMatchingFailure -> error "Unexpected conclusion!"
 
 (* The tactic Decide Equality *)
@@ -143,31 +147,33 @@ let hd_app c = match kind_of_term c with
 
 let decideGralEquality g =
   try
-    let typ = match_eqdec (pf_concl g) in
+    let eqonleft,_,c1,c2,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 
+    in
     (tclTHEN
-      mkBranches 
-      (tclORELSE h_solveRightBranch (solveLeftBranch rectype))) g
+      (mkBranches c1 c2)
+      (tclORELSE (h_solveNoteqBranch eqonleft) (solveEqBranch rectype)))
+    g
   with PatternMatchingFailure ->
-    error "The goal does not have the expected form"
+    error "The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}"
 
+let decideEqualityGoal = tclTHEN intros decideGralEquality
 
 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
+  (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) 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  
+  let decide  = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in  
   (tclTHENS (cut decide) 
             [(tclTHEN  intro 
              (tclTHEN (tclLAST_HYP simplest_case)
@@ -177,12 +183,11 @@ let compare c1 c2 g =
 
 (* User syntax *)
 
-TACTIC EXTEND DecideEquality
-  [ "Decide" "Equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ]
-| [ "Decide" "Equality" ] -> [ decideGralEquality ]
+TACTIC EXTEND decide_equality
+  [ "decide" "equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ]
+| [ "decide" "equality" ] -> [ decideEqualityGoal ]
 END
 
-TACTIC EXTEND Compare
-| [ "Compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
+TACTIC EXTEND compare
+| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
 END
-
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 994abb9d..754aec1c 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: equality.ml,v 1.120.2.4 2004/11/21 22:24:09 herbelin Exp $ *)
+(* $Id: equality.ml 9521 2007-01-23 14:31:21Z notin $ *)
 
 open Pp
 open Util
@@ -20,7 +20,6 @@ open Inductiveops
 open Environ
 open Libnames
 open Reductionops
-open Instantiate
 open Typeops
 open Typing
 open Retyping
@@ -40,6 +39,7 @@ open Coqlib
 open Vernacexpr
 open Setoid_replace
 open Declarations
+open Indrec
 
 (* Rewriting tactics *)
 
@@ -48,32 +48,110 @@ open Declarations
    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
+   -- Eduardo (19/8/97)
+*)
+
+let general_s_rewrite_clause = function
+  | None -> general_s_rewrite
+  | Some id -> general_s_rewrite_in id
+
+(* Ad hoc asymmetric general_elim_clause *)
+let general_elim_clause cls c elim = match cls with
+  | None ->
+      (* was tclWEAK_PROGRESS which only fails for tactics generating one 
+         subgoal and did not fail for useless conditional rewritings generating
+         an extra condition *)
+      tclNOTSAMEGOAL (general_elim c elim ~allow_K:false)
+  | Some id ->
+      general_elim_in id c elim 
+
+let elimination_sort_of_clause = function
+  | None -> elimination_sort_of_goal
+  | Some id -> elimination_sort_of_hyp id
+
+(* The next function decides in particular whether to try a regular 
+  rewrite or a setoid rewrite. 
+
+  Old approach was: 
+   break everything, if [eq] appears in head position 
+   then regular rewrite else try setoid rewrite
+ 
+  New approach is: 
+   if head position is a known setoid relation then setoid rewrite
+   else back to the old approach
 *)
 
-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
+let general_rewrite_bindings_clause cls lft2rgt (c,l) gl =
+  let ctype = pf_apply get_type_of gl c in 
+  (* A delta-reduction would be here too strong, since it would 
+     break search for a defined setoid relation in head position. *)
+  let t = snd (decompose_prod (whd_betaiotazeta ctype)) in 
+  let head = if isApp t then fst (destApp t) else t in 
+    if relation_table_mem head && l = NoBindings then 
+      general_s_rewrite_clause cls lft2rgt c [] gl
+    else 
+      (* Original code. In particular, [splay_prod] performs delta-reduction. *)
+      let env = pf_env gl in
+      let sigma = project gl in 
+      let _,t = splay_prod env sigma t in
+	match match_with_equation t with
+	  | None -> 
+	      if l = NoBindings
+	      then general_s_rewrite_clause cls 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 = elimination_suffix (elimination_sort_of_clause cls gl) in
+              let dir = if cls=None then lft2rgt else not lft2rgt in
+              let rwr_thm = if dir then hdcncls^suffix^"_r" else hdcncls^suffix 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_clause cls (c,l) (elim,NoBindings) gl
+
+let general_rewrite_bindings = general_rewrite_bindings_clause None
+let general_rewrite l2r c = general_rewrite_bindings l2r (c,NoBindings)
+
+let general_rewrite_bindings_in l2r id =
+  general_rewrite_bindings_clause (Some id) l2r
+let general_rewrite_in l2r id c = 
+  general_rewrite_bindings_clause (Some id) l2r (c,NoBindings)
+
+let general_multi_rewrite l2r c cl = 
+  if cl.concl_occs <> [] then 
+    error "The \"at\" syntax isn't available yet for the rewrite/replace tactic"
+  else match cl.onhyps with 
+    | Some l -> 
+	(* If a precise list of locations is given, success is mandatory for
+	   each of these locations. *)
+	let rec do_hyps = function 
+	  | [] -> tclIDTAC
+	  | ((_,id),_) :: l -> 
+	      tclTHENFIRST (general_rewrite_bindings_in l2r id c) (do_hyps l)
+	in 
+	if not cl.onconcl then do_hyps l 
+	else tclTHENFIRST (general_rewrite_bindings l2r c) (do_hyps l)
     | 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 *)
+	(* Otherwise, if we are told to rewrite in all hypothesis via the 
+           syntax "* |-", we fail iff all the different rewrites fail *) 
+	let rec do_hyps_atleastonce = function 
+	  | [] -> (fun gl -> error "Nothing to rewrite.")
+	  | id :: l -> 
+	      tclIFTHENTRYELSEMUST 
+		(general_rewrite_bindings_in l2r id c) 
+		(do_hyps_atleastonce l)
+	in 
+	let do_hyps gl = 
+	  (* If the term to rewrite is an hypothesis, don't rewrite in itself *)
+	  let ids = match kind_of_term (fst c) with 
+	    | Var id -> list_remove id (pf_ids_of_hyps gl)
+	    | _ -> pf_ids_of_hyps gl
+	  in do_hyps_atleastonce ids gl
+	in 
+	if not cl.onconcl then do_hyps 
+	else tclIFTHENTRYELSEMUST (general_rewrite_bindings l2r c) do_hyps
 
 (* Conditional rewriting, the success of a rewriting is related 
    to the resolution of the conditions by a given tactic *)
@@ -82,73 +160,68 @@ 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 rewriteLRin_bindings = general_rewrite_bindings_in true
+let rewriteRLin_bindings = general_rewrite_bindings_in false
 
 let conditional_rewrite_in lft2rgt id tac (c,bl) = 
-  tclTHENSFIRSTn (general_rewrite_in lft2rgt id (c,bl))
+  tclTHENSFIRSTn (general_rewrite_bindings_in lft2rgt id (c,bl))
     [|tclIDTAC|] (tclCOMPLETE tac)
 
 let rewriteRL_clause = function
   | None -> rewriteRL_bindings
-  | Some id -> rewriteRLin id
+  | Some id -> rewriteRLin_bindings id
 
 (* Replacing tactics *)
 
-(* eqt,sym_eqt : equality on Type and its symmetry theorem
+(* eq,sym_eq : 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
+   tac : Used to prove the equality c1 = c2 
    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
+let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = 
+  let try_prove_eq = 
+    match try_prove_eq_opt with 
+      | None -> tclIDTAC
+      | Some tac ->  tclTRY (tclCOMPLETE tac)
+  in
+  let t1 = pf_apply get_type_of gl c1 
+  and t2 = pf_apply get_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 e = build_coq_eq () in
+    let sym = build_coq_sym_eq () 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)))
+	  (tclTRY (general_multi_rewrite false (mkVar id,NoBindings) clause))
 	  (clear [id]));
-       tclORELSE assumption 
-	(tclTRY (tclTHEN (apply sym) assumption))] gl
+       tclFIRST
+	 [assumption;
+	  tclTHEN (apply sym) assumption;
+	  try_prove_eq
+	 ]
+      ] gl
   else
-    error "terms does not have convertible types"
+    error "terms do not have convertible types"
+  
+
+let replace c2 c1 gl = multi_replace onConcl c2 c1 false None gl
+
+let replace_in id c2 c1 gl = multi_replace (onHyp id) c2 c1 false None gl
+
+let replace_by c2 c1 tac gl = multi_replace onConcl c2 c1 false (Some tac) gl
 
-let replace c2 c1 gl = abstract_replace None c2 c1 false gl
+let replace_in_by id c2 c1 tac gl = multi_replace (onHyp id) c2 c1 false (Some tac) gl
 
-let replace_in id c2 c1 gl = abstract_replace (Some id) c2 c1 false gl
+let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = 
+  multi_replace cl c2 c1 false tac_opt gl
 
 (* End of Eduardo's code. The rest of this file could be improved
    using the functions match_with_equation, etc that I defined
@@ -156,24 +229,8 @@ let replace_in id c2 c1 gl = abstract_replace (Some id) c2 c1 false gl
    -- 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 ()
+(* Tactics for equality reasoning with the "eq" relation. This code
+   will work with any equivalence relation which is substitutive *)
 
 (* [find_positions t1 t2]
 
@@ -214,24 +271,27 @@ exception DiscrFound of
   (constructor * int) list * constructor * constructor
 
 let find_positions env sigma t1 t2 =
-  let rec findrec posn t1 t2 =
+  let rec findrec sorts 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
+            ->
+	  let sorts = list_intersect sorts (allowed_sorts env (fst sp1)) in
+          (* both sides are fully applied constructors, so either we descend,
+             or we can discriminate here. *)
+	  if is_conv env sigma hd1 hd2 then
+	    let nrealargs = constructor_nrealargs env sp1 in
+	    let rargs1 = list_lastn nrealargs args1 in
+	    let rargs2 = list_lastn nrealargs args2 in
             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))
+	      (list_map2_i (fun i -> findrec sorts ((sp1,i)::posn))
+		0 rargs1 rargs2)
+	  else if List.mem InType sorts then (* see build_discriminator *)
+	    raise (DiscrFound (List.rev posn,sp1,sp2))
+	  else []
 
       | _ ->
 	  let t1_0 = applist (hd1,args1) 
@@ -240,14 +300,13 @@ let find_positions env sigma t1 t2 =
 	    []
           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 s = get_sort_family_of env sigma ty1_0 in
+	    if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in 
+  try
+    (* Rem: to allow injection on proofs objects, just add InProp *)
+    Inr (findrec [InSet;InType] [] 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
@@ -316,8 +375,9 @@ let discriminable env sigma t1 t2 =
 
    the continuation then constructs the case-split.
  *)
+
 let descend_then sigma env head dirn =
-  let IndType (indf,_) as indt =
+  let IndType (indf,_) =
     try find_rectype env sigma (get_type_of env sigma head)
     with Not_found -> assert false in
   let ind,_ = dest_ind_family indf in
@@ -328,9 +388,7 @@ let descend_then sigma env head dirn =
   (dirn_nlams,
    dirn_env,
    (fun dirnval (dfltval,resty) ->
-      let arsign,_ = get_arity env indf in
-      let depind = build_dependent_inductive env indf in
-      let deparsign = (Anonymous,None,depind)::arsign in
+      let deparsign = make_arity_signature env true indf in
       let p =
 	it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in
       let build_branch i =
@@ -360,8 +418,8 @@ let descend_then sigma env head dirn =
    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)
+  let IndType(indf,_) =
+    try find_rectype env sigma (get_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 
@@ -373,10 +431,8 @@ let construct_discriminator sigma env dirn c sort =
 		 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 depind = build_dependent_inductive env indf in
-  let deparsign = (Anonymous,None,depind)::arsign in
+  let deparsign = make_arity_signature env true indf in
   let p = it_mkLambda_or_LetIn (mkSort sort_0) deparsign in
   let cstrs = get_constructors env indf in
   let build_branch i =
@@ -390,18 +446,22 @@ let construct_discriminator sigma env dirn c sort =
 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 newc = mkRel(cnum_nlams-argnum) in
       let subval = build_discriminator sigma cnum_env dirn newc sort l  in
       kont subval (build_coq_False (),mkSort (Prop Null))
 
+(* Note: discrimination could be more clever: if some elimination is
+   not allowed because of a large impredicative constructor in the
+   path (see allowed_sorts in find_positions), the positions could
+   still be discrimated by projecting first instead of putting the
+   discrimination combinator inside the projecting combinator. Example
+   of relevant situation:
+
+   Inductive t:Set := c : forall A:Set, A -> nat -> t.
+   Goal ~ c _ 0 0 = c _ 0 1. intro. discriminate H.
+*)
+
 let gen_absurdity id gl =
   if is_empty_type (clause_type (onHyp id) gl)
   then
@@ -412,42 +472,41 @@ let gen_absurdity id gl =
 
 (* Precondition: eq is leibniz equality
  
-  returns ((eq_elim t t1 P i t2), absurd_term)
-  where  P=[e:t]discriminator 
-         absurd_term=False
+   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 discrimination_pf e (t,t1,t2) discriminator lbeq =
   let i           = build_coq_I () in
   let absurd_term = build_coq_False () in
-  let eq_elim     = build_ind lbeq in
+  let eq_elim     = lbeq.ind in
   (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term)
 
 exception NotDiscriminable
 
-let discrEq (lbeq,(t,t1,t2)) id gls =
-  let sort = pf_type_of gls (pf_concl gls) in 
+let eq_baseid = id_of_string "e"
+
+let discr_positions env sigma (lbeq,(t,t1,t2)) id cpath dirn sort =
+  let e = next_ident_away eq_baseid (ids_of_context env) 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 in
+  tclCOMPLETE 
+    ((tclTHENS (cut_intro absurd_term)
+      [onLastHyp gen_absurdity; 
+       refine (mkApp (pf,[|mkVar id|]))]))
+
+let discrEq (lbeq,(t,t1,t2) as u) id gls =
   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")
+  match find_positions env sigma t1 t2 with
+    | Inr _ ->
+	errorlabstrm "discr" (str" Not a discriminable equality")
+    | Inl (cpath, (_,dirn), _) ->
+	let sort = pf_apply get_type_of gls (pf_concl gls) in 
+	discr_positions env sigma u id cpath dirn sort gls
 
 let onEquality tac id gls =
   let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in
@@ -457,26 +516,20 @@ let onEquality tac id gls =
       errorlabstrm "" (pr_id id ++ str": not a primitive equality") 
   in tac eq id gls
 
-let check_equality tac id gls =
-  let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in
+let onNegatedEquality tac gls =
+  let ccl = pf_concl gls in
   let eq =
-    try find_eq_data_decompose eqn
+    try match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with
+      | Prod (_,t,u) when is_empty_type u ->
+          find_eq_data_decompose (pf_whd_betadeltaiota gls t)
+      | _ -> raise PatternMatchingFailure
     with PatternMatchingFailure ->
-      errorlabstrm "" (str "The goal should negate an equality")
-  in tac eq id gls
-
-let onNegatedEquality tac gls =
-   if is_matching_not (pf_concl gls) then
-     (tclTHEN (tclTHEN hnf_in_concl intro) (onLastHyp(check_equality tac))) gls
-   else if is_matching_imp_False (pf_concl gls)then
-     (tclTHEN intro (onLastHyp (check_equality tac))) gls
-  else
-    errorlabstrm "extract_negated_equality_then"
-      (str"The goal should negate an equality")
+      errorlabstrm "" (str "Not a negated primitive equality")
+  in tclTHEN introf (onLastHyp (tac eq)) gls
 
 let discrSimpleClause = function
   | None -> onNegatedEquality discrEq
-  | Some (id,_,_) -> onEquality discrEq id
+  | Some ((_,id),_) -> onEquality discrEq id
 
 let discr = onEquality discrEq
 
@@ -486,7 +539,7 @@ let discrEverywhere =
   tclORELSE
     (Tacticals.tryAllClauses discrSimpleClause)
     (fun gls -> 
-       errorlabstrm "DiscrEverywhere" (str" No discriminable equalities"))
+       errorlabstrm "DiscrEverywhere" (str"No discriminable equalities"))
 
 let discr_tac = function
   | None -> discrEverywhere
@@ -497,19 +550,16 @@ 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"
+(* J.F.: correction du bug #1167 en accord avec Hugo. *) 
+   
+let find_sigma_data s = build_sigma_type ()
 
 (* [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)]
+     [(existT 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}]
  *)
@@ -577,33 +627,34 @@ let minimal_free_rels env sigma (c,cty) =
 
  *)
 
-let sig_clausal_form env sigma sort_of_ty siglen ty (dFLT,dFLTty) =
+let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
   let { intro = exist_term } = find_sigma_data sort_of_ty in 
-  let isevars = Evarutil.create_evar_defs sigma in
+  let isevars = ref (Evd.create_evar_defs sigma) in
   let rec sigrec_clausal_form siglen p_i =
     if siglen = 0 then
-      if Evarconv.the_conv_x_leq env isevars dFLTty p_i then
+      (* is the default value typable with the expected type *)
+      let dflt_typ = type_of env sigma dflt in
+      if Evarconv.e_cumul env isevars dflt_typ p_i then
 	(* the_conv_x had a side-effect on isevars *)
-	dFLT
+	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 ev = Evarutil.e_new_evar isevars env a 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) 
+	Evd.existential_opt_value (Evd.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
+  Evarutil.nf_evar (Evd.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
@@ -639,7 +690,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty (dFLT,dFLTty) =
    [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))]
+   [existT [xn]Pn Rel(in) .. (existT [x2]P2 Rel(i2) (existT [x1]P1 Rel(i1) z))]
 
    where P1 is zty[i1/x1], P2 is {x1 | P1[i2/x2]} etc.
 
@@ -654,7 +705,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty (dFLT,dFLTty) =
    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))]
+    [existT [xn]Pn ?n (... existT [x2]P2 ?2 (existT [x1]P1 ?1 term))]
 
    but for this we have to solve the following unification problem:
 
@@ -675,43 +726,63 @@ let make_iterated_tuple env sigma dflt (z,zty) =
   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)
+let rec build_injrec sigma env dflt c = function
+  | [] -> make_iterated_tuple env sigma dflt (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
+      let newc = mkRel(cnum_nlams-argnum) in
+      let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt 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
+let build_injector sigma env dflt c cpath =
+  let (injcode,resty,_) = build_injrec sigma env dflt 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
+      | 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 injEq (eq,(t,t1,t2)) id gls =
+let simplify_args env sigma t = 
+  (* Quick hack to reduce in arguments of eq only *)
+  match decompose_app t with
+    | eq, [t;c1;c2] -> applist (eq,[t;nf env sigma c1;nf env sigma c2])
+    | eq, [t1;c1;t2;c2] -> applist (eq,[t1;nf env sigma c1;t2;nf env sigma c2])
+    | _ -> t
+
+let inject_at_positions env sigma (eq,(t,t1,t2)) id posns =
+  let e = next_ident_away eq_baseid (ids_of_context env) in
+  let e_env = push_named (e,None,t) env in
+  let injectors =
+    map_succeed
+      (fun (cpath,t1',t2') ->
+        (* arbitrarily take t1' as the injector default value *)
+	let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in
+	let injfun = mkNamedLambda e t injbody in
+	let pf = applist(eq.congr,[t;resty;injfun;t1;t2;mkVar id]) in
+	let ty = simplify_args env sigma (get_type_of env sigma pf) in
+	(pf,ty))
+      posns in
+  if injectors = [] then
+    errorlabstrm "Equality.inj" (str "Failed to decompose the equality");
+  tclMAP
+    (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf])
+    injectors
+
+let injEq ipats (eq,(t,t1,t2)) id gls =
   let sigma = project gls in
   let env = pf_env gls in
   match find_positions env sigma t1 t2 with
@@ -723,98 +794,38 @@ let injEq (eq,(t,t1,t2)) id gls =
 	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
+(* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ?
+	let t1 = try_delta_expand env sigma t1 in
+	let t2 = try_delta_expand env sigma t2 in
+*)
+	tclTHEN 
+	  (inject_at_positions env sigma (eq,(t,t1,t2)) id posns)
+	  (intros_pattern None ipats)
 	  gls
 
-let inj = onEquality injEq
+let inj ipats = onEquality (injEq ipats)
 
-let injClause = function
-  | None -> onNegatedEquality injEq
-  | Some id -> try_intros_until inj id
+let injClause ipats = function
+  | None -> onNegatedEquality (injEq ipats)
+  | Some id -> try_intros_until (inj ipats) id
 
-let injConcl gls  = injClause None gls
-let injHyp id gls = injClause (Some id) gls
+let injConcl gls  = injClause [] None gls
+let injHyp id gls = injClause [] (Some id) gls
 
-let decompEqThen ntac (lbeq,(t,t1,t2)) id gls =
-  let sort = pf_type_of gls (pf_concl gls) in 
+let decompEqThen ntac (lbeq,(t,t1,t2) as u) id gls =
+  let sort = pf_apply get_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))
+  match find_positions env sigma t1 t2 with
+    | Inl (cpath, (_,dirn), _) ->
+	discr_positions env sigma u id cpath dirn sort gls
+    | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
+        ntac 0 gls
+    | Inr posns ->
+	tclTHEN
+	  (inject_at_positions env sigma (lbeq,(t,t1,t2)) id (List.rev posns))
+	  (ntac (List.length posns))
+	  gls
 
 let dEqThen ntac = function
   | None -> onNegatedEquality (decompEqThen ntac)
@@ -833,73 +844,43 @@ let swap_equands gls eqn =
 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
+  refine (applist(sym_equal,[t;e2;e1;Evarutil.mk_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
+  cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id))
+    (tclTHEN swapEquandsInConcl) 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 *)
+   eliminate lbeq on sort_of_gl.
+   This is somehow an artificial choice as we could take eq_rect in
+   all cases (eq_ind - and eq_rec - are instances of eq_rect) [HH 2/4/06].
+*)
 
-let find_elim  sort_of_gl  lbeq =
+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 *) -> 
+    | Sort(Prop Null)  (* Prop *)  -> lbeq.ind
+    | _ (* Set/Type *) -> 
         (match lbeq.rect with
-           | Some eq_rect -> (eq_rect, true) 
+           | Some eq_rect -> eq_rect
            | 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) *)
+		 (str "this type of substitution is not allowed"))
 
-let build_non_dependent_rewrite_predicate (t,t1,t2) body gls =
-  lambda_create (pf_env gls) (t,body)
+(* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *)
 
 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
+  (* find substitution scheme *)
+  let eq_elim = find_elim (pf_apply get_type_of gls (pf_concl gls)) lbeq in
+  (* build substitution predicate *)
+  let p = lambda_create (pf_env gls) (t,body) in
+  (* apply substitution scheme *)
+  refine (applist(eq_elim,[t;e1;p;Evarutil.mk_new_meta();
+                           e2;Evarutil.mk_new_meta()])) gls
 
 (* [subst_tuple_term dep_pair B]
 
    Given that dep_pair looks like:
 
-   (existS e1 (existS e2 ... (existS en en+1) ... ))
+   (existT e1 (existT e2 ... (existT en en+1) ... ))
 
    and B might contain instances of the ei, we will return the term:
 
@@ -925,8 +906,7 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
 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 {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
@@ -942,48 +922,41 @@ let subst_tuple_term env sigma dep_pair b =
   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
+  applist(abst_B,proj_list)
     
-(* |- (P e2)
-     BY RevSubstInConcl (eq T e1 e2)
-     |- (P e1)
-     |- (eq T e1 e2)
- *)
-(* Redondant avec Replace ! *)
+(* Comme "replace" mais decompose les egalites dependantes *)
 
-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
+let cutSubstInConcl_RL eqn gls =
+  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in
+  let body = pf_apply subst_tuple_term gls e2 (pf_concl gls) in
   assert (dependent (mkRel 1) body);
-  bareRevSubstInConcl lbeq body (t,e1,e2) gls
+  bareRevSubstInConcl lbeq body eq gls
 
 (* |- (P e1)
-     BY SubstInConcl (eq T e1 e2)
+     BY CutSubstInConcl_LR (eq T e1 e2)
      |- (P e2)
      |- (eq T e1 e2)
  *)
-let substInConcl_LR eqn gls =
-  (tclTHENS (substInConcl_RL (swap_equands gls eqn))
+let cutSubstInConcl_LR eqn gls =
+  (tclTHENS (cutSubstInConcl_RL (swap_equands gls eqn))
      ([tclIDTAC;
        swapEquandsInConcl])) gls
 
-let substInConcl l2r = if l2r then substInConcl_LR else substInConcl_RL
+let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_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 cutSubstInHyp_LR eqn id gls =
+  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose eqn in 
+  let body = pf_apply subst_tuple_term gls e1 (pf_get_hyp_typ gls id) in
+  assert (dependent (mkRel 1) body);
+  cut_replacing id (subst1 e2 body)
+    (tclTHENFIRST (bareRevSubstInConcl lbeq body eq)) gls
 
-let substInHyp_RL eqn id gls =
-  (tclTHENS (substInHyp_LR (swap_equands gls eqn) id)
+let cutSubstInHyp_RL eqn id gls =
+  (tclTHENS (cutSubstInHyp_LR (swap_equands gls eqn) id)
      ([tclIDTAC;
        swapEquandsInConcl])) gls
 
-let substInHyp l2r = if l2r then substInHyp_LR else substInHyp_RL
+let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL
 
 let try_rewrite tac gls =
   try 
@@ -996,77 +969,51 @@ let try_rewrite tac gls =
           (str "Cannot find a well-typed generalization of the goal that" ++
              str " makes the proof progress")
 
-let subst l2r eqn cls gls =
+let cutSubstClause l2r eqn cls gls =
   match cls with
-    | None ->    substInConcl l2r eqn gls
-    | Some id -> substInHyp l2r eqn id gls
+    | None ->    cutSubstInConcl l2r eqn gls
+    | Some id -> cutSubstInHyp l2r eqn id gls
 
-(* |- (P a)
- * SubstConcl_LR a=b 
- *  |- (P b)
- *  |- a=b
- *)
+let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls)
+let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id)
+let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None
 
-let substConcl l2r eqn gls = try_rewrite (subst l2r eqn None) gls
-let substConcl_LR = substConcl true
+let substClause l2r c cls gls =
+  let eq = pf_apply get_type_of gls c in
+  tclTHENS (cutSubstClause l2r eq cls) [tclIDTAC; exact_no_check c] gls
 
-(* id:(P a) |- G
- * SubstHyp a=b id
- *  id:(P b) |- G
- *  id:(P a) |-a=b
-*)
+let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls)
+let rewriteInHyp l2r c id = rewriteClause l2r c (Some id)
+let rewriteInConcl l2r c = rewriteClause l2r c None
 
-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
+(* Renaming scheme correspondence new name (old name)
 
-let hypSubst_LR = hypSubst true
+      give equality                    give proof of equality
 
-(* 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
+    / cutSubstClause (subst)          substClause (HypSubst on hyp)
+raw | cutSubstInHyp (substInHyp)      substInHyp (none)
+    \ cutSubstInConcl (substInConcl)  substInConcl (none) 
 
-(* 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
+    / cutRewriteClause (none)         rewriteClause (none)
+user| cutRewriteInHyp (substHyp)      rewriteInHyp (none)
+    \ cutRewriteInConcl (substConcl)  rewriteInConcl (substHypInConcl on hyp)
 
-(* id:(P b) |-G
-   SubstHyp_RL a=b id 
-      id:(P a) |- G
-      |- a=b  
+raw = raise typing error or PatternMatchingFailure
+user = raise user error specific to rewrite
 *)
-let substHyp l2r eqn id gls = try_rewrite (subst l2r eqn (Some id)) gls
-let substHyp_RL = substHyp false
 
+(* Summary of obsolete forms
+let substInConcl = cutSubstInConcl
+let substInHyp = cutSubstInHyp
+let hypSubst l2r id = substClause l2r (mkVar id)
+let hypSubst_LR = hypSubst true
 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
+let substHypInConcl l2r id = rewriteInConcl l2r (mkVar id)
+let substConcl = cutRewriteInConcl
+let substHyp = cutRewriteInHyp
 *)
 
+(**********************************************************************)
 (* Substitutions tactics (JCF) *)
 
 let unfold_body x gl =
@@ -1077,13 +1024,12 @@ let unfold_body x gl =
       | _ -> 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 hl = List.fold_right (fun (y,yval,_) cl -> (([],y),InHyp) :: 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
+     reduct_in_concl (rfun,DEFAULTcast)] gl
 
 
 
@@ -1135,8 +1081,10 @@ let subst_one x gl =
   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
+        letin_tac true (Name id)
+	  (mkCast(replace_term varx rhs hval,DEFAULTcast,
+	          replace_term varx rhs htyp)) nowhere
+  in
   let need_rewrite = dephyps <> [] || depconcl in
   tclTHENLIST 
     ((if need_rewrite then
@@ -1155,6 +1103,8 @@ let subst_all gl =
   let test (_,c) =
     try
       let (_,x,y) = snd (find_eq_data_decompose c) in
+      (* J.F.: added to prevent failure on goal containing x=x as an hyp *)
+      if eq_constr x y then failwith "caught";
       match kind_of_term x with Var x -> x | _ -> 
       match kind_of_term y with Var y -> y | _ -> failwith "caught"
     with PatternMatchingFailure -> failwith "caught"
@@ -1163,28 +1113,10 @@ let subst_all gl =
   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
@@ -1205,6 +1137,48 @@ let cond_eq_term c t gl =
     else failwith "not convertible"
   with PatternMatchingFailure -> failwith "not an equality"
 
+let rewrite_mutli_assumption_cond cond_eq_term cl gl = 
+  let rec arec = function 
+    | [] -> error "No such assumption"
+    | (id,_,t) ::rest -> 
+	begin 
+	  try 
+	    let dir = cond_eq_term t gl in 
+	    general_multi_rewrite dir (mkVar id,NoBindings) cl gl
+	  with | Failure _ | UserError _ -> arec rest
+	end
+  in 
+  arec (pf_hyps gl)
+
+let replace_multi_term dir_opt c  = 
+  let cond_eq_fun = 
+    match dir_opt with 
+      | None -> cond_eq_term c
+      | Some true -> cond_eq_term_left c
+      | Some false -> cond_eq_term_right c
+  in 
+  rewrite_mutli_assumption_cond cond_eq_fun 
+
+(* JF. old version 
+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) gl
+	   with Failure _ | UserError _ ->  arec rest)
+   in arec (pf_hyps gl)
+
 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)
@@ -1216,3 +1190,27 @@ 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)
+*)
+
+let replace_term_left t = replace_multi_term (Some true) t Tacticals.onConcl
+
+let replace_term_right t = replace_multi_term (Some false) t Tacticals.onConcl
+
+let replace_term t = replace_multi_term None t Tacticals.onConcl
+
+let replace_term_in_left t hyp = replace_multi_term (Some true) t (Tacticals.onHyp hyp)
+
+let replace_term_in_right t hyp = replace_multi_term (Some false) t (Tacticals.onHyp hyp)
+
+let replace_term_in t hyp = replace_multi_term None t (Tacticals.onHyp hyp)
+
+
+
+
+
+
+
+
+
+let _ = Setoid_replace.register_replace (fun tac_opt c2 c1 gl ->  replace_in_clause_maybe_by c2 c1 onConcl tac_opt gl)
+let _ = Setoid_replace.register_general_rewrite general_rewrite
diff --git a/tactics/equality.mli b/tactics/equality.mli
index ab439c39..3d6a08b6 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: equality.mli 9195 2006-10-01 09:41:57Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -22,25 +22,40 @@ open Tacticals
 open Tactics
 open Tacexpr
 open Rawterm
+open Genarg
 (*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
 
+(* Obsolete, use [general_rewrite_bindings l2r]
+[val rewriteLR_bindings       : constr with_bindings -> tactic]
+[val rewriteRL_bindings       : constr with_bindings -> tactic]
+*)
+
+(* Equivalent to [general_rewrite l2r] *)
 val rewriteLR   : constr -> tactic
 val rewriteRL   : constr  -> tactic
 
+(* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *)
+
+val general_rewrite_bindings_in :
+  bool -> identifier -> constr with_bindings -> tactic
+val general_rewrite_in          :
+  bool -> identifier -> constr -> tactic
+
+val general_multi_rewrite : 
+  bool -> constr with_bindings -> clause -> 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_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic
 val replace    : constr -> constr -> tactic
 val replace_in : identifier -> constr -> constr -> tactic
+val replace_by : constr -> constr -> tactic -> tactic
+val replace_in_by : identifier -> constr -> constr -> tactic -> tactic
 
 val discr        : identifier -> tactic
 val discrConcl   : tactic
@@ -48,22 +63,46 @@ 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 inj          : intro_pattern_expr list -> identifier -> tactic
+val injClause    : intro_pattern_expr list -> 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
+  env -> evar_map -> constr -> (constr * types) -> constr * constr * constr
 
+(* The family cutRewriteIn expect an equality statement *)
+val cutRewriteInHyp : bool -> types -> identifier -> tactic
+val cutRewriteInConcl : bool -> constr -> tactic
+
+(* The family rewriteIn expect the proof of an equality *)
+val rewriteInHyp : bool -> constr -> identifier -> tactic
+val rewriteInConcl : bool -> constr -> tactic
+
+(* Expect the proof of an equality; fails with raw internal errors *)
+val substClause : bool -> constr -> identifier option -> tactic
+
+(*
+(* [substHypInConcl l2r id] is obsolete: use [rewriteInConcl l2r (mkVar id)] *)
 val substHypInConcl : bool -> identifier -> tactic
+
+(* [substConcl] is an obsolete synonym for [cutRewriteInConcl] *)
 val substConcl : bool -> constr -> tactic
-val substHyp : bool -> constr -> identifier -> tactic
 
-val hypSubst_LR : identifier -> clause -> tactic
-val hypSubst_RL : identifier -> clause -> tactic
+(* [substHyp] is an obsolete synonym of [cutRewriteInHyp] *)
+val substHyp : bool -> types -> identifier -> tactic
+*)
+
+(* Obsolete, use [rewriteInConcl lr (mkVar id)] in concl
+              or [rewriteInHyp lr (mkVar id) (Some hyp)] in hyp
+   (which, if they fail, raise only UserError, not PatternMatchingFailure)
+   or [substClause lr (mkVar id) None]
+   or [substClause lr (mkVar id) (Some hyp)]
+[val hypSubst_LR : identifier -> clause -> tactic]
+[val hypSubst_RL : identifier -> clause -> tactic]
+*)
 
 val discriminable : env -> evar_map -> constr -> constr -> bool
 
@@ -75,9 +114,8 @@ 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
+(* [replace_multi_term dir_opt c cl] 
+   perfoms replacement of [c] by the first value found in context
+   (according to [dir] if given to get the rewrite direction)  in the clause [cl]
+*)
+val replace_multi_term : bool option -> constr -> clause -> tactic
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
new file mode 100644
index 00000000..ed40af1c
--- /dev/null
+++ b/tactics/evar_tactics.ml
@@ -0,0 +1,75 @@
+(************************************************************************)
+(*  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: evar_tactics.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+
+open Term
+open Util
+open Evar_refiner
+open Tacmach
+open Tacexpr
+open Proof_type
+open Evd
+open Sign
+open Termops
+
+(* The instantiate tactic *)
+
+let evar_list evc c = 
+  let rec evrec acc c =
+    match kind_of_term c with
+    | Evar (n, _) when Evd.mem evc n -> c :: acc
+    | _ -> fold_constr evrec acc c
+  in 
+    evrec [] c
+
+let instantiate n rawc ido gl = 
+  let sigma = gl.sigma in
+  let evl = 
+    match ido with
+	ConclLocation () -> evar_list sigma gl.it.evar_concl 
+      | HypLocation (id,hloc) ->
+	  let decl = Environ.lookup_named_val id gl.it.evar_hyps in
+	    match hloc with
+		InHyp ->  
+		  (match decl with 
+		       (_,None,typ) -> evar_list sigma typ
+		     | _ -> error 
+			 "please be more specific : in type or value ?")
+	      | InHypTypeOnly ->
+		  let (_, _, typ) = decl in evar_list sigma typ
+	      | InHypValueOnly ->
+		  (match decl with 
+		       (_,Some body,_) -> evar_list sigma body
+		     | _ -> error "not a let .. in  hypothesis") in
+    if List.length evl < n then
+      error "not enough uninstantiated existential variables";
+    if n <= 0 then error "incorrect existential variable index";
+    let ev,_ =  destEvar (List.nth evl (n-1)) in
+    let evd' = w_refine ev rawc (create_evar_defs sigma)  in
+    Refiner.tclEVARS (evars_of evd') gl
+	
+(*
+let pfic gls c =
+  let evc = gls.sigma in 
+  Constrintern.interp_constr evc (Global.env_of_context gls.it.evar_hyps) c
+
+let instantiate_tac = function
+  | [Integer n; Command com] ->
+      (fun gl -> instantiate n (pfic gl com) gl)
+  | [Integer n; Constr c] ->
+      (fun gl -> instantiate n c gl)
+  | _ -> invalid_arg "Instantiate called with bad arguments"
+*)
+
+let let_evar name typ gls =
+  let evd = Evd.create_evar_defs gls.sigma in
+  let evd',evar = Evarutil.new_evar evd (pf_env gls) typ in
+  Refiner.tclTHEN (Refiner.tclEVARS (evars_of evd'))
+    (Tactics.letin_tac true name evar nowhere) gls
+ 
diff --git a/theories7/Init/Prelude.v b/tactics/evar_tactics.mli
index 2752f462..dbf7db31 100755..100644
--- a/theories7/Init/Prelude.v
+++ b/tactics/evar_tactics.mli
@@ -6,11 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Prelude.v,v 1.1.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
+(*i $Id: evar_tactics.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
 
-Require Export Notations.
-Require Export Logic.
-Require Export Datatypes.
-Require Export Specif.
-Require Export Peano.
-Require Export Wf.
+open Tacmach
+open Names
+open Tacexpr
+
+val instantiate : int -> Rawterm.rawconstr -> 
+  (identifier * hyp_location_flag, unit) location -> tactic
+
+(*i
+val instantiate_tac : tactic_arg list -> tactic
+i*)
+
+val let_evar : name -> Term.types -> tactic
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index 34348834..3c7d76b2 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -8,24 +8,231 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extraargs.ml4,v 1.5.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+(* $Id: extraargs.ml4 9076 2006-08-23 15:05:54Z jforest $ *)
 
 open Pp
 open Pcoq
 open Genarg
+open Names
+open Tacexpr
+open Tacinterp
 
 (* Rewriting orientation *)
 
 let _ = Metasyntax.add_token_obj "<-"
 let _ = Metasyntax.add_token_obj "->"
 
-let pr_orient _prc _prt = function
+let pr_orient _prc _prlc _prt = function
   | true -> Pp.mt ()
   | false -> Pp.str " <-"
 
+
 ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
 | [ "->" ] -> [ true ]
 | [ "<-" ] -> [ false ]
 | [ ] -> [ true ]
 END
 
+(* For Setoid rewrite *)
+let pr_morphism_signature _ _ _ s =
+  spc () ++ Setoid_replace.pr_morphism_signature s
+
+ARGUMENT EXTEND morphism_signature
+ TYPED AS morphism_signature
+ PRINTED BY pr_morphism_signature
+  | [ constr(out) ] -> [ [],out ]
+  | [ constr(c) "++>" morphism_signature(s) ] ->
+       [ let l,out = s in (Some true,c)::l,out ]
+  | [ constr(c) "-->" morphism_signature(s) ] ->
+       [ let l,out = s in (Some false,c)::l,out ]
+  | [ constr(c) "==>" morphism_signature(s) ] ->
+       [ let l,out = s in (None,c)::l,out ]
+END
+
+let pr_gen prc _prlc _prtac c = prc c
+
+let pr_rawc _prc _prlc _prtac raw = Printer.pr_rawconstr raw
+
+let interp_raw _ _ (t,_) = t
+
+let glob_raw = Tacinterp.intern_constr
+
+let subst_raw = Tacinterp.subst_rawconstr_and_expr
+
+ARGUMENT EXTEND raw
+    TYPED AS rawconstr
+    PRINTED BY pr_rawc
+     
+     INTERPRETED BY interp_raw	
+     GLOBALIZED BY glob_raw
+     SUBSTITUTED BY subst_raw
+     
+     RAW_TYPED AS constr_expr
+     RAW_PRINTED BY pr_gen
+     
+     GLOB_TYPED AS rawconstr_and_expr
+     GLOB_PRINTED BY pr_gen
+  [ lconstr(c) ] -> [ c ]
+END
+
+type 'id gen_place= ('id * hyp_location_flag,unit) location
+
+type loc_place = identifier Util.located gen_place
+type place = identifier gen_place
+
+let pr_gen_place pr_id = function
+    ConclLocation () -> Pp.mt ()
+  | HypLocation (id,InHyp) -> str "in " ++ pr_id id
+  | HypLocation (id,InHypTypeOnly) -> 
+      str "in (Type of " ++ pr_id id ++ str ")"
+  | HypLocation (id,InHypValueOnly) -> 
+      str "in (Value of " ++ pr_id id ++ str ")"
+
+let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id)
+let pr_place _ _ _ = pr_gen_place Nameops.pr_id
+
+let intern_place ist = function
+    ConclLocation () -> ConclLocation ()
+  | HypLocation (id,hl) -> HypLocation (intern_hyp ist id,hl)
+
+let interp_place ist gl = function
+    ConclLocation () -> ConclLocation ()
+  | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl)
+
+let subst_place subst pl = pl 
+
+ARGUMENT EXTEND hloc
+    TYPED AS place
+    PRINTED BY pr_place
+    INTERPRETED BY interp_place
+    GLOBALIZED BY intern_place
+    SUBSTITUTED BY subst_place
+    RAW_TYPED AS loc_place
+    RAW_PRINTED BY pr_loc_place
+    GLOB_TYPED AS loc_place
+    GLOB_PRINTED BY pr_loc_place
+  [ ] -> 
+    [ ConclLocation () ]
+  |  [ "in" "|-" "*" ] -> 
+    [ ConclLocation () ]
+| [ "in" ident(id) ] ->
+    [ HypLocation ((Util.dummy_loc,id),InHyp) ]
+| [ "in" "(" "Type" "of" ident(id) ")" ] -> 
+    [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ]
+| [ "in" "(" "Value" "of" ident(id) ")" ] -> 
+    [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ]
+   
+ END
+
+
+
+
+
+
+
+(* Julien: Mise en commun des differentes version de replace with in by *)
+
+let pr_by_arg_tac _prc _prlc prtac opt_c = 
+  match opt_c with 
+    | None -> mt ()
+    | Some t -> spc () ++ hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t)
+
+ARGUMENT EXTEND by_arg_tac
+  TYPED AS tactic_opt
+  PRINTED BY pr_by_arg_tac
+| [ "by" tactic3(c) ] -> [ Some c ]
+| [ ] -> [ None ]
+END
+ 
+
+let pr_in_hyp  pr_id (lo,concl) :  Pp.std_ppcmds = 
+  match lo,concl with 
+    | Some [],true -> mt ()
+    | None,true -> str "in" ++ spc () ++ str "*"
+    | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-" 
+    | Some l,_ -> 
+	str "in" ++ spc () ++ 
+	  Util.prlist_with_sep spc pr_id l ++ 
+	  match concl with 
+	    | true -> spc () ++ str "|-" ++ spc () ++ str "*"
+	    | _ -> mt ()
+
+
+let pr_in_arg_hyp _ _ _ = pr_in_hyp (fun (_,id) -> Ppconstr.pr_id id)
+
+let pr_in_arg_hyp_typed  _ _  _  = pr_in_hyp Ppconstr.pr_id 
+
+
+let pr_var_list_gen pr_id = Util.prlist_with_sep (fun () -> str ",") pr_id 
+
+let pr_var_list_typed _ _ _ =  pr_var_list_gen Ppconstr.pr_id 
+
+let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id)
+
+
+ARGUMENT EXTEND comma_var_lne 
+  TYPED AS var list 
+  PRINTED BY pr_var_list_typed
+  RAW_TYPED AS var list 
+  RAW_PRINTED BY pr_var_list
+  GLOB_TYPED AS var list
+  GLOB_PRINTED BY pr_var_list
+| [ var(x) ] -> [ [x] ]
+| [ var(x) "," comma_var_lne(l) ] -> [x::l]
+END
+
+ARGUMENT EXTEND comma_var_l 
+  TYPED AS var list 
+  PRINTED BY pr_var_list_typed
+  RAW_TYPED AS var list 
+  RAW_PRINTED BY pr_var_list
+  GLOB_TYPED AS var list
+  GLOB_PRINTED BY pr_var_list
+| [  comma_var_lne(l) ] -> [l]
+| [] -> [ [] ]
+END
+
+let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-" 
+
+ARGUMENT EXTEND inconcl  
+  TYPED AS bool 
+  PRINTED BY pr_in_concl
+| [ "|-" "*" ] -> [ true ]
+| [ "|-" ] -> [ false ]
+END
+
+
+
+ARGUMENT EXTEND in_arg_hyp
+  TYPED AS var list option * bool
+  PRINTED BY pr_in_arg_hyp_typed
+  RAW_TYPED AS var list option * bool 
+  RAW_PRINTED BY pr_in_arg_hyp
+  GLOB_TYPED AS var list option * bool
+  GLOB_PRINTED BY pr_in_arg_hyp
+| [ "in" "*" ] -> [(None,true)]
+| [ "in" "*" inconcl_opt(b) ] -> [let onconcl = match b with Some b -> b | None -> true in (None,onconcl)]
+| [ "in" comma_var_l(l) inconcl_opt(b) ] -> [ let onconcl = match b with Some b -> b | None -> false in 
+					      Some l, onconcl
+					   ]
+| [ ] -> [ (Some [],true) ]
+END
+
+
+let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = 
+  {Tacexpr.onhyps=
+   Util.option_map 
+     (fun l -> 
+	List.map 
+	  (fun id -> ( ([],trad_id id) ,Tacexpr.InHyp))
+	  l
+     )
+     hyps;
+   Tacexpr.onconcl=concl;
+   Tacexpr.concl_occs = []}
+
+
+let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd 
+let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x) 
+
+
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index 2b4746ae..4a9a0c5f 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -6,13 +6,47 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extraargs.mli,v 1.3.2.2 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: extraargs.mli 9076 2006-08-23 15:05:54Z jforest $ i*)
 
 open Tacexpr
 open Term
+open Names
 open Proof_type
 open Topconstr
+open Rawterm
 
 val rawwit_orient : bool raw_abstract_argument_type
 val wit_orient : bool closed_abstract_argument_type
 val orient : bool Pcoq.Gram.Entry.e
+
+val rawwit_morphism_signature :
+ Setoid_replace.morphism_signature raw_abstract_argument_type
+val wit_morphism_signature :
+ Setoid_replace.morphism_signature closed_abstract_argument_type
+val morphism_signature :
+ Setoid_replace.morphism_signature Pcoq.Gram.Entry.e
+
+val rawwit_raw : constr_expr raw_abstract_argument_type
+val wit_raw : rawconstr closed_abstract_argument_type
+val raw : constr_expr Pcoq.Gram.Entry.e
+
+type 'id gen_place= ('id * hyp_location_flag,unit) location
+
+type loc_place = identifier Util.located gen_place
+type place = identifier gen_place
+
+val rawwit_hloc : loc_place raw_abstract_argument_type
+val wit_hloc : place closed_abstract_argument_type
+val hloc : loc_place Pcoq.Gram.Entry.e
+
+
+val in_arg_hyp:  (Names.identifier Util.located list option * bool)  Pcoq.Gram.Entry.e
+val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type
+val wit_in_arg_hyp : (Names.identifier list option * bool) closed_abstract_argument_type
+val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause
+val glob_in_arg_hyp_to_clause :  (Names.identifier list option * bool)  -> Tacticals.clause
+
+
+val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e
+val rawwit_by_arg_tac :  raw_tactic_expr option raw_abstract_argument_type
+val wit_by_arg_tac : glob_tactic_expr option closed_abstract_argument_type
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index 237f0a0d..d6de2666 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -8,142 +8,128 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(* $Id: extratactics.ml4,v 1.21.2.2 2004/11/15 11:06:49 herbelin Exp $ *)
+(* $Id: extratactics.ml4 9430 2006-12-12 08:25:19Z herbelin $ *)
 
 open Pp
 open Pcoq
 open Genarg
 open Extraargs
+open Mod_subst
+open Names
 
 (* 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 ]
+TACTIC EXTEND replace 
+   ["replace" constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ]
+-> [ replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp) (Util.option_map Tacinterp.eval_tactic tac) ]
 END
 
-TACTIC EXTEND ReplaceIn
-  [ "Replace" constr(c1) "with" constr(c2) "in" hyp(h) ] ->
-    [ replace_in h c1 c2 ]
+TACTIC EXTEND replace_term_left
+  [ "replace"  "->" constr(c) in_arg_hyp(in_hyp) ]
+  -> [ replace_multi_term (Some true) c (glob_in_arg_hyp_to_clause in_hyp)]
 END
 
-TACTIC EXTEND Replacetermleft
-  [ "Replace" "->" constr(c)  ] -> [ replace_term_left c ]
+TACTIC EXTEND replace_term_right
+  [ "replace"  "<-" constr(c) in_arg_hyp(in_hyp) ]
+  -> [replace_multi_term (Some false) c (glob_in_arg_hyp_to_clause in_hyp)]
 END
 
-TACTIC EXTEND Replacetermright
-  [ "Replace" "<-" constr(c)  ] -> [ replace_term_right c ]
+TACTIC EXTEND replace_term
+  [ "replace" constr(c) in_arg_hyp(in_hyp) ]
+  -> [ replace_multi_term None c (glob_in_arg_hyp_to_clause in_hyp) ]
 END
 
-TACTIC EXTEND Replaceterm
-  [ "Replace" constr(c)  ] -> [ replace_term c ]
+TACTIC EXTEND simplify_eq
+  [ "simplify_eq" quantified_hypothesis_opt(h) ] -> [ dEq h ]
 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 ]
+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 ]
+TACTIC EXTEND injection
+  [ "injection" quantified_hypothesis_opt(h) ] -> [ injClause [] h ]
+END 
+TACTIC EXTEND injection_as
+  [ "injection" quantified_hypothesis_opt(h) 
+    "as" simple_intropattern_list(ipat)] -> [ injClause ipat h ]
 END
 
 let h_injHyp id = h_injection (Some id)
 
-TACTIC EXTEND ConditionalRewrite
-  [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c) ]
+TACTIC EXTEND conditional_rewrite
+| [ "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)
+| [ "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 ]
+TACTIC EXTEND dependent_rewrite
+| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ]
+| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ]
+    -> [ rewriteInHyp b c id ]
+END
+
+TACTIC EXTEND cut_rewrite
+| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ]
+| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ]
+    -> [ cutRewriteInHyp b eqn id ]
 END
 
 (* Contradiction *)
 open Contradiction
 
-TACTIC EXTEND Absurd
- [ "Absurd" constr(c) ] -> [ absurd c ]
+TACTIC EXTEND absurd
+ [ "absurd" constr(c) ] -> [ absurd c ]
 END
 
-TACTIC EXTEND Contradiction
- [ "Contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ]
+TACTIC EXTEND contradiction
+ [ "contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ]
 END
 
 (* AutoRewrite *)
 
 open Autorewrite
-TACTIC EXTEND AutorewriteV7
-  [ "AutoRewrite" "[" ne_preident_list(l) "]" ] ->
+(* J.F : old version 
+TACTIC EXTEND autorewrite
+  [ "autorewrite" "with" ne_preident_list(l) ] ->
     [ autorewrite Refiner.tclIDTAC l ]
-| [ "AutoRewrite" "[" ne_preident_list(l) "]" "using" tactic(t) ] ->
+| [ "autorewrite" "with" ne_preident_list(l) "using" tactic(t) ] ->
     [ autorewrite (snd t) l ]
+| [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) ] ->
+    [ autorewrite_in id Refiner.tclIDTAC l ]
+| [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) "using" tactic(t) ] ->
+    [ autorewrite_in id (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 ]
+*)
+
+TACTIC EXTEND autorewrite
+| [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) ] ->
+    [ auto_multi_rewrite  l (glob_in_arg_hyp_to_clause  cl) ]
+| [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] ->
+    [ 
+      let cl =  glob_in_arg_hyp_to_clause cl in 
+      auto_multi_rewrite_with (snd t) l cl
+
+    ]
 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
+VERNAC COMMAND EXTEND HintRewrite
   [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] ->
-  [ add_rewrite_hint b o (Tacexpr.TacId "") l ]
+  [ 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 ]
@@ -154,8 +140,8 @@ END
 
 open Refine
 
-TACTIC EXTEND Refine
-  [ "Refine" castedopenconstr(c) ] -> [ refine c ]
+TACTIC EXTEND refine
+  [ "refine" casted_open_constr(c) ] -> [ refine c ]
 END
 
 let refine_tac = h_refine
@@ -164,18 +150,81 @@ let refine_tac = h_refine
 
 open Setoid_replace
 
-TACTIC EXTEND SetoidReplace
-  [ "Setoid_replace" constr(c1) "with" constr(c2) ]
-  -> [ setoid_replace c1 c2 None]
+TACTIC EXTEND setoid_replace
+   [ "setoid_replace" constr(c1) "with" constr(c2) by_arg_tac(tac)] ->
+     [ setoid_replace  (Util.option_map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:[] ]
+ | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) by_arg_tac(tac)] ->
+     [ setoid_replace  (Util.option_map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:[] ]
+ | [ "setoid_replace" constr(c1) "with" constr(c2) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] ->
+     [ setoid_replace  (Util.option_map Tacinterp.eval_tactic tac) None c1 c2 ~new_goals:l ]
+ | [ "setoid_replace" constr(c1) "with" constr(c2) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac) ] ->
+     [ setoid_replace  (Util.option_map Tacinterp.eval_tactic tac) (Some rel) c1 c2 ~new_goals:l ]
+ | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) by_arg_tac(tac) ] ->
+     [ setoid_replace_in  (Util.option_map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:[] ]
+ | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) by_arg_tac(tac)] ->
+     [ setoid_replace_in  (Util.option_map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:[] ]
+ | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] ->
+     [ setoid_replace_in  (Util.option_map Tacinterp.eval_tactic tac) h None c1 c2 ~new_goals:l ]
+ | [ "setoid_replace" constr(c1) "with" constr(c2) "in" hyp(h) "using" "relation" constr(rel) "generate" "side" "conditions" constr_list(l) by_arg_tac(tac)] ->
+     [ setoid_replace_in  (Util.option_map Tacinterp.eval_tactic tac) h (Some rel) c1 c2 ~new_goals:l ]
+END
+
+TACTIC EXTEND setoid_rewrite
+   [ "setoid_rewrite" orient(b) constr(c) ]
+   -> [ general_s_rewrite b c ~new_goals:[] ]
+ | [ "setoid_rewrite" orient(b) constr(c) "generate" "side" "conditions" constr_list(l) ]
+   -> [ general_s_rewrite b c ~new_goals:l ]
+ | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) ] ->
+      [ general_s_rewrite_in h b c ~new_goals:[] ]
+ | [ "setoid_rewrite" orient(b) constr(c) "in" hyp(h) "generate" "side" "conditions" constr_list(l) ] ->
+      [ general_s_rewrite_in h b c ~new_goals:l ]
+END
+
+VERNAC COMMAND EXTEND AddSetoid1
+  [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+   [ add_setoid n a aeq t ]
+| [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
+   [ new_named_morphism n m None ]
+| [ "Add" "Morphism" constr(m) "with" "signature" morphism_signature(s) "as" ident(n) ] ->
+   [ new_named_morphism n m (Some s)]
+END
+
+VERNAC COMMAND EXTEND AddRelation1
+  [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "as" ident(n) ] ->
+   [ add_relation n a aeq (Some t) (Some t') None ]
+| [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t)  "as" ident(n) ] ->
+   [ add_relation n a aeq (Some t) None None ]
+| [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] ->
+   [ add_relation n a aeq None None None ]
+END
+
+VERNAC COMMAND EXTEND AddRelation2
+  [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "as" ident(n) ] ->
+   [ add_relation n a aeq None (Some t') None ]
+| [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'')  "as" ident(n) ] ->
+   [ add_relation n a aeq None (Some t') (Some t'') ]
+END
+
+VERNAC COMMAND EXTEND AddRelation3
+  [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "transitivity" "proved" "by" constr(t') "as" ident(n) ] ->
+   [ add_relation n a aeq (Some t) None (Some t') ]
+| [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(t) "symmetry" "proved" "by" constr(t') "transitivity" "proved" "by" constr(t'') "as" ident(n) ] ->
+   [ add_relation n a aeq (Some t) (Some t') (Some t'') ]
+| [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(t) "as" ident(n) ] ->
+   [ add_relation n a aeq None None (Some t) ]
+END
+
+TACTIC EXTEND setoid_symmetry
+   [ "setoid_symmetry" ] -> [ setoid_symmetry ]
+ | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
 END
 
-TACTIC EXTEND SetoidRewrite
-  [ "Setoid_rewrite" orient(b) constr(c) ] -> [ general_s_rewrite b c ]
+TACTIC EXTEND setoid_reflexivity
+   [ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
 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 ]
+TACTIC EXTEND setoid_transitivity
+   [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity t ]
 END
 
 (* Inversion lemmas (Leminv) *)
@@ -226,11 +275,28 @@ END
 
 (* Subst *)
 
-TACTIC EXTEND Subst
-| [ "Subst" ne_var_list(l) ] -> [ subst l ]
-| [ "Subst" ] -> [ subst_all ]
+TACTIC EXTEND subst
+| [ "subst" ne_var_list(l) ] -> [ subst l ]
+| [ "subst" ] -> [ subst_all ]
 END
 
+open Evar_tactics
+
+(* evar creation *)
+
+TACTIC EXTEND evar
+  [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ]
+| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ]
+END
+
+open Tacexpr
+
+TACTIC EXTEND instantiate
+  [ "instantiate" "(" integer(i) ":=" raw(c) ")" hloc(hl) ] ->
+    [instantiate i c hl  ]
+END
+
+
 (** Nijmegen "step" tactic for setoid rewriting *)
 
 open Tacticals
@@ -257,7 +323,7 @@ let step left x tac =
   let l =
     List.map (fun lem ->
       tclTHENLAST
-      (apply_with_bindings (constr_of_reference lem, ImplicitBindings [x]))
+      (apply_with_bindings (lem, ImplicitBindings [x]))
         tac)
       !(if left then transitivity_left_table else transitivity_right_table)
   in
@@ -271,7 +337,7 @@ let cache_transitivity_lemma (_,(left,lem)) =
   else
     transitivity_right_table := lem :: !transitivity_right_table
   
-let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_global subst ref)
+let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_mps subst ref)
 
 let (inTransitivity,_) =
   declare_object {(default_object "TRANSITIVITY-STEPS") with
@@ -303,27 +369,39 @@ let _ =
 
 (* Main entry points *)
 
-let add_transitivity_lemma left ref =
-  add_anonymous_leaf (inTransitivity (left,Nametab.global ref))
+let add_transitivity_lemma left lem =
+ let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in
+  add_anonymous_leaf (inTransitivity (left,lem'))
 
 (* Vernacular syntax *)
 
-TACTIC EXTEND Stepl
-| ["Stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ]
-| ["Stepl" constr(c) ] -> [ step true c tclIDTAC ]
+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 ]
+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 ]
+| [ "Declare" "Left" "Step" constr(t) ] ->
+    [ add_transitivity_lemma true t ]
 END
 
 VERNAC COMMAND EXTEND AddStepr
-| [ "Declare" "Right" "Step" global(id) ] ->
-    [ add_transitivity_lemma false id ]
+| [ "Declare" "Right" "Step" constr(t) ] ->
+    [ add_transitivity_lemma false t ]
+END
+
+VERNAC COMMAND EXTEND ImplicitTactic
+| [ "Declare" "Implicit" "Tactic" tactic(tac) ] ->
+    [ Tacinterp.declare_implicit_tactic (Tacinterp.interp tac) ]
+END
+
+TACTIC EXTEND apply_in
+| ["apply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in id [c] ]
+| ["apply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",") 
+   "in" hyp(id) ] -> [ apply_in id (c::cl) ]
 END
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index 78a94190..234c0161 100644
--- a/tactics/extratactics.mli
+++ b/tactics/extratactics.mli
@@ -6,15 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: extratactics.mli,v 1.3.10.2 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: extratactics.mli 9073 2006-08-22 08:54:29Z jforest $ i*)
 
+open Util
 open Names
 open Term
 open Proof_type
 open Rawterm
+open Tacexpr
+open Topconstr
+open Genarg
 
 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
index f35c624b..4133a3f6 100644
--- a/tactics/hiddentac.ml
+++ b/tactics/hiddentac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hiddentac.ml,v 1.21.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+(* $Id: hiddentac.ml 9551 2007-01-29 15:13:35Z bgregoir $ *)
 
 open Term
 open Proof_type
@@ -23,11 +23,14 @@ 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)
+  abstract_tactic (TacIntroMove (x, option_map 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_exact_no_check c = abstract_tactic (TacExactNoCheck c) (exact_no_check c)
+let h_vm_cast_no_check c = 
+  abstract_tactic (TacVmCastNoCheck c) (vm_cast_no_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)
@@ -41,15 +44,14 @@ 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))
+let h_instantiate n c ido = 
+(Evar_tactics.instantiate n c ido)
+  (* abstract_tactic (TacInstantiate (n,c,cls))
+    (Evar_refiner.instantiate n c (simple_clause_of cls)) *)
 
 (* Derived basic tactics *)
 let h_simple_induction h =
@@ -64,7 +66,8 @@ 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 b l = abstract_tactic (TacClear (b,l))
+  ((if b then keep else 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)
@@ -87,7 +90,9 @@ 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)
+let h_change oc c cl =
+  abstract_tactic (TacChange (oc,c,cl))
+    (change (option_map Redexpr.out_with_occurrences oc) c cl)
 
 (* Equivalence relations *)
 let h_reflexivity    = abstract_tactic TacReflexivity intros_reflexivity
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
index 1b37291c..1456601b 100644
--- a/tactics/hiddentac.mli
+++ b/tactics/hiddentac.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: hiddentac.mli,v 1.19.2.2 2005/01/21 16:41:52 herbelin Exp $ i*)
+(*i $Id: hiddentac.mli 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 (*i*)
 open Names
@@ -29,6 +29,8 @@ val h_intros_until    : quantified_hypothesis -> tactic
 
 val h_assumption      : tactic
 val h_exact           : constr -> tactic
+val h_exact_no_check  : constr -> tactic
+val h_vm_cast_no_check  : constr -> tactic
 
 val h_apply           : constr with_bindings -> tactic
 
@@ -45,25 +47,22 @@ 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
+val h_instantiate     : int -> Rawterm.rawconstr ->
+  (identifier * hyp_location_flag, unit) location -> tactic
 
 (* Derived basic tactics *)
 
-val h_simple_induction   : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic
+val h_simple_induction   : quantified_hypothesis -> 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
+  constr induction_arg list -> constr with_bindings option ->
+  intro_pattern_expr -> 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
+  constr induction_arg list -> constr with_bindings option -> 
+  intro_pattern_expr -> tactic
 val h_specialize      : int option -> constr with_bindings -> tactic
 val h_lapply          : constr -> tactic
 
@@ -71,16 +70,13 @@ val h_lapply          : constr -> tactic
 
 
 (* Context management *)
-val h_clear           : identifier list -> tactic
+val h_clear           : bool -> identifier list -> tactic
 val h_clear_body      : identifier list -> tactic
 val h_move            : bool -> identifier -> identifier -> tactic
 val h_rename          : identifier -> identifier -> tactic
 
 
 (* Constructors *)
-(*i
-val h_any_constructor : tactic -> tactic
-i*)
 val h_constructor     : int -> constr bindings -> tactic
 val h_left            : constr bindings -> tactic
 val h_right           : constr bindings -> tactic
@@ -92,9 +88,9 @@ val h_simplest_right  : tactic
 
 
 (* Conversion *)
-val h_reduce          : Tacred.red_expr -> Tacticals.clause -> tactic
+val h_reduce          : Redexpr.red_expr -> Tacticals.clause -> tactic
 val h_change          :
-  constr occurrences option -> constr -> Tacticals.clause -> tactic
+  constr with_occurrences option -> constr -> Tacticals.clause -> tactic
 
 (* Equivalence relations *)
 val h_reflexivity     : tactic
diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml4
index 0ada5a06..fca84fd2 100644
--- a/tactics/hipattern.ml
+++ b/tactics/hipattern.ml4
@@ -6,7 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: hipattern.ml,v 1.29.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+(*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*)
+
+(* $Id: hipattern.ml4 8866 2006-05-28 16:21:04Z herbelin $ *)
 
 open Pp
 open Util
@@ -40,7 +42,6 @@ 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
@@ -120,7 +121,7 @@ let match_with_unit_type t =
         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  
+          nb_prod c = mib.mind_nparams in  
 	if nconstr = 1 && array_for_all zero_args constr_types then 
 	  Some hdapp
         else 
@@ -133,21 +134,9 @@ let is_unit_type t = op2bool (match_with_unit_type t)
    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 coq_refl_rel1_pattern  = PATTERN [ forall A:_, forall x:A, _ A x x ]
+let coq_refl_rel2_pattern  = PATTERN [ forall x:_, _ x x ]
+let coq_refl_reljm_pattern = PATTERN [ forall A:_, forall x:A, _ A x A x ]
 
 let match_with_equation t =
   let (hdapp,args) = decompose_app t in
@@ -168,9 +157,8 @@ let match_with_equation t =
 
 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 coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ]
+
 let match_arrow_pattern t =
   match matches coq_arrow_pattern t with
     | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind)
@@ -213,11 +201,11 @@ let match_with_nodep_ind t =
       | 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
+	      let nodep_constr = has_nodep_prod_after mib.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
+		      fst (list_chop mib.mind_nparams args) in
 		    Some (hdapp,params,mip.mind_nrealargs)
 		else 
 		  None
@@ -233,7 +221,7 @@ let match_with_sigma_type t=
           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
+	    has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then
 	      (*allowing only 1 existential*) 
 	      Some (hdapp,args)
 	  else 
@@ -252,12 +240,10 @@ let rec first_match matcher = function
 
 (*** 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|]))
+(* Patterns "(eq ?1 ?2 ?3)" and "(identity ?1 ?2 ?3)" *)
+let coq_eq_pattern_gen eq = lazy PATTERN [ %eq ?X1 ?X2 ?X3 ]
 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 coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref
 
 let match_eq eqn eq_pat =
   match matches (Lazy.force eq_pat) eqn with
@@ -268,8 +254,7 @@ let match_eq eqn eq_pat =
 
 let equalities =
   [coq_eq_pattern, build_coq_eq_data;
-(*   coq_eqT_pattern, build_coq_eqT_data;*)
-   coq_idT_pattern, build_coq_idT_data]
+   coq_identity_pattern, build_coq_identity_data]
 
 let find_eq_data_decompose eqn = (* fails with PatternMatchingFailure *)
   first_match (match_eq eqn) equalities
@@ -293,14 +278,12 @@ let dest_nf_eq gls eqn =
 (*** 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_ex_pattern_gen ex = lazy PATTERN [ %ex ?X1 ?X2 ?X3 ?X4 ]
 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 ->
+    | [(m1,a);(m2,p);(m3,car);(m4,cdr)] ->
 	assert (m1=meta1 & m2=meta2 & m3=meta3 & m4=meta4);
 	(a,p,car,cdr)
     | _ ->
@@ -308,12 +291,10 @@ let match_sigma ex ex_pat =
 
 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]
+    [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 coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ]
 
 let match_sigma t =
   match matches (Lazy.force coq_sig_pattern) t with
@@ -324,43 +305,47 @@ 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) |]))
+(* The expected form of the goal for the tactic Decide Equality *)
 
-let match_eqdec_partial t =
-  match matches (Lazy.force coq_eqdec_partial_pattern) t with
-    | [_; (_,lhs); (_,rhs); _] -> (lhs,rhs)
-    | _ -> anomaly "Unexpected pattern"
+(* Pattern "{<?1>x=y}+{~(<?1>x=y)}" *)
+(* i.e. "(sumbool (eq ?1 x y) ~(eq ?1 x y))" *)
 
-(* The expected form of the goal for the tactic Decide Equality *)
+let coq_eqdec_inf_pattern =
+ lazy PATTERN [ { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } ]
+
+let coq_eqdec_inf_rev_pattern =
+ lazy PATTERN [ { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } ]
 
-(* 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 |])|]) |]))))
+ lazy PATTERN [ %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) ]
+
+let coq_eqdec_rev_pattern =
+ lazy PATTERN [ %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) ]
+
+let op_or = coq_or_ref
+let op_sum = coq_sumbool_ref
 
 let match_eqdec t =
-  match matches (Lazy.force coq_eqdec_pattern) t with
-    | [(_,typ)] -> typ
-    | _ -> anomaly "Unexpected pattern"
+  let eqonleft,op,subst =
+    try true,op_sum,matches (Lazy.force coq_eqdec_inf_pattern) t
+    with PatternMatchingFailure -> 
+    try false,op_sum,matches (Lazy.force coq_eqdec_inf_rev_pattern) t
+    with PatternMatchingFailure -> 
+    try true,op_or,matches (Lazy.force coq_eqdec_pattern) t
+    with PatternMatchingFailure -> 
+        false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in
+  match subst with
+  | [(_,typ);(_,c1);(_,c2)] -> 
+      eqonleft, Libnames.constr_of_global (Lazy.force op), c1, c2, 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 coq_not_pattern = lazy PATTERN [ ~ _ ]
+let coq_imp_False_pattern = lazy PATTERN [ _ -> %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
+
+(* Remark: patterns that have references to the standard library must
+   be evaluated lazily (i.e. at the time they are used, not a the time
+   coqtop starts) *)
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 7e2aa8f2..86cd191e 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: hipattern.mli 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -37,8 +37,6 @@ open Proof_trees
    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.
@@ -98,12 +96,12 @@ val is_sigma_type           : testing_function
 
 open Coqlib
 
-(* Match terms [(eq A t u)], [(eqT A t u)] or [(identityT A t u)] *)
+(* Match terms [(eq A t u)] or [(identity 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)] *)
+(* Match a term of the form [(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)
@@ -113,11 +111,9 @@ 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 a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns
+   [t,u,T] and a boolean telling if equality is on the left side *)
+val match_eqdec : constr -> bool * constr * constr * constr * constr
 
 (* Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
 open Proof_type
diff --git a/tactics/inv.ml b/tactics/inv.ml
index e4bab195..c48a90ac 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inv.ml,v 1.53.2.3 2005/09/08 12:28:00 herbelin Exp $ *)
+(* $Id: inv.ml 7880 2006-01-16 13:59:08Z herbelin $ *)
 
 open Pp
 open Util
@@ -46,13 +46,13 @@ let collect_meta_variables 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
+    let metas = List.filter (fun na -> na<>Anonymous)
+      (List.map (Evd.meta_name clenv.env) (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 *))
+	 prlist_with_sep pr_coma pr_name metas
+	 (* ajouter "in " ++ pr_lconstr ccl mais il faut le bon contexte *))
 
 let var_occurs_in_pf gl id =
   let env = pf_env gl in
@@ -88,8 +88,7 @@ let var_occurs_in_pf gl id =
 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)))
+  (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
@@ -112,7 +111,7 @@ let make_inv_predicate env sigma indf realargs id status concl =
               | 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
+		Unification.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)
@@ -128,14 +127,13 @@ let make_inv_predicate env sigma indf realargs id status concl =
    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 ->
+    | (ai,(xi,ti))::restlist ->
         let (lhs,eqnty,rhs) =
           if closed0 ti then 
 	    (xi,ti,ai)
           else 
-	    make_iterated_tuple env' sigma (ai,ati) (xi,ti)
+	    make_iterated_tuple env' sigma ai (xi,ti)
 	in
-        let sort = get_sort_of env sigma concl in 
         let eq_term = Coqlib.build_coq_eq () in
         let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in 
 	build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist
@@ -306,17 +304,16 @@ let remember_first_eq id x = if !x = None then x := Some id
    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 subst_hyp l2r id =
+    tclTHEN (tclTRY(rewriteInConcl l2r (mkVar id)))
+      (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC))
+  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
+    | Var id1, _ -> generalizeRewriteIntros (subst_hyp true id) depids id1 gls
+    | _, Var id2 -> generalizeRewriteIntros (subst_hyp false id) depids id2 gls
+    | _ -> tac id gls
   in
   let deq_trailer id neqns =
     tclTHENSEQ 
@@ -326,7 +323,7 @@ let projectAndApply thin id eqname names depids gls =
 	   (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))))
+	   (tclTRY (onLastHyp (substHypIfVariable (subst_hyp false)))))
 	 names);
        (if names = [] then clear [id] else tclIDTAC)]
   in
@@ -380,6 +377,8 @@ let rewrite_equations_gene othin neqns ba gl =
 let rec get_names allow_conj = function
   | IntroWildcard ->
       error "Discarding pattern not allowed for inversion equations"
+  | IntroAnonymous ->
+      error "Anonymous pattern not allowed for inversion equations"
   | IntroOrAndPattern [l] -> 
       if allow_conj then
 	if l = [] then (None,[]) else
@@ -401,7 +400,6 @@ let rewrite_equations othin neqns names ba gl =
   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
@@ -446,12 +444,11 @@ let rewrite_equations_tac (gene, othin) id neqns names ba =
 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 = mk_clenv_from gl (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
+  let newc = clenv_value indclause' in
+  let ccl = clenv_type indclause' in
   check_no_metas indclause' ccl;
   let IndType (indf,realargs) =
     try find_rectype env sigma ccl
@@ -477,7 +474,7 @@ let raw_inversion inv_kind indbinding id status names gl =
         (fun id ->
            (tclTHEN
               (apply_term (mkVar id)
-                 (list_tabulate (fun _ -> mkMeta(Clenv.new_meta())) neqns))
+                 (list_tabulate (fun _ -> Evarutil.mk_new_meta()) neqns))
               reflexivity))])
   gl
 
@@ -524,15 +521,15 @@ 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 half_inv_tac id  = inv SimpleInversion IntroAnonymous (NamedHyp id)
+let inv_tac id       = inv FullInversion IntroAnonymous (NamedHyp id)
+let inv_clear_tac id = inv FullInversionClear IntroAnonymous (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)
+let half_dinv_tac id  = dinv SimpleInversion None IntroAnonymous (NamedHyp id)
+let dinv_tac id       = dinv FullInversion None IntroAnonymous (NamedHyp id)
+let dinv_clear_tac id = dinv FullInversionClear None IntroAnonymous (NamedHyp id)
 
 (* InvIn will bring the specified clauses into the conclusion, and then
  * perform inversion on the named hypothesis.  After, it will intro them
diff --git a/tactics/inv.mli b/tactics/inv.mli
index e19d8232..bd38d08f 100644
--- a/tactics/inv.mli
+++ b/tactics/inv.mli
@@ -6,7 +6,7 @@
 (*         *       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 $Id: inv.mli 7880 2006-01-16 13:59:08Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -21,19 +21,19 @@ type inversion_status = Dep of constr option | NoDep
 
 val inv_gen :
   bool -> inversion_kind -> inversion_status ->
-    intro_pattern_expr option -> quantified_hypothesis -> tactic
+    intro_pattern_expr -> quantified_hypothesis -> tactic
 val invIn_gen :
-  inversion_kind -> intro_pattern_expr option -> identifier list -> 
+  inversion_kind -> intro_pattern_expr -> identifier list -> 
     quantified_hypothesis -> tactic
 
 val inv_clause :
-  inversion_kind -> intro_pattern_expr option -> identifier list ->
+  inversion_kind -> intro_pattern_expr -> identifier list ->
     quantified_hypothesis -> tactic
 
-val inv : inversion_kind -> intro_pattern_expr option ->
+val inv : inversion_kind -> intro_pattern_expr ->
   quantified_hypothesis -> tactic
 
-val dinv : inversion_kind -> constr option -> intro_pattern_expr option ->
+val dinv : inversion_kind -> constr option -> intro_pattern_expr ->
   quantified_hypothesis -> tactic
 
 val half_inv_tac : identifier -> tactic
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 1be465f5..9507ce5f 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: leminv.ml,v 1.41.2.1 2004/07/16 19:30:54 herbelin Exp $ *)
+(* $Id: leminv.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
 
 open Pp
 open Util
@@ -40,7 +40,7 @@ let not_work_message = "tactic fails to build the inversion lemma, may be becaus
 
 let no_inductive_inconstr env constr =
   (str "Cannot recognize an inductive predicate in " ++ 
-     prterm_env env constr ++
+     pr_lconstr_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.")
@@ -216,8 +216,8 @@ let inversion_scheme env sigma t sort dep_option inv_op =
     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 invSign = named_context_val invEnv in
+  let pfs = mk_pftreestate (mk_goal invSign invGoal None) 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
@@ -245,9 +245,11 @@ 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 }, 
+    (DefinitionEntry 
+       { const_entry_body = invProof;
+         const_entry_type = None;
+         const_entry_opaque = false;
+	 const_entry_boxed = true && (Options.boxed_definitions())}, 
      IsProof Lemma)
   in ()
 
@@ -256,13 +258,15 @@ let add_inversion_lemma name env sigma t sort dep inv_op =
 (* 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 inversion_lemma_from_goal n na (loc,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 t = 
+    try pf_get_hyp_typ gl id
+    with Not_found -> Pretype_errors.error_var_not_found_loc loc id in
   let env = pf_env gl and sigma = project gl in
-  let fv = global_vars env t in
 (* Pourquoi ??? 
+  let fv = global_vars env t in
   let thin_ids = thin_ids (hyps,fv) in
   if not(list_subset thin_ids fv) then
     errorlabstrm "lemma_inversion"
@@ -287,15 +291,14 @@ let add_inversion_lemma_exn na com comsort bool tac =
 
 let lemInv id c gls =
   try
-    let (wc,kONT) = startWalk gls in
-    let clause = mk_clenv_type_of wc c in
+    let clause = mk_clenv_type_of gls c in
     let clause = clenv_constrain_with_bindings [(-1,mkVar id)] clause in
-    elim_res_pf kONT clause true gls
+    Clenvtac.res_pf clause ~allow_K:true gls
   with 
     |  UserError (a,b) -> 
 	 errorlabstrm "LemInv" 
 	   (str "Cannot refine current goal with the lemma " ++ 
-	      prterm_env (Global.env()) c) 
+	      pr_lconstr_env (Global.env()) c) 
 
 let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id
 
diff --git a/tactics/leminv.mli b/tactics/leminv.mli
index 6617edf2..3e12f770 100644
--- a/tactics/leminv.mli
+++ b/tactics/leminv.mli
@@ -1,4 +1,4 @@
-
+open Util
 open Names
 open Term
 open Rawterm
@@ -12,7 +12,7 @@ val lemInv_clause :
   quantified_hypothesis -> constr -> identifier list -> tactic
 
 val inversion_lemma_from_goal :
-  int -> identifier -> identifier -> sorts -> bool ->
+  int -> identifier -> identifier located -> sorts -> bool ->
     (identifier -> tactic) -> unit
 val add_inversion_lemma_exn :
   identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) ->
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
index bd4fb60e..554ce2e9 100644
--- a/tactics/nbtermdn.ml
+++ b/tactics/nbtermdn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: nbtermdn.ml,v 1.7.16.1 2004/07/16 19:30:54 herbelin Exp $ *)
+(* $Id: nbtermdn.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
 
 open Util
 open Names
@@ -14,6 +14,7 @@ open Term
 open Libobject
 open Library
 open Pattern
+open Libnames
 
 (* Named, bounded-depth, term-discrimination nets.
    Implementation:
@@ -28,11 +29,11 @@ open Pattern
 
 type ('na,'a) t = {
   mutable table : ('na,constr_pattern * 'a) Gmap.t;
-  mutable patterns : (constr_label option,'a Btermdn.t) Gmap.t }
+  mutable patterns : (global_reference 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
+    * (global_reference option,'a Btermdn.t) Gmap.t
 
 let create () =
   { table = Gmap.empty;
@@ -42,14 +43,14 @@ 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 
+  let hkey = option_map 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 
+  let hkey = option_map 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
@@ -61,7 +62,7 @@ let remap ndn na (pat,valu) =
   add ndn (na,(pat,valu))
 
 let lookup dn valu =
-  let hkey = option_app fst (Termdn.constr_val_discr valu) in 
+  let hkey = option_map 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
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
index 90656619..579b24d4 100644
--- a/tactics/nbtermdn.mli
+++ b/tactics/nbtermdn.mli
@@ -6,11 +6,12 @@
 (*         *       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 $Id: nbtermdn.mli 6427 2004-12-07 17:41:10Z sacerdot $ i*)
 
 (*i*)
 open Term
 open Pattern
+open Libnames
 (*i*)
 
 (* Named, bounded-depth, term-discrimination nets. *)
@@ -34,4 +35,4 @@ 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
+                             (global_reference option * 'a Btermdn.t) list
diff --git a/tactics/refine.ml b/tactics/refine.ml
index 4a2fb01b..5b162729 100644
--- a/tactics/refine.ml
+++ b/tactics/refine.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refine.ml,v 1.34.2.2 2004/07/16 19:30:54 herbelin Exp $ *)
+(* $Id: refine.ml 9364 2006-11-11 11:59:42Z herbelin $ *)
 
 (* JCF -- 6 janvier 1998  EXPERIMENTAL *)
 
@@ -66,12 +66,12 @@ 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 () ++
+  (str"TH=[ " ++ hov 0 (pr_lconstr 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)
+	   (fun (n,c) -> (int n ++ str" --> " ++ pr_lconstr c)) l)
 and pp_sg sg =
   hov 0 (prlist_with_sep (fun _ -> (fnl ()))
 	   (function None -> (str"None") | Some th -> (pp_th th)) sg)
@@ -89,72 +89,71 @@ and pp_sg sg =
  *  meta_map correspond à celui des buts qui seront engendrés par le refine.
  *)
 
-let replace_by_meta env gmm = function
+let replace_by_meta env sigma = 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 n = Evarutil.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))
+	    let _,_,t = destCast c2 in mkNamedProd id c1 t
 	| Lambda (Anonymous,c1,c2) when isCast c2 ->
-	    mkArrow c1 (snd (destCast c2))
+	    let _,_,t = destCast c2 in mkArrow c1 t
 	| _ -> (* (App _ | Case _) -> *)
-	    Retyping.get_type_of_with_meta env Evd.empty (gmm@mm) c
+	    Retyping.get_type_of_with_meta env sigma 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]
+      mkCast (m,DEFAULTcast, ty),[n,ty],[Some th]
 
 exception NoMeta
 
-let replace_in_array env gmm a =
+let replace_in_array keep_length env sigma 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 
+			| (TH (c,mm,[])) when not keep_length -> c,mm,[]
+			| th -> replace_by_meta env sigma 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
+  let v' = Array.map pi1 a' in
+  let mm = Array.fold_left (@) [] (Array.map pi2 a') in
+  let sgp = Array.fold_left (@) [] (Array.map pi3 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
+let rec compute_metamap env sigma 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 -> 
+
+  | 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
+      begin match compute_metamap env' sigma (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
+	    let m,mm,sgp = replace_by_meta env' sigma th in
 	    TH (mkLambda (Name v,c1,m), mm, sgp)
       end
 
@@ -163,21 +162,21 @@ let rec compute_metamap env gmm c = match kind_of_term c with
 	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
+      begin match compute_metamap env' sigma (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
+	    let m,mm,sgp = replace_by_meta env' sigma 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
+      let a = Array.map (compute_metamap env sigma) (Array.append [|f|] v) in
       begin
 	try
-	  let v',mm,sgp = replace_in_array env gmm a in
+	  let v',mm,sgp = replace_in_array false env sigma a in
           let v'' = Array.sub v' 1 (Array.length v) in
           TH (mkApp(v'.(0), v''),mm,sgp)
 	with NoMeta ->
@@ -188,10 +187,10 @@ let rec compute_metamap env gmm c = match kind_of_term c with
       (* 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
+      let a = Array.map (compute_metamap env sigma) v in
       begin
 	try
-	  let v',mm,sgp = replace_in_array env gmm a in
+	  let v',mm,sgp = replace_in_array false env sigma a in
 	  let v'' = Array.sub v' 2 nbr in
 	  TH (mkCase (ci,v'.(0),v'.(1),v''),mm,sgp)
 	with NoMeta ->
@@ -205,12 +204,12 @@ let rec compute_metamap env gmm c = match kind_of_term c with
       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)
+		(compute_metamap env' sigma)
 		(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 v',mm,sgp = replace_in_array true env' sigma a in
 	  let fix = mkFix ((ni,i),(fi',ai,v')) in
 	  TH (fix,mm,sgp)
 	with NoMeta ->
@@ -218,7 +217,7 @@ let rec compute_metamap env gmm c = match kind_of_term c with
       end
 	      
   (* Cast. Est-ce bien exact ? *)
-  | Cast (c,t) -> compute_metamap env gmm c
+  | Cast (c,_,t) -> compute_metamap env sigma c
       (*let TH (c',mm,sgp) = compute_metamap sign c in
 	TH (mkCast (c',t),mm,sgp) *)
       
@@ -235,12 +234,12 @@ let rec compute_metamap env gmm c = match kind_of_term c with
       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)
+		(compute_metamap env' sigma)
 		(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 v',mm,sgp = replace_in_array true env' sigma a in
 	  let cofix = mkCoFix (i,(fi',ai,v')) in
 	  TH (cofix,mm,sgp)
 	with NoMeta ->
@@ -253,14 +252,14 @@ let rec compute_metamap env gmm c = match kind_of_term c with
  *  Réalise le 3. ci-dessus
  *)
 
-let rec tcc_aux subst (TH (c,mm,sgp) as th) gl =
+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 ->
+    | Cast (c,_,_), _ when isMeta c ->
 	tclIDTAC gl
 	  
     (* terme pur => refine *)
@@ -339,8 +338,8 @@ let rec tcc_aux subst (TH (c,mm,sgp) as th) gl =
 
 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
-
+  let (sigma,c) = Evarutil.evars_to_metas sigma oc in
+  (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise 
+     complicated to update meta types when passing through a binder *)
+  let th = compute_metamap (pf_env gl) sigma c in
+  tclTHEN (Refiner.tclEVARS sigma) (tcc_aux [] th) gl
diff --git a/tactics/refine.mli b/tactics/refine.mli
index e053aea6..aae1f5e1 100644
--- a/tactics/refine.mli
+++ b/tactics/refine.mli
@@ -6,9 +6,8 @@
 (*         *       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*)
+(*i $Id: refine.mli 6099 2004-09-12 11:38:09Z barras $ i*)
 
-open Term
 open Tacmach
 
-val refine : Pretyping.open_constr -> tactic
+val refine : Evd.open_constr -> tactic
diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml
index 74b062e0..2727e669 100644
--- a/tactics/setoid_replace.ml
+++ b/tactics/setoid_replace.ml
@@ -6,7 +6,7 @@
 (*         *       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 $ *)
+(* $Id: setoid_replace.ml 9331 2006-11-01 09:36:06Z herbelin $ *)
 
 open Tacmach
 open Proof_type
@@ -22,6 +22,8 @@ open Util
 open Pp
 open Printer
 open Environ
+open Clenv
+open Unification
 open Tactics 
 open Tacticals
 open Vernacexpr
@@ -29,106 +31,365 @@ open Safe_typing
 open Nametab
 open Decl_kinds
 open Constrintern
-
-type setoid =
-    { set_a : constr;
-      set_aeq : constr;
-      set_th : constr
+open Mod_subst
+
+let replace = ref (fun _ _ _ -> assert false)
+let register_replace f = replace := f
+
+let general_rewrite = ref (fun _ _ -> assert false)
+let register_general_rewrite f = general_rewrite := f
+
+(* util function; it should be in util.mli *)
+let prlist_with_sepi sep elem =
+ let rec aux n =
+  function
+   | []   -> mt ()
+   | [h]  -> elem n h
+   | h::t ->
+      let e = elem n h and s = sep() and r = aux (n+1) t in
+      e ++ s ++ r
+ in
+  aux 1
+
+type relation =
+   { rel_a: constr ;
+     rel_aeq: constr;
+     rel_refl: constr option;
+     rel_sym: constr option;
+     rel_trans : constr option;
+     rel_quantifiers_no: int  (* it helps unification *);
+     rel_X_relation_class: constr;
+     rel_Xreflexive_relation_class: constr
+   }
+
+type 'a relation_class =
+   Relation of 'a            (* the rel_aeq of the relation or the relation   *)
+ | Leibniz of constr option  (* the carrier (if eq is partially instantiated) *)
+
+type 'a morphism =
+    { args : (bool option * 'a relation_class) list;
+      output : 'a relation_class;
+      lem : constr;
+      morphism_theory : constr
     }
 
-type morphism =
-    { lem : constr;
-      profil : bool list;
-      arg_types : constr list;
-      lem2 : constr option
+type funct =
+    { f_args : constr list;
+      f_output : constr
     }
 
+type morphism_class =
+   ACMorphism of relation morphism
+ | ACFunction of funct
+
+let subst_mps_in_relation_class subst =
+ function
+    Relation  t -> Relation  (subst_mps subst t)
+  | Leibniz t -> Leibniz (option_map (subst_mps subst) t) 
+
+let subst_mps_in_argument_class subst (variance,rel) =
+ variance, subst_mps_in_relation_class subst rel
+
+let constr_relation_class_of_relation_relation_class =
+ function
+    Relation relation -> Relation relation.rel_aeq
+  | Leibniz t -> Leibniz t
+ 
+
 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 gen_constant dir s = Coqlib.gen_constant "Setoid_replace" dir s
+let reference dir s = Coqlib.gen_reference "Setoid_replace" ("Setoids"::dir) s
+let eval_reference dir s = EvalConstRef (destConst (constant dir s))
+let eval_init_reference dir s = EvalConstRef (destConst (gen_constant ("Init"::dir) s))
 
 let current_constant id =
   try
     global_reference id
   with Not_found ->
-    anomaly ("Setoid: cannot find "^(string_of_id id))
+    anomaly ("Setoid: cannot find " ^ (string_of_id id))
 
-(* Setoid_theory *)
+(* From Setoid.v *)
 
-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 **********************)
+let coq_reflexive =
+ lazy(gen_constant ["Relations"; "Relation_Definitions"] "reflexive")
+let coq_symmetric =
+ lazy(gen_constant ["Relations"; "Relation_Definitions"] "symmetric")
+let coq_transitive =
+ lazy(gen_constant ["Relations"; "Relation_Definitions"] "transitive")
+let coq_relation =
+ lazy(gen_constant ["Relations"; "Relation_Definitions"] "relation")
 
+let coq_Relation_Class = lazy(constant ["Setoid"] "Relation_Class")
+let coq_Argument_Class = lazy(constant ["Setoid"] "Argument_Class")
+let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory")
+let coq_Morphism_Theory = lazy(constant ["Setoid"] "Morphism_Theory")
+let coq_Build_Morphism_Theory= lazy(constant ["Setoid"] "Build_Morphism_Theory")
+let coq_Compat = lazy(constant ["Setoid"] "Compat")
 
-(* Setoids are stored in a table which is synchronised with the Reset mechanism. *)
+let coq_AsymmetricReflexive = lazy(constant ["Setoid"] "AsymmetricReflexive")
+let coq_SymmetricReflexive = lazy(constant ["Setoid"] "SymmetricReflexive")
+let coq_SymmetricAreflexive = lazy(constant ["Setoid"] "SymmetricAreflexive")
+let coq_AsymmetricAreflexive = lazy(constant ["Setoid"] "AsymmetricAreflexive")
+let coq_Leibniz = lazy(constant ["Setoid"] "Leibniz")
 
-module Cmap = Map.Make(struct type t = constr let compare = compare end)
+let coq_RAsymmetric = lazy(constant ["Setoid"] "RAsymmetric")
+let coq_RSymmetric = lazy(constant ["Setoid"] "RSymmetric")
+let coq_RLeibniz = lazy(constant ["Setoid"] "RLeibniz")
 
-let setoid_table = ref Gmap.empty
+let coq_ASymmetric = lazy(constant ["Setoid"] "ASymmetric")
+let coq_AAsymmetric = lazy(constant ["Setoid"] "AAsymmetric")
 
-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 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 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
+let coq_variance = lazy(constant ["Setoid"] "variance")
+let coq_Covariant = lazy(constant ["Setoid"] "Covariant")
+let coq_Contravariant = lazy(constant ["Setoid"] "Contravariant")
+let coq_Left2Right = lazy(constant ["Setoid"] "Left2Right")
+let coq_Right2Left = lazy(constant ["Setoid"] "Right2Left")
+let coq_MSNone = lazy(constant ["Setoid"] "MSNone")
+let coq_MSCovariant = lazy(constant ["Setoid"] "MSCovariant")
+let coq_MSContravariant = lazy(constant ["Setoid"] "MSContravariant")
+
+let coq_singl = lazy(constant ["Setoid"] "singl")
+let coq_cons = lazy(constant ["Setoid"] "necons")
+
+let coq_equality_morphism_of_asymmetric_areflexive_transitive_relation =
+ lazy(constant ["Setoid"]
+  "equality_morphism_of_asymmetric_areflexive_transitive_relation")
+let coq_equality_morphism_of_symmetric_areflexive_transitive_relation =
+ lazy(constant ["Setoid"]
+  "equality_morphism_of_symmetric_areflexive_transitive_relation")
+let coq_equality_morphism_of_asymmetric_reflexive_transitive_relation =
+ lazy(constant ["Setoid"]
+  "equality_morphism_of_asymmetric_reflexive_transitive_relation")
+let coq_equality_morphism_of_symmetric_reflexive_transitive_relation =
+ lazy(constant ["Setoid"]
+  "equality_morphism_of_symmetric_reflexive_transitive_relation")
+let coq_make_compatibility_goal =
+ lazy(constant ["Setoid"] "make_compatibility_goal")
+let coq_make_compatibility_goal_eval_ref =
+ lazy(eval_reference ["Setoid"] "make_compatibility_goal")
+let coq_make_compatibility_goal_aux_eval_ref =
+ lazy(eval_reference ["Setoid"] "make_compatibility_goal_aux")
+
+let coq_App = lazy(constant ["Setoid"] "App")
+let coq_ToReplace = lazy(constant ["Setoid"] "ToReplace")
+let coq_ToKeep = lazy(constant ["Setoid"] "ToKeep")
+let coq_ProperElementToKeep = lazy(constant ["Setoid"] "ProperElementToKeep")
+let coq_fcl_singl = lazy(constant ["Setoid"] "fcl_singl")
+let coq_fcl_cons = lazy(constant ["Setoid"] "fcl_cons")
+
+let coq_setoid_rewrite = lazy(constant ["Setoid"] "setoid_rewrite")
+let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1")
+let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2")
+let coq_unit = lazy(gen_constant ["Init"; "Datatypes"] "unit")
+let coq_tt = lazy(gen_constant ["Init"; "Datatypes"] "tt")
+let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
+
+let coq_morphism_theory_of_function =
+ lazy(constant ["Setoid"] "morphism_theory_of_function")
+let coq_morphism_theory_of_predicate =
+ lazy(constant ["Setoid"] "morphism_theory_of_predicate")
+let coq_relation_of_relation_class =
+ lazy(eval_reference ["Setoid"] "relation_of_relation_class")
+let coq_directed_relation_of_relation_class =
+ lazy(eval_reference ["Setoid"] "directed_relation_of_relation_class")
+let coq_interp = lazy(eval_reference ["Setoid"] "interp")
+let coq_Morphism_Context_rect2 =
+ lazy(eval_reference ["Setoid"] "Morphism_Context_rect2")
+let coq_iff = lazy(gen_constant ["Init";"Logic"] "iff")
+let coq_impl = lazy(constant ["Setoid"] "impl")
+
+
+(************************* Table of declared relations **********************)
+
+
+(* Relations are stored in a table which is synchronised with the Reset mechanism. *)
+
+let relation_table = ref Gmap.empty
+
+let relation_table_add (s,th) = relation_table := Gmap.add s th !relation_table
+let relation_table_find s = Gmap.find s !relation_table
+let relation_table_mem s = Gmap.mem s !relation_table
+
+let prrelation s =
+ str "(" ++ pr_lconstr s.rel_a ++ str "," ++ pr_lconstr s.rel_aeq ++ str ")"
+
+let prrelation_class =
+ function
+    Relation eq  ->
+     (try prrelation (relation_table_find eq)
+      with Not_found ->
+       str "[[ Error: " ++ pr_lconstr eq ++
+        str " is not registered as a relation ]]")
+  | Leibniz (Some ty) -> pr_lconstr ty
+  | Leibniz None -> str "_"
+
+let prmorphism_argument_gen prrelation (variance,rel) =
+ prrelation rel ++
+  match variance with
+     None -> str " ==> "
+   | Some true -> str " ++> "
+   | Some false -> str " --> "
+
+let prargument_class = prmorphism_argument_gen prrelation_class
+
+let pr_morphism_signature (l,c) =
+ prlist (prmorphism_argument_gen Ppconstr.pr_constr_expr) l ++
+  Ppconstr.pr_constr_expr c
+
+let prmorphism k m =
+  pr_lconstr k ++ str ": " ++
+  prlist prargument_class m.args ++
+  prrelation_class m.output
+
+
+(* A function that gives back the only relation_class on a given carrier *)
+(*CSC: this implementation is really inefficient. I should define a new
+  map to make it efficient. However, is this really worth of? *)
+let default_relation_for_carrier ?(filter=fun _ -> true) a =
+ let rng = Gmap.rng !relation_table in
+ match List.filter (fun ({rel_a=rel_a} as r) -> rel_a = a && filter r) rng with
+    [] -> Leibniz (Some a)
+  | relation::tl ->
+     if tl <> [] then
+      ppnl
+       (str "Warning: There are several relations on the carrier \"" ++
+         pr_lconstr a ++ str "\". The relation " ++ prrelation relation ++
+         str " is chosen.") ;
+     Relation relation
+
+let find_relation_class rel =
+ try Relation (relation_table_find rel)
+ with
+  Not_found ->
+   let rel = Reduction.whd_betadeltaiota (Global.env ()) rel in
+   match kind_of_term rel with
+    | App (eq,[|ty|]) when eq_constr eq (Lazy.force coq_eq) -> Leibniz (Some ty)
+    | _ when eq_constr rel (Lazy.force coq_eq) -> Leibniz None
+    | _ -> raise Not_found
+
+let coq_iff_relation = lazy (find_relation_class (Lazy.force coq_iff))
+let coq_impl_relation = lazy (find_relation_class (Lazy.force coq_impl))
+
+let relation_morphism_of_constr_morphism =
+ let relation_relation_class_of_constr_relation_class =
+  function
+     Leibniz t -> Leibniz t
+   | Relation aeq ->
+      Relation (try relation_table_find aeq with Not_found -> assert false)
+ in
+  function mor ->
+   let args' =
+    List.map
+     (fun (variance,rel) ->
+       variance, relation_relation_class_of_constr_relation_class rel
+     ) mor.args in
+   let output' = relation_relation_class_of_constr_relation_class mor.output in
+    {mor with args=args' ; output=output'}
+
+let subst_relation subst relation = 
+  let rel_a' = subst_mps subst relation.rel_a in
+  let rel_aeq' = subst_mps subst relation.rel_aeq in
+  let rel_refl' = option_map (subst_mps subst) relation.rel_refl in
+  let rel_sym' = option_map (subst_mps subst) relation.rel_sym in
+  let rel_trans' = option_map (subst_mps subst) relation.rel_trans in
+  let rel_X_relation_class' = subst_mps subst relation.rel_X_relation_class in
+  let rel_Xreflexive_relation_class' =
+   subst_mps subst relation.rel_Xreflexive_relation_class
+  in
+    if rel_a' == relation.rel_a
+      && rel_aeq' == relation.rel_aeq
+      && rel_refl' == relation.rel_refl
+      && rel_sym' == relation.rel_sym
+      && rel_trans' == relation.rel_trans
+      && rel_X_relation_class' == relation.rel_X_relation_class
+      && rel_Xreflexive_relation_class'==relation.rel_Xreflexive_relation_class
     then
-      setoid
+      relation
     else
-      { set_a = set_a' ;
-	set_aeq = set_aeq' ;
-	set_th = set_th' ;
+      { rel_a = rel_a' ;
+        rel_aeq = rel_aeq' ;
+        rel_refl = rel_refl' ;
+        rel_sym = rel_sym';
+        rel_trans = rel_trans';
+        rel_quantifiers_no = relation.rel_quantifiers_no;
+        rel_X_relation_class = rel_X_relation_class';
+        rel_Xreflexive_relation_class = rel_Xreflexive_relation_class'
       }
       
-let equiv_list () = List.map (fun x -> x.set_aeq) (Gmap.rng !setoid_table)
+let equiv_list () = List.map (fun x -> x.rel_aeq) (Gmap.rng !relation_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.declare_summary "relation-table"
+    { Summary.freeze_function = (fun () -> !relation_table);
+      Summary.unfreeze_function = (fun t -> relation_table := t);
+      Summary.init_function = (fun () -> relation_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)
+(* Declare a new type of object in the environment : "relation-theory". *)
+
+let (relation_to_obj, obj_to_relation)=
+  let cache_set (_,(s, th)) =
+   let th' =
+    if relation_table_mem s then
+     begin
+      let old_relation = relation_table_find s in
+       let th' =
+        {th with rel_sym =
+          match th.rel_sym with
+             None -> old_relation.rel_sym
+           | Some t -> Some t} in
+        ppnl
+         (str "Warning: The relation " ++ prrelation th' ++
+          str " is redeclared. The new declaration" ++
+           (match th'.rel_refl with
+              None -> str ""
+            | Some t -> str " (reflevity proved by " ++ pr_lconstr t) ++
+           (match th'.rel_sym with
+               None -> str ""
+             | Some t ->
+                (if th'.rel_refl = None then str " (" else str " and ") ++
+                str "symmetry proved by " ++ pr_lconstr t) ++
+           (if th'.rel_refl <> None && th'.rel_sym <> None then
+             str ")" else str "") ++
+           str " replaces the old declaration" ++
+           (match old_relation.rel_refl with
+              None -> str ""
+            | Some t -> str " (reflevity proved by " ++ pr_lconstr t) ++
+           (match old_relation.rel_sym with
+               None -> str ""
+             | Some t ->
+                (if old_relation.rel_refl = None then
+                  str " (" else str " and ") ++
+                str "symmetry proved by " ++ pr_lconstr t) ++
+           (if old_relation.rel_refl <> None && old_relation.rel_sym <> None
+            then str ")" else str "") ++
+           str ".");
+        th'
+     end
+    else
+     th
+   in
+    relation_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
+    let th' = subst_relation subst th in
       if s' == s && th' == th then obj else
-	(s',th')
+        (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}
+    declare_object {(default_object "relation-theory") with
+                      cache_function = cache_set;
+                      load_function = (fun i o -> cache_set o);
+                      subst_function = subst_set;
+                      classify_function = (fun (_,x) -> Substitute x);
+                      export_function = export_set}
 
 (******************************* Table of declared morphisms ********************)
 
@@ -136,24 +397,56 @@ let (setoid_to_obj, obj_to_setoid)=
 
 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 morphism_table_add (m,c) =
+ let old =
+  try
+   morphism_table_find m
+  with
+   Not_found -> []
+ in
+  try
+   let old_morph =
+    List.find
+     (function mor -> mor.args = c.args && mor.output = c.output) old
+   in
+    ppnl
+     (str "Warning: The morphism " ++ prmorphism m old_morph ++
+      str " is redeclared. " ++
+      str "The new declaration whose compatibility is proved by " ++
+       pr_lconstr c.lem ++ str " replaces the old declaration whose" ++
+       str " compatibility was proved by " ++
+       pr_lconstr old_morph.lem ++ str ".")
+  with
+   Not_found -> morphism_table := Gmap.add m (c::old) !morphism_table
+
+let default_morphism ?(filter=fun _ -> true) m =
+  match List.filter filter (morphism_table_find m) with
+      [] -> raise Not_found
+    | m1::ml ->
+        if ml <> [] then
+          ppnl
+            (str "Warning: There are several morphisms associated to \"" ++
+            pr_lconstr m ++ str"\". Morphism " ++ prmorphism m m1 ++
+            str " is randomly chosen.");
+        relation_morphism_of_constr_morphism m1
 
 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
+  let args' = list_smartmap (subst_mps_in_argument_class subst) morph.args in
+  let output' = subst_mps_in_relation_class subst morph.output in
+  let morphism_theory' = subst_mps subst morph.morphism_theory in
     if lem' == morph.lem
-      && arg_types' == morph.arg_types
-      && lem2' == morph.lem2
+      && args' == morph.args
+      && output' == morph.output
+      && morphism_theory' == morph.morphism_theory
     then
       morph
     else
-      { lem = lem' ;
-	profil = morph.profil ;
-	arg_types = arg_types' ;
-	lem2 = lem2' ;
+      { args = args' ;
+        output = output' ;
+        lem = lem' ;
+        morphism_theory = morphism_theory'
       }
 
 
@@ -173,139 +466,42 @@ let (morphism_to_obj, obj_to_morphism)=
     let m' = subst_mps subst m in
     let c' = subst_morph subst c in
       if m' == m && c' == c then obj else
-	(m',c')
+        (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)
+                      cache_function = cache_set;
+                      load_function = (fun i o -> cache_set o);
+                      subst_function = subst_set;
+                      classify_function = (fun (_,x) -> Substitute x);
+                      export_function = export_set}
+
+(************************** Printing relations and morphisms **********************)
+
+let print_setoids () =
+  Gmap.iter
+   (fun k relation ->
+     assert (k=relation.rel_aeq) ;
+     ppnl (str"Relation " ++ prrelation relation ++ str";" ++
+      (match relation.rel_refl with
+          None -> str ""
+        | Some t -> str" reflexivity proved by " ++ pr_lconstr t) ++
+      (match relation.rel_sym with
+          None -> str ""
+        | Some t -> str " symmetry proved by " ++ pr_lconstr t) ++
+      (match relation.rel_trans with
+          None -> str ""
+        | Some t -> str " transitivity proved by " ++ pr_lconstr t)))
+   !relation_table ;
+  Gmap.iter
+   (fun k l ->
+     List.iter
+      (fun ({lem=lem} as mor) ->
+        ppnl (str "Morphism " ++ prmorphism k mor ++
+        str ". Compatibility proved by " ++
+        pr_lconstr lem ++ str "."))
+      l) !morphism_table
+;;
 
 (***************** Adding a morphism to the database ****************************)
 
@@ -314,8 +510,8 @@ let add_setoid a aeq th =
 
 let edited = ref Gmap.empty
 
-let new_edited id m profil = 
-  edited := Gmap.add id (m,profil)  !edited
+let new_edited id m = 
+  edited := Gmap.add id m !edited
 
 let is_edited id =
   Gmap.mem id !edited
@@ -326,361 +522,1486 @@ let no_more_edited id =
 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)) 
+(* also returns the triple (args_ty_quantifiers_rev,real_args_ty,real_output)
+   where the args_ty and the output are delifted *)
+let check_is_dependent n args_ty output =
+ let m = List.length args_ty - n in
+ let args_ty_quantifiers, args_ty = Util.list_chop n args_ty in
+  let rec aux m t =
+   match kind_of_term t with
+      Prod (n,s,t) when m > 0 ->
+       if not (dependent (mkRel 1) t) then
+        let args,out = aux (m - 1) (subst1 (mkRel 1) (* dummy *) t) in
+         s::args,out
+       else
+        errorlabstrm "New Morphism"
+         (str "The morphism is not a quantified non dependent product.")
+    | _ -> [],t
+  in
+   let ty = compose_prod (List.rev args_ty) output in
+   let args_ty, output = aux m ty in
+   List.rev args_ty_quantifiers, args_ty, output
+
+let cic_relation_class_of_X_relation typ value =
+ function
+    {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} ->
+     mkApp ((Lazy.force coq_AsymmetricReflexive),
+      [| typ ; value ; rel_a ; rel_aeq; refl |])
+  | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} ->
+     mkApp ((Lazy.force coq_SymmetricReflexive),
+      [| typ ; rel_a ; rel_aeq; sym ; refl |])
+  | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} ->
+     mkApp ((Lazy.force coq_AsymmetricAreflexive),
+      [| typ ; value ; rel_a ; rel_aeq |])
+  | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} ->
+     mkApp ((Lazy.force coq_SymmetricAreflexive),
+      [| typ ; rel_a ; rel_aeq; sym |])
+
+let cic_relation_class_of_X_relation_class typ value =
+ function
+    Relation {rel_X_relation_class=x_relation_class} ->
+     mkApp (x_relation_class, [| typ ; value |])
+  | Leibniz (Some t) ->
+     mkApp ((Lazy.force coq_Leibniz), [| typ ; t |])
+  | Leibniz None -> assert false
+
+
+let cic_precise_relation_class_of_relation =
+ function
+    {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} ->
+      mkApp ((Lazy.force coq_RAsymmetric), [| rel_a ; rel_aeq; refl |])
+  | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} ->
+      mkApp ((Lazy.force coq_RSymmetric), [| rel_a ; rel_aeq; sym ; refl |])
+  | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} ->
+      mkApp ((Lazy.force coq_AAsymmetric), [| rel_a ; rel_aeq |])
+  | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} ->
+      mkApp ((Lazy.force coq_ASymmetric), [| rel_a ; rel_aeq; sym |])
+
+let cic_precise_relation_class_of_relation_class =
+ function
+    Relation
+     {rel_aeq=rel_aeq; rel_Xreflexive_relation_class=lem; rel_refl=rel_refl }
+     ->
+      rel_aeq,lem,not(rel_refl=None)
+  | Leibniz (Some t) ->
+     mkApp ((Lazy.force coq_eq), [| t |]),
+      mkApp ((Lazy.force coq_RLeibniz), [| t |]), true
+  | Leibniz None -> assert false
+
+let cic_relation_class_of_relation_class rel =
+ cic_relation_class_of_X_relation_class
+  (Lazy.force coq_unit) (Lazy.force coq_tt) rel
+
+let cic_argument_class_of_argument_class (variance,arg) =
+ let coq_variant_value =
+  match variance with
+     None -> (Lazy.force coq_Covariant) (* dummy value, it won't be used *)
+   | Some true -> (Lazy.force coq_Covariant)
+   | Some false -> (Lazy.force coq_Contravariant)
+ in
+  cic_relation_class_of_X_relation_class (Lazy.force coq_variance)
+   coq_variant_value arg
+
+let cic_arguments_of_argument_class_list args =
+ let rec aux =
+  function
+     [] -> assert false
+   | [last] ->
+      mkApp ((Lazy.force coq_singl), [| Lazy.force coq_Argument_Class; last |])
+   | he::tl ->
+      mkApp ((Lazy.force coq_cons),
+       [| Lazy.force coq_Argument_Class; he ; aux tl |])
+ in
+  aux (List.map cic_argument_class_of_argument_class args)
+
+let gen_compat_lemma_statement quantifiers_rev output args m =
+ let output = cic_relation_class_of_relation_class output in
+ let args = cic_arguments_of_argument_class_list args in
+  args, output,
+   compose_prod quantifiers_rev
+    (mkApp ((Lazy.force coq_make_compatibility_goal), [| args ; output ; m |]))
+
+let morphism_theory_id_of_morphism_proof_id id =
+ id_of_string (string_of_id id ^ "_morphism_theory")
+
+(* apply_to_rels c [l1 ; ... ; ln] returns (c Rel1 ... reln) *)
+let apply_to_rels c l =
+ if l = [] then c
+ else
+  let len = List.length l in
+   applistc c (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 l)
+
+let apply_to_relation subst rel =
+ if Array.length subst = 0 then rel
+ else
+  let new_quantifiers_no = rel.rel_quantifiers_no - Array.length subst in
+   assert (new_quantifiers_no >= 0) ;
+   { rel_a = mkApp (rel.rel_a, subst) ;
+     rel_aeq = mkApp (rel.rel_aeq, subst) ;
+     rel_refl = option_map (fun c -> mkApp (c,subst)) rel.rel_refl ; 
+     rel_sym = option_map (fun c -> mkApp (c,subst)) rel.rel_sym;
+     rel_trans = option_map (fun c -> mkApp (c,subst)) rel.rel_trans;
+     rel_quantifiers_no = new_quantifiers_no;
+     rel_X_relation_class = mkApp (rel.rel_X_relation_class, subst);
+     rel_Xreflexive_relation_class =
+      mkApp (rel.rel_Xreflexive_relation_class, subst) }
+
+let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) =
+ let lem =
+  match lemma_infos with
+     None ->
+      (* the Morphism_Theory object has already been created *)
+      let applied_args =
+       let len = List.length quantifiers_rev in
+       let subst =
+        Array.of_list
+         (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 quantifiers_rev)
+       in
+        List.map
+         (fun (v,rel) ->
+           match rel with
+              Leibniz (Some t) ->
+               assert (subst=[||]);
+               v, Leibniz (Some t)
+            | Leibniz None ->
+               assert (Array.length subst = 1);
+               v, Leibniz (Some (subst.(0)))
+            | Relation rel -> v, Relation (apply_to_relation subst rel)) args
+      in
+       compose_lam quantifiers_rev
+        (mkApp (Lazy.force coq_Compat,
+          [| cic_arguments_of_argument_class_list applied_args;
+             cic_relation_class_of_relation_class output;
+             apply_to_rels (current_constant mor_name) quantifiers_rev |]))
+   | Some (lem_name,argsconstr,outputconstr) ->
+      (* only the compatibility has been proved; we need to declare the
+         Morphism_Theory object *)
+     let mext = current_constant lem_name in
+     ignore (
+      Declare.declare_internal_constant mor_name
+       (DefinitionEntry
+         {const_entry_body =
+           compose_lam quantifiers_rev
+            (mkApp ((Lazy.force coq_Build_Morphism_Theory),
+              [| argsconstr; outputconstr; apply_to_rels m quantifiers_rev ;
+                  apply_to_rels mext quantifiers_rev |]));
+          const_entry_type = None;
+          const_entry_opaque = false;
+          const_entry_boxed = Options.boxed_definitions()},
+	IsDefinition Definition)) ;
+     mext 
+ in
+  let mmor = current_constant mor_name in
+  let args_constr =
+   List.map
+    (fun (variance,arg) ->
+      variance, constr_relation_class_of_relation_relation_class arg) args in
+  let output_constr = constr_relation_class_of_relation_relation_class output in
+   Lib.add_anonymous_leaf
+    (morphism_to_obj (m, 
+      { args = args_constr;
+        output = output_constr;
+        lem = lem;
+        morphism_theory = mmor }));
+   Options.if_verbose ppnl (pr_lconstr m ++ str " is registered as a morphism")   
+
+(* first order matching with a bit of conversion *)
+let unify_relation_carrier_with_type env rel t =
+ let raise_error quantifiers_no =
+  errorlabstrm "New Morphism"
+   (str "One morphism argument or its output has type " ++ pr_lconstr t ++
+    str " but the signature requires an argument of type \"" ++
+    pr_lconstr rel.rel_a ++ str " " ++ prvect_with_sep pr_spc (fun _ -> str  "?")
+     (Array.make quantifiers_no 0) ++ str "\"") in
+ let args =
+  match kind_of_term t with
+     App (he',args') ->
+      let argsno = Array.length args' - rel.rel_quantifiers_no in
+      let args1 = Array.sub args' 0 argsno in
+      let args2 = Array.sub args' argsno rel.rel_quantifiers_no in
+       if is_conv env Evd.empty rel.rel_a (mkApp (he',args1)) then
+        args2
+       else
+        raise_error rel.rel_quantifiers_no
+   | _  ->
+     if rel.rel_quantifiers_no = 0 && is_conv env Evd.empty rel.rel_a t then
+      [||] 
+     else
+      begin
+        let evars,args,instantiated_rel_a =
+         let ty = Typing.type_of env Evd.empty rel.rel_a in
+         let evd = Evd.create_evar_defs Evd.empty in
+         let evars,args,concl =
+          Clenv.clenv_environments_evars env evd
+           (Some rel.rel_quantifiers_no) ty
+         in
+          evars, args,
+          nf_betaiota
+           (match args with [] -> rel.rel_a | _ -> applist (rel.rel_a,args))
+        in
+         let evars' =
+          w_unify true (*??? or false? *) env Reduction.CONV (*??? or cumul? *)
+           ~mod_delta:true (*??? or true? *) t instantiated_rel_a evars in
+         let args' =
+          List.map (Reductionops.nf_evar (Evd.evars_of evars')) args
+         in
+          Array.of_list args'
+      end
+ in
+  apply_to_relation args rel
+
+let unify_relation_class_carrier_with_type env rel t =
+ match rel with
+    Leibniz (Some t') ->
+     if is_conv env Evd.empty t t' then
+      rel
+     else
+      errorlabstrm "New Morphism"
+       (str "One morphism argument or its output has type " ++ pr_lconstr t ++
+        str " but the signature requires an argument of type " ++
+        pr_lconstr t')
+  | Leibniz None -> Leibniz (Some t)
+  | Relation rel -> Relation (unify_relation_carrier_with_type env rel t)
+
+exception Impossible
+
+(* first order matching with a bit of conversion *)
+(* Note: the type checking operations performed by the function could  *)
+(* be done once and for all abstracting the morphism structure using   *)
+(* the quantifiers. Would the new structure be more suited than the    *)
+(* existent one for other tasks to? (e.g. pretty printing would expose *)
+(* much more information: is it ok or is it too much information?)     *)
+let unify_morphism_with_arguments gl (c,av)
+     {args=args; output=output; lem=lem; morphism_theory=morphism_theory} t
+=
+ let avlen = Array.length av in 
+ let argsno = List.length args in
+ if avlen < argsno then raise Impossible; (* partial application *)
+ let al = Array.to_list av in
+ let quantifiers,al' = Util.list_chop (avlen - argsno) al in
+ let quantifiersv = Array.of_list quantifiers in
+ let c' = mkApp (c,quantifiersv) in
+ if dependent t c' then raise Impossible; 
+ (* these are pf_type_of we could avoid *)
+ let al'_type = List.map (Tacmach.pf_type_of gl) al' in
+ let args' =
+   List.map2
+     (fun (var,rel) ty ->
+	var,unify_relation_class_carrier_with_type (pf_env gl) rel ty)
+     args al'_type in
+ (* this is another pf_type_of we could avoid *)
+ let ty = Tacmach.pf_type_of gl (mkApp (c,av)) in
+ let output' = unify_relation_class_carrier_with_type (pf_env gl) output ty in
+ let lem' = mkApp (lem,quantifiersv) in
+ let morphism_theory' = mkApp (morphism_theory,quantifiersv) in
+ ({args=args'; output=output'; lem=lem'; morphism_theory=morphism_theory'},
+  c',Array.of_list al')
+
+let new_morphism m signature id hook =
+ if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
+  errorlabstrm "New Morphism" (pr_id id ++ str " already exists")
+ else
+  let env = Global.env() in
+  let typeofm = Typing.type_of env Evd.empty m in
+  let typ = clos_norm_flags Closure.betaiotazeta empty_env Evd.empty typeofm in
+  let argsrev, output =
+    match signature with
+	None -> decompose_prod typ
+      | Some (_,output') ->
+	  (* the carrier of the relation output' can be a Prod ==>
+             we must uncurry on the fly output.
+             E.g: A -> B -> C vs        A -> (B -> C)
+             args   output     args     output
+	  *)
+	  let rel = 
+	    try find_relation_class output' 
+	    with Not_found -> errorlabstrm "Add Morphism"
+	      (str "Not a valid signature: " ++ pr_lconstr output' ++
+		  str " is neither a registered relation nor the Leibniz " ++
+		  str " equality.") in
+	  let rel_a,rel_quantifiers_no =
+            match rel with
+		Relation rel -> rel.rel_a, rel.rel_quantifiers_no
+              | Leibniz (Some t) -> t, 0
+              | Leibniz None -> assert false in
+	  let rel_a_n =
+            clos_norm_flags Closure.betaiotazeta empty_env Evd.empty rel_a in
+	    try
+              let _,output_rel_a_n = decompose_lam_n rel_quantifiers_no rel_a_n in
+              let argsrev,_ = decompose_prod output_rel_a_n in
+              let n = List.length argsrev in
+              let argsrev',_ = decompose_prod typ in
+              let m = List.length argsrev' in
+		decompose_prod_n (m - n) typ
+	    with UserError(_,_) ->
+              (* decompose_lam_n failed. This may happen when rel_a is an axiom,
+		 a constructor, an inductive type, etc. *)
+              decompose_prod typ
+  in
+  let args_ty = List.rev argsrev in
+  let args_ty_len = List.length (args_ty) in
+  let args_ty_quantifiers_rev,args,args_instance,output,output_instance =
+    match signature with
+	None ->
+	  if args_ty = [] then
+            errorlabstrm "New Morphism"
+              (str "The term " ++ pr_lconstr m ++ str " has type " ++
+		  pr_lconstr typeofm ++ str " that is not a product.") ;
+	  ignore (check_is_dependent 0 args_ty output) ;
+	  let args =
+            List.map
+              (fun (_,ty) -> None,default_relation_for_carrier ty) args_ty in
+	  let output = default_relation_for_carrier output in
+            [],args,args,output,output
+      | Some (args,output') ->
+	  assert (args <> []);
+	  let number_of_arguments = List.length args in
+	  let number_of_quantifiers = args_ty_len - number_of_arguments in
+	    if number_of_quantifiers < 0 then
+              errorlabstrm "New Morphism"
+		(str "The morphism " ++ pr_lconstr m ++ str " has type " ++
+		    pr_lconstr typeofm ++ str " that attends at most " ++ int args_ty_len ++
+		    str " arguments. The signature that you specified requires " ++
+		    int number_of_arguments ++ str " arguments.")
+	    else
+              begin
+		(* the real_args_ty returned are already delifted *)
+		let args_ty_quantifiers_rev, real_args_ty, real_output =
+		  check_is_dependent number_of_quantifiers args_ty output in
+		let quantifiers_rel_context =
+		  List.map (fun (n,t) -> n,None,t) args_ty_quantifiers_rev in
+		let env = push_rel_context quantifiers_rel_context env in
+		let find_relation_class t real_t =
+		  try
+		    let rel = find_relation_class t in
+		      rel, unify_relation_class_carrier_with_type env rel real_t
+		  with Not_found ->
+		    errorlabstrm "Add Morphism"
+		      (str "Not a valid signature: " ++ pr_lconstr t ++
+			  str " is neither a registered relation nor the Leibniz " ++
+			  str " equality.")
+		in
+		let find_relation_class_v (variance,t) real_t =
+		  let relation,relation_instance = find_relation_class t real_t in
+		    match relation, variance with
+			Leibniz _, None
+		      | Relation {rel_sym = Some _}, None
+		      | Relation {rel_sym = None}, Some _ ->
+			  (variance, relation), (variance, relation_instance)
+		      | Relation {rel_sym = None},None ->
+			  errorlabstrm "Add Morphism"
+			    (str "You must specify the variance in each argument " ++
+				str "whose relation is asymmetric.")
+		      | Leibniz _, Some _
+		      | Relation {rel_sym = Some _}, Some _ ->
+			  errorlabstrm "Add Morphism"
+			    (str "You cannot specify the variance of an argument " ++
+				str "whose relation is symmetric.")
+		in
+		let args, args_instance =
+		  List.split
+		    (List.map2 find_relation_class_v args real_args_ty) in
+		let output,output_instance= find_relation_class output' real_output in
+		  args_ty_quantifiers_rev, args, args_instance, output, output_instance
+              end
+  in
+  let argsconstr,outputconstr,lem =
+    gen_compat_lemma_statement args_ty_quantifiers_rev output_instance
+      args_instance (apply_to_rels m args_ty_quantifiers_rev) in
+    (* "unfold make_compatibility_goal" *)
+  let lem =
+    Reductionops.clos_norm_flags
+      (Closure.unfold_red (Lazy.force coq_make_compatibility_goal_eval_ref))
+      env Evd.empty lem in
+    (* "unfold make_compatibility_goal_aux" *)
+  let lem =
+    Reductionops.clos_norm_flags
+      (Closure.unfold_red(Lazy.force coq_make_compatibility_goal_aux_eval_ref))
+      env Evd.empty lem in
+    (* "simpl" *)
+  let lem = Tacred.nf env Evd.empty lem in
+    if Lib.is_modtype () then
+      begin
+	ignore
+	  (Declare.declare_internal_constant id
+              (ParameterEntry lem, IsAssumption Logical)) ;
+	let mor_name = morphism_theory_id_of_morphism_proof_id id in
+	let lemma_infos = Some (id,argsconstr,outputconstr) in
+	  add_morphism lemma_infos mor_name
+            (m,args_ty_quantifiers_rev,args,output)
+      end
+    else
+      begin
+	new_edited id
+	  (m,args_ty_quantifiers_rev,args,argsconstr,output,outputconstr);
+	Pfedit.start_proof id (Global, 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 =
+	Options.if_verbose msg (Printer.pr_open_subgoals ());
+      end
+
+let morphism_hook _ ref =
   let pf_id = id_of_global ref in
+  let mor_id = morphism_theory_id_of_morphism_proof_id pf_id in
+  let (m,quantifiers_rev,args,argsconstr,output,outputconstr) =
+   what_edited pf_id in
   if (is_edited pf_id)
   then 
-    (add_morphism pf_id (what_edited pf_id); no_more_edited pf_id)
+   begin
+    add_morphism (Some (pf_id,argsconstr,outputconstr)) mor_id
+     (m,quantifiers_rev,args,output) ;
+    no_more_edited pf_id
+   end
+
+type morphism_signature =
+ (bool option * Topconstr.constr_expr) list * Topconstr.constr_expr
+
+let new_named_morphism id m sign =
+ let sign =
+  match sign with
+     None -> None
+   | Some (args,out) ->
+      Some
+       (List.map (fun (variance,ty) -> variance, constr_of ty) args,
+        constr_of out)
+ in
+  new_morphism (constr_of m) sign id morphism_hook
+
+(************************** Adding a relation to the database *********************)
+
+let check_a env a =
+ let typ = Typing.type_of env Evd.empty a in
+ let a_quantifiers_rev,_ = Reduction.dest_arity env typ in
+  a_quantifiers_rev
+
+let check_eq env a_quantifiers_rev a aeq =
+ let typ =
+  Sign.it_mkProd_or_LetIn
+   (mkApp ((Lazy.force coq_relation),[| apply_to_rels a a_quantifiers_rev |]))
+   a_quantifiers_rev in
+ if
+  not
+   (is_conv env Evd.empty (Typing.type_of env Evd.empty aeq) typ)
+ then
+  errorlabstrm "Add Relation Class"
+   (pr_lconstr aeq ++ str " should have type (" ++ pr_lconstr typ ++ str ")")
+
+let check_property env a_quantifiers_rev a aeq strprop coq_prop t =
+ if
+  not
+   (is_conv env Evd.empty (Typing.type_of env Evd.empty t)
+    (Sign.it_mkProd_or_LetIn
+     (mkApp ((Lazy.force coq_prop),
+       [| apply_to_rels a   a_quantifiers_rev ;
+          apply_to_rels aeq a_quantifiers_rev |])) a_quantifiers_rev))
+ then
+  errorlabstrm "Add Relation Class"
+   (str "Not a valid proof of " ++ str strprop ++ str ".")
+
+let check_refl env a_quantifiers_rev a aeq refl =
+ check_property env a_quantifiers_rev a aeq "reflexivity" coq_reflexive refl
+
+let check_sym env a_quantifiers_rev a aeq sym =
+ check_property env a_quantifiers_rev a aeq "symmetry" coq_symmetric sym
+
+let check_trans env a_quantifiers_rev a aeq trans =
+ check_property env a_quantifiers_rev a aeq "transitivity" coq_transitive trans
+
+let check_setoid_theory env a_quantifiers_rev a aeq th =
+ if
+  not
+   (is_conv env Evd.empty (Typing.type_of env Evd.empty th)
+    (Sign.it_mkProd_or_LetIn
+     (mkApp ((Lazy.force coq_Setoid_Theory),
+       [| apply_to_rels a   a_quantifiers_rev ;
+          apply_to_rels aeq a_quantifiers_rev |])) a_quantifiers_rev))
+ then
+  errorlabstrm "Add Relation Class"
+   (str "Not a valid proof of symmetry")
+
+let int_add_relation id a aeq refl sym trans =
+ let env = Global.env () in
+ let a_quantifiers_rev = check_a env a in
+  check_eq env a_quantifiers_rev a aeq  ;
+  option_iter (check_refl env a_quantifiers_rev a aeq) refl ;
+  option_iter (check_sym env a_quantifiers_rev a aeq) sym ;
+  option_iter (check_trans env a_quantifiers_rev a aeq) trans ;
+  let quantifiers_no = List.length a_quantifiers_rev in
+  let aeq_rel =
+   { rel_a = a;
+     rel_aeq = aeq;
+     rel_refl = refl;
+     rel_sym = sym;
+     rel_trans = trans;
+     rel_quantifiers_no = quantifiers_no;
+     rel_X_relation_class = mkProp; (* dummy value, overwritten below *)
+     rel_Xreflexive_relation_class = mkProp (* dummy value, overwritten below *)
+   } in
+  let x_relation_class =
+   let subst =
+    let len = List.length a_quantifiers_rev in
+    Array.of_list
+     (Util.list_map_i (fun i _ -> mkRel (len - i + 2)) 0 a_quantifiers_rev) in
+   cic_relation_class_of_X_relation
+    (mkRel 2) (mkRel 1) (apply_to_relation subst aeq_rel) in
+  let _ =
+   Declare.declare_internal_constant id
+    (DefinitionEntry
+      {const_entry_body =
+        Sign.it_mkLambda_or_LetIn x_relation_class
+         ([ Name (id_of_string "v"),None,mkRel 1;
+            Name (id_of_string "X"),None,mkType (Termops.new_univ ())] @
+            a_quantifiers_rev);
+       const_entry_type = None;
+       const_entry_opaque = false;
+       const_entry_boxed = Options.boxed_definitions()},
+      IsDefinition Definition) in
+  let id_precise = id_of_string (string_of_id id ^ "_precise_relation_class") in
+  let xreflexive_relation_class =
+   let subst =
+    let len = List.length a_quantifiers_rev in
+    Array.of_list
+     (Util.list_map_i (fun i _ -> mkRel (len - i)) 0 a_quantifiers_rev)
+   in
+    cic_precise_relation_class_of_relation (apply_to_relation subst aeq_rel) in
+  let _ =
+   Declare.declare_internal_constant id_precise
+    (DefinitionEntry
+      {const_entry_body =
+        Sign.it_mkLambda_or_LetIn xreflexive_relation_class a_quantifiers_rev;
+       const_entry_type = None;
+       const_entry_opaque = false;
+       const_entry_boxed = Options.boxed_definitions() },
+      IsDefinition Definition) in
+  let aeq_rel =
+   { aeq_rel with
+      rel_X_relation_class = current_constant id;
+      rel_Xreflexive_relation_class = current_constant id_precise } in
+  Lib.add_anonymous_leaf (relation_to_obj (aeq, aeq_rel)) ;
+  Options.if_verbose ppnl (pr_lconstr aeq ++ str " is registered as a relation");
+  match trans with
+     None -> ()
+   | Some trans ->
+      let mor_name = id_of_string (string_of_id id ^ "_morphism") in
+      let a_instance = apply_to_rels a a_quantifiers_rev in
+      let aeq_instance = apply_to_rels aeq a_quantifiers_rev in
+      let sym_instance =
+       option_map (fun x -> apply_to_rels x a_quantifiers_rev) sym in
+      let refl_instance =
+       option_map (fun x -> apply_to_rels x a_quantifiers_rev) refl in
+      let trans_instance = apply_to_rels trans a_quantifiers_rev in
+      let aeq_rel_class_and_var1, aeq_rel_class_and_var2, lemma, output =
+       match sym_instance, refl_instance with
+          None, None ->
+           (Some false, Relation aeq_rel),
+           (Some true, Relation aeq_rel),
+            mkApp
+             ((Lazy.force
+                coq_equality_morphism_of_asymmetric_areflexive_transitive_relation),
+              [| a_instance ; aeq_instance ; trans_instance |]),
+            Lazy.force coq_impl_relation
+        | None, Some refl_instance ->
+           (Some false, Relation aeq_rel),
+           (Some true, Relation aeq_rel),
+            mkApp
+             ((Lazy.force
+                coq_equality_morphism_of_asymmetric_reflexive_transitive_relation),
+              [| a_instance ; aeq_instance ; refl_instance ; trans_instance |]),
+            Lazy.force coq_impl_relation
+        | Some sym_instance, None ->
+           (None, Relation aeq_rel),
+           (None, Relation aeq_rel),
+            mkApp
+             ((Lazy.force
+                coq_equality_morphism_of_symmetric_areflexive_transitive_relation),
+              [| a_instance ; aeq_instance ; sym_instance ; trans_instance |]),
+            Lazy.force coq_iff_relation
+        | Some sym_instance, Some refl_instance ->
+           (None, Relation aeq_rel),
+           (None, Relation aeq_rel),
+            mkApp
+             ((Lazy.force
+                coq_equality_morphism_of_symmetric_reflexive_transitive_relation),
+              [| a_instance ; aeq_instance ; refl_instance ; sym_instance ;
+                 trans_instance |]),
+            Lazy.force coq_iff_relation in
+      let _ =
+       Declare.declare_internal_constant mor_name
+        (DefinitionEntry
+          {const_entry_body = Sign.it_mkLambda_or_LetIn lemma a_quantifiers_rev;
+           const_entry_type = None;
+           const_entry_opaque = false;
+          const_entry_boxed = Options.boxed_definitions()},
+          IsDefinition Definition)
+      in
+       let a_quantifiers_rev =
+        List.map (fun (n,b,t) -> assert (b = None); n,t) a_quantifiers_rev in
+       add_morphism None mor_name
+        (aeq,a_quantifiers_rev,[aeq_rel_class_and_var1; aeq_rel_class_and_var2],
+          output)
+
+(* The vernac command "Add Relation ..." *)
+let add_relation id a aeq refl sym trans =
+ int_add_relation id (constr_of a) (constr_of aeq) (option_map constr_of refl)
+  (option_map constr_of sym) (option_map constr_of trans)
+
+(************************ Add Setoid ******************************************)
+
+(* The vernac command "Add Setoid" *)
+let add_setoid id a aeq th =
+ let a = constr_of a in
+ let aeq = constr_of aeq in
+ let th = constr_of th in
+ let env = Global.env () in
+ let a_quantifiers_rev = check_a env a in
+  check_eq env a_quantifiers_rev a aeq  ;
+  check_setoid_theory env a_quantifiers_rev a aeq  th ;
+   let a_instance = apply_to_rels a a_quantifiers_rev in
+   let aeq_instance = apply_to_rels aeq a_quantifiers_rev in
+   let th_instance = apply_to_rels th a_quantifiers_rev in
+   let refl =
+    Sign.it_mkLambda_or_LetIn
+     (mkApp ((Lazy.force coq_seq_refl),
+       [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in
+   let sym =
+    Sign.it_mkLambda_or_LetIn
+     (mkApp ((Lazy.force coq_seq_sym),
+       [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in
+   let trans =
+    Sign.it_mkLambda_or_LetIn
+     (mkApp ((Lazy.force coq_seq_trans),
+       [| a_instance; aeq_instance; th_instance |])) a_quantifiers_rev in
+   int_add_relation id a aeq (Some refl) (Some sym) (Some trans)
 
-let new_named_morphism id m = new_morphism (constr_of m) id morphism_hook
 
 (****************************** The tactic itself *******************************)
 
+type direction =
+   Left2Right
+ | Right2Left
+
+let prdirection =
+ function
+    Left2Right -> str "->"
+  | Right2Left -> str "<-"
+
 type constr_with_marks =
-  | MApp of constr_with_marks array 
-  | Toreplace
-  | Tokeep
-  | Mimp of constr_with_marks * constr_with_marks
+  | MApp of constr * morphism_class * constr_with_marks array * direction
+  | ToReplace
+  | ToKeep of constr * relation relation_class * direction
 
 let is_to_replace = function
-  | Tokeep -> false
-  | Toreplace -> true
-  | MApp _ -> true
-  | Mimp _ -> true
+ | ToKeep _ -> false
+ | ToReplace -> true
+ | MApp _ -> 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
+let cic_direction_of_direction =
+ function
+    Left2Right -> Lazy.force coq_Left2Right
+  | Right2Left -> Lazy.force coq_Right2Left
+
+let opposite_direction =
+ function
+    Left2Right -> Right2Left
+  | Right2Left -> Left2Right
+
+let direction_of_constr_with_marks hole_direction =
+ function
+    MApp (_,_,_,dir) -> cic_direction_of_direction dir
+  | ToReplace -> hole_direction
+  | ToKeep (_,_,dir) -> cic_direction_of_direction dir
+
+type argument =
+   Toapply of constr         (* apply the function to the argument *)
+ | Toexpand of name * types  (* beta-expand the function w.r.t. an argument
+                                of this type *)
+let beta_expand c args_rev =
+ let rec to_expand =
+  function
+     [] -> []
+   | (Toapply _)::tl -> to_expand tl
+   | (Toexpand (name,s))::tl -> (name,s)::(to_expand tl) in
+ let rec aux n =
+  function
+     [] -> []
+   | (Toapply arg)::tl -> arg::(aux n tl)
+   | (Toexpand _)::tl -> (mkRel n)::(aux (n + 1) tl)
+ in
+  compose_lam (to_expand args_rev)
+   (mkApp (c, Array.of_list (List.rev (aux 1 args_rev))))
+
+exception Optimize (* used to fall-back on the tactic for Leibniz equality *)
+
+let relation_class_that_matches_a_constr caller_name new_goals hypt =
+ let (heq, hargs) = decompose_app hypt in
+ let rec get_all_but_last_two =
+  function
+     []
+   | [_] ->
+      errorlabstrm caller_name (pr_lconstr hypt ++
+       str " is not a registered relation.")
+   | [_;_] -> []
+   | he::tl -> he::(get_all_but_last_two tl) in
+ let all_aeq_args = get_all_but_last_two hargs in
+ let rec find_relation l subst =
+  let aeq = mkApp (heq,(Array.of_list l)) in
+  try
+   let rel = find_relation_class aeq in
+   match rel,new_goals with
+      Leibniz _,[] ->
+       assert (subst = []);
+       raise Optimize (* let's optimize the proof term size *)
+    | Leibniz (Some _), _ ->
+       assert (subst = []);
+       rel
+    | Leibniz None, _ ->
+       (* for well-typedness reasons it should have been catched by the
+          previous guard in the previous iteration. *)
+       assert false
+    | Relation rel,_ -> Relation (apply_to_relation (Array.of_list subst) rel)
+  with Not_found ->
+   if l = [] then
+    errorlabstrm caller_name
+     (pr_lconstr (mkApp (aeq, Array.of_list all_aeq_args)) ++
+      str " is not a registered relation.")
+   else
+    let last,others = Util.list_sep_last l in
+    find_relation others (last::subst)
+ in
+  find_relation all_aeq_args []
+
+(* rel1 is a subrelation of rel2 whenever 
+    forall x1 x2, rel1 x1 x2 -> rel2 x1 x2
+   The Coq part of the tactic, however, needs rel1 == rel2.
+   Hence the third case commented out.
+   Note: accepting user-defined subrelations seems to be the last
+   useful generalization that does not go against the original spirit of
+   the tactic.
+*)
+let subrelation gl rel1 rel2 =
+ match rel1,rel2 with
+    Relation {rel_aeq=rel_aeq1}, Relation {rel_aeq=rel_aeq2} ->
+     Tacmach.pf_conv_x gl rel_aeq1 rel_aeq2
+  | Leibniz (Some t1), Leibniz (Some t2) ->
+     Tacmach.pf_conv_x gl t1 t2
+  | Leibniz None, _
+  | _, Leibniz None -> assert false
+(* This is the commented out case (see comment above)
+  | Leibniz (Some t1), Relation {rel_a=t2; rel_refl = Some _} ->
+     Tacmach.pf_conv_x gl t1 t2
+*)
+  | _,_ -> false
+
+(* this function returns the list of new goals opened by a constr_with_marks *)
+let rec collect_new_goals =
+ function
+   MApp (_,_,a,_) -> List.concat (List.map collect_new_goals (Array.to_list a))
+ | ToReplace
+ | ToKeep (_,Leibniz _,_)
+ | ToKeep (_,Relation {rel_refl=Some _},_) -> []
+ | ToKeep (c,Relation {rel_aeq=aeq; rel_refl=None},_) -> [mkApp(aeq,[|c ; c|])]
+
+(* two marked_constr are equivalent if they produce the same set of new goals *)
+let marked_constr_equiv_or_more_complex to_marked_constr gl c1 c2 =
+  let glc1 = collect_new_goals (to_marked_constr c1) in
+  let glc2 = collect_new_goals (to_marked_constr c2) in
+   List.for_all (fun c -> List.exists (fun c' -> pf_conv_x gl c c') glc1) glc2
+
+let pr_new_goals i c =
+ let glc = collect_new_goals c in
+  str " " ++ int i ++ str ") side conditions:" ++
+   (if glc = [] then str " no side conditions"
+    else
+     (pr_fnl () ++ str "   " ++
+       prlist_with_sep (fun () -> str "\n   ")
+        (fun c -> str " ... |- " ++ pr_lconstr c) glc))
+
+(* given a list of constr_with_marks, it returns the list where
+   constr_with_marks than open more goals than simpler ones in the list
+   are got rid of *)
+let elim_duplicates gl to_marked_constr =
+ let rec aux =
+  function
+     [] -> []
+   | he:: tl ->
+      if List.exists
+          (marked_constr_equiv_or_more_complex to_marked_constr gl he) tl
+      then aux tl
+      else he::aux tl
+ in
+  aux
+
+let filter_superset_of_new_goals gl new_goals l =
+ List.filter
+  (fun (_,_,c) ->
+    List.for_all
+     (fun g -> List.exists (pf_conv_x gl g) (collect_new_goals c)) new_goals) l
+
+(* given the array of lists [| l1 ; ... ; ln |] it returns the list of arrays
+   [ c1 ; ... ; cn ] that is the cartesian product of the sets l1, ..., ln *)
+let cartesian_product gl a =
+ let rec aux =
+  function
+     [] -> assert false
+   | [he] -> List.map (fun e -> [e]) he
+   | he::tl ->
+      let tl' = aux tl in
+       List.flatten
+        (List.map (function e -> List.map (function l -> e :: l) tl') he)
+ in
+  List.map Array.of_list
+   (aux (List.map (elim_duplicates gl identity) (Array.to_list a)))
+
+let mark_occur gl ~new_goals t in_c input_relation input_direction =
+ let rec aux output_relation output_directions in_c =
+  if eq_constr t in_c then
+   if List.mem input_direction output_directions
+   && subrelation gl input_relation output_relation then
+    [ToReplace]
+   else []
+  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
+         let mors_and_cs_and_als =
+          let mors_and_cs_and_als =
+           let morphism_table_find c =
+            try morphism_table_find c with Not_found -> [] in
+           let rec aux acc =
+            function
+               [] ->
+                let c' = mkApp (c, Array.of_list acc) in
+                let al' = [||] in
+                List.map (fun m -> m,c',al') (morphism_table_find c')
+             | (he::tl) as l ->
+                let c' = mkApp (c, Array.of_list acc) in
+                let al' = Array.of_list l in
+                let acc' = acc @ [he] in
+                 (List.map (fun m -> m,c',al') (morphism_table_find c')) @
+                  (aux acc' tl)
+           in
+            aux [] (Array.to_list al) in
+          let mors_and_cs_and_als =
+           List.map
+            (function (m,c,al) ->
+              relation_morphism_of_constr_morphism m, c, al)
+             mors_and_cs_and_als in
+          let mors_and_cs_and_als =
+           List.fold_left
+            (fun l (m,c,al) ->
+	       try (unify_morphism_with_arguments gl (c,al) m t) :: l
+	       with Impossible -> l
+	    ) [] mors_and_cs_and_als
+          in
+           List.filter
+            (fun (mor,_,_) -> subrelation gl mor.output output_relation)
+            mors_and_cs_and_als
+         in
+          (* First we look for well typed morphisms *)
+          let res_mors =
+           List.fold_left
+            (fun res (mor,c,al) ->
+              let a =
+               let arguments = Array.of_list mor.args in
+               let apply_variance_to_direction =
+                function
+                   None -> [Left2Right;Right2Left]
+                 | Some true -> output_directions
+                 | Some false -> List.map opposite_direction output_directions
+               in
+                Util.array_map2
+                 (fun a (variance,relation) ->
+                   (aux relation (apply_variance_to_direction variance) a)
+                 ) al arguments
+              in
+               let a' = cartesian_product gl a in
+	       List.flatten (List.map (fun output_direction ->
+                (List.map
+                  (function a ->
+                    if not (get_mark a) then
+                     ToKeep (in_c,output_relation,output_direction)
+                    else
+                     MApp (c,ACMorphism mor,a,output_direction)) a'))
+		 output_directions) @ res
+            ) [] mors_and_cs_and_als in
+          (* Then we look for well typed functions *)
+          let res_functions =
+           (* the tactic works only if the function type is
+               made of non-dependent products only. However, here we
+               can cheat a bit by partially instantiating c to match
+               the requirement when the arguments to be replaced are
+               bound by non-dependent products only. *)
+            let typeofc = Tacmach.pf_type_of gl c in
+            let typ = nf_betaiota typeofc in
+            let rec find_non_dependent_function env c c_args_rev typ f_args_rev
+                     a_rev
+            =
+             function
+                [] ->
+                 if a_rev = [] then
+		  List.map (fun output_direction ->
+                   ToKeep (in_c,output_relation,output_direction))
+		   output_directions
+                 else
+                  let a' =
+                   cartesian_product gl (Array.of_list (List.rev a_rev))
+                  in
+                   List.fold_left
+                    (fun res a ->
+                      if not (get_mark a) then
+			List.map (fun output_direction ->
+			 (ToKeep (in_c,output_relation,output_direction)))
+			 output_directions @ res
+                      else
+                       let err =
+                        match output_relation with
+                           Leibniz (Some typ') when pf_conv_x gl typ typ' ->
+                            false
+                         | Leibniz None -> assert false
+                         | _ when output_relation = Lazy.force coq_iff_relation
+                             -> false
+                         | _ -> true
+                       in
+                        if err then res
+                        else
+                         let mor =
+                          ACFunction{f_args=List.rev f_args_rev;f_output=typ} in
+                         let func = beta_expand c c_args_rev in
+			 List.map (fun output_direction ->
+                          (MApp (func,mor,a,output_direction)))
+			  output_directions @ res
+                    ) [] a'
+              | (he::tl) as a->
+                 let typnf = Reduction.whd_betadeltaiota env typ in
+                  match kind_of_term typnf with
+                    Cast (typ,_,_) ->
+                     find_non_dependent_function env c c_args_rev typ
+                      f_args_rev a_rev a
+                  | Prod (name,s,t) ->
+                     let env' = push_rel (name,None,s) env in
+                     let he =
+                      (aux (Leibniz (Some s)) [Left2Right;Right2Left] he) in
+                     if he = [] then []
+                     else
+                      let he0 = List.hd he in
+                      begin
+                       match noccurn 1 t, he0 with
+                          _, ToKeep (arg,_,_) ->
+                           (* invariant: if he0 = ToKeep (t,_,_) then every
+                              element in he is = ToKeep (t,_,_) *)
+                           assert
+                            (List.for_all
+                              (function
+                                  ToKeep(arg',_,_) when pf_conv_x gl arg arg' ->
+                                    true
+                                | _ -> false) he) ;
+                           (* generic product, to keep *)
+                           find_non_dependent_function
+                            env' c ((Toapply arg)::c_args_rev)
+                            (subst1 arg t) f_args_rev a_rev tl
+                        | true, _ ->
+                           (* non-dependent product, to replace *)
+                           find_non_dependent_function
+                            env' c ((Toexpand (name,s))::c_args_rev)
+                             (lift 1 t) (s::f_args_rev) (he::a_rev) tl
+                        | false, _ ->
+                           (* dependent product, to replace *)
+                           (* This limitation is due to the reflexive
+                             implementation and it is hard to lift *)
+                           errorlabstrm "Setoid_replace"
+                            (str "Cannot rewrite in the argument of a " ++
+                             str "dependent product. If you need this " ++
+                             str "feature, please report to the author.")
+                      end
+                  | _ -> assert false
+            in
+             find_non_dependent_function (Tacmach.pf_env gl) c [] typ [] []
+              (Array.to_list al)
+          in
+           elim_duplicates gl identity (res_functions @ res_mors)
       | 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)
+          if (dependent (mkRel 1) c2)
+          then
+            if (occur_term t c2)
+	    then errorlabstrm "Setoid_replace"
+              (str "Cannot rewrite in the type of a variable bound " ++
+		  str "in a dependent product.")
+	    else
+	      List.map (fun output_direction ->
+	       ToKeep (in_c,output_relation,output_direction)) 
+	       output_directions
+          else 
+            let typeofc1 = Tacmach.pf_type_of gl c1 in
+              if not (Tacmach.pf_conv_x gl typeofc1 mkProp) then
+		(* to avoid this error we should introduce an impl relation
+                   whose first argument is Type instead of Prop. However,
+                   the type of the new impl would be Type -> Prop -> Prop
+                   that is no longer a Relation_Definitions.relation. Thus
+                   the Coq part of the tactic should be heavily modified. *)
+		errorlabstrm "Setoid_replace"
+		  (str "Rewriting in a product A -> B is possible only when A " ++
+		      str "is a proposition (i.e. A is of type Prop). The type " ++
+		      pr_lconstr c1 ++ str " has type " ++ pr_lconstr typeofc1 ++
+		      str " that is not convertible to Prop.")
+              else
+		aux output_relation output_directions
+		  (mkApp ((Lazy.force coq_impl),
+			 [| c1 ; subst1 (mkRel 1 (*dummy*)) c2 |]))
+      | _ ->
+          if occur_term t in_c then
+            errorlabstrm "Setoid_replace"
+              (str "Trying to replace " ++ pr_lconstr t ++ str " in " ++ pr_lconstr in_c ++
+		  str " that is not an applicative context.")
+          else
+	    List.map (fun output_direction ->
+             ToKeep (in_c,output_relation,output_direction))
+	      output_directions
+ in
+  let aux2 output_relation output_direction =
+   List.map
+    (fun res -> output_relation,output_direction,res)
+     (aux output_relation [output_direction] in_c) in
+  let res =
+   (aux2 (Lazy.force coq_iff_relation) Right2Left) @
+   (* [Left2Right] is the case of a prop of signature A ++> iff or B --> iff *)
+   (aux2 (Lazy.force coq_iff_relation) Left2Right) @
+   (aux2 (Lazy.force coq_impl_relation) Right2Left) in
+  let res = elim_duplicates gl (function (_,_,t) -> t) res in
+  let res' = filter_superset_of_new_goals gl new_goals res in
+  match res' with
+     [] when res = [] ->
+      errorlabstrm "Setoid_rewrite"
+       (str "Either the term " ++ pr_lconstr t ++ str " that must be " ++
+        str "rewritten occurs in a covariant position or the goal is not " ++
+        str "made of morphism applications only. You can replace only " ++
+        str "occurrences that are in a contravariant position and such that " ++
+        str "the context obtained by abstracting them is made of morphism " ++
+        str "applications only.")
+   | [] ->
+      errorlabstrm "Setoid_rewrite"
+       (str "No generated set of side conditions is a superset of those " ++
+        str "requested by the user. The generated sets of side conditions " ++
+        str "are: " ++
+         pr_fnl () ++
+         prlist_with_sepi pr_fnl
+          (fun i (_,_,mc) -> pr_new_goals i mc) res)
+   | [he] -> he
+   | he::_ ->
+      ppnl
+       (str "Warning: The application of the tactic is subject to one of " ++
+        str "the \nfollowing set of side conditions that the user needs " ++
+        str "to prove:" ++
+         pr_fnl () ++
+         prlist_with_sepi pr_fnl
+          (fun i (_,_,mc) -> pr_new_goals i mc) res' ++ pr_fnl () ++
+         str "The first set is randomly chosen. Use the syntax " ++
+         str "\"setoid_rewrite ... generate side conditions ...\" to choose " ++
+         str "a different set.") ;
+      he
+
+let cic_morphism_context_list_of_list hole_relation hole_direction out_direction
+=
+ let check =
+  function
+     (None,dir,dir') -> 
+      mkApp ((Lazy.force coq_MSNone), [| dir ; dir' |])
+   | (Some true,dir,dir') ->
+      assert (dir = dir');
+      mkApp ((Lazy.force coq_MSCovariant), [| dir |])
+   | (Some false,dir,dir') ->
+      assert (dir <> dir');
+      mkApp ((Lazy.force coq_MSContravariant), [| dir |]) in
+ let rec aux =
+  function
+     [] -> assert false
+   | [(variance,out),(value,direction)] ->
+      mkApp ((Lazy.force coq_singl), [| Lazy.force coq_Argument_Class ; out |]),
+      mkApp ((Lazy.force coq_fcl_singl),
+       [| hole_relation; hole_direction ; out ;
+          direction ; out_direction ;
+          check (variance,direction,out_direction) ; value |])
+   | ((variance,out),(value,direction))::tl ->
+      let outtl, valuetl = aux tl in
+       mkApp ((Lazy.force coq_cons),
+        [| Lazy.force coq_Argument_Class ; out ; outtl |]),
+       mkApp ((Lazy.force coq_fcl_cons),
+        [| hole_relation ; hole_direction ; out ; outtl ;
+           direction ; out_direction ;
+           check (variance,direction,out_direction) ;
+           value ; valuetl |])
+ in aux
+
+let rec cic_type_nelist_of_list =
+ function
+    [] -> assert false
+  | [value] ->
+      mkApp ((Lazy.force coq_singl), [| mkType (Termops.new_univ ()) ; value |])
+  | value::tl ->
+     mkApp ((Lazy.force coq_cons),
+      [| mkType (Termops.new_univ ()); value; cic_type_nelist_of_list tl |])
+
+let syntactic_but_representation_of_marked_but hole_relation hole_direction =
+ let rec aux out (rel_out,precise_out,is_reflexive) =
+  function
+     MApp (f, m, args, direction) ->
+      let direction = cic_direction_of_direction direction in
+      let morphism_theory, relations =
+       match m with
+          ACMorphism { args = args ; morphism_theory = morphism_theory } ->
+           morphism_theory,args
+        | ACFunction { f_args = f_args ; f_output = f_output } ->
+           let mt =
+            if eq_constr out (cic_relation_class_of_relation_class
+              (Lazy.force coq_iff_relation))
+            then
+              mkApp ((Lazy.force coq_morphism_theory_of_predicate),
+               [| cic_type_nelist_of_list f_args; f|])
+            else
+              mkApp ((Lazy.force coq_morphism_theory_of_function),
+               [| cic_type_nelist_of_list f_args; f_output; f|])
+           in
+            mt,List.map (fun x -> None,Leibniz (Some x)) f_args in
+      let cic_relations =
+       List.map
+        (fun (variance,r) ->
+          variance,
+          r,
+          cic_relation_class_of_relation_class r,
+          cic_precise_relation_class_of_relation_class r
+        ) relations in
+      let cic_args_relations,argst =
+       cic_morphism_context_list_of_list hole_relation hole_direction direction
+        (List.map2
+         (fun (variance,trel,t,precise_t) v ->
+           (variance,cic_argument_class_of_argument_class (variance,trel)),
+             (aux t precise_t v,
+               direction_of_constr_with_marks hole_direction v)
+         ) cic_relations (Array.to_list args))
+      in
+       mkApp ((Lazy.force coq_App),
+        [|hole_relation ; hole_direction ;
+          cic_args_relations ; out ; direction ;
+          morphism_theory ; argst|])
+   | ToReplace ->
+      mkApp ((Lazy.force coq_ToReplace), [| hole_relation ; hole_direction |])
+   | ToKeep (c,_,direction) ->
+      let direction = cic_direction_of_direction direction in
+       if is_reflexive then
+        mkApp ((Lazy.force coq_ToKeep),
+         [| hole_relation ; hole_direction ; precise_out ; direction ; c |])
+       else
+        let c_is_proper =
+         let typ = mkApp (rel_out, [| c ; c |]) in
+          mkCast (Evarutil.mk_new_meta (),DEFAULTcast, typ)
+        in
+         mkApp ((Lazy.force coq_ProperElementToKeep),
+          [| hole_relation ; hole_direction; precise_out ;
+             direction; c ; c_is_proper |])
+ in aux
+
+let apply_coq_setoid_rewrite hole_relation prop_relation c1 c2 (direction,h)
+ prop_direction m
+=
+ let hole_relation = cic_relation_class_of_relation_class hole_relation in
+ let hyp,hole_direction = h,cic_direction_of_direction direction in
+ let cic_prop_relation = cic_relation_class_of_relation_class prop_relation in
+ let precise_prop_relation =
+  cic_precise_relation_class_of_relation_class prop_relation
+ in
+  mkApp ((Lazy.force coq_setoid_rewrite),
+   [| hole_relation ; hole_direction ; cic_prop_relation ;
+      prop_direction ; c1 ; c2 ;
+      syntactic_but_representation_of_marked_but hole_relation hole_direction
+       cic_prop_relation precise_prop_relation m ; hyp |])
+
+let check_evar_map_of_evars_defs evd =
+ let metas = Evd.meta_list evd in
+ let check_freemetas_is_empty rebus =
+  Evd.Metaset.iter
+   (fun m ->
+     if Evd.meta_defined evd m then () else
+      raise (Logic.RefinerError (Logic.OccurMetaGoal rebus)))
+ in
+  List.iter
+   (fun (_,binding) ->
+     match binding with
+        Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
+         check_freemetas_is_empty rebus freemetas
+      | Evd.Clval (_,{Evd.rebus=rebus1; Evd.freemetas=freemetas1},
+                 {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
+         check_freemetas_is_empty rebus1 freemetas1 ;
+         check_freemetas_is_empty rebus2 freemetas2
+   ) metas
+
+(* For a correct meta-aware "rewrite in", we split unification 
+   apart from the actual rewriting (Pierre L, 05/04/06) *)
+   
+(* [unification_rewrite] searchs a match for [c1] in [but] and then 
+   returns the modified objects (in particular [c1] and [c2]) *)  
+
+let unification_rewrite c1 c2 cl but gl = 
+  let (env',c1) =
+    try
+      (* ~mod_delta:false to allow to mark occurences that must not be
+         rewritten simply by replacing them with let-defined definitions
+         in the context *)
+      w_unify_to_subterm ~mod_delta:false (pf_env gl) (c1,but) cl.env
+    with
+	Pretype_errors.PretypeError _ ->
+	  (* ~mod_delta:true to make Ring work (since it really
+             exploits conversion) *)
+	  w_unify_to_subterm ~mod_delta:true (pf_env gl) (c1,but) cl.env
   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])
+  let cl' = {cl with env = env' } in
+  let c2 = Clenv.clenv_nf_meta cl' c2 in
+  check_evar_map_of_evars_defs env' ;
+  env',Clenv.clenv_value cl', c1, c2
+
+(* no unification is performed in this function. [sigma] is the 
+ substitution obtained from an earlier unification. *)
+
+let relation_rewrite_no_unif c1 c2 hyp ~new_goals sigma gl = 
+  let but = pf_concl gl in 
+  try
+   let input_relation =
+    relation_class_that_matches_a_constr "Setoid_rewrite"
+     new_goals (Typing.mtype_of (pf_env gl) sigma (snd hyp)) in
+   let output_relation,output_direction,marked_but =
+    mark_occur gl ~new_goals c1 but input_relation (fst hyp) in
+   let cic_output_direction = cic_direction_of_direction output_direction in
+   let if_output_relation_is_iff gl =
+    let th =
+     apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp
+      cic_output_direction marked_but
+    in
+     let new_but = Termops.replace_term c1 c2 but in
+     let hyp1,hyp2,proj =
+      match output_direction with
+         Right2Left -> new_but, but, Lazy.force coq_proj1
+       | Left2Right -> but, new_but, Lazy.force coq_proj2
+     in
+     let impl1 = mkProd (Anonymous, hyp2, lift 1 hyp1) in
+     let impl2 = mkProd (Anonymous, hyp1, lift 1 hyp2) in
+      let th' = mkApp (proj, [|impl2; impl1; th|]) in
+       Tactics.refine
+        (mkApp (th',[|mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)|]))
+	gl in
+   let if_output_relation_is_if gl =
+    let th =
+     apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp
+      cic_output_direction marked_but
+    in
+     let new_but = Termops.replace_term c1 c2 but in
+      Tactics.refine
+       (mkApp (th, [|mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)|]))
+       gl in
+   if output_relation = (Lazy.force coq_iff_relation) then
+     if_output_relation_is_iff gl
+   else
+     if_output_relation_is_if gl
+  with
+    Optimize ->
+      !general_rewrite (fst hyp = Left2Right) (snd hyp) gl
+
+let relation_rewrite c1 c2 (input_direction,cl) ~new_goals gl =
+ let (sigma,cl,c1,c2) = unification_rewrite c1 c2 cl (pf_concl gl) gl in 
+ relation_rewrite_no_unif c1 c2 (input_direction,cl) ~new_goals sigma gl 
+
+let analyse_hypothesis gl c =
+ let ctype = pf_type_of gl c in
+ let eqclause  = Clenv.make_clenv_binding gl (c,ctype) Rawterm.NoBindings in
+ let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
+ let rec split_last_two = function
+   | [c1;c2] -> [],(c1, c2)
+   | x::y::z ->
+      let l,res = split_last_two (y::z) in x::l, res
+   | _ -> error "The term provided is not an equivalence" in
+ let others,(c1,c2) = split_last_two args in
+  eqclause,mkApp (equiv, Array.of_list others),c1,c2
+
+let general_s_rewrite lft2rgt c ~new_goals gl =
+  let eqclause,_,c1,c2 = analyse_hypothesis gl c in
+  if lft2rgt then 
+    relation_rewrite c1 c2 (Left2Right,eqclause) ~new_goals gl
+  else 
+    relation_rewrite c2 c1 (Right2Left,eqclause) ~new_goals gl
+
+let relation_rewrite_in id c1 c2 (direction,eqclause) ~new_goals gl = 
+ let hyp = pf_type_of gl (mkVar id) in
+ (* first, we find a match for c1 in the hyp *)
+ let (sigma,cl,c1,c2) = unification_rewrite c1 c2 eqclause hyp gl in 
+ (* since we will actually rewrite in the opposite direction, we also need
+    to replace every occurrence of c2 (resp. c1) in hyp with something that
+    is convertible but not syntactically equal. To this aim we introduce a
+    let-in and then we will use the intro tactic to get rid of it.
+    Quite tricky to do properly since c1 can occur in c2 or vice-versa ! *)
+ let mangled_new_hyp = 
+   let hyp = lift 2 hyp in 
+   (* first, we backup every occurences of c1 in newly allocated (Rel 1) *)
+   let hyp = Termops.replace_term (lift 2 c1) (mkRel 1) hyp in 
+   (* then, we factorize every occurences of c2 into (Rel 2) *)
+   let hyp = Termops.replace_term (lift 2 c2) (mkRel 2) hyp in 
+   (* Now we substitute (Rel 1) (i.e. c1) for c2 *)
+   let hyp = subst1 (lift 1 c2) hyp in 
+   (* Since subst1 has killed Rel 1 and decreased the other Rels, 
+      Rel 1 is now coding for c2, we can build the let-in factorizing c2 *)
+   mkLetIn (Anonymous,c2,pf_type_of gl c2,hyp) 
+ in 
+ let new_hyp = Termops.replace_term c1 c2 hyp in 
+ let oppdir = opposite_direction direction in 
+ cut_replacing id new_hyp
+   (tclTHENLAST
+      (tclTHEN (change_in_concl None mangled_new_hyp)
+         (tclTHEN intro
+            (relation_rewrite_no_unif c2 c1 (oppdir,cl) ~new_goals sigma))))
+   gl
+
+let general_s_rewrite_in id lft2rgt c ~new_goals gl =
+  let eqclause,_,c1,c2 = analyse_hypothesis gl c in
+  if lft2rgt then 
+    relation_rewrite_in id c1 c2 (Left2Right,eqclause) ~new_goals gl
+  else 
+    relation_rewrite_in id c2 c1 (Right2Left,eqclause) ~new_goals gl
+
+
+(* 
+   [general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_goals ]
+   common part of [setoid_replace] and [setoid_replace_in]  (distinction is done using rewrite_tac). 
+
+   Algorith sketch: 
+   1- find the (setoid) relation [rel] between [c1] and [c2] using [relation]
+   2- assert [H:rel c2 c1] 
+   3- replace [c1] with [c2] using [rewrite_tac] (should be [general_s_rewrite] if we want to replace in the 
+      goal, and [general_s_rewrite_in id] if we want to replace in the hypothesis [id]). Possibly generate
+      new_goals if asked (cf general_s_rewrite)
+   4- if [try_prove_eq_tac_opt] is [Some tac] try to complete [rel c2 c1] using tac and do nothing if 
+      [try_prove_eq_tac_opt] is [None]
 *)
-  | (_, 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
+let general_setoid_replace rewrite_tac try_prove_eq_tac_opt relation c1 c2 ~new_goals gl =
+  let try_prove_eq_tac = 
+    match try_prove_eq_tac_opt with 
+      | None -> Tacticals.tclIDTAC
+      | Some tac ->  Tacticals.tclTRY (Tacticals.tclCOMPLETE tac )
+  in 
+  try
+  let relation =
+   match relation with
+      Some rel ->
+       (try
+         match find_relation_class rel with
+            Relation sa -> sa
+          | Leibniz _ -> raise Optimize
+        with
+         Not_found ->
+          errorlabstrm "Setoid_rewrite"
+           (pr_lconstr rel ++ str " is not a registered relation."))
+    | None ->
+       match default_relation_for_carrier (pf_type_of gl c1) with
+          Relation sa -> sa
+        | Leibniz _ -> raise Optimize
+  in
+   let eq_left_to_right = mkApp (relation.rel_aeq, [| c1 ; c2 |]) in
+   let eq_right_to_left = mkApp (relation.rel_aeq, [| c2 ; c1 |]) in
+   let replace dir eq =
+    tclTHENS (assert_tac false Anonymous eq)
+      [onLastHyp (fun id ->
+        tclTHEN
+          (rewrite_tac dir (mkVar id) ~new_goals)
+          (clear [id]));
+       try_prove_eq_tac]
+   in
+    tclORELSE
+     (replace true eq_left_to_right) (replace false eq_right_to_left) gl
+ with
+  Optimize -> (* (!replace tac_opt c1 c2) gl *)
+    let eq =  mkApp (Lazy.force  coq_eq, [| pf_type_of gl c1;c2 ; c1 |]) in 
+    tclTHENS (assert_tac false Anonymous eq)
+      [onLastHyp (fun id ->
+		    tclTHEN
+		      (rewrite_tac false (mkVar id) ~new_goals)
+		      (clear [id]));
+       try_prove_eq_tac] gl
+      
+
+
+
+let setoid_replace = general_setoid_replace general_s_rewrite
+let setoid_replace_in  tac_opt id relation c1 c2 ~new_goals gl = 
+  general_setoid_replace (general_s_rewrite_in id)  tac_opt relation c1 c2 ~new_goals gl
+ 
+(* [setoid_]{reflexivity,symmetry,transitivity} tactics *)
+
+let setoid_reflexivity gl =
+ try
+  let relation_class =
+   relation_class_that_matches_a_constr "Setoid_reflexivity"
+    [] (pf_concl gl) in
+  match relation_class with
+     Leibniz _ -> assert false (* since [] is empty *)
+   | Relation rel ->
+      match rel.rel_refl with
+         None ->
+          errorlabstrm "Setoid_reflexivity"
+           (str "The relation " ++ prrelation rel ++ str " is not reflexive.")
+       | Some refl -> apply refl gl
+ with
+  Optimize -> reflexivity gl
+
+let setoid_symmetry gl =
+ try
+  let relation_class =
+   relation_class_that_matches_a_constr "Setoid_symmetry"
+    [] (pf_concl gl) in
+  match relation_class with
+     Leibniz _ -> assert false (* since [] is empty *)
+   | Relation rel ->
+      match rel.rel_sym with
+         None ->
+          errorlabstrm "Setoid_symmetry"
+           (str "The relation " ++ prrelation rel ++ str " is not symmetric.")
+       | Some sym -> apply sym gl
+ with
+  Optimize -> symmetry gl
+
+let setoid_symmetry_in id gl =
+ let new_hyp =
+  let _,he,c1,c2 = analyse_hypothesis gl (mkVar id) in
+   mkApp (he, [| c2 ; c1 |])
+ in
+ cut_replacing id new_hyp (tclTHEN setoid_symmetry) gl
+
+let setoid_transitivity c gl =
+ try
+  let relation_class =
+   relation_class_that_matches_a_constr "Setoid_transitivity"
+    [] (pf_concl gl) in
+  match relation_class with
+     Leibniz _ -> assert false (* since [] is empty *)
+   | Relation rel ->
+      let ctyp = pf_type_of gl c in
+      let rel' = unify_relation_carrier_with_type (pf_env gl) rel ctyp in
+       match rel'.rel_trans with
+          None ->
+           errorlabstrm "Setoid_transitivity"
+            (str "The relation " ++ prrelation rel ++ str " is not transitive.")
+        | Some trans ->
+           let transty = nf_betaiota (pf_type_of gl trans) in
+           let argsrev, _ =
+            Reductionops.decomp_n_prod (pf_env gl) Evd.empty 2 transty in
+           let binder =
+            match List.rev argsrev with
+               _::(Name n2,None,_)::_ -> Rawterm.NamedHyp n2
+             | _ -> assert false
+           in
+            apply_with_bindings
+             (trans, Rawterm.ExplicitBindings [ dummy_loc, binder, c ]) gl
+ with
+  Optimize -> transitivity c gl
+;;
+
+Tactics.register_setoid_reflexivity setoid_reflexivity;;
+Tactics.register_setoid_symmetry setoid_symmetry;;
+Tactics.register_setoid_symmetry_in setoid_symmetry_in;;
+Tactics.register_setoid_transitivity setoid_transitivity;;
diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli
index 854fa478..eb71f68e 100644
--- a/tactics/setoid_replace.mli
+++ b/tactics/setoid_replace.mli
@@ -6,22 +6,76 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: setoid_replace.mli,v 1.3.6.2 2005/01/21 17:14:11 herbelin Exp $ i*)
+(*i $Id: setoid_replace.mli 9073 2006-08-22 08:54:29Z jforest $ i*)
 
 open Term
 open Proof_type
 open Topconstr
+open Names
+
+type relation =
+   { rel_a: constr ;
+     rel_aeq: constr;
+     rel_refl: constr option;
+     rel_sym: constr option;
+     rel_trans : constr option;
+     rel_quantifiers_no: int  (* it helps unification *);
+     rel_X_relation_class: constr;
+     rel_Xreflexive_relation_class: constr
+   }
+
+type 'a relation_class =
+   Relation of 'a    (* the [rel_aeq] of the relation or the relation*)
+ | Leibniz of constr option  (* the [carrier] (if [eq] is partially instantiated)*)
+
+type 'a morphism =
+    { args : (bool option * 'a relation_class) list;
+      output : 'a relation_class;
+      lem : constr;
+      morphism_theory : constr
+    }
+
+type morphism_signature = (bool option * constr_expr) list * constr_expr
+
+val pr_morphism_signature : morphism_signature -> Pp.std_ppcmds
+
+val register_replace : (tactic option -> constr -> constr -> tactic) -> unit
+val register_general_rewrite : (bool -> constr -> tactic) -> unit
+
+val print_setoids : unit -> unit
 
 val equiv_list : unit -> constr list
+val default_relation_for_carrier :
+  ?filter:(relation -> bool) -> types -> relation relation_class 
+(* [default_morphism] raises [Not_found] *)
+val default_morphism :
+  ?filter:(constr morphism -> bool) -> constr -> relation morphism
+
+val setoid_replace :
+  tactic option -> constr option -> constr -> constr -> new_goals:constr list -> tactic
+val setoid_replace_in :
+  tactic option -> 
+ identifier -> constr option -> constr -> constr -> new_goals:constr list ->
+  tactic
 
-val setoid_replace : constr -> constr -> constr option -> tactic
+val general_s_rewrite : bool -> constr -> new_goals:constr list -> tactic
+val general_s_rewrite_in :
+ identifier -> bool -> constr -> new_goals:constr list -> tactic
 
-val setoid_rewriteLR : constr -> tactic
+val setoid_reflexivity : tactic
+val setoid_symmetry : tactic
+val setoid_symmetry_in : identifier -> tactic
+val setoid_transitivity : constr -> tactic
 
-val setoid_rewriteRL : constr -> tactic
+val add_relation :
+ Names.identifier -> constr_expr -> constr_expr -> constr_expr option ->
+  constr_expr option -> constr_expr option -> unit
 
-val general_s_rewrite : bool -> constr -> tactic
+val add_setoid :
+ Names.identifier -> constr_expr -> constr_expr -> constr_expr -> unit
 
-val add_setoid : constr_expr -> constr_expr -> constr_expr -> unit
+val new_named_morphism :
+ Names.identifier -> constr_expr -> morphism_signature option -> unit
 
-val new_named_morphism : Names.identifier -> constr_expr -> unit
+val relation_table_find : constr -> relation
+val relation_table_mem : constr -> bool
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index 245b5a5b..29150c27 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacinterp.ml,v 1.84.2.11 2005/11/04 09:01:27 herbelin Exp $ *)
+(* $Id: tacinterp.ml 9551 2007-01-29 15:13:35Z bgregoir $ *)
 
 open Constrintern
 open Closure
@@ -32,7 +32,6 @@ open Refiner
 open Tacmach
 open Tactic_debug
 open Topconstr
-open Ast
 open Term
 open Termops
 open Tacexpr
@@ -41,11 +40,19 @@ 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
+open Mod_subst
+open Printer
+open Inductiveops
+open Syntax_def
+open Pretyping
+open Pretyping.Default
+open Pcoq
+
+let safe_msgnl s =
+    try msgnl s with e -> 
+      msgnl 
+	(str "bug in the debugger : " ++
+         str "an exception is raised while printing debug information")
 
 let error_syntactic_metavariables_not_allowed loc =
   user_err_loc 
@@ -72,8 +79,9 @@ type value =
   | 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 of constr   (* includes idents known to be bound and references *)
   | VConstr_context of constr
+  | VList of value list
   | VRec of value ref
 
 let locate_tactic_call loc = function
@@ -111,13 +119,16 @@ let constr_of_VConstr_context = function
     errorlabstrm "constr_of_VConstr_context" (str "not a context variable")
 
 (* Displays a value *)
-let pr_value env = function
+let rec 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>"
+  | VConstr c | VConstr_context c ->
+      (match env with Some env -> pr_lconstr_env env c | _ -> str "a term")
+  | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "a tactic"
+  | VList [] -> str "an empty list"
+  | VList (a::_) ->
+      str "a list (first element is " ++ pr_value env a ++ str")"
 
 (* Transforms a named_context into a (string * constr) list *)
 let make_hyps = List.map (fun (id,_,typ) -> (id, typ))
@@ -126,7 +137,7 @@ let make_hyps = List.map (fun (id,_,typ) -> (id, typ))
 let constr_of_id env id = 
   construct_reference (Environ.named_context env) id
 
-(* To embed several objects in Coqast.t *)
+(* To embed tactics *)
 let ((tactic_in : (interp_sign -> raw_tactic_expr) -> Dyn.t),
      (tactic_out : Dyn.t -> (interp_sign -> raw_tactic_expr))) =
   create "tactic"
@@ -155,45 +166,20 @@ let valueOut = function
   | ast ->
     anomalylabstrm "valueOut" (str "Not a Dynamic ast: ")
 
-(* To embed constr in Coqast.t *)
-let constrIn t = CDynamic (dummy_loc,Pretyping.constr_in t)
+(* To embed constr *)
+let constrIn t = CDynamic (dummy_loc,constr_in t)
 let constrOut = function
   | CDynamic (_,d) ->
     if (Dyn.tag d) = "constr" then
-      Pretyping.constr_out d
+      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
+let dloc = dummy_loc
 
 (* Globalizes the identifier *)
-
 let find_reference env qid =
   (* We first look for a variable of the current proof *)
   match repr_qualid qid with
@@ -201,58 +187,21 @@ let find_reference env qid =
 	-> 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 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)))
+  let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in
+  List.iter
+      (fun (s,t) -> add_primitive_tactic s (TacAtom(dloc,t)))
       [ "red", TacReduce(Red false,nocl);
         "hnf", TacReduce(Hnf,nocl);
         "simpl", TacReduce(Simpl None,nocl);
@@ -261,8 +210,8 @@ let _ =
         "intros", TacIntroPattern [];
         "assumption", TacAssumption;
         "cofix", TacCofix None;
-        "trivial", TacTrivial None;
-        "auto", TacAuto(None,None);
+        "trivial", TacTrivial ([],None);
+        "auto", TacAuto(None,[],None);
         "left", TacLeft NoBindings;
         "right", TacRight NoBindings;
         "split", TacSplit(false,NoBindings);
@@ -270,12 +219,12 @@ let _ =
         "reflexivity", TacReflexivity;
         "symmetry", TacSymmetry nocl
       ];
-    List.iter
+  List.iter
       (fun (s,t) -> add_primitive_tactic s t)
-      [ "idtac",TacId "";
-        "fail", TacFail(ArgArg 0,"");
-        "fresh", TacArg(TacFreshId None)
-      ])
+      [ "idtac",TacId [];
+        "fail", TacFail(ArgArg 0,[]);
+        "fresh", TacArg(TacFreshId [])
+      ]
  
 let lookup_atomic id = Idmap.find id !atomic_mactab
 let is_atomic id = Idmap.mem id !atomic_mactab
@@ -299,6 +248,34 @@ let _ =
       Summary.survive_module = false;
       Summary.survive_section   = false }
 
+(* Tactics table (TacExtend). *)
+
+let tac_tab = Hashtbl.create 17
+
+let add_tactic s t =
+  if Hashtbl.mem tac_tab s then
+    errorlabstrm ("Refiner.add_tactic: ") 
+      (str ("Cannot redeclare tactic "^s));
+  Hashtbl.add tac_tab s t
+
+let overwriting_add_tactic s t =
+  if Hashtbl.mem tac_tab s then begin
+    Hashtbl.remove tac_tab s;
+    warning ("Overwriting definition of tactic "^s)
+  end;
+  Hashtbl.add tac_tab s t
+
+let lookup_tactic s =
+  try 
+    Hashtbl.find tac_tab s
+  with Not_found -> 
+    errorlabstrm "Refiner.lookup_tactic"
+      (str"The tactic " ++ str s ++ str" is not installed")
+(*
+let vernac_tactic (s,args) =
+  let tacfun = lookup_tactic s args in
+  abstract_extended_tactic s args tacfun
+*)
 (* Interpretation of extra generic arguments *)
 type glob_sign = {
   ltacvars : identifier list * identifier list;
@@ -312,7 +289,7 @@ 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)
+  (substitution -> glob_generic_argument -> glob_generic_argument)
 
 let extragenargtab =
   ref (Gmap.empty : (string,interp_genarg_type) Gmap.t)
@@ -326,10 +303,12 @@ 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
+(* Dynamically check that an argument is a tactic, possibly unboxing VRec *)
+let coerce_to_tactic loc id = function
   | VRec v -> !v
-  | a -> a
+  | VTactic _ | VFun _ | VRTactic _ as a -> a
+  | _ -> user_err_loc 
+  (loc, "", str "variable " ++  pr_id id ++ str " should be bound to a tactic")
 
 (*****************)
 (* Globalization *)
@@ -377,43 +356,32 @@ let get_current_context () =
 
 let strict_check = ref false
 
-let adjust_loc loc = if !strict_check then dummy_loc else loc
+let adjust_loc loc = if !strict_check then dloc 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)
+    (dloc,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_or_var ist = function
+  | ArgVar locid -> ArgVar (intern_hyp ist locid)
+  | ArgArg _ 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)
+  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
   | r -> 
       let loc,qid = qualid_of_reference r in
-      try ArgArg (loc,locate_reference qid)
+      try ArgArg (loc,locate_global qid)
       with _ -> 
 	error_global_not_found_loc loc qid
 
@@ -435,16 +403,15 @@ let intern_tactic_reference ist r =
 
 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
+      RVar (dloc,id), None
   | r ->
       let loc,qid = qualid_of_reference r in
-      RRef (loc,locate_reference qid), if strict then None else Some (CRef r)
+      RRef (loc,locate_global qid), if strict then None else Some (CRef r)
 
 let intern_reference strict ist r =
   (try Reference (intern_tac_ref ist r)
    with Not_found ->
-     (try
-       ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+     (try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
       with Not_found ->
         (match r with
           | Ident (loc,id) when is_atomic id -> Tacexp (lookup_atomic id)
@@ -453,13 +420,18 @@ let intern_reference strict ist r =
               let (loc,qid) = qualid_of_reference r in
               error_global_not_found_loc loc qid)))
 
+let intern_message_token ist = function
+  | (MsgString _ | MsgInt _ as x) -> x
+  | MsgIdent id -> MsgIdent (intern_hyp_or_metaid ist id)
+
+let intern_message ist = List.map (intern_message_token ist)
+
 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)
+  | IntroWildcard | IntroAnonymous as x -> x
 
 and intern_case_intro_pattern lf ist =
   List.map (List.map (intern_intro_pattern lf ist))
@@ -469,19 +441,16 @@ let intern_quantified_hypothesis ist x =
      statically check the existence of a quantified hyp); thus nothing to do *)
   x
 
-let intern_constr {ltacvars=lfun; gsigma=sigma; genv=env} c =
+let intern_constr_gen isarity {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;
+    warn (Constrintern.intern_gen isarity ~ltacvars:(fst lfun,[]) sigma env) c
+  in
   (c',if !strict_check then None else Some c)
 
+let intern_constr = intern_constr_gen false
+let intern_type = intern_constr_gen true
+
 (* Globalize bindings *)
 let intern_binding ist (loc,b,c) =
   (loc,intern_quantified_hypothesis ist b,intern_constr ist c)
@@ -504,23 +473,23 @@ let intern_clause_pattern ist (l,occl) =
 let intern_induction_arg ist = function
   | ElimOnConstr c -> ElimOnConstr (intern_constr ist c)
   | ElimOnAnonHyp n as x -> x
-  | ElimOnIdent (loc,id) as x ->
+  | ElimOnIdent (loc,id) ->
       if !strict_check then
 	(* If in a defined tactic, no intros-until *)
-	ElimOnConstr (intern_constr ist (CRef (Ident (dummy_loc,id))))
+	ElimOnConstr (intern_constr ist (CRef (Ident (dloc,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 (loc,id) 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
+	let e = match locate_global qid with
 	  | ConstRef c -> EvalConstRef c
 	  | VarRef c -> EvalVarRef c
 	  | _ -> error_not_evaluable (pr_reference r) in
@@ -529,7 +498,6 @@ let intern_evaluable ist = function
 	  | _ -> 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 ->
@@ -543,50 +511,74 @@ let intern_flag ist red =
 
 let intern_constr_occurrence ist (l,c) = (l,intern_constr ist c)
 
-let intern_redexp ist = function
+let intern_red_expr 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 | ExtraRedExpr _ as r) -> r
+  | Simpl o -> Simpl (option_map (intern_constr_occurrence ist) o)
+  | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r
+  
 
 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)
+      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)
+      DepInversion (k, option_map (intern_constr ist) copt,
+      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)
+let intern_hyp_location ist ((occs,id),hl) =
+  ((List.map (intern_or_var ist) occs,intern_hyp ist (skip_metaid id)), hl)
+
+let interp_constrpattern_gen sigma env ltacvar c =
+  let c = intern_gen false ~allow_soapp:true ~ltacvars:(ltacvar,[])
+                     sigma env c in
+  pattern_of_rawconstr c
 
 (* Reads a pattern *)
-let intern_pattern evc env lfun = function
+let intern_pattern sigma env lfun = function
   | Subterm (ido,pc) ->
-      let (metas,pat) = interp_constrpattern_gen evc env lfun pc  in
+      let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in
       ido, metas, Subterm (ido,pat)
   | Term pc ->
-      let (metas,pat) = interp_constrpattern_gen evc env lfun pc  in
+      let (metas,pat) = interp_constrpattern_gen sigma 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)
+  | ConstrEval (r,c) -> ConstrEval (intern_red_expr 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)
 
+(* External tactics *)
+let print_xml_term = ref (fun _ -> failwith "print_xml_term unset")
+let declare_xml_printer f = print_xml_term := f
+
+let internalise_tacarg ch = G_xml.parse_tactic_arg ch
+
+let extern_tacarg ch env sigma = function
+  | VConstr c -> !print_xml_term ch env sigma c
+  | VTactic _ | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _
+  | VIntroPattern _  | VRec _ | VList _ ->
+      error "Only externing of terms is implemented"
+
+let extern_request ch req gl la =
+  output_string ch "<REQUEST req=\""; output_string ch req;
+  output_string ch "\">\n";
+  List.iter (pf_apply (extern_tacarg ch) gl) la;
+  output_string ch "</REQUEST>\n"
+
 (* Reads the hypotheses of a Match Context rule *)
-let rec intern_match_context_hyps evc env lfun = function
+let rec intern_match_context_hyps sigma 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 ido, metas1, pat = intern_pattern sigma env lfun mp in
+      let lfun, metas2, hyps = intern_match_context_hyps sigma env lfun tl in
       let lfun' = name_cons na (option_cons ido lfun) in
       lfun', metas1@metas2, Hyp (locna,pat)::hyps
   | [] -> lfun, [], []
@@ -615,7 +607,6 @@ let extract_let_names lrc =
       name::l)
     lrc []
 
-
 let clause_app f = function
     { onhyps=None; onconcl=b;concl_occs=nl } ->
       { onhyps=None; onconcl=b; concl_occs=nl }
@@ -630,62 +621,70 @@ let rec intern_atomic lf ist x =
       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')
+      TacIntroMove (option_map (intern_ident lf ist) ido,
+          option_map (intern_hyp ist) ido')
   | TacAssumption -> TacAssumption
   | TacExact c -> TacExact (intern_constr ist c)
+  | TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c)
+  | TacVmCastNoCheck c -> TacVmCastNoCheck (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)
+               option_map (intern_constr_with_bindings ist) cbo)
+  | TacElimType c -> TacElimType (intern_type 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)
+  | TacCaseType c -> TacCaseType (intern_type ist c)
+  | TacFix (idopt,n) -> TacFix (option_map (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
+      let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in
       TacMutualFix (intern_ident lf ist id, n, List.map f l)
-  | TacCofix idopt -> TacCofix (option_app (intern_ident lf ist) idopt)
+  | TacCofix idopt -> TacCofix (option_map (intern_ident lf ist) idopt)
   | TacMutualCofix (id,l) ->
-      let f (id,c) = (intern_ident lf ist id,intern_constr ist c) in
+      let f (id,c) = (intern_ident lf ist id,intern_type 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)
+  | TacCut c -> TacCut (intern_type ist c)
+  | TacAssert (otac,ipat,c) ->
+      TacAssert (option_map (intern_tactic ist) otac,
+                 intern_intro_pattern lf ist ipat,
+                 intern_constr_gen (otac<>None) 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,c,idh) -> 
       TacInstantiate (n,intern_constr ist c,
-		      (clause_app (intern_hyp_location ist) cls))
+		      (match idh with
+			   ConclLocation () -> ConclLocation ()
+			 | HypLocation (id,hloc) -> 
+			      HypLocation(intern_hyp_or_metaid ist id,hloc))) 
+*)
 
   (* Automation tactics *)
-  | TacTrivial l -> TacTrivial l
-  | TacAuto (n,l) -> TacAuto (option_app (intern_int_or_var ist) n,l)
+  | TacTrivial (lems,l) -> TacTrivial (List.map (intern_constr ist) lems,l)
+  | TacAuto (n,lems,l) ->
+      TacAuto (option_map (intern_or_var ist) n,
+        List.map (intern_constr ist) lems,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 (option_app (intern_int_or_var ist) n,p)
+  | TacDAuto (n,p) -> TacDAuto (option_map (intern_or_var ist) 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'))
+  | TacSimpleInduction h ->
+      TacSimpleInduction (intern_quantified_hypothesis ist h)
+  | TacNewInduction (lc,cbo,ids) ->
+      TacNewInduction (List.map (intern_induction_arg ist) lc,
+               option_map (intern_constr_with_bindings ist) cbo,
+               (intern_intro_pattern lf ist 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'))
+  | TacNewDestruct (c,cbo,ids) ->
+      TacNewDestruct (List.map (intern_induction_arg ist) c,
+               option_map (intern_constr_with_bindings ist) cbo,
+	       (intern_intro_pattern lf ist ids))
   | TacDoubleInduction (h1,h2) ->
       let h1 = intern_quantified_hypothesis ist h1 in
       let h2 = intern_quantified_hypothesis ist h2 in
@@ -698,7 +697,7 @@ let rec intern_atomic lf ist x =
   | TacLApply c -> TacLApply (intern_constr ist c)
 
   (* Context management *)
-  | TacClear l -> TacClear (List.map (intern_hyp_or_metaid ist) l)
+  | TacClear (b,l) -> TacClear (b,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)
@@ -708,15 +707,16 @@ let rec intern_atomic lf ist x =
   | 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)
+  | TacAnyConstructor t -> TacAnyConstructor (option_map (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)
+      TacReduce (intern_red_expr 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)
+      TacChange (option_map (intern_constr_occurrence ist) occl,
+        (if occl = None then intern_type ist c else intern_constr ist c),
+	clause_app (intern_hyp_location ist) cl)
 
   (* Equivalence relations *)
   | TacReflexivity -> TacReflexivity
@@ -725,6 +725,9 @@ let rec intern_atomic lf ist x =
   | TacTransitivity c -> TacTransitivity (intern_constr ist c)
 
   (* Equality and inversion *)
+  | TacRewrite (b,c,cl) -> 
+      TacRewrite (b,intern_constr_with_bindings ist c,
+		  clause_app (intern_hyp_location ist) cl)
   | TacInversion (inv,hyp) ->
       TacInversion (intern_inversion_strength lf ist inv,
         intern_quantified_hypothesis ist hyp)
@@ -734,21 +737,13 @@ let rec intern_atomic lf ist x =
       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))
+      let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
+      try TacAlias (loc,s,l,(dir,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
@@ -763,16 +758,17 @@ and intern_tactic_seq ist = function
   | 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
+          (n,option_map (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)
+  | TacMatchContext (lz,lr,lmr) ->
+      ist.ltacvars, TacMatchContext(lz,lr, intern_match_rule ist lmr)
+  | TacMatch (lz,c,lmr) ->
+      ist.ltacvars, TacMatch (lz,intern_tactic ist c,intern_match_rule ist lmr)
+  | TacId l -> ist.ltacvars, TacId (intern_message ist l)
+  | TacFail (n,l) -> 
+      ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l)
   | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac)
   | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s)
   | TacThen (t1,t2) ->
@@ -785,7 +781,7 @@ and intern_tactic_seq ist = function
       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)
+      ist.ltacvars, TacDo (intern_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)
@@ -793,6 +789,7 @@ and intern_tactic_seq ist = function
       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)
+  | TacComplete tac -> ist.ltacvars, TacComplete (intern_tactic ist tac)
   | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a)
 
 and intern_tactic_fun ist (var,body) = 
@@ -811,14 +808,15 @@ and intern_tacarg strict ist = function
   | 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))
+      if find_ltacvar id ist then Reference (ArgVar (adjust_loc loc,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
+  | TacExternal (loc,com,req,la) -> 
+      TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la)
+  | TacFreshId x -> TacFreshId (List.map (intern_or_var ist) x)
   | Tacexp t -> Tacexp (intern_tactic ist t)
   | TacDynamic(loc,t) as x ->
       (match tag t with
@@ -845,7 +843,7 @@ and intern_genarg ist 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))
+        (intern_or_var ist (out_gen rawwit_int_or_var x))
   | StringArgType ->
       in_gen globwit_string (out_gen rawwit_string x)
   | PreIdentArgType ->
@@ -858,7 +856,7 @@ and intern_genarg ist x =
   | IdentArgType ->
       let lf = ref ([],[]) in
       in_gen globwit_ident(intern_ident lf ist (out_gen rawwit_ident x))
-  | HypArgType ->
+  | VarArgType ->
       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))
@@ -873,15 +871,10 @@ and intern_genarg ist x =
       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))
-  | OpenConstrArgType ->
-      in_gen globwit_open_constr
-      ((),intern_constr ist (snd (out_gen rawwit_open_constr x)))
-  | CastedOpenConstrArgType ->
-      in_gen globwit_casted_open_constr 
-        ((),intern_constr ist (snd (out_gen rawwit_casted_open_constr x)))
+      in_gen globwit_red_expr (intern_red_expr ist (out_gen rawwit_red_expr x))
+  | OpenConstrArgType b ->
+      in_gen (globwit_open_constr_gen b)
+        ((),intern_constr ist (snd (out_gen (rawwit_open_constr_gen b) x)))
   | ConstrWithBindingsArgType ->
       in_gen globwit_constr_with_bindings
         (intern_constr_with_bindings ist (out_gen rawwit_constr_with_bindings x))
@@ -892,7 +885,14 @@ and 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
+  | ExtraArgType s ->
+      match tactic_genarg_level s with
+      | Some n -> 
+          (* Special treatment of tactic arguments *)
+          in_gen (globwit_tactic n) (intern_tactic ist
+	    (out_gen (rawwit_tactic n) x))
+      | None ->
+          lookup_genarg_glob s ist x
 
 (************* End globalization ************)
 
@@ -918,55 +918,45 @@ let give_context ctxt = function
   | None -> []
   | Some id -> [id,VConstr_context ctxt]
 
-(* Reads a pattern by substituing vars of lfun *)
+(* Reads a pattern by substituting vars of lfun *)
 let eval_pattern lfun c = 
-  let lvar = List.map (fun (id,c) -> (id,pattern_of_constr c)) lfun in
+  let lvar = List.map (fun (id,c) -> (id,lazy(pattern_of_constr c))) lfun in
   instantiate_pattern lvar c
 
-let read_pattern evc env lfun = function
+let read_pattern 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",
+    user_err_loc (dloc,"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
+let rec read_match_context_hyps 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)
+      Hyp (locna,read_pattern lfun mp)::
+	(read_match_context_hyps 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)
+let rec read_match_rule lfun = function
+  | (All tc)::tl -> (All tc)::(read_match_rule 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)
+      Pat (read_match_context_hyps lfun [] rl, read_pattern lfun mp,tc)
+      :: read_match_rule 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
+exception Eval_fail of std_ppcmds
 
 let is_match_catchable = function
-  | No_match | Eval_fail _ -> true
-  | e -> is_failure e or Logic.catchable_exception e
-
-let hack_fail_level_shift = ref 0
-let hack_fail_level n =
-  if n >= !hack_fail_level_shift then n - !hack_fail_level_shift else 0
+  | PatternMatchingFailure | Eval_fail _ -> true
+  | e -> Logic.catchable_exception e
 
 (* Verifies if the matched list is coherent with respect to lcm *)
 let rec verify_metas_coherence gl lcm = function
@@ -977,17 +967,9 @@ let rec verify_metas_coherence gl lcm = function
       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
@@ -1002,18 +984,18 @@ let apply_one_mhyp_context ist env gl lmatch (hypname,pat) (lhyps,nocc) =
             apply_one_mhyp_context_rec 0 tl)
       | Subterm (ic,t) ->
         (try
-          let (lm,ctxt) = sub_match nocc t hyp in
+          let (lm,ctxt) = match_subterm 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 _ ->
+         | PatternMatchingFailure ->
              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
+        raise PatternMatchingFailure
       in
   apply_one_mhyp_context_rec nocc lhyps
 
@@ -1022,9 +1004,12 @@ let constr_to_id loc = function
   | _ -> invalid_arg_loc (loc, "Not an identifier")
 
 let constr_to_qid loc c =
-  try shortest_qualid_of_global Idset.empty (reference_of_constr c)
+  try shortest_qualid_of_global Idset.empty (global_of_constr c)
   with _ -> invalid_arg_loc (loc, "Not a global reference")
 
+let is_variable env id =
+  List.mem id (ids_of_named_context (Environ.named_context env))
+
 (* Debug reference *)
 let debug = ref DebugOff
 
@@ -1034,82 +1019,115 @@ let set_debug pos = debug := pos
 (* Gives the state of debug *)
 let get_debug () = !debug
 
+let error_ltac_variable loc id env v s =
+   user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ 
+   str " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ 
+   str "which cannot be coerced to " ++ str s)
+
+exception CannotCoerceTo of string
+
+(* Raise Not_found if not in interpretation sign *)
+let try_interp_ltac_var coerce ist env (loc,id) =
+  let v = List.assoc id ist.lfun in
+  try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s
+
+let interp_ltac_var coerce ist env locid =
+  try try_interp_ltac_var coerce ist env locid
+  with Not_found -> anomaly "Detected as ltac var at interning time"
+
 (* Interprets an identifier which must be fresh *)
-let interp_ident ist id =
-  try match List.assoc id ist.lfun with
+let coerce_to_ident env = function
   | 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 *)
+  | VConstr c when isVar c & not (is_variable env (destVar c)) ->
+      (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
       destVar c
-  | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++ 
-         str ") should have been bound to an identifier")
+  | v -> raise (CannotCoerceTo "a fresh identifier")
+
+let interp_ident ist gl id =
+  let env = pf_env gl in
+  try try_interp_ltac_var (coerce_to_ident env) ist (Some env) (dloc,id)
   with Not_found -> id
 
-let interp_intro_pattern_var ist id =
-  try match List.assoc id ist.lfun with
+(* Interprets an optional identifier which must be fresh *)
+let interp_name ist gl = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (interp_ident ist gl id)
+
+let coerce_to_intro_pattern env = function
   | 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 *)
+  | VConstr c when isVar c ->
+      (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
+      (* but also in "destruct H as (H,H')" *)
       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")
+  | v -> raise (CannotCoerceTo "an introduction pattern")
+
+let interp_intro_pattern_var ist env id =
+  try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env)(dloc,id)
   with Not_found -> IntroIdentifier id
 
-let interp_int lfun (loc,id) =
-  try match List.assoc id lfun with
+let coerce_to_hint_base = function
+  | VIntroPattern (IntroIdentifier id) -> string_of_id id
+  | _ -> raise (CannotCoerceTo "a hint base name")
+
+let interp_hint_base ist s =
+  try try_interp_ltac_var coerce_to_hint_base ist None (dloc,id_of_string s)
+  with Not_found -> s
+
+let coerce_to_int = function
   | 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")
+  | v -> raise (CannotCoerceTo "an integer")
+
+let interp_int ist locid =
+  try try_interp_ltac_var coerce_to_int ist None locid
+  with Not_found -> user_err_loc(fst locid,"interp_int",str "Unbound variable")
 
 let interp_int_or_var ist = function
-  | ArgVar locid -> interp_int ist.lfun locid
+  | ArgVar locid -> interp_int ist locid
   | ArgArg n -> n
 
+let int_or_var_list_of_VList = function
+  | VList l -> List.map (fun n -> ArgArg (coerce_to_int n)) l
+  | _ -> raise Not_found
+
+let interp_int_or_var_as_list ist = function
+  | ArgVar (_,id as locid) -> 
+      (try int_or_var_list_of_VList (List.assoc id ist.lfun)
+       with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)])
+  | ArgArg n as x -> [x]
+
+let interp_int_or_var_list ist l =
+  List.flatten (List.map (interp_int_or_var_as_list ist) l)
+
 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
+let coerce_to_hyp env = function
+  | VConstr c 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
+  | _ -> raise (CannotCoerceTo "a variable")
 
-(* 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) =
+(* Interprets a bound variable (especially an existing hypothesis) *)
+let interp_hyp ist gl (loc,id as locid) =
+  let env = pf_env gl in
   (* 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")
+  try try_interp_ltac_var (coerce_to_hyp env) ist (Some env) locid
   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")
+  if is_variable env id then id
+  else user_err_loc (loc,"eval_variable",pr_id id ++ str " not found")
+
+let hyp_list_of_VList env = function
+  | VList l -> List.map (coerce_to_hyp env) l
+  | _ -> raise Not_found
 
-(* Interprets an existing hypothesis (i.e. a declared variable) *)
-let interp_hyp = interp_var
+let interp_hyp_list_as_list ist gl (loc,id as x) =
+  try hyp_list_of_VList (pf_env gl) (List.assoc id ist.lfun)
+  with Not_found | CannotCoerceTo _ -> [interp_hyp ist gl x]
 
-let interp_name ist = function
-  | Anonymous -> Anonymous
-  | Name id -> Name (interp_ident ist id)
+let interp_hyp_list ist gl l =
+  List.flatten (List.map (interp_hyp_list_as_list ist gl) l)
 
 let interp_clause_pattern ist gl (l,occl) =
   let rec check acc = function
@@ -1122,35 +1140,60 @@ let interp_clause_pattern ist gl (l,occl) =
   in (l,check [] occl)
 
 (* Interprets a qualified name *)
+let coerce_to_reference env v =
+  try match v with
+  | VConstr c -> global_of_constr c (* may raise Not_found *)
+  | _ -> raise Not_found
+  with Not_found -> raise (CannotCoerceTo "a reference")
+
 let interp_reference ist env = function
   | ArgArg (_,r) -> r
-  | ArgVar (loc,id) -> coerce_to_reference env (unrec (List.assoc id ist.lfun))
+  | ArgVar locid -> 
+      interp_ltac_var (coerce_to_reference env) ist (Some env) locid
 
 let pf_interp_reference ist gl = interp_reference ist (pf_env gl)
 
+let coerce_to_inductive = function
+  | VConstr c when isInd c -> destInd c
+  | _ -> raise (CannotCoerceTo "an inductive type")
+
 let interp_inductive ist = function
   | ArgArg r -> r
-  | ArgVar (_,id) -> coerce_to_inductive (unrec (List.assoc id ist.lfun))
+  | ArgVar locid -> interp_ltac_var coerce_to_inductive ist None locid
+
+let coerce_to_evaluable_ref env v =
+  let ev = match v with
+    | VConstr c when isConst c -> EvalConstRef (destConst c)
+    | VConstr c when isVar c -> EvalVarRef (destVar c)
+    | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env) 
+	-> EvalVarRef id
+    | _ -> raise (CannotCoerceTo "an evaluable reference")
+  in
+  if not (Tacred.is_evaluable env ev) then
+    raise (CannotCoerceTo "an evaluable reference")
+  else
+    ev
 
 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)
+       | (_,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))
+  | ArgVar locid -> 
+      interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid
 
 (* Interprets an hypothesis name *)
-let interp_hyp_location ist gl (id,occs,hl) = (interp_hyp ist gl id,occs,hl)
+let interp_hyp_location ist gl ((occs,id),hl) =
+  ((interp_int_or_var_list ist occs,interp_hyp ist gl id),hl)
 
 let interp_clause ist gl { onhyps=ol; onconcl=b; concl_occs=occs } =
-  { onhyps=option_app(List.map (interp_hyp_location ist gl)) ol;
+  { onhyps=option_map(List.map (interp_hyp_location ist gl)) ol;
     onconcl=b;
     concl_occs=occs }
 
@@ -1175,88 +1218,164 @@ let rec intropattern_ids = function
   | IntroIdentifier id -> [id]
   | IntroOrAndPattern ll -> 
       List.flatten (List.map intropattern_ids (List.flatten ll))
-  | IntroWildcard -> []
+  | IntroWildcard | IntroAnonymous -> []
 
-let rec extract_ids = function
-  | (id,VIntroPattern ipat)::tl -> intropattern_ids ipat @ extract_ids tl
-  | _::tl -> extract_ids tl
+let rec extract_ids ids = function
+  | (id,VIntroPattern ipat)::tl when not (List.mem id ids) ->
+      intropattern_ids ipat @ extract_ids ids tl
+  | _::tl -> extract_ids ids tl
   | [] -> []
 
+let default_fresh_id = id_of_string "H"
+
+let interp_fresh_id ist gl l =
+  let ids = map_succeed (function ArgVar(_,id) -> id | _ -> failwith "") l in
+  let avoid = extract_ids ids ist.lfun in
+  let id = 
+    if l = [] then default_fresh_id 
+    else
+      id_of_string (String.concat "" (List.map (function
+	| ArgArg s -> s
+	| ArgVar (_,id) -> string_of_id (interp_ident ist gl id)) l)) in 
+  Tactics.fresh_id avoid id gl
+
+(* To retype a list of key*constr with undefined key *)
 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 implicit_tactic = ref None
 
-let interp_constr ist sigma env c =
-  interp_casted_constr None ist sigma env c
+let declare_implicit_tactic tac = implicit_tactic := Some tac
 
-(* Interprets an open constr expression casted by the current goal *)
-let pf_interp_openconstr_gen casted ist gl (c,ce) =
-  let sigma = project gl in
-  let env = pf_env gl in
-  let (ltacvars,l) = constr_list ist env in
+open Evd
+
+let solvable_by_tactic env evi (ev,args) src = 
+  match (!implicit_tactic, src) with
+  | Some tac, (ImplicitArg _ | QuestionMark)
+      when 
+	Environ.named_context_of_val evi.evar_hyps = 
+	Environ.named_context env ->
+      let id = id_of_string "H" in
+      start_proof id (Local,Proof Lemma) evi.evar_hyps evi.evar_concl
+	(fun _ _ -> ());
+      begin
+	try
+	  by (tclCOMPLETE tac);
+	  let _,(const,_,_) = cook_proof () in 
+	  delete_current_proof (); const.const_entry_body
+	with e when Logic.catchable_exception e -> 
+	  delete_current_proof();
+	  raise Exit
+      end
+  | _ -> raise Exit
+
+let solve_remaining_evars env initial_sigma evars c =
+  let isevars = ref evars in
+  let rec proc_rec c =
+    match kind_of_term (Reductionops.whd_evar (evars_of !isevars) c) with
+      | Evar (ev,args as k) when not (Evd.mem initial_sigma ev) ->
+            let (loc,src) = evar_source ev !isevars in
+	    let sigma = evars_of !isevars in
+	    (try 
+	      let evi = Evd.find sigma ev in
+	      let c = solvable_by_tactic env evi k src in
+	      isevars := Evd.evar_define ev c !isevars;
+	      c
+	    with Exit ->
+	      Pretype_errors.error_unsolvable_implicit loc env sigma src)
+      | _ -> map_constr proc_rec c      
+  in
+  proc_rec c
+
+let interp_gen kind ist sigma env (c,ce) =
+  let (ltacvars,unbndltacvars) = constr_list ist env in
   let typs = retype_list sigma env ltacvars in
-  let ocl = if casted then Some (pf_concl gl) else None in
-  match ce with
-  | None ->
-      Pretyping.understand_gen_tcc sigma env typs ocl c
+  let c = match ce with
+  | None -> 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
+  | Some c ->
+      let ltacdata = (List.map fst ltacvars,unbndltacvars) in
+      intern_gen (kind = IsType) ~ltacvars:ltacdata sigma env c in
+  understand_ltac sigma env (typs,unbndltacvars) kind c
+
+(* Interprets a constr and solve remaining evars with default tactic *)
+let interp_econstr kind ist sigma env cc =
+  let evars,c = interp_gen kind ist sigma env cc in
+  let csr = solve_remaining_evars env sigma evars c in
+  db_constr ist.debug env csr;
+  csr
+
+(* Interprets an open constr *)
+let interp_open_constr ccl ist sigma env cc =
+  let isevars,c = interp_gen (OfType ccl) ist sigma env cc in
+  (evars_of isevars,c)
+
+let interp_constr = interp_econstr (OfType None)
 
-let pf_interp_casted_openconstr = pf_interp_openconstr_gen true
-let pf_interp_openconstr = pf_interp_openconstr_gen false
+let interp_type = interp_econstr IsType
+
+(* Interprets a constr expression casted by the current goal *)
+let pf_interp_casted_constr ist gl cc =
+  interp_econstr (OfType (Some (pf_concl gl))) ist (project gl) (pf_env gl) cc
+
+(* Interprets an open constr expression *)
+let pf_interp_open_constr casted ist gl cc =
+  let cl = if casted then Some (pf_concl gl) else None in
+  interp_open_constr cl ist (project gl) (pf_env gl) cc
 
 (* 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
+let constr_list_of_VList env = function
+  | VList l -> List.map (constr_of_value env) l
+  | _ -> raise Not_found
+      
+let pf_interp_constr_list_as_list ist gl (c,_ as x) =
+  match c with
+    | RVar (_,id) ->
+        (try constr_list_of_VList (pf_env gl) (List.assoc id ist.lfun)
+        with Not_found -> [interp_constr ist (project gl) (pf_env gl) x])
+    | _ -> [interp_constr ist (project gl) (pf_env gl) x]
+
+let pf_interp_constr_list ist gl l =
+  List.flatten (List.map (pf_interp_constr_list_as_list ist gl) l)
+
+(* Interprets a type expression *)
+let pf_interp_type ist gl =
+  interp_type ist (project gl) (pf_env gl)
 
 (* Interprets a reduction expression *)
 let interp_unfold ist env (l,qid) =
-  (l,interp_evaluable ist env qid)
+  (interp_int_or_var_list ist 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 interp_pattern ist sigma env (l,c) = 
+  (interp_int_or_var_list ist 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
+let interp_red_expr 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 | ExtraRedExpr _ as r) -> r
+  | Simpl o -> Simpl (option_map (interp_pattern ist sigma env) o)
+  | (Red _ |  Hnf | ExtraRedExpr _ | CbvVm as r) -> r
 
-let pf_redexp_interp ist gl = redexp_interp ist (project gl) (pf_env gl)
+let pf_interp_red_expr ist gl = interp_red_expr 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)
+      let redexp = pf_interp_red_expr ist gl  r in
+      pf_reduction_of_red_expr gl redexp (f ist gl c)
   | ConstrContext ((loc,s),c) ->
       (try
 	let ic = f ist gl c
@@ -1267,43 +1386,104 @@ let interp_may_eval f ist gl = function
 	    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
+  | ConstrTerm c -> 
+     try 
+	f ist gl c
+     with e -> 
+	begin 
+	  match ist.debug with 
+	    DebugOn lev -> 
+	    safe_msgnl (str "Level " ++ int lev ++
+                          str ": interpretation of term " ++ 
+			   Printer.pr_rawconstr_env (pf_env gl) (fst c) ++
+			   str " raised an exception" ++
+			   fnl() ++
+			   !Tactic_debug.explain_logic_error_no_anomaly e)
+	| _ -> ()
+     end;
+     raise e  
 
 (* 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
+  let csr = 
+    try
+      interp_may_eval pf_interp_constr ist gl c
+    with e -> 
+      begin match ist.debug with
+	  DebugOn lev -> 
+	    safe_msgnl (str "Level " ++ int lev ++
+                           str ": evaluation of term raised an exception" ++
+			   fnl() ++
+			   !Tactic_debug.explain_logic_error_no_anomaly e)
+	| _ -> ()
+      end;
+      raise e
+  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))
+let message_of_value = function
+  | VVoid -> str "()"
+  | VInteger n -> int n
+  | VIntroPattern ipat -> pr_intro_pattern ipat
+  | VConstr_context c | VConstr c -> pr_constr c
+  | VRec _ | VTactic _ | VRTactic _ | VFun _ -> str "<tactic>"
+  | VList _ -> str "<list>"
+
+let rec interp_message ist = function
+  | [] -> mt()
+  | MsgString s :: l -> pr_arg str s ++ interp_message ist l
+  | MsgInt n :: l -> pr_arg int n ++ interp_message ist l
+  | MsgIdent (loc,id) :: l ->
+      let v =
+	try List.assoc id ist.lfun
+	with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found") in
+      pr_arg message_of_value v ++ interp_message ist l
+
+let rec interp_message_nl ist = function
+  | [] -> mt()
+  | l -> interp_message ist l ++ fnl()
+
+let rec interp_intro_pattern ist gl = function
+  | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist gl l)
+  | IntroIdentifier id -> interp_intro_pattern_var ist (pf_env gl) id
+  | IntroWildcard | IntroAnonymous as x -> x
+
+and interp_case_intro_pattern ist gl =
+  List.map (List.map (interp_intro_pattern ist gl))
 
 (* Quantified named or numbered hypothesis or hypothesis in context *)
 (* (as in Inversion) *)
+let coerce_to_quantified_hypothesis = function
+  | VInteger n -> AnonHyp n
+  | VIntroPattern (IntroIdentifier id) -> NamedHyp id
+  | v -> raise (CannotCoerceTo "a quantified hypothesis")
+
 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
+      try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id)
+      with Not_found 
+      | Stdpp.Exc_located (_, UserError _) | UserError _ (*Compat provisoire*)
+   -> NamedHyp id
 
 (* Quantified named or numbered hypothesis or hypothesis in context *)
 (* (as in Inversion) *)
+let coerce_to_decl_or_quant_hyp env = function
+  | VInteger n -> AnonHyp n
+  | v -> 
+      try NamedHyp (coerce_to_hyp env v)
+      with CannotCoerceTo _ -> 
+	raise (CannotCoerceTo "a declared or quantified hypothesis")
+
 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)
+      let env = pf_env gl in
+      try try_interp_ltac_var 
+	    (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id)
       with Not_found -> NamedHyp id
 
 let interp_induction_arg ist gl = function
@@ -1319,12 +1499,16 @@ let interp_binding ist gl (loc,b,c) =
 
 let interp_bindings ist gl = function
 | NoBindings -> NoBindings
-| ImplicitBindings l -> ImplicitBindings (List.map (pf_interp_constr ist gl) l)
+| ImplicitBindings l -> ImplicitBindings (pf_interp_constr_list 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)
 
+let mk_constr_value ist gl c = VConstr (pf_interp_constr ist gl c)
+let mk_hyp_value ist gl c = VConstr (mkVar (interp_hyp ist gl c))
+let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c)
+
 (* Interprets an l-tac expression into a value *)
 let rec val_interp ist gl (tac:glob_tactic_expr) =
 
@@ -1335,11 +1519,11 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
   | 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
+  | TacMatchContext (lz,lr,lmr) -> interp_match_context ist gl lz lr lmr 
+  | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
   | TacArg a -> interp_tacarg ist gl a
   (* Delayed evaluation *)
-  | t -> VTactic (dummy_loc,eval_tactic ist t)
+  | t -> VTactic (dloc,eval_tactic ist t)
 
   in check_for_interrupt (); 
     match ist.debug with
@@ -1349,13 +1533,10 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
 
 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 (hack_fail_level (interp_int_or_var ist n)) s
+  | TacFun _ | TacLetRecIn _ | TacLetIn _ -> assert false
+  | TacMatchContext _ | TacMatch _ -> assert false
+  | TacId s -> tclIDTAC_MESSAGE (interp_message_nl ist s)
+  | TacFail (n,s) -> tclFAIL (interp_int_or_var ist n) (interp_message ist 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)
@@ -1369,29 +1550,34 @@ and eval_tactic ist = function
         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)
+  | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac)
   | TacArg a -> assert false
 
-and interp_ltac_reference isapplied ist gl = function
-  | ArgVar (loc,id) -> unrec (List.assoc id ist.lfun)
+and interp_ltac_reference isapplied mustbetac ist gl = function
+  | ArgVar (loc,id) ->
+      let v = List.assoc id ist.lfun in
+      if mustbetac then coerce_to_tactic loc id v else v
   | 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
+  | Reference r -> interp_ltac_reference false false ist gl r
   | Integer n -> VInteger n
-  | IntroPattern ipat -> VIntroPattern ipat
+  | IntroPattern ipat -> VIntroPattern (interp_intro_pattern ist gl ipat)
   | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c)
   | MetaIdArg (loc,id) -> assert false
+  | TacCall (loc,r,[]) -> interp_ltac_reference false true ist gl r
   | TacCall (loc,f,l) ->
-      let fv = interp_ltac_reference true ist gl f
+      let fv = interp_ltac_reference true 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
+  | TacExternal (loc,com,req,la) ->
+      interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la)
+  | TacFreshId l -> 
+      let id = interp_fresh_id ist gl l in
       VIntroPattern (IntroIdentifier id)
   | Tacexp t -> val_interp ist gl t
   | TacDynamic(_,t) ->
@@ -1406,9 +1592,9 @@ and interp_tacarg ist gl = function
       else if tg = "value" then
         value_out t
       else if tg = "constr" then
-        VConstr (Pretyping.constr_out t)
+        VConstr (constr_out t)
       else
-        anomaly_loc (loc, "Tacinterp.val_interp",
+        anomaly_loc (dloc, "Tacinterp.val_interp",
           (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
 
 (* Interprets an application node *)
@@ -1417,7 +1603,31 @@ and interp_app ist gl fv largs loc =
     | 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
+	let v = 
+          let res = 
+	    try
+	      val_interp { ist with lfun=newlfun@olfun } gl body
+	    with e ->
+	      begin match ist.debug with
+		  DebugOn lev -> 
+		    safe_msgnl 
+		      (str "Level " ++ int lev ++ 
+			  str ": evaluation raises an exception" ++
+                          fnl() ++
+			  !Tactic_debug.explain_logic_error_no_anomaly e)
+		| _ -> ()
+	      end;
+	      raise e
+	  in
+	    (match ist.debug with
+		DebugOn lev -> 
+		  safe_msgnl (str "Level " ++ int lev ++ 
+				 str ": evaluation returns" ++ fnl() ++
+				 pr_value (Some (pf_env gl)) res)
+	      | _ -> ());
+	    res
+	in
+
         if lval=[] then locate_tactic_call loc v
 	else interp_app ist gl v lval loc
       else
@@ -1435,10 +1645,10 @@ and tactic_of_value vle g =
   | _ -> raise NotTactic
 
 (* Evaluation with FailError catching *)
-and eval_with_fail ist tac goal =
+and eval_with_fail ist is_lazy goal tac =
   try
     (match val_interp ist goal tac with
-    | VTactic (loc,tac) -> VRTactic (catch_error loc tac goal)
+    | VTactic (loc,tac) when not is_lazy -> VRTactic (catch_error loc tac goal)
     | a -> a)
   with
     | Stdpp.Exc_located (_,FailError (0,s)) | FailError (0,s) ->
@@ -1478,96 +1688,72 @@ and interp_letin ist gl = function
       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 _ _ -> ());
+	let ndc = Environ.named_context_val env in
+	start_proof id (Local,Proof Lemma) ndc typ (fun _ _ -> ());
 	by t;
 	let (_,({const_entry_body = pft},_,_)) = cook_proof () in
-	delete_proof (dummy_loc,id);
+	delete_proof (dloc,id);
         pft
       with | NotTactic ->
-	delete_proof (dummy_loc,id);
+	delete_proof (dloc,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)
+    in (id,VConstr (mkCast (csr,DEFAULTcast, typ)))::(interp_letin ist gl tl)
 
 (* Interprets the Match Context expressions *)
-and interp_match_context ist g lr lmr =
+and interp_match_context ist g lz 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 lctxt 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 (lgoal,ctxt) = match_subterm nocc c csr in
+    let lctxt = give_context ctxt id in
+      try apply_hyps_context ist env lz goal mt lctxt lgoal mhyps hyps
+      with 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_failure e -> raise e
-         | 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
+      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;
-	      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_failure e -> raise e
-        | 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_failure e -> raise e
-         | e when is_match_catchable e ->
-           apply_match_context ist env goal (nrs+1) (List.tl lex) tl))
-    | _ ->
-      errorlabstrm "Tacinterp.apply_match_context"
-        (v 0 (str "No matching clauses for match goal" ++
-        (if ist.debug=DebugOff then
-           fnl() ++ str "(use \"Debug On\" for more info)"
-         else mt())))
+              try eval_with_fail ist lz goal t
+              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 = matches mg concl in
+			  db_matched_concl ist.debug (pf_env goal) concl;
+			  apply_hyps_context ist env lz goal mt [] lgoal mhyps hyps
+		      with e when is_match_catchable e ->
+			(match e with
+			   | PatternMatchingFailure -> 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)
+		 | Subterm (id,mg) ->
+		     (try apply_goal_sub ist env goal 0 (id,mg) concl mt mhyps hyps
+		      with
+			| PatternMatchingFailure ->
+			    apply_match_context ist env goal (nrs+1) (List.tl lex) tl))
+	| _ ->
+	    errorlabstrm "Tacinterp.apply_match_context"
+              (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)
+    apply_match_context ist env g 0 lmr
+      (read_match_rule (fst (constr_list ist env)) lmr)
 
 (* Tries to match the hypotheses in a Match Context *)
-and apply_hyps_context ist env goal mt lctxt lgmatch mhyps hyps =
+and apply_hyps_context ist env lz goal mt lctxt 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) =
@@ -1578,20 +1764,23 @@ and apply_hyps_context ist env goal mt lctxt lgmatch mhyps hyps =
             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 -> 
+          with 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
+        eval_with_fail {ist with lfun=lmatch@lfun@ist.lfun} lz goal mt
   in
   apply_hyps_context_rec lctxt lgmatch hyps (hyps,0) mhyps
 
+and interp_external loc ist gl com req la =
+  let f ch = extern_request ch req gl la in
+  let g ch = internalise_tacarg ch in
+  interp_tacarg ist gl (System.connect f g com)
+
   (* Interprets extended tactic generic arguments *)
-and interp_genarg ist goal x =
+and interp_genarg ist gl 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)
@@ -1604,166 +1793,267 @@ and interp_genarg ist goal x =
       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))
+        (interp_intro_pattern ist gl (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)))
+      in_gen wit_ident (interp_ident ist gl (out_gen globwit_ident x))
+  | VarArgType ->
+      in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x))
   | RefArgType ->
-      in_gen wit_ref (pf_interp_reference ist goal (out_gen globwit_ref x))
+      in_gen wit_ref (pf_interp_reference ist gl (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)))
+	  (pf_interp_constr ist gl 
+	    (RSort (dloc,out_gen globwit_sort x), None)))
   | ConstrArgType ->
-      in_gen wit_constr (pf_interp_constr ist goal (out_gen globwit_constr x))
+      in_gen wit_constr (pf_interp_constr ist gl (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))
+      in_gen wit_constr_may_eval (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
   | QuantHypArgType ->
       in_gen wit_quant_hyp
-        (interp_declared_or_quantified_hypothesis ist goal
+        (interp_declared_or_quantified_hypothesis ist gl
           (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)
-  | OpenConstrArgType ->
-      in_gen wit_open_constr 
-        (pf_interp_openconstr ist goal (snd (out_gen globwit_open_constr x)))
-  | CastedOpenConstrArgType ->
-      in_gen wit_casted_open_constr 
-        (pf_interp_casted_openconstr ist goal (snd (out_gen globwit_casted_open_constr x)))
+      in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x))
+  | OpenConstrArgType casted ->
+      in_gen (wit_open_constr_gen casted) 
+        (pf_interp_open_constr casted ist gl 
+          (snd (out_gen (globwit_open_constr_gen casted) x)))
   | ConstrWithBindingsArgType ->
       in_gen wit_constr_with_bindings
-        (interp_constr_with_bindings ist goal (out_gen globwit_constr_with_bindings x))
+        (interp_constr_with_bindings ist gl (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
+        (interp_bindings ist gl (out_gen globwit_bindings x))
+  | List0ArgType ConstrArgType -> interp_genarg_constr_list0 ist gl x
+  | List1ArgType ConstrArgType -> interp_genarg_constr_list1 ist gl x
+  | List0ArgType _ -> app_list0 (interp_genarg ist gl) x
+  | List1ArgType _ -> app_list1 (interp_genarg ist gl) x
+  | OptArgType _ -> app_opt (interp_genarg ist gl) x
+  | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
+  | ExtraArgType s -> 
+      match tactic_genarg_level s with
+      | Some n -> 
+          (* Special treatment of tactic arguments *)
+          in_gen (wit_tactic n) (out_gen (globwit_tactic n) x)
+      | None -> 
+          lookup_interp_genarg s ist gl x
+
+and interp_genarg_constr_list0 ist gl x =
+  let lc = out_gen (wit_list0 globwit_constr) x in
+  let lc = pf_interp_constr_list ist gl lc in
+  in_gen (wit_list0 wit_constr) lc
+
+and interp_genarg_constr_list1 ist gl x =
+  let lc = out_gen (wit_list1 globwit_constr) x in
+  let lc = pf_interp_constr_list ist gl lc in
+  in_gen (wit_list1 wit_constr) lc
 
 (* 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
-         | e when is_match_catchable e -> 
-             apply_sub_match ist (nocc + 1) (id,c) csr mt
+and interp_match ist g lz constr lmr =
+  let rec apply_match_subterm ist nocc (id,c) csr mt =
+    let (lm,ctxt) = match_subterm nocc c csr in
+    let lctxt = give_context ctxt id in
+    let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
+    try eval_with_fail {ist with lfun=lm@lctxt@ist.lfun} lz g mt
+    with e when is_match_catchable e ->
+      apply_match_subterm ist (nocc + 1) (id,c) csr mt
   in
   let rec apply_match ist csr = function
     | (All t)::_ ->
-        (try val_interp ist g t
+        (try eval_with_fail ist lz 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)
+        (try let lm = 
+              (try matches c csr with 
+                e -> 
+                  (match ist.debug with
+                    DebugOn lev ->
+                      safe_msgnl (str "Level " ++ int lev ++
+                             str ": matching with pattern" ++ fnl() ++
+                         Printer.pr_constr_pattern_env (pf_env g) c ++ fnl() ++
+                         str "raised the exception" ++ fnl() ++
+                         !Tactic_debug.explain_logic_error_no_anomaly e)
+                  | _ -> ()); raise e) in
+            (try let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
+               eval_with_fail { ist with lfun=lm@ist.lfun } lz g mt
+            with e ->
+               (match ist.debug with
+                  DebugOn lev -> 
+                    safe_msgnl (str "rule body for pattern" ++ fnl() ++
+                    Printer.pr_constr_pattern_env (pf_env g) c ++ fnl() ++
+                    str "raised the exception" ++ fnl() ++
+                    !Tactic_debug.explain_logic_error_no_anomaly e)
+                | _ -> ()); raise e)
+         with e when is_match_catchable e ->
+            (match ist.debug with
+               DebugOn lev ->
+                 safe_msgnl (str "Level " ++ int lev ++ 
+                       str ":switching to the next rule");
+             | DebugOff -> ());
+            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)
+        (try apply_match_subterm ist 0 (id,c) csr mt
+         with PatternMatchingFailure -> 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
-  try
-    incr hack_fail_level_shift;
-    let x = apply_match ist csr ilr in
-    decr hack_fail_level_shift;
-    x
-  with e ->
-    decr hack_fail_level_shift;
-    raise e
+  let csr = 
+      try interp_ltac_constr ist g constr with
+        e -> (match ist.debug with
+               DebugOn lev ->
+               safe_msgnl (str "Level " ++ int lev ++ 
+                      str ": evaluation of the matched expression raised " ++
+                      str "the exception" ++ fnl() ++
+                      !Tactic_debug.explain_logic_error e)
+             | _ -> ()); raise e in
+  let ilr = read_match_rule (fst (constr_list ist (pf_env g))) lmr in
+  let res = 
+     try apply_match ist csr ilr with
+       e -> 
+           begin match ist.debug with
+             DebugOn lev ->
+                safe_msgnl (str "Level " ++ int lev ++ 
+                        str ": match expression failed with error" ++ fnl() ++
+                    !Tactic_debug.explain_logic_error e)
+           | _ -> ()
+           end;
+           raise e in
+     (if ist.debug <> DebugOff then
+     safe_msgnl (str "match expression returns " ++
+            pr_value (Some (pf_env g)) res));
+     res
+
+(* Interprets tactic expressions : returns a "constr" *)
+and interp_ltac_constr ist gl e =
+  let result = 
+  try (val_interp ist gl e) with Not_found -> 
+    begin match ist.debug with
+      DebugOn lev ->
+       safe_msgnl (str "Level " ++ int lev ++ 
+                   str ": evaluation failed for" ++ fnl() ++
+                       Pptactic.pr_glob_tactic (pf_env gl) e)
+    | _ -> ()
+    end;
+    raise Not_found in
+  try let cresult = constr_of_value (pf_env gl) result in
+    (if !debug <> DebugOff then 
+        safe_msgnl (Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++
+        str " has value " ++ fnl() ++ print_constr_env (pf_env gl) cresult);
+     cresult)
+        
+  with Not_found ->
+    errorlabstrm ""
+      (str "Must evaluate to a term" ++ fnl() ++ 
+	  str "offending expression: " ++ fnl() ++
+          Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ str "this is a " ++
+          (match result with
+              VTactic _ -> str "VTactic"
+            | VRTactic _ -> str "VRTactic"
+            | VFun (il,ul,b) ->
+                (str "VFun with body " ++ fnl() ++
+                    Pptactic.pr_glob_tactic (pf_env gl) b ++ fnl() ++
+		    str "instantiated arguments " ++ fnl() ++
+                    List.fold_right 
+                    (fun p s ->
+                      let (i,v) = p in str (string_of_id i) ++ str ", " ++ s)
+                    il (str "") ++
+                    str "uninstantiated arguments " ++ fnl() ++
+                    List.fold_right
+                    (fun opt_id s ->
+                      (match opt_id with
+                          Some id -> str (string_of_id id)
+                        | None -> str "_") ++ str ", " ++ s)
+                    ul (str ""))
+            | VVoid -> str "VVoid"
+            | VInteger _ -> str "VInteger"
+            | VConstr _ -> str "VConstr"
+            | VIntroPattern _ -> str "VIntroPattern"
+            | VConstr_context _ -> str "VConstrr_context"
+            | VRec _ -> str "VRec"
+            | VList _ -> str "VList"))
 
 (* 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")
+  with NotTactic ->
+    errorlabstrm "" (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)
+      h_intro_patterns (List.map (interp_intro_pattern ist gl) 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')
+      h_intro_move (option_map (interp_ident ist gl) ido)
+      (option_map (interp_hyp ist gl) ido')
   | TacAssumption -> h_assumption
   | TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
+  | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c)
+  | TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_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)
+                (option_map (interp_constr_with_bindings ist gl) cbo)
+  | TacElimType c -> h_elim_type (pf_interp_type 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
+  | TacCaseType c -> h_case_type (pf_interp_type ist gl c)
+  | TacFix (idopt,n) -> h_fix (option_map (interp_ident ist gl) 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)
+      let f (id,n,c) = (interp_ident ist gl id,n,pf_interp_type ist gl c) in
+      h_mutual_fix (interp_ident ist gl id) n (List.map f l)
+  | TacCofix idopt -> h_cofix (option_map (interp_ident ist gl) 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)
+      let f (id,c) = (interp_ident ist gl id,pf_interp_type ist gl c) in
+      h_mutual_cofix (interp_ident ist gl id) (List.map f l)
+  | TacCut c -> h_cut (pf_interp_type ist gl c)
+  | TacAssert (t,ipat,c) ->
+      let c = (if t=None then pf_interp_constr else pf_interp_type) ist gl c in
+      abstract_tactic (TacAssert (t,ipat,c))
+        (Tactics.forward (option_map (interp_tactic ist) t)
+	  (interp_intro_pattern ist gl ipat) c)
+  | TacGeneralize cl -> h_generalize (pf_interp_constr_list 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)
-
+      h_let_tac (interp_name ist gl na) (pf_interp_constr ist gl c) clp
+(* | TacInstantiate (n,c,idh) -> h_instantiate n (fst c) 
+      (* pf_interp_constr ist gl c *)
+      (match idh with
+	   ConclLocation () -> ConclLocation ()
+	 | HypLocation (id,hloc) -> 
+	     HypLocation(interp_hyp ist gl id,hloc))
+*)
   (* Automation tactics *)
-  | TacTrivial l -> Auto.h_trivial l
-  | TacAuto (n, l) -> Auto.h_auto (option_app (interp_int_or_var ist) n) l
+  | TacTrivial (lems,l) -> 
+      Auto.h_trivial (pf_interp_constr_list ist gl lems)
+	(option_map (List.map (interp_hint_base ist)) l)
+  | TacAuto (n,lems,l) ->
+      Auto.h_auto (option_map (interp_int_or_var ist) n)
+      (pf_interp_constr_list ist gl lems)
+      (option_map (List.map (interp_hint_base ist)) 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 (option_app (interp_int_or_var ist) n,p)
+  | TacDAuto (n,p) -> Auto.h_dauto (option_map (interp_int_or_var ist) 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')
+  | TacSimpleInduction h ->
+      h_simple_induction (interp_quantified_hypothesis ist h)
+  | TacNewInduction (lc,cbo,ids) ->
+      h_new_induction (List.map (interp_induction_arg ist gl) lc)
+        (option_map (interp_constr_with_bindings ist gl) cbo)
+        (interp_intro_pattern ist gl 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')
+  | TacNewDestruct (c,cbo,ids) -> 
+      h_new_destruct (List.map (interp_induction_arg ist gl) c)
+        (option_map (interp_constr_with_bindings ist gl) cbo)
+        (interp_intro_pattern ist gl ids)
   | TacDoubleInduction (h1,h2) ->
       let h1 = interp_quantified_hypothesis ist h1 in
       let h2 = interp_quantified_hypothesis ist h2 in
@@ -1778,12 +2068,12 @@ and interp_atomic ist gl = function
   | 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)
+  | TacClear (b,l) -> h_clear b (interp_hyp_list ist gl l)
+  | TacClearBody l -> h_clear_body (interp_hyp_list 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))
+      h_rename (interp_hyp ist gl id1) (interp_ident ist gl (snd id2))
 
   (* Constructors *)
   | TacLeft bl -> h_left (interp_bindings ist gl bl)
@@ -1791,16 +2081,18 @@ and interp_atomic ist gl = function
   | TacSplit (_,bl) -> h_split (interp_bindings ist gl bl)
   | TacAnyConstructor t ->
       abstract_tactic (TacAnyConstructor t)
-        (Tactics.any_constructor (option_app (interp_tactic ist) t))
+        (Tactics.any_constructor (option_map (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)
+      h_reduce (pf_interp_red_expr 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)
+      h_change (option_map (pf_interp_pattern ist gl) occl)
+        (if occl = None then pf_interp_type ist gl c 
+	 else pf_interp_constr ist gl c)
+        (interp_clause ist gl cl)
 
   (* Equivalence relations *)
   | TacReflexivity -> h_reflexivity
@@ -1808,57 +2100,102 @@ and interp_atomic ist gl = function
   | TacTransitivity c -> h_transitivity (pf_interp_constr ist gl c)
 
   (* Equality and inversion *)
+  | TacRewrite (b,c,cl) -> 
+      Equality.general_multi_rewrite b 
+	(interp_constr_with_bindings ist gl c) 
+	(interp_clause ist gl cl)
   | TacInversion (DepInversion (k,c,ids),hyp) ->
-      Inv.dinv k (option_app (pf_interp_constr ist gl) c)
-        (option_app (interp_intro_pattern ist) ids)
+      Inv.dinv k (option_map (pf_interp_constr ist gl) c)
+        (interp_intro_pattern ist gl 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_intro_pattern ist gl ids)
+        (interp_hyp_list 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)
+        (interp_hyp_list ist gl idl)
 
   (* For extensions *)
   | TacExtend (loc,opn,l) ->
-      fun gl -> vernac_tactic (opn,List.map (interp_genarg ist gl) l) gl
+      let tac = lookup_tactic opn in
+      fun gl ->
+        let args = List.map (interp_genarg ist gl) l in
+        abstract_extended_tactic opn args (tac args) 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))
+    | IntArgType -> 
+        VInteger (out_gen globwit_int x)
+    | IntOrVarArgType ->
+        mk_int_or_var_value ist (out_gen globwit_int_or_var x)
     | PreIdentArgType ->
 	failwith "pre-identifiers cannot be bound"
     | IntroPatternArgType ->
-	VIntroPattern (out_gen globwit_intro_pattern x)
+	VIntroPattern 
+	  (interp_intro_pattern ist gl (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)))
+        VIntroPattern 
+	  (IntroIdentifier (interp_ident ist gl (out_gen globwit_ident x)))
+    | VarArgType ->
+        mk_hyp_value ist gl (out_gen globwit_var x)
     | RefArgType -> 
-        VConstr (constr_of_reference 
+        VConstr (constr_of_global 
           (pf_interp_reference ist gl (out_gen globwit_ref x)))
-    | SortArgType ->
-	VConstr (mkSort (Pretyping.interp_sort (out_gen globwit_sort x)))
+    | SortArgType -> 
+        VConstr (mkSort (interp_sort (out_gen globwit_sort x)))
     | ConstrArgType ->
-        VConstr (pf_interp_constr ist gl (out_gen globwit_constr x))
+        mk_constr_value 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)
+    | ExtraArgType s when tactic_genarg_level s <> None ->
+          (* Special treatment of tactic arguments *)
+	val_interp ist gl 
+          (out_gen (globwit_tactic (out_some (tactic_genarg_level s))) x)
+    | List0ArgType ConstrArgType -> 
+        let wit = wit_list0 globwit_constr in
+        VList (List.map (mk_constr_value ist gl) (out_gen wit x))
+    | List0ArgType VarArgType -> 
+        let wit = wit_list0 globwit_var in
+        VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
+    | List0ArgType IntArgType -> 
+        let wit = wit_list0 globwit_int in
+        VList (List.map (fun x -> VInteger x) (out_gen wit x))
+    | List0ArgType IntOrVarArgType -> 
+        let wit = wit_list0 globwit_int_or_var in
+        VList (List.map (mk_int_or_var_value ist) (out_gen wit x))
+    | List1ArgType ConstrArgType -> 
+        let wit = wit_list1 globwit_constr in
+        VList (List.map (mk_constr_value ist gl) (out_gen wit x))
+    | List1ArgType VarArgType -> 
+        let wit = wit_list1 globwit_var in
+        VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
+    | List1ArgType IntArgType -> 
+        let wit = wit_list1 globwit_int in
+        VList (List.map (fun x -> VInteger x) (out_gen wit x))
+    | List1ArgType IntOrVarArgType -> 
+        let wit = wit_list1 globwit_int_or_var in
+        VList (List.map (mk_int_or_var_value ist) (out_gen wit x))
     | StringArgType | BoolArgType
-    | QuantHypArgType | RedExprArgType | OpenConstrArgType
-    | CastedOpenConstrArgType | ConstrWithBindingsArgType | BindingsArgType 
-    | ExtraArgType _ | List0ArgType _ | List1ArgType _ | OptArgType _ | PairArgType _ 
+    | QuantHypArgType | RedExprArgType 
+    | OpenConstrArgType _ | ConstrWithBindingsArgType 
+    | ExtraArgType _ | BindingsArgType 
+    | OptArgType _ | PairArgType _ 
+    | List0ArgType _ | List1ArgType _ 
 	-> 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
+    in 
+    try tactic_of_value v gl 
+    with NotTactic -> user_err_loc (loc,"",str "not a tactic")
+
+let make_empty_glob_sign () =
+  { ltacvars = ([],[]); ltacrecvars = []; 
+    gsigma = Evd.empty; genv = Global.env() }
 
 (* Initial call for interpretation *)
 let interp_tac_gen lfun debug t gl = 
@@ -1867,10 +2204,14 @@ let interp_tac_gen lfun debug t gl =
       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 eval_tactic t gls = interp_tactic { lfun=[]; debug=get_debug() } t gls
 
 let interp t = interp_tac_gen [] (get_debug()) t
 
+let eval_ltac_constr gl t =
+  interp_ltac_constr { lfun=[]; debug=get_debug() } gl
+    (intern_tactic (make_empty_glob_sign ()) t )
+
 (* Hides interpretation for pretty-print *)
 let hide_interp t ot gl =
   let ist = { ltacvars = ([],[]); ltacrecvars = []; 
@@ -1879,7 +2220,8 @@ let hide_interp t ot gl =
   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
+  | Some t' ->
+      abstract_tactic_expr ~dflt:true (TacArg (Tacexp te)) (tclTHEN t t') gl
 
 (***************************************************************************)
 (* Substitution at module closing time *)
@@ -1888,11 +2230,11 @@ 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) =
+let subst_rawconstr_and_expr subst (c,e) =
   assert (e=None); (* e<>None only for toplevel tactics *)
-  (subst_raw subst c,None)
+  (Detyping.subst_rawconstr subst c,None)
+
+let subst_rawconstr = subst_rawconstr_and_expr (* shortening *)
 
 let subst_binding subst (loc,b,c) =
   (loc,subst_quantified_hypothesis subst b,subst_rawconstr subst c)
@@ -1910,28 +2252,36 @@ let subst_induction_arg subst = function
   | 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 *)
+(*  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)
+  | ArgArg x -> ArgArg (f x)
 
-let subst_located f (_loc,id) = (loc,f id)
+let subst_located f (_loc,id) = (dloc,f id)
 
 let subst_reference subst = 
   subst_or_var (subst_located (subst_kn subst))
 
+(*CSC: subst_global_reference is used "only" for RefArgType, that propagates
+  to the syntactic non-terminals "global", used in commands such as
+  Print. It is also used for non-evaluable references. *) 
 let subst_global_reference subst = 
-  subst_or_var (subst_located (subst_global subst))
+ let subst_global ref =
+  let ref',t' = subst_global subst ref in
+   if not (eq_constr (constr_of_global ref') t') then
+    ppnl (str "Warning: the reference " ++ pr_global ref ++ str " is not " ++
+          str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
+          pr_global ref') ;
+   ref'
+ in
+  subst_or_var (subst_located subst_global)
 
 let subst_evaluable subst =
-  subst_or_var (subst_and_short_name (subst_evaluable_reference subst))
+  let subst_eval_ref = subst_evaluable_reference subst in
+    subst_or_var (subst_and_short_name subst_eval_ref)
 
 let subst_unfold subst (l,e) = 
   (l,subst_evaluable subst e)
@@ -1947,8 +2297,8 @@ let subst_redexp subst = function
   | 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 | ExtraRedExpr _ as r) -> r
+  | Simpl o -> Simpl (option_map (subst_constr_occurrence subst) o)
+  | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r
 
 let subst_raw_may_eval subst = function
   | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_rawconstr subst c)
@@ -1971,10 +2321,12 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x
   | TacAssumption as x -> x
   | TacExact c -> TacExact (subst_rawconstr subst c)
+  | TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c)
+  | TacVmCastNoCheck c -> TacVmCastNoCheck (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)
+               option_map (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)
@@ -1985,16 +2337,15 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | 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)
+  | TacAssert (b,na,c) -> TacAssert (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)
-
+(*| TacInstantiate (n,c,ido) -> TacInstantiate (n,subst_rawconstr subst c,ido)
+*)
   (* Automation tactics *)
-  | TacTrivial l -> TacTrivial l
-  | TacAuto (n,l) -> TacAuto (n,l)
+  | TacTrivial (lems,l) -> TacTrivial (List.map (subst_rawconstr subst) lems,l)
+  | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_rawconstr subst) lems,l)
   | TacAutoTDB n -> TacAutoTDB n
   | TacDestructHyp (b,id) -> TacDestructHyp(b,id)
   | TacDestructConcl -> TacDestructConcl
@@ -2003,13 +2354,13 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
 
   (* 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)
+  | TacNewInduction (lc,cbo,ids) -> (* Pierre C. est-ce correct? *)
+      TacNewInduction (List.map (subst_induction_arg subst) lc,
+               option_map (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)
+      TacNewDestruct (List.map (subst_induction_arg subst) c,  (* Julien F. est-ce correct? *)
+               option_map (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)
@@ -2020,7 +2371,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | TacLApply c -> TacLApply (subst_rawconstr subst c)
 
   (* Context management *)
-  | TacClear l as x -> x
+  | TacClear _ as x -> x
   | TacClearBody l as x -> x
   | TacMove (dep,id1,id2) as x -> x
   | TacRename (id1,id2) as x -> x
@@ -2029,13 +2380,13 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | 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)
+  | TacAnyConstructor t -> TacAnyConstructor (option_map (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,
+      TacChange (option_map (subst_constr_occurrence subst) occl,
         subst_rawconstr subst c, cl)
 
   (* Equivalence relations *)
@@ -2043,32 +2394,33 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | TacTransitivity c -> TacTransitivity (subst_rawconstr subst c)
 
   (* Equality and inversion *)
+  | TacRewrite (b,c,cl) -> TacRewrite (b, subst_raw_with_bindings subst c,cl)
   | TacInversion (DepInversion (k,c,l),hyp) ->
-     TacInversion (DepInversion (k,option_app (subst_rawconstr subst) c,l),hyp)
+     TacInversion (DepInversion (k,option_map (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)
+      TacExtend (dloc,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,
+      TacAlias (dloc,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)
+  | TacAtom (_loc,t) -> TacAtom (dloc, 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
+      let l = List.map (fun (n,c,b) -> (n,option_map (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)
+  | TacMatchContext (lz,lr,lmr) ->
+      TacMatchContext(lz,lr, subst_match_rule subst lmr)
+  | TacMatch (lz,c,lmr) ->
+      TacMatch (lz,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)
@@ -2084,6 +2436,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with
       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)
+  | TacComplete tac -> TacComplete (subst_tactic subst tac)
   | TacArg a -> TacArg (subst_tacarg subst a)
 
 and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
@@ -2094,12 +2447,16 @@ and subst_tacarg subst = function
   | MetaIdArg (_loc,_) -> assert false
   | TacCall (_loc,f,l) ->
       TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
+  | TacExternal (_loc,com,req,la) -> 
+      TacExternal (_loc,com,req,List.map (subst_tacarg subst) la)
   | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x
   | Tacexp t -> Tacexp (subst_tactic subst t)
-  | TacDynamic(_,t) as x ->
+  | TacDynamic(the_loc,t) as x ->
       (match tag t with
-	| "tactic" | "value" | "constr" -> x
-	| s -> anomaly_loc (loc, "Tacinterp.val_interp",
+	| "tactic" | "value" -> x
+        | "constr" -> 
+          TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t)))
+	| s -> anomaly_loc (dloc, "Tacinterp.val_interp",
                  str "Unknown dynamic: <" ++ str s ++ str ">"))
 
 (* Reads the rules of a Match Context or a Match *)
@@ -2123,7 +2480,7 @@ and subst_genarg subst (x:glob_generic_argument) =
   | 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)
+  | VarArgType -> in_gen globwit_var (out_gen globwit_var x)
   | RefArgType ->
       in_gen globwit_ref (subst_global_reference subst 
 	(out_gen globwit_ref x))
@@ -2139,14 +2496,9 @@ and subst_genarg subst (x:glob_generic_argument) =
           (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))
-  | OpenConstrArgType ->
-      in_gen globwit_open_constr 
-        ((),subst_rawconstr subst (snd (out_gen globwit_open_constr x)))
-  | CastedOpenConstrArgType ->
-      in_gen globwit_casted_open_constr 
-        ((),subst_rawconstr subst (snd (out_gen globwit_casted_open_constr x)))
+  | OpenConstrArgType b ->
+      in_gen (globwit_open_constr_gen b)
+        ((),subst_rawconstr subst (snd (out_gen (globwit_open_constr_gen b) x)))
   | ConstrWithBindingsArgType ->
       in_gen globwit_constr_with_bindings
         (subst_raw_with_bindings subst (out_gen globwit_constr_with_bindings x))
@@ -2157,7 +2509,14 @@ and subst_genarg subst (x:glob_generic_argument) =
   | 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
+  | ExtraArgType s ->
+      match tactic_genarg_level s with
+      | Some n -> 
+          (* Special treatment of tactic arguments *)
+          in_gen (globwit_tactic n)
+            (subst_tactic subst (out_gen (globwit_tactic n) x))
+      | None -> 
+          lookup_genarg_subst s subst x
 
 (***************************************************************************)
 (* Tactic registration *)
@@ -2201,6 +2560,17 @@ let (inMD,outMD) =
      classify_function = (fun (_,o) -> Substitute o);       
      export_function = (fun x -> Some x)}
 
+let print_ltac id =
+ try
+  let kn = Nametab.locate_tactic id in
+  let t = lookup kn in
+   str "Ltac" ++ spc() ++ pr_qualid id ++ str ":=" ++ spc() ++
+    Pptactic.pr_glob_tactic (Global.env ()) t
+ with
+  Not_found ->
+   errorlabstrm "print_ltac"
+    (pr_qualid id ++ spc() ++ str "is not a user defined tactic")
+
 (* Adds a definition for tactics in the table *)
 let make_absolute_name (loc,id) =
   let kn = Lib.make_kn id in
@@ -2209,10 +2579,6 @@ let make_absolute_name (loc,id) =
       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
@@ -2234,14 +2600,15 @@ let add_tacdef isrec tacl =
 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 }
+  Options.with_option strict_check
+  (intern_tactic
+    { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env })
     x
 
-let interp_redexp env evc r = 
+let interp_redexp env sigma 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)
+  let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in
+  interp_red_expr ist sigma env (intern_red_expr gist r)
 
 (***************************************************************************)
 (* Backwarding recursive needs of tactic glob/interp/eval functions *)
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 1f75b5a4..01e7750a 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -6,11 +6,12 @@
 (*         *       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 $Id: tacinterp.mli 9178 2006-09-26 11:18:22Z barras $ i*)
 
 (*i*)
 open Dyn
 open Pp
+open Util
 open Names
 open Proof_type
 open Tacmach
@@ -19,6 +20,8 @@ open Term
 open Tacexpr
 open Genarg
 open Topconstr
+open Mod_subst
+open Redexpr
 (*i*)
 
 (* Values for interpretation *)
@@ -31,6 +34,7 @@ type value =
   | VIntroPattern of intro_pattern_expr
   | VConstr of constr
   | VConstr_context of constr
+  | VList of value list
   | VRec of value ref
 
 (* Signature for interpretation: val\_interp and interpretation functions *)
@@ -38,12 +42,6 @@ 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
 
@@ -66,6 +64,14 @@ val add_tacdef :
   bool -> (identifier Util.located * raw_tactic_expr) list -> unit
 val add_primitive_tactic : string -> glob_tactic_expr -> unit
 
+(* Tactic extensions *)
+val add_tactic :
+  string -> (closed_generic_argument list -> tactic) -> unit
+val overwriting_add_tactic :
+  string -> (closed_generic_argument list -> tactic) -> unit
+val lookup_tactic :
+  string -> (closed_generic_argument list) -> tactic
+
 (* Adds an interpretation function for extra generic arguments *)
 type glob_sign = {
   ltacvars : identifier list * identifier list;
@@ -78,7 +84,7 @@ val add_interp_genarg :
     (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)
+    (substitution -> glob_generic_argument -> glob_generic_argument)
     -> unit
 
 val interp_genarg :
@@ -87,20 +93,37 @@ val interp_genarg :
 val intern_genarg :
   glob_sign -> raw_generic_argument -> glob_generic_argument
 
+val intern_tactic : 
+  glob_sign -> raw_tactic_expr -> glob_tactic_expr
+
+val intern_constr :
+  glob_sign -> constr_expr -> rawconstr_and_expr
+
+val intern_hyp :
+  glob_sign -> identifier Util.located -> identifier Util.located
+
 val subst_genarg :
-  Names.substitution -> glob_generic_argument -> glob_generic_argument
+  substitution -> glob_generic_argument -> glob_generic_argument
+
+val subst_rawconstr_and_expr :
+  substitution -> rawconstr_and_expr -> rawconstr_and_expr
 
 (* Interprets any expression *)
 val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
 
+(* Interprets an expression that evaluates to a constr *)
+val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> 
+  constr
+
 (* Interprets redexp arguments *)
-val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr
-  -> Tacred.red_expr
+val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr
 
 (* Interprets tactic expressions *)
 val interp_tac_gen : (identifier * value) list -> 
                  debug_info -> raw_tactic_expr -> tactic
 
+val interp_hyp :  interp_sign -> goal sigma -> identifier located -> identifier
+
 (* Initial call for interpretation *)
 val glob_tactic : raw_tactic_expr -> glob_tactic_expr
 
@@ -110,17 +133,20 @@ val eval_tactic : glob_tactic_expr -> tactic
 
 val interp : raw_tactic_expr -> tactic
 
+val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr
+
 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
+(* Declare the default tactic to fill implicit arguments *)
+val declare_implicit_tactic : tactic -> unit
 
+(* Declare the xml printer *)
+val declare_xml_printer : 
+  (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit
 
+(* printing *)
+val print_ltac : Libnames.qualid -> std_ppcmds
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index 77898afb..06289169 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacticals.ml,v 1.60.2.1 2004/07/16 19:30:55 herbelin Exp $ *)
+(* $Id: tacticals.ml 9211 2006-10-05 12:38:33Z letouzey $ *)
 
 open Pp
 open Util
@@ -22,6 +22,7 @@ open Libnames
 open Refiner
 open Tacmach
 open Clenv
+open Clenvtac
 open Pattern
 open Matching
 open Evar_refiner
@@ -67,6 +68,7 @@ let tclTHENTRY       = tclTHENTRY
 let tclIFTHENELSE    = tclIFTHENELSE
 let tclIFTHENSELSE   = tclIFTHENSELSE
 let tclIFTHENSVELSE   = tclIFTHENSVELSE
+let tclIFTHENTRYELSEMUST = tclIFTHENTRYELSEMUST
 
 let unTAC            = unTAC
 
@@ -90,7 +92,7 @@ let tclLAST_HYP = tclNTH_HYP 1
 
 let tclTRY_sign (tac : constr->tactic) sign gl =
   let rec arec = function
-    | []      -> tclFAIL 0 "no applicable hypothesis"
+    | []      -> tclFAIL 0 (str "no applicable hypothesis")
     | [s]     -> tac (mkVar s) (*added in order to get useful error messages *)
     | (s::sl) -> tclORELSE (tac (mkVar s)) (arec sl) 
   in 
@@ -118,15 +120,13 @@ 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 onHyp id = { onhyps=Some[(([],id),InHyp)]; 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)
+        None -> List.map (fun id -> Some(([],id),InHyp)) (pf_ids_of_hyps gls)
       | Some l -> List.map (fun h -> Some h) l in
   if cl.onconcl then None::hyps else hyps
 
@@ -134,7 +134,7 @@ let simple_clause_list_of cl gls =
 (* OR-branch *)
 let tryClauses tac cl gls = 
   let rec firstrec = function
-    | []      -> tclFAIL 0 "no applicable hypothesis"
+    | []      -> tclFAIL 0 (str "no applicable hypothesis")
     | [cls]   -> tac cls (* added in order to get a useful error message *)
     | cls::tl -> (tclORELSE (tac cls) (firstrec tl))
   in
@@ -168,13 +168,12 @@ let nth_clause n gl =
 let clause_type cls gl =
   match simple_clause_of cls with
     | None    -> pf_concl gl
-    | Some (id,_,_) -> pf_get_hyp_typ gl id
+    | 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
+  is_matching_conv (pf_env gls) (project gls) pat n
 
 let pf_matches gls pat n =
   matches_conv (pf_env gls) (project gls) pat n
@@ -219,7 +218,7 @@ 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
+  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
 
@@ -268,9 +267,9 @@ type branch_assumptions = {
   assums    : named_context}   (* the list of assumptions introduced *)
 
 let compute_induction_names n = function
-  | None ->
+  | IntroAnonymous ->
       Array.make n []
-  | Some (IntroOrAndPattern names) when List.length names = n ->
+  | IntroOrAndPattern names when List.length names = n ->
       Array.of_list names
   | _ ->
       errorlabstrm "" (str "Expects " ++ int n ++ str " lists of names")
@@ -288,7 +287,7 @@ let compute_construtor_signatures isrec (_,k as ity) =
     | _ -> anomaly "compute_construtor_signatures"
   in 
   let (mib,mip) = Global.lookup_inductive ity in
-  let n = mip.mind_nparams in
+  let n = mib.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
@@ -324,23 +323,22 @@ 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  = mk_clenv_from gl (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 elimclause = mk_clenv_from gl (elim,pf_type_of gl elim) in
   let indmv = 
-    match kind_of_term (last_arg (clenv_template elimclause).rebus) with
+    match kind_of_term (last_arg elimclause.templval.Evd.rebus) with
       | Meta mv -> mv
       | _         -> error "elimination"
   in
   let pmv =
-    let p, _ = decompose_app (clenv_template_type elimclause).rebus in
+    let p, _ = decompose_app elimclause.templtyp.Evd.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
+	      | Const kn -> string_of_con kn
 	      | Var id -> string_of_id id
 	      | _ -> "\b"
 	  in
@@ -351,7 +349,7 @@ let general_elim_then_using
   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 (hd,largs) = decompose_app ce.templtyp.Evd.rebus in
     let ba = { branchsign = branchsigns.(i);
                branchnames = brnames.(i);
                nassums = 
@@ -360,8 +358,8 @@ let general_elim_then_using
                    0 branchsigns.(i);
                branchnum = i+1;
                ity = ity;
-               largs = List.map (clenv_instance_term ce) largs;
-               pred = clenv_instance_term ce hd }
+               largs = List.map (clenv_nf_meta ce) largs;
+               pred = clenv_nf_meta ce hd }
     in 
     tac ba gl
   in
@@ -369,9 +367,10 @@ let general_elim_then_using
   let elimclause' =
     match predicate with
        | None   -> elimclause'
-       | Some p -> clenv_assign pmv p elimclause'
+       | Some p ->
+           clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause'
   in 
-  elim_res_pf_THEN_i kONT elimclause' branchtacs gl
+  elim_res_pf_THEN_i elimclause' branchtacs gl
 
 
 let elimination_then_using tac predicate (indbindings,elimbindings) c gl = 
@@ -379,7 +378,7 @@ let elimination_then_using tac predicate (indbindings,elimbindings) c gl =
   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
+    elim true IntroAnonymous tac predicate (indbindings,elimbindings) c gl
 
 
 let elimination_then tac        = elimination_then_using tac None 
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 111a5e2d..458ab732 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -6,9 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tacticals.mli,v 1.38.2.2 2005/01/21 16:41:52 herbelin Exp $ i*)
+(*i $Id: tacticals.mli 9211 2006-10-05 12:38:33Z letouzey $ i*)
 
 (*i*)
+open Pp
 open Names
 open Term
 open Sign
@@ -24,7 +25,7 @@ open Tacexpr
 (* Tacticals i.e. functions from tactics to tactics. *)
 
 val tclIDTAC         : tactic
-val tclIDTAC_MESSAGE : string -> tactic
+val tclIDTAC_MESSAGE : std_ppcmds -> tactic
 val tclORELSE        : tactic -> tactic -> tactic
 val tclTHEN          : tactic -> tactic -> tactic
 val tclTHENSEQ       : tactic list -> tactic
@@ -46,7 +47,7 @@ val tclTRY           : tactic -> tactic
 val tclINFO          : tactic -> tactic
 val tclCOMPLETE      : tactic -> tactic
 val tclAT_LEAST_ONCE : tactic -> tactic
-val tclFAIL          : int -> string -> tactic
+val tclFAIL          : int -> std_ppcmds -> tactic
 val tclDO            : int -> tactic -> tactic
 val tclPROGRESS      : tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
@@ -63,7 +64,7 @@ val tclIFTHENELSE    : tactic -> tactic -> tactic -> tactic
 val tclIFTHENSELSE   : tactic -> tactic list -> tactic -> tactic
 val tclIFTHENSVELSE  : tactic -> tactic array -> tactic -> tactic
 
-
+val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
 
 val unTAC            : tactic -> goal sigma -> proof_tree sigma
 
@@ -129,13 +130,13 @@ type branch_assumptions = {
 
 (* Useful for [as intro_pattern] modifier *)
 val compute_induction_names : 
-  int -> intro_pattern_expr option -> intro_pattern_expr list array
+  int -> intro_pattern_expr -> 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 ->
+  constr -> (* isrec: *) bool -> intro_pattern_expr ->
     (branch_args -> tactic) -> constr option -> 
       (arg_bindings * arg_bindings) -> constr -> tactic
 	  
@@ -148,11 +149,11 @@ val elimination_then :
     (arg_bindings * arg_bindings) -> constr -> tactic
 
 val case_then_using :
-  intro_pattern_expr option -> (branch_args -> tactic) -> 
+  intro_pattern_expr -> (branch_args -> tactic) -> 
     constr option -> (arg_bindings * arg_bindings) -> constr -> tactic
 
 val case_nodep_then_using :
-  intro_pattern_expr option -> (branch_args -> tactic) -> 
+  intro_pattern_expr -> (branch_args -> tactic) -> 
     constr option -> (arg_bindings * arg_bindings) -> constr -> tactic
 
 val simple_elimination_then :
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 2ba09e52..cb98ec18 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tactics.ml,v 1.162.2.7 2005/07/13 16:18:57 herbelin Exp $ *)
+(* $Id: tactics.ml 9605 2007-02-07 12:19:19Z notin $ *)
 
 open Pp
 open Util
@@ -31,6 +31,7 @@ open Proof_type
 open Logic
 open Evar_refiner
 open Clenv
+open Clenvtac
 open Refiner
 open Tacticals
 open Hipattern
@@ -39,6 +40,8 @@ open Nametab
 open Genarg
 open Tacexpr
 open Decl_kinds
+open Evarutil
+open Indrec
 
 exception Bound
 
@@ -47,7 +50,7 @@ let rec nb_prod x =
     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
+      | Cast(c,_,_) -> count n c
       | _ -> n
   in count 0 x
 
@@ -141,28 +144,24 @@ type tactic_reduction = env -> evar_map -> constr -> constr
    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_concl (redfun,sty) gl = 
+  convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl
 
-let reduct_in_hyp redfun (id,_,(where,where')) gl =
+let reduct_in_hyp redfun ((_,id),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 
+  | Some id -> reduct_in_hyp (fst redfun) id 
   | None    -> reduct_in_concl redfun 
 
 (* The following tactic determines whether the reduction
@@ -182,10 +181,13 @@ let change_and_check cv_pb t env sigma c =
 (* 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) 
+  | Some occl -> contextually false occl (change_and_check Reduction.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_in_concl occl t =
+  reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast)
+
+let change_in_hyp occl t   =
+  reduct_in_hyp (change_on_subterm Reduction.CONV t occl)
 
 let change_option occl t = function
     Some id -> change_in_hyp occl t id
@@ -200,22 +202,23 @@ let change occl c cls =
   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_concl        = reduct_in_concl (red_product,DEFAULTcast)
 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 red_option          = reduct_option   (red_product,DEFAULTcast)
+let hnf_in_concl        = reduct_in_concl (hnf_constr,DEFAULTcast)
 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 hnf_option          = reduct_option   (hnf_constr,DEFAULTcast)
+let simpl_in_concl      = reduct_in_concl (nf,DEFAULTcast)
 let simpl_in_hyp        = reduct_in_hyp   nf
-let simpl_option        = reduct_option   nf
-let normalise_in_concl  = reduct_in_concl compute
+let simpl_option        = reduct_option   (nf,DEFAULTcast)
+let normalise_in_concl  = reduct_in_concl (compute,DEFAULTcast)
 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)
+let normalise_option    = reduct_option   (compute,DEFAULTcast)
+let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast)
+let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,DEFAULTcast)
+let unfold_in_hyp   loccname = reduct_in_hyp   (unfoldn loccname) 
+let unfold_option   loccname = reduct_option (unfoldn loccname,DEFAULTcast) 
+let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast)
 
 (* A function which reduces accordingly to a reduction expression,
    as the command Eval does. *)
@@ -228,7 +231,7 @@ let needs_check = function
 
 let reduce redexp cl goal =
   (if needs_check redexp then with_check else (fun x -> x))
-    (redin_combinator (reduction_of_redexp redexp) cl)
+    (redin_combinator (Redexpr.reduction_of_red_expr redexp) cl)
     goal
 
 (* Unfolding occurrences of a constant *)
@@ -242,20 +245,22 @@ let unfold_constr = function
 (*         Introduction tactics            *)
 (*******************************************)
 
+let fresh_id_avoid avoid id =
+  next_global_ident_away true id avoid
+
 let fresh_id avoid id gl =
-  next_global_ident_away true id (avoid@(pf_ids_of_hyps gl))
+  fresh_id_avoid (avoid@(pf_ids_of_hyps gl)) id
 
 let id_of_name_with_default s = function
   | Anonymous -> id_of_string s
   | Name id   -> id
 
-let default_id gl = function
+let default_id env sigma = 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
+      (match Typing.sort_of env sigma t with
+	| Prop _ -> (id_of_name_with_default "H" name)
+	| Type _ -> (id_of_name_with_default "X" name))
+  | (name,Some b,_) -> id_of_name_using_hdchar env b name
 
 (* Non primitive introduction tactics are treated by central_intro
    There is possibly renaming, with possibly names to avoid and 
@@ -267,14 +272,32 @@ type intro_name_flag =
   | IntroMustBe of identifier
 
 let find_name decl gl = function
-  | IntroAvoid idl        -> 
-      let id = fresh_id idl (default_id gl decl) gl in id
+  | IntroAvoid idl -> 
+      (* this case must be compatible with [find_intro_names] below. *)
+      let id = fresh_id idl (default_id (pf_env gl) gl.sigma 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'
 
+(* Returns the names that would be created by intros, without doing
+   intros.  This function is supposed to be compatible with an
+   iteration of [find_name] above. As [default_id] checks the sort of
+   the type to build hyp names, we maintain an environment to be able
+   to type dependent hyps. *)
+let find_intro_names ctxt gl = 
+  let _, res = List.fold_right 
+    (fun decl acc -> 
+      let wantedname,x,typdecl = decl in
+      let env,idl = acc in
+      let name = fresh_id idl (default_id env gl.sigma decl) gl in
+      let newenv = push_rel (wantedname,x,typdecl) env in
+      (newenv,(name::idl)))
+    ctxt (pf_env gl , []) in
+  List.rev res 
+
+
 let build_intro_tac id = function
   | None      -> introduction id
   | Some dest -> tclTHEN (introduction id) (move_hyp true id dest)
@@ -300,6 +323,8 @@ let intro_force force_flag = intro_gen (IntroAvoid []) None force_flag
 let intro = intro_force false
 let introf = intro_force true
 
+let intro_avoiding l = intro_gen (IntroAvoid l) None false 
+
 let introf_move_name destopt = intro_gen (IntroAvoid []) destopt true
 
 (* For backwards compatibility *)
@@ -313,7 +338,7 @@ let rec intros_using = function
 
 let intros = tclREPEAT (intro_force false)
 
-let intro_erasing id = tclTHEN (thin [id]) (intro_using id)
+let intro_erasing id = tclTHEN (thin [id]) (introduction id)
 
 let intros_replacing ids gls = 
   let rec introrec = function
@@ -341,7 +366,9 @@ let pf_lookup_hypothesis_as_renamed_gen red h gl =
   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)
+          aux 
+	    ((fst (Redexpr.reduction_of_red_expr (Red true))) 
+	       env (project gl) ccl)
       | x -> x
   in
   try aux (pf_concl gl)
@@ -420,15 +447,12 @@ let rec intros_rmove = function
  		    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. *)
+(**************************)
+(*  Refinement tactics    *)
+(**************************)
 
 let apply_type hdcty argl gl =
-  refine (applist (mkCast (mkMeta (new_meta()),hdcty),argl)) gl
+  refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl
     
 let apply_term hdc argl gl =
   refine (applist (hdc,argl)) gl
@@ -438,39 +462,75 @@ let bring_hyps hyps =
   else
     (fun gl ->
       let newcl = List.fold_right mkNamedProd_or_LetIn hyps (pf_concl gl) in
-      let f = mkCast (mkMeta (new_meta()),newcl) in
+      let f = mkCast (Evarutil.mk_new_meta(),DEFAULTcast, newcl) in
       refine_no_check (mkApp (f, instance_from_named_context hyps)) gl)
 
+(**************************)
+(*     Cut tactics        *)
+(**************************)
+
+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 tac = 
+  tclTHENS (cut t)
+    [tclORELSE
+	(intro_replacing id) 
+	(tclORELSE (intro_erasing id) (intro_using id));
+     tac (refine_no_check (mkVar id)) ] *)
+
+(* cut_replacing échoue si l'hypothèse à remplacer apparaît dans le
+   but, ou dans une autre hypothèse *)
+let cut_replacing id t tac = 
+  tclTHENS (cut t) [
+      tclORELSE (intro_replacing id) (intro_erasing id); 
+      tac (refine_no_check (mkVar id)) ]
+
+let cut_in_parallel l = 
+  let rec prec = function
+    | [] -> tclIDTAC 
+    | h::t -> tclTHENFIRST (cut h) (prec t)
+  in 
+    prec (List.rev l)
+
+(****************************************************)
+(*            Resolution tactics                    *)
+(****************************************************)
+
 (* 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 thm_ty0 = nf_betaiota (pf_type_of gl 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 clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in
+      Clenvtac.res_pf clause gl
+    with (Pretype_errors.PretypeError _|RefinerError _|UserError _|Failure _) as exn ->
       let red_thm =
-        try red_product (w_env wc) (w_Underlying wc) thm_ty
+        try red_product (pf_env gl) (project gl) thm_ty
         with (Redelimination | UserError _) -> raise exn in
       try_apply red_thm in
   try try_apply thm_ty0
-  with (RefinerError _|UserError _|Failure _) ->
+  with (Pretype_errors.PretypeError _|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 clause = make_clenv_binding_apply gl None (c,thm_ty0) lbind in 
+    Clenvtac.res_pf clause gl
 
 let apply c = apply_with_bindings (c,NoBindings)
 
@@ -481,9 +541,46 @@ let apply_list = function
 (* 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
+  let clause = mk_clenv_type_of gl c in 
+  res_pf clause gl
+
+(* [apply_in hyp c] replaces
+
+   hyp : forall y1, ti -> t             hyp : rho(u)
+   ========================    with     ============  and the =======
+   goal                                 goal                  rho(ti)
+
+   assuming that [c] has type [forall x1..xn -> t' -> u] for some [t]
+   unifiable with [t'] with unifier [rho]
+*)
+
+let find_matching_clause unifier clause =
+  let rec find clause =
+    try unifier clause
+    with exn when catchable_exception exn ->
+    try find (clenv_push_prod clause)
+    with NotExtensibleClause -> failwith "Cannot apply"
+  in find clause
+
+let apply_in_once gls innerclause (d,lbind) =
+  let thm = nf_betaiota (pf_type_of gls d) in
+  let clause = make_clenv_binding gls (d,thm) lbind in
+  let ordered_metas = List.rev (clenv_independent clause) in
+  if ordered_metas = [] then error "Statement without assumptions";
+  let f mv = find_matching_clause (clenv_fchain mv clause) innerclause in
+  try list_try_find f ordered_metas
+  with Failure _ -> error "Unable to unify"
+
+let apply_in id lemmas gls =
+  let t' = pf_get_hyp_typ gls id in
+  let innermostclause = mk_clenv_from_n gls (Some 0) (mkVar id,t') in
+  let clause = List.fold_left (apply_in_once gls) innermostclause lemmas in
+  let new_hyp_prf  = clenv_value clause in
+  let new_hyp_typ  = clenv_type clause in
+  tclTHEN
+    (tclEVARS (evars_of clause.env))
+    (cut_replacing id new_hyp_typ
+      (fun x gls -> refine_no_check new_hyp_prf gls)) gls
 
 (* A useful resolution tactic which, if c:A->B, transforms |- C into
    |- B -> C and |- A
@@ -504,278 +601,13 @@ let apply_without_reduce c gl =
 
 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 in_every_hyp cls = (cls.onhyps = None)
-
-(*
-(* 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 occ = [] & d = newdecl then
-	    if not (in_every_hyp 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 = Evarutil.refresh_universes (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
+    match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with
+      | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) ->
+	  let c2 = refresh_universes c2 in
+	  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"
 
 (********************************************************************)
 (*               Exact tactics                                      *)
@@ -791,6 +623,11 @@ let exact_check c gl =
 
 let exact_no_check = refine_no_check
 
+let vm_cast_no_check c gl = 
+  let concl = pf_concl gl in
+  refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl
+
+
 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)
@@ -838,9 +675,8 @@ let rec intros_clearing = function
 (* 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 clause  = make_clenv_binding g (c,pf_type_of g c) lbind in
+  let (thd,tstack) = whd_stack (clenv_value clause) in
   let nargs = List.length tstack in
   let cut_pf = 
     applist(thd, 
@@ -848,10 +684,25 @@ let new_hyp mopt (c,lbind) g =
 	      | Some m -> if m < nargs then list_firstn m tstack else tstack
 	      | None   -> tstack)
   in 
-  (tclTHENLAST (tclTHEN (kONT clause.hook)
+  (tclTHENLAST (tclTHEN (tclEVARS (evars_of clause.env))
                (cut (pf_type_of g cut_pf)))
      ((tclORELSE (apply cut_pf) (exact_no_check cut_pf)))) g
 
+(* Keeping only a few hypotheses *)
+
+let keep hyps gl =
+  let env = Global.env() in
+  let ccl = pf_concl gl in
+  let cl,_ =
+    fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
+      if List.mem hyp hyps
+	or List.exists (occur_var_in_decl env hyp) keep
+	or occur_var env hyp ccl
+      then (clear,decl::keep)
+      else (hyp::clear,keep))
+      ~init:([],[]) (pf_env gl)
+  in thin cl gl
+
 (************************)
 (* Introduction tactics *)
 (************************)
@@ -860,8 +711,7 @@ 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
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames 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 
@@ -872,7 +722,8 @@ let constructor_tac boundopt i lbind gl =
   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
+  (tclTHENLIST 
+     [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl
 
 let one_constructor i = constructor_tac None i
 
@@ -903,33 +754,26 @@ 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
+  | App (f,cl) ->  
+      array_last cl
   | _ -> anomaly "last_arg"
 	
-let elimination_clause_scheme kONT elimclause indclause allow_K gl = 
+let elimination_clause_scheme allow_K elimclause indclause gl = 
   let indmv = 
-    (match kind_of_term (last_arg (clenv_template elimclause).rebus) with
+    (match kind_of_term (last_arg elimclause.templval.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
+  res_pf elimclause' ~allow_K: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)
+  clenv_type (make_clenv_binding wc (c,t) lbind)
 
 (* 
  * Elimination tactic with bindings and using an arbitrary 
@@ -939,41 +783,30 @@ let type_clenv_binding wc (c,t) lbind =
  * 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 general_elim_clause elimtac (c,lbindc) (elimc,lbindelimc) gl =
   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
+  let indclause  = make_clenv_binding gl (c,t) lbindc  in
+  let elimt      = pf_type_of gl elimc in
+  let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in 
+    elimtac elimclause indclause gl
+
+let general_elim c e ?(allow_K=true) =
+  general_elim_clause (elimination_clause_scheme allow_K) c e
 
 (* 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 (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  lookup_eliminator ind (elimination_sort_of_goal gl)
+
+let default_elim (c,_ as cx) gl = 
+  general_elim cx (find_eliminator c gl,NoBindings) gl
+
+let elim_in_context c = function
+  | Some elim -> general_elim c elim ~allow_K:true
+  | None -> default_elim c
 
 let elim (c,lbindc as cx) elim =
   match kind_of_term c with
@@ -986,8 +819,16 @@ let elim (c,lbindc as cx) elim =
 let simplest_elim c = default_elim (c,NoBindings)
 
 (* Elimination in hypothesis *)
+(* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y)
+              indclause : forall ..., hyps -> a=b    (to take place of ?Heq)
+              id : phi(a)                            (to take place of ?H)
+      and the result is to overwrite id with the proof of phi(b)
 
-let elimination_in_clause_scheme kONT id elimclause indclause =
+   but this generalizes to any elimination scheme with one constructor
+   (e.g. it could replace id:A->B->C by id:C, knowing A/\B)
+*)
+
+let elimination_in_clause_scheme id elimclause indclause gl =
   let (hypmv,indmv) = 
     match clenv_independent elimclause with
         [k1;k2] -> (k1,k2)
@@ -995,43 +836,30 @@ let elimination_in_clause_scheme kONT id elimclause indclause =
           (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 hyp_typ = pf_type_of gl hyp in
+  let hypclause = mk_clenv_from_n gl (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
+  let new_hyp_prf  = clenv_value elimclause'' in
+  let new_hyp_typ  = clenv_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
+    (tclEVARS (evars_of elimclause''.env))
+    (cut_replacing id new_hyp_typ
+      (fun x gls -> refine_no_check new_hyp_prf gls)) gl
+
+let general_elim_in id =
+  general_elim_clause (elimination_in_clause_scheme id)
 
 (* 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 
+  let case = 
+    if occur_term c (pf_concl gl) then make_case_dep else make_case_gen in
+  let elim     = pf_apply case gl mind sort in 
   general_elim (c,lbindc) (elim,NoBindings) gl
 
 let general_case_analysis (c,lbindc as cx) =
@@ -1051,23 +879,297 @@ let simplest_case c = general_case_analysis (c,NoBindings)
 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
+let rec explicit_intro_names = function
+| (IntroWildcard | IntroAnonymous) :: l -> explicit_intro_names l
+| IntroIdentifier id :: l -> id :: explicit_intro_names l
+| IntroOrAndPattern ll :: l' -> 
+    List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll)
+| [] -> []
+
+  (* We delay thinning until the completion of the whole intros tactic
+     to ensure that dependent hypotheses are cleared in the right
+     dependency order (see bug #1000); we use fresh names, not used in
+     the tactic, for the hyps to clear *)
+let rec intros_patterns avoid thin destopt = function
+  | IntroWildcard :: l ->
+      tclTHEN 
+        (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) None true)
+        (onLastHyp (fun id ->
+	  tclORELSE
+	    (tclTHEN (clear [id]) (intros_patterns avoid thin destopt l))
+	    (intros_patterns avoid (id::thin) destopt l)))
+  | IntroIdentifier id :: l ->
+      tclTHEN
+        (intro_gen (IntroMustBe id) destopt true)
+        (intros_patterns avoid thin destopt l)
+  | IntroAnonymous :: l ->
+      tclTHEN
+        (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) destopt true)
+        (intros_patterns avoid thin destopt l)
+  | IntroOrAndPattern ll :: l' ->
+      tclTHEN
+        introf
         (tclTHENS
 	  (tclTHEN case_last clear_last)
-	  (List.map (intros_pattern destopt) l))
+	  (List.map (fun l -> intros_patterns avoid thin destopt (l@l')) ll))
+  | [] -> clear thin
+
+let intros_pattern = intros_patterns [] []
 
-and intros_pattern destopt l = tclMAP (intro_pattern destopt) l
+let intro_pattern destopt pat = intros_patterns [] [] destopt [pat]
 
 let intro_patterns = function 
   | [] -> tclREPEAT intro
   | l  -> intros_pattern None l
 
+(**************************)
+(*   Other cut tactics    *)
+(**************************)
+
+let hid = id_of_string "H"
+let xid = id_of_string "X"
+
+let make_id s = fresh_id [] (match s with Prop _ -> hid | Type _ -> xid)
+
+let prepare_intros s ipat gl = match ipat with
+  | IntroAnonymous -> make_id s gl, tclIDTAC
+  | IntroWildcard -> let id = make_id s gl in id, thin [id]
+  | IntroIdentifier id -> id, tclIDTAC
+  | IntroOrAndPattern ll -> make_id s gl, 
+    (tclTHENS 
+      (tclTHEN case_last clear_last)
+      (List.map (intros_pattern None) ll))
+
+let ipat_of_name = function
+  | Anonymous -> IntroAnonymous
+  | Name id -> IntroIdentifier id
+
+let assert_as first ipat c gl =
+  match kind_of_term (hnf_type_of gl c) with
+  | Sort s ->
+      let id,tac = prepare_intros s ipat gl in
+      tclTHENS ((if first then internal_cut else internal_cut_rev) id c)
+	(if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl
+  | _  -> error "Not a proposition or a type"
+
+let assert_tac first na = assert_as first (ipat_of_name na)
+let true_cut = assert_tac true 
+
+(**************************)
+(*   Generalize tactics   *)
+(**************************)
+
+let generalize_goal gl c cl =
+  let t = refresh_universes (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 out_arg = function
+  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgArg x -> x
+
+let occurrences_of_hyp id cls =
+  let rec hyp_occ = function
+      [] -> None
+    | ((occs,id'),hl)::_ when id=id' -> Some (List.map out_arg 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 (List.map out_arg cls.concl_occs) else None
+
+let in_every_hyp cls = (cls.onhyps=None)
+
+(*
+(* 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 occ = [] & d = newdecl then
+		if not (in_every_hyp occs)
+		then raise (RefinerError (DoesNotOccurIn (c,hyp)))
+		else raise Not_found
+              else 
+		(subst1_named_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 occ = [] & d = newdecl then
+	    if not (in_every_hyp occs)
+	    then raise (RefinerError (DoesNotOccurIn (c,hyp)))
+	    else depdecls
+          else 
+	    (subst1_named_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 = refresh_universes (pf_type_of gl c) in
+  let newcl = mkNamedLetIn id c t ccl in
+  tclTHENLIST
+    [ convert_concl_no_check newcl DEFAULTcast;
+      intro_gen (IntroMustBe id) lastlhyp true;
+      if with_eq then tclIDTAC else thin_body [id];
+      tclMAP convert_hyp_no_check depdecls ] gl
+  
+(* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *)
+let forward usetac ipat c gl =
+  match usetac with
+  | None -> 
+      let t = refresh_universes (pf_type_of gl c) in
+      tclTHENFIRST (assert_as true ipat t) (exact_no_check c) gl
+  | Some tac -> 
+      tclTHENFIRST (assert_as true ipat c) tac gl
+
+(*****************************)
+(* High-level induction      *)
+(*****************************)
+
 (*
  * A "natural" induction tactic
  * 
@@ -1100,20 +1202,12 @@ let intro_patterns = function
 
  *)
 
-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)
+    msg_warning 
+      (str"Unused introduction pattern" ++ str s ++ 
+       str": " ++ prlist_with_sep spc pr_intro_pattern names)
 
 let rec first_name_buggy = function
   | IntroOrAndPattern [] -> None
@@ -1121,112 +1215,64 @@ let rec first_name_buggy = function
   | IntroOrAndPattern ((p::_)::_) -> first_name_buggy p
   | IntroWildcard -> None
   | IntroIdentifier id -> Some id
+  | IntroAnonymous -> assert false
+
+let consume_pattern avoid id gl = function
+  | [] -> (IntroIdentifier (fresh_id avoid id gl), [])
+  | IntroAnonymous::names ->
+      let avoid = avoid@explicit_intro_names names in
+      (IntroIdentifier (fresh_id avoid id gl), names)
+  | pat::names -> (pat,names)
+
+let re_intro_dependent_hypotheses tophyp (lstatus,rstatus) =
+  let newlstatus = (* if some IH has taken place at the top of hyps *)
+    List.map (function (hyp,None) -> (hyp,tophyp) | x -> x) lstatus in
+  tclTHEN
+    (intros_rmove rstatus)
+    (intros_move newlstatus)
 
 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, [])
+let induct_discharge statuslists destopt avoid' (avoid,ra) names gl =
+  let avoid = avoid @ avoid' in
+  let rec peel_tac ra names tophyp gl = match ra with
+    | (RecArg,recvarname) ::
+        (IndArg,hyprecname) :: ra' ->
+        let recpat,names = match names with
           | [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];
+              let id = next_ident_away (add_prefix "IH" id) avoid in
+	      (pat, [IntroIdentifier id])
+          | _ -> consume_pattern avoid recvarname gl names in
+        let hyprec,names = consume_pattern avoid hyprecname gl names in
+        (* IH stays at top: we need to update tophyp *)
+        (* This is buggy for intro-or-patterns with different first hypnames *)
+        (* Would need to pass peel_tac as a continuation of intros_patterns *)
+        (* (or to have hypotheses classified by blocks...) *)
+        let tophyp = if tophyp=None then first_name_buggy hyprec else tophyp in
         tclTHENLIST
-	  [ intros_pattern destopt [recpat];
-	    intros_pattern None [hyprec];
-	    peel_tac ra' names ] gl
-    | (IndArg,(hyprecname7,hyprecname8)) :: ra' ->
+	  [ intros_patterns avoid [] destopt [recpat];
+	    intros_patterns avoid [] None [hyprec];
+	    peel_tac ra' names tophyp] gl
+    | (IndArg,hyprecname) :: 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) 
-		  | _ -> raise (RefinerError IntroNeedsProduct))) 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
+        let pat,names = consume_pattern avoid hyprecname gl names in
+	tclTHEN (intros_patterns avoid [] destopt [pat])
+          (peel_tac ra' names tophyp) gl
+    | (RecArg,recvarname) :: ra' ->
+        let pat,names = consume_pattern avoid recvarname gl names in
+	tclTHEN (intros_patterns avoid [] destopt [pat]) 
+          (peel_tac ra' names tophyp) 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) 
-		  | _ -> raise (RefinerError IntroNeedsProduct))) 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) 
-		  | _ -> raise (RefinerError IntroNeedsProduct))) 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
+        let pat,names = match names with
+          | [] -> IntroAnonymous, []
+          | pat::names -> pat,names in
+	tclTHEN (intros_patterns avoid [] destopt [pat])
+          (peel_tac ra' names tophyp) gl
     | [] ->
         check_unused_names names;
-        tclIDTAC gl
+        re_intro_dependent_hypotheses tophyp statuslists 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
+  peel_tac ra names None 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
@@ -1335,11 +1381,25 @@ let find_atomic_param_of_ind nparams indtyp =
    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 *)
+   Others solutions are welcome 
+
+   PC 9 fev 06: Adapted to accept multi argument principle with no
+   main arg hyp. hyp0 is now optional, meaning that it is possible
+   that there is no main induction hypotheses. In this case, we
+   consider the last "parameter" (in [indvars]) as the limit between
+   "left" and "right", BUT it must be included in indhyps.
+
+   Other solutions are still welcome
+
+*)
 
 exception Shunt of identifier option
 
-let cook_sign hyp0 indvars env =
+let cook_sign hyp0_opt indvars_init env =
+  let hyp0,indvars = 
+    match hyp0_opt with
+      | None -> List.hd (List.rev indvars_init) , indvars_init
+      | Some h -> h,indvars_init in
   (* 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
@@ -1352,6 +1412,9 @@ let cook_sign hyp0 indvars env =
   let seek_deps env (hyp,_,_ as decl) rhyp =
     if hyp = hyp0 then begin
       before:=false; 
+      (* If there was no main induction hypotheses, then hyp is one of
+         indvars too, so add it to indhyps. *)
+      (if hyp0_opt=None then indhyps := hyp::!indhyps); 
       None (* fake value *)
     end else if List.mem hyp indvars then begin
       (* warning: hyp can still occur after induction *)
@@ -1374,7 +1437,7 @@ let cook_sign hyp0 indvars env =
   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) =
+  let compute_lstatus lhyp (hyp,_,_) =
     if hyp = hyp0 then raise (Shunt lhyp);
     if List.mem hyp !ldeps then begin
       lstatus := (hyp,lhyp)::!lstatus;
@@ -1384,49 +1447,89 @@ let cook_sign hyp0 indvars env =
   in
   try 
     let _ = fold_named_context_reverse compute_lstatus ~init:None env in
-    anomaly "hyp0 not found"
+(*     anomaly "hyp0 not found" *)
+    raise (Shunt (None)) (* ?? FIXME *)
   with Shunt lhyp0 ->
     let statuslists = (!lstatus,List.rev !rstatus) in
-    (statuslists, lhyp0, !indhyps, !decldeps)
+    (statuslists, (if hyp0_opt=None then None else lhyp0) , !indhyps, !decldeps)
+
 
-let induction_tac varname typ ((elimc,lbindelimc),elimt) gl =
+(*
+   The general form of an induction principle is the following:
+   
+   forall prm1 prm2 ... prmp,                          (induction parameters)
+   forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates)
+   branch1, branch2, ... , branchr,                    (branches of the principle)
+   forall (x1:Ti_1) (x2:Ti_2) ... (xni:Ti_ni),         (induction arguments)
+   (HI: I prm1..prmp x1...xni)                         (optional main induction arg)
+   -> (Qi x1...xni HI        (f prm1...prmp x1...xni)).(conclusion)
+                   ^^        ^^^^^^^^^^^^^^^^^^^^^^^^
+               optional        optional argument added if
+               even if HI    principle generated by functional 
+             present above   induction, only if HI does not exist
+             [indarg]                  [farg]
+
+  HI is not present when the induction principle does not come directly from an
+  inductive type (like when it is generated by functional induction for
+  example). HI is present otherwise BUT may not appear in the conclusion
+  (dependent principle). HI and (f...) cannot be both present.
+
+  Principles taken from functional induction have the final (f...).*)
+
+(* [rel_contexts] and [rel_declaration] actually contain triples, and
+   lists are actually in reverse order to fit [compose_prod]. *)
+type elim_scheme = { 
+  elimc: (Term.constr * constr Rawterm.bindings) option;
+  elimt: types;
+  indref: global_reference option;
+  params: rel_context;     (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
+  nparams: int;            (* number of parameters *)
+  predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
+  npredicates: int;        (* Number of predicates *)
+  branches: rel_context;   (* branchr,...,branch1 *)
+  nbranches: int;          (* Number of branches *) 
+  args: rel_context;       (* (xni, Ti_ni) ... (x1, Ti_1) *)
+  nargs: int;              (* number of arguments *)
+  indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) 
+				     if HI is in premisses, None otherwise *)
+  concl: types;            (* Qi x1...xni HI (f...), HI and (f...) 
+			      are optional and mutually exclusive *)
+  indarg_in_concl: bool;   (* true if HI appears at the end of conclusion *)
+  farg_in_concl: bool;     (* true if (f...) appears at the end of conclusion *)
+}
+
+let empty_scheme = 
+  { 
+    elimc = None;
+    elimt = mkProp;
+    indref = None;
+    params = [];
+    nparams = 0;
+    predicates = [];
+    npredicates = 0;
+    branches = [];
+    nbranches = 0;
+    args = [];
+    nargs = 0;
+    indarg = None;
+    concl = mkProp;
+    indarg_in_concl = false;
+    farg_in_concl = false;
+  }
+
+
+(* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the
+   hypothesis on which the induction is made *)
+let induction_tac varname typ scheme (*(elimc,lbindelimc),elimt*) gl =
+  let elimc,lbindelimc = 
+    match scheme.elimc with | Some x -> x | None -> error "No definition of the principle" in
+  let elimt = scheme.elimt in
   let c = mkVar varname in
-  let (wc,kONT)  = startWalk gl                    in
-  let indclause  = make_clenv_binding wc (c,typ) NoBindings  in
+  let indclause  = make_clenv_binding gl (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
+    make_clenv_binding gl 
+      (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in
+  elimination_clause_scheme true elimclause indclause gl
 
 let make_base n id =
   if n=0 or n=1 then id
@@ -1435,12 +1538,19 @@ let make_base n id =
     (* digits *)
     id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0)))
 
-let make_up_names8 n ind (_,cname) = 
+(* Builds tw different names from an optional inductive type and a
+   number, also deals with a list of names to avoid. If the inductive
+   type is None, then hyprecname is HIi where i is a number. *)
+let make_up_names n ind_opt 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 base_ind = 
+    if is_hyp then 
+      match ind_opt with
+	| None -> id_of_string ""
+	| Some ind_id -> Nametab.id_of_global ind_id 
+    else cname in
+  let hyprecname = add_prefix "IH" (make_base n base_ind) in
   let avoid =
     if n=1 (* Only one recursive argument *) or n=0 then []
     else
@@ -1475,109 +1585,438 @@ let error_ind_scheme s =
   let s = if s <> "" then s^" " else s in
   error ("Cannot recognise "^s^"an induction schema")
 
+
+
+
+let occur_rel n c = 
+  let res = not (noccurn n c) in
+  res
+
+let list_filter_firsts f l =
+  let rec list_filter_firsts_aux f acc l =
+    match l with
+      | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l'
+      | _ -> acc,l
+  in
+  list_filter_firsts_aux f [] l
+
+let count_rels_from n c =
+  let rels = free_rels c in
+  let cpt,rg = ref 0, ref n in
+  while Intset.mem !rg rels do
+    cpt:= !cpt+1; rg:= !rg+1;
+  done;
+  !cpt
+
+let count_nonfree_rels_from n c =
+  let rels = free_rels c in
+  if Intset.exists (fun x -> x >= n) rels then
+    let cpt,rg = ref 0, ref n in
+    while not (Intset.mem !rg rels) do
+      cpt:= !cpt+1; rg:= !rg+1;
+    done;
+    !cpt
+  else raise Not_found
+
+
+(* cuts a list in two parts, first of size n. Size must be greater than n *)
+let cut_list n l =
+  let rec cut_list_aux acc n l =
+    if n<=0 then acc,l
+    else match l with
+      | [] -> assert false
+      | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in
+  let res = cut_list_aux [] n l in
+  res
+
+
+(* This functions splits the products of the induction scheme [elimt] in three
+   parts: 
+    - branches, easily detectable (they are not referred by rels in the subterm)
+    - what was found before branches (acc1) that is: parameters and predicates
+    - what was found after branches (acc3) that is: args and indarg if any
+   if there is no branch, we try to fill in acc3 with args/indargs.
+   We also return the conclusion.
+*)
+let decompose_paramspred_branch_args elimt = 
+  let rec cut_noccur elimt acc2 : rel_context * rel_context * types =
+    match kind_of_term elimt with
+      | Prod(nme,tpe,elimt') -> 
+	  let hd_tpe,_ = decompose_app (snd (decompose_prod_assum tpe)) in
+	  if not (occur_rel 1 elimt') && isRel hd_tpe	    
+	  then cut_noccur elimt' ((nme,None,tpe)::acc2)
+	  else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl
+      | App(_, _) | Rel _ -> acc2 , [] , elimt
+      | _ -> error "cannot recognise an induction schema" in
+  let rec cut_occur elimt acc1 : rel_context * rel_context * rel_context * types =
+    match kind_of_term elimt with
+      | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c ((nme,None,tpe)::acc1)
+      | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl
+      | App(_, _) | Rel _ -> acc1,[],[],elimt
+      | _ -> error "cannot recognise an induction schema" in
+  let acc1, acc2 , acc3, ccl = cut_occur elimt [] in
+  (* Particular treatment when dealing with a dependent empty type elim scheme:
+     if there is no branch, then acc1 contains all hyps which is wrong (acc1
+     should contain parameters and predicate only). This happens for an empty
+     type (See for example Empty_set_ind, as False would actually be ok). Then
+     we must find the predicate of the conclusion to separate params_pred from
+     args. We suppose there is only one predicate here. *)
+  if List.length acc2 <> 0 then acc1, acc2 , acc3, ccl
+  else 
+    let hyps,ccl = decompose_prod_assum elimt in
+    let hd_ccl_pred,_ = decompose_app ccl in
+    match kind_of_term hd_ccl_pred with
+      | Rel i  -> let acc3,acc1 = cut_list (i-1) hyps in acc1 , [] , acc3 , ccl
+      | _ -> error "cannot recognize an induction schema"
+
+
+
+let exchange_hd_app subst_hd t =
+  let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args)
+
+
+exception NoLastArg
+exception NoLastArgCcl
+
+(* Builds an elim_scheme frome its type and calling form (const+binding) We
+   first separate branches.  We obtain branches, hyps before (params + preds),
+   hyps after (args <+ indarg if present>) and conclusion.  Then we proceed as
+   follows:
+   
+   - separate parameters and predicates in params_preds. For that we build: 
+ forall (x1:Ti_1)(xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY x1...xni HI/farg
+                             ^^^^^^^^^^^^^^^^^^^^^^^^^                  ^^^^^^^
+                                       optional                           opt
+     Free rels appearing in this term are parameters (branches should not
+     appear, and the only predicate would have been Qi but we replaced it by
+     DUMMY). We guess this heuristic catches all params.  TODO: generalize to
+     the case where args are merged with branches (?) and/or where several
+     predicates are cited in the conclusion.
+
+   - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *)
+let compute_elim_sig ?elimc elimt =
+  let params_preds,branches,args_indargs,conclusion = 
+    decompose_paramspred_branch_args elimt in
+  
+  let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in
+  let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in  
+  let nparams = Intset.cardinal (free_rels concl_with_args) in
+  let preds,params = cut_list (List.length params_preds - nparams) params_preds in
+  
+  (* A first approximation, further anlysis will tweak it *)
+  let res = ref { empty_scheme with
+    (* This fields are ok: *)
+    elimc = elimc; elimt = elimt; concl = conclusion;
+    predicates = preds; npredicates = List.length preds; 
+    branches = branches; nbranches = List.length branches; 
+    farg_in_concl = (try isApp (last_arg ccl) with _ -> false);
+    params = params; nparams = nparams; 
+    (* all other fields are unsure at this point. Including these:*)
+    args = args_indargs; nargs = List.length args_indargs; } in
+  try 
+    (* Order of tests below is important. Each of them exits if successful. *)
+    (* 1- First see if (f x...) is in the conclusion. *)
+    if !res.farg_in_concl 
+    then begin
+      res := { !res with
+	indarg = None;
+	indarg_in_concl = false; farg_in_concl = true };
+      raise Exit
+    end;
+    (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *)
+    if !res.nargs=0 then raise Exit; 
+    (* 3- Look at last arg: is it the indarg? *)
+    ignore (
+      match List.hd args_indargs with
+	| hiname,Some _,hi -> error "cannot recognize an induction schema"
+	| hiname,None,hi -> 
+	    let hi_ind, hi_args = decompose_app hi in
+	    let hi_is_ind = (* hi est d'un type globalisable *)
+	      match kind_of_term hi_ind with
+		| Ind (mind,_)  -> true 
+		| Var _ -> true 
+		| Const _ -> true 
+		| Construct _ -> true 
+		| _ -> false in
+	    let hi_args_enough = (* hi a le bon nbre d'arguments *)
+	      List.length hi_args = List.length params + !res.nargs -1 in
+	    (* FIXME: Ces deux tests ne sont pas suffisants. *)
+	    if not (hi_is_ind & hi_args_enough) then raise Exit (* No indarg *)
+	    else (* Last arg is the indarg *)
+	      res := {!res with
+		indarg = Some (List.hd !res.args);
+		indarg_in_concl = occur_rel 1 ccl;
+		args = List.tl !res.args; nargs = !res.nargs - 1;
+	      };
+	    raise Exit);
+    raise Exit(* exit anyway *)
+  with Exit -> (* Ending by computing indrev: *)
+    match !res.indarg with
+      | None -> !res (* No indref *)
+      | Some ( _,Some _,_) -> error "Cannot recognise an induction scheme"
+      | Some ( _,None,ind) -> 
+	  let indhd,indargs = decompose_app ind in
+	  try {!res with indref = Some (global_of_constr indhd) }
+	  with _ -> error "Cannot find the inductive type of the inductive 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 =
+   elimination schemes built by Coq. Schemes may have the standard
+   form computed from an inductive type OR (feb. 2006) a non standard
+   form. That is: with no main induction argument and with an optional
+   extra final argument of the form (f x y ...) in the conclusion. In
+   the non standard case, naming of generated hypos is slightly
+   different. *)
+let compute_elim_signature elimc elimt names_info =
+  let scheme = compute_elim_sig ~elimc:elimc elimt in
+  let f,l = decompose_app scheme.concl in
+  (* Vérifier que les arguments de Qi sont bien les xi. *)
+  match scheme.indarg with
+    | Some (_,Some _,_) -> error "strange letin, cannot recognize an induction schema"
+    | None -> (* Non standard scheme *)
+	let npred = List.length scheme.predicates in 
+	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
+	    | _ -> 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
+	    | _ when is_pred p c = IndArg -> []
+	    | _ -> raise Exit in 
+	let rec find_branches p lbrch = 
+	  match lbrch with
+	    | (_,None,t)::brs ->
+		(try
+		  let lchck_brch = check_branch p t in
+		  let n = List.fold_left 
+		    (fun n b -> if b=RecArg then n+1 else n) 0 lchck_brch in
+		  let recvarname, hyprecname, avoid = 
+		    make_up_names n scheme.indref names_info in
+		  let namesign = 
+		    List.map (fun b -> (b,if b=IndArg then hyprecname else recvarname))
+		      lchck_brch in
+		  (avoid,namesign) :: find_branches (p+1) brs
+		with Exit-> error_ind_scheme "the branches of")
+	    | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
+	    | [] -> [] in
+	let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in
+	indsign,scheme	
+	
+    | Some ( _,None,ind) -> (* Standard scheme from an inductive type *)
+	let indhd,indargs = decompose_app ind in
+	let npred = List.length scheme.predicates in
+	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
+	  | _ when is_pred p c = IndArg -> []
+	  | _ -> raise Exit in 
+	let rec find_branches p lbrch =
+	  match lbrch with
+	    | (_,None,t)::brs ->
+		(try
+		  let lchck_brch = check_branch p t in
+		  let n = List.fold_left 
+		    (fun n b -> if b=RecArg then n+1 else n) 0 lchck_brch in
+		  let recvarname, hyprecname, avoid = 
+		    make_up_names n scheme.indref names_info in
+		  let namesign = 
+		    List.map (fun b -> (b,if b=IndArg then hyprecname else recvarname))
+		      lchck_brch in
+		  (avoid,namesign) :: find_branches (p+1) brs
+		with Exit -> error_ind_scheme "the branches of")
+	    | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
+	    | [] ->
+		(* Check again conclusion *)
+
+		let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in
+		let ind_is_ok = 
+		  list_lastn scheme.nargs indargs 
+		  = extended_rel_list 0 scheme.args in
+		if not (ccl_arg_ok & ind_is_ok) then
+		  error "Cannot recognize the conclusion of an induction schema";
+		[] 
+	in
+	let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in
+	indsign,scheme
+
+
+let find_elim_signature isrec 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
+	  if isrec then lookup_eliminator mind s
+	  else pf_apply 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 indsign,elim_scheme = compute_elim_signature elimc elimt hyp0 in
+  (indsign,elim_scheme)
+
+
+let mapi f l =
+  let rec mapi_aux f i l =   
+    match l with
+      | [] -> []
+      | e::l' -> f e i :: mapi_aux f (i+1) l' in
+  mapi_aux f 0 l
+
+
+(* Instanciate all meta variables of elimclause using lid, some elts
+   of lid are parameters (first ones), the other are
+   arguments. Returns the clause obtained.  *)
+let recolle_clenv scheme lid elimclause gl = 
+  let _,arr = destApp elimclause.templval.rebus in
+  let lindmv = 
+    Array.map
+      (fun x -> 
+	match kind_of_term x with
+	  | Meta mv -> mv
+	  | _  -> errorlabstrm "elimination_clause"
+              (str "The type of elimination clause is not well-formed"))
+      arr in
+  let nmv = Array.length lindmv in
+  let lidparams,lidargs = cut_list (scheme.nparams) lid in
+  let nidargs = List.length lidargs in
+  (* parameters correspond to first elts of lid. *)
+  let clauses_params = 
+    mapi (fun id i -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) lidparams in
+  (* arguments correspond to last elts of lid. *)
+  let clauses_args = 
+    mapi 
+      (fun id i -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i))
+      lidargs in
+  let clause_indarg = 
+    match scheme.indarg with
+      | None -> []
+      | Some (x,_,typx) -> []
+  in
+  let clauses = clauses_params@clauses_args@clause_indarg in
+  (* iteration of clenv_fchain with all infos we have. *)
+  List.fold_right
+    (fun e acc ->
+      let x,y,i = e in
+      (* from_n (Some 0) means that x should be taken "as is" without
+         trying to unify (which would lead to trying to apply it to
+         evars if y is a product). *)
+      let indclause  = mk_clenv_from_n gl (Some 0) (x,y) in
+      let elimclause' = clenv_fchain i acc indclause in
+      elimclause')
+    (List.rev clauses)
+    elimclause
+
+
+
+(* Unification of the goal and the principle applied to meta variables:
+   (elimc ?i ?j ?k...?l). This solves partly meta variables (and may
+    produce new ones). Then refine with the resulting term with holes.
+*)
+let induction_tac_felim indvars (* (elimc,lbindelimc) elimt *) scheme gl = 
+  let elimt = scheme.elimt in
+  let elimc,lbindelimc = 
+    match scheme.elimc with | Some x -> x | None -> error "No definition of the principle" in
+  (* elimclause contains this: (elimc ?i ?j ?k...?l) *)
+  let elimclause =
+    make_clenv_binding gl (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in
+  (* elimclause' is built from elimclause by instanciating all args and params. *)
+  let elimclause' = recolle_clenv scheme indvars elimclause gl in
+  (* one last resolution (useless?) *)
+  let resolved = clenv_unique_resolver true elimclause' gl in
+  clenv_refine resolved gl
+
+(* Induction with several induction arguments, main differences with
+   induction_from_context is that there is no main induction argument,
+   so we chose one to be the positioning reference. On the other hand,
+   all args and params must be given, so we help a bit the unifier by
+   making the "pattern" by hand before calling induction_tac_felim
+   FIXME: REUNIF AVEC induction_tac_felim? *)
+let induction_from_context_l isrec elim_info lid names gl =
+  let indsign,scheme = elim_info in
+  (* number of all args, counting farg and indarg if present. *)
+  let nargs_indarg_farg = scheme.nargs
+    + (if scheme.farg_in_concl then 1 else 0) 
+    + (if scheme.indarg <> None then 1 else 0) in
+  (* Number of given induction args must be exact. *)
+  if List.length lid <> nargs_indarg_farg + scheme.nparams then 
+      error "not the right number of arguments given to induction scheme";  
+  let env = pf_env gl in
+  (* hyp0 is used for re-introducing hyps at the right place afterward.
+     We chose the first element of the list of variables on which to
+     induct. It is probably the first of them appearing in the
+     context. *)
+  let hyp0,indvars,lid_params = 
+    match lid with
+      | []  -> anomaly "induction_from_context_l"
+      | e::l -> 
+	  let nargs_without_first = nargs_indarg_farg - 1 in
+	  let ivs,lp = cut_list nargs_without_first l in
+	  e, ivs, lp in
+  let statlists,lhyp0,indhyps,deps = cook_sign None (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
+  let dephyps = List.map (fun (id,_,_) -> id) deps in
+  let deps_cstr =
+    List.fold_left (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
+  (* terms to patternify we must patternify indarg or farg if present in concl *)
+  let lid_in_pattern = 
+    if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars
+    else List.rev (hyp0::indvars) in
+  let lidcstr = List.map (fun x -> mkVar x) lid_in_pattern in
+  let realindvars = (* hyp0 is a real induction arg if it is not the
+		       farg in the conclusion of the induction scheme *)
+    List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in
+  (* Magistral effet de bord: comme dans induction_from_context. *)
+  tclTHENLIST
+    [ 
+      (* Generalize dependent hyps (but not args) *)
+      if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
+      thin dephyps; (* clear dependent hyps *)
+      (* pattern to make the predicate appear. *)
+      reduce (Pattern (List.map (fun e -> ([],e)) lidcstr)) onConcl;
+      (* FIXME: Tester ca avec un principe dependant et non-dependant *)
+      (if isrec then tclTHENFIRSTn else tclTHENLASTn)
+       	(tclTHENLIST [ 
+	  (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all
+	     possible holes using arguments given by the user (but the
+	     functional one). *)
+	  induction_tac_felim realindvars scheme;
+          tclTRY (thin (List.rev (indhyps)));
+	])
+	(array_map2 
+	  (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names)
+    ]
+    gl
+
 
-let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl =
+
+let induction_from_context isrec elim_info hyp0 names 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 indsign,scheme = elim_info in
+
+  let indref = match scheme.indref with | None -> assert false | Some x -> x 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 indvars = find_atomic_param_of_ind scheme.nparams (snd (decompose_prod typ0)) in
+  (* induction_from_context_l isrec elim_info (hyp0::List.rev indvars) names gl  *)
+  let statlists,lhyp0,indhyps,deps = cook_sign (Some 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 =
+  let deps_cstr =
     List.fold_left
       (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
 
@@ -1590,11 +2029,11 @@ let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl =
      "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;
+    [ if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
       thin dephyps;
       (if isrec then tclTHENFIRSTn else tclTHENLASTn)
        	(tclTHENLIST
-	  [ induction_tac hyp0 typ0 (elimc,elimt);
+	  [ induction_tac hyp0 typ0 scheme (*scheme.elimc,scheme.elimt*);
 	    thin [hyp0];
             tclTRY (thin indhyps) ])
        	(array_map2
@@ -1602,15 +2041,38 @@ let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl =
     ]
     gl
 
+
+
+exception TryNewInduct of exn
+
 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
+  let (indsign,scheme as elim_info) = find_elim_signature isrec elim hyp0 gl in
+  if scheme.indarg = None then (* This is not a standard induction scheme (the
+				  argument is probably a parameter) So try the
+				  more general induction mechanism. *)
+    induction_from_context_l isrec elim_info [hyp0] names gl
+  else
+    let indref = match scheme.indref with | None -> assert false | Some x -> x in
+    tclTHEN
+      (atomize_param_of_ind (indref,scheme.nparams) hyp0)
+      (induction_from_context isrec elim_info hyp0 names) gl
+
+(* Induction on a list of induction arguments. Analyse the elim
+   scheme (which is mandatory for multiple ind args), check that all
+   parameters and arguments are given (mandatory too). *)
+let induction_without_atomization isrec elim names lid gl =
+  let (indsign,scheme as elim_info) =
+    find_elim_signature isrec elim (List.hd lid) gl in
+  let awaited_nargs = 
+    scheme.nparams + scheme.nargs 
+    + (if scheme.farg_in_concl then 1 else 0)
+    + (if scheme.indarg <> None then 1 else 0)
+  in
+  let nlid = List.length lid in
+  if nlid <> awaited_nargs
+  then error "Not the right number of induction arguments"
+  else induction_from_context_l isrec elim_info lid 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())) ->
@@ -1623,18 +2085,119 @@ let new_induct_gen isrec elim names c gl =
 	  (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))
+(* The two following functions should already exist, but found nowhere *)
+(* Unfolds x by its definition everywhere *)
+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) :: 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,DEFAULTcast)] gl
+
+(* Unfolds x by its definition everywhere and clear x. This may raise
+   an error if x is not defined. *)
+let unfold_all x gl =
+  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 tclIDTAC gl
+
+
+(* Induction on a list of arguments. First make induction arguments
+   atomic (using letins), then do induction. The specificity here is
+   that all arguments and parameters of the scheme are given
+   (mandatory for the moment), so we don't need to deal with
+    parameters of the inductive type as in new_induct_gen. *)
+let new_induct_gen_l isrec elim names lc gl =
+  let newlc = ref [] in
+  let letids = ref [] in
+  let rec atomize_list l gl =
+    match l with
+      | [] -> tclIDTAC gl
+      | c::l' ->
+	  match kind_of_term c with
+	    | Var id when not (mem_named_context id (Global.named_context())) -> 
+		let _ = newlc:= id::!newlc in
+		atomize_list l' gl
+
+	    | _ ->
+		let x = 
+		  id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in
+		
+		let id = fresh_id [] x gl in
+		let newl' = List.map (replace_term c (mkVar id)) l' in
+		let _ = newlc:=id::!newlc in
+		let _ = letids:=id::!letids in
+		tclTHEN 
+		  (letin_tac true (Name id) c allClauses)
+		  (atomize_list newl') gl in
+  tclTHENLIST 
+    [
+      (atomize_list lc);
+      (fun gl' -> (* recompute each time to have the new value of newlc *)
+	induction_without_atomization isrec elim names !newlc gl') ;
+      (* after induction, try to unfold all letins created by atomize_list
+         FIXME: unfold_all does not exist anywhere else? *)
+      (fun gl' -> (* recompute each time to have the new value of letids *)
+	tclMAP (fun x -> tclTRY (unfold_all x)) !letids gl')
+    ]
+    gl
+
 
-let new_induct = new_induct_destruct true
-let new_destruct = new_induct_destruct false
+let induct_destruct_l isrec lc elim names = 
+  (* Several induction hyps: induction scheme is mandatory *)
+  let _ = 
+    if elim = None 
+    then 
+      error ("Induction scheme must be given when several induction hypothesis.\n"
+      ^ "Example: induction x1 x2 x3 using my_scheme.") in
+  let newlc = 
+    List.map
+      (fun x -> 
+	match x with (* FIXME: should we deal with ElimOnIdent? *)
+	  | ElimOnConstr x -> x
+	  | _ -> error "don't know where to find some argument")
+      lc in
+  new_induct_gen_l isrec elim names newlc
+
+
+(* Induction either over a term, over a quantified premisse, or over
+   several quantified premisses (like with functional induction
+   principles). 
+   TODO: really unify induction with one and induction with several
+   args *)
+let induct_destruct isrec lc elim names = 
+  assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *)
+  if List.length lc = 1 then (* induction on one arg: use old mechanism *)
+    try 
+      let c = List.hd lc in
+      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))
+    with (* If this fails, try with new mechanism but if it fails too,
+	    then the exception is the first one. *)
+      | x -> (try induct_destruct_l isrec lc elim names with _  -> raise x)
+  else induct_destruct_l isrec lc elim names
+
+
+      
+
+let new_induct = induct_destruct true
+let new_destruct = induct_destruct false
 
 (* The registered tactic, which calls the default elimination
  * if no elimination constant is provided. *)
@@ -1645,23 +2208,12 @@ let new_destruct = new_induct_destruct false
 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_id hyp = 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
+  | NamedHyp id -> simple_induct_id id
+  | AnonHyp n -> simple_induct_nodep n
 
 (* Destruction tactics *)
 
@@ -1682,25 +2234,25 @@ let simple_destruct = function
  *)
 
 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
+  let clause = mk_clenv_type_of gl elim in
+  match kind_of_term (last_arg clause.templval.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
+	  clenv_unify true Reduction.CUMUL t
+            (clenv_meta_type clause mv) clause in
+	res_pf clause' ~allow_K: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
+  let elimc = 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 
+  let elimc = make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in 
   elim_scheme_type elimc t gl
 
 
@@ -1730,7 +2282,7 @@ let dAnd cls =
   onClauses
     (function
       | None    -> simplest_split
-      | Some (id,_,_) -> andE id)
+      | Some ((_,id),_) -> andE id)
     cls
 
 let orE id gl =
@@ -1744,7 +2296,7 @@ let orE id gl =
 let dorE b cls =
   onClauses
     (function
-      | (Some (id,_,_)) -> orE id
+      | (Some ((_,id),_)) -> orE id
       |  None     -> (if b then right else left) NoBindings)
     cls
 
@@ -1764,7 +2316,7 @@ let dImp cls =
   onClauses
     (function
       | None    -> intro
-      | Some (id,_,_) -> impE id)
+      | Some ((_,id),_) -> impE id)
     cls
 
 (************************************************)
@@ -1773,9 +2325,12 @@ let dImp cls =
 
 (* Reflexivity tactics *)
 
+let setoid_reflexivity = ref (fun _ -> assert false)
+let register_setoid_reflexivity f = setoid_reflexivity := f
+
 let reflexivity gl =
   match match_with_equation (pf_concl gl) with
-    | None -> error "The conclusion is not a substitutive equation" 
+    | None -> !setoid_reflexivity gl
     | Some (hdcncl,args) ->  one_constructor 1 NoBindings gl
 
 let intros_reflexivity  = (tclTHEN intros reflexivity)
@@ -1787,9 +2342,12 @@ let intros_reflexivity  = (tclTHEN intros reflexivity)
    defined and the conclusion is a=b, it solves the goal doing (Cut
    b=a;Intro H;Case H;Constructor 1) *)
 
+let setoid_symmetry = ref (fun _ -> assert false)
+let register_setoid_symmetry f = setoid_symmetry := f
+
 let symmetry gl =
   match match_with_equation (pf_concl gl) with
-    | None -> error "The conclusion is not a substitutive equation" 
+    | None -> !setoid_symmetry gl
     | Some (hdcncl,args) ->
         let hdcncls = string_of_inductive hdcncl in
         begin 
@@ -1810,12 +2368,14 @@ let symmetry gl =
 	      gl
 	end
 
+let setoid_symmetry_in = ref (fun _ _ -> assert false)
+let register_setoid_symmetry_in f = setoid_symmetry_in := f
+
 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" 
+    | None -> !setoid_symmetry_in id gl
     | Some (hdcncl,args) -> 
         let symccl = match args with 
 	  | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |])
@@ -1831,7 +2391,7 @@ let intros_symmetry =
   onClauses
     (function
       | None -> tclTHEN intros symmetry
-      | Some (id,_,_) -> symmetry_in id)
+      | Some ((_,id),_) -> symmetry_in id)
 
 (* Transitivity tactics *)
 
@@ -1845,9 +2405,12 @@ let intros_symmetry =
    --Eduardo (19/8/97)
 *)
 
+let setoid_transitivity = ref (fun _ _ -> assert false)
+let register_setoid_transitivity f = setoid_transitivity := f
+
 let transitivity t gl =
   match match_with_equation (pf_concl gl) with
-    | None -> error "The conclusion is not a substitutive equation" 
+    | None -> !setoid_transitivity t gl
     | Some (hdcncl,args) -> 
         let hdcncls = string_of_inductive hdcncl in
         begin
@@ -1886,7 +2449,48 @@ let interpretable_as_section_decl d1 d2 = match d1,d2 with
   | (_,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,push_named_context_val d s2)
+	else (add_named_decl d s1,s2)) 
+      global_sign (empty_named_context,empty_named_context_val) 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
+      error "\"abstract\" cannot handle existentials";
+    let lemme =
+      start_proof na (Global, 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 -> 
+	  (delete_current_proof(); raise e)
+      in   (* Faudrait un peu fonctionnaliser cela *)
+      let cd = Entries.DefinitionEntry const in
+      let con = Declare.declare_internal_constant na (cd,IsProof Lemma) in
+	constr_of_global (ConstRef con)
+    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
+
+
+let admit_as_an_axiom gls =
   let current_sign = Global.named_context()
   and global_sign = pf_hyps gls in
   let sign,secsign = 
@@ -1897,34 +2501,16 @@ let abstract_subproof name tac gls =
          then (s1,add_named_decl d s2)
 	 else (add_named_decl d s1,s2)) 
       global_sign (empty_named_context,empty_named_context) in
+  let name = add_suffix (get_current_proof_name ()) "_admitted" 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))
+  if occur_existential concl then error "\"admit\" cannot handle existentials";
+  let axiom =
+    let cd = Entries.ParameterEntry concl in
+    let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in
+    constr_of_global (ConstRef con)
   in
   exact_no_check 
-    (applist (lemme, 
+    (applist (axiom, 
               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
index 1155d845..aece3231 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: tactics.mli,v 1.59.2.2 2005/01/21 16:41:52 herbelin Exp $ i*)
+(*i $Id: tactics.mli 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 (*i*)
 open Names
@@ -19,7 +19,7 @@ open Reduction
 open Evd
 open Evar_refiner
 open Clenv
-open Tacred
+open Redexpr
 open Tacticals
 open Libnames
 open Genarg
@@ -32,7 +32,7 @@ open Rawterm
 
 (*s General functions. *)
 
-val type_clenv_binding : named_context sigma ->
+val type_clenv_binding : goal sigma ->
   constr * constr -> constr bindings  -> constr
 
 val string_of_inductive : constr -> string
@@ -46,7 +46,7 @@ exception Bound
 
 val introduction    : identifier -> tactic
 val refine          : constr -> tactic
-val convert_concl   : constr -> tactic
+val convert_concl   : constr -> cast_kind -> tactic
 val convert_hyp     : named_declaration -> tactic
 val thin            : identifier list -> tactic
 val mutual_fix      :
@@ -58,11 +58,15 @@ val cofix           : identifier option -> tactic
 (*s Introduction tactics. *)
 
 val fresh_id : identifier list -> identifier -> goal sigma -> identifier
+val find_intro_names : rel_context -> goal sigma -> identifier list
 
 val intro                : tactic
 val introf               : tactic
 val intro_force          : bool -> tactic
 val intro_move           : identifier option -> identifier option -> tactic
+  (* [intro_avoiding idl] acts as intro but prevents the new identifier
+     to belong to [idl] *)
+val intro_avoiding       : identifier list -> tactic
 
 val intro_replacing      : identifier -> tactic
 val intro_using          : identifier -> tactic
@@ -102,6 +106,7 @@ val intros_pattern    : identifier option -> intro_pattern_expr list -> tactic
 
 val assumption       : tactic
 val exact_no_check   : constr -> tactic
+val vm_cast_no_check : constr -> tactic
 val exact_check      : constr -> tactic
 val exact_proof      : Topconstr.constr_expr -> tactic
 
@@ -110,10 +115,10 @@ val exact_proof      : Topconstr.constr_expr -> tactic
 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 ->
+val reduct_option     : tactic_reduction * cast_kind -> simple_clause -> tactic
+val reduct_in_concl   : tactic_reduction * cast_kind -> tactic
+val change_in_concl   : (int list * constr) option -> constr -> tactic
+val change_in_hyp     : (int list * constr) option -> constr -> hyp_location ->
   tactic
 val red_in_concl      : tactic
 val red_in_hyp        : hyp_location        -> tactic
@@ -124,9 +129,10 @@ 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_concl : tactic
 val normalise_in_hyp  : hyp_location        -> tactic
 val normalise_option  : simple_clause -> tactic
+val normalise_vm_in_concl : 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
@@ -135,7 +141,7 @@ val unfold_option     :
     -> tactic
 val reduce            : red_expr -> clause -> tactic
 val change            :
-  constr occurrences option -> constr -> clause -> tactic
+  (int list * constr) option -> constr -> clause -> tactic
 
 val unfold_constr     : global_reference -> tactic
 val pattern_option  : (int list * constr) list -> simple_clause -> tactic
@@ -144,6 +150,7 @@ val pattern_option  : (int list * constr) list -> simple_clause -> tactic
 
 val clear         : identifier list -> tactic
 val clear_body    : identifier list -> tactic
+val keep          : identifier list -> tactic
 
 val new_hyp       : int option -> constr with_bindings -> tactic
 
@@ -163,23 +170,71 @@ val apply_with_bindings   : constr with_bindings -> tactic
 
 val cut_and_apply         : constr -> tactic
 
+val apply_in              : identifier -> constr with_bindings list -> tactic
+
 (*s Elimination tactics. *)
 
-val general_elim  : constr with_bindings -> constr with_bindings -> 
-  ?allow_K:bool -> tactic
+
+(*
+   The general form of an induction principle is the following:
+   
+   forall prm1 prm2 ... prmp,                          (induction parameters)
+   forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates)
+   branch1, branch2, ... , branchr,                    (branches of the principle)
+   forall (x1:Ti_1) (x2:Ti_2) ... (xni:Ti_ni),         (induction arguments)
+   (HI: I prm1..prmp x1...xni)                         (optional main induction arg)
+   -> (Qi x1...xni HI        (f prm1...prmp x1...xni)).(conclusion)
+                   ^^        ^^^^^^^^^^^^^^^^^^^^^^^^
+               optional                optional
+               even if HI      argument added if principle
+             present above   generated by functional induction
+             [indarg]          [farg]
+
+  HI is not present when the induction principle does not come directly from an
+  inductive type (like when it is generated by functional induction for
+  example). HI is present otherwise BUT may not appear in the conclusion
+  (dependent principle). HI and (f...) cannot be both present.
+
+  Principles taken from functional induction have the final (f...).
+*)
+
+(* [rel_contexts] and [rel_declaration] actually contain triples, and
+   lists are actually in reverse order to fit [compose_prod]. *)
+type elim_scheme = { 
+  elimc: (Term.constr * constr Rawterm.bindings) option;
+  elimt: types;
+  indref: global_reference option;
+  params: rel_context;     (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
+  nparams: int;            (* number of parameters *)
+  predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
+  npredicates: int;        (* Number of predicates *)
+  branches: rel_context;   (* branchr,...,branch1 *)
+  nbranches: int;          (* Number of branches *) 
+  args: rel_context;       (* (xni, Ti_ni) ... (x1, Ti_1) *)
+  nargs: int;              (* number of arguments *)
+  indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) 
+				     if HI is in premisses, None otherwise *)
+  concl: types;            (* Qi x1...xni HI (f...), HI and (f...) 
+			      are optional and mutually exclusive *)
+  indarg_in_concl: bool;   (* true if HI appears at the end of conclusion *)
+  farg_in_concl: bool;     (* true if (f...) appears at the end of conclusion *)
+}
+
+
+val compute_elim_sig : ?elimc: (Term.constr * constr Rawterm.bindings) -> types -> elim_scheme
+
+val general_elim  :
+  constr with_bindings -> constr with_bindings -> ?allow_K:bool -> tactic
+val general_elim_in :
+  identifier -> constr with_bindings -> constr with_bindings -> 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 -> 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
+val new_induct : constr induction_arg list -> constr with_bindings option ->
+  intro_pattern_expr -> tactic
 
 (*s Case analysis tactics. *)
 
@@ -187,9 +242,8 @@ 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
+val new_destruct : constr induction_arg list -> constr with_bindings option ->
+  intro_pattern_expr -> tactic
 
 (*s Eliminations giving the type instead of the proof. *)
 
@@ -221,26 +275,36 @@ val simplest_split             : tactic
 
 (*s Logical connective tactics. *)
 
+val register_setoid_reflexivity : tactic -> unit
 val reflexivity                 : tactic
 val intros_reflexivity          : tactic
 
+val register_setoid_symmetry : tactic -> unit
 val symmetry                    : tactic
+val register_setoid_symmetry_in : (identifier -> tactic) -> unit
 val symmetry_in                 : identifier -> tactic
 val intros_symmetry             : clause -> tactic
 
+val register_setoid_transitivity : (constr -> tactic) -> unit
 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_replacing               : 
+  identifier -> constr -> (tactic -> tactic) -> tactic
 val cut_in_parallel             : constr list -> tactic
 
-val assert_tac                  : bool -> name -> constr -> tactic
+val assert_as : bool -> intro_pattern_expr -> constr -> tactic
+val forward   : tactic option -> intro_pattern_expr -> constr -> tactic
+
 val true_cut                    : name -> constr -> tactic
 val letin_tac                   : bool -> name -> constr -> clause -> tactic
-val forward                     : bool -> name -> constr -> tactic
+val assert_tac                  : bool -> name -> constr -> tactic
 val generalize                  : constr list -> tactic
 val generalize_dep              : constr  -> tactic
 
 val tclABSTRACT : identifier option -> tactic -> tactic
+
+val admit_as_an_axiom : tactic
+
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index 553acc91..c91038fc 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -8,10 +8,8 @@
 
 (*i camlp4deps: "parsing/grammar.cma" i*)
 
-(*i $Id: tauto.ml4,v 1.62.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+(*i $Id: tauto.ml4 7732 2005-12-26 13:51:24Z herbelin $ i*)
 
-open Ast
-open Coqast
 open Hipattern
 open Names
 open Libnames
@@ -171,39 +169,11 @@ let tauto g =
 
 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 ]
+TACTIC EXTEND tauto
+| [ "tauto" ] -> [ tauto ]
 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]
+
+TACTIC EXTEND intuition
+| [ "intuition" ] -> [ intuition_gen default_intuition_tac ]
+| [ "intuition" tactic(t) ] -> [ intuition_gen (snd t) ]
 END
-*)
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
index 9e77ddbd..65ad1dee 100644
--- a/tactics/termdn.ml
+++ b/tactics/termdn.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: termdn.ml,v 1.15.8.1 2004/07/16 19:30:56 herbelin Exp $ *)
+(* $Id: termdn.ml 7639 2005-12-02 10:01:15Z gregoire $ *)
 
 open Util
 open Names
@@ -21,14 +21,14 @@ open Nametab
    See the module dn.ml for further explanations.
    Eduardo (5/8/97) *)
 
-type 'a t = (constr_label,constr_pattern,'a) Dn.t
+type 'a t = (global_reference,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
+    | Cast (c1,_,_) -> decrec acc c1
     | _ -> (c,acc)
   in 
   decrec []
@@ -45,19 +45,18 @@ let constr_pat_discr t =
     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)
+      | PRef ((IndRef _) as ref), args
+      | PRef ((ConstructRef _ ) as ref), args
+      | PRef ((VarRef _) as ref), args -> Some(ref,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)
+    | Ind ind_sp -> Some(IndRef ind_sp,l)
+    | Construct cstr_sp -> Some(ConstructRef cstr_sp,l)
+    | Var id -> Some(VarRef id,l)
     | _ -> None
 
 (* Les deux fonctions suivantes ecrasaient les precedentes, 
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
index e3caf6d9..b65c0eeb 100644
--- a/tactics/termdn.mli
+++ b/tactics/termdn.mli
@@ -6,11 +6,12 @@
 (*         *       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 $Id: termdn.mli 6427 2004-12-07 17:41:10Z sacerdot $ i*)
 
 (*i*)
 open Term
 open Pattern
+open Libnames
 (*i*)
   
 (* Discrimination nets of terms. *)
@@ -44,8 +45,8 @@ val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit
 (* These are for Nbtermdn *)
 
 val constr_pat_discr : 
-  constr_pattern -> (constr_label * constr_pattern list) option
+  constr_pattern -> (global_reference * constr_pattern list) option
 val constr_val_discr :
-  constr -> (constr_label * constr list) option
+  constr -> (global_reference * constr list) option
 
 (*i*)
diff --git a/test-suite/check b/test-suite/check
index fdc7b2d6..2f6738a0 100755
--- a/test-suite/check
+++ b/test-suite/check
@@ -3,16 +3,12 @@
 # Automatic test of Coq
 
 if [ "$1" = -byte ]; then
-  command7="../bin/coqtop.byte -translate -q -batch -load-vernac-source"
+  coqtop="../bin/coqtop.byte -q -batch"
 else
-  command7="../bin/coqtop -translate -q -batch -load-vernac-source"
+  coqtop="../bin/coqtop -q -batch"
 fi
 
-if [ "$1" = -byte ]; then
-  command="../bin/coqtop.byte -q -batch -load-vernac-source"
-else
-  command="../bin/coqtop -q -batch -load-vernac-source"
-fi
+command="$coqtop -top Top -load-vernac-source"
 
 # on compte le nombre de tests et de succès
 nbtests=0
@@ -24,34 +20,14 @@ test_success() {
     for f in $1/*.v; do 
 	nbtests=`expr $nbtests + 1`
 	printf "    "$f"..."
-	$command7 $f > /dev/null 2>&1
+	$command $f $2 > /dev/null 2>&1 
 	if [ $? = 0 ]; then
-            mv "$f"8 tmp8.v
-            $command tmp8.v > /dev/null 2>&1
-            if [ $? = 0 ]; then
-                echo "Ok"
-                nbtestsok=`expr $nbtestsok + 1`
-            else
-                echo "V8 Error! (should be accepted)"
-            fi
-            rm tmp8.v
+	    echo "Ok"
+	    nbtestsok=`expr $nbtestsok + 1`
         else 
-	    echo "V7 Error! (should be accepted)"
+	    echo "Error! (should be accepted)"
         fi 
     done
-    for f in $1/*.v8; do 
-	nbtests=`expr $nbtests + 1`
-	printf "    "$f"..."
-        cp $f tmp8.v
-	$command tmp8.v > /dev/null 2>&1
-        if [ $? = 0 ]; then
-            echo "Ok"
-            nbtestsok=`expr $nbtestsok + 1`
-        else
-            echo "V8 Error! (should be accepted)"
-        fi
-        rm tmp8.v
-    done
 }
 
 # La fonction suivante teste le compilateur sur des fichiers qu'il doit
@@ -60,7 +36,7 @@ test_failure() {
     for f in $1/*.v; do 
 	nbtests=`expr $nbtests + 1`
 	printf "    "$f"..."
-	$command7 $f > /dev/null 2>&1
+	$command $f > /dev/null 2>&1
 	if [ $? != 0 ]; then 
 	    echo "Ok"
 	    nbtestsok=`expr $nbtestsok + 1`
@@ -76,16 +52,16 @@ test_output() {
 	nbtests=`expr $nbtests + 1`
 	printf "    "$f"..."
         tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`
-	$command7 $f | tail +3 > $tmpoutput 2>&1
+	$command $f 2>&1 | grep -v "Welcome to Coq" | grep -v "Skipping rcfile loading" > $tmpoutput
         foutput=`dirname $f`/`basename $f .v`.out
-        diff $tmpoutput $foutput > /dev/null
+        diff $tmpoutput $foutput >& /dev/null
 	if [ $? = 0 ]; then 
 	    echo "Ok"
 	    nbtestsok=`expr $nbtestsok + 1`
         else 
 	    echo "Error! (unexpected output)"
-        fi
-	rm $tmpoutput
+        fi 
+        rm $tmpoutput
     done
 }
 
@@ -107,25 +83,83 @@ test_parser() {
             echo "Ok"
             nbtestsok=`expr $nbtestsok + 1`
         fi
-	rm $tmpoutput
+        rm $tmpoutput
     done
     fi
 }
 
+# La fonction suivante teste en interactif 
+test_interactive() {
+    for f in $1/*.v; do 
+	nbtests=`expr $nbtests + 1`
+	printf "    "$f"..."
+	$coqtop < $f > /dev/null 2>&1
+	if [ $? = 0 ]; then 
+	    echo "Ok"
+	    nbtestsok=`expr $nbtestsok + 1`
+        else 
+	    echo "Error! (should be accepted)"
+        fi 
+    done
+}
+
+# La fonction suivante teste en interactif 
+# It expects a line "(* Expected time < XXX.YYs *)" in the .v file 
+# with exactly two digits after the dot
+test_complexity() {
+    if [ -f /proc/cpuinfo ]; then
+        bogomips=`sed -n -e "s/bogomips.*: \([0-9]*\).*/\1/p" /proc/cpuinfo | head -1`
+    else
+        bogomips=6120 # assume a i386 3Gz
+    fi
+    for f in $1/*.v; do 
+	nbtests=`expr $nbtests + 1`
+	printf "    "$f"..."
+        # compute effective user time (get X seconds, or XX ds, or XXX cs)
+	res=`$command $f 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]\)\.\([0-9]*\)u.*)/\1\2/p" | head -1`
+	if [ $? != 0 ]; then
+ 	    echo "Error! (should be accepted)"
+        else
+          # express effective time in cenths of seconds
+	  n=`echo -n $res | wc -c`
+	  if [ $n = 2 ]; then res="$res"0;
+	  else if [ $n = 1 ]; then res="$res"00; fi
+	  fi
+          # find expected time * 100
+          exp=`sed -n -e "s/(\*.*Expected time < \([0-9]\).\([0-9][0-9]\)s.*\*)/\1\2/p" $f`
+          ok=`expr \( $res \* $bogomips \) "<" \( $exp \* 6120 \)`
+          if [ "$ok" = 1 ]; then
+              echo "Ok"
+              nbtestsok=`expr $nbtestsok + 1`
+          else
+              echo "Error! (should run faster)"
+          fi
+        fi
+    done
+}
+
 # Programme principal
 
-# echo "Output tests"
-# test_output output
-echo "[Output tests are off]"
 echo "Success tests"
 test_success success
 echo "Failure tests"
 test_failure failure
+echo "Output tests"
+test_output output
 echo "Parser tests"
 test_parser parser
+echo "Interactive tests"
+test_interactive interactive
+echo "Complexity tests"
+test_complexity complexity
+echo "Module tests"
+$coqtop -compile modules/Nat
+$coqtop -compile modules/plik
+test_success modules "-I modules -impredicative-set"
+
 pourcentage=`expr 100 \* $nbtestsok / $nbtests`
 echo
 echo "$nbtestsok tests passed over $nbtests, i.e. $pourcentage %"
 
-
-
+#echo "Ideal-features tests"
+#test_success ideal-features
diff --git a/test-suite/complexity/pretyping.v b/test-suite/complexity/pretyping.v
new file mode 100644
index 00000000..c271fb50
--- /dev/null
+++ b/test-suite/complexity/pretyping.v
@@ -0,0 +1,2660 @@
+(* Test parsing/interpretation/pretyping on a large example *)
+(* Expected time < 1.50s *)
+
+Require Import Reals.
+Require Import Ring_tac.
+
+Open Scope R_scope.
+
+Time Goal forall x1 x2 x3 y1 y2 y3 e1 e2 e3 e4 e5 e6 e7: R,
+(e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) *
+((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1) *
+((- (y1 - y2) * (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x1) -
+  e2 * y1 - e2 * y3) *
+ ((- (y1 - y2) * (e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x1) -
+   e2 * y1 - e2 * y3) * 1)) * e3 -
+(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) *
+((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) *
+((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) *
+ ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) *
+(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1) * e3 -
+(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) *
+((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) *
+((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) *
+ ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * x3 * e1 * e3 -
+(- (y2 - y3) * (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x2) -
+ e4 * y2 - e4 * y1) *
+((- (y2 - y3) * (e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x2) -
+  e4 * y2 - e4 * y1) * 1) *
+((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) *
+ ((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1)) * e1 +
+(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) *
+((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) *
+((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) *
+ ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) *
+(e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3) * e1 +
+(e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) *
+((e5 + e6 - 2 * y1 * y2 - x1 * e1 - x2 * e1 - e1 * x3) * 1) *
+((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) *
+ ((e6 + e7 - 2 * y2 * y3 - x2 * e3 - x3 * e3 - e3 * x1) * 1)) * x1 * e1 * e3 =
+3 * e1 * e6 ^ 4 * e7 + e1 * e6 ^ 2 * e7 ^ 3 + e3 * e6 ^ 4 * y1 ^ 2 +
+3 * e1 * e6 ^ 3 * e7 ^ 2 - 2 * e6 ^ 4 * x2 * e1 ^ 2 + 2 * e1 * e6 ^ 4 * e5 -
+2 * e3 * e6 ^ 4 * e7 - 2 * e6 ^ 4 * x1 * e1 ^ 2 + e1 ^ 3 * x3 ^ 2 * e6 ^ 3 -
+2 * e6 ^ 4 * e1 ^ 2 * x3 + x2 ^ 4 * e3 ^ 3 * y1 ^ 2 * e1 ^ 2 +
+x2 ^ 4 * e3 ^ 3 * y2 ^ 2 * e1 ^ 2 + x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 ^ 2 +
+x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 ^ 2 + 4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 4 * y2 ^ 2 +
+x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 ^ 2 + x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 ^ 2 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 4 * y2 ^ 2 + 4 * e3 ^ 3 * x1 ^ 4 * y1 ^ 2 * e1 ^ 2 +
+4 * e3 ^ 3 * x1 ^ 4 * y2 ^ 2 * e1 ^ 2 + e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 ^ 2 +
+e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 ^ 2 + 4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 4 * y2 ^ 2 +
+x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 ^ 2 + x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 ^ 2 +
+4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 4 + x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 ^ 2 +
+x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y3 ^ 2 + x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 ^ 2 +
+x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 ^ 2 + 4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 4 +
+x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 ^ 2 + x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y3 ^ 2 +
+e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 ^ 2 + e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 ^ 2 +
+4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y1 ^ 2 +
+e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y3 ^ 2 - 2 * e6 ^ 3 * x2 * e3 ^ 2 * y1 ^ 2 -
+2 * e6 ^ 3 * x3 * e3 ^ 2 * y1 ^ 2 - 2 * e6 ^ 3 * e3 ^ 2 * x1 * y1 ^ 2 -
+2 * e6 ^ 3 * x2 * e3 ^ 2 * y2 ^ 2 - 2 * e6 ^ 3 * x3 * e3 ^ 2 * y2 ^ 2 -
+2 * e6 ^ 3 * e3 ^ 2 * x1 * y2 ^ 2 + 2 * e3 * e6 ^ 3 * y1 ^ 2 * e5 -
+4 * e3 * e6 ^ 3 * y1 ^ 3 * y2 + 4 * e3 * e6 ^ 4 * y1 * y2 -
+4 * e3 * e6 ^ 3 * y1 ^ 2 * y2 ^ 2 + 2 * e3 * e6 ^ 3 * y1 ^ 2 * e2 +
+2 * e3 * e6 ^ 3 * y2 ^ 2 * e5 - 4 * e3 * e6 ^ 3 * y2 ^ 3 * y1 +
+e3 * e6 ^ 2 * y1 ^ 2 * e5 ^ 2 + 4 * e3 * e6 ^ 2 * y1 ^ 4 * y2 ^ 2 +
+2 * e3 * e6 ^ 3 * e7 * y1 ^ 2 + e3 * e7 ^ 2 * y1 ^ 2 * e5 ^ 2 +
+e3 * e7 ^ 2 * y1 ^ 2 * e6 ^ 2 + 4 * e3 * e7 ^ 2 * y1 ^ 4 * y2 ^ 2 +
+16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 4 + e3 * e6 ^ 2 * y2 ^ 2 * e5 ^ 2 +
+4 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 * e6 ^ 2 * e2 ^ 2 * y1 ^ 2 +
+e3 * e6 ^ 2 * e2 ^ 2 * y3 ^ 2 + 2 * e3 * e6 ^ 3 * e7 * y2 ^ 2 +
+e3 * e7 ^ 2 * y2 ^ 2 * e5 ^ 2 + e3 * e7 ^ 2 * y2 ^ 2 * e6 ^ 2 +
+x1 ^ 2 * e1 ^ 3 * e6 ^ 3 + x2 ^ 2 * e1 ^ 3 * e6 ^ 3 + e1 * e5 ^ 2 * e7 ^ 3 +
+e3 * e6 ^ 4 * y2 ^ 2 - 24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 -
+8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 +
+32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 * e6 +
+8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e5 * e2 -
+24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 -
+8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e6 * e1 +
+16 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * e1 +
+8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e6 * e2 +
+48 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * x1 * e1 -
+16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 +
+24 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 -
+16 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e2 +
+8 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e6 -
+16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e5 +
+16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 ^ 2 -
+16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 +
+8 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 -
+16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e6 +
+16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e6 ^ 2 -
+16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 +
+16 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * e2 -
+16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 ^ 3 * e2 +
+32 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+4 * y2 * y3 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 +
+8 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 * e6 -
+16 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * e5 * y1 -
+16 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * e6 * y1 +
+16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e2 +
+32 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+4 * y2 ^ 3 * y3 * x2 ^ 3 * e3 ^ 2 * e1 ^ 2 +
+8 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * e2 ^ 2 * y1 +
+4 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 +
+4 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 +
+16 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * y1 ^ 4 -
+16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 -
+8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 +
+32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * e6 +
+8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e5 * e2 -
+16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 -
+8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 +
+8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e6 * e2 +
+32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * x1 * e1 +
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * x2 * e1 -
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 +
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 -
+16 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e2 +
+8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e6 -
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e5 +
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 ^ 2 -
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 +
+8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 -
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e6 +
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 ^ 2 -
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 +
+16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * e2 -
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 ^ 3 * e2 +
+16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * e6 -
+16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * e5 * y1 -
+16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * e6 * y1 +
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e2 +
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * e2 ^ 2 * y1 +
+4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 +
+4 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 +
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * y1 ^ 4 -
+16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 +
+32 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e5 * e6 +
+8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e5 * e2 -
+16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e6 * e1 +
+8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e6 * e2 +
+32 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * e1 -
+8 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 -
+16 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e2 +
+8 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e6 -
+16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e5 +
+16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e5 ^ 2 -
+16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 +
+8 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 -
+16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e6 +
+16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 * e6 ^ 2 -
+16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 +
+16 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * e2 -
+16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 ^ 3 * e2 +
+16 * y2 * y3 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 +
+20 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+8 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e5 * e6 -
+16 * y2 ^ 4 * y3 * e3 ^ 2 * x1 * e5 * y1 -
+16 * y2 ^ 4 * y3 * e3 ^ 2 * x1 * e6 * y1 +
+16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e2 +
+16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 3 * e1 ^ 2 +
+20 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * x2 ^ 2 * e1 ^ 2 +
+8 * y2 * y3 ^ 2 * e3 ^ 2 * x1 * e2 ^ 2 * y1 +
+4 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 +
+4 * y2 * y3 * e3 ^ 2 * x1 * y1 ^ 2 * e6 ^ 2 +
+16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * y1 ^ 4 -
+8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x1 * e1 -
+2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e5 * e1 +
+8 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * e6 +
+2 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * e2 * y3 -
+8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x1 * e1 -
+2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e6 * e1 +
+2 * x2 ^ 2 * e3 ^ 3 * y1 * e6 * e2 * y3 +
+16 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x1 * e1 +
+4 * x2 ^ 3 * e3 ^ 3 * y1 ^ 3 * y2 * e1 -
+4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 * e2 * y3 +
+2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e6 -
+4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * e5 * y2 +
+4 * x2 ^ 2 * e3 ^ 3 * y1 * e5 ^ 2 * y2 -
+4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * y2 ^ 2 +
+2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e2 -
+4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * e6 * y2 +
+4 * x2 ^ 2 * e3 ^ 3 * y1 * e6 ^ 2 * y2 -
+4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * y2 ^ 2 +
+2 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * e2 -
+4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * e2 +
+13 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+2 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * e6 -
+4 * x2 ^ 2 * e3 ^ 3 * y2 ^ 3 * e5 * y1 -
+4 * x2 ^ 2 * e3 ^ 3 * y2 ^ 3 * e6 * y1 +
+4 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 2 * e2 +
+13 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+2 * x2 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 * y3 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x1 * e1 -
+2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * x2 * e1 +
+8 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * e6 +
+2 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * e2 * y3 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x1 * e1 -
+2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * x2 * e1 +
+2 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * e2 * y3 +
+8 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x1 * e1 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * x2 * e1 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 * e2 * y3 +
+2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e6 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * e5 * y2 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 * e5 ^ 2 * y2 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * y2 ^ 2 +
+2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e5 * e2 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * e6 * y2 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 * e6 ^ 2 * y2 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * y2 ^ 2 +
+2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * e6 * e2 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 3 * y2 * e2 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * e6 -
+4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 3 * e5 * y1 -
+4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 3 * e6 * y1 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * y2 ^ 2 * e2 +
+4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+2 * x3 ^ 2 * e3 ^ 3 * e2 ^ 2 * y1 * y3 -
+4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e5 * e1 -
+10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * x2 * e1 +
+8 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * e6 +
+2 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * e2 * y3 -
+4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e6 * e1 -
+10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * x2 * e1 +
+2 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * e2 * y3 +
+8 * e3 ^ 3 * x1 ^ 3 * y1 ^ 3 * y2 * e1 +
+20 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * x2 * e1 -
+4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 * e2 * y3 +
+2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e6 -
+4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * e5 * y2 +
+4 * e3 ^ 3 * x1 ^ 2 * y1 * e5 ^ 2 * y2 -
+4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 +
+2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e2 -
+4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * e6 * y2 +
+4 * e3 ^ 3 * x1 ^ 2 * y1 * e6 ^ 2 * y2 -
+4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 +
+2 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * e2 -
+4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * e2 +
+2 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * e6 -
+4 * e3 ^ 3 * x1 ^ 2 * y2 ^ 3 * e5 * y1 -
+4 * e3 ^ 3 * x1 ^ 2 * y2 ^ 3 * e6 * y1 +
+4 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 +
+2 * e3 ^ 3 * x1 ^ 2 * e2 ^ 2 * y1 * y3 +
+4 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 ^ 2 +
+4 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e6 ^ 2 +
+16 * y2 ^ 5 * y3 * x2 * e3 ^ 2 * y1 ^ 2 +
+4 * y2 * y3 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 +
+4 * y2 * y3 ^ 3 * x2 * e3 ^ 2 * e2 ^ 2 -
+32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e5 * x1 * e1 -
+40 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * e1 -
+32 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 * e6 * x1 * e1 -
+40 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e6 * e1 -
+24 * y2 * y3 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 +
+24 * y2 ^ 2 * y3 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 -
+8 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 -
+24 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e5 * x1 * e1 -
+8 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * e5 * e1 -
+8 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * e5 * e2 * y1 -
+8 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * e5 * e2 -
+24 * y2 ^ 3 * y3 * x2 * e3 ^ 2 * e6 * x1 * e1 -
+8 * y2 ^ 3 * y3 * x2 ^ 2 * e3 ^ 2 * e6 * e1 -
+16 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * e6 * e2 * y1 -
+8 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * e6 * e2 +
+48 * y2 ^ 4 * y3 * x2 * e3 ^ 2 * y1 * x1 * e1 +
+16 * y2 ^ 4 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * e1 +
+16 * y2 ^ 3 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * e2 +
+24 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 -
+24 * y2 * y3 ^ 2 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 -
+8 * y2 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 +
+24 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * x1 * e1 * e2 * y1 +
+24 * y2 ^ 2 * y3 ^ 2 * x2 * e3 ^ 2 * x1 * e1 * e2 +
+8 * y2 ^ 2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 * e2 * y1 +
+8 * y2 ^ 2 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 * e2 +
+4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 ^ 2 +
+4 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 ^ 2 +
+16 * y2 ^ 5 * y3 * x3 * e3 ^ 2 * y1 ^ 2 +
+4 * y2 * y3 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 +
+4 * y2 * y3 ^ 3 * x3 * e3 ^ 2 * e2 ^ 2 -
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * x1 * e1 -
+32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e5 * x2 * e1 -
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 * x1 * e1 -
+32 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * e6 * x2 * e1 +
+16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 -
+16 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 +
+24 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 -
+8 * y2 * y3 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 -
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * x1 * e1 -
+8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e5 * x2 * e1 -
+8 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * e5 * e2 * y1 -
+8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * e5 * e2 -
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 * x1 * e1 -
+8 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * e6 * x2 * e1 -
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * e6 * e2 * y1 -
+8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * e6 * e2 +
+32 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * y1 * x1 * e1 +
+16 * y2 ^ 4 * y3 * x3 * e3 ^ 2 * y1 * x2 * e1 +
+16 * y2 ^ 3 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * e2 +
+16 * y2 ^ 3 * y3 * x3 * e3 ^ 2 * x1 * e1 ^ 2 * x2 -
+16 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 -
+8 * y2 * y3 ^ 2 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 +
+16 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * x1 * e1 * e2 * y1 +
+16 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * x1 * e1 * e2 +
+8 * y2 ^ 2 * y3 * x3 * e3 ^ 2 * x2 * e1 * e2 * y1 +
+8 * y2 ^ 2 * y3 ^ 2 * x3 * e3 ^ 2 * x2 * e1 * e2 +
+4 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e5 ^ 2 +
+4 * y2 ^ 3 * y3 * e3 ^ 2 * x1 * e6 ^ 2 +
+16 * y2 ^ 5 * y3 * e3 ^ 2 * x1 * y1 ^ 2 +
+4 * y2 * y3 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 +
+4 * y2 * y3 ^ 3 * e3 ^ 2 * x1 * e2 ^ 2 -
+24 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * e1 -
+24 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e6 * e1 -
+16 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 -
+16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * e5 * e1 -
+8 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * e5 * e2 * y1 -
+8 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * e5 * e2 -
+16 * y2 ^ 3 * y3 * e3 ^ 2 * x1 ^ 2 * e6 * e1 -
+16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * e6 * e2 * y1 -
+8 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 * e6 * e2 +
+32 * y2 ^ 4 * y3 * e3 ^ 2 * x1 ^ 2 * y1 * e1 +
+16 * y2 ^ 3 * y3 ^ 2 * e3 ^ 2 * x1 * y1 * e2 -
+16 * y2 * y3 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 +
+16 * y2 ^ 2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 * e2 * y1 +
+16 * y2 ^ 2 * y3 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 * e2 -
+16 * x2 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x1 * e1 -
+4 * x2 ^ 3 * e3 ^ 3 * y1 * e5 * y2 * e1 -
+16 * x2 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x1 * e1 -
+4 * x2 ^ 3 * e3 ^ 3 * y1 * e6 * y2 * e1 +
+6 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * x1 * e1 ^ 2 +
+10 * x2 ^ 2 * e3 ^ 3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 -
+8 * x2 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 * e2 -
+2 * x2 ^ 3 * e3 ^ 3 * y1 ^ 2 * e1 * e2 -
+8 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x1 * e1 -
+2 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * e5 * e1 -
+2 * x2 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y1 -
+2 * x2 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y3 -
+8 * x2 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x1 * e1 -
+2 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * e6 * e1 -
+2 * x2 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y1 -
+2 * x2 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y3 +
+16 * x2 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x1 * e1 +
+4 * x2 ^ 3 * e3 ^ 3 * y1 * y2 ^ 3 * e1 +
+4 * x2 ^ 2 * e3 ^ 3 * y1 * y2 ^ 2 * e2 * y3 +
+6 * x2 ^ 3 * e3 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 +
+4 * x2 ^ 3 * e3 ^ 3 * y1 * x1 * e1 ^ 2 * y2 -
+8 * x2 ^ 2 * e3 ^ 3 * y1 * x1 * e1 * e2 * y3 -
+2 * x2 ^ 3 * e3 ^ 3 * y1 * e1 * e2 * y3 +
+8 * x2 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y1 +
+8 * x2 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y3 +
+2 * x2 ^ 3 * e3 ^ 3 * y2 * e1 * e2 * y1 +
+2 * x2 ^ 3 * e3 ^ 3 * y2 * e1 * e2 * y3 -
+8 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x1 * e1 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 * e5 * y2 * x2 * e1 -
+8 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x1 * e1 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 * e6 * y2 * x2 * e1 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x1 * e1 * e2 -
+14 * x3 ^ 2 * e3 ^ 3 * y1 * x2 ^ 2 * e1 ^ 2 * y2 -
+2 * x3 ^ 2 * e3 ^ 3 * y1 ^ 2 * x2 * e1 * e2 -
+4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x1 * e1 -
+2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e5 * x2 * e1 -
+2 * x3 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y1 -
+2 * x3 ^ 2 * e3 ^ 3 * y2 * e5 * e2 * y3 -
+4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x1 * e1 -
+2 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * e6 * x2 * e1 -
+2 * x3 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y1 -
+2 * x3 ^ 2 * e3 ^ 3 * y2 * e6 * e2 * y3 +
+8 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x1 * e1 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 3 * x2 * e1 +
+4 * x3 ^ 2 * e3 ^ 3 * y1 * y2 ^ 2 * e2 * y3 +
+4 * x3 ^ 2 * e3 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 * x2 -
+8 * x3 ^ 2 * e3 ^ 3 * y1 * x1 * e1 ^ 2 * y2 * x2 -
+4 * x3 ^ 2 * e3 ^ 3 * y1 * x1 * e1 * e2 * y3 -
+2 * x3 ^ 2 * e3 ^ 3 * y1 * x2 * e1 * e2 * y3 +
+4 * x3 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y1 +
+4 * x3 ^ 2 * e3 ^ 3 * y2 * x1 * e1 * e2 * y3 +
+2 * x3 ^ 2 * e3 ^ 3 * y2 * x2 * e1 * e2 * y1 +
+2 * x3 ^ 2 * e3 ^ 3 * y2 * x2 * e1 * e2 * y3 -
+8 * e3 ^ 3 * x1 ^ 3 * y1 * e5 * y2 * e1 -
+20 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * x2 * e1 -
+8 * e3 ^ 3 * x1 ^ 3 * y1 * e6 * y2 * e1 -
+20 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * y2 * x2 * e1 +
+12 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 * x2 +
+2 * e3 ^ 3 * x1 ^ 4 * y1 * e1 ^ 2 * y2 -
+4 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 * e2 -
+10 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * x2 * e1 * e2 -
+4 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e5 * e1 -
+10 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * x2 * e1 -
+2 * e3 ^ 3 * x1 ^ 2 * y2 * e5 * e2 * y1 -
+2 * e3 ^ 3 * x1 ^ 2 * y2 * e5 * e2 * y3 -
+4 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e6 * e1 -
+10 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 * x2 * e1 -
+2 * e3 ^ 3 * x1 ^ 2 * y2 * e6 * e2 * y1 -
+2 * e3 ^ 3 * x1 ^ 2 * y2 * e6 * e2 * y3 +
+8 * e3 ^ 3 * x1 ^ 3 * y1 * y2 ^ 3 * e1 +
+20 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 3 * x2 * e1 +
+4 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 2 * e2 * y3 +
+12 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 * x2 +
+8 * e3 ^ 3 * x1 ^ 3 * y1 * e1 ^ 2 * y2 * x2 -
+4 * e3 ^ 3 * x1 ^ 3 * y1 * e1 * e2 * y3 -
+10 * e3 ^ 3 * x1 ^ 2 * y1 * x2 * e1 * e2 * y3 +
+4 * e3 ^ 3 * x1 ^ 3 * y2 * e1 * e2 * y1 +
+4 * e3 ^ 3 * x1 ^ 3 * y2 * e1 * e2 * y3 +
+10 * e3 ^ 3 * x1 ^ 2 * y2 * x2 * e1 * e2 * y1 +
+10 * e3 ^ 3 * x1 ^ 2 * y2 * x2 * e1 * e2 * y3 +
+2 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 ^ 2 -
+12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * x1 * e1 -
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e1 +
+16 * x2 * e3 ^ 3 * x3 * y1 * e5 * y2 * e6 +
+4 * x2 * e3 ^ 3 * x3 * y1 * e5 * e2 * y3 -
+12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * x1 * e1 -
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * e1 +
+4 * x2 * e3 ^ 3 * x3 * y1 * e6 * e2 * y3 +
+24 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * x1 * e1 +
+8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * e1 -
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 * e2 * y3 +
+4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e6 -
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * e5 * y2 +
+8 * x2 * e3 ^ 3 * x3 * y1 * e5 ^ 2 * y2 -
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * y2 ^ 2 +
+4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 * e2 -
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * e6 * y2 +
+8 * x2 * e3 ^ 3 * x3 * y1 * e6 ^ 2 * y2 -
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * y2 ^ 2 +
+4 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 * e2 -
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 3 * y2 * e2 +
+16 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+2 * x2 ^ 3 * e3 ^ 3 * x3 * y1 ^ 2 * e1 ^ 2 +
+4 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * e6 -
+8 * x2 * e3 ^ 3 * x3 * y2 ^ 3 * e5 * y1 -
+8 * x2 * e3 ^ 3 * x3 * y2 ^ 3 * e6 * y1 +
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 ^ 2 * e2 +
+16 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+2 * x2 ^ 3 * e3 ^ 3 * x3 * y2 ^ 2 * e1 ^ 2 +
+4 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y1 * y3 +
+2 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e5 ^ 2 +
+2 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * e6 ^ 2 +
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 4 * y2 ^ 2 +
+16 * x2 * e3 ^ 3 * x1 * y1 * e5 * y2 * e6 +
+4 * x2 * e3 ^ 3 * x1 * y1 * e5 * e2 * y3 +
+4 * x2 * e3 ^ 3 * x1 * y1 * e6 * e2 * y3 -
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 * e2 * y3 +
+4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e6 -
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * e5 * y2 +
+8 * x2 * e3 ^ 3 * x1 * y1 * e5 ^ 2 * y2 -
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * y2 ^ 2 +
+4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e2 -
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * e6 * y2 +
+8 * x2 * e3 ^ 3 * x1 * y1 * e6 ^ 2 * y2 -
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * y2 ^ 2 +
+4 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * e2 -
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 3 * y2 * e2 +
+4 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e5 * e6 -
+8 * x2 * e3 ^ 3 * x1 * y2 ^ 3 * e5 * y1 -
+8 * x2 * e3 ^ 3 * x1 * y2 ^ 3 * e6 * y1 +
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 2 * e2 +
+4 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y1 * y3 +
+2 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e5 ^ 2 +
+2 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * e6 ^ 2 +
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 4 * y2 ^ 2 -
+8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e5 * e1 +
+16 * x3 * e3 ^ 3 * x1 * y1 * e5 * y2 * e6 +
+4 * x3 * e3 ^ 3 * x1 * y1 * e5 * e2 * y3 -
+8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e6 * e1 +
+4 * x3 * e3 ^ 3 * x1 * y1 * e6 * e2 * y3 +
+16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 3 * y2 * e1 -
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 * e2 * y3 +
+4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e6 -
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * e5 * y2 +
+8 * x3 * e3 ^ 3 * x1 * y1 * e5 ^ 2 * y2 -
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * y2 ^ 2 +
+4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 * e2 -
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * e6 * y2 +
+8 * x3 * e3 ^ 3 * x1 * y1 * e6 ^ 2 * y2 -
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * y2 ^ 2 +
+4 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 * e2 -
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 3 * y2 * e2 +
+8 * x3 * e3 ^ 3 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 +
+10 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+4 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e5 * e6 -
+8 * x3 * e3 ^ 3 * x1 * y2 ^ 3 * e5 * y1 -
+8 * x3 * e3 ^ 3 * x1 * y2 ^ 3 * e6 * y1 +
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 2 * e2 +
+8 * x3 * e3 ^ 3 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 +
+10 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+4 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y1 * y3 +
+2 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e5 ^ 2 +
+2 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * e6 ^ 2 +
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 4 * y2 ^ 2 +
+12 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 +
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 -
+16 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * e5 * y2 -
+4 * e6 * x2 * e3 ^ 2 * y1 * e5 * e2 * y3 +
+12 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 +
+4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 -
+4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * e2 * y3 -
+24 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 -
+8 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * y2 * e1 +
+8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 +
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 -
+4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e5 +
+8 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * e5 * y2 -
+8 * e6 * x2 * e3 ^ 2 * y1 * e5 ^ 2 * y2 +
+8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 -
+4 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 +
+8 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * x2 * e3 ^ 2 * y1 * y2 +
+8 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 -
+4 * e6 ^ 2 * x2 * e3 ^ 2 * y1 ^ 2 * e2 +
+8 * e6 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * e2 -
+16 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+2 * e6 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 -
+4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 2 * e5 +
+8 * e6 * x2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 +
+8 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 3 * y1 -
+8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 -
+16 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+6 * e6 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e1 ^ 2 -
+4 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y1 * y3 -
+2 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 -
+8 * e6 * x2 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 +
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 +
+4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 -
+16 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * e5 * y2 -
+4 * e6 * x3 * e3 ^ 2 * y1 * e5 * e2 * y3 +
+8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 +
+4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 -
+4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * e2 * y3 -
+16 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 -
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x2 * e1 +
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 +
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 -
+4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e5 +
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * e5 * y2 -
+8 * e6 * x3 * e3 ^ 2 * y1 * e5 ^ 2 * y2 +
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 -
+4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 +
+8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * x3 * e3 ^ 2 * y1 * y2 +
+8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 -
+4 * e6 ^ 2 * x3 * e3 ^ 2 * y1 ^ 2 * e2 +
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * e2 -
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+2 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 2 * e5 +
+8 * e6 * x3 * e3 ^ 2 * y2 ^ 3 * e5 * y1 +
+8 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 3 * y1 -
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 -
+8 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+14 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+4 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y1 * y3 -
+2 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 -
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 +
+8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 -
+16 * e6 ^ 2 * e3 ^ 2 * x1 * y1 * e5 * y2 -
+4 * e6 * e3 ^ 2 * x1 * y1 * e5 * e2 * y3 +
+8 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 -
+4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 * e2 * y3 -
+16 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * y2 * e1 +
+4 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 -
+4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e5 +
+8 * e6 * e3 ^ 2 * x1 * y1 ^ 3 * e5 * y2 -
+8 * e6 * e3 ^ 2 * x1 * y1 * e5 ^ 2 * y2 +
+8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * y2 ^ 2 -
+4 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 +
+8 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 3 * y2 - 8 * e6 ^ 3 * e3 ^ 2 * x1 * y1 * y2 +
+8 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 -
+4 * e6 ^ 2 * e3 ^ 2 * x1 * y1 ^ 2 * e2 +
+8 * e6 * e3 ^ 2 * x1 * y1 ^ 3 * y2 * e2 -
+8 * e6 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 -
+10 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 ^ 2 * e5 +
+8 * e6 * e3 ^ 2 * x1 * y2 ^ 3 * e5 * y1 +
+8 * e6 ^ 2 * e3 ^ 2 * x1 * y2 ^ 3 * y1 -
+8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 * e2 -
+8 * e6 * e3 ^ 2 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 -
+2 * e6 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+4 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y1 * y3 -
+2 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 -
+8 * e6 * e3 ^ 2 * x1 * y1 ^ 4 * y2 ^ 2 +
+12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e5 * e1 -
+16 * e7 * x2 * e3 ^ 2 * y1 * e5 * y2 * e6 -
+4 * e7 * x2 * e3 ^ 2 * y1 * e5 * e2 * y3 +
+12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e6 * e1 -
+4 * e7 * x2 * e3 ^ 2 * y1 * e6 * e2 * y3 -
+24 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 -
+8 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 3 * y2 * e1 +
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 +
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 * e2 * y3 -
+4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e6 +
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * e5 * y2 -
+8 * e7 * x2 * e3 ^ 2 * y1 * e5 ^ 2 * y2 +
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 -
+4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 * e2 +
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * e6 * y2 -
+8 * e7 * x2 * e3 ^ 2 * y1 * e6 ^ 2 * y2 +
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 -
+4 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 * e2 +
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 3 * y2 * e2 -
+16 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+2 * e7 * x2 ^ 3 * e3 ^ 2 * y1 ^ 2 * e1 ^ 2 -
+4 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * e6 +
+8 * e7 * x2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 +
+8 * e7 * x2 * e3 ^ 2 * y2 ^ 3 * e6 * y1 -
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 -
+16 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+2 * e7 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e1 ^ 2 -
+4 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y1 * y3 -
+2 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 -
+2 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 -
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 +
+4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 -
+16 * e7 * x3 * e3 ^ 2 * y1 * e5 * y2 * e6 -
+4 * e7 * x3 * e3 ^ 2 * y1 * e5 * e2 * y3 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 +
+4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 -
+4 * e7 * x3 * e3 ^ 2 * y1 * e6 * e2 * y3 -
+16 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x1 * e1 -
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * x2 * e1 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 * e2 * y3 -
+4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e6 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * e5 * y2 -
+8 * e7 * x3 * e3 ^ 2 * y1 * e5 ^ 2 * y2 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 -
+4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 * e2 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * e6 * y2 -
+8 * e7 * x3 * e3 ^ 2 * y1 * e6 ^ 2 * y2 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 -
+4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 * e2 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 3 * y2 * e2 -
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * e6 +
+8 * e7 * x3 * e3 ^ 2 * y2 ^ 3 * e5 * y1 +
+8 * e7 * x3 * e3 ^ 2 * y2 ^ 3 * e6 * y1 -
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 -
+8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+4 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y1 * y3 -
+2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e5 ^ 2 -
+2 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * e6 ^ 2 -
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 4 * y2 ^ 2 +
+8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e5 * e1 -
+16 * e7 * e3 ^ 2 * x1 * y1 * e5 * y2 * e6 -
+4 * e7 * e3 ^ 2 * x1 * y1 * e5 * e2 * y3 +
+8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e6 * e1 -
+4 * e7 * e3 ^ 2 * x1 * y1 * e6 * e2 * y3 -
+16 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 3 * y2 * e1 +
+4 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * y2 ^ 2 * e1 +
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 * e2 * y3 -
+4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e6 +
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * e5 * y2 -
+8 * e7 * e3 ^ 2 * x1 * y1 * e5 ^ 2 * y2 +
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * y2 ^ 2 -
+4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 * e2 +
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * e6 * y2 -
+8 * e7 * e3 ^ 2 * x1 * y1 * e6 ^ 2 * y2 +
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * y2 ^ 2 -
+4 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 * e2 +
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 3 * y2 * e2 -
+8 * e7 * e3 ^ 2 * x1 ^ 3 * y1 ^ 2 * e1 ^ 2 -
+10 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+4 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e5 * e6 +
+8 * e7 * e3 ^ 2 * x1 * y2 ^ 3 * e5 * y1 +
+8 * e7 * e3 ^ 2 * x1 * y2 ^ 3 * e6 * y1 -
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 2 * e2 -
+8 * e7 * e3 ^ 2 * x1 ^ 3 * y2 ^ 2 * e1 ^ 2 -
+10 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+4 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y1 * y3 -
+2 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e5 ^ 2 -
+2 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * e6 ^ 2 -
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 4 * y2 ^ 2 +
+2 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 ^ 2 +
+8 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * y2 ^ 4 +
+2 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y1 ^ 2 +
+2 * x2 * e3 ^ 3 * x3 * e2 ^ 2 * y3 ^ 2 -
+24 * x2 * e3 ^ 3 * x3 * y1 * e5 * y2 * x1 * e1 -
+8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e5 * y2 * e1 -
+24 * x2 * e3 ^ 3 * x3 * y1 * e6 * y2 * x1 * e1 -
+8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e6 * y2 * e1 +
+16 * x2 * e3 ^ 3 * x3 * y1 * x1 ^ 2 * e1 ^ 2 * y2 -
+12 * x2 * e3 ^ 3 * x3 * y1 ^ 2 * x1 * e1 * e2 -
+4 * x2 ^ 3 * e3 ^ 3 * x3 * y1 * e1 ^ 2 * y2 -
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 ^ 2 * e1 * e2 -
+12 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * x1 * e1 -
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 ^ 2 * e5 * e1 -
+4 * x2 * e3 ^ 3 * x3 * y2 * e5 * e2 * y1 -
+4 * x2 * e3 ^ 3 * x3 * y2 * e5 * e2 * y3 -
+12 * x2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 * x1 * e1 -
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 ^ 2 * e6 * e1 -
+4 * x2 * e3 ^ 3 * x3 * y2 * e6 * e2 * y1 -
+4 * x2 * e3 ^ 3 * x3 * y2 * e6 * e2 * y3 +
+24 * x2 * e3 ^ 3 * x3 * y1 * y2 ^ 3 * x1 * e1 +
+8 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * y2 ^ 3 * e1 +
+8 * x2 * e3 ^ 3 * x3 * y1 * y2 ^ 2 * e2 * y3 +
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * x1 * e1 ^ 2 * y2 -
+12 * x2 * e3 ^ 3 * x3 * y1 * x1 * e1 * e2 * y3 -
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y1 * e1 * e2 * y3 +
+12 * x2 * e3 ^ 3 * x3 * y2 * x1 * e1 * e2 * y1 +
+12 * x2 * e3 ^ 3 * x3 * y2 * x1 * e1 * e2 * y3 +
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 * e1 * e2 * y1 +
+4 * x2 ^ 2 * e3 ^ 3 * x3 * y2 * e1 * e2 * y3 +
+2 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e5 ^ 2 +
+2 * x2 * e3 ^ 3 * x1 * y2 ^ 2 * e6 ^ 2 +
+8 * x2 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 4 +
+2 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y1 ^ 2 +
+2 * x2 * e3 ^ 3 * x1 * e2 ^ 2 * y3 ^ 2 -
+4 * x2 * e3 ^ 3 * x1 * y2 * e5 * e2 * y1 -
+4 * x2 * e3 ^ 3 * x1 * y2 * e5 * e2 * y3 -
+4 * x2 * e3 ^ 3 * x1 * y2 * e6 * e2 * y1 -
+4 * x2 * e3 ^ 3 * x1 * y2 * e6 * e2 * y3 +
+8 * x2 * e3 ^ 3 * x1 * y1 * y2 ^ 2 * e2 * y3 +
+2 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e5 ^ 2 +
+2 * x3 * e3 ^ 3 * x1 * y2 ^ 2 * e6 ^ 2 +
+8 * x3 * e3 ^ 3 * x1 * y1 ^ 2 * y2 ^ 4 +
+2 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y1 ^ 2 +
+2 * x3 * e3 ^ 3 * x1 * e2 ^ 2 * y3 ^ 2 -
+16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e5 * y2 * e1 -
+16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e6 * y2 * e1 +
+8 * x3 * e3 ^ 3 * x1 ^ 3 * y1 * e1 ^ 2 * y2 -
+8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 ^ 2 * e1 * e2 -
+8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e5 * e1 -
+4 * x3 * e3 ^ 3 * x1 * y2 * e5 * e2 * y1 -
+4 * x3 * e3 ^ 3 * x1 * y2 * e5 * e2 * y3 -
+8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 ^ 2 * e6 * e1 -
+4 * x3 * e3 ^ 3 * x1 * y2 * e6 * e2 * y1 -
+4 * x3 * e3 ^ 3 * x1 * y2 * e6 * e2 * y3 +
+16 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * y2 ^ 3 * e1 +
+8 * x3 * e3 ^ 3 * x1 * y1 * y2 ^ 2 * e2 * y3 -
+8 * x3 * e3 ^ 3 * x1 ^ 2 * y1 * e1 * e2 * y3 +
+8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 * e1 * e2 * y1 +
+8 * x3 * e3 ^ 3 * x1 ^ 2 * y2 * e1 * e2 * y3 -
+2 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 -
+8 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 -
+2 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 -
+2 * e6 * x2 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 +
+16 * e6 * x2 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 +
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * y2 * e1 +
+16 * e6 ^ 2 * x2 * e3 ^ 2 * y1 * y2 * x1 * e1 +
+4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * e1 +
+12 * e6 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 +
+4 * e6 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 * y2 +
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 +
+12 * e6 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 -
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e1 +
+4 * e6 * x2 * e3 ^ 2 * y2 * e5 * e2 * y1 +
+4 * e6 * x2 * e3 ^ 2 * y2 * e5 * e2 * y3 +
+12 * e6 ^ 2 * x2 * e3 ^ 2 * y2 ^ 2 * x1 * e1 +
+4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 * e2 * y1 +
+4 * e6 ^ 2 * x2 * e3 ^ 2 * y2 * e2 * y3 -
+24 * e6 * x2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 +
+8 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * e1 +
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 +
+12 * e6 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 +
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 * y3 -
+12 * e6 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 -
+12 * e6 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 -
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y1 -
+4 * e6 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y3 -
+2 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 -
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 -
+2 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 -
+2 * e6 * x3 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 +
+8 * e6 * x3 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 +
+8 * e6 ^ 2 * x3 * e3 ^ 2 * y1 * y2 * x1 * e1 -
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 +
+8 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 +
+20 * e6 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 +
+4 * e6 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 +
+8 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 -
+4 * e6 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 +
+4 * e6 * x3 * e3 ^ 2 * y2 * e5 * e2 * y1 +
+4 * e6 * x3 * e3 ^ 2 * y2 * e5 * e2 * y3 +
+8 * e6 ^ 2 * x3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 +
+4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 * e2 * y1 +
+4 * e6 ^ 2 * x3 * e3 ^ 2 * y2 * e2 * y3 -
+16 * e6 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 +
+8 * e6 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 +
+16 * e6 * x3 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 +
+8 * e6 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 +
+4 * e6 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 * y3 -
+8 * e6 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 -
+8 * e6 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 -
+4 * e6 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y1 -
+4 * e6 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y3 -
+2 * e6 * e3 ^ 2 * x1 * y2 ^ 2 * e5 ^ 2 -
+8 * e6 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 4 -
+2 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 -
+2 * e6 * e3 ^ 2 * x1 * e2 ^ 2 * y3 ^ 2 +
+12 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * y2 * e1 +
+12 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y1 * y2 * e1 +
+8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 +
+8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e5 * e1 +
+4 * e6 * e3 ^ 2 * x1 * y2 * e5 * e2 * y1 +
+4 * e6 * e3 ^ 2 * x1 * y2 * e5 * e2 * y3 +
+8 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e1 +
+4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 * e2 * y1 +
+4 * e6 ^ 2 * e3 ^ 2 * x1 * y2 * e2 * y3 -
+16 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * y2 ^ 3 * e1 +
+8 * e6 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 * y3 -
+8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y1 -
+8 * e6 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y3 -
+2 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 -
+2 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 -
+8 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 -
+2 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 -
+2 * e7 * x2 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 +
+16 * e7 * x2 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e5 * y2 * e1 +
+16 * e7 * x2 * e3 ^ 2 * y1 * e6 * y2 * x1 * e1 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e6 * y2 * e1 +
+12 * e7 * x2 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 +
+4 * e7 * x2 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 * y2 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * e1 * e2 +
+12 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e1 +
+4 * e7 * x2 * e3 ^ 2 * y2 * e5 * e2 * y1 +
+4 * e7 * x2 * e3 ^ 2 * y2 * e5 * e2 * y3 +
+12 * e7 * x2 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * e1 +
+4 * e7 * x2 * e3 ^ 2 * y2 * e6 * e2 * y1 +
+4 * e7 * x2 * e3 ^ 2 * y2 * e6 * e2 * y3 -
+24 * e7 * x2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 -
+8 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * e1 -
+8 * e7 * x2 * e3 ^ 2 * y1 * y2 ^ 2 * e2 * y3 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 +
+12 * e7 * x2 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 +
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y1 * e1 * e2 * y3 -
+12 * e7 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 -
+12 * e7 * x2 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 -
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y1 -
+4 * e7 * x2 ^ 2 * e3 ^ 2 * y2 * e1 * e2 * y3 -
+2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 -
+2 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 -
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 -
+2 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y1 ^ 2 -
+2 * e7 * x3 * e3 ^ 2 * e2 ^ 2 * y3 ^ 2 +
+8 * e7 * x3 * e3 ^ 2 * y1 * e5 * y2 * x1 * e1 +
+8 * e7 * x3 * e3 ^ 2 * y1 * e6 * y2 * x1 * e1 -
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 +
+8 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 +
+20 * e7 * x3 * e3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 +
+4 * e7 * x3 * e3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 +
+8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 +
+4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 +
+4 * e7 * x3 * e3 ^ 2 * y2 * e5 * e2 * y1 +
+4 * e7 * x3 * e3 ^ 2 * y2 * e5 * e2 * y3 +
+8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 +
+4 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * e6 * x2 * e1 +
+4 * e7 * x3 * e3 ^ 2 * y2 * e6 * e2 * y1 +
+4 * e7 * x3 * e3 ^ 2 * y2 * e6 * e2 * y3 -
+16 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 -
+8 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 -
+8 * e7 * x3 * e3 ^ 2 * y1 * y2 ^ 2 * e2 * y3 -
+8 * e7 * x3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 +
+16 * e7 * x3 * e3 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 +
+8 * e7 * x3 * e3 ^ 2 * y1 * x1 * e1 * e2 * y3 +
+4 * e7 * x3 * e3 ^ 2 * y1 * x2 * e1 * e2 * y3 -
+8 * e7 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y1 -
+8 * e7 * x3 * e3 ^ 2 * y2 * x1 * e1 * e2 * y3 -
+4 * e7 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y1 -
+4 * e7 * x3 * e3 ^ 2 * y2 * x2 * e1 * e2 * y3 -
+2 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e5 ^ 2 -
+2 * e7 * e3 ^ 2 * x1 * y2 ^ 2 * e6 ^ 2 -
+8 * e7 * e3 ^ 2 * x1 * y1 ^ 2 * y2 ^ 4 -
+2 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y1 ^ 2 -
+2 * e7 * e3 ^ 2 * x1 * e2 ^ 2 * y3 ^ 2 +
+12 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e5 * y2 * e1 +
+12 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e6 * y2 * e1 +
+8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 ^ 2 * e1 * e2 +
+8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e5 * e1 +
+4 * e7 * e3 ^ 2 * x1 * y2 * e5 * e2 * y1 +
+4 * e7 * e3 ^ 2 * x1 * y2 * e5 * e2 * y3 +
+8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 ^ 2 * e6 * e1 +
+4 * e7 * e3 ^ 2 * x1 * y2 * e6 * e2 * y1 +
+4 * e7 * e3 ^ 2 * x1 * y2 * e6 * e2 * y3 -
+16 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * y2 ^ 3 * e1 -
+8 * e7 * e3 ^ 2 * x1 * y1 * y2 ^ 2 * e2 * y3 +
+8 * e7 * e3 ^ 2 * x1 ^ 2 * y1 * e1 * e2 * y3 -
+8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y1 -
+8 * e7 * e3 ^ 2 * x1 ^ 2 * y2 * e1 * e2 * y3 + 8 * e3 * e6 ^ 3 * y1 * e5 * y2 -
+4 * e3 * e6 ^ 3 * y1 ^ 2 * x1 * e1 - 2 * e3 * e6 ^ 3 * y1 ^ 2 * x2 * e1 +
+2 * e3 * e6 ^ 3 * y1 * e2 * y3 - 4 * e3 * e6 ^ 2 * y1 ^ 3 * e5 * y2 +
+x1 ^ 2 * e1 ^ 3 * e7 ^ 3 + 4 * e3 * e6 ^ 2 * y1 * e5 ^ 2 * y2 -
+4 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * e2 -
+4 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * e2 +
+4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+e3 * e6 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 - 4 * e3 * e6 ^ 2 * y2 ^ 3 * e5 * y1 +
+4 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 +
+4 * e3 * e6 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+7 * e3 * e6 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+2 * e3 * e6 ^ 2 * e2 ^ 2 * y1 * y3 + 4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * e5 -
+8 * e3 * e6 ^ 2 * e7 * y1 ^ 3 * y2 + 8 * e3 * e6 ^ 3 * e7 * y1 * y2 -
+8 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * y2 ^ 2 + 4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * e2 +
+4 * e3 * e6 ^ 2 * e7 * y2 ^ 2 * e5 - 8 * e3 * e6 ^ 2 * e7 * y2 ^ 3 * y1 +
+2 * e3 * e6 * e7 * y1 ^ 2 * e5 ^ 2 + 8 * e3 * e6 * e7 * y1 ^ 4 * y2 ^ 2 +
+2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * e6 - 4 * e3 * e7 ^ 2 * y1 ^ 3 * e5 * y2 +
+4 * e3 * e7 ^ 2 * y1 * e5 ^ 2 * y2 - 4 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * x1 * e1 -
+2 * e3 * e6 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 2 * e3 * e6 ^ 2 * y1 * e5 * e2 * y3 +
+8 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * x1 * e1 +
+4 * e3 * e6 ^ 2 * y1 ^ 3 * y2 * x2 * e1 -
+8 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 -
+8 * e3 * e6 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 -
+12 * e3 * e6 ^ 2 * y1 ^ 2 * y2 * e2 * y3 + e1 * e5 ^ 2 * e6 ^ 3 -
+8 * e3 * e6 * e7 * y1 ^ 2 * e5 * x1 * e1 -
+4 * e3 * e6 * e7 * y1 ^ 2 * e5 * x2 * e1 +
+16 * e3 * e6 ^ 2 * e7 * y1 * e5 * y2 + 4 * e3 * e6 * e7 * y1 * e5 * e2 * y3 -
+8 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * x1 * e1 -
+4 * e3 * e6 ^ 2 * e7 * y1 ^ 2 * x2 * e1 + 4 * e3 * e6 ^ 2 * e7 * y1 * e2 * y3 +
+16 * e3 * e6 * e7 * y1 ^ 3 * y2 * x1 * e1 +
+8 * e3 * e6 * e7 * y1 ^ 3 * y2 * x2 * e1 -
+16 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * x1 * e1 -
+16 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * x2 * e1 -
+16 * e3 * e6 * e7 * y1 ^ 2 * y2 * e2 * y3 -
+8 * e3 * e6 * e7 * y1 ^ 3 * e5 * y2 + 8 * e3 * e6 * e7 * y1 * e5 ^ 2 * y2 -
+8 * e3 * e6 * e7 * y1 ^ 2 * e5 * y2 ^ 2 + 4 * e3 * e6 * e7 * y1 ^ 2 * e5 * e2 -
+8 * e3 * e6 * e7 * y1 ^ 3 * y2 * e2 +
+8 * e3 * e6 * e7 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+2 * e3 * e6 * e7 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+8 * e3 * e6 * e7 * y2 ^ 3 * e5 * y1 + 8 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 2 * e2 +
+8 * e3 * e6 * e7 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+6 * e3 * e6 * e7 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+4 * e3 * e6 * e7 * e2 ^ 2 * y1 * y3 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * x1 * e1 -
+2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * x2 * e1 + 8 * e3 * e7 ^ 2 * y1 * e5 * y2 * e6 +
+2 * e3 * e7 ^ 2 * y1 * e5 * e2 * y3 - 4 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * x1 * e1 -
+2 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * x2 * e1 + 2 * e3 * e7 ^ 2 * y1 * e6 * e2 * y3 +
+8 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * x1 * e1 +
+4 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * x2 * e1 -
+8 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * x1 * e1 -
+8 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * x2 * e1 -
+4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 * e2 * y3 -
+4 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * y2 ^ 2 + 2 * e3 * e7 ^ 2 * y1 ^ 2 * e5 * e2 -
+4 * e3 * e7 ^ 2 * y1 ^ 3 * e6 * y2 + 4 * e3 * e7 ^ 2 * y1 * e6 ^ 2 * y2 -
+4 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 + 2 * e3 * e7 ^ 2 * y1 ^ 2 * e6 * e2 -
+4 * e3 * e7 ^ 2 * y1 ^ 3 * y2 * e2 +
+4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+e3 * e7 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * e6 -
+4 * e3 * e7 ^ 2 * y2 ^ 3 * e5 * y1 - 4 * e3 * e7 ^ 2 * y2 ^ 3 * e6 * y1 +
+4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 * e2 +
+4 * e3 * e7 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+e3 * e7 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 2 + 2 * e3 * e7 ^ 2 * e2 ^ 2 * y1 * y3 -
+16 * e3 * y2 ^ 3 * y3 ^ 3 * y1 ^ 2 * e2 -
+16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e5 +
+16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 ^ 2 -
+16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e5 -
+16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e6 +
+16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e6 ^ 2 -
+16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e6 -
+16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * e2 + 8 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * e6 -
+16 * e3 * y2 ^ 5 * y3 ^ 2 * e5 * y1 - 16 * e3 * y2 ^ 5 * y3 ^ 2 * e6 * y1 +
+16 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e2 +
+16 * e3 * y2 ^ 4 * y3 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+4 * e3 * y2 ^ 4 * y3 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+8 * e3 * y2 ^ 2 * y3 ^ 3 * e2 ^ 2 * y1 +
+4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 ^ 2 +
+4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 ^ 2 -
+4 * e3 * e6 ^ 3 * y2 ^ 2 * x1 * e1 + 2 * e3 * e6 ^ 3 * y2 ^ 2 * x2 * e1 -
+2 * e3 * e6 ^ 3 * y2 * e2 * y1 - 2 * e3 * e6 ^ 3 * y2 * e2 * y3 +
+2 * e3 * e6 * e7 * y2 ^ 2 * e5 ^ 2 + 8 * e3 * e6 * e7 * y1 ^ 2 * y2 ^ 4 +
+2 * e3 * e6 * e7 * e2 ^ 2 * y1 ^ 2 + 2 * e3 * e6 * e7 * e2 ^ 2 * y3 ^ 2 +
+4 * e3 * y2 ^ 2 * y3 ^ 2 * e2 ^ 2 * y1 ^ 2 -
+8 * e3 * y2 ^ 3 * y3 ^ 3 * e5 * e2 - 8 * e3 * y2 ^ 3 * y3 ^ 3 * e6 * e2 +
+16 * e3 * y2 ^ 4 * y3 ^ 3 * y1 * e2 + 16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 ^ 3 -
+16 * e3 * e6 ^ 3 * y2 ^ 2 * y3 * y1 + 16 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * y1 ^ 2 -
+8 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * e5 -
+16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * x1 * e1 -
+8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * x2 * e1 +
+32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * e6 +
+8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * e5 * e2 -
+16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * x1 * e1 +
+8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * x2 * e1 +
+8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * e6 * e2 +
+32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * x1 * e1 +
+16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 ^ 3 * x2 * e1 -
+32 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * x1 * e1 +
+32 * e3 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * x2 * e1 +
+8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * e6 +
+8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e5 * e2 + x2 ^ 2 * e1 ^ 3 * e7 ^ 3 +
+24 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 * e2 +
+16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 +
+4 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+4 * e3 * e7 ^ 2 * y1 ^ 2 * y2 ^ 4 + e3 * e7 ^ 2 * e2 ^ 2 * y1 ^ 2 +
+e3 * e7 ^ 2 * e2 ^ 2 * y3 ^ 2 + 4 * e3 * y2 ^ 4 * y3 ^ 2 * e5 ^ 2 +
+4 * e3 * y2 ^ 4 * y3 ^ 2 * e6 ^ 2 + 16 * e3 * y2 ^ 6 * y3 ^ 2 * y1 ^ 2 +
+4 * e3 * y2 ^ 2 * y3 ^ 4 * e2 ^ 2 - 4 * e3 * e6 ^ 3 * y2 ^ 3 * y3 +
+4 * e3 * e6 ^ 2 * y1 * e5 * y2 * x2 * e1 +
+4 * e3 * e6 ^ 3 * y1 * y2 * x2 * e1 +
+4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 -
+6 * e3 * e6 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 * y2 -
+4 * e3 * e6 ^ 2 * y1 ^ 2 * x1 * e1 * e2 -
+8 * e3 * e6 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 -
+2 * e3 * e6 ^ 2 * y1 ^ 2 * x2 * e1 * e2 -
+4 * e3 * e6 ^ 2 * y2 ^ 2 * e5 * x1 * e1 +
+6 * e3 * e6 ^ 2 * y2 ^ 2 * e5 * x2 * e1 - 2 * e3 * e6 ^ 2 * y2 * e5 * e2 * y1 -
+2 * e3 * e6 ^ 2 * y2 * e5 * e2 * y3 + 8 * e3 * e6 ^ 2 * y1 * y2 ^ 3 * x1 * e1 -
+12 * e3 * e6 ^ 2 * y1 * y2 ^ 3 * x2 * e1 +
+12 * e3 * e6 ^ 2 * y1 * y2 ^ 2 * e2 * y3 -
+4 * e3 * e6 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 -
+12 * e3 * e6 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 -
+4 * e3 * e6 ^ 2 * y1 * x1 * e1 * e2 * y3 -
+2 * e3 * e6 ^ 2 * y1 * x2 * e1 * e2 * y3 +
+4 * e3 * e6 ^ 2 * y2 * x1 * e1 * e2 * y1 +
+4 * e3 * e6 ^ 2 * y2 * x1 * e1 * e2 * y3 +
+2 * e3 * e6 ^ 2 * y2 * x2 * e1 * e2 * y1 +
+2 * e3 * e6 ^ 2 * y2 * x2 * e1 * e2 * y3 +
+8 * e3 * e6 * e7 * y1 * e5 * y2 * x2 * e1 +
+8 * e3 * e6 ^ 2 * e7 * y1 * y2 * x2 * e1 +
+8 * e3 * e6 * e7 * y1 ^ 2 * x1 * e1 ^ 2 * x2 -
+12 * e3 * e6 * e7 * y1 * x1 ^ 2 * e1 ^ 2 * y2 -
+8 * e3 * e6 * e7 * y1 ^ 2 * x1 * e1 * e2 -
+16 * e3 * e6 * e7 * y1 * x2 ^ 2 * e1 ^ 2 * y2 -
+4 * e3 * e6 * e7 * y1 ^ 2 * x2 * e1 * e2 -
+8 * e3 * e6 * e7 * y2 ^ 2 * e5 * x1 * e1 +
+4 * e3 * e6 * e7 * y2 ^ 2 * e5 * x2 * e1 -
+4 * e3 * e6 * e7 * y2 * e5 * e2 * y1 - 4 * e3 * e6 * e7 * y2 * e5 * e2 * y3 -
+8 * e3 * e6 ^ 2 * e7 * y2 ^ 2 * x1 * e1 - 4 * e3 * e6 ^ 2 * e7 * y2 * e2 * y1 -
+4 * e3 * e6 ^ 2 * e7 * y2 * e2 * y3 +
+16 * e3 * e6 * e7 * y1 * y2 ^ 3 * x1 * e1 -
+8 * e3 * e6 * e7 * y1 * y2 ^ 3 * x2 * e1 +
+16 * e3 * e6 * e7 * y1 * y2 ^ 2 * e2 * y3 -
+24 * e3 * e6 * e7 * y1 * x1 * e1 ^ 2 * y2 * x2 -
+8 * e3 * e6 * e7 * y1 * x1 * e1 * e2 * y3 -
+4 * e3 * e6 * e7 * y1 * x2 * e1 * e2 * y3 +
+8 * e3 * e6 * e7 * y2 * x1 * e1 * e2 * y1 +
+8 * e3 * e6 * e7 * y2 * x1 * e1 * e2 * y3 +
+4 * e3 * e6 * e7 * y2 * x2 * e1 * e2 * y1 +
+4 * e3 * e6 * e7 * y2 * x2 * e1 * e2 * y3 +
+4 * e3 * e7 ^ 2 * y1 * e5 * y2 * x2 * e1 +
+4 * e3 * e7 ^ 2 * y1 * e6 * y2 * x2 * e1 +
+4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 -
+6 * e3 * e7 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 * y2 -
+4 * e3 * e7 ^ 2 * y1 ^ 2 * x1 * e1 * e2 -
+8 * e3 * e7 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 * y2 -
+2 * e3 * e7 ^ 2 * y1 ^ 2 * x2 * e1 * e2 -
+4 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * x1 * e1 -
+2 * e3 * e7 ^ 2 * y2 ^ 2 * e5 * x2 * e1 - 2 * e3 * e7 ^ 2 * y2 * e5 * e2 * y1 -
+2 * e3 * e7 ^ 2 * y2 * e5 * e2 * y3 - 4 * e3 * e7 ^ 2 * y2 ^ 2 * e6 * x1 * e1 -
+2 * e3 * e7 ^ 2 * y2 ^ 2 * e6 * x2 * e1 - 2 * e3 * e7 ^ 2 * y2 * e6 * e2 * y1 -
+2 * e3 * e7 ^ 2 * y2 * e6 * e2 * y3 + 8 * e3 * e7 ^ 2 * y1 * y2 ^ 3 * x1 * e1 +
+4 * e3 * e7 ^ 2 * y1 * y2 ^ 3 * x2 * e1 +
+4 * e3 * e7 ^ 2 * y1 * y2 ^ 2 * e2 * y3 +
+4 * e3 * e7 ^ 2 * y2 ^ 2 * x1 * e1 ^ 2 * x2 -
+12 * e3 * e7 ^ 2 * y1 * x1 * e1 ^ 2 * y2 * x2 -
+4 * e3 * e7 ^ 2 * y1 * x1 * e1 * e2 * y3 -
+2 * e3 * e7 ^ 2 * y1 * x2 * e1 * e2 * y3 +
+4 * e3 * e7 ^ 2 * y2 * x1 * e1 * e2 * y1 +
+4 * e3 * e7 ^ 2 * y2 * x1 * e1 * e2 * y3 +
+2 * e3 * e7 ^ 2 * y2 * x2 * e1 * e2 * y1 +
+2 * e3 * e7 ^ 2 * y2 * x2 * e1 * e2 * y3 -
+48 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * x2 * e1 -
+48 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x2 * e1 +
+16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 * x2 -
+24 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x1 ^ 2 * e1 ^ 2 -
+16 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x1 * e1 * e2 +
+32 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x2 ^ 2 * e1 ^ 2 -
+8 * e3 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * x2 * e1 * e2 -
+16 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * x1 * e1 -
+8 * e3 * y2 ^ 4 * y3 ^ 2 * e5 * x2 * e1 -
+8 * e3 * y2 ^ 3 * y3 ^ 2 * e5 * e2 * y1 -
+16 * e3 * y2 ^ 4 * y3 ^ 2 * e6 * x1 * e1 -
+8 * e3 * y2 ^ 4 * y3 ^ 2 * e6 * x2 * e1 -
+24 * e3 * y2 ^ 3 * y3 ^ 2 * e6 * e2 * y1 +
+32 * e3 * y2 ^ 5 * y3 ^ 2 * y1 * x1 * e1 +
+16 * e3 * y2 ^ 5 * y3 ^ 2 * y1 * x2 * e1 +
+16 * e3 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 2 * x2 +
+16 * e3 * y2 ^ 3 * y3 ^ 2 * y1 * x1 * e1 ^ 2 * x2 -
+16 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * x1 * e1 * e2 -
+8 * e3 * y2 ^ 2 * y3 ^ 3 * y1 * x2 * e1 * e2 +
+16 * e3 * y2 ^ 3 * y3 ^ 2 * x1 * e1 * e2 * y1 +
+16 * e3 * y2 ^ 3 * y3 ^ 3 * x1 * e1 * e2 +
+8 * e3 * y2 ^ 3 * y3 ^ 2 * x2 * e1 * e2 * y1 +
+8 * e3 * y2 ^ 3 * y3 ^ 3 * x2 * e1 * e2 - e3 * e6 ^ 3 * e7 ^ 2 +
+16 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * x1 * e1 +
+8 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * x2 * e1 -
+32 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * e5 -
+8 * e3 * e6 * y2 * y3 ^ 2 * y1 * e5 * e2 +
+16 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * x1 * e1 +
+8 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * x2 * e1 -
+8 * e3 * e6 ^ 2 * y2 * y3 ^ 2 * y1 * e2 -
+32 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * x1 * e1 -
+16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * x2 * e1 +
+32 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * x1 * e1 -
+8 * e3 * e6 ^ 2 * y2 * y3 * y1 ^ 2 * e5 +
+16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * e5 -
+16 * e3 * e6 * y2 ^ 2 * y3 * y1 * e5 ^ 2 +
+16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * e5 -
+8 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 * e2 +
+16 * e3 * e6 * y2 ^ 2 * y3 * y1 ^ 3 * e2 -
+16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+4 * e3 * e6 * y2 * y3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 +
+16 * e3 * e6 * y2 ^ 4 * y3 * e5 * y1 + 16 * e3 * e6 ^ 2 * y2 ^ 4 * y3 * y1 -
+4 * e3 * e6 ^ 3 * y2 * y3 * y1 ^ 2 - 16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 4 -
+16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 4 - 4 * e3 * e6 * y2 ^ 3 * y3 * e5 ^ 2 -
+16 * e3 * e6 * y2 ^ 5 * y3 * y1 ^ 2 - 4 * e3 * e6 * y2 * y3 ^ 3 * e2 ^ 2 +
+8 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * e2 - 4 * e3 * e7 * y2 ^ 3 * y3 * e5 ^ 2 -
+4 * e3 * e7 * y2 ^ 3 * y3 * e6 ^ 2 - 16 * e3 * e7 * y2 ^ 5 * y3 * y1 ^ 2 -
+4 * e3 * e7 * y2 * y3 ^ 3 * e2 ^ 2 - 16 * e3 * e6 * y2 ^ 3 * y3 * y1 ^ 2 * e2 -
+16 * e3 * e6 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 2 +
+12 * e3 * e6 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 2 -
+8 * e3 * e6 * y2 * y3 ^ 2 * e2 ^ 2 * y1 -
+4 * e3 * e6 * y2 * y3 * y1 ^ 2 * e5 ^ 2 +
+16 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * x1 * e1 +
+8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * x2 * e1 -
+32 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 * e6 -
+8 * e3 * e7 * y2 * y3 ^ 2 * y1 * e5 * e2 +
+16 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 * x1 * e1 +
+8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 * x2 * e1 -
+8 * e3 * e7 * y2 * y3 ^ 2 * y1 * e6 * e2 -
+32 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * x1 * e1 -
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * x2 * e1 +
+32 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * x1 * e1 +
+16 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e2 -
+8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * e6 +
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e5 -
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 ^ 2 +
+16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e5 -
+8 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 * e2 +
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e6 -
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e6 ^ 2 +
+16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e6 +
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 ^ 3 * e2 -
+16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 ^ 2 * e1 ^ 2 -
+4 * e3 * e7 * y2 * y3 * y1 ^ 2 * x2 ^ 2 * e1 ^ 2 -
+8 * e3 * e7 * y2 ^ 3 * y3 * e5 * e6 + 16 * e3 * e7 * y2 ^ 4 * y3 * e5 * y1 +
+16 * e3 * e7 * y2 ^ 4 * y3 * e6 * y1 -
+16 * e3 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e2 -
+16 * e3 * e7 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 2 -
+4 * e3 * e7 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 2 -
+8 * e3 * e7 * y2 * y3 ^ 2 * e2 ^ 2 * y1 -
+4 * e3 * e7 * y2 * y3 * y1 ^ 2 * e5 ^ 2 -
+4 * e3 * e7 * y2 * y3 * y1 ^ 2 * e6 ^ 2 + e1 ^ 3 * x3 ^ 2 * e7 ^ 3 -
+4 * e3 * e6 * y2 * y3 * e2 ^ 2 * y1 ^ 2 +
+16 * e3 * e6 * y2 ^ 2 * y3 * y1 * e5 * x2 * e1 +
+16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x2 * e1 -
+16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 +
+24 * e3 * e6 * y2 ^ 2 * y3 * y1 * x1 ^ 2 * e1 ^ 2 +
+16 * e3 * e6 * y2 * y3 * y1 ^ 2 * x1 * e1 * e2 +
+8 * e3 * e6 * y2 * y3 * y1 ^ 2 * x2 * e1 * e2 +
+16 * e3 * e6 * y2 ^ 3 * y3 * e5 * x1 * e1 -
+8 * e3 * e6 * y2 ^ 3 * y3 * e5 * x2 * e1 +
+8 * e3 * e6 * y2 ^ 2 * y3 * e5 * e2 * y1 +
+8 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * e5 * e2 +
+16 * e3 * e6 ^ 2 * y2 ^ 3 * y3 * x1 * e1 -
+32 * e3 * e6 * y2 ^ 4 * y3 * y1 * x1 * e1 +
+16 * e3 * e6 * y2 ^ 4 * y3 * y1 * x2 * e1 +
+16 * e3 * e6 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 * x2 +
+16 * e3 * e6 * y2 * y3 ^ 2 * y1 * x1 * e1 * e2 +
+8 * e3 * e6 * y2 * y3 ^ 2 * y1 * x2 * e1 * e2 -
+16 * e3 * e6 * y2 ^ 2 * y3 * x1 * e1 * e2 * y1 -
+16 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 * e2 -
+8 * e3 * e6 * y2 ^ 2 * y3 * x2 * e1 * e2 * y1 -
+8 * e3 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 * e2 - e1 * y3 ^ 2 * e6 ^ 4 -
+4 * e3 * e7 * y2 * y3 * e2 ^ 2 * y1 ^ 2 +
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e5 * x2 * e1 +
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 * e6 * x2 * e1 -
+16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 * e1 ^ 2 * x2 +
+24 * e3 * e7 * y2 ^ 2 * y3 * y1 * x1 ^ 2 * e1 ^ 2 +
+16 * e3 * e7 * y2 * y3 * y1 ^ 2 * x1 * e1 * e2 +
+8 * e3 * e7 * y2 * y3 * y1 ^ 2 * x2 * e1 * e2 +
+16 * e3 * e7 * y2 ^ 3 * y3 * e5 * x1 * e1 +
+8 * e3 * e7 * y2 ^ 3 * y3 * e5 * x2 * e1 +
+8 * e3 * e7 * y2 ^ 2 * y3 * e5 * e2 * y1 +
+8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * e5 * e2 +
+16 * e3 * e7 * y2 ^ 3 * y3 * e6 * x1 * e1 +
+8 * e3 * e7 * y2 ^ 3 * y3 * e6 * x2 * e1 +
+8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * e6 * e2 -
+32 * e3 * e7 * y2 ^ 4 * y3 * y1 * x1 * e1 -
+16 * e3 * e7 * y2 ^ 4 * y3 * y1 * x2 * e1 -
+16 * e3 * e7 * y2 ^ 3 * y3 ^ 2 * y1 * e2 -
+16 * e3 * e7 * y2 ^ 3 * y3 * x1 * e1 ^ 2 * x2 +
+16 * e3 * e7 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 * x2 +
+16 * e3 * e7 * y2 * y3 ^ 2 * y1 * x1 * e1 * e2 +
+8 * e3 * e7 * y2 * y3 ^ 2 * y1 * x2 * e1 * e2 -
+16 * e3 * e7 * y2 ^ 2 * y3 * x1 * e1 * e2 * y1 -
+16 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * x1 * e1 * e2 -
+8 * e3 * e7 * y2 ^ 2 * y3 * x2 * e1 * e2 * y1 -
+8 * e3 * e7 * y2 ^ 2 * y3 ^ 2 * x2 * e1 * e2 - e6 ^ 3 * x3 ^ 2 * e3 ^ 3 -
+16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * y1 ^ 3 - e6 ^ 3 * e3 ^ 3 * x1 ^ 2 +
+2 * e6 ^ 4 * x2 * e3 ^ 2 + 2 * e6 ^ 4 * x3 * e3 ^ 2 +
+2 * e6 ^ 4 * e3 ^ 2 * x1 - e5 ^ 3 * x2 ^ 2 * e3 ^ 3 -
+e5 ^ 3 * x3 ^ 2 * e3 ^ 3 - e5 ^ 3 * e3 ^ 3 * x1 ^ 2 +
+2 * x1 ^ 5 * e1 ^ 3 * e3 ^ 3 - 3 * e3 * e6 ^ 4 * e5 - e3 * e5 ^ 3 * e6 ^ 2 -
+3 * e3 * e5 ^ 2 * e6 ^ 3 - e3 * e5 ^ 3 * e7 ^ 2 - e6 ^ 3 * x2 ^ 2 * e3 ^ 3 -
+2 * e6 ^ 3 * x2 * e3 ^ 3 * x3 - 2 * e6 ^ 3 * x2 * e3 ^ 3 * x1 -
+2 * e6 ^ 3 * x3 * e3 ^ 3 * x1 + 2 * e6 ^ 3 * e7 * x2 * e3 ^ 2 +
+2 * e6 ^ 3 * e7 * x3 * e3 ^ 2 + 2 * e6 ^ 3 * e7 * e3 ^ 2 * x1 -
+2 * e5 ^ 3 * x2 * e3 ^ 3 * x3 - 2 * e5 ^ 3 * x2 * e3 ^ 3 * x1 -
+2 * e5 ^ 3 * x3 * e3 ^ 3 * x1 + 2 * e5 ^ 3 * e6 * x2 * e3 ^ 2 +
+6 * e5 ^ 2 * e6 ^ 2 * x2 * e3 ^ 2 + 2 * e5 ^ 3 * e6 * x3 * e3 ^ 2 +
+6 * e5 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 + 2 * e5 ^ 3 * e6 * e3 ^ 2 * x1 +
+6 * e5 ^ 2 * e6 ^ 2 * e3 ^ 2 * x1 + 2 * e5 ^ 3 * e7 * x2 * e3 ^ 2 +
+2 * e5 ^ 3 * e7 * x3 * e3 ^ 2 + 2 * e5 ^ 3 * e7 * e3 ^ 2 * x1 -
+3 * e5 ^ 2 * e6 * x2 ^ 2 * e3 ^ 3 - 3 * e5 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 -
+3 * e5 ^ 2 * e6 * x3 ^ 2 * e3 ^ 3 - 3 * e5 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 -
+3 * e5 ^ 2 * e6 * e3 ^ 3 * x1 ^ 2 - 3 * e5 * e6 ^ 2 * e3 ^ 3 * x1 ^ 2 +
+6 * e5 * e6 ^ 3 * x2 * e3 ^ 2 + 6 * e5 * e6 ^ 3 * x3 * e3 ^ 2 +
+6 * e5 * e6 ^ 3 * e3 ^ 2 * x1 + 8 * x1 ^ 3 * e1 ^ 2 * e6 ^ 2 * e3 ^ 2 -
+8 * e1 ^ 2 * x3 ^ 3 * e6 ^ 2 * e3 ^ 2 + 4 * e5 ^ 2 * x1 ^ 3 * e1 * e3 ^ 3 +
+2 * e5 ^ 2 * x2 ^ 3 * e1 * e3 ^ 3 - 5 * x1 ^ 4 * e1 ^ 2 * e3 ^ 3 * e5 -
+5 * x1 ^ 4 * e1 ^ 2 * e3 ^ 3 * e6 - x2 ^ 4 * e1 ^ 2 * e3 ^ 3 * e5 -
+x2 ^ 4 * e1 ^ 2 * e3 ^ 3 * e6 + 3 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * e5 +
+3 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * e6 + 8 * x1 ^ 2 * e1 ^ 3 * x2 ^ 3 * e3 ^ 3 +
+2 * x1 * e1 ^ 3 * x2 ^ 4 * e3 ^ 3 + 8 * x1 ^ 4 * e1 ^ 3 * x2 * e3 ^ 3 +
+12 * x1 ^ 3 * e1 ^ 3 * x2 ^ 2 * e3 ^ 3 +
+4 * x1 ^ 3 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 + 6 * x1 ^ 4 * e1 ^ 3 * x3 * e3 ^ 3 -
+3 * x1 ^ 4 * e1 ^ 3 * e6 * e3 ^ 2 - 3 * x1 ^ 4 * e1 ^ 3 * e7 * e3 ^ 2 -
+8 * x2 ^ 3 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 - 2 * x2 ^ 4 * e1 ^ 3 * e3 ^ 3 * x3 +
+x2 ^ 4 * e1 ^ 3 * e6 * e3 ^ 2 + x2 ^ 4 * e1 ^ 3 * e7 * e3 ^ 2 -
+12 * e1 ^ 3 * x3 ^ 3 * x2 ^ 2 * e3 ^ 3 -
+4 * e1 ^ 3 * x3 ^ 3 * e3 ^ 3 * x1 ^ 2 + 2 * e6 ^ 2 * x2 ^ 3 * e3 ^ 3 * e1 +
+4 * e6 ^ 2 * e3 ^ 3 * x1 ^ 3 * e1 - 3 * e6 ^ 3 * x2 ^ 2 * e3 ^ 2 * e1 -
+7 * e6 ^ 3 * e3 ^ 2 * x1 ^ 2 * e1 - 6 * e1 ^ 3 * x3 ^ 4 * e3 ^ 3 * x1 -
+8 * e1 ^ 3 * x3 ^ 4 * e3 ^ 3 * x2 + e6 ^ 3 * e1 * x3 ^ 2 * e3 ^ 2 -
+6 * e3 * e6 ^ 3 * e7 * e5 - 4 * e3 * e6 ^ 3 * y2 ^ 2 * y3 ^ 2 +
+4 * e3 * e6 ^ 4 * y2 * y3 - 2 * e3 * e5 ^ 3 * e6 * e7 -
+6 * e3 * e5 ^ 2 * e6 ^ 2 * e7 - 4 * e3 * e5 ^ 3 * y2 ^ 2 * y3 ^ 2 -
+3 * e3 * e5 ^ 2 * e6 * e7 ^ 2 - 3 * e3 * e5 * e6 ^ 2 * e7 ^ 2 - e3 * e6 ^ 5 +
+12 * e6 ^ 2 * x2 * e3 ^ 3 * x3 * x1 * e1 +
+4 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e1 +
+10 * e6 ^ 2 * x2 * e3 ^ 3 * x1 ^ 2 * e1 +
+8 * e6 ^ 2 * x2 ^ 2 * e3 ^ 3 * x1 * e1 - 4 * e6 ^ 3 * y2 * y3 * x2 * e3 ^ 2 -
+4 * e6 ^ 3 * y2 * y3 * x3 * e3 ^ 2 - 4 * e6 ^ 3 * y2 * y3 * e3 ^ 2 * x1 +
+8 * x1 * e1 ^ 2 * x2 ^ 2 * e6 ^ 2 * e3 ^ 2 +
+16 * x1 ^ 2 * e1 ^ 2 * x2 * e6 ^ 2 * e3 ^ 2 -
+4 * e5 ^ 3 * y2 * y3 * x2 * e3 ^ 2 - 4 * e5 ^ 3 * y2 * y3 * x3 * e3 ^ 2 -
+4 * e5 ^ 3 * y2 * y3 * e3 ^ 2 * x1 +
+8 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 -
+8 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * x3 * e3 ^ 2 -
+16 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * x2 * e3 ^ 2 -
+6 * e6 ^ 2 * x2 * e3 ^ 3 * x3 * e5 - 6 * e6 ^ 2 * x2 * e3 ^ 3 * x1 * e5 -
+6 * e6 ^ 2 * x3 * e3 ^ 3 * x1 * e5 + 6 * e6 ^ 2 * e7 * x2 * e3 ^ 2 * e5 +
+6 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * e5 + 6 * e6 ^ 2 * e7 * e3 ^ 2 * x1 * e5 -
+8 * x1 * e1 ^ 2 * x2 ^ 3 * e3 ^ 3 * e5 -
+8 * x1 * e1 ^ 2 * x2 ^ 3 * e3 ^ 3 * e6 -
+16 * x1 ^ 3 * e1 ^ 2 * x2 * e3 ^ 3 * e5 -
+16 * x1 ^ 3 * e1 ^ 2 * x2 * e3 ^ 3 * e6 -
+18 * x1 ^ 2 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * e5 -
+18 * x1 ^ 2 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * e6 -
+6 * e5 ^ 2 * x2 * e3 ^ 3 * x3 * e6 - 6 * e5 ^ 2 * x2 * e3 ^ 3 * x1 * e6 -
+6 * e5 ^ 2 * x3 * e3 ^ 3 * x1 * e6 + 6 * e5 ^ 2 * e7 * x2 * e3 ^ 2 * e6 +
+6 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * e6 + 6 * e5 ^ 2 * e7 * e3 ^ 2 * x1 * e6 -
+6 * x1 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e5 -
+6 * x1 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e6 -
+12 * x1 ^ 3 * e1 ^ 2 * x3 * e3 ^ 3 * e5 -
+12 * x1 ^ 3 * e1 ^ 2 * x3 * e3 ^ 3 * e6 +
+8 * x1 ^ 3 * e1 ^ 2 * e6 * e3 ^ 2 * e5 +
+8 * x1 ^ 3 * e1 ^ 2 * e7 * e3 ^ 2 * e5 +
+8 * x1 ^ 3 * e1 ^ 2 * e7 * e3 ^ 2 * e6 +
+6 * x2 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e5 +
+6 * x2 ^ 2 * e1 ^ 2 * x3 ^ 2 * e3 ^ 3 * e6 +
+8 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * e5 +
+8 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * e6 +
+4 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * e5 +
+4 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * e6 -
+12 * e6 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e5 -
+12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 -
+12 * e6 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e5 -
+32 * x1 * e1 ^ 2 * x2 ^ 2 * y2 * y3 * e3 ^ 2 * e5 -
+32 * x1 * e1 ^ 2 * x2 ^ 2 * y2 * y3 * e3 ^ 2 * e6 -
+16 * x1 * e1 ^ 2 * x2 * y2 * y3 * x3 * e3 ^ 2 * e5 -
+16 * x1 * e1 ^ 2 * x2 * y2 * y3 * x3 * e3 ^ 2 * e6 -
+32 * x1 ^ 2 * e1 ^ 2 * x2 * y2 * y3 * e3 ^ 2 * e5 -
+32 * x1 ^ 2 * e1 ^ 2 * x2 * y2 * y3 * e3 ^ 2 * e6 -
+12 * x1 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e5 -
+12 * x1 * e1 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e6 -
+24 * x1 ^ 2 * e1 ^ 2 * x2 * x3 * e3 ^ 3 * e5 -
+24 * x1 ^ 2 * e1 ^ 2 * x2 * x3 * e3 ^ 3 * e6 +
+8 * x1 * e1 ^ 2 * x2 ^ 2 * e6 * e3 ^ 2 * e5 +
+16 * x1 ^ 2 * e1 ^ 2 * x2 * e6 * e3 ^ 2 * e5 +
+8 * x1 * e1 ^ 2 * x2 ^ 2 * e7 * e3 ^ 2 * e5 +
+8 * x1 * e1 ^ 2 * x2 ^ 2 * e7 * e3 ^ 2 * e6 +
+16 * x1 ^ 2 * e1 ^ 2 * x2 * e7 * e3 ^ 2 * e5 +
+16 * x1 ^ 2 * e1 ^ 2 * x2 * e7 * e3 ^ 2 * e6 -
+12 * e5 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e6 -
+12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 -
+12 * e5 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e6 -
+16 * x1 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 -
+16 * x1 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 -
+16 * x1 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e5 -
+16 * x1 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e6 +
+8 * x1 ^ 2 * e1 ^ 2 * e6 * x3 * e3 ^ 2 * e5 +
+8 * x1 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e5 +
+8 * x1 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e6 -
+16 * x2 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e5 -
+16 * x2 ^ 3 * e1 ^ 2 * y2 * y3 * e3 ^ 2 * e6 -
+16 * x2 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e5 -
+16 * x2 ^ 2 * e1 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * e6 -
+8 * x2 ^ 2 * e1 ^ 2 * e6 * x3 * e3 ^ 2 * e5 -
+8 * x2 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e5 -
+8 * x2 ^ 2 * e1 ^ 2 * e7 * x3 * e3 ^ 2 * e6 +
+12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e5 +
+12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * e6 +
+12 * e1 ^ 2 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * e5 +
+12 * e1 ^ 2 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * e6 +
+12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e5 +
+12 * e1 ^ 2 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 * e6 -
+16 * e1 ^ 2 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * e5 -
+8 * e1 ^ 2 * x3 ^ 3 * e6 * e3 ^ 2 * e5 -
+8 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * e5 -
+8 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * e6 + 8 * e5 * x1 ^ 3 * e1 * e3 ^ 3 * e6 +
+4 * e5 * x2 ^ 3 * e1 * e3 ^ 3 * e6 -
+8 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e3 ^ 2 * x1 +
+8 * e6 ^ 2 * x3 * e3 ^ 3 * x1 ^ 2 * e1 -
+10 * e6 ^ 2 * e7 * x2 * e3 ^ 2 * x1 * e1 -
+3 * e6 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 * e1 -
+6 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * x1 * e1 -
+2 * e6 ^ 2 * e7 * x3 * e3 ^ 2 * x2 * e1 -
+7 * e6 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 * e1 +
+12 * e5 ^ 2 * x2 * e3 ^ 3 * x3 * x1 * e1 +
+4 * e5 ^ 2 * x2 ^ 2 * e3 ^ 3 * x3 * e1 +
+10 * e5 ^ 2 * x2 * e3 ^ 3 * x1 ^ 2 * e1 +
+8 * e5 ^ 2 * x2 ^ 2 * e3 ^ 3 * x1 * e1 +
+8 * e5 ^ 2 * x3 * e3 ^ 3 * x1 ^ 2 * e1 -
+10 * e5 ^ 2 * e6 * x2 * e3 ^ 2 * x1 * e1 -
+3 * e5 ^ 2 * e6 * x2 ^ 2 * e3 ^ 2 * e1 -
+6 * e5 ^ 2 * e6 * x3 * e3 ^ 2 * x1 * e1 -
+2 * e5 ^ 2 * e6 * x3 * e3 ^ 2 * x2 * e1 -
+7 * e5 ^ 2 * e6 * e3 ^ 2 * x1 ^ 2 * e1 -
+10 * e5 ^ 2 * e7 * x2 * e3 ^ 2 * x1 * e1 -
+3 * e5 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 * e1 -
+6 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * x1 * e1 -
+2 * e5 ^ 2 * e7 * x3 * e3 ^ 2 * x2 * e1 -
+7 * e5 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 * e1 +
+16 * e5 * e6 * x2 ^ 2 * e3 ^ 3 * x1 * e1 +
+8 * e5 * e6 * x3 ^ 2 * e3 ^ 3 * x1 * e1 +
+4 * e5 * e6 * x3 ^ 2 * e3 ^ 3 * x2 * e1 +
+20 * e5 * e6 * e3 ^ 3 * x1 ^ 2 * x2 * e1 -
+20 * e5 * e6 ^ 2 * x2 * e3 ^ 2 * x1 * e1 -
+6 * e5 * e6 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 -
+12 * e5 * e6 ^ 2 * x3 * e3 ^ 2 * x1 * e1 -
+4 * e5 * e6 ^ 2 * x3 * e3 ^ 2 * x2 * e1 -
+14 * e5 * e6 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 +
+16 * x1 ^ 3 * e1 ^ 3 * x3 * e3 ^ 3 * x2 -
+8 * x1 ^ 3 * e1 ^ 3 * e6 * e3 ^ 2 * x2 -
+8 * x1 ^ 3 * e1 ^ 3 * e7 * e3 ^ 2 * x2 -
+12 * x2 ^ 2 * e1 ^ 3 * x3 ^ 2 * e3 ^ 3 * x1 -
+16 * e1 ^ 2 * x3 ^ 3 * x2 * e3 ^ 3 * y1 * y2 -
+16 * e1 ^ 3 * x3 ^ 3 * x2 * e3 ^ 3 * x1 -
+8 * e1 ^ 2 * x3 ^ 3 * e3 ^ 3 * x1 * y1 * y2 +
+20 * e6 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 +
+14 * e6 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 +
+12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 +
+12 * e6 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 +
+4 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 * x1 * e1 +
+2 * e6 ^ 2 * x3 ^ 2 * e3 ^ 3 * x2 * e1 - 10 * e6 ^ 3 * x2 * e3 ^ 2 * x1 * e1 -
+6 * e6 ^ 3 * x3 * e3 ^ 2 * x1 * e1 - 2 * e6 ^ 3 * x3 * e3 ^ 2 * x2 * e1 +
+4 * e5 ^ 2 * x3 ^ 2 * e3 ^ 3 * x1 * e1 +
+2 * e5 ^ 2 * x3 ^ 2 * e3 ^ 3 * x2 * e1 -
+6 * e1 ^ 2 * x3 ^ 4 * e3 ^ 3 * y1 * y2 +
+14 * e6 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 +
+20 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * y2 * y3 * e3 ^ 2 +
+16 * x1 * e1 ^ 3 * x2 ^ 3 * y2 * y3 * e3 ^ 2 +
+8 * x1 ^ 2 * e1 ^ 3 * x2 * y2 * y3 * x3 * e3 ^ 2 +
+8 * x1 * e1 ^ 3 * x2 ^ 2 * y2 * y3 * x3 * e3 ^ 2 +
+16 * x1 ^ 3 * e1 ^ 3 * x2 * y2 * y3 * e3 ^ 2 +
+12 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e3 ^ 3 * x3 -
+6 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e6 * e3 ^ 2 +
+12 * x1 * e1 ^ 3 * x2 ^ 2 * e6 * x3 * e3 ^ 2 -
+6 * x1 ^ 2 * e1 ^ 3 * x2 ^ 2 * e7 * e3 ^ 2 +
+12 * x1 * e1 ^ 3 * x2 ^ 2 * e7 * x3 * e3 ^ 2 +
+20 * e5 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 +
+14 * e5 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 +
+12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 +
+12 * e5 ^ 2 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 +
+14 * e5 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 +
+40 * e5 * e6 * y2 * y3 * x2 * e3 ^ 2 * x1 * e1 +
+28 * e5 * e6 * y2 * y3 * x2 ^ 2 * e3 ^ 2 * e1 +
+24 * e5 * e6 * y2 * y3 * x3 * e3 ^ 2 * x1 * e1 +
+24 * e5 * e6 * y2 * y3 * x3 * e3 ^ 2 * x2 * e1 +
+28 * e5 * e6 * y2 * y3 * e3 ^ 2 * x1 ^ 2 * e1 +
+24 * e5 * e6 * x2 * e3 ^ 3 * x3 * x1 * e1 +
+8 * e5 * e6 * x2 ^ 2 * e3 ^ 3 * x3 * e1 +
+16 * e5 * e6 * x3 * e3 ^ 3 * x1 ^ 2 * e1 -
+20 * e5 * e6 * e7 * x2 * e3 ^ 2 * x1 * e1 -
+6 * e5 * e6 * e7 * x2 ^ 2 * e3 ^ 2 * e1 -
+12 * e5 * e6 * e7 * x3 * e3 ^ 2 * x1 * e1 -
+4 * e5 * e6 * e7 * x3 * e3 ^ 2 * x2 * e1 -
+14 * e5 * e6 * e7 * e3 ^ 2 * x1 ^ 2 * e1 +
+8 * x1 ^ 3 * e1 ^ 3 * y2 * y3 * x3 * e3 ^ 2 +
+6 * x1 ^ 4 * e1 ^ 3 * y2 * y3 * e3 ^ 2 -
+4 * x1 ^ 3 * e1 ^ 3 * e6 * x3 * e3 ^ 2 -
+4 * x1 ^ 3 * e1 ^ 3 * e7 * x3 * e3 ^ 2 +
+6 * x2 ^ 4 * e1 ^ 3 * y2 * y3 * e3 ^ 2 +
+8 * x2 ^ 3 * e1 ^ 3 * y2 * y3 * x3 * e3 ^ 2 +
+8 * x2 ^ 3 * e1 ^ 3 * e6 * x3 * e3 ^ 2 +
+8 * x2 ^ 3 * e1 ^ 3 * e7 * x3 * e3 ^ 2 -
+24 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 * x2 * e3 ^ 2 * y1 -
+28 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * x2 * e3 ^ 2 * x1 -
+10 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * x2 ^ 2 * e3 ^ 2 -
+24 * e1 ^ 2 * x3 ^ 3 * y2 ^ 2 * y3 * e3 ^ 2 * y1 -
+20 * e1 ^ 3 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * x1 -
+20 * e1 ^ 3 * x3 ^ 3 * y2 * y3 * e3 ^ 2 * x2 -
+24 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 * e3 ^ 2 * x1 * y1 -
+10 * e1 ^ 3 * x3 ^ 2 * y2 * y3 * e3 ^ 2 * x1 ^ 2 +
+32 * e1 ^ 2 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * y1 * y2 +
+24 * e1 ^ 3 * x3 ^ 2 * e6 * x2 * e3 ^ 2 * x1 +
+18 * e1 ^ 3 * x3 ^ 2 * e6 * x2 ^ 2 * e3 ^ 2 +
+16 * e1 ^ 2 * x3 ^ 3 * e6 * e3 ^ 2 * y1 * y2 +
+12 * e1 ^ 3 * x3 ^ 3 * e6 * e3 ^ 2 * x1 +
+16 * e1 ^ 3 * x3 ^ 3 * e6 * e3 ^ 2 * x2 +
+16 * e1 ^ 2 * x3 ^ 3 * e7 * e3 ^ 2 * y1 * y2 +
+12 * e1 ^ 3 * x3 ^ 3 * e7 * e3 ^ 2 * x1 +
+16 * e1 ^ 3 * x3 ^ 3 * e7 * e3 ^ 2 * x2 -
+4 * y1 * y2 * e1 * x3 ^ 2 * e6 ^ 2 * e3 ^ 2 +
+e5 ^ 2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 + e5 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 +
+e6 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 + 2 * e6 ^ 2 * e1 * x3 ^ 2 * e3 ^ 2 * e5 -
+8 * e1 ^ 2 * x3 ^ 2 * e6 * e3 ^ 2 * x1 * e5 -
+16 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * e5 -
+16 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * e6 -
+8 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * e5 -
+8 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * e6 -
+4 * y1 * y2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 * e5 -
+4 * y1 * y2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e5 -
+4 * y1 * y2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e6 +
+2 * e5 * e1 * x3 ^ 2 * e7 * e3 ^ 2 * e6 +
+16 * e1 ^ 2 * x3 ^ 2 * e6 * e3 ^ 2 * x1 * y1 * y2 +
+6 * e1 ^ 3 * x3 ^ 2 * e6 * e3 ^ 2 * x1 ^ 2 +
+32 * e1 ^ 2 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * y1 * y2 +
+24 * e1 ^ 3 * x3 ^ 2 * e7 * x2 * e3 ^ 2 * x1 +
+18 * e1 ^ 3 * x3 ^ 2 * e7 * x2 ^ 2 * e3 ^ 2 +
+16 * e1 ^ 2 * x3 ^ 2 * e7 * e3 ^ 2 * x1 * y1 * y2 +
+6 * e1 ^ 3 * x3 ^ 2 * e7 * e3 ^ 2 * x1 ^ 2 +
+4 * y1 ^ 2 * y2 ^ 2 * e1 * x3 ^ 2 * e6 * e3 ^ 2 +
+4 * y1 ^ 2 * y2 ^ 2 * e1 * x3 ^ 2 * e7 * e3 ^ 2 +
+4 * e3 * e6 ^ 3 * e7 * y2 * y3 + 2 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 3 +
+4 * e3 * e5 ^ 3 * e6 * y2 * y3 + 12 * e3 * e5 ^ 2 * e6 ^ 2 * y2 * y3 +
+4 * e3 * e5 ^ 3 * e7 * y2 * y3 - 12 * e3 * e5 ^ 2 * e6 * y2 ^ 2 * y3 ^ 2 -
+12 * e3 * e5 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 + 12 * e3 * e5 * e6 ^ 3 * y2 * y3 -
+e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 3 + 3 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 3 +
+7 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 3 + 2 * e3 * e6 ^ 4 * x1 * e1 -
+2 * e3 * e6 ^ 4 * e1 * x3 - 2 * e3 * x2 ^ 3 * e1 ^ 3 * e6 ^ 2 -
+2 * e3 * x2 ^ 3 * e1 ^ 3 * e7 ^ 2 - 2 * e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * e7 +
+6 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * e7 +
+14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e7 + 6 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 3 +
+10 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 3 + 2 * e3 * e5 ^ 2 * x1 * e1 * e6 ^ 2 +
+2 * e3 * e5 ^ 2 * x1 * e1 * e7 ^ 2 - 2 * e3 * e5 ^ 2 * e1 * x3 * e6 ^ 2 -
+2 * e3 * e5 ^ 2 * e1 * x3 * e7 ^ 2 - e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * e5 -
+e3 * x1 ^ 2 * e1 ^ 2 * e7 ^ 2 * e5 - e3 * x1 ^ 2 * e1 ^ 2 * e7 ^ 2 * e6 +
+3 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * e5 +
+3 * e3 * x2 ^ 2 * e1 ^ 2 * e7 ^ 2 * e5 +
+3 * e3 * x2 ^ 2 * e1 ^ 2 * e7 ^ 2 * e6 +
+7 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * e5 +
+7 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * e5 +
+7 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * e6 + 4 * e3 * e6 ^ 3 * x1 * e1 * e5 -
+4 * e3 * e6 ^ 3 * e1 * x3 * e5 - 2 * e3 * x1 ^ 2 * e1 ^ 3 * x2 * e6 ^ 2 -
+4 * e3 * x1 * e1 ^ 3 * x2 ^ 2 * e6 ^ 2 -
+2 * e3 * x1 ^ 2 * e1 ^ 3 * x2 * e7 ^ 2 -
+4 * e3 * x1 * e1 ^ 3 * x2 ^ 2 * e7 ^ 2 +
+4 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * e7 +
+8 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * y2 * y3 +
+4 * e3 * x1 ^ 2 * e1 ^ 2 * e6 ^ 2 * y2 * y3 +
+4 * e3 * x2 ^ 2 * e1 ^ 2 * e6 ^ 2 * y2 * y3 -
+20 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * y2 * y3 +
+12 * e3 * e6 ^ 2 * e7 * y2 * y3 * e5 +
+2 * e3 * x1 * e1 ^ 2 * x2 * e6 ^ 2 * e5 +
+2 * e3 * x1 * e1 ^ 2 * x2 * e7 ^ 2 * e5 +
+2 * e3 * x1 * e1 ^ 2 * x2 * e7 ^ 2 * e6 +
+12 * e3 * e5 ^ 2 * e7 * y2 * y3 * e6 -
+2 * e3 * x1 ^ 2 * e1 ^ 2 * e6 * e7 * e5 -
+4 * e3 * x1 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 -
+4 * e3 * x1 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 +
+6 * e3 * x2 ^ 2 * e1 ^ 2 * e6 * e7 * e5 -
+20 * e3 * x2 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 -
+20 * e3 * x2 ^ 2 * e1 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 +
+14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * e7 * e5 +
+12 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e5 +
+12 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 +
+4 * e3 * x1 * e1 ^ 2 * x2 * e6 * e7 * e5 -
+24 * e3 * x1 * e1 ^ 2 * x2 * y2 ^ 2 * y3 ^ 2 * e5 -
+24 * e3 * x1 * e1 ^ 2 * x2 * y2 ^ 2 * y3 ^ 2 * e6 +
+8 * e3 * x1 * e1 ^ 2 * x2 * e6 * y2 * y3 * e5 +
+8 * e3 * x1 * e1 ^ 2 * x2 * e7 * y2 * y3 * e5 +
+8 * e3 * x1 * e1 ^ 2 * x2 * e7 * y2 * y3 * e6 +
+4 * e3 * x1 ^ 2 * e1 ^ 2 * e6 * y2 * y3 * e5 +
+4 * e3 * x1 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e5 +
+4 * e3 * x1 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e6 +
+4 * e3 * x2 ^ 2 * e1 ^ 2 * e6 * y2 * y3 * e5 +
+4 * e3 * x2 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e5 +
+4 * e3 * x2 ^ 2 * e1 ^ 2 * e7 * y2 * y3 * e6 -
+20 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * y2 * y3 * e5 +
+6 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * e5 +
+6 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * e5 +
+6 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * e6 +
+10 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * e5 +
+10 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * e5 +
+10 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * e6 +
+4 * e3 * e5 * x1 * e1 * e7 ^ 2 * e6 - 4 * e3 * e5 * e1 * x3 * e7 ^ 2 * e6 -
+8 * e3 * e6 ^ 2 * e7 * y2 * y3 * x1 * e1 -
+8 * e3 * e6 ^ 2 * e7 * y2 * y3 * x2 * e1 -
+8 * e3 * e5 ^ 2 * e6 * y2 * y3 * x1 * e1 -
+8 * e3 * e5 ^ 2 * e6 * y2 * y3 * x2 * e1 -
+8 * e3 * e5 ^ 2 * e7 * y2 * y3 * x1 * e1 -
+8 * e3 * e5 ^ 2 * e7 * y2 * y3 * x2 * e1 +
+16 * e3 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 +
+32 * e3 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 -
+16 * e3 * e5 * e6 ^ 2 * y2 * y3 * x1 * e1 -
+16 * e3 * e5 * e6 ^ 2 * y2 * y3 * x2 * e1 -
+4 * e3 * x1 ^ 2 * e1 ^ 3 * e6 * e7 * x2 +
+8 * e3 * x1 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * x2 -
+4 * e3 * x2 ^ 3 * e1 ^ 3 * e6 * e7 +
+8 * e3 * x2 ^ 3 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 + 4 * e3 * e6 ^ 3 * e7 * x1 * e1 -
+8 * e3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * x1 -
+10 * e3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * x2 -
+8 * e3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * x1 -
+10 * e3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * x2 + 2 * e3 * e6 ^ 2 * e7 ^ 2 * x1 * e1 -
+4 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 ^ 2 -
+4 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e7 ^ 2 -
+8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 ^ 2 -
+8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e7 ^ 2 - 4 * e3 * e6 ^ 3 * e1 * x3 * e7 -
+2 * e3 * e6 ^ 2 * e1 * x3 * e7 ^ 2 - 8 * e3 * x2 ^ 2 * e1 ^ 3 * e6 * e7 * x1 +
+16 * e3 * x2 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * x1 -
+28 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * e7 * y1 * y2 -
+16 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * e7 * x1 -
+20 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * e7 * x2 -
+24 * e3 * e1 ^ 2 * x3 ^ 2 * y2 ^ 3 * y3 ^ 2 * y1 -
+16 * e3 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 -
+8 * e3 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 +
+8 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 +
+16 * e3 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 -
+8 * e3 * e6 ^ 3 * y2 * y3 * x1 * e1 - 8 * e3 * e6 ^ 3 * y2 * y3 * x2 * e1 +
+4 * e3 * e5 ^ 2 * e6 * e7 * x1 * e1 +
+8 * e3 * e5 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 +
+16 * e3 * e5 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 +
+8 * e3 * e5 * e6 ^ 2 * e7 * x1 * e1 -
+14 * e3 * e1 ^ 2 * x3 ^ 2 * e6 ^ 2 * y1 * y2 -
+14 * e3 * e1 ^ 2 * x3 ^ 2 * e7 ^ 2 * y1 * y2 +
+8 * e3 * e6 ^ 3 * e1 * x3 * y1 * y2 -
+16 * e3 * e5 * e6 * e7 * y2 * y3 * x1 * e1 -
+16 * e3 * e5 * e6 * e7 * y2 * y3 * x2 * e1 +
+40 * e3 * e1 ^ 2 * x3 ^ 2 * e6 * y2 ^ 2 * y3 * y1 +
+24 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * y2 * y3 * x1 +
+24 * e3 * e1 ^ 3 * x3 ^ 2 * e6 * y2 * y3 * x2 -
+12 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * y1 * y2 -
+12 * e3 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * x2 -
+12 * e3 * x1 * e1 ^ 2 * x3 * e7 ^ 2 * y1 * y2 -
+12 * e3 * x1 * e1 ^ 3 * x3 * e7 ^ 2 * x2 -
+20 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * y1 * y2 -
+20 * e3 * x2 * e1 ^ 2 * x3 * e7 ^ 2 * y1 * y2 +
+8 * e3 * e5 * e1 * x3 * e6 ^ 2 * y1 * y2 +
+8 * e3 * e5 * e1 * x3 * e7 ^ 2 * y1 * y2 +
+16 * e3 * y1 * y2 * e1 * x3 * e6 ^ 2 * e7 -
+16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e6 ^ 2 * y3 +
+12 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * e7 -
+16 * e3 * x1 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 +
+20 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * e7 -
+16 * e3 * x2 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 -
+4 * e3 * e5 ^ 2 * e1 * x3 * e6 * e7 +
+4 * e3 * e5 ^ 2 * e1 * x3 * e6 * y2 * y3 +
+8 * e3 * e5 * e1 * x3 * e6 ^ 2 * y2 * y3 +
+4 * e3 * e5 ^ 2 * e1 * x3 * e7 * y2 * y3 +
+4 * e3 * e6 ^ 3 * e1 * x3 * y2 * y3 +
+4 * e3 * e6 ^ 2 * e1 * x3 * e7 * y2 * y3 -
+8 * e3 * e6 ^ 2 * e1 * x3 * e7 * e5 -
+20 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 * y3 * e5 -
+20 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 * y3 * e6 +
+16 * e3 * y1 * y2 * e1 * x3 * e6 * e7 * e5 +
+8 * e3 * y1 * y2 * e1 * x3 * e7 ^ 2 * e6 -
+16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e6 * y3 * e5 -
+16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e7 * y3 * e5 -
+16 * e3 * y1 * y2 ^ 2 * e1 * x3 * e7 * y3 * e6 +
+12 * e3 * x1 * e1 ^ 2 * x3 * e6 * e7 * e5 +
+8 * e3 * x1 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e5 +
+8 * e3 * x1 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 -
+16 * e3 * x1 * e1 ^ 2 * x3 * e6 * y2 * y3 * e5 -
+16 * e3 * x1 * e1 ^ 2 * x3 * e7 * y2 * y3 * e5 -
+16 * e3 * x1 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 +
+20 * e3 * x2 * e1 ^ 2 * x3 * e6 * e7 * e5 -
+8 * e3 * x2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e5 -
+8 * e3 * x2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 -
+16 * e3 * x2 * e1 ^ 2 * x3 * e6 * y2 * y3 * e5 -
+16 * e3 * x2 * e1 ^ 2 * x3 * e7 * y2 * y3 * e5 -
+16 * e3 * x2 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 +
+8 * e3 * e5 * e1 * x3 * e7 * y2 * y3 * e6 +
+40 * e3 * e1 ^ 2 * x3 ^ 2 * e7 * y2 ^ 2 * y3 * y1 +
+24 * e3 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * x1 +
+24 * e3 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * x2 -
+8 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e6 ^ 2 -
+16 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e6 * e7 -
+24 * e3 * y1 * y2 * e1 ^ 2 * x3 * e6 * e7 * x1 -
+40 * e3 * y1 * y2 * e1 ^ 2 * x3 * e6 * e7 * x2 -
+8 * e3 * y1 ^ 2 * y2 ^ 2 * e1 * x3 * e7 ^ 2 -
+16 * e3 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * x1 +
+16 * e3 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * x2 +
+16 * e3 * y1 ^ 2 * y2 ^ 3 * e1 * x3 * e6 * y3 +
+32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 * y3 * x1 +
+32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 * y3 * x2 +
+16 * e3 * y1 ^ 2 * y2 ^ 3 * e1 * x3 * e7 * y3 +
+32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * x1 +
+32 * e3 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * x2 -
+8 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 * e7 -
+24 * e3 * x1 * e1 ^ 3 * x3 * e6 * e7 * x2 -
+8 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 +
+12 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e6 * y2 * y3 +
+24 * e3 * x1 * e1 ^ 3 * x3 * e6 * y2 * y3 * x2 +
+12 * e3 * x1 ^ 2 * e1 ^ 3 * x3 * e7 * y2 * y3 +
+24 * e3 * x1 * e1 ^ 3 * x3 * e7 * y2 * y3 * x2 -
+16 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 * e7 +
+8 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 +
+12 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e6 * y2 * y3 +
+12 * e3 * x2 ^ 2 * e1 ^ 3 * x3 * e7 * y2 * y3 - 2 * x3 ^ 5 * e1 ^ 3 * e3 ^ 3 -
+4 * x3 ^ 3 * e1 ^ 3 * e3 * e6 ^ 2 - 4 * x3 ^ 3 * e1 ^ 3 * e3 * e7 ^ 2 +
+5 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * e6 + 5 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * e7 -
+8 * x3 ^ 3 * e1 ^ 3 * e3 * e6 * e7 -
+8 * x3 ^ 3 * e1 ^ 3 * e3 * y2 ^ 2 * y3 ^ 2 -
+8 * x3 ^ 4 * e1 ^ 3 * e3 ^ 2 * y2 * y3 +
+12 * x3 ^ 3 * e1 ^ 3 * e3 * e6 * y2 * y3 +
+12 * x3 ^ 3 * e1 ^ 3 * e3 * e7 * y2 * y3 -
+8 * y2 ^ 3 * y3 * x2 * e3 * x1 ^ 2 * e1 ^ 3 -
+e6 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e6 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 -
+e7 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e7 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 -
+4 * y2 ^ 4 * y3 ^ 2 * x1 ^ 2 * e1 ^ 3 - 4 * y2 ^ 4 * y3 ^ 2 * x2 ^ 2 * e1 ^ 3 -
+4 * x2 ^ 4 * e3 ^ 2 * y2 ^ 2 * e1 ^ 3 + 2 * e6 ^ 3 * y2 ^ 2 * x1 * e1 ^ 2 +
+2 * e6 ^ 3 * y2 ^ 2 * x2 * e1 ^ 2 - y2 ^ 2 * e7 ^ 2 * e1 ^ 3 * x3 ^ 2 -
+4 * y2 ^ 4 * y3 ^ 2 * e1 ^ 3 * x3 ^ 2 - y3 ^ 2 * e6 ^ 2 * x1 ^ 2 * e1 ^ 3 -
+y3 ^ 2 * e6 ^ 2 * x2 ^ 2 * e1 ^ 3 - y3 ^ 2 * e6 ^ 2 * e1 ^ 3 * x3 ^ 2 -
+y3 ^ 2 * e7 ^ 2 * x1 ^ 2 * e1 ^ 3 - y3 ^ 2 * e7 ^ 2 * x2 ^ 2 * e1 ^ 3 -
+y3 ^ 2 * e7 ^ 2 * e1 ^ 3 * x3 ^ 2 - 4 * y2 ^ 2 * y3 ^ 4 * x1 ^ 2 * e1 ^ 3 -
+4 * y2 ^ 2 * y3 ^ 4 * x2 ^ 2 * e1 ^ 3 - 4 * y2 ^ 2 * y3 ^ 4 * e1 ^ 3 * x3 ^ 2 -
+e4 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 - e4 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 -
+e4 ^ 2 * y2 ^ 2 * e1 ^ 3 * x3 ^ 2 - e4 ^ 2 * y1 ^ 2 * x1 ^ 2 * e1 ^ 3 -
+e4 ^ 2 * y1 ^ 2 * x2 ^ 2 * e1 ^ 3 - e4 ^ 2 * y1 ^ 2 * e1 ^ 3 * x3 ^ 2 -
+y2 ^ 2 * x3 ^ 4 * e3 ^ 2 * e1 ^ 3 - 4 * y3 ^ 2 * x2 ^ 4 * e3 ^ 2 * e1 ^ 3 -
+y3 ^ 2 * x3 ^ 4 * e3 ^ 2 * e1 ^ 3 + 2 * y2 ^ 2 * e6 ^ 3 * e1 ^ 2 * x3 +
+2 * y3 ^ 2 * e6 ^ 3 * x1 * e1 ^ 2 + 2 * y3 ^ 2 * e6 ^ 3 * x2 * e1 ^ 2 +
+2 * y3 ^ 2 * e6 ^ 3 * e1 ^ 2 * x3 - 2 * e1 * e6 ^ 3 * y2 ^ 2 * e5 +
+4 * e1 * e6 ^ 3 * y2 ^ 3 * y1 - e1 * e6 ^ 2 * y2 ^ 2 * e5 ^ 2 -
+4 * e1 * e6 ^ 2 * y1 ^ 2 * y2 ^ 4 - 2 * e1 * e6 ^ 3 * e7 * y2 ^ 2 -
+e1 * e7 ^ 2 * y2 ^ 2 * e5 ^ 2 - e1 * e7 ^ 2 * y2 ^ 2 * e6 ^ 2 -
+4 * e1 * e7 ^ 2 * y1 ^ 2 * y2 ^ 4 - 4 * e1 * y2 ^ 4 * y3 ^ 2 * e5 ^ 2 -
+4 * e1 * y2 ^ 4 * y3 ^ 2 * e6 ^ 2 - 16 * e1 * y2 ^ 6 * y3 ^ 2 * y1 ^ 2 +
+4 * e1 * e6 ^ 3 * y2 ^ 3 * y3 - 8 * e1 * e4 ^ 2 * y2 ^ 3 * y1 ^ 3 +
+4 * e1 * e6 ^ 3 * y2 ^ 2 * y3 ^ 2 - 4 * e1 * e6 ^ 4 * y2 * y3 -
+e1 * y3 ^ 2 * e6 ^ 2 * e5 ^ 2 - 2 * e1 * y3 ^ 2 * e6 ^ 3 * e5 -
+e1 * y3 ^ 2 * e7 ^ 2 * e6 ^ 2 - e1 * y3 ^ 2 * e7 ^ 2 * e5 ^ 2 -
+4 * e1 * y2 ^ 2 * y3 ^ 4 * e6 ^ 2 - 4 * e1 * y2 ^ 2 * y3 ^ 4 * e5 ^ 2 -
+8 * y2 ^ 3 * y3 * x2 ^ 3 * e3 * e1 ^ 3 - e1 * e6 ^ 4 * y2 ^ 2 -
+4 * y2 ^ 3 * y3 * x3 * e3 * x1 ^ 2 * e1 ^ 3 -
+20 * y2 ^ 3 * y3 * x3 * e3 * x2 ^ 2 * e1 ^ 3 -
+16 * y2 ^ 3 * y3 * e3 * x1 * x2 ^ 2 * e1 ^ 3 -
+2 * e6 * e7 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 -
+2 * e6 * e7 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 -
+4 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 -
+x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 -
+13 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 +
+16 * y2 ^ 3 * y3 * x2 * e3 * e5 * x1 * e1 ^ 2 +
+16 * y2 ^ 3 * y3 * x2 ^ 2 * e3 * e5 * e1 ^ 2 +
+2 * e6 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 -
+32 * y2 ^ 4 * y3 * x2 * e3 * y1 * x1 * e1 ^ 2 -
+32 * y2 ^ 4 * y3 * x2 ^ 2 * e3 * y1 * e1 ^ 2 +
+8 * y2 ^ 3 * y3 * x3 * e3 * e5 * x1 * e1 ^ 2 +
+24 * y2 ^ 3 * y3 * x3 * e3 * e5 * x2 * e1 ^ 2 +
+8 * y2 ^ 3 * y3 * x3 * e3 * e6 * x1 * e1 ^ 2 +
+24 * y2 ^ 3 * y3 * x3 * e3 * e6 * x2 * e1 ^ 2 -
+16 * y2 ^ 4 * y3 * x3 * e3 * y1 * x1 * e1 ^ 2 -
+48 * y2 ^ 4 * y3 * x3 * e3 * y1 * x2 * e1 ^ 2 -
+24 * y2 ^ 3 * y3 * x3 * e3 * x1 * e1 ^ 3 * x2 +
+2 * e6 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 -
+4 * e6 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 -
+4 * e6 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 -
+2 * e6 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 +
+4 * e6 * e7 * y2 ^ 2 * e5 * x1 * e1 ^ 2 +
+4 * e6 * e7 * y2 ^ 2 * e5 * x2 * e1 ^ 2 +
+4 * e6 ^ 2 * e7 * y2 ^ 2 * x1 * e1 ^ 2 +
+4 * e6 ^ 2 * e7 * y2 ^ 2 * x2 * e1 ^ 2 -
+8 * e6 * e7 * y1 * y2 ^ 3 * x1 * e1 ^ 2 -
+8 * e6 * e7 * y1 * y2 ^ 3 * x2 * e1 ^ 2 -
+4 * e6 * e7 * y2 ^ 2 * x1 * e1 ^ 3 * x2 +
+2 * e7 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 +
+2 * e7 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 +
+2 * e7 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 +
+2 * e7 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 - y2 ^ 2 * e6 ^ 2 * e1 ^ 3 * x3 ^ 2 -
+4 * e7 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 -
+4 * e7 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 -
+2 * e7 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 +
+16 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x1 * e1 ^ 2 +
+16 * y2 ^ 3 * y3 ^ 2 * y1 * e6 * x2 * e1 ^ 2 +
+8 * y2 ^ 4 * y3 ^ 2 * e5 * x1 * e1 ^ 2 +
+8 * y2 ^ 4 * y3 ^ 2 * e5 * x2 * e1 ^ 2 +
+8 * y2 ^ 4 * y3 ^ 2 * e6 * x1 * e1 ^ 2 +
+8 * y2 ^ 4 * y3 ^ 2 * e6 * x2 * e1 ^ 2 -
+16 * y2 ^ 5 * y3 ^ 2 * y1 * x1 * e1 ^ 2 -
+16 * y2 ^ 5 * y3 ^ 2 * y1 * x2 * e1 ^ 2 -
+8 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 3 * x2 +
+8 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 +
+8 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * e5 * e1 ^ 2 -
+16 * x2 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 -
+16 * x2 ^ 3 * e3 ^ 2 * y1 * y2 ^ 3 * e1 ^ 2 -
+8 * x2 ^ 3 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 +
+2 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 +
+10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 +
+2 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 +
+10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 -
+4 * x3 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x1 * e1 ^ 2 -
+20 * x3 ^ 2 * e3 ^ 2 * y1 * y2 ^ 3 * x2 * e1 ^ 2 -
+10 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 -
+4 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 -
+12 * x2 ^ 3 * e3 ^ 2 * x3 * y2 ^ 2 * e1 ^ 3 -
+16 * x3 * e3 ^ 2 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 +
+4 * e6 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 3 +
+4 * e6 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 3 +
+4 * e6 * x2 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 +
+4 * e6 * x2 ^ 3 * e3 * y2 ^ 2 * e1 ^ 3 +
+2 * e6 * x3 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 +
+10 * e6 * x3 * e3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 +
+8 * e6 * e3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 +
+4 * e7 * y2 ^ 3 * y3 * x1 ^ 2 * e1 ^ 3 +
+4 * e7 * y2 ^ 3 * y3 * x2 ^ 2 * e1 ^ 3 +
+4 * e7 * x2 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 +
+4 * e7 * x2 ^ 3 * e3 * y2 ^ 2 * e1 ^ 3 +
+2 * e7 * x3 * e3 * y2 ^ 2 * x1 ^ 2 * e1 ^ 3 +
+10 * e7 * x3 * e3 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 +
+8 * e7 * e3 * x1 * y2 ^ 2 * x2 ^ 2 * e1 ^ 3 +
+8 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 +
+16 * x2 ^ 2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 * e1 ^ 2 -
+16 * x2 * e3 ^ 2 * x3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 -
+32 * x2 ^ 2 * e3 ^ 2 * x3 * y1 * y2 ^ 3 * e1 ^ 2 -
+16 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x1 * e1 ^ 2 -
+16 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * x2 * e1 ^ 2 -
+8 * e6 * y2 ^ 3 * y3 * e5 * x1 * e1 ^ 2 -
+8 * e6 * y2 ^ 3 * y3 * e5 * x2 * e1 ^ 2 -
+8 * e6 ^ 2 * y2 ^ 3 * y3 * x1 * e1 ^ 2 -
+8 * e6 ^ 2 * y2 ^ 3 * y3 * x2 * e1 ^ 2 +
+16 * e6 * y2 ^ 4 * y3 * y1 * x1 * e1 ^ 2 +
+16 * e6 * y2 ^ 4 * y3 * y1 * x2 * e1 ^ 2 +
+8 * e6 * y2 ^ 3 * y3 * x1 * e1 ^ 3 * x2 -
+8 * e6 * x2 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 -
+8 * e6 * x2 ^ 2 * e3 * y2 ^ 2 * e5 * e1 ^ 2 +
+16 * e6 * x2 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 +
+16 * e6 * x2 ^ 2 * e3 * y1 * y2 ^ 3 * e1 ^ 2 -
+4 * e6 * x3 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 -
+12 * e6 * x3 * e3 * y2 ^ 2 * e5 * x2 * e1 ^ 2 -
+4 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 2 -
+12 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * x2 * e1 ^ 2 +
+8 * e6 * x3 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 +
+24 * e6 * x3 * e3 * y1 * y2 ^ 3 * x2 * e1 ^ 2 +
+12 * e6 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 3 * x2 -
+32 * e7 * y2 ^ 2 * y3 * y1 * e6 * x1 * e1 ^ 2 -
+32 * e7 * y2 ^ 2 * y3 * y1 * e6 * x2 * e1 ^ 2 -
+8 * e7 * y2 ^ 3 * y3 * e5 * x1 * e1 ^ 2 -
+8 * e7 * y2 ^ 3 * y3 * e5 * x2 * e1 ^ 2 -
+8 * e7 * y2 ^ 3 * y3 * e6 * x1 * e1 ^ 2 -
+8 * e7 * y2 ^ 3 * y3 * e6 * x2 * e1 ^ 2 +
+16 * e7 * y2 ^ 4 * y3 * y1 * x1 * e1 ^ 2 +
+16 * e7 * y2 ^ 4 * y3 * y1 * x2 * e1 ^ 2 +
+8 * e7 * y2 ^ 3 * y3 * x1 * e1 ^ 3 * x2 -
+8 * e7 * x2 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 -
+8 * e7 * x2 ^ 2 * e3 * y2 ^ 2 * e5 * e1 ^ 2 +
+16 * e7 * x2 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 +
+16 * e7 * x2 ^ 2 * e3 * y1 * y2 ^ 3 * e1 ^ 2 -
+4 * e7 * x3 * e3 * y2 ^ 2 * e5 * x1 * e1 ^ 2 -
+12 * e7 * x3 * e3 * y2 ^ 2 * e5 * x2 * e1 ^ 2 -
+4 * e7 * x3 * e3 * y2 ^ 2 * e6 * x1 * e1 ^ 2 -
+12 * e7 * x3 * e3 * y2 ^ 2 * e6 * x2 * e1 ^ 2 +
+8 * e7 * x3 * e3 * y1 * y2 ^ 3 * x1 * e1 ^ 2 +
+24 * e7 * x3 * e3 * y1 * y2 ^ 3 * x2 * e1 ^ 2 +
+12 * e7 * x3 * e3 * y2 ^ 2 * x1 * e1 ^ 3 * x2 -
+8 * x1 * e1 ^ 3 * x2 * e6 ^ 2 * y2 * y3 -
+4 * x1 ^ 2 * e1 ^ 3 * e6 ^ 2 * y2 * y3 -
+4 * x2 ^ 2 * e1 ^ 3 * e6 ^ 2 * y2 * y3 -
+4 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * y2 * y3 +
+4 * x1 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * e6 +
+4 * x2 ^ 2 * e1 ^ 3 * y2 ^ 2 * y3 ^ 2 * e6 +
+4 * e1 ^ 3 * x3 ^ 2 * y2 ^ 2 * y3 ^ 2 * e6 +
+8 * x1 * e1 ^ 3 * x2 * y2 ^ 2 * y3 ^ 2 * e6 -
+16 * x1 * e1 ^ 3 * x2 * e7 * y2 * y3 * e6 -
+8 * x1 ^ 2 * e1 ^ 3 * e7 * y2 * y3 * e6 -
+8 * x2 ^ 2 * e1 ^ 3 * e7 * y2 * y3 * e6 +
+16 * e6 ^ 2 * e7 * y2 * y3 * x1 * e1 ^ 2 +
+16 * e6 ^ 2 * e7 * y2 * y3 * x2 * e1 ^ 2 -
+8 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x1 * e1 ^ 2 -
+8 * e5 * e6 * y2 ^ 2 * y3 ^ 2 * x2 * e1 ^ 2 +
+8 * e5 * e6 ^ 2 * y2 * y3 * x1 * e1 ^ 2 +
+8 * e5 * e6 ^ 2 * y2 * y3 * x2 * e1 ^ 2 -
+8 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x1 * e1 ^ 2 -
+8 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 * x2 * e1 ^ 2 +
+8 * e6 ^ 3 * y2 * y3 * x1 * e1 ^ 2 + 8 * e6 ^ 3 * y2 * y3 * x2 * e1 ^ 2 +
+16 * e5 * e6 * e7 * y2 * y3 * x1 * e1 ^ 2 +
+16 * e5 * e6 * e7 * y2 * y3 * x2 * e1 ^ 2 -
+16 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e6 ^ 2 * y3 -
+8 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * y2 * y3 -
+8 * x2 * e1 ^ 3 * x3 * e6 ^ 2 * y2 * y3 +
+8 * e5 * e1 ^ 2 * x3 * e6 ^ 2 * y2 * y3 -
+8 * e6 ^ 2 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 +
+8 * e6 ^ 3 * e1 ^ 2 * x3 * y2 * y3 + 16 * e6 ^ 2 * e1 ^ 2 * x3 * e7 * y2 * y3 -
+8 * e1 ^ 3 * x3 ^ 2 * e7 * y2 * y3 * e6 +
+16 * y1 * y2 ^ 3 * e1 ^ 2 * x3 * y3 ^ 2 * e6 -
+32 * y1 * y2 ^ 2 * e1 ^ 2 * x3 * e7 * y3 * e6 +
+8 * x1 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 * e6 -
+16 * x1 * e1 ^ 3 * x3 * e7 * y2 * y3 * e6 +
+8 * x2 * e1 ^ 3 * x3 * y2 ^ 2 * y3 ^ 2 * e6 -
+16 * x2 * e1 ^ 3 * x3 * e7 * y2 * y3 * e6 -
+8 * e5 * e1 ^ 2 * x3 * y2 ^ 2 * y3 ^ 2 * e6 +
+16 * e5 * e1 ^ 2 * x3 * e7 * y2 * y3 * e6 -
+2 * y3 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x2 -
+4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * x1 * e1 ^ 2 -
+4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * x2 * e1 ^ 2 -
+2 * y3 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x2 -
+4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * x1 * e1 ^ 2 -
+4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * x2 * e1 ^ 2 -
+8 * y2 ^ 2 * y3 ^ 4 * x1 * e1 ^ 3 * x2 -
+16 * y2 ^ 3 * y3 ^ 4 * y1 * x1 * e1 ^ 2 -
+16 * y2 ^ 3 * y3 ^ 4 * y1 * x2 * e1 ^ 2 -
+2 * e4 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x2 -
+4 * e4 ^ 2 * y2 ^ 3 * y1 * x1 * e1 ^ 2 -
+4 * e4 ^ 2 * y2 ^ 3 * y1 * x2 * e1 ^ 2 -
+2 * e4 ^ 2 * y1 ^ 2 * x1 * e1 ^ 3 * x2 -
+4 * e4 ^ 2 * y1 ^ 3 * y2 * x1 * e1 ^ 2 -
+4 * e4 ^ 2 * y1 ^ 3 * y2 * x2 * e1 ^ 2 -
+2 * y2 ^ 2 * e6 * e7 * e1 ^ 3 * x3 ^ 2 +
+4 * y2 ^ 3 * e6 * y3 * e1 ^ 3 * x3 ^ 2 -
+4 * y2 ^ 2 * e6 * e4 * x1 * e1 ^ 3 * x2 -
+2 * y2 ^ 2 * e6 * e4 * x1 ^ 2 * e1 ^ 3 -
+2 * y2 ^ 2 * e6 * e4 * x2 ^ 2 * e1 ^ 3 -
+2 * y2 ^ 2 * e6 * e4 * e1 ^ 3 * x3 ^ 2 -
+8 * y2 ^ 3 * e6 * e4 * y1 * x1 * e1 ^ 2 -
+8 * y2 ^ 3 * e6 * e4 * y1 * x2 * e1 ^ 2 +
+4 * y2 ^ 3 * e7 * y3 * e1 ^ 3 * x3 ^ 2 -
+8 * y2 * e7 ^ 2 * y3 * x1 * e1 ^ 3 * x2 -
+4 * y2 * e7 ^ 2 * y3 * x1 ^ 2 * e1 ^ 3 -
+4 * y2 * e7 ^ 2 * y3 * x2 ^ 2 * e1 ^ 3 -
+4 * y2 * e7 ^ 2 * y3 * e1 ^ 3 * x3 ^ 2 -
+16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * x1 * e1 ^ 2 -
+16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * x2 * e1 ^ 2 +
+8 * y2 ^ 2 * e7 * y3 ^ 2 * x1 * e1 ^ 3 * x2 +
+4 * y2 ^ 2 * e7 * y3 ^ 2 * x1 ^ 2 * e1 ^ 3 +
+4 * y2 ^ 2 * e7 * y3 ^ 2 * x2 ^ 2 * e1 ^ 3 +
+4 * y2 ^ 2 * e7 * y3 ^ 2 * e1 ^ 3 * x3 ^ 2 +
+16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * x1 * e1 ^ 2 +
+16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * x2 * e1 ^ 2 -
+4 * y2 ^ 2 * e7 * e4 * x1 * e1 ^ 3 * x2 -
+2 * y2 ^ 2 * e7 * e4 * x1 ^ 2 * e1 ^ 3 -
+2 * y2 ^ 2 * e7 * e4 * x2 ^ 2 * e1 ^ 3 -
+2 * y2 ^ 2 * e7 * e4 * e1 ^ 3 * x3 ^ 2 -
+8 * y2 ^ 3 * e7 * e4 * y1 * x1 * e1 ^ 2 -
+8 * y2 ^ 3 * e7 * e4 * y1 * x2 * e1 ^ 2 +
+8 * y2 ^ 3 * y3 * e4 * x1 * e1 ^ 3 * x2 +
+4 * y2 ^ 3 * y3 * e4 * x1 ^ 2 * e1 ^ 3 +
+4 * y2 ^ 3 * y3 * e4 * x2 ^ 2 * e1 ^ 3 +
+4 * y2 ^ 3 * y3 * e4 * e1 ^ 3 * x3 ^ 2 +
+16 * y2 ^ 4 * y3 * e4 * y1 * x1 * e1 ^ 2 +
+16 * y2 ^ 4 * y3 * e4 * y1 * x2 * e1 ^ 2 -
+4 * y3 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x2 -
+2 * y3 ^ 2 * e6 * e7 * x1 ^ 2 * e1 ^ 3 -
+2 * y3 ^ 2 * e6 * e7 * x2 ^ 2 * e1 ^ 3 -
+2 * y3 ^ 2 * e6 * e7 * e1 ^ 3 * x3 ^ 2 -
+8 * y3 ^ 2 * e6 * e7 * y1 * y2 * x1 * e1 ^ 2 -
+8 * y3 ^ 2 * e6 * e7 * y1 * y2 * x2 * e1 ^ 2 +
+8 * y3 ^ 3 * e6 * y2 * x1 * e1 ^ 3 * x2 +
+4 * y3 ^ 3 * e6 * y2 * x1 ^ 2 * e1 ^ 3 +
+4 * y3 ^ 3 * e6 * y2 * x2 ^ 2 * e1 ^ 3 +
+4 * y3 ^ 3 * e6 * y2 * e1 ^ 3 * x3 ^ 2 +
+16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * x1 * e1 ^ 2 +
+16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * x2 * e1 ^ 2 +
+8 * y3 ^ 3 * e7 * y2 * x1 * e1 ^ 3 * x2 +
+4 * y3 ^ 3 * e7 * y2 * x1 ^ 2 * e1 ^ 3 +
+4 * y3 ^ 3 * e7 * y2 * x2 ^ 2 * e1 ^ 3 +
+4 * y3 ^ 3 * e7 * y2 * e1 ^ 3 * x3 ^ 2 +
+16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * x1 * e1 ^ 2 +
+16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * x2 * e1 ^ 2 -
+8 * y2 ^ 2 * y3 ^ 2 * e4 * x1 * e1 ^ 3 * x2 -
+4 * y2 ^ 2 * y3 ^ 2 * e4 * x1 ^ 2 * e1 ^ 3 -
+4 * y2 ^ 2 * y3 ^ 2 * e4 * x2 ^ 2 * e1 ^ 3 -
+4 * y2 ^ 2 * y3 ^ 2 * e4 * e1 ^ 3 * x3 ^ 2 -
+16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 2 -
+16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * x2 * e1 ^ 2 -
+8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 -
+4 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 3 -
+13 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e1 ^ 3 * x3 ^ 2 -
+16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * x1 * e1 ^ 2 -
+16 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * y1 * y2 * e1 ^ 2 -
+10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * x1 * e1 ^ 3 * x2 -
+y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * x1 ^ 2 * e1 ^ 3 -
+4 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 * y2 * x1 * e1 ^ 2 -
+20 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 * y2 * x2 * e1 ^ 2 +
+8 * y2 ^ 2 * e6 * x2 * e3 * e1 ^ 3 * x3 ^ 2 +
+2 * y2 ^ 2 * e6 * x3 ^ 3 * e3 * e1 ^ 3 -
+4 * y2 * e6 * e4 * y1 * x1 * e1 ^ 3 * x2 -
+2 * y2 * e6 * e4 * y1 * x1 ^ 2 * e1 ^ 3 -
+2 * y2 * e6 * e4 * y1 * x2 ^ 2 * e1 ^ 3 -
+2 * y2 * e6 * e4 * y1 * e1 ^ 3 * x3 ^ 2 -
+8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * x1 * e1 ^ 2 -
+8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * x2 * e1 ^ 2 +
+8 * y2 ^ 2 * e7 * x2 * e3 * e1 ^ 3 * x3 ^ 2 +
+2 * y2 ^ 2 * e7 * x3 ^ 3 * e3 * e1 ^ 3 -
+4 * y2 * e7 * e4 * y1 * x1 * e1 ^ 3 * x2 -
+2 * y2 * e7 * e4 * y1 * x1 ^ 2 * e1 ^ 3 -
+2 * y2 * e7 * e4 * y1 * x2 ^ 2 * e1 ^ 3 -
+2 * y2 * e7 * e4 * y1 * e1 ^ 3 * x3 ^ 2 -
+8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * x1 * e1 ^ 2 -
+8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * x2 * e1 ^ 2 -
+4 * y2 ^ 3 * e6 ^ 2 * y1 * e1 ^ 2 * x3 -
+2 * y2 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x3 -
+2 * y2 ^ 2 * e6 ^ 2 * x2 * e1 ^ 3 * x3 +
+2 * y2 ^ 2 * e6 ^ 2 * e5 * e1 ^ 2 * x3 -
+4 * y2 ^ 3 * e7 ^ 2 * y1 * e1 ^ 2 * x3 -
+2 * y2 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x3 -
+2 * y2 ^ 2 * e7 ^ 2 * x2 * e1 ^ 3 * x3 +
+2 * y2 ^ 2 * e7 ^ 2 * e5 * e1 ^ 2 * x3 +
+2 * y2 ^ 2 * e7 ^ 2 * e6 * e1 ^ 2 * x3 -
+16 * y2 ^ 5 * y3 ^ 2 * y1 * e1 ^ 2 * x3 -
+8 * y2 ^ 4 * y3 ^ 2 * x1 * e1 ^ 3 * x3 -
+8 * y2 ^ 4 * y3 ^ 2 * x2 * e1 ^ 3 * x3 +
+8 * y2 ^ 4 * y3 ^ 2 * e5 * e1 ^ 2 * x3 +
+8 * y2 ^ 4 * y3 ^ 2 * e6 * e1 ^ 2 * x3 -
+4 * y3 ^ 2 * e6 ^ 2 * y1 * y2 * e1 ^ 2 * x3 -
+2 * y3 ^ 2 * e6 ^ 2 * x1 * e1 ^ 3 * x3 -
+2 * y3 ^ 2 * e6 ^ 2 * x2 * e1 ^ 3 * x3 +
+2 * y3 ^ 2 * e6 ^ 2 * e5 * x1 * e1 ^ 2 +
+2 * y3 ^ 2 * e6 ^ 2 * e5 * x2 * e1 ^ 2 +
+2 * y3 ^ 2 * e6 ^ 2 * e5 * e1 ^ 2 * x3 -
+4 * y3 ^ 2 * e7 ^ 2 * y1 * y2 * e1 ^ 2 * x3 -
+2 * y3 ^ 2 * e7 ^ 2 * x1 * e1 ^ 3 * x3 -
+2 * y3 ^ 2 * e7 ^ 2 * x2 * e1 ^ 3 * x3 +
+2 * y3 ^ 2 * e7 ^ 2 * e5 * x1 * e1 ^ 2 +
+2 * y3 ^ 2 * e7 ^ 2 * e5 * x2 * e1 ^ 2 +
+2 * y3 ^ 2 * e7 ^ 2 * e5 * e1 ^ 2 * x3 +
+2 * y3 ^ 2 * e7 ^ 2 * e6 * x1 * e1 ^ 2 +
+2 * y3 ^ 2 * e7 ^ 2 * e6 * x2 * e1 ^ 2 +
+2 * y3 ^ 2 * e7 ^ 2 * e6 * e1 ^ 2 * x3 -
+16 * y2 ^ 3 * y3 ^ 4 * y1 * e1 ^ 2 * x3 -
+8 * y2 ^ 2 * y3 ^ 4 * x1 * e1 ^ 3 * x3 -
+8 * y2 ^ 2 * y3 ^ 4 * x2 * e1 ^ 3 * x3 +
+8 * y2 ^ 2 * y3 ^ 4 * e5 * x1 * e1 ^ 2 +
+8 * y2 ^ 2 * y3 ^ 4 * e5 * x2 * e1 ^ 2 +
+8 * y2 ^ 2 * y3 ^ 4 * e5 * e1 ^ 2 * x3 +
+8 * y2 ^ 2 * y3 ^ 4 * e6 * x1 * e1 ^ 2 +
+8 * y2 ^ 2 * y3 ^ 4 * e6 * x2 * e1 ^ 2 +
+8 * y2 ^ 2 * y3 ^ 4 * e6 * e1 ^ 2 * x3 -
+4 * e4 ^ 2 * y2 ^ 3 * y1 * e1 ^ 2 * x3 -
+2 * e4 ^ 2 * y2 ^ 2 * x1 * e1 ^ 3 * x3 -
+2 * e4 ^ 2 * y2 ^ 2 * x2 * e1 ^ 3 * x3 +
+2 * e4 ^ 2 * y2 ^ 2 * e5 * x1 * e1 ^ 2 +
+2 * e4 ^ 2 * y2 ^ 2 * e5 * x2 * e1 ^ 2 +
+2 * e4 ^ 2 * y2 ^ 2 * e5 * e1 ^ 2 * x3 +
+2 * e4 ^ 2 * y2 ^ 2 * e6 * x1 * e1 ^ 2 +
+2 * e4 ^ 2 * y2 ^ 2 * e6 * x2 * e1 ^ 2 +
+2 * e4 ^ 2 * y2 ^ 2 * e6 * e1 ^ 2 * x3 -
+4 * e4 ^ 2 * y1 ^ 3 * y2 * e1 ^ 2 * x3 -
+2 * e4 ^ 2 * y1 ^ 2 * x1 * e1 ^ 3 * x3 -
+2 * e4 ^ 2 * y1 ^ 2 * x2 * e1 ^ 3 * x3 +
+2 * e4 ^ 2 * y1 ^ 2 * e5 * x1 * e1 ^ 2 +
+2 * e4 ^ 2 * y1 ^ 2 * e5 * x2 * e1 ^ 2 +
+2 * e4 ^ 2 * y1 ^ 2 * e5 * e1 ^ 2 * x3 +
+2 * e4 ^ 2 * y1 ^ 2 * e6 * x1 * e1 ^ 2 +
+2 * e4 ^ 2 * y1 ^ 2 * e6 * x2 * e1 ^ 2 +
+2 * e4 ^ 2 * y1 ^ 2 * e6 * e1 ^ 2 * x3 -
+8 * y2 ^ 3 * e6 * e7 * y1 * e1 ^ 2 * x3 -
+4 * y2 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x3 -
+4 * y2 ^ 2 * e6 * e7 * x2 * e1 ^ 3 * x3 +
+4 * y2 ^ 2 * e6 * e7 * e5 * e1 ^ 2 * x3 +
+4 * y2 ^ 2 * e6 ^ 2 * e7 * e1 ^ 2 * x3 +
+16 * y2 ^ 4 * e6 * y3 * y1 * e1 ^ 2 * x3 +
+8 * y2 ^ 3 * e6 * y3 * x1 * e1 ^ 3 * x3 +
+8 * y2 ^ 3 * e6 * y3 * x2 * e1 ^ 3 * x3 -
+8 * y2 ^ 3 * e6 * y3 * e5 * e1 ^ 2 * x3 -
+8 * y2 ^ 3 * e6 ^ 2 * y3 * e1 ^ 2 * x3 -
+8 * y2 ^ 3 * e6 * e4 * y1 * e1 ^ 2 * x3 -
+4 * y2 ^ 2 * e6 * e4 * x1 * e1 ^ 3 * x3 -
+4 * y2 ^ 2 * e6 * e4 * x2 * e1 ^ 3 * x3 +
+4 * y2 ^ 2 * e6 * e4 * e5 * x1 * e1 ^ 2 +
+4 * y2 ^ 2 * e6 * e4 * e5 * x2 * e1 ^ 2 +
+4 * y2 ^ 2 * e6 * e4 * e5 * e1 ^ 2 * x3 +
+4 * y2 ^ 2 * e6 ^ 2 * e4 * x1 * e1 ^ 2 +
+4 * y2 ^ 2 * e6 ^ 2 * e4 * x2 * e1 ^ 2 +
+4 * y2 ^ 2 * e6 ^ 2 * e4 * e1 ^ 2 * x3 +
+16 * y2 ^ 4 * e7 * y3 * y1 * e1 ^ 2 * x3 +
+8 * y2 ^ 3 * e7 * y3 * x1 * e1 ^ 3 * x3 +
+8 * y2 ^ 3 * e7 * y3 * x2 * e1 ^ 3 * x3 -
+8 * y2 ^ 3 * e7 * y3 * e5 * e1 ^ 2 * x3 -
+8 * y2 ^ 3 * e7 * y3 * e6 * e1 ^ 2 * x3 -
+16 * y2 ^ 2 * e7 ^ 2 * y3 * y1 * e1 ^ 2 * x3 -
+8 * y2 * e7 ^ 2 * y3 * x1 * e1 ^ 3 * x3 -
+8 * y2 * e7 ^ 2 * y3 * x2 * e1 ^ 3 * x3 +
+8 * y2 * e7 ^ 2 * y3 * e5 * x1 * e1 ^ 2 +
+8 * y2 * e7 ^ 2 * y3 * e5 * x2 * e1 ^ 2 +
+8 * y2 * e7 ^ 2 * y3 * e5 * e1 ^ 2 * x3 +
+8 * y2 * e7 ^ 2 * y3 * e6 * x1 * e1 ^ 2 +
+8 * y2 * e7 ^ 2 * y3 * e6 * x2 * e1 ^ 2 +
+8 * y2 * e7 ^ 2 * y3 * e6 * e1 ^ 2 * x3 +
+16 * y2 ^ 3 * e7 * y3 ^ 2 * y1 * e1 ^ 2 * x3 +
+8 * y2 ^ 2 * e7 * y3 ^ 2 * x1 * e1 ^ 3 * x3 +
+8 * y2 ^ 2 * e7 * y3 ^ 2 * x2 * e1 ^ 3 * x3 -
+8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * x1 * e1 ^ 2 -
+8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * x2 * e1 ^ 2 -
+8 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * e1 ^ 2 * x3 -
+8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * x1 * e1 ^ 2 -
+8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * x2 * e1 ^ 2 -
+8 * y2 ^ 2 * e7 * y3 ^ 2 * e6 * e1 ^ 2 * x3 -
+8 * y2 ^ 3 * e7 * e4 * y1 * e1 ^ 2 * x3 -
+4 * y2 ^ 2 * e7 * e4 * x1 * e1 ^ 3 * x3 -
+4 * y2 ^ 2 * e7 * e4 * x2 * e1 ^ 3 * x3 +
+4 * y2 ^ 2 * e7 * e4 * e5 * x1 * e1 ^ 2 +
+4 * y2 ^ 2 * e7 * e4 * e5 * x2 * e1 ^ 2 +
+4 * y2 ^ 2 * e7 * e4 * e5 * e1 ^ 2 * x3 +
+4 * y2 ^ 2 * e7 * e4 * e6 * x1 * e1 ^ 2 +
+4 * y2 ^ 2 * e7 * e4 * e6 * x2 * e1 ^ 2 +
+4 * y2 ^ 2 * e7 * e4 * e6 * e1 ^ 2 * x3 +
+16 * y2 ^ 4 * y3 * e4 * y1 * e1 ^ 2 * x3 +
+8 * y2 ^ 3 * y3 * e4 * x1 * e1 ^ 3 * x3 +
+8 * y2 ^ 3 * y3 * e4 * x2 * e1 ^ 3 * x3 -
+8 * y2 ^ 3 * y3 * e4 * e5 * x1 * e1 ^ 2 -
+8 * y2 ^ 3 * y3 * e4 * e5 * x2 * e1 ^ 2 -
+8 * y2 ^ 3 * y3 * e4 * e5 * e1 ^ 2 * x3 -
+8 * y2 ^ 3 * y3 * e4 * e6 * x1 * e1 ^ 2 -
+8 * y2 ^ 3 * y3 * e4 * e6 * x2 * e1 ^ 2 -
+8 * y2 ^ 3 * y3 * e4 * e6 * e1 ^ 2 * x3 -
+4 * y2 ^ 3 * x3 ^ 3 * e3 ^ 2 * y1 * e1 ^ 2 -
+2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 -
+6 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * x2 * e1 ^ 3 +
+2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 +
+2 * y2 ^ 2 * x3 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 -
+8 * y3 ^ 2 * e6 * e7 * y1 * y2 * e1 ^ 2 * x3 -
+4 * y3 ^ 2 * e6 * e7 * x1 * e1 ^ 3 * x3 -
+4 * y3 ^ 2 * e6 * e7 * x2 * e1 ^ 3 * x3 +
+4 * y3 ^ 2 * e6 * e7 * e5 * x1 * e1 ^ 2 +
+4 * y3 ^ 2 * e6 * e7 * e5 * x2 * e1 ^ 2 +
+4 * y3 ^ 2 * e6 * e7 * e5 * e1 ^ 2 * x3 +
+4 * y3 ^ 2 * e6 ^ 2 * e7 * x1 * e1 ^ 2 +
+4 * y3 ^ 2 * e6 ^ 2 * e7 * x2 * e1 ^ 2 +
+4 * y3 ^ 2 * e6 ^ 2 * e7 * e1 ^ 2 * x3 +
+16 * y3 ^ 3 * e6 * y2 ^ 2 * y1 * e1 ^ 2 * x3 +
+8 * y3 ^ 3 * e6 * y2 * x1 * e1 ^ 3 * x3 +
+8 * y3 ^ 3 * e6 * y2 * x2 * e1 ^ 3 * x3 -
+8 * y3 ^ 3 * e6 * y2 * e5 * x1 * e1 ^ 2 -
+8 * y3 ^ 3 * e6 * y2 * e5 * x2 * e1 ^ 2 -
+8 * y3 ^ 3 * e6 * y2 * e5 * e1 ^ 2 * x3 -
+8 * y3 ^ 3 * e6 ^ 2 * y2 * x1 * e1 ^ 2 -
+8 * y3 ^ 3 * e6 ^ 2 * y2 * x2 * e1 ^ 2 -
+8 * y3 ^ 3 * e6 ^ 2 * y2 * e1 ^ 2 * x3 +
+16 * y3 ^ 3 * e7 * y2 ^ 2 * y1 * e1 ^ 2 * x3 +
+8 * y3 ^ 3 * e7 * y2 * x1 * e1 ^ 3 * x3 +
+8 * y3 ^ 3 * e7 * y2 * x2 * e1 ^ 3 * x3 -
+8 * y3 ^ 3 * e7 * y2 * e5 * x1 * e1 ^ 2 -
+8 * y3 ^ 3 * e7 * y2 * e5 * x2 * e1 ^ 2 -
+8 * y3 ^ 3 * e7 * y2 * e5 * e1 ^ 2 * x3 -
+8 * y3 ^ 3 * e7 * y2 * e6 * x1 * e1 ^ 2 -
+8 * y3 ^ 3 * e7 * y2 * e6 * x2 * e1 ^ 2 -
+8 * y3 ^ 3 * e7 * y2 * e6 * e1 ^ 2 * x3 -
+16 * y2 ^ 3 * y3 ^ 2 * e4 * y1 * e1 ^ 2 * x3 -
+8 * y2 ^ 2 * y3 ^ 2 * e4 * x1 * e1 ^ 3 * x3 -
+8 * y2 ^ 2 * y3 ^ 2 * e4 * x2 * e1 ^ 3 * x3 +
+8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * x1 * e1 ^ 2 +
+8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * x2 * e1 ^ 2 +
+8 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * e1 ^ 2 * x3 +
+8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * x1 * e1 ^ 2 +
+8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * x2 * e1 ^ 2 +
+8 * y2 ^ 2 * y3 ^ 2 * e4 * e6 * e1 ^ 2 * x3 -
+32 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 * y2 * e1 ^ 2 * x3 -
+16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * x1 * e1 ^ 3 * x3 -
+12 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e1 ^ 3 * x3 +
+8 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * x1 * e1 ^ 2 +
+8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 +
+16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * e1 ^ 2 * x3 +
+8 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * x1 * e1 ^ 2 +
+8 * y3 ^ 2 * x2 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 +
+16 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * e1 ^ 2 * x3 -
+4 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * y1 * y2 * e1 ^ 2 -
+2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * x1 * e1 ^ 3 -
+6 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * x2 * e1 ^ 3 +
+2 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * x1 * e1 ^ 2 +
+10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * x2 * e1 ^ 2 +
+2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * e5 * e1 ^ 2 +
+2 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * x1 * e1 ^ 2 +
+10 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * x2 * e1 ^ 2 +
+2 * y3 ^ 2 * x3 ^ 3 * e3 ^ 2 * e6 * e1 ^ 2 +
+8 * y2 ^ 3 * e6 * x3 ^ 2 * e3 * y1 * e1 ^ 2 +
+4 * y2 ^ 2 * e6 * x3 ^ 2 * e3 * x1 * e1 ^ 3 -
+4 * y2 ^ 2 * e6 * x3 ^ 2 * e3 * e5 * e1 ^ 2 -
+4 * y2 ^ 2 * e6 ^ 2 * x3 ^ 2 * e3 * e1 ^ 2 -
+8 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * e1 ^ 2 * x3 -
+4 * y2 * e6 * e4 * y1 * x1 * e1 ^ 3 * x3 -
+4 * y2 * e6 * e4 * y1 * x2 * e1 ^ 3 * x3 +
+4 * y2 * e6 * e4 * y1 * e5 * x1 * e1 ^ 2 +
+4 * y2 * e6 * e4 * y1 * e5 * x2 * e1 ^ 2 +
+4 * y2 * e6 * e4 * y1 * e5 * e1 ^ 2 * x3 +
+4 * y2 * e6 ^ 2 * e4 * y1 * x1 * e1 ^ 2 +
+4 * y2 * e6 ^ 2 * e4 * y1 * x2 * e1 ^ 2 +
+4 * y2 * e6 ^ 2 * e4 * y1 * e1 ^ 2 * x3 +
+8 * y2 ^ 3 * e7 * x3 ^ 2 * e3 * y1 * e1 ^ 2 +
+4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * x1 * e1 ^ 3 -
+4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * e5 * e1 ^ 2 -
+4 * y2 ^ 2 * e7 * x3 ^ 2 * e3 * e6 * e1 ^ 2 -
+8 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e1 ^ 2 * x3 -
+4 * y2 * e7 * e4 * y1 * x1 * e1 ^ 3 * x3 -
+4 * y2 * e7 * e4 * y1 * x2 * e1 ^ 3 * x3 +
+4 * y2 * e7 * e4 * y1 * e5 * x1 * e1 ^ 2 +
+4 * y2 * e7 * e4 * y1 * e5 * x2 * e1 ^ 2 +
+4 * y2 * e7 * e4 * y1 * e5 * e1 ^ 2 * x3 +
+4 * y2 * e7 * e4 * y1 * e6 * x1 * e1 ^ 2 +
+4 * y2 * e7 * e4 * y1 * e6 * x2 * e1 ^ 2 +
+4 * y2 * e7 * e4 * y1 * e6 * e1 ^ 2 * x3 -
+16 * y2 ^ 3 * y3 * x2 * e3 * e1 ^ 3 * x3 ^ 2 -
+4 * y2 ^ 3 * y3 * x3 ^ 3 * e3 * e1 ^ 3 +
+8 * y2 ^ 2 * y3 * e4 * y1 * x1 * e1 ^ 3 * x2 +
+4 * y2 ^ 2 * y3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 +
+4 * y2 ^ 2 * y3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 +
+4 * y2 ^ 2 * y3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 +
+16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 +
+16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * x2 * e1 ^ 2 +
+8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * x1 * e1 ^ 3 +
+4 * y2 ^ 2 * x2 * e3 * e4 * x1 ^ 2 * e1 ^ 3 +
+4 * y2 ^ 2 * x2 ^ 3 * e3 * e4 * e1 ^ 3 +
+8 * y2 ^ 2 * x2 * e3 * e4 * e1 ^ 3 * x3 ^ 2 +
+16 * y2 ^ 3 * x2 * e3 * e4 * y1 * x1 * e1 ^ 2 +
+16 * y2 ^ 3 * x2 ^ 2 * e3 * e4 * y1 * e1 ^ 2 +
+8 * y2 * x2 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 +
+4 * y2 * x2 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 +
+4 * y2 * x2 ^ 3 * e3 * e4 * y1 * e1 ^ 3 +
+8 * y2 * x2 * e3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 +
+16 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 +
+16 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * y1 ^ 2 * e1 ^ 2 +
+12 * y2 ^ 2 * x3 * e3 * e4 * x1 * e1 ^ 3 * x2 +
+2 * y2 ^ 2 * x3 * e3 * e4 * x1 ^ 2 * e1 ^ 3 +
+10 * y2 ^ 2 * x3 * e3 * e4 * x2 ^ 2 * e1 ^ 3 +
+2 * y2 ^ 2 * x3 ^ 3 * e3 * e4 * e1 ^ 3 +
+8 * y2 ^ 3 * x3 * e3 * e4 * y1 * x1 * e1 ^ 2 +
+24 * y2 ^ 3 * x3 * e3 * e4 * y1 * x2 * e1 ^ 2 +
+8 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * x1 * e1 ^ 3 +
+4 * y3 ^ 2 * e6 * x2 * e3 * x1 ^ 2 * e1 ^ 3 +
+4 * y3 ^ 2 * e6 * x2 ^ 3 * e3 * e1 ^ 3 +
+8 * y3 ^ 2 * e6 * x2 * e3 * e1 ^ 3 * x3 ^ 2 +
+16 * y3 ^ 2 * e6 * x2 * e3 * y1 * y2 * x1 * e1 ^ 2 +
+16 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * y1 * y2 * e1 ^ 2 +
+12 * y3 ^ 2 * e6 * x3 * e3 * x1 * e1 ^ 3 * x2 +
+2 * y3 ^ 2 * e6 * x3 * e3 * x1 ^ 2 * e1 ^ 3 +
+10 * y3 ^ 2 * e6 * x3 * e3 * x2 ^ 2 * e1 ^ 3 +
+2 * y3 ^ 2 * e6 * x3 ^ 3 * e3 * e1 ^ 3 +
+8 * y3 ^ 2 * e6 * x3 * e3 * y1 * y2 * x1 * e1 ^ 2 +
+24 * y3 ^ 2 * e6 * x3 * e3 * y1 * y2 * x2 * e1 ^ 2 +
+4 * y3 * e6 * e4 * y2 * x1 * e1 ^ 3 * x2 +
+2 * y3 * e6 * e4 * y2 * x1 ^ 2 * e1 ^ 3 +
+2 * y3 * e6 * e4 * y2 * x2 ^ 2 * e1 ^ 3 +
+2 * y3 * e6 * e4 * y2 * e1 ^ 3 * x3 ^ 2 +
+4 * y3 * e6 * e4 * y1 * x1 * e1 ^ 3 * x2 +
+2 * y3 * e6 * e4 * y1 * x1 ^ 2 * e1 ^ 3 +
+2 * y3 * e6 * e4 * y1 * x2 ^ 2 * e1 ^ 3 +
+2 * y3 * e6 * e4 * y1 * e1 ^ 3 * x3 ^ 2 +
+8 * y3 * e6 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 +
+8 * y3 * e6 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 +
+8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * x1 * e1 ^ 3 +
+4 * y3 ^ 2 * e7 * x2 * e3 * x1 ^ 2 * e1 ^ 3 +
+4 * y3 ^ 2 * e7 * x2 ^ 3 * e3 * e1 ^ 3 +
+8 * y3 ^ 2 * e7 * x2 * e3 * e1 ^ 3 * x3 ^ 2 +
+16 * y3 ^ 2 * e7 * x2 * e3 * y1 * y2 * x1 * e1 ^ 2 +
+16 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * y1 * y2 * e1 ^ 2 +
+12 * y3 ^ 2 * e7 * x3 * e3 * x1 * e1 ^ 3 * x2 +
+2 * y3 ^ 2 * e7 * x3 * e3 * x1 ^ 2 * e1 ^ 3 +
+10 * y3 ^ 2 * e7 * x3 * e3 * x2 ^ 2 * e1 ^ 3 +
+2 * y3 ^ 2 * e7 * x3 ^ 3 * e3 * e1 ^ 3 +
+8 * y3 ^ 2 * e7 * x3 * e3 * y1 * y2 * x1 * e1 ^ 2 +
+24 * y3 ^ 2 * e7 * x3 * e3 * y1 * y2 * x2 * e1 ^ 2 +
+4 * y3 * e7 * e4 * y2 * x1 * e1 ^ 3 * x2 +
+2 * y3 * e7 * e4 * y2 * x1 ^ 2 * e1 ^ 3 +
+2 * y3 * e7 * e4 * y2 * x2 ^ 2 * e1 ^ 3 +
+2 * y3 * e7 * e4 * y2 * e1 ^ 3 * x3 ^ 2 +
+8 * y3 * e7 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 +
+8 * y3 * e7 * e4 * y2 ^ 2 * y1 * x2 * e1 ^ 2 +
+4 * y3 * e7 * e4 * y1 * x1 * e1 ^ 3 * x2 +
+2 * y3 * e7 * e4 * y1 * x1 ^ 2 * e1 ^ 3 +
+2 * y3 * e7 * e4 * y1 * x2 ^ 2 * e1 ^ 3 +
+2 * y3 * e7 * e4 * y1 * e1 ^ 3 * x3 ^ 2 +
+8 * y3 * e7 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 +
+8 * y3 * e7 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 -
+16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * x1 * e1 ^ 3 -
+8 * y2 * y3 ^ 3 * x2 * e3 * x1 ^ 2 * e1 ^ 3 -
+8 * y2 * y3 ^ 3 * x2 ^ 3 * e3 * e1 ^ 3 -
+16 * y2 * y3 ^ 3 * x2 * e3 * e1 ^ 3 * x3 ^ 2 -
+32 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * y1 * x1 * e1 ^ 2 -
+32 * y2 ^ 2 * y3 ^ 3 * x2 ^ 2 * e3 * y1 * e1 ^ 2 -
+24 * y2 * y3 ^ 3 * x3 * e3 * x1 * e1 ^ 3 * x2 -
+4 * y2 * y3 ^ 3 * x3 * e3 * x1 ^ 2 * e1 ^ 3 -
+20 * y2 * y3 ^ 3 * x3 * e3 * x2 ^ 2 * e1 ^ 3 -
+4 * y2 * y3 ^ 3 * x3 ^ 3 * e3 * e1 ^ 3 -
+16 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * y1 * x1 * e1 ^ 2 -
+48 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * y1 * x2 * e1 ^ 2 -
+8 * y2 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 3 * x2 -
+4 * y2 * y3 ^ 2 * e4 * y1 * x1 ^ 2 * e1 ^ 3 -
+4 * y2 * y3 ^ 2 * e4 * y1 * x2 ^ 2 * e1 ^ 3 -
+4 * y2 * y3 ^ 2 * e4 * y1 * e1 ^ 3 * x3 ^ 2 -
+16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * x1 * e1 ^ 2 -
+16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * x2 * e1 ^ 2 -
+4 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * x1 ^ 2 * e1 ^ 3 -
+16 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * y1 * y2 * x1 * e1 ^ 2 +
+12 * y2 * x3 * e3 * e4 * y1 * x1 * e1 ^ 3 * x2 +
+2 * y2 * x3 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 +
+10 * y2 * x3 * e3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 +
+2 * y2 * x3 ^ 3 * e3 * e4 * y1 * e1 ^ 3 +
+8 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * x1 * e1 ^ 2 +
+24 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * x2 * e1 ^ 2 -
+8 * y3 * x2 ^ 2 * e3 * e4 * y2 * x1 * e1 ^ 3 -
+4 * y3 * x2 * e3 * e4 * y2 * x1 ^ 2 * e1 ^ 3 -
+4 * y3 * x2 ^ 3 * e3 * e4 * y2 * e1 ^ 3 -
+8 * y3 * x2 * e3 * e4 * y2 * e1 ^ 3 * x3 ^ 2 -
+16 * y3 * x2 * e3 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 -
+16 * y3 * x2 ^ 2 * e3 * e4 * y2 ^ 2 * y1 * e1 ^ 2 -
+8 * y3 * x2 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 -
+4 * y3 * x2 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 -
+4 * y3 * x2 ^ 3 * e3 * e4 * y1 * e1 ^ 3 -
+8 * y3 * x2 * e3 * e4 * y1 * e1 ^ 3 * x3 ^ 2 -
+16 * y3 * x2 * e3 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 -
+16 * y3 * x2 ^ 2 * e3 * e4 * y1 ^ 2 * y2 * e1 ^ 2 -
+12 * y3 * x3 * e3 * e4 * y2 * x1 * e1 ^ 3 * x2 -
+2 * y3 * x3 * e3 * e4 * y2 * x1 ^ 2 * e1 ^ 3 -
+10 * y3 * x3 * e3 * e4 * y2 * x2 ^ 2 * e1 ^ 3 -
+2 * y3 * x3 ^ 3 * e3 * e4 * y2 * e1 ^ 3 -
+8 * y3 * x3 * e3 * e4 * y2 ^ 2 * y1 * x1 * e1 ^ 2 -
+24 * y3 * x3 * e3 * e4 * y2 ^ 2 * y1 * x2 * e1 ^ 2 -
+12 * y3 * x3 * e3 * e4 * y1 * x1 * e1 ^ 3 * x2 -
+2 * y3 * x3 * e3 * e4 * y1 * x1 ^ 2 * e1 ^ 3 -
+10 * y3 * x3 * e3 * e4 * y1 * x2 ^ 2 * e1 ^ 3 -
+2 * y3 * x3 ^ 3 * e3 * e4 * y1 * e1 ^ 3 -
+8 * y3 * x3 * e3 * e4 * y1 ^ 2 * y2 * x1 * e1 ^ 2 -
+24 * y3 * x3 * e3 * e4 * y1 ^ 2 * y2 * x2 * e1 ^ 2 -
+4 * e4 ^ 2 * y2 * y1 * x1 * e1 ^ 3 * x2 -
+2 * e4 ^ 2 * y2 * y1 * x1 ^ 2 * e1 ^ 3 -
+2 * e4 ^ 2 * y2 * y1 * x2 ^ 2 * e1 ^ 3 -
+2 * e4 ^ 2 * y2 * y1 * e1 ^ 3 * x3 ^ 2 -
+8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * x1 * e1 ^ 2 -
+8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * x2 * e1 ^ 2 -
+16 * y2 ^ 4 * y3 * x3 ^ 2 * e3 * y1 * e1 ^ 2 -
+8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * x1 * e1 ^ 3 +
+8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * e5 * e1 ^ 2 +
+8 * y2 ^ 3 * y3 * x3 ^ 2 * e3 * e6 * e1 ^ 2 +
+16 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * e1 ^ 2 * x3 +
+8 * y2 ^ 2 * y3 * e4 * y1 * x1 * e1 ^ 3 * x3 +
+8 * y2 ^ 2 * y3 * e4 * y1 * x2 * e1 ^ 3 * x3 -
+8 * y2 ^ 2 * y3 * e4 * y1 * e5 * x1 * e1 ^ 2 -
+8 * y2 ^ 2 * y3 * e4 * y1 * e5 * x2 * e1 ^ 2 -
+8 * y2 ^ 2 * y3 * e4 * y1 * e5 * e1 ^ 2 * x3 -
+8 * y2 ^ 2 * x2 * e3 * e4 * e5 * x1 * e1 ^ 2 -
+8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * e5 * e1 ^ 2 -
+12 * y2 ^ 2 * x2 * e3 * e4 * e5 * e1 ^ 2 * x3 -
+8 * y2 ^ 2 * x2 * e3 * e4 * e6 * x1 * e1 ^ 2 -
+8 * y2 ^ 2 * x2 ^ 2 * e3 * e4 * e6 * e1 ^ 2 -
+12 * y2 ^ 2 * x2 * e3 * e4 * e6 * e1 ^ 2 * x3 -
+8 * y2 * x2 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 -
+8 * y2 * x2 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 -
+12 * y2 * x2 * e3 * e4 * y1 * e5 * e1 ^ 2 * x3 -
+8 * y2 * x2 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 -
+8 * y2 * x2 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 -
+12 * y2 * x2 * e3 * e4 * y1 * e6 * e1 ^ 2 * x3 +
+8 * y2 ^ 3 * x3 ^ 2 * e3 * e4 * y1 * e1 ^ 2 +
+4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * x1 * e1 ^ 3 -
+4 * y2 ^ 2 * x3 * e3 * e4 * e5 * x1 * e1 ^ 2 -
+4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * e5 * e1 ^ 2 -
+4 * y2 ^ 2 * x3 * e3 * e4 * e6 * x1 * e1 ^ 2 -
+4 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * e6 * e1 ^ 2 -
+8 * y3 ^ 2 * e6 * x2 * e3 * e5 * x1 * e1 ^ 2 -
+8 * y3 ^ 2 * e6 * x2 ^ 2 * e3 * e5 * e1 ^ 2 -
+12 * y3 ^ 2 * e6 * x2 * e3 * e5 * e1 ^ 2 * x3 -
+8 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * x1 * e1 ^ 2 -
+8 * y3 ^ 2 * e6 ^ 2 * x2 ^ 2 * e3 * e1 ^ 2 -
+12 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * e1 ^ 2 * x3 +
+8 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * y1 * y2 * e1 ^ 2 +
+4 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * x1 * e1 ^ 3 -
+4 * y3 ^ 2 * e6 * x3 * e3 * e5 * x1 * e1 ^ 2 -
+4 * y3 ^ 2 * e6 * x3 ^ 2 * e3 * e5 * e1 ^ 2 -
+4 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * x1 * e1 ^ 2 -
+4 * y3 ^ 2 * e6 ^ 2 * x3 ^ 2 * e3 * e1 ^ 2 +
+4 * y3 * e6 * e4 * y2 * x1 * e1 ^ 3 * x3 +
+4 * y3 * e6 * e4 * y2 * x2 * e1 ^ 3 * x3 -
+4 * y3 * e6 * e4 * y2 * e5 * x1 * e1 ^ 2 -
+4 * y3 * e6 * e4 * y2 * e5 * x2 * e1 ^ 2 -
+4 * y3 * e6 * e4 * y2 * e5 * e1 ^ 2 * x3 -
+4 * y3 * e6 ^ 2 * e4 * y2 * x1 * e1 ^ 2 -
+4 * y3 * e6 ^ 2 * e4 * y2 * x2 * e1 ^ 2 -
+4 * y3 * e6 ^ 2 * e4 * y2 * e1 ^ 2 * x3 +
+8 * y3 * e6 * e4 * y1 ^ 2 * y2 * e1 ^ 2 * x3 +
+4 * y3 * e6 * e4 * y1 * x1 * e1 ^ 3 * x3 +
+4 * y3 * e6 * e4 * y1 * x2 * e1 ^ 3 * x3 -
+4 * y3 * e6 * e4 * y1 * e5 * x1 * e1 ^ 2 -
+4 * y3 * e6 * e4 * y1 * e5 * x2 * e1 ^ 2 -
+4 * y3 * e6 * e4 * y1 * e5 * e1 ^ 2 * x3 -
+4 * y3 * e6 ^ 2 * e4 * y1 * x1 * e1 ^ 2 -
+4 * y3 * e6 ^ 2 * e4 * y1 * x2 * e1 ^ 2 -
+4 * y3 * e6 ^ 2 * e4 * y1 * e1 ^ 2 * x3 -
+8 * y3 ^ 2 * e7 * x2 * e3 * e5 * x1 * e1 ^ 2 -
+8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * e5 * e1 ^ 2 -
+12 * y3 ^ 2 * e7 * x2 * e3 * e5 * e1 ^ 2 * x3 -
+8 * y3 ^ 2 * e7 * x2 * e3 * e6 * x1 * e1 ^ 2 -
+8 * y3 ^ 2 * e7 * x2 ^ 2 * e3 * e6 * e1 ^ 2 -
+12 * y3 ^ 2 * e7 * x2 * e3 * e6 * e1 ^ 2 * x3 +
+8 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * y1 * y2 * e1 ^ 2 +
+4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * x1 * e1 ^ 3 -
+4 * y3 ^ 2 * e7 * x3 * e3 * e5 * x1 * e1 ^ 2 -
+4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * e5 * e1 ^ 2 -
+4 * y3 ^ 2 * e7 * x3 * e3 * e6 * x1 * e1 ^ 2 -
+4 * y3 ^ 2 * e7 * x3 ^ 2 * e3 * e6 * e1 ^ 2 +
+8 * y3 * e7 * e4 * y2 ^ 2 * y1 * e1 ^ 2 * x3 +
+4 * y3 * e7 * e4 * y2 * x1 * e1 ^ 3 * x3 +
+4 * y3 * e7 * e4 * y2 * x2 * e1 ^ 3 * x3 -
+4 * y3 * e7 * e4 * y2 * e5 * x1 * e1 ^ 2 -
+4 * y3 * e7 * e4 * y2 * e5 * x2 * e1 ^ 2 -
+4 * y3 * e7 * e4 * y2 * e5 * e1 ^ 2 * x3 -
+4 * y3 * e7 * e4 * y2 * e6 * x1 * e1 ^ 2 -
+4 * y3 * e7 * e4 * y2 * e6 * x2 * e1 ^ 2 -
+4 * y3 * e7 * e4 * y2 * e6 * e1 ^ 2 * x3 +
+8 * y3 * e7 * e4 * y1 ^ 2 * y2 * e1 ^ 2 * x3 +
+4 * y3 * e7 * e4 * y1 * x1 * e1 ^ 3 * x3 +
+4 * y3 * e7 * e4 * y1 * x2 * e1 ^ 3 * x3 -
+4 * y3 * e7 * e4 * y1 * e5 * x1 * e1 ^ 2 -
+4 * y3 * e7 * e4 * y1 * e5 * x2 * e1 ^ 2 -
+4 * y3 * e7 * e4 * y1 * e5 * e1 ^ 2 * x3 -
+4 * y3 * e7 * e4 * y1 * e6 * x1 * e1 ^ 2 -
+4 * y3 * e7 * e4 * y1 * e6 * x2 * e1 ^ 2 -
+4 * y3 * e7 * e4 * y1 * e6 * e1 ^ 2 * x3 +
+16 * y2 * y3 ^ 3 * x2 * e3 * e5 * x1 * e1 ^ 2 +
+16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * e5 * e1 ^ 2 +
+24 * y2 * y3 ^ 3 * x2 * e3 * e5 * e1 ^ 2 * x3 +
+16 * y2 * y3 ^ 3 * x2 * e3 * e6 * x1 * e1 ^ 2 +
+16 * y2 * y3 ^ 3 * x2 ^ 2 * e3 * e6 * e1 ^ 2 +
+24 * y2 * y3 ^ 3 * x2 * e3 * e6 * e1 ^ 2 * x3 -
+16 * y2 ^ 2 * y3 ^ 3 * x3 ^ 2 * e3 * y1 * e1 ^ 2 -
+8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * x1 * e1 ^ 3 +
+8 * y2 * y3 ^ 3 * x3 * e3 * e5 * x1 * e1 ^ 2 +
+8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * e5 * e1 ^ 2 +
+8 * y2 * y3 ^ 3 * x3 * e3 * e6 * x1 * e1 ^ 2 +
+8 * y2 * y3 ^ 3 * x3 ^ 2 * e3 * e6 * e1 ^ 2 -
+16 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e1 ^ 2 * x3 -
+8 * y2 * y3 ^ 2 * e4 * y1 * x1 * e1 ^ 3 * x3 -
+8 * y2 * y3 ^ 2 * e4 * y1 * x2 * e1 ^ 3 * x3 +
+8 * y2 * y3 ^ 2 * e4 * y1 * e5 * x1 * e1 ^ 2 +
+8 * y2 * y3 ^ 2 * e4 * y1 * e5 * x2 * e1 ^ 2 +
+8 * y2 * y3 ^ 2 * e4 * y1 * e5 * e1 ^ 2 * x3 +
+8 * y2 * y3 ^ 2 * e4 * y1 * e6 * x1 * e1 ^ 2 +
+8 * y2 * y3 ^ 2 * e4 * y1 * e6 * x2 * e1 ^ 2 +
+8 * y2 * y3 ^ 2 * e4 * y1 * e6 * e1 ^ 2 * x3 +
+8 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * x1 * e1 ^ 2 +
+8 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 * x1 * e1 ^ 2 +
+8 * y2 ^ 2 * x3 ^ 2 * e3 * e4 * y1 ^ 2 * e1 ^ 2 +
+4 * y2 * x3 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 -
+4 * y2 * x3 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 -
+4 * y2 * x3 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 -
+4 * y2 * x3 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 -
+4 * y2 * x3 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 +
+8 * y3 * x2 * e3 * e4 * y2 * e5 * x1 * e1 ^ 2 +
+8 * y3 * x2 ^ 2 * e3 * e4 * y2 * e5 * e1 ^ 2 +
+12 * y3 * x2 * e3 * e4 * y2 * e5 * e1 ^ 2 * x3 +
+8 * y3 * x2 * e3 * e4 * y2 * e6 * x1 * e1 ^ 2 +
+8 * y3 * x2 ^ 2 * e3 * e4 * y2 * e6 * e1 ^ 2 +
+12 * y3 * x2 * e3 * e4 * y2 * e6 * e1 ^ 2 * x3 +
+8 * y3 * x2 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 +
+8 * y3 * x2 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 +
+12 * y3 * x2 * e3 * e4 * y1 * e5 * e1 ^ 2 * x3 +
+8 * y3 * x2 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 +
+8 * y3 * x2 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 +
+12 * y3 * x2 * e3 * e4 * y1 * e6 * e1 ^ 2 * x3 -
+8 * y3 * x3 ^ 2 * e3 * e4 * y2 ^ 2 * y1 * e1 ^ 2 -
+4 * y3 * x3 ^ 2 * e3 * e4 * y2 * x1 * e1 ^ 3 +
+4 * y3 * x3 * e3 * e4 * y2 * e5 * x1 * e1 ^ 2 +
+4 * y3 * x3 ^ 2 * e3 * e4 * y2 * e5 * e1 ^ 2 +
+4 * y3 * x3 * e3 * e4 * y2 * e6 * x1 * e1 ^ 2 +
+4 * y3 * x3 ^ 2 * e3 * e4 * y2 * e6 * e1 ^ 2 -
+8 * y3 * x3 ^ 2 * e3 * e4 * y1 ^ 2 * y2 * e1 ^ 2 -
+4 * y3 * x3 ^ 2 * e3 * e4 * y1 * x1 * e1 ^ 3 +
+4 * y3 * x3 * e3 * e4 * y1 * e5 * x1 * e1 ^ 2 +
+4 * y3 * x3 ^ 2 * e3 * e4 * y1 * e5 * e1 ^ 2 +
+4 * y3 * x3 * e3 * e4 * y1 * e6 * x1 * e1 ^ 2 +
+4 * y3 * x3 ^ 2 * e3 * e4 * y1 * e6 * e1 ^ 2 -
+8 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e1 ^ 2 * x3 -
+4 * e4 ^ 2 * y2 * y1 * x1 * e1 ^ 3 * x3 -
+4 * e4 ^ 2 * y2 * y1 * x2 * e1 ^ 3 * x3 +
+4 * e4 ^ 2 * y2 * y1 * e5 * x1 * e1 ^ 2 +
+4 * e4 ^ 2 * y2 * y1 * e5 * x2 * e1 ^ 2 +
+4 * e4 ^ 2 * y2 * y1 * e5 * e1 ^ 2 * x3 +
+4 * e4 ^ 2 * y2 * y1 * e6 * x1 * e1 ^ 2 +
+4 * e4 ^ 2 * y2 * y1 * e6 * x2 * e1 ^ 2 +
+4 * e4 ^ 2 * y2 * y1 * e6 * e1 ^ 2 * x3 + 4 * e1 * e6 ^ 2 * y2 ^ 3 * e5 * y1 -
+4 * e1 * e6 ^ 2 * e7 * y2 ^ 2 * e5 + 8 * e1 * e6 ^ 2 * e7 * y2 ^ 3 * y1 +
+32 * e1 * y2 ^ 4 * y3 * x2 * e3 * e5 * y1 -
+8 * e1 * y2 ^ 3 * y3 * x3 * e3 * e5 * e6 +
+16 * e1 * y2 ^ 4 * y3 * x3 * e3 * e5 * y1 +
+16 * e1 * y2 ^ 4 * y3 * x3 * e3 * e6 * y1 +
+8 * e1 * e6 * e7 * y2 ^ 3 * e5 * y1 - 2 * e1 * e7 ^ 2 * y2 ^ 2 * e5 * e6 +
+4 * e1 * e7 ^ 2 * y2 ^ 3 * e5 * y1 + 4 * e1 * e7 ^ 2 * y2 ^ 3 * e6 * y1 -
+16 * e1 * y2 ^ 3 * y3 ^ 2 * y1 * e6 ^ 2 +
+16 * e1 * y2 ^ 4 * y3 ^ 2 * y1 ^ 2 * e6 - 8 * e1 * y2 ^ 4 * y3 ^ 2 * e5 * e6 +
+16 * e1 * y2 ^ 5 * y3 ^ 2 * e5 * y1 + 16 * e1 * y2 ^ 5 * y3 ^ 2 * e6 * y1 -
+4 * e1 * y2 ^ 2 * y3 ^ 2 * y1 ^ 2 * e6 ^ 2 -
+2 * e1 * e6 * e7 * y2 ^ 2 * e5 ^ 2 - 8 * e1 * e6 * e7 * y1 ^ 2 * y2 ^ 4 -
+4 * e1 * x2 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 -
+16 * e1 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 -
+e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 ^ 2 -
+e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e6 ^ 2 -
+4 * e1 * x3 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 4 +
+16 * e1 * e6 ^ 3 * y2 ^ 2 * y3 * y1 - 16 * e1 * e6 ^ 2 * y2 ^ 3 * y3 * y1 ^ 2 +
+8 * e1 * e6 ^ 2 * y2 ^ 3 * y3 * e5 - 16 * e1 * y2 ^ 3 * y3 ^ 2 * y1 * e5 * e6 +
+16 * e1 * x2 ^ 2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 -
+2 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 2 * e5 * e6 +
+4 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 3 * e5 * y1 +
+4 * e1 * x3 ^ 2 * e3 ^ 2 * y2 ^ 3 * e6 * y1 -
+8 * e1 * y2 ^ 3 * y3 * x2 * e3 * e5 ^ 2 -
+32 * e1 * y2 ^ 5 * y3 * x2 * e3 * y1 ^ 2 -
+4 * e1 * y2 ^ 3 * y3 * x3 * e3 * e5 ^ 2 -
+4 * e1 * y2 ^ 3 * y3 * x3 * e3 * e6 ^ 2 -
+16 * e1 * y2 ^ 5 * y3 * x3 * e3 * y1 ^ 2 -
+4 * e1 * x2 * e3 ^ 2 * x3 * y2 ^ 2 * e5 ^ 2 +
+16 * e1 * x2 * e3 ^ 2 * x3 * y2 ^ 3 * e5 * y1 +
+16 * e1 * e6 ^ 2 * y2 ^ 2 * y3 * y1 * e5 -
+16 * e1 * e6 * y2 ^ 4 * y3 * e5 * y1 - 16 * e1 * e6 ^ 2 * y2 ^ 4 * y3 * y1 +
+4 * e1 * e6 * y2 ^ 3 * y3 * e5 ^ 2 + 16 * e1 * e6 * y2 ^ 5 * y3 * y1 ^ 2 +
+2 * e1 * e6 ^ 3 * x3 * e3 * y2 ^ 2 + 4 * e1 * e7 * y2 ^ 3 * y3 * e5 ^ 2 +
+4 * e1 * e7 * y2 ^ 3 * y3 * e6 ^ 2 + 16 * e1 * e7 * y2 ^ 5 * y3 * y1 ^ 2 -
+16 * e1 * e6 * x2 * e3 * y2 ^ 3 * e5 * y1 +
+4 * e1 * e6 ^ 2 * x3 * e3 * y2 ^ 2 * e5 -
+8 * e1 * e6 * x3 * e3 * y2 ^ 3 * e5 * y1 -
+8 * e1 * e6 ^ 2 * x3 * e3 * y2 ^ 3 * y1 +
+32 * e1 * e7 * y2 ^ 2 * y3 * y1 * e5 * e6 +
+32 * e1 * e7 * y2 ^ 2 * y3 * y1 * e6 ^ 2 -
+32 * e1 * e7 * y2 ^ 3 * y3 * y1 ^ 2 * e6 +
+8 * e1 * e7 * y2 ^ 3 * y3 * e5 * e6 - 16 * e1 * e7 * y2 ^ 4 * y3 * e5 * y1 -
+16 * e1 * e7 * y2 ^ 4 * y3 * e6 * y1 -
+16 * e1 * e7 * x2 * e3 * y2 ^ 3 * e5 * y1 +
+4 * e1 * e7 * x3 * e3 * y2 ^ 2 * e5 * e6 -
+8 * e1 * e7 * x3 * e3 * y2 ^ 3 * e5 * y1 -
+8 * e1 * e7 * x3 * e3 * y2 ^ 3 * e6 * y1 -
+16 * e1 * x2 * e3 ^ 2 * x3 * y1 ^ 2 * y2 ^ 4 +
+4 * e1 * e6 * x2 * e3 * y2 ^ 2 * e5 ^ 2 +
+16 * e1 * e6 * x2 * e3 * y1 ^ 2 * y2 ^ 4 +
+2 * e1 * e6 * x3 * e3 * y2 ^ 2 * e5 ^ 2 +
+8 * e1 * e6 * x3 * e3 * y1 ^ 2 * y2 ^ 4 +
+4 * e1 * e7 * x2 * e3 * y2 ^ 2 * e5 ^ 2 +
+16 * e1 * e7 * x2 * e3 * y1 ^ 2 * y2 ^ 4 +
+2 * e1 * e7 * x3 * e3 * y2 ^ 2 * e5 ^ 2 +
+2 * e1 * e7 * x3 * e3 * y2 ^ 2 * e6 ^ 2 +
+8 * e1 * e7 * x3 * e3 * y1 ^ 2 * y2 ^ 4 - 8 * e1 * e6 ^ 3 * e7 * y2 * y3 -
+4 * e1 * e5 ^ 2 * e6 ^ 2 * y2 * y3 + 4 * e1 * e5 ^ 2 * e6 * y2 ^ 2 * y3 ^ 2 +
+8 * e1 * e5 * e6 ^ 2 * y2 ^ 2 * y3 ^ 2 - 8 * e1 * e5 * e6 ^ 3 * y2 * y3 -
+16 * e1 * e6 ^ 2 * e7 * y2 * y3 * e5 - 8 * e1 * e5 ^ 2 * e7 * y2 * y3 * e6 -
+2 * e1 * y3 ^ 2 * e7 ^ 2 * e5 * e6 -
+4 * e1 * y3 ^ 2 * e7 ^ 2 * y1 ^ 2 * y2 ^ 2 -
+8 * e1 * y2 ^ 2 * y3 ^ 4 * e5 * e6 - 2 * e1 * e4 ^ 2 * y2 ^ 2 * e5 * e6 -
+2 * e1 * e4 ^ 2 * y1 ^ 2 * e5 * e6 - 16 * e1 * y2 ^ 4 * y3 ^ 4 * y1 ^ 2 -
+e1 * e4 ^ 2 * y2 ^ 2 * e6 ^ 2 - e1 * e4 ^ 2 * y2 ^ 2 * e5 ^ 2 -
+4 * e1 * e4 ^ 2 * y2 ^ 4 * y1 ^ 2 - e1 * e4 ^ 2 * y1 ^ 2 * e6 ^ 2 -
+e1 * e4 ^ 2 * y1 ^ 2 * e5 ^ 2 - 4 * e1 * e4 ^ 2 * y1 ^ 4 * y2 ^ 2 -
+2 * e1 * y2 ^ 2 * e6 ^ 3 * e4 - 2 * e1 * y3 ^ 2 * e6 ^ 3 * e7 +
+4 * e1 * y3 ^ 3 * e6 ^ 3 * y2 - 2 * e1 * y2 ^ 2 * e6 * e4 * e5 ^ 2 -
+4 * e1 * y2 ^ 2 * e6 ^ 2 * e4 * e5 - 8 * e1 * y2 ^ 4 * e6 * e4 * y1 ^ 2 -
+4 * e1 * y2 * e7 ^ 2 * y3 * e6 ^ 2 - 4 * e1 * y2 * e7 ^ 2 * y3 * e5 ^ 2 -
+16 * e1 * y2 ^ 3 * e7 ^ 2 * y3 * y1 ^ 2 +
+4 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e6 ^ 2 +
+4 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e5 ^ 2 +
+16 * e1 * y2 ^ 4 * e7 * y3 ^ 2 * y1 ^ 2 - 2 * e1 * y2 ^ 2 * e7 * e4 * e6 ^ 2 -
+2 * e1 * y2 ^ 2 * e7 * e4 * e5 ^ 2 - 8 * e1 * y2 ^ 4 * e7 * e4 * y1 ^ 2 +
+4 * e1 * y2 ^ 3 * y3 * e4 * e6 ^ 2 + 4 * e1 * y2 ^ 3 * y3 * e4 * e5 ^ 2 +
+16 * e1 * y2 ^ 5 * y3 * e4 * y1 ^ 2 - 2 * e1 * y3 ^ 2 * e6 * e7 * e5 ^ 2 -
+4 * e1 * y3 ^ 2 * e6 ^ 2 * e7 * e5 + 4 * e1 * y3 ^ 3 * e6 * y2 * e5 ^ 2 +
+8 * e1 * y3 ^ 3 * e6 ^ 2 * y2 * e5 + 16 * e1 * y3 ^ 3 * e6 * y2 ^ 3 * y1 ^ 2 +
+4 * e1 * y3 ^ 3 * e7 * y2 * e6 ^ 2 + 4 * e1 * y3 ^ 3 * e7 * y2 * e5 ^ 2 +
+16 * e1 * y3 ^ 3 * e7 * y2 ^ 3 * y1 ^ 2 -
+4 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e6 ^ 2 -
+4 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e5 ^ 2 -
+16 * e1 * y2 ^ 4 * y3 ^ 2 * e4 * y1 ^ 2 -
+4 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 ^ 2 -
+4 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 ^ 2 -
+e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 ^ 2 -
+e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 ^ 2 - 2 * e1 * y2 * e6 ^ 3 * e4 * y1 -
+8 * e1 * y2 ^ 3 * e6 * e4 * y1 ^ 3 - 8 * e1 * y2 ^ 3 * e7 * e4 * y1 ^ 3 +
+4 * e1 * y3 ^ 2 * e6 ^ 3 * y1 * y2 + 16 * e1 * y2 ^ 3 * y3 ^ 4 * e5 * y1 +
+16 * e1 * y2 ^ 3 * y3 ^ 4 * e6 * y1 + 4 * e1 * e4 ^ 2 * y2 ^ 3 * e5 * y1 -
+8 * e1 * y2 * e7 ^ 2 * y3 * e5 * e6 + 8 * e1 * y2 ^ 2 * e7 * y3 ^ 2 * e5 * e6 -
+4 * e1 * y2 ^ 2 * e7 * e4 * e5 * e6 + 8 * e1 * y2 ^ 3 * y3 * e4 * e5 * e6 -
+8 * e1 * y3 ^ 2 * e6 * e7 * y1 ^ 2 * y2 ^ 2 +
+8 * e1 * y3 ^ 3 * e7 * y2 * e5 * e6 - 8 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * e5 * e6 -
+8 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * e6 -
+16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 -
+2 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * e6 -
+4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * y1 ^ 2 * y2 ^ 2 -
+2 * e1 * y2 * e6 * e4 * y1 * e5 ^ 2 - 4 * e1 * y2 * e6 ^ 2 * e4 * y1 * e5 -
+2 * e1 * y2 * e7 * e4 * y1 * e6 ^ 2 - 2 * e1 * y2 * e7 * e4 * y1 * e5 ^ 2 -
+4 * e1 * y2 * e7 * e4 * y1 * e5 * e6 +
+4 * e1 * y3 ^ 2 * e6 ^ 2 * e5 * y1 * y2 +
+4 * e1 * y3 ^ 2 * e7 ^ 2 * e5 * y1 * y2 +
+4 * e1 * y3 ^ 2 * e7 ^ 2 * e6 * y1 * y2 + 4 * e1 * e4 ^ 2 * y2 ^ 3 * e6 * y1 +
+4 * e1 * e4 ^ 2 * y1 ^ 3 * e5 * y2 + 4 * e1 * e4 ^ 2 * y1 ^ 3 * e6 * y2 +
+8 * e1 * y2 ^ 3 * e6 ^ 2 * e4 * y1 - 16 * e1 * y3 ^ 3 * e6 ^ 2 * y2 ^ 2 * y1 +
+8 * e1 * y2 ^ 2 * e6 ^ 2 * e4 * y1 ^ 2 + 16 * e1 * y2 ^ 4 * y3 * e4 * y1 ^ 3 +
+4 * e1 * y3 ^ 2 * e6 ^ 3 * x2 * e3 + 2 * e1 * y3 ^ 2 * e6 ^ 3 * x3 * e3 +
+2 * e1 * y3 * e6 ^ 3 * e4 * y2 + 2 * e1 * y3 * e6 ^ 3 * e4 * y1 -
+2 * e1 * e4 ^ 2 * y2 * y1 * e6 ^ 2 - 2 * e1 * e4 ^ 2 * y2 * y1 * e5 ^ 2 +
+8 * e1 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e5 +
+8 * e1 * e4 ^ 2 * y2 ^ 2 * y1 ^ 2 * e6 + 8 * e1 * y2 ^ 3 * e6 * e4 * e5 * y1 +
+16 * e1 * y2 ^ 2 * e7 ^ 2 * y3 * e5 * y1 +
+16 * e1 * y2 ^ 2 * e7 ^ 2 * y3 * e6 * y1 -
+16 * e1 * y2 ^ 3 * e7 * y3 ^ 2 * e5 * y1 -
+16 * e1 * y2 ^ 3 * e7 * y3 ^ 2 * e6 * y1 +
+8 * e1 * y2 ^ 3 * e7 * e4 * e5 * y1 + 8 * e1 * y2 ^ 3 * e7 * e4 * e6 * y1 -
+16 * e1 * y2 ^ 4 * y3 * e4 * e5 * y1 - 16 * e1 * y2 ^ 4 * y3 * e4 * e6 * y1 +
+8 * e1 * y3 ^ 2 * e6 * e7 * e5 * y1 * y2 +
+8 * e1 * y3 ^ 2 * e6 ^ 2 * e7 * y1 * y2 -
+16 * e1 * y3 ^ 3 * e6 * y2 ^ 2 * e5 * y1 -
+16 * e1 * y3 ^ 3 * e7 * y2 ^ 2 * e5 * y1 -
+16 * e1 * y3 ^ 3 * e7 * y2 ^ 2 * e6 * y1 +
+16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * e5 * y1 +
+16 * e1 * y2 ^ 3 * y3 ^ 2 * e4 * e6 * y1 +
+16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e5 * y1 * y2 +
+16 * e1 * y3 ^ 2 * x2 ^ 2 * e3 ^ 2 * e6 * y1 * y2 +
+4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e5 * y1 * y2 +
+4 * e1 * y3 ^ 2 * x3 ^ 2 * e3 ^ 2 * e6 * y1 * y2 +
+8 * e1 * y2 ^ 2 * e6 * e4 * y1 ^ 2 * e5 +
+8 * e1 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e5 +
+8 * e1 * y2 ^ 2 * e7 * e4 * y1 ^ 2 * e6 -
+4 * e1 * y2 ^ 2 * y3 * e4 * y1 * e6 ^ 2 +
+4 * e1 * y2 ^ 2 * y3 * e4 * y1 * e5 ^ 2 +
+4 * e1 * y2 ^ 2 * x2 * e3 * e4 * e6 ^ 2 +
+4 * e1 * y2 ^ 2 * x2 * e3 * e4 * e5 ^ 2 +
+8 * e1 * y2 ^ 2 * x2 * e3 * e4 * e5 * e6 +
+16 * e1 * y2 ^ 4 * x2 * e3 * e4 * y1 ^ 2 +
+4 * e1 * y2 * x2 * e3 * e4 * y1 * e6 ^ 2 +
+4 * e1 * y2 * x2 * e3 * e4 * y1 * e5 ^ 2 +
+8 * e1 * y2 * x2 * e3 * e4 * y1 * e5 * e6 +
+16 * e1 * y2 ^ 3 * x2 * e3 * e4 * y1 ^ 3 +
+2 * e1 * y2 ^ 2 * x3 * e3 * e4 * e6 ^ 2 +
+2 * e1 * y2 ^ 2 * x3 * e3 * e4 * e5 ^ 2 +
+4 * e1 * y2 ^ 2 * x3 * e3 * e4 * e5 * e6 +
+8 * e1 * y2 ^ 4 * x3 * e3 * e4 * y1 ^ 2 +
+4 * e1 * y3 ^ 2 * e6 * x2 * e3 * e5 ^ 2 +
+8 * e1 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * e5 +
+2 * e1 * y3 ^ 2 * e6 * x3 * e3 * e5 ^ 2 +
+4 * e1 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * e5 +
+8 * e1 * y3 ^ 2 * e6 * x3 * e3 * y1 ^ 2 * y2 ^ 2 +
+2 * e1 * y3 * e6 * e4 * y2 * e5 ^ 2 + 4 * e1 * y3 * e6 ^ 2 * e4 * y2 * e5 -
+8 * e1 * y3 * e6 * e4 * y2 ^ 3 * y1 ^ 2 + 2 * e1 * y3 * e6 * e4 * y1 * e5 ^ 2 +
+4 * e1 * y3 * e6 ^ 2 * e4 * y1 * e5 + 8 * e1 * y3 * e6 * e4 * y1 ^ 3 * y2 ^ 2 +
+4 * e1 * y3 ^ 2 * e7 * x2 * e3 * e6 ^ 2 +
+4 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 ^ 2 +
+8 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 * e6 +
+16 * e1 * y3 ^ 2 * e7 * x2 * e3 * y1 ^ 2 * y2 ^ 2 +
+2 * e1 * y3 ^ 2 * e7 * x3 * e3 * e6 ^ 2 +
+2 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 ^ 2 +
+4 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 * e6 +
+8 * e1 * y3 ^ 2 * e7 * x3 * e3 * y1 ^ 2 * y2 ^ 2 +
+2 * e1 * y3 * e7 * e4 * y2 * e6 ^ 2 + 2 * e1 * y3 * e7 * e4 * y2 * e5 ^ 2 +
+4 * e1 * y3 * e7 * e4 * y2 * e5 * e6 +
+8 * e1 * y3 * e7 * e4 * y2 ^ 3 * y1 ^ 2 + 2 * e1 * y3 * e7 * e4 * y1 * e6 ^ 2 +
+2 * e1 * y3 * e7 * e4 * y1 * e5 ^ 2 + 4 * e1 * y3 * e7 * e4 * y1 * e5 * e6 +
+8 * e1 * y3 * e7 * e4 * y1 ^ 3 * y2 ^ 2 -
+8 * e1 * y2 * y3 ^ 3 * x2 * e3 * e6 ^ 2 -
+8 * e1 * y2 * y3 ^ 3 * x2 * e3 * e5 ^ 2 -
+16 * e1 * y2 * y3 ^ 3 * x2 * e3 * e5 * e6 -
+32 * e1 * y2 ^ 3 * y3 ^ 3 * x2 * e3 * y1 ^ 2 -
+4 * e1 * y2 * y3 ^ 3 * x3 * e3 * e6 ^ 2 -
+4 * e1 * y2 * y3 ^ 3 * x3 * e3 * e5 ^ 2 -
+8 * e1 * y2 * y3 ^ 3 * x3 * e3 * e5 * e6 -
+16 * e1 * y2 ^ 3 * y3 ^ 3 * x3 * e3 * y1 ^ 2 -
+4 * e1 * y2 * y3 ^ 2 * e4 * y1 * e6 ^ 2 -
+4 * e1 * y2 * y3 ^ 2 * e4 * y1 * e5 ^ 2 -
+8 * e1 * y2 * y3 ^ 2 * e4 * y1 * e5 * e6 -
+4 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 ^ 2 -
+4 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 ^ 2 -
+8 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * e6 -
+16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * y1 ^ 2 * y2 ^ 2 +
+2 * e1 * y2 * x3 * e3 * e4 * y1 * e6 ^ 2 +
+2 * e1 * y2 * x3 * e3 * e4 * y1 * e5 ^ 2 +
+4 * e1 * y2 * x3 * e3 * e4 * y1 * e5 * e6 +
+8 * e1 * y2 ^ 3 * x3 * e3 * e4 * y1 ^ 3 -
+4 * e1 * y3 * x2 * e3 * e4 * y2 * e6 ^ 2 -
+4 * e1 * y3 * x2 * e3 * e4 * y2 * e5 ^ 2 -
+8 * e1 * y3 * x2 * e3 * e4 * y2 * e5 * e6 -
+16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 3 * y1 ^ 2 -
+4 * e1 * y3 * x2 * e3 * e4 * y1 * e6 ^ 2 -
+4 * e1 * y3 * x2 * e3 * e4 * y1 * e5 ^ 2 -
+8 * e1 * y3 * x2 * e3 * e4 * y1 * e5 * e6 -
+16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 3 * y2 ^ 2 -
+2 * e1 * y3 * x3 * e3 * e4 * y2 * e6 ^ 2 -
+2 * e1 * y3 * x3 * e3 * e4 * y2 * e5 ^ 2 -
+4 * e1 * y3 * x3 * e3 * e4 * y2 * e5 * e6 -
+8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 3 * y1 ^ 2 -
+2 * e1 * y3 * x3 * e3 * e4 * y1 * e6 ^ 2 -
+2 * e1 * y3 * x3 * e3 * e4 * y1 * e5 ^ 2 -
+4 * e1 * y3 * x3 * e3 * e4 * y1 * e5 * e6 -
+8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 3 * y2 ^ 2 -
+4 * e1 * e4 ^ 2 * y2 * y1 * e5 * e6 -
+16 * e1 * y2 ^ 3 * y3 * e4 * y1 ^ 2 * e5 -
+16 * e1 * y2 ^ 3 * x2 * e3 * e4 * e5 * y1 -
+16 * e1 * y2 ^ 3 * x2 * e3 * e4 * e6 * y1 -
+16 * e1 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * e5 -
+16 * e1 * y2 ^ 2 * x2 * e3 * e4 * y1 ^ 2 * e6 -
+8 * e1 * y2 ^ 3 * x3 * e3 * e4 * e5 * y1 -
+8 * e1 * y2 ^ 3 * x3 * e3 * e4 * e6 * y1 -
+16 * e1 * y3 ^ 2 * e6 * x2 * e3 * e5 * y1 * y2 -
+16 * e1 * y3 ^ 2 * e6 ^ 2 * x2 * e3 * y1 * y2 -
+8 * e1 * y3 ^ 2 * e6 * x3 * e3 * e5 * y1 * y2 -
+8 * e1 * y3 ^ 2 * e6 ^ 2 * x3 * e3 * y1 * y2 -
+8 * e1 * y3 * e6 * e4 * y1 ^ 2 * e5 * y2 -
+8 * e1 * y3 * e6 ^ 2 * e4 * y1 ^ 2 * y2 -
+16 * e1 * y3 ^ 2 * e7 * x2 * e3 * e5 * y1 * y2 -
+16 * e1 * y3 ^ 2 * e7 * x2 * e3 * e6 * y1 * y2 -
+8 * e1 * y3 ^ 2 * e7 * x3 * e3 * e5 * y1 * y2 -
+8 * e1 * y3 ^ 2 * e7 * x3 * e3 * e6 * y1 * y2 -
+8 * e1 * y3 * e7 * e4 * y2 ^ 2 * e5 * y1 -
+8 * e1 * y3 * e7 * e4 * y2 ^ 2 * e6 * y1 -
+8 * e1 * y3 * e7 * e4 * y1 ^ 2 * e5 * y2 -
+8 * e1 * y3 * e7 * e4 * y1 ^ 2 * e6 * y2 +
+32 * e1 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * e5 * y1 +
+32 * e1 * y2 ^ 2 * y3 ^ 3 * x2 * e3 * e6 * y1 +
+16 * e1 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * e5 * y1 +
+16 * e1 * y2 ^ 2 * y3 ^ 3 * x3 * e3 * e6 * y1 +
+16 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e5 +
+16 * e1 * y2 ^ 2 * y3 ^ 2 * e4 * y1 ^ 2 * e6 +
+16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e5 * y1 * y2 +
+16 * e1 * y3 ^ 2 * x2 * e3 ^ 2 * x3 * e6 * y1 * y2 -
+8 * e1 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * e5 -
+8 * e1 * y2 ^ 2 * x3 * e3 * e4 * y1 ^ 2 * e6 +
+16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 2 * e5 * y1 +
+16 * e1 * y3 * x2 * e3 * e4 * y2 ^ 2 * e6 * y1 +
+16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 2 * e5 * y2 +
+16 * e1 * y3 * x2 * e3 * e4 * y1 ^ 2 * e6 * y2 +
+8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 2 * e5 * y1 +
+8 * e1 * y3 * x3 * e3 * e4 * y2 ^ 2 * e6 * y1 +
+8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 2 * e5 * y2 +
+8 * e1 * y3 * x3 * e3 * e4 * y1 ^ 2 * e6 * y2 +
+12 * e6 ^ 2 * e7 * y1 * y2 * x1 * e1 ^ 2 + 2 * x1 * e1 ^ 3 * x2 * e6 ^ 3 +
+3 * x1 ^ 2 * e1 ^ 3 * e6 ^ 2 * e7 + 3 * x2 ^ 2 * e1 ^ 3 * e6 ^ 2 * e7 +
+3 * e1 ^ 3 * x3 ^ 2 * e6 ^ 2 * e7 + 2 * x1 * e1 ^ 3 * x3 * e6 ^ 3 +
+2 * x2 * e1 ^ 3 * x3 * e6 ^ 3 + 3 * x1 ^ 2 * e1 ^ 3 * e7 ^ 2 * e6 +
+3 * x2 ^ 2 * e1 ^ 3 * e7 ^ 2 * e6 + 4 * e6 ^ 3 * y1 * y2 * x1 * e1 ^ 2 +
+4 * e6 ^ 3 * y1 * y2 * x2 * e1 ^ 2 + 12 * e6 ^ 2 * e7 * y1 * y2 * x2 * e1 ^ 2 +
+12 * e7 ^ 2 * y1 * e6 * y2 * x1 * e1 ^ 2 +
+12 * e7 ^ 2 * y1 * e6 * y2 * x2 * e1 ^ 2 + e1 * e6 ^ 5 +
+3 * e1 ^ 3 * x3 ^ 2 * e7 ^ 2 * e6 - 2 * e6 ^ 3 * x1 * e1 ^ 2 * e5 -
+2 * e6 ^ 3 * x2 * e1 ^ 2 * e5 - 2 * e6 ^ 3 * e1 ^ 2 * x3 * e5 -
+6 * e6 ^ 3 * e7 * x1 * e1 ^ 2 - 6 * e6 ^ 3 * e7 * x2 * e1 ^ 2 -
+6 * e6 ^ 2 * e7 ^ 2 * x1 * e1 ^ 2 - 6 * e6 ^ 2 * e7 ^ 2 * x2 * e1 ^ 2 -
+6 * e6 ^ 3 * e1 ^ 2 * x3 * e7 - 6 * e6 ^ 2 * e1 ^ 2 * x3 * e7 ^ 2 +
+6 * x1 * e1 ^ 3 * x2 * e6 ^ 2 * e7 + 6 * x1 * e1 ^ 3 * x2 * e7 ^ 2 * e6 +
+6 * x1 * e1 ^ 3 * x3 * e7 ^ 2 * e6 + 6 * x2 * e1 ^ 3 * x3 * e7 ^ 2 * e6 -
+6 * e5 * x1 * e1 ^ 2 * e7 ^ 2 * e6 - 6 * e5 * x2 * e1 ^ 2 * e7 ^ 2 * e6 -
+6 * e5 * e1 ^ 2 * x3 * e7 ^ 2 * e6 - 6 * e5 * e6 ^ 2 * e7 * x1 * e1 ^ 2 -
+6 * e5 * e6 ^ 2 * e7 * x2 * e1 ^ 2 + 4 * e6 ^ 3 * e1 ^ 2 * x3 * y1 * y2 +
+12 * y1 * y2 * e1 ^ 2 * x3 * e6 ^ 2 * e7 + 6 * x1 * e1 ^ 3 * x3 * e6 ^ 2 * e7 +
+6 * x2 * e1 ^ 3 * x3 * e6 ^ 2 * e7 - 6 * e6 ^ 2 * e1 ^ 2 * x3 * e7 * e5 +
+12 * y1 * y2 * e1 ^ 2 * x3 * e7 ^ 2 * e6 + 2 * x1 * e1 ^ 3 * x2 * e7 ^ 3 +
+2 * x1 * e1 ^ 3 * x3 * e7 ^ 3 + 2 * x2 * e1 ^ 3 * x3 * e7 ^ 3 -
+2 * e5 * x1 * e1 ^ 2 * e7 ^ 3 - 2 * e5 * x2 * e1 ^ 2 * e7 ^ 3 -
+2 * e5 * e1 ^ 2 * x3 * e7 ^ 3 - 2 * e6 * e1 ^ 2 * x3 * e7 ^ 3 -
+2 * e6 * x1 * e1 ^ 2 * e7 ^ 3 - 2 * e6 * x2 * e1 ^ 2 * e7 ^ 3 -
+4 * e1 * e6 ^ 4 * y1 * y2 + 4 * e1 * e6 ^ 3 * y1 ^ 2 * y2 ^ 2 +
+6 * e1 * e6 ^ 3 * e7 * e5 + 3 * e1 * e5 ^ 2 * e6 ^ 2 * e7 +
+3 * e1 * e5 ^ 2 * e6 * e7 ^ 2 + 6 * e1 * e5 * e6 ^ 2 * e7 ^ 2 +
+2 * e1 * e5 * e6 * e7 ^ 3 + 4 * e1 * y1 ^ 2 * y2 ^ 2 * e7 ^ 3 +
+4 * y1 * y2 * x1 * e1 ^ 2 * e7 ^ 3 + 4 * y1 * y2 * x2 * e1 ^ 2 * e7 ^ 3 +
+4 * y1 * y2 * e1 ^ 2 * x3 * e7 ^ 3 - 4 * e1 * e6 ^ 3 * y1 * e5 * y2 -
+12 * e1 * e6 ^ 3 * e7 * y1 * y2 + 12 * e1 * e6 ^ 2 * e7 * y1 ^ 2 * y2 ^ 2 -
+12 * e1 * e6 ^ 2 * e7 * y1 * e5 * y2 - 12 * e1 * e7 ^ 2 * y1 * e5 * y2 * e6 -
+12 * e1 * e7 ^ 2 * y1 * e6 ^ 2 * y2 + 12 * e1 * e7 ^ 2 * y1 ^ 2 * e6 * y2 ^ 2 -
+4 * e1 * e5 * y1 * y2 * e7 ^ 3 - 4 * e1 * e6 * y1 * y2 * e7 ^ 3.
+
diff --git a/test-suite/complexity/setoid_rewrite.v b/test-suite/complexity/setoid_rewrite.v
new file mode 100644
index 00000000..3b5a0de7
--- /dev/null
+++ b/test-suite/complexity/setoid_rewrite.v
@@ -0,0 +1,10 @@
+(* Check bug #1176 *)
+(* Expected time < 0.50s *)
+
+Require Import Setoid.
+
+Variable f : nat -> Prop.
+
+Goal forall U:Prop, f 100 <-> U.
+intros U.
+Time setoid_replace U with False.
diff --git a/test-suite/failure/Case1.v b/test-suite/failure/Case1.v
index fafcafc1..df11ed38 100644
--- a/test-suite/failure/Case1.v
+++ b/test-suite/failure/Case1.v
@@ -1 +1,4 @@
-Type Cases O of x => O | O => (S O) end.
+Type match 0 with
+     | x => 0
+     | O => 1
+     end.
diff --git a/test-suite/failure/Case10.v b/test-suite/failure/Case10.v
index ee47544d..43cc1e34 100644
--- a/test-suite/failure/Case10.v
+++ b/test-suite/failure/Case10.v
@@ -1 +1,3 @@
-Type [x:nat]<nat> Cases x  of ((S x) as b) => (S b) end.
+Type (fun x : nat => match x return nat with
+                     | S x as b => S b
+                     end).
diff --git a/test-suite/failure/Case11.v b/test-suite/failure/Case11.v
index c39a76ca..e76d0609 100644
--- a/test-suite/failure/Case11.v
+++ b/test-suite/failure/Case11.v
@@ -1 +1,3 @@
-Type [x:nat]<nat> Cases x  of ((S x) as b) => (S b x) end.
+Type (fun x : nat => match x return nat with
+                     | S x as b => S b x
+                     end).
diff --git a/test-suite/failure/Case12.v b/test-suite/failure/Case12.v
index b56eac0d..cf6c2026 100644
--- a/test-suite/failure/Case12.v
+++ b/test-suite/failure/Case12.v
@@ -1,7 +1,8 @@
 
-Type [x:nat]<nat> Cases x  of 
-                  ((S x) as b) => <nat>Cases x  of
-                                        x => x 
-                                   end
-                          end.
-
+Type
+  (fun x : nat =>
+   match x return nat with
+   | S x as b => match x with
+                 | x => x
+                 end
+   end).
diff --git a/test-suite/failure/Case13.v b/test-suite/failure/Case13.v
index 8a4d75b6..994dfd20 100644
--- a/test-suite/failure/Case13.v
+++ b/test-suite/failure/Case13.v
@@ -1,5 +1,7 @@
-Type [x:nat]<nat> Cases x  of 
-                  ((S x) as b) => <nat>Cases x  of
-                                        x => (S b x)
-                                   end
-                          end.
+Type
+  (fun x : nat =>
+   match x return nat with
+   | S x as b => match x with
+                 | x => S b x
+                 end
+   end).
diff --git a/test-suite/failure/Case14.v b/test-suite/failure/Case14.v
index a198d068..ba0c51a1 100644
--- a/test-suite/failure/Case14.v
+++ b/test-suite/failure/Case14.v
@@ -1,8 +1,9 @@
-Inductive List [A:Set] :Set := 
- Nil:(List A) | Cons:A->(List A)->(List A).
+Inductive List (A : Set) : Set :=
+  | Nil : List A
+  | Cons : A -> List A -> List A.
 
-Definition NIL := (Nil nat).
-Type <(List nat)>Cases (Nil nat) of 
-                NIL   => NIL
-              |  _    => NIL
-              end.
+Definition NIL := Nil nat.
+Type match Nil nat return (List nat) with
+     | NIL => NIL
+     | _ => NIL
+     end.
diff --git a/test-suite/failure/Case15.v b/test-suite/failure/Case15.v
index a27b07f8..18faaf5c 100644
--- a/test-suite/failure/Case15.v
+++ b/test-suite/failure/Case15.v
@@ -1,6 +1,9 @@
 (* Non exhaustive pattern-matching *)
 
-Check [x]Cases x x of
-    O (S (S y)) => true
-  | O (S x) => false
-  | (S y) O => true end.
\ No newline at end of file
+Check
+  (fun x =>
+   match x, x with
+   | O, S (S y) => true
+   | O, S x => false
+   | S y, O => true
+   end).
diff --git a/test-suite/failure/Case16.v b/test-suite/failure/Case16.v
index f994a8f2..3739adae 100644
--- a/test-suite/failure/Case16.v
+++ b/test-suite/failure/Case16.v
@@ -1,9 +1,11 @@
 (* Check for redundant clauses *)
 
-Check [x]Cases x x of
-   O (S (S y)) => true
- | (S _) (S (S y)) => true
- | _ (S (S x)) => false 
- | (S y) O => true 
- | _ _ => true
-end.
+Check
+  (fun x =>
+   match x, x with
+   | O, S (S y) => true
+   | S _, S (S y) => true
+   | _, S (S x) => false
+   | S y, O => true
+   | _, _ => true
+   end).
diff --git a/test-suite/failure/Case2.v b/test-suite/failure/Case2.v
index 183f612b..7d81ee81 100644
--- a/test-suite/failure/Case2.v
+++ b/test-suite/failure/Case2.v
@@ -1,13 +1,13 @@
-Inductive IFExpr : Set := 
-          Var  : nat -> IFExpr
-        | Tr   : IFExpr
-        | Fa   : IFExpr
-        | IfE   : IFExpr -> IFExpr -> IFExpr -> IFExpr.
-
-Type [F:IFExpr]
-    <Prop>Cases F of
-       (IfE (Var _) H I) => True
-     | (IfE _ _ _)   => False
-     |  _          => True
-     end.
+Inductive IFExpr : Set :=
+  | Var : nat -> IFExpr
+  | Tr : IFExpr
+  | Fa : IFExpr
+  | IfE : IFExpr -> IFExpr -> IFExpr -> IFExpr.
 
+Type
+  (fun F : IFExpr =>
+   match F return Prop with
+   | IfE (Var _) H I => True
+   | IfE _ _ _ => False
+   | _ => True
+   end).
diff --git a/test-suite/failure/Case3.v b/test-suite/failure/Case3.v
index 2c651b87..ca450d5b 100644
--- a/test-suite/failure/Case3.v
+++ b/test-suite/failure/Case3.v
@@ -1,7 +1,10 @@
-Inductive List [A:Set] :Set := 
- Nil:(List A) | Cons:A->(List A)->(List A).
+Inductive List (A : Set) : Set :=
+  | Nil : List A
+  | Cons : A -> List A -> List A.
 
-Type [l:(List nat)]<nat>Cases l of 
-                         (Nil nat) =>O
-                      | (Cons  a l) => (S a)
-                      end.
+Type
+  (fun l : List nat =>
+   match l return nat with
+   | Nil nat => 0
+   | Cons a l => S a
+   end).
diff --git a/test-suite/failure/Case4.v b/test-suite/failure/Case4.v
index d00c9a05..de63c3f7 100644
--- a/test-suite/failure/Case4.v
+++ b/test-suite/failure/Case4.v
@@ -1,7 +1,7 @@
 
-Definition Berry := [x,y,z:bool] 
-  Cases x y z of 
-     true false _ => O
-   | false _ true => (S O)
-   | _ true false => (S (S O))
-end.
+Definition Berry (x y z : bool) :=
+  match x, y, z with
+  | true, false, _ => 0
+  | false, _, true => 1
+  | _, true, false => 2
+  end.
diff --git a/test-suite/failure/Case5.v b/test-suite/failure/Case5.v
index bdb5544b..29996fd4 100644
--- a/test-suite/failure/Case5.v
+++ b/test-suite/failure/Case5.v
@@ -1,3 +1,7 @@
-Inductive MS: Set := X:MS->MS | Y:MS->MS.
+Inductive MS : Set :=
+  | X : MS -> MS
+  | Y : MS -> MS.
  
-Type  [p:MS]<nat>Cases p of (X x) => O end.
+Type (fun p : MS => match p return nat with
+                    | X x => 0
+                    end).
diff --git a/test-suite/failure/Case6.v b/test-suite/failure/Case6.v
index f588d275..fb8659bf 100644
--- a/test-suite/failure/Case6.v
+++ b/test-suite/failure/Case6.v
@@ -1,10 +1,8 @@
-Inductive List [A:Set] :Set := 
- Nil:(List A) | Cons:A->(List A)->(List A).
-
-
-Type <(List nat)>Cases (Nil nat) of 
-                NIL   => NIL
-              | (CONS _ _)  => NIL
-
-              end.
-
+Inductive List (A : Set) : Set :=
+  | Nil : List A
+  | Cons : A -> List A -> List A.
+
+Type (match Nil nat return List nat with
+      | NIL   => NIL
+      | (CONS _ _)  => NIL
+      end).
diff --git a/test-suite/failure/Case7.v b/test-suite/failure/Case7.v
index 3718f198..64453481 100644
--- a/test-suite/failure/Case7.v
+++ b/test-suite/failure/Case7.v
@@ -1,22 +1,20 @@
-Inductive listn : nat-> Set := 
-  niln : (listn O) 
-| consn : (n:nat)nat->(listn n) -> (listn (S n)).
+Inductive listn : nat -> Set :=
+  | niln : listn 0
+  | consn : forall n : nat, nat -> listn n -> listn (S n).
 
-Definition length1:= [n:nat] [l:(listn n)]
-                    Cases l of 
-                     (consn n _ (consn m _ _)) => (S (S m))
-                    |(consn n _ _) => (S O)
-                    | _ => O
-                    end.
-
-Type [n:nat]
-       [l:(listn n)]
-        <nat>Cases n of 
-            O  => O
-        |  (S n)  =>
-             <([_:nat]nat)>Cases l of 
-                 niln  => (S O)
-              |  l'  => (length1 (S n) l')
-             end
-       end.
+Definition length1 (n : nat) (l : listn n) :=
+  match l with
+  | consn n _ (consn m _ _) => S (S m)
+  | consn n _ _ => 1
+  | _ => 0
+  end.
 
+Type
+  (fun (n : nat) (l : listn n) =>
+   match n return nat with
+   | O => 0
+   | S n => match l return nat with
+            | niln => 1
+            | l' => length1 (S n) l'
+            end
+   end).
diff --git a/test-suite/failure/Case8.v b/test-suite/failure/Case8.v
index 7f6bb615..feae29a7 100644
--- a/test-suite/failure/Case8.v
+++ b/test-suite/failure/Case8.v
@@ -1,8 +1,8 @@
-Inductive List [A:Set] :Set := 
- Nil:(List A) | Cons:A->(List A)->(List A).
-
-Type <nat>Cases (Nil nat) of 
-                             ((Nil_) as b) =>b
-                            |((Cons _ _ _) as d) => d
-                      end.
+Inductive List (A : Set) : Set :=
+  | Nil : List A
+  | Cons : A -> List A -> List A.
 
+Type match Nil nat return nat with
+     | b => b
+     | Cons _ _ _ as d => d
+     end.
diff --git a/test-suite/failure/Case9.v b/test-suite/failure/Case9.v
index e8d8e89a..a3b99f63 100644
--- a/test-suite/failure/Case9.v
+++ b/test-suite/failure/Case9.v
@@ -1,6 +1,8 @@
-Parameter compare : (n,m:nat)({(lt n m)}+{n=m})+{(gt n m)}.
-Type <nat>Cases (compare O O) of
-               (* k<i *)  (left _ _ (left _ _ _)) => O
-            |  (* k=i *)  (left _ _ _)  => O
-            |  (* k>i *)  (right _ _ _) => O end.
-
+Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}.
+Type
+  match compare 0 0 return nat with
+  
+      (* k<i *) | left _ _ (left _ _ _) => 0
+   (* k=i *) | left _ _ _ => 0
+   (* k>i *) | right _ _ _ => 0
+  end.
diff --git a/test-suite/failure/ClearBody.v b/test-suite/failure/ClearBody.v
index ca8e3c68..609d5b3b 100644
--- a/test-suite/failure/ClearBody.v
+++ b/test-suite/failure/ClearBody.v
@@ -2,7 +2,7 @@
    invalidate the well-typabilility of the visible goal *)
 
 Goal True.
-LetTac n:=O.
-LetTac I:=(refl_equal nat O).
-Change (n=O) in (Type of I).
-ClearBody n.
+set (n := 0) in *.
+set (I := refl_equal 0) in *.
+change (n = 0) in (type of I).
+clearbody n.
diff --git a/test-suite/failure/Notations.v b/test-suite/failure/Notations.v
new file mode 100644
index 00000000..074e176a
--- /dev/null
+++ b/test-suite/failure/Notations.v
@@ -0,0 +1,7 @@
+(* Submitted by Roland Zumkeller *)
+
+Notation "! A" := (forall i:nat, A) (at level 60).
+
+(* Should fail: no dynamic capture *)
+Check ! (i=i).
+
diff --git a/test-suite/failure/Tauto.v b/test-suite/failure/Tauto.v
index fb9a27bb..cda2d51e 100644
--- a/test-suite/failure/Tauto.v
+++ b/test-suite/failure/Tauto.v
@@ -15,6 +15,6 @@
   Simplifications of goals, based on LJT calcul ****)
 
 (* Fails because Tauto does not perform any Apply *)
-Goal ((A:Prop)A\/~A)->(x,y:nat)(x=y\/~x=y).
+Goal (forall A : Prop, A \/ ~ A) -> forall x y : nat, x = y \/ x <> y.
 Proof.
-  Tauto.
+   tauto.
diff --git a/test-suite/failure/Uminus.v b/test-suite/failure/Uminus.v
new file mode 100644
index 00000000..6866f19a
--- /dev/null
+++ b/test-suite/failure/Uminus.v
@@ -0,0 +1,62 @@
+(* Check that the encoding of system U- fails *)
+
+Inductive prop : Prop := down : Prop -> prop.
+
+Definition up (p:prop) : Prop := let (A) := p in A.
+
+Lemma p2p1 : forall A:Prop, up (down A) -> A.
+Proof.
+exact (fun A x => x).
+Qed.
+
+Lemma p2p2 : forall A:Prop, A -> up (down A).
+Proof.
+exact (fun A x => x).
+Qed.
+
+(** Hurkens' paradox *)
+
+Definition V := forall A:Prop, ((A -> prop) -> A -> prop) -> A -> prop.
+Definition U := V -> prop.
+Definition sb (z:V) : V := fun A r a => r (z A r) a.
+Definition le (i:U -> prop) (x:U) : prop :=
+  x (fun A r a => i (fun v => sb v A r a)).
+Definition induct (i:U -> prop) : Prop :=
+  forall x:U, up (le i x) -> up (i x).
+Definition WF : U := fun z => down (induct (z U le)).
+Definition I (x:U) : Prop :=
+  (forall i:U -> prop, up (le i x) -> up (i (fun v => sb v U le x))) -> False.
+
+Lemma Omega : forall i:U -> prop, induct i -> up (i WF).
+Proof.
+intros i y.
+apply y.
+unfold le, WF, induct in |- *.
+intros x H0.
+apply y.
+exact H0.
+Qed.
+
+Lemma lemma1 : induct (fun u => down (I u)).
+Proof.
+unfold induct in |- *.
+intros x p.
+intro q.
+apply (q (fun u => down (I u)) p).
+intro i.
+apply q with (i := fun y => i (fun v:V => sb v U le y)).
+Qed.
+
+Lemma lemma2 : (forall i:U -> prop, induct i -> up (i WF)) -> False.
+Proof.
+intro x.
+apply (x (fun u => down (I u)) lemma1).
+intros i H0.
+apply (x (fun y => i (fun v => sb v U le y))).
+apply H0.
+Qed.
+
+Theorem paradox : False.
+Proof.
+exact (lemma2 Omega).
+Qed.
diff --git a/test-suite/failure/autorewritein.v b/test-suite/failure/autorewritein.v
new file mode 100644
index 00000000..dc17742a
--- /dev/null
+++ b/test-suite/failure/autorewritein.v
@@ -0,0 +1,15 @@
+Variable Ack : nat -> nat -> nat.
+
+Axiom Ack0 : forall m : nat, Ack 0 m = S m.
+Axiom Ack1 : forall n : nat, Ack (S n) 0 = Ack n 1.
+Axiom Ack2 : forall n m : nat, Ack (S n) (S m) = Ack n (Ack (S n) m).
+
+Hint Rewrite Ack0 Ack1 Ack2 : base0.
+
+Lemma ResAck2 : forall H:(Ack 2 2 = 7 -> False), H=H  -> False.
+Proof.
+  intros.
+  autorewrite with base0 in * using try (apply H1;reflexivity).
+
+
+
diff --git a/test-suite/failure/cases.v b/test-suite/failure/cases.v
index a27b07f8..18faaf5c 100644
--- a/test-suite/failure/cases.v
+++ b/test-suite/failure/cases.v
@@ -1,6 +1,9 @@
 (* Non exhaustive pattern-matching *)
 
-Check [x]Cases x x of
-    O (S (S y)) => true
-  | O (S x) => false
-  | (S y) O => true end.
\ No newline at end of file
+Check
+  (fun x =>
+   match x, x with
+   | O, S (S y) => true
+   | O, S x => false
+   | S y, O => true
+   end).
diff --git a/test-suite/failure/check.v b/test-suite/failure/check.v
index 0bf7091c..649fdd2d 100644
--- a/test-suite/failure/check.v
+++ b/test-suite/failure/check.v
@@ -1,3 +1,3 @@
-Implicits eq [1].
+Implicit Arguments eq [A].
 
-Check (eq bool true).
+Check (bool = true).
diff --git a/test-suite/failure/clash_cons.v b/test-suite/failure/clash_cons.v
index 56cd73f4..07db69a9 100644
--- a/test-suite/failure/clash_cons.v
+++ b/test-suite/failure/clash_cons.v
@@ -8,9 +8,8 @@
 (* Teste la verification d'unicite des noms de constr *)
 
 
-Inductive X : Set := 
+Inductive X : Set :=
     cons : X.
 
-Inductive Y : Set := 
+Inductive Y : Set :=
     cons : Y.
-
diff --git a/test-suite/failure/clashes.v b/test-suite/failure/clashes.v
index fcfd29fe..207d62b9 100644
--- a/test-suite/failure/clashes.v
+++ b/test-suite/failure/clashes.v
@@ -4,5 +4,6 @@
    S.n to keep n accessible... *)
 
 Section S.
-Variable n:nat.
-Inductive P : Set := n : P.
+Variable n : nat.
+Inductive P : Set :=
+    n : P.
diff --git a/test-suite/failure/coqbugs0266.v b/test-suite/failure/coqbugs0266.v
index 2ac6c4f0..79eef5c9 100644
--- a/test-suite/failure/coqbugs0266.v
+++ b/test-suite/failure/coqbugs0266.v
@@ -1,7 +1,7 @@
 (* It is forbidden to erase a variable (or a local def) that is used in
    the current goal. *)
 Section S.
-Local a:=O.
-Definition b:=a.
-Goal b=b.
-Clear a.
+Let a := 0.
+Definition b := a.
+Goal b = b.
+clear a.
diff --git a/test-suite/failure/fixpoint1.v b/test-suite/failure/fixpoint1.v
index 742e9774..7d0d9d2d 100644
--- a/test-suite/failure/fixpoint1.v
+++ b/test-suite/failure/fixpoint1.v
@@ -5,5 +5,6 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-Fixpoint PreParadox [u:unit] : False := (PreParadox u).
-Definition Paradox := (PreParadox tt).
\ No newline at end of file
+Fixpoint PreParadox (u : unit) : False := PreParadox u.
+Definition Paradox := PreParadox tt.
+
diff --git a/test-suite/failure/inductive1.v b/test-suite/failure/inductive1.v
new file mode 100644
index 00000000..3b57d919
--- /dev/null
+++ b/test-suite/failure/inductive1.v
@@ -0,0 +1,4 @@
+(* A check that sort-polymorphic product is not set too low *)
+
+Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
+Check (fun (A:Type) (B:Prop) => (prod A B : Prop)).
diff --git a/test-suite/failure/inductive2.v b/test-suite/failure/inductive2.v
new file mode 100644
index 00000000..b77474be
--- /dev/null
+++ b/test-suite/failure/inductive2.v
@@ -0,0 +1,4 @@
+(* A check that sort-polymorphic product is not set too low *)
+
+Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
+Check (fun (A:Prop) (B:Type) => (prod A B : Prop)).
diff --git a/test-suite/failure/inductive3.v b/test-suite/failure/inductive3.v
new file mode 100644
index 00000000..e5a4e1b6
--- /dev/null
+++ b/test-suite/failure/inductive3.v
@@ -0,0 +1,5 @@
+(* Check that the nested inductive types positivity check avoids recursively 
+   non uniform parameters (at least if these parameters break positivity) *)
+
+Inductive t (A:Type) : Type := c : t (A -> A) -> t A.
+Inductive u : Type := d : u | e : t u -> u.
diff --git a/test-suite/failure/ltac1.v b/test-suite/failure/ltac1.v
index d0256619..7b496a75 100644
--- a/test-suite/failure/ltac1.v
+++ b/test-suite/failure/ltac1.v
@@ -1,5 +1,7 @@
 (* Check all variables are different in a Context *)
-Tactic Definition X := Match Context With [ x:?; x:? |- ? ] -> Apply x.
-Goal True->True->True.
-Intros.
+Ltac X := match goal with
+          | x:_,x:_ |- _ => apply x
+          end.
+Goal True -> True -> True.
+intros.
 X.
diff --git a/test-suite/failure/ltac2.v b/test-suite/failure/ltac2.v
index 55925a7a..14436e58 100644
--- a/test-suite/failure/ltac2.v
+++ b/test-suite/failure/ltac2.v
@@ -1,6 +1,6 @@
 (* Check that Match arguments are forbidden *)
-Tactic Definition E x := Apply x.
-Goal True->True.
-E (Match Context With [ |- ? ] -> Intro H).
-(* Should fail with "Immediate Match producing tactics not allowed in 
-   local definitions" *)
+Ltac E x := apply x.
+Goal True -> True.
+E ltac:(match goal with
+        |  |- _ => intro H
+        end).
diff --git a/test-suite/failure/ltac3.v b/test-suite/failure/ltac3.v
deleted file mode 100644
index bfccc546..00000000
--- a/test-suite/failure/ltac3.v
+++ /dev/null
@@ -1,2 +0,0 @@
-(* Proposed by Benjamin *)
-Definition A := Try REflexivity.
diff --git a/test-suite/failure/ltac4.v b/test-suite/failure/ltac4.v
index d1e4e892..41471275 100644
--- a/test-suite/failure/ltac4.v
+++ b/test-suite/failure/ltac4.v
@@ -1,4 +1,5 @@
 (* Check static globalisation of tactic names *)
 (* Proposed by Benjamin (mars 2002) *)
-Goal (n:nat)n=n.
-Induction n; Try REflexivity.
+Goal forall n : nat, n = n.
+induction n; try REflexivity.
+
diff --git a/test-suite/failure/params_ind.v b/test-suite/failure/params_ind.v
deleted file mode 100644
index 20689128..00000000
--- a/test-suite/failure/params_ind.v
+++ /dev/null
@@ -1,4 +0,0 @@
-Inductive list [A:Set] : Set :=
-   nil : (list A)
-|  cons : A -> (list A->A)-> (list A).
-
diff --git a/test-suite/failure/pattern.v b/test-suite/failure/pattern.v
new file mode 100644
index 00000000..129c380e
--- /dev/null
+++ b/test-suite/failure/pattern.v
@@ -0,0 +1,9 @@
+(* Check that untypable beta-expansion are trapped *)
+
+Variable A : nat -> Type.
+Variable n : nat.
+Variable P : forall m : nat, m = n -> Prop.
+
+Goal forall p : n = n, P n p.
+intro.
+pattern n, p in |- *.
diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v
index b43eb899..21683605 100644
--- a/test-suite/failure/positivity.v
+++ b/test-suite/failure/positivity.v
@@ -5,4 +5,5 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-Inductive t:Set := c: (t -> nat) -> t.
+Inductive t : Set :=
+    c : (t -> nat) -> t.
diff --git a/test-suite/failure/proofirrelevance.v b/test-suite/failure/proofirrelevance.v
new file mode 100644
index 00000000..eedf2612
--- /dev/null
+++ b/test-suite/failure/proofirrelevance.v
@@ -0,0 +1,11 @@
+(* This was working in version 8.1beta (bug in the Sort-polymorphism
+   of inductive types), but this is inconsistent with classical logic 
+   in Prop *)
+
+Inductive bool_in_prop : Type := hide : bool -> bool_in_prop
+with bool : Type := true : bool | false : bool.
+
+Lemma not_proof_irrelevance : ~ forall (P:Prop) (p p':P), p=p'.
+intro H; pose proof (H bool_in_prop (hide true) (hide false)); discriminate.
+Qed.
+
diff --git a/test-suite/failure/rewrite_in_goal.v b/test-suite/failure/rewrite_in_goal.v
new file mode 100644
index 00000000..c11a6237
--- /dev/null
+++ b/test-suite/failure/rewrite_in_goal.v
@@ -0,0 +1,3 @@
+Goal forall T1 T2 (H:T1=T2) (f:T1->Prop) (x:T1) , f x -> Type.
+  intros until x.
+  rewrite H in x.
diff --git a/test-suite/failure/rewrite_in_hyp.v b/test-suite/failure/rewrite_in_hyp.v
new file mode 100644
index 00000000..613d707c
--- /dev/null
+++ b/test-suite/failure/rewrite_in_hyp.v
@@ -0,0 +1,3 @@
+Goal forall (T1 T2 : Type) (f:T1 -> Prop) (x:T1) (H:T1=T2), f x -> 0=1.
+  intros T1 T2 f x H fx.
+  rewrite H in x.
diff --git a/test-suite/failure/search.v b/test-suite/failure/search.v
index e8ca8494..ef750b50 100644
--- a/test-suite/failure/search.v
+++ b/test-suite/failure/search.v
@@ -5,4 +5,5 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-SearchPattern ? = ? outside n_existe_pas.
+
+SearchPattern (_ = _) outside n_existe_pas.
diff --git a/test-suite/failure/universes-buraliforti-redef.v b/test-suite/failure/universes-buraliforti-redef.v
new file mode 100644
index 00000000..049f97f2
--- /dev/null
+++ b/test-suite/failure/universes-buraliforti-redef.v
@@ -0,0 +1,246 @@
+(* A variant of Burali-Forti that used to pass in V8.1beta, because of
+   a bug in the instantiation of sort-polymorphic inductive types *)
+
+(* The following type seems to satisfy the hypothesis of the paradox below *)
+(* It should infer constraints forbidding the paradox to go through, but via *)
+(* a redefinition that did not propagate constraints correctly in V8.1beta *)
+(* it was exploitable to derive an inconsistency *)
+
+(* We keep the file as a non regression test of the bug *)
+
+  Record A1 (B:Type) (g:B->Type) : Type :=  (* Type_i' *)
+    i1 {X0 : B; R0 : g X0 -> g X0 -> Prop}. (* X0: Type_j' *)
+
+  Definition A2 := A1. (* here was the bug *)
+
+  Definition A0 := (A2 Type (fun x => x)).
+  Definition i0 := (i1 Type (fun x => x)).
+
+(* The rest is as in universes-buraliforti.v *)
+
+
+(* Some properties about relations on objects in Type *)
+
+  Inductive ACC (A : Type) (R : A -> A -> Prop) : A -> Prop :=
+      ACC_intro :
+        forall x : A, (forall y : A, R y x -> ACC A R y) -> ACC A R x.
+
+  Lemma ACC_nonreflexive :
+   forall (A : Type) (R : A -> A -> Prop) (x : A),
+   ACC A R x -> R x x -> False.
+simple induction 1; intros.
+exact (H1 x0 H2 H2).
+Qed.
+
+  Definition WF (A : Type) (R : A -> A -> Prop) := forall x : A, ACC A R x.
+
+
+Section Inverse_Image.
+
+  Variables (A B : Type) (R : B -> B -> Prop) (f : A -> B).
+
+  Definition Rof (x y : A) : Prop := R (f x) (f y).
+
+  Remark ACC_lemma :
+   forall y : B, ACC B R y -> forall x : A, y = f x -> ACC A Rof x.
+    simple induction 1; intros.
+    constructor; intros.
+    apply (H1 (f y0)); trivial.
+    elim H2 using eq_ind_r; trivial.
+    Qed.
+
+  Lemma ACC_inverse_image : forall x : A, ACC B R (f x) -> ACC A Rof x.
+    intros; apply (ACC_lemma (f x)); trivial.
+    Qed.
+
+  Lemma WF_inverse_image : WF B R -> WF A Rof.
+    red in |- *; intros; apply ACC_inverse_image; auto.
+    Qed.
+
+End Inverse_Image.
+
+
+(* Remark: the paradox is written in Type, but also works in Prop or Set. *)
+
+Section Burali_Forti_Paradox.
+
+  Definition morphism (A : Type) (R : A -> A -> Prop) 
+    (B : Type) (S : B -> B -> Prop) (f : A -> B) :=
+    forall x y : A, R x y -> S (f x) (f y).
+
+  (* The hypothesis of the paradox:
+     assumes there exists an universal system of notations, i.e:
+      - A type A0
+      - An injection i0 from relations on any type into A0
+      - The proof that i0 is injective modulo morphism 
+   *)
+  Variable A0 : Type.                     (* Type_i *)
+  Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *)
+  Hypothesis
+    inj :
+      forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type)
+        (R2 : X2 -> X2 -> Prop),
+      i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f.
+
+  (* Embedding of x in y: x and y are images of 2 well founded relations
+     R1 and R2, the ordinal of R2 being strictly greater than that of R1.
+   *)
+  Record emb (x y : A0) : Prop := 
+    {X1 : Type;
+     R1 : X1 -> X1 -> Prop;
+     eqx : x = i0 X1 R1;
+     X2 : Type;
+     R2 : X2 -> X2 -> Prop;
+     eqy : y = i0 X2 R2;
+     W2 : WF X2 R2;
+     f : X1 -> X2;
+     fmorph : morphism X1 R1 X2 R2 f;
+     maj : X2;
+     majf : forall z : X1, R2 (f z) maj}.
+
+  Lemma emb_trans : forall x y z : A0, emb x y -> emb y z -> emb x z.
+intros.
+case H; intros X1 R1 eqx X2 R2 eqy; intros.
+case H0; intros X3 R3 eqx0 X4 R4 eqy0; intros.
+generalize eqx0; clear eqx0.
+elim eqy using eq_ind_r; intro.
+case (inj _ _ _ _ eqx0); intros.
+exists X1 R1 X4 R4 (fun x : X1 => f0 (x0 (f x))) maj0; trivial.
+red in |- *; auto.
+Defined.
+
+
+  Lemma ACC_emb :
+   forall (X : Type) (R : X -> X -> Prop) (x : X),
+   ACC X R x ->
+   forall (Y : Type) (S : Y -> Y -> Prop) (f : Y -> X),
+   morphism Y S X R f -> (forall y : Y, R (f y) x) -> ACC A0 emb (i0 Y S).
+simple induction 1; intros.
+constructor; intros.
+case H4; intros.
+elim eqx using eq_ind_r.
+case (inj X2 R2 Y S).
+apply sym_eq; assumption.
+
+intros.
+apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x)));
+ try red in |- *; auto.
+Defined.
+
+  (* The embedding relation is well founded *)
+  Lemma WF_emb : WF A0 emb.
+constructor; intros.
+case H; intros.
+elim eqx using eq_ind_r.
+apply ACC_emb with (X := X2) (R := R2) (x := maj) (f := f); trivial.
+Defined.
+
+
+  (* The following definition enforces Type_j >= Type_i *)
+  Definition Omega : A0 := i0 A0 emb.
+
+
+Section Subsets.
+
+  Variable a : A0.
+
+  (* We define the type of elements of A0 smaller than a w.r.t embedding.
+     The Record is in Type, but it is possible to avoid such structure. *)
+  Record sub : Type :=  {witness : A0; emb_wit : emb witness a}.
+
+  (* F is its image through i0 *)
+  Definition F : A0 := i0 sub (Rof _ _ emb witness).
+
+  (* F is embedded in Omega:
+     - the witness projection is a morphism
+     - a is an upper bound because emb_wit proves that witness is
+       smaller than a.
+   *)
+  Lemma F_emb_Omega : emb F Omega.
+exists sub (Rof _ _ emb witness) A0 emb witness a; trivial.
+exact WF_emb.
+
+red in |- *; trivial.
+
+exact emb_wit.
+Defined.
+
+End Subsets.
+
+
+  Definition fsub (a b : A0) (H : emb a b) (x : sub a) : 
+    sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H).
+
+  (* F is a morphism: a < b => F(a) < F(b)
+      - the morphism from F(a) to F(b) is fsub above
+      - the upper bound is a, which is in F(b) since a < b
+   *)
+  Lemma F_morphism : morphism A0 emb A0 emb F.
+red in |- *; intros.
+exists
+ (sub x)
+   (Rof _ _ emb (witness x))
+   (sub y)
+   (Rof _ _ emb (witness y))
+   (fsub x y H)
+   (Build_sub _ x H); trivial.
+apply WF_inverse_image.
+exact WF_emb.
+
+unfold morphism, Rof, fsub in |- *; simpl in |- *; intros.
+trivial.
+
+unfold Rof, fsub in |- *; simpl in |- *; intros.
+apply emb_wit.
+Defined.
+
+
+  (* Omega is embedded in itself:
+     - F is a morphism
+     - Omega is an upper bound of the image of F
+   *)
+  Lemma Omega_refl : emb Omega Omega.
+exists A0 emb A0 emb F Omega; trivial.
+exact WF_emb.
+
+exact F_morphism.
+
+exact F_emb_Omega.
+Defined.
+
+  (* The paradox is that Omega cannot be embedded in itself, since
+     the embedding relation is well founded.
+   *)
+  Theorem Burali_Forti : False.
+apply ACC_nonreflexive with A0 emb Omega.
+apply WF_emb.
+
+exact Omega_refl.
+
+Defined.
+
+End Burali_Forti_Paradox.
+
+
+  (* Note: this proof uses a large elimination of A0. *)
+  Lemma inj :
+   forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type)
+     (R2 : X2 -> X2 -> Prop),
+   i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f.
+intros.
+change
+  match i0 X1 R1, i0 X2 R2 with
+  | i1 x1 r1, i1 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f
+  end in |- *.
+case H; simpl in |- *.
+exists (fun x : X1 => x).
+red in |- *; trivial.
+Defined.
+
+(* The following command raises 'Error: Universe Inconsistency'.
+   To allow large elimination of A0, i0 must not be a large constructor.
+   Hence, the constraint Type_j' < Type_i' is added, which is incompatible
+   with the constraint j >= i in the paradox.
+*)
+
+  Definition Paradox : False := Burali_Forti A0 i0 inj.
diff --git a/test-suite/failure/universes-buraliforti.v b/test-suite/failure/universes-buraliforti.v
index 01d46133..d18d2119 100644
--- a/test-suite/failure/universes-buraliforti.v
+++ b/test-suite/failure/universes-buraliforti.v
@@ -4,38 +4,41 @@
 
 (* Some properties about relations on objects in Type *)
 
-  Inductive ACC [A : Type; R : A->A->Prop] : A->Prop :=
-      ACC_intro : (x:A)((y:A)(R y x)->(ACC A R y))->(ACC A R x).
+  Inductive ACC (A : Type) (R : A -> A -> Prop) : A -> Prop :=
+      ACC_intro :
+        forall x : A, (forall y : A, R y x -> ACC A R y) -> ACC A R x.
 
-  Lemma ACC_nonreflexive:
-    (A:Type)(R:A->A->Prop)(x:A)(ACC A R x)->(R x x)->False.
-Induction 1; Intros.
-Exact (H1 x0 H2 H2).
-Save.
+  Lemma ACC_nonreflexive :
+   forall (A : Type) (R : A -> A -> Prop) (x : A),
+   ACC A R x -> R x x -> False.
+simple induction 1; intros.
+exact (H1 x0 H2 H2).
+Qed.
 
-  Definition WF := [A:Type][R:A->A->Prop](x:A)(ACC A R x).
+  Definition WF (A : Type) (R : A -> A -> Prop) := forall x : A, ACC A R x.
 
 
 Section Inverse_Image.
 
-  Variables A,B:Type; R:B->B->Prop; f:A->B.
+  Variables (A B : Type) (R : B -> B -> Prop) (f : A -> B).
 
-  Definition Rof : A->A->Prop := [x,y:A](R (f x) (f y)).
+  Definition Rof (x y : A) : Prop := R (f x) (f y).
 
-  Remark ACC_lemma : (y:B)(ACC B R y)->(x:A)(y==(f x))->(ACC A Rof x).
-    Induction 1; Intros.
-    Constructor; Intros.
-    Apply (H1 (f y0)); Trivial.
-    Elim H2 using eqT_ind_r; Trivial.
-    Save.
+  Remark ACC_lemma :
+   forall y : B, ACC B R y -> forall x : A, y = f x -> ACC A Rof x.
+    simple induction 1; intros.
+    constructor; intros.
+    apply (H1 (f y0)); trivial.
+    elim H2 using eq_ind_r; trivial.
+    Qed.
 
-  Lemma ACC_inverse_image : (x:A)(ACC B R (f x)) -> (ACC A Rof x).
-    Intros; Apply (ACC_lemma (f x)); Trivial.
-    Save.
+  Lemma ACC_inverse_image : forall x : A, ACC B R (f x) -> ACC A Rof x.
+    intros; apply (ACC_lemma (f x)); trivial.
+    Qed.
 
-  Lemma WF_inverse_image: (WF B R)->(WF A Rof).
-    Red; Intros; Apply ACC_inverse_image; Auto.
-    Save.
+  Lemma WF_inverse_image : WF B R -> WF A Rof.
+    red in |- *; intros; apply ACC_inverse_image; auto.
+    Qed.
 
 End Inverse_Image.
 
@@ -44,8 +47,9 @@ End Inverse_Image.
 
 Section Burali_Forti_Paradox.
 
-  Definition morphism := [A:Type][R:A->A->Prop][B:Type][S:B->B->Prop][f:A->B]
-    (x,y:A)(R x y)->(S (f x) (f y)).
+  Definition morphism (A : Type) (R : A -> A -> Prop) 
+    (B : Type) (S : B -> B -> Prop) (f : A -> B) :=
+    forall x y : A, R x y -> S (f x) (f y).
 
   (* The hypothesis of the paradox:
      assumes there exists an universal system of notations, i.e:
@@ -53,120 +57,125 @@ Section Burali_Forti_Paradox.
       - An injection i0 from relations on any type into A0
       - The proof that i0 is injective modulo morphism 
    *)
-  Variable   A0  : Type.                     (* Type_i *)
-  Variable   i0  : (X:Type)(X->X->Prop)->A0. (* X: Type_j *)
-  Hypothesis inj : (X1:Type)(R1:X1->X1->Prop)(X2:Type)(R2:X2->X2->Prop)
-                     (i0 X1 R1)==(i0 X2 R2)
-                       ->(EXT f:X1->X2 | (morphism X1 R1 X2 R2 f)).
+  Variable A0 : Type.                     (* Type_i *)
+  Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *)
+  Hypothesis
+    inj :
+      forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type)
+        (R2 : X2 -> X2 -> Prop),
+      i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f.
 
   (* Embedding of x in y: x and y are images of 2 well founded relations
      R1 and R2, the ordinal of R2 being strictly greater than that of R1.
    *)
-  Record emb [x,y:A0]: Prop := {
-    X1: Type;
-    R1: X1->X1->Prop;
-    eqx: x==(i0 X1 R1);
-    X2: Type;
-    R2: X2->X2->Prop;
-    eqy: y==(i0 X2 R2);
-    W2: (WF X2 R2);
-    f: X1->X2;
-    fmorph: (morphism X1 R1 X2 R2 f);
-    maj: X2;
-    majf: (z:X1)(R2 (f z) maj) }.
-
-
-  Lemma emb_trans: (x,y,z:A0)(emb x y)->(emb y z)->(emb x z).
-Intros.
-Case H; Intros.
-Case H0; Intros.
-Generalize eqx0; Clear eqx0.
-Elim eqy using eqT_ind_r; Intro.
-Case (inj ? ? ? ? eqx0); Intros.
-Exists X1 R1 X3 R3 [x:X1](f0 (x0 (f x))) maj0; Trivial.
-Red; Auto.
+  Record emb (x y : A0) : Prop := 
+    {X1 : Type;
+     R1 : X1 -> X1 -> Prop;
+     eqx : x = i0 X1 R1;
+     X2 : Type;
+     R2 : X2 -> X2 -> Prop;
+     eqy : y = i0 X2 R2;
+     W2 : WF X2 R2;
+     f : X1 -> X2;
+     fmorph : morphism X1 R1 X2 R2 f;
+     maj : X2;
+     majf : forall z : X1, R2 (f z) maj}.
+
+
+  Lemma emb_trans : forall x y z : A0, emb x y -> emb y z -> emb x z.
+intros.
+case H; intros.
+case H0; intros.
+generalize eqx0; clear eqx0.
+elim eqy using eq_ind_r; intro.
+case (inj _ _ _ _ eqx0); intros.
+exists X1 R1 X3 R3 (fun x : X1 => f0 (x0 (f x))) maj0; trivial.
+red in |- *; auto.
 Defined.
 
 
-  Lemma ACC_emb: (X:Type)(R:X->X->Prop)(x:X)(ACC X R x)
-    ->(Y:Type)(S:Y->Y->Prop)(f:Y->X)(morphism Y S X R f)
-      ->((y:Y)(R (f y) x))
-        ->(ACC A0 emb (i0 Y S)).
-Induction 1; Intros.
-Constructor; Intros.
-Case H4; Intros.
-Elim eqx using eqT_ind_r.
-Case (inj X2 R2 Y S).
-Apply sym_eqT; Assumption.
-
-Intros.
-Apply H1 with y:=(f (x1 maj)) f:=[x:X1](f (x1 (f0 x))); Try Red; Auto.
+  Lemma ACC_emb :
+   forall (X : Type) (R : X -> X -> Prop) (x : X),
+   ACC X R x ->
+   forall (Y : Type) (S : Y -> Y -> Prop) (f : Y -> X),
+   morphism Y S X R f -> (forall y : Y, R (f y) x) -> ACC A0 emb (i0 Y S).
+simple induction 1; intros.
+constructor; intros.
+case H4; intros.
+elim eqx using eq_ind_r.
+case (inj X2 R2 Y S).
+apply sym_eq; assumption.
+
+intros.
+apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x)));
+ try red in |- *; auto.
 Defined.
 
   (* The embedding relation is well founded *)
-  Lemma WF_emb: (WF A0 emb).
-Constructor; Intros.
-Case H; Intros.
-Elim eqx using eqT_ind_r.
-Apply ACC_emb with X:=X2 R:=R2 x:=maj f:=f; Trivial.
+  Lemma WF_emb : WF A0 emb.
+constructor; intros.
+case H; intros.
+elim eqx using eq_ind_r.
+apply ACC_emb with (X := X2) (R := R2) (x := maj) (f := f); trivial.
 Defined.
 
 
   (* The following definition enforces Type_j >= Type_i *)
-  Definition Omega: A0 := (i0 A0 emb).
+  Definition Omega : A0 := i0 A0 emb.
 
 
 Section Subsets.
 
-  Variable a: A0.
+  Variable a : A0.
 
   (* We define the type of elements of A0 smaller than a w.r.t embedding.
      The Record is in Type, but it is possible to avoid such structure. *)
-  Record sub: Type := {
-    witness : A0;
-    emb_wit : (emb witness a) }.
+  Record sub : Type :=  {witness : A0; emb_wit : emb witness a}.
 
   (* F is its image through i0 *)
-  Definition F : A0 := (i0 sub (Rof ? ? emb witness)).
+  Definition F : A0 := i0 sub (Rof _ _ emb witness).
 
   (* F is embedded in Omega:
      - the witness projection is a morphism
      - a is an upper bound because emb_wit proves that witness is
        smaller than a.
    *)
-  Lemma F_emb_Omega: (emb F Omega).
-Exists sub (Rof ? ? emb witness) A0 emb witness a; Trivial.
-Exact WF_emb.
+  Lemma F_emb_Omega : emb F Omega.
+exists sub (Rof _ _ emb witness) A0 emb witness a; trivial.
+exact WF_emb.
 
-Red; Trivial.
+red in |- *; trivial.
 
-Exact emb_wit.
+exact emb_wit.
 Defined.
 
 End Subsets.
 
 
-  Definition fsub: (a,b:A0)(emb a b)->(sub a)->(sub b):=
-    [_,_][H][x]
-      (Build_sub ? (witness ? x) (emb_trans ? ? ? (emb_wit ? x) H)).
+  Definition fsub (a b : A0) (H : emb a b) (x : sub a) : 
+    sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H).
 
   (* F is a morphism: a < b => F(a) < F(b)
       - the morphism from F(a) to F(b) is fsub above
       - the upper bound is a, which is in F(b) since a < b
    *)
-  Lemma F_morphism: (morphism A0 emb A0 emb F).
-Red; Intros.
-Exists (sub x) (Rof ? ? emb (witness x)) (sub y)
-       (Rof ? ? emb (witness y)) (fsub x y H) (Build_sub ? x H); 
-Trivial.
-Apply WF_inverse_image.
-Exact WF_emb.
-
-Unfold morphism Rof fsub; Simpl; Intros.
-Trivial.
-
-Unfold Rof fsub; Simpl; Intros.
-Apply emb_wit.
+  Lemma F_morphism : morphism A0 emb A0 emb F.
+red in |- *; intros.
+exists
+ (sub x)
+   (Rof _ _ emb (witness x))
+   (sub y)
+   (Rof _ _ emb (witness y))
+   (fsub x y H)
+   (Build_sub _ x H); trivial.
+apply WF_inverse_image.
+exact WF_emb.
+
+unfold morphism, Rof, fsub in |- *; simpl in |- *; intros.
+trivial.
+
+unfold Rof, fsub in |- *; simpl in |- *; intros.
+apply emb_wit.
 Defined.
 
 
@@ -174,23 +183,23 @@ Defined.
      - F is a morphism
      - Omega is an upper bound of the image of F
    *)
-  Lemma Omega_refl: (emb Omega Omega).
-Exists A0 emb A0 emb F Omega; Trivial.
-Exact WF_emb.
+  Lemma Omega_refl : emb Omega Omega.
+exists A0 emb A0 emb F Omega; trivial.
+exact WF_emb.
 
-Exact F_morphism.
+exact F_morphism.
 
-Exact F_emb_Omega.
+exact F_emb_Omega.
 Defined.
 
   (* The paradox is that Omega cannot be embedded in itself, since
      the embedding relation is well founded.
    *)
-  Theorem Burali_Forti: False.
-Apply ACC_nonreflexive with A0 emb Omega.
-Apply WF_emb.
+  Theorem Burali_Forti : False.
+apply ACC_nonreflexive with A0 emb Omega.
+apply WF_emb.
 
-Exact Omega_refl.
+exact Omega_refl.
 
 Defined.
 
@@ -200,21 +209,23 @@ End Burali_Forti_Paradox.
   (* The following type seems to satisfy the hypothesis of the paradox.
      But it does not!
    *)
-  Record A0: Type := (* Type_i' *)
-    i0 { X0: Type; R0: X0->X0->Prop }. (* X0: Type_j' *)
+  Record A0 : Type :=  (* Type_i' *)
+    i0 {X0 : Type; R0 : X0 -> X0 -> Prop}. (* X0: Type_j' *)
 
 
   (* Note: this proof uses a large elimination of A0. *)
-  Lemma inj : (X1:Type)(R1:X1->X1->Prop)(X2:Type)(R2:X2->X2->Prop)
-                    (i0 X1 R1)==(i0 X2 R2)
-                      ->(EXT f:X1->X2 | (morphism X1 R1 X2 R2 f)).
-Intros.
-Change Cases (i0 X1 R1) (i0 X2 R2) of
-         (i0 x1 r1) (i0 x2 r2) => (EXT f | (morphism x1 r1 x2 r2 f))
-       end.
-Case H; Simpl.
-Exists [x:X1]x.
-Red; Trivial.
+  Lemma inj :
+   forall (X1 : Type) (R1 : X1 -> X1 -> Prop) (X2 : Type)
+     (R2 : X2 -> X2 -> Prop),
+   i0 X1 R1 = i0 X2 R2 -> exists f : X1 -> X2, morphism X1 R1 X2 R2 f.
+intros.
+change
+  match i0 X1 R1, i0 X2 R2 with
+  | i0 x1 r1, i0 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f
+  end in |- *.
+case H; simpl in |- *.
+exists (fun x : X1 => x).
+red in |- *; trivial.
 Defined.
 
 (* The following command raises 'Error: Universe Inconsistency'.
@@ -223,5 +234,4 @@ Defined.
    with the constraint j >= i in the paradox.
 *)
 
-  Definition Paradox: False := (Burali_Forti A0 i0 inj).
-
+  Definition Paradox : False := Burali_Forti A0 i0 inj.
diff --git a/test-suite/failure/universes-sections1.v b/test-suite/failure/universes-sections1.v
index c4eef34b..6cd04349 100644
--- a/test-suite/failure/universes-sections1.v
+++ b/test-suite/failure/universes-sections1.v
@@ -2,7 +2,7 @@
 
 Section A.
   Definition Type2 := Type.
-  Definition Type1 := Type : Type2.
+  Definition Type1 : Type2 := Type.
 End A.
 
-Definition Inconsistency := Type2 : Type1.
+Definition Inconsistency : Type1 := Type2.
diff --git a/test-suite/failure/universes-sections2.v b/test-suite/failure/universes-sections2.v
index 1872dac1..98fdbc0d 100644
--- a/test-suite/failure/universes-sections2.v
+++ b/test-suite/failure/universes-sections2.v
@@ -3,8 +3,8 @@
 Definition Type2 := Type.
 
 Section A.
-  Local Type1 := Type : Type2.
+  Let Type1 : Type2 := Type.
   Definition Type1' := Type1.
 End A.
 
-Definition Inconsistency := Type2 : Type1'.
+Definition Inconsistency : Type1' := Type2.
diff --git a/test-suite/failure/universes.v b/test-suite/failure/universes.v
index 6fada6f1..938c29b8 100644
--- a/test-suite/failure/universes.v
+++ b/test-suite/failure/universes.v
@@ -1,3 +1,3 @@
 Definition Type2 := Type.
-Definition Type1 := Type : Type2.
-Definition Inconsistency := Type2 : Type1.
+Definition Type1 : Type2 := Type.
+Definition Inconsistency : Type1 := Type2.
diff --git a/test-suite/failure/universes2.v b/test-suite/failure/universes2.v
index a6c8ba43..e74de70f 100644
--- a/test-suite/failure/universes2.v
+++ b/test-suite/failure/universes2.v
@@ -1,5 +1,4 @@
 (* Example submitted by Randy Pollack *)
 
-Parameter K: (T:Type)T->T.
-Check (K ((T:Type)T->T) K).
-(* Universe Inconsistency *)
+Parameter K : forall T : Type, T -> T.
+Check (K (forall T : Type, T -> T) K).
diff --git a/test-suite/ideal-features/Apply.v b/test-suite/ideal-features/Apply.v
index bba356f2..6fd0fe8b 100644
--- a/test-suite/ideal-features/Apply.v
+++ b/test-suite/ideal-features/Apply.v
@@ -6,21 +6,25 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* This needs unification on type *)
+(* This needs step by step unfolding *)
 
-Goal (n,m:nat)(eq nat (S m) (S n)).
-Intros.
-Apply f_equal.
+Fixpoint T (n:nat) : Prop :=
+  match n with
+  | O => True
+  | S p => n = n -> T p
+  end.
 
-(* f_equal : (A,B:Set; f:(A->B); x,y:A)x=y->(f x)=(f y) *)
-(* and A cannot be deduced from the goal but only from the type of f, x or y *)
+Require Import Arith.
 
+Goal T 3 -> T 1.
+intro H.
+apply H.
 
-(* This needs step by step unfolding *)
+(* This needs unification on type *)
 
-Fixpoint T [n:nat] : Prop := Cases n of O => True | (S p) => n=n->(T p) end.
-Require Arith.
+Goal forall n m : nat, S m = S n :>nat.
+intros.
+apply f_equal.
 
-Goal (T (3))->(T (1)).
-Intro H.
-Apply H.
+(* f_equal : forall (A B:Set) (f:A->B) (x y:A), x=y->(f x)=(f y) *)
+(* and A cannot be deduced from the goal but only from the type of f, x or y *)
diff --git a/test-suite/ideal-features/Case3.v b/test-suite/ideal-features/Case3.v
index e9dba1e3..de7784ae 100644
--- a/test-suite/ideal-features/Case3.v
+++ b/test-suite/ideal-features/Case3.v
@@ -1,28 +1,29 @@
-Inductive Le : nat->nat->Set :=
-  LeO: (n:nat)(Le O n) 
-| LeS: (n,m:nat)(Le n m) -> (Le (S n) (S m)).
+Inductive Le : nat -> nat -> Set :=
+  | LeO : forall n : nat, Le 0 n
+  | LeS : forall n m : nat, Le n m -> Le (S n) (S m).
 
-Parameter iguales : (n,m:nat)(h:(Le n m))Prop .
+Parameter discr_l : forall n : nat, S n <> 0.
 
-Type <[n,m:nat][h:(Le n m)]Prop>Cases (LeO O) of 
-                         (LeO O) => True
-                       | (LeS (S x) (S y) H) => (iguales (S x) (S y) H)
-                       | _ => False end.
+Type
+  (fun n : nat =>
+   match n return (n = 0 \/ n <> 0) with
+   | O => or_introl (0 <> 0) (refl_equal 0)
+   | S O => or_intror (1 = 0) (discr_l 0)
+   | S (S x) => or_intror (S (S x) = 0) (discr_l (S x))
+   end).
 
+Parameter iguales : forall (n m : nat) (h : Le n m), Prop.
 
-Type <[n,m:nat][h:(Le n m)]Prop>Cases (LeO O) of 
-                         (LeO O) => True
-                       | (LeS (S x) O H) => (iguales (S x) O H)
-                       | _ => False end.
-
-Parameter discr_l : (n:nat) ~((S n)=O).
-
-Type 
-[n:nat] 
-  <[n:nat]n=O\/~n=O>Cases n of 
-      O     => (or_introl ? ~O=O (refl_equal ? O))      
-   |  (S O) => (or_intror (S O)=O ? (discr_l O))
-   |  (S (S x)) => (or_intror (S (S x))=O ? (discr_l (S x)))
- 
+Type
+  match LeO 0 as h in (Le n m) return Prop with
+  | LeO O => True
+  | LeS (S x) (S y) H => iguales (S x) (S y) H
+  | _ => False
   end.
 
+Type
+  match LeO 0 as h in (Le n m) return Prop with
+  | LeO O => True
+  | LeS (S x) O H => iguales (S x) 0 H
+  | _ => False
+  end.
diff --git a/test-suite/ideal-features/Case4.v b/test-suite/ideal-features/Case4.v
index d8f14a4e..cb076a71 100644
--- a/test-suite/ideal-features/Case4.v
+++ b/test-suite/ideal-features/Case4.v
@@ -1,39 +1,34 @@
-Inductive listn : nat-> Set := 
-  niln : (listn O) 
-| consn : (n:nat)nat->(listn n) -> (listn (S n)).
-
-Inductive empty : (n:nat)(listn n)-> Prop := 
-  intro_empty: (empty O niln).
-
-Parameter inv_empty : (n,a:nat)(l:(listn n)) ~(empty (S n) (consn n a l)).
-
-Type 
-[n:nat] [l:(listn n)]
-  <[n:nat] [l:(listn n)](empty n l) \/ ~(empty n l)>Cases l of 
-        niln               =>  (or_introl ? ~(empty O niln) intro_empty)
-   |  ((consn n O y) as b) =>  (or_intror (empty (S n) b) ? (inv_empty n O y))
-   |  ((consn n a y) as b) =>  (or_intror (empty (S n) b) ? (inv_empty n a y))
-
-  end.
-
-
-Type 
-[n:nat] [l:(listn n)]
-  <[n:nat] [l:(listn n)](empty n l) \/ ~(empty n l)>Cases l of 
-        niln               =>  (or_introl ? ~(empty O niln) intro_empty)
-   |  (consn n O y)  =>  (or_intror (empty (S n) (consn n O y)) ? 
-                                              (inv_empty n O y))
-   |  (consn n a y) =>  (or_intror (empty (S n) (consn n a y)) ? 
-                                          (inv_empty n a y))
-
-  end.
-
-Type 
-[n:nat] [l:(listn n)]
-  <[n:nat] [l:(listn n)](empty n l) \/ ~(empty n l)>Cases l of 
-        niln               =>  (or_introl ? ~(empty O niln) intro_empty)
-   |  ((consn O a y) as b) =>  (or_intror (empty (S O) b) ? (inv_empty O a y))
-   |  ((consn n a y) as b) =>  (or_intror (empty (S n) b) ? (inv_empty n a y))
-
-  end.
-
+Inductive listn : nat -> Set :=
+  | niln : listn 0
+  | consn : forall n : nat, nat -> listn n -> listn (S n).
+
+Inductive empty : forall n : nat, listn n -> Prop :=
+    intro_empty : empty 0 niln.
+
+Parameter
+  inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l).
+
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l in (listn n) return (empty n l \/ ~ empty n l) with
+   | niln => or_introl (~ empty 0 niln) intro_empty
+   | consn n O y as b => or_intror (empty (S n) b) (inv_empty n 0 y)
+   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
+   end).
+
+
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l in (listn n) return (empty n l \/ ~ empty n l) with
+   | niln => or_introl (~ empty 0 niln) intro_empty
+   | consn n O y => or_intror (empty (S n) (consn n 0 y)) (inv_empty n 0 y)
+   | consn n a y => or_intror (empty (S n) (consn n a y)) (inv_empty n a y)
+   end).
+
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l in (listn n) return (empty n l \/ ~ empty n l) with
+   | niln => or_introl (~ empty 0 niln) intro_empty
+   | consn O a y as b => or_intror (empty 1 b) (inv_empty 0 a y)
+   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
+   end).
diff --git a/test-suite/ideal-features/Case8.v b/test-suite/ideal-features/Case8.v
index 73b55028..2ac5bd8c 100644
--- a/test-suite/ideal-features/Case8.v
+++ b/test-suite/ideal-features/Case8.v
@@ -1,40 +1,36 @@
-Inductive listn : nat-> Set := 
-  niln : (listn O) 
-| consn : (n:nat)nat->(listn n) -> (listn (S n)).
-
-Inductive empty : (n:nat)(listn n)-> Prop := 
-  intro_empty: (empty O niln).
-
-Parameter inv_empty : (n,a:nat)(l:(listn n)) ~(empty (S n) (consn n a l)).
-
-Type 
-[n:nat] [l:(listn n)]
-  <[n:nat] [l:(listn n)](empty n l) \/ ~(empty n l)>Cases l of 
-        niln               =>  (or_introl ? ~(empty O niln) intro_empty)
-   |  ((consn n O y) as b) =>  (or_intror (empty (S n) b) ? (inv_empty n O y))
-   |  ((consn n a y) as b) =>  (or_intror (empty (S n) b) ? (inv_empty n a y))
-
-  end.
-
-
-Type 
-[n:nat] [l:(listn n)]
-  <[n:nat] [l:(listn n)](empty n l) \/ ~(empty n l)>Cases l of 
-        niln               =>  (or_introl ? ~(empty O niln) intro_empty)
-   |  (consn n O y)  =>  (or_intror (empty (S n) (consn n O y)) ? 
-                                              (inv_empty n O y))
-   |  (consn n a y) =>  (or_intror (empty (S n) (consn n a y)) ? 
-                                          (inv_empty n a y))
-
-  end.
-
-
-
-Type 
-[n:nat] [l:(listn n)]
-  <[n:nat] [l:(listn n)](empty n l) \/ ~(empty n l)>Cases l of 
-        niln               =>  (or_introl ? ~(empty O niln) intro_empty)
-   |  ((consn O a y) as b) =>  (or_intror (empty (S O) b) ? (inv_empty O a y))
-   |  ((consn n a y) as b) =>  (or_intror (empty (S n) b) ? (inv_empty n a y))
-
-  end.
+Inductive listn : nat -> Set :=
+  | niln : listn 0
+  | consn : forall n : nat, nat -> listn n -> listn (S n).
+
+Inductive empty : forall n : nat, listn n -> Prop :=
+    intro_empty : empty 0 niln.
+
+Parameter
+  inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l).
+
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l in (listn n) return (empty n l \/ ~ empty n l) with
+   | niln => or_introl (~ empty 0 niln) intro_empty
+   | consn n O y as b => or_intror (empty (S n) b) (inv_empty n 0 y)
+   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
+   end).
+
+
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l in (listn n) return (empty n l \/ ~ empty n l) with
+   | niln => or_introl (~ empty 0 niln) intro_empty
+   | consn n O y => or_intror (empty (S n) (consn n 0 y)) (inv_empty n 0 y)
+   | consn n a y => or_intror (empty (S n) (consn n a y)) (inv_empty n a y)
+   end).
+
+
+
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l in (listn n) return (empty n l \/ ~ empty n l) with
+   | niln => or_introl (~ empty 0 niln) intro_empty
+   | consn O a y as b => or_intror (empty 1 b) (inv_empty 0 a y)
+   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
+   end).
diff --git a/test-suite/interactive/Back.v b/test-suite/interactive/Back.v
new file mode 100644
index 00000000..b813a79a
--- /dev/null
+++ b/test-suite/interactive/Back.v
@@ -0,0 +1,8 @@
+(* Check that reset remains synchronised with the compilation unit cache *)
+(* See bug #1030 *)
+
+Section multiset_defs.
+  Require Import Plus.
+End multiset_defs.
+Unset Implicit Arguments.
+Back 1.
diff --git a/test-suite/interactive/Evar.v b/test-suite/interactive/Evar.v
new file mode 100644
index 00000000..1bc1f71d
--- /dev/null
+++ b/test-suite/interactive/Evar.v
@@ -0,0 +1,6 @@
+(* Check that no toplevel "unresolved evar" flees through Declare
+   Implicit Tactic support (bug #1229) *)
+
+Goal True. 
+(* should raise an error, not an anomaly *)
+set (x := _).
diff --git a/test-suite/modules/Demo.v b/test-suite/modules/Demo.v
index 1e9273f0..1f27fe1b 100644
--- a/test-suite/modules/Demo.v
+++ b/test-suite/modules/Demo.v
@@ -1,51 +1,51 @@
 Module M.
-  Definition t:=nat.
-  Definition x:=O.
+  Definition t := nat.
+  Definition x := 0.
 End M.
 
 Print M.t.
 
 
 Module Type SIG.
-  Parameter t:Set.
-  Parameter x:t.
+  Parameter t : Set.
+  Parameter x : t.
 End SIG.
 
 
-Module F[X:SIG].
-  Definition t:=X.t->X.t.
-  Definition x:t.
-    Intro.
-    Exact X.x.
+Module F (X: SIG).
+  Definition t := X.t -> X.t.
+  Definition x : t.
+    intro.
+    exact X.x.
   Defined.
-  Definition y:=X.x.
+  Definition y := X.x.
 End F.
 
 
 Module N := F M.
 
 Print N.t.
-Eval Compute in N.t.
+Eval compute in N.t.
 
 
 Module N' : SIG := N.
 
 Print N'.t.
-Eval Compute in N'.t.
+Eval compute in N'.t.
 
 
 Module N'' <: SIG := F N.
 
 Print N''.t.
-Eval Compute in N''.t.
+Eval compute in N''.t.
 
-Eval Compute in N''.x.
+Eval compute in N''.x.
 
 
-Module N''' : SIG with Definition t:=nat->nat  :=  N.
+Module N''' : SIG with Definition t := nat -> nat := N.
 
 Print N'''.t.
-Eval Compute in N'''.t.
+Eval compute in N'''.t.
 
 Print N'''.x.
 
diff --git a/test-suite/modules/Nametab.v b/test-suite/modules/Nametab.v
deleted file mode 100644
index 61966c7c..00000000
--- a/test-suite/modules/Nametab.v
+++ /dev/null
@@ -1,48 +0,0 @@
-Module Q.
-  Module N.
-    Module K.
-      Definition id:=Set.
-    End K.
-  End N.
-End Q.
-
-(* Bad *) Locate id.
-(* Bad *) Locate K.id.
-(* Bad *) Locate N.K.id.
-(* OK  *) Locate Q.N.K.id.
-(* OK  *) Locate Top.Q.N.K.id.
-
-(* Bad *) Locate K.
-(* Bad *) Locate N.K.
-(* OK  *) Locate Q.N.K.
-(* OK  *) Locate Top.Q.N.K.
-
-(* Bad *) Locate N.
-(* OK  *) Locate Q.N.
-(* OK  *) Locate Top.Q.N.
-
-(* OK  *) Locate Q.
-(* OK  *) Locate Top.Q.
-
-
-
-Import Q.N.
-
-
-(* Bad *) Locate id.
-(* OK  *) Locate K.id.
-(* Bad *) Locate N.K.id.
-(* OK  *) Locate Q.N.K.id.
-(* OK  *) Locate Top.Q.N.K.id.
-
-(* OK  *) Locate K.
-(* Bad *) Locate N.K.
-(* OK  *) Locate Q.N.K.
-(* OK  *) Locate Top.Q.N.K.
-
-(* Bad *) Locate N.
-(* OK  *) Locate Q.N.
-(* OK  *) Locate Top.Q.N.
-
-(* OK  *) Locate Q.
-(* OK  *) Locate Top.Q.
diff --git a/test-suite/modules/Nat.v b/test-suite/modules/Nat.v
index d3e98ae4..57878a5f 100644
--- a/test-suite/modules/Nat.v
+++ b/test-suite/modules/Nat.v
@@ -1,19 +1,19 @@
-Definition T:=nat.
+Definition T := nat.
 
-Definition le:=Peano.le.
+Definition le := le.
 
-Hints Unfold le.
+Hint Unfold le.
 
-Lemma le_refl:(n:nat)(le n n).
-  Auto.
+Lemma le_refl : forall n : nat, le n n.
+  auto.
 Qed.
 
-Require Le.
+Require Import Le.
 
-Lemma le_trans:(n,m,k:nat)(le n m) -> (le m k) -> (le n k).
-  EAuto with arith.
+Lemma le_trans : forall n m k : nat, le n m -> le m k -> le n k.
+   eauto with arith.
 Qed.
 
-Lemma le_antis:(n,m:nat)(le n m) -> (le m n) -> n=m.
-  EAuto with arith.
-Qed.
+Lemma le_antis : forall n m : nat, le n m -> le m n -> n = m.
+   eauto with arith.
+Qed.
\ No newline at end of file
diff --git a/test-suite/modules/PO.v b/test-suite/modules/PO.v
index 9ba3fb2e..354c3957 100644
--- a/test-suite/modules/PO.v
+++ b/test-suite/modules/PO.v
@@ -1,57 +1,57 @@
-Implicit Arguments On.
+Set Implicit Arguments.
+Unset Strict Implicit.
 
-Implicits fst.
-Implicits snd.
+Implicit Arguments fst.
+Implicit Arguments snd.
 
 Module Type PO.
-  Parameter T:Set.
-  Parameter le:T->T->Prop.
+  Parameter T : Set.
+  Parameter le : T -> T -> Prop.
   
-  Axiom le_refl : (x:T)(le x x).
-  Axiom le_trans : (x,y,z:T)(le x y) -> (le y z) -> (le x z).
-  Axiom le_antis : (x,y:T)(le x y) -> (le y x) -> (x=y).
+  Axiom le_refl : forall x : T, le x x.
+  Axiom le_trans : forall x y z : T, le x y -> le y z -> le x z.
+  Axiom le_antis : forall x y : T, le x y -> le y x -> x = y.
   
-  Hints Resolve le_refl le_trans le_antis.
+  Hint Resolve le_refl le_trans le_antis.
 End PO.
 
 
-Module Pair[X:PO][Y:PO] <: PO.
-  Definition T:=X.T*Y.T.
-  Definition le:=[p1,p2]
-    (X.le (fst p1) (fst p2)) /\ (Y.le (snd p1) (snd p2)).
+Module Pair (X: PO) (Y: PO) <: PO.
+  Definition T := (X.T * Y.T)%type.
+  Definition le p1 p2 := X.le (fst p1) (fst p2) /\ Y.le (snd p1) (snd p2).
 
-  Hints Unfold le.
+  Hint Unfold le.
 
-  Lemma le_refl : (p:T)(le p p).
-    Info Auto.
+  Lemma le_refl : forall p : T, le p p.
+    info auto.
   Qed.
 
-  Lemma le_trans : (p1,p2,p3:T)(le p1 p2) -> (le p2 p3) -> (le p1 p3).
-    Unfold le; Intuition; Info EAuto.
+  Lemma le_trans : forall p1 p2 p3 : T, le p1 p2 -> le p2 p3 -> le p1 p3.
+    unfold le in |- *;  intuition; info  eauto.
   Qed.    
 
-  Lemma le_antis : (p1,p2:T)(le p1 p2) -> (le p2 p1) -> (p1=p2).
-    NewDestruct p1.  
-    NewDestruct p2.
-    Unfold le.
-    Intuition.
-    CutRewrite t=t1.
-    CutRewrite t0=t2.
-    Reflexivity.
+  Lemma le_antis : forall p1 p2 : T, le p1 p2 -> le p2 p1 -> p1 = p2.
+    destruct p1.  
+    destruct p2.
+    unfold le in |- *.
+     intuition.
+     cutrewrite (t = t1).
+     cutrewrite (t0 = t2).
+    reflexivity.
 
-    Info Auto.
+    info auto.
 
-    Info Auto.
+    info auto.
   Qed.
 
 End Pair.
 
 
 
-Read Module Nat.
+Require Nat.
 
 Module NN := Pair Nat Nat.
 
-Lemma zz_min : (p:NN.T)(NN.le (O,O) p).
-  Info Auto with arith.
-Qed.
+Lemma zz_min : forall p : NN.T, NN.le (0, 0) p.
+  info auto with arith.
+Qed.
\ No newline at end of file
diff --git a/test-suite/modules/Przyklad.v b/test-suite/modules/Przyklad.v
index 4f4c2066..014f6c60 100644
--- a/test-suite/modules/Przyklad.v
+++ b/test-suite/modules/Przyklad.v
@@ -1,38 +1,40 @@
-Definition ifte := [T:Set][A:Prop][B:Prop][s:(sumbool A B)][th:T][el:T] 
-	   	   if s then [_]th else [_]el.
+Definition ifte (T : Set) (A B : Prop) (s : {A} + {B}) 
+  (th el : T) := if s then th else el.
 
-Implicits ifte.
+Implicit Arguments ifte.
 
-Lemma Reflexivity_provable : 
-  (A:Set)(a:A)(s:{a=a}+{~a=a})(EXT x| s==(left ? ? x)).
-Intros.
-Elim s.
-Intro x.
-Split with x; Reflexivity.
+Lemma Reflexivity_provable :
+ forall (A : Set) (a : A) (s : {a = a} + {a <> a}),
+ exists x : _, s = left _ x.
+intros.
+elim s.
+intro x.
+split with x; reflexivity.
 
-Intro.
-Absurd a=a; Auto.
+intro.
+ absurd (a = a); auto.
 
-Save.
+Qed.
 
-Lemma Disequality_provable : 
-  (A:Set)(a,b:A)(~a=b)->(s:{a=b}+{~a=b})(EXT x| s==(right ? ? x)).
-Intros.
-Elim s.
-Intro.
-Absurd a=a; Auto.
+Lemma Disequality_provable :
+ forall (A : Set) (a b : A),
+ a <> b -> forall s : {a = b} + {a <> b}, exists x : _, s = right _ x.
+intros.
+elim s.
+intro.
+ absurd (a = a); auto.
 
-Intro.
-Split with b0; Reflexivity.
+intro.
+split with b0; reflexivity.
 
-Save.
+Qed.
 
 Module Type ELEM.
   Parameter T : Set.
-  Parameter eq_dec : (a,a':T){a=a'}+{~ a=a'}.
+  Parameter eq_dec : forall a a' : T, {a = a'} + {a <> a'}.
 End ELEM.
                                         
-Module Type SET[Elt : ELEM].
+Module Type SET (Elt: ELEM).
   Parameter T : Set.
   Parameter empty : T.
   Parameter add : Elt.T -> T -> T.
@@ -40,56 +42,52 @@ Module Type SET[Elt : ELEM].
 
   (* Axioms *)
 
-  Axiom find_empty_false : 
-      (e:Elt.T) (find e empty) = false.
+  Axiom find_empty_false : forall e : Elt.T, find e empty = false.
 
-  Axiom find_add_true : 
-        (s:T) (e:Elt.T) (find e (add e s)) = true.
+  Axiom find_add_true : forall (s : T) (e : Elt.T), find e (add e s) = true.
 
-  Axiom find_add_false :
-        (s:T) (e:Elt.T) (e':Elt.T) ~(e=e') -> 
-	(find e (add e' s))=(find e s).
+  Axiom
+    find_add_false :
+      forall (s : T) (e e' : Elt.T), e <> e' -> find e (add e' s) = find e s.
 
 End SET.
 
-Module FuncDict[E : ELEM].
+Module FuncDict (E: ELEM).
   Definition T := E.T -> bool.
-  Definition empty := [e':E.T] false.
-  Definition find := [e':E.T] [s:T] (s e').
-  Definition add := [e:E.T][s:T][e':E.T]
-        (ifte (E.eq_dec e e') true (find e' s)).
+  Definition empty (e' : E.T) := false.
+  Definition find (e' : E.T) (s : T) := s e'.
+  Definition add (e : E.T) (s : T) (e' : E.T) :=
+    ifte (E.eq_dec e e') true (find e' s).
 
-  Lemma find_empty_false : (e:E.T) (find e empty) = false.
-    Auto.
+  Lemma find_empty_false : forall e : E.T, find e empty = false.
+    auto.
   Qed.
 
-  Lemma find_add_true : 
-        (s:T) (e:E.T) (find e (add e s)) = true.
+  Lemma find_add_true : forall (s : T) (e : E.T), find e (add e s) = true.
 
-    Intros.
-    Unfold find add.
-    Elim (Reflexivity_provable ? ? (E.eq_dec e e)).
-    Intros.
-    Rewrite H.
-    Auto.
+    intros.
+    unfold find, add in |- *.
+    elim (Reflexivity_provable _ _ (E.eq_dec e e)).
+    intros.
+     rewrite H.
+    auto.
 
   Qed.
 
   Lemma find_add_false :
-        (s:T) (e:E.T) (e':E.T) ~(e=e') -> 
-	(find e (add e' s))=(find e s).
-    Intros.
-    Unfold add find.
-    Cut (EXT x:? | (E.eq_dec e' e)==(right ? ? x)).
-    Intros.
-    Elim H0.
-    Intros.
-    Rewrite H1.
-    Unfold ifte.
-    Reflexivity.
-
-    Apply Disequality_provable.
-    Auto.
+   forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s.
+    intros.
+    unfold add, find in |- *.
+    cut (exists x : _, E.eq_dec e' e = right _ x).
+    intros.
+    elim H0.
+    intros.
+     rewrite H1.
+    unfold ifte in |- *.
+    reflexivity.
+
+    apply Disequality_provable.
+    auto.
 
   Qed.
 
@@ -99,84 +97,81 @@ Module F : SET := FuncDict.
 
 
 Module Nat.
-  Definition T:=nat.
-  Lemma eq_dec :  (a,a':T){a=a'}+{~ a=a'}.
-    Decide Equality.
+  Definition T := nat.
+  Lemma eq_dec : forall a a' : T, {a = a'} + {a <> a'}.
+     decide equality.
   Qed.
 End Nat.
 
 
-Module SetNat:=F Nat. 
+Module SetNat := F Nat. 
 
 
-Lemma no_zero_in_empty:(SetNat.find O SetNat.empty)=false. 
-Apply SetNat.find_empty_false. 
-Save.
+Lemma no_zero_in_empty : SetNat.find 0 SetNat.empty = false. 
+apply SetNat.find_empty_false. 
+Qed.
 
 (***************************************************************************)
-Module Lemmas[G:SET][E:ELEM].
+Module Lemmas (G: SET) (E: ELEM).
 
-  Module ESet:=G E.
+  Module ESet := G E.
 
-  Lemma commute : (S:ESet.T)(a1,a2:E.T) 
-    let S1 = (ESet.add a1 (ESet.add a2 S)) in 
-    let S2 = (ESet.add a2 (ESet.add a1 S)) in
-      (a:E.T)(ESet.find a S1)=(ESet.find a S2). 
+  Lemma commute :
+   forall (S : ESet.T) (a1 a2 : E.T),
+   let S1 := ESet.add a1 (ESet.add a2 S) in
+   let S2 := ESet.add a2 (ESet.add a1 S) in
+   forall a : E.T, ESet.find a S1 = ESet.find a S2. 
   
-    Intros.
-    Unfold S1 S2.
-    Elim (E.eq_dec a a1); Elim (E.eq_dec a a2); Intros H1 H2;
-    Try Rewrite <- H1; Try Rewrite <- H2;
-    Repeat 
-      (Try (Rewrite ESet.find_add_true; Auto);
-       Try (Rewrite ESet.find_add_false; Auto); 
-       Auto).
-  Save.
+    intros.
+    unfold S1, S2 in |- *.
+    elim (E.eq_dec a a1); elim (E.eq_dec a a2); intros H1 H2;
+     try  rewrite <- H1; try  rewrite <- H2;
+     repeat
+      (try ( rewrite ESet.find_add_true; auto);
+        try ( rewrite ESet.find_add_false; auto); auto).
+  Qed.
 End Lemmas.
 
 
-Inductive list [A:Set] : Set := nil : (list A) 
-                             | cons : A -> (list A) -> (list A).
+Inductive list (A : Set) : Set :=
+  | nil : list A
+  | cons : A -> list A -> list A.
 
-Module ListDict[E : ELEM]. 
-  Definition T := (list E.T).
+Module ListDict (E: ELEM). 
+  Definition T := list E.T.
   Definition elt := E.T.
    
-  Definition empty := (nil elt).
-  Definition add := [e:elt][s:T] (cons elt e s).
-  Fixpoint find [e:elt; s:T] : bool :=
-        Cases s of 
-          nil => false
-        | (cons e' s') => (ifte (E.eq_dec e e') 
-                                true
-                                (find e s'))
-        end.
-
-  Definition find_empty_false := [e:elt] (refl_equal bool false).
-
-  Lemma find_add_true : 
-        (s:T) (e:E.T) (find e (add e s)) = true.
-    Intros.
-    Simpl.
-    Elim (Reflexivity_provable ? ? (E.eq_dec e e)).
-    Intros.
-    Rewrite H.
-    Auto.
+  Definition empty := nil elt.
+  Definition add (e : elt) (s : T) := cons elt e s.
+  Fixpoint find (e : elt) (s : T) {struct s} : bool :=
+    match s with
+    | nil => false
+    | cons e' s' => ifte (E.eq_dec e e') true (find e s')
+    end.
+
+  Definition find_empty_false (e : elt) := refl_equal false.
+
+  Lemma find_add_true : forall (s : T) (e : E.T), find e (add e s) = true.
+    intros.
+    simpl in |- *.
+    elim (Reflexivity_provable _ _ (E.eq_dec e e)).
+    intros.
+     rewrite H.
+    auto.
 
   Qed.
   
 
   Lemma find_add_false :
-        (s:T) (e:E.T) (e':E.T) ~(e=e') -> 
-	(find e (add e' s))=(find e s).
-    Intros.
-    Simpl.
-    Elim (Disequality_provable ? ? ? H (E.eq_dec e e')).
-    Intros.
-    Rewrite H0.
-    Simpl.
-    Reflexivity.
-  Save.    
+   forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s.
+    intros.
+    simpl in |- *.
+    elim (Disequality_provable _ _ _ H (E.eq_dec e e')).
+    intros.
+     rewrite H0.
+    simpl in |- *.
+    reflexivity.
+  Qed.    
   
 
 End ListDict.
@@ -190,4 +185,3 @@ Module L : SET := ListDict.
 
 
 
-
diff --git a/test-suite/modules/Tescik.v b/test-suite/modules/Tescik.v
index 13c28418..8dadace7 100644
--- a/test-suite/modules/Tescik.v
+++ b/test-suite/modules/Tescik.v
@@ -1,30 +1,30 @@
 
 Module Type ELEM.
-  Parameter A:Set.
-  Parameter x:A.
+  Parameter A : Set.
+  Parameter x : A.
 End ELEM.
 
 Module Nat.
-    Definition A:=nat.
-    Definition x:=O.
+    Definition A := nat.
+    Definition x := 0.
 End Nat. 
 
-Module List[X:ELEM].
-  Inductive list : Set := nil : list 
-		       | cons : X.A -> list -> list.
+Module List (X: ELEM).
+  Inductive list : Set :=
+    | nil : list
+    | cons : X.A -> list -> list.
  
-  Definition head := 
-     [l:list]Cases l of 
-	  nil => X.x 
-	| (cons x _) => x
-     end.
+  Definition head (l : list) := match l with
+                                | nil => X.x
+                                | cons x _ => x
+                                end.
 
-  Definition singl := [x:X.A] (cons x nil).
+  Definition singl (x : X.A) := cons x nil.
   
-  Lemma head_singl : (x:X.A)(head (singl x))=x.
-  Auto.
+  Lemma head_singl : forall x : X.A, head (singl x) = x.
+  auto.
   Qed.
 
 End List.
 
-Module N:=(List Nat).
+Module N := List Nat.
\ No newline at end of file
diff --git a/test-suite/modules/fun_objects.v b/test-suite/modules/fun_objects.v
index 0f8eef84..f4dc19b3 100644
--- a/test-suite/modules/fun_objects.v
+++ b/test-suite/modules/fun_objects.v
@@ -1,32 +1,32 @@
-Implicit Arguments On.
+Set Implicit Arguments.
+Unset Strict Implicit.
 
 Module Type SIG.
-  Parameter id:(A:Set)A->A.
+  Parameter id : forall A : Set, A -> A.
 End SIG.
  
-Module M[X:SIG].
-  Definition idid := (X.id X.id).
-  Definition id := (idid X.id).
+Module M (X: SIG).
+  Definition idid := X.id X.id.
+  Definition id := idid X.id.
 End M.
 
-Module N:=M.
+Module N := M.
 
 Module Nat.
   Definition T := nat.
-  Definition x := O.
-  Definition id := [A:Set][x:A]x.
+  Definition x := 0.
+  Definition id (A : Set) (x : A) := x.
 End Nat.
 
-Module Z:=(N Nat).
+Module Z := N Nat.
 
-Check (Z.idid O).
+Check (Z.idid 0).
 
-Module P[Y:SIG] := N.
+Module P (Y: SIG) := N.
 
-Module Y:=P Nat Z.
-
-Check (Y.id O).
+Module Y := P Nat Z.
 
+Check (Y.id 0).
 
 
 
diff --git a/test-suite/modules/grammar.v b/test-suite/modules/grammar.v
index fb734b5d..9657c685 100644
--- a/test-suite/modules/grammar.v
+++ b/test-suite/modules/grammar.v
@@ -1,15 +1,15 @@
 Module N.
-Definition f:=plus.
-Syntax constr level 7: plus [ (f $n $m)] -> [ $n:L "+" $m:E].
-Check (f O O).
+Definition f := plus.
+(* <Warning> : Syntax is discontinued *)
+Check (f 0 0).
 End N.
-Check (N.f O O).
+Check (N.f 0 0).
 Import N.
-Check (N.f O O).
-Check (f O O).
-Module M:=N.
-Check (f O O).
-Check (N.f O O).
+Check (f 0 0).
+Check (f 0 0).
+Module M := N.
+Check (f 0 0).
+Check (f 0 0).
 Import M.
-Check (f O O).
-Check (N.f O O).
+Check (f 0 0).
+Check (N.f 0 0).
\ No newline at end of file
diff --git a/test-suite/modules/ind.v b/test-suite/modules/ind.v
index 94c344bb..3af94c3b 100644
--- a/test-suite/modules/ind.v
+++ b/test-suite/modules/ind.v
@@ -1,13 +1,49 @@
 Module Type SIG.
-  Inductive w:Set:=A:w.
-  Parameter f : w->w.
+  Inductive w : Set :=
+      A : w.
+  Parameter f : w -> w.
 End SIG.
 
-Module M:SIG.
-  Inductive w:Set:=A:w.
-  Definition f:=[x]Cases x of A => A end.
+Module M : SIG.
+  Inductive w : Set :=
+      A : w.
+  Definition f x := match x with
+                    | A => A
+                    end.
 End M.
 
-Module N:=M.
+Module N := M.
 
 Check (N.f M.A).
+
+(* Check use of equivalence on inductive types (bug #1242) *)
+
+  Module Type ASIG.
+  Inductive t : Set := a | b : t.
+  Definition f := fun x => match x with a => true | b => false end.
+  End ASIG.
+
+  Module Type BSIG.
+  Declare Module A : ASIG.
+  Definition f := fun x => match x with A.a => true | A.b => false end.
+  End BSIG.
+
+  Module C (A : ASIG) (B : BSIG with Module A:=A).
+
+  (* Check equivalence is considered in "case_info" *)
+  Lemma test : forall x, A.f x = B.f x.
+  intro x. unfold B.f, A.f.
+  destruct x; reflexivity.
+  Qed.
+
+  (* Check equivalence is considered in pattern-matching *)
+  Definition f (x : A.t) := match x with B.A.a => true | B.A.b => false end.
+
+  End C.
+
+(* Check subtyping of the context of parameters of the inductive types *)
+(* Only the number of expected uniform parameters and the convertibility *)
+(* of the inductive arities and constructors types are checked *)
+
+Module Type S. Inductive I (x:=0) (y:nat): Set := c: x=y -> I y. End S.
+Module P : S.  Inductive I (y':nat) (z:=y'): Set := c : 0=y' -> I y'. End P.
diff --git a/test-suite/modules/injection_discriminate_inversion.v b/test-suite/modules/injection_discriminate_inversion.v
new file mode 100644
index 00000000..88c19cb1
--- /dev/null
+++ b/test-suite/modules/injection_discriminate_inversion.v
@@ -0,0 +1,34 @@
+Module M.
+  Inductive I : Set := C : nat -> I.
+End M.
+
+Module M1 := M.
+
+
+Goal forall x, M.C x = M1.C 0 -> x = 0 .
+  intros x H.
+  (* 
+     injection sur deux constructeurs egaux mais appeles 
+     par des modules differents 
+     *)
+  injection H. 
+  tauto.
+Qed.
+
+Goal  M.C 0 <> M1.C 1.
+  (* 
+     Discriminate sur deux constructeurs egaux mais appeles 
+     par des modules differents 
+     *)
+  intro H;discriminate H.
+Qed.
+
+
+Goal forall x,  M.C x = M1.C 0 -> x = 0.
+  intros x H.
+  (* 
+     inversion sur deux constructeurs egaux mais appeles 
+     par des modules differents 
+     *)
+  inversion H. reflexivity.
+Qed.
\ No newline at end of file
diff --git a/test-suite/modules/mod_decl.v b/test-suite/modules/mod_decl.v
index 867b8a11..b886eb59 100644
--- a/test-suite/modules/mod_decl.v
+++ b/test-suite/modules/mod_decl.v
@@ -1,55 +1,49 @@
 Module Type SIG.
-  Definition A:Set. (*error*)
-  Axiom A:Set.
+  Axiom A : Set.
 End SIG.
 
 Module M0.
-  Definition A:Set.
-  Exact nat.
-  Save.
+  Definition A : Set.
+  exact nat.
+  Qed.
 End M0.
 
-Module M1:SIG.
-  Definition A:=nat.
+Module M1 : SIG.
+  Definition A := nat.
 End M1.
 
-Module M2<:SIG.
-  Definition A:=nat.
+Module M2 <: SIG.
+  Definition A := nat.
 End M2.
 
-Module M3:=M0.
+Module M3 := M0.
 
-Module M4:SIG:=M0.
+Module M4 : SIG := M0.
 
-Module M5<:SIG:=M0.
+Module M5 <: SIG := M0.
 
 
-Module F[X:SIG]:=X.
-
-
-Declare Module M6.
+Module F (X: SIG) := X.
 
 
 Module Type T.
 
-  Declare Module M0.
-    Lemma A:Set (*error*).
-    Axiom A:Set.
+  Module M0.
+    Axiom A : Set.
   End M0.
   
-  Declare Module M1:SIG.
+  Declare Module M1: SIG.
   
-  Declare Module M2<:SIG.
-    Definition A:=nat.
+  Module M2 <: SIG.
+    Definition A := nat.
   End M2.
   
-  Declare Module M3:=M0.
+  Module M3 := M0.
   
-  Declare Module M4:SIG:=M0.  (* error *)
+  Module M4 : SIG := M0.
   
-  Declare Module M5<:SIG:=M0.
+  Module M5 <: SIG := M0.
 
-  Declare Module M6:=F M0. (* error *)
+  Module M6 := F M0.
 
-  Module M7.
-End T.
\ No newline at end of file
+End T.
diff --git a/test-suite/modules/modeq.v b/test-suite/modules/modeq.v
index 73448dc7..45cf9f12 100644
--- a/test-suite/modules/modeq.v
+++ b/test-suite/modules/modeq.v
@@ -1,22 +1,22 @@
 Module M.
-  Definition T:=nat.
-  Definition x:T:=O.
+  Definition T := nat.
+  Definition x : T := 0.
 End M.
 
 Module Type SIG.
-  Declare Module M:=Top.M.
+  Module M := Top.M.
   Module Type SIG.
-    Parameter T:Set.
+    Parameter T : Set.
   End SIG.
-  Declare Module N:SIG.
+  Declare Module N: SIG.
 End SIG.
 
 Module Z.
-  Module M:=Top.M.
+  Module M := Top.M.
   Module Type SIG.
-    Parameter T:Set.
+    Parameter T : Set.
   End SIG.
-  Module N:=M.
+  Module N := M.
 End Z.
 
-Module A:SIG:=Z.  
+Module A : SIG := Z.  
\ No newline at end of file
diff --git a/test-suite/modules/modul.v b/test-suite/modules/modul.v
index 84942da1..9d24d6ce 100644
--- a/test-suite/modules/modul.v
+++ b/test-suite/modules/modul.v
@@ -1,39 +1,35 @@
 Module M.
-  Parameter rel:nat -> nat -> Prop.
+  Parameter rel : nat -> nat -> Prop.
 
-  Axiom w : (n:nat)(rel O (S n)).
+  Axiom w : forall n : nat, rel 0 (S n).
 
-  Hints Resolve w.
+  Hint Resolve w.
 
-  Grammar constr constr8 := 
-     not_eq [ constr7($a) "#" constr7($b) ] -> [ (rel $a $b) ].
+  (* <Warning> : Grammar is replaced by Notation *)
   
   Print Hint *.
 
-  Lemma w1 : (O#(S O)).
-  Auto.
-  Save.
+  Lemma w1 : rel 0 1.
+  auto.
+  Qed.
 
 End M.
 
+Locate Module M.
+
 (*Lemma w1 : (M.rel O (S O)).
 Auto.
 *)
 
 Import M.
 
-Print Hint *.
-Lemma w1 : (O#(S O)).
-Print Hint.
-Print Hint *.
-
-Auto.
-Save.
+Lemma w1 : rel 0 1.
+auto.
+Qed.
 
-Check (O#O).
+Check (rel 0 0).
 Locate rel.
 
-Locate Library M.
-
-Module N:=Top.M.
+Locate Module M.
 
+Module N := Top.M.
diff --git a/test-suite/modules/nested_mod_types.v b/test-suite/modules/nested_mod_types.v
new file mode 100644
index 00000000..f459f9ec
--- /dev/null
+++ b/test-suite/modules/nested_mod_types.v
@@ -0,0 +1,26 @@
+Module Type T.
+  Module Type U.
+    Module Type V.
+      Variable b : nat.
+    End V.
+    Variable a : nat.
+  End U.
+  Declare Module u : U.
+  Declare Module v : u.V.
+End T.
+
+Module F (t:T).
+End F.
+
+Module M:T.
+  Module Type U.
+    Module Type V.
+      Variable b : nat.
+    End V.
+    Variable a : nat.
+  End U.
+  Declare Module u : U.
+  Declare Module v : u.V.
+End M.
+
+Module FM := F M.
diff --git a/test-suite/modules/obj.v b/test-suite/modules/obj.v
index 2231e084..97337a12 100644
--- a/test-suite/modules/obj.v
+++ b/test-suite/modules/obj.v
@@ -1,16 +1,17 @@
-Implicit Arguments On.
+Set Implicit Arguments.
+Unset Strict Implicit.
 
 Module M. 
-  Definition a:=[s:Set]s.
+  Definition a (s : Set) := s.
   Print a.
 End M.
 
 Print M.a.
 
 Module K.
-  Definition app:=[A,B:Set; f:(A->B); x:A](f x).
+  Definition app (A B : Set) (f : A -> B) (x : A) := f x.
   Module N.
-    Definition apap:=[A,B:Set](app (app 1!A 2!B)).
+    Definition apap (A B : Set) := app (app (A:=A) (B:=B)).
     Print app.
     Print apap.
   End N.
@@ -20,7 +21,6 @@ End K.
 Print K.app.
 Print K.N.apap.
 
-Module W:=K.N.
+Module W := K.N.
 
 Print W.apap.
-
diff --git a/test-suite/modules/objects.v b/test-suite/modules/objects.v
index 418ece44..070f859e 100644
--- a/test-suite/modules/objects.v
+++ b/test-suite/modules/objects.v
@@ -1,33 +1,33 @@
 Module Type SET.
-  Axiom T:Set.
-  Axiom x:T.
+  Axiom T : Set.
+  Axiom x : T.
 End SET.
  
-Implicit Arguments On.
+Set Implicit Arguments.
+Unset Strict Implicit.
 
-Module M[X:SET].
+Module M (X: SET).
   Definition T := nat.
-  Definition x := O.
-  Definition f := [A:Set][x:A]X.x.
+  Definition x := 0.
+  Definition f (A : Set) (x : A) := X.x.
 End M.
 
-Module N:=M.
+Module N := M.
 
 Module Nat.
   Definition T := nat.
-  Definition x := O.
+  Definition x := 0.
 End Nat.
 
-Module Z:=(N Nat).
+Module Z := N Nat.
 
-Check (Z.f O).
+Check (Z.f 0).
 
-Module P[Y:SET] := N.
+Module P (Y: SET) := N.
 
-Module Y:=P Z Nat.
-
-Check (Y.f O).
+Module Y := P Z Nat.
 
+Check (Y.f 0).
 
 
 
diff --git a/test-suite/modules/objects2.v b/test-suite/modules/objects2.v
new file mode 100644
index 00000000..e286609e
--- /dev/null
+++ b/test-suite/modules/objects2.v
@@ -0,0 +1,11 @@
+(* Check that non logical object loading is done after registration of
+   the logical objects in the environment
+*)
+
+(* Bug #1118 (simplified version), submitted by Evelyne Contejean
+  (used to failed in pre-V8.1 trunk because of a call to lookup_mind
+   for structure objects) 
+*)
+
+Module Type S. Record t : Set := { a : nat; b : nat }. End S.
+Module Make (X:S). Module Y:=X. End Make.
diff --git a/test-suite/modules/pliczek.v b/test-suite/modules/pliczek.v
index 6061ace3..f806a7c4 100644
--- a/test-suite/modules/pliczek.v
+++ b/test-suite/modules/pliczek.v
@@ -1,3 +1,3 @@
 Require Export plik.
 
-Definition tutu := [X:Set](toto X).
+Definition tutu (X : Set) := toto X.
\ No newline at end of file
diff --git a/test-suite/modules/plik.v b/test-suite/modules/plik.v
index f1f59df0..50bfd960 100644
--- a/test-suite/modules/plik.v
+++ b/test-suite/modules/plik.v
@@ -1,4 +1,3 @@
-Definition toto:=[x:Set]x.
+Definition toto (x : Set) := x.
 
-Grammar constr constr8 := 
-     toto [ "#" constr7($b) ] -> [ (toto $b) ].
+(* <Warning> : Grammar is replaced by Notation *)
\ No newline at end of file
diff --git a/test-suite/modules/sig.v b/test-suite/modules/sig.v
index eb8736bb..4cb6291d 100644
--- a/test-suite/modules/sig.v
+++ b/test-suite/modules/sig.v
@@ -1,29 +1,29 @@
 Module M.
   Module Type SIG.
-    Parameter T:Set.
-    Parameter x:T.
+    Parameter T : Set.
+    Parameter x : T.
   End SIG.
-  Module N:SIG.
-    Definition T:=nat.
-    Definition x:=O.
+  Module N : SIG.
+    Definition T := nat.
+    Definition x := 0.
   End N.
 End M.
 
-Module N:=M.
+Module N := M.
 
 Module Type SPRYT.
-  Declare Module N.
-    Definition T:=M.N.T.
-    Parameter x:T.
+  Module N.
+    Definition T := M.N.T.
+    Parameter x : T.
   End N.
 End SPRYT.
 
-Module K:SPRYT:=N.  
-Module K':SPRYT:=M.  
+Module K : SPRYT := N.  
+Module K' : SPRYT := M.  
 
 Module Type SIG.
-  Definition T:Set:=M.N.T.
-  Parameter x:T.
+  Definition T : Set := M.N.T.
+  Parameter x : T.
 End SIG.
 
-Module J:SIG:=M.N.
+Module J : SIG := M.N.
\ No newline at end of file
diff --git a/test-suite/modules/sub_objects.v b/test-suite/modules/sub_objects.v
index 1bd4faef..5eec0775 100644
--- a/test-suite/modules/sub_objects.v
+++ b/test-suite/modules/sub_objects.v
@@ -1,33 +1,32 @@
 Set Implicit Arguments.
+Unset Strict Implicit.
 
 
 Module M.
-  Definition id:=[A:Set][x:A]x.
+  Definition id (A : Set) (x : A) := x.
 
   Module Type SIG.
-    Parameter idid:(A:Set)A->A.
+    Parameter idid : forall A : Set, A -> A.
   End SIG.
 
   Module N.
-    Definition idid:=[A:Set][x:A](id x).
-    Grammar constr constr8 := 
-      not_eq [ "#"  constr7($b) ] -> [ (idid $b) ].
-    Notation inc := (plus (S O)). 
+    Definition idid (A : Set) (x : A) := id x.
+    (* <Warning> : Grammar is replaced by Notation *)
+    Notation inc := (plus 1). 
   End N.
 
-  Definition zero:=(N.idid O).
+  Definition zero := N.idid 0.
 
 End M.
 
-Definition zero := (M.N.idid O).
-Definition jeden := (M.N.inc O).
+Definition zero := M.N.idid 0.
+Definition jeden := M.N.inc 0.
 
-Module Goly:=M.N.
+Module Goly := M.N.
 
-Definition Gole_zero := (Goly.idid O).
-Definition Goly_jeden := (Goly.inc O).
+Definition Gole_zero := Goly.idid 0.
+Definition Goly_jeden := Goly.inc 0.
 
 Module Ubrany : M.SIG := M.N.
 
-Definition Ubrane_zero := (Ubrany.idid O).
-
+Definition Ubrane_zero := Ubrany.idid 0.
diff --git a/test-suite/output/Arith.out b/test-suite/output/Arith.out
deleted file mode 100644
index 210dd6ad..00000000
--- a/test-suite/output/Arith.out
+++ /dev/null
@@ -1,4 +0,0 @@
-[n:nat](S (S n))
-     : nat->nat
-[n:nat](S (plus n n))
-     : nat->nat
diff --git a/test-suite/output/Arith.v b/test-suite/output/Arith.v
deleted file mode 100644
index 39989dfc..00000000
--- a/test-suite/output/Arith.v
+++ /dev/null
@@ -1,2 +0,0 @@
-Check [n](S (S n)).
-Check [n](S (plus n n)).
diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out
index 5f13caaf..a3033e94 100644
--- a/test-suite/output/Cases.out
+++ b/test-suite/output/Cases.out
@@ -1,4 +1,9 @@
 t_rect = 
-[P:(t->Type); f:([x:=t](x0:x)(P x0)->(P (k x0)))]
- Fix F{F [t:t] : (P t) := <P>Cases t of (k x x0) => (f x0 (F x0)) end}
-     : (P:(t->Type))([x:=t](x0:x)(P x0)->(P (k x0)))->(t:t)(P t)
+fun (P : t -> Type) (f : let x := t in forall x0 : x, P x0 -> P (k x0)) =>
+fix F (t : t) : P t :=
+  match t as t0 return (P t0) with
+  | k _ x0 => f x0 (F x0)
+  end
+     : forall P : t -> Type,
+       (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t
+
diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v
index 7483e8c4..452d3603 100644
--- a/test-suite/output/Cases.v
+++ b/test-suite/output/Cases.v
@@ -1,5 +1,6 @@
 (* Cases with let-in in constructors types *)
 
-Inductive t : Set := k : [x:=t]x -> x.
+Inductive t : Set :=
+    k : let x := t in x -> x.
 
 Print t_rect.
diff --git a/test-suite/output/Coercions.out b/test-suite/output/Coercions.out
index 63e042d8..4b8aa355 100644
--- a/test-suite/output/Coercions.out
+++ b/test-suite/output/Coercions.out
@@ -1,4 +1,6 @@
-(P x)
+P x
      : Prop
-(R x x)
+R x x
      : Prop
+fun (x : foo) (n : nat) => x n
+     : foo -> nat -> nat
diff --git a/test-suite/output/Coercions.v b/test-suite/output/Coercions.v
index 61b69038..c88b143f 100644
--- a/test-suite/output/Coercions.v
+++ b/test-suite/output/Coercions.v
@@ -1,9 +1,15 @@
 (* Submitted by Randy Pollack *)
 
-Record pred [S:Set]: Type := { sp_pred :> S -> Prop }.
-Record rel [S:Set]: Type := { sr_rel :> S -> S -> Prop }.
+Record pred (S : Set) : Type :=  {sp_pred :> S -> Prop}.
+Record rel (S : Set) : Type :=  {sr_rel :> S -> S -> Prop}.
 
 Section testSection.
-Variables S: Set; P: (pred S); R: (rel S); x:S.
+Variables (S : Set) (P : pred S) (R : rel S) (x : S).
 Check (P x).
 Check (R x x).
+End testSection.
+
+(* Check the removal of coercions with target Funclass *)
+
+Record foo : Type :=  {D :> nat -> nat}.
+Check (fun (x : foo) (n : nat) => x n).
diff --git a/test-suite/output/Fixpoint.out b/test-suite/output/Fixpoint.out
new file mode 100644
index 00000000..62c9d395
--- /dev/null
+++ b/test-suite/output/Fixpoint.out
@@ -0,0 +1,11 @@
+fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : 
+list B := match l with
+          | nil => nil (A:=B)
+          | a :: l0 => f a :: F A B f l0
+          end
+     : forall A B : Set, (A -> B) -> list A -> list B
+let fix f (m : nat) : nat := match m with
+                             | 0 => 0
+                             | S m' => f m'
+                             end in f 0
+     : nat
diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v
index 270fff4e..fc27e8d2 100644
--- a/test-suite/output/Fixpoint.v
+++ b/test-suite/output/Fixpoint.v
@@ -1,7 +1,18 @@
-Require PolyList.
+Require Import List.
+
+Check
+  (fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : 
+   list B := match l with
+             | nil => nil
+             | a :: l => f a :: F _ _ f l
+             end).
+
+(* V8 printing of this term used to failed in V8.0 and V8.0pl1 (cf bug #860) *)
+Check
+  let fix f (m : nat) : nat :=
+    match m with
+    | O => 0
+    | S m' => f m'
+    end
+  in f 0.
 
-Check Fix F { F/4 : (A,B:Set)(A->B)->(list A)->(list B) :=
- [_,_,f,l]Cases l of
-   nil => (nil ?)
- | (cons a l) => (cons (f a) (F ? ? f l))
- end}.
diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out
index f9cf9efc..38c5b827 100644
--- a/test-suite/output/Implicit.out
+++ b/test-suite/output/Implicit.out
@@ -1,5 +1,10 @@
-d2 = [x:nat](d1 1!x)
-     : (x,x0:nat)x0=x ->x0=x
+compose (C:=nat) S
+     : (nat -> nat) -> nat -> nat
+ex_intro (P:=fun _ : nat => True) (x:=0) I
+     : ex (fun _ : nat => True)
+d2 = fun x : nat => d1 (y:=x)
+     : forall x x0 : nat, x0 = x -> x0 = x
 
-Positions [1; 2] are implicit
+
+Arguments x, x0 are implicit
 Argument scopes are [nat_scope nat_scope _]
diff --git a/test-suite/output/Implicit.v b/test-suite/output/Implicit.v
index 2dea0d18..0ff7e87f 100644
--- a/test-suite/output/Implicit.v
+++ b/test-suite/output/Implicit.v
@@ -1,18 +1,19 @@
 Set Implicit Arguments.
+Unset Strict Implicit.
 
 (* Suggested by Pierre Casteran (bug #169) *)
 (* Argument 3 is needed to typecheck and should be printed *)
-Definition compose := [A,B,C:Set; f : A-> B ; g : B->C ; x : A] (g (f x)).
-Check (compose 3!nat S).
+Definition compose (A B C : Set) (f : A -> B) (g : B -> C) (x : A) := g (f x).
+Check (compose (C:=nat) S).
 
 (* Better to explicitly display the arguments inferable from a
    position that could disappear after reduction *)
-Inductive ex [A:Set;P:A->Prop] : Prop
-    := ex_intro : (x:A)(P x)->(ex P).
-Check (ex_intro 2![_]True 3!O I).
+Inductive ex (A : Set) (P : A -> Prop) : Prop :=
+    ex_intro : forall x : A, P x -> ex P.
+Check (ex_intro (P:=fun _ => True) (x:=0) I).
 
 (* Test for V8 printing of implicit by names *)
-Definition d1 [y;x;h:x=y:>nat] := h.
-Definition d2 [x] := (!d1 x).
+Definition d1 y x (h : x = y :>nat) := h.
+Definition d2 x := d1 (y:=x).
 
 Print d2.
diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out
index d7120f89..c7f3ed7d 100644
--- a/test-suite/output/InitSyntax.out
+++ b/test-suite/output/InitSyntax.out
@@ -1,6 +1,10 @@
-Inductive sig2 [A : Set; P : A->Prop; Q : A->Prop] : Set :=
-    exist2 : (x:A)(P x)->(Q x)->(sig2 A P Q)
-(EX x:nat|x=x)
+Inductive sig2 (A : Type) (P : A -> Prop) (Q : A -> Prop) : Type :=
+    exist2 : forall x : A, P x -> Q x -> sig2 P Q
+For sig2: Argument A is implicit
+For exist2: Argument A is implicit
+For sig2: Argument scopes are [type_scope type_scope type_scope]
+For exist2: Argument scopes are [type_scope _ _ _ _ _]
+exists x : nat, x = x
      : Prop
-[b:bool](if b then b else b)
-     : bool->bool
+fun b : bool => if b then b else b
+     : bool -> bool
diff --git a/test-suite/output/InitSyntax.v b/test-suite/output/InitSyntax.v
index 90fad371..eb39782e 100644
--- a/test-suite/output/InitSyntax.v
+++ b/test-suite/output/InitSyntax.v
@@ -1,4 +1,4 @@
 (* Soumis par Pierre *)
-Print  sig2.
-Check (EX x:nat|x=x).
-Check [b:bool]if b then b else b.
+Print sig2.
+Check (exists x : nat, x = x).
+Check (fun b : bool => if b then b else b).
diff --git a/test-suite/output/Intuition.out b/test-suite/output/Intuition.out
index cadb35c6..5831c9f4 100644
--- a/test-suite/output/Intuition.out
+++ b/test-suite/output/Intuition.out
@@ -2,6 +2,6 @@
   
   m : Z
   n : Z
-  H : `m >= n`
+  H : (m >= n)%Z
   ============================
-   `m >= m`
+   (m >= m)%Z
diff --git a/test-suite/output/Intuition.v b/test-suite/output/Intuition.v
index c0508c90..5f1914d2 100644
--- a/test-suite/output/Intuition.v
+++ b/test-suite/output/Intuition.v
@@ -1,5 +1,5 @@
-Require ZArith_base.
-Goal (m,n:Z) `m >= n` -> `m >= m` /\ `m >= n`.
-Intros; Intuition.
+Require Import ZArith_base.
+Goal forall m n : Z, (m >= n)%Z -> (m >= m)%Z /\ (m >= n)%Z.
+intros; intuition.
 Show.
 Abort.
diff --git a/test-suite/output/Nametab.out b/test-suite/output/Nametab.out
index 505821d7..d0f15f0e 100644
--- a/test-suite/output/Nametab.out
+++ b/test-suite/output/Nametab.out
@@ -1,27 +1,35 @@
-id is not a defined object
-K.id is not a defined object
-N.K.id is not a defined object
 Constant Top.Q.N.K.id
+  (shorter name to refer to it in current context is Q.N.K.id)
 Constant Top.Q.N.K.id
-K is not a defined object
-N.K is not a defined object
+  (shorter name to refer to it in current context is Q.N.K.id)
+Constant Top.Q.N.K.id
+  (shorter name to refer to it in current context is Q.N.K.id)
+Constant Top.Q.N.K.id
+Constant Top.Q.N.K.id
+  (shorter name to refer to it in current context is Q.N.K.id)
+No module is referred to by basename K
+No module is referred to by name N.K
 Module Top.Q.N.K
 Module Top.Q.N.K
-N is not a defined object
+No module is referred to by basename N
 Module Top.Q.N
 Module Top.Q.N
 Module Top.Q
 Module Top.Q
-id is not a defined object
 Constant Top.Q.N.K.id
-N.K.id is not a defined object
+  (shorter name to refer to it in current context is K.id)
+Constant Top.Q.N.K.id
+Constant Top.Q.N.K.id
+  (shorter name to refer to it in current context is K.id)
 Constant Top.Q.N.K.id
+  (shorter name to refer to it in current context is K.id)
 Constant Top.Q.N.K.id
+  (shorter name to refer to it in current context is K.id)
 Module Top.Q.N.K
-N.K is not a defined object
+No module is referred to by name N.K
 Module Top.Q.N.K
 Module Top.Q.N.K
-N is not a defined object
+No module is referred to by basename N
 Module Top.Q.N
 Module Top.Q.N
 Module Top.Q
diff --git a/test-suite/output/Nametab.v b/test-suite/output/Nametab.v
index 61966c7c..a1a7579b 100644
--- a/test-suite/output/Nametab.v
+++ b/test-suite/output/Nametab.v
@@ -1,7 +1,7 @@
 Module Q.
   Module N.
     Module K.
-      Definition id:=Set.
+      Definition id := Set.
     End K.
   End N.
 End Q.
@@ -12,18 +12,17 @@ End Q.
 (* OK  *) Locate Q.N.K.id.
 (* OK  *) Locate Top.Q.N.K.id.
 
-(* Bad *) Locate K.
-(* Bad *) Locate N.K.
-(* OK  *) Locate Q.N.K.
-(* OK  *) Locate Top.Q.N.K.
+(* Bad *) Locate Module K.
+(* Bad *) Locate Module N.K.
+(* OK  *) Locate Module Q.N.K.
+(* OK  *) Locate Module Top.Q.N.K.
 
-(* Bad *) Locate N.
-(* OK  *) Locate Q.N.
-(* OK  *) Locate Top.Q.N.
-
-(* OK  *) Locate Q.
-(* OK  *) Locate Top.Q.
+(* Bad *) Locate Module N.
+(* OK  *) Locate Module Q.N.
+(* OK  *) Locate Module Top.Q.N.
 
+(* OK  *) Locate Module Q.
+(* OK  *) Locate Module Top.Q.
 
 
 Import Q.N.
@@ -35,14 +34,14 @@ Import Q.N.
 (* OK  *) Locate Q.N.K.id.
 (* OK  *) Locate Top.Q.N.K.id.
 
-(* OK  *) Locate K.
-(* Bad *) Locate N.K.
-(* OK  *) Locate Q.N.K.
-(* OK  *) Locate Top.Q.N.K.
+(* OK  *) Locate Module K.
+(* Bad *) Locate Module N.K.
+(* OK  *) Locate Module Q.N.K.
+(* OK  *) Locate Module Top.Q.N.K.
 
-(* Bad *) Locate N.
-(* OK  *) Locate Q.N.
-(* OK  *) Locate Top.Q.N.
+(* Bad *) Locate Module N.
+(* OK  *) Locate Module Q.N.
+(* OK  *) Locate Module Top.Q.N.
 
-(* OK  *) Locate Q.
-(* OK  *) Locate Top.Q.
+(* OK  *) Locate Module Q.
+(* OK  *) Locate Module Top.Q.
diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out
new file mode 100644
index 00000000..be4cd4fa
--- /dev/null
+++ b/test-suite/output/Notations.out
@@ -0,0 +1,48 @@
+true ? 0; 1
+     : nat
+if true as x return (x ? nat; bool) then 0 else true
+     : true ? nat; bool
+Defining 'proj1' as keyword
+fun e : nat * nat => proj1 e
+     : nat * nat -> nat
+Defining 'decomp' as keyword
+decomp (true, true) as t, u in (t, u)
+     : bool * bool
+!(0 = 0)
+     : Prop
+forall n : nat, n = 0
+     : Prop
+!(0 = 0)
+     : Prop
+forall n : nat, #(n = n)
+     : Prop
+forall n n0 : nat, ##(n = n0)
+     : Prop
+forall n n0 : nat, ###(n = n0)
+     : Prop
+3 + 3
+     : Z
+3 + 3
+     : znat
+[1; 2; 4]
+     : list nat
+(1; 2, 4)
+     : nat * nat * nat
+Defining 'ifzero' as keyword
+ifzero 3
+     : bool
+Defining 'pred' as keyword
+pred 3
+     : nat
+fun n : nat => pred n
+     : nat -> nat
+fun n : nat => pred n
+     : nat -> nat
+Defining 'ifn' as keyword
+Defining 'is' as keyword
+fun x : nat => ifn x is succ n then n else 0
+     : nat -> nat
+1-
+     : bool
+-4
+     : Z
diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v
new file mode 100644
index 00000000..3cc0a189
--- /dev/null
+++ b/test-suite/output/Notations.v
@@ -0,0 +1,121 @@
+(**********************************************************************)
+(* Notations for if and let (submitted by Roland Zumkeller)           *)
+
+Notation "a ? b ; c" := (if a then b else c) (at level 10).
+
+Check (true ? 0 ; 1).
+Check if true as x return (if x then nat else bool) then 0 else true.
+
+Notation "'proj1' t" := (let (a,_) := t in a) (at level 1).
+
+Check (fun e : nat * nat => proj1 e).
+
+Notation "'decomp' a 'as' x , y 'in' b" := (let (x,y) := a in b) (at level 1).
+
+Check (decomp (true,true) as t, u in (t,u)).
+
+(**********************************************************************)
+(* Behaviour wrt to binding variables (submitted by Roland Zumkeller) *)
+
+Section A.
+
+Notation "! A" := (forall _:nat, A) (at level 60).
+
+Check ! (0=0).
+Check forall n, n=0.
+Check forall n:nat, 0=0.
+
+End A.
+
+(**********************************************************************)
+(* Behaviour wrt to binding variables (cf bug report #1186)           *)
+
+Section B.
+
+Notation "# A" := (forall n:nat, n=n->A) (at level 60).
+Check forall n:nat, # (n=n).
+
+Notation "## A" := (forall n n0:nat, n=n0->A) (at level 60).
+Check forall n n0:nat, ## (n=n0).
+
+Notation "### A" :=
+ (forall n n0:nat, match n with O => True | S n => n=n0 end ->A) (at level 60).
+Check forall n n0:nat, ### (n=n0).
+
+End B.
+
+(**********************************************************************)
+(* Conflict between notation and notation below coercions             *)
+
+(* Case of a printer conflict *)
+
+Require Import BinInt.
+Coercion Zpos : positive >-> Z.
+Open Scope Z_scope.
+
+  (* Check that (Zpos 3) is better printed by the printer for Z than
+     by the printer for positive *)
+
+Check (3 + Zpos 3).
+
+(* Case of a num printer only below coercion (submitted by Georges Gonthier) *)
+
+Open Scope nat_scope.
+
+Inductive znat : Set := Zpos (n : nat) | Zneg (m : nat).
+Coercion Zpos: nat >-> znat.
+ 
+Delimit Scope znat_scope with znat.
+Open Scope znat_scope.
+ 
+Variable addz : znat -> znat -> znat.
+Notation "z1 + z2" := (addz z1 z2) : znat_scope.
+
+  (* Check that "3+3", where 3 is in nat and the coercion to znat is implicit,
+     is printed the same way, and not "S 2 + S 2" as if numeral printing was 
+     only tested with coercion still present *)
+
+Check (3+3).
+
+(**********************************************************************)
+(* Check recursive notations                                          *)
+ 
+Require Import List.
+Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
+Check [1;2;4].
+  
+Reserved Notation "( x ; y , .. , z )" (at level 0).
+Notation "( x ; y , .. , z )" := (pair .. (pair x y) .. z).
+Check (1;2,4).
+
+(* Check basic notations involving "match" *)
+
+Section C.
+
+Notation "'ifzero' n" := (match n with 0 => true | S _ => false end)
+  (at level 0, n at level 0).
+Check (ifzero 3).
+
+Notation "'pred' n" := (match n with 0 => 0 | S n' => n' end)
+  (at level 0, n at level 0).
+Check (pred 3).
+Check (fun n => match n with 0 => 0 | S n => n end).
+Check (fun n => match n with S p as x => p | y => 0 end).
+
+Notation "'ifn' x 'is' 'succ' n 'then' t 'else' u" := 
+  (match x with O => u | S n => t end) (at level 0, u at level 0).
+Check fun x => ifn x is succ n then n else 0.
+
+End C.
+
+(* Check correction of bug #1179 *)
+
+Notation "1 -" := true (at level 0).
+Check 1-.
+
+(* This is another aspect of bug #1179 (raises anomaly in 8.1) *)
+
+Require Import ZArith.
+Open Scope Z_scope.
+Notation "- 4" := (-2 + -2).
+Check -4.
diff --git a/test-suite/output/RealSyntax.out b/test-suite/output/RealSyntax.out
index fa30656b..e6f7556d 100644
--- a/test-suite/output/RealSyntax.out
+++ b/test-suite/output/RealSyntax.out
@@ -1,4 +1,4 @@
-``32``
+32%R
      : R
-``-31``
+(-31)%R
      : R
diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v
index d976dcc1..15ae6601 100644
--- a/test-suite/output/RealSyntax.v
+++ b/test-suite/output/RealSyntax.v
@@ -1,3 +1,3 @@
-Require Reals.
-Check ``32``.
-Check ``-31``.
+Require Import Reals.
+Check 32%R.
+Check (-31)%R.
diff --git a/test-suite/output/Remark2.out b/test-suite/output/Remark2.out
deleted file mode 100644
index adabc2fe..00000000
--- a/test-suite/output/Remark2.out
+++ /dev/null
@@ -1 +0,0 @@
-B.C.t is not a defined object
diff --git a/test-suite/output/Remark2.v b/test-suite/output/Remark2.v
deleted file mode 100644
index e1ef57a0..00000000
--- a/test-suite/output/Remark2.v
+++ /dev/null
@@ -1,8 +0,0 @@
-Section A.
-Section B.
-Section C.
-Remark t : True. Proof I.
-End C.
-End B.
-End A.
-Locate B.C.t.
diff --git a/test-suite/output/Sum.out b/test-suite/output/Sum.out
index 22422602..bda6a68b 100644
--- a/test-suite/output/Sum.out
+++ b/test-suite/output/Sum.out
@@ -1,6 +1,6 @@
-nat+nat+{True}
+nat + nat + {True}
      : Set
-{True}+{True}+{True}
+{True} + {True} + {True}
      : Set
-nat+{True}+{True}
+nat + {True} + {True}
      : Set
diff --git a/test-suite/output/Sum.v b/test-suite/output/Sum.v
index aceadd12..f12285a6 100644
--- a/test-suite/output/Sum.v
+++ b/test-suite/output/Sum.v
@@ -1,3 +1,3 @@
-Check nat+nat+{True}.
-Check {True}+{True}+{True}.
-Check nat+{True}+{True}.
+Check (nat + nat + {True}).
+Check ({True} + {True} + {True}).
+Check (nat + {True} + {True}).
diff --git a/test-suite/output/Tactics.out b/test-suite/output/Tactics.out
new file mode 100644
index 00000000..8e8b8059
--- /dev/null
+++ b/test-suite/output/Tactics.out
@@ -0,0 +1,4 @@
+intro H; split; [  a H |  e H ].
+intros; match goal with
+        | |- context [if ?X then _ else _] => case X
+        end; trivial.
diff --git a/test-suite/output/Tactics.v b/test-suite/output/Tactics.v
new file mode 100644
index 00000000..8fa91994
--- /dev/null
+++ b/test-suite/output/Tactics.v
@@ -0,0 +1,18 @@
+(* Test printing of Tactic Notation *)
+
+Tactic Notation "a" constr(x) := apply x.
+Tactic Notation "e" constr(x) := exact x.
+
+Lemma test : True -> True /\ True.
+intro H; split; [a H|e H].
+Show Script.
+Qed.
+
+(* Test printing of match context *)
+(* Used to fail after translator removal (see bug #1070) *)
+
+Lemma test2 : forall n:nat, forall f: nat -> bool, O = if (f n) then O else O.
+Proof.
+intros;match goal with |- context [if ?X then _ else _ ] => case X end;trivial.
+Show Script.
+Qed.
diff --git a/test-suite/output/TranspModtype.v b/test-suite/output/TranspModtype.v
index 27b1fb9f..68eff33a 100644
--- a/test-suite/output/TranspModtype.v
+++ b/test-suite/output/TranspModtype.v
@@ -1,17 +1,17 @@
 Module Type SIG.
-  Axiom A:Set.
-  Axiom B:Set.
+  Axiom A : Set.
+  Axiom B : Set.
 End SIG.
 
-Module M:SIG.
-  Definition A:=nat.
-  Definition B:=nat.
+Module M : SIG.
+  Definition A := nat.
+  Definition B := nat.
 End M.
 
-Module N<:SIG:=M.
+Module N <: SIG := M.
 
-Module TranspId[X:SIG] <: SIG with Definition A:=X.A := X.
-Module OpaqueId[X:SIG] : SIG with Definition A:=X.A := X.
+Module TranspId (X: SIG) <: SIG with Definition A := X.A := X.
+Module OpaqueId (X: SIG) : SIG with Definition A := X.A := X.
 
 Module TrM := TranspId M.
 Module OpM := OpaqueId M.
diff --git a/test-suite/output/ZSyntax.out b/test-suite/output/ZSyntax.out
index 0fdc5b7e..cbfb9f20 100644
--- a/test-suite/output/ZSyntax.out
+++ b/test-suite/output/ZSyntax.out
@@ -1,26 +1,26 @@
-`32`
+32%Z
      : Z
-[f:(nat->Z)]`(f O)+0`
-     : (nat->Z)->Z
-[x:positive](POS (xO x))
-     : positive->Z
-[x:positive]`(POS x)+1`
-     : positive->Z
-[x:positive](POS x)
-     : positive->Z
-[x:positive](NEG (xO x))
-     : positive->Z
-[x:positive]`(POS (xO x))+0`
-     : positive->Z
-[x:positive]`(Zopp (POS (xO x)))`
-     : positive->Z
-[x:positive]`(Zopp (POS (xO x)))+0`
-     : positive->Z
-`(inject_nat (0))+1`
+fun f : nat -> Z => (f 0%nat + 0)%Z
+     : (nat -> Z) -> Z
+fun x : positive => Zpos (xO x)
+     : positive -> Z
+fun x : positive => (Zpos x + 1)%Z
+     : positive -> Z
+fun x : positive => Zpos x
+     : positive -> Z
+fun x : positive => Zneg (xO x)
+     : positive -> Z
+fun x : positive => (Zpos (xO x) + 0)%Z
+     : positive -> Z
+fun x : positive => (- Zpos (xO x))%Z
+     : positive -> Z
+fun x : positive => (- Zpos (xO x) + 0)%Z
+     : positive -> Z
+(Z_of_nat 0 + 1)%Z
      : Z
-`0+(inject_nat (plus (0) (0)))`
+(0 + Z_of_nat (0 + 0))%Z
      : Z
-`(inject_nat (0)) = 0`
+Z_of_nat 0 = 0%Z
      : Prop
-`0+(inject_nat (11))`
+(0 + Z_of_nat 11)%Z
      : Z
diff --git a/test-suite/output/ZSyntax.v b/test-suite/output/ZSyntax.v
index 49442b75..289a1e3f 100644
--- a/test-suite/output/ZSyntax.v
+++ b/test-suite/output/ZSyntax.v
@@ -1,17 +1,17 @@
-Require ZArith.
-Check `32`.
-Check [f:nat->Z]`(f O) + 0`.
-Check [x:positive]`(POS (xO x))`.
-Check [x:positive]`(POS x)+1`.
-Check [x:positive]`(POS x)`.
-Check [x:positive]`(NEG (xO x))`.
-Check [x:positive]`(POS (xO x))+0`.
-Check [x:positive]`(Zopp (POS (xO x)))`.
-Check [x:positive]`(Zopp (POS (xO x)))+0`.
-Check `(inject_nat O)+1`.
-Check (Zplus `0` (inject_nat (plus O O))).
-Check `(inject_nat O)=0`.
+Require Import ZArith.
+Check 32%Z.
+Check (fun f : nat -> Z => (f 0%nat + 0)%Z).
+Check (fun x : positive => Zpos (xO x)).
+Check (fun x : positive => (Zpos x + 1)%Z).
+Check (fun x : positive => Zpos x).
+Check (fun x : positive => Zneg (xO x)).
+Check (fun x : positive => (Zpos (xO x) + 0)%Z).
+Check (fun x : positive => (- Zpos (xO x))%Z).
+Check (fun x : positive => (- Zpos (xO x) + 0)%Z).
+Check (Z_of_nat 0 + 1)%Z.
+Check (0 + Z_of_nat (0 + 0))%Z.
+Check (Z_of_nat 0 = 0%Z).
 
 (* Submitted by Pierre Casteran *)
-Require Arith.
-Check (Zplus `0` (inject_nat (11))).
+Require Import Arith.
+Check (0 + Z_of_nat 11)%Z.
diff --git a/test-suite/output/implicits.out b/test-suite/output/implicits.out
deleted file mode 100644
index e4837199..00000000
--- a/test-suite/output/implicits.out
+++ /dev/null
@@ -1,4 +0,0 @@
-(compose 3!nat S)
-     : (nat->nat)->nat->nat
-(ex_intro 2![_:nat]True 3!(0) I)
-     : (ex [_:nat]True)
diff --git a/test-suite/output/implicits.v b/test-suite/output/implicits.v
deleted file mode 100644
index d7ea7227..00000000
--- a/test-suite/output/implicits.v
+++ /dev/null
@@ -1,13 +0,0 @@
-Set Implicit Arguments.
-
-(* Suggested by Pierre Casteran (bug #169) *)
-(* Argument 3 is needed to typecheck and should be printed *)
-Definition compose := [A,B,C:Set; f : A-> B ; g : B->C ; x : A] (g (f x)).
-Check (compose 3!nat S).
-
-(* Better to explicitly display the arguments inferable from a
-   position that could disappear after reduction *)
-Inductive ex [A:Set;P:A->Prop] : Prop
-    := ex_intro : (x:A)(P x)->(ex P).
-Check (ex_intro 2![_]True 3!O I).
-
diff --git a/test-suite/success/Abstract.v8 b/test-suite/success/Abstract.v
index 21a985bc..fc8800a5 100644
--- a/test-suite/success/Abstract.v8
+++ b/test-suite/success/Abstract.v
@@ -24,3 +24,4 @@ induction n.
 Defined.
 
 End S.
+
diff --git a/test-suite/success/CanonicalStructure.v b/test-suite/success/CanonicalStructure.v
new file mode 100644
index 00000000..44d21b83
--- /dev/null
+++ b/test-suite/success/CanonicalStructure.v
@@ -0,0 +1,14 @@
+(* Bug #1172 *)
+
+Structure foo : Type := Foo {
+   A : Set; Aopt := option A; unopt : Aopt -> A
+}.
+
+Canonical Structure unopt_nat := @Foo nat (fun _ => O).
+
+(* Granted wish #1187 *)
+
+Record Silly (X : Set) : Set := mkSilly { x : X }.
+Definition anotherMk := mkSilly.
+Definition struct := anotherMk nat 3.
+Canonical Structure struct.
diff --git a/test-suite/success/Case1.v b/test-suite/success/Case1.v
index 2d5a5134..ea9b654d 100644
--- a/test-suite/success/Case1.v
+++ b/test-suite/success/Case1.v
@@ -2,14 +2,14 @@
 
 Section NATIND2.
 Variable P : nat -> Type.
-Variable H0 : (P O).
-Variable H1 : (P (S O)).
-Variable H2 : (n:nat)(P n)->(P (S (S n))).
-Fixpoint nat_ind2 [n:nat] : (P n) :=
-         <P>Cases n of  
-                        O     => H0
-                  | (S O)     => H1
-                  | (S (S n)) => (H2 n (nat_ind2 n))
-        end.
+Variable H0 : P 0.
+Variable H1 : P 1.
+Variable H2 : forall n : nat, P n -> P (S (S n)).
+Fixpoint nat_ind2 (n : nat) : P n :=
+  match n as x return (P x) with
+  | O => H0
+  | S O => H1
+  | S (S n) => H2 n (nat_ind2 n)
+  end.
 End NATIND2.
 
diff --git a/test-suite/success/Case10.v b/test-suite/success/Case10.v
index 73413c47..378859e9 100644
--- a/test-suite/success/Case10.v
+++ b/test-suite/success/Case10.v
@@ -2,25 +2,27 @@
 (*     To test compilation of dependent case      *)
 (*      Multiple Patterns                         *)
 (* ============================================== *)
-Inductive skel: Type :=
-     PROP: skel
-   | PROD: skel->skel->skel.
+Inductive skel : Type :=
+  | PROP : skel
+  | PROD : skel -> skel -> skel.
 
 Parameter Can : skel -> Type.
-Parameter default_can : (s:skel) (Can s).
+Parameter default_can : forall s : skel, Can s.
 
 
-Type [s1,s2:skel]
-      <[s1,_:skel](Can s1)>Cases s1 s2 of
-          PROP PROP => (default_can PROP)
-        | s1 _ => (default_can s1)
-        end.
+Type
+  (fun s1 s2 : skel =>
+   match s1, s2 return (Can s1) with
+   | PROP, PROP => default_can PROP
+   | s1, _ => default_can s1
+   end).
 
 
-Type [s1,s2:skel]
-<[s1:skel][_:skel](Can s1)>Cases s1 s2 of
-  PROP                 PROP => (default_can PROP)
-| (PROP as s)             _ => (default_can s)
-| ((PROD s1 s2) as s)  PROP => (default_can s)
-| ((PROD s1 s2) as s)   _   => (default_can s)
-end.
+Type
+  (fun s1 s2 : skel =>
+   match s1, s2 return (Can s1) with
+   | PROP, PROP => default_can PROP
+   | PROP as s, _ => default_can s
+   | PROD s1 s2 as s, PROP => default_can s
+   | PROD s1 s2 as s, _ => default_can s
+   end).
diff --git a/test-suite/success/Case11.v b/test-suite/success/Case11.v
index 580cd87d..fd5d139c 100644
--- a/test-suite/success/Case11.v
+++ b/test-suite/success/Case11.v
@@ -3,9 +3,11 @@
 
 Section A.
 
-Variables Alpha:Set; Beta:Set.
+Variables (Alpha : Set) (Beta : Set).
 
-Definition nodep_prod_of_dep: (sigS Alpha [a:Alpha]Beta)-> Alpha*Beta:=
-[c] Cases c of (existS a b)=>(a,b) end.
+Definition nodep_prod_of_dep (c : sigS (fun a : Alpha => Beta)) :
+  Alpha * Beta := match c with
+                  | existS a b => (a, b)
+                  end.
 
 End A.
diff --git a/test-suite/success/Case12.v b/test-suite/success/Case12.v
index 284695f4..f6a0d578 100644
--- a/test-suite/success/Case12.v
+++ b/test-suite/success/Case12.v
@@ -1,60 +1,73 @@
 (* This example was proposed by Cuihtlauac ALVARADO *)
 
-Require PolyList.
+Require Import List.
 
-Fixpoint mult2 [n:nat] : nat :=
-Cases n of
-| O => O
-| (S n) => (S (S (mult2 n)))
-end.
+Fixpoint mult2 (n : nat) : nat :=
+  match n with
+  | O => 0
+  | S n => S (S (mult2 n))
+  end.
 
 Inductive list : nat -> Set :=
-| nil : (list O)
-| cons : (n:nat)(list (mult2 n))->(list (S (S (mult2 n)))).
+  | nil : list 0
+  | cons : forall n : nat, list (mult2 n) -> list (S (S (mult2 n))).
 
 Type
-[P:((n:nat)(list n)->Prop);
- f:(P O nil);
- f0:((n:nat; l:(list (mult2 n)))
-      (P (mult2 n) l)->(P (S (S (mult2 n))) (cons n l)))]
- Fix F
-   {F [n:nat; l:(list n)] : (P n l) :=
-      <P>Cases l of
-        nil => f
-      | (cons n0 l0) => (f0 n0 l0 (F (mult2 n0) l0))
-      end}.
+  (fun (P : forall n : nat, list n -> Prop) (f : P 0 nil)
+     (f0 : forall (n : nat) (l : list (mult2 n)),
+           P (mult2 n) l -> P (S (S (mult2 n))) (cons n l)) =>
+   fix F (n : nat) (l : list n) {struct l} : P n l :=
+     match l as x0 in (list x) return (P x x0) with
+     | nil => f
+     | cons n0 l0 => f0 n0 l0 (F (mult2 n0) l0)
+     end).
 
 Inductive list' : nat -> Set :=
-| nil' : (list' O)
-| cons' : (n:nat)[m:=(mult2 n)](list' m)->(list' (S (S m))).
+  | nil' : list' 0
+  | cons' : forall n : nat, let m := mult2 n in list' m -> list' (S (S m)).
 
-Fixpoint length [n; l:(list' n)] : nat :=
-  Cases l of
-     nil' => O
-  | (cons' _ m l0) => (S (length m l0))
+Fixpoint length n (l : list' n) {struct l} : nat :=
+  match l with
+  | nil' => 0
+  | cons' _ m l0 => S (length m l0)
   end.
 
 Type
-[P:((n:nat)(list' n)->Prop);
- f:(P O nil');
- f0:((n:nat)
-      [m:=(mult2 n)](l:(list' m))(P m l)->(P (S (S m)) (cons' n l)))]
- Fix F
-   {F [n:nat; l:(list' n)] : (P n l) :=
-      <P>
-        Cases l of
-          nil' => f
-        | (cons' n0 m l0) => (f0 n0 l0 (F m l0))
-        end}.
+  (fun (P : forall n : nat, list' n -> Prop) (f : P 0 nil')
+     (f0 : forall n : nat,
+           let m := mult2 n in
+           forall l : list' m, P m l -> P (S (S m)) (cons' n l)) =>
+   fix F (n : nat) (l : list' n) {struct l} : P n l :=
+     match l as x0 in (list' x) return (P x x0) with
+     | nil' => f
+     | cons' n0 m l0 => f0 n0 l0 (F m l0)
+     end).
 
 (* Check on-the-fly insertion of let-in patterns for compatibility *)
 
 Inductive list'' : nat -> Set :=
-| nil'' : (list'' O)
-| cons'' : (n:nat)[m:=(mult2 n)](list'' m)->[p:=(S (S m))](list'' p).
-
-Check Fix length { length [n; l:(list'' n)] : nat :=
-         Cases l of
-           nil'' => O
-         | (cons'' n l0) => (S (length (mult2 n) l0))
-         end }.
+  | nil'' : list'' 0
+  | cons'' :
+      forall n : nat,
+      let m := mult2 n in list'' m -> let p := S (S m) in list'' p.
+
+Check
+  (fix length n (l : list'' n) {struct l} : nat :=
+     match l with
+     | nil'' => 0
+     | cons'' n l0 => S (length (mult2 n) l0)
+     end).
+
+(* Check let-in in both parameters and in constructors *)
+
+Inductive list''' (A:Set) (B:=(A*A)%type) (a:A) : B -> Set :=
+  | nil''' : list''' A a (a,a)
+  | cons''' : 
+     forall a' : A, let m := (a',a) in list''' A a m -> list''' A a (a,a).
+
+Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m) 
+  {struct l} : nat :=
+  match l with
+  | nil''' => 0
+  | cons''' _ m l0 => S (length''' A a m l0)
+  end.
diff --git a/test-suite/success/Case13.v b/test-suite/success/Case13.v
index 71c9191d..f14725a8 100644
--- a/test-suite/success/Case13.v
+++ b/test-suite/success/Case13.v
@@ -1,33 +1,81 @@
 (* Check coercions in patterns *)
 
 Inductive I : Set :=
-  C1 : nat -> I
-| C2 : I -> I.
+  | C1 : nat -> I
+  | C2 : I -> I.
 
 Coercion C1 : nat >-> I.
 
 (* Coercion at the root of pattern *)
-Check [x]Cases x of (C2 n) => O | O => O | (S n) => n end.
+Check (fun x => match x with
+                | C2 n => 0
+                | O => 0
+                | S n => n
+                end).
 
 (* Coercion not at the root of pattern *)
-Check [x]Cases x of (C2 O) => O | _ => O end.
+Check (fun x => match x with
+                | C2 O => 0
+                | _ => 0
+                end).
 
 (* Unification and coercions inside patterns *)
-Check [x:(option nat)]Cases x of None => O | (Some O) => O | _ => O end.
+Check
+  (fun x : option nat => match x with
+                         | None => 0
+                         | Some O => 0
+                         | _ => 0
+                         end).
 
 (* Coercion up to delta-conversion, and unification *)
-Coercion somenat := (Some nat).
-Check [x]Cases x of None => O | O => O | (S n) => n end.
+Coercion somenat := Some (A:=nat).
+Check (fun x => match x with
+                | None => 0
+                | O => 0
+                | S n => n
+                end).
 
 (* Coercions with parameters *)
-Inductive listn : nat-> Set := 
-  niln : (listn O) 
-| consn : (n:nat)nat->(listn n) -> (listn (S n)).
+Inductive listn : nat -> Set :=
+  | niln : listn 0
+  | consn : forall n : nat, nat -> listn n -> listn (S n).
 
 Inductive I' : nat -> Set :=
-  C1' : (n:nat) (listn n) -> (I' n)
-| C2' : (n:nat) (I' n) -> (I' n).
+  | C1' : forall n : nat, listn n -> I' n
+  | C2' : forall n : nat, I' n -> I' n.
 
 Coercion C1' : listn >-> I'.
-Check [x:(I' O)]Cases x of (C2' _ _) => O | niln => O | _ => O end.
-Check [x:(I' O)]Cases x of (C2' _ niln) => O | _ => O end.
+Check (fun x : I' 0 => match x with
+                       | C2' _ _ => 0
+                       | niln => 0
+                       | _ => 0
+                       end).
+Check (fun x : I' 0 => match x with
+                       | C2' _ niln => 0
+                       | _ => 0
+                       end).
+
+(* Check insertion of coercions around matched subterm *)
+
+Parameter A:Set.
+Parameter f:> A -> nat.
+
+Inductive J : Set := D : A -> J.
+
+Check (fun x => match x with
+                | D 0 => 0
+                | D _ => 1
+                end).
+
+(* Check coercions against the type of the term to match *)
+(* Used to fail in V8.1beta *)
+
+Inductive C : Set := c : C.
+Inductive E : Set := e :> C -> E.
+Check fun (x : E) => match x with c => e c end.
+
+(* Check coercions with uniform parameters (cf bug #1168) *)
+
+Inductive C' : bool -> Set := c' : C' true.
+Inductive E' (b : bool) : Set := e' :> C' b -> E' b.
+Check fun (x : E' true) => match x with c' => e' true c' end.
diff --git a/test-suite/success/Case14.v b/test-suite/success/Case14.v
index edecee79..f106a64c 100644
--- a/test-suite/success/Case14.v
+++ b/test-suite/success/Case14.v
@@ -4,13 +4,18 @@
 Axiom bad : false = true.
 
 Definition try1 : False :=
-  <[b:bool][_:false=b](if b then False else True)>
-  Cases bad of refl_equal => I end.
+  match bad in (_ = b) return (if b then False else True) with
+  | refl_equal => I
+  end.
 
 Definition try2 : False :=
-  <[b:bool][_:false=b]((if b then False else True)::Prop)>
-  Cases bad of refl_equal => I end.
+  match bad in (_ = b) return ((if b then False else True):Prop) with
+  | refl_equal => I
+  end.
 
 Definition try3 : False :=
-  <[b:bool][_:false=b](([b':bool] if b' then False else True) b)>
-  Cases bad of refl_equal => I end.
+  match
+    bad in (_ = b) return ((fun b' : bool => if b' then False else True) b)
+  with
+  | refl_equal => I
+  end.
diff --git a/test-suite/success/Case15.v b/test-suite/success/Case15.v
index 22944520..8431880d 100644
--- a/test-suite/success/Case15.v
+++ b/test-suite/success/Case15.v
@@ -2,20 +2,23 @@
    apparently of inductive type *)
 
 (* Check that the non dependency in y is OK both in V7 and V8 *)
-Check ([x;y:Prop;z]<[x][z]x=x \/ z=z>Cases x y z of
-           | O y z' => (or_introl ? (z'=z') (refl_equal ? O))
-           | _ y O => (or_intror ?? (refl_equal ? O))
-           | x y _ => (or_introl ?? (refl_equal ? x))
-           end).
+Check
+  (fun x (y : Prop) z =>
+   match x, y, z return (x = x \/ z = z) with
+   | O, y, z' => or_introl (z' = z') (refl_equal 0)
+   | _, y, O => or_intror _ (refl_equal 0)
+   | x, y, _ => or_introl _ (refl_equal x)
+   end).
 
 (* Suggested by Pierre Letouzey (PR#207) *)
-Inductive Boite : Set := 
-  boite : (b:bool)(if b then nat else nat*nat)->Boite. 
+Inductive Boite : Set :=
+    boite : forall b : bool, (if b then nat else (nat * nat)%type) -> Boite. 
 
-Definition test := [B:Boite]<nat>Cases B of 
-  (boite true n) => n 
-| (boite false (n,m)) => (plus n m)
-end.
+Definition test (B : Boite) :=
+  match B return nat with
+  | boite true n => n
+  | boite false (n, m) => n + m
+  end.
 
 (* Check lazyness of compilation ... future work
 Inductive I : Set := c : (b:bool)(if b then bool else nat)->I.
diff --git a/test-suite/success/Case16.v b/test-suite/success/Case16.v
index 3f142fae..77016bbf 100644
--- a/test-suite/success/Case16.v
+++ b/test-suite/success/Case16.v
@@ -2,8 +2,9 @@
 (* Test dependencies in constructors                                  *)
 (**********************************************************************)
 
-Check [x : {b:bool|if b then True else False}]
-   <[x]let (b,_) = x in if b then True else False>Cases x of
-   | (exist true y)  => y
-   | (exist false z) => z
-   end.
+Check
+  (fun x : {b : bool | if b then True else False} =>
+   match x return (let (b, _) := x in if b then True else False) with
+   | exist true y => y
+   | exist false z => z
+   end).
diff --git a/test-suite/success/Case17.v b/test-suite/success/Case17.v
index 07d64958..061e136e 100644
--- a/test-suite/success/Case17.v
+++ b/test-suite/success/Case17.v
@@ -3,43 +3,48 @@
    (Simplification of an example from file parsing2.v of the Coq'Art
     exercises) *)
 
-Require Import PolyList.
+Require Import List.
 
-Variable parse_rel : (list bool) -> (list bool) -> nat -> Prop.
+Variable parse_rel : list bool -> list bool -> nat -> Prop.
 
-Variables l0:(list bool); rec:(l' : (list bool))
-    (le (length l') (S (length l0))) ->
-    {l'' : (list bool) &
-    {t : nat | (parse_rel l' l'' t) /\ (le (length l'') (length l'))}} +
-    {(l'' : (list bool))(t : nat)~ (parse_rel l' l'' t)}.
+Variables (l0 : list bool)
+  (rec :
+     forall l' : list bool,
+     length l' <= S (length l0) ->
+     {l'' : list bool & 
+     {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} +
+     {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}).
 
-Axiom HHH : (A:Prop)A.
+Axiom HHH : forall A : Prop, A.
 
-Check (Cases (rec l0 (HHH ?)) of
-      | (inleft (existS (cons false l1) _)) => (inright ? ? (HHH ?))
-      | (inleft (existS (cons true l1) (exist t1 (conj Hp Hl)))) =>
-         (inright ? ? (HHH ?))
-      | (inleft (existS _ _)) => (inright ? ? (HHH ?))
-      | (inright Hnp) => (inright ? ? (HHH ?))
-      end ::
-   {l'' : (list bool) &
-   {t : nat | (parse_rel (cons true l0) l'' t) /\ (le (length l'') (S (length l0)))}} +
-   {(l'' : (list bool)) (t : nat) ~ (parse_rel (cons true l0) l'' t)}).
+Check
+  (match rec l0 (HHH _) with
+   | inleft (existS (false :: l1) _) => inright _ (HHH _)
+   | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) =>
+       inright _ (HHH _)
+   | inleft (existS _ _) => inright _ (HHH _)
+   | inright Hnp => inright _ (HHH _)
+   end
+   :{l'' : list bool & 
+    {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} +
+    {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}).
  
 (* The same but with relative links to l0 and rec *)
  
-Check [l0:(list bool);rec:(l' : (list bool))
-    (le (length l') (S (length l0))) ->
-    {l'' : (list bool) &
-    {t : nat | (parse_rel l' l'' t) /\ (le (length l'') (length l'))}} +
-    {(l'' : (list bool)) (t : nat) ~ (parse_rel l' l'' t)}]
-   (Cases (rec l0 (HHH ?)) of
-      | (inleft (existS (cons false l1) _)) => (inright ? ? (HHH ?))
-      | (inleft (existS (cons true l1) (exist t1 (conj Hp Hl)))) =>
-         (inright ? ? (HHH ?))
-      | (inleft (existS _ _)) => (inright ? ? (HHH ?))
-      | (inright Hnp) => (inright ? ? (HHH ?))
-      end ::
-   {l'' : (list bool) &
-   {t : nat | (parse_rel (cons true l0) l'' t) /\ (le (length l'') (S (length l0)))}} +
-   {(l'' : (list bool)) (t : nat) ~ (parse_rel (cons true l0) l'' t)}).
+Check
+  (fun (l0 : list bool)
+     (rec : forall l' : list bool,
+            length l' <= S (length l0) ->
+            {l'' : list bool & 
+            {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} +
+            {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}) =>
+   match rec l0 (HHH _) with
+   | inleft (existS (false :: l1) _) => inright _ (HHH _)
+   | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) =>
+       inright _ (HHH _)
+   | inleft (existS _ _) => inright _ (HHH _)
+   | inright Hnp => inright _ (HHH _)
+   end
+   :{l'' : list bool & 
+    {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} +
+    {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}).
diff --git a/test-suite/success/Case18.v b/test-suite/success/Case18.v
new file mode 100644
index 00000000..91c80e88
--- /dev/null
+++ b/test-suite/success/Case18.v
@@ -0,0 +1,14 @@
+(* Check or-patterns *)
+
+Definition g x :=
+  match x with ((((1 as x),_) | (_,x)), (_,(2 as y))|(y,_)) => (x,y) end.
+
+Check (refl_equal _ : g ((1,2),(3,4)) = (1,3)).
+
+Check (refl_equal _ : g ((1,4),(3,2)) = (1,2)).
+
+Fixpoint max (n m:nat) {struct m} : nat :=
+  match  n, m with
+  | S n', S m' => S (max n' m')
+  | 0, p | p, 0 => p
+  end.
diff --git a/test-suite/success/Case19.v b/test-suite/success/Case19.v
new file mode 100644
index 00000000..9a6ed71a
--- /dev/null
+++ b/test-suite/success/Case19.v
@@ -0,0 +1,8 @@
+(* This used to fail in Coq version 8.1 beta due to a non variable
+   universe (issued by the inductive sort-polymorphism) being sent by
+   pretyping to the kernel (bug #1182) *)
+
+Variable T : Type.
+Variable x : nat*nat.
+
+Check let (_, _) := x in sigT (fun _ : T => nat).
diff --git a/test-suite/success/Case2.v b/test-suite/success/Case2.v
index 0aa7b5be..db433695 100644
--- a/test-suite/success/Case2.v
+++ b/test-suite/success/Case2.v
@@ -3,9 +3,10 @@
 (*  Nested patterns                               *)
 (* ============================================== *)
 
-Type <[n:nat]n=n>Cases O of 
-                    O => (refl_equal nat O) 
-                  | m => (refl_equal nat m) 
-end.
+Type
+  match 0 as n return (n = n) with
+  | O => refl_equal 0
+  | m => refl_equal m
+  end.
 
 
diff --git a/test-suite/success/Case5.v b/test-suite/success/Case5.v
index fe49cdf9..833621d2 100644
--- a/test-suite/success/Case5.v
+++ b/test-suite/success/Case5.v
@@ -1,14 +1,13 @@
 
-Parameter ff: (n,m:nat)~n=m -> ~(S n)=(S m).
-Parameter discr_r : (n:nat) ~(O=(S n)).
-Parameter discr_l : (n:nat) ~((S n)=O).
+Parameter ff : forall n m : nat, n <> m -> S n <> S m.
+Parameter discr_r : forall n : nat, 0 <> S n.
+Parameter discr_l : forall n : nat, S n <> 0.
 
 
-Type 
-[n:nat] 
-  <[n:nat]n=O\/~n=O>Cases n of 
-      O     => (or_introl ? ~O=O (refl_equal ? O))      
-   |  (S O) => (or_intror (S O)=O ? (discr_l O))
-   |  (S (S x)) => (or_intror (S (S x))=O ? (discr_l (S x)))
- 
-  end.
+Type
+  (fun n : nat =>
+   match n return (n = 0 \/ n <> 0) with
+   | O => or_introl (0 <> 0) (refl_equal 0)
+   | S O => or_intror (1 = 0) (discr_l 0)
+   | S (S x) => or_intror (S (S x) = 0) (discr_l (S x))
+   end).
diff --git a/test-suite/success/Case6.v b/test-suite/success/Case6.v
index a262251e..cc1994e7 100644
--- a/test-suite/success/Case6.v
+++ b/test-suite/success/Case6.v
@@ -1,19 +1,15 @@
-Parameter ff: (n,m:nat)~n=m -> ~(S n)=(S m).
-Parameter discr_r : (n:nat) ~(O=(S n)).
-Parameter discr_l : (n:nat) ~((S n)=O).
-
-Fixpoint eqdec [n:nat] : (m:nat) n=m \/ ~n=m := 
-[m:nat]
- <[n,m:nat] n=m \/ ~n=m>Cases n m of
-      O   O   => (or_introl ? ~O=O (refl_equal ? O))
-
-   |  O (S x) => (or_intror O=(S x) ? (discr_r x))
-
-   | (S x) O  => (or_intror ? ~(S x)=O (discr_l x))
-
-   | ((S x) as N) ((S y) as M) =>  
-      <N=M\/~N=M>Cases (eqdec x y) of
-        (or_introl h) => (or_introl  ? ~N=M (f_equal nat nat S x y h))
-      | (or_intror h) => (or_intror N=M ? (ff x y h))   
+Parameter ff : forall n m : nat, n <> m -> S n <> S m.
+Parameter discr_r : forall n : nat, 0 <> S n.
+Parameter discr_l : forall n : nat, S n <> 0.
+
+Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
+  match n, m return (n = m \/ n <> m) with
+  | O, O => or_introl (0 <> 0) (refl_equal 0)
+  | O, S x => or_intror (0 = S x) (discr_r x)
+  | S x, O => or_intror _ (discr_l x)
+  | S x as N, S y as M =>
+      match eqdec x y return (N = M \/ N <> M) with
+      | or_introl h => or_introl (N <> M) (f_equal S h)
+      | or_intror h => or_intror (N = M) (ff x y h)
       end
- end.
+  end.
diff --git a/test-suite/success/Case7.v b/test-suite/success/Case7.v
index 6e2aea48..6e4b2003 100644
--- a/test-suite/success/Case7.v
+++ b/test-suite/success/Case7.v
@@ -1,16 +1,17 @@
-Inductive List [A:Set] :Set := 
- Nil:(List A) | Cons:A->(List A)->(List A).
+Inductive List (A : Set) : Set :=
+  | Nil : List A
+  | Cons : A -> List A -> List A.
 
-Inductive Empty [A:Set] : (List A)-> Prop := 
-  intro_Empty: (Empty A (Nil A)).
+Inductive Empty (A : Set) : List A -> Prop :=
+    intro_Empty : Empty A (Nil A).
 
-Parameter inv_Empty : (A:Set)(a:A)(x:(List A)) ~(Empty A (Cons A a x)).
+Parameter
+  inv_Empty : forall (A : Set) (a : A) (x : List A), ~ Empty A (Cons A a x).
 
 
 Type
-[A:Set] 
-[l:(List A)]
-  <[l:(List A)](Empty A l) \/ ~(Empty A l)>Cases l of 
-        Nil  =>  (or_introl ? ~(Empty A (Nil A)) (intro_Empty A))
-   |  ((Cons a y) as b) =>  (or_intror (Empty A b) ? (inv_Empty A a y))
-  end.
+  (fun (A : Set) (l : List A) =>
+   match l return (Empty A l \/ ~ Empty A l) with
+   | Nil => or_introl (~ Empty A (Nil A)) (intro_Empty A)
+   | Cons a y as b => or_intror (Empty A b) (inv_Empty A a y)
+   end).
diff --git a/test-suite/success/Case8.v b/test-suite/success/Case8.v
new file mode 100644
index 00000000..a6113ab9
--- /dev/null
+++ b/test-suite/success/Case8.v
@@ -0,0 +1,11 @@
+(* Check dependencies in the matching predicate (was failing in V8.0pl1) *)
+
+Inductive t : forall x : 0 = 0, x = x -> Prop :=
+    c : forall x : 0 = 0, t x (refl_equal x).
+
+Definition a (x : t _ (refl_equal (refl_equal 0))) :=
+  match x return match x with
+                 | c y => Prop
+                 end with
+  | c y => y = y
+  end.
diff --git a/test-suite/success/Case9.v b/test-suite/success/Case9.v
index a5d07405..a8534a0b 100644
--- a/test-suite/success/Case9.v
+++ b/test-suite/success/Case9.v
@@ -1,55 +1,61 @@
-Inductive List [A:Set] :Set := 
- Nil:(List A) | Cons:A->(List A)->(List A).
-
-Inductive eqlong : (List nat)-> (List nat)-> Prop :=
- eql_cons : (n,m:nat)(x,y:(List nat)) 
-            (eqlong x y) -> (eqlong (Cons nat n x) (Cons nat m y))
-| eql_nil :  (eqlong (Nil nat) (Nil nat)).
-
-
-Parameter V1 : (eqlong (Nil nat) (Nil nat))\/ ~(eqlong (Nil nat) (Nil nat)).
-Parameter V2 : (a:nat)(x:(List nat))
-      (eqlong (Nil nat) (Cons nat a x))\/ ~(eqlong (Nil nat)(Cons nat a x)).
-Parameter V3 : (a:nat)(x:(List nat))
-      (eqlong  (Cons nat a x)  (Nil nat))\/ ~(eqlong (Cons nat a x) (Nil nat)).
-Parameter V4 : (a:nat)(x:(List nat))(b:nat)(y:(List nat))
-      (eqlong  (Cons nat a x)(Cons nat b y))
-        \/ ~(eqlong (Cons nat a x) (Cons nat b y)).
-
-Parameter nff : (n,m:nat)(x,y:(List nat)) 
-               ~(eqlong x y)-> ~(eqlong (Cons nat n x) (Cons nat m y)).
-Parameter inv_r : (n:nat)(x:(List nat)) ~(eqlong (Nil nat) (Cons nat n x)).
-Parameter inv_l : (n:nat)(x:(List nat)) ~(eqlong (Cons nat n x) (Nil nat)).
-
-Fixpoint eqlongdec [x:(List nat)]: (y:(List nat))(eqlong x y)\/~(eqlong x y) :=
-[y:(List nat)]
- <[x,y:(List nat)](eqlong x y)\/~(eqlong x y)>Cases x y of
-      Nil Nil   => (or_introl ? ~(eqlong (Nil nat) (Nil nat))  eql_nil)
-
-   |  Nil ((Cons a x) as L) =>(or_intror (eqlong (Nil nat) L)  ? (inv_r a x))
-
-   |  ((Cons a x) as L) Nil => (or_intror (eqlong L (Nil nat)) ? (inv_l a x))
-
-   | ((Cons a x) as L1) ((Cons b y) as L2) =>  
-      <(eqlong L1 L2) \/~(eqlong L1 L2)>Cases (eqlongdec x y) of
-        (or_introl h) => (or_introl  ? ~(eqlong L1 L2) (eql_cons a b x y h))
-      | (or_intror h) => (or_intror (eqlong L1 L2) ? (nff a b x y h))   
+Inductive List (A : Set) : Set :=
+  | Nil : List A
+  | Cons : A -> List A -> List A.
+
+Inductive eqlong : List nat -> List nat -> Prop :=
+  | eql_cons :
+      forall (n m : nat) (x y : List nat),
+      eqlong x y -> eqlong (Cons nat n x) (Cons nat m y)
+  | eql_nil : eqlong (Nil nat) (Nil nat).
+
+
+Parameter V1 : eqlong (Nil nat) (Nil nat) \/ ~ eqlong (Nil nat) (Nil nat).
+Parameter
+  V2 :
+    forall (a : nat) (x : List nat),
+    eqlong (Nil nat) (Cons nat a x) \/ ~ eqlong (Nil nat) (Cons nat a x).
+Parameter
+  V3 :
+    forall (a : nat) (x : List nat),
+    eqlong (Cons nat a x) (Nil nat) \/ ~ eqlong (Cons nat a x) (Nil nat).
+Parameter
+  V4 :
+    forall (a : nat) (x : List nat) (b : nat) (y : List nat),
+    eqlong (Cons nat a x) (Cons nat b y) \/
+    ~ eqlong (Cons nat a x) (Cons nat b y).
+
+Parameter
+  nff :
+    forall (n m : nat) (x y : List nat),
+    ~ eqlong x y -> ~ eqlong (Cons nat n x) (Cons nat m y).
+Parameter
+  inv_r : forall (n : nat) (x : List nat), ~ eqlong (Nil nat) (Cons nat n x).
+Parameter
+  inv_l : forall (n : nat) (x : List nat), ~ eqlong (Cons nat n x) (Nil nat).
+
+Fixpoint eqlongdec (x y : List nat) {struct x} :
+ eqlong x y \/ ~ eqlong x y :=
+  match x, y return (eqlong x y \/ ~ eqlong x y) with
+  | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil
+  | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x)
+  | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x)
+  | Cons a x as L1, Cons b y as L2 =>
+      match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with
+      | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h)
+      | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h)
       end
- end.
+  end.
 
 
 Type
- <[x,y:(List nat)](eqlong x y)\/~(eqlong x y)>Cases (Nil nat) (Nil nat) of
-      Nil Nil   => (or_introl ? ~(eqlong (Nil nat) (Nil nat))  eql_nil)
-
-   |  Nil ((Cons a x) as L) =>(or_intror (eqlong (Nil nat) L)  ? (inv_r a x))
-
-   |  ((Cons a x) as L) Nil => (or_intror (eqlong L (Nil nat)) ? (inv_l a x))
-
-   | ((Cons a x) as L1) ((Cons b y) as L2) =>  
-      <(eqlong L1 L2) \/~(eqlong L1 L2)>Cases (eqlongdec x y) of
-        (or_introl h) => (or_introl  ? ~(eqlong L1 L2) (eql_cons a b x y h))
-      | (or_intror h) => (or_intror (eqlong L1 L2) ? (nff a b x y h))   
+  match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with
+  | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil
+  | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x)
+  | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x)
+  | Cons a x as L1, Cons b y as L2 =>
+      match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with
+      | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h)
+      | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h)
       end
- end.
+  end.
 
diff --git a/test-suite/success/CaseAlias.v b/test-suite/success/CaseAlias.v
index b5f0e730..32d85779 100644
--- a/test-suite/success/CaseAlias.v
+++ b/test-suite/success/CaseAlias.v
@@ -1,21 +1,21 @@
 (* This has been a bug reported by Y. Bertot *)
 Inductive expr : Set :=
-   b: expr -> expr ->  expr
- | u: expr ->  expr
- | a: expr
- | var: nat ->  expr .
+  | b : expr -> expr -> expr
+  | u : expr -> expr
+  | a : expr
+  | var : nat -> expr.
 
-Fixpoint f [t : expr] : expr :=
- Cases t of
- | (b t1 t2) => (b (f t1) (f t2))
- | a => a
- | x => (b t a)
- end.
+Fixpoint f (t : expr) : expr :=
+  match t with
+  | b t1 t2 => b (f t1) (f t2)
+  | a => a
+  | x => b t a
+  end.
 
-Fixpoint f2 [t : expr] : expr :=
- Cases t of
- | (b t1 t2) => (b (f2 t1) (f2 t2))
- | a => a
- | x => (b x a)
- end.
+Fixpoint f2 (t : expr) : expr :=
+  match t with
+  | b t1 t2 => b (f2 t1) (f2 t2)
+  | a => a
+  | x => b x a
+  end.
 
diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v
index 6ccd669a..7c2b7c0b 100644
--- a/test-suite/success/Cases.v
+++ b/test-suite/success/Cases.v
@@ -2,89 +2,118 @@
 (* Pattern-matching when non inductive terms occur                          *)
 
 (* Dependent form of annotation *)
-Type <[n:nat]nat>Cases O eq of O x => O | (S x) y => x end.
-Type <[_,_:nat]nat>Cases O eq O of O x y => O | (S x) y z => x end.
+Type match 0 as n, eq return nat with
+     | O, x => 0
+     | S x, y => x
+     end.
+Type match 0, eq, 0 return nat with
+     | O, x, y => 0
+     | S x, y, z => x
+     end.
 
 (* Non dependent form of annotation *)
-Type <nat>Cases O eq of O x => O | (S x) y => x end.
+Type match 0, eq return nat with
+     | O, x => 0
+     | S x, y => x
+     end.
 
 (* Combining dependencies and non inductive arguments *)
-Type [A:Set][a:A][H:O=O]<[x][H]H==H>Cases H a of _ _ => (refl_eqT ? H) end.
+Type
+  (fun (A : Set) (a : A) (H : 0 = 0) =>
+   match H in (_ = x), a return (H = H) with
+   | _, _ => refl_equal H
+   end).
 
 (* Interaction with coercions *)
 Parameter bool2nat : bool -> nat.
 Coercion bool2nat : bool >-> nat.
-Check [x](Cases x of O => true | (S _) => O end :: nat).
+Check (fun x => match x with
+                | O => true
+                | S _ => 0
+                end:nat).
 
 (****************************************************************************)
 (* All remaining examples come from Cristina Cornes' V6 TESTS/MultCases.v   *)
 
-Inductive IFExpr : Set := 
-          Var  : nat -> IFExpr
-        | Tr   : IFExpr
-        | Fa   : IFExpr
-        | IfE   : IFExpr -> IFExpr -> IFExpr -> IFExpr.
+Inductive IFExpr : Set :=
+  | Var : nat -> IFExpr
+  | Tr : IFExpr
+  | Fa : IFExpr
+  | IfE : IFExpr -> IFExpr -> IFExpr -> IFExpr.
 
-Inductive List [A:Set] :Set := 
- Nil:(List A) | Cons:A->(List A)->(List A).
+Inductive List (A : Set) : Set :=
+  | Nil : List A
+  | Cons : A -> List A -> List A.
 
-Inductive listn : nat-> Set := 
-  niln : (listn O) 
-| consn : (n:nat)nat->(listn n) -> (listn (S n)).
+Inductive listn : nat -> Set :=
+  | niln : listn 0
+  | consn : forall n : nat, nat -> listn n -> listn (S n).
 
-Inductive Listn [A:Set] : nat-> Set := 
-  Niln : (Listn A O) 
-| Consn : (n:nat)nat->(Listn A n) -> (Listn A (S n)).
+Inductive Listn (A : Set) : nat -> Set :=
+  | Niln : Listn A 0
+  | Consn : forall n : nat, nat -> Listn A n -> Listn A (S n).
 
-Inductive Le : nat->nat->Set :=
-  LeO: (n:nat)(Le O n) 
-| LeS: (n,m:nat)(Le n m) -> (Le (S n) (S m)).
+Inductive Le : nat -> nat -> Set :=
+  | LeO : forall n : nat, Le 0 n
+  | LeS : forall n m : nat, Le n m -> Le (S n) (S m).
 
-Inductive LE [n:nat] : nat->Set := 
-    LE_n : (LE n n) | LE_S : (m:nat)(LE n m)->(LE n (S m)).
+Inductive LE (n : nat) : nat -> Set :=
+  | LE_n : LE n n
+  | LE_S : forall m : nat, LE n m -> LE n (S m).
 
-Require Bool.
+Require Import Bool.
 
 
 
-Inductive PropForm : Set := 
-          Fvar : nat -> PropForm
-        | Or   : PropForm -> PropForm -> PropForm .
+Inductive PropForm : Set :=
+  | Fvar : nat -> PropForm
+  | Or : PropForm -> PropForm -> PropForm.
 
 Section testIFExpr.
-Definition  Assign:= nat->bool.
+Definition Assign := nat -> bool.
 Parameter Prop_sem : Assign -> PropForm -> bool.
 
-Type [A:Assign][F:PropForm] 
-    <bool>Cases F of
-           (Fvar n)   => (A n)
-         | (Or F G)   => (orb (Prop_sem A F) (Prop_sem A G))
-    end.
-
-Type [A:Assign][H:PropForm] 
-    <bool>Cases H of
-           (Fvar n)   => (A n)
-         | (Or F G)   => (orb (Prop_sem A F) (Prop_sem A G))
-    end.
+Type
+  (fun (A : Assign) (F : PropForm) =>
+   match F return bool with
+   | Fvar n => A n
+   | Or F G => Prop_sem A F || Prop_sem A G
+   end).
+
+Type
+  (fun (A : Assign) (H : PropForm) =>
+   match H return bool with
+   | Fvar n => A n
+   | Or F G => Prop_sem A F || Prop_sem A G
+   end).
 End testIFExpr.
 
 
 
-Type [x:nat]<nat>Cases x of O => O | x => x end.
+Type (fun x : nat => match x return nat with
+                     | O => 0
+                     | x => x
+                     end).
 
 Section testlist.
-Parameter A:Set.
-Inductive list : Set := nil : list | cons : A->list->list.
-Parameter inf: A->A->Prop.
+Parameter A : Set.
+Inductive list : Set :=
+  | nil : list
+  | cons : A -> list -> list.
+Parameter inf : A -> A -> Prop.
 
 
-Definition list_Lowert2 :=
-   [a:A][l:list](<Prop>Cases l of nil => True 
-                               | (cons b l) =>(inf a b) end).
+Definition list_Lowert2 (a : A) (l : list) :=
+  match l return Prop with
+  | nil => True
+  | cons b l => inf a b
+  end.
 
-Definition titi :=
-   [a:A][l:list](<list>Cases l of nil => l
-                               | (cons b l) => l end).
+Definition titi (a : A) (l : list) :=
+  match l return list with
+  | nil => l
+  | cons b l => l
+  end.
 Reset list.
 End testlist.
 
@@ -93,444 +122,490 @@ End testlist.
 (* ------------------- *)
 
 
-Type  <nat>Cases O of O => O | _ => O end.
-
-Type <nat>Cases O of
-               (O as b) => b 
-             | (S O)  => O
-             | (S (S x)) => x end.
+Type match 0 return nat with
+     | O => 0
+     | _ => 0
+     end.
 
-Type Cases O of
-               (O as b) => b 
-             | (S O)  => O
-             | (S (S x)) => x end.
+Type match 0 return nat with
+     | O as b => b
+     | S O => 0
+     | S (S x) => x
+     end.
 
+Type match 0 with
+     | O as b => b
+     | S O => 0
+     | S (S x) => x
+     end.
 
-Type [x:nat]<nat>Cases x of
-                          (O as b) => b 
-                        | (S x)  => x end.
 
-Type              [x:nat]Cases x of
-                          (O as b) => b 
-                        | (S x)  => x end.
+Type (fun x : nat => match x return nat with
+                     | O as b => b
+                     | S x => x
+                     end).
 
-Type <nat>Cases O of 
-                          (O as b) => b 
-                        | (S x)  => x end.
+Type (fun x : nat => match x with
+                     | O as b => b
+                     | S x => x
+                     end).
 
-Type <nat>Cases O of 
-                          x  => x 
-                       end.
+Type match 0 return nat with
+     | O as b => b
+     | S x => x
+     end.
 
-Type  Cases O of 
-                          x  => x 
-                       end.
+Type match 0 return nat with
+     | x => x
+     end.
 
-Type <nat>Cases O of
-                              O => O
-                         | ((S x) as b) => b
-                        end.
+Type match 0 with
+     | x => x
+     end.
 
-Type [x:nat]<nat>Cases x of
-                              O => O
-                         | ((S x) as b) => b
-                        end.
+Type match 0 return nat with
+     | O => 0
+     | S x as b => b
+     end.
 
-Type [x:nat] Cases x of
-                              O => O
-                         | ((S x) as b) => b
-                        end.
+Type (fun x : nat => match x return nat with
+                     | O => 0
+                     | S x as b => b
+                     end).
 
+Type (fun x : nat => match x with
+                     | O => 0
+                     | S x as b => b
+                     end).
 
-Type <nat>Cases O of
-         O => O
-    | (S x) => O
-      end.
 
+Type match 0 return nat with
+     | O => 0
+     | S x => 0
+     end.
 
-Type <nat*nat>Cases O of
-                              O => (O,O)
-                         | (S x) =>  (x,O)
-                        end.
 
-Type                    Cases O of
-                              O => (O,O)
-                         | (S x) =>  (x,O)
-                        end.
+Type match 0 return (nat * nat) with
+     | O => (0, 0)
+     | S x => (x, 0)
+     end.
 
-Type <nat->nat>Cases O of
-                              O => [n:nat]O
-                         | (S x) =>  [n:nat]O
-                        end.
+Type match 0 with
+     | O => (0, 0)
+     | S x => (x, 0)
+     end.
 
-Type                   Cases O of
-                              O => [n:nat]O
-                         | (S x) =>  [n:nat]O
-                        end.
+Type
+  match 0 return (nat -> nat) with
+  | O => fun n : nat => 0
+  | S x => fun n : nat => 0
+  end.
 
+Type match 0 with
+     | O => fun n : nat => 0
+     | S x => fun n : nat => 0
+     end.
 
-Type <nat->nat>Cases O of
-                              O => [n:nat]O
-                         | (S x) =>  [n:nat](plus x n)
-                        end.
 
-Type                    Cases O of
-                              O => [n:nat]O
-                         | (S x) =>  [n:nat](plus x n)
-                        end.
+Type
+  match 0 return (nat -> nat) with
+  | O => fun n : nat => 0
+  | S x => fun n : nat => x + n
+  end.
 
+Type match 0 with
+     | O => fun n : nat => 0
+     | S x => fun n : nat => x + n
+     end.
 
-Type <nat>Cases O of
-                              O => O
-                         | ((S x) as b) => (plus b x)
-                         end.
 
-Type <nat>Cases O of
-              O => O
-          | ((S (x as a)) as b) => (plus b a)
-                         end.
-Type  Cases O of
-              O => O
-          | ((S (x as a)) as b) => (plus b a)
-                         end.
+Type match 0 return nat with
+     | O => 0
+     | S x as b => b + x
+     end.
 
+Type match 0 return nat with
+     | O => 0
+     | S a as b => b + a
+     end.
+Type match 0 with
+     | O => 0
+     | S a as b => b + a
+     end.
 
-Type  Cases O of
-                              O => O
-                         |  _  => O
-                        end.
 
-Type <nat>Cases O of
-                  O => O
-               |  x => x
-                 end.
+Type match 0 with
+     | O => 0
+     | _ => 0
+     end.
 
-Type <nat>Cases O (S O) of
-                             x  y => (plus x y)
-                        end.
-
-Type      Cases O (S O) of
-                             x  y => (plus x y)
-                        end.
- 
-Type <nat>Cases O (S O) of
-                             O  y => y
-                          | (S x) y => (plus x y) 
-                        end.
+Type match 0 return nat with
+     | O => 0
+     | x => x
+     end.
 
-Type              Cases O (S O) of
-                             O  y => y
-                          | (S x) y => (plus x y) 
-                        end.
+Type match 0, 1 return nat with
+     | x, y => x + y
+     end.
 
+Type match 0, 1 with
+     | x, y => x + y
+     end.
+ 
+Type match 0, 1 return nat with
+     | O, y => y
+     | S x, y => x + y
+     end.
 
-Type    <nat>Cases O (S O) of
-                      O  x =>  x
-             |      (S y) O =>  y
-             |        x y  => (plus x y)
-           end.
+Type match 0, 1 with
+     | O, y => y
+     | S x, y => x + y
+     end.
 
 
+Type match 0, 1 return nat with
+     | O, x => x
+     | S y, O => y
+     | x, y => x + y
+     end.
 
 
-Type        Cases O (S O) of
-                      O  x => (plus x O)
-             |      (S y) O =>  (plus y O)
-             |        x y  => (plus x y)
-           end.
 
-Type 
-          <nat>Cases O (S O) of
-                      O  x => (plus x O)
-             |      (S y) O =>  (plus y O)
-             |        x y  => (plus x y)
-           end.
 
+Type match 0, 1 with
+     | O, x => x + 0
+     | S y, O => y + 0
+     | x, y => x + y
+     end.
 
-Type 
-          <nat>Cases O (S O) of
-                      O  x =>  x 
-             | ((S x) as b) (S y) => (plus (plus b x) y)
-             |    x y  => (plus x y)
-           end.
+Type
+  match 0, 1 return nat with
+  | O, x => x + 0
+  | S y, O => y + 0
+  | x, y => x + y
+  end.
 
 
-Type         Cases O (S O) of
-                    O  x =>  x 
-             | ((S x) as b) (S y) => (plus (plus b x) y)
-             |    x y  => (plus x y)
-           end.
+Type
+  match 0, 1 return nat with
+  | O, x => x
+  | S x as b, S y => b + x + y
+  | x, y => x + y
+  end.
 
 
-Type [l:(List nat)]<(List nat)>Cases l of 
-                         Nil => (Nil nat)
-                      | (Cons  a l) => l
-                      end.
+Type
+  match 0, 1 with
+  | O, x => x
+  | S x as b, S y => b + x + y
+  | x, y => x + y
+  end.
 
-Type [l:(List nat)]  Cases l of 
-                         Nil => (Nil nat)
-                      | (Cons  a l) => l
-                      end.
 
-Type <nat>Cases (Nil nat) of 
-                         Nil =>O
-                      | (Cons  a l) => (S a)
-                      end.
-Type Cases (Nil nat) of 
-                         Nil =>O
-                      | (Cons  a l) => (S a)
-                      end.
+Type
+  (fun l : List nat =>
+   match l return (List nat) with
+   | Nil => Nil nat
+   | Cons a l => l
+   end).
+
+Type (fun l : List nat => match l with
+                          | Nil => Nil nat
+                          | Cons a l => l
+                          end).
+
+Type match Nil nat return nat with
+     | Nil => 0
+     | Cons a l => S a
+     end.
+Type match Nil nat with
+     | Nil => 0
+     | Cons a l => S a
+     end.
 
-Type <(List nat)>Cases (Nil nat) of 
-                        (Cons  a l) => l
-                       | x => x
-                      end.
+Type match Nil nat return (List nat) with
+     | Cons a l => l
+     | x => x
+     end.
 
-Type              Cases (Nil nat) of 
-                        (Cons  a l) => l
-                       | x => x
-                      end.
+Type match Nil nat with
+     | Cons a l => l
+     | x => x
+     end.
 
-Type <(List nat)>Cases (Nil nat) of 
-                         Nil => (Nil nat)
-                      | (Cons  a l) => l
-                      end.
+Type
+  match Nil nat return (List nat) with
+  | Nil => Nil nat
+  | Cons a l => l
+  end.
 
-Type             Cases (Nil nat) of 
-                         Nil => (Nil nat)
-                      | (Cons  a l) => l
-                      end.
+Type match Nil nat with
+     | Nil => Nil nat
+     | Cons a l => l
+     end.
 
 
-Type 
-   <nat>Cases O of 
-      O => O
-    | (S x) => <nat>Cases (Nil nat) of 
-                         Nil => x
-                      | (Cons  a l) => (plus x a)
-                      end
-     end.
+Type
+  match 0 return nat with
+  | O => 0
+  | S x => match Nil nat return nat with
+           | Nil => x
+           | Cons a l => x + a
+           end
+  end.
 
-Type 
-   Cases O of 
-      O => O
-    | (S x) => Cases (Nil nat) of 
-                         Nil => x
-                      | (Cons  a l) => (plus x a)
-                      end
-     end.
+Type
+  match 0 with
+  | O => 0
+  | S x => match Nil nat with
+           | Nil => x
+           | Cons a l => x + a
+           end
+  end.
 
-Type 
- [y:nat]Cases y of 
-      O => O
-    | (S x) => Cases (Nil nat) of 
-                         Nil => x
-                      | (Cons  a l) => (plus x a)
-                      end
-     end.
+Type
+  (fun y : nat =>
+   match y with
+   | O => 0
+   | S x => match Nil nat with
+            | Nil => x
+            | Cons a l => x + a
+            end
+   end).
 
 
-Type 
-   <nat>Cases O (Nil nat) of 
-      O       x => O
-    | (S x)  Nil => x
-    | (S x) (Cons  a l) => (plus x a)      
-     end.
+Type
+  match 0, Nil nat return nat with
+  | O, x => 0
+  | S x, Nil => x
+  | S x, Cons a l => x + a
+  end.
 
 
 
-Type [n:nat][l:(listn n)]<[_:nat]nat>Cases l of 
-                         niln => O
-                      |    x  => O
-                      end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l return nat with
+   | niln => 0
+   | x => 0
+   end).
 
-Type [n:nat][l:(listn n)]
-                     Cases l of 
-                         niln => O
-                      |    x  => O
-                      end.
+Type (fun (n : nat) (l : listn n) => match l with
+                                     | niln => 0
+                                     | x => 0
+                                     end).
 
 
-Type <[_:nat]nat>Cases niln of 
-                         niln => O
-                      |    x  => O
-                      end.
+Type match niln return nat with
+     | niln => 0
+     | x => 0
+     end.
 
-Type               Cases niln of 
-                         niln => O
-                      |    x  => O
-                      end.
+Type match niln with
+     | niln => 0
+     | x => 0
+     end.
 
 
-Type <[_:nat]nat>Cases niln of 
-                         niln => O
-                      |  (consn n a l)  => a
-                      end.
-Type Cases niln of niln => O
-               |  (consn n a l)  => a
+Type match niln return nat with
+     | niln => 0
+     | consn n a l => a
+     end.
+Type match niln with
+     | niln => 0
+     | consn n a l => a
      end.
 
 
-Type  <[n:nat][_:(listn n)]nat>Cases niln of 
-                         (consn m _ niln) => m
-                       | _ => (S O) end.
+Type
+  match niln in (listn n) return nat with
+  | consn m _ niln => m
+  | _ => 1
+  end.
 
 
 
-Type [n:nat][x:nat][l:(listn n)]<[_:nat]nat>Cases x l of 
-                         O niln => O
-                      |  y  x  => O
-                      end.
+Type
+  (fun (n x : nat) (l : listn n) =>
+   match x, l return nat with
+   | O, niln => 0
+   | y, x => 0
+   end).
+
+Type match 0, niln return nat with
+     | O, niln => 0
+     | y, x => 0
+     end.
 
-Type <[_:nat]nat>Cases O niln of 
-                         O niln => O
-                      |  y  x  => O
-                      end.
 
+Type match niln, 0 return nat with
+     | niln, O => 0
+     | y, x => 0
+     end.
 
-Type <[_:nat]nat>Cases niln O of 
-                         niln O => O
-                      |  y  x  => O
-                      end.
+Type match niln, 0 with
+     | niln, O => 0
+     | y, x => 0
+     end.
 
-Type               Cases niln O of 
-                         niln O => O
-                      |  y  x  => O
-                      end.
+Type match niln, niln return nat with
+     | niln, niln => 0
+     | x, y => 0
+     end.
 
-Type <[_:nat][_:nat]nat>Cases niln niln of 
-                         niln niln => O
-                      |    x  y  => O
-                      end.
+Type match niln, niln with
+     | niln, niln => 0
+     | x, y => 0
+     end.
 
-Type               Cases niln niln of 
-                         niln niln => O
-                      |    x  y  => O
-                      end.
+Type
+  match niln, niln, niln return nat with
+  | niln, niln, niln => 0
+  | x, y, z => 0
+  end.
 
-Type <[_,_,_:nat]nat>Cases niln niln niln of 
-                         niln niln niln => O
-                      |    x  y z  => O
-                      end.
 
+Type match niln, niln, niln with
+     | niln, niln, niln => 0
+     | x, y, z => 0
+     end.
 
-Type                 Cases niln niln niln of 
-                         niln niln niln => O
-                      |    x  y z  => O
-                      end.
 
 
+Type match niln return nat with
+     | niln => 0
+     | consn n a l => 0
+     end.
 
-Type <[_:nat]nat>Cases (niln) of 
-                         niln  => O
-                      | (consn n a l) => O
-                      end.
+Type match niln with
+     | niln => 0
+     | consn n a l => 0
+     end.
 
-Type         Cases (niln) of 
-                         niln  => O
-                      | (consn n a l) => O
-                      end.
 
+Type
+  match niln, niln return nat with
+  | niln, niln => 0
+  | niln, consn n a l => n
+  | consn n a l, x => a
+  end.
 
-Type <[_:nat][_:nat]nat>Cases niln niln of 
-                         niln niln => O
-                      |  niln (consn n a l) => n
-                      |  (consn n a l)  x  => a
-                      end.
 
+Type
+  match niln, niln with
+  | niln, niln => 0
+  | niln, consn n a l => n
+  | consn n a l, x => a
+  end.
 
-Type                Cases niln niln of 
-                         niln niln => O
-                      |  niln (consn n a l) => n
-                      |  (consn n a l)  x  => a
-                      end.
 
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l return nat with
+   | niln => 0
+   | x => 0
+   end).
 
-Type [n:nat][l:(listn n)]<[_:nat]nat>Cases l of 
-                         niln => O
-                      |    x  => O
-                      end.
+Type
+  (fun (c : nat) (s : bool) =>
+   match c, s return nat with
+   | O, _ => 0
+   | _, _ => c
+   end).
 
-Type [c:nat;s:bool]
-  <[_:nat;_:bool]nat>Cases c s of
-        | O _ => O
-        | _ _ => c
-        end.
-
-Type [c:nat;s:bool]
-  <[_:nat;_:bool]nat>Cases c s of
-        | O _ => O
-        | (S _) _ => c
-        end.
+Type
+  (fun (c : nat) (s : bool) =>
+   match c, s return nat with
+   | O, _ => 0
+   | S _, _ => c
+   end).
          
 
 (* Rows of pattern variables: some tricky cases *)
-Axiom P:nat->Prop; f:(n:nat)(P n).
+Axioms (P : nat -> Prop) (f : forall n : nat, P n).
 
-Type [i:nat]
-  <[_:bool;n:nat](P n)>Cases true i of
-        | true k => (f k)
-        | _    k => (f k)
-        end.
+Type
+  (fun i : nat =>
+   match true, i as n return (P n) with
+   | true, k => f k
+   | _, k => f k
+   end).
 
-Type [i:nat]
-  <[n:nat;_:bool](P n)>Cases i true of
-        | k true => (f k)
-        | k _ => (f k)
-        end.
+Type
+  (fun i : nat =>
+   match i as n, true return (P n) with
+   | k, true => f k
+   | k, _ => f k
+   end).
 
 (* Nested Cases: the SYNTH of the Cases on n used to make Multcase believe
  * it has to synthtize the predicate on O (which he can't)
  *)
-Type <[n]Cases n of O => bool | (S _) => nat end>Cases O of
-    O => true
-  | (S _) => O
+Type
+  match 0 as n return match n with
+                      | O => bool
+                      | S _ => nat
+                      end with
+  | O => true
+  | S _ => 0
   end.
 
-Type [n:nat][l:(listn n)]Cases l of 
-                         niln => O
-                      |    x  => O
-                      end.
+Type (fun (n : nat) (l : listn n) => match l with
+                                     | niln => 0
+                                     | x => 0
+                                     end).
 
-Type [n:nat][l:(listn n)]<[_:nat]nat>Cases l of 
-                         niln  => O
-                      | (consn n a niln) => O
-                      | (consn n a (consn m b l)) => (plus n m)
-                      end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l return nat with
+   | niln => 0
+   | consn n a niln => 0
+   | consn n a (consn m b l) => n + m
+   end).
 
 
-Type [n:nat][l:(listn n)]Cases l of 
-                         niln  => O
-                      | (consn n a niln) => O
-                      | (consn n a (consn m b l)) => (plus n m)
-                      end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l with
+   | niln => 0
+   | consn n a niln => 0
+   | consn n a (consn m b l) => n + m
+   end).
 
 
 
-Type [n:nat][l:(listn n)]<[_:nat]nat>Cases l of 
-                         niln  => O
-                      | (consn n a niln) => O
-                      | (consn n a (consn m b l)) => (plus n m)
-                      end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l return nat with
+   | niln => 0
+   | consn n a niln => 0
+   | consn n a (consn m b l) => n + m
+   end).
 
-Type [n:nat][l:(listn n)]Cases l of 
-                         niln  => O
-                      | (consn n a niln) => O
-                      | (consn n a (consn m b l)) => (plus n m)
-                      end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l with
+   | niln => 0
+   | consn n a niln => 0
+   | consn n a (consn m b l) => n + m
+   end).
 
 
-Type [A:Set][n:nat][l:(Listn A n)]<[_:nat]nat>Cases l of 
-                         Niln   => O
-                      | (Consn n a Niln) => O
-                      | (Consn n a (Consn m b l)) => (plus n m)
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l return nat with
+   | Niln => 0
+   | Consn n a Niln => 0
+   | Consn n a (Consn m b l) => n + m
+   end).
 
-Type [A:Set][n:nat][l:(Listn A n)]Cases l of 
-                         Niln   => O
-                      | (Consn n a Niln) => O
-                      | (Consn n a (Consn m b l)) => (plus n m)
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l with
+   | Niln => 0
+   | Consn n a Niln => 0
+   | Consn n a (Consn m b l) => n + m
+   end).
 
 (*
 Type [A:Set][n:nat][l:(Listn A n)]
@@ -557,401 +632,441 @@ Type [A:Set][n:nat][l:(Listn A n)]
 **********)
 
 (* To test tratement of as-patterns in depth *)
-Type [A:Set] [l:(List A)]
-                    Cases l of 
-                         (Nil  as b) => (Nil A)
-                      | ((Cons a Nil)  as L) => L
-                      | ((Cons a (Cons b m)) as L) => L
-                      end.
+Type
+  (fun (A : Set) (l : List A) =>
+   match l with
+   | Nil as b => Nil A
+   | Cons a Nil as L => L
+   | Cons a (Cons b m) as L => L
+   end).
 
 
-Type [n:nat][l:(listn n)]
-             <[_:nat](listn n)>Cases l of 
-                         niln  => l 
-                      | (consn n a c) => l
-                      end.
-Type [n:nat][l:(listn n)]
-                      Cases l of 
-                         niln  => l 
-                      | (consn n a c) => l
-                      end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l return (listn n) with
+   | niln => l
+   | consn n a c => l
+   end).
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l with
+   | niln => l
+   | consn n a c => l
+   end).
 
 
-Type [n:nat][l:(listn n)]
-             <[_:nat](listn n)>Cases l of 
-                         (niln as b) => l 
-                      |  _  => l
-                      end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l return (listn n) with
+   | niln as b => l
+   | _ => l
+   end).
 
 
-Type [n:nat][l:(listn n)]
-                     Cases l of 
-                         (niln as b) => l 
-                      |  _  => l
-                      end.
+Type
+  (fun (n : nat) (l : listn n) => match l with
+                                  | niln as b => l
+                                  | _ => l
+                                  end).
 
-Type [n:nat][l:(listn n)]
-             <[_:nat](listn n)>Cases l of 
-                         (niln as b) => l
-                      |  x  => l
-                      end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l return (listn n) with
+   | niln as b => l
+   | x => l
+   end).
 
 
-Type [A:Set][n:nat][l:(Listn A n)]
-                       Cases l of 
-                         (Niln  as b) => l 
-                      |   _ => l
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l with
+   | Niln as b => l
+   | _ => l
+   end).
 
-Type [A:Set][n:nat][l:(Listn A n)]
-             <[_:nat](Listn A n)>Cases l of 
-                         Niln  => l 
-                      | (Consn  n a Niln) => l
-                      | (Consn  n a (Consn  m b c)) => l 
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l return (Listn A n) with
+   | Niln => l
+   | Consn n a Niln => l
+   | Consn n a (Consn m b c) => l
+   end).
 
-Type [A:Set][n:nat][l:(Listn A n)]
-                      Cases l of 
-                         Niln  => l 
-                      | (Consn  n a Niln) => l
-                      | (Consn  n a (Consn  m b c)) => l 
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l with
+   | Niln => l
+   | Consn n a Niln => l
+   | Consn n a (Consn m b c) => l
+   end).
 
-Type [A:Set][n:nat][l:(Listn A n)]
-             <[_:nat](Listn A n)>Cases l of 
-                         (Niln as b) => l 
-                      | (Consn  n a (Niln as b)) => l
-                      | (Consn  n a (Consn  m b _)) => l 
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l return (Listn A n) with
+   | Niln as b => l
+   | Consn n a (Niln as b) => l
+   | Consn n a (Consn m b _) => l
+   end).
 
-Type [A:Set][n:nat][l:(Listn A n)]
-                     Cases l of 
-                         (Niln as b) => l 
-                      | (Consn  n a (Niln as b)) => l
-                      | (Consn  n a (Consn  m b _)) => l 
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l with
+   | Niln as b => l
+   | Consn n a (Niln as b) => l
+   | Consn n a (Consn m b _) => l
+   end).
 
 
-Type <[_:nat]nat>Cases (niln) of 
-                         niln  => O
-                      | (consn n a niln) => O
-                      | (consn n a (consn m b l)) => (plus n m)
-                      end.
+Type
+  match niln return nat with
+  | niln => 0
+  | consn n a niln => 0
+  | consn n a (consn m b l) => n + m
+  end.
 
 
-Type               Cases (niln) of 
-                         niln  => O
-                      | (consn n a niln) => O
-                      | (consn n a (consn m b l)) => (plus n m)
-                      end.
+Type
+  match niln with
+  | niln => 0
+  | consn n a niln => 0
+  | consn n a (consn m b l) => n + m
+  end.
 
-Type <[_,_:nat]nat>Cases (LeO O) of 
-                         (LeO x)  => x
-                      | (LeS n m h) => (plus n m) 
-                      end.
+Type match LeO 0 return nat with
+     | LeO x => x
+     | LeS n m h => n + m
+     end.
 
 
-Type               Cases (LeO O) of 
-                         (LeO x)  => x
-                      | (LeS n m h) => (plus n m) 
-                      end.
+Type match LeO 0 with
+     | LeO x => x
+     | LeS n m h => n + m
+     end.
 
-Type [n:nat][l:(Listn nat n)]
-                     <[_:nat]nat>Cases l of 
-                         Niln  => O
-                      | (Consn n a l) => O
-                      end.
+Type
+  (fun (n : nat) (l : Listn nat n) =>
+   match l return nat with
+   | Niln => 0
+   | Consn n a l => 0
+   end).
 
 
-Type [n:nat][l:(Listn nat n)]
-                      Cases l of 
-                         Niln  => O
-                      | (Consn n a l) => O
-                      end.
+Type
+  (fun (n : nat) (l : Listn nat n) =>
+   match l with
+   | Niln => 0
+   | Consn n a l => 0
+   end).
 
 
-Type                Cases (Niln nat) of 
-                         Niln  => O
-                      | (Consn n a l) => O
-                      end.
+Type match Niln nat with
+     | Niln => 0
+     | Consn n a l => 0
+     end.
 
-Type <[_:nat]nat>Cases (LE_n O) of 
-                         LE_n   => O 
-                      | (LE_S m h) => O
-                      end.
+Type match LE_n 0 return nat with
+     | LE_n => 0
+     | LE_S m h => 0
+     end.
 
 
-Type               Cases (LE_n O) of 
-                         LE_n   => O 
-                      | (LE_S m h) => O
-                      end.
+Type match LE_n 0 with
+     | LE_n => 0
+     | LE_S m h => 0
+     end.
 
 
 
-Type               Cases (LE_n O) of 
-                         LE_n   => O 
-                      | (LE_S m h) => O
-                      end.
+Type match LE_n 0 with
+     | LE_n => 0
+     | LE_S m h => 0
+     end.
 
 
 
-Type <[_:nat]nat>Cases (niln ) of 
-                         niln   => O
-                      | (consn  n a niln) => n
-                      | (consn  n a (consn  m b l)) => (plus n m)
-                      end.
+Type
+  match niln return nat with
+  | niln => 0
+  | consn n a niln => n
+  | consn n a (consn m b l) => n + m
+  end.
 
-Type               Cases (niln ) of 
-                         niln   => O
-                      | (consn  n a niln) => n
-                      | (consn  n a (consn  m b l)) => (plus n m)
-                      end.
+Type
+  match niln with
+  | niln => 0
+  | consn n a niln => n
+  | consn n a (consn m b l) => n + m
+  end.
 
 
-Type <[_:nat]nat>Cases (Niln nat) of 
-                         Niln  => O
-                      | (Consn  n a Niln) => n
-                      | (Consn   n a (Consn  m b l)) => (plus n m)
-                      end.
+Type
+  match Niln nat return nat with
+  | Niln => 0
+  | Consn n a Niln => n
+  | Consn n a (Consn m b l) => n + m
+  end.
 
-Type                Cases (Niln nat) of 
-                         Niln  => O
-                      | (Consn  n a Niln) => n
-                      | (Consn   n a (Consn  m b l)) => (plus n m)
-                      end.
+Type
+  match Niln nat with
+  | Niln => 0
+  | Consn n a Niln => n
+  | Consn n a (Consn m b l) => n + m
+  end.
 
 
-Type <[_,_:nat]nat>Cases (LeO O) of 
-                         (LeO x)  => x
-                      | (LeS n m (LeO x)) => (plus x m)
-                      | (LeS n m (LeS x y h)) => (plus n x)
-                      end.
+Type
+  match LeO 0 return nat with
+  | LeO x => x
+  | LeS n m (LeO x) => x + m
+  | LeS n m (LeS x y h) => n + x
+  end.
 
 
-Type                 Cases (LeO O) of 
-                         (LeO x)  => x
-                      | (LeS n m (LeO x)) => (plus x m)
-                      | (LeS n m (LeS x y h)) => (plus n x)
-                      end.
+Type
+  match LeO 0 with
+  | LeO x => x
+  | LeS n m (LeO x) => x + m
+  | LeS n m (LeS x y h) => n + x
+  end.
 
 
-Type <[_,_:nat]nat>Cases (LeO O) of 
-                         (LeO x)  => x
-                      | (LeS n m (LeO x)) => (plus x m)
-                      | (LeS n m (LeS x y h)) => m
-                      end.
+Type
+  match LeO 0 return nat with
+  | LeO x => x
+  | LeS n m (LeO x) => x + m
+  | LeS n m (LeS x y h) => m
+  end.
 
-Type                Cases (LeO O) of 
-                         (LeO x)  => x
-                      | (LeS n m (LeO x)) => (plus x m)
-                      | (LeS n m (LeS x y h)) => m
-                      end.
+Type
+  match LeO 0 with
+  | LeO x => x
+  | LeS n m (LeO x) => x + m
+  | LeS n m (LeS x y h) => m
+  end.
 
 
-Type [n,m:nat][h:(Le n m)]
-                    <[_,_:nat]nat>Cases h of 
-                         (LeO x)  => x
-                      | x => O
-                      end.
+Type
+  (fun (n m : nat) (h : Le n m) =>
+   match h return nat with
+   | LeO x => x
+   | x => 0
+   end).
 
-Type [n,m:nat][h:(Le n m)]
-                     Cases h of 
-                         (LeO x)  => x
-                      | x => O
-                      end.
+Type (fun (n m : nat) (h : Le n m) => match h with
+                                      | LeO x => x
+                                      | x => 0
+                                      end).
 
 
-Type [n,m:nat][h:(Le n m)]
-                    <[_,_:nat]nat>Cases h of 
-                        (LeS n m h)  => n
-                      | x => O
-                      end.
+Type
+  (fun (n m : nat) (h : Le n m) =>
+   match h return nat with
+   | LeS n m h => n
+   | x => 0
+   end).
 
 
-Type [n,m:nat][h:(Le n m)]
-                      Cases h of 
-                        (LeS n m h)  => n
-                      | x => O
-                      end.
+Type
+  (fun (n m : nat) (h : Le n m) => match h with
+                                   | LeS n m h => n
+                                   | x => 0
+                                   end).
 
 
-Type    [n,m:nat][h:(Le n m)]
-  <[_,_:nat]nat*nat>Cases h of
-                    (LeO n) => (O,n)
-                   |(LeS n m _) => ((S n),(S m))
-                   end.
+Type
+  (fun (n m : nat) (h : Le n m) =>
+   match h return (nat * nat) with
+   | LeO n => (0, n)
+   | LeS n m _ => (S n, S m)
+   end).
 
 
-Type    [n,m:nat][h:(Le n m)]
-                  Cases h of
-                    (LeO n) => (O,n)
-                   |(LeS n m _) => ((S n),(S m))
-                   end.
+Type
+  (fun (n m : nat) (h : Le n m) =>
+   match h with
+   | LeO n => (0, n)
+   | LeS n m _ => (S n, S m)
+   end).
 
 
-Fixpoint F [n,m:nat; h:(Le n m)] : (Le n (S m)) :=
- <[n,m:nat](Le n (S m))>Cases h  of 
-                (LeO m') => (LeO (S m'))
-              | (LeS n' m' h') => (LeS n' (S m') (F n' m' h'))
-        end.
+Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) :=
+  match h in (Le n m) return (Le n (S m)) with
+  | LeO m' => LeO (S m')
+  | LeS n' m' h' => LeS n' (S m') (F n' m' h')
+  end.
 
 Reset F.
 
-Fixpoint F [n,m:nat; h:(Le n m)] :(Le n (S m)) :=
-  <[n,m:nat](Le n (S m))>Cases h of
-                           (LeS n m h) => (LeS n (S m) (F n m h))
-                         | (LeO m) => (LeO (S m)) 
-                        end.
+Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) :=
+  match h in (Le n m) return (Le n (S m)) with
+  | LeS n m h => LeS n (S m) (F n m h)
+  | LeO m => LeO (S m)
+  end.
 
 (* Rend la longueur de la liste *)
-Definition length1:= [n:nat] [l:(listn n)]
-        <[_:nat]nat>Cases l of 
-                     (consn n _ (consn m _ _)) => (S (S m))
-                    |(consn n _ _) => (S O)
-                    | _ => O
-             end.
+Definition length1 (n : nat) (l : listn n) :=
+  match l return nat with
+  | consn n _ (consn m _ _) => S (S m)
+  | consn n _ _ => 1
+  | _ => 0
+  end.
 
 Reset length1.
-Definition length1:= [n:nat] [l:(listn n)]
-                    Cases l of 
-                     (consn n _ (consn m _ _)) => (S (S m))
-                    |(consn n _ _) => (S O)
-                    | _ => O
-                    end.
+Definition length1 (n : nat) (l : listn n) :=
+  match l with
+  | consn n _ (consn m _ _) => S (S m)
+  | consn n _ _ => 1
+  | _ => 0
+  end.
 
 
-Definition length2:= [n:nat] [l:(listn n)]
-        <[_:nat]nat>Cases l of 
-                     (consn n _ (consn m _ _)) => (S (S m))
-                    |(consn n _ _) => (S n)
-                    | _ => O
-             end.
+Definition length2 (n : nat) (l : listn n) :=
+  match l return nat with
+  | consn n _ (consn m _ _) => S (S m)
+  | consn n _ _ => S n
+  | _ => 0
+  end.
 
 Reset length2.
 
-Definition length2:= [n:nat] [l:(listn n)]
-                   Cases l of 
-                     (consn n _ (consn m _ _)) => (S (S m))
-                    |(consn n _ _) => (S n)
-                    | _ => O
-                   end.
+Definition length2 (n : nat) (l : listn n) :=
+  match l with
+  | consn n _ (consn m _ _) => S (S m)
+  | consn n _ _ => S n
+  | _ => 0
+  end.
 
-Definition length3 :=
-[n:nat][l:(listn n)]
-        <[_:nat]nat>Cases l of 
-                     (consn n _ (consn m _ l)) => (S n)
-                    |(consn n _ _) => (S O)
-                    | _  => O
-                   end.
+Definition length3 (n : nat) (l : listn n) :=
+  match l return nat with
+  | consn n _ (consn m _ l) => S n
+  | consn n _ _ => 1
+  | _ => 0
+  end.
 
 
 Reset length3.
 
-Definition length3 :=
-[n:nat][l:(listn n)]
-                   Cases l of 
-                     (consn n _ (consn m _ l)) => (S n)
-                    |(consn n _ _) => (S O)
-                    | _  => O
-                   end.
+Definition length3 (n : nat) (l : listn n) :=
+  match l with
+  | consn n _ (consn m _ l) => S n
+  | consn n _ _ => 1
+  | _ => 0
+  end.
 
  
-Type <[_,_:nat]nat>Cases (LeO O) of 
-                        (LeS n m h)  =>(plus n m)
-                      | x => O
-                      end.
-Type              Cases (LeO O) of 
-                        (LeS n m h)  =>(plus n m)
-                      | x => O
-                      end.
+Type match LeO 0 return nat with
+     | LeS n m h => n + m
+     | x => 0
+     end.
+Type match LeO 0 with
+     | LeS n m h => n + m
+     | x => 0
+     end.
 
-Type [n,m:nat][h:(Le n m)]<[_,_:nat]nat>Cases h of 
-                         (LeO x)  => x
-                      | (LeS n m (LeO x)) => (plus x m)
-                      | (LeS n m (LeS x y h)) =>(plus n (plus m (plus x y)))
-                      end.
+Type
+  (fun (n m : nat) (h : Le n m) =>
+   match h return nat with
+   | LeO x => x
+   | LeS n m (LeO x) => x + m
+   | LeS n m (LeS x y h) => n + (m + (x + y))
+   end).
 
 
-Type [n,m:nat][h:(Le n m)]Cases h of 
-                         (LeO x)  => x
-                      | (LeS n m (LeO x)) => (plus x m)
-                      | (LeS n m (LeS x y h)) =>(plus n (plus m (plus x y)))
-                      end.
+Type
+  (fun (n m : nat) (h : Le n m) =>
+   match h with
+   | LeO x => x
+   | LeS n m (LeO x) => x + m
+   | LeS n m (LeS x y h) => n + (m + (x + y))
+   end).
 
-Type <[_,_:nat]nat>Cases (LeO O) of 
-                         (LeO x)  => x
-                      | (LeS n m (LeO x)) => (plus x m)
-                      | (LeS n m (LeS x y h)) =>(plus n (plus m (plus x y)))
-                      end.
+Type
+  match LeO 0 return nat with
+  | LeO x => x
+  | LeS n m (LeO x) => x + m
+  | LeS n m (LeS x y h) => n + (m + (x + y))
+  end.
 
-Type                 Cases (LeO O) of 
-                         (LeO x)  => x
-                      | (LeS n m (LeO x)) => (plus x m)
-                      | (LeS n m (LeS x y h)) =>(plus n (plus m (plus x y)))
-                      end.
+Type
+  match LeO 0 with
+  | LeO x => x
+  | LeS n m (LeO x) => x + m
+  | LeS n m (LeS x y h) => n + (m + (x + y))
+  end.
 
 
-Type <[_:nat]nat>Cases (LE_n O) of 
-                         LE_n   => O
-                      | (LE_S m LE_n) => (plus O m)
-                      | (LE_S m (LE_S y h)) => (plus O m)
-                      end.
+Type
+  match LE_n 0 return nat with
+  | LE_n => 0
+  | LE_S m LE_n => 0 + m
+  | LE_S m (LE_S y h) => 0 + m
+  end.
 
 
-Type                Cases (LE_n O) of 
-                         LE_n   => O
-                      | (LE_S m LE_n) => (plus O m)
-                      | (LE_S m (LE_S y h)) => (plus O m)
-                      end.
+Type
+  match LE_n 0 with
+  | LE_n => 0
+  | LE_S m LE_n => 0 + m
+  | LE_S m (LE_S y h) => 0 + m
+  end.
 
 
-Type [n,m:nat][h:(Le n m)]              Cases h of 
-                                                x => x 
-                                          end.
+Type (fun (n m : nat) (h : Le n m) => match h with
+                                      | x => x
+                                      end).
 
-Type [n,m:nat][h:(Le n m)]<[_,_:nat]nat>Cases h of 
-                                               (LeO n) => n
-                                              |   x => O
-                                          end.
-Type [n,m:nat][h:(Le n m)] Cases h of 
-                               (LeO n) => n
-                             |   x => O
-                            end.
+Type
+  (fun (n m : nat) (h : Le n m) =>
+   match h return nat with
+   | LeO n => n
+   | x => 0
+   end).
+Type (fun (n m : nat) (h : Le n m) => match h with
+                                      | LeO n => n
+                                      | x => 0
+                                      end).
 
 
-Type [n:nat]<[_:nat]nat->nat>Cases niln of 
-                         niln  => [_:nat]O
-                      | (consn n a niln) => [_:nat]O
-                      | (consn n a (consn m b l)) => [_:nat](plus n m)
-                      end.
+Type
+  (fun n : nat =>
+   match niln return (nat -> nat) with
+   | niln => fun _ : nat => 0
+   | consn n a niln => fun _ : nat => 0
+   | consn n a (consn m b l) => fun _ : nat => n + m
+   end).
 
 
-Type [n:nat]         Cases niln of 
-                         niln  => [_:nat]O
-                      | (consn n a niln) => [_:nat]O
-                      | (consn n a (consn m b l)) => [_:nat](plus n m)
-                      end.
+Type
+  (fun n : nat =>
+   match niln with
+   | niln => fun _ : nat => 0
+   | consn n a niln => fun _ : nat => 0
+   | consn n a (consn m b l) => fun _ : nat => n + m
+   end).
 
-Type [A:Set][n:nat][l:(Listn A n)]
-                  <[_:nat]nat->nat>Cases l of 
-                         Niln  => [_:nat]O
-                      | (Consn  n a Niln) =>  [_:nat] n
-                      | (Consn  n a (Consn  m b l)) => [_:nat](plus n m)
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l return (nat -> nat) with
+   | Niln => fun _ : nat => 0
+   | Consn n a Niln => fun _ : nat => n
+   | Consn n a (Consn m b l) => fun _ : nat => n + m
+   end).
 
-Type [A:Set][n:nat][l:(Listn A n)]
-                        Cases l of 
-                         Niln  => [_:nat]O
-                      | (Consn  n a Niln) =>  [_:nat] n
-                      | (Consn  n a (Consn  m b l)) => [_:nat](plus n m)
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l with
+   | Niln => fun _ : nat => 0
+   | Consn n a Niln => fun _ : nat => n
+   | Consn n a (Consn m b l) => fun _ : nat => n + m
+   end).
 
 (* Alsos tests for multiple _ patterns *)
-Type [A:Set][n:nat][l:(Listn A n)]
-                  <[n:nat](Listn A n)>Cases l of 
-                        (Niln as b) => b
-                      | ((Consn _ _ _ ) as b)=>  b
-                      end.
+Type
+  (fun (A : Set) (n : nat) (l : Listn A n) =>
+   match l in (Listn _ n) return (Listn A n) with
+   | Niln as b => b
+   | Consn _ _ _ as b => b
+   end).
 
 (** Horrible error message! 
 
@@ -962,215 +1077,278 @@ Type [A:Set][n:nat][l:(Listn A n)]
                       end.
 ******)
 
-Type   <[n:nat](listn  n)>Cases niln of 
-               (niln as b) => b
-          | ((consn _ _ _ ) as b)=>  b
-          end.
-
+Type
+  match niln in (listn n) return (listn n) with
+  | niln as b => b
+  | consn _ _ _ as b => b
+  end.
 
-Type   <[n:nat](listn  n)>Cases niln of 
-               (niln as b) => b
-          |    x  =>  x
-          end.
 
-Type [n,m:nat][h:(LE n m)]<[_:nat]nat->nat>Cases h  of 
-                         LE_n   => [_:nat]n
-                      | (LE_S  m LE_n) => [_:nat](plus n m)
-                      | (LE_S  m (LE_S y h)) => [_:nat](plus m y )
-                      end.
-Type [n,m:nat][h:(LE n m)]Cases h  of 
-                         LE_n   => [_:nat]n
-                      | (LE_S  m LE_n) => [_:nat](plus n m)
-                      | (LE_S  m (LE_S y h)) => [_:nat](plus m y )
-                      end.
+Type
+  match niln in (listn n) return (listn n) with
+  | niln as b => b
+  | x => x
+  end.
 
+Type
+  (fun (n m : nat) (h : LE n m) =>
+   match h return (nat -> nat) with
+   | LE_n => fun _ : nat => n
+   | LE_S m LE_n => fun _ : nat => n + m
+   | LE_S m (LE_S y h) => fun _ : nat => m + y
+   end).
+Type
+  (fun (n m : nat) (h : LE n m) =>
+   match h with
+   | LE_n => fun _ : nat => n
+   | LE_S m LE_n => fun _ : nat => n + m
+   | LE_S m (LE_S y h) => fun _ : nat => m + y
+   end).
 
-Type [n,m:nat][h:(LE n m)]
-    <[_:nat]nat>Cases h  of 
-        LE_n   => n
-      | (LE_S m  LE_n ) => (plus n m)
-      | (LE_S  m (LE_S  y  LE_n )) => (plus (plus n m) y)
-      | (LE_S  m (LE_S  y (LE_S  y' h))) => (plus (plus n m) (plus y y'))
-                      end.
 
+Type
+  (fun (n m : nat) (h : LE n m) =>
+   match h return nat with
+   | LE_n => n
+   | LE_S m LE_n => n + m
+   | LE_S m (LE_S y LE_n) => n + m + y
+   | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y')
+   end).
 
 
-Type [n,m:nat][h:(LE n m)]
-       Cases h  of 
-        LE_n   => n
-      | (LE_S m  LE_n ) => (plus n m)
-      | (LE_S  m (LE_S  y  LE_n )) => (plus (plus n m) y)
-      | (LE_S  m (LE_S  y (LE_S  y' h))) => (plus (plus n m) (plus y y'))
-                      end.
 
+Type
+  (fun (n m : nat) (h : LE n m) =>
+   match h with
+   | LE_n => n
+   | LE_S m LE_n => n + m
+   | LE_S m (LE_S y LE_n) => n + m + y
+   | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y')
+   end).
 
-Type [n,m:nat][h:(LE n m)]<[_:nat]nat>Cases h  of 
-                        LE_n   => n
-                      | (LE_S m LE_n) => (plus n m)
-                      | (LE_S  m (LE_S y h)) => (plus (plus n m) y)
-                      end.
 
+Type
+  (fun (n m : nat) (h : LE n m) =>
+   match h return nat with
+   | LE_n => n
+   | LE_S m LE_n => n + m
+   | LE_S m (LE_S y h) => n + m + y
+   end).
 
-Type [n,m:nat][h:(LE n m)]Cases h  of 
-                        LE_n   => n
-                      | (LE_S m LE_n) => (plus n m)
-                      | (LE_S  m (LE_S y h)) => (plus (plus n m) y)
-                      end.
 
-Type [n,m:nat]
-                    <[_,_:nat]nat>Cases (LeO O) of 
-                        (LeS n m h)  =>(plus n m)
-                      | x => O
-                      end.
+Type
+  (fun (n m : nat) (h : LE n m) =>
+   match h with
+   | LE_n => n
+   | LE_S m LE_n => n + m
+   | LE_S m (LE_S y h) => n + m + y
+   end).
 
-Type [n,m:nat]
-                      Cases (LeO O) of 
-                        (LeS n m h)  =>(plus n m)
-                      | x => O
-                      end.
+Type
+  (fun n m : nat =>
+   match LeO 0 return nat with
+   | LeS n m h => n + m
+   | x => 0
+   end).
+
+Type (fun n m : nat => match LeO 0 with
+                       | LeS n m h => n + m
+                       | x => 0
+                       end).
 
-Parameter test : (n:nat){(le O n)}+{False}.
-Type  [n:nat]<nat>Cases (test n) of
-                        (left _) => O 
-                        | _ => O end.
+Parameter test : forall n : nat, {0 <= n} + {False}.
+Type (fun n : nat => match test n return nat with
+                     | left _ => 0
+                     | _ => 0
+                     end).
 
 
-Type  [n:nat]   <nat> Cases (test n) of
-                          (left _) => O 
-                        | _ => O end.
+Type (fun n : nat => match test n return nat with
+                     | left _ => 0
+                     | _ => 0
+                     end).
 
-Type  [n:nat]Cases (test n) of
-                          (left _) => O 
-                        | _ => O end.
+Type (fun n : nat => match test n with
+                     | left _ => 0
+                     | _ => 0
+                     end).
 
-Parameter compare : (n,m:nat)({(lt n m)}+{n=m})+{(gt n m)}.
-Type <nat>Cases (compare O O) of
-               (* k<i *)  (inleft (left _)) => O
-            |  (* k=i *)  (inleft  _)  => O
-            |  (* k>i *)  (inright  _) => O end.
+Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}.
+Type
+  match compare 0 0 return nat with
+  
+      (* k<i *) | inleft (left _) => 0
+   (* k=i *) | inleft _ => 0
+   (* k>i *) | inright _ => 0
+  end.
 
-Type    Cases (compare O O) of
-               (* k<i *)  (inleft (left _)) => O
-            |  (* k=i *)  (inleft  _)  => O
-            |  (* k>i *)  (inright  _) => O end.
+Type
+  match compare 0 0 with
+  
+      (* k<i *) | inleft (left _) => 0
+   (* k=i *) | inleft _ => 0
+   (* k>i *) | inright _ => 0
+  end.
 
 
 
-CoInductive SStream [A:Set]  : (nat->A->Prop)->Type :=
-scons  : 
-  (P:nat->A->Prop)(a:A)(P O a)->(SStream A [n:nat](P (S n)))->(SStream A P).
+CoInductive SStream (A : Set) : (nat -> A -> Prop) -> Type :=
+    scons :
+      forall (P : nat -> A -> Prop) (a : A),
+      P 0 a -> SStream A (fun n : nat => P (S n)) -> SStream A P.
 Parameter B : Set.
 
-Type 
-  [P:nat->B->Prop][x:(SStream B P)]<[_:nat->B->Prop]B>Cases x of
-     (scons _ a _ _) => a  end.
+Type
+  (fun (P : nat -> B -> Prop) (x : SStream B P) =>
+   match x return B with
+   | scons _ a _ _ => a
+   end).
 
 
-Type 
-  [P:nat->B->Prop][x:(SStream B P)] Cases x of
-     (scons _ a _ _) => a  end.
+Type
+  (fun (P : nat -> B -> Prop) (x : SStream B P) =>
+   match x with
+   | scons _ a _ _ => a
+   end).
 
-Type <nat*nat>Cases (O,O) of  (x,y) => ((S x),(S y)) end.
-Type <nat*nat>Cases (O,O) of  ((x as b), y) => ((S x),(S y)) end.
-Type <nat*nat>Cases (O,O) of  (pair x y) => ((S x),(S y)) end.
+Type match (0, 0) return (nat * nat) with
+     | (x, y) => (S x, S y)
+     end.
+Type match (0, 0) return (nat * nat) with
+     | (b, y) => (S b, S y)
+     end.
+Type match (0, 0) return (nat * nat) with
+     | (x, y) => (S x, S y)
+     end.
 
-Type Cases (O,O) of  (x,y) => ((S x),(S y)) end.
-Type Cases (O,O) of  ((x as b), y) => ((S x),(S y)) end.
-Type Cases (O,O) of  (pair x y) => ((S x),(S y)) end.
+Type match (0, 0) with
+     | (x, y) => (S x, S y)
+     end.
+Type match (0, 0) with
+     | (b, y) => (S b, S y)
+     end.
+Type match (0, 0) with
+     | (x, y) => (S x, S y)
+     end.
 
 
 
-Parameter concat : (A:Set)(List A) ->(List A) ->(List A).
+Parameter concat : forall A : Set, List A -> List A -> List A.
 
-Type <(List nat)>Cases (Nil nat) (Nil nat) of 
-                 (Nil as b)  x  => (concat nat b x)
-              | ((Cons _ _) as d) (Nil as c) => (concat nat d c)
-              |  _ _ => (Nil nat)
-              end.
-Type Cases (Nil nat) (Nil nat) of 
-           (Nil as b)  x  => (concat nat b x)
-       | ((Cons _ _) as d) (Nil as c) => (concat nat d c)
-       |  _ _ => (Nil nat)
-       end.
+Type
+  match Nil nat, Nil nat return (List nat) with
+  | Nil as b, x => concat nat b x
+  | Cons _ _ as d, Nil as c => concat nat d c
+  | _, _ => Nil nat
+  end.
+Type
+  match Nil nat, Nil nat with
+  | Nil as b, x => concat nat b x
+  | Cons _ _ as d, Nil as c => concat nat d c
+  | _, _ => Nil nat
+  end.
 
 
 Inductive redexes : Set :=
-    VAR : nat -> redexes
+  | VAR : nat -> redexes
   | Fun : redexes -> redexes
-  | Ap  : bool -> redexes -> redexes -> redexes.
-
-Fixpoint regular [U:redexes] : Prop := <Prop>Cases U of
-  (VAR n) => True
-| (Fun V) => (regular V)
-| (Ap true ((Fun _) as V)  W) => (regular V) /\ (regular W)
-| (Ap true _ W) => False
-| (Ap false V W) => (regular V) /\ (regular W) 
-end.
+  | Ap : bool -> redexes -> redexes -> redexes.
+
+Fixpoint regular (U : redexes) : Prop :=
+  match U return Prop with
+  | VAR n => True
+  | Fun V => regular V
+  | Ap true (Fun _ as V) W => regular V /\ regular W
+  | Ap true _ W => False
+  | Ap false V W => regular V /\ regular W
+  end.
 
 
-Type [n:nat]Cases n of O => O | (S ((S n) as V)) => V | _ => O end.
+Type (fun n : nat => match n with
+                     | O => 0
+                     | S (S n as V) => V
+                     | _ => 0
+                     end).
 
 Reset concat.
-Parameter concat :(n:nat) (listn n) -> (m:nat) (listn m)-> (listn (plus n m)).
-Type [n:nat][l:(listn n)][m:nat][l':(listn m)] 
- <[n,_:nat](listn (plus n m))>Cases l l' of 
-                 niln  x => x
-              | (consn n a l'') x =>(consn (plus n m) a (concat n l'' m x))
-               end.
-
-Type [x,y,z:nat]
-        [H:x=y]
-         [H0:y=z]<[_:nat]x=z>Cases H of refl_equal => 
-                          <[n:nat]x=n>Cases H0 of refl_equal => H
-                                             end
-                                       end.
-
-Type [h:False]<False>Cases h of end.
+Parameter
+  concat :
+    forall n : nat, listn n -> forall m : nat, listn m -> listn (n + m).
+Type
+  (fun (n : nat) (l : listn n) (m : nat) (l' : listn m) =>
+   match l in (listn n), l' return (listn (n + m)) with
+   | niln, x => x
+   | consn n a l'', x => consn (n + m) a (concat n l'' m x)
+   end).
 
-Type [h:False]<True>Cases h of end.
+Type
+  (fun (x y z : nat) (H : x = y) (H0 : y = z) =>
+   match H return (x = z) with
+   | refl_equal =>
+       match H0 in (_ = n) return (x = n) with
+       | refl_equal => H
+       end
+   end).
+
+Type (fun h : False => match h return False with
+                       end).
 
-Definition is_zero := [n:nat]Cases n of O => True | _ => False end.
+Type (fun h : False => match h return True with
+                       end).
 
-Type [n:nat][h:O=(S n)]<[n:nat](is_zero n)>Cases h of refl_equal => I end.
+Definition is_zero (n : nat) := match n with
+                                | O => True
+                                | _ => False
+                                end.
 
-Definition disc : (n:nat)O=(S n)->False :=
-  [n:nat][h:O=(S n)]
-      <[n:nat](is_zero n)>Cases h of refl_equal => I end.
+Type
+  (fun (n : nat) (h : 0 = S n) =>
+   match h in (_ = n) return (is_zero n) with
+   | refl_equal => I
+   end).
+
+Definition disc (n : nat) (h : 0 = S n) : False :=
+  match h in (_ = n) return (is_zero n) with
+  | refl_equal => I
+  end.
 
-Definition nlength3 := [n:nat] [l: (listn n)]
-                         Cases l of 
-                            niln  => O
-                         |  (consn O  _ _)  => (S O)
-                         |  (consn (S n)  _ _) => (S (S n))
-                         end.
+Definition nlength3 (n : nat) (l : listn n) :=
+  match l with
+  | niln => 0
+  | consn O _ _ => 1
+  | consn (S n) _ _ => S (S n)
+  end.
 
 (* == Testing strategy elimintation predicate  synthesis == *)
 Section titi.
-Variable h:False.
-Type Cases O of 
-          O  => O
-       |  _  => (Except h)
-       end.
+Variable h : False.
+Type match 0 with
+     | O => 0
+     | _ => except h
+     end.
 End titi.
 
-Type Cases niln of 
-    (consn _ a niln) => a
- |  (consn n _ x)    => O
- |   niln  => O
- end.
+Type match niln with
+     | consn _ a niln => a
+     | consn n _ x => 0
+     | niln => 0
+     end.
 
 
 
-Inductive wsort : Set := ws : wsort | wt : wsort.
-Inductive TS : wsort->Set := 
-   id :(TS ws) 
-| lift:(TS ws)->(TS ws).
+Inductive wsort : Set :=
+  | ws : wsort
+  | wt : wsort.
+Inductive TS : wsort -> Set :=
+  | id : TS ws
+  | lift : TS ws -> TS ws.
 
-Type [b:wsort][M:(TS b)][N:(TS b)]
- Cases   M   N of   
-  (lift M1)   id => False 
- | _ _ => True 
- end.
+Type
+  (fun (b : wsort) (M N : TS b) =>
+   match M, N with
+   | lift M1, id => False
+   | _, _ => True
+   end).
 
 
 
@@ -1182,51 +1360,56 @@ Type [b:wsort][M:(TS b)][N:(TS b)]
 
 
 Parameter LTERM : nat -> Set.
-Mutual Inductive TERM : Type :=
-	  var : TERM
-	| oper : (op:nat) (LTERM op) -> TERM.
-
-Parameter t1, t2:TERM.
+Inductive TERM : Type :=
+  | var : TERM
+  | oper : forall op : nat, LTERM op -> TERM.
 
-Type Cases t1 t2 of 
-   var   var  => True
+Parameter t1 t2 : TERM.
 
- | (oper op1 l1)  (oper op2 l2) => False
- | _ _ => False 
- end. 
+Type
+  match t1, t2 with
+  | var, var => True
+  | oper op1 l1, oper op2 l2 => False
+  | _, _ => False
+  end. 
 Reset LTERM.
 
 
 
-Require Peano_dec.
-Parameter n:nat.
-Definition eq_prf := (EXT m | n=m).
-Parameter p:eq_prf .
+Require Import Peano_dec.
+Parameter n : nat.
+Definition eq_prf := exists m : _, n = m.
+Parameter p : eq_prf.
 
-Type Cases p of
-     (exT_intro c eqc) =>
-          Cases (eq_nat_dec c n) of
-            (right _) => (refl_equal ? n)
-           |(left y) (* c=n*) => (refl_equal ? n) 
-          end
-     end.
+Type
+  match p with
+  | ex_intro c eqc =>
+      match eq_nat_dec c n with
+      | right _ => refl_equal n
+      | left y => (* c=n*)  refl_equal n
+      end
+  end.
 
 
-Parameter ordre_total : nat->nat->Prop.
+Parameter ordre_total : nat -> nat -> Prop.
 
-Parameter N_cla:(N:nat){N=O}+{N=(S O)}+{(ge N (S (S O)))}.
+Parameter N_cla : forall N : nat, {N = 0} + {N = 1} + {N >= 2}.
 
-Parameter exist_U2:(N:nat)(ge N (S (S O)))->
-                      {n:nat|(m:nat)(lt O m)/\(le m N)
-                             /\(ordre_total n m)                   
-                             /\(lt O n)/\(lt n N)}.
+Parameter
+  exist_U2 :
+    forall N : nat,
+    N >= 2 ->
+    {n : nat |
+    forall m : nat, 0 < m /\ m <= N /\ ordre_total n m /\ 0 < n /\ n < N}.
 
-Type [N:nat](Cases (N_cla N) of
-                         (inright H)=>(Cases (exist_U2 N H) of
-                                               (exist a b)=>a
-                                       end)
-                        |   _       => O
-                       end).
+Type
+  (fun N : nat =>
+   match N_cla N with
+   | inright H => match exist_U2 N H with
+                  | exist a b => a
+                  end
+   | _ => 0
+   end).
 
 
 
@@ -1238,148 +1421,159 @@ Type [N:nat](Cases (N_cla N) of
 (* == To test that terms named with AS are correctly absolutized before
       substitution in rhs   == *)
 
-Type [n:nat]<[n:nat]nat>Cases (n) of 
-          O  => O
-       |  (S O)  => O
-       |  ((S (S n1)) as N)  => N
-      end.
+Type
+  (fun n : nat =>
+   match n return nat with
+   | O => 0
+   | S O => 0
+   | S (S n1) as N => N
+   end).
 
 (* ========= *)
 
-Type <[n:nat][_:(listn n)]Prop>Cases niln of 
-                         niln => True
-                       | (consn (S O) _ _) => False
-                       | _ => True end.
-
-Type <[n:nat][_:(listn n)]Prop>Cases niln of 
-                         niln => True
-                       | (consn (S (S O)) _ _) => False
-                       | _ => True end.
-
-
-Type <[n,m:nat][h:(Le n m)]nat>Cases (LeO O) of 
-                         (LeO _) => O
-                       | (LeS (S x) _ _) => x
-                       | _ => (S O) end.
-
-Type <[n,m:nat][h:(Le n m)]nat>Cases (LeO O) of 
-                         (LeO _) => O
-                       | (LeS (S x)  (S y) _) => x
-                       | _ => (S O) end.
-
-Type <[n,m:nat][h:(Le n m)]nat>Cases (LeO O) of 
-                         (LeO _) => O
-                       | (LeS ((S x) as b)  (S y) _) => b
-                       | _ => (S O) end.
+Type
+  match niln in (listn n) return Prop with
+  | niln => True
+  | consn (S O) _ _ => False
+  | _ => True
+  end.
 
+Type
+  match niln in (listn n) return Prop with
+  | niln => True
+  | consn (S (S O)) _ _ => False
+  | _ => True
+  end.
 
 
-Parameter ff: (n,m:nat)~n=m -> ~(S n)=(S m).
-Parameter discr_r : (n:nat) ~(O=(S n)).
-Parameter discr_l : (n:nat) ~((S n)=O).
+Type
+  match LeO 0 as h in (Le n m) return nat with
+  | LeO _ => 0
+  | LeS (S x) _ _ => x
+  | _ => 1
+  end.
 
-Type 
-[n:nat] 
-  <[n:nat]n=O\/~n=O>Cases n of 
-      O     => (or_introl ? ~O=O (refl_equal ? O))      
-   |  (S x) => (or_intror (S x)=O ? (discr_l x))
+Type
+  match LeO 0 as h in (Le n m) return nat with
+  | LeO _ => 0
+  | LeS (S x) (S y) _ => x
+  | _ => 1
   end.
 
+Type
+  match LeO 0 as h in (Le n m) return nat with
+  | LeO _ => 0
+  | LeS (S x as b) (S y) _ => b
+  | _ => 1
+  end.
 
-Fixpoint eqdec [n:nat] : (m:nat) n=m \/ ~n=m := 
-[m:nat]
- <[n,m:nat] n=m \/ ~n=m>Cases n m of
-      O   O   => (or_introl ? ~O=O (refl_equal ? O))
 
-   |  O (S x) => (or_intror O=(S x) ? (discr_r x))
 
-   | (S x) O  => (or_intror ? ~(S x)=O (discr_l x))
+Parameter ff : forall n m : nat, n <> m -> S n <> S m.
+Parameter discr_r : forall n : nat, 0 <> S n.
+Parameter discr_l : forall n : nat, S n <> 0.
 
-   | (S x) (S y) =>  
-      <(S x)=(S y)\/~(S x)=(S y)>Cases (eqdec x y) of
-        (or_introl h) => (or_introl  ? ~(S x)=(S y) (f_equal nat nat S x y h))
-      | (or_intror h) => (or_intror (S x)=(S y) ? (ff x y h))   
+Type
+  (fun n : nat =>
+   match n return (n = 0 \/ n <> 0) with
+   | O => or_introl (0 <> 0) (refl_equal 0)
+   | S x => or_intror (S x = 0) (discr_l x)
+   end).
+
+
+Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
+  match n, m return (n = m \/ n <> m) with
+  | O, O => or_introl (0 <> 0) (refl_equal 0)
+  | O, S x => or_intror (0 = S x) (discr_r x)
+  | S x, O => or_intror _ (discr_l x)
+  | S x, S y =>
+      match eqdec x y return (S x = S y \/ S x <> S y) with
+      | or_introl h => or_introl (S x <> S y) (f_equal S h)
+      | or_intror h => or_intror (S x = S y) (ff x y h)
       end
- end.
+  end.
 
 Reset eqdec.
 
-Fixpoint eqdec [n:nat] : (m:nat) n=m \/ ~n=m := 
-<[n:nat] (m:nat)n=m \/ ~n=m>Cases n  of
-    O  => [m:nat] <[m:nat]O=m\/~O=m>Cases m of 
-                     O    => (or_introl ? ~O=O (refl_equal nat O))
-                   |(S x) => (or_intror O=(S x) ?  (discr_r x))
-                  end
-  | (S x) => [m:nat] 
-    <[m:nat](S x)=m\/~(S x)=m>Cases m of  
-        O    => (or_intror (S x)=O ? (discr_l x))
-     | (S y) =>  
-         <(S x)=(S y)\/~(S x)=(S y)>Cases (eqdec x y) of
-            (or_introl h) => (or_introl ? ~(S x)=(S y) (f_equal ? ? S x y h))
-          | (or_intror h) => (or_intror (S x)=(S y) ? (ff x y h))   
-         end
-    end
- end.
-
-
-Inductive empty : (n:nat)(listn n)-> Prop := 
-  intro_empty: (empty O niln).
-
-Parameter inv_empty : (n,a:nat)(l:(listn n)) ~(empty (S n) (consn n a l)).
-
-Type 
-[n:nat] [l:(listn n)]
-  <[n:nat] [l:(listn n)](empty n l) \/ ~(empty n l)>Cases l of 
-        niln               =>  (or_introl ? ~(empty O niln) intro_empty)
-   |  ((consn n a y) as b) =>  (or_intror (empty (S n) b) ? (inv_empty n a y))
+Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m :=
+  match n return (forall m : nat, n = m \/ n <> m) with
+  | O =>
+      fun m : nat =>
+      match m return (0 = m \/ 0 <> m) with
+      | O => or_introl (0 <> 0) (refl_equal 0)
+      | S x => or_intror (0 = S x) (discr_r x)
+      end
+  | S x =>
+      fun m : nat =>
+      match m return (S x = m \/ S x <> m) with
+      | O => or_intror (S x = 0) (discr_l x)
+      | S y =>
+          match eqdec x y return (S x = S y \/ S x <> S y) with
+          | or_introl h => or_introl (S x <> S y) (f_equal S h)
+          | or_intror h => or_intror (S x = S y) (ff x y h)
+          end
+      end
   end.
 
-Reset ff.
-Parameter ff: (n,m:nat)~n=m -> ~(S n)=(S m).
-Parameter discr_r : (n:nat) ~(O=(S n)).
-Parameter discr_l : (n:nat) ~((S n)=O).
-
-Type 
-[n:nat] 
-  <[n:nat]n=O\/~n=O>Cases n of 
-      O     => (or_introl ? ~O=O (refl_equal ? O))      
-   |  (S x) => (or_intror (S x)=O ? (discr_l x))
-  end.
 
+Inductive empty : forall n : nat, listn n -> Prop :=
+    intro_empty : empty 0 niln.
 
-Fixpoint eqdec [n:nat] : (m:nat) n=m \/ ~n=m := 
-[m:nat]
- <[n,m:nat] n=m \/ ~n=m>Cases n m of
-      O   O   => (or_introl ? ~O=O (refl_equal ? O))
+Parameter
+  inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l).
 
-   |  O (S x) => (or_intror O=(S x) ? (discr_r x))
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l in (listn n) return (empty n l \/ ~ empty n l) with
+   | niln => or_introl (~ empty 0 niln) intro_empty
+   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
+   end).
 
-   | (S x) O  => (or_intror ? ~(S x)=O (discr_l x))
+Reset ff.
+Parameter ff : forall n m : nat, n <> m -> S n <> S m.
+Parameter discr_r : forall n : nat, 0 <> S n.
+Parameter discr_l : forall n : nat, S n <> 0.
 
-   | (S x) (S y) =>  
-      <(S x)=(S y)\/~(S x)=(S y)>Cases (eqdec x y) of
-        (or_introl h) => (or_introl  ? ~(S x)=(S y) (f_equal nat nat S x y h))
-      | (or_intror h) => (or_intror (S x)=(S y) ? (ff x y h))   
+Type
+  (fun n : nat =>
+   match n return (n = 0 \/ n <> 0) with
+   | O => or_introl (0 <> 0) (refl_equal 0)
+   | S x => or_intror (S x = 0) (discr_l x)
+   end).
+
+
+Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
+  match n, m return (n = m \/ n <> m) with
+  | O, O => or_introl (0 <> 0) (refl_equal 0)
+  | O, S x => or_intror (0 = S x) (discr_r x)
+  | S x, O => or_intror _ (discr_l x)
+  | S x, S y =>
+      match eqdec x y return (S x = S y \/ S x <> S y) with
+      | or_introl h => or_introl (S x <> S y) (f_equal S h)
+      | or_intror h => or_intror (S x = S y) (ff x y h)
       end
- end.
+  end.
 Reset eqdec.
 
-Fixpoint eqdec [n:nat] : (m:nat) n=m \/ ~n=m := 
-<[n:nat] (m:nat)n=m \/ ~n=m>Cases n  of
-    O  => [m:nat] <[m:nat]O=m\/~O=m>Cases m of 
-                     O    => (or_introl ? ~O=O (refl_equal nat O))
-                   |(S x) => (or_intror O=(S x) ?  (discr_r x))
-                  end
-  | (S x) => [m:nat] 
-    <[m:nat](S x)=m\/~(S x)=m>Cases m of  
-        O    => (or_intror (S x)=O ? (discr_l x))
-     | (S y) =>  
-         <(S x)=(S y)\/~(S x)=(S y)>Cases (eqdec x y) of
-            (or_introl h) => (or_introl ? ~(S x)=(S y) (f_equal ? ? S x y h))
-          | (or_intror h) => (or_intror (S x)=(S y) ? (ff x y h))   
-         end
-    end
- end.
+Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m :=
+  match n return (forall m : nat, n = m \/ n <> m) with
+  | O =>
+      fun m : nat =>
+      match m return (0 = m \/ 0 <> m) with
+      | O => or_introl (0 <> 0) (refl_equal 0)
+      | S x => or_intror (0 = S x) (discr_r x)
+      end
+  | S x =>
+      fun m : nat =>
+      match m return (S x = m \/ S x <> m) with
+      | O => or_intror (S x = 0) (discr_l x)
+      | S y =>
+          match eqdec x y return (S x = S y \/ S x <> S y) with
+          | or_introl h => or_introl (S x <> S y) (f_equal S h)
+          | or_intror h => or_intror (S x = S y) (ff x y h)
+          end
+      end
+  end.
 
 
 (* ================================================== *)
@@ -1387,17 +1581,17 @@ Fixpoint eqdec [n:nat] : (m:nat) n=m \/ ~n=m :=
 (* ================================================== *)
 
 
-Inductive Empty [A:Set] : (List A)-> Prop := 
-  intro_Empty: (Empty A (Nil A)).
+Inductive Empty (A : Set) : List A -> Prop :=
+    intro_Empty : Empty A (Nil A).
 
-Parameter inv_Empty : (A:Set)(a:A)(x:(List A)) ~(Empty A (Cons A a x)).
+Parameter
+  inv_Empty : forall (A : Set) (a : A) (x : List A), ~ Empty A (Cons A a x).
 
 
 Type
-  <[l:(List nat)](Empty nat l) \/ ~(Empty nat l)>Cases (Nil nat) of 
-        Nil   =>  (or_introl ? ~(Empty nat (Nil nat)) (intro_Empty nat))
-   |   (Cons a y)  =>  (or_intror (Empty nat (Cons nat a y)) ? 
-                                   (inv_Empty nat a y))
+  match Nil nat as l return (Empty nat l \/ ~ Empty nat l) with
+  | Nil => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat)
+  | Cons a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y)
   end.
 
 
@@ -1406,192 +1600,222 @@ Type
 (* ================================================== *)
 
 
-Inductive empty : (n:nat)(listn n)-> Prop := 
-  intro_empty: (empty O niln).
+Inductive empty : forall n : nat, listn n -> Prop :=
+    intro_empty : empty 0 niln.
 
-Parameter inv_empty : (n,a:nat)(l:(listn n)) ~(empty (S n) (consn n a l)).
+Parameter
+  inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l).
 
-Type 
-[n:nat] [l:(listn n)]
-  <[n:nat] [l:(listn n)](empty n l) \/ ~(empty n l)>Cases l of 
-        niln               =>  (or_introl ? ~(empty O niln) intro_empty)
-   |  ((consn n a y) as b) =>  (or_intror (empty (S n) b) ? (inv_empty n a y))
-  end.
+Type
+  (fun (n : nat) (l : listn n) =>
+   match l in (listn n) return (empty n l \/ ~ empty n l) with
+   | niln => or_introl (~ empty 0 niln) intro_empty
+   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
+   end).
 
 (* ===================================== *)
 (*   Test parametros:                    *)
 (* ===================================== *)
 
-Inductive eqlong : (List nat)-> (List nat)-> Prop :=
- eql_cons : (n,m:nat)(x,y:(List nat)) 
-            (eqlong x y) -> (eqlong (Cons nat n x) (Cons nat m y))
-| eql_nil :  (eqlong (Nil nat) (Nil nat)).
-
-
-Parameter V1 : (eqlong (Nil nat) (Nil nat))\/ ~(eqlong (Nil nat) (Nil nat)).
-Parameter V2 : (a:nat)(x:(List nat))
-      (eqlong (Nil nat) (Cons nat a x))\/ ~(eqlong (Nil nat)(Cons nat a x)).
-Parameter V3 : (a:nat)(x:(List nat))
-      (eqlong  (Cons nat a x)  (Nil nat))\/ ~(eqlong (Cons nat a x) (Nil nat)).
-Parameter V4 : (a:nat)(x:(List nat))(b:nat)(y:(List nat))
-      (eqlong  (Cons nat a x)(Cons nat b y))
-        \/ ~(eqlong (Cons nat a x) (Cons nat b y)).
+Inductive eqlong : List nat -> List nat -> Prop :=
+  | eql_cons :
+      forall (n m : nat) (x y : List nat),
+      eqlong x y -> eqlong (Cons nat n x) (Cons nat m y)
+  | eql_nil : eqlong (Nil nat) (Nil nat).
+
+
+Parameter V1 : eqlong (Nil nat) (Nil nat) \/ ~ eqlong (Nil nat) (Nil nat).
+Parameter
+  V2 :
+    forall (a : nat) (x : List nat),
+    eqlong (Nil nat) (Cons nat a x) \/ ~ eqlong (Nil nat) (Cons nat a x).
+Parameter
+  V3 :
+    forall (a : nat) (x : List nat),
+    eqlong (Cons nat a x) (Nil nat) \/ ~ eqlong (Cons nat a x) (Nil nat).
+Parameter
+  V4 :
+    forall (a : nat) (x : List nat) (b : nat) (y : List nat),
+    eqlong (Cons nat a x) (Cons nat b y) \/
+    ~ eqlong (Cons nat a x) (Cons nat b y).
 
 Type
- <[x,y:(List nat)](eqlong x y)\/~(eqlong x y)>Cases (Nil nat) (Nil nat) of
-      Nil Nil   => V1
-   |  Nil (Cons a x)  => (V2 a x)
-   |  (Cons a x)  Nil => (V3 a x)
-   | (Cons a x)  (Cons b y)  => (V4 a x b y)
- end.
+  match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with
+  | Nil, Nil => V1
+  | Nil, Cons a x => V2 a x
+  | Cons a x, Nil => V3 a x
+  | Cons a x, Cons b y => V4 a x b y
+  end.
 
 
 Type
-[x,y:(List nat)]
- <[x,y:(List nat)](eqlong x y)\/~(eqlong x y)>Cases x y of
-      Nil Nil   => V1
-   |  Nil (Cons a x)  => (V2 a x)
-   |  (Cons a x)  Nil => (V3 a x)
-   | (Cons a x)  (Cons b y)  => (V4 a x b y)
- end.
+  (fun x y : List nat =>
+   match x, y return (eqlong x y \/ ~ eqlong x y) with
+   | Nil, Nil => V1
+   | Nil, Cons a x => V2 a x
+   | Cons a x, Nil => V3 a x
+   | Cons a x, Cons b y => V4 a x b y
+   end).
 
  
 (* ===================================== *)
 
-Inductive Eqlong : (n:nat) (listn n)-> (m:nat) (listn m)-> Prop :=
- Eql_cons : (n,m:nat )(x:(listn n))(y:(listn m)) (a,b:nat) 
-            (Eqlong n x m y) 
-             ->(Eqlong (S n) (consn n a x) (S m) (consn m b y))
-| Eql_niln :  (Eqlong O niln O niln).
-
-
-Parameter W1 : (Eqlong O niln O niln)\/ ~(Eqlong O niln O niln).
-Parameter W2 : (n,a:nat)(x:(listn n)) 
-  (Eqlong O niln (S n)(consn n a x)) \/ ~(Eqlong  O niln (S n) (consn n a x)).
-Parameter W3 : (n,a:nat)(x:(listn n)) 
- (Eqlong (S n) (consn n a x)  O niln) \/ ~(Eqlong (S n) (consn n a x)  O niln).
-Parameter W4 : (n,a:nat)(x:(listn n)) (m,b:nat)(y:(listn m)) 
-      (Eqlong  (S n)(consn n a x) (S m) (consn m b y))
-        \/ ~(Eqlong (S n)(consn n a x) (S m) (consn m b y)).
+Inductive Eqlong :
+forall n : nat, listn n -> forall m : nat, listn m -> Prop :=
+  | Eql_cons :
+      forall (n m : nat) (x : listn n) (y : listn m) (a b : nat),
+      Eqlong n x m y -> Eqlong (S n) (consn n a x) (S m) (consn m b y)
+  | Eql_niln : Eqlong 0 niln 0 niln.
+
+
+Parameter W1 : Eqlong 0 niln 0 niln \/ ~ Eqlong 0 niln 0 niln.
+Parameter
+  W2 :
+    forall (n a : nat) (x : listn n),
+    Eqlong 0 niln (S n) (consn n a x) \/ ~ Eqlong 0 niln (S n) (consn n a x).
+Parameter
+  W3 :
+    forall (n a : nat) (x : listn n),
+    Eqlong (S n) (consn n a x) 0 niln \/ ~ Eqlong (S n) (consn n a x) 0 niln.
+Parameter
+  W4 :
+    forall (n a : nat) (x : listn n) (m b : nat) (y : listn m),
+    Eqlong (S n) (consn n a x) (S m) (consn m b y) \/
+    ~ Eqlong (S n) (consn n a x) (S m) (consn m b y).
 
 Type
- <[n:nat][x:(listn n)][m:nat][y:(listn m)]
-     (Eqlong n x m y)\/~(Eqlong n x m y)>Cases niln  niln  of
-      niln niln   => W1
-   |  niln (consn n a x)  => (W2 n a x)
-   |  (consn n a x)  niln => (W3 n a x)
-   | (consn n a x)  (consn m b y)  => (W4 n a x m b y)
- end.
-
-
-Type 
-[n,m:nat][x:(listn n)][y:(listn m)]
- <[n:nat][x:(listn n)][m:nat][y:(listn m)]
-     (Eqlong n x m y)\/~(Eqlong n x m y)>Cases x y of
-      niln niln   => W1
-   |  niln (consn n a x)  => (W2 n a x)
-   |  (consn n a x)  niln => (W3 n a x)
-   | (consn n a x)  (consn m b y)  => (W4 n a x m b y)
- end.
-
-
-Parameter Inv_r : (n,a:nat)(x:(listn n)) ~(Eqlong O niln (S n) (consn n a x)).
-Parameter Inv_l : (n,a:nat)(x:(listn n)) ~(Eqlong (S n) (consn n a x) O niln).
-Parameter Nff : (n,a:nat)(x:(listn n)) (m,b:nat)(y:(listn m)) 
-               ~(Eqlong n x m y)
-                -> ~(Eqlong (S n) (consn n a x) (S m) (consn m b y)).
-
-
-
-Fixpoint Eqlongdec [n:nat; x:(listn n)] : (m:nat)(y:(listn m))
-                                           (Eqlong n x m y)\/~(Eqlong n x m y)
-:= [m:nat][y:(listn m)]
- <[n:nat][x:(listn n)][m:nat][y:(listn m)]
-     (Eqlong n x m y)\/~(Eqlong n x m y)>Cases x y of
-      niln niln   => (or_introl ? ~(Eqlong O niln O niln)  Eql_niln)
-
-   |  niln ((consn n a x) as L)  => 
-        (or_intror (Eqlong O niln (S n) L)  ? (Inv_r n a x))
-
-   | ((consn n a x) as L)  niln => 
-       (or_intror (Eqlong (S n) L O niln) ? (Inv_l n a x))
+  match
+    niln as x in (listn n), niln as y in (listn m)
+    return (Eqlong n x m y \/ ~ Eqlong n x m y)
+  with
+  | niln, niln => W1
+  | niln, consn n a x => W2 n a x
+  | consn n a x, niln => W3 n a x
+  | consn n a x, consn m b y => W4 n a x m b y
+  end.
 
 
-   | ((consn n a x) as L1) ((consn m b y) as L2) =>
-     <(Eqlong (S n) L1 (S m) L2) \/~(Eqlong (S n) L1 (S m) L2)>
-      Cases (Eqlongdec n x m y) of
-        (or_introl h) => 
-           (or_introl  ? ~(Eqlong (S n) L1 (S m) L2)(Eql_cons n m x y a b h))
-      | (or_intror h) => 
-           (or_intror (Eqlong (S n) L1 (S m) L2) ? (Nff n a x  m b y h))   
+Type
+  (fun (n m : nat) (x : listn n) (y : listn m) =>
+   match
+     x in (listn n), y in (listn m)
+     return (Eqlong n x m y \/ ~ Eqlong n x m y)
+   with
+   | niln, niln => W1
+   | niln, consn n a x => W2 n a x
+   | consn n a x, niln => W3 n a x
+   | consn n a x, consn m b y => W4 n a x m b y
+   end).
+
+
+Parameter
+  Inv_r :
+    forall (n a : nat) (x : listn n), ~ Eqlong 0 niln (S n) (consn n a x).
+Parameter
+  Inv_l :
+    forall (n a : nat) (x : listn n), ~ Eqlong (S n) (consn n a x) 0 niln.
+Parameter
+  Nff :
+    forall (n a : nat) (x : listn n) (m b : nat) (y : listn m),
+    ~ Eqlong n x m y -> ~ Eqlong (S n) (consn n a x) (S m) (consn m b y).
+
+
+
+Fixpoint Eqlongdec (n : nat) (x : listn n) (m : nat) 
+ (y : listn m) {struct x} : Eqlong n x m y \/ ~ Eqlong n x m y :=
+  match
+    x in (listn n), y in (listn m)
+    return (Eqlong n x m y \/ ~ Eqlong n x m y)
+  with
+  | niln, niln => or_introl (~ Eqlong 0 niln 0 niln) Eql_niln
+  | niln, consn n a x as L => or_intror (Eqlong 0 niln (S n) L) (Inv_r n a x)
+  | consn n a x as L, niln => or_intror (Eqlong (S n) L 0 niln) (Inv_l n a x)
+  | consn n a x as L1, consn m b y as L2 =>
+      match
+        Eqlongdec n x m y
+        return (Eqlong (S n) L1 (S m) L2 \/ ~ Eqlong (S n) L1 (S m) L2)
+      with
+      | or_introl h =>
+          or_introl (~ Eqlong (S n) L1 (S m) L2) (Eql_cons n m x y a b h)
+      | or_intror h =>
+          or_intror (Eqlong (S n) L1 (S m) L2) (Nff n a x m b y h)
       end
- end.
+  end.
 
 (* ============================================== *)
 (*     To test compilation of dependent case      *)
 (*      Multiple Patterns                         *)
 (* ============================================== *)
-Inductive skel: Type :=
-     PROP: skel
-   | PROD: skel->skel->skel.
+Inductive skel : Type :=
+  | PROP : skel
+  | PROD : skel -> skel -> skel.
 
 Parameter Can : skel -> Type.
-Parameter default_can : (s:skel) (Can s).
+Parameter default_can : forall s : skel, Can s.
 
-Type  [s1,s2:skel]
-[s1,s2:skel]<[s1:skel][_:skel](Can s1)>Cases s1 s2 of
-  PROP PROP => (default_can PROP)
-| (PROD x y) PROP => (default_can (PROD x y))
-| (PROD x y) _ => (default_can (PROD x y))
-| PROP _ => (default_can PROP)
-end.
+Type
+  (fun s1 s2 s1 s2 : skel =>
+   match s1, s2 return (Can s1) with
+   | PROP, PROP => default_can PROP
+   | PROD x y, PROP => default_can (PROD x y)
+   | PROD x y, _ => default_can (PROD x y)
+   | PROP, _ => default_can PROP
+   end).
 
 (* to test bindings in nested Cases *)
 (* ================================ *)
 Inductive Pair : Set :=
-  pnil : Pair |
-  pcons : Pair -> Pair -> Pair.
-
-Type [p,q:Pair]Cases p of
-  (pcons _ x) => 
-     Cases q of 
-      (pcons _ (pcons _ x)) => True
-     |  _  => False
-     end
-|  _  => False
-end.
-
-
-Type [p,q:Pair]Cases p of
-  (pcons _ x) => 
-     Cases q of 
-      (pcons _ (pcons _ x)) => 
-          Cases q of 
-              (pcons _ (pcons _ (pcons _ x))) => x
+  | pnil : Pair
+  | pcons : Pair -> Pair -> Pair.
+
+Type
+  (fun p q : Pair =>
+   match p with
+   | pcons _ x => match q with
+                  | pcons _ (pcons _ x) => True
+                  | _ => False
+                  end
+   | _ => False
+   end).
+
+
+Type
+  (fun p q : Pair =>
+   match p with
+   | pcons _ x =>
+       match q with
+       | pcons _ (pcons _ x) =>
+           match q with
+           | pcons _ (pcons _ (pcons _ x)) => x
            | _ => pnil
            end
-     |  _  => pnil
-     end
-|  _  => pnil
-end.
+       | _ => pnil
+       end
+   | _ => pnil
+   end).
 
-Type  
-  [n:nat]
-         [l:(listn (S n))]
-           <[z:nat](listn (pred z))>Cases l of 
-                       niln  => niln
-                    |  (consn n _ l)  => 
-                           <[m:nat](listn m)>Cases l of 
-                                             niln => niln
-                                           | b => b
-                                           end
-                   end.
+Type
+  (fun (n : nat) (l : listn (S n)) =>
+   match l in (listn z) return (listn (pred z)) with
+   | niln => niln
+   | consn n _ l =>
+       match l in (listn m) return (listn m) with
+       | niln => niln
+       | b => b
+       end
+   end).
 
 
 
 (* Test de la syntaxe avec nombres *)
-Require Arith.
-Type [n]Cases n of (2) => true | _ => false end.
-
-Require ZArith.
-Type [n]Cases n of `0` => true | _ => false end.
+Require Import Arith.
+Type (fun n => match n with
+               | S (S O) => true
+               | _ => false
+               end).
+
+Require Import ZArith.
+Type (fun n => match n with
+               | Z0 => true
+               | _ => false
+               end).
diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v
index 0256280c..0477377e 100644
--- a/test-suite/success/CasesDep.v
+++ b/test-suite/success/CasesDep.v
@@ -1,25 +1,28 @@
 (* Check forward dependencies *)
 
-Check [P:nat->Prop][Q][A:(P O)->Q][B:(n:nat)(P (S n))->Q][x]
-  <[_]Q>Cases x of 
-  | (exist O H) => (A H)
-  | (exist (S n) H) => (B n H)
-  end.
+Check
+  (fun (P : nat -> Prop) Q (A : P 0 -> Q) (B : forall n : nat, P (S n) -> Q)
+     x =>
+   match x return Q with
+   | exist O H => A H
+   | exist (S n) H => B n H
+   end).
 
 (* Check dependencies in anonymous arguments (from FTA/listn.v) *)
 
-Inductive listn [A:Set] : nat->Set :=
-  niln: (listn A O)
-| consn: (a:A)(n:nat)(listn A n)->(listn A (S n)).
+Inductive listn (A : Set) : nat -> Set :=
+  | niln : listn A 0
+  | consn : forall (a : A) (n : nat), listn A n -> listn A (S n).
 
 Section Folding.
-Variables B, C : Set.
+Variable B C : Set.
 Variable g : B -> C -> C.
 Variable c : C.
 
-Fixpoint foldrn [n:nat; bs:(listn B n)] : C :=
-  Cases bs of niln => c
-            | (consn b _ tl) => (g b (foldrn ? tl))
+Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C :=
+  match bs with
+  | niln => c
+  | consn b _ tl => g b (foldrn _ tl)
   end.
 End Folding.
 
@@ -30,149 +33,154 @@ End Folding.
 (* -------------------------------------------------------------------- *)
 
 
-Require Prelude.
-Require Logic_Type.
+Require Import Prelude.
+Require Import Logic_Type.
 
 Section Orderings.
-   Variable U: Type.
+   Variable U : Type.
    
-   Definition Relation :=  U -> U -> Prop.
+   Definition Relation := U -> U -> Prop.
 
-   Variable R: Relation.
+   Variable R : Relation.
    
-   Definition Reflexive : Prop :=  (x: U) (R x x).
+   Definition Reflexive : Prop := forall x : U, R x x.
    
-   Definition Transitive : Prop :=  (x,y,z: U) (R x y) -> (R y z) -> (R x z).
+   Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z.
    
-   Definition Symmetric : Prop :=  (x,y: U) (R x y) -> (R y x).
+   Definition Symmetric : Prop := forall x y : U, R x y -> R y x.
    
-   Definition Antisymmetric : Prop :=
-      (x,y: U) (R x y) -> (R y x) -> x==y.
+   Definition Antisymmetric : Prop := forall x y : U, R x y -> R y x -> x = y.
    
-   Definition contains : Relation -> Relation -> Prop :=
-      [R,R': Relation] (x,y: U) (R' x y) -> (R x y).
-  Definition same_relation : Relation -> Relation -> Prop :=
-      [R,R': Relation] (contains R R') /\ (contains R' R).
+   Definition contains (R R' : Relation) : Prop :=
+     forall x y : U, R' x y -> R x y.
+  Definition same_relation (R R' : Relation) : Prop :=
+    contains R R' /\ contains R' R.
 Inductive Equivalence : Prop :=
-         Build_Equivalence:
-           Reflexive -> Transitive -> Symmetric -> Equivalence.
+    Build_Equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence.
    
    Inductive PER : Prop :=
-         Build_PER: Symmetric -> Transitive -> PER.
+       Build_PER : Symmetric -> Transitive -> PER.
    
 End Orderings.
 
 (***** Setoid  *******)
 
-Inductive Setoid : Type 
-  := Build_Setoid : (S:Type)(R:(Relation S))(Equivalence ? R) -> Setoid.
+Inductive Setoid : Type :=
+    Build_Setoid :
+      forall (S : Type) (R : Relation S), Equivalence _ R -> Setoid.
 
-Definition elem := [A:Setoid] let (S,R,e)=A in S.
+Definition elem (A : Setoid) := let (S, R, e) := A in S.
 
-Grammar constr constr1 :=
- elem  [ "|" constr0($s) "|"] -> [ (elem $s) ].
+(* <Warning> : Grammar is replaced by Notation *)
 
-Definition equal := [A:Setoid]
-   <[s:Setoid](Relation |s|)>let (S,R,e)=A in R.
+Definition equal (A : Setoid) :=
+  let (S, R, e) as s return (Relation (elem s)) := A in R.
 
-Grammar constr constr1 :=
- equal   [ constr0($c) "=" "%" "S" constr0($c2) ] -> 
-         [ (equal ? $c $c2) ].
+(* <Warning> : Grammar is replaced by Notation *)
 
 
-Axiom prf_equiv : (A:Setoid)(Equivalence |A| (equal A)).
-Axiom prf_refl : (A:Setoid)(Reflexive |A| (equal A)).
-Axiom prf_sym : (A:Setoid)(Symmetric |A| (equal A)).
-Axiom prf_trans : (A:Setoid)(Transitive |A| (equal A)).
+Axiom prf_equiv : forall A : Setoid, Equivalence (elem A) (equal A).
+Axiom prf_refl : forall A : Setoid, Reflexive (elem A) (equal A).
+Axiom prf_sym : forall A : Setoid, Symmetric (elem A) (equal A).
+Axiom prf_trans : forall A : Setoid, Transitive (elem A) (equal A).
 
 Section Maps.
-Variables A,B: Setoid.
+Variable A B : Setoid.
 
-Definition Map_law := [f:|A| -> |B|]
-    (x,y:|A|) x =%S y -> (f x) =%S (f y).
+Definition Map_law (f : elem A -> elem B) :=
+  forall x y : elem A, equal _ x y -> equal _ (f x) (f y).
 
 Inductive Map : Type :=
-    Build_Map : (f:|A| -> |B|)(p:(Map_law f))Map.
+    Build_Map : forall (f : elem A -> elem B) (p : Map_law f), Map.
 
-Definition explicit_ap := [m:Map] <|A| -> |B|>Match m with 
-         [f:?][p:?]f end.
+Definition explicit_ap (m : Map) :=
+  match m return (elem A -> elem B) with
+  | Build_Map f p => f
+  end.
 
-Axiom pres : (m:Map)(Map_law (explicit_ap m)).
+Axiom pres : forall m : Map, Map_law (explicit_ap m).
 
-Definition ext := [f,g:Map]
-         (x:|A|) (explicit_ap f x) =%S (explicit_ap g x).
+Definition ext (f g : Map) :=
+  forall x : elem A, equal _ (explicit_ap f x) (explicit_ap g x).
 
-Axiom Equiv_map_eq : (Equivalence Map ext).
+Axiom Equiv_map_eq : Equivalence Map ext.
 
-Definition Map_setoid := (Build_Setoid Map ext Equiv_map_eq).
+Definition Map_setoid := Build_Setoid Map ext Equiv_map_eq.
 
 End Maps.
 
-Notation ap := (explicit_ap ? ?). 
+Notation ap := (explicit_ap _ _). 
 
-Grammar constr constr8 :=
-  map_setoid [ constr7($c1) "=>" constr8($c2) ] 
-                 -> [ (Map_setoid $c1 $c2) ].
+(* <Warning> : Grammar is replaced by Notation *)
 
 
-Definition ap2 := [A,B,C:Setoid][f:|(A=>(B=>C))|][a:|A|] (ap (ap f a)).
+Definition ap2 (A B C : Setoid) (f : elem (Map_setoid A (Map_setoid B C)))
+  (a : elem A) := ap (ap f a).
 
 
 (*****    posint     ******)
 
-Inductive posint : Type
-        := Z : posint | Suc : posint -> posint.
+Inductive posint : Type :=
+  | Z : posint
+  | Suc : posint -> posint.
 
-Axiom f_equal : (A,B:Type)(f:A->B)(x,y:A) x==y -> (f x)==(f y).
-Axiom eq_Suc : (n,m:posint) n==m -> (Suc n)==(Suc m).
+Axiom
+  f_equal : forall (A B : Type) (f : A -> B) (x y : A), x = y -> f x = f y.
+Axiom eq_Suc : forall n m : posint, n = m -> Suc n = Suc m.
 
 (* The predecessor function *)
 
-Definition pred : posint->posint
-     := [n:posint](<posint>Case n of (* Z *) Z 
-                            (* Suc u *) [u:posint]u end).
+Definition pred (n : posint) : posint :=
+  match n return posint with
+  | Z => (* Z *)  Z 
+      (* Suc u *) 
+  | Suc u => u
+  end.
 
-Axiom pred_Sucn : (m:posint) m==(pred (Suc m)).
-Axiom eq_add_Suc : (n,m:posint) (Suc n)==(Suc m) -> n==m.
-Axiom not_eq_Suc : (n,m:posint) ~(n==m) -> ~((Suc n)==(Suc m)).
+Axiom pred_Sucn : forall m : posint, m = pred (Suc m).
+Axiom eq_add_Suc : forall n m : posint, Suc n = Suc m -> n = m.
+Axiom not_eq_Suc : forall n m : posint, n <> m -> Suc n <> Suc m.
 
 
-Definition IsSuc : posint->Prop
-  := [n:posint](<Prop>Case n of (* Z *) False
-                          (* Suc p *) [p:posint]True end).
-Definition IsZero :posint->Prop :=
-	[n:posint]<Prop>Match n with 
-		True
-		[p:posint][H:Prop]False end.
+Definition IsSuc (n : posint) : Prop :=
+  match n return Prop with
+  | Z => (* Z *)  False
+      (* Suc p *) 
+  | Suc p => True
+  end.
+Definition IsZero (n : posint) : Prop :=
+  match n with
+  | Z => True
+  | Suc _ => False
+  end.
 
-Axiom Z_Suc : (n:posint) ~(Z==(Suc n)).
-Axiom  Suc_Z: (n:posint) ~(Suc n)==Z.
-Axiom n_Sucn : (n:posint) ~(n==(Suc n)).
-Axiom Sucn_n : (n:posint) ~(Suc n)==n.
-Axiom eqT_symt : (a,b:posint) ~(a==b)->~(b==a).
+Axiom Z_Suc : forall n : posint, Z <> Suc n.
+Axiom Suc_Z : forall n : posint, Suc n <> Z.
+Axiom n_Sucn : forall n : posint, n <> Suc n.
+Axiom Sucn_n : forall n : posint, Suc n <> n.
+Axiom eqT_symt : forall a b : posint, a <> b -> b <> a.
 
 
 (*******  Dsetoid *****)
 
-Definition Decidable :=[A:Type][R:(Relation A)]
-		(x,y:A)(R x y) \/ ~(R x y).
+Definition Decidable (A : Type) (R : Relation A) :=
+  forall x y : A, R x y \/ ~ R x y.
 
 
-Record DSetoid : Type :=
-{Set_of : Setoid;
- prf_decid : (Decidable |Set_of| (equal Set_of))}.
+Record DSetoid : Type := 
+  {Set_of : Setoid; prf_decid : Decidable (elem Set_of) (equal Set_of)}.
 
 (* example de Dsetoide d'entiers *)
 
 
-Axiom eqT_equiv : (Equivalence posint (eqT posint)).
-Axiom Eq_posint_deci : (Decidable posint (eqT posint)).
+Axiom eqT_equiv : Equivalence posint (eq (A:=posint)).
+Axiom Eq_posint_deci : Decidable posint (eq (A:=posint)).
 
 (* Dsetoide des posint*)
 
-Definition Set_of_posint := (Build_Setoid posint (eqT posint) eqT_equiv).
+Definition Set_of_posint := Build_Setoid posint (eq (A:=posint)) eqT_equiv.
 
-Definition Dposint := (Build_DSetoid Set_of_posint Eq_posint_deci).
+Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci.
 
 
 
@@ -186,23 +194,22 @@ Definition Dposint := (Build_DSetoid Set_of_posint Eq_posint_deci).
 
 Section Sig.
 
-Record Signature :Type :=
-{Sigma : DSetoid; 
- Arity : (Map (Set_of Sigma) (Set_of Dposint))}.
+Record Signature : Type := 
+  {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}.
 
-Variable S:Signature.
+Variable S : Signature.
 
 
 
 Variable Var : DSetoid.
 
-Mutual Inductive TERM : Type :=
-	  var : |(Set_of Var)| -> TERM
-	| oper : (op: |(Set_of (Sigma S))| ) (LTERM (ap (Arity S) op)) -> TERM
-with
-	LTERM : posint -> Type :=
-	  nil : (LTERM Z)
-	| cons : TERM -> (n:posint)(LTERM n) -> (LTERM (Suc n)).
+Inductive TERM : Type :=
+  | var : elem (Set_of Var) -> TERM
+  | oper :
+      forall op : elem (Set_of (Sigma S)), LTERM (ap (Arity S) op) -> TERM
+with LTERM : posint -> Type :=
+  | nil : LTERM Z
+  | cons : TERM -> forall n : posint, LTERM n -> LTERM (Suc n).
 
 
 
@@ -211,51 +218,51 @@ with
 (* -------------------------------------------------------------------- *)
 
 
-Parameter t1,t2: TERM.
+Parameter t1 t2 : TERM.
 
-Type 
- Cases t1 t2 of 
- | (var  v1) (var v2) => True
- | (oper op1 l1) (oper op2 l2) => False
- | _ _ => False 
- end.
+Type
+  match t1, t2 with
+  | var v1, var v2 => True
+  | oper op1 l1, oper op2 l2 => False
+  | _, _ => False
+  end.
 
 
 
-Parameter n2:posint.
-Parameter l1, l2:(LTERM n2).
+Parameter n2 : posint.
+Parameter l1 l2 : LTERM n2.
 
-Type 
- Cases l1 l2  of
-    nil            nil => True 
- |  (cons v m y)   nil => False
- |  _               _  => False
-end.
+Type
+  match l1, l2 with
+  | nil, nil => True
+  | cons v m y, nil => False
+  | _, _ => False
+  end.
 
 
-Type Cases l1 l2 of
-    nil              nil      => True 
- | (cons u n x)  (cons v m y) =>False
- |   _               _        => False
-end.
+Type
+  match l1, l2 with
+  | nil, nil => True
+  | cons u n x, cons v m y => False
+  | _, _ => False
+  end.
 
 
 
-Definition equalT [t1:TERM]:TERM->Prop :=
-[t2:TERM] 
- Cases t1 t2 of 
-   (var  v1)        (var v2)    => True
- | (oper op1 l1)  (oper op2 l2) => False
- |  _                   _       => False 
- end.
+Definition equalT (t1 t2 : TERM) : Prop :=
+  match t1, t2 with
+  | var v1, var v2 => True
+  | oper op1 l1, oper op2 l2 => False
+  | _, _ => False
+  end.
 
-Definition EqListT [n1:posint;l1:(LTERM n1)]: (n2:posint)(LTERM n2)->Prop :=
-[n2:posint][l2:(LTERM n2)]
- Cases l1 l2 of
-    nil                 nil             => True 
- | (cons t1 n1' l1')  (cons t2 n2' l2') => False
- | _                    _               => False
-end.
+Definition EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
+  (l2 : LTERM n2) : Prop :=
+  match l1, l2 with
+  | nil, nil => True
+  | cons t1 n1' l1', cons t2 n2' l2' => False
+  | _, _ => False
+  end.
 
 
 Reset equalT.
@@ -263,37 +270,52 @@ Reset equalT.
 (*          Initial exemple (without patterns)                       *)
 (*-------------------------------------------------------------------*)
 
-Fixpoint equalT [t1:TERM]:TERM->Prop :=
-<TERM->Prop>Case t1 of 
-	(*var*) [v1:|(Set_of Var)|][t2:TERM]
-		<Prop>Case t2 of
-		(*var*)[v2:|(Set_of Var)|] (v1 =%S v2)
-		(*oper*)[op2:|(Set_of (Sigma S))|][_:(LTERM (ap (Arity S) op2))]False
-		end
-	(*oper*)[op1:|(Set_of (Sigma S))|]
-                [l1:(LTERM (ap (Arity S) op1))][t2:TERM]
-                <Prop>Case t2 of
-		(*var*)[v2:|(Set_of Var)|]False
-		(*oper*)[op2:|(Set_of (Sigma S))|]
-                        [l2:(LTERM (ap (Arity S) op2))]
-			((op1=%S op2)/\ (EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2))
-		end
-end
-with EqListT [n1:posint;l1:(LTERM n1)]: (n2:posint)(LTERM n2)->Prop :=
-<[_:posint](n2:posint)(LTERM n2)->Prop>Case l1 of
-	(*nil*) [n2:posint][l2:(LTERM n2)]
-		<[_:posint]Prop>Case l2 of
-		(*nil*)True
-	 	(*cons*)[t2:TERM][n2':posint][l2':(LTERM n2')]False
-	end
-	(*cons*)[t1:TERM][n1':posint][l1':(LTERM n1')]
-		[n2:posint][l2:(LTERM n2)]
-		<[_:posint]Prop>Case l2 of
-		(*nil*) False
-		(*cons*)[t2:TERM][n2':posint][l2':(LTERM n2')]
-			((equalT t1 t2) /\ (EqListT n1' l1' n2' l2'))
-		end
-end.
+Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
+  match t1 return (TERM -> Prop) with
+  | var v1 => 
+      (*var*) 
+      fun t2 : TERM =>
+      match t2 return Prop with
+      | var v2 =>
+          (*var*) equal _ v1 v2
+          (*oper*)
+      | oper op2 _ => False
+      end
+      (*oper*)
+  | oper op1 l1 =>
+      fun t2 : TERM =>
+      match t2 return Prop with
+      | var v2 =>
+          (*var*) False
+          (*oper*)
+      | oper op2 l2 =>
+          equal _ op1 op2 /\
+          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
+      end
+  end
+ 
+ with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} :
+ forall n2 : posint, LTERM n2 -> Prop :=
+  match l1 in (LTERM _) return (forall n2 : posint, LTERM n2 -> Prop) with
+  | nil =>
+      (*nil*) 
+      fun (n2 : posint) (l2 : LTERM n2) =>
+      match l2 in (LTERM _) return Prop with
+      | nil =>
+          (*nil*) True
+          (*cons*)
+      | cons t2 n2' l2' => False
+      end
+      (*cons*)
+  | cons t1 n1' l1' =>
+      fun (n2 : posint) (l2 : LTERM n2) =>
+      match l2 in (LTERM _) return Prop with
+      | nil =>
+          (*nil*)  False
+          (*cons*)
+      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
+      end
+  end.
 
 
 (* ---------------------------------------------------------------- *)
@@ -301,91 +323,97 @@ end.
 (* ---------------------------------------------------------------- *)
 Reset equalT.
 
-Fixpoint equalT [t1:TERM]:TERM->Prop :=
-Cases t1 of 
-  (var  v1) => [t2:TERM]
-	        Cases t2 of
-		     (var v2) => (v1 =%S v2)
-		 | (oper op2 _) =>False
-		 end
-| (oper op1 l1) => [t2:TERM]
-		    Cases t2 of
-	              (var _) => False
-                    | (oper op2 l2) => (op1=%S op2)
-                      /\ (EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2)
-		    end
-end
-with EqListT [n1:posint;l1:(LTERM n1)]: (n2:posint)(LTERM n2)->Prop :=
-<[_:posint](n2:posint)(LTERM n2)->Prop>Cases l1 of
-  nil => [n2:posint][l2:(LTERM n2)]
-          Cases l2 of
-              nil => True
-	  | _  => False
-	  end
-| (cons t1 n1' l1') => [n2:posint][l2:(LTERM n2)]
-		        Cases l2 of
-		           nil =>False
-		        | (cons t2 n2' l2') => (equalT t1 t2) 
-                                                /\ (EqListT n1' l1' n2' l2')
-		end
-end.
+Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
+  match t1 with
+  | var v1 =>
+      fun t2 : TERM =>
+      match t2 with
+      | var v2 => equal _ v1 v2
+      | oper op2 _ => False
+      end
+  | oper op1 l1 =>
+      fun t2 : TERM =>
+      match t2 with
+      | var _ => False
+      | oper op2 l2 =>
+          equal _ op1 op2 /\
+          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
+      end
+  end
+ 
+ with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} :
+ forall n2 : posint, LTERM n2 -> Prop :=
+  match l1 return (forall n2 : posint, LTERM n2 -> Prop) with
+  | nil =>
+      fun (n2 : posint) (l2 : LTERM n2) =>
+      match l2 with
+      | nil => True
+      | _ => False
+      end
+  | cons t1 n1' l1' =>
+      fun (n2 : posint) (l2 : LTERM n2) =>
+      match l2 with
+      | nil => False
+      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
+      end
+  end.
 
 
 Reset equalT.
 
-Fixpoint equalT [t1:TERM]:TERM->Prop :=
-Cases t1 of 
-  (var  v1) => [t2:TERM]
-	        Cases t2 of
-		     (var v2) => (v1 =%S v2)
-		 | (oper op2 _) =>False
-		 end
-| (oper op1 l1) => [t2:TERM]
-		    Cases t2 of
-	              (var _) => False
-                    | (oper op2 l2) => (op1=%S op2)
-                      /\ (EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2)
-		    end
-end
-with EqListT [n1:posint;l1:(LTERM n1)]: (n2:posint)(LTERM n2)->Prop :=
-[n2:posint][l2:(LTERM n2)]
-Cases l1 of
-  nil => 
-          Cases l2 of
-              nil => True
-	  | _  => False
-	  end
-| (cons t1 n1' l1') =>  Cases l2 of
-		           nil =>False
-		        | (cons t2 n2' l2') => (equalT t1 t2) 
-                                                /\ (EqListT n1' l1' n2' l2')
-		end
-end.
+Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
+  match t1 with
+  | var v1 =>
+      fun t2 : TERM =>
+      match t2 with
+      | var v2 => equal _ v1 v2
+      | oper op2 _ => False
+      end
+  | oper op1 l1 =>
+      fun t2 : TERM =>
+      match t2 with
+      | var _ => False
+      | oper op2 l2 =>
+          equal _ op1 op2 /\
+          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
+      end
+  end
+ 
+ with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) 
+ (l2 : LTERM n2) {struct l1} : Prop :=
+  match l1 with
+  | nil => match l2 with
+           | nil => True
+           | _ => False
+           end
+  | cons t1 n1' l1' =>
+      match l2 with
+      | nil => False
+      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
+      end
+  end.
 
 (* ---------------------------------------------------------------- *)
 (*                  Version with multiple patterns                  *)
 (* ---------------------------------------------------------------- *)
 Reset equalT.
 
-Fixpoint equalT [t1:TERM]:TERM->Prop :=
-[t2:TERM] 
- Cases t1 t2 of 
-   (var  v1)       (var v2)     => (v1 =%S v2)
-
- | (oper op1 l1)  (oper op2 l2) => 
-     (op1=%S op2) /\ (EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2)
-
- |  _               _ => False 
- end
-
-with EqListT [n1:posint;l1:(LTERM n1)]: (n2:posint)(LTERM n2)->Prop :=
-[n2:posint][l2:(LTERM n2)]
- Cases l1 l2 of
-    nil                nil              => True 
- | (cons t1 n1' l1')  (cons t2 n2' l2') => (equalT t1 t2) 
-                                          /\ (EqListT n1' l1' n2'  l2')
- | _ _ => False
-end.
+Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop :=
+  match t1, t2 with
+  | var v1, var v2 => equal _ v1 v2
+  | oper op1 l1, oper op2 l2 =>
+      equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
+  | _, _ => False
+  end
+ 
+ with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) 
+ (l2 : LTERM n2) {struct l1} : Prop :=
+  match l1, l2 with
+  | nil, nil => True
+  | cons t1 n1' l1', cons t2 n2' l2' =>
+      equalT t1 t2 /\ EqListT n1' l1' n2' l2'
+  | _, _ => False
+  end.
 
 
 (* ------------------------------------------------------------------ *)
@@ -394,12 +422,11 @@ End Sig.
 
 (* Exemple soumis par Bruno *)
 
-Definition bProp [b:bool] : Prop :=
-  if b then True else False.
+Definition bProp (b : bool) : Prop := if b then True else False.
 
-Definition f0 [F:False;ty:bool]: (bProp ty) :=
-  <[_:bool][ty:bool](bProp ty)>Cases ty ty of
-    true true => I
-  | _ false => F
-  | _ true => I
+Definition f0 (F : False) (ty : bool) : bProp ty :=
+  match ty as _, ty return (bProp ty) with
+  | true, true => I
+  | _, false => F
+  | _, true => I
   end.
diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v
index 5d183528..a20490cc 100644
--- a/test-suite/success/Check.v
+++ b/test-suite/success/Check.v
@@ -9,6 +9,6 @@
 (* This file tests that pretty-printing does not fail                        *)
 (* Test of exact output is not specified                                     *)
 
-Check O.
+Check 0.
 Check S.
 Check nat.
diff --git a/test-suite/success/Conjecture.v b/test-suite/success/Conjecture.v
index 6db5859b..ea4b5ff7 100644
--- a/test-suite/success/Conjecture.v
+++ b/test-suite/success/Conjecture.v
@@ -1,13 +1,13 @@
 (* Check keywords Conjecture and Admitted are recognized *)
 
-Conjecture c : (n:nat)n=O.
+Conjecture c : forall n : nat, n = 0.
 
 Check c.
 
-Theorem d : (n:nat)n=O.
+Theorem d : forall n : nat, n = 0.
 Proof.
-  NewInduction n.
-  Reflexivity.
-  Assert H:False.
-  2:NewDestruct H.
+  induction n.
+  reflexivity.
+  assert (H : False).
+  2: destruct H.
 Admitted.
diff --git a/test-suite/success/DHyp.v b/test-suite/success/DHyp.v
index 73907bc4..8b137891 100644
--- a/test-suite/success/DHyp.v
+++ b/test-suite/success/DHyp.v
@@ -1,14 +1 @@
-V7only [
-HintDestruct Hypothesis h1 (le ? O) 3 [Fun I -> Inversion I ].
 
-Lemma lem1 : ~(le (S O) O).
-Intro H.
-DHyp H.
-Qed.
-
-HintDestruct Conclusion h2 (le O ?) 3 [Constructor].
-
-Lemma lem2 : (le O O).
-DConcl.
-Qed.
-].
diff --git a/test-suite/success/Decompose.v b/test-suite/success/Decompose.v
index 21a3ab5d..1316cbf9 100644
--- a/test-suite/success/Decompose.v
+++ b/test-suite/success/Decompose.v
@@ -1,7 +1,9 @@
 (* This was a Decompose bug reported by Randy Pollack (29 Mar 2000) *)
 
-Goal (O=O/\((x:nat)(x=x)->(x=x)/\((y:nat)y=y->y=y)))-> True.
-Intro H.
-Decompose [and] H. (* Was failing *)
+Goal
+0 = 0 /\ (forall x : nat, x = x -> x = x /\ (forall y : nat, y = y -> y = y)) ->
+True.
+intro H.
+decompose [and] H. (* Was failing *)
 
 Abort.
diff --git a/test-suite/success/Destruct.v b/test-suite/success/Destruct.v
deleted file mode 100644
index fdd929bb..00000000
--- a/test-suite/success/Destruct.v
+++ /dev/null
@@ -1,13 +0,0 @@
-(* Submitted by Robert Schneck *)
-
-Parameter A,B,C,D : Prop.
-Axiom X : A->B->C/\D.
-
-Lemma foo : A->B->C.
-Proof.
-Intros. 
-NewDestruct X. (* Should find axiom X and should handle arguments of X *)
-Assumption.
-Assumption.
-Assumption.
-Qed.
diff --git a/test-suite/success/DiscrR.v b/test-suite/success/DiscrR.v
index 5d12098f..54528fb5 100644
--- a/test-suite/success/DiscrR.v
+++ b/test-suite/success/DiscrR.v
@@ -1,41 +1,41 @@
-Require Reals.
-Require DiscrR.
+Require Import Reals.
+Require Import DiscrR.
 
-Lemma ex0: ``1<>0``.
+Lemma ex0 : 1%R <> 0%R.
 Proof.
-  DiscrR.
-Save.
+  discrR.
+Qed.
 
-Lemma ex1: ``0<>2``.
+Lemma ex1 : 0%R <> 2%R.
 Proof.
-  DiscrR.
-Save.
-Lemma ex2: ``4<>3``.
+  discrR.
+Qed.
+Lemma ex2 : 4%R <> 3%R.
 Proof.
-  DiscrR.
-Save.
+  discrR.
+Qed.
 
-Lemma ex3: ``3<>5``.
+Lemma ex3 : 3%R <> 5%R.
 Proof.
-  DiscrR.
-Save.
+  discrR.
+Qed.
 
-Lemma ex4: ``-1<>0``.
+Lemma ex4 : (-1)%R <> 0%R.
 Proof.
-  DiscrR.
-Save.
+  discrR.
+Qed.
 
-Lemma ex5: ``-2<>-3``.
+Lemma ex5 : (-2)%R <> (-3)%R.
 Proof.
-  DiscrR.
-Save.
+  discrR.
+Qed.
 
-Lemma ex6: ``8<>-3``.
+Lemma ex6 : 8%R <> (-3)%R.
 Proof.
-  DiscrR.
-Save.
+  discrR.
+Qed.
 
-Lemma ex7: ``-8<>3``.
+Lemma ex7 : (-8)%R <> 3%R.
 Proof.
-  DiscrR.
-Save.
+  discrR.
+Qed.
diff --git a/test-suite/success/Discriminate.v b/test-suite/success/Discriminate.v
index 39d2f4bb..f28c83de 100644
--- a/test-suite/success/Discriminate.v
+++ b/test-suite/success/Discriminate.v
@@ -2,10 +2,10 @@
 
 (* Check that Discriminate tries Intro until *)
 
-Lemma l1 : O=(S O)->False.   
-Discriminate 1.
+Lemma l1 : 0 = 1 -> False.   
+ discriminate 1.
 Qed.
 
-Lemma l2 : (H:O=(S O))H==H.   
-Discriminate H.
+Lemma l2 : forall H : 0 = 1, H = H.   
+ discriminate H.
 Qed.
diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v
index c203b739..b4c06c7b 100644
--- a/test-suite/success/Field.v
+++ b/test-suite/success/Field.v
@@ -6,66 +6,86 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Field.v,v 1.1.16.1 2004/07/16 19:30:58 herbelin Exp $ *)
+(* $Id: Field.v 9197 2006-10-02 15:55:52Z barras $ *)
 
 (**** Tests of Field with real numbers ****)
 
-Require Reals.
+Require Import Reals RealField.
+Open Scope R_scope.
 
 (* Example 1 *)
-Goal (eps:R)``eps*1/(2+2)+eps*1/(2+2) == eps*1/2``.
+Goal
+forall eps : R,
+eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)) = eps * (1 / 2).
 Proof.
-  Intros.
-  Field.
-Abort.
+  intros.
+   field.
+Qed.
 
 (* Example 2 *)
-Goal  (f,g:(R->R); x0,x1:R)
-    ``((f x1)-(f x0))*1/(x1-x0)+((g x1)-(g x0))*1/(x1-x0) == ((f x1)+
-    (g x1)-((f x0)+(g x0)))*1/(x1-x0)``.
+Goal
+forall (f g : R -> R) (x0 x1 : R),
+(f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)) =
+(f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)).
 Proof.
-  Intros.
-  Field.
+  intros.
+   field.
 Abort.
  
 (* Example 3 *)
-Goal (a,b:R)``1/(a*b)*1/1/b == 1/a``.
+Goal forall a b : R, 1 / (a * b) * (1 / (1 / b)) = 1 / a.
+Proof.
+  intros.
+   field.
+Abort.
+
+Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a.
 Proof.
-  Intros.
-  Field.
+  intros.
+   field_simplify_eq.
 Abort.
  
-(* Example 4 *)
-Goal (a,b:R)``a <> 0``->``b <> 0``->``1/(a*b)/1/b == 1/a``.
+Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a.
 Proof.
-  Intros.
-  Field.
+  intros.
+   field_simplify (1 / (a * b) * (1 / 1 / b)).
 Abort.
+
+(* Example 4 *)
+Goal
+forall a b : R, a <> 0 -> b <> 0 -> 1 / (a * b) / (1 / b) = 1 / a.
+Proof.
+  intros.
+   field; auto.
+Qed.
  
 (* Example 5 *)
-Goal (a:R)``1 == 1*1/a*a``.
+Goal forall a : R, 1 = 1 * (1 / a) * a.
 Proof.
-  Intros.
-  Field.
+  intros.
+   field.
 Abort.
  
 (* Example 6 *)
-Goal (a,b:R)``b == b*/a*a``.
+Goal forall a b : R, b = b * / a * a.
 Proof.
-  Intros.
-  Field.
+  intros.
+   field.
 Abort.
  
 (* Example 7 *)
-Goal (a,b:R)``b == b*1/a*a``.
+Goal forall a b : R, b = b * (1 / a) * a.
 Proof.
-  Intros.
-  Field.
+  intros.
+   field.
 Abort.
 
 (* Example 8 *)
-Goal (x,y:R)``x*((1/x)+x/(x+y)) == -(1/y)*y*(-(x*x/(x+y))-1)``.
+Goal
+forall x y : R,
+x * (1 / x + x / (x + y)) =
+- (1 / y) * y * (- (x * (x / (x + y))) - 1).
 Proof.
-  Intros.
-  Field.
+  intros.
+   field.
 Abort.
diff --git a/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v
new file mode 100644
index 00000000..680046da
--- /dev/null
+++ b/test-suite/success/Fixpoint.v
@@ -0,0 +1,31 @@
+(* Playing with (co-)fixpoints with local definitions *)
+
+Inductive listn : nat -> Set :=
+  niln : listn 0
+| consn : forall n:nat, nat -> listn n -> listn (S n).
+
+Fixpoint f (n:nat) (m:=pred n) (l:listn m) (p:=S n) {struct l} : nat :=
+   match n with O => p | _ => 
+     match l with niln => p | consn q _ l => f (S q) l end
+   end.
+
+Eval compute in (f 2 (consn 0 0 niln)).
+
+CoInductive Stream : nat -> Set :=
+  Consn : forall n, nat -> Stream n -> Stream (S n).
+
+CoFixpoint g (n:nat) (m:=pred n) (l:Stream m) (p:=S n) : Stream p :=
+    match n return (let m:=pred n in forall l:Stream m, let p:=S n in Stream p)
+    with
+    | O => fun l:Stream 0 => Consn O 0 l
+    | S n' =>
+      fun l:Stream n' =>
+      let l' :=
+        match l in Stream q return Stream (pred q) with Consn _ _ l => l end
+      in
+      let a := match l with Consn _ a l => a end in
+      Consn (S n') (S a) (g n' l')
+   end l.
+
+Eval compute in (fun l => match g 2 (Consn 0 6 l) with Consn _ a _ => a end).
+
diff --git a/test-suite/success/Fourier.v b/test-suite/success/Fourier.v
index f1f7ae08..2d184fef 100644
--- a/test-suite/success/Fourier.v
+++ b/test-suite/success/Fourier.v
@@ -1,16 +1,12 @@
-Require Rfunctions.
-Require Fourier.
+Require Import Rfunctions.
+Require Import Fourier.
  
-Lemma l1:
- (x, y, z : R)
-  ``(Rabsolu x-z) <= (Rabsolu x-y)+(Rabsolu y-z)``.
-Intros; SplitAbsolu; Fourier.
+Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z).
+intros; split_Rabs; fourier.
 Qed.
  
-Lemma l2:
- (x, y : R)
- ``x < (Rabsolu y)`` ->
- ``y < 1`` -> ``x >= 0`` -> ``-y <= 1`` ->  ``(Rabsolu x) <= 1``.
-Intros.
-SplitAbsolu; Fourier.
+Lemma l2 :
+ forall x y : R, x < Rabs y -> y < 1 -> x >= 0 -> - y <= 1 -> Rabs x <= 1.
+intros.
+split_Rabs; fourier.
 Qed.
diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v
index 819da259..1c3e56f2 100644
--- a/test-suite/success/Funind.v
+++ b/test-suite/success/Funind.v
@@ -1,80 +1,82 @@
 
-Definition iszero [n:nat] : bool := Cases n of
-                                    | O => true
-                                    | _ => false
-                                    end.
+Definition iszero (n : nat) : bool :=
+  match n with
+  | O => true
+  | _ => false
+  end.
 
-Functional Scheme iszer_ind := Induction for iszero.
+Functional Scheme iszero_ind := Induction for iszero Sort Prop.
  
-Lemma toto : (n:nat) n = 0 -> (iszero n) = true.
-Intros x eg.
-Functional Induction iszero x; Simpl.
-Trivial.
-Subst x.
-Inversion H_eq_.
+Lemma toto : forall n : nat, n = 0 -> iszero n = true.
+intros x eg.
+ functional induction iszero x; simpl in |- *.
+trivial.
+inversion eg.
 Qed.
 
-(* We can even reuse the proof as a scheme: *)
-
-Functional Scheme toto_ind := Induction for iszero.
-
-
-
-
  
-Definition ftest [n, m:nat] : nat :=
-  Cases n of
-  | O => Cases m of
+Function ftest (n m : nat) : nat :=
+  match n with
+  | O => match m with
          | O => 0
          | _ => 1
          end
-  | (S p) => 0
+  | S p => 0
   end.
 
-Functional Scheme ftest_ind := Induction for ftest. 
-
-Lemma test1 : (n,m:nat) (le (ftest n m) 2).
-Intros n m.
-Functional Induction ftest n m;Auto.
-Save.
+Lemma test1 : forall n m : nat, ftest n m <= 2.
+intros n m.
+ functional induction ftest n m; auto.
+Qed.
 
+Lemma test2 : forall m n, ~ 2 = ftest n m.
+Proof. 
+intros n m;intro H.
+functional inversion H ftest.
+Qed.
 
-Lemma test11 : (m:nat) (le (ftest 0 m) 2).
-Intros m.
-Functional Induction ftest 0 m.
-Auto. 
-Auto. 
+Lemma test3 : forall n m, ftest n m = 0 -> (n = 0 /\ m = 0)  \/ n <> 0.
+Proof.
+functional inversion 1 ftest;auto.
 Qed.
 
 
-Definition lamfix :=
-[m:nat ]
-(Fix trivfun {trivfun [n:nat] : nat := Cases n of
-                              | O => m
-                              | (S p) => (trivfun p)
-                              end}).
+Require Import Arith.
+Lemma test11 : forall m : nat, ftest 0 m <= 2.
+intros m.
+ functional induction ftest 0 m.
+auto. 
+auto.
+auto with *. 
+Qed.
+
+Function lamfix (m n : nat) {struct n } : nat :=
+  match n with
+    | O => m
+    | S p => lamfix m p
+  end.
 
 (* Parameter v1 v2 : nat. *)
 
-Lemma lamfix_lem : (v1,v2:nat) (lamfix v1 v2) = v1.
-Intros v1 v2.
-Functional Induction lamfix v1 v2.
-Trivial.
-Assumption.
+Lemma lamfix_lem : forall v1 v2 : nat, lamfix v1 v2 = v1.
+intros v1 v2.
+ functional induction lamfix v1 v2.
+trivial.
+assumption.
 Defined.
 
 
 
 (* polymorphic function *)
-Require PolyList.
+Require Import List.
 
-Functional Scheme app_ind := Induction for app.
+Functional Scheme app_ind := Induction for app Sort Prop.
 
-Lemma appnil : (A:Set)(l,l':(list A)) l'=(nil A) ->  l = (app l l').
-Intros A l l'.
-Functional Induction app A l l';Intuition.
-Rewrite <- H1;Trivial.
-Save.
+Lemma appnil : forall (A : Set) (l l' : list A), l' = nil -> l = l ++ l'.
+intros A l l'.
+ functional induction app A l l';  intuition.
+ rewrite <- H0; trivial.
+Qed.
 
 
 
@@ -83,10 +85,10 @@ Save.
 Require Export Arith.
 
 
-Fixpoint trivfun [n:nat] : nat :=
-  Cases n of
+Function trivfun (n : nat) : nat :=
+  match n with
   | O => 0
-  | (S m) => (trivfun m)
+  | S m => trivfun m
   end.
 
 
@@ -94,22 +96,20 @@ Fixpoint trivfun [n:nat] : nat :=
 
 Parameter varessai : nat.
 
-Lemma first_try : (trivfun varessai) = 0.
-Functional Induction trivfun varessai.
-Trivial.
-Simpl.
-Assumption.
+Lemma first_try : trivfun varessai = 0.
+ functional induction trivfun varessai.
+trivial.
+assumption.
 Defined.
  
 
-Functional Scheme triv_ind := Induction for trivfun.
+ Functional Scheme triv_ind := Induction for trivfun Sort Prop.
 
-Lemma bisrepetita : (n':nat) (trivfun n') = 0.
-Intros n'.
-Functional Induction trivfun n'.
-Trivial.
-Simpl .
-Assumption.
+Lemma bisrepetita : forall n' : nat, trivfun n' = 0.
+intros n'.
+ functional induction trivfun n'.
+trivial.
+assumption.
 Qed.
 
 
@@ -118,318 +118,388 @@ Qed.
 
 
 
-Fixpoint iseven [n:nat] : bool :=
-  Cases n of
+Function iseven (n : nat) : bool :=
+  match n with
   | O => true
-  | (S (S m)) => (iseven m)
+  | S (S m) => iseven m
   | _ => false
   end.
- 
-Fixpoint funex [n:nat] : nat :=
-  Cases (iseven n) of
+
+
+Function funex (n : nat) : nat :=
+  match iseven n with
   | true => n
-  | false => Cases n of
+  | false => match n with
              | O => 0
-             | (S r) => (funex r)
+             | S r => funex r
              end
   end.
  
-Fixpoint nat_equal_bool [n:nat]  : nat -> bool :=
-[m:nat]
-  Cases n of
-  | O => Cases m of
+
+Function nat_equal_bool (n m : nat) {struct n} : bool :=
+  match n with
+  | O => match m with
          | O => true
          | _ => false
          end
-  | (S p) => Cases m of
+  | S p => match m with
            | O => false
-           | (S q) => (nat_equal_bool p q)
+           | S q => nat_equal_bool p q
            end
   end.
 
 
 Require Export Div2.
  
-Lemma div2_inf : (n:nat) (le (div2 n) n).
-Intros n.
-Functional Induction div2 n.
-Auto.
-Auto.
+Functional Scheme div2_ind := Induction for div2 Sort Prop.
+Lemma div2_inf : forall n : nat, div2 n <= n.
+intros n.
+ functional induction div2 n.
+auto.
+auto.
 
-Apply le_S.
-Apply le_n_S.
-Exact H.
+apply le_S.
+apply le_n_S.
+exact IHn0.
 Qed.
 
 (* reuse this lemma as a scheme:*)
 
-Functional Scheme div2_ind := Induction for div2_inf.
-
-Fixpoint nested_lam [n:nat] : nat -> nat :=
-  Cases n of
-  | O => [m:nat ] 0
-  | (S n') => [m:nat ] (plus m (nested_lam n' m))
+Function nested_lam (n : nat) : nat -> nat :=
+  match n with
+  | O => fun m : nat => 0
+  | S n' => fun m : nat => m + nested_lam n' m
   end.
 
-Functional Scheme nested_lam_ind := Induction for nested_lam.
 
-Lemma nest : (n, m:nat) (nested_lam n m) = (mult n m).
-Intros n m.
-Functional Induction nested_lam n m; Auto.
+Lemma nest : forall n m : nat, nested_lam n m = n * m.
+intros n m.
+ functional induction nested_lam n m; simpl;auto.
 Qed.
 
-Lemma nest2 : (n, m:nat) (nested_lam n m) = (mult n m).
-Intros n m. Pattern n m . 
-Apply nested_lam_ind; Simpl ; Intros; Auto.
+ 
+Function essai (x : nat) (p : nat * nat) {struct x} : nat :=
+  let (n, m) := (p: nat*nat) in
+  match n with
+  | O => 0
+  | S q => match x with
+           | O => 1
+           | S r => S (essai r (q, m))
+           end
+  end.
+ 
+Lemma essai_essai :
+ forall (x : nat) (p : nat * nat), let (n, m) := p in 0 < n -> 0 < essai x p.
+intros x p.
+ functional induction essai x p; intros.
+inversion H.
+auto with arith.
+ auto with arith.
 Qed.
 
+Function plus_x_not_five'' (n m : nat) {struct n} : nat :=
+  let x := nat_equal_bool m 5 in
+  let y := 0 in
+  match n with
+  | O => y
+  | S q =>
+      let recapp := plus_x_not_five'' q m in
+      match x with
+      | true => S recapp
+      | false => S recapp
+      end
+  end.
  
-Fixpoint essai [x : nat] : nat * nat ->  nat :=
- [p : nat * nat]  ( Case p of [n, m : ?]  Cases n of
-                                            O => O
-                                           | (S q) =>
-                                               Cases x of
-                                                 O => (S O)
-                                                | (S r) => (S (essai r (q, m)))
-                                               end
-                                          end end ).
+Lemma notplusfive'' : forall x y : nat, y = 5 -> plus_x_not_five'' x y = x.
+intros a b.
+ functional induction plus_x_not_five'' a b; intros hyp; simpl in |- *; auto.
+Qed.
  
-Lemma essai_essai:
- (x : nat)
- (p : nat * nat)  ( Case p of [n, m : ?] (lt O n) ->  (lt O (essai x p)) end ).
-Intros x p.
-(Functional Induction essai x p); Intros.
-Inversion H.
-Simpl; Try Abstract ( Auto with arith ).
-Simpl; Try Abstract ( Auto with arith ).
+Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true.
+intros n m.
+ functional induction nat_equal_bool n m; simpl in |- *; intros hyp; auto.
+rewrite <- hyp in y; simpl in y;tauto. 
+inversion hyp.
+Qed.
+ 
+Lemma iseq_eq' : forall n m : nat, nat_equal_bool n m = true -> n = m.
+intros n m.
+ functional induction nat_equal_bool n m; simpl in |- *; intros eg; auto.
+inversion eg.
+inversion eg.
+Qed.
+ 
+ 
+Inductive istrue : bool -> Prop :=
+    istrue0 : istrue true.
+ 
+Functional Scheme plus_ind := Induction for plus Sort Prop.
+
+Lemma inf_x_plusxy' : forall x y : nat, x <= x + y.
+intros n m.
+ functional induction plus n m; intros.
+auto with arith.
+auto with arith.
 Qed.
 
  
-Fixpoint plus_x_not_five'' [n : nat] : nat ->  nat :=
- [m : nat]  let x = (nat_equal_bool m (S (S (S (S (S O)))))) in
-              let y = O in
-                Cases n of
-                  O => y
-                 | (S q) =>
-                     let recapp = (plus_x_not_five'' q m) in
-                       Cases x of true => (S recapp) | false => (S recapp) end
-                end.
+Lemma inf_x_plusxy'' : forall x : nat, x <= x + 0.
+intros n.
+unfold plus in |- *.
+ functional induction plus n 0; intros.
+auto with arith.
+apply le_n_S.
+assumption.
+Qed.
  
-Lemma notplusfive'':
- (x, y : nat) y = (S (S (S (S (S O))))) ->  (plus_x_not_five'' x y) = x.
-Intros a b.
-Unfold plus_x_not_five''.
-(Functional Induction plus_x_not_five'' a b); Intros hyp; Simpl; Auto.
+Lemma inf_x_plusxy''' : forall x : nat, x <= 0 + x.
+intros n.
+ functional induction plus 0 n; intros; auto with arith.
 Qed.
+
+Function mod2 (n : nat) : nat :=
+  match n with
+  | O => 0
+  | S (S m) => S (mod2 m)
+  | _ => 0
+  end.
  
-Lemma iseq_eq: (n, m : nat) n = m ->  (nat_equal_bool n m) = true.
-Intros n m.
-Unfold nat_equal_bool.
-(Functional Induction nat_equal_bool n m); Simpl; Intros hyp; Auto.
-Inversion hyp.
-Inversion hyp.
+Lemma princ_mod2 : forall n : nat, mod2 n <= n.
+intros n.
+ functional induction mod2 n; simpl in |- *; auto with arith.
 Qed.
  
-Lemma iseq_eq': (n, m : nat) (nat_equal_bool n m) = true ->  n = m.
-Intros n m.
-Unfold nat_equal_bool.
-(Functional Induction nat_equal_bool n m); Simpl; Intros eg; Auto.
-Inversion eg.
-Inversion eg.
+Function isfour (n : nat) : bool :=
+  match n with
+  | S (S (S (S O))) => true
+  | _ => false
+  end.
+ 
+Function isononeorfour (n : nat) : bool :=
+  match n with
+  | S O => true
+  | S (S (S (S O))) => true
+  | _ => false
+  end.
+ 
+Lemma toto'' : forall n : nat, istrue (isfour n) -> istrue (isononeorfour n).
+intros n.
+ functional induction isononeorfour n; intros istr; simpl in |- *;
+ inversion istr.
+apply istrue0.
+destruct n. inversion istr.
+destruct n. tauto.
+destruct n. inversion istr.
+destruct n. inversion istr.
+destruct n. tauto.
+simpl in *. inversion H0.
 Qed.
  
+Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n).
+intros n.
+ functional induction isononeorfour n; intros m istr; inversion istr.
+apply istrue0.
+rewrite H in y; simpl in y;tauto.
+Qed.
  
-Inductive istrue : bool ->  Prop :=
-  istrue0: (istrue true) .
+Function ftest4 (n m : nat) : nat :=
+  match n with
+  | O => match m with
+         | O => 0
+         | S q => 1
+         end
+  | S p => match m with
+           | O => 0
+           | S r => 1
+           end
+  end.
  
-Lemma inf_x_plusxy': (x, y : nat)  (le x (plus x y)).
-Intros n m.
-(Functional Induction plus n m); Intros.
-Auto with arith.
-Auto with arith.
+Lemma test4 : forall n m : nat, ftest n m <= 2.
+intros n m.
+ functional induction ftest n m; auto with arith.
 Qed.
-
  
-Lemma inf_x_plusxy'': (x : nat)  (le x (plus x O)).
-Intros n.
-Unfold plus.
-(Functional Induction plus n O); Intros.
-Auto with arith.
-Apply le_n_S.
-Assumption.
+Lemma test4' : forall n m : nat, ftest4 (S n) m <= 2.
+intros n m.
+assert ({n0 | n0 = S n}).
+exists (S n);reflexivity.
+destruct H as [n0 H1].
+rewrite <- H1;revert H1.
+ functional induction ftest4 n0 m.
+inversion 1.
+inversion 1.
+
+auto with arith.
+auto with arith.
 Qed.
  
-Lemma inf_x_plusxy''': (x : nat)  (le x (plus O x)).
-Intros n.
-(Functional Induction plus O n); Intros;Auto with arith.
+Function ftest44 (x : nat * nat) (n m : nat) : nat :=
+  let (p, q) := (x: nat*nat) in
+  match n with
+  | O => match m with
+         | O => 0
+         | S q => 1
+         end
+  | S p => match m with
+           | O => 0
+           | S r => 1
+           end
+  end.
+ 
+Lemma test44 :
+ forall (pq : nat * nat) (n m o r s : nat), ftest44 pq n (S m) <= 2.
+intros pq n m o r s.
+ functional induction ftest44 pq n (S m).
+auto with arith.
+auto with arith.
+auto with arith.
+auto with arith.
 Qed.
-
-Fixpoint mod2 [n : nat] : nat :=
- Cases n of   O => O
-             | (S (S m)) => (S (mod2 m))
-             | _ => O end.
  
-Lemma princ_mod2: (n : nat)  (le (mod2 n) n).
-Intros n.
-(Functional Induction mod2 n); Simpl; Auto with arith.
+Function ftest2 (n m : nat) {struct n} : nat :=
+  match n with
+  | O => match m with
+         | O => 0
+         | S q => 0
+         end
+  | S p => ftest2 p m
+  end.
+ 
+Lemma test2' : forall n m : nat, ftest2 n m <= 2.
+intros n m.
+ functional induction ftest2 n m; simpl in |- *; intros; auto.
+Qed.
+ 
+Function ftest3 (n m : nat) {struct n} : nat :=
+  match n with
+  | O => 0
+  | S p => match m with
+           | O => ftest3 p 0
+           | S r => 0
+           end
+  end.
+ 
+Lemma test3' : forall n m : nat, ftest3 n m <= 2.
+intros n m.
+ functional induction ftest3 n m.
+intros.
+auto.
+intros.
+auto.
+intros.
+simpl in |- *.
+auto.
 Qed.
- 
-Definition isfour : nat ->  bool :=
-   [n : nat]  Cases n of (S (S (S (S O)))) => true | _ => false end.
- 
-Definition isononeorfour : nat ->  bool :=
-   [n : nat]  Cases n of   (S O) => true
-                          | (S (S (S (S O)))) => true
-                          | _ => false end.
- 
-Lemma toto'': (n : nat) (istrue (isfour n)) ->  (istrue (isononeorfour n)).
-Intros n.
-(Functional Induction isononeorfour n); Intros istr; Simpl; Inversion istr.
-Apply istrue0.
-Qed.
- 
-Lemma toto': (n, m : nat) n = (S (S (S (S O)))) ->  (istrue (isononeorfour n)).
-Intros n.
-(Functional Induction isononeorfour n); Intros m istr; Inversion istr.
-Apply istrue0.
-Qed.
- 
-Definition ftest4 : nat -> nat ->  nat :=
-   [n, m : nat]  Cases n of
-                   O =>
-                     Cases m of O => O | (S q) => (S O) end
-                  | (S p) =>
-                      Cases m of O => O | (S r) => (S O) end
-                 end.
- 
-Lemma test4: (n, m : nat)  (le (ftest n m) (S (S O))).
-Intros n m.
-(Functional Induction ftest n m); Auto with arith.
-Qed.
- 
-Lemma test4': (n, m : nat)  (le (ftest4 (S n) m) (S (S O))).
-Intros n m.
-(Functional Induction ftest4 (S n) m).
-Auto with arith.
-Auto with arith.
-Qed.
- 
-Definition ftest44 : nat * nat -> nat -> nat ->  nat :=
-   [x : nat * nat]
-   [n, m : nat]
-    ( Case x of [p, q : ?]  Cases n of
-                              O =>
-                                Cases m of O => O | (S q) => (S O) end
-                             | (S p) =>
-                                 Cases m of O => O | (S r) => (S O) end
-                            end end ).
- 
-Lemma test44:
- (pq : nat * nat) (n, m, o, r, s : nat)  (le (ftest44 pq n (S m)) (S (S O))).
-Intros pq n m o r s.
-(Functional Induction ftest44 pq n (S m)).
-Auto with arith.
-Auto with arith.
-Auto with arith.
-Auto with arith.
-Qed.
- 
-Fixpoint ftest2 [n : nat] : nat ->  nat :=
- [m : nat]  Cases n of
-              O =>
-                Cases m of O => O | (S q) => O end
-             | (S p) => (ftest2 p m)
-            end.
- 
-Lemma test2: (n, m : nat)  (le (ftest2 n m) (S (S O))).
-Intros n m.
-(Functional Induction ftest2 n m) ; Simpl; Intros; Auto.
-Qed.
- 
-Fixpoint ftest3 [n : nat] : nat ->  nat :=
- [m : nat]  Cases n of
-              O => O
-             | (S p) =>
-                 Cases m of O => (ftest3 p O) | (S r) => O end
-            end.
- 
-Lemma test3: (n, m : nat)  (le (ftest3 n m) (S (S O))).
-Intros n m.
-(Functional Induction ftest3 n m).
-Intros.
-Auto.
-Intros.
-Auto.
-Intros.
-Simpl.
-Auto.
-Qed.
- 
-Fixpoint ftest5 [n : nat] : nat ->  nat :=
- [m : nat]  Cases n of
-              O => O
-             | (S p) =>
-                 Cases m of O => (ftest5 p O) | (S r) => (ftest5 p r) end
-            end.
- 
-Lemma test5: (n, m : nat)  (le (ftest5 n m) (S (S O))).
-Intros n m.
-(Functional Induction ftest5 n m).
-Intros.
-Auto.
-Intros.
-Auto.
-Intros.
-Simpl.
-Auto.
-Qed.
- 
-Definition ftest7 : (n : nat)  nat :=
-   [n : nat]  Cases (ftest5 n O) of O => O | (S r) => O end.
- 
-Lemma essai7:
- (Hrec : (n : nat) (ftest5 n O) = O ->  (le (ftest7 n) (S (S O))))
- (Hrec0 : (n, r : nat) (ftest5 n O) = (S r) ->  (le (ftest7 n) (S (S O))))
- (n : nat)  (le (ftest7 n) (S (S O))).
-Intros hyp1 hyp2 n.
-Unfold ftest7.
-(Functional Induction ftest7 n); Auto.
-Qed.
- 
-Fixpoint ftest6 [n : nat] : nat ->  nat :=
- [m : nat]
-  Cases n of
-    O => O
-   | (S p) =>
-       Cases (ftest5 p O) of O => (ftest6 p O) | (S r) => (ftest6 p r) end
+ 
+Function ftest5 (n m : nat) {struct n} : nat :=
+  match n with
+  | O => 0
+  | S p => match m with
+           | O => ftest5 p 0
+           | S r => ftest5 p r
+           end
+  end.
+ 
+Lemma test5 : forall n m : nat, ftest5 n m <= 2.
+intros n m.
+ functional induction ftest5 n m.
+intros.
+auto.
+intros.
+auto.
+intros.
+simpl in |- *.
+auto.
+Qed.
+ 
+Function ftest7 (n : nat) : nat :=
+  match ftest5 n 0 with
+  | O => 0
+  | S r => 0
+  end.
+ 
+Lemma essai7 :
+ forall (Hrec : forall n : nat, ftest5 n 0 = 0 -> ftest7 n <= 2)
+   (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2) 
+   (n : nat), ftest7 n <= 2.
+intros hyp1 hyp2 n.
+ functional induction ftest7 n; auto.
+Qed.
+ 
+Function ftest6 (n m : nat) {struct n} : nat :=
+  match n with
+  | O => 0
+  | S p => match ftest5 p 0 with
+           | O => ftest6 p 0
+           | S r => ftest6 p r
+           end
   end.
 
  
-Lemma princ6:
- ((n, m : nat) n = O ->  (le (ftest6 O m) (S (S O)))) ->
- ((n, m, p : nat)
-  (le (ftest6 p O) (S (S O))) ->
-  (ftest5 p O) = O -> n = (S p) ->  (le (ftest6 (S p) m) (S (S O)))) ->
- ((n, m, p, r : nat)
-  (le (ftest6 p r) (S (S O))) ->
-  (ftest5 p O) = (S r) -> n = (S p) ->  (le (ftest6 (S p) m) (S (S O)))) ->
- (x, y : nat)  (le (ftest6 x y) (S (S O))).
-Intros hyp1 hyp2 hyp3 n m.
-Generalize hyp1 hyp2 hyp3.
-Clear hyp1 hyp2 hyp3.
-(Functional Induction ftest6 n m);Auto.
+Lemma princ6 :
+ (forall n m : nat, n = 0 -> ftest6 0 m <= 2) ->
+ (forall n m p : nat,
+  ftest6 p 0 <= 2 -> ftest5 p 0 = 0 -> n = S p -> ftest6 (S p) m <= 2) ->
+ (forall n m p r : nat,
+  ftest6 p r <= 2 -> ftest5 p 0 = S r -> n = S p -> ftest6 (S p) m <= 2) ->
+ forall x y : nat, ftest6 x y <= 2.
+intros hyp1 hyp2 hyp3 n m.
+generalize hyp1 hyp2 hyp3.
+clear hyp1 hyp2 hyp3.
+ functional induction ftest6 n m; auto.
 Qed.
  
-Lemma essai6: (n, m : nat)  (le (ftest6 n m) (S (S O))).
-Intros n m.
-Unfold ftest6.
-(Functional Induction ftest6 n m); Simpl; Auto.
+Lemma essai6 : forall n m : nat, ftest6 n m <= 2.
+intros n m.
+ functional induction ftest6 n m; simpl in |- *; auto.
 Qed.
 
+(* Some tests with modules *) 
+Module M.
+Function test_m (n:nat) : nat := 
+  match n with 
+    | 0 => 0
+    | S n =>  S (S (test_m n))
+  end.
 
+Lemma test_m_is_double :  forall n, div2 (test_m n) = n.
+Proof.
+intros n.
+functional induction (test_m n).
+reflexivity.
+simpl;rewrite IHn0;reflexivity.
+Qed.
+End M.
+(* We redefine a new Function with the same name *) 
+Function test_m (n:nat) : nat := 
+  pred n.
+
+Lemma test_m_is_pred : forall n, test_m n = pred n.
+Proof. 
+intro n.
+functional induction (test_m n). (* the test_m_ind to use is the last defined  saying that test_m = pred*) 
+reflexivity.
+Qed.
 
+(* Checks if the dot notation are correctly treated in infos *)
+Lemma M_test_m_is_double : forall n, div2 (M.test_m n) = n.
+intro n.
+(* here we should apply M.test_m_ind *)
+functional induction (M.test_m n).
+reflexivity.
+simpl;rewrite IHn0;reflexivity.
+Qed.
 
+Import M.
+(* Now test_m is the one which defines double *)
 
+Lemma test_m_is_double : forall n, div2 (M.test_m n) = n.
+intro n.
+(* here we should apply M.test_m_ind *)
+functional induction (test_m n).
+reflexivity.
+simpl;rewrite IHn0;reflexivity.
+Qed.
 
 
 
diff --git a/test-suite/success/Generalize.v b/test-suite/success/Generalize.v
index 0dc73991..980c89dd 100644
--- a/test-suite/success/Generalize.v
+++ b/test-suite/success/Generalize.v
@@ -1,7 +1,8 @@
 (* Check Generalize Dependent *)
 
-Lemma l1 : [a:=O;b:=a](c:b=b;d:(True->b=b))d=d.
-Intros.
-Generalize Dependent a.
-Intros a b c d.
+Lemma l1 :
+ let a := 0 in let b := a in forall (c : b = b) (d : True -> b = b), d = d.
+intros.
+generalize dependent a.
+intros a b c d.
 Abort.
diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v
index f32753e0..e1c74048 100644
--- a/test-suite/success/Hints.v
+++ b/test-suite/success/Hints.v
@@ -2,47 +2,47 @@
 (* Checks that qualified names are accepted *)
 
 (* New-style syntax *)
-Hint h1 : core arith := Resolve Logic.refl_equal.
-Hint h2 := Immediate Logic.trans_equal.
-Hint h3 : core := Unfold Logic.sym_equal.
-Hint h4 : foo bar := Constructors Logic.eq.
-Hint h5 : foo bar := Extern 3 (eq ? ? ?) Apply Logic.refl_equal.
+Hint Resolve refl_equal: core arith.
+Hint Immediate trans_equal.
+Hint Unfold sym_equal: core.
+Hint Constructors eq: foo bar.
+Hint Extern 3 (_ = _) => apply refl_equal: foo bar.
 
 (* Old-style syntax *)
-Hints Resolve Coq.Init.Logic.refl_equal Coq.Init.Logic.sym_equal.
-Hints Resolve Coq.Init.Logic.refl_equal Coq.Init.Logic.sym_equal : foo.
-Hints Immediate Coq.Init.Logic.refl_equal Coq.Init.Logic.sym_equal.
-Hints Immediate Coq.Init.Logic.refl_equal Coq.Init.Logic.sym_equal : foo.
-Hints Unfold Coq.Init.Datatypes.fst Coq.Init.Logic.sym_equal.
-Hints Unfold Coq.Init.Datatypes.fst Coq.Init.Logic.sym_equal : foo.
+Hint Resolve refl_equal sym_equal.
+Hint Resolve refl_equal sym_equal: foo.
+Hint Immediate refl_equal sym_equal.
+Hint Immediate refl_equal sym_equal: foo.
+Hint Unfold fst sym_equal.
+Hint Unfold fst sym_equal: foo.
 
 (* What's this stranged syntax ? *)
-HintDestruct Conclusion h6 (le ? ?) 4 [ Fun H -> Apply H ].
-HintDestruct Discardable Hypothesis h7 (le ? ?) 4 [ Fun H -> Apply H ].
-HintDestruct Hypothesis h8 (le ? ?) 4 [ Fun H -> Apply H ].
+Hint Destruct h6 := 4 Conclusion (_ <= _) => fun H => apply H.
+Hint Destruct h7 := 4 Discardable Hypothesis (_ <= _) => fun H => apply H.
+Hint Destruct h8 := 4 Hypothesis (_ <= _) => fun H => apply H.
 
 (* Checks that local names are accepted *)
 Section A.
-  Remark Refl : (A:Set)(x:A)x=x. 
+  Remark Refl : forall (A : Set) (x : A), x = x. 
   Proof refl_equal.
   Definition Sym := sym_equal.
-  Local Trans := trans_equal.
+  Let Trans := trans_equal.
  
-  Hint h1 : foo := Resolve Refl.
-  Hint h2 : bar := Resolve Sym.
-  Hint h3 : foo2 := Resolve Trans.
+  Hint Resolve Refl: foo.
+  Hint Resolve Sym: bar.
+  Hint Resolve Trans: foo2.
 
-  Hint h2 := Immediate Refl.
-  Hint h2 := Immediate Sym.
-  Hint h2 := Immediate Trans.
+  Hint Immediate Refl.
+  Hint Immediate Sym.
+  Hint Immediate Trans.
 
-  Hint h3 := Unfold Refl.
-  Hint h3 := Unfold Sym.
-  Hint h3 := Unfold Trans.
+  Hint Unfold Refl.
+  Hint Unfold Sym.
+  Hint Unfold Trans.
 
-  Hints Resolve Sym Trans Refl.
-  Hints Immediate Sym Trans Refl.
-  Hints Unfold Sym Trans Refl.
+  Hint Resolve Sym Trans Refl.
+  Hint Immediate Sym Trans Refl.
+  Hint Unfold Sym Trans Refl.
 
 End A.
 
diff --git a/test-suite/success/ImplicitTactic.v b/test-suite/success/ImplicitTactic.v
new file mode 100644
index 00000000..d8fa3043
--- /dev/null
+++ b/test-suite/success/ImplicitTactic.v
@@ -0,0 +1,16 @@
+(* A Wiedijk-Cruz-Filipe style tactic for solving implicit arguments *)
+
+(* Declare a term expression with a hole *)
+Parameter quo : nat -> forall n:nat, n<>0 -> nat.
+Notation "x / y" := (quo x y _) : nat_scope.
+
+(* Declare the tactic for resolving implicit arguments still
+   unresolved after type-checking; it must complete the subgoal to
+   succeed *)
+Declare Implicit Tactic assumption.
+
+Goal forall n d, d<>0 -> { q:nat & { r:nat | d * q + r = n }}.
+intros.
+(* Here, assumption is used to solve the implicit argument of quo *)
+exists (n / d).
+
diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v
index 87431a75..1adcbd39 100644
--- a/test-suite/success/Inductive.v
+++ b/test-suite/success/Inductive.v
@@ -1,34 +1,52 @@
 (* Check local definitions in context of inductive types *)
-Inductive A [C,D:Prop; E:=C; F:=D; x,y:E->F] : E -> Set :=
-   I : (z:E)(A C D x y z).
+Inductive A (C D : Prop) (E:=C) (F:=D) (x y : E -> F) : E -> Set :=
+    I : forall z : E, A C D x y z.
 
 Check
-   [C,D:Prop; E:=C; F:=D; x,y:(E ->F);
-    P:((c:C)(A C D x y c) ->Type);
-    f:((z:C)(P z (I C D x y z)));
-    y0:C; a:(A C D x y y0)]
-    <[y1:C; a0:(A C D x y y1)](P y1 a0)>Cases a of (I x0) => (f x0) end.
-
-Record B [C,D:Set; E:=C; F:=D; x,y:E->F] : Set := { p : C; q : E }.
+  (fun C D : Prop =>
+   let E := C in
+   let F := D in
+   fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type)
+     (f : forall z : C, P z (I C D x y z)) (y0 : C) 
+     (a : A C D x y y0) =>
+   match a as a0 in (A _ _ _ _ y1) return (P y1 a0) with
+   | I x0 => f x0
+   end).
+
+Record B (C D : Set) (E:=C) (F:=D) (x y : E -> F) : Set :=  {p : C; q : E}.
 
 Check
-   [C,D:Set; E:=C; F:=D; x,y:(E ->F);
-    P:((B C D x y) ->Type);
-    f:((p0,q0:C)(P (Build_B C D x y p0 q0)));
-    b:(B C D x y)]
-    <[b0:(B C D x y)](P b0)>Cases b of (Build_B x0 x1) => (f x0 x1) end.
+  (fun C D : Set =>
+   let E := C in
+   let F := D in
+   fun (x y : E -> F) (P : B C D x y -> Type)
+     (f : forall p0 q0 : C, P (Build_B C D x y p0 q0)) 
+     (b : B C D x y) =>
+   match b as b0 return (P b0) with
+   | Build_B x0 x1 => f x0 x1
+   end).
 
 (* Check implicit parameters of inductive types (submitted by Pierre
   Casteran and also implicit in #338) *)
 
 Set Implicit Arguments.
+Unset Strict Implicit.
+
+CoInductive LList (A : Set) : Set :=
+  | LNil : LList A
+  | LCons : A -> LList A -> LList A.
+
+Implicit Arguments LNil [A].
+
+Inductive Finite (A : Set) : LList A -> Prop :=
+  | Finite_LNil : Finite LNil
+  | Finite_LCons :
+      forall (a : A) (l : LList A), Finite l -> Finite (LCons a l).
+
+(* Check positivity modulo reduction (cf bug #983) *)
 
-CoInductive LList [A:Set] : Set :=
-   | LNil : (LList A)
-   | LCons : A -> (LList A) -> (LList A).
+Record P:Type := {PA:Set; PB:Set}.
 
-Implicits LNil [1].
+Definition F (p:P) := (PA p) -> (PB p).
 
-Inductive Finite [A:Set] : (LList A) -> Prop :=
-   | Finite_LNil : (Finite LNil)
-   | Finite_LCons : (a:A) (l:(LList A)) (Finite l) -> (Finite (LCons a l)).
+Inductive I_F:Set := c : (F (Build_P nat I_F)) -> I_F.
diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v
index fd80cec6..606e884a 100644
--- a/test-suite/success/Injection.v
+++ b/test-suite/success/Injection.v
@@ -2,33 +2,63 @@
 
 (* Check that Injection tries Intro until *)
 
-Lemma l1 : (x:nat)(S x)=(S (S x))->False.
-Injection 1.
-Apply n_Sn.
+Lemma l1 : forall x : nat, S x = S (S x) -> False.
+ injection 1.
+apply n_Sn.
 Qed.
 
-Lemma l2 : (x:nat)(H:(S x)=(S (S x)))H==H->False.
-Injection H.
-Intros.
-Apply (n_Sn x H0).
+Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False.
+ injection H.
+intros.
+apply (n_Sn x H0).
 Qed.
 
 (* Check that no tuple needs to be built *)
-Lemma l3 : (x,y:nat)
-     (existS ? [n:nat]({n=n}+{n=n}) x (left ? ? (refl_equal nat x)))=
-     (existS ? [n:nat]({n=n}+{n=n}) y (left ? ? (refl_equal nat y)))
-  -> x=y.
-Intros x y H.
-Injection H.
-Exact [H]H.
+Lemma l3 :
+ forall x y : nat,
+ existS (fun n : nat => {n = n} + {n = n}) x (left _ (refl_equal x)) =
+ existS (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) -> 
+ x = y.
+intros x y H.
+ injection H.
+exact (fun H => H).
 Qed.
 
 (* Check that a tuple is built (actually the same as the initial one) *)
-Lemma l4 : (p1,p2:{O=O}+{O=O})
-    (existS ? [n:nat]({n=n}+{n=n}) O p1)=(existS ? [n:nat]({n=n}+{n=n}) O p2)
-  ->(existS ? [n:nat]({n=n}+{n=n}) O p1)=(existS ? [n:nat]({n=n}+{n=n}) O p2).
-Intros.
-Injection H.
-Exact [H]H.
+Lemma l4 :
+ forall p1 p2 : {0 = 0} + {0 = 0},
+ existS (fun n : nat => {n = n} + {n = n}) 0 p1 =
+ existS (fun n : nat => {n = n} + {n = n}) 0 p2 ->
+ existS (fun n : nat => {n = n} + {n = n}) 0 p1 =
+ existS (fun n : nat => {n = n} + {n = n}) 0 p2.
+intros.
+ injection H.
+exact (fun H => H).
 Qed.
 
+(* Test injection as *)
+
+Lemma l5 : forall x y z t : nat, (x,y) = (z,t) -> x=z.
+intros; injection H as Hyt Hxz.
+exact Hxz.
+Qed.
+
+(* Injection does not projects at positions in Prop... allow it?
+
+Inductive t (A:Prop) : Set := c : A -> t A.
+Goal forall p q : True\/True, c _ p = c _ q -> False.
+intros.
+injection H.
+Abort.
+
+*)
+
+(* Accept does not project on discriminable positions... allow it?
+
+Goal 1=2 -> 1=0.
+intro H.
+injection H.
+intro; assumption.
+Qed.
+
+ *)
diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v
index a9e4a843..f83328e8 100644
--- a/test-suite/success/Inversion.v
+++ b/test-suite/success/Inversion.v
@@ -1,85 +1,101 @@
-Axiom magic:False.
+Axiom magic : False.
 
 (* Submitted by Dachuan Yu (bug #220) *)
-Fixpoint T[n:nat] : Type := 
- Cases n of 
- | O => (nat -> Prop) 
- | (S n') => (T n') 
- end. 
-Inductive R : (n:nat)(T n) -> nat -> Prop := 
-  | RO : (Psi:(T O); l:nat) 
-          (Psi l) -> (R O Psi l) 
-  | RS : (n:nat; Psi:(T (S n)); l:nat) 
-          (R n Psi l) -> (R (S n) Psi l). 
-Definition Psi00 : (nat -> Prop) := [n:nat] False. 
-Definition Psi0 : (T O) := Psi00. 
-Lemma Inversion_RO : (l:nat)(R O Psi0 l) -> (Psi00 l).
-Inversion 1.
+Fixpoint T (n : nat) : Type :=
+  match n with
+  | O => nat -> Prop
+  | S n' => T n'
+  end. 
+Inductive R : forall n : nat, T n -> nat -> Prop :=
+  | RO : forall (Psi : T 0) (l : nat), Psi l -> R 0 Psi l
+  | RS :
+      forall (n : nat) (Psi : T (S n)) (l : nat), R n Psi l -> R (S n) Psi l. 
+Definition Psi00 (n : nat) : Prop := False. 
+Definition Psi0 : T 0 := Psi00. 
+Lemma Inversion_RO : forall l : nat, R 0 Psi0 l -> Psi00 l.
+inversion 1.
 Abort.
 
 (* Submitted by Pierre Casteran (bug #540) *)
 
 Set Implicit Arguments.
-Parameter rule: Set -> Type.
+Unset Strict Implicit.
+Parameter rule : Set -> Type.
 
-Inductive extension [I:Set]:Type :=
- NL : (extension I) 
-|add_rule : (rule I)  -> (extension I)  -> (extension I).
+Inductive extension (I : Set) : Type :=
+  | NL : extension I
+  | add_rule : rule I -> extension I -> extension I.
 
 
-Inductive in_extension [I :Set;r: (rule I)] : (extension I)  -> Type :=
- in_first : (e:?)(in_extension r (add_rule r e))
-|in_rest : (e,r':?)(in_extension r e) -> (in_extension r (add_rule r' e)).
+Inductive in_extension (I : Set) (r : rule I) : extension I -> Type :=
+  | in_first : forall e, in_extension r (add_rule r e)
+  | in_rest : forall e r', in_extension r e -> in_extension r (add_rule r' e).
 
-Implicits NL [1].
+Implicit Arguments NL [I].
 
-Inductive super_extension [I:Set;e :(extension I)] : (extension I)  -> Type :=
- super_NL   : (super_extension   e NL)
-| super_add : (r:?)(e': (extension I))
-                 (in_extension  r e) ->
-                 (super_extension  e e') ->
-                 (super_extension  e (add_rule r e')). 
+Inductive super_extension (I : Set) (e : extension I) :
+extension I -> Type :=
+  | super_NL : super_extension e NL
+  | super_add :
+      forall r (e' : extension I),
+      in_extension r e ->
+      super_extension e e' -> super_extension e (add_rule r e'). 
 
 
 
-Lemma super_def : (I :Set)(e1, e2: (extension I))
-                 (super_extension  e2 e1) ->
-                 (ru:?) 
-                   (in_extension ru e1) ->
-                   (in_extension ru e2).
+Lemma super_def :
+ forall (I : Set) (e1 e2 : extension I),
+ super_extension e2 e1 -> forall ru, in_extension ru e1 -> in_extension ru e2.
 Proof.                 
- Induction 1.
- Inversion 1; Auto.
- Elim magic.
+ simple induction 1.
+ inversion 1; auto.
+ elim magic.
 Qed.
 
 (* Example from Norbert Schirmer on Coq-Club, Sep 2000 *)
 
+Set Strict Implicit.
 Unset Implicit Arguments.
-Definition Q[n,m:nat;prf:(le n m)]:=True.
-Goal (n,m:nat;H:(le (S n) m))(Q (S n) m H)==True.
-Intros.
-Dependent Inversion_clear H.
-Elim magic.
-Elim magic.
+Definition Q (n m : nat) (prf : n <= m) := True.
+Goal forall (n m : nat) (H : S n <= m), Q (S n) m H = True.
+intros.
+dependent inversion_clear H.
+elim magic.
+elim magic.
 Qed.
 
 (* Submitted by Boris Yakobowski (bug #529) *)
 (* Check that Inversion does not fail due to unnormalized evars *)
 
 Set Implicit Arguments.
+Unset Strict Implicit.
 Require Import Bvector.
 
 Inductive I : nat -> Set :=
-| C1 : (I (S O))
-| C2 : (k,i:nat)(vector (I i) k) -> (I i).
+  | C1 : I 1
+  | C2 : forall k i : nat, vector (I i) k -> I i.
 
-Inductive SI : (k:nat)(I k) -> (vector nat k) -> nat -> Prop :=
-| SC2 : (k,i,vf:nat) (v:(vector (I i) k))(xi:(vector nat i))(SI (C2 v) xi vf).
+Inductive SI : forall k : nat, I k -> vector nat k -> nat -> Prop :=
+    SC2 :
+      forall (k i vf : nat) (v : vector (I i) k) (xi : vector nat i),
+      SI (C2 v) xi vf.
 
-Theorem SUnique : (k:nat)(f:(I k))(c:(vector nat k))
-(v,v':?) (SI f c v) -> (SI f c v') -> v=v'.
+Theorem SUnique :
+ forall (k : nat) (f : I k) (c : vector nat k) v v',
+ SI f c v -> SI f c v' -> v = v'.
 Proof.
-NewInduction 1.
-Intros H ; Inversion H.
+induction 1.
+intros H; inversion H.
 Admitted.
+
+(* Used to failed at some time *)
+
+Set Strict Implicit.
+Unset Implicit Arguments.
+Parameter bar : forall p q : nat, p = q -> Prop.
+Inductive foo : nat -> nat -> Prop :=
+    C : forall (a b : nat) (Heq : a = b), bar a b Heq -> foo a b.
+Lemma depinv : forall a b, foo a b -> True.
+intros a b H.
+inversion H.
+Abort.
diff --git a/test-suite/success/LegacyField.v b/test-suite/success/LegacyField.v
new file mode 100644
index 00000000..d53e4010
--- /dev/null
+++ b/test-suite/success/LegacyField.v
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  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: Field.v 7693 2005-12-21 23:50:17Z herbelin $ *)
+
+(**** Tests of Field with real numbers ****)
+
+Require Import Reals LegacyRfield.
+
+(* Example 1 *)
+Goal
+forall eps : R,
+(eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)))%R = (eps * (1 / 2))%R.
+Proof.
+  intros.
+   legacy field.
+Abort.
+
+(* Example 2 *)
+Goal
+forall (f g : R -> R) (x0 x1 : R),
+((f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)))%R =
+((f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)))%R.
+Proof.
+  intros.
+   legacy field.
+Abort.
+ 
+(* Example 3 *)
+Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R.
+Proof.
+  intros.
+   legacy field.
+Abort.
+ 
+(* Example 4 *)
+Goal
+forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R.
+Proof.
+  intros.
+   legacy field.
+Abort.
+ 
+(* Example 5 *)
+Goal forall a : R, 1%R = (1 * (1 / a) * a)%R.
+Proof.
+  intros.
+   legacy field.
+Abort.
+ 
+(* Example 6 *)
+Goal forall a b : R, b = (b * / a * a)%R.
+Proof.
+  intros.
+   legacy field.
+Abort.
+ 
+(* Example 7 *)
+Goal forall a b : R, b = (b * (1 / a) * a)%R.
+Proof.
+  intros.
+   legacy field.
+Abort.
+
+(* Example 8 *)
+Goal
+forall x y : R,
+(x * (1 / x + x / (x + y)))%R =
+(- (1 / y) * y * (- (x * (x / (x + y))) - 1))%R.
+Proof.
+  intros.
+   legacy field.
+Abort.
diff --git a/test-suite/success/LetIn.v b/test-suite/success/LetIn.v
index 0e0b4435..b61ea784 100644
--- a/test-suite/success/LetIn.v
+++ b/test-suite/success/LetIn.v
@@ -1,11 +1,11 @@
 (* Simple let-in's *)
-Definition l1 := [P := O]P.
-Definition l2 := [P := nat]P.
-Definition l3 := [P := True]P.
-Definition l4 := [P := Prop]P.
-Definition l5 := [P := Type]P.
+Definition l1 := let P := 0 in P.
+Definition l2 := let P := nat in P.
+Definition l3 := let P := True in P.
+Definition l4 := let P := Prop in P.
+Definition l5 := let P := Type in P.
 
 (* Check casting of let-in *)
-Definition l6 := [P := O : nat]P.
-Definition l7 := [P := True : Prop]P.
-Definition l8 := [P := True : Type]P.
+Definition l6 := let P := 0:nat in P.
+Definition l7 := let P := True:Prop in P.
+Definition l8 := let P := True:Type in P.
diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v
index d89ee3be..660ca3cb 100644
--- a/test-suite/success/MatchFail.v
+++ b/test-suite/success/MatchFail.v
@@ -6,23 +6,24 @@ Require Export ZArithRing.
    2*(POS e)+1  ou 2*(POS e), pour rendre les expressions plus
    à même d'être utilisées par Ring, lorsque ces expressions contiennent
    des variables de type positive. *)
-Tactic Definition compute_POS :=
- (Match Context With
- | [|- [(POS (xI ?1))]] -> Let v = ?1 In 
-                          (Match v With
-                            | [xH] ->
-                              (Fail 1)
-                            |_->
-                              Rewrite (POS_xI v))
- | [ |- [(POS (xO ?1))]] -> Let v = ?1 In
-                           Match v With
-                            |[xH]->
-                              (Fail 1)
-                            |[?]->
-                              Rewrite (POS_xO v)).
+Ltac compute_POS :=
+  match goal with
+  |  |- context [(Zpos (xI ?X1))] =>
+      let v := constr:X1 in
+      match constr:v with
+      | 1%positive => fail 1
+      | _ =>  rewrite (BinInt.Zpos_xI v)
+      end
+  |  |- context [(Zpos (xO ?X1))] =>
+      let v := constr:X1 in
+      match constr:v with
+      | 1%positive => fail 1
+      | _ =>  rewrite (BinInt.Zpos_xO v)
+      end
+  end.
 
-Goal (x:positive)(POS (xI (xI x)))=`4*(POS x)+3`.
-Intros.
-Repeat compute_POS.
-Ring.
+Goal forall x : positive, Zpos (xI (xI x)) = (4 * Zpos x + 3)%Z.
+intros.
+repeat compute_POS.
+ ring.
 Qed.
diff --git a/test-suite/success/Mod_ltac.v b/test-suite/success/Mod_ltac.v
index 1a9f6fc5..44bb3a55 100644
--- a/test-suite/success/Mod_ltac.v
+++ b/test-suite/success/Mod_ltac.v
@@ -1,20 +1,20 @@
 (* Submitted by Houda Anoun *)
 
 Module toto.
-Tactic Definition titi:=Auto.
+Ltac titi := auto.
 End toto.
 
 Module ti.
 Import toto.
-Tactic Definition equal:=
-Match Context With
-[ |- ?1=?1]-> titi
-| [ |- ?]-> Idtac.
+Ltac equal := match goal with
+              |  |- (?X1 = ?X1) => titi
+              |  |- _ => idtac
+              end.
 
 End ti.
 
 Import ti.
-Definition simple:(a:nat) a=a.
-Intro.
+Definition simple : forall a : nat, a = a.
+intro.
 equal.
 Qed.
diff --git a/test-suite/success/Mod_params.v b/test-suite/success/Mod_params.v
index 098de3cf..74228bbb 100644
--- a/test-suite/success/Mod_params.v
+++ b/test-suite/success/Mod_params.v
@@ -3,10 +3,10 @@
 Module Type SIG.
 End SIG.
 
-Module Type FSIG[X:SIG].
+Module Type FSIG (X: SIG).
 End FSIG.
 
-Module F[X:SIG].
+Module F (X: SIG).
 End F.
 
 Module Q.
@@ -22,57 +22,57 @@ End Q.
 
 Module M.
 Reset M.
-Module M[X:SIG].
+Module M (X: SIG).
 Reset M.
-Module M[X,Y:SIG].
+Module M (X Y: SIG).
 Reset M.
-Module M[X:SIG;Y:SIG].
+Module M (X: SIG) (Y: SIG).
 Reset M.
-Module M[X,Y:SIG;Z1,Z:SIG].
+Module M (X Y: SIG) (Z1 Z: SIG).
 Reset M.
-Module M[X:SIG][Y:SIG].
+Module M (X: SIG) (Y: SIG).
 Reset M.
-Module M[X,Y:SIG][Z1,Z:SIG].
+Module M (X Y: SIG) (Z1 Z: SIG).
 Reset M.
-Module M:SIG.
+Module M : SIG.
 Reset M.
-Module M[X:SIG]:SIG.
+Module M (X: SIG) : SIG.
 Reset M.
-Module M[X,Y:SIG]:SIG.
+Module M (X Y: SIG) : SIG.
 Reset M.
-Module M[X:SIG;Y:SIG]:SIG.
+Module M (X: SIG) (Y: SIG) : SIG.
 Reset M.
-Module M[X,Y:SIG;Z1,Z:SIG]:SIG.
+Module M (X Y: SIG) (Z1 Z: SIG) : SIG.
 Reset M.
-Module M[X:SIG][Y:SIG]:SIG.
+Module M (X: SIG) (Y: SIG) : SIG.
 Reset M.
-Module M[X,Y:SIG][Z1,Z:SIG]:SIG.
+Module M (X Y: SIG) (Z1 Z: SIG) : SIG.
 Reset M.
-Module M:=(F Q).
+Module M := F Q.
 Reset M.
-Module M[X:FSIG]:=(X Q).
+Module M (X: FSIG) := X Q.
 Reset M.
-Module M[X,Y:FSIG]:=(X Q).
+Module M (X Y: FSIG) := X Q.
 Reset M.
-Module M[X:FSIG;Y:SIG]:=(X Y).
+Module M (X: FSIG) (Y: SIG) := X Y.
 Reset M.
-Module M[X,Y:FSIG;Z1,Z:SIG]:=(X Z).
+Module M (X Y: FSIG) (Z1 Z: SIG) := X Z.
 Reset M.
-Module M[X:FSIG][Y:SIG]:=(X Y).
+Module M (X: FSIG) (Y: SIG) := X Y.
 Reset M.
-Module M[X,Y:FSIG][Z1,Z:SIG]:=(X Z).
+Module M (X Y: FSIG) (Z1 Z: SIG) := X Z.
 Reset M.
-Module M:SIG:=(F Q).
+Module M : SIG := F Q.
 Reset M.
-Module M[X:FSIG]:SIG:=(X Q).
+Module M (X: FSIG) : SIG := X Q.
 Reset M.
-Module M[X,Y:FSIG]:SIG:=(X Q).
+Module M (X Y: FSIG) : SIG := X Q.
 Reset M.
-Module M[X:FSIG;Y:SIG]:SIG:=(X Y).
+Module M (X: FSIG) (Y: SIG) : SIG := X Y.
 Reset M.
-Module M[X,Y:FSIG;Z1,Z:SIG]:SIG:=(X Z).
+Module M (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
 Reset M.
-Module M[X:FSIG][Y:SIG]:SIG:=(X Y).
+Module M (X: FSIG) (Y: SIG) : SIG := X Y.
 Reset M.
-Module M[X,Y:FSIG][Z1,Z:SIG]:SIG:=(X Z).
+Module M (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
 Reset M.
diff --git a/test-suite/success/Mod_strengthen.v b/test-suite/success/Mod_strengthen.v
index a472e698..449610be 100644
--- a/test-suite/success/Mod_strengthen.v
+++ b/test-suite/success/Mod_strengthen.v
@@ -1,25 +1,27 @@
 Module Type Sub.
-  Axiom Refl1 : (x:nat)(x=x).
-  Axiom Refl2 : (x:nat)(x=x).
-  Axiom Refl3 : (x:nat)(x=x).
-  Inductive T : Set := A : T.
+  Axiom Refl1 : forall x : nat, x = x.
+  Axiom Refl2 : forall x : nat, x = x.
+  Axiom Refl3 : forall x : nat, x = x.
+  Inductive T : Set :=
+      A : T.
 End Sub.
 
 Module Type Main.
-  Declare Module M:Sub.
+  Declare Module M: Sub.
 End Main.
 
 
 Module A <: Main.
   Module M <: Sub.
-    Lemma Refl1 : (x:nat) x=x.
-      Intros;Reflexivity.
+    Lemma Refl1 : forall x : nat, x = x.
+      intros; reflexivity.
     Qed.
-    Axiom Refl2 : (x:nat) x=x.
-    Lemma Refl3 : (x:nat) x=x.
-      Intros;Reflexivity.
+    Axiom Refl2 : forall x : nat, x = x.
+    Lemma Refl3 : forall x : nat, x = x.
+      intros; reflexivity.
     Defined.
-    Inductive T : Set := A : T.
+    Inductive T : Set :=
+        A : T.
   End M.
 End A.
 
@@ -27,8 +29,8 @@ End A.
 
 (* first test *)
 
-Module F[S:Sub].
-  Module M:=S.
+Module F (S: Sub).
+  Module M := S.
 End F.
 
 Module B <: Main with Module M:=A.M := F A.M.
@@ -37,28 +39,29 @@ Module B <: Main with Module M:=A.M := F A.M.
 
 (* second test *)
 
-Lemma r1 : (A.M.Refl1 == B.M.Refl1).
+Lemma r1 : (A.M.Refl1 = B.M.Refl1).
 Proof.
-  Reflexivity.
+  reflexivity.
 Qed.
 
-Lemma r2 : (A.M.Refl2 == B.M.Refl2).
+Lemma r2 : (A.M.Refl2 = B.M.Refl2).
 Proof.
-  Reflexivity.
+  reflexivity.
 Qed.
 
-Lemma r3 : (A.M.Refl3 == B.M.Refl3).
+Lemma r3 : (A.M.Refl3 = B.M.Refl3).
 Proof.
-  Reflexivity.
+  reflexivity.
 Qed.
 
-Lemma t : (A.M.T == B.M.T).
+Lemma t : (A.M.T = B.M.T).
 Proof.
-  Reflexivity.
+  reflexivity.
 Qed.
 
-Lemma a : (A.M.A == B.M.A).
+Lemma a : (A.M.A = B.M.A).
 Proof.
-  Reflexivity.
+  reflexivity.
 Qed.
 
+
diff --git a/test-suite/success/Mod_type.v b/test-suite/success/Mod_type.v
new file mode 100644
index 00000000..b847833f
--- /dev/null
+++ b/test-suite/success/Mod_type.v
@@ -0,0 +1,19 @@
+(* Check bug #1025 submitted by Pierre-Luc Carmel Biron *)
+
+Module Type FOO.
+  Parameter A : Type.
+End FOO.
+
+Module Type BAR.
+  Declare Module Foo : FOO.
+End BAR.
+
+Module Bar : BAR.
+
+  Module Fu : FOO.
+    Definition A := Prop.
+  End Fu.
+
+  Module Foo := Fu.
+
+End Bar.
diff --git a/test-suite/success/NatRing.v b/test-suite/success/NatRing.v
index 6a1eeccc..22d021d5 100644
--- a/test-suite/success/NatRing.v
+++ b/test-suite/success/NatRing.v
@@ -1,10 +1,10 @@
-Require ArithRing.
+Require Import ArithRing.
 
-Lemma l1 : (S (S O))=(plus (S O) (S O)).
-NatRing.
+Lemma l1 : 2 = 1 + 1.
+ring.
 Qed.
 
-Lemma l2 : (x:nat)(S (S x))=(plus (S O) (S x)).
-Intro.
-NatRing.
-Qed.
\ No newline at end of file
+Lemma l2 : forall x : nat, S (S x) = 1 + S x.
+intro.
+ring.
+Qed.
diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v
new file mode 100644
index 00000000..a9e2c59a
--- /dev/null
+++ b/test-suite/success/Notations.v
@@ -0,0 +1,9 @@
+(* Check that "where" clause behaves as if given independently of the  *)
+(* definition (variant of bug #113? submitted by Assia Mahboubi) *)
+
+Fixpoint plus1 (n m:nat) {struct n} : nat :=
+   match n with
+   | O => m
+   | S p => S (p+m)
+   end
+ where "n + m" := (plus1 n m) : nat_scope.
diff --git a/test-suite/success/Omega.v b/test-suite/success/Omega.v
index c324919f..2d29a835 100644
--- a/test-suite/success/Omega.v
+++ b/test-suite/success/Omega.v
@@ -1,40 +1,38 @@
 
-Require Omega.
+Require Import Omega.
 
 (* Submitted by Xavier Urbain 18 Jan 2002 *)
 
-Lemma lem1 : (x,y:Z) 
-  `-5 < x < 5` ->
-  `-5 < y` ->
-  `-5 < x+y+5`.
+Lemma lem1 :
+ forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z.
 Proof.
-Intros x y.
-Omega.
+intros x y.
+ omega.
 Qed.
 
 (* Proposed by Pierre Crégut *)
 
-Lemma lem2 : (x:Z) `x < 4` -> `x > 2` -> `x=3`.
-Intro.
-Omega.
+Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z.
+intro.
+ omega.
 Qed.
 
 (* Proposed by Jean-Christophe Filliâtre *)
 
-Lemma lem3 : (x,y:Z) `x = y` -> `x+x = y+y`.
+Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z.
 Proof.
-Intros.
-Omega.
+intros.
+ omega.
 Qed.
 
 (* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *)
 (* internal variable and a section variable (June 2001) *)
 
 Section A.
-Variable x,y : Z.
-Hypothesis H : `x > y`.
-Lemma lem4 : `x > y`.
-Omega.
+Variable x y : Z.
+Hypothesis H : (x > y)%Z.
+Lemma lem4 : (x > y)%Z.
+ omega.
 Qed.
 End A.
 
@@ -42,48 +40,57 @@ End A.
 (* May 2002 *)
 
 Section B.
-Variables R1,R2,S1,S2,H,S:Z.
-Hypothesis I:`R1 < 0`->`R2 = R1+(2*S1-1)`.
-Hypothesis J:`R1 < 0`->`S2 = S1-1`.
-Hypothesis K:`R1 >= 0`->`R2 = R1`.
-Hypothesis L:`R1 >= 0`->`S2 = S1`.
-Hypothesis M:`H <= 2*S`.
-Hypothesis N:`S < H`.
-Lemma lem5 : `H > 0`.
-Omega.
+Variable R1 R2 S1 S2 H S : Z.
+Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z.
+Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z.
+Hypothesis K : (R1 >= 0)%Z -> R2 = R1.
+Hypothesis L : (R1 >= 0)%Z -> S2 = S1.
+Hypothesis M : (H <= 2 * S)%Z.
+Hypothesis N : (S < H)%Z.
+Lemma lem5 : (H > 0)%Z.
+ omega.
 Qed.
 End B.
 
 (* From Nicolas Oury (bug #180): handling -> on Set (fixed Oct 2002) *)
-Lemma lem6: (A: Set) (i:Z) `i<= 0` -> (`i<= 0` -> A) -> `i<=0`.
-Intros.
-Omega.
+Lemma lem6 :
+ forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z.
+intros.
+ omega.
 Qed.
 
 (* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *)
-Require Omega.
+Require Import Omega.
 Section C.
-Parameter g:(m:nat)~m=O->Prop.
-Parameter f:(m:nat)(H:~m=O)(g m H).
-Variable n:nat.
-Variable ap_n:~n=O.
-Local delta:=(f n ap_n).
-Lemma lem7 : n=n.
-Omega.
+Parameter g : forall m : nat, m <> 0 -> Prop.
+Parameter f : forall (m : nat) (H : m <> 0), g m H.
+Variable n : nat.
+Variable ap_n : n <> 0.
+Let delta := f n ap_n.
+Lemma lem7 : n = n.
+ omega.
 Qed.
 End C.
 
 (* Problem of dependencies *)
-Require Omega.
-Lemma lem8 : (H:O=O->O=O) H=H -> O=O.
-Intros; Omega.
+Require Import Omega.
+Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0.
+intros;  omega.
 Qed.
 
 (* Bug that what caused by the use of intro_using in Omega *)
+Require Import Omega.
+Lemma lem9 :
+ forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p.
+intros;  omega.
+Qed.
+
+(* Check that the interpretation of mult on nat enforces its positivity *)
+(* Submitted by Hubert Thierry (bug #743) *)
+(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z"
 Require Omega.
-Lemma lem9 : (p,q:nat)
-  ~((le p q)/\(lt p q)\/(le q p)/\(lt p q))
-  -> (lt p p)\/(le p p).
+Lemma lem10 : (n, m : nat) (le n (plus n (mult n m))).
+Proof.
 Intros; Omega.
 Qed.
-
+*)
diff --git a/test-suite/success/Omega0.v b/test-suite/success/Omega0.v
new file mode 100644
index 00000000..4614c90d
--- /dev/null
+++ b/test-suite/success/Omega0.v
@@ -0,0 +1,149 @@
+Require Import ZArith Omega.
+Open Scope Z_scope.
+
+(* Pierre L: examples gathered while debugging romega. *)
+
+Lemma test_romega_0 : 
+ forall m m', 
+  0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
+Proof.
+intros.
+(*omega.*)
+Admitted.
+
+Lemma test_romega_0b : 
+ forall m m', 
+  0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
+Proof.
+intros m m'.
+(*omega.*)
+Admitted.
+
+Lemma test_romega_1 : 
+ forall (z z1 z2 : Z), 
+    z2 <= z1 ->
+    z1 <= z2 ->
+    z1 >= 0 ->
+    z2 >= 0 ->
+    z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 ->
+    z >= 0.
+Proof.
+intros.
+omega.
+Qed.
+
+Lemma test_romega_1b : 
+ forall (z z1 z2 : Z), 
+    z2 <= z1 ->
+    z1 <= z2 ->
+    z1 >= 0 ->
+    z2 >= 0 ->
+    z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 ->
+    z >= 0.
+Proof.
+intros z z1 z2.
+omega.
+Qed.
+
+Lemma test_romega_2 : forall a b c:Z, 
+ 0<=a-b<=1 -> b-c<=2 -> a-c<=3.
+Proof.
+intros.
+omega.
+Qed.
+
+Lemma test_romega_2b : forall a b c:Z, 
+ 0<=a-b<=1 -> b-c<=2 -> a-c<=3.
+Proof.
+intros a b c.
+omega.
+Qed.
+
+Lemma test_romega_3 : forall a b h hl hr ha hb, 
+ 0 <= ha - hl <= 1 -> 
+ -2 <= hl - hr <= 2 ->
+ h =b+1 ->
+ (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
+ (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
+ (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
+ (-2 <= ha-hr <=2 -> hb = a  + 1) -> 
+ 0 <= hb - h <= 1.
+Proof.
+intros.
+omega.
+Qed.
+
+Lemma test_romega_3b : forall a b h hl hr ha hb, 
+ 0 <= ha - hl <= 1 -> 
+ -2 <= hl - hr <= 2 ->
+ h =b+1 ->
+ (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
+ (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
+ (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
+ (-2 <= ha-hr <=2 -> hb = a  + 1) -> 
+ 0 <= hb - h <= 1.
+Proof.
+intros a b h hl hr ha hb.
+omega.
+Qed.
+
+
+Lemma test_romega_4 : forall hr ha, 
+ ha = 0 ->
+ (ha = 0 -> hr =0) -> 
+ hr = 0.
+Proof.
+intros hr ha.
+omega.
+Qed.
+
+Lemma test_romega_5 : forall hr ha, 
+ ha = 0 ->
+ (~ha = 0 \/ hr =0) -> 
+ hr = 0.
+Proof.
+intros hr ha.
+omega.
+Qed.
+
+Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False.
+Proof.
+intros.
+omega.
+Qed.
+
+Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False.
+Proof.
+intros z.
+omega.
+Qed.
+
+Lemma test_romega_7 : forall z, 
+  0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
+Proof.
+intros.
+omega.
+Qed.
+
+Lemma test_romega_7b : forall z, 
+  0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
+Proof.
+intros.
+omega.
+Qed.
+
+(* Magaud #240 *)
+
+Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x.
+intros.
+omega.
+Qed.
+
+Lemma test_romega_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x.
+intros x y.
+omega.
+Qed.
+
+
+
+
diff --git a/test-suite/success/Omega2.v b/test-suite/success/Omega2.v
new file mode 100644
index 00000000..54b13702
--- /dev/null
+++ b/test-suite/success/Omega2.v
@@ -0,0 +1,28 @@
+Require Import ZArith Omega.
+
+(* Submitted by Yegor Bryukhov (#922) *)
+
+Open Scope Z_scope.
+
+Lemma Test46 : 
+forall v1 v2 v3 v4 v5 : Z,
+((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) ->
+9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) ->
+((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 ->
+0 > 6 * v1 ->
+(0 * v3) + (6 * v2) <> 2 ->
+(0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) ->
+7 * v3 > 5 * v5 ->
+0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) ->
+7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) ->
+0 * v3 > 7 * v1 ->
+9 * v2 < 9 * v5 ->
+(2 * v3) + (8 * v1) <= 5 * v4 ->
+5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) ->
+0 * v5 <= 9 * v2 ->
+((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9))
+-> False.
+intros.
+omega.
+Qed.
+
diff --git a/test-suite/success/PPFix.v8 b/test-suite/success/PPFix.v
index 1ecbae3a..833eb3ad 100644
--- a/test-suite/success/PPFix.v8
+++ b/test-suite/success/PPFix.v
@@ -6,3 +6,4 @@ Check fix a(n: nat): n<5 -> nat :=
     | 0 => fun _ => 0
     | S n => fun h => S (a n (lt_S_n _ _ (lt_S _ _ h)))
   end.
+
diff --git a/test-suite/success/Print.v b/test-suite/success/Print.v
index 4554a843..c4726bf3 100644
--- a/test-suite/success/Print.v
+++ b/test-suite/success/Print.v
@@ -6,15 +6,14 @@ Print Graph.
 Print Coercions.
 Print Classes.
 Print nat.
-Print Proof O.
+Print Term O.
 Print All.
-Print Grammar constr constr.
+Print Grammar constr.
 Inspect 10.
 
 Section A.
-Coercion f := [x]True : nat -> Prop.
-Print Coercion Paths nat SORTCLASS.
+Coercion f (x : nat) : Prop := True.
+Print Coercion Paths nat Sortclass.
 
 Print Section A.
-Print.
 
diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v
index 7f5cd800..88da6013 100644
--- a/test-suite/success/Projection.v
+++ b/test-suite/success/Projection.v
@@ -1,10 +1,8 @@
-Structure S : Type := 
- {Dom     : Type;
-  Op      : Dom -> Dom -> Dom}.
+Structure S : Type :=  {Dom : Type; Op : Dom -> Dom -> Dom}.
 
-Check [s:S](Dom s).
-Check [s:S](Op s).
-Check [s:S;a,b:(Dom s)](Op s a b).
+Check (fun s : S => Dom s).
+Check (fun s : S => Op s).
+Check (fun (s : S) (a b : Dom s) => Op s a b).
 
 (* v8
 Check fun s:S => s.(Dom).
@@ -13,17 +11,16 @@ Check fun (s:S) (a b:s.(Dom)) => s.(Op) a b.
 *)
 
 Set Implicit Arguments.
-Unset Strict Implicits. 
+Unset Strict Implicit.
+Unset Strict Implicit. 
 
-Structure S' [A:Set] : Type := 
- {Dom'     : Type;
-  Op'      : A -> Dom' -> Dom'}.
+Structure S' (A : Set) : Type :=  {Dom' : Type; Op' : A -> Dom' -> Dom'}.
 
-Check [s:(S' nat)](Dom' s).
-Check [s:(S' nat)](Op' 2!s).
-Check [s:(S' nat)](!Op' nat s).
-Check [s:(S' nat);a:nat;b:(Dom' s)](Op' a b).
-Check [s:(S' nat);a:nat;b:(Dom' s)](!Op' nat s a b).
+Check (fun s : S' nat => Dom' s).
+Check (fun s : S' nat => Op' (s:=s)).
+Check (fun s : S' nat => Op' (A:=nat) (s:=s)).
+Check (fun (s : S' nat) (a : nat) (b : Dom' s) => Op' a b).
+Check (fun (s : S' nat) (a : nat) (b : Dom' s) => Op' (A:=nat) (s:=s) a b).
 
 (* v8
 Check fun s:S' => s.(Dom').
diff --git a/test-suite/success/ROmega.v b/test-suite/success/ROmega.v
new file mode 100644
index 00000000..04b666ed
--- /dev/null
+++ b/test-suite/success/ROmega.v
@@ -0,0 +1,98 @@
+
+Require Import ZArith ROmega.
+
+(* Submitted by Xavier Urbain 18 Jan 2002 *)
+
+Lemma lem1 :
+ forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z.
+Proof.
+intros x y.
+ (*romega.*)
+Admitted.
+
+(* Proposed by Pierre Crégut *)
+
+Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z.
+intro.
+ romega.
+Qed.
+
+(* Proposed by Jean-Christophe Filliâtre *)
+
+Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z.
+Proof.
+intros.
+ (*romega.*)
+Admitted.
+
+(* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *)
+(* internal variable and a section variable (June 2001) *)
+
+Section A.
+Variable x y : Z.
+Hypothesis H : (x > y)%Z.
+Lemma lem4 : (x > y)%Z.
+ romega.
+Qed.
+End A.
+
+(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *)
+(* May 2002 *)
+
+Section B.
+Variable R1 R2 S1 S2 H S : Z.
+Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z.
+Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z.
+Hypothesis K : (R1 >= 0)%Z -> R2 = R1.
+Hypothesis L : (R1 >= 0)%Z -> S2 = S1.
+Hypothesis M : (H <= 2 * S)%Z.
+Hypothesis N : (S < H)%Z.
+Lemma lem5 : (H > 0)%Z.
+ romega.
+Qed.
+End B.
+
+(* From Nicolas Oury (bug #180): handling -> on Set (fixed Oct 2002) *)
+Lemma lem6 :
+ forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z.
+intros.
+ romega.
+Qed.
+
+(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *)
+Require Import Omega.
+Section C.
+Parameter g : forall m : nat, m <> 0 -> Prop.
+Parameter f : forall (m : nat) (H : m <> 0), g m H.
+Variable n : nat.
+Variable ap_n : n <> 0.
+Let delta := f n ap_n.
+Lemma lem7 : n = n.
+ (*romega.*) (*ROMEGA CANT DEAL WITH NAT*)
+Admitted.
+End C.
+
+(* Problem of dependencies *)
+Require Import Omega.
+Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0.
+intros.
+(* romega.*) (*ROMEGA CANT DEAL WITH NAT*)
+Admitted.
+
+(* Bug that what caused by the use of intro_using in Omega *)
+Require Import Omega.
+Lemma lem9 :
+ forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p.
+intros.
+(* romega.*)(*ROMEGA CANT DEAL WITH NAT*) 
+Admitted.
+
+(* Check that the interpretation of mult on nat enforces its positivity *)
+(* Submitted by Hubert Thierry (bug #743) *)
+(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z"
+Require Omega.
+Lemma lem10 : (n, m : nat) (le n (plus n (mult n m))).
+Proof.
+Intros; Omega.
+Qed.
+*)
diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v
new file mode 100644
index 00000000..0efca1e1
--- /dev/null
+++ b/test-suite/success/ROmega0.v
@@ -0,0 +1,149 @@
+Require Import ZArith ROmega.
+Open Scope Z_scope.
+
+(* Pierre L: examples gathered while debugging romega. *)
+
+Lemma test_romega_0 : 
+ forall m m', 
+  0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
+Proof.
+intros.
+(*romega.*)
+Admitted.
+
+Lemma test_romega_0b : 
+ forall m m', 
+  0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'.
+Proof.
+intros m m'.
+(*romega.*)
+Admitted.
+
+Lemma test_romega_1 : 
+ forall (z z1 z2 : Z), 
+    z2 <= z1 ->
+    z1 <= z2 ->
+    z1 >= 0 ->
+    z2 >= 0 ->
+    z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 ->
+    z >= 0.
+Proof.
+intros.
+romega.
+Qed.
+
+Lemma test_romega_1b : 
+ forall (z z1 z2 : Z), 
+    z2 <= z1 ->
+    z1 <= z2 ->
+    z1 >= 0 ->
+    z2 >= 0 ->
+    z1 >= z2 /\ z = z1 \/ z1 <= z2 /\ z = z2 ->
+    z >= 0.
+Proof.
+intros z z1 z2.
+(* romega. *) 
+Admitted.
+
+Lemma test_romega_2 : forall a b c:Z, 
+ 0<=a-b<=1 -> b-c<=2 -> a-c<=3.
+Proof.
+intros.
+romega.
+Qed.
+
+Lemma test_romega_2b : forall a b c:Z, 
+ 0<=a-b<=1 -> b-c<=2 -> a-c<=3.
+Proof.
+intros a b c.
+(*romega.*)
+Admitted.
+
+Lemma test_romega_3 : forall a b h hl hr ha hb, 
+ 0 <= ha - hl <= 1 -> 
+ -2 <= hl - hr <= 2 ->
+ h =b+1 ->
+ (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
+ (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
+ (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
+ (-2 <= ha-hr <=2 -> hb = a  + 1) -> 
+ 0 <= hb - h <= 1.
+Proof.
+intros.
+romega.
+Qed.
+
+Lemma test_romega_3b : forall a b h hl hr ha hb, 
+ 0 <= ha - hl <= 1 -> 
+ -2 <= hl - hr <= 2 ->
+ h =b+1 ->
+ (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) ->
+ (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) ->
+ (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) ->
+ (-2 <= ha-hr <=2 -> hb = a  + 1) -> 
+ 0 <= hb - h <= 1.
+Proof.
+intros a b h hl hr ha hb.
+romega.
+Qed.
+
+
+Lemma test_romega_4 : forall hr ha, 
+ ha = 0 ->
+ (ha = 0 -> hr =0) -> 
+ hr = 0.
+Proof.
+intros hr ha.
+romega.
+Qed.
+
+Lemma test_romega_5 : forall hr ha, 
+ ha = 0 ->
+ (~ha = 0 \/ hr =0) -> 
+ hr = 0.
+Proof.
+intros hr ha.
+romega.
+Qed.
+
+Lemma test_romega_6 : forall z, z>=0 -> 0>z+2 -> False.
+Proof.
+intros.
+romega.
+Qed.
+
+Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False.
+Proof.
+intros z.
+(*romega. *)
+Admitted.
+
+Lemma test_romega_7 : forall z, 
+  0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
+Proof.
+intros.
+(*romega.*)
+Admitted.
+
+Lemma test_romega_7b : forall z, 
+  0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1.
+Proof.
+intros.
+(*romega.*)
+Admitted.
+
+(* Magaud #240 *)
+
+Lemma test_romega_8 : forall x y:Z, x*x<y*y-> ~ y*y <= x*x.
+intros.
+romega.
+Qed.
+
+Lemma test_romega_8b : forall x y:Z, x*x<y*y-> ~ y*y <= x*x.
+intros x y.
+romega.
+Qed.
+
+
+
+
diff --git a/test-suite/success/ROmega2.v b/test-suite/success/ROmega2.v
new file mode 100644
index 00000000..9d47c9f6
--- /dev/null
+++ b/test-suite/success/ROmega2.v
@@ -0,0 +1,28 @@
+Require Import ZArith ROmega.
+
+(* Submitted by Yegor Bryukhov (#922) *)
+
+Open Scope Z_scope.
+
+Lemma Test46 : 
+forall v1 v2 v3 v4 v5 : Z,
+((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) ->
+9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) ->
+((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 ->
+0 > 6 * v1 ->
+(0 * v3) + (6 * v2) <> 2 ->
+(0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) ->
+7 * v3 > 5 * v5 ->
+0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) ->
+7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) ->
+0 * v3 > 7 * v1 ->
+9 * v2 < 9 * v5 ->
+(2 * v3) + (8 * v1) <= 5 * v4 ->
+5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) ->
+0 * v5 <= 9 * v2 ->
+((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9))
+-> False.
+intros.
+(*romega.*)
+Admitted.
+
diff --git a/test-suite/success/RecTutorial.v8 b/test-suite/success/RecTutorial.v
index 1cef3f2f..60e170e4 100644
--- a/test-suite/success/RecTutorial.v8
+++ b/test-suite/success/RecTutorial.v
@@ -769,7 +769,7 @@ Eval simpl in even_test.
 
 Eval simpl in (fun x : nat => even_test x).
 
-
+Eval simpl in (fun x : nat => plus 5 x).
 Eval simpl in (fun x : nat => even_test (plus 5 x)).
 
 Eval simpl in (fun x : nat => even_test (plus x 5)).
@@ -778,11 +778,11 @@ Eval simpl in (fun x : nat => even_test (plus x 5)).
 Section Principle_of_Induction.
 Variable    P               : nat -> Prop.
 Hypothesis  base_case       : P 0.
-Hypothesis  inductive_hyp   : forall n:nat, P n -> P (S n).
+Hypothesis  inductive_step   : forall n:nat, P n -> P (S n).
 Fixpoint nat_ind  (n:nat)    : (P n) := 
    match n return P n with
           | 0 => base_case
-          | S m => inductive_hyp m (nat_ind m)
+          | S m => inductive_step m (nat_ind m)
    end. 
 
 End Principle_of_Induction.
@@ -802,12 +802,12 @@ Section Principle_of_Double_Induction.
 Variable    P               : nat -> nat ->Prop.
 Hypothesis  base_case1      : forall x:nat, P 0 x.
 Hypothesis  base_case2      : forall x:nat, P (S x) 0.
-Hypothesis  inductive_hyp   : forall n m:nat, P n m -> P (S n) (S m).
+Hypothesis  inductive_step   : forall n m:nat, P n m -> P (S n) (S m).
 Fixpoint nat_double_ind (n m:nat){struct n} : P n m := 
   match n, m return P n m with 
          |  0 ,     x    =>  base_case1 x 
          |  (S x),    0  =>  base_case2 x
-         |  (S x), (S y) =>  inductive_hyp x y (nat_double_ind x y)
+         |  (S x), (S y) =>  inductive_step x y (nat_double_ind x y)
      end.
 End Principle_of_Double_Induction.
 
@@ -815,12 +815,12 @@ Section Principle_of_Double_Recursion.
 Variable    P               : nat -> nat -> Set.
 Hypothesis  base_case1      : forall x:nat, P 0 x.
 Hypothesis  base_case2      : forall x:nat, P (S x) 0.
-Hypothesis  inductive_hyp   : forall n m:nat, P n m -> P (S n) (S m).
+Hypothesis  inductive_step   : forall n m:nat, P n m -> P (S n) (S m).
 Fixpoint nat_double_rec (n m:nat){struct n} : P n m := 
   match n, m return P n m with 
          |   0 ,     x    =>  base_case1 x 
          |  (S x),    0   => base_case2 x
-         |  (S x), (S y)  => inductive_hyp x y (nat_double_rec x y)
+         |  (S x), (S y)  => inductive_step x y (nat_double_rec x y)
      end.
 End Principle_of_Double_Recursion.
 
@@ -912,7 +912,7 @@ Definition minus_decrease : forall x y:nat, Acc lt x ->
                                          Acc lt (x-y).
 Proof.
  intros x y H; case H.
- intros z Hz posz posy. 
+ intros Hz posz posy. 
  apply Hz; apply minus_smaller_positive; assumption.
 Defined.
 
@@ -1011,7 +1011,7 @@ Implicit Arguments Vnil [A].
 Implicit Arguments Vhead [A n].
 Implicit Arguments Vtail [A n].
 
-Definition Vid : forall (A : Set)(n:nat), vector A n -> vector A n.
+Definition Vid : forall (A : Type)(n:nat), vector A n -> vector A n.
 Proof.
  destruct n; intro v.
  exact Vnil.
@@ -1024,7 +1024,7 @@ Eval simpl in (fun (A:Set)(v:vector A 0) => v).
 
 
 
-Lemma Vid_eq : forall (n:nat) (A:Set)(v:vector A n), v=(Vid _ n v).
+Lemma Vid_eq : forall (n:nat) (A:Type)(v:vector A n), v=(Vid _ n v).
 Proof.
  destruct v. 
  reflexivity.
diff --git a/test-suite/success/Record.v b/test-suite/success/Record.v
index f3a13634..7fdbcda7 100644
--- a/test-suite/success/Record.v
+++ b/test-suite/success/Record.v
@@ -1,3 +1,3 @@
 (* Nijmegen expects redefinition of sorts *)
 Definition CProp := Prop.
-Record test : CProp := { n:nat }.
+Record test : CProp :=  {n : nat}.
diff --git a/test-suite/success/Reg.v b/test-suite/success/Reg.v
index eaa0690c..89b3032c 100644
--- a/test-suite/success/Reg.v
+++ b/test-suite/success/Reg.v
@@ -1,136 +1,144 @@
-Require Reals.
+Require Import Reals.
 
-Axiom y : R->R.
-Axiom d_y : (derivable y).
-Axiom n_y : (x:R)``(y x)<>0``.
-Axiom dy_0 : (derive_pt y R0 (d_y R0)) == R1.
+Axiom y : R -> R.
+Axiom d_y : derivable y.
+Axiom n_y : forall x : R, y x <> 0%R.
+Axiom dy_0 : derive_pt y 0 (d_y 0%R) = 1%R.
 
-Lemma essai0 : (continuity_pt [x:R]``(x+2)/(y x)+x/(y x)`` R0).
-Assert H := d_y.
-Assert H0 := n_y.
-Reg.
+Lemma essai0 : continuity_pt (fun x : R => ((x + 2) / y x + x / y x)%R) 0.
+assert (H := d_y).
+assert (H0 := n_y).
+reg.
 Qed.
 
-Lemma essai1 : (derivable_pt [x:R]``/2*(sin x)`` ``1``).
-Reg.
+Lemma essai1 : derivable_pt (fun x : R => (/ 2 * sin x)%R) 1.
+reg.
 Qed.
 
-Lemma essai2 : (continuity [x:R]``(Rsqr x)*(cos (x*x))+x``).
-Reg.
+Lemma essai2 : continuity (fun x : R => (Rsqr x * cos (x * x) + x)%R).
+reg.
 Qed.
 
-Lemma essai3 : (derivable_pt [x:R]``x*((Rsqr x)+3)`` R0).
-Reg.
+Lemma essai3 : derivable_pt (fun x : R => (x * (Rsqr x + 3))%R) 0.
+reg.
 Qed.
 
-Lemma essai4 : (derivable [x:R]``(x+x)*(sin x)``).
-Reg.
+Lemma essai4 : derivable (fun x : R => ((x + x) * sin x)%R).
+reg.
 Qed.
 
-Lemma essai5 : (derivable [x:R]``1+(sin (2*x+3))*(cos (cos x))``).
-Reg.
+Lemma essai5 : derivable (fun x : R => (1 + sin (2 * x + 3) * cos (cos x))%R).
+reg.
 Qed.
 
-Lemma essai6 : (derivable [x:R]``(cos (x+3))``).
-Reg.
+Lemma essai6 : derivable (fun x : R => cos (x + 3)).
+reg.
 Qed.
 
-Lemma essai7 : (derivable_pt [x:R]``(cos (/(sqrt x)))*(Rsqr ((sin x)+1))`` R1).
-Reg.
-Apply Rlt_R0_R1.
-Red; Intro; Rewrite sqrt_1 in H; Assert H0 := R1_neq_R0; Elim H0; Assumption.
+Lemma essai7 :
+ derivable_pt (fun x : R => (cos (/ sqrt x) * Rsqr (sin x + 1))%R) 1.
+reg.
+apply Rlt_0_1.
+red in |- *; intro;  rewrite sqrt_1 in H; assert (H0 := R1_neq_R0); elim H0;
+ assumption.
 Qed.
 
-Lemma essai8 : (derivable_pt [x:R]``(sqrt ((Rsqr x)+(sin x)+1))`` R0).
-Reg.
-Rewrite sin_0.
-Rewrite Rsqr_O.
-Replace ``0+0+1`` with ``1``; [Apply Rlt_R0_R1 | Ring].
+Lemma essai8 : derivable_pt (fun x : R => sqrt (Rsqr x + sin x + 1)) 0.
+reg.
+ rewrite sin_0.
+ rewrite Rsqr_0.
+ replace (0 + 0 + 1)%R with 1%R; [ apply Rlt_0_1 |  ring ].
 Qed.
 
-Lemma essai9 : (derivable_pt (plus_fct id sin) R1).
-Reg.
+Lemma essai9 : derivable_pt (id + sin) 1.
+reg.
 Qed.
 
-Lemma essai10 : (derivable_pt [x:R]``x+2`` R0).
-Reg.
+Lemma essai10 : derivable_pt (fun x : R => (x + 2)%R) 0.
+reg.
 Qed.
 
-Lemma essai11 : (derive_pt [x:R]``x+2`` R0 essai10)==R1.
-Reg.
+Lemma essai11 : derive_pt (fun x : R => (x + 2)%R) 0 essai10 = 1%R.
+reg.
 Qed.
 
-Lemma essai12 : (derivable [x:R]``x+(Rsqr (x+2))``).
-Reg.
+Lemma essai12 : derivable (fun x : R => (x + Rsqr (x + 2))%R).
+reg.
 Qed.
 
-Lemma essai13 : (derive_pt [x:R]``x+(Rsqr (x+2))`` R0 (essai12 R0)) == ``5``.
-Reg.
+Lemma essai13 :
+ derive_pt (fun x : R => (x + Rsqr (x + 2))%R) 0 (essai12 0%R) = 5%R.
+reg.
 Qed.
 
-Lemma essai14 : (derivable_pt [x:R]``2*x+x`` ``2``).
-Reg.
+Lemma essai14 : derivable_pt (fun x : R => (2 * x + x)%R) 2.
+reg.
 Qed.
 
-Lemma essai15 : (derive_pt [x:R]``2*x+x`` ``2`` essai14) == ``3``.
-Reg.
+Lemma essai15 : derive_pt (fun x : R => (2 * x + x)%R) 2 essai14 = 3%R.
+reg.
 Qed.
 
-Lemma essai16 : (derivable_pt [x:R]``x+(sin x)`` R0).
-Reg.
+Lemma essai16 : derivable_pt (fun x : R => (x + sin x)%R) 0.
+reg.
 Qed.
 
-Lemma essai17 : (derive_pt [x:R]``x+(sin x)`` R0 essai16)==``2``.
-Reg.
-Rewrite cos_0.
-Reflexivity.
+Lemma essai17 : derive_pt (fun x : R => (x + sin x)%R) 0 essai16 = 2%R.
+reg.
+ rewrite cos_0.
+reflexivity.
 Qed.
 
-Lemma essai18 : (derivable_pt [x:R]``x+(y x)`` ``0``).
-Assert H := d_y.
-Reg.
+Lemma essai18 : derivable_pt (fun x : R => (x + y x)%R) 0.
+assert (H := d_y).
+reg.
 Qed.
 
-Lemma essai19 : (derive_pt [x:R]``x+(y x)`` ``0`` essai18) == ``2``.
-Assert H := dy_0.
-Assert H0 := d_y.
-Reg.
+Lemma essai19 : derive_pt (fun x : R => (x + y x)%R) 0 essai18 = 2%R.
+assert (H := dy_0).
+assert (H0 := d_y).
+reg.
 Qed.
 
-Axiom z:R->R.
-Axiom d_z: (derivable z).
+Axiom z : R -> R.
+Axiom d_z : derivable z.
 
-Lemma essai20 : (derivable_pt [x:R]``(z (y x))`` R0).
-Reg.
-Apply d_y.
-Apply d_z.
+Lemma essai20 : derivable_pt (fun x : R => z (y x)) 0.
+reg.
+apply d_y.
+apply d_z.
 Qed.
 
-Lemma essai21 : (derive_pt [x:R]``(z (y x))`` R0 essai20) == R1.
-Assert H := dy_0.
-Reg.
+Lemma essai21 : derive_pt (fun x : R => z (y x)) 0 essai20 = 1%R.
+assert (H := dy_0).
+reg.
 Abort.
 
-Lemma essai22 : (derivable [x:R]``(sin (z x))+(Rsqr (z x))/(y x)``).
-Assert H := d_y.
-Reg.
-Apply n_y.
-Apply d_z.
+Lemma essai22 : derivable (fun x : R => (sin (z x) + Rsqr (z x) / y x)%R).
+assert (H := d_y).
+reg.
+apply n_y.
+apply d_z.
 Qed.
 
 (* Pour tester la continuite de sqrt en 0 *)
-Lemma essai23 : (continuity_pt [x:R]``(sin (sqrt (x-1)))+(exp (Rsqr ((sqrt x)+3)))`` R1).
-Reg.
-Left; Apply Rlt_R0_R1.
-Right; Unfold Rminus; Rewrite Rplus_Ropp_r; Reflexivity.
-Qed.
-
-Lemma essai24 : (derivable [x:R]``(sqrt (x*x+2*x+2))+(Rabsolu (x*x+1))``).
-Reg.
-Replace ``x*x+2*x+2`` with ``(Rsqr (x+1))+1``.
-Apply ge0_plus_gt0_is_gt0; [Apply pos_Rsqr | Apply Rlt_R0_R1].
-Unfold Rsqr; Ring.
-Red; Intro; Cut ``0<x*x+1``.
-Intro; Rewrite H in H0; Elim (Rlt_antirefl ? H0).
-Apply ge0_plus_gt0_is_gt0; [Replace ``x*x`` with (Rsqr x); [Apply pos_Rsqr | Reflexivity] | Apply Rlt_R0_R1].
+Lemma essai23 :
+ continuity_pt
+   (fun x : R => (sin (sqrt (x - 1)) + exp (Rsqr (sqrt x + 3)))%R) 1.
+reg.
+left; apply Rlt_0_1.
+right; unfold Rminus in |- *;  rewrite Rplus_opp_r; reflexivity.
+Qed.
+
+Lemma essai24 :
+ derivable (fun x : R => (sqrt (x * x + 2 * x + 2) + Rabs (x * x + 1))%R).
+reg.
+ replace (x * x + 2 * x + 2)%R with (Rsqr (x + 1) + 1)%R.
+apply Rplus_le_lt_0_compat; [ apply Rle_0_sqr | apply Rlt_0_1 ].
+unfold Rsqr in |- *;  ring.
+red in |- *; intro; cut (0 < x * x + 1)%R.
+intro;  rewrite H in H0; elim (Rlt_irrefl _ H0).
+apply Rplus_le_lt_0_compat;
+ [  replace (x * x)%R with (Rsqr x); [ apply Rle_0_sqr | reflexivity ]
+ | apply Rlt_0_1 ].
 Qed.
diff --git a/test-suite/success/Rename.v b/test-suite/success/Rename.v
index edb20a81..0576f3c6 100644
--- a/test-suite/success/Rename.v
+++ b/test-suite/success/Rename.v
@@ -1,5 +1,18 @@
-Goal (n:nat)(n=O)->(n=O).
-Intros.
-Rename n into p.
-NewInduction p; Auto.
+Goal forall n : nat, n = 0 -> n = 0.
+intros.
+rename n into p.
+induction p; auto.
 Qed.
+
+(* Submitted by Iris Loeb (#842) *)
+
+Section rename.
+
+Variable A:Prop.
+
+Lemma Tauto: A->A.
+rename A into B.
+tauto.
+Qed.
+
+End rename.
diff --git a/test-suite/success/Require.v b/test-suite/success/Require.v
index 654808fc..f851d8c7 100644
--- a/test-suite/success/Require.v
+++ b/test-suite/success/Require.v
@@ -1,3 +1,3 @@
-Require Coq.Arith.Plus.
-Read Module Coq.Arith.Minus.
+Require Import Coq.Arith.Plus.
+Require Coq.Arith.Minus.
 Locate Library Coq.Arith.Minus.
diff --git a/test-suite/success/Reset.v b/test-suite/success/Reset.v
new file mode 100644
index 00000000..b71ea69d
--- /dev/null
+++ b/test-suite/success/Reset.v
@@ -0,0 +1,7 @@
+(* Check Reset Section *)
+
+Section A.
+Definition B := Prop.
+End A.
+
+Reset A.
diff --git a/test-suite/success/Simplify_eq.v b/test-suite/success/Simplify_eq.v
index 41aa77ef..5b856e3d 100644
--- a/test-suite/success/Simplify_eq.v
+++ b/test-suite/success/Simplify_eq.v
@@ -2,12 +2,12 @@
 
 (* Check that Simplify_eq tries Intro until *)
 
-Lemma l1 : O=(S O)->False.   
-Simplify_eq 1.
+Lemma l1 : 0 = 1 -> False.   
+ simplify_eq 1.
 Qed.
 
-Lemma l2 : (x:nat)(H:(S x)=(S (S x)))H==H->False.   
-Simplify_eq H.
-Intros.
-Apply (n_Sn x H0).
+Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False.   
+ simplify_eq H.
+intros.
+apply (n_Sn x H0).
 Qed.
diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v
index 883a82ab..f0809839 100644
--- a/test-suite/success/Tauto.v
+++ b/test-suite/success/Tauto.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Tauto.v,v 1.10.8.1 2004/07/16 19:30:59 herbelin Exp $ *)
+(* $Id: Tauto.v 7693 2005-12-21 23:50:17Z herbelin $ *)
 
 (**** Tactics Tauto and Intuition ****)
 
@@ -18,183 +18,186 @@
   Simplifications of goals, based on LJT* calcul ****)
 
 (**** Examples of intuitionistic tautologies ****)
-Parameter A,B,C,D,E,F:Prop.
-Parameter even:nat -> Prop.
-Parameter P:nat -> Prop.
+Parameter A B C D E F : Prop.
+Parameter even : nat -> Prop.
+Parameter P : nat -> Prop.
 
-Lemma Ex_Wallen:(A->(B/\C)) -> ((A->B)\/(A->C)).
+Lemma Ex_Wallen : (A -> B /\ C) -> (A -> B) \/ (A -> C).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma Ex_Klenne:~(~(A \/ ~A)).
+Lemma Ex_Klenne : ~ ~ (A \/ ~ A).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma Ex_Klenne':(n:nat)(~(~((even n) \/ ~(even n)))).
+Lemma Ex_Klenne' : forall n : nat, ~ ~ (even n \/ ~ even n).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma Ex_Klenne'':~(~(((n:nat)(even n)) \/ ~((m:nat)(even m)))).
+Lemma Ex_Klenne'' :
+ ~ ~ ((forall n : nat, even n) \/ ~ (forall m : nat, even m)).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma tauto:((x:nat)(P x)) -> ((y:nat)(P y)).
+Lemma tauto : (forall x : nat, P x) -> forall y : nat, P y.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma tauto1:(A -> A).
+Lemma tauto1 : A -> A.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma tauto2:(A -> B -> C) -> (A -> B) -> A -> C.
+Lemma tauto2 : (A -> B -> C) -> (A -> B) -> A -> C.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma a:(x0: (A \/ B))(x1:(B /\ C))(A -> B).
+Lemma a : forall (x0 : A \/ B) (x1 : B /\ C), A -> B.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma a2:((A -> (B /\ C)) -> ((A -> B) \/ (A -> C))).
+Lemma a2 : (A -> B /\ C) -> (A -> B) \/ (A -> C).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma a4:(~A -> ~A).
+Lemma a4 : ~ A -> ~ A.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma e2:~(~(A \/ ~A)).
+Lemma e2 : ~ ~ (A \/ ~ A).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma e4:~(~((A \/ B) -> (A \/ B))).
+Lemma e4 : ~ ~ (A \/ B -> A \/ B).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y0:(x0:A)(x1: ~A)(x2:(A -> B))(x3:(A \/ B))(x4:(A /\ B))(A -> False).
+Lemma y0 :
+ forall (x0 : A) (x1 : ~ A) (x2 : A -> B) (x3 : A \/ B) (x4 : A /\ B),
+ A -> False.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y1:(x0:((A /\ B) /\ C))B.
+Lemma y1 : forall x0 : (A /\ B) /\ C, B.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y2:(x0:A)(x1:B)(C \/ B).
+Lemma y2 : forall (x0 : A) (x1 : B), C \/ B.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y3:(x0:(A /\ B))(B /\ A).
+Lemma y3 : forall x0 : A /\ B, B /\ A.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y5:(x0:(A \/ B))(B \/ A).
+Lemma y5 : forall x0 : A \/ B, B \/ A.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y6:(x0:(A -> B))(x1:A) B.
+Lemma y6 : forall (x0 : A -> B) (x1 : A), B.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y7:(x0 : ((A /\ B) -> C))(x1 : B)(x2 : A) C.
+Lemma y7 : forall (x0 : A /\ B -> C) (x1 : B) (x2 : A), C.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y8:(x0 : ((A \/ B) -> C))(x1 : A) C.
+Lemma y8 : forall (x0 : A \/ B -> C) (x1 : A), C.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y9:(x0 : ((A \/ B) -> C))(x1 : B) C.
+Lemma y9 : forall (x0 : A \/ B -> C) (x1 : B), C.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
-Lemma y10:(x0 : ((A -> B) -> C))(x1 : B) C.
+Lemma y10 : forall (x0 : (A -> B) -> C) (x1 : B), C.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* This example took much time with the old version of Tauto *)
-Lemma critical_example0:(~~B->B)->(A->B)->~~A->B.
+Lemma critical_example0 : (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* Same remark as previously *)
-Lemma critical_example1:(~~B->B)->(~B->~A)->~~A->B.
+Lemma critical_example1 : (~ ~ B -> B) -> (~ B -> ~ A) -> ~ ~ A -> B.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* This example took very much time (about 3mn on a PIII 450MHz in bytecode)
    with the old Tauto. Now, it's immediate (less than 1s). *)
-Lemma critical_example2:(~A<->B)->(~B<->A)->(~~A<->A).
+Lemma critical_example2 : (~ A <-> B) -> (~ B <-> A) -> (~ ~ A <-> A).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* This example was a bug *)
-Lemma old_bug0:(~A<->B)->(~(C\/E)<->D/\F)->~(C\/A\/E)<->D/\B/\F.
+Lemma old_bug0 :
+ (~ A <-> B) -> (~ (C \/ E) <-> D /\ F) -> (~ (C \/ A \/ E) <-> D /\ B /\ F).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* Another bug *)
-Lemma old_bug1:((A->B->False)->False) -> (B->False) -> False.
+Lemma old_bug1 : ((A -> B -> False) -> False) -> (B -> False) -> False.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* A bug again *)
-Lemma old_bug2:
-  ((((C->False)->A)->((B->False)->A)->False)->False) ->
-  (((C->B->False)->False)->False) ->
-  ~A->A.
+Lemma old_bug2 :
+ ((((C -> False) -> A) -> ((B -> False) -> A) -> False) -> False) ->
+ (((C -> B -> False) -> False) -> False) -> ~ A -> A.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* A bug from CNF form *)
-Lemma old_bug3:
-  ((~A\/B)/\(~B\/B)/\(~A\/~B)/\(~B\/~B)->False)->~((A->B)->B)->False.
+Lemma old_bug3 :
+ ((~ A \/ B) /\ (~ B \/ B) /\ (~ A \/ ~ B) /\ (~ B \/ ~ B) -> False) ->
+ ~ ((A -> B) -> B) -> False.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* sometimes, the behaviour of Tauto depends on the order of the hyps *)
-Lemma old_bug3bis:
-  ~((A->B)->B)->((~B\/~B)/\(~B\/~A)/\(B\/~B)/\(B\/~A)->False)->False.
+Lemma old_bug3bis :
+ ~ ((A -> B) -> B) ->
+ ((~ B \/ ~ B) /\ (~ B \/ ~ A) /\ (B \/ ~ B) /\ (B \/ ~ A) -> False) -> False.
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 (* A bug found by Freek Wiedijk <freek@cs.kun.nl> *)
-Lemma new_bug:
- ((A<->B)->(B<->C)) ->
- ((B<->C)->(C<->A)) ->
- ((C<->A)->(A<->B)) ->
- (A<->B).
+Lemma new_bug :
+ ((A <-> B) -> (B <-> C)) ->
+ ((B <-> C) -> (C <-> A)) -> ((C <-> A) -> (A <-> B)) -> (A <-> B).
 Proof.
-  Tauto.
-Save.
+   tauto.
+Qed.
 
 
 (*  A private club has the following rules :
@@ -211,30 +214,31 @@ Save.
 
 Section club.
 
-Variable Scottish, RedSocks, WearKilt, Married, GoOutSunday : Prop.
+Variable Scottish RedSocks WearKilt Married GoOutSunday : Prop.
 
-Hypothesis rule1 : ~Scottish -> RedSocks.
-Hypothesis rule2 : WearKilt \/ ~RedSocks.
-Hypothesis rule3 : Married -> ~GoOutSunday.
+Hypothesis rule1 : ~ Scottish -> RedSocks.
+Hypothesis rule2 : WearKilt \/ ~ RedSocks.
+Hypothesis rule3 : Married -> ~ GoOutSunday.
 Hypothesis rule4 : GoOutSunday <-> Scottish.
-Hypothesis rule5 : WearKilt -> (Scottish /\ Married).
+Hypothesis rule5 : WearKilt -> Scottish /\ Married.
 Hypothesis rule6 : Scottish -> WearKilt.
 
 Lemma NoMember : False.
-Tauto.
-Save.
+ tauto.
+Qed.
 
 End club.
 
 (**** Use of Intuition ****)
-Lemma intu0:(((x:nat)(P x)) /\ B) ->
-              (((y:nat)(P y)) /\ (P O)) \/ (B /\ (P O)).
+Lemma intu0 :
+ (forall x : nat, P x) /\ B -> (forall y : nat, P y) /\ P 0 \/ B /\ P 0.
 Proof.
-  Intuition.
-Save.
+   intuition.
+Qed.
 
-Lemma intu1:((A:Prop)A\/~A)->(x,y:nat)(x=y\/~x=y).
+Lemma intu1 :
+ (forall A : Prop, A \/ ~ A) -> forall x y : nat, x = y \/ x <> y.
 Proof.
-  Intuition.
-Save.
+   intuition.
+Qed.
 
diff --git a/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v
index ee3d7e3f..82c5cf2e 100644
--- a/test-suite/success/TestRefine.v
+++ b/test-suite/success/TestRefine.v
@@ -6,27 +6,32 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Petit bench vite fait, mal fait *)
-
-Require Refine.
-
-
 (************************************************************************)
 
-Lemma essai : (x:nat)x=x.
+Lemma essai : forall x : nat, x = x.
 
-Refine (([x0:nat]Cases x0 of
-    O => ?
-  | (S p) => ?
-  end) :: (x:nat)x=x).  (* x0=x0 et x0=x0 *)
+ refine
+ ((fun x0 : nat => match x0 with
+                   | O => _
+                   | S p => _
+                   end)
+  :forall x : nat, x = x).  (* x0=x0 et x0=x0 *)
 
 Restart.
 
-Refine [x0:nat]<[n:nat]n=n>Case x0 of ? [p:nat]? end. (* OK *)
+ refine
+ (fun x0 : nat => match x0 as n return (n = n) with
+                  | O => _
+                  | S p => _
+                  end). (* OK *)
 
 Restart.
 
-Refine [x0:nat]<[n:nat]n=n>Cases x0 of O => ? | (S p) => ? end. (* OK *)
+ refine
+ (fun x0 : nat => match x0 as n return (n = n) with
+                  | O => _
+                  | S p => _
+                  end). (* OK *)
 
 Restart.
 
@@ -41,55 +46,66 @@ Abort.
 
 Lemma T : nat. 
 
-Refine (S ?).
+ refine (S _).
 
 Abort.
 
 
 (************************************************************************)
 
-Lemma essai2 : (x:nat)x=x.
+Lemma essai2 : forall x : nat, x = x.
 
-Refine Fix f{f/1 : (x:nat)x=x := [x:nat]? }.
+ refine (fix f (x : nat) : x = x := _).
 
 Restart.
 
-Refine Fix f{f/1 : (x:nat)x=x :=
-  [x:nat]<[n:nat](eq nat n n)>Case x of ? [p:nat]? end}.
+ refine
+ (fix f (x : nat) : x = x :=
+    match x as n return (n = n :>nat) with
+    | O => _
+    | S p => _
+    end).
 
 Restart.
 
-Refine Fix f{f/1 : (x:nat)x=x :=
-  [x:nat]<[n:nat]n=n>Cases x of O => ? | (S p) => ? end}.
+ refine
+ (fix f (x : nat) : x = x :=
+    match x as n return (n = n) with
+    | O => _
+    | S p => _
+    end).
 
 Restart.
 
-Refine Fix f{f/1 : (x:nat)x=x :=
-  [x:nat]<[n:nat](eq nat n n)>Case x of
-       ?
-       [p:nat](f_equal nat nat S p p ?) end}.
+ refine
+ (fix f (x : nat) : x = x :=
+    match x as n return (n = n :>nat) with
+    | O => _
+    | S p => f_equal S _
+    end).
 
 Restart.
 
-Refine Fix f{f/1 : (x:nat)x=x :=
-  [x:nat]<[n:nat](eq nat n n)>Cases x of
-       O => ?
-     | (S p) =>(f_equal nat nat S p p ?) end}.
+ refine
+ (fix f (x : nat) : x = x :=
+    match x as n return (n = n :>nat) with
+    | O => _
+    | S p => f_equal S _
+    end).
 
 Abort.
 
 
 (************************************************************************)
+Parameter f : nat * nat -> nat -> nat. 
 
 Lemma essai : nat.
 
-Parameter f : nat*nat -> nat -> nat. 
-
-Refine (f ? ([x:nat](? :: nat) O)).
+ refine (f _ ((fun x : nat => _:nat) 0)).
 
 Restart.
 
-Refine (f ? O).
+ refine (f _ 0).
 
 Abort.
 
@@ -98,93 +114,113 @@ Abort.
 
 Parameter P : nat -> Prop.
 
-Lemma essai : { x:nat | x=(S O) }.
+Lemma essai : {x : nat | x = 1}.
 
-Refine (exist nat ? (S O) ?).  (* ECHEC *)
+ refine (exist _ 1 _).  (* ECHEC *)
 
 Restart.
 
 (* mais si on contraint par le but alors ca marche : *)
 (* Remarque : on peut toujours faire ça *)
-Refine ((exist nat ? (S O) ?) :: { x:nat | x=(S O) }).
+ refine (exist _ 1 _:{x : nat | x = 1}).
 
 Restart.
 
-Refine (exist nat [x:nat](x=(S O)) (S O) ?).
+ refine (exist (fun x : nat => x = 1) 1 _).
 
 Abort.
 
 
 (************************************************************************)
 
-Lemma essai : (n:nat){ x:nat | x=(S n) }.
+Lemma essai : forall n : nat, {x : nat | x = S n}.
 
-Refine [n:nat]<[n:nat]{x:nat|x=(S n)}>Case n of ? [p:nat]? end.
+ refine
+ (fun n : nat =>
+  match n return {x : nat | x = S n} with
+  | O => _
+  | S p => _
+  end).
 
 Restart.
 
-Refine (([n:nat]Case n of ? [p:nat]? end) :: (n:nat){ x:nat | x=(S n) }).
+ refine
+ ((fun n : nat => match n with
+                  | O => _
+                  | S p => _
+                  end)
+  :forall n : nat, {x : nat | x = S n}).
 
 Restart.
 
-Refine [n:nat]<[n:nat]{x:nat|x=(S n)}>Cases n of O => ? | (S p) => ? end.
+ refine
+ (fun n : nat =>
+  match n return {x : nat | x = S n} with
+  | O => _
+  | S p => _
+  end).
 
 Restart.
 
-Refine Fix f{f/1 :(n:nat){x:nat|x=(S n)} :=
-        [n:nat]<[n:nat]{x:nat|x=(S n)}>Case n of ? [p:nat]? end}.
+ refine
+ (fix f (n : nat) : {x : nat | x = S n} :=
+    match n return {x : nat | x = S n} with
+    | O => _
+    | S p => _
+    end).
 
 Restart.
 
-Refine Fix f{f/1 :(n:nat){x:nat|x=(S n)} :=
-        [n:nat]<[n:nat]{x:nat|x=(S n)}>Cases n of O => ? | (S p) => ? end}.
+ refine
+ (fix f (n : nat) : {x : nat | x = S n} :=
+    match n return {x : nat | x = S n} with
+    | O => _
+    | S p => _
+    end).
 
-Exists (S O). Trivial. 
-Elim (f0 p).
-Refine [x:nat][h:x=(S p)](exist nat [x:nat]x=(S (S p)) (S x) ?). 
-Rewrite h. Auto.
-Save.
+exists 1. trivial. 
+elim (f0 p).
+ refine
+ (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _). 
+ rewrite h. auto.
+Qed.
 
 
 
 (* Quelques essais de recurrence bien fondée *)
 
-Require Wf.
-Require Wf_nat.
+Require Import Wf.
+Require Import Wf_nat.
 
-Lemma essai_wf : nat->nat.
+Lemma essai_wf : nat -> nat.
 
-Refine [x:nat](well_founded_induction
-      	       nat
-      	       lt ?
-               [_:nat]nat->nat
-	       [phi0:nat][w:(phi:nat)(lt phi phi0)->nat->nat](w x ?)
-	       x x).
-Exact lt_wf.
+ refine
+ (fun x : nat =>
+  well_founded_induction _ (fun _ : nat => nat -> nat)
+    (fun (phi0 : nat) (w : forall phi : nat, phi < phi0 -> nat -> nat) =>
+     w x _) x x).
+exact lt_wf.
 
 Abort.
 
 
-Require Compare_dec.
-Require Lt.
+Require Import Compare_dec.
+Require Import Lt.
 
 Lemma fibo : nat -> nat.
-Refine (well_founded_induction
-       nat
-       lt ?
-       [_:nat]nat
-       [x0:nat][fib:(x:nat)(lt x x0)->nat]
-         Cases (zerop x0) of 
-      	   (left _)   => (S O)
-      	 | (right h1) => Cases (zerop (pred x0)) of
-      	                   (left _)   => (S O)
-                         | (right h2) => (plus (fib (pred x0) ?)
-      	       	       	       	       	       (fib (pred (pred x0)) ?))
-		     end
-	 end).
-Exact lt_wf.
-Auto with arith.
-Apply lt_trans with m:=(pred x0); Auto with arith.
-Save.
-
+ refine
+ (well_founded_induction _ (fun _ : nat => nat)
+    (fun (x0 : nat) (fib : forall x : nat, x < x0 -> nat) =>
+     match zerop x0 with
+     | left _ => 1
+     | right h1 =>
+         match zerop (pred x0) with
+         | left _ => 1
+         | right h2 => fib (pred x0) _ + fib (pred (pred x0)) _
+         end
+     end)).
+exact lt_wf.
+auto with arith.
+apply lt_trans with (m := pred x0); auto with arith.
+Qed.
 
diff --git a/test-suite/success/Try.v b/test-suite/success/Try.v
index 05cab1e6..b356f277 100644
--- a/test-suite/success/Try.v
+++ b/test-suite/success/Try.v
@@ -2,7 +2,7 @@
    non-existent names in Unfold [cf bug #263] *)
 
 Lemma lem1 : True.
-Try (Unfold i_dont_exist).
-Trivial.
+try unfold i_dont_exist in |- *.
+trivial.
 Qed.
 
diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v
new file mode 100644
index 00000000..4f260696
--- /dev/null
+++ b/test-suite/success/apply.v
@@ -0,0 +1,14 @@
+(* Test apply in *)
+
+Goal (forall x y, x = S y -> y=y) -> 2 = 4 -> 3=3.
+intros H H0.
+apply H in H0.
+assumption.
+Qed.
+
+Require Import ZArith.
+Open Scope Z_scope.
+Goal forall x y z, ~ z <= 0 -> x * z < y * z -> x <= y.
+intros; apply Znot_le_gt, Zgt_lt in H.
+apply Zmult_lt_reg_r, Zlt_le_weak in H0; auto.
+Qed.
diff --git a/test-suite/success/autorewritein.v b/test-suite/success/autorewritein.v
new file mode 100644
index 00000000..68f2f7ce
--- /dev/null
+++ b/test-suite/success/autorewritein.v
@@ -0,0 +1,23 @@
+Variable Ack : nat -> nat -> nat.
+
+Axiom Ack0 : forall m : nat, Ack 0 m = S m.
+Axiom Ack1 : forall n : nat, Ack (S n) 0 = Ack n 1.
+Axiom Ack2 : forall n m : nat, Ack (S n) (S m) = Ack n (Ack (S n) m).
+
+Hint Rewrite Ack0 Ack1 Ack2 : base0.
+
+Lemma ResAck0 : (Ack 2 2 = 7 -> False) -> False.
+Proof.
+  intros.
+  autorewrite with base0 in H using try (apply H; reflexivity).
+Qed.
+
+Lemma ResAck1 : forall H:(Ack 2 2 = 7 -> False), True -> False.
+Proof.
+  intros.
+  autorewrite with base0 in *.
+    apply H;reflexivity.
+Qed.
+
+
+
diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v
index 4d898da9..42df990f 100644
--- a/test-suite/success/cc.v
+++ b/test-suite/success/cc.v
@@ -1,83 +1,79 @@
 
-Theorem t1: (A:Set)(a:A)(f:A->A)
-	(f a)=a->(f (f a))=a.
-Intros.
-Congruence.
-Save.
-
-Theorem t2: (A:Set)(a,b:A)(f:A->A)(g:A->A->A)
-	a=(f a)->(g b (f a))=(f (f a))->(g a b)=(f (g b a))->
-	(g a b)=a.
-Intros.
-Congruence.
-Save.
+Theorem t1 : forall (A : Set) (a : A) (f : A -> A), f a = a -> f (f a) = a.
+intros.
+ congruence.
+Qed.
+
+Theorem t2 :
+ forall (A : Set) (a b : A) (f : A -> A) (g : A -> A -> A),
+ a = f a -> g b (f a) = f (f a) -> g a b = f (g b a) -> g a b = a.
+intros.
+ congruence.
+Qed.
 
 (* 15=0 /\ 10=0 /\ 6=0 -> 0=1 *)
 
-Theorem t3: (N:Set)(o:N)(s:N->N)(d:N->N)
-	(s(s(s(s(s(s(s(s(s(s(s(s(s(s(s o)))))))))))))))=o->
-	(s (s (s (s (s (s (s (s (s (s o))))))))))=o->
-	(s (s (s (s (s (s o))))))=o->
-	o=(s o).
-Intros.
-Congruence.
-Save.
+Theorem t3 :
+ forall (N : Set) (o : N) (s d : N -> N),
+ s (s (s (s (s (s (s (s (s (s (s (s (s (s (s o)))))))))))))) = o ->
+ s (s (s (s (s (s (s (s (s (s o))))))))) = o ->
+ s (s (s (s (s (s o))))) = o -> o = s o.
+intros.
+ congruence.
+Qed.
 
 (* Examples that fail due to dependencies *) 
 
 (* yields transitivity problem *)
 
-Theorem dep:(A:Set)(P:A->Set)(f,g:(x:A)(P x))(x,y:A)
-    (e:x=y)(e0:(f y)=(g y))(f x)=(g x).
-Intros;Dependent Rewrite -> e;Exact e0.
-Save.
+Theorem dep :
+ forall (A : Set) (P : A -> Set) (f g : forall x : A, P x) 
+   (x y : A) (e : x = y) (e0 : f y = g y), f x = g x.
+intros;  dependent rewrite e; exact e0.
+Qed.
 
 (* yields congruence problem *)
 
-Theorem dep2:(A,B:Set)(f:(A:Set)(b:bool)if b then unit else A->unit)(e:A==B)
-   (f A true)=(f B true).
-Intros;Rewrite e;Reflexivity.
-Save.
+Theorem dep2 :
+ forall (A B : Set)
+   (f : forall (A : Set) (b : bool), if b then unit else A -> unit)
+   (e : A = B), f A true = f B true.
+intros;  rewrite e; reflexivity.
+Qed.
 
 
 (* example that Congruence. can solve 	
 	(dependent function applied to the same argument)*) 
 
-Theorem dep3:(A:Set)(P:(A->Set))(f,g:(x:A)(P x))f=g->(x:A)(f x)=(g x).		Intros.	
-Congruence.
-Save.
+Theorem dep3 :
+ forall (A : Set) (P : A -> Set) (f g : forall x : A, P x),
+ f = g -> forall x : A, f x = g x.		intros.	
+ congruence.
+Qed.
 
 (* Examples with injection rule *)
 
-Theorem inj1 : (A:Set;a,b,c,d:A)(a,c)=(b,d)->a=b/\c=d.
-Intros.
-Split;Congruence.
-Save.
+Theorem inj1 :
+ forall (A : Set) (a b c d : A), (a, c) = (b, d) -> a = b /\ c = d.
+intros.
+split;  congruence.
+Qed.
 
-Theorem inj2 : (A:Set;a,c,d:A;f:A->A*A) (f=(pair A A a))->
-  (Some ? (f c))=(Some ? (f d))->c=d.                             
-Intros.
-Congruence.
-Save.
+Theorem inj2 :
+ forall (A : Set) (a c d : A) (f : A -> A * A),
+ f = pair (B:=A) a -> Some (f c) = Some (f d) -> c = d.                             
+intros.
+ congruence.
+Qed.
 
 (* Examples with discrimination rule *)
 
-Theorem discr1 : true=false->False.
-Intros.
-Congruence.
-Save.
+Theorem discr1 : true = false -> False.
+intros.
+ congruence.
+Qed.
 
-Theorem discr2 : (Some ? true)=(Some ? false)->False.
-Intros.
-Congruence.
-Save.
-
-(* example with Congruence.Solve (requires CCSolve.v)*)
-
-Require CCSolve.
-
-Theorem t4 :  (A:Set; P:(A->Prop); a,b,c,d:A)a=b->c=d->
-                 (P a)->((P b)->(P c))->(P d).
-Intros.
-CCsolve.
-Save.
+Theorem discr2 : Some true = Some false -> False.
+intros.
+ congruence.
+Qed.
diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v
new file mode 100644
index 00000000..444146f7
--- /dev/null
+++ b/test-suite/success/clear.v
@@ -0,0 +1,6 @@
+Goal forall x:nat, (forall x, x=0 -> True)->True.
+  intros; eapply H.
+  instantiate (1:=(fun y => _) (S x)).
+  simpl.
+  clear x || trivial.
+Qed.
diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v
index 98b613ba..d652132e 100644
--- a/test-suite/success/coercions.v
+++ b/test-suite/success/coercions.v
@@ -1,11 +1,63 @@
 (* Interaction between coercions and casts *)
 (*   Example provided by Eduardo Gimenez   *)
 
-Parameter Z,S:Set.
+Parameter Z S : Set.
 
-Parameter f: S  -> Z.
-Coercion  f: S >-> Z.
+Parameter f : S -> Z.
+Coercion f : S >-> Z.
 
 Parameter g : Z -> Z.
 
-Check [s](g (s::S)).
+Check (fun s => g (s:S)).
+
+
+(* Check uniform inheritance condition *)
+
+Parameter h : nat -> nat -> Prop.
+Parameter i : forall n m : nat, h n m -> nat.
+Coercion i : h >-> nat.
+
+(* Check coercion to funclass when the source occurs in the target *)
+
+Parameter C : nat -> nat -> nat.
+Coercion C : nat >-> Funclass.
+
+(* Remark: in the following example, it cannot be decided whether C is
+   from nat to Funclass or from A to nat. An explicit Coercion command is
+   expected 
+
+Parameter A : nat -> Prop.
+Parameter C:> forall n:nat, A n -> nat.
+*)
+
+(* Check coercion between products based on eta-expansion *)
+(* (there was a de Bruijn bug until rev 9254) *)
+
+Section P.
+
+Variable E : Set.
+Variables C D : E -> Prop.
+Variable G :> forall x, C x -> D x.
+
+Check fun (H : forall y:E, y = y -> C y) => (H : forall y:E, y = y -> D y).
+
+End P.
+
+(* Check that class arguments are computed the same when looking for a
+   coercion and when applying it (class_args_of) (failed until rev 9255) *)
+
+Section Q.
+
+Variable bool : Set.
+Variables C D : bool -> Prop.
+Variable G :> forall x, C x -> D x.
+Variable f : nat -> bool.
+
+Definition For_all (P : nat -> Prop) := forall x, P x.
+
+Check fun (H : For_all (fun x => C (f x))) => H : forall x, D (f x).
+Check fun (H : For_all (fun x => C (f x))) x => H x : D (f x).
+Check fun (H : For_all (fun x => C (f x))) => H : For_all (fun x => D (f x)).
+
+End Q.
+
diff --git a/test-suite/success/coqbugs0181.v b/test-suite/success/coqbugs0181.v
index 21f906a6..d541dcf7 100644
--- a/test-suite/success/coqbugs0181.v
+++ b/test-suite/success/coqbugs0181.v
@@ -1,7 +1,7 @@
 
 (* test the strength of pretyping unification *)
 
-Require PolyList.
-Definition listn := [A,n] {l:(list A)|(length l)=n}.
-Definition make_ln [A,n;l:(list A); h:([l](length l)=n l)] :=
-  (exist ?? l h).
+Require Import List.
+Definition listn A n := {l : list A | length l = n}.
+Definition make_ln A n (l : list A) (h : (fun l => length l = n) l) :=
+  exist _ l h.
diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v
new file mode 100644
index 00000000..9f938e10
--- /dev/null
+++ b/test-suite/success/destruct.v
@@ -0,0 +1,25 @@
+(* Submitted by Robert Schneck *)
+
+Parameter A B C D : Prop.
+Axiom X : A -> B -> C /\ D.
+
+Lemma foo : A -> B -> C.
+Proof.
+intros. 
+destruct X. (* Should find axiom X and should handle arguments of X *)
+assumption.
+assumption.
+assumption.
+Qed.
+
+(* Simplification of bug 711 *)
+
+Parameter f : true = false.
+Goal let p := f in True.
+intro p.
+set (b := true) in *.
+(* Check that it doesn't fail with an anomaly *)
+(* Ultimately, adapt destruct to make it succeeding *)
+try destruct b.
+Abort.
+
diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v
index 97f7ccf0..26339d51 100644
--- a/test-suite/success/eauto.v
+++ b/test-suite/success/eauto.v
@@ -5,45 +5,56 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-Require PolyList.
+Require Import List.
 
-Parameter in_list : (list nat*nat)->nat->Prop.
-Definition not_in_list : (list nat*nat)->nat->Prop
-	:= [l,n]~(in_list l n).
+Parameter in_list : list (nat * nat) -> nat -> Prop.
+Definition not_in_list (l : list (nat * nat)) (n : nat) : Prop :=
+  ~ in_list l n.
 
 (* Hints Unfold not_in_list. *)
 
-Axiom lem1 : (l1,l2:(list nat*nat))(n:nat)
-		(not_in_list (app l1 l2) n)->(not_in_list l1 n).
-
-Axiom lem2 : (l1,l2:(list nat*nat))(n:nat)
-		(not_in_list (app l1 l2) n)->(not_in_list l2 n).
-
-Axiom lem3 : (l:(list nat*nat))(n,p,q:nat)
-		(not_in_list (cons (p,q) l) n)->(not_in_list l n).
-
-Axiom lem4 : (l1,l2:(list nat*nat))(n:nat)
-	(not_in_list l1 n)->(not_in_list l2 n)->(not_in_list (app l1 l2) n).
-
-Hints Resolve lem1 lem2 lem3 lem4: essai.
-
-Goal (l:(list nat*nat))(n,p,q:nat)
-		(not_in_list (cons (p,q) l) n)->(not_in_list l n).
-Intros.
-EAuto with essai.
-Save.
+Axiom
+  lem1 :
+    forall (l1 l2 : list (nat * nat)) (n : nat),
+    not_in_list (l1 ++ l2) n -> not_in_list l1 n.
+
+Axiom
+  lem2 :
+    forall (l1 l2 : list (nat * nat)) (n : nat),
+    not_in_list (l1 ++ l2) n -> not_in_list l2 n.
+
+Axiom
+  lem3 :
+    forall (l : list (nat * nat)) (n p q : nat),
+    not_in_list ((p, q) :: l) n -> not_in_list l n.
+
+Axiom
+  lem4 :
+    forall (l1 l2 : list (nat * nat)) (n : nat),
+    not_in_list l1 n -> not_in_list l2 n -> not_in_list (l1 ++ l2) n.
+
+Hint Resolve lem1 lem2 lem3 lem4: essai.
+
+Goal
+forall (l : list (nat * nat)) (n p q : nat),
+not_in_list ((p, q) :: l) n -> not_in_list l n.
+intros.
+ eauto with essai.
+Qed.
 
 (* Example from Nicolas Magaud on coq-club - Jul 2000 *)
 
-Definition Nat: Set := nat.
-Parameter S':Nat ->Nat.
-Parameter plus':Nat -> Nat ->Nat.
-
-Lemma simpl_plus_l_rr1:
-  ((n0:Nat) ((m, p:Nat) (plus' n0 m)=(plus' n0 p) ->m=p) ->
-   (m, p:Nat) (S' (plus' n0 m))=(S' (plus' n0 p)) ->m=p) ->
-  (n:Nat) ((m, p:Nat) (plus' n m)=(plus' n p) ->m=p) ->
-  (m, p:Nat) (S' (plus' n m))=(S' (plus' n p)) ->m=p.
-Intros.
-EAuto. (* does EApply H *) 
+Definition Nat : Set := nat.
+Parameter S' : Nat -> Nat.
+Parameter plus' : Nat -> Nat -> Nat.
+
+Lemma simpl_plus_l_rr1 :
+ (forall n0 : Nat,
+  (forall m p : Nat, plus' n0 m = plus' n0 p -> m = p) ->
+  forall m p : Nat, S' (plus' n0 m) = S' (plus' n0 p) -> m = p) ->
+ forall n : Nat,
+ (forall m p : Nat, plus' n m = plus' n p -> m = p) ->
+ forall m p : Nat, S' (plus' n m) = S' (plus' n p) -> m = p.
+intros.
+ eauto. (* does EApply H *) 
 Qed.
diff --git a/test-suite/success/eqdecide.v b/test-suite/success/eqdecide.v
index f826df9a..e7b8ca23 100644
--- a/test-suite/success/eqdecide.v
+++ b/test-suite/success/eqdecide.v
@@ -6,24 +6,26 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Inductive T : Set := A: T | B :T->T.
+Inductive T : Set :=
+  | A : T
+  | B : T -> T.
 
-Lemma lem1 : (x,y:T){x=y}+{~x=y}.
-Decide Equality.
+Lemma lem1 : forall x y : T, {x = y} + {x <> y}.
+ decide equality.
 Qed.
 
-Lemma lem2 : (x,y:T){x=y}+{~x=y}.
-Intros x y.
-Decide Equality x y.
+Lemma lem2 : forall x y : T, {x = y} + {x <> y}.
+intros x y.
+ decide equality x y.
 Qed.
 
-Lemma lem3 : (x,y:T){x=y}+{~x=y}.
-Intros x y.
-Decide Equality y x.
+Lemma lem3 : forall x y : T, {x = y} + {x <> y}.
+intros x y.
+ decide equality y x.
 Qed.
 
-Lemma lem4 : (x,y:T){x=y}+{~x=y}.
-Intros x y.
-Compare x y; Auto.
+Lemma lem4 : forall x y : T, {x = y} + {x <> y}.
+intros x y.
+ compare x y; auto.
 Qed.
 
diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v
index a7b6d6d8..ad69ced1 100644
--- a/test-suite/success/evars.v
+++ b/test-suite/success/evars.v
@@ -1,23 +1,76 @@
 (* The "?" of cons and eq should be inferred *)
-Variable list:Set -> Set.
-Variable cons:(T:Set) T -> (list T) -> (list T).
-Check (n:(list nat)) (EX l| (EX x| (n = (cons ? x l)))).
+Variable list : Set -> Set.
+Variable cons : forall T : Set, T -> list T -> list T.
+Check (forall n : list nat, exists l : _, (exists x : _, n = cons _ x l)).
 
 (* Examples provided by Eduardo Gimenez *)
 
-Definition c [A;Q:(nat*A->Prop)->Prop;P] :=
-   (Q [p:nat*A]let (i,v) = p in (P i v)).
+Definition c A (Q : (nat * A -> Prop) -> Prop) P :=
+  Q (fun p : nat * A => let (i, v) := p in P i v).
 
 (* What does this test ? *)
-Require PolyList.
-Definition list_forall_bool  [A:Set][p:A->bool][l:(list A)] : bool := 
- (fold_right ([a][r]if (p a) then r else false) true l).
+Require Import List.
+Definition list_forall_bool (A : Set) (p : A -> bool) 
+  (l : list A) : bool :=
+  fold_right (fun a r => if p a then r else false) true l.
 
 (* Checks that solvable ? in the lambda prefix of the definition are harmless*)
-Parameter A1,A2,F,B,C : Set.
+Parameter A1 A2 F B C : Set.
 Parameter f : F -> A1 -> B.
-Definition f1 [frm0,a1]: B := (f frm0 a1).
+Definition f1 frm0 a1 : B := f frm0 a1.
 
 (* Checks that solvable ? in the type part of the definition are harmless *)
-Definition f2 : (frm0:?;a1:?)B := [frm0,a1](f frm0 a1).
+Definition f2 frm0 a1 : B := f frm0 a1.
 
+(* Checks that sorts that are evars are handled correctly (bug 705) *)
+Require Import List.
+
+Fixpoint build (nl : list nat) :
+ match nl with
+ | nil => True
+ | _ => False
+ end -> unit :=
+  match nl return (match nl with
+                   | nil => True
+                   | _ => False
+                   end -> unit) with
+  | nil => fun _ => tt
+  | n :: rest =>
+      match n with
+      | O => fun _ => tt
+      | S m => fun a => build rest (False_ind _ a)
+      end
+  end.
+
+
+(* Checks that disjoint contexts are correctly set by restrict_hyp *)
+(* Bug de 1999 corrigé en déc 2004 *)
+
+Check
+  (let p :=
+     fun (m : nat) f (n : nat) =>
+     match f m n with
+     | exist a b => exist _ a b
+     end in
+   p
+   :forall x : nat,
+    (forall y n : nat, {q : nat | y = q * n}) ->
+    forall n : nat, {q : nat | x = q * n}).
+
+(* Check instantiation of nested evars (bug #1089) *)
+
+Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))).
+
+(* This used to fail with anomaly "evar was not declared" in V8.0pl3 *)
+
+Theorem contradiction : forall p, ~ p -> p -> False.
+Proof. trivial. Qed.
+Hint Resolve contradiction.
+Goal False.
+eauto.
+
+(* This used to fail in V8.1beta because first-order unification was
+   used before using type information *)
+
+Check (exist _ O (refl_equal 0) : {n:nat|n=0}).
+Check (exist _ O I : {n:nat|True}).
diff --git a/contrib/extraction/test_extraction.v b/test-suite/success/extraction.v
index 0745f62d..0b3060d5 100644
--- a/contrib/extraction/test_extraction.v
+++ b/test-suite/success/extraction.v
@@ -9,6 +9,12 @@
 Require Import Arith.
 Require Import List.
 
+(**** A few tests for the extraction mechanism ****) 
+
+(* Ideally, we should monitor the extracted output 
+   for changes, but this is painful. For the moment, 
+   we just check for failures of this script. *)
+
 (*** STANDARD EXAMPLES *)
 
 (** Functions. *)
@@ -138,7 +144,7 @@ Definition Ensemble (U:Type) := U -> Prop.
 Definition Empty_set (U:Type) (x:U) := False.
 Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y.
 
-Inductive Finite (U:Type) : Ensemble U -> Set :=
+Inductive Finite (U:Type) : Ensemble U -> Type :=
   | Empty_is_finite : Finite U (Empty_set U)
   | Union_is_finite :
       forall A:Ensemble U,
@@ -200,7 +206,7 @@ Definition test15 := tata 0 1.
 Extraction test15. 
 (* let test15 x x0 = Tata (O, (S O), x, x0) *)
 
-Inductive eta : Set :=
+Inductive eta : Type :=
     eta_c : nat -> Prop -> nat -> Prop -> eta.
 Extraction eta_c.
 (* 
@@ -220,7 +226,7 @@ Extraction test18.
 
 (** Example of singleton inductive type *)
 
-Inductive bidon (A:Prop) (B:Type) : Set :=
+Inductive bidon (A:Prop) (B:Type) : Type :=
     tb : forall (x:A) (y:B), bidon A B. 
 Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) 
   (x:A) (y:B) := f x y.
@@ -266,9 +272,9 @@ Extraction eq_rect.
 
 (** No more propagation of type parameters. Obj.t instead. *)
 
-Inductive tp1 : Set :=
+Inductive tp1 : Type :=
     T : forall (C:Set) (c:C), tp2 -> tp1
-with tp2 : Set :=
+with tp2 : Type :=
     T' : tp1 -> tp2.
 Extraction tp1.
 (* 
@@ -278,9 +284,9 @@ and tp2 =
   | T' of tp1
 *) 
 
-Inductive tp1bis : Set :=
+Inductive tp1bis : Type :=
     Tbis : tp2bis -> tp1bis
-with tp2bis : Set :=
+with tp2bis : Type :=
     T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis.
 Extraction tp1bis.
 (* 
@@ -293,7 +299,7 @@ and tp2bis =
 
 (** Strange inductive type. *)
 
-Inductive Truc : Set -> Set :=
+Inductive Truc : Set -> Type :=
   | chose : forall A:Set, Truc A
   | machin : forall A:Set, A -> Truc bool -> Truc A.
 Extraction Truc.
@@ -487,7 +493,7 @@ let test_boite = function
 
 (* singleton inductive with magic needed *)
 
-Inductive Box : Set :=
+Inductive Box : Type :=
     box : forall A:Set, A -> Box. 
 Extraction Box.
 (* type box = __ *)
@@ -538,15 +544,47 @@ Recursive Extraction test_proj.
 
 (*** TO SUM UP: ***) 
 
-
-Extraction
- "test_extraction.ml" idnat id id' test2 test3 test4 test5 test6 test7 d d2
-                     d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
-                     test13 test19 test20 nat sumbool_rect c Finite tree
-                     tree_size test14 test15 eta_c test16 test17 test18 bidon
-                     tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
-                     tp1bis Truc oups test24 loop horibilis PropSet natbool
-                     zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
-                     f_arity f_normal Boite boite1 boite2 test_boite Box box1
-                     zarb test_proj.
-
+(* Was previously producing a "test_extraction.ml" *)
+Recursive Extraction 
+  idnat id id' test2 test3 test4 test5 test6 test7 d d2
+  d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
+  test13 test19 test20 nat sumbool_rect c Finite tree
+  tree_size test14 test15 eta_c test16 test17 test18 bidon
+  tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
+  tp1bis Truc oups test24 loop horibilis PropSet natbool
+  zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
+  f_arity f_normal Boite boite1 boite2 test_boite Box box1
+  zarb test_proj.
+
+Extraction Language Haskell.
+(* Was previously producing a "Test_extraction.hs" *)
+Recursive Extraction
+ idnat id id' test2 test3 test4 test5 test6 test7 d d2
+ d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
+ test13 test19 test20 nat sumbool_rect c Finite tree
+ tree_size test14 test15 eta_c test16 test17 test18 bidon
+ tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
+ tp1bis Truc oups test24 loop horibilis PropSet natbool
+ zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
+ f_arity f_normal Boite boite1 boite2 test_boite Box box1
+ zarb test_proj.
+
+Extraction Language Scheme.
+(* Was previously producing a "test_extraction.scm" *)
+Recursive Extraction
+ idnat id id' test2 test3 test4 test5 test6 test7 d d2
+ d3 d4 d5 d6 test8 id id' test9 test10 test11 test12
+ test13 test19 test20 nat sumbool_rect c Finite tree
+ tree_size test14 test15 eta_c test16 test17 test18 bidon
+ tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1
+ tp1bis Truc oups test24 loop horibilis PropSet natbool
+ zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop
+ f_arity f_normal Boite boite1 boite2 test_boite Box box1
+ zarb test_proj.
+                     
+
+(*** Finally, a test more focused on everyday's life situations ***)
+
+Require Import ZArith.
+
+Recursive Extraction two_or_two_plus_one Zdiv_eucl_exist.
diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v
index 374029bb..f4a4d36d 100644
--- a/test-suite/success/fix.v
+++ b/test-suite/success/fix.v
@@ -12,40 +12,41 @@ Require Import ZArith.
 
 Definition rNat := positive.
 
-Inductive rBoolOp: Set :=
-     rAnd: rBoolOp
-    | rEq: rBoolOp .
-
-Definition rlt: rNat -> rNat ->Prop := [a, b:rNat](compare a b EGAL)=INFERIEUR.
-
-Definition rltDec: (m, n:rNat){(rlt m n)}+{(rlt n m) \/ m=n}.
-Intros n m; Generalize (compare_convert_INFERIEUR n m);
- Generalize (compare_convert_SUPERIEUR n m);
- Generalize (compare_convert_EGAL n m); Case (compare n m EGAL).
-Intros H' H'0 H'1; Right; Right; Auto.
-Intros H' H'0 H'1; Left; Unfold rlt.
-Apply convert_compare_INFERIEUR; Auto.
-Intros H' H'0 H'1; Right; Left; Unfold rlt.
-Apply convert_compare_INFERIEUR; Auto.
-Apply H'0; Auto.
+Inductive rBoolOp : Set :=
+  | rAnd : rBoolOp
+  | rEq : rBoolOp.
+
+Definition rlt (a b : rNat) : Prop :=
+  (a ?= b)%positive Datatypes.Eq = Datatypes.Lt.
+
+Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}.
+intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
+ generalize (nat_of_P_gt_Gt_compare_morphism n m);
+ generalize (Pcompare_Eq_eq n m); case ((n ?= m)%positive Datatypes.Eq).
+intros H' H'0 H'1; right; right; auto.
+intros H' H'0 H'1; left; unfold rlt in |- *.
+apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
+intros H' H'0 H'1; right; left; unfold rlt in |- *.
+apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
+apply H'0; auto.
 Defined.
 
 
-Definition rmax: rNat -> rNat ->rNat.
-Intros n m; Case (rltDec n m); Intros Rlt0.
-Exact m.
-Exact n.
+Definition rmax : rNat -> rNat -> rNat.
+intros n m; case (rltDec n m); intros Rlt0.
+exact m.
+exact n.
 Defined.
 
-Inductive rExpr: Set :=
-     rV: rNat ->rExpr
-    | rN: rExpr ->rExpr
-    | rNode: rBoolOp -> rExpr -> rExpr ->rExpr .
-
-Fixpoint maxVar[e:rExpr]: rNat :=
-   Cases e of
-       (rV n) => n
-      | (rN p) => (maxVar p)
-      | (rNode n p q) => (rmax (maxVar p) (maxVar q))
-   end.
+Inductive rExpr : Set :=
+  | rV : rNat -> rExpr
+  | rN : rExpr -> rExpr
+  | rNode : rBoolOp -> rExpr -> rExpr -> rExpr.
+
+Fixpoint maxVar (e : rExpr) : rNat :=
+  match e with
+  | rV n => n
+  | rN p => maxVar p
+  | rNode n p q => rmax (maxVar p) (maxVar q)
+  end.
 
diff --git a/test-suite/success/if.v b/test-suite/success/if.v
index 85cd1f11..9fde95e8 100644
--- a/test-suite/success/if.v
+++ b/test-suite/success/if.v
@@ -1,5 +1,12 @@
 (* The synthesis of the elimination predicate may fail if algebric *)
 (* universes are not cautiously treated *)
 
-Check [b:bool]if b then Type else nat.
+Check (fun b : bool => if b then Type else nat).
+
+(* Check correct use of if-then-else predicate annotation (cf bug 690) *)
+
+Check fun b : bool =>
+ if b as b0 return (if b0 then b0 = true else b0 = false)
+ then refl_equal true
+ else refl_equal false.
 
diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v
index c597f9bf..47c58f04 100644
--- a/test-suite/success/implicit.v
+++ b/test-suite/success/implicit.v
@@ -1,20 +1,23 @@
 (* Implicit on section variables *)
 
 Set Implicit Arguments.
+Unset Strict Implicit.
 
 (* Example submitted by David Nowak *)
 
 Section Spec.
-Variable A:Set.
-Variable op : (A:Set)A->A->Set.
-Infix 6 "#" op V8only (at level 70).
-Check (x:A)(x # x).
+Variable A : Set.
+Variable op : forall A : Set, A -> A -> Set.
+Infix "#" := op (at level 70).
+Check (forall x : A, x # x).
 
 (* Example submitted by Christine *)
-Record stack : Type := {type : Set; elt : type; 
-                        empty : type -> bool; proof : (empty elt)=true }.
+Record stack : Type := 
+  {type : Set; elt : type; empty : type -> bool; proof : empty elt = true}.
 
-Check (type:Set; elt:type; empty:(type->bool))(empty elt)=true->stack.
+Check
+  (forall (type : Set) (elt : type) (empty : type -> bool),
+   empty elt = true -> stack).
 
 End Spec.
 
@@ -22,10 +25,14 @@ End Spec.
 
 Parameter f : nat -> nat * nat.
 Notation lhs := fst.
-Check [x](lhs ? ? (f x)).
-Check [x](!lhs ? ? (f x)).
-Notation "'rhs'" := snd.
-Check [x](rhs ? ? (f x)).
-(* V8 seulement 
-Check (fun x => @ rhs ? ? (f x)).
-*)
+Check (fun x => fst (f x)).
+Check (fun x => fst (f x)).
+Notation rhs := snd.
+Check (fun x => snd (f x)).
+Check (fun x => @ rhs _ _ (f x)).
+
+(* Implicit arguments in fixpoints and inductive declarations *)
+
+Fixpoint g n := match n with O => true | S n => g n end.
+
+Inductive P n : nat -> Prop := c : P n n.
diff --git a/test-suite/success/import_lib.v b/test-suite/success/import_lib.v
index d031691d..c3dc2fc6 100644
--- a/test-suite/success/import_lib.v
+++ b/test-suite/success/import_lib.v
@@ -1,47 +1,47 @@
-Definition le_trans:=O.
+Definition le_trans := 0.
 
 
 Module Test_Read.     
   Module M.  
-    Read Module Le.        (* Reading without importing *)
+    Require Le.        (* Reading without importing *)
 
     Check Le.le_trans.
 
-    Lemma th0 : le_trans = O.
-      Reflexivity.
+    Lemma th0 : le_trans = 0.
+      reflexivity.
     Qed.
   End M.
 
   Check Le.le_trans. 
 
-  Lemma th0 : le_trans = O.
-    Reflexivity.
+  Lemma th0 : le_trans = 0.
+    reflexivity.
   Qed.
 
   Import M.
 
-  Lemma th1 : le_trans = O.
-    Reflexivity.
+  Lemma th1 : le_trans = 0.
+    reflexivity.
   Qed.
 End Test_Read.
 
 
 (****************************************************************)
 
-Definition le_decide := (S O).  (* from Arith/Compare *)
-Definition min := O.            (* from Arith/Min *)
+Definition le_decide := 1.  (* from Arith/Compare *)
+Definition min := 0.            (* from Arith/Min *)
 
 Module Test_Require.
   
   Module M.
-    Require Compare.              (* Imports Min as well *)
+    Require Import Compare.              (* Imports Min as well *)
   
-    Lemma th1 : le_decide = Compare.le_decide.
-      Reflexivity.
+    Lemma th1 : le_decide = le_decide.
+      reflexivity.
     Qed.
   
-    Lemma th2 : min = Min.min.
-      Reflexivity.
+    Lemma th2 : min = min.
+      reflexivity.
     Qed.
   
   End M.
@@ -52,23 +52,23 @@ Module Test_Require.
   
   
   (* Checks that Compare and List are _not_ imported *)
-  Lemma th1 : le_decide = (S O).
-    Reflexivity.
+  Lemma th1 : le_decide = 1.
+    reflexivity.
   Qed.
   
-  Lemma th2 : min = O.
-    Reflexivity.
+  Lemma th2 : min = 0.
+    reflexivity.
   Qed.
   
   (* It should still be the case after Import M *)
   Import M.
   
-  Lemma th3 : le_decide = (S O).
-    Reflexivity.
+  Lemma th3 : le_decide = 1.
+    reflexivity.
   Qed.
   
-  Lemma th4 : min = O.
-    Reflexivity.
+  Lemma th4 : min = 0.
+    reflexivity.
   Qed.
 
 End Test_Require.  
@@ -79,12 +79,12 @@ Module Test_Import.
   Module M.
     Import Compare.              (* Imports Min as well *)
   
-    Lemma th1 : le_decide = Compare.le_decide.
-      Reflexivity.
+    Lemma th1 : le_decide = le_decide.
+      reflexivity.
     Qed.
   
-    Lemma th2 : min = Min.min.
-      Reflexivity.
+    Lemma th2 : min = min.
+      reflexivity.
     Qed.
   
   End M.
@@ -95,23 +95,23 @@ Module Test_Import.
   
   
   (* Checks that Compare and List are _not_ imported *)
-  Lemma th1 : le_decide = (S O).
-    Reflexivity.
+  Lemma th1 : le_decide = 1.
+    reflexivity.
   Qed.
   
-  Lemma th2 : min = O.
-    Reflexivity.
+  Lemma th2 : min = 0.
+    reflexivity.
   Qed.
   
   (* It should still be the case after Import M *)
   Import M.
   
-  Lemma th3 : le_decide = (S O).
-    Reflexivity.
+  Lemma th3 : le_decide = 1.
+    reflexivity.
   Qed.
   
-  Lemma th4 : min = O.
-    Reflexivity.
+  Lemma th4 : min = 0.
+    reflexivity.
   Qed.
 End Test_Import.
 
@@ -121,24 +121,24 @@ Module Test_Export.
   Module M.
     Export Compare.              (* Exports Min as well *)
 
-    Lemma th1 : le_decide = Compare.le_decide.
-      Reflexivity.
+    Lemma th1 : le_decide = le_decide.
+      reflexivity.
     Qed.
 
-    Lemma th2 : min = Min.min.
-      Reflexivity.
+    Lemma th2 : min = min.
+      reflexivity.
     Qed.
 
   End M.
 
 
   (* Checks that Compare and List are _not_ imported *)
-  Lemma th1 : le_decide = (S O).
-    Reflexivity.
+  Lemma th1 : le_decide = 1.
+    reflexivity.
   Qed.
 
-  Lemma th2 : min = O.
-    Reflexivity.
+  Lemma th2 : min = 0.
+    reflexivity.
   Qed.
 
 
@@ -146,12 +146,12 @@ Module Test_Export.
 
   Import M.
 
-  Lemma th3 : le_decide = Compare.le_decide.
-    Reflexivity.
+  Lemma th3 : le_decide = le_decide.
+    reflexivity.
   Qed.
 
-  Lemma th4 : min = Min.min.
-    Reflexivity.
+  Lemma th4 : min = min.
+    reflexivity.
   Qed.
 End Test_Export.
 
@@ -160,30 +160,30 @@ End Test_Export.
 
 Module Test_Require_Export.
 
-  Definition mult_sym:=(S O).    (* from Arith/Mult *)
-  Definition plus_sym:=O.        (* from Arith/Plus *)
+  Definition mult_sym := 1.    (* from Arith/Mult *)
+  Definition plus_sym := 0.        (* from Arith/Plus *)
 
   Module M.
     Require Export Mult.         (* Exports Plus as well *)
 
-    Lemma th1 : mult_sym = Mult.mult_sym.
-      Reflexivity.
+    Lemma th1 : mult_comm = mult_comm.
+      reflexivity.
     Qed.
 
-    Lemma th2 : plus_sym = Plus.plus_sym.
-      Reflexivity.
+    Lemma th2 : plus_comm = plus_comm.
+      reflexivity.
     Qed.
 
   End M.
 
 
   (* Checks that Mult and Plus are _not_ imported *)
-  Lemma th1 : mult_sym = (S O).
-    Reflexivity.
+  Lemma th1 : mult_sym = 1.
+    reflexivity.
   Qed.
 
-  Lemma th2 : plus_sym = O.
-    Reflexivity.
+  Lemma th2 : plus_sym = 0.
+    reflexivity.
   Qed.
 
 
@@ -191,12 +191,12 @@ Module Test_Require_Export.
 
   Import M.
 
-  Lemma th3 : mult_sym = Mult.mult_sym.
-    Reflexivity.
+  Lemma th3 : mult_comm = mult_comm.
+    reflexivity.
   Qed.
 
-  Lemma th4 : plus_sym = Plus.plus_sym.
-    Reflexivity.
+  Lemma th4 : plus_comm = plus_comm.
+    reflexivity.
   Qed.
 
 End Test_Require_Export.
diff --git a/test-suite/success/import_mod.v b/test-suite/success/import_mod.v
index b4a8af46..c098c6e8 100644
--- a/test-suite/success/import_mod.v
+++ b/test-suite/success/import_mod.v
@@ -1,38 +1,38 @@
 
-Definition p:=O.
-Definition m:=O.
+Definition p := 0.
+Definition m := 0.
 
 Module Test_Import.
   Module P.
-    Definition p:=(S O).
+    Definition p := 1.
   End P.
 
   Module M.
     Import P.
-    Definition m:=p.
+    Definition m := p.
   End M.
 
   Module N.
     Import M.
 
-    Lemma th0 : p=O.
-      Reflexivity.
+    Lemma th0 : p = 0.
+      reflexivity.
     Qed.
 
   End N.
 
 
   (* M and P should be closed *)
-  Lemma th1 : m=O /\ p=O.
-    Split; Reflexivity.
+  Lemma th1 : m = 0 /\ p = 0.
+    split; reflexivity.
   Qed.
 
 
   Import N.
 
   (* M and P should still be closed *)
-  Lemma th2 : m=O /\ p=O.
-    Split; Reflexivity.
+  Lemma th2 : m = 0 /\ p = 0.
+    split; reflexivity.
   Qed.
 End Test_Import.
 
@@ -42,34 +42,34 @@ End Test_Import.
 
 Module Test_Export.
   Module P.
-    Definition p:=(S O).
+    Definition p := 1.
   End P.
 
   Module M.
     Export P.
-    Definition m:=p.
+    Definition m := p.
   End M.
 
   Module N.
     Export M.
 
-    Lemma th0 : p=(S O).
-      Reflexivity.
+    Lemma th0 : p = 1.
+      reflexivity.
     Qed.
 
   End N.
 
 
   (* M and P should be closed *)
-  Lemma th1 : m=O /\ p=O.
-    Split; Reflexivity.
+  Lemma th1 : m = 0 /\ p = 0.
+    split; reflexivity.
   Qed.
 
 
   Import N.
 
   (* M and P should now be opened *)
-  Lemma th2 : m=(S O) /\ p=(S O).
-    Split; Reflexivity.
+  Lemma th2 : m = 1 /\ p = 1.
+    split; reflexivity.
   Qed.
 End Test_Export.
diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v
index a391b804..ed8b23c8 100644
--- a/test-suite/success/inds_type_sec.v
+++ b/test-suite/success/inds_type_sec.v
@@ -6,5 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 Section S.
-Inductive T [U:Type] : Type := c : U -> (T U).
+Inductive T (U : Type) : Type :=
+    c : U -> T U.
 End S.
diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v
index 9ae498d2..2aec6e9b 100644
--- a/test-suite/success/induct.v
+++ b/test-suite/success/induct.v
@@ -7,11 +7,11 @@
 (************************************************************************)
 (* Teste des definitions inductives imbriquees *)
 
-Require PolyList.
+Require Import List.
 
-Inductive X : Set := 
-    cons1 : (list X)->X.
+Inductive X : Set :=
+    cons1 : list X -> X.
 
-Inductive Y : Set := 
-    cons2 : (list Y*Y)->Y.
+Inductive Y : Set :=
+    cons2 : list (Y * Y) -> Y.
 
diff --git a/test-suite/success/instantiate.v b/test-suite/success/instantiate.v
new file mode 100644
index 00000000..4224405d
--- /dev/null
+++ b/test-suite/success/instantiate.v
@@ -0,0 +1,11 @@
+(* Test régression bug #1041 *)
+
+Goal Prop.
+
+pose (P:= fun x y :Prop => y).
+evar (Q: forall X Y,P X Y -> Prop) .
+
+instantiate (1:= fun _ => _ ) in (Value of Q).
+instantiate (1:= fun _ => _ ) in (Value of Q).
+instantiate (1:= fun _ => _ ) in (Value of Q).
+instantiate (1:= H) in (Value of Q).
diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v
new file mode 100644
index 00000000..3599da4d
--- /dev/null
+++ b/test-suite/success/intros.v
@@ -0,0 +1,7 @@
+(* Thinning introduction hypothesis must be done after all introductions *)
+(* Submitted by Guillaume Melquiond (bug #1000) *)
+
+Goal forall A, A -> True.
+intros _ _.
+
+
diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v
index 55aa110d..3f25f703 100644
--- a/test-suite/success/ltac.v
+++ b/test-suite/success/ltac.v
@@ -2,20 +2,23 @@
 
 (* Submitted by Pierre Crégut *)
 (* Checks substitution of x *)
-Tactic Definition f x := Unfold x; Idtac.
+Ltac f x := unfold x in |- *; idtac.
  
-Lemma lem1 : (plus O O) = O.
+Lemma lem1 : 0 + 0 = 0.
 f plus.
-Reflexivity.
+reflexivity.
 Qed.
 
 (* Submitted by Pierre Crégut *)
 (* Check syntactic correctness *)
-Recursive Tactic Definition F x := Idtac; (G x)
-And G y := Idtac; (F y).
+Ltac F x := idtac; G x
+ with G y := idtac; F y.
 
 (* Check that Match Context keeps a closure *)
-Tactic Definition U := Let a = 'I In Match Context With [ |- ? ] -> Apply a.
+Ltac U := let a := constr:I in
+          match goal with
+          |  |- _ => apply a
+          end.
 
 Lemma lem2 : True.
 U.
@@ -23,48 +26,152 @@ Qed.
 
 (* Check that Match giving non-tactic arguments are evaluated at Let-time *)
  
-Tactic Definition B :=
- Let y = (Match Context With [ z:? |- ? ] -> z) In 
- Intro H1; Exact y.
+Ltac B := let y := (match goal with
+                    | z:_ |- _ => z
+                    end) in
+          (intro H1; exact y).
 
 Lemma lem3 : True -> False -> True -> False.
-Intros H H0.
+intros H H0.
 B.  (* y is H0 if at let-time, H1 otherwise *)
 Qed.
 
 (* Checks the matching order of hypotheses *)
-Tactic Definition Y := Match Context With [ x:?; y:? |- ? ] -> Apply x.
-Tactic Definition Z := Match Context With [ y:?; x:? |- ? ] -> Apply x.
+Ltac Y := match goal with
+          | x:_,y:_ |- _ => apply x
+          end.
+Ltac Z := match goal with
+          | y:_,x:_ |- _ => apply x
+          end.
 
-Lemma lem4 : (True->False) -> (False->False) -> False.
-Intros H H0.
+Lemma lem4 : (True -> False) -> (False -> False) -> False.
+intros H H0.
 Z. (* Apply H0 *)
 Y. (* Apply H *)
-Exact I.
+exact I.
 Qed.
 
 (* Check backtracking *)
-Lemma back1 : (0)=(1)->(0)=(0)->(1)=(1)->(0)=(0).
-Intros; Match Context With [_:(O)=?1;_:(1)=(1)|-? ] -> Exact (refl_equal ? ?1).
+Lemma back1 : 0 = 1 -> 0 = 0 -> 1 = 1 -> 0 = 0.
+intros;
+ match goal with
+ | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1)
+ end.
 Qed.
 
-Lemma back2 : (0)=(0)->(0)=(1)->(1)=(1)->(0)=(0).
-Intros; Match Context With [_:(O)=?1;_:(1)=(1)|-? ] -> Exact (refl_equal ? ?1).
+Lemma back2 : 0 = 0 -> 0 = 1 -> 1 = 1 -> 0 = 0.
+intros;
+ match goal with
+ | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1)
+ end.
 Qed.
 
-Lemma back3 : (0)=(0)->(1)=(1)->(0)=(1)->(0)=(0).
-Intros; Match Context With [_:(O)=?1;_:(1)=(1)|-? ] -> Exact (refl_equal ? ?1).
+Lemma back3 : 0 = 0 -> 1 = 1 -> 0 = 1 -> 0 = 0.
+intros;
+ match goal with
+ | _:(0 = ?X1),_:(1 = 1) |- _ => exact (refl_equal X1)
+ end.
 Qed.
 
 (* Check context binding *)
-Tactic Definition sym t := Match t With [C[?1=?2]] -> Inst C[?1=?2].
-
-Lemma sym : ~(0)=(1)->~(1)=(0).
-Intro H.
-Let t = (sym (Check H)) In Assert t.
-Exact H.
-Intro H1.
-Apply H.
-Symmetry.
-Assumption.
+Ltac sym t :=
+  match constr:t with
+  | context C[(?X1 = ?X2)] => context C [X1 = X2]
+  end.
+
+Lemma sym : 0 <> 1 -> 1 <> 0.
+intro H.
+let t := sym type of H in
+assert t.
+exact H.
+intro H1.
+apply H.
+symmetry  in |- *.
+assumption.
+Qed.
+
+(* Check context binding in match goal *)
+(* This wasn't working in V8.0pl1, as the list of matched hyps wasn't empty *)
+Ltac sym' :=
+  match goal with
+  | _:True |- context C[(?X1 = ?X2)] =>
+      let t := context C [X2 = X1] in
+      assert t
+  end.
+
+Lemma sym' : True -> 0 <> 1 -> 1 <> 0.
+intros Ht H.
+sym'.
+exact H.
+intro H1.
+apply H.
+symmetry  in |- *.
+assumption.
+Qed.
+
+(* Check that fails abort the current match context *)
+Lemma decide : True \/ False.
+match goal with
+| _ => fail 1
+| _ => right
+end || left.
+exact I.
 Qed.
+
+(* Check that "match c with" backtracks on subterms *)
+Lemma refl : 1 = 1.
+let t :=
+ (match constr:(1 = 2) with
+  | context [(S ?X1)] => constr:(refl_equal X1:1 = 1)
+  end) in
+assert (H := t).
+assumption.
+Qed.
+
+(* Note that backtracking in "match c with" is only on type-checking not on
+evaluation of tactics. E.g., this does not work
+
+Lemma refl : (1)=(1).
+Match (1)=(2) With
+  [[(S ?1)]] -> Apply (refl_equal nat ?1).
+Qed.
+*)
+
+
+(* Check the precedences of rel context, ltac context and vars context *)
+(* (was wrong in V8.0) *)
+
+Ltac check_binding y := cut ((fun y => y) = S).
+Goal True.
+check_binding true.
+Abort.
+
+(* Check that variables explicitly parsed as ltac variables are not
+   seen as intro pattern or constr (bug #984) *)
+
+Ltac afi tac := intros; tac.
+Goal 1 = 2.
+afi ltac:auto.
+
+(* Tactic Notation avec listes *)
+
+Tactic Notation "pat" hyp(id) "occs" integer_list(l) := pattern id at l.
+
+Goal forall x, x=0 -> x=x.
+intro x.
+pat x occs 1 3.
+Abort.
+
+Tactic Notation "revert" ne_hyp_list(l) := generalize l; clear l.
+
+Goal forall a b c, a=0 -> b=c+a.
+intros.
+revert a b c H.
+Abort.
+
+(* Used to fail until revision 9280 because of a parasitic App node with
+   empty args *)
+
+Goal True.
+match None with @None => exact I end.
+Abort.
diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v
index e932f50c..463efed3 100644
--- a/test-suite/success/mutual_ind.v
+++ b/test-suite/success/mutual_ind.v
@@ -7,35 +7,36 @@
 (************************************************************************)
 (* Definition mutuellement inductive et dependante *)
 
-Require Export PolyList.
+Require Export List.
 
- Record signature : Type := {
-    sort : Set;
-    sort_beq : sort->sort->bool;
-    sort_beq_refl : (f:sort)true=(sort_beq f f);
-    sort_beq_eq : (f1,f2:sort)true=(sort_beq f1 f2)->f1=f2;
+ Record signature : Type := 
+   {sort : Set;
+    sort_beq : sort -> sort -> bool;
+    sort_beq_refl : forall f : sort, true = sort_beq f f;
+    sort_beq_eq : forall f1 f2 : sort, true = sort_beq f1 f2 -> f1 = f2;
     fsym :> Set;
-    fsym_type : fsym->(list sort)*sort;
-    fsym_beq : fsym->fsym->bool;
-    fsym_beq_refl : (f:fsym)true=(fsym_beq f f);
-    fsym_beq_eq : (f1,f2:fsym)true=(fsym_beq f1 f2)->f1=f2
-  }.
+    fsym_type : fsym -> list sort * sort;
+    fsym_beq : fsym -> fsym -> bool;
+    fsym_beq_refl : forall f : fsym, true = fsym_beq f f;
+    fsym_beq_eq : forall f1 f2 : fsym, true = fsym_beq f1 f2 -> f1 = f2}.
 
  
  Variable F : signature.
 
-  Definition vsym := (sort F)*nat.
+  Definition vsym := (sort F * nat)%type.
 
-  Definition vsym_sort := (fst (sort F) nat).
-  Definition vsym_nat := (snd (sort F) nat).
+  Definition vsym_sort := fst (A:=sort F) (B:=nat).
+  Definition vsym_nat := snd (A:=sort F) (B:=nat).
  
 
-  Mutual Inductive term : (sort F)->Set :=
-  	| term_var : (v:vsym)(term (vsym_sort v))
-	| term_app : (f:F)(list_term (Fst (fsym_type F f)))
-		->(term (Snd (fsym_type F f)))
-  with list_term : (list (sort F)) -> Set :=
-	| term_nil : (list_term (nil (sort F)))
-	| term_cons : (s:(sort F);l:(list (sort F)))
-	  (term s)->(list_term l)->(list_term (cons s l)).
+  Inductive term : sort F -> Set :=
+    | term_var : forall v : vsym, term (vsym_sort v)
+    | term_app :
+        forall f : F,
+        list_term (fst (fsym_type F f)) -> term (snd (fsym_type F f))
+with list_term : list (sort F) -> Set :=
+  | term_nil : list_term nil
+  | term_cons :
+      forall (s : sort F) (l : list (sort F)),
+      term s -> list_term l -> list_term (s :: l).
 
diff --git a/test-suite/success/options.v b/test-suite/success/options.v
index 9e9af4fa..bb678150 100644
--- a/test-suite/success/options.v
+++ b/test-suite/success/options.v
@@ -1,5 +1,7 @@
 (* Check that the syntax for options works *)
 Set Implicit Arguments.
+Unset Strict Implicit.
+Set Strict Implicit.
 Unset Implicit Arguments.
 Test Implicit Arguments.
 
@@ -12,16 +14,16 @@ Unset Silent.
 Test Silent.
 
 Set Printing Depth 100.
-Print Table Printing Depth.
+Test Printing Depth.
 
 Parameter i : bool -> nat.
 Coercion i : bool >-> nat.
-Set Printing Coercion i.
-Unset Printing Coercion i.
+Add Printing Coercion i.
+Remove Printing Coercion i.
 Test Printing Coercion i.
 
-Print Table Printing Let.
-Print Table Printing If.
+Test Printing Let.
+Test Printing If.
 Remove Printing Let sig.
 Remove Printing If bool.
 
diff --git a/test-suite/success/params_ind.v b/test-suite/success/params_ind.v
new file mode 100644
index 00000000..1bee31c8
--- /dev/null
+++ b/test-suite/success/params_ind.v
@@ -0,0 +1,4 @@
+Inductive list (A : Set) : Set :=
+  | nil : list A
+  | cons : A -> list (A -> A) -> list A.
+
diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v
new file mode 100644
index 00000000..5a008f18
--- /dev/null
+++ b/test-suite/success/polymorphism.v
@@ -0,0 +1,12 @@
+(* Some tests of sort-polymorphisme *)
+Section S.
+Variable A:Type.
+(*
+Definition f (B:Type) := (A * B)%type.
+*)
+Inductive I (B:Type) : Type := prod : A->B->I B.
+End S.
+(*
+Check f nat nat : Set.
+*)
+Check I nat nat : Set.
diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v
index ad4eed5a..4346ce9a 100644
--- a/test-suite/success/refine.v
+++ b/test-suite/success/refine.v
@@ -1,30 +1,89 @@
 
 (* Refine and let-in's *)
 
-Goal (EX x:nat | x=O).
-Refine let y = (plus O O) in ?.
-Exists y; Auto.
+Goal exists x : nat, x = 0.
+ refine (let y := 0 + 0 in _).
+exists y; auto.
 Save test1.
 
-Goal (EX x:nat | x=O).
-Refine let y = (plus O O) in (ex_intro ? ? (plus y y) ?).  
-Auto.
+Goal exists x : nat, x = 0.
+ refine (let y := 0 + 0 in ex_intro _ (y + y) _).  
+auto.
 Save test2.
 
 Goal nat.
-Refine let y = O in (plus O ?).
-Exact (S O).
+ refine (let y := 0 in 0 + _).
+exact 1.
 Save test3.
 
 (* Example submitted by Yves on coqdev *)
 
-Require PolyList.
+Require Import List.
 
-Goal (l:(list nat))l=l.
+Goal forall l : list nat, l = l.
 Proof.
-Refine [l]<[l]l=l>
-       Cases l of
-       | nil => ?
-       | (cons O l0) => ?
-       | (cons (S _) l0) => ?
-       end.
+ refine
+ (fun l =>
+  match l return (l = l) with
+  | nil => _
+  | O :: l0 => _
+  | S _ :: l0 => _
+  end).
+Abort.
+
+(* Submitted by Roland Zumkeller (bug #888) *)
+
+(* The Fix and CoFix rules expect a subgoal even for closed components of the
+   (co-)fixpoint *)
+
+Goal nat -> nat.
+ refine (fix f (n : nat) : nat := S _
+         with pred (n : nat) : nat := n
+         for f).
+exact 0.
+Qed.
+
+(* Submitted by Roland Zumkeller (bug #889) *)
+
+(* The types of metas were in metamap and they were not updated when
+   passing through a binder *)
+
+Goal forall n : nat, nat -> n = 0.
+ refine
+ (fun n => fix f (i : nat) : n = 0 := match i with
+                                      | O => _
+                                      | S _ => _
+                                      end).
+Abort.
+
+(* Submitted by Roland Zumkeller (bug #931) *)
+(* Don't turn dependent evar into metas *)
+
+Goal (forall n : nat, n = 0 -> Prop) -> Prop.
+intro P.
+ refine (P _ _).
+reflexivity.
+Abort.
+
+(* Submitted by Jacek Chrzaszcz (bug #1102) *)
+
+(* le problème a été résolu ici par normalisation des evars présentes
+   dans les types d'evars, mais le problème reste a priori ouvert dans
+   le cas plus général d'evars non instanciées dans les types d'autres
+   evars *)
+
+Goal exists n:nat, n=n.
+refine (ex_intro _ _ _).
+Abort.
+
+(* Used to failed with error not clean *)
+
+Definition div :
+  forall x:nat, (forall y:nat, forall n:nat, {q:nat | y = q*n}) -> 
+     forall n:nat, {q:nat | x = q*n}.
+refine
+  (fun m div_rec n =>
+     match div_rec m n with
+     | exist _ _ => _
+     end).
+Abort.
diff --git a/test-suite/success/replace.v b/test-suite/success/replace.v
new file mode 100644
index 00000000..94b75c7f
--- /dev/null
+++ b/test-suite/success/replace.v
@@ -0,0 +1,24 @@
+Goal forall x, x = 0 -> S x = 7 -> x = 22 .
+Proof.
+replace 0 with 33.
+Undo.
+intros x H H0.
+replace x with 0.
+Undo.
+replace x with 0 in  |- *. 
+Undo.
+replace x with 1 in *.
+Undo.
+replace x with 0 in *|- *.
+Undo.
+replace x with 0 in *|-.
+Undo.
+replace x with 0 in H0 .
+Undo.
+replace x with 0 in H0 |- * .
+Undo.
+
+replace x with 0 in H,H0 |- * .
+Undo.
+Admitted.
+
diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v
new file mode 100644
index 00000000..9629b213
--- /dev/null
+++ b/test-suite/success/rewrite.v
@@ -0,0 +1,19 @@
+(* Check that dependent rewrite applies on arbitrary terms *)
+
+Inductive listn : nat -> Set :=
+  | niln : listn 0
+  | consn : forall n : nat, nat -> listn n -> listn (S n).
+
+Axiom
+  ax :
+    forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)),
+    existS _ (n + n') l = existS _ (n' + n) l'.
+
+Lemma lem :
+ forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)),
+ n + n' = n' + n /\ existT _ (n + n') l = existT _ (n' + n) l'.
+Proof.
+intros n n' l l'.
+ dependent rewrite (ax n n' l l').
+split; reflexivity.
+Qed.
diff --git a/test-suite/success/rewrite_in.v b/test-suite/success/rewrite_in.v
new file mode 100644
index 00000000..29fe915f
--- /dev/null
+++ b/test-suite/success/rewrite_in.v
@@ -0,0 +1,8 @@
+Require Import Setoid.
+
+Goal forall (P Q : Prop) (f:P->Prop) (p:P), (P<->Q) -> f p -> True.
+  intros P Q f p H.
+  rewrite H in p || trivial.
+Qed.
+
+
diff --git a/test-suite/success/set.v b/test-suite/success/set.v
new file mode 100644
index 00000000..23019275
--- /dev/null
+++ b/test-suite/success/set.v
@@ -0,0 +1,8 @@
+Goal forall n, n+n=0->0=n+n.
+intros.
+
+(* This used to fail in 8.0pl1 *)
+set n in * |-.
+
+
+
diff --git a/test-suite/success/setoid_ring_module.v b/test-suite/success/setoid_ring_module.v
new file mode 100644
index 00000000..e947c6d9
--- /dev/null
+++ b/test-suite/success/setoid_ring_module.v
@@ -0,0 +1,40 @@
+Require Import Setoid Ring Ring_theory.
+
+Module abs_ring.
+
+Parameters (Coef:Set)(c0 c1 : Coef)
+(cadd cmul csub: Coef -> Coef -> Coef)
+(copp : Coef -> Coef)
+(ceq : Coef -> Coef -> Prop)
+(ceq_sym : forall x y, ceq x y -> ceq y x)
+(ceq_trans : forall x y z, ceq x y -> ceq y z -> ceq x z)
+(ceq_refl : forall x, ceq x x).
+
+
+Add Relation Coef ceq 
+  reflexivity proved by ceq_refl symmetry proved by ceq_sym
+  transitivity proved by ceq_trans
+  as ceq_relation.
+  
+Add Morphism cadd with signature ceq ==> ceq ==> ceq as cadd_Morphism.
+Admitted.
+
+Add Morphism cmul with signature ceq ==> ceq ==> ceq as cmul_Morphism.
+Admitted.
+
+Add Morphism copp with signature ceq ==> ceq as copp_Morphism.
+Admitted.
+
+Definition cRth : ring_theory c0 c1 cadd cmul csub copp ceq.
+Admitted.
+
+Add Ring CoefRing : cRth.
+
+End abs_ring.
+Import abs_ring.
+
+Theorem check_setoid_ring_modules :
+  forall a b, ceq (cadd a b) (cadd b a).
+intros.
+ring.
+Qed.
diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v
index 2d2b2af8..dd1022f0 100644
--- a/test-suite/success/setoid_test.v
+++ b/test-suite/success/setoid_test.v
@@ -1,104 +1,106 @@
-Require Setoid.
+Require Import Setoid.
 
 Parameter A : Set.
 
-Axiom eq_dec : (a,b :A) {a=b}+{~a=b}.
+Axiom eq_dec : forall a b : A, {a = b} + {a <> b}.
 
 Inductive set : Set :=
-|Empty : set
-|Add : A -> set -> set.
+  | Empty : set
+  | Add : A -> set -> set.
 
-Fixpoint In [a:A; s:set] : Prop :=
-Cases s of
-|Empty => False
-|(Add b s') => a=b \/ (In a s')
-end.
+Fixpoint In (a : A) (s : set) {struct s} : Prop :=
+  match s with
+  | Empty => False
+  | Add b s' => a = b \/ In a s'
+  end.
 
-Definition same [s,t:set] : Prop :=
-(a:A) (In a s) <-> (In a t).
+Definition same (s t : set) : Prop := forall a : A, In a s <-> In a t.
 
-Lemma setoid_set : (Setoid_Theory set same).
+Lemma setoid_set : Setoid_Theory set same.
 
-Unfold same; Split.
-Red; Auto.
+unfold same in |- *; split.
+red in |- *; auto.
 
-Red.
-Intros.
-Elim (H a); Auto.
+red in |- *.
+intros.
+elim (H a); auto.
 
-Intros.
-Elim (H a); Elim (H0 a).
-Split; Auto.
-Save.
+intros.
+elim (H a); elim (H0 a).
+split; auto.
+Qed.
 
-Add Setoid set same setoid_set.
+Add Setoid set same setoid_set as setsetoid.
 
 Add Morphism In : In_ext.
-Unfold same; Intros a s t H; Elim (H a); Auto.
-Save.
-
-Lemma add_aux : (s,t:set) (same s t) ->
-  (a,b:A)(In a (Add b s)) -> (In a (Add b t)).
-Unfold same; Induction 2; Intros.
-Rewrite H1.
-Simpl; Left; Reflexivity.
-
-Elim (H a).
-Intros.
-Simpl; Right.
-Apply (H2 H1).
-Save.
+unfold same in |- *; intros a s t H; elim (H a); auto.
+Qed.
+
+Lemma add_aux :
+ forall s t : set,
+ same s t -> forall a b : A, In a (Add b s) -> In a (Add b t).
+unfold same in |- *; simple induction 2; intros.
+rewrite H1.
+simpl in |- *; left; reflexivity.
+
+elim (H a).
+intros.
+simpl in |- *; right.
+apply (H2 H1).
+Qed.
 
 Add Morphism Add : Add_ext.
-Split; Apply add_aux.
-Assumption.
+split; apply add_aux.
+assumption.
+
+rewrite H.
+reflexivity.
+Qed.
 
-Rewrite H.
-Apply Seq_refl.
-Exact setoid_set.
-Save.
+Fixpoint remove (a : A) (s : set) {struct s} : set :=
+  match s with
+  | Empty => Empty
+  | Add b t =>
+      match eq_dec a b with
+      | left _ => remove a t
+      | right _ => Add b (remove a t)
+      end
+  end.
 
-Fixpoint remove [a:A; s:set] : set :=
-Cases s of
-|Empty => Empty
-|(Add b t) => Cases (eq_dec a b) of
-              |(left _) => (remove a t)
-              |(right _) => (Add b (remove a t))
-              end
-end.
+Lemma in_rem_not : forall (a : A) (s : set), ~ In a (remove a (Add a Empty)).
 
-Lemma in_rem_not : (a:A)(s:set) ~(In a (remove a (Add a Empty))).
+intros.
+setoid_replace (remove a (Add a Empty)) with Empty.
 
-Intros.
-Setoid_replace (remove a (Add a Empty)) with Empty.
-Unfold same.
-Split.
-Simpl.
-Intro H; Elim H.
+auto.
 
-Simpl.
-Case (eq_dec a a).
-Intros e ff; Elim ff.
+unfold same in |- *.
+split.
+simpl in |- *.
+case (eq_dec a a).
+intros e ff; elim ff.
 
-Intros; Absurd a=a; Trivial.
+intros; absurd (a = a); trivial.
 
-Auto.
-Save.
+simpl in |- *.
+intro H; elim H.
+Qed.
 
-Parameter P :set -> Prop.
-Parameter P_ext : (s,t:set) (same s t) -> (P s) -> (P t).
+Parameter P : set -> Prop.
+Parameter P_ext : forall s t : set, same s t -> P s -> P t.
 
 Add Morphism P : P_extt.
-Exact P_ext.
-Save.
-
-Lemma test_rewrite : (a:A)(s,t:set)(same s t) -> (P (Add a s)) -> (P (Add a t)).
-Intros.
-Rewrite <- H.
-Rewrite H.
-Setoid_rewrite <- H.
-Setoid_rewrite H.
-Setoid_rewrite <- H.
-Trivial.
-Save.
+intros; split; apply P_ext; (assumption || apply (Seq_sym _ _ setoid_set); assumption).
+Qed.
+
+Lemma test_rewrite :
+ forall (a : A) (s t : set), same s t -> P (Add a s) -> P (Add a t).
+intros.
+rewrite <- H.
+rewrite H.
+setoid_rewrite <- H.
+setoid_rewrite H.
+setoid_rewrite <- H.
+trivial.
+Qed.
 
diff --git a/test-suite/success/setoid_test2.v b/test-suite/success/setoid_test2.v
new file mode 100644
index 00000000..bac1cf14
--- /dev/null
+++ b/test-suite/success/setoid_test2.v
@@ -0,0 +1,242 @@
+Require Export Setoid.
+
+(* Testare:
+   +1. due setoidi con ugualianza diversa sullo stesso tipo
+   +2. due setoidi sulla stessa uguaglianza
+   +3. due morfismi sulla stessa funzione ma setoidi diversi
+   +4. due morfismi sulla stessa funzione e stessi setoidi
+   +5. setoid_replace
+   +6. solo cammini mal tipati
+   +7. esempio (f (g (h E1)))
+       dove h:(T1,=1) -> T2, g:T2->(T3,=3), f:(T3,=3)->Prop
+   +8. test con occorrenze non lineari del pattern
+   +9. test in cui setoid_replace fa direttamente fallback su replace
+   10. sezioni
+  +11. goal con impl
+  +12. testare *veramente* setoid_replace (ora testato solamente il caso
+       di fallback su replace)
+
+  Incompatibilita':
+    1. full_trivial in setoid_replace
+    2. "as ..." per "Add Setoid"
+    3. ipotesi permutate in lemma di "Add Morphism"
+    4. iff invece di if in "Add Morphism" nel caso di predicati
+    5. setoid_replace poteva riscrivere sia c1 in c2 che c2 in c1
+       (???? o poteva farlo da destra a sinitra o viceversa? ????)
+
+### Come evitare di dover fare "Require Setoid" prima di usare la
+    tattica?
+
+??? scelta: quando ci sono piu' scelte dare un warning oppure fallire?
+    difficile quando la tattica e' rewrite ed e' usata in tattiche
+    automatiche
+
+??? in test4.v il setoid_rewrite non si puo' sostituire con rewrite
+    perche' questo ultimo fallisce per via dell'unificazione
+
+??? ??? <-> non e' sottorelazione di ->. Quindi ora puo' capitare
+    di non riuscire a provare goal del tipo A /\ B dove (A, <->) e
+    (B, ->) (per esempio)
+
+### Nota: il parsing e pretty printing delle relazioni non e' in synch!
+    eq contro (ty,eq). Uniformare
+
+### diminuire la taglia dei proof term
+
+??? il messaggio di errore non e' assolutamente significativo quando
+    nessuna marcatura viene trovata
+
+### fare in modo che uscendo da una sezione vengano quantificate le
+    relazioni e i morfismi. Hugo: paciugare nel discharge.ml
+
+### implementare relazioni/morfismi quantificati con dei LetIn (che palle...)
+    decompose_prod da far diventare simile a un Reduction.dest_arity?
+    (ma senza riduzione??? e perche' li' c'e' riduzione?)
+    Soluzione da struzzo: fare zeta-conversione.
+
+### fare in modo che impl sia espanso nel lemma di compatibilita' del
+    morfismo (richiesta di Marco per poter fare Add Hing)
+
+??? snellire la sintassi omettendo "proved by" come proposto da Marco?  ;-(
+
+### non capisce piu' le riscritture con uguaglianze quantificate (almeno
+    nell'esempio di Marco)
+### Bas Spitters: poter dichiarare che ogni variabile nel contesto di tipo
+    un setoid_function e' un morfismo
+
+### unificare le varie check_...
+### sostituire a Use_* una sola eccezione Optimize
+
+  Implementare:
+   -2. user-defined subrelations && user-proved subrelations
+   -1. trucco di Bruno
+
+  Sorgenti di inefficacia:
+    1. scelta del setoide di default per un sostegno: per farlo velocemente
+       ci vorrebbe una tabella hash; attualmente viene fatta una ricerca
+       lineare sul range della setoid_table
+
+  Vantaggi rispetto alla vecchia tattica:
+    1. permette di avere setoidi differenti con lo stesso sostegno,
+       ma equivalenza differente
+    2. accetta setoidi differenti con lo stesso sostegno e stessa
+       equivalenza, scegliendo a caso quello da usare (proof irrelevance)
+    3. permette di avere morfismi differenti sulla stessa funzione
+       se hanno dominio o codominio differenti
+    4. accetta di avere morfismi differenti sulla stessa funzione e con
+       lo stesso dominio e codominio, scegliendo a caso quello da usare
+       (proof irrelevance)
+    5. quando un morfismo viene definito, se la scelta del dominio o del
+       codominio e' ambigua l'utente puo' esplicitamente disambiguare
+       la scelta fornendo esplicitamente il "tipo" del morfismo
+    6. permette di gestire riscritture ove ad almeno una funzione venga
+       associato piu' di un morfismo. Vengono automaticamente calcolate
+       le scelte globali che rispettano il tipaggio.
+    7. se esistono piu' scelte globali che rispettano le regole di tipaggio
+       l'utente puo' esplicitamente disambiguare la scelta globale fornendo
+       esplicitamente la scelta delle side conditions generate.
+    8. nel caso in cui la setoid_replace sia stata invocata al posto
+       della replace la setoid_replace invoca direttamente la replace.
+       Stessa cosa per la setoid_rewrite.
+    9. permette di gestire termini in cui il prefisso iniziale dell'albero
+       (fino a trovare il termine da riscrivere) non sia formato esclusivamente
+       da morfismi il cui dominio e codominio sia un setoide.
+       Ovvero ammette anche morfismi il cui dominio e/o codominio sia
+       l'uguaglianza di Leibniz. (Se entrambi sono uguaglianze di Leibniz
+       allora il setoide e' una semplice funzione).
+   10. [setoid_]rewrite ... in ...
+       setoid_replace ... in ...
+       [setoid_]reflexivity
+       [setoid_]transitivity ...
+       [setoid_]symmetry
+       [setoid_]symmetry in ...
+   11. permette di dichiarare dei setoidi/relazioni/morfismi in un module
+       type
+   12. relazioni, morfismi e setoidi quantificati
+*)
+
+Axiom S1: Set.
+Axiom eqS1: S1 -> S1 -> Prop.
+Axiom SetoidS1 : Setoid_Theory S1 eqS1.
+Add Setoid S1 eqS1 SetoidS1 as S1setoid.
+
+Axiom eqS1': S1 -> S1 -> Prop.
+Axiom SetoidS1' : Setoid_Theory S1 eqS1'.
+Axiom SetoidS1'_bis : Setoid_Theory S1 eqS1'.
+Add Setoid S1 eqS1' SetoidS1' as S1setoid'.
+Add Setoid S1 eqS1' SetoidS1'_bis as S1setoid''.
+
+Axiom S2: Set.
+Axiom eqS2: S2 -> S2 -> Prop.
+Axiom SetoidS2 : Setoid_Theory S2 eqS2.
+Add Setoid S2 eqS2 SetoidS2 as S2setoid.
+
+Axiom f : S1 -> nat -> S2.
+Add Morphism f : f_compat. Admitted.
+Add Morphism f : f_compat2. Admitted.
+
+Theorem test1: forall x y, (eqS1 x y) -> (eqS2 (f x 0) (f y 0)).
+ intros.
+ rewrite H.
+ reflexivity.
+Qed.
+
+Theorem test1': forall x y, (eqS1 x y) -> (eqS2 (f x 0) (f y 0)).
+ intros.
+ setoid_replace x with y.
+ reflexivity.
+ assumption.
+Qed.
+
+Axiom g : S1 -> S2 -> nat.
+Add Morphism g : g_compat. Admitted.
+
+Axiom P : nat -> Prop.
+Theorem test2:
+ forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (P (g x' y')) -> (P (g x y)).
+ intros.
+ rewrite H.
+ rewrite H0.
+ assumption.
+Qed.
+
+Theorem test3:
+ forall x x' y y',
+  (eqS1 x x') -> (eqS2 y y') -> (P (S (g x' y'))) -> (P (S (g x y))).
+ intros.
+ rewrite H.
+ rewrite H0.
+ assumption.
+Qed.
+
+Theorem test4:
+ forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (S (g x y)) = (S (g x' y')).
+ intros.
+ rewrite H.
+ rewrite H0.
+ reflexivity.
+Qed.
+
+Theorem test5:
+ forall x x' y y', (eqS1 x x') -> (eqS2 y y') -> (S (g x y)) = (S (g x' y')).
+ intros.
+ setoid_replace (g x y) with (g x' y').
+ reflexivity.
+ rewrite <- H0.
+ rewrite H.
+ reflexivity.
+Qed.
+
+Axiom f_test6 : S2 -> Prop.
+Add Morphism f_test6 : f_test6_compat. Admitted.
+
+Axiom g_test6 : bool -> S2.
+Add Morphism g_test6 : g_test6_compat. Admitted.
+
+Axiom h_test6 : S1 -> bool.
+Add Morphism h_test6 : h_test6_compat. Admitted.
+
+Theorem test6:
+ forall E1 E2, (eqS1 E1 E2) -> (f_test6 (g_test6 (h_test6 E2))) ->
+  (f_test6 (g_test6 (h_test6 E1))).
+ intros.
+ rewrite  H.
+ assumption.
+Qed.
+  
+Theorem test7:
+ forall E1 E2 y y', (eqS1 E1 E2) -> (eqS2 y y') ->
+  (f_test6 (g_test6 (h_test6 E2))) ->
+   (f_test6 (g_test6 (h_test6 E1))) /\ (S (g E1 y')) = (S (g E2 y')).
+  intros.
+  rewrite H.
+  split; [assumption | reflexivity].
+Qed.
+
+Axiom S1_test8: Set.
+Axiom eqS1_test8: S1_test8 -> S1_test8 -> Prop.
+Axiom SetoidS1_test8 : Setoid_Theory S1_test8 eqS1_test8.
+Add Setoid S1_test8 eqS1_test8 SetoidS1_test8 as S1_test8setoid.
+
+Axiom f_test8 : S2 -> S1_test8.
+Add Morphism f_test8 : f_compat_test8. Admitted.
+
+Axiom eqS1_test8': S1_test8 -> S1_test8 -> Prop.
+Axiom SetoidS1_test8' : Setoid_Theory S1_test8 eqS1_test8'.
+Add Setoid S1_test8 eqS1_test8' SetoidS1_test8' as S1_test8setoid'.
+    
+(*CSC: for test8 to be significant I want to choose the setoid
+  (S1_test8, eqS1_test8'). However this does not happen and
+  there is still no syntax for it ;-( *)
+Axiom g_test8 : S1_test8 -> S2.
+Add Morphism g_test8 : g_compat_test8. Admitted.
+
+Theorem test8:
+ forall x x': S2, (eqS2 x x') ->
+  (eqS2 (g_test8 (f_test8 x)) (g_test8 (f_test8 x'))).
+  intros.
+  rewrite H.
+Abort.
+
+(*Print Setoids.*)
+
diff --git a/test-suite/success/setoid_test_function_space.v b/test-suite/success/setoid_test_function_space.v
new file mode 100644
index 00000000..1602991d
--- /dev/null
+++ b/test-suite/success/setoid_test_function_space.v
@@ -0,0 +1,45 @@
+Require Export Setoid.
+Set Implicit Arguments.
+Section feq.
+Variables A B:Type.
+Definition feq (f g: A -> B):=forall a, (f a)=(g a).
+Infix "=f":= feq  (at level 80, right associativity).
+Hint Unfold feq.
+
+Lemma feq_refl: forall f, f =f f.
+intuition.
+Qed.
+                                                                                
+Lemma feq_sym: forall f g, f =f g-> g =f f.
+intuition.
+Qed.
+                                                                                
+Lemma feq_trans: forall f g h, f =f g-> g =f h -> f  =f h.
+unfold feq. intuition.
+rewrite H.
+auto.
+Qed.
+End feq.
+Infix "=f":= feq  (at level 80, right associativity).
+Hint Unfold feq. Hint Resolve feq_refl feq_sym feq_trans.
+                                                                                
+Variable K:(nat -> nat)->Prop.
+Variable K_ext:forall a b, (K a)->(a =f b)->(K b).
+
+Add Relation (fun A B:Type => A -> B) feq
+ reflexivity proved by feq_refl
+ symmetry proved by feq_sym
+ transitivity proved by feq_trans as funsetoid.
+                                                                             
+Add Morphism K with signature feq ==> iff as K_ext1.
+intuition. apply (K_ext H0 H).
+intuition. assert (x2 =f x1);auto.  apply (K_ext H0 H1).
+Qed.
+
+Lemma three:forall n, forall a, (K a)->(a =f (fun m => (a (n+m))))-> (K (fun m
+=> (a (n+m)))).
+intuition.
+setoid_rewrite <- H0.
+assumption.
+Qed.
+
diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v
new file mode 100644
index 00000000..8d32b1d9
--- /dev/null
+++ b/test-suite/success/simpl.v
@@ -0,0 +1,24 @@
+(* Check that inversion of names of mutual inductive fixpoints works *)
+(* (cf bug #1031) *)
+
+Inductive tree : Set :=
+| node : nat -> forest -> tree  
+with forest    : Set :=
+| leaf : forest  
+| cons : tree    -> forest   -> forest  
+    .
+Definition copy_of_compute_size_forest := 
+fix copy_of_compute_size_forest (f:forest) : nat :=
+  match f with
+  | leaf => 1
+  | cons t f0 => copy_of_compute_size_forest f0 + copy_of_compute_size_tree t
+  end
+with copy_of_compute_size_tree (t:tree) : nat :=
+  match t with
+  | node _ f => 1 + copy_of_compute_size_forest f
+  end for copy_of_compute_size_forest
+.
+Eval simpl in (copy_of_compute_size_forest leaf).
+
+
+
diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v
index de75dfce..35910011 100644
--- a/test-suite/success/unfold.v
+++ b/test-suite/success/unfold.v
@@ -8,8 +8,8 @@
 (* Test le Hint Unfold sur des var locales *)
 
 Section toto.
-Local EQ:=eq.
-Goal (EQ nat O O).
-Hints Unfold EQ.
-Auto.
-Save.
+Let EQ := eq.
+Goal EQ nat 0 0.
+Hint Unfold EQ.
+auto.
+Qed.
diff --git a/test-suite/success/unicode_utf8.v b/test-suite/success/unicode_utf8.v
new file mode 100644
index 00000000..19e306fe
--- /dev/null
+++ b/test-suite/success/unicode_utf8.v
@@ -0,0 +1,12 @@
+(* Check correct separation of identifiers followed by unicode symbols *)
+  Notation "x 〈 w" := (plus x w) (at level 30).
+  Check fun x => x〈x.
+
+(* Check Greek letters *)
+Definition test_greek : nat -> nat := fun Δ => Δ.
+Parameter � : Set.
+Parameter π : �.
+
+(* Check indices *)
+Definition test_indices : nat -> nat := fun x� => x�.
+Definition π₂ := snd.
diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v
new file mode 100644
index 00000000..68869621
--- /dev/null
+++ b/test-suite/success/unification.v
@@ -0,0 +1,65 @@
+(* Test patterns unification *)
+
+Lemma l1 : (forall P, (exists x:nat, P x) -> False) 
+         -> forall P, (exists x:nat, P x /\ P x) -> False.
+Proof.
+intros; apply (H _ H0).
+Qed.
+
+Lemma l2 :  forall A:Set, forall Q:A->Set,
+           (forall (P: forall x:A, Q x -> Prop), 
+                   (exists x:A, exists y:Q x, P x y) -> False) 
+         -> forall (P: forall x:A, Q x -> Prop), 
+                   (exists x:A, exists y:Q x, P x y /\ P x y) -> False.
+Proof.
+intros; apply (H _ H0).
+Qed.
+
+
+(* Example submitted for Zenon *)
+
+Axiom zenon_noteq : forall T : Type, forall t : T, ((t <> t) -> False).
+Axiom zenon_notall : forall T : Type, forall P : T -> Prop,
+  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
+
+  (* Must infer "P := fun x => x=x" in zenon_notall *)
+Check (fun _h1 => (zenon_notall nat _ (fun _T_0 =>
+          (fun _h2 => (zenon_noteq _ _T_0 _h2))) _h1)).
+
+
+(* Core of an example submitted by Ralph Matthes (#849)
+
+   It used to fail because of the K-variable x in the type of "sum_rec ..."
+   which was not in the scope of the evar ?B. Solved by a head
+   beta-reduction of the type "(fun _ : unit + unit => L unit) x" of
+   "sum_rec ...". Shall we used more reduction when solving evars (in
+   real_clean)?? Is there a risk of starting too long reductions?
+
+   Note that the example originally came from a non re-typable
+   pretty-printed term (the checked term is actually re-printed the
+   same form it is checked).  
+*)
+
+Set Implicit Arguments.
+Inductive L (A:Set) : Set := c : A -> L A.
+Parameter f: forall (A:Set)(B:Set), (A->B) -> L A -> L B.
+Parameter t: L (unit + unit).
+
+Check (f (fun x : unit + unit =>
+  sum_rec (fun _ : unit + unit => L unit)
+    (fun y => c y) (fun y => c y) x) t).
+
+
+(* Test patterns unification in apply *)
+
+Require Import Arith.
+Parameter x y : nat.
+Parameter G:x=y->x=y->Prop.
+Parameter K:x<>y->x<>y->Prop.
+Lemma l3 : (forall f:x=y->Prop, forall g:x<>y->Prop,
+            match eq_nat_dec x y with left a => f a | right a => g a end)
+   -> match eq_nat_dec x y with left a => G a a | right a => K a a end.
+Proof.
+intros.
+apply H.
+Qed.
diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v
index a619b8da..87edc4de 100644
--- a/test-suite/success/univers.v
+++ b/test-suite/success/univers.v
@@ -1,40 +1,58 @@
 (* This requires cumulativity *)
 
 Definition Type2 := Type.
-Definition Type1 := Type : Type2.
+Definition Type1 : Type2 := Type.
 
-Lemma lem1 : (True->Type1)->Type2.
-Intro H.
-Apply H.
-Exact I.
+Lemma lem1 : (True -> Type1) -> Type2.
+intro H.
+apply H.
+exact I.
 Qed.
 
-Lemma lem2 : (A:Type)(P:A->Type)(x:A)((y:A)(x==y)->(P y))->(P x).
-Auto.
+Lemma lem2 :
+ forall (A : Type) (P : A -> Type) (x : A),
+ (forall y : A, x = y -> P y) -> P x.
+auto.
 Qed.
 
-Lemma lem3 : (P:Prop)P.
-Intro P ; Pattern P.
-Apply lem2.
+Lemma lem3 : forall P : Prop, P.
+intro P; pattern P in |- *.
+apply lem2.
 Abort.
 
 (* Check managing of universe constraints in inversion *)
 (* Bug report #855 *)
 
-Inductive dep_eq : (X:Type) X -> X -> Prop :=
-   | intro_eq : (X:Type) (f:X)(dep_eq X f f)
-   | intro_feq : (A:Type) (B:A->Type)
-                 let T = (x:A)(B x) in
-                 (f, g:T) (x:A)
-                 (dep_eq (B x) (f x) (g x)) ->
-                 (dep_eq T f g).
+Inductive dep_eq : forall X : Type, X -> X -> Prop :=
+  | intro_eq : forall (X : Type) (f : X), dep_eq X f f
+  | intro_feq :
+      forall (A : Type) (B : A -> Type),
+      let T := forall x : A, B x in
+      forall (f g : T) (x : A), dep_eq (B x) (f x) (g x) -> dep_eq T f g.
                                                                                 
 Require Import Relations.
                                                                                 
-Theorem dep_eq_trans : (X:Type) (transitive X (dep_eq X)).
+Theorem dep_eq_trans : forall X : Type, transitive X (dep_eq X).
 Proof.
-  Unfold transitive.
-  Intros X f g h H1 H2.
-  Inversion H1.
+  unfold transitive in |- *.
+  intros X f g h H1 H2.
+  inversion H1.
 Abort.
 
+
+(* Submitted by Bas Spitters (bug report #935) *)
+
+(* This is a problem with the status of the type in LetIn: is it a
+   user-provided one or an inferred one? At the current time, the
+   kernel type-check the type in LetIn, which means that it must be
+   considered as user-provided when calling the kernel. However, in
+   practice it is inferred so that a universe refresh is needed to set
+   its status as "user-provided".
+
+   Especially, universe refreshing was not done for "set/pose" *)
+
+Lemma ind_unsec : forall Q : nat -> Type, True. 
+intro.
+set (C := forall m, Q m -> Q m).
+exact I.
+Qed.
diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v
index 114a60ee..be065f1d 100755..100644
--- a/theories/Arith/Arith.v
+++ b/theories/Arith/Arith.v
@@ -6,15 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Arith.v,v 1.11.2.2 2004/08/03 17:42:42 herbelin Exp $ i*)
+(*i $Id: Arith.v 9302 2006-10-27 21:21:17Z barras $ i*)
 
-Require Export Le.
-Require Export Lt.
-Require Export Plus.
-Require Export Gt.
-Require Export Minus.
-Require Export Mult.
-Require Export Between.
-Require Export Peano_dec.
-Require Export Compare_dec.
-Require Export Factorial.
+Require Export Arith_base.
+Require Export ArithRing.
diff --git a/theories7/Arith/Arith.v b/theories/Arith/Arith_base.v
index 181fadbc..b076de2a 100755..100644
--- a/theories7/Arith/Arith.v
+++ b/theories/Arith/Arith_base.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Arith.v,v 1.1.2.1 2004/07/16 19:31:23 herbelin Exp $ i*)
+(*i $Id$ i*)
 
 Require Export Le.
 Require Export Lt.
@@ -15,7 +15,6 @@ Require Export Gt.
 Require Export Minus.
 Require Export Mult.
 Require Export Between.
-Require Export Minus.
 Require Export Peano_dec.
 Require Export Compare_dec.
 Require Export Factorial.
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
index 448ce002..2e9472c4 100755..100644
--- a/theories/Arith/Between.v
+++ b/theories/Arith/Between.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Between.v,v 1.12.2.1 2004/07/16 19:30:59 herbelin Exp $ i*)
+(*i $Id: Between.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Le.
 Require Import Lt.
@@ -16,174 +16,174 @@ Open Local Scope nat_scope.
 Implicit Types k l p q r : nat.
 
 Section Between.
-Variables P Q : nat -> Prop.
-
-Inductive between k : nat -> Prop :=
-  | bet_emp : between k k
-  | bet_S : forall l, between k l -> P l -> between k (S l).
-
-Hint Constructors between: arith v62.
-
-Lemma bet_eq : forall k l, l = k -> between k l.
-Proof.
-induction 1; auto with arith.
-Qed.
-
-Hint Resolve bet_eq: arith v62.
-
-Lemma between_le : forall k l, between k l -> k <= l.
-Proof.
-induction 1; auto with arith.
-Qed.
-Hint Immediate between_le: arith v62.
-
-Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l.
-Proof.
-induction 1.
-intros; absurd (S k <= k); auto with arith.
-destruct H; auto with arith.
-Qed.
-Hint Resolve between_Sk_l: arith v62.
-
-Lemma between_restr :
- forall k l (m:nat), k <= l -> l <= m -> between k m -> between l m.
-Proof.
-induction 1; auto with arith.
-Qed.
-
-Inductive exists_between k : nat -> Prop :=
-  | exists_S : forall l, exists_between k l -> exists_between k (S l)
-  | exists_le : forall l, k <= l -> Q l -> exists_between k (S l).
-
-Hint Constructors exists_between: arith v62.
-
-Lemma exists_le_S : forall k l, exists_between k l -> S k <= l.
-Proof.
-induction 1; auto with arith.
-Qed.
-
-Lemma exists_lt : forall k l, exists_between k l -> k < l.
-Proof exists_le_S.
-Hint Immediate exists_le_S exists_lt: arith v62.
-
-Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l.
-Proof.
-intros; apply le_S_n; auto with arith.
-Qed.
-Hint Immediate exists_S_le: arith v62.
-
-Definition in_int p q r := p <= r /\ r < q.
-
-Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r.
-Proof.
-red in |- *; auto with arith.
-Qed.
-Hint Resolve in_int_intro: arith v62.
-
-Lemma in_int_lt : forall p q r, in_int p q r -> p < q.
-Proof.
-induction 1; intros.
-apply le_lt_trans with r; auto with arith.
-Qed.
-
-Lemma in_int_p_Sq :
- forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat.
-Proof.
-induction 1; intros.
-elim (le_lt_or_eq r q); auto with arith.
-Qed.
-
-Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r.
-Proof.
-induction 1; auto with arith.
-Qed.
-Hint Resolve in_int_S: arith v62.
-
-Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r.
-Proof.
-induction 1; auto with arith.
-Qed.
-Hint Immediate in_int_Sp_q: arith v62.
-
-Lemma between_in_int :
- forall k l, between k l -> forall r, in_int k l r -> P r.
-Proof.
-induction 1; intros.
-absurd (k < k); auto with arith.
-apply in_int_lt with r; auto with arith.
-elim (in_int_p_Sq k l r); intros; auto with arith.
-rewrite H2; trivial with arith.
-Qed.
-
-Lemma in_int_between :
- forall k l, k <= l -> (forall r, in_int k l r -> P r) -> between k l.
-Proof.
-induction 1; auto with arith.
-Qed.
-
-Lemma exists_in_int :
- forall k l, exists_between k l ->  exists2 m : nat, in_int k l m & Q m.
-Proof.
-induction 1.
-case IHexists_between; intros p inp Qp; exists p; auto with arith.
-exists l; auto with arith.
-Qed.
-
-Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l.
-Proof.
-destruct 1; intros.
-elim H0; auto with arith.
-Qed.
-
-Lemma between_or_exists :
- forall k l,
-   k <= l ->
-   (forall n:nat, in_int k l n -> P n \/ Q n) ->
-   between k l \/ exists_between k l.
-Proof.
-induction 1; intros; auto with arith.
-elim IHle; intro; auto with arith.
-elim (H0 m); auto with arith.
-Qed.
-
-Lemma between_not_exists :
- forall k l,
-   between k l ->
-   (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l.
-Proof.
-induction 1; red in |- *; intros.
-absurd (k < k); auto with arith.
-absurd (Q l); auto with arith.
-elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'.
-replace l with l'; auto with arith.
-elim inl'; intros.
-elim (le_lt_or_eq l' l); auto with arith; intros.
-absurd (exists_between k l); auto with arith.
-apply in_int_exists with l'; auto with arith.
-Qed.
-
-Inductive P_nth (init:nat) : nat -> nat -> Prop :=
-  | nth_O : P_nth init init 0
-  | nth_S :
+  Variables P Q : nat -> Prop.
+  
+  Inductive between k : nat -> Prop :=
+    | bet_emp : between k k
+    | bet_S : forall l, between k l -> P l -> between k (S l).
+  
+  Hint Constructors between: arith v62.
+
+  Lemma bet_eq : forall k l, l = k -> between k l.
+  Proof.
+    induction 1; auto with arith.
+  Qed.
+
+  Hint Resolve bet_eq: arith v62.
+
+  Lemma between_le : forall k l, between k l -> k <= l.
+  Proof.
+    induction 1; auto with arith.
+  Qed.
+  Hint Immediate between_le: arith v62.
+
+  Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l.
+  Proof.
+    intros k l H; induction H as [|l H].
+    intros; absurd (S k <= k); auto with arith.
+    destruct H; auto with arith.
+  Qed.
+  Hint Resolve between_Sk_l: arith v62.
+
+  Lemma between_restr :
+    forall k l (m:nat), k <= l -> l <= m -> between k m -> between l m.
+  Proof.
+    induction 1; auto with arith.
+  Qed.
+
+  Inductive exists_between k : nat -> Prop :=
+    | exists_S : forall l, exists_between k l -> exists_between k (S l)
+    | exists_le : forall l, k <= l -> Q l -> exists_between k (S l).
+
+  Hint Constructors exists_between: arith v62.
+
+  Lemma exists_le_S : forall k l, exists_between k l -> S k <= l.
+  Proof.
+    induction 1; auto with arith.
+  Qed.
+
+  Lemma exists_lt : forall k l, exists_between k l -> k < l.
+  Proof exists_le_S.
+  Hint Immediate exists_le_S exists_lt: arith v62.
+
+  Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l.
+  Proof.
+    intros; apply le_S_n; auto with arith.
+  Qed.
+  Hint Immediate exists_S_le: arith v62.
+
+  Definition in_int p q r := p <= r /\ r < q.
+
+  Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r.
+  Proof.
+    red in |- *; auto with arith.
+  Qed.
+  Hint Resolve in_int_intro: arith v62.
+
+  Lemma in_int_lt : forall p q r, in_int p q r -> p < q.
+  Proof.
+    induction 1; intros.
+    apply le_lt_trans with r; auto with arith.
+  Qed.
+
+  Lemma in_int_p_Sq :
+    forall p q r, in_int p (S q) r -> in_int p q r \/ r = q :>nat.
+  Proof.
+    induction 1; intros.
+    elim (le_lt_or_eq r q); auto with arith.
+  Qed.
+
+  Lemma in_int_S : forall p q r, in_int p q r -> in_int p (S q) r.
+  Proof.
+    induction 1; auto with arith.
+  Qed.
+  Hint Resolve in_int_S: arith v62.
+
+  Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r.
+  Proof.
+    induction 1; auto with arith.
+  Qed.
+  Hint Immediate in_int_Sp_q: arith v62.
+
+  Lemma between_in_int :
+    forall k l, between k l -> forall r, in_int k l r -> P r.
+  Proof.
+    induction 1; intros.
+    absurd (k < k); auto with arith.
+    apply in_int_lt with r; auto with arith.
+    elim (in_int_p_Sq k l r); intros; auto with arith.
+    rewrite H2; trivial with arith.
+  Qed.
+
+  Lemma in_int_between :
+    forall k l, k <= l -> (forall r, in_int k l r -> P r) -> between k l.
+  Proof.
+    induction 1; auto with arith.
+  Qed.
+
+  Lemma exists_in_int :
+    forall k l, exists_between k l ->  exists2 m : nat, in_int k l m & Q m.
+  Proof.
+    induction 1.
+    case IHexists_between; intros p inp Qp; exists p; auto with arith.
+    exists l; auto with arith.
+  Qed.
+
+  Lemma in_int_exists : forall k l r, in_int k l r -> Q r -> exists_between k l.
+  Proof.
+    destruct 1; intros.
+    elim H0; auto with arith.
+  Qed.
+
+  Lemma between_or_exists :
+    forall k l,
+      k <= l ->
+      (forall n:nat, in_int k l n -> P n \/ Q n) ->
+      between k l \/ exists_between k l.
+  Proof.
+    induction 1; intros; auto with arith.
+    elim IHle; intro; auto with arith.
+    elim (H0 m); auto with arith.
+  Qed.
+
+  Lemma between_not_exists :
+    forall k l,
+      between k l ->
+      (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l.
+  Proof.
+    induction 1; red in |- *; intros.
+    absurd (k < k); auto with arith.
+    absurd (Q l); auto with arith.
+    elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'.
+    replace l with l'; auto with arith.
+    elim inl'; intros.
+    elim (le_lt_or_eq l' l); auto with arith; intros.
+    absurd (exists_between k l); auto with arith.
+    apply in_int_exists with l'; auto with arith.
+  Qed.
+
+  Inductive P_nth (init:nat) : nat -> nat -> Prop :=
+    | nth_O : P_nth init init 0
+    | nth_S :
       forall k l (n:nat),
-        P_nth init k n -> between (S k) l -> Q l -> P_nth init l (S n).
+	P_nth init k n -> between (S k) l -> Q l -> P_nth init l (S n).
 
-Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l.
-Proof.
-induction 1; intros; auto with arith.
-apply le_trans with (S k); auto with arith.
-Qed.
+  Lemma nth_le : forall (init:nat) l (n:nat), P_nth init l n -> init <= l.
+  Proof.
+    induction 1; intros; auto with arith.
+    apply le_trans with (S k); auto with arith.
+  Qed.
 
-Definition eventually (n:nat) :=  exists2 k : nat, k <= n & Q k.
+  Definition eventually (n:nat) :=  exists2 k : nat, k <= n & Q k.
 
-Lemma event_O : eventually 0 -> Q 0.
-Proof.
-induction 1; intros.
-replace 0 with x; auto with arith.
-Qed.
+  Lemma event_O : eventually 0 -> Q 0.
+  Proof.
+    induction 1; intros.
+    replace 0 with x; auto with arith.
+  Qed.
 
 End Between.
 
 Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le
   in_int_S in_int_intro: arith v62. 
-Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62.
\ No newline at end of file
+Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62.
diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v
index 55dfd47f..fed650ab 100644
--- a/theories/Arith/Bool_nat.v
+++ b/theories/Arith/Bool_nat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Bool_nat.v,v 1.5.2.1 2004/07/16 19:30:59 herbelin Exp $ *)
+(* $Id: Bool_nat.v 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 Require Export Compare_dec.
 Require Export Peano_dec.
diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v
index 46827bae..06898658 100755..100644
--- a/theories/Arith/Compare.v
+++ b/theories/Arith/Compare.v
@@ -6,21 +6,17 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Compare.v,v 1.12.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Compare.v 9302 2006-10-27 21:21:17Z barras $ i*)
 
 (** Equality is decidable on [nat] *)
+
 Open Local Scope nat_scope.
 
-(*
-Lemma not_eq_sym : (A:Set)(p,q:A)(~p=q) -> ~(q=p).
-Proof sym_not_eq.
-Hints Immediate not_eq_sym : arith.
-*)
 Notation not_eq_sym := sym_not_eq.
 
 Implicit Types m n p q : nat.
 
-Require Import Arith.
+Require Import Arith_base.
 Require Import Peano_dec.
 Require Import Compare_dec.
 
@@ -41,17 +37,17 @@ Proof le_lt_or_eq.
 
 (* By special request of G. Kahn - Used in Group Theory *)
 Lemma discrete_nat :
- forall n m, n < m -> S n = m \/ (exists r : nat, m = S (S (n + r))).
+  forall n m, n < m -> S n = m \/ (exists r : nat, m = S (S (n + r))).
 Proof.
-intros m n H.
-lapply (lt_le_S m n); auto with arith.
-intro H'; lapply (le_lt_or_eq (S m) n); auto with arith.
-induction 1; auto with arith.
-right; exists (n - S (S m)); simpl in |- *.
-rewrite (plus_comm m (n - S (S m))).
-rewrite (plus_n_Sm (n - S (S m)) m).
-rewrite (plus_n_Sm (n - S (S m)) (S m)).
-rewrite (plus_comm (n - S (S m)) (S (S m))); auto with arith.
+  intros m n H.
+  lapply (lt_le_S m n); auto with arith.
+  intro H'; lapply (le_lt_or_eq (S m) n); auto with arith.
+  induction 1; auto with arith.
+  right; exists (n - S (S m)); simpl in |- *.
+  rewrite (plus_comm m (n - S (S m))).
+  rewrite (plus_n_Sm (n - S (S m)) m).
+  rewrite (plus_n_Sm (n - S (S m)) (S m)).
+  rewrite (plus_comm (n - S (S m)) (S (S m))); auto with arith.
 Qed.
 
 Require Export Wf_nat.
diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v
index ea21437d..e6dc7c46 100755..100644
--- a/theories/Arith/Compare_dec.v
+++ b/theories/Arith/Compare_dec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Compare_dec.v,v 1.13.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Compare_dec.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Le.
 Require Import Lt.
@@ -17,91 +17,231 @@ Open Local Scope nat_scope.
 
 Implicit Types m n x y : nat.
 
-Definition zerop : forall n, {n = 0} + {0 < n}.
-destruct n; auto with arith.
+Definition zerop n : {n = 0} + {0 < n}.
+  destruct n; auto with arith.
 Defined.
 
-Definition lt_eq_lt_dec : forall n m, {n < m} + {n = m} + {m < n}.
-Proof.
-induction n; simple destruct m; auto with arith.
-intros m0; elim (IHn m0); auto with arith.
-induction 1; auto with arith.
+Definition lt_eq_lt_dec n m : {n < m} + {n = m} + {m < n}.
+  induction n; simple destruct m; auto with arith.
+  intros m0; elim (IHn m0); auto with arith.
+  induction 1; auto with arith.
 Defined.
 
-Lemma gt_eq_gt_dec : forall n m, {m > n} + {n = m} + {n > m}.
-Proof lt_eq_lt_dec.
+Definition gt_eq_gt_dec n m : {m > n} + {n = m} + {n > m}.
+  exact lt_eq_lt_dec.
+Defined.
 
-Lemma le_lt_dec : forall n m, {n <= m} + {m < n}.
-Proof.
-induction n.
-auto with arith.
-induction m.
-auto with arith.
-elim (IHn m); auto with arith.
+Definition le_lt_dec n m : {n <= m} + {m < n}.
+  induction n.
+  auto with arith.
+  induction m.
+  auto with arith.
+  elim (IHn m); auto with arith.
 Defined.
 
-Definition le_le_S_dec : forall n m, {n <= m} + {S m <= n}.
-Proof.
-exact le_lt_dec.
+Definition le_le_S_dec n m : {n <= m} + {S m <= n}.
+  exact le_lt_dec.
 Defined.
 
-Definition le_ge_dec : forall n m, {n <= m} + {n >= m}.
-Proof.
-intros; elim (le_lt_dec n m); auto with arith.
+Definition le_ge_dec n m : {n <= m} + {n >= m}.
+  intros; elim (le_lt_dec n m); auto with arith.
 Defined.
 
-Definition le_gt_dec : forall n m, {n <= m} + {n > m}.
-Proof.
-exact le_lt_dec.
+Definition le_gt_dec n m : {n <= m} + {n > m}.
+  exact le_lt_dec.
 Defined.
 
-Definition le_lt_eq_dec : forall n m, n <= m -> {n < m} + {n = m}.
-Proof.
-intros; elim (lt_eq_lt_dec n m); auto with arith.
-intros; absurd (m < n); auto with arith.
+Definition le_lt_eq_dec n m : n <= m -> {n < m} + {n = m}.
+  intros; elim (lt_eq_lt_dec n m); auto with arith.
+  intros; absurd (m < n); auto with arith.
 Defined.
 
 (** Proofs of decidability *)
 
 Theorem dec_le : forall n m, decidable (n <= m).
-intros x y; unfold decidable in |- *; elim (le_gt_dec x y);
- [ auto with arith | intro; right; apply gt_not_le; assumption ].
+Proof.
+  intros x y; unfold decidable in |- *; elim (le_gt_dec x y);
+    [ auto with arith | intro; right; apply gt_not_le; assumption ].
 Qed.
 
 Theorem dec_lt : forall n m, decidable (n < m).
-intros x y; unfold lt in |- *; apply dec_le.
+Proof.
+  intros x y; unfold lt in |- *; apply dec_le.
 Qed.
 
 Theorem dec_gt : forall n m, decidable (n > m).
-intros x y; unfold gt in |- *; apply dec_lt.
+Proof.
+  intros x y; unfold gt in |- *; apply dec_lt.
 Qed.
 
 Theorem dec_ge : forall n m, decidable (n >= m).
-intros x y; unfold ge in |- *; apply dec_le.
+Proof.
+  intros x y; unfold ge in |- *; apply dec_le.
 Qed.
 
 Theorem not_eq : forall n m, n <> m -> n < m \/ m < n.
-intros x y H; elim (lt_eq_lt_dec x y);
- [ intros H1; elim H1;
-    [ auto with arith | intros H2; absurd (x = y); assumption ]
- | auto with arith ].
+Proof.
+  intros x y H; elim (lt_eq_lt_dec x y);
+    [ intros H1; elim H1;
+      [ auto with arith | intros H2; absurd (x = y); assumption ]
+      | auto with arith ].
 Qed.
 
 
 Theorem not_le : forall n m, ~ n <= m -> n > m.
-intros x y H; elim (le_gt_dec x y);
- [ intros H1; absurd (x <= y); assumption | trivial with arith ].
+Proof.
+  intros x y H; elim (le_gt_dec x y);
+    [ intros H1; absurd (x <= y); assumption | trivial with arith ].
 Qed.
 
 Theorem not_gt : forall n m, ~ n > m -> n <= m.
-intros x y H; elim (le_gt_dec x y);
- [ trivial with arith | intros H1; absurd (x > y); assumption ].
+Proof.
+  intros x y H; elim (le_gt_dec x y);
+    [ trivial with arith | intros H1; absurd (x > y); assumption ].
 Qed.
 
 Theorem not_ge : forall n m, ~ n >= m -> n < m.
-intros x y H; exact (not_le y x H).
+Proof.
+  intros x y H; exact (not_le y x H).
 Qed.
 
 Theorem not_lt : forall n m, ~ n < m -> n >= m.
-intros x y H; exact (not_gt y x H). 
+Proof.
+  intros x y H; exact (not_gt y x H). 
+Qed.
+
+
+(** A ternary comparison function in the spirit of [Zcompare]. *)
+
+Definition nat_compare (n m:nat) :=
+  match lt_eq_lt_dec n m with 
+    | inleft (left _) => Lt
+    | inleft (right _) => Eq
+    | inright _ => Gt
+  end.
+
+Lemma nat_compare_S : forall n m, nat_compare (S n) (S m) = nat_compare n m.
+Proof.
+  unfold nat_compare; intros.
+  simpl; destruct (lt_eq_lt_dec n m) as [[H|H]|H]; simpl; auto.
+Qed.
+
+Lemma nat_compare_eq : forall n m, nat_compare n m = Eq -> n = m.
+Proof.
+  induction n; destruct m; simpl; auto.
+  unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
+    auto; intros; try discriminate.
+  unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
+    auto; intros; try discriminate.
+  rewrite nat_compare_S; auto.
+Qed.
+
+Lemma nat_compare_lt : forall n m, n<m <-> nat_compare n m = Lt.
+Proof.
+  induction n; destruct m; simpl.
+  unfold nat_compare; simpl; intuition; [inversion H | discriminate H].
+  split; auto with arith.
+  split; [inversion 1 |].
+  unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
+    auto; intros; try discriminate.
+  rewrite nat_compare_S.
+  generalize (IHn m); clear IHn; intuition.
+Qed.
+
+Lemma nat_compare_gt : forall n m, n>m <-> nat_compare n m = Gt.
+Proof.
+  induction n; destruct m; simpl.
+  unfold nat_compare; simpl; intuition; [inversion H | discriminate H].
+  split; [inversion 1 |].
+  unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
+    auto; intros; try discriminate.
+  split; auto with arith.
+  rewrite nat_compare_S.
+  generalize (IHn m); clear IHn; intuition.
+Qed.
+
+Lemma nat_compare_le : forall n m, n<=m <-> nat_compare n m <> Gt.
+Proof.
+  split.
+  intros.
+  intro.
+  destruct (nat_compare_gt n m).
+  generalize (le_lt_trans _ _ _ H (H2 H0)).
+  exact (lt_irrefl n).
+  intros.
+  apply not_gt.
+  swap H.
+  destruct (nat_compare_gt n m); auto.
+Qed.  
+
+Lemma nat_compare_ge : forall n m, n>=m <-> nat_compare n m <> Lt.
+Proof.
+  split.
+  intros.
+  intro.
+  destruct (nat_compare_lt n m).
+  generalize (le_lt_trans _ _ _ H (H2 H0)).
+  exact (lt_irrefl m).
+  intros.
+  apply not_lt.
+  swap H.
+  destruct (nat_compare_lt n m); auto.
+Qed.  
+
+(** A boolean version of [le] over [nat]. *)
+
+Fixpoint leb (m:nat) : nat -> bool :=
+  match m with
+    | O => fun _:nat => true
+    | S m' =>
+      fun n:nat => match n with
+                     | O => false
+                     | S n' => leb m' n'
+                   end
+  end.
+
+Lemma leb_correct : forall m n:nat, m <= n -> leb m n = true.
+Proof.
+  induction m as [| m IHm]. trivial.
+  destruct n. intro H. elim (le_Sn_O _ H).
+  intros. simpl in |- *. apply IHm. apply le_S_n. assumption.
 Qed.
+
+Lemma leb_complete : forall m n:nat, leb m n = true -> m <= n.
+Proof.
+  induction m. trivial with arith.
+  destruct n. intro H. discriminate H.
+  auto with arith.
+Qed.
+
+Lemma leb_correct_conv : forall m n:nat, m < n -> leb n m = false.
+Proof.
+  intros. 
+  generalize (leb_complete n m).
+  destruct (leb n m); auto.
+  intros.
+  elim (lt_irrefl _ (lt_le_trans _ _ _ H (H0 (refl_equal true)))).
+Qed.
+
+Lemma leb_complete_conv : forall m n:nat, leb n m = false -> m < n.
+Proof.
+  intros. elim (le_or_lt n m). intro. conditional trivial rewrite leb_correct in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma leb_compare : forall n m, leb n m = true <-> nat_compare n m <> Gt.
+Proof.
+ induction n; destruct m; simpl.
+ unfold nat_compare; simpl.
+ intuition; discriminate.
+ split; auto with arith.
+ unfold nat_compare; destruct (lt_eq_lt_dec 0 (S m)) as [[H|H]|H]; 
+  intuition; try discriminate.
+ inversion H.
+ split; try (intros; discriminate).
+ unfold nat_compare; destruct (lt_eq_lt_dec (S n) 0) as [[H|H]|H]; 
+  intuition; try discriminate.
+ inversion H.
+ rewrite nat_compare_S; auto.
+Qed. 
+
diff --git a/theories/Arith/Div.v b/theories/Arith/Div.v
index adb5593d..1dec34e2 100755..100644
--- a/theories/Arith/Div.v
+++ b/theories/Arith/Div.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Div.v,v 1.8.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Div.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Euclidean division *)
 
@@ -20,45 +20,45 @@ Require Compare_dec.
 Implicit Variables Type n,a,b,q,r:nat.
 
 Fixpoint inf_dec [n:nat] : nat->bool :=
-      [m:nat] Cases n m of
-                  O     _     => true
-              | (S n')  O     => false
-              | (S n') (S m') => (inf_dec n' m')
-             end.
+  [m:nat] Cases n m of
+            O     _     => true
+            | (S n')  O     => false
+            | (S n') (S m') => (inf_dec n' m')
+          end.
 
 Theorem div1 : (b:nat)(gt b O)->(a:nat)(diveucl a b).
-Realizer Fix div1 {div1/2: nat->nat->diveucl :=
-  [b,a]Cases a of
-         O     => (O,O)
-       | (S n) =>
-           let (q,r) = (div1 b n) in
-             if (le_gt_dec b (S r)) then ((S q),O)
-	     else (q,(S r))
-       end}.
-Program_all.
-Rewrite e.
-Replace b with (S r).
-Simpl.
-Elim plus_n_O; Auto with arith.
-Apply le_antisym; Auto with arith.
-Elim plus_n_Sm; Auto with arith.
+  Realizer Fix div1 {div1/2: nat->nat->diveucl :=
+    [b,a]Cases a of
+           O     => (O,O)
+	   | (S n) =>
+             let (q,r) = (div1 b n) in
+               if (le_gt_dec b (S r)) then ((S q),O)
+		 else (q,(S r))
+	 end}.
+  Program_all.
+  Rewrite e.
+  Replace b with (S r).
+  Simpl.
+  Elim plus_n_O; Auto with arith.
+  Apply le_antisym; Auto with arith.
+  Elim plus_n_Sm; Auto with arith.
 Qed.
 
 Theorem div2 : (b:nat)(gt b O)->(a:nat)(diveucl a b).
-Realizer Fix div1 {div1/2: nat->nat->diveucl :=
-  [b,a]Cases a of
-         O     => (O,O)
-       | (S n) =>
-           let (q,r) = (div1 b n) in
-             if (inf_dec b (S r)) :: :: { {(le b (S r))}+{(gt b (S r))} }
-             then ((S q),O)
-	     else (q,(S r))
-       end}.
-Program_all.
-Rewrite e.
-Replace b with (S r).
-Simpl.
-Elim plus_n_O; Auto with arith.
-Apply le_antisym; Auto with arith.
-Elim plus_n_Sm; Auto with arith.
+  Realizer Fix div1 {div1/2: nat->nat->diveucl :=
+    [b,a]Cases a of
+           O     => (O,O)
+	   | (S n) =>
+             let (q,r) = (div1 b n) in
+               if (inf_dec b (S r)) :: :: { {(le b (S r))}+{(gt b (S r))} }
+		 then ((S q),O)
+		 else (q,(S r))
+	 end}.
+  Program_all.
+  Rewrite e.
+  Replace b with (S r).
+  Simpl.
+  Elim plus_n_O; Auto with arith.
+  Apply le_antisym; Auto with arith.
+  Elim plus_n_Sm; Auto with arith.
 Qed.
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v
index c005f061..c32759b2 100644
--- a/theories/Arith/Div2.v
+++ b/theories/Arith/Div2.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Div2.v,v 1.15.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Div2.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Lt.
 Require Import Plus.
@@ -30,28 +30,30 @@ Fixpoint div2 n : nat :=
     useful to prove the corresponding induction principle *)
 
 Lemma ind_0_1_SS :
- forall P:nat -> Prop,
-   P 0 -> P 1 -> (forall n, P n -> P (S (S n))) -> forall n, P n.
+  forall P:nat -> Prop,
+    P 0 -> P 1 -> (forall n, P n -> P (S (S n))) -> forall n, P n.
 Proof.
-intros.
-cut (forall n, P n /\ P (S n)).
-intros. elim (H2 n). auto with arith.
-
-induction n0. auto with arith.
-intros. elim IHn0; auto with arith.
+  intros P H0 H1 Hn.
+  cut (forall n, P n /\ P (S n)).
+  intros H'n n. elim (H'n n). auto with arith.
+  
+  induction n. auto with arith.
+  intros. elim IHn; auto with arith.
 Qed.
 
 (** [0 <n  =>  n/2 < n] *)
 
 Lemma lt_div2 : forall n, 0 < n -> div2 n < n.
 Proof.
-intro n. pattern n in |- *. apply ind_0_1_SS.
-intro. inversion H.
-auto with arith.
-intros. simpl in |- *.
-case (zerop n0).
-intro. rewrite e. auto with arith.
-auto with arith.
+  intro n. pattern n in |- *. apply ind_0_1_SS.
+  (* n = 0 *)
+  inversion 1.
+  (* n=1 *)
+  simpl; trivial.
+  (* n=S S n' *)
+  intro n'; case (zerop n').
+    intro n'_eq_0. rewrite n'_eq_0. auto with arith.
+    auto with arith.
 Qed.
 
 Hint Resolve lt_div2: arith.
@@ -59,27 +61,27 @@ Hint Resolve lt_div2: arith.
 (** Properties related to the parity *)
 
 Lemma even_odd_div2 :
- forall n,
-   (even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)).
+  forall n,
+    (even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)).
 Proof.
-intro n. pattern n in |- *. apply ind_0_1_SS.
-(* n  = 0 *)
-split. split; auto with arith. 
-split. intro H. inversion H.
-intro H.  absurd (S (div2 0) = div2 1); auto with arith.
-(* n = 1 *)
-split. split. intro. inversion H. inversion H1.
-intro H.  absurd (div2 1 = div2 2).
-simpl in |- *. discriminate. assumption.
-split; auto with arith.
-(* n = (S (S n')) *)
-intros. decompose [and] H. unfold iff in H0, H1.
-decompose [and] H0. decompose [and] H1. clear H H0 H1.
-split; split; auto with arith.
-intro H. inversion H. inversion H1.
-change (S (div2 n0) = S (div2 (S n0))) in |- *. auto with arith.
-intro H. inversion H. inversion H1.
-change (S (S (div2 n0)) = S (div2 (S n0))) in |- *. auto with arith.
+  intro n. pattern n in |- *. apply ind_0_1_SS.
+  (* n  = 0 *)
+  split. split; auto with arith. 
+  split. intro H. inversion H.
+  intro H.  absurd (S (div2 0) = div2 1); auto with arith.
+  (* n = 1 *)
+  split. split. intro. inversion H. inversion H1.
+  intro H.  absurd (div2 1 = div2 2).
+  simpl in |- *. discriminate. assumption.
+  split; auto with arith.
+  (* n = (S (S n')) *)
+  intros. decompose [and] H. unfold iff in H0, H1.
+  decompose [and] H0. decompose [and] H1. clear H H0 H1.
+  split; split; auto with arith.
+  intro H. inversion H. inversion H1.
+  change (S (div2 n0) = S (div2 (S n0))) in |- *. auto with arith.
+  intro H. inversion H. inversion H1.
+  change (S (S (div2 n0)) = S (div2 (S n0))) in |- *. auto with arith.
 Qed.
 
 (** Specializations *)
@@ -106,39 +108,39 @@ Hint Unfold double: arith.
 
 Lemma double_S : forall n, double (S n) = S (S (double n)).
 Proof.
-intro. unfold double in |- *. simpl in |- *. auto with arith.
+  intro. unfold double in |- *. simpl in |- *. auto with arith.
 Qed.
 
 Lemma double_plus : forall n (m:nat), double (n + m) = double n + double m.
 Proof.
-intros m n. unfold double in |- *.
-do 2 rewrite plus_assoc_reverse. rewrite (plus_permute n).
-reflexivity.
+  intros m n. unfold double in |- *.
+  do 2 rewrite plus_assoc_reverse. rewrite (plus_permute n).
+  reflexivity.
 Qed.
 
 Hint Resolve double_S: arith.
 
 Lemma even_odd_double :
- forall n,
-   (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))).
+  forall n,
+    (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))).
 Proof.
-intro n. pattern n in |- *. apply ind_0_1_SS.
-(* n = 0 *)
-split; split; auto with arith.
-intro H. inversion H.
-(* n = 1 *)
-split; split; auto with arith.
-intro H. inversion H. inversion H1.
-(* n = (S (S n')) *)
-intros. decompose [and] H. unfold iff in H0, H1.
-decompose [and] H0. decompose [and] H1. clear H H0 H1.
-split; split.
-intro H. inversion H. inversion H1.
-simpl in |- *. rewrite (double_S (div2 n0)). auto with arith.
-simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
-intro H. inversion H. inversion H1.
-simpl in |- *. rewrite (double_S (div2 n0)). auto with arith.
-simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
+  intro n. pattern n in |- *. apply ind_0_1_SS.
+  (* n = 0 *)
+  split; split; auto with arith.
+  intro H. inversion H.
+  (* n = 1 *)
+  split; split; auto with arith.
+  intro H. inversion H. inversion H1.
+  (* n = (S (S n')) *)
+  intros. decompose [and] H. unfold iff in H0, H1.
+  decompose [and] H0. decompose [and] H1. clear H H0 H1.
+  split; split.
+  intro H. inversion H. inversion H1.
+  simpl in |- *. rewrite (double_S (div2 n0)). auto with arith.
+  simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
+  intro H. inversion H. inversion H1.
+  simpl in |- *. rewrite (double_S (div2 n0)). auto with arith.
+  simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
 Qed.
 
 
@@ -166,10 +168,32 @@ Hint Resolve even_double double_even odd_double double_odd: arith.
 
 Lemma even_2n : forall n, even n -> {p : nat | n = double p}.
 Proof.
-intros n H. exists (div2 n). auto with arith.
+  intros n H. exists (div2 n). auto with arith.
 Qed.
 
 Lemma odd_S2n : forall n, odd n -> {p : nat | n = S (double p)}.
 Proof.
-intros n H. exists (div2 n). auto with arith.
+  intros n H. exists (div2 n). auto with arith.
+Qed.
+
+(** Doubling before dividing by two brings back to the initial number. *)
+
+Lemma div2_double : forall n:nat, div2 (2*n) = n.
+Proof.
+  induction n.
+  simpl; auto.
+  simpl.
+  replace (n+S(n+0)) with (S (2*n)).
+  f_equal; auto.
+  simpl; auto with arith.
+Qed.
+
+Lemma div2_double_plus_one : forall n:nat, div2 (S (2*n)) = n.
+Proof.
+  induction n.
+  simpl; auto.
+  simpl.
+  replace (n+S(n+0)) with (S (2*n)).
+  f_equal; auto.
+  simpl; auto with arith.
 Qed.
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
index 2e99e068..82d05e2c 100755..100644
--- a/theories/Arith/EqNat.v
+++ b/theories/Arith/EqNat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: EqNat.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: EqNat.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Equality on natural numbers *)
 
@@ -14,52 +14,66 @@ Open Local Scope nat_scope.
 
 Implicit Types m n x y : nat.
 
+(** * Propositional equality  *)
+
 Fixpoint eq_nat n m {struct n} : Prop :=
   match n, m with
-  | O, O => True
-  | O, S _ => False
-  | S _, O => False
-  | S n1, S m1 => eq_nat n1 m1
+    | O, O => True
+    | O, S _ => False
+    | S _, O => False
+    | S n1, S m1 => eq_nat n1 m1
   end.
 
 Theorem eq_nat_refl : forall n, eq_nat n n.
-induction n; simpl in |- *; auto.
+  induction n; simpl in |- *; auto.
 Qed.
 Hint Resolve eq_nat_refl: arith v62.
 
-Theorem eq_eq_nat : forall n m, n = m -> eq_nat n m.
-induction 1; trivial with arith.
+(** [eq] restricted to [nat] and [eq_nat] are equivalent *)
+
+Lemma eq_eq_nat : forall n m, n = m -> eq_nat n m.
+  induction 1; trivial with arith.
 Qed.
 Hint Immediate eq_eq_nat: arith v62.
 
-Theorem eq_nat_eq : forall n m, eq_nat n m -> n = m.
-induction n; induction m; simpl in |- *; contradiction || auto with arith.
+Lemma eq_nat_eq : forall n m, eq_nat n m -> n = m.
+  induction n; induction m; simpl in |- *; contradiction || auto with arith.
 Qed.
 Hint Immediate eq_nat_eq: arith v62.
 
+Theorem eq_nat_is_eq : forall n m, eq_nat n m <-> n = m.
+Proof.
+  split; auto with arith.
+Qed.
+
 Theorem eq_nat_elim :
- forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m.
-intros; replace m with n; auto with arith.
+  forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m.
+Proof.
+  intros; replace m with n; auto with arith.
 Qed.
 
 Theorem eq_nat_decide : forall n m, {eq_nat n m} + {~ eq_nat n m}.
-induction n.
-destruct m as [| n].
-auto with arith.
-intros; right; red in |- *; trivial with arith.
-destruct m as [| n0].
-right; red in |- *; auto with arith.
-intros.
-simpl in |- *.
-apply IHn.
+Proof.
+  induction n.
+  destruct m as [| n].
+  auto with arith.
+  intros; right; red in |- *; trivial with arith.
+  destruct m as [| n0].
+  right; red in |- *; auto with arith.
+  intros.
+  simpl in |- *.
+  apply IHn.
 Defined.
 
+
+(** * Boolean equality on [nat] *)
+
 Fixpoint beq_nat n m {struct n} : bool :=
   match n, m with
-  | O, O => true
-  | O, S _ => false
-  | S _, O => false
-  | S n1, S m1 => beq_nat n1 m1
+    | O, O => true
+    | O, S _ => false
+    | S _, O => false
+    | S n1, S m1 => beq_nat n1 m1
   end.
 
 Lemma beq_nat_refl : forall n, true = beq_nat n n.
@@ -71,7 +85,7 @@ Definition beq_nat_eq : forall x y, true = beq_nat x y -> x = y.
 Proof.
   double induction x y; simpl in |- *.
     reflexivity.
-    intros; discriminate H0.
-    intros; discriminate H0.
-    intros; case (H0 _ H1); reflexivity.
+    intros n H1 H2. discriminate H2.
+    intros n H1 H2. discriminate H2.
+    intros n H1 z H2 H3. case (H2 _ H3). reflexivity.
 Defined.
diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v
index e50e3d70..3d6f1af5 100644
--- a/theories/Arith/Euclid.v
+++ b/theories/Arith/Euclid.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Euclid.v,v 1.7.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Euclid.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Mult.
 Require Import Compare_dec.
@@ -17,52 +17,55 @@ Open Local Scope nat_scope.
 Implicit Types a b n q r : nat.
 
 Inductive diveucl a b : Set :=
-    divex : forall q r, b > r -> a = q * b + r -> diveucl a b.
+  divex : forall q r, b > r -> a = q * b + r -> diveucl a b.
 
 
 Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n.
-intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
-elim (le_gt_dec b n).
-intro lebn.
-elim (H0 (n - b)); auto with arith.
-intros q r g e.
-apply divex with (S q) r; simpl in |- *; auto with arith.
-elim plus_assoc.
-elim e; auto with arith.
-intros gtbn.
-apply divex with 0 n; simpl in |- *; auto with arith.
+Proof.
+  intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
+  elim (le_gt_dec b n).
+  intro lebn.
+  elim (H0 (n - b)); auto with arith.
+  intros q r g e.
+  apply divex with (S q) r; simpl in |- *; auto with arith.
+  elim plus_assoc.
+  elim e; auto with arith.
+  intros gtbn.
+  apply divex with 0 n; simpl in |- *; auto with arith.
 Qed.
 
 Lemma quotient :
- forall n,
-   n > 0 ->
-   forall m:nat, {q : nat |  exists r : nat, m = q * n + r /\ n > r}.
-intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
-elim (le_gt_dec b n).
-intro lebn.
-elim (H0 (n - b)); auto with arith.
-intros q Hq; exists (S q).
-elim Hq; intros r Hr.
-exists r; simpl in |- *; elim Hr; intros.
-elim plus_assoc.
-elim H1; auto with arith.
-intros gtbn.
-exists 0; exists n; simpl in |- *; auto with arith.
+  forall n,
+    n > 0 ->
+    forall m:nat, {q : nat |  exists r : nat, m = q * n + r /\ n > r}.
+Proof.
+  intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
+  elim (le_gt_dec b n).
+  intro lebn.
+  elim (H0 (n - b)); auto with arith.
+  intros q Hq; exists (S q).
+  elim Hq; intros r Hr.
+  exists r; simpl in |- *; elim Hr; intros.
+  elim plus_assoc.
+  elim H1; auto with arith.
+  intros gtbn.
+  exists 0; exists n; simpl in |- *; auto with arith.
 Qed.
 
 Lemma modulo :
- forall n,
-   n > 0 ->
-   forall m:nat, {r : nat |  exists q : nat, m = q * n + r /\ n > r}.
-intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
-elim (le_gt_dec b n).
-intro lebn.
-elim (H0 (n - b)); auto with arith.
-intros r Hr; exists r.
-elim Hr; intros q Hq.
-elim Hq; intros; exists (S q); simpl in |- *.
-elim plus_assoc.
-elim H1; auto with arith.
-intros gtbn.
-exists n; exists 0; simpl in |- *; auto with arith.
-Qed.
\ No newline at end of file
+  forall n,
+    n > 0 ->
+    forall m:nat, {r : nat |  exists q : nat, m = q * n + r /\ n > r}.
+Proof.
+  intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
+  elim (le_gt_dec b n).
+  intro lebn.
+  elim (H0 (n - b)); auto with arith.
+  intros r Hr; exists r.
+  elim Hr; intros q Hq.
+  elim Hq; intros; exists (S q); simpl in |- *.
+  elim plus_assoc.
+  elim H1; auto with arith.
+  intros gtbn.
+  exists n; exists 0; simpl in |- *; auto with arith.
+Qed.
diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v
index f7a2ad71..83c0ce17 100644
--- a/theories/Arith/Even.v
+++ b/theories/Arith/Even.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Even.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Even.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Here we define the predicates [even] and [odd] by mutual induction
     and we prove the decidability and the exclusion of those predicates.
@@ -16,6 +16,9 @@ Open Local Scope nat_scope.
 
 Implicit Types m n : nat.
 
+
+(** * Definition of [even] and [odd], and basic facts *) 
+
 Inductive even : nat -> Prop :=
   | even_O : even 0
   | even_S : forall n, odd n -> even (S n)
@@ -27,279 +30,285 @@ Hint Constructors odd: arith.
 
 Lemma even_or_odd : forall n, even n \/ odd n.
 Proof.
-induction n.
-auto with arith.
-elim IHn; auto with arith.
+  induction n.
+    auto with arith.
+    elim IHn; auto with arith.
 Qed.
 
 Lemma even_odd_dec : forall n, {even n} + {odd n}.
 Proof.
-induction n.
-auto with arith.
-elim IHn; auto with arith.
+  induction n.
+    auto with arith.
+    elim IHn; auto with arith.
 Qed.
 
 Lemma not_even_and_odd : forall n, even n -> odd n -> False.
 Proof.
-induction n.
-intros. inversion H0.
-intros. inversion H. inversion H0. auto with arith.
+  induction n.
+    intros even_0 odd_0. inversion odd_0.
+    intros even_Sn odd_Sn. inversion even_Sn. inversion odd_Sn. auto with arith.
 Qed.
 
+
+(** * Facts about [even] & [odd] wrt. [plus] *)
+
 Lemma even_plus_aux :
- forall n m,
-   (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\
-   (even (n + m) <-> even n /\ even m \/ odd n /\ odd m).
+  forall n m,
+    (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\
+    (even (n + m) <-> even n /\ even m \/ odd n /\ odd m).
 Proof.
-intros n; elim n; simpl in |- *; auto with arith.
-intros m; split; auto.
-split.
-intros H; right; split; auto with arith.
-intros H'; case H'; auto with arith.
-intros H'0; elim H'0; intros H'1 H'2; inversion H'1.
-intros H; elim H; auto.
-split; auto with arith.
-intros H'; elim H'; auto with arith.
-intros H; elim H; auto.
-intros H'0; elim H'0; intros H'1 H'2; inversion H'1.
-intros n0 H' m; elim (H' m); intros H'1 H'2; elim H'1; intros E1 E2; elim H'2;
- intros E3 E4; clear H'1 H'2.
-split; split.
-intros H'0; case E3.
-inversion H'0; auto.
-intros H; elim H; intros H0 H1; clear H; auto with arith.
-intros H; elim H; intros H0 H1; clear H; auto with arith.
-intros H'0; case H'0; intros C0; case C0; intros C1 C2.
-apply odd_S.
-apply E4; left; split; auto with arith.
-inversion C1; auto.
-apply odd_S.
-apply E4; right; split; auto with arith.
-inversion C1; auto.
-intros H'0.
-case E1.
-inversion H'0; auto.
-intros H; elim H; intros H0 H1; clear H; auto with arith.
-intros H; elim H; intros H0 H1; clear H; auto with arith.
-intros H'0; case H'0; intros C0; case C0; intros C1 C2.
-apply even_S.
-apply E2; left; split; auto with arith.
-inversion C1; auto.
-apply even_S.
-apply E2; right; split; auto with arith.
-inversion C1; auto.
+  intros n; elim n; simpl in |- *; auto with arith.
+  intros m; split; auto.
+  split.
+  intros H; right; split; auto with arith.
+  intros H'; case H'; auto with arith.
+  intros H'0; elim H'0; intros H'1 H'2; inversion H'1.
+  intros H; elim H; auto.
+  split; auto with arith.
+  intros H'; elim H'; auto with arith.
+  intros H; elim H; auto.
+  intros H'0; elim H'0; intros H'1 H'2; inversion H'1.
+  intros n0 H' m; elim (H' m); intros H'1 H'2; elim H'1; intros E1 E2; elim H'2;
+    intros E3 E4; clear H'1 H'2.
+  split; split.
+  intros H'0; case E3.
+  inversion H'0; auto.
+  intros H; elim H; intros H0 H1; clear H; auto with arith.
+  intros H; elim H; intros H0 H1; clear H; auto with arith.
+  intros H'0; case H'0; intros C0; case C0; intros C1 C2.
+  apply odd_S.
+  apply E4; left; split; auto with arith.
+  inversion C1; auto.
+  apply odd_S.
+  apply E4; right; split; auto with arith.
+  inversion C1; auto.
+  intros H'0.
+  case E1.
+  inversion H'0; auto.
+  intros H; elim H; intros H0 H1; clear H; auto with arith.
+  intros H; elim H; intros H0 H1; clear H; auto with arith.
+  intros H'0; case H'0; intros C0; case C0; intros C1 C2.
+  apply even_S.
+  apply E2; left; split; auto with arith.
+  inversion C1; auto.
+  apply even_S.
+  apply E2; right; split; auto with arith.
+  inversion C1; auto.
 Qed.
  
 Lemma even_even_plus : forall n m, even n -> even m -> even (n + m).
 Proof.
-intros n m; case (even_plus_aux n m).
-intros H H0; case H0; auto.
+  intros n m; case (even_plus_aux n m).
+  intros H H0; case H0; auto.
 Qed.
  
 Lemma odd_even_plus : forall n m, odd n -> odd m -> even (n + m).
 Proof.
-intros n m; case (even_plus_aux n m).
-intros H H0; case H0; auto.
+  intros n m; case (even_plus_aux n m).
+  intros H H0; case H0; auto.
 Qed.
- 
+
 Lemma even_plus_even_inv_r : forall n m, even (n + m) -> even n -> even m.
 Proof.
-intros n m H; case (even_plus_aux n m).
-intros H' H'0; elim H'0.
-intros H'1; case H'1; auto.
-intros H0; elim H0; auto.
-intros H0 H1 H2; case (not_even_and_odd n); auto.
-case H0; auto.
+  intros n m H; case (even_plus_aux n m).
+  intros H' H'0; elim H'0.
+  intros H'1; case H'1; auto.
+  intros H0; elim H0; auto.
+  intros H0 H1 H2; case (not_even_and_odd n); auto.
+  case H0; auto.
 Qed.
  
 Lemma even_plus_even_inv_l : forall n m, even (n + m) -> even m -> even n.
 Proof.
-intros n m H; case (even_plus_aux n m).
-intros H' H'0; elim H'0.
-intros H'1; case H'1; auto.
-intros H0; elim H0; auto.
-intros H0 H1 H2; case (not_even_and_odd m); auto.
-case H0; auto.
+  intros n m H; case (even_plus_aux n m).
+  intros H' H'0; elim H'0.
+  intros H'1; case H'1; auto.
+  intros H0; elim H0; auto.
+  intros H0 H1 H2; case (not_even_and_odd m); auto.
+  case H0; auto.
 Qed.
- 
+
 Lemma even_plus_odd_inv_r : forall n m, even (n + m) -> odd n -> odd m.
 Proof.
-intros n m H; case (even_plus_aux n m).
-intros H' H'0; elim H'0.
-intros H'1; case H'1; auto.
-intros H0 H1 H2; case (not_even_and_odd n); auto.
-case H0; auto.
-intros H0; case H0; auto.
+  intros n m H; case (even_plus_aux n m).
+  intros H' H'0; elim H'0.
+  intros H'1; case H'1; auto.
+  intros H0 H1 H2; case (not_even_and_odd n); auto.
+  case H0; auto.
+  intros H0; case H0; auto.
 Qed.
- 
+
 Lemma even_plus_odd_inv_l : forall n m, even (n + m) -> odd m -> odd n.
 Proof.
-intros n m H; case (even_plus_aux n m).
-intros H' H'0; elim H'0.
-intros H'1; case H'1; auto.
-intros H0 H1 H2; case (not_even_and_odd m); auto.
-case H0; auto.
-intros H0; case H0; auto.
+  intros n m H; case (even_plus_aux n m).
+  intros H' H'0; elim H'0.
+  intros H'1; case H'1; auto.
+  intros H0 H1 H2; case (not_even_and_odd m); auto.
+  case H0; auto.
+  intros H0; case H0; auto.
 Qed.
 Hint Resolve even_even_plus odd_even_plus: arith.
- 
+
 Lemma odd_plus_l : forall n m, odd n -> even m -> odd (n + m).
 Proof.
-intros n m; case (even_plus_aux n m).
-intros H; case H; auto.
+  intros n m; case (even_plus_aux n m).
+  intros H; case H; auto.
 Qed.
  
 Lemma odd_plus_r : forall n m, even n -> odd m -> odd (n + m).
 Proof.
-intros n m; case (even_plus_aux n m).
-intros H; case H; auto.
+  intros n m; case (even_plus_aux n m).
+  intros H; case H; auto.
 Qed.
  
 Lemma odd_plus_even_inv_l : forall n m, odd (n + m) -> odd m -> even n.
 Proof.
-intros n m H; case (even_plus_aux n m).
-intros H' H'0; elim H'.
-intros H'1; case H'1; auto.
-intros H0 H1 H2; case (not_even_and_odd m); auto.
-case H0; auto.
-intros H0; case H0; auto.
+  intros n m H; case (even_plus_aux n m).
+  intros H' H'0; elim H'.
+  intros H'1; case H'1; auto.
+  intros H0 H1 H2; case (not_even_and_odd m); auto.
+  case H0; auto.
+  intros H0; case H0; auto.
 Qed.
  
 Lemma odd_plus_even_inv_r : forall n m, odd (n + m) -> odd n -> even m.
 Proof.
-intros n m H; case (even_plus_aux n m).
-intros H' H'0; elim H'.
-intros H'1; case H'1; auto.
-intros H0; case H0; auto.
-intros H0 H1 H2; case (not_even_and_odd n); auto.
-case H0; auto.
+  intros n m H; case (even_plus_aux n m).
+  intros H' H'0; elim H'.
+  intros H'1; case H'1; auto.
+  intros H0; case H0; auto.
+  intros H0 H1 H2; case (not_even_and_odd n); auto.
+  case H0; auto.
 Qed.
  
 Lemma odd_plus_odd_inv_l : forall n m, odd (n + m) -> even m -> odd n.
 Proof.
-intros n m H; case (even_plus_aux n m).
-intros H' H'0; elim H'.
-intros H'1; case H'1; auto.
-intros H0; case H0; auto.
-intros H0 H1 H2; case (not_even_and_odd m); auto.
-case H0; auto.
+  intros n m H; case (even_plus_aux n m).
+  intros H' H'0; elim H'.
+  intros H'1; case H'1; auto.
+  intros H0; case H0; auto.
+  intros H0 H1 H2; case (not_even_and_odd m); auto.
+  case H0; auto.
 Qed.
- 
+
 Lemma odd_plus_odd_inv_r : forall n m, odd (n + m) -> even n -> odd m.
 Proof.
-intros n m H; case (even_plus_aux n m).
-intros H' H'0; elim H'.
-intros H'1; case H'1; auto.
-intros H0 H1 H2; case (not_even_and_odd n); auto.
-case H0; auto.
-intros H0; case H0; auto.
+  intros n m H; case (even_plus_aux n m).
+  intros H' H'0; elim H'.
+  intros H'1; case H'1; auto.
+  intros H0 H1 H2; case (not_even_and_odd n); auto.
+  case H0; auto.
+  intros H0; case H0; auto.
 Qed.
 Hint Resolve odd_plus_l odd_plus_r: arith.
- 
+
+
+(** * Facts about [even] and [odd] wrt. [mult] *)
+
 Lemma even_mult_aux :
- forall n m,
-   (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m).
+  forall n m,
+    (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m).
 Proof.
-intros n; elim n; simpl in |- *; auto with arith.
-intros m; split; split; auto with arith.
-intros H'; inversion H'.
-intros H'; elim H'; auto.
-intros n0 H' m; split; split; auto with arith.
-intros H'0.
-elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'3; intros H'1 H'2;
- case H'1; auto.
-intros H'5; elim H'5; intros H'6 H'7; auto with arith.
-split; auto with arith.
-case (H' m).
-intros H'8 H'9; case H'9.
-intros H'10; case H'10; auto with arith.
-intros H'11 H'12; case (not_even_and_odd m); auto with arith.
-intros H'5; elim H'5; intros H'6 H'7; case (not_even_and_odd (n0 * m)); auto.
-case (H' m).
-intros H'8 H'9; case H'9; auto.
-intros H'0; elim H'0; intros H'1 H'2; clear H'0.
-elim (even_plus_aux m (n0 * m)); auto.
-intros H'0 H'3.
-elim H'0.
-intros H'4 H'5; apply H'5; auto.
-left; split; auto with arith.
-case (H' m).
-intros H'6 H'7; elim H'7.
-intros H'8 H'9; apply H'9.
-left.
-inversion H'1; auto.
-intros H'0.
-elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'4.
-intros H'1 H'2.
-elim H'1; auto.
-intros H; case H; auto.
-intros H'5; elim H'5; intros H'6 H'7; auto with arith.
-left.
-case (H' m).
-intros H'8; elim H'8.
-intros H'9; elim H'9; auto with arith.
-intros H'0; elim H'0; intros H'1.
-case (even_or_odd m); intros H'2.
-apply even_even_plus; auto.
-case (H' m).
-intros H H0; case H0; auto.
-apply odd_even_plus; auto.
-inversion H'1; case (H' m); auto.
-intros H1; case H1; auto.
-apply even_even_plus; auto.
-case (H' m).
-intros H H0; case H0; auto.
+  intros n; elim n; simpl in |- *; auto with arith.
+  intros m; split; split; auto with arith.
+  intros H'; inversion H'.
+  intros H'; elim H'; auto.
+  intros n0 H' m; split; split; auto with arith.
+  intros H'0.
+  elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'3; intros H'1 H'2;
+    case H'1; auto.
+  intros H'5; elim H'5; intros H'6 H'7; auto with arith.
+  split; auto with arith.
+  case (H' m).
+  intros H'8 H'9; case H'9.
+  intros H'10; case H'10; auto with arith.
+  intros H'11 H'12; case (not_even_and_odd m); auto with arith.
+  intros H'5; elim H'5; intros H'6 H'7; case (not_even_and_odd (n0 * m)); auto.
+  case (H' m).
+  intros H'8 H'9; case H'9; auto.
+  intros H'0; elim H'0; intros H'1 H'2; clear H'0.
+  elim (even_plus_aux m (n0 * m)); auto.
+  intros H'0 H'3.
+  elim H'0.
+  intros H'4 H'5; apply H'5; auto.
+  left; split; auto with arith.
+  case (H' m).
+  intros H'6 H'7; elim H'7.
+  intros H'8 H'9; apply H'9.
+  left.
+  inversion H'1; auto.
+  intros H'0.
+  elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'4.
+  intros H'1 H'2.
+  elim H'1; auto.
+  intros H; case H; auto.
+  intros H'5; elim H'5; intros H'6 H'7; auto with arith.
+  left.
+  case (H' m).
+  intros H'8; elim H'8.
+  intros H'9; elim H'9; auto with arith.
+  intros H'0; elim H'0; intros H'1.
+  case (even_or_odd m); intros H'2.
+  apply even_even_plus; auto.
+  case (H' m).
+  intros H H0; case H0; auto.
+  apply odd_even_plus; auto.
+  inversion H'1; case (H' m); auto.
+  intros H1; case H1; auto.
+  apply even_even_plus; auto.
+  case (H' m).
+  intros H H0; case H0; auto.
 Qed.
- 
+
 Lemma even_mult_l : forall n m, even n -> even (n * m).
 Proof.
-intros n m; case (even_mult_aux n m); auto.
-intros H H0; case H0; auto.
+  intros n m; case (even_mult_aux n m); auto.
+  intros H H0; case H0; auto.
 Qed.
  
 Lemma even_mult_r : forall n m, even m -> even (n * m).
 Proof.
-intros n m; case (even_mult_aux n m); auto.
-intros H H0; case H0; auto.
+  intros n m; case (even_mult_aux n m); auto.
+  intros H H0; case H0; auto.
 Qed.
 Hint Resolve even_mult_l even_mult_r: arith.
- 
+
 Lemma even_mult_inv_r : forall n m, even (n * m) -> odd n -> even m.
 Proof.
-intros n m H' H'0.
-case (even_mult_aux n m).
-intros H'1 H'2; elim H'2.
-intros H'3; elim H'3; auto.
-intros H; case (not_even_and_odd n); auto.
+  intros n m H' H'0.
+  case (even_mult_aux n m).
+  intros H'1 H'2; elim H'2.
+  intros H'3; elim H'3; auto.
+  intros H; case (not_even_and_odd n); auto.
 Qed.
  
 Lemma even_mult_inv_l : forall n m, even (n * m) -> odd m -> even n.
 Proof.
-intros n m H' H'0.
-case (even_mult_aux n m).
-intros H'1 H'2; elim H'2.
-intros H'3; elim H'3; auto.
-intros H; case (not_even_and_odd m); auto.
+  intros n m H' H'0.
+  case (even_mult_aux n m).
+  intros H'1 H'2; elim H'2.
+  intros H'3; elim H'3; auto.
+  intros H; case (not_even_and_odd m); auto.
 Qed.
  
 Lemma odd_mult : forall n m, odd n -> odd m -> odd (n * m).
 Proof.
-intros n m; case (even_mult_aux n m); intros H; case H; auto.
+  intros n m; case (even_mult_aux n m); intros H; case H; auto.
 Qed.
 Hint Resolve even_mult_l even_mult_r odd_mult: arith.
  
 Lemma odd_mult_inv_l : forall n m, odd (n * m) -> odd n.
 Proof.
-intros n m H'.
-case (even_mult_aux n m).
-intros H'1 H'2; elim H'1.
-intros H'3; elim H'3; auto.
+  intros n m H'.
+  case (even_mult_aux n m).
+  intros H'1 H'2; elim H'1.
+  intros H'3; elim H'3; auto.
 Qed.
- 
+
 Lemma odd_mult_inv_r : forall n m, odd (n * m) -> odd m.
 Proof.
-intros n m H'.
-case (even_mult_aux n m).
-intros H'1 H'2; elim H'1.
-intros H'3; elim H'3; auto.
+  intros n m H'.
+  case (even_mult_aux n m).
+  intros H'1 H'2; elim H'1.
+  intros H'3; elim H'3; auto.
 Qed.
diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v
index 4db211e4..5e2f491a 100644
--- a/theories/Arith/Factorial.v
+++ b/theories/Arith/Factorial.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Factorial.v,v 1.5.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Factorial.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Plus.
 Require Import Mult.
@@ -15,36 +15,36 @@ Open Local Scope nat_scope.
 
 (** Factorial *)
 
-Fixpoint fact (n:nat) : nat :=
+Boxed Fixpoint fact (n:nat) : nat :=
   match n with
-  | O => 1
-  | S n => S n * fact n
+    | O => 1
+    | S n => S n * fact n
   end.
 
 Arguments Scope fact [nat_scope].
 
 Lemma lt_O_fact : forall n:nat, 0 < fact n.
 Proof.
-simple induction n; unfold lt in |- *; simpl in |- *; auto with arith.
+  simple induction n; unfold lt in |- *; simpl in |- *; auto with arith.
 Qed.
 
 Lemma fact_neq_0 : forall n:nat, fact n <> 0.
 Proof.
-intro.
-apply sym_not_eq.
-apply lt_O_neq.
-apply lt_O_fact.
+  intro.
+  apply sym_not_eq.
+  apply lt_O_neq.
+  apply lt_O_fact.
 Qed.
 
 Lemma fact_le : forall n m:nat, n <= m -> fact n <= fact m.
 Proof.
-induction 1.
-apply le_n.
-assert (1 * fact n <= S m * fact m).
-apply mult_le_compat.
-apply lt_le_S; apply lt_O_Sn.
-assumption.
-simpl (1 * fact n) in H0.
-rewrite <- plus_n_O in H0.
-assumption.
-Qed.
\ No newline at end of file
+  induction 1.
+  apply le_n.
+  assert (1 * fact n <= S m * fact m).
+  apply mult_le_compat.
+  apply lt_le_S; apply lt_O_Sn.
+  assumption.
+  simpl (1 * fact n) in H0.
+  rewrite <- plus_n_O in H0.
+  assumption.
+Qed.
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
index 299c664d..5b1ee1b2 100755..100644
--- a/theories/Arith/Gt.v
+++ b/theories/Arith/Gt.v
@@ -6,7 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Gt.v,v 1.8.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Gt.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+(** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as:
+<<
+Definition gt (n m:nat) := m < n.
+>>
+*)
 
 Require Import Le.
 Require Import Lt.
@@ -15,7 +21,7 @@ Open Local Scope nat_scope.
 
 Implicit Types m n p : nat.
 
-(** Order and successor *)
+(** * Order and successor *)
 
 Theorem gt_Sn_O : forall n, S n > 0.
 Proof.
@@ -52,20 +58,20 @@ Proof.
 Qed.
 Hint Immediate gt_pred: arith v62.
 
-(** Irreflexivity *)
+(** * Irreflexivity *)
 
 Lemma gt_irrefl : forall n, ~ n > n.
 Proof lt_irrefl.
 Hint Resolve gt_irrefl: arith v62.
 
-(** Asymmetry *)
+(** * Asymmetry *)
 
 Lemma gt_asym : forall n m, n > m -> ~ m > n.
 Proof fun n m => lt_asym m n.
 
 Hint Resolve gt_asym: arith v62.
 
-(** Relating strict and large orders *)
+(** * Relating strict and large orders *)
 
 Lemma le_not_gt : forall n m, n <= m -> ~ n > m.
 Proof le_not_lt.
@@ -102,7 +108,7 @@ Proof.
 Qed.
 Hint Resolve le_gt_S: arith v62.
 
-(** Transitivity *)
+(** * Transitivity *)
 
 Theorem le_gt_trans : forall n m p, m <= n -> m > p -> n > p.
 Proof.
@@ -127,14 +133,14 @@ Qed.
 
 Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62.
 
-(** Comparison to 0 *)
+(** * Comparison to 0 *)
 
 Theorem gt_O_eq : forall n, n > 0 \/ 0 = n.
 Proof.
   intro n; apply gt_S; auto with arith.
 Qed.
 
-(** Simplification and compatibility *)
+(** * Simplification and compatibility *)
 
 Lemma plus_gt_reg_l : forall n m p, p + n > p + m -> n > m.
 Proof.
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
index a5378cff..e8b9e6be 100755..100644
--- a/theories/Arith/Le.v
+++ b/theories/Arith/Le.v
@@ -6,109 +6,124 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Le.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Le.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+(** Order on natural numbers. [le] is defined in [Init/Peano.v] as:
+<<
+Inductive le (n:nat) : nat -> Prop :=
+  | le_n : n <= n
+  | le_S : forall m:nat, n <= m -> n <= S m
+
+where "n <= m" := (le n m) : nat_scope.
+>>
+ *)
 
-(** Order on natural numbers *)
 Open Local Scope nat_scope.
 
 Implicit Types m n p : nat.
 
-(** Reflexivity *)
+(** * [le] is a pre-order *)
 
+(** Reflexivity *)
 Theorem le_refl : forall n, n <= n.
 Proof.
-exact le_n.
+  exact le_n.
 Qed.
 
 (** Transitivity *)
-
 Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p.
 Proof.
   induction 2; auto.
 Qed.
 Hint Resolve le_trans: arith v62.
 
-(** Order, successor and predecessor *)
+(** * Properties of [le] w.r.t. successor, predecessor and 0 *)
 
-Theorem le_n_S : forall n m, n <= m -> S n <= S m.
+(** Comparison to 0 *)
+
+Theorem le_O_n : forall n, 0 <= n.
 Proof.
-  induction 1; auto.
+  induction n; auto.
 Qed.
 
-Theorem le_n_Sn : forall n, n <= S n.
+Theorem le_Sn_O : forall n, ~ S n <= 0.
 Proof.
-  auto.
+  red in |- *; intros n H.
+  change (IsSucc 0) in |- *; elim H; simpl in |- *; auto with arith.
 Qed.
 
-Theorem le_O_n : forall n, 0 <= n.
+Hint Resolve le_O_n le_Sn_O: arith v62.
+
+Theorem le_n_O_eq : forall n, n <= 0 -> 0 = n.
 Proof.
-  induction n; auto.
+  induction n; auto with arith.
+  intro; contradiction le_Sn_O with n.
 Qed.
+Hint Immediate le_n_O_eq: arith v62.
 
-Hint Resolve le_n_S le_n_Sn le_O_n le_n_S: arith v62.
 
-Theorem le_pred_n : forall n, pred n <= n.
+(** [le] and successor *)
+
+Theorem le_n_S : forall n m, n <= m -> S n <= S m.
 Proof.
-induction n; auto with arith.
+  induction 1; auto.
 Qed.
-Hint Resolve le_pred_n: arith v62.
+
+Theorem le_n_Sn : forall n, n <= S n.
+Proof.
+  auto.
+Qed.
+
+Hint Resolve le_n_S le_n_Sn : arith v62.
 
 Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
 Proof.
-intros n m H; apply le_trans with (S n); auto with arith.
+  intros n m H; apply le_trans with (S n); auto with arith.
 Qed.
 Hint Immediate le_Sn_le: arith v62.
 
 Theorem le_S_n : forall n m, S n <= S m -> n <= m.
 Proof.
-intros n m H; change (pred (S n) <= pred (S m)) in |- *.
-elim H; simpl in |- *; auto with arith.
+  intros n m H; change (pred (S n) <= pred (S m)) in |- *.
+  destruct H; simpl; auto with arith.
 Qed.
 Hint Immediate le_S_n: arith v62.
 
-Theorem le_pred : forall n m, n <= m -> pred n <= pred m.
+Theorem le_Sn_n : forall n, ~ S n <= n.
 Proof.
-induction n as [| n IHn]. simpl in |- *. auto with arith.
-destruct m as [| m]. simpl in |- *. intro H. inversion H.
-simpl in |- *. auto with arith.
+  induction n; auto with arith.
 Qed.
+Hint Resolve le_Sn_n: arith v62.
 
-(** Comparison to 0 *)
+(** [le] and predecessor *)
 
-Theorem le_Sn_O : forall n, ~ S n <= 0.
+Theorem le_pred_n : forall n, pred n <= n.
 Proof.
-red in |- *; intros n H.
-change (IsSucc 0) in |- *; elim H; simpl in |- *; auto with arith.
+  induction n; auto with arith.
 Qed.
-Hint Resolve le_Sn_O: arith v62.
+Hint Resolve le_pred_n: arith v62.
 
-Theorem le_n_O_eq : forall n, n <= 0 -> 0 = n.
+Theorem le_pred : forall n m, n <= m -> pred n <= pred m.
 Proof.
-induction n; auto with arith.
-intro; contradiction le_Sn_O with n.
+  destruct n; simpl; auto with arith.
+  destruct m; simpl; auto with arith.
 Qed.
-Hint Immediate le_n_O_eq: arith v62.
 
-(** Negative properties *)
-
-Theorem le_Sn_n : forall n, ~ S n <= n.
-Proof.
-induction n; auto with arith.
-Qed.
-Hint Resolve le_Sn_n: arith v62.
 
+(** * [le] is a order on [nat] *)
 (** Antisymmetry *)
 
 Theorem le_antisym : forall n m, n <= m -> m <= n -> n = m.
 Proof.
-intros n m h; destruct h as [| m0 H]; auto with arith.
-intros H1.
-absurd (S m0 <= m0); auto with arith.
-apply le_trans with n; auto with arith.
+  intros n m H; destruct H as [|m' H]; auto with arith.
+  intros H1.
+  absurd (S m' <= m'); auto with arith.
+  apply le_trans with n; auto with arith.
 Qed.
 Hint Immediate le_antisym: arith v62.
 
-(** A different elimination principle for the order on natural numbers *)
+
+(** * A different elimination principle for the order on natural numbers *)
 
 Lemma le_elim_rel :
  forall P:nat -> nat -> Prop,
@@ -116,7 +131,7 @@ Lemma le_elim_rel :
    (forall p (q:nat), p <= q -> P p q -> P (S p) (S q)) ->
    forall n m, n <= m -> P n m.
 Proof.
-induction n; auto with arith.
-intros m Le.
-elim Le; auto with arith.
-Qed.
\ No newline at end of file
+  induction n; auto with arith.
+  intros m Le.
+  elim Le; auto with arith.
+Qed.
diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v
index e1b3e4b8..94cf3793 100755..100644
--- a/theories/Arith/Lt.v
+++ b/theories/Arith/Lt.v
@@ -6,86 +6,93 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lt.v,v 1.11.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Lt.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+(** Theorems about [lt] in nat. [lt] is defined in library [Init/Peano.v] as:
+<<
+Definition lt (n m:nat) := S n <= m.
+Infix "<" := lt : nat_scope.
+>>
+*)
 
 Require Import Le.
 Open Local Scope nat_scope.
 
 Implicit Types m n p : nat.
 
-(** Irreflexivity *)
+(** * Irreflexivity *)
 
 Theorem lt_irrefl : forall n, ~ n < n.
 Proof le_Sn_n.
 Hint Resolve lt_irrefl: arith v62.
 
-(** Relationship between [le] and [lt] *) 
+(** * Relationship between [le] and [lt] *) 
 
 Theorem lt_le_S : forall n m, n < m -> S n <= m.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Immediate lt_le_S: arith v62.
 
 Theorem lt_n_Sm_le : forall n m, n < S m -> n <= m.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Immediate lt_n_Sm_le: arith v62.
 
 Theorem le_lt_n_Sm : forall n m, n <= m -> n < S m.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Immediate le_lt_n_Sm: arith v62.
 
 Theorem le_not_lt : forall n m, n <= m -> ~ m < n.
 Proof.
-induction 1; auto with arith.
+  induction 1; auto with arith.
 Qed.
 
 Theorem lt_not_le : forall n m, n < m -> ~ m <= n.
 Proof.
-red in |- *; intros n m Lt Le; exact (le_not_lt m n Le Lt).
+  red in |- *; intros n m Lt Le; exact (le_not_lt m n Le Lt).
 Qed.
 Hint Immediate le_not_lt lt_not_le: arith v62.
 
-(** Asymmetry *)
+(** * Asymmetry *)
 
 Theorem lt_asym : forall n m, n < m -> ~ m < n.
 Proof.
-induction 1; auto with arith.
+  induction 1; auto with arith.
 Qed.
 
-(** Order and successor *)
+(** * Order and successor *)
 
 Theorem lt_n_Sn : forall n, n < S n.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Resolve lt_n_Sn: arith v62.
 
 Theorem lt_S : forall n m, n < m -> n < S m.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Resolve lt_S: arith v62.
 
 Theorem lt_n_S : forall n m, n < m -> S n < S m.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Resolve lt_n_S: arith v62.
 
 Theorem lt_S_n : forall n m, S n < S m -> n < m.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Immediate lt_S_n: arith v62.
 
 Theorem lt_O_Sn : forall n, 0 < S n.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Resolve lt_O_Sn: arith v62.
 
@@ -93,7 +100,7 @@ Theorem lt_n_O : forall n, ~ n < 0.
 Proof le_Sn_O.
 Hint Resolve lt_n_O: arith v62.
 
-(** Predecessor *)
+(** * Predecessor *)
 
 Lemma S_pred : forall n m, m < n -> n = S (pred n).
 Proof.
@@ -111,65 +118,65 @@ destruct 1; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve lt_pred_n_n: arith v62.
 
-(** Transitivity properties *)
+(** * Transitivity properties *)
 
 Theorem lt_trans : forall n m p, n < m -> m < p -> n < p.
 Proof.
-induction 2; auto with arith.
+  induction 2; auto with arith.
 Qed.
 
 Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p.
 Proof.
-induction 2; auto with arith.
+  induction 2; auto with arith.
 Qed.
 
 Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p.
 Proof.
-induction 2; auto with arith.
+  induction 2; auto with arith.
 Qed.
 
 Hint Resolve lt_trans lt_le_trans le_lt_trans: arith v62.
 
-(** Large = strict or equal *)
+(** * Large = strict or equal *)
 
 Theorem le_lt_or_eq : forall n m, n <= m -> n < m \/ n = m.
 Proof.
-induction 1; auto with arith.
+  induction 1; auto with arith.
 Qed.
 
 Theorem lt_le_weak : forall n m, n < m -> n <= m.
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Immediate lt_le_weak: arith v62.
 
-(** Dichotomy *)
+(** * Dichotomy *)
 
 Theorem le_or_lt : forall n m, n <= m \/ m < n.
 Proof.
-intros n m; pattern n, m in |- *; apply nat_double_ind; auto with arith.
-induction 1; auto with arith.
+  intros n m; pattern n, m in |- *; apply nat_double_ind; auto with arith.
+  induction 1; auto with arith.
 Qed.
 
 Theorem nat_total_order : forall n m, n <> m -> n < m \/ m < n.
 Proof.
-intros m n diff.
-elim (le_or_lt n m); [ intro H'0 | auto with arith ].
-elim (le_lt_or_eq n m); auto with arith.
-intro H'; elim diff; auto with arith.
+  intros m n diff.
+  elim (le_or_lt n m); [ intro H'0 | auto with arith ].
+  elim (le_lt_or_eq n m); auto with arith.
+  intro H'; elim diff; auto with arith.
 Qed.
 
-(** Comparison to 0 *)
+(** * Comparison to 0 *)
 
 Theorem neq_O_lt : forall n, 0 <> n -> 0 < n.
 Proof.
-induction n; auto with arith.
-intros; absurd (0 = 0); trivial with arith.
+  induction n; auto with arith.
+  intros; absurd (0 = 0); trivial with arith.
 Qed.
 Hint Immediate neq_O_lt: arith v62.
 
 Theorem lt_O_neq : forall n, 0 < n -> 0 <> n.
 Proof.
-induction 1; auto with arith.
+  induction 1; auto with arith.
 Qed.
 Hint Immediate lt_O_neq: arith v62.
\ No newline at end of file
diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v
index 82673ed0..e0222e41 100755..100644
--- a/theories/Arith/Max.v
+++ b/theories/Arith/Max.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Max.v,v 1.7.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Max.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Arith.
 
@@ -14,72 +14,66 @@ Open Local Scope nat_scope.
 
 Implicit Types m n : nat.
 
-(** maximum of two natural numbers *)
+(** * maximum of two natural numbers *)
 
 Fixpoint max n m {struct n} : nat :=
   match n, m with
-  | O, _ => m
-  | S n', O => n
-  | S n', S m' => S (max n' m')
+    | O, _ => m
+    | S n', O => n
+    | S n', S m' => S (max n' m')
   end.
 
-(** Simplifications of [max] *)
+(** * Simplifications of [max] *)
 
 Lemma max_SS : forall n m, S (max n m) = max (S n) (S m).
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 
 Lemma max_comm : forall n m, max n m = max m n.
 Proof.
-induction n; induction m; simpl in |- *; auto with arith.
+  induction n; induction m; simpl in |- *; auto with arith.
 Qed.
 
-(** [max] and [le] *)
+(** * [max] and [le] *)
 
 Lemma max_l : forall n m, m <= n -> max n m = n.
 Proof.
-induction n; induction m; simpl in |- *; auto with arith.
+  induction n; induction m; simpl in |- *; auto with arith.
 Qed.
 
 Lemma max_r : forall n m, n <= m -> max n m = m.
 Proof.
-induction n; induction m; simpl in |- *; auto with arith.
+  induction n; induction m; simpl in |- *; auto with arith.
 Qed.
 
 Lemma le_max_l : forall n m, n <= max n m.
 Proof.
-induction n; intros; simpl in |- *; auto with arith.
-elim m; intros; simpl in |- *; auto with arith.
+  induction n; intros; simpl in |- *; auto with arith.
+  elim m; intros; simpl in |- *; auto with arith.
 Qed.
 
 Lemma le_max_r : forall n m, m <= max n m.
 Proof.
-induction n; simpl in |- *; auto with arith.
-induction m; simpl in |- *; auto with arith.
+  induction n; simpl in |- *; auto with arith.
+  induction m; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve max_r max_l le_max_l le_max_r: arith v62.
 
 
-(** [max n m] is equal to [n] or [m] *)
+(** * [max n m] is equal to [n] or [m] *)
 
 Lemma max_dec : forall n m, {max n m = n} + {max n m = m}.
 Proof.
-induction n; induction m; simpl in |- *; auto with arith.
-elim (IHn m); intro H; elim H; auto.
+  induction n; induction m; simpl in |- *; auto with arith.
+  elim (IHn m); intro H; elim H; auto.
 Qed.
 
-Lemma max_case : forall n m (P:nat -> Set), P n -> P m -> P (max n m).
+Lemma max_case : forall n m (P:nat -> Type), P n -> P m -> P (max n m).
 Proof.
-induction n; simpl in |- *; auto with arith.
-induction m; intros; simpl in |- *; auto with arith.
-pattern (max n m) in |- *; apply IHn; auto with arith.
-Qed.
-
-Lemma max_case2 : forall n m (P:nat -> Prop), P n -> P m -> P (max n m).
-Proof.
-induction n; simpl in |- *; auto with arith.
-induction m; intros; simpl in |- *; auto with arith.
-pattern (max n m) in |- *; apply IHn; auto with arith.
+  induction n; simpl in |- *; auto with arith.
+  induction m; intros; simpl in |- *; auto with arith.
+  pattern (max n m) in |- *; apply IHn; auto with arith.
 Qed.
 
+Notation max_case2 := max_case (only parsing).
diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v
index 912e7ba3..db14e74b 100755..100644
--- a/theories/Arith/Min.v
+++ b/theories/Arith/Min.v
@@ -6,78 +6,74 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Min.v,v 1.10.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Min.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
-Require Import Arith.
+Require Import Le.
 
 Open Local Scope nat_scope.
 
 Implicit Types m n : nat.
 
-(** minimum of two natural numbers *)
+(** * minimum of two natural numbers *)
 
 Fixpoint min n m {struct n} : nat :=
   match n, m with
-  | O, _ => 0
-  | S n', O => 0
-  | S n', S m' => S (min n' m')
+    | O, _ => 0
+    | S n', O => 0
+    | S n', S m' => S (min n' m')
   end.
 
-(** Simplifications of [min] *)
+(** * Simplifications of [min] *)
 
 Lemma min_SS : forall n m, S (min n m) = min (S n) (S m).
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 
 Lemma min_comm : forall n m, min n m = min m n.
 Proof.
-induction n; induction m; simpl in |- *; auto with arith.
+  induction n; induction m; simpl in |- *; auto with arith.
 Qed.
 
-(** [min] and [le] *)
+(** * [min] and [le] *)
 
 Lemma min_l : forall n m, n <= m -> min n m = n.
 Proof.
-induction n; induction m; simpl in |- *; auto with arith.
+  induction n; induction m; simpl in |- *; auto with arith.
 Qed.
 
 Lemma min_r : forall n m, m <= n -> min n m = m.
 Proof.
-induction n; induction m; simpl in |- *; auto with arith.
+  induction n; induction m; simpl in |- *; auto with arith.
 Qed.
 
 Lemma le_min_l : forall n m, min n m <= n.
 Proof.
-induction n; intros; simpl in |- *; auto with arith.
-elim m; intros; simpl in |- *; auto with arith.
+  induction n; intros; simpl in |- *; auto with arith.
+  elim m; intros; simpl in |- *; auto with arith.
 Qed.
 
 Lemma le_min_r : forall n m, min n m <= m.
 Proof.
-induction n; simpl in |- *; auto with arith.
-induction m; simpl in |- *; auto with arith.
+  induction n; simpl in |- *; auto with arith.
+  induction m; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve min_l min_r le_min_l le_min_r: arith v62.
 
-(** [min n m] is equal to [n] or [m] *)
+(** * [min n m] is equal to [n] or [m] *)
 
 Lemma min_dec : forall n m, {min n m = n} + {min n m = m}.
 Proof.
-induction n; induction m; simpl in |- *; auto with arith.
-elim (IHn m); intro H; elim H; auto.
+  induction n; induction m; simpl in |- *; auto with arith.
+  elim (IHn m); intro H; elim H; auto.
 Qed.
 
-Lemma min_case : forall n m (P:nat -> Set), P n -> P m -> P (min n m).
+Lemma min_case : forall n m (P:nat -> Type), P n -> P m -> P (min n m).
 Proof.
-induction n; simpl in |- *; auto with arith.
-induction m; intros; simpl in |- *; auto with arith.
-pattern (min n m) in |- *; apply IHn; auto with arith.
+  induction n; simpl in |- *; auto with arith.
+  induction m; intros; simpl in |- *; auto with arith.
+  pattern (min n m) in |- *; apply IHn; auto with arith.
 Qed.
 
-Lemma min_case2 : forall n m (P:nat -> Prop), P n -> P m -> P (min n m).
-Proof.
-induction n; simpl in |- *; auto with arith.
-induction m; intros; simpl in |- *; auto with arith.
-pattern (min n m) in |- *; apply IHn; auto with arith.
-Qed.
\ No newline at end of file
+Notation min_case2 := min_case (only parsing).
+
diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v
index ba9a46ad..2380c2de 100755..100644
--- a/theories/Arith/Minus.v
+++ b/theories/Arith/Minus.v
@@ -6,9 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Minus.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
-
-(** Subtraction (difference between two natural numbers) *)
+(*i $Id: Minus.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+(** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as:
+<<
+Fixpoint minus (n m:nat) {struct n} : nat :=
+  match n, m with
+  | O, _ => 0
+  | S k, O => S k
+  | S k, S l => k - l
+  end
+where "n - m" := (minus n m) : nat_scope.
+>>
+*)
 
 Require Import Lt.
 Require Import Le.
@@ -17,36 +27,37 @@ Open Local Scope nat_scope.
 
 Implicit Types m n p : nat.
 
-(** 0 is right neutral *)
+(** * 0 is right neutral *)
 
 Lemma minus_n_O : forall n, n = n - 0.
 Proof.
-induction n; simpl in |- *; auto with arith.
+  induction n; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve minus_n_O: arith v62.
 
-(** Permutation with successor *)
+(** * Permutation with successor *)
 
 Lemma minus_Sn_m : forall n m, m <= n -> S (n - m) = S n - m.
 Proof.
-intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *;
- auto with arith.
+  intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *;
+    auto with arith.
 Qed.
 Hint Resolve minus_Sn_m: arith v62.
 
 Theorem pred_of_minus : forall n, pred n = n - 1.
-intro x; induction x; simpl in |- *; auto with arith.
+Proof.
+  intro x; induction x; simpl in |- *; auto with arith.
 Qed.
 
-(** Diagonal *)
+(** * Diagonal *)
 
 Lemma minus_n_n : forall n, 0 = n - n.
 Proof.
-induction n; simpl in |- *; auto with arith.
+  induction n; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve minus_n_n: arith v62.
 
-(** Simplification *)
+(** * Simplification *)
 
 Lemma minus_plus_simpl_l_reverse : forall n m p, n - m = p + n - (p + m).
 Proof.
@@ -54,70 +65,71 @@ Proof.
 Qed.
 Hint Resolve minus_plus_simpl_l_reverse: arith v62.
 
-(** Relation with plus *)
+(** * Relation with plus *)
 
 Lemma plus_minus : forall n m p, n = m + p -> p = n - m.
 Proof.
-intros n m p; pattern m, n in |- *; apply nat_double_ind; simpl in |- *;
- intros.
-replace (n0 - 0) with n0; auto with arith.
-absurd (0 = S (n0 + p)); auto with arith.
-auto with arith.
+  intros n m p; pattern m, n in |- *; apply nat_double_ind; simpl in |- *;
+    intros.
+  replace (n0 - 0) with n0; auto with arith.
+  absurd (0 = S (n0 + p)); auto with arith.
+  auto with arith.
 Qed.
 Hint Immediate plus_minus: arith v62.
 
 Lemma minus_plus : forall n m, n + m - n = m.
-symmetry  in |- *; auto with arith.
+  symmetry  in |- *; auto with arith.
 Qed.
 Hint Resolve minus_plus: arith v62.
 
 Lemma le_plus_minus : forall n m, n <= m -> m = n + (m - n).
 Proof.
-intros n m Le; pattern n, m in |- *; apply le_elim_rel; simpl in |- *;
- auto with arith.
+  intros n m Le; pattern n, m in |- *; apply le_elim_rel; simpl in |- *;
+    auto with arith.
 Qed.
 Hint Resolve le_plus_minus: arith v62.
 
 Lemma le_plus_minus_r : forall n m, n <= m -> n + (m - n) = m.
 Proof.
-symmetry  in |- *; auto with arith.
+  symmetry  in |- *; auto with arith.
 Qed.
 Hint Resolve le_plus_minus_r: arith v62.
 
-(** Relation with order *)
+(** * Relation with order *)
 
 Theorem le_minus : forall n m, n - m <= n.
 Proof.
-intros i h; pattern i, h in |- *; apply nat_double_ind;
- [ auto
- | auto
- | intros m n H; simpl in |- *; apply le_trans with (m := m); auto ].
+  intros i h; pattern i, h in |- *; apply nat_double_ind;
+    [ auto
+      | auto
+      | intros m n H; simpl in |- *; apply le_trans with (m := m); auto ].
 Qed.
 
 Lemma lt_minus : forall n m, m <= n -> 0 < m -> n - m < n.
 Proof.
-intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *;
- auto with arith.
-intros; absurd (0 < 0); auto with arith.
-intros p q lepq Hp gtp.
-elim (le_lt_or_eq 0 p); auto with arith.
-auto with arith.
-induction 1; elim minus_n_O; auto with arith.
+  intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *;
+    auto with arith.
+  intros; absurd (0 < 0); auto with arith.
+  intros p q lepq Hp gtp.
+  elim (le_lt_or_eq 0 p); auto with arith.
+  auto with arith.
+  induction 1; elim minus_n_O; auto with arith.
 Qed.
 Hint Resolve lt_minus: arith v62.
 
 Lemma lt_O_minus_lt : forall n m, 0 < n - m -> m < n.
 Proof.
-intros n m; pattern n, m in |- *; apply nat_double_ind; simpl in |- *;
- auto with arith.
-intros; absurd (0 < 0); trivial with arith.
+  intros n m; pattern n, m in |- *; apply nat_double_ind; simpl in |- *;
+    auto with arith.
+  intros; absurd (0 < 0); trivial with arith.
 Qed.
 Hint Immediate lt_O_minus_lt: arith v62.
 
 Theorem not_le_minus_0 : forall n m, ~ m <= n -> n - m = 0.
-intros y x; pattern y, x in |- *; apply nat_double_ind;
- [ simpl in |- *; trivial with arith
- | intros n H; absurd (0 <= S n); [ assumption | apply le_O_n ]
- | simpl in |- *; intros n m H1 H2; apply H1; unfold not in |- *; intros H3;
-    apply H2; apply le_n_S; assumption ].
-Qed.
\ No newline at end of file
+Proof.
+  intros y x; pattern y, x in |- *; apply nat_double_ind;
+    [ simpl in |- *; trivial with arith
+      | intros n H; absurd (0 <= S n); [ assumption | apply le_O_n ]
+      | simpl in |- *; intros n m H1 H2; apply H1; unfold not in |- *; intros H3;
+	apply H2; apply le_n_S; assumption ].
+Qed.
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
index abfade57..2315e12c 100755..100644
--- a/theories/Arith/Mult.v
+++ b/theories/Arith/Mult.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Mult.v,v 1.21.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Mult.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Plus.
 Require Export Minus.
@@ -17,86 +17,98 @@ Open Local Scope nat_scope.
 
 Implicit Types m n p : nat.
 
-(** Zero property *)
+(** Theorems about multiplication in [nat]. [mult] is defined in module [Init/Peano.v]. *)
+
+(** * [nat] is a semi-ring *)
+
+(** ** Zero property *)
 
 Lemma mult_0_r : forall n, n * 0 = 0.
 Proof.
-intro; symmetry  in |- *; apply mult_n_O.
+  intro; symmetry  in |- *; apply mult_n_O.
 Qed.
 
 Lemma mult_0_l : forall n, 0 * n = 0.
 Proof.
-reflexivity.
+  reflexivity.
 Qed.
 
-(** Distributivity *)
+(** ** 1 is neutral *)
 
-Lemma mult_plus_distr_r : forall n m p, (n + m) * p = n * p + m * p.
+Lemma mult_1_l : forall n, 1 * n = n.
 Proof.
-intros; elim n; simpl in |- *; intros; auto with arith.
-elim plus_assoc; elim H; auto with arith.
+  simpl in |- *; auto with arith.
 Qed.
-Hint Resolve mult_plus_distr_r: arith v62.
+Hint Resolve mult_1_l: arith v62.
 
-Lemma mult_plus_distr_l : forall n m p, n * (m + p) = n * m + n * p.
+Lemma mult_1_r : forall n, n * 1 = n.
 Proof.
-  induction n. trivial.
-  intros. simpl in |- *. rewrite (IHn m p). apply sym_eq. apply plus_permute_2_in_4.
+  induction n; [ trivial | 
+    simpl; rewrite IHn; reflexivity].
 Qed.
+Hint Resolve mult_1_r: arith v62.
 
-Lemma mult_minus_distr_r : forall n m p, (n - m) * p = n * p - m * p.
+(** ** Commutativity *)
+
+Lemma mult_comm : forall n m, n * m = m * n.
 Proof.
-intros; pattern n, m in |- *; apply nat_double_ind; simpl in |- *; intros;
- auto with arith.
-elim minus_plus_simpl_l_reverse; auto with arith.
+intros; elim n; intros; simpl in |- *; auto with arith.
+elim mult_n_Sm.
+elim H; apply plus_comm.
 Qed.
-Hint Resolve mult_minus_distr_r: arith v62.
+Hint Resolve mult_comm: arith v62.
 
-(** Associativity *)
+(** ** Distributivity *)
 
-Lemma mult_assoc_reverse : forall n m p, n * m * p = n * (m * p).
+Lemma mult_plus_distr_r : forall n m p, (n + m) * p = n * p + m * p.
 Proof.
-intros; elim n; intros; simpl in |- *; auto with arith.
-rewrite mult_plus_distr_r.
-elim H; auto with arith.
+  intros; elim n; simpl in |- *; intros; auto with arith.
+  elim plus_assoc; elim H; auto with arith.
 Qed.
-Hint Resolve mult_assoc_reverse: arith v62.
+Hint Resolve mult_plus_distr_r: arith v62.
 
-Lemma mult_assoc : forall n m p, n * (m * p) = n * m * p.
+Lemma mult_plus_distr_l : forall n m p, n * (m + p) = n * m + n * p.
 Proof.
-auto with arith.
+  induction n. trivial.
+  intros. simpl in |- *. rewrite (IHn m p). apply sym_eq. apply plus_permute_2_in_4.
 Qed.
-Hint Resolve mult_assoc: arith v62.
 
-(** Commutativity *)
+Lemma mult_minus_distr_r : forall n m p, (n - m) * p = n * p - m * p.
+Proof.
+  intros; pattern n, m in |- *; apply nat_double_ind; simpl in |- *; intros;
+    auto with arith.
+  elim minus_plus_simpl_l_reverse; auto with arith.
+Qed.
+Hint Resolve mult_minus_distr_r: arith v62.
 
-Lemma mult_comm : forall n m, n * m = m * n.
+Lemma mult_minus_distr_l : forall n m p, n * (m - p) = n * m - n * p.
 Proof.
-intros; elim n; intros; simpl in |- *; auto with arith.
-elim mult_n_Sm.
-elim H; apply plus_comm.
+  intros n m p. rewrite mult_comm. rewrite mult_minus_distr_r. 
+  rewrite (mult_comm m n); rewrite (mult_comm p n); reflexivity.
 Qed.
-Hint Resolve mult_comm: arith v62.
+Hint Resolve mult_minus_distr_l: arith v62.
 
-(** 1 is neutral *)
+(** ** Associativity *)
 
-Lemma mult_1_l : forall n, 1 * n = n.
+Lemma mult_assoc_reverse : forall n m p, n * m * p = n * (m * p).
 Proof.
-simpl in |- *; auto with arith.
+  intros; elim n; intros; simpl in |- *; auto with arith.
+  rewrite mult_plus_distr_r.
+  elim H; auto with arith.
 Qed.
-Hint Resolve mult_1_l: arith v62.
+Hint Resolve mult_assoc_reverse: arith v62.
 
-Lemma mult_1_r : forall n, n * 1 = n.
+Lemma mult_assoc : forall n m p, n * (m * p) = n * m * p.
 Proof.
-intro; elim mult_comm; auto with arith.
+  auto with arith.
 Qed.
-Hint Resolve mult_1_r: arith v62.
+Hint Resolve mult_assoc: arith v62.
 
-(** Compatibility with orders *)
+(** * Compatibility with orders *)
 
 Lemma mult_O_le : forall n m, m = 0 \/ n <= m * n.
 Proof.
-induction m; simpl in |- *; auto with arith.
+  induction m; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve mult_O_le: arith v62.
 
@@ -110,26 +122,27 @@ Hint Resolve mult_le_compat_l: arith.
 
 
 Lemma mult_le_compat_r : forall n m p, n <= m -> n * p <= m * p.
-intros m n p H.
-rewrite mult_comm. rewrite (mult_comm n).
-auto with arith.
+Proof.
+  intros m n p H.
+  rewrite mult_comm. rewrite (mult_comm n).
+  auto with arith.
 Qed.
 
 Lemma mult_le_compat :
- forall n m p (q:nat), n <= m -> p <= q -> n * p <= m * q.
-Proof.
-intros m n p q Hmn Hpq; induction Hmn.
-induction Hpq.
-(* m*p<=m*p *)
-apply le_n.
-(* m*p<=m*m0 -> m*p<=m*(S m0) *)
-rewrite <- mult_n_Sm; apply le_trans with (m * m0).
-assumption.
-apply le_plus_l.
-(* m*p<=m0*q -> m*p<=(S m0)*q *)
-simpl in |- *; apply le_trans with (m0 * q).
-assumption.
-apply le_plus_r.
+  forall n m p (q:nat), n <= m -> p <= q -> n * p <= m * q.
+Proof.
+  intros m n p q Hmn Hpq; induction Hmn.
+  induction Hpq.
+  (* m*p<=m*p *)
+  apply le_n.
+  (* m*p<=m*m0 -> m*p<=m*(S m0) *)
+  rewrite <- mult_n_Sm; apply le_trans with (m * m0).
+  assumption.
+  apply le_plus_l.
+  (* m*p<=m0*q -> m*p<=(S m0)*q *)
+  simpl in |- *; apply le_trans with (m0 * q).
+  assumption.
+  apply le_plus_r.
 Qed.
 
 Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p.
@@ -141,11 +154,12 @@ Qed.
 Hint Resolve mult_S_lt_compat_l: arith.
 
 Lemma mult_lt_compat_r : forall n m p, n < m -> 0 < p -> n * p < m * p.
-intros m n p H H0.
-induction p.
-elim (lt_irrefl _ H0).
-rewrite mult_comm.
-replace (n * S p) with (S p * n); auto with arith.
+Proof.
+  intros m n p H H0.
+  induction p.
+  elim (lt_irrefl _ H0).
+  rewrite mult_comm.
+  replace (n * S p) with (S p * n); auto with arith.
 Qed.
 
 Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p.
@@ -156,27 +170,28 @@ Proof.
   apply mult_S_lt_compat_l. assumption.
 Qed.
 
-(** n|->2*n and n|->2n+1 have disjoint image *)
+(** * n|->2*n and n|->2n+1 have disjoint image *)
 
 Theorem odd_even_lem : forall p q, 2 * p + 1 <> 2 * q.
-intros p; elim p; auto.
-intros q; case q; simpl in |- *.
-red in |- *; intros; discriminate.
-intros q'; rewrite (fun x y => plus_comm x (S y)); simpl in |- *; red in |- *;
- intros; discriminate.
-intros p' H q; case q.
-simpl in |- *; red in |- *; intros; discriminate.
-intros q'; red in |- *; intros H0; case (H q').
-replace (2 * q') with (2 * S q' - 2).
-rewrite <- H0; simpl in |- *; auto.
-repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; auto.
-simpl in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *;
- auto.
-case q'; simpl in |- *; auto.
+Proof.
+  intros p; elim p; auto.
+  intros q; case q; simpl in |- *.
+  red in |- *; intros; discriminate.
+  intros q'; rewrite (fun x y => plus_comm x (S y)); simpl in |- *; red in |- *;
+    intros; discriminate.
+  intros p' H q; case q.
+  simpl in |- *; red in |- *; intros; discriminate.
+  intros q'; red in |- *; intros H0; case (H q').
+  replace (2 * q') with (2 * S q' - 2).
+  rewrite <- H0; simpl in |- *; auto.
+  repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; auto.
+  simpl in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *;
+    auto.
+  case q'; simpl in |- *; auto.
 Qed.
 
 
-(** Tail-recursive mult *)
+(** * Tail-recursive mult *)
 
 (** [tail_mult] is an alternative definition for [mult] which is 
     tail-recursive, whereas [mult] is not. This can be useful 
@@ -184,23 +199,23 @@ Qed.
 
 Fixpoint mult_acc (s:nat) m n {struct n} : nat :=
   match n with
-  | O => s
-  | S p => mult_acc (tail_plus m s) m p
+    | O => s
+    | S p => mult_acc (tail_plus m s) m p
   end.
 
 Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n.
 Proof.
-induction n as [| p IHp]; simpl in |- *; auto.
-intros s m; rewrite <- plus_tail_plus; rewrite <- IHp.
-rewrite <- plus_assoc_reverse; apply (f_equal2 (A1:=nat) (A2:=nat)); auto.
-rewrite plus_comm; auto.
+  induction n as [| p IHp]; simpl in |- *; auto.
+  intros s m; rewrite <- plus_tail_plus; rewrite <- IHp.
+  rewrite <- plus_assoc_reverse; apply (f_equal2 (A1:=nat) (A2:=nat)); auto.
+  rewrite plus_comm; auto.
 Qed.
 
 Definition tail_mult n m := mult_acc 0 m n.
 
 Lemma mult_tail_mult : forall n m, n * m = tail_mult n m.
 Proof.
-intros; unfold tail_mult in |- *; rewrite <- mult_acc_aux; auto.
+  intros; unfold tail_mult in |- *; rewrite <- mult_acc_aux; auto.
 Qed.
 
 (** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] 
@@ -208,4 +223,4 @@ Qed.
 
 Ltac tail_simpl :=
   repeat rewrite <- plus_tail_plus; repeat rewrite <- mult_tail_mult;
-   simpl in |- *. 
\ No newline at end of file
+    simpl in |- *.
\ No newline at end of file
diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v
index 01204ee6..b17021bc 100755..100644
--- a/theories/Arith/Peano_dec.v
+++ b/theories/Arith/Peano_dec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Peano_dec.v,v 1.10.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Peano_dec.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Decidable.
 
@@ -16,19 +16,19 @@ Implicit Types m n x y : nat.
 
 Theorem O_or_S : forall n, {m : nat | S m = n} + {0 = n}.
 Proof.
-induction n.
-auto.
-left; exists n; auto.
+  induction n.
+  auto.
+  left; exists n; auto.
 Defined.
 
 Theorem eq_nat_dec : forall n m, {n = m} + {n <> m}.
 Proof.
-induction n; induction m; auto.
-elim (IHn m); auto.
+  induction n; induction m; auto.
+  elim (IHn m); auto.
 Defined.
 
 Hint Resolve O_or_S eq_nat_dec: arith.
 
 Theorem dec_eq_nat : forall n m, decidable (n = m).
-intros x y; unfold decidable in |- *; elim (eq_nat_dec x y); auto with arith.
+  intros x y; unfold decidable in |- *; elim (eq_nat_dec x y); auto with arith.
 Defined.
diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v
index e4ac631e..74d0dc93 100755..100644
--- a/theories/Arith/Plus.v
+++ b/theories/Arith/Plus.v
@@ -6,9 +6,18 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Plus.v,v 1.18.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+(*i $Id: Plus.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
-(** Properties of addition *)
+(** Properties of addition. [add] is defined in [Init/Peano.v] as:
+<<
+Fixpoint plus (n m:nat) {struct n} : nat :=
+  match n with
+  | O => m
+  | S p => S (p + m)
+  end
+where "n + m" := (plus n m) : nat_scope.
+>>
+ *)
 
 Require Import Le.
 Require Import Lt.
@@ -17,126 +26,127 @@ Open Local Scope nat_scope.
 
 Implicit Types m n p q : nat.
 
-(** Zero is neutral *)
+(** * Zero is neutral *)
 
 Lemma plus_0_l : forall n, 0 + n = n.
 Proof.
-reflexivity.
+  reflexivity.
 Qed.
 
 Lemma plus_0_r : forall n, n + 0 = n.
 Proof.
-intro; symmetry  in |- *; apply plus_n_O.
+  intro; symmetry  in |- *; apply plus_n_O.
 Qed.
 
-(** Commutativity *)
+(** * Commutativity *)
 
 Lemma plus_comm : forall n m, n + m = m + n.
 Proof.
-intros n m; elim n; simpl in |- *; auto with arith.
-intros y H; elim (plus_n_Sm m y); auto with arith.
+  intros n m; elim n; simpl in |- *; auto with arith.
+  intros y H; elim (plus_n_Sm m y); auto with arith.
 Qed.
 Hint Immediate plus_comm: arith v62.
 
-(** Associativity *)
+(** * Associativity *)
 
 Lemma plus_Snm_nSm : forall n m, S n + m = n + S m.
-intros.
-simpl in |- *.
-rewrite (plus_comm n m).
-rewrite (plus_comm n (S m)).
-trivial with arith.
+Proof.
+  intros.
+  simpl in |- *.
+  rewrite (plus_comm n m).
+  rewrite (plus_comm n (S m)).
+  trivial with arith.
 Qed.
 
 Lemma plus_assoc : forall n m p, n + (m + p) = n + m + p.
 Proof.
-intros n m p; elim n; simpl in |- *; auto with arith.
+  intros n m p; elim n; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve plus_assoc: arith v62.
 
 Lemma plus_permute : forall n m p, n + (m + p) = m + (n + p).
 Proof. 
-intros; rewrite (plus_assoc m n p); rewrite (plus_comm m n); auto with arith.
+  intros; rewrite (plus_assoc m n p); rewrite (plus_comm m n); auto with arith.
 Qed.
 
 Lemma plus_assoc_reverse : forall n m p, n + m + p = n + (m + p).
 Proof.
-auto with arith.
+  auto with arith.
 Qed.
 Hint Resolve plus_assoc_reverse: arith v62.
 
-(** Simplification *)
+(** * Simplification *)
 
 Lemma plus_reg_l : forall n m p, p + n = p + m -> n = m.
 Proof.
-intros m p n; induction n; simpl in |- *; auto with arith.
+  intros m p n; induction n; simpl in |- *; auto with arith.
 Qed.
 
 Lemma plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
 Proof.
-induction p; simpl in |- *; auto with arith.
+  induction p; simpl in |- *; auto with arith.
 Qed.
 
 Lemma plus_lt_reg_l : forall n m p, p + n < p + m -> n < m.
 Proof.
-induction p; simpl in |- *; auto with arith.
+  induction p; simpl in |- *; auto with arith.
 Qed.
 
-(** Compatibility with order *)
+(** * Compatibility with order *)
 
 Lemma plus_le_compat_l : forall n m p, n <= m -> p + n <= p + m.
 Proof.
-induction p; simpl in |- *; auto with arith.
+  induction p; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve plus_le_compat_l: arith v62.
 
 Lemma plus_le_compat_r : forall n m p, n <= m -> n + p <= m + p.
 Proof.
-induction 1; simpl in |- *; auto with arith.
+  induction 1; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve plus_le_compat_r: arith v62.
 
 Lemma le_plus_l : forall n m, n <= n + m.
 Proof.
-induction n; simpl in |- *; auto with arith.
+  induction n; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve le_plus_l: arith v62.
 
 Lemma le_plus_r : forall n m, m <= n + m.
 Proof.
-intros n m; elim n; simpl in |- *; auto with arith.
+  intros n m; elim n; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve le_plus_r: arith v62.
 
 Theorem le_plus_trans : forall n m p, n <= m -> n <= m + p.
 Proof.
-intros; apply le_trans with (m := m); auto with arith.
+  intros; apply le_trans with (m := m); auto with arith.
 Qed.
 Hint Resolve le_plus_trans: arith v62.
 
 Theorem lt_plus_trans : forall n m p, n < m -> n < m + p.
 Proof.
-intros; apply lt_le_trans with (m := m); auto with arith.
+  intros; apply lt_le_trans with (m := m); auto with arith.
 Qed.
 Hint Immediate lt_plus_trans: arith v62.
 
 Lemma plus_lt_compat_l : forall n m p, n < m -> p + n < p + m.
 Proof.
-induction p; simpl in |- *; auto with arith.
+  induction p; simpl in |- *; auto with arith.
 Qed.
 Hint Resolve plus_lt_compat_l: arith v62.
 
 Lemma plus_lt_compat_r : forall n m p, n < m -> n + p < m + p.
 Proof.
-intros n m p H; rewrite (plus_comm n p); rewrite (plus_comm m p).
-elim p; auto with arith.
+  intros n m p H; rewrite (plus_comm n p); rewrite (plus_comm m p).
+  elim p; auto with arith.
 Qed.
 Hint Resolve plus_lt_compat_r: arith v62.
 
 Lemma plus_le_compat : forall n m p q, n <= m -> p <= q -> n + p <= m + q.
 Proof.
-intros n m p q H H0.
-elim H; simpl in |- *; auto with arith.
+  intros n m p q H H0.
+  elim H; simpl in |- *; auto with arith.
 Qed.
 
 Lemma plus_le_lt_compat : forall n m p q, n <= m -> p < q -> n + p < m + q.
@@ -156,7 +166,7 @@ Proof.
   apply lt_le_weak. assumption.
 Qed.
 
-(** Inversion lemmas *)
+(** * Inversion lemmas *)
 
 Lemma plus_is_O : forall n m, n + m = 0 -> n = 0 /\ m = 0.
 Proof.
@@ -173,7 +183,7 @@ Proof.
   simpl in H. discriminate H.
 Defined.
 
-(** Derived properties *)
+(** * Derived properties *)
 
 Lemma plus_permute_2_in_4 : forall n m p q, n + m + (p + q) = n + p + (m + q).
 Proof.
@@ -182,7 +192,7 @@ Proof.
   rewrite (plus_comm n p). rewrite <- (plus_assoc p n q). apply plus_assoc.
 Qed.
 
-(** Tail-recursive plus *)
+(** * Tail-recursive plus *)
 
 (** [tail_plus] is an alternative definition for [plus] which is 
     tail-recursive, whereas [plus] is not. This can be useful
@@ -190,8 +200,8 @@ Qed.
 
 Fixpoint plus_acc q n {struct n} : nat :=
   match n with
-  | O => q
-  | S p => plus_acc (S q) p
+    | O => q
+    | S p => plus_acc (S q) p
   end.
 
 Definition tail_plus n m := plus_acc m n.
@@ -199,4 +209,29 @@ Definition tail_plus n m := plus_acc m n.
 Lemma plus_tail_plus : forall n m, n + m = tail_plus n m.
 unfold tail_plus in |- *; induction n as [| n IHn]; simpl in |- *; auto.
 intro m; rewrite <- IHn; simpl in |- *; auto.
-Qed.
\ No newline at end of file
+Qed.
+
+(** * Discrimination *)
+
+Lemma succ_plus_discr : forall n m, n <> S (plus m n).
+Proof.
+  intros n m; induction n as [|n IHn].
+  discriminate.
+  intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm; 
+    reflexivity.
+Qed.
+
+Lemma n_SSn : forall n, n <> S (S n).
+Proof.
+  intro n; exact (succ_plus_discr n 1).
+Qed.
+
+Lemma n_SSSn : forall n, n <> S (S (S n)).
+Proof.
+  intro n; exact (succ_plus_discr n 2).
+Qed.
+
+Lemma n_SSSSn : forall n, n <> S (S (S (S n))).
+Proof.
+  intro n; exact (succ_plus_discr n 3).
+Qed.
diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v
index 8bf237b5..11fcd161 100755..100644
--- a/theories/Arith/Wf_nat.v
+++ b/theories/Arith/Wf_nat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wf_nat.v,v 1.16.2.1 2004/07/16 19:31:01 herbelin Exp $ i*)
+(*i $Id: Wf_nat.v 9341 2006-11-06 13:08:10Z notin $ i*)
 
 (** Well-founded relations and natural numbers *)
 
@@ -18,7 +18,7 @@ Implicit Types m n p : nat.
 
 Section Well_founded_Nat.
 
-Variable A : Set.
+Variable A : Type.
 
 Variable f : A -> nat.
 Definition ltof (a b:A) := f a < f b.
@@ -26,72 +26,77 @@ Definition gtof (a b:A) := f b > f a.
 
 Theorem well_founded_ltof : well_founded ltof.
 Proof.
-red in |- *.
-cut (forall n (a:A), f a < n -> Acc ltof a).
-intros H a; apply (H (S (f a))); auto with arith.
-induction n.
-intros; absurd (f a < 0); auto with arith.
-intros a ltSma.
-apply Acc_intro.
-unfold ltof in |- *; intros b ltfafb.
-apply IHn.
-apply lt_le_trans with (f a); auto with arith.
-Qed.
+  red in |- *.
+  cut (forall n (a:A), f a < n -> Acc ltof a).
+  intros H a; apply (H (S (f a))); auto with arith.
+  induction n.
+  intros; absurd (f a < 0); auto with arith.
+  intros a ltSma.
+  apply Acc_intro.
+  unfold ltof in |- *; intros b ltfafb.
+  apply IHn.
+  apply lt_le_trans with (f a); auto with arith.
+Defined.
 
 Theorem well_founded_gtof : well_founded gtof.
-Proof well_founded_ltof.
+Proof.
+  exact well_founded_ltof.
+Defined.
 
 (** It is possible to directly prove the induction principle going
    back to primitive recursion on natural numbers ([induction_ltof1])
    or to use the previous lemmas to extract a program with a fixpoint
    ([induction_ltof2]) 
 
-the ML-like program for [induction_ltof1] is : [[
+the ML-like program for [induction_ltof1] is : 
+[[
    let induction_ltof1 F a = indrec ((f a)+1) a 
    where rec indrec = 
         function 0    -> (function a -> error)
                |(S m) -> (function a -> (F a (function y -> indrec y m)));;
 ]]
 
-the ML-like program for [induction_ltof2] is : [[
+the ML-like program for [induction_ltof2] is : 
+[[
    let induction_ltof2 F a = indrec a
    where rec indrec a = F a indrec;;
-]] *)
+]]
+*)
 
 Theorem induction_ltof1 :
- forall P:A -> Set,
-   (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
+  forall P:A -> Set,
+    (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
 Proof.
-intros P F; cut (forall n (a:A), f a < n -> P a).
-intros H a; apply (H (S (f a))); auto with arith.
-induction n.
-intros; absurd (f a < 0); auto with arith.
-intros a ltSma.
-apply F.
-unfold ltof in |- *; intros b ltfafb.
-apply IHn.
-apply lt_le_trans with (f a); auto with arith.
+  intros P F; cut (forall n (a:A), f a < n -> P a).
+  intros H a; apply (H (S (f a))); auto with arith.
+  induction n.
+  intros; absurd (f a < 0); auto with arith.
+  intros a ltSma.
+  apply F.
+  unfold ltof in |- *; intros b ltfafb.
+  apply IHn.
+  apply lt_le_trans with (f a); auto with arith.
 Defined. 
 
 Theorem induction_gtof1 :
- forall P:A -> Set,
-   (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a.
+  forall P:A -> Set,
+    (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a.
 Proof.
-exact induction_ltof1.
+  exact induction_ltof1.
 Defined.
 
 Theorem induction_ltof2 :
- forall P:A -> Set,
-   (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
+  forall P:A -> Set,
+    (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
 Proof.
-exact (well_founded_induction well_founded_ltof).
+  exact (well_founded_induction well_founded_ltof).
 Defined.
 
 Theorem induction_gtof2 :
- forall P:A -> Set,
-   (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a.
+  forall P:A -> Set,
+    (forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a.
 Proof.
-exact induction_ltof2.
+  exact induction_ltof2.
 Defined.
 
 (** If a relation [R] is compatible with [lt] i.e. if [x R y => f(x) < f(y)]
@@ -103,104 +108,105 @@ Hypothesis H_compat : forall x y:A, R x y -> f x < f y.
 
 Theorem well_founded_lt_compat : well_founded R.
 Proof.
-red in |- *.
-cut (forall n (a:A), f a < n -> Acc R a).
-intros H a; apply (H (S (f a))); auto with arith.
-induction n.
-intros; absurd (f a < 0); auto with arith.
-intros a ltSma.
-apply Acc_intro.
-intros b ltfafb.
-apply IHn.
-apply lt_le_trans with (f a); auto with arith.
-Qed.
+  red in |- *.
+  cut (forall n (a:A), f a < n -> Acc R a).
+  intros H a; apply (H (S (f a))); auto with arith.
+  induction n.
+  intros; absurd (f a < 0); auto with arith.
+  intros a ltSma.
+  apply Acc_intro.
+  intros b ltfafb.
+  apply IHn.
+  apply lt_le_trans with (f a); auto with arith.
+Defined.
 
 End Well_founded_Nat.
 
 Lemma lt_wf : well_founded lt.
-Proof well_founded_ltof nat (fun m => m).
+Proof.
+  exact (well_founded_ltof nat (fun m => m)).
+Defined.
 
 Lemma lt_wf_rec1 :
- forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
+  forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
 Proof.
-exact
- (fun p (P:nat -> Set) (F:forall n, (forall m, m < n -> P m) -> P n) =>
-    induction_ltof1 nat (fun m => m) P F p).
+  exact (fun p P F => induction_ltof1 nat (fun m => m) P F p).
 Defined.
 
 Lemma lt_wf_rec :
- forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
+  forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
 Proof.
-exact
- (fun p (P:nat -> Set) (F:forall n, (forall m, m < n -> P m) -> P n) =>
-    induction_ltof2 nat (fun m => m) P F p).
+  exact (fun p P F => induction_ltof2 nat (fun m => m) P F p).
 Defined.
 
 Lemma lt_wf_ind :
- forall n (P:nat -> Prop), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
-intro p; intros; elim (lt_wf p); auto with arith.
+  forall n (P:nat -> Prop), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
+Proof.
+  intro p; intros; elim (lt_wf p); auto with arith.
 Qed.
 
 Lemma gt_wf_rec :
- forall n (P:nat -> Set), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
+  forall n (P:nat -> Set), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
 Proof.
-exact lt_wf_rec.
+  exact lt_wf_rec.
 Defined.
 
 Lemma gt_wf_ind :
- forall n (P:nat -> Prop), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
+  forall n (P:nat -> Prop), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
 Proof lt_wf_ind.
 
 Lemma lt_wf_double_rec :
  forall P:nat -> nat -> Set,
    (forall n m,
-      (forall p (q:nat), p < n -> P p q) ->
-      (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
-intros P Hrec p; pattern p in |- *; apply lt_wf_rec.
-intros n H q; pattern q in |- *; apply lt_wf_rec; auto with arith.
+     (forall p q, p < n -> P p q) ->
+     (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
+Proof.
+  intros P Hrec p; pattern p in |- *; apply lt_wf_rec.
+  intros n H q; pattern q in |- *; apply lt_wf_rec; auto with arith.
 Defined.
 
 Lemma lt_wf_double_ind :
- forall P:nat -> nat -> Prop,
-   (forall n m,
+  forall P:nat -> nat -> Prop,
+    (forall n m,
       (forall p (q:nat), p < n -> P p q) ->
       (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
-intros P Hrec p; pattern p in |- *; apply lt_wf_ind.
-intros n H q; pattern q in |- *; apply lt_wf_ind; auto with arith.
+Proof.
+  intros P Hrec p; pattern p in |- *; apply lt_wf_ind.
+  intros n H q; pattern q in |- *; apply lt_wf_ind; auto with arith.
 Qed.
 
 Hint Resolve lt_wf: arith.
 Hint Resolve well_founded_lt_compat: arith.
 
 Section LT_WF_REL.
-Variable A : Set.
-Variable R : A -> A -> Prop.
-
-(* Relational form of inversion *)
-Variable F : A -> nat -> Prop.
-Definition inv_lt_rel x y :=
-   exists2 n : _, F x n & (forall m, F y m -> n < m).
-
-Hypothesis F_compat : forall x y:A, R x y -> inv_lt_rel x y.
-Remark acc_lt_rel : forall x:A, (exists n : _, F x n) -> Acc R x.
-intros x [n fxn]; generalize x fxn; clear x fxn.
-pattern n in |- *; apply lt_wf_ind; intros.
-constructor; intros.
-case (F_compat y x); trivial; intros.
-apply (H x0); auto.
-Qed.
-
-Theorem well_founded_inv_lt_rel_compat : well_founded R.
-constructor; intros.
-case (F_compat y a); trivial; intros.
-apply acc_lt_rel; trivial.
-exists x; trivial.
-Qed.
-
+  Variable A : Set.
+  Variable R : A -> A -> Prop.
+
+  (* Relational form of inversion *)
+  Variable F : A -> nat -> Prop.
+  Definition inv_lt_rel x y := exists2 n, F x n & (forall m, F y m -> n < m).
+
+  Hypothesis F_compat : forall x y:A, R x y -> inv_lt_rel x y.
+  Remark acc_lt_rel : forall x:A, (exists n, F x n) -> Acc R x.
+  Proof.
+    intros x [n fxn]; generalize dependent x.
+    pattern n in |- *; apply lt_wf_ind; intros.
+    constructor; intros.
+    destruct (F_compat y x) as (x0,H1,H2); trivial.
+    apply (H x0); auto.
+  Qed.
+
+  Theorem well_founded_inv_lt_rel_compat : well_founded R.
+  Proof.
+    constructor; intros.
+    case (F_compat y a); trivial; intros.
+    apply acc_lt_rel; trivial.
+    exists x; trivial.
+  Qed.
 
 End LT_WF_REL.
 
 Lemma well_founded_inv_rel_inv_lt_rel :
- forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F).
-intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial.
-Qed.
\ No newline at end of file
+  forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F).
+  intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial.
+Qed.
diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v
index 854eb9e3..e126ad35 100755..100644
--- a/theories/Bool/Bool.v
+++ b/theories/Bool/Bool.v
@@ -6,149 +6,135 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Bool.v,v 1.29.2.1 2004/07/16 19:31:01 herbelin Exp $ i*)
-
-(** Booleans  *)
+(*i $Id: Bool.v 9246 2006-10-17 14:01:18Z herbelin $ i*)
 
 (** The type [bool] is defined in the prelude as
     [Inductive bool : Set := true : bool | false : bool] *)
 
-(** Interpretation of booleans as Proposition *)
+(** Interpretation of booleans as propositions *)
 Definition Is_true (b:bool) :=
   match b with
-  | true => True
-  | false => False
+    | true => True
+    | false => False
   end.
-Hint Unfold Is_true: bool.
 
-Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x.
-Proof.
-  intros; rewrite H; auto with bool.
-Qed.
+(*******************)
+(** * Decidability *)
+(*******************)
 
-Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x.
+Lemma bool_dec : forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}.
 Proof.
-  intros; rewrite <- H; auto with bool.
-Qed.
+  decide equality.
+Defined.
 
-Hint Immediate Is_true_eq_right Is_true_eq_left: bool.
-
-(*******************)
-(** Discrimination *)
-(*******************)
+(*********************)
+(** * Discrimination *)
+(*********************)
 
 Lemma diff_true_false : true <> false.
 Proof.
-unfold not in |- *; intro contr; change (Is_true false) in |- *.
-elim contr; simpl in |- *; trivial with bool.
+  unfold not in |- *; intro contr; change (Is_true false) in |- *.
+  elim contr; simpl in |- *; trivial.
 Qed.
-Hint Resolve diff_true_false: bool v62.
+Hint Resolve diff_true_false : bool v62.
 
 Lemma diff_false_true : false <> true.
-Proof.
-red in |- *; intros H; apply diff_true_false.
-symmetry  in |- *.
+Proof. 
+  red in |- *; intros H; apply diff_true_false.
+  symmetry  in |- *.
 assumption.
 Qed.
-Hint Resolve diff_false_true: bool v62.
+Hint Resolve diff_false_true : bool v62.
+Hint Extern 1 (false <> true) => exact diff_false_true.
 
 Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False.
-intros b H; rewrite H; auto with bool.
+Proof.
+  intros b H; rewrite H; auto with bool.
 Qed.
-Hint Resolve eq_true_false_abs: bool.
 
 Lemma not_true_is_false : forall b:bool, b <> true -> b = false.
-destruct b.
-intros.
-red in H; elim H.
-reflexivity.
-intros abs.
-reflexivity.
+Proof.
+  destruct b.
+  intros.
+  red in H; elim H.
+  reflexivity.
+  intros abs.
+  reflexivity.
 Qed.
 
 Lemma not_false_is_true : forall b:bool, b <> false -> b = true.
-destruct b.
-intros.
-reflexivity.
-intro H; red in H; elim H.
-reflexivity.
+Proof.
+  destruct b.
+  intros.
+  reflexivity.
+  intro H; red in H; elim H.
+  reflexivity.
 Qed.
 
 (**********************)
-(** Order on booleans *)
+(** * Order on booleans *)
 (**********************)
 
 Definition leb (b1 b2:bool) :=
   match b1 with
-  | true => b2 = true
-  | false => True
+    | true => b2 = true
+    | false => True
   end.
 Hint Unfold leb: bool v62.
 
+(* Infix "<=" := leb : bool_scope. *)
+
 (*************)
-(** Equality *)
+(** * Equality *)
 (*************)
 
 Definition eqb (b1 b2:bool) : bool :=
   match b1, b2 with
-  | true, true => true
-  | true, false => false
-  | false, true => false
-  | false, false => true
+    | true, true => true
+    | true, false => false
+    | false, true => false
+    | false, false => true
   end.
 
-Lemma eqb_refl : forall x:bool, Is_true (eqb x x).
-destruct x; simpl in |- *; auto with bool.
-Qed.
-
-Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y.
-destruct x; destruct y; simpl in |- *; tauto.
-Qed.
-
-Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true.
-destruct x; simpl in |- *; tauto.
-Qed.
- 
-Lemma Is_true_eq_true2 : forall x:bool, x = true -> Is_true x.
-destruct x; simpl in |- *; auto with bool.
-Qed.
-
 Lemma eqb_subst :
- forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2.
-unfold eqb in |- *.
-intros P b1.
-intros b2.
-case b1.
-case b2.
-trivial with bool.
-intros H.
-inversion_clear H.
-case b2.
-intros H.
-inversion_clear H.
-trivial with bool.
+  forall (P:bool -> Prop) (b1 b2:bool), eqb b1 b2 = true -> P b1 -> P b2.
+Proof.
+  unfold eqb in |- *.
+  intros P b1.
+  intros b2.
+  case b1.
+  case b2.
+  trivial with bool.
+  intros H.
+  inversion_clear H.
+  case b2.
+  intros H.
+  inversion_clear H.
+  trivial with bool.
 Qed.
 
 Lemma eqb_reflx : forall b:bool, eqb b b = true.
-intro b.
-case b.
-trivial with bool.
-trivial with bool.
+Proof.
+  intro b.
+  case b.
+  trivial with bool.
+  trivial with bool.
 Qed.
 
 Lemma eqb_prop : forall a b:bool, eqb a b = true -> a = b.
-destruct a; destruct b; simpl in |- *; intro; discriminate H || reflexivity.
+Proof.
+  destruct a; destruct b; simpl in |- *; intro; discriminate H || reflexivity.
 Qed.
 
 
 (************************)
-(** Logical combinators *)
+(** * Logical combinators *)
 (************************)
  
 Definition ifb (b1 b2 b3:bool) : bool :=
   match b1 with
-  | true => b2
-  | false => b3
+    | true => b2
+    | false => b3
   end.
 
 Definition andb (b1 b2:bool) : bool := ifb b1 b2 false.
@@ -159,16 +145,13 @@ Definition implb (b1 b2:bool) : bool := ifb b1 b2 true.
 
 Definition xorb (b1 b2:bool) : bool :=
   match b1, b2 with
-  | true, true => false
-  | true, false => true
-  | false, true => true
-  | false, false => false
+    | true, true => false
+    | true, false => true
+    | false, true => true
+    | false, false => false
   end.
 
-Definition negb (b:bool) := match b with
-                            | true => false
-                            | false => true
-                            end.
+Definition negb (b:bool) := if b then false else true.
 
 Infix "||" := orb (at level 50, left associativity) : bool_scope.
 Infix "&&" := andb (at level 40, left associativity) : bool_scope.
@@ -179,119 +162,139 @@ Delimit Scope bool_scope with bool.
 
 Bind Scope bool_scope with bool.
 
-(**************************)
-(** Lemmas about [negb]   *)
-(**************************)
+(****************************)
+(** * De Morgan laws          *)
+(****************************)
 
-Lemma negb_intro : forall b:bool, b = negb (negb b).
+Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2.
 Proof.
-destruct b; reflexivity.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
 Qed.
 
-Lemma negb_elim : forall b:bool, negb (negb b) = b.
+Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2.
 Proof.
-destruct b; reflexivity.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
 Qed.
-       
-Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2.
+
+(********************************)
+(** * Properties of [negb]    *)
+(********************************)
+
+Lemma negb_involutive : forall b:bool, negb (negb b) = b.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; reflexivity.
+  destruct b; reflexivity.
 Qed.
 
-Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2.
+Lemma negb_involutive_reverse : forall b:bool, b = negb (negb b).
 Proof.
-  destruct b1; destruct b2; simpl in |- *; reflexivity.
+  destruct b; reflexivity.
 Qed.
 
+Notation negb_elim := negb_involutive (only parsing).
+Notation negb_intro := negb_involutive_reverse (only parsing).
+
 Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'.
 Proof.
-destruct b; destruct b'; intros; simpl in |- *; trivial with bool.
+  destruct b; destruct b'; intros; simpl in |- *; trivial with bool.
 Qed.
 
 Lemma no_fixpoint_negb : forall b:bool, negb b <> b.
 Proof.
-destruct b; simpl in |- *; intro; apply diff_true_false;
- auto with bool.
+  destruct b; simpl in |- *; intro; apply diff_true_false;
+    auto with bool.
 Qed.
 
 Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false.
-destruct b.
-trivial with bool.
-trivial with bool.
+Proof.
+  destruct b.
+  trivial with bool.
+  trivial with bool.
 Qed.
  
 Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false.
-destruct b.
-trivial with bool.
-trivial with bool.
+Proof.
+  destruct b.
+  trivial with bool.
+  trivial with bool.
 Qed.
 
 
 Lemma if_negb :
- forall (A:Set) (b:bool) (x y:A),
-   (if negb b then x else y) = (if b then y else x).
+  forall (A:Set) (b:bool) (x y:A),
+    (if negb b then x else y) = (if b then y else x).
 Proof.
   destruct b; trivial.
 Qed.
 
 
-(****************************)
-(** A few lemmas about [or] *)
-(****************************)
+(********************************)
+(** * Properties of [orb]     *)
+(********************************)
 
-Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true.
-destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
- auto with bool.
-Qed.
+Lemma orb_true_elim :
+  forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}.
+Proof.
+  destruct b1; simpl in |- *; auto with bool.
+Defined.
 
-Lemma orb_prop2 : forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b.
-destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
- auto with bool.
+Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true.
+Proof.
+  destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
+    auto with bool.
 Qed.
 
 Lemma orb_true_intro :
- forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true.
-destruct b1; auto with bool.
-destruct 1; intros.
-elim diff_true_false; auto with bool.
-rewrite H; trivial with bool.
+  forall b1 b2:bool, b1 = true \/ b2 = true -> b1 || b2 = true.
+Proof.
+  destruct b1; auto with bool.
+  destruct 1; intros.
+  elim diff_true_false; auto with bool.
+  rewrite H; trivial with bool.
 Qed.
 Hint Resolve orb_true_intro: bool v62.
 
-Lemma orb_b_true : forall b:bool, b || true = true.
-auto with bool.
+Lemma orb_false_intro :
+  forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false.
+Proof.
+  intros b1 b2 H1 H2; rewrite H1; rewrite H2; trivial with bool.
 Qed.
-Hint Resolve orb_b_true: bool v62.
+Hint Resolve orb_false_intro: bool v62.
 
-Lemma orb_true_b : forall b:bool, true || b = true.
-trivial with bool.
-Qed.
+(** [true] is a zero for [orb] *)
 
-Definition orb_true_elim :
-  forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}.
-destruct b1; simpl in |- *; auto with bool.
-Defined.
+Lemma orb_true_r : forall b:bool, b || true = true.
+Proof.
+  auto with bool.
+Qed.
+Hint Resolve orb_true_r: bool v62.
 
-Lemma orb_false_intro :
- forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false.
-intros b1 b2 H1 H2; rewrite H1; rewrite H2; trivial with bool.
+Lemma orb_true_l : forall b:bool, true || b = true.
+Proof.
+  trivial with bool.
 Qed.
-Hint Resolve orb_false_intro: bool v62.
 
-Lemma orb_b_false : forall b:bool, b || false = b.
+Notation orb_b_true := orb_true_r (only parsing).
+Notation orb_true_b := orb_true_l (only parsing).
+
+(** [false] is neutral for [orb] *)
+
+Lemma orb_false_r : forall b:bool, b || false = b.
 Proof.
   destruct b; trivial with bool.
 Qed.
-Hint Resolve orb_b_false: bool v62.
+Hint Resolve orb_false_r: bool v62.
 
-Lemma orb_false_b : forall b:bool, false || b = b.
+Lemma orb_false_l : forall b:bool, false || b = b.
 Proof.
   destruct b; trivial with bool.
 Qed.
-Hint Resolve orb_false_b: bool v62.
+Hint Resolve orb_false_l: bool v62.
+
+Notation orb_b_false := orb_false_r (only parsing).
+Notation orb_false_b := orb_false_l (only parsing).
 
 Lemma orb_false_elim :
- forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false.
+  forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false.
 Proof.
   destruct b1.
   intros; elim diff_true_false; auto with bool.
@@ -300,148 +303,234 @@ Proof.
   auto with bool.
 Qed.
 
-Lemma orb_neg_b : forall b:bool, b || negb b = true.
+(** Complementation *)
+
+Lemma orb_negb_r : forall b:bool, b || negb b = true.
 Proof.
   destruct b; reflexivity.
 Qed.
-Hint Resolve orb_neg_b: bool v62.
+Hint Resolve orb_negb_r: bool v62.
+
+Notation orb_neg_b := orb_negb_r (only parsing).
+
+(** Commutativity *)
 
 Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1.
-destruct b1; destruct b2; reflexivity.
+Proof.
+  destruct b1; destruct b2; reflexivity.
 Qed.
 
+(** Associativity *)
+
 Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3.
 Proof.
   destruct b1; destruct b2; destruct b3; reflexivity.
 Qed.
+Hint Resolve orb_comm orb_assoc: bool v62.
 
-Hint Resolve orb_comm orb_assoc orb_b_false orb_false_b: bool v62.
-
-(*****************************)
-(** A few lemmas about [and] *)
-(*****************************)
+(*******************************)
+(** * Properties of [andb]     *)
+(*******************************)
 
 Lemma andb_prop : forall a b:bool, a && b = true -> a = true /\ b = true.
-
 Proof.
   destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
-   auto with bool.
+    auto with bool.
 Qed.
 Hint Resolve andb_prop: bool v62.
 
-Definition andb_true_eq :
+Lemma andb_true_eq :
   forall a b:bool, true = a && b -> true = a /\ true = b.
 Proof.
   destruct a; destruct b; auto.
 Defined.
 
-Lemma andb_prop2 :
- forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b.
-Proof.
-  destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
-   auto with bool.
-Qed.
-Hint Resolve andb_prop2: bool v62.
-
 Lemma andb_true_intro :
- forall b1 b2:bool, b1 = true /\ b2 = true -> b1 && b2 = true.
+  forall b1 b2:bool, b1 = true /\ b2 = true -> b1 && b2 = true.
 Proof.
   destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
 Qed.
 Hint Resolve andb_true_intro: bool v62.
 
-Lemma andb_true_intro2 :
- forall b1 b2:bool, Is_true b1 -> Is_true b2 -> Is_true (b1 && b2).
-Proof.
-  destruct b1; destruct b2; simpl in |- *; tauto.
-Qed.
-Hint Resolve andb_true_intro2: bool v62.
-
 Lemma andb_false_intro1 : forall b1 b2:bool, b1 = false -> b1 && b2 = false.
-destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
 Qed.
 
 Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false.
-destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
 Qed.
 
-Lemma andb_b_false : forall b:bool, b && false = false.
-destruct b; auto with bool.
+(** [false] is a zero for [andb] *)
+
+Lemma andb_false_r : forall b:bool, b && false = false.
+Proof.
+  destruct b; auto with bool.
 Qed.
 
-Lemma andb_false_b : forall b:bool, false && b = false.
-trivial with bool.
+Lemma andb_false_l : forall b:bool, false && b = false.
+Proof.
+  trivial with bool.
 Qed.
 
-Lemma andb_b_true : forall b:bool, b && true = b.
-destruct b; auto with bool.
+Notation andb_b_false := andb_false_r (only parsing).
+Notation andb_false_b := andb_false_l (only parsing).
+
+(** [true] is neutral for [andb] *)
+
+Lemma andb_true_r : forall b:bool, b && true = b.
+Proof.
+  destruct b; auto with bool.
 Qed.
 
-Lemma andb_true_b : forall b:bool, true && b = b.
-trivial with bool.
+Lemma andb_true_l : forall b:bool, true && b = b.
+Proof.
+  trivial with bool.
 Qed.
 
-Definition andb_false_elim :
+Notation andb_b_true := andb_true_r (only parsing).
+Notation andb_true_b := andb_true_l (only parsing).
+
+Lemma andb_false_elim :
   forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}.
-destruct b1; simpl in |- *; auto with bool.
+Proof.
+  destruct b1; simpl in |- *; auto with bool.
 Defined.
 Hint Resolve andb_false_elim: bool v62.
 
-Lemma andb_neg_b : forall b:bool, b && negb b = false.
-destruct b; reflexivity.
+(** Complementation *)
+
+Lemma andb_negb_r : forall b:bool, b && negb b = false.
+Proof.
+  destruct b; reflexivity.
 Qed.   
-Hint Resolve andb_neg_b: bool v62.
+Hint Resolve andb_negb_r: bool v62.
+
+Notation andb_neg_b := andb_negb_r (only parsing).
+
+(** Commutativity *)
 
 Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1.
-destruct b1; destruct b2; reflexivity.
+Proof.
+  destruct b1; destruct b2; reflexivity.
 Qed.
 
+(** Associativity *)
+
 Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3.
-destruct b1; destruct b2; destruct b3; reflexivity.
+Proof.
+  destruct b1; destruct b2; destruct b3; reflexivity.
 Qed.
 
 Hint Resolve andb_comm andb_assoc: bool v62.
 
-(*******************************)
-(** Properties of [xorb]       *)
-(*******************************)
+(*******************************************)
+(** * Properties mixing [andb] and [orb] *)
+(*******************************************)
+
+(** Distributivity *)
+
+Lemma andb_orb_distrib_r :
+  forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3.
+Proof.
+  destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma andb_orb_distrib_l :
+ forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3.
+Proof.
+  destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma orb_andb_distrib_r :
+  forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3).
+Proof.
+  destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma orb_andb_distrib_l :
+  forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3).
+Proof.
+  destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+(* Compatibility *)
+Notation demorgan1 := andb_orb_distrib_r (only parsing).
+Notation demorgan2 := andb_orb_distrib_l (only parsing).
+Notation demorgan3 := orb_andb_distrib_r (only parsing).
+Notation demorgan4 := orb_andb_distrib_l (only parsing).
+
+(** Absorption *)
+
+Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
+Qed.
+
+Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
+Qed.
+
+(*********************************)
+(** * Properties of [xorb]       *)
+(*********************************)
 
-Lemma xorb_false : forall b:bool, xorb b false = b.
+(** [false] is neutral for [xorb] *)
+
+Lemma xorb_false_r : forall b:bool, xorb b false = b.
 Proof.
   destruct b; trivial.
 Qed.
 
-Lemma false_xorb : forall b:bool, xorb false b = b.
+Lemma xorb_false_l : forall b:bool, xorb false b = b.
 Proof.
   destruct b; trivial.
 Qed.
 
-Lemma xorb_true : forall b:bool, xorb b true = negb b.
+Notation xorb_false := xorb_false_r (only parsing).
+Notation false_xorb := xorb_false_l (only parsing).
+
+(** [true] is "complementing" for [xorb] *)
+
+Lemma xorb_true_r : forall b:bool, xorb b true = negb b.
 Proof.
   trivial.
 Qed.
 
-Lemma true_xorb : forall b:bool, xorb true b = negb b.
+Lemma xorb_true_l : forall b:bool, xorb true b = negb b.
 Proof.
   destruct b; trivial.
 Qed.
 
+Notation xorb_true := xorb_true_r (only parsing).
+Notation true_xorb := xorb_true_l (only parsing).
+
+(** Nilpotency (alternatively: identity is a inverse for [xorb]) *)
+
 Lemma xorb_nilpotent : forall b:bool, xorb b b = false.
 Proof.
   destruct b; trivial.
 Qed.
 
+(** Commutativity *)
+
 Lemma xorb_comm : forall b b':bool, xorb b b' = xorb b' b.
 Proof.
   destruct b; destruct b'; trivial.
 Qed.
 
-Lemma xorb_assoc :
- forall b b' b'':bool, xorb (xorb b b') b'' = xorb b (xorb b' b'').
+(** Associativity *)
+
+Lemma xorb_assoc_reverse :
+  forall b b' b'':bool, xorb (xorb b b') b'' = xorb b (xorb b' b'').
 Proof.
   destruct b; destruct b'; destruct b''; trivial.
 Qed.
 
+Notation xorb_assoc := xorb_assoc_reverse (only parsing). (* Compatibility *)
+
 Lemma xorb_eq : forall b b':bool, xorb b b' = false -> b = b'.
 Proof.
   destruct b; destruct b'; trivial.
@@ -449,95 +538,180 @@ Proof.
 Qed.
 
 Lemma xorb_move_l_r_1 :
- forall b b' b'':bool, xorb b b' = b'' -> b' = xorb b b''.
+  forall b b' b'':bool, xorb b b' = b'' -> b' = xorb b b''.
 Proof.
   intros. rewrite <- (false_xorb b'). rewrite <- (xorb_nilpotent b). rewrite xorb_assoc.
   rewrite H. reflexivity.
 Qed.
 
 Lemma xorb_move_l_r_2 :
- forall b b' b'':bool, xorb b b' = b'' -> b = xorb b'' b'.
+  forall b b' b'':bool, xorb b b' = b'' -> b = xorb b'' b'.
 Proof.
   intros. rewrite xorb_comm in H. rewrite (xorb_move_l_r_1 b' b b'' H). apply xorb_comm.
 Qed.
 
 Lemma xorb_move_r_l_1 :
- forall b b' b'':bool, b = xorb b' b'' -> xorb b' b = b''.
+  forall b b' b'':bool, b = xorb b' b'' -> xorb b' b = b''.
 Proof.
   intros. rewrite H. rewrite <- xorb_assoc. rewrite xorb_nilpotent. apply false_xorb.
 Qed.
 
 Lemma xorb_move_r_l_2 :
- forall b b' b'':bool, b = xorb b' b'' -> xorb b b'' = b'.
+  forall b b' b'':bool, b = xorb b' b'' -> xorb b b'' = b'.
 Proof.
   intros. rewrite H. rewrite xorb_assoc. rewrite xorb_nilpotent. apply xorb_false.
 Qed.
 
-(*******************************)
-(** De Morgan's law            *)
-(*******************************)
+(** Lemmas about the [b = true] embedding of [bool] to [Prop] *)
 
-Lemma demorgan1 :
- forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3.
-destruct b1; destruct b2; destruct b3; reflexivity.
+Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. 
+Proof. 
+  intros b1 b2; case b1; case b2; intuition.
 Qed.
 
-Lemma demorgan2 :
- forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3.
-destruct b1; destruct b2; destruct b3; reflexivity.
+Notation bool_1 := eq_true_iff_eq (only parsing). (* Compatibility *)
+
+Lemma eq_true_negb_classical : forall b:bool, negb b <> true -> b = true.
+Proof.
+  destruct b; intuition.
+Qed.
+
+Notation bool_3 := eq_true_negb_classical (only parsing). (* Compatibility *)
+
+Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true.  
+Proof.
+  destruct b; intuition.
 Qed.
 
-Lemma demorgan3 :
- forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3).
-destruct b1; destruct b2; destruct b3; reflexivity.
+Notation bool_6 := eq_true_not_negb (only parsing). (* Compatibility *)
+
+Hint Resolve eq_true_not_negb : bool.
+
+(* An interesting lemma for auto but too strong to keep compatibility *)
+
+Lemma absurd_eq_bool : forall b b':bool, False -> b = b'.
+Proof.
+  contradiction.
 Qed.
 
-Lemma demorgan4 :
- forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3).
-destruct b1; destruct b2; destruct b3; reflexivity.
+(* A more specific one that preserves compatibility with old hint bool_3 *)
+
+Lemma absurd_eq_true : forall b, False -> b = true.
+Proof.
+  contradiction.
 Qed.
+Hint Resolve absurd_eq_true.
 
-Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1.
+(* A specific instance of trans_eq that preserves compatibility with
+   old hint bool_2 *)
+
+Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; reflexivity.
+  apply trans_eq.
 Qed.
+Hint Resolve trans_eq_bool.
 
-Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1.
+(*****************************************)
+(** * Reflection of [bool] into [Prop] *)
+(*****************************************)
+
+(** [Is_true] and equality *)
+
+Hint Unfold Is_true: bool.
+
+Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; reflexivity.
+  destruct x; simpl in |- *; tauto.
+Qed.
+
+Lemma Is_true_eq_left : forall x:bool, x = true -> Is_true x.
+Proof.
+  intros; rewrite H; auto with bool.
+Qed.
+
+Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x.
+Proof.
+  intros; rewrite <- H; auto with bool.
+Qed.
+
+Notation Is_true_eq_true2 := Is_true_eq_right (only parsing).
+
+Hint Immediate Is_true_eq_right Is_true_eq_left: bool.
+
+Lemma eqb_refl : forall x:bool, Is_true (eqb x x).
+Proof.
+  destruct x; simpl; auto with bool.
+Qed.
+
+Lemma eqb_eq : forall x y:bool, Is_true (eqb x y) -> x = y.
+Proof.
+  destruct x; destruct y; simpl; tauto.
+Qed.
+
+(** [Is_true] and connectives *)
+
+Lemma orb_prop_elim : 
+  forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b.
+Proof.
+  destruct a; destruct b; simpl; tauto.
 Qed.
 
+Notation orb_prop2 := orb_prop_elim (only parsing).
 
-(** Misc. equalities between booleans (to be used by Auto) *)
+Lemma orb_prop_intro : 
+  forall a b:bool, Is_true a \/ Is_true b -> Is_true (a || b).
+Proof.
+  destruct a; destruct b; simpl; tauto.
+Qed.
+
+Lemma andb_prop_intro :
+  forall b1 b2:bool, Is_true b1 /\ Is_true b2 -> Is_true (b1 && b2).
+Proof.
+  destruct b1; destruct b2; simpl in |- *; tauto.
+Qed.
+Hint Resolve andb_prop_intro: bool v62.
+
+Notation andb_true_intro2 :=
+  (fun b1 b2 H1 H2 => andb_prop_intro b1 b2 (conj H1 H2))
+  (only parsing).
 
-Lemma bool_1 : forall b1 b2:bool, (b1 = true <-> b2 = true) -> b1 = b2. 
+Lemma andb_prop_elim :
+  forall a b:bool, Is_true (a && b) -> Is_true a /\ Is_true b.
+Proof.
+  destruct a; destruct b; simpl in |- *; try (intro H; discriminate H);
+    auto with bool.
+Qed.
+Hint Resolve andb_prop_elim: bool v62.
+
+Notation andb_prop2 := andb_prop_elim (only parsing).
+
+Lemma eq_bool_prop_intro : 
+  forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. 
 Proof. 
- intros b1 b2; case b1; case b2; intuition.
+  destruct b1; destruct b2; simpl in *; intuition.
 Qed.
 
-Lemma bool_2 : forall b1 b2:bool, b1 = b2 -> b1 = true -> b2 = true.
+Lemma eq_bool_prop_elim : forall b1 b2, b1 = b2 -> (Is_true b1 <-> Is_true b2).
 Proof. 
- intros b1 b2; case b1; case b2; intuition.
+  intros b1 b2; case b1; case b2; intuition.
 Qed. 
 
-Lemma bool_3 : forall b:bool, negb b <> true -> b = true.
+Lemma negb_prop_elim : forall b, Is_true (negb b) -> ~ Is_true b.
 Proof.
   destruct b; intuition.
 Qed.
 
-Lemma bool_4 : forall b:bool, b = true -> negb b <> true.  
+Lemma negb_prop_intro : forall b, ~ Is_true b -> Is_true (negb b).
 Proof.
-  destruct b; intuition.
+  destruct b; simpl in *; intuition.
 Qed.
 
-Lemma bool_5 : forall b:bool, negb b = true -> b <> true.
+Lemma negb_prop_classical : forall b, ~ Is_true (negb b) -> Is_true b.
 Proof.
   destruct b; intuition.
 Qed.
 
-Lemma bool_6 : forall b:bool, b <> true -> negb b = true.  
+Lemma negb_prop_involutive : forall b, Is_true b -> ~ Is_true (negb b).
 Proof.
   destruct b; intuition.
 Qed.
-
-Hint Resolve bool_1 bool_2 bool_3 bool_4 bool_5 bool_6.
diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v
index e038b3da..806ac70f 100644
--- a/theories/Bool/BoolEq.v
+++ b/theories/Bool/BoolEq.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BoolEq.v,v 1.4.2.1 2004/07/16 19:31:02 herbelin Exp $ i*)
+(*i $Id: BoolEq.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
 (* Cuihtlauac Alvarado - octobre 2000 *)
 
 (** Properties of a boolean equality   *)
diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
index 51d940cf..659630c5 100644
--- a/theories/Bool/Bvector.v
+++ b/theories/Bool/Bvector.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Bvector.v,v 1.6.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: Bvector.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)
 
@@ -16,8 +16,8 @@ Require Import Arith.
 
 Open Local Scope nat_scope.
 
-(*  
-On s'inspire de PolyList pour fabriquer les vecteurs de bits.
+(** 
+On s'inspire de List.v pour fabriquer les vecteurs de bits.
 La dimension du vecteur est un paramètre trop important pour
 se contenter de la fonction "length".
 La première idée est de faire un record avec la liste et la longueur.
@@ -26,47 +26,14 @@ de nombreux lemmes pour gerer les longueurs.
 La seconde idée est de faire un type dépendant dans lequel la
 longueur est un paramètre de construction. Cela complique un
 peu les inductions structurelles, la solution qui a ma préférence
-est alors d'utiliser un terme de preuve comme définition.
-
-(En effet une définition comme :
-Fixpoint Vunaire [n:nat; v:(vector n)]: (vector n) :=
-Cases v of
-	| Vnil => Vnil
-	| (Vcons a p v') => (Vcons (f a) p (Vunaire p v'))
-end.
-provoque ce message d'erreur :
-Coq < Error: Inference of annotation not yet implemented in this case).
-
-
-	Inductive list [A : Set]  : Set :=
-		nil : (list A) | cons : A->(list A)->(list A).
-	head = [A:Set; l:(list A)] Cases l of
-			| nil => Error
- 			| (cons x _) => (Value x)
- 			end
-     		: (A:Set)(list A)->(option A).
-	tail = [A:Set; l:(list A)]Cases l of
-                   			| nil => (nil A)
-                   			| (cons _ m) => m
-                   			end
-     		: (A:Set)(list A)->(list A).
-	length = [A:Set] Fix length {length [l:(list A)] : nat :=
-      		Cases l of
-       			| nil => O
-      			| (cons _ m) => (S (length m))
-      		end}
-     		: (A:Set)(list A)->nat.
-	map = [A,B:Set; f:(A->B)] Fix map {map [l:(list A)] : (list B) :=
-		Cases l of
-			| nil => (nil B)
-			| (cons a t) => (cons (f a) (map t))
-		end}
-		: (A,B:Set)(A->B)->(list A)->(list B)
+est alors d'utiliser un terme de preuve comme définition, car le
+mécanisme d'inférence du type du filtrage n'est pas aussi puissant que
+celui implanté par les tactiques d'élimination.
 *)
 
 Section VECTORS.
 
-(* 
+(** 
 Un vecteur est une liste de taille n d'éléments d'un ensemble A.
 Si la taille est non nulle, on peut extraire la première composante et 
 le reste du vecteur, la dernière composante ou rajouter ou enlever 
@@ -75,125 +42,143 @@ On peut aussi tronquer le vecteur de ses p dernières composantes ou
 au contraire l'étendre (concaténer) d'un vecteur de longueur p.
 Une fonction unaire sur A génère une fonction des vecteurs de taille n
 dans les vecteurs de taille n en appliquant f terme à terme.
-Une fonction binaire sur A génère une fonction des couple de vecteurs 
+Une fonction binaire sur A génère une fonction des couples de vecteurs 
 de taille n dans les vecteurs de taille n en appliquant f terme à terme.
 *)
 
-Variable A : Set.
+Variable A : Type.
 
-Inductive vector : nat -> Set :=
+Inductive vector : nat -> Type :=
   | Vnil : vector 0
   | Vcons : forall (a:A) (n:nat), vector n -> vector (S n).
 
 Definition Vhead : forall n:nat, vector (S n) -> A.
 Proof.
-	intros n v; inversion v; exact a.
+  intros n v; inversion v; exact a.
 Defined.
 
 Definition Vtail : forall n:nat, vector (S n) -> vector n.
 Proof.
-	intros n v; inversion v; exact H0.
+  intros n v; inversion v as [|_ n0 H0 H1]; exact H0.
 Defined.
 
 Definition Vlast : forall n:nat, vector (S n) -> A.
 Proof.
-	induction n as [| n f]; intro v.
-	inversion v.
-	exact a.
-
-	inversion v.
-	exact (f H0).
+  induction n as [| n f]; intro v.
+  inversion v.
+  exact a.
+  
+  inversion v as [| n0 a H0 H1].
+  exact (f H0).
 Defined.
 
 Definition Vconst : forall (a:A) (n:nat), vector n.
 Proof.
-	induction n as [| n v].
-	exact Vnil.
+  induction n as [| n v].
+  exact Vnil.
 
-	exact (Vcons a n v).
+  exact (Vcons a n v).
 Defined.
 
 Lemma Vshiftout : forall n:nat, vector (S n) -> vector n.
 Proof.
-	induction n as [| n f]; intro v.
-	exact Vnil.
-
-	inversion v.
-	exact (Vcons a n (f H0)).
+  induction n as [| n f]; intro v.
+  exact Vnil.
+  
+  inversion v as [| a n0 H0 H1].
+  exact (Vcons a n (f H0)).
 Defined.
 
 Lemma Vshiftin : forall n:nat, A -> vector n -> vector (S n).
 Proof.
-	induction n as [| n f]; intros a v.
-	exact (Vcons a 0 v).
-
-	inversion v.
-	exact (Vcons a (S n) (f a H0)).
+  induction n as [| n f]; intros a v.
+  exact (Vcons a 0 v).
+  
+  inversion v as [| a0 n0 H0 H1 ].
+  exact (Vcons a (S n) (f a H0)).
 Defined.
 
 Lemma Vshiftrepeat : forall n:nat, vector (S n) -> vector (S (S n)).
 Proof.
-	induction n as [| n f]; intro v.
-	inversion v.
-	exact (Vcons a 1 v).
-
-	inversion v.
-	exact (Vcons a (S (S n)) (f H0)).
+  induction n as [| n f]; intro v.
+  inversion v.
+  exact (Vcons a 1 v).
+  
+  inversion v as [| a n0 H0 H1 ].
+  exact (Vcons a (S (S n)) (f H0)).
 Defined.
 
-(*
-Lemma S_minus_S : (n,p:nat) (gt n (S p)) -> (S (minus n (S p)))=(minus n p).
-Proof.
-  Intros.
-Save.
-*)
-
 Lemma Vtrunc : forall n p:nat, n > p -> vector n -> vector (n - p).
 Proof.
-	induction p as [| p f]; intros H v.
-	rewrite <- minus_n_O.
-	exact v.
-
-	apply (Vshiftout (n - S p)).
-
-rewrite minus_Sn_m.
-apply f.
-auto with *.
-exact v.
-auto with *.
+  induction p as [| p f]; intros H v.
+  rewrite <- minus_n_O.
+  exact v.
+  
+  apply (Vshiftout (n - S p)).
+  
+  rewrite minus_Sn_m.
+  apply f.
+  auto with *.
+  exact v.
+  auto with *.
 Defined.
 
 Lemma Vextend : forall n p:nat, vector n -> vector p -> vector (n + p).
 Proof.
-	induction n as [| n f]; intros p v v0.
-	simpl in |- *; exact v0.
-
-	inversion v.
-	simpl in |- *; exact (Vcons a (n + p) (f p H0 v0)).
+  induction n as [| n f]; intros p v v0.
+  simpl in |- *; exact v0.
+  
+  inversion v as [| a n0 H0 H1].
+  simpl in |- *; exact (Vcons a (n + p) (f p H0 v0)).
 Defined.
 
 Variable f : A -> A.
 
 Lemma Vunary : forall n:nat, vector n -> vector n.
 Proof.
-	induction n as [| n g]; intro v.
-	exact Vnil.
-
-	inversion v.
-	exact (Vcons (f a) n (g H0)).
+  induction n as [| n g]; intro v.
+  exact Vnil.
+  
+  inversion v as [| a n0 H0 H1].
+  exact (Vcons (f a) n (g H0)).
 Defined.
 
 Variable g : A -> A -> A.
 
 Lemma Vbinary : forall n:nat, vector n -> vector n -> vector n.
 Proof.
-	induction n as [| n h]; intros v v0.
-	exact Vnil.
+  induction n as [| n h]; intros v v0.
+  exact Vnil.
+  
+  inversion v as [| a n0 H0 H1]; inversion v0 as [| a0 n1 H2 H3].
+  exact (Vcons (g a a0) n (h H0 H2)).
+Defined.
 
-	inversion v; inversion v0.
-	exact (Vcons (g a a0) n (h H0 H2)).
+Definition Vid : forall n:nat, vector n -> vector n.
+Proof.
+  destruct n; intro X.
+  exact Vnil.
+  exact (Vcons (Vhead _ X) _ (Vtail _ X)).
 Defined.
 
+Lemma Vid_eq : forall (n:nat) (v:vector n), v=(Vid n v).
+Proof.
+  destruct v; auto.
+Qed.
+
+Lemma VSn_eq :
+  forall (n : nat) (v : vector (S n)), v = Vcons (Vhead _ v) _ (Vtail _ v).
+Proof.
+  intros.
+  exact (Vid_eq _ v).
+Qed.
+
+Lemma V0_eq : forall (v : vector 0), v = Vnil.
+Proof.
+  intros.
+  exact (Vid_eq _ v).
+Qed.
+
 End VECTORS.
 
 (* suppressed: incompatible with Coq-Art book 
@@ -203,7 +188,7 @@ Implicit Arguments Vcons [A n].
 
 Section BOOLEAN_VECTORS.
 
-(* 
+(**
 Un vecteur de bits est un vecteur sur l'ensemble des booléens de longueur fixe. 
 ATTENTION : le stockage s'effectue poids FAIBLE en tête.
 On en extrait le bit  de poids faible (head) et la fin du vecteur (tail).
@@ -249,24 +234,24 @@ Definition BshiftRa (n:nat) (bv:Bvector (S n)) :=
   Bhigh (S n) (Vshiftrepeat bool n bv).
 
 Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
- Bvector (S n) :=
+  Bvector (S n) :=
   match p with
-  | O => bv
-  | S p' => BshiftL n (BshiftL_iter n bv p') false
+    | O => bv
+    | S p' => BshiftL n (BshiftL_iter n bv p') false
   end.
 
 Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
- Bvector (S n) :=
+  Bvector (S n) :=
   match p with
-  | O => bv
-  | S p' => BshiftRl n (BshiftRl_iter n bv p') false
+    | O => bv
+    | S p' => BshiftRl n (BshiftRl_iter n bv p') false
   end.
 
 Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) {struct p} :
- Bvector (S n) :=
+  Bvector (S n) :=
   match p with
-  | O => bv
-  | S p' => BshiftRa n (BshiftRa_iter n bv p')
+    | O => bv
+    | S p' => BshiftRa n (BshiftRa_iter n bv p')
   end.
 
 End BOOLEAN_VECTORS.
diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v
index 1998fb8e..af9acea1 100755..100644
--- a/theories/Bool/DecBool.v
+++ b/theories/Bool/DecBool.v
@@ -6,26 +6,28 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: DecBool.v,v 1.6.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: DecBool.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Set Implicit Arguments.
 
-Definition ifdec (A B:Prop) (C:Set) (H:{A} + {B}) (x y:C) : C :=
+Definition ifdec (A B:Prop) (C:Type) (H:{A} + {B}) (x y:C) : C :=
   if H then x else y.
 
 
 Theorem ifdec_left :
- forall (A B:Prop) (C:Set) (H:{A} + {B}),
-   ~ B -> forall x y:C, ifdec H x y = x.
-intros; case H; auto.
-intro; absurd B; trivial.
+  forall (A B:Prop) (C:Set) (H:{A} + {B}),
+    ~ B -> forall x y:C, ifdec H x y = x.
+Proof.
+  intros; case H; auto.
+  intro; absurd B; trivial.
 Qed.
 
 Theorem ifdec_right :
- forall (A B:Prop) (C:Set) (H:{A} + {B}),
-   ~ A -> forall x y:C, ifdec H x y = y.
-intros; case H; auto.
-intro; absurd A; trivial.
+  forall (A B:Prop) (C:Set) (H:{A} + {B}),
+    ~ A -> forall x y:C, ifdec H x y = y.
+Proof.
+  intros; case H; auto.
+  intro; absurd A; trivial.
 Qed.
 
-Unset Implicit Arguments.
\ No newline at end of file
+Unset Implicit Arguments.
diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v
index a00449d8..0a98c32a 100755..100644
--- a/theories/Bool/IfProp.v
+++ b/theories/Bool/IfProp.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: IfProp.v,v 1.7.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: IfProp.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Require Import Bool.
 
diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v
index 8188f038..0da72f56 100644
--- a/theories/Bool/Sumbool.v
+++ b/theories/Bool/Sumbool.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sumbool.v,v 1.12.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: Sumbool.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Here are collected some results about the type sumbool (see INIT/Specif.v)
    [sumbool A B], which is written [{A}+{B}], is the informative
@@ -16,7 +16,6 @@
 (** A boolean is either [true] or [false], and this is decidable *)
 
 Definition sumbool_of_bool : forall b:bool, {b = true} + {b = false}.
-Proof.
   destruct b; auto.
 Defined.
 
@@ -25,54 +24,48 @@ Hint Resolve sumbool_of_bool: bool.
 Definition bool_eq_rec :
   forall (b:bool) (P:bool -> Set),
     (b = true -> P true) -> (b = false -> P false) -> P b.
-destruct b; auto.
+  destruct b; auto.
 Defined.
 
 Definition bool_eq_ind :
   forall (b:bool) (P:bool -> Prop),
     (b = true -> P true) -> (b = false -> P false) -> P b.
-destruct b; auto.
+  destruct b; auto.
 Defined.
 
 
-(*i pourquoi ce machin-la est dans BOOL et pas dans LOGIC ?  Papageno i*)
-
 (** Logic connectives on type [sumbool] *)
 
 Section connectives.
 
-Variables A B C D : Prop.
-
-Hypothesis H1 : {A} + {B}.
-Hypothesis H2 : {C} + {D}.
-
-Definition sumbool_and : {A /\ C} + {B \/ D}.
-Proof.
-case H1; case H2; auto.
-Defined.
-
-Definition sumbool_or : {A \/ C} + {B /\ D}.
-Proof.
-case H1; case H2; auto.
-Defined.
-
-Definition sumbool_not : {B} + {A}.
-Proof.
-case H1; auto.
-Defined.
+  Variables A B C D : Prop.
+  
+  Hypothesis H1 : {A} + {B}.
+  Hypothesis H2 : {C} + {D}.
+  
+  Definition sumbool_and : {A /\ C} + {B \/ D}.
+    case H1; case H2; auto.
+  Defined.
+  
+  Definition sumbool_or : {A \/ C} + {B /\ D}.
+    case H1; case H2; auto.
+  Defined.
+  
+  Definition sumbool_not : {B} + {A}.
+    case H1; auto.
+  Defined.
 
 End connectives.
 
-Hint Resolve sumbool_and sumbool_or sumbool_not: core.
-
+Hint Resolve sumbool_and sumbool_or: core.
+Hint Immediate sumbool_not : core.
 
 (** Any decidability function in type [sumbool] can be turned into a function
     returning a boolean with the corresponding specification: *)
 
 Definition bool_of_sumbool :
   forall A B:Prop, {A} + {B} -> {b : bool | if b then A else B}.
-Proof.
-intros A B H.
-elim H; [ intro; exists true; assumption | intro; exists false; assumption ].
+  intros A B H.
+  elim H; intro; [exists true | exists false]; assumption.
 Defined.
 Implicit Arguments bool_of_sumbool.
\ No newline at end of file
diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v
index b654e556..fe656777 100755..100644
--- a/theories/Bool/Zerob.v
+++ b/theories/Bool/Zerob.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zerob.v,v 1.8.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: Zerob.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Arith.
 Require Import Bool.
@@ -15,24 +15,28 @@ Open Local Scope nat_scope.
 
 Definition zerob (n:nat) : bool :=
   match n with
-  | O => true
-  | S _ => false
+    | O => true
+    | S _ => false
   end.
 
 Lemma zerob_true_intro : forall n:nat, n = 0 -> zerob n = true.
-destruct n; [ trivial with bool | inversion 1 ].
+Proof.
+  destruct n; [ trivial with bool | inversion 1 ].
 Qed.
 Hint Resolve zerob_true_intro: bool.
 
 Lemma zerob_true_elim : forall n:nat, zerob n = true -> n = 0.
-destruct n; [ trivial with bool | inversion 1 ].
+Proof.
+  destruct n; [ trivial with bool | inversion 1 ].
 Qed.
 
 Lemma zerob_false_intro : forall n:nat, n <> 0 -> zerob n = false.
-destruct n; [ destruct 1; auto with bool | trivial with bool ].
+Proof.
+  destruct n; [ destruct 1; auto with bool | trivial with bool ].
 Qed.
 Hint Resolve zerob_false_intro: bool.
 
 Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0.
-destruct n; [ intro H; inversion H | auto with bool ].
+Proof.
+  destruct n; [ inversion 1 | auto with bool ].
 Qed.
\ No newline at end of file
diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
new file mode 100644
index 00000000..786ade0e
--- /dev/null
+++ b/theories/FSets/FMapAVL.v
@@ -0,0 +1,2058 @@
+
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite map library.  *)
+
+(* $Id: FMapAVL.v 8985 2006-06-23 16:12:45Z jforest $ *)
+
+(** This module implements map using AVL trees.
+    It follows the implementation from Ocaml's standard library. *)
+
+Require Import FSetInterface.
+Require Import FMapInterface.
+Require Import FMapList.
+
+Require Import ZArith.
+Require Import Int.
+
+Set Firstorder Depth 3.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+
+Module Raw (I:Int)(X: OrderedType).
+Import I.
+Module II:=MoreInt(I).
+Import II.
+Open Scope Int_scope.
+
+Module E := X.
+Module MX := OrderedTypeFacts X.
+Module PX := KeyOrderedType X.
+Module L := FMapList.Raw X.
+Import MX. 
+Import PX.
+
+Definition key := X.t.
+
+(** * Trees *)
+
+Section Elt.
+
+Variable elt : Set.
+
+(* Now in KeyOrderedType:
+Definition eqk (p p':key*elt) := X.eq (fst p) (fst p').
+Definition eqke (p p':key*elt) := 
+         X.eq (fst p) (fst p') /\ (snd p) = (snd p').
+Definition ltk (p p':key*elt) := X.lt (fst p) (fst p').
+*)
+
+Notation eqk := (eqk (elt:= elt)).
+Notation eqke := (eqke (elt:= elt)).
+Notation ltk := (ltk (elt:= elt)).
+
+Inductive tree  : Set :=
+  | Leaf : tree
+  | Node : tree -> key -> elt -> tree -> int -> tree.
+
+Notation t := tree.
+
+(** The Sixth field of [Node] is the height of the tree *)
+
+(** * Occurrence in a tree *)
+
+Inductive MapsTo (x : key)(e : elt) : tree -> Prop :=
+  | MapsRoot : forall l r h y,
+      X.eq x y -> MapsTo x e (Node l y e r h)
+  | MapsLeft : forall l r h y e', 
+      MapsTo x e l -> MapsTo x e (Node l y e' r h)
+  | MapsRight : forall l r h y e', 
+      MapsTo x e r -> MapsTo x e (Node l y e' r h).
+
+Inductive In (x : key) : tree -> Prop :=
+  | InRoot : forall l r h y e,
+      X.eq x y -> In x (Node l y e r h)
+  | InLeft : forall l r h y e', 
+      In x l -> In x (Node l y e' r h)
+  | InRight : forall l r h y e', 
+      In x r -> In x (Node l y e' r h).
+
+Definition In0 (k:key)(m:t) : Prop := exists e:elt, MapsTo k e m.
+
+(** * Binary search trees *)
+
+(** [lt_tree x s]: all elements in [s] are smaller than [x] 
+   (resp. greater for [gt_tree]) *)
+
+Definition lt_tree x s := forall y:key, In y s -> X.lt y x.
+Definition gt_tree x s := forall y:key, In y s -> X.lt x y.
+
+(** [bst t] : [t] is a binary search tree *)
+
+Inductive bst : tree -> Prop :=
+  | BSLeaf : bst Leaf
+  | BSNode : forall x e l r h, 
+      bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x e r h).
+
+(** * AVL trees *)
+
+(** [avl s] : [s] is a properly balanced AVL tree,
+    i.e. for any node the heights of the two children
+    differ by at most 2 *)
+
+Definition height (s : tree) : int :=
+  match s with
+  | Leaf => 0
+  | Node _ _ _ _ h => h
+  end.
+
+Inductive avl : tree -> Prop :=
+  | RBLeaf : avl Leaf
+  | RBNode : forall x e l r h, 
+      avl l ->
+      avl r ->
+      -(2) <= height l - height r <= 2 ->
+      h = max (height l) (height r) + 1 -> 
+      avl (Node l x e r h).
+
+(* We should end this section before the big proofs that follows, 
+    otherwise the discharge takes a lot of time. *)
+End Elt. 
+
+(** Some helpful hints and tactics. *)
+
+Notation t := tree.
+Hint Constructors tree.
+Hint Constructors MapsTo.
+Hint Constructors In.
+Hint Constructors bst.
+Hint Constructors avl.
+Hint Unfold lt_tree gt_tree.
+
+Ltac inv f :=
+  match goal with 
+     | H:f (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | _ => idtac
+  end.
+
+Ltac safe_inv f := match goal with 
+  | H:f (Node _ _ _ _ _) |- _ => 
+        generalize H; inversion_clear H; safe_inv f
+  | H:f _ (Node _ _ _ _ _) |- _ => 
+        generalize H; inversion_clear H; safe_inv f
+  | _ => intros 
+ end.
+
+Ltac inv_all f := 
+  match goal with 
+   | H: f _ |- _ => inversion_clear H; inv f
+   | H: f _ _ |- _ => inversion_clear H; inv f
+   | H: f _ _ _ |- _ => inversion_clear H; inv f
+   | H: f _ _ _ _ |- _ => inversion_clear H; inv f
+   | _ => idtac
+  end.
+
+Ltac order := match goal with 
+ | H: lt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order
+ | H: gt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order
+ | _ => MX.order
+end.
+
+Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo).
+Ltac firstorder_in := repeat progress (firstorder; inv In; inv MapsTo).
+
+Lemma height_non_negative : forall elt (s : t elt), avl s -> height s >= 0.
+Proof.
+ induction s; simpl; intros; auto with zarith.
+ inv avl; intuition; omega_max.
+Qed.
+
+Ltac avl_nn_hyp H := 
+     let nz := fresh "nz" in assert (nz := height_non_negative H).
+
+Ltac avl_nn h := 
+  let t := type of h in 
+  match type of t with 
+   | Prop => avl_nn_hyp h
+   | _ => match goal with H : avl h |- _ => avl_nn_hyp H end
+  end.
+
+(* Repeat the previous tactic. 
+   Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)
+
+Ltac avl_nns :=
+  match goal with 
+     | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
+     | _ => idtac
+  end.
+
+
+(** Facts about [MapsTo] and [In]. *)
+
+Lemma MapsTo_In : forall elt k e (m:t elt), MapsTo k e m -> In k m.
+Proof.
+ induction 1; auto.
+Qed.
+Hint Resolve MapsTo_In.
+
+Lemma In_MapsTo : forall elt k (m:t elt), In k m -> exists e, MapsTo k e m.
+Proof.
+ induction 1; try destruct IHIn as (e,He); exists e; auto.
+Qed.
+
+Lemma In_alt : forall elt k (m:t elt), In0 k m <-> In k m.
+Proof. 
+ split.
+ intros (e,H); eauto.
+ unfold In0; apply In_MapsTo; auto.
+Qed.
+
+Lemma MapsTo_1 :
+ forall elt (m:t elt) x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m.
+Proof.
+ induction m; simpl; intuition_in; eauto.
+Qed.
+Hint Immediate MapsTo_1.
+
+Lemma In_1 : 
+ forall elt (m:t elt) x y, X.eq x y -> In x m -> In y m.
+Proof.
+ intros elt m x y; induction m; simpl; intuition_in; eauto.
+Qed.
+
+
+(** Results about [lt_tree] and [gt_tree] *)
+
+Lemma lt_leaf : forall elt x, lt_tree x (Leaf elt).
+Proof.
+ unfold lt_tree in |- *; intros; intuition_in.
+Qed.
+
+Lemma gt_leaf : forall elt x, gt_tree x (Leaf elt).
+Proof.
+  unfold gt_tree in |- *; intros; intuition_in.
+Qed.
+
+Lemma lt_tree_node : forall elt x y (l:t elt) r e h, 
+ lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h).
+Proof.
+ unfold lt_tree in *; firstorder_in; order.
+Qed.
+
+Lemma gt_tree_node : forall elt x y (l:t elt) r e h,
+ gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y e r h).
+Proof.
+ unfold gt_tree in *; firstorder_in; order.
+Qed.
+
+Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+
+Lemma lt_left : forall elt x y (l: t elt) r e h, 
+ lt_tree x (Node l y e r h) -> lt_tree x l.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma lt_right : forall elt x y (l:t elt) r e h, 
+ lt_tree x (Node l y e r h) -> lt_tree x r.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma gt_left : forall elt x y (l:t elt) r e h, 
+ gt_tree x (Node l y e r h) -> gt_tree x l.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma gt_right : forall elt x y (l:t elt) r e h, 
+ gt_tree x (Node l y e r h) -> gt_tree x r.
+Proof.
+ intuition_in.
+Qed.
+
+Hint Resolve lt_left lt_right gt_left gt_right.
+
+Lemma lt_tree_not_in :
+ forall elt x (t : t elt), lt_tree x t -> ~ In x t.
+Proof.
+ intros; intro; generalize (H _ H0); order.
+Qed.
+
+Lemma lt_tree_trans :
+ forall elt x y, X.lt x y -> forall (t:t elt), lt_tree x t -> lt_tree y t.
+Proof.
+ firstorder eauto.
+Qed.
+
+Lemma gt_tree_not_in :
+ forall elt x (t : t elt), gt_tree x t -> ~ In x t.
+Proof.
+ intros; intro; generalize (H _ H0); order.
+Qed.
+
+Lemma gt_tree_trans :
+ forall elt x y, X.lt y x -> forall (t:t elt), gt_tree x t -> gt_tree y t.
+Proof.
+ firstorder eauto.
+Qed.
+
+Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+
+(** Results about [avl] *)
+
+Lemma avl_node : forall elt x e (l:t elt) r, 
+ avl l ->
+ avl r ->
+ -(2) <= height l - height r <= 2 ->
+ avl (Node l x e r (max (height l) (height r) + 1)).
+Proof.
+  intros; auto.
+Qed.
+Hint Resolve avl_node.
+
+(** * Helper functions *)
+
+(** [create l x r] creates a node, assuming [l] and [r]
+    to be balanced and [|height l - height r| <= 2]. *)
+
+Definition create elt (l:t elt) x e r := 
+   Node l x e r (max (height l) (height r) + 1).
+
+Lemma create_bst : 
+ forall elt (l:t elt) x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> 
+ bst (create l x e r).
+Proof.
+ unfold create; auto.
+Qed.
+Hint Resolve create_bst.
+
+Lemma create_avl : 
+ forall elt (l:t elt) x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+ avl (create l x e r).
+Proof.
+ unfold create; auto.
+Qed.
+
+Lemma create_height : 
+ forall elt (l:t elt) x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+ height (create l x e r) = max (height l) (height r) + 1.
+Proof.
+ unfold create; intros; auto.
+Qed.
+
+Lemma create_in : 
+ forall elt (l:t elt) x e r y,  In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+(** trick for emulating [assert false] in Coq *)
+
+Notation assert_false := Leaf.
+
+(** [bal l x e r] acts as [create], but performs one step of
+    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition bal elt (l: tree elt) x e r := 
+  let hl := height l in 
+  let hr := height r in
+  if gt_le_dec hl (hr+2) then 
+    match l with 
+     | Leaf => assert_false _
+     | Node ll lx le lr _ => 
+       if ge_lt_dec (height ll) (height lr) then 
+         create ll lx le (create lr x e r)
+       else 
+         match lr with 
+          | Leaf => assert_false _
+          | Node lrl lrx lre lrr _ => 
+              create (create ll lx le lrl) lrx lre (create lrr x e r)
+         end
+    end
+  else 
+    if gt_le_dec hr (hl+2) then 
+      match r with
+       | Leaf => assert_false _
+       | Node rl rx re rr _ =>
+         if ge_lt_dec (height rr) (height rl) then 
+            create (create l x e rl) rx re rr
+         else 
+           match rl with
+            | Leaf => assert_false _
+            | Node rll rlx rle rlr _ => 
+                create (create l x e rll) rlx rle (create rlr rx re rr) 
+           end
+      end
+    else 
+      create l x e r. 
+
+Ltac bal_tac := 
+ intros elt l x e r;
+ unfold bal; 
+ destruct (gt_le_dec (height l) (height r + 2)); 
+   [ destruct l as [ |ll lx le lr lh]; 
+     [ | destruct (ge_lt_dec (height ll) (height lr)); 
+          [ | destruct lr ] ]
+   | destruct (gt_le_dec (height r) (height l + 2)); 
+     [ destruct r as [ |rl rx re rr rh];
+          [ | destruct (ge_lt_dec (height rr) (height rl)); 
+               [ | destruct rl ] ]
+     | ] ]; intros.
+
+Ltac bal_tac_imp := match goal with 
+  | |- context [ assert_false ] => 
+      inv avl; avl_nns; simpl in *; false_omega
+  | _ => idtac
+end.
+
+Lemma bal_bst : forall elt (l:t elt) x e r, bst l -> bst r -> 
+ lt_tree x l -> gt_tree x r -> bst (bal l x e r).
+Proof.
+ bal_tac;
+ inv bst; repeat apply create_bst; auto; unfold create; 
+ apply lt_tree_node || apply gt_tree_node; auto; 
+ eapply lt_tree_trans || eapply gt_tree_trans || eauto; eauto.
+Qed.
+
+Lemma bal_avl : forall elt (l:t elt) x e r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 -> avl (bal l x e r).
+Proof.
+ bal_tac; inv avl; repeat apply create_avl; simpl in *; auto; omega_max.
+Qed.
+
+Lemma bal_height_1 : forall elt (l:t elt) x e r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 ->
+ 0 <= height (bal l x e r) - max (height l) (height r) <= 1.
+Proof.
+ bal_tac; inv avl; avl_nns; simpl in *; omega_max.
+Qed.
+
+Lemma bal_height_2 : 
+ forall elt (l:t elt) x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> 
+ height (bal l x e r) == max (height l) (height r) +1.
+Proof.
+ bal_tac; inv avl; simpl in *; omega_max.
+Qed.
+
+Lemma bal_in : forall elt (l:t elt) x e r y, avl l -> avl r -> 
+ (In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r).
+Proof.
+ bal_tac; bal_tac_imp; repeat rewrite create_in; intuition_in.
+Qed.
+
+Lemma bal_mapsto : forall elt (l:t elt) x e r y e', avl l -> avl r -> 
+ (MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r)).
+Proof.
+ bal_tac; bal_tac_imp; unfold create; intuition_in.
+Qed.
+
+Ltac omega_bal := match goal with 
+  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => 
+     generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); 
+     omega_max
+  end. 
+
+(** * Insertion *)
+
+Function add (elt:Set)(x:key)(e:elt)(s:t elt) { struct s } : t elt := match s with 
+   | Leaf => Node (Leaf _) x e (Leaf _) 1
+   | Node l y e' r h => 
+      match X.compare x y with
+         | LT _ => bal (add x e l) y e' r
+         | EQ _ => Node l y e r h
+         | GT _ => bal l y e' (add x e r)
+      end
+  end.
+
+Lemma add_avl_1 :  forall elt (m:t elt) x e, avl m -> 
+ avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1.
+Proof. 
+ intros elt m x e; functional induction (add x e m); intros; inv avl; simpl in *.
+ intuition; try constructor; simpl; auto; try omega_max.
+ (* LT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+ (* EQ *)
+ intuition; omega_max.
+ (* GT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma add_avl : forall elt (m:t elt) x e, avl m -> avl (add x e m).
+Proof.
+ intros; generalize (add_avl_1 x e H); intuition.
+Qed.
+Hint Resolve add_avl.
+
+Lemma add_in : forall elt (m:t elt) x y e, avl m -> 
+ (In y (add x e m) <-> X.eq y x \/ In y m).
+Proof.
+ intros elt m x y e; functional induction (add x e m); auto; intros.
+ intuition_in.
+ (* LT *)
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite (IHt H0); intuition_in.
+ (* EQ *)  
+ inv avl.
+ firstorder_in.
+ eapply In_1; eauto.
+ (* GT *)
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite (IHt H1); intuition_in.
+Qed.
+
+Lemma add_bst : forall elt (m:t elt) x e, bst m -> avl m -> bst (add x e m).
+Proof. 
+ intros elt m x e; functional induction (add x e m); 
+   intros; inv bst; inv avl; auto; apply bal_bst; auto.
+ (* lt_tree -> lt_tree (add ...) *)
+ red; red in H4.
+ intros.
+ rewrite (add_in x y0 e H) in H0.
+ intuition.
+ eauto.
+ (* gt_tree -> gt_tree (add ...) *)
+ red; red in H4.
+ intros.
+ rewrite (add_in x y0 e H5) in H0.
+ intuition.
+ apply lt_eq with x; auto.
+Qed.
+
+Lemma add_1 : forall elt (m:t elt) x y e, avl m -> X.eq x y -> MapsTo y e (add x e m).
+Proof. 
+ intros elt m x y e; functional induction (add x e m); 
+   intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; eauto.
+Qed. 
+
+Lemma add_2 : forall elt (m:t elt) x y e e', avl m -> ~X.eq x y -> 
+ MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros elt m x y e e'; induction m; simpl; auto.
+ destruct (X.compare x k);
+ intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; auto; 
+   inv MapsTo; auto; order.
+Qed.
+
+Lemma add_3 : forall elt (m:t elt) x y e e', avl m -> ~X.eq x y -> 
+ MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros elt m x y e e'; induction m; simpl; auto. 
+ intros; inv avl; inv MapsTo; auto; order.
+ destruct (X.compare x k); intro; inv avl; 
+  try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; 
+  order. 
+Qed.
+
+
+(** * Extraction of minimum binding
+
+  morally, [remove_min] is to be applied to a non-empty tree 
+  [t = Node l x e r h]. Since we can't deal here with [assert false] 
+  for [t=Leaf], we pre-unpack [t] (and forget about [h]). 
+*)
+ 
+Function remove_min (elt:Set)(l:t elt)(x:key)(e:elt)(r:t elt) { struct l } : t elt*(key*elt) := 
+  match l with 
+    | Leaf => (r,(x,e))
+    | Node ll lx le lr lh => let (l',m) := (remove_min ll lx le lr : t elt*(key*elt)) in (bal l' x e r, m)
+  end.
+
+Lemma remove_min_avl_1 : forall elt (l:t elt) x e r h, avl (Node l x e r h) -> 
+ avl (fst (remove_min l x e r)) /\ 
+ 0 <= height (Node l x e r h) - height (fst (remove_min l x e r)) <= 1.
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv avl; simpl in *; split; auto.
+ avl_nns; omega_max.
+ (* l = Node *)
+ inversion_clear H.
+ destruct (IHp lh); auto.
+ split; simpl in *. 
+ rewrite_all e1. simpl in *.
+ apply bal_avl; subst;auto; omega_max.
+ rewrite_all e1;simpl in *;omega_bal.
+Qed.
+
+Lemma remove_min_avl : forall elt (l:t elt) x e r h, avl (Node l x e r h) -> 
+    avl (fst (remove_min l x e r)). 
+Proof.
+ intros; generalize (remove_min_avl_1 H); intuition.
+Qed.
+
+Lemma remove_min_in : forall elt (l:t elt) x e r h y, avl (Node l x e r h) -> 
+ (In y (Node l x e r h) <-> 
+  X.eq y (fst (snd (remove_min l x e r))) \/ In y (fst (remove_min l x e r))).
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ intuition_in.
+ (* l = Node *)
+ inversion_clear H.
+ generalize (remove_min_avl H0).
+ 
+ rewrite_all e1; simpl; intros.
+ rewrite bal_in; auto.
+ generalize (IHp lh y H0).
+ intuition.
+ inversion_clear H7; intuition.
+Qed.
+
+Lemma remove_min_mapsto : forall elt (l:t elt) x e r h y e', avl (Node l x e r h) -> 
+ (MapsTo y e' (Node l x e r h) <-> 
+   ((X.eq y (fst (snd (remove_min l x e r))) /\ e' = (snd (snd (remove_min l x e r))))
+    \/ MapsTo y e' (fst (remove_min l x e r)))).
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ intuition_in; subst; auto.
+ (* l = Node *)
+ inversion_clear H.
+ generalize (remove_min_avl H0).
+ rewrite_all e1; simpl; intros.
+ rewrite bal_mapsto; auto; unfold create.
+ simpl in *;destruct (IHp lh y e').
+ auto.
+ intuition.
+ inversion_clear H2; intuition.
+ inversion_clear H9; intuition.
+Qed.
+
+Lemma remove_min_bst : forall elt (l:t elt) x e r h, 
+ bst (Node l x e r h) -> avl (Node l x e r h) -> bst (fst (remove_min l x e r)).
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H0.
+ apply bal_bst; auto.
+ rewrite_all e1;simpl in *;firstorder.
+ intro; intros.
+ generalize (remove_min_in y H).
+ rewrite_all e1; simpl in *.
+ destruct 1.
+ apply H3; intuition.
+Qed.
+
+Lemma remove_min_gt_tree : forall elt (l:t elt) x e r h, 
+ bst (Node l x e r h) -> avl (Node l x e r h) -> 
+ gt_tree (fst (snd (remove_min l x e r))) (fst (remove_min l x e r)).
+Proof.
+ intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H0.
+ intro; intro.
+ rewrite_all e1;simpl in *.
+ generalize (IHp lh H1 H); clear H7 H6 IHp.
+ generalize (remove_min_avl H).
+ generalize (remove_min_in (fst m) H).
+ rewrite e1; simpl; intros.
+ rewrite (bal_in x e y H7 H5) in H0.
+ destruct H6.
+ firstorder.
+ apply lt_eq with x; auto.
+ apply X.lt_trans with x; auto.
+Qed.
+
+(** * Merging two trees
+
+  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
+  of [t1] to be smaller than all elements of [t2], and
+  [|height t1 - height t2| <= 2].
+*)
+
+Function merge (elt:Set) (s1 s2 : t elt) : tree elt :=  match s1,s2 with 
+  | Leaf, _ => s2 
+  | _, Leaf => s1
+  | _, Node l2 x2 e2 r2 h2 => 
+    match remove_min l2 x2 e2 r2 with 
+      (s2',(x,e)) => bal s1 x e s2'
+    end
+end.
+
+Lemma merge_avl_1 : forall elt (s1 s2:t elt), avl s1 -> avl s2 -> 
+ -(2) <= height s1 - height s2 <= 2 -> 
+ avl (merge s1 s2) /\ 
+ 0<= height (merge s1 s2) - max (height s1) (height s2) <=1.
+Proof.
+ intros elt s1 s2; functional induction (merge s1 s2); simpl in *; intros.
+ split; auto; avl_nns; omega_max.
+ destruct s1;try contradiction;clear y.
+ split; auto; avl_nns; simpl in *; omega_max.
+ destruct s1;try contradiction;clear y.
+ generalize (remove_min_avl_1 H0).
+ rewrite e3; simpl;destruct 1.
+ split.
+ apply bal_avl; auto.
+ simpl; omega_max.
+ omega_bal.
+Qed.
+
+Lemma merge_avl : forall elt (s1 s2:t elt), avl s1 -> avl s2 -> 
+  -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2).
+Proof. 
+ intros; generalize (merge_avl_1 H H0 H1); intuition.
+Qed.
+
+Lemma merge_in : forall elt (s1 s2:t elt) y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (In y (merge s1 s2) <-> In y s1 \/ In y s2).
+Proof. 
+ intros elt s1 s2; functional induction (merge s1 s2);intros.
+ intuition_in.
+ intuition_in.
+ destruct s1;try contradiction;clear y.
+(*  rewrite H_eq_2; rewrite H_eq_2 in H_eq_1; clear H_eq_2. *)
+ replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto].
+ rewrite bal_in; auto.
+ generalize (remove_min_avl H2); rewrite e3; simpl; auto.
+ generalize (remove_min_in y0 H2); rewrite e3; simpl; intro.
+ rewrite H3; intuition.
+Qed.
+
+Lemma merge_mapsto : forall elt (s1 s2:t elt) y e, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+  (MapsTo y e (merge s1 s2) <-> MapsTo y e s1 \/ MapsTo y e s2).
+Proof.
+ intros elt s1 s2; functional induction (@merge elt s1 s2); intros.
+ intuition_in.
+ intuition_in.
+ destruct s1;try contradiction;clear y.
+ replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto].
+ rewrite bal_mapsto; auto; unfold create.
+ generalize (remove_min_avl H2); rewrite e3; simpl; auto.
+ generalize (remove_min_mapsto y0 e H2); rewrite e3; simpl; intro.
+ rewrite H3; intuition (try subst; auto).
+ inversion_clear H3; intuition.
+Qed.
+
+Lemma merge_bst : forall elt (s1 s2:t elt), bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (forall y1 y2 : key, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
+ bst (merge s1 s2). 
+Proof.
+ intros elt s1 s2; functional induction (@merge elt s1 s2); intros; auto.
+
+ apply bal_bst; auto.
+ destruct s1;try contradiction.
+ generalize (remove_min_bst H1); rewrite e3; simpl in *; auto.
+ destruct s1;try contradiction.
+ intro; intro.
+ apply H3; auto.
+ generalize (remove_min_in x H2); rewrite e3; simpl; intuition.
+ destruct s1;try contradiction.
+ generalize (remove_min_gt_tree H1); rewrite e3; simpl; auto.
+Qed. 
+
+(** * Deletion *)
+
+Function remove (elt:Set)(x:key)(s:t elt) { struct s } : t elt := match s with 
+  | Leaf => Leaf _
+  | Node l y e r h =>
+      match X.compare x y with
+         | LT _ => bal (remove x l) y e r
+         | EQ _ => merge l r
+         | GT _ => bal l y e (remove x r)
+      end
+   end.
+
+Lemma remove_avl_1 : forall elt (s:t elt) x, avl s -> 
+ avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1.
+Proof.
+ intros elt s x; functional induction (@remove elt x s); intros.
+ split; auto; omega_max.
+ (* LT *)
+ inv avl.
+ destruct (IHt H0).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+ (* EQ *)
+ inv avl. 
+ generalize (merge_avl_1 H0 H1 H2).
+ intuition omega_max.
+ (* GT *)
+ inv avl.
+ destruct (IHt H1).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_avl : forall elt (s:t elt) x, avl s -> avl (remove x s).
+Proof. 
+ intros; generalize (remove_avl_1 x H); intuition.
+Qed.
+Hint Resolve remove_avl.
+
+Lemma remove_in : forall elt (s:t elt) x y, bst s -> avl s -> 
+ (In y (remove x s) <-> ~ X.eq y x /\ In y s).
+Proof.
+ intros elt s x; functional induction (@remove elt x s); simpl; intros.
+ intuition_in.
+ (* LT *)
+ inv avl; inv bst; clear e1.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H0); intuition; [ order | order | intuition_in ].
+ (* EQ *)
+ inv avl; inv bst; clear e1.
+ rewrite merge_in; intuition; [ order | order | intuition_in ].
+ elim H9; eauto.
+ (* GT *)
+ inv avl; inv bst; clear e1.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H5); intuition; [ order | order | intuition_in ].
+Qed.
+
+Lemma remove_bst : forall elt (s:t elt) x, bst s -> avl s -> bst (remove x s).
+Proof. 
+ intros elt s x; functional induction (@remove elt x s); simpl; intros.
+ auto.
+ (* LT *)
+ inv avl; inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in x y0 H0) in H; auto.
+ destruct H; eauto.
+ (* EQ *)
+ inv avl; inv bst.
+ apply merge_bst; eauto.
+ (* GT *) 
+ inv avl; inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in x y0 H5) in H; auto.
+ destruct H; eauto.
+Qed.
+
+Lemma remove_1 : forall elt (m:t elt) x y, bst m -> avl m -> X.eq x y -> ~ In y (remove x m).
+Proof. 
+ intros; rewrite remove_in; intuition.
+Qed. 
+
+Lemma remove_2 : forall elt (m:t elt) x y e, bst m -> avl m -> ~X.eq x y -> 
+ MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros elt m x y e; induction m; simpl; auto.
+ destruct (X.compare x k); 
+   intros; inv bst; inv avl; try rewrite bal_mapsto; unfold create; auto; 
+   try solve [inv MapsTo; auto].
+ rewrite merge_mapsto; auto.
+ inv MapsTo; auto; order.
+Qed.
+
+Lemma remove_3 : forall elt (m:t elt) x y e, bst m -> avl m ->
+ MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros elt m x y e; induction m; simpl; auto.
+ destruct (X.compare x k); intros Bs Av; inv avl; inv bst; 
+  try rewrite bal_mapsto; auto; unfold create.
+  intros; inv MapsTo; auto. 
+  rewrite merge_mapsto; intuition.
+  intros; inv MapsTo; auto.
+Qed.
+
+Section Elt2.
+
+Variable elt:Set.
+
+Notation eqk := (eqk (elt:= elt)).
+Notation eqke := (eqke (elt:= elt)).
+Notation ltk := (ltk (elt:= elt)).
+
+(** * Empty map *)
+
+Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+
+Definition empty := (Leaf elt).
+
+Lemma empty_bst : bst empty.
+Proof.
+ unfold empty; auto.
+Qed.
+
+Lemma empty_avl : avl empty.
+Proof. 
+ unfold empty; auto.
+Qed.
+
+Lemma empty_1 : Empty empty.
+Proof.
+ unfold empty, Empty; intuition_in.
+Qed.
+
+(** * Emptyness test *)
+
+Definition is_empty (s:t elt) := match s with Leaf => true | _ => false end.
+
+Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. 
+Proof.
+ destruct s as [|r x e l h]; simpl; auto.
+ intro H; elim (H x e); auto.
+Qed.
+
+Lemma is_empty_2 : forall s, is_empty s = true -> Empty s.
+Proof. 
+ destruct s; simpl; intros; try discriminate; red; intuition_in.
+Qed.
+
+(** * Appartness *)
+
+(** The [mem] function is deciding appartness. It exploits the [bst] property
+    to achieve logarithmic complexity. *)
+
+Function mem (x:key)(m:t elt) { struct m } : bool := 
+   match m with 
+     |  Leaf => false 
+     |  Node l y e r _ => match X.compare x y with 
+             | LT _ => mem x l 
+             | EQ _ => true
+             | GT _ => mem x r
+         end
+   end.
+Implicit Arguments mem. 
+
+Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true.
+Proof. 
+ intros s x.
+ functional induction (mem x s); inversion_clear 1; auto.
+ intuition_in.
+ intuition_in; firstorder; absurd (X.lt x y); eauto.
+ intuition_in; firstorder; absurd (X.lt y x); eauto.
+Qed.
+
+Lemma mem_2 : forall s x, mem x s = true -> In x s. 
+Proof. 
+ intros s x. 
+ functional induction (mem x s); firstorder; intros; try discriminate.
+Qed.
+
+Function find (x:key)(m:t elt) { struct m } : option elt := 
+   match m with 
+     |  Leaf => None 
+     |  Node l y e r _ => match X.compare x y with 
+             | LT _ => find x l 
+             | EQ _ => Some e
+             | GT _ => find x r
+         end
+   end.
+
+Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e.
+Proof. 
+ intros m x e.
+ functional induction (find x m); inversion_clear 1; auto.
+ intuition_in.
+ intuition_in; firstorder; absurd (X.lt x y); eauto.
+ intuition_in; auto.
+  absurd (X.lt x y); eauto.
+  absurd (X.lt y x); eauto.
+ intuition_in; firstorder; absurd (X.lt y x); eauto.
+Qed.
+
+Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+Proof. 
+ intros m x.
+ functional induction (find x m); subst;firstorder; intros; try discriminate.
+ inversion H; subst; auto.
+Qed.
+
+(** An all-in-one spec for [add] used later in the naive [map2] *)
+
+Lemma add_spec : forall m x y e , bst m -> avl m -> 
+  find x (add y e m) = if eq_dec x y then Some e else find x m.
+Proof.
+intros.
+destruct (eq_dec x y).
+apply find_1.
+apply add_bst; auto.
+eapply MapsTo_1 with y; eauto.
+apply add_1; auto.
+case_eq (find x m); intros.
+apply find_1.
+apply add_bst; auto.
+apply add_2; auto.
+apply find_2; auto.
+case_eq (find x (add y e m)); auto; intros.
+rewrite <- H1; symmetry.
+apply find_1; auto.
+eapply add_3; eauto.
+apply find_2; eauto.
+Qed.
+
+(** * Elements *)
+
+(** [elements_tree_aux acc t] catenates the elements of [t] in infix
+    order to the list [acc] *)
+
+Fixpoint elements_aux (acc : list (key*elt)) (t : t elt) {struct t} : list (key*elt) :=
+  match t with
+   | Leaf => acc
+   | Node l x e r _ => elements_aux ((x,e) :: elements_aux acc r) l
+  end.
+
+(** then [elements] is an instanciation with an empty [acc] *)
+
+Definition elements := elements_aux nil.
+
+Lemma elements_aux_mapsto : forall s acc x e, 
+ InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc.
+Proof.
+ induction s as [ | l Hl x e r Hr h ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0 e0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+ destruct H0; simpl in *; subst; intuition.
+Qed.
+
+Lemma elements_mapsto : forall s x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. 
+Proof. 
+ intros; generalize (elements_aux_mapsto s nil x e); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma elements_in : forall s x, L.PX.In x (elements s) <-> In x s.
+Proof.
+ intros.
+ unfold L.PX.In.
+ rewrite <- In_alt; unfold In0.
+ firstorder.
+ exists x0.
+ rewrite <- elements_mapsto; auto.
+ exists x0.
+ unfold L.PX.MapsTo; rewrite elements_mapsto; auto.
+Qed.
+
+Lemma elements_aux_sort : forall s acc, bst s -> sort ltk acc ->
+ (forall x e y, InA eqke (x,e) acc -> In y s -> X.lt y x) ->
+ sort ltk (elements_aux acc s).
+Proof.
+ induction s as [ | l Hl y e r Hr h]; simpl; intuition.
+ inv bst.
+ apply Hl; auto.
+ constructor. 
+ apply Hr; eauto.
+ apply (InA_InfA (eqke_refl (elt:=elt))); intros (y',e') H6.
+ destruct (elements_aux_mapsto r acc y' e'); intuition.
+ red; simpl; eauto.
+ red; simpl; eauto.
+ intros.
+ inversion_clear H.
+ destruct H7; simpl in *.
+ order.
+ destruct (elements_aux_mapsto r acc x e0); intuition eauto.
+Qed.
+
+Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s).
+Proof.
+ intros; unfold elements; apply elements_aux_sort; auto.
+ intros; inversion H0.
+Qed.
+Hint Resolve elements_sort.
+
+
+(** * Fold *)
+
+Fixpoint fold (A : Set) (f : key -> elt -> A -> A)(s : t elt) {struct s} : A -> A := 
+ fun a => match s with
+  | Leaf => a
+  | Node l x e r _ => fold f r (f x e (fold f l a))
+ end.
+
+Definition fold' (A : Set) (f : key -> elt -> A -> A)(s : t elt) := 
+  L.fold f (elements s).
+
+Lemma fold_equiv_aux :
+ forall (A : Set) (s : t elt) (f : key -> elt -> A -> A) (a : A) acc,
+ L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a).
+Proof.
+ simple induction s.
+ simpl in |- *; intuition.
+ simpl in |- *; intros.
+ rewrite H.
+ simpl.
+ apply H0.
+Qed.
+
+Lemma fold_equiv :
+ forall (A : Set) (s : t elt) (f : key -> elt -> A -> A) (a : A),
+ fold f s a = fold' f s a.
+Proof.
+ unfold fold', elements in |- *. 
+ simple induction s; simpl in |- *; auto; intros.
+ rewrite fold_equiv_aux.
+ rewrite H0.
+ simpl in |- *; auto.
+Qed.
+
+Lemma fold_1 : 
+ forall (s:t elt)(Hs:bst s)(A : Set)(i:A)(f : key -> elt -> A -> A),
+ fold f s i = fold_left (fun a p => f (fst p) (snd p) a) (elements s) i.
+Proof.
+ intros.
+ rewrite fold_equiv.
+ unfold fold'.
+ rewrite L.fold_1.
+ unfold L.elements; auto.
+Qed.
+
+(** * Comparison *)
+
+Definition Equal (cmp:elt->elt->bool) m m' := 
+  (forall k, In k m <-> In k m') /\ 
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+(** ** Enumeration of the elements of a tree *)
+
+Inductive enumeration : Set :=
+ | End : enumeration
+ | More : key -> elt -> t elt -> enumeration -> enumeration.
+
+(** [flatten_e e] returns the list of elements of [e] i.e. the list
+    of elements actually compared *)
+ 
+Fixpoint flatten_e (e : enumeration) : list (key*elt) := match e with
+  | End => nil
+  | More x e t r => (x,e) :: elements t ++ flatten_e r
+ end.
+
+(** [sorted_e e] expresses that elements in the enumeration [e] are
+    sorted, and that all trees in [e] are binary search trees. *)
+
+Inductive In_e (p:key*elt) : enumeration -> Prop :=
+  | InEHd1 :
+      forall (y : key)(d:elt) (s : t elt) (e : enumeration),
+      eqke p (y,d) -> In_e p (More y d s e)
+  | InEHd2 :
+      forall (y : key) (d:elt) (s : t elt) (e : enumeration),
+      MapsTo (fst p) (snd p) s -> In_e p (More y d s e)
+  | InETl :
+      forall (y : key) (d:elt) (s : t elt) (e : enumeration),
+      In_e p e -> In_e p (More y d s e).
+
+Hint Constructors In_e.
+
+Inductive sorted_e : enumeration -> Prop :=
+  | SortedEEnd : sorted_e End
+  | SortedEMore :
+      forall (x : key) (d:elt) (s : t elt) (e : enumeration),
+      bst s ->
+      (gt_tree x s) ->
+      sorted_e e ->
+      (forall p, In_e p e -> ltk (x,d) p) ->
+      (forall p,
+       MapsTo (fst p) (snd p) s -> forall q, In_e q e -> ltk p q) ->
+      sorted_e (More x d s e).
+
+Hint Constructors sorted_e.
+
+Lemma in_flatten_e :
+ forall p e, InA eqke p (flatten_e e) -> In_e p e.
+Proof.
+ simple induction e; simpl in |- *; intuition.
+ inversion_clear H.
+ inversion_clear H0; auto.
+ elim (InA_app H1); auto.
+ destruct (elements_mapsto t a b); auto.
+Qed.
+
+Lemma sorted_flatten_e :
+ forall e : enumeration, sorted_e e -> sort ltk (flatten_e e).
+Proof.
+ simple induction e; simpl in |- *; intuition.
+ apply cons_sort.
+ apply (SortA_app (eqke_refl (elt:=elt))); inversion_clear H0; auto.
+ intros; apply H5; auto.
+ rewrite <- elements_mapsto; auto; destruct x; auto.
+ apply in_flatten_e; auto.
+ inversion_clear H0.
+ apply In_InfA; intros.
+ intros; elim (in_app_or _ _ _ H0); intuition.
+ generalize (In_InA (eqke_refl (elt:=elt)) H6).
+ destruct y; rewrite elements_mapsto; eauto.
+ apply H4; apply in_flatten_e; auto.
+ apply In_InA; auto.
+Qed.
+
+Lemma elements_app :
+ forall s acc, elements_aux acc s = elements s ++ acc.
+Proof.
+ simple induction s; simpl in |- *; intuition.
+ rewrite H0.
+ rewrite H.
+ unfold elements; simpl.
+ do 2 rewrite H.
+ rewrite H0.
+ repeat rewrite <- app_nil_end.
+ repeat rewrite app_ass; auto.
+Qed.
+
+Lemma compare_flatten_1 :
+ forall t1 t2 x e z l,
+ elements t1 ++ (x,e) :: elements t2 ++ l =
+ elements (Node t1 x e t2 z) ++ l.
+Proof.
+ simpl in |- *; unfold elements in |- *; simpl in |- *; intuition.
+ repeat rewrite elements_app.
+ repeat rewrite <- app_nil_end.
+ repeat rewrite app_ass; auto.
+Qed.
+
+(** key lemma for correctness *)
+
+Lemma flatten_e_elements :
+ forall l r x d z e,
+ elements l ++ flatten_e (More x d r e) = 
+ elements (Node l x d r z) ++ flatten_e e.
+Proof.
+ intros; simpl.
+ apply compare_flatten_1.
+Qed.
+
+Open Scope Z_scope.
+
+(** termination of [compare_aux] *)
+ 
+Fixpoint measure_e_t (s : t elt) : Z := match s with
+  | Leaf => 0
+  | Node l _ _ r _ => 1 + measure_e_t l + measure_e_t r
+ end.
+
+Fixpoint measure_e (e : enumeration) : Z := match e with
+  | End => 0
+  | More _ _ s r => 1 + measure_e_t s + measure_e r
+ end.
+
+Ltac Measure_e_t := unfold measure_e_t in |- *; fold measure_e_t in |- *.
+Ltac Measure_e := unfold measure_e in |- *; fold measure_e in |- *.
+
+Lemma measure_e_t_0 : forall s : t elt, measure_e_t s >= 0.
+Proof.
+ simple induction s.
+ simpl in |- *; omega.
+ intros.
+ Measure_e_t; omega.
+Qed.
+
+Ltac Measure_e_t_0 s := generalize (@measure_e_t_0 s); intro.
+
+Lemma measure_e_0 : forall e : enumeration, measure_e e >= 0.
+Proof.
+ simple induction e.
+ simpl in |- *; omega.
+ intros.
+ Measure_e; Measure_e_t_0 t; omega.
+Qed.
+
+Ltac Measure_e_0 e := generalize (@measure_e_0 e); intro.
+
+(** Induction principle over the sum of the measures for two lists *)
+
+Definition compare_rec2 :
+ forall P : enumeration -> enumeration -> Set,
+  (forall x x' : enumeration,
+   (forall y y' : enumeration,
+    measure_e y + measure_e y' < measure_e x + measure_e x' -> P y y') ->
+   P x x') -> 
+ forall x x' : enumeration, P x x'.
+Proof.
+ intros P H x x'.
+ apply well_founded_induction_type_2
+ with (R := fun yy' xx' : enumeration * enumeration =>
+            measure_e (fst yy') + measure_e (snd yy') <
+            measure_e (fst xx') + measure_e (snd xx')); auto.    
+ apply Wf_nat.well_founded_lt_compat
+ with (f := fun xx' : enumeration * enumeration =>
+            Zabs_nat (measure_e (fst xx') + measure_e (snd xx'))).
+ intros; apply Zabs.Zabs_nat_lt.
+ Measure_e_0 (fst x0); Measure_e_0 (snd x0); Measure_e_0 (fst y);
+ Measure_e_0 (snd y); intros; omega.
+Qed.
+
+(** [cons t e] adds the elements of tree [t] on the head of 
+    enumeration [e]. Code:
+ 
+let rec cons s e = match s with
+ | Empty -> e
+ | Node(l, k, d, r, _) -> cons l (More(k, d, r, e))
+*)
+
+Definition cons : forall s e, bst s -> sorted_e e ->
+  (forall x y, MapsTo (fst x) (snd x) s -> In_e y e -> ltk x y) ->
+  { r : enumeration 
+  | sorted_e r /\ 
+    measure_e r = measure_e_t s + measure_e e /\
+    flatten_e r = elements s ++ flatten_e e
+  }.
+Proof.
+ simple induction s; intuition.
+ (* s = Leaf *)
+ exists e; intuition.
+ (* s = Node t k e t0 z *)
+ clear H0.
+ case (H (More k e t0 e0)); clear H; intuition.
+ inv bst; auto.
+ constructor; inversion_clear H1; auto.
+ inversion_clear H0; inv bst; intuition.
+ destruct y; red; red in H4; simpl in *; intuition.
+ apply lt_eq with k; eauto.
+ destruct y; red; simpl in *; intuition.
+ apply X.lt_trans with k; eauto.
+ exists x; intuition.
+ generalize H4; Measure_e; intros; Measure_e_t; omega.
+ rewrite H5.
+ apply flatten_e_elements.
+Qed.
+
+Definition equal_aux : 
+ forall (cmp: elt -> elt -> bool)(e1 e2:enumeration), 
+ sorted_e e1 -> sorted_e e2 -> 
+ { L.Equal cmp (flatten_e e1) (flatten_e e2) } +
+ { ~ L.Equal cmp (flatten_e e1) (flatten_e e2) }.
+Proof.
+ intros cmp e1 e2; pattern e1, e2 in |- *; apply compare_rec2.
+ simple destruct x; simple destruct x'; intuition.
+ (* x = x' = End *)
+ left; unfold L.Equal in |- *; intuition.
+ inversion H2.
+ (* x = End x' = More *)
+ right; simpl in |- *; auto.
+ destruct 1.
+ destruct (H2 k).
+ destruct H5; auto.
+ exists e; auto.
+ inversion H5.
+ (* x = More x' = End *)
+ right; simpl in |- *; auto.
+ destruct 1.
+ destruct (H2 k).
+ destruct H4; auto.
+ exists e; auto.
+ inversion H4.
+ (* x = More k e t e0, x' = More k0 e3 t0 e4 *)
+ case (X.compare k k0); intro.
+ (* k < k0 *)
+ right.
+ destruct 1. 
+ clear H3 H.
+ assert (L.PX.In k (flatten_e (More k0 e3 t0 e4))).
+  destruct (H2 k).
+  apply H; simpl; exists e; auto.
+ destruct H. 
+ generalize (Sort_In_cons_2 (sorted_flatten_e H1) (InA_eqke_eqk H)).
+ compute.
+ intuition order. 
+ (* k = k0 *)
+ case_eq (cmp e e3).
+ intros EQ.
+ destruct (@cons t e0) as [c1 (H2,(H3,H4))]; try inversion_clear H0; auto.
+ destruct (@cons t0 e4) as [c2 (H5,(H6,H7))]; try inversion_clear H1; auto.
+ destruct (H c1 c2); clear H; intuition.
+ Measure_e; omega.
+ left.
+ rewrite H4 in e6; rewrite H7 in e6.
+ simpl; rewrite <- L.equal_cons; auto.
+ apply (sorted_flatten_e H0).
+ apply (sorted_flatten_e H1).
+ right.
+ simpl; rewrite <- L.equal_cons; auto.
+ apply (sorted_flatten_e H0).
+ apply (sorted_flatten_e H1).
+ swap f.
+ rewrite H4; rewrite H7; auto.
+ right.
+ destruct 1.
+ rewrite (H4 k) in H2; try discriminate; simpl; auto.
+ (* k > k0 *)
+ right.
+ destruct 1. 
+ clear H3 H.
+ assert (L.PX.In k0 (flatten_e (More k e t e0))).
+  destruct (H2 k0).
+  apply H3; simpl; exists e3; auto.
+ destruct H. 
+ generalize (Sort_In_cons_2 (sorted_flatten_e H0) (InA_eqke_eqk H)).
+ compute.
+ intuition order. 
+Qed.
+
+Lemma Equal_elements : forall cmp s s', 
+ Equal cmp s s' <-> L.Equal cmp (elements s) (elements s').
+Proof.
+unfold Equal, L.Equal; split; split; intros.
+do 2 rewrite elements_in; firstorder.
+destruct H.
+apply (H2 k); rewrite <- elements_mapsto; auto.
+do 2 rewrite <- elements_in; firstorder.
+destruct H.
+apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto.
+Qed.
+
+Definition equal : forall cmp s s', bst s -> bst s' -> 
+  {Equal cmp s s'} + {~ Equal cmp s s'}.
+Proof.
+ intros cmp s1 s2 s1_bst s2_bst; simpl.
+ destruct (@cons s1 End); auto.
+ inversion_clear 2.
+ destruct (@cons s2 End); auto.
+ inversion_clear 2.
+ simpl in a; rewrite <- app_nil_end in a.
+ simpl in a0; rewrite <- app_nil_end in a0.
+ destruct (@equal_aux cmp x x0); intuition.
+ left.
+ rewrite H4 in e; rewrite H5 in e.
+ rewrite Equal_elements; auto.
+ right.
+ swap n.
+ rewrite H4; rewrite H5.
+ rewrite <- Equal_elements; auto.
+Qed.
+
+End Elt2.
+
+Section Elts. 
+
+Variable elt elt' elt'' : Set.
+
+Section Map. 
+Variable f : elt -> elt'. 
+
+Fixpoint map (m:t elt) {struct m} : t elt' := 
+  match m with 
+   | Leaf   => Leaf _
+   | Node l v d r h => Node (map l) v  (f d) (map r) h
+  end.
+
+Lemma map_height : forall m, height (map m) = height m.
+Proof. 
+destruct m; simpl; auto.
+Qed.
+
+Lemma map_avl : forall m, avl m -> avl (map m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto.
+Qed.
+
+Lemma map_1 : forall (m: tree elt)(x:key)(e:elt), 
+    MapsTo x e m -> MapsTo x (f e) (map m).
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma map_2 : forall (m: t elt)(x:key), 
+    In x (map m) -> In x m.
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma map_bst : forall m, bst m -> bst (map m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto.
+red; intros; apply H2; apply map_2; auto.
+red; intros; apply H3; apply map_2; auto.
+Qed.
+
+End Map.
+Section Mapi. 
+Variable f : key -> elt -> elt'. 
+
+Fixpoint mapi (m:t elt) {struct m} : t elt' := 
+  match m with 
+   | Leaf   => Leaf _
+   | Node l v d r h => Node (mapi l) v  (f v d) (mapi r) h
+  end.
+
+Lemma mapi_height : forall m, height (mapi m) = height m.
+Proof. 
+destruct m; simpl; auto.
+Qed.
+
+Lemma mapi_avl : forall m, avl m -> avl (mapi m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto.
+Qed.
+
+Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), 
+    MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi m).
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+exists k; auto.
+destruct (IHm1 _ _ H0).
+exists x0; intuition.
+destruct (IHm2 _ _ H0).
+exists x0; intuition.
+Qed.
+
+Lemma mapi_2 : forall (m: t elt)(x:key), 
+    In x (mapi m) -> In x m.
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma mapi_bst : forall m, bst m -> bst (mapi m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto.
+red; intros; apply H2; apply mapi_2; auto.
+red; intros; apply H3; apply mapi_2; auto.
+Qed.
+
+End Mapi.
+
+Section Map2.
+Variable f : option elt -> option elt' -> option elt''.
+
+(* Not exactly pretty nor perfect, but should suffice as a first naive implem. 
+    Anyway, map2 isn't in Ocaml...
+*)
+
+Definition anti_elements (l:list (key*elt'')) := L.fold (@add _) l (empty _).
+
+Definition map2 (m:t elt)(m':t elt') : t elt'' := 
+  anti_elements (L.map2 f (elements m) (elements m')).
+
+Lemma anti_elements_avl_aux : forall (l:list (key*elt''))(m:t elt''), 
+  avl m -> avl (L.fold (@add _) l m).
+Proof.
+unfold anti_elements; induction l.
+simpl; auto.
+simpl; destruct a; intros.
+apply IHl.
+apply add_avl; auto.
+Qed.
+
+Lemma anti_elements_avl : forall l, avl (anti_elements l).
+Proof.
+unfold anti_elements, empty; intros; apply anti_elements_avl_aux; auto.
+Qed.
+
+Lemma anti_elements_bst_aux : forall (l:list (key*elt''))(m:t elt''), 
+  bst m -> avl m -> bst (L.fold (@add _) l m).
+Proof.
+induction l.
+simpl; auto.
+simpl; destruct a; intros.
+apply IHl.
+apply add_bst; auto.
+apply add_avl; auto.
+Qed.
+
+Lemma anti_elements_bst : forall l, bst (anti_elements l).
+Proof.
+unfold anti_elements, empty; intros; apply anti_elements_bst_aux; auto.
+Qed.
+
+Lemma anti_elements_mapsto_aux : forall (l:list (key*elt'')) m k e,
+  bst m -> avl m -> NoDupA (eqk (elt:=elt'')) l -> 
+  (forall x, L.PX.In x l -> In x m -> False) -> 
+  (MapsTo k e (L.fold (@add _) l m) <-> L.PX.MapsTo k e l \/ MapsTo k e m).
+Proof.
+induction l. 
+simpl; auto.
+intuition.
+inversion H4.
+simpl; destruct a; intros.
+rewrite IHl; clear IHl.
+apply add_bst; auto.
+apply add_avl; auto.
+inversion H1; auto.
+intros.
+inversion_clear H1.
+assert (~X.eq x k).
+ swap H5.
+ destruct H3.
+ apply InA_eqA with (x,x0); eauto.
+apply (H2 x).
+destruct H3; exists x0; auto.
+revert H4; do 2 rewrite <- In_alt; destruct 1; exists x0; auto.
+eapply add_3; eauto.
+intuition.
+assert (find k0 (add k e m) = Some e0).
+ apply find_1; auto.
+ apply add_bst; auto.
+clear H4. 
+rewrite add_spec in H3; auto.
+destruct (eq_dec k0 k).
+inversion_clear H3; subst; auto.
+right; apply find_2; auto.
+inversion_clear H4; auto.
+compute in H3; destruct H3.
+subst; right; apply add_1; auto.
+inversion_clear H1.
+destruct (eq_dec k0 k).
+destruct (H2 k); eauto.
+right; apply add_2; auto.
+Qed.
+
+Lemma anti_elements_mapsto : forall l k e, NoDupA (eqk (elt:=elt'')) l ->
+  (MapsTo k e (anti_elements l) <-> L.PX.MapsTo k e l).
+Proof. 
+intros. 
+unfold anti_elements.
+rewrite anti_elements_mapsto_aux; auto; unfold empty; auto.
+inversion 2.
+intuition.
+inversion H1.
+Qed.
+
+Lemma map2_avl : forall (m: t elt)(m': t elt'), avl (map2 m m').
+Proof.
+unfold map2; intros; apply anti_elements_avl; auto.
+Qed.
+
+Lemma map2_bst : forall (m: t elt)(m': t elt'), bst (map2 m m').
+Proof.
+unfold map2; intros; apply anti_elements_bst; auto.
+Qed.
+
+Lemma find_elements : forall (elt:Set)(m: t elt) x, bst m -> 
+  L.find x (elements m) = find x m.
+Proof. 
+intros.
+case_eq (find x m); intros.
+apply L.find_1.
+apply elements_sort; auto.
+red; rewrite elements_mapsto.
+apply find_2; auto.
+case_eq (L.find x (elements m)); auto; intros.
+rewrite <- H0; symmetry.
+apply find_1; auto.
+rewrite <- elements_mapsto.
+apply L.find_2; auto.
+Qed.
+
+Lemma find_anti_elements : forall (l: list (key*elt'')) x, sort (@ltk _) l -> 
+  find x (anti_elements l) = L.find x l.
+Proof.
+intros.
+case_eq (L.find x l); intros.
+apply find_1.
+apply anti_elements_bst; auto.
+rewrite anti_elements_mapsto.
+apply L.PX.Sort_NoDupA; auto.
+apply L.find_2; auto.
+case_eq (find x (anti_elements l)); auto; intros.
+rewrite <- H0; symmetry.
+apply L.find_1; auto.
+rewrite <- anti_elements_mapsto.
+apply L.PX.Sort_NoDupA; auto.
+apply find_2; auto.
+Qed.
+
+Lemma map2_1 : forall (m: t elt)(m': t elt')(x:key), bst m -> bst m' -> 
+  In x m \/ In x m' -> find x (map2 m m') = f (find x m) (find x m').       
+Proof. 
+unfold map2; intros.
+rewrite find_anti_elements; auto.
+rewrite <- find_elements; auto.
+rewrite <- find_elements; auto.
+apply L.map2_1; auto.
+apply elements_sort; auto.
+apply elements_sort; auto.
+do 2 rewrite elements_in; auto.
+apply L.map2_sorted; auto.
+apply elements_sort; auto.
+apply elements_sort; auto.
+Qed.
+
+Lemma map2_2 : forall (m: t elt)(m': t elt')(x:key), bst m -> bst m' -> 
+  In x (map2 m m') -> In x m \/ In x m'.
+Proof.
+unfold map2; intros.
+do 2 rewrite <- elements_in.
+apply L.map2_2 with (f:=f); auto.
+apply elements_sort; auto.
+apply elements_sort; auto.
+revert H1.
+rewrite <- In_alt.
+destruct 1.
+exists x0.
+rewrite <- anti_elements_mapsto; auto.
+apply L.PX.Sort_NoDupA; auto.
+apply L.map2_sorted; auto.
+apply elements_sort; auto.
+apply elements_sort; auto.
+Qed.
+
+End Map2.
+End Elts.
+End Raw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we 
+   need to encapsulate everything into a type of balanced binary search trees. *)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Raw := Raw I X. 
+
+ Record bbst (elt:Set) : Set := 
+  Bbst {this :> Raw.tree elt; is_bst : Raw.bst this; is_avl: Raw.avl this}.
+ 
+ Definition t := bbst. 
+ Definition key := E.t.
+ 
+ Section Elt. 
+ Variable elt elt' elt'': Set.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key. 
+ Implicit Types e : elt. 
+
+ Definition empty : t elt := Bbst (Raw.empty_bst elt) (Raw.empty_avl elt).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := 
+  Bbst (Raw.add_bst x e m.(is_bst) m.(is_avl)) (Raw.add_avl x e m.(is_avl)).
+ Definition remove x m : t elt := 
+  Bbst (Raw.remove_bst x m.(is_bst) m.(is_avl)) (Raw.remove_avl x m.(is_avl)). 
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition map f m : t elt' := 
+  Bbst (Raw.map_bst f m.(is_bst)) (Raw.map_avl f m.(is_avl)).
+ Definition mapi (f:key->elt->elt') m : t elt' := 
+  Bbst (Raw.mapi_bst f m.(is_bst)) (Raw.mapi_avl f m.(is_avl)).
+ Definition map2 f m (m':t elt') : t elt'' := 
+  Bbst (Raw.map2_bst f m m') (Raw.map2_avl f m m').
+ Definition elements m : list (key*elt) := Raw.elements m.(this).
+ Definition fold (A:Set) (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i.
+ Definition equal cmp m m' : bool := 
+   if (Raw.equal cmp m.(is_bst) m'.(is_bst)) then true else false.
+
+ Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.In0 x m.(this).
+ Definition Empty m : Prop := Raw.Empty m.(this).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.MapsTo_1 _ m.(this)). Qed.
+ 
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof.
+ unfold In, mem; intros m x; rewrite Raw.In_alt; simpl; apply Raw.mem_1; auto.
+ apply m.(is_bst).
+ Qed.
+ 
+ Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+ Proof.
+ unfold In, mem; intros m x; rewrite Raw.In_alt; simpl; apply Raw.mem_2; auto.
+ Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@Raw.empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@Raw.is_empty_1 _ m.(this)). Qed.
+ Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@Raw.is_empty_2 _ m.(this)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m x y e; exact (@Raw.add_1 elt _ x y e m.(is_avl)). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m x y e e'; exact (@Raw.add_2 elt _ x y e e' m.(is_avl)). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m x y e e'; exact (@Raw.add_3 elt _ x y e e' m.(is_avl)). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof.
+ unfold In, remove; intros m x y; rewrite Raw.In_alt; simpl; apply Raw.remove_1; auto.
+ apply m.(is_bst).
+ apply m.(is_avl).
+ Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m x y e; exact (@Raw.remove_2 elt _ x y e m.(is_bst) m.(is_avl)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m x y e; exact (@Raw.remove_3 elt _ x y e m.(is_bst) m.(is_avl)). Qed.
+
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Proof. intros m x e; exact (@Raw.find_1 elt _ x e m.(is_bst)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.
+
+ Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@Raw.fold_1 elt m.(this) m.(is_bst)). Qed.
+
+ Lemma elements_1 : forall m x e,       
+   MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite Raw.elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_2 : forall m x e,   
+   InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite <- Raw.elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_3 : forall m, sort lt_key (elements m).  
+ Proof. intros m; exact (@Raw.elements_sort elt m.(this) m.(is_bst)). Qed.
+
+ Definition Equal cmp m m' := 
+   (forall k, In k m <-> In k m') /\ 
+   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+ Lemma Equal_Equal : forall cmp m m', Equal cmp m m' <-> Raw.Equal cmp m m'.
+ Proof. 
+ intros; unfold Equal, Raw.Equal, In; intuition.
+ generalize (H0 k); do 2 rewrite Raw.In_alt; intuition.
+ generalize (H0 k); do 2 rewrite Raw.In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- Raw.In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- Raw.In_alt; intuition.
+ Qed. 
+
+ Lemma equal_1 : forall m m' cmp, 
+   Equal cmp m m' -> equal cmp m m' = true. 
+ Proof. 
+ unfold equal; intros m m' cmp; rewrite Equal_Equal.
+ destruct (@Raw.equal _ cmp m m'); auto.
+ Qed. 
+
+ Lemma equal_2 : forall m m' cmp, 
+   equal cmp m m' = true -> Equal cmp m m'.
+ Proof. 
+ unfold equal; intros; rewrite Equal_Equal.
+ destruct (@Raw.equal _ cmp m m'); auto; try discriminate.
+ Qed.  
+
+ End Elt.
+
+ Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m x e f; exact (@Raw.map_1 elt elt' f m.(this) x e). Qed.
+
+ Lemma map_2 : forall (elt elt':Set)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m.
+ Proof.
+ intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite Raw.In_alt; simpl.
+ apply Raw.map_2; auto.
+ Qed. 
+
+ Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m x e f; exact (@Raw.mapi_1 elt elt' f m.(this) x e). Qed.
+ Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof.
+ intros elt elt' m x f; unfold In in *; do 2 rewrite Raw.In_alt; simpl; apply Raw.mapi_2; auto.
+ Qed. 
+
+ Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''), 
+    In x m \/ In x m' -> 
+    find x (map2 f m m') = f (find x m) (find x m'). 
+ Proof. 
+ unfold find, map2, In; intros elt elt' elt'' m m' x f.
+ do 2 rewrite Raw.In_alt; intros; simpl; apply Raw.map2_1; auto.
+ apply m.(is_bst).
+ apply m'.(is_bst).
+ Qed.
+
+ Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+     (x:key)(f:option elt->option elt'->option elt''), 
+     In x (map2 f m m') -> In x m \/ In x m'.
+ Proof. 
+ unfold In, map2; intros elt elt' elt'' m m' x f.
+ do 3 rewrite Raw.In_alt; intros; simpl in *; eapply Raw.map2_2; eauto.
+ apply m.(is_bst).
+ apply m'.(is_bst).
+ Qed.
+
+End IntMake.
+
+
+Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: 
+    Sord with Module Data := D 
+            with Module MapS.E := X.
+
+  Module Data := D.
+  Module MapS := IntMake(I)(X). 
+  Import MapS.
+
+  Module MD := OrderedTypeFacts(D).
+  Import MD.
+
+  Module LO := FMapList.Make_ord(X)(D).
+
+  Definition t := MapS.t D.t. 
+
+  Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.	
+
+  Definition elements (m:t) := 
+    LO.MapS.Build_slist (Raw.elements_sort m.(is_bst)).
+
+  Definition eq : t -> t -> Prop := 
+    fun m1 m2 => LO.eq (elements m1) (elements m2).
+
+  Definition lt : t -> t -> Prop := 
+    fun m1 m2 => LO.lt (elements m1) (elements m2).
+
+  Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'.
+  Proof.
+  intros m m'.
+  unfold eq.
+  rewrite Equal_Equal.
+  rewrite Raw.Equal_elements.
+  intros.
+  apply LO.eq_1.
+  auto.
+  Qed.
+
+  Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'.
+  Proof.
+  intros m m'.
+  unfold eq.
+  rewrite Equal_Equal.
+  rewrite Raw.Equal_elements.
+  intros.
+  generalize (LO.eq_2 H).
+  auto.
+  Qed.
+ 
+  Lemma eq_refl : forall m : t, eq m m.
+  Proof. 
+  unfold eq; intros; apply LO.eq_refl.
+  Qed.
+
+  Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+  Proof.
+  unfold eq; intros; apply LO.eq_sym; auto.
+  Qed.
+
+  Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+  Proof.
+  unfold eq; intros; eapply LO.eq_trans; eauto.
+  Qed.
+
+  Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+  Proof.
+  unfold lt; intros; eapply LO.lt_trans; eauto.
+  Qed.
+
+  Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+  Proof.
+  unfold lt, eq; intros; apply LO.lt_not_eq; auto.
+  Qed.
+
+  Import Raw.
+
+  Definition flatten_slist (e:enumeration D.t)(He:sorted_e e) := 
+   LO.MapS.Build_slist (sorted_flatten_e He). 
+
+  Open Scope Z_scope.
+
+  Definition compare_aux : 
+   forall (e1 e2:enumeration D.t)(He1:sorted_e e1)(He2: sorted_e e2), 
+   Compare LO.lt LO.eq (flatten_slist He1) (flatten_slist He2).
+  Proof.
+  intros e1 e2; pattern e1, e2 in |- *; apply compare_rec2.
+  simple destruct x; simple destruct x'; intuition.
+  (* x = x' = End *)
+  constructor 2.
+  compute; auto.
+  (* x = End x' = More *)
+  constructor 1.
+  compute; auto.
+  (* x = More x' = End *)
+  constructor 3.
+  compute; auto.
+  (* x = More k t0 t1 e, x' = More k0 t2 t3 e0 *)
+  case (X.compare k k0); intro.
+  (* k < k0 *)
+  constructor 1.
+  compute; MX.elim_comp; auto.
+  (* k = k0 *)
+  destruct (D.compare t t1).
+  constructor 1.
+  compute; MX.elim_comp; auto.
+  destruct (@cons _ t0 e) as [c1 (H2,(H3,H4))]; try inversion_clear He1; auto.
+  destruct (@cons _ t2 e0) as [c2 (H5,(H6,H7))]; try inversion_clear He2; auto.
+  assert (measure_e c1 + measure_e c2 <
+              measure_e (More k t t0 e) + 
+              measure_e (More k0 t1 t2 e0)).
+  unfold measure_e in *; fold measure_e in *; omega.           
+  destruct (H c1 c2 H0 H2 H5); clear H.
+  constructor 1.
+  unfold flatten_slist, LO.lt in *; simpl; simpl in l.
+  MX.elim_comp.
+  right; split; auto.
+  rewrite <- H7; rewrite <- H4; auto.
+  constructor 2.
+  unfold flatten_slist, LO.eq in *; simpl; simpl in e5.
+  MX.elim_comp.
+  split; auto.
+  rewrite <- H7; rewrite <- H4; auto.
+  constructor 3.
+  unfold flatten_slist, LO.lt in *; simpl; simpl in l.
+  MX.elim_comp.
+  right; split; auto.
+  rewrite <- H7; rewrite <- H4; auto.
+  constructor 3.
+  compute; MX.elim_comp; auto.
+  (* k > k0 *)
+  constructor 3.
+  compute; MX.elim_comp; auto.
+  Qed.
+
+  Definition compare : forall m1 m2, Compare lt eq m1 m2.
+  Proof.
+  intros (m1,m1_bst,m1_avl) (m2,m2_bst,m2_avl); simpl.
+  destruct (@cons _ m1 (End _)) as [x1 (H1,H11)]; auto.
+  apply SortedEEnd.
+  inversion_clear 2.
+  destruct (@cons _ m2 (End _)) as [x2 (H2,H22)]; auto.
+  apply SortedEEnd.
+  inversion_clear 2.
+  simpl in H11; rewrite <- app_nil_end in H11.
+  simpl in H22; rewrite <- app_nil_end in H22.
+  destruct (compare_aux H1 H2); intuition.
+  constructor 1.
+  unfold lt, LO.lt, IntMake_ord.elements, flatten_slist in *; simpl in *.
+  rewrite <- H0; rewrite <- H4; auto.
+  constructor 2.
+  unfold eq, LO.eq, IntMake_ord.elements, flatten_slist in *; simpl in *.
+  rewrite <- H0; rewrite <- H4; auto.
+  constructor 3.
+  unfold lt, LO.lt, IntMake_ord.elements, flatten_slist in *; simpl in *.
+  rewrite <- H0; rewrite <- H4; auto.
+  Qed.
+
+End IntMake_ord.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
+
+Module Make_ord (X: OrderedType)(D: OrderedType) 
+ <: Sord with Module Data := D 
+            with Module MapS.E := X
+ :=IntMake_ord(Z_as_Int)(X)(D).
diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v
new file mode 100644
index 00000000..0105095a
--- /dev/null
+++ b/theories/FSets/FMapFacts.v
@@ -0,0 +1,557 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMapFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
+
+(** * Finite maps library *)
+
+(** This functor derives additional facts from [FMapInterface.S]. These
+  facts are mainly the specifications of [FMapInterface.S] written using 
+  different styles: equivalence and boolean equalities. 
+*)
+
+Require Import Bool.
+Require Import OrderedType.
+Require Export FMapInterface. 
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Facts (M: S).
+Module ME := OrderedTypeFacts M.E.
+Import ME.
+Import M.
+Import Logic. (* to unmask [eq] *)  
+Import Peano. (* to unmask [lt] *)
+
+Lemma MapsTo_fun : forall (elt:Set) m x (e e':elt), 
+  MapsTo x e m -> MapsTo x e' m -> e=e'.
+Proof.
+intros.
+generalize (find_1 H) (find_1 H0); clear H H0.
+intros; rewrite H in H0; injection H0; auto.
+Qed.
+
+(** * Specifications written using equivalences *)
+
+Section IffSpec. 
+Variable elt elt' elt'': Set.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m).
+Proof.
+split; apply MapsTo_1; auto.
+Qed.
+
+Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m).
+Proof.
+unfold In.
+split; intros (e0,H0); exists e0.
+apply (MapsTo_1 H H0); auto.
+apply (MapsTo_1 (E.eq_sym H) H0); auto.
+Qed.
+
+Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e.
+Proof.
+split; [apply find_1|apply find_2].
+Qed.
+
+Lemma not_find_mapsto_iff : forall m x, ~In x m <-> find x m = None.
+Proof.
+intros.
+generalize (find_mapsto_iff m x); destruct (find x m).
+split; intros; try discriminate.
+destruct H0.
+exists e; rewrite H; auto.
+split; auto.
+intros; intros (e,H1).
+rewrite H in H1; discriminate.
+Qed.
+
+Lemma mem_in_iff : forall m x, In x m <-> mem x m = true.
+Proof.
+split; [apply mem_1|apply mem_2].
+Qed.
+
+Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false.
+Proof.
+intros; rewrite mem_in_iff; destruct (mem x m); intuition.
+Qed.
+
+Lemma equal_iff : forall m m' cmp, Equal cmp m m' <-> equal cmp m m' = true.
+Proof. 
+split; [apply equal_1|apply equal_2].
+Qed.
+
+Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False.
+Proof.
+intuition; apply (empty_1 H).
+Qed.
+
+Lemma empty_in_iff : forall x, In x (empty elt) <-> False.
+Proof.
+unfold In.
+split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition.
+Qed.
+
+Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. 
+Proof. 
+split; [apply is_empty_1|apply is_empty_2].
+Qed.
+
+Lemma add_mapsto_iff : forall m x y e e', 
+  MapsTo y e' (add x e m) <-> 
+     (E.eq x y /\ e=e') \/ 
+     (~E.eq x y /\ MapsTo y e' m).
+Proof. 
+intros.
+intuition.
+destruct (eq_dec x y); [left|right].
+split; auto.
+symmetry; apply (MapsTo_fun (e':=e) H); auto.
+split; auto; apply add_3 with x e; auto.
+subst; auto.
+Qed.
+
+Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m.
+Proof. 
+unfold In; split.
+intros (e',H).
+destruct (eq_dec x y) as [E|E]; auto.
+right; exists e'; auto.
+apply (add_3 E H).
+destruct (eq_dec x y) as [E|E]; auto.
+intros.
+exists e; apply add_1; auto.
+intros [H|(e',H)].
+destruct E; auto.
+exists e'; apply add_2; auto.
+Qed.
+
+Lemma add_neq_mapsto_iff : forall m x y e e', 
+ ~ E.eq x y -> (MapsTo y e' (add x e m)  <-> MapsTo y e' m).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma add_neq_in_iff : forall m x y e, 
+ ~ E.eq x y -> (In y (add x e m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (add_3 H H0).
+apply add_2; auto.
+Qed.
+
+Lemma remove_mapsto_iff : forall m x y e, 
+  MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m.
+Proof. 
+intros.
+split; intros.
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+apply remove_3 with x; auto.
+apply remove_2; intuition.
+Qed.
+
+Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m.
+Proof. 
+unfold In; split.
+intros (e,H).
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+exists e; apply remove_3 with x; auto.
+intros (H,(e,H0)); exists e; apply remove_2; auto.
+Qed.
+
+Lemma remove_neq_mapsto_iff : forall m x y e, 
+ ~ E.eq x y -> (MapsTo y e (remove x m)  <-> MapsTo y e m).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma remove_neq_in_iff : forall m x y, 
+ ~ E.eq x y -> (In y (remove x m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (remove_3 H0).
+apply remove_2; auto.
+Qed.
+
+Lemma elements_mapsto_iff : forall m x e, 
+ MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m).
+Proof. 
+split; [apply elements_1 | apply elements_2].
+Qed.
+
+Lemma elements_in_iff : forall m x, 
+ In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m).
+Proof. 
+unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto.
+Qed.
+
+Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), 
+ MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m.
+Proof.
+split.
+case_eq (find x m); intros.
+exists e.
+split.
+apply (MapsTo_fun (m:=map f m) (x:=x)); auto.
+apply find_2; auto.
+assert (In x (map f m)) by (exists b; auto).
+destruct (map_2 H1) as (a,H2).
+rewrite (find_1 H2) in H; discriminate.
+intros (a,(H,H0)).
+subst b; auto.
+Qed.
+
+Lemma map_in_iff : forall m x (f : elt -> elt'), 
+ In x (map f m) <-> In x m.
+Proof.
+split; intros; eauto.
+destruct H as (a,H).
+exists (f a); auto.
+Qed.
+
+Lemma mapi_in_iff : forall m x (f:key->elt->elt'),
+ In x (mapi f m) <-> In x m.
+Proof.
+split; intros; eauto.
+destruct H as (a,H).
+destruct (mapi_1 f H) as (y,(H0,H1)).
+exists (f y a); auto.
+Qed.
+
+(* Unfortunately, we don't have simple equivalences for [mapi] 
+  and [MapsTo]. The only correct one needs compatibility of [f]. *) 
+
+Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), 
+ MapsTo x b (mapi f m) -> 
+ exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m.
+Proof.
+intros; case_eq (find x m); intros.
+exists e.
+destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)).
+apply find_2; auto.
+exists y; repeat split; auto.
+apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto.
+assert (In x (mapi f m)) by (exists b; auto).
+destruct (mapi_2 H1) as (a,H2).
+rewrite (find_1 H2) in H0; discriminate.
+Qed.
+
+Lemma mapi_1bis : forall m x e (f:key->elt->elt'), 
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ MapsTo x e m -> MapsTo x (f x e) (mapi f m).
+Proof.
+intros.
+destruct (mapi_1 f H0) as (y,(H1,H2)).
+replace (f x e) with (f y e) by auto.
+auto.
+Qed.
+
+Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m).
+Proof.
+split.
+intros.
+destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))).
+exists a; split; auto.
+subst b; auto.
+intros (a,(H0,H1)).
+subst b.
+apply mapi_1bis; auto.
+Qed.
+
+(** Things are even worse for [map2] : we don't try to state any 
+ equivalence, see instead boolean results below. *)
+
+End IffSpec.
+
+(** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *)
+  
+Ltac map_iff := 
+ repeat (progress (
+  rewrite add_mapsto_iff || rewrite add_in_iff ||
+  rewrite remove_mapsto_iff || rewrite remove_in_iff ||
+  rewrite empty_mapsto_iff || rewrite empty_in_iff ||
+  rewrite map_mapsto_iff || rewrite map_in_iff ||
+  rewrite mapi_in_iff)).
+
+(**  * Specifications written using boolean predicates *)
+
+Section BoolSpec.
+
+Lemma mem_find_b : forall (elt:Set)(m:t elt)(x:key), mem x m = if find x m then true else false. 
+Proof.
+intros.
+generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In.
+destruct (find x m); destruct (mem x m); auto.
+intros.
+rewrite <- H0; exists e; rewrite H; auto.
+intuition.
+destruct H0 as (e,H0).
+destruct (H e); intuition discriminate.
+Qed.
+
+Variable elt elt' elt'' : Set.
+Implicit Types m : t elt.
+Implicit Types x y z : key.
+Implicit Types e : elt.
+
+Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m.
+Proof. 
+intros.
+generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H).
+destruct (mem x m); destruct (mem y m); intuition.
+Qed.
+
+Lemma find_o : forall m x y, E.eq x y -> find x m = find y m.
+Proof.
+intros.
+generalize (find_mapsto_iff m x) (find_mapsto_iff m y) (fun e => MapsTo_iff m e H).
+destruct (find x m); destruct (find y m); intros.
+rewrite <- H0; rewrite H2; rewrite H1; auto.
+symmetry; rewrite <- H1; rewrite <- H2; rewrite H0; auto.
+rewrite <- H0; rewrite H2; rewrite H1; auto.
+auto.
+Qed.
+
+Lemma empty_o : forall x, find x (empty elt) = None.
+Proof.
+intros.
+case_eq (find x (empty elt)); intros; auto.
+generalize (find_2 H).
+rewrite empty_mapsto_iff; intuition.
+Qed.
+
+Lemma empty_a : forall x, mem x (empty elt) = false.
+Proof.
+intros.
+case_eq (mem x (empty elt)); intros; auto.
+generalize (mem_2 H).
+rewrite empty_in_iff; intuition.
+Qed.
+
+Lemma add_eq_o : forall m x y e, 
+ E.eq x y -> find y (add x e m) = Some e.
+Proof.
+auto.
+Qed.
+
+Lemma add_neq_o : forall m x y e, 
+ ~ E.eq x y -> find y (add x e m) = find y m. 
+Proof.
+intros.
+case_eq (find y m); intros; auto.
+case_eq (find y (add x e m)); intros; auto.
+rewrite <- H0; symmetry.
+apply find_1; apply add_3 with x e; auto.
+Qed.
+Hint Resolve add_neq_o.
+
+Lemma add_o : forall m x y e, 
+ find y (add x e m) = if eq_dec x y then Some e else find y m.
+Proof.
+intros; destruct (eq_dec x y); auto.
+Qed.
+
+Lemma add_eq_b : forall m x y e, 
+ E.eq x y -> mem y (add x e m) = true.
+Proof.
+intros; rewrite mem_find_b; rewrite add_eq_o; auto.
+Qed.
+
+Lemma add_neq_b : forall m x y e, 
+ ~E.eq x y -> mem y (add x e m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto.
+Qed.
+
+Lemma add_b : forall m x y e, 
+ mem y (add x e m) = eqb x y || mem y m. 
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb.
+destruct (eq_dec x y); simpl; auto.
+Qed.
+
+Lemma remove_eq_o : forall m x y, 
+ E.eq x y -> find y (remove x m) = None.
+Proof.
+intros.
+generalize (remove_1 (m:=m) H).
+generalize (find_mapsto_iff (remove x m) y).
+destruct (find y (remove x m)); auto.
+destruct 2.
+exists e; rewrite H0; auto.
+Qed.
+Hint Resolve remove_eq_o.
+
+Lemma remove_neq_o : forall m x y, 
+ ~ E.eq x y -> find y (remove x m) = find y m. 
+Proof.
+intros.
+case_eq (find y m); intros; auto.
+case_eq (find y (remove x m)); intros; auto.
+rewrite <- H0; symmetry.
+apply find_1; apply remove_3 with x; auto.
+Qed.
+Hint Resolve remove_neq_o.
+
+Lemma remove_o : forall m x y, 
+ find y (remove x m) = if eq_dec x y then None else find y m.
+Proof.
+intros; destruct (eq_dec x y); auto.
+Qed.
+
+Lemma remove_eq_b : forall m x y, 
+ E.eq x y -> mem y (remove x m) = false.
+Proof.
+intros; rewrite mem_find_b; rewrite remove_eq_o; auto.
+Qed.
+
+Lemma remove_neq_b : forall m x y, 
+ ~ E.eq x y -> mem y (remove x m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto.
+Qed.
+
+Lemma remove_b : forall m x y, 
+ mem y (remove x m) = negb (eqb x y) && mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb.
+destruct (eq_dec x y); auto.
+Qed.
+
+Definition option_map (A:Set)(B:Set)(f:A->B)(o:option A) : option B := 
+ match o with 
+  | Some a => Some (f a)
+  | None => None
+ end.
+
+Lemma map_o : forall m x (f:elt->elt'), 
+ find x (map f m) = option_map f (find x m). 
+Proof.
+intros.
+generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x)
+  (fun b => map_mapsto_iff m x b f).
+destruct (find x (map f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H; rewrite H1; exists e0; rewrite H0; auto.
+destruct (H e) as [_ H2].
+rewrite H1 in H2.
+destruct H2 as (a,(_,H2)); auto.
+rewrite H0 in H2; discriminate.
+rewrite <- H; rewrite H1; exists e; rewrite H0; auto.
+Qed.
+
+Lemma map_b : forall m x (f:elt->elt'), 
+ mem x (map f m) = mem x m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite map_o.
+destruct (find x m); simpl; auto.
+Qed.
+
+Lemma mapi_b : forall m x (f:key->elt->elt'), 
+ mem x (mapi f m) = mem x m.
+Proof.
+intros.
+generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f).
+destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros.
+symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto.
+rewrite <- H; rewrite H1; rewrite H0; auto.
+Qed.
+
+Lemma mapi_o : forall m x (f:key->elt->elt'), 
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ find x (mapi f m) = option_map (f x) (find x m).
+Proof.
+intros.
+generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) 
+  (fun b => mapi_mapsto_iff m x b H).
+destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto.
+destruct (H0 e) as [_ H3].
+rewrite H2 in H3.
+destruct H3 as (a,(_,H3)); auto.
+rewrite H1 in H3; discriminate.
+rewrite <- H0; rewrite H2; exists e; rewrite H1; auto.
+Qed.
+
+Lemma map2_1bis : forall (m: t elt)(m': t elt') x 
+ (f:option elt->option elt'->option elt''), 
+ f None None = None -> 
+ find x (map2 f m m') = f (find x m) (find x m').       
+Proof.
+intros.
+case_eq (find x m); intros.
+rewrite <- H0.
+apply map2_1; auto.
+left; exists e; auto.
+case_eq (find x m'); intros.
+rewrite <- H0; rewrite <- H1.
+apply map2_1; auto.
+right; exists e; auto.
+rewrite H.
+case_eq (find x (map2 f m m')); intros; auto.
+assert (In x (map2 f m m')) by (exists e; auto).
+destruct (map2_2 H3) as [(e0,H4)|(e0,H4)].
+rewrite (find_1 H4) in H0; discriminate.
+rewrite (find_1 H4) in H1; discriminate.
+Qed.
+
+Lemma elements_o : forall m x, 
+ find x m = findA (eqb x) (elements m).
+Proof.
+intros.
+assert (forall e, find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x,e) (elements m)).
+ intros; rewrite <- find_mapsto_iff; apply elements_mapsto_iff.
+assert (NoDupA (eq_key (elt:=elt)) (elements m)). 
+ apply SortA_NoDupA with (lt_key (elt:=elt)); unfold eq_key, lt_key; intuition eauto.
+ destruct y; simpl in *.
+ apply (E.lt_not_eq H0 H1).
+ exact (elements_3 m).
+generalize (fun e => @findA_NoDupA _ _ _ E.eq_sym E.eq_trans eq_dec (elements m) x e H0).
+unfold eqb.
+destruct (find x m); destruct (findA (fun y : E.t => if eq_dec x y then true else false) (elements m)); 
+ simpl; auto; intros.
+symmetry; rewrite <- H1; rewrite <- H; auto.
+symmetry; rewrite <- H1; rewrite <- H; auto.
+rewrite H; rewrite H1; auto.
+Qed.
+
+Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m).
+Proof.
+intros.
+generalize (mem_in_iff m x)(elements_in_iff m x)
+ (existsb_exists (fun p => eqb x (fst p)) (elements m)).
+destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros.
+symmetry; rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (e,He); [ intuition |].
+rewrite InA_alt in He.
+destruct He as ((y,e'),(Ha1,Ha2)).
+compute in Ha1; destruct Ha1; subst e'.
+exists (y,e); split; simpl; auto.
+unfold eqb; destruct (eq_dec x y); intuition.
+rewrite <- H; rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|].
+simpl in Ha2.
+unfold eqb in *; destruct (eq_dec x y); auto; try discriminate.
+exists e; rewrite InA_alt.
+exists (y,e); intuition.
+compute; auto.
+Qed.
+
+End BoolSpec.
+
+End Facts.
diff --git a/theories/FSets/FMapIntMap.v b/theories/FSets/FMapIntMap.v
new file mode 100644
index 00000000..c7681bd4
--- /dev/null
+++ b/theories/FSets/FMapIntMap.v
@@ -0,0 +1,622 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: FMapIntMap.v 8876 2006-05-30 13:43:15Z letouzey $ *)
+
+Require Import Bool.
+Require Import NArith Ndigits Ndec Nnat. 
+Require Import Allmaps.
+Require Import OrderedType.
+Require Import OrderedTypeEx.
+Require Import FMapInterface FMapList.
+
+
+Set Implicit Arguments.
+
+(** * An implementation of [FMapInterface.S] based on [IntMap] *)
+
+(** Keys are of type [N]. The main functions are directly taken from 
+  [IntMap]. Since they have no exact counterpart in [IntMap], functions 
+  [fold], [map2] and [equal] are for now obtained by translation 
+  to sorted lists. *)
+
+(** [N] is an ordered type, using not the usual order on numbers, 
+   but lexicographic ordering on bits (lower bit considered first). *) 
+
+Module NUsualOrderedType <: UsualOrderedType.
+  Definition t:=N.
+  Definition eq:=@eq N.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt p q:= Nless p q = true.
+ 
+  Definition lt_trans := Nless_trans.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite H0 in H.
+  red in H.
+  rewrite Nless_not_refl in H; discriminate.
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  intros x y.
+  destruct (Nless_total x y) as [[H|H]|H].
+  apply LT; unfold lt; auto.
+  apply GT; unfold lt; auto.
+  apply EQ; auto.
+  Qed.
+
+End NUsualOrderedType.
+ 
+
+(** The module of maps over [N] keys based on [IntMap] *)
+
+Module MapIntMap <: S with Module E:=NUsualOrderedType.
+
+  Module E:=NUsualOrderedType.
+  Module ME:=OrderedTypeFacts(E).
+  Module PE:=KeyOrderedType(E).
+
+  Definition key := N.
+
+  Definition t := Map.
+
+  Section A.
+  Variable A:Set.
+
+  Definition empty : t A := M0 A.
+ 
+  Definition is_empty (m : t A) : bool := 
+    MapEmptyp _ (MapCanonicalize _ m).
+
+  Definition find (x:key)(m: t A) : option A := MapGet _ m x.
+
+  Definition mem (x:key)(m: t A) : bool := 
+    match find x m with 
+     | Some _ => true
+     | None => false
+    end.
+
+  Definition add (x:key)(v:A)(m:t A) : t A := MapPut _ m x v.
+  
+  Definition remove (x:key)(m:t A) : t A := MapRemove _ m x.
+
+  Definition elements (m : t A) : list (N*A) := alist_of_Map _ m.
+
+  Definition MapsTo (x:key)(v:A)(m:t A) := find x m = Some v.
+
+  Definition In (x:key)(m:t A) := exists e:A, MapsTo x e m.
+
+  Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m.
+
+  Definition eq_key (p p':key*A) := E.eq (fst p) (fst p').
+      
+  Definition eq_key_elt (p p':key*A) := 
+          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+  Definition lt_key (p p':key*A) := E.lt (fst p) (fst p').
+
+  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
+  Proof.
+  unfold Empty, MapsTo.
+  intuition.
+  generalize (H a).
+  destruct (find a m); intuition.
+  elim (H0 a0); auto.
+  rewrite H in H0; discriminate.
+  Qed.
+
+  Section Spec. 
+  Variable  m m' m'' : t A.
+  Variable x y z : key.
+  Variable e e' : A.
+
+  Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+  Proof. intros; rewrite <- H; auto. Qed.
+
+  Lemma find_1 : MapsTo x e m -> find x m = Some e.
+  Proof. unfold MapsTo; auto. Qed.
+
+  Lemma find_2 : find x m = Some e -> MapsTo x e m.
+  Proof. red; auto. Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  rewrite Empty_alt; intros; unfold empty, find; simpl; auto.
+  Qed.
+
+  Lemma is_empty_1 : Empty m -> is_empty m = true. 
+  Proof.
+  unfold Empty, is_empty, find; intros.
+  cut (MapCanonicalize _ m = M0 _).
+  intros; rewrite H0; simpl; auto.
+  apply mapcanon_unique.
+  apply mapcanon_exists_2.
+  constructor.
+  red; red; simpl; intros.
+  rewrite <- (mapcanon_exists_1 _ m).
+  unfold MapsTo, find in *.
+  generalize (H a).
+  destruct (MapGet _ m a); auto.
+  intros; generalize (H0 a0); destruct 1; auto.
+  Qed.  
+
+  Lemma is_empty_2 : is_empty m = true -> Empty m.
+  Proof.
+  unfold Empty, is_empty, MapsTo, find; intros.
+  generalize (MapEmptyp_complete _ _ H); clear H; intros.
+  rewrite (mapcanon_exists_1 _ m).
+  rewrite H; simpl; auto.
+  discriminate.
+  Qed.
+
+  Lemma mem_1 : In x m -> mem x m = true.
+  Proof.
+  unfold In, MapsTo, mem.
+  destruct (find x m); auto.
+  destruct 1; discriminate.
+  Qed.
+
+  Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+  Proof.
+  unfold In, MapsTo, mem.
+  intros.
+  destruct (find x0 m0); auto; try discriminate.
+  exists a; auto.
+  Qed.
+
+  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
+  Proof.
+  unfold MapsTo, find, add.
+  intro H; rewrite H; clear H.
+  rewrite MapPut_semantics.
+  rewrite Neqb_correct; auto.
+  Qed.
+
+  Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+  Proof.
+  unfold MapsTo, find, add.
+  intros.
+  rewrite MapPut_semantics.
+  rewrite H0.
+  generalize (Neqb_complete x y).
+  destruct (Neqb x y); auto.
+  intros.
+  elim H; auto.
+  apply H1; auto.
+  Qed.
+
+  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+  Proof.
+  unfold MapsTo, find, add.
+  rewrite MapPut_semantics.
+  intro H.
+  generalize (Neqb_complete x y).
+  destruct (Neqb x y); auto.
+  intros; elim H; auto.
+  apply H0; auto.
+  Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
+  Proof. 
+  unfold In, MapsTo, find, remove.
+  rewrite MapRemove_semantics.
+  intro H.
+  rewrite H; rewrite Neqb_correct.
+  red; destruct 1; discriminate.
+  Qed.
+
+  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+  Proof.
+  unfold MapsTo, find, remove.
+  rewrite MapRemove_semantics.
+  intros.
+  rewrite H0.
+  generalize (Neqb_complete x y).
+  destruct (Neqb x y); auto.
+  intros; elim H; apply H1; auto.
+  Qed.
+
+  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
+  Proof. 
+  unfold MapsTo, find, remove.
+  rewrite MapRemove_semantics.
+  destruct (Neqb x y); intros; auto.
+  discriminate.
+  Qed.
+
+  Lemma alist_sorted_sort : forall l, alist_sorted A l=true -> sort lt_key l.
+  Proof.
+  induction l.
+  auto.
+  simpl.
+  destruct a.
+  destruct l.
+  auto.
+  destruct p.
+  intros; destruct (andb_prop _ _ H); auto.
+  Qed.
+
+  Lemma elements_3 : sort lt_key (elements m). 
+  Proof.
+  unfold elements.
+  apply alist_sorted_sort.
+  apply alist_of_Map_sorts.
+  Qed.
+  
+  Lemma elements_1 : 
+     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+  Proof.
+  unfold MapsTo, find, elements.
+  rewrite InA_alt.
+  intro H.
+  exists (x,e).
+  split.
+  red; simpl; unfold E.eq; auto.
+  rewrite alist_of_Map_semantics in H.
+  generalize H.
+  set (l:=alist_of_Map A m); clearbody l; clear.
+  induction l; simpl; auto.
+  intro; discriminate.
+  destruct a; simpl; auto.
+  generalize (Neqb_complete a x).
+  destruct (Neqb a x); auto.
+  left.
+  injection H0; auto.
+  intros; f_equal; auto.
+  Qed.
+
+  Lemma elements_2 : 
+     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+  Proof.
+  generalize elements_3.
+  unfold MapsTo, find, elements.
+  rewrite InA_alt.
+  intros H ((e0,a),(H0,H1)).
+  red in H0; simpl in H0; unfold E.eq in H0; destruct H0; subst.
+  rewrite alist_of_Map_semantics.
+  generalize H H1; clear H H1.
+  set (l:=alist_of_Map A m); clearbody l; clear.
+  induction l; simpl; auto.
+  intro; contradiction.
+  intros.
+  destruct a0; simpl.
+  inversion H1. 
+  injection H0; intros; subst.
+  rewrite Neqb_correct; auto.
+  assert (InA eq_key (e0,a) l).
+  rewrite InA_alt.
+  exists (e0,a); split; auto.
+  red; simpl; auto; red; auto.
+  generalize (PE.Sort_In_cons_1 H H2).
+  unfold PE.ltk; simpl.
+  intros H3; generalize (E.lt_not_eq H3).
+  generalize (Neqb_complete a0 e0).
+  destruct (Neqb a0 e0); auto.
+  destruct 2.
+  apply H4; auto.
+  inversion H; auto.
+  Qed.
+
+  Definition Equal cmp m m' := 
+         (forall k, In k m <-> In k m') /\ 
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+  (** unfortunately, the [MapFold] of [IntMap] isn't compatible with 
+   the FMap interface. We use a naive version for now : *)
+
+  Definition fold (B:Set)(f:key -> A -> B -> B)(m:t A)(i:B) : B := 
+    fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+
+  Lemma fold_1 :
+	forall (B:Set) (i : B) (f : key -> A -> B -> B),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+  Proof. auto. Qed.
+
+  End Spec.
+
+  Variable B : Set.
+
+  Fixpoint mapi_aux (pf:N->N)(f : N -> A -> B)(m:t A) { struct m }: t B := 
+    match m with 
+      | M0 => M0 _ 
+      | M1 x y => M1 _ x (f (pf x) y)
+      | M2 m0 m1 =>  M2 _ (mapi_aux (fun n => pf (Ndouble n)) f m0)
+                                         (mapi_aux (fun n => pf (Ndouble_plus_one n)) f m1)
+    end.
+    
+  Definition mapi := mapi_aux (fun n => n).
+
+  Definition map (f:A->B) := mapi (fun _ => f).
+ 
+  End A.
+
+  Lemma mapi_aux_1 : forall (elt elt':Set)(m: t elt)(pf:N->N)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f (pf y) e) (mapi_aux pf f m).
+  Proof.
+  unfold MapsTo; induction m; simpl; auto.
+  inversion 1.
+
+  intros.
+  exists x; split; [red; auto|].
+  generalize (Neqb_complete a x).
+  destruct (Neqb a x); try discriminate.
+  injection H; intros; subst; auto.
+  rewrite H1; auto.
+
+  intros.
+  exists x; split; [red;auto|].
+  destruct x; simpl in *.
+  destruct (IHm1 (fun n : N => pf (Ndouble n)) _ _ f H) as (y,(Hy,Hy')).
+  rewrite Hy in Hy'; simpl in Hy'; auto.
+  destruct p; simpl in *.
+  destruct (IHm2 (fun n : N => pf (Ndouble_plus_one n)) _ _ f H) as (y,(Hy,Hy')).
+  rewrite Hy in Hy'; simpl in Hy'; auto.
+  destruct (IHm1 (fun n : N => pf (Ndouble n)) _ _ f H) as (y,(Hy,Hy')).
+  rewrite Hy in Hy'; simpl in Hy'; auto.
+  destruct (IHm2 (fun n : N => pf (Ndouble_plus_one n)) _ _ f H) as (y,(Hy,Hy')).
+  rewrite Hy in Hy'; simpl in Hy'; auto.
+  Qed.
+
+  Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+  Proof.
+  intros elt elt' m; exact (mapi_aux_1 (fun n => n)).
+  Qed.
+
+  Lemma mapi_aux_2 : forall (elt elt':Set)(m: t elt)(pf:N->N)(x:key)
+        (f:key->elt->elt'), In x (mapi_aux pf f m) -> In x m.
+  Proof.
+  unfold In, MapsTo.
+  induction m; simpl in *.
+  intros pf x f (e,He); inversion He.
+  intros pf x f (e,He).
+  exists a0.
+  destruct (Neqb a x); try discriminate; auto.
+  intros pf x f (e,He).
+  destruct x; [|destruct p]; eauto.
+  Qed.
+
+  Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+  Proof.
+  intros elt elt' m; exact (mapi_aux_2 m (fun n => n)).
+  Qed.
+
+  Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+  Proof.
+  unfold map; intros.
+  destruct (@mapi_1 _ _ m x e (fun _ => f)) as (e',(_,H0)); auto.
+  Qed.
+
+  Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+        In x (map f m) -> In x m.
+  Proof.
+  unfold map; intros.
+  eapply mapi_2; eauto.
+  Qed.
+
+  Module L := FMapList.Raw E.
+
+  (** Not exactly pretty nor perfect, but should suffice as a first naive implem. 
+    Anyway, map2 isn't in Ocaml...
+  *)
+
+  Definition anti_elements (A:Set)(l:list (key*A)) := L.fold (@add _) l (empty _).
+
+  Definition map2 (A B C:Set)(f:option A->option B -> option C)(m:t A)(m':t B) : t C := 
+    anti_elements (L.map2 f (elements m) (elements m')).
+
+  Lemma add_spec : forall (A:Set)(m:t A) x y e, 
+    find x (add y e m) = if ME.eq_dec x y then Some e else find x m.
+  Proof.
+  intros.
+  destruct (ME.eq_dec x y).
+  apply find_1.
+  eapply MapsTo_1 with y; eauto.
+  red; auto.
+  apply add_1; auto.
+  red; auto.
+  case_eq (find x m); intros.
+  apply find_1.
+  apply add_2; unfold E.eq in *; auto.
+  case_eq (find x (add y e m)); auto; intros.
+  rewrite <- H; symmetry.
+  apply find_1; auto.
+  apply (@add_3 _ m y x a e); unfold E.eq in *; auto.
+  Qed.
+  
+  Lemma anti_elements_mapsto_aux : forall (A:Set)(l:list (key*A)) m k e,
+    NoDupA (eq_key (A:=A)) l -> 
+    (forall x, L.PX.In x l -> In x m -> False) -> 
+    (MapsTo k e (L.fold (@add _) l m) <-> L.PX.MapsTo k e l \/ MapsTo k e m).
+  Proof.
+  induction l. 
+  simpl; auto.
+  intuition.
+  inversion H2.
+  simpl; destruct a; intros.
+  rewrite IHl; clear IHl.
+  inversion H; auto.
+  intros.
+  inversion_clear H.
+  assert (~E.eq x k).
+   swap H3.
+   destruct H1.
+   apply InA_eqA with (x,x0); eauto.
+   unfold eq_key, E.eq; eauto.
+   unfold eq_key, E.eq; congruence.
+  apply (H0 x).
+  destruct H1; exists x0; auto.
+  revert H2.
+  unfold In.
+  intros (e',He').
+  exists e'; apply (@add_3 _ m k x e' a); unfold E.eq; auto.
+  intuition.
+  red in H2.
+  rewrite add_spec in H2; auto.
+  destruct (ME.eq_dec k0 k).
+  inversion_clear H2; subst; auto.
+  right; apply find_2; auto.
+  inversion_clear H2; auto.
+  compute in H1; destruct H1.
+  subst; right; apply add_1; auto.
+  red; auto.
+  inversion_clear H.
+  destruct (ME.eq_dec k0 k).
+  unfold E.eq in *; subst.
+  destruct (H0 k); eauto.
+  red; eauto.
+  right; apply add_2; unfold E.eq in *; auto.
+  Qed.
+  
+  Lemma anti_elements_mapsto : forall (A:Set) l k e, NoDupA (eq_key (A:=A)) l ->
+    (MapsTo k e (anti_elements l) <-> L.PX.MapsTo k e l).
+  Proof. 
+  intros. 
+  unfold anti_elements.
+  rewrite anti_elements_mapsto_aux; auto; unfold empty; auto.
+  inversion 2.
+  inversion H2.
+  intuition.
+  inversion H1.
+  Qed.
+  
+  Lemma find_anti_elements : forall (A:Set)(l: list (key*A)) x, sort (@lt_key _) l -> 
+    find x (anti_elements l) = L.find x l.
+  Proof.
+  intros.
+  case_eq (L.find x l); intros.
+  apply find_1.
+  rewrite anti_elements_mapsto.
+  apply L.PX.Sort_NoDupA; auto.
+  apply L.find_2; auto.
+  case_eq (find x (anti_elements l)); auto; intros.
+  rewrite <- H0; symmetry.
+  apply L.find_1; auto.
+  rewrite <- anti_elements_mapsto.
+  apply L.PX.Sort_NoDupA; auto.
+  apply find_2; auto.
+  Qed.
+
+  Lemma find_elements : forall (A:Set)(m: t A) x,  
+    L.find x (elements m) = find x m.
+  Proof. 
+  intros.
+  case_eq (find x m); intros.
+  apply L.find_1.
+  apply elements_3; auto.
+  red; apply elements_1.
+  apply find_2; auto.
+  case_eq (L.find x (elements m)); auto; intros.
+  rewrite <- H; symmetry.
+  apply find_1; auto.
+  apply elements_2.
+  apply L.find_2; auto.
+  Qed.
+  
+  Lemma elements_in : forall (A:Set)(s:t A) x, L.PX.In x (elements s) <-> In x s.
+  Proof.
+   intros.
+   unfold L.PX.In, In.
+   firstorder.
+   exists x0.
+   red; rewrite <- find_elements; auto.
+   apply L.find_1; auto.
+   apply elements_3.
+   exists x0.
+   apply L.find_2.
+   rewrite find_elements; auto.
+  Qed.
+  
+  Lemma map2_1 : forall (A B C:Set)(m: t A)(m': t B)(x:key)
+    (f:option A->option B ->option C), 
+    In x m \/ In x m' -> find x (map2 f m m') = f (find x m) (find x m').       
+  Proof. 
+  unfold map2; intros.
+  rewrite find_anti_elements; auto.
+  rewrite <- find_elements; auto.
+  rewrite <- find_elements; auto.
+  apply L.map2_1; auto.
+  apply elements_3; auto.
+  apply elements_3; auto.
+  do 2 rewrite elements_in; auto.
+  apply L.map2_sorted; auto.
+  apply elements_3; auto.
+  apply elements_3; auto.
+  Qed.
+  
+  Lemma map2_2 : forall (A B C: Set)(m: t A)(m': t B)(x:key)
+      (f:option A->option B ->option C), 
+    In x (map2 f m m') -> In x m \/ In x m'.
+  Proof.
+  unfold map2; intros.
+  do 2 rewrite <- elements_in.
+  apply L.map2_2 with (f:=f); auto.
+  apply elements_3; auto.
+  apply elements_3; auto.
+  destruct H.
+  exists x0.
+  rewrite <- anti_elements_mapsto; auto.
+  apply L.PX.Sort_NoDupA; auto.
+  apply L.map2_sorted; auto.
+  apply elements_3; auto.
+  apply elements_3; auto.
+  Qed.
+
+  (** same trick for [equal] *)
+
+  Definition equal (A:Set)(cmp:A -> A -> bool)(m m' : t A) : bool := 
+    L.equal cmp (elements m) (elements m').
+  
+  Lemma equal_1 : 
+    forall (A:Set)(m: t A)(m': t A)(cmp: A -> A -> bool), 
+    Equal cmp m m' -> equal cmp m m' = true. 
+  Proof.
+  unfold equal, Equal.
+  intros.
+  apply L.equal_1.
+  apply elements_3.
+  apply elements_3.
+  unfold L.Equal.
+  destruct H.
+  split; intros.
+  do 2 rewrite elements_in; auto.
+  apply (H0 k); 
+    red; rewrite <- find_elements; apply L.find_1; auto; 
+    apply elements_3.
+  Qed.  
+
+  Lemma equal_2 : 
+    forall (A:Set)(m: t A)(m': t A)(cmp: A -> A -> bool), 
+    equal cmp m m' = true -> Equal cmp m m'.
+  Proof.
+  unfold equal, Equal.
+  intros.
+  destruct (L.equal_2 (elements_3 m) (elements_3 m') H); clear H.
+  split.
+  intros; do 2 rewrite <- elements_in; auto.
+  intros; apply (H1 k); 
+    apply L.find_2; rewrite find_elements;auto.
+  Qed.
+
+End MapIntMap.
+
diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v
new file mode 100644
index 00000000..dde74a0a
--- /dev/null
+++ b/theories/FSets/FMapInterface.v
@@ -0,0 +1,245 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMapInterface.v 8671 2006-03-29 08:31:28Z letouzey $ *)
+
+(** * Finite map library *)  
+
+(** This file proposes an interface for finite maps *)
+
+(* begin hide *)
+Set Implicit Arguments.
+Unset Strict Implicit.
+Require Import FSetInterface. 
+(* end hide *)
+
+(** When compared with Ocaml Map, this signature has been split in two: 
+   - The first part [S] contains the usual operators (add, find, ...)
+     It only requires a ordered key type, the data type can be arbitrary. 
+     The only function that asks more is [equal], whose first argument should 
+     be an equality on data. 
+   - Then, [Sord] extends [S] with a complete comparison function. For 
+     that, the data type should have a decidable total ordering. 
+*)
+
+
+Module Type S.
+
+  Declare Module E : OrderedType.
+
+  Definition key := E.t.
+
+  Parameter t : Set -> Set. (** the abstract type of maps *)
+ 
+  Section Types. 
+
+    Variable elt:Set.
+
+    Parameter empty : t elt.
+      (** The empty map. *)
+
+    Parameter is_empty : t elt -> bool.
+    (** Test whether a map is empty or not. *)
+
+    Parameter add : key -> elt -> t elt -> t elt.
+    (** [add x y m] returns a map containing the same bindings as [m], 
+	plus a binding of [x] to [y]. If [x] was already bound in [m], 
+	its previous binding disappears. *)
+
+    Parameter find : key -> t elt -> option elt. 
+    (** [find x m] returns the current binding of [x] in [m], 
+	or raises [Not_found] if no such binding exists.
+	NB: in Coq, the exception mechanism becomes a option type. *)
+
+    Parameter remove : key -> t elt -> t elt.
+    (** [remove x m] returns a map containing the same bindings as [m], 
+	except for [x] which is unbound in the returned map. *)
+
+    Parameter mem : key -> t elt -> bool.
+    (** [mem x m] returns [true] if [m] contains a binding for [x], 
+	and [false] otherwise. *)
+
+    (** Coq comment: [iter] is useless in a purely functional world *)
+    (** val iter : (key -> 'a -> unit) -> 'a t -> unit *)
+    (** iter f m applies f to all bindings in map m. f receives the key as 
+	first argument, and the associated value as second argument. 
+	The bindings are passed to f in increasing order with respect to the 
+	ordering over the type of the keys. Only current bindings are 
+	presented to f: bindings hidden by more recent bindings are not 
+	passed to f. *)
+
+    Variable elt' : Set. 
+    Variable elt'': Set.
+
+    Parameter map : (elt -> elt') -> t elt -> t elt'.
+    (** [map f m] returns a map with same domain as [m], where the associated 
+	value a of all bindings of [m] has been replaced by the result of the
+	application of [f] to [a]. The bindings are passed to [f] in 
+	increasing order with respect to the ordering over the type of the 
+	keys. *)
+
+    Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
+    (** Same as [S.map], but the function receives as arguments both the 
+	key and the associated value for each binding of the map. *)
+
+    Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
+    (** Not present in Ocaml. 
+         [map f m m'] creates a new map whose bindings belong to the ones of either 
+         [m] or [m']. The presence and value for a key [k] is determined by [f e e'] 
+         where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *)
+
+    Parameter elements : t elt -> list (key*elt).
+    (** Not present in Ocaml. 
+         [elements m] returns an assoc list corresponding to the bindings of [m].
+         Elements of this list are sorted with respect to their first components. 
+         Useful to specify [fold] ... *)
+
+    Parameter fold : forall A: Set, (key -> elt -> A -> A) -> t elt -> A -> A.
+    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], 
+	where [k1] ... [kN] are the keys of all bindings in [m] 
+	(in increasing order), and [d1] ... [dN] are the associated data. *)
+
+    Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
+    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, 
+      that is, contain equal keys and associate them with equal data. 
+      [cmp] is the equality predicate used to compare the data associated 
+      with the keys. *)
+
+    Section Spec. 
+      
+      Variable m m' m'' : t elt.
+      Variable x y z : key.
+      Variable e e' : elt.
+
+      Parameter MapsTo : key -> elt -> t elt -> Prop.
+
+      Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.
+
+      Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+
+      Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').
+      
+      Definition eq_key_elt (p p':key*elt) := 
+          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+      Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').
+
+    (** Specification of [MapsTo] *)
+      Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+      
+    (** Specification of [mem] *)
+      Parameter mem_1 : In x m -> mem x m = true.
+      Parameter mem_2 : mem x m = true -> In x m. 
+      
+    (** Specification of [empty] *)
+      Parameter empty_1 : Empty empty.
+
+    (** Specification of [is_empty] *)
+      Parameter is_empty_1 : Empty m -> is_empty m = true. 
+      Parameter is_empty_2 : is_empty m = true -> Empty m.
+      
+    (** Specification of [add] *)
+      Parameter add_1 : E.eq x y -> MapsTo y e (add x e m).
+      Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+      Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+
+    (** Specification of [remove] *)
+      Parameter remove_1 : E.eq x y -> ~ In y (remove x m).
+      Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+      Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
+
+    (** Specification of [find] *)
+      Parameter find_1 : MapsTo x e m -> find x m = Some e. 
+      Parameter find_2 : find x m = Some e -> MapsTo x e m.
+
+    (** Specification of [elements] *)
+      Parameter elements_1 : 
+        MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+      Parameter elements_2 : 
+        InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+      Parameter elements_3 : sort lt_key (elements m).  
+
+    (** Specification of [fold] *)  
+      Parameter fold_1 :
+	forall (A : Set) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ 
+   Definition Equal cmp m m' := 
+         (forall k, In k m <-> In k m') /\ 
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+   Variable cmp : elt -> elt -> bool. 
+
+   (** Specification of [equal] *)
+     Parameter equal_1 : Equal cmp m m' -> equal cmp m m' = true. 
+     Parameter equal_2 : equal cmp m m' = true -> Equal cmp m m'.
+
+    End Spec. 
+   End Types. 
+
+    (** Specification of [map] *)
+      Parameter map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+      Parameter map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+        In x (map f m) -> In x m.
+ 
+    (** Specification of [mapi] *)
+      Parameter mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+      Parameter mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+
+    (** Specification of [map2] *)
+      Parameter map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+	In x m \/ In x m' -> 
+        find x (map2 f m m') = f (find x m) (find x m').       
+
+     Parameter map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+        In x (map2 f m m') -> In x m \/ In x m'.
+
+  (* begin hide *)
+  Hint Immediate MapsTo_1 mem_2 is_empty_2.
+  
+  Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 add_3 remove_1
+    remove_2 remove_3 find_1 find_2 fold_1 map_1 map_2 mapi_1 mapi_2. 
+  (* end hide *)
+
+End S.
+
+
+Module Type Sord.
+ 
+  Declare Module Data : OrderedType.   
+  Declare Module MapS : S. 
+  Import MapS.
+  
+  Definition t := MapS.t Data.t. 
+
+  Parameter eq : t -> t -> Prop.
+  Parameter lt : t -> t -> Prop. 
+ 
+  Axiom eq_refl : forall m : t, eq m m.
+  Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+  Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+  Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+  Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+
+  Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.	
+
+  Parameter eq_1 : forall m m', Equal cmp m m' -> eq m m'.
+  Parameter eq_2 : forall m m', eq m m' -> Equal cmp m m'.
+
+  Parameter compare : forall m1 m2, Compare lt eq m1 m2.
+  (** Total ordering between maps. The first argument (in Coq: Data.compare) 
+      is a total ordering used to compare data associated with equal keys 
+      in the two maps. *)
+
+End Sord.
\ No newline at end of file
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
new file mode 100644
index 00000000..067f5a3e
--- /dev/null
+++ b/theories/FSets/FMapList.v
@@ -0,0 +1,1343 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMapList.v 9035 2006-07-09 15:42:09Z herbelin $ *)
+
+(** * Finite map library *)
+
+(** This file proposes an implementation of the non-dependant interface
+ [FMapInterface.S] using lists of pairs ordered (increasing) with respect to
+ left projection. *)
+
+Require Import FSetInterface. 
+Require Import FMapInterface.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Raw (X:OrderedType).
+
+Module E := X.
+Module MX := OrderedTypeFacts X.
+Module PX := KeyOrderedType X.
+Import MX. 
+Import PX. 
+
+Definition key := X.t.
+Definition t (elt:Set) := list (X.t * elt).
+
+Section Elt.
+Variable elt : Set.
+
+(* Now in KeyOrderedType: 
+Definition eqk (p p':key*elt) := X.eq (fst p) (fst p').
+Definition eqke (p p':key*elt) := 
+        X.eq (fst p) (fst p') /\ (snd p) = (snd p').
+Definition ltk (p p':key*elt) := X.lt (fst p) (fst p').
+Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
+Definition In k m := exists e:elt, MapsTo k e m.
+*)
+
+Notation eqk := (eqk (elt:=elt)).   
+Notation eqke := (eqke (elt:=elt)).
+Notation ltk := (ltk (elt:=elt)).
+Notation MapsTo := (MapsTo (elt:=elt)).
+Notation In := (In (elt:=elt)).
+Notation Sort := (sort ltk).
+Notation Inf := (lelistA (ltk)).
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+
+Lemma empty_1 : Empty empty.
+Proof.  
+ unfold Empty,empty.
+ intros a e.
+ intro abs.
+ inversion abs.
+Qed.
+Hint Resolve empty_1.
+
+Lemma empty_sorted : Sort empty.
+Proof. 
+ unfold empty; auto.
+Qed.
+
+(** * [is_empty] *)
+
+Definition is_empty (l : t elt) : bool := if l then true else false.
+
+Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. 
+Proof.
+ unfold Empty, PX.MapsTo.
+ intros m.
+ case m;auto.
+ intros (k,e) l inlist.
+ absurd (InA eqke (k, e) ((k, e) :: l));auto.
+Qed.
+
+Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+Proof.  
+ intros m.
+ case m;auto.
+ intros p l abs.
+ inversion abs.
+Qed.
+
+(** * [mem] *)
+
+Function mem (k : key) (s : t elt) {struct s} : bool :=
+ match s with
+  | nil => false
+  | (k',_) :: l =>
+     match X.compare k k' with
+      | LT _ => false
+      | EQ _ => true
+      | GT _ => mem k l
+     end
+ end.
+
+Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
+Proof.  
+ intros m Hm x; generalize Hm; clear Hm.      
+ functional induction (mem x m);intros sorted belong1;trivial.
+ 
+ inversion belong1. inversion H.
+ 
+ absurd (In x ((k', _x) :: l));try assumption.
+ apply Sort_Inf_NotIn with _x;auto.
+
+ apply IHb.
+ elim (sort_inv sorted);auto.
+ elim (In_inv belong1);auto.
+ intro abs.
+ absurd (X.eq x k');auto.
+Qed. 
+
+Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. 
+Proof.
+ intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
+ functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail).
+ exists _x; auto. 
+ induction IHb; auto.
+ exists x0; auto.
+ inversion_clear sorted; auto.
+Qed.
+
+(** * [find] *)
+
+Function find (k:key) (s: t elt) {struct s} : option elt :=
+ match s with
+  | nil => None
+  | (k',x)::s' => 
+     match X.compare k k' with
+      | LT _ => None
+      | EQ _ => Some x
+      | GT _ => find k s'
+     end
+ end.
+
+Lemma find_2 :  forall m x e, find x m = Some e -> MapsTo x e m.
+Proof.
+ intros m x. unfold PX.MapsTo.
+ functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
+Qed.
+
+Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. 
+Proof.
+ intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (find x m);simpl; subst; try clear H_eq_1.
+
+ inversion 2.
+
+ inversion_clear 2.
+ clear e1;compute in H0; destruct H0;order.
+ clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
+
+ clear e1;inversion_clear 2.
+ compute in H0; destruct H0; intuition congruence. 
+ generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
+ 
+ clear e1; do 2 inversion_clear 1; auto.
+ compute in H2; destruct H2; order.
+Qed.
+
+(** * [add] *)
+
+Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
+ match s with
+  | nil => (k,x) :: nil
+  | (k',y) :: l =>
+     match X.compare k k' with
+      | LT _ => (k,x)::s
+      | EQ _ => (k,x)::l
+      | GT _ => (k',y) :: add k x l
+     end
+ end.
+
+Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros m x y e; generalize y; clear y.
+ unfold PX.MapsTo.
+ functional induction (add x e m);simpl;auto.
+Qed.
+
+Lemma add_2 : forall m x y e e', 
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros m x  y e e'. 
+ generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction (add x e' m) ;simpl;auto;  clear e0.
+ subst;auto.
+
+ intros y' e'' eqky';  inversion_clear 1;  destruct H0; simpl in *.
+ order.
+ auto.
+ auto.
+ intros y' e'' eqky'; inversion_clear 1; intuition.
+Qed.
+  
+
+Lemma add_3 : forall m x y e e',
+  ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction (add x e' m);simpl; intros.
+ apply (In_inv_3 H0); compute; auto.
+ apply (In_inv_3 H0); compute; auto.
+ constructor 2; apply (In_inv_3 H0); compute; auto. 
+ inversion_clear H0; auto.
+Qed.
+
+
+Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), 
+  Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
+Proof.
+ induction m.  
+ simpl; intuition.
+ intros.
+ destruct a as (x'',e'').
+ inversion_clear H.
+ compute in H0,H1.
+ simpl; case (X.compare x x''); intuition.
+Qed.
+Hint Resolve add_Inf.
+
+Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
+ constructor; auto.
+ apply Inf_eq with (x',e'); auto.
+Qed.  
+
+(** * [remove] *)
+
+Function remove (k : key) (s : t elt) {struct s} : t elt :=
+ match s with
+  | nil => nil
+  | (k',x) :: l =>
+     match X.compare k k' with
+      | LT _ => s
+      | EQ _ => l
+      | GT _ => (k',x) :: remove k l
+     end
+ end.  
+
+Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m).
+Proof.
+ intros m Hm x y; generalize Hm; clear Hm.
+ functional induction (remove x m);simpl;intros;subst.
+ 
+ red; inversion 1; inversion H1.
+
+ apply Sort_Inf_NotIn with x0; auto.
+ clear e0;constructor; compute; order.
+ 
+ clear e0;inversion_clear Hm.
+ apply Sort_Inf_NotIn with x0; auto. 
+ apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto.
+
+ clear e0;inversion_clear Hm.
+ assert (notin:~ In y (remove x l)) by auto.
+ intros (x1,abs).
+ inversion_clear abs. 
+ compute in H2; destruct H2; order.
+ apply notin; exists x1; auto.
+Qed.
+
+
+Lemma remove_2 : forall m (Hm:Sort m) x y e, 
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);subst;auto; 
+   match goal with 
+     | [H: X.compare _ _ = _ |- _ ] => clear H
+     | _ => idtac
+   end.
+
+ inversion_clear 3; auto.
+ compute in H1; destruct H1; order.
+ 
+ inversion_clear 1; inversion_clear 2; auto.
+Qed.
+
+Lemma remove_3 : forall m (Hm:Sort m) x y e, 
+  MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);subst;auto.
+ inversion_clear 1; inversion_clear 1; auto.
+Qed.
+
+Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), 
+  Inf (x',e') m -> Inf (x',e') (remove x m).
+Proof.
+ induction m.  
+ simpl; intuition.
+ intros.
+ destruct a as (x'',e'').
+ inversion_clear H.
+ compute in H0.
+ simpl; case (X.compare x x''); intuition.
+ inversion_clear Hm.
+ apply Inf_lt with (x'',e''); auto.
+Qed.
+Hint Resolve remove_Inf.
+
+Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
+Qed.  
+
+(** * [elements] *)
+
+Definition elements (m: t elt) := m.
+
+Lemma elements_1 : forall m x e, 
+  MapsTo x e m -> InA eqke (x,e) (elements m).
+Proof.
+ auto.
+Qed.
+
+Lemma elements_2 : forall m x e, 
+  InA eqke (x,e) (elements m) -> MapsTo x e m.
+Proof. 
+ auto.
+Qed.
+
+Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). 
+Proof. 
+ auto.
+Qed.
+
+(** * [fold] *)
+
+Function fold (A:Set)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} :  A :=
+  match m with
+   | nil => acc
+   | (k,e)::m' => fold f m' (f k e acc)
+  end.
+
+Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A),
+  fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+Proof. 
+ intros; functional induction (fold f m i); auto.
+Qed.
+
+(** * [equal] *)
+
+Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := 
+  match m, m' with 
+   | nil, nil => true
+   | (x,e)::l, (x',e')::l' => 
+      match X.compare x x' with 
+       | EQ _ => cmp e e' && equal cmp l l'
+       | _    => false
+      end 
+   | _, _ => false 
+  end.
+
+Definition Equal cmp m m' := 
+  (forall k, In k m <-> In k m') /\ 
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, 
+  Equal cmp m m' -> equal cmp m m' = true. 
+Proof. 
+ intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equal;
+ intuition; subst;   match goal with 
+     | [H: X.compare _ _ = _ |- _ ] => clear H
+     | _ => idtac
+   end.
+
+
+
+ assert (cmp_e_e':cmp e e' = true).
+  apply H1 with x; auto.
+ rewrite cmp_e_e'; simpl.
+ apply IHb; auto.
+ inversion_clear Hm; auto.
+ inversion_clear Hm'; auto.
+ unfold Equal; intuition.
+ destruct (H0 k).
+ assert (In k ((x,e) ::l)).
+  destruct H as (e'', hyp); exists e''; auto.
+ destruct (In_inv (H2 H4)); auto.
+ inversion_clear Hm.
+ elim (Sort_Inf_NotIn H6 H7).
+ destruct H as (e'', hyp); exists e''; auto.
+ apply MapsTo_eq with k; auto; order.
+ destruct (H0 k).
+ assert (In k ((x',e') ::l')).
+  destruct H as (e'', hyp); exists e''; auto.
+ destruct (In_inv (H3 H4)); auto.
+ inversion_clear Hm'.
+ elim (Sort_Inf_NotIn H6 H7).
+ destruct H as (e'', hyp); exists e''; auto.
+ apply MapsTo_eq with k; auto; order.
+ apply H1 with k; destruct (eq_dec x k); auto.
+
+
+ destruct (X.compare x x'); try contradiction; clear y.
+ destruct (H0 x).
+ assert (In x ((x',e')::l')). 
+  apply H; auto.
+  exists e; auto.
+ destruct (In_inv H3).
+ order.
+ inversion_clear Hm'.
+ assert (Inf (x,e) l').
+ apply Inf_lt with (x',e'); auto.
+ elim (Sort_Inf_NotIn H5 H7 H4).
+
+ destruct (H0 x').
+ assert (In x' ((x,e)::l)). 
+  apply H2; auto.
+  exists e'; auto.
+ destruct (In_inv H3).
+ order.
+ inversion_clear Hm.
+ assert (Inf (x',e') l).
+  apply Inf_lt with (x,e); auto.
+ elim (Sort_Inf_NotIn H5 H7 H4).
+
+ destruct m;
+ destruct m';try contradiction.
+ 
+ clear H1;destruct p as (k,e).
+ destruct (H0 k).
+ destruct H1.
+ exists e; auto.
+ inversion H1.
+
+ destruct p as (x,e).
+ destruct (H0 x).
+ destruct H.
+ exists e; auto.
+ inversion H.
+
+ destruct p;destruct p0;contradiction.
+Qed.
+
+
+Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, 
+  equal cmp m m' = true -> Equal cmp m m'.
+Proof.
+ intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equal; 
+  intuition; try discriminate; subst; match goal with 
+     | [H: X.compare _ _ = _ |- _ ] => clear H
+     | _ => idtac
+   end. 
+
+ inversion H0.
+
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H. 
+ destruct (IHb H1 H3 H6).
+ destruct (In_inv H0).
+ exists e'; constructor; split; trivial; apply X.eq_trans with x; auto.
+ destruct (H k).
+ destruct (H9 H8) as (e'',hyp).
+ exists e''; auto.
+
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H. 
+ destruct (IHb H1 H3 H6).
+ destruct (In_inv H0).
+ exists e; constructor; split; trivial; apply X.eq_trans with x'; auto.
+ destruct (H k).
+ destruct (H10 H8) as (e'',hyp).
+ exists e''; auto.
+
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H. 
+ destruct (IHb H2 H4 H7).
+ inversion_clear H0.
+ destruct H9; simpl in *; subst.
+ inversion_clear H1. 
+ destruct H9; simpl in *; subst; auto.
+ elim (Sort_Inf_NotIn H4 H5).
+ exists e'0; apply MapsTo_eq with k; auto; order.
+ inversion_clear H1. 
+ destruct H0; simpl in *; subst; auto.
+ elim (Sort_Inf_NotIn H2 H3).
+ exists e0; apply MapsTo_eq with k; auto; order.
+ apply H8 with k; auto.
+Qed. 
+
+(** This lemma isn't part of the spec of [Equal], but is used in [FMapAVL] *)
+
+Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
+  eqk x y -> cmp (snd x) (snd y) = true -> 
+  (Equal cmp l1 l2 <-> Equal cmp (x :: l1) (y :: l2)).
+Proof.
+ intros.
+ inversion H; subst.
+ inversion H0; subst.
+ destruct x; destruct y; compute in H1, H2.
+ split; intros.
+ apply equal_2; auto.
+ simpl.
+ elim_comp.
+ rewrite H2; simpl.
+ apply equal_1; auto.
+ apply equal_2; auto.
+ generalize (equal_1 H H0 H3).
+ simpl.
+ elim_comp.
+ rewrite H2; simpl; auto.
+Qed.
+
+Variable elt':Set.
+
+(** * [map] and [mapi] *)
+  
+Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f e) :: map f m'
+  end.
+
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f k e) :: mapi f m'
+  end.
+
+End Elt.
+Section Elt2. 
+(* A new section is necessary for previous definitions to work 
+   with different [elt], especially [MapsTo]... *)
+  
+Variable elt elt' : Set.
+
+(** Specification of [map] *)
+
+Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), 
+  MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+ intros m x e f.
+ (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+    
+ destruct a as (x',e').
+ simpl. 
+ inversion_clear 1.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ constructor 2.
+ unfold MapsTo in *; auto.
+Qed.
+
+Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), 
+  In x (map f m) -> In x m.
+Proof.
+ intros m x f. 
+ (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+  
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'),
+  lelistA (@ltk elt) (x,e) m -> 
+  lelistA (@ltk elt') (x,e') (map f m).
+Proof. 
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x0,e0).
+ inversion_clear H; auto.
+Qed.
+
+Hint Resolve map_lelistA.
+
+Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), 
+  sort (@ltk elt') (map f m).
+Proof.   
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm.
+ constructor; auto.
+ exact (map_lelistA _ _ H0).
+Qed.      
+ 
+(** Specification of [mapi] *)
+
+Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), 
+  MapsTo x e m -> 
+  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
+Proof.
+ intros m x e f.
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+    
+ destruct a as (x',e').
+ simpl. 
+ inversion_clear 1.
+ exists x'.
+ destruct H0; simpl in *.
+ split; auto.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ destruct IHm as (y, hyp); auto.
+ exists y; intuition.
+Qed.  
+
+
+Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), 
+  In x (mapi f m) -> In x m.
+Proof.
+ intros m x f. 
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+   
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
+  lelistA (@ltk elt) (x,e) m -> 
+  lelistA (@ltk elt') (x,f x e) (mapi f m).
+Proof. 
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear H; auto.
+Qed.
+
+Hint Resolve mapi_lelistA.
+
+Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), 
+  sort (@ltk elt') (mapi f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm; auto.
+Qed.
+
+End Elt2. 
+Section Elt3.
+
+(** * [map2] *)
+
+Variable elt elt' elt'' : Set.
+Variable f : option elt -> option elt' -> option elt''.
+
+Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := 
+  match o with 
+   | Some e => (k,e)::l
+   | None => l
+  end.
+
+Fixpoint map2_l (m : t elt) : t elt'' := 
+  match m with 
+   | nil => nil 
+   | (k,e)::l => option_cons k (f (Some e) None) (map2_l l)
+  end. 
+
+Fixpoint map2_r (m' : t elt') : t elt'' := 
+  match m' with 
+   | nil => nil 
+   | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l')
+  end. 
+
+Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
+  match m with
+   | nil => map2_r 
+   | (k,e) :: l =>
+      fix map2_aux (m' : t elt') : t elt'' :=
+        match m' with
+         | nil => map2_l m
+         | (k',e') :: l' =>
+            match X.compare k k' with
+             | LT _ => option_cons k (f (Some e) None) (map2 l m')
+             | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l')
+             | GT _ => option_cons k' (f None (Some e')) (map2_aux l')
+            end
+        end
+  end.      
+
+Notation oee' := (option elt * option elt')%type.
+
+Fixpoint combine (m : t elt) : t elt' -> t oee' :=
+  match m with
+   | nil => map (fun e' => (None,Some e'))
+   | (k,e) :: l =>
+      fix combine_aux (m':t elt') : list (key * oee') :=
+        match m' with
+         | nil => map (fun e => (Some e,None)) m
+         | (k',e') :: l' =>
+            match X.compare k k' with
+             | LT _ => (k,(Some e, None))::combine l m'
+             | EQ _ => (k,(Some e, Some e'))::combine l l'
+             | GT _ => (k',(None,Some e'))::combine_aux l'
+            end
+        end
+  end. 
+
+Definition fold_right_pair (A B C:Set)(f: A->B->C->C)(l:list (A*B))(i:C) := 
+  List.fold_right (fun p => f (fst p) (snd p)) i l.
+
+Definition map2_alt m m' := 
+  let m0 : t oee' := combine m m' in 
+  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in 
+  fold_right_pair (option_cons (A:=elt'')) m1 nil.
+
+Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'.
+Proof.
+ unfold map2_alt.
+ induction m.
+ simpl; auto; intros.
+ (* map2_r *)
+ induction m'; try destruct a; simpl; auto.
+ rewrite IHm'; auto.
+ (* fin map2_r *)
+ induction m'; destruct a.
+ simpl; f_equal.
+ (* map2_l *)
+ clear IHm.
+ induction m; try destruct a; simpl; auto.
+ rewrite IHm; auto.
+ (* fin map2_l *)
+ destruct a0.
+ simpl.
+ destruct (X.compare t0 t1); simpl; f_equal.
+ apply IHm.
+ apply IHm.
+ apply IHm'.
+Qed.
+
+Lemma combine_lelistA : 
+  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), 
+  lelistA (@ltk elt) (x,e) m -> 
+  lelistA (@ltk elt') (x,e') m' -> 
+  lelistA (@ltk oee') (x,e'') (combine m m').
+Proof.
+ induction m. 
+ intros.
+ simpl.
+ exact (map_lelistA _ _ H0).
+ induction m'. 
+ intros.
+ destruct a.
+ replace (combine ((t0, e0) :: m) nil) with 
+             (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
+ exact (map_lelistA _ _ H).
+ intros.
+ simpl.
+ destruct a as (k,e0); destruct a0 as (k',e0').
+ destruct (X.compare k k').
+ inversion_clear H; auto.
+ inversion_clear H; auto.
+ inversion_clear H0; auto.
+Qed.
+Hint Resolve combine_lelistA.
+
+Lemma combine_sorted : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), 
+  sort (@ltk oee') (combine m m').
+Proof.
+ induction m. 
+ intros; clear Hm.
+ simpl.
+ apply map_sorted; auto.
+ induction m'. 
+ intros; clear Hm'.
+ destruct a.
+ replace (combine ((t0, e) :: m) nil) with 
+             (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
+ apply map_sorted; auto.
+ intros.
+ simpl.
+ destruct a as (k,e); destruct a0 as (k',e').
+ destruct (X.compare k k').
+ inversion_clear Hm.
+ constructor; auto.
+ assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
+ exact (combine_lelistA _ H0 H1). 
+ inversion_clear Hm; inversion_clear Hm'.
+ constructor; auto.
+ assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto).
+ exact (combine_lelistA _ H0 H3). 
+ inversion_clear Hm; inversion_clear Hm'.
+ constructor; auto.
+ change (lelistA (ltk (elt:=oee')) (k', (None, Some e'))
+                 (combine ((k,e)::m) m')).
+ assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto.
+ exact (combine_lelistA _  H3 H2).
+Qed.
+
+Lemma map2_sorted : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), 
+  sort (@ltk elt'') (map2 m m').
+Proof.
+ intros.
+ rewrite <- map2_alt_equiv.
+ unfold map2_alt.
+ assert (H0:=combine_sorted Hm Hm').
+ set (l0:=combine m m') in *; clearbody l0.
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ assert (H1:=map_sorted (elt' := option elt'') H0 f').
+ set (l1:=map f' l0) in *; clearbody l1. 
+ clear f' f H0 l0 Hm Hm' m m'.
+ induction l1.
+ simpl; auto.
+ inversion_clear H1.
+ destruct a; destruct o; auto.
+ simpl.
+ constructor; auto.
+ clear IHl1.
+ induction l1.
+ simpl; auto.
+ destruct a; destruct o; simpl; auto.
+ inversion_clear H0; auto.
+ inversion_clear H0.
+ red in H1; simpl in H1.
+ inversion_clear H.
+ apply IHl1; auto.
+ apply Inf_lt with (t1, None (A:=elt'')); auto.
+Qed.
+ 
+Definition at_least_one (o:option elt)(o':option elt') := 
+  match o, o' with 
+   | None, None => None 
+   | _, _  => Some (o,o')
+  end.
+
+Lemma combine_1 : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), 
+  find x (combine m m') = at_least_one (find x m) (find x m'). 
+Proof.
+ induction m.
+ intros.
+ simpl.
+ induction m'.
+ intros; simpl; auto.
+ simpl; destruct a.
+ simpl; destruct (X.compare x t0); simpl; auto.
+ inversion_clear Hm'; auto.
+ induction m'.
+ (* m' = nil *)
+ intros; destruct a; simpl.
+ destruct (X.compare x t0); simpl; auto.
+ inversion_clear Hm; clear H0 l Hm' IHm t0.
+ induction m; simpl; auto.
+ inversion_clear H.
+ destruct a.
+ simpl; destruct (X.compare x t0); simpl; auto.
+ (* m' <> nil *)
+ intros.
+ destruct a as (k,e); destruct a0 as (k',e'); simpl.
+ inversion Hm; inversion Hm'; subst.
+ destruct (X.compare k k'); simpl;
+  destruct (X.compare x k); 
+   elim_comp || destruct (X.compare x k'); simpl; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
+ rewrite IHm'; auto. 
+ simpl find; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
+ rewrite IHm'; auto. 
+ simpl find; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') = 
+         at_least_one (find x m) (find x m')).
+ rewrite IHm'; auto. 
+ simpl find; elim_comp; auto.
+Qed.
+
+Definition at_least_one_then_f (o:option elt)(o':option elt') := 
+  match o, o' with 
+   | None, None => None 
+   | _, _  => f o o'
+  end.
+
+Lemma map2_0 : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), 
+  find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). 
+Proof.
+ intros.
+ rewrite <- map2_alt_equiv.
+ unfold map2_alt.
+ assert (H:=combine_1 Hm Hm' x).
+ assert (H2:=combine_sorted Hm Hm').
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ set (m0 := combine m m') in *; clearbody m0.
+ set (o:=find x m) in *; clearbody o. 
+ set (o':=find x m') in *; clearbody o'.
+ clear Hm Hm' m m'.
+ generalize H; clear H.
+ match goal with |- ?m=?n -> ?p=?q =>
+   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
+ induction m0; simpl in *; intuition.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct a as (k,(oo,oo')); simpl in *.
+ inversion_clear H2.
+ destruct (X.compare x k); simpl in *.
+ (* x < k *)
+ destruct (f' (oo,oo')); simpl.
+ elim_comp.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct (IHm0 H0) as (H2,_); apply H2; auto.
+ rewrite <- H.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)).
+ exists p; apply find_2; auto.
+ (* x = k *)
+ assert (at_least_one_then_f o o' = f oo oo').
+  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
+ rewrite H2.
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)).
+ exists p; apply find_2; auto.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (H3,_); apply H3; auto.
+ destruct (IHm0 H0) as (H3,_); apply H3; auto.
+
+ (* None -> None *)
+ destruct a as (k,(oo,oo')).
+ simpl.
+ inversion_clear H2.
+ destruct (X.compare x k).
+ (* x < k *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
+ exists p; apply find_2; auto.
+ (* x = k *)
+ discriminate.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+Qed.
+
+(** Specification of [map2] *)
+
+Lemma map2_1 : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
+  In x m \/ In x m' -> 
+  find x (map2 m m') = f (find x m) (find x m'). 
+Proof.
+ intros.
+ rewrite map2_0; auto.
+ destruct H as [(e,H)|(e,H)].
+ rewrite (find_1 Hm H).
+ destruct (find x m'); simpl; auto.
+ rewrite (find_1 Hm' H).
+ destruct (find x m); simpl; auto.
+Qed.
+ 
+Lemma map2_2 : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), 
+  In x (map2 m m') -> In x m \/ In x m'. 
+Proof.
+ intros.
+ destruct H as (e,H).
+ generalize (map2_0 Hm Hm' x).
+ rewrite (find_1 (map2_sorted Hm Hm') H).
+ generalize (@find_2 _ m x).
+ generalize (@find_2 _ m' x).
+ destruct (find x m); 
+   destruct (find x m'); simpl; intros.
+ left; exists e0; auto. 
+ left; exists e0; auto.
+ right; exists e0; auto.
+ discriminate.
+Qed.
+
+End Elt3.
+End Raw.
+
+Module Make (X: OrderedType) <: S with Module E := X.
+Module Raw := Raw X. 
+Module E := X.
+
+Definition key := E.t.
+
+Record slist (elt:Set) : Set :=  
+  {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
+Definition t (elt:Set) : Set := slist elt. 
+
+Section Elt. 
+ Variable elt elt' elt'':Set. 
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key. 
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Build_slist (Raw.empty_sorted elt).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). 
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f).
+ Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f).
+ Definition map2 f m (m':t elt') : t elt'' := 
+   Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)).
+ Definition elements m : list (key*elt) := @Raw.elements elt m.(this).
+ Definition fold (A:Set)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i.
+ Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.PX.In x m.(this).
+ Definition Empty m : Prop := Raw.Empty m.(this).
+ Definition Equal cmp m m' : Prop := @Raw.Equal elt cmp m.(this) m'.(this).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed.
+
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(sorted)). Qed.
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
+ Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(sorted)). Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@Raw.empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed.
+ Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(sorted)). Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(sorted)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed.
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.
+
+ Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed.
+ Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed.
+ Lemma elements_3 : forall m, sort lt_key (elements m).  
+ Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed.
+
+ Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed.
+
+ Lemma equal_1 : forall m m' cmp, Equal cmp m m' -> equal cmp m m' = true. 
+ Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.
+ Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equal cmp m m'.
+ Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.
+
+ End Elt.
+ 
+ Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed.
+ Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+        In x (map f m) -> In x m. 
+ Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed.
+
+ Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed.
+ Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+	In x m \/ In x m' -> 
+        find x (map2 f m m') = f (find x m) (find x m').       
+ Proof. 
+ intros elt elt' elt'' m m' x f; 
+ exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
+ Qed.
+ Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+        In x (map2 f m m') -> In x m \/ In x m'.
+ Proof. 
+ intros elt elt' elt'' m m' x f;  
+ exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
+ Qed.
+
+End Make.
+
+Module Make_ord (X: OrderedType)(D : OrderedType) <: 
+Sord with Module Data := D 
+        with Module MapS.E := X.
+
+Module Data := D.
+Module MapS := Make(X). 
+Import MapS.
+
+Module MD := OrderedTypeFacts(D).
+Import MD.
+
+Definition t := MapS.t D.t. 
+
+Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.
+
+Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := 
+  match m, m' with 
+   | nil, nil => True
+   | (x,e)::l, (x',e')::l' => 
+      match X.compare x x' with 
+       | EQ _ => D.eq e e' /\ eq_list l l'
+       | _       => False
+      end 
+   | _, _ => False
+  end.
+
+Definition eq m m' := eq_list m.(this) m'.(this).
+
+Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := 
+  match m, m' with 
+   | nil, nil => False
+   | nil, _  => True
+   | _, nil  => False
+   | (x,e)::l, (x',e')::l' => 
+      match X.compare x x' with 
+       | LT _ => True
+       | GT _ => False
+       | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l')
+      end
+  end.
+
+Definition lt m m' := lt_list m.(this) m'.(this).
+
+Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true.
+Proof.
+ intros (l,Hl); induction l.
+ intros (l',Hl'); unfold eq; simpl.
+ destruct l'; unfold equal; simpl; intuition.
+ intros (l',Hl'); unfold eq.
+ destruct l'.
+ destruct a; unfold equal; simpl; intuition.
+ destruct a as (x,e).
+ destruct p as (x',e').
+ unfold equal; simpl. 
+ destruct (X.compare x x'); simpl; intuition.
+ unfold cmp at 1. 
+ MD.elim_comp; clear H; simpl.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Build_slist H3)).
+ unfold equal, eq in H5; simpl in H5; auto.
+ destruct (andb_prop _ _ H); clear H.
+ generalize H0; unfold cmp.
+ MD.elim_comp; auto; intro; discriminate.
+ destruct (andb_prop _ _ H); clear H.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Build_slist H3)).
+ unfold equal, eq in H6; simpl in H6; auto.
+Qed.
+
+Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'.
+Proof.
+ intros.
+ generalize (@equal_1 D.t m m' cmp).
+ generalize (@eq_equal m m').
+ intuition.
+Qed.
+
+Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'.
+Proof.
+ intros.
+ generalize (@equal_2 D.t m m' cmp).
+ generalize (@eq_equal m m').
+ intuition.
+Qed.
+
+Lemma eq_refl : forall m : t, eq m m.
+Proof.
+ intros (m,Hm); induction m; unfold eq; simpl; auto.
+ destruct a.
+ destruct (X.compare t0 t0); auto.
+ apply (MapS.Raw.MX.lt_antirefl l); auto.
+ split.
+ apply D.eq_refl.
+ inversion_clear Hm.
+ apply (IHm H).
+ apply (MapS.Raw.MX.lt_antirefl l); auto.
+Qed.
+
+Lemma  eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+Proof.
+ intros (m,Hm); induction m; 
+ intros (m', Hm'); destruct m'; unfold eq; simpl;
+ try destruct a as (x,e); try destruct p as (x',e'); auto.
+ destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition.
+ inversion_clear Hm; inversion_clear Hm'.
+ apply (IHm H0 (Build_slist H4)); auto.
+Qed.
+
+Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+Proof. 
+ intros (m1,Hm1); induction m1; 
+ intros (m2, Hm2); destruct m2; 
+ intros (m3, Hm3); destruct m3; unfold eq; simpl; 
+ try destruct a as (x,e); 
+ try destruct p as (x',e'); 
+ try destruct p0 as (x'',e''); try contradiction; auto.
+ destruct (X.compare x x'); 
+  destruct (X.compare x' x''); 
+   MapS.Raw.MX.elim_comp.
+ intuition.
+ apply D.eq_trans with e'; auto.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition.
+Qed.
+
+Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+Proof.
+ intros (m1,Hm1); induction m1; 
+ intros (m2, Hm2); destruct m2; 
+ intros (m3, Hm3); destruct m3; unfold lt; simpl; 
+ try destruct a as (x,e); 
+ try destruct p as (x',e'); 
+ try destruct p0 as (x'',e''); try contradiction; auto.
+ destruct (X.compare x x'); 
+  destruct (X.compare x' x''); 
+   MapS.Raw.MX.elim_comp; auto.
+ intuition.
+ left; apply D.lt_trans with e'; auto.
+ left; apply lt_eq with e'; auto.
+ left; apply eq_lt with e'; auto.
+ right.
+ split.
+ apply D.eq_trans with e'; auto.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition.
+Qed.
+
+Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+Proof.
+ intros (m1,Hm1); induction m1; 
+ intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; 
+ try destruct a as (x,e); 
+ try destruct p as (x',e'); try contradiction; auto.
+ destruct (X.compare x x'); auto.
+ intuition.
+ exact (D.lt_not_eq H0 H1).
+ inversion_clear Hm1; inversion_clear Hm2.
+ apply (IHm1 H0 (Build_slist H5)); intuition.
+Qed.
+
+Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto.
+
+Definition compare : forall m1 m2, Compare lt eq m1 m2.
+Proof.
+ intros (m1,Hm1); induction m1; 
+ intros (m2, Hm2); destruct m2; 
+  [ apply EQ | apply LT | apply GT | ]; cmp_solve.
+ destruct a as (x,e); destruct p as (x',e'). 
+ destruct (X.compare x x'); 
+  [ apply LT | | apply GT ]; cmp_solve.
+ destruct (D.compare e e'); 
+  [ apply LT | | apply GT ]; cmp_solve.
+ assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1).
+  inversion_clear Hm1; auto.
+ assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2).
+  inversion_clear Hm2; auto.
+ destruct (IHm1 Hm11 (Build_slist Hm22)); 
+  [ apply LT | apply EQ | apply GT ]; cmp_solve.
+Qed.
+
+End Make_ord. 
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
new file mode 100644
index 00000000..911de00e
--- /dev/null
+++ b/theories/FSets/FMapPositive.v
@@ -0,0 +1,1154 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: FMapPositive.v 9178 2006-09-26 11:18:22Z barras $ *)
+
+Require Import Bool.
+Require Import ZArith.
+Require Import OrderedType.
+Require Import FMapInterface.
+
+Set Implicit Arguments.
+
+Open Scope positive_scope.
+
+(** * An implementation of [FMapInterface.S] for positive keys. *)
+
+(** This file is an adaptation to the [FMap] framework of a work by 
+  Xavier Leroy and Sandrine Blazy (used for building certified compilers).
+  Keys are of type [positive], and maps are binary trees: the sequence 
+  of binary digits of a positive number corresponds to a path in such a tree.
+  This is quite similar to the [IntMap] library, except that no path compression 
+  is implemented, and that the current file is simple enough to be 
+  self-contained. *)
+
+(** Even if [positive] can be seen as an ordered type with respect to the 
+  usual order (see [OrderedTypeEx]), we use here a lexicographic order 
+  over bits, which is more natural here (lower bits are considered first). *)
+
+Module PositiveOrderedTypeBits <: OrderedType.
+  Definition t:=positive.
+  Definition eq:=@eq positive.
+
+  Fixpoint bits_lt (p q:positive) { struct p } : Prop := 
+   match p, q with 
+   | xH, xI _ => True
+   | xH, _ => False
+   | xO p, xO q => bits_lt p q
+   | xO _, _ => True
+   | xI p, xI q => bits_lt p q
+   | xI _, _ => False
+   end.
+
+  Definition lt:=bits_lt.
+
+  Lemma eq_refl : forall x : t, eq x x.
+  Proof. red; auto. Qed.
+
+  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
+  Proof. red; auto. Qed.
+
+  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
+  Proof. red; intros; transitivity y; auto. Qed.
+
+  Lemma bits_lt_trans : forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
+  Proof.
+  induction x.
+  induction y; destruct z; simpl; eauto; intuition.
+  induction y; destruct z; simpl; eauto; intuition.
+  induction y; destruct z; simpl; eauto; intuition.
+  Qed.
+ 
+  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Proof. 
+  exact bits_lt_trans.
+  Qed.
+
+  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
+  Proof.
+  induction x; simpl; auto.
+  Qed.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite <- H0 in H; clear H0 y.
+  unfold lt in H.
+  exact (bits_lt_antirefl x H).
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  induction x; destruct y.
+  (* I I *)
+  destruct (IHx y).
+  apply LT; auto.
+  apply EQ; rewrite e; red; auto.
+  apply GT; auto.
+  (* I O *)
+  apply GT; simpl; auto.
+  (* I H *)
+  apply GT; simpl; auto.
+  (* O I *)
+  apply LT; simpl; auto.
+  (* O O *)
+  destruct (IHx y).
+  apply LT; auto.
+  apply EQ; rewrite e; red; auto.
+  apply GT; auto.
+  (* O H *) 
+  apply LT; simpl; auto.
+  (* H I *)
+  apply LT; simpl; auto.
+  (* H O *)
+  apply GT; simpl; auto.
+  (* H H *)
+  apply EQ; red; auto.
+  Qed.
+
+End PositiveOrderedTypeBits.
+
+(** Other positive stuff *)
+
+Lemma peq_dec (x y: positive): {x = y} + {x <> y}.
+Proof.
+  intros. case_eq ((x ?= y) Eq); intros.
+  left. apply Pcompare_Eq_eq; auto.
+  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
+  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
+Qed.
+ 
+Fixpoint append (i j : positive) {struct i} : positive :=
+    match i with
+      | xH => j
+      | xI ii => xI (append ii j)
+      | xO ii => xO (append ii j)
+    end.
+
+Lemma append_assoc_0 : 
+  forall (i j : positive), append i (xO j) = append (append i (xO xH)) j.
+Proof.
+ induction i; intros; destruct j; simpl;
+ try rewrite (IHi (xI j));
+ try rewrite (IHi (xO j));
+ try rewrite <- (IHi xH);
+ auto.
+Qed.
+
+Lemma append_assoc_1 : 
+  forall (i j : positive), append i (xI j) = append (append i (xI xH)) j.
+Proof.
+ induction i; intros; destruct j; simpl;
+ try rewrite (IHi (xI j));
+ try rewrite (IHi (xO j));
+ try rewrite <- (IHi xH);
+ auto.
+Qed.
+
+Lemma append_neutral_r : forall (i : positive), append i xH = i.
+Proof.
+ induction i; simpl; congruence.
+Qed.
+
+Lemma append_neutral_l : forall (i : positive), append xH i = i.
+Proof.
+ simpl; auto.
+Qed.
+ 
+
+(** The module of maps over positive keys *)
+
+Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
+
+  Module E:=PositiveOrderedTypeBits.
+
+  Definition key := positive.
+
+  Inductive tree (A : Set) : Set :=
+    | Leaf : tree A
+    | Node : tree A -> option A -> tree A -> tree A.
+
+  Definition t := tree.
+
+  Section A.
+  Variable A:Set.
+
+  Implicit Arguments Leaf [A].
+
+  Definition empty : t A := Leaf.
+ 
+  Fixpoint is_empty (m : t A) {struct m} : bool := 
+   match m with 
+    | Leaf => true
+    | Node l None r => (is_empty l) && (is_empty r)
+    | _ => false
+   end.
+
+  Fixpoint find (i : positive) (m : t A) {struct i} : option A :=
+    match m with
+    | Leaf => None
+    | Node l o r =>
+        match i with
+        | xH => o
+        | xO ii => find ii l
+        | xI ii => find ii r
+        end
+    end.
+
+  Fixpoint mem (i : positive) (m : t A) {struct i} : bool :=
+    match m with
+    | Leaf => false
+    | Node l o r =>
+        match i with
+        | xH => match o with None => false | _ => true end
+        | xO ii => mem ii l
+        | xI ii => mem ii r
+        end
+    end.
+
+  Fixpoint add (i : positive) (v : A) (m : t A) {struct i} : t A :=
+    match m with
+    | Leaf =>
+        match i with
+        | xH => Node Leaf (Some v) Leaf
+        | xO ii => Node (add ii v Leaf) None Leaf
+        | xI ii => Node Leaf None (add ii v Leaf)
+        end
+    | Node l o r =>
+        match i with
+        | xH => Node l (Some v) r
+        | xO ii => Node (add ii v l) o r
+        | xI ii => Node l o (add ii v r)
+        end
+    end.
+
+  Fixpoint remove (i : positive) (m : t A) {struct i} : t A :=
+    match i with
+    | xH =>
+        match m with
+        | Leaf => Leaf
+        | Node Leaf o Leaf => Leaf
+        | Node l o r => Node l None r
+        end
+    | xO ii =>
+        match m with
+        | Leaf => Leaf
+        | Node l None Leaf =>
+            match remove ii l with
+            | Leaf => Leaf
+            | mm => Node mm None Leaf
+            end
+        | Node l o r => Node (remove ii l) o r
+        end
+    | xI ii =>
+        match m with
+        | Leaf => Leaf
+        | Node Leaf None r =>
+            match remove ii r with
+            | Leaf => Leaf
+            | mm => Node Leaf None mm
+            end
+        | Node l o r => Node l o (remove ii r)
+        end
+    end.
+
+  (** [elements] *)
+
+    Fixpoint xelements (m : t A) (i : positive) {struct m}
+             : list (positive * A) :=
+      match m with
+      | Leaf => nil
+      | Node l None r =>
+          (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH)))
+      | Node l (Some x) r =>
+          (xelements l (append i (xO xH)))
+          ++ ((i, x) :: xelements r (append i (xI xH)))
+      end.
+
+  (* Note: function [xelements] above is inefficient.  We should apply
+     deforestation to it, but that makes the proofs even harder. *)
+
+  Definition elements (m : t A) := xelements m xH.
+
+  Section CompcertSpec.
+
+  Theorem gempty:
+    forall (i: positive), find i empty = None.
+  Proof.
+    destruct i; simpl; auto.
+  Qed.
+
+  Theorem gss:
+    forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x.
+  Proof.
+    induction i; destruct m; simpl; auto.
+  Qed.
+
+  Lemma gleaf : forall (i : positive), find i (Leaf : t A) = None.
+  Proof. exact gempty. Qed.
+
+  Theorem gso:
+    forall (i j: positive) (x: A) (m: t A),
+    i <> j -> find i (add j x m) = find i m.
+  Proof.
+    induction i; intros; destruct j; destruct m; simpl;
+       try rewrite <- (gleaf i); auto; try apply IHi; congruence.
+  Qed.
+
+  Lemma rleaf : forall (i : positive), remove i (Leaf : t A) = Leaf.
+  Proof. destruct i; simpl; auto. Qed.
+
+  Theorem grs:
+    forall (i: positive) (m: t A), find i (remove i m) = None.
+  Proof.
+    induction i; destruct m.
+     simpl; auto.
+     destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto.
+      rewrite (rleaf i); auto.
+      cut (find i (remove i (Node ll oo rr)) = None).
+        destruct (remove i (Node ll oo rr)); auto; apply IHi.
+        apply IHi.
+     simpl; auto.
+     destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto.
+      rewrite (rleaf i); auto.
+      cut (find i (remove i (Node ll oo rr)) = None).
+        destruct (remove i (Node ll oo rr)); auto; apply IHi.
+        apply IHi.
+     simpl; auto.
+     destruct m1; destruct m2; simpl; auto.
+  Qed.
+
+  Theorem gro:
+    forall (i j: positive) (m: t A),
+    i <> j -> find i (remove j m) = find i m.
+  Proof.
+    induction i; intros; destruct j; destruct m;
+        try rewrite (rleaf (xI j));
+        try rewrite (rleaf (xO j));
+        try rewrite (rleaf 1); auto;
+        destruct m1; destruct o; destruct m2;
+        simpl;
+        try apply IHi; try congruence;
+        try rewrite (rleaf j); auto;
+        try rewrite (gleaf i); auto.
+     cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2));
+        [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto
+        | apply IHi; congruence ].
+     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
+        auto.
+     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
+        auto.
+     cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2));
+        [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto
+        | apply IHi; congruence ].
+     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
+        auto.
+     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
+        auto.
+  Qed.
+
+  Lemma xelements_correct:
+      forall (m: t A) (i j : positive) (v: A),
+      find i m = Some v -> List.In (append j i, v) (xelements m j).
+    Proof.
+      induction m; intros.
+       rewrite (gleaf i) in H; congruence.
+       destruct o; destruct i; simpl; simpl in H.
+        rewrite append_assoc_1; apply in_or_app; right; apply in_cons;
+          apply IHm2; auto.
+        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
+        rewrite append_neutral_r; apply in_or_app; injection H;
+          intro EQ; rewrite EQ; right; apply in_eq.
+        rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto.
+        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
+        congruence.
+    Qed.
+
+  Theorem elements_correct:
+    forall (m: t A) (i: positive) (v: A),
+    find i m = Some v -> List.In (i, v) (elements m).
+  Proof.
+    intros m i v H.
+    exact (xelements_correct m i xH H).
+  Qed.
+
+  Fixpoint xfind (i j : positive) (m : t A) {struct j} : option A :=
+      match i, j with
+      | _, xH => find i m
+      | xO ii, xO jj => xfind ii jj m
+      | xI ii, xI jj => xfind ii jj m
+      | _, _ => None
+      end.
+
+   Lemma xfind_left :
+      forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A),
+      xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v.
+    Proof.
+      induction j; intros; destruct i; simpl; simpl in H; auto; try congruence.
+      destruct i; congruence.
+    Qed.
+
+    Lemma xelements_ii :
+      forall (m: t A) (i j : positive) (v: A),
+      List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
+         apply in_or_app.
+        left; apply IHm1; auto.
+        right; destruct (in_inv H0).
+         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
+         apply in_cons; apply IHm2; auto.
+        left; apply IHm1; auto.
+        right; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_io :
+      forall (m: t A) (i j : positive) (v: A),
+      ~List.In (xI i, v) (xelements m (xO j)).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        apply (IHm1 _ _ _ H0).
+        destruct (in_inv H0).
+         congruence.
+         apply (IHm2 _ _ _ H1).
+        apply (IHm1 _ _ _ H0).
+        apply (IHm2 _ _ _ H0).
+    Qed.
+
+    Lemma xelements_oo :
+      forall (m: t A) (i j : positive) (v: A),
+      List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
+         apply in_or_app.
+        left; apply IHm1; auto.
+        right; destruct (in_inv H0).
+         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
+         apply in_cons; apply IHm2; auto.
+        left; apply IHm1; auto.
+        right; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_oi :
+      forall (m: t A) (i j : positive) (v: A),
+      ~List.In (xO i, v) (xelements m (xI j)).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        apply (IHm1 _ _ _ H0).
+        destruct (in_inv H0).
+         congruence.
+         apply (IHm2 _ _ _ H1).
+        apply (IHm1 _ _ _ H0).
+        apply (IHm2 _ _ _ H0).
+    Qed.
+
+    Lemma xelements_ih :
+      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
+      List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH).
+    Proof.
+      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
+        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
+        destruct (in_inv H0).
+         congruence.
+         apply xelements_ii; auto.
+        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
+        apply xelements_ii; auto.
+    Qed.
+
+    Lemma xelements_oh :
+      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
+      List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH).
+    Proof.
+      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
+        apply xelements_oo; auto.
+        destruct (in_inv H0).
+         congruence.
+         absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
+        apply xelements_oo; auto.
+        absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
+    Qed.
+
+    Lemma xelements_hi :
+      forall (m: t A) (i : positive) (v: A),
+      ~List.In (xH, v) (xelements m (xI i)).
+    Proof.
+      induction m; intros.
+       simpl; auto.
+       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        generalize H0; apply IHm1; auto.
+        destruct (in_inv H0).
+         congruence.
+         generalize H1; apply IHm2; auto.
+        generalize H0; apply IHm1; auto.
+        generalize H0; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_ho :
+      forall (m: t A) (i : positive) (v: A),
+      ~List.In (xH, v) (xelements m (xO i)).
+    Proof.
+      induction m; intros.
+       simpl; auto.
+       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        generalize H0; apply IHm1; auto.
+        destruct (in_inv H0).
+         congruence.
+         generalize H1; apply IHm2; auto.
+        generalize H0; apply IHm1; auto.
+        generalize H0; apply IHm2; auto.
+    Qed.
+
+    Lemma find_xfind_h :
+      forall (m: t A) (i: positive), find i m = xfind i xH m.
+    Proof.
+      destruct i; simpl; auto.
+    Qed.
+
+    Lemma xelements_complete:
+      forall (i j : positive) (m: t A) (v: A),
+      List.In (i, v) (xelements m j) -> xfind i j m = Some v.
+    Proof.
+      induction i; simpl; intros; destruct j; simpl.
+       apply IHi; apply xelements_ii; auto.
+       absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io.
+       destruct m.
+        simpl in H; tauto.
+        rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H).
+       absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi.
+       apply IHi; apply xelements_oo; auto.
+       destruct m.
+        simpl in H; tauto.
+        rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H).
+       absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi.
+       absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho.
+       destruct m.
+        simpl in H; tauto.
+        destruct o; simpl in H; destruct (in_app_or _ _ _ H).
+         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
+         destruct (in_inv H0).
+          congruence.
+          absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
+         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
+         absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
+    Qed.
+
+  Theorem elements_complete:
+    forall (m: t A) (i: positive) (v: A),
+    List.In (i, v) (elements m) -> find i m = Some v.
+  Proof.
+    intros m i v H.
+    unfold elements in H.
+    rewrite find_xfind_h.
+    exact (xelements_complete i xH m v H).
+  Qed.
+
+  End CompcertSpec.
+
+  Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v.
+
+  Definition In (i:positive)(m:t A) := exists e:A, MapsTo i e m.
+
+  Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m.
+
+  Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p').
+      
+  Definition eq_key_elt (p p':positive*A) := 
+          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+  Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p').
+
+  Lemma mem_find : 
+    forall m x, mem x m = match find x m with None => false | _ => true end.
+  Proof.
+  induction m; destruct x; simpl; auto.
+  Qed.
+
+  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
+  Proof.
+  unfold Empty, MapsTo.
+  intuition.
+  generalize (H a).
+  destruct (find a m); intuition.
+  elim (H0 a0); auto.
+  rewrite H in H0; discriminate.
+  Qed.
+
+  Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r.
+  Proof.
+  intros l o r.
+  split.
+  rewrite Empty_alt.
+  split.
+  destruct o; auto.
+  generalize (H 1); simpl; auto.
+  split; rewrite Empty_alt; intros.
+  generalize (H (xO a)); auto.
+  generalize (H (xI a)); auto.
+  intros (H,(H0,H1)).
+  subst.
+  rewrite Empty_alt; intros.
+  destruct a; auto.
+  simpl; generalize H1; rewrite Empty_alt; auto.
+  simpl; generalize H0; rewrite Empty_alt; auto.
+  Qed.
+
+  Section FMapSpec. 
+
+  Lemma mem_1 : forall m x, In x m -> mem x m = true.
+  Proof.
+  unfold In, MapsTo; intros m x; rewrite mem_find.
+  destruct 1 as (e0,H0); rewrite H0; auto.
+  Qed.
+
+  Lemma mem_2 : forall m x, mem x m = true -> In x m. 
+  Proof.
+  unfold In, MapsTo; intros m x; rewrite mem_find.
+  destruct (find x m).
+  exists a; auto.
+  intros; discriminate.
+  Qed.
+
+  Variable  m m' m'' : t A.
+  Variable x y z : key.
+  Variable e e' : A.
+
+  Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+  Proof. intros; rewrite <- H; auto. Qed.
+
+  Lemma find_1 : MapsTo x e m -> find x m = Some e.
+  Proof. unfold MapsTo; auto. Qed.
+
+  Lemma find_2 : find x m = Some e -> MapsTo x e m.
+  Proof. red; auto. Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  rewrite Empty_alt; apply gempty.
+  Qed.
+
+  Lemma is_empty_1 : Empty m -> is_empty m = true. 
+  Proof.
+  induction m; simpl; auto.
+  rewrite Empty_Node.
+  intros (H,(H0,H1)).
+  subst; simpl.
+  rewrite IHt0_1; simpl; auto.
+  Qed.
+
+  Lemma is_empty_2 : is_empty m = true -> Empty m.
+  Proof.
+  induction m; simpl; auto.
+  rewrite Empty_alt.
+  intros _; exact gempty.
+  rewrite Empty_Node.
+  destruct o.
+  intros; discriminate.
+  intro H; destruct (andb_prop _ _ H); intuition.
+  Qed.
+
+  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite H; clear H.
+  apply gss.
+  Qed.
+
+  Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+  Proof.
+  unfold MapsTo.
+  intros; rewrite gso; auto.
+  Qed.
+
+  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite gso; auto.
+  Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
+  Proof. 
+  intros; intro.
+  generalize (mem_1 H0).
+  rewrite mem_find.
+  rewrite H.
+  rewrite grs.
+  intros; discriminate.
+  Qed.
+
+  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite gro; auto.
+  Qed.
+
+  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
+  Proof. 
+  unfold MapsTo.
+  destruct (peq_dec x y).
+  subst.
+  rewrite grs; intros; discriminate.
+  rewrite gro; auto.
+  Qed.
+  
+  Lemma elements_1 : 
+     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+  Proof.
+  unfold MapsTo.
+  rewrite InA_alt.
+  intro H.
+  exists (x,e).
+  split.
+  red; simpl; unfold E.eq; auto.
+  apply elements_correct; auto.
+  Qed.
+
+  Lemma elements_2 : 
+     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+  Proof.
+  unfold MapsTo.
+  rewrite InA_alt.
+  intros ((e0,a),(H,H0)).
+  red in H; simpl in H; unfold E.eq in H; destruct H; subst.
+  apply elements_complete; auto.
+  Qed.
+
+  Lemma xelements_bits_lt_1 : forall p p0 q m v, 
+     List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p.
+  Proof.
+  intros.
+  generalize (xelements_complete _ _ _ _ H); clear H; intros.
+  revert p0 q m v H.
+  induction p; destruct p0; simpl; intros; eauto; try discriminate.
+  Qed.
+
+  Lemma xelements_bits_lt_2 : forall p p0 q m v, 
+     List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0.
+  Proof.
+  intros.
+  generalize (xelements_complete _ _ _ _ H); clear H; intros.
+  revert p0 q m v H.
+  induction p; destruct p0; simpl; intros; eauto; try discriminate.
+  Qed.
+
+  Lemma xelements_sort : forall p, sort lt_key (xelements m p).
+  Proof.
+  induction m.
+  simpl; auto.
+  destruct o; simpl; intros.
+  (* Some *)
+  apply (SortA_app (eqA:=eq_key_elt)); auto.
+  compute; intuition.
+  constructor; auto.
+  apply In_InfA; intros.
+  destruct y0.
+  red; red; simpl.
+  eapply xelements_bits_lt_2; eauto.
+  intros x0 y0.
+  do 2 rewrite InA_alt.
+  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
+  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
+  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
+  red; red; simpl.
+  destruct H0.
+  injection H0; clear H0; intros _ H0; subst.
+  eapply xelements_bits_lt_1; eauto.
+  apply E.bits_lt_trans with p.
+  eapply xelements_bits_lt_1; eauto.
+  eapply xelements_bits_lt_2; eauto.
+  (* None *)
+  apply (SortA_app (eqA:=eq_key_elt)); auto.
+  compute; intuition.
+  intros x0 y0.
+  do 2 rewrite InA_alt.
+  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
+  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
+  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
+  red; red; simpl.
+  apply E.bits_lt_trans with p.
+  eapply xelements_bits_lt_1; eauto.
+  eapply xelements_bits_lt_2; eauto.
+  Qed.
+
+  Lemma elements_3 : sort lt_key (elements m). 
+  Proof.
+  unfold elements.
+  apply xelements_sort; auto.
+  Qed.
+
+  End FMapSpec.
+
+  (** [map] and [mapi] *)
+ 
+  Variable B : Set.
+
+  Fixpoint xmapi (f : positive -> A -> B) (m : t A) (i : positive)
+             {struct m} : t B :=
+     match m with
+      | Leaf => @Leaf B
+      | Node l o r => Node (xmapi f l (append i (xO xH)))
+                           (option_map (f i) o)
+                           (xmapi f r (append i (xI xH)))
+     end.
+
+  Definition mapi (f : positive -> A -> B) m := xmapi f m xH.
+
+  Definition map (f : A -> B) m := mapi (fun _ => f) m.
+
+  End A.
+
+  Lemma xgmapi:
+      forall (A B: Set) (f: positive -> A -> B) (i j : positive) (m: t A),
+      find i (xmapi f m j) = option_map (f (append j i)) (find i m).
+  Proof.
+  induction i; intros; destruct m; simpl; auto.
+  rewrite (append_assoc_1 j i); apply IHi.
+  rewrite (append_assoc_0 j i); apply IHi.
+  rewrite (append_neutral_r j); auto.
+  Qed.
+
+  Theorem gmapi:
+    forall (A B: Set) (f: positive -> A -> B) (i: positive) (m: t A),
+    find i (mapi f m) = option_map (f i) (find i m).
+  Proof.
+  intros.
+  unfold mapi.
+  replace (f i) with (f (append xH i)).
+  apply xgmapi.
+  rewrite append_neutral_l; auto.
+  Qed.
+
+  Lemma mapi_1 : 
+    forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), 
+    MapsTo x e m -> 
+    exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+  Proof.
+  intros.
+  exists x.
+  split; [red; auto|].
+  apply find_2.
+  generalize (find_1 H); clear H; intros.
+  rewrite gmapi.
+  rewrite H.
+  simpl; auto.
+  Qed.
+
+  Lemma mapi_2 : 
+    forall (elt elt':Set)(m: t elt)(x:key)(f:key->elt->elt'), 
+    In x (mapi f m) -> In x m.
+  Proof.
+  intros.
+  apply mem_2.
+  rewrite mem_find.
+  destruct H as (v,H).
+  generalize (find_1 H); clear H; intros.
+  rewrite gmapi in H.
+  destruct (find x m); auto.
+  simpl in *; discriminate.
+  Qed.
+
+  Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+    MapsTo x e m -> MapsTo x (f e) (map f m).
+  Proof.
+  intros; unfold map.
+  destruct (mapi_1 (fun _ => f) H); intuition.
+  Qed.
+  
+  Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+    In x (map f m) -> In x m.
+  Proof.
+  intros; unfold map in *; eapply mapi_2; eauto.
+  Qed.
+
+  Section map2.
+  Variable A B C : Set.
+  Variable f : option A -> option B -> option C.
+  
+  Implicit Arguments Leaf [A].
+
+  Fixpoint xmap2_l (m : t A) {struct m} : t C :=
+      match m with
+      | Leaf => Leaf
+      | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r)
+      end.
+
+  Lemma xgmap2_l : forall (i : positive) (m : t A),
+          f None None = None -> find i (xmap2_l m) = f (find i m) None.
+    Proof.
+      induction i; intros; destruct m; simpl; auto.
+    Qed.
+
+  Fixpoint xmap2_r (m : t B) {struct m} : t C :=
+      match m with
+      | Leaf => Leaf
+      | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r)
+      end.
+
+  Lemma xgmap2_r : forall (i : positive) (m : t B),
+          f None None = None -> find i (xmap2_r m) = f None (find i m).
+    Proof.
+      induction i; intros; destruct m; simpl; auto.
+    Qed.
+
+  Fixpoint _map2 (m1 : t A)(m2 : t B) {struct m1} : t C :=
+    match m1 with
+    | Leaf => xmap2_r m2
+    | Node l1 o1 r1 =>
+        match m2 with
+        | Leaf => xmap2_l m1
+        | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2)
+        end
+    end.
+
+    Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B),
+      f None None = None ->
+      find i (_map2 m1 m2) = f (find i m1) (find i m2).
+    Proof.
+      induction i; intros; destruct m1; destruct m2; simpl; auto;
+      try apply xgmap2_r; try apply xgmap2_l; auto.
+    Qed.
+
+  End map2.
+
+  Definition map2 (elt elt' elt'':Set)(f:option elt->option elt'->option elt'') := 
+   _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end).
+
+  Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''), 
+    In x m \/ In x m' -> 
+    find x (map2 f m m') = f (find x m) (find x m'). 
+  Proof. 
+  intros.
+  unfold map2.
+  rewrite gmap2; auto.
+  generalize (@mem_1 _ m x) (@mem_1 _ m' x).
+  do 2 rewrite mem_find.
+  destruct (find x m); simpl; auto.
+  destruct (find x m'); simpl; auto.
+  intros.
+  destruct H; intuition; try discriminate.
+  Qed.
+
+  Lemma  map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''), 
+    In x (map2 f m m') -> In x m \/ In x m'.
+  Proof.
+  intros.
+  generalize (mem_1 H); clear H; intros.
+  rewrite mem_find in H.
+  unfold map2 in H.
+  rewrite gmap2 in H; auto.
+  generalize (@mem_2 _ m x) (@mem_2 _ m' x).
+  do 2 rewrite mem_find.
+  destruct (find x m); simpl in *; auto.
+  destruct (find x m'); simpl in *; auto.
+  Qed.
+
+
+  Definition fold (A B : Set) (f: positive -> A -> B -> B) (tr: t A) (v: B) :=
+     List.fold_left (fun a p => f (fst p) (snd p) a) (elements tr) v.
+  
+  Lemma fold_1 :
+    forall (A:Set)(m:t A)(B:Set)(i : B) (f : key -> A -> B -> B),
+    fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+  Proof.
+  intros; unfold fold; auto.
+  Qed.
+
+  Fixpoint equal (A:Set)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := 
+    match m1, m2 with 
+      | Leaf, _ => is_empty m2
+      | _, Leaf => is_empty m1
+      | Node l1 o1 r1, Node l2 o2 r2 => 
+           (match o1, o2 with 
+             | None, None => true
+             | Some v1, Some v2 => cmp v1 v2
+             | _, _ => false
+            end)
+           && equal cmp l1 l2 && equal cmp r1 r2
+     end.
+
+  Definition Equal (A:Set)(cmp:A->A->bool)(m m':t A) := 
+    (forall k, In k m <-> In k m') /\ 
+    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+  Lemma equal_1 : forall (A:Set)(m m':t A)(cmp:A->A->bool), 
+    Equal cmp m m' -> equal cmp m m' = true. 
+  Proof. 
+  induction m.
+  (* m = Leaf *)
+  destruct 1. 
+  simpl.
+  apply is_empty_1.
+  red; red; intros.
+  assert (In a (Leaf A)).
+  rewrite H.
+  exists e; auto.
+  destruct H2; red in H2.
+  destruct a; simpl in *; discriminate.
+  (* m = Node *)
+  destruct m'.
+  (* m' = Leaf *)
+  destruct 1. 
+  simpl.
+  destruct o.
+  assert (In xH (Leaf A)).
+  rewrite <- H.
+  exists a; red; auto.
+  destruct H1; red in H1; simpl in H1; discriminate.
+  apply andb_true_intro; split; apply is_empty_1; red; red; intros.
+  assert (In (xO a) (Leaf A)).
+  rewrite <- H.
+  exists e; auto.
+  destruct H2; red in H2; simpl in H2; discriminate.
+  assert (In (xI a) (Leaf A)).
+  rewrite <- H.
+  exists e; auto.
+  destruct H2; red in H2; simpl in H2; discriminate.
+  (* m' = Node *)
+  destruct 1.
+  assert (Equal cmp m1 m'1).
+    split.
+    intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto.
+    intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto.
+  assert (Equal cmp m2 m'2).
+    split.
+    intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto.
+    intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto.
+  simpl.
+  destruct o; destruct o0; simpl.
+  repeat (apply andb_true_intro; split); auto.
+  apply (H0 xH); red; auto.
+  generalize (H xH); unfold In, MapsTo; simpl; intuition.
+  destruct H4; try discriminate; eauto.
+  generalize (H xH); unfold In, MapsTo; simpl; intuition.
+  destruct H5; try discriminate; eauto.
+  apply andb_true_intro; split; auto.
+  Qed.
+
+  Lemma equal_2 : forall (A:Set)(m m':t A)(cmp:A->A->bool), 
+    equal cmp m m' = true -> Equal cmp m m'. 
+  Proof. 
+  induction m.
+  (* m = Leaf *)
+  simpl.
+  split; intros.
+  split.
+  destruct 1; red in H0; destruct k; discriminate.
+  destruct 1; elim (is_empty_2 H H0).
+  red in H0; destruct k; discriminate.
+  (* m = Node *)
+  destruct m'.
+  (* m' = Leaf *)
+  simpl.
+  destruct o; intros; try discriminate.
+  destruct (andb_prop _ _ H); clear H.
+  split; intros.
+  split; unfold In, MapsTo; destruct 1.
+  destruct k; simpl in *; try discriminate.
+  destruct (is_empty_2 H1 (find_2 _ _ H)).
+  destruct (is_empty_2 H0 (find_2 _ _ H)).
+  destruct k; simpl in *; discriminate.
+  unfold In, MapsTo; destruct k; simpl in *; discriminate.
+  (* m' = Node *)
+  destruct o; destruct o0; simpl; intros; try discriminate.
+  destruct (andb_prop _ _ H); clear H.
+  destruct (andb_prop _ _ H0); clear H0.
+  destruct (IHm1 _ _ H2); clear H2 IHm1.
+  destruct (IHm2 _ _ H1); clear H1 IHm2.
+  split; intros.
+  destruct k; unfold In, MapsTo in *; simpl; auto.
+  split; eauto.
+  destruct k; unfold In, MapsTo in *; simpl in *.
+  eapply H4; eauto.
+  eapply H3; eauto.
+  congruence.
+  destruct (andb_prop _ _ H); clear H.
+  destruct (IHm1 _ _ H0); clear H0 IHm1.
+  destruct (IHm2 _ _ H1); clear H1 IHm2.
+  split; intros.
+  destruct k; unfold In, MapsTo in *; simpl; auto.
+  split; eauto.
+  destruct k; unfold In, MapsTo in *; simpl in *.
+  eapply H3; eauto.
+  eapply H2; eauto.
+  try discriminate.
+  Qed.
+
+End PositiveMap.
+
+(** Here come some additionnal facts about this implementation.
+  Most are facts that cannot be derivable from the general interface. *)
+
+
+Module PositiveMapAdditionalFacts.
+  Import PositiveMap.
+
+  (* Derivable from the Map interface *)
+  Theorem gsspec:
+    forall (A:Set)(i j: positive) (x: A) (m: t A),
+    find i (add j x m) = if peq_dec i j then Some x else find i m.
+  Proof.
+    intros.
+    destruct (peq_dec i j); [ rewrite e; apply gss | apply gso; auto ].
+  Qed.
+
+   (* Not derivable from the Map interface *)
+  Theorem gsident:
+    forall (A:Set)(i: positive) (m: t A) (v: A),
+    find i m = Some v -> add i v m = m.
+  Proof.
+    induction i; intros; destruct m; simpl; simpl in H; try congruence.
+     rewrite (IHi m2 v H); congruence.
+     rewrite (IHi m1 v H); congruence.
+  Qed.
+  
+  Lemma xmap2_lr :
+      forall (A B : Set)(f g: option A -> option A -> option B)(m : t A),
+      (forall (i j : option A), f i j = g j i) ->
+      xmap2_l f m = xmap2_r g m.
+    Proof.
+      induction m; intros; simpl; auto.
+      rewrite IHm1; auto.
+      rewrite IHm2; auto.
+      rewrite H; auto.
+    Qed.
+
+  Theorem map2_commut:
+    forall (A B: Set) (f g: option A -> option A -> option B),
+    (forall (i j: option A), f i j = g j i) ->
+    forall (m1 m2: t A),
+    _map2 f m1 m2 = _map2 g m2 m1.
+  Proof.
+    intros A B f g Eq1.
+    assert (Eq2: forall (i j: option A), g i j = f j i).
+      intros; auto.
+    induction m1; intros; destruct m2; simpl;
+      try rewrite Eq1;
+      repeat rewrite (xmap2_lr f g);
+      repeat rewrite (xmap2_lr g f);
+      auto.
+     rewrite IHm1_1.
+     rewrite IHm1_2.
+     auto. 
+  Qed.
+
+End PositiveMapAdditionalFacts.
+
diff --git a/contrib7/ring/Setoid_ring.v b/theories/FSets/FMapWeak.v
index 222104e5..1ad190a4 100644
--- a/contrib7/ring/Setoid_ring.v
+++ b/theories/FSets/FMapWeak.v
@@ -1,13 +1,15 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
 
-(* $Id: Setoid_ring.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+(* $Id: FMapWeak.v 8844 2006-05-22 17:22:36Z letouzey $ *)
 
-Require Export Setoid_ring_theory.
-Require Export Quote.
-Require Export Setoid_ring_normalize.
+Require Export DecidableType.
+Require Export DecidableTypeEx.
+Require Export FMapWeakInterface.
+Require Export FMapWeakList.
+Require Export FMapWeakFacts.
\ No newline at end of file
diff --git a/theories/FSets/FMapWeakFacts.v b/theories/FSets/FMapWeakFacts.v
new file mode 100644
index 00000000..18f73a3f
--- /dev/null
+++ b/theories/FSets/FMapWeakFacts.v
@@ -0,0 +1,599 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMapWeakFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
+
+(** * Finite maps library *)
+
+(** This functor derives additional facts from [FMapWeakInterface.S]. These
+  facts are mainly the specifications of [FMapWeakInterface.S] written using 
+  different styles: equivalence and boolean equalities. 
+*)
+
+Require Import Bool.
+Require Import OrderedType.
+Require Export FMapWeakInterface. 
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Facts (M: S).
+Import M.
+Import Logic. (* to unmask [eq] *)  
+Import Peano. (* to unmask [lt] *)
+
+Lemma MapsTo_fun : forall (elt:Set) m x (e e':elt), 
+  MapsTo x e m -> MapsTo x e' m -> e=e'.
+Proof.
+intros.
+generalize (find_1 H) (find_1 H0); clear H H0.
+intros; rewrite H in H0; injection H0; auto.
+Qed.
+
+(** * Specifications written using equivalences *)
+
+Section IffSpec. 
+Variable elt elt' elt'': Set.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m).
+Proof.
+split; apply MapsTo_1; auto.
+Qed.
+
+Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m).
+Proof.
+unfold In.
+split; intros (e0,H0); exists e0.
+apply (MapsTo_1 H H0); auto.
+apply (MapsTo_1 (E.eq_sym H) H0); auto.
+Qed.
+
+Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e.
+Proof.
+split; [apply find_1|apply find_2].
+Qed.
+
+Lemma not_find_mapsto_iff : forall m x, ~In x m <-> find x m = None.
+Proof.
+intros.
+generalize (find_mapsto_iff m x); destruct (find x m).
+split; intros; try discriminate.
+destruct H0.
+exists e; rewrite H; auto.
+split; auto.
+intros; intros (e,H1).
+rewrite H in H1; discriminate.
+Qed.
+
+Lemma mem_in_iff : forall m x, In x m <-> mem x m = true.
+Proof.
+split; [apply mem_1|apply mem_2].
+Qed.
+
+Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false.
+Proof.
+intros; rewrite mem_in_iff; destruct (mem x m); intuition.
+Qed.
+
+Lemma equal_iff : forall m m' cmp, Equal cmp m m' <-> equal cmp m m' = true.
+Proof. 
+split; [apply equal_1|apply equal_2].
+Qed.
+
+Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False.
+Proof.
+intuition; apply (empty_1 H).
+Qed.
+
+Lemma empty_in_iff : forall x, In x (empty elt) <-> False.
+Proof.
+unfold In.
+split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition.
+Qed.
+
+Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. 
+Proof. 
+split; [apply is_empty_1|apply is_empty_2].
+Qed.
+
+Lemma add_mapsto_iff : forall m x y e e', 
+  MapsTo y e' (add x e m) <-> 
+     (E.eq x y /\ e=e') \/ 
+     (~E.eq x y /\ MapsTo y e' m).
+Proof. 
+intros.
+intuition.
+destruct (E.eq_dec x y); [left|right].
+split; auto.
+symmetry; apply (MapsTo_fun (e':=e) H); auto.
+split; auto; apply add_3 with x e; auto.
+subst; auto.
+Qed.
+
+Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m.
+Proof. 
+unfold In; split.
+intros (e',H).
+destruct (E.eq_dec x y) as [E|E]; auto.
+right; exists e'; auto.
+apply (add_3 E H).
+destruct (E.eq_dec x y) as [E|E]; auto.
+intros.
+exists e; apply add_1; auto.
+intros [H|(e',H)].
+destruct E; auto.
+exists e'; apply add_2; auto.
+Qed.
+
+Lemma add_neq_mapsto_iff : forall m x y e e', 
+ ~ E.eq x y -> (MapsTo y e' (add x e m)  <-> MapsTo y e' m).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma add_neq_in_iff : forall m x y e, 
+ ~ E.eq x y -> (In y (add x e m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (add_3 H H0).
+apply add_2; auto.
+Qed.
+
+Lemma remove_mapsto_iff : forall m x y e, 
+  MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m.
+Proof. 
+intros.
+split; intros.
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+apply remove_3 with x; auto.
+apply remove_2; intuition.
+Qed.
+
+Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m.
+Proof. 
+unfold In; split.
+intros (e,H).
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+exists e; apply remove_3 with x; auto.
+intros (H,(e,H0)); exists e; apply remove_2; auto.
+Qed.
+
+Lemma remove_neq_mapsto_iff : forall m x y e, 
+ ~ E.eq x y -> (MapsTo y e (remove x m)  <-> MapsTo y e m).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma remove_neq_in_iff : forall m x y, 
+ ~ E.eq x y -> (In y (remove x m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (remove_3 H0).
+apply remove_2; auto.
+Qed.
+
+Lemma elements_mapsto_iff : forall m x e, 
+ MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m).
+Proof. 
+split; [apply elements_1 | apply elements_2].
+Qed.
+
+Lemma elements_in_iff : forall m x, 
+ In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m).
+Proof. 
+unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto.
+Qed.
+
+Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), 
+ MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m.
+Proof.
+split.
+case_eq (find x m); intros.
+exists e.
+split.
+apply (MapsTo_fun (m:=map f m) (x:=x)); auto.
+apply find_2; auto.
+assert (In x (map f m)) by (exists b; auto).
+destruct (map_2 H1) as (a,H2).
+rewrite (find_1 H2) in H; discriminate.
+intros (a,(H,H0)).
+subst b; auto.
+Qed.
+
+Lemma map_in_iff : forall m x (f : elt -> elt'), 
+ In x (map f m) <-> In x m.
+Proof.
+split; intros; eauto.
+destruct H as (a,H).
+exists (f a); auto.
+Qed.
+
+Lemma mapi_in_iff : forall m x (f:key->elt->elt'),
+ In x (mapi f m) <-> In x m.
+Proof.
+split; intros; eauto.
+destruct H as (a,H).
+destruct (mapi_1 f H) as (y,(H0,H1)).
+exists (f y a); auto.
+Qed.
+
+(* Unfortunately, we don't have simple equivalences for [mapi] 
+  and [MapsTo]. The only correct one needs compatibility of [f]. *) 
+
+Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), 
+ MapsTo x b (mapi f m) -> 
+ exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m.
+Proof.
+intros; case_eq (find x m); intros.
+exists e.
+destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)).
+apply find_2; auto.
+exists y; repeat split; auto.
+apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto.
+assert (In x (mapi f m)) by (exists b; auto).
+destruct (mapi_2 H1) as (a,H2).
+rewrite (find_1 H2) in H0; discriminate.
+Qed.
+
+Lemma mapi_1bis : forall m x e (f:key->elt->elt'), 
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ MapsTo x e m -> MapsTo x (f x e) (mapi f m).
+Proof.
+intros.
+destruct (mapi_1 f H0) as (y,(H1,H2)).
+replace (f x e) with (f y e) by auto.
+auto.
+Qed.
+
+Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m).
+Proof.
+split.
+intros.
+destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))).
+exists a; split; auto.
+subst b; auto.
+intros (a,(H0,H1)).
+subst b.
+apply mapi_1bis; auto.
+Qed.
+
+(** Things are even worse for [map2] : we don't try to state any 
+ equivalence, see instead boolean results below. *)
+
+End IffSpec.
+
+(** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *)
+  
+Ltac map_iff := 
+ repeat (progress (
+  rewrite add_mapsto_iff || rewrite add_in_iff ||
+  rewrite remove_mapsto_iff || rewrite remove_in_iff ||
+  rewrite empty_mapsto_iff || rewrite empty_in_iff ||
+  rewrite map_mapsto_iff || rewrite map_in_iff ||
+  rewrite mapi_in_iff)).
+
+(**  * Specifications written using boolean predicates *)
+
+Section BoolSpec.
+
+Definition eqb x y := if E.eq_dec x y then true else false.
+
+Lemma mem_find_b : forall (elt:Set)(m:t elt)(x:key), mem x m = if find x m then true else false. 
+Proof.
+intros.
+generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In.
+destruct (find x m); destruct (mem x m); auto.
+intros.
+rewrite <- H0; exists e; rewrite H; auto.
+intuition.
+destruct H0 as (e,H0).
+destruct (H e); intuition discriminate.
+Qed.
+
+Variable elt elt' elt'' : Set.
+Implicit Types m : t elt.
+Implicit Types x y z : key.
+Implicit Types e : elt.
+
+Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m.
+Proof. 
+intros.
+generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H).
+destruct (mem x m); destruct (mem y m); intuition.
+Qed.
+
+Lemma find_o : forall m x y, E.eq x y -> find x m = find y m.
+Proof.
+intros.
+generalize (find_mapsto_iff m x) (find_mapsto_iff m y) (fun e => MapsTo_iff m e H).
+destruct (find x m); destruct (find y m); intros.
+rewrite <- H0; rewrite H2; rewrite H1; auto.
+symmetry; rewrite <- H1; rewrite <- H2; rewrite H0; auto.
+rewrite <- H0; rewrite H2; rewrite H1; auto.
+auto.
+Qed.
+
+Lemma empty_o : forall x, find x (empty elt) = None.
+Proof.
+intros.
+case_eq (find x (empty elt)); intros; auto.
+generalize (find_2 H).
+rewrite empty_mapsto_iff; intuition.
+Qed.
+
+Lemma empty_a : forall x, mem x (empty elt) = false.
+Proof.
+intros.
+case_eq (mem x (empty elt)); intros; auto.
+generalize (mem_2 H).
+rewrite empty_in_iff; intuition.
+Qed.
+
+Lemma add_eq_o : forall m x y e, 
+ E.eq x y -> find y (add x e m) = Some e.
+Proof.
+auto.
+Qed.
+
+Lemma add_neq_o : forall m x y e, 
+ ~ E.eq x y -> find y (add x e m) = find y m. 
+Proof.
+intros.
+case_eq (find y m); intros; auto.
+case_eq (find y (add x e m)); intros; auto.
+rewrite <- H0; symmetry.
+apply find_1; apply add_3 with x e; auto.
+Qed.
+Hint Resolve add_neq_o.
+
+Lemma add_o : forall m x y e, 
+ find y (add x e m) = if E.eq_dec x y then Some e else find y m.
+Proof.
+intros; destruct (E.eq_dec x y); auto.
+Qed.
+
+Lemma add_eq_b : forall m x y e, 
+ E.eq x y -> mem y (add x e m) = true.
+Proof.
+intros; rewrite mem_find_b; rewrite add_eq_o; auto.
+Qed.
+
+Lemma add_neq_b : forall m x y e, 
+ ~E.eq x y -> mem y (add x e m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto.
+Qed.
+
+Lemma add_b : forall m x y e, 
+ mem y (add x e m) = eqb x y || mem y m. 
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb.
+destruct (E.eq_dec x y); simpl; auto.
+Qed.
+
+Lemma remove_eq_o : forall m x y, 
+ E.eq x y -> find y (remove x m) = None.
+Proof.
+intros.
+generalize (remove_1 (m:=m) H).
+generalize (find_mapsto_iff (remove x m) y).
+destruct (find y (remove x m)); auto.
+destruct 2.
+exists e; rewrite H0; auto.
+Qed.
+Hint Resolve remove_eq_o.
+
+Lemma remove_neq_o : forall m x y, 
+ ~ E.eq x y -> find y (remove x m) = find y m. 
+Proof.
+intros.
+case_eq (find y m); intros; auto.
+case_eq (find y (remove x m)); intros; auto.
+rewrite <- H0; symmetry.
+apply find_1; apply remove_3 with x; auto.
+Qed.
+Hint Resolve remove_neq_o.
+
+Lemma remove_o : forall m x y, 
+ find y (remove x m) = if E.eq_dec x y then None else find y m.
+Proof.
+intros; destruct (E.eq_dec x y); auto.
+Qed.
+
+Lemma remove_eq_b : forall m x y, 
+ E.eq x y -> mem y (remove x m) = false.
+Proof.
+intros; rewrite mem_find_b; rewrite remove_eq_o; auto.
+Qed.
+
+Lemma remove_neq_b : forall m x y, 
+ ~ E.eq x y -> mem y (remove x m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto.
+Qed.
+
+Lemma remove_b : forall m x y, 
+ mem y (remove x m) = negb (eqb x y) && mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb.
+destruct (E.eq_dec x y); auto.
+Qed.
+
+Definition option_map (A:Set)(B:Set)(f:A->B)(o:option A) : option B := 
+ match o with 
+  | Some a => Some (f a)
+  | None => None
+ end.
+
+Lemma map_o : forall m x (f:elt->elt'), 
+ find x (map f m) = option_map f (find x m). 
+Proof.
+intros.
+generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x)
+  (fun b => map_mapsto_iff m x b f).
+destruct (find x (map f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H; rewrite H1; exists e0; rewrite H0; auto.
+destruct (H e) as [_ H2].
+rewrite H1 in H2.
+destruct H2 as (a,(_,H2)); auto.
+rewrite H0 in H2; discriminate.
+rewrite <- H; rewrite H1; exists e; rewrite H0; auto.
+Qed.
+
+Lemma map_b : forall m x (f:elt->elt'), 
+ mem x (map f m) = mem x m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite map_o.
+destruct (find x m); simpl; auto.
+Qed.
+
+Lemma mapi_b : forall m x (f:key->elt->elt'), 
+ mem x (mapi f m) = mem x m.
+Proof.
+intros.
+generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f).
+destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros.
+symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto.
+rewrite <- H; rewrite H1; rewrite H0; auto.
+Qed.
+
+Lemma mapi_o : forall m x (f:key->elt->elt'), 
+ (forall x y e, E.eq x y -> f x e = f y e) -> 
+ find x (mapi f m) = option_map (f x) (find x m).
+Proof.
+intros.
+generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) 
+  (fun b => mapi_mapsto_iff m x b H).
+destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto.
+destruct (H0 e) as [_ H3].
+rewrite H2 in H3.
+destruct H3 as (a,(_,H3)); auto.
+rewrite H1 in H3; discriminate.
+rewrite <- H0; rewrite H2; exists e; rewrite H1; auto.
+Qed.
+
+Lemma map2_1bis : forall (m: t elt)(m': t elt') x 
+ (f:option elt->option elt'->option elt''), 
+ f None None = None -> 
+ find x (map2 f m m') = f (find x m) (find x m').       
+Proof.
+intros.
+case_eq (find x m); intros.
+rewrite <- H0.
+apply map2_1; auto.
+left; exists e; auto.
+case_eq (find x m'); intros.
+rewrite <- H0; rewrite <- H1.
+apply map2_1; auto.
+right; exists e; auto.
+rewrite H.
+case_eq (find x (map2 f m m')); intros; auto.
+assert (In x (map2 f m m')) by (exists e; auto).
+destruct (map2_2 H3) as [(e0,H4)|(e0,H4)].
+rewrite (find_1 H4) in H0; discriminate.
+rewrite (find_1 H4) in H1; discriminate.
+Qed.
+
+Fixpoint findA (A B:Set)(f : A -> bool) (l:list (A*B)) : option B := 
+ match l with  
+  | nil => None 
+  | (a,b)::l => if f a then Some b else findA f l
+ end.
+
+Lemma findA_NoDupA : 
+ forall (A B:Set)
+ (eqA:A->A->Prop)
+ (eqA_sym: forall a b, eqA a b -> eqA b a)
+ (eqA_trans: forall a b c, eqA a b -> eqA b c -> eqA a c)
+ (eqA_dec : forall a a', { eqA a a' }+{~eqA a a' }) 
+ (l:list (A*B))(x:A)(e:B),  
+ NoDupA (fun p p' => eqA (fst p) (fst p')) l -> 
+ (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (x,e) l <->
+  findA (fun y:A => if eqA_dec x y then true else false) l = Some e).
+Proof.
+induction l; simpl; intros.
+split; intros; try discriminate.
+inversion H0.
+destruct a as (y,e').
+inversion_clear H.
+split; intros.
+inversion_clear H.
+simpl in *; destruct H2; subst e'.
+destruct (eqA_dec x y); intuition.
+destruct (eqA_dec x y); simpl.
+destruct H0.
+generalize e0 H2 eqA_trans eqA_sym; clear.
+induction l.
+inversion 2.
+inversion_clear 2; intros; auto.
+destruct a.
+compute in H; destruct H.
+subst b.
+constructor 1; auto.
+simpl.
+apply eqA_trans with x; auto.
+rewrite <- IHl; auto.
+destruct (eqA_dec x y); simpl in *.
+inversion H; clear H; intros; subst e'; auto.
+constructor 2.
+rewrite IHl; auto.
+Qed.
+
+Lemma elements_o : forall m x, 
+ find x m = findA (eqb x) (elements m).
+Proof.
+intros.
+assert (forall e, find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x,e) (elements m)).
+ intros; rewrite <- find_mapsto_iff; apply elements_mapsto_iff.
+assert (NoDupA (eq_key (elt:=elt)) (elements m)). 
+ exact (elements_3 m).
+generalize (fun e => @findA_NoDupA _ _ _ E.eq_sym E.eq_trans E.eq_dec (elements m) x e H0).
+unfold eqb.
+destruct (find x m); destruct (findA (fun y : E.t => if E.eq_dec x y then true else false) (elements m)); 
+ simpl; auto; intros.
+symmetry; rewrite <- H1; rewrite <- H; auto.
+symmetry; rewrite <- H1; rewrite <- H; auto.
+rewrite H; rewrite H1; auto.
+Qed.
+
+Lemma elements_b : forall m x, mem x m = existsb (fun p => eqb x (fst p)) (elements m).
+Proof.
+intros.
+generalize (mem_in_iff m x)(elements_in_iff m x)
+ (existsb_exists (fun p => eqb x (fst p)) (elements m)).
+destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros.
+symmetry; rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (e,He); [ intuition |].
+rewrite InA_alt in He.
+destruct He as ((y,e'),(Ha1,Ha2)).
+compute in Ha1; destruct Ha1; subst e'.
+exists (y,e); split; simpl; auto.
+unfold eqb; destruct (E.eq_dec x y); intuition.
+rewrite <- H; rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|].
+simpl in Ha2.
+unfold eqb in *; destruct (E.eq_dec x y); auto; try discriminate.
+exists e; rewrite InA_alt.
+exists (y,e); intuition.
+compute; auto.
+Qed.
+
+End BoolSpec.
+
+End Facts.
diff --git a/theories/FSets/FMapWeakInterface.v b/theories/FSets/FMapWeakInterface.v
new file mode 100644
index 00000000..b6df4da5
--- /dev/null
+++ b/theories/FSets/FMapWeakInterface.v
@@ -0,0 +1,201 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMapWeakInterface.v 8639 2006-03-16 19:21:55Z letouzey $ *)
+
+(** * Finite map library *) 
+
+(** This file proposes an interface for finite maps over keys with decidable 
+     equality, but no decidable order. *)
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+Require Import FSetInterface. 
+Require Import FSetWeakInterface. 
+
+Module Type S.
+
+  Declare Module E : DecidableType.
+
+  Definition key := E.t.
+
+  Parameter t : Set -> Set. (** the abstract type of maps *)
+ 
+  Section Types. 
+
+    Variable elt:Set.
+
+    Parameter empty : t elt.
+      (** The empty map. *)
+
+    Parameter is_empty : t elt -> bool.
+    (** Test whether a map is empty or not. *)
+
+    Parameter add : key -> elt -> t elt -> t elt.
+    (** [add x y m] returns a map containing the same bindings as [m], 
+	plus a binding of [x] to [y]. If [x] was already bound in [m], 
+	its previous binding disappears. *)
+
+    Parameter find : key -> t elt -> option elt. 
+    (** [find x m] returns the current binding of [x] in [m], 
+	or raises [Not_found] if no such binding exists.
+	NB: in Coq, the exception mechanism becomes a option type. *)
+
+    Parameter remove : key -> t elt -> t elt.
+    (** [remove x m] returns a map containing the same bindings as [m], 
+	except for [x] which is unbound in the returned map. *)
+
+    Parameter mem : key -> t elt -> bool.
+    (** [mem x m] returns [true] if [m] contains a binding for [x], 
+	and [false] otherwise. *)
+
+    (** Coq comment: [iter] is useless in a purely functional world *)
+    (** val iter : (key -> 'a -> unit) -> 'a t -> unit *)
+    (** iter f m applies f to all bindings in map m. f receives the key as 
+	first argument, and the associated value as second argument. 
+	The bindings are passed to f in increasing order with respect to the 
+	ordering over the type of the keys. Only current bindings are 
+	presented to f: bindings hidden by more recent bindings are not 
+	passed to f. *)
+
+    Variable elt' : Set. 
+    Variable elt'': Set.
+
+    Parameter map : (elt -> elt') -> t elt -> t elt'.
+    (** [map f m] returns a map with same domain as [m], where the associated 
+	value a of all bindings of [m] has been replaced by the result of the
+	application of [f] to [a]. The bindings are passed to [f] in 
+	increasing order with respect to the ordering over the type of the 
+	keys. *)
+
+    Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
+    (** Same as [S.map], but the function receives as arguments both the 
+	key and the associated value for each binding of the map. *)
+
+    Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
+    (** Not present in Ocaml. 
+         [map f m m'] creates a new map whose bindings belong to the ones of either 
+         [m] or [m']. The presence and value for a key [k] is determined by [f e e'] 
+         where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *)
+
+    Parameter elements : t elt -> list (key*elt).
+    (** Not present in Ocaml. 
+         [elements m] returns an assoc list corresponding to the bindings of [m].
+         Elements of this list are sorted with respect to their first components. 
+         Useful to specify [fold] ... *)
+
+    Parameter fold : forall A: Set, (key -> elt -> A -> A) -> t elt -> A -> A.
+    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], 
+	where [k1] ... [kN] are the keys of all bindings in [m] 
+	(in increasing order), and [d1] ... [dN] are the associated data. *)
+
+    Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
+    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, 
+      that is, contain equal keys and associate them with equal data. 
+      [cmp] is the equality predicate used to compare the data associated 
+      with the keys. *)
+
+    Section Spec. 
+      
+      Variable m m' m'' : t elt.
+      Variable x y z : key.
+      Variable e e' : elt.
+
+      Parameter MapsTo : key -> elt -> t elt -> Prop.
+
+      Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.
+
+      Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+
+      Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').
+      
+      Definition eq_key_elt (p p':key*elt) := 
+          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+    (** Specification of [MapsTo] *)
+      Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+      
+    (** Specification of [mem] *)
+      Parameter mem_1 : In x m -> mem x m = true.
+      Parameter mem_2 : mem x m = true -> In x m. 
+      
+    (** Specification of [empty] *)
+      Parameter empty_1 : Empty empty.
+
+    (** Specification of [is_empty] *)
+      Parameter is_empty_1 : Empty m -> is_empty m = true. 
+      Parameter is_empty_2 : is_empty m = true -> Empty m.
+      
+    (** Specification of [add] *)
+      Parameter add_1 : E.eq x y -> MapsTo y e (add x e m).
+      Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+      Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+
+    (** Specification of [remove] *)
+      Parameter remove_1 : E.eq x y -> ~ In y (remove x m).
+      Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+      Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
+
+    (** Specification of [find] *)
+      Parameter find_1 : MapsTo x e m -> find x m = Some e. 
+      Parameter find_2 : find x m = Some e -> MapsTo x e m.
+
+    (** Specification of [elements] *)
+      Parameter elements_1 : 
+        MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+      Parameter elements_2 : 
+        InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+      Parameter elements_3 : NoDupA eq_key (elements m).  
+
+    (** Specification of [fold] *)  
+      Parameter fold_1 :
+	forall (A : Set) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ 
+   Definition Equal cmp m m' := 
+         (forall k, In k m <-> In k m') /\ 
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+   Variable cmp : elt -> elt -> bool. 
+
+   (** Specification of [equal] *)
+     Parameter equal_1 : Equal cmp m m' -> equal cmp m m' = true. 
+     Parameter equal_2 : equal cmp m m' = true -> Equal cmp m m'.
+
+    End Spec. 
+   End Types. 
+
+    (** Specification of [map] *)
+      Parameter map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+      Parameter map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+        In x (map f m) -> In x m.
+ 
+    (** Specification of [mapi] *)
+      Parameter mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+      Parameter mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+
+    (** Specification of [map2] *)
+      Parameter map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+	In x m \/ In x m' -> 
+        find x (map2 f m m') = f (find x m) (find x m').       
+
+     Parameter map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+        In x (map2 f m m') -> In x m \/ In x m'.
+
+  Hint Immediate MapsTo_1 mem_2 is_empty_2.
+  
+  Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 add_3 remove_1
+    remove_2 remove_3 find_1 find_2 fold_1 map_1 map_2 mapi_1 mapi_2. 
+
+End S.
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
new file mode 100644
index 00000000..890485a8
--- /dev/null
+++ b/theories/FSets/FMapWeakList.v
@@ -0,0 +1,1000 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMapWeakList.v 8985 2006-06-23 16:12:45Z jforest $ *)
+
+(** * Finite map library *)  
+
+(** This file proposes an implementation of the non-dependant interface
+ [FMapInterface.S] using lists of pairs,  unordered but without redundancy. *)
+
+Require Import FSetInterface. 
+Require Import FSetWeakInterface.
+Require Import FMapWeakInterface.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Arguments Scope list [type_scope].
+
+Module Raw (X:DecidableType).
+
+Module PX := KeyDecidableType X.
+Import PX.
+
+Definition key := X.t.
+Definition t (elt:Set) := list (X.t * elt).
+
+Section Elt.
+
+Variable elt : Set.
+
+(* now in KeyDecidableType:
+Definition eqk (p p':key*elt) := X.eq (fst p) (fst p').
+Definition eqke (p p':key*elt) := 
+          X.eq (fst p) (fst p') /\ (snd p) = (snd p').
+*)
+
+Notation eqk := (eqk (elt:=elt)).   
+Notation eqke := (eqke (elt:=elt)).
+Notation MapsTo := (MapsTo (elt:=elt)).
+Notation In := (In (elt:=elt)).
+Notation NoDupA := (NoDupA eqk).
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Definition Empty m := forall (a : key)(e:elt), ~ MapsTo a e m.
+
+Lemma empty_1 : Empty empty.
+Proof.
+ unfold Empty,empty.
+ intros a e.
+ intro abs.
+ inversion abs.
+Qed.
+
+Hint Resolve empty_1.
+
+Lemma empty_NoDup : NoDupA empty.
+Proof. 
+ unfold empty; auto.
+Qed.
+
+(** * [is_empty] *)
+
+Definition is_empty (l : t elt) : bool := if l then true else false.
+
+Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. 
+Proof.
+ unfold Empty, PX.MapsTo.
+ intros m.
+ case m;auto.
+ intros p l inlist.
+ destruct p.
+ absurd (InA eqke (t0, e) ((t0, e) :: l));auto.
+Qed.
+
+Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+Proof.
+ intros m.
+ case m;auto.
+ intros p l abs.
+ inversion abs.
+Qed.
+
+(** * [mem] *)
+
+Function mem (k : key) (s : t elt) {struct s} : bool :=
+  match s with
+   | nil => false
+   | (k',_) :: l => if X.eq_dec k k' then true else mem k l
+  end.
+
+Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true.
+Proof.
+ intros m Hm x; generalize Hm; clear Hm.      
+ functional induction (mem x m);intros NoDup belong1;trivial.
+ inversion belong1. inversion H.
+ inversion_clear NoDup.
+ inversion_clear belong1.
+ inversion_clear H1.
+ compute in H2; destruct H2.
+ contradiction.
+ apply IHb; auto.
+ exists x0; auto.
+Qed. 
+
+Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. 
+Proof.
+ intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
+ functional induction (mem x m); intros NoDup hyp; try discriminate.
+ exists _x; auto. 
+ inversion_clear NoDup.
+ destruct IHb; auto.
+ exists x0; auto.
+Qed.
+
+(** * [find] *)
+
+Function find (k:key) (s: t elt) {struct s} : option elt :=
+  match s with
+   | nil => None
+   | (k',x)::s' => if X.eq_dec k k' then Some x else find k s'
+  end.
+
+Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+Proof.
+ intros m x. unfold PX.MapsTo.
+ functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
+Qed.
+
+Lemma find_1 : forall m (Hm:NoDupA m) x e, 
+  MapsTo x e m -> find x m = Some e. 
+Proof.
+ intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (find x m);simpl; subst; try clear H_eq_1.
+
+ inversion 2.
+
+ do 2 inversion_clear 1.
+ compute in H2; destruct H2; subst; trivial.
+ elim H; apply InA_eqk with (x,e); auto.
+
+ do 2 inversion_clear 1; auto.
+ compute in H2; destruct H2; elim _x; auto.
+Qed.
+
+(* Not part of the exported specifications, used later for [combine]. *)
+
+Lemma find_eq : forall m (Hm:NoDupA m) x x', 
+   X.eq x x' -> find x m = find x' m.
+Proof.
+ induction m; simpl; auto; destruct a; intros.
+ inversion_clear Hm.
+ rewrite (IHm H1 x x'); auto.
+ destruct (X.eq_dec x t0); destruct (X.eq_dec x' t0); trivial.
+ elim n; apply X.eq_trans with x; auto.
+ elim n; apply X.eq_trans with x'; auto.
+Qed.
+
+(** * [add] *)
+
+Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
+  match s with
+   | nil => (k,x) :: nil
+   | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l
+  end.
+
+Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros m x y e; generalize y; clear y; unfold PX.MapsTo.
+ functional induction (add x e m);simpl;auto.
+Qed.
+
+Lemma add_2 : forall m x y e e', 
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros m x  y e e'; generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction (add x e' m);simpl;auto.
+ intros y' e'' eqky';  inversion_clear 1.
+ destruct H0; simpl in *.
+ elim eqky'; apply X.eq_trans with k'; auto.
+ auto.
+ intros y' e'' eqky'; inversion_clear 1; intuition.
+Qed.
+  
+Lemma add_3 : forall m x y e e',
+  ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction (add x e' m);simpl;auto.
+ intros; apply (In_inv_3 H0); auto.
+ constructor 2; apply (In_inv_3 H0); auto.
+ inversion_clear 2; auto.
+Qed.
+
+Lemma add_3' : forall m x y e e', 
+  ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. 
+Proof.
+ intros m x y e e'. generalize y e; clear y e.
+ functional induction (add x e' m);simpl;auto.
+ inversion_clear 2.
+ compute in H1; elim H; auto.
+ inversion H1. 
+ constructor 2; inversion_clear H0; auto.
+ compute in H1; elim H; auto.
+ inversion_clear 2; auto.
+Qed.
+
+Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m).
+Proof.
+ induction m.
+ simpl; constructor; auto; red; inversion 1.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.eq_dec x x'); inversion_clear Hm; auto.
+ constructor; auto.
+ swap H.
+ apply InA_eqk with (x,e); auto.
+ constructor; auto.
+ swap H; apply add_3' with x e; auto.
+Qed.
+
+(* Not part of the exported specifications, used later for [combine]. *)
+
+Lemma add_eq : forall m (Hm:NoDupA m) x a e, 
+   X.eq x a -> find x (add a e m) = Some e.
+Proof.
+ intros.
+ apply find_1; auto.
+ apply add_NoDup; auto.
+ apply add_1; auto.
+Qed.
+
+Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, 
+  ~X.eq x a -> find x (add a e m) = find x m.
+Proof.
+ intros.
+ case_eq (find x m); intros.
+ apply find_1; auto.
+ apply add_NoDup; auto.
+ apply add_2; auto.
+ apply find_2; auto.
+ case_eq (find x (add a e m)); intros; auto.
+ rewrite <- H0; symmetry.
+ apply find_1; auto.
+ apply add_3 with a e; auto.
+ apply find_2; auto.
+Qed.
+
+
+(** * [remove] *)
+
+Function remove (k : key) (s : t elt) {struct s} : t elt :=
+  match s with
+   | nil => nil
+   | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l
+  end.  
+
+Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m).
+Proof.
+ intros m Hm x y; generalize Hm; clear Hm.
+ functional induction (remove x m);simpl;intros;auto.
+
+ red; inversion 1; inversion H1.
+
+ inversion_clear Hm.
+ subst.
+ swap H0.
+ destruct H2 as (e,H2); unfold PX.MapsTo in H2.
+ apply InA_eqk with (y,e); auto.
+ compute; apply X.eq_trans with x; auto.
+  
+ intro H2.
+ destruct H2 as (e,H2); inversion_clear H2.
+ compute in H0; destruct H0.
+ elim _x; apply X.eq_trans with y; auto.
+ inversion_clear Hm.
+ elim (IHt0 H2 H).
+ exists e; auto.
+Qed.
+  
+Lemma remove_2 : forall m (Hm:NoDupA m) x y e, 
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);auto.
+ inversion_clear 3; auto.
+ compute in H1; destruct H1.
+ elim H; apply X.eq_trans with k'; auto.
+  
+ inversion_clear 1; inversion_clear 2; auto.
+Qed.
+
+Lemma remove_3 : forall m (Hm:NoDupA m) x y e, 
+  MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);auto.
+ do 2 inversion_clear 1; auto.
+Qed.
+
+Lemma remove_3' : forall m (Hm:NoDupA m) x y e, 
+  InA eqk (y,e) (remove x m) -> InA eqk (y,e) m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);auto.
+ do 2 inversion_clear 1; auto.
+Qed.
+
+Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ inversion_clear Hm.
+ destruct a as (x',e').
+ simpl; case (X.eq_dec x x'); auto.
+ constructor; auto.
+ swap H; apply remove_3' with x; auto.
+Qed.  
+
+(** * [elements] *)
+
+Definition elements (m: t elt) := m.
+
+Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m).
+Proof.
+ auto.
+Qed.
+
+Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m.
+Proof. 
+auto.
+Qed.
+
+Lemma elements_3 : forall m (Hm:NoDupA m), NoDupA (elements m). 
+Proof. 
+ auto.
+Qed.
+
+(** * [fold] *)
+
+Function fold (A:Set)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} :  A :=
+  match m with
+   | nil => acc
+   | (k,e)::m' => fold f m' (f k e acc)
+  end.
+
+Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A),
+  fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+Proof. 
+ intros; functional induction (@fold A f m i); auto.
+Qed.
+
+(** * [equal] *)
+
+Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := 
+  match find k m' with 
+   | None => false
+   | Some e' => cmp e e'
+  end.
+
+Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := 
+  fold (fun k e b => andb (check cmp k e m') b) m true. 
+   
+Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool :=
+  andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m).
+
+Definition Submap cmp m m' := 
+  (forall k, In k m -> In k m') /\ 
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+Definition Equal cmp m m' := 
+  (forall k, In k m <-> In k m') /\ 
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, 
+  Submap cmp m m' -> submap cmp m m' = true. 
+Proof.
+ unfold Submap, submap.
+ induction m.
+ simpl; auto.
+ destruct a; simpl; intros.
+ destruct H.
+ inversion_clear Hm.
+ assert (H3 : In t0 m').
+  apply H; exists e; auto.
+ destruct H3 as (e', H3).
+ unfold check at 2; rewrite (find_1 Hm' H3).
+ rewrite (H0 t0); simpl; auto.
+ eapply IHm; auto.
+ split; intuition.
+ apply H.
+ destruct H5 as (e'',H5); exists e''; auto.
+ apply H0 with k; auto.
+Qed.
+   
+Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, 
+  submap cmp m m' = true -> Submap cmp m m'. 
+Proof.
+ unfold Submap, submap.
+ induction m.
+ simpl; auto.
+ intuition.
+ destruct H0; inversion H0.
+ inversion H0.
+ 
+ destruct a; simpl; intros.
+ inversion_clear Hm.
+ rewrite andb_b_true in H.
+ assert (check cmp t0 e m' = true).
+  clear H1 H0 Hm' IHm.
+  set (b:=check cmp t0 e m') in *.
+  generalize H; clear H; generalize b; clear b.
+  induction m; simpl; auto; intros.
+  destruct a; simpl in *.
+  destruct (andb_prop _ _ (IHm _ H)); auto.
+ rewrite H2 in H.
+ destruct (IHm H1 m' Hm' cmp H); auto.
+ unfold check in H2.
+ case_eq (find t0 m'); [intros e' H5 | intros H5]; 
+  rewrite H5 in H2; try discriminate.
+ split; intros.
+ destruct H6 as (e0,H6); inversion_clear H6.
+ compute in H7; destruct H7; subst.
+ exists e'.
+ apply PX.MapsTo_eq with t0; auto.
+ apply find_2; auto.
+ apply H3.
+ exists e0; auto.
+ inversion_clear H6.
+ compute in H8; destruct H8; subst.
+ rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence.
+ apply H4 with k; auto.
+Qed.
+
+(** Specification of [equal] *)
+
+Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, 
+  Equal cmp m m' -> equal cmp m m' = true. 
+Proof. 
+ unfold Equal, equal.
+ intuition.
+ apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder.
+Qed.
+
+Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, 
+  equal cmp m m' = true -> Equal cmp m m'.
+Proof.
+ unfold Equal, equal.
+ intros.
+ destruct (andb_prop _ _ H); clear H.
+ generalize (submap_2 Hm Hm' H0).
+ generalize (submap_2 Hm' Hm H1).
+ firstorder.
+Qed. 
+
+Variable elt':Set.
+
+(** * [map] and [mapi] *)
+  
+Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f e) :: map f m'
+  end.
+
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f k e) :: mapi f m'
+  end.
+
+End Elt.
+Section Elt2. 
+(* A new section is necessary for previous definitions to work 
+   with different [elt], especially [MapsTo]... *)
+  
+Variable elt elt' : Set.
+
+(** Specification of [map] *)
+
+Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), 
+  MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+ intros m x e f.
+ (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+    
+ destruct a as (x',e').
+ simpl. 
+ inversion_clear 1.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ constructor 2.
+ unfold MapsTo in *; auto.
+Qed.
+
+Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), 
+  In x (map f m) -> In x m.
+Proof.
+ intros m x f. 
+ (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+    
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), 
+  NoDupA (@eqk elt') (map f m).
+Proof.   
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm.
+ constructor; auto.
+ swap H.
+ (* il faut un map_1 avec eqk au lieu de eqke *)
+ clear IHm H0. 
+ induction m; simpl in *; auto.
+ inversion H1.
+ destruct a; inversion H1; auto.
+Qed.      
+ 
+(** Specification of [mapi] *)
+
+Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), 
+  MapsTo x e m -> 
+  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
+Proof.
+ intros m x e f.
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+    
+ destruct a as (x',e').
+ simpl. 
+ inversion_clear 1.
+ exists x'.
+ destruct H0; simpl in *.
+ split; auto.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ destruct IHm as (y, hyp); auto.
+ exists y; intuition.
+Qed.  
+
+Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), 
+  In x (mapi f m) -> In x m.
+Proof.
+ intros m x f. 
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+    
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), 
+  NoDupA (@eqk elt') (mapi f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm; auto.
+ constructor; auto.
+ swap H.
+ clear IHm H0.
+ induction m; simpl in *; auto.
+ inversion_clear H1.
+ destruct a; inversion_clear H1; auto.
+Qed.
+
+End Elt2. 
+Section Elt3.
+
+Variable elt elt' elt'' : Set.
+
+Notation oee' := (option elt * option elt')%type.
+	
+Definition combine_l (m:t elt)(m':t elt') : t oee' :=
+  mapi (fun k e => (Some e, find k m')) m.	
+
+Definition combine_r (m:t elt)(m':t elt') : t oee' :=
+  mapi (fun k e' => (find k m, Some e')) m'.	
+
+Definition fold_right_pair (A B C:Set)(f:A->B->C->C)(l:list (A*B))(i:C) := 
+  List.fold_right (fun p => f (fst p) (snd p)) i l.
+
+Definition combine (m:t elt)(m':t elt') : t oee' := 
+  let l := combine_l m m' in 
+  let r := combine_r m m' in 
+  fold_right_pair (add (elt:=oee')) l r.
+
+Lemma fold_right_pair_NoDup : 
+  forall l r (Hl: NoDupA (eqk (elt:=oee')) l) 
+    (Hl: NoDupA (eqk (elt:=oee')) r), 
+    NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r).
+Proof.
+ induction l; simpl; auto.
+ destruct a; simpl; auto.
+ inversion_clear 1.
+ intros; apply add_NoDup; auto.
+Qed.
+Hint Resolve fold_right_pair_NoDup.
+
+Lemma combine_NoDup : 
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), 
+  NoDupA (@eqk oee') (combine m m').
+Proof.
+ unfold combine, combine_r, combine_l.
+ intros.
+ set (f1 := fun (k : key) (e : elt) => (Some e, find k m')).
+ set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')).
+ generalize (mapi_NoDup Hm f1).
+ generalize (mapi_NoDup Hm' f2).
+ set (l := mapi f1 m); clearbody l.
+ set (r := mapi f2 m'); clearbody r.
+ auto.
+Qed.
+
+Definition at_least_left (o:option elt)(o':option elt') := 
+  match o with 
+   | None => None 
+   | _  => Some (o,o')
+  end.
+
+Definition at_least_right (o:option elt)(o':option elt') := 
+  match o' with 
+   | None => None 
+   | _  => Some (o,o')
+  end.
+
+Lemma combine_l_1 : 
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
+  find x (combine_l m m') = at_least_left (find x m) (find x m'). 
+Proof.
+ unfold combine_l.
+ intros.
+ case_eq (find x m); intros.
+ simpl.
+ apply find_1.
+ apply mapi_NoDup; auto.
+ destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)).
+ rewrite (find_eq Hm' (X.eq_sym H0)); auto.
+ simpl.
+ case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto.
+ destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))).
+ exists p; apply find_2; auto.
+ rewrite (find_1 Hm H1) in H; discriminate.
+Qed.
+
+Lemma combine_r_1 : 
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
+  find x (combine_r m m') = at_least_right (find x m) (find x m'). 
+Proof.
+ unfold combine_r.
+ intros.
+ case_eq (find x m'); intros.
+ simpl.
+ apply find_1.
+ apply mapi_NoDup; auto.
+ destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)).
+ rewrite (find_eq Hm (X.eq_sym H0)); auto.
+ simpl.
+ case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto.
+ destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))).
+ exists p; apply find_2; auto.
+ rewrite (find_1 Hm' H1) in H; discriminate.
+Qed.
+
+Definition at_least_one (o:option elt)(o':option elt') := 
+  match o, o' with 
+   | None, None => None 
+   | _, _  => Some (o,o')
+  end.
+
+Lemma combine_1 : 
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
+  find x (combine m m') = at_least_one (find x m) (find x m'). 
+Proof.
+ unfold combine.
+ intros.
+ generalize (combine_r_1 Hm Hm' x).
+ generalize (combine_l_1 Hm Hm' x).
+ assert (NoDupA (eqk (elt:=oee')) (combine_l m m')).
+  unfold combine_l; apply mapi_NoDup; auto.
+ assert (NoDupA (eqk (elt:=oee')) (combine_r m m')).
+  unfold combine_r; apply mapi_NoDup; auto.
+ set (l := combine_l m m') in *; clearbody l.
+ set (r := combine_r m m') in *; clearbody r.
+ set (o := find x m); clearbody o.
+ set (o' := find x m'); clearbody o'.
+ clear Hm' Hm m m'.
+ induction l.
+ destruct o; destruct o'; simpl; intros; discriminate || auto.
+ destruct a; simpl in *; intros.
+ destruct (X.eq_dec x t0); simpl in *.
+ unfold at_least_left in H1.
+ destruct o; simpl in *; try discriminate.
+ inversion H1; subst.
+ apply add_eq; auto.
+ inversion_clear H; auto.
+ inversion_clear H.
+ rewrite <- IHl; auto.
+ apply add_not_eq; auto.
+Qed.
+
+Variable f : option elt -> option elt' -> option elt''.
+
+Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := 
+  match o with
+   | Some e => (k,e)::l
+   | None => l
+  end.
+
+Definition map2 m m' := 
+  let m0 : t oee' := combine m m' in 
+  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in 
+  fold_right_pair (option_cons (A:=elt'')) m1 nil.
+
+Lemma map2_NoDup : 
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), 
+  NoDupA (@eqk elt'') (map2 m m').
+Proof.
+ intros.
+ unfold map2.
+ assert (H0:=combine_NoDup Hm Hm').
+ set (l0:=combine m m') in *; clearbody l0.
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ assert (H1:=map_NoDup (elt' := option elt'') H0 f').
+ set (l1:=map f' l0) in *; clearbody l1. 
+ clear f' f H0 l0 Hm Hm' m m'.
+ induction l1.
+ simpl; auto.
+ inversion_clear H1.
+ destruct a; destruct o; simpl; auto.
+ constructor; auto.
+ swap H.
+ clear IHl1.
+ induction l1.
+ inversion H1.
+ inversion_clear H0.
+ destruct a; destruct o; simpl in *; auto.
+ inversion_clear  H1; auto.
+Qed.
+
+Definition at_least_one_then_f (o:option elt)(o':option elt') := 
+  match o, o' with 
+   | None, None => None 
+   | _, _  => f o o'
+  end.
+
+Lemma map2_0 : 
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
+  find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). 
+Proof.
+ intros.
+ unfold map2.
+ assert (H:=combine_1 Hm Hm' x).
+ assert (H2:=combine_NoDup Hm Hm').
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ set (m0 := combine m m') in *; clearbody m0.
+ set (o:=find x m) in *; clearbody o. 
+ set (o':=find x m') in *; clearbody o'.
+ clear Hm Hm' m m'.
+ generalize H; clear H.
+ match goal with |- ?m=?n -> ?p=?q =>
+   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
+ induction m0; simpl in *; intuition.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct a as (k,(oo,oo')); simpl in *.
+ inversion_clear H2.
+ destruct (X.eq_dec x k); simpl in *.
+ (* x = k *)
+ assert (at_least_one_then_f o o' = f oo oo').
+  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
+ rewrite H2.
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl. 
+ destruct (X.eq_dec x k); try absurd_hyp n; auto.
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ elim H0.
+ apply InA_eqk with (x,p); auto.
+ apply InA_eqke_eqk.
+ exact (find_2 H3). 
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto].
+ destruct (IHm0 H1) as (H3,_); apply H3; auto.
+ destruct (IHm0 H1) as (H3,_); apply H3; auto.
+
+ (* None -> None *)
+ destruct a as (k,(oo,oo')).
+ simpl.
+ inversion_clear H2.
+ destruct (X.eq_dec x k).
+ (* x = k *)
+ discriminate.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto].
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+Qed.
+
+(** Specification of [map2] *)
+Lemma map2_1 : 
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  In x m \/ In x m' -> 
+  find x (map2 m m') = f (find x m) (find x m'). 
+Proof.
+ intros.
+ rewrite map2_0; auto.
+ destruct H as [(e,H)|(e,H)].
+ rewrite (find_1 Hm H).
+ destruct (find x m'); simpl; auto.
+ rewrite (find_1 Hm' H).
+ destruct (find x m); simpl; auto.
+Qed.
+ 
+Lemma map2_2 : 
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), 
+  In x (map2 m m') -> In x m \/ In x m'. 
+Proof.
+ intros.
+ destruct H as (e,H).
+ generalize (map2_0 Hm Hm' x).
+ rewrite (find_1 (map2_NoDup Hm Hm') H).
+ generalize (@find_2 _ m x).
+ generalize (@find_2 _ m' x).
+ destruct (find x m); 
+   destruct (find x m'); simpl; intros.
+ left; exists e0; auto. 
+ left; exists e0; auto.
+ right; exists e0; auto.
+ discriminate.
+Qed.
+
+End Elt3.
+End Raw.
+
+
+Module Make (X: DecidableType) <: S with Module E:=X.
+ Module Raw := Raw X. 
+
+ Module E := X.
+ Definition key := E.t. 
+
+ Record slist (elt:Set) : Set :=  
+  {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}.
+ Definition t (elt:Set) := slist elt. 
+
+Section Elt. 
+ Variable elt elt' elt'':Set. 
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key. 
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Build_slist (Raw.empty_NoDup elt).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). 
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f).
+ Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f).
+ Definition map2 f m (m':t elt') : t elt'' := 
+   Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)).
+ Definition elements m : list (key*elt) := @Raw.elements elt m.(this).
+ Definition fold (A:Set)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i.
+ Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.PX.In x m.(this).
+ Definition Empty m : Prop := Raw.Empty m.(this).
+ Definition Equal cmp m m' : Prop := @Raw.Equal elt cmp m.(this) m'.(this).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed.
+
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(NoDup)). Qed.
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
+ Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(NoDup)). Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@Raw.empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed.
+ Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(NoDup)). Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(NoDup)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed.
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. 
+ Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed.
+
+ Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed.
+ Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed.
+ Lemma elements_3 : forall m, NoDupA eq_key (elements m).  
+ Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(NoDup)). Qed.
+
+ Lemma fold_1 : forall m (A : Set) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed.
+
+ Lemma equal_1 : forall m m' cmp, Equal cmp m m' -> equal cmp m m' = true. 
+ Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed.
+ Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equal cmp m m'.
+ Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed.
+
+ End Elt.
+ 
+ Lemma map_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)(f:elt->elt'), 
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed.
+ Lemma map_2 : forall (elt elt':Set)(m: t elt)(x:key)(f:elt->elt'), 
+        In x (map f m) -> In x m. 
+ Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed.
+
+ Lemma mapi_1 : forall (elt elt':Set)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m -> 
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed.
+ Lemma mapi_2 : forall (elt elt':Set)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+	In x m \/ In x m' -> 
+        find x (map2 f m m') = f (find x m) (find x m').       
+ Proof. 
+ intros elt elt' elt'' m m' x f; 
+ exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x).
+ Qed.
+ Lemma map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''), 
+        In x (map2 f m m') -> In x m \/ In x m'.
+ Proof. 
+ intros elt elt' elt'' m m' x f;  
+ exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x).
+ Qed.
+
+End Make.
+
diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v
new file mode 100644
index 00000000..72ccad3f
--- /dev/null
+++ b/theories/FSets/FMaps.v
@@ -0,0 +1,18 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FMaps.v 8844 2006-05-22 17:22:36Z letouzey $ *)
+
+Require Export OrderedType.
+Require Export OrderedTypeEx.
+Require Export OrderedTypeAlt.
+Require Export FMapInterface.
+Require Export FMapList.
+Require Export FMapPositive.
+Require Export FMapIntMap.
+Require Export FMapFacts.
\ No newline at end of file
diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v
new file mode 100644
index 00000000..5b09945b
--- /dev/null
+++ b/theories/FSets/FSetAVL.v
@@ -0,0 +1,2900 @@
+
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: FSetAVL.v 8985 2006-06-23 16:12:45Z jforest $ *)
+
+(** This module implements sets using AVL trees.
+    It follows the implementation from Ocaml's standard library. *)
+
+Require Import FSetInterface.
+Require Import FSetList.
+Require Import ZArith.
+Require Import Int.
+
+Set Firstorder Depth 3.
+
+Module Raw (I:Int)(X:OrderedType).
+Import I.
+Module II:=MoreInt(I).
+Import II.
+Open Scope Int_scope.
+
+Module E := X.
+Module MX := OrderedTypeFacts X.
+
+Definition elt := X.t.
+
+(** * Trees *)
+
+Inductive tree : Set :=
+  | Leaf : tree
+  | Node : tree -> X.t -> tree -> int -> tree.
+
+Notation t := tree.
+
+(** The fourth field of [Node] is the height of the tree *)
+
+(** A tactic to repeat [inversion_clear] on all hyps of the 
+    form [(f (Node _ _ _ _))] *)
+Ltac inv f :=
+  match goal with 
+     | H:f Leaf |- _ => inversion_clear H; inv f
+     | H:f _ Leaf |- _ => inversion_clear H; inv f
+     | H:f (Node _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ (Node _ _ _ _) |- _ => inversion_clear H; inv f
+     | _ => idtac
+  end.
+
+(** Same, but with a backup of the original hypothesis. *)
+
+Ltac safe_inv f := match goal with 
+  | H:f (Node _ _ _ _) |- _ => 
+        generalize H; inversion_clear H; safe_inv f
+  | _ => intros 
+ end.
+
+(** * Occurrence in a tree *)
+
+Inductive In (x : elt) : tree -> Prop :=
+  | IsRoot :
+      forall (l r : tree) (h : int) (y : elt),
+      X.eq x y -> In x (Node l y r h)
+  | InLeft :
+      forall (l r : tree) (h : int) (y : elt),
+      In x l -> In x (Node l y r h)
+  | InRight :
+      forall (l r : tree) (h : int) (y : elt),
+      In x r -> In x (Node l y r h).
+
+Hint Constructors In.
+
+Ltac intuition_in := repeat progress (intuition; inv In).
+
+(** [In] is compatible with [X.eq] *)
+
+Lemma In_1 :
+ forall s x y, X.eq x y -> In x s -> In y s.
+Proof.
+ induction s; simpl; intuition_in; eauto.
+Qed.
+Hint Immediate In_1.
+
+(** * Binary search trees *)
+
+(** [lt_tree x s]: all elements in [s] are smaller than [x] 
+   (resp. greater for [gt_tree]) *)
+
+Definition lt_tree (x : elt) (s : tree) := 
+ forall y:elt, In y s -> X.lt y x.
+Definition gt_tree (x : elt) (s : tree) := 
+ forall y:elt, In y s -> X.lt x y.
+
+Hint Unfold lt_tree gt_tree.
+
+Ltac order := match goal with 
+ | H: lt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order
+ | H: gt_tree ?x ?s, H1: In ?y ?s |- _ => generalize (H _ H1); clear H; order
+ | _ => MX.order
+end.
+
+(** Results about [lt_tree] and [gt_tree] *)
+
+Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
+Proof.
+ unfold lt_tree in |- *; intros; inversion H.
+Qed.
+
+Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
+Proof.
+  unfold gt_tree in |- *; intros; inversion H.
+Qed.
+
+Lemma lt_tree_node :
+ forall (x y : elt) (l r : tree) (h : int),
+ lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h).
+Proof.
+ unfold lt_tree in *; intuition_in; order.
+Qed.
+
+Lemma gt_tree_node :
+ forall (x y : elt) (l r : tree) (h : int),
+ gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h).
+Proof.
+ unfold gt_tree in *; intuition_in; order.
+Qed.
+
+Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+
+Lemma lt_tree_not_in :
+ forall (x : elt) (t : tree), lt_tree x t -> ~ In x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma lt_tree_trans :
+ forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
+Proof.
+ firstorder eauto.
+Qed.
+
+Lemma gt_tree_not_in :
+ forall (x : elt) (t : tree), gt_tree x t -> ~ In x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma gt_tree_trans :
+ forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
+Proof.
+ firstorder eauto.
+Qed.
+
+Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+
+(** [bst t] : [t] is a binary search tree *)
+
+Inductive bst : tree -> Prop :=
+  | BSLeaf : bst Leaf
+  | BSNode :
+      forall (x : elt) (l r : tree) (h : int),
+      bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x r h).
+
+Hint Constructors bst.
+
+(** * AVL trees *)
+
+(** [avl s] : [s] is a properly balanced AVL tree,
+    i.e. for any node the heights of the two children
+    differ by at most 2 *)
+
+Definition height (s : tree) : int :=
+  match s with
+  | Leaf => 0
+  | Node _ _ _ h => h
+  end.
+
+Inductive avl : tree -> Prop :=
+  | RBLeaf : avl Leaf
+  | RBNode :
+      forall (x : elt) (l r : tree) (h : int),
+      avl l ->
+      avl r ->
+      -(2) <= height l - height r <= 2 ->
+      h = max (height l) (height r) + 1 -> 
+      avl (Node l x r h).
+
+Hint Constructors avl.
+
+(** Results about [avl] *)
+
+Lemma avl_node :
+ forall (x : elt) (l r : tree),
+ avl l ->
+ avl r ->
+ -(2) <= height l - height r <= 2 ->
+ avl (Node l x r (max (height l) (height r) + 1)).
+Proof.
+  intros; auto.
+Qed.
+Hint Resolve avl_node.
+
+(** The tactics *)
+
+Lemma height_non_negative : forall s : tree, avl s -> height s >= 0.
+Proof.
+ induction s; simpl; intros; auto with zarith.
+ inv avl; intuition; omega_max.
+Qed.
+Implicit Arguments height_non_negative. 
+
+(** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *)
+
+Ltac avl_nn_hyp H := 
+     let nz := fresh "nz" in assert (nz := height_non_negative H).
+
+Ltac avl_nn h := 
+  let t := type of h in 
+  match type of t with 
+   | Prop => avl_nn_hyp h
+   | _ => match goal with H : avl h |- _ => avl_nn_hyp H end
+  end.
+
+(* Repeat the previous tactic. 
+   Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)
+
+Ltac avl_nns :=
+  match goal with 
+     | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
+     | _ => idtac
+  end.
+
+(** * Some shortcuts. *)
+
+Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+Definition Subset s s' := forall a : elt, In a s -> In a s'.
+Definition Empty s := forall a : elt, ~ In a s.
+Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+(** * Empty set *)
+
+Definition empty := Leaf.
+
+Lemma empty_bst : bst empty.
+Proof.
+ auto.
+Qed.
+
+Lemma empty_avl : avl empty.
+Proof. 
+ auto.
+Qed.
+
+Lemma empty_1 : Empty empty.
+Proof.
+ intro; intro.
+ inversion H.
+Qed.
+
+(** * Emptyness test *)
+
+Definition is_empty (s:t) := match s with Leaf => true | _ => false end.
+
+Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. 
+Proof.
+ destruct s as [|r x l h]; simpl; auto.
+ intro H; elim (H x); auto.
+Qed.
+
+Lemma is_empty_2 : forall s, is_empty s = true -> Empty s.
+Proof. 
+ destruct s; simpl; intros; try discriminate; red; auto.
+Qed.
+
+(** * Appartness *)
+
+(** The [mem] function is deciding appartness. It exploits the [bst] property
+    to achieve logarithmic complexity. *)
+
+Function mem (x:elt)(s:t) { struct s } : bool := 
+   match s with 
+     |  Leaf => false 
+     |  Node l y r _ => match X.compare x y with 
+             | LT _ => mem x l 
+             | EQ _ => true
+             | GT _ => mem x r
+         end
+   end.
+
+Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true.
+Proof. 
+ intros s x.
+ functional induction (mem x s); inversion_clear 1; auto.
+ inversion_clear 1.
+ inversion_clear 1; auto; absurd (X.lt x y); eauto.
+ inversion_clear 1; auto; absurd (X.lt y x); eauto.
+Qed.
+
+Lemma mem_2 : forall s x, mem x s = true -> In x s. 
+Proof. 
+ intros s x. 
+ functional induction (mem x s); auto; intros; try discriminate.
+Qed.
+
+(** * Singleton set *)
+
+Definition singleton (x : elt) := Node Leaf x Leaf 1.
+
+Lemma singleton_bst : forall x : elt, bst (singleton x).
+Proof.
+ unfold singleton;  auto.
+Qed.
+
+Lemma singleton_avl : forall x : elt, avl (singleton x).
+Proof.
+ unfold singleton; intro.
+ constructor; auto; try red; simpl; omega_max.
+Qed.
+
+Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. 
+Proof. 
+ unfold singleton; inversion_clear 1; auto; inversion_clear H0.
+Qed.
+
+Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). 
+Proof. 
+ unfold singleton; auto.
+Qed.
+
+(** * Helper functions *)
+
+(** [create l x r] creates a node, assuming [l] and [r]
+    to be balanced and [|height l - height r| <= 2]. *)
+
+Definition create l x r := 
+   Node l x r (max (height l) (height r) + 1).
+
+Lemma create_bst : 
+ forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> 
+ bst (create l x r).
+Proof.
+ unfold create; auto.
+Qed.
+Hint Resolve create_bst.
+
+Lemma create_avl : 
+ forall l x r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+ avl (create l x r).
+Proof.
+ unfold create; auto.
+Qed.
+
+Lemma create_height : 
+ forall l x r, avl l -> avl r ->  -(2) <= height l - height r <= 2 -> 
+ height (create l x r) = max (height l) (height r) + 1.
+Proof.
+ unfold create; intros; auto.
+Qed.
+
+Lemma create_in : 
+ forall l x r y,  In y (create l x r) <-> X.eq y x \/ In y l \/ In y r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+(** trick for emulating [assert false] in Coq *)
+
+Definition assert_false := Leaf.
+
+(** [bal l x r] acts as [create], but performs one step of
+    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition bal l x r := 
+  let hl := height l in 
+  let hr := height r in
+  if gt_le_dec hl (hr+2) then 
+    match l with 
+     | Leaf => assert_false
+     | Node ll lx lr _ => 
+       if ge_lt_dec (height ll) (height lr) then 
+         create ll lx (create lr x r)
+       else 
+         match lr with 
+          | Leaf => assert_false 
+          | Node lrl lrx lrr _ => 
+              create (create ll lx lrl) lrx (create lrr x r)
+         end
+    end
+  else 
+    if gt_le_dec hr (hl+2) then 
+      match r with
+       | Leaf => assert_false
+       | Node rl rx rr _ =>
+         if ge_lt_dec (height rr) (height rl) then 
+            create (create l x rl) rx rr
+         else 
+           match rl with
+            | Leaf => assert_false
+            | Node rll rlx rlr _ => 
+                create (create l x rll) rlx (create rlr rx rr) 
+           end
+      end
+    else 
+      create l x r. 
+
+Ltac bal_tac := 
+ intros l x r;
+ unfold bal; 
+ destruct (gt_le_dec (height l) (height r + 2)); 
+   [ destruct l as [ |ll lx lr lh]; 
+     [ | destruct (ge_lt_dec (height ll) (height lr)); 
+          [ | destruct lr ] ]
+   | destruct (gt_le_dec (height r) (height l + 2)); 
+     [ destruct r as [ |rl rx rr rh];
+          [ | destruct (ge_lt_dec (height rr) (height rl)); 
+               [ | destruct rl ] ]
+     | ] ]; intros.
+
+Lemma bal_bst : forall l x r, bst l -> bst r -> 
+ lt_tree x l -> gt_tree x r -> bst (bal l x r).
+Proof.
+ (* intros l x r; functional induction bal l x r. MARCHE PAS !*) 
+ bal_tac; 
+ inv bst; repeat apply create_bst; auto; unfold create; 
+ apply lt_tree_node || apply gt_tree_node; auto; 
+ eapply lt_tree_trans || eapply gt_tree_trans || eauto; eauto.
+Qed.
+
+Lemma bal_avl : forall l x r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 -> avl (bal l x r).
+Proof.
+ bal_tac; inv avl; repeat apply create_avl; simpl in *; auto; omega_max.
+Qed.
+
+Lemma bal_height_1 : forall l x r, avl l -> avl r -> 
+ -(3) <= height l - height r <= 3 ->
+ 0 <= height (bal l x r) - max (height l) (height r) <= 1.
+Proof.
+ bal_tac; inv avl; avl_nns; simpl in *; omega_max.
+Qed.
+
+Lemma bal_height_2 : 
+ forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> 
+ height (bal l x r) == max (height l) (height r) +1.
+Proof.
+ bal_tac; inv avl; simpl in *; omega_max.
+Qed.
+
+Lemma bal_in : forall l x r y, avl l -> avl r -> 
+ (In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r).
+Proof.
+ bal_tac; 
+ solve [repeat rewrite create_in; intuition_in
+       |inv avl; avl_nns; simpl in *; false_omega].
+Qed.
+
+Ltac omega_bal := match goal with 
+  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => 
+     generalize (bal_height_1 l x r H H') (bal_height_2 l x r H H'); 
+     omega_max
+  end. 
+
+(** * Insertion *)
+
+Function add (x:elt)(s:t) { struct s } : t := match s with 
+   | Leaf => Node Leaf x Leaf 1
+   | Node l y r h => 
+      match X.compare x y with
+         | LT _ => bal (add x l) y r
+         | EQ _ => Node l y r h
+         | GT _ => bal l y (add x r)
+      end
+  end.
+
+Lemma add_avl_1 :  forall s x, avl s -> 
+ avl (add x s) /\ 0 <= height (add x s) - height s <= 1.
+Proof. 
+ intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *.
+ intuition; try constructor; simpl; auto; try omega_max.
+ (* LT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+ (* EQ *)
+ intuition; omega_max.
+ (* GT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma add_avl : forall s x, avl s -> avl (add x s).
+Proof.
+ intros; generalize (add_avl_1 s x H); intuition.
+Qed.
+Hint Resolve add_avl.
+
+Lemma add_in : forall s x y, avl s -> 
+ (In y (add x s) <-> X.eq y x \/ In y s).
+Proof.
+ intros s x; functional induction (add x s); auto; intros.
+ intuition_in.
+ (* LT *)
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite (IHt y0 H0); intuition_in.
+ (* EQ *)  
+ inv avl.
+ intuition.
+ eapply In_1; eauto.
+ (* GT *)
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite (IHt y0 H1); intuition_in.
+Qed.
+
+Lemma add_bst : forall s x, bst s -> avl s -> bst (add x s).
+Proof. 
+ intros s x; functional induction (add x s); auto; intros.
+ inv bst; inv avl; apply bal_bst; auto.
+ (* lt_tree -> lt_tree (add ...) *)
+ red; red in H4.
+ intros.
+ rewrite (add_in l x y0 H) in H0.
+ intuition.
+ eauto.
+ inv bst; inv avl; apply bal_bst; auto.
+ (* gt_tree -> gt_tree (add ...) *)
+ red; red in H4.
+ intros.
+ rewrite (add_in r x y0 H5) in H0.
+ intuition.
+ apply MX.lt_eq with x; auto.
+Qed.
+
+(** * Join
+
+    Same as [bal] but does not assume anything regarding heights
+    of [l] and [r].
+*)
+
+Fixpoint join (l:t) : elt -> t -> t :=
+  match l with
+    | Leaf => add
+    | Node ll lx lr lh => fun x => 
+       fix join_aux (r:t) : t := match r with 
+          | Leaf =>  add x l
+          | Node rl rx rr rh =>  
+               if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
+               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr 
+               else create l x r
+          end
+  end.
+
+Ltac join_tac := 
+ intro l; induction l as [| ll _ lx lr Hlr lh]; 
+   [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join;
+     [ | destruct (gt_le_dec lh (rh+2)); 
+       [ match goal with |- context b [ bal ?a ?b ?c] => 
+           replace (bal a b c) 
+           with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] 
+         end 
+       | destruct (gt_le_dec rh (lh+2)); 
+         [ match goal with |- context b [ bal ?a ?b ?c] => 
+             replace (bal a b c) 
+             with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] 
+           end
+         | ] ] ] ]; intros.
+
+Lemma join_avl_1 : forall l x r, avl l -> avl r -> avl (join l x r) /\
+ 0<= height (join l x r) - max (height l) (height r) <= 1.
+Proof. 
+ (* intros l x r; functional induction join l x r. AUTRE PROBLEME! *)
+ join_tac.
+
+ split; simpl; auto. 
+ destruct (add_avl_1 r x H0).
+ avl_nns; omega_max.
+ split; auto.
+ set (l:=Node ll lx lr lh) in *.
+ destruct (add_avl_1 l x H).
+ simpl (height Leaf).
+ avl_nns; omega_max.
+
+ inversion_clear H.
+ assert (height (Node rl rx rr rh) = rh); auto.
+ set (r := Node rl rx rr rh) in *; clearbody r.
+ destruct (Hlr x r H2 H0); clear Hrl Hlr.
+ set (j := join lr x r) in *; clearbody j.
+ simpl.
+ assert (-(3) <= height ll - height j <= 3) by omega_max.
+ split.
+ apply bal_avl; auto.
+ omega_bal.
+
+ inversion_clear H0.
+ assert (height (Node ll lx lr lh) = lh); auto.
+ set (l := Node ll lx lr lh) in *; clearbody l.
+ destruct (Hrl H H1); clear Hrl Hlr.
+ set (j := join l x rl) in *; clearbody j.
+ simpl.
+ assert (-(3) <= height j - height rr <= 3) by omega_max.
+ split.
+ apply bal_avl; auto.
+ omega_bal.
+
+ clear Hrl Hlr.
+ assert (height (Node ll lx lr lh) = lh); auto.
+ assert (height (Node rl rx rr rh) = rh); auto.
+ set (l := Node ll lx lr lh) in *; clearbody l.
+ set (r := Node rl rx rr rh) in *; clearbody r.
+ assert (-(2) <= height l - height r <= 2) by omega_max.
+ split.
+ apply create_avl; auto.
+ rewrite create_height; auto; omega_max.
+Qed.
+
+Lemma join_avl : forall l x r, avl l -> avl r -> avl (join l x r).
+Proof.
+ intros; generalize (join_avl_1 l x r H H0); intuition.
+Qed.
+Hint Resolve join_avl.
+
+Lemma join_in : forall l x r y, avl l -> avl r -> 
+     (In y (join l x r) <-> X.eq y x \/ In y l \/ In y r).
+Proof.
+ join_tac.
+ simpl.
+ rewrite add_in; intuition_in.
+
+ rewrite add_in; intuition_in.
+
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite Hlr; clear Hlr Hrl; intuition_in.
+
+ inv avl.
+ rewrite bal_in; auto.
+ rewrite Hrl; clear Hlr Hrl; intuition_in.
+
+ apply create_in.
+Qed.
+
+Lemma join_bst : forall l x r, bst l -> avl l -> bst r -> avl r -> 
+ lt_tree x l -> gt_tree x r -> bst (join l x r).
+Proof.
+ join_tac.
+ apply add_bst; auto.
+ apply add_bst; auto.
+
+ inv bst; safe_inv avl.
+ apply bal_bst; auto.
+ clear Hrl Hlr H13 H14 H16 H17 z; intro; intros.
+ set (r:=Node rl rx rr rh) in *; clearbody r.
+ rewrite (join_in lr x r y) in H13; auto.
+ intuition.
+ apply MX.lt_eq with x; eauto.
+ eauto.
+
+ inv bst; safe_inv avl.
+ apply bal_bst; auto.
+ clear Hrl Hlr H13 H14 H16 H17 z; intro; intros.
+ set (l:=Node ll lx lr lh) in *; clearbody l.
+ rewrite (join_in l x rl y) in H13; auto.
+ intuition.
+ apply MX.eq_lt with x; eauto.
+ eauto.
+
+ apply create_bst; auto.
+Qed.
+
+(** * Extraction of minimum element
+
+  morally, [remove_min] is to be applied to a non-empty tree 
+  [t = Node l x r h]. Since we can't deal here with [assert false] 
+  for [t=Leaf], we pre-unpack [t] (and forget about [h]). 
+*)
+ 
+Function remove_min (l:t)(x:elt)(r:t) { struct l } : t*elt := 
+  match l with 
+    | Leaf => (r,x)
+    | Node ll lx lr lh => let (l',m) := (remove_min ll lx lr : t*elt) in (bal l' x r, m)
+  end.
+
+Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> 
+ avl (fst (remove_min l x r)) /\ 
+ 0 <= height (Node l x r h) - height (fst (remove_min l x r)) <= 1.
+Proof.
+ intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
+ inv avl; simpl in *; split; auto.
+ avl_nns; omega_max.
+ (* l = Node *)
+ inversion_clear H.
+ rewrite e0 in IHp;simpl in IHp;destruct (IHp lh); auto.
+ split; simpl in *. 
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> 
+    avl (fst (remove_min l x r)). 
+Proof.
+ intros; generalize (remove_min_avl_1 l x r h H); intuition.
+Qed.
+
+Lemma remove_min_in : forall l x r h y, avl (Node l x r h) -> 
+ (In y (Node l x r h) <-> 
+  X.eq y (snd (remove_min l x r)) \/ In y (fst (remove_min l x r))).
+Proof.
+ intros l x r; functional induction (remove_min l x r); simpl in *; intros.
+ intuition_in.
+ (* l = Node *)
+ inversion_clear H.
+ generalize (remove_min_avl ll lx lr lh H0).
+ rewrite e0; simpl; intros.
+ rewrite bal_in; auto.
+ rewrite e0 in IHp;generalize (IHp lh y H0).
+ intuition.
+ inversion_clear H7; intuition.
+Qed.
+
+Lemma remove_min_bst : forall l x r h, 
+ bst (Node l x r h) -> avl (Node l x r h) -> bst (fst (remove_min l x r)).
+Proof.
+ intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H0.
+ rewrite_all e0;simpl in *.
+ apply bal_bst; auto.
+ firstorder.
+ intro; intros.
+ generalize (remove_min_in ll lx lr lh y H).
+ rewrite e0; simpl.
+ destruct 1.
+ apply H3; intuition.
+Qed.
+
+Lemma remove_min_gt_tree : forall l x r h, 
+ bst (Node l x r h) -> avl (Node l x r h) -> 
+ gt_tree (snd (remove_min l x r)) (fst (remove_min l x r)).
+Proof.
+ intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H0.
+ intro; intro.
+ generalize (IHp lh H1 H); clear H6 H7 IHp.
+ generalize (remove_min_avl ll lx lr lh H).
+ generalize (remove_min_in ll lx lr lh m H).
+ rewrite e0; simpl; intros.
+ rewrite (bal_in l' x r y H7 H5) in H0.
+ destruct H6.
+ firstorder.
+ apply MX.lt_eq with x; auto.
+ apply X.lt_trans with x; auto.
+Qed.
+
+(** * Merging two trees
+
+  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
+  of [t1] to be smaller than all elements of [t2], and
+  [|height t1 - height t2| <= 2].
+*)
+
+Function merge (s1 s2 :t) : t:=  match s1,s2 with 
+  | Leaf, _ => s2 
+  | _, Leaf => s1
+  | _, Node l2 x2 r2 h2 => 
+        let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
+end.
+
+Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> 
+ -(2) <= height s1 - height s2 <= 2 -> 
+ avl (merge s1 s2) /\ 
+ 0<= height (merge s1 s2) - max (height s1) (height s2) <=1.
+Proof.
+ intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros.
+ split; auto; avl_nns; omega_max.
+ split; auto; avl_nns; simpl in *; omega_max.
+ destruct s1;try contradiction;clear y.
+ generalize (remove_min_avl_1 l2 x2 r2 h2 H0).
+ rewrite e1; simpl; destruct 1.
+ split.
+ apply bal_avl; auto.
+ simpl; omega_max.
+ omega_bal.
+Qed.
+
+Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> 
+  -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2).
+Proof. 
+ intros; generalize (merge_avl_1 s1 s2 H H0 H1); intuition.
+Qed.
+
+Lemma merge_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (In y (merge s1 s2) <-> In y s1 \/ In y s2).
+Proof. 
+ intros s1 s2; functional induction (merge s1 s2); subst; simpl in *; intros.
+ intuition_in.
+ intuition_in.
+ destruct s1;try contradiction;clear y.
+ replace s2' with (fst (remove_min l2 x2 r2)); [|rewrite e1; auto].
+ rewrite bal_in; auto.
+ generalize (remove_min_avl l2 x2 r2 h2); rewrite e1; simpl; auto.
+ generalize (remove_min_in l2 x2 r2 h2 y0); rewrite e1; simpl; intro.
+ rewrite H3 ; intuition.
+Qed.
+
+Lemma merge_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
+ bst (merge s1 s2). 
+Proof.
+ intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros; auto.
+ destruct s1;try contradiction;clear y.
+ apply bal_bst; auto.
+ generalize (remove_min_bst l2 x2 r2 h2); rewrite e1; simpl in *; auto.
+ intro; intro.
+ apply H3; auto.
+ generalize (remove_min_in l2 x2 r2 h2 m); rewrite e1; simpl; intuition.
+ generalize (remove_min_gt_tree l2 x2 r2 h2); rewrite e1; simpl; auto.
+Qed. 
+
+(** * Deletion *)
+
+Function remove (x:elt)(s:tree) { struct s } : t := match s with 
+  | Leaf => Leaf
+  | Node l y r h =>
+      match X.compare x y with
+         | LT _ => bal (remove x l) y r
+         | EQ _ => merge l r
+         | GT _ => bal l  y (remove x r)
+      end
+   end.
+
+Lemma remove_avl_1 : forall s x, avl s -> 
+ avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1.
+Proof.
+ intros s x; functional induction (remove x s); subst;simpl; intros.
+ intuition; omega_max.
+ (* LT *)
+ inv avl.
+ destruct (IHt H0).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+ (* EQ *)
+ inv avl. 
+ generalize (merge_avl_1 l r H0 H1 H2).
+ intuition omega_max.
+ (* GT *)
+ inv avl.
+ destruct (IHt H1).
+ split. 
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_avl : forall s x, avl s -> avl (remove x s).
+Proof. 
+ intros; generalize (remove_avl_1 s x H); intuition.
+Qed.
+Hint Resolve remove_avl.
+
+Lemma remove_in : forall s x y, bst s -> avl s -> 
+ (In y (remove x s) <-> ~ X.eq y x /\ In y s).
+Proof.
+ intros s x; functional induction (remove x s); subst;simpl; intros.
+ intuition_in.
+ (* LT *)
+ inv avl; inv bst; clear e0.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H0); intuition; [ order | order | intuition_in ].
+ (* EQ *)
+ inv avl; inv bst; clear e0.
+ rewrite merge_in; intuition; [ order | order | intuition_in ].
+ elim H9; eauto.
+ (* GT *)
+ inv avl; inv bst; clear e0.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H5); intuition; [ order | order | intuition_in ].
+Qed.
+
+Lemma remove_bst : forall s x, bst s -> avl s -> bst (remove x s).
+Proof. 
+ intros s x; functional induction (remove x s); simpl; intros.
+ auto.
+ (* LT *)
+ inv avl; inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in l x y0) in H; auto.
+ destruct H; eauto.
+ (* EQ *)
+ inv avl; inv bst.
+ apply merge_bst; eauto.
+ (* GT *) 
+ inv avl; inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in r x y0) in H; auto.
+ destruct H; eauto.
+Qed.
+
+ (** * Minimum element *)
+
+Function min_elt (s:t) : option elt := match s with 
+   | Leaf => None
+   | Node Leaf y _  _ => Some y
+   | Node l _ _ _ => min_elt l
+end.
+
+Lemma min_elt_1 : forall s x, min_elt s = Some x -> In x s. 
+Proof. 
+ intro s; functional induction (min_elt s); subst; simpl.
+ inversion 1.
+ inversion 1; auto.
+ intros.
+ destruct l; auto.
+Qed.
+
+Lemma min_elt_2 : forall s x y, bst s -> 
+ min_elt s = Some x -> In y s -> ~ X.lt y x. 
+Proof.
+ intro s; functional induction (min_elt s); subst;simpl.
+ inversion_clear 2.
+ inversion_clear 1.
+ inversion 1; subst.
+ inversion_clear 1; auto.
+ inversion_clear H5.
+ destruct l;try contradiction.
+ inversion_clear 1.
+ simpl.
+ destruct l1.
+ inversion 1; subst.
+ assert (X.lt x _x) by (apply H2; auto).
+ inversion_clear 1; auto; order.
+ assert (X.lt t _x) by auto.
+ inversion_clear 2; auto; 
+   (assert (~ X.lt t x) by auto); order.
+Qed.
+
+Lemma min_elt_3 : forall s, min_elt s = None -> Empty s.
+Proof.
+ intro s; functional induction (min_elt s); subst;simpl.
+ red; auto.
+ inversion 1.
+ destruct l;try contradiction. 
+ clear y;intro H0.
+ destruct (IHo H0 t);  auto.
+Qed.
+
+
+(** * Maximum element *)
+
+Function max_elt (s:t) : option elt := match s with 
+   | Leaf => None
+   | Node _ y Leaf  _ => Some y
+   | Node _ _ r _ => max_elt r
+end.
+
+Lemma max_elt_1 : forall s x, max_elt s = Some x -> In x s. 
+Proof. 
+ intro s; functional induction (max_elt s); subst;simpl.
+ inversion 1.
+ inversion 1; auto.
+ destruct r;try contradiction; auto.
+Qed.
+
+Lemma max_elt_2 : forall s x y, bst s -> 
+ max_elt s = Some x -> In y s -> ~ X.lt x y. 
+Proof.
+ intro s; functional induction (max_elt s); subst;simpl.
+ inversion_clear 2.
+ inversion_clear 1.
+ inversion 1; subst.
+ inversion_clear 1; auto.
+ inversion_clear H5.
+ destruct r;try contradiction.
+ inversion_clear 1.
+(*  inversion 1; subst. *)
+(*  assert (X.lt y x) by (apply H4; auto). *)
+(*  inversion_clear 1; auto; order. *)
+ assert (X.lt _x0 t) by auto.
+ inversion_clear 2; auto; 
+  (assert (~ X.lt x t) by auto); order.
+Qed.
+
+Lemma max_elt_3 : forall s, max_elt s = None -> Empty s.
+Proof.
+ intro s; functional induction (max_elt s); subst;simpl.
+ red; auto.
+ inversion 1.
+ destruct r;try contradiction.
+ intros H0; destruct (IHo H0 t); auto.
+Qed.
+
+(** * Any element *)
+
+Definition choose := min_elt.
+
+Lemma choose_1 : forall s x, choose s = Some x -> In x s.
+Proof. 
+ exact min_elt_1.
+Qed.
+
+Lemma choose_2 : forall s, choose s = None -> Empty s.
+Proof. 
+ exact min_elt_3.
+Qed.
+
+(** * Concatenation
+
+    Same as [merge] but does not assume anything about heights.
+*)
+
+Function concat (s1 s2 : t) : t  := 
+   match s1, s2 with 
+      | Leaf, _ => s2 
+      | _, Leaf => s1
+      | _, Node l2 x2 r2 h2 => 
+            let (s2',m) := remove_min l2 x2 r2 in 
+            join s1 m s2'
+   end.
+
+Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2).
+Proof.
+ intros s1 s2; functional induction (concat s1 s2); subst;auto.
+ destruct s1;try contradiction;clear y.
+ intros; apply join_avl; auto.
+ generalize (remove_min_avl l2 x2 r2 h2 H0); rewrite e1; simpl; auto.
+Qed.
+ 
+Lemma concat_bst :   forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
+ bst (concat s1 s2).
+Proof. 
+ intros s1 s2; functional induction (concat s1 s2); subst ;auto.
+ destruct s1;try contradiction;clear y. 
+ intros;  apply join_bst; auto.
+ generalize (remove_min_bst l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto.
+ generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto.
+ generalize (remove_min_in l2 x2 r2 h2 m H2); rewrite e1; simpl; auto.
+ destruct 1; intuition.
+ generalize (remove_min_gt_tree l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto.
+Qed.
+
+Lemma concat_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> 
+ (In y (concat s1 s2) <-> In y s1 \/ In y s2).
+Proof.
+ intros s1 s2; functional induction (concat s1 s2);subst;simpl.
+ intuition.
+ inversion_clear H5.
+ destruct s1;try contradiction;clear y;intuition.
+ inversion_clear H5.
+ destruct s1;try contradiction;clear y; intros. 
+ rewrite (join_in  (Node s1_1 t s1_2 i) m s2' y H0).
+ generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto.
+ generalize (remove_min_in l2 x2 r2 h2 y H2); rewrite e1; simpl.
+ intro EQ; rewrite EQ; intuition.
+Qed.
+
+(** * Splitting 
+
+    [split x s] returns a triple [(l, present, r)] where
+    - [l] is the set of elements of [s] that are [< x]
+    - [r] is the set of elements of [s] that are [> x]
+    - [present] is [true] if and only if [s] contains  [x].
+*)
+
+Function split (x:elt)(s:t) {struct s} : t * (bool * t) := match s with 
+  | Leaf => (Leaf, (false, Leaf))
+  | Node l y r h => 
+     match X.compare x y with 
+      | LT _ => match split x l with 
+                 | (ll,(pres,rl)) => (ll, (pres, join rl y r))
+                end
+      | EQ _ => (l, (true, r))
+      | GT _ => match split x r with 
+                 | (rl,(pres,rr)) => (join l y rl, (pres, rr))
+                end
+     end
+ end.
+
+Lemma split_avl : forall s x, avl s -> 
+  avl (fst (split x s)) /\ avl (snd (snd (split x s))).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.
+ auto.
+ rewrite e1 in IHp;simpl in IHp;inversion_clear 1; intuition.
+ simpl; inversion_clear 1; auto.
+ rewrite e1 in IHp;simpl in IHp;inversion_clear 1; intuition.
+Qed.
+
+Lemma split_in_1 : forall s x y, bst s -> avl s -> 
+ (In y (fst (split x s)) <-> In y s /\ X.lt y x).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.
+ intuition; try inversion_clear H1.
+ (* LT *)
+ rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear  H7 H6.
+ rewrite (IHp y0 H0 H4); clear IHp e0.
+ intuition.
+ inversion_clear H6; auto; order.
+ (* EQ *)
+ simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0.
+ intuition.
+ order.
+ intuition_in; order.
+ (* GT *)
+ rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
+ rewrite join_in; auto.
+ generalize (split_avl r x H5); rewrite e1; simpl; intuition.
+ rewrite (IHp y0 H1 H5); clear e1.
+ intuition; [ eauto | eauto | intuition_in ].
+Qed.
+
+Lemma split_in_2 : forall s x y, bst s -> avl s -> 
+ (In y (snd (snd (split x s))) <-> In y s /\ X.lt x y).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.
+ intuition; try inversion_clear H1.
+ (* LT *)
+ rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
+  rewrite join_in; auto.
+ generalize (split_avl l x H4); rewrite e1; simpl; intuition.
+ rewrite (IHp y0 H0 H4); clear IHp e0.
+ intuition; [ order | order | intuition_in ].
+ (* EQ *)
+ simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0.
+ intuition; [ order | intuition_in; order ]. 
+ (* GT *)
+ rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
+ rewrite (IHp y0 H1 H5); clear IHp e0.
+ intuition; intuition_in; order. 
+Qed.
+
+Lemma split_in_3 : forall s x, bst s -> avl s -> 
+ (fst (snd (split x s)) = true <-> In x s).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.
+ intuition; try inversion_clear H1.
+ (* LT *)
+ rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
+ rewrite IHp; auto.
+ intuition_in; absurd (X.lt x y); eauto.
+ (* EQ *)
+ simpl in *; inversion_clear 1; inversion_clear 1; intuition.
+ (* GT *)
+ rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
+ rewrite IHp; auto.
+ intuition_in; absurd (X.lt y x); eauto.
+Qed.
+
+Lemma split_bst : forall s x, bst s -> avl s -> 
+ bst (fst (split x s)) /\ bst (snd (snd (split x s))).
+Proof. 
+ intros s x; functional induction (split x s);subst;simpl in *.  
+ intuition.
+ (* LT *)
+ rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
+ intuition.
+ apply join_bst; auto.
+ generalize (split_avl l x H4); rewrite e1; simpl; intuition.
+ intro; intro.
+ generalize (split_in_2 l x y0 H0 H4); rewrite e1; simpl; intuition.
+ (* EQ *)
+ simpl in *; inversion_clear 1; inversion_clear 1; intuition.
+ (* GT *)
+ rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
+ intuition.
+ apply join_bst; auto.
+ generalize (split_avl r x H5); rewrite e1; simpl; intuition.
+ intro; intro.
+ generalize (split_in_1 r x y0 H1 H5); rewrite e1; simpl; intuition.
+Qed.
+
+(** * Intersection *)
+
+Fixpoint inter (s1 s2 : t) {struct s1} : t := match s1, s2 with 
+    | Leaf,_ => Leaf
+    | _,Leaf => Leaf
+    | Node l1 x1 r1 h1, _ => 
+            match split x1 s2 with
+               | (l2',(true,r2')) => join (inter l1 l2') x1 (inter r1 r2')
+               | (l2',(false,r2')) => concat (inter l1 l2') (inter r1 r2')
+            end
+    end.
+
+Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). 
+Proof. 
+ (* intros s1 s2; functional induction inter s1 s2; auto. BOF BOF *)
+ induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto.
+ destruct s2 as [ | l2 x2 r2 h2]; intros; auto.
+ generalize H0; inv avl.
+ set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros. 
+ destruct (split_avl r x1 H8).
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct b; [ apply join_avl | apply concat_avl ]; auto.
+Qed.
+
+Lemma inter_bst_in : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ bst (inter s1 s2) /\ (forall y, In y (inter s1 s2) <-> In y s1 /\ In y s2).
+Proof. 
+ induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto.
+ intuition; inversion_clear H3.
+ destruct s2 as [ | l2 x2 r2 h2]; intros.
+ simpl; intuition; inversion_clear H3.
+ generalize H1 H2; inv avl; inv bst.
+ set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros.
+ destruct (split_avl r x1 H17).
+ destruct (split_bst r x1 H16 H17).
+ split.
+ (* bst *)
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct (Hl1 l2'); auto.
+ destruct (Hr1 r2'); auto.
+ destruct b.
+ (* bst join *)
+ apply join_bst; try apply inter_avl; firstorder.
+ (* bst concat *)
+ apply concat_bst; try apply inter_avl; auto.
+ intros; generalize (H22 y1) (H24 y2); intuition eauto.
+ (* in *)
+ intros.
+ destruct (split_in_1 r x1 y H16 H17). 
+ destruct (split_in_2 r x1 y H16 H17).
+ destruct (split_in_3 r x1 H16 H17).
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct (Hl1 l2'); auto.
+ destruct (Hr1 r2'); auto.
+ destruct b.
+ (* in join *)
+ rewrite join_in; try apply inter_avl; auto.
+ rewrite H30.
+ rewrite H28.
+ intuition_in.
+ apply In_1 with x1; auto.
+ (* in concat *)
+ rewrite concat_in; try apply inter_avl; auto.
+ intros.
+ intros; generalize (H28 y1) (H30 y2); intuition eauto.
+ rewrite H30.
+ rewrite H28.
+ intuition_in.
+ generalize (H26 (In_1 _ _ _ H22 H35)); intro; discriminate.
+Qed.
+
+Lemma inter_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ bst (inter s1 s2). 
+Proof. 
+ intros; generalize (inter_bst_in s1 s2); intuition.
+Qed.
+
+Lemma inter_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (In y (inter s1 s2) <-> In y s1 /\ In y s2).
+Proof. 
+ intros; generalize (inter_bst_in s1 s2); firstorder.
+Qed.
+
+(** * Difference *)
+
+Fixpoint diff (s1 s2 : t) { struct s1 } : t := match s1, s2 with 
+ | Leaf, _ => Leaf
+ | _, Leaf => s1
+ | Node l1 x1 r1 h1, _ => 
+    match split x1 s2 with 
+      | (l2',(true,r2')) => concat (diff l1 l2') (diff r1 r2')
+      | (l2',(false,r2')) => join (diff l1 l2') x1 (diff r1 r2')
+    end
+end. 
+
+Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). 
+Proof. 
+ (* intros s1 s2; functional induction diff s1 s2; auto. BOF BOF *)
+ induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto.
+ destruct s2 as [ | l2 x2 r2 h2]; intros; auto.
+ generalize H0; inv avl.
+ set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros. 
+ destruct (split_avl r x1 H8).
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct b; [ apply concat_avl | apply join_avl ]; auto.
+Qed.
+
+Lemma diff_bst_in : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ bst (diff s1 s2) /\ (forall y, In y (diff s1 s2) <-> In y s1 /\ ~In y s2).
+Proof. 
+ induction s1 as [ | l1 Hl1 x1 r1 Hr1 h1]; simpl; auto.
+ intuition; inversion_clear H3.
+ destruct s2 as [ | l2 x2 r2 h2]; intros; auto.
+ intuition; inversion_clear H4.
+ generalize H1 H2; inv avl; inv bst.
+ set (r:=Node l2 x2 r2 h2) in *; clearbody r; intros.
+ destruct (split_avl r x1 H17).
+ destruct (split_bst r x1 H16 H17).
+ split.
+ (* bst *)
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct (Hl1 l2'); auto.
+ destruct (Hr1 r2'); auto.
+ destruct b.
+ (* bst concat *)
+ apply concat_bst; try apply diff_avl; auto.
+ intros; generalize (H22 y1) (H24 y2); intuition eauto.
+ (* bst join *)
+ apply join_bst; try apply diff_avl; firstorder.
+ (* in *)
+ intros.
+ destruct (split_in_1 r x1 y H16 H17). 
+ destruct (split_in_2 r x1 y H16 H17).
+ destruct (split_in_3 r x1 H16 H17).
+ destruct (split x1 r) as [l2' (b,r2')]; simpl in *.
+ destruct (Hl1 l2'); auto.
+ destruct (Hr1 r2'); auto.
+ destruct b.
+ (* in concat *)
+ rewrite concat_in; try apply diff_avl; auto.
+ intros.
+ intros; generalize (H28 y1) (H30 y2); intuition eauto.
+ rewrite H30.
+ rewrite H28.
+ intuition_in.
+ elim H35; apply In_1 with x1; auto.
+ (* in join *)
+ rewrite join_in; try apply diff_avl; auto.
+ rewrite H30.
+ rewrite H28.
+ intuition_in.
+ generalize (H26 (In_1 _ _ _ H34 H24)); intro; discriminate.
+Qed.
+
+Lemma diff_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ bst (diff s1 s2). 
+Proof. 
+ intros; generalize (diff_bst_in s1 s2); intuition.
+Qed.
+
+Lemma diff_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ (In y (diff s1 s2) <-> In y s1 /\ ~In y s2).
+Proof. 
+ intros; generalize (diff_bst_in s1 s2); firstorder.
+Qed.
+
+(** * Elements *)
+
+(** [elements_tree_aux acc t] catenates the elements of [t] in infix
+    order to the list [acc] *)
+
+Fixpoint elements_aux (acc : list X.t) (t : tree) {struct t} : list X.t :=
+  match t with
+   | Leaf => acc
+   | Node l x r _ => elements_aux (x :: elements_aux acc r) l
+  end.
+
+(** then [elements] is an instanciation with an empty [acc] *)
+
+Definition elements := elements_aux nil.
+
+Lemma elements_aux_in : forall s acc x, 
+ InA X.eq x (elements_aux acc s) <-> In x s \/ InA X.eq x acc.
+Proof.
+ induction s as [ | l Hl x r Hr h ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+Qed.
+
+Lemma elements_in : forall s x, InA X.eq x (elements s) <-> In x s. 
+Proof. 
+ intros; generalize (elements_aux_in s nil x); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma elements_aux_sort : forall s acc, bst s -> sort X.lt acc ->
+ (forall x y : elt, InA X.eq x acc -> In y s -> X.lt y x) ->
+ sort X.lt (elements_aux acc s).
+Proof.
+ induction s as [ | l Hl y r Hr h]; simpl; intuition.
+ inv bst.
+ apply Hl; auto.
+ constructor. 
+ apply Hr; auto.
+ apply MX.In_Inf; intros.
+ destruct (elements_aux_in r acc y0); intuition.
+ intros.
+ inversion_clear H.
+ order.
+ destruct (elements_aux_in r acc x); intuition eauto.
+Qed.
+
+Lemma elements_sort : forall s : tree, bst s -> sort X.lt (elements s).
+Proof.
+ intros; unfold elements; apply elements_aux_sort; auto.
+ intros; inversion H0.
+Qed.
+Hint Resolve elements_sort.
+
+(** * Filter *)
+
+Section F.
+Variable f : elt -> bool.
+
+Fixpoint filter_acc (acc:t)(s:t) { struct s } : t := match s with 
+  | Leaf => acc
+  | Node l x r h => 
+     filter_acc (filter_acc (if f x then add x acc else acc) l) r 
+ end.
+
+Definition filter := filter_acc Leaf. 
+
+Lemma filter_acc_avl : forall s acc, avl s -> avl acc -> 
+ avl (filter_acc acc s).
+Proof.
+ induction s; simpl; auto.
+ intros.
+ inv avl.
+ apply IHs2; auto.
+ apply IHs1; auto.
+ destruct (f t); auto.
+Qed. 
+Hint Resolve filter_acc_avl.
+
+Lemma filter_acc_bst : forall s acc, bst s -> avl s -> bst acc -> avl acc -> 
+ bst (filter_acc acc s).
+Proof.
+ induction s; simpl; auto.
+ intros.
+ inv avl; inv bst.
+ destruct (f t); auto.
+ apply IHs2; auto.
+ apply IHs1; auto.
+ apply add_bst; auto.
+Qed. 
+
+Lemma filter_acc_in : forall s acc, avl s -> avl acc -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (filter_acc acc s) <-> In x acc \/ In x s /\ f x = true.
+Proof.  
+ induction s; simpl; intros.
+ intuition_in.
+ inv bst; inv avl.
+ rewrite IHs2; auto.
+ destruct (f t); auto.
+ rewrite IHs1; auto.
+ destruct (f t); auto.
+ case_eq (f t); intros.
+ rewrite (add_in); auto.
+ intuition_in.
+ rewrite (H1 _ _ H8).
+ intuition.
+ intuition_in.
+ rewrite (H1 _ _ H8) in H9.
+ rewrite H in H9; discriminate.
+Qed. 
+
+Lemma filter_avl : forall s, avl s -> avl (filter s). 
+Proof.
+ unfold filter; intros; apply filter_acc_avl; auto.
+Qed.
+
+Lemma filter_bst : forall s, bst s -> avl s -> bst (filter s). 
+Proof.
+ unfold filter; intros; apply filter_acc_bst; auto.
+Qed.
+
+Lemma filter_in : forall s, avl s -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (filter s) <-> In x s /\ f x = true.
+Proof.
+ unfold filter; intros; rewrite filter_acc_in; intuition_in.
+Qed. 
+
+(** * Partition *)
+
+Fixpoint partition_acc (acc : t*t)(s : t) { struct s } : t*t := 
+  match s with 
+   | Leaf => acc
+   | Node l x r _ => 
+      let (acct,accf) := acc in 
+      partition_acc 
+        (partition_acc 
+           (if f x then (add x acct, accf) else (acct, add x accf)) l) r
+  end. 
+
+Definition partition := partition_acc (Leaf,Leaf).
+
+Lemma partition_acc_avl_1 : forall s acc, avl s -> 
+ avl (fst acc) -> avl (fst (partition_acc acc s)).
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv avl.
+ apply IHs2; auto.
+ apply IHs1; auto.
+ destruct (f t); simpl; auto.
+Qed. 
+
+Lemma partition_acc_avl_2 : forall s acc, avl s -> 
+ avl (snd acc) -> avl (snd (partition_acc acc s)).
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv avl.
+ apply IHs2; auto.
+ apply IHs1; auto.
+ destruct (f t); simpl; auto.
+Qed. 
+Hint Resolve partition_acc_avl_1 partition_acc_avl_2.
+
+Lemma partition_acc_bst_1 : forall s acc, bst s -> avl s -> 
+ bst (fst acc) -> avl (fst acc) -> 
+ bst (fst (partition_acc acc s)).
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv avl; inv bst.
+ destruct (f t); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto.
+ apply add_bst; auto.
+ apply partition_acc_avl_1; simpl; auto.
+Qed. 
+
+Lemma partition_acc_bst_2 : forall s acc, bst s -> avl s -> 
+ bst (snd acc) -> avl (snd acc) -> 
+ bst (snd (partition_acc acc s)).
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros.
+ inv avl; inv bst.
+ destruct (f t); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto.
+ apply add_bst; auto.
+ apply partition_acc_avl_2; simpl; auto.
+Qed. 
+
+Lemma partition_acc_in_1 : forall s acc, avl s -> avl (fst acc) -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (fst (partition_acc acc s)) <-> 
+ In x (fst acc) \/ In x s /\ f x = true.
+Proof.  
+ induction s; simpl; intros.
+ intuition_in.
+ destruct acc as [acct accf]; simpl in *.
+ inv bst; inv avl.
+ rewrite IHs2; auto.
+ destruct (f t); auto.
+ apply partition_acc_avl_1; simpl; auto.
+ rewrite IHs1; auto.
+ destruct (f t); simpl; auto.
+ case_eq (f t); simpl; intros.
+ rewrite (add_in); auto.
+ intuition_in.
+ rewrite (H1 _ _ H8).
+ intuition.
+ intuition_in.
+ rewrite (H1 _ _ H8) in H9.
+ rewrite H in H9; discriminate.
+Qed. 
+
+Lemma partition_acc_in_2 : forall s acc, avl s -> avl (snd acc) -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (snd (partition_acc acc s)) <-> 
+ In x (snd acc) \/ In x s /\ f x = false.
+Proof.  
+ induction s; simpl; intros.
+ intuition_in.
+ destruct acc as [acct accf]; simpl in *.
+ inv bst; inv avl.
+ rewrite IHs2; auto.
+ destruct (f t); auto.
+ apply partition_acc_avl_2; simpl; auto.
+ rewrite IHs1; auto.
+ destruct (f t); simpl; auto.
+ case_eq (f t); simpl; intros.
+ intuition.
+ intuition_in.
+ rewrite (H1 _ _ H8) in H9.
+ rewrite H in H9; discriminate.
+ rewrite (add_in); auto.
+ intuition_in.
+ rewrite (H1 _ _ H8).
+ intuition.
+Qed. 
+
+Lemma partition_avl_1 : forall s, avl s -> avl (fst (partition s)). 
+Proof.
+ unfold partition; intros; apply partition_acc_avl_1; auto.
+Qed.
+
+Lemma partition_avl_2 : forall s, avl s -> avl (snd (partition s)). 
+Proof.
+ unfold partition; intros; apply partition_acc_avl_2; auto.
+Qed.
+
+Lemma partition_bst_1 : forall s, bst s -> avl s -> 
+ bst (fst (partition s)). 
+Proof.
+ unfold partition; intros; apply partition_acc_bst_1; auto.
+Qed.
+
+Lemma partition_bst_2 : forall s, bst s -> avl s -> 
+ bst (snd (partition s)). 
+Proof.
+ unfold partition; intros; apply partition_acc_bst_2; auto.
+Qed.
+
+Lemma partition_in_1 : forall s, avl s -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (fst (partition s)) <-> In x s /\ f x = true.
+Proof.
+ unfold partition; intros; rewrite partition_acc_in_1; 
+ simpl in *; intuition_in.
+Qed. 
+
+Lemma partition_in_2 : forall s, avl s -> 
+ compat_bool X.eq f -> forall x : elt, 
+ In x (snd (partition s)) <-> In x s /\ f x = false.
+Proof.
+ unfold partition; intros; rewrite partition_acc_in_2; 
+ simpl in *; intuition_in.
+Qed. 
+
+(** [for_all] and [exists] *)
+
+Fixpoint for_all (s:t) : bool := match s with 
+  | Leaf => true
+  | Node l x r _ => f x && for_all l && for_all r
+end.
+
+Lemma for_all_1 : forall s, compat_bool E.eq f ->
+ For_all (fun x => f x = true) s -> for_all s = true.
+Proof.
+ induction s; simpl; auto.
+ intros.
+ rewrite IHs1; try red; auto.
+ rewrite IHs2; try red; auto.
+ generalize (H0 t).
+ destruct (f t); simpl; auto.
+Qed.
+
+Lemma for_all_2 : forall s, compat_bool E.eq f ->
+ for_all s = true -> For_all (fun x => f x = true) s.
+Proof.
+ induction s; simpl; auto; intros; red; intros; inv In.
+ destruct (andb_prop _ _ H0); auto.
+ destruct (andb_prop _ _ H1); eauto.
+ apply IHs1; auto.
+ destruct (andb_prop _ _ H0); auto.
+ destruct (andb_prop _ _ H1); auto.
+ apply IHs2; auto.
+ destruct (andb_prop _ _ H0); auto.
+Qed.
+
+Fixpoint exists_ (s:t) : bool := match s with 
+  | Leaf => false
+  | Node l x r _ => f x || exists_ l || exists_ r
+end.  
+
+Lemma exists_1 : forall s, compat_bool E.eq f ->
+ Exists (fun x => f x = true) s -> exists_ s = true.
+Proof.
+ induction s; simpl; destruct 2 as (x,(U,V)); inv In.
+ rewrite (H _ _ (X.eq_sym H0)); rewrite V; auto.
+ apply orb_true_intro; left.
+ apply orb_true_intro; right; apply IHs1; firstorder.
+ apply orb_true_intro; right; apply IHs2; firstorder.
+Qed.
+
+Lemma exists_2 : forall s, compat_bool E.eq f ->
+ exists_ s = true -> Exists (fun x => f x = true) s.
+Proof. 
+ induction s; simpl; intros.
+ discriminate.
+ destruct (orb_true_elim _ _ H0) as [H1|H1]. 
+ destruct (orb_true_elim _ _ H1) as [H2|H2].
+ exists t; auto.
+ destruct (IHs1 H H2); firstorder.
+ destruct (IHs2 H H1); firstorder.
+Qed. 
+
+End F.
+
+(** * Fold *)
+
+Module L := FSetList.Raw X.
+
+Fixpoint fold (A : Set) (f : elt -> A -> A)(s : tree) {struct s} : A -> A := 
+ fun a => match s with
+  | Leaf => a
+  | Node l x r _ => fold A f r (f x (fold A f l a))
+ end.
+Implicit Arguments fold [A].
+
+Definition fold' (A : Set) (f : elt -> A -> A)(s : tree) := 
+  L.fold f (elements s).
+Implicit Arguments fold' [A].
+
+Lemma fold_equiv_aux :
+ forall (A : Set) (s : tree) (f : elt -> A -> A) (a : A) (acc : list elt),
+ L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a).
+Proof.
+ simple induction s.
+ simpl in |- *; intuition.
+ simpl in |- *; intros.
+ rewrite H.
+ simpl.
+ apply H0.
+Qed.
+
+Lemma fold_equiv :
+ forall (A : Set) (s : tree) (f : elt -> A -> A) (a : A),
+ fold f s a = fold' f s a.
+Proof.
+ unfold fold', elements in |- *. 
+ simple induction s; simpl in |- *; auto; intros.
+ rewrite fold_equiv_aux.
+ rewrite H0.
+ simpl in |- *; auto.
+Qed.
+
+Lemma fold_1 : 
+ forall (s:t)(Hs:bst s)(A : Set)(f : elt -> A -> A)(i : A),
+ fold f s i = fold_left (fun a e => f e a) (elements s) i.
+Proof.
+ intros.
+ rewrite fold_equiv.
+ unfold fold'.
+ rewrite L.fold_1.
+ unfold L.elements; auto.
+ apply elements_sort; auto.
+Qed.
+
+(** * Cardinal *)
+
+Fixpoint cardinal (s : tree) : nat :=
+  match s with
+   | Leaf => 0%nat
+   | Node l _ r _ => S (cardinal l + cardinal r)
+  end.
+
+Lemma cardinal_elements_aux_1 :
+ forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
+Proof.
+ simple induction s; simpl in |- *; intuition.
+ rewrite <- H.
+ simpl in |- *.
+ rewrite <- H0; omega.
+Qed.
+
+Lemma cardinal_elements_1 : forall s : tree, cardinal s = length (elements s).
+Proof.
+ exact (fun s => cardinal_elements_aux_1 s nil).
+Qed.
+
+(** NB: the remaining functions (union, subset, compare) are still defined
+  in a dependent style, due to the use of well-founded induction. *)
+
+(** Induction over cardinals *)
+
+Lemma sorted_subset_cardinal : forall l' l : list X.t,
+ sort X.lt l -> sort X.lt l' ->
+ (forall x : elt, InA X.eq x l -> InA X.eq x l') -> (length l <= length l')%nat.
+Proof.
+ simple induction l'; simpl in |- *; intuition.
+ destruct l; trivial; intros.
+ absurd (InA X.eq t nil); intuition.
+ inversion_clear H2.
+ inversion_clear H1.
+ destruct l0; simpl in |- *; intuition.
+ inversion_clear H0.
+ apply le_n_S.
+ case (X.compare t a); intro.
+ absurd (InA X.eq t (a :: l)).
+ intro.
+ inversion_clear H0.
+ order.
+ assert (X.lt a t).
+ apply MX.Sort_Inf_In with l; auto.
+ order.
+ firstorder.
+ apply H; auto.
+ intros.
+ assert (InA X.eq x (a :: l)).
+ apply H2; auto.
+ inversion_clear H6; auto.
+ assert (X.lt t x).
+ apply MX.Sort_Inf_In with l0; auto.
+ order.
+ apply le_trans with (length (t :: l0)).
+ simpl in |- *; omega.
+ apply (H (t :: l0)); auto.
+ intros.
+ assert (InA X.eq x (a :: l)); firstorder.
+ inversion_clear H6; auto.
+ assert (X.lt a x).
+ apply MX.Sort_Inf_In with (t :: l0); auto.
+ elim (X.lt_not_eq (x:=a) (y:=x)); auto.
+Qed.
+
+Lemma cardinal_subset : forall a b : tree, bst a -> bst b ->
+ (forall y : elt, In y a -> In y b) ->
+ (cardinal a <= cardinal b)%nat.
+Proof.
+ intros.
+ do 2 rewrite cardinal_elements_1.
+ apply sorted_subset_cardinal; auto.
+ intros.
+ generalize (elements_in a x) (elements_in b x).
+ intuition.
+Qed.
+
+Lemma cardinal_left : forall (l r : tree) (x : elt) (h : int),
+ (cardinal l < cardinal (Node l x r h))%nat.
+Proof.
+ simpl in |- *; intuition.
+Qed. 
+
+Lemma cardinal_right :
+ forall (l r : tree) (x : elt) (h : int),
+ (cardinal r < cardinal (Node l x r h))%nat.
+Proof.
+ simpl in |- *; intuition.
+Qed. 
+
+Lemma cardinal_rec2 : forall P : tree -> tree -> Set,
+ (forall s1 s2 : tree,
+  (forall t1 t2 : tree,
+   (cardinal t1 + cardinal t2 < cardinal s1 + cardinal s2)%nat -> P t1 t2) 
+   -> P s1 s2) -> 
+ forall s1 s2 : tree, P s1 s2.
+Proof.
+ intros P H s1 s2.
+ apply well_founded_induction_type_2
+ with (R := fun yy' xx' : tree * tree =>
+            (cardinal (fst yy') + cardinal (snd yy') <
+             cardinal (fst xx') + cardinal (snd xx'))%nat); auto.    
+ apply (Wf_nat.well_founded_ltof _
+   (fun xx' : tree * tree => (cardinal (fst xx') + cardinal (snd xx'))%nat)).
+Qed.
+
+Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf.
+Proof.
+ destruct 1; intuition; simpl in *.
+ avl_nns; simpl in *; false_omega_max.
+Qed.   
+
+(** * Union
+
+    [union s1 s2] does an induction over the sum of the cardinals of
+    [s1] and [s2]. Code is
+<<
+  let rec union s1 s2 =
+    match (s1, s2) with
+      (Empty, t2) -> t2
+    | (t1, Empty) -> t1
+    | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+        if h1 >= h2 then
+          if h2 = 1 then add v2 s1 else begin
+            let (l2', _, r2') = split v1 s2 in
+            join (union l1 l2') v1 (union r1 r2')
+          end
+        else
+          if h1 = 1 then add v1 s2 else begin
+            let (l1', _, r1') = split v2 s1 in
+            join (union l1' l2) v2 (union r1' r2)
+          end
+>>
+*)
+
+Definition union :
+ forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> 
+ {s' : t | bst s' /\ avl s' /\ forall x : elt, In x s' <-> In x s1 \/ In x s2}.
+Proof.
+ intros s1 s2; pattern s1, s2; apply cardinal_rec2; clear s1 s2.
+ destruct s1 as [| l1 x1 r1 h1]; intros.
+ (* s = Leaf *)
+ clear H.
+ exists s2; intuition_in.
+ (* s1 = Node l1 x1 r1 *)
+ destruct s2 as [| l2 x2 r2 h2]; simpl in |- *.
+ (* s2 = Leaf *)
+ clear H.
+ exists (Node l1 x1 r1 h1); simpl; intuition_in.
+ (* x' = Node l2 x2 r2 *)
+ case (ge_lt_dec h1 h2); intro.
+ (* h1 >= h2 *)
+ case (eq_dec h2 1); intro.
+ (* h2 = 1 *)
+ clear H.
+ exists (add x2 (Node l1 x1 r1 h1)); auto.
+ inv avl; inv bst.
+ avl_nn l2; avl_nn r2.
+ rewrite (height_0 _ H); [ | omega_max].
+ rewrite (height_0 _ H4); [ | omega_max].
+ split; [apply add_bst; auto|].
+ split; [apply add_avl; auto|].
+ intros.
+ rewrite (add_in (Node l1 x1 r1 h1) x2 x); intuition_in.
+ (* h2 <> 1 *)
+   (* split x1 s2 = l2',_,r2' *)
+ case_eq (split x1 (Node l2 x2 r2 h2)); intros l2' (b,r2') EqSplit.
+ set (s2 := Node l2 x2 r2 h2) in *; clearbody s2.
+ generalize (split_avl s2 x1 H3); rewrite EqSplit; simpl in *; intros (A,B).
+ generalize (split_bst s2 x1 H2 H3); rewrite EqSplit; simpl in *; intros (C,D).
+ generalize (split_in_1 s2 x1); rewrite EqSplit; simpl in *; intros.
+ generalize (split_in_2 s2 x1); rewrite EqSplit; simpl in *; intros.
+   (* union l1 l2' = l0 *)
+ destruct (H l1 l2') as [l0 (H7,(H8,H9))]; inv avl; inv bst; auto.
+ assert (cardinal l2' <= cardinal s2)%nat.
+ apply cardinal_subset; trivial.
+ intros y; rewrite (H4 y); intuition.
+ omega.
+   (* union r1 r2' = r0 *)
+ destruct (H r1 r2') as [r0 (H10,(H11,H12))]; inv avl; inv bst; auto.
+ assert (cardinal r2' <= cardinal s2)%nat.
+ apply cardinal_subset; trivial.
+ intros y; rewrite (H5 y); intuition.
+ omega.
+ exists (join l0 x1 r0).
+ inv avl; inv bst; clear H.
+ split.
+ apply join_bst; auto.
+ red; intros.
+ rewrite (H9 y) in H.
+ destruct H; auto.
+ rewrite (H4 y) in H; intuition.
+ red; intros.
+ rewrite (H12 y) in H.
+ destruct H; auto.
+ rewrite (H5 y) in H; intuition.
+ split.
+ apply join_avl; auto.
+ intros.
+ rewrite join_in; auto.
+ rewrite H9.
+ rewrite H12.
+ rewrite H4; auto.
+ rewrite H5; auto.
+ intuition_in.
+ case (X.compare x x1); intuition.
+ (* h1 < h2 *)
+ case (eq_dec h1 1); intro.
+ (* h1 = 1 *)
+ exists (add x1 (Node l2 x2 r2 h2)); auto.
+ inv avl; inv bst.
+ avl_nn l1; avl_nn r1.
+ rewrite (height_0 _ H3); [ | omega_max].
+ rewrite (height_0 _ H8); [ | omega_max].
+ split; [apply add_bst; auto|].
+ split; [apply add_avl; auto|].
+ intros.
+ rewrite (add_in (Node l2 x2 r2 h2) x1 x); intuition_in.
+ (* h1 <> 1 *)
+   (* split x2 s1 = l1',_,r1' *)
+ case_eq (split x2 (Node l1 x1 r1 h1)); intros l1' (b,r1') EqSplit.
+ set (s1 := Node l1 x1 r1 h1) in *; clearbody s1.
+ generalize (split_avl s1 x2 H1); rewrite EqSplit; simpl in *; intros (A,B).
+ generalize (split_bst s1 x2 H0 H1); rewrite EqSplit; simpl in *; intros (C,D).
+ generalize (split_in_1 s1 x2); rewrite EqSplit; simpl in *; intros.
+ generalize (split_in_2 s1 x2); rewrite EqSplit; simpl in *; intros.
+   (* union l1' l2 = l0 *)
+ destruct (H l1' l2) as [l0 (H7,(H8,H9))]; inv avl; inv bst; auto.
+ assert (cardinal l1' <= cardinal s1)%nat.
+ apply cardinal_subset; trivial.
+ intros y; rewrite (H4 y); intuition.
+ omega.
+   (* union r1' r2 = r0 *)
+ destruct (H r1' r2) as [r0 (H10,(H11,H12))]; inv avl; inv bst; auto.
+ assert (cardinal r1' <= cardinal s1)%nat.
+ apply cardinal_subset; trivial.
+ intros y; rewrite (H5 y); intuition.
+ omega.
+ exists (join l0 x2 r0).
+ inv avl; inv bst; clear H.
+ split.
+ apply join_bst; auto.
+ red; intros.
+ rewrite (H9 y) in H.
+ destruct H; auto.
+ rewrite (H4 y) in H; intuition.
+ red; intros.
+ rewrite (H12 y) in H.
+ destruct H; auto.
+ rewrite (H5 y) in H; intuition.
+ split.
+ apply join_avl; auto.
+ intros.
+ rewrite join_in; auto.
+ rewrite H9.
+ rewrite H12.
+ rewrite H4; auto.
+ rewrite H5; auto.
+ intuition_in.
+ case (X.compare x x2); intuition.
+Qed.
+
+
+(** * Subset
+<<
+  let rec subset s1 s2 =
+    match (s1, s2) with
+      Empty, _ -> true
+    | _, Empty -> false
+    | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+        let c = Ord.compare v1 v2 in
+        if c = 0 then 
+          subset l1 l2 && subset r1 r2
+        else if c < 0 then 
+          subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+        else
+          subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+>>
+*)
+
+Definition subset : forall s1 s2 : t, bst s1 -> bst s2 ->
+ {Subset s1 s2} + {~ Subset s1 s2}.
+Proof.
+ intros s1 s2; pattern s1, s2; apply cardinal_rec2; clear s1 s2.
+ destruct s1 as [| l1 x1 r1 h1]; intros.
+ (* s1 = Leaf *)
+ left; red; intros; inv In.
+ (* s1 = Node l1 x1 r1 h1 *)
+ destruct s2 as [| l2 x2 r2 h2].
+ (* s2 = Leaf *)
+ right; intros; intro.
+ assert (In x1 Leaf); auto.
+ inversion_clear H3.
+ (* s2 = Node l2 x2 r2 h2 *)
+ case (X.compare x1 x2); intro.
+ (* x1 < x2 *)
+ case (H (Node l1 x1 Leaf 0) l2); inv bst; auto; intros.
+ simpl in |- *; omega.
+ case (H r1 (Node l2 x2 r2 h2)); inv bst; auto; intros.
+ simpl in |- *; omega.
+ clear H; left; red; intuition.
+ generalize (s a) (s0 a); clear s s0; intuition_in.
+ clear H; right; red; firstorder.
+ clear H; right; red; inv bst; intuition.
+ apply n; red; intros.
+ assert (In a (Node l2 x2 r2 h2)) by (inv In; auto).
+ intuition_in; order.
+ (* x1 = x2 *)
+ case (H l1 l2); inv bst; auto; intros.
+ simpl in |- *; omega.
+ case (H r1 r2); inv bst; auto; intros.
+ simpl in |- *; omega.
+ clear H; left; red; intuition_in; eauto.
+ clear H; right; red; inv bst; intuition.
+ apply n; red; intros.
+ assert (In a (Node l2 x2 r2 h2)) by auto.
+ intuition_in; order.
+ clear H; right; red; inv bst; intuition.
+ apply n; red; intros.
+ assert (In a (Node l2 x2 r2 h2)) by auto.
+ intuition_in; order.
+ (*  x1 > x2 *)
+ case (H (Node Leaf x1 r1 0) r2); inv bst; auto; intros.
+ simpl in |- *; omega.
+ intros; case (H l1 (Node l2 x2 r2 h2)); inv bst; auto; intros.
+ simpl in |- *; omega.
+ clear H; left; red; intuition.
+ generalize (s a) (s0 a); clear s s0; intuition_in.
+ clear H; right; red; firstorder.
+ clear H; right; red; inv bst; intuition.
+ apply n; red; intros.
+ assert (In a (Node l2 x2 r2 h2)) by (inv In; auto).
+ intuition_in; order.
+Qed.
+
+(** * Comparison *)
+
+(** ** Relations [eq] and [lt] over trees *)
+
+Definition eq : t -> t -> Prop := Equal.
+
+Lemma eq_refl : forall s : t, eq s s. 
+Proof.
+ unfold eq, Equal in |- *; intuition.
+Qed.
+
+Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s.
+Proof.
+ unfold eq, Equal in |- *; firstorder.
+Qed.
+
+Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+Proof.
+ unfold eq, Equal in |- *; firstorder.
+Qed.
+
+Lemma eq_L_eq :
+ forall s s' : t, eq s s' -> L.eq (elements s) (elements s').
+Proof.
+ unfold eq, Equal, L.eq, L.Equal in |- *; intros.
+ generalize (elements_in s a) (elements_in s' a).
+ firstorder.
+Qed.
+
+Lemma L_eq_eq :
+ forall s s' : t, L.eq (elements s) (elements s') -> eq s s'.
+Proof.
+ unfold eq, Equal, L.eq, L.Equal in |- *; intros.
+ generalize (elements_in s a) (elements_in s' a).
+ firstorder.
+Qed.
+Hint Resolve eq_L_eq L_eq_eq.
+
+Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2).
+
+Definition lt_trans (s s' s'' : t) (h : lt s s') 
+  (h' : lt s' s'') : lt s s'' := L.lt_trans h h'.
+
+Lemma lt_not_eq : forall s s' : t, bst s -> bst s' -> lt s s' -> ~ eq s s'.
+Proof.
+ unfold lt in |- *; intros; intro.
+ apply L.lt_not_eq with (s := elements s) (s' := elements s'); auto.
+Qed.
+
+(** A new comparison algorithm suggested by Xavier Leroy:
+
+type enumeration = End | More of elt * t * enumeration
+
+let rec cons s e = match s with
+ | Empty -> e
+ | Node(l, v, r, _) -> cons l (More(v, r, e))
+
+let rec compare_aux e1 e2 = match (e1, e2) with
+ | (End, End) -> 0
+ | (End, More _) -> -1
+ | (More _, End) -> 1
+ | (More(v1, r1, k1), More(v2, r2, k2)) ->
+    let c = Ord.compare v1 v2 in
+    if c <> 0 then c else compare_aux (cons r1 k1) (cons r2 k2)
+
+let compare s1 s2 = compare_aux (cons s1 End) (cons s2 End)
+*)
+
+(** ** Enumeration of the elements of a tree *)
+
+Inductive enumeration : Set :=
+ | End : enumeration
+ | More : elt -> tree -> enumeration -> enumeration.
+
+(** [flatten_e e] returns the list of elements of [e] i.e. the list
+    of elements actually compared *)
+ 
+Fixpoint flatten_e (e : enumeration) : list elt := match e with
+  | End => nil
+  | More x t r => x :: elements t ++ flatten_e r
+ end.
+
+(** [sorted_e e] expresses that elements in the enumeration [e] are
+    sorted, and that all trees in [e] are binary search trees. *)
+
+Inductive In_e (x:elt) : enumeration -> Prop :=
+  | InEHd1 :
+      forall (y : elt) (s : tree) (e : enumeration),
+      X.eq x y -> In_e x (More y s e)
+  | InEHd2 :
+      forall (y : elt) (s : tree) (e : enumeration),
+      In x s -> In_e x (More y s e)
+  | InETl :
+      forall (y : elt) (s : tree) (e : enumeration),
+      In_e x e -> In_e x (More y s e).
+
+Hint Constructors In_e.
+
+Inductive sorted_e : enumeration -> Prop :=
+  | SortedEEnd : sorted_e End
+  | SortedEMore :
+      forall (x : elt) (s : tree) (e : enumeration),
+      bst s ->
+      (gt_tree x s) ->
+      sorted_e e ->
+      (forall y : elt, In_e y e -> X.lt x y) ->
+      (forall y : elt,
+       In y s -> forall z : elt, In_e z e -> X.lt y z) ->
+      sorted_e (More x s e).
+
+Hint Constructors sorted_e.
+
+Lemma in_app :
+ forall (x : elt) (l1 l2 : list elt),
+ InA X.eq x (l1 ++ l2) -> InA X.eq x l1 \/ InA X.eq x l2.
+Proof.
+ simple induction l1; simpl in |- *; intuition.
+ inversion_clear H0; auto.
+ elim (H l2 H1); auto.
+Qed.
+
+Lemma in_flatten_e :
+ forall (x : elt) (e : enumeration), InA X.eq x (flatten_e e) -> In_e x e.
+Proof.
+ simple induction e; simpl in |- *; intuition.
+ inversion_clear H.
+ inversion_clear H0; auto.
+ elim (in_app x _ _ H1); auto.
+ destruct (elements_in t x); auto.
+Qed.
+
+Lemma sort_app :
+ forall l1 l2 : list elt, sort X.lt l1 -> sort X.lt l2 ->
+ (forall x y : elt, InA X.eq x l1 -> InA X.eq y l2 -> X.lt x y) ->
+ sort X.lt (l1 ++ l2).
+Proof.
+ simple induction l1; simpl in |- *; intuition.
+ apply cons_sort; auto.
+ apply H; auto.
+ inversion_clear H0; trivial.
+ induction  l as [| a0 l Hrecl]; simpl in |- *; intuition.
+ induction  l2 as [| a0 l2 Hrecl2]; simpl in |- *; intuition. 
+ inversion_clear H0; inversion_clear H4; auto.
+Qed.
+
+Lemma sorted_flatten_e :
+ forall e : enumeration, sorted_e e -> sort X.lt (flatten_e e).
+Proof.
+ simple induction e; simpl in |- *; intuition.
+ apply cons_sort.
+ apply sort_app; inversion H0; auto.
+ intros; apply H8; auto.
+ destruct (elements_in t x0); auto.
+ apply in_flatten_e; auto.
+ apply L.MX.ListIn_Inf.
+ inversion_clear H0.
+ intros; elim (in_app_or _ _ _ H0); intuition.
+ destruct (elements_in t y); auto.
+ apply H4; apply in_flatten_e; auto.
+Qed.
+
+Lemma elements_app :
+ forall (s : tree) (acc : list elt), elements_aux acc s = elements s ++ acc.
+Proof.
+ simple induction s; simpl in |- *; intuition.
+ rewrite H0.
+ rewrite H.
+ unfold elements; simpl.
+ do 2 rewrite H.
+ rewrite H0.
+ repeat rewrite <- app_nil_end.
+ repeat rewrite app_ass; auto.
+Qed.
+
+Lemma compare_flatten_1 :
+ forall (t0 t2 : tree) (t1 : elt) (z : int) (l : list elt),
+ elements t0 ++ t1 :: elements t2 ++ l =
+ elements (Node t0 t1 t2 z) ++ l.
+Proof.
+ simpl in |- *; unfold elements in |- *; simpl in |- *; intuition.
+ repeat rewrite elements_app.
+ repeat rewrite <- app_nil_end.
+ repeat rewrite app_ass; auto.
+Qed.
+
+(** key lemma for correctness *)
+
+Lemma flatten_e_elements :
+ forall (x : elt) (l r : tree) (z : int) (e : enumeration),
+ elements l ++ flatten_e (More x r e) = elements (Node l x r z) ++ flatten_e e.
+Proof.
+ intros; simpl.
+ apply compare_flatten_1.
+Qed.
+
+(** termination of [compare_aux] *)
+
+Open Scope Z_scope.
+ 
+Fixpoint measure_e_t (s : tree) : Z := match s with
+  | Leaf => 0
+  | Node l _ r _ => 1 + measure_e_t l + measure_e_t r
+ end.
+
+Fixpoint measure_e (e : enumeration) : Z := match e with
+  | End => 0
+  | More _ s r => 1 + measure_e_t s + measure_e r
+ end.
+
+Ltac Measure_e_t := unfold measure_e_t in |- *; fold measure_e_t in |- *.
+Ltac Measure_e := unfold measure_e in |- *; fold measure_e in |- *.
+
+Lemma measure_e_t_0 : forall s : tree, measure_e_t s >= 0.
+Proof.
+ simple induction s.
+ simpl in |- *; omega.
+ intros.
+ Measure_e_t; omega. (* BUG Simpl! *)
+Qed.
+
+Ltac Measure_e_t_0 s := generalize (measure_e_t_0 s); intro.
+
+Lemma measure_e_0 : forall e : enumeration, measure_e e >= 0.
+Proof.
+ simple induction e.
+ simpl in |- *; omega.
+ intros.
+ Measure_e; Measure_e_t_0 t; omega.
+Qed.
+
+Ltac Measure_e_0 e := generalize (measure_e_0 e); intro.
+
+(** Induction principle over the sum of the measures for two lists *)
+
+Definition compare_rec2 :
+ forall P : enumeration -> enumeration -> Set,
+  (forall x x' : enumeration,
+   (forall y y' : enumeration,
+    measure_e y + measure_e y' < measure_e x + measure_e x' -> P y y') ->
+   P x x') -> 
+ forall x x' : enumeration, P x x'.
+Proof.
+ intros P H x x'.
+ apply well_founded_induction_type_2
+ with (R := fun yy' xx' : enumeration * enumeration =>
+            measure_e (fst yy') + measure_e (snd yy') <
+            measure_e (fst xx') + measure_e (snd xx')); auto.    
+ apply Wf_nat.well_founded_lt_compat
+ with (f := fun xx' : enumeration * enumeration =>
+            Zabs_nat (measure_e (fst xx') + measure_e (snd xx'))).
+ intros; apply Zabs.Zabs_nat_lt.
+ Measure_e_0 (fst x0); Measure_e_0 (snd x0); Measure_e_0 (fst y);
+ Measure_e_0 (snd y); intros; omega.
+Qed.
+
+(** [cons t e] adds the elements of tree [t] on the head of 
+    enumeration [e]. Code:
+ 
+let rec cons s e = match s with
+ | Empty -> e
+ | Node(l, v, r, _) -> cons l (More(v, r, e))
+*)
+
+Definition cons : forall (s : tree) (e : enumeration), bst s -> sorted_e e ->
+  (forall (x y : elt), In x s -> In_e y e -> X.lt x y) ->
+  { r : enumeration 
+  | sorted_e r /\ 
+    measure_e r = measure_e_t s + measure_e e /\
+    flatten_e r = elements s ++ flatten_e e
+  }.
+Proof.
+ simple induction s; intuition.
+ (* s = Leaf *)
+ exists e; intuition.
+ (* s = Node t t0 t1 z *)
+ clear H0.
+ case (H (More t0 t1 e)); clear H; intuition.
+ inv bst; auto.
+ constructor; inversion_clear H1; auto.
+ inversion_clear H0; inv bst; intuition; order.
+ exists x; intuition.
+ generalize H4; Measure_e; intros; Measure_e_t; omega.
+ rewrite H5.
+ apply flatten_e_elements.
+Qed.
+
+Lemma l_eq_cons :
+ forall (l1 l2 : list elt) (x y : elt),
+ X.eq x y -> L.eq l1 l2 -> L.eq (x :: l1) (y :: l2).
+Proof.
+ unfold L.eq, L.Equal in |- *; intuition.
+ inversion_clear H1; generalize (H0 a); clear H0; intuition.
+ apply InA_eqA with x; eauto.
+ inversion_clear H1; generalize (H0 a); clear H0; intuition.
+ apply InA_eqA with y; eauto.
+Qed.
+
+Definition compare_aux :
+ forall e1 e2 : enumeration, sorted_e e1 -> sorted_e e2 ->
+ Compare L.lt L.eq (flatten_e e1) (flatten_e e2).
+Proof.
+ intros e1 e2; pattern e1, e2 in |- *; apply compare_rec2.
+ simple destruct x; simple destruct x'; intuition.
+ (* x = x' = End *)
+ constructor 2; unfold L.eq, L.Equal in |- *; intuition.
+ (* x = End x' = More *)
+ constructor 1; simpl in |- *; auto.
+ (* x = More x' = End *)
+ constructor 3; simpl in |- *; auto.
+ (* x = More e t e0, x' = More e3 t0 e4 *)
+ case (X.compare e e3); intro.
+ (* e < e3 *)
+ constructor 1; simpl; auto.
+ (* e = e3 *)
+ destruct (cons t e0) as [c1 (H2,(H3,H4))]; try inversion_clear H0; auto.
+ destruct (cons t0 e4) as [c2 (H5,(H6,H7))]; try inversion_clear H1; auto.
+ destruct (H c1 c2); clear H; intuition.
+ Measure_e; omega.
+ constructor 1; simpl.
+ apply L.lt_cons_eq; auto.
+ rewrite H4 in l; rewrite H7 in l; auto.
+ constructor 2; simpl.
+ apply l_eq_cons; auto.
+ rewrite H4 in e6; rewrite H7 in e6; auto.
+ constructor 3; simpl.
+ apply L.lt_cons_eq; auto.
+ rewrite H4 in l; rewrite H7 in l; auto.
+ (* e > e3 *)
+ constructor 3; simpl; auto.
+Qed.
+
+Definition compare : forall s1 s2, bst s1 -> bst s2 -> Compare lt eq s1 s2.
+Proof.
+ intros s1 s2 s1_bst s2_bst; unfold lt, eq; simpl.
+ destruct (cons s1 End); intuition.
+ inversion_clear H0.
+ destruct (cons s2 End); intuition.
+ inversion_clear H3.
+ simpl in H2; rewrite <- app_nil_end in H2.
+ simpl in H5; rewrite <- app_nil_end in H5.
+ destruct (compare_aux x x0); intuition.
+ constructor 1; simpl in |- *.
+ rewrite H2 in l; rewrite H5 in l; auto.
+ constructor 2; apply L_eq_eq; simpl in |- *.
+ rewrite H2 in e; rewrite H5 in e; auto.
+ constructor 3; simpl in |- *.
+ rewrite H2 in l; rewrite H5 in l; auto.
+Qed.
+
+(** * Equality test *)
+
+Definition equal : forall s s' : t, bst s -> bst s' -> {Equal s s'} + {~ Equal s s'}.
+Proof.
+ intros s s' Hs Hs'; case (compare s s'); auto; intros.
+ right; apply lt_not_eq; auto.
+ right; intro; apply (lt_not_eq s' s); auto; apply eq_sym; auto.
+Qed.
+
+(**  We provide additionally a different implementation for union, subset and 
+  equal, which is less efficient, but uses structural induction, hence  computes 
+  within Coq. *)
+
+(** Alternative union based on fold. 
+  Complexity : [min(|s|,|s'|)*log(max(|s|,|s'|))] *)
+
+Definition union' s s' := 
+  if ge_lt_dec (height s) (height s') then fold add s' s else fold add s s'.
+
+Lemma fold_add_avl : forall s s', avl s -> avl s' -> avl (fold add s s').
+Proof. 
+ induction s; simpl; intros; inv avl; auto.
+Qed.
+Hint Resolve fold_add_avl.
+
+Lemma union'_avl : forall s s', avl s -> avl s' -> avl (union' s s').
+Proof. 
+ unfold union'; intros; destruct (ge_lt_dec (height s) (height s')); auto.
+Qed.
+
+Lemma fold_add_bst : forall s s', bst s -> avl s -> bst s' -> avl s' -> 
+ bst (fold add s s').
+Proof. 
+ induction s; simpl; intros; inv avl; inv bst; auto.
+ apply IHs2; auto.
+ apply add_bst; auto.
+Qed.
+
+Lemma union'_bst : forall s s', bst s -> avl s -> bst s' -> avl s' -> 
+ bst (union' s s').
+Proof. 
+ unfold union'; intros; destruct (ge_lt_dec (height s) (height s')); 
+  apply fold_add_bst; auto.
+Qed.
+
+Lemma fold_add_in : forall s s' y, bst s -> avl s -> bst s' -> avl s' -> 
+ (In y (fold add s s') <-> In y s \/ In y s').
+Proof. 
+ induction s; simpl; intros; inv avl; inv bst; auto.
+ intuition_in.
+ rewrite IHs2; auto.
+ apply add_bst; auto.
+ apply fold_add_bst; auto.
+ rewrite add_in; auto.
+ rewrite IHs1; auto.
+ intuition_in.
+Qed.
+
+Lemma union'_in : forall s s' y, bst s -> avl s -> bst s' -> avl s' -> 
+ (In y (union' s s') <-> In y s \/ In y s').
+Proof.
+ unfold union'; intros; destruct (ge_lt_dec (height s) (height s')).
+ rewrite fold_add_in; intuition.
+ apply fold_add_in; auto.
+Qed.
+
+(** Alternative subset based on diff. *)
+
+Definition subset' s s' := is_empty (diff s s').
+
+Lemma subset'_1 : forall s s', bst s -> avl s -> bst s' -> avl s' -> 
+ Subset s s' -> subset' s s' = true.
+Proof. 
+ unfold subset', Subset; intros; apply is_empty_1; red; intros.
+ rewrite (diff_in); intuition.
+Qed.
+
+Lemma subset'_2 : forall s s', bst s -> avl s -> bst s' -> avl s' ->
+ subset' s s' = true -> Subset s s'.
+Proof. 
+ unfold subset', Subset; intros; generalize (is_empty_2 _ H3 a); unfold Empty.
+ rewrite (diff_in); intuition.
+ generalize (mem_2 s' a) (mem_1 s' a); destruct (mem a s'); intuition.
+Qed.
+
+(** Alternative equal based on subset *)
+
+Definition equal' s s' := subset' s s' && subset' s' s.
+
+Lemma equal'_1 : forall s s', bst s -> avl s -> bst s' -> avl s' ->
+ Equal s s' -> equal' s s' = true.
+Proof. 
+ unfold equal', Equal; intros.
+ rewrite subset'_1; firstorder; simpl.
+ apply subset'_1; firstorder.
+Qed.
+
+Lemma equal'_2 : forall s s', bst s -> avl s -> bst s' -> avl s' ->
+ equal' s s' = true -> Equal s s'.
+Proof. 
+ unfold equal', Equal; intros; destruct (andb_prop _ _ H3); split; 
+  apply subset'_2; auto.
+Qed. 
+
+End Raw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we 
+   need to encapsulate everything into a type of balanced binary search trees. *)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Raw := Raw I X. 
+
+ Record bbst : Set := Bbst {this :> Raw.t; is_bst : Raw.bst this; is_avl: Raw.avl this}.
+ Definition t := bbst. 
+ Definition elt := E.t.
+ 
+ Definition In (x : elt) (s : t) : Prop := Raw.In x s.
+ Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
+ Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
+ Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x.
+  
+ Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. 
+ Proof. intro s; exact (Raw.In_1 s). Qed.
+ 
+ Definition mem (x:elt)(s:t) : bool := Raw.mem x s.
+
+ Definition empty : t := Bbst _ Raw.empty_bst Raw.empty_avl.
+ Definition is_empty (s:t) : bool := Raw.is_empty s.
+ Definition singleton (x:elt) : t := Bbst _ (Raw.singleton_bst x) (Raw.singleton_avl x).
+ Definition add (x:elt)(s:t) : t := 
+   Bbst _ (Raw.add_bst s x (is_bst s) (is_avl s)) 
+          (Raw.add_avl s x (is_avl s)). 
+ Definition remove (x:elt)(s:t) : t := 
+   Bbst _ (Raw.remove_bst s x (is_bst s) (is_avl s)) 
+          (Raw.remove_avl s x (is_avl s)). 
+ Definition inter (s s':t) : t := 
+   Bbst _ (Raw.inter_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s'))  
+          (Raw.inter_avl _ _ (is_avl s) (is_avl s')).
+ Definition diff (s s':t) : t := 
+   Bbst _ (Raw.diff_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s'))  
+          (Raw.diff_avl _ _ (is_avl s) (is_avl s')).
+ Definition elements (s:t) : list elt := Raw.elements s.
+ Definition min_elt (s:t) : option elt := Raw.min_elt s.
+ Definition max_elt (s:t) : option elt := Raw.max_elt s.
+ Definition choose (s:t) : option elt := Raw.choose s.
+ Definition fold (B : Set) (f : elt -> B -> B) (s:t) : B -> B := Raw.fold f s. 
+ Definition cardinal (s:t) : nat := Raw.cardinal s.
+ Definition filter (f : elt -> bool) (s:t) : t := 
+   Bbst _ (Raw.filter_bst f _ (is_bst s) (is_avl s))
+          (Raw.filter_avl f _ (is_avl s)). 
+ Definition for_all (f : elt -> bool) (s:t) : bool := Raw.for_all f s.
+ Definition exists_ (f : elt -> bool) (s:t) : bool := Raw.exists_ f s.
+ Definition partition (f : elt -> bool) (s:t) : t * t :=
+   let p := Raw.partition f s in
+   (Bbst (fst p) (Raw.partition_bst_1 f _ (is_bst s) (is_avl s)) 
+                 (Raw.partition_avl_1 f _ (is_avl s)),
+    Bbst (snd p) (Raw.partition_bst_2 f _ (is_bst s) (is_avl s)) 
+                 (Raw.partition_avl_2 f _ (is_avl s))).
+
+ Definition union (s s':t) : t :=
+   let (u,p) := Raw.union _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s') in 
+   let (b,p) := p in 
+   let (a,_) := p in 
+   Bbst u b a.
+
+ Definition union' (s s' : t) : t := 
+   Bbst _ (Raw.union'_bst _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s'))  
+          (Raw.union'_avl _ _ (is_avl s) (is_avl s')).
+
+ Definition equal (s s': t) : bool := if Raw.equal _ _ (is_bst s) (is_bst s') then true else false. 
+ Definition equal' (s s':t) : bool := Raw.equal' s s'.
+
+ Definition subset (s s':t) : bool := if Raw.subset _ _ (is_bst s) (is_bst s') then true else false.
+ Definition subset' (s s':t) : bool := Raw.subset' s s'.
+
+ Definition eq (s s':t) : Prop := Raw.eq s s'.
+ Definition lt (s s':t) : Prop := Raw.lt s s'.
+
+ Definition compare  (s s':t) : Compare lt eq s s'.
+ Proof.
+ intros; elim (Raw.compare _ _ (is_bst s) (is_bst s'));
+  [ constructor 1 | constructor 2 | constructor 3 ]; 
+  auto. 
+ Defined.
+
+ (* specs *)
+ Section Specs. 
+ Variable s s' s'': t. 
+ Variable x y : elt.
+
+ Hint Resolve is_bst is_avl.
+ 
+ Lemma mem_1 : In x s -> mem x s = true. 
+ Proof. exact (Raw.mem_1 s x (is_bst s)). Qed.
+ Lemma mem_2 : mem x s = true -> In x s.
+ Proof. exact (Raw.mem_2 s x). Qed.
+
+ Lemma equal_1 : Equal s s' -> equal s s' = true.
+ Proof. 
+ unfold equal; destruct (Raw.equal s s'); simpl; auto.
+ Qed.
+
+ Lemma equal_2 : equal s s' = true -> Equal s s'.
+ Proof. 
+ unfold equal; destruct (Raw.equal s s'); simpl; intuition; discriminate.
+ Qed.
+
+ Lemma equal'_1 : Equal s s' -> equal' s s' = true.
+ Proof. exact (Raw.equal'_1 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed.
+ Lemma equal'_2 : equal' s s' = true -> Equal s s'.
+ Proof. exact (Raw.equal'_2 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed.
+
+ Lemma subset_1 : Subset s s' -> subset s s' = true.
+ Proof. 
+ unfold subset; destruct (Raw.subset s s'); simpl; intuition.
+ Qed.
+
+ Lemma subset_2 : subset s s' = true -> Subset s s'.
+ Proof. 
+ unfold subset; destruct (Raw.subset s s'); simpl; intuition discriminate.
+ Qed.
+
+ Lemma subset'_1 : Subset s s' -> subset' s s' = true. 
+ Proof. exact (Raw.subset'_1 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed.
+ Lemma subset'_2 : subset' s s' = true -> Subset s s'.
+ Proof. exact (Raw.subset'_2 _ _ (is_bst s) (is_avl s) (is_bst s') (is_avl s')). Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact Raw.empty_1. Qed.
+
+ Lemma is_empty_1 : Empty s -> is_empty s = true.
+ Proof. exact (Raw.is_empty_1 s). Qed.
+ Lemma is_empty_2 : is_empty s = true -> Empty s. 
+ Proof. exact (Raw.is_empty_2 s). Qed.
+ 
+ Lemma add_1 : E.eq x y -> In y (add x s).
+ Proof. 
+ unfold add, In; simpl; rewrite Raw.add_in; auto.
+ Qed.
+
+ Lemma add_2 : In y s -> In y (add x s).
+ Proof.
+ unfold add, In; simpl; rewrite Raw.add_in; auto.
+ Qed.
+
+ Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+ Proof. 
+ unfold add, In; simpl; rewrite Raw.add_in; intuition.
+ elim H; auto.
+ Qed.
+
+ Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+ Proof. 
+ unfold remove, In; simpl; rewrite Raw.remove_in; intuition.
+ Qed.
+
+ Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+ Proof. 
+ unfold remove, In; simpl; rewrite Raw.remove_in; intuition.
+ Qed.
+
+ Lemma remove_3 : In y (remove x s) -> In y s.
+ Proof. 
+ unfold remove, In; simpl; rewrite Raw.remove_in; intuition.
+ Qed.
+
+ Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
+ Proof. exact (Raw.singleton_1 x y). Qed.
+ Lemma singleton_2 : E.eq x y -> In y (singleton x). 
+ Proof. exact (Raw.singleton_2 x y). Qed.
+
+ Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+ Proof.
+ unfold union, In; simpl.
+ destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) 
+  as (u,(b,(a,i))).
+ simpl in *; rewrite i; auto.
+ Qed.
+
+ Lemma union_2 : In x s -> In x (union s s'). 
+ Proof.
+ unfold union, In; simpl.
+ destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) 
+  as (u,(b,(a,i))).
+ simpl in *; rewrite i; auto.
+ Qed.
+
+ Lemma union_3 : In x s' -> In x (union s s').
+ Proof.
+ unfold union, In; simpl.
+ destruct (Raw.union s s' (is_bst s) (is_avl s) (is_bst s') (is_avl s')) 
+  as (u,(b,(a,i))).
+ simpl in *; rewrite i; auto.
+ Qed.
+
+ Lemma union'_1 : In x (union' s s') -> In x s \/ In x s'.
+ Proof.
+ unfold union', In; simpl; rewrite Raw.union'_in; intuition.
+ Qed.
+
+ Lemma union'_2 : In x s -> In x (union' s s'). 
+ Proof.
+ unfold union', In; simpl; rewrite Raw.union'_in; intuition.
+ Qed.
+
+ Lemma union'_3 : In x s' -> In x (union' s s').
+ Proof.
+ unfold union', In; simpl; rewrite Raw.union'_in; intuition.
+ Qed.
+
+ Lemma inter_1 : In x (inter s s') -> In x s.
+ Proof.
+ unfold inter, In; simpl; rewrite Raw.inter_in; intuition.
+ Qed.
+
+ Lemma inter_2 : In x (inter s s') -> In x s'.
+ Proof. 
+ unfold inter, In; simpl; rewrite Raw.inter_in; intuition.
+ Qed.
+
+ Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+ Proof. 
+ unfold inter, In; simpl; rewrite Raw.inter_in; intuition.
+ Qed.
+ 
+ Lemma diff_1 : In x (diff s s') -> In x s. 
+ Proof. 
+ unfold diff, In; simpl; rewrite Raw.diff_in; intuition.
+ Qed.
+
+ Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+ Proof. 
+ unfold diff, In; simpl; rewrite Raw.diff_in; intuition.
+ Qed.
+
+ Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+ Proof. 
+ unfold diff, In; simpl; rewrite Raw.diff_in; intuition.
+ Qed.
+ 
+ Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+      fold A f s i = fold_left (fun a e => f e a) (elements s) i.
+ Proof. 
+ unfold fold, elements; intros; apply Raw.fold_1; auto.
+ Qed.
+
+ Lemma cardinal_1 : cardinal s = length (elements s).
+ Proof. 
+ unfold cardinal, elements; intros; apply Raw.cardinal_elements_1; auto.
+ Qed.
+
+ Section Filter.
+ Variable f : elt -> bool.
+
+ Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
+ Proof. 
+ intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition.
+ Qed.
+
+ Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+ Proof. 
+ intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition.
+ Qed.
+
+ Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+ Proof. 
+ intro; unfold filter, In; simpl; rewrite Raw.filter_in; intuition.
+ Qed.
+
+ Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true.
+ Proof. exact (Raw.for_all_1 f s). Qed.
+ Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s.
+ Proof. exact (Raw.for_all_2 f s). Qed.
+
+ Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+ Proof. exact (Raw.exists_1 f s). Qed.
+ Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+ Proof. exact (Raw.exists_2 f s). Qed.
+
+ Lemma partition_1 : compat_bool E.eq f -> 
+  Equal (fst (partition f s)) (filter f s).
+ Proof.
+ unfold partition, filter, Equal, In; simpl ;intros H a.
+ rewrite Raw.partition_in_1; auto.
+ rewrite Raw.filter_in; intuition.
+ Qed.
+
+ Lemma partition_2 : compat_bool E.eq f -> 
+  Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+ Proof.
+ unfold partition, filter, Equal, In; simpl ;intros H a.
+ rewrite Raw.partition_in_2; auto.
+ rewrite Raw.filter_in; intuition.
+ red; intros.
+ f_equal; auto.
+ destruct (f a); auto.
+ destruct (f a); auto.
+ Qed.
+
+ End Filter.
+
+ Lemma elements_1 : In x s -> InA E.eq x (elements s).
+ Proof. 
+ unfold elements, In; rewrite Raw.elements_in; auto.
+ Qed.
+
+ Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+ Proof. 
+ unfold elements, In; rewrite Raw.elements_in; auto.
+ Qed.
+
+ Lemma elements_3 : sort E.lt (elements s).
+ Proof. exact (Raw.elements_sort _ (is_bst s)). Qed.
+
+ Lemma min_elt_1 : min_elt s = Some x -> In x s. 
+ Proof. exact (Raw.min_elt_1 s x). Qed.
+ Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
+ Proof. exact (Raw.min_elt_2 s x y (is_bst s)). Qed.
+ Lemma min_elt_3 : min_elt s = None -> Empty s.
+ Proof. exact (Raw.min_elt_3 s). Qed.
+
+ Lemma max_elt_1 : max_elt s = Some x -> In x s. 
+ Proof. exact (Raw.max_elt_1 s x). Qed.
+ Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
+ Proof. exact (Raw.max_elt_2 s x y (is_bst s)). Qed.
+ Lemma max_elt_3 : max_elt s = None -> Empty s.
+ Proof. exact (Raw.max_elt_3 s). Qed.
+
+ Lemma choose_1 : choose s = Some x -> In x s.
+ Proof. exact (Raw.choose_1 s x). Qed.
+ Lemma choose_2 : choose s = None -> Empty s.
+ Proof. exact (Raw.choose_2 s). Qed.
+
+ Lemma eq_refl : eq s s. 
+ Proof. exact (Raw.eq_refl s). Qed.
+ Lemma eq_sym : eq s s' -> eq s' s.
+ Proof. exact (Raw.eq_sym s s'). Qed.
+ Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
+ Proof. exact (Raw.eq_trans s s' s''). Qed.
+  
+ Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
+ Proof. exact (Raw.lt_trans s s' s''). Qed.
+ Lemma lt_not_eq : lt s s' -> ~eq s s'.
+ Proof. exact (Raw.lt_not_eq _ _ (is_bst s) (is_bst s')). Qed.
+
+ End Specs.
+End IntMake.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
+
+
diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v
new file mode 100644
index 00000000..08985cfc
--- /dev/null
+++ b/theories/FSets/FSetBridge.v
@@ -0,0 +1,750 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetBridge.v 8834 2006-05-20 00:41:35Z letouzey $ *)
+
+(** * Finite sets library *)
+
+(** This module implements bridges (as functors) from dependent
+    to/from non-dependent set signature. *)
+
+Require Export FSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+Set Firstorder Depth 2.
+
+(** * From non-dependent signature [S] to dependent signature [Sdep]. *)
+
+Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
+  Import M.
+
+  Module ME := OrderedTypeFacts E.
+   
+  Definition empty : {s : t | Empty s}.
+  Proof. 
+    exists empty; auto.
+  Qed.
+
+  Definition is_empty : forall s : t, {Empty s} + {~ Empty s}.
+  Proof. 
+    intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)).
+    case (is_empty s); intuition.
+  Qed.
+
+
+  Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}.
+  Proof. 
+    intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)).
+    case (mem x s); intuition.
+  Qed.
+ 
+  Definition Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq x y \/ In y s.
+ 
+  Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
+  Proof.
+    intros; exists (add x s); auto.
+    unfold Add in |- *; intuition.
+    elim (ME.eq_dec x y); auto.
+    intros; right. 
+    eapply add_3; eauto.
+  Qed. 
+ 
+  Definition singleton :
+    forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
+  Proof. 
+    intros; exists (singleton x); intuition.
+  Qed.
+ 
+  Definition remove :
+    forall (x : elt) (s : t),
+    {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}.
+  Proof.
+    intros; exists (remove x s); intuition.
+    absurd (In x (remove x s)); auto.
+    apply In_1 with y; auto. 
+    elim (ME.eq_dec x y); intros; auto.
+    absurd (In x (remove x s)); auto.
+    apply In_1 with y; auto. 
+    eauto.
+  Qed.
+
+  Definition union :
+    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}.
+  Proof.
+    intros; exists (union s s'); intuition.
+  Qed.    
+
+  Definition inter :
+    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}.
+  Proof. 
+    intros; exists (inter s s'); intuition; eauto.
+  Qed.
+
+  Definition diff :
+    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
+  Proof. 
+    intros; exists (diff s s'); intuition; eauto. 
+    absurd (In x s'); eauto. 
+  Qed. 
+ 
+  Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}.
+  Proof. 
+    intros. 
+    generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')).
+    case (equal s s'); intuition.
+  Qed.
+
+  Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}.
+  Proof. 
+    intros. 
+    generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')).
+    case (subset s s'); intuition.
+  Qed.   
+
+  Definition elements :
+    forall s : t,
+    {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}.
+   Proof.
+     intros; exists (elements s); intuition.   
+   Defined. 
+
+  Definition fold :
+    forall (A : Set) (f : elt -> A -> A) (s : t) (i : A),
+    {r : A |   let (l,_) := elements s in 
+                  r = fold_left (fun a e => f e a) l i}.
+  Proof. 
+  intros; exists (fold (A:=A) f s i); exact (fold_1 s i f).
+  Qed.
+
+  Definition cardinal :
+      forall s : t,
+      {r : nat | let (l,_) := elements s in r = length l }.
+  Proof.
+    intros; exists (cardinal s); exact (cardinal_1 s).
+  Qed.    
+
+  Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+    (x : elt) := if Pdec x then true else false. 
+
+  Lemma compat_P_aux :
+   forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}),
+   compat_P E.eq P -> compat_bool E.eq (fdec Pdec).
+  Proof.
+    unfold compat_P, compat_bool, fdec in |- *; intros.
+    generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder.
+  Qed.
+
+  Hint Resolve compat_P_aux.
+
+  Definition filter :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}.
+  Proof.
+    intros. 
+    exists (filter (fdec Pdec) s).
+    intro H; assert (compat_bool E.eq (fdec Pdec)); auto.
+    intuition.
+    eauto.
+    generalize (filter_2 H0 H1).
+    unfold fdec in |- *.
+    case (Pdec x); intuition.
+    inversion H2.
+    apply filter_3; auto.
+    unfold fdec in |- *; simpl in |- *.
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition for_all :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
+  Proof. 
+    intros. 
+    generalize (for_all_1 (s:=s) (f:=fdec Pdec))
+     (for_all_2 (s:=s) (f:=fdec Pdec)).
+    case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ];
+     intros.
+    assert (compat_bool E.eq (fdec Pdec)); auto.
+    generalize (H0 H3 (refl_equal _) _ H2).
+    unfold fdec in |- *. 
+    case (Pdec x); intuition.
+    inversion H4.
+    intuition.    
+    absurd (false = true); [ auto with bool | apply H; auto ].
+    intro.
+    unfold fdec in |- *. 
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition exists_ :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
+  Proof. 
+    intros. 
+    generalize (exists_1 (s:=s) (f:=fdec Pdec))
+     (exists_2 (s:=s) (f:=fdec Pdec)).
+    case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ];
+     intros.
+    elim H0; auto; intros.
+    exists x; intuition.
+    generalize H4.
+    unfold fdec in |- *. 
+    case (Pdec x); intuition.
+    inversion H2.
+    intuition. 
+    elim H2; intros.    
+    absurd (false = true); [ auto with bool | apply H; auto ].
+    exists x; intuition.
+    unfold fdec in |- *. 
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition partition :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {partition : t * t |
+    let (s1, s2) := partition in
+    compat_P E.eq P ->
+    For_all P s1 /\
+    For_all (fun x => ~ P x) s2 /\
+    (forall x : elt, In x s <-> In x s1 \/ In x s2)}.
+  Proof.
+    intros.
+    exists (partition (fdec Pdec) s).
+    generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)).
+    case (partition (fdec Pdec) s).
+    intros s1 s2; simpl in |- *.
+    intros; assert (compat_bool E.eq (fdec Pdec)); auto.
+    intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))).
+    generalize H2; unfold compat_bool in |- *; intuition;
+     apply (f_equal negb); auto.
+    intuition.
+    generalize H4; unfold For_all, Equal in |- *; intuition.
+    elim (H0 x); intros.
+    assert (fdec Pdec x = true).
+     eauto.      
+    generalize H8; unfold fdec in |- *; case (Pdec x); intuition.
+    inversion H9.
+    generalize H; unfold For_all, Equal in |- *; intuition.
+    elim (H0 x); intros.
+    cut ((fun x => negb (fdec Pdec x)) x = true). 
+    unfold fdec in |- *; case (Pdec x); intuition.
+      change ((fun x => negb (fdec Pdec x)) x = true) in |- *.
+      apply (filter_2 (s:=s) (x:=x)); auto.
+    set (b := fdec Pdec x) in *; generalize (refl_equal b);
+     pattern b at -1 in |- *; case b; unfold b in |- *; 
+     [ left | right ].
+    elim (H4 x); intros _ B; apply B; auto.
+    elim (H x); intros _ B; apply B; auto.
+    apply filter_3; auto.
+    rewrite H5; auto.
+    eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B;
+     auto.
+    eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto.
+  Qed. 
+
+  Definition choose : forall s : t, {x : elt | In x s} + {Empty s}.
+  Proof.  
+    intros.
+    generalize (choose_1 (s:=s)) (choose_2 (s:=s)).
+    case (choose s); [ left | right ]; auto.
+    exists e; auto.    
+  Qed.
+
+  Definition min_elt :
+    forall s : t,
+    {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}.
+  Proof. 
+    intros;
+     generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)).
+    case (min_elt s); [ left | right ]; auto.    
+    exists e; unfold For_all in |- *; eauto.
+  Qed. 
+
+  Definition max_elt :
+    forall s : t,
+    {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}.
+  Proof. 
+    intros;
+     generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)).
+    case (max_elt s); [ left | right ]; auto.    
+    exists e; unfold For_all in |- *; eauto.
+  Qed. 
+
+  Module E := E. 
+
+  Definition elt := elt.
+  Definition t := t.
+
+  Definition In := In. 
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) (s : t) :=
+    forall x : elt, In x s -> P x.
+  Definition Exists (P : elt -> Prop) (s : t) :=
+    exists x : elt, In x s /\ P x.
+  
+  Definition eq_In := In_1.
+
+  Definition eq := Equal.
+  Definition lt := lt.
+  Definition eq_refl := eq_refl.
+  Definition eq_sym := eq_sym.
+  Definition eq_trans := eq_trans.
+  Definition lt_trans := lt_trans. 
+  Definition lt_not_eq := lt_not_eq.
+  Definition compare := compare.
+
+End DepOfNodep.
+
+
+(** * From dependent signature [Sdep] to non-dependent signature [S]. *)
+
+Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
+  Import M.
+
+  Module ME := OrderedTypeFacts E.
+
+  Definition empty : t := let (s, _) := empty in s.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+    unfold empty in |- *; case M.empty; auto.
+  Qed.
+
+  Definition is_empty (s : t) : bool :=
+    if is_empty s then true else false.
+
+  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
+  Proof.
+    intros; unfold is_empty in |- *; case (M.is_empty s); auto.
+  Qed.
+
+  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s.
+  Proof.
+    intro s; unfold is_empty in |- *; case (M.is_empty s); auto.
+    intros; discriminate H.
+  Qed.
+
+  Definition mem (x : elt) (s : t) : bool :=
+    if mem x s then true else false.
+
+  Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true.
+  Proof.
+    intros; unfold mem in |- *; case (M.mem x s); auto.
+  Qed.
+   
+  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
+  Proof.
+    intros s x; unfold mem in |- *; case (M.mem x s); auto.
+    intros; discriminate H.
+  Qed.
+
+  Definition equal (s s' : t) : bool :=
+    if equal s s' then true else false.
+
+  Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true.
+  Proof. 
+    intros; unfold equal in |- *; case M.equal; intuition.
+  Qed.    
+ 
+  Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
+  Proof. 
+    intros s s'; unfold equal in |- *; case (M.equal s s'); intuition;
+     inversion H.
+  Qed.
+  
+  Definition subset (s s' : t) : bool :=
+    if subset s s' then true else false.
+
+  Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true.
+  Proof. 
+    intros; unfold subset in |- *; case M.subset; intuition.
+  Qed.    
+ 
+  Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
+  Proof. 
+    intros s s'; unfold subset in |- *; case (M.subset s s'); intuition;
+     inversion H.
+  Qed.
+
+  Definition choose (s : t) : option elt :=
+    match choose s with
+    | inleft (exist x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s.
+  Proof.
+    intros s x; unfold choose in |- *; case (M.choose s).
+    simple destruct s0; intros; injection H; intros; subst; auto.
+    intros; discriminate H.
+  Qed.
+
+  Lemma choose_2 : forall s : t, choose s = None -> Empty s.
+  Proof.
+    intro s; unfold choose in |- *; case (M.choose s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed.
+
+  Definition elements (s : t) : list elt := let (l, _) := elements s in l. 
+ 
+  Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s).
+  Proof. 
+    intros; unfold elements in |- *; case (M.elements s); firstorder.
+  Qed.
+
+  Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s.
+  Proof. 
+    intros s x; unfold elements in |- *; case (M.elements s); firstorder.
+  Qed.
+
+  Lemma elements_3 : forall s : t, sort E.lt (elements s).  
+  Proof. 
+    intros; unfold elements in |- *; case (M.elements s); firstorder.
+  Qed.
+
+  Definition min_elt (s : t) : option elt :=
+    match min_elt s with
+    | inleft (exist x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. 
+  Proof.
+    intros s x; unfold min_elt in |- *; case (M.min_elt s).
+    simple destruct s0; intros; injection H; intros; subst; intuition.
+    intros; discriminate H.
+  Qed. 
+
+  Lemma min_elt_2 :
+   forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. 
+  Proof.
+    intros s x y; unfold min_elt in |- *; case (M.min_elt s).
+    unfold For_all in |- *; simple destruct s0; intros; injection H; intros;
+     subst; firstorder.
+    intros; discriminate H.
+  Qed. 
+
+  Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
+  Proof.
+    intros s; unfold min_elt in |- *; case (M.min_elt s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed. 
+
+  Definition max_elt (s : t) : option elt :=
+    match max_elt s with
+    | inleft (exist x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. 
+  Proof.
+    intros s x; unfold max_elt in |- *; case (M.max_elt s).
+    simple destruct s0; intros; injection H; intros; subst; intuition.
+    intros; discriminate H.
+  Qed. 
+
+  Lemma max_elt_2 :
+   forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. 
+  Proof.
+    intros s x y; unfold max_elt in |- *; case (M.max_elt s).
+    unfold For_all in |- *; simple destruct s0; intros; injection H; intros;
+     subst; firstorder.
+    intros; discriminate H.
+  Qed. 
+
+  Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
+  Proof.
+    intros s; unfold max_elt in |- *; case (M.max_elt s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed. 
+
+  Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'.
+
+  Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s).
+  Proof.
+    intros; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+     firstorder.
+  Qed.
+
+  Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s).
+  Proof.
+    intros; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+     firstorder.
+  Qed.
+
+  Lemma add_3 :
+   forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s.
+  Proof.
+    intros s x y; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+     firstorder.
+  Qed.
+
+  Definition remove (x : elt) (s : t) : t := let (s', _) := remove x s in s'.
+
+  Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s).
+  Proof.
+    intros; unfold remove in |- *; case (M.remove x s); firstorder.
+  Qed.
+
+  Lemma remove_2 :
+   forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s).
+  Proof.
+    intros; unfold remove in |- *; case (M.remove x s); firstorder.
+  Qed.
+
+  Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s.
+  Proof.
+    intros s x y; unfold remove in |- *; case (M.remove x s); firstorder.
+  Qed.
+  
+  Definition singleton (x : elt) : t := let (s, _) := singleton x in s. 
+ 
+  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. 
+  Proof.
+    intros x y; unfold singleton in |- *; case (M.singleton x); firstorder.
+  Qed.
+
+  Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). 
+  Proof.
+    intros x y; unfold singleton in |- *; case (M.singleton x); firstorder.
+  Qed.
+  
+  Definition union (s s' : t) : t := let (s'', _) := union s s' in s''.
+ 
+  Lemma union_1 :
+   forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'.
+  Proof. 
+    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+  Qed.
+
+  Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). 
+  Proof. 
+    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+  Qed.
+
+  Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s').
+  Proof. 
+    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+  Qed.
+
+  Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''.
+ 
+  Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s.
+  Proof. 
+    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+  Qed.
+
+  Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'.
+  Proof. 
+    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+  Qed.
+
+  Lemma inter_3 :
+   forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s').
+  Proof. 
+    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+  Qed.
+
+  Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''.
+ 
+  Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s.
+  Proof. 
+    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+  Qed.
+
+  Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'.
+  Proof. 
+    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+  Qed.
+
+  Lemma diff_3 :
+   forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s').
+  Proof. 
+    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+  Qed.
+
+  Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f.
+
+  Lemma cardinal_1 : forall s, cardinal s = length (elements s).
+  Proof.
+    intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; 
+    destruct (M.elements s); auto.
+  Qed.
+
+  Definition fold (B : Set) (f : elt -> B -> B) (i : t) 
+    (s : B) : B := let (fold, _) := fold f i s in fold.
+
+  Lemma fold_1 :
+   forall (s : t) (A : Set) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof.
+    intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; 
+    destruct (M.elements s); auto.
+  Qed.  
+
+  Definition f_dec :
+    forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}.
+  Proof.
+    intros; case (f x); auto with bool.
+  Defined. 
+
+  Lemma compat_P_aux :
+   forall f : elt -> bool,
+   compat_bool E.eq f -> compat_P E.eq (fun x => f x = true).
+  Proof.
+     unfold compat_bool, compat_P in |- *; intros; rewrite <- H1; firstorder.
+  Qed.
+
+  Hint Resolve compat_P_aux.
+    
+  Definition filter (f : elt -> bool) (s : t) : t :=
+    let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'.
+
+  Lemma filter_1 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x (filter f s) -> In x s.
+  Proof.
+    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    generalize (i (compat_P_aux H)); firstorder.
+  Qed.
+
+  Lemma filter_2 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Proof.
+    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    generalize (i (compat_P_aux H)); firstorder.
+  Qed.
+
+  Lemma filter_3 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).     
+  Proof.
+    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    generalize (i (compat_P_aux H)); firstorder.
+  Qed.
+
+  Definition for_all (f : elt -> bool) (s : t) : bool :=
+    if for_all (P:=fun x => f x = true) (f_dec f) s
+    then true
+    else false. 
+
+  Lemma for_all_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f ->
+   For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. 
+    intros s f; unfold for_all in |- *; case M.for_all; intuition; elim n;
+     auto.
+  Qed.
+ 
+  Lemma for_all_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f ->
+   for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. 
+    intros s f; unfold for_all in |- *; case M.for_all; intuition;
+     inversion H0.
+  Qed.
+  
+  Definition exists_ (f : elt -> bool) (s : t) : bool :=
+    if exists_ (P:=fun x => f x = true) (f_dec f) s
+    then true
+    else false. 
+
+  Lemma exists_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof. 
+    intros s f; unfold exists_ in |- *; case M.exists_; intuition; elim n;
+     auto.
+  Qed.
+ 
+  Lemma exists_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. 
+    intros s f; unfold exists_ in |- *; case M.exists_; intuition;
+     inversion H0.
+  Qed.
+     
+  Definition partition (f : elt -> bool) (s : t) : 
+    t * t :=
+    let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p.
+  
+  Lemma partition_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof.
+    intros s f; unfold partition in |- *; case M.partition. 
+    intro p; case p; clear p; intros s1 s2 H C. 
+    generalize (H (compat_P_aux C)); clear H; intro H.
+    simpl in |- *; unfold Equal in |- *; intuition.
+    apply filter_3; firstorder. 
+    elim (H2 a); intros. 
+    assert (In a s). 
+     eapply filter_1; eauto.
+    elim H3; intros; auto.
+    absurd (f a = true).
+    exact (H a H6).
+    eapply filter_2; eauto. 
+  Qed.    
+    
+  Lemma partition_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+    intros s f; unfold partition in |- *; case M.partition. 
+    intro p; case p; clear p; intros s1 s2 H C. 
+    generalize (H (compat_P_aux C)); clear H; intro H.
+    assert (D : compat_bool E.eq (fun x => negb (f x))).
+    generalize C; unfold compat_bool in |- *; intros; apply (f_equal negb);
+     auto.
+    simpl in |- *; unfold Equal in |- *; intuition.
+    apply filter_3; firstorder.
+    elim (H2 a); intros. 
+    assert (In a s). 
+     eapply filter_1; eauto.
+    elim H3; intros; auto.
+    absurd (f a = true).
+    intro.
+    generalize (filter_2 D H1). 
+    rewrite H7; intros H8; inversion H8.
+    exact (H0 a H6).
+  Qed. 
+
+
+  Module E := E. 
+  Definition elt := elt.
+  Definition t := t.
+
+  Definition In := In. 
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq y x \/ In y s.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) (s : t) :=
+    forall x : elt, In x s -> P x.
+  Definition Exists (P : elt -> Prop) (s : t) :=
+    exists x : elt, In x s /\ P x.
+
+  Definition In_1 := eq_In.
+
+  Definition eq := Equal.
+  Definition lt := lt.
+  Definition eq_refl := eq_refl.
+  Definition eq_sym := eq_sym.
+  Definition eq_trans := eq_trans.
+  Definition lt_trans := lt_trans. 
+  Definition lt_not_eq := lt_not_eq.
+  Definition compare := compare.
+
+End NodepOfDep.
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
new file mode 100644
index 00000000..d7062d5a
--- /dev/null
+++ b/theories/FSets/FSetEqProperties.v
@@ -0,0 +1,928 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetEqProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *)
+
+(** * Finite sets library *)
+
+(** This module proves many properties of finite sets that 
+    are consequences of the axiomatization in [FsetInterface] 
+    Contrary to the functor in [FsetProperties] it uses 
+    sets operations instead of predicates over sets, i.e.
+    [mem x s=true] instead of [In x s], 
+    [equal s s'=true] instead of [Equal s s'], etc. *)
+
+
+Require Import FSetProperties.
+Require Import Zerob.
+Require Import Sumbool.
+Require Import Omega.
+
+Module EqProperties (M:S).
+Import M.
+Import Logic. (* to unmask [eq] *)  
+Import Peano. (* to unmask [lt] *)
+  
+Module ME := OrderedTypeFacts E.  
+Module MP := Properties M.
+Import MP.
+Import MP.FM.
+
+Definition Add := MP.Add.
+
+Section BasicProperties. 
+
+(** Some old specifications written with boolean equalities. *) 
+
+Variable s s' s'': t.
+Variable x y z : elt.
+
+Lemma mem_eq: 
+  E.eq x y -> mem x s=mem y s.
+Proof. 
+intro H; rewrite H; auto.
+Qed.
+
+Lemma equal_mem_1: 
+  (forall a, mem a s=mem a s') -> equal s s'=true.
+Proof. 
+intros; apply equal_1; unfold Equal; intros.
+do 2 rewrite mem_iff; rewrite H; tauto.
+Qed.
+
+Lemma equal_mem_2: 
+  equal s s'=true -> forall a, mem a s=mem a s'.
+Proof. 
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma subset_mem_1: 
+  (forall a, mem a s=true->mem a s'=true) -> subset s s'=true.
+Proof. 
+intros; apply subset_1; unfold Subset; intros a.
+do 2 rewrite mem_iff; auto.
+Qed.
+
+Lemma subset_mem_2: 
+  subset s s'=true -> forall a, mem a s=true -> mem a s'=true.
+Proof. 
+intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto.
+Qed.
+  
+Lemma empty_mem: mem x empty=false.
+Proof. 
+rewrite <- not_mem_iff; auto.
+Qed.
+
+Lemma is_empty_equal_empty: is_empty s = equal s empty.
+Proof. 
+apply bool_1; split; intros.
+rewrite <- (empty_is_empty_1 (s:=empty)); auto with set.
+rewrite <- is_empty_iff; auto with set.
+Qed.
+  
+Lemma choose_mem_1: choose s=Some x -> mem x s=true.
+Proof.  
+auto.
+Qed.
+
+Lemma choose_mem_2: choose s=None -> is_empty s=true.
+Proof.
+auto.
+Qed.
+
+Lemma add_mem_1: mem x (add x s)=true.
+Proof.
+auto.
+Qed.  
+ 
+Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s.
+Proof. 
+apply add_neq_b.
+Qed.
+
+Lemma remove_mem_1: mem x (remove x s)=false.
+Proof. 
+rewrite <- not_mem_iff; auto.
+Qed. 
+ 
+Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s.
+Proof. 
+apply remove_neq_b.
+Qed.
+
+Lemma singleton_equal_add: 
+  equal (singleton x) (add x empty)=true.
+Proof.
+rewrite (singleton_equal_add x); auto with set.
+Qed.  
+
+Lemma union_mem: 
+  mem x (union s s')=mem x s || mem x s'.
+Proof. 
+apply union_b.
+Qed.
+
+Lemma inter_mem: 
+  mem x (inter s s')=mem x s && mem x s'.
+Proof. 
+apply inter_b.
+Qed.
+
+Lemma diff_mem: 
+  mem x (diff s s')=mem x s && negb (mem x s').
+Proof. 
+apply diff_b.
+Qed.
+
+(** properties of [mem] *)
+
+Lemma mem_3 : ~In x s -> mem x s=false.
+Proof.
+intros; rewrite <- not_mem_iff; auto.
+Qed.
+
+Lemma mem_4 : mem x s=false -> ~In x s.
+Proof.
+intros; rewrite not_mem_iff; auto.
+Qed.
+
+(** Properties of [equal] *) 
+
+Lemma equal_refl: equal s s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma equal_sym: equal s s'=equal s' s.
+Proof.
+intros; apply bool_1; do 2 rewrite <- equal_iff; intuition.
+Qed.
+
+Lemma equal_trans: 
+ equal s s'=true -> equal s' s''=true -> equal s s''=true.
+Proof.
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma equal_equal: 
+ equal s s'=true -> equal s s''=equal s' s''.
+Proof.
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma equal_cardinal: 
+ equal s s'=true -> cardinal s=cardinal s'.
+Proof.
+auto with set.
+Qed.
+
+(* Properties of [subset] *)
+
+Lemma subset_refl: subset s s=true. 
+Proof.
+auto with set.
+Qed.
+
+Lemma subset_antisym: 
+ subset s s'=true -> subset s' s=true -> equal s s'=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma subset_trans: 
+ subset s s'=true -> subset s' s''=true -> subset s s''=true.
+Proof.
+do 3 rewrite <- subset_iff; intros.
+apply subset_trans with s'; auto.
+Qed.
+
+Lemma subset_equal: 
+ equal s s'=true -> subset s s'=true.
+Proof.
+auto with set.
+Qed.
+
+(** Properties of [choose] *)
+
+Lemma choose_mem_3: 
+ is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}.
+Proof.
+intros.
+generalize (@choose_1 s) (@choose_2 s).
+destruct (choose s);intros.
+exists e;auto.
+generalize (H1 (refl_equal None)); clear H1.
+intros; rewrite (is_empty_1 H1) in H; discriminate.
+Qed.
+
+Lemma choose_mem_4: choose empty=None.
+Proof.
+generalize (@choose_1 empty).
+case (@choose empty);intros;auto.
+elim (@empty_1 e); auto.
+Qed.
+
+(** Properties of [add] *)
+
+Lemma add_mem_3: 
+ mem y s=true -> mem y (add x s)=true.
+Proof.
+auto.
+Qed.
+
+Lemma add_equal: 
+ mem x s=true -> equal (add x s) s=true.
+Proof.
+auto with set.
+Qed.
+
+(** Properties of [remove] *)
+
+Lemma remove_mem_3: 
+ mem y (remove x s)=true -> mem y s=true.
+Proof.
+rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto.
+Qed.
+
+Lemma remove_equal: 
+ mem x s=false -> equal (remove x s) s=true.
+Proof.
+intros; apply equal_1; apply remove_equal.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma add_remove: 
+ mem x s=true -> equal (add x (remove x s)) s=true.
+Proof.
+intros; apply equal_1; apply add_remove; auto.
+Qed.
+
+Lemma remove_add: 
+ mem x s=false -> equal (remove x (add x s)) s=true.
+Proof.
+intros; apply equal_1; apply remove_add; auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+(** Properties of [is_empty] *)
+
+Lemma is_empty_cardinal: is_empty s = zerob (cardinal s).
+Proof.
+intros; apply bool_1; split; intros.
+rewrite cardinal_1; simpl; auto.
+assert (cardinal s = 0) by (apply zerob_true_elim; auto).
+auto.
+Qed.
+
+(** Properties of [singleton] *)
+
+Lemma singleton_mem_1: mem x (singleton x)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false.
+Proof.
+intros; rewrite singleton_b.
+unfold ME.eqb; destruct (ME.eq_dec x y); intuition.
+Qed.
+
+Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y.
+Proof.
+auto.
+Qed.
+
+(** Properties of [union] *)
+
+Lemma union_sym:
+ equal (union s s') (union s' s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_subset_equal: 
+ subset s s'=true -> equal (union s s') s'=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_equal_1: 
+ equal s s'=true-> equal (union s s'') (union s' s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_equal_2: 
+ equal s' s''=true-> equal (union s s') (union s s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_assoc: 
+ equal (union (union s s') s'') (union s (union s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_union_singleton: 
+ equal (add x s) (union (singleton x) s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_add: 
+ equal (union (add x s) s') (add x (union s s'))=true.
+Proof.
+auto with set.
+Qed.
+
+(* caracterisation of [union] via [subset] *)
+
+Lemma union_subset_1: subset s (union s s')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_subset_2: subset s' (union s s')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_subset_3:
+ subset s s''=true -> subset s' s''=true -> 
+  subset (union s s') s''=true.
+Proof.
+intros; apply subset_1; apply union_subset_3; auto.
+Qed.
+
+(** Properties of [inter] *) 
+
+Lemma inter_sym: equal (inter s s') (inter s' s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_subset_equal: 
+ subset s s'=true -> equal (inter s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_equal_1: 
+ equal s s'=true -> equal (inter s s'') (inter s' s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_equal_2: 
+ equal s' s''=true -> equal (inter s s') (inter s s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_assoc: 
+ equal (inter (inter s s') s'') (inter s (inter s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_inter_1: 
+ equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_inter_2: 
+ equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_add_1: mem x s'=true -> 
+ equal (inter (add x s) s') (add x (inter s s'))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_add_2: mem x s'=false -> 
+ equal (inter (add x s) s') (inter s s')=true.
+Proof.
+intros; apply equal_1; apply inter_add_2.
+rewrite not_mem_iff; auto.
+Qed.
+
+(* caracterisation of [union] via [subset] *)
+
+Lemma inter_subset_1: subset (inter s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_subset_2: subset (inter s s') s'=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_subset_3:
+ subset s'' s=true -> subset s'' s'=true -> 
+  subset s'' (inter s s')=true.
+Proof.
+intros; apply subset_1; apply inter_subset_3; auto.
+Qed.
+
+(** Properties of [diff] *)
+
+Lemma diff_subset: subset (diff s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_subset_equal:
+ subset s s'=true -> equal (diff s s') empty=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma remove_inter_singleton: 
+ equal (remove x s) (diff s (singleton x))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_inter_empty:
+ equal (inter (diff s s') (inter s s')) empty=true. 
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_inter_all: 
+ equal (union (diff s s') (inter s s')) s=true.
+Proof.
+auto with set.
+Qed.
+
+End BasicProperties.
+
+Hint Immediate empty_mem is_empty_equal_empty add_mem_1
+   remove_mem_1 singleton_equal_add union_mem inter_mem
+   diff_mem equal_sym add_remove remove_add : set. 
+Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1
+   choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal
+   subset_refl subset_equal subset_antisym
+   add_mem_3 add_equal remove_mem_3 remove_equal : set.
+
+
+(** General recursion principes based on [cardinal] *)
+
+Lemma cardinal_set_rec:  forall (P:t->Type),
+ (forall s s', equal s s'=true -> P s -> P s') -> 
+ (forall s x, mem x s=false -> P s -> P (add x s)) -> 
+ P empty -> forall n s, cardinal s=n -> P s.
+Proof.
+intros.
+apply cardinal_induction with n; auto; intros.
+apply X with empty; auto with set.
+apply X with (add x s0); auto with set.
+apply equal_1; intro a; rewrite add_iff; rewrite (H1 a); tauto.
+apply X0; auto with set; apply mem_3; auto.
+Qed.
+
+Lemma set_rec:  forall (P:t->Type),
+ (forall s s', equal s s'=true -> P s -> P s') ->
+ (forall s x, mem x s=false -> P s -> P (add x s)) -> 
+ P empty -> forall s, P s.
+Proof.
+intros;apply cardinal_set_rec with (cardinal s);auto.
+Qed.
+
+(** Properties of [fold] *)
+
+Lemma exclusive_set : forall s s' x,
+ ~In x s\/~In x s' <-> mem x s && mem x s'=false.
+Proof.
+intros; do 2 rewrite not_mem_iff.
+destruct (mem x s); destruct (mem x s'); intuition.
+Qed.
+
+Section Fold. 
+Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
+Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
+Variables (i:A).
+Variables (s s':t)(x:elt).
+ 
+Lemma fold_empty: eqA (fold f empty i) i.
+Proof. 
+apply fold_empty; auto.
+Qed.
+
+Lemma fold_equal: 
+ equal s s'=true -> eqA (fold f s i) (fold f s' i).
+Proof. 
+intros; apply fold_equal with (eqA:=eqA); auto.
+Qed.
+   
+Lemma fold_add: 
+ mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)).
+Proof. 
+intros; apply fold_add with (eqA:=eqA); auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma add_fold: 
+  mem x s=true -> eqA (fold f (add x s) i) (fold f s i).
+Proof.
+intros; apply add_fold with (eqA:=eqA); auto.
+Qed.
+
+Lemma remove_fold_1: 
+ mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i).
+Proof.
+intros; apply remove_fold_1 with (eqA:=eqA); auto.
+Qed.
+
+Lemma remove_fold_2: 
+ mem x s=false -> eqA (fold f (remove x s) i) (fold f s i).
+Proof.
+intros; apply remove_fold_2 with (eqA:=eqA); auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma fold_union: 
+ (forall x, mem x s && mem x s'=false) -> 
+ eqA (fold f (union s s') i) (fold f s (fold f s' i)).
+Proof.
+intros; apply fold_union with (eqA:=eqA); auto.
+intros; rewrite exclusive_set; auto.
+Qed.
+
+End Fold.
+
+(** Properties of [cardinal] *)
+
+Lemma add_cardinal_1: 
+ forall s x, mem x s=true -> cardinal (add x s)=cardinal s.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_cardinal_2: 
+ forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s).
+Proof.
+intros; apply add_cardinal_2; auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma remove_cardinal_1: 
+ forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s.
+Proof.
+intros; apply remove_cardinal_1; auto.
+Qed.
+
+Lemma remove_cardinal_2: 
+ forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_cardinal: 
+ forall s s', (forall x, mem x s && mem x s'=false) -> 
+ cardinal (union s s')=cardinal s+cardinal s'.
+Proof.
+intros; apply union_cardinal; auto; intros.
+rewrite exclusive_set; auto.
+Qed.
+
+Lemma subset_cardinal: 
+ forall s s', subset s s'=true -> cardinal s<=cardinal s'.
+Proof.
+intros; apply subset_cardinal; auto.
+Qed.
+
+Section Bool.
+
+(** Properties of [filter] *)
+
+Variable f:elt->bool.
+Variable Comp: compat_bool E.eq f.
+
+Let Comp' : compat_bool E.eq (fun x =>negb (f x)).
+Proof.
+unfold compat_bool in *; intros; f_equal; auto.
+Qed.
+
+Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x.
+Proof. 
+intros; apply filter_b; auto.
+Qed.
+
+Lemma for_all_filter: 
+ forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s).
+Proof. 
+intros; apply bool_1; split; intros.
+apply is_empty_1.
+unfold Empty; intros. 
+rewrite filter_iff; auto.
+red; destruct 1.
+rewrite <- (@for_all_iff s f) in H; auto.
+rewrite (H a H0) in H1; discriminate.
+apply for_all_1; auto; red; intros.
+revert H; rewrite <- is_empty_iff.
+unfold Empty; intro H; generalize (H x); clear H.
+rewrite filter_iff; auto.
+destruct (f x); auto.
+Qed.
+
+Lemma exists_filter : 
+ forall s, exists_ f s=negb (is_empty (filter f s)).
+Proof. 
+intros; apply bool_1; split; intros. 
+destruct (exists_2 Comp H) as (a,(Ha1,Ha2)).
+apply bool_6.
+red; intros; apply (@is_empty_2 _ H0 a); auto.
+generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)).
+destruct (choose (filter f s)).
+intros H0 _; apply exists_1; auto.
+exists e; generalize (H0 e); rewrite filter_iff; auto.
+intros _ H0.
+rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate.
+Qed.
+
+Lemma partition_filter_1: 
+ forall s, equal (fst (partition f s)) (filter f s)=true.
+Proof. 
+auto.
+Qed.
+
+Lemma partition_filter_2: 
+ forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
+Proof. 
+auto.
+Qed.
+
+Lemma add_filter_1 : forall s s' x, 
+ f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')).
+Proof.
+unfold Add, MP.Add; intros.
+repeat rewrite filter_iff; auto.
+rewrite H0; clear H0.
+assert (E.eq x y -> f y = true) by 
+ (intro H0; rewrite <- (Comp _ _ H0); auto).
+tauto.
+Qed.
+
+Lemma add_filter_2 : forall s s' x, 
+ f x=false -> (Add x s s') -> filter f s [=] filter f s'.
+Proof.
+unfold Add, MP.Add, Equal; intros.
+repeat rewrite filter_iff; auto.
+rewrite H0; clear H0.
+assert (f a = true -> ~E.eq x a).
+ intros H0 H1.
+ rewrite (Comp _ _ H1) in H.
+ rewrite H in H0; discriminate.
+tauto. 
+Qed.
+
+Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) ->
+  forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s.
+Proof.
+clear Comp' Comp f.
+intros.
+assert (compat_bool E.eq (fun x => orb (f x) (g x))).
+  unfold compat_bool; intros.
+  rewrite (H x y H1);  rewrite (H0 x y H1); auto.
+unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto.
+assert (f a || g a = true <-> f a = true \/ g a = true).
+  split; auto with bool.
+  intro H3; destruct (orb_prop _ _ H3); auto.
+tauto.
+Qed.
+
+Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s').
+Proof.
+unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto.
+Qed.
+
+(** Properties of [for_all] *)
+
+Lemma for_all_mem_1: forall s, 
+ (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true.
+Proof.
+intros.
+rewrite for_all_filter; auto.
+rewrite is_empty_equal_empty.
+apply equal_mem_1;intros.
+rewrite filter_b; auto.
+rewrite empty_mem.
+generalize (H a); case (mem a s);intros;auto.
+rewrite H0;auto.
+Qed.
+
+Lemma for_all_mem_2: forall s, 
+ (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. 
+Proof.
+intros.
+rewrite for_all_filter in H; auto.
+rewrite is_empty_equal_empty in H.
+generalize (equal_mem_2 _ _ H x).
+rewrite filter_b; auto.
+rewrite empty_mem.
+rewrite H0; simpl;intros.
+replace true with (negb false);auto;apply negb_sym;auto.
+Qed.
+
+Lemma for_all_mem_3: 
+ forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false.
+Proof.
+intros.
+apply (bool_eq_ind (for_all f s));intros;auto.
+rewrite for_all_filter in H1; auto.
+rewrite is_empty_equal_empty in H1.
+generalize (equal_mem_2 _ _ H1 x).
+rewrite filter_b; auto.
+rewrite empty_mem.
+rewrite H.
+rewrite H0.
+simpl;auto.
+Qed.
+
+Lemma for_all_mem_4: 
+ forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}.
+Proof.
+intros.
+rewrite for_all_filter in H; auto.
+destruct (choose_mem_3 _ H) as (x,(H0,H1));intros.
+exists x.
+rewrite filter_b in H1; auto.
+elim (andb_prop _ _ H1).
+split;auto.
+replace false with (negb true);auto;apply negb_sym;auto.
+Qed.
+
+(** Properties of [exists] *)
+
+Lemma for_all_exists: 
+ forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s).
+Proof.
+intros.
+rewrite for_all_b; auto.
+rewrite exists_b; auto.
+induction (elements s); simpl; auto.
+destruct (f a); simpl; auto.
+Qed.
+
+End Bool.
+Section Bool'.
+
+Variable f:elt->bool.
+Variable Comp: compat_bool E.eq f.
+
+Let Comp' : compat_bool E.eq (fun x =>negb (f x)).
+Proof.
+unfold compat_bool in *; intros; f_equal; auto.
+Qed.
+
+Lemma exists_mem_1: 
+ forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false.
+Proof.
+intros.
+rewrite for_all_exists; auto.
+rewrite for_all_mem_1;auto with bool.
+intros;generalize (H x H0);intros. 
+symmetry;apply negb_sym;simpl;auto.
+Qed.
+
+Lemma exists_mem_2: 
+ forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. 
+Proof.
+intros.
+rewrite for_all_exists in H; auto.
+replace false with (negb true);auto;apply negb_sym;symmetry.
+rewrite (for_all_mem_2 (fun x => negb (f x)) Comp' s);simpl;auto.
+replace true with (negb false);auto;apply negb_sym;auto.
+Qed.
+
+Lemma exists_mem_3: 
+ forall s x, mem x s=true -> f x=true -> exists_ f s=true.
+Proof.
+intros.
+rewrite for_all_exists; auto.
+symmetry;apply negb_sym;simpl.
+apply for_all_mem_3 with x;auto.
+rewrite H0;auto.
+Qed.
+
+Lemma exists_mem_4: 
+ forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}.
+Proof.
+intros.
+rewrite for_all_exists in H; auto.
+elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros.
+elim p;intros.
+exists x;split;auto.
+replace true with (negb false);auto;apply negb_sym;auto.
+replace false with (negb true);auto;apply negb_sym;auto.
+Qed.
+
+End Bool'.
+
+Section Sum.
+
+(** Adding a valuation function on all elements of a set. *)
+
+Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. 
+
+Lemma sum_plus : 
+  forall f g, compat_nat E.eq f -> compat_nat E.eq g -> 
+    forall s, sum (fun x =>f x+g x) s = sum f s + sum g s.
+Proof.
+unfold sum.
+intros f g Hf Hg.
+assert (fc : compat_op E.eq (@eq _) (fun x:elt =>plus (f x))).  auto.
+assert (ft : transpose (@eq _) (fun x:elt =>plus (f x))). red; intros; omega.
+assert (gc : compat_op E.eq (@eq _) (fun x:elt => plus (g x))). auto.
+assert (gt : transpose (@eq _) (fun x:elt =>plus (g x))). red; intros; omega.
+assert (fgc : compat_op E.eq (@eq _) (fun x:elt =>plus ((f x)+(g x)))). auto.
+assert (fgt : transpose (@eq _) (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega.
+assert (st := gen_st nat).
+intros s;pattern s; apply set_rec.
+intros.
+rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H).
+rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H).
+rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto.
+intros; do 3 (rewrite (fold_add _ _ st);auto).
+rewrite H0;simpl;omega.
+intros; do 3 rewrite (fold_empty _ _ st);auto.
+Qed.
+
+Lemma sum_filter : forall f, (compat_bool E.eq f) -> 
+  forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)).
+Proof.
+unfold sum; intros f Hf.
+assert (st := gen_st nat).
+assert (cc : compat_op E.eq (@eq _) (fun x => plus (if f x then 1 else 0))). 
+ unfold compat_op; intros.
+ rewrite (Hf x x' H); auto.
+assert (ct : transpose (@eq _) (fun x => plus (if f x then 1 else 0))).
+ unfold transpose; intros; omega.
+intros s;pattern s; apply set_rec.
+intros.
+change elt with E.t.
+rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H).
+rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto.
+intros; rewrite (fold_add _ _ st _ cc ct); auto.
+generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) .
+assert (~ In x (filter f s0)).
+ intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H.
+case (f x); simpl; intros.
+rewrite (MP.cardinal_2 H1 (H2 (refl_equal true) (MP.Add_add s0 x))); auto.
+rewrite <- (MP.Equal_cardinal (H3 (refl_equal false) (MP.Add_add s0 x))); auto.
+intros; rewrite (fold_empty _ _ st);auto.
+rewrite MP.cardinal_1; auto.
+unfold Empty; intros.
+rewrite filter_iff; auto; set_iff; tauto.
+Qed.
+
+Lemma fold_compat : 
+  forall (A:Set)(eqA:A->A->Prop)(st:(Setoid_Theory _ eqA))
+  (f g:elt->A->A),
+  (compat_op E.eq eqA f) -> (transpose eqA f) -> 
+  (compat_op E.eq eqA g) -> (transpose eqA g) -> 
+  forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> 
+  (eqA (fold f s i) (fold g s i)).
+Proof.
+intros A eqA st f g fc ft gc gt i.
+intro s; pattern s; apply set_rec; intros.
+trans_st (fold f s0 i).
+apply fold_equal with (eqA:=eqA); auto.
+rewrite equal_sym; auto.
+trans_st (fold g s0 i).
+apply H0; intros; apply H1; auto.
+elim  (equal_2 H x); auto; intros.
+apply fold_equal with (eqA:=eqA); auto.
+trans_st (f x (fold f s0 i)).
+apply fold_add with (eqA:=eqA); auto.
+trans_st (g x (fold f s0 i)).
+trans_st (g x (fold g s0 i)).
+sym_st; apply fold_add with (eqA:=eqA); auto.
+trans_st i; [idtac | sym_st ]; apply fold_empty; auto.
+Qed.
+
+Lemma sum_compat : 
+  forall f g, compat_nat E.eq f -> compat_nat E.eq g -> 
+  forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s.
+intros.
+unfold sum; apply (fold_compat _ (@eq nat)); auto.
+unfold transpose; intros; omega.
+unfold transpose; intros; omega.
+Qed.
+
+End Sum.
+
+End EqProperties. 
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
new file mode 100644
index 00000000..aa57f066
--- /dev/null
+++ b/theories/FSets/FSetFacts.v
@@ -0,0 +1,415 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
+
+(** * Finite sets library *)
+
+(** This functor derives additional facts from [FSetInterface.S]. These
+  facts are mainly the specifications of [FSetInterface.S] written using 
+  different styles: equivalence and boolean equalities. 
+  Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
+*)
+
+Require Export FSetInterface. 
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Facts (M: S).
+Module ME := OrderedTypeFacts M.E.  
+Import ME.
+Import M.
+Import Logic. (* to unmask [eq] *)  
+Import Peano. (* to unmask [lt] *)
+
+(** * Specifications written using equivalences *)
+
+Section IffSpec. 
+Variable s s' s'' : t.
+Variable x y z : elt.
+
+Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s).
+Proof.
+split; apply In_1; auto.
+Qed.
+
+Lemma mem_iff : In x s <-> mem x s = true.
+Proof.
+split; [apply mem_1|apply mem_2].
+Qed.
+
+Lemma not_mem_iff : ~In x s <-> mem x s = false.
+Proof.
+rewrite mem_iff; destruct (mem x s); intuition.
+Qed.
+
+Lemma equal_iff : s[=]s' <-> equal s s' = true.
+Proof. 
+split; [apply equal_1|apply equal_2].
+Qed.
+
+Lemma subset_iff : s[<=]s' <-> subset s s' = true.
+Proof. 
+split; [apply subset_1|apply subset_2].
+Qed.
+
+Lemma empty_iff : In x empty <-> False.
+Proof.
+intuition; apply (empty_1 H).
+Qed.
+
+Lemma is_empty_iff : Empty s <-> is_empty s = true. 
+Proof. 
+split; [apply is_empty_1|apply is_empty_2].
+Qed.
+
+Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
+Proof.
+split; [apply singleton_1|apply singleton_2].
+Qed.
+
+Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
+Proof. 
+split; [ | destruct 1; [apply add_1|apply add_2]]; auto.
+destruct (eq_dec x y) as [E|E]; auto.
+intro H; right; exact (add_3 E H).
+Qed.
+
+Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
+Proof.
+split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto.
+intro.
+apply (remove_1 H0 H).
+Qed.
+
+Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma union_iff : In x (union s s') <-> In x s \/ In x s'.
+Proof.
+split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto.
+Qed.
+
+Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'.
+Proof.
+split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto.
+Qed.
+
+Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'.
+Proof.
+split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto.
+Qed.
+
+Variable f : elt->bool.
+
+Lemma filter_iff :  compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true).
+Proof. 
+split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. 
+Qed.
+
+Lemma for_all_iff : compat_bool E.eq f ->
+  (For_all (fun x => f x = true) s <-> for_all f s = true).
+Proof.
+split; [apply for_all_1 | apply for_all_2]; auto.
+Qed.
+ 
+Lemma exists_iff : compat_bool E.eq f ->
+  (Exists (fun x => f x = true) s <-> exists_ f s = true).
+Proof.
+split; [apply exists_1 | apply exists_2]; auto.
+Qed.
+
+Lemma elements_iff : In x s <-> InA E.eq x (elements s).
+Proof. 
+split; [apply elements_1 | apply elements_2].
+Qed.
+
+End IffSpec.
+
+(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)
+  
+Ltac set_iff := 
+ repeat (progress (
+  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff 
+  || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
+  || rewrite empty_iff)).
+
+(**  * Specifications written using boolean predicates *)
+
+Section BoolSpec.
+Variable s s' s'' : t.
+Variable x y z : elt.
+
+Lemma mem_b : E.eq x y -> mem x s = mem y s.
+Proof. 
+intros.
+generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
+destruct (mem x s); destruct (mem y s); intuition.
+Qed.
+
+Lemma empty_b : mem y empty = false.
+Proof.
+generalize (empty_iff y)(mem_iff empty y).
+destruct (mem y empty); intuition.
+Qed.
+
+Lemma add_b : mem y (add x s) = eqb x y || mem y s.
+Proof.
+generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
+destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
+Proof.
+generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
+Qed.
+
+Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
+destruct (mem y s); destruct (mem y (remove x s)); intuition.
+Qed.
+
+Lemma singleton_b : mem y (singleton x) = eqb x y.
+Proof. 
+generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
+Qed.
+
+Lemma union_b : mem x (union s s') = mem x s || mem x s'.
+Proof.
+generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
+Qed.
+
+Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
+Proof.
+generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
+Qed.
+
+Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
+Proof.
+generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
+Qed.
+
+Lemma elements_b : mem x s = existsb (eqb x) (elements s).
+Proof.
+generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
+rewrite InA_alt.
+destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
+symmetry.
+rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
+exists a; intuition.
+unfold eqb; destruct (eq_dec x a); auto.
+rewrite <- H.
+rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as (a,(Ha1,Ha2)); [intuition|].
+exists a; intuition.
+unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
+Qed.
+
+Variable f : elt->bool.
+
+Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x.
+Proof. 
+intros.
+generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
+destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
+Qed.
+
+Lemma for_all_b : compat_bool E.eq f ->
+  for_all f s = forallb f (elements s).
+Proof.
+intros.
+generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
+unfold For_all.
+destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+rewrite (H2 x0) in H3.
+rewrite (InA_alt E.eq x0 (elements s)) in H3.
+destruct H3 as (a,(Ha1,Ha2)).
+rewrite (H _ _ Ha1).
+apply H0; auto.
+symmetry.
+rewrite H0; intros.
+destruct H1 as (_,H1).
+apply H1; auto.
+Qed.
+
+Lemma exists_b : compat_bool E.eq f -> 
+  exists_ f s = existsb f (elements s).
+Proof.
+intros.
+generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s).
+unfold Exists.
+destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); auto.
+exists a; auto.
+symmetry.
+rewrite H0.
+destruct H1 as (_,H1).
+destruct H1 as (a,(Ha1,Ha2)); auto.
+rewrite (H2 a) in Ha1.
+rewrite (InA_alt E.eq a (elements s)) in Ha1.
+destruct Ha1 as (b,(Hb1,Hb2)).
+exists b; auto.
+rewrite <- (H _ _ Hb1); auto.
+Qed.
+
+End BoolSpec.
+
+(** * [E.eq] and [Equal] are setoid equalities *)
+
+Definition E_ST : Setoid_Theory elt E.eq.
+Proof.
+constructor; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans].
+Qed.
+
+Add Setoid elt E.eq E_ST as EltSetoid.
+
+Definition Equal_ST : Setoid_Theory t Equal.
+Proof. 
+constructor; [apply eq_refl | apply eq_sym | apply eq_trans].
+Qed.
+
+Add Setoid t Equal Equal_ST as EqualSetoid.
+
+Add Morphism In with signature E.eq ==> Equal ==> iff as In_m.
+Proof.
+unfold Equal; intros x y H s s' H0.
+rewrite (In_eq_iff s H); auto.
+Qed.
+
+Add Morphism is_empty : is_empty_m.
+Proof.
+unfold Equal; intros s s' H.
+generalize (is_empty_iff s)(is_empty_iff s').
+destruct (is_empty s); destruct (is_empty s'); 
+ unfold Empty; auto; intros.
+symmetry.
+rewrite <- H1; intros a Ha.
+rewrite <- (H a) in Ha.
+destruct H0 as (_,H0).
+exact (H0 (refl_equal true) _ Ha).
+rewrite <- H0; intros a Ha.
+rewrite (H a) in Ha.
+destruct H1 as (_,H1).
+exact (H1 (refl_equal true) _ Ha).
+Qed.
+
+Add Morphism Empty with signature Equal ==> iff as Empty_m.
+Proof. 
+intros; do 2 rewrite is_empty_iff; rewrite H; intuition.
+Qed.
+
+Add Morphism mem : mem_m.
+Proof.
+unfold Equal; intros x y H s s' H0.
+generalize (H0 x); clear H0; rewrite (In_eq_iff s' H).
+generalize (mem_iff s x)(mem_iff s' y).
+destruct (mem x s); destruct (mem y s'); intuition.
+Qed.
+
+Add Morphism singleton : singleton_m.
+Proof.
+unfold Equal; intros x y H a.
+do 2 rewrite singleton_iff; split; order.
+Qed.
+
+Add Morphism add : add_m.
+Proof.
+unfold Equal; intros x y H s s' H0 a.
+do 2 rewrite add_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism remove : remove_m.
+Proof.
+unfold Equal; intros x y H s s' H0 a.
+do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism union : union_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite union_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism inter : inter_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism diff : diff_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism Subset with signature Equal ==> Equal ==> iff as  Subset_m.
+Proof. 
+unfold Equal, Subset; firstorder.
+Qed.
+
+Add Morphism subset : subset_m.
+Proof.
+intros s s' H s'' s''' H0.
+generalize (subset_iff s s'') (subset_iff s' s'''). 
+destruct (subset s s''); destruct (subset s' s'''); auto; intros.
+rewrite H in H1; rewrite H0 in H1; intuition.
+rewrite H in H1; rewrite H0 in H1; intuition.
+Qed.
+
+Add Morphism equal : equal_m.
+Proof.
+intros s s' H s'' s''' H0.
+generalize (equal_iff s s'') (equal_iff s' s''').
+destruct (equal s s''); destruct (equal s' s'''); auto; intros.
+rewrite H in H1; rewrite H0 in H1; intuition.
+rewrite H in H1; rewrite H0 in H1; intuition.
+Qed.
+
+(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism
+   without additional hypothesis on [f]. For instance: *)
+
+Lemma filter_equal : forall f, compat_bool E.eq f -> 
+  forall s s', s[=]s' -> filter f s [=] filter f s'.
+Proof.
+unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto.
+Qed.
+
+(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid 
+   structures on [list elt] and [option elt]. *)
+
+(* Later:
+Add Morphism cardinal ; cardinal_m.
+*)
+
+End Facts.
diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v
new file mode 100644
index 00000000..64ad234b
--- /dev/null
+++ b/theories/FSets/FSetInterface.v
@@ -0,0 +1,421 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetInterface.v 8820 2006-05-15 11:44:05Z letouzey $ *)
+
+(** * Finite set library *)
+
+(** Set interfaces *)
+
+(* begin hide *)
+Require Export Bool.
+Require Export OrderedType.
+Set Implicit Arguments.
+Unset Strict Implicit.
+(* end hide *)
+
+(** Compatibility of a  boolean function with respect to an equality. *)
+Definition compat_bool (A:Set)(eqA: A->A->Prop)(f: A-> bool) :=
+  forall x y : A, eqA x y -> f x = f y.
+
+(** Compatibility of a predicate with respect to an equality. *)
+Definition compat_P (A:Set)(eqA: A->A->Prop)(P : A -> Prop) :=
+  forall x y : A, eqA x y -> P x -> P y.
+
+Hint Unfold compat_bool compat_P.
+
+(** * Non-dependent signature
+
+    Signature [S] presents sets as purely informative programs 
+    together with axioms *)
+
+Module Type S.
+
+  Declare Module E : OrderedType.
+  Definition elt := E.t.
+
+  Parameter t : Set. (** the abstract type of sets *)
+
+  (** Logical predicates *)
+  Parameter In : elt -> t -> Prop.
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+  
+  Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
+  Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).
+
+  Parameter empty : t.
+  (** The empty set. *)
+
+  Parameter is_empty : t -> bool.
+  (** Test whether a set is empty or not. *)
+
+  Parameter mem : elt -> t -> bool.
+  (** [mem x s] tests whether [x] belongs to the set [s]. *)
+
+  Parameter add : elt -> t -> t.
+  (** [add x s] returns a set containing all elements of [s],
+  plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
+
+  Parameter singleton : elt -> t.
+  (** [singleton x] returns the one-element set containing only [x]. *)
+
+  Parameter remove : elt -> t -> t.
+  (** [remove x s] returns a set containing all elements of [s],
+  except [x]. If [x] was not in [s], [s] is returned unchanged. *)
+
+  Parameter union : t -> t -> t.
+  (** Set union. *)
+
+  Parameter inter : t -> t -> t.
+  (** Set intersection. *)
+
+  Parameter diff : t -> t -> t.
+  (** Set difference. *)
+
+  Definition eq : t -> t -> Prop := Equal.
+  Parameter lt : t -> t -> Prop.
+  Parameter compare : forall s s' : t, Compare lt eq s s'.
+  (** Total ordering between sets. Can be used as the ordering function
+  for doing sets of sets. *)
+
+  Parameter equal : t -> t -> bool.
+  (** [equal s1 s2] tests whether the sets [s1] and [s2] are
+  equal, that is, contain equal elements. *)
+
+  Parameter subset : t -> t -> bool.
+  (** [subset s1 s2] tests whether the set [s1] is a subset of
+  the set [s2]. *)
+
+  (** Coq comment: [iter] is useless in a purely functional world *)
+  (**  iter: (elt -> unit) -> set -> unit. i*)
+  (** [iter f s] applies [f] in turn to all elements of [s].
+  The order in which the elements of [s] are presented to [f]
+  is unspecified. *)
+
+  Parameter fold : forall A : Set, (elt -> A -> A) -> t -> A -> A.
+  (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
+  where [x1 ... xN] are the elements of [s], in increasing order. *)
+
+  Parameter for_all : (elt -> bool) -> t -> bool.
+  (** [for_all p s] checks if all elements of the set
+  satisfy the predicate [p]. *)
+
+  Parameter exists_ : (elt -> bool) -> t -> bool.
+  (** [exists p s] checks if at least one element of
+  the set satisfies the predicate [p]. *)
+
+  Parameter filter : (elt -> bool) -> t -> t.
+  (** [filter p s] returns the set of all elements in [s]
+  that satisfy predicate [p]. *)
+
+  Parameter partition : (elt -> bool) -> t -> t * t.
+  (** [partition p s] returns a pair of sets [(s1, s2)], where
+  [s1] is the set of all the elements of [s] that satisfy the
+  predicate [p], and [s2] is the set of all the elements of
+  [s] that do not satisfy [p]. *)
+
+  Parameter cardinal : t -> nat.
+  (** Return the number of elements of a set. *)
+  (** Coq comment: nat instead of int ... *)
+
+  Parameter elements : t -> list elt.
+  (** Return the list of all elements of the given set.
+  The returned list is sorted in increasing order with respect
+  to the ordering [Ord.compare], where [Ord] is the argument
+  given to {!Set.Make}. *)
+
+  Parameter min_elt : t -> option elt.
+  (** Return the smallest element of the given set
+  (with respect to the [Ord.compare] ordering), or raise
+  [Not_found] if the set is empty. *)
+  (** Coq comment: [Not_found] is represented by the option type *)
+
+  Parameter max_elt : t -> option elt.
+  (** Same as {!Set.S.min_elt}, but returns the largest element of the
+  given set. *)
+  (** Coq comment: [Not_found] is represented by the option type *)
+
+  Parameter choose : t -> option elt.
+  (** Return one element of the given set, or raise [Not_found] if
+  the set is empty. Which element is chosen is unspecified,
+  but equal elements will be chosen for equal sets. *)
+  (** Coq comment: [Not_found] is represented by the option type *)
+
+  Section Spec. 
+
+  Variable s s' s'' : t.
+  Variable x y : elt.
+
+  (** Specification of [In] *)
+  Parameter In_1 : E.eq x y -> In x s -> In y s.
+ 
+  (** Specification of [eq] *)
+  Parameter eq_refl : eq s s. 
+  Parameter eq_sym : eq s s' -> eq s' s.
+  Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''.
+ 
+  (** Specification of [lt] *)
+  Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''.
+  Parameter lt_not_eq : lt s s' -> ~ eq s s'.
+
+  (** Specification of [mem] *)
+  Parameter mem_1 : In x s -> mem x s = true.
+  Parameter mem_2 : mem x s = true -> In x s. 
+ 
+  (** Specification of [equal] *) 
+  Parameter equal_1 : s[=]s' -> equal s s' = true.
+  Parameter equal_2 : equal s s' = true ->s[=]s'.
+
+  (** Specification of [subset] *)
+  Parameter subset_1 : s[<=]s' -> subset s s' = true.
+  Parameter subset_2 : subset s s' = true -> s[<=]s'.
+
+  (** Specification of [empty] *)
+  Parameter empty_1 : Empty empty.
+
+  (** Specification of [is_empty] *)
+  Parameter is_empty_1 : Empty s -> is_empty s = true. 
+  Parameter is_empty_2 : is_empty s = true -> Empty s.
+ 
+  (** Specification of [add] *)
+  Parameter add_1 : E.eq x y -> In y (add x s).
+  Parameter add_2 : In y s -> In y (add x s).
+  Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+
+  (** Specification of [remove] *)
+  Parameter remove_1 : E.eq x y -> ~ In y (remove x s).
+  Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+  Parameter remove_3 : In y (remove x s) -> In y s.
+
+  (** Specification of [singleton] *)
+  Parameter singleton_1 : In y (singleton x) -> E.eq x y. 
+  Parameter singleton_2 : E.eq x y -> In y (singleton x). 
+
+  (** Specification of [union] *)
+  Parameter union_1 : In x (union s s') -> In x s \/ In x s'.
+  Parameter union_2 : In x s -> In x (union s s'). 
+  Parameter union_3 : In x s' -> In x (union s s').
+
+  (** Specification of [inter] *)
+  Parameter inter_1 : In x (inter s s') -> In x s.
+  Parameter inter_2 : In x (inter s s') -> In x s'.
+  Parameter inter_3 : In x s -> In x s' -> In x (inter s s').
+
+  (** Specification of [diff] *)
+  Parameter diff_1 : In x (diff s s') -> In x s. 
+  Parameter diff_2 : In x (diff s s') -> ~ In x s'.
+  Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+ 
+  (** Specification of [fold] *)  
+  Parameter fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+
+  (** Specification of [cardinal] *)  
+  Parameter cardinal_1 : cardinal s = length (elements s).
+
+  Section Filter.
+  
+  Variable f : elt -> bool.
+
+  (** Specification of [filter] *)
+  Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
+  Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Parameter filter_3 :
+      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+
+  (** Specification of [for_all] *)
+  Parameter for_all_1 :
+      compat_bool E.eq f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+  Parameter for_all_2 :
+      compat_bool E.eq f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+
+  (** Specification of [exists] *)
+  Parameter exists_1 :
+      compat_bool E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Parameter exists_2 :
+      compat_bool E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+
+  (** Specification of [partition] *)
+  Parameter partition_1 : compat_bool E.eq f -> 
+      fst (partition f s) [=] filter f s.
+  Parameter partition_2 : compat_bool E.eq f -> 
+      snd (partition f s) [=] filter (fun x => negb (f x)) s.
+
+  End Filter.
+
+  (** Specification of [elements] *)
+  Parameter elements_1 : In x s -> InA E.eq x (elements s).
+  Parameter elements_2 : InA E.eq x (elements s) -> In x s.
+  Parameter elements_3 : sort E.lt (elements s).  
+
+  (** Specification of [min_elt] *)
+  Parameter min_elt_1 : min_elt s = Some x -> In x s. 
+  Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. 
+  Parameter min_elt_3 : min_elt s = None -> Empty s.
+
+  (** Specification of [max_elt] *)  
+  Parameter max_elt_1 : max_elt s = Some x -> In x s. 
+  Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. 
+  Parameter max_elt_3 : max_elt s = None -> Empty s.
+
+  (** Specification of [choose] *)
+  Parameter choose_1 : choose s = Some x -> In x s.
+  Parameter choose_2 : choose s = None -> Empty s.
+(*  Parameter choose_equal: 
+      (equal s s')=true -> E.eq (choose s) (choose s'). *)
+
+  End Spec.
+
+  (* begin hide *)
+  Hint Immediate In_1.
+  
+  Hint Resolve mem_1 mem_2 equal_1 equal_2 subset_1 subset_2 empty_1
+    is_empty_1 is_empty_2 choose_1 choose_2 add_1 add_2 add_3 remove_1
+    remove_2 remove_3 singleton_1 singleton_2 union_1 union_2 union_3 inter_1
+    inter_2 inter_3 diff_1 diff_2 diff_3 filter_1 filter_2 filter_3 for_all_1
+    for_all_2 exists_1 exists_2 partition_1 partition_2 elements_1 elements_2
+    elements_3 min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3.
+  (* end hide *)
+
+End S.
+
+(** * Dependent signature 
+
+    Signature [Sdep] presents sets using dependent types *)
+
+Module Type Sdep.
+
+  Declare Module E : OrderedType.
+  Definition elt := E.t.
+
+  Parameter t : Set.
+
+  Parameter In : elt -> t -> Prop.
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
+
+  Definition eq : t -> t -> Prop := Equal.
+  Parameter lt : t -> t -> Prop.
+  Parameter compare : forall s s' : t, Compare lt eq s s'.
+
+  Parameter eq_refl : forall s : t, eq s s. 
+  Parameter eq_sym : forall s s' : t, eq s s' -> eq s' s.
+  Parameter eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+  Parameter lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''.
+  Parameter lt_not_eq : forall s s' : t, lt s s' -> ~ eq s s'.
+
+  Parameter eq_In : forall (s : t) (x y : elt), E.eq x y -> In x s -> In y s.
+
+  Parameter empty : {s : t | Empty s}.
+
+  Parameter is_empty : forall s : t, {Empty s} + {~ Empty s}.
+
+  Parameter mem : forall (x : elt) (s : t), {In x s} + {~ In x s}.
+
+  Parameter add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
+
+  Parameter
+    singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
+  
+  Parameter
+    remove :
+      forall (x : elt) (s : t),
+      {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}.
+
+  Parameter
+    union :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}.
+
+  Parameter
+    inter :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}.
+
+  Parameter
+    diff :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
+
+  Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}.
+ 
+  Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}.
+
+  Parameter
+    filter :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}.
+
+  Parameter
+    for_all :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
+  
+  Parameter
+    exists_ :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
+
+  Parameter
+    partition :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {partition : t * t |
+      let (s1, s2) := partition in
+      compat_P E.eq P ->
+      For_all P s1 /\
+      For_all (fun x => ~ P x) s2 /\
+      (forall x : elt, In x s <-> In x s1 \/ In x s2)}.
+
+  Parameter
+    elements :
+      forall s : t,
+      {l : list elt |
+      sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}.
+
+  Parameter
+    fold :
+      forall (A : Set) (f : elt -> A -> A) (s : t) (i : A),
+      {r : A | let (l,_) := elements s in 
+                  r = fold_left (fun a e => f e a) l i}.
+
+  Parameter
+    cardinal :
+      forall s : t,
+      {r : nat | let (l,_) := elements s in r = length l }.
+
+  Parameter
+    min_elt :
+      forall s : t,
+      {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}.
+
+  Parameter
+    max_elt :
+      forall s : t,
+      {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}.
+
+  Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}.
+
+End Sdep.
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
new file mode 100644
index 00000000..f6205542
--- /dev/null
+++ b/theories/FSets/FSetList.v
@@ -0,0 +1,1246 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetList.v 8834 2006-05-20 00:41:35Z letouzey $ *)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependant 
+    interface [FSetInterface.S] using strictly ordered list. *)
+
+Require Export FSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Functions over lists
+
+   First, we provide sets as lists which are not necessarily sorted.
+   The specs are proved under the additional condition of being sorted. 
+   And the functions returning sets are proved to preserve this invariant. *)
+
+Module Raw (X: OrderedType).
+ 
+  Module E := X.
+  Module MX := OrderedTypeFacts X.
+  Import MX.
+
+  Definition elt := X.t.
+  Definition t := list elt.
+
+  Definition empty : t := nil.
+
+  Definition is_empty (l : t) : bool := if l then true else false.
+
+  (** ** The set operations. *)
+
+  Fixpoint mem (x : elt) (s : t) {struct s} : bool :=
+    match s with
+    | nil => false
+    | y :: l =>
+        match X.compare x y with
+        | LT _ => false
+        | EQ _ => true
+        | GT _ => mem x l
+        end
+    end.
+
+  Fixpoint add (x : elt) (s : t) {struct s} : t :=
+    match s with
+    | nil => x :: nil
+    | y :: l =>
+        match X.compare x y with
+        | LT _ => x :: s
+        | EQ _ => s
+        | GT _ => y :: add x l
+        end
+    end.
+
+  Definition singleton (x : elt) : t := x :: nil. 
+
+  Fixpoint remove (x : elt) (s : t) {struct s} : t :=
+    match s with
+    | nil => nil
+    | y :: l =>
+        match X.compare x y with
+        | LT _ => s
+        | EQ _ => l
+        | GT _ => y :: remove x l
+        end
+    end.  
+  
+  Fixpoint union (s : t) : t -> t :=
+    match s with
+    | nil => fun s' => s'
+    | x :: l =>
+        (fix union_aux (s' : t) : t :=
+           match s' with
+           | nil => s
+           | x' :: l' =>
+               match X.compare x x' with
+               | LT _ => x :: union l s'
+               | EQ _ => x :: union l l'
+               | GT _ => x' :: union_aux l'
+               end
+           end)
+    end.      
+
+  Fixpoint inter (s : t) : t -> t :=
+    match s with
+    | nil => fun _ => nil
+    | x :: l =>
+        (fix inter_aux (s' : t) : t :=
+           match s' with
+           | nil => nil
+           | x' :: l' =>
+               match X.compare x x' with
+               | LT _ => inter l s'
+               | EQ _ => x :: inter l l'
+               | GT _ => inter_aux l'
+               end
+           end)
+    end.  
+  
+  Fixpoint diff (s : t) : t -> t :=
+    match s with
+    | nil => fun _ => nil
+    | x :: l =>
+        (fix diff_aux (s' : t) : t :=
+           match s' with
+           | nil => s
+           | x' :: l' =>
+               match X.compare x x' with
+               | LT _ => x :: diff l s'
+               | EQ _ => diff l l'
+               | GT _ => diff_aux l'
+               end
+           end)
+    end.  
+   
+  Fixpoint equal (s : t) : t -> bool :=
+    fun s' : t =>
+    match s, s' with
+    | nil, nil => true
+    | x :: l, x' :: l' =>
+        match X.compare x x' with
+        | EQ _ => equal l l'
+        | _ => false
+        end
+    | _, _ => false
+    end.
+
+  Fixpoint subset (s s' : t) {struct s'} : bool :=
+    match s, s' with
+    | nil, _ => true
+    | x :: l, x' :: l' =>
+        match X.compare x x' with
+        | LT _ => false
+        | EQ _ => subset l l'
+        | GT _ => subset s l'
+        end
+    | _, _ => false
+    end.
+
+  Fixpoint fold (B : Set) (f : elt -> B -> B) (s : t) {struct s} : 
+   B -> B := fun i => match s with
+                      | nil => i
+                      | x :: l => fold f l (f x i)
+                      end.  
+
+  Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t :=
+    match s with
+    | nil => nil
+    | x :: l => if f x then x :: filter f l else filter f l
+    end.  
+
+  Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool :=
+    match s with
+    | nil => true
+    | x :: l => if f x then for_all f l else false
+    end.  
+ 
+  Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool :=
+    match s with
+    | nil => false
+    | x :: l => if f x then true else exists_ f l
+    end.
+
+  Fixpoint partition (f : elt -> bool) (s : t) {struct s} : 
+   t * t :=
+    match s with
+    | nil => (nil, nil)
+    | x :: l =>
+        let (s1, s2) := partition f l in
+        if f x then (x :: s1, s2) else (s1, x :: s2)
+    end.
+
+  Definition cardinal (s : t) : nat := length s.
+
+  Definition elements (x : t) : list elt := x.
+
+  Definition min_elt (s : t) : option elt :=
+    match s with
+    | nil => None
+    | x :: _ => Some x
+    end.
+
+  Fixpoint max_elt (s : t) : option elt :=
+    match s with
+    | nil => None
+    | x :: nil => Some x
+    | _ :: l => max_elt l
+    end.
+
+  Definition choose := min_elt.
+
+  (** ** Proofs of set operation specifications. *)
+
+  Section ForNotations.
+
+  Notation Sort := (sort X.lt).
+  Notation Inf := (lelistA X.lt).
+  Notation In := (InA X.eq).
+
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x.
+
+  Lemma mem_1 :
+   forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true. 
+  Proof.
+  simple induction s; intros.
+  inversion H.
+  inversion_clear Hs.
+  inversion_clear H0.
+  simpl; elim_comp; trivial.
+  simpl; elim_comp_gt x a; auto.
+  apply Sort_Inf_In with l; trivial.
+  Qed.
+
+  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
+  Proof.
+  simple induction s.
+  intros; inversion H.
+  intros a l Hrec x.
+  simpl.
+  case (X.compare x a); intros; try discriminate; auto.
+  Qed.
+
+  Lemma add_Inf :
+   forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s).
+  Proof.
+  simple induction s.  
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion H0;
+   intuition.
+  Qed.
+  Hint Resolve add_Inf.
+  
+  Lemma add_sort : forall (s : t) (Hs : Sort s) (x : elt), Sort (add x s).
+  Proof.
+  simple induction s.
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs;
+   auto.
+  Qed. 
+
+  Lemma add_1 :
+   forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> In y (add x s).
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); inversion_clear Hs; auto.
+  constructor; apply X.eq_trans with x; auto.
+  Qed.
+
+  Lemma add_2 :
+   forall (s : t) (Hs : Sort s) (x y : elt), In y s -> In y (add x s).
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition.
+  inversion_clear Hs; inversion_clear H0; auto.
+  Qed.
+
+  Lemma add_3 :
+   forall (s : t) (Hs : Sort s) (x y : elt),
+   ~ X.eq x y -> In y (add x s) -> In y s.
+  Proof.
+  simple induction s. 
+  simpl; inversion_clear 3; auto; order.
+  simpl; intros a l Hrec Hs x y; case (X.compare x a); intros;
+   inversion_clear H0; inversion_clear Hs; auto.
+  order.
+  constructor 2; apply Hrec with x; auto.
+  Qed.
+
+  Lemma remove_Inf :
+   forall (s : t) (Hs : Sort s) (x a : elt), Inf a s -> Inf a (remove x s).
+  Proof.
+  simple induction s.  
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear H0; auto.
+  inversion_clear Hs; apply Inf_lt with a; auto.
+  Qed.
+  Hint Resolve remove_Inf.
+
+  Lemma remove_sort :
+   forall (s : t) (Hs : Sort s) (x : elt), Sort (remove x s).
+  Proof.
+  simple induction s.
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; auto.
+  Qed. 
+
+  Lemma remove_1 :
+   forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> ~ In y (remove x s).
+  Proof.
+  simple induction s. 
+  simpl; red; intros; inversion H0.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs. 
+  inversion_clear H1.
+  order.
+  generalize (Sort_Inf_In H2 H3 H4); order.
+  generalize (Sort_Inf_In H2 H3 H1); order.
+  inversion_clear H1.
+  order.
+  apply (H H2 _ _ H0 H4).
+  Qed.
+
+  Lemma remove_2 :
+   forall (s : t) (Hs : Sort s) (x y : elt),
+   ~ X.eq x y -> In y s -> In y (remove x s).
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs;
+   inversion_clear H1; auto. 
+  destruct H0; apply X.eq_trans with a; auto.
+  Qed.
+
+  Lemma remove_3 :
+   forall (s : t) (Hs : Sort s) (x y : elt), In y (remove x s) -> In y s.
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros a l Hrec Hs x y; case (X.compare x a); intuition.
+  inversion_clear Hs; inversion_clear H; auto.
+  constructor 2; apply Hrec with x; auto.
+  Qed.
+  
+  Lemma singleton_sort : forall x : elt, Sort (singleton x).
+  Proof.
+  unfold singleton; simpl; auto.
+  Qed.
+
+  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y.
+  Proof.
+  unfold singleton; simpl; intuition.
+  inversion_clear H; auto; inversion H0.
+  Qed. 
+
+  Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x).
+  Proof.
+  unfold singleton; simpl; auto.
+  Qed. 
+
+  Ltac DoubleInd :=
+    simple induction s;
+     [ simpl; auto; try solve [ intros; inversion H ]
+     | intros x l Hrec; simple induction s';
+        [ simpl; auto; try solve [ intros; inversion H ]
+        | intros x' l' Hrec' Hs Hs'; inversion Hs; inversion Hs'; subst;
+           simpl ] ].
+
+  Lemma union_Inf :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
+   Inf a s -> Inf a s' -> Inf a (union s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; inversion_clear His; inversion_clear His'.
+  case (X.compare x x'); auto.
+  Qed.
+  Hint Resolve union_Inf.
+ 
+  Lemma union_sort :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (union s s').
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition; constructor; auto.
+  apply Inf_eq with x'; trivial; apply union_Inf; trivial; apply Inf_eq with x; auto.
+  change (Inf x' (union (x :: l) l')); auto.
+  Qed.  
+  
+  Lemma union_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (union s s') -> In x s \/ In x s'.
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition; inversion_clear H; intuition.
+  elim (Hrec (x' :: l') H1 Hs' x0); intuition.
+  elim (Hrec l' H1 H5 x0); intuition.
+  elim (H0 x0); intuition.
+  Qed.
+
+  Lemma union_2 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x s -> In x (union s s').
+  Proof.
+  DoubleInd. 
+  intros i Hi; case (X.compare x x'); intuition; inversion_clear Hi; auto.
+  Qed.
+
+  Lemma union_3 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x s' -> In x (union s s').
+  Proof.
+  DoubleInd. 
+  intros i Hi; case (X.compare x x'); inversion_clear Hi; intuition.
+  constructor; apply X.eq_trans with x'; auto.  
+  Qed.
+    
+  Lemma inter_Inf :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
+   Inf a s -> Inf a s' -> Inf a (inter s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; inversion His; inversion His'; subst.
+  case (X.compare x x'); intuition. 
+  apply Inf_lt with x; auto.
+  apply H3; auto.
+  apply Inf_lt with x'; auto.
+  Qed.
+  Hint Resolve inter_Inf. 
+
+  Lemma inter_sort :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (inter s s').
+  Proof.
+  DoubleInd; case (X.compare x x'); auto.
+  constructor; auto.
+  apply Inf_eq with x'; trivial; apply inter_Inf; trivial; apply Inf_eq with x; auto.
+  Qed.  
+  
+  Lemma inter_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (inter s s') -> In x s.
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition.
+  constructor 2; apply Hrec with (x'::l'); auto.
+  inversion_clear H; auto.
+  constructor 2; apply Hrec with l'; auto.
+  Qed.
+
+  Lemma inter_2 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (inter s s') -> In x s'.
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition; inversion_clear H.
+  constructor 1; apply X.eq_trans with x; auto.
+  constructor 2; auto.
+  Qed.
+
+  Lemma inter_3 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x s -> In x s' -> In x (inter s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; elim (X.compare x x'); intuition.
+
+  inversion_clear His; auto.
+  generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) His'); order.
+
+  inversion_clear His; auto; inversion_clear His'; auto.
+  constructor; apply X.eq_trans with x'; auto.
+
+  change (In i (inter (x :: l) l')). 
+  inversion_clear His'; auto.
+  generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) His); order.
+  Qed.
+
+  Lemma diff_Inf :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
+   Inf a s -> Inf a s' -> Inf a (diff s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; inversion His; inversion His'.
+  case (X.compare x x'); intuition.
+  apply Hrec; trivial.
+  apply Inf_lt with x; auto.
+  apply Inf_lt with x'; auto.
+  apply H10; trivial.
+  apply Inf_lt with x'; auto.
+  Qed.
+  Hint Resolve diff_Inf. 
+
+  Lemma diff_sort :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (diff s s').
+  Proof.
+  DoubleInd; case (X.compare x x'); auto.
+  Qed.  
+  
+  Lemma diff_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (diff s s') -> In x s.
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition.
+  inversion_clear H; auto.
+  constructor 2; apply Hrec with (x'::l'); auto.
+  constructor 2; apply Hrec with l'; auto.
+  Qed.
+
+  Lemma diff_2 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (diff s s') -> ~ In x s'.
+  Proof.
+  DoubleInd.
+  intros; intro Abs; inversion Abs. 
+  case (X.compare x x'); intuition.
+
+  inversion_clear H.
+  generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) H3); order.
+  apply Hrec with (x'::l') x0; auto.
+  
+  inversion_clear H3.
+  generalize (Sort_Inf_In H1 H2 (diff_1 H1 H5 H)); order.
+  apply Hrec with l' x0; auto.
+  
+  inversion_clear H3. 
+  generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) (diff_1 Hs H5 H)); order.
+  apply H0 with x0; auto.
+  Qed.
+
+  Lemma diff_3 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x s -> ~ In x s' -> In x (diff s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; elim (X.compare x x'); intuition; inversion_clear His; auto.
+  elim His'; constructor; apply X.eq_trans with x; auto.
+  Qed.  
+
+  Lemma equal_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'),
+   Equal s s' -> equal s s' = true.
+  Proof.
+  simple induction s; unfold Equal.
+  intro s'; case s'; auto.
+  simpl; intuition.
+  elim (H e); intros; assert (A : In e nil); auto; inversion A.
+  intros x l Hrec s'.
+  case s'.
+  intros; elim (H x); intros; assert (A : In x nil); auto; inversion A.
+  intros x' l' Hs Hs'; inversion Hs; inversion Hs'; subst.
+  simpl; case (X.compare x); intros; auto.
+
+  elim (H x); intros.
+  assert (A : In x (x' :: l')); auto; inversion_clear A.
+  order.
+  generalize (Sort_Inf_In H5 H6 H4); order.
+  
+  apply Hrec; intuition; elim (H a); intros.
+  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
+  generalize (Sort_Inf_In H1 H2 H0); order.
+  assert (A : In a (x :: l)); auto; inversion_clear A; auto.
+  generalize (Sort_Inf_In H5 H6 H0); order.
+
+  elim (H x'); intros.
+  assert (A : In x' (x :: l)); auto; inversion_clear A.
+  order.
+  generalize (Sort_Inf_In H1 H2 H4); order.
+  Qed.
+
+  Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
+  Proof.
+  simple induction s; unfold Equal.
+  intro s'; case s'; intros.
+  intuition.
+  simpl in H; discriminate H.
+  intros x l Hrec s'.
+  case s'.
+  intros; simpl in H; discriminate.
+  intros x' l'; simpl; case (X.compare x); intros; auto; try discriminate.
+  elim (Hrec l' H a); intuition; inversion_clear H2; auto.
+  constructor; apply X.eq_trans with x; auto.
+  constructor; apply X.eq_trans with x'; auto.
+  Qed.  
+  
+  Lemma subset_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'),
+   Subset s s' -> subset s s' = true.
+  Proof.
+  intros s s'; generalize s' s; clear s s'.
+  simple induction s'; unfold Subset.
+  intro s; case s; auto.
+  intros; elim (H e); intros; assert (A : In e nil); auto; inversion A. 
+  intros x' l' Hrec s; case s.
+  simpl; auto.
+  intros x l Hs Hs'; inversion Hs; inversion Hs'; subst.
+  simpl; case (X.compare x); intros; auto.
+
+  assert (A : In x (x' :: l')); auto; inversion_clear A.
+  order.
+  generalize (Sort_Inf_In H5 H6 H0); order.
+  
+  apply Hrec; intuition.
+  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
+  generalize (Sort_Inf_In H1 H2 H0); order.
+
+  apply Hrec; intuition.
+  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
+  inversion_clear H0. 
+  order.
+  generalize (Sort_Inf_In H1 H2 H4); order.
+  Qed.
+
+  Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
+  Proof.
+  intros s s'; generalize s' s; clear s s'.
+  simple induction s'; unfold Subset.
+  intro s; case s; auto.
+  simpl; intros; discriminate H.
+  intros x' l' Hrec s; case s.
+  intros; inversion H0.
+  intros x l; simpl; case (X.compare x); intros; auto.
+  discriminate H.  
+  inversion_clear H0.
+  constructor; apply X.eq_trans with x; auto.
+  constructor 2; apply Hrec with l; auto.
+  constructor 2; apply Hrec with (x::l); auto.
+  Qed.  
+  
+  Lemma empty_sort : Sort empty.
+  Proof.
+  unfold empty; constructor.
+  Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  unfold Empty, empty; intuition; inversion H.
+  Qed. 
+
+  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition.
+  elim (H e); auto.
+  Qed.
+  
+  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. 
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition;
+   inversion H0.
+  Qed.
+
+  Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s).
+  Proof.
+  unfold elements; auto.
+  Qed.
+
+  Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s.
+  Proof. 
+  unfold elements; auto.
+  Qed.
+ 
+  Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (elements s).  
+  Proof. 
+  unfold elements; auto.
+  Qed.
+
+  Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. 
+  Proof.
+  intro s; case s; simpl; intros; inversion H; auto.
+  Qed.  
+
+  Lemma min_elt_2 :
+   forall (s : t) (Hs : Sort s) (x y : elt),
+   min_elt s = Some x -> In y s -> ~ X.lt y x. 
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H.
+  intros a l; case l; intros; inversion H0; inversion_clear H1; subst. 
+  order.
+  inversion H2.
+  order.
+  inversion_clear Hs.
+  inversion_clear H3.
+  generalize (H H1 e y (refl_equal (Some e)) H2); order.
+  Qed. 
+
+  Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition;
+   inversion H; inversion H0.
+  Qed.
+
+  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. 
+  Proof. 
+  simple induction s; simpl.
+  intros; inversion H.
+  intros x l; case l; simpl.
+  intuition.
+  inversion H0; auto.
+  intros.
+  constructor 2; apply (H _ H0).
+  Qed.
+ 
+  Lemma max_elt_2 :
+   forall (s : t) (Hs : Sort s) (x y : elt),
+   max_elt s = Some x -> In y s -> ~ X.lt x y. 
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H.
+  intros x l; case l; simpl.
+  intuition.
+  inversion H0; subst.
+  inversion_clear H1.
+  order.
+  inversion H3.
+  intros; inversion_clear Hs; inversion_clear H3; inversion_clear H1.
+  assert (In e (e::l0)) by auto.
+  generalize (H H2 x0 e H0 H1); order.
+  generalize (H H2 x0 y H0 H3); order.
+  Qed. 
+
+  Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
+  Proof.
+  unfold Empty; simple induction s; simpl.
+  red; intros; inversion H0.
+  intros x l; case l; simpl; intros.
+  inversion H0.
+  elim (H H0 e); auto.
+  Qed.
+
+  Definition choose_1 :
+    forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_1.
+
+  Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3.
+
+  Lemma fold_1 :
+   forall (s : t) (Hs : Sort s) (A : Set) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof.
+  induction s.
+  simpl; trivial.
+  intros.
+  inversion_clear Hs.
+  simpl; auto.
+  Qed.
+
+  Lemma cardinal_1 :
+   forall (s : t) (Hs : Sort s),
+   cardinal s = length (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma filter_Inf :
+   forall (s : t) (Hs : Sort s) (x : elt) (f : elt -> bool),
+   Inf x s -> Inf x (filter f s).
+  Proof.
+  simple induction s; simpl.
+  intuition.  
+  intros x l Hrec Hs a f Ha; inversion_clear Hs; inversion_clear Ha.
+  case (f x). 
+  constructor; auto.
+  apply Hrec; auto.
+  apply Inf_lt with x; auto.
+  Qed.
+
+  Lemma filter_sort :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (filter f s).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  case (f x); auto.
+  constructor; auto.
+  apply filter_Inf; auto. 
+  Qed.
+
+  Lemma filter_1 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool X.eq f -> In x (filter f s) -> In x s.
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  case (f x); simpl.
+  inversion_clear 1.
+  constructor; auto.
+  constructor 2; apply (Hrec a f Hf); trivial.
+  constructor 2; apply (Hrec a f Hf); trivial.
+  Qed.
+
+   Lemma filter_2 :
+    forall (s : t) (x : elt) (f : elt -> bool),
+    compat_bool X.eq f -> In x (filter f s) -> f x = true.   
+   Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  generalize (Hf x); case (f x); simpl; auto.
+  inversion_clear 2; auto.
+  symmetry; auto.
+  Qed.
+ 
+  Lemma filter_3 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s).     
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  generalize (Hf x); case (f x); simpl.
+  inversion_clear 2; auto.
+  inversion_clear 2; auto.
+  rewrite <- (H a (X.eq_sym H1)); intros; discriminate.
+  Qed.
+
+  Lemma for_all_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. 
+  simple induction s; simpl; auto; unfold For_all.
+  intros x l Hrec f Hf. 
+  generalize (Hf x); case (f x); simpl.
+  auto.
+  intros; rewrite (H x); auto.
+  Qed.
+
+  Lemma for_all_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. 
+  simple induction s; simpl; auto; unfold For_all.
+  intros; inversion H1.
+  intros x l Hrec f Hf. 
+  intros A a; intros. 
+  assert (f x = true).
+   generalize A; case (f x); auto.
+  rewrite H0 in A; simpl in A.
+  inversion_clear H; auto.
+  rewrite (Hf a x); auto.
+  Qed.
+
+  Lemma exists_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof.
+  simple induction s; simpl; auto; unfold Exists.
+  intros.
+  elim H0; intuition. 
+  inversion H2.
+  intros x l Hrec f Hf. 
+  generalize (Hf x); case (f x); simpl.
+  auto.
+  destruct 2 as [a (A1,A2)].
+  inversion_clear A1.
+  rewrite <- (H a (X.eq_sym H0)) in A2; discriminate.
+  apply Hrec; auto.
+  exists a; auto.
+  Qed.
+
+  Lemma exists_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. 
+  simple induction s; simpl; auto; unfold Exists.
+  intros; discriminate.
+  intros x l Hrec f Hf.
+  case_eq (f x); intros.
+  exists x; auto.
+  destruct (Hrec f Hf H0) as [a (A1,A2)].
+  exists a; auto.
+  Qed.
+
+  Lemma partition_Inf_1 :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt),
+   Inf x s -> Inf x (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  intuition.  
+  intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha.
+  generalize (Hrec H f a).
+  case (f x); case (partition f l); simpl.
+  auto.
+  intros; apply H2; apply Inf_lt with x; auto.
+  Qed.
+
+  Lemma partition_Inf_2 :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt),
+   Inf x s -> Inf x (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  intuition.  
+  intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha.
+  generalize (Hrec H f a).
+  case (f x); case (partition f l); simpl.
+  intros; apply H2; apply Inf_lt with x; auto.
+  auto.
+  Qed.
+
+  Lemma partition_sort_1 :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  generalize (Hrec H f); generalize (partition_Inf_1 H f).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+  
+  Lemma partition_sort_2 :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  generalize (Hrec H f); generalize (partition_Inf_2 H f).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+
+  Lemma partition_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  split; auto.
+  intros x l Hrec f Hf.
+  generalize (Hrec f Hf); clear Hrec.
+  destruct (partition f l) as [s1 s2]; simpl; intros.
+  case (f x); simpl; auto.
+  split; inversion_clear 1; auto.
+  constructor 2; rewrite <- H; auto.
+  constructor 2; rewrite H; auto.
+  Qed.
+   
+  Lemma partition_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  split; auto.
+  intros x l Hrec f Hf. 
+  generalize (Hrec f Hf); clear Hrec.
+  destruct (partition f l) as [s1 s2]; simpl; intros.
+  case (f x); simpl; auto.
+  split; inversion_clear 1; auto.
+  constructor 2; rewrite <- H; auto.
+  constructor 2; rewrite H; auto.
+  Qed.
+ 
+  Definition eq : t -> t -> Prop := Equal.
+
+  Lemma eq_refl : forall s : t, eq s s. 
+  Proof. 
+  unfold eq, Equal; intuition.
+  Qed.
+
+  Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s.
+  Proof. 
+  unfold eq, Equal; intros; destruct (H a); intuition.
+  Qed.
+
+  Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+  Proof. 
+  unfold eq, Equal; intros; destruct (H a); destruct (H0 a); intuition.
+  Qed.
+
+  Inductive lt : t -> t -> Prop :=
+    | lt_nil : forall (x : elt) (s : t), lt nil (x :: s)
+    | lt_cons_lt :
+        forall (x y : elt) (s s' : t), X.lt x y -> lt (x :: s) (y :: s')
+    | lt_cons_eq :
+        forall (x y : elt) (s s' : t),
+        X.eq x y -> lt s s' -> lt (x :: s) (y :: s').
+  Hint Constructors lt.
+   
+  Lemma lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''.
+  Proof. 
+  intros s s' s'' H; generalize s''; clear s''; elim H.
+  intros x l s'' H'; inversion_clear H'; auto.
+  intros x x' l l' E s'' H'; inversion_clear H'; auto. 
+  constructor; apply X.lt_trans with x'; auto.
+  constructor; apply lt_eq with x'; auto.
+  intros.
+  inversion_clear H3.
+  constructor; apply eq_lt with y; auto.
+  constructor 3; auto; apply X.eq_trans with y; auto.  
+  Qed. 
+
+  Lemma lt_not_eq :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), lt s s' -> ~ eq s s'.
+  Proof. 
+  unfold eq, Equal. 
+  intros s s' Hs Hs' H; generalize Hs Hs'; clear Hs Hs'; elim H; intros; intro.
+  elim (H0 x); intros.
+  assert (X : In x nil); auto; inversion X.
+  inversion_clear Hs; inversion_clear Hs'.
+  elim (H1 x); intros. 
+  assert (X : In x (y :: s'0)); auto; inversion_clear X.
+  order.
+  generalize (Sort_Inf_In H4 H5 H8); order.
+  inversion_clear Hs; inversion_clear Hs'.
+  elim H2; auto; split; intros.
+  generalize (Sort_Inf_In H4 H5 H8); intros.
+  elim (H3 a); intros.
+  assert (X : In a (y :: s'0)); auto; inversion_clear X; auto.
+  order.
+  generalize (Sort_Inf_In H6 H7 H8); intros.
+  elim (H3 a); intros.
+  assert (X : In a (x :: s0)); auto; inversion_clear X; auto.
+  order.
+  Qed.
+
+  Definition compare :
+    forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Compare lt eq s s'.
+  Proof.
+  simple induction s.
+  intros; case s'. 
+  constructor 2; apply eq_refl. 
+  constructor 1; auto.
+  intros a l Hrec s'; case s'.
+  constructor 3; auto.
+  intros a' l' Hs Hs'.
+  case (X.compare a a'); [ constructor 1 | idtac | constructor 3 ]; auto.
+  elim (Hrec l');
+   [ constructor 1
+   | constructor 2
+   | constructor 3
+   | inversion Hs
+   | inversion Hs' ]; auto.
+  generalize e; unfold eq, Equal; intuition; inversion_clear H.
+  constructor; apply X.eq_trans with a; auto.
+  destruct (e1 a0); auto.
+  constructor; apply X.eq_trans with a'; auto.
+  destruct (e1 a0); auto.
+  Defined.
+
+  End ForNotations. 
+  Hint Constructors lt.
+
+End Raw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we 
+   need to encapsulate everything into a type of strictly ordered lists. *)
+
+Module Make (X: OrderedType) <: S with Module E := X.
+
+ Module Raw := Raw X. 
+ Module E := X.
+
+ Record slist : Set :=  {this :> Raw.t; sorted : sort E.lt this}.
+ Definition t := slist. 
+ Definition elt := E.t.
+ 
+ Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this).
+ Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
+ Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
+ Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop)(s:t) : Prop := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop)(s:t) : Prop := exists x, In x s /\ P x.
+
+ Definition mem (x : elt) (s : t) : bool := Raw.mem x s.
+ Definition add (x : elt)(s : t) : t := Build_slist (Raw.add_sort (sorted s) x).
+ Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_sort (sorted s) x).
+ Definition singleton (x : elt) : t  := Build_slist (Raw.singleton_sort x).
+ Definition union (s s' : t) : t :=
+   Build_slist (Raw.union_sort (sorted s) (sorted s')). 
+ Definition inter (s s' : t) : t :=
+   Build_slist (Raw.inter_sort (sorted s) (sorted s')). 
+ Definition diff (s s' : t) : t :=
+   Build_slist (Raw.diff_sort (sorted s) (sorted s')). 
+ Definition equal (s s' : t) : bool := Raw.equal s s'. 
+ Definition subset (s s' : t) : bool := Raw.subset s s'.
+ Definition empty : t := Build_slist Raw.empty_sort.
+ Definition is_empty (s : t) : bool := Raw.is_empty s.
+ Definition elements (s : t) : list elt := Raw.elements s.
+ Definition min_elt (s : t) : option elt := Raw.min_elt s.
+ Definition max_elt (s : t) : option elt := Raw.max_elt s.
+ Definition choose (s : t) : option elt  := Raw.choose s.
+ Definition fold (B : Set) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. 
+ Definition cardinal (s : t) : nat := Raw.cardinal s.
+ Definition filter (f : elt -> bool) (s : t) : t :=
+   Build_slist (Raw.filter_sort (sorted s) f).
+ Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s.
+ Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s.
+ Definition partition (f : elt -> bool) (s : t) : t * t :=
+   let p := Raw.partition f s in
+   (Build_slist (this:=fst p) (Raw.partition_sort_1 (sorted s) f),
+   Build_slist (this:=snd p) (Raw.partition_sort_2 (sorted s) f)).
+ Definition eq (s s' : t) : Prop := Raw.eq s s'.
+ Definition lt (s s' : t) : Prop := Raw.lt s s'.
+
+ Section Spec. 
+  Variable s s' s'': t.
+  Variable x y : elt.
+
+  Lemma In_1 : E.eq x y -> In x s -> In y s. 
+  Proof. exact (fun H H' => Raw.MX.In_eq H H'). Qed.
+ 
+  Lemma mem_1 : In x s -> mem x s = true.
+  Proof. exact (fun H => Raw.mem_1 s.(sorted) H). Qed.
+  Lemma mem_2 : mem x s = true -> In x s. 
+  Proof. exact (fun H => Raw.mem_2 H). Qed.
+ 
+  Lemma equal_1 : Equal s s' -> equal s s' = true.
+  Proof. exact (Raw.equal_1 s.(sorted) s'.(sorted)). Qed.
+  Lemma equal_2 : equal s s' = true -> Equal s s'.
+  Proof. exact (fun H => Raw.equal_2 H). Qed.
+
+  Lemma subset_1 : Subset s s' -> subset s s' = true.
+  Proof. exact (Raw.subset_1 s.(sorted) s'.(sorted)). Qed.
+  Lemma subset_2 : subset s s' = true -> Subset s s'.
+  Proof. exact (fun H => Raw.subset_2 H). Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof. exact Raw.empty_1. Qed.
+
+  Lemma is_empty_1 : Empty s -> is_empty s = true. 
+  Proof. exact (fun H => Raw.is_empty_1 H). Qed.
+  Lemma is_empty_2 : is_empty s = true -> Empty s.
+  Proof. exact (fun H => Raw.is_empty_2 H). Qed.
+ 
+  Lemma add_1 : E.eq x y -> In y (add x s).
+  Proof. exact (fun H => Raw.add_1 s.(sorted) H). Qed.
+  Lemma add_2 : In y s -> In y (add x s).
+  Proof. exact (fun H => Raw.add_2 s.(sorted) x H). Qed.
+  Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+  Proof. exact (fun H => Raw.add_3 s.(sorted) H). Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+  Proof. exact (fun H => Raw.remove_1 s.(sorted) H). Qed.
+  Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+  Proof. exact (fun H H' => Raw.remove_2 s.(sorted) H H'). Qed.
+  Lemma remove_3 : In y (remove x s) -> In y s.
+  Proof. exact (fun H => Raw.remove_3 s.(sorted) H). Qed.
+
+  Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
+  Proof. exact (fun H => Raw.singleton_1 H). Qed.
+  Lemma singleton_2 : E.eq x y -> In y (singleton x). 
+  Proof. exact (fun H => Raw.singleton_2 H). Qed.
+
+  Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+  Proof. exact (fun H => Raw.union_1 s.(sorted) s'.(sorted) H). Qed.
+  Lemma union_2 : In x s -> In x (union s s'). 
+  Proof. exact (fun H => Raw.union_2 s.(sorted) s'.(sorted) H). Qed.
+  Lemma union_3 : In x s' -> In x (union s s').
+  Proof. exact (fun H => Raw.union_3 s.(sorted) s'.(sorted) H). Qed.
+
+  Lemma inter_1 : In x (inter s s') -> In x s.
+  Proof. exact (fun H => Raw.inter_1 s.(sorted) s'.(sorted) H). Qed.
+  Lemma inter_2 : In x (inter s s') -> In x s'.
+  Proof. exact (fun H => Raw.inter_2 s.(sorted) s'.(sorted) H). Qed.
+  Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+  Proof. exact (fun H => Raw.inter_3 s.(sorted) s'.(sorted) H). Qed.
+
+  Lemma diff_1 : In x (diff s s') -> In x s. 
+  Proof. exact (fun H => Raw.diff_1 s.(sorted) s'.(sorted) H). Qed.
+  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+  Proof. exact (fun H => Raw.diff_2 s.(sorted) s'.(sorted) H). Qed.
+  Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+  Proof. exact (fun H => Raw.diff_3 s.(sorted) s'.(sorted) H). Qed.
+ 
+  Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof. exact (Raw.fold_1 s.(sorted)). Qed.
+
+  Lemma cardinal_1 : cardinal s = length (elements s).
+  Proof. exact (Raw.cardinal_1 s.(sorted)). Qed.
+
+  Section Filter.
+  
+  Variable f : elt -> bool.
+
+  Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
+  Proof. exact (@Raw.filter_1 s x f). Qed.
+  Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Proof. exact (@Raw.filter_2 s x f). Qed.
+  Lemma filter_3 :
+      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+  Proof. exact (@Raw.filter_3 s x f). Qed.
+
+  Lemma for_all_1 :
+      compat_bool E.eq f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. exact (@Raw.for_all_1 s f). Qed.
+  Lemma for_all_2 :
+      compat_bool E.eq f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. exact (@Raw.for_all_2 s f). Qed.
+
+  Lemma exists_1 :
+      compat_bool E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof. exact (@Raw.exists_1 s f). Qed.
+  Lemma exists_2 :
+      compat_bool E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. exact (@Raw.exists_2 s f). Qed.
+
+  Lemma partition_1 :
+      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof. exact (@Raw.partition_1 s f). Qed.
+  Lemma partition_2 :
+      compat_bool E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. exact (@Raw.partition_2 s f). Qed.
+
+  End Filter.
+
+  Lemma elements_1 : In x s -> InA E.eq x (elements s).
+  Proof. exact (fun H => Raw.elements_1 H). Qed.
+  Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+  Proof. exact (fun H => Raw.elements_2 H). Qed.
+  Lemma elements_3 : sort E.lt (elements s).
+  Proof. exact (Raw.elements_3 s.(sorted)). Qed.
+
+  Lemma min_elt_1 : min_elt s = Some x -> In x s. 
+  Proof. exact (fun H => Raw.min_elt_1 H). Qed.
+  Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. 
+  Proof. exact (fun H => Raw.min_elt_2 s.(sorted) H). Qed.
+  Lemma min_elt_3 : min_elt s = None -> Empty s.
+  Proof. exact (fun H => Raw.min_elt_3 H). Qed.
+
+  Lemma max_elt_1 : max_elt s = Some x -> In x s. 
+  Proof. exact (fun H => Raw.max_elt_1 H). Qed.
+  Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. 
+  Proof. exact (fun H => Raw.max_elt_2 s.(sorted) H). Qed.
+  Lemma max_elt_3 : max_elt s = None -> Empty s.
+  Proof. exact (fun H => Raw.max_elt_3 H). Qed.
+
+  Lemma choose_1 : choose s = Some x -> In x s.
+  Proof. exact (fun H => Raw.choose_1 H). Qed.
+  Lemma choose_2 : choose s = None -> Empty s.
+  Proof. exact (fun H => Raw.choose_2 H). Qed.
+
+  Lemma eq_refl : eq s s.
+  Proof. exact (Raw.eq_refl s). Qed.
+  Lemma eq_sym : eq s s' -> eq s' s.
+  Proof. exact (@Raw.eq_sym s s'). Qed.
+  Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''.
+  Proof. exact (@Raw.eq_trans s s' s''). Qed.
+
+  Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''.
+  Proof. exact (@Raw.lt_trans s s' s''). Qed.
+  Lemma lt_not_eq : lt s s' -> ~ eq s s'.
+  Proof. exact (Raw.lt_not_eq s.(sorted) s'.(sorted)). Qed.
+
+  Definition compare : Compare lt eq s s'.
+  Proof.
+  elim (Raw.compare s.(sorted) s'.(sorted));
+   [ constructor 1 | constructor 2 | constructor 3 ]; 
+   auto. 
+  Defined.
+
+ End Spec.
+
+End Make.
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
new file mode 100644
index 00000000..6e93a546
--- /dev/null
+++ b/theories/FSets/FSetProperties.v
@@ -0,0 +1,895 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *)
+
+(** * Finite sets library *)
+
+(** This functor derives additional properties from [FSetInterface.S].
+    Contrary to the functor in [FSetEqProperties] it uses 
+    predicates over sets instead of sets operations, i.e.
+    [In x s] instead of [mem x s=true], 
+    [Equal s s'] instead of [equal s s'=true], etc. *)
+
+Require Export FSetInterface. 
+Require Import FSetFacts.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Hint Unfold transpose compat_op compat_nat.
+Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence.
+
+Module Properties (M: S).
+  Module ME:=OrderedTypeFacts(M.E).
+  Import ME. (* for ME.eq_dec *)
+  Import M.E.
+  Import M.
+  Import Logic. (* to unmask [eq] *)  
+  Import Peano. (* to unmask [lt] *)
+  
+   (** Results about lists without duplicates *)
+
+  Module FM := Facts M.
+  Import FM.
+
+  Definition Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq x y \/ In y s.
+
+  Lemma In_dec : forall x s, {In x s} + {~ In x s}.
+  Proof.
+  intros; generalize (mem_iff s x); case (mem x s); intuition.
+  Qed.
+
+  Section BasicProperties.
+
+  (** properties of [Equal] *)
+
+  Lemma equal_refl : forall s, s[=]s.
+  Proof.
+  unfold Equal; intuition.
+  Qed.
+
+  Lemma equal_sym : forall s s', s[=]s' -> s'[=]s.
+  Proof.
+  unfold Equal; intros.
+  rewrite H; intuition.
+  Qed.
+
+  Lemma equal_trans : forall s1 s2 s3, s1[=]s2 -> s2[=]s3 -> s1[=]s3.
+  Proof.
+  unfold Equal; intros.
+  rewrite H; exact (H0 a).
+  Qed.
+
+  Variable s s' s'' s1 s2 s3 : t.
+  Variable x x' : elt.
+
+  (** properties of [Subset] *)
+  
+  Lemma subset_refl : s[<=]s. 
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
+  Proof.
+  unfold Subset, Equal; intuition.
+  Qed.
+
+  Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma subset_equal : s[=]s' -> s[<=]s'.
+  Proof.
+  unfold Subset, Equal; firstorder.
+  Qed.
+
+  Lemma subset_empty : empty[<=]s.
+  Proof.
+  unfold Subset; intros a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
+  Proof.
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
+  Proof.
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
+  Proof.
+  unfold Subset; intros H H0 a; set_iff; intuition.
+  rewrite <- H2; auto.
+  Qed.
+
+  Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+ 
+  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
+  Proof.
+  unfold Subset, Equal; split; intros; intuition; generalize (H a); intuition.
+  Qed.
+
+  (** properties of [empty] *)
+
+  Lemma empty_is_empty_1 : Empty s -> s[=]empty.
+  Proof.
+  unfold Empty, Equal; intros; generalize (H a); set_iff; tauto.
+  Qed.
+
+  Lemma empty_is_empty_2 : s[=]empty -> Empty s.
+  Proof.
+  unfold Empty, Equal; intros; generalize (H a); set_iff; tauto.
+  Qed.
+
+  (** properties of [add] *)
+
+  Lemma add_equal : In x s -> add x s [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite <- H1; auto.
+  Qed.
+ 
+  Lemma add_add : add x (add x' s) [=] add x' (add x s).
+  Proof. 
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  (** properties of [remove] *)
+
+  Lemma remove_equal : ~ In x s -> remove x s [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite H1 in H; auto.
+  Qed.
+
+  Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  (** properties of [add] and [remove] *)
+
+  Lemma add_remove : In x s -> add x (remove x s) [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; elim (eq_dec x a); intuition.
+  rewrite <- H1; auto.
+  Qed.
+
+  Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; elim (eq_dec x a); intuition.
+  rewrite H1 in H; auto.
+  Qed.
+
+  (** properties of [singleton] *)
+
+  Lemma singleton_equal_add : singleton x [=] add x empty.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  (** properties of [union] *)
+
+  Lemma union_sym : union s s' [=] union s' s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
+  Proof.
+  unfold Subset, Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma add_union_singleton : add x s [=] union (singleton x) s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_add : union (add x s) s' [=] add x (union s s').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_subset_1 : s [<=] union s s'.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma union_subset_2 : s' [<=] union s s'.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
+  Proof.
+  unfold Subset; intros H H0 a; set_iff; intuition.
+  Qed.
+
+  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
+  Proof. 
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
+  Proof. 
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma empty_union_1 : Empty s -> union s s' [=] s'.
+  Proof.
+  unfold Equal, Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_union_2 : Empty s -> union s' s [=] s'.
+  Proof.
+  unfold Equal, Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). 
+  Proof.
+  intros; set_iff; intuition. 
+  Qed.  
+
+  (** properties of [inter] *)
+
+  Lemma inter_sym : inter s s' [=] inter s' s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite <- H1; auto.
+  Qed.
+
+  Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  destruct H; rewrite H0; auto.
+  Qed.
+
+  Lemma empty_inter_1 : Empty s -> Empty (inter s s').
+  Proof.
+  unfold Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
+  Proof.
+  unfold Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma inter_subset_1 : inter s s' [<=] s.
+  Proof.
+  unfold Subset; intro a; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_2 : inter s s' [<=] s'.
+  Proof.
+  unfold Subset; intro a; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_3 :
+   s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
+  Proof.
+  unfold Subset; intros H H' a; set_iff; intuition.
+  Qed.
+
+  (** properties of [diff] *)
+
+  Lemma empty_diff_1 : Empty s -> Empty (diff s s'). 
+  Proof.
+  unfold Empty, Equal; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
+  Proof.
+  unfold Empty, Equal; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma diff_subset : diff s s' [<=] s.
+  Proof.
+  unfold Subset; intros a; set_iff; tauto.
+  Qed.
+
+  Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
+  Proof.
+  unfold Subset, Equal; intros; set_iff; intuition; absurd (In a empty); auto.
+  Qed.
+
+  Lemma remove_diff_singleton :
+   remove x s [=] diff s (singleton x).
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. 
+  Proof.
+  unfold Equal; intros; set_iff; intuition; absurd (In a empty); auto.
+  Qed.
+
+  Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  elim (In_dec a s'); auto.
+  Qed.
+
+  (** properties of [Add] *)
+
+  Lemma Add_add : Add x s (add x s).
+  Proof.
+   unfold Add; intros; set_iff; intuition.
+  Qed.
+
+  Lemma Add_remove : In x s -> Add x (remove x s) s. 
+  Proof. 
+    unfold Add; intros; set_iff; intuition.
+    elim (eq_dec x y); auto.
+    rewrite <- H1; auto.
+  Qed.
+
+  Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
+  Proof. 
+  unfold Add; intros; set_iff; rewrite H; tauto.
+  Qed.
+
+  Lemma inter_Add :
+   In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
+  Proof. 
+  unfold Add; intros; set_iff; rewrite H0; intuition.
+  rewrite <- H2; auto.
+  Qed.  
+
+  Lemma union_Equal :
+   In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
+  Proof. 
+  unfold Add, Equal; intros; set_iff; rewrite H0; intuition. 
+  rewrite <- H1; auto.
+  Qed.  
+
+  Lemma inter_Add_2 :
+   ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
+  Proof.
+  unfold Add, Equal; intros; set_iff; rewrite H0; intuition.
+  destruct H; rewrite H1; auto.
+  Qed.
+
+  End BasicProperties.
+
+  Hint Immediate equal_sym: set.
+  Hint Resolve equal_refl equal_trans : set.
+
+  Hint Immediate add_remove remove_add union_sym inter_sym: set.
+  Hint Resolve subset_refl subset_equal subset_antisym 
+    subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 
+    subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal
+    remove_equal singleton_equal_add union_subset_equal union_equal_1 
+    union_equal_2 union_assoc add_union_singleton union_add union_subset_1 
+    union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2
+    inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2
+    empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 
+    empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union 
+    inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal 
+    remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
+    Equal_remove add_add : set.
+
+  (** * Alternative (weaker) specifications for [fold] *)
+
+  Section Old_Spec_Now_Properties. 
+
+  Notation NoDup := (NoDupA E.eq).
+
+  (** When [FSets] was first designed, the order in which Ocaml's [Set.fold]
+        takes the set elements was unspecified. This specification reflects this fact: 
+  *)
+
+  Lemma fold_0 : 
+      forall s (A : Set) (i : A) (f : elt -> A -> A),
+      exists l : list elt,
+        NoDup l /\
+        (forall x : elt, In x s <-> InA E.eq x l) /\
+        fold f s i = fold_right f i l.
+  Proof.
+  intros; exists (rev (elements s)); split.
+  apply NoDupA_rev; auto.
+  exact E.eq_trans.
+  split; intros.
+  rewrite elements_iff; do 2 rewrite InA_alt.
+  split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition.
+  rewrite fold_left_rev_right.
+  apply fold_1.
+  Qed.
+
+  (** An alternate (and previous) specification for [fold] was based on 
+      the recursive structure of a set. It is now lemmas [fold_1] and 
+      [fold_2]. *)
+
+  Lemma fold_1 :
+   forall s (A : Set) (eqA : A -> A -> Prop) 
+     (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
+   Empty s -> eqA (fold f s i) i.
+  Proof.
+  unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))).
+  rewrite H3; clear H3.
+  generalize H H2; clear H H2; case l; simpl; intros.
+  refl_st.
+  elim (H e).
+  elim (H2 e); intuition. 
+  Qed.
+
+  Lemma fold_2 :
+   forall s s' x (A : Set) (eqA : A -> A -> Prop)
+     (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
+   compat_op E.eq eqA f ->
+   transpose eqA f ->
+   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); 
+    destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
+  rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
+  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto.
+  eauto.
+  exact eq_dec.
+  rewrite <- Hl1; auto.
+  intros; rewrite <- Hl1; rewrite <- Hl'1; auto.
+  Qed.
+
+  (** Similar specifications for [cardinal]. *)
+
+  Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0.
+  Proof.
+  intros; rewrite cardinal_1; rewrite M.fold_1.
+  symmetry; apply fold_left_length; auto.
+  Qed.
+
+  Lemma cardinal_0 :
+     forall s, exists l : list elt,
+        NoDupA E.eq l /\
+        (forall x : elt, In x s <-> InA E.eq x l) /\ 
+        cardinal s = length l.
+  Proof. 
+  intros; exists (elements s); intuition; apply cardinal_1.
+  Qed.
+
+  Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0.
+  Proof.
+  intros; rewrite cardinal_fold; apply fold_1; auto.
+  Qed.
+
+  Lemma cardinal_2 :
+    forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s).
+  Proof.
+  intros; do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x).
+  apply fold_2; auto.
+  Qed.
+
+  End Old_Spec_Now_Properties.
+
+  (** * Induction principle over sets *)
+
+  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. 
+  Proof. 
+    intros s; rewrite M.cardinal_1; intros H a; red.
+    rewrite elements_iff.
+    destruct (elements s); simpl in *; discriminate || inversion 1.
+  Qed.
+  Hint Resolve cardinal_inv_1.
+ 
+  Lemma cardinal_inv_2 :
+   forall s n, cardinal s = S n -> { x : elt | In x s }.
+  Proof. 
+    intros; rewrite M.cardinal_1 in H.
+    generalize (elements_2 (s:=s)).
+    destruct (elements s); try discriminate. 
+    exists e; auto.
+  Qed.
+
+  Lemma Equal_cardinal_aux :
+   forall n s s', cardinal s = n -> s[=]s' -> cardinal s = cardinal s'.
+  Proof.
+     simple induction n; intros.
+     rewrite H; symmetry .
+     apply cardinal_1.
+     rewrite <- H0; auto.
+     destruct (cardinal_inv_2 H0) as (x,H2).
+     revert H0.
+     rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set.
+     rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); auto with set.
+     rewrite H1 in H2; auto with set.
+  Qed.
+
+  Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
+  Proof. 
+    intros; apply Equal_cardinal_aux with (cardinal s); auto.
+  Qed.
+
+  Add Morphism cardinal : cardinal_m.
+  Proof.
+  exact Equal_cardinal.
+  Qed.
+
+  Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal.
+
+  Lemma cardinal_induction :
+   forall P : t -> Type,
+   (forall s, Empty s -> P s) ->
+   (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') ->
+   forall n s, cardinal s = n -> P s.
+  Proof.
+  simple induction n; intros; auto.
+  destruct (cardinal_inv_2 H) as (x,H0). 
+  apply X0 with (remove x s) x; auto.
+  apply X1; auto.
+  rewrite (cardinal_2 (x:=x)(s:=remove x s)(s':=s)) in H; auto.
+  Qed.
+
+  Lemma set_induction :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s' : t, P s -> forall x : elt, ~In x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; apply cardinal_induction with (cardinal s); auto.
+  Qed.  
+
+  (** Other properties of [fold]. *)
+
+  Section Fold. 
+  Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
+  Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
+
+  Section Fold_1. 
+  Variable i i':A.
+
+  Lemma fold_empty : eqA (fold f empty i) i.
+  Proof. 
+  apply fold_1; auto.
+  Qed.
+
+  Lemma fold_equal : 
+   forall s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof. 
+  intros s; pattern s; apply set_induction; clear s; intros.
+  trans_st i.
+  apply fold_1; auto.
+  sym_st; apply fold_1; auto.
+  rewrite <- H0; auto.
+  trans_st (f x (fold f s i)).
+  apply fold_2 with (eqA := eqA); auto.
+  sym_st; apply fold_2 with (eqA := eqA); auto.
+  unfold Add in *; intros.
+  rewrite <- H2; auto.
+  Qed.
+   
+  Lemma fold_add : forall s x, ~In x s -> 
+   eqA (fold f (add x s) i) (f x (fold f s i)).
+  Proof. 
+  intros; apply fold_2 with (eqA := eqA); auto.
+  Qed.
+
+  Lemma add_fold : forall s x, In x s -> 
+   eqA (fold f (add x s) i) (fold f s i).
+  Proof.
+  intros; apply fold_equal; auto with set.
+  Qed.
+
+  Lemma remove_fold_1: forall s x, In x s -> 
+   eqA (f x (fold f (remove x s) i)) (fold f s i).
+  Proof.
+  intros.
+  sym_st.
+  apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma remove_fold_2: forall s x, ~In x s -> 
+   eqA (fold f (remove x s) i) (fold f s i).
+  Proof.
+  intros.
+  apply fold_equal; auto with set.
+  Qed.
+
+  Lemma fold_commutes : forall s x, 
+   eqA (fold f s (f x i)) (f x (fold f s i)).
+  Proof.
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st (f x i).
+  apply fold_1; auto.
+  sym_st.
+  apply Comp; auto.
+  apply fold_1; auto.
+  trans_st (f x0 (fold f s (f x i))).
+  apply fold_2 with (eqA:=eqA); auto.
+  trans_st (f x0 (f x (fold f s i))).
+  trans_st (f x (f x0 (fold f s i))).
+  apply Comp; auto.
+  sym_st.
+  apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma fold_init : forall s, eqA i i' -> 
+   eqA (fold f s i) (fold f s i').
+  Proof. 
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st i.
+  apply fold_1; auto.
+  trans_st i'.
+  sym_st; apply fold_1; auto.
+  trans_st (f x (fold f s i)).
+  apply fold_2 with (eqA:=eqA); auto.
+  trans_st (f x (fold f s i')).
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  End Fold_1.
+  Section Fold_2.
+  Variable i:A.
+
+  Lemma fold_union_inter : forall s s',
+   eqA (fold f (union s s') (fold f (inter s s') i))
+       (fold f s (fold f s' i)).
+  Proof.
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st (fold f s' (fold f (inter s s') i)).
+  apply fold_equal; auto with set.
+  trans_st (fold f s' i).
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  sym_st; apply fold_1; auto.
+  rename s'0 into s''.
+  destruct (In_dec x s').
+  (* In x s' *)   
+  trans_st (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
+  apply fold_init; auto.
+  apply fold_2 with (eqA:=eqA); auto with set.
+  rewrite inter_iff; intuition.
+  trans_st (f x (fold f s (fold f s' i))).
+  trans_st (fold f (union s s') (f x (fold f (inter s s') i))).
+  apply fold_equal; auto.
+  apply equal_sym; apply union_Equal with x; auto with set.
+  trans_st (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply fold_commutes; auto.
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  (* ~(In x s') *)
+  trans_st (f x (fold f (union s s') (fold f (inter s'' s') i))).
+  apply fold_2 with (eqA:=eqA); auto with set.
+  trans_st (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply Comp;auto.
+  apply fold_init;auto.
+  apply fold_equal;auto.
+  apply equal_sym; apply inter_Add_2 with x; auto with set.
+  trans_st (f x (fold f s (fold f s' i))).
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  End Fold_2.
+  Section Fold_3.
+  Variable i:A.
+
+  Lemma fold_diff_inter : forall s s', 
+   eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
+  Proof.
+  intros.
+  trans_st (fold f (union (diff s s') (inter s s')) 
+              (fold f (inter (diff s s') (inter s s')) i)).
+  sym_st; apply fold_union_inter; auto.
+  trans_st (fold f s (fold f (inter (diff s s') (inter s s')) i)).
+  apply fold_equal; auto with set.
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  Qed.
+
+  Lemma fold_union: forall s s', (forall x, ~In x s\/~In x s') ->
+   eqA (fold f (union s s') i) (fold f s (fold f s' i)).
+  Proof.
+  intros.
+  trans_st (fold f (union s s') (fold f (inter s s') i)).
+  apply fold_init; auto.
+  sym_st; apply fold_1; auto with set.
+  unfold Empty; intro a; generalize (H a); set_iff; tauto.
+  apply fold_union_inter; auto.
+  Qed.
+
+  End Fold_3.
+  End Fold.
+
+  Lemma fold_plus :
+   forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
+  Proof.
+  assert (st := gen_st nat).
+  assert (fe : compat_op E.eq (@eq _) (fun _ => S)) by (unfold compat_op; auto). 
+  assert (fp : transpose (@eq _) (fun _:elt => S)) by (unfold transpose; auto).
+  intros s p; pattern s; apply set_induction; clear s; intros.
+  rewrite (fold_1 st p (fun _ => S) H).
+  rewrite (fold_1 st 0 (fun _ => S) H); trivial.
+  assert (forall p s', Add x s s' -> fold (fun _ => S) s' p = S (fold (fun _ => S) s p)).
+   change S with ((fun _ => S) x).  
+   intros; apply fold_2; auto.
+  rewrite H2; auto.
+  rewrite (H2 0); auto.
+  rewrite H.
+  simpl; auto.
+  Qed.
+
+  (** properties of [cardinal] *)
+
+  Lemma empty_cardinal : cardinal empty = 0.
+  Proof.
+  rewrite cardinal_fold; apply fold_1; auto.
+  Qed.
+
+  Hint Immediate empty_cardinal cardinal_1 : set.
+
+  Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1.
+  Proof.
+  intros.
+  rewrite (singleton_equal_add x).
+  replace 0 with (cardinal empty); auto with set.
+  apply cardinal_2 with x; auto with set.
+  Qed.
+
+  Hint Resolve singleton_cardinal: set.
+
+  Lemma diff_inter_cardinal :
+   forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s .
+  Proof.
+  intros; do 3 rewrite cardinal_fold.
+  rewrite <- fold_plus.
+  apply fold_diff_inter with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma union_cardinal: 
+   forall s s', (forall x, ~In x s\/~In x s') -> 
+   cardinal (union s s')=cardinal s+cardinal s'.
+  Proof.
+  intros; do 3 rewrite cardinal_fold.
+  rewrite <- fold_plus.
+  apply fold_union; auto.
+  Qed.
+
+  Lemma subset_cardinal : 
+   forall s s', s[<=]s' -> cardinal s <= cardinal s' .
+  Proof.
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H); auto with arith.
+  Qed.
+
+  Lemma subset_cardinal_lt : 
+   forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
+  Proof. 
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H).
+  generalize (@cardinal_inv_1 (diff s' s)).
+  destruct (cardinal (diff s' s)).
+  intro H2; destruct (H2 (refl_equal _) x).
+  set_iff; auto.
+  intros _.
+  change (0 + cardinal s < S n + cardinal s).
+  apply Plus.plus_lt_le_compat; auto with arith.
+  Qed. 
+
+  Theorem union_inter_cardinal :
+   forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
+  Proof.
+  intros.
+  do 4 rewrite cardinal_fold.
+  do 2 rewrite <- fold_plus.
+  apply fold_union_inter with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma union_cardinal_inter : 
+   forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
+  Proof.
+  intros.
+  rewrite <- union_inter_cardinal.
+  rewrite Plus.plus_comm.
+  auto with arith.
+  Qed.
+
+  Lemma union_cardinal_le : 
+   forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
+  Proof.
+   intros; generalize (union_inter_cardinal s s').
+   intros; rewrite <- H; auto with arith.
+  Qed.
+
+  Lemma add_cardinal_1 : 
+   forall s x, In x s -> cardinal (add x s) = cardinal s.
+  Proof.
+  auto with set.  
+  Qed.
+
+  Lemma add_cardinal_2 :
+   forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x);
+   apply fold_add with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma remove_cardinal_1 :
+   forall s x, In x s -> S (cardinal (remove x s)) = cardinal s.
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ =>S) x).
+  apply remove_fold_1 with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma remove_cardinal_2 : 
+   forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
+  Proof. 
+  auto with set.
+  Qed.
+
+  Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2.
+
+End Properties.
diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v
new file mode 100644
index 00000000..8cf85efe
--- /dev/null
+++ b/theories/FSets/FSetToFiniteSet.v
@@ -0,0 +1,139 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: FSetToFiniteSet.v 8876 2006-05-30 13:43:15Z letouzey $ *)
+
+Require Import Ensembles Finite_sets.
+Require Import FSetInterface FSetProperties OrderedTypeEx.
+
+(** * Going from [FSets] with usual equality 
+    to the old [Ensembles] and [Finite_sets] theory. *)
+
+Module S_to_Finite_set (U:UsualOrderedType)(M:S with Module E := U).
+ Module MP:= Properties(M).
+ Import M MP FM Ensembles Finite_sets.
+
+ Definition mkEns : M.t -> Ensemble M.elt := 
+   fun s x => M.In x s.
+
+ Notation " !! " := mkEns.
+
+ Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x.
+ Proof.
+ unfold In; compute; auto.
+ Qed.
+
+ Lemma Subset_Included : forall s s',  s[<=]s'  <-> Included _ (!!s) (!!s').
+ Proof.
+ unfold Subset, Included, In, mkEns; intuition.
+ Qed.
+
+ Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity).
+
+ Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'.
+ Proof.
+ intros.
+ rewrite double_inclusion.
+ unfold Subset, Included, Same_set, In, mkEns; intuition.
+ Qed.
+
+ Lemma empty_Empty_Set : !!M.empty === Empty_set _.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1.
+ Qed.
+
+ Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intros.
+ destruct(H x H0).
+ inversion H0.
+ Qed.
+
+ Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x .
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; try constructor; auto.
+ Qed.
+
+ Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s').
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto.
+ Qed.
+
+ Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s').
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; try constructor; auto.
+ Qed.
+
+ Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; unfold E.eq; auto with sets.
+ inversion H0.
+ constructor 2; constructor.
+ constructor 1; auto.
+ Qed.
+
+ Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intros.
+ red in H; rewrite H in H0.
+ destruct H0.
+ inversion H0.
+ constructor 2; constructor.
+ constructor 1; auto.
+ red in H; rewrite H; unfold E.eq in *.
+ inversion H0; auto.
+ inversion H1; auto.
+ Qed.
+
+ Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; unfold E.eq in *; auto with sets.
+ split; auto.
+ swap H1.
+ inversion H2; auto.
+ Qed.
+
+ Lemma mkEns_Finite : forall s, Finite _ (!!s).
+ Proof.
+ intro s; pattern s; apply set_induction; clear s; intros.
+ intros; replace (!!s) with (Empty_set elt); auto with sets.
+ symmetry; apply Extensionality_Ensembles. 
+ apply Empty_Empty_set; auto.
+ replace (!!s') with (Add _ (!!s) x).
+ constructor 2; auto.
+ symmetry; apply Extensionality_Ensembles. 
+ apply Add_Add; auto.
+ Qed.
+
+ Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s).
+ Proof.
+ intro s; pattern s; apply set_induction; clear s; intros.
+ intros; replace (!!s) with (Empty_set elt); auto with sets.
+ rewrite cardinal_1; auto with sets.
+ symmetry; apply Extensionality_Ensembles. 
+ apply Empty_Empty_set; auto.
+ replace (!!s') with (Add _ (!!s) x).
+ rewrite (cardinal_2 H0 H1); auto with sets. 
+ symmetry; apply Extensionality_Ensembles. 
+ apply Add_Add; auto.
+ Qed.
+
+End S_to_Finite_set.
diff --git a/theories/FSets/FSetWeak.v b/theories/FSets/FSetWeak.v
new file mode 100644
index 00000000..c88a7869
--- /dev/null
+++ b/theories/FSets/FSetWeak.v
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetWeak.v 9278 2006-10-25 13:43:17Z letouzey $ *)
+
+Require Export DecidableType.
+Require Export DecidableTypeEx.
+Require Export FSetWeakInterface.
+Require Export FSetWeakFacts.
+Require Export FSetWeakProperties.
+Require Export FSetWeakList.
diff --git a/theories/FSets/FSetWeakFacts.v b/theories/FSets/FSetWeakFacts.v
new file mode 100644
index 00000000..61797a95
--- /dev/null
+++ b/theories/FSets/FSetWeakFacts.v
@@ -0,0 +1,421 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetWeakFacts.v 8882 2006-05-31 21:55:30Z letouzey $ *)
+
+(** * Finite sets library *)
+
+(** This functor derives additional facts from [FSetInterface.S]. These
+  facts are mainly the specifications of [FSetInterface.S] written using 
+  different styles: equivalence and boolean equalities. 
+  Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
+*)
+
+Require Export FSetWeakInterface. 
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Facts (M: S).
+Import M.E.
+Import M.
+Import Logic. (* to unmask [eq] *)  
+
+(** * Specifications written using equivalences *)
+
+Section IffSpec. 
+Variable s s' s'' : t.
+Variable x y z : elt.
+
+Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s).
+Proof.
+split; apply In_1; auto.
+Qed.
+
+Lemma mem_iff : In x s <-> mem x s = true.
+Proof.
+split; [apply mem_1|apply mem_2].
+Qed.
+
+Lemma not_mem_iff : ~In x s <-> mem x s = false.
+Proof.
+rewrite mem_iff; destruct (mem x s); intuition.
+Qed.
+
+Lemma equal_iff : s[=]s' <-> equal s s' = true.
+Proof. 
+split; [apply equal_1|apply equal_2].
+Qed.
+
+Lemma subset_iff : s[<=]s' <-> subset s s' = true.
+Proof. 
+split; [apply subset_1|apply subset_2].
+Qed.
+
+Lemma empty_iff : In x empty <-> False.
+Proof.
+intuition; apply (empty_1 H).
+Qed.
+
+Lemma is_empty_iff : Empty s <-> is_empty s = true. 
+Proof. 
+split; [apply is_empty_1|apply is_empty_2].
+Qed.
+
+Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
+Proof.
+split; [apply singleton_1|apply singleton_2].
+Qed.
+
+Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
+Proof. 
+split; [ | destruct 1; [apply add_1|apply add_2]]; auto.
+destruct (eq_dec x y) as [E|E]; auto.
+intro H; right; exact (add_3 E H).
+Qed.
+
+Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
+Proof.
+split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto.
+intro.
+apply (remove_1 H0 H).
+Qed.
+
+Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma union_iff : In x (union s s') <-> In x s \/ In x s'.
+Proof.
+split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto.
+Qed.
+
+Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'.
+Proof.
+split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto.
+Qed.
+
+Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'.
+Proof.
+split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto.
+Qed.
+
+Variable f : elt->bool.
+
+Lemma filter_iff :  compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true).
+Proof. 
+split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. 
+Qed.
+
+Lemma for_all_iff : compat_bool E.eq f ->
+  (For_all (fun x => f x = true) s <-> for_all f s = true).
+Proof.
+split; [apply for_all_1 | apply for_all_2]; auto.
+Qed.
+ 
+Lemma exists_iff : compat_bool E.eq f ->
+  (Exists (fun x => f x = true) s <-> exists_ f s = true).
+Proof.
+split; [apply exists_1 | apply exists_2]; auto.
+Qed.
+
+Lemma elements_iff : In x s <-> InA E.eq x (elements s).
+Proof. 
+split; [apply elements_1 | apply elements_2].
+Qed.
+
+End IffSpec.
+
+(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)
+  
+Ltac set_iff := 
+ repeat (progress (
+  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff 
+  || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
+  || rewrite empty_iff)).
+
+(**  * Specifications written using boolean predicates *)
+
+Definition eqb x y := if eq_dec x y then true else false.
+
+Section BoolSpec.
+Variable s s' s'' : t.
+Variable x y z : elt.
+
+Lemma mem_b : E.eq x y -> mem x s = mem y s.
+Proof. 
+intros.
+generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
+destruct (mem x s); destruct (mem y s); intuition.
+Qed.
+
+Lemma empty_b : mem y empty = false.
+Proof.
+generalize (empty_iff y)(mem_iff empty y).
+destruct (mem y empty); intuition.
+Qed.
+
+Lemma add_b : mem y (add x s) = eqb x y || mem y s.
+Proof.
+generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
+destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
+Proof.
+generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
+Qed.
+
+Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
+destruct (mem y s); destruct (mem y (remove x s)); intuition.
+Qed.
+
+Lemma singleton_b : mem y (singleton x) = eqb x y.
+Proof. 
+generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
+Qed.
+
+Lemma union_b : mem x (union s s') = mem x s || mem x s'.
+Proof.
+generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
+Qed.
+
+Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
+Proof.
+generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
+Qed.
+
+Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
+Proof.
+generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
+Qed.
+
+Lemma elements_b : mem x s = existsb (eqb x) (elements s).
+Proof.
+generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
+rewrite InA_alt.
+destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
+symmetry.
+rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
+exists a; intuition.
+unfold eqb; destruct (eq_dec x a); auto.
+rewrite <- H.
+rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as (a,(Ha1,Ha2)); [intuition|].
+exists a; intuition.
+unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
+Qed.
+
+Variable f : elt->bool.
+
+Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x.
+Proof. 
+intros.
+generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
+destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
+Qed.
+
+Lemma for_all_b : compat_bool E.eq f ->
+  for_all f s = forallb f (elements s).
+Proof.
+intros.
+generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
+unfold For_all.
+destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+rewrite (H2 x0) in H3.
+rewrite (InA_alt E.eq x0 (elements s)) in H3.
+destruct H3 as (a,(Ha1,Ha2)).
+rewrite (H _ _ Ha1).
+apply H0; auto.
+symmetry.
+rewrite H0; intros.
+destruct H1 as (_,H1).
+apply H1; auto.
+rewrite H2.
+rewrite InA_alt; eauto.
+Qed.
+
+Lemma exists_b : compat_bool E.eq f -> 
+  exists_ f s = existsb f (elements s).
+Proof.
+intros.
+generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s).
+unfold Exists.
+destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); auto.
+exists a; auto.
+split; auto.
+rewrite H2; rewrite InA_alt; eauto.
+symmetry.
+rewrite H0.
+destruct H1 as (_,H1).
+destruct H1 as (a,(Ha1,Ha2)); auto.
+rewrite (H2 a) in Ha1.
+rewrite (InA_alt E.eq a (elements s)) in Ha1.
+destruct Ha1 as (b,(Hb1,Hb2)).
+exists b; auto.
+rewrite <- (H _ _ Hb1); auto.
+Qed.
+
+End BoolSpec.
+
+(** * [E.eq] and [Equal] are setoid equalities *)
+
+Definition E_ST : Setoid_Theory elt E.eq.
+Proof.
+constructor; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans].
+Qed.
+
+Add Setoid elt E.eq E_ST as EltSetoid.
+
+Definition Equal_ST : Setoid_Theory t Equal.
+Proof. 
+constructor; unfold Equal; firstorder.
+Qed.
+
+Add Setoid t Equal Equal_ST as EqualSetoid.
+
+Add Morphism In with signature E.eq ==> Equal ==> iff as In_m.
+Proof.
+unfold Equal; intros x y H s s' H0.
+rewrite (In_eq_iff s H); auto.
+Qed.
+
+Add Morphism is_empty : is_empty_m.
+Proof.
+unfold Equal; intros s s' H.
+generalize (is_empty_iff s)(is_empty_iff s').
+destruct (is_empty s); destruct (is_empty s'); 
+ unfold Empty; auto; intros.
+symmetry.
+rewrite <- H1; intros a Ha.
+rewrite <- (H a) in Ha.
+destruct H0 as (_,H0).
+exact (H0 (refl_equal true) _ Ha).
+rewrite <- H0; intros a Ha.
+rewrite (H a) in Ha.
+destruct H1 as (_,H1).
+exact (H1 (refl_equal true) _ Ha).
+Qed.
+
+Add Morphism Empty with signature Equal ==> iff as Empty_m.
+Proof. 
+intros; do 2 rewrite is_empty_iff; rewrite H; intuition.
+Qed.
+
+Add Morphism mem : mem_m.
+Proof.
+unfold Equal; intros x y H s s' H0.
+generalize (H0 x); clear H0; rewrite (In_eq_iff s' H).
+generalize (mem_iff s x)(mem_iff s' y).
+destruct (mem x s); destruct (mem y s'); intuition.
+Qed.
+
+Add Morphism singleton : singleton_m.
+Proof.
+unfold Equal; intros x y H a.
+do 2 rewrite singleton_iff; split.
+intros; apply E.eq_trans with x; auto.
+intros; apply E.eq_trans with y; auto.
+Qed.
+
+Add Morphism add : add_m.
+Proof.
+unfold Equal; intros x y H s s' H0 a.
+do 2 rewrite add_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism remove : remove_m.
+Proof.
+unfold Equal; intros x y H s s' H0 a.
+do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism union : union_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite union_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism inter : inter_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism diff : diff_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Add Morphism Subset with signature Equal ==> Equal ==> iff as  Subset_m.
+Proof. 
+unfold Equal, Subset; firstorder.
+Qed.
+
+Add Morphism subset : subset_m.
+Proof.
+intros s s' H s'' s''' H0.
+generalize (subset_iff s s'') (subset_iff s' s'''). 
+destruct (subset s s''); destruct (subset s' s'''); auto; intros.
+rewrite H in H1; rewrite H0 in H1; intuition.
+rewrite H in H1; rewrite H0 in H1; intuition.
+Qed.
+
+Add Morphism equal : equal_m.
+Proof.
+intros s s' H s'' s''' H0.
+generalize (equal_iff s s'') (equal_iff s' s''').
+destruct (equal s s''); destruct (equal s' s'''); auto; intros.
+rewrite H in H1; rewrite H0 in H1; intuition.
+rewrite H in H1; rewrite H0 in H1; intuition.
+Qed.
+
+(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism
+   without additional hypothesis on [f]. For instance: *)
+
+Lemma filter_equal : forall f, compat_bool E.eq f -> 
+  forall s s', s[=]s' -> filter f s [=] filter f s'.
+Proof.
+unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto.
+Qed.
+
+(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid 
+   structures on [list elt] and [option elt]. *)
+
+(* Later:
+Add Morphism cardinal ; cardinal_m.
+*)
+
+End Facts.
diff --git a/theories/FSets/FSetWeakInterface.v b/theories/FSets/FSetWeakInterface.v
new file mode 100644
index 00000000..a281ce22
--- /dev/null
+++ b/theories/FSets/FSetWeakInterface.v
@@ -0,0 +1,251 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetWeakInterface.v 8820 2006-05-15 11:44:05Z letouzey $ *)
+
+(** * Finite sets library *)
+
+(** Set interfaces for types with only a decidable equality, but no ordering *)
+
+Require Export Bool.
+Require Export DecidableType.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** Compatibility of a  boolean function with respect to an equality. *)
+Definition compat_bool (A:Set)(eqA: A->A->Prop)(f: A-> bool) :=
+  forall x y : A, eqA x y -> f x = f y.
+
+(** Compatibility of a predicate with respect to an equality. *)
+Definition compat_P (A:Set)(eqA: A->A->Prop)(P : A -> Prop) :=
+  forall x y : A, eqA x y -> P x -> P y.
+
+Hint Unfold compat_bool compat_P.
+
+(** * Non-dependent signature
+
+    Signature [S] presents sets as purely informative programs 
+    together with axioms *)
+
+Module Type S.
+
+  Declare Module E : DecidableType.
+  Definition elt := E.t.
+
+  Parameter t : Set. (** the abstract type of sets *)
+
+  (** Logical predicates *)
+  Parameter In : elt -> t -> Prop.
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+  
+  Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
+  Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).
+
+  Parameter empty : t.
+  (** The empty set. *)
+
+  Parameter is_empty : t -> bool.
+  (** Test whether a set is empty or not. *)
+
+  Parameter mem : elt -> t -> bool.
+  (** [mem x s] tests whether [x] belongs to the set [s]. *)
+
+  Parameter add : elt -> t -> t.
+  (** [add x s] returns a set containing all elements of [s],
+  plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
+
+  Parameter singleton : elt -> t.
+  (** [singleton x] returns the one-element set containing only [x]. *)
+
+  Parameter remove : elt -> t -> t.
+  (** [remove x s] returns a set containing all elements of [s],
+  except [x]. If [x] was not in [s], [s] is returned unchanged. *)
+
+  Parameter union : t -> t -> t.
+  (** Set union. *)
+
+  Parameter inter : t -> t -> t.
+  (** Set intersection. *)
+
+  Parameter diff : t -> t -> t.
+  (** Set difference. *)
+
+  Parameter equal : t -> t -> bool.
+  (** [equal s1 s2] tests whether the sets [s1] and [s2] are
+  equal, that is, contain equal elements. *)
+
+  Parameter subset : t -> t -> bool.
+  (** [subset s1 s2] tests whether the set [s1] is a subset of
+  the set [s2]. *)
+
+  (** Coq comment: [iter] is useless in a purely functional world *)
+  (**  iter: (elt -> unit) -> set -> unit. i*)
+  (** [iter f s] applies [f] in turn to all elements of [s].
+  The order in which the elements of [s] are presented to [f]
+  is unspecified. *)
+
+  Parameter fold : forall A : Set, (elt -> A -> A) -> t -> A -> A.
+  (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
+  where [x1 ... xN] are the elements of [s].
+  The order in which elements of [s] are presented to [f] is
+  unspecified. *)
+
+  Parameter for_all : (elt -> bool) -> t -> bool.
+  (** [for_all p s] checks if all elements of the set
+  satisfy the predicate [p]. *)
+
+  Parameter exists_ : (elt -> bool) -> t -> bool.
+  (** [exists p s] checks if at least one element of
+  the set satisfies the predicate [p]. *)
+
+  Parameter filter : (elt -> bool) -> t -> t.
+  (** [filter p s] returns the set of all elements in [s]
+  that satisfy predicate [p]. *)
+
+  Parameter partition : (elt -> bool) -> t -> t * t.
+  (** [partition p s] returns a pair of sets [(s1, s2)], where
+  [s1] is the set of all the elements of [s] that satisfy the
+  predicate [p], and [s2] is the set of all the elements of
+  [s] that do not satisfy [p]. *)
+
+  Parameter cardinal : t -> nat.
+  (** Return the number of elements of a set. *)
+  (** Coq comment: nat instead of int ... *)
+
+  Parameter elements : t -> list elt.
+  (** Return the list of all elements of the given set, in any order. *)
+
+  Parameter choose : t -> option elt.
+  (** Return one element of the given set, or raise [Not_found] if
+  the set is empty. Which element is chosen is unspecified.
+  Equal sets could return different elements. *)
+  (** Coq comment: [Not_found] is represented by the option type *)
+
+  Section Spec. 
+
+  Variable s s' : t.
+  Variable x y : elt.
+
+  (** Specification of [In] *)
+  Parameter In_1 : E.eq x y -> In x s -> In y s.
+ 
+  (** Specification of [mem] *)
+  Parameter mem_1 : In x s -> mem x s = true.
+  Parameter mem_2 : mem x s = true -> In x s. 
+ 
+  (** Specification of [equal] *) 
+  Parameter equal_1 : Equal s s' -> equal s s' = true.
+  Parameter equal_2 : equal s s' = true -> Equal s s'.
+
+  (** Specification of [subset] *)
+  Parameter subset_1 : Subset s s' -> subset s s' = true.
+  Parameter subset_2 : subset s s' = true -> Subset s s'.
+
+  (** Specification of [empty] *)
+  Parameter empty_1 : Empty empty.
+
+  (** Specification of [is_empty] *)
+  Parameter is_empty_1 : Empty s -> is_empty s = true. 
+  Parameter is_empty_2 : is_empty s = true -> Empty s.
+ 
+  (** Specification of [add] *)
+  Parameter add_1 : E.eq x y -> In y (add x s).
+  Parameter add_2 : In y s -> In y (add x s).
+  Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+
+  (** Specification of [remove] *)
+  Parameter remove_1 : E.eq x y -> ~ In y (remove x s).
+  Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+  Parameter remove_3 : In y (remove x s) -> In y s.
+
+  (** Specification of [singleton] *)
+  Parameter singleton_1 : In y (singleton x) -> E.eq x y. 
+  Parameter singleton_2 : E.eq x y -> In y (singleton x). 
+
+  (** Specification of [union] *)
+  Parameter union_1 : In x (union s s') -> In x s \/ In x s'.
+  Parameter union_2 : In x s -> In x (union s s'). 
+  Parameter union_3 : In x s' -> In x (union s s').
+
+  (** Specification of [inter] *)
+  Parameter inter_1 : In x (inter s s') -> In x s.
+  Parameter inter_2 : In x (inter s s') -> In x s'.
+  Parameter inter_3 : In x s -> In x s' -> In x (inter s s').
+
+  (** Specification of [diff] *)
+  Parameter diff_1 : In x (diff s s') -> In x s. 
+  Parameter diff_2 : In x (diff s s') -> ~ In x s'.
+  Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+ 
+  (** Specification of [fold] *)  
+  Parameter fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+
+  (** Specification of [cardinal] *)  
+  Parameter cardinal_1 : cardinal s = length (elements s).
+
+  Section Filter.
+  
+  Variable f : elt -> bool.
+
+  (** Specification of [filter] *)
+  Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
+  Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Parameter filter_3 :
+      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+
+  (** Specification of [for_all] *)
+  Parameter for_all_1 :
+      compat_bool E.eq f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+  Parameter for_all_2 :
+      compat_bool E.eq f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+
+  (** Specification of [exists] *)
+  Parameter exists_1 :
+      compat_bool E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Parameter exists_2 :
+      compat_bool E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+
+  (** Specification of [partition] *)
+  Parameter partition_1 :
+      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Parameter partition_2 :
+      compat_bool E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+
+  End Filter.
+
+  (** Specification of [elements] *)
+  Parameter elements_1 : In x s -> InA E.eq x (elements s).
+  Parameter elements_2 : InA E.eq x (elements s) -> In x s.
+  Parameter elements_3 : NoDupA E.eq (elements s).
+
+  (** Specification of [choose] *)
+  Parameter choose_1 : choose s = Some x -> In x s.
+  Parameter choose_2 : choose s = None -> Empty s.
+
+  End Spec.
+
+  Hint Immediate In_1.
+  
+  Hint Resolve mem_1 mem_2 equal_1 equal_2 subset_1 subset_2 empty_1
+    is_empty_1 is_empty_2 choose_1 choose_2 add_1 add_2 add_3 remove_1
+    remove_2 remove_3 singleton_1 singleton_2 union_1 union_2 union_3 inter_1
+    inter_2 inter_3 diff_1 diff_2 diff_3 filter_1 filter_2 filter_3 for_all_1
+    for_all_2 exists_1 exists_2 partition_1 partition_2 elements_1 elements_2
+    elements_3.
+
+End S.
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
new file mode 100644
index 00000000..97080b7a
--- /dev/null
+++ b/theories/FSets/FSetWeakList.v
@@ -0,0 +1,936 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetWeakList.v 8834 2006-05-20 00:41:35Z letouzey $ *)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependant 
+    interface [FSetWeakInterface.S] using lists without redundancy. *)
+
+Require Import FSetWeakInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Functions over lists
+
+   First, we provide sets as lists which are (morally) without redundancy.
+   The specs are proved under the additional condition of no redundancy. 
+   And the functions returning sets are proved to preserve this invariant. *)
+
+Module Raw (X: DecidableType).
+ 
+  Module E := X.
+
+  Definition elt := X.t.
+  Definition t := list elt.
+
+  Definition empty : t := nil.
+
+  Definition is_empty (l : t) : bool := if l then true else false.
+
+  (** ** The set operations. *)
+
+  Fixpoint mem (x : elt) (s : t) {struct s} : bool :=
+    match s with
+    | nil => false
+    | y :: l =>
+           if X.eq_dec x y then true else mem x l
+    end.
+
+  Fixpoint add (x : elt) (s : t) {struct s} : t :=
+    match s with
+    | nil => x :: nil
+    | y :: l =>
+        if X.eq_dec x y then s else y :: add x l
+    end.
+
+  Definition singleton (x : elt) : t := x :: nil. 
+
+  Fixpoint remove (x : elt) (s : t) {struct s} : t :=
+    match s with
+    | nil => nil
+    | y :: l =>
+        if X.eq_dec x y then l else y :: remove x l
+    end.
+
+  Fixpoint fold (B : Set) (f : elt -> B -> B) (s : t) {struct s} : 
+   B -> B := fun i => match s with
+                      | nil => i
+                      | x :: l => fold f l (f x i)
+                      end.  
+
+  Definition union (s : t) : t -> t := fold add s.
+  
+  Definition diff (s s' : t) : t := fold remove s' s.
+
+  Definition inter (s s': t) : t := 
+    fold (fun x s => if mem x s' then add x s else s) s nil.
+
+  Definition subset (s s' : t) : bool := is_empty (diff s s').
+
+  Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). 
+
+  Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t :=
+    match s with
+    | nil => nil
+    | x :: l => if f x then x :: filter f l else filter f l
+    end.  
+
+  Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool :=
+    match s with
+    | nil => true
+    | x :: l => if f x then for_all f l else false
+    end.  
+ 
+  Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool :=
+    match s with
+    | nil => false
+    | x :: l => if f x then true else exists_ f l
+    end.
+
+  Fixpoint partition (f : elt -> bool) (s : t) {struct s} : 
+   t * t :=
+    match s with
+    | nil => (nil, nil)
+    | x :: l =>
+        let (s1, s2) := partition f l in
+        if f x then (x :: s1, s2) else (s1, x :: s2)
+    end.
+
+  Definition cardinal (s : t) : nat := length s.
+
+  Definition elements (s : t) : list elt := s.
+
+  Definition choose (s : t) : option elt := 
+     match s with 
+      | nil => None
+      | x::_ => Some x
+     end.
+
+  (** ** Proofs of set operation specifications. *)
+  Section ForNotations. 
+  Notation NoDup := (NoDupA X.eq).
+  Notation In := (InA X.eq).
+
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Lemma In_eq :
+    forall (s : t) (x y : elt), X.eq x y -> In x s -> In y s.
+  Proof.
+  intros s x y; do 2 setoid_rewrite InA_alt; firstorder eauto.
+  Qed.
+  Hint Immediate In_eq.
+
+  Lemma mem_1 :
+   forall (s : t)(x : elt), In x s -> mem x s = true. 
+  Proof.
+  induction s; intros.
+  inversion H.
+  simpl; destruct (X.eq_dec x a); trivial.
+  inversion_clear H; auto.
+  Qed.
+
+  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
+  Proof.
+  induction s. 
+  intros; inversion H.
+  intros x; simpl.
+  destruct (X.eq_dec x a); firstorder; discriminate.
+  Qed.
+
+  Lemma add_1 :
+   forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> In y (add x s).
+  Proof.
+  induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
+   firstorder.
+  eauto.
+  Qed.
+
+  Lemma add_2 :
+   forall (s : t) (Hs : NoDup s) (x y : elt), In y s -> In y (add x s).
+  Proof.
+  induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.eq_dec x a); intuition.
+  inversion_clear Hs; eauto; inversion_clear H; intuition.
+  Qed.
+
+  Lemma add_3 :
+   forall (s : t) (Hs : NoDup s) (x y : elt),
+   ~ X.eq x y -> In y (add x s) -> In y s.
+  Proof.
+  induction s. 
+  simpl; intuition.
+  inversion_clear H0; firstorder; absurd (X.eq x y); auto.
+  simpl; intros Hs x y; case (X.eq_dec x a); intros;
+   inversion_clear H0; inversion_clear Hs; firstorder; 
+   absurd (X.eq x y); auto.
+  Qed.
+
+  Lemma add_unique :
+   forall (s : t) (Hs : NoDup s)(x:elt), NoDup (add x s).
+  Proof.
+  induction s.  
+  simpl; intuition.
+  constructor; auto.
+  intro H0; inversion H0.
+  intros.
+  inversion_clear Hs.
+  simpl.
+  destruct (X.eq_dec x a).
+  constructor; auto.
+  constructor; auto.
+  intro H1; apply H.
+  eapply add_3; eauto.
+  Qed.
+
+  Lemma remove_1 :
+   forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> ~ In y (remove x s).
+  Proof.
+  simple induction s. 
+  simpl; red; intros; inversion H0.
+  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs. 
+  elim H2.
+  apply In_eq with y; eauto.
+  inversion_clear H1; eauto.
+  Qed.
+
+  Lemma remove_2 :
+   forall (s : t) (Hs : NoDup s) (x y : elt),
+   ~ X.eq x y -> In y s -> In y (remove x s).
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
+   inversion_clear H1; auto. 
+  absurd (X.eq x y); eauto. 
+  Qed.
+
+  Lemma remove_3 :
+   forall (s : t) (Hs : NoDup s) (x y : elt), In y (remove x s) -> In y s.
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros a l Hrec Hs x y; case (X.eq_dec x a); intuition.
+  inversion_clear Hs; inversion_clear H; firstorder.
+  Qed.
+
+  Lemma remove_unique :
+   forall (s : t) (Hs : NoDup s) (x : elt), NoDup (remove x s).
+  Proof.
+  simple induction s.
+  simpl; intuition.
+  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
+   auto.
+  constructor; auto.
+  intro H2; elim H0.
+  eapply remove_3; eauto.
+  Qed. 
+
+  Lemma singleton_unique : forall x : elt, NoDup (singleton x).
+  Proof.
+  unfold singleton; simpl; constructor; auto; intro H; inversion H.
+  Qed.
+
+  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y.
+  Proof.
+  unfold singleton; simpl; intuition.
+  inversion_clear H; auto; inversion H0.
+  Qed. 
+
+  Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x).
+  Proof.
+  unfold singleton; simpl; intuition.
+  Qed. 
+  
+  Lemma empty_unique : NoDup empty.
+  Proof.
+  unfold empty; constructor.
+  Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  unfold Empty, empty; intuition; inversion H.
+  Qed. 
+
+  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition.
+  elim (H e); auto.
+  Qed.
+  
+  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. 
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition;
+   inversion H0.
+  Qed.
+
+  Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s).
+  Proof.
+  unfold elements; auto.
+  Qed.
+
+  Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s.
+  Proof. 
+  unfold elements; auto.
+  Qed.
+ 
+  Lemma elements_3 : forall (s : t) (Hs : NoDup s), NoDup (elements s).  
+  Proof. 
+  unfold elements; auto.
+  Qed.
+
+  Lemma fold_1 :
+   forall (s : t) (Hs : NoDup s) (A : Set) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof.
+  induction s; simpl; auto; intros.
+  inversion_clear Hs; auto.
+  Qed.
+
+  Lemma union_unique :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (union s s').
+  Proof.
+  unfold union; induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  apply IHs; auto.
+  apply add_unique; auto.
+  Qed.
+  
+  Lemma union_1 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x (union s s') -> In x s \/ In x s'.
+  Proof.
+  unfold union; induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  destruct (X.eq_dec x a).
+  left; auto.
+  destruct (IHs (add a s') H1 (add_unique Hs' a) x); intuition.
+  right; eapply add_3; eauto.
+  Qed.
+
+  Lemma union_0 : 
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x s \/ In x s' -> In x (union s s').
+  Proof.
+  unfold union; induction s; simpl; auto; intros.
+  inversion_clear H; auto.
+  inversion_clear H0.
+  inversion_clear Hs.
+  apply IHs; auto.
+  apply add_unique; auto.
+  destruct H.
+  inversion_clear H; auto.
+  right; apply add_1; auto.
+  right; apply add_2; auto.
+  Qed.
+
+  Lemma union_2 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x s -> In x (union s s').
+  Proof.
+  intros; apply union_0; auto.
+  Qed.
+
+  Lemma union_3 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x s' -> In x (union s s').
+  Proof.
+  intros; apply union_0; auto.
+  Qed.
+
+  Lemma inter_unique :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (inter s s').
+  Proof.
+  unfold inter; intros s.
+  set (acc := nil (A:=elt)).
+  assert (NoDup acc) by (unfold acc; auto).
+  clearbody acc; generalize H; clear H; generalize acc; clear acc. 
+  induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  apply IHs; auto.
+  destruct (mem a s'); intros; auto.
+  apply add_unique; auto.
+  Qed.  
+  
+  Lemma inter_0  :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x (inter s s') -> In x s /\ In x s'.
+  Proof.
+  unfold inter; intros.
+  set (acc := nil (A:=elt)) in *.
+  assert (NoDup acc) by (unfold acc; auto).
+  cut ((In x s /\ In x s') \/ In x acc).
+    destruct 1; auto.
+    inversion H1.
+  clearbody acc. 
+  generalize H0 H Hs' Hs; clear H0 H Hs Hs'.
+  generalize acc x s'; clear acc x s'.
+  induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  case_eq (mem a s'); intros H3; rewrite H3 in H; simpl in H.
+  destruct (IHs _ _ _ (add_unique H0 a) H); auto.
+  left; intuition.
+  destruct (X.eq_dec x a); auto.
+  left; intuition.
+  apply In_eq with a; eauto.
+  apply mem_2; auto.
+  right; eapply add_3; eauto.
+  destruct (IHs _ _ _ H0 H); auto.
+  left; intuition.
+  Qed.
+
+  Lemma inter_1  :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x (inter s s') -> In x s.
+  Proof.
+  intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ].
+  Qed.
+
+  Lemma inter_2 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x (inter s s') -> In x s'.
+  Proof.
+  intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ].
+  Qed.
+
+  Lemma inter_3 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x s -> In x s' -> In x (inter s s').
+  Proof.
+  intros s s' Hs Hs' x.
+  cut (((In x s /\ In x s')\/ In x (nil (A:=elt))) -> In x (inter s s')).
+  intuition.
+  unfold inter.
+  set (acc := nil (A:=elt)) in *.
+  assert (NoDup acc) by (unfold acc; auto).
+  clearbody acc. 
+  generalize H Hs' Hs; clear H Hs Hs'.
+  generalize acc x s'; clear acc x s'.
+  induction s; simpl; auto; intros.
+  destruct H0; auto.
+  destruct H0; inversion H0.
+  inversion_clear Hs.
+  case_eq (mem a s'); intros H3; apply IHs; auto.
+  apply add_unique; auto.
+  destruct H0.
+  destruct H0.
+  inversion_clear H0.
+  right; apply add_1; auto.
+  left; auto.
+  right; apply add_2; auto.
+  destruct H0; auto.
+  destruct H0.
+  inversion_clear H0; auto.
+  absurd (In x s'); auto.
+  red; intros.
+  rewrite (mem_1 (In_eq H5 H0)) in H3.
+  discriminate.
+  Qed.
+
+  Lemma diff_unique :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (diff s s').
+  Proof.
+  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
+  induction s'; simpl; auto; intros.
+  inversion_clear Hs'.
+  apply IHs'; auto.
+  apply remove_unique; auto.
+  Qed.  
+  
+  Lemma diff_0 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x (diff s s') -> In x s /\ ~ In x s'.
+  Proof.
+  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
+  induction s'; simpl; auto; intros.
+  inversion_clear Hs'.
+  split; auto; intro H1; inversion H1.
+  inversion_clear Hs'.
+  destruct (IHs' (remove a s) (remove_unique Hs a) H1 x H).
+  split. 
+  eapply remove_3; eauto.
+  red; intros.
+  inversion_clear H4; auto.
+  destruct (remove_1 Hs (X.eq_sym H5) H2).
+  Qed.
+
+  Lemma diff_1 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x (diff s s') -> In x s.
+  Proof.
+  intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. 
+  Qed.
+
+  Lemma diff_2 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x (diff s s') -> ~ In x s'.
+  Proof.
+  intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. 
+  Qed.
+
+  Lemma diff_3 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt),
+   In x s -> ~ In x s' -> In x (diff s s').
+  Proof.
+  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
+  induction s'; simpl; auto; intros.
+  inversion_clear Hs'.
+  apply IHs'; auto.
+  apply remove_unique; auto.
+  apply remove_2; auto.
+  Qed.  
+  
+  Lemma subset_1 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'),
+   Subset s s' -> subset s s' = true.
+  Proof.
+  unfold subset, Subset; intros.
+  apply is_empty_1.
+  unfold Empty; intros.
+  intro.
+  destruct (diff_2 Hs Hs' H0).
+  apply H.
+  eapply diff_1; eauto.
+  Qed.
+
+  Lemma subset_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), 
+     subset s s' = true -> Subset s s'.
+  Proof.
+  unfold subset, Subset; intros.
+  generalize (is_empty_2 H); clear H; unfold Empty; intros.
+  generalize (@mem_1 s' a) (@mem_2 s' a); destruct (mem a s').
+  intuition.
+  intros.
+  destruct (H a).
+  apply diff_3; intuition.
+  Qed.
+
+  Lemma equal_1 :
+   forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'),
+   Equal s s' -> equal s s' = true.
+  Proof.
+  unfold Equal, equal; intros.
+  apply andb_true_intro; split; apply subset_1; firstorder.
+  Qed.
+
+  Lemma equal_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'),  
+     equal s s' = true -> Equal s s'.
+  Proof.
+  unfold Equal, equal; intros.
+  destruct (andb_prop _ _ H); clear H.
+  split; apply subset_2; auto.
+  Qed.  
+
+  Definition choose_1 :
+    forall (s : t) (x : elt), choose s = Some x -> In x s.
+  Proof.
+  destruct s; simpl; intros; inversion H; auto.
+  Qed.  
+
+  Definition choose_2 : forall s : t, choose s = None -> Empty s.
+  Proof.
+  destruct s; simpl; intros.
+  intros x H0; inversion H0.
+  inversion H.
+  Qed.  
+
+  Lemma cardinal_1 :
+   forall (s : t) (Hs : NoDup s), cardinal s = length (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma filter_1 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   In x (filter f s) -> In x s.
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H.
+  intros x l Hrec a f.
+  case (f x); simpl.
+  inversion_clear 1.
+  constructor; auto.
+  constructor 2; apply (Hrec a f); trivial.
+  constructor 2; apply (Hrec a f); trivial.
+  Qed.
+
+   Lemma filter_2 :
+    forall (s : t) (x : elt) (f : elt -> bool),
+    compat_bool X.eq f -> In x (filter f s) -> f x = true.   
+   Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  generalize (Hf x); case (f x); simpl; auto.
+  inversion_clear 2; auto.
+  symmetry; auto.
+  Qed.
+ 
+  Lemma filter_3 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s).     
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  generalize (Hf x); case (f x); simpl.
+  inversion_clear 2; auto.
+  inversion_clear 2; auto.
+  rewrite <- (H a (X.eq_sym H1)); intros; discriminate.
+  Qed.
+
+  Lemma filter_unique :
+   forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (filter f s).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  case (f x); auto.
+  constructor; auto.
+  intro H1; apply H.
+  eapply filter_1; eauto.
+  Qed.
+
+
+  Lemma for_all_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. 
+  simple induction s; simpl; auto; unfold For_all.
+  intros x l Hrec f Hf. 
+  generalize (Hf x); case (f x); simpl.
+  auto.
+  intros; rewrite (H x); auto.
+  Qed.
+
+  Lemma for_all_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. 
+  simple induction s; simpl; auto; unfold For_all.
+  intros; inversion H1.
+  intros x l Hrec f Hf. 
+  intros A a; intros. 
+  assert (f x = true).
+   generalize A; case (f x); auto.
+  rewrite H0 in A; simpl in A.
+  inversion_clear H; auto.
+  rewrite (Hf a x); auto.
+  Qed.
+
+  Lemma exists_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof.
+  simple induction s; simpl; auto; unfold Exists.
+  intros.
+  elim H0; intuition. 
+  inversion H2.
+  intros x l Hrec f Hf. 
+  generalize (Hf x); case (f x); simpl.
+  auto.
+  destruct 2 as [a (A1,A2)].
+  inversion_clear A1.
+  rewrite <- (H a (X.eq_sym H0)) in A2; discriminate.
+  apply Hrec; auto.
+  exists a; auto.
+  Qed.
+
+  Lemma exists_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. 
+  simple induction s; simpl; auto; unfold Exists.
+  intros; discriminate.
+  intros x l Hrec f Hf.
+  case_eq (f x); intros.
+  exists x; auto.
+  destruct (Hrec f Hf H0) as [a (A1,A2)].
+  exists a; auto.
+  Qed.
+
+  Lemma partition_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  firstorder.
+  intros x l Hrec f Hf.
+  generalize (Hrec f Hf); clear Hrec.
+  case (partition f l); intros s1 s2; simpl; intros.
+  case (f x); simpl; firstorder; inversion H0; intros; firstorder. 
+  Qed.
+   
+  Lemma partition_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  firstorder.
+  intros x l Hrec f Hf. 
+  generalize (Hrec f Hf); clear Hrec.
+  case (partition f l); intros s1 s2; simpl; intros.
+  case (f x); simpl; firstorder; inversion H0; intros; firstorder. 
+  Qed.
+
+  Lemma partition_aux_1 : 
+   forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), 
+    In x (fst (partition f s)) -> In x s.
+  Proof.
+  induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  generalize (IHs H1 f x).
+  destruct (f a); destruct (partition f s); simpl in *; auto.
+  inversion_clear H; auto.
+  Qed. 
+     
+  Lemma partition_aux_2 : 
+   forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), 
+    In x (snd (partition f s)) -> In x s.
+  Proof.
+  induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  generalize (IHs H1 f x).
+  destruct (f a); destruct (partition f s); simpl in *; auto.
+  inversion_clear H; auto.
+  Qed. 
+  
+  Lemma partition_unique_1 :
+   forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  generalize (@partition_aux_1 _ H0 f x).
+  generalize (Hrec H0 f).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+  
+  Lemma partition_unique_2 :
+   forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  generalize (@partition_aux_2 _ H0 f x).
+  generalize (Hrec H0 f).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+ 
+  Definition eq : t -> t -> Prop := Equal.
+
+  Lemma eq_refl : forall s : t, eq s s. 
+  Proof. 
+  unfold eq, Equal; intuition.
+  Qed.
+
+  Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s.
+  Proof. 
+  unfold eq, Equal; firstorder.
+  Qed.
+
+  Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+  Proof. 
+  unfold eq, Equal; firstorder.
+  Qed.
+
+  End ForNotations.
+End Raw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we 
+   need to encapsulate everything into a type of lists without redundancy. *)
+
+Module Make (X: DecidableType) <: S with Module E := X.
+
+ Module Raw := Raw X. 
+ Module E := X.
+
+ Record slist : Set :=  {this :> Raw.t; unique : NoDupA E.eq this}.
+ Definition t := slist. 
+ Definition elt := E.t.
+ 
+ Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this).
+ Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
+ Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
+ Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) (s : t) : Prop :=
+   forall x : elt, In x s -> P x.
+ Definition Exists (P : elt -> Prop) (s : t) : Prop := exists x : elt, In x s /\ P x.
+
+ Definition mem (x : elt) (s : t) : bool := Raw.mem x s.
+ Definition add (x : elt)(s : t) : t  := Build_slist (Raw.add_unique (unique s) x).
+ Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_unique (unique s) x).
+ Definition singleton (x : elt) : t := Build_slist (Raw.singleton_unique x).
+ Definition union (s s' : t) : t :=
+   Build_slist (Raw.union_unique (unique s) (unique s')). 
+ Definition inter (s s' : t) : t :=
+   Build_slist (Raw.inter_unique (unique s) (unique s')). 
+ Definition diff (s s' : t) : t :=
+   Build_slist (Raw.diff_unique (unique s) (unique s')). 
+ Definition equal (s s' : t) : bool := Raw.equal s s'. 
+ Definition subset (s s' : t) : bool := Raw.subset s s'.
+ Definition empty : t := Build_slist Raw.empty_unique.
+ Definition is_empty (s : t) : bool := Raw.is_empty s.
+ Definition elements (s : t) : list elt := Raw.elements s.
+ Definition choose (s:t) : option elt := Raw.choose s.
+ Definition fold (B : Set) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. 
+ Definition cardinal (s : t) : nat := Raw.cardinal s.
+ Definition filter (f : elt -> bool) (s : t) : t :=
+   Build_slist (Raw.filter_unique (unique s) f).
+ Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s.
+ Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s.
+ Definition partition (f : elt -> bool) (s : t) : t * t :=
+   let p := Raw.partition f s in
+   (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f),
+   Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)).
+
+ Section Spec. 
+  Variable s s' : t.
+  Variable x y : elt.
+
+  Lemma In_1 : E.eq x y -> In x s -> In y s. 
+  Proof. exact (fun H H' => Raw.In_eq H H'). Qed.
+ 
+  Lemma mem_1 : In x s -> mem x s = true.
+  Proof. exact (fun H => Raw.mem_1 H). Qed.
+  Lemma mem_2 : mem x s = true -> In x s. 
+  Proof. exact (fun H => Raw.mem_2 H). Qed.
+ 
+  Lemma equal_1 : Equal s s' -> equal s s' = true.
+  Proof. exact (Raw.equal_1 s.(unique) s'.(unique)). Qed.
+  Lemma equal_2 : equal s s' = true -> Equal s s'.
+  Proof. exact (Raw.equal_2 s.(unique) s'.(unique)). Qed.
+
+  Lemma subset_1 : Subset s s' -> subset s s' = true.
+  Proof. exact (Raw.subset_1 s.(unique) s'.(unique)). Qed.
+  Lemma subset_2 : subset s s' = true -> Subset s s'.
+  Proof. exact (Raw.subset_2 s.(unique) s'.(unique)). Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof. exact Raw.empty_1. Qed.
+
+  Lemma is_empty_1 : Empty s -> is_empty s = true. 
+  Proof. exact (fun H => Raw.is_empty_1 H). Qed.
+  Lemma is_empty_2 : is_empty s = true -> Empty s.
+  Proof. exact (fun H => Raw.is_empty_2 H). Qed.
+ 
+  Lemma add_1 : E.eq x y -> In y (add x s).
+  Proof. exact (fun H => Raw.add_1 s.(unique) H). Qed.
+  Lemma add_2 : In y s -> In y (add x s).
+  Proof. exact (fun H => Raw.add_2 s.(unique) x H). Qed.
+  Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. 
+  Proof. exact (fun H => Raw.add_3 s.(unique) H). Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+  Proof. exact (fun H => Raw.remove_1 s.(unique) H). Qed.
+  Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+  Proof. exact (fun H H' => Raw.remove_2 s.(unique) H H'). Qed.
+  Lemma remove_3 : In y (remove x s) -> In y s.
+  Proof. exact (fun H => Raw.remove_3 s.(unique) H). Qed.
+
+  Lemma singleton_1 : In y (singleton x) -> E.eq x y. 
+  Proof. exact (fun H => Raw.singleton_1 H). Qed.
+  Lemma singleton_2 : E.eq x y -> In y (singleton x). 
+  Proof. exact (fun H => Raw.singleton_2 H). Qed.
+
+  Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+  Proof. exact (fun H => Raw.union_1 s.(unique) s'.(unique) H). Qed.
+  Lemma union_2 : In x s -> In x (union s s'). 
+  Proof. exact (fun H => Raw.union_2 s.(unique) s'.(unique) H). Qed.
+  Lemma union_3 : In x s' -> In x (union s s').
+  Proof. exact (fun H => Raw.union_3 s.(unique) s'.(unique) H). Qed.
+
+  Lemma inter_1 : In x (inter s s') -> In x s.
+  Proof. exact (fun H => Raw.inter_1 s.(unique) s'.(unique) H). Qed.
+  Lemma inter_2 : In x (inter s s') -> In x s'.
+  Proof. exact (fun H => Raw.inter_2 s.(unique) s'.(unique) H). Qed.
+  Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+  Proof. exact (fun H => Raw.inter_3 s.(unique) s'.(unique) H). Qed.
+
+  Lemma diff_1 : In x (diff s s') -> In x s. 
+  Proof. exact (fun H => Raw.diff_1 s.(unique) s'.(unique) H). Qed.
+  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+  Proof. exact (fun H => Raw.diff_2 s.(unique) s'.(unique) H). Qed.
+  Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+  Proof. exact (fun H => Raw.diff_3 s.(unique) s'.(unique) H). Qed.
+ 
+  Lemma fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof. exact (Raw.fold_1 s.(unique)). Qed.
+
+  Lemma cardinal_1 : cardinal s = length (elements s).
+  Proof. exact (Raw.cardinal_1 s.(unique)). Qed.
+
+  Section Filter.
+  
+  Variable f : elt -> bool.
+
+  Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. 
+  Proof. exact (fun H => @Raw.filter_1 s x f). Qed.
+  Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Proof. exact (@Raw.filter_2 s x f). Qed.
+  Lemma filter_3 :
+      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+  Proof. exact (@Raw.filter_3 s x f). Qed.
+
+  Lemma for_all_1 :
+      compat_bool E.eq f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. exact (@Raw.for_all_1 s f). Qed.
+  Lemma for_all_2 :
+      compat_bool E.eq f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. exact (@Raw.for_all_2 s f). Qed.
+
+  Lemma exists_1 :
+      compat_bool E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof. exact (@Raw.exists_1 s f). Qed.
+  Lemma exists_2 :
+      compat_bool E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. exact (@Raw.exists_2 s f). Qed.
+
+  Lemma partition_1 :
+      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof. exact (@Raw.partition_1 s f). Qed.
+  Lemma partition_2 :
+      compat_bool E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. exact (@Raw.partition_2 s f). Qed.
+
+  End Filter.
+
+  Lemma elements_1 : In x s -> InA E.eq x (elements s).
+  Proof. exact (fun H => Raw.elements_1 H). Qed.
+  Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+  Proof. exact (fun H => Raw.elements_2 H). Qed.
+  Lemma elements_3 : NoDupA E.eq (elements s).
+  Proof. exact (Raw.elements_3 s.(unique)). Qed.
+
+  Lemma choose_1 : choose s = Some x -> In x s.
+  Proof. exact (fun H => Raw.choose_1 H). Qed.
+  Lemma choose_2 : choose s = None -> Empty s.
+  Proof. exact (fun H => Raw.choose_2 H). Qed.
+
+ End Spec.
+
+End Make.
diff --git a/theories/FSets/FSetWeakProperties.v b/theories/FSets/FSetWeakProperties.v
new file mode 100644
index 00000000..a0054d36
--- /dev/null
+++ b/theories/FSets/FSetWeakProperties.v
@@ -0,0 +1,896 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSetWeakProperties.v 8853 2006-05-23 18:17:38Z herbelin $ *)
+
+(** * Finite sets library *)
+
+(** NB: this file is a clone of [FSetProperties] for weak sets
+     and should remain so until we find a way to share the two. *)
+
+(** This functor derives additional properties from [FSetWeakInterface.S].
+    Contrary to the functor in [FSetWeakEqProperties] it uses 
+    predicates over sets instead of sets operations, i.e.
+    [In x s] instead of [mem x s=true], 
+    [Equal s s'] instead of [equal s s'=true], etc. *)
+
+Require Export FSetWeakInterface. 
+Require Import FSetWeakFacts.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Hint Unfold transpose compat_op.
+Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence.
+
+Module Properties (M: S).
+  Import M.E.
+  Import M.
+  Import Logic. (* to unmask [eq] *)  
+  Import Peano. (* to unmask [lt] *)
+  
+   (** Results about lists without duplicates *)
+
+  Module FM := Facts M.
+  Import FM.
+
+  Definition Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq x y \/ In y s.
+
+  Lemma In_dec : forall x s, {In x s} + {~ In x s}.
+  Proof.
+  intros; generalize (mem_iff s x); case (mem x s); intuition.
+  Qed.
+
+  Section BasicProperties.
+
+  (** properties of [Equal] *)
+
+  Lemma equal_refl : forall s, s[=]s.
+  Proof.
+  unfold Equal; intuition.
+  Qed.
+
+  Lemma equal_sym : forall s s', s[=]s' -> s'[=]s.
+  Proof.
+  unfold Equal; intros.
+  rewrite H; intuition.
+  Qed.
+
+  Lemma equal_trans : forall s1 s2 s3, s1[=]s2 -> s2[=]s3 -> s1[=]s3.
+  Proof.
+  unfold Equal; intros.
+  rewrite H; exact (H0 a).
+  Qed.
+
+  Variable s s' s'' s1 s2 s3 : t.
+  Variable x x' : elt.
+
+  (** properties of [Subset] *)
+  
+  Lemma subset_refl : s[<=]s. 
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
+  Proof.
+  unfold Subset, Equal; intuition.
+  Qed.
+
+  Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma subset_equal : s[=]s' -> s[<=]s'.
+  Proof.
+  unfold Subset, Equal; firstorder.
+  Qed.
+
+  Lemma subset_empty : empty[<=]s.
+  Proof.
+  unfold Subset; intros a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
+  Proof.
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
+  Proof.
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
+  Proof.
+  unfold Subset; intros H H0 a; set_iff; intuition.
+  rewrite <- H2; auto.
+  Qed.
+
+  Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+ 
+  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
+  Proof.
+  unfold Subset, Equal; split; intros; intuition; generalize (H a); intuition.
+  Qed.
+
+  (** properties of [empty] *)
+
+  Lemma empty_is_empty_1 : Empty s -> s[=]empty.
+  Proof.
+  unfold Empty, Equal; intros; generalize (H a); set_iff; tauto.
+  Qed.
+
+  Lemma empty_is_empty_2 : s[=]empty -> Empty s.
+  Proof.
+  unfold Empty, Equal; intros; generalize (H a); set_iff; tauto.
+  Qed.
+
+  (** properties of [add] *)
+
+  Lemma add_equal : In x s -> add x s [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite <- H1; auto.
+  Qed.
+ 
+  Lemma add_add : add x (add x' s) [=] add x' (add x s).
+  Proof. 
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  (** properties of [remove] *)
+
+  Lemma remove_equal : ~ In x s -> remove x s [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite H1 in H; auto.
+  Qed.
+
+  Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  (** properties of [add] and [remove] *)
+
+  Lemma add_remove : In x s -> add x (remove x s) [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; elim (eq_dec x a); intuition.
+  rewrite <- H1; auto.
+  Qed.
+
+  Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; elim (eq_dec x a); intuition.
+  rewrite H1 in H; auto.
+  Qed.
+
+  (** properties of [singleton] *)
+
+  Lemma singleton_equal_add : singleton x [=] add x empty.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  (** properties of [union] *)
+
+  Lemma union_sym : union s s' [=] union s' s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
+  Proof.
+  unfold Subset, Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma add_union_singleton : add x s [=] union (singleton x) s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_add : union (add x s) s' [=] add x (union s s').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_subset_1 : s [<=] union s s'.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma union_subset_2 : s' [<=] union s s'.
+  Proof.
+  unfold Subset; intuition.
+  Qed.
+
+  Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
+  Proof.
+  unfold Subset; intros H H0 a; set_iff; intuition.
+  Qed.
+
+  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
+  Proof. 
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
+  Proof. 
+  unfold Subset; intros H a; set_iff; intuition.
+  Qed.
+
+  Lemma empty_union_1 : Empty s -> union s s' [=] s'.
+  Proof.
+  unfold Equal, Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_union_2 : Empty s -> union s' s [=] s'.
+  Proof.
+  unfold Equal, Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). 
+  Proof.
+  intros; set_iff; intuition. 
+  Qed.  
+
+  (** properties of [inter] *)
+
+  Lemma inter_sym : inter s s' [=] inter s' s.
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
+  Proof.
+  intros; rewrite H; apply equal_refl.
+  Qed.
+
+  Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s'').
+  Proof.
+  unfold Equal; intros; set_iff; tauto.
+  Qed.
+
+  Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  rewrite <- H1; auto.
+  Qed.
+
+  Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  destruct H; rewrite H0; auto.
+  Qed.
+
+  Lemma empty_inter_1 : Empty s -> Empty (inter s s').
+  Proof.
+  unfold Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
+  Proof.
+  unfold Empty; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma inter_subset_1 : inter s s' [<=] s.
+  Proof.
+  unfold Subset; intro a; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_2 : inter s s' [<=] s'.
+  Proof.
+  unfold Subset; intro a; set_iff; tauto.
+  Qed.
+
+  Lemma inter_subset_3 :
+   s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
+  Proof.
+  unfold Subset; intros H H' a; set_iff; intuition.
+  Qed.
+
+  (** properties of [diff] *)
+
+  Lemma empty_diff_1 : Empty s -> Empty (diff s s'). 
+  Proof.
+  unfold Empty, Equal; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
+  Proof.
+  unfold Empty, Equal; intros; set_iff; firstorder.
+  Qed.
+
+  Lemma diff_subset : diff s s' [<=] s.
+  Proof.
+  unfold Subset; intros a; set_iff; tauto.
+  Qed.
+
+  Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
+  Proof.
+  unfold Subset, Equal; intros; set_iff; intuition; absurd (In a empty); auto.
+  Qed.
+
+  Lemma remove_diff_singleton :
+   remove x s [=] diff s (singleton x).
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  Qed.
+
+  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. 
+  Proof.
+  unfold Equal; intros; set_iff; intuition; absurd (In a empty); auto.
+  Qed.
+
+  Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
+  Proof.
+  unfold Equal; intros; set_iff; intuition.
+  elim (In_dec a s'); auto.
+  Qed.
+
+  (** properties of [Add] *)
+
+  Lemma Add_add : Add x s (add x s).
+  Proof.
+   unfold Add; intros; set_iff; intuition.
+  Qed.
+
+  Lemma Add_remove : In x s -> Add x (remove x s) s. 
+  Proof. 
+    unfold Add; intros; set_iff; intuition.
+    elim (eq_dec x y); auto.
+    rewrite <- H1; auto.
+  Qed.
+
+  Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
+  Proof. 
+  unfold Add; intros; set_iff; rewrite H; tauto.
+  Qed.
+
+  Lemma inter_Add :
+   In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
+  Proof. 
+  unfold Add; intros; set_iff; rewrite H0; intuition.
+  rewrite <- H2; auto.
+  Qed.  
+
+  Lemma union_Equal :
+   In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
+  Proof. 
+  unfold Add, Equal; intros; set_iff; rewrite H0; intuition. 
+  rewrite <- H1; auto.
+  Qed.  
+
+  Lemma inter_Add_2 :
+   ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
+  Proof.
+  unfold Add, Equal; intros; set_iff; rewrite H0; intuition.
+  destruct H; rewrite H1; auto.
+  Qed.
+
+  End BasicProperties.
+
+  Hint Immediate equal_sym: set.
+  Hint Resolve equal_refl equal_trans : set.
+
+  Hint Immediate add_remove remove_add union_sym inter_sym: set.
+  Hint Resolve subset_refl subset_equal subset_antisym 
+    subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 
+    subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal
+    remove_equal singleton_equal_add union_subset_equal union_equal_1 
+    union_equal_2 union_assoc add_union_singleton union_add union_subset_1 
+    union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2
+    inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2
+    empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 
+    empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union 
+    inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal 
+    remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
+    Equal_remove add_add : set.
+
+  (** * Alternative (weaker) specifications for [fold] *)
+
+  Section Old_Spec_Now_Properties. 
+
+  Notation NoDup := (NoDupA E.eq).
+
+  (** When [FSets] was first designed, the order in which Ocaml's [Set.fold]
+        takes the set elements was unspecified. This specification reflects this fact: 
+  *)
+
+  Lemma fold_0 : 
+      forall s (A : Set) (i : A) (f : elt -> A -> A),
+      exists l : list elt,
+        NoDup l /\
+        (forall x : elt, In x s <-> InA E.eq x l) /\
+        fold f s i = fold_right f i l.
+  Proof.
+  intros; exists (rev (elements s)); split.
+  apply NoDupA_rev; auto.
+  exact E.eq_trans.
+  split; intros.
+  rewrite elements_iff; do 2 rewrite InA_alt.
+  split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition.
+  rewrite fold_left_rev_right.
+  apply fold_1.
+  Qed.
+
+  (** An alternate (and previous) specification for [fold] was based on 
+      the recursive structure of a set. It is now lemmas [fold_1] and 
+      [fold_2]. *)
+
+  Lemma fold_1 :
+   forall s (A : Set) (eqA : A -> A -> Prop) 
+     (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
+   Empty s -> eqA (fold f s i) i.
+  Proof.
+  unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))).
+  rewrite H3; clear H3.
+  generalize H H2; clear H H2; case l; simpl; intros.
+  refl_st.
+  elim (H e).
+  elim (H2 e); intuition. 
+  Qed.
+
+  Lemma fold_2 :
+   forall s s' x (A : Set) (eqA : A -> A -> Prop)
+     (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A),
+   compat_op E.eq eqA f ->
+   transpose eqA f ->
+   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); 
+    destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
+  rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
+  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto.
+  eauto.
+  exact eq_dec.
+  rewrite <- Hl1; auto.
+  intros; rewrite <- Hl1; rewrite <- Hl'1; auto.
+  Qed.
+
+  (** Similar specifications for [cardinal]. *)
+
+  Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0.
+  Proof.
+  intros; rewrite cardinal_1; rewrite M.fold_1.
+  symmetry; apply fold_left_length; auto.
+  Qed.
+
+  Lemma cardinal_0 :
+     forall s, exists l : list elt,
+        NoDupA E.eq l /\
+        (forall x : elt, In x s <-> InA E.eq x l) /\ 
+        cardinal s = length l.
+  Proof. 
+  intros; exists (elements s); intuition; apply cardinal_1.
+  Qed.
+
+  Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0.
+  Proof.
+  intros; rewrite cardinal_fold; apply fold_1; auto.
+  Qed.
+
+  Lemma cardinal_2 :
+    forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s).
+  Proof.
+  intros; do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x).
+  apply fold_2; auto.
+  Qed.
+
+  End Old_Spec_Now_Properties.
+
+  (** * Induction principle over sets *)
+
+  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. 
+  Proof. 
+    intros s; rewrite M.cardinal_1; intros H a; red.
+    rewrite elements_iff.
+    destruct (elements s); simpl in *; discriminate || inversion 1.
+  Qed.
+  Hint Resolve cardinal_inv_1.
+ 
+  Lemma cardinal_inv_2 :
+   forall s n, cardinal s = S n -> { x : elt | In x s }.
+  Proof. 
+    intros; rewrite M.cardinal_1 in H.
+    generalize (elements_2 (s:=s)).
+    destruct (elements s); try discriminate. 
+    exists e; auto.
+  Qed.
+
+  Lemma Equal_cardinal_aux :
+   forall n s s', cardinal s = n -> s[=]s' -> cardinal s = cardinal s'.
+  Proof.
+     simple induction n; intros.
+     rewrite H; symmetry .
+     apply cardinal_1.
+     rewrite <- H0; auto.
+     destruct (cardinal_inv_2 H0) as (x,H2).
+     revert H0.
+     rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set.
+     rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); auto with set.
+     rewrite H1 in H2; auto with set.
+  Qed.
+
+  Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
+  Proof. 
+    intros; apply Equal_cardinal_aux with (cardinal s); auto.
+  Qed.
+
+  Add Morphism cardinal : cardinal_m.
+  Proof.
+  exact Equal_cardinal.
+  Qed.
+
+  Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal.
+
+  Lemma cardinal_induction :
+   forall P : t -> Type,
+   (forall s, Empty s -> P s) ->
+   (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') ->
+   forall n s, cardinal s = n -> P s.
+  Proof.
+  simple induction n; intros; auto.
+  destruct (cardinal_inv_2 H) as (x,H0). 
+  apply X0 with (remove x s) x; auto.
+  apply X1; auto.
+  rewrite (cardinal_2 (x:=x)(s:=remove x s)(s':=s)) in H; auto.
+  Qed.
+
+  Lemma set_induction :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s' : t, P s -> forall x : elt, ~In x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; apply cardinal_induction with (cardinal s); auto.
+  Qed.  
+
+  (** Other properties of [fold]. *)
+
+  Section Fold. 
+  Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
+  Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
+
+  Section Fold_1. 
+  Variable i i':A.
+
+  Lemma fold_empty : eqA (fold f empty i) i.
+  Proof. 
+  apply fold_1; auto.
+  Qed.
+
+  Lemma fold_equal : 
+   forall s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof. 
+  intros s; pattern s; apply set_induction; clear s; intros.
+  trans_st i.
+  apply fold_1; auto.
+  sym_st; apply fold_1; auto.
+  rewrite <- H0; auto.
+  trans_st (f x (fold f s i)).
+  apply fold_2 with (eqA := eqA); auto.
+  sym_st; apply fold_2 with (eqA := eqA); auto.
+  unfold Add in *; intros.
+  rewrite <- H2; auto.
+  Qed.
+   
+  Lemma fold_add : forall s x, ~In x s -> 
+   eqA (fold f (add x s) i) (f x (fold f s i)).
+  Proof. 
+  intros; apply fold_2 with (eqA := eqA); auto.
+  Qed.
+
+  Lemma add_fold : forall s x, In x s -> 
+   eqA (fold f (add x s) i) (fold f s i).
+  Proof.
+  intros; apply fold_equal; auto with set.
+  Qed.
+
+  Lemma remove_fold_1: forall s x, In x s -> 
+   eqA (f x (fold f (remove x s) i)) (fold f s i).
+  Proof.
+  intros.
+  sym_st.
+  apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma remove_fold_2: forall s x, ~In x s -> 
+   eqA (fold f (remove x s) i) (fold f s i).
+  Proof.
+  intros.
+  apply fold_equal; auto with set.
+  Qed.
+
+  Lemma fold_commutes : forall s x, 
+   eqA (fold f s (f x i)) (f x (fold f s i)).
+  Proof.
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st (f x i).
+  apply fold_1; auto.
+  sym_st.
+  apply Comp; auto.
+  apply fold_1; auto.
+  trans_st (f x0 (fold f s (f x i))).
+  apply fold_2 with (eqA:=eqA); auto.
+  trans_st (f x0 (f x (fold f s i))).
+  trans_st (f x (f x0 (fold f s i))).
+  apply Comp; auto.
+  sym_st.
+  apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma fold_init : forall s, eqA i i' -> 
+   eqA (fold f s i) (fold f s i').
+  Proof. 
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st i.
+  apply fold_1; auto.
+  trans_st i'.
+  sym_st; apply fold_1; auto.
+  trans_st (f x (fold f s i)).
+  apply fold_2 with (eqA:=eqA); auto.
+  trans_st (f x (fold f s i')).
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  End Fold_1.
+  Section Fold_2.
+  Variable i:A.
+
+  Lemma fold_union_inter : forall s s',
+   eqA (fold f (union s s') (fold f (inter s s') i))
+       (fold f s (fold f s' i)).
+  Proof.
+  intros; pattern s; apply set_induction; clear s; intros.
+  trans_st (fold f s' (fold f (inter s s') i)).
+  apply fold_equal; auto with set.
+  trans_st (fold f s' i).
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  sym_st; apply fold_1; auto.
+  rename s'0 into s''.
+  destruct (In_dec x s').
+  (* In x s' *)   
+  trans_st (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
+  apply fold_init; auto.
+  apply fold_2 with (eqA:=eqA); auto with set.
+  rewrite inter_iff; intuition.
+  trans_st (f x (fold f s (fold f s' i))).
+  trans_st (fold f (union s s') (f x (fold f (inter s s') i))).
+  apply fold_equal; auto.
+  apply equal_sym; apply union_Equal with x; auto with set.
+  trans_st (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply fold_commutes; auto.
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  (* ~(In x s') *)
+  trans_st (f x (fold f (union s s') (fold f (inter s'' s') i))).
+  apply fold_2 with (eqA:=eqA); auto with set.
+  trans_st (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply Comp;auto.
+  apply fold_init;auto.
+  apply fold_equal;auto.
+  apply equal_sym; apply inter_Add_2 with x; auto with set.
+  trans_st (f x (fold f s (fold f s' i))).
+  sym_st; apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  End Fold_2.
+  Section Fold_3.
+  Variable i:A.
+
+  Lemma fold_diff_inter : forall s s', 
+   eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
+  Proof.
+  intros.
+  trans_st (fold f (union (diff s s') (inter s s')) 
+              (fold f (inter (diff s s') (inter s s')) i)).
+  sym_st; apply fold_union_inter; auto.
+  trans_st (fold f s (fold f (inter (diff s s') (inter s s')) i)).
+  apply fold_equal; auto with set.
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  Qed.
+
+  Lemma fold_union: forall s s', (forall x, ~In x s\/~In x s') ->
+   eqA (fold f (union s s') i) (fold f s (fold f s' i)).
+  Proof.
+  intros.
+  trans_st (fold f (union s s') (fold f (inter s s') i)).
+  apply fold_init; auto.
+  sym_st; apply fold_1; auto with set.
+  unfold Empty; intro a; generalize (H a); set_iff; tauto.
+  apply fold_union_inter; auto.
+  Qed.
+
+  End Fold_3.
+  End Fold.
+
+  Lemma fold_plus :
+   forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
+  Proof.
+  assert (st := gen_st nat).
+  assert (fe : compat_op E.eq (@eq _) (fun _ => S)) by (unfold compat_op; auto). 
+  assert (fp : transpose (@eq _) (fun _:elt => S)) by (unfold transpose; auto).
+  intros s p; pattern s; apply set_induction; clear s; intros.
+  rewrite (fold_1 st p (fun _ => S) H).
+  rewrite (fold_1 st 0 (fun _ => S) H); trivial.
+  assert (forall p s', Add x s s' -> fold (fun _ => S) s' p = S (fold (fun _ => S) s p)).
+   change S with ((fun _ => S) x).  
+   intros; apply fold_2; auto.
+  rewrite H2; auto.
+  rewrite (H2 0); auto.
+  rewrite H.
+  simpl; auto.
+  Qed.
+
+  (** properties of [cardinal] *)
+
+  Lemma empty_cardinal : cardinal empty = 0.
+  Proof.
+  rewrite cardinal_fold; apply fold_1; auto.
+  Qed.
+
+  Hint Immediate empty_cardinal cardinal_1 : set.
+
+  Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1.
+  Proof.
+  intros.
+  rewrite (singleton_equal_add x).
+  replace 0 with (cardinal empty); auto with set.
+  apply cardinal_2 with x; auto with set.
+  Qed.
+
+  Hint Resolve singleton_cardinal: set.
+
+  Lemma diff_inter_cardinal :
+   forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s .
+  Proof.
+  intros; do 3 rewrite cardinal_fold.
+  rewrite <- fold_plus.
+  apply fold_diff_inter with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma union_cardinal: 
+   forall s s', (forall x, ~In x s\/~In x s') -> 
+   cardinal (union s s')=cardinal s+cardinal s'.
+  Proof.
+  intros; do 3 rewrite cardinal_fold.
+  rewrite <- fold_plus.
+  apply fold_union; auto.
+  Qed.
+
+  Lemma subset_cardinal : 
+   forall s s', s[<=]s' -> cardinal s <= cardinal s' .
+  Proof.
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H); auto with arith.
+  Qed.
+
+  Lemma subset_cardinal_lt : 
+   forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
+  Proof. 
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H).
+  generalize (@cardinal_inv_1 (diff s' s)).
+  destruct (cardinal (diff s' s)).
+  intro H2; destruct (H2 (refl_equal _) x).
+  set_iff; auto.
+  intros _.
+  change (0 + cardinal s < S n + cardinal s).
+  apply Plus.plus_lt_le_compat; auto with arith.
+  Qed. 
+
+  Theorem union_inter_cardinal :
+   forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
+  Proof.
+  intros.
+  do 4 rewrite cardinal_fold.
+  do 2 rewrite <- fold_plus.
+  apply fold_union_inter with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma union_cardinal_inter : 
+   forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
+  Proof.
+  intros.
+  rewrite <- union_inter_cardinal.
+  rewrite Plus.plus_comm.
+  auto with arith.
+  Qed.
+
+  Lemma union_cardinal_le : 
+   forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
+  Proof.
+   intros; generalize (union_inter_cardinal s s').
+   intros; rewrite <- H; auto with arith.
+  Qed.
+
+  Lemma add_cardinal_1 : 
+   forall s x, In x s -> cardinal (add x s) = cardinal s.
+  Proof.
+  auto with set.  
+  Qed.
+
+  Lemma add_cardinal_2 :
+   forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x);
+   apply fold_add with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma remove_cardinal_1 :
+   forall s x, In x s -> S (cardinal (remove x s)) = cardinal s.
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ =>S) x).
+  apply remove_fold_1 with (eqA:=@eq nat); auto.
+  Qed.
+
+  Lemma remove_cardinal_2 : 
+   forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
+  Proof. 
+  auto with set.
+  Qed.
+
+  Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2.
+
+End Properties.
diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v
new file mode 100644
index 00000000..b0402db6
--- /dev/null
+++ b/theories/FSets/FSets.v
@@ -0,0 +1,18 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: FSets.v 8897 2006-06-05 21:04:10Z letouzey $ *)
+
+Require Export OrderedType.
+Require Export OrderedTypeEx.
+Require Export OrderedTypeAlt.
+Require Export FSetInterface.
+Require Export FSetBridge.
+Require Export FSetProperties.
+Require Export FSetEqProperties.
+Require Export FSetList.
diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v
new file mode 100644
index 00000000..f966cd4d
--- /dev/null
+++ b/theories/FSets/OrderedType.v
@@ -0,0 +1,570 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: OrderedType.v 8834 2006-05-20 00:41:35Z letouzey $ *)
+
+Require Export SetoidList.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(* TODO concernant la tactique order: 
+   * propagate_lt n'est sans doute pas complet
+   * un propagate_le
+   * exploiter les hypotheses negatives restant a la fin
+   * faire que ca marche meme quand une hypothese depend d'un eq ou lt.
+*) 
+
+(** * Ordered types *)
+
+Inductive Compare (X : Set) (lt eq : X -> X -> Prop) (x y : X) : Set :=
+  | LT : lt x y -> Compare lt eq x y
+  | EQ : eq x y -> Compare lt eq x y
+  | GT : lt y x -> Compare lt eq x y.
+
+Module Type OrderedType.
+
+  Parameter t : Set.
+
+  Parameter eq : t -> t -> Prop.
+  Parameter lt : t -> t -> Prop.
+
+  Axiom eq_refl : forall x : t, eq x x.
+  Axiom eq_sym : forall x y : t, eq x y -> eq y x.
+  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
+ 
+  Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+
+  Parameter compare : forall x y : t, Compare lt eq x y.
+
+  Hint Immediate eq_sym.
+  Hint Resolve eq_refl eq_trans lt_not_eq lt_trans.
+
+End OrderedType.
+
+(** * Ordered types properties *)
+
+(** Additional properties that can be derived from signature
+    [OrderedType]. *)
+
+Module OrderedTypeFacts (O: OrderedType). 
+  Import O.
+
+  Lemma lt_antirefl : forall x, ~ lt x x.
+  Proof.
+   intros; intro; absurd (eq x x); auto. 
+  Qed.
+
+  Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z.
+  Proof. 
+   intros; destruct (compare x z); auto.
+   elim (lt_not_eq H); apply eq_trans with z; auto.
+   elim (lt_not_eq (lt_trans l H)); auto.
+  Qed. 
+
+  Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z.    
+  Proof.
+   intros; destruct (compare x z); auto.
+   elim (lt_not_eq H0); apply eq_trans with x; auto.
+   elim (lt_not_eq (lt_trans H0 l)); auto.
+  Qed. 
+
+  Lemma le_eq : forall x y z, ~lt x y -> eq y z -> ~lt x z.
+  Proof.
+   intros; intro; destruct H; apply lt_eq with z; auto.
+  Qed.
+
+  Lemma eq_le : forall x y z, eq x y -> ~lt y z -> ~lt x z.
+  Proof.
+   intros; intro; destruct H0; apply eq_lt with x; auto.
+  Qed.
+
+  Lemma neq_eq : forall x y z, ~eq x y -> eq y z -> ~eq x z.
+  Proof.
+   intros; intro; destruct H; apply eq_trans with z; auto.
+  Qed.
+
+  Lemma eq_neq : forall x y z, eq x y -> ~eq y z -> ~eq x z.
+  Proof.
+   intros; intro; destruct H0; apply eq_trans with x; auto.
+  Qed.
+
+  Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq.
+
+  Lemma le_lt_trans : forall x y z, ~lt y x -> lt y z -> lt x z.
+  Proof.
+   intros; destruct (compare y x); auto.
+   elim (H l).
+   apply eq_lt with y; auto.
+   apply lt_trans with y; auto.
+  Qed.
+
+  Lemma lt_le_trans : forall x y z, lt x y -> ~lt z y -> lt x z.
+  Proof.
+   intros; destruct (compare z y); auto.
+   elim (H0 l).
+   apply lt_eq with y; auto.
+   apply lt_trans with y; auto.
+  Qed.
+
+  Lemma le_neq : forall x y, ~lt x y -> ~eq x y -> lt y x.
+  Proof. 
+   intros; destruct (compare x y); intuition.
+  Qed.
+
+  Lemma neq_sym : forall x y, ~eq x y -> ~eq y x.
+  Proof. 
+   intuition.
+  Qed.
+
+Ltac abstraction := match goal with 
+ (* First, some obvious simplifications *)
+ | H : False |- _ => elim H
+ | H : lt ?x ?x |- _ => elim (lt_antirefl H)
+ | H : ~eq ?x ?x |- _ => elim (H (eq_refl x))
+ | H : eq ?x ?x |- _ => clear H; abstraction
+ | H : ~lt ?x ?x |- _ => clear H; abstraction
+ | |- eq ?x ?x => exact (eq_refl x)
+ | |- lt ?x ?x => elimtype False; abstraction
+ | |- ~ _ => intro; abstraction
+ | H1: ~lt ?x ?y, H2: ~eq ?x ?y |- _ => 
+     generalize (le_neq H1 H2); clear H1 H2; intro; abstraction
+ | H1: ~lt ?x ?y, H2: ~eq ?y ?x |- _ => 
+     generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; abstraction
+ (* Then, we generalize all interesting facts *)
+ | H : lt ?x ?y |- _ => revert H; abstraction
+ | H : ~lt ?x ?y |- _ => revert H; abstraction  
+ | H : ~eq ?x ?y |- _ =>  revert H; abstraction
+ | H : eq ?x ?y |- _ =>  revert H; abstraction
+ | _ => idtac
+end.
+
+Ltac do_eq a b EQ := match goal with 
+ | |- lt ?x ?y -> _ => let H := fresh "H" in 
+     (intro H; 
+      (generalize (eq_lt (eq_sym EQ) H); clear H; intro H) ||
+      (generalize (lt_eq H EQ); clear H; intro H) || 
+      idtac); 
+      do_eq a b EQ
+ | |- ~lt ?x ?y -> _ => let H := fresh "H" in 
+     (intro H; 
+      (generalize (eq_le (eq_sym EQ) H); clear H; intro H) ||
+      (generalize (le_eq H EQ); clear H; intro H) || 
+      idtac); 
+      do_eq a b EQ 
+ | |- eq ?x ?y -> _ => let H := fresh "H" in 
+     (intro H; 
+      (generalize (eq_trans (eq_sym EQ) H); clear H; intro H) ||
+      (generalize (eq_trans H EQ); clear H; intro H) || 
+      idtac); 
+      do_eq a b EQ 
+ | |- ~eq ?x ?y -> _ => let H := fresh "H" in 
+     (intro H; 
+      (generalize (eq_neq (eq_sym EQ) H); clear H; intro H) ||
+      (generalize (neq_eq H EQ); clear H; intro H) || 
+      idtac); 
+      do_eq a b EQ 
+ | |- lt a ?y => apply eq_lt with b; [exact EQ|]
+ | |- lt ?y a => apply lt_eq with b; [|exact (eq_sym EQ)]
+ | |- eq a ?y => apply eq_trans with b; [exact EQ|]
+ | |- eq ?y a => apply eq_trans with b; [|exact (eq_sym EQ)]
+ | _ => idtac
+ end.
+
+Ltac propagate_eq := abstraction; clear; match goal with 
+ (* the abstraction tactic leaves equality facts in head position...*)
+ | |- eq ?a ?b -> _ => 
+     let EQ := fresh "EQ" in (intro EQ; do_eq a b EQ; clear EQ); 
+     propagate_eq 
+ | _ => idtac
+end.
+
+Ltac do_lt x y LT := match goal with 
+ (* LT *)
+ | |- lt x y -> _ => intros _; do_lt x y LT
+ | |- lt y ?z -> _ => let H := fresh "H" in 
+     (intro H; generalize (lt_trans LT H); intro); do_lt x y LT
+ | |- lt ?z x -> _ => let H := fresh "H" in 
+     (intro H; generalize (lt_trans H LT); intro); do_lt x y LT
+ | |- lt _ _ -> _ => intro; do_lt x y LT
+ (* Ge *)
+ | |- ~lt y x -> _ => intros _; do_lt x y LT
+ | |- ~lt x ?z -> _ => let H := fresh "H" in 
+     (intro H; generalize (le_lt_trans H LT); intro); do_lt x y LT
+ | |- ~lt ?z y -> _ => let H := fresh "H" in 
+     (intro H; generalize (lt_le_trans LT H); intro); do_lt x y LT
+ | |- ~lt _ _ -> _ => intro; do_lt x y LT
+ | _ => idtac
+ end.
+
+Definition hide_lt := lt.
+
+Ltac propagate_lt := abstraction; match goal with 
+ (* when no [=] remains, the abstraction tactic leaves [<] facts first. *)
+ | |- lt ?x ?y -> _ => 
+     let LT := fresh "LT" in (intro LT; do_lt x y LT; 
+     change (hide_lt x y) in LT); 
+     propagate_lt 
+ | _ => unfold hide_lt in *
+end.
+
+Ltac order := 
+ intros; 
+ propagate_eq; 
+ propagate_lt; 
+ auto; 
+ propagate_lt; 
+ eauto.
+
+Ltac false_order := elimtype False; order.
+
+  Lemma gt_not_eq : forall x y, lt y x -> ~ eq x y.
+  Proof.
+    order.
+  Qed.	
+ 
+  Lemma eq_not_lt : forall x y : t, eq x y -> ~ lt x y.
+  Proof. 
+    order.
+  Qed.
+
+  Hint Resolve gt_not_eq eq_not_lt.
+
+  Lemma eq_not_gt : forall x y : t, eq x y -> ~ lt y x.
+  Proof. 
+   order.
+  Qed.
+
+  Lemma lt_not_gt : forall x y : t, lt x y -> ~ lt y x.
+  Proof.  
+   order.
+  Qed.
+
+  Hint Resolve eq_not_gt lt_antirefl lt_not_gt.
+
+  Lemma elim_compare_eq :
+   forall x y : t,
+   eq x y -> exists H : eq x y, compare x y = EQ _ H.
+  Proof. 
+   intros; case (compare x y); intros H'; try solve [false_order].
+   exists H'; auto.   
+  Qed.
+
+  Lemma elim_compare_lt :
+   forall x y : t,
+   lt x y -> exists H : lt x y, compare x y = LT _ H.
+  Proof. 
+   intros; case (compare x y); intros H'; try solve [false_order].
+   exists H'; auto. 
+  Qed.
+
+  Lemma elim_compare_gt :
+   forall x y : t,
+   lt y x -> exists H : lt y x, compare x y = GT _ H.
+  Proof. 
+   intros; case (compare x y); intros H'; try solve [false_order].
+   exists H'; auto.   
+  Qed.
+
+  Ltac elim_comp := 
+    match goal with 
+      | |- ?e => match e with 
+           | context ctx [ compare ?a ?b ] =>
+                let H := fresh in 
+                (destruct (compare a b) as [H|H|H]; 
+                 try solve [ intros; false_order])
+         end
+    end.
+
+  Ltac elim_comp_eq x y :=
+    elim (elim_compare_eq (x:=x) (y:=y));
+     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. 
+
+  Ltac elim_comp_lt x y :=
+    elim (elim_compare_lt (x:=x) (y:=y));
+     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. 
+
+  Ltac elim_comp_gt x y :=
+    elim (elim_compare_gt (x:=x) (y:=y));
+     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ].
+
+  Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
+  Proof.
+   intros; elim (compare x y); [ right | left | right ]; auto.
+  Qed.
+ 
+  Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}.
+  Proof.
+   intros; elim (compare x y); [ left | right | right ]; auto.
+  Qed.
+
+  Definition eqb x y : bool := if eq_dec x y then true else false.
+
+  Lemma eqb_alt : 
+    forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. 
+  Proof.
+  unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto.
+  Qed.
+
+(* Specialization of resuts about lists modulo. *)
+
+Section ForNotations.
+
+Notation In:=(InA eq).
+Notation Inf:=(lelistA lt).
+Notation Sort:=(sort lt).
+Notation NoDup:=(NoDupA eq).
+
+Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+Proof. exact (InA_eqA eq_sym eq_trans). Qed.
+
+Lemma ListIn_In : forall l x, List.In x l -> In x l.
+Proof. exact (In_InA eq_refl). Qed.
+
+Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_ltA lt_trans). Qed.
+ 
+Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_eqA eq_lt). Qed.
+
+Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
+Proof. exact (SortA_InfA_InA eq_refl eq_sym lt_trans lt_eq eq_lt). Qed.
+  
+Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l.
+Proof. exact (@In_InfA t lt). Qed.
+
+Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l.
+Proof. exact (InA_InfA eq_refl (ltA:=lt)). Qed.
+
+Lemma Inf_alt : 
+ forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)).
+Proof. exact (InfA_alt eq_refl eq_sym lt_trans lt_eq eq_lt). Qed.
+
+Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
+Proof. exact (SortA_NoDupA eq_refl eq_sym lt_trans lt_not_eq lt_eq eq_lt) . Qed.
+
+End ForNotations.
+
+Hint Resolve ListIn_In Sort_NoDup Inf_lt. 
+Hint Immediate In_eq Inf_lt. 
+
+End OrderedTypeFacts.
+
+Module KeyOrderedType(O:OrderedType).
+ Import O.
+ Module MO:=OrderedTypeFacts(O).
+ Import MO.
+
+ Section Elt.
+ Variable elt : Set.
+ Notation key:=t.
+
+  Definition eqk (p p':key*elt) := eq (fst p) (fst p').
+  Definition eqke (p p':key*elt) := 
+          eq (fst p) (fst p') /\ (snd p) = (snd p').
+  Definition ltk (p p':key*elt) := lt (fst p) (fst p').
+
+  Hint Unfold eqk eqke ltk.
+  Hint Extern 2 (eqke ?a ?b) => split.
+
+   (* eqke is stricter than eqk *)
+ 
+   Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
+   Proof.
+     unfold eqk, eqke; intuition.
+   Qed.
+
+  (* ltk ignore the second components *)
+
+   Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e').
+   Proof. auto. Qed.
+
+   Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x.
+   Proof. auto. Qed.
+   Hint Immediate ltk_right_r ltk_right_l.
+
+  (* eqk, eqke are equalities, ltk is a strict order *)
+ 
+  Lemma eqk_refl : forall e, eqk e e.
+  Proof. auto. Qed.
+
+  Lemma eqke_refl : forall e, eqke e e.
+  Proof. auto. Qed.
+
+  Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e.
+  Proof. auto. Qed.
+
+  Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e.
+  Proof. unfold eqke; intuition. Qed.
+
+  Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''.
+  Proof. eauto. Qed.
+
+  Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''.
+  Proof.
+    unfold eqke; intuition; [ eauto | congruence ].
+  Qed.
+
+  Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''.
+  Proof. eauto. Qed.
+
+  Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
+  Proof. unfold eqk, ltk; auto. Qed.  
+
+  Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
+  Proof.
+    unfold eqke, ltk; intuition; simpl in *; subst.
+    exact (lt_not_eq H H1).
+  Qed.
+
+  Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
+  Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
+  Hint Immediate eqk_sym eqke_sym.
+
+  (* Additionnal facts *)
+
+  Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'.
+   Proof.
+     unfold eqk, ltk; simpl; auto.
+   Qed.
+
+  Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''.
+  Proof. eauto. Qed.
+
+  Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''.
+  Proof.
+      intros (k,e) (k',e') (k'',e'').
+      unfold ltk, eqk; simpl; eauto.
+  Qed.
+  Hint Resolve eqk_not_ltk. 
+  Hint Immediate ltk_eqk eqk_ltk.
+
+  Lemma InA_eqke_eqk : 
+     forall x m, InA eqke x m -> InA eqk x m.
+  Proof.
+    unfold eqke; induction 1; intuition.
+  Qed.
+  Hint Resolve InA_eqke_eqk.
+
+  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
+  Definition In k m := exists e:elt, MapsTo k e m.
+  Notation Sort := (sort ltk).
+  Notation Inf := (lelistA ltk).
+
+  Hint Unfold MapsTo In.
+
+  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
+
+  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
+  Proof.
+  firstorder.
+  exists x; auto.
+  induction H.
+  destruct y.
+  exists e; auto.
+  destruct IHInA as [e H0].
+  exists e; auto.
+  Qed.
+
+  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
+  Proof.
+  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto.
+  Qed.
+
+  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+  Proof.
+  destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
+  Qed. 
+
+  Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
+  Proof. exact (InfA_eqA eqk_ltk). Qed.
+
+  Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
+  Proof. exact (InfA_ltA ltk_trans). Qed.
+
+  Hint Immediate Inf_eq.
+  Hint Resolve Inf_lt.
+
+  Lemma Sort_Inf_In : 
+      forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
+  Proof. 
+  exact (SortA_InfA_InA eqk_refl eqk_sym ltk_trans ltk_eqk eqk_ltk).
+  Qed.
+
+  Lemma Sort_Inf_NotIn : 
+      forall l k e, Sort l -> Inf (k,e) l ->  ~In k l.
+  Proof.
+    intros; red; intros.
+    destruct H1 as [e' H2].
+    elim (@ltk_not_eqk (k,e) (k,e')).
+    eapply Sort_Inf_In; eauto.
+    red; simpl; auto.
+  Qed.
+
+  Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l.
+  Proof. 
+  exact (SortA_NoDupA eqk_refl eqk_sym ltk_trans ltk_not_eqk ltk_eqk eqk_ltk).
+  Qed.
+
+  Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
+  Proof.
+   inversion 1; intros; eapply Sort_Inf_In; eauto.
+  Qed.
+
+  Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) ->
+      ltk e e' \/ eqk e e'.
+  Proof.
+    inversion_clear 2; auto.
+    left; apply Sort_In_cons_1 with l; auto.
+  Qed.
+
+  Lemma Sort_In_cons_3 : 
+    forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k.
+  Proof.
+    inversion_clear 1; red; intros.
+    destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)).
+  Qed.
+
+  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
+  Proof.
+    inversion 1.
+    inversion_clear H0; eauto.
+    destruct H1; simpl in *; intuition.
+  Qed.      
+
+  Lemma In_inv_2 : forall k k' e e' l, 
+      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
+  Proof.  
+   inversion_clear 1; compute in H0; intuition.
+  Qed.
+
+  Lemma In_inv_3 : forall x x' l, 
+      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+  Proof.
+   inversion_clear 1; compute in H0; intuition.
+  Qed.
+
+ End Elt.
+
+ Hint Unfold eqk eqke ltk.
+ Hint Extern 2 (eqke ?a ?b) => split.
+ Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
+ Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
+ Hint Immediate eqk_sym eqke_sym.
+ Hint Resolve eqk_not_ltk. 
+ Hint Immediate ltk_eqk eqk_ltk.
+ Hint Resolve InA_eqke_eqk.
+ Hint Unfold MapsTo In.
+ Hint Immediate Inf_eq.
+ Hint Resolve Inf_lt.
+ Hint Resolve Sort_Inf_NotIn.
+ Hint Resolve In_inv_2 In_inv_3.
+
+End KeyOrderedType.
+
+
diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v
new file mode 100644
index 00000000..9bcfbfc7
--- /dev/null
+++ b/theories/FSets/OrderedTypeAlt.v
@@ -0,0 +1,129 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: OrderedTypeAlt.v 8773 2006-04-29 14:31:32Z letouzey $ *)
+
+Require Import OrderedType.
+
+(** * An alternative (but equivalent) presentation for an Ordered Type inferface. *)
+
+(** NB: [comparison], defined in [theories/Init/datatypes.v] is [Eq|Lt|Gt]
+whereas [compare], defined in [theories/FSets/OrderedType.v] is [EQ _ | LT _ | GT _ ] 
+*)
+
+Module Type OrderedTypeAlt.
+
+ Parameter t : Set.
+ 
+ Parameter compare : t -> t -> comparison.
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Parameter compare_sym : 
+   forall x y, (y?=x) = CompOpp (x?=y).
+ Parameter compare_trans : 
+   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+
+End OrderedTypeAlt. 
+
+(** From this new presentation to the original one. *)
+
+Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType.
+ Import O.
+
+ Definition t := t.
+
+ Definition eq x y := (x?=y) = Eq.
+ Definition lt x y := (x?=y) = Lt.
+
+ Lemma eq_refl : forall x, eq x x.
+ Proof.
+ intro x.
+ unfold eq.
+ assert (H:=compare_sym x x).
+ destruct (x ?= x); simpl in *; try discriminate; auto.
+ Qed.
+
+ Lemma eq_sym : forall x y, eq x y -> eq y x.
+ Proof. 
+ unfold eq; intros.
+ rewrite compare_sym.
+ rewrite H; simpl; auto.
+ Qed.
+
+ Definition eq_trans := (compare_trans Eq).
+
+ Definition lt_trans := (compare_trans Lt).
+
+ Lemma lt_not_eq : forall x y, lt x y -> ~eq x y.
+ Proof.
+ unfold eq, lt; intros.
+ rewrite H; discriminate.
+ Qed.
+
+ Definition compare : forall x y, Compare lt eq x y.
+ Proof.
+ intros.
+ case_eq (x ?= y); intros.
+ apply EQ; auto.
+ apply LT; auto.
+ apply GT; red.
+ rewrite compare_sym; rewrite H; auto.
+ Defined.
+
+End OrderedType_from_Alt. 
+
+(** From the original presentation to this alternative one. *)
+
+Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt.
+ Import O.
+ Module MO:=OrderedTypeFacts(O).
+ Import MO.
+
+ Definition t := t.
+
+ Definition compare x y := match compare x y with 
+   | LT _ => Lt
+   | EQ _ => Eq
+   | GT _ => Gt
+  end. 
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Lemma compare_sym : 
+   forall x y, (y?=x) = CompOpp (x?=y).
+ Proof.
+ intros x y.
+ unfold compare.
+ destruct (O.compare y x); elim_comp; simpl; auto.
+ Qed.
+ 
+ Lemma compare_trans : 
+   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+ Proof.
+ intros c x y z.
+ destruct c; unfold compare.
+ destruct (O.compare x y); intros; try discriminate.
+ destruct (O.compare y z); intros; try discriminate.
+ elim_comp; auto.
+ destruct (O.compare x y); intros; try discriminate.
+ destruct (O.compare y z); intros; try discriminate.
+ elim_comp; auto.
+ destruct (O.compare x y); intros; try discriminate.
+ destruct (O.compare y z); intros; try discriminate.
+ elim_comp; auto.
+ Qed.
+
+End OrderedType_to_Alt.
+
+ 
diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v
new file mode 100644
index 00000000..6fa6a85c
--- /dev/null
+++ b/theories/FSets/OrderedTypeEx.v
@@ -0,0 +1,248 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: OrderedTypeEx.v 9066 2006-08-14 10:11:18Z letouzey $ *)
+
+Require Import OrderedType.
+Require Import ZArith.
+Require Import Omega.
+Require Import NArith Ndec.
+Require Import Compare_dec.
+
+(** * Examples of Ordered Type structures. *)
+
+(** First, a particular case of [OrderedType] where 
+    the equality is the usual one of Coq. *)
+
+Module Type UsualOrderedType.
+ Parameter t : Set.
+ Definition eq := @eq t.
+ Parameter lt : t -> t -> Prop.
+ Definition eq_refl := @refl_equal t.
+ Definition eq_sym := @sym_eq t.
+ Definition eq_trans := @trans_eq t.
+ Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+ Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+ Parameter compare : forall x y : t, Compare lt eq x y.
+End UsualOrderedType.
+
+(** a [UsualOrderedType] is in particular an [OrderedType]. *)
+
+Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U.
+
+(** [nat] is an ordered type with respect to the usual order on natural numbers. *)
+
+Module Nat_as_OT <: UsualOrderedType.
+
+  Definition t := nat.
+
+  Definition eq := @eq nat.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt := lt.
+
+  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Proof. unfold lt in |- *; intros; apply lt_trans with y; auto. Qed.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof. unfold lt, eq in |- *; intros; omega. Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+    intros; case (lt_eq_lt_dec x y).
+    simple destruct 1; intro.
+    constructor 1; auto.
+    constructor 2; auto.
+    intro; constructor 3; auto.
+  Defined.
+
+End Nat_as_OT.
+
+
+(** [Z] is an ordered type with respect to the usual order on integers. *)
+
+Open Scope Z_scope.
+
+Module Z_as_OT <: UsualOrderedType.
+
+  Definition t := Z.
+  Definition eq := @eq Z. 
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt (x y:Z) := (x<y).
+
+  Lemma lt_trans : forall x y z, x<y -> y<z -> x<z.
+  Proof. intros; omega. Qed.
+
+  Lemma lt_not_eq : forall x y, x<y -> ~ x=y.
+  Proof. intros; omega. Qed.
+
+  Definition compare : forall x y, Compare lt eq x y.
+  Proof.
+    intros x y; case_eq (x ?= y); intros.
+    apply EQ; unfold eq; apply Zcompare_Eq_eq; auto.
+    apply LT; unfold lt, Zlt; auto.
+    apply GT; unfold lt, Zlt; rewrite <- Zcompare_Gt_Lt_antisym; auto.
+  Defined.
+
+End Z_as_OT.
+
+(** [positive] is an ordered type with respect to the usual order on natural numbers. *) 
+
+Open Scope positive_scope.
+
+Module Positive_as_OT <: UsualOrderedType.
+  Definition t:=positive.
+  Definition eq:=@eq positive.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt p q:= (p ?= q) Eq = Lt.
+ 
+  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Proof. 
+  unfold lt; intros x y z.
+  change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z).
+  omega.
+  Qed.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite H0 in H.
+  unfold lt in H.
+  rewrite Pcompare_refl in H; discriminate.
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  intros x y.
+  case_eq ((x ?= y) Eq); intros.
+  apply EQ; apply Pcompare_Eq_eq; auto.
+  apply LT; unfold lt; auto.
+  apply GT; unfold lt.
+  replace Eq with (CompOpp Eq); auto.
+  rewrite <- Pcompare_antisym; rewrite H; auto.
+  Qed.
+
+End Positive_as_OT.
+
+
+(** [N] is an ordered type with respect to the usual order on natural numbers. *) 
+
+Open Scope positive_scope.
+
+Module N_as_OT <: UsualOrderedType.
+  Definition t:=N.
+  Definition eq:=@eq N.
+  Definition eq_refl := @refl_equal t.
+  Definition eq_sym := @sym_eq t.
+  Definition eq_trans := @trans_eq t.
+
+  Definition lt p q:= Nle q p = false.
+ 
+  Definition lt_trans := Nlt_trans.
+
+  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+  Proof.
+  intros; intro.
+  rewrite H0 in H.
+  unfold lt in H.
+  rewrite Nle_refl in H; discriminate.
+  Qed.
+
+  Definition compare : forall x y : t, Compare lt eq x y.
+  Proof.
+  intros x y.
+  case_eq ((x ?= y)%N); intros.
+  apply EQ; apply Ncompare_Eq_eq; auto.
+  apply LT; unfold lt; auto.
+   generalize (Nle_Ncompare y x).
+   destruct (Nle y x); auto.
+   rewrite <- Ncompare_antisym.
+   destruct (x ?= y)%N; simpl; try discriminate.
+   intros (H0,_); elim H0; auto.
+  apply GT; unfold lt.
+   generalize (Nle_Ncompare x y).
+   destruct (Nle x y); auto.
+   destruct (x ?= y)%N; simpl; try discriminate.
+   intros (H0,_); elim H0; auto.
+  Defined.
+
+End N_as_OT.
+
+
+(** From two ordered types, we can build a new OrderedType 
+   over their cartesian product, using the lexicographic order. *)
+
+Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
+ Module MO1:=OrderedTypeFacts(O1).
+ Module MO2:=OrderedTypeFacts(O2).
+
+ Definition t := prod O1.t O2.t.
+  
+ Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y).
+
+ Definition lt x y := 
+    O1.lt (fst x) (fst y) \/ 
+    (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).
+
+ Lemma eq_refl : forall x : t, eq x x.
+ Proof. 
+ intros (x1,x2); red; simpl; auto.
+ Qed.
+
+ Lemma eq_sym : forall x y : t, eq x y -> eq y x.
+ Proof. 
+ intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
+ Qed.
+
+ Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
+ Proof. 
+ intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto.
+ Qed.
+ 
+ Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 
+ Proof.
+ intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition.
+ left; eauto.
+ left; eapply MO1.lt_eq; eauto.
+ left; eapply MO1.eq_lt; eauto.
+ right; split; eauto.
+ Qed.
+
+ Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+ Proof.
+ intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition.
+ apply (O1.lt_not_eq H0 H1).
+ apply (O2.lt_not_eq H3 H2).
+ Qed.
+
+ Definition compare : forall x y : t, Compare lt eq x y.
+ intros (x1,x2) (y1,y2).
+ destruct (O1.compare x1 y1).
+ apply LT; unfold lt; auto.
+ destruct (O2.compare x2 y2).
+ apply LT; unfold lt; auto.
+ apply EQ; unfold eq; auto.
+ apply GT; unfold lt; auto.
+ apply GT; unfold lt; auto.
+ Defined.
+
+End PairOrderedType.
+
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index 6aeabe13..56dc7e95 100755..100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -6,19 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Datatypes.v,v 1.26.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: Datatypes.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+Set Implicit Arguments.
 
 Require Import Notations.
 Require Import Logic.
 
-Set Implicit Arguments.
-
 (** [unit] is a singleton datatype with sole inhabitant [tt] *)
 
 Inductive unit : Set :=
     tt : unit.
 
-(** [bool] is the datatype of the booleans values [true] and [false] *)
+(** [bool] is the datatype of the boolean values [true] and [false] *)
 
 Inductive bool : Set :=
   | true : bool
@@ -27,7 +27,9 @@ Inductive bool : Set :=
 Add Printing If bool.
 
 (** [nat] is the datatype of natural numbers built from [O] and successor [S];
-    note that zero is the letter O, not the numeral 0 *)
+    note that the constructor name is the letter O.
+    Numbers in [nat] can be denoted using a decimal notation; 
+    e.g. [3%nat] abbreviates [S (S (S O))] *)
 
 Inductive nat : Set :=
   | O : nat
@@ -45,25 +47,31 @@ Inductive Empty_set : Set :=.
     member is the singleton datatype [identity A a a] whose
     sole inhabitant is denoted [refl_identity A a] *)
 
-Inductive identity (A:Type) (a:A) : A -> Set :=
-    refl_identity : identity (A:=A) a a.
+Inductive identity (A:Type) (a:A) : A -> Type :=
+  refl_identity : identity (A:=A) a a.
 Hint Resolve refl_identity: core v62.
 
 Implicit Arguments identity_ind [A].
 Implicit Arguments identity_rec [A].
 Implicit Arguments identity_rect [A].
 
-(** [option A] is the extension of A with a dummy element None *)
+(** [option A] is the extension of [A] with an extra element [None] *)
 
-Inductive option (A:Set) : Set :=
+Inductive option (A:Type) : Type :=
   | Some : A -> option A
   | None : option A.
 
 Implicit Arguments None [A].
 
-(** [sum A B], equivalently [A + B], is the disjoint sum of [A] and [B] *)
+Definition option_map (A B:Type) (f:A->B) o :=
+  match o with
+    | Some a => Some (f a)
+    | None => None
+  end.
+
+(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)
 (* Syntax defined in Specif.v *)
-Inductive sum (A B:Set) : Set :=
+Inductive sum (A B:Type) : Type :=
   | inl : A -> sum A B
   | inr : B -> sum A B.
 
@@ -72,39 +80,46 @@ Notation "x + y" := (sum x y) : type_scope.
 (** [prod A B], written [A * B], is the product of [A] and [B];
     the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)
 
-Inductive prod (A B:Set) : Set :=
-    pair : A -> B -> prod A B.
+Inductive prod (A B:Type) : Type :=
+  pair : A -> B -> prod A B.
 Add Printing Let prod.
 
 Notation "x * y" := (prod x y) : type_scope.
 Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
 
 Section projections.
-   Variables A B : Set.
-   Definition fst (p:A * B) := match p with
-                               | (x, y) => x
-                               end.
-   Definition snd (p:A * B) := match p with
-                               | (x, y) => y
-                               end.
+  Variables A B : Type.
+  Definition fst (p:A * B) := match p with
+				| (x, y) => x
+                              end.
+  Definition snd (p:A * B) := match p with
+				| (x, y) => y
+                              end.
 End projections. 
 
 Hint Resolve pair inl inr: core v62.
 
 Lemma surjective_pairing :
- forall (A B:Set) (p:A * B), p = pair (fst p) (snd p).
+  forall (A B:Type) (p:A * B), p = pair (fst p) (snd p).
 Proof.
-destruct p; reflexivity.
+  destruct p; reflexivity.
 Qed.
 
 Lemma injective_projections :
- forall (A B:Set) (p1 p2:A * B),
-   fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2.
+  forall (A B:Type) (p1 p2:A * B),
+    fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2.
 Proof.
-destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd.
-rewrite Hfst; rewrite Hsnd; reflexivity. 
+  destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd.
+  rewrite Hfst; rewrite Hsnd; reflexivity. 
 Qed.
 
+Definition prod_uncurry (A B C:Type) (f:prod A B -> C) 
+  (x:A) (y:B) : C := f (pair x y).
+
+Definition prod_curry (A B C:Type) (f:A -> B -> C) 
+  (p:prod A B) : C := match p with
+                       | pair x y => f x y
+                       end.
 
 (** Comparison *)
 
@@ -115,7 +130,19 @@ Inductive comparison : Set :=
 
 Definition CompOpp (r:comparison) :=
   match r with
-  | Eq => Eq
-  | Lt => Gt
-  | Gt => Lt
+    | Eq => Eq
+    | Lt => Gt
+    | Gt => Lt
   end.
+
+(* Compatibility *)
+
+Notation prodT := prod (only parsing).
+Notation pairT := pair (only parsing).
+Notation prodT_rect := prod_rect (only parsing).
+Notation prodT_rec := prod_rec (only parsing).
+Notation prodT_ind := prod_ind (only parsing).
+Notation fstT := fst (only parsing).
+Notation sndT := snd (only parsing).
+Notation prodT_uncurry := prod_uncurry (only parsing).
+Notation prodT_curry := prod_curry (only parsing).
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index bae8d4a1..8b487432 100755..100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Logic.v,v 1.29.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: Logic.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Set Implicit Arguments.
 
@@ -16,7 +16,7 @@ Require Import Notations.
 
 (** [True] is the always true proposition *)
 Inductive True : Prop :=
-    I : True. 
+  I : True. 
 
 (** [False] is the always false proposition *)
 Inductive False : Prop :=. 
@@ -28,13 +28,6 @@ Notation "~ x" := (not x) : type_scope.
 
 Hint Unfold not: core.
 
-Inductive and (A B:Prop) : Prop :=
-    conj : A -> B -> A /\ B 
- where "A /\ B" := (and A B) : type_scope.
-
-
-Section Conjunction.
-
   (** [and A B], written [A /\ B], is the conjunction of [A] and [B]
 
       [conj p q] is a proof of [A /\ B] as soon as 
@@ -42,16 +35,23 @@ Section Conjunction.
 
       [proj1] and [proj2] are first and second projections of a conjunction *)
 
+Inductive and (A B:Prop) : Prop :=
+  conj : A -> B -> A /\ B 
+  
+where "A /\ B" := (and A B) : type_scope.
+
+Section Conjunction.
+
   Variables A B : Prop.
 
   Theorem proj1 : A /\ B -> A.
   Proof.
-  destruct 1; trivial.
+    destruct 1; trivial.
   Qed.
 
   Theorem proj2 : A /\ B -> B.
   Proof.
-  destruct 1; trivial.
+    destruct 1; trivial.
   Qed.
 
 End Conjunction.
@@ -61,7 +61,8 @@ End Conjunction.
 Inductive or (A B:Prop) : Prop :=
   | or_introl : A -> A \/ B
   | or_intror : B -> A \/ B 
- where "A \/ B" := (or A B) : type_scope.
+
+where "A \/ B" := (or A B) : type_scope.
 
 (** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)
 
@@ -94,44 +95,52 @@ End Equivalence.
 Definition IF_then_else (P Q R:Prop) := P /\ Q \/ ~ P /\ R.
 
 Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3)
-  (at level 200) : type_scope.
-
-(** * First-order quantifiers
-  - [ex A P], or simply [exists x, P x], expresses the existence of an 
-      [x] of type [A] which satisfies the predicate [P] ([A] is of type 
-      [Set]). This is existential quantification.
-  - [ex2 A P Q], or simply [exists2 x, P x & Q x], expresses the
-      existence of an [x] of type [A] which satisfies both the predicates
-      [P] and [Q].
-  - Universal quantification (especially first-order one) is normally 
-    written [forall x:A, P x]. For duality with existential quantification, 
-    the construction [all P] is provided too.
+  (at level 200, right associativity) : type_scope.
+
+(** * First-order quantifiers *)
+
+(** [ex P], or simply [exists x, P x], or also [exists x:A, P x],
+    expresses the existence of an [x] of some type [A] in [Set] which
+    satisfies the predicate [P].  This is existential quantification.
+
+    [ex2 P Q], or simply [exists2 x, P x & Q x], or also 
+    [exists2 x:A, P x & Q x], expresses the existence of an [x] of
+    type [A] which satisfies both predicates [P] and [Q].
+
+    Universal quantification is primitively written [forall x:A, Q]. By
+    symmetry with existential quantification, the construction [all P]
+    is provided too.
 *)
 
+(** Remark: [exists x, Q] denotes [ex (fun x => Q)] so that [exists x,
+   P x] is in fact equivalent to [ex (fun x => P x)] which may be not
+   convertible to [ex P] if [P] is not itself an abstraction *)
+
+
 Inductive ex (A:Type) (P:A -> Prop) : Prop :=
-    ex_intro : forall x:A, P x -> ex (A:=A) P.
+  ex_intro : forall x:A, P x -> ex (A:=A) P.
 
 Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop :=
-    ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q.
+  ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q.
 
 Definition all (A:Type) (P:A -> Prop) := forall x:A, P x. 
 
 (* Rule order is important to give printing priority to fully typed exists *)
 
 Notation "'exists' x , p" := (ex (fun x => p))
-  (at level 200, x ident) : type_scope.
+  (at level 200, x ident, right associativity) : type_scope.
 Notation "'exists' x : t , p" := (ex (fun x:t => p))
-  (at level 200, x ident, format "'exists'  '/  ' x  :  t ,  '/  ' p")
+  (at level 200, x ident, right associativity, 
+    format "'[' 'exists'  '/  ' x  :  t ,  '/  ' p ']'")
   : type_scope.
 
 Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))
-  (at level 200, x ident, p at level 200) : type_scope.
+  (at level 200, x ident, p at level 200, right associativity) : type_scope.
 Notation "'exists2' x : t , p & q" := (ex2 (fun x:t => p) (fun x:t => q))
-  (at level 200, x ident, t at level 200, p at level 200,
-   format "'exists2'  '/  ' x  :  t ,  '/  ' '[' p  &  '/' q ']'")
+  (at level 200, x ident, t at level 200, p at level 200, right associativity,
+    format "'[' 'exists2'  '/  ' x  :  t ,  '/  ' '[' p  &  '/' q ']' ']'")
   : type_scope.
 
-
 (** Derived rules for universal quantification *)
 
 Section universal_quantification.
@@ -141,28 +150,31 @@ Section universal_quantification.
 
   Theorem inst : forall x:A, all (fun x => P x) -> P x.
   Proof.
-  unfold all in |- *; auto.
+    unfold all in |- *; auto.
   Qed.
 
   Theorem gen : forall (B:Prop) (f:forall y:A, B -> P y), B -> all P.
   Proof.
-  red in |- *; auto.
+    red in |- *; auto.
   Qed.
 
 End universal_quantification.
 
 (** * Equality *)
 
-(** [eq x y], or simply [x=y], expresses the (Leibniz') equality
-    of [x] and [y]. Both [x] and [y] must belong to the same type [A].
+(** [eq x y], or simply [x=y] expresses the equality of [x] and
+    [y]. Both [x] and [y] must belong to the same type [A].
     The definition is inductive and states the reflexivity of the equality.
     The others properties (symmetry, transitivity, replacement of 
-    equals) are proved below. The type of [x] and [y] can be made explicit
-    using the notation [x = y :> A] *)
+    equals by equals) are proved below. The type of [x] and [y] can be
+    made explicit using the notation [x = y :> A]. This is Leibniz equality
+    as it expresses that [x] and [y] are equal iff every property on
+    [A] which is true of [x] is also true of [y] *)
 
 Inductive eq (A:Type) (x:A) : A -> Prop :=
     refl_equal : x = x :>A 
- where "x = y :> A" := (@eq A x y) : type_scope.
+
+where "x = y :> A" := (@eq A x y) : type_scope.
 
 Notation "x = y" := (x = y :>_) : type_scope.
 Notation "x <> y  :> T" := (~ x = y :>T) : type_scope.
@@ -190,53 +202,43 @@ Section Logic_lemmas.
 
     Theorem sym_eq : x = y -> y = x.
     Proof.
-     destruct 1; trivial.
+      destruct 1; trivial.
     Defined.
     Opaque sym_eq.
 
     Theorem trans_eq : x = y -> y = z -> x = z.
     Proof.
-     destruct 2; trivial.
+      destruct 2; trivial.
     Defined.
     Opaque trans_eq.
 
     Theorem f_equal : x = y -> f x = f y.
     Proof.
-     destruct 1; trivial.
+      destruct 1; trivial.
     Defined.
     Opaque f_equal.
 
     Theorem sym_not_eq : x <> y -> y <> x.
     Proof.
-     red in |- *; intros h1 h2; apply h1; destruct h2; trivial.
+      red in |- *; intros h1 h2; apply h1; destruct h2; trivial.
     Qed.
-
+    
     Definition sym_equal := sym_eq.
     Definition sym_not_equal := sym_not_eq.
     Definition trans_equal := trans_eq.
 
   End equality.
 
-(* Is now a primitive principle 
-  Theorem eq_rect: (A:Type)(x:A)(P:A->Type)(P x)->(y:A)(eq ? x y)->(P y).
-  Proof.
-   Intros.
-   Cut (identity A x y).
-   NewDestruct 1; Auto.
-   NewDestruct H; Auto.
-  Qed.
-*)
-
   Definition eq_ind_r :
     forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y.
-   intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
+    intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
   Defined.
-
+  
   Definition eq_rec_r :
     forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y.
     intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
   Defined.
-
+  
   Definition eq_rect_r :
     forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y.
     intros A x P H y H0; elim sym_eq with (1 := H0); assumption.
@@ -244,36 +246,74 @@ Section Logic_lemmas.
 End Logic_lemmas.
 
 Theorem f_equal2 :
- forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) 
-   (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
+  forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) 
+    (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
 Proof.
   destruct 1; destruct 1; reflexivity.
 Qed.
 
 Theorem f_equal3 :
- forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) 
-   (x2 y2:A2) (x3 y3:A3),
-   x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3.
+  forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) 
+    (x2 y2:A2) (x3 y3:A3),
+    x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3.
 Proof.
   destruct 1; destruct 1; destruct 1; reflexivity.
 Qed.
 
 Theorem f_equal4 :
- forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B) 
-   (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
-   x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4.
+  forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B) 
+    (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
+    x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4.
 Proof.
   destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
 Qed.
 
 Theorem f_equal5 :
- forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B)
-   (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5),
-   x1 = y1 ->
-   x2 = y2 ->
-   x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
+  forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B)
+    (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5),
+    x1 = y1 ->
+    x2 = y2 ->
+    x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
 Proof.
   destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
 Qed.
 
 Hint Immediate sym_eq sym_not_eq: core v62.
+
+(** Basic definitions about relations and properties *)
+
+Definition subrelation (A B : Type) (R R' : A->B->Prop) :=
+  forall x y, R x y -> R' x y.
+
+Definition unique (A : Type) (P : A->Prop) (x:A) :=
+  P x /\ forall (x':A), P x' -> x=x'.
+
+Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y.
+
+(** Unique existence *)
+
+Notation "'exists' ! x , P" := (ex (unique (fun x => P)))
+  (at level 200, x ident, right associativity,
+    format "'[' 'exists' !  '/  ' x ,  '/  ' P ']'") : type_scope.
+Notation "'exists' ! x : A , P" := 
+  (ex (unique (fun x:A => P)))
+  (at level 200, x ident, right associativity,
+    format "'[' 'exists' !  '/  ' x  :  A ,  '/  ' P ']'") : type_scope.
+
+Lemma unique_existence : forall (A:Type) (P:A->Prop),
+  ((exists x, P x) /\ uniqueness P) <-> (exists! x, P x).
+Proof.
+  intros A P; split.
+  intros ((x,Hx),Huni); exists x; red; auto.
+  intros (x,(Hx,Huni)); split. 
+  exists x; assumption.
+  intros x' x'' Hx' Hx''; transitivity x.
+  symmetry; auto.
+  auto.
+Qed.
+
+(** Being inhabited *)
+
+Inductive inhabited (A:Type) : Prop := inhabits : A -> inhabited A.
+
+Hint Resolve inhabits: core.
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
index 0e62e842..dbe944b0 100755..100644
--- a/theories/Init/Logic_Type.v
+++ b/theories/Init/Logic_Type.v
@@ -6,18 +6,22 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Logic_Type.v,v 1.19.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: Logic_Type.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
-Set Implicit Arguments.
+(** This module defines type constructors for types in [Type]
+    ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *)
 
-(** This module defines quantification on the world [Type]
-    ([Logic.v] was defining it on the world [Set]) *)
+Set Implicit Arguments.
 
 Require Import Datatypes.
 Require Export Logic.
 
+(** Negation of a type in [Type] *)
+
 Definition notT (A:Type) := A -> False.
 
+(** Properties of [identity] *)
+
 Section identity_is_a_congruence.
 
  Variables A B : Type.
@@ -62,28 +66,4 @@ Definition identity_rect_r :
  intros A x P H y H0; case sym_id with (1 := H0); trivial.
 Defined.
 
-Inductive prodT (A B:Type) : Type :=
-    pairT : A -> B -> prodT A B.
-
-Section prodT_proj.
-
-  Variables A B : Type.
-
-  Definition fstT (H:prodT A B) := match H with
-                                   | pairT x _ => x
-                                   end.
-  Definition sndT (H:prodT A B) := match H with
-                                   | pairT _ y => y
-                                   end.
-
-End prodT_proj.
-
-Definition prodT_uncurry (A B C:Type) (f:prodT A B -> C) 
-  (x:A) (y:B) : C := f (pairT x y).
-
-Definition prodT_curry (A B C:Type) (f:A -> B -> C) 
-  (p:prodT A B) : C := match p with
-                       | pairT x y => f x y
-                       end.
-
 Hint Immediate sym_id sym_not_id: core v62.
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index e0a18747..416647b4 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Notations.v,v 1.24.2.2 2004/08/01 09:36:44 herbelin Exp $ i*)
+(*i $Id: Notations.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 (** These are the notations whose level and associativity are imposed by Coq *)
 
@@ -54,17 +54,17 @@ Reserved Notation "x ^ y" (at level 30, right associativity).
 Reserved Notation "( x , y , .. , z )" (at level 0).
 
 (** Notation "{ x }" is reserved and has a special status as component
-    of other notations; it is at level 0 to factor with {x:A|P} etc *)
+    of other notations such as "{ A } + { B }" and "A + { B }" (which
+    are at the same level than "x + y");
+    "{ x }" is at level 0 to factor with "{ x : A | P }" *)
 
 Reserved Notation "{ x }" (at level 0, x at level 99).
 
-(** Notations for sum-types *)
-
-Reserved Notation "{ A } + { B }" (at level 50, left associativity).
-Reserved Notation "A + { B }" (at level 50, left associativity).
-
 (** Notations for sigma-types or subsets *)
 
+Reserved Notation "{ x  |  P }" (at level 0, x at level 99).
+Reserved Notation "{ x  |  P  &  Q }" (at level 0, x at level 99).
+
 Reserved Notation "{ x : A  |  P }" (at level 0, x at level 99).
 Reserved Notation "{ x : A  |  P  &  Q }" (at level 0, x at level 99).
 
diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v
index 789a020f..3df2b566 100755..100644
--- a/theories/Init/Peano.v
+++ b/theories/Init/Peano.v
@@ -6,9 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Peano.v,v 1.23.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: Peano.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
-(** Natural numbers [nat] built from [O] and [S] are defined in Datatypes.v *)
+(** The type [nat] of Peano natural numbers (built from [O] and [S])
+    is defined in [Datatypes.v] *)
 
 (** This module defines the following operations on natural numbers :
     - predecessor [pred]
@@ -19,13 +20,15 @@
     - greater or equal [ge]
     - greater [gt]
 
-   This module states various lemmas and theorems about natural numbers,
-   including Peano's axioms of arithmetic (in Coq, these are in fact provable)
-   Case analysis on [nat] and induction on [nat * nat] are provided too *)
+   It states various lemmas and theorems about natural numbers,
+   including Peano's axioms of arithmetic (in Coq, these are provable).
+   Case analysis on [nat] and induction on [nat * nat] are provided too
+ *)
 
 Require Import Notations.
 Require Import Datatypes.
 Require Import Logic.
+Unset Boxed Definitions.
 
 Open Scope nat_scope.
 
@@ -44,18 +47,20 @@ Hint Resolve (f_equal pred): v62.
 
 Theorem pred_Sn : forall n:nat, n = pred (S n).
 Proof.
-  auto.
+  simpl; reflexivity.  
 Qed.
 
+(** Injectivity of successor *)
+
 Theorem eq_add_S : forall n m:nat, S n = S m -> n = m.
 Proof.
-  intros n m H; change (pred (S n) = pred (S m)) in |- *; auto.
+  intros n m Sn_eq_Sm.
+  replace (n=m) with (pred (S n) = pred (S m)) by auto using pred_Sn.
+  rewrite Sn_eq_Sm; trivial.
 Qed.
 
 Hint Immediate eq_add_S: core v62.
 
-(** A consequence of the previous axioms *)
-
 Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m.
 Proof.
   red in |- *; auto.
@@ -68,12 +73,12 @@ Definition IsSucc (n:nat) : Prop :=
   | S p => True
   end.
 
+(** Zero is not the successor of a number *)
 
 Theorem O_S : forall n:nat, 0 <> S n.
 Proof.
-  red in |- *; intros n H.
-  change (IsSucc 0) in |- *.
-  rewrite <- (sym_eq (x:=0) (y:=(S n))); [ exact I | assumption ].
+  unfold not; intros n H.
+  inversion H.
 Qed.
 Hint Resolve O_S: core v62.
 
@@ -88,13 +93,14 @@ Hint Resolve n_Sn: core v62.
 Fixpoint plus (n m:nat) {struct n} : nat :=
   match n with
   | O => m
-  | S p => S (plus p m)
-  end.
+  | S p => S (p + m)
+  end
+
+where "n + m" := (plus n m) : nat_scope.
+
 Hint Resolve (f_equal2 plus): v62.
 Hint Resolve (f_equal2 (A1:=nat) (A2:=nat)): core.
 
-Infix "+" := plus : nat_scope.
-
 Lemma plus_n_O : forall n:nat, n = n + 0.
 Proof.
   induction n; simpl in |- *; auto.
@@ -122,11 +128,12 @@ Qed.
 Fixpoint mult (n m:nat) {struct n} : nat :=
   match n with
   | O => 0
-  | S p => m + mult p m
-  end.
-Hint Resolve (f_equal2 mult): core v62.
+  | S p => m + p * m
+  end
 
-Infix "*" := mult : nat_scope.
+where "n * m" := (mult n m) : nat_scope.
+
+Hint Resolve (f_equal2 mult): core v62.
 
 Lemma mult_n_O : forall n:nat, 0 = n * 0.
 Proof.
@@ -142,27 +149,25 @@ Proof.
 Qed.
 Hint Resolve mult_n_Sm: core v62.
 
-(** Definition of subtraction on [nat] : [m-n] is [0] if [n>=m] *)
+(** Truncated subtraction: [m-n] is [0] if [n>=m] *)
 
 Fixpoint minus (n m:nat) {struct n} : nat :=
   match n, m with
   | O, _ => 0
   | S k, O => S k
-  | S k, S l => minus k l
-  end. 
+  | S k, S l => k - l
+  end
 
-Infix "-" := minus : nat_scope.
+where "n - m" := (minus n m) : nat_scope.
 
 (** Definition of the usual orders, the basic properties of [le] and [lt] 
     can be found in files Le and Lt *)
 
-(** An inductive definition to define the order *)
-
 Inductive le (n:nat) : nat -> Prop :=
-  | le_n : le n n
-  | le_S : forall m:nat, le n m -> le n (S m).
+  | le_n : n <= n
+  | le_S : forall m:nat, n <= m -> n <= S m
 
-Infix "<=" := le : nat_scope.
+where "n <= m" := (le n m) : nat_scope.
 
 Hint Constructors le: core v62.
 (*i equivalent to : "Hints Resolve le_n le_S : core v62." i*)
@@ -187,7 +192,7 @@ Notation "x <= y < z" := (x <= y /\ y < z) : nat_scope.
 Notation "x < y < z" := (x < y /\ y < z) : nat_scope.
 Notation "x < y <= z" := (x < y /\ y <= z) : nat_scope.
 
-(** Pattern-Matching on natural numbers *)
+(** Case analysis *)
 
 Theorem nat_case :
  forall (n:nat) (P:nat -> Prop), P 0 -> (forall m:nat, P (S m)) -> P n.
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
index 2fe520c4..5f6f1eab 100755..100644
--- a/theories/Init/Prelude.v
+++ b/theories/Init/Prelude.v
@@ -6,11 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Prelude.v,v 1.11.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+(*i $Id: Prelude.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Require Export Notations.
 Require Export Logic.
 Require Export Datatypes.
 Require Export Specif.
 Require Export Peano.
-Require Export Wf.
\ No newline at end of file
+Require Export Wf.
+Require Export Tactics.
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index 6855e689..dd2f7697 100755..100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -6,62 +6,71 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Specif.v,v 1.25.2.1 2004/07/16 19:31:04 herbelin Exp $ i*)
+(*i $Id: Specif.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
-Set Implicit Arguments.
+(** Basic specifications : sets that may contain logical information *)
 
-(** Basic specifications : Sets containing logical information *)
+Set Implicit Arguments.
 
 Require Import Notations.
 Require Import Datatypes.
 Require Import Logic.
 
-(** Subsets *)
+(** Subsets and Sigma-types *)
 
-(** [(sig A P)], or more suggestively [{x:A | (P x)}], denotes the subset 
-    of elements of the Set [A] which satisfy the predicate [P].
-    Similarly [(sig2 A P Q)], or [{x:A | (P x) & (Q x)}], denotes the subset 
-    of elements of the Set [A] which satisfy both [P] and [Q]. *)
+(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset 
+    of elements of the type [A] which satisfy the predicate [P].
+    Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset 
+    of elements of the type [A] which satisfy both [P] and [Q]. *)
 
-Inductive sig (A:Set) (P:A -> Prop) : Set :=
-    exist : forall x:A, P x -> sig (A:=A) P.
+Inductive sig (A:Type) (P:A -> Prop) : Type :=
+    exist : forall x:A, P x -> sig P.
 
-Inductive sig2 (A:Set) (P Q:A -> Prop) : Set :=
-    exist2 : forall x:A, P x -> Q x -> sig2 (A:=A) P Q.
+Inductive sig2 (A:Type) (P Q:A -> Prop) : Type :=
+    exist2 : forall x:A, P x -> Q x -> sig2 P Q.
 
-(** [(sigS A P)], or more suggestively [{x:A & (P x)}], is a subtle variant
-    of subset where [P] is now of type [Set].
-    Similarly for [(sigS2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *)
-     
-Inductive sigS (A:Set) (P:A -> Set) : Set :=
-    existS : forall x:A, P x -> sigS (A:=A) P.
+(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. 
+    Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *)
+
+Inductive sigT (A:Type) (P:A -> Type) : Type :=
+    existT : forall x:A, P x -> sigT P.
 
-Inductive sigS2 (A:Set) (P Q:A -> Set) : Set :=
-    existS2 : forall x:A, P x -> Q x -> sigS2 (A:=A) P Q.
+Inductive sigT2 (A:Type) (P Q:A -> Type) : Type :=
+    existT2 : forall x:A, P x -> Q x -> sigT2 P Q.
+
+(* Notations *)
 
 Arguments Scope sig [type_scope type_scope].
 Arguments Scope sig2 [type_scope type_scope type_scope].
-Arguments Scope sigS [type_scope type_scope].
-Arguments Scope sigS2 [type_scope type_scope type_scope].
+Arguments Scope sigT [type_scope type_scope].
+Arguments Scope sigT2 [type_scope type_scope type_scope].
 
+Notation "{ x  |  P }" := (sig (fun x => P)) : type_scope.
+Notation "{ x  |  P  &  Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope.
 Notation "{ x : A  |  P }" := (sig (fun x:A => P)) : type_scope.
 Notation "{ x : A  |  P  &  Q }" := (sig2 (fun x:A => P) (fun x:A => Q)) :
   type_scope.
-Notation "{ x : A  &  P }" := (sigS (fun x:A => P)) : type_scope.
-Notation "{ x : A  &  P  &  Q }" := (sigS2 (fun x:A => P) (fun x:A => Q)) :
+Notation "{ x : A  &  P }" := (sigT (fun x:A => P)) : type_scope.
+Notation "{ x : A  &  P  &  Q }" := (sigT2 (fun x:A => P) (fun x:A => Q)) :
   type_scope.
 
 Add Printing Let sig.
 Add Printing Let sig2.
-Add Printing Let sigS.
-Add Printing Let sigS2.
+Add Printing Let sigT.
+Add Printing Let sigT2.
+
+
+(** Projections of [sig]
 
+    An element [y] of a subset [{x:A & (P x)}] is the pair of an [a]
+    of type [A] and of a proof [h] that [a] satisfies [P].  Then
+    [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the
+    proof of [(P a)] *)
 
-(** Projections of sig *)
 
 Section Subset_projections.
 
-  Variable A : Set.
+  Variable A : Type.
   Variable P : A -> Prop.
 
   Definition proj1_sig (e:sig P) := match e with
@@ -76,30 +85,31 @@ Section Subset_projections.
 End Subset_projections.
 
 
-(** Projections of sigS *)
+(** Projections of [sigT]
 
-Section Projections.
+    An element [x] of a sigma-type [{y:A & P y}] is a dependent pair
+    made of an [a] of type [A] and an [h] of type [P a].  Then,
+    [(projT1 x)] is the first projection and [(projT2 x)] is the
+    second projection, the type of which depends on the [projT1]. *)
 
-  Variable A : Set.
-  Variable P : A -> Set.
+Section Projections.
 
- (** An element [y] of a subset [{x:A & (P x)}] is the pair of an [a] of 
-     type [A] and of a proof [h] that [a] satisfies [P].
-     Then [(projS1 y)] is the witness [a]
-     and [(projS2 y)] is the proof of [(P a)] *)
+  Variable A : Type.
+  Variable P : A -> Type.
 
-  Definition projS1 (x:sigS P) : A := match x with
-                                      | existS a _ => a
+  Definition projT1 (x:sigT P) : A := match x with
+                                      | existT a _ => a
                                       end.
-  Definition projS2 (x:sigS P) : P (projS1 x) :=
-    match x return P (projS1 x) with
-    | existS _ h => h
+  Definition projT2 (x:sigT P) : P (projT1 x) :=
+    match x return P (projT1 x) with
+    | existT _ h => h
     end.
 
 End Projections.
 
 
-(** Extended_booleans *)
+(** [sumbool] is a boolean type equipped with the justification of
+    their value *)
 
 Inductive sumbool (A B:Prop) : Set :=
   | left : A -> {A} + {B}
@@ -108,19 +118,20 @@ Inductive sumbool (A B:Prop) : Set :=
 
 Add Printing If sumbool.
 
-Inductive sumor (A:Set) (B:Prop) : Set :=
+(** [sumor] is an option type equipped with the justification of why
+    it may not be a regular value *)
+
+Inductive sumor (A:Type) (B:Prop) : Type :=
   | inleft : A -> A + {B}
   | inright : B -> A + {B} 
  where "A + { B }" := (sumor A B) : type_scope.
 
 Add Printing If sumor.
 
-(** Choice *)
+(** Various forms of the axiom of choice for specifications *)
 
 Section Choice_lemmas.
 
-  (** The following lemmas state various forms of the axiom of choice *)
-
   Variables S S' : Set.
   Variable R : S -> S' -> Prop.
   Variable R' : S -> S' -> Set.
@@ -138,12 +149,12 @@ Section Choice_lemmas.
   Qed.
 
   Lemma Choice2 :
-   (forall x:S, sigS (fun y:S' => R' x y)) ->
-   sigS (fun f:S -> S' => forall z:S, R' z (f z)).
+   (forall x:S, sigT (fun y:S' => R' x y)) ->
+   sigT (fun f:S -> S' => forall z:S, R' z (f z)).
   Proof.
     intro H.
     exists (fun z:S => match H z with
-                       | existS y _ => y
+                       | existT y _ => y
                        end).
     intro z; destruct (H z); trivial.
   Qed.
@@ -167,8 +178,10 @@ End Choice_lemmas.
 
  (** A result of type [(Exc A)] is either a normal value of type [A] or 
      an [error] :
-     [Inductive Exc [A:Set] : Set := value : A->(Exc A) | error : (Exc A)]
-     it is implemented using the option type. *) 
+
+     [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)].
+
+     It is implemented using the option type. *) 
 
 Definition Exc := option.
 Definition value := Some.
@@ -189,24 +202,18 @@ Qed.
 
 Hint Resolve left right inleft inright: core v62.
 
-(** Sigma Type at Type level [sigT] *)
-
-Inductive sigT (A:Type) (P:A -> Type) : Type :=
-    existT : forall x:A, P x -> sigT (A:=A) P.
-
-Section projections_sigT.
-
-  Variable A : Type.
-  Variable P : A -> Type.
-
-  Definition projT1 (H:sigT P) : A := match H with
-                                      | existT x _ => x
-                                      end.
-   
-  Definition projT2 : forall x:sigT P, P (projT1 x) :=
-    fun H:sigT P => match H return P (projT1 H) with
-                    | existT x h => h
-                    end.
-
-End projections_sigT.
-
+(* Compatibility *)
+
+Notation sigS := sigT (only parsing).
+Notation existS := existT (only parsing).
+Notation sigS_rect := sigT_rect (only parsing).
+Notation sigS_rec := sigT_rec (only parsing).
+Notation sigS_ind := sigT_ind (only parsing).
+Notation projS1 := projT1 (only parsing).
+Notation projS2 := projT2 (only parsing).
+
+Notation sigS2 := sigT2 (only parsing).
+Notation existS2 := existT2 (only parsing).
+Notation sigS2_rect := sigT2_rect (only parsing).
+Notation sigS2_rec := sigT2_rec (only parsing).
+Notation sigS2_ind := sigT2_ind (only parsing).
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
new file mode 100644
index 00000000..ba210dd6
--- /dev/null
+++ b/theories/Init/Tactics.v
@@ -0,0 +1,64 @@
+(************************************************************************)
+(*  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.v 9268 2006-10-24 12:56:16Z herbelin $ i*)
+
+Require Import Notations.
+Require Import Logic.
+
+(** Useful tactics *)
+
+(* A shorter name for generalize + clear, can be seen as an anti-intro *)
+
+Tactic Notation "revert" ne_hyp_list(l) := generalize l; clear l.
+
+(* to contradict an hypothesis without copying its type. *)
+
+Ltac absurd_hyp h := 
+  let T := type of h in 
+  absurd T.
+
+(* Transforming a negative goal [ H:~A |- ~B ] into a positive one [ B |- A ]*)
+
+Ltac swap H := intro; apply H; clear H.
+
+(* A case with no loss of information. *)
+
+Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x.
+
+(* A tactic for easing the use of lemmas f_equal, f_equal2, ... *)
+
+Ltac f_equal := 
+  let cg := try congruence in
+  let r := try reflexivity in 
+  match goal with 
+   | |- ?f ?a = ?f' ?a' => cut (a=a'); [cg|r]
+   | |- ?f ?a ?b = ?f' ?a' ?b' => 
+      cut (b=b');[cut (a=a');[cg|r]|r]
+   | |- ?f ?a ?b ?c = ?f' ?a' ?b' ?c'=> 
+      cut (c=c');[cut (b=b');[cut (a=a');[cg|r]|r]|r]
+   | |- ?f ?a ?b ?c ?d= ?f' ?a' ?b' ?c' ?d'=> 
+      cut (d=d');[cut (c=c');[cut (b=b');[cut (a=a');[cg|r]|r]|r]|r]
+  | |- ?f ?a ?b ?c ?d ?e= ?f' ?a' ?b' ?c' ?d' ?e'=> 
+      cut (e=e');[cut (d=d');[cut (c=c');[cut (b=b');[cut (a=a');[cg|r]|r]|r]|r]|r]
+   | _ => idtac
+  end.
+
+(* Rewriting in all hypothesis several times everywhere *)
+
+Tactic Notation "rewrite_all" constr(eq) := repeat rewrite eq in *.
+Tactic Notation "rewrite_all" "<-" constr(eq) := repeat rewrite <- eq in *.
+
+(* Keeping a copy of an expression *)
+
+Ltac remembertac x a :=
+  let x := fresh x in
+  let H := fresh "Heq" x in
+  (set (x:=a) in *; assert (H: x=a) by reflexivity; clearbody x).
+
+Tactic Notation "remember" constr(c) "as" ident(x) := remembertac x c.
diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v
index 7ab3723d..4e0f3745 100755..100644
--- a/theories/Init/Wf.v
+++ b/theories/Init/Wf.v
@@ -6,61 +6,59 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Set Implicit Arguments.
-
-(*i $Id: Wf.v,v 1.17.2.1 2004/07/16 19:31:04 herbelin Exp $ i*)
+(*i $Id: Wf.v 8988 2006-06-25 22:15:32Z letouzey $ i*)
 
 (** This module proves the validity of
     - well-founded recursion (also called course of values)
     - well-founded induction
 
-   from a well-founded ordering on a given set *)
+    from a well-founded ordering on a given set *)
+
+Set Implicit Arguments.
 
 Require Import Notations.
 Require Import Logic.
 Require Import Datatypes.
 
-(** Well-founded induction principle on Prop *)
+(** Well-founded induction principle on [Prop] *)
 
 Section Well_founded.
 
- Variable A : Set.
+ Variable A : Type.
  Variable R : A -> A -> Prop.
 
  (** The accessibility predicate is defined to be non-informative *)
 
- Inductive Acc : A -> Prop :=
-     Acc_intro : forall x:A, (forall y:A, R y x -> Acc y) -> Acc x.
+ Inductive Acc (x: A) : Prop :=
+     Acc_intro : (forall y:A, R y x -> Acc y) -> Acc x.
 
  Lemma Acc_inv : forall x:A, Acc x -> forall y:A, R y x -> Acc y.
   destruct 1; trivial.
  Defined.
 
-  (** the informative elimination :
+  (** Informative elimination :
      [let Acc_rec F = let rec wf x = F x wf in wf] *)
 
  Section AccRecType.
   Variable P : A -> Type.
-  Variable
-    F :
-      forall x:A,
-        (forall y:A, R y x -> Acc y) -> (forall y:A, R y x -> P y) -> P x.
+  Variable F : forall x:A,
+    (forall y:A, R y x -> Acc y) -> (forall y:A, R y x -> P y) -> P x.
 
   Fixpoint Acc_rect (x:A) (a:Acc x) {struct a} : P x :=
-    F (Acc_inv a) (fun (y:A) (h:R y x) => Acc_rect (x:=y) (Acc_inv a h)).
+    F (Acc_inv a) (fun (y:A) (h:R y x) => Acc_rect (Acc_inv a h)).
 
  End AccRecType.
 
  Definition Acc_rec (P:A -> Set) := Acc_rect P.
 
- (** A simplified version of Acc_rec(t) *)
+ (** A simplified version of [Acc_rect] *)
 
  Section AccIter.
-  Variable P : A -> Type. 
+  Variable P : A -> Type.
   Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x.
 
   Fixpoint Acc_iter (x:A) (a:Acc x) {struct a} : P x :=
-    F (fun (y:A) (h:R y x) => Acc_iter (x:=y) (Acc_inv a h)).
+    F (fun (y:A) (h:R y x) => Acc_iter (Acc_inv a h)).
 
  End AccIter.
 
@@ -68,7 +66,7 @@ Section Well_founded.
 
  Definition well_founded := forall a:A, Acc a.
 
- (** well-founded induction on Set and Prop *)
+ (** Well-founded induction on [Set] and [Prop] *)
 
  Hypothesis Rwf : well_founded.
 
@@ -95,47 +93,48 @@ Section Well_founded.
 
 (** Building fixpoints  *) 
 
-Section FixPoint.
+ Section FixPoint.
 
-Variable P : A -> Set.
-Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x.
-
-Fixpoint Fix_F (x:A) (r:Acc x) {struct r} : P x :=
-  F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)).
+  Variable P : A -> Type.
+  Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x.
 
-Definition Fix (x:A) := Fix_F (Rwf x).
+  Notation Fix_F := (Acc_iter P F) (only parsing). (* alias *)
 
-(** Proof that [well_founded_induction] satisfies the fixpoint equation. 
-    It requires an extra property of the functional *)
+  Definition Fix (x:A) := Acc_iter P F (Rwf x).
 
-Hypothesis
-  F_ext :
-    forall (x:A) (f g:forall y:A, R y x -> P y),
-      (forall (y:A) (p:R y x), f y p = g y p) -> F f = F g.
+  (** Proof that [well_founded_induction] satisfies the fixpoint equation. 
+      It requires an extra property of the functional *)
 
-Scheme Acc_inv_dep := Induction for Acc Sort Prop.
+  Hypothesis
+    F_ext :
+      forall (x:A) (f g:forall y:A, R y x -> P y),
+        (forall (y:A) (p:R y x), f y p = g y p) -> F f = F g.
 
-Lemma Fix_F_eq :
- forall (x:A) (r:Acc x),
-   F (fun (y:A) (p:R y x) => Fix_F (Acc_inv r p)) = Fix_F r.
-destruct r using Acc_inv_dep; auto.
-Qed.
+  Scheme Acc_inv_dep := Induction for Acc Sort Prop.
 
-Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F r = Fix_F s.
-intro x; induction (Rwf x); intros.
-rewrite <- (Fix_F_eq r); rewrite <- (Fix_F_eq s); intros.
-apply F_ext; auto.
-Qed.
+  Lemma Fix_F_eq :
+   forall (x:A) (r:Acc x),
+     F (fun (y:A) (p:R y x) => Fix_F y (Acc_inv r p)) = Fix_F x r.
+  Proof. 
+   destruct r using Acc_inv_dep; auto.
+  Qed.
 
+  Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F x r = Fix_F x s.
+  Proof.
+   intro x; induction (Rwf x); intros.
+   rewrite <- (Fix_F_eq r); rewrite <- (Fix_F_eq s); intros.
+   apply F_ext; auto.
+  Qed.
 
-Lemma Fix_eq : forall x:A, Fix x = F (fun (y:A) (p:R y x) => Fix y).
-intro x; unfold Fix in |- *.
-rewrite <- (Fix_F_eq (x:=x)).
-apply F_ext; intros.
-apply Fix_F_inv.
-Qed.
+  Lemma Fix_eq : forall x:A, Fix x = F (fun (y:A) (p:R y x) => Fix y).
+  Proof.
+   intro x; unfold Fix in |- *.
+   rewrite <- (Fix_F_eq (x:=x)).
+   apply F_ext; intros.
+   apply Fix_F_inv.
+  Qed.
 
-End FixPoint.
+ End FixPoint.
 
 End Well_founded. 
 
@@ -147,6 +146,8 @@ Section Well_founded_2.
   Variable R : A * B -> A * B -> Prop.
 
   Variable P : A -> B -> Type. 
+
+  Section Acc_iter_2.
   Variable
     F :
       forall (x:A) (x':B),
@@ -157,6 +158,7 @@ Section Well_founded_2.
     F
       (fun (y:A) (y':B) (h:R (y, y') (x, x')) =>
          Acc_iter_2 (x:=y) (x':=y') (Acc_inv a (y, y') h)).
+  End Acc_iter_2.
 
   Hypothesis Rwf : well_founded R.
 
@@ -169,3 +171,5 @@ Section Well_founded_2.
   Defined.
 
 End Well_founded_2.
+
+Notation Fix_F := Acc_iter (only parsing). (* compatibility *)
diff --git a/theories/IntMap/Adalloc.v b/theories/IntMap/Adalloc.v
index 9fde8f5f..ca8e7eeb 100644
--- a/theories/IntMap/Adalloc.v
+++ b/theories/IntMap/Adalloc.v
@@ -5,15 +5,15 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Adalloc.v,v 1.10.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Adalloc.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
 Require Import Arith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
+Require Import Nnat.
 Require Import Map.
 Require Import Fset.
 
@@ -21,215 +21,36 @@ Section AdAlloc.
 
   Variable A : Set.
 
-  Definition nat_of_ad (a:ad) :=
-    match a with
-    | ad_z => 0
-    | ad_x p => nat_of_P p
-    end.
-
-  Fixpoint nat_le (m:nat) : nat -> bool :=
-    match m with
-    | O => fun _:nat => true
-    | S m' =>
-        fun n:nat => match n with
-                     | O => false
-                     | S n' => nat_le m' n'
-                     end
-    end.
-
-  Lemma nat_le_correct : forall m n:nat, m <= n -> nat_le m n = true.
-  Proof.
-    induction m as [| m IHm]. trivial.
-    destruct n. intro H. elim (le_Sn_O _ H).
-    intros. simpl in |- *. apply IHm. apply le_S_n. assumption.
-  Qed.
-
-  Lemma nat_le_complete : forall m n:nat, nat_le m n = true -> m <= n.
-  Proof.
-    induction m. trivial with arith.
-    destruct n. intro H. discriminate H.
-    auto with arith.
-  Qed.
-
-  Lemma nat_le_correct_conv : forall m n:nat, m < n -> nat_le n m = false.
-  Proof.
-    intros. elim (sumbool_of_bool (nat_le n m)). intro H0.
-    elim (lt_irrefl _ (lt_le_trans _ _ _ H (nat_le_complete _ _ H0))).
-    trivial.
-  Qed.
-
-  Lemma nat_le_complete_conv : forall m n:nat, nat_le n m = false -> m < n.
-  Proof.
-    intros. elim (le_or_lt n m). intro. conditional trivial rewrite nat_le_correct in H. discriminate H.
-    trivial.
-  Qed.
-
-  Definition ad_of_nat (n:nat) :=
-    match n with
-    | O => ad_z
-    | S n' => ad_x (P_of_succ_nat n')
-    end.
-
-  Lemma ad_of_nat_of_ad : forall a:ad, ad_of_nat (nat_of_ad a) = a.
-  Proof.
-    destruct a as [| p]. reflexivity.
-    simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H.
-    rewrite nat_of_P_inj with (1 := H). reflexivity.
-  Qed.
-
-  Lemma nat_of_ad_of_nat : forall n:nat, nat_of_ad (ad_of_nat n) = n.
-  Proof.
-    induction n. trivial.
-    intros. simpl in |- *. apply nat_of_P_o_P_of_succ_nat_eq_succ.
-  Qed.
-
-  Definition ad_le (a b:ad) := nat_le (nat_of_ad a) (nat_of_ad b).
-
-  Lemma ad_le_refl : forall a:ad, ad_le a a = true.
-  Proof.
-    intro. unfold ad_le in |- *. apply nat_le_correct. apply le_n.
-  Qed.
-
-  Lemma ad_le_antisym :
-   forall a b:ad, ad_le a b = true -> ad_le b a = true -> a = b.
-  Proof.
-    unfold ad_le in |- *. intros. rewrite <- (ad_of_nat_of_ad a). rewrite <- (ad_of_nat_of_ad b).
-    rewrite (le_antisym _ _ (nat_le_complete _ _ H) (nat_le_complete _ _ H0)). reflexivity.
-  Qed.
-
-  Lemma ad_le_trans :
-   forall a b c:ad, ad_le a b = true -> ad_le b c = true -> ad_le a c = true.
-  Proof.
-    unfold ad_le in |- *. intros. apply nat_le_correct. apply le_trans with (m := nat_of_ad b).
-    apply nat_le_complete. assumption.
-    apply nat_le_complete. assumption.
-  Qed.
-
-  Lemma ad_le_lt_trans :
-   forall a b c:ad,
-     ad_le a b = true -> ad_le c b = false -> ad_le c a = false.
-  Proof.
-    unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply le_lt_trans with (m := nat_of_ad b).
-    apply nat_le_complete. assumption.
-    apply nat_le_complete_conv. assumption.
-  Qed.
-
-  Lemma ad_lt_le_trans :
-   forall a b c:ad,
-     ad_le b a = false -> ad_le b c = true -> ad_le c a = false.
-  Proof.
-    unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply lt_le_trans with (m := nat_of_ad b).
-    apply nat_le_complete_conv. assumption.
-    apply nat_le_complete. assumption.
-  Qed.
-
-  Lemma ad_lt_trans :
-   forall a b c:ad,
-     ad_le b a = false -> ad_le c b = false -> ad_le c a = false.
-  Proof.
-    unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply lt_trans with (m := nat_of_ad b).
-    apply nat_le_complete_conv. assumption.
-    apply nat_le_complete_conv. assumption.
-  Qed.
-
-  Lemma ad_lt_le_weak : forall a b:ad, ad_le b a = false -> ad_le a b = true.
-  Proof.
-    unfold ad_le in |- *. intros. apply nat_le_correct. apply lt_le_weak.
-    apply nat_le_complete_conv. assumption.
-  Qed.
-
-  Definition ad_min (a b:ad) := if ad_le a b then a else b.
-
-  Lemma ad_min_choice : forall a b:ad, {ad_min a b = a} + {ad_min a b = b}.
-  Proof.
-    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. left. rewrite H.
-    reflexivity.
-    intro H. right. rewrite H. reflexivity.
-  Qed.
-
-  Lemma ad_min_le_1 : forall a b:ad, ad_le (ad_min a b) a = true.
-  Proof.
-    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. rewrite H.
-    apply ad_le_refl.
-    intro H. rewrite H. apply ad_lt_le_weak. assumption.
-  Qed.
-
-  Lemma ad_min_le_2 : forall a b:ad, ad_le (ad_min a b) b = true.
-  Proof.
-    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. rewrite H. assumption.
-    intro H. rewrite H. apply ad_le_refl.
-  Qed.
-
-  Lemma ad_min_le_3 :
-   forall a b c:ad, ad_le a (ad_min b c) = true -> ad_le a b = true.
-  Proof.
-    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H.
-    assumption.
-    intro H0. rewrite H0 in H. apply ad_lt_le_weak. apply ad_le_lt_trans with (b := c); assumption.
-  Qed.
-
-  Lemma ad_min_le_4 :
-   forall a b c:ad, ad_le a (ad_min b c) = true -> ad_le a c = true.
-  Proof.
-    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H.
-    apply ad_le_trans with (b := b); assumption.
-    intro H0. rewrite H0 in H. assumption.
-  Qed.
-
-  Lemma ad_min_le_5 :
-   forall a b c:ad,
-     ad_le a b = true -> ad_le a c = true -> ad_le a (ad_min b c) = true.
-  Proof.
-    intros. elim (ad_min_choice b c). intro H1. rewrite H1. assumption.
-    intro H1. rewrite H1. assumption.
-  Qed.
-
-  Lemma ad_min_lt_3 :
-   forall a b c:ad, ad_le (ad_min b c) a = false -> ad_le b a = false.
-  Proof.
-    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H.
-    assumption.
-    intro H0. rewrite H0 in H. apply ad_lt_trans with (b := c); assumption.
-  Qed.
-
-  Lemma ad_min_lt_4 :
-   forall a b c:ad, ad_le (ad_min b c) a = false -> ad_le c a = false.
-  Proof.
-    unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H.
-    apply ad_lt_le_trans with (b := b); assumption.
-    intro H0. rewrite H0 in H. assumption.
-  Qed.
-
   (** Allocator: returns an address not in the domain of [m].
   This allocator is optimal in that it returns the lowest possible address,
   in the usual ordering on integers. It is not the most efficient, however. *)
   Fixpoint ad_alloc_opt (m:Map A) : ad :=
     match m with
-    | M0 => ad_z
-    | M1 a _ => if ad_eq a ad_z then ad_x 1 else ad_z
+    | M0 => N0
+    | M1 a _ => if Neqb a N0 then Npos 1 else N0
     | M2 m1 m2 =>
-        ad_min (ad_double (ad_alloc_opt m1))
-          (ad_double_plus_un (ad_alloc_opt m2))
+        Nmin (Ndouble (ad_alloc_opt m1))
+          (Ndouble_plus_one (ad_alloc_opt m2))
     end.
 
   Lemma ad_alloc_opt_allocates_1 :
-   forall m:Map A, MapGet A m (ad_alloc_opt m) = NONE A.
+   forall m:Map A, MapGet A m (ad_alloc_opt m) = None.
   Proof.
     induction m as [| a| m0 H m1 H0]. reflexivity.
-    simpl in |- *. elim (sumbool_of_bool (ad_eq a ad_z)). intro H. rewrite H.
-    rewrite (ad_eq_complete _ _ H). reflexivity.
+    simpl in |- *. elim (sumbool_of_bool (Neqb a N0)). intro H. rewrite H.
+    rewrite (Neqb_complete _ _ H). reflexivity.
     intro H. rewrite H. rewrite H. reflexivity.
     intros. change
-   (ad_alloc_opt (M2 A m0 m1)) with (ad_min (ad_double (ad_alloc_opt m0))
-                                       (ad_double_plus_un (ad_alloc_opt m1)))
+   (ad_alloc_opt (M2 A m0 m1)) with (Nmin (Ndouble (ad_alloc_opt m0))
+                                       (Ndouble_plus_one (ad_alloc_opt m1)))
   in |- *.
     elim
-     (ad_min_choice (ad_double (ad_alloc_opt m0))
-        (ad_double_plus_un (ad_alloc_opt m1))).
-    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption.
-    apply ad_double_bit_0.
-    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2. assumption.
-    apply ad_double_plus_un_bit_0.
+     (Nmin_choice (Ndouble (ad_alloc_opt m0))
+        (Ndouble_plus_one (ad_alloc_opt m1))).
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption.
+    apply Ndouble_bit0.
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2. assumption.
+    apply Ndouble_plus_one_bit0.
   Qed.
 
   Lemma ad_alloc_opt_allocates :
@@ -241,122 +62,30 @@ Section AdAlloc.
   (** Moreover, this is optimal: all addresses below [(ad_alloc_opt m)]
       are in [dom m]: *)
 
-  Lemma nat_of_ad_double :
-   forall a:ad, nat_of_ad (ad_double a) = 2 * nat_of_ad a.
-  Proof.
-    destruct a as [| p]. trivial.
-    exact (nat_of_P_xO p).
-  Qed.
-
-  Lemma nat_of_ad_double_plus_un :
-   forall a:ad, nat_of_ad (ad_double_plus_un a) = S (2 * nat_of_ad a).
-  Proof.
-    destruct a as [| p]. trivial.
-    exact (nat_of_P_xI p).
-  Qed.
-
-  Lemma ad_le_double_mono :
-   forall a b:ad,
-     ad_le a b = true -> ad_le (ad_double a) (ad_double b) = true.
-  Proof.
-    unfold ad_le in |- *. intros. rewrite nat_of_ad_double. rewrite nat_of_ad_double. apply nat_le_correct.
-    simpl in |- *. apply plus_le_compat. apply nat_le_complete. assumption.
-    apply plus_le_compat. apply nat_le_complete. assumption.
-    apply le_n.
-  Qed.
-
-  Lemma ad_le_double_plus_un_mono :
-   forall a b:ad,
-     ad_le a b = true ->
-     ad_le (ad_double_plus_un a) (ad_double_plus_un b) = true.
-  Proof.
-    unfold ad_le in |- *. intros. rewrite nat_of_ad_double_plus_un. rewrite nat_of_ad_double_plus_un.
-    apply nat_le_correct. apply le_n_S. simpl in |- *. apply plus_le_compat. apply nat_le_complete.
-    assumption.
-    apply plus_le_compat. apply nat_le_complete. assumption.
-    apply le_n.
-  Qed.
-
-  Lemma ad_le_double_mono_conv :
-   forall a b:ad,
-     ad_le (ad_double a) (ad_double b) = true -> ad_le a b = true.
-  Proof.
-    unfold ad_le in |- *. intros a b. rewrite nat_of_ad_double. rewrite nat_of_ad_double. intro.
-    apply nat_le_correct. apply (mult_S_le_reg_l 1). apply nat_le_complete. assumption.
-  Qed.
-
-  Lemma ad_le_double_plus_un_mono_conv :
-   forall a b:ad,
-     ad_le (ad_double_plus_un a) (ad_double_plus_un b) = true ->
-     ad_le a b = true.
-  Proof.
-    unfold ad_le in |- *. intros a b. rewrite nat_of_ad_double_plus_un. rewrite nat_of_ad_double_plus_un.
-    intro. apply nat_le_correct. apply (mult_S_le_reg_l 1). apply le_S_n. apply nat_le_complete.
-    assumption.
-  Qed.
-
-  Lemma ad_lt_double_mono :
-   forall a b:ad,
-     ad_le a b = false -> ad_le (ad_double a) (ad_double b) = false.
-  Proof.
-    intros. elim (sumbool_of_bool (ad_le (ad_double a) (ad_double b))). intro H0.
-    rewrite (ad_le_double_mono_conv _ _ H0) in H. discriminate H.
-    trivial.
-  Qed.
-
-  Lemma ad_lt_double_plus_un_mono :
-   forall a b:ad,
-     ad_le a b = false ->
-     ad_le (ad_double_plus_un a) (ad_double_plus_un b) = false.
-  Proof.
-    intros. elim (sumbool_of_bool (ad_le (ad_double_plus_un a) (ad_double_plus_un b))). intro H0.
-    rewrite (ad_le_double_plus_un_mono_conv _ _ H0) in H. discriminate H.
-    trivial.
-  Qed.
-
-  Lemma ad_lt_double_mono_conv :
-   forall a b:ad,
-     ad_le (ad_double a) (ad_double b) = false -> ad_le a b = false.
-  Proof.
-    intros. elim (sumbool_of_bool (ad_le a b)). intro H0. rewrite (ad_le_double_mono _ _ H0) in H.
-    discriminate H.
-    trivial.
-  Qed.
-
-  Lemma ad_lt_double_plus_un_mono_conv :
-   forall a b:ad,
-     ad_le (ad_double_plus_un a) (ad_double_plus_un b) = false ->
-     ad_le a b = false.
-  Proof.
-    intros. elim (sumbool_of_bool (ad_le a b)). intro H0.
-    rewrite (ad_le_double_plus_un_mono _ _ H0) in H. discriminate H.
-    trivial.
-  Qed.
-
   Lemma ad_alloc_opt_optimal_1 :
    forall (m:Map A) (a:ad),
-     ad_le (ad_alloc_opt m) a = false -> {y : A | MapGet A m a = SOME A y}.
+     Nle (ad_alloc_opt m) a = false -> {y : A | MapGet A m a = Some y}.
   Proof.
-    induction m as [| a y| m0 H m1 H0]. simpl in |- *. unfold ad_le in |- *. simpl in |- *. intros. discriminate H.
-    simpl in |- *. intros b H. elim (sumbool_of_bool (ad_eq a ad_z)). intro H0. rewrite H0 in H.
-    unfold ad_le in H. cut (ad_z = b). intro. split with y. rewrite <- H1. rewrite H0. reflexivity.
-    rewrite <- (ad_of_nat_of_ad b).
-    rewrite <- (le_n_O_eq _ (le_S_n _ _ (nat_le_complete_conv _ _ H))). reflexivity.
+    induction m as [| a y| m0 H m1 H0]. simpl in |- *. unfold Nle in |- *. simpl in |- *. intros. discriminate H.
+    simpl in |- *. intros b H. elim (sumbool_of_bool (Neqb a N0)). intro H0. rewrite H0 in H.
+    unfold Nle in H. cut (N0 = b). intro. split with y. rewrite <- H1. rewrite H0. reflexivity.
+    rewrite <- (N_of_nat_of_N b).
+    rewrite <- (le_n_O_eq _ (le_S_n _ _ (leb_complete_conv _ _ H))). reflexivity.
     intro H0. rewrite H0 in H. discriminate H.
-    intros. simpl in H1. elim (ad_double_or_double_plus_un a). intro H2. elim H2. intros a0 H3.
-    rewrite H3 in H1. elim (H _ (ad_lt_double_mono_conv _ _ (ad_min_lt_3 _ _ _ H1))). intros y H4.
-    split with y. rewrite H3. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption.
-    apply ad_double_bit_0.
+    intros. simpl in H1. elim (Ndouble_or_double_plus_un a). intro H2. elim H2. intros a0 H3.
+    rewrite H3 in H1. elim (H _ (Nlt_double_mono_conv _ _ (Nmin_lt_3 _ _ _ H1))). intros y H4.
+    split with y. rewrite H3. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption.
+    apply Ndouble_bit0.
     intro H2. elim H2. intros a0 H3. rewrite H3 in H1.
-    elim (H0 _ (ad_lt_double_plus_un_mono_conv _ _ (ad_min_lt_4 _ _ _ H1))). intros y H4.
-    split with y. rewrite H3. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2.
+    elim (H0 _ (Nlt_double_plus_one_mono_conv _ _ (Nmin_lt_4 _ _ _ H1))). intros y H4.
+    split with y. rewrite H3. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2.
     assumption.
-    apply ad_double_plus_un_bit_0.
+    apply Ndouble_plus_one_bit0.
   Qed.
 
   Lemma ad_alloc_opt_optimal :
    forall (m:Map A) (a:ad),
-     ad_le (ad_alloc_opt m) a = false -> in_dom A a m = true.
+     Nle (ad_alloc_opt m) a = false -> in_dom A a m = true.
   Proof.
     intros. unfold in_dom in |- *. elim (ad_alloc_opt_optimal_1 m a H). intros y H0. rewrite H0.
     reflexivity.
diff --git a/theories/IntMap/Addec.v b/theories/IntMap/Addec.v
deleted file mode 100644
index 7dba9ef6..00000000
--- a/theories/IntMap/Addec.v
+++ /dev/null
@@ -1,193 +0,0 @@
-(************************************************************************)
-(*  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: Addec.v,v 1.7.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
-
-(** Equality on adresses *)
-
-Require Import Bool.
-Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-
-Fixpoint ad_eq_1 (p1 p2:positive) {struct p2} : bool :=
-  match p1, p2 with
-  | xH, xH => true
-  | xO p'1, xO p'2 => ad_eq_1 p'1 p'2
-  | xI p'1, xI p'2 => ad_eq_1 p'1 p'2
-  | _, _ => false
-  end.
-
-Definition ad_eq (a a':ad) :=
-  match a, a' with
-  | ad_z, ad_z => true
-  | ad_x p, ad_x p' => ad_eq_1 p p'
-  | _, _ => false
-  end.
-
-Lemma ad_eq_correct : forall a:ad, ad_eq a a = true.
-Proof.
-  destruct a; trivial.
-  induction p; trivial.
-Qed.
-
-Lemma ad_eq_complete : forall a a':ad, ad_eq a a' = true -> a = a'.
-Proof.
-  destruct a. destruct a'; trivial. destruct p.
-  discriminate 1.
-  discriminate 1.
-  discriminate 1.
-  destruct a'. intros. discriminate H.
-  unfold ad_eq in |- *. intros. cut (p = p0). intros. rewrite H0. reflexivity.
-  generalize dependent p0.
-  induction p as [p IHp| p IHp| ]. destruct p0; intro H.
-  rewrite (IHp p0). reflexivity.
-  exact H.
-  discriminate H.
-  discriminate H.
-  destruct p0; intro H. discriminate H.
-  rewrite (IHp p0 H). reflexivity.
-  discriminate H.
-  destruct p0 as [p| p| ]; intro H. discriminate H.
-  discriminate H.
-  trivial.
-Qed.
-
-Lemma ad_eq_comm : forall a a':ad, ad_eq a a' = ad_eq a' a.
-Proof.
-  intros. cut (forall b b':bool, ad_eq a a' = b -> ad_eq a' a = b' -> b = b').
-  intros. apply H. reflexivity.
-  reflexivity.
-  destruct b. intros. cut (a = a').
-  intro. rewrite H1 in H0. rewrite (ad_eq_correct a') in H0. exact H0.
-  apply ad_eq_complete. exact H.
-  destruct b'. intros. cut (a' = a).
-  intro. rewrite H1 in H. rewrite H1 in H0. rewrite <- H. exact H0.
-  apply ad_eq_complete. exact H0.
-  trivial.
-Qed.
-
-Lemma ad_xor_eq_true :
- forall a a':ad, ad_xor a a' = ad_z -> ad_eq a a' = true.
-Proof.
-  intros. rewrite (ad_xor_eq a a' H). apply ad_eq_correct.
-Qed.
-
-Lemma ad_xor_eq_false :
- forall (a a':ad) (p:positive), ad_xor a a' = ad_x p -> ad_eq a a' = false.
-Proof.
-  intros. elim (sumbool_of_bool (ad_eq a a')). intro H0.
-  rewrite (ad_eq_complete a a' H0) in H. rewrite (ad_xor_nilpotent a') in H. discriminate H.
-  trivial.
-Qed.
-
-Lemma ad_bit_0_1_not_double :
- forall a:ad,
-   ad_bit_0 a = true -> forall a0:ad, ad_eq (ad_double a0) a = false.
-Proof.
-  intros. elim (sumbool_of_bool (ad_eq (ad_double a0) a)). intro H0.
-  rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_bit_0 a0) in H. discriminate H.
-  trivial.
-Qed.
-
-Lemma ad_not_div_2_not_double :
- forall a a0:ad,
-   ad_eq (ad_div_2 a) a0 = false -> ad_eq a (ad_double a0) = false.
-Proof.
-  intros. elim (sumbool_of_bool (ad_eq (ad_double a0) a)). intro H0.
-  rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_div_2 a0) in H.
-  rewrite (ad_eq_correct a0) in H. discriminate H.
-  intro. rewrite ad_eq_comm. assumption.
-Qed.
-
-Lemma ad_bit_0_0_not_double_plus_un :
- forall a:ad,
-   ad_bit_0 a = false -> forall a0:ad, ad_eq (ad_double_plus_un a0) a = false.
-Proof.
-  intros. elim (sumbool_of_bool (ad_eq (ad_double_plus_un a0) a)). intro H0.
-  rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_plus_un_bit_0 a0) in H.
-  discriminate H.
-  trivial.
-Qed.
-
-Lemma ad_not_div_2_not_double_plus_un :
- forall a a0:ad,
-   ad_eq (ad_div_2 a) a0 = false -> ad_eq (ad_double_plus_un a0) a = false.
-Proof.
-  intros. elim (sumbool_of_bool (ad_eq a (ad_double_plus_un a0))). intro H0.
-  rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_double_plus_un_div_2 a0) in H.
-  rewrite (ad_eq_correct a0) in H. discriminate H.
-  intro H0. rewrite ad_eq_comm. assumption.
-Qed.
-
-Lemma ad_bit_0_neq :
- forall a a':ad,
-   ad_bit_0 a = false -> ad_bit_0 a' = true -> ad_eq a a' = false.
-Proof.
-  intros. elim (sumbool_of_bool (ad_eq a a')). intro H1. rewrite (ad_eq_complete _ _ H1) in H.
-  rewrite H in H0. discriminate H0.
-  trivial.
-Qed.
-
-Lemma ad_div_eq :
- forall a a':ad, ad_eq a a' = true -> ad_eq (ad_div_2 a) (ad_div_2 a') = true.
-Proof.
-  intros. cut (a = a'). intros. rewrite H0. apply ad_eq_correct.
-  apply ad_eq_complete. exact H.
-Qed.
-
-Lemma ad_div_neq :
- forall a a':ad,
-   ad_eq (ad_div_2 a) (ad_div_2 a') = false -> ad_eq a a' = false.
-Proof.
-  intros. elim (sumbool_of_bool (ad_eq a a')). intro H0.
-  rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_eq_correct (ad_div_2 a')) in H. discriminate H.
-  trivial.
-Qed.
-
-Lemma ad_div_bit_eq :
- forall a a':ad,
-   ad_bit_0 a = ad_bit_0 a' -> ad_div_2 a = ad_div_2 a' -> a = a'.
-Proof.
-  intros. apply ad_faithful. unfold eqf in |- *. destruct n.
-  rewrite ad_bit_0_correct. rewrite ad_bit_0_correct. assumption.
-  rewrite <- ad_div_2_correct. rewrite <- ad_div_2_correct.
-  rewrite H0. reflexivity.
-Qed.
-
-Lemma ad_div_bit_neq :
- forall a a':ad,
-   ad_eq a a' = false ->
-   ad_bit_0 a = ad_bit_0 a' -> ad_eq (ad_div_2 a) (ad_div_2 a') = false.
-Proof.
-  intros. elim (sumbool_of_bool (ad_eq (ad_div_2 a) (ad_div_2 a'))). intro H1.
-  rewrite (ad_div_bit_eq _ _ H0 (ad_eq_complete _ _ H1)) in H.
-  rewrite (ad_eq_correct a') in H. discriminate H.
-  trivial.
-Qed.
-
-Lemma ad_neq :
- forall a a':ad,
-   ad_eq a a' = false ->
-   ad_bit_0 a = negb (ad_bit_0 a') \/
-   ad_eq (ad_div_2 a) (ad_div_2 a') = false.
-Proof.
-  intros. cut (ad_bit_0 a = ad_bit_0 a' \/ ad_bit_0 a = negb (ad_bit_0 a')).
-  intros. elim H0. intro. right. apply ad_div_bit_neq. assumption.
-  assumption.
-  intro. left. assumption.
-  case (ad_bit_0 a); case (ad_bit_0 a'); auto.
-Qed.
-
-Lemma ad_double_or_double_plus_un :
- forall a:ad,
-   {a0 : ad | a = ad_double a0} + {a1 : ad | a = ad_double_plus_un a1}.
-Proof.
-  intro. elim (sumbool_of_bool (ad_bit_0 a)). intro H. right. split with (ad_div_2 a).
-  rewrite (ad_div_2_double_plus_un a H). reflexivity.
-  intro H. left. split with (ad_div_2 a). rewrite (ad_div_2_double a H). reflexivity.
-Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Addr.v b/theories/IntMap/Addr.v
deleted file mode 100644
index 1370d72d..00000000
--- a/theories/IntMap/Addr.v
+++ /dev/null
@@ -1,491 +0,0 @@
-(************************************************************************)
-(*  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: Addr.v,v 1.8.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
-
-(** Representation of adresses by the [positive] type of binary numbers *)
-
-Require Import Bool.
-Require Import ZArith.
-
-Inductive ad : Set :=
-  | ad_z : ad
-  | ad_x : positive -> ad.
-
-Lemma ad_sum : forall a:ad, {p : positive | a = ad_x p} + {a = ad_z}.
-Proof.
-  destruct a; auto.
-  left; exists p; trivial.
-Qed.
-
-Fixpoint p_xor (p p2:positive) {struct p} : ad :=
-  match p with
-  | xH =>
-      match p2 with
-      | xH => ad_z
-      | xO p'2 => ad_x (xI p'2)
-      | xI p'2 => ad_x (xO p'2)
-      end
-  | xO p' =>
-      match p2 with
-      | xH => ad_x (xI p')
-      | xO p'2 =>
-          match p_xor p' p'2 with
-          | ad_z => ad_z
-          | ad_x p'' => ad_x (xO p'')
-          end
-      | xI p'2 =>
-          match p_xor p' p'2 with
-          | ad_z => ad_x 1
-          | ad_x p'' => ad_x (xI p'')
-          end
-      end
-  | xI p' =>
-      match p2 with
-      | xH => ad_x (xO p')
-      | xO p'2 =>
-          match p_xor p' p'2 with
-          | ad_z => ad_x 1
-          | ad_x p'' => ad_x (xI p'')
-          end
-      | xI p'2 =>
-          match p_xor p' p'2 with
-          | ad_z => ad_z
-          | ad_x p'' => ad_x (xO p'')
-          end
-      end
-  end.
-
-Definition ad_xor (a a':ad) :=
-  match a with
-  | ad_z => a'
-  | ad_x p => match a' with
-              | ad_z => a
-              | ad_x p' => p_xor p p'
-              end
-  end.
-
-Lemma ad_xor_neutral_left : forall a:ad, ad_xor ad_z a = a.
-Proof.
-  trivial.
-Qed.
-
-Lemma ad_xor_neutral_right : forall a:ad, ad_xor a ad_z = a.
-Proof.
-  destruct a; trivial.
-Qed.
-
-Lemma ad_xor_comm : forall a a':ad, ad_xor a a' = ad_xor a' a.
-Proof.
-  destruct a; destruct a'; simpl in |- *; auto.
-  generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl in |- *;
-   auto.
-  destruct p0; simpl in |- *; trivial; intros.
-  rewrite Hrecp; trivial.
-  rewrite Hrecp; trivial.
-  destruct p0; simpl in |- *; trivial; intros.
-  rewrite Hrecp; trivial.
-  rewrite Hrecp; trivial.
-  destruct p0 as [p| p| ]; simpl in |- *; auto.
-Qed.
-
-Lemma ad_xor_nilpotent : forall a:ad, ad_xor a a = ad_z.
-Proof.
-  destruct a; trivial.
-  simpl in |- *. induction p as [p IHp| p IHp| ]; trivial.
-  simpl in |- *. rewrite IHp; reflexivity.
-  simpl in |- *. rewrite IHp; reflexivity.
-Qed.
-
-Fixpoint ad_bit_1 (p:positive) : nat -> bool :=
-  match p with
-  | xH => fun n:nat => match n with
-                       | O => true
-                       | S _ => false
-                       end
-  | xO p =>
-      fun n:nat => match n with
-                   | O => false
-                   | S n' => ad_bit_1 p n'
-                   end
-  | xI p => fun n:nat => match n with
-                         | O => true
-                         | S n' => ad_bit_1 p n'
-                         end
-  end.
-
-Definition ad_bit (a:ad) :=
-  match a with
-  | ad_z => fun _:nat => false
-  | ad_x p => ad_bit_1 p
-  end.
-
-Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n.
-
-Lemma ad_faithful_1 : forall a:ad, eqf (ad_bit ad_z) (ad_bit a) -> ad_z = a.
-Proof.
-  destruct a. trivial.
-  induction p as [p IHp| p IHp| ]; intro H. absurd (ad_z = ad_x p). discriminate.
-  exact (IHp (fun n:nat => H (S n))).
-  absurd (ad_z = ad_x p). discriminate.
-  exact (IHp (fun n:nat => H (S n))).
-  absurd (false = true). discriminate.
-  exact (H 0).
-Qed.
-
-Lemma ad_faithful_2 :
- forall a:ad, eqf (ad_bit (ad_x 1)) (ad_bit a) -> ad_x 1 = a.
-Proof.
-  destruct a. intros. absurd (true = false). discriminate.
-  exact (H 0).
-  destruct p. intro H. absurd (ad_z = ad_x p). discriminate.
-  exact (ad_faithful_1 (ad_x p) (fun n:nat => H (S n))).
-  intros. absurd (true = false). discriminate.
-  exact (H 0).
-  trivial.
-Qed.
-
-Lemma ad_faithful_3 :
- forall (a:ad) (p:positive),
-   (forall p':positive, eqf (ad_bit (ad_x p)) (ad_bit (ad_x p')) -> p = p') ->
-   eqf (ad_bit (ad_x (xO p))) (ad_bit a) -> ad_x (xO p) = a.
-Proof.
-  destruct a. intros. cut (eqf (ad_bit ad_z) (ad_bit (ad_x (xO p)))).
-  intro. rewrite (ad_faithful_1 (ad_x (xO p)) H1). reflexivity.
-  unfold eqf in |- *. intro. unfold eqf in H0. rewrite H0. reflexivity.
-  case p. intros. absurd (false = true). discriminate.
-  exact (H0 0).
-  intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity.
-  intros. absurd (false = true). discriminate.
-  exact (H0 0).
-Qed.
-
-Lemma ad_faithful_4 :
- forall (a:ad) (p:positive),
-   (forall p':positive, eqf (ad_bit (ad_x p)) (ad_bit (ad_x p')) -> p = p') ->
-   eqf (ad_bit (ad_x (xI p))) (ad_bit a) -> ad_x (xI p) = a.
-Proof.
-  destruct a. intros. cut (eqf (ad_bit ad_z) (ad_bit (ad_x (xI p)))).
-  intro. rewrite (ad_faithful_1 (ad_x (xI p)) H1). reflexivity.
-  unfold eqf in |- *. intro. unfold eqf in H0. rewrite H0. reflexivity.
-  case p. intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity.
-  intros. absurd (true = false). discriminate.
-  exact (H0 0).
-  intros. absurd (ad_z = ad_x p0). discriminate.
-  cut (eqf (ad_bit (ad_x 1)) (ad_bit (ad_x (xI p0)))).
-  intro. exact (ad_faithful_1 (ad_x p0) (fun n:nat => H1 (S n))).
-  unfold eqf in |- *. unfold eqf in H0. intro. rewrite H0. reflexivity.
-Qed.
-
-Lemma ad_faithful : forall a a':ad, eqf (ad_bit a) (ad_bit a') -> a = a'.
-Proof.
-  destruct a. exact ad_faithful_1.
-  induction p. intros a' H. apply ad_faithful_4. intros. cut (ad_x p = ad_x p').
-  intro. inversion H1. reflexivity.
-  exact (IHp (ad_x p') H0).
-  assumption.
-  intros. apply ad_faithful_3. intros. cut (ad_x p = ad_x p'). intro. inversion H1. reflexivity.
-  exact (IHp (ad_x p') H0).
-  assumption.
-  exact ad_faithful_2.
-Qed.
-
-Definition adf_xor (f g:nat -> bool) (n:nat) := xorb (f n) (g n).
-
-Lemma ad_xor_sem_1 : forall a':ad, ad_bit (ad_xor ad_z a') 0 = ad_bit a' 0.
-Proof.
-  trivial.
-Qed.
-
-Lemma ad_xor_sem_2 :
- forall a':ad, ad_bit (ad_xor (ad_x 1) a') 0 = negb (ad_bit a' 0).
-Proof.
-  intro. case a'. trivial.
-  simpl in |- *. intro. 
-  case p; trivial.
-Qed.
-
-Lemma ad_xor_sem_3 :
- forall (p:positive) (a':ad),
-   ad_bit (ad_xor (ad_x (xO p)) a') 0 = ad_bit a' 0.
-Proof.
-  intros. case a'. trivial.
-  simpl in |- *. intro. 
-  case p0; trivial. intro. 
-  case (p_xor p p1); trivial.
-  intro. case (p_xor p p1); trivial.
-Qed.
-
-Lemma ad_xor_sem_4 :
- forall (p:positive) (a':ad),
-   ad_bit (ad_xor (ad_x (xI p)) a') 0 = negb (ad_bit a' 0).
-Proof.
-  intros. case a'. trivial.
-  simpl in |- *. intro. case p0; trivial. intro. 
-  case (p_xor p p1); trivial.
-  intro. 
-  case (p_xor p p1); trivial.
-Qed.
-
-Lemma ad_xor_sem_5 :
- forall a a':ad, ad_bit (ad_xor a a') 0 = adf_xor (ad_bit a) (ad_bit a') 0.
-Proof.
-  destruct a. intro. change (ad_bit a' 0 = xorb false (ad_bit a' 0)) in |- *. rewrite false_xorb. trivial.
-  case p. exact ad_xor_sem_4.
-  intros. change (ad_bit (ad_xor (ad_x (xO p0)) a') 0 = xorb false (ad_bit a' 0))
-  in |- *.
-  rewrite false_xorb. apply ad_xor_sem_3. exact ad_xor_sem_2.
-Qed.
-
-Lemma ad_xor_sem_6 :
- forall n:nat,
-   (forall a a':ad, ad_bit (ad_xor a a') n = adf_xor (ad_bit a) (ad_bit a') n) ->
-   forall a a':ad,
-     ad_bit (ad_xor a a') (S n) = adf_xor (ad_bit a) (ad_bit a') (S n).
-Proof.
-  intros. case a. unfold adf_xor in |- *. unfold ad_bit at 2 in |- *. rewrite false_xorb. reflexivity.
-  case a'. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. intro. rewrite xorb_false. reflexivity.
-  intros. case p0. case p. intros.
-  change
-    (ad_bit (ad_xor (ad_x (xI p2)) (ad_x (xI p1))) (S n) =
-     adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) 
-   in |- *.
-  rewrite <- H. simpl in |- *. 
-  case (p_xor p2 p1); trivial.
-  intros.
-  change
-    (ad_bit (ad_xor (ad_x (xI p2)) (ad_x (xO p1))) (S n) =
-     adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) 
-   in |- *.
-  rewrite <- H. simpl in |- *. 
-  case (p_xor p2 p1); trivial.
-  intro. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. unfold ad_bit_1 in |- *. rewrite xorb_false. reflexivity.
-  case p. intros.
-  change
-    (ad_bit (ad_xor (ad_x (xO p2)) (ad_x (xI p1))) (S n) =
-     adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) 
-   in |- *.
-  rewrite <- H. simpl in |- *. 
-  case (p_xor p2 p1); trivial.
-  intros.
-  change
-    (ad_bit (ad_xor (ad_x (xO p2)) (ad_x (xO p1))) (S n) =
-     adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) 
-   in |- *.
-  rewrite <- H. simpl in |- *. 
-  case (p_xor p2 p1); trivial.
-  intro. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. unfold ad_bit_1 in |- *. rewrite xorb_false. reflexivity.
-  unfold adf_xor in |- *. unfold ad_bit at 2 in |- *. unfold ad_bit_1 in |- *. rewrite false_xorb. simpl in |- *.   case p; trivial.
-Qed.
-
-Lemma ad_xor_semantics :
- forall a a':ad, eqf (ad_bit (ad_xor a a')) (adf_xor (ad_bit a) (ad_bit a')).
-Proof.
-  unfold eqf in |- *. intros. generalize a a'. elim n. exact ad_xor_sem_5.
-  exact ad_xor_sem_6.
-Qed.
-
-Lemma eqf_sym : forall f f':nat -> bool, eqf f f' -> eqf f' f.
-Proof.
-  unfold eqf in |- *. intros. rewrite H. reflexivity.
-Qed.
-
-Lemma eqf_refl : forall f:nat -> bool, eqf f f.
-Proof.
-  unfold eqf in |- *. trivial.
-Qed.
-
-Lemma eqf_trans :
- forall f f' f'':nat -> bool, eqf f f' -> eqf f' f'' -> eqf f f''.
-Proof.
-  unfold eqf in |- *. intros. rewrite H. exact (H0 n).
-Qed.
-
-Lemma adf_xor_eq :
- forall f f':nat -> bool, eqf (adf_xor f f') (fun n:nat => false) -> eqf f f'.
-Proof.
-  unfold eqf in |- *. unfold adf_xor in |- *. intros. apply xorb_eq. apply H.
-Qed.
-
-Lemma ad_xor_eq : forall a a':ad, ad_xor a a' = ad_z -> a = a'.
-Proof.
-  intros. apply ad_faithful. apply adf_xor_eq. apply eqf_trans with (f' := ad_bit (ad_xor a a')).
-  apply eqf_sym. apply ad_xor_semantics.
-  rewrite H. unfold eqf in |- *. trivial.
-Qed.
-
-Lemma adf_xor_assoc :
- forall f f' f'':nat -> bool,
-   eqf (adf_xor (adf_xor f f') f'') (adf_xor f (adf_xor f' f'')).
-Proof.
-  unfold eqf in |- *. unfold adf_xor in |- *. intros. apply xorb_assoc.
-Qed.
-
-Lemma eqf_xor_1 :
- forall f f' f'' f''':nat -> bool,
-   eqf f f' -> eqf f'' f''' -> eqf (adf_xor f f'') (adf_xor f' f''').
-Proof.
-  unfold eqf in |- *. intros. unfold adf_xor in |- *. rewrite H. rewrite H0. reflexivity.
-Qed.
-
-Lemma ad_xor_assoc :
- forall a a' a'':ad, ad_xor (ad_xor a a') a'' = ad_xor a (ad_xor a' a'').
-Proof.
-  intros. apply ad_faithful.
-  apply eqf_trans with
-   (f' := adf_xor (adf_xor (ad_bit a) (ad_bit a')) (ad_bit a'')).
-  apply eqf_trans with (f' := adf_xor (ad_bit (ad_xor a a')) (ad_bit a'')).
-  apply ad_xor_semantics.
-  apply eqf_xor_1. apply ad_xor_semantics.
-  apply eqf_refl.
-  apply eqf_trans with
-   (f' := adf_xor (ad_bit a) (adf_xor (ad_bit a') (ad_bit a''))).
-  apply adf_xor_assoc.
-  apply eqf_trans with (f' := adf_xor (ad_bit a) (ad_bit (ad_xor a' a''))).
-  apply eqf_xor_1. apply eqf_refl.
-  apply eqf_sym. apply ad_xor_semantics.
-  apply eqf_sym. apply ad_xor_semantics.
-Qed.
-
-Definition ad_double (a:ad) :=
-  match a with
-  | ad_z => ad_z
-  | ad_x p => ad_x (xO p)
-  end.
-
-Definition ad_double_plus_un (a:ad) :=
-  match a with
-  | ad_z => ad_x 1
-  | ad_x p => ad_x (xI p)
-  end.
-
-Definition ad_div_2 (a:ad) :=
-  match a with
-  | ad_z => ad_z
-  | ad_x xH => ad_z
-  | ad_x (xO p) => ad_x p
-  | ad_x (xI p) => ad_x p
-  end.
-
-Lemma ad_double_div_2 : forall a:ad, ad_div_2 (ad_double a) = a.
-Proof.
-  destruct a; trivial.
-Qed.
-
-Lemma ad_double_plus_un_div_2 :
- forall a:ad, ad_div_2 (ad_double_plus_un a) = a.
-Proof.
-  destruct a; trivial.
-Qed.
-
-Lemma ad_double_inj : forall a0 a1:ad, ad_double a0 = ad_double a1 -> a0 = a1.
-Proof.
-  intros. rewrite <- (ad_double_div_2 a0). rewrite H. apply ad_double_div_2.
-Qed.
-
-Lemma ad_double_plus_un_inj :
- forall a0 a1:ad, ad_double_plus_un a0 = ad_double_plus_un a1 -> a0 = a1.
-Proof.
-  intros. rewrite <- (ad_double_plus_un_div_2 a0). rewrite H. apply ad_double_plus_un_div_2.
-Qed.
-
-Definition ad_bit_0 (a:ad) :=
-  match a with
-  | ad_z => false
-  | ad_x (xO _) => false
-  | _ => true
-  end.
-
-Lemma ad_double_bit_0 : forall a:ad, ad_bit_0 (ad_double a) = false.
-Proof.
-  destruct a; trivial.
-Qed.
-
-Lemma ad_double_plus_un_bit_0 :
- forall a:ad, ad_bit_0 (ad_double_plus_un a) = true.
-Proof.
-  destruct a; trivial.
-Qed.
-
-Lemma ad_div_2_double :
- forall a:ad, ad_bit_0 a = false -> ad_double (ad_div_2 a) = a.
-Proof.
-  destruct a. trivial. destruct p. intro H. discriminate H.
-  intros. reflexivity.
-  intro H. discriminate H.
-Qed.
-
-Lemma ad_div_2_double_plus_un :
- forall a:ad, ad_bit_0 a = true -> ad_double_plus_un (ad_div_2 a) = a.
-Proof.
-  destruct a. intro. discriminate H.
-  destruct p. intros. reflexivity.
-  intro H. discriminate H.
-  intro. reflexivity.
-Qed.
-
-Lemma ad_bit_0_correct : forall a:ad, ad_bit a 0 = ad_bit_0 a.
-Proof.
-  destruct a; trivial.
-  destruct p; trivial.
-Qed.
-
-Lemma ad_div_2_correct :
- forall (a:ad) (n:nat), ad_bit (ad_div_2 a) n = ad_bit a (S n).
-Proof.
-  destruct a; trivial.
-  destruct p; trivial.
-Qed.
-
-Lemma ad_xor_bit_0 :
- forall a a':ad, ad_bit_0 (ad_xor a a') = xorb (ad_bit_0 a) (ad_bit_0 a').
-Proof.
-  intros. rewrite <- ad_bit_0_correct. rewrite (ad_xor_semantics a a' 0).
-  unfold adf_xor in |- *. rewrite ad_bit_0_correct. rewrite ad_bit_0_correct. reflexivity.
-Qed.
-
-Lemma ad_xor_div_2 :
- forall a a':ad, ad_div_2 (ad_xor a a') = ad_xor (ad_div_2 a) (ad_div_2 a').
-Proof.
-  intros. apply ad_faithful. unfold eqf in |- *. intro.
-  rewrite (ad_xor_semantics (ad_div_2 a) (ad_div_2 a') n).
-  rewrite ad_div_2_correct.
-  rewrite (ad_xor_semantics a a' (S n)).
-  unfold adf_xor in |- *. rewrite ad_div_2_correct. rewrite ad_div_2_correct.
-  reflexivity.
-Qed.
-
-Lemma ad_neg_bit_0 :
- forall a a':ad,
-   ad_bit_0 (ad_xor a a') = true -> ad_bit_0 a = negb (ad_bit_0 a').
-Proof.
-  intros. rewrite <- true_xorb. rewrite <- H. rewrite ad_xor_bit_0.
-  rewrite xorb_assoc. rewrite xorb_nilpotent. rewrite xorb_false. reflexivity.
-Qed.
-
-Lemma ad_neg_bit_0_1 :
- forall a a':ad, ad_xor a a' = ad_x 1 -> ad_bit_0 a = negb (ad_bit_0 a').
-Proof.
-  intros. apply ad_neg_bit_0. rewrite H. reflexivity.
-Qed.
-
-Lemma ad_neg_bit_0_2 :
- forall (a a':ad) (p:positive),
-   ad_xor a a' = ad_x (xI p) -> ad_bit_0 a = negb (ad_bit_0 a').
-Proof.
-  intros. apply ad_neg_bit_0. rewrite H. reflexivity.
-Qed.
-
-Lemma ad_same_bit_0 :
- forall (a a':ad) (p:positive),
-   ad_xor a a' = ad_x (xO p) -> ad_bit_0 a = ad_bit_0 a'.
-Proof.
-  intros. rewrite <- (xorb_false (ad_bit_0 a)). cut (ad_bit_0 (ad_x (xO p)) = false).
-  intro. rewrite <- H0. rewrite <- H. rewrite ad_xor_bit_0. rewrite <- xorb_assoc.
-  rewrite xorb_nilpotent. rewrite false_xorb. reflexivity.
-  reflexivity.
-Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Allmaps.v b/theories/IntMap/Allmaps.v
index 68744220..d5af8f80 100644
--- a/theories/IntMap/Allmaps.v
+++ b/theories/IntMap/Allmaps.v
@@ -5,17 +5,12 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Allmaps.v,v 1.3.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Allmaps.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
-Require Export Addr.
-Require Export Adist.
-Require Export Addec.
 Require Export Map.
-
 Require Export Fset.
 Require Export Mapaxioms.
 Require Export Mapiter.
-
 Require Export Mapsubset.
 Require Export Lsort.
 Require Export Mapfold.
diff --git a/theories/IntMap/Fset.v b/theories/IntMap/Fset.v
index 8d217be9..5b46c969 100644
--- a/theories/IntMap/Fset.v
+++ b/theories/IntMap/Fset.v
@@ -5,16 +5,15 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Fset.v,v 1.5.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Fset.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 (*s Sets operations on maps *)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 
 Section Dom.
@@ -26,7 +25,7 @@ Section Dom.
     | M0 => fun _:Map B => M0 A
     | M1 a y =>
         fun m':Map B => match MapGet B m' a with
-                        | NONE => M0 A
+                        | None => M0 A
                         | _ => m
                         end
     | M2 m1 m2 =>
@@ -35,8 +34,8 @@ Section Dom.
           | M0 => M0 A
           | M1 a' y' =>
               match MapGet A m a' with
-              | NONE => M0 A
-              | SOME y => M1 A a' y
+              | None => M0 A
+              | Some y => M1 A a' y
               end
           | M2 m'1 m'2 =>
               makeM2 A (MapDomRestrTo m1 m'1) (MapDomRestrTo m2 m'2)
@@ -48,35 +47,35 @@ Section Dom.
      eqm A (MapGet A (MapDomRestrTo m m'))
        (fun a0:ad =>
           match MapGet B m' a0 with
-          | NONE => NONE A
+          | None => None
           | _ => MapGet A m a0
           end).
   Proof.
     unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial.
-    intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a a1)). intro H. rewrite H.
-    rewrite <- (ad_eq_complete _ _ H). case (MapGet B m' a). reflexivity.
+    intros. simpl in |- *. elim (sumbool_of_bool (Neqb a a1)). intro H. rewrite H.
+    rewrite <- (Neqb_complete _ _ H). case (MapGet B m' a); try reflexivity.
     intro. apply M1_semantics_1.
     intro H. rewrite H. case (MapGet B m' a). 
-    case (MapGet B m' a1); reflexivity.
     case (MapGet B m' a1); intros; exact (M1_semantics_2 A a a1 a0 H).
+    case (MapGet B m' a1); reflexivity.
     simple induction m'. trivial.
-    unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)).
+    unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (Neqb a a1)).
     intro H1.
-    rewrite (ad_eq_complete _ _ H1). rewrite (M1_semantics_1 B a1 a0).
-    case (MapGet A (M2 A m0 m1) a1). reflexivity.
+    rewrite (Neqb_complete _ _ H1). rewrite (M1_semantics_1 B a1 a0).
+    case (MapGet A (M2 A m0 m1) a1); try reflexivity.
     intro. apply M1_semantics_1.
-    intro H1. rewrite (M1_semantics_2 B a a1 a0 H1). case (MapGet A (M2 A m0 m1) a). reflexivity.
+    intro H1. rewrite (M1_semantics_2 B a a1 a0 H1). case (MapGet A (M2 A m0 m1) a); try reflexivity.
     intro. exact (M1_semantics_2 A a a1 a2 H1).
     intros. change
    (MapGet A (makeM2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3)) a =
     match MapGet B (M2 B m2 m3) a with
-    | NONE => NONE A
-    | SOME _ => MapGet A (M2 A m0 m1) a
+    | None => None
+    | Some _ => MapGet A (M2 A m0 m1) a
     end) in |- *.
     rewrite (makeM2_M2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3) a).
-    rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)).
+    rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 a)).
     rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a).
-    case (ad_bit_0 a); reflexivity.
+    case (Nbit0 a); reflexivity.
   Qed.
 
   Fixpoint MapDomRestrBy (m:Map A) : Map B -> Map A :=
@@ -84,7 +83,7 @@ Section Dom.
     | M0 => fun _:Map B => M0 A
     | M1 a y =>
         fun m':Map B => match MapGet B m' a with
-                        | NONE => m
+                        | None => m
                         | _ => M0 A
                         end
     | M2 m1 m2 =>
@@ -102,37 +101,38 @@ Section Dom.
      eqm A (MapGet A (MapDomRestrBy m m'))
        (fun a0:ad =>
           match MapGet B m' a0 with
-          | NONE => MapGet A m a0
-          | _ => NONE A
+          | None => MapGet A m a0
+          | _ => None
           end).
   Proof.
     unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial.
-    intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a a1)). intro H. rewrite H.
-    rewrite (ad_eq_complete _ _ H). case (MapGet B m' a1). apply M1_semantics_1.
-    trivial.
-    intro H. rewrite H. case (MapGet B m' a). rewrite (M1_semantics_2 A a a1 a0 H).
+    intros. simpl in |- *. elim (sumbool_of_bool (Neqb a a1)). intro H. rewrite H.
+    rewrite (Neqb_complete _ _ H). case (MapGet B m' a1). trivial.
+    apply M1_semantics_1.
+    intro H. rewrite H. case (MapGet B m' a). 
     case (MapGet B m' a1); trivial.
+    rewrite (M1_semantics_2 A a a1 a0 H).
     case (MapGet B m' a1); trivial.
     simple induction m'. trivial.
     unfold MapDomRestrBy in |- *. intros. rewrite (MapRemove_semantics A (M2 A m0 m1) a a1).
-    elim (sumbool_of_bool (ad_eq a a1)). intro H1. rewrite H1. rewrite (ad_eq_complete _ _ H1).
+    elim (sumbool_of_bool (Neqb a a1)). intro H1. rewrite H1. rewrite (Neqb_complete _ _ H1).
     rewrite (M1_semantics_1 B a1 a0). reflexivity.
     intro H1. rewrite H1. rewrite (M1_semantics_2 B a a1 a0 H1). reflexivity.
     intros. change
    (MapGet A (makeM2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3)) a =
     match MapGet B (M2 B m2 m3) a with
-    | NONE => MapGet A (M2 A m0 m1) a
-    | SOME _ => NONE A
+    | None => MapGet A (M2 A m0 m1) a
+    | Some _ => None
     end) in |- *.
     rewrite (makeM2_M2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3) a).
-    rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)).
+    rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 a)).
     rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a).
-    case (ad_bit_0 a); reflexivity.
+    case (Nbit0 a); reflexivity.
   Qed.
 
   Definition in_dom (a:ad) (m:Map A) :=
     match MapGet A m a with
-    | NONE => false
+    | None => false
     | _ => true
     end.
 
@@ -141,32 +141,32 @@ Section Dom.
     trivial.
   Qed.
 
-  Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = ad_eq a a0.
+  Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = Neqb a a0.
   Proof.
-    unfold in_dom in |- *. intros. simpl in |- *. case (ad_eq a a0); reflexivity.
+    unfold in_dom in |- *. intros. simpl in |- *. case (Neqb a a0); reflexivity.
   Qed.
 
   Lemma in_dom_M1_1 : forall (a:ad) (y:A), in_dom a (M1 A a y) = true.
   Proof.
-    intros. rewrite in_dom_M1. apply ad_eq_correct.
+    intros. rewrite in_dom_M1. apply Neqb_correct.
   Qed.
 
   Lemma in_dom_M1_2 :
    forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = true -> a = a0.
   Proof.
-    intros. apply (ad_eq_complete a a0). rewrite (in_dom_M1 a a0 y) in H. assumption.
+    intros. apply (Neqb_complete a a0). rewrite (in_dom_M1 a a0 y) in H. assumption.
   Qed.
 
   Lemma in_dom_some :
    forall (m:Map A) (a:ad),
-     in_dom a m = true -> {y : A | MapGet A m a = SOME A y}.
+     in_dom a m = true -> {y : A | MapGet A m a = Some y}.
   Proof.
     unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). trivial.
     intro H0. rewrite H0 in H. discriminate H.
   Qed.
 
   Lemma in_dom_none :
-   forall (m:Map A) (a:ad), in_dom a m = false -> MapGet A m a = NONE A.
+   forall (m:Map A) (a:ad), in_dom a m = false -> MapGet A m a = None.
   Proof.
     unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). intro H0. elim H0.
     intros y H1. rewrite H1 in H. discriminate H.
@@ -175,33 +175,33 @@ Section Dom.
 
   Lemma in_dom_put :
    forall (m:Map A) (a0:ad) (y0:A) (a:ad),
-     in_dom a (MapPut A m a0 y0) = orb (ad_eq a a0) (in_dom a m).
+     in_dom a (MapPut A m a0 y0) = orb (Neqb a a0) (in_dom a m).
   Proof.
     unfold in_dom in |- *. intros. rewrite (MapPut_semantics A m a0 y0 a).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H.
+    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
     rewrite H. rewrite orb_true_b. reflexivity.
-    intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H. rewrite orb_false_b.
+    intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. rewrite orb_false_b.
     reflexivity.
   Qed.
 
   Lemma in_dom_put_behind :
    forall (m:Map A) (a0:ad) (y0:A) (a:ad),
-     in_dom a (MapPut_behind A m a0 y0) = orb (ad_eq a a0) (in_dom a m).
+     in_dom a (MapPut_behind A m a0 y0) = orb (Neqb a a0) (in_dom a m).
   Proof.
     unfold in_dom in |- *. intros. rewrite (MapPut_behind_semantics A m a0 y0 a).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H.
+    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
     rewrite H. case (MapGet A m a); reflexivity.
-    intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H. case (MapGet A m a); trivial.
+    intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. case (MapGet A m a); trivial.
   Qed.
 
   Lemma in_dom_remove :
    forall (m:Map A) (a0 a:ad),
-     in_dom a (MapRemove A m a0) = andb (negb (ad_eq a a0)) (in_dom a m).
+     in_dom a (MapRemove A m a0) = andb (negb (Neqb a a0)) (in_dom a m).
   Proof.
     unfold in_dom in |- *. intros. rewrite (MapRemove_semantics A m a0 a).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H.
+    elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
     rewrite H. reflexivity.
-    intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H.
+    intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H.
     case (MapGet A m a); reflexivity.
   Qed.
 
@@ -272,35 +272,35 @@ Section FSetDefs.
 
   Lemma MapDom_semantics_1 :
    forall (m:Map A) (a:ad) (y:A),
-     MapGet A m a = SOME A y -> in_FSet a (MapDom m) = true.
+     MapGet A m a = Some y -> in_FSet a (MapDom m) = true.
   Proof.
     simple induction m. intros. discriminate H.
     unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0 y0.
-    case (ad_eq a a0). trivial.
+    case (Neqb a a0). trivial.
     intro. discriminate H.
     intros m0 H m1 H0 a y. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *.
     unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
-    case (ad_bit_0 a). unfold in_FSet, in_dom in H0. intro. apply H0 with (y := y). assumption.
+    case (Nbit0 a). unfold in_FSet, in_dom in H0. intro. apply H0 with (y := y). assumption.
     unfold in_FSet, in_dom in H. intro. apply H with (y := y). assumption.
   Qed.
 
   Lemma MapDom_semantics_2 :
    forall (m:Map A) (a:ad),
-     in_FSet a (MapDom m) = true -> {y : A | MapGet A m a = SOME A y}.
+     in_FSet a (MapDom m) = true -> {y : A | MapGet A m a = Some y}.
   Proof.
     simple induction m. intros. discriminate H.
-    unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0. case (ad_eq a a0).
+    unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0. case (Neqb a a0).
     intro. split with y. reflexivity.
     intro. discriminate H.
     intros m0 H m1 H0 a. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *.
     unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
-    case (ad_bit_0 a). unfold in_FSet, in_dom in H0. intro. apply H0. assumption.
+    case (Nbit0 a). unfold in_FSet, in_dom in H0. intro. apply H0. assumption.
     unfold in_FSet, in_dom in H. intro. apply H. assumption.
   Qed.
 
   Lemma MapDom_semantics_3 :
    forall (m:Map A) (a:ad),
-     MapGet A m a = NONE A -> in_FSet a (MapDom m) = false.
+     MapGet A m a = None -> in_FSet a (MapDom m) = false.
   Proof.
     intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H0.
     elim (MapDom_semantics_2 m a H0). intros y H1. rewrite H in H1. discriminate H1.
@@ -309,7 +309,7 @@ Section FSetDefs.
 
   Lemma MapDom_semantics_4 :
    forall (m:Map A) (a:ad),
-     in_FSet a (MapDom m) = false -> MapGet A m a = NONE A.
+     in_FSet a (MapDom m) = false -> MapGet A m a = None.
   Proof.
     intros. elim (option_sum A (MapGet A m a)). intro H0. elim H0. intros y H1.
     rewrite (MapDom_semantics_1 m a y H1) in H. discriminate H.
diff --git a/theories/IntMap/Lsort.v b/theories/IntMap/Lsort.v
index 48972872..c8d793a1 100644
--- a/theories/IntMap/Lsort.v
+++ b/theories/IntMap/Lsort.v
@@ -5,15 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Lsort.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Lsort.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import List.
 Require Import Mapiter.
@@ -22,199 +21,19 @@ Section LSort.
 
   Variable A : Set.
 
-  Fixpoint ad_less_1 (a a':ad) (p:positive) {struct p} : bool :=
-    match p with
-    | xO p' => ad_less_1 (ad_div_2 a) (ad_div_2 a') p'
-    | _ => andb (negb (ad_bit_0 a)) (ad_bit_0 a')
-    end.
-
-  Definition ad_less (a a':ad) :=
-    match ad_xor a a' with
-    | ad_z => false
-    | ad_x p => ad_less_1 a a' p
-    end.
-
-  Lemma ad_bit_0_less :
-   forall a a':ad,
-     ad_bit_0 a = false -> ad_bit_0 a' = true -> ad_less a a' = true.
-  Proof.
-    intros. elim (ad_sum (ad_xor a a')). intro H1. elim H1. intros p H2. unfold ad_less in |- *.
-    rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
-    intros. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H5.
-    rewrite H in H5. rewrite H0 in H5. discriminate H5.
-    rewrite H4. reflexivity.
-    intro. simpl in |- *. rewrite H. rewrite H0. reflexivity.
-    intro H1. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H2.
-    rewrite H in H2. rewrite H0 in H2. discriminate H2.
-    rewrite H1. reflexivity.
-  Qed.
-
-  Lemma ad_bit_0_gt :
-   forall a a':ad,
-     ad_bit_0 a = true -> ad_bit_0 a' = false -> ad_less a a' = false.
-  Proof.
-    intros. elim (ad_sum (ad_xor a a')). intro H1. elim H1. intros p H2. unfold ad_less in |- *.
-    rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
-    intros. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H5.
-    rewrite H in H5. rewrite H0 in H5. discriminate H5.
-    rewrite H4. reflexivity.
-    intro. simpl in |- *. rewrite H. rewrite H0. reflexivity.
-    intro H1. unfold ad_less in |- *. rewrite H1. reflexivity.
-  Qed.
-
-  Lemma ad_less_not_refl : forall a:ad, ad_less a a = false.
-  Proof.
-    intro. unfold ad_less in |- *. rewrite (ad_xor_nilpotent a). reflexivity.
-  Qed.
-
-  Lemma ad_ind_double :
-   forall (a:ad) (P:ad -> Prop),
-     P ad_z ->
-     (forall a:ad, P a -> P (ad_double a)) ->
-     (forall a:ad, P a -> P (ad_double_plus_un a)) -> P a.
-  Proof.
-    intros; elim a. trivial.
-    simple induction p. intros. 
-    apply (H1 (ad_x p0)); trivial.
-    intros; apply (H0 (ad_x p0)); trivial.
-    intros; apply (H1 ad_z); assumption.
-  Qed.
-
-  Lemma ad_rec_double :
-   forall (a:ad) (P:ad -> Set),
-     P ad_z ->
-     (forall a:ad, P a -> P (ad_double a)) ->
-     (forall a:ad, P a -> P (ad_double_plus_un a)) -> P a.
-  Proof.
-    intros; elim a. trivial.
-    simple induction p. intros. 
-    apply (H1 (ad_x p0)); trivial.
-    intros; apply (H0 (ad_x p0)); trivial.
-    intros; apply (H1 ad_z); assumption.
-  Qed.
-
-  Lemma ad_less_def_1 :
-   forall a a':ad, ad_less (ad_double a) (ad_double a') = ad_less a a'.
-  Proof.
-    simple induction a. simple induction a'. reflexivity.
-    trivial.
-    simple induction a'. unfold ad_less in |- *. simpl in |- *. elim p; trivial.
-    unfold ad_less in |- *. simpl in |- *. intro. case (p_xor p p0). reflexivity.
-    trivial.
-  Qed.
-
-  Lemma ad_less_def_2 :
-   forall a a':ad,
-     ad_less (ad_double_plus_un a) (ad_double_plus_un a') = ad_less a a'.
-  Proof.
-    simple induction a. simple induction a'. reflexivity.
-    trivial.
-    simple induction a'. unfold ad_less in |- *. simpl in |- *. elim p; trivial.
-    unfold ad_less in |- *. simpl in |- *. intro. case (p_xor p p0). reflexivity.
-    trivial.
-  Qed.
-
-  Lemma ad_less_def_3 :
-   forall a a':ad, ad_less (ad_double a) (ad_double_plus_un a') = true.
-  Proof.
-    intros. apply ad_bit_0_less. apply ad_double_bit_0.
-    apply ad_double_plus_un_bit_0.
-  Qed.
-
-  Lemma ad_less_def_4 :
-   forall a a':ad, ad_less (ad_double_plus_un a) (ad_double a') = false.
-  Proof.
-    intros. apply ad_bit_0_gt. apply ad_double_plus_un_bit_0.
-    apply ad_double_bit_0.
-  Qed.
-
-  Lemma ad_less_z : forall a:ad, ad_less a ad_z = false.
-  Proof.
-    simple induction a. reflexivity.
-    unfold ad_less in |- *. intro. rewrite (ad_xor_neutral_right (ad_x p)). elim p; trivial.
-  Qed.
-
-  Lemma ad_z_less_1 :
-   forall a:ad, ad_less ad_z a = true -> {p : positive | a = ad_x p}.
-  Proof.
-    simple induction a. intro. discriminate H.
-    intros. split with p. reflexivity.
-  Qed.
-
-  Lemma ad_z_less_2 : forall a:ad, ad_less ad_z a = false -> a = ad_z.
-  Proof.
-    simple induction a. trivial.
-    unfold ad_less in |- *. simpl in |- *. cut (forall p:positive, ad_less_1 ad_z (ad_x p) p = false -> False).
-    intros. elim (H p H0).
-    simple induction p. intros. discriminate H0.
-    intros. exact (H H0).
-    intro. discriminate H.
-  Qed.
-
-  Lemma ad_less_trans :
-   forall a a' a'':ad,
-     ad_less a a' = true -> ad_less a' a'' = true -> ad_less a a'' = true.
-  Proof.
-    intro a. apply ad_ind_double with
-  (P := fun a:ad =>
-          forall a' a'':ad,
-            ad_less a a' = true ->
-            ad_less a' a'' = true -> ad_less a a'' = true).
-    intros. elim (sumbool_of_bool (ad_less ad_z a'')). trivial.
-    intro H1. rewrite (ad_z_less_2 a'' H1) in H0. rewrite (ad_less_z a') in H0. discriminate H0.
-    intros a0 H a'. apply ad_ind_double with
-  (P := fun a':ad =>
-          forall a'':ad,
-            ad_less (ad_double a0) a' = true ->
-            ad_less a' a'' = true -> ad_less (ad_double a0) a'' = true).
-    intros. rewrite (ad_less_z (ad_double a0)) in H0. discriminate H0.
-    intros a1 H0 a'' H1. rewrite (ad_less_def_1 a0 a1) in H1.
-    apply ad_ind_double with
-     (P := fun a'':ad =>
-             ad_less (ad_double a1) a'' = true ->
-             ad_less (ad_double a0) a'' = true).
-    intro. rewrite (ad_less_z (ad_double a1)) in H2. discriminate H2.
-    intros. rewrite (ad_less_def_1 a1 a2) in H3. rewrite (ad_less_def_1 a0 a2).
-    exact (H a1 a2 H1 H3).
-    intros. apply ad_less_def_3.
-    intros a1 H0 a'' H1. apply ad_ind_double with
-  (P := fun a'':ad =>
-          ad_less (ad_double_plus_un a1) a'' = true ->
-          ad_less (ad_double a0) a'' = true).
-    intro. rewrite (ad_less_z (ad_double_plus_un a1)) in H2. discriminate H2.
-    intros. rewrite (ad_less_def_4 a1 a2) in H3. discriminate H3.
-    intros. apply ad_less_def_3.
-    intros a0 H a'. apply ad_ind_double with
-  (P := fun a':ad =>
-          forall a'':ad,
-            ad_less (ad_double_plus_un a0) a' = true ->
-            ad_less a' a'' = true ->
-            ad_less (ad_double_plus_un a0) a'' = true).
-    intros. rewrite (ad_less_z (ad_double_plus_un a0)) in H0. discriminate H0.
-    intros. rewrite (ad_less_def_4 a0 a1) in H1. discriminate H1.
-    intros a1 H0 a'' H1. apply ad_ind_double with
-  (P := fun a'':ad =>
-          ad_less (ad_double_plus_un a1) a'' = true ->
-          ad_less (ad_double_plus_un a0) a'' = true).
-    intro. rewrite (ad_less_z (ad_double_plus_un a1)) in H2. discriminate H2.
-    intros. rewrite (ad_less_def_4 a1 a2) in H3. discriminate H3.
-    rewrite (ad_less_def_2 a0 a1) in H1. intros. rewrite (ad_less_def_2 a1 a2) in H3.
-    rewrite (ad_less_def_2 a0 a2). exact (H a1 a2 H1 H3).
-  Qed.
-
   Fixpoint alist_sorted (l:alist A) : bool :=
     match l with
     | nil => true
     | (a, _) :: l' =>
         match l' with
         | nil => true
-        | (a', y') :: l'' => andb (ad_less a a') (alist_sorted l')
+        | (a', y') :: l'' => andb (Nless a a') (alist_sorted l')
         end
     end.
 
   Fixpoint alist_nth_ad (n:nat) (l:alist A) {struct l} : ad :=
     match l with
-    | nil => ad_z (* dummy *)
+    | nil => N0 (* dummy *)
     | (a, y) :: l' => match n with
                       | O => a
                       | S n' => alist_nth_ad n' l'
@@ -224,7 +43,7 @@ Section LSort.
   Definition alist_sorted_1 (l:alist A) :=
     forall n:nat,
       S (S n) <= length l ->
-      ad_less (alist_nth_ad n l) (alist_nth_ad (S n) l) = true.
+      Nless (alist_nth_ad n l) (alist_nth_ad (S n) l) = true.
 
   Lemma alist_sorted_imp_1 :
    forall l:alist A, alist_sorted l = true -> alist_sorted_1 l.
@@ -235,7 +54,7 @@ Section LSort.
     intro r0. elim r0. intros a0 y0. simple induction n. intros. simpl in |- *. simpl in H1.
     exact (proj1 (andb_prop _ _ H1)).
     intros. change
-   (ad_less (alist_nth_ad n0 ((a0, y0) :: l1))
+   (Nless (alist_nth_ad n0 ((a0, y0) :: l1))
       (alist_nth_ad (S n0) ((a0, y0) :: l1)) = true) 
   in |- *.
     apply H0. exact (proj2 (andb_prop _ _ H1)).
@@ -245,13 +64,13 @@ Section LSort.
   Definition alist_sorted_2 (l:alist A) :=
     forall m n:nat,
       m < n ->
-      S n <= length l -> ad_less (alist_nth_ad m l) (alist_nth_ad n l) = true.
+      S n <= length l -> Nless (alist_nth_ad m l) (alist_nth_ad n l) = true.
 
   Lemma alist_sorted_1_imp_2 :
    forall l:alist A, alist_sorted_1 l -> alist_sorted_2 l.
   Proof.
     unfold alist_sorted_1, alist_sorted_2, lt in |- *. intros l H m n H0. elim H0. exact (H m).
-    intros. apply ad_less_trans with (a' := alist_nth_ad m0 l). apply H2. apply le_Sn_le.
+    intros. apply Nless_trans with (a' := alist_nth_ad m0 l). apply H2. apply le_Sn_le.
     assumption.
     apply H. assumption.
   Qed.
@@ -262,7 +81,7 @@ Section LSort.
     unfold alist_sorted_2, lt in |- *. simple induction l. trivial.
     intro r. elim r. intros a y. simple induction l0. trivial.
     intro r0. elim r0. intros a0 y0. intros.
-    change (andb (ad_less a a0) (alist_sorted ((a0, y0) :: l1)) = true)
+    change (andb (Nless a a0) (alist_sorted ((a0, y0) :: l1)) = true)
      in |- *.
     apply andb_true_intro. split. apply (H1 0 1). apply le_n.
     simpl in |- *. apply le_n_S. apply le_n_S. apply le_O_n.
@@ -319,7 +138,7 @@ Section LSort.
      (forall n n':nat,
         S n <= length l ->
         S n' <= length l' ->
-        ad_less (alist_nth_ad n l) (alist_nth_ad n' l') = true) ->
+        Nless (alist_nth_ad n l) (alist_nth_ad n' l') = true) ->
      alist_sorted_2 (aapp A l l').
   Proof.
     unfold alist_sorted_2, lt in |- *. intros. rewrite (aapp_length l l') in H3.
@@ -348,14 +167,14 @@ Section LSort.
   Lemma alist_nth_ad_semantics :
    forall (l:alist A) (n:nat),
      S n <= length l ->
-     {y : A | alist_semantics A l (alist_nth_ad n l) = SOME A y}.
+     {y : A | alist_semantics A l (alist_nth_ad n l) = Some y}.
   Proof.
     simple induction l. intros. elim (le_Sn_O _ H).
     intro r. elim r. intros a y l0 H. simple induction n. simpl in |- *. intro. split with y.
-    rewrite (ad_eq_correct a). reflexivity.
+    rewrite (Neqb_correct a). reflexivity.
     intros. elim (H _ (le_S_n _ _ H1)). intros y0 H2.
-    elim (sumbool_of_bool (ad_eq a (alist_nth_ad n0 l0))). intro H3. split with y.
-    rewrite (ad_eq_complete _ _ H3). simpl in |- *. rewrite (ad_eq_correct (alist_nth_ad n0 l0)).
+    elim (sumbool_of_bool (Neqb a (alist_nth_ad n0 l0))). intro H3. split with y.
+    rewrite (Neqb_complete _ _ H3). simpl in |- *. rewrite (Neqb_correct (alist_nth_ad n0 l0)).
     reflexivity.
     intro H3. split with y0. simpl in |- *. rewrite H3. assumption.
   Qed.
@@ -373,16 +192,16 @@ Section LSort.
   Qed.
 
   Definition ad_monotonic (pf:ad -> ad) :=
-    forall a a':ad, ad_less a a' = true -> ad_less (pf a) (pf a') = true.
+    forall a a':ad, Nless a a' = true -> Nless (pf a) (pf a') = true.
 
-  Lemma ad_double_monotonic : ad_monotonic ad_double.
+  Lemma Ndouble_monotonic : ad_monotonic Ndouble.
   Proof.
-    unfold ad_monotonic in |- *. intros. rewrite ad_less_def_1. assumption.
+    unfold ad_monotonic in |- *. intros. rewrite Nless_def_1. assumption.
   Qed.
 
-  Lemma ad_double_plus_un_monotonic : ad_monotonic ad_double_plus_un.
+  Lemma Ndouble_plus_one_monotonic : ad_monotonic Ndouble_plus_one.
   Proof.
-    unfold ad_monotonic in |- *. intros. rewrite ad_less_def_2. assumption.
+    unfold ad_monotonic in |- *. intros. rewrite Nless_def_2. assumption.
   Qed.
 
   Lemma ad_comp_monotonic :
@@ -395,18 +214,18 @@ Section LSort.
 
   Lemma ad_comp_double_monotonic :
    forall pf:ad -> ad,
-     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (ad_double a0)).
+     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (Ndouble a0)).
   Proof.
     intros. apply ad_comp_monotonic. assumption.
-    exact ad_double_monotonic.
+    exact Ndouble_monotonic.
   Qed.
 
   Lemma ad_comp_double_plus_un_monotonic :
    forall pf:ad -> ad,
-     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (ad_double_plus_un a0)).
+     ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (Ndouble_plus_one a0)).
   Proof.
     intros. apply ad_comp_monotonic. assumption.
-    exact ad_double_plus_un_monotonic.
+    exact Ndouble_plus_one_monotonic.
   Qed.
 
   Lemma alist_of_Map_sorts_1 :
@@ -420,22 +239,22 @@ Section LSort.
     intros. simpl in |- *. apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. reflexivity.
     intros. simpl in |- *. apply alist_conc_sorted.
     exact
-     (H (fun a0:ad => pf (ad_double a0)) (ad_comp_double_monotonic pf H1)).
+     (H (fun a0:ad => pf (Ndouble a0)) (ad_comp_double_monotonic pf H1)).
     exact
-     (H0 (fun a0:ad => pf (ad_double_plus_un a0))
+     (H0 (fun a0:ad => pf (Ndouble_plus_one a0))
         (ad_comp_double_plus_un_monotonic pf H1)).
     intros. elim
-  (alist_of_Map_nth_ad m0 (fun a0:ad => pf (ad_double a0))
+  (alist_of_Map_nth_ad m0 (fun a0:ad => pf (Ndouble a0))
      (MapFold1 A (alist A) (anil A) (aapp A)
         (fun (a0:ad) (y:A) => acons A (a0, y) (anil A))
-        (fun a0:ad => pf (ad_double a0)) m0) (refl_equal _) n H2).
+        (fun a0:ad => pf (Ndouble a0)) m0) (refl_equal _) n H2).
     intros a H4. rewrite H4. elim
-  (alist_of_Map_nth_ad m1 (fun a0:ad => pf (ad_double_plus_un a0))
+  (alist_of_Map_nth_ad m1 (fun a0:ad => pf (Ndouble_plus_one a0))
      (MapFold1 A (alist A) (anil A) (aapp A)
         (fun (a0:ad) (y:A) => acons A (a0, y) (anil A))
-        (fun a0:ad => pf (ad_double_plus_un a0)) m1) (
+        (fun a0:ad => pf (Ndouble_plus_one a0)) m1) (
      refl_equal _) n' H3).
-    intros a' H5. rewrite H5. unfold ad_monotonic in H1. apply H1. apply ad_less_def_3.
+    intros a' H5. rewrite H5. unfold ad_monotonic in H1. apply H1. apply Nless_def_3.
   Qed.
 
   Lemma alist_of_Map_sorts :
@@ -444,7 +263,7 @@ Section LSort.
     intro. apply alist_sorted_2_imp.
     exact
      (alist_of_Map_sorts_1 m (fun a0:ad => a0)
-        (fun (a a':ad) (p:ad_less a a' = true) => p)).
+        (fun (a a':ad) (p:Nless a a' = true) => p)).
   Qed.
 
   Lemma alist_of_Map_sorts1 :
@@ -458,59 +277,25 @@ Section LSort.
   Proof.
     intro. apply alist_sorted_1_imp_2. apply alist_of_Map_sorts1.
   Qed.
- 
-  Lemma ad_less_total :
-   forall a a':ad, {ad_less a a' = true} + {ad_less a' a = true} + {a = a'}.
-  Proof.
-    intro a. refine
-  (ad_rec_double a
-     (fun a:ad =>
-        forall a':ad,
-          {ad_less a a' = true} + {ad_less a' a = true} + {a = a'}) _ _ _).
-    intro. elim (sumbool_of_bool (ad_less ad_z a')). intro H. left. left. assumption.
-    intro H. right. rewrite (ad_z_less_2 a' H). reflexivity.
-    intros a0 H a'. refine
-  (ad_rec_double a'
-     (fun a':ad =>
-        {ad_less (ad_double a0) a' = true} +
-        {ad_less a' (ad_double a0) = true} + {ad_double a0 = a'}) _ _ _).
-    elim (sumbool_of_bool (ad_less ad_z (ad_double a0))). intro H0. left. right. assumption.
-    intro H0. right. exact (ad_z_less_2 _ H0).
-    intros a1 H0. rewrite ad_less_def_1. rewrite ad_less_def_1. elim (H a1). intro H1.
-    left. assumption.
-    intro H1. right. rewrite H1. reflexivity.
-    intros a1 H0. left. left. apply ad_less_def_3.
-    intros a0 H a'. refine
-  (ad_rec_double a'
-     (fun a':ad =>
-        {ad_less (ad_double_plus_un a0) a' = true} +
-        {ad_less a' (ad_double_plus_un a0) = true} +
-        {ad_double_plus_un a0 = a'}) _ _ _).
-    left. right. case a0; reflexivity.
-    intros a1 H0. left. right. apply ad_less_def_3.
-    intros a1 H0. rewrite ad_less_def_2. rewrite ad_less_def_2. elim (H a1). intro H1.
-    left. assumption.
-    intro H1. right. rewrite H1. reflexivity.
-  Qed.
 
   Lemma alist_too_low :
    forall (l:alist A) (a a':ad) (y:A),
-     ad_less a a' = true ->
+     Nless a a' = true ->
      alist_sorted_2 ((a', y) :: l) ->
-     alist_semantics A ((a', y) :: l) a = NONE A.
+     alist_semantics A ((a', y) :: l) a = None.
   Proof.
-    simple induction l. intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a' a)). intro H1.
-    rewrite (ad_eq_complete _ _ H1) in H. rewrite (ad_less_not_refl a) in H. discriminate H.
+    simple induction l. intros. simpl in |- *. elim (sumbool_of_bool (Neqb a' a)). intro H1.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (Nless_not_refl a) in H. discriminate H.
     intro H1. rewrite H1. reflexivity.
     intro r. elim r. intros a y l0 H a0 a1 y0 H0 H1.
     change
-      (match ad_eq a1 a0 with
-       | true => SOME A y0
+      (match Neqb a1 a0 with
+       | true => Some y0
        | false => alist_semantics A ((a, y) :: l0) a0
-       end = NONE A) in |- *.
-    elim (sumbool_of_bool (ad_eq a1 a0)). intro H2. rewrite (ad_eq_complete _ _ H2) in H0.
-    rewrite (ad_less_not_refl a0) in H0. discriminate H0.
-    intro H2. rewrite H2. apply H. apply ad_less_trans with (a' := a1). assumption.
+       end = None) in |- *.
+    elim (sumbool_of_bool (Neqb a1 a0)). intro H2. rewrite (Neqb_complete _ _ H2) in H0.
+    rewrite (Nless_not_refl a0) in H0. discriminate H0.
+    intro H2. rewrite H2. apply H. apply Nless_trans with (a' := a1). assumption.
     unfold alist_sorted_2 in H1. apply (H1 0 1). apply lt_n_Sn.
     simpl in |- *. apply le_n_S. apply le_n_S. apply le_O_n.
     apply alist_sorted_1_imp_2. apply alist_sorted_imp_1.
@@ -521,13 +306,13 @@ Section LSort.
 
   Lemma alist_semantics_nth_ad :
    forall (l:alist A) (a:ad) (y:A),
-     alist_semantics A l a = SOME A y ->
+     alist_semantics A l a = Some y ->
      {n : nat | S n <= length l /\ alist_nth_ad n l = a}.
   Proof.
     simple induction l. intros. discriminate H.
-    intro r. elim r. intros a y l0 H a0 y0 H0. simpl in H0. elim (sumbool_of_bool (ad_eq a a0)).
+    intro r. elim r. intros a y l0 H a0 y0 H0. simpl in H0. elim (sumbool_of_bool (Neqb a a0)).
     intro H1. rewrite H1 in H0. split with 0. split. simpl in |- *. apply le_n_S. apply le_O_n.
-    simpl in |- *. exact (ad_eq_complete _ _ H1).
+    simpl in |- *. exact (Neqb_complete _ _ H1).
     intro H1. rewrite H1 in H0. elim (H a0 y0 H0). intros n' H2. split with (S n'). split.
     simpl in |- *. apply le_n_S. exact (proj1 H2).
     exact (proj2 H2).
@@ -538,16 +323,16 @@ Section LSort.
      alist_sorted_2 ((a, y) :: l) ->
      eqm A (alist_semantics A l)
        (fun a0:ad =>
-          if ad_eq a a0 then NONE A else alist_semantics A ((a, y) :: l) a0).
+          if Neqb a a0 then None else alist_semantics A ((a, y) :: l) a0).
   Proof.
-    unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0.
-    rewrite <- (ad_eq_complete _ _ H0). unfold alist_sorted_2 in H.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0.
+    rewrite <- (Neqb_complete _ _ H0). unfold alist_sorted_2 in H.
     elim (option_sum A (alist_semantics A l a)). intro H1. elim H1. intros y0 H2.
     elim (alist_semantics_nth_ad l a y0 H2). intros n H3. elim H3. intros.
     cut
-     (ad_less (alist_nth_ad 0 ((a, y) :: l))
+     (Nless (alist_nth_ad 0 ((a, y) :: l))
         (alist_nth_ad (S n) ((a, y) :: l)) = true).
-    intro. simpl in H6. rewrite H5 in H6. rewrite (ad_less_not_refl a) in H6. discriminate H6.
+    intro. simpl in H6. rewrite H5 in H6. rewrite (Nless_not_refl a) in H6. discriminate H6.
     apply H. apply lt_O_Sn.
     simpl in |- *. apply le_n_S. assumption.
     trivial.
@@ -563,7 +348,7 @@ Section LSort.
      eqm A (alist_semantics A l) (alist_semantics A l').
   Proof.
     unfold eqm in |- *. intros. rewrite (alist_semantics_tail _ _ _ H a0).
-    rewrite (alist_semantics_tail _ _ _ H0 a0). case (ad_eq a a0). reflexivity.
+    rewrite (alist_semantics_tail _ _ _ H0 a0). case (Neqb a a0). reflexivity.
     exact (H1 a0).
   Qed.
 
@@ -583,40 +368,40 @@ Section LSort.
     unfold eqm in |- *. simple induction l. simple induction l'. trivial.
     intro r. elim r. intros a y l0 H H0 H1 H2. simpl in H0.
     cut
-     (NONE A =
-      match ad_eq a a with
-      | true => SOME A y
+     (None =
+      match Neqb a a with
+      | true => Some y
       | false => alist_semantics A l0 a
       end).
-    rewrite (ad_eq_correct a). intro. discriminate H3.
+    rewrite (Neqb_correct a). intro. discriminate H3.
     exact (H0 a).
     intro r. elim r. intros a y l0 H. simple induction l'. intros. simpl in H0.
     cut
-     (match ad_eq a a with
-      | true => SOME A y
+     (match Neqb a a with
+      | true => Some y
       | false => alist_semantics A l0 a
-      end = NONE A).
-    rewrite (ad_eq_correct a). intro. discriminate H3.
+      end = None).
+    rewrite (Neqb_correct a). intro. discriminate H3.
     exact (H0 a).
-    intro r'. elim r'. intros a' y' l'0 H0 H1 H2 H3. elim (ad_less_total a a'). intro H4.
+    intro r'. elim r'. intros a' y' l'0 H0 H1 H2 H3. elim (Nless_total a a'). intro H4.
     elim H4. intro H5.
     cut
      (alist_semantics A ((a, y) :: l0) a =
       alist_semantics A ((a', y') :: l'0) a).
     intro. rewrite (alist_too_low l'0 a a' y' H5 H3) in H6. simpl in H6.
-    rewrite (ad_eq_correct a) in H6. discriminate H6.
+    rewrite (Neqb_correct a) in H6. discriminate H6.
     exact (H1 a).
     intro H5. cut
   (alist_semantics A ((a, y) :: l0) a' =
    alist_semantics A ((a', y') :: l'0) a').
     intro. rewrite (alist_too_low l0 a' a y H5 H2) in H6. simpl in H6.
-    rewrite (ad_eq_correct a') in H6. discriminate H6.
+    rewrite (Neqb_correct a') in H6. discriminate H6.
     exact (H1 a').
     intro H4. rewrite H4.
     cut
      (alist_semantics A ((a, y) :: l0) a =
       alist_semantics A ((a', y') :: l'0) a).
-    intro. simpl in H5. rewrite H4 in H5. rewrite (ad_eq_correct a') in H5. inversion H5.
+    intro. simpl in H5. rewrite H4 in H5. rewrite (Neqb_correct a') in H5. inversion H5.
     rewrite H4 in H1. rewrite H7 in H1. cut (l0 = l'0). intro. rewrite H6. reflexivity.
     apply H. rewrite H4 in H2. rewrite H7 in H2.
     exact (alist_semantics_same_tail l0 l'0 a' y' H2 H3 H1).
diff --git a/theories/IntMap/Map.v b/theories/IntMap/Map.v
index da1fa99e..2be6de04 100644
--- a/theories/IntMap/Map.v
+++ b/theories/IntMap/Map.v
@@ -5,21 +5,26 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Map.v,v 1.7.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Map.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 (** Definition of finite sets as trees indexed by adresses *)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 
+(* The type [ad] of addresses is now [N] in [BinNat]. *)
+
+Definition ad := N. 
+
+(* a Notation or complete replacement would be nice, 
+   but that would changes hyps names *)
 
 Section MapDefs.
 
-(** We define maps from ad to A. *)
+(** We now define maps from ad to A. *)
   Variable A : Set.  
 
   Inductive Map : Set :=
@@ -27,31 +32,28 @@ Section MapDefs.
     | M1 : ad -> A -> Map
     | M2 : Map -> Map -> Map.
 
-  Inductive option : Set :=
-    | NONE : option
-    | SOME : A -> option.
-
-  Lemma option_sum : forall o:option, {y : A | o = SOME y} + {o = NONE}.
+  Lemma option_sum : forall o:option A, {y : A | o = Some y} + {o = None}.
   Proof.
-    simple induction o. right. reflexivity.
+    simple induction o. 
     left. split with a. reflexivity.
+    right. reflexivity.
   Qed.
 
   (** The semantics of maps is given by the function [MapGet].
       The semantics of a map [m] is a partial, finite function from
       [ad] to [A]: *)
 
-  Fixpoint MapGet (m:Map) : ad -> option :=
+  Fixpoint MapGet (m:Map) : ad -> option A :=
     match m with
-    | M0 => fun a:ad => NONE
-    | M1 x y => fun a:ad => if ad_eq x a then SOME y else NONE
+    | M0 => fun a:ad => None
+    | M1 x y => fun a:ad => if Neqb x a then Some y else None
     | M2 m1 m2 =>
         fun a:ad =>
           match a with
-          | ad_z => MapGet m1 ad_z
-          | ad_x xH => MapGet m2 ad_z
-          | ad_x (xO p) => MapGet m1 (ad_x p)
-          | ad_x (xI p) => MapGet m2 (ad_x p)
+          | N0 => MapGet m1 N0
+          | Npos xH => MapGet m2 N0
+          | Npos (xO p) => MapGet m1 (Npos p)
+          | Npos (xI p) => MapGet m2 (Npos p)
           end
     end.
 
@@ -59,9 +61,9 @@ Section MapDefs.
 
   Definition MapSingleton := M1.
 
-  Definition eqm (g g':ad -> option) := forall a:ad, g a = g' a.
+  Definition eqm (g g':ad -> option A) := forall a:ad, g a = g' a.
 
-  Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => NONE).
+  Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => None).
   Proof.
     simpl in |- *. unfold eqm in |- *. trivial.
   Qed.
@@ -69,61 +71,61 @@ Section MapDefs.
   Lemma MapSingleton_semantics :
    forall (a:ad) (y:A),
      eqm (MapGet (MapSingleton a y))
-       (fun a':ad => if ad_eq a a' then SOME y else NONE).
+       (fun a':ad => if Neqb a a' then Some y else None).
   Proof.
     simpl in |- *. unfold eqm in |- *. trivial.
   Qed.
 
-  Lemma M1_semantics_1 : forall (a:ad) (y:A), MapGet (M1 a y) a = SOME y.
+  Lemma M1_semantics_1 : forall (a:ad) (y:A), MapGet (M1 a y) a = Some y.
   Proof.
-    unfold MapGet in |- *. intros. rewrite (ad_eq_correct a). reflexivity.
+    unfold MapGet in |- *. intros. rewrite (Neqb_correct a). reflexivity.
   Qed.
 
   Lemma M1_semantics_2 :
-   forall (a a':ad) (y:A), ad_eq a a' = false -> MapGet (M1 a y) a' = NONE.
+   forall (a a':ad) (y:A), Neqb a a' = false -> MapGet (M1 a y) a' = None.
   Proof.
     intros. simpl in |- *. rewrite H. reflexivity.
   Qed.
 
   Lemma Map2_semantics_1 :
    forall m m':Map,
-     eqm (MapGet m) (fun a:ad => MapGet (M2 m m') (ad_double a)).
+     eqm (MapGet m) (fun a:ad => MapGet (M2 m m') (Ndouble a)).
   Proof.
     unfold eqm in |- *. simple induction a; trivial.
   Qed.
 
   Lemma Map2_semantics_1_eq :
-   forall (m m':Map) (f:ad -> option),
-     eqm (MapGet (M2 m m')) f -> eqm (MapGet m) (fun a:ad => f (ad_double a)).
+   forall (m m':Map) (f:ad -> option A),
+     eqm (MapGet (M2 m m')) f -> eqm (MapGet m) (fun a:ad => f (Ndouble a)).
   Proof.
     unfold eqm in |- *.
     intros.
-    rewrite <- (H (ad_double a)).
+    rewrite <- (H (Ndouble a)).
     exact (Map2_semantics_1 m m' a).
   Qed.
 
   Lemma Map2_semantics_2 :
    forall m m':Map,
-     eqm (MapGet m') (fun a:ad => MapGet (M2 m m') (ad_double_plus_un a)).
+     eqm (MapGet m') (fun a:ad => MapGet (M2 m m') (Ndouble_plus_one a)).
   Proof.
     unfold eqm in |- *. simple induction a; trivial.
   Qed.
 
   Lemma Map2_semantics_2_eq :
-   forall (m m':Map) (f:ad -> option),
+   forall (m m':Map) (f:ad -> option A),
      eqm (MapGet (M2 m m')) f ->
-     eqm (MapGet m') (fun a:ad => f (ad_double_plus_un a)).
+     eqm (MapGet m') (fun a:ad => f (Ndouble_plus_one a)).
   Proof.
     unfold eqm in |- *.
     intros.
-    rewrite <- (H (ad_double_plus_un a)).
+    rewrite <- (H (Ndouble_plus_one a)).
     exact (Map2_semantics_2 m m' a).
   Qed.
 
   Lemma MapGet_M2_bit_0_0 :
    forall a:ad,
-     ad_bit_0 a = false ->
-     forall m m':Map, MapGet (M2 m m') a = MapGet m (ad_div_2 a).
+     Nbit0 a = false ->
+     forall m m':Map, MapGet (M2 m m') a = MapGet m (Ndiv2 a).
   Proof.
     simple induction a; trivial. simple induction p. intros. discriminate H0.
     trivial.
@@ -132,8 +134,8 @@ Section MapDefs.
 
   Lemma MapGet_M2_bit_0_1 :
    forall a:ad,
-     ad_bit_0 a = true ->
-     forall m m':Map, MapGet (M2 m m') a = MapGet m' (ad_div_2 a).
+     Nbit0 a = true ->
+     forall m m':Map, MapGet (M2 m m') a = MapGet m' (Ndiv2 a).
   Proof.
     simple induction a. intros. discriminate H.
     simple induction p. trivial.
@@ -144,19 +146,19 @@ Section MapDefs.
   Lemma MapGet_M2_bit_0_if :
    forall (m m':Map) (a:ad),
      MapGet (M2 m m') a =
-     (if ad_bit_0 a then MapGet m' (ad_div_2 a) else MapGet m (ad_div_2 a)).
+     (if Nbit0 a then MapGet m' (Ndiv2 a) else MapGet m (Ndiv2 a)).
   Proof.
-    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. rewrite H.
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H. rewrite H.
     apply MapGet_M2_bit_0_1; assumption.
     intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption.
   Qed.
 
   Lemma MapGet_M2_bit_0 :
    forall (m m' m'':Map) (a:ad),
-     (if ad_bit_0 a then MapGet (M2 m' m) a else MapGet (M2 m m'') a) =
-     MapGet m (ad_div_2 a).
+     (if Nbit0 a then MapGet (M2 m' m) a else MapGet (M2 m m'') a) =
+     MapGet m (Ndiv2 a).
   Proof.
-    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. rewrite H.
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H. rewrite H.
     apply MapGet_M2_bit_0_1; assumption.
     intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption.
   Qed.
@@ -165,9 +167,9 @@ Section MapDefs.
    forall m m':Map,
      eqm (MapGet (M2 m m'))
        (fun a:ad =>
-          match ad_bit_0 a with
-          | false => MapGet m (ad_div_2 a)
-          | true => MapGet m' (ad_div_2 a)
+          match Nbit0 a with
+          | false => MapGet m (Ndiv2 a)
+          | true => MapGet m' (Ndiv2 a)
           end).
   Proof.
     unfold eqm in |- *.
@@ -176,20 +178,20 @@ Section MapDefs.
   Qed.
 
   Lemma Map2_semantics_3_eq :
-   forall (m m':Map) (f f':ad -> option),
+   forall (m m':Map) (f f':ad -> option A),
      eqm (MapGet m) f ->
      eqm (MapGet m') f' ->
      eqm (MapGet (M2 m m'))
        (fun a:ad =>
-          match ad_bit_0 a with
-          | false => f (ad_div_2 a)
-          | true => f' (ad_div_2 a)
+          match Nbit0 a with
+          | false => f (Ndiv2 a)
+          | true => f' (Ndiv2 a)
           end).
   Proof.
     unfold eqm in |- *.
     intros.
-    rewrite <- (H (ad_div_2 a)).
-    rewrite <- (H0 (ad_div_2 a)).
+    rewrite <- (H (Ndiv2 a)).
+    rewrite <- (H0 (Ndiv2 a)).
     exact (Map2_semantics_3 m m' a).
   Qed.
 
@@ -197,15 +199,15 @@ Section MapDefs.
    Map :=
     match p with
     | xO p' =>
-        let m := MapPut1 (ad_div_2 a) y (ad_div_2 a') y' p' in
-        match ad_bit_0 a with
+        let m := MapPut1 (Ndiv2 a) y (Ndiv2 a') y' p' in
+        match Nbit0 a with
         | false => M2 m M0
         | true => M2 M0 m
         end
     | _ =>
-        match ad_bit_0 a with
-        | false => M2 (M1 (ad_div_2 a) y) (M1 (ad_div_2 a') y')
-        | true => M2 (M1 (ad_div_2 a') y') (M1 (ad_div_2 a) y)
+        match Nbit0 a with
+        | false => M2 (M1 (Ndiv2 a) y) (M1 (Ndiv2 a') y')
+        | true => M2 (M1 (Ndiv2 a') y') (M1 (Ndiv2 a) y)
         end
     end.
 
@@ -218,14 +220,14 @@ Section MapDefs.
 
   (*i
   Lemma MapGet_M2_bit_0_1' : (m,m',m'',m''':Map)
-      (a:ad) (MapGet (if (ad_bit_0 a) then (M2 m m') else (M2 m'' m''')) a)=
-             (MapGet (if (ad_bit_0 a) then m' else m'') (ad_div_2 a)).
+      (a:ad) (MapGet (if (Nbit0 a) then (M2 m m') else (M2 m'' m''')) a)=
+             (MapGet (if (Nbit0 a) then m' else m'') (Ndiv2 a)).
   Proof.
-    Intros. Rewrite (MapGet_if_commute (ad_bit_0 a)). Rewrite (MapGet_if_commute (ad_bit_0 a)).
-    Cut (ad_bit_0 a)=false\/(ad_bit_0 a)=true. Intros. Elim H. Intros. Rewrite H0.
+    Intros. Rewrite (MapGet_if_commute (Nbit0 a)). Rewrite (MapGet_if_commute (Nbit0 a)).
+    Cut (Nbit0 a)=false\/(Nbit0 a)=true. Intros. Elim H. Intros. Rewrite H0.
     Apply MapGet_M2_bit_0_0. Assumption.
     Intros. Rewrite H0. Apply MapGet_M2_bit_0_1. Assumption.
-    Case (ad_bit_0 a); Auto.
+    Case (Nbit0 a); Auto.
   Qed.
   i*)
 
@@ -237,107 +239,107 @@ Section MapDefs.
 
   Lemma MapGet_M2_bit_0_2 :
    forall (m m' m'':Map) (a:ad),
-     MapGet (if ad_bit_0 a then M2 m m' else M2 m' m'') a =
-     MapGet m' (ad_div_2 a).
+     MapGet (if Nbit0 a then M2 m m' else M2 m' m'') a =
+     MapGet m' (Ndiv2 a).
   Proof.
     intros. rewrite MapGet_if_commute. apply MapGet_M2_bit_0.
   Qed.
 
   Lemma MapPut1_semantics_1 :
    forall (p:positive) (a a':ad) (y y':A),
-     ad_xor a a' = ad_x p -> MapGet (MapPut1 a y a' y' p) a = SOME y.
+     Nxor a a' = Npos p -> MapGet (MapPut1 a y a' y' p) a = Some y.
   Proof.
     simple induction p. intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
-    intros. simpl in |- *. rewrite MapGet_M2_bit_0_2. apply H. rewrite <- ad_xor_div_2. rewrite H0.
+    intros. simpl in |- *. rewrite MapGet_M2_bit_0_2. apply H. rewrite <- Nxor_div2. rewrite H0.
     reflexivity.
     intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
   Qed.
 
   Lemma MapPut1_semantics_2 :
    forall (p:positive) (a a':ad) (y y':A),
-     ad_xor a a' = ad_x p -> MapGet (MapPut1 a y a' y' p) a' = SOME y'.
+     Nxor a a' = Npos p -> MapGet (MapPut1 a y a' y' p) a' = Some y'.
   Proof.
-    simple induction p. intros. unfold MapPut1 in |- *. rewrite (ad_neg_bit_0_2 a a' p0 H0).
+    simple induction p. intros. unfold MapPut1 in |- *. rewrite (Nneg_bit0_2 a a' p0 H0).
     rewrite if_negb. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
-    intros. simpl in |- *. rewrite (ad_same_bit_0 a a' p0 H0). rewrite MapGet_M2_bit_0_2.
-    apply H. rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
-    intros. unfold MapPut1 in |- *. rewrite (ad_neg_bit_0_1 a a' H). rewrite if_negb.
+    intros. simpl in |- *. rewrite (Nsame_bit0 a a' p0 H0). rewrite MapGet_M2_bit_0_2.
+    apply H. rewrite <- Nxor_div2. rewrite H0. reflexivity.
+    intros. unfold MapPut1 in |- *. rewrite (Nneg_bit0_1 a a' H). rewrite if_negb.
     rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
   Qed.
 
-  Lemma MapGet_M2_both_NONE :
+  Lemma MapGet_M2_both_None :
    forall (m m':Map) (a:ad),
-     MapGet m (ad_div_2 a) = NONE ->
-     MapGet m' (ad_div_2 a) = NONE -> MapGet (M2 m m') a = NONE.
+     MapGet m (Ndiv2 a) = None ->
+     MapGet m' (Ndiv2 a) = None -> MapGet (M2 m m') a = None.
   Proof.
     intros. rewrite (Map2_semantics_3 m m' a). 
-    case (ad_bit_0 a); assumption.
+    case (Nbit0 a); assumption.
   Qed.
  
   Lemma MapPut1_semantics_3 :
    forall (p:positive) (a a' a0:ad) (y y':A),
-     ad_xor a a' = ad_x p ->
-     ad_eq a a0 = false ->
-     ad_eq a' a0 = false -> MapGet (MapPut1 a y a' y' p) a0 = NONE.
-  Proof.
-    simple induction p. intros. unfold MapPut1 in |- *. elim (ad_neq a a0 H1). intro. rewrite H3. rewrite if_negb.
-    rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply ad_div_bit_neq. assumption.
-    rewrite (ad_neg_bit_0_2 a a' p0 H0) in H3. rewrite (negb_intro (ad_bit_0 a')).
-    rewrite (negb_intro (ad_bit_0 a0)). rewrite H3. reflexivity.
-    intro. elim (ad_neq a' a0 H2). intro. rewrite (ad_neg_bit_0_2 a a' p0 H0). rewrite H4.
-    rewrite (negb_elim (ad_bit_0 a0)). rewrite MapGet_M2_bit_0_2.
+     Nxor a a' = Npos p ->
+     Neqb a a0 = false ->
+     Neqb a' a0 = false -> MapGet (MapPut1 a y a' y' p) a0 = None.
+  Proof.
+    simple induction p. intros. unfold MapPut1 in |- *. elim (Nneq_elim a a0 H1). intro. rewrite H3. rewrite if_negb.
+    rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply Ndiv2_bit_neq. assumption.
+    rewrite (Nneg_bit0_2 a a' p0 H0) in H3. rewrite (negb_intro (Nbit0 a')).
+    rewrite (negb_intro (Nbit0 a0)). rewrite H3. reflexivity.
+    intro. elim (Nneq_elim a' a0 H2). intro. rewrite (Nneg_bit0_2 a a' p0 H0). rewrite H4.
+    rewrite (negb_elim (Nbit0 a0)). rewrite MapGet_M2_bit_0_2.
     apply M1_semantics_2; assumption.
-    intro; case (ad_bit_0 a); apply MapGet_M2_both_NONE; apply M1_semantics_2;
+    intro; case (Nbit0 a); apply MapGet_M2_both_None; apply M1_semantics_2;
      assumption.
-    intros. simpl in |- *. elim (ad_neq a a0 H1). intro. rewrite H3. rewrite if_negb.
+    intros. simpl in |- *. elim (Nneq_elim a a0 H1). intro. rewrite H3. rewrite if_negb.
     rewrite MapGet_M2_bit_0_2. reflexivity.
-    intro. elim (ad_neq a' a0 H2). intro. rewrite (ad_same_bit_0 a a' p0 H0). rewrite H4.
+    intro. elim (Nneq_elim a' a0 H2). intro. rewrite (Nsame_bit0 a a' p0 H0). rewrite H4.
     rewrite if_negb. rewrite MapGet_M2_bit_0_2. reflexivity.
-    intro. cut (ad_xor (ad_div_2 a) (ad_div_2 a') = ad_x p0). intro.
-    case (ad_bit_0 a); apply MapGet_M2_both_NONE; trivial; apply H;
+    intro. cut (Nxor (Ndiv2 a) (Ndiv2 a') = Npos p0). intro.
+    case (Nbit0 a); apply MapGet_M2_both_None; trivial; apply H;
      assumption.
-    rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
-    intros. simpl in |- *. elim (ad_neq a a0 H0). intro. rewrite H2. rewrite if_negb.
-    rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply ad_div_bit_neq. assumption.
-    rewrite (ad_neg_bit_0_1 a a' H) in H2. rewrite (negb_intro (ad_bit_0 a')).
-    rewrite (negb_intro (ad_bit_0 a0)). rewrite H2. reflexivity.
-    intro. elim (ad_neq a' a0 H1). intro. rewrite (ad_neg_bit_0_1 a a' H). rewrite H3.
-    rewrite (negb_elim (ad_bit_0 a0)). rewrite MapGet_M2_bit_0_2.
+    rewrite <- Nxor_div2. rewrite H0. reflexivity.
+    intros. simpl in |- *. elim (Nneq_elim a a0 H0). intro. rewrite H2. rewrite if_negb.
+    rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply Ndiv2_bit_neq. assumption.
+    rewrite (Nneg_bit0_1 a a' H) in H2. rewrite (negb_intro (Nbit0 a')).
+    rewrite (negb_intro (Nbit0 a0)). rewrite H2. reflexivity.
+    intro. elim (Nneq_elim a' a0 H1). intro. rewrite (Nneg_bit0_1 a a' H). rewrite H3.
+    rewrite (negb_elim (Nbit0 a0)). rewrite MapGet_M2_bit_0_2.
     apply M1_semantics_2; assumption.
-    intro. case (ad_bit_0 a); apply MapGet_M2_both_NONE; apply M1_semantics_2;
+    intro. case (Nbit0 a); apply MapGet_M2_both_None; apply M1_semantics_2;
   assumption.
   Qed.
 
   Lemma MapPut1_semantics :
    forall (p:positive) (a a':ad) (y y':A),
-     ad_xor a a' = ad_x p ->
+     Nxor a a' = Npos p ->
      eqm (MapGet (MapPut1 a y a' y' p))
        (fun a0:ad =>
-          if ad_eq a a0
-          then SOME y
-          else if ad_eq a' a0 then SOME y' else NONE).
-  Proof.
-    unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0.
-    rewrite <- (ad_eq_complete _ _ H0). exact (MapPut1_semantics_1 p a a' y y' H).
-    intro H0. rewrite H0. elim (sumbool_of_bool (ad_eq a' a0)). intro H1.
-    rewrite <- (ad_eq_complete _ _ H1). rewrite (ad_eq_correct a').
+          if Neqb a a0
+          then Some y
+          else if Neqb a' a0 then Some y' else None).
+  Proof.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0.
+    rewrite <- (Neqb_complete _ _ H0). exact (MapPut1_semantics_1 p a a' y y' H).
+    intro H0. rewrite H0. elim (sumbool_of_bool (Neqb a' a0)). intro H1.
+    rewrite <- (Neqb_complete _ _ H1). rewrite (Neqb_correct a').
     exact (MapPut1_semantics_2 p a a' y y' H).
     intro H1. rewrite H1. exact (MapPut1_semantics_3 p a a' a0 y y' H H0 H1).
   Qed.
 
   Lemma MapPut1_semantics' :
    forall (p:positive) (a a':ad) (y y':A),
-     ad_xor a a' = ad_x p ->
+     Nxor a a' = Npos p ->
      eqm (MapGet (MapPut1 a y a' y' p))
        (fun a0:ad =>
-          if ad_eq a' a0
-          then SOME y'
-          else if ad_eq a a0 then SOME y else NONE).
+          if Neqb a' a0
+          then Some y'
+          else if Neqb a a0 then Some y else None).
   Proof.
     unfold eqm in |- *. intros. rewrite (MapPut1_semantics p a a' y y' H a0).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0.
-    rewrite <- (ad_eq_complete a a0 H0). rewrite (ad_eq_comm a' a).
-    rewrite (ad_xor_eq_false a a' p H). reflexivity.
+    elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0.
+    rewrite <- (Neqb_complete a a0 H0). rewrite (Neqb_comm a' a).
+    rewrite (Nxor_eq_false a a' p H). reflexivity.
     intro H0. rewrite H0. reflexivity.
   Qed.
 
@@ -346,17 +348,17 @@ Section MapDefs.
     | M0 => M1
     | M1 a y =>
         fun (a':ad) (y':A) =>
-          match ad_xor a a' with
-          | ad_z => M1 a' y'
-          | ad_x p => MapPut1 a y a' y' p
+          match Nxor a a' with
+          | N0 => M1 a' y'
+          | Npos p => MapPut1 a y a' y' p
           end
     | M2 m1 m2 =>
         fun (a:ad) (y:A) =>
           match a with
-          | ad_z => M2 (MapPut m1 ad_z y) m2
-          | ad_x xH => M2 m1 (MapPut m2 ad_z y)
-          | ad_x (xO p) => M2 (MapPut m1 (ad_x p) y) m2
-          | ad_x (xI p) => M2 m1 (MapPut m2 (ad_x p) y)
+          | N0 => M2 (MapPut m1 N0 y) m2
+          | Npos xH => M2 m1 (MapPut m2 N0 y)
+          | Npos (xO p) => M2 (MapPut m1 (Npos p) y) m2
+          | Npos (xI p) => M2 m1 (MapPut m2 (Npos p) y)
           end
     end.
 
@@ -370,39 +372,39 @@ Section MapDefs.
   Lemma MapPut_semantics_2_1 :
    forall (a:ad) (y y':A) (a0:ad),
      MapGet (MapPut (M1 a y) a y') a0 =
-     (if ad_eq a a0 then SOME y' else NONE).
+     (if Neqb a a0 then Some y' else None).
   Proof.
-    simpl in |- *. intros. rewrite (ad_xor_nilpotent a). trivial.
+    simpl in |- *. intros. rewrite (Nxor_nilpotent a). trivial.
   Qed.
 
   Lemma MapPut_semantics_2_2 :
    forall (a a':ad) (y y':A) (a0 a'':ad),
-     ad_xor a a' = a'' ->
+     Nxor a a' = a'' ->
      MapGet (MapPut (M1 a y) a' y') a0 =
-     (if ad_eq a' a0 then SOME y' else if ad_eq a a0 then SOME y else NONE).
+     (if Neqb a' a0 then Some y' else if Neqb a a0 then Some y else None).
   Proof.
-    simple induction a''. intro. rewrite (ad_xor_eq _ _ H). rewrite MapPut_semantics_2_1.
-    case (ad_eq a' a0); trivial.
+    simple induction a''. intro. rewrite (Nxor_eq _ _ H). rewrite MapPut_semantics_2_1.
+    case (Neqb a' a0); trivial.
     intros. simpl in |- *. rewrite H. rewrite (MapPut1_semantics p a a' y y' H a0).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0. rewrite <- (ad_eq_complete _ _ H0).
-    rewrite (ad_eq_comm a' a). rewrite (ad_xor_eq_false _ _ _ H). reflexivity.
+    elim (sumbool_of_bool (Neqb a a0)). intro H0. rewrite H0. rewrite <- (Neqb_complete _ _ H0).
+    rewrite (Neqb_comm a' a). rewrite (Nxor_eq_false _ _ _ H). reflexivity.
     intro H0. rewrite H0. reflexivity.
   Qed.
 
   Lemma MapPut_semantics_2 :
    forall (a a':ad) (y y':A) (a0:ad),
      MapGet (MapPut (M1 a y) a' y') a0 =
-     (if ad_eq a' a0 then SOME y' else if ad_eq a a0 then SOME y else NONE).
+     (if Neqb a' a0 then Some y' else if Neqb a a0 then Some y else None).
   Proof.
-    intros. apply MapPut_semantics_2_2 with (a'' := ad_xor a a'); trivial.
+    intros. apply MapPut_semantics_2_2 with (a'' := Nxor a a'); trivial.
   Qed.
 
   Lemma MapPut_semantics_3_1 :
    forall (m m':Map) (a:ad) (y:A),
      MapPut (M2 m m') a y =
-     (if ad_bit_0 a
-      then M2 m (MapPut m' (ad_div_2 a) y)
-      else M2 (MapPut m (ad_div_2 a) y) m').
+     (if Nbit0 a
+      then M2 m (MapPut m' (Ndiv2 a) y)
+      else M2 (MapPut m (Ndiv2 a) y) m').
   Proof.
     simple induction a. trivial.
     simple induction p; trivial.
@@ -411,24 +413,24 @@ Section MapDefs.
   Lemma MapPut_semantics :
    forall (m:Map) (a:ad) (y:A),
      eqm (MapGet (MapPut m a y))
-       (fun a':ad => if ad_eq a a' then SOME y else MapGet m a').
+       (fun a':ad => if Neqb a a' then Some y else MapGet m a').
   Proof.
     unfold eqm in |- *. simple induction m. exact MapPut_semantics_1.
     intros. unfold MapGet at 2 in |- *. apply MapPut_semantics_2; assumption.
     intros. rewrite MapPut_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a0).
-    elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if.
-    elim (sumbool_of_bool (ad_bit_0 a0)). intro H2. rewrite H2.
-    rewrite (H0 (ad_div_2 a) y (ad_div_2 a0)). elim (sumbool_of_bool (ad_eq a a0)).
-    intro H3. rewrite H3. rewrite (ad_div_eq _ _ H3). reflexivity.
-    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1). reflexivity.
-    intro H2. rewrite H2. rewrite (ad_eq_comm a a0). rewrite (ad_bit_0_neq a0 a H2 H1).
+    elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if.
+    elim (sumbool_of_bool (Nbit0 a0)). intro H2. rewrite H2.
+    rewrite (H0 (Ndiv2 a) y (Ndiv2 a0)). elim (sumbool_of_bool (Neqb a a0)).
+    intro H3. rewrite H3. rewrite (Ndiv2_eq _ _ H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). reflexivity.
+    intro H2. rewrite H2. rewrite (Neqb_comm a a0). rewrite (Nbit0_neq a0 a H2 H1).
     reflexivity.
-    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a0)).
-    intro H2. rewrite H2. rewrite (ad_bit_0_neq a a0 H1 H2). reflexivity.
-    intro H2. rewrite H2. rewrite (H (ad_div_2 a) y (ad_div_2 a0)).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H3. rewrite H3.
-    rewrite (ad_div_eq a a0 H3). reflexivity.
-    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq a a0 H3 H1). reflexivity.
+    intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a0)).
+    intro H2. rewrite H2. rewrite (Nbit0_neq a a0 H1 H2). reflexivity.
+    intro H2. rewrite H2. rewrite (H (Ndiv2 a) y (Ndiv2 a0)).
+    elim (sumbool_of_bool (Neqb a a0)). intro H3. rewrite H3.
+    rewrite (Ndiv2_eq a a0 H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq a a0 H3 H1). reflexivity.
   Qed.
 
   Fixpoint MapPut_behind (m:Map) : ad -> A -> Map :=
@@ -436,26 +438,26 @@ Section MapDefs.
     | M0 => M1
     | M1 a y =>
         fun (a':ad) (y':A) =>
-          match ad_xor a a' with
-          | ad_z => m
-          | ad_x p => MapPut1 a y a' y' p
+          match Nxor a a' with
+          | N0 => m
+          | Npos p => MapPut1 a y a' y' p
           end
     | M2 m1 m2 =>
         fun (a:ad) (y:A) =>
           match a with
-          | ad_z => M2 (MapPut_behind m1 ad_z y) m2
-          | ad_x xH => M2 m1 (MapPut_behind m2 ad_z y)
-          | ad_x (xO p) => M2 (MapPut_behind m1 (ad_x p) y) m2
-          | ad_x (xI p) => M2 m1 (MapPut_behind m2 (ad_x p) y)
+          | N0 => M2 (MapPut_behind m1 N0 y) m2
+          | Npos xH => M2 m1 (MapPut_behind m2 N0 y)
+          | Npos (xO p) => M2 (MapPut_behind m1 (Npos p) y) m2
+          | Npos (xI p) => M2 m1 (MapPut_behind m2 (Npos p) y)
           end
     end.
 
   Lemma MapPut_behind_semantics_3_1 :
    forall (m m':Map) (a:ad) (y:A),
      MapPut_behind (M2 m m') a y =
-     (if ad_bit_0 a
-      then M2 m (MapPut_behind m' (ad_div_2 a) y)
-      else M2 (MapPut_behind m (ad_div_2 a) y) m').
+     (if Nbit0 a
+      then M2 m (MapPut_behind m' (Ndiv2 a) y)
+      else M2 (MapPut_behind m (Ndiv2 a) y) m').
   Proof.
     simple induction a. trivial.
     simple induction p; trivial.
@@ -463,52 +465,52 @@ Section MapDefs.
 
   Lemma MapPut_behind_as_before_1 :
    forall a a' a0:ad,
-     ad_eq a' a0 = false ->
+     Neqb a' a0 = false ->
      forall y y':A,
        MapGet (MapPut (M1 a y) a' y') a0 =
        MapGet (MapPut_behind (M1 a y) a' y') a0.
   Proof.
-    intros a a' a0. simpl in |- *. intros H y y'. elim (ad_sum (ad_xor a a')). intro H0. elim H0.
+    intros a a' a0. simpl in |- *. intros H y y'. elim (Ndiscr (Nxor a a')). intro H0. elim H0.
     intros p H1. rewrite H1. reflexivity.
-    intro H0. rewrite H0. rewrite (ad_xor_eq _ _ H0). rewrite (M1_semantics_2 a' a0 y H).
+    intro H0. rewrite H0. rewrite (Nxor_eq _ _ H0). rewrite (M1_semantics_2 a' a0 y H).
     exact (M1_semantics_2 a' a0 y' H).
   Qed.
 
   Lemma MapPut_behind_as_before :
    forall (m:Map) (a:ad) (y:A) (a0:ad),
-     ad_eq a a0 = false ->
+     Neqb a a0 = false ->
      MapGet (MapPut m a y) a0 = MapGet (MapPut_behind m a y) a0.
   Proof.
     simple induction m. trivial.
     intros a y a' y' a0 H. exact (MapPut_behind_as_before_1 a a' a0 H y y').
     intros. rewrite MapPut_semantics_3_1. rewrite MapPut_behind_semantics_3_1.
-    elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if.
-    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a0)). intro H3.
-    rewrite H3. apply H0. rewrite <- H3 in H2. exact (ad_div_bit_neq a a0 H1 H2).
+    elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if.
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a0)). intro H3.
+    rewrite H3. apply H0. rewrite <- H3 in H2. exact (Ndiv2_bit_neq a a0 H1 H2).
     intro H3. rewrite H3. reflexivity.
     intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if.
-    elim (sumbool_of_bool (ad_bit_0 a0)). intro H3. rewrite H3. reflexivity.
-    intro H3. rewrite H3. apply H. rewrite <- H3 in H2. exact (ad_div_bit_neq a a0 H1 H2).
+    elim (sumbool_of_bool (Nbit0 a0)). intro H3. rewrite H3. reflexivity.
+    intro H3. rewrite H3. apply H. rewrite <- H3 in H2. exact (Ndiv2_bit_neq a a0 H1 H2).
   Qed.
 
   Lemma MapPut_behind_new :
    forall (m:Map) (a:ad) (y:A),
      MapGet (MapPut_behind m a y) a =
      match MapGet m a with
-     | SOME y' => SOME y'
-     | _ => SOME y
+     | Some y' => Some y'
+     | _ => Some y
      end.
   Proof.
-    simple induction m. simpl in |- *. intros. rewrite (ad_eq_correct a). reflexivity.
-    intros. elim (ad_sum (ad_xor a a1)). intro H. elim H. intros p H0. simpl in |- *.
-    rewrite H0. rewrite (ad_xor_eq_false a a1 p). exact (MapPut1_semantics_2 p a a1 a0 y H0).
+    simple induction m. simpl in |- *. intros. rewrite (Neqb_correct a). reflexivity.
+    intros. elim (Ndiscr (Nxor a a1)). intro H. elim H. intros p H0. simpl in |- *.
+    rewrite H0. rewrite (Nxor_eq_false a a1 p). exact (MapPut1_semantics_2 p a a1 a0 y H0).
     assumption.
-    intro H. simpl in |- *. rewrite H. rewrite <- (ad_xor_eq _ _ H). rewrite (ad_eq_correct a).
+    intro H. simpl in |- *. rewrite H. rewrite <- (Nxor_eq _ _ H). rewrite (Neqb_correct a).
     exact (M1_semantics_1 a a0).
     intros. rewrite MapPut_behind_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a).
-    elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_1 a H1).
-    exact (H0 (ad_div_2 a) y).
-    intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_0 a H1). exact (H (ad_div_2 a) y).
+    elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_1 a H1).
+    exact (H0 (Ndiv2 a) y).
+    intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_0 a H1). exact (H (Ndiv2 a) y).
   Qed.
 
   Lemma MapPut_behind_semantics :
@@ -516,12 +518,12 @@ Section MapDefs.
      eqm (MapGet (MapPut_behind m a y))
        (fun a':ad =>
           match MapGet m a' with
-          | SOME y' => SOME y'
-          | _ => if ad_eq a a' then SOME y else NONE
+          | Some y' => Some y'
+          | _ => if Neqb a a' then Some y else None
           end).
   Proof.
-    unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H.
-    rewrite (ad_eq_complete _ _ H). apply MapPut_behind_new.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H. rewrite H.
+    rewrite (Neqb_complete _ _ H). apply MapPut_behind_new.
     intro H. rewrite H. rewrite <- (MapPut_behind_as_before m a y a0 H).
     rewrite (MapPut_semantics m a y a0). rewrite H. case (MapGet m a0); trivial.
   Qed.
@@ -529,41 +531,41 @@ Section MapDefs.
   Definition makeM2 (m m':Map) :=
     match m, m' with
     | M0, M0 => M0
-    | M0, M1 a y => M1 (ad_double_plus_un a) y
-    | M1 a y, M0 => M1 (ad_double a) y
+    | M0, M1 a y => M1 (Ndouble_plus_one a) y
+    | M1 a y, M0 => M1 (Ndouble a) y
     | _, _ => M2 m m'
     end.
 
   Lemma makeM2_M2 :
    forall m m':Map, eqm (MapGet (makeM2 m m')) (MapGet (M2 m m')).
   Proof.
-    unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H.
+    unfold eqm in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H.
     rewrite (MapGet_M2_bit_0_1 a H m m'). case m'. case m. reflexivity.
-    intros a0 y. simpl in |- *. rewrite (ad_bit_0_1_not_double a H a0). reflexivity.
+    intros a0 y. simpl in |- *. rewrite (Nodd_not_double a H a0). reflexivity.
     intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
     assumption.
-    case m. intros a0 y. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 (ad_div_2 a))).
-    intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0). rewrite (ad_div_2_double_plus_un a H).
-    rewrite (ad_eq_correct a). reflexivity.
-    intro H0. rewrite H0. rewrite (ad_eq_comm a0 (ad_div_2 a)) in H0.
-    rewrite (ad_not_div_2_not_double_plus_un a a0 H0). reflexivity.
+    case m. intros a0 y. simpl in |- *. elim (sumbool_of_bool (Neqb a0 (Ndiv2 a))).
+    intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0). rewrite (Ndiv2_double_plus_one a H).
+    rewrite (Neqb_correct a). reflexivity.
+    intro H0. rewrite H0. rewrite (Neqb_comm a0 (Ndiv2 a)) in H0.
+    rewrite (Nnot_div2_not_double_plus_one a a0 H0). reflexivity.
     intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
     assumption.
     intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
     assumption.
     intros m1 m2. unfold makeM2 in |- *.
-    cut (MapGet (M2 m (M2 m1 m2)) a = MapGet (M2 m1 m2) (ad_div_2 a)). 
+    cut (MapGet (M2 m (M2 m1 m2)) a = MapGet (M2 m1 m2) (Ndiv2 a)). 
     case m; trivial.
     exact (MapGet_M2_bit_0_1 a H m (M2 m1 m2)).
     intro H. rewrite (MapGet_M2_bit_0_0 a H m m'). case m. case m'. reflexivity.
-    intros a0 y. simpl in |- *. rewrite (ad_bit_0_0_not_double_plus_un a H a0). reflexivity.
+    intros a0 y. simpl in |- *. rewrite (Neven_not_double_plus_one a H a0). reflexivity.
     intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
     assumption.
-    case m'. intros a0 y. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 (ad_div_2 a))). intro H0.
-    rewrite H0. rewrite (ad_eq_complete _ _ H0). rewrite (ad_div_2_double a H).
-    rewrite (ad_eq_correct a). reflexivity.
-    intro H0. rewrite H0. rewrite (ad_eq_comm (ad_double a0) a).
-    rewrite (ad_eq_comm a0 (ad_div_2 a)) in H0. rewrite (ad_not_div_2_not_double a a0 H0).
+    case m'. intros a0 y. simpl in |- *. elim (sumbool_of_bool (Neqb a0 (Ndiv2 a))). intro H0.
+    rewrite H0. rewrite (Neqb_complete _ _ H0). rewrite (Ndiv2_double a H).
+    rewrite (Neqb_correct a). reflexivity.
+    intro H0. rewrite H0. rewrite (Neqb_comm (Ndouble a0) a).
+    rewrite (Neqb_comm a0 (Ndiv2 a)) in H0. rewrite (Nnot_div2_not_double a a0 H0).
     reflexivity.
     intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
     assumption.
@@ -576,55 +578,55 @@ Section MapDefs.
     match m with
     | M0 => fun _:ad => M0
     | M1 a y =>
-        fun a':ad => match ad_eq a a' with
+        fun a':ad => match Neqb a a' with
                      | true => M0
                      | false => m
                      end
     | M2 m1 m2 =>
         fun a:ad =>
-          if ad_bit_0 a
-          then makeM2 m1 (MapRemove m2 (ad_div_2 a))
-          else makeM2 (MapRemove m1 (ad_div_2 a)) m2
+          if Nbit0 a
+          then makeM2 m1 (MapRemove m2 (Ndiv2 a))
+          else makeM2 (MapRemove m1 (Ndiv2 a)) m2
     end.
 
   Lemma MapRemove_semantics :
    forall (m:Map) (a:ad),
      eqm (MapGet (MapRemove m a))
-       (fun a':ad => if ad_eq a a' then NONE else MapGet m a').
-  Proof.
-    unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (ad_eq a a0); trivial.
-    intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a1 a2)). intro H. rewrite H.
-    elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0. reflexivity.
-    intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H) in H0. exact (M1_semantics_2 a a2 a0 H0).
-    intro H. elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0. rewrite H.
-    rewrite <- (ad_eq_complete _ _ H0) in H. rewrite H. reflexivity.
+       (fun a':ad => if Neqb a a' then None else MapGet m a').
+  Proof.
+    unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (Neqb a a0); trivial.
+    intros. simpl in |- *. elim (sumbool_of_bool (Neqb a1 a2)). intro H. rewrite H.
+    elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0. reflexivity.
+    intro H0. rewrite H0. rewrite (Neqb_complete _ _ H) in H0. exact (M1_semantics_2 a a2 a0 H0).
+    intro H. elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0. rewrite H.
+    rewrite <- (Neqb_complete _ _ H0) in H. rewrite H. reflexivity.
     intro H0. rewrite H0. rewrite H. reflexivity.
     intros. change
    (MapGet
-      (if ad_bit_0 a
-       then makeM2 m0 (MapRemove m1 (ad_div_2 a))
-       else makeM2 (MapRemove m0 (ad_div_2 a)) m1) a0 =
-    (if ad_eq a a0 then NONE else MapGet (M2 m0 m1) a0)) 
+      (if Nbit0 a
+       then makeM2 m0 (MapRemove m1 (Ndiv2 a))
+       else makeM2 (MapRemove m0 (Ndiv2 a)) m1) a0 =
+    (if Neqb a a0 then None else MapGet (M2 m0 m1) a0)) 
   in |- *.
-    elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1.
-    rewrite (makeM2_M2 m0 (MapRemove m1 (ad_div_2 a)) a0). elim (sumbool_of_bool (ad_bit_0 a0)).
-    intro H2. rewrite MapGet_M2_bit_0_1. rewrite (H0 (ad_div_2 a) (ad_div_2 a0)).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H3. rewrite H3. rewrite (ad_div_eq _ _ H3).
+    elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1.
+    rewrite (makeM2_M2 m0 (MapRemove m1 (Ndiv2 a)) a0). elim (sumbool_of_bool (Nbit0 a0)).
+    intro H2. rewrite MapGet_M2_bit_0_1. rewrite (H0 (Ndiv2 a) (Ndiv2 a0)).
+    elim (sumbool_of_bool (Neqb a a0)). intro H3. rewrite H3. rewrite (Ndiv2_eq _ _ H3).
     reflexivity.
-    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1).
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1).
     rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). reflexivity.
     assumption.
-    intro H2. rewrite (MapGet_M2_bit_0_0 a0 H2 m0 (MapRemove m1 (ad_div_2 a))).
-    rewrite (ad_eq_comm a a0). rewrite (ad_bit_0_neq _ _ H2 H1).
+    intro H2. rewrite (MapGet_M2_bit_0_0 a0 H2 m0 (MapRemove m1 (Ndiv2 a))).
+    rewrite (Neqb_comm a a0). rewrite (Nbit0_neq _ _ H2 H1).
     rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). reflexivity.
-    intro H1. rewrite H1. rewrite (makeM2_M2 (MapRemove m0 (ad_div_2 a)) m1 a0).
-    elim (sumbool_of_bool (ad_bit_0 a0)). intro H2. rewrite MapGet_M2_bit_0_1.
-    rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). rewrite (ad_bit_0_neq a a0 H1 H2). reflexivity.
+    intro H1. rewrite H1. rewrite (makeM2_M2 (MapRemove m0 (Ndiv2 a)) m1 a0).
+    elim (sumbool_of_bool (Nbit0 a0)). intro H2. rewrite MapGet_M2_bit_0_1.
+    rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). rewrite (Nbit0_neq a a0 H1 H2). reflexivity.
     assumption.
-    intro H2. rewrite MapGet_M2_bit_0_0. rewrite (H (ad_div_2 a) (ad_div_2 a0)).
-    rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). elim (sumbool_of_bool (ad_eq a a0)). intro H3.
-    rewrite H3. rewrite (ad_div_eq _ _ H3). reflexivity.
-    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1). reflexivity.
+    intro H2. rewrite MapGet_M2_bit_0_0. rewrite (H (Ndiv2 a) (Ndiv2 a0)).
+    rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). elim (sumbool_of_bool (Neqb a a0)). intro H3.
+    rewrite H3. rewrite (Ndiv2_eq _ _ H3). reflexivity.
+    intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). reflexivity.
     assumption.
   Qed.
 
@@ -653,21 +655,21 @@ Section MapDefs.
      eqm (MapGet (MapMerge m m'))
        (fun a0:ad =>
           match MapGet m' a0 with
-          | SOME y' => SOME y'
-          | NONE => MapGet m a0
+          | Some y' => Some y'
+          | None => MapGet m a0
           end).
   Proof.
     unfold eqm in |- *. simple induction m. intros. simpl in |- *. case (MapGet m' a); trivial.
     intros. simpl in |- *. rewrite (MapPut_behind_semantics m' a a0 a1). reflexivity.
     simple induction m'. trivial.
     intros. unfold MapMerge in |- *. rewrite (MapPut_semantics (M2 m0 m1) a a0 a1).
-    elim (sumbool_of_bool (ad_eq a a1)). intro H1. rewrite H1. rewrite (ad_eq_complete _ _ H1).
+    elim (sumbool_of_bool (Neqb a a1)). intro H1. rewrite H1. rewrite (Neqb_complete _ _ H1).
     rewrite (M1_semantics_1 a1 a0). reflexivity.
     intro H1. rewrite H1. rewrite (M1_semantics_2 a a1 a0 H1). reflexivity.
     intros. cut (MapMerge (M2 m0 m1) (M2 m2 m3) = M2 (MapMerge m0 m2) (MapMerge m1 m3)).
-    intro. rewrite H3. rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)).
-    rewrite (H m2 (ad_div_2 a)). rewrite (MapGet_M2_bit_0_if m2 m3 a).
-    rewrite (MapGet_M2_bit_0_if m0 m1 a). case (ad_bit_0 a); trivial.
+    intro. rewrite H3. rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (Ndiv2 a)).
+    rewrite (H m2 (Ndiv2 a)). rewrite (MapGet_M2_bit_0_if m2 m3 a).
+    rewrite (MapGet_M2_bit_0_if m0 m1 a). case (Nbit0 a); trivial.
     reflexivity.
   Qed.
 
@@ -680,7 +682,7 @@ Section MapDefs.
     | M1 a y =>
         fun m':Map =>
           match MapGet m' a with
-          | NONE => MapPut m' a y
+          | None => MapPut m' a y
           | _ => MapRemove m' a
           end
     | M2 m1 m2 =>
@@ -689,7 +691,7 @@ Section MapDefs.
           | M0 => m
           | M1 a' y' =>
               match MapGet m a' with
-              | NONE => MapPut m a' y'
+              | None => MapPut m a' y'
               | _ => MapRemove m a'
               end
           | M2 m'1 m'2 => makeM2 (MapDelta m1 m'1) (MapDelta m2 m'2)
@@ -701,17 +703,17 @@ Section MapDefs.
   Proof.
     unfold eqm in |- *. simple induction m. simple induction m'; reflexivity.
     simple induction m'. reflexivity.
-    unfold MapDelta in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H.
-    rewrite <- (ad_eq_complete _ _ H). rewrite (M1_semantics_1 a a2).
-    rewrite (M1_semantics_1 a a0). simpl in |- *. rewrite (ad_eq_correct a). reflexivity.
-    intro H. rewrite (M1_semantics_2 a a1 a0 H). rewrite (ad_eq_comm a a1) in H.
+    unfold MapDelta in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H.
+    rewrite <- (Neqb_complete _ _ H). rewrite (M1_semantics_1 a a2).
+    rewrite (M1_semantics_1 a a0). simpl in |- *. rewrite (Neqb_correct a). reflexivity.
+    intro H. rewrite (M1_semantics_2 a a1 a0 H). rewrite (Neqb_comm a a1) in H.
     rewrite (M1_semantics_2 a1 a a2 H). rewrite (MapPut_semantics (M1 a a0) a1 a2 a3).
-    rewrite (MapPut_semantics (M1 a1 a2) a a0 a3). elim (sumbool_of_bool (ad_eq a a3)).
-    intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0) in H. rewrite H.
-    rewrite (ad_eq_complete _ _ H0). rewrite (M1_semantics_1 a3 a0). reflexivity.
+    rewrite (MapPut_semantics (M1 a1 a2) a a0 a3). elim (sumbool_of_bool (Neqb a a3)).
+    intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0) in H. rewrite H.
+    rewrite (Neqb_complete _ _ H0). rewrite (M1_semantics_1 a3 a0). reflexivity.
     intro H0. rewrite H0. rewrite (M1_semantics_2 a a3 a0 H0).
-    elim (sumbool_of_bool (ad_eq a1 a3)). intro H1. rewrite H1.
-    rewrite (ad_eq_complete _ _ H1). exact (M1_semantics_1 a3 a2).
+    elim (sumbool_of_bool (Neqb a1 a3)). intro H1. rewrite H1.
+    rewrite (Neqb_complete _ _ H1). exact (M1_semantics_1 a3 a2).
     intro H1. rewrite H1. exact (M1_semantics_2 a1 a3 a2 H1).
     intros. reflexivity.
     simple induction m'. reflexivity.
@@ -720,24 +722,25 @@ Section MapDefs.
     rewrite (makeM2_M2 (MapDelta m2 m0) (MapDelta m3 m1) a).
     rewrite (MapGet_M2_bit_0_if (MapDelta m0 m2) (MapDelta m1 m3) a).
     rewrite (MapGet_M2_bit_0_if (MapDelta m2 m0) (MapDelta m3 m1) a).
-    rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)). reflexivity.
+    rewrite (H0 m3 (Ndiv2 a)). rewrite (H m2 (Ndiv2 a)). reflexivity.
   Qed.
 
   Lemma MapDelta_semantics_1_1 :
    forall (a:ad) (y:A) (m':Map) (a0:ad),
-     MapGet (M1 a y) a0 = NONE ->
-     MapGet m' a0 = NONE -> MapGet (MapDelta (M1 a y) m') a0 = NONE.
+     MapGet (M1 a y) a0 = None ->
+     MapGet m' a0 = None -> MapGet (MapDelta (M1 a y) m') a0 = None.
   Proof.
-    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1.
-    rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
-    intro H1. case (MapGet m' a). rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
+    intro H1. case (MapGet m' a).  
     rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
+    rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
   Qed.
 
   Lemma MapDelta_semantics_1 :
    forall (m m':Map) (a:ad),
-     MapGet m a = NONE ->
-     MapGet m' a = NONE -> MapGet (MapDelta m m') a = NONE.
+     MapGet m a = None ->
+     MapGet m' a = None -> MapGet (MapDelta m m') a = None.
   Proof.
     simple induction m. trivial.
     exact MapDelta_semantics_1_1.
@@ -745,7 +748,7 @@ Section MapDefs.
     intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
     apply MapDelta_semantics_1_1; trivial.
     intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
-    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5.
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5.
     apply H0. rewrite (MapGet_M2_bit_0_1 a H5 m0 m1) in H3. exact H3.
     rewrite (MapGet_M2_bit_0_1 a H5 m2 m3) in H4. exact H4.
     intro H5. rewrite H5. apply H. rewrite (MapGet_M2_bit_0_0 a H5 m0 m1) in H3. exact H3.
@@ -754,31 +757,32 @@ Section MapDefs.
 
   Lemma MapDelta_semantics_2_1 :
    forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A),
-     MapGet (M1 a y) a0 = NONE ->
-     MapGet m' a0 = SOME y0 -> MapGet (MapDelta (M1 a y) m') a0 = SOME y0.
+     MapGet (M1 a y) a0 = None ->
+     MapGet m' a0 = Some y0 -> MapGet (MapDelta (M1 a y) m') a0 = Some y0.
   Proof.
-    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1.
-    rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
-    intro H1. case (MapGet m' a). rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
+    intro H1. case (MapGet m' a).
     rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
+    rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
   Qed.
 
   Lemma MapDelta_semantics_2_2 :
    forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A),
-     MapGet (M1 a y) a0 = SOME y0 ->
-     MapGet m' a0 = NONE -> MapGet (MapDelta (M1 a y) m') a0 = SOME y0.
+     MapGet (M1 a y) a0 = Some y0 ->
+     MapGet m' a0 = None -> MapGet (MapDelta (M1 a y) m') a0 = Some y0.
   Proof.
-    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1.
-    rewrite (ad_eq_complete _ _ H1) in H. rewrite (ad_eq_complete _ _ H1).
-    rewrite H0. rewrite (MapPut_semantics m' a0 y a0). rewrite (ad_eq_correct a0).
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a a0)). intro H1.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (Neqb_complete _ _ H1).
+    rewrite H0. rewrite (MapPut_semantics m' a0 y a0). rewrite (Neqb_correct a0).
     rewrite (M1_semantics_1 a0 y) in H. simple inversion H. assumption.
     intro H1. rewrite (M1_semantics_2 a a0 y H1) in H. discriminate H.
   Qed.
 
   Lemma MapDelta_semantics_2 :
    forall (m m':Map) (a:ad) (y:A),
-     MapGet m a = NONE ->
-     MapGet m' a = SOME y -> MapGet (MapDelta m m') a = SOME y.
+     MapGet m a = None ->
+     MapGet m' a = Some y -> MapGet (MapDelta m m') a = Some y.
   Proof.
     simple induction m. trivial.
     exact MapDelta_semantics_2_1.
@@ -786,7 +790,7 @@ Section MapDefs.
     intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
     apply MapDelta_semantics_2_2; assumption.
     intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
-    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5.
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5.
     apply H0. rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption.
     rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption.
     intro H5. rewrite H5. apply H. rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption.
@@ -795,19 +799,19 @@ Section MapDefs.
 
   Lemma MapDelta_semantics_3_1 :
    forall (a0:ad) (y0:A) (m':Map) (a:ad) (y y':A),
-     MapGet (M1 a0 y0) a = SOME y ->
-     MapGet m' a = SOME y' -> MapGet (MapDelta (M1 a0 y0) m') a = NONE.
+     MapGet (M1 a0 y0) a = Some y ->
+     MapGet m' a = Some y' -> MapGet (MapDelta (M1 a0 y0) m') a = None.
   Proof.
-    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a0 a)). intro H1.
-    rewrite (ad_eq_complete a0 a H1). rewrite H0. rewrite (MapRemove_semantics m' a a).
-    rewrite (ad_eq_correct a). reflexivity.
+    intros. unfold MapDelta in |- *. elim (sumbool_of_bool (Neqb a0 a)). intro H1.
+    rewrite (Neqb_complete a0 a H1). rewrite H0. rewrite (MapRemove_semantics m' a a).
+    rewrite (Neqb_correct a). reflexivity.
     intro H1. rewrite (M1_semantics_2 a0 a y0 H1) in H. discriminate H.
   Qed.
 
   Lemma MapDelta_semantics_3 :
    forall (m m':Map) (a:ad) (y y':A),
-     MapGet m a = SOME y ->
-     MapGet m' a = SOME y' -> MapGet (MapDelta m m') a = NONE.
+     MapGet m a = Some y ->
+     MapGet m' a = Some y' -> MapGet (MapDelta m m') a = None.
   Proof.
     simple induction m. intros. discriminate H.
     exact MapDelta_semantics_3_1.
@@ -815,10 +819,10 @@ Section MapDefs.
     intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
     exact (MapDelta_semantics_3_1 a a0 (M2 m0 m1) a1 y' y H2 H1).
     intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
-    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5.
-    apply (H0 m3 (ad_div_2 a) y y'). rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption.
+    rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5.
+    apply (H0 m3 (Ndiv2 a) y y'). rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption.
     rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption.
-    intro H5. rewrite H5. apply (H m2 (ad_div_2 a) y y').
+    intro H5. rewrite H5. apply (H m2 (Ndiv2 a) y y').
     rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption.
     rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption.
   Qed.
@@ -828,9 +832,9 @@ Section MapDefs.
      eqm (MapGet (MapDelta m m'))
        (fun a0:ad =>
           match MapGet m a0, MapGet m' a0 with
-          | NONE, SOME y' => SOME y'
-          | SOME y, NONE => SOME y
-          | _, _ => NONE
+          | None, Some y' => Some y'
+          | Some y, None => Some y
+          | _, _ => None
           end).
   Proof.
     unfold eqm in |- *. intros. elim (option_sum (MapGet m' a)). intro H. elim H. intros a0 H0.
diff --git a/theories/IntMap/Mapaxioms.v b/theories/IntMap/Mapaxioms.v
index 9d09f2a9..0722bcfa 100644
--- a/theories/IntMap/Mapaxioms.v
+++ b/theories/IntMap/Mapaxioms.v
@@ -5,14 +5,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapaxioms.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Mapaxioms.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Fset.
 
@@ -59,8 +58,8 @@ Section MapAxioms.
      eqmap (MapPut A m a y) (MapMerge A m (M1 A a y)).
   Proof.
     unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m a y a0).
-    rewrite (MapMerge_semantics A m (M1 A a y) a0). unfold MapGet at 2 in |- *.
-    elim (sumbool_of_bool (ad_eq a a0)); intro H; rewrite H; reflexivity.
+    rewrite (MapMerge_semantics A m (M1 A a y) a0). unfold MapGet at 2.
+    elim (sumbool_of_bool (Neqb a a0)); intro H; rewrite H; reflexivity.
   Qed.
 
   Lemma MapPut_ext :
@@ -70,7 +69,7 @@ Section MapAxioms.
   Proof.
     unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m' a y a0).
     rewrite (MapPut_semantics A m a y a0). 
-    case (ad_eq a a0); [ reflexivity | apply H ].
+    case (Neqb a a0); [ reflexivity | apply H ].
   Qed.
 
   Lemma MapPut_behind_as_Merge :
@@ -115,7 +114,7 @@ Section MapAxioms.
    forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m (M0 A).
   Proof.
     unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a).
-    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a). trivial.
+    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a); trivial.
     intros. discriminate H0.
     exact (H a).
   Qed.
@@ -124,8 +123,7 @@ Section MapAxioms.
    forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m' (M0 A).
   Proof.
     unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a).
-    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a). trivial.
-    intros. discriminate H0.
+    rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a); trivial.
     exact (H a).
   Qed.
 
@@ -190,8 +188,8 @@ Section MapAxioms.
      eqmap (MapRemove A m a) (MapDomRestrBy A B m (M1 B a y)).
   Proof.
     unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m a a0).
-    rewrite (MapDomRestrBy_semantics A B m (M1 B a y) a0). elim (sumbool_of_bool (ad_eq a a0)).
-    intro H. rewrite H. rewrite (ad_eq_complete a a0 H). rewrite (M1_semantics_1 B a0 y).
+    rewrite (MapDomRestrBy_semantics A B m (M1 B a y) a0). elim (sumbool_of_bool (Neqb a a0)).
+    intro H. rewrite H. rewrite (Neqb_complete a a0 H). rewrite (M1_semantics_1 B a0 y).
     reflexivity.
     intro H. rewrite H. rewrite (M1_semantics_2 B a a0 y H). reflexivity.
   Qed.
@@ -202,7 +200,7 @@ Section MapAxioms.
   Proof.
     unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m' a a0).
     rewrite (MapRemove_semantics A m a a0). 
-    case (ad_eq a a0); [ reflexivity | apply H ].
+    case (Neqb a a0); [ reflexivity | apply H ].
   Qed.
 
   Lemma MapDomRestrTo_empty_m_1 :
@@ -259,7 +257,7 @@ Section MapAxioms.
     elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0. unfold in_FSet, in_dom in H.
     generalize H. case (MapGet unit (MapDom B m') a); trivial. intro H1. discriminate H1.
     intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H.
-    generalize H. case (MapGet unit (MapDom B m') a). trivial.
+    generalize H. case (MapGet unit (MapDom B m') a); trivial.
     intros H0 H1. discriminate H1.
   Qed.
 
@@ -298,7 +296,7 @@ Section MapAxioms.
     unfold in_FSet, in_dom in H. generalize H. case (MapGet unit (MapDom B m') a); trivial.
     intro H1. discriminate H1.
     intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H.
-    generalize H. case (MapGet unit (MapDom B m') a). trivial.
+    generalize H. case (MapGet unit (MapDom B m') a); trivial.
     intros H0 H1. discriminate H1.
   Qed.
 
diff --git a/theories/IntMap/Mapc.v b/theories/IntMap/Mapc.v
index 7a394abb..163373bf 100644
--- a/theories/IntMap/Mapc.v
+++ b/theories/IntMap/Mapc.v
@@ -5,15 +5,12 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapc.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Mapc.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
 Require Import Map.
 Require Import Mapaxioms.
 Require Import Fset.
diff --git a/theories/IntMap/Mapcanon.v b/theories/IntMap/Mapcanon.v
index 868fbe5e..33741b98 100644
--- a/theories/IntMap/Mapcanon.v
+++ b/theories/IntMap/Mapcanon.v
@@ -5,15 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapcanon.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Mapcanon.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Mapaxioms.
 Require Import Mapiter.
@@ -57,37 +56,37 @@ Section MapCanon.
    forall m0 m1 m2 m3:Map A,
      eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m0 m2.
   Proof.
-    unfold eqmap, eqm in |- *. intros. rewrite <- (ad_double_div_2 a).
-    rewrite <- (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m0 m1).
-    rewrite <- (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m2 m3).
-    exact (H (ad_double a)).
+    unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_div2 a).
+    rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1).
+    rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m2 m3).
+    exact (H (Ndouble a)).
   Qed.
 
   Lemma M2_eqmap_2 :
    forall m0 m1 m2 m3:Map A,
      eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m1 m3.
   Proof.
-    unfold eqmap, eqm in |- *. intros. rewrite <- (ad_double_plus_un_div_2 a).
-    rewrite <- (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m0 m1).
-    rewrite <- (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m2 m3).
-    exact (H (ad_double_plus_un a)).
+    unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_plus_one_div2 a).
+    rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1).
+    rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m2 m3).
+    exact (H (Ndouble_plus_one a)).
   Qed.
 
   Lemma mapcanon_unique :
    forall m m':Map A, mapcanon m -> mapcanon m' -> eqmap A m m' -> m = m'.
   Proof.
     simple induction m. simple induction m'. trivial.
-    intros a y H H0 H1. cut (NONE A = MapGet A (M1 A a y) a). simpl in |- *. rewrite (ad_eq_correct a).
+    intros a y H H0 H1. cut (None = MapGet A (M1 A a y) a). simpl in |- *. rewrite (Neqb_correct a).
     intro. discriminate H2.
     exact (H1 a).
     intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4).
     rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2).
-    intros a y. simple induction m'. intros. cut (MapGet A (M1 A a y) a = NONE A). simpl in |- *.
-    rewrite (ad_eq_correct a). intro. discriminate H2.
+    intros a y. simple induction m'. intros. cut (MapGet A (M1 A a y) a = None). simpl in |- *.
+    rewrite (Neqb_correct a). intro. discriminate H2.
     exact (H1 a).
     intros a0 y0 H H0 H1. cut (MapGet A (M1 A a y) a = MapGet A (M1 A a0 y0) a). simpl in |- *.
-    rewrite (ad_eq_correct a). intro. elim (sumbool_of_bool (ad_eq a0 a)). intro H3.
-    rewrite H3 in H2. inversion H2. rewrite (ad_eq_complete _ _ H3). reflexivity.
+    rewrite (Neqb_correct a). intro. elim (sumbool_of_bool (Neqb a0 a)). intro H3.
+    rewrite H3 in H2. inversion H2. rewrite (Neqb_complete _ _ H3). reflexivity.
     intro H3. rewrite H3 in H2. discriminate H2.
     exact (H1 a).
     intros. cut (2 <= MapCard A (M1 A a y)). intro. elim (le_Sn_O _ (le_S_n _ _ H4)).
@@ -109,19 +108,19 @@ Section MapCanon.
   Lemma MapPut1_canon :
    forall (p:positive) (a a':ad) (y y':A), mapcanon (MapPut1 A a y a' y' p).
   Proof.
-    simple induction p. simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M1_canon.
+    simple induction p. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon.
     apply M1_canon.
     apply le_n.
     apply M2_canon. apply M1_canon.
     apply M1_canon.
     apply le_n.
-    simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M0_canon.
+    simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M0_canon.
     apply H.
     simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n.
     apply M2_canon. apply H.
     apply M0_canon.
     simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n.
-    simpl in |- *. simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M1_canon.
+    simpl in |- *. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon.
     apply M1_canon.
     simpl in |- *. apply le_n.
     apply M2_canon. apply M1_canon.
@@ -134,28 +133,28 @@ Section MapCanon.
      mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut A m a y).
   Proof.
     simple induction m. intros. simpl in |- *. apply M1_canon.
-    intros a0 y0 H a y. simpl in |- *. case (ad_xor a0 a). apply M1_canon.
+    intros a0 y0 H a y. simpl in |- *. case (Nxor a0 a). apply M1_canon.
     intro. apply MapPut1_canon.
     intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
     exact (mapcanon_M2_2 m0 m1 H1).
     simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1).
-    apply plus_le_compat. exact (MapCard_Put_lb A m0 ad_z y).
+    apply plus_le_compat. exact (MapCard_Put_lb A m0 N0 y).
     apply le_n.
     intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1).
     apply H0. exact (mapcanon_M2_2 m0 m1 H1).
     simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
     exact (mapcanon_M2 m0 m1 H1).
-    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 (ad_x p0) y).
+    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 (Npos p0) y).
     intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
     exact (mapcanon_M2_2 m0 m1 H1).
     simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
     exact (mapcanon_M2 m0 m1 H1).
-    apply plus_le_compat_r. exact (MapCard_Put_lb A m0 (ad_x p0) y).
+    apply plus_le_compat_r. exact (MapCard_Put_lb A m0 (Npos p0) y).
     apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1).
     apply H0. apply (mapcanon_M2_2 m0 m1 H1).
     simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
     exact (mapcanon_M2 m0 m1 H1).
-    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 ad_z y).
+    apply plus_le_compat_l. exact (MapCard_Put_lb A m1 N0 y).
   Qed.
 
   Lemma MapPut_behind_canon :
@@ -163,37 +162,37 @@ Section MapCanon.
      mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut_behind A m a y).
   Proof.
     simple induction m. intros. simpl in |- *. apply M1_canon.
-    intros a0 y0 H a y. simpl in |- *. case (ad_xor a0 a). apply M1_canon.
+    intros a0 y0 H a y. simpl in |- *. case (Nxor a0 a). apply M1_canon.
     intro. apply MapPut1_canon.
     intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
     exact (mapcanon_M2_2 m0 m1 H1).
     simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1).
-    apply plus_le_compat. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 ad_z y).
+    apply plus_le_compat. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 N0 y).
     apply le_n.
     intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1).
     apply H0. exact (mapcanon_M2_2 m0 m1 H1).
     simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
     exact (mapcanon_M2 m0 m1 H1).
-    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 (ad_x p0) y).
+    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 (Npos p0) y).
     intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
     exact (mapcanon_M2_2 m0 m1 H1).
     simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
     exact (mapcanon_M2 m0 m1 H1).
-    apply plus_le_compat_r. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 (ad_x p0) y).
+    apply plus_le_compat_r. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 (Npos p0) y).
     apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1).
     apply H0. apply (mapcanon_M2_2 m0 m1 H1).
     simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
     exact (mapcanon_M2 m0 m1 H1).
-    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 ad_z y).
+    apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 N0 y).
   Qed.
 
   Lemma makeM2_canon :
    forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (makeM2 A m m').
   Proof.
     intro. case m. intro. case m'. intros. exact M0_canon.
-    intros a y H H0. exact (M1_canon (ad_double_plus_un a) y).
+    intros a y H H0. exact (M1_canon (Ndouble_plus_one a) y).
     intros. simpl in |- *. apply M2_canon; try assumption. exact (mapcanon_M2 m0 m1 H0).
-    intros a y m'. case m'. intros. exact (M1_canon (ad_double a) y).
+    intros a y m'. case m'. intros. exact (M1_canon (Ndouble a) y).
     intros a0 y0 H H0. simpl in |- *. apply M2_canon; try assumption. apply le_n.
     intros. simpl in |- *. apply M2_canon; try assumption.
     apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H0).
@@ -216,7 +215,7 @@ Section MapCanon.
     intros. simpl in |- *. unfold eqmap, eqm in |- *. intro.
     rewrite (makeM2_M2 A (MapCanonicalize m0) (MapCanonicalize m1) a).
     rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if.
-    rewrite <- (H (ad_div_2 a)). rewrite <- (H0 (ad_div_2 a)). reflexivity.
+    rewrite <- (H (Ndiv2 a)). rewrite <- (H0 (Ndiv2 a)). reflexivity.
   Qed.
 
   Lemma mapcanon_exists_2 : forall m:Map A, mapcanon (MapCanonicalize m).
@@ -237,9 +236,9 @@ Section MapCanon.
    forall m:Map A, mapcanon m -> forall a:ad, mapcanon (MapRemove A m a).
   Proof.
     simple induction m. intros. exact M0_canon.
-    intros a y H a0. simpl in |- *. case (ad_eq a a0). exact M0_canon.
+    intros a y H a0. simpl in |- *. case (Neqb a a0). exact M0_canon.
     assumption.
-    intros. simpl in |- *. case (ad_bit_0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
+    intros. simpl in |- *. case (Nbit0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
     apply H0. exact (mapcanon_M2_2 _ _ H1).
     apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1).
     exact (mapcanon_M2_2 _ _ H1).
@@ -265,12 +264,13 @@ Section MapCanon.
    forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapDelta A m m').
   Proof.
     simple induction m. intros. exact H0.
-    simpl in |- *. intros a y m' H H0. case (MapGet A m' a). exact (MapPut_canon m' H0 a y).
+    simpl in |- *. intros a y m' H H0. case (MapGet A m' a).
     intro. exact (MapRemove_canon m' H0 a).
+    exact (MapPut_canon m' H0 a y).
     simple induction m'. intros. exact H1.
-    unfold MapDelta in |- *. intros a y H1 H2. case (MapGet A (M2 A m0 m1) a).
-    exact (MapPut_canon _ H1 a y).
+    unfold MapDelta in |- *. intros a y H1 H2. case (MapGet A (M2 A m0 m1) a). 
     intro. exact (MapRemove_canon _ H1 a).
+    exact (MapPut_canon _ H1 a y).
     intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H3).
     exact (mapcanon_M2_1 _ _ H4).
     apply H0. exact (mapcanon_M2_2 _ _ H3).
@@ -284,11 +284,13 @@ Section MapCanon.
      mapcanon m -> forall m':Map B, mapcanon (MapDomRestrTo A B m m').
   Proof.
     simple induction m. intros. exact M0_canon.
-    simpl in |- *. intros a y H m'. case (MapGet B m' a). exact M0_canon.
+    simpl in |- *. intros a y H m'. case (MapGet B m' a). 
     intro. apply M1_canon.
+    exact M0_canon.
     simple induction m'. exact M0_canon.
-    unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a). exact M0_canon.
+    unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a). 
     intro. apply M1_canon.
+    exact M0_canon.
     intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
     apply H0. exact (mapcanon_M2_2 m0 m1 H1).
   Qed.
@@ -298,10 +300,10 @@ Section MapCanon.
      mapcanon m -> forall m':Map B, mapcanon (MapDomRestrBy A B m m').
   Proof.
     simple induction m. intros. exact M0_canon.
-    simpl in |- *. intros a y H m'. case (MapGet B m' a). assumption.
+    simpl in |- *. intros a y H m'. case (MapGet B m' a); try assumption.
     intro. exact M0_canon.
     simple induction m'. exact H1.
-    intros a y. simpl in |- *. case (ad_bit_0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
+    intros a y. simpl in |- *. case (Nbit0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
     apply MapRemove_canon. exact (mapcanon_M2_2 _ _ H1).
     apply makeM2_canon. apply MapRemove_canon. exact (mapcanon_M2_1 _ _ H1).
     exact (mapcanon_M2_2 _ _ H1).
diff --git a/theories/IntMap/Mapcard.v b/theories/IntMap/Mapcard.v
index 49f9fe91..36be9bf9 100644
--- a/theories/IntMap/Mapcard.v
+++ b/theories/IntMap/Mapcard.v
@@ -5,15 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapcard.v,v 1.5.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Mapcard.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Mapaxioms.
 Require Import Mapiter.
@@ -38,80 +37,80 @@ Section MapCard.
   Qed.
 
   Lemma MapCard_is_O :
-   forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = NONE A.
+   forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = None.
   Proof.
     simple induction m. trivial.
     intros a y H. discriminate H.
     intros. simpl in H1. elim (plus_is_O _ _ H1). intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a).
-    case (ad_bit_0 a). apply H0. assumption.
+    case (Nbit0 a). apply H0. assumption.
     apply H. assumption.
   Qed.
 
   Lemma MapCard_is_not_O :
    forall (m:Map A) (a:ad) (y:A),
-     MapGet A m a = SOME A y -> {n : nat | MapCard A m = S n}.
+     MapGet A m a = Some y -> {n : nat | MapCard A m = S n}.
   Proof.
     simple induction m. intros. discriminate H.
-    intros a y a0 y0 H. simpl in H. elim (sumbool_of_bool (ad_eq a a0)). intro H0. split with 0.
+    intros a y a0 y0 H. simpl in H. elim (sumbool_of_bool (Neqb a a0)). intro H0. split with 0.
     reflexivity.
     intro H0. rewrite H0 in H. discriminate H.
-    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2.
-    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. elim (H0 (ad_div_2 a) y H1). intros n H3.
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H2.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. elim (H0 (Ndiv2 a) y H1). intros n H3.
     simpl in |- *. rewrite H3. split with (MapCard A m0 + n).
     rewrite <- (plus_Snm_nSm (MapCard A m0) n). reflexivity.
-    intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. elim (H (ad_div_2 a) y H1).
+    intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. elim (H (Ndiv2 a) y H1).
     intros n H3. simpl in |- *. rewrite H3. split with (n + MapCard A m1). reflexivity.
   Qed.
 
   Lemma MapCard_is_one :
    forall m:Map A,
-     MapCard A m = 1 -> {a : ad &  {y : A | MapGet A m a = SOME A y}}.
+     MapCard A m = 1 -> {a : ad &  {y : A | MapGet A m a = Some y}}.
   Proof.
     simple induction m. intro. discriminate H.
     intros a y H. split with a. split with y. apply M1_semantics_1.
     intros. simpl in H1. elim (plus_is_one (MapCard A m0) (MapCard A m1) H1).
-    intro H2. elim H2. intros. elim (H0 H4). intros a H5. split with (ad_double_plus_un a).
-    rewrite (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m0 m1).
-    rewrite ad_double_plus_un_div_2. exact H5.
-    intro H2. elim H2. intros. elim (H H3). intros a H5. split with (ad_double a).
-    rewrite (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m0 m1).
-    rewrite ad_double_div_2. exact H5.
+    intro H2. elim H2. intros. elim (H0 H4). intros a H5. split with (Ndouble_plus_one a).
+    rewrite (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1).
+    rewrite Ndouble_plus_one_div2. exact H5.
+    intro H2. elim H2. intros. elim (H H3). intros a H5. split with (Ndouble a).
+    rewrite (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1).
+    rewrite Ndouble_div2. exact H5.
   Qed.
 
   Lemma MapCard_is_one_unique :
    forall m:Map A,
      MapCard A m = 1 ->
      forall (a a':ad) (y y':A),
-       MapGet A m a = SOME A y ->
-       MapGet A m a' = SOME A y' -> a = a' /\ y = y'.
+       MapGet A m a = Some y ->
+       MapGet A m a' = Some y' -> a = a' /\ y = y'.
   Proof.
     simple induction m. intro. discriminate H.
-    intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2. rewrite (ad_eq_complete _ _ H2) in H0.
-    rewrite (M1_semantics_1 A a1 a0) in H0. inversion H0. elim (sumbool_of_bool (ad_eq a a')).
-    intro H5. rewrite (ad_eq_complete _ _ H5) in H1. rewrite (M1_semantics_1 A a' a0) in H1.
-    inversion H1. rewrite <- (ad_eq_complete _ _ H2). rewrite <- (ad_eq_complete _ _ H5).
+    intros. elim (sumbool_of_bool (Neqb a a1)). intro H2. rewrite (Neqb_complete _ _ H2) in H0.
+    rewrite (M1_semantics_1 A a1 a0) in H0. inversion H0. elim (sumbool_of_bool (Neqb a a')).
+    intro H5. rewrite (Neqb_complete _ _ H5) in H1. rewrite (M1_semantics_1 A a' a0) in H1.
+    inversion H1. rewrite <- (Neqb_complete _ _ H2). rewrite <- (Neqb_complete _ _ H5).
     rewrite <- H4. rewrite <- H6. split; reflexivity.
     intro H5. rewrite (M1_semantics_2 A a a' a0 H5) in H1. discriminate H1.
     intro H2. rewrite (M1_semantics_2 A a a1 a0 H2) in H0. discriminate H0.
     intros. simpl in H1. elim (plus_is_one _ _ H1). intro H4. elim H4. intros.
-    rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. elim (sumbool_of_bool (ad_bit_0 a)).
+    rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. elim (sumbool_of_bool (Nbit0 a)).
     intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3.
-    elim (sumbool_of_bool (ad_bit_0 a')). intro H8. rewrite H8 in H3. elim (H0 H6 _ _ _ _ H2 H3).
-    intros. split. rewrite <- (ad_div_2_double_plus_un a H7).
-    rewrite <- (ad_div_2_double_plus_un a' H8). rewrite H9. reflexivity.
+    elim (sumbool_of_bool (Nbit0 a')). intro H8. rewrite H8 in H3. elim (H0 H6 _ _ _ _ H2 H3).
+    intros. split. rewrite <- (Ndiv2_double_plus_one a H7).
+    rewrite <- (Ndiv2_double_plus_one a' H8). rewrite H9. reflexivity.
     assumption.
-    intro H8. rewrite H8 in H3. rewrite (MapCard_is_O m0 H5 (ad_div_2 a')) in H3.
+    intro H8. rewrite H8 in H3. rewrite (MapCard_is_O m0 H5 (Ndiv2 a')) in H3.
     discriminate H3.
-    intro H7. rewrite H7 in H2. rewrite (MapCard_is_O m0 H5 (ad_div_2 a)) in H2.
+    intro H7. rewrite H7 in H2. rewrite (MapCard_is_O m0 H5 (Ndiv2 a)) in H2.
     discriminate H2.
     intro H4. elim H4. intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2.
-    elim (sumbool_of_bool (ad_bit_0 a)). intro H7. rewrite H7 in H2.
-    rewrite (MapCard_is_O m1 H6 (ad_div_2 a)) in H2. discriminate H2.
+    elim (sumbool_of_bool (Nbit0 a)). intro H7. rewrite H7 in H2.
+    rewrite (MapCard_is_O m1 H6 (Ndiv2 a)) in H2. discriminate H2.
     intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3.
-    elim (sumbool_of_bool (ad_bit_0 a')). intro H8. rewrite H8 in H3.
-    rewrite (MapCard_is_O m1 H6 (ad_div_2 a')) in H3. discriminate H3.
+    elim (sumbool_of_bool (Nbit0 a')). intro H8. rewrite H8 in H3.
+    rewrite (MapCard_is_O m1 H6 (Ndiv2 a')) in H3. discriminate H3.
     intro H8. rewrite H8 in H3. elim (H H5 _ _ _ _ H2 H3). intros. split.
-    rewrite <- (ad_div_2_double a H7). rewrite <- (ad_div_2_double a' H8).
+    rewrite <- (Ndiv2_double a H7). rewrite <- (Ndiv2_double a' H8).
     rewrite H9. reflexivity.
     assumption.
   Qed.
@@ -139,8 +138,8 @@ Section MapCard.
   Proof.
     simple induction m. trivial.
     trivial.
-    intros. simpl in |- *. rewrite <- (H (fun a0:ad => pf (ad_double a0))).
-    rewrite <- (H0 (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity.
+    intros. simpl in |- *. rewrite <- (H (fun a0:ad => pf (Ndouble a0))).
+    rewrite <- (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity.
   Qed.
 
   Lemma MapCard_as_Fold :
@@ -164,10 +163,10 @@ Section MapCard.
    forall (p:positive) (a a':ad) (y y':A),
      MapCard A (MapPut1 A a y a' y' p) = 2.
   Proof.
-    simple induction p. intros. simpl in |- *. case (ad_bit_0 a); reflexivity.
-    intros. simpl in |- *. case (ad_bit_0 a). exact (H (ad_div_2 a) (ad_div_2 a') y y').
-    simpl in |- *. rewrite <- plus_n_O. exact (H (ad_div_2 a) (ad_div_2 a') y y').
-    intros. simpl in |- *. case (ad_bit_0 a); reflexivity.
+    simple induction p. intros. simpl in |- *. case (Nbit0 a); reflexivity.
+    intros. simpl in |- *. case (Nbit0 a). exact (H (Ndiv2 a) (Ndiv2 a') y y').
+    simpl in |- *. rewrite <- plus_n_O. exact (H (Ndiv2 a) (Ndiv2 a') y y').
+    intros. simpl in |- *. case (Nbit0 a); reflexivity.
   Qed.
 
   Lemma MapCard_Put_sum :
@@ -177,17 +176,17 @@ Section MapCard.
   Proof.
     simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. right.
     rewrite H0. rewrite H1. reflexivity.
-    intros a y m' a0 y0 n n' H H0 H1. simpl in H. elim (ad_sum (ad_xor a a0)). intro H2.
+    intros a y m' a0 y0 n n' H H0 H1. simpl in H. elim (Ndiscr (Nxor a a0)). intro H2.
     elim H2. intros p H3. rewrite H3 in H. rewrite H in H1.
     rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H1. simpl in H0. right.
     rewrite H0. rewrite H1. reflexivity.
     intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. simpl in H0. left.
     rewrite H0. rewrite H1. reflexivity.
     intros. simpl in H2. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1.
-    elim (sumbool_of_bool (ad_bit_0 a)). intro H4. rewrite H4 in H1.
+    elim (sumbool_of_bool (Nbit0 a)). intro H4. rewrite H4 in H1.
     elim
-     (H0 (MapPut A m1 (ad_div_2 a) y) (ad_div_2 a) y (
-        MapCard A m1) (MapCard A (MapPut A m1 (ad_div_2 a) y)) (
+     (H0 (MapPut A m1 (Ndiv2 a) y) (Ndiv2 a) y (
+        MapCard A m1) (MapCard A (MapPut A m1 (Ndiv2 a) y)) (
         refl_equal _) (refl_equal _) (refl_equal _)).
     intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. rewrite <- H2 in H3. left.
     assumption.
@@ -196,8 +195,8 @@ Section MapCard.
     simpl in H3. rewrite <- H2 in H3. right. assumption.
     intro H4. rewrite H4 in H1.
     elim
-     (H (MapPut A m0 (ad_div_2 a) y) (ad_div_2 a) y (
-        MapCard A m0) (MapCard A (MapPut A m0 (ad_div_2 a) y)) (
+     (H (MapPut A m0 (Ndiv2 a) y) (Ndiv2 a) y (
+        MapCard A m0) (MapCard A (MapPut A m0 (Ndiv2 a) y)) (
         refl_equal _) (refl_equal _) (refl_equal _)).
     intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. rewrite <- H2 in H3.
     left. assumption.
@@ -233,35 +232,35 @@ Section MapCard.
   Lemma MapCard_Put_1 :
    forall (m:Map A) (a:ad) (y:A),
      MapCard A (MapPut A m a y) = MapCard A m ->
-     {y : A | MapGet A m a = SOME A y}.
+     {y : A | MapGet A m a = Some y}.
   Proof.
     simple induction m. intros. discriminate H.
-    intros a y a0 y0 H. simpl in H. elim (ad_sum (ad_xor a a0)). intro H0. elim H0.
+    intros a y a0 y0 H. simpl in H. elim (Ndiscr (Nxor a a0)). intro H0. elim H0.
     intros p H1. rewrite H1 in H. rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H.
     discriminate H.
-    intro H0. rewrite H0 in H. rewrite (ad_xor_eq _ _ H0). split with y. apply M1_semantics_1.
-    intros. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1. elim (sumbool_of_bool (ad_bit_0 a)).
-    intro H2. rewrite H2 in H1. simpl in H1. elim (H0 (ad_div_2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)).
+    intro H0. rewrite H0 in H. rewrite (Nxor_eq _ _ H0). split with y. apply M1_semantics_1.
+    intros. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1. elim (sumbool_of_bool (Nbit0 a)).
+    intro H2. rewrite H2 in H1. simpl in H1. elim (H0 (Ndiv2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)).
     intros y0 H3. split with y0. rewrite <- H3. exact (MapGet_M2_bit_0_1 A a H2 m0 m1).
     intro H2. rewrite H2 in H1. simpl in H1.
     rewrite
-     (plus_comm (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1))
+     (plus_comm (MapCard A (MapPut A m0 (Ndiv2 a) y)) (MapCard A m1))
       in H1.
     rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1.
-    elim (H (ad_div_2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)). intros y0 H3. split with y0.
+    elim (H (Ndiv2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)). intros y0 H3. split with y0.
     rewrite <- H3. exact (MapGet_M2_bit_0_0 A a H2 m0 m1).
   Qed.
 
   Lemma MapCard_Put_2 :
    forall (m:Map A) (a:ad) (y:A),
-     MapCard A (MapPut A m a y) = S (MapCard A m) -> MapGet A m a = NONE A.
+     MapCard A (MapPut A m a y) = S (MapCard A m) -> MapGet A m a = None.
   Proof.
     simple induction m. trivial.
-    intros. simpl in H. elim (sumbool_of_bool (ad_eq a a1)). intro H0.
-    rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_xor_nilpotent a1) in H. discriminate H.
+    intros. simpl in H. elim (sumbool_of_bool (Neqb a a1)). intro H0.
+    rewrite (Neqb_complete _ _ H0) in H. rewrite (Nxor_nilpotent a1) in H. discriminate H.
     intro H0. exact (M1_semantics_2 A a a1 a0 H0).
-    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2.
-    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply (H0 (ad_div_2 a) y).
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H2.
+    rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply (H0 (Ndiv2 a) y).
     apply (fun n m p:nat => plus_reg_l m p n) with (n := MapCard A m0).
     rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)). simpl in H1. simpl in |- *. rewrite <- H1.
     clear H1.
@@ -269,11 +268,11 @@ Section MapCard.
     induction p. reflexivity.
     discriminate H2.
     reflexivity.
-    intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply (H (ad_div_2 a) y).
+    intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply (H (Ndiv2 a) y).
     cut
-     (MapCard A (MapPut A m0 (ad_div_2 a) y) + MapCard A m1 =
+     (MapCard A (MapPut A m0 (Ndiv2 a) y) + MapCard A m1 =
       S (MapCard A m0) + MapCard A m1).
-    intro. rewrite (plus_comm (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1))
+    intro. rewrite (plus_comm (MapCard A (MapPut A m0 (Ndiv2 a) y)) (MapCard A m1))
    in H3.
     rewrite (plus_comm (S (MapCard A m0)) (MapCard A m1)) in H3. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H3).
     simpl in |- *. simpl in H1. rewrite <- H1. induction a. trivial.
@@ -284,7 +283,7 @@ Section MapCard.
 
   Lemma MapCard_Put_1_conv :
    forall (m:Map A) (a:ad) (y y':A),
-     MapGet A m a = SOME A y -> MapCard A (MapPut A m a y') = MapCard A m.
+     MapGet A m a = Some y -> MapCard A (MapPut A m a y') = MapCard A m.
   Proof.
     intros.
     elim
@@ -297,7 +296,7 @@ Section MapCard.
 
   Lemma MapCard_Put_2_conv :
    forall (m:Map A) (a:ad) (y:A),
-     MapGet A m a = NONE A -> MapCard A (MapPut A m a y) = S (MapCard A m).
+     MapGet A m a = None -> MapCard A (MapPut A m a y) = S (MapCard A m).
   Proof.
     intros.
     elim
@@ -331,10 +330,10 @@ Section MapCard.
      MapDom A (MapPut_behind A m a y) = MapDom A (MapPut A m a y).
   Proof.
     simple induction m. trivial.
-    intros a y a0 y0. simpl in |- *. elim (ad_sum (ad_xor a a0)). intro H. elim H.
+    intros a y a0 y0. simpl in |- *. elim (Ndiscr (Nxor a a0)). intro H. elim H.
     intros p H0. rewrite H0. reflexivity.
-    intro H. rewrite H. rewrite (ad_xor_eq _ _ H). reflexivity.
-    intros. simpl in |- *. elim (ad_sum a). intro H1. elim H1. intros p H2. rewrite H2. case p.
+    intro H. rewrite H. rewrite (Nxor_eq _ _ H). reflexivity.
+    intros. simpl in |- *. elim (Ndiscr a). intro H1. elim H1. intros p H2. rewrite H2. case p.
     intro p0. simpl in |- *. rewrite H0. reflexivity.
     intro p0. simpl in |- *. rewrite H. reflexivity.
     simpl in |- *. rewrite H0. reflexivity.
@@ -370,27 +369,27 @@ Section MapCard.
      n = MapCard A m -> n' = MapCard A m' -> {n = n'} + {n = S n'}.
   Proof.
     simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. left. rewrite H1. assumption.
-    simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2. rewrite H2 in H.
+    simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H2. rewrite H2 in H.
     rewrite H in H1. simpl in H1. right. rewrite H1. assumption.
     intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. left. rewrite H1. assumption.
-    intros. simpl in H1. simpl in H2. elim (sumbool_of_bool (ad_bit_0 a)). intro H4.
+    intros. simpl in H1. simpl in H2. elim (sumbool_of_bool (Nbit0 a)). intro H4.
     rewrite H4 in H1. rewrite H1 in H3.
-    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H3.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 a))) in H3.
     elim
-     (H0 (MapRemove A m1 (ad_div_2 a)) (ad_div_2 a) (
-        MapCard A m1) (MapCard A (MapRemove A m1 (ad_div_2 a)))
+     (H0 (MapRemove A m1 (Ndiv2 a)) (Ndiv2 a) (
+        MapCard A m1) (MapCard A (MapRemove A m1 (Ndiv2 a)))
         (refl_equal _) (refl_equal _) (refl_equal _)).
     intro H5. rewrite H5 in H2. left. rewrite H3. exact H2.
     intro H5. rewrite H5 in H2.
     rewrite <-
-     (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (ad_div_2 a))))
+     (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (Ndiv2 a))))
       in H2.
     right. rewrite H3. exact H2.
     intro H4. rewrite H4 in H1. rewrite H1 in H3.
-    rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H3.
+    rewrite (MapCard_makeM2 (MapRemove A m0 (Ndiv2 a)) m1) in H3.
     elim
-     (H (MapRemove A m0 (ad_div_2 a)) (ad_div_2 a) (
-        MapCard A m0) (MapCard A (MapRemove A m0 (ad_div_2 a)))
+     (H (MapRemove A m0 (Ndiv2 a)) (Ndiv2 a) (
+        MapCard A m0) (MapCard A (MapRemove A m0 (Ndiv2 a)))
         (refl_equal _) (refl_equal _) (refl_equal _)).
     intro H5. rewrite H5 in H2. left. rewrite H3. exact H2.
     intro H5. rewrite H5 in H2. right. rewrite H3. exact H2.
@@ -422,20 +421,20 @@ Section MapCard.
 
   Lemma MapCard_Remove_1 :
    forall (m:Map A) (a:ad),
-     MapCard A (MapRemove A m a) = MapCard A m -> MapGet A m a = NONE A.
+     MapCard A (MapRemove A m a) = MapCard A m -> MapGet A m a = None.
   Proof.
     simple induction m. trivial.
-    simpl in |- *. intros a y a0 H. elim (sumbool_of_bool (ad_eq a a0)). intro H0.
+    simpl in |- *. intros a y a0 H. elim (sumbool_of_bool (Neqb a a0)). intro H0.
     rewrite H0 in H. discriminate H.
     intro H0. rewrite H0. reflexivity.
-    intros. simpl in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2 in H1.
-    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H1.
+    intros. simpl in H1. elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2 in H1.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 a))) in H1.
     rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
     intro H2. rewrite H2 in H1.
-    rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H1.
+    rewrite (MapCard_makeM2 (MapRemove A m0 (Ndiv2 a)) m1) in H1.
     rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H.
     rewrite
-     (plus_comm (MapCard A (MapRemove A m0 (ad_div_2 a))) (MapCard A m1))
+     (plus_comm (MapCard A (MapRemove A m0 (Ndiv2 a))) (MapCard A m1))
       in H1.
     rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
   Qed.
@@ -443,36 +442,36 @@ Section MapCard.
   Lemma MapCard_Remove_2 :
    forall (m:Map A) (a:ad),
      S (MapCard A (MapRemove A m a)) = MapCard A m ->
-     {y : A | MapGet A m a = SOME A y}.
+     {y : A | MapGet A m a = Some y}.
   Proof.
     simple induction m. intros. discriminate H.
-    intros a y a0 H. simpl in H. elim (sumbool_of_bool (ad_eq a a0)). intro H0.
-    rewrite (ad_eq_complete _ _ H0). split with y. exact (M1_semantics_1 A a0 y).
+    intros a y a0 H. simpl in H. elim (sumbool_of_bool (Neqb a a0)). intro H0.
+    rewrite (Neqb_complete _ _ H0). split with y. exact (M1_semantics_1 A a0 y).
     intro H0. rewrite H0 in H. discriminate H.
-    intros. simpl in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2 in H1.
-    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H1.
+    intros. simpl in H1. elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2 in H1.
+    rewrite (MapCard_makeM2 m0 (MapRemove A m1 (Ndiv2 a))) in H1.
     rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0.
     change
-      (S (MapCard A m0) + MapCard A (MapRemove A m1 (ad_div_2 a)) =
+      (S (MapCard A m0) + MapCard A (MapRemove A m1 (Ndiv2 a)) =
        MapCard A m0 + MapCard A m1) in H1.
     rewrite
-     (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (ad_div_2 a))))
+     (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (Ndiv2 a))))
       in H1.
     exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
     intro H2. rewrite H2 in H1. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H.
-    rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H1.
+    rewrite (MapCard_makeM2 (MapRemove A m0 (Ndiv2 a)) m1) in H1.
     change
-      (S (MapCard A (MapRemove A m0 (ad_div_2 a))) + MapCard A m1 =
+      (S (MapCard A (MapRemove A m0 (Ndiv2 a))) + MapCard A m1 =
        MapCard A m0 + MapCard A m1) in H1.
     rewrite
-     (plus_comm (S (MapCard A (MapRemove A m0 (ad_div_2 a)))) (MapCard A m1))
+     (plus_comm (S (MapCard A (MapRemove A m0 (Ndiv2 a)))) (MapCard A m1))
       in H1.
     rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1).
   Qed.
 
   Lemma MapCard_Remove_1_conv :
    forall (m:Map A) (a:ad),
-     MapGet A m a = NONE A -> MapCard A (MapRemove A m a) = MapCard A m.
+     MapGet A m a = None -> MapCard A (MapRemove A m a) = MapCard A m.
   Proof.
     intros.
     elim
@@ -486,7 +485,7 @@ Section MapCard.
 
   Lemma MapCard_Remove_2_conv :
    forall (m:Map A) (a:ad) (y:A),
-     MapGet A m a = SOME A y -> S (MapCard A (MapRemove A m a)) = MapCard A m.
+     MapGet A m a = Some y -> S (MapCard A (MapRemove A m a)) = MapCard A m.
   Proof.
     intros.
     elim
@@ -577,20 +576,20 @@ Section MapCard.
   Proof.
     simple induction m. intros. apply Map_M0_disjoint.
     simpl in |- *. intros. rewrite (MapCard_Put_behind_Put m' a a0) in H. unfold MapDisjoint, in_dom in |- *.
-    simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2.
-    rewrite (ad_eq_complete _ _ H2) in H. rewrite (MapCard_Put_2 m' a1 a0 H) in H1.
+    simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H2.
+    rewrite (Neqb_complete _ _ H2) in H. rewrite (MapCard_Put_2 m' a1 a0 H) in H1.
     discriminate H1.
     intro H2. rewrite H2 in H0. discriminate H0.
     simple induction m'. intros. apply Map_disjoint_M0.
     intros a y H1. rewrite <- (MapCard_ext _ _ (MapPut_as_Merge A (M2 A m0 m1) a y)) in H1.
     unfold MapCard at 3 in H1. rewrite <- (plus_Snm_nSm (MapCard A (M2 A m0 m1)) 0) in H1.
     rewrite <- (plus_n_O (S (MapCard A (M2 A m0 m1)))) in H1. unfold MapDisjoint, in_dom in |- *.
-    unfold MapGet at 2 in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H4.
-    rewrite <- (ad_eq_complete _ _ H4) in H2. rewrite (MapCard_Put_2 _ _ _ H1) in H2.
+    unfold MapGet at 2 in |- *. intros. elim (sumbool_of_bool (Neqb a a0)). intro H4.
+    rewrite <- (Neqb_complete _ _ H4) in H2. rewrite (MapCard_Put_2 _ _ _ H1) in H2.
     discriminate H2.
     intro H4. rewrite H4 in H3. discriminate H3.
-    intros. unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H6.
-    unfold MapDisjoint in H0. apply H0 with (m' := m3) (a := ad_div_2 a). apply le_antisym.
+    intros. unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H6.
+    unfold MapDisjoint in H0. apply H0 with (m' := m3) (a := Ndiv2 a). apply le_antisym.
     apply MapMerge_Card_ub.
     apply (fun p n m:nat => plus_le_reg_l n m p) with
      (p := MapCard A m0 + MapCard A m2).
@@ -606,7 +605,7 @@ Section MapCard.
     unfold in_dom in |- *. rewrite H7. reflexivity.
     elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m2 m3) in H7.
     unfold in_dom in |- *. rewrite H7. reflexivity.
-    intro H6. unfold MapDisjoint in H. apply H with (m' := m2) (a := ad_div_2 a). apply le_antisym.
+    intro H6. unfold MapDisjoint in H. apply H with (m' := m2) (a := Ndiv2 a). apply le_antisym.
     apply MapMerge_Card_ub.
     apply (fun p n m:nat => plus_le_reg_l n m p) with
      (p := MapCard A m1 + MapCard A m3).
@@ -637,15 +636,15 @@ Section MapCard.
     simple induction m. intros. discriminate H.
     intros a y n H. split with a. unfold in_dom in |- *. rewrite (M1_semantics_1 _ a y). reflexivity.
     intros. simpl in H1. elim (O_or_S (MapCard _ m0)). intro H2. elim H2. intros m2 H3.
-    elim (H _ (sym_eq H3)). intros a H4. split with (ad_double a). unfold in_dom in |- *.
-    rewrite (MapGet_M2_bit_0_0 A (ad_double a) (ad_double_bit_0 a) m0 m1).
-    rewrite (ad_double_div_2 a). elim (in_dom_some _ _ _ H4). intros y H5. rewrite H5. reflexivity.
+    elim (H _ (sym_eq H3)). intros a H4. split with (Ndouble a). unfold in_dom in |- *.
+    rewrite (MapGet_M2_bit_0_0 A (Ndouble a) (Ndouble_bit0 a) m0 m1).
+    rewrite (Ndouble_div2 a). elim (in_dom_some _ _ _ H4). intros y H5. rewrite H5. reflexivity.
     intro H2. rewrite <- H2 in H1. simpl in H1. elim (H0 _ H1). intros a H3.
-    split with (ad_double_plus_un a). unfold in_dom in |- *.
+    split with (Ndouble_plus_one a). unfold in_dom in |- *.
     rewrite
-     (MapGet_M2_bit_0_1 A (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+     (MapGet_M2_bit_0_1 A (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a)
         m0 m1).
-    rewrite (ad_double_plus_un_div_2 a). elim (in_dom_some _ _ _ H3). intros y H4. rewrite H4.
+    rewrite (Ndouble_plus_one_div2 a). elim (in_dom_some _ _ _ H3). intros y H4. rewrite H4.
     reflexivity.
   Qed.
 
@@ -675,11 +674,11 @@ Section MapCard2.
     rewrite <- (MapCard_Remove_2_conv _ m a y H4) in H1. inversion_clear H1. reflexivity.
     rewrite <- (MapCard_Remove_2_conv _ m' a y' H6) in H2. inversion_clear H2. reflexivity.
     unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove B m' a) a y' a0).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H7. rewrite H7. rewrite <- (ad_eq_complete _ _ H7).
+    elim (sumbool_of_bool (Neqb a a0)). intro H7. rewrite H7. rewrite <- (Neqb_complete _ _ H7).
     apply sym_eq. assumption.
     intro H7. rewrite H7. rewrite (MapRemove_semantics _ m' a a0). rewrite H7. reflexivity.
     unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove A m a) a y a0).
-    elim (sumbool_of_bool (ad_eq a a0)). intro H7. rewrite H7. rewrite <- (ad_eq_complete _ _ H7).
+    elim (sumbool_of_bool (Neqb a a0)). intro H7. rewrite H7. rewrite <- (Neqb_complete _ _ H7).
     apply sym_eq. assumption.
     intro H7. rewrite H7. rewrite (MapRemove_semantics A m a a0). rewrite H7. reflexivity.
   Qed.
@@ -695,8 +694,9 @@ Section MapCard2.
     intro H. rewrite H. simpl in |- *. apply le_O_n.
     simple induction m'. simpl in |- *. apply le_O_n.
 
-    intros a y. unfold MapDomRestrTo in |- *. case (MapGet A (M2 A m0 m1) a). simpl in |- *. apply le_O_n.
+    intros a y. unfold MapDomRestrTo in |- *. case (MapGet A (M2 A m0 m1) a). simpl in |- *. 
     intro. simpl in |- *. apply le_n.
+    apply le_O_n.
     intros. simpl in |- *. rewrite
   (MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3))
   .
diff --git a/theories/IntMap/Mapfold.v b/theories/IntMap/Mapfold.v
index 641529ee..eb58cb64 100644
--- a/theories/IntMap/Mapfold.v
+++ b/theories/IntMap/Mapfold.v
@@ -5,14 +5,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i   	  $Id: Mapfold.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $      i*)
+(*i   	  $Id: Mapfold.v 8733 2006-04-25 22:52:18Z letouzey $      i*)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Fset.
 Require Import Mapaxioms.
@@ -50,22 +49,22 @@ Section MapFoldResults.
 
   Lemma MapFold_ext_f_1 :
    forall (m:Map A) (f g:ad -> A -> M) (pf:ad -> ad),
-     (forall (a:ad) (y:A), MapGet _ m a = SOME _ y -> f (pf a) y = g (pf a) y) ->
+     (forall (a:ad) (y:A), MapGet _ m a = Some y -> f (pf a) y = g (pf a) y) ->
      MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op g pf m.
   Proof.
     simple induction m. trivial.
-    simpl in |- *. intros. apply H. rewrite (ad_eq_correct a). reflexivity.
-    intros. simpl in |- *. rewrite (H f g (fun a0:ad => pf (ad_double a0))).
-    rewrite (H0 f g (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity.
-    intros. apply H1. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2. assumption.
-    apply ad_double_plus_un_bit_0.
-    intros. apply H1. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption.
-    apply ad_double_bit_0.
+    simpl in |- *. intros. apply H. rewrite (Neqb_correct a). reflexivity.
+    intros. simpl in |- *. rewrite (H f g (fun a0:ad => pf (Ndouble a0))).
+    rewrite (H0 f g (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity.
+    intros. apply H1. rewrite MapGet_M2_bit_0_1. rewrite Ndouble_plus_one_div2. assumption.
+    apply Ndouble_plus_one_bit0.
+    intros. apply H1. rewrite MapGet_M2_bit_0_0. rewrite Ndouble_div2. assumption.
+    apply Ndouble_bit0.
   Qed.
 
   Lemma MapFold_ext_f :
    forall (f g:ad -> A -> M) (m:Map A),
-     (forall (a:ad) (y:A), MapGet _ m a = SOME _ y -> f a y = g a y) ->
+     (forall (a:ad) (y:A), MapGet _ m a = Some y -> f a y = g a y) ->
      MapFold _ _ neutral op f m = MapFold _ _ neutral op g m.
   Proof.
     intros. exact (MapFold_ext_f_1 m f g (fun a0:ad => a0) H).
@@ -80,11 +79,11 @@ Section MapFoldResults.
     intros. simpl in |- *. apply H.
     intros. simpl in |- *.
     rewrite
-     (H f f' (fun a0:ad => pf (ad_double a0))
-        (fun a0:ad => pf' (ad_double a0))).
+     (H f f' (fun a0:ad => pf (Ndouble a0))
+        (fun a0:ad => pf' (Ndouble a0))).
     rewrite
-     (H0 f f' (fun a0:ad => pf (ad_double_plus_un a0))
-        (fun a0:ad => pf' (ad_double_plus_un a0))).
+     (H0 f f' (fun a0:ad => pf (Ndouble_plus_one a0))
+        (fun a0:ad => pf' (Ndouble_plus_one a0))).
     reflexivity.
     intros. apply H1.
     intros. apply H1.
@@ -112,81 +111,83 @@ Section MapFoldResults.
   Lemma MapFold_Put_disjoint_1 :
    forall (p:positive) (f:ad -> A -> M) (pf:ad -> ad) 
      (a1 a2:ad) (y1 y2:A),
-     ad_xor a1 a2 = ad_x p ->
+     Nxor a1 a2 = Npos p ->
      MapFold1 A M neutral op f pf (MapPut1 A a1 y1 a2 y2 p) =
      op (f (pf a1) y1) (f (pf a2) y2).
   Proof.
-    simple induction p. intros. simpl in |- *. elim (sumbool_of_bool (ad_bit_0 a1)). intro H1. rewrite H1.
-    simpl in |- *. rewrite ad_div_2_double_plus_un. rewrite ad_div_2_double. apply comm.
-    change (ad_bit_0 a2 = negb true) in |- *. rewrite <- H1. rewrite (ad_neg_bit_0_2 _ _ _ H0).
+    simple induction p. intros. simpl in |- *. elim (sumbool_of_bool (Nbit0 a1)). intro H1. rewrite H1.
+    simpl in |- *. rewrite Ndiv2_double_plus_one. rewrite Ndiv2_double. apply comm.
+    change (Nbit0 a2 = negb true) in |- *. rewrite <- H1. rewrite (Nneg_bit0_2 _ _ _ H0).
     rewrite negb_elim. reflexivity.
     assumption.
-    intro H1. rewrite H1. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un.
+    intro H1. rewrite H1. simpl in |- *. rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one.
     reflexivity.
-    change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H1. rewrite (ad_neg_bit_0_2 _ _ _ H0).
+    change (Nbit0 a2 = negb false) in |- *. rewrite <- H1. rewrite (Nneg_bit0_2 _ _ _ H0).
     rewrite negb_elim. reflexivity.
     assumption.
-    simpl in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a1)). intro H1. rewrite H1. simpl in |- *.
+    simpl in |- *. intros. elim (sumbool_of_bool (Nbit0 a1)). intro H1. rewrite H1. simpl in |- *.
     rewrite nleft.
     rewrite
-     (H f (fun a0:ad => pf (ad_double_plus_un a0)) (
-        ad_div_2 a1) (ad_div_2 a2) y1 y2).
-    rewrite ad_div_2_double_plus_un. rewrite ad_div_2_double_plus_un. reflexivity.
-    rewrite <- (ad_same_bit_0 _ _ _ H0). assumption.
+     (H f (fun a0:ad => pf (Ndouble_plus_one a0)) (
+        Ndiv2 a1) (Ndiv2 a2) y1 y2).
+    rewrite Ndiv2_double_plus_one. rewrite Ndiv2_double_plus_one. reflexivity.
+    unfold Nodd.
+    rewrite <- (Nsame_bit0 _ _ _ H0). assumption.
     assumption.
-    rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
+    rewrite <- Nxor_div2. rewrite H0. reflexivity.
     intro H1. rewrite H1. simpl in |- *. rewrite nright.
     rewrite
-     (H f (fun a0:ad => pf (ad_double a0)) (ad_div_2 a1) (ad_div_2 a2) y1 y2)
+     (H f (fun a0:ad => pf (Ndouble a0)) (Ndiv2 a1) (Ndiv2 a2) y1 y2)
      .
-    rewrite ad_div_2_double. rewrite ad_div_2_double. reflexivity.
-    rewrite <- (ad_same_bit_0 _ _ _ H0). assumption.
+    rewrite Ndiv2_double. rewrite Ndiv2_double. reflexivity.
+    unfold Neven.
+    rewrite <- (Nsame_bit0 _ _ _ H0). assumption.
     assumption.
-    rewrite <- ad_xor_div_2. rewrite H0. reflexivity.
-    intros. simpl in |- *. elim (sumbool_of_bool (ad_bit_0 a1)). intro H0. rewrite H0. simpl in |- *.
-    rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un. apply comm.
+    rewrite <- Nxor_div2. rewrite H0. reflexivity.
+    intros. simpl in |- *. elim (sumbool_of_bool (Nbit0 a1)). intro H0. rewrite H0. simpl in |- *.
+    rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one. apply comm.
     assumption.
-    change (ad_bit_0 a2 = negb true) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H).
+    change (Nbit0 a2 = negb true) in |- *. rewrite <- H0. rewrite (Nneg_bit0_1 _ _ H).
     rewrite negb_elim. reflexivity.
-    intro H0. rewrite H0. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un.
+    intro H0. rewrite H0. simpl in |- *. rewrite Ndiv2_double. rewrite Ndiv2_double_plus_one.
     reflexivity.
-    change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H).
+    change (Nbit0 a2 = negb false) in |- *. rewrite <- H0. rewrite (Nneg_bit0_1 _ _ H).
     rewrite negb_elim. reflexivity.
     assumption.
   Qed.
 
   Lemma MapFold_Put_disjoint_2 :
    forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A) (pf:ad -> ad),
-     MapGet A m a = NONE A ->
+     MapGet A m a = None ->
      MapFold1 A M neutral op f pf (MapPut A m a y) =
      op (f (pf a) y) (MapFold1 A M neutral op f pf m).
   Proof.
     simple induction m. intros. simpl in |- *. rewrite (nright (f (pf a) y)). reflexivity.
-    intros a1 y1 a2 y2 pf H. simpl in |- *. elim (ad_sum (ad_xor a1 a2)). intro H0. elim H0.
+    intros a1 y1 a2 y2 pf H. simpl in |- *. elim (Ndiscr (Nxor a1 a2)). intro H0. elim H0.
     intros p H1. rewrite H1. rewrite comm. exact (MapFold_Put_disjoint_1 p f pf a1 a2 y1 y2 H1).
-    intro H0. rewrite (ad_eq_complete _ _ (ad_xor_eq_true _ _ H0)) in H.
+    intro H0. rewrite (Neqb_complete _ _ (Nxor_eq_true _ _ H0)) in H.
     rewrite (M1_semantics_1 A a2 y1) in H. discriminate H.
-    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2.
-    cut (MapPut A (M2 A m0 m1) a y = M2 A m0 (MapPut A m1 (ad_div_2 a) y)). intro.
-    rewrite H3. simpl in |- *. rewrite (H0 (ad_div_2 a) y (fun a0:ad => pf (ad_double_plus_un a0))).
-    rewrite ad_div_2_double_plus_un. rewrite <- assoc.
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H2.
+    cut (MapPut A (M2 A m0 m1) a y = M2 A m0 (MapPut A m1 (Ndiv2 a) y)). intro.
+    rewrite H3. simpl in |- *. rewrite (H0 (Ndiv2 a) y (fun a0:ad => pf (Ndouble_plus_one a0))).
+    rewrite Ndiv2_double_plus_one. rewrite <- assoc.
     rewrite
-     (comm (MapFold1 A M neutral op f (fun a0:ad => pf (ad_double a0)) m0)
+     (comm (MapFold1 A M neutral op f (fun a0:ad => pf (Ndouble a0)) m0)
         (f (pf a) y)).
     rewrite assoc. reflexivity.
     assumption.
     rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. assumption.
-    simpl in |- *. elim (ad_sum a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5.
+    simpl in |- *. elim (Ndiscr a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5.
     reflexivity.
     intros p0 H4 H5. rewrite H5 in H2. discriminate H2.
     intro H4. rewrite H4. reflexivity.
     intro H3. rewrite H3 in H2. discriminate H2.
-    intro H2. cut (MapPut A (M2 A m0 m1) a y = M2 A (MapPut A m0 (ad_div_2 a) y) m1).
-    intro. rewrite H3. simpl in |- *. rewrite (H (ad_div_2 a) y (fun a0:ad => pf (ad_double a0))).
-    rewrite ad_div_2_double. rewrite <- assoc. reflexivity.
+    intro H2. cut (MapPut A (M2 A m0 m1) a y = M2 A (MapPut A m0 (Ndiv2 a) y) m1).
+    intro. rewrite H3. simpl in |- *. rewrite (H (Ndiv2 a) y (fun a0:ad => pf (Ndouble a0))).
+    rewrite Ndiv2_double. rewrite <- assoc. reflexivity.
     assumption.
     rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. assumption.
-    simpl in |- *. elim (ad_sum a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5 in H2.
+    simpl in |- *. elim (Ndiscr a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5 in H2.
     discriminate H2.
     intros p0 H4 H5. rewrite H5. reflexivity.
     intro H4. rewrite H4 in H2. discriminate H2.
@@ -195,7 +196,7 @@ Section MapFoldResults.
 
   Lemma MapFold_Put_disjoint :
    forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A),
-     MapGet A m a = NONE A ->
+     MapGet A m a = None ->
      MapFold A M neutral op f (MapPut A m a y) =
      op (f a y) (MapFold A M neutral op f m).
   Proof.
@@ -204,7 +205,7 @@ Section MapFoldResults.
 
   Lemma MapFold_Put_behind_disjoint_2 :
    forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A) (pf:ad -> ad),
-     MapGet A m a = NONE A ->
+     MapGet A m a = None ->
      MapFold1 A M neutral op f pf (MapPut_behind A m a y) =
      op (f (pf a) y) (MapFold1 A M neutral op f pf m).
   Proof.
@@ -213,12 +214,12 @@ Section MapFoldResults.
     apply eqmap_trans with (m' := MapMerge A (M1 A a y) m). apply MapPut_behind_as_Merge.
     apply eqmap_trans with (m' := MapMerge A m (M1 A a y)).
     apply eqmap_trans with (m' := MapDelta A (M1 A a y) m). apply eqmap_sym. apply MapDelta_disjoint.
-    unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)).
-    intro H2. rewrite (ad_eq_complete _ _ H2) in H. rewrite H in H1. discriminate H1.
+    unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a0)).
+    intro H2. rewrite (Neqb_complete _ _ H2) in H. rewrite H in H1. discriminate H1.
     intro H2. rewrite H2 in H0. discriminate H0.
     apply eqmap_trans with (m' := MapDelta A m (M1 A a y)). apply MapDelta_sym.
     apply MapDelta_disjoint. unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros.
-    elim (sumbool_of_bool (ad_eq a a0)). intro H2. rewrite (ad_eq_complete _ _ H2) in H.
+    elim (sumbool_of_bool (Neqb a a0)). intro H2. rewrite (Neqb_complete _ _ H2) in H.
     rewrite H in H0. discriminate H0.
     intro H2. rewrite H2 in H1. discriminate H1.
     apply eqmap_sym. apply MapPut_as_Merge.
@@ -226,7 +227,7 @@ Section MapFoldResults.
 
   Lemma MapFold_Put_behind_disjoint :
    forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A),
-     MapGet A m a = NONE A ->
+     MapGet A m a = None ->
      MapFold A M neutral op f (MapPut_behind A m a y) =
      op (f a y) (MapFold A M neutral op f m).
   Proof.
@@ -245,8 +246,8 @@ Section MapFoldResults.
     simple induction m2. intros. simpl in |- *. rewrite nright. reflexivity.
     intros. unfold MapMerge in |- *. rewrite (MapFold_Put_disjoint_2 f (M2 A m m0) a a0 pf). apply comm.
     apply in_dom_none. exact (MapDisjoint_M1_r _ _ (M2 A m m0) a a0 H1).
-    intros. simpl in |- *. rewrite (H m3 (fun a0:ad => pf (ad_double a0))).
-    rewrite (H0 m4 (fun a0:ad => pf (ad_double_plus_un a0))).
+    intros. simpl in |- *. rewrite (H m3 (fun a0:ad => pf (Ndouble a0))).
+    rewrite (H0 m4 (fun a0:ad => pf (Ndouble_plus_one a0))).
     cut (forall a b c d:M, op (op a b) (op c d) = op (op a c) (op b d)). intro. apply H4.
     intros. rewrite assoc. rewrite <- (assoc b c d). rewrite (comm b c). rewrite (assoc c b d).
     rewrite assoc. reflexivity.
@@ -346,22 +347,22 @@ Section MapFoldExists.
    forall (f:ad -> A -> bool) (m:Map A) (pf:ad -> ad),
      MapFold1 A bool false orb f pf m =
      match MapSweep1 A f pf m with
-     | SOME _ => true
+     | Some _ => true
      | _ => false
      end.
   Proof.
     simple induction m. trivial.
     intros a y pf. simpl in |- *. unfold MapSweep2 in |- *. case (f (pf a) y); reflexivity.
-    intros. simpl in |- *. rewrite (H (fun a0:ad => pf (ad_double a0))).
-    rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))).
-    case (MapSweep1 A f (fun a0:ad => pf (ad_double a0)) m0); reflexivity.
+    intros. simpl in |- *. rewrite (H (fun a0:ad => pf (Ndouble a0))).
+    rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))).
+    case (MapSweep1 A f (fun a0:ad => pf (Ndouble a0)) m0); reflexivity.
   Qed.
 
   Lemma MapFold_orb :
    forall (f:ad -> A -> bool) (m:Map A),
      MapFold A bool false orb f m =
      match MapSweep A f m with
-     | SOME _ => true
+     | Some _ => true
      | _ => false
      end.
   Proof.
@@ -381,7 +382,7 @@ Section DMergeDef.
    forall (m:Map (Map A)) (a:ad),
      in_dom A a (DMerge m) =
      match MapSweep _ (fun (_:ad) (m0:Map A) => in_dom A a m0) m with
-     | SOME _ => true
+     | Some _ => true
      | _ => false
      end.
   Proof.
@@ -397,7 +398,7 @@ Section DMergeDef.
    forall (m:Map (Map A)) (a:ad),
      in_dom A a (DMerge m) = true ->
      {b : ad & 
-     {m0 : Map A | MapGet _ m b = SOME _ m0 /\ in_dom A a m0 = true}}.
+     {m0 : Map A | MapGet _ m b = Some m0 /\ in_dom A a m0 = true}}.
   Proof.
     intros m a. rewrite in_dom_DMerge_1.
     elim
@@ -411,7 +412,7 @@ Section DMergeDef.
 
   Lemma in_dom_DMerge_3 :
    forall (m:Map (Map A)) (a b:ad) (m0:Map A),
-     MapGet _ m a = SOME _ m0 ->
+     MapGet _ m a = Some m0 ->
      in_dom A b m0 = true -> in_dom A b (DMerge m) = true.
   Proof.
     intros m a b m0 H H0. rewrite in_dom_DMerge_1.
diff --git a/theories/IntMap/Mapiter.v b/theories/IntMap/Mapiter.v
index f5d443cc..a8ba7e39 100644
--- a/theories/IntMap/Mapiter.v
+++ b/theories/IntMap/Mapiter.v
@@ -5,14 +5,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapiter.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Mapiter.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Mapaxioms.
 Require Import Fset.
@@ -27,17 +26,17 @@ Section MapIter.
   Variable f : ad -> A -> bool.
 
   Definition MapSweep2 (a0:ad) (y:A) :=
-    if f a0 y then SOME _ (a0, y) else NONE _.
+    if f a0 y then Some (a0, y) else None.
 
   Fixpoint MapSweep1 (pf:ad -> ad) (m:Map A) {struct m} : 
    option (ad * A) :=
     match m with
-    | M0 => NONE _
+    | M0 => None
     | M1 a y => MapSweep2 (pf a) y
     | M2 m m' =>
-        match MapSweep1 (fun a:ad => pf (ad_double a)) m with
-        | SOME r => SOME _ r
-        | NONE => MapSweep1 (fun a:ad => pf (ad_double_plus_un a)) m'
+        match MapSweep1 (fun a:ad => pf (Ndouble a)) m with
+        | Some r => Some r
+        | None => MapSweep1 (fun a:ad => pf (Ndouble_plus_one a)) m'
         end
     end.
 
@@ -45,27 +44,27 @@ Section MapIter.
 
   Lemma MapSweep_semantics_1_1 :
    forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
-     MapSweep1 pf m = SOME _ (a, y) -> f a y = true.
+     MapSweep1 pf m = Some (a, y) -> f a y = true.
   Proof.
     simple induction m. intros. discriminate H.
     simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (f (pf a) y)). intro H. unfold MapSweep2 in |- *.
     rewrite H. intro H0. inversion H0. rewrite <- H3. assumption.
     intro H. unfold MapSweep2 in |- *. rewrite H. intro H0. discriminate H0.
-    simpl in |- *. intros. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)).
+    simpl in |- *. intros. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)).
     intro H2. elim H2. intros r H3. rewrite H3 in H1. inversion H1. rewrite H5 in H3.
-    exact (H (fun a0:ad => pf (ad_double a0)) a y H3).
-    intro H2. rewrite H2 in H1. exact (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H1).
+    exact (H (fun a0:ad => pf (Ndouble a0)) a y H3).
+    intro H2. rewrite H2 in H1. exact (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) a y H1).
   Qed.
 
   Lemma MapSweep_semantics_1 :
-   forall (m:Map A) (a:ad) (y:A), MapSweep m = SOME _ (a, y) -> f a y = true.
+   forall (m:Map A) (a:ad) (y:A), MapSweep m = Some (a, y) -> f a y = true.
   Proof.
     intros. exact (MapSweep_semantics_1_1 m (fun a:ad => a) a y H).
   Qed.
 
   Lemma MapSweep_semantics_2_1 :
    forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
-     MapSweep1 pf m = SOME _ (a, y) -> {a' : ad | a = pf a'}.
+     MapSweep1 pf m = Some (a, y) -> {a' : ad | a = pf a'}.
   Proof.
     simple induction m. intros. discriminate H.
     simpl in |- *. unfold MapSweep2 in |- *. intros a y pf a0 y0. case (f (pf a) y). intros. split with a.
@@ -73,63 +72,63 @@ Section MapIter.
     intro. discriminate H.
     intros m0 H m1 H0 pf a y. simpl in |- *.
     elim
-     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H1. elim H1.
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)). intro H1. elim H1.
     intros r H2. rewrite H2. intro H3. inversion H3. rewrite H5 in H2.
-    elim (H (fun a0:ad => pf (ad_double a0)) a y H2). intros a0 H6. split with (ad_double a0).
+    elim (H (fun a0:ad => pf (Ndouble a0)) a y H2). intros a0 H6. split with (Ndouble a0).
     assumption.
-    intro H1. rewrite H1. intro H2. elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H2).
-    intros a0 H3. split with (ad_double_plus_un a0). assumption.
+    intro H1. rewrite H1. intro H2. elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) a y H2).
+    intros a0 H3. split with (Ndouble_plus_one a0). assumption.
   Qed.
 
   Lemma MapSweep_semantics_2_2 :
    forall (m:Map A) (pf fp:ad -> ad),
      (forall a0:ad, fp (pf a0) = a0) ->
      forall (a:ad) (y:A),
-       MapSweep1 pf m = SOME _ (a, y) -> MapGet A m (fp a) = SOME _ y.
+       MapSweep1 pf m = Some (a, y) -> MapGet A m (fp a) = Some y.
   Proof.
     simple induction m. intros. discriminate H0.
     simpl in |- *. intros a y pf fp H a0 y0. unfold MapSweep2 in |- *. elim (sumbool_of_bool (f (pf a) y)).
-    intro H0. rewrite H0. intro H1. inversion H1. rewrite (H a). rewrite (ad_eq_correct a).
+    intro H0. rewrite H0. intro H1. inversion H1. rewrite (H a). rewrite (Neqb_correct a).
     reflexivity.
     intro H0. rewrite H0. intro H1. discriminate H1.
-    intros. rewrite (MapGet_M2_bit_0_if A m0 m1 (fp a)). elim (sumbool_of_bool (ad_bit_0 (fp a))).
-    intro H3. rewrite H3. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)).
+    intros. rewrite (MapGet_M2_bit_0_if A m0 m1 (fp a)). elim (sumbool_of_bool (Nbit0 (fp a))).
+    intro H3. rewrite H3. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)).
     intro H4. simpl in H2. apply
-  (H0 (fun a0:ad => pf (ad_double_plus_un a0))
-     (fun a0:ad => ad_div_2 (fp a0))).
-    intro. rewrite H1. apply ad_double_plus_un_div_2.
+  (H0 (fun a0:ad => pf (Ndouble_plus_one a0))
+     (fun a0:ad => Ndiv2 (fp a0))).
+    intro. rewrite H1. apply Ndouble_plus_one_div2.
     elim
-     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H5. elim H5.
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)). intro H5. elim H5.
     intros r H6. rewrite H6 in H2. inversion H2. rewrite H8 in H6.
-    elim (MapSweep_semantics_2_1 m0 (fun a0:ad => pf (ad_double a0)) a y H6). intros a0 H9.
-    rewrite H9 in H3. rewrite (H1 (ad_double a0)) in H3. rewrite (ad_double_bit_0 a0) in H3.
+    elim (MapSweep_semantics_2_1 m0 (fun a0:ad => pf (Ndouble a0)) a y H6). intros a0 H9.
+    rewrite H9 in H3. rewrite (H1 (Ndouble a0)) in H3. rewrite (Ndouble_bit0 a0) in H3.
     discriminate H3.
     intro H5. rewrite H5 in H2. assumption.
     intro H4. simpl in H2. rewrite H4 in H2.
     apply
-     (H0 (fun a0:ad => pf (ad_double_plus_un a0))
-        (fun a0:ad => ad_div_2 (fp a0))). intro.
-    rewrite H1. apply ad_double_plus_un_div_2.
+     (H0 (fun a0:ad => pf (Ndouble_plus_one a0))
+        (fun a0:ad => Ndiv2 (fp a0))). intro.
+    rewrite H1. apply Ndouble_plus_one_div2.
     assumption.
     intro H3. rewrite H3. simpl in H2.
     elim
-     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H4. elim H4.
+     (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (Ndouble a0)) m0)). intro H4. elim H4.
     intros r H5. rewrite H5 in H2. inversion H2. rewrite H7 in H5.
     apply
-     (H (fun a0:ad => pf (ad_double a0)) (fun a0:ad => ad_div_2 (fp a0))). intro. rewrite H1.
-    apply ad_double_div_2.
+     (H (fun a0:ad => pf (Ndouble a0)) (fun a0:ad => Ndiv2 (fp a0))). intro. rewrite H1.
+    apply Ndouble_div2.
     assumption.
     intro H4. rewrite H4 in H2.
     elim
-     (MapSweep_semantics_2_1 m1 (fun a0:ad => pf (ad_double_plus_un a0)) a y
+     (MapSweep_semantics_2_1 m1 (fun a0:ad => pf (Ndouble_plus_one a0)) a y
         H2).
-    intros a0 H5. rewrite H5 in H3. rewrite (H1 (ad_double_plus_un a0)) in H3.
-    rewrite (ad_double_plus_un_bit_0 a0) in H3. discriminate H3.
+    intros a0 H5. rewrite H5 in H3. rewrite (H1 (Ndouble_plus_one a0)) in H3.
+    rewrite (Ndouble_plus_one_bit0 a0) in H3. discriminate H3.
   Qed.
 
   Lemma MapSweep_semantics_2 :
    forall (m:Map A) (a:ad) (y:A),
-     MapSweep m = SOME _ (a, y) -> MapGet A m a = SOME _ y.
+     MapSweep m = Some (a, y) -> MapGet A m a = Some y.
   Proof.
     intros.
     exact
@@ -139,28 +138,28 @@ Section MapIter.
 
   Lemma MapSweep_semantics_3_1 :
    forall (m:Map A) (pf:ad -> ad),
-     MapSweep1 pf m = NONE _ ->
-     forall (a:ad) (y:A), MapGet A m a = SOME _ y -> f (pf a) y = false.
+     MapSweep1 pf m = None ->
+     forall (a:ad) (y:A), MapGet A m a = Some y -> f (pf a) y = false.
   Proof.
     simple induction m. intros. discriminate H0.
     simpl in |- *. unfold MapSweep2 in |- *. intros a y pf. elim (sumbool_of_bool (f (pf a) y)). intro H.
     rewrite H. intro. discriminate H0.
-    intro H. rewrite H. intros H0 a0 y0. elim (sumbool_of_bool (ad_eq a a0)). intro H1. rewrite H1.
-    intro H2. inversion H2. rewrite <- H4. rewrite <- (ad_eq_complete _ _ H1). assumption.
+    intro H. rewrite H. intros H0 a0 y0. elim (sumbool_of_bool (Neqb a a0)). intro H1. rewrite H1.
+    intro H2. inversion H2. rewrite <- H4. rewrite <- (Neqb_complete _ _ H1). assumption.
     intro H1. rewrite H1. intro. discriminate H2.
-    intros. simpl in H1. elim (option_sum (ad * A) (MapSweep1 (fun a:ad => pf (ad_double a)) m0)).
+    intros. simpl in H1. elim (option_sum (ad * A) (MapSweep1 (fun a:ad => pf (Ndouble a)) m0)).
     intro H3. elim H3. intros r H4. rewrite H4 in H1. discriminate H1.
-    intro H3. rewrite H3 in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H4.
-    rewrite (MapGet_M2_bit_0_1 A a H4 m0 m1) in H2. rewrite <- (ad_div_2_double_plus_un a H4).
-    exact (H0 (fun a:ad => pf (ad_double_plus_un a)) H1 (ad_div_2 a) y H2).
-    intro H4. rewrite (MapGet_M2_bit_0_0 A a H4 m0 m1) in H2. rewrite <- (ad_div_2_double a H4).
-    exact (H (fun a:ad => pf (ad_double a)) H3 (ad_div_2 a) y H2).
+    intro H3. rewrite H3 in H1. elim (sumbool_of_bool (Nbit0 a)). intro H4.
+    rewrite (MapGet_M2_bit_0_1 A a H4 m0 m1) in H2. rewrite <- (Ndiv2_double_plus_one a H4).
+    exact (H0 (fun a:ad => pf (Ndouble_plus_one a)) H1 (Ndiv2 a) y H2).
+    intro H4. rewrite (MapGet_M2_bit_0_0 A a H4 m0 m1) in H2. rewrite <- (Ndiv2_double a H4).
+    exact (H (fun a:ad => pf (Ndouble a)) H3 (Ndiv2 a) y H2).
   Qed.
 
   Lemma MapSweep_semantics_3 :
    forall m:Map A,
-     MapSweep m = NONE _ ->
-     forall (a:ad) (y:A), MapGet A m a = SOME _ y -> f a y = false.
+     MapSweep m = None ->
+     forall (a:ad) (y:A), MapGet A m a = Some y -> f a y = false.
   Proof.
     intros.
     exact (MapSweep_semantics_3_1 m (fun a0:ad => a0) H a y H0).
@@ -168,36 +167,36 @@ Section MapIter.
 
   Lemma MapSweep_semantics_4_1 :
    forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
-     MapGet A m a = SOME A y ->
+     MapGet A m a = Some y ->
      f (pf a) y = true ->
-     {a' : ad &  {y' : A | MapSweep1 pf m = SOME _ (a', y')}}.
+     {a' : ad &  {y' : A | MapSweep1 pf m = Some (a', y')}}.
   Proof.
     simple induction m. intros. discriminate H.
-    intros. elim (sumbool_of_bool (ad_eq a a1)). intro H1. split with (pf a1). split with y.
-    rewrite (ad_eq_complete _ _ H1). unfold MapSweep1, MapSweep2 in |- *.
-    rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 _ a1 a0) in H.
+    intros. elim (sumbool_of_bool (Neqb a a1)). intro H1. split with (pf a1). split with y.
+    rewrite (Neqb_complete _ _ H1). unfold MapSweep1, MapSweep2 in |- *.
+    rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 _ a1 a0) in H.
     inversion H. rewrite H0. reflexivity.
 
     intro H1. rewrite (M1_semantics_2 _ a a1 a0 H1) in H. discriminate H.
 
-    intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H3.
+    intros. elim (sumbool_of_bool (Nbit0 a)). intro H3.
     rewrite (MapGet_M2_bit_0_1 _ _ H3 m0 m1) in H1.
-    rewrite <- (ad_div_2_double_plus_un a H3) in H2.
-    elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) (ad_div_2 a) y H1 H2). intros a'' H4. elim H4.
-    intros y'' H5. simpl in |- *. elim (option_sum _ (MapSweep1 (fun a:ad => pf (ad_double a)) m0)).
+    rewrite <- (Ndiv2_double_plus_one a H3) in H2.
+    elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) y H1 H2). intros a'' H4. elim H4.
+    intros y'' H5. simpl in |- *. elim (option_sum _ (MapSweep1 (fun a:ad => pf (Ndouble a)) m0)).
     intro H6. elim H6. intro r. elim r. intros a''' y''' H7. rewrite H7. split with a'''.
     split with y'''. reflexivity.
     intro H6. rewrite H6. split with a''. split with y''. assumption.
     intro H3. rewrite (MapGet_M2_bit_0_0 _ _ H3 m0 m1) in H1.
-    rewrite <- (ad_div_2_double a H3) in H2.
-    elim (H (fun a0:ad => pf (ad_double a0)) (ad_div_2 a) y H1 H2). intros a'' H4. elim H4.
+    rewrite <- (Ndiv2_double a H3) in H2.
+    elim (H (fun a0:ad => pf (Ndouble a0)) (Ndiv2 a) y H1 H2). intros a'' H4. elim H4.
     intros y'' H5. split with a''. split with y''. simpl in |- *. rewrite H5. reflexivity.
   Qed.
 
   Lemma MapSweep_semantics_4 :
    forall (m:Map A) (a:ad) (y:A),
-     MapGet A m a = SOME A y ->
-     f a y = true -> {a' : ad &  {y' : A | MapSweep m = SOME _ (a', y')}}.
+     MapGet A m a = Some y ->
+     f a y = true -> {a' : ad &  {y' : A | MapSweep m = Some (a', y')}}.
   Proof.
     intros. exact (MapSweep_semantics_4_1 m (fun a0:ad => a0) a y H H0).
   Qed.
@@ -212,8 +211,8 @@ Section MapIter.
     | M0 => M0 B
     | M1 a y => f (pf a) y
     | M2 m1 m2 =>
-        MapMerge B (MapCollect1 f (fun a0:ad => pf (ad_double a0)) m1)
-          (MapCollect1 f (fun a0:ad => pf (ad_double_plus_un a0)) m2)
+        MapMerge B (MapCollect1 f (fun a0:ad => pf (Ndouble a0)) m1)
+          (MapCollect1 f (fun a0:ad => pf (Ndouble_plus_one a0)) m2)
     end.
 
   Definition MapCollect (f:ad -> A -> Map B) (m:Map A) :=
@@ -231,8 +230,8 @@ Section MapIter.
       | M0 => neutral
       | M1 a y => f (pf a) y
       | M2 m1 m2 =>
-          op (MapFold1 f (fun a0:ad => pf (ad_double a0)) m1)
-            (MapFold1 f (fun a0:ad => pf (ad_double_plus_un a0)) m2)
+          op (MapFold1 f (fun a0:ad => pf (Ndouble a0)) m1)
+            (MapFold1 f (fun a0:ad => pf (Ndouble_plus_one a0)) m2)
       end.
 
     Definition MapFold (f:ad -> A -> M) (m:Map A) :=
@@ -258,11 +257,11 @@ Section MapIter.
       | M0 => (state, neutral)
       | M1 a y => f state (pf a) y
       | M2 m1 m2 =>
-          match MapFold1_state state (fun a0:ad => pf (ad_double a0)) m1 with
+          match MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m1 with
           | (state1, x1) =>
               match
                 MapFold1_state state1
-                  (fun a0:ad => pf (ad_double_plus_un a0)) m2
+                  (fun a0:ad => pf (Ndouble_plus_one a0)) m2
               with
               | (state2, x2) => (state2, op x1 x2)
               end
@@ -285,19 +284,19 @@ Section MapIter.
       simple induction m. trivial.
       intros. simpl in |- *. apply H.
       intros. simpl in |- *. rewrite
-  (pair_sp _ _ (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0))
+  (pair_sp _ _ (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0))
   .
-      rewrite (H g (fun a0:ad => pf (ad_double a0)) H1 state).
+      rewrite (H g (fun a0:ad => pf (Ndouble a0)) H1 state).
       rewrite
        (pair_sp _ _
           (MapFold1_state
-             (fst (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0))
-             (fun a0:ad => pf (ad_double_plus_un a0)) m1))
+             (fst (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0))
+             (fun a0:ad => pf (Ndouble_plus_one a0)) m1))
        .
       simpl in |- *.
       rewrite
-       (H0 g (fun a0:ad => pf (ad_double_plus_un a0)) H1
-          (fst (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0)))
+       (H0 g (fun a0:ad => pf (Ndouble_plus_one a0)) H1
+          (fst (MapFold1_state state (fun a0:ad => pf (Ndouble a0)) m0)))
        .
       reflexivity.
     Qed.
@@ -330,21 +329,21 @@ Section MapIter.
 
   Fixpoint alist_semantics (l:alist) : ad -> option A :=
     match l with
-    | nil => fun _:ad => NONE A
+    | nil => fun _:ad => None
     | (a, y) :: l' =>
-        fun a0:ad => if ad_eq a a0 then SOME A y else alist_semantics l' a0
+        fun a0:ad => if Neqb a a0 then Some y else alist_semantics l' a0
     end.
 
   Lemma alist_semantics_app :
    forall (l l':alist) (a:ad),
      alist_semantics (aapp l l') a =
      match alist_semantics l a with
-     | NONE => alist_semantics l' a
-     | SOME y => SOME A y
+     | None => alist_semantics l' a
+     | Some y => Some y
      end.
   Proof.
     unfold aapp in |- *. simple induction l. trivial.
-    intros. elim a. intros a1 y1. simpl in |- *. case (ad_eq a1 a0). reflexivity.
+    intros. elim a. intros a1 y1. simpl in |- *. case (Neqb a1 a0). reflexivity.
     apply H.
   Qed.
 
@@ -352,53 +351,53 @@ Section MapIter.
    forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A),
      alist_semantics
        (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) pf
-          m) a = SOME A y -> {a' : ad | a = pf a'}.
+          m) a = Some y -> {a' : ad | a = pf a'}.
   Proof.
     simple induction m. simpl in |- *. intros. discriminate H.
-    simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (ad_eq (pf a) a0)). intro H. rewrite H.
-    intro H0. split with a. rewrite (ad_eq_complete _ _ H). reflexivity.
+    simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (Neqb (pf a) a0)). intro H. rewrite H.
+    intro H0. split with a. rewrite (Neqb_complete _ _ H). reflexivity.
     intro H. rewrite H. intro H0. discriminate H0.
     intros. change
    (alist_semantics
       (aapp
          (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
-            (fun a0:ad => pf (ad_double a0)) m0)
+            (fun a0:ad => pf (Ndouble a0)) m0)
          (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
-            (fun a0:ad => pf (ad_double_plus_un a0)) m1)) a = 
-    SOME A y) in H1.
+            (fun a0:ad => pf (Ndouble_plus_one a0)) m1)) a = 
+    Some y) in H1.
     rewrite
      (alist_semantics_app
         (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil)
-           (fun a0:ad => pf (ad_double a0)) m0)
+           (fun a0:ad => pf (Ndouble a0)) m0)
         (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil)
-           (fun a0:ad => pf (ad_double_plus_un a0)) m1) a)
+           (fun a0:ad => pf (Ndouble_plus_one a0)) m1) a)
       in H1.
     elim
      (option_sum A
         (alist_semantics
            (MapFold1 alist anil aapp
               (fun (a0:ad) (y0:A) => acons (a0, y0) anil)
-              (fun a0:ad => pf (ad_double a0)) m0) a)).
-    intro H2. elim H2. intros y0 H3. elim (H (fun a0:ad => pf (ad_double a0)) a y0 H3). intros a0 H4.
-    split with (ad_double a0). assumption.
-    intro H2. rewrite H2 in H1. elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H1).
-    intros a0 H3. split with (ad_double_plus_un a0). assumption.
+              (fun a0:ad => pf (Ndouble a0)) m0) a)).
+    intro H2. elim H2. intros y0 H3. elim (H (fun a0:ad => pf (Ndouble a0)) a y0 H3). intros a0 H4.
+    split with (Ndouble a0). assumption.
+    intro H2. rewrite H2 in H1. elim (H0 (fun a0:ad => pf (Ndouble_plus_one a0)) a y H1).
+    intros a0 H3. split with (Ndouble_plus_one a0). assumption.
   Qed.
 
   Definition ad_inj (pf:ad -> ad) :=
     forall a0 a1:ad, pf a0 = pf a1 -> a0 = a1.
 
   Lemma ad_comp_double_inj :
-   forall pf:ad -> ad, ad_inj pf -> ad_inj (fun a0:ad => pf (ad_double a0)).
+   forall pf:ad -> ad, ad_inj pf -> ad_inj (fun a0:ad => pf (Ndouble a0)).
   Proof.
-    unfold ad_inj in |- *. intros. apply ad_double_inj. exact (H _ _ H0).
+    unfold ad_inj in |- *. intros. apply Ndouble_inj. exact (H _ _ H0).
   Qed.
 
   Lemma ad_comp_double_plus_un_inj :
    forall pf:ad -> ad,
-     ad_inj pf -> ad_inj (fun a0:ad => pf (ad_double_plus_un a0)).
+     ad_inj pf -> ad_inj (fun a0:ad => pf (Ndouble_plus_one a0)).
   Proof.
-    unfold ad_inj in |- *. intros. apply ad_double_plus_un_inj. exact (H _ _ H0).
+    unfold ad_inj in |- *. intros. apply Ndouble_plus_one_inj. exact (H _ _ H0).
   Qed.
 
   Lemma alist_of_Map_semantics_1 :
@@ -411,10 +410,10 @@ Section MapIter.
             pf m) (pf a).
   Proof.
     simple induction m. trivial.
-    simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0.
-    rewrite (ad_eq_complete _ _ H0). rewrite (ad_eq_correct (pf a1)). reflexivity.
-    intro H0. rewrite H0. elim (sumbool_of_bool (ad_eq (pf a) (pf a1))). intro H1.
-    rewrite (H a a1 (ad_eq_complete _ _ H1)) in H0. rewrite (ad_eq_correct a1) in H0.
+    simpl in |- *. intros. elim (sumbool_of_bool (Neqb a a1)). intro H0. rewrite H0.
+    rewrite (Neqb_complete _ _ H0). rewrite (Neqb_correct (pf a1)). reflexivity.
+    intro H0. rewrite H0. elim (sumbool_of_bool (Neqb (pf a) (pf a1))). intro H1.
+    rewrite (H a a1 (Neqb_complete _ _ H1)) in H0. rewrite (Neqb_correct a1) in H0.
     discriminate H0.
     intro H1. rewrite H1. reflexivity.
     intros. change
@@ -422,54 +421,53 @@ Section MapIter.
     alist_semantics
       (aapp
          (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
-            (fun a0:ad => pf (ad_double a0)) m0)
+            (fun a0:ad => pf (Ndouble a0)) m0)
          (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
-            (fun a0:ad => pf (ad_double_plus_un a0)) m1)) (
+            (fun a0:ad => pf (Ndouble_plus_one a0)) m1)) (
       pf a)) in |- *.
     rewrite alist_semantics_app. rewrite (MapGet_M2_bit_0_if A m0 m1 a).
-    elim (ad_double_or_double_plus_un a). intro H2. elim H2. intros a0 H3. rewrite H3.
-    rewrite (ad_double_bit_0 a0).
+    elim (Ndouble_or_double_plus_un a). intro H2. elim H2. intros a0 H3. rewrite H3.
+    rewrite (Ndouble_bit0 a0).
     rewrite <-
-     (H (fun a1:ad => pf (ad_double a1)) (ad_comp_double_inj pf H1) a0)
+     (H (fun a1:ad => pf (Ndouble a1)) (ad_comp_double_inj pf H1) a0)
      .
-    rewrite ad_double_div_2. case (MapGet A m0 a0).
+    rewrite Ndouble_div2. case (MapGet A m0 a0); trivial.
     elim
      (option_sum A
         (alist_semantics
            (MapFold1 alist anil aapp
               (fun (a1:ad) (y:A) => acons (a1, y) anil)
-              (fun a1:ad => pf (ad_double_plus_un a1)) m1)
-           (pf (ad_double a0)))).
+              (fun a1:ad => pf (Ndouble_plus_one a1)) m1)
+           (pf (Ndouble a0)))).
     intro H4. elim H4. intros y H5.
     elim
-     (alist_of_Map_semantics_1_1 m1 (fun a1:ad => pf (ad_double_plus_un a1))
-        (pf (ad_double a0)) y H5).
-    intros a1 H6. cut (ad_bit_0 (ad_double a0) = ad_bit_0 (ad_double_plus_un a1)).
-    intro. rewrite (ad_double_bit_0 a0) in H7. rewrite (ad_double_plus_un_bit_0 a1) in H7.
+     (alist_of_Map_semantics_1_1 m1 (fun a1:ad => pf (Ndouble_plus_one a1))
+        (pf (Ndouble a0)) y H5).
+    intros a1 H6. cut (Nbit0 (Ndouble a0) = Nbit0 (Ndouble_plus_one a1)).
+    intro. rewrite (Ndouble_bit0 a0) in H7. rewrite (Ndouble_plus_one_bit0 a1) in H7.
     discriminate H7.
-    rewrite (H1 (ad_double a0) (ad_double_plus_un a1) H6). reflexivity.
+    rewrite (H1 (Ndouble a0) (Ndouble_plus_one a1) H6). reflexivity.
     intro H4. rewrite H4. reflexivity.
-    trivial.
-    intro H2. elim H2. intros a0 H3. rewrite H3. rewrite (ad_double_plus_un_bit_0 a0).
+    intro H2. elim H2. intros a0 H3. rewrite H3. rewrite (Ndouble_plus_one_bit0 a0).
     rewrite <-
-     (H0 (fun a1:ad => pf (ad_double_plus_un a1))
+     (H0 (fun a1:ad => pf (Ndouble_plus_one a1))
         (ad_comp_double_plus_un_inj pf H1) a0).
-    rewrite ad_double_plus_un_div_2.
+    rewrite Ndouble_plus_one_div2.
     elim
      (option_sum A
         (alist_semantics
            (MapFold1 alist anil aapp
               (fun (a1:ad) (y:A) => acons (a1, y) anil)
-              (fun a1:ad => pf (ad_double a1)) m0)
-           (pf (ad_double_plus_un a0)))).
+              (fun a1:ad => pf (Ndouble a1)) m0)
+           (pf (Ndouble_plus_one a0)))).
     intro H4. elim H4. intros y H5.
     elim
-     (alist_of_Map_semantics_1_1 m0 (fun a1:ad => pf (ad_double a1))
-        (pf (ad_double_plus_un a0)) y H5).
-    intros a1 H6. cut (ad_bit_0 (ad_double_plus_un a0) = ad_bit_0 (ad_double a1)).
-    intro H7. rewrite (ad_double_plus_un_bit_0 a0) in H7. rewrite (ad_double_bit_0 a1) in H7.
+     (alist_of_Map_semantics_1_1 m0 (fun a1:ad => pf (Ndouble a1))
+        (pf (Ndouble_plus_one a0)) y H5).
+    intros a1 H6. cut (Nbit0 (Ndouble_plus_one a0) = Nbit0 (Ndouble a1)).
+    intro H7. rewrite (Ndouble_plus_one_bit0 a0) in H7. rewrite (Ndouble_bit0 a1) in H7.
     discriminate H7.
-    rewrite (H1 (ad_double_plus_un a0) (ad_double a1) H6). reflexivity.
+    rewrite (H1 (Ndouble_plus_one a0) (Ndouble a1) H6). reflexivity.
     intro H4. rewrite H4. reflexivity.
   Qed.
 
@@ -491,9 +489,9 @@ Section MapIter.
    forall l:alist, eqm A (alist_semantics l) (MapGet A (Map_of_alist l)).
   Proof.
     unfold eqm in |- *. simple induction l. trivial.
-    intros r l0 H a. elim r. intros a0 y0. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 a)).
-    intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0).
-    rewrite (MapPut_semantics A (Map_of_alist l0) a y0 a). rewrite (ad_eq_correct a).
+    intros r l0 H a. elim r. intros a0 y0. simpl in |- *. elim (sumbool_of_bool (Neqb a0 a)).
+    intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0).
+    rewrite (MapPut_semantics A (Map_of_alist l0) a y0 a). rewrite (Neqb_correct a).
     reflexivity.
     intro H0. rewrite H0. rewrite (MapPut_semantics A (Map_of_alist l0) a0 y0 a).
     rewrite H0. apply H.
@@ -551,7 +549,7 @@ Section MapIter.
     simple induction m. trivial.
     intros. simpl in |- *. rewrite H1. reflexivity.
     intros. simpl in |- *. rewrite (fold_right_aapp M neutral op H H0 f).
-    rewrite (H2 (fun a0:ad => pf (ad_double a0))). rewrite (H3 (fun a0:ad => pf (ad_double_plus_un a0))).
+    rewrite (H2 (fun a0:ad => pf (Ndouble a0))). rewrite (H3 (fun a0:ad => pf (Ndouble_plus_one a0))).
     reflexivity.
   Qed.
 
@@ -590,7 +588,7 @@ Section MapIter.
     rewrite <- (alist_of_Map_semantics (MapMerge A m m') a). rewrite (MapMerge_semantics A m m' a).
     elim (option_sum _ (MapGet A m a)). intro H0. elim H0. intros y H1. rewrite H1.
     elim (option_sum _ (MapGet A m' a)). intro H2. elim H2. intros y' H3.
-    cut (MapGet A (MapDomRestrTo A A m m') a = NONE A).
+    cut (MapGet A (MapDomRestrTo A A m m') a = None).
     rewrite (MapDomRestrTo_semantics A A m m' a). rewrite H3. rewrite H1. intro. discriminate H4.
     exact (H a).
     intro H2. rewrite H2. reflexivity.
diff --git a/theories/IntMap/Maplists.v b/theories/IntMap/Maplists.v
index 645c3407..56a3c160 100644
--- a/theories/IntMap/Maplists.v
+++ b/theories/IntMap/Maplists.v
@@ -5,10 +5,11 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Maplists.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+(*i 	$Id: Maplists.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
-Require Import Addr.
-Require Import Addec.
+Require Import BinNat.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Fset.
 Require Import Mapaxioms.
@@ -28,7 +29,7 @@ Section MapLists.
   Fixpoint ad_in_list (a:ad) (l:list ad) {struct l} : bool :=
     match l with
     | nil => false
-    | a' :: l' => orb (ad_eq a a') (ad_in_list a l')
+    | a' :: l' => orb (Neqb a a') (ad_in_list a l')
     end.
 
   Fixpoint ad_list_stutters (l:list ad) : bool :=
@@ -43,8 +44,8 @@ Section MapLists.
      {l1 : list ad &  {l2 : list ad | l = l1 ++ x :: l2}}.
   Proof.
     simple induction l. intro. discriminate H.
-    intros. elim (sumbool_of_bool (ad_eq x a)). intro H1. simpl in H0. split with (nil (A:=ad)).
-    split with l0. rewrite (ad_eq_complete _ _ H1). reflexivity.
+    intros. elim (sumbool_of_bool (Neqb x a)). intro H1. simpl in H0. split with (nil (A:=ad)).
+    split with l0. rewrite (Neqb_complete _ _ H1). reflexivity.
     intro H2. simpl in H0. rewrite H2 in H0. simpl in H0. elim (H H0). intros l'1 H3.
     split with (a :: l'1). elim H3. intros l2 H4. split with l2. rewrite H4. reflexivity.
   Qed.
@@ -223,7 +224,7 @@ Section MapLists.
   Lemma ad_in_list_app_1 :
    forall (l l':list ad) (x:ad), ad_in_list x (l ++ x :: l') = true.
   Proof.
-    simple induction l. simpl in |- *. intros. rewrite (ad_eq_correct x). reflexivity.
+    simple induction l. simpl in |- *. intros. rewrite (Neqb_correct x). reflexivity.
     intros. simpl in |- *. rewrite (H l' x). apply orb_b_true.
   Qed.
 
@@ -353,18 +354,18 @@ Section MapLists.
         (fun (a:ad) (l:list ad) => ad_in_list a l) (
         fun c:ad => refl_equal _) ad_in_list_app
         (fun (a0:ad) (_:A) => a0 :: nil) m a).
-    simpl in |- *. rewrite (MapFold_orb A (fun (a0:ad) (_:A) => orb (ad_eq a a0) false) m).
+    simpl in |- *. rewrite (MapFold_orb A (fun (a0:ad) (_:A) => orb (Neqb a a0) false) m).
     elim
      (option_sum _
-        (MapSweep A (fun (a0:ad) (_:A) => orb (ad_eq a a0) false) m)). intro H. elim H.
+        (MapSweep A (fun (a0:ad) (_:A) => orb (Neqb a a0) false) m)). intro H. elim H.
     intro r. elim r. intros a0 y H0. rewrite H0. unfold in_dom in |- *.
     elim (orb_prop _ _ (MapSweep_semantics_1 _ _ _ _ _ H0)). intro H1.
-    rewrite (ad_eq_complete _ _ H1). rewrite (MapSweep_semantics_2 A _ _ _ _ H0). reflexivity.
+    rewrite (Neqb_complete _ _ H1). rewrite (MapSweep_semantics_2 A _ _ _ _ H0). reflexivity.
     intro H1. discriminate H1.
     intro H. rewrite H. elim (sumbool_of_bool (in_dom A a m)). intro H0.
     elim (in_dom_some A m a H0). intros y H1.
     elim (orb_false_elim _ _ (MapSweep_semantics_3 _ _ _ H _ _ H1)). intro H2.
-    rewrite (ad_eq_correct a) in H2. discriminate H2.
+    rewrite (Neqb_correct a) in H2. discriminate H2.
     exact (sym_eq (y:=_)).
   Qed.
 
@@ -397,7 +398,7 @@ Section MapLists.
           pf m) = MapCard A m.
   Proof.
     simple induction m; try trivial. simpl in |- *. intros. rewrite ad_list_app_length.
-    rewrite (H (fun a0:ad => pf (ad_double a0))). rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))).
+    rewrite (H (fun a0:ad => pf (Ndouble a0))). rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))).
     reflexivity.
   Qed.
 
@@ -423,8 +424,8 @@ Section MapLists.
      MapFold1 unit (list ad) nil (app (A:=ad))
        (fun (a:ad) (_:unit) => a :: nil) pf (MapDom A m).
   Proof.
-    simple induction m; try trivial. simpl in |- *. intros. rewrite (H (fun a0:ad => pf (ad_double a0))).
-    rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity.
+    simple induction m; try trivial. simpl in |- *. intros. rewrite (H (fun a0:ad => pf (Ndouble a0))).
+    rewrite (H0 (fun a0:ad => pf (Ndouble_plus_one a0))). reflexivity.
   Qed.
 
   Lemma ad_list_of_dom_Dom :
diff --git a/theories/IntMap/Mapsubset.v b/theories/IntMap/Mapsubset.v
index 33b412e3..6771c03e 100644
--- a/theories/IntMap/Mapsubset.v
+++ b/theories/IntMap/Mapsubset.v
@@ -5,15 +5,14 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Mapsubset.v,v 1.4.2.1 2004/07/16 19:31:05 herbelin Exp $	 i*)
+(*i 	$Id: Mapsubset.v 8733 2006-04-25 22:52:18Z letouzey $	 i*)
 
 Require Import Bool.
 Require Import Sumbool.
 Require Import Arith.
-Require Import ZArith.
-Require Import Addr.
-Require Import Adist.
-Require Import Addec.
+Require Import NArith.
+Require Import Ndigits.
+Require Import Ndec.
 Require Import Map.
 Require Import Fset.
 Require Import Mapaxioms.
@@ -28,7 +27,7 @@ Section MapSubsetDef.
 
   Definition MapSubset_1 (m:Map A) (m':Map B) :=
     match MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m with
-    | NONE => true
+    | None => true
     | _ => false
     end.
 
@@ -76,10 +75,10 @@ Section MapSubsetDef.
     unfold eqmap, eqm, in_dom in |- *. intros.
     cut
      (match MapGet A m a with
-      | NONE => false
-      | SOME _ => true
+      | None => false
+      | Some _ => true
       end = false).
-    case (MapGet A m a). trivial.
+    case (MapGet A m a); trivial.
     intros. discriminate H0.
     exact (H a).
   Qed.
@@ -346,7 +345,7 @@ Section MapDisjointDef.
 
   Definition MapDisjoint_1 (m:Map A) (m':Map B) :=
     match MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m with
-    | NONE => true
+    | None => true
     | _ => false
     end.
 
@@ -395,7 +394,7 @@ Section MapDisjointDef.
   Proof.
     unfold MapDisjoint, MapDisjoint_2 in |- *. unfold eqmap, eqm in |- *. intros. elim (in_dom_some _ _ _ H0).
     intros y H2. elim (in_dom_some _ _ _ H1). intros y' H3.
-    cut (MapGet A (MapDomRestrTo A B m m') a = NONE A). intro.
+    cut (MapGet A (MapDomRestrTo A B m m') a = None). intro.
     rewrite (MapDomRestrTo_semantics _ _ m m' a) in H4. rewrite H3 in H4. rewrite H2 in H4.
     discriminate H4.
     exact (H a).
@@ -449,11 +448,11 @@ Section MapDisjointExtra.
   Proof.
     unfold MapDisjoint, in_dom in |- *. intros. elim (option_sum _ (MapGet A m0 a)). intro H2.
     elim H2. intros y H3. elim (option_sum _ (MapGet B m2 a)). intro H4. elim H4.
-    intros y' H5. apply (H (ad_double a)).
-    rewrite (MapGet_M2_bit_0_0 _ (ad_double a) (ad_double_bit_0 a) m0 m1).
-    rewrite (ad_double_div_2 a). rewrite H3. reflexivity.
-    rewrite (MapGet_M2_bit_0_0 _ (ad_double a) (ad_double_bit_0 a) m2 m3).
-    rewrite (ad_double_div_2 a). rewrite H5. reflexivity.
+    intros y' H5. apply (H (Ndouble a)).
+    rewrite (MapGet_M2_bit_0_0 _ (Ndouble a) (Ndouble_bit0 a) m0 m1).
+    rewrite (Ndouble_div2 a). rewrite H3. reflexivity.
+    rewrite (MapGet_M2_bit_0_0 _ (Ndouble a) (Ndouble_bit0 a) m2 m3).
+    rewrite (Ndouble_div2 a). rewrite H5. reflexivity.
     intro H4. rewrite H4 in H1. discriminate H1.
     intro H2. rewrite H2 in H0. discriminate H0.
   Qed.
@@ -464,15 +463,15 @@ Section MapDisjointExtra.
   Proof.
     unfold MapDisjoint, in_dom in |- *. intros. elim (option_sum _ (MapGet A m1 a)). intro H2.
     elim H2. intros y H3. elim (option_sum _ (MapGet B m3 a)). intro H4. elim H4.
-    intros y' H5. apply (H (ad_double_plus_un a)).
+    intros y' H5. apply (H (Ndouble_plus_one a)).
     rewrite
-     (MapGet_M2_bit_0_1 _ (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+     (MapGet_M2_bit_0_1 _ (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a)
         m0 m1).
-    rewrite (ad_double_plus_un_div_2 a). rewrite H3. reflexivity.
+    rewrite (Ndouble_plus_one_div2 a). rewrite H3. reflexivity.
     rewrite
-     (MapGet_M2_bit_0_1 _ (ad_double_plus_un a) (ad_double_plus_un_bit_0 a)
+     (MapGet_M2_bit_0_1 _ (Ndouble_plus_one a) (Ndouble_plus_one_bit0 a)
         m2 m3).
-    rewrite (ad_double_plus_un_div_2 a). rewrite H5. reflexivity.
+    rewrite (Ndouble_plus_one_div2 a). rewrite H5. reflexivity.
     intro H4. rewrite H4 in H1. discriminate H1.
     intro H2. rewrite H2 in H0. discriminate H0.
   Qed.
@@ -482,11 +481,11 @@ Section MapDisjointExtra.
      MapDisjoint A B m0 m2 ->
      MapDisjoint A B m1 m3 -> MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3).
   Proof.
-    unfold MapDisjoint, in_dom in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H3.
+    unfold MapDisjoint, in_dom in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H3.
     rewrite (MapGet_M2_bit_0_1 A a H3 m0 m1) in H1.
-    rewrite (MapGet_M2_bit_0_1 B a H3 m2 m3) in H2. exact (H0 (ad_div_2 a) H1 H2).
+    rewrite (MapGet_M2_bit_0_1 B a H3 m2 m3) in H2. exact (H0 (Ndiv2 a) H1 H2).
     intro H3. rewrite (MapGet_M2_bit_0_0 A a H3 m0 m1) in H1.
-    rewrite (MapGet_M2_bit_0_0 B a H3 m2 m3) in H2. exact (H (ad_div_2 a) H1 H2).
+    rewrite (MapGet_M2_bit_0_0 B a H3 m2 m3) in H2. exact (H (Ndiv2 a) H1 H2).
   Qed.
 
   Lemma MapDisjoint_M1_l :
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index c3f65d67..c80d0b15 100755..100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -1,655 +1,1785 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
+  (************************************************************************)
+  (*  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: List.v,v 1.9.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+  (*i $Id: List.v 9290 2006-10-26 19:20:42Z herbelin $ i*)
 
-Require Import Le.
-
-
-Section Lists.
-
-Variable A : Set.
+Require Import Le Gt Minus Min Bool.
+Require Import Setoid.
 
 Set Implicit Arguments.
 
-Inductive list : Set :=
-  | nil : list
-  | cons : A -> list -> list.
 
-Infix "::" := cons (at level 60, right associativity) : list_scope.
-
-Open Scope list_scope.
+(******************************************************************)
+(** * Basics: definition of polymorphic lists and some operations *)
+(******************************************************************)
 
-(*************************)
-(** Discrimination       *)
-(*************************)
+(** ** Definitions *)
 
-Lemma nil_cons : forall (a:A) (m:list), nil <> a :: m.
-Proof. 
-  intros; discriminate.
-Qed.
+Section Lists.
 
-(*************************)
-(** Concatenation        *)
-(*************************)
+  Variable A : Type.
+
+  Inductive list : Type :=
+    | nil : list
+    | cons : A -> list -> list.
+
+  Infix "::" := cons (at level 60, right associativity) : list_scope.
+
+  Open Scope list_scope.
+
+  (** Head and tail        *)
+  Definition head (l:list) :=
+    match l with
+      | nil => error
+      | x :: _ => value x
+    end.
+
+ Definition hd (default:A) (l:list) :=
+   match l with
+     | nil => default
+     | x :: _ => x
+   end. 
+
+  Definition tail (l:list) : list :=
+    match l with
+      | nil => nil
+      | a :: m => m
+    end.
+
+  (** Length of lists                *)
+  Fixpoint length (l:list) : nat :=
+    match l with
+      | nil => 0
+      | _ :: m => S (length m)
+    end.
+
+  (** The [In] predicate *)
+  Fixpoint In (a:A) (l:list) {struct l} : Prop :=
+    match l with
+      | nil => False
+      | b :: m => b = a \/ In a m
+    end.
+
+
+  (** Concatenation of two lists *)
+  Fixpoint app (l m:list) {struct l} : list :=
+    match l with
+      | nil => m
+      | a :: l1 => a :: app l1 m
+    end.
+  
+  Infix "++" := app (right associativity, at level 60) : list_scope.
+  
+End Lists.
 
-Fixpoint app (l m:list) {struct l} : list :=
-  match l with
-  | nil => m
-  | a :: l1 => a :: app l1 m
-  end.
+(** Exporting list notations and tactics *)
 
+Implicit Arguments nil [A].
+Infix "::" := cons (at level 60, right associativity) : list_scope.
 Infix "++" := app (right associativity, at level 60) : list_scope.
-
-Lemma app_nil_end : forall l:list, l = l ++ nil.
-Proof. 
-	induction l; simpl in |- *; auto.
-        rewrite <- IHl; auto.
-Qed.
-Hint Resolve app_nil_end.
-
+ 
 Ltac now_show c := change c in |- *.
 
-Lemma app_ass : forall l m n:list, (l ++ m) ++ n = l ++ m ++ n.
-Proof. 
-	intros. induction l; simpl in |- *; auto.
-        now_show (a :: (l ++ m) ++ n = a :: l ++ m ++ n).
-	rewrite <- IHl; auto.
-Qed.
-Hint Resolve app_ass.
-
-Lemma ass_app : forall l m n:list, l ++ m ++ n = (l ++ m) ++ n.
-Proof. 
-	auto.
-Qed.
-Hint Resolve ass_app.
-
-Lemma app_comm_cons : forall (x y:list) (a:A), a :: x ++ y = (a :: x) ++ y.
-Proof.
- auto.
-Qed.
-
-Lemma app_eq_nil : forall x y:list, x ++ y = nil -> x = nil /\ y = nil.
-Proof.
-  destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
-   simpl in |- *; auto.
-  intros H; discriminate H.
-  intros; discriminate H.
-Qed.
-
-Lemma app_cons_not_nil : forall (x y:list) (a:A), nil <> x ++ a :: y.
-Proof.
-unfold not in |- *.
-  destruct x as [| a l]; simpl in |- *; intros.
-  discriminate H.
-  discriminate H.
-Qed.
-
-Lemma app_eq_unit :
- forall (x y:list) (a:A),
-   x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil.
+Open Scope list_scope.
 
-Proof.
-  destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
-   simpl in |- *.
-  intros a H; discriminate H.
-  left; split; auto.
-  right; split; auto.
-  generalize H.
-  generalize (app_nil_end l); intros E.
-  rewrite <- E; auto.
-  intros.
-  injection H.
-  intro.
-  cut (nil = l ++ a0 :: l0); auto.
-  intro.
-  generalize (app_cons_not_nil _ _ _ H1); intro.
-  elim H2.
-Qed.
+Delimit Scope list_scope with list.
 
-Lemma app_inj_tail :
- forall (x y:list) (a b:A), x ++ a :: nil = y ++ b :: nil -> x = y /\ a = b.
-Proof.
-  induction x as [| x l IHl];
-   [ destruct y as [| a l] | destruct y as [| a l0] ]; 
-   simpl in |- *; auto.
-  intros a b H.
-  injection H.
-  auto.
-  intros a0 b H.
-  injection H; intros.
-  generalize (app_cons_not_nil _ _ _ H0); destruct 1.
-  intros a b H.
-  injection H; intros.
-  cut (nil = l ++ a :: nil); auto.
-  intro.
-  generalize (app_cons_not_nil _ _ _ H2); destruct 1.
-  intros a0 b H.
-  injection H; intros.
-  destruct (IHl l0 a0 b H0). 
-  split; auto.
-  rewrite <- H1; rewrite <- H2; reflexivity.
-Qed.
+Bind Scope list_scope with list.
 
-(*************************)
-(** Head and tail        *)
-(*************************)
+Arguments Scope list [type_scope].
+
+(** ** Facts about lists *)
+
+Section Facts.
+
+  Variable A : Type.
+
+
+  (** *** Genereric facts *)
+
+  (** Discrimination *)
+  Theorem nil_cons : forall (x:A) (l:list A), nil <> x :: l.
+  Proof. 
+    intros; discriminate.
+  Qed.
+
+
+  (** Destruction *)
+
+  Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = nil}.
+  Proof.
+    induction l as [|a tl].
+    right; reflexivity.
+    left; exists a; exists tl; reflexivity.
+  Qed.
+    
+  (** *** Head and tail *)
+  
+  Theorem head_nil : head (@nil A) = None.
+  Proof.
+    simpl; reflexivity.
+  Qed.
+
+  Theorem head_cons : forall (l : list A) (x : A), head (x::l) = Some x.
+  Proof.
+    intros; simpl; reflexivity.
+  Qed.
+
+
+  (************************)
+  (** *** Facts about [In] *) 
+  (************************)
+
+
+  (** Characterization of [In] *)
+  
+  Theorem in_eq : forall (a:A) (l:list A), In a (a :: l).
+  Proof. 
+    simpl in |- *; auto.
+  Qed.
+  
+  Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l).
+  Proof. 
+    simpl in |- *; auto.
+  Qed.
+
+  Theorem in_nil : forall a:A, ~ In a nil.
+  Proof.
+    unfold not in |- *; intros a H; inversion_clear H.
+  Qed.
+
+  Lemma In_split : forall x (l:list A), In x l -> exists l1, exists l2, l = l1++x::l2.
+  Proof.
+  induction l; simpl; destruct 1.
+  subst a; auto.
+  exists (@nil A); exists l; auto.
+  destruct (IHl H) as (l1,(l2,H0)).
+  exists (a::l1); exists l2; simpl; f_equal; auto.
+  Qed.
+
+  (** Inversion *)
+  Theorem in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l.
+  Proof.
+    intros a b l H; inversion_clear H; auto.
+  Qed.
+
+  (** Decidability of [In] *)
+  Theorem In_dec :
+    (forall x y:A, {x = y} + {x <> y}) ->
+    forall (a:A) (l:list A), {In a l} + {~ In a l}.
+  Proof.
+    intro H; induction l as [| a0 l IHl].
+    right; apply in_nil.
+    destruct (H a0 a); simpl in |- *; auto.
+    destruct IHl; simpl in |- *; auto. 
+    right; unfold not in |- *; intros [Hc1| Hc2]; auto.
+  Defined.
+
+
+  (*************************)
+  (** *** Facts about [app] *)
+  (*************************)
+
+  (** Discrimination *)
+  Theorem app_cons_not_nil : forall (x y:list A) (a:A), nil <> x ++ a :: y.
+  Proof.
+    unfold not in |- *.
+    destruct x as [| a l]; simpl in |- *; intros.
+    discriminate H.
+    discriminate H.
+  Qed.
+
+
+  (** Concat with [nil] *)
+
+  Theorem app_nil_end : forall l:list A, l = l ++ nil.
+  Proof. 
+    induction l; simpl in |- *; auto.
+    rewrite <- IHl; auto.
+  Qed.
+
+  (** [app] is associative *)
+  Theorem app_ass : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n.
+  Proof. 
+    intros. induction l; simpl in |- *; auto.
+    now_show (a :: (l ++ m) ++ n = a :: l ++ m ++ n).
+    rewrite <- IHl; auto.
+  Qed.
+  Hint Resolve app_ass.
+
+  Theorem ass_app : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n.
+  Proof. 
+    auto using app_ass.
+  Qed.
+
+  (** [app] commutes with [cons] *) 
+  Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
+  Proof.
+    auto.
+  Qed.
+
+
+
+  (** Facts deduced from the result of a concatenation *)  
+
+  Theorem app_eq_nil : forall l l':list A, l ++ l' = nil -> l = nil /\ l' = nil.
+  Proof.
+    destruct l as [| x l]; destruct l' as [| y l']; simpl in |- *; auto.
+    intro; discriminate.
+    intros H; discriminate H.
+  Qed.
+
+  Theorem app_eq_unit :
+    forall (x y:list A) (a:A),
+      x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil.
+  Proof.
+    destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
+      simpl in |- *.
+    intros a H; discriminate H.
+    left; split; auto.
+    right; split; auto.
+    generalize H.
+    generalize (app_nil_end l); intros E.
+    rewrite <- E; auto.
+    intros.
+    injection H.
+    intro.
+    cut (nil = l ++ a0 :: l0); auto.
+    intro.
+    generalize (app_cons_not_nil _ _ _ H1); intro.
+    elim H2.
+  Qed.
+
+  Lemma app_inj_tail :
+    forall (x y:list A) (a b:A), x ++ a :: nil = y ++ b :: nil -> x = y /\ a = b.
+  Proof.
+    induction x as [| x l IHl];
+      [ destruct y as [| a l] | destruct y as [| a l0] ]; 
+      simpl in |- *; auto.
+    intros a b H.
+    injection H.
+    auto.
+    intros a0 b H.
+    injection H; intros.
+    generalize (app_cons_not_nil _ _ _ H0); destruct 1.
+    intros a b H.
+    injection H; intros.
+    cut (nil = l ++ a :: nil); auto.
+    intro.
+    generalize (app_cons_not_nil _ _ _ H2); destruct 1.
+    intros a0 b H.
+    injection H; intros.
+    destruct (IHl l0 a0 b H0). 
+    split; auto.
+    rewrite <- H1; rewrite <- H2; reflexivity.
+  Qed.
+
+
+  (** Compatibility wtih other operations *)
+
+  Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'.
+  Proof.
+    induction l; simpl; auto.
+  Qed.
+
+  Lemma in_app_or : forall (l m:list A) (a:A), In a (l ++ m) -> In a l \/ In a m.
+  Proof. 
+    intros l m a.
+    elim l; simpl in |- *; auto.
+    intros a0 y H H0.
+    now_show ((a0 = a \/ In a y) \/ In a m).
+    elim H0; auto.
+    intro H1.
+    now_show ((a0 = a \/ In a y) \/ In a m).
+    elim (H H1); auto.
+  Qed.
+
+  Lemma in_or_app : forall (l m:list A) (a:A), In a l \/ In a m -> In a (l ++ m).
+  Proof. 
+    intros l m a.
+    elim l; simpl in |- *; intro H.
+    now_show (In a m).
+    elim H; auto; intro H0.
+    now_show (In a m).
+    elim H0. (* subProof completed *)
+    intros y H0 H1.
+    now_show (H = a \/ In a (y ++ m)).
+    elim H1; auto 4.
+    intro H2.
+    now_show (H = a \/ In a (y ++ m)).
+    elim H2; auto.
+  Qed.
+
+
+End Facts.
+
+Hint Resolve app_nil_end ass_app app_ass: datatypes v62.
+Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62.
+Hint Immediate app_eq_nil: datatypes v62.
+Hint Resolve app_eq_unit app_inj_tail: datatypes v62. 
+Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62.
 
-Definition head (l:list) :=
-  match l with
-  | nil => error
-  | x :: _ => value x
-  end.
 
-Definition tail (l:list) : list :=
-  match l with
-  | nil => nil
-  | a :: m => m
-  end.
 
-(****************************************)
-(** Length of lists                     *)
-(****************************************)
+(*******************************************)
+(** * Operations on the elements of a list *)
+(*******************************************)
+
+Section Elts.
+
+  Variable A : Type.
+
+  (*****************************)
+  (** ** Nth element of a list *)
+  (*****************************)
+
+  Fixpoint nth (n:nat) (l:list A) (default:A) {struct l} : A :=
+    match n, l with
+      | O, x :: l' => x
+      | O, other => default
+      | S m, nil => default
+      | S m, x :: t => nth m t default
+    end.
+
+  Fixpoint nth_ok (n:nat) (l:list A) (default:A) {struct l} : bool :=
+    match n, l with
+      | O, x :: l' => true
+      | O, other => false
+      | S m, nil => false
+      | S m, x :: t => nth_ok m t default
+    end.
+
+  Lemma nth_in_or_default :
+    forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}.
+  (* Realizer nth_ok. Program_all. *)
+  Proof. 
+    intros n l d; generalize n; induction l; intro n0.
+    right; case n0; trivial.
+    case n0; simpl in |- *.
+    auto.
+    intro n1; elim (IHl n1); auto.     
+  Qed.
+
+  Lemma nth_S_cons :
+    forall (n:nat) (l:list A) (d a:A),
+      In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l).
+  Proof. 
+    simpl in |- *; auto.
+  Qed.
+
+  Fixpoint nth_error (l:list A) (n:nat) {struct n} : Exc A :=
+    match n, l with
+      | O, x :: _ => value x
+      | S n, _ :: l => nth_error l n
+      | _, _ => error
+    end.
+
+  Definition nth_default (default:A) (l:list A) (n:nat) : A :=
+    match nth_error l n with
+      | Some x => x
+      | None => default
+    end.
+
+  Lemma nth_In :
+    forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l.
+
+  Proof.
+    unfold lt in |- *; induction n as [| n hn]; simpl in |- *.
+    destruct l; simpl in |- *; [ inversion 2 | auto ].
+    destruct l as [| a l hl]; simpl in |- *.
+    inversion 2.
+    intros d ie; right; apply hn; auto with arith.
+  Qed.
+
+  Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d.
+  Proof.
+    induction l; destruct n; simpl; intros; auto.
+    inversion H.
+    apply IHl; auto with arith.
+  Qed.
+
+  Lemma nth_indep : 
+    forall l n d d', n < length l -> nth n l d = nth n l d'.
+  Proof.
+    induction l; simpl; intros; auto.
+    inversion H.
+    destruct n; simpl; auto with arith.
+  Qed.
+
+  Lemma app_nth1 : 
+    forall l l' d n, n < length l -> nth n (l++l') d = nth n l d.
+  Proof.
+    induction l.
+    intros.
+    inversion H.
+    intros l' d n.
+    case n; simpl; auto.
+    intros; rewrite IHl; auto with arith.
+  Qed.
+
+  Lemma app_nth2 : 
+    forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
+  Proof.
+    induction l.
+    intros.
+    simpl.
+    destruct n; auto.
+    intros l' d n.
+    case n; simpl; auto.
+    intros.
+    inversion H.
+    intros.
+    rewrite IHl; auto with arith.
+  Qed.
+
+
+
+
+  (*****************)
+  (** ** Remove    *)
+  (*****************)
+
+  Section Remove.
+
+    Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}.
+    
+    Fixpoint remove (x : A) (l : list A){struct l} : list A :=
+      match l with
+	| nil => nil
+	| y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl)
+      end.
+    
+    Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l).
+    Proof.
+      induction l as [|x l]; auto.
+      intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. 
+      apply IHl.
+      unfold not; intro HF; simpl in HF; destruct HF; auto.
+      apply (IHl y); assumption. 
+    Qed.
+  
+  End Remove.
 
-Fixpoint length (l:list) : nat :=
-  match l with
-  | nil => 0
-  | _ :: m => S (length m)
-  end.
 
 (******************************)
-(** Length order of lists     *)
+(** ** Last element of a list *)
 (******************************)
 
-Section length_order.
-Definition lel (l m:list) := length l <= length m.
-
-Variables a b : A.
-Variables l m n : list.
-
-Lemma lel_refl : lel l l.
-Proof. 
-	unfold lel in |- *; auto with arith.
-Qed.
-
-Lemma lel_trans : lel l m -> lel m n -> lel l n.
-Proof. 
-	unfold lel in |- *; intros.
-        now_show (length l <= length n).
-        apply le_trans with (length m); auto with arith.
-Qed.
-
-Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m).
-Proof. 
-	unfold lel in |- *; simpl in |- *; auto with arith.
-Qed.
-
-Lemma lel_cons : lel l m -> lel l (b :: m).
-Proof. 
-	unfold lel in |- *; simpl in |- *; auto with arith.
-Qed.
-
-Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m.
-Proof. 
-	unfold lel in |- *; simpl in |- *; auto with arith.
-Qed.
+  (** [last l d] returns the last element of the list [l], 
+    or the default value [d] if [l] is empty. *)
 
-Lemma lel_nil : forall l':list, lel l' nil -> nil = l'.
-Proof. 
-	intro l'; elim l'; auto with arith.
-	intros a' y H H0.
-        now_show (nil = a' :: y).
-	absurd (S (length y) <= 0); auto with arith.
-Qed.
-End length_order.
-
-Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons.
-
-(*********************************)
-(** The [In] predicate           *)
-(*********************************)
-
-Fixpoint In (a:A) (l:list) {struct l} : Prop :=
-  match l with
-  | nil => False
-  | b :: m => b = a \/ In a m
+  Fixpoint last (l:list A) (d:A)  {struct l} : A := 
+  match l with 
+    | nil => d 
+    | a :: nil => a 
+    | a :: l => last l d
   end.
 
-Lemma in_eq : forall (a:A) (l:list), In a (a :: l).
-Proof. 
-	simpl in |- *; auto.
-Qed.
-Hint Resolve in_eq.
+  (** [removelast l] remove the last element of [l] *)
+
+  Fixpoint removelast (l:list A) {struct l} : list A := 
+    match l with 
+      | nil =>  nil 
+      | a :: nil => nil 
+      | a :: l => a :: removelast l
+    end.
+  
+  Lemma app_removelast_last : 
+    forall l d, l<>nil -> l = removelast l ++ (last l d :: nil).
+  Proof.
+    induction l.
+    destruct 1; auto.
+    intros d _.
+    destruct l; auto.
+    pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate.
+  Qed.
+  
+  Lemma exists_last : 
+    forall l, l<>nil -> { l' : (list A) & { a : A | l = l'++a::nil}}. 
+  Proof. 
+    induction l.
+    destruct 1; auto.
+    intros _.
+    destruct l.
+    exists (@nil A); exists a; auto.
+    destruct IHl as [l' (a',H)]; try discriminate.
+    rewrite H.
+    exists (a::l'); exists a'; auto.
+  Qed.
+
+  
+  (****************************************)
+  (** ** Counting occurences of a element *)
+  (****************************************)
+
+  Hypotheses eqA_dec : forall x y : A, {x = y}+{x <> y}.
+  
+  Fixpoint count_occ (l : list A) (x : A){struct l} : nat :=
+    match l with 
+      | nil => 0
+      | y :: tl => 
+	let n := count_occ tl x in 
+	  if eqA_dec y x then S n else n
+    end.
+  
+  (** Compatibility of count_occ with operations on list *)
+  Theorem count_occ_In : forall (l : list A) (x : A), In x l <-> count_occ l x > 0.
+  Proof.
+    induction l as [|y l].
+    simpl; intros; split; [destruct 1 | apply gt_irrefl].
+    simpl. intro x; destruct (eqA_dec y x) as [Heq|Hneq].
+    rewrite Heq; intuition. 
+    rewrite <- (IHl x).
+    tauto.
+  Qed.
+  
+  Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = nil.
+  Proof.
+    split.
+    (* Case -> *)
+    induction l as [|x l].
+    trivial.
+    intro H.
+    elim (O_S (count_occ l x)).
+    apply sym_eq.
+    generalize (H x).
+    simpl. destruct (eqA_dec x x) as [|HF].
+    trivial.
+    elim HF; reflexivity.
+    (* Case <- *)
+    intro H; rewrite H; simpl; reflexivity.
+  Qed.
+  
+  Lemma count_occ_nil : forall (x : A), count_occ nil x = 0.
+  Proof.
+    intro x; simpl; reflexivity.
+  Qed.
+
+  Lemma count_occ_cons_eq : forall (l : list A) (x y : A), x = y -> count_occ (x::l) y = S (count_occ l y).
+  Proof.
+    intros l x y H; simpl.
+    destruct (eqA_dec x y); [reflexivity | contradiction].
+  Qed.
+  
+  Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y.
+  Proof.
+    intros l x y H; simpl.
+    destruct (eqA_dec x y); [contradiction | reflexivity]. 
+  Qed.
+
+End Elts.
+
+
+
+(*******************************)
+(** * Manipulating whole lists *)
+(*******************************)
+
+Section ListOps.
+
+  Variable A : Type.
+
+  (*************************)
+  (** ** Reverse           *)
+  (*************************)
+
+  Fixpoint rev (l:list A) : list A :=
+    match l with
+      | nil => nil
+      | x :: l' => rev l' ++ x :: nil
+    end.
+
+  Lemma distr_rev : forall x y:list A, rev (x ++ y) = rev y ++ rev x.
+  Proof.
+    induction x as [| a l IHl].
+    destruct y as [| a l].
+    simpl in |- *.
+    auto.
+
+    simpl in |- *.
+    apply app_nil_end; auto.
+
+    intro y.
+    simpl in |- *.
+    rewrite (IHl y).
+    apply (app_ass (rev y) (rev l) (a :: nil)).
+  Qed.
+
+  Remark rev_unit : forall (l:list A) (a:A), rev (l ++ a :: nil) = a :: rev l.
+  Proof.
+    intros.
+    apply (distr_rev l (a :: nil)); simpl in |- *; auto.
+  Qed.
+
+  Lemma rev_involutive : forall l:list A, rev (rev l) = l.
+  Proof.
+    induction l as [| a l IHl].
+    simpl in |- *; auto.
+
+    simpl in |- *.
+    rewrite (rev_unit (rev l) a).
+    rewrite IHl; auto.
+  Qed.
+
+
+  (** Compatibility with other operations *)
+
+  Lemma In_rev : forall l x, In x l <-> In x (rev l).
+  Proof.
+    induction l.
+    simpl; intuition.
+    intros.
+    simpl.
+    intuition.
+    subst.
+    apply in_or_app; right; simpl; auto.
+    apply in_or_app; left; firstorder.
+    destruct (in_app_or _ _ _ H); firstorder.
+  Qed.
+
+  Lemma rev_length : forall l, length (rev l) = length l.
+  Proof.
+    induction l;simpl; auto.
+    rewrite app_length.
+    rewrite IHl.
+    simpl.
+    elim (length l); simpl; auto.
+  Qed.
+
+  Lemma rev_nth : forall l d n,  n < length l ->  
+    nth n (rev l) d = nth (length l - S n) l d.
+  Proof.
+    induction l.
+    intros; inversion H.
+    intros.
+    simpl in H.
+    simpl (rev (a :: l)).
+    simpl (length (a :: l) - S n).
+    inversion H.
+    rewrite <- minus_n_n; simpl.
+    rewrite <- rev_length.
+    rewrite app_nth2; auto.
+    rewrite <- minus_n_n; auto.
+    rewrite app_nth1; auto.
+    rewrite (minus_plus_simpl_l_reverse (length l) n 1).
+    replace (1 + length l) with (S (length l)); auto with arith.
+    rewrite <- minus_Sn_m; auto with arith; simpl.
+    apply IHl; auto.
+    rewrite rev_length; auto.
+  Qed.
+
+
+  (**  An alternative tail-recursive definition for reverse *) 
+
+  Fixpoint rev_append (l l': list A) {struct l} : list A := 
+    match l with 
+      | nil => l' 
+      | a::l => rev_append l (a::l')
+    end.
+
+  Definition rev' l : list A := rev_append l nil.
+
+  Notation rev_acc := rev_append (only parsing).
+
+  Lemma rev_append_rev : forall l l', rev_acc l l' = rev l ++ l'.
+  Proof.
+    induction l; simpl; auto; intros.
+    rewrite <- ass_app; firstorder.
+  Qed.
+
+  Notation rev_acc_rev := rev_append_rev (only parsing).
+
+  Lemma rev_alt : forall l, rev l = rev_append l nil.
+  Proof.
+    intros; rewrite rev_append_rev.
+    apply app_nil_end.
+  Qed.
 
-Lemma in_cons : forall (a b:A) (l:list), In b l -> In b (a :: l).
-Proof. 
-	simpl in |- *; auto.
-Qed.
-Hint Resolve in_cons.
-
-Lemma in_nil : forall a:A, ~ In a nil.
-Proof.
-  unfold not in |- *; intros a H; inversion_clear H.
-Qed.
-
-
-Lemma in_inv : forall (a b:A) (l:list), In b (a :: l) -> a = b \/ In b l.
-Proof.
- intros a b l H; inversion_clear H; auto.
-Qed.
-
-Lemma In_dec :
- (forall x y:A, {x = y} + {x <> y}) ->
- forall (a:A) (l:list), {In a l} + {~ In a l}.
-
-Proof.
-  induction l as [| a0 l IHl].
-  right; apply in_nil.
-  destruct (H a0 a); simpl in |- *; auto.
-  destruct IHl; simpl in |- *; auto. 
-  right; unfold not in |- *; intros [Hc1| Hc2]; auto.
-Qed.
 
-Lemma in_app_or : forall (l m:list) (a:A), In a (l ++ m) -> In a l \/ In a m.
-Proof. 
-	intros l m a.
-	elim l; simpl in |- *; auto.
-	intros a0 y H H0.
-	now_show ((a0 = a \/ In a y) \/ In a m).
-	elim H0; auto.
-	intro H1.
-        now_show ((a0 = a \/ In a y) \/ In a m).
-	elim (H H1); auto.
-Qed.
-Hint Immediate in_app_or.
-
-Lemma in_or_app : forall (l m:list) (a:A), In a l \/ In a m -> In a (l ++ m).
-Proof. 
-	intros l m a.
-	elim l; simpl in |- *; intro H.
-        now_show (In a m).
-	elim H; auto; intro H0.
-	now_show (In a m).
-	elim H0. (* subProof completed *)
-	intros y H0 H1.
-	now_show (H = a \/ In a (y ++ m)).
-	elim H1; auto 4.
-	intro H2.
-	now_show (H = a \/ In a (y ++ m)).
-	elim H2; auto.
-Qed.
-Hint Resolve in_or_app.
-
-(***************************)
-(** Set inclusion on list  *)
-(***************************)
-
-Definition incl (l m:list) := forall a:A, In a l -> In a m.
-Hint Unfold incl.
-
-Lemma incl_refl : forall l:list, incl l l.
-Proof. 
-	auto.
-Qed.
-Hint Resolve incl_refl.
-
-Lemma incl_tl : forall (a:A) (l m:list), incl l m -> incl l (a :: m).
-Proof. 
-	auto.
-Qed.
-Hint Immediate incl_tl.
-
-Lemma incl_tran : forall l m n:list, incl l m -> incl m n -> incl l n.
-Proof. 
-	auto.
-Qed.
-
-Lemma incl_appl : forall l m n:list, incl l n -> incl l (n ++ m).
-Proof. 
-	auto.
-Qed.
-Hint Immediate incl_appl.
-
-Lemma incl_appr : forall l m n:list, incl l n -> incl l (m ++ n).
-Proof. 
-	auto.
-Qed.
-Hint Immediate incl_appr.
-
-Lemma incl_cons :
- forall (a:A) (l m:list), In a m -> incl l m -> incl (a :: l) m.
-Proof. 
-	unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1.
-        now_show (In a0 m).
-	elim H1.
-	now_show (a = a0 -> In a0 m).
-	elim H1; auto; intro H2.
-	now_show (a = a0 -> In a0 m).
-	elim H2; auto. (* solves subgoal *)
-	now_show (In a0 l -> In a0 m).
-	auto.
-Qed.
-Hint Resolve incl_cons.
-
-Lemma incl_app : forall l m n:list, incl l n -> incl m n -> incl (l ++ m) n.
-Proof. 
-	unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1.
-        now_show (In a n).
-	elim (in_app_or _ _ _ H1); auto.
-Qed.
-Hint Resolve incl_app.
-
-(**************************)
-(** Nth element of a list *)
-(**************************)
-
-Fixpoint nth (n:nat) (l:list) (default:A) {struct l} : A :=
-  match n, l with
-  | O, x :: l' => x
-  | O, other => default
-  | S m, nil => default
-  | S m, x :: t => nth m t default
-  end.
-
-Fixpoint nth_ok (n:nat) (l:list) (default:A) {struct l} : bool :=
-  match n, l with
-  | O, x :: l' => true
-  | O, other => false
-  | S m, nil => false
-  | S m, x :: t => nth_ok m t default
-  end.
-
-Lemma nth_in_or_default :
- forall (n:nat) (l:list) (d:A), {In (nth n l d) l} + {nth n l d = d}.
-(* Realizer nth_ok. Program_all. *)
-Proof. 
-  intros n l d; generalize n; induction l; intro n0.
-  right; case n0; trivial.
-  case n0; simpl in |- *.
-  auto.
-  intro n1; elim (IHl n1); auto.     
-Qed.
-
-Lemma nth_S_cons :
- forall (n:nat) (l:list) (d a:A),
-   In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l).
-Proof. 
-  simpl in |- *; auto.
-Qed.
-
-Fixpoint nth_error (l:list) (n:nat) {struct n} : Exc A :=
-  match n, l with
-  | O, x :: _ => value x
-  | S n, _ :: l => nth_error l n
-  | _, _ => error
-  end.
-
-Definition nth_default (default:A) (l:list) (n:nat) : A :=
-  match nth_error l n with
-  | Some x => x
-  | None => default
-  end.
-
-Lemma nth_In :
- forall (n:nat) (l:list) (d:A), n < length l -> In (nth n l d) l.
+(*********************************************)
+(** Reverse Induction Principle on Lists  *)
+(*********************************************)
+  
+  Section Reverse_Induction.
+    
+    Unset Implicit Arguments.
+    
+    Lemma rev_list_ind :
+      forall P:list A-> Prop,
+	P nil ->
+	(forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
+	forall l:list A, P (rev l).
+    Proof.
+      induction l; auto.
+    Qed.
+    Set Implicit Arguments.
+    
+    Theorem rev_ind :
+      forall P:list A -> Prop,
+	P nil ->
+	(forall (x:A) (l:list A), P l -> P (l ++ x :: nil)) -> forall l:list A, P l.
+    Proof.
+      intros.
+      generalize (rev_involutive l).
+      intros E; rewrite <- E.
+      apply (rev_list_ind P).
+      auto.
+      
+      simpl in |- *.
+      intros.
+      apply (H0 a (rev l0)).
+      auto.
+    Qed.
+  
+  End Reverse_Induction.
+
+
+
+  (***********************************)
+  (** ** Lists modulo permutation    *)
+  (***********************************)
+  
+  Section Permutation.
+
+    Inductive Permutation : list A -> list A -> Prop :=
+      | perm_nil: Permutation nil nil
+      | perm_skip: forall (x:A) (l l':list A), Permutation l l' -> Permutation (cons x l) (cons x l')
+      | perm_swap: forall (x y:A) (l:list A), Permutation (cons y (cons x l)) (cons x (cons y l))
+      | perm_trans: forall (l l' l'':list A), Permutation l l' -> Permutation l' l'' -> Permutation l l''.
+
+    Hint Constructors Permutation.
+
+  (** Some facts about [Permutation] *)
+
+    Theorem Permutation_nil : forall (l : list A), Permutation nil l -> l = nil.
+    Proof.
+      intros l HF.
+      set (m:=@nil A) in HF; assert (m = nil); [reflexivity|idtac]; clearbody m.
+      induction HF; try elim (nil_cons (sym_eq H)); auto.
+    Qed.
+
+    Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l).
+    Proof.
+      unfold not; intros l x HF.
+      elim (@nil_cons A x l). apply sym_eq. exact (Permutation_nil HF).
+    Qed.
+
+  (** Permutation over lists is a equivalence relation *)
+
+    Theorem Permutation_refl : forall l : list A, Permutation l l.
+    Proof.
+      induction l; constructor. exact IHl. 
+    Qed.
+
+    Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l.
+    Proof.
+      intros l l' Hperm; induction Hperm; auto.
+      apply perm_trans with (l':=l'); assumption.
+    Qed.
+
+    Theorem Permutation_trans : forall l l' l'' : list A, Permutation l l' -> Permutation l' l'' -> Permutation l l''.
+    Proof.
+      exact perm_trans.
+    Qed.
+
+    Hint Resolve Permutation_refl Permutation_sym Permutation_trans.
+
+  (** Compatibility with others operations on lists *)
+
+    Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'.
+    Proof.
+      intros l l' x Hperm; induction Hperm; simpl; tauto. 
+    Qed.
+
+    Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl).
+    Proof.
+      intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
+      eapply Permutation_trans with (l':=l'++tl); trivial.
+    Qed.
+
+    Lemma Permutation_app_head : forall (l tl tl' : list A), Permutation tl tl' -> Permutation (l++tl) (l++tl').
+    Proof.
+      intros l tl tl' Hperm; induction l; [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
+    Qed.
+
+    Theorem Permutation_app : forall (l m l' m' : list A), Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
+    Proof.
+      intros l m l' m' Hpermll' Hpermmm'; induction Hpermll' as [|x l l'|x y l|l l' l'']; repeat rewrite <- app_comm_cons; auto.
+      apply Permutation_trans with (l' := (x :: y :: l ++ m));
+	[idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
+      apply Permutation_trans with (l' := (l' ++ m')); try assumption.
+      apply Permutation_app_tail; assumption.
+    Qed.
+
+    Theorem Permutation_app_swap : forall (l l' : list A), Permutation (l++l') (l'++l).
+    Proof.
+      induction l as [|x l]. 
+      simpl; intro l'; rewrite <- app_nil_end; trivial.
+      induction l' as [|y l'].
+      simpl; rewrite <- app_nil_end; trivial.
+      simpl; apply Permutation_trans with (l' := x :: y :: l' ++ l).
+      constructor; rewrite app_comm_cons; apply IHl.
+      apply Permutation_trans with (l' := y :: x :: l' ++ l); constructor.
+      apply Permutation_trans with (l' := x :: l ++ l'); auto.
+    Qed.
+  
+    Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
+      Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
+    Proof.
+    intros l l1; revert l.
+    induction l1.
+    simpl.
+    intros; apply perm_skip; auto.
+    simpl; intros.
+    apply perm_trans with (a0::a::l1++l2).
+    apply perm_skip; auto.
+    apply perm_trans with (a::a0::l1++l2).
+    apply perm_swap; auto.
+    apply perm_skip; auto.
+    Qed.
+    Hint Resolve Permutation_cons_app.
+
+    Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'.
+    Proof.
+      intros l l' Hperm; induction Hperm; simpl; auto.
+      apply trans_eq with (y:= (length l')); trivial.
+    Qed.
+
+    Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). 
+    Proof.
+      induction l as [| x l]; simpl; trivial.
+      apply Permutation_trans with (l' := (x::nil)++rev l).
+      simpl; auto.
+      apply Permutation_app_swap.
+    Qed.
+
+    Theorem Permutation_ind_bis : 
+     forall P : list A -> list A -> Prop,
+       P (@nil A) (@nil A) ->
+       (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) ->
+       (forall x y l l', Permutation l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
+       (forall l l' l'', Permutation l l' -> P l l' -> Permutation l' l'' -> P l' l'' -> P l l'') ->
+       forall l l', Permutation l l' -> P l l'.
+    Proof.
+    intros P Hnil Hskip Hswap Htrans.
+    induction 1; auto.
+    apply Htrans with (x::y::l); auto.
+    apply Hswap; auto.
+    induction l; auto.
+    apply Hskip; auto.
+    apply Hskip; auto.
+    induction l; auto.
+    eauto.
+    Qed.
+
+    Ltac break_list l x l' H := 
+     destruct l as [|x l']; simpl in *; 
+     injection H; intros; subst; clear H.
+
+    Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a,
+      Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
+    Proof.
+    set (P:=fun l l' =>  
+             forall a l1 l2 l3 l4, l=l1++a::l2 -> l'=l3++a::l4 -> Permutation (l1++l2) (l3++l4)).
+    cut (forall l l', Permutation l l' -> P l l').
+    intros; apply (H _ _ H0 a); auto.
+    intros; apply (Permutation_ind_bis P); unfold P; clear P; try clear H l l'; simpl; auto.
+    (* nil *)
+    intros; destruct l1; simpl in *; discriminate.
+    (* skip *)
+    intros x l l' H IH; intros.
+    break_list l1 b l1' H0; break_list l3 c l3' H1.
+    auto.
+    apply perm_trans with (l3'++c::l4); auto.
+    apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app.
+    apply perm_skip.
+    apply (IH a l1' l2 l3' l4); auto.
+    (* swap *)
+    intros x y l l' Hp IH; intros.
+    break_list l1 b l1' H; break_list l3 c l3' H0.
+    auto.
+    break_list l3' b l3'' H.
+    auto.
+    apply perm_trans with (c::l3''++b::l4); auto.
+    break_list l1' c l1'' H1. 
+    auto.
+    apply perm_trans with (b::l1''++c::l2); auto.
+    break_list l3' d l3'' H; break_list l1' e l1'' H1. 
+    auto.
+    apply perm_trans with (e::a::l1''++l2); auto.
+    apply perm_trans with (e::l1''++a::l2); auto.
+    apply perm_trans with (d::a::l3''++l4); auto.
+    apply perm_trans with (d::l3''++a::l4); auto.
+    apply perm_trans with (e::d::l1''++l2); auto.
+    apply perm_skip; apply perm_skip.
+    apply (IH a l1'' l2 l3'' l4); auto.
+    (*trans*)
+    intros.
+    destruct (In_split a l') as (l'1,(l'2,H6)).
+    apply (Permutation_in a H).
+    subst l.
+    apply in_or_app; right; red; auto.
+    apply perm_trans with (l'1++l'2).
+    apply (H0 _ _ _ _ _ H3 H6).
+    apply (H2 _ _ _ _ _ H6 H4).
+    Qed.
+
+    Theorem Permutation_cons_inv : 
+       forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'.
+    Proof.
+    intros; exact (Permutation_app_inv (@nil _) l (@nil _) l' a H). 
+    Qed.
+
+    Theorem Permutation_cons_app_inv :
+       forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
+    Proof.
+    intros; exact (Permutation_app_inv (@nil _) l l1 l2 a H). 
+    Qed.
+    
+    Theorem Permutation_app_inv_l : 
+        forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
+    Proof.    
+    induction l; simpl; auto.
+    intros.
+    apply IHl.
+    apply Permutation_cons_inv with a; auto.
+    Qed.
+
+    Theorem Permutation_app_inv_r : 
+       forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
+    Proof.
+    induction l.
+    intros l1 l2; do 2 rewrite <- app_nil_end; auto.
+    intros.
+    apply IHl.
+    apply Permutation_app_inv with a; auto.
+    Qed.
+
+  End Permutation.
+
+
+  (***********************************)
+  (** ** Decidable equality on lists *)
+  (***********************************)
+
+  Hypotheses eqA_dec : forall (x y : A), {x = y}+{x <> y}.
+
+  Lemma list_eq_dec :
+    forall l l':list A, {l = l'} + {l <> l'}.
+  Proof.
+    induction l as [| x l IHl]; destruct l' as [| y l'].
+    left; trivial.
+    right; apply nil_cons. 
+    right; unfold not; intro HF; apply (nil_cons (sym_eq HF)).
+    destruct (eqA_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql']; 
+      try (right; unfold not; intro HF; injection HF; intros; contradiction).
+    rewrite xeqy; rewrite leql'; left; trivial.
+  Qed.
+
+
+End ListOps.
+
+
+(***************************************************)
+(** * Applying functions to the elements of a list *)
+(***************************************************)
+
+(************)
+(** ** Map  *)
+(************)
 
+Section Map.
+  Variables A B : Type.
+  Variable f : A -> B.
+  
+  Fixpoint map (l:list A) : list B :=
+    match l with
+      | nil => nil
+      | cons a t => cons (f a) (map t)
+    end.
+  
+  Lemma in_map :
+    forall (l:list A) (x:A), In x l -> In (f x) (map l).
+  Proof. 
+    induction l as [| a l IHl]; simpl in |- *;
+      [ auto
+	| destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ].
+  Qed.
+  
+  Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l.
+  Proof.
+    induction l; firstorder (subst; auto).
+  Qed.
+
+  Lemma map_length : forall l, length (map l) = length l.
+  Proof.
+    induction l; simpl; auto.
+  Qed.
+
+  Lemma map_nth : forall l d n, 
+    nth n (map l) (f d) = f (nth n l d).
+  Proof.
+    induction l; simpl map; destruct n; firstorder.
+  Qed.
+  
+  Lemma map_app : forall l l',  
+    map (l++l') = (map l)++(map l').
+  Proof. 
+    induction l; simpl; auto.
+    intros; rewrite IHl; auto.
+  Qed.
+  
+  Lemma map_rev : forall l, map (rev l) = rev (map l).
+  Proof. 
+    induction l; simpl; auto.
+    rewrite map_app.
+    rewrite IHl; auto.
+  Qed.
+
+  Hint Constructors Permutation.
+
+  Lemma Permutation_map : 
+    forall l l', Permutation l l' -> Permutation (map l) (map l').
+  Proof. 
+  induction 1; simpl; auto; eauto.
+  Qed.
+
+  (** [flat_map] *)
+
+  Fixpoint flat_map (f:A -> list B) (l:list A) {struct l} : 
+    list B :=
+    match l with
+      | nil => nil
+      | cons x t => (f x)++(flat_map f t)
+    end.
+  
+  Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B),
+    In y (flat_map f l) <-> exists x, In x l /\ In y (f x). 
+  Proof.
+    induction l; simpl; split; intros.
+    contradiction.
+    destruct H as (x,(H,_)); contradiction.
+    destruct (in_app_or _ _ _ H).
+    exists a; auto.
+    destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)).
+    exists x; auto.
+    apply in_or_app.
+    destruct H as (x,(H0,H1)); destruct H0.
+    subst; auto.
+    right; destruct (IHl y) as (_,H2); apply H2.
+    exists x; auto.
+  Qed.
+
+End Map. 
+
+Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, 
+  map g (map f l) = map (fun x => g (f x)) l.
 Proof.
-unfold lt in |- *; induction n as [| n hn]; simpl in |- *.
-destruct l; simpl in |- *; [ inversion 2 | auto ].
-destruct l as [| a l hl]; simpl in |- *.
-inversion 2.
-intros d ie; right; apply hn; auto with arith.
+  induction l; simpl; auto.
+  rewrite IHl; auto.
 Qed.
 
-(********************************)
-(** Decidable equality on lists *)
-(********************************)
-
-
-Lemma list_eq_dec :
- (forall x y:A, {x = y} + {x <> y}) -> forall x y:list, {x = y} + {x <> y}.
+Lemma map_ext : 
+  forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
 Proof.
-  induction x as [| a l IHl]; destruct y as [| a0 l0]; auto.
-  destruct (H a a0) as [e| e].
-  destruct (IHl l0) as [e'| e'].
-  left; rewrite e; rewrite e'; trivial.
-  right; red in |- *; intro.
-  apply e'; injection H0; trivial.
-  right; red in |- *; intro.
-  apply e; injection H0; trivial.
+  induction l; simpl; auto.
+  rewrite H; rewrite IHl; auto.
 Qed.
 
-(*************************)
-(**  Reverse             *)
-(*************************)
 
-Fixpoint rev (l:list) : list :=
-  match l with
-  | nil => nil
-  | x :: l' => rev l' ++ x :: nil
-  end.
+(************************************)
+(** Left-to-right iterator on lists *)
+(************************************)
 
-Lemma distr_rev : forall x y:list, rev (x ++ y) = rev y ++ rev x.
-Proof.
- induction x as [| a l IHl].
- destruct y as [| a l].
- simpl in |- *.
- auto.
-
- simpl in |- *.
- apply app_nil_end; auto.
-
- intro y.
- simpl in |- *.
- rewrite (IHl y).
- apply (app_ass (rev y) (rev l) (a :: nil)).
-Qed.
+Section Fold_Left_Recursor.
+  Variables A B : Type.
+  Variable f : A -> B -> A.
+  
+  Fixpoint fold_left (l:list B) (a0:A) {struct l} : A :=
+    match l with
+      | nil => a0
+      | cons b t => fold_left t (f a0 b)
+    end.
+  
+  Lemma fold_left_app : forall (l l':list B)(i:A), 
+    fold_left (l++l') i = fold_left l' (fold_left l i).
+  Proof.
+    induction l. 
+    simpl; auto.
+    intros.
+    simpl.
+    auto.
+  Qed.
 
-Remark rev_unit : forall (l:list) (a:A), rev (l ++ a :: nil) = a :: rev l.
-Proof.
- intros.
- apply (distr_rev l (a :: nil)); simpl in |- *; auto.
-Qed.
+End Fold_Left_Recursor.
 
-Lemma rev_involutive : forall l:list, rev (rev l) = l.
+Lemma fold_left_length : 
+  forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l.
 Proof.
- induction l as [| a l IHl].
- simpl in |- *; auto.
-
- simpl in |- *.
- rewrite (rev_unit (rev l) a).
- rewrite IHl; auto.
+  intro A.
+  cut (forall (l:list A) n, fold_left (fun x _ => S x) l n = n + length l).
+  intros.
+  exact (H l 0).
+  induction l; simpl; auto.
+  intros; rewrite IHl.
+  simpl; auto with arith.
 Qed.
 
-(*********************************************)
-(**  Reverse Induction Principle on Lists    *)
-(*********************************************)
+(************************************)
+(** Right-to-left iterator on lists *)
+(************************************)
 
-Section Reverse_Induction.
+Section Fold_Right_Recursor.
+  Variables A B : Type.
+  Variable f : B -> A -> A.
+  Variable a0 : A.
+  
+  Fixpoint fold_right (l:list B) : A :=
+    match l with
+      | nil => a0
+      | cons b t => f b (fold_right t)
+    end.
 
-Unset Implicit Arguments.
+End Fold_Right_Recursor.
 
-Remark rev_list_ind :
- forall P:list -> Prop,
-   P nil ->
-   (forall (a:A) (l:list), P (rev l) -> P (rev (a :: l))) ->
-   forall l:list, P (rev l).
-Proof.
- induction l; auto.
-Qed.
-Set Implicit Arguments.
+  Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, 
+    fold_right f i (l++l') = fold_right f (fold_right f i l') l.
+  Proof.
+    induction l.
+    simpl; auto.
+    simpl; intros.
+    f_equal; auto.
+  Qed.
+
+  Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, 
+    fold_right f i (rev l) = fold_left (fun x y => f y x) l i.
+  Proof.
+    induction l.
+    simpl; auto.
+    intros.
+    simpl.
+    rewrite fold_right_app; simpl; auto.
+  Qed.
+
+  Theorem fold_symmetric :
+    forall (A:Type) (f:A -> A -> A),
+      (forall x y z:A, f x (f y z) = f (f x y) z) ->
+      (forall x y:A, f x y = f y x) ->
+      forall (a0:A) (l:list A), fold_left f l a0 = fold_right f a0 l.
+  Proof.
+    destruct l as [| a l].
+    reflexivity.
+    simpl in |- *.
+    rewrite <- H0.
+    generalize a0 a.
+    induction l as [| a3 l IHl]; simpl in |- *.
+    trivial.
+    intros.
+    rewrite H.
+    rewrite (H0 a2).
+    rewrite <- (H a1).
+    rewrite (H0 a1).
+    rewrite IHl.
+    reflexivity.
+  Qed.
+
+
+
+  (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
+      indexed by elts of [x], sorted in lexicographic order. *)
+
+  Fixpoint list_power (A B:Type)(l:list A) (l':list B) {struct l} :
+    list (list (A * B)) :=
+    match l with
+      | nil => cons nil nil
+      | cons x t =>
+	flat_map (fun f:list (A * B) => map (fun y:B => cons (x, y) f) l')
+        (list_power t l')
+    end.
+
+
+  (*************************************)
+  (** ** Boolean operations over lists *)
+  (*************************************)
+
+  Section Bool. 
+    Variable A : Type.
+    Variable f : A -> bool.
+
+  (** find whether a boolean function can be satisfied by an 
+       elements of the list. *)
+
+    Fixpoint existsb (l:list A) {struct l}: bool := 
+      match l with 
+	| nil => false
+	| a::l => f a || existsb l
+      end.
+
+    Lemma existsb_exists : 
+      forall l, existsb l = true <-> exists x, In x l /\ f x = true.
+    Proof.
+      induction l; simpl; intuition.
+      inversion H.
+      firstorder.
+      destruct (orb_prop _ _ H1); firstorder.
+      firstorder.
+      subst.
+      rewrite H2; auto.
+    Qed.
+
+    Lemma existsb_nth : forall l n d, n < length l ->
+      existsb l = false -> f (nth n l d) = false.
+    Proof.
+      induction l.
+      inversion 1.
+      simpl; intros.
+      destruct (orb_false_elim _ _ H0); clear H0; auto.
+      destruct n ; auto. 
+      rewrite IHl; auto with arith.
+    Qed.
+
+  (** find whether a boolean function is satisfied by 
+    all the elements of a list. *)
+
+    Fixpoint forallb (l:list A) {struct l} : bool := 
+      match l with 
+	| nil => true
+	| a::l => f a && forallb l
+      end.
+
+    Lemma forallb_forall : 
+      forall l, forallb l = true <-> (forall x, In x l -> f x = true).
+    Proof.
+      induction l; simpl; intuition.
+      destruct (andb_prop _ _ H1).
+      congruence.
+      destruct (andb_prop _ _ H1); auto.
+      assert (forallb l = true).
+      apply H0; intuition.
+      rewrite H1; auto. 
+    Qed.
+
+  (** [filter] *)
+
+    Fixpoint filter (l:list A) : list A := 
+      match l with 
+	| nil => nil
+	| x :: l => if f x then x::(filter l) else filter l
+      end.
+
+    Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true.
+    Proof.
+      induction l; simpl.
+      intuition.
+      intros.
+      case_eq (f a); intros; simpl; intuition congruence.
+    Qed.
+
+  (** [find] *)
+
+    Fixpoint find (l:list A) : option A :=
+      match l with
+	| nil => None
+	| x :: tl => if f x then Some x else find tl
+      end.
+
+  (** [partition] *)
+
+    Fixpoint partition (l:list A) {struct l} : list A * list A := 
+      match l with
+	| nil => (nil, nil)
+	| x :: tl => let (g,d) := partition tl in 
+	  if f x then (x::g,d) else (g,x::d)
+      end.
+
+  End Bool.
+
+
+
+
+  (******************************************************)
+  (** ** Operations on lists of pairs or lists of lists *)
+  (******************************************************)
+
+  Section ListPairs.
+    Variables A B : Type.
+    
+  (** [split] derives two lists from a list of pairs *)
+
+    Fixpoint split  (l:list (A*B)) { struct l }: list A * list B :=
+      match l with
+	| nil => (nil, nil)
+	| (x,y) :: tl => let (g,d) := split tl in (x::g, y::d)
+      end.
+
+    Lemma in_split_l : forall (l:list (A*B))(p:A*B), 
+      In p l -> In (fst p) (fst (split l)). 
+    Proof.
+      induction l; simpl; intros; auto.
+      destruct p; destruct a; destruct (split l); simpl in *.
+      destruct H.
+      injection H; auto.
+      right; apply (IHl (a0,b) H).
+    Qed.
+
+    Lemma in_split_r : forall (l:list (A*B))(p:A*B), 
+      In p l -> In (snd p) (snd (split l)). 
+    Proof.
+      induction l; simpl; intros; auto.
+      destruct p; destruct a; destruct (split l); simpl in *.
+      destruct H.
+      injection H; auto.
+      right; apply (IHl (a0,b) H).
+    Qed.
+
+    Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), 
+      nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)).
+    Proof.
+      induction l.
+      destruct n; destruct d; simpl; auto.
+      destruct n; destruct d; simpl; auto.
+      destruct a; destruct (split l); simpl; auto.
+      destruct a; destruct (split l); simpl in *; auto.
+      rewrite IHl; simpl; auto.
+    Qed.
+
+    Lemma split_length_l : forall (l:list (A*B)),
+      length (fst (split l)) = length l. 
+    Proof.
+      induction l; simpl; auto.
+      destruct a; destruct (split l); simpl; auto.
+    Qed.
+
+    Lemma split_length_r : forall (l:list (A*B)),
+      length (snd (split l)) = length l. 
+    Proof.
+      induction l; simpl; auto.
+      destruct a; destruct (split l); simpl; auto.
+    Qed.
+
+  (** [combine] is the opposite of [split]. 
+      Lists given to [combine] are meant to be of same length. 
+      If not, [combine] stops on the shorter list *)
+
+    Fixpoint combine (l : list A) (l' : list B){struct l} : list (A*B) :=
+      match l,l' with
+	| x::tl, y::tl' => (x,y)::(combine tl tl')
+	| _, _ => nil
+      end.
+
+    Lemma split_combine : forall (l: list (A*B)), 
+      let (l1,l2) := split l in combine l1 l2 = l.
+    Proof.
+      induction l.
+      simpl; auto.
+      destruct a; simpl. 
+      destruct (split l); simpl in *.
+      f_equal; auto.
+    Qed.
+
+    Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> 
+      split (combine l l') = (l,l').
+    Proof.
+      induction l; destruct l'; simpl; intros; auto; try discriminate.
+      injection H; clear H; intros.
+      rewrite IHl; auto.
+    Qed.
+
+    Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), 
+      In (x,y) (combine l l') -> In x l.
+    Proof.
+      induction l.
+      simpl; auto.
+      destruct l'; simpl; auto; intros.
+      contradiction. 
+      destruct H.
+      injection H; auto.
+      right; apply IHl with l' y; auto.
+    Qed.
+
+    Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), 
+      In (x,y) (combine l l') -> In y l'.
+    Proof.
+      induction l.
+      simpl; intros; contradiction.
+      destruct l'; simpl; auto; intros.
+      destruct H.
+      injection H; auto.
+      right; apply IHl with x; auto.
+    Qed.
+
+    Lemma combine_length : forall (l:list A)(l':list B), 
+      length (combine l l') = min (length l) (length l').
+    Proof.
+      induction l.
+      simpl; auto.
+      destruct l'; simpl; auto.
+    Qed.
+
+    Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), 
+      length l = length l' -> 
+      nth n (combine l l') (x,y) = (nth n l x, nth n l' y).
+    Proof.
+      induction l; destruct l'; intros; try discriminate.
+      destruct n; simpl; auto.
+      destruct n; simpl in *; auto.
+    Qed.
+
+  (** [list_prod] has the same signature as [combine], but unlike
+     [combine], it adds every possible pairs, not only those at the 
+     same position. *)
+
+    Fixpoint list_prod (l:list A) (l':list B) {struct l} :
+      list (A * B) :=
+      match l with
+	| nil => nil
+	| cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l')
+      end.
+
+    Lemma in_prod_aux :
+      forall (x:A) (y:B) (l:list B),
+	In y l -> In (x, y) (map (fun y0:B => (x, y0)) l).
+    Proof. 
+      induction l;
+	[ simpl in |- *; auto
+	  | simpl in |- *; destruct 1 as [H1| ];
+	    [ left; rewrite H1; trivial | right; auto ] ].
+    Qed.
+
+    Lemma in_prod :
+      forall (l:list A) (l':list B) (x:A) (y:B),
+	In x l -> In y l' -> In (x, y) (list_prod l l').
+    Proof. 
+      induction l;
+	[ simpl in |- *; tauto
+	  | simpl in |- *; intros; apply in_or_app; destruct H;
+	    [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ].
+    Qed.
+
+    Lemma in_prod_iff : 
+      forall (l:list A)(l':list B)(x:A)(y:B), 
+	In (x,y) (list_prod l l') <-> In x l /\ In y l'.
+    Proof.
+      split; [ | intros; apply in_prod; intuition ].
+      induction l; simpl; intros.
+      intuition.
+      destruct (in_app_or _ _ _ H); clear H.
+      destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_).
+      destruct (H1 H0) as (z,(H2,H3)); clear H0 H1.
+      injection H2; clear H2; intros; subst; intuition.
+      intuition.
+    Qed. 
+
+    Lemma prod_length : forall (l:list A)(l':list B), 
+      length (list_prod l l') = (length l) * (length l').
+    Proof.
+      induction l; simpl; auto.
+      intros.
+      rewrite app_length.
+      rewrite map_length.
+      auto.
+    Qed.
+
+  End ListPairs.
+
+
+
+
+(***************************************)
+(** * Miscelenous operations on lists  *)
+(***************************************)
 
-Lemma rev_ind :
- forall P:list -> Prop,
-   P nil ->
-   (forall (x:A) (l:list), P l -> P (l ++ x :: nil)) -> forall l:list, P l.
-Proof.
- intros.
- generalize (rev_involutive l).
- intros E; rewrite <- E.
- apply (rev_list_ind P).
- auto.
-
- simpl in |- *.
- intros.
- apply (H0 a (rev l0)).
- auto.
-Qed.
 
-End Reverse_Induction.
 
-End Lists.
+(******************************)
+(** ** Length order of lists  *)
+(******************************)
 
-Implicit Arguments nil [A].
+Section length_order.
+  Variable A : Type.
+
+  Definition lel (l m:list A) := length l <= length m.
+
+  Variables a b : A.
+  Variables l m n : list A.
+
+  Lemma lel_refl : lel l l.
+  Proof. 
+    unfold lel in |- *; auto with arith.
+  Qed.
+
+  Lemma lel_trans : lel l m -> lel m n -> lel l n.
+  Proof. 
+    unfold lel in |- *; intros.
+    now_show (length l <= length n).
+    apply le_trans with (length m); auto with arith.
+  Qed.
+
+  Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m).
+  Proof. 
+    unfold lel in |- *; simpl in |- *; auto with arith.
+  Qed.
+
+  Lemma lel_cons : lel l m -> lel l (b :: m).
+  Proof. 
+    unfold lel in |- *; simpl in |- *; auto with arith.
+  Qed.
+
+  Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m.
+  Proof. 
+    unfold lel in |- *; simpl in |- *; auto with arith.
+  Qed.
+
+  Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'.
+  Proof. 
+    intro l'; elim l'; auto with arith.
+    intros a' y H H0.
+    now_show (nil = a' :: y).
+    absurd (S (length y) <= 0); auto with arith.
+  Qed.
+End length_order.
 
-Hint Resolve nil_cons app_nil_end ass_app app_ass: datatypes v62.
-Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62.
-Hint Immediate app_eq_nil: datatypes v62.
-Hint Resolve app_eq_unit app_inj_tail: datatypes v62. 
 Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons:
   datatypes v62.
-Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62.
-Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
-  incl_app: datatypes v62.
 
-Section Functions_on_lists.
 
-(****************************************************************)
-(** Some generic functions on lists and basic functions of them *)
-(****************************************************************)
-
-Section Map.
-Variables A B : Set.
-Variable f : A -> B.
-Fixpoint map (l:list A) : list B :=
-  match l with
-  | nil => nil
-  | cons a t => cons (f a) (map t)
-  end.
-End Map.
-
-Lemma in_map :
- forall (A B:Set) (f:A -> B) (l:list A) (x:A), In x l -> In (f x) (map f l).
-Proof. 
-  induction l as [| a l IHl]; simpl in |- *;
-   [ auto
-   | destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ].
-Qed.
-
-Fixpoint flat_map (A B:Set) (f:A -> list B) (l:list A) {struct l} : 
- list B :=
-  match l with
-  | nil => nil
-  | cons x t => app (f x) (flat_map f t)
-  end.
-
-Fixpoint list_prod (A B:Set) (l:list A) (l':list B) {struct l} :
- list (A * B) :=
-  match l with
-  | nil => nil
-  | cons x t => app (map (fun y:B => (x, y)) l') (list_prod t l')
-  end.
-
-Lemma in_prod_aux :
- forall (A B:Set) (x:A) (y:B) (l:list B),
-   In y l -> In (x, y) (map (fun y0:B => (x, y0)) l).
-Proof. 
-  induction l;
-   [ simpl in |- *; auto
-   | simpl in |- *; destruct 1 as [H1| ];
-      [ left; rewrite H1; trivial | right; auto ] ].
-Qed.
-
-Lemma in_prod :
- forall (A B:Set) (l:list A) (l':list B) (x:A) (y:B),
-   In x l -> In y l' -> In (x, y) (list_prod l l').
-Proof. 
-  induction l;
-   [ simpl in |- *; tauto
-   | simpl in |- *; intros; apply in_or_app; destruct H;
-      [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ].
-Qed.
-
-(** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
-    indexed by elts of [x], sorted in lexicographic order. *)
-
-Fixpoint list_power (A B:Set) (l:list A) (l':list B) {struct l} :
- list (list (A * B)) :=
-  match l with
-  | nil => cons nil nil
-  | cons x t =>
-      flat_map (fun f:list (A * B) => map (fun y:B => cons (x, y) f) l')
-        (list_power t l')
-  end.
-
-(************************************)
-(** Left-to-right iterator on lists *)
-(************************************)
-
-Section Fold_Left_Recursor.
-Variables A B : Set.
-Variable f : A -> B -> A.
-Fixpoint fold_left (l:list B) (a0:A) {struct l} : A :=
-  match l with
-  | nil => a0
-  | cons b t => fold_left t (f a0 b)
-  end.
-End Fold_Left_Recursor.
-
-(************************************)
-(** Right-to-left iterator on lists *)
-(************************************)
-
-Section Fold_Right_Recursor.
-Variables A B : Set.
-Variable f : B -> A -> A.
-Variable a0 : A.
-Fixpoint fold_right (l:list B) : A :=
-  match l with
-  | nil => a0
-  | cons b t => f b (fold_right t)
-  end.
-End Fold_Right_Recursor.
-
-Theorem fold_symmetric :
- forall (A:Set) (f:A -> A -> A),
-   (forall x y z:A, f x (f y z) = f (f x y) z) ->
-   (forall x y:A, f x y = f y x) ->
-   forall (a0:A) (l:list A), fold_left f l a0 = fold_right f a0 l.
-Proof.
-destruct l as [| a l].
-reflexivity.
-simpl in |- *.
-rewrite <- H0.
-generalize a0 a.
-induction l as [| a3 l IHl]; simpl in |- *.
-trivial.
-intros.
-rewrite H.
-rewrite (H0 a2).
-rewrite <- (H a1).
-rewrite (H0 a1).
-rewrite IHl.
-reflexivity.
-Qed.
-
-End Functions_on_lists.
+(******************************)
+(** ** Set inclusion on list  *)
+(******************************)
 
+Section SetIncl.
+
+  Variable A : Type.
+
+  Definition incl (l m:list A) := forall a:A, In a l -> In a m.
+  Hint Unfold incl.
+  
+  Lemma incl_refl : forall l:list A, incl l l.
+  Proof. 
+    auto.
+  Qed.
+  Hint Resolve incl_refl.
+  
+  Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m).
+  Proof. 
+    auto with datatypes.
+  Qed.
+  Hint Immediate incl_tl.
+
+  Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n.
+  Proof. 
+    auto.
+  Qed.
+  
+  Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m).
+  Proof. 
+    auto with datatypes.
+  Qed.
+  Hint Immediate incl_appl.
+  
+  Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n).
+  Proof. 
+    auto with datatypes.
+  Qed.
+  Hint Immediate incl_appr.
+  
+  Lemma incl_cons :
+    forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m.
+  Proof. 
+    unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1.
+    now_show (In a0 m).
+    elim H1.
+    now_show (a = a0 -> In a0 m).
+    elim H1; auto; intro H2.
+    now_show (a = a0 -> In a0 m).
+    elim H2; auto. (* solves subgoal *)
+    now_show (In a0 l -> In a0 m).
+    auto.
+  Qed.
+  Hint Resolve incl_cons.
+  
+  Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n.
+  Proof. 
+    unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1.
+    now_show (In a n).
+    elim (in_app_or _ _ _ H1); auto.
+  Qed.
+  Hint Resolve incl_app.
+  
+End SetIncl.
 
-(** Exporting list notations *)
+Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
+  incl_app: datatypes v62.
 
-Infix "::" := cons (at level 60, right associativity) : list_scope.
 
-Infix "++" := app (right associativity, at level 60) : list_scope.
+(**************************************)
+(* ** Cutting a list at some position *)
+(**************************************)
+
+Section Cutting.
+
+  Variable A : Type.
+
+  Fixpoint firstn (n:nat)(l:list A) {struct n} : list A := 
+    match n with 
+      | 0 => nil 
+      | S n => match l with  
+		 | nil => nil 
+		 | a::l => a::(firstn n l)
+	       end
+    end.
+  
+  Fixpoint skipn (n:nat)(l:list A) { struct n } : list A := 
+    match n with 
+      | 0 => l 
+      | S n => match l with 
+		 | nil => nil 
+		 | a::l => skipn n l
+	       end
+    end.
+  
+  Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l.
+  Proof.
+    induction n.
+    simpl; auto.
+    destruct l; simpl; auto.
+    f_equal; auto.
+  Qed.
+
+End Cutting.
 
-Open Scope list_scope.
 
-(** Declare Scope list_scope with key list *)
-Delimit Scope list_scope with list.
+(********************************)
+(** ** Lists without redundancy *)
+(********************************)
 
-Bind Scope list_scope with list.
+Section ReDun.
+
+  Variable A : Type.
+  
+  Inductive NoDup : list A -> Prop := 
+    | NoDup_nil : NoDup nil 
+    | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). 
+
+  Lemma NoDup_remove_1 : forall l l' a, NoDup (l++a::l') -> NoDup (l++l').
+  Proof.
+  induction l; simpl.
+  inversion_clear 1; auto.
+  inversion_clear 1.
+  constructor.
+  swap H0.
+  apply in_or_app; destruct (in_app_or _ _ _ H); simpl; tauto.
+  apply IHl with a0; auto.
+  Qed.
+
+  Lemma NoDup_remove_2 : forall l l' a, NoDup (l++a::l') -> ~In a (l++l').
+  Proof.
+  induction l; simpl.
+  inversion_clear 1; auto.
+  inversion_clear 1.
+  swap H0.
+  destruct H.
+  subst a0.
+  apply in_or_app; right; red; auto.
+  destruct (IHl _ _ H1); auto.
+  Qed.
+
+  Lemma NoDup_Permutation : forall l l', 
+    NoDup l -> NoDup l' -> (forall x, In x l <-> In x l') -> Permutation l l'.
+  Proof.
+  induction l. 
+  destruct l'; simpl; intros.
+  apply perm_nil.
+  destruct (H1 a) as (_,H2); destruct H2; auto.
+  intros.
+  destruct (In_split a l') as (l'1,(l'2,H2)).
+  destruct (H1 a) as (H2,H3); simpl in *; auto.
+  subst l'.
+  apply Permutation_cons_app.
+  inversion_clear H.
+  apply IHl; auto.
+  apply NoDup_remove_1 with a; auto.
+  intro x; split; intros.
+  assert (In x (l'1++a::l'2)).
+   destruct (H1 x); simpl in *; auto.
+  apply in_or_app; destruct (in_app_or _ _ _ H4); auto.
+  destruct H5; auto.
+  subst x; destruct H2; auto.
+  assert (In x (l'1++a::l'2)).
+    apply in_or_app; destruct (in_app_or _ _ _ H); simpl; auto.
+  destruct (H1 x) as (_,H5); destruct H5; auto. 
+  subst x.
+  destruct (NoDup_remove_2 _ _ _ H0 H).
+  Qed.
+
+End ReDun.
+
+
+(***********************************)
+(** ** Sequence of natural numbers *)
+(***********************************)
+
+Section NatSeq.
+
+  (** [seq] computes the sequence of [len] contiguous integers 
+      that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *)
+  
+  Fixpoint seq (start len:nat) {struct len} : list nat := 
+    match len with 
+      | 0 => nil
+      | S len => start :: seq (S start) len
+    end. 
+  
+  Lemma seq_length : forall len start, length (seq start len) = len.
+  Proof.
+    induction len; simpl; auto.
+  Qed.
+  
+  Lemma seq_nth : forall len start n d, 
+    n < len -> nth n (seq start len) d = start+n.
+  Proof.
+    induction len; intros.
+    inversion H.
+    simpl seq.
+    destruct n; simpl.
+    auto with arith.
+    rewrite IHlen;simpl; auto with arith.
+  Qed.
+
+  Lemma seq_shift : forall len start,
+    map S (seq start len) = seq (S start) len.
+  Proof. 
+    induction len; simpl; auto.
+    intros.
+    rewrite IHlen.
+    auto with arith.
+  Qed.
+
+End NatSeq.
+
+
+
+  (** * Exporting hints and tactics *)
+
+
+Hint Rewrite 
+  rev_involutive (* rev (rev l) = l *)
+  rev_unit (* rev (l ++ a :: nil) = a :: rev l *)
+  map_nth (* nth n (map f l) (f d) = f (nth n l d) *)
+  map_length (* length (map f l) = length l *)
+  seq_length (* length (seq start len) = len *)
+  app_length (* length (l ++ l') = length l + length l' *)
+  rev_length (* length (rev l) = length l *)
+  : list.
+
+Hint Rewrite <- 
+  app_nil_end (* l = l ++ nil *)
+  : list.
+
+Ltac simpl_list := autorewrite with list.
+Ltac ssimpl_list := autorewrite with list using simpl.
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
index d5ecad9c..4e009ed5 100644
--- a/theories/Lists/ListSet.v
+++ b/theories/Lists/ListSet.v
@@ -6,14 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ListSet.v,v 1.13.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+(*i $Id: ListSet.v 6844 2005-03-16 13:09:55Z herbelin $ i*)
 
-(** A Library for finite sets, implemented as lists 
-    A Library with similar interface will soon be available under
-    the name TreeSet in the theories/Trees directory *)
+(** A Library for finite sets, implemented as lists *)
 
-(** PolyList is loaded, but not exported.
-    This allow to "hide" the definitions, functions and theorems of PolyList
+(** List is loaded, but not exported.
+    This allow to "hide" the definitions, functions and theorems of List
     and to see only the ones of ListSet *)
 
 Require Import List.
@@ -395,4 +393,4 @@ Section other_definitions.
  
 End other_definitions.
 
-Unset Implicit Arguments.
\ No newline at end of file
+Unset Implicit Arguments.
diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v
new file mode 100644
index 00000000..e46f1279
--- /dev/null
+++ b/theories/Lists/ListTactics.v
@@ -0,0 +1,77 @@
+(************************************************************************)
+(*  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: ListTactics.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
+
+Require Import BinPos.
+Require Import List.
+
+Ltac list_fold_right fcons fnil l :=
+  match l with
+  | (cons ?x ?tl) => fcons x ltac:(list_fold_right fcons fnil tl)
+  | nil => fnil
+  end.
+
+Ltac lazy_list_fold_right fcons fnil l :=
+  match l with
+  | (cons ?x ?tl) => 
+       let cont := lazy_list_fold_right fcons fnil in
+       fcons x cont tl
+  | nil => fnil 
+  end.
+
+Ltac list_fold_left fcons fnil l :=
+  match l with
+  | (cons ?x ?tl) => list_fold_left fcons ltac:(fcons x fnil) tl
+  | nil => fnil
+  end.
+
+Ltac list_iter f l :=
+  match l with
+  | (cons ?x ?tl) => f x; list_iter f tl
+  | nil => idtac
+  end.
+
+Ltac list_iter_gen seq f l :=
+  match l with
+  | (cons ?x ?tl) =>
+      let t1 _ := f x in
+      let t2 _ := list_iter_gen seq f tl in
+      seq t1 t2
+  | nil => idtac
+  end.
+
+Ltac AddFvTail a l :=
+ match l with
+ | nil          => constr:(cons a l)
+ | (cons a _)   => l
+ | (cons ?x ?l) => let l' := AddFvTail a l in constr:(cons x l')
+ end.
+
+Ltac Find_at a l :=
+ let rec find n l :=
+   match l with
+   | nil => fail 100 "anomaly: Find_at"
+   | (cons a _) => eval compute in n
+   | (cons _ ?l) => find (Psucc n) l
+   end
+ in find 1%positive l.
+
+Ltac check_is_list t :=
+  match t with
+  | cons _ ?l => check_is_list l
+  | nil => idtac
+  | _ => fail 100 "anomaly: failed to build a canonical list"
+  end.
+
+Ltac check_fv l :=
+  check_is_list l;
+  match type of l with 
+  | list _ => idtac
+  | _ => fail 100 "anomaly: built an ill-typed list"
+  end.
diff --git a/theories/Lists/MonoList.v b/theories/Lists/MonoList.v
index d639a39d..aa2b74dd 100755..100644
--- a/theories/Lists/MonoList.v
+++ b/theories/Lists/MonoList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: MonoList.v,v 1.2.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+(*i $Id: MonoList.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 (** THIS IS A OLD CONTRIB. IT IS NO LONGER MAINTAINED ***)
 
diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
new file mode 100644
index 00000000..eb40594b
--- /dev/null
+++ b/theories/Lists/SetoidList.v
@@ -0,0 +1,515 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: SetoidList.v 8853 2006-05-23 18:17:38Z herbelin $ *)
+
+Require Export List.
+Require Export Sorting.
+Require Export Setoid.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Logical relations over lists with respect to a setoid equality 
+      or ordering. *) 
+
+(** This can be seen as a complement of predicate [lelistA] and [sort] 
+    found in [Sorting]. *)
+
+Section Type_with_equality.
+Variable A : Set.
+Variable eqA : A -> A -> Prop. 
+
+(** Being in a list modulo an equality relation over type [A]. *)
+
+Inductive InA (x : A) : list A -> Prop :=
+  | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l)
+  | InA_cons_tl : forall y l, InA x l -> InA x (y :: l).
+
+Hint Constructors InA.
+
+(** An alternative definition of [InA]. *)
+
+Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l.
+Proof. 
+ induction l; intuition.
+ inversion H.
+ firstorder.
+ inversion H1; firstorder.
+ firstorder; subst; auto.
+Qed.
+
+(** A list without redundancy modulo the equality over [A]. *)
+
+Inductive NoDupA : list A -> Prop :=
+  | NoDupA_nil : NoDupA nil
+  | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l).
+
+Hint Constructors NoDupA.
+
+(** lists with same elements modulo [eqA] *)
+
+Definition eqlistA l l' := forall x, InA x l <-> InA x l'.
+
+(** Results concerning lists modulo [eqA] *)
+
+Hypothesis eqA_refl : forall x, eqA x x.
+Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x.
+Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z.
+
+Hint Resolve eqA_refl eqA_trans.
+Hint Immediate eqA_sym.
+
+Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l.
+Proof. 
+ intros s x y.
+ do 2 rewrite InA_alt.
+ intros H (z,(U,V)).  
+ exists z; split; eauto.
+Qed.
+Hint Immediate InA_eqA.
+
+Lemma In_InA : forall l x, In x l -> InA x l.
+Proof.
+ simple induction l; simpl in |- *; intuition.
+ subst; auto.  
+Qed.
+Hint Resolve In_InA.
+
+Lemma InA_split : forall l x, InA x l -> 
+ exists l1, exists y, exists l2, 
+ eqA x y /\ l = l1++y::l2.
+Proof.
+induction l; inversion_clear 1.
+exists (@nil A); exists a; exists l; auto.
+destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))).
+exists (a::l1); exists y; exists l2; auto.
+split; simpl; f_equal; auto.
+Qed.
+
+(** Results concerning lists modulo [eqA] and [ltA] *)
+
+Variable ltA : A -> A -> Prop.
+
+Hypothesis ltA_trans : forall x y z, ltA x y -> ltA y z -> ltA x z.
+Hypothesis ltA_not_eqA : forall x y, ltA x y -> ~ eqA x y.
+Hypothesis ltA_eqA : forall x y z, ltA x y -> eqA y z -> ltA x z.
+Hypothesis eqA_ltA : forall x y z, eqA x y -> ltA y z -> ltA x z.
+
+Hint Resolve ltA_trans.
+Hint Immediate ltA_eqA eqA_ltA.
+
+Notation InfA:=(lelistA ltA).
+Notation SortA:=(sort ltA).
+
+Lemma InfA_ltA :
+ forall l x y, ltA x y -> InfA y l -> InfA x l.
+Proof.
+ intro s; case s; constructor; inversion_clear H0.
+ eapply ltA_trans; eauto.
+Qed.
+ 
+Lemma InfA_eqA :
+ forall l x y, eqA x y -> InfA y l -> InfA x l.
+Proof.
+ intro s; case s; constructor; inversion_clear H0; eauto.
+Qed.
+Hint Immediate InfA_ltA InfA_eqA. 
+
+Lemma SortA_InfA_InA :
+ forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x.
+Proof. 
+ simple induction l.
+ intros; inversion H1.
+ intros.
+ inversion_clear H0; inversion_clear H1; inversion_clear H2.
+ eapply ltA_eqA; eauto.
+ eauto.
+Qed.
+  
+Lemma In_InfA :
+ forall l x, (forall y, In y l -> ltA x y) -> InfA x l.
+Proof.
+ simple induction l; simpl in |- *; intros; constructor; auto.
+Qed.
+ 
+Lemma InA_InfA :
+ forall l x, (forall y, InA y l -> ltA x y) -> InfA x l.
+Proof.
+ simple induction l; simpl in |- *; intros; constructor; auto.
+Qed.
+
+(* In fact, this may be used as an alternative definition for InfA: *)
+
+Lemma InfA_alt : 
+ forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)).
+Proof. 
+split.
+intros; eapply SortA_InfA_InA; eauto.
+apply InA_InfA.
+Qed.
+
+Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l.
+Proof.
+ simple induction l; auto.
+ intros x l' H H0.
+ inversion_clear H0.
+ constructor; auto.  
+ intro.
+ assert (ltA x x) by (eapply SortA_InfA_InA; eauto).
+ elim (ltA_not_eqA H3); auto.
+Qed.
+
+Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> 
+  (forall x, InA x l -> InA x l' -> False) -> 
+  NoDupA (l++l').
+Proof.
+induction l; simpl; auto; intros.
+inversion_clear H.
+constructor.
+rewrite InA_alt; intros (y,(H4,H5)).
+destruct (in_app_or _ _ _ H5).
+elim H2.
+rewrite InA_alt.
+exists y; auto.
+apply (H1 a).
+auto.
+rewrite InA_alt.
+exists y; auto.
+apply IHl; auto.
+intros.
+apply (H1 x); auto.
+Qed.
+
+
+Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l).
+Proof.
+induction l.
+simpl; auto.
+simpl; intros.
+inversion_clear H.
+apply NoDupA_app; auto.
+constructor; auto.
+intro H2; inversion H2.
+intros x.
+rewrite InA_alt.
+intros (x1,(H2,H3)).
+inversion_clear 1.
+destruct H0.
+apply InA_eqA with x1; eauto.
+apply In_InA.
+rewrite In_rev; auto.
+inversion H4.
+Qed.
+
+
+Lemma InA_app : forall l1 l2 x,
+ InA x (l1 ++ l2) -> InA x l1 \/ InA x l2.
+Proof.
+ induction l1; simpl in *; intuition.
+ inversion_clear H; auto.
+ elim (IHl1 l2 x H0); auto.
+Qed.
+
+ Hint Constructors lelistA sort.
+
+Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2).
+Proof.
+ induction l1; simpl; auto.
+ inversion_clear 1; auto.
+Qed.
+
+Lemma SortA_app :
+ forall l1 l2, SortA l1 -> SortA l2 ->
+ (forall x y, InA x l1 -> InA y l2 -> ltA x y) ->
+ SortA (l1 ++ l2).
+Proof.
+ induction l1; simpl in *; intuition.
+ inversion_clear H.
+ constructor; auto.
+ apply InfA_app; auto.
+ destruct l2; auto.
+Qed.
+
+Section Remove.
+
+Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
+
+Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }.
+Proof.
+induction l.
+right; auto.
+red; inversion 1.
+destruct (eqA_dec x a).
+left; auto.
+destruct IHl.
+left; auto.
+right; red; inversion_clear 1; tauto.
+Qed.
+
+Fixpoint removeA (x : A) (l : list A){struct l} : list A :=
+  match l with
+    | nil => nil
+    | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl)
+  end.
+
+Lemma removeA_filter : forall x l, 
+  removeA x l = filter (fun y => if eqA_dec x y then false else true) l.
+Proof.
+induction l; simpl; auto.
+destruct (eqA_dec x a); auto.
+rewrite IHl; auto.
+Qed.
+
+Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y.
+Proof.
+induction l; simpl; auto.
+split.
+inversion_clear 1.
+destruct 1; inversion_clear H.
+intros.
+destruct (eqA_dec x a); simpl; auto.
+rewrite IHl; split; destruct 1; split; auto.
+inversion_clear H; auto.
+destruct H0; apply eqA_trans with a; auto.
+split.
+inversion_clear 1.
+split; auto.
+swap n.
+apply eqA_trans with y; auto.
+rewrite (IHl x y) in H0; destruct H0; auto.
+destruct 1; inversion_clear H; auto.
+constructor 2; rewrite IHl; auto.
+Qed.
+
+Lemma removeA_NoDupA :
+  forall s x, NoDupA s ->  NoDupA (removeA x s).
+Proof.
+simple induction s; simpl; intros.
+auto.
+inversion_clear H0.
+destruct (eqA_dec x a); simpl; auto. 
+constructor; auto.
+rewrite removeA_InA.
+intuition.
+Qed. 
+
+Lemma removeA_eqlistA : forall l l' x, 
+  ~InA x l -> eqlistA (x :: l) l' -> eqlistA l (removeA x l').
+Proof.  
+unfold eqlistA; intros. 
+rewrite removeA_InA.
+split; intros.
+rewrite <- H0; split; auto.
+swap H.
+apply InA_eqA with x0; auto.
+rewrite <- (H0 x0) in H1.
+destruct H1.
+inversion_clear H1; auto.
+elim H2; auto.
+Qed.
+
+Let addlistA x l l' := forall y, InA y l' <-> eqA x y \/ InA y l.
+
+Lemma removeA_add :
+  forall s s' x x', NoDupA s -> NoDupA (x' :: s') ->
+  ~ eqA x x' -> ~ InA x s -> 
+  addlistA x s (x' :: s') -> addlistA x (removeA x' s) s'.
+Proof.
+unfold addlistA; intros.
+inversion_clear H0.
+rewrite removeA_InA; auto.
+split; intros.
+destruct (eqA_dec x y); auto; intros.
+right; split; auto.
+destruct (H3 y); clear H3.
+destruct H6; intuition.
+swap H4; apply InA_eqA with y; auto.
+destruct H0.
+assert (InA y (x' :: s')) by (rewrite H3; auto).
+inversion_clear H6; auto.
+elim H1; apply eqA_trans with y; auto.
+destruct H0.
+assert (InA y (x' :: s')) by (rewrite H3; auto).
+inversion_clear H7; auto.
+elim H6; auto.
+Qed.
+
+Section Fold.
+
+Variable B:Set.
+Variable eqB:B->B->Prop.
+
+(** Two-argument functions that allow to reorder its arguments. *)
+Definition transpose (f : A -> B -> B) :=
+  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). 
+
+(** Compatibility of a two-argument function with respect to two equalities. *)
+Definition compat_op (f : A -> B -> B) :=
+  forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y').
+
+(** Compatibility of a function upon natural numbers. *)
+Definition compat_nat (f : A -> nat) :=
+  forall x x' : A, eqA x x' -> f x = f x'.
+
+Variable st:Setoid_Theory _ eqB.
+Variable f:A->B->B.
+Variable Comp:compat_op f.
+Variable Ass:transpose f.
+Variable i:B.
+
+Lemma removeA_fold_right_0 :
+  forall s x, ~InA x s ->
+  eqB (fold_right f i s) (fold_right f i (removeA x s)).
+Proof.
+ simple induction s; simpl; intros.
+ refl_st.
+ destruct (eqA_dec x a); simpl; intros.
+ absurd_hyp e; auto.
+ apply Comp; auto. 
+Qed.   
+
+Lemma removeA_fold_right :
+  forall s x, NoDupA s -> InA x s ->
+  eqB (fold_right f i s) (f x (fold_right f i (removeA x s))).
+Proof.
+ simple induction s; simpl.  
+ inversion_clear 2.
+ intros.
+ inversion_clear H0.
+ destruct (eqA_dec x a); simpl; intros.
+ apply Comp; auto. 
+ apply removeA_fold_right_0; auto.
+ swap H2; apply InA_eqA with x; auto.
+ inversion_clear H1. 
+ destruct n; auto.
+ trans_st (f a (f x (fold_right f i (removeA x l)))).
+Qed.   
+
+Lemma fold_right_equal :
+  forall s s', NoDupA s -> NoDupA s' ->
+  eqlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
+Proof.
+ simple induction s.
+ destruct s'; simpl.
+ intros; refl_st; auto.
+ unfold eqlistA; intros.
+ destruct (H1 a).
+ assert (X : InA a nil); auto; inversion X.
+ intros x l Hrec s' N N' E; simpl in *.
+ trans_st (f x (fold_right f i (removeA x s'))).
+ apply Comp; auto.
+ apply Hrec; auto.
+ inversion N; auto.
+ apply removeA_NoDupA; auto; apply eqA_trans.
+ apply removeA_eqlistA; auto.
+ inversion_clear N; auto.
+ sym_st.
+ apply removeA_fold_right; auto.
+ unfold eqlistA in E.
+ rewrite <- E; auto.
+Qed.
+
+Lemma fold_right_add :
+  forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s ->
+  addlistA x s s' -> eqB (fold_right f i s') (f x (fold_right f i s)).
+Proof.   
+ simple induction s'.
+ unfold addlistA; intros.
+ destruct (H2 x); clear H2.
+ assert (X : InA x nil); auto; inversion X.
+ intros x' l' Hrec s x N N' IN EQ; simpl.
+ (* if x=x' *)
+ destruct (eqA_dec x x').
+ apply Comp; auto.
+ apply fold_right_equal; auto.
+ inversion_clear N'; trivial.
+ unfold eqlistA; unfold addlistA in EQ; intros.
+ destruct (EQ x0); clear EQ.
+ split; intros.
+ destruct H; auto.
+ inversion_clear N'.
+ destruct H2; apply InA_eqA with x0; auto.
+ apply eqA_trans with x; auto.
+ assert (X:InA x0 (x' :: l')); auto; inversion_clear X; auto.
+ destruct IN; apply InA_eqA with x0; auto.
+ apply eqA_trans with x'; auto.
+ (* else x<>x' *)   
+ trans_st (f x' (f x (fold_right f i (removeA x' s)))).
+ apply Comp; auto.
+ apply Hrec; auto.
+ apply removeA_NoDupA; auto; apply eqA_trans.
+ inversion_clear N'; auto.
+ rewrite removeA_InA; intuition.
+ apply removeA_add; auto.
+ trans_st (f x (f x' (fold_right f i (removeA x' s)))).
+ apply Comp; auto.
+ sym_st.
+ apply removeA_fold_right; auto.
+ destruct (EQ x'). 
+ destruct H; auto; destruct n; auto.
+Qed.
+
+End Fold.
+
+End Remove.
+
+End Type_with_equality.
+
+Hint Constructors InA.
+Hint Constructors NoDupA. 
+Hint Constructors sort.
+Hint Constructors lelistA.
+
+Section Find. 
+Variable A B : Set. 
+Variable eqA : A -> A -> Prop. 
+Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x.
+Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z.
+Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
+
+Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := 
+ match l with  
+  | nil => None 
+  | (a,b)::l => if f a then Some b else findA f l
+ end.
+
+Lemma findA_NoDupA : 
+ forall l a b, 
+ NoDupA (fun p p' => eqA (fst p) (fst p')) l -> 
+ (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <->
+  findA (fun a' => if eqA_dec a a' then true else false) l = Some b).
+Proof.
+induction l; simpl; intros.
+split; intros; try discriminate.
+inversion H0.
+destruct a as (a',b'); rename a0 into a.
+inversion_clear H.
+split; intros.
+inversion_clear H.
+simpl in *; destruct H2; subst b'.
+destruct (eqA_dec a a'); intuition.
+destruct (eqA_dec a a'); simpl.
+destruct H0.
+generalize e H2 eqA_trans eqA_sym; clear.
+induction l.
+inversion 2.
+inversion_clear 2; intros; auto.
+destruct a0.
+compute in H; destruct H.
+subst b.
+constructor 1; auto.
+simpl.
+apply eqA_trans with a; auto.
+rewrite <- IHl; auto.
+destruct (eqA_dec a a'); simpl in *.
+inversion H; clear H; intros; subst b'; auto.
+constructor 2.
+rewrite IHl; auto.
+Qed.
+
+End Find. 
diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v
index 3c433ba2..7bc6a09d 100755..100644
--- a/theories/Lists/Streams.v
+++ b/theories/Lists/Streams.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Streams.v,v 1.15.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+(*i $Id: Streams.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Set Implicit Arguments.
 
@@ -71,9 +71,8 @@ Qed.
 
 (** Extensional Equality between two streams  *)
 
-CoInductive EqSt : Stream -> Stream -> Prop :=
+CoInductive EqSt (s1 s2: Stream) : Prop :=
     eqst :
-      forall s1 s2:Stream,
         hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2.
 
 (** A coinduction principle *)
@@ -140,12 +139,12 @@ Inductive Exists : Stream -> Prop :=
   | Further : forall x:Stream, ~ P x -> Exists (tl x) -> Exists x.
 i*)
 
-Inductive Exists : Stream -> Prop :=
-  | Here : forall x:Stream, P x -> Exists x
-  | Further : forall x:Stream, Exists (tl x) -> Exists x.
+Inductive Exists ( x: Stream ) : Prop :=
+  | Here : P x -> Exists x
+  | Further : Exists (tl x) -> Exists x.
 
-CoInductive ForAll : Stream -> Prop :=
-    HereAndFurther : forall x:Stream, P x -> ForAll (tl x) -> ForAll x.
+CoInductive ForAll (x: Stream) : Prop :=
+    HereAndFurther : P x -> ForAll (tl x) -> ForAll x.
 
 
 Section Co_Induction_ForAll.
diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v
index fbeb97ce..2bfb70fe 100755..100644
--- a/theories/Lists/TheoryList.v
+++ b/theories/Lists/TheoryList.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: TheoryList.v,v 1.15.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: TheoryList.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
 
 (** Some programs and results about lists following CAML Manual *)
 
@@ -14,7 +14,7 @@ Require Export List.
 Set Implicit Arguments.
 Section Lists.
 
-Variable A : Set.
+Variable A : Type.
 
 (**********************)
 (** The null function *)
@@ -325,7 +325,7 @@ Realizer find.
 *)
 Qed.
 
-Variable B : Set.
+Variable B : Type.
 Variable T : A -> B -> Prop.
 
 Variable TS_dec : forall a:A, {c : B | T a c} + {P a}.
@@ -358,7 +358,7 @@ End Find_sec.
 
 Section Assoc_sec.
 
-Variable B : Set.
+Variable B : Type.
 Fixpoint assoc (a:A) (l:list (A * B)) {struct l} : 
  Exc B :=
   match l with
diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex
index 344bba59..c45f8803 100755
--- a/theories/Lists/intro.tex
+++ b/theories/Lists/intro.tex
@@ -4,21 +4,24 @@ This library includes the following files:
 
 \begin{itemize}
 
-\item {\tt List.v} THIS OLD LIBRARY IS HERE ONLY FOR COMPATIBILITY
-  WITH OLDER VERSIONS OF COQS. THE USER SHOULD USE POLYLIST INSTEAD.
-
-\item {\tt PolyList.v} contains definitions of (polymorphic) lists, 
+\item {\tt List.v} contains definitions of (polymorphic) lists, 
   functions on lists such as head, tail, map, append and prove some
   properties of these functions. Implicit arguments are used in this
-  library, so you should read the Referance Manual about implicit
+  library, so you should read the Reference Manual about implicit
   arguments before using it.
 
+\item {\tt ListSet.v} contains definitions and properties of finite
+  sets, implemented as lists.
+
 \item {\tt TheoryList.v} contains complementary results on lists. Here
-  a more theoric point of view is assumed : one extracts functions
+  a more theoretic point of view is assumed : one extracts functions
   from propositions, rather than defining functions and then prove them.
 
 \item {\tt Streams.v} defines the type of infinite lists (streams). It is a
   coinductive type. Basic facts are stated and proved. The streams are
   also polymorphic.
 
+\item {\tt MonoList.v} THIS OLD LIBRARY IS HERE ONLY FOR COMPATIBILITY
+  WITH OLDER VERSIONS OF COQ. THE USER SHOULD USE {\tt List.v} INSTEAD.
+
 \end{itemize}
diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v
index 0fe8a87d..9eaef07a 100644
--- a/theories/Logic/Berardi.v
+++ b/theories/Logic/Berardi.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Berardi.v,v 1.5.2.2 2004/08/03 17:42:43 herbelin Exp $ i*)
+(*i $Id: Berardi.v 8122 2006-03-04 19:26:40Z herbelin $ i*)
 
 (** This file formalizes Berardi's paradox which says that in
    the calculus of constructions, excluded middle (EM) and axiom of
@@ -92,14 +92,10 @@ End Retracts.
 Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B).
 Proof.
 intros A B.
-elim (EM (retract (pow A) (pow B))).
-intros [f0 g0 e].
-exists f0 g0.
-trivial.
-
-intros hf.
-exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F).
-intros; elim hf; auto.
+destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf].
+  exists f0 g0; trivial.
+  exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; 
+    destruct hf; auto.
 Qed.
 
 
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index 87d8a70e..3b066cfc 100644
--- a/theories/Logic/ChoiceFacts.v
+++ b/theories/Logic/ChoiceFacts.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,9 +7,240 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ChoiceFacts.v,v 1.7.2.2 2004/08/01 09:29:59 herbelin Exp $ i*)
+(*i $Id: ChoiceFacts.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
-(** We show that the functional formulation of the axiom of Choice
+(** Some facts and definitions concerning choice and description in
+       intuitionistic logic.
+
+We investigate the relations between the following choice and
+description principles
+
+- AC_rel  = relational form of the (non extensional) axiom of choice
+            (a "set-theoretic" axiom of choice)
+- AC_fun  = functional form of the (non extensional) axiom of choice
+            (a "type-theoretic" axiom of choice)
+- AC!     = functional relation reification
+            (known as axiom of unique choice in topos theory,
+             sometimes called principle of definite description in 
+             the context of constructive type theory)
+
+- GAC_rel = guarded relational form of the (non extensional) axiom of choice
+- GAC_fun = guarded functional form of the (non extensional) axiom of choice
+- GAC!    = guarded functional relation reification
+
+- OAC_rel = "omniscient" relational form of the (non extensional) axiom of choice
+- OAC_fun = "omniscient" functional form of the (non extensional) axiom of choice
+            (called AC* in Bell [Bell])
+- OAC!
+
+- ID_iota    = intuitionistic definite description
+- ID_epsilon = intuitionistic indefinite description
+
+- D_iota     = (weakly classical) definite description principle
+- D_epsilon  = (weakly classical) indefinite description principle
+
+- PI      = proof irrelevance
+- IGP     = independence of general premises
+            (an unconstrained generalisation of the constructive principle of
+             independence of premises)
+- Drinker = drinker's paradox (small form)
+            (called Ex in Bell [Bell])  
+
+We let also
+
+IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal predicate logic
+IPL_2   = 2nd-order impredicative minimal predicate logic
+IPL^2   = 2nd-order functional minimal predicate logic (with ex. quant.)
+
+Table of contents
+
+1. Definitions
+
+2. IPL_2^2 |- AC_rel + AC! = AC_fun
+
+3. 1. AC_rel + PI -> GAC_rel  and  PL_2 |- AC_rel + IGP -> GAC_rel and GAC_rel = OAC_rel
+
+4. 2. IPL^2 |- AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker
+
+5. Derivability of choice for decidable relations with well-ordered codomain
+
+6. Equivalence of choices on dependent or non dependent functional types
+
+7. Non contradiction of constructive descriptions wrt functional choices
+
+8. Definite description transports classical logic to the computational world
+
+References:
+
+[Bell] John L. Bell, Choice principles in intuitionistic set theory,
+unpublished.
+
+[Bell93] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic
+Type Theories, Mathematical Logic Quarterly, volume 39, 1993.
+
+[Carlstrøm05] Jesper Carlstrøm, Interpreting descriptions in
+intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005.
+*)
+
+Set Implicit Arguments.
+
+Notation Local "'inhabited' A" := A (at level 10, only parsing).
+
+(**********************************************************************)
+(** * Definitions *)
+
+(** Choice, reification and description schemes *)
+
+Section ChoiceSchemes.
+
+Variables A B :Type.
+
+Variables P:A->Prop.
+
+Variables R:A->B->Prop.
+
+(** ** Constructive choice and description *)
+
+(** AC_rel *)
+
+Definition RelationalChoice_on :=
+  forall R:A->B->Prop,
+    (forall x : A, exists y : B, R x y) ->
+    (exists R' : A->B->Prop, subrelation R' R /\ forall x, exists! y, R' x y).
+
+(** AC_fun *)
+
+Definition FunctionalChoice_on :=
+  forall R:A->B->Prop,
+    (forall x : A, exists y : B, R x y) ->
+    (exists f : A->B, forall x : A, R x (f x)).
+
+(** AC! or Functional Relation Reification (known as Axiom of Unique Choice
+    in topos theory; also called principle of definite description *)
+
+Definition FunctionalRelReification_on :=
+  forall R:A->B->Prop,
+    (forall x : A, exists! y : B, R x y) ->
+    (exists f : A->B, forall x : A, R x (f x)).
+
+(** ID_epsilon (constructive version of indefinite description;
+    combined with proof-irrelevance, it may be connected to
+    Carlstrøm's type theory with a constructive indefinite description
+    operator) *)
+
+Definition ConstructiveIndefiniteDescription_on :=
+  forall P:A->Prop,
+    (exists x, P x) -> { x:A | P x }.
+
+(** ID_iota (constructive version of definite description; combined
+    with proof-irrelevance, it may be connected to Carlstrøm's and
+    Stenlund's type theory with a constructive definite description
+    operator) *)
+
+Definition ConstructiveDefiniteDescription_on :=
+  forall P:A->Prop,
+    (exists! x, P x) -> { x:A | P x }.
+
+(** ** Weakly classical choice and description *)
+
+(** GAC_rel *)
+
+Definition GuardedRelationalChoice_on := 
+  forall P : A->Prop, forall R : A->B->Prop,
+    (forall x : A, P x -> exists y : B, R x y) ->
+    (exists R' : A->B->Prop, 
+      subrelation R' R /\ forall x, P x -> exists! y, R' x y).
+
+(** GAC_fun *)
+
+Definition GuardedFunctionalChoice_on := 
+  forall P : A->Prop, forall R : A->B->Prop, 
+    inhabited B ->
+    (forall x : A, P x -> exists y : B, R x y) ->
+    (exists f : A->B, forall x, P x -> R x (f x)).
+
+(** GFR_fun *)
+
+Definition GuardedFunctionalRelReification_on :=
+  forall P : A->Prop, forall R : A->B->Prop, 
+    inhabited B ->
+    (forall x : A, P x -> exists! y : B, R x y) ->
+    (exists f : A->B, forall x : A, P x -> R x (f x)).
+
+(** OAC_rel *)
+
+Definition OmniscientRelationalChoice_on := 
+  forall R : A->B->Prop,
+    exists R' : A->B->Prop, 
+      subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y.
+
+(** OAC_fun *)
+
+Definition OmniscientFunctionalChoice_on := 
+  forall R : A->B->Prop, 
+    inhabited B ->
+    exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x).
+
+(** D_epsilon *)
+
+Definition ClassicalIndefiniteDescription := 
+  forall P:A->Prop,
+    A -> { x:A | (exists x, P x) -> P x }.
+
+(** D_iota *)
+
+Definition ClassicalDefiniteDescription := 
+  forall P:A->Prop,
+    A -> { x:A | (exists! x, P x) -> P x }.
+
+End ChoiceSchemes.
+
+(** Generalized schemes *)
+
+Notation RelationalChoice :=
+  (forall A B, RelationalChoice_on A B).
+Notation FunctionalChoice :=
+  (forall A B, FunctionalChoice_on A B).
+Notation FunctionalChoiceOnInhabitedSet :=
+  (forall A B, inhabited B -> FunctionalChoice_on A B).
+Notation FunctionalRelReification :=
+  (forall A B, FunctionalRelReification_on A B).
+
+Notation GuardedRelationalChoice := 
+  (forall A B, GuardedRelationalChoice_on A B).
+Notation GuardedFunctionalChoice :=
+  (forall A B, GuardedFunctionalChoice_on A B).
+Notation GuardedFunctionalRelReification :=
+  (forall A B, GuardedFunctionalRelReification_on A B).
+
+Notation OmniscientRelationalChoice :=
+  (forall A B, OmniscientRelationalChoice_on A B).
+Notation OmniscientFunctionalChoice :=
+  (forall A B, OmniscientFunctionalChoice_on A B).
+
+Notation ConstructiveDefiniteDescription := 
+  (forall A, ConstructiveDefiniteDescription_on A).
+Notation ConstructiveIndefiniteDescription := 
+  (forall A, ConstructiveIndefiniteDescription_on A).
+
+(** Subclassical schemes *)
+
+Definition ProofIrrelevance :=
+  forall (A:Prop) (a1 a2:A), a1 = a2.
+
+Definition IndependenceOfGeneralPremises :=
+  forall (A:Type) (P:A -> Prop) (Q:Prop), 
+    inhabited A ->
+    (Q -> exists x, P x) -> exists x, Q -> P x.
+
+Definition SmallDrinker'sParadox :=
+  forall (A:Type) (P:A -> Prop), inhabited A ->
+    exists x, (exists x, P x) -> P x.
+
+(**********************************************************************)
+(** * AC_rel + PDP = AC_fun
+
+   We show that the functional formulation of the axiom of Choice
    (usual formulation in type theory) is equivalent to its relational
    formulation (only formulation of set theory) + the axiom of
    (parametric) definite description (aka axiom of unique choice) *)
@@ -17,123 +249,471 @@
    relational formulation) without known inconsistency with classical logic,
    though definite description conflicts with classical logic *)
 
-Definition RelationalChoice :=
-  forall (A B:Type) (R:A -> B -> Prop),
-    (forall x:A,  exists y : B, R x y) ->
-     exists R' : A -> B -> Prop,
-      (forall x:A,
-          exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')).
-
-Definition FunctionalChoice :=
-  forall (A B:Type) (R:A -> B -> Prop),
-    (forall x:A,  exists y : B, R x y) ->
-     exists f : A -> B, (forall x:A, R x (f x)).
+Lemma description_rel_choice_imp_funct_choice :
+  forall A B : Type,
+    FunctionalRelReification_on A B -> RelationalChoice_on A B -> FunctionalChoice_on A B.
+Proof.
+  intros A B Descr RelCh R H.
+  destruct (RelCh R H) as (R',(HR'R,H0)).
+  destruct (Descr R') as (f,Hf).
+  firstorder.
+  exists f; intro x.
+  destruct (H0 x) as (y,(HR'xy,Huniq)).
+  rewrite <- (Huniq (f x) (Hf x)).
+  apply HR'R; assumption.
+Qed.
 
-Definition ParamDefiniteDescription :=
-  forall (A B:Type) (R:A -> B -> Prop),
-    (forall x:A,  exists y : B, R x y /\ (forall y':B, R x y' -> y = y')) ->
-     exists f : A -> B, (forall x:A, R x (f x)).
+Lemma funct_choice_imp_rel_choice : 
+  forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B.
+Proof.
+  intros A B FunCh R H.
+  destruct (FunCh R H) as (f,H0).
+  exists (fun x y => f x = y).
+  split.
+  intros x y Heq; rewrite <- Heq; trivial.
+  intro x; exists (f x); split.
+    reflexivity.
+    trivial.
+Qed.
 
-Lemma description_rel_choice_imp_funct_choice :
- ParamDefiniteDescription -> RelationalChoice -> FunctionalChoice.
-intros Descr RelCh.
-red in |- *; intros A B R H.
-destruct (RelCh A B R H) as [R' H0].
-destruct (Descr A B R') as [f H1].
-intro x.
-elim (H0 x); intros y [H2 [H3 H4]]; exists y; split; [ exact H3 | exact H4 ].
-exists f; intro x.
-elim (H0 x); intros y [H2 [H3 H4]].
-rewrite <- (H4 (f x) (H1 x)).
-exact H2.
-Qed.
-
-Lemma funct_choice_imp_rel_choice : FunctionalChoice -> RelationalChoice.
-intros FunCh.
-red in |- *; intros A B R H.
-destruct (FunCh A B R H) as [f H0].
-exists (fun x y => y = f x).
-intro x; exists (f x); split;
- [ apply H0
- | split; [ reflexivity | intros y H1; symmetry  in |- *; exact H1 ] ].
-Qed.
-
-Lemma funct_choice_imp_description :
- FunctionalChoice -> ParamDefiniteDescription.
-intros FunCh.
-red in |- *; intros A B R H.
-destruct (FunCh A B R) as [f H0].
-(* 1 *)
-intro x.
-elim (H x); intros y [H0 H1].
-exists y; exact H0.
-(* 2 *)
-exists f; exact H0.
+Lemma funct_choice_imp_description : 
+  forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B.
+Proof.
+  intros A B FunCh R H.
+  destruct (FunCh R) as [f H0].
+  (* 1 *)
+  intro x.
+  destruct (H x) as (y,(HRxy,_)).
+  exists y; exact HRxy.
+  (* 2 *)
+  exists f; exact H0.
 Qed.
 
 Theorem FunChoice_Equiv_RelChoice_and_ParamDefinDescr :
- FunctionalChoice <-> RelationalChoice /\ ParamDefiniteDescription.
-split.
-intro H; split;
- [ exact (funct_choice_imp_rel_choice H)
- | exact (funct_choice_imp_description H) ].
-intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H).
+  forall A B, FunctionalChoice_on A B <-> 
+    RelationalChoice_on A B /\ FunctionalRelReification_on A B.
+Proof.
+  intros A B; split.
+  intro H; split;
+    [ exact (funct_choice_imp_rel_choice H)
+      | exact (funct_choice_imp_description H) ].
+  intros [H H0]; exact (description_rel_choice_imp_funct_choice H0 H).
 Qed.
 
+(**********************************************************************)
+(** * Connection between the guarded, non guarded and descriptive choices and *)
+
 (** We show that the guarded relational formulation of the axiom of Choice
    comes from the non guarded formulation in presence either of the
    independance of premises or proof-irrelevance *)
 
-Definition GuardedRelationalChoice :=
-  forall (A B:Type) (P:A -> Prop) (R:A -> B -> Prop),
-    (forall x:A, P x ->  exists y : B, R x y) ->
-     exists R' : A -> B -> Prop,
-      (forall x:A,
-         P x ->
-          exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')).
-
-Definition ProofIrrelevance := forall (A:Prop) (a1 a2:A), a1 = a2.
+(**********************************************************************)
+(** ** AC_rel + PI -> GAC_rel and AC_rel + IGP -> GAC_rel and GAC_rel = OAC_rel *)
 
 Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice :
- RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice.
-Proof.
-intros rel_choice proof_irrel.
-red in |- *; intros A B P R H.
-destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as [R' H0].
-intros [x HPx].
-destruct (H x HPx) as [y HRxy].
-exists y; exact HRxy.
-set (R'' := fun (x:A) (y:B) =>  exists H : P x, R' (existT P x H) y).
-exists R''; intros x HPx.
-destruct (H0 (existT P x HPx)) as [y [HRxy [HR'xy Huniq]]].
-exists y. split.
-  exact HRxy.
-  split.
-    red in |- *; exists HPx; exact HR'xy.
-    intros y' HR''xy'.
-      apply Huniq.
-      unfold R'' in HR''xy'.
-      destruct HR''xy' as [H'Px HR'xy'].
-      rewrite proof_irrel with (a1 := HPx) (a2 := H'Px).
-      exact HR'xy'.
-Qed.
-
-Definition IndependenceOfPremises :=
-  forall (A:Type) (P:A -> Prop) (Q:Prop),
-    (Q ->  exists x : _, P x) ->  exists x : _, Q -> P x.
-
-Lemma rel_choice_indep_of_premises_imp_guarded_rel_choice :
- RelationalChoice -> IndependenceOfPremises -> GuardedRelationalChoice.
-Proof.
-intros RelCh IndPrem.
-red in |- *; intros A B P R H.
-destruct (RelCh A B (fun x y => P x -> R x y)) as [R' H0].
-  intro x. apply IndPrem.
-    apply H.
-  exists R'.
+  RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice.
+Proof.
+  intros rel_choice proof_irrel.
+  red in |- *; intros A B P R H.
+  destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as (R',(HR'R,H0)).
+  intros (x,HPx).
+  destruct (H x HPx) as (y,HRxy).
+  exists y; exact HRxy.
+  set (R'' := fun (x:A) (y:B) => exists H : P x, R' (existT P x H) y).
+  exists R''; split.
+  intros x y (HPx,HR'xy).
+    change x with (projT1 (existT P x HPx)); apply HR'R; exact HR'xy.
   intros x HPx.
-    destruct (H0 x) as [y [H1 H2]].
-    exists y. split. 
-      apply (H1 HPx).
-      exact H2.
+  destruct (H0 (existT P x HPx)) as (y,(HR'xy,Huniq)).
+  exists y; split. exists HPx; exact HR'xy.
+  intros y' (H'Px,HR'xy').
+    apply Huniq.
+    rewrite proof_irrel with (a1 := HPx) (a2 := H'Px); exact HR'xy'.
+Qed.
+
+Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice :
+  forall A B, inhabited B -> RelationalChoice_on A B -> 
+    IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B.
+Proof.
+  intros A B Inh AC_rel IndPrem P R H.
+  destruct (AC_rel (fun x y => P x -> R x y)) as (R',(HR'R,H0)).
+  intro x. apply IndPrem. exact Inh. intro Hx. 
+  apply H; assumption.
+  exists (fun x y => P x /\ R' x y).
+  firstorder.
+Qed.
+
+Lemma guarded_rel_choice_imp_rel_choice :
+  forall A B, GuardedRelationalChoice_on A B -> RelationalChoice_on A B.
+Proof.
+  intros A B GAC_rel R H.
+  destruct (GAC_rel (fun _ => True) R) as (R',(HR'R,H0)).
+  firstorder.
+  exists R'; firstorder.
+Qed.
+
+(** OAC_rel = GAC_rel *)
+
+Lemma guarded_iff_omniscient_rel_choice :
+  GuardedRelationalChoice <-> OmniscientRelationalChoice.
+Proof.
+  split.
+  intros GAC_rel A B R.
+  apply (GAC_rel A B (fun x => exists y, R x y) R); auto.
+  intros OAC_rel A B P R H.
+  destruct (OAC_rel A B R) as (f,Hf); exists f; firstorder.
+Qed.
+
+(**********************************************************************)
+(** ** AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker *)
+
+(** AC_fun + IGP = GAC_fun *)
+ 
+Lemma guarded_fun_choice_imp_indep_of_general_premises :
+  GuardedFunctionalChoice -> IndependenceOfGeneralPremises.
+Proof.
+  intros GAC_fun A P Q Inh H.
+  destruct (GAC_fun unit A (fun _ => Q) (fun _ => P) Inh) as (f,Hf).
+  tauto.
+  exists (f tt); auto.
+Qed.
+
+Lemma guarded_fun_choice_imp_fun_choice :
+  GuardedFunctionalChoice -> FunctionalChoiceOnInhabitedSet.
+Proof.
+  intros GAC_fun A B Inh R H.
+  destruct (GAC_fun A B (fun _ => True) R Inh) as (f,Hf).
+  firstorder.
+  exists f; auto.
+Qed.
+
+Lemma fun_choice_and_indep_general_prem_imp_guarded_fun_choice :
+  FunctionalChoiceOnInhabitedSet -> IndependenceOfGeneralPremises
+  -> GuardedFunctionalChoice.
+Proof.
+  intros AC_fun IndPrem A B P R Inh H.
+  apply (AC_fun A B Inh (fun x y => P x -> R x y)).
+  intro x; apply IndPrem; eauto.
+Qed.
+
+(** AC_fun + Drinker = OAC_fun *)
+
+(** This was already observed by Bell [Bell] *)
+
+Lemma omniscient_fun_choice_imp_small_drinker :
+  OmniscientFunctionalChoice -> SmallDrinker'sParadox.
+Proof.
+  intros OAC_fun A P Inh.
+  destruct (OAC_fun unit A (fun _ => P)) as (f,Hf).
+  auto.
+  exists (f tt); firstorder.
+Qed.
+
+Lemma omniscient_fun_choice_imp_fun_choice :
+  OmniscientFunctionalChoice -> FunctionalChoiceOnInhabitedSet.
+Proof.
+  intros OAC_fun A B Inh R H.
+  destruct (OAC_fun A B R Inh) as (f,Hf).
+  exists f; firstorder.
+Qed.
+
+Lemma fun_choice_and_small_drinker_imp_omniscient_fun_choice :
+  FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox 
+  -> OmniscientFunctionalChoice.
+Proof.
+  intros AC_fun Drinker A B R Inh.
+  destruct (AC_fun A B Inh (fun x y => (exists y, R x y) -> R x y)) as (f,Hf).
+  intro x; apply (Drinker B (R x) Inh).
+  exists f; assumption.
+Qed.
+
+(** OAC_fun = GAC_fun *)
+
+(** This is derivable from the intuitionistic equivalence between IGP and Drinker
+but we give a direct proof *)
+
+Lemma guarded_iff_omniscient_fun_choice :
+  GuardedFunctionalChoice <-> OmniscientFunctionalChoice.
+Proof.
+  split.
+  intros GAC_fun A B R Inh.
+  apply (GAC_fun A B (fun x => exists y, R x y) R); auto.
+  intros OAC_fun A B P R Inh H.
+  destruct (OAC_fun A B R Inh) as (f,Hf).
+  exists f; firstorder.
+Qed.
+
+(**********************************************************************)
+(** * Derivability of choice for decidable relations with well-ordered codomain *)
+
+(** Countable codomains, such as [nat], can be equipped with a
+    well-order, which implies the existence of a least element on
+    inhabited decidable subsets. As a consequence, the relational form of
+    the axiom of choice is derivable on [nat] for decidable relations.
+
+    We show instead that functional relation reification and the
+    functional form of the axiom of choice are equivalent on decidable
+    relation with [nat] as codomain 
+*)
+
+Require Import Wf_nat.
+Require Import Compare_dec.
+Require Import Decidable.
+Require Import Arith.
+
+Definition has_unique_least_element (A:Type) (R:A->A->Prop) (P:A->Prop) :=
+  exists! x, P x /\ forall x', P x' -> R x x'.
+
+Lemma dec_inh_nat_subset_has_unique_least_element :
+  forall P:nat->Prop, (forall n, P n \/ ~ P n) ->
+    (exists n, P n) -> has_unique_least_element le P.
+Proof.
+  intros P Pdec (n0,HPn0).
+  assert
+    (forall n, (exists n', n'<n /\ P n' /\ forall n'', P n'' -> n'<=n'')
+      \/(forall n', P n' -> n<=n')).
+  induction n.
+  right.
+  intros n' Hn'.
+  apply le_O_n.
+  destruct IHn.
+  left; destruct H as (n', (Hlt', HPn')).
+  exists n'; split.
+  apply lt_S; assumption.
+  assumption.
+  destruct (Pdec n).
+  left; exists n; split.
+  apply lt_n_Sn.
+  split; assumption.
+  right.
+  intros n' Hltn'.
+  destruct (le_lt_eq_dec n n') as [Hltn|Heqn].
+  apply H; assumption.
+  assumption.
+  destruct H0.
+  rewrite Heqn; assumption.
+  destruct (H n0) as [(n,(Hltn,(Hmin,Huniqn)))|]; [exists n | exists n0];
+    repeat split;
+      assumption || intros n' (HPn',Hminn'); apply le_antisym; auto.
+Qed.
+
+Definition FunctionalChoice_on_rel (A B:Type) (R:A->B->Prop) :=
+  (forall x:A, exists y : B, R x y) ->
+  exists f : A -> B, (forall x:A, R x (f x)).
+
+Lemma classical_denumerable_description_imp_fun_choice : 
+  forall A:Type, 
+    FunctionalRelReification_on A nat -> 
+    forall R:A->nat->Prop, 
+      (forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R.
+Proof.
+  intros A Descr.
+  red in |- *; intros R Rdec H.
+  set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y').
+  destruct (Descr R') as (f,Hf).
+  intro x.
+  apply (dec_inh_nat_subset_has_unique_least_element (R x)). 
+    apply Rdec.
+    apply (H x).
+    exists f.
+    intros x.
+    destruct (Hf x) as (Hfx,_).
+    assumption.
+Qed.
+
+(**********************************************************************)
+(** * Choice on dependent and non dependent function types are equivalent *)
+
+(** ** Choice on dependent and non dependent function types are equivalent *)
+
+Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) :=
+  forall R:forall x:A, B x -> Prop,
+    (forall x:A, exists y : B x, R x y) ->
+    (exists f : (forall x:A, B x), forall x:A, R x (f x)).
+
+Notation DependentFunctionalChoice := 
+  (forall A (B:A->Type), DependentFunctionalChoice_on B).
+
+(** The easy part *)
+
+Theorem dep_non_dep_functional_choice : 
+  DependentFunctionalChoice -> FunctionalChoice.
+Proof.
+  intros AC_depfun A B R H.
+  destruct (AC_depfun A (fun _ => B) R H) as (f,Hf).
+  exists f; trivial.
+Qed.
+
+(** Deriving choice on product types requires some computation on
+    singleton propositional types, so we need computational
+    conjunction projections and dependent elimination of conjunction
+    and equality *)
+
+Scheme and_indd := Induction for and Sort Prop.
+Scheme eq_indd := Induction for eq Sort Prop.
+
+Definition proj1_inf (A B:Prop) (p : A/\B) :=
+  let (a,b) := p in a.
+
+Theorem non_dep_dep_functional_choice : 
+  FunctionalChoice -> DependentFunctionalChoice.
+Proof.
+  intros AC_fun A B R H.
+  pose (B' := { x:A & B x }). 
+  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). 
+  destruct (AC_fun A B' R') as (f,Hf).
+  intros x. destruct (H x) as (y,Hy).
+  exists (existT (fun x => B x) x y). split; trivial.
+  exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))).
+  intro x; destruct (Hf x) as (Heq,HR) using and_indd.
+  destruct (f x); simpl in *.
+  destruct Heq using eq_indd; trivial.
 Qed.
+
+(** ** Reification of dependent and non dependent functional relation  are equivalent *)
+
+Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) :=
+  forall (R:forall x:A, B x -> Prop),
+    (forall x:A, exists! y : B x, R x y) ->
+    (exists f : (forall x:A, B x), forall x:A, R x (f x)).
+
+Notation DependentFunctionalRelReification :=
+  (forall A (B:A->Type), DependentFunctionalRelReification_on B).
+
+(** The easy part *)
+
+Theorem dep_non_dep_functional_rel_reification : 
+  DependentFunctionalRelReification -> FunctionalRelReification.
+Proof.
+  intros DepFunReify A B R H.
+  destruct (DepFunReify A (fun _ => B) R H) as (f,Hf).
+  exists f; trivial.
+Qed.
+
+(** Deriving choice on product types requires some computation on
+    singleton propositional types, so we need computational
+    conjunction projections and dependent elimination of conjunction
+    and equality *)
+
+Theorem non_dep_dep_functional_rel_reification : 
+  FunctionalRelReification -> DependentFunctionalRelReification.
+Proof.
+  intros AC_fun A B R H.
+  pose (B' := { x:A & B x }). 
+  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). 
+  destruct (AC_fun A B' R') as (f,Hf).
+  intros x. destruct (H x) as (y,(Hy,Huni)).
+  exists (existT (fun x => B x) x y). repeat split; trivial.
+  intros (x',y') (Heqx',Hy').
+  simpl in *.
+  destruct Heqx'.
+  rewrite (Huni y'); trivial.
+  exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_inf (Hf x))).
+  intro x; destruct (Hf x) as (Heq,HR) using and_indd.
+  destruct (f x); simpl in *.
+  destruct Heq using eq_indd; trivial.
+Qed.
+
+(**********************************************************************)
+(** * Non contradiction of constructive descriptions wrt functional axioms of choice *)
+
+(** ** Non contradiction of indefinite description *)
+
+Lemma relative_non_contradiction_of_indefinite_desc :
+  (ConstructiveIndefiniteDescription -> False)
+  -> (FunctionalChoice -> False).
+Proof.
+  intros H AC_fun.
+  assert (AC_depfun := non_dep_dep_functional_choice AC_fun).
+  pose (A0 := { A:Type & { P:A->Prop & exists x, P x }}).
+  pose (B0 := fun x:A0 => projT1 x).
+  pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y).
+  pose (H0 := fun x:A0 => projT2 (projT2 x)).
+  destruct (AC_depfun A0 B0 R0 H0) as (f, Hf).
+  apply H.
+  intros A P H'.
+  exists (f (existT (fun _ => sigT _) A
+    (existT (fun P => exists x, P x) P H'))).
+  pose (Hf' := 
+    Hf (existT (fun _ => sigT _) A
+      (existT (fun P => exists x, P x) P H'))).
+  assumption.
+Qed.
+
+Lemma constructive_indefinite_descr_fun_choice :
+  ConstructiveIndefiniteDescription -> FunctionalChoice.
+Proof.
+  intros IndefDescr A B R H.
+  exists (fun x => proj1_sig (IndefDescr B (R x) (H x))).
+  intro x.
+  apply (proj2_sig (IndefDescr B (R x) (H x))).
+Qed.
+
+(** ** Non contradiction of definite description *)
+
+Lemma relative_non_contradiction_of_definite_descr :
+  (ConstructiveDefiniteDescription -> False)
+  -> (FunctionalRelReification -> False).
+Proof.
+  intros H FunReify.
+  assert (DepFunReify := non_dep_dep_functional_rel_reification FunReify).
+  pose (A0 := { A:Type & { P:A->Prop & exists! x, P x }}).
+  pose (B0 := fun x:A0 => projT1 x).
+  pose (R0 := fun x:A0 => fun y:B0 x => projT1 (projT2 x) y).
+  pose (H0 := fun x:A0 => projT2 (projT2 x)).
+  destruct (DepFunReify A0 B0 R0 H0) as (f, Hf).
+  apply H.
+  intros A P H'.
+  exists (f (existT (fun _ => sigT _) A
+    (existT (fun P => exists! x, P x) P H'))).
+  pose (Hf' := 
+    Hf (existT (fun _ => sigT _) A
+      (existT (fun P => exists! x, P x) P H'))).
+  assumption.
+Qed.
+
+Lemma constructive_definite_descr_fun_reification :
+  ConstructiveDefiniteDescription -> FunctionalRelReification.
+Proof.
+  intros DefDescr A B R H.
+  exists (fun x => proj1_sig (DefDescr B (R x) (H x))).
+  intro x.
+  apply (proj2_sig (DefDescr B (R x) (H x))).
+Qed.
+
+(**********************************************************************)
+(** * Excluded-middle + definite description => computational excluded-middle *)
+
+(** The idea for the following proof comes from [ChicliPottierSimpson02] *)
+
+(** Classical logic and axiom of unique choice (i.e. functional
+    relation reification), as shown in [ChicliPottierSimpson02],
+    implies the double-negation of excluded-middle in [Set] (which is
+    incompatible with the impredicativity of [Set]).
+
+    We adapt the proof to show that constructive definite description
+    transports excluded-middle from [Prop] to [Set].
+
+    [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos
+    Simpson, Mathematical Quotients and Quotient Types in Coq,
+    Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646,
+    Springer Verlag.  *)
+
+Require Import Setoid.
+
+Theorem constructive_definite_descr_excluded_middle :
+  ConstructiveDefiniteDescription ->
+  (forall P:Prop, P \/ ~ P) -> (forall P:Prop, {P} + {~ P}).
+Proof.
+  intros Descr EM P.
+  pose (select := fun b:bool => if b then P else ~P).
+  assert { b:bool | select b } as ([|],HP).
+  apply Descr.
+  rewrite <- unique_existence; split.
+  destruct (EM P).
+  exists true; trivial.
+  exists false; trivial.
+  intros [|] [|] H1 H2; simpl in *; reflexivity || contradiction.
+  left; trivial.
+  right; trivial.
+Qed.  
diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v
index 044cee17..523c9245 100755..100644
--- a/theories/Logic/Classical.v
+++ b/theories/Logic/Classical.v
@@ -6,9 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: Classical.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 (** Classical Logic *)
 
 Require Export Classical_Prop.
-Require Export Classical_Pred_Type.
\ No newline at end of file
+Require Export Classical_Pred_Type.
+
diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v
index 51f758e2..bb8186ae 100644
--- a/theories/Logic/ClassicalChoice.v
+++ b/theories/Logic/ClassicalChoice.v
@@ -6,27 +6,40 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalChoice.v,v 1.4.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: ClassicalChoice.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
 
-(** This file provides classical logic and functional choice *)
+(** This file provides classical logic, and functional choice *)
 
-(** This file extends ClassicalDescription.v with the axiom of choice.
-    As ClassicalDescription.v, it implies the double-negation of
-    excluded-middle in Set and implies a strongly classical
-    world. Especially it conflicts with impredicativity of Set, knowing
-    that true<>false in Set.
-*)
+(** This file extends ClassicalUniqueChoice.v with the axiom of choice.
+    As ClassicalUniqueChoice.v, it implies the double-negation of
+    excluded-middle in [Set] and leads to a classical world populated
+    with non computable functions. Especially it conflicts with the
+    impredicativity of [Set], knowing that [true<>false] in [Set].  *)
 
-Require Export ClassicalDescription.
+Require Export ClassicalUniqueChoice.
 Require Export RelationalChoice.
 Require Import ChoiceFacts.
 
+Set Implicit Arguments.
+
+Definition subset (U:Type) (P Q:U->Prop) : Prop := forall x, P x -> Q x.
+
+Theorem singleton_choice :
+  forall (A : Type) (P : A->Prop),
+  (exists x : A, P x) -> exists P' : A->Prop, subset P' P /\ exists! x, P' x.
+Proof.
+intros A P H.
+destruct (relational_choice unit A (fun _ => P) (fun _ => H)) as (R',(Hsub,HR')).
+exists (R' tt); firstorder.
+Qed.
+
 Theorem choice :
- forall (A B:Type) (R:A -> B -> Prop),
-   (forall x:A,  exists y : B, R x y) ->
-    exists f : A -> B, (forall x:A, R x (f x)).
+ forall (A B : Type) (R : A->B->Prop),
+   (forall x : A, exists y : B, R x y) ->
+    exists f : A->B, (forall x : A, R x (f x)).
 Proof.
+intros A B.
 apply description_rel_choice_imp_funct_choice.
-exact description.
-exact relational_choice.
-Qed.
\ No newline at end of file
+exact (unique_choice A B).
+exact (relational_choice A B).
+Qed.
diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v
index 6602cd73..1f1c34bf 100644
--- a/theories/Logic/ClassicalDescription.v
+++ b/theories/Logic/ClassicalDescription.v
@@ -6,73 +6,83 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalDescription.v,v 1.7.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: ClassicalDescription.v 9514 2007-01-22 14:58:50Z herbelin $ i*)
 
 (** This file provides classical logic and definite description *)
 
-(** Classical logic and definite description, as shown in [1],
-    implies the double-negation of excluded-middle in Set, hence it
-    implies a strongly classical world. Especially it conflicts with
-    impredicativity of Set, knowing that true<>false in Set.
+(** Classical definite description operator (i.e. iota) implies
+    excluded-middle in [Set] and leads to a classical world populated
+    with non computable functions. It conflicts with the
+    impredicativity of [Set] *)
 
-    [1] Laurent Chicli, Loïc Pottier, Carlos Simpson, Mathematical
-    Quotients and Quotient Types in Coq, Proceedings of TYPES 2002,
-    Lecture Notes in Computer Science 2646, Springer Verlag.
-*)
+Set Implicit Arguments.
 
 Require Export Classical.
+Require Import ChoiceFacts.
 
-Axiom
-  dependent_description :
-    forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
-      (forall x:A,
-          exists y : B x, R x y /\ (forall y':B x, R x y' -> y = y')) ->
-       exists f : forall x:A, B x, (forall x:A, R x (f x)).
+Notation Local "'inhabited' A" := A (at level 200, only parsing).
 
-(** Principle of definite descriptions (aka axiom of unique choice) *)
+Axiom constructive_definite_description :
+  forall (A : Type) (P : A->Prop), (exists! x : A, P x) -> { x : A | P x }.
 
-Theorem description :
- forall (A B:Type) (R:A -> B -> Prop),
-   (forall x:A,  exists y : B, R x y /\ (forall y':B, R x y' -> y = y')) ->
-    exists f : A -> B, (forall x:A, R x (f x)).
+(** The idea for the following proof comes from [ChicliPottierSimpson02] *)
+
+Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
 Proof.
-intros A B.
-apply (dependent_description A (fun _ => B)).
+apply 
+  (constructive_definite_descr_excluded_middle 
+   constructive_definite_description classic).
 Qed.
 
-(** The followig proof comes from [1] *)
+Theorem classical_definite_description : 
+  forall (A : Type) (P : A->Prop), inhabited A ->
+  { x : A | (exists! x : A, P x) -> P x }.
+Proof.
+intros A P i.
+destruct (excluded_middle_informative (exists! x, P x)) as [Hex|HnonP].
+  apply constructive_definite_description with (P:= fun x => (exists! x : A, P x) -> P x).
+  destruct Hex as (x,(Hx,Huni)).
+  exists x; split.
+    intros _; exact Hx.
+    firstorder.
+exists i; tauto.
+Qed.
+
+(** Church's iota operator *)
+
+Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A
+  := proj1_sig (classical_definite_description P i).
+
+Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : 
+  (exists! x:A, P x) -> P (iota i P)
+  := proj2_sig (classical_definite_description P i).
 
-Theorem classic_set : ((forall P:Prop, {P} + {~ P}) -> False) -> False.
+(** Axiom of unique "choice" (functional reification of functional relations) *)
+Theorem dependent_unique_choice :
+  forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
+    (forall x:A, exists! y : B x, R x y) ->
+    (exists f : (forall x:A, B x), forall x:A, R x (f x)).
 Proof.
-intro HnotEM.
-set (R := fun A b => A /\ true = b \/ ~ A /\ false = b).
-assert (H :  exists f : Prop -> bool, (forall A:Prop, R A (f A))).
-apply description.
-intro A.
-destruct (classic A) as [Ha| Hnota].
-  exists true; split.
-    left; split; [ assumption | reflexivity ].
-    intros y [[_ Hy]| [Hna _]].
-      assumption.
-      contradiction.
-  exists false; split.
-    right; split; [ assumption | reflexivity ].
-    intros y [[Ha _]| [_ Hy]].
-      contradiction.
-      assumption.
-destruct H as [f Hf].
-apply HnotEM.
-intro P.
-assert (HfP := Hf P).
-(* Elimination from Hf to Set is not allowed but from f to Set yes ! *)
-destruct (f P).
-  left.
-  destruct HfP as [[Ha _]| [_ Hfalse]].
-    assumption.
-    discriminate.
-  right.
-  destruct HfP as [[_ Hfalse]| [Hna _]].
-    discriminate.
-    assumption.
+intros A B R H.
+assert (Hexuni:forall x, exists! y, R x y).
+  intro x. apply H.
+exists (fun x => proj1_sig (constructive_definite_description (R x) (Hexuni x))).
+intro x.
+apply (proj2_sig (constructive_definite_description (R x) (Hexuni x))).
 Qed.
- 
+
+Theorem unique_choice :
+  forall (A B:Type) (R:A -> B -> Prop),
+    (forall x:A,  exists! y : B, R x y) ->
+    (exists f : A -> B, forall x:A, R x (f x)).
+Proof.
+intros A B.
+apply dependent_unique_choice with (B:=fun _:A => B).
+Qed.
+
+(** Compatibility lemmas *)
+
+Unset Implicit Arguments.
+
+Definition dependent_description := dependent_unique_choice.
+Definition description := unique_choice.
diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v
new file mode 100644
index 00000000..6d0a9c77
--- /dev/null
+++ b/theories/Logic/ClassicalEpsilon.v
@@ -0,0 +1,102 @@
+(************************************************************************)
+(*  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: ClassicalEpsilon.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+(** This file provides classical logic and indefinite description
+    (Hilbert's epsilon operator) *)
+
+(** Classical epsilon's operator (i.e. indefinite description) implies
+    excluded-middle in [Set] and leads to a classical world populated
+    with non computable functions. It conflicts with the
+    impredicativity of [Set] *)
+
+Require Export Classical.
+Require Import ChoiceFacts.
+
+Set Implicit Arguments.
+
+Axiom constructive_indefinite_description :
+  forall (A : Type) (P : A->Prop), 
+    (exists x, P x) -> { x : A | P x }.
+
+Lemma constructive_definite_description :
+  forall (A : Type) (P : A->Prop), 
+    (exists! x, P x) -> { x : A | P x }.
+Proof.
+  intros; apply constructive_indefinite_description; firstorder.
+Qed.
+
+Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
+Proof.
+  apply 
+    (constructive_definite_descr_excluded_middle 
+      constructive_definite_description classic).
+Qed.
+
+Theorem classical_indefinite_description : 
+  forall (A : Type) (P : A->Prop), inhabited A ->
+    { x : A | (exists x, P x) -> P x }.
+Proof.
+  intros A P i.
+  destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP].
+  apply constructive_indefinite_description 
+    with (P:= fun x => (exists x, P x) -> P x).
+  destruct Hex as (x,Hx).
+    exists x; intros _; exact Hx.
+  assert {x : A | True} as (a,_).
+    apply constructive_indefinite_description with (P := fun _ : A => True).
+    destruct i as (a); firstorder.
+  firstorder.
+Defined.
+
+(** Hilbert's epsilon operator *)
+
+Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
+  := proj1_sig (classical_indefinite_description P i).
+
+Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : 
+  (exists x, P x) -> P (epsilon i P)
+  := proj2_sig (classical_indefinite_description P i).
+
+(** Open question: is classical_indefinite_description constructively
+    provable from [relational_choice] and
+    [constructive_definite_description] (at least, using the fact that
+    [functional_choice] is provable from [relational_choice] and
+    [unique_choice], we know that the double negation of
+    [classical_indefinite_description] is provable (see
+    [relative_non_contradiction_of_indefinite_desc]). *)
+
+(** A proof that if [P] is inhabited, [epsilon a P] does not depend on
+    the actual proof that the domain of [P] is inhabited
+    (proof idea kindly provided by Pierre Castéran) *)
+
+Lemma epsilon_inh_irrelevance : 
+   forall (A:Type) (i j : inhabited A) (P:A->Prop),
+   (exists x, P x) -> epsilon i P = epsilon j P.
+Proof.
+ intros.
+ unfold epsilon, classical_indefinite_description.
+ destruct (excluded_middle_informative (exists x : A, P x)) as [|[]]; trivial.
+Qed.
+
+Opaque epsilon.
+
+(** *** Weaker lemmas (compatibility lemmas) *)
+
+Theorem choice :
+  forall (A B : Type) (R : A->B->Prop),
+    (forall x : A, exists y : B, R x y) ->
+    (exists f : A->B, forall x : A, R x (f x)).
+Proof.
+  intros A B R H.
+  exists (fun x => proj1_sig (constructive_indefinite_description _ (H x))).
+  intro x.
+  apply (proj2_sig (constructive_indefinite_description _ (H x))).
+Qed.
+
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
index cb14fb0e..dd911db6 100644
--- a/theories/Logic/ClassicalFacts.v
+++ b/theories/Logic/ClassicalFacts.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,58 +7,96 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ClassicalFacts.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: ClassicalFacts.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
-(** Some facts and definitions about classical logic *)
+(** Some facts and definitions about classical logic
 
-(** [prop_degeneracy] (also referred as propositional completeness) *)
-(*  asserts (up to consistency) that there are only two distinct formulas *)
+Table of contents:
+
+1. Propositional degeneracy = excluded-middle + propositional extensionality
+
+2. Classical logic and proof-irrelevance
+
+2.1. CC |- prop. ext. + A inhabited -> (A = A->A) -> A has fixpoint
+
+2.2. CC |- prop. ext. + dep elim on bool -> proof-irrelevance
+
+2.3. CIC |- prop. ext. -> proof-irrelevance
+
+2.4. CC |- excluded-middle + dep elim on bool -> proof-irrelevance
+
+2.5. CIC |- excluded-middle -> proof-irrelevance
+
+3. Weak classical axioms
+
+3.1. Weak excluded middle
+
+3.2. Gödel-Dummet axiom and right distributivity of implication over
+      disjunction
+
+3 3. Independence of general premises and drinker's paradox
+
+*)
+
+(************************************************************************)
+(** * Prop degeneracy = excluded-middle + prop extensionality      *)
+(**
+ i.e.        [(forall A, A=True \/ A=False)
+                         <->
+       (forall A, A\/~A) /\ (forall A B, (A<->B) -> A=B)]
+*)
+
+(** [prop_degeneracy] (also referred to as propositional completeness)
+    asserts (up to consistency) that there are only two distinct formulas *)
 Definition prop_degeneracy := forall A:Prop, A = True \/ A = False.
 
-(** [prop_extensionality] asserts equivalent formulas are equal *)
+(** [prop_extensionality] asserts that equivalent formulas are equal *)
 Definition prop_extensionality := forall A B:Prop, (A <-> B) -> A = B.
 
-(** [excluded_middle] asserts we can reason by case on the truth *)
-(*  or falsity of any formula *)
+(** [excluded_middle] asserts that we can reason by case on the truth
+    or falsity of any formula *)
 Definition excluded_middle := forall A:Prop, A \/ ~ A.
 
-(** [proof_irrelevance] asserts equality of all proofs of a given formula *)
-Definition proof_irrelevance := forall (A:Prop) (a1 a2:A), a1 = a2.
-
 (** We show [prop_degeneracy <-> (prop_extensionality /\ excluded_middle)] *)
 
 Lemma prop_degen_ext : prop_degeneracy -> prop_extensionality.
 Proof.
-intros H A B [Hab Hba].
-destruct (H A); destruct (H B).
-  rewrite H1; exact H0.
-  absurd B.
-    rewrite H1; exact (fun H => H).
-    apply Hab; rewrite H0; exact I.
-  absurd A.
-    rewrite H0; exact (fun H => H).
-    apply Hba; rewrite H1; exact I.
-  rewrite H1; exact H0.
+  intros H A B [Hab Hba].
+  destruct (H A); destruct (H B).
+    rewrite H1; exact H0.
+    absurd B.
+      rewrite H1; exact (fun H => H).
+      apply Hab; rewrite H0; exact I.
+    absurd A.
+      rewrite H0; exact (fun H => H).
+      apply Hba; rewrite H1; exact I.
+    rewrite H1; exact H0.
 Qed.
 
 Lemma prop_degen_em : prop_degeneracy -> excluded_middle.
 Proof.
-intros H A.
-destruct (H A).
-  left; rewrite H0; exact I.
-  right; rewrite H0; exact (fun x => x).
+  intros H A.
+  destruct (H A).
+    left; rewrite H0; exact I.
+    right; rewrite H0; exact (fun x => x).
 Qed.
 
 Lemma prop_ext_em_degen :
- prop_extensionality -> excluded_middle -> prop_degeneracy.
+  prop_extensionality -> excluded_middle -> prop_degeneracy.
 Proof.
-intros Ext EM A.
-destruct (EM A).
-  left; apply (Ext A True); split;
-   [ exact (fun _ => I) | exact (fun _ => H) ].
-  right; apply (Ext A False); split; [ exact H | apply False_ind ].
+  intros Ext EM A.
+  destruct (EM A).
+    left; apply (Ext A True); split;
+     [ exact (fun _ => I) | exact (fun _ => H) ].
+    right; apply (Ext A False); split; [ exact H | apply False_ind ].
 Qed.
 
+(************************************************************************)
+(** * Classical logic and proof-irrelevance *)
+
+(************************************************************************)
+(** ** CC |- prop ext + A inhabited -> (A = A->A) -> A has fixpoint *)
+
 (** We successively show that:
 
    [prop_extensionality]
@@ -71,88 +110,95 @@ Qed.
 Definition inhabited (A:Prop) := A.
 
 Lemma prop_ext_A_eq_A_imp_A :
- prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A.
+  prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A.
 Proof.
-intros Ext A a.
-apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ].
+  intros Ext A a.
+  apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ].
 Qed.
 
 Record retract (A B:Prop) : Prop := 
   {f1 : A -> B; f2 : B -> A; f1_o_f2 : forall x:B, f1 (f2 x) = x}.
 
 Lemma prop_ext_retract_A_A_imp_A :
- prop_extensionality -> forall A:Prop, inhabited A -> retract A (A -> A).
+  prop_extensionality -> forall A:Prop, inhabited A -> retract A (A -> A).
 Proof.
-intros Ext A a.
-rewrite (prop_ext_A_eq_A_imp_A Ext A a).
-exists (fun x:A => x) (fun x:A => x).
-reflexivity.
+  intros Ext A a.
+  rewrite (prop_ext_A_eq_A_imp_A Ext A a).
+  exists (fun x:A => x) (fun x:A => x).
+  reflexivity.
 Qed.
 
 Record has_fixpoint (A:Prop) : Prop := 
   {F : (A -> A) -> A; Fix : forall f:A -> A, F f = f (F f)}.
 
 Lemma ext_prop_fixpoint :
- prop_extensionality -> forall A:Prop, inhabited A -> has_fixpoint A.
+  prop_extensionality -> forall A:Prop, inhabited A -> has_fixpoint A.
 Proof.
-intros Ext A a.
-case (prop_ext_retract_A_A_imp_A Ext A a); intros g1 g2 g1_o_g2.
-exists (fun f => (fun x:A => f (g1 x x)) (g2 (fun x => f (g1 x x)))).
-intro f.
-pattern (g1 (g2 (fun x:A => f (g1 x x)))) at 1 in |- *.
-rewrite (g1_o_g2 (fun x:A => f (g1 x x))).
-reflexivity.
+  intros Ext A a.
+  case (prop_ext_retract_A_A_imp_A Ext A a); intros g1 g2 g1_o_g2.
+  exists (fun f => (fun x:A => f (g1 x x)) (g2 (fun x => f (g1 x x)))).
+  intro f.
+  pattern (g1 (g2 (fun x:A => f (g1 x x)))) at 1 in |- *.
+  rewrite (g1_o_g2 (fun x:A => f (g1 x x))).
+  reflexivity.
 Qed.
 
-(** Assume we have booleans with the property that there is at most 2
+(************************************************************************)
+(** ** CC |- prop_ext /\ dep elim on bool -> proof-irrelevance  *)
+
+(** [proof_irrelevance] asserts equality of all proofs of a given formula *)
+Definition proof_irrelevance := forall (A:Prop) (a1 a2:A), a1 = a2.
+
+(** Assume that we have booleans with the property that there is at most 2
     booleans (which is equivalent to dependent case analysis). Consider
     the fixpoint of the negation function: it is either true or false by
     dependent case analysis, but also the opposite by fixpoint. Hence
     proof-irrelevance.
 
-    We then map bool proof-irrelevance to all propositions.
+    We then map equality of boolean proofs to proof irrelevance in all
+    propositions.
 *)
 
 Section Proof_irrelevance_gen.
 
-Variable bool : Prop.
-Variable true : bool.
-Variable false : bool.
-Hypothesis bool_elim : forall C:Prop, C -> C -> bool -> C.
-Hypothesis
-  bool_elim_redl : forall (C:Prop) (c1 c2:C), c1 = bool_elim C c1 c2 true.
-Hypothesis
-  bool_elim_redr : forall (C:Prop) (c1 c2:C), c2 = bool_elim C c1 c2 false.
-Let bool_dep_induction :=
+  Variable bool : Prop.
+  Variable true : bool.
+  Variable false : bool.
+  Hypothesis bool_elim : forall C:Prop, C -> C -> bool -> C.
+  Hypothesis
+    bool_elim_redl : forall (C:Prop) (c1 c2:C), c1 = bool_elim C c1 c2 true.
+  Hypothesis
+    bool_elim_redr : forall (C:Prop) (c1 c2:C), c2 = bool_elim C c1 c2 false.
+  Let bool_dep_induction :=
   forall P:bool -> Prop, P true -> P false -> forall b:bool, P b.
 
-Lemma aux : prop_extensionality -> bool_dep_induction -> true = false.
-Proof.
-intros Ext Ind.
-case (ext_prop_fixpoint Ext bool true); intros G Gfix.
-set (neg := fun b:bool => bool_elim bool false true b).
-generalize (refl_equal (G neg)).
-pattern (G neg) at 1 in |- *.
-apply Ind with (b := G neg); intro Heq.
-rewrite (bool_elim_redl bool false true).
-change (true = neg true) in |- *; rewrite Heq; apply Gfix.
-rewrite (bool_elim_redr bool false true).
-change (neg false = false) in |- *; rewrite Heq; symmetry  in |- *;
- apply Gfix.
-Qed.
-
-Lemma ext_prop_dep_proof_irrel_gen :
- prop_extensionality -> bool_dep_induction -> proof_irrelevance.
-Proof.
-intros Ext Ind A a1 a2.
-set (f := fun b:bool => bool_elim A a1 a2 b).
-rewrite (bool_elim_redl A a1 a2).
-change (f true = a2) in |- *.
-rewrite (bool_elim_redr A a1 a2).
-change (f true = f false) in |- *.
-rewrite (aux Ext Ind).
-reflexivity.
-Qed.
+  Lemma aux : prop_extensionality -> bool_dep_induction -> true = false.
+  Proof.
+    intros Ext Ind.
+    case (ext_prop_fixpoint Ext bool true); intros G Gfix.
+    set (neg := fun b:bool => bool_elim bool false true b).
+    generalize (refl_equal (G neg)).
+    pattern (G neg) at 1 in |- *.
+    apply Ind with (b := G neg); intro Heq.
+    rewrite (bool_elim_redl bool false true).
+    change (true = neg true) in |- *; rewrite Heq; apply Gfix.
+    rewrite (bool_elim_redr bool false true).
+    change (neg false = false) in |- *; rewrite Heq; symmetry  in |- *;
+      apply Gfix.
+  Qed.
+
+  Lemma ext_prop_dep_proof_irrel_gen :
+    prop_extensionality -> bool_dep_induction -> proof_irrelevance.
+  Proof.
+    intros Ext Ind A a1 a2.
+    set (f := fun b:bool => bool_elim A a1 a2 b).
+    rewrite (bool_elim_redl A a1 a2).
+    change (f true = a2) in |- *.
+    rewrite (bool_elim_redr A a1 a2).
+    change (f true = f false) in |- *.
+    rewrite (aux Ext Ind).
+    reflexivity.
+  Qed.
 
 End Proof_irrelevance_gen.
 
@@ -161,27 +207,31 @@ End Proof_irrelevance_gen.
     most 2 elements.
 *)
 
-Section Proof_irrelevance_CC.
+Section Proof_irrelevance_Prop_Ext_CC.
+  
+  Definition BoolP := forall C:Prop, C -> C -> C.
+  Definition TrueP : BoolP := fun C c1 c2 => c1.
+  Definition FalseP : BoolP := fun C c1 c2 => c2.
+  Definition BoolP_elim C c1 c2 (b:BoolP) := b C c1 c2.
+  Definition BoolP_elim_redl (C:Prop) (c1 c2:C) :
+    c1 = BoolP_elim C c1 c2 TrueP := refl_equal c1.
+  Definition BoolP_elim_redr (C:Prop) (c1 c2:C) :
+    c2 = BoolP_elim C c1 c2 FalseP := refl_equal c2.
+  
+  Definition BoolP_dep_induction :=
+    forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b.
+  
+  Lemma ext_prop_dep_proof_irrel_cc :
+    prop_extensionality -> BoolP_dep_induction -> proof_irrelevance.
+  Proof.
+    exact (ext_prop_dep_proof_irrel_gen BoolP TrueP FalseP BoolP_elim BoolP_elim_redl
+      BoolP_elim_redr).
+  Qed.
+
+End Proof_irrelevance_Prop_Ext_CC.
 
-Definition BoolP := forall C:Prop, C -> C -> C.
-Definition TrueP : BoolP := fun C c1 c2 => c1.
-Definition FalseP : BoolP := fun C c1 c2 => c2.
-Definition BoolP_elim C c1 c2 (b:BoolP) := b C c1 c2.
-Definition BoolP_elim_redl (C:Prop) (c1 c2:C) :
-  c1 = BoolP_elim C c1 c2 TrueP := refl_equal c1.
-Definition BoolP_elim_redr (C:Prop) (c1 c2:C) :
-  c2 = BoolP_elim C c1 c2 FalseP := refl_equal c2.
-
-Definition BoolP_dep_induction :=
-  forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b.
-
-Lemma ext_prop_dep_proof_irrel_cc :
- prop_extensionality -> BoolP_dep_induction -> proof_irrelevance.
-Proof
-  ext_prop_dep_proof_irrel_gen BoolP TrueP FalseP BoolP_elim BoolP_elim_redl
-    BoolP_elim_redr.
-
-End Proof_irrelevance_CC.
+(************************************************************************)
+(** ** CIC |- prop. ext. -> proof-irrelevance                   *)
 
 (** In the Calculus of Inductive Constructions, inductively defined booleans
     enjoy dependent case analysis, hence directly proof-irrelevance from
@@ -189,21 +239,22 @@ End Proof_irrelevance_CC.
 *)
 
 Section Proof_irrelevance_CIC.
-
-Inductive boolP : Prop :=
-  | trueP : boolP
-  | falseP : boolP.
-Definition boolP_elim_redl (C:Prop) (c1 c2:C) :
-  c1 = boolP_ind C c1 c2 trueP := refl_equal c1.
-Definition boolP_elim_redr (C:Prop) (c1 c2:C) :
-  c2 = boolP_ind C c1 c2 falseP := refl_equal c2.
-Scheme boolP_indd := Induction for boolP Sort Prop.
-
-Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance.
-Proof
-  fun pe =>
-    ext_prop_dep_proof_irrel_gen boolP trueP falseP boolP_ind boolP_elim_redl
-      boolP_elim_redr pe boolP_indd.
+  
+  Inductive boolP : Prop :=
+    | trueP : boolP
+    | falseP : boolP.
+  Definition boolP_elim_redl (C:Prop) (c1 c2:C) :
+    c1 = boolP_ind C c1 c2 trueP := refl_equal c1.
+  Definition boolP_elim_redr (C:Prop) (c1 c2:C) :
+    c2 = boolP_ind C c1 c2 falseP := refl_equal c2.
+  Scheme boolP_indd := Induction for boolP Sort Prop.
+  
+  Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance.
+  Proof.
+    exact (fun pe =>
+      ext_prop_dep_proof_irrel_gen boolP trueP falseP boolP_ind boolP_elim_redl
+      boolP_elim_redr pe boolP_indd).
+  Qed.
 
 End Proof_irrelevance_CIC.
 
@@ -211,9 +262,288 @@ End Proof_irrelevance_CIC.
   (i.e. propositional extensionality + excluded middle) without
   dependent case analysis ?
 
-  Conjecture: it seems possible to build a model of CC interpreting
-  all non-empty types by the set of all lambda-terms. Such a model would
-  satisfy propositional degeneracy without satisfying proof-irrelevance
-  (nor dependent case analysis). This would imply that the previous
-  results cannot be refined.
+  Berardi [[Berardi90]] built a model of CC interpreting inhabited
+  types by the set of all untyped lambda-terms. This model satisfies
+  propositional degeneracy without satisfying proof-irrelevance (nor
+  dependent case analysis). This implies that the previous results
+  cannot be refined.
+
+  [[Berardi90]] Stefano Berardi, "Type dependence and constructive
+  mathematics", Ph. D. thesis, Dipartimento Matematica, Università di
+  Torino, 1990.
+*)
+
+(************************************************************************)
+(** ** CC |- excluded-middle + dep elim on bool -> proof-irrelevance *)
+
+(** This is a proof in the pure Calculus of Construction that
+    classical logic in [Prop] + dependent elimination of disjunction entails
+    proof-irrelevance.
+
+    Reference:
+
+    [[Coquand90]] T. Coquand, "Metamathematical Investigations of a
+    Calculus of Constructions", Proceedings of Logic in Computer Science
+    (LICS'90), 1990.
+
+    Proof skeleton: classical logic + dependent elimination of
+    disjunction + discrimination of proofs implies the existence of a
+    retract from [Prop] into [bool], hence inconsistency by encoding any
+    paradox of system U- (e.g. Hurkens' paradox).
+*)
+
+Require Import Hurkens.
+
+Section Proof_irrelevance_EM_CC.
+  
+  Variable or : Prop -> Prop -> Prop.
+  Variable or_introl : forall A B:Prop, A -> or A B.
+  Variable or_intror : forall A B:Prop, B -> or A B.
+  Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C.
+  Hypothesis
+    or_elim_redl :
+    forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A),
+      f a = or_elim A B C f g (or_introl A B a).
+  Hypothesis
+    or_elim_redr :
+    forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B),
+      g b = or_elim A B C f g (or_intror A B b).
+  Hypothesis
+    or_dep_elim :
+    forall (A B:Prop) (P:or A B -> Prop),
+      (forall a:A, P (or_introl A B a)) ->
+      (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.
+  
+  Hypothesis em : forall A:Prop, or A (~ A).
+  Variable B : Prop.
+  Variables b1 b2 : B.
+  
+  (** [p2b] and [b2p] form a retract if [~b1=b2] *)
+
+  Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A).
+  Definition b2p b := b1 = b.
+
+  Lemma p2p1 : forall A:Prop, A -> b2p (p2b A).
+  Proof.
+    unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A);
+      unfold b2p in |- *; intros.
+    apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)).
+    destruct (b H).
+  Qed.
+
+  Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A.
+  Proof.
+    intro not_eq_b1_b2.
+    unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A);
+      unfold b2p in |- *; intros.
+    assumption.
+    destruct not_eq_b1_b2.
+    rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H.
+    assumption.
+  Qed.
+
+  (** Using excluded-middle a second time, we get proof-irrelevance *)
+
+  Theorem proof_irrelevance_cc : b1 = b2.
+  Proof.
+    refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H.
+    trivial.
+    apply (paradox B p2b b2p (p2p2 H) p2p1).
+  Qed.
+
+End Proof_irrelevance_EM_CC.
+
+(** Remark: Hurkens' paradox still holds with a retract from the
+    _negative_ fragment of [Prop] into [bool], hence weak classical
+    logic, i.e. [forall A, ~A\/~~A], is enough for deriving
+    proof-irrelevance.
+*)
+
+(************************************************************************)
+(** ** CIC |- excluded-middle -> proof-irrelevance               *)
+
+(**
+    Since, dependent elimination is derivable in the Calculus of
+    Inductive Constructions (CCI), we get proof-irrelevance from classical
+    logic in the CCI.
+*)
+
+Section Proof_irrelevance_CCI.
+
+  Hypothesis em : forall A:Prop, A \/ ~ A.
+  
+  Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) 
+    (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a).
+  Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) 
+    (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b).
+  Scheme or_indd := Induction for or Sort Prop.
+  
+  Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2.
+  Proof.
+    exact (proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
+      or_elim_redr or_indd em).
+  Qed.
+
+End Proof_irrelevance_CCI.
+
+(** Remark: in the Set-impredicative CCI, Hurkens' paradox still holds with
+    [bool] in [Set] and since [~true=false] for [true] and [false]
+    in [bool] from [Set], we get the inconsistency of
+    [em : forall A:Prop, {A}+{~A}] in the Set-impredicative CCI.
+*)
+
+(** * Weak classical axioms *)
+
+(** We show the following increasing in the strength of axioms:
+ - weak excluded-middle
+ - right distributivity of implication over disjunction and Gödel-Dummet axiom
+ - independence of general premises and drinker's paradox
+ - excluded-middle
+*)
+
+(** ** Weak excluded-middle *)
+
+(** The weak classical logic based on [~~A \/ ~A] is referred to with
+    name KC in {[ChagrovZakharyaschev97]]
+
+   [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael
+   Zakharyaschev, "Modal Logic", Clarendon Press, 1997.
+*)
+
+Definition weak_excluded_middle :=
+  forall A:Prop, ~~A \/ ~A.
+
+(** The interest in the equivalent variant
+    [weak_generalized_excluded_middle] is that it holds even in logic
+    without a primitive [False] connective (like Gödel-Dummett axiom) *)
+
+Definition weak_generalized_excluded_middle := 
+  forall A B:Prop, ((A -> B) -> B) \/ (A -> B).
+
+(** ** Gödel-Dummett axiom *)
+
+(** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gödel33]].
+
+    [[Dummett59]] Michael A. E. Dummett. "A Propositional Calculus
+    with a Denumerable Matrix", In the Journal of Symbolic Logic, Vol
+    24 No. 2(1959), pp 97-103.
+
+    [[Gödel33]] Kurt Gödel. "Zum intuitionistischen Aussagenkalkül",
+    Ergeb. Math. Koll. 4 (1933), pp. 34-38.
+ *)
+
+Definition GodelDummett := forall A B:Prop, (A -> B) \/ (B -> A).
+
+Lemma excluded_middle_Godel_Dummett : excluded_middle -> GodelDummett.
+Proof.
+  intros EM A B. destruct (EM B) as [HB|HnotB].
+  left; intros _; exact HB.
+  right; intros HB; destruct (HnotB HB).
+Qed.
+
+(** [(A->B) \/ (B->A)] is equivalent to [(C -> A\/B) -> (C->A) \/ (C->B)]
+    (proof from [[Dummett59]]) *)
+
+Definition RightDistributivityImplicationOverDisjunction :=
+  forall A B C:Prop, (C -> A\/B) -> (C->A) \/ (C->B).
+
+Lemma Godel_Dummett_iff_right_distr_implication_over_disjunction :
+  GodelDummett <-> RightDistributivityImplicationOverDisjunction.
+Proof.
+  split.
+    intros GD A B C HCAB.
+    destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC; 
+      destruct (HCAB HC) as [HA|HB]; [ | apply HBA | apply HAB | ]; assumption.
+    intros Distr A B.
+    destruct (Distr A B (A\/B)) as [HABA|HABB].
+      intro HAB; exact HAB.
+      right; intro HB; apply HABA; right; assumption.
+      left; intro HA; apply HABB; left; assumption.
+Qed.
+
+(** [(A->B) \/ (B->A)] is stronger than the weak excluded middle *)
+
+Lemma Godel_Dummett_weak_excluded_middle : 
+  GodelDummett -> weak_excluded_middle.
+Proof.
+  intros GD A. destruct (GD (~A) A) as [HnotAA|HAnotA].
+    left; intro HnotA; apply (HnotA (HnotAA HnotA)).
+    right; intro HA; apply (HAnotA HA HA).
+Qed.
+
+(** ** Independence of general premises and drinker's paradox *)
+
+(** Independence of general premises is the unconstrained, non
+    constructive, version of the Independence of Premises as
+    considered in [[Troelstra73]].
+
+    It is a generalization to predicate logic of the right
+    distributivity of implication over disjunction (hence of
+    Gödel-Dummett axiom) whose own constructive form (obtained by a
+    restricting the third formula to be negative) is called
+    Kreisel-Putnam principle [[KreiselPutnam57]].
+
+    [[KreiselPutnam57]], Georg Kreisel and Hilary Putnam. "Eine
+    Unableitsbarkeitsbeweismethode für den intuitionistischen
+    Aussagenkalkül". Archiv für Mathematische Logik und
+    Graundlagenforschung, 3:74- 78, 1957.
+
+    [[Troelstra73]], Anne Troelstra, editor. Metamathematical
+    Investigation of Intuitionistic Arithmetic and Analysis, volume
+    344 of Lecture Notes in Mathematics, Springer-Verlag, 1973.
 *)
+
+Notation Local "'inhabited' A" := A (at level 10, only parsing).
+
+Definition IndependenceOfGeneralPremises :=
+  forall (A:Type) (P:A -> Prop) (Q:Prop),
+    inhabited A -> (Q -> exists x, P x) -> exists x, Q -> P x.
+
+Lemma
+  independence_general_premises_right_distr_implication_over_disjunction :
+  IndependenceOfGeneralPremises -> RightDistributivityImplicationOverDisjunction.
+Proof.
+  intros IP A B C HCAB.
+  destruct (IP bool (fun b => if b then A else B) C true) as ([|],H).
+    intro HC; destruct (HCAB HC); [exists true|exists false]; assumption.
+    left; assumption.
+    right; assumption.
+Qed.
+
+Lemma independence_general_premises_Godel_Dummett :
+  IndependenceOfGeneralPremises -> GodelDummett.
+Proof.
+  destruct Godel_Dummett_iff_right_distr_implication_over_disjunction.
+  auto using independence_general_premises_right_distr_implication_over_disjunction.
+Qed.
+
+(** Independence of general premises is equivalent to the drinker's paradox *)
+
+Definition DrinkerParadox :=
+  forall (A:Type) (P:A -> Prop), 
+    inhabited A -> exists x, (exists x, P x) -> P x.
+
+Lemma independence_general_premises_drinker : 
+  IndependenceOfGeneralPremises <-> DrinkerParadox.
+Proof.
+  split.
+    intros IP A P InhA; apply (IP A P (exists x, P x) InhA); intro Hx; exact Hx.
+    intros Drinker A P Q InhA H; destruct (Drinker A P InhA) as (x,Hx).
+      exists x; intro HQ; apply (Hx (H HQ)).
+Qed.
+
+(** Independence of general premises is weaker than (generalized) 
+    excluded middle *)
+
+Definition generalized_excluded_middle := 
+  forall A B:Prop, A \/ (A -> B).
+
+Lemma excluded_middle_independence_general_premises :
+  generalized_excluded_middle -> DrinkerParadox.
+Proof.
+  intros GEM A P x0.
+  destruct (GEM (exists x, P x) (P x0)) as [(x,Hx)|Hnot].
+    exists x; intro; exact Hx.
+    exists x0; exact Hnot.
+Qed.
+ 
diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v
new file mode 100644
index 00000000..28d32fcc
--- /dev/null
+++ b/theories/Logic/ClassicalUniqueChoice.v
@@ -0,0 +1,79 @@
+(************************************************************************)
+(*  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: ClassicalUniqueChoice.v 9026 2006-07-06 15:16:20Z herbelin $ i*)
+
+(** This file provides classical logic and unique choice *)
+
+(** Classical logic and unique choice, as shown in
+    [ChicliPottierSimpson02], implies the double-negation of
+    excluded-middle in [Set], hence it implies a strongly classical
+    world. Especially it conflicts with the impredicativity of [Set].
+
+    [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos
+    Simpson, Mathematical Quotients and Quotient Types in Coq,
+    Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646,
+    Springer Verlag.  *)
+
+Require Export Classical.
+
+Axiom
+  dependent_unique_choice :
+    forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
+      (forall x : A, exists! y : B x, R x y) ->
+      (exists f : (forall x:A, B x), forall x:A, R x (f x)).
+
+(** Unique choice reifies functional relations into functions *)
+
+Theorem unique_choice :
+ forall (A B:Type) (R:A -> B -> Prop),
+   (forall x:A,  exists! y : B, R x y) ->
+   (exists f:A->B, forall x:A, R x (f x)).
+Proof.
+intros A B.
+apply (dependent_unique_choice A (fun _ => B)).
+Qed.
+
+(** The following proof comes from [ChicliPottierSimpson02] *)
+
+Require Import Setoid.
+
+Theorem classic_set : ((forall P:Prop, {P} + {~ P}) -> False) -> False.
+Proof.
+intro HnotEM.
+set (R := fun A b => A /\ true = b \/ ~ A /\ false = b).
+assert (H :  exists f : Prop -> bool, (forall A:Prop, R A (f A))).
+apply unique_choice.
+intro A.
+destruct (classic A) as [Ha| Hnota].
+  exists true; split.
+    left; split; [ assumption | reflexivity ].
+    intros y [[_ Hy]| [Hna _]].
+      assumption.
+      contradiction.
+  exists false; split.
+    right; split; [ assumption | reflexivity ].
+    intros y [[Ha _]| [_ Hy]].
+      contradiction.
+      assumption.
+destruct H as [f Hf].
+apply HnotEM.
+intro P.
+assert (HfP := Hf P).
+(* Elimination from Hf to Set is not allowed but from f to Set yes ! *)
+destruct (f P).
+  left.
+  destruct HfP as [[Ha _]| [_ Hfalse]].
+    assumption.
+    discriminate.
+  right.
+  destruct HfP as [[_ Hfalse]| [Hna _]].
+    discriminate.
+    assumption.
+Qed.
+ 
diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v
index c8f87fe8..2a5f03ec 100755..100644
--- a/theories/Logic/Classical_Pred_Set.v
+++ b/theories/Logic/Classical_Pred_Set.v
@@ -6,11 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Pred_Set.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: Classical_Pred_Set.v 8642 2006-03-17 10:09:02Z notin $ i*)
+
+(** This file is obsolete, use Classical_Pred_Type.v via Classical.v
+instead *)
 
 (** Classical Predicate Logic on Set*)
 
-Require Import Classical_Prop.
+Require Import Classical_Pred_Type.
 
 Section Generic.
 Variable U : Set.
@@ -19,52 +22,26 @@ Variable U : Set.
 
 Lemma not_all_ex_not :
  forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
-Proof.
-unfold not in |- *; intros P notall.
-apply NNPP; unfold not in |- *.
-intro abs.
-cut (forall n:U, P n); auto.
-intro n; apply NNPP.
-unfold not in |- *; intros.
-apply abs; exists n; trivial.
-Qed.
+Proof (Classical_Pred_Type.not_all_ex_not U).
 
 Lemma not_all_not_ex :
  forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
-Proof.
-intros P H.
-elim (not_all_ex_not (fun n:U => ~ P n) H); intros n Pn; exists n.
-apply NNPP; trivial.
-Qed.
+Proof (Classical_Pred_Type.not_all_not_ex U).
 
 Lemma not_ex_all_not :
  forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
-Proof.
-unfold not in |- *; intros P notex n abs.
-apply notex.
-exists n; trivial.
-Qed. 
+Proof (Classical_Pred_Type.not_ex_all_not U).
 
 Lemma not_ex_not_all :
  forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n.
-Proof.
-intros P H n.
-apply NNPP.
-red in |- *; intro K; apply H; exists n; trivial.
-Qed.
+Proof (Classical_Pred_Type.not_ex_not_all U).
 
 Lemma ex_not_not_all :
  forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
-Proof.
-unfold not in |- *; intros P exnot allP.
-elim exnot; auto.
-Qed.
+Proof (Classical_Pred_Type.ex_not_not_all U).
 
 Lemma all_not_not_ex :
  forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
-Proof.
-unfold not in |- *; intros P allnot exP; elim exP; intros n p.
-apply allnot with n; auto.
-Qed.
+Proof (Classical_Pred_Type.all_not_not_ex U).
 
-End Generic.
\ No newline at end of file
+End Generic.
diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v
index 804ff32d..56ebf967 100755..100644
--- a/theories/Logic/Classical_Pred_Type.v
+++ b/theories/Logic/Classical_Pred_Type.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Pred_Type.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: Classical_Pred_Type.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 (** Classical Predicate Logic on Type *)
 
@@ -17,29 +17,30 @@ Variable U : Type.
 
 (** de Morgan laws for quantifiers *)
 
-Lemma not_all_ex_not :
- forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
+Lemma not_all_not_ex :
+ forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
 Proof.
-unfold not in |- *; intros P notall.
-apply NNPP; unfold not in |- *.
+intros P notall.
+apply NNPP.
 intro abs.
-cut (forall n:U, P n); auto.
-intro n; apply NNPP.
-unfold not in |- *; intros.
-apply abs; exists n; trivial.
+apply notall.
+intros n H.
+apply abs; exists n; exact H.
 Qed.
 
-Lemma not_all_not_ex :
- forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
+Lemma not_all_ex_not :
+ forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
 Proof.
-intros P H.
-elim (not_all_ex_not (fun n:U => ~ P n) H); intros n Pn; exists n.
-apply NNPP; trivial.
+intros P notall.
+apply not_all_not_ex with (P:=fun x => ~ P x).
+intro all; apply notall.
+intro n; apply NNPP.
+apply all.
 Qed.
 
 Lemma not_ex_all_not :
  forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
-Proof.
+Proof. (* Intuitionistic *)
 unfold not in |- *; intros P notex n abs.
 apply notex.
 exists n; trivial.
@@ -55,16 +56,16 @@ Qed.
 
 Lemma ex_not_not_all :
  forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
-Proof.
+Proof. (* Intuitionistic *)
 unfold not in |- *; intros P exnot allP.
 elim exnot; auto.
 Qed.
 
 Lemma all_not_not_ex :
  forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
-Proof.
+Proof. (* Intuitionistic *)
 unfold not in |- *; intros P allnot exP; elim exP; intros n p.
 apply allnot with n; auto.
 Qed.
 
-End Generic.
\ No newline at end of file
+End Generic.
diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v
index ccc26df1..ce3e84a7 100755..100644
--- a/theories/Logic/Classical_Prop.v
+++ b/theories/Logic/Classical_Prop.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Prop.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: Classical_Prop.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
 
 (** Classical Propositional Logic *)
 
-Require Import ProofIrrelevance.
+Require Import ClassicalFacts.
 
 Hint Unfold not: core.
 
@@ -22,6 +22,15 @@ unfold not in |- *; intros; elim (classic p); auto.
 intro NP; elim (H NP).
 Qed.
 
+(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. 
+    Thanks to [forall P, False -> P], it is equivalent to the
+    following form *)
+
+Lemma Peirce : forall P:Prop, ((P -> False) -> P) -> P.
+Proof.
+intros P H; destruct (classic P); auto.
+Qed.
+
 Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P.
 Proof.
 intros; apply NNPP; red in |- *.
@@ -29,8 +38,8 @@ intro; apply H; intro; absurd P; trivial.
 Qed.
 
 Lemma not_imply_elim2 : forall P Q:Prop, ~ (P -> Q) -> ~ Q.
-Proof.
-intros; elim (classic Q); auto.
+Proof. (* Intuitionistic *)
+tauto.
 Qed.
 
 Lemma imply_to_or : forall P Q:Prop, (P -> Q) -> ~ P \/ Q.
@@ -46,9 +55,8 @@ apply not_imply_elim2 with P; trivial.
 Qed.
 
 Lemma or_to_imply : forall P Q:Prop, ~ P \/ Q -> P -> Q.
-Proof.
-simple induction 1; auto.
-intros H1 H2; elim (H1 H2).
+Proof. (* Intuitionistic *)
+tauto.
 Qed.
 
 Lemma not_and_or : forall P Q:Prop, ~ (P /\ Q) -> ~ P \/ ~ Q.
@@ -62,24 +70,50 @@ simple induction 1; red in |- *; simple induction 2; auto.
 Qed.
 
 Lemma not_or_and : forall P Q:Prop, ~ (P \/ Q) -> ~ P /\ ~ Q.
-Proof.
-intros; elim (classic P); auto.
+Proof. (* Intuitionistic *)
+tauto.
 Qed.
 
 Lemma and_not_or : forall P Q:Prop, ~ P /\ ~ Q -> ~ (P \/ Q).
-Proof.
-simple induction 1; red in |- *; simple induction 3; trivial.
+Proof. (* Intuitionistic *)
+tauto.
 Qed.
 
 Lemma imply_and_or : forall P Q:Prop, (P -> Q) -> P \/ Q -> Q.
-Proof.
-simple induction 2; trivial.
+Proof. (* Intuitionistic *)
+tauto.
 Qed.
 
 Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> P \/ R -> Q \/ R.
-Proof.
-simple induction 2; auto.
+Proof. (* Intuitionistic *)
+tauto.
 Qed.
 
 Lemma proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
-Proof proof_irrelevance_cci classic.
\ No newline at end of file
+Proof proof_irrelevance_cci classic.
+
+(* classical_left  transforms |- A \/ B into ~B |- A *)
+(* classical_right transforms |- A \/ B into ~A |- B *)
+
+Ltac classical_right :=  match goal with 
+ | _:_ |-?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right])
+end.
+
+Ltac classical_left := match goal with 
+| _:_ |- _ \/?X1 => (elim (classic X1);intro;[right;trivial|left])
+end.
+
+Require Export EqdepFacts.
+
+Module Eq_rect_eq.
+
+Lemma eq_rect_eq : 
+  forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
+Proof.
+intros; rewrite proof_irrelevance with (p1:=h) (p2:=refl_equal p); reflexivity.
+Qed.
+
+End Eq_rect_eq.
+
+Module EqdepTheory := EqdepTheory(Eq_rect_eq).
+Export EqdepTheory.
diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v
index 753b8590..9b1f4e19 100755..100644
--- a/theories/Logic/Classical_Type.v
+++ b/theories/Logic/Classical_Type.v
@@ -6,9 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Classical_Type.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: Classical_Type.v 8642 2006-03-17 10:09:02Z notin $ i*)
+
+(** This file is obsolete, use Classical.v instead *)
 
 (** Classical Logic for Type *)
 
 Require Export Classical_Prop.
-Require Export Classical_Pred_Type.
\ No newline at end of file
+Require Export Classical_Pred_Type.
diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v
new file mode 100644
index 00000000..61e377ea
--- /dev/null
+++ b/theories/Logic/ConstructiveEpsilon.v
@@ -0,0 +1,155 @@
+(************************************************************************)
+(*  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:$ i*)
+
+(** This module proves the constructive description schema, which
+infers the sigma-existence (i.e., [Set]-existence) of a witness to a
+predicate from the regular existence (i.e., [Prop]-existence). One
+requires that the underlying set is countable and that the predicate
+is decidable. *)
+
+(** Coq does not allow case analysis on sort [Set] when the goal is in
+[Prop]. Therefore, one cannot eliminate [exists n, P n] in order to
+show [{n : nat | P n}]. However, one can perform a recursion on an
+inductive predicate in sort [Prop] so that the returning type of the
+recursion is in [Set]. This trick is described in Coq'Art book, Sect.
+14.2.3 and 15.4. In particular, this trick is used in the proof of
+[Acc_iter] in the module Coq.Init.Wf. There, recursion is done on an
+inductive predicate [Acc] and the resulting type is in [Type].
+
+The predicate [Acc] delineates elements that are accessible via a
+given relation [R]. An element is accessible if there are no infinite
+[R]-descending chains starting from it.
+
+To use [Acc_iter], we define a relation R and prove that if [exists n,
+P n] then 0 is accessible with respect to R. Then, by induction on the
+definition of [Acc R 0], we show [{n : nat | P n}]. *)
+
+(** Contributed by Yevgeniy Makarov *)
+
+Require Import Arith.
+
+Section ConstructiveIndefiniteDescription.
+
+Variable P : nat -> Prop.
+
+Hypothesis P_decidable : forall x : nat, {P x} + {~ P x}.
+
+(** To find a witness of [P] constructively, we define an algorithm
+that tries P on all natural numbers starting from 0 and going up. The
+relation [R] describes the connection between the two successive
+numbers we try. Namely, [y] is [R]-less then [x] if we try [y] after
+[x], i.e., [y = S x] and [P x] is false. Then the absence of an
+infinite [R]-descending chain from 0 is equivalent to the termination
+of our searching algorithm. *)
+
+Let R (x y : nat) := (x = S y /\ ~ P y).
+Notation Local "'acc' x" := (Acc R x) (at level 10).
+
+Lemma P_implies_acc : forall x : nat, P x -> acc x.
+Proof.
+intros x H. constructor.
+intros y [_ not_Px]. absurd (P x); assumption.
+Qed.
+
+Lemma P_eventually_implies_acc : forall (x : nat) (n : nat), P (n + x) -> acc x.
+Proof.
+intros x n; generalize x; clear x; induction n as [|n IH]; simpl.
+apply P_implies_acc.
+intros x H. constructor. intros y [fxy _].
+apply IH. rewrite fxy.
+replace (n + S x) with (S (n + x)); auto with arith.
+Defined.
+
+Corollary P_eventually_implies_acc_ex : (exists n : nat, P n) -> acc 0.
+Proof.
+intros H; elim H. intros x Px. apply P_eventually_implies_acc with (n := x).
+replace (x + 0) with x; auto with arith.
+Defined.
+
+(** In the following statement, we use the trick with recursion on
+[Acc]. This is also where decidability of [P] is used. *)
+
+Theorem acc_implies_P_eventually : acc 0 -> {n : nat | P n}.
+Proof.
+intros Acc_0. pattern 0. apply Acc_iter with (R := R); [| assumption].
+clear Acc_0; intros x IH.
+destruct (P_decidable x) as [Px | not_Px].
+exists x; simpl; assumption.
+set (y := S x).
+assert (Ryx : R y x). unfold R; split; auto.
+destruct (IH y Ryx) as [n Hn].
+exists n; assumption.
+Defined.
+
+Theorem constructive_indefinite_description_nat : (exists n : nat, P n) -> {n : nat | P n}.
+Proof.
+intros H; apply acc_implies_P_eventually.
+apply P_eventually_implies_acc_ex; assumption.
+Defined.
+
+End ConstructiveIndefiniteDescription.
+
+Section ConstructiveEpsilon.
+
+(** For the current purpose, we say that a set [A] is countable if
+there are functions [f : A -> nat] and [g : nat -> A] such that [g] is
+a left inverse of [f]. *)
+
+Variable A : Type.
+Variable f : A -> nat.
+Variable g : nat -> A.
+
+Hypothesis gof_eq_id : forall x : A, g (f x) = x.
+
+Variable P : A -> Prop.
+
+Hypothesis P_decidable : forall x : A, {P x} + {~ P x}.
+
+Definition P' (x : nat) : Prop := P (g x).
+
+Lemma P'_decidable : forall n : nat, {P' n} + {~ P' n}.
+Proof.
+intro n; unfold P'; destruct (P_decidable (g n)); auto.
+Defined.
+
+Lemma constructive_indefinite_description : (exists x : A, P x) -> {x : A | P x}.
+Proof.
+intro H. assert (H1 : exists n : nat, P' n).
+destruct H as [x Hx]. exists (f x); unfold P'. rewrite gof_eq_id; assumption.
+apply (constructive_indefinite_description_nat P' P'_decidable)  in H1.
+destruct H1 as [n Hn]. exists (g n); unfold P' in Hn; assumption.
+Defined.
+
+Lemma constructive_definite_description : (exists! x : A, P x) -> {x : A | P x}.
+Proof.
+  intros; apply constructive_indefinite_description; firstorder.
+Defined.
+
+Definition epsilon (E : exists x : A, P x) : A
+  := proj1_sig (constructive_indefinite_description E).
+
+Definition epsilon_spec (E : (exists x, P x)) : P (epsilon E)
+  := proj2_sig (constructive_indefinite_description E).
+
+End ConstructiveEpsilon.
+
+Theorem choice :
+  forall (A B : Type) (f : B -> nat) (g : nat -> B),
+    (forall x : B, g (f x) = x) ->
+    forall (R : A -> B -> Prop),
+    (forall (x : A) (y : B), {R x y} + {~ R x y}) ->
+    (forall x : A, exists y : B, R x y) ->
+    (exists f : A -> B, forall x : A, R x (f x)).
+Proof.
+intros A B f g gof_eq_id R R_dec H.
+exists (fun x : A => epsilon B f g gof_eq_id (R x) (R_dec x) (H x)).
+intro x.
+apply (epsilon_spec B f g gof_eq_id (R x) (R_dec x) (H x)).
+Qed.
diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v
index 08babda9..8317f6bb 100644
--- a/theories/Logic/Decidable.v
+++ b/theories/Logic/Decidable.v
@@ -5,7 +5,7 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	$Id: Decidable.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $	 i*)
+(*i 	$Id: Decidable.v 5920 2004-07-16 20:01:26Z herbelin $	 i*)
 
 (** Properties of decidable propositions *)
 
diff --git a/theories/Logic/DecidableType.v b/theories/Logic/DecidableType.v
new file mode 100644
index 00000000..a38b111f
--- /dev/null
+++ b/theories/Logic/DecidableType.v
@@ -0,0 +1,156 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: DecidableType.v 8933 2006-06-09 14:08:38Z herbelin $ *)
+
+Require Export SetoidList.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Types with decidable Equalities (but no ordering) *)
+
+Module Type DecidableType. 
+
+  Parameter t : Set.
+
+  Parameter eq : t -> t -> Prop.
+
+  Axiom eq_refl : forall x : t, eq x x.
+  Axiom eq_sym : forall x y : t, eq x y -> eq y x.
+  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
+
+  Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
+
+  Hint Immediate eq_sym.
+  Hint Resolve eq_refl eq_trans.
+
+End DecidableType. 
+
+(** * Additional notions about keys and datas used in FMap *)
+
+Module KeyDecidableType(D:DecidableType).
+ Import D.
+
+ Section Elt.
+ Variable elt : Set.
+ Notation key:=t.
+
+  Definition eqk (p p':key*elt) := eq (fst p) (fst p').
+  Definition eqke (p p':key*elt) := 
+          eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+  Hint Unfold eqk eqke.
+  Hint Extern 2 (eqke ?a ?b) => split.
+
+   (* eqke is stricter than eqk *)
+ 
+   Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
+   Proof.
+     unfold eqk, eqke; intuition.
+   Qed.
+
+  (* eqk, eqke are equalities *)
+ 
+  Lemma eqk_refl : forall e, eqk e e.
+  Proof. auto. Qed.
+
+  Lemma eqke_refl : forall e, eqke e e.
+  Proof. auto. Qed.
+
+  Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e.
+  Proof. auto. Qed.
+
+  Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e.
+  Proof. unfold eqke; intuition. Qed.
+
+  Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''.
+  Proof. eauto. Qed.
+
+  Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''.
+  Proof.
+    unfold eqke; intuition; [ eauto | congruence ].
+  Qed.
+
+  Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
+  Hint Immediate eqk_sym eqke_sym.
+
+  Lemma InA_eqke_eqk : 
+     forall x m, InA eqke x m -> InA eqk x m.
+  Proof.
+    unfold eqke; induction 1; intuition.
+  Qed.
+  Hint Resolve InA_eqke_eqk.
+
+  Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m.
+  Proof.
+   intros; apply InA_eqA with p; auto; apply eqk_trans; auto.
+  Qed.
+
+  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
+  Definition In k m := exists e:elt, MapsTo k e m.
+
+  Hint Unfold MapsTo In.
+
+  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
+
+  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
+  Proof.
+  firstorder.
+  exists x; auto.
+  induction H.
+  destruct y.
+  exists e; auto.
+  destruct IHInA as [e H0].
+  exists e; auto.
+  Qed.
+
+  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
+  Proof.
+  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto.
+  Qed.
+
+  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+  Proof.
+  destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
+  Qed. 
+
+  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
+  Proof.
+    inversion 1.
+    inversion_clear H0; eauto.
+    destruct H1; simpl in *; intuition.
+  Qed.      
+
+  Lemma In_inv_2 : forall k k' e e' l, 
+      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
+  Proof.  
+   inversion_clear 1; compute in H0; intuition.
+  Qed.
+
+  Lemma In_inv_3 : forall x x' l, 
+      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+  Proof.
+   inversion_clear 1; compute in H0; intuition.
+  Qed.
+
+ End Elt.
+
+ Hint Unfold eqk eqke.
+ Hint Extern 2 (eqke ?a ?b) => split.
+ Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
+ Hint Immediate eqk_sym eqke_sym.
+ Hint Resolve InA_eqke_eqk.
+ Hint Unfold MapsTo In.
+ Hint Resolve In_inv_2 In_inv_3.
+
+End KeyDecidableType.
+
+
+
+
+
diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Logic/DecidableTypeEx.v
new file mode 100644
index 00000000..a4f99de2
--- /dev/null
+++ b/theories/Logic/DecidableTypeEx.v
@@ -0,0 +1,50 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* $Id: DecidableTypeEx.v 8933 2006-06-09 14:08:38Z herbelin $ *)
+
+Require Import DecidableType OrderedType OrderedTypeEx.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Examples of Decidable Type structures. *)
+
+(** A particular case of [DecidableType] where 
+    the equality is the usual one of Coq. *)
+
+Module Type UsualDecidableType.
+ Parameter t : Set.
+ Definition eq := @eq t.
+ Definition eq_refl := @refl_equal t.
+ Definition eq_sym := @sym_eq t.
+ Definition eq_trans := @trans_eq t.
+ Parameter eq_dec : forall x y, { eq x y }+{~eq x y }.
+End UsualDecidableType.
+
+(** a [UsualDecidableType] is in particular an [DecidableType]. *)
+
+Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U.
+
+(** An OrderedType can be seen as a DecidableType *)
+
+Module OT_as_DT (O:OrderedType) <: DecidableType. 
+ Module OF := OrderedTypeFacts O.
+ Definition t := O.t.
+ Definition eq := O.eq. 
+ Definition eq_refl := O.eq_refl. 
+ Definition eq_sym := O.eq_sym. 
+ Definition eq_trans := O.eq_trans. 
+ Definition eq_dec := OF.eq_dec. 
+End OT_as_DT.
+
+(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *)
+
+Module Nat_as_DT <: UsualDecidableType := OT_as_DT (Nat_as_OT).
+Module Positive_as_DT <: UsualDecidableType := OT_as_DT (Positive_as_OT).
+Module N_as_DT <: UsualDecidableType := OT_as_DT (N_as_OT).
+Module Z_as_DT <: UsualDecidableType := OT_as_DT (Z_as_OT).
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
index 2b982963..5f139f35 100644
--- a/theories/Logic/Diaconescu.v
+++ b/theories/Logic/Diaconescu.v
@@ -1,3 +1,4 @@
+(* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,26 +7,46 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Diaconescu.v,v 1.5.2.3 2004/08/01 09:36:44 herbelin Exp $ i*)
+(*i $Id: Diaconescu.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
-(** R. Diaconescu [Diaconescu] showed that the Axiom of Choice in Set Theory
-   entails Excluded-Middle; S. Lacas and B. Werner [LacasWerner]
-   adapted the proof to show that the axiom of choice in equivalence
-   classes entails Excluded-Middle in Type Theory.
+(** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
+   in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show
+   that the axiom of choice in equivalence classes entails
+   Excluded-Middle in Type Theory [LacasWerner99].
 
-   This is an adaptatation of the proof by Hugo Herbelin to show that
-   the relational form of the Axiom of Choice + Extensionality for
-   predicates entails Excluded-Middle
+   Three variants of Diaconescu's result in type theory are shown below.
 
-   [Diaconescu] R. Diaconescu, Axiom of Choice and Complementation, in
-   Proceedings of AMS, vol 51, pp 176-178, 1975.
+   A. A proof that the relational form of the Axiom of Choice +
+      Extensionality for Predicates entails Excluded-Middle (by Hugo
+      Herbelin)
 
-   [LacasWerner] S. Lacas, B Werner, Which Choices imply the excluded middle?,
-   preprint, 1999.
+   B. A proof that the relational form of the Axiom of Choice + Proof
+      Irrelevance entails Excluded-Middle for Equality Statements (by
+      Benjamin Werner)
 
+   C. A proof that extensional Hilbert epsilon's description operator
+      entails excluded-middle (taken from Bell [Bell93])
+
+   See also [Carlström] for a discussion of the connection between the
+   Extensional Axiom of Choice and Excluded-Middle
+
+   [Diaconescu75] Radu Diaconescu, Axiom of Choice and Complementation,
+   in Proceedings of AMS, vol 51, pp 176-178, 1975.
+
+   [LacasWerner99] Samuel Lacas, Benjamin Werner, Which Choices imply
+   the excluded middle?, preprint, 1999.
+
+   [Bell93] John L. Bell, Hilbert's epsilon operator and classical
+   logic, Journal of Philosophical Logic, 22: 1-18, 1993
+
+   [Carlström04] Jesper Carlström, EM + Ext_ + AC_int <-> AC_ext,
+   Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
 *)
 
-Section PredExt_GuardRelChoice_imp_EM.
+(**********************************************************************)
+(** * Pred. Ext. + Rel. Axiom of Choice -> Excluded-Middle       *)
+
+Section PredExt_RelChoice_imp_EM.
 
 (** The axiom of extensionality for predicates *)
 
@@ -61,16 +82,10 @@ Require Import ChoiceFacts.
 
 Variable rel_choice : RelationalChoice.
 
-Lemma guarded_rel_choice :
- forall (A B:Type) (P:A -> Prop) (R:A -> B -> Prop),
-   (forall x:A, P x ->  exists y : B, R x y) ->
-    exists R' : A -> B -> Prop,
-     (forall x:A,
-        P x ->
-         exists y : B, R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')).
+Lemma guarded_rel_choice : GuardedRelationalChoice.
 Proof.
-  exact
-   (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
+ apply
+  (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
 Qed.
 
 (** The form of choice we need: there is a functional relation which chooses
@@ -78,16 +93,19 @@ Qed.
 
 Require Import Bool.
 
-Lemma AC :
+Lemma AC_bool_subset_to_bool :
   exists R : (bool -> Prop) -> bool -> Prop,
    (forall P:bool -> Prop,
       (exists b : bool, P b) ->
        exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
 Proof.
-  apply guarded_rel_choice with
-   (P := fun Q:bool -> Prop =>  exists y : _, Q y)
-   (R := fun (Q:bool -> Prop) (y:bool) => Q y).
-  exact (fun _ H => H).
+  destruct (guarded_rel_choice _ _ 
+   (fun Q:bool -> Prop =>  exists y : _, Q y)
+   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
+    exact (fun _ H => H).
+  exists R; intros P HP. 
+  destruct (HR P HP) as (y,(Hy,Huni)).
+  exists y; firstorder.
 Qed.
 
 (** The proof of the excluded middle *)
@@ -98,7 +116,7 @@ Proof.
 intro P.
 
 (** first we exhibit the choice functional relation R *)
-destruct AC as [R H].
+destruct AC_bool_subset_to_bool as [R H].
 
 set (class_of_true := fun b => b = true \/ P).
 set (class_of_false := fun b => b = false \/ P).
@@ -135,4 +153,152 @@ left; assumption.
 
 Qed.
 
-End PredExt_GuardRelChoice_imp_EM.
+End PredExt_RelChoice_imp_EM.
+
+(**********************************************************************)
+(** * B. Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)
+
+(** This is an adaptation of Diaconescu's paradox exploiting that
+    proof-irrelevance is some form of extensionality *)
+
+Section ProofIrrel_RelChoice_imp_EqEM.
+
+Variable rel_choice : RelationalChoice.
+
+Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y.
+
+(** Let [a1] and [a2] be two elements in some type [A] *)
+
+Variable A :Type.
+Variables a1 a2 : A.
+
+(** We build the subset [A'] of [A] made of [a1] and [a2] *)
+
+Definition A' := sigT (fun x => x=a1 \/ x=a2).
+
+Definition a1':A'.
+exists a1 ; auto.
+Defined.
+
+Definition a2':A'.
+exists a2 ; auto.
+Defined.
+
+(** By proof-irrelevance, projection is a retraction *)
+
+Lemma projT1_injective : a1=a2 -> a1'=a2'.
+Proof.
+  intro Heq ; unfold a1', a2', A'.
+  rewrite Heq.
+  replace (or_introl (a2=a2) (refl_equal a2)) 
+     with (or_intror (a2=a2) (refl_equal a2)).
+  reflexivity.
+  apply proof_irrelevance.
+Qed.
+
+(** But from the actual proofs of being in [A'], we can assert in the
+    proof-irrelevant world the existence of relevant boolean witnesses *)
+
+Lemma decide : forall x:A', exists y:bool ,
+  (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false).
+Proof.
+  intros [a [Ha1|Ha2]]; [exists true | exists false]; auto.
+Qed.
+
+(** Thanks to the axiom of choice, the boolean witnesses move from the
+    propositional world to the relevant world *)
+
+Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
+Proof.
+  destruct 
+    (rel_choice A' bool 
+       (fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
+    as (R,(HRsub,HR)). 
+    apply decide.
+  destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
+  destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
+  destruct (HR a2') as (b2,(Ha2'b2,Huni2)).
+  destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
+    left; symmetry; assumption.
+    right; intro H.
+    subst b1; subst b2.
+    rewrite (projT1_injective H) in Ha1'b1.
+    assert (false = true) by auto using Huni2.
+    discriminate.
+  left; assumption.
+Qed.
+
+(** An alternative more concise proof can be done by directly using
+    the guarded relational choice *)
+
+Declare Implicit Tactic auto.
+
+Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
+Proof.
+  assert (decide: forall x:A, x=a1 \/ x=a2 -> 
+                exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
+    intros a [Ha1|Ha2]; [exists true | exists false]; auto.
+  assert (guarded_rel_choice := 
+          rel_choice_and_proof_irrel_imp_guarded_rel_choice 
+	  rel_choice 
+	  proof_irrelevance).
+  destruct 
+    (guarded_rel_choice A bool 
+      (fun x => x=a1 \/ x=a2)
+      (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
+      as (R,(HRsub,HR)). 
+      apply decide.
+  destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
+  destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
+  destruct (HR a2) as (b2,(Ha2b2,Huni2)). right; reflexivity.
+  destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
+    left; symmetry; assumption.
+    right; intro H.
+    subst b1; subst b2; subst a1.
+    assert (false = true) by auto using Huni2, Ha1b1.
+    discriminate.
+  left; assumption.
+Qed.
+
+End ProofIrrel_RelChoice_imp_EqEM.
+
+(**********************************************************************)
+(** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *)
+
+(** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *)
+
+Notation Local "'inhabited' A" := A (at level 10, only parsing).
+
+Section ExtensionalEpsilon_imp_EM.
+
+Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.
+
+Hypothesis epsilon_spec : 
+  forall (A:Type) (i:inhabited A) (P:A->Prop), 
+  (exists x, P x) -> P (epsilon A i P).
+
+Hypothesis epsilon_extensionality :
+  forall (A:Type) (i:inhabited A) (P Q:A->Prop),
+  (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.
+
+Notation Local eps := (epsilon bool true) (only parsing).
+
+Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
+Proof.
+  intro P.
+  pose (B := fun y => y=false \/ P).
+  pose (C := fun y => y=true  \/ P).
+  assert (B (eps B)) as [Hfalse|HP] 
+    by (apply epsilon_spec; exists false; left; reflexivity).
+  assert (C (eps C)) as [Htrue|HP] 
+    by (apply epsilon_spec; exists true; left; reflexivity).
+    right; intro HP.
+    assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
+    rewrite epsilon_extensionality with (1:=H) in Hfalse.
+    rewrite Htrue in Hfalse.
+    discriminate.
+  auto.
+  auto.
+Qed.
+
+End ExtensionalEpsilon_imp_EM.
diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v
index 24905039..2fe9d1a6 100755..100644
--- a/theories/Logic/Eqdep.v
+++ b/theories/Logic/Eqdep.v
@@ -6,183 +6,29 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Eqdep.v,v 1.10.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: Eqdep.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
-(** This file defines dependent equality and shows its equivalence with
-    equality on dependent pairs (inhabiting sigma-types). It axiomatizes
-    the invariance by substitution of reflexive equality proofs and 
-    shows the equivalence between the 4 following statements
+(** This file axiomatizes the invariance by substitution of reflexive
+    equality proofs [[Streicher93]] and exports its consequences, such
+    as the injectivity of the projection of the dependent pair.
 
-    - Invariance by Substitution of Reflexive Equality Proofs.
-    - Injectivity of Dependent Equality
-    - Uniqueness of Identity Proofs
-    - Uniqueness of Reflexive Identity Proofs
-    - Streicher's Axiom K
-
-  These statements are independent of the calculus of constructions [2].
-
-  References:
-
-  [1] T. Streicher, Semantical Investigations into Intensional Type Theory,
-      Habilitationsschrift, LMU München, 1993.
-  [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory,
-      Proceedings of the meeting Twenty-five years of constructive
-      type theory, Venice, Oxford University Press, 1998
+    [[Streicher93]] T. Streicher, Semantical Investigations into
+    Intensional Type Theory, Habilitationsschrift, LMU München, 1993.
 *)
 
-Section Dependent_Equality.
-
-Variable U : Type.
-Variable P : U -> Type.
-
-(** Dependent equality *)
-
-Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop :=
-    eq_dep_intro : eq_dep p x p x.
-Hint Constructors eq_dep: core v62.
-
-Lemma eq_dep_sym :
- forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x.
-Proof.
-destruct 1; auto.
-Qed.
-Hint Immediate eq_dep_sym: core v62.
+Require Export EqdepFacts.
 
-Lemma eq_dep_trans :
- forall (p q r:U) (x:P p) (y:P q) (z:P r),
-   eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z.
-Proof.
-destruct 1; auto.
-Qed.
-
-Scheme eq_indd := Induction for eq Sort Prop.
-
-Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop :=
-    eq_dep1_intro : forall h:q = p, x = eq_rect q P y p h -> eq_dep1 p x q y.
-
-Lemma eq_dep1_dep :
- forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y.
-Proof.
-destruct 1 as (eq_qp, H).
-destruct eq_qp using eq_indd.
-rewrite H.
-apply eq_dep_intro.
-Qed.
-
-Lemma eq_dep_dep1 :
- forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y.
-Proof.
-destruct 1.
-apply eq_dep1_intro with (refl_equal p).
-simpl in |- *; trivial.
-Qed.
-
-(** Invariance by Substitution of Reflexive Equality Proofs *)
+Module Eq_rect_eq.
 
 Axiom eq_rect_eq :
-    forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
-
-(** Injectivity of Dependent Equality is a consequence of *)
-(** Invariance by Substitution of Reflexive Equality Proof *)
-
-Lemma eq_dep1_eq : forall (p:U) (x y:P p), eq_dep1 p x p y -> x = y.
-Proof.
-simple destruct 1; intro.
-rewrite <- eq_rect_eq; auto.
-Qed.
-
-Lemma eq_dep_eq : forall (p:U) (x y:P p), eq_dep p x p y -> x = y.
-Proof.
-intros; apply eq_dep1_eq; apply eq_dep_dep1; trivial.
-Qed.
-
-End Dependent_Equality.
-
-(** Uniqueness of Identity Proofs (UIP) is a consequence of *)
-(** Injectivity of Dependent Equality *)
-
-Lemma UIP : forall (U:Type) (x y:U) (p1 p2:x = y), p1 = p2.
-Proof.
-intros; apply eq_dep_eq with (P := fun y => x = y).
-elim p2 using eq_indd.
-elim p1 using eq_indd.
-apply eq_dep_intro.
-Qed.
-
-(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)
-
-Lemma UIP_refl : forall (U:Type) (x:U) (p:x = x), p = refl_equal x.
-Proof.
-intros; apply UIP.
-Qed.
-
-(** Streicher axiom K is a direct consequence of Uniqueness of
-    Reflexive Identity Proofs *)
-
-Lemma Streicher_K :
- forall (U:Type) (x:U) (P:x = x -> Prop),
-   P (refl_equal x) -> forall p:x = x, P p.
-Proof.
-intros; rewrite UIP_refl; assumption.
-Qed.
-
-(** We finally recover eq_rec_eq (alternatively eq_rect_eq) from K *)
-
-Lemma eq_rec_eq :
- forall (U:Type) (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.
-Proof.
-intros.
-apply Streicher_K with (p := h).
-reflexivity.
-Qed.
-
-(** Dependent equality is equivalent to equality on dependent pairs *)
-
-Lemma equiv_eqex_eqdep :
- forall (U:Set) (P:U -> Set) (p q:U) (x:P p) (y:P q),
-   existS P p x = existS P q y <-> eq_dep U P p x q y.
-Proof.
-split. 
-(* -> *)
-intro H.
-change p with (projS1 (existS P p x)) in |- *.
-change x at 2 with (projS2 (existS P p x)) in |- *.
-rewrite H.
-apply eq_dep_intro.
-(* <- *)
-destruct 1; reflexivity.
-Qed.
-
-(** UIP implies the injectivity of equality on dependent pairs *)
-
-Lemma inj_pair2 :
- forall (U:Set) (P:U -> Set) (p:U) (x y:P p),
-   existS P p x = existS P p y -> x = y.
-Proof.
-intros.
-apply (eq_dep_eq U P).
-generalize (equiv_eqex_eqdep U P p p x y).
-simple induction 1.
-intros.
-auto.
-Qed.
+  forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
 
-(** UIP implies the injectivity of equality on dependent pairs *)
+End Eq_rect_eq.
 
-Lemma inj_pairT2 :
- forall (U:Type) (P:U -> Type) (p:U) (x y:P p),
-   existT P p x = existT P p y -> x = y.
-Proof.
-intros.
-apply (eq_dep_eq U P).
-change p at 1 with (projT1 (existT P p x)) in |- *.
-change x at 2 with (projT2 (existT P p x)) in |- *.
-rewrite H.
-apply eq_dep_intro.
-Qed.
+Module EqdepTheory := EqdepTheory(Eq_rect_eq).
+Export EqdepTheory.
 
-(** The main results to be exported *)
+(** Exported hints *)
 
-Hint Resolve eq_dep_intro eq_dep_eq: core v62.
-Hint Immediate eq_dep_sym: core v62.
+Hint Resolve eq_dep_eq: core v62.
 Hint Resolve inj_pair2 inj_pairT2: core.
diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v
new file mode 100644
index 00000000..94a577ca
--- /dev/null
+++ b/theories/Logic/EqdepFacts.v
@@ -0,0 +1,336 @@
+(************************************************************************)
+(*  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: EqdepFacts.v 9597 2007-02-06 19:44:05Z herbelin $ i*)
+
+(** This file defines dependent equality and shows its equivalence with
+    equality on dependent pairs (inhabiting sigma-types). It derives
+    the consequence of axiomatizing the invariance by substitution of
+    reflexive equality proofs and shows the equivalence between the 4
+    following statements
+
+    - Invariance by Substitution of Reflexive Equality Proofs.
+    - Injectivity of Dependent Equality
+    - Uniqueness of Identity Proofs
+    - Uniqueness of Reflexive Identity Proofs
+    - Streicher's Axiom K
+
+  These statements are independent of the calculus of constructions [2].
+
+  References:
+
+  [1] T. Streicher, Semantical Investigations into Intensional Type Theory,
+      Habilitationsschrift, LMU München, 1993.
+  [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory,
+      Proceedings of the meeting Twenty-five years of constructive
+      type theory, Venice, Oxford University Press, 1998
+
+Table of contents:
+
+1. Definition of dependent equality and equivalence with equality
+
+2. Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K
+
+3. Definition of the functor that builds properties of dependent
+   equalities assuming axiom eq_rect_eq
+
+*)
+
+(************************************************************************)
+(** * Definition of dependent equality and equivalence with equality of dependent pairs *)
+
+Section Dependent_Equality.
+  
+  Variable U : Type.
+  Variable P : U -> Type.
+
+  (** Dependent equality *)
+
+  Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop :=
+    eq_dep_intro : eq_dep p x p x.
+  Hint Constructors eq_dep: core v62.
+
+  Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x.
+  Proof eq_dep_intro.
+
+  Lemma eq_dep_sym :
+    forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x.
+  Proof.
+    destruct 1; auto.
+  Qed.
+  Hint Immediate eq_dep_sym: core v62.
+
+  Lemma eq_dep_trans :
+    forall (p q r:U) (x:P p) (y:P q) (z:P r),
+      eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z.
+  Proof.
+    destruct 1; auto.
+  Qed.
+
+  Scheme eq_indd := Induction for eq Sort Prop.
+
+  (** Equivalent definition of dependent equality expressed as a non
+      dependent inductive type *)
+
+  Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop :=
+    eq_dep1_intro : forall h:q = p, x = eq_rect q P y p h -> eq_dep1 p x q y.
+
+  Lemma eq_dep1_dep :
+    forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y.
+  Proof.
+    destruct 1 as (eq_qp, H).
+    destruct eq_qp using eq_indd.
+    rewrite H.
+    apply eq_dep_intro.
+  Qed.
+
+  Lemma eq_dep_dep1 :
+    forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y.
+  Proof.
+    destruct 1.
+    apply eq_dep1_intro with (refl_equal p).
+    simpl in |- *; trivial.
+  Qed.
+
+End Dependent_Equality.
+
+Implicit Arguments eq_dep [U P].
+Implicit Arguments eq_dep1 [U P].
+
+(** Dependent equality is equivalent to equality on dependent pairs *)
+
+Lemma eq_sigS_eq_dep :
+  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
+    existT P p x = existT P q y -> eq_dep p x q y.
+Proof.
+  intros.
+  dependent rewrite H.
+  apply eq_dep_intro.
+Qed.
+
+Lemma equiv_eqex_eqdep :
+  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
+   existS P p x = existS P q y <-> eq_dep p x q y.
+Proof.
+  split. 
+  (* -> *)
+  apply eq_sigS_eq_dep.
+  (* <- *)
+  destruct 1; reflexivity.
+Qed.
+
+Lemma eq_sigT_eq_dep :
+  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
+    existT P p x = existT P q y -> eq_dep p x q y.
+Proof.
+  intros.
+  dependent rewrite H.
+  apply eq_dep_intro.
+Qed.
+
+Lemma eq_dep_eq_sigT :
+  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
+    eq_dep p x q y -> existT P p x = existT P q y.
+Proof.
+  destruct 1; reflexivity.
+Qed.
+
+(** Exported hints *)
+
+Hint Resolve eq_dep_intro: core v62.
+Hint Immediate eq_dep_sym: core v62.
+
+(************************************************************************)
+(** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K          *)
+
+Section Equivalences.
+  
+  Variable U:Type.
+  
+  (** Invariance by Substitution of Reflexive Equality Proofs *)
+  
+  Definition Eq_rect_eq := 
+    forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
+  
+  (** Injectivity of Dependent Equality *)
+  
+  Definition Eq_dep_eq := 
+    forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y.
+  
+  (** Uniqueness of Identity Proofs (UIP) *)
+  
+  Definition UIP_ := 
+    forall (x y:U) (p1 p2:x = y), p1 = p2.
+  
+  (** Uniqueness of Reflexive Identity Proofs *)
+
+  Definition UIP_refl_ := 
+    forall (x:U) (p:x = x), p = refl_equal x.
+
+  (** Streicher's axiom K *)
+
+  Definition Streicher_K_ :=
+    forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+
+  (** Injectivity of Dependent Equality is a consequence of *)
+  (** Invariance by Substitution of Reflexive Equality Proof *)
+
+  Lemma eq_rect_eq__eq_dep1_eq :
+    Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y.
+  Proof.
+    intro eq_rect_eq.
+    simple destruct 1; intro.
+    rewrite <- eq_rect_eq; auto.
+  Qed.
+
+  Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq.
+  Proof.
+    intros eq_rect_eq; red; intros.
+    apply (eq_rect_eq__eq_dep1_eq eq_rect_eq); apply eq_dep_dep1; trivial.
+  Qed.
+
+  (** Uniqueness of Identity Proofs (UIP) is a consequence of *)
+  (** Injectivity of Dependent Equality *)
+
+  Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_.
+  Proof.
+    intro eq_dep_eq; red.
+    intros; apply eq_dep_eq with (P := fun y => x = y).
+    elim p2 using eq_indd.
+    elim p1 using eq_indd.
+    apply eq_dep_intro.
+  Qed.
+  
+  (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)
+
+  Lemma UIP__UIP_refl : UIP_ -> UIP_refl_.
+  Proof.
+    intro UIP; red; intros; apply UIP.
+  Qed.
+
+  (** Streicher's axiom K is a direct consequence of Uniqueness of
+      Reflexive Identity Proofs *)
+
+  Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_.
+  Proof.
+    intro UIP_refl; red; intros; rewrite UIP_refl; assumption.
+  Qed.
+
+  (** We finally recover from K the Invariance by Substitution of
+      Reflexive Equality Proofs *)
+  
+  Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq.
+  Proof.
+    intro Streicher_K; red; intros.
+    apply Streicher_K with (p := h).
+    reflexivity.
+  Qed.
+
+(** Remark: It is reasonable to think that [eq_rect_eq] is strictly
+    stronger than [eq_rec_eq] (which is [eq_rect_eq] restricted on [Set]):
+
+   [Definition Eq_rec_eq :=
+      forall (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.]
+
+    Typically, [eq_rect_eq] allows to prove UIP and Streicher's K what
+    does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP]
+    requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not
+    in [Set].  
+*)
+
+End Equivalences.
+
+Section Corollaries.
+  
+  Variable U:Type.
+  
+  (** UIP implies the injectivity of equality on dependent pairs in Type *)
+ 
+ Definition Inj_dep_pair :=
+   forall (P:U -> Type) (p:U) (x y:P p), existT P p x = existT P p y -> x = y.
+ 
+ Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair.
+ Proof.
+   intro eq_dep_eq; red; intros.
+   apply eq_dep_eq.
+   apply eq_sigS_eq_dep.
+   assumption.
+ Qed.
+
+End Corollaries.
+
+Notation Inj_dep_pairS := Inj_dep_pair.
+Notation Inj_dep_pairT := Inj_dep_pair.
+Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2.
+ 
+
+(************************************************************************)
+(** *** C. Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *)
+
+Module Type EqdepElimination.
+
+  Axiom eq_rect_eq :
+    forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
+      x = eq_rect p Q x p h.
+
+End EqdepElimination.
+
+Module EqdepTheory (M:EqdepElimination).
+  
+  Section Axioms.
+    
+    Variable U:Type.
+    
+(** Invariance by Substitution of Reflexive Equality Proofs *)
+
+Lemma eq_rect_eq :
+  forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
+Proof M.eq_rect_eq U.
+
+Lemma eq_rec_eq :
+  forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rec p Q x p h.
+Proof (fun p Q => M.eq_rect_eq U p Q).
+
+(** Injectivity of Dependent Equality *)
+
+Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y.
+Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq).
+
+(** Uniqueness of Identity Proofs (UIP) is a consequence of *)
+(** Injectivity of Dependent Equality *)
+
+Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
+Proof (eq_dep_eq__UIP U eq_dep_eq).
+
+(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)
+
+Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x.
+Proof (UIP__UIP_refl U UIP).
+
+(** Streicher's axiom K is a direct consequence of Uniqueness of
+    Reflexive Identity Proofs *)
+
+Lemma Streicher_K :
+  forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+Proof (UIP_refl__Streicher_K U UIP_refl).
+
+End Axioms.
+
+(** UIP implies the injectivity of equality on dependent pairs in Type *)
+
+Lemma inj_pair2 :
+ forall (U:Type) (P:U -> Type) (p:U) (x y:P p),
+   existT P p x = existT P p y -> x = y.
+Proof (fun U => eq_dep_eq__inj_pair2 U (eq_dep_eq U)).
+
+Notation inj_pairT2 := inj_pair2.
+
+End EqdepTheory.
+
+Implicit Arguments eq_dep [].
+Implicit Arguments eq_dep1 [].
diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v
index 7caf403c..103efd22 100644
--- a/theories/Logic/Eqdep_dec.v
+++ b/theories/Logic/Eqdep_dec.v
@@ -6,153 +6,293 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Eqdep_dec.v,v 1.14.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+(*i $Id: Eqdep_dec.v 9597 2007-02-06 19:44:05Z herbelin $ i*)
 
-(** We prove that there is only one proof of [x=x], i.e [(refl_equal ? x)].
-   This holds if the equality upon the set of [x] is decidable.
-   A corollary of this theorem is the equality of the right projections
-   of two equal dependent pairs.
+(** We prove that there is only one proof of [x=x], i.e [refl_equal x].
+    This holds if the equality upon the set of [x] is decidable.
+    A corollary of this theorem is the equality of the right projections
+    of two equal dependent pairs.
 
-   Author:   Thomas Kleymann |<tms@dcs.ed.ac.uk>| in Lego
-             adapted to Coq by B. Barras
+    Author:   Thomas Kleymann |<tms@dcs.ed.ac.uk>| in Lego
+              adapted to Coq by B. Barras
 
-   Credit:   Proofs up to [K_dec] follows an outline by Michael Hedberg
-*)
+    Credit:   Proofs up to [K_dec] follow an outline by Michael Hedberg
 
+Table of contents:
 
-(** We need some dependent elimination schemes *)
+1. Streicher's K and injectivity of dependent pair hold on decidable types
 
-Set Implicit Arguments.
+1.1. Definition of the functor that builds properties of dependent equalities
+     from a proof of decidability of equality for a set in Type
 
-  (** Bijection between [eq] and [eqT] *)
-  Definition eq2eqT (A:Set) (x y:A) (eqxy:x = y) : 
-    x = y :=
-    match eqxy in (_ = y) return x = y with
-    | refl_equal => refl_equal x
-    end.
-
-  Definition eqT2eq (A:Set) (x y:A) (eqTxy:x = y) : 
-    x = y :=
-    match eqTxy in (_ = y) return x = y with
-    | refl_equal => refl_equal x
-    end.
+1.2. Definition of the functor that builds properties of dependent equalities
+     from a proof of decidability of equality for a set in Set
 
-  Lemma eq_eqT_bij : forall (A:Set) (x y:A) (p:x = y), p = eqT2eq (eq2eqT p).
-intros.
-case p; reflexivity.
-Qed.
+*)
 
-  Lemma eqT_eq_bij : forall (A:Set) (x y:A) (p:x = y), p = eq2eqT (eqT2eq p).
-intros.
-case p; reflexivity.
-Qed.
+(************************************************************************)
+(** * Streicher's K and injectivity of dependent pair hold on decidable types *)
 
+Set Implicit Arguments.
 
-Section DecidableEqDep.
+Section EqdepDec.
 
   Variable A : Type.
-
+  
   Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
     eq_ind _ (fun a => a = y') eq2 _ eq1.
 
-  Remark trans_sym_eqT : forall (x y:A) (u:x = y), comp u u = refl_equal y.
-intros.
-case u; trivial.
-Qed.
-
-
+  Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = refl_equal y.
+  Proof.
+    intros.
+    case u; trivial.
+  Qed.
 
   Variable eq_dec : forall x y:A, x = y \/ x <> y.
-
+  
   Variable x : A.
 
-
   Let nu (y:A) (u:x = y) : x = y :=
     match eq_dec x y with
-    | or_introl eqxy => eqxy
-    | or_intror neqxy => False_ind _ (neqxy u)
+      | or_introl eqxy => eqxy
+      | or_intror neqxy => False_ind _ (neqxy u)
     end.
 
   Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
-intros.
-unfold nu in |- *.
-case (eq_dec x y); intros.
-reflexivity.
-
-case n; trivial.
-Qed.
+    intros.
+    unfold nu in |- *.
+    case (eq_dec x y); intros.
+    reflexivity.
+  
+    case n; trivial.
+  Qed.
 
 
   Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v.
-
+  
 
   Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u.
-intros.
-case u; unfold nu_inv in |- *.
-apply trans_sym_eqT.
-Qed.
+  Proof.
+    intros.
+    case u; unfold nu_inv in |- *.
+    apply trans_sym_eq.
+  Qed.
 
 
   Theorem eq_proofs_unicity : forall (y:A) (p1 p2:x = y), p1 = p2.
-intros.
-elim nu_left_inv with (u := p1).
-elim nu_left_inv with (u := p2).
-elim nu_constant with y p1 p2.
-reflexivity.
-Qed.
-
-  Theorem K_dec :
-   forall P:x = x -> Prop, P (refl_equal x) -> forall p:x = x, P p.
-intros.
-elim eq_proofs_unicity with x (refl_equal x) p.
-trivial.
-Qed.
-
+  Proof.
+    intros.
+    elim nu_left_inv with (u := p1).
+    elim nu_left_inv with (u := p2).
+    elim nu_constant with y p1 p2.
+    reflexivity.
+  Qed.
+
+  Theorem K_dec : 
+    forall P:x = x -> Prop, P (refl_equal x) -> forall p:x = x, P p.
+  Proof.
+    intros.
+    elim eq_proofs_unicity with x (refl_equal x) p.
+    trivial.
+  Qed.
 
   (** The corollary *)
 
   Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x :=
     match exP with
-    | ex_intro x' prf =>
+      | ex_intro x' prf =>
         match eq_dec x' x with
-        | or_introl eqprf => eq_ind x' P prf x eqprf
-        | _ => def
+          | or_introl eqprf => eq_ind x' P prf x eqprf
+          | _ => def
         end
     end.
 
 
   Theorem inj_right_pair :
-   forall (P:A -> Prop) (y y':P x),
-     ex_intro P x y = ex_intro P x y' -> y = y'.
-intros.
-cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y).
-simpl in |- *.
-case (eq_dec x x).
-intro e.
-elim e using K_dec; trivial.
-
-intros.
-case n; trivial.
-
-case H.
-reflexivity.
+    forall (P:A -> Prop) (y y':P x),
+      ex_intro P x y = ex_intro P x y' -> y = y'.
+  Proof.
+    intros.
+    cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y).
+    simpl in |- *.
+    case (eq_dec x x).
+    intro e.
+    elim e using K_dec; trivial.
+    
+    intros.
+    case n; trivial.
+    
+    case H.
+    reflexivity.
+  Qed.
+
+End EqdepDec.
+
+Require Import EqdepFacts.
+
+(** We deduce axiom [K] for (decidable) types *)
+Theorem K_dec_type :
+  forall A:Type,
+    (forall x y:A, {x = y} + {x <> y}) ->
+    forall (x:A) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+Proof.
+  intros A eq_dec x P H p.
+  elim p using K_dec; intros.
+  case (eq_dec x0 y); [left|right]; assumption.
+  trivial.
 Qed.
 
+Theorem K_dec_set :
+  forall A:Set,
+    (forall x y:A, {x = y} + {x <> y}) ->
+    forall (x:A) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+Proof fun A => K_dec_type (A:=A).
+
+(** We deduce the [eq_rect_eq] axiom for (decidable) types *)
+Theorem eq_rect_eq_dec :
+  forall A:Type,
+    (forall x y:A, {x = y} + {x <> y}) ->
+    forall (p:A) (Q:A -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
+Proof.
+  intros A eq_dec.
+  apply (Streicher_K__eq_rect_eq A (K_dec_type eq_dec)).
+Qed.
+
+Unset Implicit Arguments.
+
+(************************************************************************)
+(** ** Definition of the functor that builds properties of dependent equalities on decidable sets in Type *)
+
+(** The signature of decidable sets in [Type] *)
+
+Module Type DecidableType.
+  
+  Parameter U:Type.
+  Axiom eq_dec : forall x y:U, {x = y} + {x <> y}.
+
+End DecidableType.
+
+(** The module [DecidableEqDep] collects equality properties for decidable 
+    set in [Type] *)
+
+Module DecidableEqDep (M:DecidableType).
+
+  Import M.
+
+  (** Invariance by Substitution of Reflexive Equality Proofs *)
+
+  Lemma eq_rect_eq :
+    forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
+  Proof eq_rect_eq_dec eq_dec.
+
+  (** Injectivity of Dependent Equality *)
+
+  Theorem eq_dep_eq :
+    forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y.
+  Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq).
+
+  (** Uniqueness of Identity Proofs (UIP) *)
+
+  Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
+  Proof (eq_dep_eq__UIP U eq_dep_eq).
+
+  (** Uniqueness of Reflexive Identity Proofs *)
+
+  Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x.
+  Proof (UIP__UIP_refl U UIP).
+
+  (** Streicher's axiom K *)
+
+  Lemma Streicher_K :
+    forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+  Proof (K_dec_type eq_dec).
+
+  (** Injectivity of equality on dependent pairs in [Type] *)
+
+  Lemma inj_pairT2 :
+    forall (P:U -> Type) (p:U) (x y:P p),
+      existT P p x = existT P p y -> x = y.
+  Proof eq_dep_eq__inj_pairT2 U eq_dep_eq.
+
+  (** Proof-irrelevance on subsets of decidable sets *)
+
+  Lemma inj_pairP2 :
+    forall (P:U -> Prop) (x:U) (p q:P x),
+      ex_intro P x p = ex_intro P x q -> p = q.
+  Proof.
+    intros.
+    apply inj_right_pair with (A:=U).
+    intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption.
+    assumption.
+  Qed.
+
 End DecidableEqDep.
 
-  (** We deduce the [K] axiom for (decidable) Set *)
-  Theorem K_dec_set :
-   forall A:Set,
-     (forall x y:A, {x = y} + {x <> y}) ->
-     forall (x:A) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
-intros.
-rewrite eq_eqT_bij.
-elim (eq2eqT p) using K_dec.
-intros.
-case (H x0 y); intros.
-elim e; left; reflexivity.
-
-right; red in |- *; intro neq; apply n; elim neq; reflexivity.
-
-trivial.
-Qed.
\ No newline at end of file
+(************************************************************************)
+(** ** B Definition of the functor that builds properties of dependent equalities on decidable sets in Set *)
+
+(** The signature of decidable sets in [Set] *)
+
+Module Type DecidableSet.
+
+  Parameter U:Type.
+  Axiom eq_dec : forall x y:U, {x = y} + {x <> y}.
+
+End DecidableSet.
+
+(** The module [DecidableEqDepSet] collects equality properties for decidable 
+    set in [Set] *)
+
+Module DecidableEqDepSet (M:DecidableSet).
+
+  Import M.
+  Module N:=DecidableEqDep(M).
+
+  (** Invariance by Substitution of Reflexive Equality Proofs *)
+
+  Lemma eq_rect_eq :
+    forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
+  Proof eq_rect_eq_dec eq_dec.
+
+  (** Injectivity of Dependent Equality *)
+
+  Theorem eq_dep_eq :
+    forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y.
+  Proof N.eq_dep_eq.
+
+  (** Uniqueness of Identity Proofs (UIP) *)
+
+  Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
+  Proof N.UIP.
+
+  (** Uniqueness of Reflexive Identity Proofs *)
+
+  Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x.
+  Proof N.UIP_refl.
+
+  (** Streicher's axiom K *)
+
+  Lemma Streicher_K :
+    forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+  Proof N.Streicher_K.
+
+  (** Proof-irrelevance on subsets of decidable sets *)
+
+  Lemma inj_pairP2 :
+    forall (P:U -> Prop) (x:U) (p q:P x),
+      ex_intro P x p = ex_intro P x q -> p = q.
+  Proof N.inj_pairP2.
+
+  (** Injectivity of equality on dependent pairs in [Type] *)
+
+  Lemma inj_pair2 :
+    forall (P:U -> Type) (p:U) (x y:P p),
+      existS P p x = existS P p y -> x = y.
+  Proof eq_dep_eq__inj_pair2 U N.eq_dep_eq.
+
+  (** Injectivity of equality on dependent pairs with second component
+      in [Type] *)
+
+  Notation inj_pairT2 := inj_pair2.
+
+End DecidableEqDepSet.
diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v
index 4666d9b4..6a723e43 100644
--- a/theories/Logic/JMeq.v
+++ b/theories/Logic/JMeq.v
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: JMeq.v,v 1.8.2.2 2004/08/03 17:42:32 herbelin Exp $ i*)
+(*i $Id: JMeq.v 9077 2006-08-24 08:44:32Z herbelin $ i*)
 
-(** John Major's Equality as proposed by C. Mc Bride
+(** John Major's Equality as proposed by Conor McBride
 
   Reference:
 
@@ -19,56 +19,65 @@
 
 Set Implicit Arguments.
 
-Inductive JMeq (A:Set) (x:A) : forall B:Set, B -> Prop :=
+Inductive JMeq (A:Type) (x:A) : forall B:Type, B -> Prop :=
     JMeq_refl : JMeq x x.
-Reset JMeq_ind.
+Reset JMeq_rect.
 
 Hint Resolve JMeq_refl.
 
-Lemma sym_JMeq : forall (A B:Set) (x:A) (y:B), JMeq x y -> JMeq y x.
+Lemma sym_JMeq : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x.
 destruct 1; trivial.
 Qed.
 
 Hint Immediate sym_JMeq.
 
 Lemma trans_JMeq :
- forall (A B C:Set) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z.
+ forall (A B C:Type) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z.
 destruct 1; trivial.
 Qed.
 
-Axiom JMeq_eq : forall (A:Set) (x y:A), JMeq x y -> x = y.
+Axiom JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y.
 
-Lemma JMeq_ind : forall (A:Set) (x y:A) (P:A -> Prop), P x -> JMeq x y -> P y.
+Lemma JMeq_ind : forall (A:Type) (x y:A) (P:A -> Prop), P x -> JMeq x y -> P y.
 intros A x y P H H'; case JMeq_eq with (1 := H'); trivial.
 Qed.
 
-Lemma JMeq_rec : forall (A:Set) (x y:A) (P:A -> Set), P x -> JMeq x y -> P y.
+Lemma JMeq_rec : forall (A:Type) (x y:A) (P:A -> Set), P x -> JMeq x y -> P y.
+intros A x y P H H'; case JMeq_eq with (1 := H'); trivial.
+Qed.
+
+Lemma JMeq_rect : forall (A:Type) (x y:A) (P:A->Type), P x -> JMeq x y -> P y.
 intros A x y P H H'; case JMeq_eq with (1 := H'); trivial.
 Qed.
 
 Lemma JMeq_ind_r :
- forall (A:Set) (x y:A) (P:A -> Prop), P y -> JMeq x y -> P x.
+ forall (A:Type) (x y:A) (P:A -> Prop), P y -> JMeq x y -> P x.
 intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial.
 Qed.
 
 Lemma JMeq_rec_r :
- forall (A:Set) (x y:A) (P:A -> Set), P y -> JMeq x y -> P x.
+ forall (A:Type) (x y:A) (P:A -> Set), P y -> JMeq x y -> P x.
+intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial.
+Qed.
+
+Lemma JMeq_rect_r :
+ forall (A:Type) (x y:A) (P:A -> Type), P y -> JMeq x y -> P x.
 intros A x y P H H'; case JMeq_eq with (1 := sym_JMeq H'); trivial.
 Qed.
 
-(** [JMeq] is equivalent to [(eq_dep Set [X]X)] *)
+(** [JMeq] is equivalent to [(eq_dep Type [X]X)] *)
 
 Require Import Eqdep.
 
 Lemma JMeq_eq_dep :
- forall (A B:Set) (x:A) (y:B), JMeq x y -> eq_dep Set (fun X => X) A x B y.
+ forall (A B:Type) (x:A) (y:B), JMeq x y -> eq_dep Type (fun X => X) A x B y.
 Proof.
 destruct 1.
 apply eq_dep_intro.
 Qed.
 
 Lemma eq_dep_JMeq :
- forall (A B:Set) (x:A) (y:B), eq_dep Set (fun X => X) A x B y -> JMeq x y.
+ forall (A B:Type) (x:A) (y:B), eq_dep Type (fun X => X) A x B y -> JMeq x y.
 Proof.
 destruct 1.
 apply JMeq_refl. 
diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v
index afdc0ffe..44ab9a2e 100644
--- a/theories/Logic/ProofIrrelevance.v
+++ b/theories/Logic/ProofIrrelevance.v
@@ -6,109 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** This is a proof in the pure Calculus of Construction that
-    classical logic in Prop + dependent elimination of disjunction entails
-    proof-irrelevance.
+(** This file axiomatizes proof-irrelevance and derives some consequences *)
 
-    Since, dependent elimination is derivable in the Calculus of
-    Inductive Constructions (CCI), we get proof-irrelevance from classical
-    logic in the CCI.
+Require Import ProofIrrelevanceFacts.
 
-    Reference:
+Axiom proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
 
-    - [Coquand] T. Coquand, "Metamathematical Investigations of a
-      Calculus of Constructions", Proceedings of Logic in Computer Science
-      (LICS'90), 1990.
+Module PI. Definition proof_irrelevance := proof_irrelevance. End PI.
 
-    Proof skeleton: classical logic + dependent elimination of
-    disjunction + discrimination of proofs implies the existence of a
-    retract from [Prop] into [bool], hence inconsistency by encoding any
-    paradox of system U- (e.g. Hurkens' paradox).
-*)
-
-Require Import Hurkens.
-
-Section Proof_irrelevance_CC.
-
-Variable or : Prop -> Prop -> Prop.
-Variable or_introl : forall A B:Prop, A -> or A B.
-Variable or_intror : forall A B:Prop, B -> or A B.
-Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C.
-Hypothesis
-  or_elim_redl :
-    forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A),
-      f a = or_elim A B C f g (or_introl A B a).
-Hypothesis
-  or_elim_redr :
-    forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B),
-      g b = or_elim A B C f g (or_intror A B b).
-Hypothesis
-  or_dep_elim :
-    forall (A B:Prop) (P:or A B -> Prop),
-      (forall a:A, P (or_introl A B a)) ->
-      (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.
-
-Hypothesis em : forall A:Prop, or A (~ A).
-Variable B : Prop.
-Variables b1 b2 : B.
-
-(** [p2b] and [b2p] form a retract if [~b1=b2] *)
-
-Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A).
-Definition b2p b := b1 = b.
-
-Lemma p2p1 : forall A:Prop, A -> b2p (p2b A).
-Proof.
-  unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A);
-   unfold b2p in |- *; intros.
-  apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)).
-  destruct (b H).
-Qed.
-Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A.
-Proof.
-  intro not_eq_b1_b2.
-  unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A);
-   unfold b2p in |- *; intros.
-  assumption.
-  destruct not_eq_b1_b2.
-  rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H.
-  assumption.
-Qed.
-
-(** Using excluded-middle a second time, we get proof-irrelevance *)
-
-Theorem proof_irrelevance_cc : b1 = b2.
-Proof.
-  refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H.
-    trivial.
-  apply (paradox B p2b b2p (p2p2 H) p2p1).
-Qed.
-
-End Proof_irrelevance_CC.
-
-
-(** The Calculus of Inductive Constructions (CCI) enjoys dependent
-    elimination, hence classical logic in CCI entails proof-irrelevance.
-*)
-
-Section Proof_irrelevance_CCI.
-
-Hypothesis em : forall A:Prop, A \/ ~ A.
-
-Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) 
-  (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a).
-Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) 
-  (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b).
-Scheme or_indd := Induction for or Sort Prop.
-
-Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2.
-Proof
-  proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
-    or_elim_redr or_indd em.
-
-End Proof_irrelevance_CCI.
-
-(** Remark: in CCI, [bool] can be taken in [Set] as well in the
-    paradox and since [~true=false] for [true] and [false] in
-    [bool], we get the inconsistency of [em : forall A:Prop, {A}+{~A}] in CCI
-*)
+Module ProofIrrelevanceTheory := ProofIrrelevanceTheory(PI).
+Export ProofIrrelevanceTheory.
diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v
new file mode 100644
index 00000000..dd3178eb
--- /dev/null
+++ b/theories/Logic/ProofIrrelevanceFacts.v
@@ -0,0 +1,62 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This defines the functor that build consequences of proof-irrelevance *)
+
+Require Export EqdepFacts.
+
+Module Type ProofIrrelevance.
+
+  Axiom proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
+
+End ProofIrrelevance.
+
+Module ProofIrrelevanceTheory (M:ProofIrrelevance).
+
+  (** Proof-irrelevance implies uniqueness of reflexivity proofs *)
+
+  Module Eq_rect_eq.
+    Lemma eq_rect_eq : 
+      forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), 
+        x = eq_rect p Q x p h.
+    Proof.
+      intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=refl_equal p).
+      reflexivity.
+    Qed.
+  End Eq_rect_eq.
+
+  (** Export the theory of injective dependent elimination *)
+
+  Module EqdepTheory := EqdepTheory(Eq_rect_eq).
+  Export EqdepTheory.
+
+  Scheme eq_indd := Induction for eq Sort Prop.
+
+  (** We derive the irrelevance of the membership property for subsets *)
+
+  Lemma subset_eq_compat :
+    forall (U:Set) (P:U->Prop) (x y:U) (p:P x) (q:P y),
+      x = y -> exist P x p = exist P y q.
+  Proof.
+    intros.
+    rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H).
+    elim H using eq_indd.
+    reflexivity.
+  Qed.
+
+  Lemma subsetT_eq_compat :
+    forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y),
+      x = y -> existT P x p = existT P y q.
+  Proof.
+    intros.
+    rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H).
+    elim H using eq_indd.
+    reflexivity.
+  Qed.
+
+End ProofIrrelevanceTheory.
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
index 08873aa5..ec168f09 100644
--- a/theories/Logic/RelationalChoice.v
+++ b/theories/Logic/RelationalChoice.v
@@ -6,15 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RelationalChoice.v,v 1.3.2.2 2004/08/01 09:29:59 herbelin Exp $ i*)
+(*i $Id: RelationalChoice.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
 
 (** This file axiomatizes the relational form of the axiom of choice *)
 
-Axiom
-  relational_choice :
-    forall (A B:Type) (R:A -> B -> Prop),
-      (forall x:A,  exists y : B, R x y) ->
-       exists R' : A -> B -> Prop,
-        (forall x:A,
-            exists y : B,
-             R x y /\ R' x y /\ (forall y':B, R' x y' -> y = y')).
+Axiom relational_choice :
+  forall (A B : Type) (R : A->B->Prop),
+   (forall x : A, exists y : B, R x y) ->
+     exists R' : A->B->Prop, 
+       subrelation R' R /\ forall x : A, exists! y : B, R' x y.
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
index e6a14938..78353145 100644
--- a/theories/NArith/BinNat.v
+++ b/theories/NArith/BinNat.v
@@ -6,9 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinNat.v,v 1.7.2.1 2004/07/16 19:31:07 herbelin Exp $ i*)
+(*i $Id: BinNat.v 8771 2006-04-29 11:55:57Z letouzey $ i*)
 
 Require Import BinPos.
+Unset Boxed Definitions.
 
 (**********************************************************************)
 (** Binary natural numbers *)
@@ -21,33 +22,40 @@ Inductive N : Set :=
 
 Delimit Scope N_scope with N.
 
-(** Automatically open scope N_scope for the constructors of N *)
+(** Automatically open scope positive_scope for the constructors of N *)
 
 Bind Scope N_scope with N.
-Arguments Scope Npos [N_scope].
+Arguments Scope Npos [positive_scope].
 
 Open Local Scope N_scope.
 
+Definition Ndiscr : forall n:N, { p:positive | n = Npos p } + { n = N0 }.
+Proof.
+ destruct n; auto.
+ left; exists p; auto.
+Defined.
+
 (** Operation x -> 2*x+1 *)
 
 Definition Ndouble_plus_one x :=
   match x with
-  | N0 => Npos 1%positive
+  | N0 => Npos 1
   | Npos p => Npos (xI p)
   end.
 
 (** Operation x -> 2*x *)
 
-Definition Ndouble n := match n with
-                        | N0 => N0
-                        | Npos p => Npos (xO p)
-                        end.
+Definition Ndouble n := 
+  match n with
+  | N0 => N0
+  | Npos p => Npos (xO p)
+  end.
 
 (** Successor *)
 
 Definition Nsucc n :=
   match n with
-  | N0 => Npos 1%positive
+  | N0 => Npos 1
   | Npos p => Npos (Psucc p)
   end.
 
@@ -57,7 +65,7 @@ Definition Nplus n m :=
   match n, m with
   | N0, _ => m
   | _, N0 => n
-  | Npos p, Npos q => Npos (p + q)%positive
+  | Npos p, Npos q => Npos (p + q)
   end.
 
 Infix "+" := Nplus : N_scope.
@@ -68,7 +76,7 @@ Definition Nmult n m :=
   match n, m with
   | N0, _ => N0
   | _, N0 => N0
-  | Npos p, Npos q => Npos (p * q)%positive
+  | Npos p, Npos q => Npos (p * q)
   end.
 
 Infix "*" := Nmult : N_scope.
@@ -85,6 +93,34 @@ Definition Ncompare n m :=
 
 Infix "?=" := Ncompare (at level 70, no associativity) : N_scope.
 
+(** convenient induction principles *)
+
+Lemma N_ind_double :
+ forall (a:N) (P:N -> Prop),
+   P N0 ->
+   (forall a, P a -> P (Ndouble a)) ->
+   (forall a, P a -> P (Ndouble_plus_one a)) -> P a.
+Proof.
+  intros; elim a. trivial.
+  simple induction p. intros. 
+  apply (H1 (Npos p0)); trivial.
+  intros; apply (H0 (Npos p0)); trivial.
+  intros; apply (H1 N0); assumption.
+Qed.
+
+Lemma N_rec_double :
+ forall (a:N) (P:N -> Set),
+   P N0 ->
+   (forall a, P a -> P (Ndouble a)) ->
+   (forall a, P a -> P (Ndouble_plus_one a)) -> P a.
+Proof.
+  intros; elim a. trivial.
+  simple induction p. intros. 
+  apply (H1 (Npos p0)); trivial.
+  intros; apply (H0 (Npos p0)); trivial.
+  intros; apply (H1 N0); assumption.
+Qed.
+
 (** Peano induction on binary natural numbers *)
 
 Theorem Nind :
@@ -154,7 +190,7 @@ Qed.
 
 (** Properties of multiplication *)
 
-Theorem Nmult_1_l : forall n:N, Npos 1%positive * n = n.
+Theorem Nmult_1_l : forall n:N, Npos 1 * n = n.
 Proof.
 destruct n; reflexivity.
 Qed.
@@ -210,3 +246,47 @@ destruct n as [| n]; destruct m as [| m]; simpl in |- *; intro H;
  reflexivity || (try discriminate H).
   rewrite (Pcompare_Eq_eq n m H); reflexivity.
 Qed.
+
+Lemma Ncompare_refl : forall n, (n ?= n) = Eq.
+Proof.
+destruct n; simpl; auto.
+apply Pcompare_refl.
+Qed.
+
+Lemma Ncompare_antisym : forall n m, CompOpp (n ?= m) = (m ?= n).
+Proof.
+destruct n; destruct m; simpl; auto.
+exact (Pcompare_antisym p p0 Eq).
+Qed.
+
+(** Dividing by 2 *)
+
+Definition Ndiv2 (n:N) :=
+  match n with
+  | N0 => N0
+  | Npos 1 => N0
+  | Npos (xO p) => Npos p
+  | Npos (xI p) => Npos p
+  end.
+
+Lemma Ndouble_div2 : forall n:N, Ndiv2 (Ndouble n) = n.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Ndouble_plus_one_div2 :
+ forall n:N, Ndiv2 (Ndouble_plus_one n) = n.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Ndouble_inj : forall n m, Ndouble n = Ndouble m -> n = m.
+Proof.
+  intros. rewrite <- (Ndouble_div2 n). rewrite H. apply Ndouble_div2.
+Qed.
+
+Lemma Ndouble_plus_one_inj :
+ forall n m, Ndouble_plus_one n = Ndouble_plus_one m -> n = m.
+Proof.
+  intros. rewrite <- (Ndouble_plus_one_div2 n). rewrite H. apply Ndouble_plus_one_div2.
+Qed.
diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v
index fffb10c1..513a67c2 100644
--- a/theories/NArith/BinPos.v
+++ b/theories/NArith/BinPos.v
@@ -6,7 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinPos.v,v 1.7.2.1 2004/07/16 19:31:07 herbelin Exp $ i*)
+(*i $Id: BinPos.v 6699 2005-02-07 14:30:08Z coq $ i*)
+
+Unset Boxed Definitions.
 
 (**********************************************************************)
 (** Binary positive numbers *)
@@ -39,6 +41,8 @@ Fixpoint Psucc (x:positive) : positive :=
 
 (** Addition *)
 
+Set Boxed Definitions.
+
 Fixpoint Pplus (x y:positive) {struct x} : positive :=
   match x, y with
   | xI x', xI y' => xO (Pplus_carry x' y')
@@ -65,6 +69,8 @@ Fixpoint Pplus (x y:positive) {struct x} : positive :=
   | xH, xH => xI xH
   end.
 
+Unset Boxed Definitions.
+
 Infix "+" := Pplus : positive_scope.
 
 Open Local Scope positive_scope.
diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v
index b1bdaaf0..019ef5f7 100644
--- a/theories/NArith/NArith.v
+++ b/theories/NArith/NArith.v
@@ -6,9 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: NArith.v,v 1.2.2.1 2004/07/16 19:31:07 herbelin Exp $ *)
+(* $Id: NArith.v 9210 2006-10-05 10:12:15Z barras $ *)
 
 (** Library for binary natural numbers *)
 
 Require Export BinPos.
-Require Export BinNat.
\ No newline at end of file
+Require Export BinNat.
+
+Require Export NArithRing.
diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v
new file mode 100644
index 00000000..df2da25b
--- /dev/null
+++ b/theories/NArith/Ndec.v
@@ -0,0 +1,412 @@
+(************************************************************************)
+(*  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: Ndec.v 8733 2006-04-25 22:52:18Z letouzey $ i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import BinPos.
+Require Import BinNat.
+Require Import Pnat.
+Require Import Nnat.
+Require Import Ndigits.
+
+(** A boolean equality over [N] *)
+
+Fixpoint Peqb (p1 p2:positive) {struct p2} : bool :=
+  match p1, p2 with
+  | xH, xH => true
+  | xO p'1, xO p'2 => Peqb p'1 p'2
+  | xI p'1, xI p'2 => Peqb p'1 p'2
+  | _, _ => false
+  end.
+
+Lemma Peqb_correct : forall p, Peqb p p = true.
+Proof.
+induction p; auto.
+Qed.
+
+Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq.
+Proof.
+ induction p; destruct p'; simpl; intros; try discriminate; auto.
+Qed.
+
+Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true.
+Proof. 
+intros; rewrite <- (Pcompare_Eq_eq _ _ H).
+apply Peqb_correct.
+Qed.
+
+Definition Neqb (a a':N) :=
+  match a, a' with
+  | N0, N0 => true
+  | Npos p, Npos p' => Peqb p p'
+  | _, _ => false
+  end.
+
+Lemma Neqb_correct : forall n, Neqb n n = true.
+Proof.
+  destruct n; trivial.
+  simpl; apply Peqb_correct.
+Qed.
+
+Lemma Neqb_Ncompare : forall n n', Neqb n n' = true -> Ncompare n n' = Eq.
+Proof.
+ destruct n; destruct n'; simpl; intros; try discriminate; auto; apply Peqb_Pcompare; auto.
+Qed.
+
+Lemma Ncompare_Neqb : forall n n', Ncompare n n' = Eq -> Neqb n n' = true.
+Proof. 
+intros; rewrite <- (Ncompare_Eq_eq _ _ H).
+apply Neqb_correct.
+Qed.
+
+Lemma Neqb_complete : forall a a', Neqb a a' = true -> a = a'.
+Proof.
+  intros.
+  apply Ncompare_Eq_eq.
+  apply Neqb_Ncompare; auto.
+Qed.
+
+Lemma Neqb_comm : forall a a', Neqb a a' = Neqb a' a.
+Proof.
+  intros; apply bool_1; split; intros.
+  rewrite (Neqb_complete _ _ H); apply Neqb_correct.
+  rewrite (Neqb_complete _ _ H); apply Neqb_correct.
+Qed.
+
+Lemma Nxor_eq_true :
+ forall a a', Nxor a a' = N0 -> Neqb a a' = true.
+Proof.
+  intros. rewrite (Nxor_eq a a' H). apply Neqb_correct.
+Qed.
+
+Lemma Nxor_eq_false :
+ forall a a' p, Nxor a a' = Npos p -> Neqb a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
+  rewrite (Neqb_complete a a' H0) in H. rewrite (Nxor_nilpotent a') in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nodd_not_double :
+ forall a,
+   Nodd a -> forall a0, Neqb (Ndouble a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
+  rewrite <- (Neqb_complete _ _ H0) in H. 
+  unfold Nodd in H.
+  rewrite (Ndouble_bit0 a0) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nnot_div2_not_double :
+ forall a a0,
+   Neqb (Ndiv2 a) a0 = false -> Neqb a (Ndouble a0) = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
+  rewrite <- (Neqb_complete _ _ H0) in H. rewrite (Ndouble_div2 a0) in H.
+  rewrite (Neqb_correct a0) in H. discriminate H.
+  intro. rewrite Neqb_comm. assumption.
+Qed.
+
+Lemma Neven_not_double_plus_one :
+ forall a,
+   Neven a -> forall a0, Neqb (Ndouble_plus_one a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb (Ndouble_plus_one a0) a)). intro H0.
+  rewrite <- (Neqb_complete _ _ H0) in H. 
+  unfold Neven in H.
+  rewrite (Ndouble_plus_one_bit0 a0) in H.
+  discriminate H.
+  trivial.
+Qed.
+
+Lemma Nnot_div2_not_double_plus_one :
+ forall a a0,
+   Neqb (Ndiv2 a) a0 = false -> Neqb (Ndouble_plus_one a0) a = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb a (Ndouble_plus_one a0))). intro H0.
+  rewrite (Neqb_complete _ _ H0) in H. rewrite (Ndouble_plus_one_div2 a0) in H.
+  rewrite (Neqb_correct a0) in H. discriminate H.
+  intro H0. rewrite Neqb_comm. assumption.
+Qed.
+
+Lemma Nbit0_neq :
+ forall a a',
+   Nbit0 a = false -> Nbit0 a' = true -> Neqb a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb a a')). intro H1. rewrite (Neqb_complete _ _ H1) in H.
+  rewrite H in H0. discriminate H0.
+  trivial.
+Qed.
+
+Lemma Ndiv2_eq :
+ forall a a', Neqb a a' = true -> Neqb (Ndiv2 a) (Ndiv2 a') = true.
+Proof.
+  intros. cut (a = a'). intros. rewrite H0. apply Neqb_correct.
+  apply Neqb_complete. exact H.
+Qed.
+
+Lemma Ndiv2_neq :
+ forall a a',
+   Neqb (Ndiv2 a) (Ndiv2 a') = false -> Neqb a a' = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
+  rewrite (Neqb_complete _ _ H0) in H. rewrite (Neqb_correct (Ndiv2 a')) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Ndiv2_bit_eq :
+ forall a a',
+   Nbit0 a = Nbit0 a' -> Ndiv2 a = Ndiv2 a' -> a = a'.
+Proof.
+  intros. apply Nbit_faithful. unfold eqf in |- *. destruct n.
+  rewrite Nbit0_correct. rewrite Nbit0_correct. assumption.
+  rewrite <- Ndiv2_correct. rewrite <- Ndiv2_correct.
+  rewrite H0. reflexivity.
+Qed.
+
+Lemma Ndiv2_bit_neq :
+ forall a a',
+   Neqb a a' = false ->
+   Nbit0 a = Nbit0 a' -> Neqb (Ndiv2 a) (Ndiv2 a') = false.
+Proof.
+  intros. elim (sumbool_of_bool (Neqb (Ndiv2 a) (Ndiv2 a'))). intro H1.
+  rewrite (Ndiv2_bit_eq _ _ H0 (Neqb_complete _ _ H1)) in H.
+  rewrite (Neqb_correct a') in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nneq_elim :
+ forall a a',
+   Neqb a a' = false ->
+   Nbit0 a = negb (Nbit0 a') \/
+   Neqb (Ndiv2 a) (Ndiv2 a') = false.
+Proof.
+  intros. cut (Nbit0 a = Nbit0 a' \/ Nbit0 a = negb (Nbit0 a')).
+  intros. elim H0. intro. right. apply Ndiv2_bit_neq. assumption.
+  assumption.
+  intro. left. assumption.
+  case (Nbit0 a); case (Nbit0 a'); auto.
+Qed.
+
+Lemma Ndouble_or_double_plus_un :
+ forall a,
+   {a0 : N | a = Ndouble a0} + {a1 : N | a = Ndouble_plus_one a1}.
+Proof.
+  intro. elim (sumbool_of_bool (Nbit0 a)). intro H. right. split with (Ndiv2 a).
+  rewrite (Ndiv2_double_plus_one a H). reflexivity.
+  intro H. left. split with (Ndiv2 a). rewrite (Ndiv2_double a H). reflexivity.
+Qed.
+
+(** A boolean order on [N] *)
+
+Definition Nle (a b:N) := leb (nat_of_N a) (nat_of_N b).
+
+Lemma Nle_Ncompare : forall a b, Nle a b = true <-> Ncompare a b <> Gt.
+Proof.
+ intros; rewrite nat_of_Ncompare.
+ unfold Nle; apply leb_compare.
+Qed.
+
+Lemma Nle_refl : forall a, Nle a a = true.
+Proof.
+  intro. unfold Nle in |- *. apply leb_correct. apply le_n.
+Qed.
+
+Lemma Nle_antisym :
+ forall a b, Nle a b = true -> Nle b a = true -> a = b.
+Proof.
+  unfold Nle in |- *. intros. rewrite <- (N_of_nat_of_N a). rewrite <- (N_of_nat_of_N b).
+  rewrite (le_antisym _ _ (leb_complete _ _ H) (leb_complete _ _ H0)). reflexivity.
+Qed.
+
+Lemma Nle_trans :
+ forall a b c, Nle a b = true -> Nle b c = true -> Nle a c = true.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct. apply le_trans with (m := nat_of_N b).
+  apply leb_complete. assumption.
+  apply leb_complete. assumption.
+Qed.
+
+Lemma Nle_lt_trans :
+ forall a b c,
+   Nle a b = true -> Nle c b = false -> Nle c a = false.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct_conv. apply le_lt_trans with (m := nat_of_N b).
+  apply leb_complete. assumption.
+  apply leb_complete_conv. assumption.
+Qed.
+
+Lemma Nlt_le_trans :
+ forall a b c,
+   Nle b a = false -> Nle b c = true -> Nle c a = false.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct_conv. apply lt_le_trans with (m := nat_of_N b).
+  apply leb_complete_conv. assumption.
+  apply leb_complete. assumption.
+Qed.
+
+Lemma Nlt_trans :
+ forall a b c,
+   Nle b a = false -> Nle c b = false -> Nle c a = false.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct_conv. apply lt_trans with (m := nat_of_N b).
+  apply leb_complete_conv. assumption.
+  apply leb_complete_conv. assumption.
+Qed.
+
+Lemma Nlt_le_weak : forall a b:N, Nle b a = false -> Nle a b = true.
+Proof.
+  unfold Nle in |- *. intros. apply leb_correct. apply lt_le_weak.
+  apply leb_complete_conv. assumption.
+Qed.
+
+Lemma Nle_double_mono :
+ forall a b,
+   Nle a b = true -> Nle (Ndouble a) (Ndouble b) = true.
+Proof.
+  unfold Nle in |- *. intros. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. apply leb_correct.
+  simpl in |- *. apply plus_le_compat. apply leb_complete. assumption.
+  apply plus_le_compat. apply leb_complete. assumption.
+  apply le_n.
+Qed.
+
+Lemma Nle_double_plus_one_mono :
+ forall a b,
+   Nle a b = true ->
+   Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = true.
+Proof.
+  unfold Nle in |- *. intros. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one.
+  apply leb_correct. apply le_n_S. simpl in |- *. apply plus_le_compat. apply leb_complete.
+  assumption.
+  apply plus_le_compat. apply leb_complete. assumption.
+  apply le_n.
+Qed.
+
+Lemma Nle_double_mono_conv :
+ forall a b,
+   Nle (Ndouble a) (Ndouble b) = true -> Nle a b = true.
+Proof.
+  unfold Nle in |- *. intros a b. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. intro.
+  apply leb_correct. apply (mult_S_le_reg_l 1). apply leb_complete. assumption.
+Qed.
+
+Lemma Nle_double_plus_one_mono_conv :
+ forall a b,
+   Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = true ->
+   Nle a b = true.
+Proof.
+  unfold Nle in |- *. intros a b. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one.
+  intro. apply leb_correct. apply (mult_S_le_reg_l 1). apply le_S_n. apply leb_complete.
+  assumption.
+Qed.
+
+Lemma Nlt_double_mono :
+ forall a b,
+   Nle a b = false -> Nle (Ndouble a) (Ndouble b) = false.
+Proof.
+  intros. elim (sumbool_of_bool (Nle (Ndouble a) (Ndouble b))). intro H0.
+  rewrite (Nle_double_mono_conv _ _ H0) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nlt_double_plus_one_mono :
+ forall a b,
+   Nle a b = false ->
+   Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = false.
+Proof.
+  intros. elim (sumbool_of_bool (Nle (Ndouble_plus_one a) (Ndouble_plus_one b))). intro H0.
+  rewrite (Nle_double_plus_one_mono_conv _ _ H0) in H. discriminate H.
+  trivial.
+Qed.
+
+Lemma Nlt_double_mono_conv :
+ forall a b,
+   Nle (Ndouble a) (Ndouble b) = false -> Nle a b = false.
+Proof.
+  intros. elim (sumbool_of_bool (Nle a b)). intro H0. rewrite (Nle_double_mono _ _ H0) in H.
+  discriminate H.
+  trivial.
+Qed.
+
+Lemma Nlt_double_plus_one_mono_conv :
+ forall a b,
+   Nle (Ndouble_plus_one a) (Ndouble_plus_one b) = false ->
+   Nle a b = false.
+Proof.
+  intros. elim (sumbool_of_bool (Nle a b)). intro H0.
+  rewrite (Nle_double_plus_one_mono _ _ H0) in H. discriminate H.
+  trivial.
+Qed.
+
+(* A [min] function over [N] *)
+
+Definition Nmin (a b:N) := if Nle a b then a else b.
+
+Lemma Nmin_choice : forall a b, {Nmin a b = a} + {Nmin a b = b}.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. left. rewrite H.
+  reflexivity.
+  intro H. right. rewrite H. reflexivity.
+Qed.
+
+Lemma Nmin_le_1 : forall a b, Nle (Nmin a b) a = true.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. rewrite H.
+  apply Nle_refl.
+  intro H. rewrite H. apply Nlt_le_weak. assumption.
+Qed.
+
+Lemma Nmin_le_2 : forall a b, Nle (Nmin a b) b = true.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle a b)). intro H. rewrite H. assumption.
+  intro H. rewrite H. apply Nle_refl.
+Qed.
+
+Lemma Nmin_le_3 :
+ forall a b c, Nle a (Nmin b c) = true -> Nle a b = true.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H.
+  assumption.
+  intro H0. rewrite H0 in H. apply Nlt_le_weak. apply Nle_lt_trans with (b := c); assumption.
+Qed.
+
+Lemma Nmin_le_4 :
+ forall a b c, Nle a (Nmin b c) = true -> Nle a c = true.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H.
+  apply Nle_trans with (b := b); assumption.
+  intro H0. rewrite H0 in H. assumption.
+Qed.
+
+Lemma Nmin_le_5 :
+ forall a b c,
+   Nle a b = true -> Nle a c = true -> Nle a (Nmin b c) = true.
+Proof.
+  intros. elim (Nmin_choice b c). intro H1. rewrite H1. assumption.
+  intro H1. rewrite H1. assumption.
+Qed.
+
+Lemma Nmin_lt_3 :
+ forall a b c, Nle (Nmin b c) a = false -> Nle b a = false.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H.
+  assumption.
+  intro H0. rewrite H0 in H. apply Nlt_trans with (b := c); assumption.
+Qed.
+
+Lemma Nmin_lt_4 :
+ forall a b c, Nle (Nmin b c) a = false -> Nle c a = false.
+Proof.
+  unfold Nmin in |- *. intros. elim (sumbool_of_bool (Nle b c)). intro H0. rewrite H0 in H.
+  apply Nlt_le_trans with (b := b); assumption.
+  intro H0. rewrite H0 in H. assumption.
+Qed.
diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v
new file mode 100644
index 00000000..ed8ced5b
--- /dev/null
+++ b/theories/NArith/Ndigits.v
@@ -0,0 +1,767 @@
+(************************************************************************)
+(*  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: Ndigits.v 8736 2006-04-26 21:18:44Z letouzey $ i*)
+
+Require Import Bool.
+Require Import Bvector.
+Require Import BinPos.
+Require Import BinNat.
+
+(** Operation over bits of a [N] number. *)
+
+(** [xor] *)
+
+Fixpoint Pxor (p1 p2:positive) {struct p1} : N :=
+  match p1, p2 with
+  | xH, xH => N0
+  | xH, xO p2 => Npos (xI p2)
+  | xH, xI p2 => Npos (xO p2)
+  | xO p1, xH => Npos (xI p1)
+  | xO p1, xO p2 => Ndouble (Pxor p1 p2)
+  | xO p1, xI p2 => Ndouble_plus_one (Pxor p1 p2)
+  | xI p1, xH => Npos (xO p1)
+  | xI p1, xO p2 => Ndouble_plus_one (Pxor p1 p2)
+  | xI p1, xI p2 => Ndouble (Pxor p1 p2) 
+  end.
+
+Definition Nxor (n n':N) :=
+  match n, n' with
+  | N0, _ => n'
+  | _, N0 => n
+  | Npos p, Npos p' => Pxor p p'
+  end.
+
+Lemma Nxor_neutral_left : forall n:N, Nxor N0 n = n.
+Proof.
+  trivial.
+Qed.
+
+Lemma Nxor_neutral_right : forall n:N, Nxor n N0 = n.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Nxor_comm : forall n n':N, Nxor n n' = Nxor n' n.
+Proof.
+  destruct n; destruct n'; simpl; auto.
+  generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl;
+   auto.
+  destruct p0; simpl; trivial; intros; rewrite Hrecp; trivial.
+  destruct p0; simpl; trivial; intros; rewrite Hrecp; trivial.
+  destruct p0 as [p| p| ]; simpl; auto.
+Qed.
+
+Lemma Nxor_nilpotent : forall n:N, Nxor n n = N0.
+Proof.
+  destruct n; trivial.
+  simpl. induction p as [p IHp| p IHp| ]; trivial.
+  simpl. rewrite IHp; reflexivity.
+  simpl. rewrite IHp; reflexivity.
+Qed.
+
+(** Checking whether a particular bit is set on not *) 
+
+Fixpoint Pbit (p:positive) : nat -> bool :=
+  match p with
+  | xH => fun n:nat => match n with
+                       | O => true
+                       | S _ => false
+                       end
+  | xO p =>
+      fun n:nat => match n with
+                   | O => false
+                   | S n' => Pbit p n'
+                   end
+  | xI p => fun n:nat => match n with
+                         | O => true
+                         | S n' => Pbit p n'
+                         end
+  end.
+
+Definition Nbit (a:N) :=
+  match a with
+  | N0 => fun _ => false
+  | Npos p => Pbit p
+  end.
+
+(** Auxiliary results about streams of bits *)
+
+Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n.
+
+Lemma eqf_sym : forall f f':nat -> bool, eqf f f' -> eqf f' f.
+Proof.
+  unfold eqf. intros. rewrite H. reflexivity.
+Qed.
+
+Lemma eqf_refl : forall f:nat -> bool, eqf f f.
+Proof.
+  unfold eqf. trivial.
+Qed.
+
+Lemma eqf_trans :
+ forall f f' f'':nat -> bool, eqf f f' -> eqf f' f'' -> eqf f f''.
+Proof.
+  unfold eqf. intros. rewrite H. exact (H0 n).
+Qed.
+
+Definition xorf (f g:nat -> bool) (n:nat) := xorb (f n) (g n).
+
+Lemma xorf_eq :
+ forall f f', eqf (xorf f f') (fun n => false) -> eqf f f'.
+Proof.
+  unfold eqf, xorf. intros. apply xorb_eq. apply H.
+Qed.
+
+Lemma xorf_assoc :
+ forall f f' f'',
+   eqf (xorf (xorf f f') f'') (xorf f (xorf f' f'')).
+Proof.
+  unfold eqf, xorf. intros. apply xorb_assoc.
+Qed.
+
+Lemma eqf_xorf :
+ forall f f' f'' f''',
+   eqf f f' -> eqf f'' f''' -> eqf (xorf f f'') (xorf f' f''').
+Proof.
+  unfold eqf, xorf. intros. rewrite H. rewrite H0. reflexivity.
+Qed.
+
+(** End of auxilliary results *)
+
+(** This part is aimed at proving that if two numbers produce 
+  the same stream of bits, then they are equal. *)
+
+Lemma Nbit_faithful_1 : forall a:N, eqf (Nbit N0) (Nbit a) -> N0 = a.
+Proof.
+  destruct a. trivial.
+  induction p as [p IHp| p IHp| ]; intro H. 
+  absurd (N0 = Npos p). discriminate.
+  exact (IHp (fun n => H (S n))).
+  absurd (N0 = Npos p). discriminate.
+  exact (IHp (fun n => H (S n))).
+  absurd (false = true). discriminate.
+  exact (H 0).
+Qed.
+
+Lemma Nbit_faithful_2 :
+ forall a:N, eqf (Nbit (Npos 1)) (Nbit a) -> Npos 1 = a.
+Proof.
+  destruct a. intros. absurd (true = false). discriminate.
+  exact (H 0).
+  destruct p. intro H. absurd (N0 = Npos p). discriminate.
+  exact (Nbit_faithful_1 (Npos p) (fun n:nat => H (S n))).
+  intros. absurd (true = false). discriminate.
+  exact (H 0).
+  trivial.
+Qed.
+
+Lemma Nbit_faithful_3 :
+ forall (a:N) (p:positive),
+   (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') ->
+   eqf (Nbit (Npos (xO p))) (Nbit a) -> Npos (xO p) = a.
+Proof.
+  destruct a. intros. cut (eqf (Nbit N0) (Nbit (Npos (xO p)))).
+  intro. rewrite (Nbit_faithful_1 (Npos (xO p)) H1). reflexivity.
+  unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity.
+  case p. intros. absurd (false = true). discriminate.
+  exact (H0 0).
+  intros. rewrite (H p0 (fun n => H0 (S n))). reflexivity.
+  intros. absurd (false = true). discriminate.
+  exact (H0 0).
+Qed.
+
+Lemma Nbit_faithful_4 :
+ forall (a:N) (p:positive),
+   (forall p':positive, eqf (Nbit (Npos p)) (Nbit (Npos p')) -> p = p') ->
+   eqf (Nbit (Npos (xI p))) (Nbit a) -> Npos (xI p) = a.
+Proof.
+  destruct a. intros. cut (eqf (Nbit N0) (Nbit (Npos (xI p)))).
+  intro. rewrite (Nbit_faithful_1 (Npos (xI p)) H1). reflexivity.
+  unfold eqf. intro. unfold eqf in H0. rewrite H0. reflexivity.
+  case p. intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity.
+  intros. absurd (true = false). discriminate.
+  exact (H0 0).
+  intros. absurd (N0 = Npos p0). discriminate.
+  cut (eqf (Nbit (Npos 1)) (Nbit (Npos (xI p0)))).
+  intro. exact (Nbit_faithful_1 (Npos p0) (fun n:nat => H1 (S n))).
+  unfold eqf in *. intro. rewrite H0. reflexivity.
+Qed.
+
+Lemma Nbit_faithful : forall a a':N, eqf (Nbit a) (Nbit a') -> a = a'.
+Proof.
+  destruct a. exact Nbit_faithful_1.
+  induction p. intros a' H. apply Nbit_faithful_4. intros. cut (Npos p = Npos p').
+  intro. inversion H1. reflexivity.
+  exact (IHp (Npos p') H0).
+  assumption.
+  intros. apply Nbit_faithful_3. intros. cut (Npos p = Npos p'). intro. inversion H1. reflexivity.
+  exact (IHp (Npos p') H0).
+  assumption.
+  exact Nbit_faithful_2.
+Qed.
+
+(** We now describe the semantics of [Nxor] in terms of bit streams. *)
+
+Lemma Nxor_sem_1 : forall a':N, Nbit (Nxor N0 a') 0 = Nbit a' 0.
+Proof.
+  trivial.
+Qed.
+
+Lemma Nxor_sem_2 :
+ forall a':N, Nbit (Nxor (Npos 1) a') 0 = negb (Nbit a' 0).
+Proof.
+  intro. case a'. trivial.
+  simpl. intro. 
+  case p; trivial.
+Qed.
+
+Lemma Nxor_sem_3 :
+ forall (p:positive) (a':N),
+   Nbit (Nxor (Npos (xO p)) a') 0 = Nbit a' 0.
+Proof.
+  intros. case a'. trivial.
+  simpl. intro. 
+  case p0; trivial. intro. 
+  case (Pxor p p1); trivial.
+  intro. case (Pxor p p1); trivial.
+Qed.
+
+Lemma Nxor_sem_4 :
+ forall (p:positive) (a':N),
+   Nbit (Nxor (Npos (xI p)) a') 0 = negb (Nbit a' 0).
+Proof.
+  intros. case a'. trivial.
+  simpl. intro. case p0; trivial. intro. 
+  case (Pxor p p1); trivial.
+  intro. 
+  case (Pxor p p1); trivial.
+Qed.
+
+Lemma Nxor_sem_5 :
+ forall a a':N, Nbit (Nxor a a') 0 = xorf (Nbit a) (Nbit a') 0.
+Proof.
+  destruct a. intro. change (Nbit a' 0 = xorb false (Nbit a' 0)). rewrite false_xorb. trivial.
+  case p. exact Nxor_sem_4.
+  intros. change (Nbit (Nxor (Npos (xO p0)) a') 0 = xorb false (Nbit a' 0)).
+  rewrite false_xorb. apply Nxor_sem_3. exact Nxor_sem_2.
+Qed.
+
+Lemma Nxor_sem_6 :
+ forall n:nat,
+   (forall a a':N, Nbit (Nxor a a') n = xorf (Nbit a) (Nbit a') n) ->
+   forall a a':N,
+     Nbit (Nxor a a') (S n) = xorf (Nbit a) (Nbit a') (S n).
+Proof.
+  intros. 
+  generalize (fun p1 p2 => H (Npos p1) (Npos p2)); clear H; intro H.
+  unfold xorf in *.
+  case a. simpl Nbit; rewrite false_xorb. reflexivity.
+  case a'; intros. 
+  simpl Nbit; rewrite xorb_false. reflexivity.
+  case p0. case p; intros; simpl Nbit in *.
+  rewrite <- H; simpl; case (Pxor p2 p1); trivial.
+  rewrite <- H; simpl; case (Pxor p2 p1); trivial.
+  rewrite xorb_false. reflexivity.
+  case p; intros; simpl Nbit in *.
+  rewrite <- H; simpl; case (Pxor p2 p1); trivial.
+  rewrite <- H; simpl; case (Pxor p2 p1); trivial.
+  rewrite xorb_false. reflexivity.
+  simpl Nbit. rewrite false_xorb. simpl. case p; trivial.
+Qed.
+
+Lemma Nxor_semantics :
+ forall a a':N, eqf (Nbit (Nxor a a')) (xorf (Nbit a) (Nbit a')).
+Proof.
+  unfold eqf. intros. generalize a a'. elim n. exact Nxor_sem_5.
+  exact Nxor_sem_6.
+Qed.
+
+(** Consequences: 
+       - only equal numbers lead to a null xor
+       - xor is associative 
+*)
+
+Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'.
+Proof.
+  intros. apply Nbit_faithful. apply xorf_eq. apply eqf_trans with (f' := Nbit (Nxor a a')).
+  apply eqf_sym. apply Nxor_semantics.
+  rewrite H. unfold eqf. trivial.
+Qed.
+
+Lemma Nxor_assoc :
+ forall a a' a'':N, Nxor (Nxor a a') a'' = Nxor a (Nxor a' a'').
+Proof.
+  intros. apply Nbit_faithful.
+  apply eqf_trans with
+   (f' := xorf (xorf (Nbit a) (Nbit a')) (Nbit a'')).
+  apply eqf_trans with (f' := xorf (Nbit (Nxor a a')) (Nbit a'')).
+  apply Nxor_semantics.
+  apply eqf_xorf. apply Nxor_semantics.
+  apply eqf_refl.
+  apply eqf_trans with
+   (f' := xorf (Nbit a) (xorf (Nbit a') (Nbit a''))).
+  apply xorf_assoc.
+  apply eqf_trans with (f' := xorf (Nbit a) (Nbit (Nxor a' a''))).
+  apply eqf_xorf. apply eqf_refl.
+  apply eqf_sym. apply Nxor_semantics.
+  apply eqf_sym. apply Nxor_semantics.
+Qed.
+
+(** Checking whether a number is odd, i.e. 
+   if its lower bit is set. *)
+
+Definition Nbit0 (n:N) :=
+  match n with
+  | N0 => false
+  | Npos (xO _) => false
+  | _ => true
+  end.
+
+Definition Nodd (n:N) := Nbit0 n = true.
+Definition Neven (n:N) := Nbit0 n = false.
+
+Lemma Nbit0_correct : forall n:N, Nbit n 0 = Nbit0 n.
+Proof.
+  destruct n; trivial.
+  destruct p; trivial.
+Qed.
+
+Lemma Ndouble_bit0 : forall n:N, Nbit0 (Ndouble n) = false.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Ndouble_plus_one_bit0 :
+ forall n:N, Nbit0 (Ndouble_plus_one n) = true.
+Proof.
+  destruct n; trivial.
+Qed.
+
+Lemma Ndiv2_double :
+ forall n:N, Neven n -> Ndouble (Ndiv2 n) = n.
+Proof.
+  destruct n. trivial. destruct p. intro H. discriminate H.
+  intros. reflexivity.
+  intro H. discriminate H.
+Qed.
+
+Lemma Ndiv2_double_plus_one :
+ forall n:N, Nodd n -> Ndouble_plus_one (Ndiv2 n) = n.
+Proof.
+  destruct n. intro. discriminate H.
+  destruct p. intros. reflexivity.
+  intro H. discriminate H.
+  intro. reflexivity.
+Qed.
+
+Lemma Ndiv2_correct :
+ forall (a:N) (n:nat), Nbit (Ndiv2 a) n = Nbit a (S n).
+Proof.
+  destruct a; trivial.
+  destruct p; trivial.
+Qed.
+
+Lemma Nxor_bit0 :
+ forall a a':N, Nbit0 (Nxor a a') = xorb (Nbit0 a) (Nbit0 a').
+Proof.
+  intros. rewrite <- Nbit0_correct. rewrite (Nxor_semantics a a' 0).
+  unfold xorf. rewrite Nbit0_correct. rewrite Nbit0_correct. reflexivity.
+Qed.
+
+Lemma Nxor_div2 :
+ forall a a':N, Ndiv2 (Nxor a a') = Nxor (Ndiv2 a) (Ndiv2 a').
+Proof.
+  intros. apply Nbit_faithful. unfold eqf. intro.
+  rewrite (Nxor_semantics (Ndiv2 a) (Ndiv2 a') n).
+  rewrite Ndiv2_correct.
+  rewrite (Nxor_semantics a a' (S n)).
+  unfold xorf. rewrite Ndiv2_correct. rewrite Ndiv2_correct.
+  reflexivity.
+Qed.
+
+Lemma Nneg_bit0 :
+ forall a a':N,
+   Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a').
+Proof.
+  intros. rewrite <- true_xorb. rewrite <- H. rewrite Nxor_bit0.
+  rewrite xorb_assoc. rewrite xorb_nilpotent. rewrite xorb_false. reflexivity.
+Qed.
+
+Lemma Nneg_bit0_1 :
+ forall a a':N, Nxor a a' = Npos 1 -> Nbit0 a = negb (Nbit0 a').
+Proof.
+  intros. apply Nneg_bit0. rewrite H. reflexivity.
+Qed.
+
+Lemma Nneg_bit0_2 :
+ forall (a a':N) (p:positive),
+   Nxor a a' = Npos (xI p) -> Nbit0 a = negb (Nbit0 a').
+Proof.
+  intros. apply Nneg_bit0. rewrite H. reflexivity.
+Qed.
+
+Lemma Nsame_bit0 :
+ forall (a a':N) (p:positive),
+   Nxor a a' = Npos (xO p) -> Nbit0 a = Nbit0 a'.
+Proof.
+  intros. rewrite <- (xorb_false (Nbit0 a)). cut (Nbit0 (Npos (xO p)) = false).
+  intro. rewrite <- H0. rewrite <- H. rewrite Nxor_bit0. rewrite <- xorb_assoc.
+  rewrite xorb_nilpotent. rewrite false_xorb. reflexivity.
+  reflexivity.
+Qed.
+
+(** a lexicographic order on bits, starting from the lowest bit *)
+
+Fixpoint Nless_aux (a a':N) (p:positive) {struct p} : bool :=
+  match p with
+  | xO p' => Nless_aux (Ndiv2 a) (Ndiv2 a') p'
+  | _ => andb (negb (Nbit0 a)) (Nbit0 a')
+  end.
+
+Definition Nless (a a':N) :=
+  match Nxor a a' with
+  | N0 => false
+  | Npos p => Nless_aux a a' p
+  end.
+
+Lemma Nbit0_less :
+ forall a a',
+   Nbit0 a = false -> Nbit0 a' = true -> Nless a a' = true.
+Proof.
+  intros. elim (Ndiscr (Nxor a a')). intro H1. elim H1. intros p H2. unfold Nless in |- *.
+  rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+  intros. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H5.
+  rewrite H in H5. rewrite H0 in H5. discriminate H5.
+  rewrite H4. reflexivity.
+  intro. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+  intro H1. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H2.
+  rewrite H in H2. rewrite H0 in H2. discriminate H2.
+  rewrite H1. reflexivity.
+Qed.
+
+Lemma Nbit0_gt :
+ forall a a',
+   Nbit0 a = true -> Nbit0 a' = false -> Nless a a' = false.
+Proof.
+  intros. elim (Ndiscr (Nxor a a')). intro H1. elim H1. intros p H2. unfold Nless in |- *.
+  rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+  intros. cut (Nbit0 (Nxor a a') = false). intro. rewrite (Nxor_bit0 a a') in H5.
+  rewrite H in H5. rewrite H0 in H5. discriminate H5.
+  rewrite H4. reflexivity.
+  intro. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+  intro H1. unfold Nless in |- *. rewrite H1. reflexivity.
+Qed.
+
+Lemma Nless_not_refl : forall a, Nless a a = false.
+Proof.
+  intro. unfold Nless in |- *. rewrite (Nxor_nilpotent a). reflexivity.
+Qed.
+
+Lemma Nless_def_1 :
+ forall a a', Nless (Ndouble a) (Ndouble a') = Nless a a'.
+Proof.
+  simple induction a. simple induction a'. reflexivity.
+  trivial.
+  simple induction a'. unfold Nless in |- *. simpl in |- *. elim p; trivial.
+  unfold Nless in |- *. simpl in |- *. intro. case (Pxor p p0). reflexivity.
+  trivial.
+Qed.
+
+Lemma Nless_def_2 :
+ forall a a',
+   Nless (Ndouble_plus_one a) (Ndouble_plus_one a') = Nless a a'.
+Proof.
+  simple induction a. simple induction a'. reflexivity.
+  trivial.
+  simple induction a'. unfold Nless in |- *. simpl in |- *. elim p; trivial.
+  unfold Nless in |- *. simpl in |- *. intro. case (Pxor p p0). reflexivity.
+  trivial.
+Qed.
+
+Lemma Nless_def_3 :
+ forall a a', Nless (Ndouble a) (Ndouble_plus_one a') = true.
+Proof.
+  intros. apply Nbit0_less. apply Ndouble_bit0.
+  apply Ndouble_plus_one_bit0.
+Qed.
+
+Lemma Nless_def_4 :
+ forall a a', Nless (Ndouble_plus_one a) (Ndouble a') = false.
+Proof.
+  intros. apply Nbit0_gt. apply Ndouble_plus_one_bit0.
+  apply Ndouble_bit0.
+Qed.
+
+Lemma Nless_z : forall a, Nless a N0 = false.
+Proof.
+  simple induction a. reflexivity.
+  unfold Nless in |- *. intro. rewrite (Nxor_neutral_right (Npos p)). elim p; trivial.
+Qed.
+
+Lemma N0_less_1 :
+ forall a, Nless N0 a = true -> {p : positive | a = Npos p}.
+Proof.
+  simple induction a. intro. discriminate H.
+  intros. split with p. reflexivity.
+Qed.
+
+Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0.
+Proof.
+  simple induction a. trivial.
+  unfold Nless in |- *. simpl in |- *. 
+  cut (forall p:positive, Nless_aux N0 (Npos p) p = false -> False).
+  intros. elim (H p H0).
+  simple induction p. intros. discriminate H0.
+  intros. exact (H H0).
+  intro. discriminate H.
+Qed.
+
+Lemma Nless_trans :
+ forall a a' a'',
+   Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true.
+Proof.
+  intro a. pattern a; apply N_ind_double.
+  intros. case_eq (Nless N0 a''). trivial.
+  intro H1. rewrite (N0_less_2 a'' H1) in H0. rewrite (Nless_z a') in H0. discriminate H0.
+  intros a0 H a'. pattern a'; apply N_ind_double.
+  intros. rewrite (Nless_z (Ndouble a0)) in H0. discriminate H0.
+  intros a1 H0 a'' H1. rewrite (Nless_def_1 a0 a1) in H1.
+  pattern a''; apply N_ind_double; clear a''.
+  intro. rewrite (Nless_z (Ndouble a1)) in H2. discriminate H2.
+  intros. rewrite (Nless_def_1 a1 a2) in H3. rewrite (Nless_def_1 a0 a2).
+  exact (H a1 a2 H1 H3).
+  intros. apply Nless_def_3.
+  intros a1 H0 a'' H1. pattern a''; apply N_ind_double.
+  intro. rewrite (Nless_z (Ndouble_plus_one a1)) in H2. discriminate H2.
+  intros. rewrite (Nless_def_4 a1 a2) in H3. discriminate H3.
+  intros. apply Nless_def_3.
+  intros a0 H a'. pattern a'; apply N_ind_double.
+  intros. rewrite (Nless_z (Ndouble_plus_one a0)) in H0. discriminate H0.
+  intros. rewrite (Nless_def_4 a0 a1) in H1. discriminate H1.
+  intros a1 H0 a'' H1. pattern a''; apply N_ind_double.
+  intro. rewrite (Nless_z (Ndouble_plus_one a1)) in H2. discriminate H2.
+  intros. rewrite (Nless_def_4 a1 a2) in H3. discriminate H3.
+  rewrite (Nless_def_2 a0 a1) in H1. intros. rewrite (Nless_def_2 a1 a2) in H3.
+  rewrite (Nless_def_2 a0 a2). exact (H a1 a2 H1 H3).
+Qed.
+ 
+Lemma Nless_total :
+ forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}.
+Proof.
+  intro a. 
+  pattern a; apply N_rec_double; clear a.
+  intro. case_eq (Nless N0 a'). intro H. left. left. auto.
+  intro H. right. rewrite (N0_less_2 a' H). reflexivity.
+  intros a0 H a'. 
+  pattern a'; apply N_rec_double; clear a'.
+  case_eq (Nless N0 (Ndouble a0)). intro H0. left. right. auto.
+  intro H0. right. exact (N0_less_2 _ H0).
+  intros a1 H0. rewrite Nless_def_1. rewrite Nless_def_1. elim (H a1). intro H1.
+  left. assumption.
+  intro H1. right. rewrite H1. reflexivity.
+  intros a1 H0. left. left. apply Nless_def_3.
+  intros a0 H a'. 
+  pattern a'; apply N_rec_double; clear a'.
+  left. right. case a0; reflexivity.
+  intros a1 H0. left. right. apply Nless_def_3.
+  intros a1 H0. rewrite Nless_def_2. rewrite Nless_def_2. elim (H a1). intro H1.
+  left. assumption.
+  intro H1. right. rewrite H1. reflexivity.
+Qed.
+
+(** Number of digits in a number *)
+
+Fixpoint Psize (p:positive) : nat := 
+  match p with 
+    | xH => 1%nat
+    | xI p => S (Psize p) 
+    | xO p => S (Psize p)
+  end.
+
+Definition Nsize (n:N) : nat := match n with 
+  | N0 => 0%nat
+  | Npos p => Psize p
+ end.
+
+
+(** conversions between N and bit vectors. *)
+
+Fixpoint P2Bv (p:positive) : Bvector (Psize p) := 
+ match p return Bvector (Psize p) with 
+   | xH => Bvect_true 1%nat
+   | xO p => Bcons false (Psize p) (P2Bv p)
+   | xI p => Bcons true (Psize p) (P2Bv p)
+ end.
+
+Definition N2Bv (n:N) : Bvector (Nsize n) :=
+  match n as n0 return Bvector (Nsize n0) with 
+    | N0 => Bnil
+    | Npos p => P2Bv p
+  end.
+
+Fixpoint Bv2N (n:nat)(bv:Bvector n) {struct bv} : N := 
+  match bv with 
+    | Vnil => N0
+    | Vcons false n bv => Ndouble (Bv2N n bv)
+    | Vcons true n bv => Ndouble_plus_one (Bv2N n bv) 
+  end.
+
+Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n.
+Proof. 
+destruct n.
+simpl; auto.
+induction p; simpl in *; auto; rewrite IHp; simpl; auto.
+Qed.
+
+(** The opposite composition is not so simple: if the considered 
+  bit vector has some zeros on its right, they will disappear during 
+  the return [Bv2N] translation: *)
+
+Lemma Bv2N_Nsize : forall n (bv:Bvector n), Nsize (Bv2N n bv) <= n.
+Proof.
+induction n; intros.
+rewrite (V0_eq _ bv); simpl; auto.
+rewrite (VSn_eq _ _ bv); simpl.
+generalize (IHn (Vtail _ _ bv)); clear IHn.
+destruct (Vhead _ _ bv); 
+ destruct (Bv2N n (Vtail bool n bv)); 
+  simpl; auto with arith.
+Qed.
+
+(** In the previous lemma, we can only replace the inequality by
+  an equality whenever the highest bit is non-null. *)
+
+Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), 
+  Bsign _ bv = true <-> 
+  Nsize (Bv2N _ bv) = (S n).
+Proof.
+induction n; intro.
+rewrite (VSn_eq _ _ bv); simpl.
+rewrite (V0_eq _ (Vtail _ _ bv)); simpl.
+destruct (Vhead _ _ bv); simpl; intuition; try discriminate.
+rewrite (VSn_eq _ _ bv); simpl.
+generalize (IHn (Vtail _ _ bv)); clear IHn.
+destruct (Vhead _ _ bv); 
+ destruct (Bv2N (S n) (Vtail bool (S n) bv)); 
+  simpl; intuition; try discriminate.
+Qed.
+
+(** To state nonetheless a second result about composition of 
+ conversions, we define a conversion on a given number of bits : *) 
+
+Fixpoint N2Bv_gen (n:nat)(a:N) { struct n } : Bvector n := 
+ match n return Bvector n with 
+   | 0 => Bnil
+   | S n => match a with 
+       | N0 => Bvect_false (S n)
+       | Npos xH => Bcons true _ (Bvect_false n)
+       | Npos (xO p) => Bcons false _ (N2Bv_gen n (Npos p))
+       | Npos (xI p) => Bcons true _ (N2Bv_gen n (Npos p))
+      end
+  end.
+
+(** The first [N2Bv] is then a special case of [N2Bv_gen] *)
+
+Lemma N2Bv_N2Bv_gen : forall (a:N), N2Bv a = N2Bv_gen (Nsize a) a.
+Proof.
+destruct a; simpl.
+auto.
+induction p; simpl; intros; auto; congruence.
+Qed.
+
+(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of 
+   [a] plus some zeros. *)
+
+Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), 
+ N2Bv_gen (Nsize a + k) a = Vextend _ _ _ (N2Bv a) (Bvect_false k).
+Proof.
+destruct a; simpl.
+destruct k; simpl; auto.
+induction p; simpl; intros;unfold Bcons; f_equal; auto.
+Qed.
+
+(** Here comes now the second composition result. *)
+
+Lemma N2Bv_Bv2N : forall n (bv:Bvector n), 
+   N2Bv_gen n (Bv2N n bv) = bv.
+Proof.
+induction n; intros.
+rewrite (V0_eq _ bv); simpl; auto.
+rewrite (VSn_eq _ _ bv); simpl.
+generalize (IHn (Vtail _ _ bv)); clear IHn.
+unfold Bcons.
+destruct (Bv2N _ (Vtail _ _ bv)); 
+ destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial; 
+  induction n; simpl; auto.
+Qed.
+
+(** accessing some precise bits. *)
+
+Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), 
+  Nbit0 (Bv2N _ bv) = Blow _ bv.
+Proof.
+intros.
+unfold Blow.
+pattern bv at 1; rewrite (VSn_eq _ _ bv).
+simpl.
+destruct (Bv2N n (Vtail bool n bv)); simpl; 
+ destruct (Vhead bool n bv); auto.
+Qed.
+
+Definition Bnth (n:nat)(bv:Bvector n)(p:nat) : p<n -> bool.
+Proof.
+ induction 1.
+ intros.
+ elimtype False; inversion H.
+ intros.
+ destruct p.
+ exact a.
+ apply (IHbv p); auto with arith.
+Defined.
+
+Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n), 
+  Bnth _ bv p H = Nbit (Bv2N _ bv) p.
+Proof.
+induction bv; intros.
+inversion H.
+destruct p; simpl; destruct (Bv2N n bv); destruct a; simpl in *; auto.
+Qed.
+
+Lemma Nbit_Nsize : forall n p, Nsize n <= p -> Nbit n p = false.
+Proof.
+destruct n as [|n].
+simpl; auto.
+induction n; simpl in *; intros; destruct p; auto with arith.
+inversion H.
+inversion H.
+Qed.
+
+Lemma Nbit_Bth: forall n p (H:p < Nsize n), Nbit n p = Bnth _ (N2Bv n) p H.
+Proof.
+destruct n as [|n].
+inversion H.
+induction n; simpl in *; intros; destruct p; auto with arith.
+inversion H; inversion H1.
+Qed.
+
+(** Xor is the same in the two worlds. *)
+
+Lemma Nxor_BVxor : forall n (bv bv' : Bvector n), 
+  Bv2N _ (BVxor _ bv bv') = Nxor (Bv2N _ bv) (Bv2N _ bv').
+Proof.
+induction n.
+intros.
+rewrite (V0_eq _ bv); rewrite (V0_eq _ bv'); simpl; auto.
+intros.
+rewrite (VSn_eq _ _ bv); rewrite (VSn_eq _ _ bv'); simpl; auto.
+rewrite IHn.
+destruct (Vhead bool n bv); destruct (Vhead bool n bv'); 
+ destruct (Bv2N n (Vtail bool n bv)); destruct (Bv2N n (Vtail bool n bv')); simpl; auto.
+Qed.
+
diff --git a/theories/IntMap/Adist.v b/theories/NArith/Ndist.v
index cdb4c885..d5bfc15c 100644
--- a/theories/IntMap/Adist.v
+++ b/theories/NArith/Ndist.v
@@ -5,40 +5,42 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i 	     $Id: Adist.v,v 1.9.2.1 2004/07/16 19:31:04 herbelin Exp $	      i*)
+(*i 	     $Id: Ndist.v 8733 2006-04-25 22:52:18Z letouzey $	      i*)
 
-Require Import Bool.
-Require Import ZArith.
 Require Import Arith.
 Require Import Min.
-Require Import Addr.
+Require Import BinPos.
+Require Import BinNat.
+Require Import Ndigits.
 
-Fixpoint ad_plength_1 (p:positive) : nat :=
-  match p with
-  | xH => 0
-  | xI _ => 0
-  | xO p' => S (ad_plength_1 p')
-  end.
+(** An ultrametric distance over [N] numbers *)
 
 Inductive natinf : Set :=
   | infty : natinf
   | ni : nat -> natinf.
 
-Definition ad_plength (a:ad) :=
+Fixpoint Pplength (p:positive) : nat :=
+  match p with
+  | xH => 0
+  | xI _ => 0
+  | xO p' => S (Pplength p')
+  end.
+
+Definition Nplength (a:N) :=
   match a with
-  | ad_z => infty
-  | ad_x p => ni (ad_plength_1 p)
+  | N0 => infty
+  | Npos p => ni (Pplength p)
   end.
 
-Lemma ad_plength_infty : forall a:ad, ad_plength a = infty -> a = ad_z.
+Lemma Nplength_infty : forall a:N, Nplength a = infty -> a = N0.
 Proof.
   simple induction a; trivial. 
-  unfold ad_plength in |- *; intros; discriminate H.
+  unfold Nplength in |- *; intros; discriminate H.
 Qed.
 
-Lemma ad_plength_zeros :
- forall (a:ad) (n:nat),
-   ad_plength a = ni n -> forall k:nat, k < n -> ad_bit a k = false.
+Lemma Nplength_zeros :
+ forall (a:N) (n:nat),
+   Nplength a = ni n -> forall k:nat, k < n -> Nbit a k = false.
 Proof.
   simple induction a; trivial. 
   simple induction p. simple induction n. intros. inversion H1.
@@ -46,33 +48,33 @@ Proof.
   intros. simpl in H1. discriminate H1.
   simple induction k. trivial.
   generalize H0. case n. intros. inversion H3.
-  intros. simpl in |- *. unfold ad_bit in H. apply (H n0). simpl in H1. inversion H1. reflexivity.
+  intros. simpl in |- *. unfold Nbit in H. apply (H n0). simpl in H1. inversion H1. reflexivity.
   exact (lt_S_n n1 n0 H3).
   simpl in |- *. intros n H. inversion H. intros. inversion H0.
 Qed.
 
-Lemma ad_plength_one :
- forall (a:ad) (n:nat), ad_plength a = ni n -> ad_bit a n = true.
+Lemma Nplength_one :
+ forall (a:N) (n:nat), Nplength a = ni n -> Nbit a n = true.
 Proof.
   simple induction a. intros. inversion H.
   simple induction p. intros. simpl in H0. inversion H0. reflexivity.
-  intros. simpl in H0. inversion H0. simpl in |- *. unfold ad_bit in H. apply H. reflexivity.
+  intros. simpl in H0. inversion H0. simpl in |- *. unfold Nbit in H. apply H. reflexivity.
   intros. simpl in H. inversion H. reflexivity.
 Qed.
 
-Lemma ad_plength_first_one :
- forall (a:ad) (n:nat),
-   (forall k:nat, k < n -> ad_bit a k = false) ->
-   ad_bit a n = true -> ad_plength a = ni n.
+Lemma Nplength_first_one :
+ forall (a:N) (n:nat),
+   (forall k:nat, k < n -> Nbit a k = false) ->
+   Nbit a n = true -> Nplength a = ni n.
 Proof.
   simple induction a. intros. simpl in H0. discriminate H0.
   simple induction p. intros. generalize H0. case n. intros. reflexivity.
-  intros. absurd (ad_bit (ad_x (xI p0)) 0 = false). trivial with bool.
+  intros. absurd (Nbit (Npos (xI p0)) 0 = false). trivial with bool.
   auto with bool arith.
   intros. generalize H0 H1. case n. intros. simpl in H3. discriminate H3.
-  intros. simpl in |- *. unfold ad_plength in H.
-  cut (ni (ad_plength_1 p0) = ni n0). intro. inversion H4. reflexivity.
-  apply H. intros. change (ad_bit (ad_x (xO p0)) (S k) = false) in |- *. apply H2. apply lt_n_S. exact H4.
+  intros. simpl in |- *. unfold Nplength in H.
+  cut (ni (Pplength p0) = ni n0). intro. inversion H4. reflexivity.
+  apply H. intros. change (Nbit (Npos (xO p0)) (S k) = false) in |- *. apply H2. apply lt_n_S. exact H4.
   exact H3.
   intro. case n. trivial.
   intros. simpl in H0. discriminate H0.
@@ -220,117 +222,117 @@ Proof.
   unfold ni_le in |- *. unfold ni_min in |- *. intros. inversion H. apply le_min_r.
 Qed.
 
-Lemma ad_plength_lb :
- forall (a:ad) (n:nat),
-   (forall k:nat, k < n -> ad_bit a k = false) -> ni_le (ni n) (ad_plength a).
+Lemma Nplength_lb :
+ forall (a:N) (n:nat),
+   (forall k:nat, k < n -> Nbit a k = false) -> ni_le (ni n) (Nplength a).
 Proof.
   simple induction a. intros. exact (ni_min_inf_r (ni n)).
-  intros. unfold ad_plength in |- *. apply le_ni_le. case (le_or_lt n (ad_plength_1 p)). trivial.
-  intro. absurd (ad_bit (ad_x p) (ad_plength_1 p) = false).
+  intros. unfold Nplength in |- *. apply le_ni_le. case (le_or_lt n (Pplength p)). trivial.
+  intro. absurd (Nbit (Npos p) (Pplength p) = false).
   rewrite
-   (ad_plength_one (ad_x p) (ad_plength_1 p)
-      (refl_equal (ad_plength (ad_x p)))).
+   (Nplength_one (Npos p) (Pplength p)
+      (refl_equal (Nplength (Npos p)))).
   discriminate.
   apply H. exact H0.
 Qed.
 
-Lemma ad_plength_ub :
- forall (a:ad) (n:nat), ad_bit a n = true -> ni_le (ad_plength a) (ni n).
+Lemma Nplength_ub :
+ forall (a:N) (n:nat), Nbit a n = true -> ni_le (Nplength a) (ni n).
 Proof.
   simple induction a. intros. discriminate H.
-  intros. unfold ad_plength in |- *. apply le_ni_le. case (le_or_lt (ad_plength_1 p) n). trivial.
-  intro. absurd (ad_bit (ad_x p) n = true).
+  intros. unfold Nplength in |- *. apply le_ni_le. case (le_or_lt (Pplength p) n). trivial.
+  intro. absurd (Nbit (Npos p) n = true).
   rewrite
-   (ad_plength_zeros (ad_x p) (ad_plength_1 p)
-      (refl_equal (ad_plength (ad_x p))) n H0).
+   (Nplength_zeros (Npos p) (Pplength p)
+      (refl_equal (Nplength (Npos p))) n H0).
   discriminate.
   exact H.
 Qed.
 
 
-(** We define an ultrametric distance between addresses: 
+(** We define an ultrametric distance between [N] numbers: 
     $d(a,a')=1/2^pd(a,a')$, 
     where $pd(a,a')$ is the number of identical bits at the beginning 
     of $a$ and $a'$ (infinity if $a=a'$).  
     Instead of working with $d$, we work with $pd$, namely
-    [ad_pdist]: *)
+    [Npdist]: *)
 
-Definition ad_pdist (a a':ad) := ad_plength (ad_xor a a').
+Definition Npdist (a a':N) := Nplength (Nxor a a').
 
 (** d is a distance, so $d(a,a')=0$ iff $a=a'$; this means that
     $pd(a,a')=infty$ iff $a=a'$: *)
 
-Lemma ad_pdist_eq_1 : forall a:ad, ad_pdist a a = infty.
+Lemma Npdist_eq_1 : forall a:N, Npdist a a = infty.
 Proof.
-  intros. unfold ad_pdist in |- *. rewrite ad_xor_nilpotent. reflexivity.
+  intros. unfold Npdist in |- *. rewrite Nxor_nilpotent. reflexivity.
 Qed.
 
-Lemma ad_pdist_eq_2 : forall a a':ad, ad_pdist a a' = infty -> a = a'.
+Lemma Npdist_eq_2 : forall a a':N, Npdist a a' = infty -> a = a'.
 Proof.
-  intros. apply ad_xor_eq. apply ad_plength_infty. exact H.
+  intros. apply Nxor_eq. apply Nplength_infty. exact H.
 Qed.
 
 (** $d$ is a distance, so $d(a,a')=d(a',a)$: *)
 
-Lemma ad_pdist_comm : forall a a':ad, ad_pdist a a' = ad_pdist a' a.
+Lemma Npdist_comm : forall a a':N, Npdist a a' = Npdist a' a.
 Proof.
-  unfold ad_pdist in |- *. intros. rewrite ad_xor_comm. reflexivity.
+  unfold Npdist in |- *. intros. rewrite Nxor_comm. reflexivity.
 Qed.
 
 (** $d$ is an ultrametric distance, that is, not only $d(a,a')\leq
     d(a,a'')+d(a'',a')$,
   but in fact $d(a,a')\leq max(d(a,a''),d(a'',a'))$.
-  This means that $min(pd(a,a''),pd(a'',a'))<=pd(a,a')$ (lemma [ad_pdist_ultra] below).
-  This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{ad\_plength}}(a))$
+  This means that $min(pd(a,a''),pd(a'',a'))<=pd(a,a')$ (lemma [Npdist_ultra] below).
+  This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{Nplength}}(a))$
   is an ultrametric norm, i.e. that $|a-a'| \leq max (|a-a''|, |a''-a'|)$,
   or equivalently that $|a+b|<=max(|a|,|b|)$, i.e. that
-  min $(\texttt{ad\_plength}(a), \texttt{ad\_plength}(b)) \leq 
-  \texttt{ad\_plength} (a~\texttt{xor}~ b)$
-  (lemma [ad_plength_ultra]).
+  min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq 
+  \texttt{Nplength} (a~\texttt{xor}~ b)$
+  (lemma [Nplength_ultra]).
 *)
 
-Lemma ad_plength_ultra_1 :
- forall a a':ad,
-   ni_le (ad_plength a) (ad_plength a') ->
-   ni_le (ad_plength a) (ad_plength (ad_xor a a')).
+Lemma Nplength_ultra_1 :
+ forall a a':N,
+   ni_le (Nplength a) (Nplength a') ->
+   ni_le (Nplength a) (Nplength (Nxor a a')).
 Proof.
-  simple induction a. intros. unfold ni_le in H. unfold ad_plength at 1 3 in H.
-  rewrite (ni_min_inf_l (ad_plength a')) in H.
-  rewrite (ad_plength_infty a' H). simpl in |- *. apply ni_le_refl.
-  intros. unfold ad_plength at 1 in |- *. apply ad_plength_lb. intros.
-  cut (forall a'':ad, ad_xor (ad_x p) a' = a'' -> ad_bit a'' k = false).
+  simple induction a. intros. unfold ni_le in H. unfold Nplength at 1 3 in H.
+  rewrite (ni_min_inf_l (Nplength a')) in H.
+  rewrite (Nplength_infty a' H). simpl in |- *. apply ni_le_refl.
+  intros. unfold Nplength at 1 in |- *. apply Nplength_lb. intros.
+  cut (forall a'':N, Nxor (Npos p) a' = a'' -> Nbit a'' k = false).
   intros. apply H1. reflexivity.
   intro a''. case a''. intro. reflexivity.
-  intros. rewrite <- H1. rewrite (ad_xor_semantics (ad_x p) a' k). unfold adf_xor in |- *.
+  intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k). unfold xorf in |- *.
   rewrite
-   (ad_plength_zeros (ad_x p) (ad_plength_1 p)
-      (refl_equal (ad_plength (ad_x p))) k H0).
+   (Nplength_zeros (Npos p) (Pplength p)
+      (refl_equal (Nplength (Npos p))) k H0).
   generalize H. case a'. trivial.
-  intros. cut (ad_bit (ad_x p1) k = false). intros. rewrite H3. reflexivity.
-  apply ad_plength_zeros with (n := ad_plength_1 p1). reflexivity.
-  apply (lt_le_trans k (ad_plength_1 p) (ad_plength_1 p1)). exact H0.
+  intros. cut (Nbit (Npos p1) k = false). intros. rewrite H3. reflexivity.
+  apply Nplength_zeros with (n := Pplength p1). reflexivity.
+  apply (lt_le_trans k (Pplength p) (Pplength p1)). exact H0.
   apply ni_le_le. exact H2.
 Qed.
 
-Lemma ad_plength_ultra :
- forall a a':ad,
-   ni_le (ni_min (ad_plength a) (ad_plength a')) (ad_plength (ad_xor a a')).
+Lemma Nplength_ultra :
+ forall a a':N,
+   ni_le (ni_min (Nplength a) (Nplength a')) (Nplength (Nxor a a')).
 Proof.
-  intros. case (ni_le_total (ad_plength a) (ad_plength a')). intro.
-  cut (ni_min (ad_plength a) (ad_plength a') = ad_plength a).
-  intro. rewrite H0. apply ad_plength_ultra_1. exact H.
+  intros. case (ni_le_total (Nplength a) (Nplength a')). intro.
+  cut (ni_min (Nplength a) (Nplength a') = Nplength a).
+  intro. rewrite H0. apply Nplength_ultra_1. exact H.
   exact H.
-  intro. cut (ni_min (ad_plength a) (ad_plength a') = ad_plength a').
-  intro. rewrite H0. rewrite ad_xor_comm. apply ad_plength_ultra_1. exact H.
+  intro. cut (ni_min (Nplength a) (Nplength a') = Nplength a').
+  intro. rewrite H0. rewrite Nxor_comm. apply Nplength_ultra_1. exact H.
   rewrite ni_min_comm. exact H.
 Qed.
 
-Lemma ad_pdist_ultra :
- forall a a' a'':ad,
-   ni_le (ni_min (ad_pdist a a'') (ad_pdist a'' a')) (ad_pdist a a').
+Lemma Npdist_ultra :
+ forall a a' a'':N,
+   ni_le (ni_min (Npdist a a'') (Npdist a'' a')) (Npdist a a').
 Proof.
-  intros. unfold ad_pdist in |- *. cut (ad_xor (ad_xor a a'') (ad_xor a'' a') = ad_xor a a').
-  intro. rewrite <- H. apply ad_plength_ultra.
-  rewrite ad_xor_assoc. rewrite <- (ad_xor_assoc a'' a'' a'). rewrite ad_xor_nilpotent.
-  rewrite ad_xor_neutral_left. reflexivity.
+  intros. unfold Npdist in |- *. cut (Nxor (Nxor a a'') (Nxor a'' a') = Nxor a a').
+  intro. rewrite <- H. apply Nplength_ultra.
+  rewrite Nxor_assoc. rewrite <- (Nxor_assoc a'' a'' a'). rewrite Nxor_nilpotent.
+  rewrite Nxor_neutral_left. reflexivity.
 Qed.
\ No newline at end of file
diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v
new file mode 100644
index 00000000..94f50bd0
--- /dev/null
+++ b/theories/NArith/Nnat.v
@@ -0,0 +1,177 @@
+(************************************************************************)
+(*  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: Nnat.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
+
+Require Import Arith_base.
+Require Import Compare_dec.
+Require Import Sumbool.
+Require Import Div2.
+Require Import BinPos.
+Require Import BinNat.
+Require Import Pnat.
+
+(** Translation from [N] to [nat] and back. *)
+
+Definition nat_of_N (a:N) :=
+  match a with
+  | N0 => 0%nat
+  | Npos p => nat_of_P p
+  end.
+
+Definition N_of_nat (n:nat) :=
+  match n with
+  | O => N0
+  | S n' => Npos (P_of_succ_nat n')
+  end.
+
+Lemma N_of_nat_of_N : forall a:N, N_of_nat (nat_of_N a) = a.
+Proof.
+  destruct a as [| p]. reflexivity.
+  simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. 
+  rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H.
+  rewrite nat_of_P_inj with (1 := H). reflexivity.
+Qed.
+
+Lemma nat_of_N_of_nat : forall n:nat, nat_of_N (N_of_nat n) = n.
+Proof.
+  induction n. trivial.
+  intros. simpl in |- *. apply nat_of_P_o_P_of_succ_nat_eq_succ.
+Qed.
+
+(** Interaction of this translation and usual operations. *)
+
+Lemma nat_of_Ndouble : forall a, nat_of_N (Ndouble a) = 2*(nat_of_N a).
+Proof.
+  destruct a; simpl nat_of_N; auto.
+  apply nat_of_P_xO.
+Qed.
+
+Lemma N_of_double : forall n, N_of_nat (2*n) = Ndouble (N_of_nat n).
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  rewrite <- nat_of_Ndouble.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Ndouble_plus_one : 
+  forall a, nat_of_N (Ndouble_plus_one a) = S (2*(nat_of_N a)).
+Proof.
+  destruct a; simpl nat_of_N; auto.
+  apply nat_of_P_xI.
+Qed.
+
+Lemma N_of_double_plus_one : 
+  forall n, N_of_nat (S (2*n)) = Ndouble_plus_one (N_of_nat n).
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  rewrite <- nat_of_Ndouble_plus_one.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Nsucc : forall a, nat_of_N (Nsucc a) = S (nat_of_N a).
+Proof.
+  destruct a; simpl.
+  apply nat_of_P_xH.
+  apply nat_of_P_succ_morphism.
+Qed.
+
+Lemma N_of_S : forall n, N_of_nat (S n) = Nsucc (N_of_nat n).
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  rewrite <- nat_of_Nsucc.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Nplus : 
+  forall a a', nat_of_N (Nplus a a') = (nat_of_N a)+(nat_of_N a').
+Proof.
+  destruct a; destruct a'; simpl; auto.
+  apply nat_of_P_plus_morphism.
+Qed.
+
+Lemma N_of_plus : 
+  forall n n', N_of_nat (n+n') = Nplus (N_of_nat n) (N_of_nat n').
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
+  rewrite <- nat_of_Nplus.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Nmult : 
+  forall a a', nat_of_N (Nmult a a') = (nat_of_N a)*(nat_of_N a').
+Proof.
+  destruct a; destruct a'; simpl; auto.
+  apply nat_of_P_mult_morphism.
+Qed.
+
+Lemma N_of_mult : 
+  forall n n', N_of_nat (n*n') = Nmult (N_of_nat n) (N_of_nat n').
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
+  rewrite <- nat_of_Nmult.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Ndiv2 : 
+  forall a, nat_of_N (Ndiv2 a) = div2 (nat_of_N a).
+Proof.
+  destruct a; simpl in *; auto.
+  destruct p; auto.
+  rewrite nat_of_P_xI.
+  rewrite div2_double_plus_one; auto.
+  rewrite nat_of_P_xO.
+  rewrite div2_double; auto.
+Qed.  
+
+Lemma N_of_div2 : 
+  forall n, N_of_nat (div2 n) = Ndiv2 (N_of_nat n).
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  rewrite <- nat_of_Ndiv2.
+  apply N_of_nat_of_N.
+Qed.
+
+Lemma nat_of_Ncompare : 
+ forall a a', Ncompare a a' = nat_compare (nat_of_N a) (nat_of_N a').
+Proof.
+  destruct a; destruct a'; simpl.
+  compute; auto.
+  generalize (lt_O_nat_of_P p).
+  unfold nat_compare.
+  destruct (lt_eq_lt_dec 0 (nat_of_P p)) as [[H|H]|H]; auto.
+  rewrite <- H; inversion 1.
+  intros; generalize (lt_trans _ _ _ H0 H); inversion 1.
+  generalize (lt_O_nat_of_P p).
+  unfold nat_compare.
+  destruct (lt_eq_lt_dec (nat_of_P p) 0) as [[H|H]|H]; auto.
+  intros; generalize (lt_trans _ _ _ H0 H); inversion 1.
+  rewrite H; inversion 1.
+  unfold nat_compare.
+  destruct (lt_eq_lt_dec (nat_of_P p) (nat_of_P p0)) as [[H|H]|H]; auto.
+  apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
+  rewrite (nat_of_P_inj _ _ H); apply Pcompare_refl.
+  apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
+Qed.
+
+Lemma N_of_nat_compare : 
+ forall n n', nat_compare n n' = Ncompare (N_of_nat n) (N_of_nat n').
+Proof.
+  intros.
+  pattern n at 1; rewrite <- (nat_of_N_of_nat n).
+  pattern n' at 1; rewrite <- (nat_of_N_of_nat n').
+  symmetry; apply nat_of_Ncompare.
+Qed.
diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v
index f5bbb1c9..88abc700 100644
--- a/theories/NArith/Pnat.v
+++ b/theories/NArith/Pnat.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Pnat.v,v 1.3.2.1 2004/07/16 19:31:07 herbelin Exp $ i*)
+(*i $Id: Pnat.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 Require Import BinPos.
 
diff --git a/theories/NArith/intro.tex b/theories/NArith/intro.tex
new file mode 100644
index 00000000..83eed970
--- /dev/null
+++ b/theories/NArith/intro.tex
@@ -0,0 +1,5 @@
+\section{Binary positive and non negative integers : NArith}\label{NArith}
+
+Here are defined various arithmetical notions and their properties,
+similar to those of {\tt Arith}.
+
diff --git a/parsing/g_natsyntaxnew.mli b/theories/QArith/QArith.v
index 50d38133..03935e2b 100644
--- a/parsing/g_natsyntaxnew.mli
+++ b/theories/QArith/QArith.v
@@ -6,6 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: g_natsyntaxnew.mli,v 1.1.2.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+(*i $Id: QArith.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
 
-(* Nice syntax for naturals. *)
+Require Export QArith_base.
+Require Export Qring.
+Require Export Qreduction.
diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v
new file mode 100644
index 00000000..66d16cfe
--- /dev/null
+++ b/theories/QArith/QArith_base.v
@@ -0,0 +1,690 @@
+(************************************************************************)
+(*  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: QArith_base.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+Require Export ZArith.
+Require Export ZArithRing.
+Require Export Setoid.
+
+(** * Definition of [Q] and basic properties *)
+
+(** Rationals are pairs of [Z] and [positive] numbers. *)
+
+Record Q : Set := Qmake {Qnum : Z; Qden : positive}.
+
+Delimit Scope Q_scope with Q.
+Bind Scope Q_scope with Q.
+Arguments Scope Qmake [Z_scope positive_scope].
+Open Scope Q_scope.
+Ltac simpl_mult := repeat rewrite Zpos_mult_morphism.
+
+(** [a#b] denotes the fraction [a] over [b]. *)
+
+Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope.
+
+Definition inject_Z (x : Z) := Qmake x 1. 
+Arguments Scope inject_Z [Z_scope].
+
+Notation " 'QDen'  p " := (Zpos (Qden p)) (at level 20, no associativity) : Q_scope.
+Notation " 0 " := (0#1) : Q_scope.
+Notation " 1 " := (1#1) : Q_scope.
+
+Definition Qeq (p q : Q) := (Qnum p * QDen q)%Z = (Qnum q * QDen p)%Z.
+Definition Qle (x y : Q) := (Qnum x * QDen y <= Qnum y * QDen x)%Z.
+Definition Qlt (x y : Q) := (Qnum x * QDen y < Qnum y * QDen x)%Z.
+Notation Qgt := (fun x y : Q => Qlt y x).
+Notation Qge := (fun x y : Q => Qle y x).
+
+Infix "==" := Qeq (at level 70, no associativity) : Q_scope. 
+Infix "<" := Qlt : Q_scope.
+Infix ">" := Qgt : Q_scope.
+Infix "<=" := Qle : Q_scope.
+Infix ">=" := Qge : Q_scope.
+Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope.
+
+(** Another approach : using Qcompare for defining order relations. *)
+
+Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z.
+Notation "p ?= q" := (Qcompare p q) : Q_scope.
+
+Lemma Qeq_alt : forall p q, (p == q) <-> (p ?= q) = Eq.
+Proof.
+unfold Qeq, Qcompare; intros; split; intros.
+rewrite H; apply Zcompare_refl.
+apply Zcompare_Eq_eq; auto.
+Qed.
+
+Lemma Qlt_alt : forall p q, (p<q) <-> (p?=q = Lt).
+Proof.
+unfold Qlt, Qcompare, Zlt; split; auto.
+Qed.
+
+Lemma Qgt_alt : forall p q, (p>q) <-> (p?=q = Gt).
+Proof.
+unfold Qlt, Qcompare, Zlt.
+intros; rewrite Zcompare_Gt_Lt_antisym; split; auto.
+Qed.
+
+Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt).
+Proof.
+unfold Qle, Qcompare, Zle; split; auto.
+Qed.
+
+Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt).
+Proof.
+unfold Qle, Qcompare, Zle.
+split; intros; swap H.
+rewrite Zcompare_Gt_Lt_antisym; auto.
+rewrite Zcompare_Gt_Lt_antisym in H0; auto.
+Qed.
+
+Hint Unfold Qeq Qlt Qle: qarith.
+Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith.
+
+(** * Properties of equality. *)
+
+Theorem Qeq_refl : forall x, x == x.
+Proof.
+ auto with qarith.
+Qed.
+
+Theorem Qeq_sym : forall x y, x == y -> y == x. 
+Proof.
+ auto with qarith.
+Qed.
+
+Theorem Qeq_trans : forall x y z, x == y -> y == z -> x == z.
+Proof.
+unfold Qeq in |- *; intros.
+apply Zmult_reg_l with (QDen y). 
+auto with qarith.
+transitivity (Qnum x * QDen y * QDen z)%Z; try ring.
+rewrite H.
+transitivity (Qnum y * QDen z * QDen x)%Z; try ring.
+rewrite H0; ring.
+Qed.
+
+(** Furthermore, this equality is decidable: *)
+
+Theorem Qeq_dec : forall x y, {x==y} + {~ x==y}.
+Proof.
+ intros; case (Z_eq_dec (Qnum x * QDen y) (Qnum y * QDen x)); auto.
+Defined.
+
+(** We now consider [Q] seen as a setoid. *)
+
+Definition Q_Setoid : Setoid_Theory Q Qeq.
+Proof.
+ split; unfold Qeq in |- *; auto; apply Qeq_trans.
+Qed.
+
+Add Setoid Q Qeq Q_Setoid as Qsetoid.
+
+Hint Resolve (Seq_refl Q Qeq Q_Setoid): qarith.
+Hint Resolve (Seq_sym Q Qeq Q_Setoid): qarith.
+Hint Resolve (Seq_trans Q Qeq Q_Setoid): qarith.
+
+
+(** * Addition, multiplication and opposite *)
+
+(** The addition, multiplication and opposite are defined 
+   in the straightforward way: *)
+
+Definition Qplus (x y : Q) :=
+  (Qnum x * QDen y + Qnum y * QDen x) # (Qden x * Qden y).
+
+Definition Qmult (x y : Q) := (Qnum x * Qnum y) # (Qden x * Qden y). 
+
+Definition Qopp (x : Q) := (- Qnum x) # (Qden x).
+
+Definition Qminus (x y : Q) := Qplus x (Qopp y).
+
+Definition Qinv (x : Q) :=
+  match Qnum x with
+  | Z0 => 0
+  | Zpos p => (QDen x)#p
+  | Zneg p => (Zneg (Qden x))#p
+  end.
+
+Definition Qdiv (x y : Q) := Qmult x (Qinv y).
+
+Infix "+" := Qplus : Q_scope.
+Notation "- x" := (Qopp x) : Q_scope.
+Infix "-" := Qminus : Q_scope.
+Infix "*" := Qmult : Q_scope.
+Notation "/ x" := (Qinv x) : Q_scope. 
+Infix "/" := Qdiv : Q_scope. 
+
+(** A light notation for [Zpos] *)
+
+Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.
+
+
+(** * Setoid compatibility results *)
+
+Add Morphism Qplus : Qplus_comp. 
+Proof.
+  unfold Qeq, Qplus; simpl.
+  Open Scope Z_scope.
+  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
+  simpl_mult; ring_simplify.
+  replace (p1 * 'r2 * 'q2) with (p1 * 'q2 * 'r2) by ring.
+  rewrite H.
+  replace (r1 * 'p2 * 'q2 * 's2) with (r1 * 's2 * 'p2 * 'q2) by ring.
+  rewrite H0.
+  ring.
+  Close Scope Z_scope.
+Qed.
+
+Add Morphism Qopp : Qopp_comp.
+Proof.
+  unfold Qeq, Qopp; simpl.
+  Open Scope Z_scope.
+  intros.
+  replace (- Qnum x1 * ' Qden x2) with (- (Qnum x1 * ' Qden x2)) by ring.
+  rewrite H in |- *;  ring.
+  Close Scope Z_scope.
+Qed.
+
+Add Morphism Qminus : Qminus_comp.
+Proof.
+  intros.
+  unfold Qminus. 
+  rewrite H; rewrite H0; auto with qarith.
+Qed.
+
+Add Morphism Qmult : Qmult_comp.
+Proof.
+  unfold Qeq; simpl.
+  Open Scope Z_scope.
+  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
+  intros; simpl_mult; ring_simplify.
+  replace (q1 * s1 * 'p2) with (q1 * 'p2 * s1) by ring.
+  rewrite <- H.
+  replace (p1 * r1 * 'q2 * 's2) with (r1 * 's2 * p1 * 'q2) by ring.
+  rewrite H0.
+  ring.
+  Close Scope Z_scope.
+Qed.
+
+Add Morphism Qinv : Qinv_comp.
+Proof.
+  unfold Qeq, Qinv; simpl.
+  Open Scope Z_scope.
+  intros (p1, p2) (q1, q2); simpl.
+  case p1; simpl.
+  intros. 
+  assert (q1 = 0).
+  elim (Zmult_integral q1 ('p2)); auto with zarith.
+  intros; discriminate.
+  subst; auto. 
+  case q1; simpl; intros; try discriminate.
+  rewrite (Pmult_comm p2 p); rewrite (Pmult_comm q2 p0); auto.
+  case q1; simpl; intros; try discriminate.
+  rewrite (Pmult_comm p2 p); rewrite (Pmult_comm q2 p0); auto.
+  Close Scope Z_scope.
+Qed.
+
+Add Morphism Qdiv : Qdiv_comp.
+Proof.
+  intros; unfold Qdiv.
+  rewrite H; rewrite H0; auto with qarith.
+Qed.
+
+Add Morphism Qle with signature Qeq ==> Qeq ==> iff as Qle_comp.
+Proof.
+  cut (forall x1 x2, x1==x2 -> forall x3 x4, x3==x4 -> x1<=x3 -> x2<=x4).
+  split; apply H; assumption || (apply Qeq_sym ; assumption).
+  
+  unfold Qeq, Qle; simpl.
+  Open Scope Z_scope.
+  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0 H1; simpl in *.
+  apply Zmult_le_reg_r with ('p2).
+  unfold Zgt; auto.
+  replace (q1 * 's2 * 'p2) with (q1 * 'p2 * 's2) by ring.
+  rewrite <- H.
+  apply Zmult_le_reg_r with ('r2).
+  unfold Zgt; auto.
+  replace (s1 * 'q2 * 'p2 * 'r2) with (s1 * 'r2 * 'q2 * 'p2) by ring.
+  rewrite <- H0.
+  replace (p1 * 'q2 * 's2 * 'r2) with ('q2 * 's2 * (p1 * 'r2)) by ring.
+  replace (r1 * 's2 * 'q2 * 'p2) with ('q2 * 's2 * (r1 * 'p2)) by ring.
+  auto with zarith.
+  Close Scope Z_scope.
+Qed.
+
+Add Morphism Qlt with signature Qeq ==> Qeq ==> iff as  Qlt_comp.
+Proof.
+  cut (forall x1 x2, x1==x2 -> forall x3 x4, x3==x4 -> x1<x3 -> x2<x4).
+  split; apply H; assumption || (apply Qeq_sym ; assumption).
+
+  unfold Qeq, Qlt; simpl.
+  Open Scope Z_scope.
+  intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0 H1; simpl in *.
+  apply Zgt_lt.
+  generalize (Zlt_gt _ _ H1); clear H1; intro H1.
+  apply Zmult_gt_reg_r with ('p2); auto with zarith.
+  replace (q1 * 's2 * 'p2) with (q1 * 'p2 * 's2) by ring.
+  rewrite <- H.
+  apply Zmult_gt_reg_r with ('r2); auto with zarith.
+  replace (s1 * 'q2 * 'p2 * 'r2) with (s1 * 'r2 * 'q2 * 'p2) by ring.
+  rewrite <- H0.
+  replace (p1 * 'q2 * 's2 * 'r2) with ('q2 * 's2 * (p1 * 'r2)) by ring.
+  replace (r1 * 's2 * 'q2 * 'p2) with ('q2 * 's2 * (r1 * 'p2)) by ring. 
+  apply Zlt_gt.
+  apply Zmult_gt_0_lt_compat_l; auto with zarith.
+  Close Scope Z_scope.
+Qed.
+
+
+Lemma Qcompare_egal_dec: forall n m p q : Q, 
+  (n<m -> p<q) -> (n==m -> p==q) -> (n>m -> p>q) -> ((n?=m) = (p?=q)).
+Proof.
+  intros.
+  do 2 rewrite Qeq_alt in H0.
+  unfold Qeq, Qlt, Qcompare in *.
+  apply Zcompare_egal_dec; auto.
+  omega.
+Qed.
+
+
+Add Morphism Qcompare : Qcompare_comp.
+Proof.
+  intros; apply Qcompare_egal_dec; rewrite H; rewrite H0; auto.
+Qed.
+
+
+(** [0] and [1] are apart *)
+
+Lemma Q_apart_0_1 : ~ 1 == 0.
+Proof.
+  unfold Qeq; auto with qarith.
+Qed.
+
+(** * Properties of [Qadd] *)
+
+(** Addition is associative: *)
+
+Theorem Qplus_assoc : forall x y z, x+(y+z)==(x+y)+z.
+Proof.
+  intros (x1, x2) (y1, y2) (z1, z2).
+  unfold Qeq, Qplus; simpl; simpl_mult; ring.
+Qed.
+
+(** [0] is a neutral element for addition: *)
+
+Lemma Qplus_0_l : forall x, 0+x == x.
+Proof.
+  intros (x1, x2); unfold Qeq, Qplus; simpl; ring.
+Qed.
+
+Lemma Qplus_0_r : forall x, x+0 == x.
+Proof.
+  intros (x1, x2); unfold Qeq, Qplus; simpl.
+  rewrite Pmult_comm; simpl; ring.
+Qed. 
+
+(** Commutativity of addition: *)
+
+Theorem Qplus_comm : forall x y, x+y == y+x.
+Proof.
+  intros (x1, x2); unfold Qeq, Qplus; simpl.
+  intros; rewrite Pmult_comm; ring.
+Qed.
+
+
+(** * Properties of [Qopp] *)
+
+Lemma Qopp_involutive : forall q, - -q == q.
+Proof.
+  red; simpl; intros; ring.
+Qed.
+
+Theorem Qplus_opp_r : forall q, q+(-q) == 0.
+Proof.
+  red; simpl; intro; ring.
+Qed.
+
+
+(** * Properties of [Qmult] *)
+
+(** Multiplication is associative: *)
+
+Theorem Qmult_assoc : forall n m p, n*(m*p)==(n*m)*p.
+Proof.
+  intros; red; simpl; rewrite Pmult_assoc; ring.
+Qed.
+
+(** [1] is a neutral element for multiplication: *)
+
+Lemma Qmult_1_l : forall n, 1*n == n.
+Proof.
+  intro; red; simpl; destruct (Qnum n); auto.
+Qed.
+
+Theorem Qmult_1_r : forall n, n*1==n.
+Proof.
+  intro; red; simpl.
+  rewrite Zmult_1_r with (n := Qnum n).
+  rewrite Pmult_comm; simpl; trivial. 
+Qed.
+
+(** Commutativity of multiplication *)
+
+Theorem Qmult_comm : forall x y, x*y==y*x.
+Proof.
+  intros; red; simpl; rewrite Pmult_comm; ring.
+Qed.
+
+(** Distributivity over [Qadd] *)
+
+Theorem Qmult_plus_distr_r : forall x y z, x*(y+z)==(x*y)+(x*z).
+Proof.
+  intros (x1, x2) (y1, y2) (z1, z2).
+  unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
+Qed.
+
+Theorem Qmult_plus_distr_l : forall x y z, (x+y)*z==(x*z)+(y*z).
+Proof.
+  intros (x1, x2) (y1, y2) (z1, z2).
+  unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
+Qed.
+
+(** Integrality *)
+
+Theorem Qmult_integral : forall x y, x*y==0 -> x==0 \/ y==0.
+Proof.
+  intros (x1,x2) (y1,y2).
+  unfold Qeq, Qmult; simpl; intros.
+  destruct (Zmult_integral (x1*1)%Z (y1*1)%Z); auto.
+  rewrite <- H; ring.
+Qed.
+
+Theorem Qmult_integral_l : forall x y, ~ x == 0 -> x*y == 0 -> y == 0.
+Proof.
+  intros (x1, x2) (y1, y2).
+  unfold Qeq, Qmult; simpl; intros.
+  apply Zmult_integral_l with x1; auto with zarith.
+  rewrite <- H0; ring.
+Qed.
+
+(** * Inverse and division. *) 
+
+Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1.
+Proof.
+  intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl;
+    intros; simpl_mult; try ring.
+  elim H; auto. 
+Qed.
+
+Lemma Qinv_mult_distr : forall p q, / (p * q) == /p * /q.
+Proof.
+  intros (x1,x2) (y1,y2); unfold Qeq, Qinv, Qmult; simpl.
+  destruct x1; simpl; auto; 
+    destruct y1; simpl; auto.
+Qed.
+
+Theorem Qdiv_mult_l : forall x y, ~ y == 0 -> (x*y)/y == x.
+Proof.
+  intros; unfold Qdiv.
+  rewrite <- (Qmult_assoc x y (Qinv y)).
+  rewrite (Qmult_inv_r y H).
+  apply Qmult_1_r.
+Qed.
+
+Theorem Qmult_div_r : forall x y, ~ y == 0 -> y*(x/y) == x.
+Proof.
+  intros; unfold Qdiv.
+  rewrite (Qmult_assoc y x (Qinv y)).
+  rewrite (Qmult_comm y x).
+  fold (Qdiv (Qmult x y) y).
+  apply Qdiv_mult_l; auto.
+Qed.
+
+(** * Properties of order upon Q. *)
+
+Lemma Qle_refl : forall x, x<=x.
+Proof.
+  unfold Qle; auto with zarith.
+Qed.
+
+Lemma Qle_antisym : forall x y, x<=y -> y<=x -> x==y.
+Proof.
+  unfold Qle, Qeq; auto with zarith.
+Qed.
+
+Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z.
+Proof.
+  unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
+  Open Scope Z_scope.
+  apply Zmult_le_reg_r with ('y2).
+  red; trivial.
+  apply Zle_trans with (y1 * 'x2 * 'z2).
+  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
+  apply Zmult_le_compat_r; auto with zarith. 
+  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
+  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
+  apply Zmult_le_compat_r; auto with zarith. 
+  Close Scope Z_scope.
+Qed.
+
+Lemma Qlt_not_eq : forall x y, x<y -> ~ x==y.
+Proof.
+  unfold Qlt, Qeq; auto with zarith.
+Qed.
+
+(** Large = strict or equal *)
+
+Lemma Qlt_le_weak : forall x y, x<y -> x<=y.
+Proof.
+  unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
+Proof.
+  unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
+  Open Scope Z_scope.
+  apply Zgt_lt.
+  apply Zmult_gt_reg_r with ('y2).
+  red; trivial.
+  apply Zgt_le_trans with (y1 * 'x2 * 'z2).
+  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
+  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
+  apply Zmult_gt_compat_r; auto with zarith. 
+  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
+  apply Zmult_le_compat_r; auto with zarith. 
+  Close Scope Z_scope.
+Qed.
+
+Lemma Qlt_le_trans : forall x y z, x<y -> y<=z -> x<z.
+Proof.
+  unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
+  Open Scope Z_scope.
+  apply Zgt_lt.
+  apply Zmult_gt_reg_r with ('y2).
+  red; trivial.
+  apply Zle_gt_trans with (y1 * 'x2 * 'z2).
+  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
+  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
+  apply Zmult_le_compat_r; auto with zarith. 
+  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
+  apply Zmult_gt_compat_r; auto with zarith. 
+  Close Scope Z_scope.
+Qed.
+
+Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z.
+Proof.
+  intros.
+  apply Qle_lt_trans with y; auto.
+  apply Qlt_le_weak; auto.
+Qed.
+
+(** [x<y] iff [~(y<=x)] *)
+
+Lemma Qnot_lt_le : forall x y, ~ x<y -> y<=x.
+Proof.
+  unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qnot_le_lt : forall x y, ~ x<=y -> y<x.
+Proof.
+  unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qlt_not_le : forall x y, x<y -> ~ y<=x.
+Proof.
+  unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qle_not_lt : forall x y, x<=y -> ~ y<x.
+Proof.
+  unfold Qle, Qlt; auto with zarith.
+Qed.
+
+Lemma Qle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
+Proof.
+  unfold Qle, Qlt, Qeq; intros; apply Zle_lt_or_eq; auto.
+Qed.
+
+(** Some decidability results about orders. *)
+
+Lemma Q_dec : forall x y, {x<y} + {y<x} + {x==y}.
+Proof.
+  unfold Qlt, Qle, Qeq; intros.
+  exact (Z_dec' (Qnum x * QDen y) (Qnum y * QDen x)).
+Defined.
+
+Lemma Qlt_le_dec : forall x y, {x<y} + {y<=x}.
+Proof.
+  unfold Qlt, Qle; intros.
+  exact (Z_lt_le_dec (Qnum x * QDen y) (Qnum y * QDen x)).
+Defined.
+
+(** Compatibility of operations with respect to order. *)
+
+Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p.
+Proof.
+  intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl.
+  do 2 rewrite <- Zopp_mult_distr_l; omega.
+Qed.
+
+Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p.
+Proof.
+  intros (x1,x2) (y1,y2); unfold Qle; simpl.
+  rewrite <- Zopp_mult_distr_l.
+  split; omega.
+Qed.
+
+Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p.
+Proof.
+  intros (x1,x2) (y1,y2); unfold Qlt; simpl.
+  rewrite <- Zopp_mult_distr_l.
+  split; omega.
+Qed.
+
+Lemma Qplus_le_compat :
+  forall x y z t, x<=y -> z<=t -> x+z <= y+t.
+Proof.
+  unfold Qplus, Qle; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
+    simpl; simpl_mult.
+  Open Scope Z_scope.
+  intros.
+  match goal with |- ?a <= ?b => ring_simplify a b end.
+  rewrite Zplus_comm.
+  apply Zplus_le_compat.
+  match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end.
+  auto with zarith.
+  match goal with |- ?a <= ?b => ring_simplify x1 y1 ('x2) ('y2) a b end.
+  auto with zarith.
+  Close Scope Z_scope.
+Qed.
+
+Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z.
+Proof.
+  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
+  Open Scope Z_scope.
+  intros; simpl_mult.
+  replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
+  replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
+  apply Zmult_le_compat_r; auto with zarith.
+  Close Scope Z_scope.
+Qed.
+
+Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 <  z  -> x*z <= y*z -> x <= y.
+Proof.
+  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
+  Open Scope Z_scope.
+  simpl_mult.
+  replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
+  replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
+  intros; apply Zmult_le_reg_r with (c1*'c2); auto with zarith.
+  Close Scope Z_scope.
+Qed.
+
+Lemma Qmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
+Proof.
+  intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
+  Open Scope Z_scope.
+  intros; simpl_mult.
+  replace (a1*c1*('b2*'c2)) with ((a1*'b2)*(c1*'c2)) by ring.
+  replace (b1*c1*('a2*'c2)) with ((b1*'a2)*(c1*'c2)) by ring.
+  apply Zmult_lt_compat_r; auto with zarith.
+  apply Zmult_lt_0_compat.
+  omega.
+  compute; auto.
+  Close Scope Z_scope.
+Qed.
+
+(** * Rational to the n-th power *)
+
+Fixpoint Qpower (q:Q)(n:nat) { struct n } : Q := 
+  match n with 
+    | O => 1
+    | S n => q * (Qpower q n)
+  end. 
+
+Notation " q ^ n " := (Qpower q n) : Q_scope.
+
+Lemma Qpower_1 : forall n, 1^n == 1.
+Proof.
+  induction n; simpl; auto with qarith.
+  rewrite IHn; auto with qarith.
+Qed.
+
+Lemma Qpower_0 : forall n, n<>O -> 0^n == 0.
+Proof.
+  destruct n; simpl.
+  destruct 1; auto.
+  intros. 
+  compute; auto.
+Qed.
+
+Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n.
+Proof.
+  induction n; simpl; auto with qarith.
+  intros; compute; intro; discriminate.
+  intros.
+  apply Qle_trans with (0*(p^n)).
+  compute; intro; discriminate.
+  apply Qmult_le_compat_r; auto.
+Qed.
+
+Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z ('p))^n.
+Proof.
+  induction n.
+  compute; auto.
+  simpl.
+  intros; rewrite IHn; clear IHn.
+  unfold Qdiv; rewrite Qinv_mult_distr.
+  setoid_replace (1#p) with (/ inject_Z ('p)).
+  apply Qeq_refl.
+  compute; auto.
+Qed.
+
+
diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v
new file mode 100644
index 00000000..98c5ff9e
--- /dev/null
+++ b/theories/QArith/Qcanon.v
@@ -0,0 +1,550 @@
+(************************************************************************)
+(*  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: Qcanon.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+Require Import Field.
+Require Import QArith.
+Require Import Znumtheory.
+Require Import Eqdep_dec.
+
+(** [Qc] : A canonical representation of rational numbers. 
+   based on the setoid representation [Q]. *)
+
+Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }.
+
+Delimit Scope Qc_scope with Qc.
+Bind Scope Qc_scope with Qc.
+Arguments Scope Qcmake [Q_scope].
+Open Scope Qc_scope.
+
+Lemma Qred_identity : 
+  forall q:Q, Zgcd (Qnum q) (QDen q) = 1%Z -> Qred q = q.
+Proof.
+  unfold Qred; intros (a,b); simpl.
+  generalize (Zggcd_gcd a ('b)) (Zggcd_correct_divisors a ('b)).
+  intros.
+  rewrite H1 in H; clear H1.
+  destruct (Zggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
+  destruct H0.
+  rewrite Zmult_1_l in H, H0.
+  subst; simpl; auto.
+Qed.
+
+Lemma Qred_identity2 : 
+  forall q:Q, Qred q = q -> Zgcd (Qnum q) (QDen q) = 1%Z.
+Proof.
+  unfold Qred; intros (a,b); simpl.
+  generalize (Zggcd_gcd a ('b)) (Zggcd_correct_divisors a ('b)) (Zgcd_is_pos a ('b)).
+  intros.
+  rewrite <- H; rewrite <- H in H1; clear H.
+  destruct (Zggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
+  injection H2; intros; clear H2.
+  destruct H0.
+  clear H0 H3.
+  destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate.
+  f_equal.
+  apply Pmult_reg_r with bb.
+  injection H2; intros. 
+  rewrite <- H0.
+  rewrite H; simpl; auto.
+  elim H1; auto.
+Qed.
+
+Lemma Qred_iff : forall q:Q, Qred q = q <-> Zgcd (Qnum q) (QDen q) = 1%Z.
+Proof.
+  split; intros.
+  apply Qred_identity2; auto.
+  apply Qred_identity; auto.
+Qed.
+
+
+Lemma Qred_involutive : forall q:Q, Qred (Qred q) = Qred q.
+Proof.
+  intros; apply Qred_complete.
+  apply Qred_correct.
+Qed.
+
+Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). 
+Arguments Scope Q2Qc [Q_scope].
+Notation " !! " := Q2Qc : Qc_scope.
+
+Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'.
+Proof.
+  intros (q,proof_q) (q',proof_q').
+  simpl.
+  intros H.
+  assert (H0:=Qred_complete _ _ H).
+  assert (q = q') by congruence.
+  subst q'.
+  assert (proof_q = proof_q'). 
+  apply eq_proofs_unicity; auto; intros.
+  repeat decide equality.
+  congruence.
+Qed.
+Hint Resolve Qc_is_canon.
+
+Notation " 0 " := (!!0) : Qc_scope.
+Notation " 1 " := (!!1) : Qc_scope.
+
+Definition Qcle (x y : Qc) := (x <= y)%Q.
+Definition Qclt (x y : Qc) := (x < y)%Q.
+Notation Qcgt := (fun x y : Qc => Qlt y x).
+Notation Qcge := (fun x y : Qc => Qle y x).
+Infix "<" := Qclt : Qc_scope.
+Infix "<=" := Qcle : Qc_scope.
+Infix ">" := Qcgt : Qc_scope. 
+Infix ">=" := Qcge : Qc_scope. 
+Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope.
+
+Definition Qccompare (p q : Qc) := (Qcompare p q).
+Notation "p ?= q" := (Qccompare p q) : Qc_scope.
+
+Lemma Qceq_alt : forall p q, (p = q) <-> (p ?= q) = Eq.
+Proof.
+  unfold Qccompare.
+  intros; rewrite <- Qeq_alt.
+  split; auto.
+  intro H; rewrite H; auto with qarith.
+Qed.
+
+Lemma Qclt_alt : forall p q, (p<q) <-> (p?=q = Lt).
+Proof.
+  intros; exact (Qlt_alt p q).
+Qed.
+
+Lemma Qcgt_alt : forall p q, (p>q) <-> (p?=q = Gt).
+Proof.
+  intros; exact (Qgt_alt p q).
+Qed.
+
+Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt).
+Proof.
+  intros; exact (Qle_alt p q).
+Qed.
+
+Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt).
+Proof.
+  intros; exact (Qge_alt p q).
+Qed.
+
+(** equality on [Qc] is decidable: *)
+
+Theorem Qc_eq_dec : forall x y:Qc, {x=y} + {x<>y}.
+Proof.
+  intros.
+  destruct (Qeq_dec x y) as [H|H]; auto.
+  right; swap H; subst; auto with qarith.
+Defined. 
+
+(** The addition, multiplication and opposite are defined 
+   in the straightforward way: *)
+
+Definition Qcplus (x y : Qc) := !!(x+y).
+Infix "+" := Qcplus : Qc_scope.
+Definition Qcmult (x y : Qc) := !!(x*y).
+Infix "*" := Qcmult : Qc_scope.
+Definition Qcopp (x : Qc) := !!(-x).
+Notation "- x" := (Qcopp x) : Qc_scope.
+Definition Qcminus (x y : Qc) := x+-y.
+Infix "-" := Qcminus : Qc_scope.
+Definition Qcinv (x : Qc) := !!(/x).
+Notation "/ x" := (Qcinv x) : Qc_scope. 
+Definition Qcdiv (x y : Qc) := x*/y.
+Infix "/" := Qcdiv : Qc_scope. 
+
+(** [0] and [1] are apart *)
+
+Lemma Q_apart_0_1 : 1 <> 0.
+Proof.
+  unfold Q2Qc.
+  intros H; discriminate H.
+Qed.
+
+Ltac qc := match goal with 
+ | q:Qc |- _ => destruct q; qc 
+ | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct
+end.
+
+Opaque Qred.
+
+(** Addition is associative: *)
+
+Theorem Qcplus_assoc : forall x y z, x+(y+z)=(x+y)+z.
+Proof.
+  intros; qc; apply Qplus_assoc.
+Qed.
+
+(** [0] is a neutral element for addition: *)
+
+Lemma Qcplus_0_l : forall x, 0+x = x.
+Proof.
+  intros; qc; apply Qplus_0_l.
+Qed.
+
+Lemma Qcplus_0_r : forall x, x+0 = x.
+Proof.
+  intros; qc; apply Qplus_0_r.
+Qed. 
+
+(** Commutativity of addition: *)
+
+Theorem Qcplus_comm : forall x y, x+y = y+x.
+Proof.
+  intros; qc; apply Qplus_comm.
+Qed.
+
+(** Properties of [Qopp] *)
+
+Lemma Qcopp_involutive : forall q, - -q = q.
+Proof.
+  intros; qc; apply Qopp_involutive.
+Qed.
+
+Theorem Qcplus_opp_r : forall q, q+(-q) = 0.
+Proof.
+  intros; qc; apply Qplus_opp_r.
+Qed.
+
+(** Multiplication is associative: *)
+
+Theorem Qcmult_assoc : forall n m p, n*(m*p)=(n*m)*p.
+Proof.
+  intros; qc; apply Qmult_assoc.
+Qed.
+
+(** [1] is a neutral element for multiplication: *)
+
+Lemma Qcmult_1_l : forall n, 1*n = n.
+Proof.
+  intros; qc; apply Qmult_1_l.
+Qed.
+
+Theorem Qcmult_1_r : forall n, n*1=n.
+Proof.
+  intros; qc; apply Qmult_1_r.
+Qed.
+
+(** Commutativity of multiplication *)
+
+Theorem Qcmult_comm : forall x y, x*y=y*x.
+Proof.
+  intros; qc; apply Qmult_comm.
+Qed.
+
+(** Distributivity *)
+
+Theorem Qcmult_plus_distr_r : forall x y z, x*(y+z)=(x*y)+(x*z).
+Proof.
+  intros; qc; apply Qmult_plus_distr_r.
+Qed.
+
+Theorem Qcmult_plus_distr_l : forall x y z, (x+y)*z=(x*z)+(y*z).
+Proof.
+  intros; qc; apply Qmult_plus_distr_l.
+Qed.
+
+(** Integrality *)
+
+Theorem Qcmult_integral : forall x y, x*y=0 -> x=0 \/ y=0.
+Proof.
+  intros.
+  destruct (Qmult_integral x y); try qc; auto.
+  injection H; clear H; intros.
+  rewrite <- (Qred_correct (x*y)).
+  rewrite <- (Qred_correct 0).
+  rewrite H; auto with qarith.
+Qed.
+
+Theorem Qcmult_integral_l : forall x y, ~ x = 0 -> x*y = 0 -> y = 0.
+Proof.
+  intros; destruct (Qcmult_integral _ _ H0); tauto.
+Qed. 
+
+(** Inverse and division. *) 
+
+Theorem Qcmult_inv_r : forall x, x<>0 -> x*(/x) = 1.
+Proof.
+  intros; qc; apply Qmult_inv_r; auto. 
+Qed.
+
+Theorem Qcmult_inv_l : forall x, x<>0 -> (/x)*x = 1.
+Proof.
+  intros.
+  rewrite Qcmult_comm.
+  apply Qcmult_inv_r; auto.
+Qed.
+
+Lemma Qcinv_mult_distr : forall p q, / (p * q) = /p * /q.
+Proof.
+  intros; qc; apply Qinv_mult_distr.
+Qed.
+
+Theorem Qcdiv_mult_l : forall x y, y<>0 -> (x*y)/y = x.
+Proof.
+  unfold Qcdiv.
+  intros.
+  rewrite <- Qcmult_assoc.
+  rewrite Qcmult_inv_r; auto.
+  apply Qcmult_1_r.
+Qed.
+
+Theorem Qcmult_div_r : forall x y, ~ y = 0 -> y*(x/y) = x.
+Proof.
+  unfold Qcdiv.
+  intros.
+  rewrite Qcmult_assoc.
+  rewrite Qcmult_comm.
+  rewrite Qcmult_assoc.
+  rewrite Qcmult_inv_l; auto.
+  apply Qcmult_1_l.
+Qed.
+
+(** Properties of order upon Q. *)
+
+Lemma Qcle_refl : forall x, x<=x.
+Proof.
+  unfold Qcle; intros; simpl; apply Qle_refl.
+Qed.
+
+Lemma Qcle_antisym : forall x y, x<=y -> y<=x -> x=y.
+Proof.
+  unfold Qcle; intros; simpl in *.
+  apply Qc_is_canon; apply Qle_antisym; auto.
+Qed.
+
+Lemma Qcle_trans : forall x y z, x<=y -> y<=z -> x<=z.
+Proof.
+  unfold Qcle; intros; eapply Qle_trans; eauto.
+Qed.
+
+Lemma Qclt_not_eq : forall x y, x<y -> x<>y.
+Proof.
+  unfold Qclt; intros; simpl in *.
+  intro; destruct (Qlt_not_eq _ _ H).
+  subst; auto with qarith.
+Qed.
+
+(** Large = strict or equal *)
+
+Lemma Qclt_le_weak : forall x y, x<y -> x<=y.
+Proof.
+  unfold Qcle, Qclt; intros; apply Qlt_le_weak; auto.
+Qed.
+
+Lemma Qcle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
+Proof.
+  unfold Qcle, Qclt; intros; eapply Qle_lt_trans; eauto.
+Qed.
+
+Lemma Qclt_le_trans : forall x y z, x<y -> y<=z -> x<z.
+Proof.
+  unfold Qcle, Qclt; intros; eapply Qlt_le_trans; eauto.
+Qed.
+
+Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z.
+Proof.
+  unfold Qclt; intros; eapply Qlt_trans; eauto.
+Qed.
+
+(** [x<y] iff [~(y<=x)] *)
+
+Lemma Qcnot_lt_le : forall x y, ~ x<y -> y<=x.
+Proof.
+  unfold Qcle, Qclt; intros; apply Qnot_lt_le; auto.
+Qed.
+
+Lemma Qcnot_le_lt : forall x y, ~ x<=y -> y<x.
+Proof.
+  unfold Qcle, Qclt; intros; apply Qnot_le_lt; auto.
+Qed.
+
+Lemma Qclt_not_le : forall x y, x<y -> ~ y<=x.
+Proof.
+  unfold Qcle, Qclt; intros; apply Qlt_not_le; auto.
+Qed.
+
+Lemma Qcle_not_lt : forall x y, x<=y -> ~ y<x.
+Proof.
+  unfold Qcle, Qclt; intros; apply Qle_not_lt; auto.
+Qed.
+
+Lemma Qcle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
+Proof.
+  unfold Qcle, Qclt; intros; apply Qle_lt_or_eq; auto.
+Qed.
+
+(** Some decidability results about orders. *)
+
+Lemma Qc_dec : forall x y, {x<y} + {y<x} + {x=y}.
+Proof.
+  unfold Qclt, Qcle; intros.
+  destruct (Q_dec x y) as [H|H].
+  left; auto.
+  right; apply Qc_is_canon; auto.
+Defined.
+
+Lemma Qclt_le_dec : forall x y, {x<y} + {y<=x}.
+Proof.
+  unfold Qclt, Qcle; intros; apply Qlt_le_dec; auto.
+Defined.
+
+(** Compatibility of operations with respect to order. *)
+
+Lemma Qcopp_le_compat : forall p q, p<=q -> -q <= -p.
+Proof.
+  unfold Qcle, Qcopp; intros; simpl in *.
+  repeat rewrite Qred_correct.
+  apply Qopp_le_compat; auto.
+Qed.
+
+Lemma Qcle_minus_iff : forall p q, p <= q <-> 0 <= q+-p.
+Proof.
+  unfold Qcle, Qcminus; intros; simpl in *.
+  repeat rewrite Qred_correct.
+  apply Qle_minus_iff; auto.
+Qed.
+
+Lemma Qclt_minus_iff : forall p q, p < q <-> 0 < q+-p.
+Proof.
+  unfold Qclt, Qcplus, Qcopp; intros; simpl in *.
+  repeat rewrite Qred_correct.
+  apply Qlt_minus_iff; auto.
+Qed.
+
+Lemma Qcplus_le_compat :
+  forall x y z t, x<=y -> z<=t -> x+z <= y+t.
+Proof.
+  unfold Qcplus, Qcle; intros; simpl in *.
+  repeat rewrite Qred_correct.
+  apply Qplus_le_compat; auto.
+Qed.
+
+Lemma Qcmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z.
+Proof.
+  unfold Qcmult, Qcle; intros; simpl in *.
+  repeat rewrite Qred_correct.
+  apply Qmult_le_compat_r; auto.
+Qed.
+
+Lemma Qcmult_lt_0_le_reg_r : forall x y z, 0 <  z  -> x*z <= y*z -> x <= y.
+Proof.
+  unfold Qcmult, Qcle, Qclt; intros; simpl in *.
+  repeat progress rewrite Qred_correct in * |-. 
+  eapply Qmult_lt_0_le_reg_r; eauto.
+Qed.
+
+Lemma Qcmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
+Proof.
+  unfold Qcmult, Qclt; intros; simpl in *.
+  repeat progress rewrite Qred_correct in *. 
+  eapply Qmult_lt_compat_r; eauto.
+Qed.
+
+(** Rational to the n-th power *)
+
+Fixpoint Qcpower (q:Qc)(n:nat) { struct n } : Qc := 
+  match n with 
+    | O => 1
+    | S n => q * (Qcpower q n)
+  end. 
+
+Notation " q ^ n " := (Qcpower q n) : Qc_scope.
+
+Lemma Qcpower_1 : forall n, 1^n = 1.
+Proof.
+  induction n; simpl; auto with qarith.
+  rewrite IHn; auto with qarith.
+Qed.
+
+Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0.
+Proof.
+  destruct n; simpl.
+  destruct 1; auto.
+  intros. 
+  apply Qc_is_canon.
+  simpl.
+  compute; auto.
+Qed.
+
+Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n.
+Proof.
+  induction n; simpl; auto with qarith.
+  intros; compute; intro; discriminate.
+  intros.
+  apply Qcle_trans with (0*(p^n)).
+  compute; intro; discriminate.
+  apply Qcmult_le_compat_r; auto.
+Qed.
+
+(** And now everything is easier concerning tactics: *)
+
+(** A ring tactic for rational numbers *)
+
+Definition Qc_eq_bool (x y : Qc) :=
+  if Qc_eq_dec x y then true else false.
+
+Lemma Qc_eq_bool_correct : forall x y : Qc, Qc_eq_bool x y = true -> x=y.
+Proof.
+  intros x y; unfold Qc_eq_bool in |- *; case (Qc_eq_dec x y); simpl in |- *; auto.
+  intros _ H; inversion H.
+Qed.
+
+(*
+Definition Qcrt : Ring_Theory Qcplus Qcmult 1 0 Qcopp Qc_eq_bool.
+Proof.
+constructor.
+exact Qcplus_comm.
+exact Qcplus_assoc.
+exact Qcmult_comm.
+exact Qcmult_assoc.
+exact Qcplus_0_l.
+exact Qcmult_1_l.
+exact Qcplus_opp_r.
+exact Qcmult_plus_distr_l.
+unfold Is_true; intros x y; generalize (Qc_eq_bool_correct x y);
+ case (Qc_eq_bool x y); auto.
+Qed.
+Add Ring Qc Qcplus Qcmult 1 0 Qcopp Qc_eq_bool Qcrt [ Qcmake ].
+*)
+Definition Qcrt : ring_theory 0 1 Qcplus Qcmult Qcminus Qcopp (eq(A:=Qc)).
+Proof.
+  constructor.
+  exact Qcplus_0_l.
+  exact Qcplus_comm.
+  exact Qcplus_assoc.
+  exact Qcmult_1_l.
+  exact Qcmult_comm.
+  exact Qcmult_assoc.
+  exact Qcmult_plus_distr_l.
+  reflexivity.
+  exact Qcplus_opp_r.
+Qed.
+
+Definition Qcft :
+  field_theory 0%Qc 1%Qc Qcplus Qcmult Qcminus Qcopp Qcdiv Qcinv (eq(A:=Qc)).
+Proof.
+  constructor.
+  exact Qcrt.
+  exact Q_apart_0_1.
+  reflexivity.
+  exact Qcmult_inv_l.
+Qed.
+
+Add Field Qcfield : Qcft.
+
+(** A field tactic for rational numbers *)
+
+Example test_field : (forall x y : Qc, y<>0 -> (x/y)*y = x)%Qc.
+intros.
+field.
+auto.
+Qed.
+
+
+
diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v
new file mode 100644
index 00000000..6bd161f3
--- /dev/null
+++ b/theories/QArith/Qreals.v
@@ -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 $Id: Qreals.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+Require Export Rbase.
+Require Export QArith_base.
+
+(** A field tactic for rational numbers. *)
+
+(** Since field cannot operate on setoid datatypes (yet?), 
+  we translate Q goals into reals before applying field. *)
+
+Lemma IZR_nz : forall p : positive, IZR (Zpos p) <> 0%R.
+intros; apply not_O_IZR; auto with qarith.
+Qed.
+
+Hint Immediate IZR_nz.
+Hint Resolve Rmult_integral_contrapositive.
+
+Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R.
+
+Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y.
+Proof.
+unfold Qeq, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+apply eq_IZR.
+do 2 rewrite mult_IZR.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+assert ((X2 * X1 * / X2)%R = (X2 * (Y1 * / Y2))%R).
+rewrite <- H; field; auto.
+rewrite Rinv_r_simpl_m in H0; auto; rewrite H0; field; auto.
+Qed.
+
+Lemma Qeq_eqR : forall x y : Q, x==y -> Q2R x = Q2R y.
+Proof.
+unfold Qeq, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+assert ((X1 * Y2)%R = (Y1 * X2)%R).
+ unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ apply IZR_eq; auto.
+clear H.
+field_simplify_eq; auto.
+ring_simplify X1 Y2 (Y2 * X1)%R.
+rewrite H0 in |- *;  ring.
+Qed.
+
+Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y.
+Proof.
+unfold Qle, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+apply le_IZR.
+do 2 rewrite mult_IZR.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
+replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
+apply Rmult_le_compat_r; auto.
+apply Rmult_le_pos.
+unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_le;
+ auto with zarith.
+unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_le;
+ auto with zarith.
+Qed.
+
+Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R.
+Proof.
+unfold Qle, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+assert (X1 * Y2 <= Y1 * X2)%R.
+ unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ apply IZR_le; auto.
+clear H.
+replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
+replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
+apply Rmult_le_compat_r; auto.
+apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat.
+unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+Qed.
+
+Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x<y.
+Proof.
+unfold Qlt, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+apply lt_IZR.
+do 2 rewrite mult_IZR.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
+replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
+apply Rmult_lt_compat_r; auto.
+apply Rmult_lt_0_compat.
+unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+Qed.
+
+Lemma Qlt_Rlt : forall x y : Q, x<y -> (Q2R x < Q2R y)%R.
+Proof.
+unfold Qlt, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+ intros.
+set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
+ set (X2 := IZR (Zpos x2)) in *.
+set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
+ set (Y2 := IZR (Zpos y2)) in *.
+assert (X1 * Y2 < Y1 * X2)%R.
+ unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ apply IZR_lt; auto.
+clear H.
+replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
+replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
+apply Rmult_lt_compat_r; auto.
+apply Rmult_lt_0_compat; apply Rinv_0_lt_compat.
+unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+ auto with zarith.
+Qed.
+
+Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R.
+Proof.
+unfold Qplus, Qeq, Q2R in |- *; intros (x1, x2) (y1, y2);
+ unfold Qden, Qnum in |- *.
+simpl_mult.
+rewrite plus_IZR.
+do 3 rewrite mult_IZR.
+field; auto.
+Qed.
+
+Lemma Q2R_mult : forall x y : Q, Q2R (x*y) = (Q2R x * Q2R y)%R.
+Proof.
+unfold Qmult, Qeq, Q2R in |- *; intros (x1, x2) (y1, y2);
+ unfold Qden, Qnum in |- *.
+simpl_mult.
+do 2 rewrite mult_IZR.
+field; auto.
+Qed.
+
+Lemma Q2R_opp : forall x : Q, Q2R (- x) = (- Q2R x)%R.
+Proof.
+unfold Qopp, Qeq, Q2R in |- *; intros (x1, x2); unfold Qden, Qnum in |- *.
+rewrite Ropp_Ropp_IZR.
+field; auto.
+Qed.
+
+Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R.
+unfold Qminus in |- *; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto.
+Qed.
+
+Lemma Q2R_inv : forall x : Q, ~ x==0#1 -> Q2R (/x) = (/ Q2R x)%R.
+Proof.
+unfold Qinv, Q2R, Qeq in |- *; intros (x1, x2); unfold Qden, Qnum in |- *.
+case x1.
+simpl in |- *; intros; elim H; trivial.
+intros; field; auto.
+intros; 
+  change (IZR (Zneg x2)) with (- IZR (' x2))%R in |- *;
+  change (IZR (Zneg p)) with (- IZR (' p))%R in |- *;
+  field; (*auto 8 with real.*)
+  repeat split; auto; auto with real.
+Qed.
+
+Lemma Q2R_div :
+ forall x y : Q, ~ y==0#1 -> Q2R (x/y) = (Q2R x / Q2R y)%R.
+Proof.
+unfold Qdiv, Rdiv in |- *.
+intros; rewrite Q2R_mult.
+rewrite Q2R_inv; auto.
+Qed.
+
+Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl.
+
+Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto.
+
+(** Examples of use: *)
+
+Goal forall x y z : Q, (x+y)*z == (x*z)+(y*z).
+intros; QField.
+Abort.
+
+Goal forall x y : Q, ~ y==0#1 -> (x/y)*y == x.
+intros; QField.
+intro; apply H; apply eqR_Qeq.
+rewrite H0; unfold Q2R in |- *; simpl in |- *; field; auto with real.
+Abort.
diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v
new file mode 100644
index 00000000..340cac83
--- /dev/null
+++ b/theories/QArith/Qreduction.v
@@ -0,0 +1,169 @@
+(************************************************************************)
+(*  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: Qreduction.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+(** Normalisation functions for rational numbers. *)
+
+Require Export QArith_base.
+Require Import Znumtheory.
+
+(** First, a function that (tries to) build a positive back from a Z. *)
+
+Definition Z2P (z : Z) :=
+  match z with
+  | Z0 => 1%positive
+  | Zpos p => p
+  | Zneg p => p
+  end.
+
+Lemma Z2P_correct : forall z : Z, (0 < z)%Z -> Zpos (Z2P z) = z.
+Proof.
+ simple destruct z; simpl in |- *; auto; intros; discriminate.
+Qed.
+
+Lemma Z2P_correct2 : forall z : Z, 0%Z <> z -> Zpos (Z2P z) = Zabs z.
+Proof.
+ simple destruct z; simpl in |- *; auto; intros; elim H; auto.
+Qed.
+
+(** Simplification of fractions using [Zgcd].
+  This version can compute within Coq. *)
+
+Definition Qred (q:Q) := 
+  let (q1,q2) := q in 
+  let (r1,r2) := snd (Zggcd q1 ('q2)) 
+  in r1#(Z2P r2).
+
+Lemma Qred_correct : forall q, (Qred q) == q.
+Proof.
+  unfold Qred, Qeq; intros (n,d); simpl.
+  generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d)) 
+    (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)).
+  destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl.
+  Open Scope Z_scope.
+  intuition.
+  rewrite <- H in H0,H1; clear H.
+  rewrite H3; rewrite H4.
+  assert (0 <> g).
+  intro; subst g; discriminate.
+  
+  assert (0 < dd).
+  apply Zmult_gt_0_lt_0_reg_r with g.
+  omega.
+  rewrite Zmult_comm.
+  rewrite <- H4; compute; auto.
+  rewrite Z2P_correct; auto.
+  ring.
+  Close Scope Z_scope.
+Qed.
+
+Lemma Qred_complete : forall p q,  p==q -> Qred p = Qred q.
+Proof.
+  intros (a,b) (c,d).
+  unfold Qred, Qeq in *; simpl in *.
+  Open Scope Z_scope.
+  generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) 
+    (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)).
+  destruct (Zggcd a (Zpos b)) as (g,(aa,bb)).
+  generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) 
+    (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)).
+  destruct (Zggcd c (Zpos d)) as (g',(cc,dd)).
+  simpl.
+  intro H; rewrite <- H; clear H.
+  intros Hg'1 Hg'2 (Hg'3,Hg'4).
+  intro H; rewrite <- H; clear H.
+  intros Hg1 Hg2 (Hg3,Hg4).
+  intros.
+  assert (g <> 0).
+  intro; subst g; discriminate.
+  assert (g' <> 0).
+  intro; subst g'; discriminate.
+  elim (rel_prime_cross_prod aa bb cc dd).
+  congruence.
+  unfold rel_prime in |- *.
+  (*rel_prime*)
+  constructor.
+  exists aa; auto with zarith.
+  exists bb; auto with zarith.
+  intros.
+  inversion Hg1.
+  destruct (H6 (g*x)).
+  rewrite Hg3.
+  destruct H2 as (xa,Hxa); exists xa; rewrite Hxa; ring.
+  rewrite Hg4.
+  destruct H3 as (xb,Hxb); exists xb; rewrite Hxb; ring.
+  exists q.
+  apply Zmult_reg_l with g; auto.
+  pattern g at 1; rewrite H7; ring.
+  (* /rel_prime *)
+  unfold rel_prime in |- *.
+  (* rel_prime *)
+  constructor.
+  exists cc; auto with zarith.
+  exists dd; auto with zarith.
+  intros.
+  inversion Hg'1.
+  destruct (H6 (g'*x)).
+  rewrite Hg'3.
+  destruct H2 as (xc,Hxc); exists xc; rewrite Hxc; ring.
+  rewrite Hg'4.
+  destruct H3 as (xd,Hxd); exists xd; rewrite Hxd; ring.
+  exists q.
+  apply Zmult_reg_l with g'; auto.
+  pattern g' at 1; rewrite H7; ring.
+    (* /rel_prime *)
+  assert (0<bb); [|auto with zarith].
+  apply Zmult_gt_0_lt_0_reg_r with g.
+  omega.
+  rewrite Zmult_comm.
+  rewrite <- Hg4; compute; auto.
+  assert (0<dd); [|auto with zarith].
+  apply Zmult_gt_0_lt_0_reg_r with g'.
+  omega.
+  rewrite Zmult_comm.
+  rewrite <- Hg'4; compute; auto.
+  apply Zmult_reg_l with (g'*g).
+  intro H2; elim (Zmult_integral _ _ H2); auto.
+  replace (g'*g*(aa*dd)) with ((g*aa)*(g'*dd)); [|ring].
+  replace (g'*g*(bb*cc)) with ((g'*cc)*(g*bb)); [|ring].
+  rewrite <- Hg3; rewrite <- Hg4; rewrite <- Hg'3; rewrite <- Hg'4; auto.
+  Close Scope Z_scope.
+Qed.
+
+Add Morphism Qred : Qred_comp. 
+Proof.
+  intros q q' H.
+  rewrite (Qred_correct q); auto.
+  rewrite (Qred_correct q'); auto.
+Qed.
+
+Definition Qplus' (p q : Q) := Qred (Qplus p q).
+Definition Qmult' (p q : Q) := Qred (Qmult p q). 
+
+Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q).
+Proof.
+  intros; unfold Qplus' in |- *; apply Qred_correct; auto.
+Qed.
+
+Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q).
+Proof.
+  intros; unfold Qmult' in |- *; apply Qred_correct; auto.
+Qed.
+
+Add Morphism Qplus' : Qplus'_comp.
+Proof.
+  intros; unfold Qplus' in |- *.
+  rewrite H; rewrite H0; auto with qarith.
+Qed.
+
+Add Morphism Qmult' : Qmult'_comp.
+  intros; unfold Qmult' in |- *.
+  rewrite H; rewrite H0; auto with qarith.
+Qed.
+
diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v
new file mode 100644
index 00000000..f9aa3e50
--- /dev/null
+++ b/theories/QArith/Qring.v
@@ -0,0 +1,104 @@
+(************************************************************************)
+(*  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: Qring.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
+
+Require Export Ring.
+Require Export QArith_base.
+
+(** * A ring tactic for rational numbers *)
+
+Definition Qeq_bool (x y : Q) :=
+  if Qeq_dec x y then true else false.
+
+Lemma Qeq_bool_correct : forall x y : Q, Qeq_bool x y = true -> x==y.
+Proof.
+  intros x y; unfold Qeq_bool in |- *; case (Qeq_dec x y); simpl in |- *; auto.
+  intros _ H; inversion H.
+Qed.
+
+Definition Qsrt : ring_theory 0 1 Qplus Qmult Qminus Qopp Qeq.
+Proof.
+  constructor.
+  exact Qplus_0_l.
+  exact Qplus_comm.
+  exact Qplus_assoc.
+  exact Qmult_1_l.
+  exact Qmult_comm.
+  exact Qmult_assoc.
+  exact Qmult_plus_distr_l.
+  reflexivity.
+  exact Qplus_opp_r.
+Qed.
+
+Ltac isQcst t :=
+  match t with
+  | inject_Z ?z => isZcst z
+  | Qmake ?n ?d =>
+    match isZcst n with
+      true => isPcst d
+    | _ => false
+    end
+  | _ => false
+  end.
+
+Ltac Qcst t :=
+  match isQcst t with
+    true => t
+    | _ => NotConstant
+  end.
+
+Add Ring Qring : Qsrt (decidable Qeq_bool_correct, constants [Qcst]).
+(** Exemple of use: *)
+
+Section Examples. 
+
+Let ex1 : forall x y z : Q, (x+y)*z ==  (x*z)+(y*z).
+  intros.
+  ring.
+Qed.
+
+Let ex2 : forall x y : Q, x+y == y+x.
+  intros. 
+  ring.
+Qed.
+
+Let ex3 : forall x y z : Q, (x+y)+z == x+(y+z).
+  intros.
+  ring.
+Qed.
+
+Let ex4 : (inject_Z 1)+(inject_Z 1)==(inject_Z 2).
+ ring.
+Qed.
+
+Let ex5 : 1+1 == 2#1.
+  ring.
+Qed.
+
+Let ex6 : (1#1)+(1#1) == 2#1.
+  ring.
+Qed.
+
+Let ex7 : forall x : Q, x-x== 0#1.
+  intro.
+  ring.
+Qed.
+
+End Examples.
+
+Lemma Qopp_plus : forall a b,  -(a+b) == -a + -b.
+Proof.
+  intros; ring.
+Qed.
+
+Lemma Qopp_opp : forall q, - -q==q.
+Proof.
+  intros; ring.
+Qed.
+
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index a691b189..802bfa71 100644
--- a/theories/Reals/Alembert.v
+++ b/theories/Reals/Alembert.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
  
-(*i $Id: Alembert.v,v 1.14.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+(*i $Id: Alembert.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -22,705 +22,712 @@ Open Local Scope R_scope.
 (***************************************************)
 
 Lemma Alembert_C1 :
- forall An:nat -> R,
-   (forall n:nat, 0 < An n) ->
-   Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
-intros An H H0.
-cut
- (sigT (fun l:R => is_lub (EUn (fun N:nat => sum_f_R0 An N)) l) ->
-  sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
-intro; apply X.
-apply completeness.
-unfold Un_cv in H0; unfold bound in |- *; cut (0 < / 2);
- [ intro | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H0 (/ 2) H1); intros.
-exists (sum_f_R0 An x + 2 * An (S x)).
-unfold is_upper_bound in |- *; intros; unfold EUn in H3; elim H3; intros.
-rewrite H4; assert (H5 := lt_eq_lt_dec x1 x).
-elim H5; intros.
-elim a; intro.
-replace (sum_f_R0 An x) with
- (sum_f_R0 An x1 + sum_f_R0 (fun i:nat => An (S x1 + i)%nat) (x - S x1)).
-pattern (sum_f_R0 An x1) at 1 in |- *; rewrite <- Rplus_0_r;
- rewrite Rplus_assoc; apply Rplus_le_compat_l.
-left; apply Rplus_lt_0_compat.
-apply tech1; intros; apply H.
-apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
-symmetry  in |- *; apply tech2; assumption.
-rewrite b; pattern (sum_f_R0 An x) at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_le_compat_l.
-left; apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
-replace (sum_f_R0 An x1) with
- (sum_f_R0 An x + sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x)).
-apply Rplus_le_compat_l.
-cut
- (sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x) <=
-  An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)).
-intro;
- apply Rle_trans with
-  (An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)).
-assumption.
-rewrite <- (Rmult_comm (An (S x))); apply Rmult_le_compat_l.
-left; apply H.
-rewrite tech3.
-replace (1 - / 2) with (/ 2).
-unfold Rdiv in |- *; rewrite Rinv_involutive.
-pattern 2 at 3 in |- *; rewrite <- Rmult_1_r; rewrite <- (Rmult_comm 2);
- apply Rmult_le_compat_l.
-left; prove_sup0.
-left; apply Rplus_lt_reg_r with ((/ 2) ^ S (x1 - S x)).
-replace ((/ 2) ^ S (x1 - S x) + (1 - (/ 2) ^ S (x1 - S x))) with 1;
- [ idtac | ring ].
-rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_lt_compat_l.
-apply pow_lt; apply Rinv_0_lt_compat; prove_sup0.
-discrR.
-apply Rmult_eq_reg_l with 2.
-rewrite Rmult_minus_distr_l; rewrite <- Rinv_r_sym.
-ring.
-discrR.
-discrR.
-pattern 1 at 3 in |- *; replace 1 with (/ 1);
- [ apply tech7; discrR | apply Rinv_1 ].
-replace (An (S x)) with (An (S x + 0)%nat).
-apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)).
-left; apply Rinv_0_lt_compat; prove_sup0.
-intro; cut (forall n:nat, (n >= x)%nat -> An (S n) < / 2 * An n).
-intro; replace (S x + S i)%nat with (S (S x + i)).
-apply H6; unfold ge in |- *; apply tech8.
-apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
-intros; unfold R_dist in H2; apply Rmult_lt_reg_l with (/ An n).
-apply Rinv_0_lt_compat; apply H.
-do 2 rewrite (Rmult_comm (/ An n)); rewrite Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r;
- replace (An (S n) * / An n) with (Rabs (Rabs (An (S n) / An n) - 0)).
-apply H2; assumption.
-unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
- rewrite Rabs_Rabsolu; rewrite Rabs_right.
-unfold Rdiv in |- *; reflexivity.
-left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
- apply Rmult_lt_0_compat; [ apply H | apply Rinv_0_lt_compat; apply H ].
-red in |- *; intro; assert (H8 := H n); rewrite H7 in H8;
- elim (Rlt_irrefl _ H8).
-replace (S x + 0)%nat with (S x); [ reflexivity | ring ].
-symmetry  in |- *; apply tech2; assumption.
-exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
-intro; elim X; intros.
-apply existT with x; apply tech10;
- [ unfold Un_growing in |- *; intro; rewrite tech5;
-    pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
-    apply Rplus_le_compat_l; left; apply H
- | apply p ].
+  forall An:nat -> R,
+    (forall n:nat, 0 < An n) ->
+    Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+Proof.
+  intros An H H0.
+  cut
+    (sigT (fun l:R => is_lub (EUn (fun N:nat => sum_f_R0 An N)) l) ->
+      sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
+  intro X; apply X.
+  apply completeness.
+  unfold Un_cv in H0; unfold bound in |- *; cut (0 < / 2);
+    [ intro | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H0 (/ 2) H1); intros.
+  exists (sum_f_R0 An x + 2 * An (S x)).
+  unfold is_upper_bound in |- *; intros; unfold EUn in H3; elim H3; intros.
+  rewrite H4; assert (H5 := lt_eq_lt_dec x1 x).
+  elim H5; intros.
+  elim a; intro.
+  replace (sum_f_R0 An x) with
+    (sum_f_R0 An x1 + sum_f_R0 (fun i:nat => An (S x1 + i)%nat) (x - S x1)).
+  pattern (sum_f_R0 An x1) at 1 in |- *; rewrite <- Rplus_0_r;
+    rewrite Rplus_assoc; apply Rplus_le_compat_l.
+  left; apply Rplus_lt_0_compat.
+  apply tech1; intros; apply H.
+  apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
+  symmetry  in |- *; apply tech2; assumption.
+  rewrite b; pattern (sum_f_R0 An x) at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_le_compat_l.
+  left; apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
+  replace (sum_f_R0 An x1) with
+    (sum_f_R0 An x + sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x)).
+  apply Rplus_le_compat_l.
+  cut
+    (sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x) <=
+      An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)).
+  intro;
+    apply Rle_trans with
+      (An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)).
+  assumption.
+  rewrite <- (Rmult_comm (An (S x))); apply Rmult_le_compat_l.
+  left; apply H.
+  rewrite tech3.
+  replace (1 - / 2) with (/ 2).
+  unfold Rdiv in |- *; rewrite Rinv_involutive.
+  pattern 2 at 3 in |- *; rewrite <- Rmult_1_r; rewrite <- (Rmult_comm 2);
+    apply Rmult_le_compat_l.
+  left; prove_sup0.
+  left; apply Rplus_lt_reg_r with ((/ 2) ^ S (x1 - S x)).
+  replace ((/ 2) ^ S (x1 - S x) + (1 - (/ 2) ^ S (x1 - S x))) with 1;
+    [ idtac | ring ].
+  rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_lt_compat_l.
+  apply pow_lt; apply Rinv_0_lt_compat; prove_sup0.
+  discrR.
+  apply Rmult_eq_reg_l with 2.
+  rewrite Rmult_minus_distr_l; rewrite <- Rinv_r_sym.
+  ring.
+  discrR.
+  discrR.
+  pattern 1 at 3 in |- *; replace 1 with (/ 1);
+    [ apply tech7; discrR | apply Rinv_1 ].
+  replace (An (S x)) with (An (S x + 0)%nat).
+  apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)).
+  left; apply Rinv_0_lt_compat; prove_sup0.
+  intro; cut (forall n:nat, (n >= x)%nat -> An (S n) < / 2 * An n).
+  intro; replace (S x + S i)%nat with (S (S x + i)).
+  apply H6; unfold ge in |- *; apply tech8.
+  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
+  intros; unfold R_dist in H2; apply Rmult_lt_reg_l with (/ An n).
+  apply Rinv_0_lt_compat; apply H.
+  do 2 rewrite (Rmult_comm (/ An n)); rewrite Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r;
+    replace (An (S n) * / An n) with (Rabs (Rabs (An (S n) / An n) - 0)).
+  apply H2; assumption.
+  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+    rewrite Rabs_Rabsolu; rewrite Rabs_right.
+  unfold Rdiv in |- *; reflexivity.
+  left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
+    apply Rmult_lt_0_compat; [ apply H | apply Rinv_0_lt_compat; apply H ].
+  red in |- *; intro; assert (H8 := H n); rewrite H7 in H8;
+    elim (Rlt_irrefl _ H8).
+  replace (S x + 0)%nat with (S x); [ reflexivity | ring ].
+  symmetry  in |- *; apply tech2; assumption.
+  exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
+  intro X; elim X; intros.
+  apply existT with x; apply tech10;
+    [ unfold Un_growing in |- *; intro; rewrite tech5;
+      pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+	apply Rplus_le_compat_l; left; apply H
+      | apply p ].
 Qed.
 
 Lemma Alembert_C2 :
- forall An:nat -> R,
-   (forall n:nat, An n <> 0) ->
-   Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
-intros.
-set (Vn := fun i:nat => (2 * Rabs (An i) + An i) / 2).
-set (Wn := fun i:nat => (2 * Rabs (An i) - An i) / 2).
-cut (forall n:nat, 0 < Vn n).
-intro; cut (forall n:nat, 0 < Wn n).
-intro; cut (Un_cv (fun n:nat => Rabs (Vn (S n) / Vn n)) 0).
-intro; cut (Un_cv (fun n:nat => Rabs (Wn (S n) / Wn n)) 0).
-intro; assert (H5 := Alembert_C1 Vn H1 H3).
-assert (H6 := Alembert_C1 Wn H2 H4).
-elim H5; intros.
-elim H6; intros.
-apply existT with (x - x0); unfold Un_cv in |- *; unfold Un_cv in p;
- unfold Un_cv in p0; intros; cut (0 < eps / 2).
-intro; elim (p (eps / 2) H8); clear p; intros.
-elim (p0 (eps / 2) H8); clear p0; intros.
-set (N := max x1 x2).
-exists N; intros;
- replace (sum_f_R0 An n) with (sum_f_R0 Vn n - sum_f_R0 Wn n).
-unfold R_dist in |- *;
- replace (sum_f_R0 Vn n - sum_f_R0 Wn n - (x - x0)) with
-  (sum_f_R0 Vn n - x + - (sum_f_R0 Wn n - x0)); [ idtac | ring ];
- apply Rle_lt_trans with
-  (Rabs (sum_f_R0 Vn n - x) + Rabs (- (sum_f_R0 Wn n - x0))).
-apply Rabs_triang.
-rewrite Rabs_Ropp; apply Rlt_le_trans with (eps / 2 + eps / 2).
-apply Rplus_lt_compat.
-unfold R_dist in H9; apply H9; unfold ge in |- *; apply le_trans with N;
- [ unfold N in |- *; apply le_max_l | assumption ].
-unfold R_dist in H10; apply H10; unfold ge in |- *; apply le_trans with N;
- [ unfold N in |- *; apply le_max_r | assumption ].
-right; symmetry  in |- *; apply double_var.
-symmetry  in |- *; apply tech11; intro; unfold Vn, Wn in |- *;
- unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
- apply Rmult_eq_reg_l with 2.
-rewrite Rmult_minus_distr_l; repeat rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-ring.
-discrR.
-discrR.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-cut (forall n:nat, / 2 * Rabs (An n) <= Wn n <= 3 * / 2 * Rabs (An n)).
-intro; cut (forall n:nat, / Wn n <= 2 * / Rabs (An n)).
-intro; cut (forall n:nat, Wn (S n) / Wn n <= 3 * Rabs (An (S n) / An n)).
-intro; unfold Un_cv in |- *; intros; unfold Un_cv in H0; cut (0 < eps / 3).
-intro; elim (H0 (eps / 3) H8); intros.
-exists x; intros.
-assert (H11 := H9 n H10).
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H11;
- unfold Rminus in H11; rewrite Ropp_0 in H11; rewrite Rplus_0_r in H11;
- rewrite Rabs_Rabsolu in H11; rewrite Rabs_right.
-apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)).
-apply H6.
-apply Rmult_lt_reg_l with (/ 3).
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
- rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H11;
- exact H11.
-left; change (0 < Wn (S n) / Wn n) in |- *; unfold Rdiv in |- *;
- apply Rmult_lt_0_compat.
-apply H2.
-apply Rinv_0_lt_compat; apply H2.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
- replace 3 with (2 * (3 * / 2));
- [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
- apply Rle_trans with (Wn (S n) * 2 * / Rabs (An n)).
-rewrite Rmult_assoc; apply Rmult_le_compat_l.
-left; apply H2.
-apply H5.
-rewrite Rabs_Rinv.
-replace (Wn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Wn (S n));
- [ idtac | ring ];
- replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
-  (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); 
- [ idtac | ring ]; apply Rmult_le_compat_l.
-left; apply Rmult_lt_0_compat.
-prove_sup0.
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H.
-elim (H4 (S n)); intros; assumption.
-apply H.
-intro; apply Rmult_le_reg_l with (Wn n).
-apply H2.
-rewrite <- Rinv_r_sym.
-apply Rmult_le_reg_l with (Rabs (An n)).
-apply Rabs_pos_lt; apply H.
-rewrite Rmult_1_r;
- replace (Rabs (An n) * (Wn n * (2 * / Rabs (An n)))) with
-  (2 * Wn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ];
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2).
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; elim (H4 n); intros; assumption.
-discrR.
-apply Rabs_no_R0; apply H.
-red in |- *; intro; assert (H6 := H2 n); rewrite H5 in H6;
- elim (Rlt_irrefl _ H6).
-intro; split.
-unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
- apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; prove_sup0.
-pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
- unfold Rminus in |- *; rewrite Rplus_assoc; apply Rplus_le_compat_l.
-apply Rplus_le_reg_l with (An n).
-rewrite Rplus_0_r; rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
- rewrite Rplus_opp_l; rewrite Rplus_0_r; apply RRle_abs.
-unfold Wn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
- repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; prove_sup0.
-unfold Rminus in |- *; rewrite double;
- replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
- [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
-rewrite <- Rabs_Ropp; apply RRle_abs.
-cut (forall n:nat, / 2 * Rabs (An n) <= Vn n <= 3 * / 2 * Rabs (An n)).
-intro; cut (forall n:nat, / Vn n <= 2 * / Rabs (An n)).
-intro; cut (forall n:nat, Vn (S n) / Vn n <= 3 * Rabs (An (S n) / An n)).
-intro; unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / 3).
-intro; elim (H0 (eps / 3) H7); intros.
-exists x; intros.
-assert (H10 := H8 n H9).
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H10;
- unfold Rminus in H10; rewrite Ropp_0 in H10; rewrite Rplus_0_r in H10;
- rewrite Rabs_Rabsolu in H10; rewrite Rabs_right.
-apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)).
-apply H5.
-apply Rmult_lt_reg_l with (/ 3).
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
- rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H10;
- exact H10.
-left; change (0 < Vn (S n) / Vn n) in |- *; unfold Rdiv in |- *;
- apply Rmult_lt_0_compat.
-apply H1.
-apply Rinv_0_lt_compat; apply H1.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
- replace 3 with (2 * (3 * / 2));
- [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
- apply Rle_trans with (Vn (S n) * 2 * / Rabs (An n)).
-rewrite Rmult_assoc; apply Rmult_le_compat_l.
-left; apply H1.
-apply H4.
-rewrite Rabs_Rinv.
-replace (Vn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Vn (S n));
- [ idtac | ring ];
- replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
-  (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); 
- [ idtac | ring ]; apply Rmult_le_compat_l.
-left; apply Rmult_lt_0_compat.
-prove_sup0.
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H.
-elim (H3 (S n)); intros; assumption.
-apply H.
-intro; apply Rmult_le_reg_l with (Vn n).
-apply H1.
-rewrite <- Rinv_r_sym.
-apply Rmult_le_reg_l with (Rabs (An n)).
-apply Rabs_pos_lt; apply H.
-rewrite Rmult_1_r;
- replace (Rabs (An n) * (Vn n * (2 * / Rabs (An n)))) with
-  (2 * Vn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ];
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2).
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; elim (H3 n); intros; assumption.
-discrR.
-apply Rabs_no_R0; apply H.
-red in |- *; intro; assert (H5 := H1 n); rewrite H4 in H5;
- elim (Rlt_irrefl _ H5).
-intro; split.
-unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
- apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; prove_sup0.
-pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
- rewrite Rplus_assoc; apply Rplus_le_compat_l.
-apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r;
- rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; 
- rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; 
- apply RRle_abs.
-unfold Vn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
- repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; prove_sup0.
-unfold Rminus in |- *; rewrite double;
- replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
- [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l;
- apply RRle_abs.
-intro; unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
- rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
-apply Rinv_0_lt_compat; prove_sup0.
-apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus in |- *;
- rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; 
- rewrite Rplus_opp_l; rewrite Rplus_0_r;
- apply Rle_lt_trans with (Rabs (An n)).
-apply RRle_abs.
-rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
-intro; unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
- rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
-apply Rinv_0_lt_compat; prove_sup0.
-apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus in |- *;
- rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; 
- rewrite Rplus_opp_r; rewrite Rplus_0_r;
- apply Rle_lt_trans with (Rabs (An n)).
-rewrite <- Rabs_Ropp; apply RRle_abs.
-rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
+  forall An:nat -> R,
+    (forall n:nat, An n <> 0) ->
+    Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+Proof.
+  intros.
+  set (Vn := fun i:nat => (2 * Rabs (An i) + An i) / 2).
+  set (Wn := fun i:nat => (2 * Rabs (An i) - An i) / 2).
+  cut (forall n:nat, 0 < Vn n).
+  intro; cut (forall n:nat, 0 < Wn n).
+  intro; cut (Un_cv (fun n:nat => Rabs (Vn (S n) / Vn n)) 0).
+  intro; cut (Un_cv (fun n:nat => Rabs (Wn (S n) / Wn n)) 0).
+  intro; assert (H5 := Alembert_C1 Vn H1 H3).
+  assert (H6 := Alembert_C1 Wn H2 H4).
+  elim H5; intros.
+  elim H6; intros.
+  apply existT with (x - x0); unfold Un_cv in |- *; unfold Un_cv in p;
+    unfold Un_cv in p0; intros; cut (0 < eps / 2).
+  intro; elim (p (eps / 2) H8); clear p; intros.
+  elim (p0 (eps / 2) H8); clear p0; intros.
+  set (N := max x1 x2).
+  exists N; intros;
+    replace (sum_f_R0 An n) with (sum_f_R0 Vn n - sum_f_R0 Wn n).
+  unfold R_dist in |- *;
+    replace (sum_f_R0 Vn n - sum_f_R0 Wn n - (x - x0)) with
+      (sum_f_R0 Vn n - x + - (sum_f_R0 Wn n - x0)); [ idtac | ring ];
+      apply Rle_lt_trans with
+	(Rabs (sum_f_R0 Vn n - x) + Rabs (- (sum_f_R0 Wn n - x0))).
+  apply Rabs_triang.
+  rewrite Rabs_Ropp; apply Rlt_le_trans with (eps / 2 + eps / 2).
+  apply Rplus_lt_compat.
+  unfold R_dist in H9; apply H9; unfold ge in |- *; apply le_trans with N;
+    [ unfold N in |- *; apply le_max_l | assumption ].
+  unfold R_dist in H10; apply H10; unfold ge in |- *; apply le_trans with N;
+    [ unfold N in |- *; apply le_max_r | assumption ].
+  right; symmetry  in |- *; apply double_var.
+  symmetry  in |- *; apply tech11; intro; unfold Vn, Wn in |- *;
+    unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
+      apply Rmult_eq_reg_l with 2.
+  rewrite Rmult_minus_distr_l; repeat rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  ring.
+  discrR.
+  discrR.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  cut (forall n:nat, / 2 * Rabs (An n) <= Wn n <= 3 * / 2 * Rabs (An n)).
+  intro; cut (forall n:nat, / Wn n <= 2 * / Rabs (An n)).
+  intro; cut (forall n:nat, Wn (S n) / Wn n <= 3 * Rabs (An (S n) / An n)).
+  intro; unfold Un_cv in |- *; intros; unfold Un_cv in H0; cut (0 < eps / 3).
+  intro; elim (H0 (eps / 3) H8); intros.
+  exists x; intros.
+  assert (H11 := H9 n H10).
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H11;
+      unfold Rminus in H11; rewrite Ropp_0 in H11; rewrite Rplus_0_r in H11;
+	rewrite Rabs_Rabsolu in H11; rewrite Rabs_right.
+  apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)).
+  apply H6.
+  apply Rmult_lt_reg_l with (/ 3).
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
+    rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H11;
+      exact H11.
+  left; change (0 < Wn (S n) / Wn n) in |- *; unfold Rdiv in |- *;
+    apply Rmult_lt_0_compat.
+  apply H2.
+  apply Rinv_0_lt_compat; apply H2.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
+    replace 3 with (2 * (3 * / 2));
+      [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
+      apply Rle_trans with (Wn (S n) * 2 * / Rabs (An n)).
+  rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  left; apply H2.
+  apply H5.
+  rewrite Rabs_Rinv.
+  replace (Wn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Wn (S n));
+    [ idtac | ring ];
+    replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
+      (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); 
+      [ idtac | ring ]; apply Rmult_le_compat_l.
+  left; apply Rmult_lt_0_compat.
+  prove_sup0.
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H.
+  elim (H4 (S n)); intros; assumption.
+  apply H.
+  intro; apply Rmult_le_reg_l with (Wn n).
+  apply H2.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_le_reg_l with (Rabs (An n)).
+  apply Rabs_pos_lt; apply H.
+  rewrite Rmult_1_r;
+    replace (Rabs (An n) * (Wn n * (2 * / Rabs (An n)))) with
+      (2 * Wn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ];
+      rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2).
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; elim (H4 n); intros; assumption.
+  discrR.
+  apply Rabs_no_R0; apply H.
+  red in |- *; intro; assert (H6 := H2 n); rewrite H5 in H6;
+    elim (Rlt_irrefl _ H6).
+  intro; split.
+  unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+    apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; prove_sup0.
+  pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
+    unfold Rminus in |- *; rewrite Rplus_assoc; apply Rplus_le_compat_l.
+  apply Rplus_le_reg_l with (An n).
+  rewrite Rplus_0_r; rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
+    rewrite Rplus_opp_l; rewrite Rplus_0_r; apply RRle_abs.
+  unfold Wn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
+    repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; prove_sup0.
+  unfold Rminus in |- *; rewrite double;
+    replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
+      [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  cut (forall n:nat, / 2 * Rabs (An n) <= Vn n <= 3 * / 2 * Rabs (An n)).
+  intro; cut (forall n:nat, / Vn n <= 2 * / Rabs (An n)).
+  intro; cut (forall n:nat, Vn (S n) / Vn n <= 3 * Rabs (An (S n) / An n)).
+  intro; unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / 3).
+  intro; elim (H0 (eps / 3) H7); intros.
+  exists x; intros.
+  assert (H10 := H8 n H9).
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H10;
+      unfold Rminus in H10; rewrite Ropp_0 in H10; rewrite Rplus_0_r in H10;
+	rewrite Rabs_Rabsolu in H10; rewrite Rabs_right.
+  apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)).
+  apply H5.
+  apply Rmult_lt_reg_l with (/ 3).
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
+    rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H10;
+      exact H10.
+  left; change (0 < Vn (S n) / Vn n) in |- *; unfold Rdiv in |- *;
+    apply Rmult_lt_0_compat.
+  apply H1.
+  apply Rinv_0_lt_compat; apply H1.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
+    replace 3 with (2 * (3 * / 2));
+      [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
+      apply Rle_trans with (Vn (S n) * 2 * / Rabs (An n)).
+  rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  left; apply H1.
+  apply H4.
+  rewrite Rabs_Rinv.
+  replace (Vn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Vn (S n));
+    [ idtac | ring ];
+    replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
+      (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); 
+      [ idtac | ring ]; apply Rmult_le_compat_l.
+  left; apply Rmult_lt_0_compat.
+  prove_sup0.
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H.
+  elim (H3 (S n)); intros; assumption.
+  apply H.
+  intro; apply Rmult_le_reg_l with (Vn n).
+  apply H1.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_le_reg_l with (Rabs (An n)).
+  apply Rabs_pos_lt; apply H.
+  rewrite Rmult_1_r;
+    replace (Rabs (An n) * (Vn n * (2 * / Rabs (An n)))) with
+      (2 * Vn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ];
+      rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2).
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; elim (H3 n); intros; assumption.
+  discrR.
+  apply Rabs_no_R0; apply H.
+  red in |- *; intro; assert (H5 := H1 n); rewrite H4 in H5;
+    elim (Rlt_irrefl _ H5).
+  intro; split.
+  unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+    apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; prove_sup0.
+  pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
+    rewrite Rplus_assoc; apply Rplus_le_compat_l.
+  apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r;
+    rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; 
+      rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; 
+	apply RRle_abs.
+  unfold Vn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
+    repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; prove_sup0.
+  unfold Rminus in |- *; rewrite double;
+    replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
+      [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l;
+	apply RRle_abs.
+  intro; unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
+    rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
+  apply Rinv_0_lt_compat; prove_sup0.
+  apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus in |- *;
+    rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; 
+      rewrite Rplus_opp_l; rewrite Rplus_0_r;
+	apply Rle_lt_trans with (Rabs (An n)).
+  apply RRle_abs.
+  rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
+  intro; unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
+    rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
+  apply Rinv_0_lt_compat; prove_sup0.
+  apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus in |- *;
+    rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; 
+      rewrite Rplus_opp_r; rewrite Rplus_0_r;
+	apply Rle_lt_trans with (Rabs (An n)).
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
 Qed.
 
 Lemma AlembertC3_step1 :
- forall (An:nat -> R) (x:R),
-   x <> 0 ->
-   (forall n:nat, An n <> 0) ->
-   Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
-   sigT (fun l:R => Pser An x l).
-intros; set (Bn := fun i:nat => An i * x ^ i).
-cut (forall n:nat, Bn n <> 0).
-intro; cut (Un_cv (fun n:nat => Rabs (Bn (S n) / Bn n)) 0).
-intro; assert (H4 := Alembert_C2 Bn H2 H3).
-elim H4; intros.
-apply existT with x0; unfold Bn in p; apply tech12; assumption.
-unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x).
-intro; elim (H1 (eps / Rabs x) H4); intros.
-exists x0; intros; unfold R_dist in |- *; unfold Rminus in |- *;
- rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
- unfold Bn in |- *;
- replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
-rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x).
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-rewrite <- (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H5;
- replace (Rabs (An (S n) / An n)) with (R_dist (Rabs (An (S n) * / An n)) 0).
-apply H5; assumption.
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *; 
- reflexivity.
-apply Rabs_no_R0; assumption.
-replace (S n) with (n + 1)%nat; [ idtac | ring ]; rewrite pow_add;
- unfold Rdiv in |- *; rewrite Rinv_mult_distr.
-replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with
- (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)); 
- [ idtac | ring ]; rewrite <- Rinv_r_sym.
-simpl in |- *; ring.
-apply pow_nonzero; assumption.
-apply H0.
-apply pow_nonzero; assumption.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
-intro; unfold Bn in |- *; apply prod_neq_R0;
- [ apply H0 | apply pow_nonzero; assumption ].
+  forall (An:nat -> R) (x:R),
+    x <> 0 ->
+    (forall n:nat, An n <> 0) ->
+    Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
+    sigT (fun l:R => Pser An x l).
+Proof.
+  intros; set (Bn := fun i:nat => An i * x ^ i).
+  cut (forall n:nat, Bn n <> 0).
+  intro; cut (Un_cv (fun n:nat => Rabs (Bn (S n) / Bn n)) 0).
+  intro; assert (H4 := Alembert_C2 Bn H2 H3).
+  elim H4; intros.
+  apply existT with x0; unfold Bn in p; apply tech12; assumption.
+  unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x).
+  intro; elim (H1 (eps / Rabs x) H4); intros.
+  exists x0; intros; unfold R_dist in |- *; unfold Rminus in |- *;
+    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+      unfold Bn in |- *;
+	replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
+  rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+  rewrite <- (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H5;
+    replace (Rabs (An (S n) / An n)) with (R_dist (Rabs (An (S n) * / An n)) 0).
+  apply H5; assumption.
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *; 
+      reflexivity.
+  apply Rabs_no_R0; assumption.
+  replace (S n) with (n + 1)%nat; [ idtac | ring ]; rewrite pow_add;
+    unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with
+    (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)); 
+    [ idtac | ring ]; rewrite <- Rinv_r_sym.
+  simpl in |- *; ring.
+  apply pow_nonzero; assumption.
+  apply H0.
+  apply pow_nonzero; assumption.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
+  intro; unfold Bn in |- *; apply prod_neq_R0;
+    [ apply H0 | apply pow_nonzero; assumption ].
 Qed.
 
 Lemma AlembertC3_step2 :
- forall (An:nat -> R) (x:R), x = 0 -> sigT (fun l:R => Pser An x l).
-intros; apply existT with (An 0%nat).
-unfold Pser in |- *; unfold infinit_sum in |- *; intros; exists 0%nat; intros;
- replace (sum_f_R0 (fun n0:nat => An n0 * x ^ n0) n) with (An 0%nat).
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; assumption.
-induction  n as [| n Hrecn].
-simpl in |- *; ring.
-rewrite tech5; rewrite Hrecn;
- [ rewrite H; simpl in |- *; ring | unfold ge in |- *; apply le_O_n ].
+  forall (An:nat -> R) (x:R), x = 0 -> sigT (fun l:R => Pser An x l).
+Proof.
+  intros; apply existT with (An 0%nat).
+  unfold Pser in |- *; unfold infinit_sum in |- *; intros; exists 0%nat; intros;
+    replace (sum_f_R0 (fun n0:nat => An n0 * x ^ n0) n) with (An 0%nat).
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; assumption.
+  induction  n as [| n Hrecn].
+  simpl in |- *; ring.
+  rewrite tech5; rewrite Hrecn;
+    [ rewrite H; simpl in |- *; ring | unfold ge in |- *; apply le_O_n ].
 Qed.
 
-(* An useful criterion of convergence for power series *)
+(** An useful criterion of convergence for power series *)
 Theorem Alembert_C3 :
- forall (An:nat -> R) (x:R),
-   (forall n:nat, An n <> 0) ->
-   Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
-   sigT (fun l:R => Pser An x l).
-intros; case (total_order_T x 0); intro.
-elim s; intro.
-cut (x <> 0).
-intro; apply AlembertC3_step1; assumption.
-red in |- *; intro; rewrite H1 in a; elim (Rlt_irrefl _ a).
-apply AlembertC3_step2; assumption.
-cut (x <> 0).
-intro; apply AlembertC3_step1; assumption.
-red in |- *; intro; rewrite H1 in r; elim (Rlt_irrefl _ r).
+  forall (An:nat -> R) (x:R),
+    (forall n:nat, An n <> 0) ->
+    Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
+    sigT (fun l:R => Pser An x l).
+Proof.
+  intros; case (total_order_T x 0); intro.
+  elim s; intro.
+  cut (x <> 0).
+  intro; apply AlembertC3_step1; assumption.
+  red in |- *; intro; rewrite H1 in a; elim (Rlt_irrefl _ a).
+  apply AlembertC3_step2; assumption.
+  cut (x <> 0).
+  intro; apply AlembertC3_step1; assumption.
+  red in |- *; intro; rewrite H1 in r; elim (Rlt_irrefl _ r).
 Qed.
 
 Lemma Alembert_C4 :
- forall (An:nat -> R) (k:R),
-   0 <= k < 1 ->
-   (forall n:nat, 0 < An n) ->
-   Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
-intros An k Hyp H H0.
-cut
- (sigT (fun l:R => is_lub (EUn (fun N:nat => sum_f_R0 An N)) l) ->
-  sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
-intro; apply X.
-apply completeness.
-assert (H1 := tech13 _ _ Hyp H0).
-elim H1; intros.
-elim H2; intros.
-elim H4; intros.
-unfold bound in |- *; exists (sum_f_R0 An x0 + / (1 - x) * An (S x0)).
-unfold is_upper_bound in |- *; intros; unfold EUn in H6.
-elim H6; intros.
-rewrite H7.
-assert (H8 := lt_eq_lt_dec x2 x0).
-elim H8; intros.
-elim a; intro.
-replace (sum_f_R0 An x0) with
- (sum_f_R0 An x2 + sum_f_R0 (fun i:nat => An (S x2 + i)%nat) (x0 - S x2)).
-pattern (sum_f_R0 An x2) at 1 in |- *; rewrite <- Rplus_0_r.
-rewrite Rplus_assoc; apply Rplus_le_compat_l.
-left; apply Rplus_lt_0_compat.
-apply tech1.
-intros; apply H.
-apply Rmult_lt_0_compat.
-apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
- replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
-apply H.
-symmetry  in |- *; apply tech2; assumption.
-rewrite b; pattern (sum_f_R0 An x0) at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_le_compat_l.
-left; apply Rmult_lt_0_compat.
-apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
- replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
-apply H.
-replace (sum_f_R0 An x2) with
- (sum_f_R0 An x0 + sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0)).
-apply Rplus_le_compat_l.
-cut
- (sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0) <=
-  An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)).
-intro;
- apply Rle_trans with (An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)).
-assumption.
-rewrite <- (Rmult_comm (An (S x0))); apply Rmult_le_compat_l.
-left; apply H.
-rewrite tech3.
-unfold Rdiv in |- *; apply Rmult_le_reg_l with (1 - x).
-apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
-replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
-do 2 rewrite (Rmult_comm (1 - x)).
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; apply Rplus_le_reg_l with (x ^ S (x2 - S x0)).
-replace (x ^ S (x2 - S x0) + (1 - x ^ S (x2 - S x0))) with 1;
- [ idtac | ring ].
-rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_le_compat_l.
-left; apply pow_lt.
-apply Rle_lt_trans with k.
-elim Hyp; intros; assumption.
-elim H3; intros; assumption.
-apply Rminus_eq_contra.
-red in |- *; intro.
-elim H3; intros.
-rewrite H10 in H12; elim (Rlt_irrefl _ H12).
-red in |- *; intro.
-elim H3; intros.
-rewrite H10 in H12; elim (Rlt_irrefl _ H12).
-replace (An (S x0)) with (An (S x0 + 0)%nat).
-apply (tech6 (fun i:nat => An (S x0 + i)%nat) x).
-left; apply Rle_lt_trans with k.
-elim Hyp; intros; assumption.
-elim H3; intros; assumption.
-intro.
-cut (forall n:nat, (n >= x0)%nat -> An (S n) < x * An n).
-intro.
-replace (S x0 + S i)%nat with (S (S x0 + i)).
-apply H9.
-unfold ge in |- *.
-apply tech8.
+  forall (An:nat -> R) (k:R),
+    0 <= k < 1 ->
+    (forall n:nat, 0 < An n) ->
+    Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+Proof.
+  intros An k Hyp H H0.
+  cut
+    (sigT (fun l:R => is_lub (EUn (fun N:nat => sum_f_R0 An N)) l) ->
+      sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
+  intro X; apply X.
+  apply completeness.
+  assert (H1 := tech13 _ _ Hyp H0).
+  elim H1; intros.
+  elim H2; intros.
+  elim H4; intros.
+  unfold bound in |- *; exists (sum_f_R0 An x0 + / (1 - x) * An (S x0)).
+  unfold is_upper_bound in |- *; intros; unfold EUn in H6.
+  elim H6; intros.
+  rewrite H7.
+  assert (H8 := lt_eq_lt_dec x2 x0).
+  elim H8; intros.
+  elim a; intro.
+  replace (sum_f_R0 An x0) with
+    (sum_f_R0 An x2 + sum_f_R0 (fun i:nat => An (S x2 + i)%nat) (x0 - S x2)).
+  pattern (sum_f_R0 An x2) at 1 in |- *; rewrite <- Rplus_0_r.
+  rewrite Rplus_assoc; apply Rplus_le_compat_l.
+  left; apply Rplus_lt_0_compat.
+  apply tech1.
+  intros; apply H.
+  apply Rmult_lt_0_compat.
+  apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+    replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
+  apply H.
+  symmetry  in |- *; apply tech2; assumption.
+  rewrite b; pattern (sum_f_R0 An x0) at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_le_compat_l.
+  left; apply Rmult_lt_0_compat.
+  apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+    replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
+  apply H.
+  replace (sum_f_R0 An x2) with
+    (sum_f_R0 An x0 + sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0)).
+  apply Rplus_le_compat_l.
+  cut
+    (sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0) <=
+      An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)).
+  intro;
+    apply Rle_trans with (An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)).
+  assumption.
+  rewrite <- (Rmult_comm (An (S x0))); apply Rmult_le_compat_l.
+  left; apply H.
+  rewrite tech3.
+  unfold Rdiv in |- *; apply Rmult_le_reg_l with (1 - x).
+  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
+  replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
+  do 2 rewrite (Rmult_comm (1 - x)).
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; apply Rplus_le_reg_l with (x ^ S (x2 - S x0)).
+  replace (x ^ S (x2 - S x0) + (1 - x ^ S (x2 - S x0))) with 1;
+    [ idtac | ring ].
+  rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_le_compat_l.
+  left; apply pow_lt.
+  apply Rle_lt_trans with k.
+  elim Hyp; intros; assumption.
+  elim H3; intros; assumption.
+  apply Rminus_eq_contra.
+  red in |- *; intro.
+  elim H3; intros.
+  rewrite H10 in H12; elim (Rlt_irrefl _ H12).
+  red in |- *; intro.
+  elim H3; intros.
+  rewrite H10 in H12; elim (Rlt_irrefl _ H12).
+  replace (An (S x0)) with (An (S x0 + 0)%nat).
+  apply (tech6 (fun i:nat => An (S x0 + i)%nat) x).
+  left; apply Rle_lt_trans with k.
+  elim Hyp; intros; assumption.
+  elim H3; intros; assumption.
+  intro.
+  cut (forall n:nat, (n >= x0)%nat -> An (S n) < x * An n).
+  intro.
+  replace (S x0 + S i)%nat with (S (S x0 + i)).
+  apply H9.
+  unfold ge in |- *.
+  apply tech8.
   apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR;
-   ring.
-intros.
-apply Rmult_lt_reg_l with (/ An n).
-apply Rinv_0_lt_compat; apply H.
-do 2 rewrite (Rmult_comm (/ An n)).
-rewrite Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r.
-replace (An (S n) * / An n) with (Rabs (An (S n) / An n)).
-apply H5; assumption.
-rewrite Rabs_right.
-unfold Rdiv in |- *; reflexivity.
-left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
- apply Rmult_lt_0_compat.
-apply H.
-apply Rinv_0_lt_compat; apply H.
-red in |- *; intro.
-assert (H11 := H n).
-rewrite H10 in H11; elim (Rlt_irrefl _ H11).
-replace (S x0 + 0)%nat with (S x0); [ reflexivity | ring ].
-symmetry  in |- *; apply tech2; assumption.
-exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
-intro; elim X; intros.
-apply existT with x; apply tech10;
- [ unfold Un_growing in |- *; intro; rewrite tech5;
-    pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
-    apply Rplus_le_compat_l; left; apply H
- | apply p ].
+    ring.
+  intros.
+  apply Rmult_lt_reg_l with (/ An n).
+  apply Rinv_0_lt_compat; apply H.
+  do 2 rewrite (Rmult_comm (/ An n)).
+  rewrite Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r.
+  replace (An (S n) * / An n) with (Rabs (An (S n) / An n)).
+  apply H5; assumption.
+  rewrite Rabs_right.
+  unfold Rdiv in |- *; reflexivity.
+  left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
+    apply Rmult_lt_0_compat.
+  apply H.
+  apply Rinv_0_lt_compat; apply H.
+  red in |- *; intro.
+  assert (H11 := H n).
+  rewrite H10 in H11; elim (Rlt_irrefl _ H11).
+  replace (S x0 + 0)%nat with (S x0); [ reflexivity | ring ].
+  symmetry  in |- *; apply tech2; assumption.
+  exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
+  intro X; elim X; intros.
+  apply existT with x; apply tech10;
+    [ unfold Un_growing in |- *; intro; rewrite tech5;
+      pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+	apply Rplus_le_compat_l; left; apply H
+      | apply p ].
 Qed.
 
 Lemma Alembert_C5 :
- forall (An:nat -> R) (k:R),
-   0 <= k < 1 ->
-   (forall n:nat, An n <> 0) ->
-   Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
-intros.
-cut
- (sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) ->
-  sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
-intro Hyp0; apply Hyp0.
-apply cv_cauchy_2.
-apply cauchy_abs.
-apply cv_cauchy_1.
-cut
- (sigT
-    (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l) ->
-  sigT
-    (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l)).
-intro Hyp; apply Hyp.
-apply (Alembert_C4 (fun i:nat => Rabs (An i)) k).
-assumption.
-intro; apply Rabs_pos_lt; apply H0.
-unfold Un_cv in |- *.
-unfold Un_cv in H1.
-unfold Rdiv in |- *.
-intros.
-elim (H1 eps H2); intros.
-exists x; intros.
-rewrite <- Rabs_Rinv.
-rewrite <- Rabs_mult.
-rewrite Rabs_Rabsolu.
-unfold Rdiv in H3; apply H3; assumption.
-apply H0.
-intro.
-elim X; intros.
-apply existT with x.
-assumption.
-intro.
-elim X; intros.
-apply existT with x.
-assumption.
+  forall (An:nat -> R) (k:R),
+    0 <= k < 1 ->
+    (forall n:nat, An n <> 0) ->
+    Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+Proof.
+  intros.
+  cut
+    (sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) ->
+      sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l)).
+  intro Hyp0; apply Hyp0.
+  apply cv_cauchy_2.
+  apply cauchy_abs.
+  apply cv_cauchy_1.
+  cut
+    (sigT
+      (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l) ->
+      sigT
+      (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l)).
+  intro Hyp; apply Hyp.
+  apply (Alembert_C4 (fun i:nat => Rabs (An i)) k).
+  assumption.
+  intro; apply Rabs_pos_lt; apply H0.
+  unfold Un_cv in |- *.
+  unfold Un_cv in H1.
+  unfold Rdiv in |- *.
+  intros.
+  elim (H1 eps H2); intros.
+  exists x; intros.
+  rewrite <- Rabs_Rinv.
+  rewrite <- Rabs_mult.
+  rewrite Rabs_Rabsolu.
+  unfold Rdiv in H3; apply H3; assumption.
+  apply H0.
+  intro X.
+  elim X; intros.
+  apply existT with x.
+  assumption.
+  intro X.
+  elim X; intros.
+  apply existT with x.
+  assumption.
 Qed.
 
-(* Convergence of power series in D(O,1/k) *)
-(*     k=0 is described in Alembert_C3     *)
+(** Convergence of power series in D(O,1/k)
+    k=0 is described in Alembert_C3     *)
 Lemma Alembert_C6 :
- forall (An:nat -> R) (x k:R),
-   0 < k ->
-   (forall n:nat, An n <> 0) ->
-   Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
-   Rabs x < / k -> sigT (fun l:R => Pser An x l).
-intros.
-cut
- (sigT
-    (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l)).
-intro.
-elim X; intros.
-apply existT with x0.
-apply tech12; assumption.
-case (total_order_T x 0); intro.
-elim s; intro.
-eapply Alembert_C5 with (k * Rabs x).
-split.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-left; assumption.
-left; apply Rabs_pos_lt.
-red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
-apply Rmult_lt_reg_l with (/ k).
-apply Rinv_0_lt_compat; assumption.
-rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-rewrite Rmult_1_r; assumption.
-red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
-intro; apply prod_neq_R0.
-apply H0.
-apply pow_nonzero.
-red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
-unfold Un_cv in |- *; unfold Un_cv in H1.
-intros.
-cut (0 < eps / Rabs x).
-intro.
-elim (H1 (eps / Rabs x) H4); intros.
-exists x0.
-intros.
-replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
-unfold R_dist in |- *.
-rewrite Rabs_mult.
-replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
- (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
-rewrite Rabs_mult.
-rewrite Rabs_Rabsolu.
-apply Rmult_lt_reg_l with (/ Rabs x).
-apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
-rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-rewrite <- (Rmult_comm eps).
-unfold R_dist in H5.
-unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
-apply Rabs_no_R0.
-red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
-unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
-rewrite pow_add.
-simpl in |- *.
-rewrite Rmult_1_r.
-rewrite Rinv_mult_distr.
-replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
- (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); 
- [ idtac | ring ].
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; reflexivity.
-apply pow_nonzero.
-red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
-apply H0.
-apply pow_nonzero.
-red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-assumption.
-apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-red in |- *; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a).
-apply existT with (An 0%nat).
-unfold Un_cv in |- *.
-intros.
-exists 0%nat.
-intros.
-unfold R_dist in |- *.
-replace (sum_f_R0 (fun i:nat => An i * x ^ i) n) with (An 0%nat).
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-induction  n as [| n Hrecn].
-simpl in |- *; ring.
-rewrite tech5.
-rewrite <- Hrecn.
-rewrite b; simpl in |- *; ring.
-unfold ge in |- *; apply le_O_n.
-eapply Alembert_C5 with (k * Rabs x).
-split.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-left; assumption.
-left; apply Rabs_pos_lt.
-red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
-apply Rmult_lt_reg_l with (/ k).
-apply Rinv_0_lt_compat; assumption.
-rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-rewrite Rmult_1_r; assumption.
-red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
-intro; apply prod_neq_R0.
-apply H0.
-apply pow_nonzero.
-red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
-unfold Un_cv in |- *; unfold Un_cv in H1.
-intros.
-cut (0 < eps / Rabs x).
-intro.
-elim (H1 (eps / Rabs x) H4); intros.
-exists x0.
-intros.
-replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
-unfold R_dist in |- *.
-rewrite Rabs_mult.
-replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
- (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
-rewrite Rabs_mult.
-rewrite Rabs_Rabsolu.
-apply Rmult_lt_reg_l with (/ Rabs x).
-apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
-rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-rewrite <- (Rmult_comm eps).
-unfold R_dist in H5.
-unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
-apply Rabs_no_R0.
-red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
-unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
-rewrite pow_add.
-simpl in |- *.
-rewrite Rmult_1_r.
-rewrite Rinv_mult_distr.
-replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
- (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); 
- [ idtac | ring ].
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; reflexivity.
-apply pow_nonzero.
-red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
-apply H0.
-apply pow_nonzero.
-red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-assumption.
-apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-red in |- *; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r).
-Qed.
\ No newline at end of file
+  forall (An:nat -> R) (x k:R),
+    0 < k ->
+    (forall n:nat, An n <> 0) ->
+    Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
+    Rabs x < / k -> sigT (fun l:R => Pser An x l).
+  intros.
+  cut
+    (sigT
+      (fun l:R => Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l)).
+  intro X.
+  elim X; intros.
+  apply existT with x0.
+  apply tech12; assumption.
+  case (total_order_T x 0); intro.
+  elim s; intro.
+  eapply Alembert_C5 with (k * Rabs x).
+  split.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  left; assumption.
+  left; apply Rabs_pos_lt.
+  red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
+  apply Rmult_lt_reg_l with (/ k).
+  apply Rinv_0_lt_compat; assumption.
+  rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  rewrite Rmult_1_r; assumption.
+  red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
+  intro; apply prod_neq_R0.
+  apply H0.
+  apply pow_nonzero.
+  red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
+  unfold Un_cv in |- *; unfold Un_cv in H1.
+  intros.
+  cut (0 < eps / Rabs x).
+  intro.
+  elim (H1 (eps / Rabs x) H4); intros.
+  exists x0.
+  intros.
+  replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
+  unfold R_dist in |- *.
+  rewrite Rabs_mult.
+  replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
+    (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
+  rewrite Rabs_mult.
+  rewrite Rabs_Rabsolu.
+  apply Rmult_lt_reg_l with (/ Rabs x).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  rewrite <- (Rmult_comm eps).
+  unfold R_dist in H5.
+  unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
+  apply Rabs_no_R0.
+  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  rewrite pow_add.
+  simpl in |- *.
+  rewrite Rmult_1_r.
+  rewrite Rinv_mult_distr.
+  replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
+    (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); 
+    [ idtac | ring ].
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; reflexivity.
+  apply pow_nonzero.
+  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  apply H0.
+  apply pow_nonzero.
+  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  assumption.
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+  red in |- *; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  apply existT with (An 0%nat).
+  unfold Un_cv in |- *.
+  intros.
+  exists 0%nat.
+  intros.
+  unfold R_dist in |- *.
+  replace (sum_f_R0 (fun i:nat => An i * x ^ i) n) with (An 0%nat).
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  induction  n as [| n Hrecn].
+  simpl in |- *; ring.
+  rewrite tech5.
+  rewrite <- Hrecn.
+  rewrite b; simpl in |- *; ring.
+  unfold ge in |- *; apply le_O_n.
+  eapply Alembert_C5 with (k * Rabs x).
+  split.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  left; assumption.
+  left; apply Rabs_pos_lt.
+  red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
+  apply Rmult_lt_reg_l with (/ k).
+  apply Rinv_0_lt_compat; assumption.
+  rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  rewrite Rmult_1_r; assumption.
+  red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
+  intro; apply prod_neq_R0.
+  apply H0.
+  apply pow_nonzero.
+  red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
+  unfold Un_cv in |- *; unfold Un_cv in H1.
+  intros.
+  cut (0 < eps / Rabs x).
+  intro.
+  elim (H1 (eps / Rabs x) H4); intros.
+  exists x0.
+  intros.
+  replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
+  unfold R_dist in |- *.
+  rewrite Rabs_mult.
+  replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
+    (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
+  rewrite Rabs_mult.
+  rewrite Rabs_Rabsolu.
+  apply Rmult_lt_reg_l with (/ Rabs x).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  rewrite <- (Rmult_comm eps).
+  unfold R_dist in H5.
+  unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
+  apply Rabs_no_R0.
+  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  rewrite pow_add.
+  simpl in |- *.
+  rewrite Rmult_1_r.
+  rewrite Rinv_mult_distr.
+  replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
+    (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); 
+    [ idtac | ring ].
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; reflexivity.
+  apply pow_nonzero.
+  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  apply H0.
+  apply pow_nonzero.
+  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  assumption.
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+  red in |- *; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r).
+Qed.
diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v
index 166a8a46..581c181f 100644
--- a/theories/Reals/AltSeries.v
+++ b/theories/Reals/AltSeries.v
@@ -1,12 +1,12 @@
-(************************************************************************)
-(*  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: AltSeries.v,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+  (************************************************************************)
+  (*  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: AltSeries.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -17,432 +17,442 @@ Require Import Max.
 Open Local Scope R_scope.
 
 (**********)
+(** * Formalization of alternated series *)
 Definition tg_alt (Un:nat -> R) (i:nat) : R := (-1) ^ i * Un i.
 Definition positivity_seq (Un:nat -> R) : Prop := forall n:nat, 0 <= Un n.
 
 Lemma CV_ALT_step0 :
- forall Un:nat -> R,
-   Un_decreasing Un ->
-   Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
-intros; unfold Un_growing in |- *; intro.
-cut ((2 * S n)%nat = S (S (2 * n))).
-intro; rewrite H0.
-do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l.
-pattern (tg_alt Un (S (2 * n))) at 1 in |- *; rewrite <- Rplus_0_r.
-apply Rplus_le_compat_l.
-unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
- rewrite Rmult_1_l.
-apply Rplus_le_reg_l with (Un (S (2 * S n))).
-rewrite Rplus_0_r;
- replace (Un (S (2 * S n)) + (Un (2 * S n)%nat + -1 * Un (S (2 * S n)))) with
-  (Un (2 * S n)%nat); [ idtac | ring ].
-apply H.
-cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
-rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
+  forall Un:nat -> R,
+    Un_decreasing Un ->
+    Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
+Proof.
+  intros; unfold Un_growing in |- *; intro.
+  cut ((2 * S n)%nat = S (S (2 * n))).
+  intro; rewrite H0.
+  do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l.
+  pattern (tg_alt Un (S (2 * n))) at 1 in |- *; rewrite <- Rplus_0_r.
+  apply Rplus_le_compat_l.
+  unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
+    rewrite Rmult_1_l.
+  apply Rplus_le_reg_l with (Un (S (2 * S n))).
+  rewrite Rplus_0_r;
+    replace (Un (S (2 * S n)) + (Un (2 * S n)%nat + -1 * Un (S (2 * S n)))) with
+      (Un (2 * S n)%nat); [ idtac | ring ].
+  apply H.
+  cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
+  rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
 Qed.
 
 Lemma CV_ALT_step1 :
- forall Un:nat -> R,
-   Un_decreasing Un ->
-   Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)).
-intros; unfold Un_decreasing in |- *; intro.
-cut ((2 * S n)%nat = S (S (2 * n))).
-intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc.
-pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2 in |- *; rewrite <- Rplus_0_r.
-apply Rplus_le_compat_l.
-unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
- rewrite Rmult_1_l.
-apply Rplus_le_reg_l with (Un (S (2 * n))).
-rewrite Rplus_0_r;
- replace (Un (S (2 * n)) + (-1 * Un (S (2 * n)) + Un (2 * S n)%nat)) with
-  (Un (2 * S n)%nat); [ idtac | ring ].
-rewrite H0; apply H.
-cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
-rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
+  forall Un:nat -> R,
+    Un_decreasing Un ->
+    Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)).
+Proof.
+  intros; unfold Un_decreasing in |- *; intro.
+  cut ((2 * S n)%nat = S (S (2 * n))).
+  intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc.
+  pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2 in |- *; rewrite <- Rplus_0_r.
+  apply Rplus_le_compat_l.
+  unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
+    rewrite Rmult_1_l.
+  apply Rplus_le_reg_l with (Un (S (2 * n))).
+  rewrite Rplus_0_r;
+    replace (Un (S (2 * n)) + (-1 * Un (S (2 * n)) + Un (2 * S n)%nat)) with
+      (Un (2 * S n)%nat); [ idtac | ring ].
+  rewrite H0; apply H.
+  cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
+  rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
 Qed.
 
 (**********)
 Lemma CV_ALT_step2 :
- forall (Un:nat -> R) (N:nat),
-   Un_decreasing Un ->
-   positivity_seq Un ->
-   sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. 
-intros; induction  N as [| N HrecN].
-simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
-replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ].
-apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r.
-replace (Un 1%nat + (-1 * Un 1%nat + Un 2%nat)) with (Un 2%nat);
- [ apply H | ring ].
-cut (S (2 * S N) = S (S (S (2 * N)))).
-intro; rewrite H1; do 2 rewrite tech5.
-apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))).
-pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2 in |- *;
- rewrite <- Rplus_0_r.
-rewrite Rplus_assoc; apply Rplus_le_compat_l.
-unfold tg_alt in |- *; rewrite <- H1.
-rewrite pow_1_odd.
-cut (S (S (2 * S N)) = (2 * S (S N))%nat).
-intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2.
-apply Rplus_le_reg_l with (Un (S (2 * S N))).
-rewrite Rplus_0_r;
- replace (Un (S (2 * S N)) + (-1 * Un (S (2 * S N)) + Un (S (S (2 * S N)))))
-  with (Un (S (S (2 * S N)))); [ idtac | ring ].
-apply H.
-apply INR_eq; rewrite mult_INR; repeat rewrite S_INR; rewrite mult_INR;
- repeat rewrite S_INR; ring.
-apply HrecN.
-apply INR_eq; repeat rewrite S_INR; do 2 rewrite mult_INR;
- repeat rewrite S_INR; ring.
+  forall (Un:nat -> R) (N:nat),
+    Un_decreasing Un ->
+    positivity_seq Un ->
+    sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. 
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
+  replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ].
+  apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r.
+  replace (Un 1%nat + (-1 * Un 1%nat + Un 2%nat)) with (Un 2%nat);
+    [ apply H | ring ].
+  cut (S (2 * S N) = S (S (S (2 * N)))).
+  intro; rewrite H1; do 2 rewrite tech5.
+  apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))).
+  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2 in |- *;
+    rewrite <- Rplus_0_r.
+  rewrite Rplus_assoc; apply Rplus_le_compat_l.
+  unfold tg_alt in |- *; rewrite <- H1.
+  rewrite pow_1_odd.
+  cut (S (S (2 * S N)) = (2 * S (S N))%nat).
+  intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2.
+  apply Rplus_le_reg_l with (Un (S (2 * S N))).
+  rewrite Rplus_0_r;
+    replace (Un (S (2 * S N)) + (-1 * Un (S (2 * S N)) + Un (S (S (2 * S N)))))
+      with (Un (S (S (2 * S N)))); [ idtac | ring ].
+  apply H.
+  ring.
+  apply HrecN.
+  ring.
 Qed.
 
-(* A more general inequality *)
+(** A more general inequality *)
 Lemma CV_ALT_step3 :
- forall (Un:nat -> R) (N:nat),
-   Un_decreasing Un ->
-   positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. 
-intros; induction  N as [| N HrecN].
-simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
-apply Rplus_le_reg_l with (Un 1%nat).
-rewrite Rplus_0_r; replace (Un 1%nat + -1 * Un 1%nat) with 0;
- [ apply H0 | ring ].
-assert (H1 := even_odd_cor N).
-elim H1; intros.
-elim H2; intro.
-rewrite H3; apply CV_ALT_step2; assumption.
-rewrite H3; rewrite tech5.
-apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))).
-pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2 in |- *;
- rewrite <- Rplus_0_r.
-apply Rplus_le_compat_l.
-unfold tg_alt in |- *; simpl in |- *.
-replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ].
-rewrite pow_1_even.
-replace (-1 * (-1 * (-1 * 1)) * Un (S (S (S (2 * x))))) with
- (- Un (S (S (S (2 * x))))); [ idtac | ring ].
-apply Rplus_le_reg_l with (Un (S (S (S (2 * x))))).
-rewrite Rplus_0_r; rewrite Rplus_opp_r.
-apply H0.
-apply CV_ALT_step2; assumption.
+  forall (Un:nat -> R) (N:nat),
+    Un_decreasing Un ->
+    positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. 
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
+  apply Rplus_le_reg_l with (Un 1%nat).
+  rewrite Rplus_0_r; replace (Un 1%nat + -1 * Un 1%nat) with 0;
+    [ apply H0 | ring ].
+  assert (H1 := even_odd_cor N).
+  elim H1; intros.
+  elim H2; intro.
+  rewrite H3; apply CV_ALT_step2; assumption.
+  rewrite H3; rewrite tech5.
+  apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))).
+  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2 in |- *;
+    rewrite <- Rplus_0_r.
+  apply Rplus_le_compat_l.
+  unfold tg_alt in |- *; simpl in |- *.
+  replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ].
+  rewrite pow_1_even.
+  replace (-1 * (-1 * (-1 * 1)) * Un (S (S (S (2 * x))))) with
+    (- Un (S (S (S (2 * x))))); [ idtac | ring ].
+  apply Rplus_le_reg_l with (Un (S (S (S (2 * x))))).
+  rewrite Rplus_0_r; rewrite Rplus_opp_r.
+  apply H0.
+  apply CV_ALT_step2; assumption.
 Qed.
 
-(**********)
+  (**********)
 Lemma CV_ALT_step4 :
- forall Un:nat -> R,
-   Un_decreasing Un ->
-   positivity_seq Un ->
-   has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
-intros; unfold has_ub in |- *; unfold bound in |- *.
-exists (Un 0%nat).
-unfold is_upper_bound in |- *; intros; elim H1; intros.
-rewrite H2; rewrite decomp_sum.
-replace (tg_alt Un 0) with (Un 0%nat).
-pattern (Un 0%nat) at 2 in |- *; rewrite <- Rplus_0_r.
-apply Rplus_le_compat_l.
-apply CV_ALT_step3; assumption.
-unfold tg_alt in |- *; simpl in |- *; ring.
-apply lt_O_Sn.
+  forall Un:nat -> R,
+    Un_decreasing Un ->
+    positivity_seq Un ->
+    has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
+Proof.
+  intros; unfold has_ub in |- *; unfold bound in |- *.
+  exists (Un 0%nat).
+  unfold is_upper_bound in |- *; intros; elim H1; intros.
+  rewrite H2; rewrite decomp_sum.
+  replace (tg_alt Un 0) with (Un 0%nat).
+  pattern (Un 0%nat) at 2 in |- *; rewrite <- Rplus_0_r.
+  apply Rplus_le_compat_l.
+  apply CV_ALT_step3; assumption.
+  unfold tg_alt in |- *; simpl in |- *; ring.
+  apply lt_O_Sn.
 Qed.
 
-(* This lemma gives an interesting result about alternated series *)
+(** This lemma gives an interesting result about alternated series *)
 Lemma CV_ALT :
- forall Un:nat -> R,
-   Un_decreasing Un ->
-   positivity_seq Un ->
-   Un_cv Un 0 ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l).
-intros.
-assert (H2 := CV_ALT_step0 _ H).
-assert (H3 := CV_ALT_step4 _ H H0).
-assert (X := growing_cv _ H2 H3).
-elim X; intros.
-apply existT with x.
-unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
- unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
-intros; cut (0 < eps / 2);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
-elim (H1 (eps / 2) H5); intros N2 H6.
-elim (p (eps / 2) H5); intros N1 H7.
-set (N := max (S (2 * N1)) N2).
-exists N; intros.
-assert (H9 := even_odd_cor n).
-elim H9; intros P H10.
-cut (N1 <= P)%nat.
-intro; elim H10; intro.
-replace (sum_f_R0 (tg_alt Un) n - x) with
- (sum_f_R0 (tg_alt Un) (S n) - x + - tg_alt Un (S n)).
-apply Rle_lt_trans with
- (Rabs (sum_f_R0 (tg_alt Un) (S n) - x) + Rabs (- tg_alt Un (S n))).
-apply Rabs_triang.
-rewrite (double_var eps); apply Rplus_lt_compat.
-rewrite H12; apply H7; assumption.
-rewrite Rabs_Ropp; unfold tg_alt in |- *; rewrite Rabs_mult;
- rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
- rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); 
- apply H6.
-unfold ge in |- *; apply le_trans with n.
-apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ].
-apply le_n_Sn.
-rewrite tech5; ring.
-rewrite H12; apply Rlt_trans with (eps / 2).
-apply H7; assumption.
-unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
-prove_sup0.
-rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
- [ rewrite Rmult_1_r | discrR ].
-rewrite double.
-pattern eps at 1 in |- *; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
- assumption.
-elim H10; intro; apply le_double.
-rewrite <- H11; apply le_trans with N.
-unfold N in |- *; apply le_trans with (S (2 * N1));
- [ apply le_n_Sn | apply le_max_l ].
-assumption.
-apply lt_n_Sm_le.
-rewrite <- H11.
-apply lt_le_trans with N.
-unfold N in |- *; apply lt_le_trans with (S (2 * N1)).
-apply lt_n_Sn.
-apply le_max_l.
-assumption.
+  forall Un:nat -> R,
+    Un_decreasing Un ->
+    positivity_seq Un ->
+    Un_cv Un 0 ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l).
+Proof.
+  intros.
+  assert (H2 := CV_ALT_step0 _ H).
+  assert (H3 := CV_ALT_step4 _ H H0).
+  assert (X := growing_cv _ H2 H3).
+  elim X; intros.
+  apply existT with x.
+  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+    unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
+  intros; cut (0 < eps / 2);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (H1 (eps / 2) H5); intros N2 H6.
+  elim (p (eps / 2) H5); intros N1 H7.
+  set (N := max (S (2 * N1)) N2).
+  exists N; intros.
+  assert (H9 := even_odd_cor n).
+  elim H9; intros P H10.
+  cut (N1 <= P)%nat.
+  intro; elim H10; intro.
+  replace (sum_f_R0 (tg_alt Un) n - x) with
+    (sum_f_R0 (tg_alt Un) (S n) - x + - tg_alt Un (S n)).
+  apply Rle_lt_trans with
+    (Rabs (sum_f_R0 (tg_alt Un) (S n) - x) + Rabs (- tg_alt Un (S n))).
+  apply Rabs_triang.
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  rewrite H12; apply H7; assumption.
+  rewrite Rabs_Ropp; unfold tg_alt in |- *; rewrite Rabs_mult;
+    rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
+      rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); 
+	apply H6.
+  unfold ge in |- *; apply le_trans with n.
+  apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ].
+  apply le_n_Sn.
+  rewrite tech5; ring.
+  rewrite H12; apply Rlt_trans with (eps / 2).
+  apply H7; assumption.
+  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
+    [ rewrite Rmult_1_r | discrR ].
+  rewrite double.
+  pattern eps at 1 in |- *; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
+    assumption.
+  elim H10; intro; apply le_double.
+  rewrite <- H11; apply le_trans with N.
+  unfold N in |- *; apply le_trans with (S (2 * N1));
+    [ apply le_n_Sn | apply le_max_l ].
+  assumption.
+  apply lt_n_Sm_le.
+  rewrite <- H11.
+  apply lt_le_trans with N.
+  unfold N in |- *; apply lt_le_trans with (S (2 * N1)).
+  apply lt_n_Sn.
+  apply le_max_l.
+  assumption.
 Qed.
 
-(************************************************)
-(*        Convergence of alternated series      *)
-(*                                              *)
-(*         Applications: PI, cos, sin           *)
-(************************************************)
+
+(*************************************************)
+(** *       Convergence of alternated series     *)
 Theorem alternated_series :
- forall Un:nat -> R,
-   Un_decreasing Un ->
-   Un_cv Un 0 ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l).
-intros; apply CV_ALT.
-assumption.
-unfold positivity_seq in |- *; apply decreasing_ineq; assumption.
-assumption.
+  forall Un:nat -> R,
+    Un_decreasing Un ->
+    Un_cv Un 0 ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l).
+Proof.
+  intros; apply CV_ALT.
+  assumption.
+  unfold positivity_seq in |- *; apply decreasing_ineq; assumption.
+  assumption.
 Qed.
 
 Theorem alternated_series_ineq :
- forall (Un:nat -> R) (l:R) (N:nat),
-   Un_decreasing Un ->
-   Un_cv Un 0 ->
-   Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l ->
-   sum_f_R0 (tg_alt Un) (S (2 * N)) <= l <= sum_f_R0 (tg_alt Un) (2 * N).
-intros.
-cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)) l).
-cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))) l).
-intros; split.
-apply (growing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N)))).
-apply CV_ALT_step0; assumption.
-assumption.
-apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))).
-apply CV_ALT_step1; assumption.
-assumption.
-unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
- unfold R_dist in H1; intros. 
-elim (H1 eps H2); intros.
-exists x; intros.
-apply H3.
-unfold ge in |- *; apply le_trans with (2 * n)%nat.
-apply le_trans with n.
-assumption.
-assert (H5 := mult_O_le n 2).
-elim H5; intro. 
-cut (0%nat <> 2%nat);
- [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
-assumption.
-apply le_n_Sn.
-unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
- unfold R_dist in H1; intros. 
-elim (H1 eps H2); intros.
-exists x; intros.
-apply H3.
-unfold ge in |- *; apply le_trans with n.
-assumption.
-assert (H5 := mult_O_le n 2).
-elim H5; intro. 
-cut (0%nat <> 2%nat);
- [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
-assumption.
+  forall (Un:nat -> R) (l:R) (N:nat),
+    Un_decreasing Un ->
+    Un_cv Un 0 ->
+    Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l ->
+    sum_f_R0 (tg_alt Un) (S (2 * N)) <= l <= sum_f_R0 (tg_alt Un) (2 * N).
+Proof.
+  intros.
+  cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)) l).
+  cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))) l).
+  intros; split.
+  apply (growing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N)))).
+  apply CV_ALT_step0; assumption.
+  assumption.
+  apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))).
+  apply CV_ALT_step1; assumption.
+  assumption.
+  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+    unfold R_dist in H1; intros. 
+  elim (H1 eps H2); intros.
+  exists x; intros.
+  apply H3.
+  unfold ge in |- *; apply le_trans with (2 * n)%nat.
+  apply le_trans with n.
+  assumption.
+  assert (H5 := mult_O_le n 2).
+  elim H5; intro. 
+  cut (0%nat <> 2%nat);
+    [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
+  assumption.
+  apply le_n_Sn.
+  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+    unfold R_dist in H1; intros. 
+  elim (H1 eps H2); intros.
+  exists x; intros.
+  apply H3.
+  unfold ge in |- *; apply le_trans with n.
+  assumption.
+  assert (H5 := mult_O_le n 2).
+  elim H5; intro. 
+  cut (0%nat <> 2%nat);
+    [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
+  assumption.
 Qed.
 
-(************************************)
-(* Application : construction of PI *)
-(************************************)
+(***************************************)
+(** * Application : construction of PI *)
+(***************************************)
 
 Definition PI_tg (n:nat) := / INR (2 * n + 1).
 
 Lemma PI_tg_pos : forall n:nat, 0 <= PI_tg n.
-intro; unfold PI_tg in |- *; left; apply Rinv_0_lt_compat; apply lt_INR_0;
- replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
+Proof.
+  intro; unfold PI_tg in |- *; left; apply Rinv_0_lt_compat; apply lt_INR_0;
+    replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
 Qed.
 
 Lemma PI_tg_decreasing : Un_decreasing PI_tg.
-unfold PI_tg, Un_decreasing in |- *; intro.
-apply Rmult_le_reg_l with (INR (2 * n + 1)).
-apply lt_INR_0.
-replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
-rewrite <- Rinv_r_sym.
-apply Rmult_le_reg_l with (INR (2 * S n + 1)).
-apply lt_INR_0.
-replace (2 * S n + 1)%nat with (S (2 * S n)); [ apply lt_O_Sn | ring ].
-rewrite (Rmult_comm (INR (2 * S n + 1))); rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-do 2 rewrite Rmult_1_r; apply le_INR.
-replace (2 * S n + 1)%nat with (S (S (2 * n + 1))).
-apply le_trans with (S (2 * n + 1)); apply le_n_Sn.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite plus_INR;
- do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
-apply not_O_INR; discriminate.
-apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
- [ discriminate | ring ].
+Proof.
+  unfold PI_tg, Un_decreasing in |- *; intro.
+  apply Rmult_le_reg_l with (INR (2 * n + 1)).
+  apply lt_INR_0.
+  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
+  rewrite <- Rinv_r_sym.
+  apply Rmult_le_reg_l with (INR (2 * S n + 1)).
+  apply lt_INR_0.
+  replace (2 * S n + 1)%nat with (S (2 * S n)); [ apply lt_O_Sn | ring ].
+  rewrite (Rmult_comm (INR (2 * S n + 1))); rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  do 2 rewrite Rmult_1_r; apply le_INR.
+  replace (2 * S n + 1)%nat with (S (S (2 * n + 1))).
+  apply le_trans with (S (2 * n + 1)); apply le_n_Sn.
+  ring.
+  apply not_O_INR; discriminate.
+  apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
+    [ discriminate | ring ].
 Qed.
 
 Lemma PI_tg_cv : Un_cv PI_tg 0.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
-cut (0 < 2 * eps);
- [ intro | apply Rmult_lt_0_compat; [ prove_sup0 | assumption ] ].
-assert (H1 := archimed (/ (2 * eps))).
-cut (0 <= up (/ (2 * eps)))%Z.
-intro; assert (H3 := IZN (up (/ (2 * eps))) H2).
-elim H3; intros N H4.
-cut (0 < N)%nat.
-intro; exists N; intros.
-cut (0 < n)%nat.
-intro; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
- rewrite Rabs_right.
-unfold PI_tg in |- *; apply Rlt_trans with (/ INR (2 * n)).
-apply Rmult_lt_reg_l with (INR (2 * n)).
-apply lt_INR_0.
-replace (2 * n)%nat with (n + n)%nat; [ idtac | ring ].
-apply lt_le_trans with n.
-assumption.
-apply le_plus_l.
-rewrite <- Rinv_r_sym.
-apply Rmult_lt_reg_l with (INR (2 * n + 1)).
-apply lt_INR_0.
-replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
-rewrite (Rmult_comm (INR (2 * n + 1))).
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-do 2 rewrite Rmult_1_r; apply lt_INR.
-replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_n_Sn | ring ].
-apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
- [ discriminate | ring ].
-replace n with (S (pred n)).
-apply not_O_INR; discriminate.
-symmetry  in |- *; apply S_pred with 0%nat.
-assumption.
-apply Rle_lt_trans with (/ INR (2 * N)).
-apply Rmult_le_reg_l with (INR (2 * N)).
-rewrite mult_INR; apply Rmult_lt_0_compat;
- [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
-rewrite <- Rinv_r_sym.
-apply Rmult_le_reg_l with (INR (2 * n)).
-rewrite mult_INR; apply Rmult_lt_0_compat;
- [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
-rewrite (Rmult_comm (INR (2 * n))); rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-do 2 rewrite Rmult_1_r; apply le_INR.
-apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
-replace n with (S (pred n)).
-apply not_O_INR; discriminate.
-symmetry  in |- *; apply S_pred with 0%nat.
-assumption.
-replace N with (S (pred N)).
-apply not_O_INR; discriminate.
-symmetry  in |- *; apply S_pred with 0%nat.
-assumption.
-rewrite mult_INR.
-rewrite Rinv_mult_distr.
-replace (INR 2) with 2; [ idtac | reflexivity ].
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ idtac | discrR ].
-rewrite Rmult_1_l; apply Rmult_lt_reg_l with (INR N).
-apply lt_INR_0; assumption.
-rewrite <- Rinv_r_sym.
-apply Rmult_lt_reg_l with (/ (2 * eps)).
-apply Rinv_0_lt_compat; assumption.
-rewrite Rmult_1_r;
- replace (/ (2 * eps) * (INR N * (2 * eps))) with
-  (INR N * (2 * eps * / (2 * eps))); [ idtac | ring ].
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; replace (INR N) with (IZR (Z_of_nat N)).
-rewrite <- H4.
-elim H1; intros; assumption.
-symmetry  in |- *; apply INR_IZR_INZ.
-apply prod_neq_R0;
- [ discrR | red in |- *; intro; rewrite H8 in H; elim (Rlt_irrefl _ H) ].
-apply not_O_INR.
-red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
-replace (INR 2) with 2; [ discrR | reflexivity ].
-apply not_O_INR.
-red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
-apply Rle_ge; apply PI_tg_pos.
-apply lt_le_trans with N; assumption.
-elim H1; intros H5 _.
-assert (H6 := lt_eq_lt_dec 0 N).
-elim H6; intro.
-elim a; intro.
-assumption.
-rewrite <- b in H4.
-rewrite H4 in H5.
-simpl in H5.
-cut (0 < / (2 * eps)); [ intro | apply Rinv_0_lt_compat; assumption ].
-elim (Rlt_irrefl _ (Rlt_trans _ _ _ H7 H5)).
-elim (lt_n_O _ b).
-apply le_IZR.
-simpl in |- *.
-left; apply Rlt_trans with (/ (2 * eps)).
-apply Rinv_0_lt_compat; assumption.
-elim H1; intros; assumption.
+Proof.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  cut (0 < 2 * eps);
+    [ intro | apply Rmult_lt_0_compat; [ prove_sup0 | assumption ] ].
+  assert (H1 := archimed (/ (2 * eps))).
+  cut (0 <= up (/ (2 * eps)))%Z.
+  intro; assert (H3 := IZN (up (/ (2 * eps))) H2).
+  elim H3; intros N H4.
+  cut (0 < N)%nat.
+  intro; exists N; intros.
+  cut (0 < n)%nat.
+  intro; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+    rewrite Rabs_right.
+  unfold PI_tg in |- *; apply Rlt_trans with (/ INR (2 * n)).
+  apply Rmult_lt_reg_l with (INR (2 * n)).
+  apply lt_INR_0.
+  replace (2 * n)%nat with (n + n)%nat; [ idtac | ring ].
+  apply lt_le_trans with n.
+  assumption.
+  apply le_plus_l.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_lt_reg_l with (INR (2 * n + 1)).
+  apply lt_INR_0.
+  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
+  rewrite (Rmult_comm (INR (2 * n + 1))).
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  do 2 rewrite Rmult_1_r; apply lt_INR.
+  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_n_Sn | ring ].
+  apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
+    [ discriminate | ring ].
+  replace n with (S (pred n)).
+  apply not_O_INR; discriminate.
+  symmetry  in |- *; apply S_pred with 0%nat.
+  assumption.
+  apply Rle_lt_trans with (/ INR (2 * N)).
+  apply Rmult_le_reg_l with (INR (2 * N)).
+  rewrite mult_INR; apply Rmult_lt_0_compat;
+    [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
+  rewrite <- Rinv_r_sym.
+  apply Rmult_le_reg_l with (INR (2 * n)).
+  rewrite mult_INR; apply Rmult_lt_0_compat;
+    [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
+  rewrite (Rmult_comm (INR (2 * n))); rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  do 2 rewrite Rmult_1_r; apply le_INR.
+  apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
+  replace n with (S (pred n)).
+  apply not_O_INR; discriminate.
+  symmetry  in |- *; apply S_pred with 0%nat.
+  assumption.
+  replace N with (S (pred N)).
+  apply not_O_INR; discriminate.
+  symmetry  in |- *; apply S_pred with 0%nat.
+  assumption.
+  rewrite mult_INR.
+  rewrite Rinv_mult_distr.
+  replace (INR 2) with 2; [ idtac | reflexivity ].
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ idtac | discrR ].
+  rewrite Rmult_1_l; apply Rmult_lt_reg_l with (INR N).
+  apply lt_INR_0; assumption.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_lt_reg_l with (/ (2 * eps)).
+  apply Rinv_0_lt_compat; assumption.
+  rewrite Rmult_1_r;
+    replace (/ (2 * eps) * (INR N * (2 * eps))) with
+      (INR N * (2 * eps * / (2 * eps))); [ idtac | ring ].
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; replace (INR N) with (IZR (Z_of_nat N)).
+  rewrite <- H4.
+  elim H1; intros; assumption.
+  symmetry  in |- *; apply INR_IZR_INZ.
+  apply prod_neq_R0;
+    [ discrR | red in |- *; intro; rewrite H8 in H; elim (Rlt_irrefl _ H) ].
+  apply not_O_INR.
+  red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
+  replace (INR 2) with 2; [ discrR | reflexivity ].
+  apply not_O_INR.
+  red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
+  apply Rle_ge; apply PI_tg_pos.
+  apply lt_le_trans with N; assumption.
+  elim H1; intros H5 _.
+  assert (H6 := lt_eq_lt_dec 0 N).
+  elim H6; intro.
+  elim a; intro.
+  assumption.
+  rewrite <- b in H4.
+  rewrite H4 in H5.
+  simpl in H5.
+  cut (0 < / (2 * eps)); [ intro | apply Rinv_0_lt_compat; assumption ].
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H7 H5)).
+  elim (lt_n_O _ b).
+  apply le_IZR.
+  simpl in |- *.
+  left; apply Rlt_trans with (/ (2 * eps)).
+  apply Rinv_0_lt_compat; assumption.
+  elim H1; intros; assumption.
 Qed.
 
 Lemma exist_PI :
- sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l).
-apply alternated_series.
-apply PI_tg_decreasing.
-apply PI_tg_cv.
+  sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l).
+Proof.
+  apply alternated_series.
+  apply PI_tg_decreasing.
+  apply PI_tg_cv.
 Qed.
 
-(* Now, PI is defined *)
+(** Now, PI is defined *)
 Definition PI : R := 4 * match exist_PI with
-                         | existT a b => a
+                           | existT a b => a
                          end.
 
-(* We can get an approximation of PI with the following inequality *)
+(** We can get an approximation of PI with the following inequality *)
 Lemma PI_ineq :
- forall N:nat,
-   sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI / 4 <=
-   sum_f_R0 (tg_alt PI_tg) (2 * N).
-intro; apply alternated_series_ineq.
-apply PI_tg_decreasing.
-apply PI_tg_cv.
-unfold PI in |- *; case exist_PI; intro.
-replace (4 * x / 4) with x.
-trivial.
-unfold Rdiv in |- *; rewrite (Rmult_comm 4); rewrite Rmult_assoc;
- rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | discrR ].
+  forall N:nat,
+    sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI / 4 <=
+    sum_f_R0 (tg_alt PI_tg) (2 * N).
+Proof.
+  intro; apply alternated_series_ineq.
+  apply PI_tg_decreasing.
+  apply PI_tg_cv.
+  unfold PI in |- *; case exist_PI; intro.
+  replace (4 * x / 4) with x.
+  trivial.
+  unfold Rdiv in |- *; rewrite (Rmult_comm 4); rewrite Rmult_assoc;
+    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | discrR ].
 Qed.
 
 Lemma PI_RGT_0 : 0 < PI.
-assert (H := PI_ineq 0).
-apply Rmult_lt_reg_l with (/ 4).
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite Rmult_0_r; rewrite Rmult_comm.
-elim H; clear H; intros H _.
-unfold Rdiv in H;
- apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
-simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_l;
- rewrite Rmult_1_r; apply Rplus_lt_reg_r with (PI_tg 1).
-rewrite Rplus_0_r;
- replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0);
- [ unfold PI_tg in |- * | ring ].
-simpl in |- *; apply Rinv_lt_contravar.
-rewrite Rmult_1_l; replace (2 + 1) with 3; [ prove_sup0 | ring ].
-rewrite Rplus_comm; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_lt_compat_l; prove_sup0.
-assumption.
-Qed.
\ No newline at end of file
+Proof.
+  assert (H := PI_ineq 0).
+  apply Rmult_lt_reg_l with (/ 4).
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite Rmult_0_r; rewrite Rmult_comm.
+  elim H; clear H; intros H _.
+  unfold Rdiv in H;
+    apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
+  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_l;
+    rewrite Rmult_1_r; apply Rplus_lt_reg_r with (PI_tg 1).
+  rewrite Rplus_0_r;
+    replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0);
+      [ unfold PI_tg in |- * | ring ].
+  simpl in |- *; apply Rinv_lt_contravar.
+  rewrite Rmult_1_l; replace (2 + 1) with 3; [ prove_sup0 | ring ].
+  rewrite Rplus_comm; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_lt_compat_l; prove_sup0.
+  assumption.
+Qed.
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
index ad535a9d..7dbbd605 100644
--- a/theories/Reals/ArithProp.v
+++ b/theories/Reals/ArithProp.v
@@ -1,178 +1,187 @@
-(************************************************************************)
-(*  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: ArithProp.v,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+  (************************************************************************)
+  (*  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: ArithProp.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rbasic_fun.
 Require Import Even.
 Require Import Div2.
+Require Import ArithRing.
+
 Open Local Scope Z_scope.
 Open Local Scope R_scope.
 
 Lemma minus_neq_O : forall n i:nat, (i < n)%nat -> (n - i)%nat <> 0%nat.
-intros; red in |- *; intro.
-cut (forall n m:nat, (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
-intro; assert (H2 := H1 _ _ (lt_le_weak _ _ H) H0); rewrite H2 in H;
- elim (lt_irrefl _ H).
-set (R := fun n m:nat => (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
-cut
- ((forall n m:nat, R n m) ->
-  forall n0 m:nat, (m <= n0)%nat -> (n0 - m)%nat = 0%nat -> n0 = m).
-intro; apply H1.
-apply nat_double_ind.
-unfold R in |- *; intros; inversion H2; reflexivity.
-unfold R in |- *; intros; simpl in H3; assumption.
-unfold R in |- *; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
- assert (H6 := H2 H5 H4); rewrite H6; reflexivity.
-unfold R in |- *; intros; apply H1; assumption.
+Proof.
+  intros; red in |- *; intro.
+  cut (forall n m:nat, (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
+  intro; assert (H2 := H1 _ _ (lt_le_weak _ _ H) H0); rewrite H2 in H;
+    elim (lt_irrefl _ H).
+  set (R := fun n m:nat => (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
+  cut
+    ((forall n m:nat, R n m) ->
+      forall n0 m:nat, (m <= n0)%nat -> (n0 - m)%nat = 0%nat -> n0 = m).
+  intro; apply H1.
+  apply nat_double_ind.
+  unfold R in |- *; intros; inversion H2; reflexivity.
+  unfold R in |- *; intros; simpl in H3; assumption.
+  unfold R in |- *; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
+    assert (H6 := H2 H5 H4); rewrite H6; reflexivity.
+  unfold R in |- *; intros; apply H1; assumption.
 Qed.
 
 Lemma le_minusni_n : forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat.
-set (R := fun m n:nat => (n <= m)%nat -> (m - n <= m)%nat).
-cut
- ((forall m n:nat, R m n) -> forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat).
-intro; apply H.
-apply nat_double_ind.
-unfold R in |- *; intros; simpl in |- *; apply le_n.
-unfold R in |- *; intros; simpl in |- *; apply le_n.
-unfold R in |- *; intros; simpl in |- *; apply le_trans with n.
-apply H0; apply le_S_n; assumption.
-apply le_n_Sn.
-unfold R in |- *; intros; apply H; assumption.
+Proof.
+  set (R := fun m n:nat => (n <= m)%nat -> (m - n <= m)%nat).
+  cut
+    ((forall m n:nat, R m n) -> forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat).
+  intro; apply H.
+  apply nat_double_ind.
+  unfold R in |- *; intros; simpl in |- *; apply le_n.
+  unfold R in |- *; intros; simpl in |- *; apply le_n.
+  unfold R in |- *; intros; simpl in |- *; apply le_trans with n.
+  apply H0; apply le_S_n; assumption.
+  apply le_n_Sn.
+  unfold R in |- *; intros; apply H; assumption.
 Qed.
 
 Lemma lt_minus_O_lt : forall m n:nat, (m < n)%nat -> (0 < n - m)%nat.
-intros n m; pattern n, m in |- *; apply nat_double_ind;
- [ intros; rewrite <- minus_n_O; assumption
- | intros; elim (lt_n_O _ H)
- | intros; simpl in |- *; apply H; apply lt_S_n; assumption ].
+Proof.
+  intros n m; pattern n, m in |- *; apply nat_double_ind;
+    [ intros; rewrite <- minus_n_O; assumption
+      | intros; elim (lt_n_O _ H)
+      | intros; simpl in |- *; apply H; apply lt_S_n; assumption ].
 Qed.
 
 Lemma even_odd_cor :
- forall n:nat,  exists p : nat, n = (2 * p)%nat \/ n = S (2 * p).
-intro.
-assert (H := even_or_odd n).
-exists (div2 n).
-assert (H0 := even_odd_double n).
-elim H0; intros.
-elim H1; intros H3 _.
-elim H2; intros H4 _.
-replace (2 * div2 n)%nat with (double (div2 n)).
-elim H; intro.
-left.
-apply H3; assumption.
-right.
-apply H4; assumption.
-unfold double in |- *; ring.
+  forall n:nat,  exists p : nat, n = (2 * p)%nat \/ n = S (2 * p).
+Proof.
+  intro.
+  assert (H := even_or_odd n).
+  exists (div2 n).
+  assert (H0 := even_odd_double n).
+  elim H0; intros.
+  elim H1; intros H3 _.
+  elim H2; intros H4 _.
+  replace (2 * div2 n)%nat with (double (div2 n)).
+  elim H; intro.
+  left.
+  apply H3; assumption.
+  right.
+  apply H4; assumption.
+  unfold double in |- *;ring.
 Qed.
 
-(* 2m <= 2n => m<=n *)
+  (* 2m <= 2n => m<=n *)
 Lemma le_double : forall m n:nat, (2 * m <= 2 * n)%nat -> (m <= n)%nat.
-intros; apply INR_le.
-assert (H1 := le_INR _ _ H).
-do 2 rewrite mult_INR in H1.
-apply Rmult_le_reg_l with (INR 2).
-replace (INR 2) with 2; [ prove_sup0 | reflexivity ].
-assumption.
+Proof.
+  intros; apply INR_le.
+  assert (H1 := le_INR _ _ H).
+  do 2 rewrite mult_INR in H1.
+  apply Rmult_le_reg_l with (INR 2).
+  replace (INR 2) with 2; [ prove_sup0 | reflexivity ].
+  assumption.
 Qed.
 
-(* Here, we have the euclidian division *)
-(* This lemma is used in the proof of sin_eq_0 : (sin x)=0<->x=kPI *)
+(** Here, we have the euclidian division *)
+(** This lemma is used in the proof of sin_eq_0 : (sin x)=0<->x=kPI *)
 Lemma euclidian_division :
- forall x y:R,
-   y <> 0 ->
+  forall x y:R,
+    y <> 0 ->
     exists k : Z, (exists r : R, x = IZR k * y + r /\ 0 <= r < Rabs y).
-intros.
-set
- (k0 :=
-  match Rcase_abs y with
-  | left _ => (1 - up (x / - y))%Z
-  | right _ => (up (x / y) - 1)%Z
-  end).
-exists k0.
-exists (x - IZR k0 * y).
-split.
-ring.
-unfold k0 in |- *; case (Rcase_abs y); intro.
-assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl in |- *;
- unfold Rminus in |- *.
-replace (- ((1 + - IZR (up (x / - y))) * y)) with
- ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ].
-split.
-apply Rmult_le_reg_l with (/ - y).
-apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
-rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
- rewrite <- Ropp_inv_permute; [ idtac | assumption ].
-rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
- rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ].
-apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y).
-rewrite Rplus_0_r; unfold Rdiv in |- *; pattern (/ - y) at 4 in |- *;
- rewrite <- Ropp_inv_permute; [ idtac | assumption ].
-replace
- (IZR (up (x * / - y)) - x * - / y +
-  (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; 
- [ idtac | ring ].
-elim H0; intros _ H1; unfold Rdiv in H1; exact H1.
-rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y).
-apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
-rewrite <- Rinv_l_sym.
-rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
- rewrite <- Ropp_inv_permute; [ idtac | assumption ].
-rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
- rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ];
- apply Rplus_lt_reg_r with (IZR (up (x / - y)) - 1).
-replace (IZR (up (x / - y)) - 1 + 1) with (IZR (up (x / - y)));
- [ idtac | ring ].
-replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1)))
- with (- (x * / y)); [ idtac | ring ].
-rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0;
- unfold Rdiv in |- *; intros H1 _; exact H1.
-apply Ropp_neq_0_compat; assumption.
-assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl in |- *;
- cut (0 < y).
-intro; unfold Rminus in |- *;
- replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y);
- [ idtac | ring ].
-split.
-apply Rmult_le_reg_l with (/ y).
-apply Rinv_0_lt_compat; assumption.
-rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r;
- rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
- [ rewrite Rmult_1_r | assumption ];
- apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); 
- rewrite Rplus_0_r; unfold Rdiv in |- *;
- replace
-  (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
-  1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; 
- exact H2.
-rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y).
-apply Rinv_0_lt_compat; assumption.
-rewrite <- (Rinv_l_sym _ H); rewrite (Rmult_comm (/ y));
- rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
- [ rewrite Rmult_1_r | assumption ];
- apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1);
- replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); 
- [ idtac | ring ];
- replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
-  (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *; 
- intros H2 _; exact H2.
-case (total_order_T 0 y); intro.
-elim s; intro.
-assumption.
-elim H; symmetry  in |- *; exact b.
-assert (H1 := Rge_le _ _ r); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r0)).
+Proof.
+  intros.
+  set
+    (k0 :=
+      match Rcase_abs y with
+	| left _ => (1 - up (x / - y))%Z
+	| right _ => (up (x / y) - 1)%Z
+      end).
+  exists k0.
+  exists (x - IZR k0 * y).
+  split.
+  ring.
+  unfold k0 in |- *; case (Rcase_abs y); intro.
+  assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl in |- *;
+    unfold Rminus in |- *.
+  replace (- ((1 + - IZR (up (x / - y))) * y)) with
+    ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ].
+  split.
+  apply Rmult_le_reg_l with (/ - y).
+  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
+  rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
+    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
+  rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
+    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ].
+  apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y).
+  rewrite Rplus_0_r; unfold Rdiv in |- *; pattern (/ - y) at 4 in |- *;
+    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
+  replace
+    (IZR (up (x * / - y)) - x * - / y +
+      (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; 
+    [ idtac | ring ].
+  elim H0; intros _ H1; unfold Rdiv in H1; exact H1.
+  rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y).
+  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
+  rewrite <- Rinv_l_sym.
+  rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
+    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
+  rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
+    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ];
+      apply Rplus_lt_reg_r with (IZR (up (x / - y)) - 1).
+  replace (IZR (up (x / - y)) - 1 + 1) with (IZR (up (x / - y)));
+    [ idtac | ring ].
+  replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1)))
+    with (- (x * / y)); [ idtac | ring ].
+  rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0;
+    unfold Rdiv in |- *; intros H1 _; exact H1.
+  apply Ropp_neq_0_compat; assumption.
+  assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl in |- *;
+    cut (0 < y).
+  intro; unfold Rminus in |- *;
+    replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y);
+      [ idtac | ring ].
+  split.
+  apply Rmult_le_reg_l with (/ y).
+  apply Rinv_0_lt_compat; assumption.
+  rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r;
+    rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
+      [ rewrite Rmult_1_r | assumption ];
+      apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); 
+	rewrite Rplus_0_r; unfold Rdiv in |- *;
+	  replace
+	    (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
+	    1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; 
+	      exact H2.
+  rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y).
+  apply Rinv_0_lt_compat; assumption.
+  rewrite <- (Rinv_l_sym _ H); rewrite (Rmult_comm (/ y));
+    rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
+      [ rewrite Rmult_1_r | assumption ];
+      apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1);
+	replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); 
+	  [ idtac | ring ];
+	  replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
+	    (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *; 
+	      intros H2 _; exact H2.
+  case (total_order_T 0 y); intro.
+  elim s; intro.
+  assumption.
+  elim H; symmetry  in |- *; exact b.
+  assert (H1 := Rge_le _ _ r); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r0)).
 Qed.
 
 Lemma tech8 : forall n i:nat, (n <= S n + i)%nat.
-intros; induction  i as [| i Hreci].
-replace (S n + 0)%nat with (S n); [ apply le_n_Sn | ring ].
-replace (S n + S i)%nat with (S (S n + i)).
-apply le_S; assumption.
-apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
-Qed.
\ No newline at end of file
+Proof.
+  intros; induction  i as [| i Hreci].
+  replace (S n + 0)%nat with (S n); [ apply le_n_Sn | ring ].
+  replace (S n + S i)%nat with (S (S n + i)).
+  apply le_S; assumption.
+  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
+Qed.
diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v
index e31b623c..5be34e71 100644
--- a/theories/Reals/Binomial.v
+++ b/theories/Reals/Binomial.v
@@ -1,12 +1,12 @@
-(************************************************************************)
-(*  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: Binomial.v,v 1.9.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+  (************************************************************************)
+  (*  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: Binomial.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -17,188 +17,193 @@ Definition C (n p:nat) : R :=
   INR (fact n) / (INR (fact p) * INR (fact (n - p))).
 
 Lemma pascal_step1 : forall n i:nat, (i <= n)%nat -> C n i = C n (n - i).
-intros; unfold C in |- *; replace (n - (n - i))%nat with i.
-rewrite Rmult_comm.
-reflexivity.
-apply plus_minus; rewrite plus_comm; apply le_plus_minus; assumption.
+Proof.
+  intros; unfold C in |- *; replace (n - (n - i))%nat with i.
+  rewrite Rmult_comm.
+  reflexivity.
+  apply plus_minus; rewrite plus_comm; apply le_plus_minus; assumption.
 Qed.
 
 Lemma pascal_step2 :
- forall n i:nat,
-   (i <= n)%nat -> C (S n) i = INR (S n) / INR (S n - i) * C n i.
-intros; unfold C in |- *; replace (S n - i)%nat with (S (n - i)).
-cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
-intro; repeat rewrite H0.
-unfold Rdiv in |- *; repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
-ring.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply not_O_INR; discriminate.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply prod_neq_R0.
-apply not_O_INR; discriminate.
-apply INR_fact_neq_0.
-intro; reflexivity.
-apply minus_Sn_m; assumption.
+  forall n i:nat,
+    (i <= n)%nat -> C (S n) i = INR (S n) / INR (S n - i) * C n i.
+Proof.
+  intros; unfold C in |- *; replace (S n - i)%nat with (S (n - i)).
+  cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
+  intro; repeat rewrite H0.
+  unfold Rdiv in |- *; repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
+  ring.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply not_O_INR; discriminate.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply prod_neq_R0.
+  apply not_O_INR; discriminate.
+  apply INR_fact_neq_0.
+  intro; reflexivity.
+  apply minus_Sn_m; assumption.
 Qed.
 
 Lemma pascal_step3 :
- forall n i:nat, (i < n)%nat -> C n (S i) = INR (n - i) / INR (S i) * C n i.
-intros; unfold C in |- *.
-cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
-intro.
-cut ((n - i)%nat = S (n - S i)).
-intro.
-pattern (n - i)%nat at 2 in |- *; rewrite H1.
-repeat rewrite H0; unfold Rdiv in |- *; repeat rewrite mult_INR;
- repeat rewrite Rinv_mult_distr.
-rewrite <- H1; rewrite (Rmult_comm (/ INR (n - i)));
- repeat rewrite Rmult_assoc; rewrite (Rmult_comm (INR (n - i)));
- repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-ring.
-apply not_O_INR; apply minus_neq_O; assumption.
-apply not_O_INR; discriminate.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
-apply not_O_INR; discriminate.
-apply INR_fact_neq_0.
-apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
-apply INR_fact_neq_0.
-rewrite minus_Sn_m.
-simpl in |- *; reflexivity.
-apply lt_le_S; assumption.
-intro; reflexivity.
+  forall n i:nat, (i < n)%nat -> C n (S i) = INR (n - i) / INR (S i) * C n i.
+Proof.
+  intros; unfold C in |- *.
+  cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
+  intro.
+  cut ((n - i)%nat = S (n - S i)).
+  intro.
+  pattern (n - i)%nat at 2 in |- *; rewrite H1.
+  repeat rewrite H0; unfold Rdiv in |- *; repeat rewrite mult_INR;
+    repeat rewrite Rinv_mult_distr.
+  rewrite <- H1; rewrite (Rmult_comm (/ INR (n - i)));
+    repeat rewrite Rmult_assoc; rewrite (Rmult_comm (INR (n - i)));
+      repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  ring.
+  apply not_O_INR; apply minus_neq_O; assumption.
+  apply not_O_INR; discriminate.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+  apply not_O_INR; discriminate.
+  apply INR_fact_neq_0.
+  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+  apply INR_fact_neq_0.
+  rewrite minus_Sn_m.
+  simpl in |- *; reflexivity.
+  apply lt_le_S; assumption.
+  intro; reflexivity.
 Qed.
 
-(**********)
+  (**********)
 Lemma pascal :
- forall n i:nat, (i < n)%nat -> C n i + C n (S i) = C (S n) (S i).
-intros.
-rewrite pascal_step3; [ idtac | assumption ].
-replace (C n i + INR (n - i) / INR (S i) * C n i) with
- (C n i * (1 + INR (n - i) / INR (S i))); [ idtac | ring ].
-replace (1 + INR (n - i) / INR (S i)) with (INR (S n) / INR (S i)).
-rewrite pascal_step1.
-rewrite Rmult_comm; replace (S i) with (S n - (n - i))%nat.
-rewrite <- pascal_step2.
-apply pascal_step1.
-apply le_trans with n.
-apply le_minusni_n.
-apply lt_le_weak; assumption.
-apply le_n_Sn.
-apply le_minusni_n.
-apply lt_le_weak; assumption.
-rewrite <- minus_Sn_m.
-cut ((n - (n - i))%nat = i).
-intro; rewrite H0; reflexivity.
-symmetry  in |- *; apply plus_minus.
-rewrite plus_comm; rewrite le_plus_minus_r.
-reflexivity.
-apply lt_le_weak; assumption.
-apply le_minusni_n; apply lt_le_weak; assumption.
-apply lt_le_weak; assumption.
-unfold Rdiv in |- *.
-repeat rewrite S_INR.
-rewrite minus_INR.
-cut (INR i + 1 <> 0).
-intro.
-apply Rmult_eq_reg_l with (INR i + 1); [ idtac | assumption ].
-rewrite Rmult_plus_distr_l.
-rewrite Rmult_1_r.
-do 2 rewrite (Rmult_comm (INR i + 1)).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym; [ idtac | assumption ].
-ring.
-rewrite <- S_INR.
-apply not_O_INR; discriminate.
-apply lt_le_weak; assumption.
+  forall n i:nat, (i < n)%nat -> C n i + C n (S i) = C (S n) (S i).
+Proof.
+  intros.
+  rewrite pascal_step3; [ idtac | assumption ].
+  replace (C n i + INR (n - i) / INR (S i) * C n i) with
+    (C n i * (1 + INR (n - i) / INR (S i))); [ idtac | ring ].
+  replace (1 + INR (n - i) / INR (S i)) with (INR (S n) / INR (S i)).
+  rewrite pascal_step1.
+  rewrite Rmult_comm; replace (S i) with (S n - (n - i))%nat.
+  rewrite <- pascal_step2.
+  apply pascal_step1.
+  apply le_trans with n.
+  apply le_minusni_n.
+  apply lt_le_weak; assumption.
+  apply le_n_Sn.
+  apply le_minusni_n.
+  apply lt_le_weak; assumption.
+  rewrite <- minus_Sn_m.
+  cut ((n - (n - i))%nat = i).
+  intro; rewrite H0; reflexivity.
+  symmetry  in |- *; apply plus_minus.
+  rewrite plus_comm; rewrite le_plus_minus_r.
+  reflexivity.
+  apply lt_le_weak; assumption.
+  apply le_minusni_n; apply lt_le_weak; assumption.
+  apply lt_le_weak; assumption.
+  unfold Rdiv in |- *.
+  repeat rewrite S_INR.
+  rewrite minus_INR.
+  cut (INR i + 1 <> 0).
+  intro.
+  apply Rmult_eq_reg_l with (INR i + 1); [ idtac | assumption ].
+  rewrite Rmult_plus_distr_l.
+  rewrite Rmult_1_r.
+  do 2 rewrite (Rmult_comm (INR i + 1)).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym; [ idtac | assumption ].
+  ring.
+  rewrite <- S_INR.
+  apply not_O_INR; discriminate.
+  apply lt_le_weak; assumption.
 Qed.
 
-(*********************)
-(*********************)
+  (*********************)
+  (*********************)
 Lemma binomial :
- forall (x y:R) (n:nat),
-   (x + y) ^ n = sum_f_R0 (fun i:nat => C n i * x ^ i * y ^ (n - i)) n.
-intros; induction  n as [| n Hrecn].
-unfold C in |- *; simpl in |- *; unfold Rdiv in |- *;
- repeat rewrite Rmult_1_r; rewrite Rinv_1; ring.
-pattern (S n) at 1 in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
-rewrite pow_add; rewrite Hrecn.
-replace ((x + y) ^ 1) with (x + y); [ idtac | simpl in |- *; ring ].
-rewrite tech5.
-cut (forall p:nat, C p p = 1).
-cut (forall p:nat, C p 0 = 1).
-intros; rewrite H0; rewrite <- minus_n_n; rewrite Rmult_1_l.
-replace (y ^ 0) with 1; [ rewrite Rmult_1_r | simpl in |- *; reflexivity ].
-induction  n as [| n Hrecn0].
-simpl in |- *; do 2 rewrite H; ring.
-(* N >= 1 *)
-set (N := S n).
-rewrite Rmult_plus_distr_l.
-replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * x) with
- (sum_f_R0 (fun i:nat => C N i * x ^ S i * y ^ (N - i)) N).
-replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * y) with
- (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (S N - i)) N).
-rewrite (decomp_sum (fun i:nat => C (S N) i * x ^ i * y ^ (S N - i)) N).
-rewrite H; replace (x ^ 0) with 1; [ idtac | reflexivity ].
-do 2 rewrite Rmult_1_l.
-replace (S N - 0)%nat with (S N); [ idtac | reflexivity ].
-set (An := fun i:nat => C N i * x ^ S i * y ^ (N - i)).
-set (Bn := fun i:nat => C N (S i) * x ^ S i * y ^ (N - i)).
-replace (pred N) with n.
-replace (sum_f_R0 (fun i:nat => C (S N) (S i) * x ^ S i * y ^ (S N - S i)) n)
- with (sum_f_R0 (fun i:nat => An i + Bn i) n).
-rewrite plus_sum.
-replace (x ^ S N) with (An (S n)).
-rewrite (Rplus_comm (sum_f_R0 An n)).
-repeat rewrite Rplus_assoc.
-rewrite <- tech5.
-fold N in |- *.
-set (Cn := fun i:nat => C N i * x ^ i * y ^ (S N - i)).
-cut (forall i:nat, (i < N)%nat -> Cn (S i) = Bn i).
-intro; replace (sum_f_R0 Bn n) with (sum_f_R0 (fun i:nat => Cn (S i)) n).
-replace (y ^ S N) with (Cn 0%nat).
-rewrite <- Rplus_assoc; rewrite (decomp_sum Cn N).
-replace (pred N) with n.
-ring.
-unfold N in |- *; simpl in |- *; reflexivity.
-unfold N in |- *; apply lt_O_Sn.
-unfold Cn in |- *; rewrite H; simpl in |- *; ring.
-apply sum_eq.
-intros; apply H1.
-unfold N in |- *; apply le_lt_trans with n; [ assumption | apply lt_n_Sn ].
-intros; unfold Bn, Cn in |- *.
-replace (S N - S i)%nat with (N - i)%nat; reflexivity.
-unfold An in |- *; fold N in |- *; rewrite <- minus_n_n; rewrite H0;
- simpl in |- *; ring.
-apply sum_eq.
-intros; unfold An, Bn in |- *; replace (S N - S i)%nat with (N - i)%nat;
- [ idtac | reflexivity ].
-rewrite <- pascal;
- [ ring
- | apply le_lt_trans with n; [ assumption | unfold N in |- *; apply lt_n_Sn ] ].
-unfold N in |- *; reflexivity.
-unfold N in |- *; apply lt_O_Sn.
-rewrite <- (Rmult_comm y); rewrite scal_sum; apply sum_eq.
-intros; replace (S N - i)%nat with (S (N - i)).
-replace (S (N - i)) with (N - i + 1)%nat; [ idtac | ring ].
-rewrite pow_add; replace (y ^ 1) with y; [ idtac | simpl in |- *; ring ];
- ring.
-apply minus_Sn_m; assumption.
-rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq.
-intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add;
- replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ]; 
- ring.
-intro; unfold C in |- *.
-replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
-replace (p - 0)%nat with p; [ idtac | apply minus_n_O ].
-rewrite Rmult_1_l; unfold Rdiv in |- *; rewrite <- Rinv_r_sym;
- [ reflexivity | apply INR_fact_neq_0 ].
-intro; unfold C in |- *.
-replace (p - p)%nat with 0%nat; [ idtac | apply minus_n_n ].
-replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
-rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym;
- [ reflexivity | apply INR_fact_neq_0 ].
-Qed.
\ No newline at end of file
+  forall (x y:R) (n:nat),
+    (x + y) ^ n = sum_f_R0 (fun i:nat => C n i * x ^ i * y ^ (n - i)) n.
+Proof.
+  intros; induction  n as [| n Hrecn].
+  unfold C in |- *; simpl in |- *; unfold Rdiv in |- *;
+    repeat rewrite Rmult_1_r; rewrite Rinv_1; ring.
+  pattern (S n) at 1 in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  rewrite pow_add; rewrite Hrecn.
+  replace ((x + y) ^ 1) with (x + y); [ idtac | simpl in |- *; ring ].
+  rewrite tech5.
+  cut (forall p:nat, C p p = 1).
+  cut (forall p:nat, C p 0 = 1).
+  intros; rewrite H0; rewrite <- minus_n_n; rewrite Rmult_1_l.
+  replace (y ^ 0) with 1; [ rewrite Rmult_1_r | simpl in |- *; reflexivity ].
+  induction  n as [| n Hrecn0].
+  simpl in |- *; do 2 rewrite H; ring.
+  (* N >= 1 *)
+  set (N := S n).
+  rewrite Rmult_plus_distr_l.
+  replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * x) with
+    (sum_f_R0 (fun i:nat => C N i * x ^ S i * y ^ (N - i)) N).
+  replace (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (N - i)) N * y) with
+    (sum_f_R0 (fun i:nat => C N i * x ^ i * y ^ (S N - i)) N).
+  rewrite (decomp_sum (fun i:nat => C (S N) i * x ^ i * y ^ (S N - i)) N).
+  rewrite H; replace (x ^ 0) with 1; [ idtac | reflexivity ].
+  do 2 rewrite Rmult_1_l.
+  replace (S N - 0)%nat with (S N); [ idtac | reflexivity ].
+  set (An := fun i:nat => C N i * x ^ S i * y ^ (N - i)).
+  set (Bn := fun i:nat => C N (S i) * x ^ S i * y ^ (N - i)).
+  replace (pred N) with n.
+  replace (sum_f_R0 (fun i:nat => C (S N) (S i) * x ^ S i * y ^ (S N - S i)) n)
+    with (sum_f_R0 (fun i:nat => An i + Bn i) n).
+  rewrite plus_sum.
+  replace (x ^ S N) with (An (S n)).
+  rewrite (Rplus_comm (sum_f_R0 An n)).
+  repeat rewrite Rplus_assoc.
+  rewrite <- tech5.
+  fold N in |- *.
+  set (Cn := fun i:nat => C N i * x ^ i * y ^ (S N - i)).
+  cut (forall i:nat, (i < N)%nat -> Cn (S i) = Bn i).
+  intro; replace (sum_f_R0 Bn n) with (sum_f_R0 (fun i:nat => Cn (S i)) n).
+  replace (y ^ S N) with (Cn 0%nat).
+  rewrite <- Rplus_assoc; rewrite (decomp_sum Cn N).
+  replace (pred N) with n.
+  ring.
+  unfold N in |- *; simpl in |- *; reflexivity.
+  unfold N in |- *; apply lt_O_Sn.
+  unfold Cn in |- *; rewrite H; simpl in |- *; ring.
+  apply sum_eq.
+  intros; apply H1.
+  unfold N in |- *; apply le_lt_trans with n; [ assumption | apply lt_n_Sn ].
+  intros; unfold Bn, Cn in |- *.
+  replace (S N - S i)%nat with (N - i)%nat; reflexivity.
+  unfold An in |- *; fold N in |- *; rewrite <- minus_n_n; rewrite H0;
+    simpl in |- *; ring.
+  apply sum_eq.
+  intros; unfold An, Bn in |- *; replace (S N - S i)%nat with (N - i)%nat;
+    [ idtac | reflexivity ].
+  rewrite <- pascal;
+    [ ring
+      | apply le_lt_trans with n; [ assumption | unfold N in |- *; apply lt_n_Sn ] ].
+  unfold N in |- *; reflexivity.
+  unfold N in |- *; apply lt_O_Sn.
+  rewrite <- (Rmult_comm y); rewrite scal_sum; apply sum_eq.
+  intros; replace (S N - i)%nat with (S (N - i)).
+  replace (S (N - i)) with (N - i + 1)%nat; [ idtac | ring ].
+  rewrite pow_add; replace (y ^ 1) with y; [ idtac | simpl in |- *; ring ];
+    ring.
+  apply minus_Sn_m; assumption.
+  rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq.
+  intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add;
+    replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ]; 
+      ring.
+  intro; unfold C in |- *.
+  replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
+  replace (p - 0)%nat with p; [ idtac | apply minus_n_O ].
+  rewrite Rmult_1_l; unfold Rdiv in |- *; rewrite <- Rinv_r_sym;
+    [ reflexivity | apply INR_fact_neq_0 ].
+  intro; unfold C in |- *.
+  replace (p - p)%nat with 0%nat; [ idtac | apply minus_n_n ].
+  replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
+  rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym;
+    [ reflexivity | apply INR_fact_neq_0 ].
+Qed.
diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v
index 41a6284f..37429a90 100644
--- a/theories/Reals/Cauchy_prod.v
+++ b/theories/Reals/Cauchy_prod.v
@@ -1,12 +1,12 @@
-(************************************************************************)
-(*  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: Cauchy_prod.v,v 1.10.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+  (************************************************************************)
+  (*  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: Cauchy_prod.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -14,445 +14,449 @@ Require Import Rseries.
 Require Import PartSum.
 Open Local Scope R_scope.
 
-(**********)
+  (**********)
 Lemma sum_N_predN :
- forall (An:nat -> R) (N:nat),
-   (0 < N)%nat -> sum_f_R0 An N = sum_f_R0 An (pred N) + An N.
-intros.
-replace N with (S (pred N)).
-rewrite tech5.
-reflexivity.
-symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  forall (An:nat -> R) (N:nat),
+    (0 < N)%nat -> sum_f_R0 An N = sum_f_R0 An (pred N) + An N.
+Proof.
+  intros.
+  replace N with (S (pred N)).
+  rewrite tech5.
+  reflexivity.
+  symmetry  in |- *; apply S_pred with 0%nat; assumption.
 Qed.
 
-(**********)
+  (**********)
 Lemma sum_plus :
- forall (An Bn:nat -> R) (N:nat),
-   sum_f_R0 (fun l:nat => An l + Bn l) N = sum_f_R0 An N + sum_f_R0 Bn N.
-intros.
-induction  N as [| N HrecN].
-reflexivity.
-do 3 rewrite tech5.
-rewrite HrecN; ring.
+  forall (An Bn:nat -> R) (N:nat),
+    sum_f_R0 (fun l:nat => An l + Bn l) N = sum_f_R0 An N + sum_f_R0 Bn N.
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  reflexivity.
+  do 3 rewrite tech5.
+  rewrite HrecN; ring.
 Qed.
 
-(* The main result *)
+  (* The main result *)
 Theorem cauchy_finite :
- forall (An Bn:nat -> R) (N:nat),
-   (0 < N)%nat ->
-   sum_f_R0 An N * sum_f_R0 Bn N =
-   sum_f_R0 (fun k:nat => sum_f_R0 (fun p:nat => An p * Bn (k - p)%nat) k) N +
-   sum_f_R0
-     (fun k:nat =>
-        sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat)
-          (pred (N - k))) (pred N). 
-intros; induction  N as [| N HrecN].
-elim (lt_irrefl _ H).
-cut (N = 0%nat \/ (0 < N)%nat).
-intro; elim H0; intro.
-rewrite H1; simpl in |- *; ring.
-replace (pred (S N)) with (S (pred N)).
-do 5 rewrite tech5.
-rewrite Rmult_plus_distr_r; rewrite Rmult_plus_distr_l; rewrite (HrecN H1).
-repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
-replace (pred (S N - S (pred N))) with 0%nat.
-rewrite Rmult_plus_distr_l;
- replace
-  (sum_f_R0 (fun l:nat => An (S (l + S (pred N))) * Bn (S N - l)%nat) 0) with
-  (An (S N) * Bn (S N)).
-repeat rewrite <- Rplus_assoc;
- do 2 rewrite <- (Rplus_comm (An (S N) * Bn (S N)));
- repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
-rewrite <- minus_n_n; cut (N = 1%nat \/ (2 <= N)%nat).
-intro; elim H2; intro.
-rewrite H3; simpl in |- *; ring.
-replace
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k)))
-    (pred N)) with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (pred (N - k)))) (pred (pred N)) +
-  sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)).
-replace (sum_f_R0 (fun p:nat => An p * Bn (S N - p)%nat) N) with
- (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N) +
-  An 0%nat * Bn (S N)).
-repeat rewrite <- Rplus_assoc;
- rewrite <-
-  (Rplus_comm (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)))
-  ; repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
-replace
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat)
-         (pred (S N - k))) (pred N)) with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (N - k))) (pred N) +
-  Bn (S N) * sum_f_R0 (fun l:nat => An (S l)) (pred N)).
-rewrite (decomp_sum An N H1); rewrite Rmult_plus_distr_r;
- repeat rewrite <- Rplus_assoc; rewrite <- (Rplus_comm (An 0%nat * Bn (S N)));
- repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
-repeat rewrite <- Rplus_assoc;
- rewrite <-
-  (Rplus_comm (sum_f_R0 (fun i:nat => An (S i)) (pred N) * Bn (S N)))
-  ;
- rewrite <-
-  (Rplus_comm (Bn (S N) * sum_f_R0 (fun i:nat => An (S i)) (pred N)))
-  ; rewrite (Rmult_comm (Bn (S N))); repeat rewrite Rplus_assoc;
- apply Rplus_eq_compat_l.
-replace
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (N - k))) (pred N)) with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (pred (N - k)))) (pred (pred N)) +
-  An (S N) * sum_f_R0 (fun l:nat => Bn (S l)) (pred N)).
-rewrite (decomp_sum Bn N H1); rewrite Rmult_plus_distr_l.
-set
- (Z :=
-  sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (pred (N - k)))) (pred (pred N)));
- set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); 
- ring.
-rewrite
- (sum_N_predN
+  forall (An Bn:nat -> R) (N:nat),
+    (0 < N)%nat ->
+    sum_f_R0 An N * sum_f_R0 Bn N =
+    sum_f_R0 (fun k:nat => sum_f_R0 (fun p:nat => An p * Bn (k - p)%nat) k) N +
+    sum_f_R0
     (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (N - k))) (pred N)).
-replace
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (N - k))) (pred (pred N))) with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (pred (N - k))) + An (S N) * Bn (S k)) (
-    pred (pred N))).
-rewrite
- (sum_plus
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (pred (N - k)))) (fun k:nat => An (S N) * Bn (S k))
-    (pred (pred N))).
-repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
-replace (pred (N - pred N)) with 0%nat.
-simpl in |- *; rewrite <- minus_n_O.
-replace (S (pred N)) with N.
-replace (sum_f_R0 (fun k:nat => An (S N) * Bn (S k)) (pred (pred N))) with
- (sum_f_R0 (fun k:nat => Bn (S k) * An (S N)) (pred (pred N))).
-rewrite <- (scal_sum (fun l:nat => Bn (S l)) (pred (pred N)) (An (S N)));
- rewrite (sum_N_predN (fun l:nat => Bn (S l)) (pred N)).
-replace (S (pred N)) with N.
-ring.
-apply S_pred with 0%nat; assumption.
-apply lt_pred; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | assumption ].
-apply sum_eq; intros; apply Rmult_comm.
-apply S_pred with 0%nat; assumption.
-replace (N - pred N)%nat with 1%nat.
-reflexivity.
-pattern N at 1 in |- *; replace N with (S (pred N)).
-rewrite <- minus_Sn_m.
-rewrite <- minus_n_n; reflexivity.
-apply le_n.
-symmetry  in |- *; apply S_pred with 0%nat; assumption.
-apply sum_eq; intros;
- rewrite
-  (sum_N_predN (fun l:nat => An (S (S (l + i))) * Bn (N - l)%nat)
-     (pred (N - i))).
-replace (S (S (pred (N - i) + i))) with (S N).
-replace (N - pred (N - i))%nat with (S i).
-ring.
-rewrite pred_of_minus; apply INR_eq; repeat rewrite minus_INR.
-rewrite S_INR; ring.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-apply INR_le; rewrite minus_INR.
-apply Rplus_le_reg_l with (INR i - 1).
-replace (INR i - 1 + INR 1) with (INR i); [ idtac | ring ].
-replace (INR i - 1 + (INR N - INR i)) with (INR N - INR 1); [ idtac | ring ].
-rewrite <- minus_INR.
-apply le_INR; apply le_trans with (pred (pred N)).
-assumption.
-rewrite <- pred_of_minus; apply le_pred_n.
-apply le_trans with 2%nat.
-apply le_n_Sn.
-assumption.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-rewrite <- pred_of_minus.
-apply le_trans with (pred N).
-apply le_S_n.
-replace (S (pred N)) with N.
-replace (S (pred (N - i))) with (N - i)%nat.
-apply (fun p n m:nat => plus_le_reg_l n m p) with i; rewrite le_plus_minus_r.
-apply le_plus_r.
-apply le_trans with (pred (pred N));
- [ assumption | apply le_trans with (pred N); apply le_pred_n ].
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with i; rewrite le_plus_minus_r.
-replace (i + 0)%nat with i; [ idtac | ring ].
-apply le_lt_trans with (pred (pred N));
- [ assumption | apply lt_trans with (pred N); apply lt_pred_n_n ].
-apply lt_S_n.
-replace (S (pred N)) with N.
-apply lt_le_trans with 2%nat.
-apply lt_n_Sn.
-assumption.
-apply S_pred with 0%nat; assumption.
-assumption.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-apply S_pred with 0%nat; assumption.
-apply le_pred_n.
-apply INR_eq; rewrite pred_of_minus; do 3 rewrite S_INR; rewrite plus_INR;
- repeat rewrite minus_INR.
-ring.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-apply INR_le.
-rewrite minus_INR.
-apply Rplus_le_reg_l with (INR i - 1).
-replace (INR i - 1 + INR 1) with (INR i); [ idtac | ring ].
-replace (INR i - 1 + (INR N - INR i)) with (INR N - INR 1); [ idtac | ring ].
-rewrite <- minus_INR.
-apply le_INR.
-apply le_trans with (pred (pred N)).
-assumption.
-rewrite <- pred_of_minus.
-apply le_pred_n.
-apply le_trans with 2%nat.
-apply le_n_Sn.
-assumption.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-apply lt_le_trans with 1%nat.
-apply lt_O_Sn.
-apply INR_le.
-rewrite pred_of_minus.
-repeat rewrite minus_INR.
-apply Rplus_le_reg_l with (INR i - 1).
-replace (INR i - 1 + INR 1) with (INR i); [ idtac | ring ].
-replace (INR i - 1 + (INR N - INR i - INR 1)) with (INR N - INR 1 - INR 1).
-repeat rewrite <- minus_INR.
-apply le_INR.
-apply le_trans with (pred (pred N)).
-assumption.
-do 2 rewrite <- pred_of_minus.
-apply le_n.
-apply (fun p n m:nat => plus_le_reg_l n m p) with 1%nat.
-rewrite le_plus_minus_r.
-simpl in |- *; assumption.
-apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
-apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
-ring.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-apply (fun p n m:nat => plus_le_reg_l n m p) with i.
-rewrite le_plus_minus_r.
-replace (i + 1)%nat with (S i).
-replace N with (S (pred N)).
-apply le_n_S.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_pred_n.
-symmetry  in |- *; apply S_pred with 0%nat; assumption.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; reflexivity.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-apply lt_le_trans with 1%nat.
-apply lt_O_Sn.
-apply le_S_n.
-replace (S (pred N)) with N.
-assumption.
-apply S_pred with 0%nat; assumption.
-replace
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat)
-         (pred (S N - k))) (pred N)) with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (N - k)) + An (S k) * Bn (S N)) (pred N)).
-rewrite
- (sum_plus
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
-         (pred (N - k))) (fun k:nat => An (S k) * Bn (S N)))
- .
-apply Rplus_eq_compat_l.
-rewrite scal_sum; reflexivity.
-apply sum_eq; intros; rewrite Rplus_comm;
- rewrite
-  (decomp_sum (fun l:nat => An (S (l + i)) * Bn (S N - l)%nat)
-     (pred (S N - i))).
-replace (0 + i)%nat with i; [ idtac | ring ].
-rewrite <- minus_n_O; apply Rplus_eq_compat_l.
-replace (pred (pred (S N - i))) with (pred (N - i)).
-apply sum_eq; intros.
-replace (S N - S i0)%nat with (N - i0)%nat; [ idtac | reflexivity ].
-replace (S i0 + i)%nat with (S (i0 + i)).
-reflexivity.
-apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; ring.
-cut ((N - i)%nat = pred (S N - i)).
-intro; rewrite H5; reflexivity.
-rewrite pred_of_minus.
-apply INR_eq; repeat rewrite minus_INR.
-rewrite S_INR; ring.
-apply le_trans with N.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply (fun p n m:nat => plus_le_reg_l n m p) with i.
-rewrite le_plus_minus_r.
-replace (i + 1)%nat with (S i).
-apply le_n_S.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; ring.
-apply le_trans with N.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-replace (pred (S N - i)) with (S N - S i)%nat.
-replace (S N - S i)%nat with (N - i)%nat; [ idtac | reflexivity ].
-apply plus_lt_reg_l with i.
-rewrite le_plus_minus_r.
-replace (i + 0)%nat with i; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n.
-assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-rewrite pred_of_minus.
-apply INR_eq; repeat rewrite minus_INR.
-repeat rewrite S_INR; ring.
-apply le_trans with N.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply (fun p n m:nat => plus_le_reg_l n m p) with i.
-rewrite le_plus_minus_r.
-replace (i + 1)%nat with (S i).
-apply le_n_S.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; ring.
-apply le_trans with N.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply le_n_S.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-rewrite Rplus_comm.
-rewrite (decomp_sum (fun p:nat => An p * Bn (S N - p)%nat) N).
-rewrite <- minus_n_O.
-apply Rplus_eq_compat_l.
-apply sum_eq; intros.
-reflexivity.
-assumption.
-rewrite Rplus_comm.
-rewrite
- (decomp_sum
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k)))
-    (pred N)).
-rewrite <- minus_n_O.
-replace (sum_f_R0 (fun l:nat => An (S (l + 0)) * Bn (N - l)%nat) (pred N))
- with (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)).
-apply Rplus_eq_compat_l.
-apply sum_eq; intros.
-replace (pred (N - S i)) with (pred (pred (N - i))).
-apply sum_eq; intros.
-replace (i0 + S i)%nat with (S (i0 + i)).
-reflexivity.
-apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; ring.
-cut (pred (N - i) = (N - S i)%nat).
-intro; rewrite H5; reflexivity.
-rewrite pred_of_minus.
-apply INR_eq.
-repeat rewrite minus_INR.
-repeat rewrite S_INR; ring.
-apply le_trans with (S (pred (pred N))).
-apply le_n_S; assumption.
-replace (S (pred (pred N))) with (pred N).
-apply le_pred_n.
-apply S_pred with 0%nat.
-apply lt_S_n.
-replace (S (pred N)) with N.
-apply lt_le_trans with 2%nat.
-apply lt_n_Sn.
-assumption.
-apply S_pred with 0%nat; assumption.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-apply (fun p n m:nat => plus_le_reg_l n m p) with i.
-rewrite le_plus_minus_r.
-replace (i + 1)%nat with (S i).
-replace N with (S (pred N)).
-apply le_n_S.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_pred_n.
-symmetry  in |- *; apply S_pred with 0%nat; assumption.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; ring.
-apply le_trans with (pred (pred N)).
-assumption.
-apply le_trans with (pred N); apply le_pred_n.
-apply sum_eq; intros.
-replace (i + 0)%nat with i; [ reflexivity | trivial ].
-apply lt_S_n.
-replace (S (pred N)) with N.
-apply lt_le_trans with 2%nat; [ apply lt_n_Sn | assumption ].
-apply S_pred with 0%nat; assumption.
-inversion H1.
-left; reflexivity.
-right; apply le_n_S; assumption.
-simpl in |- *.
-replace (S (pred N)) with N.
-reflexivity.
-apply S_pred with 0%nat; assumption.
-simpl in |- *.
-cut ((N - pred N)%nat = 1%nat).
-intro; rewrite H2; reflexivity.
-rewrite pred_of_minus.
-apply INR_eq; repeat rewrite minus_INR.
-ring.
-apply lt_le_S; assumption.
-rewrite <- pred_of_minus; apply le_pred_n.
-simpl in |- *; symmetry  in |- *; apply S_pred with 0%nat; assumption.
-inversion H.
-left; reflexivity.
-right; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | exact H1 ].
-Qed.
\ No newline at end of file
+      sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat)
+      (pred (N - k))) (pred N). 
+Proof.
+  intros; induction  N as [| N HrecN].
+  elim (lt_irrefl _ H).
+  cut (N = 0%nat \/ (0 < N)%nat).
+  intro; elim H0; intro.
+  rewrite H1; simpl in |- *; ring.
+  replace (pred (S N)) with (S (pred N)).
+  do 5 rewrite tech5.
+  rewrite Rmult_plus_distr_r; rewrite Rmult_plus_distr_l; rewrite (HrecN H1).
+  repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+  replace (pred (S N - S (pred N))) with 0%nat.
+  rewrite Rmult_plus_distr_l;
+    replace
+      (sum_f_R0 (fun l:nat => An (S (l + S (pred N))) * Bn (S N - l)%nat) 0) with
+      (An (S N) * Bn (S N)).
+  repeat rewrite <- Rplus_assoc;
+    do 2 rewrite <- (Rplus_comm (An (S N) * Bn (S N)));
+      repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+  rewrite <- minus_n_n; cut (N = 1%nat \/ (2 <= N)%nat).
+  intro; elim H2; intro.
+  rewrite H3; simpl in |- *; ring.
+  replace
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k)))
+      (pred N)) with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (pred (N - k)))) (pred (pred N)) +
+      sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)).
+  replace (sum_f_R0 (fun p:nat => An p * Bn (S N - p)%nat) N) with
+    (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N) +
+      An 0%nat * Bn (S N)).
+  repeat rewrite <- Rplus_assoc;
+    rewrite <-
+      (Rplus_comm (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)))
+      ; repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+  replace
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat)
+        (pred (S N - k))) (pred N)) with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (N - k))) (pred N) +
+      Bn (S N) * sum_f_R0 (fun l:nat => An (S l)) (pred N)).
+  rewrite (decomp_sum An N H1); rewrite Rmult_plus_distr_r;
+    repeat rewrite <- Rplus_assoc; rewrite <- (Rplus_comm (An 0%nat * Bn (S N)));
+      repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+  repeat rewrite <- Rplus_assoc;
+    rewrite <-
+      (Rplus_comm (sum_f_R0 (fun i:nat => An (S i)) (pred N) * Bn (S N)))
+      ;
+      rewrite <-
+	(Rplus_comm (Bn (S N) * sum_f_R0 (fun i:nat => An (S i)) (pred N)))
+	; rewrite (Rmult_comm (Bn (S N))); repeat rewrite Rplus_assoc;
+	  apply Rplus_eq_compat_l.
+  replace
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (N - k))) (pred N)) with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (pred (N - k)))) (pred (pred N)) +
+      An (S N) * sum_f_R0 (fun l:nat => Bn (S l)) (pred N)).
+  rewrite (decomp_sum Bn N H1); rewrite Rmult_plus_distr_l.
+  set
+    (Z :=
+      sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (pred (N - k)))) (pred (pred N)));
+    set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); 
+      ring.
+  rewrite
+    (sum_N_predN
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (N - k))) (pred N)).
+  replace
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (N - k))) (pred (pred N))) with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (pred (N - k))) + An (S N) * Bn (S k)) (
+	  pred (pred N))).
+  rewrite
+    (sum_plus
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (pred (N - k)))) (fun k:nat => An (S N) * Bn (S k))
+      (pred (pred N))).
+  repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
+  replace (pred (N - pred N)) with 0%nat.
+  simpl in |- *; rewrite <- minus_n_O.
+  replace (S (pred N)) with N.
+  replace (sum_f_R0 (fun k:nat => An (S N) * Bn (S k)) (pred (pred N))) with
+    (sum_f_R0 (fun k:nat => Bn (S k) * An (S N)) (pred (pred N))).
+  rewrite <- (scal_sum (fun l:nat => Bn (S l)) (pred (pred N)) (An (S N)));
+    rewrite (sum_N_predN (fun l:nat => Bn (S l)) (pred N)).
+  replace (S (pred N)) with N.
+  ring.
+  apply S_pred with 0%nat; assumption.
+  apply lt_pred; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | assumption ].
+  apply sum_eq; intros; apply Rmult_comm.
+  apply S_pred with 0%nat; assumption.
+  replace (N - pred N)%nat with 1%nat.
+  reflexivity.
+  pattern N at 1 in |- *; replace N with (S (pred N)).
+  rewrite <- minus_Sn_m.
+  rewrite <- minus_n_n; reflexivity.
+  apply le_n.
+  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  apply sum_eq; intros;
+    rewrite
+      (sum_N_predN (fun l:nat => An (S (S (l + i))) * Bn (N - l)%nat)
+	(pred (N - i))).
+  replace (S (S (pred (N - i) + i))) with (S N).
+  replace (N - pred (N - i))%nat with (S i).
+  reflexivity.
+  rewrite pred_of_minus; apply INR_eq; repeat rewrite minus_INR.
+  rewrite S_INR; simpl; ring.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  apply INR_le; rewrite minus_INR.
+  apply Rplus_le_reg_l with (INR i - 1).
+  replace (INR i - 1 + INR 1) with (INR i); [ idtac | simpl; ring ].
+  replace (INR i - 1 + (INR N - INR i)) with (INR N - INR 1);
+    [ idtac | simpl; ring ].
+  rewrite <- minus_INR.
+  apply le_INR; apply le_trans with (pred (pred N)).
+  assumption.
+  rewrite <- pred_of_minus; apply le_pred_n.
+  apply le_trans with 2%nat.
+  apply le_n_Sn.
+  assumption.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  rewrite <- pred_of_minus.
+  apply le_trans with (pred N).
+  apply le_S_n.
+  replace (S (pred N)) with N.
+  replace (S (pred (N - i))) with (N - i)%nat.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with i; rewrite le_plus_minus_r.
+  apply le_plus_r.
+  apply le_trans with (pred (pred N));
+    [ assumption | apply le_trans with (pred N); apply le_pred_n ].
+  apply S_pred with 0%nat.
+  apply plus_lt_reg_l with i; rewrite le_plus_minus_r.
+  replace (i + 0)%nat with i; [ idtac | ring ].
+  apply le_lt_trans with (pred (pred N));
+    [ assumption | apply lt_trans with (pred N); apply lt_pred_n_n ].
+  apply lt_S_n.
+  replace (S (pred N)) with N.
+  apply lt_le_trans with 2%nat.
+  apply lt_n_Sn.
+  assumption.
+  apply S_pred with 0%nat; assumption.
+  assumption.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  apply S_pred with 0%nat; assumption.
+  apply le_pred_n.
+  apply INR_eq; rewrite pred_of_minus; do 3 rewrite S_INR; rewrite plus_INR;
+    repeat rewrite minus_INR.
+  simpl; ring.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  apply INR_le.
+  rewrite minus_INR.
+  apply Rplus_le_reg_l with (INR i - 1).
+  replace (INR i - 1 + INR 1) with (INR i); [ idtac | simpl; ring ].
+  replace (INR i - 1 + (INR N - INR i)) with (INR N - INR 1);
+    [ idtac | simpl; ring ].
+  rewrite <- minus_INR.
+  apply le_INR.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  rewrite <- pred_of_minus.
+  apply le_pred_n.
+  apply le_trans with 2%nat.
+  apply le_n_Sn.
+  assumption.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  apply lt_le_trans with 1%nat.
+  apply lt_O_Sn.
+  apply INR_le.
+  rewrite pred_of_minus.
+  repeat rewrite minus_INR.
+  apply Rplus_le_reg_l with (INR i - 1).
+  replace (INR i - 1 + INR 1) with (INR i); [ idtac | simpl; ring ].
+  replace (INR i - 1 + (INR N - INR i - INR 1)) with (INR N - INR 1 - INR 1).
+  repeat rewrite <- minus_INR.
+  apply le_INR.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  do 2 rewrite <- pred_of_minus.
+  apply le_n.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with 1%nat.
+  rewrite le_plus_minus_r.
+  simpl in |- *; assumption.
+  apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
+  apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
+  simpl; ring.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with i.
+  rewrite le_plus_minus_r.
+  replace (i + 1)%nat with (S i).
+  replace N with (S (pred N)).
+  apply le_n_S.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_pred_n.
+  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  apply INR_eq; rewrite S_INR; rewrite plus_INR; reflexivity.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  apply lt_le_trans with 1%nat.
+  apply lt_O_Sn.
+  apply le_S_n.
+  replace (S (pred N)) with N.
+  assumption.
+  apply S_pred with 0%nat; assumption.
+  replace
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (S N - l)%nat)
+        (pred (S N - k))) (pred N)) with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (N - k)) + An (S k) * Bn (S N)) (pred N)).
+  rewrite
+    (sum_plus
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat)
+        (pred (N - k))) (fun k:nat => An (S k) * Bn (S N))).
+  apply Rplus_eq_compat_l.
+  rewrite scal_sum; reflexivity.
+  apply sum_eq; intros; rewrite Rplus_comm;
+    rewrite
+      (decomp_sum (fun l:nat => An (S (l + i)) * Bn (S N - l)%nat)
+	(pred (S N - i))).
+  replace (0 + i)%nat with i; [ idtac | ring ].
+  rewrite <- minus_n_O; apply Rplus_eq_compat_l.
+  replace (pred (pred (S N - i))) with (pred (N - i)).
+  apply sum_eq; intros.
+  replace (S N - S i0)%nat with (N - i0)%nat; [ idtac | reflexivity ].
+  replace (S i0 + i)%nat with (S (i0 + i)).
+  reflexivity.
+  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; simpl; ring.
+  cut ((N - i)%nat = pred (S N - i)).
+  intro; rewrite H5; reflexivity.
+  rewrite pred_of_minus.
+  apply INR_eq; repeat rewrite minus_INR.
+  rewrite S_INR; simpl; ring.
+  apply le_trans with N.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  apply le_n_Sn.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with i.
+  rewrite le_plus_minus_r.
+  replace (i + 1)%nat with (S i).
+  apply le_n_S.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  apply INR_eq; rewrite S_INR; rewrite plus_INR; simpl; ring.
+  apply le_trans with N.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  apply le_n_Sn.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  replace (pred (S N - i)) with (S N - S i)%nat.
+  replace (S N - S i)%nat with (N - i)%nat; [ idtac | reflexivity ].
+  apply plus_lt_reg_l with i.
+  rewrite le_plus_minus_r.
+  replace (i + 0)%nat with i; [ idtac | ring ].
+  apply le_lt_trans with (pred N).
+  assumption.
+  apply lt_pred_n_n.
+  assumption.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  rewrite pred_of_minus.
+  apply INR_eq; repeat rewrite minus_INR.
+  repeat rewrite S_INR; simpl; ring.
+  apply le_trans with N.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  apply le_n_Sn.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with i.
+  rewrite le_plus_minus_r.
+  replace (i + 1)%nat with (S i).
+  apply le_n_S.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  apply INR_eq; rewrite S_INR; rewrite plus_INR; simpl; ring.
+  apply le_trans with N.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  apply le_n_Sn.
+  apply le_n_S.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  rewrite Rplus_comm.
+  rewrite (decomp_sum (fun p:nat => An p * Bn (S N - p)%nat) N).
+  rewrite <- minus_n_O.
+  apply Rplus_eq_compat_l.
+  apply sum_eq; intros.
+  reflexivity.
+  assumption.
+  rewrite Rplus_comm.
+  rewrite
+    (decomp_sum
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) (pred (N - k)))
+      (pred N)).
+  rewrite <- minus_n_O.
+  replace (sum_f_R0 (fun l:nat => An (S (l + 0)) * Bn (N - l)%nat) (pred N))
+    with (sum_f_R0 (fun l:nat => An (S l) * Bn (N - l)%nat) (pred N)).
+  apply Rplus_eq_compat_l.
+  apply sum_eq; intros.
+  replace (pred (N - S i)) with (pred (pred (N - i))).
+  apply sum_eq; intros.
+  replace (i0 + S i)%nat with (S (i0 + i)).
+  reflexivity.
+  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; simpl; ring.
+  cut (pred (N - i) = (N - S i)%nat).
+  intro; rewrite H5; reflexivity.
+  rewrite pred_of_minus.
+  apply INR_eq.
+  repeat rewrite minus_INR.
+  repeat rewrite S_INR; simpl; ring.
+  apply le_trans with (S (pred (pred N))).
+  apply le_n_S; assumption.
+  replace (S (pred (pred N))) with (pred N).
+  apply le_pred_n.
+  apply S_pred with 0%nat.
+  apply lt_S_n.
+  replace (S (pred N)) with N.
+  apply lt_le_trans with 2%nat.
+  apply lt_n_Sn.
+  assumption.
+  apply S_pred with 0%nat; assumption.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with i.
+  rewrite le_plus_minus_r.
+  replace (i + 1)%nat with (S i).
+  replace N with (S (pred N)).
+  apply le_n_S.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_pred_n.
+  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  apply INR_eq; rewrite S_INR; rewrite plus_INR; simpl; ring.
+  apply le_trans with (pred (pred N)).
+  assumption.
+  apply le_trans with (pred N); apply le_pred_n.
+  apply sum_eq; intros.
+  replace (i + 0)%nat with i; [ reflexivity | trivial ].
+  apply lt_S_n.
+  replace (S (pred N)) with N.
+  apply lt_le_trans with 2%nat; [ apply lt_n_Sn | assumption ].
+  apply S_pred with 0%nat; assumption.
+  inversion H1.
+  left; reflexivity.
+  right; apply le_n_S; assumption.
+  simpl in |- *.
+  replace (S (pred N)) with N.
+  reflexivity.
+  apply S_pred with 0%nat; assumption.
+  simpl in |- *.
+  cut ((N - pred N)%nat = 1%nat).
+  intro; rewrite H2; reflexivity.
+  rewrite pred_of_minus.
+  apply INR_eq; repeat rewrite minus_INR.
+  simpl; ring.
+  apply lt_le_S; assumption.
+  rewrite <- pred_of_minus; apply le_pred_n.
+  simpl in |- *; symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  inversion H.
+  left; reflexivity.
+  right; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | exact H1 ].
+Qed.
diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v
index 422eb4a4..10965951 100644
--- a/theories/Reals/Cos_plus.v
+++ b/theories/Reals/Cos_plus.v
@@ -1,12 +1,12 @@
-(************************************************************************)
-(*  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: Cos_plus.v,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+  (************************************************************************)
+  (*  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: Cos_plus.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -19,1043 +19,833 @@ Definition Majxy (x y:R) (n:nat) : R :=
   Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S n) / INR (fact n).
 
 Lemma Majxy_cv_R0 : forall x y:R, Un_cv (Majxy x y) 0.
-intros.
-set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
-set (C0 := C ^ 4).
-cut (0 < C).
-intro.
-cut (0 < C0).
-intro.
-assert (H1 := cv_speed_pow_fact C0).
-unfold Un_cv in H1; unfold R_dist in H1.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
-cut (0 < eps / C0);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; assumption ] ].
-elim (H1 (eps / C0) H3); intros N0 H4.
-exists N0; intros.
-replace (Majxy x y n) with (C0 ^ S n / INR (fact n)).
-simpl in |- *.
-apply Rmult_lt_reg_l with (Rabs (/ C0)).
-apply Rabs_pos_lt.
-apply Rinv_neq_0_compat.
-red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
-rewrite <- Rabs_mult.
-unfold Rminus in |- *; rewrite Rmult_plus_distr_l.
-rewrite Ropp_0; rewrite Rmult_0_r.
-unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-rewrite (Rabs_right (/ C0)).
-rewrite <- (Rmult_comm eps).
-replace (C0 ^ n * / INR (fact n) + 0) with (C0 ^ n * / INR (fact n) - 0);
- [ idtac | ring ].
-unfold Rdiv in H4; apply H4; assumption.
-apply Rle_ge; left; apply Rinv_0_lt_compat; assumption.
-red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
-unfold Majxy in |- *.
-unfold C0 in |- *.
-rewrite pow_mult.
-unfold C in |- *; reflexivity.
-unfold C0 in |- *; apply pow_lt; assumption.
-apply Rlt_le_trans with 1.
-apply Rlt_0_1.
-unfold C in |- *.
-apply RmaxLess1.
+Proof.
+  intros.
+  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
+  set (C0 := C ^ 4).
+  cut (0 < C).
+  intro.
+  cut (0 < C0).
+  intro.
+  assert (H1 := cv_speed_pow_fact C0).
+  unfold Un_cv in H1; unfold R_dist in H1.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  cut (0 < eps / C0);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+	[ assumption | apply Rinv_0_lt_compat; assumption ] ].
+  elim (H1 (eps / C0) H3); intros N0 H4.
+  exists N0; intros.
+  replace (Majxy x y n) with (C0 ^ S n / INR (fact n)).
+  simpl in |- *.
+  apply Rmult_lt_reg_l with (Rabs (/ C0)).
+  apply Rabs_pos_lt.
+  apply Rinv_neq_0_compat.
+  red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
+  rewrite <- Rabs_mult.
+  unfold Rminus in |- *; rewrite Rmult_plus_distr_l.
+  rewrite Ropp_0; rewrite Rmult_0_r.
+  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  rewrite (Rabs_right (/ C0)).
+  rewrite <- (Rmult_comm eps).
+  replace (C0 ^ n * / INR (fact n) + 0) with (C0 ^ n * / INR (fact n) - 0);
+    [ idtac | ring ].
+  unfold Rdiv in H4; apply H4; assumption.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; assumption.
+  red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
+  unfold Majxy in |- *.
+  unfold C0 in |- *.
+  rewrite pow_mult.
+  unfold C in |- *; reflexivity.
+  unfold C0 in |- *; apply pow_lt; assumption.
+  apply Rlt_le_trans with 1.
+  apply Rlt_0_1.
+  unfold C in |- *.
+  apply RmaxLess1.
 Qed.
 
 Lemma reste1_maj :
- forall (x y:R) (N:nat),
-   (0 < N)%nat -> Rabs (Reste1 x y N) <= Majxy x y (pred N).
-intros.
-set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
-unfold Reste1 in |- *.
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       Rabs
-         (sum_f_R0
-            (fun l:nat =>
-               (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
-               x ^ (2 * S (l + k)) *
-               ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
-               y ^ (2 * (N - l))) (pred (N - k)))) (
-    pred N)).
-apply
- (Rsum_abs
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
+  forall (x y:R) (N:nat),
+    (0 < N)%nat -> Rabs (Reste1 x y N) <= Majxy x y (pred N).
+Proof.
+  intros.
+  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
+  unfold Reste1 in |- *.
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	Rabs
+        (sum_f_R0
+          (fun l:nat =>
             (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
-            x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
-            y ^ (2 * (N - l))) (pred (N - k))) (pred N)).
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            Rabs
-              ((-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
-               x ^ (2 * S (l + k)) *
-               ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
-               y ^ (2 * (N - l)))) (pred (N - k))) (
-    pred N)).
-apply sum_Rle.
-intros.
-apply
- (Rsum_abs
-    (fun l:nat =>
-       (-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) *
-       ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * 
-       y ^ (2 * (N - l))) (pred (N - n))).
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) *
-            C ^ (2 * S (N + k))) (pred (N - k))) (pred N)).
-apply sum_Rle; intros.
-apply sum_Rle; intros.
-unfold Rdiv in |- *; repeat rewrite Rabs_mult.
-do 2 rewrite pow_1_abs.
-do 2 rewrite Rmult_1_l.
-rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n))))).
-rewrite (Rabs_right (/ INR (fact (2 * (N - n0))))).
-rewrite mult_INR.
-rewrite Rinv_mult_distr.
-repeat rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-rewrite <- Rmult_assoc.
-rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0))))).
-rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-do 2 rewrite <- RPow_abs.
-apply Rle_trans with (Rabs x ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
-apply Rmult_le_compat_l.
-apply pow_le; apply Rabs_pos.
-apply pow_incr.
-split.
-apply Rabs_pos.
-unfold C in |- *.
-apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
-apply Rle_trans with (C ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
-do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0)))).
-apply Rmult_le_compat_l.
-apply pow_le.
-apply Rle_trans with 1.
-left; apply Rlt_0_1.
-unfold C in |- *; apply RmaxLess1.
-apply pow_incr.
-split.
-apply Rabs_pos.
-unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
-apply RmaxLess1.
-apply RmaxLess2.
-right.
-replace (2 * S (N + n))%nat with (2 * (N - n0) + 2 * S (n0 + n))%nat.
-rewrite pow_add.
-apply Rmult_comm.
-apply INR_eq; rewrite plus_INR; do 3 rewrite mult_INR.
-rewrite minus_INR.
-repeat rewrite S_INR; do 2 rewrite plus_INR; ring.
-apply le_trans with (pred (N - n)).
-exact H1.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) * C ^ (4 * N))
-         (pred (N - k))) (pred N)).
-apply sum_Rle; intros.
-apply sum_Rle; intros.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat.
-rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
-apply Rle_pow.
-unfold C in |- *; apply RmaxLess1.
-replace (4 * N)%nat with (2 * (2 * N))%nat; [ idtac | ring ].
-apply (fun m n p:nat => mult_le_compat_l p n m).
-replace (2 * N)%nat with (S (N + pred N)).
-apply le_n_S.
-apply plus_le_compat_l; assumption.
-rewrite pred_of_minus.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
- rewrite minus_INR.
-repeat rewrite S_INR; ring.
-apply lt_le_S; assumption.
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => C ^ (4 * N) * Rsqr (/ INR (fact (S (N + k)))))
-         (pred (N - k))) (pred N)).
-apply sum_Rle; intros.
-apply sum_Rle; intros.
-rewrite <- (Rmult_comm (C ^ (4 * N))).
-apply Rmult_le_compat_l.
-apply pow_le.
-left; apply Rlt_le_trans with 1.
-apply Rlt_0_1.
-unfold C in |- *; apply RmaxLess1.
-replace (/ INR (fact (2 * S (n0 + n)) * fact (2 * (N - n0)))) with
- (Binomial.C (2 * S (N + n)) (2 * S (n0 + n)) / INR (fact (2 * S (N + n)))).
-apply Rle_trans with
- (Binomial.C (2 * S (N + n)) (S (N + n)) / INR (fact (2 * S (N + n)))).
-unfold Rdiv in |- *;
- do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (N + n))))).
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply C_maj.
-apply (fun m n p:nat => mult_le_compat_l p n m).
-apply le_n_S.
-apply plus_le_compat_r.
-apply le_trans with (pred (N - n)).
-assumption.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-right.
-unfold Rdiv in |- *; rewrite Rmult_comm.
-unfold Binomial.C in |- *.
-unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-replace (2 * S (N + n) - S (N + n))%nat with (S (N + n)).
-rewrite Rinv_mult_distr.
-unfold Rsqr in |- *; reflexivity.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_eq; rewrite S_INR; rewrite minus_INR.
-rewrite mult_INR; repeat rewrite S_INR; rewrite plus_INR; ring.
-apply le_n_2n.
-apply INR_fact_neq_0.
-unfold Rdiv in |- *; rewrite Rmult_comm.
-unfold Binomial.C in |- *.
-unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat.
-rewrite mult_INR.
-reflexivity.
-apply INR_eq; rewrite minus_INR.
-do 3 rewrite mult_INR; repeat rewrite S_INR; do 2 rewrite plus_INR;
- rewrite minus_INR.
-ring.
-apply le_trans with (pred (N - n)).
-assumption.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply (fun m n p:nat => mult_le_compat_l p n m).
-apply le_n_S.
-apply plus_le_compat_r.
-apply le_trans with (pred (N - n)).
-assumption.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply INR_fact_neq_0.
-apply Rle_trans with
- (sum_f_R0 (fun k:nat => INR N / INR (fact (S N)) * C ^ (4 * N)) (pred N)).
-apply sum_Rle; intros.
-rewrite <-
- (scal_sum (fun _:nat => C ^ (4 * N)) (pred (N - n))
-    (Rsqr (/ INR (fact (S (N + n)))))).
-rewrite sum_cte.
-rewrite <- Rmult_assoc.
-do 2 rewrite <- (Rmult_comm (C ^ (4 * N))).
-rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-apply pow_le.
-left; apply Rlt_le_trans with 1.
-apply Rlt_0_1.
-unfold C in |- *; apply RmaxLess1.
-apply Rle_trans with (Rsqr (/ INR (fact (S (N + n)))) * INR N).
-apply Rmult_le_compat_l.
-apply Rle_0_sqr.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_INR.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
-apply pos_INR.
-apply Rle_trans with (/ INR (fact (S (N + n)))).
-pattern (/ INR (fact (S (N + n)))) at 2 in |- *; rewrite <- Rmult_1_r.
-unfold Rsqr in |- *.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
-apply INR_fact_lt_0.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r.
-replace 1 with (INR 1).
-apply le_INR.
-apply lt_le_S.
-apply INR_lt; apply INR_fact_lt_0.
-reflexivity.
-apply INR_fact_neq_0.
-apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
-apply INR_fact_lt_0.
-rewrite <- Rinv_r_sym.
-apply Rmult_le_reg_l with (INR (fact (S N))).
-apply INR_fact_lt_0.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm (INR (fact (S N)))).
-rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-apply le_INR.
-apply fact_le.
-apply le_n_S.
-apply le_plus_l.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-rewrite sum_cte.
-apply Rle_trans with (C ^ (4 * N) / INR (fact (pred N))).
-rewrite <- (Rmult_comm (C ^ (4 * N))).
-unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
-apply pow_le.
-left; apply Rlt_le_trans with 1.
-apply Rlt_0_1.
-unfold C in |- *; apply RmaxLess1.
-cut (S (pred N) = N).
-intro; rewrite H0.
-pattern N at 2 in |- *; rewrite <- H0.
-do 2 rewrite fact_simpl.
-rewrite H0.
-repeat rewrite mult_INR.
-repeat rewrite Rinv_mult_distr.
-rewrite (Rmult_comm (/ INR (S N))).
-repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l.
-pattern (/ INR (fact (pred N))) at 2 in |- *; rewrite <- Rmult_1_r.
-rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rmult_le_reg_l with (INR (S N)).
-apply lt_INR_0; apply lt_O_Sn.
-rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; rewrite Rmult_1_l.
-apply le_INR; apply le_n_Sn.
-apply not_O_INR; discriminate.
-apply not_O_INR.
-red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
-apply not_O_INR.
-red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
-apply INR_fact_neq_0.
-apply not_O_INR; discriminate.
-apply prod_neq_R0.
-apply not_O_INR.
-red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
-apply INR_fact_neq_0.
-symmetry  in |- *; apply S_pred with 0%nat; assumption.
-right.
-unfold Majxy in |- *.
-unfold C in |- *.
-replace (S (pred N)) with N.
-reflexivity.
-apply S_pred with 0%nat; assumption.
+            x ^ (2 * S (l + k)) *
+            ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
+            y ^ (2 * (N - l))) (pred (N - k)))) (
+	      pred N)).
+  apply
+    (Rsum_abs
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat =>
+          (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
+          x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
+          y ^ (2 * (N - l))) (pred (N - k))) (pred N)).
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat =>
+          Rabs
+          ((-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
+            x ^ (2 * S (l + k)) *
+            ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
+            y ^ (2 * (N - l)))) (pred (N - k))) (
+	      pred N)).
+  apply sum_Rle.
+  intros.
+  apply
+    (Rsum_abs
+      (fun l:nat =>
+	(-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) *
+	((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * 
+	y ^ (2 * (N - l))) (pred (N - n))).
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat =>
+          / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) *
+          C ^ (2 * S (N + k))) (pred (N - k))) (pred N)).
+  apply sum_Rle; intros.
+  apply sum_Rle; intros.
+  unfold Rdiv in |- *; repeat rewrite Rabs_mult.
+  do 2 rewrite pow_1_abs.
+  do 2 rewrite Rmult_1_l.
+  rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n))))).
+  rewrite (Rabs_right (/ INR (fact (2 * (N - n0))))).
+  rewrite mult_INR.
+  rewrite Rinv_mult_distr.
+  repeat rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  rewrite <- Rmult_assoc.
+  rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0))))).
+  rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  do 2 rewrite <- RPow_abs.
+  apply Rle_trans with (Rabs x ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
+  apply Rmult_le_compat_l.
+  apply pow_le; apply Rabs_pos.
+  apply pow_incr.
+  split.
+  apply Rabs_pos.
+  unfold C in |- *.
+  apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
+  apply Rle_trans with (C ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
+  do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0)))).
+  apply Rmult_le_compat_l.
+  apply pow_le.
+  apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  unfold C in |- *; apply RmaxLess1.
+  apply pow_incr.
+  split.
+  apply Rabs_pos.
+  unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+  apply RmaxLess1.
+  apply RmaxLess2.
+  right.
+  replace (2 * S (N + n))%nat with (2 * (N - n0) + 2 * S (n0 + n))%nat.
+  rewrite pow_add.
+  apply Rmult_comm.
+  apply INR_eq; rewrite plus_INR; do 3 rewrite mult_INR.
+  rewrite minus_INR.
+  repeat rewrite S_INR; do 2 rewrite plus_INR; ring.
+  apply le_trans with (pred (N - n)).
+  exact H1.
+  apply le_S_n.
+  replace (S (pred (N - n))) with (N - n)%nat.
+  apply le_trans with N.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+  rewrite <- le_plus_minus.
+  apply le_plus_r.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  apply le_n_Sn.
+  apply S_pred with 0%nat.
+  apply plus_lt_reg_l with n.
+  rewrite <- le_plus_minus.
+  replace (n + 0)%nat with n; [ idtac | ring ].
+  apply le_lt_trans with (pred N).
+  assumption.
+  apply lt_pred_n_n; assumption.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat =>
+          / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) * C ^ (4 * N))
+        (pred (N - k))) (pred N)).
+  apply sum_Rle; intros.
+  apply sum_Rle; intros.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat.
+  rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
+  apply Rle_pow.
+  unfold C in |- *; apply RmaxLess1.
+  replace (4 * N)%nat with (2 * (2 * N))%nat; [ idtac | ring ].
+  apply (fun m n p:nat => mult_le_compat_l p n m).
+  replace (2 * N)%nat with (S (N + pred N)).
+  apply le_n_S.
+  apply plus_le_compat_l; assumption.
+  rewrite pred_of_minus.
+  omega.
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0 (fun l:nat => C ^ (4 * N) * Rsqr (/ INR (fact (S (N + k)))))
+        (pred (N - k))) (pred N)).
+  apply sum_Rle; intros.
+  apply sum_Rle; intros.
+  rewrite <- (Rmult_comm (C ^ (4 * N))).
+  apply Rmult_le_compat_l.
+  apply pow_le.
+  left; apply Rlt_le_trans with 1.
+  apply Rlt_0_1.
+  unfold C in |- *; apply RmaxLess1.
+  replace (/ INR (fact (2 * S (n0 + n)) * fact (2 * (N - n0)))) with
+    (Binomial.C (2 * S (N + n)) (2 * S (n0 + n)) / INR (fact (2 * S (N + n)))).
+  apply Rle_trans with
+    (Binomial.C (2 * S (N + n)) (S (N + n)) / INR (fact (2 * S (N + n)))).
+  unfold Rdiv in |- *;
+    do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (N + n))))).
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply C_maj.
+  omega.
+  right.
+  unfold Rdiv in |- *; rewrite Rmult_comm.
+  unfold Binomial.C in |- *.
+  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  replace (2 * S (N + n) - S (N + n))%nat with (S (N + n)).
+  rewrite Rinv_mult_distr.
+  unfold Rsqr in |- *; reflexivity.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  omega.
+  apply INR_fact_neq_0.
+  unfold Rdiv in |- *; rewrite Rmult_comm.
+  unfold Binomial.C in |- *.
+  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat.
+  rewrite mult_INR.
+  reflexivity.
+  omega.
+  apply INR_fact_neq_0.
+  apply Rle_trans with
+    (sum_f_R0 (fun k:nat => INR N / INR (fact (S N)) * C ^ (4 * N)) (pred N)).
+  apply sum_Rle; intros.
+  rewrite <-
+    (scal_sum (fun _:nat => C ^ (4 * N)) (pred (N - n))
+      (Rsqr (/ INR (fact (S (N + n)))))).
+  rewrite sum_cte.
+  rewrite <- Rmult_assoc.
+  do 2 rewrite <- (Rmult_comm (C ^ (4 * N))).
+  rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  apply pow_le.
+  left; apply Rlt_le_trans with 1.
+  apply Rlt_0_1.
+  unfold C in |- *; apply RmaxLess1.
+  apply Rle_trans with (Rsqr (/ INR (fact (S (N + n)))) * INR N).
+  apply Rmult_le_compat_l.
+  apply Rle_0_sqr.
+  apply le_INR.
+  omega.
+  rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+  apply pos_INR.
+  apply Rle_trans with (/ INR (fact (S (N + n)))).
+  pattern (/ INR (fact (S (N + n)))) at 2 in |- *; rewrite <- Rmult_1_r.
+  unfold Rsqr in |- *.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
+  apply INR_fact_lt_0.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r.
+  replace 1 with (INR 1).
+  apply le_INR.
+  apply lt_le_S.
+  apply INR_lt; apply INR_fact_lt_0.
+  reflexivity.
+  apply INR_fact_neq_0.
+  apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
+  apply INR_fact_lt_0.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_le_reg_l with (INR (fact (S N))).
+  apply INR_fact_lt_0.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm (INR (fact (S N)))).
+  rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  apply le_INR.
+  apply fact_le.
+  apply le_n_S.
+  apply le_plus_l.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  rewrite sum_cte.
+  apply Rle_trans with (C ^ (4 * N) / INR (fact (pred N))).
+  rewrite <- (Rmult_comm (C ^ (4 * N))).
+  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  apply pow_le.
+  left; apply Rlt_le_trans with 1.
+  apply Rlt_0_1.
+  unfold C in |- *; apply RmaxLess1.
+  cut (S (pred N) = N).
+  intro; rewrite H0.
+  pattern N at 2 in |- *; rewrite <- H0.
+  do 2 rewrite fact_simpl.
+  rewrite H0.
+  repeat rewrite mult_INR.
+  repeat rewrite Rinv_mult_distr.
+  rewrite (Rmult_comm (/ INR (S N))).
+  repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l.
+  pattern (/ INR (fact (pred N))) at 2 in |- *; rewrite <- Rmult_1_r.
+  rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rmult_le_reg_l with (INR (S N)).
+  apply lt_INR_0; apply lt_O_Sn.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; rewrite Rmult_1_l.
+  apply le_INR; apply le_n_Sn.
+  apply not_O_INR; discriminate.
+  apply not_O_INR.
+  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+  apply not_O_INR.
+  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+  apply INR_fact_neq_0.
+  apply not_O_INR; discriminate.
+  apply prod_neq_R0.
+  apply not_O_INR.
+  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+  apply INR_fact_neq_0.
+  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  right.
+  unfold Majxy in |- *.
+  unfold C in |- *.
+  replace (S (pred N)) with N.
+  reflexivity.
+  apply S_pred with 0%nat; assumption.
 Qed.
 
 Lemma reste2_maj :
- forall (x y:R) (N:nat), (0 < N)%nat -> Rabs (Reste2 x y N) <= Majxy x y N.
-intros.
-set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
-unfold Reste2 in |- *.
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       Rabs
-         (sum_f_R0
-            (fun l:nat =>
-               (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
-               x ^ (2 * S (l + k) + 1) *
-               ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
-               y ^ (2 * (N - l) + 1)) (pred (N - k)))) (
-    pred N)).
-apply
- (Rsum_abs
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
+  forall (x y:R) (N:nat), (0 < N)%nat -> Rabs (Reste2 x y N) <= Majxy x y N.
+Proof.
+  intros.
+  set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
+  unfold Reste2 in |- *.
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	Rabs
+        (sum_f_R0
+          (fun l:nat =>
             (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
             x ^ (2 * S (l + k) + 1) *
             ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
-            y ^ (2 * (N - l) + 1)) (pred (N - k))) (
-    pred N)).
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            Rabs
-              ((-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
-               x ^ (2 * S (l + k) + 1) *
-               ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
-               y ^ (2 * (N - l) + 1))) (pred (N - k))) (
-    pred N)).
-apply sum_Rle.
-intros.
-apply
- (Rsum_abs
-    (fun l:nat =>
-       (-1) ^ S (l + n) / INR (fact (2 * S (l + n) + 1)) *
-       x ^ (2 * S (l + n) + 1) *
-       ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
-       y ^ (2 * (N - l) + 1)) (pred (N - n))).
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
-            C ^ (2 * S (S (N + k)))) (pred (N - k))) (
-    pred N)).
-apply sum_Rle; intros.
-apply sum_Rle; intros.
-unfold Rdiv in |- *; repeat rewrite Rabs_mult.
-do 2 rewrite pow_1_abs.
-do 2 rewrite Rmult_1_l.
-rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n) + 1)))).
-rewrite (Rabs_right (/ INR (fact (2 * (N - n0) + 1)))).
-rewrite mult_INR.
-rewrite Rinv_mult_distr.
-repeat rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-rewrite <- Rmult_assoc.
-rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0) + 1)))).
-rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-do 2 rewrite <- RPow_abs.
-apply Rle_trans with (Rabs x ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
-apply Rmult_le_compat_l.
-apply pow_le; apply Rabs_pos.
-apply pow_incr.
-split.
-apply Rabs_pos.
-unfold C in |- *.
-apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
-apply Rle_trans with (C ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
-do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0) + 1))).
-apply Rmult_le_compat_l.
-apply pow_le.
-apply Rle_trans with 1.
-left; apply Rlt_0_1.
-unfold C in |- *; apply RmaxLess1.
-apply pow_incr.
-split.
-apply Rabs_pos.
-unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
-apply RmaxLess1.
-apply RmaxLess2.
-right.
-replace (2 * S (S (N + n)))%nat with
- (2 * (N - n0) + 1 + (2 * S (n0 + n) + 1))%nat.
-repeat rewrite pow_add.
-ring.
-apply INR_eq; repeat rewrite plus_INR; do 3 rewrite mult_INR.
-rewrite minus_INR.
-repeat rewrite S_INR; do 2 rewrite plus_INR; ring.
-apply le_trans with (pred (N - n)).
-exact H1.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply Rle_ge; left; apply Rinv_0_lt_compat.
-apply INR_fact_lt_0.
-apply Rle_ge; left; apply Rinv_0_lt_compat.
-apply INR_fact_lt_0.
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
-            C ^ (4 * S N)) (pred (N - k))) (pred N)).
-apply sum_Rle; intros.
-apply sum_Rle; intros.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat.
-rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
-apply Rle_pow.
-unfold C in |- *; apply RmaxLess1.
-replace (4 * S N)%nat with (2 * (2 * S N))%nat; [ idtac | ring ].
-apply (fun m n p:nat => mult_le_compat_l p n m).
-replace (2 * S N)%nat with (S (S (N + N))).
-repeat apply le_n_S.
-apply plus_le_compat_l.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply INR_eq; do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR.
-repeat rewrite S_INR; ring.
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat => C ^ (4 * S N) * Rsqr (/ INR (fact (S (S (N + k))))))
-         (pred (N - k))) (pred N)).
-apply sum_Rle; intros.
-apply sum_Rle; intros.
-rewrite <- (Rmult_comm (C ^ (4 * S N))).
-apply Rmult_le_compat_l.
-apply pow_le.
-left; apply Rlt_le_trans with 1.
-apply Rlt_0_1.
-unfold C in |- *; apply RmaxLess1.
-replace (/ INR (fact (2 * S (n0 + n) + 1) * fact (2 * (N - n0) + 1))) with
- (Binomial.C (2 * S (S (N + n))) (2 * S (n0 + n) + 1) /
-  INR (fact (2 * S (S (N + n))))).
-apply Rle_trans with
- (Binomial.C (2 * S (S (N + n))) (S (S (N + n))) /
-  INR (fact (2 * S (S (N + n))))).
-unfold Rdiv in |- *;
- do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (S (N + n)))))).
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply C_maj.
-apply le_trans with (2 * S (S (n0 + n)))%nat.
-replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)).
-apply le_n_Sn.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite mult_INR;
- repeat rewrite S_INR; rewrite plus_INR; ring.
-apply (fun m n p:nat => mult_le_compat_l p n m).
-repeat apply le_n_S.
-apply plus_le_compat_r.
-apply le_trans with (pred (N - n)).
-assumption.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-right.
-unfold Rdiv in |- *; rewrite Rmult_comm.
-unfold Binomial.C in |- *.
-unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-replace (2 * S (S (N + n)) - S (S (N + n)))%nat with (S (S (N + n))).
-rewrite Rinv_mult_distr.
-unfold Rsqr in |- *; reflexivity.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_eq; do 2 rewrite S_INR; rewrite minus_INR.
-rewrite mult_INR; repeat rewrite S_INR; rewrite plus_INR; ring.
-apply le_n_2n.
-apply INR_fact_neq_0.
-unfold Rdiv in |- *; rewrite Rmult_comm.
-unfold Binomial.C in |- *.
-unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-replace (2 * S (S (N + n)) - (2 * S (n0 + n) + 1))%nat with
- (2 * (N - n0) + 1)%nat.
-rewrite mult_INR.
-reflexivity.
-apply INR_eq; rewrite minus_INR.
-do 2 rewrite plus_INR; do 3 rewrite mult_INR; repeat rewrite S_INR;
- do 2 rewrite plus_INR; rewrite minus_INR.
-ring.
-apply le_trans with (pred (N - n)).
-assumption.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_trans with (2 * S (S (n0 + n)))%nat.
-replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)).
-apply le_n_Sn.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite mult_INR;
- repeat rewrite S_INR; rewrite plus_INR; ring.
-apply (fun m n p:nat => mult_le_compat_l p n m).
-repeat apply le_n_S.
-apply plus_le_compat_r.
-apply le_trans with (pred (N - n)).
-assumption.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply INR_fact_neq_0.
-apply Rle_trans with
- (sum_f_R0 (fun k:nat => INR N / INR (fact (S (S N))) * C ^ (4 * S N))
-    (pred N)).
-apply sum_Rle; intros.
-rewrite <-
- (scal_sum (fun _:nat => C ^ (4 * S N)) (pred (N - n))
-    (Rsqr (/ INR (fact (S (S (N + n))))))).
-rewrite sum_cte.
-rewrite <- Rmult_assoc.
-do 2 rewrite <- (Rmult_comm (C ^ (4 * S N))).
-rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-apply pow_le.
-left; apply Rlt_le_trans with 1.
-apply Rlt_0_1.
-unfold C in |- *; apply RmaxLess1.
-apply Rle_trans with (Rsqr (/ INR (fact (S (S (N + n))))) * INR N).
-apply Rmult_le_compat_l.
-apply Rle_0_sqr.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_INR.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-assumption.
-apply lt_pred_n_n; assumption.
-apply le_trans with (pred N).
-assumption.
-apply le_pred_n.
-rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
-apply pos_INR.
-apply Rle_trans with (/ INR (fact (S (S (N + n))))).
-pattern (/ INR (fact (S (S (N + n))))) at 2 in |- *; rewrite <- Rmult_1_r.
-unfold Rsqr in |- *.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
-apply INR_fact_lt_0.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r.
-replace 1 with (INR 1).
-apply le_INR.
-apply lt_le_S.
-apply INR_lt; apply INR_fact_lt_0.
-reflexivity.
-apply INR_fact_neq_0.
-apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
-apply INR_fact_lt_0.
-rewrite <- Rinv_r_sym.
-apply Rmult_le_reg_l with (INR (fact (S (S N)))).
-apply INR_fact_lt_0.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm (INR (fact (S (S N))))).
-rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-apply le_INR.
-apply fact_le.
-repeat apply le_n_S.
-apply le_plus_l.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-rewrite sum_cte.
-apply Rle_trans with (C ^ (4 * S N) / INR (fact N)).
-rewrite <- (Rmult_comm (C ^ (4 * S N))).
-unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
-apply pow_le.
-left; apply Rlt_le_trans with 1.
-apply Rlt_0_1.
-unfold C in |- *; apply RmaxLess1.
-cut (S (pred N) = N).
-intro; rewrite H0.
-do 2 rewrite fact_simpl.
-repeat rewrite mult_INR.
-repeat rewrite Rinv_mult_distr.
-apply Rle_trans with
- (INR (S (S N)) * (/ INR (S (S N)) * (/ INR (S N) * / INR (fact N))) * INR N).
-repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm (INR N)).
-rewrite (Rmult_comm (INR (S (S N)))).
-apply Rmult_le_compat_l.
-repeat apply Rmult_le_pos.
-left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
-left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
-left; apply Rinv_0_lt_compat.
-apply INR_fact_lt_0.
-apply pos_INR.
-apply le_INR.
-apply le_trans with (S N); apply le_n_Sn.
-repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l.
-apply Rle_trans with (/ INR (S N) * / INR (fact N) * INR (S N)).
-repeat rewrite Rmult_assoc.
-repeat apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply le_INR; apply le_n_Sn.
-rewrite (Rmult_comm (/ INR (S N))).
-rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; right; reflexivity.
-apply not_O_INR; discriminate.
-apply not_O_INR; discriminate.
-apply not_O_INR; discriminate.
-apply INR_fact_neq_0.
-apply not_O_INR; discriminate.
-apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
-symmetry  in |- *; apply S_pred with 0%nat; assumption.
-right.
-unfold Majxy in |- *.
-unfold C in |- *.
-reflexivity.
+            y ^ (2 * (N - l) + 1)) (pred (N - k)))) (
+	      pred N)).
+  apply
+    (Rsum_abs
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat =>
+          (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
+          x ^ (2 * S (l + k) + 1) *
+          ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
+          y ^ (2 * (N - l) + 1)) (pred (N - k))) (
+	    pred N)).
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat =>
+          Rabs
+          ((-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
+            x ^ (2 * S (l + k) + 1) *
+            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
+            y ^ (2 * (N - l) + 1))) (pred (N - k))) (
+	      pred N)).
+  apply sum_Rle.
+  intros.
+  apply
+    (Rsum_abs
+      (fun l:nat =>
+	(-1) ^ S (l + n) / INR (fact (2 * S (l + n) + 1)) *
+	x ^ (2 * S (l + n) + 1) *
+	((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
+	y ^ (2 * (N - l) + 1)) (pred (N - n))).
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat =>
+          / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
+          C ^ (2 * S (S (N + k)))) (pred (N - k))) (
+	    pred N)).
+  apply sum_Rle; intros.
+  apply sum_Rle; intros.
+  unfold Rdiv in |- *; repeat rewrite Rabs_mult.
+  do 2 rewrite pow_1_abs.
+  do 2 rewrite Rmult_1_l.
+  rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n) + 1)))).
+  rewrite (Rabs_right (/ INR (fact (2 * (N - n0) + 1)))).
+  rewrite mult_INR.
+  rewrite Rinv_mult_distr.
+  repeat rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  rewrite <- Rmult_assoc.
+  rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0) + 1)))).
+  rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  do 2 rewrite <- RPow_abs.
+  apply Rle_trans with (Rabs x ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
+  apply Rmult_le_compat_l.
+  apply pow_le; apply Rabs_pos.
+  apply pow_incr.
+  split.
+  apply Rabs_pos.
+  unfold C in |- *.
+  apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
+  apply Rle_trans with (C ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
+  do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0) + 1))).
+  apply Rmult_le_compat_l.
+  apply pow_le.
+  apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  unfold C in |- *; apply RmaxLess1.
+  apply pow_incr.
+  split.
+  apply Rabs_pos.
+  unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+  apply RmaxLess1.
+  apply RmaxLess2.
+  right.
+  replace (2 * S (S (N + n)))%nat with
+    (2 * (N - n0) + 1 + (2 * S (n0 + n) + 1))%nat.
+  repeat rewrite pow_add.
+  ring.
+  omega.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply Rle_ge; left; apply Rinv_0_lt_compat.
+  apply INR_fact_lt_0.
+  apply Rle_ge; left; apply Rinv_0_lt_compat.
+  apply INR_fact_lt_0.
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat =>
+          / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
+          C ^ (4 * S N)) (pred (N - k))) (pred N)).
+  apply sum_Rle; intros.
+  apply sum_Rle; intros.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat.
+  rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
+  apply Rle_pow.
+  unfold C in |- *; apply RmaxLess1.
+  replace (4 * S N)%nat with (2 * (2 * S N))%nat; [ idtac | ring ].
+  apply (fun m n p:nat => mult_le_compat_l p n m).
+  replace (2 * S N)%nat with (S (S (N + N))).
+  repeat apply le_n_S.
+  apply plus_le_compat_l.
+  apply le_trans with (pred N).
+  assumption.
+  apply le_pred_n.
+  ring.
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+	sum_f_R0
+        (fun l:nat => C ^ (4 * S N) * Rsqr (/ INR (fact (S (S (N + k))))))
+        (pred (N - k))) (pred N)).
+  apply sum_Rle; intros.
+  apply sum_Rle; intros.
+  rewrite <- (Rmult_comm (C ^ (4 * S N))).
+  apply Rmult_le_compat_l.
+  apply pow_le.
+  left; apply Rlt_le_trans with 1.
+  apply Rlt_0_1.
+  unfold C in |- *; apply RmaxLess1.
+  replace (/ INR (fact (2 * S (n0 + n) + 1) * fact (2 * (N - n0) + 1))) with
+    (Binomial.C (2 * S (S (N + n))) (2 * S (n0 + n) + 1) /
+      INR (fact (2 * S (S (N + n))))).
+  apply Rle_trans with
+    (Binomial.C (2 * S (S (N + n))) (S (S (N + n))) /
+      INR (fact (2 * S (S (N + n))))).
+  unfold Rdiv in |- *;
+    do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (S (N + n)))))).
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply C_maj.
+  apply le_trans with (2 * S (S (n0 + n)))%nat.
+  replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)).
+  apply le_n_Sn.
+  ring.
+  omega.
+  right.
+  unfold Rdiv in |- *; rewrite Rmult_comm.
+  unfold Binomial.C in |- *.
+  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  replace (2 * S (S (N + n)) - S (S (N + n)))%nat with (S (S (N + n))).
+  rewrite Rinv_mult_distr.
+  unfold Rsqr in |- *; reflexivity.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  omega.
+  apply INR_fact_neq_0.
+  unfold Rdiv in |- *; rewrite Rmult_comm.
+  unfold Binomial.C in |- *.
+  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  replace (2 * S (S (N + n)) - (2 * S (n0 + n) + 1))%nat with
+    (2 * (N - n0) + 1)%nat.
+  rewrite mult_INR.
+  reflexivity.
+  omega.
+  apply INR_fact_neq_0.
+  apply Rle_trans with
+    (sum_f_R0 (fun k:nat => INR N / INR (fact (S (S N))) * C ^ (4 * S N))
+      (pred N)).
+  apply sum_Rle; intros.
+  rewrite <-
+    (scal_sum (fun _:nat => C ^ (4 * S N)) (pred (N - n))
+      (Rsqr (/ INR (fact (S (S (N + n))))))).
+  rewrite sum_cte.
+  rewrite <- Rmult_assoc.
+  do 2 rewrite <- (Rmult_comm (C ^ (4 * S N))).
+  rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  apply pow_le.
+  left; apply Rlt_le_trans with 1.
+  apply Rlt_0_1.
+  unfold C in |- *; apply RmaxLess1.
+  apply Rle_trans with (Rsqr (/ INR (fact (S (S (N + n))))) * INR N).
+  apply Rmult_le_compat_l.
+  apply Rle_0_sqr.
+  replace (S (pred (N - n))) with (N - n)%nat.
+  apply le_INR.
+  omega.
+  omega.
+  rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+  apply pos_INR.
+  apply Rle_trans with (/ INR (fact (S (S (N + n))))).
+  pattern (/ INR (fact (S (S (N + n))))) at 2 in |- *; rewrite <- Rmult_1_r.
+  unfold Rsqr in |- *.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
+  apply INR_fact_lt_0.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r.
+  replace 1 with (INR 1).
+  apply le_INR.
+  apply lt_le_S.
+  apply INR_lt; apply INR_fact_lt_0.
+  reflexivity.
+  apply INR_fact_neq_0.
+  apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
+  apply INR_fact_lt_0.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_le_reg_l with (INR (fact (S (S N)))).
+  apply INR_fact_lt_0.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm (INR (fact (S (S N))))).
+  rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  apply le_INR.
+  apply fact_le.
+  omega.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  rewrite sum_cte.
+  apply Rle_trans with (C ^ (4 * S N) / INR (fact N)).
+  rewrite <- (Rmult_comm (C ^ (4 * S N))).
+  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  apply pow_le.
+  left; apply Rlt_le_trans with 1.
+  apply Rlt_0_1.
+  unfold C in |- *; apply RmaxLess1.
+  cut (S (pred N) = N).
+  intro; rewrite H0.
+  do 2 rewrite fact_simpl.
+  repeat rewrite mult_INR.
+  repeat rewrite Rinv_mult_distr.
+  apply Rle_trans with
+    (INR (S (S N)) * (/ INR (S (S N)) * (/ INR (S N) * / INR (fact N))) * INR N).
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm (INR N)).
+  rewrite (Rmult_comm (INR (S (S N)))).
+  apply Rmult_le_compat_l.
+  repeat apply Rmult_le_pos.
+  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  left; apply Rinv_0_lt_compat.
+  apply INR_fact_lt_0.
+  apply pos_INR.
+  apply le_INR.
+  apply le_trans with (S N); apply le_n_Sn.
+  repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l.
+  apply Rle_trans with (/ INR (S N) * / INR (fact N) * INR (S N)).
+  repeat rewrite Rmult_assoc.
+  repeat apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply le_INR; apply le_n_Sn.
+  rewrite (Rmult_comm (/ INR (S N))).
+  rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; right; reflexivity.
+  apply not_O_INR; discriminate.
+  apply not_O_INR; discriminate.
+  apply not_O_INR; discriminate.
+  apply INR_fact_neq_0.
+  apply not_O_INR; discriminate.
+  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  right.
+  unfold Majxy in |- *.
+  unfold C in |- *.
+  reflexivity.
 Qed.
 
 Lemma reste1_cv_R0 : forall x y:R, Un_cv (Reste1 x y) 0.
-intros.
-assert (H := Majxy_cv_R0 x y).
-unfold Un_cv in H; unfold R_dist in H.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
-elim (H eps H0); intros N0 H1.
-exists (S N0); intros.
-unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
-apply Rle_lt_trans with (Rabs (Majxy x y (pred n))).
-rewrite (Rabs_right (Majxy x y (pred n))).
-apply reste1_maj.
-apply lt_le_trans with (S N0).
-apply lt_O_Sn.
-assumption.
-apply Rle_ge.
-unfold Majxy in |- *.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-apply pow_le.
-apply Rle_trans with 1.
-left; apply Rlt_0_1.
-apply RmaxLess1.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-replace (Majxy x y (pred n)) with (Majxy x y (pred n) - 0); [ idtac | ring ].
-apply H1.
-unfold ge in |- *; apply le_S_n.
-replace (S (pred n)) with n.
-assumption.
-apply S_pred with 0%nat.
-apply lt_le_trans with (S N0); [ apply lt_O_Sn | assumption ].
+Proof.
+  intros.
+  assert (H := Majxy_cv_R0 x y).
+  unfold Un_cv in H; unfold R_dist in H.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  elim (H eps H0); intros N0 H1.
+  exists (S N0); intros.
+  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
+  apply Rle_lt_trans with (Rabs (Majxy x y (pred n))).
+  rewrite (Rabs_right (Majxy x y (pred n))).
+  apply reste1_maj.
+  apply lt_le_trans with (S N0).
+  apply lt_O_Sn.
+  assumption.
+  apply Rle_ge.
+  unfold Majxy in |- *.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  apply pow_le.
+  apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  apply RmaxLess1.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  replace (Majxy x y (pred n)) with (Majxy x y (pred n) - 0); [ idtac | ring ].
+  apply H1.
+  unfold ge in |- *; apply le_S_n.
+  replace (S (pred n)) with n.
+  assumption.
+  apply S_pred with 0%nat.
+  apply lt_le_trans with (S N0); [ apply lt_O_Sn | assumption ].
 Qed.
 
 Lemma reste2_cv_R0 : forall x y:R, Un_cv (Reste2 x y) 0.
-intros.
-assert (H := Majxy_cv_R0 x y).
-unfold Un_cv in H; unfold R_dist in H.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
-elim (H eps H0); intros N0 H1.
-exists (S N0); intros.
-unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
-apply Rle_lt_trans with (Rabs (Majxy x y n)).
-rewrite (Rabs_right (Majxy x y n)).
-apply reste2_maj.
-apply lt_le_trans with (S N0).
-apply lt_O_Sn.
-assumption.
-apply Rle_ge.
-unfold Majxy in |- *.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-apply pow_le.
-apply Rle_trans with 1.
-left; apply Rlt_0_1.
-apply RmaxLess1.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-replace (Majxy x y n) with (Majxy x y n - 0); [ idtac | ring ].
-apply H1.
-unfold ge in |- *; apply le_trans with (S N0).
-apply le_n_Sn.
-exact H2.
+Proof.
+  intros.
+  assert (H := Majxy_cv_R0 x y).
+  unfold Un_cv in H; unfold R_dist in H.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  elim (H eps H0); intros N0 H1.
+  exists (S N0); intros.
+  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
+  apply Rle_lt_trans with (Rabs (Majxy x y n)).
+  rewrite (Rabs_right (Majxy x y n)).
+  apply reste2_maj.
+  apply lt_le_trans with (S N0).
+  apply lt_O_Sn.
+  assumption.
+  apply Rle_ge.
+  unfold Majxy in |- *.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  apply pow_le.
+  apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  apply RmaxLess1.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  replace (Majxy x y n) with (Majxy x y n - 0); [ idtac | ring ].
+  apply H1.
+  unfold ge in |- *; apply le_trans with (S N0).
+  apply le_n_Sn.
+  exact H2.
 Qed.
 
 Lemma reste_cv_R0 : forall x y:R, Un_cv (Reste x y) 0.
-intros.
-unfold Reste in |- *.
-set (An := fun n:nat => Reste2 x y n).
-set (Bn := fun n:nat => Reste1 x y (S n)).
-cut
- (Un_cv (fun n:nat => An n - Bn n) (0 - 0) ->
-  Un_cv (fun N:nat => Reste2 x y N - Reste1 x y (S N)) 0).
-intro.
-apply H.
-apply CV_minus.
-unfold An in |- *.
-replace (fun n:nat => Reste2 x y n) with (Reste2 x y).
-apply reste2_cv_R0.
-reflexivity.
-unfold Bn in |- *.
-assert (H0 := reste1_cv_R0 x y).
-unfold Un_cv in H0; unfold R_dist in H0.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
-elim (H0 eps H1); intros N0 H2.
-exists N0; intros.
-apply H2.
-unfold ge in |- *; apply le_trans with (S N0).
-apply le_n_Sn.
-apply le_n_S; assumption.
-unfold An, Bn in |- *.
-intro.
-replace 0 with (0 - 0); [ idtac | ring ].
-exact H.
+Proof.
+  intros.
+  unfold Reste in |- *.
+  set (An := fun n:nat => Reste2 x y n).
+  set (Bn := fun n:nat => Reste1 x y (S n)).
+  cut
+    (Un_cv (fun n:nat => An n - Bn n) (0 - 0) ->
+      Un_cv (fun N:nat => Reste2 x y N - Reste1 x y (S N)) 0).
+  intro.
+  apply H.
+  apply CV_minus.
+  unfold An in |- *.
+  replace (fun n:nat => Reste2 x y n) with (Reste2 x y).
+  apply reste2_cv_R0.
+  reflexivity.
+  unfold Bn in |- *.
+  assert (H0 := reste1_cv_R0 x y).
+  unfold Un_cv in H0; unfold R_dist in H0.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  elim (H0 eps H1); intros N0 H2.
+  exists N0; intros.
+  apply H2.
+  unfold ge in |- *; apply le_trans with (S N0).
+  apply le_n_Sn.
+  apply le_n_S; assumption.
+  unfold An, Bn in |- *.
+  intro.
+  replace 0 with (0 - 0); [ idtac | ring ].
+  exact H.
 Qed.
 
 Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y. 
-intros. 
-cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). 
-cut (Un_cv (C1 x y) (cos (x + y))). 
-intros. 
-apply UL_sequence with (C1 x y); assumption. 
-apply C1_cvg. 
-unfold Un_cv in |- *; unfold R_dist in |- *. 
-intros. 
-assert (H0 := A1_cvg x). 
-assert (H1 := A1_cvg y). 
-assert (H2 := B1_cvg x). 
-assert (H3 := B1_cvg y). 
-assert (H4 := CV_mult _ _ _ _ H0 H1). 
-assert (H5 := CV_mult _ _ _ _ H2 H3). 
-assert (H6 := reste_cv_R0 x y).
-unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6.
-unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6. 
-cut (0 < eps / 3);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
-elim (H4 (eps / 3) H7); intros N1 H8. 
-elim (H5 (eps / 3) H7); intros N2 H9. 
-elim (H6 (eps / 3) H7); intros N3 H10.
-set (N := S (S (max (max N1 N2) N3))). 
-exists N. 
-intros. 
-cut (n = S (pred n)). 
-intro; rewrite H12. 
-rewrite <- cos_plus_form. 
-rewrite <- H12. 
-apply Rle_lt_trans with
- (Rabs (A1 x n * A1 y n - cos x * cos y) +
-  Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). 
-replace
- (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) -
-  (cos x * cos y - sin x * sin y)) with
- (A1 x n * A1 y n - cos x * cos y +
-  (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n)));
- [ apply Rabs_triang | ring ].
-replace eps with (eps / 3 + (eps / 3 + eps / 3)).
-apply Rplus_lt_compat. 
-apply H8. 
-unfold ge in |- *; apply le_trans with N. 
-unfold N in |- *. 
-apply le_trans with (max N1 N2). 
-apply le_max_l. 
-apply le_trans with (max (max N1 N2) N3).
-apply le_max_l.
-apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn.
-assumption. 
-apply Rle_lt_trans with
- (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) +
-  Rabs (Reste x y (pred n))).
-apply Rabs_triang.
-apply Rplus_lt_compat.
-rewrite <- Rabs_Ropp. 
-rewrite Ropp_minus_distr. 
-apply H9. 
-unfold ge in |- *; apply le_trans with (max N1 N2). 
-apply le_max_r. 
-apply le_S_n. 
-rewrite <- H12. 
-apply le_trans with N.
-unfold N in |- *.
-apply le_n_S.
-apply le_trans with (max (max N1 N2) N3).
-apply le_max_l.
-apply le_n_Sn.
-assumption.
-replace (Reste x y (pred n)) with (Reste x y (pred n) - 0).
-apply H10.
-unfold ge in |- *.
-apply le_S_n.
-rewrite <- H12.
-apply le_trans with N.
-unfold N in |- *.
-apply le_n_S.
-apply le_trans with (max (max N1 N2) N3).
-apply le_max_r.
-apply le_n_Sn.
-assumption.
-ring.
-pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
-ring.
-unfold Rdiv in |- *.
-rewrite <- Rmult_assoc.
-apply Rinv_r_simpl_m.
-discrR.
-apply lt_le_trans with (pred N).
-unfold N in |- *; simpl in |- *; apply lt_O_Sn.
-apply le_S_n.
-rewrite <- H12.
-replace (S (pred N)) with N.
-assumption.
-unfold N in |- *; simpl in |- *; reflexivity.
-cut (0 < N)%nat. 
-intro. 
-cut (0 < n)%nat. 
-intro. 
-apply S_pred with 0%nat; assumption.
-apply lt_le_trans with N; assumption. 
-unfold N in |- *; apply lt_O_Sn.
-Qed.
\ No newline at end of file
+Proof.
+  intros. 
+  cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). 
+  cut (Un_cv (C1 x y) (cos (x + y))). 
+  intros. 
+  apply UL_sequence with (C1 x y); assumption. 
+  apply C1_cvg. 
+  unfold Un_cv in |- *; unfold R_dist in |- *. 
+  intros. 
+  assert (H0 := A1_cvg x). 
+  assert (H1 := A1_cvg y). 
+  assert (H2 := B1_cvg x). 
+  assert (H3 := B1_cvg y). 
+  assert (H4 := CV_mult _ _ _ _ H0 H1). 
+  assert (H5 := CV_mult _ _ _ _ H2 H3). 
+  assert (H6 := reste_cv_R0 x y).
+  unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6.
+  unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6. 
+  cut (0 < eps / 3);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
+  elim (H4 (eps / 3) H7); intros N1 H8. 
+  elim (H5 (eps / 3) H7); intros N2 H9. 
+  elim (H6 (eps / 3) H7); intros N3 H10.
+  set (N := S (S (max (max N1 N2) N3))). 
+  exists N. 
+  intros. 
+  cut (n = S (pred n)). 
+  intro; rewrite H12. 
+  rewrite <- cos_plus_form. 
+  rewrite <- H12. 
+  apply Rle_lt_trans with
+    (Rabs (A1 x n * A1 y n - cos x * cos y) +
+      Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). 
+  replace
+    (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) -
+      (cos x * cos y - sin x * sin y)) with
+    (A1 x n * A1 y n - cos x * cos y +
+      (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n)));
+    [ apply Rabs_triang | ring ].
+  replace eps with (eps / 3 + (eps / 3 + eps / 3)).
+  apply Rplus_lt_compat. 
+  apply H8. 
+  unfold ge in |- *; apply le_trans with N. 
+  unfold N in |- *. 
+  apply le_trans with (max N1 N2). 
+  apply le_max_l. 
+  apply le_trans with (max (max N1 N2) N3).
+  apply le_max_l.
+  apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn.
+  assumption. 
+  apply Rle_lt_trans with
+    (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) +
+      Rabs (Reste x y (pred n))).
+  apply Rabs_triang.
+  apply Rplus_lt_compat.
+  rewrite <- Rabs_Ropp. 
+  rewrite Ropp_minus_distr. 
+  apply H9. 
+  unfold ge in |- *; apply le_trans with (max N1 N2). 
+  apply le_max_r. 
+  apply le_S_n. 
+  rewrite <- H12. 
+  apply le_trans with N.
+  unfold N in |- *.
+  apply le_n_S.
+  apply le_trans with (max (max N1 N2) N3).
+  apply le_max_l.
+  apply le_n_Sn.
+  assumption.
+  replace (Reste x y (pred n)) with (Reste x y (pred n) - 0).
+  apply H10.
+  unfold ge in |- *.
+  apply le_S_n.
+  rewrite <- H12.
+  apply le_trans with N.
+  unfold N in |- *.
+  apply le_n_S.
+  apply le_trans with (max (max N1 N2) N3).
+  apply le_max_r.
+  apply le_n_Sn.
+  assumption.
+  ring.
+  pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
+  ring.
+  unfold Rdiv in |- *.
+  rewrite <- Rmult_assoc.
+  apply Rinv_r_simpl_m.
+  discrR.
+  apply lt_le_trans with (pred N).
+  unfold N in |- *; simpl in |- *; apply lt_O_Sn.
+  apply le_S_n.
+  rewrite <- H12.
+  replace (S (pred N)) with N.
+  assumption.
+  unfold N in |- *; simpl in |- *; reflexivity.
+  cut (0 < N)%nat. 
+  intro. 
+  cut (0 < n)%nat. 
+  intro. 
+  apply S_pred with 0%nat; assumption.
+  apply lt_le_trans with N; assumption. 
+  unfold N in |- *; apply lt_O_Sn.
+Qed.
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
index 9f76a5ad..d410e14a 100644
--- a/theories/Reals/Cos_rel.v
+++ b/theories/Reals/Cos_rel.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
  
-(*i $Id: Cos_rel.v,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+(*i $Id: Cos_rel.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -83,7 +83,6 @@ replace
             ((-1) ^ (n - l) / INR (fact (2 * (n - l) + 1)) *
              y ^ (2 * (n - l) + 1))) (pred (n - k))) (
     pred n)) with (Reste2 x y n).
-ring.
 replace
  (sum_f_R0
     (fun k:nat =>
@@ -98,7 +97,7 @@ replace
        sum_f_R0
          (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k)
     (S n)).
-set
+pose
  (sin_nnn :=
   fun n:nat =>
     match n with
@@ -109,7 +108,10 @@ set
           (fun l:nat =>
              C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p
     end).
+ring_simplify.
+unfold Rminus.
 replace
+(* (-   old ring compat *)
  (-
   sum_f_R0
     (fun k:nat =>
@@ -123,19 +125,13 @@ unfold C1 in |- *.
 apply sum_eq; intros.
 induction  i as [| i Hreci].
 simpl in |- *.
-rewrite Rplus_0_l.
-replace (C 0 0) with 1.
-unfold Rdiv in |- *; rewrite Rinv_1.
-ring.
-unfold C in |- *.
-rewrite <- minus_n_n.
-simpl in |- *.
-unfold Rdiv in |- *; rewrite Rmult_1_r; rewrite Rinv_1; ring.
+unfold C in |- *; simpl in |- *.
+field; discrR.
 unfold sin_nnn in |- *.
 rewrite <- Rmult_plus_distr_l.
 apply Rmult_eq_compat_l.
 rewrite binomial.
-set (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)).
+pose (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)).
 replace
  (sum_f_R0
     (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l)))
@@ -145,47 +141,42 @@ replace
     (fun l:nat =>
        C (2 * S i) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (i - l))) i) with
  (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i).
-rewrite Rplus_comm.
 apply sum_decomposition.
 apply sum_eq; intros.
 unfold Wn in |- *.
 apply Rmult_eq_compat_l.
 replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))).
 reflexivity.
-apply INR_eq.
-rewrite S_INR; rewrite mult_INR.
-repeat rewrite minus_INR.
-rewrite mult_INR; repeat rewrite S_INR.
-rewrite mult_INR; repeat rewrite S_INR; ring.
-replace (2 * S i)%nat with (S (S (2 * i))).
-apply le_n_S.
-apply le_trans with (2 * i)%nat.
-apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
-apply le_n_Sn.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-assumption.
+omega.
 apply sum_eq; intros.
 unfold Wn in |- *.
 apply Rmult_eq_compat_l.
 replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat.
 reflexivity.
-apply INR_eq.
-rewrite mult_INR.
-repeat rewrite minus_INR.
-rewrite mult_INR; repeat rewrite S_INR.
-rewrite mult_INR; repeat rewrite S_INR; ring.
-apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
-assumption.
-rewrite <- (Ropp_involutive (sum_f_R0 sin_nnn (S n))).
-apply Ropp_eq_compat.
-replace (- sum_f_R0 sin_nnn (S n)) with (-1 * sum_f_R0 sin_nnn (S n));
- [ idtac | ring ].
+omega.
+replace
+ (-
+  sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun p:nat =>
+            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
+            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
+             y ^ (2 * (k - p) + 1))) k) n) with
+ (-1 *
+  sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun p:nat =>
+            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
+            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
+             y ^ (2 * (k - p) + 1))) k) n);[idtac|ring].
 rewrite scal_sum.
 rewrite decomp_sum.
 replace (sin_nnn 0%nat) with 0.
-rewrite Rmult_0_l; rewrite Rplus_0_l.
-replace (pred (S n)) with n; [ idtac | reflexivity ].
+rewrite Rplus_0_l.
+change (pred (S n)) with n.
+   (* replace (pred (S n)) with n; [ idtac | reflexivity ]. *)
 apply sum_eq; intros.
 rewrite Rmult_comm.
 unfold sin_nnn in |- *.
@@ -193,8 +184,8 @@ rewrite scal_sum.
 rewrite scal_sum.
 apply sum_eq; intros.
 unfold Rdiv in |- *.
-repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm (/ INR (fact (2 * S i)))).
+(*repeat rewrite Rmult_assoc.*)
+(* rewrite (Rmult_comm (/ INR (fact (2 * S i)))). *)
 repeat rewrite <- Rmult_assoc.
 rewrite <- (Rmult_comm (/ INR (fact (2 * S i)))).
 repeat rewrite <- Rmult_assoc.
@@ -218,25 +209,13 @@ replace (S (2 * i0)) with (2 * i0 + 1)%nat;
  [ apply Rmult_eq_compat_l | ring ].
 replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat.
 reflexivity.
-apply INR_eq.
-rewrite plus_INR; rewrite mult_INR; repeat rewrite minus_INR.
-rewrite plus_INR; do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
-replace (2 * i0 + 1)%nat with (S (2 * i0)).
-replace (2 * S i)%nat with (S (S (2 * i))).
-apply le_n_S.
-apply le_trans with (2 * i)%nat.
-apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
-apply le_n_Sn.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
- repeat rewrite S_INR; ring.
-assumption.
+omega.
 apply INR_fact_neq_0.
 apply INR_fact_neq_0.
 apply INR_fact_neq_0.
 reflexivity.
 apply lt_O_Sn.
+(* ring. *)
 apply sum_eq; intros.
 rewrite scal_sum.
 apply sum_eq; intros.
@@ -259,11 +238,7 @@ rewrite Rmult_1_l.
 rewrite Rinv_mult_distr.
 replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat.
 reflexivity.
-apply INR_eq.
-rewrite mult_INR; repeat rewrite minus_INR.
-do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
-apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
-assumption.
+omega.
 apply INR_fact_neq_0.
 apply INR_fact_neq_0.
 apply INR_fact_neq_0.
@@ -417,4 +392,4 @@ unfold sin_in in s.
 assert
  (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s). 
 rewrite H1; reflexivity. 
-Qed. 
\ No newline at end of file
+Qed. 
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
index f897e258..a16af05c 100644
--- a/theories/Reals/DiscrR.v
+++ b/theories/Reals/DiscrR.v
@@ -6,13 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i        $Id: DiscrR.v,v 1.21.2.1 2004/07/16 19:31:10 herbelin Exp $       i*)
+(*i        $Id: DiscrR.v 9178 2006-09-26 11:18:22Z barras $       i*)
 
 Require Import RIneq.
 Require Import Omega. Open Local Scope R_scope.
 
 Lemma Rlt_R0_R2 : 0 < 2.
-replace 2 with (INR 2); [ apply lt_INR_0; apply lt_O_Sn | reflexivity ].
+change 2 with (INR 2); apply lt_INR_0; apply lt_O_Sn.
 Qed.
 
 Lemma Rplus_lt_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x + y.
@@ -36,17 +36,14 @@ Ltac discrR :=
   try
    match goal with
    |  |- (?X1 <> ?X2) =>
-       replace 2 with (IZR 2);
-        [ replace 1 with (IZR 1);
-           [ replace 0 with (IZR 0);
-              [ repeat
-                 rewrite <- plus_IZR ||
-                   rewrite <- mult_IZR ||
-                     rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
-                 apply IZR_neq; try discriminate
-              | reflexivity ]
-           | reflexivity ]
-        | reflexivity ]
+       change 2 with (IZR 2);
+       change 1 with (IZR 1);
+       change 0 with (IZR 0);
+       repeat
+         rewrite <- plus_IZR ||
+           rewrite <- mult_IZR ||
+           rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
+       apply IZR_neq; try discriminate
    end.
 
 Ltac prove_sup0 :=
@@ -60,17 +57,13 @@ Ltac prove_sup0 :=
   end.
 
 Ltac omega_sup :=
-  replace 2 with (IZR 2);
-   [ replace 1 with (IZR 1);
-      [ replace 0 with (IZR 0);
-         [ repeat
-            rewrite <- plus_IZR ||
-              rewrite <- mult_IZR ||
-                rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; 
-            apply IZR_lt; omega
-         | reflexivity ]
-      | reflexivity ]
-   | reflexivity ].
+  change 2 with (IZR 2);
+  change 1 with (IZR 1);
+  change 0 with (IZR 0);
+  repeat
+    rewrite <- plus_IZR ||
+      rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; 
+  apply IZR_lt; omega.
   
 Ltac prove_sup :=
   match goal with
@@ -84,14 +77,10 @@ Ltac prove_sup :=
   end.
 
 Ltac Rcompute :=
-  replace 2 with (IZR 2);
-   [ replace 1 with (IZR 1);
-      [ replace 0 with (IZR 0);
-         [ repeat
-            rewrite <- plus_IZR ||
-              rewrite <- mult_IZR ||
-                rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; 
-            apply IZR_eq; try reflexivity
-         | reflexivity ]
-      | reflexivity ]
-   | reflexivity ].
\ No newline at end of file
+  change 2 with (IZR 2);
+  change 1 with (IZR 1);
+  change 0 with (IZR 0);
+  repeat
+    rewrite <- plus_IZR ||
+      rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; 
+  apply IZR_eq; try reflexivity.
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
index fcaeb11e..beb4b744 100644
--- a/theories/Reals/Exp_prop.v
+++ b/theories/Reals/Exp_prop.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Exp_prop.v,v 1.16.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+(*i $Id: Exp_prop.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -24,988 +24,972 @@ Definition E1 (x:R) (N:nat) : R :=
   sum_f_R0 (fun k:nat => / INR (fact k) * x ^ k) N.
 
 Lemma E1_cvg : forall x:R, Un_cv (E1 x) (exp x).
-intro; unfold exp in |- *; unfold projT1 in |- *.
-case (exist_exp x); intro.
-unfold exp_in, Un_cv in |- *; unfold infinit_sum, E1 in |- *; trivial.
+Proof.
+  intro; unfold exp in |- *; unfold projT1 in |- *.
+  case (exist_exp x); intro.
+  unfold exp_in, Un_cv in |- *; unfold infinit_sum, E1 in |- *; trivial.
 Qed.
 
 Definition Reste_E (x y:R) (N:nat) : R :=
   sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            / INR (fact (S (l + k))) * x ^ S (l + k) *
-            (/ INR (fact (N - l)) * y ^ (N - l))) (
-         pred (N - k))) (pred N).
+  (fun k:nat =>
+    sum_f_R0
+    (fun l:nat =>
+      / INR (fact (S (l + k))) * x ^ S (l + k) *
+      (/ INR (fact (N - l)) * y ^ (N - l))) (
+        pred (N - k))) (pred N).
 
 Lemma exp_form :
- forall (x y:R) (n:nat),
-   (0 < n)%nat -> E1 x n * E1 y n - Reste_E x y n = E1 (x + y) n.
-intros; unfold E1 in |- *.
-rewrite cauchy_finite.
-unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc;
- rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; 
- intros.
-rewrite binomial.
-rewrite scal_sum; apply sum_eq; intros.
-unfold C in |- *; unfold Rdiv in |- *; repeat rewrite Rmult_assoc;
- rewrite (Rmult_comm (INR (fact i))); repeat rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite Rinv_mult_distr.
-ring.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply H.
+  forall (x y:R) (n:nat),
+    (0 < n)%nat -> E1 x n * E1 y n - Reste_E x y n = E1 (x + y) n.
+Proof.
+  intros; unfold E1 in |- *.
+  rewrite cauchy_finite.
+  unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; 
+      intros.
+  rewrite binomial.
+  rewrite scal_sum; apply sum_eq; intros.
+  unfold C in |- *; unfold Rdiv in |- *; repeat rewrite Rmult_assoc;
+    rewrite (Rmult_comm (INR (fact i))); repeat rewrite Rmult_assoc;
+      rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite Rinv_mult_distr.
+  ring.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply H.
 Qed.
 
 Definition maj_Reste_E (x y:R) (N:nat) : R :=
   4 *
   (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * N) /
-   Rsqr (INR (fact (div2 (pred N))))).
+    Rsqr (INR (fact (div2 (pred N))))).
 
 Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x.
-intros; apply Rmult_le_reg_l with x.
-apply H.
-rewrite <- Rinv_r_sym.
-apply Rmult_le_reg_l with y.
-apply H0.
-rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; apply H1.
-red in |- *; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0).
-red in |- *; intro; rewrite H2 in H; elim (Rlt_irrefl _ H).
+Proof.
+  intros; apply Rmult_le_reg_l with x.
+  apply H.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_le_reg_l with y.
+  apply H0.
+  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; apply H1.
+  red in |- *; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0).
+  red in |- *; intro; rewrite H2 in H; elim (Rlt_irrefl _ H).
 Qed.
 
 (**********)
 Lemma div2_double : forall N:nat, div2 (2 * N) = N.
-intro; induction  N as [| N HrecN].
-reflexivity.
-replace (2 * S N)%nat with (S (S (2 * N))).
-simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
+Proof.
+  intro; induction  N as [| N HrecN].
+  reflexivity.
+  replace (2 * S N)%nat with (S (S (2 * N))).
+  simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
+  ring.
 Qed.
 
 Lemma div2_S_double : forall N:nat, div2 (S (2 * N)) = N.
-intro; induction  N as [| N HrecN].
-reflexivity.
-replace (2 * S N)%nat with (S (S (2 * N))).
-simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
+Proof.
+  intro; induction  N as [| N HrecN].
+  reflexivity.
+  replace (2 * S N)%nat with (S (S (2 * N))).
+  simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
+  ring.
 Qed.
 
 Lemma div2_not_R0 : forall N:nat, (1 < N)%nat -> (0 < div2 N)%nat.
-intros; induction  N as [| N HrecN].
-elim (lt_n_O _ H).
-cut ((1 < N)%nat \/ N = 1%nat).
-intro; elim H0; intro.
-assert (H2 := even_odd_dec N).
-elim H2; intro.
-rewrite <- (even_div2 _ a); apply HrecN; assumption.
-rewrite <- (odd_div2 _ b); apply lt_O_Sn.
-rewrite H1; simpl in |- *; apply lt_O_Sn.
-inversion H.
-right; reflexivity.
-left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
+Proof.
+  intros; induction  N as [| N HrecN].
+  elim (lt_n_O _ H).
+  cut ((1 < N)%nat \/ N = 1%nat).
+  intro; elim H0; intro.
+  assert (H2 := even_odd_dec N).
+  elim H2; intro.
+  rewrite <- (even_div2 _ a); apply HrecN; assumption.
+  rewrite <- (odd_div2 _ b); apply lt_O_Sn.
+  rewrite H1; simpl in |- *; apply lt_O_Sn.
+  inversion H.
+  right; reflexivity.
+  left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
 Qed.
 
 Lemma Reste_E_maj :
- forall (x y:R) (N:nat),
-   (0 < N)%nat -> Rabs (Reste_E x y N) <= maj_Reste_E x y N.
-intros; set (M := Rmax 1 (Rmax (Rabs x) (Rabs y))).
-apply Rle_trans with
- (M ^ (2 * N) *
-  sum_f_R0
-    (fun k:nat =>
-       sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N)))))
-         (pred (N - k))) (pred N)). 
-unfold Reste_E in |- *.
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       Rabs
-         (sum_f_R0
-            (fun l:nat =>
-               / INR (fact (S (l + k))) * x ^ S (l + k) *
-               (/ INR (fact (N - l)) * y ^ (N - l))) (
-            pred (N - k)))) (pred N)).
-apply
- (Rsum_abs
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
+  forall (x y:R) (N:nat),
+    (0 < N)%nat -> Rabs (Reste_E x y N) <= maj_Reste_E x y N.
+Proof.
+  intros; set (M := Rmax 1 (Rmax (Rabs x) (Rabs y))).
+  apply Rle_trans with
+    (M ^ (2 * N) *
+      sum_f_R0
+      (fun k:nat =>
+        sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N)))))
+        (pred (N - k))) (pred N)). 
+  unfold Reste_E in |- *.
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+        Rabs
+        (sum_f_R0
+          (fun l:nat =>
             / INR (fact (S (l + k))) * x ^ S (l + k) *
             (/ INR (fact (N - l)) * y ^ (N - l))) (
-         pred (N - k))) (pred N)).
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            Rabs
-              (/ INR (fact (S (l + k))) * x ^ S (l + k) *
-               (/ INR (fact (N - l)) * y ^ (N - l)))) (
-         pred (N - k))) (pred N)).
-apply sum_Rle; intros.
-apply
- (Rsum_abs
-    (fun l:nat =>
-       / INR (fact (S (l + n))) * x ^ S (l + n) *
-       (/ INR (fact (N - l)) * y ^ (N - l)))).
-apply Rle_trans with
- (sum_f_R0
-    (fun k:nat =>
-       sum_f_R0
-         (fun l:nat =>
-            M ^ (2 * N) * / INR (fact (S l)) * / INR (fact (N - l)))
-         (pred (N - k))) (pred N)).
-apply sum_Rle; intros.
-apply sum_Rle; intros.
-repeat rewrite Rabs_mult.
-do 2 rewrite <- RPow_abs.
-rewrite (Rabs_right (/ INR (fact (S (n0 + n))))).
-rewrite (Rabs_right (/ INR (fact (N - n0)))).
-replace
- (/ INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
-  (/ INR (fact (N - n0)) * Rabs y ^ (N - n0))) with
- (/ INR (fact (N - n0)) * / INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
-  Rabs y ^ (N - n0)); [ idtac | ring ].
-rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
-repeat rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rle_trans with
- (/ INR (fact (S n0)) * Rabs x ^ S (n0 + n) * Rabs y ^ (N - n0)).
-rewrite (Rmult_comm (/ INR (fact (S (n0 + n)))));
- rewrite (Rmult_comm (/ INR (fact (S n0)))); repeat rewrite Rmult_assoc;
- apply Rmult_le_compat_l.
-apply pow_le; apply Rabs_pos.
-rewrite (Rmult_comm (/ INR (fact (S n0)))); apply Rmult_le_compat_l.
-apply pow_le; apply Rabs_pos.
-apply Rle_Rinv.
-apply INR_fact_lt_0.
-apply INR_fact_lt_0.
-apply le_INR; apply fact_le; apply le_n_S.
-apply le_plus_l.
-rewrite (Rmult_comm (M ^ (2 * N))); rewrite Rmult_assoc;
- apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rle_trans with (M ^ S (n0 + n) * Rabs y ^ (N - n0)).
-do 2 rewrite <- (Rmult_comm (Rabs y ^ (N - n0))).
-apply Rmult_le_compat_l.
-apply pow_le; apply Rabs_pos.
-apply pow_incr; split.
-apply Rabs_pos.
-apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
-apply RmaxLess1.
-unfold M in |- *; apply RmaxLess2.
-apply Rle_trans with (M ^ S (n0 + n) * M ^ (N - n0)).
-apply Rmult_le_compat_l.
-apply pow_le; apply Rle_trans with 1.
-left; apply Rlt_0_1.
-unfold M in |- *; apply RmaxLess1.
-apply pow_incr; split.
-apply Rabs_pos.
-apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
-apply RmaxLess2.
-unfold M in |- *; apply RmaxLess2.
-rewrite <- pow_add; replace (S (n0 + n) + (N - n0))%nat with (N + S n)%nat.
-apply Rle_pow.
-unfold M in |- *; apply RmaxLess1.
-replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
-apply plus_le_compat_l.
-replace N with (S (pred N)).
-apply le_n_S; apply H0.
-symmetry  in |- *; apply S_pred with 0%nat; apply H.
-apply INR_eq; do 2 rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR;
- rewrite minus_INR.
-ring.
-apply le_trans with (pred (N - n)).
-apply H1.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-apply H0.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-apply H0.
-apply lt_pred_n_n.
-apply H.
-apply le_trans with (pred N).
-apply H0.
-apply le_pred_n.
-apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-rewrite scal_sum.
-apply sum_Rle; intros.
-rewrite <- Rmult_comm.
-rewrite scal_sum.
-apply sum_Rle; intros.
-rewrite (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
-rewrite Rmult_assoc; apply Rmult_le_compat_l.
-apply pow_le.
-apply Rle_trans with 1.
-left; apply Rlt_0_1.
-unfold M in |- *; apply RmaxLess1.
-assert (H2 := even_odd_cor N).
-elim H2; intros N0 H3.
-elim H3; intro.
-apply Rle_trans with (/ INR (fact n0) * / INR (fact (N - n0))).
-do 2 rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rle_Rinv.
-apply INR_fact_lt_0.
-apply INR_fact_lt_0.
-apply le_INR.
-apply fact_le.
-apply le_n_Sn.
-replace (/ INR (fact n0) * / INR (fact (N - n0))) with
- (C N n0 / INR (fact N)).
-pattern N at 1 in |- *; rewrite H4.
-apply Rle_trans with (C N N0 / INR (fact N)).
-unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact N))).
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-rewrite H4.
-apply C_maj.
-rewrite <- H4; apply le_trans with (pred (N - n)).
-apply H1.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-apply H0.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-apply H0.
-apply lt_pred_n_n.
-apply H.
-apply le_trans with (pred N).
-apply H0.
-apply le_pred_n.
-replace (C N N0 / INR (fact N)) with (/ Rsqr (INR (fact N0))).
-rewrite H4; rewrite div2_S_double; right; reflexivity.
-unfold Rsqr, C, Rdiv in |- *.
-repeat rewrite Rinv_mult_distr.
-rewrite (Rmult_comm (INR (fact N))).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; replace (N - N0)%nat with N0.
-ring.
-replace N with (N0 + N0)%nat.
-symmetry  in |- *; apply minus_plus.
-rewrite H4.
-apply INR_eq; rewrite plus_INR; rewrite mult_INR; do 2 rewrite S_INR; ring.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-unfold C, Rdiv in |- *.
-rewrite (Rmult_comm (INR (fact N))).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rinv_mult_distr.
-rewrite Rmult_1_r; ring.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-replace (/ INR (fact (S n0)) * / INR (fact (N - n0))) with
- (C (S N) (S n0) / INR (fact (S N))).
-apply Rle_trans with (C (S N) (S N0) / INR (fact (S N))).
-unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))).
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-cut (S N = (2 * S N0)%nat).
-intro; rewrite H5; apply C_maj.
-rewrite <- H5; apply le_n_S.
-apply le_trans with (pred (N - n)).
-apply H1.
-apply le_S_n.
-replace (S (pred (N - n))) with (N - n)%nat.
-apply le_trans with N.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-apply H0.
-apply le_pred_n.
-apply le_n_Sn.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-apply H0.
-apply lt_pred_n_n.
-apply H.
-apply le_trans with (pred N).
-apply H0.
-apply le_pred_n.
-apply INR_eq; rewrite H4.
-do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
-cut (S N = (2 * S N0)%nat).
-intro.
-replace (C (S N) (S N0) / INR (fact (S N))) with (/ Rsqr (INR (fact (S N0)))).
-rewrite H5; rewrite div2_double.
-right; reflexivity.
-unfold Rsqr, C, Rdiv in |- *.
-repeat rewrite Rinv_mult_distr.
-replace (S N - S N0)%nat with (S N0).
-rewrite (Rmult_comm (INR (fact (S N)))).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; reflexivity.
-apply INR_fact_neq_0.
-replace (S N) with (S N0 + S N0)%nat.
-symmetry  in |- *; apply minus_plus.
-rewrite H5; ring.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_eq; rewrite H4; do 2 rewrite S_INR; do 2 rewrite mult_INR;
- repeat rewrite S_INR; ring.
-unfold C, Rdiv in |- *.
-rewrite (Rmult_comm (INR (fact (S N)))).
-rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; rewrite Rinv_mult_distr.
-reflexivity.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-unfold maj_Reste_E in |- *.
-unfold Rdiv in |- *; rewrite (Rmult_comm 4).
-rewrite Rmult_assoc.
-apply Rmult_le_compat_l.
-apply pow_le.
-apply Rle_trans with 1.
-left; apply Rlt_0_1.
-apply RmaxLess1.
-apply Rle_trans with
- (sum_f_R0 (fun k:nat => INR (N - k) * / Rsqr (INR (fact (div2 (S N)))))
-    (pred N)).
-apply sum_Rle; intros.
-rewrite sum_cte.
-replace (S (pred (N - n))) with (N - n)%nat.
-right; apply Rmult_comm.
-apply S_pred with 0%nat.
-apply plus_lt_reg_l with n.
-rewrite <- le_plus_minus.
-replace (n + 0)%nat with n; [ idtac | ring ].
-apply le_lt_trans with (pred N).
-apply H0.
-apply lt_pred_n_n.
-apply H.
-apply le_trans with (pred N).
-apply H0.
-apply le_pred_n.
-apply Rle_trans with
- (sum_f_R0 (fun k:nat => INR N * / Rsqr (INR (fact (div2 (S N))))) (pred N)).
-apply sum_Rle; intros.
-do 2 rewrite <- (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt.
-apply INR_fact_neq_0.
-apply le_INR.
-apply (fun p n m:nat => plus_le_reg_l n m p) with n.
-rewrite <- le_plus_minus.
-apply le_plus_r.
-apply le_trans with (pred N).
-apply H0.
-apply le_pred_n.
-rewrite sum_cte; replace (S (pred N)) with N.
-cut (div2 (S N) = S (div2 (pred N))).
-intro; rewrite H0.
-rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR; rewrite Rsqr_mult.
-rewrite Rinv_mult_distr.
-rewrite (Rmult_comm (INR N)); repeat rewrite Rmult_assoc;
- apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
-rewrite <- H0.
-cut (INR N <= INR (2 * div2 (S N))).
-intro; apply Rmult_le_reg_l with (Rsqr (INR (div2 (S N)))).
-apply Rsqr_pos_lt.
-apply not_O_INR; red in |- *; intro.
-cut (1 < S N)%nat.
-intro; assert (H4 := div2_not_R0 _ H3).
-rewrite H2 in H4; elim (lt_n_O _ H4).
-apply lt_n_S; apply H.
-repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l.
-replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ].
-rewrite Rmult_assoc.
-rewrite Rmult_comm.
-replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
-rewrite <- Rsqr_mult.
-apply Rsqr_incr_1.
-replace 2 with (INR 2).
-rewrite <- mult_INR; apply H1.
-reflexivity.
-left; apply lt_INR_0; apply H.
-left; apply Rmult_lt_0_compat.
-prove_sup0.
-apply lt_INR_0; apply div2_not_R0.
-apply lt_n_S; apply H.
-cut (1 < S N)%nat.
-intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro;
- assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; 
- elim (lt_n_O _ H4).
-apply lt_n_S; apply H.
-assert (H1 := even_odd_cor N).
-elim H1; intros N0 H2.
-elim H2; intro.
-pattern N at 2 in |- *; rewrite H3.
-rewrite div2_S_double.
-right; rewrite H3; reflexivity.
-pattern N at 2 in |- *; rewrite H3.
-replace (S (S (2 * N0))) with (2 * S N0)%nat.
-rewrite div2_double.
-rewrite H3.
-rewrite S_INR; do 2 rewrite mult_INR.
-rewrite (S_INR N0).
-rewrite Rmult_plus_distr_l.
-apply Rplus_le_compat_l.
-rewrite Rmult_1_r.
-simpl in |- *.
-pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
- apply Rlt_0_1.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-unfold Rsqr in |- *; apply prod_neq_R0; apply INR_fact_neq_0.
-unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; discriminate.
-assert (H0 := even_odd_cor N).
-elim H0; intros N0 H1.
-elim H1; intro.
-cut (0 < N0)%nat.
-intro; rewrite H2.
-rewrite div2_S_double.
-replace (2 * N0)%nat with (S (S (2 * pred N0))).
-replace (pred (S (S (2 * pred N0)))) with (S (2 * pred N0)).
-rewrite div2_S_double.
-apply S_pred with 0%nat; apply H3.
-reflexivity.
-replace N0 with (S (pred N0)).
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-symmetry  in |- *; apply S_pred with 0%nat; apply H3.
-rewrite H2 in H.
-apply neq_O_lt.
-red in |- *; intro.
-rewrite <- H3 in H.
-simpl in H.
-elim (lt_n_O _ H).
-rewrite H2.
-replace (pred (S (2 * N0))) with (2 * N0)%nat; [ idtac | reflexivity ].
-replace (S (S (2 * N0))) with (2 * S N0)%nat.
-do 2 rewrite div2_double.
-reflexivity.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-apply S_pred with 0%nat; apply H.
+              pred (N - k)))) (pred N)).
+  apply
+    (Rsum_abs
+      (fun k:nat =>
+        sum_f_R0
+        (fun l:nat =>
+          / INR (fact (S (l + k))) * x ^ S (l + k) *
+          (/ INR (fact (N - l)) * y ^ (N - l))) (
+            pred (N - k))) (pred N)).
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+        sum_f_R0
+        (fun l:nat =>
+          Rabs
+          (/ INR (fact (S (l + k))) * x ^ S (l + k) *
+            (/ INR (fact (N - l)) * y ^ (N - l)))) (
+              pred (N - k))) (pred N)).
+  apply sum_Rle; intros.
+  apply
+    (Rsum_abs
+      (fun l:nat =>
+        / INR (fact (S (l + n))) * x ^ S (l + n) *
+        (/ INR (fact (N - l)) * y ^ (N - l)))).
+  apply Rle_trans with
+    (sum_f_R0
+      (fun k:nat =>
+        sum_f_R0
+        (fun l:nat =>
+          M ^ (2 * N) * / INR (fact (S l)) * / INR (fact (N - l)))
+        (pred (N - k))) (pred N)).
+  apply sum_Rle; intros.
+  apply sum_Rle; intros.
+  repeat rewrite Rabs_mult.
+  do 2 rewrite <- RPow_abs.
+  rewrite (Rabs_right (/ INR (fact (S (n0 + n))))).
+  rewrite (Rabs_right (/ INR (fact (N - n0)))).
+  replace
+  (/ INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
+    (/ INR (fact (N - n0)) * Rabs y ^ (N - n0))) with
+  (/ INR (fact (N - n0)) * / INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
+    Rabs y ^ (N - n0)); [ idtac | ring ].
+  rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
+  repeat rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rle_trans with
+    (/ INR (fact (S n0)) * Rabs x ^ S (n0 + n) * Rabs y ^ (N - n0)).
+  rewrite (Rmult_comm (/ INR (fact (S (n0 + n)))));
+    rewrite (Rmult_comm (/ INR (fact (S n0)))); repeat rewrite Rmult_assoc;
+      apply Rmult_le_compat_l.
+  apply pow_le; apply Rabs_pos.
+  rewrite (Rmult_comm (/ INR (fact (S n0)))); apply Rmult_le_compat_l.
+  apply pow_le; apply Rabs_pos.
+  apply Rle_Rinv.
+  apply INR_fact_lt_0.
+  apply INR_fact_lt_0.
+  apply le_INR; apply fact_le; apply le_n_S.
+  apply le_plus_l.
+  rewrite (Rmult_comm (M ^ (2 * N))); rewrite Rmult_assoc;
+    apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rle_trans with (M ^ S (n0 + n) * Rabs y ^ (N - n0)).
+  do 2 rewrite <- (Rmult_comm (Rabs y ^ (N - n0))).
+  apply Rmult_le_compat_l.
+  apply pow_le; apply Rabs_pos.
+  apply pow_incr; split.
+  apply Rabs_pos.
+  apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+  apply RmaxLess1.
+  unfold M in |- *; apply RmaxLess2.
+  apply Rle_trans with (M ^ S (n0 + n) * M ^ (N - n0)).
+  apply Rmult_le_compat_l.
+  apply pow_le; apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  unfold M in |- *; apply RmaxLess1.
+  apply pow_incr; split.
+  apply Rabs_pos.
+  apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+  apply RmaxLess2.
+  unfold M in |- *; apply RmaxLess2.
+  rewrite <- pow_add; replace (S (n0 + n) + (N - n0))%nat with (N + S n)%nat.
+  apply Rle_pow.
+  unfold M in |- *; apply RmaxLess1.
+  replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
+  apply plus_le_compat_l.
+  replace N with (S (pred N)).
+  apply le_n_S; apply H0.
+  symmetry  in |- *; apply S_pred with 0%nat; apply H.
+  apply INR_eq; do 2 rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR;
+    rewrite minus_INR.
+  ring.
+  apply le_trans with (pred (N - n)).
+  apply H1.
+  apply le_S_n.
+  replace (S (pred (N - n))) with (N - n)%nat.
+  apply le_trans with N.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+  rewrite <- le_plus_minus.
+  apply le_plus_r.
+  apply le_trans with (pred N).
+  apply H0.
+  apply le_pred_n.
+  apply le_n_Sn.
+  apply S_pred with 0%nat.
+  apply plus_lt_reg_l with n.
+  rewrite <- le_plus_minus.
+  replace (n + 0)%nat with n; [ idtac | ring ].
+  apply le_lt_trans with (pred N).
+  apply H0.
+  apply lt_pred_n_n.
+  apply H.
+  apply le_trans with (pred N).
+  apply H0.
+  apply le_pred_n.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  rewrite scal_sum.
+  apply sum_Rle; intros.
+  rewrite <- Rmult_comm.
+  rewrite scal_sum.
+  apply sum_Rle; intros.
+  rewrite (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
+  rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  apply pow_le.
+  apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  unfold M in |- *; apply RmaxLess1.
+  assert (H2 := even_odd_cor N).
+  elim H2; intros N0 H3.
+  elim H3; intro.
+  apply Rle_trans with (/ INR (fact n0) * / INR (fact (N - n0))).
+  do 2 rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rle_Rinv.
+  apply INR_fact_lt_0.
+  apply INR_fact_lt_0.
+  apply le_INR.
+  apply fact_le.
+  apply le_n_Sn.
+  replace (/ INR (fact n0) * / INR (fact (N - n0))) with
+  (C N n0 / INR (fact N)).
+  pattern N at 1 in |- *; rewrite H4.
+  apply Rle_trans with (C N N0 / INR (fact N)).
+  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact N))).
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  rewrite H4.
+  apply C_maj.
+  rewrite <- H4; apply le_trans with (pred (N - n)).
+  apply H1.
+  apply le_S_n.
+  replace (S (pred (N - n))) with (N - n)%nat.
+  apply le_trans with N.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+  rewrite <- le_plus_minus.
+  apply le_plus_r.
+  apply le_trans with (pred N).
+  apply H0.
+  apply le_pred_n.
+  apply le_n_Sn.
+  apply S_pred with 0%nat.
+  apply plus_lt_reg_l with n.
+  rewrite <- le_plus_minus.
+  replace (n + 0)%nat with n; [ idtac | ring ].
+  apply le_lt_trans with (pred N).
+  apply H0.
+  apply lt_pred_n_n.
+  apply H.
+  apply le_trans with (pred N).
+  apply H0.
+  apply le_pred_n.
+  replace (C N N0 / INR (fact N)) with (/ Rsqr (INR (fact N0))).
+  rewrite H4; rewrite div2_S_double; right; reflexivity.
+  unfold Rsqr, C, Rdiv in |- *.
+  repeat rewrite Rinv_mult_distr.
+  rewrite (Rmult_comm (INR (fact N))).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; replace (N - N0)%nat with N0.
+  ring.
+  replace N with (N0 + N0)%nat.
+  symmetry  in |- *; apply minus_plus.
+  rewrite H4.
+  ring.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  unfold C, Rdiv in |- *.
+  rewrite (Rmult_comm (INR (fact N))).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rinv_mult_distr.
+  rewrite Rmult_1_r; ring.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  replace (/ INR (fact (S n0)) * / INR (fact (N - n0))) with
+  (C (S N) (S n0) / INR (fact (S N))).
+  apply Rle_trans with (C (S N) (S N0) / INR (fact (S N))).
+  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))).
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  cut (S N = (2 * S N0)%nat).
+  intro; rewrite H5; apply C_maj.
+  rewrite <- H5; apply le_n_S.
+  apply le_trans with (pred (N - n)).
+  apply H1.
+  apply le_S_n.
+  replace (S (pred (N - n))) with (N - n)%nat.
+  apply le_trans with N.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+  rewrite <- le_plus_minus.
+  apply le_plus_r.
+  apply le_trans with (pred N).
+  apply H0.
+  apply le_pred_n.
+  apply le_n_Sn.
+  apply S_pred with 0%nat.
+  apply plus_lt_reg_l with n.
+  rewrite <- le_plus_minus.
+  replace (n + 0)%nat with n; [ idtac | ring ].
+  apply le_lt_trans with (pred N).
+  apply H0.
+  apply lt_pred_n_n.
+  apply H.
+  apply le_trans with (pred N).
+  apply H0.
+  apply le_pred_n.
+  rewrite H4; ring.
+  cut (S N = (2 * S N0)%nat).
+  intro.
+  replace (C (S N) (S N0) / INR (fact (S N))) with (/ Rsqr (INR (fact (S N0)))).
+  rewrite H5; rewrite div2_double.
+  right; reflexivity.
+  unfold Rsqr, C, Rdiv in |- *.
+  repeat rewrite Rinv_mult_distr.
+  replace (S N - S N0)%nat with (S N0).
+  rewrite (Rmult_comm (INR (fact (S N)))).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; reflexivity.
+  apply INR_fact_neq_0.
+  replace (S N) with (S N0 + S N0)%nat.
+  symmetry  in |- *; apply minus_plus.
+  rewrite H5; ring.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  rewrite H4; ring.
+  unfold C, Rdiv in |- *.
+  rewrite (Rmult_comm (INR (fact (S N)))).
+  rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; rewrite Rinv_mult_distr.
+  reflexivity.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  unfold maj_Reste_E in |- *.
+  unfold Rdiv in |- *; rewrite (Rmult_comm 4).
+  rewrite Rmult_assoc.
+  apply Rmult_le_compat_l.
+  apply pow_le.
+  apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  apply RmaxLess1.
+  apply Rle_trans with
+    (sum_f_R0 (fun k:nat => INR (N - k) * / Rsqr (INR (fact (div2 (S N)))))
+      (pred N)).
+  apply sum_Rle; intros.
+  rewrite sum_cte.
+  replace (S (pred (N - n))) with (N - n)%nat.
+  right; apply Rmult_comm.
+  apply S_pred with 0%nat.
+  apply plus_lt_reg_l with n.
+  rewrite <- le_plus_minus.
+  replace (n + 0)%nat with n; [ idtac | ring ].
+  apply le_lt_trans with (pred N).
+  apply H0.
+  apply lt_pred_n_n.
+  apply H.
+  apply le_trans with (pred N).
+  apply H0.
+  apply le_pred_n.
+  apply Rle_trans with
+    (sum_f_R0 (fun k:nat => INR N * / Rsqr (INR (fact (div2 (S N))))) (pred N)).
+  apply sum_Rle; intros.
+  do 2 rewrite <- (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt.
+  apply INR_fact_neq_0.
+  apply le_INR.
+  apply (fun p n m:nat => plus_le_reg_l n m p) with n.
+  rewrite <- le_plus_minus.
+  apply le_plus_r.
+  apply le_trans with (pred N).
+  apply H0.
+  apply le_pred_n.
+  rewrite sum_cte; replace (S (pred N)) with N.
+  cut (div2 (S N) = S (div2 (pred N))).
+  intro; rewrite H0.
+  rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR; rewrite Rsqr_mult.
+  rewrite Rinv_mult_distr.
+  rewrite (Rmult_comm (INR N)); repeat rewrite Rmult_assoc;
+    apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
+  rewrite <- H0.
+  cut (INR N <= INR (2 * div2 (S N))).
+  intro; apply Rmult_le_reg_l with (Rsqr (INR (div2 (S N)))).
+  apply Rsqr_pos_lt.
+  apply not_O_INR; red in |- *; intro.
+  cut (1 < S N)%nat.
+  intro; assert (H4 := div2_not_R0 _ H3).
+  rewrite H2 in H4; elim (lt_n_O _ H4).
+  apply lt_n_S; apply H.
+  repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l.
+  replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ].
+  rewrite Rmult_assoc.
+  rewrite Rmult_comm.
+  replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
+  rewrite <- Rsqr_mult.
+  apply Rsqr_incr_1.
+  replace 2 with (INR 2).
+  rewrite <- mult_INR; apply H1.
+  reflexivity.
+  left; apply lt_INR_0; apply H.
+  left; apply Rmult_lt_0_compat.
+  prove_sup0.
+  apply lt_INR_0; apply div2_not_R0.
+  apply lt_n_S; apply H.
+  cut (1 < S N)%nat.
+  intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro;
+    assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; 
+      elim (lt_n_O _ H4).
+  apply lt_n_S; apply H.
+  assert (H1 := even_odd_cor N).
+  elim H1; intros N0 H2.
+  elim H2; intro.
+  pattern N at 2 in |- *; rewrite H3.
+  rewrite div2_S_double.
+  right; rewrite H3; reflexivity.
+  pattern N at 2 in |- *; rewrite H3.
+  replace (S (S (2 * N0))) with (2 * S N0)%nat.
+  rewrite div2_double.
+  rewrite H3.
+  rewrite S_INR; do 2 rewrite mult_INR.
+  rewrite (S_INR N0).
+  rewrite Rmult_plus_distr_l.
+  apply Rplus_le_compat_l.
+  rewrite Rmult_1_r.
+  simpl in |- *.
+  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+    apply Rlt_0_1.
+  ring.
+  unfold Rsqr in |- *; apply prod_neq_R0; apply INR_fact_neq_0.
+  unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; discriminate.
+  assert (H0 := even_odd_cor N).
+  elim H0; intros N0 H1.
+  elim H1; intro.
+  cut (0 < N0)%nat.
+  intro; rewrite H2.
+  rewrite div2_S_double.
+  replace (2 * N0)%nat with (S (S (2 * pred N0))).
+  replace (pred (S (S (2 * pred N0)))) with (S (2 * pred N0)).
+  rewrite div2_S_double.
+  apply S_pred with 0%nat; apply H3.
+  reflexivity.
+  omega.
+  omega.
+  rewrite H2.
+  replace (pred (S (2 * N0))) with (2 * N0)%nat; [ idtac | reflexivity ].
+  replace (S (S (2 * N0))) with (2 * S N0)%nat.
+  do 2 rewrite div2_double.
+  reflexivity.
+  ring.
+  apply S_pred with 0%nat; apply H.
 Qed.
 
 Lemma maj_Reste_cv_R0 : forall x y:R, Un_cv (maj_Reste_E x y) 0.
-intros; assert (H := Majxy_cv_R0 x y).
-unfold Un_cv in H; unfold Un_cv in |- *; intros.
-cut (0 < eps / 4);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
-elim (H _ H1); intros N0 H2.
-exists (max (2 * S N0) 2); intros.
-unfold R_dist in H2; unfold R_dist in |- *; rewrite Rminus_0_r;
- unfold Majxy in H2; unfold maj_Reste_E in |- *.
-rewrite Rabs_right.
-apply Rle_lt_trans with
- (4 *
+Proof.
+  intros; assert (H := Majxy_cv_R0 x y).
+  unfold Un_cv in H; unfold Un_cv in |- *; intros.
+  cut (0 < eps / 4);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (H _ H1); intros N0 H2.
+  exists (max (2 * S N0) 2); intros.
+  unfold R_dist in H2; unfold R_dist in |- *; rewrite Rminus_0_r;
+    unfold Majxy in H2; unfold maj_Reste_E in |- *.
+  rewrite Rabs_right.
+  apply Rle_lt_trans with
+    (4 *
+      (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
+        INR (fact (div2 (pred n))))).
+  apply Rmult_le_compat_l.
+  left; prove_sup0.
+  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+  rewrite (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)));
+    rewrite
+      (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n)))))
+      ; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Rle_trans with (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)).
+  rewrite Rmult_comm;
+    pattern (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)) at 2 in |- *;
+      rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
+  apply pow_le; apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  apply RmaxLess1.
+  apply Rmult_le_reg_l with (INR (fact (div2 (pred n)))).
+  apply INR_fact_lt_0.
+  rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
+  replace 1 with (INR 1); [ apply le_INR | reflexivity ].
+  apply lt_le_S.
+  apply INR_lt.
+  apply INR_fact_lt_0.
+  apply INR_fact_neq_0.
+  apply Rle_pow.
+  apply RmaxLess1.
+  assert (H4 := even_odd_cor n).
+  elim H4; intros N1 H5.
+  elim H5; intro.
+  cut (0 < N1)%nat.
+  intro.
+  rewrite H6.
+  replace (pred (2 * N1)) with (S (2 * pred N1)).
+  rewrite div2_S_double.
+  omega.
+  omega.
+  assert (0 < n)%nat.
+  apply lt_le_trans with 2%nat.
+  apply lt_O_Sn.
+  apply le_trans with (max (2 * S N0) 2).
+  apply le_max_r.
+  apply H3.
+  omega.
+  rewrite H6.
+  replace (pred (S (2 * N1))) with (2 * N1)%nat.
+  rewrite div2_double.
+  replace (4 * S N1)%nat with (2 * (2 * S N1))%nat.
+  apply (fun m n p:nat => mult_le_compat_l p n m).
+  replace (2 * S N1)%nat with (S (S (2 * N1))).
+  apply le_n_Sn.
+  ring.
+  ring.
+  reflexivity.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply Rmult_lt_reg_l with (/ 4).
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite Rmult_comm.
+  replace
   (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
-   INR (fact (div2 (pred n))))).
-apply Rmult_le_compat_l.
-left; prove_sup0.
-unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
-rewrite (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)));
- rewrite
-  (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n)))))
-  ; rewrite Rmult_assoc; apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Rle_trans with (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)).
-rewrite Rmult_comm;
- pattern (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)) at 2 in |- *;
- rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
-apply pow_le; apply Rle_trans with 1.
-left; apply Rlt_0_1.
-apply RmaxLess1.
-apply Rmult_le_reg_l with (INR (fact (div2 (pred n)))).
-apply INR_fact_lt_0.
-rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
-replace 1 with (INR 1); [ apply le_INR | reflexivity ].
-apply lt_le_S.
-apply INR_lt.
-apply INR_fact_lt_0.
-apply INR_fact_neq_0.
-apply Rle_pow.
-apply RmaxLess1.
-assert (H4 := even_odd_cor n).
-elim H4; intros N1 H5.
-elim H5; intro.
-cut (0 < N1)%nat.
-intro.
-rewrite H6.
-replace (pred (2 * N1)) with (S (2 * pred N1)).
-rewrite div2_S_double.
-replace (S (pred N1)) with N1.
-apply INR_le.
-right.
-do 3 rewrite mult_INR; repeat rewrite S_INR; ring.
-apply S_pred with 0%nat; apply H7.
-replace (2 * N1)%nat with (S (S (2 * pred N1))).
-reflexivity.
-pattern N1 at 2 in |- *; replace N1 with (S (pred N1)).
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-symmetry  in |- *; apply S_pred with 0%nat; apply H7.
-apply INR_lt.
-apply Rmult_lt_reg_l with (INR 2).
-simpl in |- *; prove_sup0.
-rewrite Rmult_0_r; rewrite <- mult_INR.
-apply lt_INR_0.
-rewrite <- H6.
-apply lt_le_trans with 2%nat.
-apply lt_O_Sn.
-apply le_trans with (max (2 * S N0) 2).
-apply le_max_r.
-apply H3.
-rewrite H6.
-replace (pred (S (2 * N1))) with (2 * N1)%nat.
-rewrite div2_double.
-replace (4 * S N1)%nat with (2 * (2 * S N1))%nat.
-apply (fun m n p:nat => mult_le_compat_l p n m).
-replace (2 * S N1)%nat with (S (S (2 * N1))).
-apply le_n_Sn.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-ring.
-reflexivity.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply Rmult_lt_reg_l with (/ 4).
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; rewrite Rmult_comm.
-replace
- (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
-  INR (fact (div2 (pred n)))) with
- (Rabs
+    INR (fact (div2 (pred n)))) with
+  (Rabs
     (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
-     INR (fact (div2 (pred n))) - 0)).
-apply H2; unfold ge in |- *.
-cut (2 * S N0 <= n)%nat.
-intro; apply le_S_n.
-apply INR_le; apply Rmult_le_reg_l with (INR 2).
-simpl in |- *; prove_sup0.
-do 2 rewrite <- mult_INR; apply le_INR.
-apply le_trans with n.
-apply H4.
-assert (H5 := even_odd_cor n).
-elim H5; intros N1 H6.
-elim H6; intro.
-cut (0 < N1)%nat.
-intro.
-rewrite H7.
-apply (fun m n p:nat => mult_le_compat_l p n m).
-replace (pred (2 * N1)) with (S (2 * pred N1)).
-rewrite div2_S_double.
-replace (S (pred N1)) with N1.
-apply le_n.
-apply S_pred with 0%nat; apply H8.
-replace (2 * N1)%nat with (S (S (2 * pred N1))).
-reflexivity.
-pattern N1 at 2 in |- *; replace N1 with (S (pred N1)).
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-symmetry  in |- *; apply S_pred with 0%nat; apply H8.
-apply INR_lt.
-apply Rmult_lt_reg_l with (INR 2).
-simpl in |- *; prove_sup0.
-rewrite Rmult_0_r; rewrite <- mult_INR.
-apply lt_INR_0.
-rewrite <- H7.
-apply lt_le_trans with 2%nat.
-apply lt_O_Sn.
-apply le_trans with (max (2 * S N0) 2).
-apply le_max_r.
-apply H3.
-rewrite H7.
-replace (pred (S (2 * N1))) with (2 * N1)%nat.
-rewrite div2_double.
-replace (2 * S N1)%nat with (S (S (2 * N1))).
-apply le_n_Sn.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-reflexivity.
-apply le_trans with (max (2 * S N0) 2).
-apply le_max_l.
-apply H3.
-rewrite Rminus_0_r; apply Rabs_right.
-apply Rle_ge.
-unfold Rdiv in |- *; repeat apply Rmult_le_pos.
-apply pow_le.
-apply Rle_trans with 1.
-left; apply Rlt_0_1.
-apply RmaxLess1.
-left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-discrR.
-apply Rle_ge.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-left; prove_sup0.
-apply Rmult_le_pos.
-apply pow_le.
-apply Rle_trans with 1.
-left; apply Rlt_0_1.
-apply RmaxLess1.
-left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
+      INR (fact (div2 (pred n))) - 0)).
+  apply H2; unfold ge in |- *.
+  cut (2 * S N0 <= n)%nat.
+  intro; apply le_S_n.
+  apply INR_le; apply Rmult_le_reg_l with (INR 2).
+  simpl in |- *; prove_sup0.
+  do 2 rewrite <- mult_INR; apply le_INR.
+  apply le_trans with n.
+  apply H4.
+  assert (H5 := even_odd_cor n).
+  elim H5; intros N1 H6.
+  elim H6; intro.
+  cut (0 < N1)%nat.
+  intro.
+  rewrite H7.
+  apply (fun m n p:nat => mult_le_compat_l p n m).
+  replace (pred (2 * N1)) with (S (2 * pred N1)).
+  rewrite div2_S_double.
+  replace (S (pred N1)) with N1.
+  apply le_n.
+  apply S_pred with 0%nat; apply H8.
+  replace (2 * N1)%nat with (S (S (2 * pred N1))).
+  reflexivity.
+  pattern N1 at 2 in |- *; replace N1 with (S (pred N1)).
+  ring.
+  symmetry  in |- *; apply S_pred with 0%nat; apply H8.
+  apply INR_lt.
+  apply Rmult_lt_reg_l with (INR 2).
+  simpl in |- *; prove_sup0.
+  rewrite Rmult_0_r; rewrite <- mult_INR.
+  apply lt_INR_0.
+  rewrite <- H7.
+  apply lt_le_trans with 2%nat.
+  apply lt_O_Sn.
+  apply le_trans with (max (2 * S N0) 2).
+  apply le_max_r.
+  apply H3.
+  rewrite H7.
+  replace (pred (S (2 * N1))) with (2 * N1)%nat.
+  rewrite div2_double.
+  replace (2 * S N1)%nat with (S (S (2 * N1))).
+  apply le_n_Sn.
+  ring.
+  reflexivity.
+  apply le_trans with (max (2 * S N0) 2).
+  apply le_max_l.
+  apply H3.
+  rewrite Rminus_0_r; apply Rabs_right.
+  apply Rle_ge.
+  unfold Rdiv in |- *; repeat apply Rmult_le_pos.
+  apply pow_le.
+  apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  apply RmaxLess1.
+  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  discrR.
+  apply Rle_ge.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  left; prove_sup0.
+  apply Rmult_le_pos.
+  apply pow_le.
+  apply Rle_trans with 1.
+  left; apply Rlt_0_1.
+  apply RmaxLess1.
+  left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
 Qed.
 
 (**********)
 Lemma Reste_E_cv : forall x y:R, Un_cv (Reste_E x y) 0.
-intros; assert (H := maj_Reste_cv_R0 x y).
-unfold Un_cv in H; unfold Un_cv in |- *; intros; elim (H _ H0); intros.
-exists (max x0 1); intros.
-unfold R_dist in |- *; rewrite Rminus_0_r.
-apply Rle_lt_trans with (maj_Reste_E x y n).
-apply Reste_E_maj.
-apply lt_le_trans with 1%nat.
-apply lt_O_Sn.
-apply le_trans with (max x0 1).
-apply le_max_r.
-apply H2.
-replace (maj_Reste_E x y n) with (R_dist (maj_Reste_E x y n) 0).
-apply H1.
-unfold ge in |- *; apply le_trans with (max x0 1).
-apply le_max_l.
-apply H2.
-unfold R_dist in |- *; rewrite Rminus_0_r; apply Rabs_right.
-apply Rle_ge; apply Rle_trans with (Rabs (Reste_E x y n)).
-apply Rabs_pos.
-apply Reste_E_maj.
-apply lt_le_trans with 1%nat.
-apply lt_O_Sn.
-apply le_trans with (max x0 1).
-apply le_max_r.
-apply H2.
+Proof.
+  intros; assert (H := maj_Reste_cv_R0 x y).
+  unfold Un_cv in H; unfold Un_cv in |- *; intros; elim (H _ H0); intros.
+  exists (max x0 1); intros.
+  unfold R_dist in |- *; rewrite Rminus_0_r.
+  apply Rle_lt_trans with (maj_Reste_E x y n).
+  apply Reste_E_maj.
+  apply lt_le_trans with 1%nat.
+  apply lt_O_Sn.
+  apply le_trans with (max x0 1).
+  apply le_max_r.
+  apply H2.
+  replace (maj_Reste_E x y n) with (R_dist (maj_Reste_E x y n) 0).
+  apply H1.
+  unfold ge in |- *; apply le_trans with (max x0 1).
+  apply le_max_l.
+  apply H2.
+  unfold R_dist in |- *; rewrite Rminus_0_r; apply Rabs_right.
+  apply Rle_ge; apply Rle_trans with (Rabs (Reste_E x y n)).
+  apply Rabs_pos.
+  apply Reste_E_maj.
+  apply lt_le_trans with 1%nat.
+  apply lt_O_Sn.
+  apply le_trans with (max x0 1).
+  apply le_max_r.
+  apply H2.
 Qed.
 
 (**********)
 Lemma exp_plus : forall x y:R, exp (x + y) = exp x * exp y.
-intros; assert (H0 := E1_cvg x).
-assert (H := E1_cvg y).
-assert (H1 := E1_cvg (x + y)).
-eapply UL_sequence.
-apply H1.
-assert (H2 := CV_mult _ _ _ _ H0 H).
-assert (H3 := CV_minus _ _ _ _ H2 (Reste_E_cv x y)).
-unfold Un_cv in |- *; unfold Un_cv in H3; intros.
-elim (H3 _ H4); intros.
-exists (S x0); intros.
-rewrite <- (exp_form x y n).
-rewrite Rminus_0_r in H5.
-apply H5.
-unfold ge in |- *; apply le_trans with (S x0).
-apply le_n_Sn.
-apply H6.
-apply lt_le_trans with (S x0).
-apply lt_O_Sn.
-apply H6.
+Proof.
+  intros; assert (H0 := E1_cvg x).
+  assert (H := E1_cvg y).
+  assert (H1 := E1_cvg (x + y)).
+  eapply UL_sequence.
+  apply H1.
+  assert (H2 := CV_mult _ _ _ _ H0 H).
+  assert (H3 := CV_minus _ _ _ _ H2 (Reste_E_cv x y)).
+  unfold Un_cv in |- *; unfold Un_cv in H3; intros.
+  elim (H3 _ H4); intros.
+  exists (S x0); intros.
+  rewrite <- (exp_form x y n).
+  rewrite Rminus_0_r in H5.
+  apply H5.
+  unfold ge in |- *; apply le_trans with (S x0).
+  apply le_n_Sn.
+  apply H6.
+  apply lt_le_trans with (S x0).
+  apply lt_O_Sn.
+  apply H6.
 Qed.
 
 (**********)
 Lemma exp_pos_pos : forall x:R, 0 < x -> 0 < exp x.
-intros; set (An := fun N:nat => / INR (fact N) * x ^ N).
-cut (Un_cv (fun n:nat => sum_f_R0 An n) (exp x)).
-intro; apply Rlt_le_trans with (sum_f_R0 An 0).
-unfold An in |- *; simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r;
- apply Rlt_0_1.
-apply sum_incr.
-assumption.
-intro; unfold An in |- *; left; apply Rmult_lt_0_compat.
-apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply (pow_lt _ n H).
-unfold exp in |- *; unfold projT1 in |- *; case (exist_exp x); intro.
-unfold exp_in in |- *; unfold infinit_sum, Un_cv in |- *; trivial.
+Proof.
+  intros; set (An := fun N:nat => / INR (fact N) * x ^ N).
+  cut (Un_cv (fun n:nat => sum_f_R0 An n) (exp x)).
+  intro; apply Rlt_le_trans with (sum_f_R0 An 0).
+  unfold An in |- *; simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r;
+    apply Rlt_0_1.
+  apply sum_incr.
+  assumption.
+  intro; unfold An in |- *; left; apply Rmult_lt_0_compat.
+  apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply (pow_lt _ n H).
+  unfold exp in |- *; unfold projT1 in |- *; case (exist_exp x); intro.
+  unfold exp_in in |- *; unfold infinit_sum, Un_cv in |- *; trivial.
 Qed.
 
 (**********)
 Lemma exp_pos : forall x:R, 0 < exp x.
-intro; case (total_order_T 0 x); intro.
-elim s; intro.
-apply (exp_pos_pos _ a).
-rewrite <- b; rewrite exp_0; apply Rlt_0_1.
-replace (exp x) with (1 / exp (- x)).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply Rlt_0_1.
-apply Rinv_0_lt_compat; apply exp_pos_pos.
-apply (Ropp_0_gt_lt_contravar _ r).
-cut (exp (- x) <> 0).
-intro; unfold Rdiv in |- *; apply Rmult_eq_reg_l with (exp (- x)).
-rewrite Rmult_1_l; rewrite <- Rinv_r_sym.
-rewrite <- exp_plus.
-rewrite Rplus_opp_l; rewrite exp_0; reflexivity.
-apply H.
-apply H.
-assert (H := exp_plus x (- x)).
-rewrite Rplus_opp_r in H; rewrite exp_0 in H.
-red in |- *; intro; rewrite H0 in H.
-rewrite Rmult_0_r in H.
-elim R1_neq_R0; assumption.
+Proof.
+  intro; case (total_order_T 0 x); intro.
+  elim s; intro.
+  apply (exp_pos_pos _ a).
+  rewrite <- b; rewrite exp_0; apply Rlt_0_1.
+  replace (exp x) with (1 / exp (- x)).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply Rlt_0_1.
+  apply Rinv_0_lt_compat; apply exp_pos_pos.
+  apply (Ropp_0_gt_lt_contravar _ r).
+  cut (exp (- x) <> 0).
+  intro; unfold Rdiv in |- *; apply Rmult_eq_reg_l with (exp (- x)).
+  rewrite Rmult_1_l; rewrite <- Rinv_r_sym.
+  rewrite <- exp_plus.
+  rewrite Rplus_opp_l; rewrite exp_0; reflexivity.
+  apply H.
+  apply H.
+  assert (H := exp_plus x (- x)).
+  rewrite Rplus_opp_r in H; rewrite exp_0 in H.
+  red in |- *; intro; rewrite H0 in H.
+  rewrite Rmult_0_r in H.
+  elim R1_neq_R0; assumption.
 Qed.
 
 (* ((exp h)-1)/h -> 0 quand h->0 *)
 Lemma derivable_pt_lim_exp_0 : derivable_pt_lim exp 0 1.
-unfold derivable_pt_lim in |- *; intros.
-set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))).
-cut (CVN_R fn).
-intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
-intro cv; cut (forall n:nat, continuity (fn n)).
-intro; cut (continuity (SFL fn cv)).
-intro; unfold continuity in H1.
-assert (H2 := H1 0).
-unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
- unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
-elim (H2 _ H); intros alp H3.
-elim H3; intros.
-exists (mkposreal _ H4); intros.
-rewrite Rplus_0_l; rewrite exp_0.
-replace ((exp h - 1) / h) with (SFL fn cv h).
-replace 1 with (SFL fn cv 0).
-apply H5.
-split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-apply (sym_not_eq H6).
-rewrite Rminus_0_r; apply H7.
-unfold SFL in |- *.
-case (cv 0); intros.
-eapply UL_sequence.
-apply u.
-unfold Un_cv, SP in |- *.
-intros; exists 1%nat; intros.
-unfold R_dist in |- *; rewrite decomp_sum.
-rewrite (Rplus_comm (fn 0%nat 0)).
-replace (fn 0%nat 0) with 1.
-unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r;
- rewrite Rplus_0_r.
-replace (sum_f_R0 (fun i:nat => fn (S i) 0) (pred n)) with 0.
-rewrite Rabs_R0; apply H8.
-symmetry  in |- *; apply sum_eq_R0; intros.
-unfold fn in |- *.
-simpl in |- *.
-unfold Rdiv in |- *; do 2 rewrite Rmult_0_l; reflexivity.
-unfold fn in |- *; simpl in |- *.
-unfold Rdiv in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
-apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ].
-unfold SFL, exp in |- *.
-unfold projT1 in |- *.
-case (cv h); case (exist_exp h); intros.
-eapply UL_sequence.
-apply u.
-unfold Un_cv in |- *; intros.
-unfold exp_in in e.
-unfold infinit_sum in e.
-cut (0 < eps0 * Rabs h).
-intro; elim (e _ H9); intros N0 H10.
-exists N0; intros.
-unfold R_dist in |- *.
-apply Rmult_lt_reg_l with (Rabs h).
-apply Rabs_pos_lt; assumption.
-rewrite <- Rabs_mult.
-rewrite Rmult_minus_distr_l.
-replace (h * ((x - 1) / h)) with (x - 1).
-unfold R_dist in H10.
-replace (h * SP fn n h - (x - 1)) with
- (sum_f_R0 (fun i:nat => / INR (fact i) * h ^ i) (S n) - x).
-rewrite (Rmult_comm (Rabs h)).
-apply H10.
-unfold ge in |- *.
-apply le_trans with (S N0).
-apply le_n_Sn.
-apply le_n_S; apply H11.
-rewrite decomp_sum.
-replace (/ INR (fact 0) * h ^ 0) with 1.
-unfold Rminus in |- *.
-rewrite Ropp_plus_distr.
-rewrite Ropp_involutive.
-rewrite <- (Rplus_comm (- x)).
-rewrite <- (Rplus_comm (- x + 1)).
-rewrite Rplus_assoc; repeat apply Rplus_eq_compat_l.
-replace (pred (S n)) with n; [ idtac | reflexivity ].
-unfold SP in |- *.
-rewrite scal_sum.
-apply sum_eq; intros.
-unfold fn in |- *.
-replace (h ^ S i) with (h * h ^ i).
-unfold Rdiv in |- *; ring.
-simpl in |- *; ring.
-simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
-apply lt_O_Sn.
-unfold Rdiv in |- *.
-rewrite <- Rmult_assoc.
-symmetry  in |- *; apply Rinv_r_simpl_m.
-assumption.
-apply Rmult_lt_0_compat.
-apply H8.
-apply Rabs_pos_lt; assumption.
-apply SFL_continuity; assumption.
-intro; unfold fn in |- *.
-replace (fun x:R => x ^ n / INR (fact (S n))) with
- (pow_fct n / fct_cte (INR (fact (S n))))%F; [ idtac | reflexivity ].
-apply continuity_div.
-apply derivable_continuous; apply (derivable_pow n).
-apply derivable_continuous; apply derivable_const.
-intro; unfold fct_cte in |- *; apply INR_fact_neq_0.
-apply (CVN_R_CVS _ X).
-assert (H0 := Alembert_exp).
-unfold CVN_R in |- *.
-intro; unfold CVN_r in |- *.
-apply existT with (fun N:nat => r ^ N / INR (fact (S N))).
-cut
- (sigT
-    (fun l:R =>
-       Un_cv
-         (fun n:nat =>
-            sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l)).
-intro.
-elim X; intros.
-exists x; intros.
-split.
-apply p.
-unfold Boule in |- *; intros.
-rewrite Rminus_0_r in H1.
-unfold fn in |- *.
-unfold Rdiv in |- *; rewrite Rabs_mult.
-cut (0 < INR (fact (S n))).
-intro.
-rewrite (Rabs_right (/ INR (fact (S n)))).
-do 2 rewrite <- (Rmult_comm (/ INR (fact (S n)))).
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply H2.
-rewrite <- RPow_abs.
-apply pow_maj_Rabs.
-rewrite Rabs_Rabsolu; left; apply H1.
-apply Rle_ge; left; apply Rinv_0_lt_compat; apply H2.
-apply INR_fact_lt_0.
-cut ((r:R) <> 0).
-intro; apply Alembert_C2.
-intro; apply Rabs_no_R0.
-unfold Rdiv in |- *; apply prod_neq_R0.
-apply pow_nonzero; assumption.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-unfold Un_cv in H0.
-unfold Un_cv in |- *; intros.
-cut (0 < eps0 / r);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; apply (cond_pos r) ] ].
-elim (H0 _ H3); intros N0 H4.
-exists N0; intros.
-cut (S n >= N0)%nat.
-intro hyp_sn.
-assert (H6 := H4 _ hyp_sn).
-unfold R_dist in H6; rewrite Rminus_0_r in H6.
-rewrite Rabs_Rabsolu in H6.
-unfold R_dist in |- *; rewrite Rminus_0_r.
-rewrite Rabs_Rabsolu.
-replace
- (Rabs (r ^ S n / INR (fact (S (S n)))) / Rabs (r ^ n / INR (fact (S n))))
- with (r * / INR (fact (S (S n))) * / / INR (fact (S n))).
-rewrite Rmult_assoc; rewrite Rabs_mult.
-rewrite (Rabs_right r).
-apply Rmult_lt_reg_l with (/ r).
-apply Rinv_0_lt_compat; apply (cond_pos r).
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; rewrite <- (Rmult_comm eps0).
-apply H6.
-assumption.
-apply Rle_ge; left; apply (cond_pos r).
-unfold Rdiv in |- *.
-repeat rewrite Rabs_mult.
-repeat rewrite Rabs_Rinv.
-rewrite Rinv_mult_distr.
-repeat rewrite Rabs_right.
-rewrite Rinv_involutive.
-rewrite (Rmult_comm r).
-rewrite (Rmult_comm (r ^ S n)).
-repeat rewrite Rmult_assoc.
-apply Rmult_eq_compat_l.
-rewrite (Rmult_comm r).
-rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (INR (fact (S n)))).
-apply Rmult_eq_compat_l.
-simpl in |- *.
-rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-ring.
-apply pow_nonzero; assumption.
-apply INR_fact_neq_0.
-apply Rle_ge; left; apply INR_fact_lt_0.
-apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
-apply Rle_ge; left; apply INR_fact_lt_0.
-apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
-apply Rabs_no_R0; apply pow_nonzero; assumption.
-apply Rinv_neq_0_compat; apply Rabs_no_R0; apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-unfold ge in |- *; apply le_trans with n.
-apply H5.
-apply le_n_Sn.
-assert (H1 := cond_pos r); red in |- *; intro; rewrite H2 in H1;
- elim (Rlt_irrefl _ H1).
+Proof.
+  unfold derivable_pt_lim in |- *; intros.
+  set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))).
+  cut (CVN_R fn).
+  intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
+  intro cv; cut (forall n:nat, continuity (fn n)).
+  intro; cut (continuity (SFL fn cv)).
+  intro; unfold continuity in H1.
+  assert (H2 := H1 0).
+  unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
+    unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
+  elim (H2 _ H); intros alp H3.
+  elim H3; intros.
+  exists (mkposreal _ H4); intros.
+  rewrite Rplus_0_l; rewrite exp_0.
+  replace ((exp h - 1) / h) with (SFL fn cv h).
+  replace 1 with (SFL fn cv 0).
+  apply H5.
+  split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  apply (sym_not_eq H6).
+  rewrite Rminus_0_r; apply H7.
+  unfold SFL in |- *.
+  case (cv 0); intros.
+  eapply UL_sequence.
+  apply u.
+  unfold Un_cv, SP in |- *.
+  intros; exists 1%nat; intros.
+  unfold R_dist in |- *; rewrite decomp_sum.
+  rewrite (Rplus_comm (fn 0%nat 0)).
+  replace (fn 0%nat 0) with 1.
+  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r;
+    rewrite Rplus_0_r.
+  replace (sum_f_R0 (fun i:nat => fn (S i) 0) (pred n)) with 0.
+  rewrite Rabs_R0; apply H8.
+  symmetry  in |- *; apply sum_eq_R0; intros.
+  unfold fn in |- *.
+  simpl in |- *.
+  unfold Rdiv in |- *; do 2 rewrite Rmult_0_l; reflexivity.
+  unfold fn in |- *; simpl in |- *.
+  unfold Rdiv in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
+  apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ].
+  unfold SFL, exp in |- *.
+  unfold projT1 in |- *.
+  case (cv h); case (exist_exp h); intros.
+  eapply UL_sequence.
+  apply u.
+  unfold Un_cv in |- *; intros.
+  unfold exp_in in e.
+  unfold infinit_sum in e.
+  cut (0 < eps0 * Rabs h).
+  intro; elim (e _ H9); intros N0 H10.
+  exists N0; intros.
+  unfold R_dist in |- *.
+  apply Rmult_lt_reg_l with (Rabs h).
+  apply Rabs_pos_lt; assumption.
+  rewrite <- Rabs_mult.
+  rewrite Rmult_minus_distr_l.
+  replace (h * ((x - 1) / h)) with (x - 1).
+  unfold R_dist in H10.
+  replace (h * SP fn n h - (x - 1)) with
+  (sum_f_R0 (fun i:nat => / INR (fact i) * h ^ i) (S n) - x).
+  rewrite (Rmult_comm (Rabs h)).
+  apply H10.
+  unfold ge in |- *.
+  apply le_trans with (S N0).
+  apply le_n_Sn.
+  apply le_n_S; apply H11.
+  rewrite decomp_sum.
+  replace (/ INR (fact 0) * h ^ 0) with 1.
+  unfold Rminus in |- *.
+  rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  rewrite <- (Rplus_comm (- x)).
+  rewrite <- (Rplus_comm (- x + 1)).
+  rewrite Rplus_assoc; repeat apply Rplus_eq_compat_l.
+  replace (pred (S n)) with n; [ idtac | reflexivity ].
+  unfold SP in |- *.
+  rewrite scal_sum.
+  apply sum_eq; intros.
+  unfold fn in |- *.
+  replace (h ^ S i) with (h * h ^ i).
+  unfold Rdiv in |- *; ring.
+  simpl in |- *; ring.
+  simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
+  apply lt_O_Sn.
+  unfold Rdiv in |- *.
+  rewrite <- Rmult_assoc.
+  symmetry  in |- *; apply Rinv_r_simpl_m.
+  assumption.
+  apply Rmult_lt_0_compat.
+  apply H8.
+  apply Rabs_pos_lt; assumption.
+  apply SFL_continuity; assumption.
+  intro; unfold fn in |- *.
+  replace (fun x:R => x ^ n / INR (fact (S n))) with
+  (pow_fct n / fct_cte (INR (fact (S n))))%F; [ idtac | reflexivity ].
+  apply continuity_div.
+  apply derivable_continuous; apply (derivable_pow n).
+  apply derivable_continuous; apply derivable_const.
+  intro; unfold fct_cte in |- *; apply INR_fact_neq_0.
+  apply (CVN_R_CVS _ X).
+  assert (H0 := Alembert_exp).
+  unfold CVN_R in |- *.
+  intro; unfold CVN_r in |- *.
+  apply existT with (fun N:nat => r ^ N / INR (fact (S N))).
+  cut
+    (sigT
+      (fun l:R =>
+        Un_cv
+        (fun n:nat =>
+          sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l)).
+  intro X.
+  elim X; intros.
+  exists x; intros.
+  split.
+  apply p.
+  unfold Boule in |- *; intros.
+  rewrite Rminus_0_r in H1.
+  unfold fn in |- *.
+  unfold Rdiv in |- *; rewrite Rabs_mult.
+  cut (0 < INR (fact (S n))).
+  intro.
+  rewrite (Rabs_right (/ INR (fact (S n)))).
+  do 2 rewrite <- (Rmult_comm (/ INR (fact (S n)))).
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply H2.
+  rewrite <- RPow_abs.
+  apply pow_maj_Rabs.
+  rewrite Rabs_Rabsolu; left; apply H1.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; apply H2.
+  apply INR_fact_lt_0.
+  cut ((r:R) <> 0).
+  intro; apply Alembert_C2.
+  intro; apply Rabs_no_R0.
+  unfold Rdiv in |- *; apply prod_neq_R0.
+  apply pow_nonzero; assumption.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  unfold Un_cv in H0.
+  unfold Un_cv in |- *; intros.
+  cut (0 < eps0 / r);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ assumption | apply Rinv_0_lt_compat; apply (cond_pos r) ] ].
+  elim (H0 _ H3); intros N0 H4.
+  exists N0; intros.
+  cut (S n >= N0)%nat.
+  intro hyp_sn.
+  assert (H6 := H4 _ hyp_sn).
+  unfold R_dist in H6; rewrite Rminus_0_r in H6.
+  rewrite Rabs_Rabsolu in H6.
+  unfold R_dist in |- *; rewrite Rminus_0_r.
+  rewrite Rabs_Rabsolu.
+  replace
+  (Rabs (r ^ S n / INR (fact (S (S n)))) / Rabs (r ^ n / INR (fact (S n))))
+    with (r * / INR (fact (S (S n))) * / / INR (fact (S n))).
+  rewrite Rmult_assoc; rewrite Rabs_mult.
+  rewrite (Rabs_right r).
+  apply Rmult_lt_reg_l with (/ r).
+  apply Rinv_0_lt_compat; apply (cond_pos r).
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps0).
+  apply H6.
+  assumption.
+  apply Rle_ge; left; apply (cond_pos r).
+  unfold Rdiv in |- *.
+  repeat rewrite Rabs_mult.
+  repeat rewrite Rabs_Rinv.
+  rewrite Rinv_mult_distr.
+  repeat rewrite Rabs_right.
+  rewrite Rinv_involutive.
+  rewrite (Rmult_comm r).
+  rewrite (Rmult_comm (r ^ S n)).
+  repeat rewrite Rmult_assoc.
+  apply Rmult_eq_compat_l.
+  rewrite (Rmult_comm r).
+  rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (INR (fact (S n)))).
+  apply Rmult_eq_compat_l.
+  simpl in |- *.
+  rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  ring.
+  apply pow_nonzero; assumption.
+  apply INR_fact_neq_0.
+  apply Rle_ge; left; apply INR_fact_lt_0.
+  apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
+  apply Rle_ge; left; apply INR_fact_lt_0.
+  apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
+  apply Rabs_no_R0; apply pow_nonzero; assumption.
+  apply Rinv_neq_0_compat; apply Rabs_no_R0; apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  unfold ge in |- *; apply le_trans with n.
+  apply H5.
+  apply le_n_Sn.
+  assert (H1 := cond_pos r); red in |- *; intro; rewrite H2 in H1;
+    elim (Rlt_irrefl _ H1).
 Qed.
 
 (**********)
 Lemma derivable_pt_lim_exp : forall x:R, derivable_pt_lim exp x (exp x).
-intro; assert (H0 := derivable_pt_lim_exp_0).
-unfold derivable_pt_lim in H0; unfold derivable_pt_lim in |- *; intros.
-cut (0 < eps / exp x);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ apply H | apply Rinv_0_lt_compat; apply exp_pos ] ].
-elim (H0 _ H1); intros del H2.
-exists del; intros.
-assert (H5 := H2 _ H3 H4).
-rewrite Rplus_0_l in H5; rewrite exp_0 in H5.
-replace ((exp (x + h) - exp x) / h - exp x) with
- (exp x * ((exp h - 1) / h - 1)).
-rewrite Rabs_mult; rewrite (Rabs_right (exp x)).
-apply Rmult_lt_reg_l with (/ exp x).
-apply Rinv_0_lt_compat; apply exp_pos.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
-apply H5.
-assert (H6 := exp_pos x); red in |- *; intro; rewrite H7 in H6;
- elim (Rlt_irrefl _ H6).
-apply Rle_ge; left; apply exp_pos.
-rewrite Rmult_minus_distr_l.
-rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
- rewrite Rmult_minus_distr_l.
-rewrite Rmult_1_r; rewrite exp_plus; reflexivity.
-Qed.
\ No newline at end of file
+Proof.
+  intro; assert (H0 := derivable_pt_lim_exp_0).
+  unfold derivable_pt_lim in H0; unfold derivable_pt_lim in |- *; intros.
+  cut (0 < eps / exp x);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ apply H | apply Rinv_0_lt_compat; apply exp_pos ] ].
+  elim (H0 _ H1); intros del H2.
+  exists del; intros.
+  assert (H5 := H2 _ H3 H4).
+  rewrite Rplus_0_l in H5; rewrite exp_0 in H5.
+  replace ((exp (x + h) - exp x) / h - exp x) with
+  (exp x * ((exp h - 1) / h - 1)).
+  rewrite Rabs_mult; rewrite (Rabs_right (exp x)).
+  apply Rmult_lt_reg_l with (/ exp x).
+  apply Rinv_0_lt_compat; apply exp_pos.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
+  apply H5.
+  assert (H6 := exp_pos x); red in |- *; intro; rewrite H7 in H6;
+    elim (Rlt_irrefl _ H6).
+  apply Rle_ge; left; apply exp_pos.
+  rewrite Rmult_minus_distr_l.
+  rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+    rewrite Rmult_minus_distr_l.
+  rewrite Rmult_1_r; rewrite exp_plus; reflexivity.
+Qed.
diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v
index c3c3d9bb..d4f3a8ec 100644
--- a/theories/Reals/Integration.v
+++ b/theories/Reals/Integration.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
  
-(*i $Id: Integration.v,v 1.1.6.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+(*i $Id: Integration.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 Require Export NewtonInt.
 Require Export RiemannInt_SF.
diff --git a/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v
new file mode 100644
index 00000000..b33274af
--- /dev/null
+++ b/theories/Reals/LegacyRfield.v
@@ -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$ i*)
+
+Require Export Raxioms.
+Require Export LegacyField.
+Import LegacyRing_theory.
+
+Section LegacyRfield.
+
+Open Scope R_scope.
+
+Lemma RLegacyTheory : Ring_Theory Rplus Rmult 1 0 Ropp (fun x y:R => false).
+  split.
+  exact Rplus_comm.
+  symmetry  in |- *; apply Rplus_assoc.
+  exact Rmult_comm.
+  symmetry  in |- *; apply Rmult_assoc.
+  intro; apply Rplus_0_l.
+  intro; apply Rmult_1_l.
+  exact Rplus_opp_r.
+  intros.
+  rewrite Rmult_comm.
+  rewrite (Rmult_comm n p).
+  rewrite (Rmult_comm m p).
+  apply Rmult_plus_distr_l.
+  intros; contradiction.
+Defined.
+
+End LegacyRfield.
+
+Add Legacy Field
+R Rplus Rmult 1%R 0%R Ropp (fun x y:R => false) Rinv RLegacyTheory Rinv_l
+  with minus := Rminus div := Rdiv.
diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v
index baa61304..8bb9298a 100644
--- a/theories/Reals/MVT.v
+++ b/theories/Reals/MVT.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: MVT.v,v 1.10.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+(*i $Id: MVT.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -15,685 +15,707 @@ Require Import Rtopology. Open Local Scope R_scope.
 
 (* The Mean Value Theorem *)
 Theorem MVT :
- forall (f g:R -> R) (a b:R) (pr1:forall c:R, a < c < b -> derivable_pt f c)
-   (pr2:forall c:R, a < c < b -> derivable_pt g c),
-   a < b ->
-   (forall c:R, a <= c <= b -> continuity_pt f c) ->
-   (forall c:R, a <= c <= b -> continuity_pt g c) ->
+  forall (f g:R -> R) (a b:R) (pr1:forall c:R, a < c < b -> derivable_pt f c)
+    (pr2:forall c:R, a < c < b -> derivable_pt g c),
+    a < b ->
+    (forall c:R, a <= c <= b -> continuity_pt f c) ->
+    (forall c:R, a <= c <= b -> continuity_pt g c) ->
     exists c : R,
-     (exists P : a < c < b,
+      (exists P : a < c < b,
         (g b - g a) * derive_pt f c (pr1 c P) =
         (f b - f a) * derive_pt g c (pr2 c P)).
-intros; assert (H2 := Rlt_le _ _ H).
-set (h := fun y:R => (g b - g a) * f y - (f b - f a) * g y).
-cut (forall c:R, a < c < b -> derivable_pt h c).
-intro; cut (forall c:R, a <= c <= b -> continuity_pt h c).
-intro; assert (H4 := continuity_ab_maj h a b H2 H3).
-assert (H5 := continuity_ab_min h a b H2 H3).
-elim H4; intros Mx H6.
-elim H5; intros mx H7.
-cut (h a = h b).
-intro; set (M := h Mx); set (m := h mx).
-cut
- (forall (c:R) (P:a < c < b),
-    derive_pt h c (X c P) =
-    (g b - g a) * derive_pt f c (pr1 c P) -
-    (f b - f a) * derive_pt g c (pr2 c P)).
-intro; case (Req_dec (h a) M); intro.
-case (Req_dec (h a) m); intro.
-cut (forall c:R, a <= c <= b -> h c = M).
-intro; cut (a < (a + b) / 2 < b).
+Proof.
+  intros; assert (H2 := Rlt_le _ _ H).
+  set (h := fun y:R => (g b - g a) * f y - (f b - f a) * g y).
+  cut (forall c:R, a < c < b -> derivable_pt h c).
+  intro X; cut (forall c:R, a <= c <= b -> continuity_pt h c).
+  intro; assert (H4 := continuity_ab_maj h a b H2 H3).
+  assert (H5 := continuity_ab_min h a b H2 H3).
+  elim H4; intros Mx H6.
+  elim H5; intros mx H7.
+  cut (h a = h b).
+  intro; set (M := h Mx); set (m := h mx).
+  cut
+    (forall (c:R) (P:a < c < b),
+      derive_pt h c (X c P) =
+      (g b - g a) * derive_pt f c (pr1 c P) -
+      (f b - f a) * derive_pt g c (pr2 c P)).
+  intro; case (Req_dec (h a) M); intro.
+  case (Req_dec (h a) m); intro.
+  cut (forall c:R, a <= c <= b -> h c = M).
+  intro; cut (a < (a + b) / 2 < b).
 (*** h constant ***)
-intro; exists ((a + b) / 2).
-exists H13.
-apply Rminus_diag_uniq; rewrite <- H9; apply deriv_constant2 with a b.
-elim H13; intros; assumption.
-elim H13; intros; assumption.
-intros; rewrite (H12 ((a + b) / 2)).
-apply H12; split; left; assumption.
-elim H13; intros; split; left; assumption.
-split.
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H.
-discrR.
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; rewrite Rplus_comm; rewrite double;
- apply Rplus_lt_compat_l; apply H.
-discrR.
-intros; elim H6; intros H13 _.
-elim H7; intros H14 _.
-apply Rle_antisym.
-apply H13; apply H12.
-rewrite H10 in H11; rewrite H11; apply H14; apply H12.
-cut (a < mx < b).
+  intro; exists ((a + b) / 2).
+  exists H13.
+  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_constant2 with a b.
+  elim H13; intros; assumption.
+  elim H13; intros; assumption.
+  intros; rewrite (H12 ((a + b) / 2)).
+  apply H12; split; left; assumption.
+  elim H13; intros; split; left; assumption.
+  split.
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H.
+  discrR.
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite Rplus_comm; rewrite double;
+    apply Rplus_lt_compat_l; apply H.
+  discrR.
+  intros; elim H6; intros H13 _.
+  elim H7; intros H14 _.
+  apply Rle_antisym.
+  apply H13; apply H12.
+  rewrite H10 in H11; rewrite H11; apply H14; apply H12.
+  cut (a < mx < b).
 (*** h admet un minimum global sur [a,b] ***)
-intro; exists mx.
-exists H12.
-apply Rminus_diag_uniq; rewrite <- H9; apply deriv_minimum with a b.
-elim H12; intros; assumption.
-elim H12; intros; assumption.
-intros; elim H7; intros.
-apply H15; split; left; assumption.
-elim H7; intros _ H12; elim H12; intros; split.
-inversion H13.
-apply H15.
-rewrite H15 in H11; elim H11; reflexivity.
-inversion H14.
-apply H15.
-rewrite H8 in H11; rewrite <- H15 in H11; elim H11; reflexivity.
-cut (a < Mx < b).
+  intro; exists mx.
+  exists H12.
+  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_minimum with a b.
+  elim H12; intros; assumption.
+  elim H12; intros; assumption.
+  intros; elim H7; intros.
+  apply H15; split; left; assumption.
+  elim H7; intros _ H12; elim H12; intros; split.
+  inversion H13.
+  apply H15.
+  rewrite H15 in H11; elim H11; reflexivity.
+  inversion H14.
+  apply H15.
+  rewrite H8 in H11; rewrite <- H15 in H11; elim H11; reflexivity.
+  cut (a < Mx < b).
 (*** h admet un maximum global sur [a,b] ***)
-intro; exists Mx.
-exists H11.
-apply Rminus_diag_uniq; rewrite <- H9; apply deriv_maximum with a b.
-elim H11; intros; assumption.
-elim H11; intros; assumption.
-intros; elim H6; intros; apply H14.
-split; left; assumption.
-elim H6; intros _ H11; elim H11; intros; split.
-inversion H12.
-apply H14.
-rewrite H14 in H10; elim H10; reflexivity.
-inversion H13.
-apply H14.
-rewrite H8 in H10; rewrite <- H14 in H10; elim H10; reflexivity.
-intros; unfold h in |- *;
- replace
-  (derive_pt (fun y:R => (g b - g a) * f y - (f b - f a) * g y) c (X c P))
-  with
-  (derive_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F) c
-     (derivable_pt_minus _ _ _
-        (derivable_pt_mult _ _ _ (derivable_pt_const (g b - g a) c) (pr1 c P))
-        (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P))));
- [ idtac | apply pr_nu ].
-rewrite derive_pt_minus; do 2 rewrite derive_pt_mult;
- do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; 
- do 2 rewrite Rplus_0_l; reflexivity.
-unfold h in |- *; ring.
-intros; unfold h in |- *;
- change
-   (continuity_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
-      c) in |- *.
-apply continuity_pt_minus; apply continuity_pt_mult.
-apply derivable_continuous_pt; apply derivable_const.
-apply H0; apply H3.
-apply derivable_continuous_pt; apply derivable_const.
-apply H1; apply H3.
-intros;
- change
-   (derivable_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
-      c) in |- *.
-apply derivable_pt_minus; apply derivable_pt_mult.
-apply derivable_pt_const.
-apply (pr1 _ H3).
-apply derivable_pt_const.
-apply (pr2 _ H3).
+  intro; exists Mx.
+  exists H11.
+  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_maximum with a b.
+  elim H11; intros; assumption.
+  elim H11; intros; assumption.
+  intros; elim H6; intros; apply H14.
+  split; left; assumption.
+  elim H6; intros _ H11; elim H11; intros; split.
+  inversion H12.
+  apply H14.
+  rewrite H14 in H10; elim H10; reflexivity.
+  inversion H13.
+  apply H14.
+  rewrite H8 in H10; rewrite <- H14 in H10; elim H10; reflexivity.
+  intros; unfold h in |- *;
+    replace
+    (derive_pt (fun y:R => (g b - g a) * f y - (f b - f a) * g y) c (X c P))
+    with
+      (derive_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F) c
+        (derivable_pt_minus _ _ _
+          (derivable_pt_mult _ _ _ (derivable_pt_const (g b - g a) c) (pr1 c P))
+          (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P))));
+      [ idtac | apply pr_nu ].
+  rewrite derive_pt_minus; do 2 rewrite derive_pt_mult;
+    do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; 
+      do 2 rewrite Rplus_0_l; reflexivity.
+  unfold h in |- *; ring.
+  intros; unfold h in |- *;
+    change
+      (continuity_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
+        c) in |- *.
+  apply continuity_pt_minus; apply continuity_pt_mult.
+  apply derivable_continuous_pt; apply derivable_const.
+  apply H0; apply H3.
+  apply derivable_continuous_pt; apply derivable_const.
+  apply H1; apply H3.
+  intros;
+    change
+      (derivable_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
+        c) in |- *.
+  apply derivable_pt_minus; apply derivable_pt_mult.
+  apply derivable_pt_const.
+  apply (pr1 _ H3).
+  apply derivable_pt_const.
+  apply (pr2 _ H3).
 Qed.
 
 (* Corollaries ... *)
 Lemma MVT_cor1 :
- forall (f:R -> R) (a b:R) (pr:derivable f),
-   a < b ->
+  forall (f:R -> R) (a b:R) (pr:derivable f),
+    a < b ->
     exists c : R, f b - f a = derive_pt f c (pr c) * (b - a) /\ a < c < b.
-intros f a b pr H; cut (forall c:R, a < c < b -> derivable_pt f c);
- [ intro | intros; apply pr ].
-cut (forall c:R, a < c < b -> derivable_pt id c);
- [ intro | intros; apply derivable_pt_id ].
-cut (forall c:R, a <= c <= b -> continuity_pt f c);
- [ intro | intros; apply derivable_continuous_pt; apply pr ].
-cut (forall c:R, a <= c <= b -> continuity_pt id c);
- [ intro | intros; apply derivable_continuous_pt; apply derivable_id ].
-assert (H2 := MVT f id a b X X0 H H0 H1).
-elim H2; intros c H3; elim H3; intros.
-exists c; split.
-cut (derive_pt id c (X0 c x) = derive_pt id c (derivable_pt_id c));
- [ intro | apply pr_nu ].
-rewrite H5 in H4; rewrite (derive_pt_id c) in H4; rewrite Rmult_1_r in H4;
- rewrite <- H4; replace (derive_pt f c (X c x)) with (derive_pt f c (pr c));
- [ idtac | apply pr_nu ]; apply Rmult_comm.
-apply x.
+Proof.
+  intros f a b pr H; cut (forall c:R, a < c < b -> derivable_pt f c);
+    [ intro X | intros; apply pr ].
+  cut (forall c:R, a < c < b -> derivable_pt id c);
+    [ intro X0 | intros; apply derivable_pt_id ].
+  cut (forall c:R, a <= c <= b -> continuity_pt f c);
+    [ intro | intros; apply derivable_continuous_pt; apply pr ].
+  cut (forall c:R, a <= c <= b -> continuity_pt id c);
+    [ intro | intros; apply derivable_continuous_pt; apply derivable_id ].
+  assert (H2 := MVT f id a b X X0 H H0 H1).
+  elim H2; intros c H3; elim H3; intros.
+  exists c; split.
+  cut (derive_pt id c (X0 c x) = derive_pt id c (derivable_pt_id c));
+    [ intro | apply pr_nu ].
+  rewrite H5 in H4; rewrite (derive_pt_id c) in H4; rewrite Rmult_1_r in H4;
+    rewrite <- H4; replace (derive_pt f c (X c x)) with (derive_pt f c (pr c));
+      [ idtac | apply pr_nu ]; apply Rmult_comm.
+  apply x.
 Qed.
 
 Theorem MVT_cor2 :
- forall (f f':R -> R) (a b:R),
-   a < b ->
-   (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) ->
+  forall (f f':R -> R) (a b:R),
+    a < b ->
+    (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) ->
     exists c : R, f b - f a = f' c * (b - a) /\ a < c < b.
-intros f f' a b H H0; cut (forall c:R, a <= c <= b -> derivable_pt f c).
-intro; cut (forall c:R, a < c < b -> derivable_pt f c).
-intro; cut (forall c:R, a <= c <= b -> continuity_pt f c).
-intro; cut (forall c:R, a <= c <= b -> derivable_pt id c).
-intro; cut (forall c:R, a < c < b -> derivable_pt id c).
-intro; cut (forall c:R, a <= c <= b -> continuity_pt id c).
-intro; elim (MVT f id a b X0 X2 H H1 H2); intros; elim H3; clear H3; intros;
- exists x; split.
-cut (derive_pt id x (X2 x x0) = 1).
-cut (derive_pt f x (X0 x x0) = f' x).
-intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3;
- rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry  in |- *; 
- assumption.
-apply derive_pt_eq_0; apply H0; elim x0; intros; split; left; assumption.
-apply derive_pt_eq_0; apply derivable_pt_lim_id.
-assumption.
-intros; apply derivable_continuous_pt; apply X1; assumption.
-intros; apply derivable_pt_id.
-intros; apply derivable_pt_id.
-intros; apply derivable_continuous_pt; apply X; assumption.
-intros; elim H1; intros; apply X; split; left; assumption.
-intros; unfold derivable_pt in |- *; apply existT with (f' c); apply H0;
- apply H1.
+Proof.
+  intros f f' a b H H0; cut (forall c:R, a <= c <= b -> derivable_pt f c).
+  intro X; cut (forall c:R, a < c < b -> derivable_pt f c).
+  intro X0; cut (forall c:R, a <= c <= b -> continuity_pt f c).
+  intro; cut (forall c:R, a <= c <= b -> derivable_pt id c).
+  intro X1; cut (forall c:R, a < c < b -> derivable_pt id c).
+  intro X2; cut (forall c:R, a <= c <= b -> continuity_pt id c).
+  intro; elim (MVT f id a b X0 X2 H H1 H2); intros; elim H3; clear H3; intros;
+    exists x; split.
+  cut (derive_pt id x (X2 x x0) = 1).
+  cut (derive_pt f x (X0 x x0) = f' x).
+  intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3;
+    rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry  in |- *; 
+      assumption.
+  apply derive_pt_eq_0; apply H0; elim x0; intros; split; left; assumption.
+  apply derive_pt_eq_0; apply derivable_pt_lim_id.
+  assumption.
+  intros; apply derivable_continuous_pt; apply X1; assumption.
+  intros; apply derivable_pt_id.
+  intros; apply derivable_pt_id.
+  intros; apply derivable_continuous_pt; apply X; assumption.
+  intros; elim H1; intros; apply X; split; left; assumption.
+  intros; unfold derivable_pt in |- *; apply existT with (f' c); apply H0;
+    apply H1.
 Qed.
 
 Lemma MVT_cor3 :
- forall (f f':R -> R) (a b:R),
-   a < b ->
-   (forall x:R, a <= x -> x <= b -> derivable_pt_lim f x (f' x)) ->
+  forall (f f':R -> R) (a b:R),
+    a < b ->
+    (forall x:R, a <= x -> x <= b -> derivable_pt_lim f x (f' x)) ->
     exists c : R, a <= c /\ c <= b /\ f b = f a + f' c * (b - a).
-intros f f' a b H H0;
- assert (H1 :  exists c : R, f b - f a = f' c * (b - a) /\ a < c < b);
- [ apply MVT_cor2; [ apply H | intros; elim H1; intros; apply (H0 _ H2 H3) ]
- | elim H1; intros; exists x; elim H2; intros; elim H4; intros; split;
-    [ left; assumption | split; [ left; assumption | rewrite <- H3; ring ] ] ].
+Proof.
+  intros f f' a b H H0;
+    assert (H1 :  exists c : R, f b - f a = f' c * (b - a) /\ a < c < b);
+      [ apply MVT_cor2; [ apply H | intros; elim H1; intros; apply (H0 _ H2 H3) ]
+        | elim H1; intros; exists x; elim H2; intros; elim H4; intros; split;
+          [ left; assumption | split; [ left; assumption | rewrite <- H3; ring ] ] ].
 Qed.
 
 Lemma Rolle :
- forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
-   (forall x:R, a <= x <= b -> continuity_pt f x) ->
-   a < b ->
-   f a = f b ->
+  forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
+    (forall x:R, a <= x <= b -> continuity_pt f x) ->
+    a < b ->
+    f a = f b ->
     exists c : R, (exists P : a < c < b, derive_pt f c (pr c P) = 0).
-intros; assert (H2 : forall x:R, a < x < b -> derivable_pt id x).
-intros; apply derivable_pt_id.
-assert (H3 := MVT f id a b pr H2 H0 H);
- assert (H4 : forall x:R, a <= x <= b -> continuity_pt id x).
-intros; apply derivable_continuous; apply derivable_id.
-elim (H3 H4); intros; elim H5; intros; exists x; exists x0; rewrite H1 in H6;
- unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6;
- rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a);
- [ rewrite Rmult_0_r; apply H6
- | apply Rminus_eq_contra; red in |- *; intro; rewrite H7 in H0;
-    elim (Rlt_irrefl _ H0) ].
+Proof.
+  intros; assert (H2 : forall x:R, a < x < b -> derivable_pt id x).
+  intros; apply derivable_pt_id.
+  assert (H3 := MVT f id a b pr H2 H0 H);
+    assert (H4 : forall x:R, a <= x <= b -> continuity_pt id x).
+  intros; apply derivable_continuous; apply derivable_id.
+  elim (H3 H4); intros; elim H5; intros; exists x; exists x0; rewrite H1 in H6;
+    unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6;
+      rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a);
+        [ rewrite Rmult_0_r; apply H6
+          | apply Rminus_eq_contra; red in |- *; intro; rewrite H7 in H0;
+            elim (Rlt_irrefl _ H0) ].
 Qed.
 
 (**********)
 Lemma nonneg_derivative_1 :
- forall (f:R -> R) (pr:derivable f),
-   (forall x:R, 0 <= derive_pt f x (pr x)) -> increasing f.
-intros.
-unfold increasing in |- *.
-intros.
-case (total_order_T x y); intro.
-elim s; intro.
-apply Rplus_le_reg_l with (- f x).
-rewrite Rplus_opp_l; rewrite Rplus_comm.
-assert (H1 := MVT_cor1 f _ _ pr a).
-elim H1; intros.
-elim H2; intros.
-unfold Rminus in H3.
-rewrite H3.
-apply Rmult_le_pos.
-apply H.
-apply Rplus_le_reg_l with x.
-rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
-rewrite b; right; reflexivity.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
+  forall (f:R -> R) (pr:derivable f),
+    (forall x:R, 0 <= derive_pt f x (pr x)) -> increasing f.
+Proof.
+  intros.
+  unfold increasing in |- *.
+  intros.
+  case (total_order_T x y); intro.
+  elim s; intro.
+  apply Rplus_le_reg_l with (- f x).
+  rewrite Rplus_opp_l; rewrite Rplus_comm.
+  assert (H1 := MVT_cor1 f _ _ pr a).
+  elim H1; intros.
+  elim H2; intros.
+  unfold Rminus in H3.
+  rewrite H3.
+  apply Rmult_le_pos.
+  apply H.
+  apply Rplus_le_reg_l with x.
+  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
+  rewrite b; right; reflexivity.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
 Qed.
- 
+
 (**********)
 Lemma nonpos_derivative_0 :
- forall (f:R -> R) (pr:derivable f),
-   decreasing f -> forall x:R, derive_pt f x (pr x) <= 0.
-intros f pr H x; assert (H0 := H); unfold decreasing in H0;
- generalize (derivable_derive f x (pr x)); intro; elim H1; 
- intros l H2.
-rewrite H2; case (Rtotal_order l 0); intro.
-left; assumption.
-elim H3; intro.
-right; assumption.
-generalize (derive_pt_eq_1 f x l (pr x) H2); intros; cut (0 < l / 2).
-intro; elim (H5 (l / 2) H6); intros delta H7;
- cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta).
-intro; decompose [and] H8; intros; generalize (H7 (delta / 2) H9 H12);
- cut ((f (x + delta / 2) - f x) / (delta / 2) <= 0).
-intro; cut (0 < - ((f (x + delta / 2) - f x) / (delta / 2) - l)).
-intro; unfold Rabs in |- *;
- case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
-intros;
- generalize
-  (Rplus_lt_compat_r (- l) (- ((f (x + delta / 2) - f x) / (delta / 2) - l))
-     (l / 2) H14); unfold Rminus in |- *.
-replace (l / 2 + - l) with (- (l / 2)).
-replace (- ((f (x + delta / 2) + - f x) / (delta / 2) + - l) + - l) with
- (- ((f (x + delta / 2) + - f x) / (delta / 2))).
-intro.
-generalize
- (Ropp_lt_gt_contravar (- ((f (x + delta / 2) + - f x) / (delta / 2)))
-    (- (l / 2)) H15). 
-repeat rewrite Ropp_involutive.
-intro.
-generalize
- (Rlt_trans 0 (l / 2) ((f (x + delta / 2) - f x) / (delta / 2)) H6 H16);
- intro.
-elim
- (Rlt_irrefl 0
-    (Rlt_le_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) 0 H17 H10)).
-ring.
-pattern l at 3 in |- *; rewrite double_var.
-ring.
-intros.
-generalize
- (Ropp_ge_le_contravar ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 r).
-rewrite Ropp_0.
-intro.
-elim
- (Rlt_irrefl 0
-    (Rlt_le_trans 0 (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) 0 H13
-       H15)).
-replace (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) with
- ((f x - f (x + delta / 2)) / (delta / 2) + l).
-unfold Rminus in |- *.
-apply Rplus_le_lt_0_compat.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-cut (x <= x + delta * / 2).
-intro; generalize (H0 x (x + delta * / 2) H13); intro;
- generalize
-  (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H14);
- rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
-pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
- left; assumption.
-left; apply Rinv_0_lt_compat; assumption.
-assumption.
-rewrite Ropp_minus_distr.
-unfold Rminus in |- *.
-rewrite (Rplus_comm l).
-unfold Rdiv in |- *.
-rewrite <- Ropp_mult_distr_l_reverse.
-rewrite Ropp_plus_distr.
-rewrite Ropp_involutive.
-rewrite (Rplus_comm (f x)).
-reflexivity.
-replace ((f (x + delta / 2) - f x) / (delta / 2)) with
- (- ((f x - f (x + delta / 2)) / (delta / 2))).
-rewrite <- Ropp_0.
-apply Ropp_ge_le_contravar.
-apply Rle_ge.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-cut (x <= x + delta * / 2).
-intro; generalize (H0 x (x + delta * / 2) H10); intro.
-generalize
- (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H13);
- rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
-pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
- left; assumption.
-left; apply Rinv_0_lt_compat; assumption.
-unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
-rewrite Ropp_minus_distr.
-reflexivity.
-split.
-unfold Rdiv in |- *; apply prod_neq_R0.
-generalize (cond_pos delta); intro; red in |- *; intro H9; rewrite H9 in H8;
- elim (Rlt_irrefl 0 H8).
-apply Rinv_neq_0_compat; discrR.
-split.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-rewrite Rabs_right.
-unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
-prove_sup0.
-rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; rewrite double; pattern (pos delta) at 1 in |- *;
- rewrite <- Rplus_0_r.
-apply Rplus_lt_compat_l; apply (cond_pos delta).
-discrR.
-apply Rle_ge; unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
-apply (cond_pos delta).
-apply Rinv_0_lt_compat; prove_sup0.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply H4 | apply Rinv_0_lt_compat; prove_sup0 ].
+  forall (f:R -> R) (pr:derivable f),
+    decreasing f -> forall x:R, derive_pt f x (pr x) <= 0.
+Proof.
+  intros f pr H x; assert (H0 := H); unfold decreasing in H0;
+    generalize (derivable_derive f x (pr x)); intro; elim H1; 
+      intros l H2.
+  rewrite H2; case (Rtotal_order l 0); intro.
+  left; assumption.
+  elim H3; intro.
+  right; assumption.
+  generalize (derive_pt_eq_1 f x l (pr x) H2); intros; cut (0 < l / 2).
+  intro; elim (H5 (l / 2) H6); intros delta H7;
+    cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta).
+  intro; decompose [and] H8; intros; generalize (H7 (delta / 2) H9 H12);
+    cut ((f (x + delta / 2) - f x) / (delta / 2) <= 0).
+  intro; cut (0 < - ((f (x + delta / 2) - f x) / (delta / 2) - l)).
+  intro; unfold Rabs in |- *;
+    case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
+  intros;
+    generalize
+      (Rplus_lt_compat_r (- l) (- ((f (x + delta / 2) - f x) / (delta / 2) - l))
+        (l / 2) H14); unfold Rminus in |- *.
+  replace (l / 2 + - l) with (- (l / 2)).
+  replace (- ((f (x + delta / 2) + - f x) / (delta / 2) + - l) + - l) with
+  (- ((f (x + delta / 2) + - f x) / (delta / 2))).
+  intro.
+  generalize
+    (Ropp_lt_gt_contravar (- ((f (x + delta / 2) + - f x) / (delta / 2)))
+      (- (l / 2)) H15). 
+  repeat rewrite Ropp_involutive.
+  intro.
+  generalize
+    (Rlt_trans 0 (l / 2) ((f (x + delta / 2) - f x) / (delta / 2)) H6 H16);
+    intro.
+  elim
+    (Rlt_irrefl 0
+      (Rlt_le_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) 0 H17 H10)).
+  ring.
+  pattern l at 3 in |- *; rewrite double_var.
+  ring.
+  intros.
+  generalize
+    (Ropp_ge_le_contravar ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 r).
+  rewrite Ropp_0.
+  intro.
+  elim
+    (Rlt_irrefl 0
+      (Rlt_le_trans 0 (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) 0 H13
+        H15)).
+  replace (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) with
+  ((f x - f (x + delta / 2)) / (delta / 2) + l).
+  unfold Rminus in |- *.
+  apply Rplus_le_lt_0_compat.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  cut (x <= x + delta * / 2).
+  intro; generalize (H0 x (x + delta * / 2) H13); intro;
+    generalize
+      (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H14);
+      rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
+  pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+    left; assumption.
+  left; apply Rinv_0_lt_compat; assumption.
+  assumption.
+  rewrite Ropp_minus_distr.
+  unfold Rminus in |- *.
+  rewrite (Rplus_comm l).
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  rewrite (Rplus_comm (f x)).
+  reflexivity.
+  replace ((f (x + delta / 2) - f x) / (delta / 2)) with
+  (- ((f x - f (x + delta / 2)) / (delta / 2))).
+  rewrite <- Ropp_0.
+  apply Ropp_ge_le_contravar.
+  apply Rle_ge.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  cut (x <= x + delta * / 2).
+  intro; generalize (H0 x (x + delta * / 2) H10); intro.
+  generalize
+    (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H13);
+    rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
+  pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+    left; assumption.
+  left; apply Rinv_0_lt_compat; assumption.
+  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+  rewrite Ropp_minus_distr.
+  reflexivity.
+  split.
+  unfold Rdiv in |- *; apply prod_neq_R0.
+  generalize (cond_pos delta); intro; red in |- *; intro H9; rewrite H9 in H8;
+    elim (Rlt_irrefl 0 H8).
+  apply Rinv_neq_0_compat; discrR.
+  split.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+  rewrite Rabs_right.
+  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite double; pattern (pos delta) at 1 in |- *;
+    rewrite <- Rplus_0_r.
+  apply Rplus_lt_compat_l; apply (cond_pos delta).
+  discrR.
+  apply Rle_ge; unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
+  apply (cond_pos delta).
+  apply Rinv_0_lt_compat; prove_sup0.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply H4 | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
 (**********)
 Lemma increasing_decreasing_opp :
- forall f:R -> R, increasing f -> decreasing (- f)%F.
-unfold increasing, decreasing, opp_fct in |- *; intros; generalize (H x y H0);
- intro; apply Ropp_ge_le_contravar; apply Rle_ge; assumption.
+  forall f:R -> R, increasing f -> decreasing (- f)%F.
+Proof.
+  unfold increasing, decreasing, opp_fct in |- *; intros; generalize (H x y H0);
+    intro; apply Ropp_ge_le_contravar; apply Rle_ge; assumption.
 Qed.
 
 (**********)
 Lemma nonpos_derivative_1 :
- forall (f:R -> R) (pr:derivable f),
-   (forall x:R, derive_pt f x (pr x) <= 0) -> decreasing f.
-intros.
-cut (forall h:R, - - f h = f h).
-intro.
-generalize (increasing_decreasing_opp (- f)%F).
-unfold decreasing in |- *.
-unfold opp_fct in |- *.
-intros.
-rewrite <- (H0 x); rewrite <- (H0 y).
-apply H1.
-cut (forall x:R, 0 <= derive_pt (- f) x (derivable_opp f pr x)).
-intros.
-replace (fun x:R => - f x) with (- f)%F; [ idtac | reflexivity ].
-apply (nonneg_derivative_1 (- f)%F (derivable_opp f pr) H3).
-intro.
-assert (H3 := derive_pt_opp f x0 (pr x0)).
-cut
- (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
-  derive_pt (- f) x0 (derivable_opp f pr x0)).
-intro.
-rewrite <- H4.
-rewrite H3.
-rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; apply (H x0).
-apply pr_nu.
-assumption.
-intro; ring.
+  forall (f:R -> R) (pr:derivable f),
+    (forall x:R, derive_pt f x (pr x) <= 0) -> decreasing f.
+Proof.
+  intros.
+  cut (forall h:R, - - f h = f h).
+  intro.
+  generalize (increasing_decreasing_opp (- f)%F).
+  unfold decreasing in |- *.
+  unfold opp_fct in |- *.
+  intros.
+  rewrite <- (H0 x); rewrite <- (H0 y).
+  apply H1.
+  cut (forall x:R, 0 <= derive_pt (- f) x (derivable_opp f pr x)).
+  intros.
+  replace (fun x:R => - f x) with (- f)%F; [ idtac | reflexivity ].
+  apply (nonneg_derivative_1 (- f)%F (derivable_opp f pr) H3).
+  intro.
+  assert (H3 := derive_pt_opp f x0 (pr x0)).
+  cut
+    (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
+      derive_pt (- f) x0 (derivable_opp f pr x0)).
+  intro.
+  rewrite <- H4.
+  rewrite H3.
+  rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; apply (H x0).
+  apply pr_nu.
+  assumption.
+  intro; ring.
 Qed.
- 
+
 (**********)
 Lemma positive_derivative :
- forall (f:R -> R) (pr:derivable f),
-   (forall x:R, 0 < derive_pt f x (pr x)) -> strict_increasing f.
-intros.
-unfold strict_increasing in |- *.
-intros.
-apply Rplus_lt_reg_r with (- f x).
-rewrite Rplus_opp_l; rewrite Rplus_comm.
-assert (H1 := MVT_cor1 f _ _ pr H0).
-elim H1; intros.
-elim H2; intros.
-unfold Rminus in H3.
-rewrite H3.
-apply Rmult_lt_0_compat.
-apply H.
-apply Rplus_lt_reg_r with x.
-rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
+  forall (f:R -> R) (pr:derivable f),
+    (forall x:R, 0 < derive_pt f x (pr x)) -> strict_increasing f.
+Proof.
+  intros.
+  unfold strict_increasing in |- *.
+  intros.
+  apply Rplus_lt_reg_r with (- f x).
+  rewrite Rplus_opp_l; rewrite Rplus_comm.
+  assert (H1 := MVT_cor1 f _ _ pr H0).
+  elim H1; intros.
+  elim H2; intros.
+  unfold Rminus in H3.
+  rewrite H3.
+  apply Rmult_lt_0_compat.
+  apply H.
+  apply Rplus_lt_reg_r with x.
+  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
 Qed.
 
 (**********)
 Lemma strictincreasing_strictdecreasing_opp :
- forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F.
-unfold strict_increasing, strict_decreasing, opp_fct in |- *; intros;
- generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; 
- assumption.
+  forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F.
+Proof.
+  unfold strict_increasing, strict_decreasing, opp_fct in |- *; intros;
+    generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; 
+      assumption.
 Qed.
- 
+
 (**********)
 Lemma negative_derivative :
- forall (f:R -> R) (pr:derivable f),
-   (forall x:R, derive_pt f x (pr x) < 0) -> strict_decreasing f.
-intros.
-cut (forall h:R, - - f h = f h).
-intros.
-generalize (strictincreasing_strictdecreasing_opp (- f)%F).
-unfold strict_decreasing, opp_fct in |- *.
-intros.
-rewrite <- (H0 x).
-rewrite <- (H0 y).
-apply H1; [ idtac | assumption ].
-cut (forall x:R, 0 < derive_pt (- f) x (derivable_opp f pr x)).
-intros; eapply positive_derivative; apply H3.
-intro.
-assert (H3 := derive_pt_opp f x0 (pr x0)).
-cut
- (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
-  derive_pt (- f) x0 (derivable_opp f pr x0)).
-intro.
-rewrite <- H4; rewrite H3.
-rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply (H x0).
-apply pr_nu.
-intro; ring.
+  forall (f:R -> R) (pr:derivable f),
+    (forall x:R, derive_pt f x (pr x) < 0) -> strict_decreasing f.
+Proof.
+  intros.
+  cut (forall h:R, - - f h = f h).
+  intros.
+  generalize (strictincreasing_strictdecreasing_opp (- f)%F).
+  unfold strict_decreasing, opp_fct in |- *.
+  intros.
+  rewrite <- (H0 x).
+  rewrite <- (H0 y).
+  apply H1; [ idtac | assumption ].
+  cut (forall x:R, 0 < derive_pt (- f) x (derivable_opp f pr x)).
+  intros; eapply positive_derivative; apply H3.
+  intro.
+  assert (H3 := derive_pt_opp f x0 (pr x0)).
+  cut
+    (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
+      derive_pt (- f) x0 (derivable_opp f pr x0)).
+  intro.
+  rewrite <- H4; rewrite H3.
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply (H x0).
+  apply pr_nu.
+  intro; ring.
 Qed.
- 
+
 (**********)
 Lemma null_derivative_0 :
- forall (f:R -> R) (pr:derivable f),
-   constant f -> forall x:R, derive_pt f x (pr x) = 0. 
-intros.
-unfold constant in H.
-apply derive_pt_eq_0.
-intros; exists (mkposreal 1 Rlt_0_1); simpl in |- *; intros.
-rewrite (H x (x + h)); unfold Rminus in |- *; unfold Rdiv in |- *;
- rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; 
- rewrite Rabs_R0; assumption.
+  forall (f:R -> R) (pr:derivable f),
+    constant f -> forall x:R, derive_pt f x (pr x) = 0. 
+Proof.
+  intros.
+  unfold constant in H.
+  apply derive_pt_eq_0.
+  intros; exists (mkposreal 1 Rlt_0_1); simpl in |- *; intros.
+  rewrite (H x (x + h)); unfold Rminus in |- *; unfold Rdiv in |- *;
+    rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; 
+      rewrite Rabs_R0; assumption.
 Qed.
 
 (**********)
 Lemma increasing_decreasing :
- forall f:R -> R, increasing f -> decreasing f -> constant f.
-unfold increasing, decreasing, constant in |- *; intros;
- case (Rtotal_order x y); intro.
-generalize (Rlt_le x y H1); intro;
- apply (Rle_antisym (f x) (f y) (H x y H2) (H0 x y H2)).
-elim H1; intro.
-rewrite H2; reflexivity.
-generalize (Rlt_le y x H2); intro; symmetry  in |- *;
- apply (Rle_antisym (f y) (f x) (H y x H3) (H0 y x H3)).
+  forall f:R -> R, increasing f -> decreasing f -> constant f.
+Proof.
+  unfold increasing, decreasing, constant in |- *; intros;
+    case (Rtotal_order x y); intro.
+  generalize (Rlt_le x y H1); intro;
+    apply (Rle_antisym (f x) (f y) (H x y H2) (H0 x y H2)).
+  elim H1; intro.
+  rewrite H2; reflexivity.
+  generalize (Rlt_le y x H2); intro; symmetry  in |- *;
+    apply (Rle_antisym (f y) (f x) (H y x H3) (H0 y x H3)).
 Qed.
 
 (**********)
 Lemma null_derivative_1 :
- forall (f:R -> R) (pr:derivable f),
-   (forall x:R, derive_pt f x (pr x) = 0) -> constant f.
-intros.
-cut (forall x:R, derive_pt f x (pr x) <= 0).
-cut (forall x:R, 0 <= derive_pt f x (pr x)).
-intros.
-assert (H2 := nonneg_derivative_1 f pr H0).
-assert (H3 := nonpos_derivative_1 f pr H1).
-apply increasing_decreasing; assumption.
-intro; right; symmetry  in |- *; apply (H x).
-intro; right; apply (H x).
+  forall (f:R -> R) (pr:derivable f),
+    (forall x:R, derive_pt f x (pr x) = 0) -> constant f.
+Proof.
+  intros.
+  cut (forall x:R, derive_pt f x (pr x) <= 0).
+  cut (forall x:R, 0 <= derive_pt f x (pr x)).
+  intros.
+  assert (H2 := nonneg_derivative_1 f pr H0).
+  assert (H3 := nonpos_derivative_1 f pr H1).
+  apply increasing_decreasing; assumption.
+  intro; right; symmetry  in |- *; apply (H x).
+  intro; right; apply (H x).
 Qed.
 
 (**********)
 Lemma derive_increasing_interv_ax :
- forall (a b:R) (f:R -> R) (pr:derivable f),
-   a < b ->
-   ((forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) ->
-    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y) /\
-   ((forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) ->
-    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y).
-intros.
-split; intros.
-apply Rplus_lt_reg_r with (- f x).
-rewrite Rplus_opp_l; rewrite Rplus_comm.
-assert (H4 := MVT_cor1 f _ _ pr H3).
-elim H4; intros.
-elim H5; intros.
-unfold Rminus in H6.
-rewrite H6.
-apply Rmult_lt_0_compat.
-apply H0.
-elim H7; intros.
-split.
-elim H1; intros.
-apply Rle_lt_trans with x; assumption.
-elim H2; intros.
-apply Rlt_le_trans with y; assumption.
-apply Rplus_lt_reg_r with x.
-rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
-apply Rplus_le_reg_l with (- f x).
-rewrite Rplus_opp_l; rewrite Rplus_comm.
-assert (H4 := MVT_cor1 f _ _ pr H3).
-elim H4; intros.
-elim H5; intros.
-unfold Rminus in H6.
-rewrite H6.
-apply Rmult_le_pos.
-apply H0.
-elim H7; intros.
-split.
-elim H1; intros.
-apply Rle_lt_trans with x; assumption.
-elim H2; intros.
-apply Rlt_le_trans with y; assumption.
-apply Rplus_le_reg_l with x.
-rewrite Rplus_0_r; replace (x + (y + - x)) with y;
- [ left; assumption | ring ].
+  forall (a b:R) (f:R -> R) (pr:derivable f),
+    a < b ->
+    ((forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) ->
+      forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y) /\
+    ((forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) ->
+      forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y).
+Proof.
+  intros.
+  split; intros.
+  apply Rplus_lt_reg_r with (- f x).
+  rewrite Rplus_opp_l; rewrite Rplus_comm.
+  assert (H4 := MVT_cor1 f _ _ pr H3).
+  elim H4; intros.
+  elim H5; intros.
+  unfold Rminus in H6.
+  rewrite H6.
+  apply Rmult_lt_0_compat.
+  apply H0.
+  elim H7; intros.
+  split.
+  elim H1; intros.
+  apply Rle_lt_trans with x; assumption.
+  elim H2; intros.
+  apply Rlt_le_trans with y; assumption.
+  apply Rplus_lt_reg_r with x.
+  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
+  apply Rplus_le_reg_l with (- f x).
+  rewrite Rplus_opp_l; rewrite Rplus_comm.
+  assert (H4 := MVT_cor1 f _ _ pr H3).
+  elim H4; intros.
+  elim H5; intros.
+  unfold Rminus in H6.
+  rewrite H6.
+  apply Rmult_le_pos.
+  apply H0.
+  elim H7; intros.
+  split.
+  elim H1; intros.
+  apply Rle_lt_trans with x; assumption.
+  elim H2; intros.
+  apply Rlt_le_trans with y; assumption.
+  apply Rplus_le_reg_l with x.
+  rewrite Rplus_0_r; replace (x + (y + - x)) with y;
+    [ left; assumption | ring ].
 Qed.
 
 (**********)
 Lemma derive_increasing_interv :
- forall (a b:R) (f:R -> R) (pr:derivable f),
-   a < b ->
-   (forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) ->
-   forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y.
-intros.
-generalize (derive_increasing_interv_ax a b f pr H); intro.
-elim H4; intros H5 _; apply (H5 H0 x y H1 H2 H3).
+  forall (a b:R) (f:R -> R) (pr:derivable f),
+    a < b ->
+    (forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) ->
+    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y.
+Proof.
+  intros.
+  generalize (derive_increasing_interv_ax a b f pr H); intro.
+  elim H4; intros H5 _; apply (H5 H0 x y H1 H2 H3).
 Qed.
 
 (**********)
 Lemma derive_increasing_interv_var :
- forall (a b:R) (f:R -> R) (pr:derivable f),
-   a < b ->
-   (forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) ->
-   forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y.
-intros a b f pr H H0 x y H1 H2 H3;
- generalize (derive_increasing_interv_ax a b f pr H); 
- intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3).
+  forall (a b:R) (f:R -> R) (pr:derivable f),
+    a < b ->
+    (forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) ->
+    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y.
+Proof.
+  intros a b f pr H H0 x y H1 H2 H3;
+    generalize (derive_increasing_interv_ax a b f pr H); 
+      intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3).
 Qed.
 
 (**********)
 (**********)
 Theorem IAF :
- forall (f:R -> R) (a b k:R) (pr:derivable f),
-   a <= b ->
-   (forall c:R, a <= c <= b -> derive_pt f c (pr c) <= k) ->
-   f b - f a <= k * (b - a).
-intros.
-case (total_order_T a b); intro.
-elim s; intro.
-assert (H1 := MVT_cor1 f _ _ pr a0).
-elim H1; intros.
-elim H2; intros.
-rewrite H3.
-do 2 rewrite <- (Rmult_comm (b - a)).
-apply Rmult_le_compat_l.
-apply Rplus_le_reg_l with a; rewrite Rplus_0_r.
-replace (a + (b - a)) with b; [ assumption | ring ].
-apply H0.
-elim H4; intros.
-split; left; assumption.
-rewrite b0.
-unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
-rewrite Rmult_0_r; right; reflexivity.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  forall (f:R -> R) (a b k:R) (pr:derivable f),
+    a <= b ->
+    (forall c:R, a <= c <= b -> derive_pt f c (pr c) <= k) ->
+    f b - f a <= k * (b - a).
+Proof.
+  intros.
+  case (total_order_T a b); intro.
+  elim s; intro.
+  assert (H1 := MVT_cor1 f _ _ pr a0).
+  elim H1; intros.
+  elim H2; intros.
+  rewrite H3.
+  do 2 rewrite <- (Rmult_comm (b - a)).
+  apply Rmult_le_compat_l.
+  apply Rplus_le_reg_l with a; rewrite Rplus_0_r.
+  replace (a + (b - a)) with b; [ assumption | ring ].
+  apply H0.
+  elim H4; intros.
+  split; left; assumption.
+  rewrite b0.
+  unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
+  rewrite Rmult_0_r; right; reflexivity.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
 Qed.
 
 Lemma IAF_var :
- forall (f g:R -> R) (a b:R) (pr1:derivable f) (pr2:derivable g),
-   a <= b ->
-   (forall c:R, a <= c <= b -> derive_pt g c (pr2 c) <= derive_pt f c (pr1 c)) ->
-   g b - g a <= f b - f a.
-intros.
-cut (derivable (g - f)).
-intro.
-cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0).
-intro. 
-assert (H2 := IAF (g - f)%F a b 0 X H H1).
-rewrite Rmult_0_l in H2; unfold minus_fct in H2.
-apply Rplus_le_reg_l with (- f b + f a).
-replace (- f b + f a + (f b - f a)) with 0; [ idtac | ring ].
-replace (- f b + f a + (g b - g a)) with (g b - f b - (g a - f a));
- [ apply H2 | ring ].
-intros.
-cut
- (derive_pt (g - f) c (X c) =
-  derive_pt (g - f) c (derivable_pt_minus _ _ _ (pr2 c) (pr1 c))).
-intro.
-rewrite H2.
-rewrite derive_pt_minus.
-apply Rplus_le_reg_l with (derive_pt f c (pr1 c)).
-rewrite Rplus_0_r.
-replace
- (derive_pt f c (pr1 c) + (derive_pt g c (pr2 c) - derive_pt f c (pr1 c)))
- with (derive_pt g c (pr2 c)); [ idtac | ring ].
-apply H0; assumption.
-apply pr_nu.
-apply derivable_minus; assumption.
+  forall (f g:R -> R) (a b:R) (pr1:derivable f) (pr2:derivable g),
+    a <= b ->
+    (forall c:R, a <= c <= b -> derive_pt g c (pr2 c) <= derive_pt f c (pr1 c)) ->
+    g b - g a <= f b - f a.
+Proof.
+  intros.
+  cut (derivable (g - f)).
+  intro X.
+  cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0).
+  intro. 
+  assert (H2 := IAF (g - f)%F a b 0 X H H1).
+  rewrite Rmult_0_l in H2; unfold minus_fct in H2.
+  apply Rplus_le_reg_l with (- f b + f a).
+  replace (- f b + f a + (f b - f a)) with 0; [ idtac | ring ].
+  replace (- f b + f a + (g b - g a)) with (g b - f b - (g a - f a));
+  [ apply H2 | ring ].
+  intros.
+  cut
+    (derive_pt (g - f) c (X c) =
+      derive_pt (g - f) c (derivable_pt_minus _ _ _ (pr2 c) (pr1 c))).
+  intro.
+  rewrite H2.
+  rewrite derive_pt_minus.
+  apply Rplus_le_reg_l with (derive_pt f c (pr1 c)).
+  rewrite Rplus_0_r.
+  replace
+  (derive_pt f c (pr1 c) + (derive_pt g c (pr2 c) - derive_pt f c (pr1 c)))
+    with (derive_pt g c (pr2 c)); [ idtac | ring ].
+  apply H0; assumption.
+  apply pr_nu.
+  apply derivable_minus; assumption.
 Qed.
 
 (* If f has a null derivative in ]a,b[ and is continue in [a,b], *)
 (* then f is constant on [a,b] *)
 Lemma null_derivative_loc :
- forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
-   (forall x:R, a <= x <= b -> continuity_pt f x) ->
-   (forall (x:R) (P:a < x < b), derive_pt f x (pr x P) = 0) ->
-   constant_D_eq f (fun x:R => a <= x <= b) (f a).
-intros; unfold constant_D_eq in |- *; intros; case (total_order_T a b); intro.
-elim s; intro.
-assert (H2 : forall y:R, a < y < x -> derivable_pt id y).
-intros; apply derivable_pt_id.
-assert (H3 : forall y:R, a <= y <= x -> continuity_pt id y).
-intros; apply derivable_continuous; apply derivable_id.
-assert (H4 : forall y:R, a < y < x -> derivable_pt f y).
-intros; apply pr; elim H4; intros; split.
-assumption.
-elim H1; intros; apply Rlt_le_trans with x; assumption.
-assert (H5 : forall y:R, a <= y <= x -> continuity_pt f y).
-intros; apply H; elim H5; intros; split.
-assumption.
-elim H1; intros; apply Rle_trans with x; assumption.
-elim H1; clear H1; intros; elim H1; clear H1; intro.
-assert (H7 := MVT f id a x H4 H2 H1 H5 H3).
-elim H7; intros; elim H8; intros; assert (H10 : a < x0 < b).
-elim x1; intros; split.
-assumption.
-apply Rlt_le_trans with x; assumption.
-assert (H11 : derive_pt f x0 (H4 x0 x1) = 0).
-replace (derive_pt f x0 (H4 x0 x1)) with (derive_pt f x0 (pr x0 H10));
- [ apply H0 | apply pr_nu ].
-assert (H12 : derive_pt id x0 (H2 x0 x1) = 1).
-apply derive_pt_eq_0; apply derivable_pt_lim_id.
-rewrite H11 in H9; rewrite H12 in H9; rewrite Rmult_0_r in H9;
- rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry  in |- *;
- assumption.
-rewrite H1; reflexivity.
-assert (H2 : x = a).
-rewrite <- b0 in H1; elim H1; intros; apply Rle_antisym; assumption.
-rewrite H2; reflexivity.
-elim H1; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) r)).
+  forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
+    (forall x:R, a <= x <= b -> continuity_pt f x) ->
+    (forall (x:R) (P:a < x < b), derive_pt f x (pr x P) = 0) ->
+    constant_D_eq f (fun x:R => a <= x <= b) (f a).
+Proof.
+  intros; unfold constant_D_eq in |- *; intros; case (total_order_T a b); intro.
+  elim s; intro.
+  assert (H2 : forall y:R, a < y < x -> derivable_pt id y).
+  intros; apply derivable_pt_id.
+  assert (H3 : forall y:R, a <= y <= x -> continuity_pt id y).
+  intros; apply derivable_continuous; apply derivable_id.
+  assert (H4 : forall y:R, a < y < x -> derivable_pt f y).
+  intros; apply pr; elim H4; intros; split.
+  assumption.
+  elim H1; intros; apply Rlt_le_trans with x; assumption.
+  assert (H5 : forall y:R, a <= y <= x -> continuity_pt f y).
+  intros; apply H; elim H5; intros; split.
+  assumption.
+  elim H1; intros; apply Rle_trans with x; assumption.
+  elim H1; clear H1; intros; elim H1; clear H1; intro.
+  assert (H7 := MVT f id a x H4 H2 H1 H5 H3).
+  elim H7; intros; elim H8; intros; assert (H10 : a < x0 < b).
+  elim x1; intros; split.
+  assumption.
+  apply Rlt_le_trans with x; assumption.
+  assert (H11 : derive_pt f x0 (H4 x0 x1) = 0).
+  replace (derive_pt f x0 (H4 x0 x1)) with (derive_pt f x0 (pr x0 H10));
+  [ apply H0 | apply pr_nu ].
+  assert (H12 : derive_pt id x0 (H2 x0 x1) = 1).
+  apply derive_pt_eq_0; apply derivable_pt_lim_id.
+  rewrite H11 in H9; rewrite H12 in H9; rewrite Rmult_0_r in H9;
+    rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry  in |- *;
+      assumption.
+  rewrite H1; reflexivity.
+  assert (H2 : x = a).
+  rewrite <- b0 in H1; elim H1; intros; apply Rle_antisym; assumption.
+  rewrite H2; reflexivity.
+  elim H1; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) r)).
 Qed.
 
 (* Unicity of the antiderivative *)
 Lemma antiderivative_Ucte :
- forall (f g1 g2:R -> R) (a b:R),
-   antiderivative f g1 a b ->
-   antiderivative f g2 a b ->
+  forall (f g1 g2:R -> R) (a b:R),
+    antiderivative f g1 a b ->
+    antiderivative f g2 a b ->
     exists c : R, (forall x:R, a <= x <= b -> g1 x = g2 x + c).
-unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0;
- clear H0; intros H0 _; exists (g1 a - g2 a); intros;
- assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x).
-intros; unfold derivable_pt in |- *; apply existT with (f x0); elim (H x0 H3);
- intros; eapply derive_pt_eq_1; symmetry  in |- *; 
- apply H4.
-assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x).
-intros; unfold derivable_pt in |- *; apply existT with (f x0);
- elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry  in |- *; 
- apply H5.
-assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x).
-intros; elim H5; intros; apply derivable_pt_minus;
- [ apply H3; split; left; assumption | apply H4; split; left; assumption ].
-assert (H6 : forall x:R, a <= x <= b -> continuity_pt (g1 - g2) x).
-intros; apply derivable_continuous_pt; apply derivable_pt_minus;
- [ apply H3 | apply H4 ]; assumption.
-assert (H7 : forall (x:R) (P:a < x < b), derive_pt (g1 - g2) x (H5 x P) = 0).
-intros; elim P; intros; apply derive_pt_eq_0; replace 0 with (f x0 - f x0);
- [ idtac | ring ].
-assert (H9 : a <= x0 <= b).
-split; left; assumption.
-apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros;
- eapply derive_pt_eq_1; symmetry  in |- *; apply H10.
-assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7);
- unfold constant_D_eq in H8; assert (H9 := H8 _ H2); 
- unfold minus_fct in H9; rewrite <- H9; ring.
+Proof.
+  unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0;
+    clear H0; intros H0 _; exists (g1 a - g2 a); intros;
+      assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x).
+  intros; unfold derivable_pt in |- *; apply existT with (f x0); elim (H x0 H3);
+    intros; eapply derive_pt_eq_1; symmetry  in |- *; 
+      apply H4.
+  assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x).
+  intros; unfold derivable_pt in |- *; apply existT with (f x0);
+    elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry  in |- *; 
+      apply H5.
+  assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x).
+  intros; elim H5; intros; apply derivable_pt_minus;
+    [ apply H3; split; left; assumption | apply H4; split; left; assumption ].
+  assert (H6 : forall x:R, a <= x <= b -> continuity_pt (g1 - g2) x).
+  intros; apply derivable_continuous_pt; apply derivable_pt_minus;
+    [ apply H3 | apply H4 ]; assumption.
+  assert (H7 : forall (x:R) (P:a < x < b), derive_pt (g1 - g2) x (H5 x P) = 0).
+  intros; elim P; intros; apply derive_pt_eq_0; replace 0 with (f x0 - f x0);
+    [ idtac | ring ].
+  assert (H9 : a <= x0 <= b).
+  split; left; assumption.
+  apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros;
+    eapply derive_pt_eq_1; symmetry  in |- *; apply H10.
+  assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7);
+    unfold constant_D_eq in H8; assert (H9 := H8 _ H2); 
+      unfold minus_fct in H9; rewrite <- H9; ring.
 Qed.
diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v
index 97cd4b94..306d5ac4 100644
--- a/theories/Reals/NewtonInt.v
+++ b/theories/Reals/NewtonInt.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: NewtonInt.v,v 1.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+(*i $Id: NewtonInt.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -23,766 +23,782 @@ Definition Newton_integrable (f:R -> R) (a b:R) : Type :=
 
 Definition NewtonInt (f:R -> R) (a b:R) (pr:Newton_integrable f a b) : R :=
   let g := match pr with
-           | existT a b => a
+             | existT a b => a
            end in g b - g a.
 
 (* If f is differentiable, then f' is Newton integrable (Tautology ?) *)
 Lemma FTCN_step1 :
- forall (f:Differential) (a b:R),
-   Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b.
-intros f a b; unfold Newton_integrable in |- *; apply existT with (d1 f);
- unfold antiderivative in |- *; intros; case (Rle_dec a b); 
- intro;
- [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ]
- | right; split;
-    [ intros; exists (cond_diff f x); reflexivity | auto with real ] ].
+  forall (f:Differential) (a b:R),
+    Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b.
+Proof.
+  intros f a b; unfold Newton_integrable in |- *; apply existT with (d1 f);
+    unfold antiderivative in |- *; intros; case (Rle_dec a b); 
+      intro;
+        [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ]
+          | right; split;
+            [ intros; exists (cond_diff f x); reflexivity | auto with real ] ].
 Defined.
 
 (* By definition, we have the Fondamental Theorem of Calculus *)
 Lemma FTC_Newton :
- forall (f:Differential) (a b:R),
-   NewtonInt (fun x:R => derive_pt f x (cond_diff f x)) a b
-     (FTCN_step1 f a b) = f b - f a.
-intros; unfold NewtonInt in |- *; reflexivity.
+  forall (f:Differential) (a b:R),
+    NewtonInt (fun x:R => derive_pt f x (cond_diff f x)) a b
+    (FTCN_step1 f a b) = f b - f a.
+Proof.
+  intros; unfold NewtonInt in |- *; reflexivity.
 Qed.
 
 (* $\int_a^a f$ exists forall a:R and f:R->R *)
 Lemma NewtonInt_P1 : forall (f:R -> R) (a:R), Newton_integrable f a a.
-intros f a; unfold Newton_integrable in |- *;
- apply existT with (fct_cte (f a) * id)%F; left;
- unfold antiderivative in |- *; split.
-intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x).
-apply derivable_pt_mult.
-apply derivable_pt_const.
-apply derivable_pt_id.
-exists H1; assert (H2 : x = a).
-elim H; intros; apply Rle_antisym; assumption.
-symmetry  in |- *; apply derive_pt_eq_0;
- replace (f x) with (0 * id x + fct_cte (f a) x * 1);
- [ apply (derivable_pt_lim_mult (fct_cte (f a)) id x);
-    [ apply derivable_pt_lim_const | apply derivable_pt_lim_id ]
- | unfold id, fct_cte in |- *; rewrite H2; ring ].
-right; reflexivity.
+Proof.
+  intros f a; unfold Newton_integrable in |- *;
+    apply existT with (fct_cte (f a) * id)%F; left;
+      unfold antiderivative in |- *; split.
+  intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x).
+  apply derivable_pt_mult.
+  apply derivable_pt_const.
+  apply derivable_pt_id.
+  exists H1; assert (H2 : x = a).
+  elim H; intros; apply Rle_antisym; assumption.
+  symmetry  in |- *; apply derive_pt_eq_0;
+    replace (f x) with (0 * id x + fct_cte (f a) x * 1);
+    [ apply (derivable_pt_lim_mult (fct_cte (f a)) id x);
+      [ apply derivable_pt_lim_const | apply derivable_pt_lim_id ]
+      | unfold id, fct_cte in |- *; rewrite H2; ring ].
+  right; reflexivity.
 Defined.
 
 (* $\int_a^a f = 0$ *)
 Lemma NewtonInt_P2 :
- forall (f:R -> R) (a:R), NewtonInt f a a (NewtonInt_P1 f a) = 0.
-intros; unfold NewtonInt in |- *; simpl in |- *;
- unfold mult_fct, fct_cte, id in |- *; ring.
+  forall (f:R -> R) (a:R), NewtonInt f a a (NewtonInt_P1 f a) = 0.
+Proof.
+  intros; unfold NewtonInt in |- *; simpl in |- *;
+    unfold mult_fct, fct_cte, id in |- *; ring.
 Qed.
 
 (* If $\int_a^b f$ exists, then $\int_b^a f$ exists too *)
 Lemma NewtonInt_P3 :
- forall (f:R -> R) (a b:R) (X:Newton_integrable f a b),
-   Newton_integrable f b a.
-unfold Newton_integrable in |- *; intros; elim X; intros g H;
- apply existT with g; tauto.
+  forall (f:R -> R) (a b:R) (X:Newton_integrable f a b),
+    Newton_integrable f b a.
+Proof.
+  unfold Newton_integrable in |- *; intros; elim X; intros g H;
+    apply existT with g; tauto.
 Defined.
 
 (* $\int_a^b f = -\int_b^a f$ *)
 Lemma NewtonInt_P4 :
- forall (f:R -> R) (a b:R) (pr:Newton_integrable f a b),
-   NewtonInt f a b pr = - NewtonInt f b a (NewtonInt_P3 f a b pr).
-intros; unfold Newton_integrable in pr; elim pr; intros; elim p; intro.
-unfold NewtonInt in |- *;
- case
-  (NewtonInt_P3 f a b
-     (existT
+  forall (f:R -> R) (a b:R) (pr:Newton_integrable f a b),
+    NewtonInt f a b pr = - NewtonInt f b a (NewtonInt_P3 f a b pr).
+Proof.
+  intros; unfold Newton_integrable in pr; elim pr; intros; elim p; intro.
+  unfold NewtonInt in |- *;
+    case
+    (NewtonInt_P3 f a b
+      (existT
         (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x
         p)).
-intros; elim o; intro.
-unfold antiderivative in H0; elim H0; intros; elim H2; intro.
-unfold antiderivative in H; elim H; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)).
-rewrite H3; ring.
-assert (H1 := antiderivative_Ucte f x x0 a b H H0); elim H1; intros;
- unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-assert (H3 : a <= a <= b).
-split; [ right; reflexivity | assumption ].
-assert (H4 : a <= b <= b).
-split; [ assumption | right; reflexivity ].
-assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
-unfold NewtonInt in |- *;
- case
-  (NewtonInt_P3 f a b
-     (existT
+  intros; elim o; intro.
+  unfold antiderivative in H0; elim H0; intros; elim H2; intro.
+  unfold antiderivative in H; elim H; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)).
+  rewrite H3; ring.
+  assert (H1 := antiderivative_Ucte f x x0 a b H H0); elim H1; intros;
+    unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+  assert (H3 : a <= a <= b).
+  split; [ right; reflexivity | assumption ].
+  assert (H4 : a <= b <= b).
+  split; [ assumption | right; reflexivity ].
+  assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
+  unfold NewtonInt in |- *;
+    case
+    (NewtonInt_P3 f a b
+      (existT
         (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x
         p)); intros; elim o; intro.
-assert (H1 := antiderivative_Ucte f x x0 b a H H0); elim H1; intros;
- unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-assert (H3 : b <= a <= a).
-split; [ assumption | right; reflexivity ].
-assert (H4 : b <= b <= a).
-split; [ right; reflexivity | assumption ].
-assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
-unfold antiderivative in H0; elim H0; intros; elim H2; intro.
-unfold antiderivative in H; elim H; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)).
-rewrite H3; ring.
+  assert (H1 := antiderivative_Ucte f x x0 b a H H0); elim H1; intros;
+    unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+  assert (H3 : b <= a <= a).
+  split; [ assumption | right; reflexivity ].
+  assert (H4 : b <= b <= a).
+  split; [ right; reflexivity | assumption ].
+  assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
+  unfold antiderivative in H0; elim H0; intros; elim H2; intro.
+  unfold antiderivative in H; elim H; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)).
+  rewrite H3; ring.
 Qed.
 
 (* The set of Newton integrable functions is a vectorial space *)
 Lemma NewtonInt_P5 :
- forall (f g:R -> R) (l a b:R),
-   Newton_integrable f a b ->
-   Newton_integrable g a b ->
-   Newton_integrable (fun x:R => l * f x + g x) a b.
-unfold Newton_integrable in |- *; intros; elim X; intros; elim X0; intros;
- exists (fun y:R => l * x y + x0 y).
-elim p; intro.
-elim p0; intro.
-left; unfold antiderivative in |- *; unfold antiderivative in H, H0; elim H;
- clear H; intros; elim H0; clear H0; intros H0 _.
-split.
-intros; elim (H _ H2); elim (H0 _ H2); intros.
-assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
-reg.
-exists H5; symmetry  in |- *; reg; rewrite <- H3; rewrite <- H4; reflexivity.
-assumption.
-unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
-left; rewrite <- H5; unfold antiderivative in |- *; split.
-intros; elim H6; intros; assert (H9 : x1 = a).
-apply Rle_antisym; assumption.
-assert (H10 : a <= x1 <= b).
-split; right; [ symmetry  in |- *; assumption | rewrite <- H5; assumption ].
-assert (H11 : b <= x1 <= a).
-split; right; [ rewrite <- H5; symmetry  in |- *; assumption | assumption ].
-assert (H12 : derivable_pt x x1).
-unfold derivable_pt in |- *; exists (f x1); elim (H3 _ H10); intros;
- eapply derive_pt_eq_1; symmetry  in |- *; apply H12.
-assert (H13 : derivable_pt x0 x1).
-unfold derivable_pt in |- *; exists (g x1); elim (H1 _ H11); intros;
- eapply derive_pt_eq_1; symmetry  in |- *; apply H13.
-assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
-reg.
-exists H14; symmetry  in |- *; reg.
-assert (H15 : derive_pt x0 x1 H13 = g x1).
-elim (H1 _ H11); intros; rewrite H15; apply pr_nu.
-assert (H16 : derive_pt x x1 H12 = f x1).
-elim (H3 _ H10); intros; rewrite H16; apply pr_nu.
-rewrite H15; rewrite H16; ring.
-right; reflexivity.
-elim p0; intro.
-unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
-left; rewrite H5; unfold antiderivative in |- *; split.
-intros; elim H6; intros; assert (H9 : x1 = a).
-apply Rle_antisym; assumption.
-assert (H10 : a <= x1 <= b).
-split; right; [ symmetry  in |- *; assumption | rewrite H5; assumption ].
-assert (H11 : b <= x1 <= a).
-split; right; [ rewrite H5; symmetry  in |- *; assumption | assumption ].
-assert (H12 : derivable_pt x x1).
-unfold derivable_pt in |- *; exists (f x1); elim (H3 _ H11); intros;
- eapply derive_pt_eq_1; symmetry  in |- *; apply H12.
-assert (H13 : derivable_pt x0 x1).
-unfold derivable_pt in |- *; exists (g x1); elim (H1 _ H10); intros;
- eapply derive_pt_eq_1; symmetry  in |- *; apply H13.
-assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
-reg.
-exists H14; symmetry  in |- *; reg.
-assert (H15 : derive_pt x0 x1 H13 = g x1).
-elim (H1 _ H10); intros; rewrite H15; apply pr_nu.
-assert (H16 : derive_pt x x1 H12 = f x1).
-elim (H3 _ H11); intros; rewrite H16; apply pr_nu.
-rewrite H15; rewrite H16; ring.
-right; reflexivity.
-right; unfold antiderivative in |- *; unfold antiderivative in H, H0; elim H;
- clear H; intros; elim H0; clear H0; intros H0 _; split.
-intros; elim (H _ H2); elim (H0 _ H2); intros.
-assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
-reg.
-exists H5; symmetry  in |- *; reg; rewrite <- H3; rewrite <- H4; reflexivity.
-assumption.
+  forall (f g:R -> R) (l a b:R),
+    Newton_integrable f a b ->
+    Newton_integrable g a b ->
+    Newton_integrable (fun x:R => l * f x + g x) a b.
+Proof.
+  unfold Newton_integrable in |- *; intros f g l a b X X0;
+    elim X; intros; elim X0; intros;
+      exists (fun y:R => l * x y + x0 y).
+  elim p; intro.
+  elim p0; intro.
+  left; unfold antiderivative in |- *; unfold antiderivative in H, H0; elim H;
+    clear H; intros; elim H0; clear H0; intros H0 _.
+  split.
+  intros; elim (H _ H2); elim (H0 _ H2); intros.
+  assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
+  reg.
+  exists H5; symmetry  in |- *; reg; rewrite <- H3; rewrite <- H4; reflexivity.
+  assumption.
+  unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
+  left; rewrite <- H5; unfold antiderivative in |- *; split.
+  intros; elim H6; intros; assert (H9 : x1 = a).
+  apply Rle_antisym; assumption.
+  assert (H10 : a <= x1 <= b).
+  split; right; [ symmetry  in |- *; assumption | rewrite <- H5; assumption ].
+  assert (H11 : b <= x1 <= a).
+  split; right; [ rewrite <- H5; symmetry  in |- *; assumption | assumption ].
+  assert (H12 : derivable_pt x x1).
+  unfold derivable_pt in |- *; exists (f x1); elim (H3 _ H10); intros;
+    eapply derive_pt_eq_1; symmetry  in |- *; apply H12.
+  assert (H13 : derivable_pt x0 x1).
+  unfold derivable_pt in |- *; exists (g x1); elim (H1 _ H11); intros;
+    eapply derive_pt_eq_1; symmetry  in |- *; apply H13.
+  assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
+  reg.
+  exists H14; symmetry  in |- *; reg.
+  assert (H15 : derive_pt x0 x1 H13 = g x1).
+  elim (H1 _ H11); intros; rewrite H15; apply pr_nu.
+  assert (H16 : derive_pt x x1 H12 = f x1).
+  elim (H3 _ H10); intros; rewrite H16; apply pr_nu.
+  rewrite H15; rewrite H16; ring.
+  right; reflexivity.
+  elim p0; intro.
+  unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
+  left; rewrite H5; unfold antiderivative in |- *; split.
+  intros; elim H6; intros; assert (H9 : x1 = a).
+  apply Rle_antisym; assumption.
+  assert (H10 : a <= x1 <= b).
+  split; right; [ symmetry  in |- *; assumption | rewrite H5; assumption ].
+  assert (H11 : b <= x1 <= a).
+  split; right; [ rewrite H5; symmetry  in |- *; assumption | assumption ].
+  assert (H12 : derivable_pt x x1).
+  unfold derivable_pt in |- *; exists (f x1); elim (H3 _ H11); intros;
+    eapply derive_pt_eq_1; symmetry  in |- *; apply H12.
+  assert (H13 : derivable_pt x0 x1).
+  unfold derivable_pt in |- *; exists (g x1); elim (H1 _ H10); intros;
+    eapply derive_pt_eq_1; symmetry  in |- *; apply H13.
+  assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
+  reg.
+  exists H14; symmetry  in |- *; reg.
+  assert (H15 : derive_pt x0 x1 H13 = g x1).
+  elim (H1 _ H10); intros; rewrite H15; apply pr_nu.
+  assert (H16 : derive_pt x x1 H12 = f x1).
+  elim (H3 _ H11); intros; rewrite H16; apply pr_nu.
+  rewrite H15; rewrite H16; ring.
+  right; reflexivity.
+  right; unfold antiderivative in |- *; unfold antiderivative in H, H0; elim H;
+    clear H; intros; elim H0; clear H0; intros H0 _; split.
+  intros; elim (H _ H2); elim (H0 _ H2); intros.
+  assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
+  reg.
+  exists H5; symmetry  in |- *; reg; rewrite <- H3; rewrite <- H4; reflexivity.
+  assumption.
 Defined.
 
 (**********)
 Lemma antiderivative_P1 :
- forall (f g F G:R -> R) (l a b:R),
-   antiderivative f F a b ->
-   antiderivative g G a b ->
-   antiderivative (fun x:R => l * f x + g x) (fun x:R => l * F x + G x) a b.
-unfold antiderivative in |- *; intros; elim H; elim H0; clear H H0; intros;
- split.
-intros; elim (H _ H3); elim (H1 _ H3); intros.
-assert (H6 : derivable_pt (fun x:R => l * F x + G x) x).
-reg.
-exists H6; symmetry  in |- *; reg; rewrite <- H4; rewrite <- H5; ring.
-assumption.
+  forall (f g F G:R -> R) (l a b:R),
+    antiderivative f F a b ->
+    antiderivative g G a b ->
+    antiderivative (fun x:R => l * f x + g x) (fun x:R => l * F x + G x) a b.
+Proof.
+  unfold antiderivative in |- *; intros; elim H; elim H0; clear H H0; intros;
+    split.
+  intros; elim (H _ H3); elim (H1 _ H3); intros.
+  assert (H6 : derivable_pt (fun x:R => l * F x + G x) x).
+  reg.
+  exists H6; symmetry  in |- *; reg; rewrite <- H4; rewrite <- H5; ring.
+  assumption.
 Qed.
 
 (* $\int_a^b \lambda f + g = \lambda \int_a^b f + \int_a^b f *)
 Lemma NewtonInt_P6 :
- forall (f g:R -> R) (l a b:R) (pr1:Newton_integrable f a b)
-   (pr2:Newton_integrable g a b),
-   NewtonInt (fun x:R => l * f x + g x) a b (NewtonInt_P5 f g l a b pr1 pr2) =
-   l * NewtonInt f a b pr1 + NewtonInt g a b pr2.
-intros f g l a b pr1 pr2; unfold NewtonInt in |- *;
- case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1; 
- intros; case pr2; intros; case (total_order_T a b); 
- intro.
-elim s; intro.
-elim o; intro.
-elim o0; intro.
-elim o1; intro.
-assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1);
- assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); 
- elim H3; intros; assert (H5 : a <= a <= b).
-split; [ right; reflexivity | left; assumption ].
-assert (H6 : a <= b <= b).
-split; [ left; assumption | right; reflexivity ].
-assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
-unfold antiderivative in H1; elim H1; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 a0)).
-unfold antiderivative in H0; elim H0; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
-unfold antiderivative in H; elim H; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 a0)).
-rewrite b0; ring.
-elim o; intro.
-unfold antiderivative in H; elim H; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r)).
-elim o0; intro.
-unfold antiderivative in H0; elim H0; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 r)).
-elim o1; intro.
-unfold antiderivative in H1; elim H1; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 r)).
-assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1);
- assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); 
- elim H3; intros; assert (H5 : b <= a <= a).
-split; [ left; assumption | right; reflexivity ].
-assert (H6 : b <= b <= a).
-split; [ right; reflexivity | left; assumption ].
-assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
+  forall (f g:R -> R) (l a b:R) (pr1:Newton_integrable f a b)
+    (pr2:Newton_integrable g a b),
+    NewtonInt (fun x:R => l * f x + g x) a b (NewtonInt_P5 f g l a b pr1 pr2) =
+    l * NewtonInt f a b pr1 + NewtonInt g a b pr2.
+Proof.
+  intros f g l a b pr1 pr2; unfold NewtonInt in |- *;
+    case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1; 
+      intros; case pr2; intros; case (total_order_T a b); 
+        intro.
+  elim s; intro.
+  elim o; intro.
+  elim o0; intro.
+  elim o1; intro.
+  assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1);
+    assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); 
+      elim H3; intros; assert (H5 : a <= a <= b).
+  split; [ right; reflexivity | left; assumption ].
+  assert (H6 : a <= b <= b).
+  split; [ left; assumption | right; reflexivity ].
+  assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
+  unfold antiderivative in H1; elim H1; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 a0)).
+  unfold antiderivative in H0; elim H0; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+  unfold antiderivative in H; elim H; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 a0)).
+  rewrite b0; ring.
+  elim o; intro.
+  unfold antiderivative in H; elim H; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r)).
+  elim o0; intro.
+  unfold antiderivative in H0; elim H0; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 r)).
+  elim o1; intro.
+  unfold antiderivative in H1; elim H1; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 r)).
+  assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1);
+    assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); 
+      elim H3; intros; assert (H5 : b <= a <= a).
+  split; [ left; assumption | right; reflexivity ].
+  assert (H6 : b <= b <= a).
+  split; [ right; reflexivity | left; assumption ].
+  assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
 Qed.
 
 Lemma antiderivative_P2 :
- forall (f F0 F1:R -> R) (a b c:R),
-   antiderivative f F0 a b ->
-   antiderivative f F1 b c ->
-   antiderivative f
-     (fun x:R =>
-        match Rle_dec x b with
+  forall (f F0 F1:R -> R) (a b c:R),
+    antiderivative f F0 a b ->
+    antiderivative f F1 b c ->
+    antiderivative f
+    (fun x:R =>
+      match Rle_dec x b with
         | left _ => F0 x
         | right _ => F1 x + (F0 b - F1 b)
-        end) a c.
-unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0;
- clear H0; intros; split.
-2: apply Rle_trans with b; assumption.
-intros; elim H3; clear H3; intros; case (total_order_T x b); intro.
-elim s; intro.
-assert (H5 : a <= x <= b).
-split; [ assumption | left; assumption ].
-assert (H6 := H _ H5); elim H6; clear H6; intros;
- assert
-  (H7 :
-   derivable_pt_lim
-     (fun x:R =>
+      end) a c.
+Proof.
+  unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0;
+    clear H0; intros; split.
+  2: apply Rle_trans with b; assumption.
+  intros; elim H3; clear H3; intros; case (total_order_T x b); intro.
+  elim s; intro.
+  assert (H5 : a <= x <= b).
+  split; [ assumption | left; assumption ].
+  assert (H6 := H _ H5); elim H6; clear H6; intros;
+    assert
+      (H7 :
+        derivable_pt_lim
+        (fun x:R =>
+          match Rle_dec x b with
+            | left _ => F0 x
+            | right _ => F1 x + (F0 b - F1 b)
+          end) x (f x)).
+  unfold derivable_pt_lim in |- *; assert (H7 : derive_pt F0 x x0 = f x).
+  symmetry  in |- *; assumption.
+  assert (H8 := derive_pt_eq_1 F0 x (f x) x0 H7); unfold derivable_pt_lim in H8;
+    intros; elim (H8 _ H9); intros; set (D := Rmin x1 (b - x)).
+  assert (H11 : 0 < D).
+  unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x1 (b - x)); intro.
+  apply (cond_pos x1).
+  apply Rlt_Rminus; assumption.
+  exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
+  case (Rle_dec (x + h) b); intro.
+  apply H10.
+  assumption.
+  apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_l ].
+  elim n; left; apply Rlt_le_trans with (x + D).
+  apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h).
+  apply RRle_abs.
+  apply H13.
+  apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
+    rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *; 
+      apply Rmin_r.
+  elim n; left; assumption.
+  assert
+    (H8 :
+      derivable_pt
+      (fun x:R =>
         match Rle_dec x b with
-        | left _ => F0 x
-        | right _ => F1 x + (F0 b - F1 b)
-        end) x (f x)).
-unfold derivable_pt_lim in |- *; assert (H7 : derive_pt F0 x x0 = f x).
-symmetry  in |- *; assumption.
-assert (H8 := derive_pt_eq_1 F0 x (f x) x0 H7); unfold derivable_pt_lim in H8;
- intros; elim (H8 _ H9); intros; set (D := Rmin x1 (b - x)).
-assert (H11 : 0 < D).
-unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x1 (b - x)); intro.
-apply (cond_pos x1).
-apply Rlt_Rminus; assumption.
-exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
-case (Rle_dec (x + h) b); intro.
-apply H10.
-assumption.
-apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_l ].
-elim n; left; apply Rlt_le_trans with (x + D).
-apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h).
-apply RRle_abs.
-apply H13.
-apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
- rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *; 
- apply Rmin_r.
-elim n; left; assumption.
-assert
- (H8 :
-  derivable_pt
-    (fun x:R =>
-       match Rle_dec x b with
-       | left _ => F0 x
-       | right _ => F1 x + (F0 b - F1 b)
-       end) x).
-unfold derivable_pt in |- *; apply existT with (f x); apply H7.
-exists H8; symmetry  in |- *; apply derive_pt_eq_0; apply H7.
-assert (H5 : a <= x <= b).
-split; [ assumption | right; assumption ].
-assert (H6 : b <= x <= c).
-split; [ right; symmetry  in |- *; assumption | assumption ].
-elim (H _ H5); elim (H0 _ H6); intros; assert (H9 : derive_pt F0 x x1 = f x).
-symmetry  in |- *; assumption.
-assert (H10 : derive_pt F1 x x0 = f x).
-symmetry  in |- *; assumption.
-assert (H11 := derive_pt_eq_1 F0 x (f x) x1 H9);
- assert (H12 := derive_pt_eq_1 F1 x (f x) x0 H10);
- assert
-  (H13 :
-   derivable_pt_lim
-     (fun x:R =>
+          | left _ => F0 x
+          | right _ => F1 x + (F0 b - F1 b)
+        end) x).
+  unfold derivable_pt in |- *; apply existT with (f x); apply H7.
+  exists H8; symmetry  in |- *; apply derive_pt_eq_0; apply H7.
+  assert (H5 : a <= x <= b).
+  split; [ assumption | right; assumption ].
+  assert (H6 : b <= x <= c).
+  split; [ right; symmetry  in |- *; assumption | assumption ].
+  elim (H _ H5); elim (H0 _ H6); intros; assert (H9 : derive_pt F0 x x1 = f x).
+  symmetry  in |- *; assumption.
+  assert (H10 : derive_pt F1 x x0 = f x).
+  symmetry  in |- *; assumption.
+  assert (H11 := derive_pt_eq_1 F0 x (f x) x1 H9);
+    assert (H12 := derive_pt_eq_1 F1 x (f x) x0 H10);
+      assert
+        (H13 :
+          derivable_pt_lim
+          (fun x:R =>
+            match Rle_dec x b with
+              | left _ => F0 x
+              | right _ => F1 x + (F0 b - F1 b)
+            end) x (f x)).
+  unfold derivable_pt_lim in |- *; unfold derivable_pt_lim in H11, H12; intros;
+    elim (H11 _ H13); elim (H12 _ H13); intros; set (D := Rmin x2 x3);
+      assert (H16 : 0 < D).
+  unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x2 x3); intro.
+  apply (cond_pos x2).
+  apply (cond_pos x3).
+  exists (mkposreal _ H16); intros; case (Rle_dec x b); intro.
+  case (Rle_dec (x + h) b); intro.
+  apply H15.
+  assumption.
+  apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_r ].
+  replace (F1 (x + h) + (F0 b - F1 b) - F0 x) with (F1 (x + h) - F1 x).
+  apply H14.
+  assumption.
+  apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_l ].
+  rewrite b0; ring.
+  elim n; right; assumption.
+  assert
+    (H14 :
+      derivable_pt
+      (fun x:R =>
         match Rle_dec x b with
-        | left _ => F0 x
-        | right _ => F1 x + (F0 b - F1 b)
-        end) x (f x)).
-unfold derivable_pt_lim in |- *; unfold derivable_pt_lim in H11, H12; intros;
- elim (H11 _ H13); elim (H12 _ H13); intros; set (D := Rmin x2 x3);
- assert (H16 : 0 < D).
-unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x2 x3); intro.
-apply (cond_pos x2).
-apply (cond_pos x3).
-exists (mkposreal _ H16); intros; case (Rle_dec x b); intro.
-case (Rle_dec (x + h) b); intro.
-apply H15.
-assumption.
-apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_r ].
-replace (F1 (x + h) + (F0 b - F1 b) - F0 x) with (F1 (x + h) - F1 x).
-apply H14.
-assumption.
-apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_l ].
-rewrite b0; ring.
-elim n; right; assumption.
-assert
- (H14 :
-  derivable_pt
-    (fun x:R =>
-       match Rle_dec x b with
-       | left _ => F0 x
-       | right _ => F1 x + (F0 b - F1 b)
-       end) x).
-unfold derivable_pt in |- *; apply existT with (f x); apply H13.
-exists H14; symmetry  in |- *; apply derive_pt_eq_0; apply H13.
-assert (H5 : b <= x <= c).
-split; [ left; assumption | assumption ].
-assert (H6 := H0 _ H5); elim H6; clear H6; intros;
- assert
-  (H7 :
-   derivable_pt_lim
-     (fun x:R =>
+          | left _ => F0 x
+          | right _ => F1 x + (F0 b - F1 b)
+        end) x).
+  unfold derivable_pt in |- *; apply existT with (f x); apply H13.
+  exists H14; symmetry  in |- *; apply derive_pt_eq_0; apply H13.
+  assert (H5 : b <= x <= c).
+  split; [ left; assumption | assumption ].
+  assert (H6 := H0 _ H5); elim H6; clear H6; intros;
+    assert
+      (H7 :
+        derivable_pt_lim
+        (fun x:R =>
+          match Rle_dec x b with
+            | left _ => F0 x
+            | right _ => F1 x + (F0 b - F1 b)
+          end) x (f x)).
+  unfold derivable_pt_lim in |- *; assert (H7 : derive_pt F1 x x0 = f x).
+  symmetry  in |- *; assumption.
+  assert (H8 := derive_pt_eq_1 F1 x (f x) x0 H7); unfold derivable_pt_lim in H8;
+    intros; elim (H8 _ H9); intros; set (D := Rmin x1 (x - b));
+      assert (H11 : 0 < D).
+  unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x1 (x - b)); intro.
+  apply (cond_pos x1).
+  apply Rlt_Rminus; assumption.
+  exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)).
+  case (Rle_dec (x + h) b); intro.
+  cut (b < x + h).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14)).
+  apply Rplus_lt_reg_r with (- h - b); replace (- h - b + b) with (- h);
+    [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); 
+    [ idtac | ring ]; apply Rle_lt_trans with (Rabs h).
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  apply Rlt_le_trans with D.
+  apply H13.
+  unfold D in |- *; apply Rmin_r.
+  replace (F1 (x + h) + (F0 b - F1 b) - (F1 x + (F0 b - F1 b))) with
+  (F1 (x + h) - F1 x); [ idtac | ring ]; apply H10.
+  assumption.
+  apply Rlt_le_trans with D.
+  assumption.
+  unfold D in |- *; apply Rmin_l.
+  assert
+    (H8 :
+      derivable_pt
+      (fun x:R =>
         match Rle_dec x b with
-        | left _ => F0 x
-        | right _ => F1 x + (F0 b - F1 b)
-        end) x (f x)).
-unfold derivable_pt_lim in |- *; assert (H7 : derive_pt F1 x x0 = f x).
-symmetry  in |- *; assumption.
-assert (H8 := derive_pt_eq_1 F1 x (f x) x0 H7); unfold derivable_pt_lim in H8;
- intros; elim (H8 _ H9); intros; set (D := Rmin x1 (x - b));
- assert (H11 : 0 < D).
-unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x1 (x - b)); intro.
-apply (cond_pos x1).
-apply Rlt_Rminus; assumption.
-exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)).
-case (Rle_dec (x + h) b); intro.
-cut (b < x + h).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14)).
-apply Rplus_lt_reg_r with (- h - b); replace (- h - b + b) with (- h);
- [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); 
- [ idtac | ring ]; apply Rle_lt_trans with (Rabs h).
-rewrite <- Rabs_Ropp; apply RRle_abs.
-apply Rlt_le_trans with D.
-apply H13.
-unfold D in |- *; apply Rmin_r.
-replace (F1 (x + h) + (F0 b - F1 b) - (F1 x + (F0 b - F1 b))) with
- (F1 (x + h) - F1 x); [ idtac | ring ]; apply H10.
-assumption.
-apply Rlt_le_trans with D.
-assumption.
-unfold D in |- *; apply Rmin_l.
-assert
- (H8 :
-  derivable_pt
-    (fun x:R =>
-       match Rle_dec x b with
-       | left _ => F0 x
-       | right _ => F1 x + (F0 b - F1 b)
-       end) x).
-unfold derivable_pt in |- *; apply existT with (f x); apply H7.
-exists H8; symmetry  in |- *; apply derive_pt_eq_0; apply H7.
+          | left _ => F0 x
+          | right _ => F1 x + (F0 b - F1 b)
+        end) x).
+  unfold derivable_pt in |- *; apply existT with (f x); apply H7.
+  exists H8; symmetry  in |- *; apply derive_pt_eq_0; apply H7.
 Qed.
 
 Lemma antiderivative_P3 :
- forall (f F0 F1:R -> R) (a b c:R),
-   antiderivative f F0 a b ->
-   antiderivative f F1 c b ->
-   antiderivative f F1 c a \/ antiderivative f F0 a c.
-intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
- intros; case (total_order_T a c); intro.
-elim s; intro.
-right; unfold antiderivative in |- *; split.
-intros; apply H1; elim H3; intros; split;
- [ assumption | apply Rle_trans with c; assumption ].
-left; assumption.
-right; unfold antiderivative in |- *; split.
-intros; apply H1; elim H3; intros; split;
- [ assumption | apply Rle_trans with c; assumption ].
-right; assumption.
-left; unfold antiderivative in |- *; split.
-intros; apply H; elim H3; intros; split;
- [ assumption | apply Rle_trans with a; assumption ].
-left; assumption.
+  forall (f F0 F1:R -> R) (a b c:R),
+    antiderivative f F0 a b ->
+    antiderivative f F1 c b ->
+    antiderivative f F1 c a \/ antiderivative f F0 a c.
+Proof.
+  intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
+    intros; case (total_order_T a c); intro.
+  elim s; intro.
+  right; unfold antiderivative in |- *; split.
+  intros; apply H1; elim H3; intros; split;
+    [ assumption | apply Rle_trans with c; assumption ].
+  left; assumption.
+  right; unfold antiderivative in |- *; split.
+  intros; apply H1; elim H3; intros; split;
+    [ assumption | apply Rle_trans with c; assumption ].
+  right; assumption.
+  left; unfold antiderivative in |- *; split.
+  intros; apply H; elim H3; intros; split;
+    [ assumption | apply Rle_trans with a; assumption ].
+  left; assumption.
 Qed.
 
 Lemma antiderivative_P4 :
- forall (f F0 F1:R -> R) (a b c:R),
-   antiderivative f F0 a b ->
-   antiderivative f F1 a c ->
-   antiderivative f F1 b c \/ antiderivative f F0 c b.
-intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
- intros; case (total_order_T c b); intro.
-elim s; intro.
-right; unfold antiderivative in |- *; split.
-intros; apply H1; elim H3; intros; split;
- [ apply Rle_trans with c; assumption | assumption ].
-left; assumption.
-right; unfold antiderivative in |- *; split.
-intros; apply H1; elim H3; intros; split;
- [ apply Rle_trans with c; assumption | assumption ].
-right; assumption.
-left; unfold antiderivative in |- *; split.
-intros; apply H; elim H3; intros; split;
- [ apply Rle_trans with b; assumption | assumption ].
-left; assumption.
+  forall (f F0 F1:R -> R) (a b c:R),
+    antiderivative f F0 a b ->
+    antiderivative f F1 a c ->
+    antiderivative f F1 b c \/ antiderivative f F0 c b.
+Proof.
+  intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
+    intros; case (total_order_T c b); intro.
+  elim s; intro.
+  right; unfold antiderivative in |- *; split.
+  intros; apply H1; elim H3; intros; split;
+    [ apply Rle_trans with c; assumption | assumption ].
+  left; assumption.
+  right; unfold antiderivative in |- *; split.
+  intros; apply H1; elim H3; intros; split;
+    [ apply Rle_trans with c; assumption | assumption ].
+  right; assumption.
+  left; unfold antiderivative in |- *; split.
+  intros; apply H; elim H3; intros; split;
+    [ apply Rle_trans with b; assumption | assumption ].
+  left; assumption.
 Qed.
 
 Lemma NewtonInt_P7 :
- forall (f:R -> R) (a b c:R),
-   a < b ->
-   b < c ->
-   Newton_integrable f a b ->
-   Newton_integrable f b c -> Newton_integrable f a c.
-unfold Newton_integrable in |- *; intros f a b c Hab Hbc X X0; elim X;
- clear X; intros F0 H0; elim X0; clear X0; intros F1 H1;
- set
-  (g :=
-   fun x:R =>
-     match Rle_dec x b with
-     | left _ => F0 x
-     | right _ => F1 x + (F0 b - F1 b)
-     end); apply existT with g; left; unfold g in |- *;
- apply antiderivative_P2.
-elim H0; intro.
-assumption.
-unfold antiderivative in H; elim H; clear H; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hab)).
-elim H1; intro.
-assumption.
-unfold antiderivative in H; elim H; clear H; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hbc)).
+  forall (f:R -> R) (a b c:R),
+    a < b ->
+    b < c ->
+    Newton_integrable f a b ->
+    Newton_integrable f b c -> Newton_integrable f a c.
+Proof.
+  unfold Newton_integrable in |- *; intros f a b c Hab Hbc X X0; elim X;
+    clear X; intros F0 H0; elim X0; clear X0; intros F1 H1;
+      set
+        (g :=
+          fun x:R =>
+            match Rle_dec x b with
+              | left _ => F0 x
+              | right _ => F1 x + (F0 b - F1 b)
+            end); apply existT with g; left; unfold g in |- *;
+        apply antiderivative_P2.
+  elim H0; intro.
+  assumption.
+  unfold antiderivative in H; elim H; clear H; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hab)).
+  elim H1; intro.
+  assumption.
+  unfold antiderivative in H; elim H; clear H; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hbc)).
 Qed.
 
 Lemma NewtonInt_P8 :
- forall (f:R -> R) (a b c:R),
-   Newton_integrable f a b ->
-   Newton_integrable f b c -> Newton_integrable f a c.
-intros.
-elim X; intros F0 H0.
-elim X0; intros F1 H1.
-case (total_order_T a b); intro.
-elim s; intro.
-case (total_order_T b c); intro.
-elim s0; intro.
+  forall (f:R -> R) (a b c:R),
+    Newton_integrable f a b ->
+    Newton_integrable f b c -> Newton_integrable f a c.
+Proof.
+  intros.
+  elim X; intros F0 H0.
+  elim X0; intros F1 H1.
+  case (total_order_T a b); intro.
+  elim s; intro.
+  case (total_order_T b c); intro.
+  elim s0; intro.
 (* a<b & b<c *)
-unfold Newton_integrable in |- *;
- apply existT with
-  (fun x:R =>
-     match Rle_dec x b with
-     | left _ => F0 x
-     | right _ => F1 x + (F0 b - F1 b)
-     end).
-elim H0; intro.
-elim H1; intro.
-left; apply antiderivative_P2; assumption.
-unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a1)).
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+  unfold Newton_integrable in |- *;
+    apply existT with
+      (fun x:R =>
+        match Rle_dec x b with
+          | left _ => F0 x
+          | right _ => F1 x + (F0 b - F1 b)
+        end).
+  elim H0; intro.
+  elim H1; intro.
+  left; apply antiderivative_P2; assumption.
+  unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a1)).
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
 (* a<b & b=c *)
-rewrite b0 in X; apply X.
+  rewrite b0 in X; apply X.
 (* a<b & b>c *)
-case (total_order_T a c); intro.
-elim s0; intro.
-unfold Newton_integrable in |- *; apply existT with F0.
-left.
-elim H1; intro.
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-elim H0; intro.
-assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
-elim H3; intro.
-unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 a1)).
-assumption.
-unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
-rewrite b0; apply NewtonInt_P1.
-unfold Newton_integrable in |- *; apply existT with F1.
-right.
-elim H1; intro.
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-elim H0; intro.
-assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
-elim H3; intro.
-assumption.
-unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 r0)).
-unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+  case (total_order_T a c); intro.
+  elim s0; intro.
+  unfold Newton_integrable in |- *; apply existT with F0.
+  left.
+  elim H1; intro.
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim H0; intro.
+  assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
+  elim H3; intro.
+  unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 a1)).
+  assumption.
+  unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+  rewrite b0; apply NewtonInt_P1.
+  unfold Newton_integrable in |- *; apply existT with F1.
+  right.
+  elim H1; intro.
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim H0; intro.
+  assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
+  elim H3; intro.
+  assumption.
+  unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 r0)).
+  unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
 (* a=b *)
-rewrite b0; apply X0.
-case (total_order_T b c); intro.
-elim s; intro.
+  rewrite b0; apply X0.
+  case (total_order_T b c); intro.
+  elim s; intro.
 (* a>b & b<c *)
-case (total_order_T a c); intro.
-elim s0; intro.
-unfold Newton_integrable in |- *; apply existT with F1.
-left.
-elim H1; intro.
+  case (total_order_T a c); intro.
+  elim s0; intro.
+  unfold Newton_integrable in |- *; apply existT with F1.
+  left.
+  elim H1; intro.
 (*****************)
-elim H0; intro.
-unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 r)).
-assert (H3 := antiderivative_P4 f F0 F1 b a c H2 H).
-elim H3; intro.
-assumption.
-unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 a1)).
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
-rewrite b0; apply NewtonInt_P1.
-unfold Newton_integrable in |- *; apply existT with F0.
-right.
-elim H0; intro.
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-elim H1; intro.
-assert (H3 := antiderivative_P4 f F0 F1 b a c H H2).
-elim H3; intro.
-unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 r0)).
-assumption.
-unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+  elim H0; intro.
+  unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 r)).
+  assert (H3 := antiderivative_P4 f F0 F1 b a c H2 H).
+  elim H3; intro.
+  assumption.
+  unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 a1)).
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+  rewrite b0; apply NewtonInt_P1.
+  unfold Newton_integrable in |- *; apply existT with F0.
+  right.
+  elim H0; intro.
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim H1; intro.
+  assert (H3 := antiderivative_P4 f F0 F1 b a c H H2).
+  elim H3; intro.
+  unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 r0)).
+  assumption.
+  unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
 (* a>b & b=c *)
-rewrite b0 in X; apply X.
+  rewrite b0 in X; apply X.
 (* a>b & b>c *)
-assert (X1 := NewtonInt_P3 f a b X).
-assert (X2 := NewtonInt_P3 f b c X0).
-apply NewtonInt_P3.
-apply NewtonInt_P7 with b; assumption.
+  assert (X1 := NewtonInt_P3 f a b X).
+  assert (X2 := NewtonInt_P3 f b c X0).
+  apply NewtonInt_P3.
+  apply NewtonInt_P7 with b; assumption.
 Defined.
 
 (* Chasles' relation *)
 Lemma NewtonInt_P9 :
- forall (f:R -> R) (a b c:R) (pr1:Newton_integrable f a b)
-   (pr2:Newton_integrable f b c),
-   NewtonInt f a c (NewtonInt_P8 f a b c pr1 pr2) =
-   NewtonInt f a b pr1 + NewtonInt f b c pr2.
-intros; unfold NewtonInt in |- *.
-case (NewtonInt_P8 f a b c pr1 pr2); intros.
-case pr1; intros.
-case pr2; intros.
-case (total_order_T a b); intro.
-elim s; intro.
-case (total_order_T b c); intro.
-elim s0; intro.
+  forall (f:R -> R) (a b c:R) (pr1:Newton_integrable f a b)
+    (pr2:Newton_integrable f b c),
+    NewtonInt f a c (NewtonInt_P8 f a b c pr1 pr2) =
+    NewtonInt f a b pr1 + NewtonInt f b c pr2.
+Proof.
+  intros; unfold NewtonInt in |- *.
+  case (NewtonInt_P8 f a b c pr1 pr2); intros.
+  case pr1; intros.
+  case pr2; intros.
+  case (total_order_T a b); intro.
+  elim s; intro.
+  case (total_order_T b c); intro.
+  elim s0; intro.
 (* a<b & b<c *)
-elim o0; intro.
-elim o1; intro.
-elim o; intro.
-assert (H2 := antiderivative_P2 f x0 x1 a b c H H0).
-assert
- (H3 :=
-  antiderivative_Ucte f x
-    (fun x:R =>
-       match Rle_dec x b with
-       | left _ => x0 x
-       | right _ => x1 x + (x0 b - x1 b)
-       end) a c H1 H2).
-elim H3; intros.
-assert (H5 : a <= a <= c).
-split; [ right; reflexivity | left; apply Rlt_trans with b; assumption ].
-assert (H6 : a <= c <= c).
-split; [ left; apply Rlt_trans with b; assumption | right; reflexivity ].
-rewrite (H4 _ H5); rewrite (H4 _ H6).
-case (Rle_dec a b); intro.
-case (Rle_dec c b); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a1)).
-ring.
-elim n; left; assumption.
-unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ a0 a1))).
-unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a1)).
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+  elim o0; intro.
+  elim o1; intro.
+  elim o; intro.
+  assert (H2 := antiderivative_P2 f x0 x1 a b c H H0).
+  assert
+    (H3 :=
+      antiderivative_Ucte f x
+      (fun x:R =>
+        match Rle_dec x b with
+          | left _ => x0 x
+          | right _ => x1 x + (x0 b - x1 b)
+        end) a c H1 H2).
+  elim H3; intros.
+  assert (H5 : a <= a <= c).
+  split; [ right; reflexivity | left; apply Rlt_trans with b; assumption ].
+  assert (H6 : a <= c <= c).
+  split; [ left; apply Rlt_trans with b; assumption | right; reflexivity ].
+  rewrite (H4 _ H5); rewrite (H4 _ H6).
+  case (Rle_dec a b); intro.
+  case (Rle_dec c b); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a1)).
+  ring.
+  elim n; left; assumption.
+  unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ a0 a1))).
+  unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a1)).
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
 (* a<b & b=c *)
-rewrite <- b0.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r.
-rewrite <- b0 in o.
-elim o0; intro.
-elim o; intro.
-assert (H1 := antiderivative_Ucte f x x0 a b H0 H).
-elim H1; intros.
-rewrite (H2 b).
-rewrite (H2 a).
-ring.
-split; [ right; reflexivity | left; assumption ].
-split; [ left; assumption | right; reflexivity ].
-unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+  rewrite <- b0.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r.
+  rewrite <- b0 in o.
+  elim o0; intro.
+  elim o; intro.
+  assert (H1 := antiderivative_Ucte f x x0 a b H0 H).
+  elim H1; intros.
+  rewrite (H2 b).
+  rewrite (H2 a).
+  ring.
+  split; [ right; reflexivity | left; assumption ].
+  split; [ left; assumption | right; reflexivity ].
+  unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
 (* a<b & b>c *)
-elim o1; intro.
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-elim o0; intro.
-elim o; intro.
-assert (H2 := antiderivative_P2 f x x1 a c b H1 H).
-assert (H3 := antiderivative_Ucte _ _ _ a b H0 H2).
-elim H3; intros.
-rewrite (H4 a).
-rewrite (H4 b).
-case (Rle_dec b c); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)).
-case (Rle_dec a c); intro.
-ring.
-elim n0; unfold antiderivative in H1; elim H1; intros; assumption.
-split; [ left; assumption | right; reflexivity ].
-split; [ right; reflexivity | left; assumption ].
-assert (H2 := antiderivative_P2 _ _ _ _ _ _ H1 H0).
-assert (H3 := antiderivative_Ucte _ _ _ c b H H2).
-elim H3; intros.
-rewrite (H4 c).
-rewrite (H4 b).
-case (Rle_dec b a); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a0)).
-case (Rle_dec c a); intro.
-ring.
-elim n0; unfold antiderivative in H1; elim H1; intros; assumption.
-split; [ left; assumption | right; reflexivity ].
-split; [ right; reflexivity | left; assumption ].
-unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+  elim o1; intro.
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim o0; intro.
+  elim o; intro.
+  assert (H2 := antiderivative_P2 f x x1 a c b H1 H).
+  assert (H3 := antiderivative_Ucte _ _ _ a b H0 H2).
+  elim H3; intros.
+  rewrite (H4 a).
+  rewrite (H4 b).
+  case (Rle_dec b c); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)).
+  case (Rle_dec a c); intro.
+  ring.
+  elim n0; unfold antiderivative in H1; elim H1; intros; assumption.
+  split; [ left; assumption | right; reflexivity ].
+  split; [ right; reflexivity | left; assumption ].
+  assert (H2 := antiderivative_P2 _ _ _ _ _ _ H1 H0).
+  assert (H3 := antiderivative_Ucte _ _ _ c b H H2).
+  elim H3; intros.
+  rewrite (H4 c).
+  rewrite (H4 b).
+  case (Rle_dec b a); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a0)).
+  case (Rle_dec c a); intro.
+  ring.
+  elim n0; unfold antiderivative in H1; elim H1; intros; assumption.
+  split; [ left; assumption | right; reflexivity ].
+  split; [ right; reflexivity | left; assumption ].
+  unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
 (* a=b *)
-rewrite b0 in o; rewrite b0.
-elim o; intro.
-elim o1; intro.
-assert (H1 := antiderivative_Ucte _ _ _ b c H H0).
-elim H1; intros.
-assert (H3 : b <= c).
-unfold antiderivative in H; elim H; intros; assumption.
-rewrite (H2 b).
-rewrite (H2 c).
-ring.
-split; [ assumption | right; reflexivity ].
-split; [ right; reflexivity | assumption ].
-assert (H1 : b = c).
-unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
- assumption.
-rewrite H1; ring.
-elim o1; intro.
-assert (H1 : b = c).
-unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
- assumption.
-rewrite H1; ring.
-assert (H1 := antiderivative_Ucte _ _ _ c b H H0).
-elim H1; intros.
-assert (H3 : c <= b).
-unfold antiderivative in H; elim H; intros; assumption.
-rewrite (H2 c).
-rewrite (H2 b).
-ring.
-split; [ assumption | right; reflexivity ].
-split; [ right; reflexivity | assumption ].
+  rewrite b0 in o; rewrite b0.
+  elim o; intro.
+  elim o1; intro.
+  assert (H1 := antiderivative_Ucte _ _ _ b c H H0).
+  elim H1; intros.
+  assert (H3 : b <= c).
+  unfold antiderivative in H; elim H; intros; assumption.
+  rewrite (H2 b).
+  rewrite (H2 c).
+  ring.
+  split; [ assumption | right; reflexivity ].
+  split; [ right; reflexivity | assumption ].
+  assert (H1 : b = c).
+  unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
+    assumption.
+  rewrite H1; ring.
+  elim o1; intro.
+  assert (H1 : b = c).
+  unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
+    assumption.
+  rewrite H1; ring.
+  assert (H1 := antiderivative_Ucte _ _ _ c b H H0).
+  elim H1; intros.
+  assert (H3 : c <= b).
+  unfold antiderivative in H; elim H; intros; assumption.
+  rewrite (H2 c).
+  rewrite (H2 b).
+  ring.
+  split; [ assumption | right; reflexivity ].
+  split; [ right; reflexivity | assumption ].
 (* a>b & b<c *)
-case (total_order_T b c); intro.
-elim s; intro.
-elim o0; intro.
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-elim o1; intro.
-elim o; intro.
-assert (H2 := antiderivative_P2 _ _ _ _ _ _ H H1).
-assert (H3 := antiderivative_Ucte _ _ _ b c H0 H2).
-elim H3; intros.
-rewrite (H4 b).
-rewrite (H4 c).
-case (Rle_dec b a); intro.
-case (Rle_dec c a); intro.
-assert (H5 : a = c).
-unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
-rewrite H5; ring.
-ring.
-elim n; left; assumption.
-split; [ left; assumption | right; reflexivity ].
-split; [ right; reflexivity | left; assumption ].
-assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H1).
-assert (H3 := antiderivative_Ucte _ _ _ b a H H2).
-elim H3; intros.
-rewrite (H4 a).
-rewrite (H4 b).
-case (Rle_dec b c); intro.
-case (Rle_dec a c); intro.
-assert (H5 : a = c).
-unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
-rewrite H5; ring.
-ring.
-elim n; left; assumption.
-split; [ right; reflexivity | left; assumption ].
-split; [ left; assumption | right; reflexivity ].
-unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+  case (total_order_T b c); intro.
+  elim s; intro.
+  elim o0; intro.
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim o1; intro.
+  elim o; intro.
+  assert (H2 := antiderivative_P2 _ _ _ _ _ _ H H1).
+  assert (H3 := antiderivative_Ucte _ _ _ b c H0 H2).
+  elim H3; intros.
+  rewrite (H4 b).
+  rewrite (H4 c).
+  case (Rle_dec b a); intro.
+  case (Rle_dec c a); intro.
+  assert (H5 : a = c).
+  unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
+  rewrite H5; ring.
+  ring.
+  elim n; left; assumption.
+  split; [ left; assumption | right; reflexivity ].
+  split; [ right; reflexivity | left; assumption ].
+  assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H1).
+  assert (H3 := antiderivative_Ucte _ _ _ b a H H2).
+  elim H3; intros.
+  rewrite (H4 a).
+  rewrite (H4 b).
+  case (Rle_dec b c); intro.
+  case (Rle_dec a c); intro.
+  assert (H5 : a = c).
+  unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
+  rewrite H5; ring.
+  ring.
+  elim n; left; assumption.
+  split; [ right; reflexivity | left; assumption ].
+  split; [ left; assumption | right; reflexivity ].
+  unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
 (* a>b & b=c *)
-rewrite <- b0.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r.
-rewrite <- b0 in o.
-elim o0; intro.
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-elim o; intro.
-unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
-assert (H1 := antiderivative_Ucte f x x0 b a H0 H).
-elim H1; intros.
-rewrite (H2 b).
-rewrite (H2 a).
-ring.
-split; [ left; assumption | right; reflexivity ].
-split; [ right; reflexivity | left; assumption ].
+  rewrite <- b0.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r.
+  rewrite <- b0 in o.
+  elim o0; intro.
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim o; intro.
+  unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
+  assert (H1 := antiderivative_Ucte f x x0 b a H0 H).
+  elim H1; intros.
+  rewrite (H2 b).
+  rewrite (H2 a).
+  ring.
+  split; [ left; assumption | right; reflexivity ].
+  split; [ right; reflexivity | left; assumption ].
 (* a>b & b>c *)
-elim o0; intro.
-unfold antiderivative in H; elim H; clear H; intros _ H.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-elim o1; intro.
-unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r0)).
-elim o; intro.
-unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ r0 r))).
-assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H).
-assert (H3 := antiderivative_Ucte _ _ _ c a H1 H2).
-elim H3; intros.
-assert (H5 : c <= a).
-unfold antiderivative in H1; elim H1; intros; assumption.
-rewrite (H4 c).
-rewrite (H4 a).
-case (Rle_dec a b); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r1 r)).
-case (Rle_dec c b); intro.
-ring.
-elim n0; left; assumption.
-split; [ assumption | right; reflexivity ].
-split; [ right; reflexivity | assumption ].
+  elim o0; intro.
+  unfold antiderivative in H; elim H; clear H; intros _ H.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim o1; intro.
+  unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r0)).
+  elim o; intro.
+  unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ r0 r))).
+  assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H).
+  assert (H3 := antiderivative_Ucte _ _ _ c a H1 H2).
+  elim H3; intros.
+  assert (H5 : c <= a).
+  unfold antiderivative in H1; elim H1; intros; assumption.
+  rewrite (H4 c).
+  rewrite (H4 a).
+  case (Rle_dec a b); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r1 r)).
+  case (Rle_dec c b); intro.
+  ring.
+  elim n0; left; assumption.
+  split; [ assumption | right; reflexivity ].
+  split; [ right; reflexivity | assumption ].
 Qed.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
index 0c19c8da..64b8e0af 100644
--- a/theories/Reals/PSeries_reg.v
+++ b/theories/Reals/PSeries_reg.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: PSeries_reg.v,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+(*i $Id: PSeries_reg.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -17,243 +17,249 @@ Require Import Even. Open Local Scope R_scope.
 
 Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.
 
-(* Uniform convergence *)
+(** Uniform convergence *)
 Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) 
   (r:posreal) : Prop :=
   forall eps:R,
     0 < eps ->
-     exists N : nat,
+    exists N : nat,
       (forall (n:nat) (y:R),
-         (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). 
+        (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). 
 
-(* Normal convergence *)
+(** Normal convergence *)
 Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type :=
   sigT
-    (fun An:nat -> R =>
-       sigT
-         (fun l:R =>
-            Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n) l /\
-            (forall (n:nat) (y:R), Boule 0 r y -> Rabs (fn n y) <= An n))).
+  (fun An:nat -> R =>
+    sigT
+    (fun l:R =>
+      Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n) l /\
+      (forall (n:nat) (y:R), Boule 0 r y -> Rabs (fn n y) <= An n))).
 
 Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r.
 
 Definition SFL (fn:nat -> R -> R)
   (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)) 
   (y:R) : R := match cv y with
-               | existT a b => a
+                 | existT a b => a
                end.
 
-(* In a complete space, normal convergence implies uniform convergence *)
+(** In a complete space, normal convergence implies uniform convergence *)
 Lemma CVN_CVU :
- forall (fn:nat -> R -> R)
-   (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l))
-   (r:posreal), CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL fn cv) 0 r.
-intros; unfold CVU in |- *; intros.
-unfold CVN_r in X.
-elim X; intros An X0.
-elim X0; intros s H0.
-elim H0; intros.
-cut (Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n - s) 0).
-intro; unfold Un_cv in H3.
-elim (H3 eps H); intros N0 H4.
-exists N0; intros.
-apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
-rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Rabs (An k)) n - s));
- rewrite Ropp_minus_distr';
- rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)).
-eapply sum_maj1.
-unfold SFL in |- *; case (cv y); intro.
-trivial.
-apply H1.
-intro; elim H0; intros.
-rewrite (Rabs_right (An n0)).
-apply H8; apply H6.
-apply Rle_ge; apply Rle_trans with (Rabs (fn n0 y)).
-apply Rabs_pos.
-apply H8; apply H6.
-apply Rle_ge;
- apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n).
-rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm s);
- rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l;
- apply sum_incr.
-apply H1.
-intro; apply Rabs_pos.
-unfold R_dist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4.
-assert (H7 := H4 n H5).
-rewrite Rplus_0_r in H7; apply H7.
-unfold Un_cv in H1; unfold Un_cv in |- *; intros.
-elim (H1 _ H3); intros.
-exists x; intros.
-unfold R_dist in |- *; unfold R_dist in H4.
-rewrite Rminus_0_r; apply H4; assumption.
+  forall (fn:nat -> R -> R)
+    (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l))
+    (r:posreal), CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL fn cv) 0 r.
+Proof.
+  intros; unfold CVU in |- *; intros.
+  unfold CVN_r in X.
+  elim X; intros An X0.
+  elim X0; intros s H0.
+  elim H0; intros.
+  cut (Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n - s) 0).
+  intro; unfold Un_cv in H3.
+  elim (H3 eps H); intros N0 H4.
+  exists N0; intros.
+  apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
+  rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Rabs (An k)) n - s));
+    rewrite Ropp_minus_distr';
+      rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)).
+  eapply sum_maj1.
+  unfold SFL in |- *; case (cv y); intro.
+  trivial.
+  apply H1.
+  intro; elim H0; intros.
+  rewrite (Rabs_right (An n0)).
+  apply H8; apply H6.
+  apply Rle_ge; apply Rle_trans with (Rabs (fn n0 y)).
+  apply Rabs_pos.
+  apply H8; apply H6.
+  apply Rle_ge;
+    apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n).
+  rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm s);
+    rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l;
+      apply sum_incr.
+  apply H1.
+  intro; apply Rabs_pos.
+  unfold R_dist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4.
+  assert (H7 := H4 n H5).
+  rewrite Rplus_0_r in H7; apply H7.
+  unfold Un_cv in H1; unfold Un_cv in |- *; intros.
+  elim (H1 _ H3); intros.
+  exists x; intros.
+  unfold R_dist in |- *; unfold R_dist in H4.
+  rewrite Rminus_0_r; apply H4; assumption.
 Qed.
 
-(* Each limit of a sequence of functions which converges uniformly is continue *)
+(** Each limit of a sequence of functions which converges uniformly is continue *)
 Lemma CVU_continuity :
- forall (fn:nat -> R -> R) (f:R -> R) (x:R) (r:posreal),
-   CVU fn f x r ->
-   (forall (n:nat) (y:R), Boule x r y -> continuity_pt (fn n) y) ->
-   forall y:R, Boule x r y -> continuity_pt f y.
-intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; unfold R_dist in |- *; intros.
-unfold CVU in H.
-cut (0 < eps / 3);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
-elim (H _ H3); intros N0 H4.
-assert (H5 := H0 N0 y H1).
-cut (exists del : posreal, (forall h:R, Rabs h < del -> Boule x r (y + h))).
-intro.
-elim H6; intros del1 H7.
-unfold continuity_pt in H5; unfold continue_in in H5; unfold limit1_in in H5;
- unfold limit_in in H5; simpl in H5; unfold R_dist in H5.
-elim (H5 _ H3); intros del2 H8.
-set (del := Rmin del1 del2).
-exists del; intros.
-split.
-unfold del in |- *; unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
-apply (cond_pos del1).
-elim H8; intros; assumption.
-intros;
- apply Rle_lt_trans with (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - f y)).
-replace (f x0 - f y) with (f x0 - fn N0 x0 + (fn N0 x0 - f y));
- [ apply Rabs_triang | ring ].
-apply Rle_lt_trans with
- (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - fn N0 y) + Rabs (fn N0 y - f y)).
-rewrite Rplus_assoc; apply Rplus_le_compat_l.
-replace (fn N0 x0 - f y) with (fn N0 x0 - fn N0 y + (fn N0 y - f y));
- [ apply Rabs_triang | ring ].
-replace eps with (eps / 3 + eps / 3 + eps / 3).
-repeat apply Rplus_lt_compat.
-apply H4.
-apply le_n.
-replace x0 with (y + (x0 - y)); [ idtac | ring ]; apply H7.
-elim H9; intros.
-apply Rlt_le_trans with del.
-assumption.
-unfold del in |- *; apply Rmin_l.
-elim H8; intros.
-apply H11.
-split.
-elim H9; intros; assumption.
-elim H9; intros; apply Rlt_le_trans with del.
-assumption.
-unfold del in |- *; apply Rmin_r.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H4.
-apply le_n.
-assumption.
-apply Rmult_eq_reg_l with 3.
-do 2 rewrite Rmult_plus_distr_l; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
- rewrite Rinv_r_simpl_m.
-ring.
-discrR.
-discrR.
-cut (0 < r - Rabs (x - y)).
-intro; exists (mkposreal _ H6).
-simpl in |- *; intros.
-unfold Boule in |- *; replace (y + h - x) with (h + (y - x));
- [ idtac | ring ]; apply Rle_lt_trans with (Rabs h + Rabs (y - x)).
-apply Rabs_triang.
-apply Rplus_lt_reg_r with (- Rabs (x - y)).
-rewrite <- (Rabs_Ropp (y - x)); rewrite Ropp_minus_distr'.
-replace (- Rabs (x - y) + r) with (r - Rabs (x - y)).
-replace (- Rabs (x - y) + (Rabs h + Rabs (x - y))) with (Rabs h).
-apply H7.
-ring.
-ring.
-unfold Boule in H1; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr';
- apply Rplus_lt_reg_r with (Rabs (y - x)).
-rewrite Rplus_0_r; replace (Rabs (y - x) + (r - Rabs (y - x))) with (pos r);
- [ apply H1 | ring ].
+  forall (fn:nat -> R -> R) (f:R -> R) (x:R) (r:posreal),
+    CVU fn f x r ->
+    (forall (n:nat) (y:R), Boule x r y -> continuity_pt (fn n) y) ->
+    forall y:R, Boule x r y -> continuity_pt f y.
+Proof.
+  intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      simpl in |- *; unfold R_dist in |- *; intros.
+  unfold CVU in H.
+  cut (0 < eps / 3);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (H _ H3); intros N0 H4.
+  assert (H5 := H0 N0 y H1).
+  cut (exists del : posreal, (forall h:R, Rabs h < del -> Boule x r (y + h))).
+  intro.
+  elim H6; intros del1 H7.
+  unfold continuity_pt in H5; unfold continue_in in H5; unfold limit1_in in H5;
+    unfold limit_in in H5; simpl in H5; unfold R_dist in H5.
+  elim (H5 _ H3); intros del2 H8.
+  set (del := Rmin del1 del2).
+  exists del; intros.
+  split.
+  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
+  apply (cond_pos del1).
+  elim H8; intros; assumption.
+  intros;
+    apply Rle_lt_trans with (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - f y)).
+  replace (f x0 - f y) with (f x0 - fn N0 x0 + (fn N0 x0 - f y));
+  [ apply Rabs_triang | ring ].
+  apply Rle_lt_trans with
+    (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - fn N0 y) + Rabs (fn N0 y - f y)).
+  rewrite Rplus_assoc; apply Rplus_le_compat_l.
+  replace (fn N0 x0 - f y) with (fn N0 x0 - fn N0 y + (fn N0 y - f y));
+  [ apply Rabs_triang | ring ].
+  replace eps with (eps / 3 + eps / 3 + eps / 3).
+  repeat apply Rplus_lt_compat.
+  apply H4.
+  apply le_n.
+  replace x0 with (y + (x0 - y)); [ idtac | ring ]; apply H7.
+  elim H9; intros.
+  apply Rlt_le_trans with del.
+  assumption.
+  unfold del in |- *; apply Rmin_l.
+  elim H8; intros.
+  apply H11.
+  split.
+  elim H9; intros; assumption.
+  elim H9; intros; apply Rlt_le_trans with del.
+  assumption.
+  unfold del in |- *; apply Rmin_r.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H4.
+  apply le_n.
+  assumption.
+  apply Rmult_eq_reg_l with 3.
+  do 2 rewrite Rmult_plus_distr_l; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+    rewrite Rinv_r_simpl_m.
+  ring.
+  discrR.
+  discrR.
+  cut (0 < r - Rabs (x - y)).
+  intro; exists (mkposreal _ H6).
+  simpl in |- *; intros.
+  unfold Boule in |- *; replace (y + h - x) with (h + (y - x));
+    [ idtac | ring ]; apply Rle_lt_trans with (Rabs h + Rabs (y - x)).
+  apply Rabs_triang.
+  apply Rplus_lt_reg_r with (- Rabs (x - y)).
+  rewrite <- (Rabs_Ropp (y - x)); rewrite Ropp_minus_distr'.
+  replace (- Rabs (x - y) + r) with (r - Rabs (x - y)).
+  replace (- Rabs (x - y) + (Rabs h + Rabs (x - y))) with (Rabs h).
+  apply H7.
+  ring.
+  ring.
+  unfold Boule in H1; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr';
+    apply Rplus_lt_reg_r with (Rabs (y - x)).
+  rewrite Rplus_0_r; replace (Rabs (y - x) + (r - Rabs (y - x))) with (pos r);
+    [ apply H1 | ring ].
 Qed.
 
 (**********)
 Lemma continuity_pt_finite_SF :
- forall (fn:nat -> R -> R) (N:nat) (x:R),
-   (forall n:nat, (n <= N)%nat -> continuity_pt (fn n) x) ->
-   continuity_pt (fun y:R => sum_f_R0 (fun k:nat => fn k y) N) x.
-intros; induction  N as [| N HrecN].
-simpl in |- *; apply (H 0%nat); apply le_n.
-simpl in |- *;
- replace (fun y:R => sum_f_R0 (fun k:nat => fn k y) N + fn (S N) y) with
-  ((fun y:R => sum_f_R0 (fun k:nat => fn k y) N) + (fun y:R => fn (S N) y))%F;
- [ idtac | reflexivity ].
-apply continuity_pt_plus.
-apply HrecN.
-intros; apply H.
-apply le_trans with N; [ assumption | apply le_n_Sn ].
-apply (H (S N)); apply le_n.
+  forall (fn:nat -> R -> R) (N:nat) (x:R),
+    (forall n:nat, (n <= N)%nat -> continuity_pt (fn n) x) ->
+    continuity_pt (fun y:R => sum_f_R0 (fun k:nat => fn k y) N) x.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; apply (H 0%nat); apply le_n.
+  simpl in |- *;
+    replace (fun y:R => sum_f_R0 (fun k:nat => fn k y) N + fn (S N) y) with
+    ((fun y:R => sum_f_R0 (fun k:nat => fn k y) N) + (fun y:R => fn (S N) y))%F;
+    [ idtac | reflexivity ].
+  apply continuity_pt_plus.
+  apply HrecN.
+  intros; apply H.
+  apply le_trans with N; [ assumption | apply le_n_Sn ].
+  apply (H (S N)); apply le_n.
 Qed.
 
-(* Continuity and normal convergence *)
+(** Continuity and normal convergence *)
 Lemma SFL_continuity_pt :
- forall (fn:nat -> R -> R)
-   (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l))
-   (r:posreal),
-   CVN_r fn r ->
-   (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y) ->
-   forall y:R, Boule 0 r y -> continuity_pt (SFL fn cv) y.
-intros; eapply CVU_continuity.
-apply CVN_CVU.
-apply X.
-intros; unfold SP in |- *; apply continuity_pt_finite_SF.
-intros; apply H.
-apply H1.
-apply H0.
+  forall (fn:nat -> R -> R)
+    (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l))
+    (r:posreal),
+    CVN_r fn r ->
+    (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y) ->
+    forall y:R, Boule 0 r y -> continuity_pt (SFL fn cv) y.
+Proof.
+  intros; eapply CVU_continuity.
+  apply CVN_CVU.
+  apply X.
+  intros; unfold SP in |- *; apply continuity_pt_finite_SF.
+  intros; apply H.
+  apply H1.
+  apply H0.
 Qed.
 
 Lemma SFL_continuity :
- forall (fn:nat -> R -> R)
-   (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)),
-   CVN_R fn -> (forall n:nat, continuity (fn n)) -> continuity (SFL fn cv).
-intros; unfold continuity in |- *; intro.
-cut (0 < Rabs x + 1);
- [ intro | apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ] ].
-cut (Boule 0 (mkposreal _ H0) x).
-intro; eapply SFL_continuity_pt with (mkposreal _ H0).
-apply X.
-intros; apply (H n y).
-apply H1.
-unfold Boule in |- *; simpl in |- *; rewrite Rminus_0_r;
- pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; 
- apply Rplus_lt_compat_l; apply Rlt_0_1.
+  forall (fn:nat -> R -> R)
+    (cv:forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)),
+    CVN_R fn -> (forall n:nat, continuity (fn n)) -> continuity (SFL fn cv).
+Proof.
+  intros; unfold continuity in |- *; intro.
+  cut (0 < Rabs x + 1);
+    [ intro | apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ] ].
+  cut (Boule 0 (mkposreal _ H0) x).
+  intro; eapply SFL_continuity_pt with (mkposreal _ H0).
+  apply X.
+  intros; apply (H n y).
+  apply H1.
+  unfold Boule in |- *; simpl in |- *; rewrite Rminus_0_r;
+    pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; 
+      apply Rplus_lt_compat_l; apply Rlt_0_1.
 Qed.
 
-(* As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) 
+(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) 
 Lemma CVN_R_CVS :
- forall fn:nat -> R -> R,
-   CVN_R fn -> forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l).
-intros; apply R_complete.
-unfold SP in |- *; set (An := fun N:nat => fn N x).
-change (Cauchy_crit_series An) in |- *.
-apply cauchy_abs.
-unfold Cauchy_crit_series in |- *; apply CV_Cauchy.
-unfold CVN_R in X; cut (0 < Rabs x + 1).
-intro; assert (H0 := X (mkposreal _ H)).
-unfold CVN_r in H0; elim H0; intros Bn H1.
-elim H1; intros l H2.
-elim H2; intros.
-apply Rseries_CV_comp with Bn.
-intro; split.
-apply Rabs_pos.
-unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
- rewrite Rminus_0_r.
-pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- apply Rlt_0_1.
-apply existT with l.
-cut (forall n:nat, 0 <= Bn n).
-intro; unfold Un_cv in H3; unfold Un_cv in |- *; intros.
-elim (H3 _ H6); intros.
-exists x0; intros.
-replace (sum_f_R0 Bn n) with (sum_f_R0 (fun k:nat => Rabs (Bn k)) n).
-apply H7; assumption.
-apply sum_eq; intros; apply Rabs_right; apply Rle_ge; apply H5.
-intro; apply Rle_trans with (Rabs (An n)).
-apply Rabs_pos.
-unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
- rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *; 
- rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1.
-apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ].
+  forall fn:nat -> R -> R,
+    CVN_R fn -> forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l).
+Proof.
+  intros; apply R_complete.
+  unfold SP in |- *; set (An := fun N:nat => fn N x).
+  change (Cauchy_crit_series An) in |- *.
+  apply cauchy_abs.
+  unfold Cauchy_crit_series in |- *; apply CV_Cauchy.
+  unfold CVN_R in X; cut (0 < Rabs x + 1).
+  intro; assert (H0 := X (mkposreal _ H)).
+  unfold CVN_r in H0; elim H0; intros Bn H1.
+  elim H1; intros l H2.
+  elim H2; intros.
+  apply Rseries_CV_comp with Bn.
+  intro; split.
+  apply Rabs_pos.
+  unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
+    rewrite Rminus_0_r.
+  pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    apply Rlt_0_1.
+  apply existT with l.
+  cut (forall n:nat, 0 <= Bn n).
+  intro; unfold Un_cv in H3; unfold Un_cv in |- *; intros.
+  elim (H3 _ H6); intros.
+  exists x0; intros.
+  replace (sum_f_R0 Bn n) with (sum_f_R0 (fun k:nat => Rabs (Bn k)) n).
+  apply H7; assumption.
+  apply sum_eq; intros; apply Rabs_right; apply Rle_ge; apply H5.
+  intro; apply Rle_trans with (Rabs (An n)).
+  apply Rabs_pos.
+  unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
+    rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *; 
+      rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1.
+  apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ].
 Qed.
diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v
index 6087d3f2..a8f72302 100644
--- a/theories/Reals/PartSum.v
+++ b/theories/Reals/PartSum.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: PartSum.v,v 1.11.2.2 2005/07/13 22:28:30 herbelin Exp $ i*)
+
+(*i $Id: PartSum.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -16,340 +16,361 @@ Require Import Max.
 Open Local Scope R_scope.
 
 Lemma tech1 :
- forall (An:nat -> R) (N:nat),
-   (forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N.
-intros; induction  N as [| N HrecN].
-simpl in |- *; apply H; apply le_n.
-simpl in |- *; apply Rplus_lt_0_compat.
-apply HrecN; intros; apply H; apply le_S; assumption.
-apply H; apply le_n.
+  forall (An:nat -> R) (N:nat),
+    (forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; apply H; apply le_n.
+  simpl in |- *; apply Rplus_lt_0_compat.
+  apply HrecN; intros; apply H; apply le_S; assumption.
+  apply H; apply le_n.
 Qed.
 
 (* Chasles' relation *)
 Lemma tech2 :
- forall (An:nat -> R) (m n:nat),
-   (m < n)%nat ->
-   sum_f_R0 An n =
-   sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). 
-intros; induction  n as [| n Hrecn].
-elim (lt_n_O _ H).
-cut ((m < n)%nat \/ m = n).
-intro; elim H0; intro.
-replace (sum_f_R0 An (S n)) with (sum_f_R0 An n + An (S n));
- [ idtac | reflexivity ].
-replace (S n - S m)%nat with (S (n - S m)).
-replace (sum_f_R0 (fun i:nat => An (S m + i)%nat) (S (n - S m))) with
- (sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m) +
-  An (S m + S (n - S m))%nat); [ idtac | reflexivity ].
-replace (S m + S (n - S m))%nat with (S n).
-rewrite (Hrecn H1).
-ring.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite S_INR;
- rewrite minus_INR.
-rewrite S_INR; ring.
-apply lt_le_S; assumption.
-apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
-repeat rewrite S_INR; ring.
-apply le_n_S; apply lt_le_weak; assumption.
-apply lt_le_S; assumption.
-rewrite H1; rewrite <- minus_n_n; simpl in |- *.
-replace (n + 0)%nat with n; [ reflexivity | ring ].
-inversion H.
-right; reflexivity.
-left; apply lt_le_trans with (S m); [ apply lt_n_Sn | assumption ].
+  forall (An:nat -> R) (m n:nat),
+    (m < n)%nat ->
+    sum_f_R0 An n =
+    sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). 
+Proof.
+  intros; induction  n as [| n Hrecn].
+  elim (lt_n_O _ H).
+  cut ((m < n)%nat \/ m = n).
+  intro; elim H0; intro.
+  replace (sum_f_R0 An (S n)) with (sum_f_R0 An n + An (S n));
+  [ idtac | reflexivity ].
+  replace (S n - S m)%nat with (S (n - S m)).
+  replace (sum_f_R0 (fun i:nat => An (S m + i)%nat) (S (n - S m))) with
+  (sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m) +
+    An (S m + S (n - S m))%nat); [ idtac | reflexivity ].
+  replace (S m + S (n - S m))%nat with (S n).
+  rewrite (Hrecn H1).
+  ring.
+  apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite S_INR;
+    rewrite minus_INR.
+  rewrite S_INR; ring.
+  apply lt_le_S; assumption.
+  apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
+  repeat rewrite S_INR; ring.
+  apply le_n_S; apply lt_le_weak; assumption.
+  apply lt_le_S; assumption.
+  rewrite H1; rewrite <- minus_n_n; simpl in |- *.
+  replace (n + 0)%nat with n; [ reflexivity | ring ].
+  inversion H.
+  right; reflexivity.
+  left; apply lt_le_trans with (S m); [ apply lt_n_Sn | assumption ].
 Qed.
 
 (* Sum of geometric sequences *)
 Lemma tech3 :
- forall (k:R) (N:nat),
-   k <> 1 -> sum_f_R0 (fun i:nat => k ^ i) N = (1 - k ^ S N) / (1 - k).
-intros; cut (1 - k <> 0).
-intro; induction  N as [| N HrecN].
-simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
-reflexivity.
-apply H0.
-replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with
- (sum_f_R0 (fun i:nat => k ^ i) N + k ^ S N); [ idtac | reflexivity ];
- rewrite HrecN;
- replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with
-  ((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)).
-apply Rmult_eq_reg_l with (1 - k).
-unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
- repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
- [ do 2 rewrite Rmult_1_l; simpl in |- *; ring | apply H0 ].
-apply H0.
-unfold Rdiv in |- *; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
- repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; reflexivity.
-apply H0.
-apply Rminus_eq_contra; red in |- *; intro; elim H; symmetry  in |- *;
- assumption.
+  forall (k:R) (N:nat),
+    k <> 1 -> sum_f_R0 (fun i:nat => k ^ i) N = (1 - k ^ S N) / (1 - k).
+Proof.
+  intros; cut (1 - k <> 0).
+  intro; induction  N as [| N HrecN].
+  simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
+  reflexivity.
+  apply H0.
+  replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with
+  (sum_f_R0 (fun i:nat => k ^ i) N + k ^ S N); [ idtac | reflexivity ];
+  rewrite HrecN;
+    replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with
+    ((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)).
+  apply Rmult_eq_reg_l with (1 - k).
+  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
+    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+      [ do 2 rewrite Rmult_1_l; simpl in |- *; ring | apply H0 ].
+  apply H0.
+  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
+    repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; reflexivity.
+  apply H0.
+  apply Rminus_eq_contra; red in |- *; intro; elim H; symmetry  in |- *;
+    assumption.
 Qed.
 
 Lemma tech4 :
- forall (An:nat -> R) (k:R) (N:nat),
-   0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N.
-intros; induction  N as [| N HrecN].
-simpl in |- *; right; ring.
-apply Rle_trans with (k * An N).
-left; apply (H0 N).
-replace (S N) with (N + 1)%nat; [ idtac | ring ].
-rewrite pow_add; simpl in |- *; rewrite Rmult_1_r;
- replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N));
- [ idtac | ring ]; apply Rmult_le_compat_l.
-assumption.
-apply HrecN.
+  forall (An:nat -> R) (k:R) (N:nat),
+    0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; right; ring.
+  apply Rle_trans with (k * An N).
+  left; apply (H0 N).
+  replace (S N) with (N + 1)%nat; [ idtac | ring ].
+  rewrite pow_add; simpl in |- *; rewrite Rmult_1_r;
+    replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N));
+    [ idtac | ring ]; apply Rmult_le_compat_l.
+  assumption.
+  apply HrecN.
 Qed.
 
 Lemma tech5 :
- forall (An:nat -> R) (N:nat), sum_f_R0 An (S N) = sum_f_R0 An N + An (S N).
-intros; reflexivity.
+  forall (An:nat -> R) (N:nat), sum_f_R0 An (S N) = sum_f_R0 An N + An (S N).
+Proof.
+  intros; reflexivity.
 Qed.
 
 Lemma tech6 :
- forall (An:nat -> R) (k:R) (N:nat),
-   0 <= k ->
-   (forall i:nat, An (S i) < k * An i) ->
-   sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N.
-intros; induction  N as [| N HrecN].
-simpl in |- *; right; ring.
-apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)).
-rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N)));
- apply Rplus_le_compat_l.
-apply HrecN.
-rewrite tech5; rewrite Rmult_plus_distr_l; apply Rplus_le_compat_l.
-apply tech4; assumption.
+  forall (An:nat -> R) (k:R) (N:nat),
+    0 <= k ->
+    (forall i:nat, An (S i) < k * An i) ->
+    sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; right; ring.
+  apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)).
+  rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N)));
+    apply Rplus_le_compat_l.
+  apply HrecN.
+  rewrite tech5; rewrite Rmult_plus_distr_l; apply Rplus_le_compat_l.
+  apply tech4; assumption.
 Qed.
 
 Lemma tech7 : forall r1 r2:R, r1 <> 0 -> r2 <> 0 -> r1 <> r2 -> / r1 <> / r2.
-intros; red in |- *; intro.
-assert (H3 := Rmult_eq_compat_l r1 _ _ H2).
-rewrite <- Rinv_r_sym in H3; [ idtac | assumption ].
-assert (H4 := Rmult_eq_compat_l r2 _ _ H3).
-rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4.
-rewrite Rinv_r_simpl_m in H4; [ idtac | assumption ].
-elim H1; symmetry  in |- *; assumption.
+Proof.
+  intros; red in |- *; intro.
+  assert (H3 := Rmult_eq_compat_l r1 _ _ H2).
+  rewrite <- Rinv_r_sym in H3; [ idtac | assumption ].
+  assert (H4 := Rmult_eq_compat_l r2 _ _ H3).
+  rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4.
+  rewrite Rinv_r_simpl_m in H4; [ idtac | assumption ].
+  elim H1; symmetry  in |- *; assumption.
 Qed.
 
 Lemma tech11 :
- forall (An Bn Cn:nat -> R) (N:nat),
-   (forall i:nat, An i = Bn i - Cn i) ->
-   sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N.
-intros; induction  N as [| N HrecN].
-simpl in |- *; apply H.
-do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring.
+  forall (An Bn Cn:nat -> R) (N:nat),
+    (forall i:nat, An i = Bn i - Cn i) ->
+    sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; apply H.
+  do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring.
 Qed.
 
 Lemma tech12 :
- forall (An:nat -> R) (x l:R),
-   Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l ->
-   Pser An x l.
-intros; unfold Pser in |- *; unfold infinit_sum in |- *; unfold Un_cv in H;
- assumption.
+  forall (An:nat -> R) (x l:R),
+    Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l ->
+    Pser An x l.
+Proof.
+  intros; unfold Pser in |- *; unfold infinit_sum in |- *; unfold Un_cv in H;
+    assumption.
 Qed. 
 
 Lemma scal_sum :
- forall (An:nat -> R) (N:nat) (x:R),
-   x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N.
-intros; induction  N as [| N HrecN].
-simpl in |- *; ring.
-do 2 rewrite tech5.
-rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring.
+  forall (An:nat -> R) (N:nat) (x:R),
+    x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; ring.
+  do 2 rewrite tech5.
+  rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring.
 Qed.
 
 Lemma decomp_sum :
- forall (An:nat -> R) (N:nat),
-   (0 < N)%nat ->
-   sum_f_R0 An N = An 0%nat + sum_f_R0 (fun i:nat => An (S i)) (pred N).
-intros; induction  N as [| N HrecN].
-elim (lt_irrefl _ H).
-cut ((0 < N)%nat \/ N = 0%nat).
-intro; elim H0; intro.
-cut (S (pred N) = pred (S N)).
-intro; rewrite <- H2.
-do 2 rewrite tech5.
-replace (S (S (pred N))) with (S N).
-rewrite (HrecN H1); ring.
-rewrite H2; simpl in |- *; reflexivity.
-assert (H2 := O_or_S N).
-elim H2; intros.
-elim a; intros.
-rewrite <- p.
-simpl in |- *; reflexivity.
-rewrite <- b in H1; elim (lt_irrefl _ H1).
-rewrite H1; simpl in |- *; reflexivity.
-inversion H.
-right; reflexivity.
-left; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
+  forall (An:nat -> R) (N:nat),
+    (0 < N)%nat ->
+    sum_f_R0 An N = An 0%nat + sum_f_R0 (fun i:nat => An (S i)) (pred N).
+Proof.
+  intros; induction  N as [| N HrecN].
+  elim (lt_irrefl _ H).
+  cut ((0 < N)%nat \/ N = 0%nat).
+  intro; elim H0; intro.
+  cut (S (pred N) = pred (S N)).
+  intro; rewrite <- H2.
+  do 2 rewrite tech5.
+  replace (S (S (pred N))) with (S N).
+  rewrite (HrecN H1); ring.
+  rewrite H2; simpl in |- *; reflexivity.
+  assert (H2 := O_or_S N).
+  elim H2; intros.
+  elim a; intros.
+  rewrite <- p.
+  simpl in |- *; reflexivity.
+  rewrite <- b in H1; elim (lt_irrefl _ H1).
+  rewrite H1; simpl in |- *; reflexivity.
+  inversion H.
+  right; reflexivity.
+  left; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
 Qed.
 
 Lemma plus_sum :
- forall (An Bn:nat -> R) (N:nat),
-   sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N.
-intros; induction  N as [| N HrecN].
-simpl in |- *; ring.
-do 3 rewrite tech5; rewrite HrecN; ring.
+  forall (An Bn:nat -> R) (N:nat),
+    sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; ring.
+  do 3 rewrite tech5; rewrite HrecN; ring.
 Qed.
 
 Lemma sum_eq :
- forall (An Bn:nat -> R) (N:nat),
-   (forall i:nat, (i <= N)%nat -> An i = Bn i) ->
-   sum_f_R0 An N = sum_f_R0 Bn N.
-intros; induction  N as [| N HrecN].
-simpl in |- *; apply H; apply le_n.
-do 2 rewrite tech5; rewrite HrecN.
-rewrite (H (S N)); [ reflexivity | apply le_n ].
-intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ].
+  forall (An Bn:nat -> R) (N:nat),
+    (forall i:nat, (i <= N)%nat -> An i = Bn i) ->
+    sum_f_R0 An N = sum_f_R0 Bn N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; apply H; apply le_n.
+  do 2 rewrite tech5; rewrite HrecN.
+  rewrite (H (S N)); [ reflexivity | apply le_n ].
+  intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ].
 Qed.
 
 (* Unicity of the limit defined by convergent series *)
 Lemma uniqueness_sum :
- forall (An:nat -> R) (l1 l2:R),
-   infinit_sum An l1 -> infinit_sum An l2 -> l1 = l2.
-unfold infinit_sum in |- *; intros.
-case (Req_dec l1 l2); intro.
-assumption.
-cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ].
-elim (H (Rabs ((l1 - l2) / 2)) H2); intros.
-elim (H0 (Rabs ((l1 - l2) / 2)) H2); intros.
-set (N := max x0 x); cut (N >= x0)%nat.
-cut (N >= x)%nat.
-intros; assert (H7 := H3 N H5); assert (H8 := H4 N H6).
-cut (Rabs (l1 - l2) <= R_dist (sum_f_R0 An N) l1 + R_dist (sum_f_R0 An N) l2).
-intro; assert (H10 := Rplus_lt_compat _ _ _ _ H7 H8);
- assert (H11 := Rle_lt_trans _ _ _ H9 H10); unfold Rdiv in H11;
- rewrite Rabs_mult in H11.
-cut (Rabs (/ 2) = / 2).
-intro; rewrite H12 in H11; assert (H13 := double_var); unfold Rdiv in H13;
- rewrite <- H13 in H11.
-elim (Rlt_irrefl _ H11).
-apply Rabs_right; left; change (0 < / 2) in |- *; apply Rinv_0_lt_compat;
- cut (0%nat <> 2%nat);
- [ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR in |- *;
-    intro; assumption
- | discriminate ].
-unfold R_dist in |- *; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
- rewrite Ropp_minus_distr'.
-replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2));
- [ idtac | ring ].
-apply Rabs_triang.
-unfold ge in |- *; unfold N in |- *; apply le_max_r.
-unfold ge in |- *; unfold N in |- *; apply le_max_l.
-unfold Rdiv in |- *; apply prod_neq_R0.
-apply Rminus_eq_contra; assumption.
-apply Rinv_neq_0_compat; discrR.
+  forall (An:nat -> R) (l1 l2:R),
+    infinit_sum An l1 -> infinit_sum An l2 -> l1 = l2.
+Proof.
+  unfold infinit_sum in |- *; intros.
+  case (Req_dec l1 l2); intro.
+  assumption.
+  cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ].
+  elim (H (Rabs ((l1 - l2) / 2)) H2); intros.
+  elim (H0 (Rabs ((l1 - l2) / 2)) H2); intros.
+  set (N := max x0 x); cut (N >= x0)%nat.
+  cut (N >= x)%nat.
+  intros; assert (H7 := H3 N H5); assert (H8 := H4 N H6).
+  cut (Rabs (l1 - l2) <= R_dist (sum_f_R0 An N) l1 + R_dist (sum_f_R0 An N) l2).
+  intro; assert (H10 := Rplus_lt_compat _ _ _ _ H7 H8);
+    assert (H11 := Rle_lt_trans _ _ _ H9 H10); unfold Rdiv in H11;
+      rewrite Rabs_mult in H11.
+  cut (Rabs (/ 2) = / 2).
+  intro; rewrite H12 in H11; assert (H13 := double_var); unfold Rdiv in H13;
+    rewrite <- H13 in H11.
+  elim (Rlt_irrefl _ H11).
+  apply Rabs_right; left; change (0 < / 2) in |- *; apply Rinv_0_lt_compat;
+    cut (0%nat <> 2%nat);
+      [ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR in |- *;
+        intro; assumption
+        | discriminate ].
+  unfold R_dist in |- *; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
+    rewrite Ropp_minus_distr'.
+  replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2));
+  [ idtac | ring ].
+  apply Rabs_triang.
+  unfold ge in |- *; unfold N in |- *; apply le_max_r.
+  unfold ge in |- *; unfold N in |- *; apply le_max_l.
+  unfold Rdiv in |- *; apply prod_neq_R0.
+  apply Rminus_eq_contra; assumption.
+  apply Rinv_neq_0_compat; discrR.
 Qed.
 
 Lemma minus_sum :
- forall (An Bn:nat -> R) (N:nat),
-   sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. 
-intros; induction  N as [| N HrecN]. 
-simpl in |- *; ring. 
-do 3 rewrite tech5; rewrite HrecN; ring. 
+  forall (An Bn:nat -> R) (N:nat),
+    sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. 
+Proof.
+  intros; induction  N as [| N HrecN]. 
+  simpl in |- *; ring. 
+  do 3 rewrite tech5; rewrite HrecN; ring. 
 Qed. 
 
 Lemma sum_decomposition :
- forall (An:nat -> R) (N:nat),
-   sum_f_R0 (fun l:nat => An (2 * l)%nat) (S N) +
-   sum_f_R0 (fun l:nat => An (S (2 * l))) N = sum_f_R0 An (2 * S N).
-intros.
-induction  N as [| N HrecN].
-simpl in |- *; ring.
-rewrite tech5.
-rewrite (tech5 (fun l:nat => An (S (2 * l))) N).
-replace (2 * S (S N))%nat with (S (S (2 * S N))).
-rewrite (tech5 An (S (2 * S N))).
-rewrite (tech5 An (2 * S N)).
-rewrite <- HrecN.
-ring.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR.
-ring.
+  forall (An:nat -> R) (N:nat),
+    sum_f_R0 (fun l:nat => An (2 * l)%nat) (S N) +
+    sum_f_R0 (fun l:nat => An (S (2 * l))) N = sum_f_R0 An (2 * S N).
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  simpl in |- *; ring.
+  rewrite tech5.
+  rewrite (tech5 (fun l:nat => An (S (2 * l))) N).
+  replace (2 * S (S N))%nat with (S (S (2 * S N))).
+  rewrite (tech5 An (S (2 * S N))).
+  rewrite (tech5 An (2 * S N)).
+  rewrite <- HrecN.
+  ring.
+  ring.
 Qed.
 
 Lemma sum_Rle :
- forall (An Bn:nat -> R) (N:nat),
-   (forall n:nat, (n <= N)%nat -> An n <= Bn n) ->
-   sum_f_R0 An N <= sum_f_R0 Bn N.
-intros.
-induction  N as [| N HrecN].
-simpl in |- *; apply H.
-apply le_n.
-do 2 rewrite tech5.
-apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
-apply Rplus_le_compat_l.
-apply H.
-apply le_n.
-do 2 rewrite <- (Rplus_comm (Bn (S N))).
-apply Rplus_le_compat_l.
-apply HrecN.
-intros; apply H.
-apply le_trans with N; [ assumption | apply le_n_Sn ].
+  forall (An Bn:nat -> R) (N:nat),
+    (forall n:nat, (n <= N)%nat -> An n <= Bn n) ->
+    sum_f_R0 An N <= sum_f_R0 Bn N.
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  simpl in |- *; apply H.
+  apply le_n.
+  do 2 rewrite tech5.
+  apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
+  apply Rplus_le_compat_l.
+  apply H.
+  apply le_n.
+  do 2 rewrite <- (Rplus_comm (Bn (S N))).
+  apply Rplus_le_compat_l.
+  apply HrecN.
+  intros; apply H.
+  apply le_trans with N; [ assumption | apply le_n_Sn ].
 Qed.
 
 Lemma Rsum_abs :
- forall (An:nat -> R) (N:nat),
-   Rabs (sum_f_R0 An N) <= sum_f_R0 (fun l:nat => Rabs (An l)) N.
-intros.
-induction  N as [| N HrecN].
-simpl in |- *.
-right; reflexivity.
-do 2 rewrite tech5.
-apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
-apply Rabs_triang.
-do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
-apply Rplus_le_compat_l.
-apply HrecN.
+  forall (An:nat -> R) (N:nat),
+    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun l:nat => Rabs (An l)) N.
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  simpl in |- *.
+  right; reflexivity.
+  do 2 rewrite tech5.
+  apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
+  apply Rabs_triang.
+  do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
+  apply Rplus_le_compat_l.
+  apply HrecN.
 Qed.
 
 Lemma sum_cte :
- forall (x:R) (N:nat), sum_f_R0 (fun _:nat => x) N = x * INR (S N).
-intros.
-induction  N as [| N HrecN].
-simpl in |- *; ring.
-rewrite tech5.
-rewrite HrecN; repeat rewrite S_INR; ring.
+  forall (x:R) (N:nat), sum_f_R0 (fun _:nat => x) N = x * INR (S N).
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  simpl in |- *; ring.
+  rewrite tech5.
+  rewrite HrecN; repeat rewrite S_INR; ring.
 Qed.
 
 (**********)
 Lemma sum_growing :
- forall (An Bn:nat -> R) (N:nat),
-   (forall n:nat, An n <= Bn n) -> sum_f_R0 An N <= sum_f_R0 Bn N.
-intros.
-induction  N as [| N HrecN].
-simpl in |- *; apply H.
-do 2 rewrite tech5.
-apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
-apply Rplus_le_compat_l; apply H.
-do 2 rewrite <- (Rplus_comm (Bn (S N))).
-apply Rplus_le_compat_l; apply HrecN.
+  forall (An Bn:nat -> R) (N:nat),
+    (forall n:nat, An n <= Bn n) -> sum_f_R0 An N <= sum_f_R0 Bn N.
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  simpl in |- *; apply H.
+  do 2 rewrite tech5.
+  apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
+  apply Rplus_le_compat_l; apply H.
+  do 2 rewrite <- (Rplus_comm (Bn (S N))).
+  apply Rplus_le_compat_l; apply HrecN.
 Qed.
 
 (**********)
 Lemma Rabs_triang_gen :
- forall (An:nat -> R) (N:nat),
-   Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. 
-intros.
-induction  N as [| N HrecN].
-simpl in |- *.
-right; reflexivity.
-do 2 rewrite tech5.
-apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
-apply Rabs_triang.
-do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
-apply Rplus_le_compat_l; apply HrecN.
+  forall (An:nat -> R) (N:nat),
+    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. 
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  simpl in |- *.
+  right; reflexivity.
+  do 2 rewrite tech5.
+  apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
+  apply Rabs_triang.
+  do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
+  apply Rplus_le_compat_l; apply HrecN.
 Qed.
 
 (**********)
 Lemma cond_pos_sum :
- forall (An:nat -> R) (N:nat),
-   (forall n:nat, 0 <= An n) -> 0 <= sum_f_R0 An N.
-intros.
-induction  N as [| N HrecN].
-simpl in |- *; apply H.
-rewrite tech5.
-apply Rplus_le_le_0_compat.
-apply HrecN.
-apply H.
+  forall (An:nat -> R) (N:nat),
+    (forall n:nat, 0 <= An n) -> 0 <= sum_f_R0 An N.
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  simpl in |- *; apply H.
+  rewrite tech5.
+  apply Rplus_le_le_0_compat.
+  apply HrecN.
+  apply H.
 Qed.
 
 (* Cauchy's criterion for series *)
@@ -358,122 +379,126 @@ Definition Cauchy_crit_series (An:nat -> R) : Prop :=
 
 (* If (|An|) satisfies the Cauchy's criterion for series, then (An) too *)
 Lemma cauchy_abs :
- forall An:nat -> R,
-   Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An.
-unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
-intros.
-elim (H eps H0); intros.
-exists x.
-intros.
-cut
- (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
-  R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
-    (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
-intro.
-apply Rle_lt_trans with
- (R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
-    (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
-assumption.
-apply H1; assumption.
-assert (H4 := lt_eq_lt_dec n m).
-elim H4; intro.
-elim a; intro.
-rewrite (tech2 An n m); [ idtac | assumption ].
-rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
-unfold R_dist in |- *.
-unfold Rminus in |- *.
-do 2 rewrite Ropp_plus_distr.
-do 2 rewrite <- Rplus_assoc.
-do 2 rewrite Rplus_opp_r.
-do 2 rewrite Rplus_0_l.
-do 2 rewrite Rabs_Ropp.
-rewrite
- (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S n + i)%nat)) (m - S n)))
- .
-set (Bn := fun i:nat => An (S n + i)%nat).
-replace (fun i:nat => Rabs (An (S n + i)%nat)) with
- (fun i:nat => Rabs (Bn i)).
-apply Rabs_triang_gen.
-unfold Bn in |- *; reflexivity.
-apply Rle_ge.
-apply cond_pos_sum.
-intro; apply Rabs_pos.
-rewrite b.
-unfold R_dist in |- *.
-unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
-rewrite Rabs_R0; right; reflexivity.
-rewrite (tech2 An m n); [ idtac | assumption ].
-rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ].
-unfold R_dist in |- *.
-unfold Rminus in |- *.
-do 2 rewrite Rplus_assoc.
-rewrite (Rplus_comm (sum_f_R0 An m)).
-rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
-do 2 rewrite Rplus_assoc.
-do 2 rewrite Rplus_opp_l.
-do 2 rewrite Rplus_0_r.
-rewrite
- (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S m + i)%nat)) (n - S m)))
- .
-set (Bn := fun i:nat => An (S m + i)%nat).
-replace (fun i:nat => Rabs (An (S m + i)%nat)) with
- (fun i:nat => Rabs (Bn i)).
-apply Rabs_triang_gen.
-unfold Bn in |- *; reflexivity.
-apply Rle_ge.
-apply cond_pos_sum.
-intro; apply Rabs_pos.
+  forall An:nat -> R,
+    Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An.
+Proof.
+  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+  intros.
+  elim (H eps H0); intros.
+  exists x.
+  intros.
+  cut
+    (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
+      R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
+      (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
+  intro.
+  apply Rle_lt_trans with
+    (R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
+      (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
+  assumption.
+  apply H1; assumption.
+  assert (H4 := lt_eq_lt_dec n m).
+  elim H4; intro.
+  elim a; intro.
+  rewrite (tech2 An n m); [ idtac | assumption ].
+  rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
+  unfold R_dist in |- *.
+  unfold Rminus in |- *.
+  do 2 rewrite Ropp_plus_distr.
+  do 2 rewrite <- Rplus_assoc.
+  do 2 rewrite Rplus_opp_r.
+  do 2 rewrite Rplus_0_l.
+  do 2 rewrite Rabs_Ropp.
+  rewrite
+    (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S n + i)%nat)) (m - S n)))
+    .
+  set (Bn := fun i:nat => An (S n + i)%nat).
+  replace (fun i:nat => Rabs (An (S n + i)%nat)) with
+  (fun i:nat => Rabs (Bn i)).
+  apply Rabs_triang_gen.
+  unfold Bn in |- *; reflexivity.
+  apply Rle_ge.
+  apply cond_pos_sum.
+  intro; apply Rabs_pos.
+  rewrite b.
+  unfold R_dist in |- *.
+  unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
+  rewrite Rabs_R0; right; reflexivity.
+  rewrite (tech2 An m n); [ idtac | assumption ].
+  rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ].
+  unfold R_dist in |- *.
+  unfold Rminus in |- *.
+  do 2 rewrite Rplus_assoc.
+  rewrite (Rplus_comm (sum_f_R0 An m)).
+  rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
+  do 2 rewrite Rplus_assoc.
+  do 2 rewrite Rplus_opp_l.
+  do 2 rewrite Rplus_0_r.
+  rewrite
+    (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S m + i)%nat)) (n - S m)))
+    .
+  set (Bn := fun i:nat => An (S m + i)%nat).
+  replace (fun i:nat => Rabs (An (S m + i)%nat)) with
+  (fun i:nat => Rabs (Bn i)).
+  apply Rabs_triang_gen.
+  unfold Bn in |- *; reflexivity.
+  apply Rle_ge.
+  apply cond_pos_sum.
+  intro; apply Rabs_pos.
 Qed.
 
 (**********)
 Lemma cv_cauchy_1 :
- forall An:nat -> R,
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) ->
-   Cauchy_crit_series An.
-intros.
-elim X; intros.
-unfold Un_cv in p.
-unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
-intros.
-cut (0 < eps / 2).
-intro.
-elim (p (eps / 2) H0); intros.
-exists x0.
-intros.
-apply Rle_lt_trans with (R_dist (sum_f_R0 An n) x + R_dist (sum_f_R0 An m) x).
-unfold R_dist in |- *.
-replace (sum_f_R0 An n - sum_f_R0 An m) with
- (sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ].
-rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)).
-apply Rabs_triang.
-apply Rlt_le_trans with (eps / 2 + eps / 2).
-apply Rplus_lt_compat.
-apply H1; assumption.
-apply H1; assumption.
-right; symmetry  in |- *; apply double_var.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  forall An:nat -> R,
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l) ->
+    Cauchy_crit_series An.
+Proof.
+  intros An X.
+  elim X; intros.
+  unfold Un_cv in p.
+  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+  intros.
+  cut (0 < eps / 2).
+  intro.
+  elim (p (eps / 2) H0); intros.
+  exists x0.
+  intros.
+  apply Rle_lt_trans with (R_dist (sum_f_R0 An n) x + R_dist (sum_f_R0 An m) x).
+  unfold R_dist in |- *.
+  replace (sum_f_R0 An n - sum_f_R0 An m) with
+  (sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ].
+  rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)).
+  apply Rabs_triang.
+  apply Rlt_le_trans with (eps / 2 + eps / 2).
+  apply Rplus_lt_compat.
+  apply H1; assumption.
+  apply H1; assumption.
+  right; symmetry  in |- *; apply double_var.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
 Lemma cv_cauchy_2 :
- forall An:nat -> R,
-   Cauchy_crit_series An ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
-intros.
-apply R_complete.
-unfold Cauchy_crit_series in H.
-exact H.
+  forall An:nat -> R,
+    Cauchy_crit_series An ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+Proof.
+  intros.
+  apply R_complete.
+  unfold Cauchy_crit_series in H.
+  exact H.
 Qed.
 
 (**********)
 Lemma sum_eq_R0 :
- forall (An:nat -> R) (N:nat),
-   (forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0.
-intros; induction  N as [| N HrecN].
-simpl in |- *; apply H; apply le_n.
-rewrite tech5; rewrite HrecN;
- [ rewrite Rplus_0_l; apply H; apply le_n
- | intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ] ].
+  forall (An:nat -> R) (N:nat),
+    (forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; apply H; apply le_n.
+  rewrite tech5; rewrite HrecN;
+    [ rewrite Rplus_0_l; apply H; apply le_n
+      | intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ] ].
 Qed.
 
 Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R :=
@@ -481,122 +506,124 @@ Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R :=
 
 (**********)
 Lemma sum_incr :
- forall (An:nat -> R) (N:nat) (l:R),
-   Un_cv (fun n:nat => sum_f_R0 An n) l ->
-   (forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l.
-intros; case (total_order_T (sum_f_R0 An N) l); intro.
-elim s; intro.
-left; apply a.
-right; apply b.
-cut (Un_growing (fun n:nat => sum_f_R0 An n)).
-intro; set (l1 := sum_f_R0 An N) in r.
-unfold Un_cv in H; cut (0 < l1 - l).
-intro; elim (H _ H2); intros.
-set (N0 := max x N); cut (N0 >= x)%nat.
-intro; assert (H5 := H3 N0 H4).
-cut (l1 <= sum_f_R0 An N0).
-intro; unfold R_dist in H5; rewrite Rabs_right in H5.
-cut (sum_f_R0 An N0 < l1).
-intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)).
-apply Rplus_lt_reg_r with (- l).
-do 2 rewrite (Rplus_comm (- l)).
-apply H5.
-apply Rle_ge; apply Rplus_le_reg_l with l.
-rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0);
- [ idtac | ring ]; apply Rle_trans with l1.
-left; apply r.
-apply H6.
-unfold l1 in |- *; apply Rge_le;
- apply (growing_prop (fun k:nat => sum_f_R0 An k)).
-apply H1.
-unfold ge, N0 in |- *; apply le_max_r.
-unfold ge, N0 in |- *; apply le_max_l.
-apply Rplus_lt_reg_r with l; rewrite Rplus_0_r;
- replace (l + (l1 - l)) with l1; [ apply r | ring ].
-unfold Un_growing in |- *; intro; simpl in |- *;
- pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_le_compat_l; apply H0.
+  forall (An:nat -> R) (N:nat) (l:R),
+    Un_cv (fun n:nat => sum_f_R0 An n) l ->
+    (forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l.
+Proof.
+  intros; case (total_order_T (sum_f_R0 An N) l); intro.
+  elim s; intro.
+  left; apply a.
+  right; apply b.
+  cut (Un_growing (fun n:nat => sum_f_R0 An n)).
+  intro; set (l1 := sum_f_R0 An N) in r.
+  unfold Un_cv in H; cut (0 < l1 - l).
+  intro; elim (H _ H2); intros.
+  set (N0 := max x N); cut (N0 >= x)%nat.
+  intro; assert (H5 := H3 N0 H4).
+  cut (l1 <= sum_f_R0 An N0).
+  intro; unfold R_dist in H5; rewrite Rabs_right in H5.
+  cut (sum_f_R0 An N0 < l1).
+  intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)).
+  apply Rplus_lt_reg_r with (- l).
+  do 2 rewrite (Rplus_comm (- l)).
+  apply H5.
+  apply Rle_ge; apply Rplus_le_reg_l with l.
+  rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0);
+    [ idtac | ring ]; apply Rle_trans with l1.
+  left; apply r.
+  apply H6.
+  unfold l1 in |- *; apply Rge_le;
+    apply (growing_prop (fun k:nat => sum_f_R0 An k)).
+  apply H1.
+  unfold ge, N0 in |- *; apply le_max_r.
+  unfold ge, N0 in |- *; apply le_max_l.
+  apply Rplus_lt_reg_r with l; rewrite Rplus_0_r;
+    replace (l + (l1 - l)) with l1; [ apply r | ring ].
+  unfold Un_growing in |- *; intro; simpl in |- *;
+    pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+      apply Rplus_le_compat_l; apply H0.
 Qed.
 
 (**********)
 Lemma sum_cv_maj :
- forall (An:nat -> R) (fn:nat -> R -> R) (x l1 l2:R),
-   Un_cv (fun n:nat => SP fn n x) l1 ->
-   Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
-   (forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2.
-intros; case (total_order_T (Rabs l1) l2); intro.
-elim s; intro.
-left; apply a.
-right; apply b.
-cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0).
-intro; cut (0 < (Rabs l1 - l2) / 2).
-intro; unfold Un_cv in H, H0.
-elim (H _ H3); intros Na H4.
-elim (H0 _ H3); intros Nb H5.
-set (N := max Na Nb).
-unfold R_dist in H4, H5.
-cut (Rabs (sum_f_R0 An N - l2) < (Rabs l1 - l2) / 2).
-intro; cut (Rabs (Rabs l1 - Rabs (SP fn N x)) < (Rabs l1 - l2) / 2).
-intro; cut (sum_f_R0 An N < (Rabs l1 + l2) / 2).
-intro; cut ((Rabs l1 + l2) / 2 < Rabs (SP fn N x)).
-intro; cut (sum_f_R0 An N < Rabs (SP fn N x)).
-intro; assert (H11 := H2 N).
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)).
-apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption.
-case (Rcase_abs (Rabs l1 - Rabs (SP fn N x))); intro.
-apply Rlt_trans with (Rabs l1).
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply r.
-discrR.
-apply (Rminus_lt _ _ r0).
-rewrite (Rabs_right _ r0) in H7.
-apply Rplus_lt_reg_r with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
-replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
- (Rabs l1 - Rabs (SP fn N x)).
-unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
- rewrite Rplus_0_r; apply H7.
-unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
- rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
- repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1 in |- *;
- rewrite double_var; unfold Rdiv in |- *; ring.
-case (Rcase_abs (sum_f_R0 An N - l2)); intro.
-apply Rlt_trans with l2.
-apply (Rminus_lt _ _ r0).
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-rewrite (double l2); unfold Rdiv in |- *; rewrite (Rmult_comm 2);
- rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
- apply r.
-discrR.
-rewrite (Rabs_right _ r0) in H6; apply Rplus_lt_reg_r with (- l2).
-replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
-rewrite Rplus_comm; apply H6.
-unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
- rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r;
- pattern l2 at 2 in |- *; rewrite double_var;
- repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr;
- unfold Rdiv in |- *; ring.
-apply Rle_lt_trans with (Rabs (SP fn N x - l1)).
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply Rabs_triang_inv2.
-apply H4; unfold ge, N in |- *; apply le_max_l.
-apply H5; unfold ge, N in |- *; apply le_max_r.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply Rplus_lt_reg_r with l2.
-rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
- [ apply r | ring ].
-apply Rinv_0_lt_compat; prove_sup0.
-intros; induction  n0 as [| n0 Hrecn0].
-unfold SP in |- *; simpl in |- *; apply H1.
-unfold SP in |- *; simpl in |- *.
-apply Rle_trans with
- (Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)).
-apply Rabs_triang.
-apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)).
-do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))).
-apply Rplus_le_compat_l; apply Hrecn0.
-apply Rplus_le_compat_l; apply H1.
+  forall (An:nat -> R) (fn:nat -> R -> R) (x l1 l2:R),
+    Un_cv (fun n:nat => SP fn n x) l1 ->
+    Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
+    (forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2.
+Proof.
+  intros; case (total_order_T (Rabs l1) l2); intro.
+  elim s; intro.
+  left; apply a.
+  right; apply b.
+  cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0).
+  intro; cut (0 < (Rabs l1 - l2) / 2).
+  intro; unfold Un_cv in H, H0.
+  elim (H _ H3); intros Na H4.
+  elim (H0 _ H3); intros Nb H5.
+  set (N := max Na Nb).
+  unfold R_dist in H4, H5.
+  cut (Rabs (sum_f_R0 An N - l2) < (Rabs l1 - l2) / 2).
+  intro; cut (Rabs (Rabs l1 - Rabs (SP fn N x)) < (Rabs l1 - l2) / 2).
+  intro; cut (sum_f_R0 An N < (Rabs l1 + l2) / 2).
+  intro; cut ((Rabs l1 + l2) / 2 < Rabs (SP fn N x)).
+  intro; cut (sum_f_R0 An N < Rabs (SP fn N x)).
+  intro; assert (H11 := H2 N).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)).
+  apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption.
+  case (Rcase_abs (Rabs l1 - Rabs (SP fn N x))); intro.
+  apply Rlt_trans with (Rabs l1).
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply r.
+  discrR.
+  apply (Rminus_lt _ _ r0).
+  rewrite (Rabs_right _ r0) in H7.
+  apply Rplus_lt_reg_r with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
+  replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
+  (Rabs l1 - Rabs (SP fn N x)).
+  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+    rewrite Rplus_0_r; apply H7.
+  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+    rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
+      repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1 in |- *;
+        rewrite double_var; unfold Rdiv in |- *; ring.
+  case (Rcase_abs (sum_f_R0 An N - l2)); intro.
+  apply Rlt_trans with l2.
+  apply (Rminus_lt _ _ r0).
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  rewrite (double l2); unfold Rdiv in |- *; rewrite (Rmult_comm 2);
+    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
+    apply r.
+  discrR.
+  rewrite (Rabs_right _ r0) in H6; apply Rplus_lt_reg_r with (- l2).
+  replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
+  rewrite Rplus_comm; apply H6.
+  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+    rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r;
+      pattern l2 at 2 in |- *; rewrite double_var;
+        repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr;
+          unfold Rdiv in |- *; ring.
+  apply Rle_lt_trans with (Rabs (SP fn N x - l1)).
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply Rabs_triang_inv2.
+  apply H4; unfold ge, N in |- *; apply le_max_l.
+  apply H5; unfold ge, N in |- *; apply le_max_r.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply Rplus_lt_reg_r with l2.
+  rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
+    [ apply r | ring ].
+  apply Rinv_0_lt_compat; prove_sup0.
+  intros; induction  n0 as [| n0 Hrecn0].
+  unfold SP in |- *; simpl in |- *; apply H1.
+  unfold SP in |- *; simpl in |- *.
+  apply Rle_trans with
+    (Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)).
+  apply Rabs_triang.
+  apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)).
+  do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))).
+  apply Rplus_le_compat_l; apply Hrecn0.
+  apply Rplus_le_compat_l; apply H1.
 Qed.
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
index 5da14193..7d98a844 100644
--- a/theories/Reals/RIneq.v
+++ b/theories/Reals/RIneq.v
@@ -6,72 +6,55 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: RIneq.v,v 1.23.2.2 2005/03/29 15:35:13 herbelin Exp $ i*)
+(*i $Id: RIneq.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 (***************************************************************************)
 (**              Basic lemmas for the classical reals numbers              *)
 (***************************************************************************)
 
 Require Export Raxioms.
+Require Import Rpow_def.
+Require Import Zpower.
 Require Export ZArithRing.
 Require Import Omega.
-Require Export Field.
+Require Export RealField.
 
 Open Local Scope Z_scope.
 Open Local Scope R_scope.
 
 Implicit Type r : R.
 
-(***************************************************************************)
-(**       Instantiating Ring tactic on reals                               *)
-(***************************************************************************)
-
-Lemma RTheory : Ring_Theory Rplus Rmult 1 0 Ropp (fun x y:R => false).
-  split.
-  exact Rplus_comm.
-  symmetry  in |- *; apply Rplus_assoc.
-  exact Rmult_comm.
-  symmetry  in |- *; apply Rmult_assoc.
-  intro; apply Rplus_0_l.
-  intro; apply Rmult_1_l.
-  exact Rplus_opp_r.
-  intros.
-  rewrite Rmult_comm.
-  rewrite (Rmult_comm n p).
-  rewrite (Rmult_comm m p).
-  apply Rmult_plus_distr_l.
-  intros; contradiction.
-Defined.
-
-Add Field R Rplus Rmult 1 0 Ropp (fun x y:R => false) Rinv RTheory Rinv_l
- with minus := Rminus div := Rdiv.
-
 (**************************************************************************)
-(**  Relation between orders and equality                                 *)
+(** * Relation between orders and equality                                *)
 (**************************************************************************)
 
 (**********)
 Lemma Rlt_irrefl : forall r, ~ r < r.
+Proof.
   generalize Rlt_asym. intuition eauto.
 Qed.
 Hint Resolve Rlt_irrefl: real.
 
 Lemma Rle_refl : forall r, r <= r.
-intro; right; reflexivity.
+Proof.
+  intro; right; reflexivity.
 Qed.
 
 Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2.
+Proof.
   red in |- *; intros r1 r2 H H0; apply (Rlt_irrefl r1).
   pattern r1 at 2 in |- *; rewrite H0; trivial.
 Qed.
 
 Lemma Rgt_not_eq : forall r1 r2, r1 > r2 -> r1 <> r2.
-intros; apply sym_not_eq; apply Rlt_not_eq; auto with real.
+Proof.
+  intros; apply sym_not_eq; apply Rlt_not_eq; auto with real.
 Qed.
 
 (**********)
 Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r1 > r2 -> r1 <> r2.
-generalize Rlt_not_eq Rgt_not_eq. intuition eauto.
+Proof.
+  generalize Rlt_not_eq Rgt_not_eq. intuition eauto.
 Qed.
 Hint Resolve Rlt_dichotomy_converse: real.
 
@@ -79,61 +62,70 @@ Hint Resolve Rlt_dichotomy_converse: real.
 
 (**********)
 Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2.
-intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
- intuition eauto 3. 
+Proof.
+  intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
+    intuition eauto 3. 
 Qed.
 Hint Resolve Req_dec: real.
 
 (**********)
 Lemma Rtotal_order : forall r1 r2, r1 < r2 \/ r1 = r2 \/ r1 > r2.
-intros; generalize (total_order_T r1 r2); tauto.
+Proof.
+  intros; generalize (total_order_T r1 r2); tauto.
 Qed.
 
 (**********)
 Lemma Rdichotomy : forall r1 r2, r1 <> r2 -> r1 < r2 \/ r1 > r2.
-intros; generalize (total_order_T r1 r2); tauto.
+Proof.
+  intros; generalize (total_order_T r1 r2); tauto.
 Qed.
 
 
 (*********************************************************************************)
-(**       Order Lemma  : relating [<], [>], [<=] and [>=]  	                 *)
+(** *     Order Lemma  : relating [<], [>], [<=] and [>=]  	                 *)
 (*********************************************************************************)
 
 (**********)
 Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2.
-intros; red in |- *; tauto.
+Proof.
+  intros; red in |- *; tauto.
 Qed.
 Hint Resolve Rlt_le: real.
 
 (**********)
 Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1.
-destruct 1; red in |- *; auto with real.
+Proof.
+  destruct 1; red in |- *; auto with real.
 Qed.
 
 Hint Immediate Rle_ge: real.
 
 (**********)
 Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1.
-destruct 1; red in |- *; auto with real.
+Proof.
+  destruct 1; red in |- *; auto with real.
 Qed.
 
 Hint Resolve Rge_le: real.
 
 (**********)
 Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1.
-intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle in |- *; tauto.
+Proof.
+  intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle in |- *; tauto.
 Qed.
 
 Hint Immediate Rnot_le_lt: real.
 
 Lemma Rnot_ge_lt : forall r1 r2, ~ r1 >= r2 -> r1 < r2.
-intros; apply Rnot_le_lt; auto with real.
+Proof.
+  intros; apply Rnot_le_lt; auto with real.
 Qed.
 
 (**********)
 Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2.
-generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle in |- *.
-intuition eauto 3.
+Proof.
+  generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle in |- *.
+  intuition eauto 3.
 Qed.
 
 Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2.
@@ -142,134 +134,157 @@ Proof Rlt_not_le.
 Hint Immediate Rlt_not_le: real.
 
 Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> ~ r1 < r2.
-intros r1 r2. generalize (Rlt_asym r1 r2) (Rlt_dichotomy_converse r1 r2).
-unfold Rle in |- *; intuition.
+Proof.
+  intros r1 r2. generalize (Rlt_asym r1 r2) (Rlt_dichotomy_converse r1 r2).
+  unfold Rle in |- *; intuition.
 Qed.
 
 (**********)
 Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2.
-generalize Rlt_not_le. unfold Rle, Rge in |- *. intuition eauto 3.
+Proof.
+  generalize Rlt_not_le. unfold Rle, Rge in |- *. intuition eauto 3.
 Qed.
 
 Hint Immediate Rlt_not_ge: real.
 
 (**********)
 Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2.
-unfold Rle in |- *; tauto.
+Proof.
+  unfold Rle in |- *; tauto.
 Qed.
 Hint Immediate Req_le: real.
 
 Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2.
-unfold Rge in |- *; tauto.
+Proof.
+  unfold Rge in |- *; tauto.
 Qed.
 Hint Immediate Req_ge: real.
 
 Lemma Req_le_sym : forall r1 r2, r2 = r1 -> r1 <= r2.
-unfold Rle in |- *; auto.
+Proof.
+  unfold Rle in |- *; auto.
 Qed.
 Hint Immediate Req_le_sym: real.
 
 Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2.
-unfold Rge in |- *; auto.
+Proof.
+  unfold Rge in |- *; auto.
 Qed.
 Hint Immediate Req_ge_sym: real.
 
 Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2.
-intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle in |- *; intuition.
+Proof.
+  intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle in |- *; intuition.
 Qed.
 Hint Resolve Rle_antisym: real.
 
 (**********)
 Lemma Rle_le_eq : forall r1 r2, r1 <= r2 /\ r2 <= r1 <-> r1 = r2.
-intuition.
+Proof.
+  intuition.
 Qed.
 
 Lemma Rlt_eq_compat :
- forall r1 r2 r3 r4, r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3.
-intros x x' y y'; intros; replace x with x'; replace y with y'; assumption.
+  forall r1 r2 r3 r4, r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3.
+Proof.
+  intros x x' y y'; intros; replace x with x'; replace y with y'; assumption.
 Qed.
 
 (**********)
 Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3.
-generalize trans_eq Rlt_trans Rlt_eq_compat.
-unfold Rle in |- *.
-intuition eauto 2.
+Proof.
+  generalize trans_eq Rlt_trans Rlt_eq_compat.
+  unfold Rle in |- *.
+  intuition eauto 2.
 Qed.
 
 (**********)
 Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3.
-generalize Rlt_trans Rlt_eq_compat. 
-unfold Rle in |- *.
-intuition eauto 2.
+Proof.
+  generalize Rlt_trans Rlt_eq_compat. 
+  unfold Rle in |- *.
+  intuition eauto 2.
 Qed.
 
 (**********)
 Lemma Rlt_le_trans : forall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3.
-generalize Rlt_trans Rlt_eq_compat; unfold Rle in |- *; intuition eauto 2.
+Proof.
+  generalize Rlt_trans Rlt_eq_compat; unfold Rle in |- *; intuition eauto 2.
 Qed.
 
 
 (** Decidability of the order *)
 Lemma Rlt_dec : forall r1 r2, {r1 < r2} + {~ r1 < r2}.
-intros; generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2);
- intuition.
+Proof.
+  intros; generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2);
+    intuition.
 Qed.
 
 (**********)
 Lemma Rle_dec : forall r1 r2, {r1 <= r2} + {~ r1 <= r2}.
-intros r1 r2.
-generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2).
-intuition eauto 4 with real.
+Proof.
+  intros r1 r2.
+  generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2).
+  intuition eauto 4 with real.
 Qed.
 
 (**********)
 Lemma Rgt_dec : forall r1 r2, {r1 > r2} + {~ r1 > r2}.
-intros; unfold Rgt in |- *; intros; apply Rlt_dec.
+Proof.
+  intros; unfold Rgt in |- *; intros; apply Rlt_dec.
 Qed.
 
 (**********)
 Lemma Rge_dec : forall r1 r2, {r1 >= r2} + {~ r1 >= r2}.
-intros; generalize (Rle_dec r2 r1); intuition.
+Proof.
+  intros; generalize (Rle_dec r2 r1); intuition.
 Qed.
 
 Lemma Rlt_le_dec : forall r1 r2, {r1 < r2} + {r2 <= r1}.
-intros; generalize (total_order_T r1 r2); intuition.
+Proof.
+  intros; generalize (total_order_T r1 r2); intuition.
 Qed.
 
 Lemma Rle_or_lt : forall r1 r2, r1 <= r2 \/ r2 < r1.
-intros n m; elim (Rlt_le_dec m n); auto with real.
+Proof.
+  intros n m; elim (Rlt_le_dec m n); auto with real.
 Qed.
 
 Lemma Rle_lt_or_eq_dec : forall r1 r2, r1 <= r2 -> {r1 < r2} + {r1 = r2}.
-intros r1 r2 H; generalize (total_order_T r1 r2); intuition.
+Proof.
+  intros r1 r2 H; generalize (total_order_T r1 r2); intuition.
 Qed.
 
 (**********)
 Lemma inser_trans_R :
- forall r1 r2 r3 r4, r1 <= r2 < r3 -> {r1 <= r2 < r4} + {r4 <= r2 < r3}.
-intros n m p q; intros; generalize (Rlt_le_dec m q); intuition.
+  forall r1 r2 r3 r4, r1 <= r2 < r3 -> {r1 <= r2 < r4} + {r4 <= r2 < r3}.
+Proof.
+  intros n m p q; intros; generalize (Rlt_le_dec m q); intuition.
 Qed.
 
 (****************************************************************)
-(**        Field Lemmas                                         *)
+(** *      Field Lemmas                                         *)
 (* This part contains lemma involving the Fields operations     *)
 (****************************************************************)
 (*********************************************************)
-(**      Addition                                        *)
+(** **   Addition                                        *)
 (*********************************************************)
 
 Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r.
-intro; split; ring.
+Proof.
+  split; ring.
 Qed.
 Hint Resolve Rplus_ne: real v62.
 
 Lemma Rplus_0_r : forall r, r + 0 = r.
-intro; ring.
+Proof.
+  intro; ring.
 Qed.
 Hint Resolve Rplus_0_r: real.
 
 (**********)
 Lemma Rplus_opp_l : forall r, - r + r = 0.
+Proof.
   intro; ring.
 Qed.
 Hint Resolve Rplus_opp_l: real.
@@ -277,14 +292,17 @@ Hint Resolve Rplus_opp_l: real.
 
 (**********)
 Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 = 0 -> r2 = - r1.
-  intros x y H; replace y with (- x + x + y);
-   [ rewrite Rplus_assoc; rewrite H; ring | ring ].
+Proof.
+  intros x y H;
+    replace y with (- x + x + y) by ring.
+  rewrite Rplus_assoc; rewrite H; ring.
 Qed.
 
 (*i New i*)
 Hint Resolve (f_equal (A:=R)): real.
 
 Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2.
+Proof.
   auto with real.
 Qed.
 
@@ -292,6 +310,7 @@ Qed.
 
 (**********)
 Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 = r + r2 -> r1 = r2.
+Proof.
   intros; transitivity (- r + r + r1).
   ring.
   transitivity (- r + r + r2).
@@ -302,55 +321,64 @@ Hint Resolve Rplus_eq_reg_l: real.
 
 (**********)
 Lemma Rplus_0_r_uniq : forall r r1, r + r1 = r -> r1 = 0.
+Proof.
   intros r b; pattern r at 2 in |- *; replace r with (r + 0); eauto with real.
 Qed.
 
 (***********************************************************)       
-(**       Multiplication                                   *)
+(** **    Multiplication                                   *)
 (***********************************************************)
 
 (**********)
 Lemma Rinv_r : forall r, r <> 0 -> r * / r = 1.
-  intros; rewrite Rmult_comm; auto with real.
+Proof.
+  intros; field; trivial.
 Qed.
 Hint Resolve Rinv_r: real.
 
 Lemma Rinv_l_sym : forall r, r <> 0 -> 1 = / r * r.
-  symmetry  in |- *; auto with real.
+Proof.
+  intros; field; trivial.
 Qed.
 
 Lemma Rinv_r_sym : forall r, r <> 0 -> 1 = r * / r.
-  symmetry  in |- *; auto with real.
+Proof.
+  intros; field; trivial.
 Qed.
 Hint Resolve Rinv_l_sym Rinv_r_sym: real.
 
 
 (**********)
 Lemma Rmult_0_r : forall r, r * 0 = 0.
-intro; ring.
+Proof.
+  intro; ring.
 Qed.
 Hint Resolve Rmult_0_r: real v62.
 
 (**********)
 Lemma Rmult_0_l : forall r, 0 * r = 0.
-intro; ring.
+Proof.
+  intro; ring.
 Qed.
 Hint Resolve Rmult_0_l: real v62.
 
 (**********)
 Lemma Rmult_ne : forall r, r * 1 = r /\ 1 * r = r.
-intro; split; ring.
+Proof.
+  intro; split; ring.
 Qed.
 Hint Resolve Rmult_ne: real v62.
 
 (**********)
 Lemma Rmult_1_r : forall r, r * 1 = r.
-intro; ring.
+Proof.
+  intro; ring.
 Qed.
 Hint Resolve Rmult_1_r: real.
 
 (**********)
 Lemma Rmult_eq_compat_l : forall r r1 r2, r1 = r2 -> r * r1 = r * r2.
+Proof.
   auto with real.
 Qed.
 
@@ -358,15 +386,17 @@ Qed.
 
 (**********)
 Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2.
+Proof.
   intros; transitivity (/ r * r * r1).
-  rewrite Rinv_l; auto with real.
+  field; trivial.
   transitivity (/ r * r * r2).
   repeat rewrite Rmult_assoc; rewrite H; trivial.
-  rewrite Rinv_l; auto with real.
+  field; trivial.
 Qed.
 
 (**********)
 Lemma Rmult_integral : forall r1 r2, r1 * r2 = 0 -> r1 = 0 \/ r2 = 0.
+Proof.
   intros; case (Req_dec r1 0); [ intro Hz | intro Hnotz ].
   auto.
   right; apply Rmult_eq_reg_l with r1; trivial.
@@ -375,6 +405,7 @@ Qed.
 
 (**********)
 Lemma Rmult_eq_0_compat : forall r1 r2, r1 = 0 \/ r2 = 0 -> r1 * r2 = 0.
+Proof.
   intros r1 r2 [H| H]; rewrite H; auto with real.
 Qed.
 
@@ -382,35 +413,40 @@ Hint Resolve Rmult_eq_0_compat: real.
 
 (**********)
 Lemma Rmult_eq_0_compat_r : forall r1 r2, r1 = 0 -> r1 * r2 = 0.
+Proof.
   auto with real.
 Qed.
 
 (**********)
 Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 = 0 -> r1 * r2 = 0.
+Proof.
   auto with real.
 Qed.
 
 
 (**********) 
 Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0.
-intros r1 r2 H; split; red in |- *; intro; apply H; auto with real.
+Proof.
+  intros r1 r2 H; split; red in |- *; intro; apply H; auto with real.
 Qed.
 
 (**********) 
 Lemma Rmult_integral_contrapositive :
- forall r1 r2, r1 <> 0 /\ r2 <> 0 -> r1 * r2 <> 0.
-red in |- *; intros r1 r2 [H1 H2] H.
-case (Rmult_integral r1 r2); auto with real.
+  forall r1 r2, r1 <> 0 /\ r2 <> 0 -> r1 * r2 <> 0.
+Proof.
+  red in |- *; intros r1 r2 [H1 H2] H.
+  case (Rmult_integral r1 r2); auto with real.
 Qed.
 Hint Resolve Rmult_integral_contrapositive: real.
 
 (**********) 
 Lemma Rmult_plus_distr_r :
- forall r1 r2 r3, (r1 + r2) * r3 = r1 * r3 + r2 * r3.
-intros; ring.
+  forall r1 r2 r3, (r1 + r2) * r3 = r1 * r3 + r2 * r3.
+Proof.
+  intros; ring.
 Qed.
 
-(** Square function *)
+(** ** Square function *)
 
 (***********)
 Definition Rsqr r : R := r * r.
@@ -422,695 +458,802 @@ Qed.
 
 (***********)
 Lemma Rsqr_0_uniq : forall r, Rsqr r = 0 -> r = 0.
-unfold Rsqr in |- *; intros; elim (Rmult_integral r r H); trivial.
+  unfold Rsqr in |- *; intros; elim (Rmult_integral r r H); trivial.
 Qed.
 
 (*********************************************************)
-(**      Opposite                                        *)
+(** **   Opposite                                        *)
 (*********************************************************)
 
 (**********)
 Lemma Ropp_eq_compat : forall r1 r2, r1 = r2 -> - r1 = - r2.
+Proof.
   auto with real.
 Qed.
 Hint Resolve Ropp_eq_compat: real.
 
 (**********)
 Lemma Ropp_0 : -0 = 0.
+Proof.
   ring.
 Qed.
 Hint Resolve Ropp_0: real v62.
 
 (**********)
 Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0.
+Proof.
   intros; rewrite H; auto with real.
 Qed.
 Hint Resolve Ropp_eq_0_compat: real.
 
 (**********)
 Lemma Ropp_involutive : forall r, - - r = r.
+Proof.
   intro; ring.
 Qed.
 Hint Resolve Ropp_involutive: real.
 
 (*********)
 Lemma Ropp_neq_0_compat : forall r, r <> 0 -> - r <> 0.
-red in |- *; intros r H H0.
-apply H.
-transitivity (- - r); auto with real.
+Proof.
+  red in |- *; intros r H H0.
+  apply H.
+  transitivity (- - r); auto with real.
 Qed.
 Hint Resolve Ropp_neq_0_compat: real.
 
 (**********)
 Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) = - r1 + - r2.
+Proof.
   intros; ring.
 Qed.
 Hint Resolve Ropp_plus_distr: real.
 
-(** Opposite and multiplication *)
+
+(** ** Opposite and multiplication *)
 
 Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2).
+Proof.
   intros; ring.
 Qed.
 Hint Resolve Ropp_mult_distr_l_reverse: real.
 
 (**********)
 Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 = r1 * r2.
+Proof.
   intros; ring.
 Qed.
 Hint Resolve Rmult_opp_opp: real.
 
 Lemma Ropp_mult_distr_r_reverse : forall r1 r2, r1 * - r2 = - (r1 * r2).
-intros; rewrite <- Ropp_mult_distr_l_reverse; ring.
+Proof.
+  intros; ring.
 Qed.
 
-(** Substraction *)
+(** ** Substraction *)
 
 Lemma Rminus_0_r : forall r, r - 0 = r.
-intro; ring.
+Proof.
+  intro; ring.
 Qed.
 Hint Resolve Rminus_0_r: real.
 
 Lemma Rminus_0_l : forall r, 0 - r = - r.
-intro; ring.
+Proof.
+  intro; ring.
 Qed.
 Hint Resolve Rminus_0_l: real.
 
 (**********)
 Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) = r2 - r1.
+Proof.
   intros; ring.
 Qed.
 Hint Resolve Ropp_minus_distr: real.
 
 Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) = r1 - r2.
-intros; ring.
+Proof.
+  intros; ring.
 Qed.
 Hint Resolve Ropp_minus_distr': real. 
 
 (**********)
 Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = 0.
+Proof.
   intros; rewrite H; ring.
 Qed.
 Hint Resolve Rminus_diag_eq: real.
 
 (**********)
 Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 = 0 -> r1 = r2.
+Proof.
   intros r1 r2; unfold Rminus in |- *; rewrite Rplus_comm; intro.
   rewrite <- (Ropp_involutive r2); apply (Rplus_opp_r_uniq (- r2) r1 H).
 Qed.
 Hint Immediate Rminus_diag_uniq: real.
 
 Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 = 0 -> r1 = r2.
-intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; intro H; rewrite H;
- ring.
+Proof.
+  intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; intro H; rewrite H;
+    ring.
 Qed.
 Hint Immediate Rminus_diag_uniq_sym: real.
 
 Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) = r2.
-intros; ring.
+Proof.
+  intros; ring.
 Qed.
 Hint Resolve Rplus_minus: real.
 
 (**********)
 Lemma Rminus_eq_contra : forall r1 r2, r1 <> r2 -> r1 - r2 <> 0.
-red in |- *; intros r1 r2 H H0.
-apply H; auto with real.
+Proof.
+  red in |- *; intros r1 r2 H H0.
+  apply H; auto with real.
 Qed.
 Hint Resolve Rminus_eq_contra: real.
 
 Lemma Rminus_not_eq : forall r1 r2, r1 - r2 <> 0 -> r1 <> r2.
-red in |- *; intros; elim H; apply Rminus_diag_eq; auto.
+Proof.
+  red in |- *; intros; elim H; apply Rminus_diag_eq; auto.
 Qed.
 Hint Resolve Rminus_not_eq: real.
 
 Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2.
-red in |- *; intros; elim H; rewrite H0; ring.
+Proof.
+  red in |- *; intros; elim H; rewrite H0; ring.
 Qed.
 Hint Resolve Rminus_not_eq_right: real. 
 
 
 (**********)
 Lemma Rmult_minus_distr_l :
- forall r1 r2 r3, r1 * (r2 - r3) = r1 * r2 - r1 * r3.
-intros; ring.
+  forall r1 r2 r3, r1 * (r2 - r3) = r1 * r2 - r1 * r3.
+Proof.
+  intros; ring.
 Qed.
 
-(** Inverse *)
+(** ** Inverse *)
 Lemma Rinv_1 : / 1 = 1.
-field; auto with real.
+Proof.
+  field.
 Qed.
 Hint Resolve Rinv_1: real.
 
 (*********)
 Lemma Rinv_neq_0_compat : forall r, r <> 0 -> / r <> 0.
-red in |- *; intros; apply R1_neq_R0.
-replace 1 with (/ r * r); auto with real.
+Proof.
+  red in |- *; intros; apply R1_neq_R0.
+  replace 1 with (/ r * r); auto with real.
 Qed.
 Hint Resolve Rinv_neq_0_compat: real.
 
 (*********)
 Lemma Rinv_involutive : forall r, r <> 0 -> / / r = r.
-intros; field; auto with real.
+Proof.
+  intros; field; trivial.
 Qed.
 Hint Resolve Rinv_involutive: real.
 
 (*********)
 Lemma Rinv_mult_distr :
- forall r1 r2, r1 <> 0 -> r2 <> 0 -> / (r1 * r2) = / r1 * / r2.
-intros; field; auto with real.
+  forall r1 r2, r1 <> 0 -> r2 <> 0 -> / (r1 * r2) = / r1 * / r2.
+Proof.
+  intros; field; auto.
 Qed.
 
 (*********)
 Lemma Ropp_inv_permute : forall r, r <> 0 -> - / r = / - r.
-intros; field; auto with real.
+Proof.
+  intros; field; trivial.
 Qed.
 
 Lemma Rinv_r_simpl_r : forall r1 r2, r1 <> 0 -> r1 * / r1 * r2 = r2.
-intros; transitivity (1 * r2); auto with real.
-rewrite Rinv_r; auto with real.
+Proof.
+  intros; transitivity (1 * r2); auto with real.
+  rewrite Rinv_r; auto with real.
 Qed.
 
 Lemma Rinv_r_simpl_l : forall r1 r2, r1 <> 0 -> r2 * r1 * / r1 = r2.
-intros; transitivity (r2 * 1); auto with real.
-transitivity (r2 * (r1 * / r1)); auto with real.
+Proof.
+  intros; transitivity (r2 * 1); auto with real.
+  transitivity (r2 * (r1 * / r1)); auto with real.
 Qed.
 
 Lemma Rinv_r_simpl_m : forall r1 r2, r1 <> 0 -> r1 * r2 * / r1 = r2.
-intros; transitivity (r2 * 1); auto with real.
-transitivity (r2 * (r1 * / r1)); auto with real.
-ring.
+Proof.
+  intros; transitivity (r2 * 1); auto with real.
+  transitivity (r2 * (r1 * / r1)); auto with real.
+  ring.
 Qed.
 Hint Resolve Rinv_r_simpl_l Rinv_r_simpl_r Rinv_r_simpl_m: real.
 
 (*********)
 Lemma Rinv_mult_simpl :
- forall r1 r2 r3, r1 <> 0 -> r1 * / r2 * (r3 * / r1) = r3 * / r2.
-intros a b c; intros.
-transitivity (a * / a * (c * / b)); auto with real.
-ring.
+  forall r1 r2 r3, r1 <> 0 -> r1 * / r2 * (r3 * / r1) = r3 * / r2.
+Proof.
+  intros a b c; intros.
+  transitivity (a * / a * (c * / b)); auto with real.
+  ring.
 Qed.
 
-(** Order and addition *)
+(** * Field operations and order *)
+
+(** ** Order and addition *)
 
 Lemma Rplus_lt_compat_r : forall r r1 r2, r1 < r2 -> r1 + r < r2 + r.
-intros.
-rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r); auto with real.
+Proof.
+  intros.
+  rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r); auto with real.
 Qed.
 
 Hint Resolve Rplus_lt_compat_r: real.
 
 (**********)
 Lemma Rplus_lt_reg_r : forall r r1 r2, r + r1 < r + r2 -> r1 < r2.
-intros; cut (- r + r + r1 < - r + r + r2).
-rewrite Rplus_opp_l.
-elim (Rplus_ne r1); elim (Rplus_ne r2); intros; rewrite <- H3; rewrite <- H1;
- auto with zarith real.
-rewrite Rplus_assoc; rewrite Rplus_assoc;
- apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H).
+Proof.
+  intros; cut (- r + r + r1 < - r + r + r2).
+  rewrite Rplus_opp_l.
+  elim (Rplus_ne r1); elim (Rplus_ne r2); intros; rewrite <- H3; rewrite <- H1;
+    auto with zarith real.
+  rewrite Rplus_assoc; rewrite Rplus_assoc;
+    apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H).
 Qed.
 
 (**********)
 Lemma Rplus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2.
-unfold Rle in |- *; intros; elim H; intro.
-left; apply (Rplus_lt_compat_l r r1 r2 H0).
-right; rewrite <- H0; auto with zarith real.
+Proof.
+  unfold Rle in |- *; intros; elim H; intro.
+  left; apply (Rplus_lt_compat_l r r1 r2 H0).
+  right; rewrite <- H0; auto with zarith real.
 Qed.
 
 (**********)
 Lemma Rplus_le_compat_r : forall r r1 r2, r1 <= r2 -> r1 + r <= r2 + r.
-unfold Rle in |- *; intros; elim H; intro.
-left; apply (Rplus_lt_compat_r r r1 r2 H0).
-right; rewrite <- H0; auto with real.
+Proof.
+  unfold Rle in |- *; intros; elim H; intro.
+  left; apply (Rplus_lt_compat_r r r1 r2 H0).
+  right; rewrite <- H0; auto with real.
 Qed.
 
 Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: real.
 
 (**********)
 Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2.
-unfold Rle in |- *; intros; elim H; intro.
-left; apply (Rplus_lt_reg_r r r1 r2 H0).
-right; apply (Rplus_eq_reg_l r r1 r2 H0).
+Proof.
+  unfold Rle in |- *; intros; elim H; intro.
+  left; apply (Rplus_lt_reg_r r r1 r2 H0).
+  right; apply (Rplus_eq_reg_l r r1 r2 H0).
 Qed.
 
 (**********)
 Lemma sum_inequa_Rle_lt :
- forall a x b c y d:R,
-   a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d.
-intros; split.
-apply Rlt_le_trans with (a + y); auto with real.
-apply Rlt_le_trans with (b + y); auto with real.
+  forall a x b c y d:R,
+    a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d.
+Proof.
+  intros; split.
+  apply Rlt_le_trans with (a + y); auto with real.
+  apply Rlt_le_trans with (b + y); auto with real.
 Qed.
 
 (*********)
 Lemma Rplus_lt_compat :
- forall r1 r2 r3 r4, r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
-intros; apply Rlt_trans with (r2 + r3); auto with real.
+  forall r1 r2 r3 r4, r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
+Proof.
+  intros; apply Rlt_trans with (r2 + r3); auto with real.
 Qed.
 
 Lemma Rplus_le_compat :
- forall r1 r2 r3 r4, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4.
-intros; apply Rle_trans with (r2 + r3); auto with real.
+  forall r1 r2 r3 r4, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4.
+Proof.
+  intros; apply Rle_trans with (r2 + r3); auto with real.
 Qed.
 
 (*********)
 Lemma Rplus_lt_le_compat :
- forall r1 r2 r3 r4, r1 < r2 -> r3 <= r4 -> r1 + r3 < r2 + r4.
-intros; apply Rlt_le_trans with (r2 + r3); auto with real.
+  forall r1 r2 r3 r4, r1 < r2 -> r3 <= r4 -> r1 + r3 < r2 + r4.
+Proof.
+  intros; apply Rlt_le_trans with (r2 + r3); auto with real.
 Qed.
 
 (*********)
 Lemma Rplus_le_lt_compat :
- forall r1 r2 r3 r4, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
-intros; apply Rle_lt_trans with (r2 + r3); auto with real.
+  forall r1 r2 r3 r4, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
+Proof.
+  intros; apply Rle_lt_trans with (r2 + r3); auto with real.
 Qed.
 
 Hint Immediate Rplus_lt_compat Rplus_le_compat Rplus_lt_le_compat
   Rplus_le_lt_compat: real.
 
-(** Order and Opposite *)
+(** ** Order and Opposite *)
 
 (**********)
 Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2.
-unfold Rgt in |- *; intros.
-apply (Rplus_lt_reg_r (r2 + r1)).
-replace (r2 + r1 + - r1) with r2.
-replace (r2 + r1 + - r2) with r1.
-trivial.
-ring.
-ring.
+Proof.
+  unfold Rgt in |- *; intros.
+  apply (Rplus_lt_reg_r (r2 + r1)).
+  replace (r2 + r1 + - r1) with r2.
+  replace (r2 + r1 + - r2) with r1.
+  trivial.
+  ring.
+  ring.
 Qed.
 Hint Resolve Ropp_gt_lt_contravar.
 
 (**********)
 Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2.
-unfold Rgt in |- *; auto with real.
+Proof.
+  unfold Rgt in |- *; auto with real.
 Qed.
 Hint Resolve Ropp_lt_gt_contravar: real.
 
 Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2.
-intros x y H'.
-rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y);
- auto with real.
+Proof.
+  intros x y H'.
+  rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y);
+    auto with real.
 Qed.
 Hint Immediate Ropp_lt_cancel: real.
 
 Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2.
-auto with real.
+Proof.
+  auto with real.
 Qed.
 Hint Resolve Ropp_lt_contravar: real.
 
 (**********)
 Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2.
-unfold Rge in |- *; intros r1 r2 [H| H]; auto with real.
+Proof.
+  unfold Rge in |- *; intros r1 r2 [H| H]; auto with real.
 Qed.
 Hint Resolve Ropp_le_ge_contravar: real.
 
 Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2.
-intros x y H.
-elim H; auto with real.
-intro H1; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y);
- rewrite H1; auto with real.
+Proof.
+  intros x y H.
+  elim H; auto with real.
+  intro H1; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y);
+    rewrite H1; auto with real.
 Qed.
 Hint Immediate Ropp_le_cancel: real.
 
 Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2.
-intros r1 r2 H; elim H; auto with real.
+Proof.
+  intros r1 r2 H; elim H; auto with real.
 Qed.
 Hint Resolve Ropp_le_contravar: real.
 
 (**********)
 Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2.
-unfold Rge in |- *; intros r1 r2 [H| H]; auto with real.
+Proof.
+  unfold Rge in |- *; intros r1 r2 [H| H]; auto with real.
 Qed.
 Hint Resolve Ropp_ge_le_contravar: real.
 
 (**********)
 Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r.
-intros; replace 0 with (-0); auto with real.
+Proof.
+  intros; replace 0 with (-0); auto with real.
 Qed.
 Hint Resolve Ropp_0_lt_gt_contravar: real.
 
 (**********)
 Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r.
-intros; replace 0 with (-0); auto with real.
+Proof.
+  intros; replace 0 with (-0); auto with real.
 Qed.
 Hint Resolve Ropp_0_gt_lt_contravar: real.
 
 (**********)
 Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0.
-intros; rewrite <- Ropp_0; auto with real.
+Proof.
+  intros; rewrite <- Ropp_0; auto with real.
 Qed.
 
 (**********)
 Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0.
-intros; rewrite <- Ropp_0; auto with real.
+Proof.
+  intros; rewrite <- Ropp_0; auto with real.
 Qed.
 Hint Resolve Ropp_lt_gt_0_contravar Ropp_gt_lt_0_contravar: real.
 
 (**********)
 Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r.
-intros; replace 0 with (-0); auto with real.
+Proof.
+  intros; replace 0 with (-0); auto with real.
 Qed.
 Hint Resolve Ropp_0_le_ge_contravar: real.
 
 (**********)
 Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r.
-intros; replace 0 with (-0); auto with real.
+Proof.
+  intros; replace 0 with (-0); auto with real.
 Qed.
 Hint Resolve Ropp_0_ge_le_contravar: real.
 
-(** Order and multiplication *)
+(** ** Order and multiplication *)
 
 Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r.
-intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real.
+Proof.
+  intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real.
 Qed.
 Hint Resolve Rmult_lt_compat_r.
 
 Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2.
-intros z x y H H0.
-case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0.
- rewrite Eq0 in H0; elimtype False; apply (Rlt_irrefl (z * y)); auto.
-generalize (Rmult_lt_compat_l z y x H Eq0); intro; elimtype False;
- generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); 
- intro; apply (Rlt_irrefl (z * x)); auto.
+Proof.
+  intros z x y H H0.
+  case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0.
+  rewrite Eq0 in H0; elimtype False; apply (Rlt_irrefl (z * y)); auto.
+  generalize (Rmult_lt_compat_l z y x H Eq0); intro; elimtype False;
+    generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); 
+      intro; apply (Rlt_irrefl (z * x)); auto.
 Qed.
 
 
 Lemma Rmult_lt_gt_compat_neg_l :
- forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2.
-intros; replace r with (- - r); auto with real.
-rewrite (Ropp_mult_distr_l_reverse (- r));
- rewrite (Ropp_mult_distr_l_reverse (- r)).
-apply Ropp_lt_gt_contravar; auto with real.
+  forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2.
+Proof.
+  intros; replace r with (- - r); auto with real.
+  rewrite (Ropp_mult_distr_l_reverse (- r));
+    rewrite (Ropp_mult_distr_l_reverse (- r)).
+  apply Ropp_lt_gt_contravar; auto with real.
 Qed.
 
 (**********)
 Lemma Rmult_le_compat_l :
- forall r r1 r2, 0 <= r -> r1 <= r2 -> r * r1 <= r * r2.
-intros r r1 r2 H H0; destruct H; destruct H0; unfold Rle in |- *;
- auto with real.
-right; rewrite <- H; do 2 rewrite Rmult_0_l; reflexivity.
+  forall r r1 r2, 0 <= r -> r1 <= r2 -> r * r1 <= r * r2.
+Proof.
+  intros r r1 r2 H H0; destruct H; destruct H0; unfold Rle in |- *;
+    auto with real.
+  right; rewrite <- H; do 2 rewrite Rmult_0_l; reflexivity.
 Qed.
 Hint Resolve Rmult_le_compat_l: real.
 
 Lemma Rmult_le_compat_r :
- forall r r1 r2, 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r.
-intros r r1 r2 H; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r);
- auto with real.
+  forall r r1 r2, 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r.
+Proof.
+  intros r r1 r2 H; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r);
+    auto with real.
 Qed.
 Hint Resolve Rmult_le_compat_r: real.
 
 Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2.
-intros z x y H H0; case H0; auto with real.
-intros H1; apply Rlt_le.
-apply Rmult_lt_reg_l with (r := z); auto.
-intros H1; replace x with (/ z * (z * x)); auto with real.
-replace y with (/ z * (z * y)).
- rewrite H1; auto with real.
-rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
-rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
+Proof.
+  intros z x y H H0; case H0; auto with real.
+  intros H1; apply Rlt_le.
+  apply Rmult_lt_reg_l with (r := z); auto.
+  intros H1; replace x with (/ z * (z * x)); auto with real.
+  replace y with (/ z * (z * y)).
+  rewrite H1; auto with real.
+  rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
+  rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
 Qed.
 
 Lemma Rmult_le_compat_neg_l :
- forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1.
-intros; replace r with (- - r); auto with real.
-do 2 rewrite (Ropp_mult_distr_l_reverse (- r)).
-apply Ropp_le_contravar; auto with real.
+  forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1.
+Proof.
+  intros; replace r with (- - r); auto with real.
+  do 2 rewrite (Ropp_mult_distr_l_reverse (- r)).
+  apply Ropp_le_contravar; auto with real.
 Qed.
 Hint Resolve Rmult_le_compat_neg_l: real.
 
 Lemma Rmult_le_ge_compat_neg_l :
- forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r1 >= r * r2.
-intros; apply Rle_ge; auto with real.
+  forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r1 >= r * r2.
+Proof.
+  intros; apply Rle_ge; auto with real.
 Qed.
 Hint Resolve Rmult_le_ge_compat_neg_l: real.
 
 Lemma Rmult_le_compat :
- forall r1 r2 r3 r4,
-   0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4.
-intros x y z t H' H'0 H'1 H'2.
-apply Rle_trans with (r2 := x * t); auto with real.
-repeat rewrite (fun x => Rmult_comm x t).
-apply Rmult_le_compat_l; auto.
-apply Rle_trans with z; auto.
+  forall r1 r2 r3 r4,
+    0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4.
+Proof.
+  intros x y z t H' H'0 H'1 H'2.
+  apply Rle_trans with (r2 := x * t); auto with real.
+  repeat rewrite (fun x => Rmult_comm x t).
+  apply Rmult_le_compat_l; auto.
+  apply Rle_trans with z; auto.
 Qed.
 Hint Resolve Rmult_le_compat: real.
 
 Lemma Rmult_gt_0_lt_compat :
- forall r1 r2 r3 r4,
-   r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
-intros; apply Rlt_trans with (r2 * r3); auto with real.
+  forall r1 r2 r3 r4,
+    r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
+Proof.
+  intros; apply Rlt_trans with (r2 * r3); auto with real.
 Qed.
 
 (*********)
 Lemma Rmult_ge_0_gt_0_lt_compat :
- forall r1 r2 r3 r4,
-   r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
-intros; apply Rle_lt_trans with (r2 * r3); auto with real.
+  forall r1 r2 r3 r4,
+    r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
+Proof.
+  intros; apply Rle_lt_trans with (r2 * r3); auto with real.
 Qed.
 
-(** Order and Substractions *)
+
+(** ** Order and Substractions *)
+
 Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0.
-intros; apply (Rplus_lt_reg_r r2).
-replace (r2 + (r1 - r2)) with r1.
-replace (r2 + 0) with r2; auto with real.
-ring.
+Proof.
+  intros; apply (Rplus_lt_reg_r r2).
+  replace (r2 + (r1 - r2)) with r1.
+  replace (r2 + 0) with r2; auto with real.
+  ring.
 Qed.
 Hint Resolve Rlt_minus: real.
 
 (**********)
 Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0.
-destruct 1; unfold Rle in |- *; auto with real.
+Proof.
+  destruct 1; unfold Rle in |- *; auto with real.
 Qed.
 
 (**********)
 Lemma Rminus_lt : forall r1 r2, r1 - r2 < 0 -> r1 < r2.
-intros; replace r1 with (r1 - r2 + r2).
-pattern r2 at 3 in |- *; replace r2 with (0 + r2); auto with real.
-ring.
+Proof.
+  intros; replace r1 with (r1 - r2 + r2).
+  pattern r2 at 3 in |- *; replace r2 with (0 + r2); auto with real.
+  ring.
 Qed.
 
 (**********)
 Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2.
-intros; replace r1 with (r1 - r2 + r2).
-pattern r2 at 3 in |- *; replace r2 with (0 + r2); auto with real.
-ring.
+Proof.
+  intros; replace r1 with (r1 - r2 + r2).
+  pattern r2 at 3 in |- *; replace r2 with (0 + r2); auto with real.
+  ring.
 Qed.
 
 (**********)
 Lemma tech_Rplus : forall r (s:R), 0 <= r -> 0 < s -> r + s <> 0.
-intros; apply sym_not_eq; apply Rlt_not_eq.
-rewrite Rplus_comm; replace 0 with (0 + 0); auto with real.
+Proof.
+  intros; apply sym_not_eq; apply Rlt_not_eq.
+  rewrite Rplus_comm; replace 0 with (0 + 0); auto with real.
 Qed.
 Hint Immediate tech_Rplus: real.
 
-(** Order and the square function *)
+
+(** ** Order and the square function *)
+
 Lemma Rle_0_sqr : forall r, 0 <= Rsqr r.
-intro; case (Rlt_le_dec r 0); unfold Rsqr in |- *; intro.
-replace (r * r) with (- r * - r); auto with real.
-replace 0 with (- r * 0); auto with real.
-replace 0 with (0 * r); auto with real.
+Proof.
+  intro; case (Rlt_le_dec r 0); unfold Rsqr in |- *; intro.
+  replace (r * r) with (- r * - r); auto with real.
+  replace 0 with (- r * 0); auto with real.
+  replace 0 with (0 * r); auto with real.
 Qed.
 
 (***********)
 Lemma Rlt_0_sqr : forall r, r <> 0 -> 0 < Rsqr r.
-intros; case (Rdichotomy r 0); trivial; unfold Rsqr in |- *; intro.
-replace (r * r) with (- r * - r); auto with real.
-replace 0 with (- r * 0); auto with real.
-replace 0 with (0 * r); auto with real.
+Proof.
+  intros; case (Rdichotomy r 0); trivial; unfold Rsqr in |- *; intro.
+  replace (r * r) with (- r * - r); auto with real.
+  replace 0 with (- r * 0); auto with real.
+  replace 0 with (0 * r); auto with real.
 Qed.
 Hint Resolve Rle_0_sqr Rlt_0_sqr: real.
 
-(** Zero is less than one *)
+(** ** Zero is less than one *)
 Lemma Rlt_0_1 : 0 < 1.
-replace 1 with (Rsqr 1); auto with real.
-unfold Rsqr in |- *; auto with real.
+Proof.
+  replace 1 with (Rsqr 1); auto with real.
+  unfold Rsqr in |- *; auto with real.
 Qed.
 Hint Resolve Rlt_0_1: real.
 
 Lemma Rle_0_1 : 0 <= 1.
-left.
-exact Rlt_0_1.
+Proof.
+  left.
+  exact Rlt_0_1.
 Qed.
 
-(** Order and inverse *)
+(** ** Order and inverse *)
 Lemma Rinv_0_lt_compat : forall r, 0 < r -> 0 < / r.
-intros; apply Rnot_le_lt; red in |- *; intros.
-absurd (1 <= 0); auto with real.
-replace 1 with (r * / r); auto with real.
-replace 0 with (r * 0); auto with real.
+Proof.
+  intros; apply Rnot_le_lt; red in |- *; intros.
+  absurd (1 <= 0); auto with real.
+  replace 1 with (r * / r); auto with real.
+  replace 0 with (r * 0); auto with real.
 Qed.
 Hint Resolve Rinv_0_lt_compat: real.
 
 (*********)
 Lemma Rinv_lt_0_compat : forall r, r < 0 -> / r < 0.
-intros; apply Rnot_le_lt; red in |- *; intros.
-absurd (1 <= 0); auto with real.
-replace 1 with (r * / r); auto with real.
-replace 0 with (r * 0); auto with real.
+Proof.
+  intros; apply Rnot_le_lt; red in |- *; intros.
+  absurd (1 <= 0); auto with real.
+  replace 1 with (r * / r); auto with real.
+  replace 0 with (r * 0); auto with real.
 Qed.
 Hint Resolve Rinv_lt_0_compat: real.
 
 (*********)
 Lemma Rinv_lt_contravar : forall r1 r2, 0 < r1 * r2 -> r1 < r2 -> / r2 < / r1.
-intros; apply Rmult_lt_reg_l with (r1 * r2); auto with real.
-case (Rmult_neq_0_reg r1 r2); intros; auto with real.
-replace (r1 * r2 * / r2) with r1.
-replace (r1 * r2 * / r1) with r2; trivial.
-symmetry  in |- *; auto with real.
-symmetry  in |- *; auto with real.
+Proof.
+  intros; apply Rmult_lt_reg_l with (r1 * r2); auto with real.
+  case (Rmult_neq_0_reg r1 r2); intros; auto with real.
+  replace (r1 * r2 * / r2) with r1.
+  replace (r1 * r2 * / r1) with r2; trivial.
+  symmetry  in |- *; auto with real.
+  symmetry  in |- *; auto with real.
 Qed.
 
 Lemma Rinv_1_lt_contravar : forall r1 r2, 1 <= r1 -> r1 < r2 -> / r2 < / r1.
-intros x y H' H'0.
-cut (0 < x); [ intros Lt0 | apply Rlt_le_trans with (r2 := 1) ];
- auto with real.
-apply Rmult_lt_reg_l with (r := x); auto with real.
-rewrite (Rmult_comm x (/ x)); rewrite Rinv_l; auto with real.
-apply Rmult_lt_reg_l with (r := y); auto with real.
-apply Rlt_trans with (r2 := x); auto.
-cut (y * (x * / y) = x).
-intro H1; rewrite H1; rewrite (Rmult_1_r y); auto.
-rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite (Rmult_comm y (/ y));
- rewrite Rinv_l; auto with real.
-apply Rlt_dichotomy_converse; right.
-red in |- *; apply Rlt_trans with (r2 := x); auto with real.
+Proof.
+  intros x y H' H'0.
+  cut (0 < x); [ intros Lt0 | apply Rlt_le_trans with (r2 := 1) ];
+    auto with real.
+  apply Rmult_lt_reg_l with (r := x); auto with real.
+  rewrite (Rmult_comm x (/ x)); rewrite Rinv_l; auto with real.
+  apply Rmult_lt_reg_l with (r := y); auto with real.
+  apply Rlt_trans with (r2 := x); auto.
+  cut (y * (x * / y) = x).
+  intro H1; rewrite H1; rewrite (Rmult_1_r y); auto.
+  rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite (Rmult_comm y (/ y));
+    rewrite Rinv_l; auto with real.
+  apply Rlt_dichotomy_converse; right.
+  red in |- *; apply Rlt_trans with (r2 := x); auto with real.
 Qed.
 Hint Resolve Rinv_1_lt_contravar: real.
 
-(*********************************************************)        
-(**      Greater                                         *)
-(*********************************************************)
+(********************************************************)        
+(** *     Greater                                       *)
+(********************************************************)
 
 (**********)
 Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 = r2.
-intros; apply Rle_antisym; auto with real.
+Proof.
+  intros; apply Rle_antisym; auto with real.
 Qed.
 
 (**********)
 Lemma Rnot_lt_ge : forall r1 r2, ~ r1 < r2 -> r1 >= r2.
-intros; unfold Rge in |- *; elim (Rtotal_order r1 r2); intro.
-absurd (r1 < r2); trivial.
-case H0; auto.
+Proof.
+  intros; unfold Rge in |- *; elim (Rtotal_order r1 r2); intro.
+  absurd (r1 < r2); trivial.
+  case H0; auto.
 Qed.
 
 (**********)
 Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1.
-intros; apply Rge_le; apply Rnot_lt_ge; assumption.
+Proof.
+  intros; apply Rge_le; apply Rnot_lt_ge; assumption.
 Qed.
 
 (**********)
 Lemma Rnot_gt_le : forall r1 r2, ~ r1 > r2 -> r1 <= r2.
-intros r1 r2 H; apply Rge_le.
-exact (Rnot_lt_ge r2 r1 H).
+Proof.
+  intros r1 r2 H; apply Rge_le.
+  exact (Rnot_lt_ge r2 r1 H).
 Qed.
 
 (**********)
 Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2.
-red in |- *; auto with real.
+Proof.
+  red in |- *; auto with real.
 Qed.
 
 
 (**********)
 Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3.
-unfold Rgt in |- *; intros; apply Rlt_le_trans with r2; auto with real.
+Proof.
+  unfold Rgt in |- *; intros; apply Rlt_le_trans with r2; auto with real.
 Qed.
 
 (**********)
 Lemma Rgt_ge_trans : forall r1 r2 r3, r1 > r2 -> r2 >= r3 -> r1 > r3.
-unfold Rgt in |- *; intros; apply Rle_lt_trans with r2; auto with real.
+Proof.
+  unfold Rgt in |- *; intros; apply Rle_lt_trans with r2; auto with real.
 Qed.
 
 (**********)
 Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3.
-unfold Rgt in |- *; intros; apply Rlt_trans with r2; auto with real.
+Proof.
+  unfold Rgt in |- *; intros; apply Rlt_trans with r2; auto with real.
 Qed.
 
 (**********)
 Lemma Rge_trans : forall r1 r2 r3, r1 >= r2 -> r2 >= r3 -> r1 >= r3.
-intros; apply Rle_ge.
-apply Rle_trans with r2; auto with real.
+Proof.
+  intros; apply Rle_ge.
+  apply Rle_trans with r2; auto with real.
 Qed.
 
 (**********)
 Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1.
-intros.
-apply Rlt_le_trans with 1; auto with real.
-pattern 1 at 1 in |- *; replace 1 with (0 + 1); auto with real.
+Proof.
+  intros.
+  apply Rlt_le_trans with 1; auto with real.
+  pattern 1 at 1 in |- *; replace 1 with (0 + 1); auto with real.
 Qed.
 Hint Resolve Rle_lt_0_plus_1: real.
 
 (**********)
 Lemma Rlt_plus_1 : forall r, r < r + 1.
-intros.
-pattern r at 1 in |- *; replace r with (r + 0); auto with real.
+Proof.
+  intros.
+  pattern r at 1 in |- *; replace r with (r + 0); auto with real.
 Qed.
 Hint Resolve Rlt_plus_1: real.
 
 (**********)
 Lemma tech_Rgt_minus : forall r1 r2, 0 < r2 -> r1 > r1 - r2.
-red in |- *; unfold Rminus in |- *; intros.
-pattern r1 at 2 in |- *; replace r1 with (r1 + 0); auto with real.
+Proof.
+  red in |- *; unfold Rminus in |- *; intros.
+  pattern r1 at 2 in |- *; replace r1 with (r1 + 0); auto with real.
 Qed.
 
 (***********)
 Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2.
-unfold Rgt in |- *; auto with real.
+Proof.
+  unfold Rgt in |- *; auto with real.
 Qed.
 Hint Resolve Rplus_gt_compat_l: real.
 
 (***********)
 Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2.
-unfold Rgt in |- *; intros; apply (Rplus_lt_reg_r r r2 r1 H).
+Proof.
+  unfold Rgt in |- *; intros; apply (Rplus_lt_reg_r r r2 r1 H).
 Qed.
 
 (***********)
 Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2.
-intros; apply Rle_ge; auto with real.
+Proof.
+  intros; apply Rle_ge; auto with real.
 Qed.
 Hint Resolve Rplus_ge_compat_l: real.
 
 (***********)
 Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2.
-intros; apply Rle_ge; apply Rplus_le_reg_l with r; auto with real.
+Proof.
+  intros; apply Rle_ge; apply Rplus_le_reg_l with r; auto with real.
 Qed.
 
 (***********)
 Lemma Rmult_ge_compat_r :
- forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r.
-intros; apply Rle_ge; apply Rmult_le_compat_r; apply Rge_le; assumption.
+  forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r.
+Proof.
+  intros; apply Rle_ge; apply Rmult_le_compat_r; apply Rge_le; assumption.
 Qed.
 
 (***********)
 Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0.
-intros; replace 0 with (r2 - r2); auto with real.
-unfold Rgt, Rminus in |- *; auto with real.
+Proof.
+  intros; replace 0 with (r2 - r2); auto with real.
+  unfold Rgt, Rminus in |- *; auto with real.
 Qed.
 
 (*********)
 Lemma minus_Rgt : forall r1 r2, r1 - r2 > 0 -> r1 > r2.
-intros; replace r2 with (r2 + 0); auto with real.
-intros; replace r1 with (r2 + (r1 - r2)); auto with real.
+Proof.
+  intros; replace r2 with (r2 + 0); auto with real.
+  intros; replace r1 with (r2 + (r1 - r2)); auto with real.
 Qed.
 
 (**********)
 Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0.
-unfold Rge in |- *; intros; elim H; intro.
-left; apply (Rgt_minus r1 r2 H0).
-right; apply (Rminus_diag_eq r1 r2 H0).
+Proof.
+  unfold Rge in |- *; intros; elim H; intro.
+  left; apply (Rgt_minus r1 r2 H0).
+  right; apply (Rminus_diag_eq r1 r2 H0).
 Qed.
 
 (*********)
 Lemma minus_Rge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2.
-intros; replace r2 with (r2 + 0); auto with real.
-intros; replace r1 with (r2 + (r1 - r2)); auto with real.
+Proof.
+  intros; replace r2 with (r2 + 0); auto with real.
+  intros; replace r1 with (r2 + (r1 - r2)); auto with real.
 Qed.
 
 
 (*********)
 Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
-unfold Rgt in |- *; intros.
-replace 0 with (0 * r2); auto with real.
+Proof.
+  unfold Rgt in |- *; intros.
+  replace 0 with (0 * r2); auto with real.
 Qed.
 
 (*********)
@@ -1119,377 +1262,431 @@ Proof Rmult_gt_0_compat.
 
 (***********)
 Lemma Rplus_eq_0_l :
- forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0.
-intros a b [H| H] H0 H1; auto with real.
-absurd (0 < a + b).
-rewrite H1; auto with real.
-replace 0 with (0 + 0); auto with real.
+  forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0.
+Proof.
+  intros a b [H| H] H0 H1; auto with real.
+  absurd (0 < a + b).
+  rewrite H1; auto with real.
+  replace 0 with (0 + 0); auto with real.
 Qed.
 
 
 Lemma Rplus_eq_R0 :
- forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0 /\ r2 = 0.
-intros a b; split.
-apply Rplus_eq_0_l with b; auto with real.
-apply Rplus_eq_0_l with a; auto with real.
-rewrite Rplus_comm; auto with real.
+  forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0 /\ r2 = 0.
+Proof.
+  intros a b; split.
+  apply Rplus_eq_0_l with b; auto with real.
+  apply Rplus_eq_0_l with a; auto with real.
+  rewrite Rplus_comm; auto with real.
 Qed.
 
 
 (***********)
 Lemma Rplus_sqr_eq_0_l : forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0.
-intros a b; intros; apply Rsqr_0_uniq; apply Rplus_eq_0_l with (Rsqr b);
- auto with real.
+Proof.
+  intros a b; intros; apply Rsqr_0_uniq; apply Rplus_eq_0_l with (Rsqr b);
+    auto with real.
 Qed.
 
 Lemma Rplus_sqr_eq_0 :
- forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0 /\ r2 = 0.
-intros a b; split.
-apply Rplus_sqr_eq_0_l with b; auto with real.
-apply Rplus_sqr_eq_0_l with a; auto with real.
-rewrite Rplus_comm; auto with real.
+  forall r1 r2, Rsqr r1 + Rsqr r2 = 0 -> r1 = 0 /\ r2 = 0.
+Proof.
+  intros a b; split.
+  apply Rplus_sqr_eq_0_l with b; auto with real.
+  apply Rplus_sqr_eq_0_l with a; auto with real.
+  rewrite Rplus_comm; auto with real.
 Qed.
 
 
 (**********************************************************) 
-(**       Injection from [N] to [R]                       *)
+(** *     Injection from [N] to [R]                       *)
 (**********************************************************)
 
 (**********)
 Lemma S_INR : forall n:nat, INR (S n) = INR n + 1.
-intro; case n; auto with real.
+Proof.
+  intro; case n; auto with real.
 Qed.
 
 (**********)
 Lemma S_O_plus_INR : forall n:nat, INR (1 + n) = INR 1 + INR n.
-intro; simpl in |- *; case n; intros; auto with real.
+Proof.
+  intro; simpl in |- *; case n; intros; auto with real.
 Qed.
 
 (**********)
 Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. 
-intros n m; induction  n as [| n Hrecn].
-simpl in |- *; auto with real.
-replace (S n + m)%nat with (S (n + m)); auto with arith.
-repeat rewrite S_INR.
-rewrite Hrecn; ring.
+Proof.
+  intros n m; induction  n as [| n Hrecn].
+  simpl in |- *; auto with real.
+  replace (S n + m)%nat with (S (n + m)); auto with arith.
+  repeat rewrite S_INR.
+  rewrite Hrecn; ring.
 Qed.
 
 (**********)
 Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) = INR n - INR m.
-intros n m le; pattern m, n in |- *; apply le_elim_rel; auto with real.
-intros; rewrite <- minus_n_O; auto with real.
-intros; repeat rewrite S_INR; simpl in |- *.
-rewrite H0; ring.
+Proof.
+  intros n m le; pattern m, n in |- *; apply le_elim_rel; auto with real.
+  intros; rewrite <- minus_n_O; auto with real.
+  intros; repeat rewrite S_INR; simpl in |- *.
+  rewrite H0; ring.
 Qed.
 
 (*********)
 Lemma mult_INR : forall n m:nat, INR (n * m) = INR n * INR m.
-intros n m; induction  n as [| n Hrecn].
-simpl in |- *; auto with real.
-intros; repeat rewrite S_INR; simpl in |- *.
-rewrite plus_INR; rewrite Hrecn; ring.
+Proof.
+  intros n m; induction  n as [| n Hrecn].
+  simpl in |- *; auto with real.
+  intros; repeat rewrite S_INR; simpl in |- *.
+  rewrite plus_INR; rewrite Hrecn; ring.
 Qed.
 
 Hint Resolve plus_INR minus_INR mult_INR: real.
 
 (*********)
 Lemma lt_INR_0 : forall n:nat, (0 < n)%nat -> 0 < INR n.
-simple induction 1; intros; auto with real.
-rewrite S_INR; auto with real.
+Proof.
+  simple induction 1; intros; auto with real.
+  rewrite S_INR; auto with real.
 Qed.
 Hint Resolve lt_INR_0: real.
 
 Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m.
-simple induction 1; intros; auto with real.
-rewrite S_INR; auto with real.
-rewrite S_INR; apply Rlt_trans with (INR m0); auto with real.
+Proof.
+  simple induction 1; intros; auto with real.
+  rewrite S_INR; auto with real.
+  rewrite S_INR; apply Rlt_trans with (INR m0); auto with real.
 Qed.
 Hint Resolve lt_INR: real.
 
 Lemma INR_lt_1 : forall n:nat, (1 < n)%nat -> 1 < INR n.
-intros; replace 1 with (INR 1); auto with real.
+Proof.
+  intros; replace 1 with (INR 1); auto with real.
 Qed.
 Hint Resolve INR_lt_1: real.
 
 (**********)
 Lemma INR_pos : forall p:positive, 0 < INR (nat_of_P p).
-intro; apply lt_INR_0.
-simpl in |- *; auto with real.
-apply lt_O_nat_of_P.
+Proof.
+  intro; apply lt_INR_0.
+  simpl in |- *; auto with real.
+  apply lt_O_nat_of_P.
 Qed.
 Hint Resolve INR_pos: real.
 
 (**********)
 Lemma pos_INR : forall n:nat, 0 <= INR n.
-intro n; case n.
-simpl in |- *; auto with real.
-auto with arith real.
+Proof.
+  intro n; case n.
+  simpl in |- *; auto with real.
+  auto with arith real.
 Qed.
 Hint Resolve pos_INR: real.
 
 Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat.
-double induction n m; intros.
-simpl in |- *; elimtype False; apply (Rlt_irrefl 0); auto.
-auto with arith.
-generalize (pos_INR (S n0)); intro; cut (INR 0 = 0);
- [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ]. 
-generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; elimtype False;
- apply (Rlt_irrefl 0); auto.
-do 2 rewrite S_INR in H1; cut (INR n1 < INR n0).
-intro H2; generalize (H0 n0 H2); intro; auto with arith.
-apply (Rplus_lt_reg_r 1 (INR n1) (INR n0)).
-rewrite Rplus_comm; rewrite (Rplus_comm 1 (INR n0)); trivial.
+Proof.
+  double induction n m; intros.
+  simpl in |- *; elimtype False; apply (Rlt_irrefl 0); auto.
+  auto with arith.
+  generalize (pos_INR (S n0)); intro; cut (INR 0 = 0);
+    [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ]. 
+  generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; elimtype False;
+    apply (Rlt_irrefl 0); auto.
+  do 2 rewrite S_INR in H1; cut (INR n1 < INR n0).
+  intro H2; generalize (H0 n0 H2); intro; auto with arith.
+  apply (Rplus_lt_reg_r 1 (INR n1) (INR n0)).
+  rewrite Rplus_comm; rewrite (Rplus_comm 1 (INR n0)); trivial.
 Qed.
 Hint Resolve INR_lt: real.
 
 (*********)
 Lemma le_INR : forall n m:nat, (n <= m)%nat -> INR n <= INR m.
-simple induction 1; intros; auto with real.
-rewrite S_INR.
-apply Rle_trans with (INR m0); auto with real.
+Proof.
+  simple induction 1; intros; auto with real.
+  rewrite S_INR.
+  apply Rle_trans with (INR m0); auto with real.
 Qed.
 Hint Resolve le_INR: real.
 
 (**********)
 Lemma not_INR_O : forall n:nat, INR n <> 0 -> n <> 0%nat.
-red in |- *; intros n H H1.
-apply H.
-rewrite H1; trivial.
+Proof.
+  red in |- *; intros n H H1.
+  apply H.
+  rewrite H1; trivial.
 Qed.
 Hint Immediate not_INR_O: real.
 
 (**********)
 Lemma not_O_INR : forall n:nat, n <> 0%nat -> INR n <> 0.
-intro n; case n.
-intro; absurd (0%nat = 0%nat); trivial.
-intros; rewrite S_INR.
-apply Rgt_not_eq; red in |- *; auto with real.
+Proof.
+  intro n; case n.
+  intro; absurd (0%nat = 0%nat); trivial.
+  intros; rewrite S_INR.
+  apply Rgt_not_eq; red in |- *; auto with real.
 Qed.
 Hint Resolve not_O_INR: real.
 
 Lemma not_nm_INR : forall n m:nat, n <> m -> INR n <> INR m.
-intros n m H; case (le_or_lt n m); intros H1.
-case (le_lt_or_eq _ _ H1); intros H2.
-apply Rlt_dichotomy_converse; auto with real.
-elimtype False; auto.
-apply sym_not_eq; apply Rlt_dichotomy_converse; auto with real.
+Proof.
+  intros n m H; case (le_or_lt n m); intros H1.
+  case (le_lt_or_eq _ _ H1); intros H2.
+  apply Rlt_dichotomy_converse; auto with real.
+  elimtype False; auto.
+  apply sym_not_eq; apply Rlt_dichotomy_converse; auto with real.
 Qed.
 Hint Resolve not_nm_INR: real.
 
 Lemma INR_eq : forall n m:nat, INR n = INR m -> n = m.
-intros; case (le_or_lt n m); intros H1.
-case (le_lt_or_eq _ _ H1); intros H2; auto.
-cut (n <> m).
-intro H3; generalize (not_nm_INR n m H3); intro H4; elimtype False; auto.
-omega.
-symmetry  in |- *; cut (m <> n).
-intro H3; generalize (not_nm_INR m n H3); intro H4; elimtype False; auto.
-omega.
+Proof.
+  intros; case (le_or_lt n m); intros H1.
+  case (le_lt_or_eq _ _ H1); intros H2; auto.
+  cut (n <> m).
+  intro H3; generalize (not_nm_INR n m H3); intro H4; elimtype False; auto.
+  omega.
+  symmetry  in |- *; cut (m <> n).
+  intro H3; generalize (not_nm_INR m n H3); intro H4; elimtype False; auto.
+  omega.
 Qed.
 Hint Resolve INR_eq: real.
 
 Lemma INR_le : forall n m:nat, INR n <= INR m -> (n <= m)%nat.
-intros; elim H; intro.
-generalize (INR_lt n m H0); intro; auto with arith.
-generalize (INR_eq n m H0); intro; rewrite H1; auto.
+Proof.
+  intros; elim H; intro.
+  generalize (INR_lt n m H0); intro; auto with arith.
+  generalize (INR_eq n m H0); intro; rewrite H1; auto.
 Qed.
 Hint Resolve INR_le: real.
 
 Lemma not_1_INR : forall n:nat, n <> 1%nat -> INR n <> 1.
-replace 1 with (INR 1); auto with real.
+Proof.
+  replace 1 with (INR 1); auto with real.
 Qed.
 Hint Resolve not_1_INR: real.
 
 (**********************************************************) 
-(**      Injection from [Z] to [R]                        *)
+(** *    Injection from [Z] to [R]                        *)
 (**********************************************************)
 
 
 (**********)
 Lemma IZN : forall n:Z, (0 <= n)%Z ->  exists m : nat, n = Z_of_nat m.
-intros z; idtac; apply Z_of_nat_complete; assumption.
+Proof.
+  intros z; idtac; apply Z_of_nat_complete; assumption.
 Qed.
 
 (**********)
 Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z_of_nat n).
-simple induction n; auto with real.
-intros; simpl in |- *; rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
- auto with real.
+Proof.
+  simple induction n; auto with real.
+  intros; simpl in |- *; rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
+    auto with real.
 Qed.
 
 Lemma plus_IZR_NEG_POS :
- forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q).
-intros.
-case (lt_eq_lt_dec (nat_of_P p) (nat_of_P q)).
-intros [H| H]; simpl in |- *.
-rewrite nat_of_P_lt_Lt_compare_complement_morphism; simpl in |- *; trivial.
-rewrite (nat_of_P_minus_morphism q p).
-rewrite minus_INR; auto with arith; ring.
-apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial.
-rewrite (nat_of_P_inj p q); trivial.
-rewrite Pcompare_refl; simpl in |- *; auto with real.
-intro H; simpl in |- *.
-rewrite nat_of_P_gt_Gt_compare_complement_morphism; simpl in |- *;
- auto with arith.
-rewrite (nat_of_P_minus_morphism p q).
-rewrite minus_INR; auto with arith; ring.
-apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial.
+  forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q).
+Proof.
+  intros.
+  case (lt_eq_lt_dec (nat_of_P p) (nat_of_P q)).
+  intros [H| H]; simpl in |- *.
+  rewrite nat_of_P_lt_Lt_compare_complement_morphism; simpl in |- *; trivial.
+  rewrite (nat_of_P_minus_morphism q p).
+  rewrite minus_INR; auto with arith; ring.
+  apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial.
+  rewrite (nat_of_P_inj p q); trivial.
+  rewrite Pcompare_refl; simpl in |- *; auto with real.
+  intro H; simpl in |- *.
+  rewrite nat_of_P_gt_Gt_compare_complement_morphism; simpl in |- *;
+    auto with arith.
+  rewrite (nat_of_P_minus_morphism p q).
+  rewrite minus_INR; auto with arith; ring.
+  apply ZC2; apply nat_of_P_lt_Lt_compare_complement_morphism; trivial.
 Qed.
 
 (**********)
 Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m.
-intro z; destruct z; intro t; destruct t; intros; auto with real.
-simpl in |- *; intros; rewrite nat_of_P_plus_morphism; auto with real.
-apply plus_IZR_NEG_POS.
-rewrite Zplus_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS.
-simpl in |- *; intros; rewrite nat_of_P_plus_morphism; rewrite plus_INR;
- auto with real.
+Proof.
+  intro z; destruct z; intro t; destruct t; intros; auto with real.
+  simpl in |- *; intros; rewrite nat_of_P_plus_morphism; auto with real.
+  apply plus_IZR_NEG_POS.
+  rewrite Zplus_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS.
+  simpl in |- *; intros; rewrite nat_of_P_plus_morphism; rewrite plus_INR;
+    auto with real.
 Qed.
 
 (**********)
 Lemma mult_IZR : forall n m:Z, IZR (n * m) = IZR n * IZR m.
-intros z t; case z; case t; simpl in |- *; auto with real.
-intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
-intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
-rewrite Rmult_comm.
-rewrite Ropp_mult_distr_l_reverse; auto with real.
-apply Ropp_eq_compat; rewrite mult_comm; auto with real.
-intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
-rewrite Ropp_mult_distr_l_reverse; auto with real.
-intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
-rewrite Rmult_opp_opp; auto with real.
+Proof.
+  intros z t; case z; case t; simpl in |- *; auto with real.
+  intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+  intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+  rewrite Rmult_comm.
+  rewrite Ropp_mult_distr_l_reverse; auto with real.
+  apply Ropp_eq_compat; rewrite mult_comm; auto with real.
+  intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+  rewrite Ropp_mult_distr_l_reverse; auto with real.
+  intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real.
+  rewrite Rmult_opp_opp; auto with real.
+Qed.
+
+Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Zpower z (Z_of_nat n)).
+Proof.
+ intros z [|n];simpl;trivial.
+ rewrite Zpower_pos_nat.
+ rewrite nat_of_P_o_P_of_succ_nat_eq_succ. unfold Zpower_nat;simpl.
+ rewrite mult_IZR.
+ induction n;simpl;trivial.
+ rewrite mult_IZR;ring[IHn].
 Qed.
 
 (**********)
 Lemma Ropp_Ropp_IZR : forall n:Z, IZR (- n) = - IZR n.
-intro z; case z; simpl in |- *; auto with real.
+Proof.
+  intro z; case z; simpl in |- *; auto with real.
 Qed.
 
 (**********)
 Lemma Z_R_minus : forall n m:Z, IZR n - IZR m = IZR (n - m).
-intros z1 z2; unfold Rminus in |- *; unfold Zminus in |- *.
-rewrite <- (Ropp_Ropp_IZR z2); symmetry  in |- *; apply plus_IZR.
+Proof.
+  intros z1 z2; unfold Rminus in |- *; unfold Zminus in |- *.
+  rewrite <- (Ropp_Ropp_IZR z2); symmetry  in |- *; apply plus_IZR.
 Qed. 
 
 (**********)
 Lemma lt_O_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z.
-intro z; case z; simpl in |- *; intros.
-absurd (0 < 0); auto with real.
-unfold Zlt in |- *; simpl in |- *; trivial.
-case Rlt_not_le with (1 := H).
-replace 0 with (-0); auto with real.
+Proof.
+  intro z; case z; simpl in |- *; intros.
+  absurd (0 < 0); auto with real.
+  unfold Zlt in |- *; simpl in |- *; trivial.
+  case Rlt_not_le with (1 := H).
+  replace 0 with (-0); auto with real.
 Qed.
 
 (**********)
 Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z.
-intros z1 z2 H; apply Zlt_0_minus_lt. 
-apply lt_O_IZR.
-rewrite <- Z_R_minus.
-exact (Rgt_minus (IZR z2) (IZR z1) H).
+Proof.
+  intros z1 z2 H; apply Zlt_0_minus_lt. 
+  apply lt_O_IZR.
+  rewrite <- Z_R_minus.
+  exact (Rgt_minus (IZR z2) (IZR z1) H).
 Qed.
 
 (**********)
 Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z.
-intro z; destruct z; simpl in |- *; intros; auto with zarith.
-case (Rlt_not_eq 0 (INR (nat_of_P p))); auto with real.
-case (Rlt_not_eq (- INR (nat_of_P p)) 0); auto with real.
-apply Ropp_lt_gt_0_contravar. unfold Rgt in |- *; apply INR_pos.
+Proof.
+  intro z; destruct z; simpl in |- *; intros; auto with zarith.
+  case (Rlt_not_eq 0 (INR (nat_of_P p))); auto with real.
+  case (Rlt_not_eq (- INR (nat_of_P p)) 0); auto with real.
+  apply Ropp_lt_gt_0_contravar. unfold Rgt in |- *; apply INR_pos.
 Qed.
 
 (**********)
 Lemma eq_IZR : forall n m:Z, IZR n = IZR m -> n = m.
-intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H);
- rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); 
- intro; omega.
+Proof.
+  intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H);
+    rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); 
+      intro; omega.
 Qed.
 
 (**********)
 Lemma not_O_IZR : forall n:Z, n <> 0%Z -> IZR n <> 0.
-intros z H; red in |- *; intros H0; case H.
-apply eq_IZR; auto.
+Proof.
+  intros z H; red in |- *; intros H0; case H.
+  apply eq_IZR; auto.
 Qed.
 
 (*********)
 Lemma le_O_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z.
-unfold Rle in |- *; intros z [H| H].
-red in |- *; intro; apply (Zlt_le_weak 0 z (lt_O_IZR z H)); assumption.
-rewrite (eq_IZR_R0 z); auto with zarith real.
+Proof.
+  unfold Rle in |- *; intros z [H| H].
+  red in |- *; intro; apply (Zlt_le_weak 0 z (lt_O_IZR z H)); assumption.
+  rewrite (eq_IZR_R0 z); auto with zarith real.
 Qed.
 
 (**********)
 Lemma le_IZR : forall n m:Z, IZR n <= IZR m -> (n <= m)%Z.
-unfold Rle in |- *; intros z1 z2 [H| H].
-apply (Zlt_le_weak z1 z2); auto with real.
-apply lt_IZR; trivial.
-rewrite (eq_IZR z1 z2); auto with zarith real.
+Proof.
+  unfold Rle in |- *; intros z1 z2 [H| H].
+  apply (Zlt_le_weak z1 z2); auto with real.
+  apply lt_IZR; trivial.
+  rewrite (eq_IZR z1 z2); auto with zarith real.
 Qed.
 
 (**********)
 Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z.
-pattern 1 at 1 in |- *; replace 1 with (IZR 1); intros; auto.
-apply le_IZR; trivial.
+Proof.
+  pattern 1 at 1 in |- *; replace 1 with (IZR 1); intros; auto.
+  apply le_IZR; trivial.
 Qed.
 
 (**********)
 Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m.
-intros m n H; apply Rnot_lt_ge; red in |- *; intro.
-generalize (lt_IZR m n H0); intro; omega.
+Proof.
+  intros m n H; apply Rnot_lt_ge; red in |- *; intro.
+  generalize (lt_IZR m n H0); intro; omega.
 Qed.
 
 Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m.
-intros m n H; apply Rnot_gt_le; red in |- *; intro.
-unfold Rgt in H0; generalize (lt_IZR n m H0); intro; omega.
+Proof.
+  intros m n H; apply Rnot_gt_le; red in |- *; intro.
+  unfold Rgt in H0; generalize (lt_IZR n m H0); intro; omega.
 Qed.
 
 Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m.
-intros m n H; cut (m <= n)%Z.
-intro H0; elim (IZR_le m n H0); intro; auto.
-generalize (eq_IZR m n H1); intro; elimtype False; omega.
-omega.
+Proof.
+  intros m n H; cut (m <= n)%Z.
+  intro H0; elim (IZR_le m n H0); intro; auto.
+  generalize (eq_IZR m n H1); intro; elimtype False; omega.
+  omega.
 Qed.
 
 Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z.
-intros z [H1 H2].
-apply Zle_antisym.
-apply Zlt_succ_le; apply lt_IZR; trivial.
-replace 0%Z with (Zsucc (-1)); trivial.
-apply Zlt_le_succ; apply lt_IZR; trivial.
+Proof.
+  intros z [H1 H2].
+  apply Zle_antisym.
+  apply Zlt_succ_le; apply lt_IZR; trivial.
+  replace 0%Z with (Zsucc (-1)); trivial.
+  apply Zlt_le_succ; apply lt_IZR; trivial.
 Qed.
 
 Lemma one_IZR_r_R1 :
- forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m.
-intros r z x [H1 H2] [H3 H4].
-cut ((z - x)%Z = 0%Z); auto with zarith.
-apply one_IZR_lt1.
-rewrite <- Z_R_minus; split.
-replace (-1) with (r - (r + 1)).
-unfold Rminus in |- *; apply Rplus_lt_le_compat; auto with real.
-ring.
-replace 1 with (r + 1 - r).
-unfold Rminus in |- *; apply Rplus_le_lt_compat; auto with real.
-ring.
+  forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m.
+Proof.
+  intros r z x [H1 H2] [H3 H4].
+  cut ((z - x)%Z = 0%Z); auto with zarith.
+  apply one_IZR_lt1.
+  rewrite <- Z_R_minus; split.
+  replace (-1) with (r - (r + 1)).
+  unfold Rminus in |- *; apply Rplus_lt_le_compat; auto with real.
+  ring.
+  replace 1 with (r + 1 - r).
+  unfold Rminus in |- *; apply Rplus_le_lt_compat; auto with real.
+  ring.
 Qed.
 
 
 (**********)
 Lemma single_z_r_R1 :
- forall r (n m:Z),
-   r < IZR n -> IZR n <= r + 1 -> r < IZR m -> IZR m <= r + 1 -> n = m.
-intros; apply one_IZR_r_R1 with r; auto.
+  forall r (n m:Z),
+    r < IZR n -> IZR n <= r + 1 -> r < IZR m -> IZR m <= r + 1 -> n = m.
+Proof.
+  intros; apply one_IZR_r_R1 with r; auto.
 Qed.
 
 (**********)
 Lemma tech_single_z_r_R1 :
- forall r (n:Z),
-   r < IZR n ->
-   IZR n <= r + 1 ->
-   (exists s : Z, s <> n /\ r < IZR s /\ IZR s <= r + 1) -> False.
-intros r z H1 H2 [s [H3 [H4 H5]]].
-apply H3; apply single_z_r_R1 with r; trivial.
+  forall r (n:Z),
+    r < IZR n ->
+    IZR n <= r + 1 ->
+    (exists s : Z, s <> n /\ r < IZR s /\ IZR s <= r + 1) -> False.
+Proof.
+  intros r z H1 H2 [s [H3 [H4 H5]]].
+  apply H3; apply single_z_r_R1 with r; trivial.
 Qed.
 
 (*****************************************************************)
-(** Definitions of new types                                     *)
+(** * Definitions of new types                                   *)
 (*****************************************************************)
 
 Record nonnegreal : Type := mknonnegreal
@@ -1507,125 +1704,138 @@ Record nonzeroreal : Type := mknonzeroreal
 
 (**********)
 Lemma prod_neq_R0 : forall r1 r2, r1 <> 0 -> r2 <> 0 -> r1 * r2 <> 0.
-intros x y; intros; red in |- *; intro; generalize (Rmult_integral x y H1);
- intro; elim H2; intro;
- [ rewrite H3 in H; elim H | rewrite H3 in H0; elim H0 ]; 
- reflexivity.
+Proof.
+  intros x y; intros; red in |- *; intro; generalize (Rmult_integral x y H1);
+    intro; elim H2; intro;
+      [ rewrite H3 in H; elim H | rewrite H3 in H0; elim H0 ]; 
+      reflexivity.
 Qed.
 
 (*********)
 Lemma Rmult_le_pos : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2.
-intros x y H H0; rewrite <- (Rmult_0_l x); rewrite <- (Rmult_comm x);
- apply (Rmult_le_compat_l x 0 y H H0).
+Proof.
+  intros x y H H0; rewrite <- (Rmult_0_l x); rewrite <- (Rmult_comm x);
+    apply (Rmult_le_compat_l x 0 y H H0).
 Qed.
 
 Lemma double : forall r1, 2 * r1 = r1 + r1.
-intro; ring.
+Proof.
+  intro; ring.
 Qed.
 
 Lemma double_var : forall r1, r1 = r1 / 2 + r1 / 2.
-intro; rewrite <- double; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
- symmetry  in |- *; apply Rinv_r_simpl_m.
-replace 2 with (INR 2);
- [ apply not_O_INR; discriminate | unfold INR in |- *; ring ].
+Proof.
+  intro; rewrite <- double; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+    symmetry  in |- *; apply Rinv_r_simpl_m.
+  replace 2 with (INR 2);
+  [ apply not_O_INR; discriminate | unfold INR in |- *; ring ].
 Qed.
 
 (**********************************************************)
-(** Other rules about < and <=                            *)
+(** * Other rules about < and <=                          *)
 (**********************************************************)
 
 Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2.
-intros x y; intros; apply Rlt_trans with x;
- [ assumption
- | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
-    assumption ].
+Proof.
+  intros x y; intros; apply Rlt_trans with x;
+    [ assumption
+      | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
+        assumption ].
 Qed.
 
 Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2.
-intros x y; intros; apply Rle_lt_trans with x;
- [ assumption
- | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
-    assumption ].
+Proof.
+  intros x y; intros; apply Rle_lt_trans with x;
+    [ assumption
+      | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
+        assumption ].
 Qed.
 
 Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2.
-intros x y; intros; rewrite <- Rplus_comm; apply Rplus_le_lt_0_compat;
- assumption.
+Proof.
+  intros x y; intros; rewrite <- Rplus_comm; apply Rplus_le_lt_0_compat;
+    assumption.
 Qed.
 
 Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2.
-intros x y; intros; apply Rle_trans with x;
- [ assumption
- | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
-    assumption ].
+Proof.
+  intros x y; intros; apply Rle_trans with x;
+    [ assumption
+      | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+        assumption ].
 Qed.
 
 Lemma plus_le_is_le : forall r1 r2 r3, 0 <= r2 -> r1 + r2 <= r3 -> r1 <= r3.
-intros x y z; intros; apply Rle_trans with (x + y);
- [ pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
-    assumption
- | assumption ].
+Proof.
+  intros x y z; intros; apply Rle_trans with (x + y);
+    [ pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+      assumption
+      | assumption ].
 Qed.
 
 Lemma plus_lt_is_lt : forall r1 r2 r3, 0 <= r2 -> r1 + r2 < r3 -> r1 < r3.
-intros x y z; intros; apply Rle_lt_trans with (x + y);
- [ pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
-    assumption
- | assumption ].
+Proof.
+  intros x y z; intros; apply Rle_lt_trans with (x + y);
+    [ pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+      assumption
+      | assumption ].
 Qed.
 
 Lemma Rmult_le_0_lt_compat :
- forall r1 r2 r3 r4,
-   0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
-intros; apply Rle_lt_trans with (r2 * r3);
- [ apply Rmult_le_compat_r; [ assumption | left; assumption ]
- | apply Rmult_lt_compat_l;
-    [ apply Rle_lt_trans with r1; assumption | assumption ] ].
+  forall r1 r2 r3 r4,
+    0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
+Proof.
+  intros; apply Rle_lt_trans with (r2 * r3);
+    [ apply Rmult_le_compat_r; [ assumption | left; assumption ]
+      | apply Rmult_lt_compat_l;
+        [ apply Rle_lt_trans with r1; assumption | assumption ] ].
 Qed.
 
 Lemma le_epsilon :
- forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2.
-intros x y; intros; elim (Rtotal_order x y); intro.
-left; assumption.
-elim H0; intro.
-right; assumption.
-clear H0; generalize (Rgt_minus x y H1); intro H2; change (0 < x - y) in H2.
-cut (0 < 2).
-intro.
-generalize (Rmult_lt_0_compat (x - y) (/ 2) H2 (Rinv_0_lt_compat 2 H0));
- intro H3; generalize (H ((x - y) * / 2) H3);
- replace (y + (x - y) * / 2) with ((y + x) * / 2).
-intro H4;
- generalize (Rmult_le_compat_l 2 x ((y + x) * / 2) (Rlt_le 0 2 H0) H4);
- rewrite <- (Rmult_comm ((y + x) * / 2)); rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; replace (2 * x) with (x + x).
-rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption.
-ring. 
-replace 2 with (INR 2); [ apply not_O_INR; discriminate | ring ].
-pattern y at 2 in |- *; replace y with (y / 2 + y / 2).
-unfold Rminus, Rdiv in |- *.
-repeat rewrite Rmult_plus_distr_r.
-ring.
-cut (forall z:R, 2 * z = z + z).
-intro.
-rewrite <- (H4 (y / 2)).
-unfold Rdiv in |- *.
-rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
-replace 2 with (INR 2).
-apply not_O_INR.
-discriminate.
-unfold INR in |- *; reflexivity.
-intro; ring.
-cut (0%nat <> 2%nat);
- [ intro H0; generalize (lt_INR_0 2 (neq_O_lt 2 H0)); unfold INR in |- *;
-    intro; assumption
- | discriminate ].
+  forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2.
+Proof.
+  intros x y; intros; elim (Rtotal_order x y); intro.
+  left; assumption.
+  elim H0; intro.
+  right; assumption.
+  clear H0; generalize (Rgt_minus x y H1); intro H2; change (0 < x - y) in H2.
+  cut (0 < 2).
+  intro.
+  generalize (Rmult_lt_0_compat (x - y) (/ 2) H2 (Rinv_0_lt_compat 2 H0));
+    intro H3; generalize (H ((x - y) * / 2) H3);
+      replace (y + (x - y) * / 2) with ((y + x) * / 2).
+  intro H4;
+    generalize (Rmult_le_compat_l 2 x ((y + x) * / 2) (Rlt_le 0 2 H0) H4);
+      rewrite <- (Rmult_comm ((y + x) * / 2)); rewrite Rmult_assoc;
+        rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; replace (2 * x) with (x + x).
+  rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption.
+  ring. 
+  replace 2 with (INR 2); [ apply not_O_INR; discriminate | reflexivity ].
+  pattern y at 2 in |- *; replace y with (y / 2 + y / 2).
+  unfold Rminus, Rdiv in |- *.
+  repeat rewrite Rmult_plus_distr_r.
+  ring.
+  cut (forall z:R, 2 * z = z + z).
+  intro.
+  rewrite <- (H4 (y / 2)).
+  unfold Rdiv in |- *.
+  rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+  replace 2 with (INR 2).
+  apply not_O_INR.
+  discriminate.
+  unfold INR in |- *; reflexivity.
+  intro; ring.
+  cut (0%nat <> 2%nat);
+    [ intro H0; generalize (lt_INR_0 2 (neq_O_lt 2 H0)); unfold INR in |- *;
+      intro; assumption
+      | discriminate ].
 Qed.
 
 (**********)
 Lemma completeness_weak :
- forall E:R -> Prop,
-   bound E -> (exists x : R, E x) ->  exists m : R, is_lub E m.
-intros; elim (completeness E H H0); intros; split with x; assumption.
+  forall E:R -> Prop,
+    bound E -> (exists x : R, E x) ->  exists m : R, is_lub E m.
+Proof.
+  intros; elim (completeness E H H0); intros; split with x; assumption.
 Qed.
diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v
index 3b58c02f..19f2b4ff 100644
--- a/theories/Reals/RList.v
+++ b/theories/Reals/RList.v
@@ -5,208 +5,217 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: RList.v,v 1.10.2.1 2004/07/16 19:31:11 herbelin Exp $ i*)
+
+(*i $Id: RList.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
 Open Local Scope R_scope.
 
 Inductive Rlist : Type :=
-  | nil : Rlist
-  | cons : R -> Rlist -> Rlist.
+| nil : Rlist
+| cons : R -> Rlist -> Rlist.
 
 Fixpoint In (x:R) (l:Rlist) {struct l} : Prop :=
   match l with
-  | nil => False
-  | cons a l' => x = a \/ In x l'
+    | nil => False
+    | cons a l' => x = a \/ In x l'
   end.
 
 Fixpoint Rlength (l:Rlist) : nat :=
   match l with
-  | nil => 0%nat
-  | cons a l' => S (Rlength l')
+    | nil => 0%nat
+    | cons a l' => S (Rlength l')
   end.
 
 Fixpoint MaxRlist (l:Rlist) : R :=
   match l with
-  | nil => 0
-  | cons a l1 =>
+    | nil => 0
+    | cons a l1 =>
       match l1 with
-      | nil => a
-      | cons a' l2 => Rmax a (MaxRlist l1)
+        | nil => a
+        | cons a' l2 => Rmax a (MaxRlist l1)
       end
   end.
 
 Fixpoint MinRlist (l:Rlist) : R :=
   match l with
-  | nil => 1
-  | cons a l1 =>
+    | nil => 1
+    | cons a l1 =>
       match l1 with
-      | nil => a
-      | cons a' l2 => Rmin a (MinRlist l1)
+        | nil => a
+        | cons a' l2 => Rmin a (MinRlist l1)
       end
   end.
 
 Lemma MaxRlist_P1 : forall (l:Rlist) (x:R), In x l -> x <= MaxRlist l.
-intros; induction  l as [| r l Hrecl].
-simpl in H; elim H.
-induction  l as [| r0 l Hrecl0].
-simpl in H; elim H; intro.
-simpl in |- *; right; assumption.
-elim H0.
-replace (MaxRlist (cons r (cons r0 l))) with (Rmax r (MaxRlist (cons r0 l))).
-simpl in H; decompose [or] H.
-rewrite H0; apply RmaxLess1.
-unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
-apply Hrecl; simpl in |- *; tauto.
-apply Rle_trans with (MaxRlist (cons r0 l));
- [ apply Hrecl; simpl in |- *; tauto | left; auto with real ].
-unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
-apply Hrecl; simpl in |- *; tauto.
-apply Rle_trans with (MaxRlist (cons r0 l));
- [ apply Hrecl; simpl in |- *; tauto | left; auto with real ].
-reflexivity.
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  simpl in H; elim H.
+  induction  l as [| r0 l Hrecl0].
+  simpl in H; elim H; intro.
+  simpl in |- *; right; assumption.
+  elim H0.
+  replace (MaxRlist (cons r (cons r0 l))) with (Rmax r (MaxRlist (cons r0 l))).
+  simpl in H; decompose [or] H.
+  rewrite H0; apply RmaxLess1.
+  unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
+  apply Hrecl; simpl in |- *; tauto.
+  apply Rle_trans with (MaxRlist (cons r0 l));
+    [ apply Hrecl; simpl in |- *; tauto | left; auto with real ].
+  unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
+  apply Hrecl; simpl in |- *; tauto.
+  apply Rle_trans with (MaxRlist (cons r0 l));
+    [ apply Hrecl; simpl in |- *; tauto | left; auto with real ].
+  reflexivity.
 Qed.
 
 Fixpoint AbsList (l:Rlist) (x:R) {struct l} : Rlist :=
   match l with
-  | nil => nil
-  | cons a l' => cons (Rabs (a - x) / 2) (AbsList l' x)
+    | nil => nil
+    | cons a l' => cons (Rabs (a - x) / 2) (AbsList l' x)
   end.
 
 Lemma MinRlist_P1 : forall (l:Rlist) (x:R), In x l -> MinRlist l <= x.
-intros; induction  l as [| r l Hrecl].
-simpl in H; elim H.
-induction  l as [| r0 l Hrecl0].
-simpl in H; elim H; intro.
-simpl in |- *; right; symmetry  in |- *; assumption.
-elim H0.
-replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
-simpl in H; decompose [or] H.
-rewrite H0; apply Rmin_l.
-unfold Rmin in |- *; case (Rle_dec r (MinRlist (cons r0 l))); intro.
-apply Rle_trans with (MinRlist (cons r0 l)).
-assumption.
-apply Hrecl; simpl in |- *; tauto.
-apply Hrecl; simpl in |- *; tauto.
-apply Rle_trans with (MinRlist (cons r0 l)).
-apply Rmin_r.
-apply Hrecl; simpl in |- *; tauto.
-reflexivity.
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  simpl in H; elim H.
+  induction  l as [| r0 l Hrecl0].
+  simpl in H; elim H; intro.
+  simpl in |- *; right; symmetry  in |- *; assumption.
+  elim H0.
+  replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
+  simpl in H; decompose [or] H.
+  rewrite H0; apply Rmin_l.
+  unfold Rmin in |- *; case (Rle_dec r (MinRlist (cons r0 l))); intro.
+  apply Rle_trans with (MinRlist (cons r0 l)).
+  assumption.
+  apply Hrecl; simpl in |- *; tauto.
+  apply Hrecl; simpl in |- *; tauto.
+  apply Rle_trans with (MinRlist (cons r0 l)).
+  apply Rmin_r.
+  apply Hrecl; simpl in |- *; tauto.
+  reflexivity.
 Qed.
 
 Lemma AbsList_P1 :
- forall (l:Rlist) (x y:R), In y l -> In (Rabs (y - x) / 2) (AbsList l x).
-intros; induction  l as [| r l Hrecl].
-elim H.
-simpl in |- *; simpl in H; elim H; intro.
-left; rewrite H0; reflexivity.
-right; apply Hrecl; assumption.
+  forall (l:Rlist) (x y:R), In y l -> In (Rabs (y - x) / 2) (AbsList l x).
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  elim H.
+  simpl in |- *; simpl in H; elim H; intro.
+  left; rewrite H0; reflexivity.
+  right; apply Hrecl; assumption.
 Qed.
 
 Lemma MinRlist_P2 :
- forall l:Rlist, (forall y:R, In y l -> 0 < y) -> 0 < MinRlist l.
-intros; induction  l as [| r l Hrecl].
-apply Rlt_0_1.
-induction  l as [| r0 l Hrecl0].
-simpl in |- *; apply H; simpl in |- *; tauto.
-replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
-unfold Rmin in |- *; case (Rle_dec r (MinRlist (cons r0 l))); intro.
-apply H; simpl in |- *; tauto.
-apply Hrecl; intros; apply H; simpl in |- *; simpl in H0; tauto.
-reflexivity.
+  forall l:Rlist, (forall y:R, In y l -> 0 < y) -> 0 < MinRlist l.
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  apply Rlt_0_1.
+  induction  l as [| r0 l Hrecl0].
+  simpl in |- *; apply H; simpl in |- *; tauto.
+  replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
+  unfold Rmin in |- *; case (Rle_dec r (MinRlist (cons r0 l))); intro.
+  apply H; simpl in |- *; tauto.
+  apply Hrecl; intros; apply H; simpl in |- *; simpl in H0; tauto.
+  reflexivity.
 Qed.
 
 Lemma AbsList_P2 :
- forall (l:Rlist) (x y:R),
-   In y (AbsList l x) ->  exists z : R, In z l /\ y = Rabs (z - x) / 2.
-intros; induction  l as [| r l Hrecl].
-elim H.
-elim H; intro.
-exists r; split.
-simpl in |- *; tauto.
-assumption.
-assert (H1 := Hrecl H0); elim H1; intros; elim H2; clear H2; intros;
- exists x0; simpl in |- *; simpl in H2; tauto.
+  forall (l:Rlist) (x y:R),
+    In y (AbsList l x) ->  exists z : R, In z l /\ y = Rabs (z - x) / 2.
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  elim H.
+  elim H; intro.
+  exists r; split.
+  simpl in |- *; tauto.
+  assumption.
+  assert (H1 := Hrecl H0); elim H1; intros; elim H2; clear H2; intros;
+    exists x0; simpl in |- *; simpl in H2; tauto.
 Qed.
 
 Lemma MaxRlist_P2 :
- forall l:Rlist, (exists y : R, In y l) -> In (MaxRlist l) l.
-intros; induction  l as [| r l Hrecl].
-simpl in H; elim H; trivial.
-induction  l as [| r0 l Hrecl0].
-simpl in |- *; left; reflexivity.
-change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))) in |- *;
- unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); 
- intro.
-right; apply Hrecl; exists r0; left; reflexivity.
-left; reflexivity.
+  forall l:Rlist, (exists y : R, In y l) -> In (MaxRlist l) l.
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  simpl in H; elim H; trivial.
+  induction  l as [| r0 l Hrecl0].
+  simpl in |- *; left; reflexivity.
+  change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))) in |- *;
+    unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); 
+      intro.
+  right; apply Hrecl; exists r0; left; reflexivity.
+  left; reflexivity.
 Qed.
 
 Fixpoint pos_Rl (l:Rlist) (i:nat) {struct l} : R :=
   match l with
-  | nil => 0
-  | cons a l' => match i with
-                 | O => a
-                 | S i' => pos_Rl l' i'
-                 end
+    | nil => 0
+    | cons a l' => match i with
+                     | O => a
+                     | S i' => pos_Rl l' i'
+                   end
   end.
 
 Lemma pos_Rl_P1 :
- forall (l:Rlist) (a:R),
-   (0 < Rlength l)%nat ->
-   pos_Rl (cons a l) (Rlength l) = pos_Rl l (pred (Rlength l)).
-intros; induction  l as [| r l Hrecl];
- [ elim (lt_n_O _ H)
- | simpl in |- *; case (Rlength l); [ reflexivity | intro; reflexivity ] ].
+  forall (l:Rlist) (a:R),
+    (0 < Rlength l)%nat ->
+    pos_Rl (cons a l) (Rlength l) = pos_Rl l (pred (Rlength l)).
+Proof.
+  intros; induction  l as [| r l Hrecl];
+    [ elim (lt_n_O _ H)
+      | simpl in |- *; case (Rlength l); [ reflexivity | intro; reflexivity ] ].
 Qed.
 
 Lemma pos_Rl_P2 :
- forall (l:Rlist) (x:R),
-   In x l <-> (exists i : nat, (i < Rlength l)%nat /\ x = pos_Rl l i).
-intros; induction  l as [| r l Hrecl].
-split; intro;
- [ elim H | elim H; intros; elim H0; intros; elim (lt_n_O _ H1) ].
-split; intro.
-elim H; intro.
-exists 0%nat; split;
- [ simpl in |- *; apply lt_O_Sn | simpl in |- *; apply H0 ].
-elim Hrecl; intros; assert (H3 := H1 H0); elim H3; intros; elim H4; intros;
- exists (S x0); split;
- [ simpl in |- *; apply lt_n_S; assumption | simpl in |- *; assumption ].
-elim H; intros; elim H0; intros; elim (zerop x0); intro.
-rewrite a in H2; simpl in H2; left; assumption.
-right; elim Hrecl; intros; apply H4; assert (H5 : S (pred x0) = x0).
-symmetry  in |- *; apply S_pred with 0%nat; assumption.
-exists (pred x0); split;
- [ simpl in H1; apply lt_S_n; rewrite H5; assumption
- | rewrite <- H5 in H2; simpl in H2; assumption ].
+  forall (l:Rlist) (x:R),
+    In x l <-> (exists i : nat, (i < Rlength l)%nat /\ x = pos_Rl l i).
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  split; intro;
+    [ elim H | elim H; intros; elim H0; intros; elim (lt_n_O _ H1) ].
+  split; intro.
+  elim H; intro.
+  exists 0%nat; split;
+    [ simpl in |- *; apply lt_O_Sn | simpl in |- *; apply H0 ].
+  elim Hrecl; intros; assert (H3 := H1 H0); elim H3; intros; elim H4; intros;
+    exists (S x0); split;
+      [ simpl in |- *; apply lt_n_S; assumption | simpl in |- *; assumption ].
+  elim H; intros; elim H0; intros; elim (zerop x0); intro.
+  rewrite a in H2; simpl in H2; left; assumption.
+  right; elim Hrecl; intros; apply H4; assert (H5 : S (pred x0) = x0).
+  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  exists (pred x0); split;
+    [ simpl in H1; apply lt_S_n; rewrite H5; assumption
+      | rewrite <- H5 in H2; simpl in H2; assumption ].
 Qed.
 
 Lemma Rlist_P1 :
- forall (l:Rlist) (P:R -> R -> Prop),
-   (forall x:R, In x l ->  exists y : R, P x y) ->
+  forall (l:Rlist) (P:R -> R -> Prop),
+    (forall x:R, In x l ->  exists y : R, P x y) ->
     exists l' : Rlist,
-     Rlength l = Rlength l' /\
-     (forall i:nat, (i < Rlength l)%nat -> P (pos_Rl l i) (pos_Rl l' i)).
-intros; induction  l as [| r l Hrecl].
-exists nil; intros; split;
- [ reflexivity | intros; simpl in H0; elim (lt_n_O _ H0) ].
-assert (H0 : In r (cons r l)).
-simpl in |- *; left; reflexivity.
-assert (H1 := H _ H0);
- assert (H2 : forall x:R, In x l ->  exists y : R, P x y).
-intros; apply H; simpl in |- *; right; assumption.
-assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (cons x x0);
- intros; elim H5; clear H5; intros; split.
-simpl in |- *; rewrite H5; reflexivity.
-intros; elim (zerop i); intro.
-rewrite a; simpl in |- *; assumption.
-assert (H8 : i = S (pred i)).
-apply S_pred with 0%nat; assumption.
-rewrite H8; simpl in |- *; apply H6; simpl in H7; apply lt_S_n; rewrite <- H8;
- assumption.
+      Rlength l = Rlength l' /\
+      (forall i:nat, (i < Rlength l)%nat -> P (pos_Rl l i) (pos_Rl l' i)).
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  exists nil; intros; split;
+    [ reflexivity | intros; simpl in H0; elim (lt_n_O _ H0) ].
+  assert (H0 : In r (cons r l)).
+  simpl in |- *; left; reflexivity.
+  assert (H1 := H _ H0);
+    assert (H2 : forall x:R, In x l ->  exists y : R, P x y).
+  intros; apply H; simpl in |- *; right; assumption.
+  assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (cons x x0);
+    intros; elim H5; clear H5; intros; split.
+  simpl in |- *; rewrite H5; reflexivity.
+  intros; elim (zerop i); intro.
+  rewrite a; simpl in |- *; assumption.
+  assert (H8 : i = S (pred i)).
+  apply S_pred with 0%nat; assumption.
+  rewrite H8; simpl in |- *; apply H6; simpl in H7; apply lt_S_n; rewrite <- H8;
+    assumption.
 Qed.
 
 Definition ordered_Rlist (l:Rlist) : Prop :=
@@ -214,531 +223,561 @@ Definition ordered_Rlist (l:Rlist) : Prop :=
 
 Fixpoint insert (l:Rlist) (x:R) {struct l} : Rlist :=
   match l with
-  | nil => cons x nil
-  | cons a l' =>
+    | nil => cons x nil
+    | cons a l' =>
       match Rle_dec a x with
-      | left _ => cons a (insert l' x)
-      | right _ => cons x l
+        | left _ => cons a (insert l' x)
+        | right _ => cons x l
       end
   end.
 
 Fixpoint cons_Rlist (l k:Rlist) {struct l} : Rlist :=
   match l with
-  | nil => k
-  | cons a l' => cons a (cons_Rlist l' k)
+    | nil => k
+    | cons a l' => cons a (cons_Rlist l' k)
   end.
 
 Fixpoint cons_ORlist (k l:Rlist) {struct k} : Rlist :=
   match k with
-  | nil => l
-  | cons a k' => cons_ORlist k' (insert l a)
+    | nil => l
+    | cons a k' => cons_ORlist k' (insert l a)
   end.
 
 Fixpoint app_Rlist (l:Rlist) (f:R -> R) {struct l} : Rlist :=
   match l with
-  | nil => nil
-  | cons a l' => cons (f a) (app_Rlist l' f)
+    | nil => nil
+    | cons a l' => cons (f a) (app_Rlist l' f)
   end.
 
 Fixpoint mid_Rlist (l:Rlist) (x:R) {struct l} : Rlist :=
   match l with
-  | nil => nil
-  | cons a l' => cons ((x + a) / 2) (mid_Rlist l' a)
+    | nil => nil
+    | cons a l' => cons ((x + a) / 2) (mid_Rlist l' a)
   end.
 
 Definition Rtail (l:Rlist) : Rlist :=
   match l with
-  | nil => nil
-  | cons a l' => l'
+    | nil => nil
+    | cons a l' => l'
   end.
 
 Definition FF (l:Rlist) (f:R -> R) : Rlist :=
   match l with
-  | nil => nil
-  | cons a l' => app_Rlist (mid_Rlist l' a) f
+    | nil => nil
+    | cons a l' => app_Rlist (mid_Rlist l' a) f
   end.
 
 Lemma RList_P0 :
- forall (l:Rlist) (a:R),
-   pos_Rl (insert l a) 0 = a \/ pos_Rl (insert l a) 0 = pos_Rl l 0.
-intros; induction  l as [| r l Hrecl];
- [ left; reflexivity
- | simpl in |- *; case (Rle_dec r a); intro;
-    [ right; reflexivity | left; reflexivity ] ].
+  forall (l:Rlist) (a:R),
+    pos_Rl (insert l a) 0 = a \/ pos_Rl (insert l a) 0 = pos_Rl l 0.
+Proof.
+  intros; induction  l as [| r l Hrecl];
+    [ left; reflexivity
+      | simpl in |- *; case (Rle_dec r a); intro;
+        [ right; reflexivity | left; reflexivity ] ].
 Qed.
 
 Lemma RList_P1 :
- forall (l:Rlist) (a:R), ordered_Rlist l -> ordered_Rlist (insert l a).
-intros; induction  l as [| r l Hrecl].
-simpl in |- *; unfold ordered_Rlist in |- *; intros; simpl in H0;
- elim (lt_n_O _ H0).
-simpl in |- *; case (Rle_dec r a); intro.
-assert (H1 : ordered_Rlist l).
-unfold ordered_Rlist in |- *; unfold ordered_Rlist in H; intros;
- assert (H1 : (S i < pred (Rlength (cons r l)))%nat);
- [ simpl in |- *; replace (Rlength l) with (S (pred (Rlength l)));
-    [ apply lt_n_S; assumption
-    | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
-       intro; rewrite <- H1 in H0; simpl in H0; elim (lt_n_O _ H0) ]
- | apply (H _ H1) ].
-assert (H2 := Hrecl H1); unfold ordered_Rlist in |- *; intros;
- induction  i as [| i Hreci].
-simpl in |- *; assert (H3 := RList_P0 l a); elim H3; intro.
-rewrite H4; assumption.
-induction  l as [| r1 l Hrecl0];
- [ simpl in |- *; assumption
- | rewrite H4; apply (H 0%nat); simpl in |- *; apply lt_O_Sn ].
-simpl in |- *; apply H2; simpl in H0; apply lt_S_n;
- replace (S (pred (Rlength (insert l a)))) with (Rlength (insert l a));
- [ assumption
- | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
-    rewrite <- H3 in H0; elim (lt_n_O _ H0) ].
-unfold ordered_Rlist in |- *; intros; induction  i as [| i Hreci];
- [ simpl in |- *; auto with real
- | change (pos_Rl (cons r l) i <= pos_Rl (cons r l) (S i)) in |- *; apply H;
-    simpl in H0; simpl in |- *; apply (lt_S_n _ _ H0) ].
+  forall (l:Rlist) (a:R), ordered_Rlist l -> ordered_Rlist (insert l a).
+Proof.
+  intros; induction  l as [| r l Hrecl].
+  simpl in |- *; unfold ordered_Rlist in |- *; intros; simpl in H0;
+    elim (lt_n_O _ H0).
+  simpl in |- *; case (Rle_dec r a); intro.
+  assert (H1 : ordered_Rlist l).
+  unfold ordered_Rlist in |- *; unfold ordered_Rlist in H; intros;
+    assert (H1 : (S i < pred (Rlength (cons r l)))%nat);
+      [ simpl in |- *; replace (Rlength l) with (S (pred (Rlength l)));
+        [ apply lt_n_S; assumption
+          | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+            intro; rewrite <- H1 in H0; simpl in H0; elim (lt_n_O _ H0) ]
+        | apply (H _ H1) ].
+  assert (H2 := Hrecl H1); unfold ordered_Rlist in |- *; intros;
+    induction  i as [| i Hreci].
+  simpl in |- *; assert (H3 := RList_P0 l a); elim H3; intro.
+  rewrite H4; assumption.
+  induction  l as [| r1 l Hrecl0];
+    [ simpl in |- *; assumption
+      | rewrite H4; apply (H 0%nat); simpl in |- *; apply lt_O_Sn ].
+  simpl in |- *; apply H2; simpl in H0; apply lt_S_n;
+    replace (S (pred (Rlength (insert l a)))) with (Rlength (insert l a));
+    [ assumption
+      | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+        rewrite <- H3 in H0; elim (lt_n_O _ H0) ].
+  unfold ordered_Rlist in |- *; intros; induction  i as [| i Hreci];
+    [ simpl in |- *; auto with real
+      | change (pos_Rl (cons r l) i <= pos_Rl (cons r l) (S i)) in |- *; apply H;
+        simpl in H0; simpl in |- *; apply (lt_S_n _ _ H0) ].
 Qed.
 
 Lemma RList_P2 :
- forall l1 l2:Rlist, ordered_Rlist l2 -> ordered_Rlist (cons_ORlist l1 l2).
-simple induction l1;
- [ intros; simpl in |- *; apply H
- | intros; simpl in |- *; apply H; apply RList_P1; assumption ].
+  forall l1 l2:Rlist, ordered_Rlist l2 -> ordered_Rlist (cons_ORlist l1 l2).
+Proof.
+  simple induction l1;
+    [ intros; simpl in |- *; apply H
+      | intros; simpl in |- *; apply H; apply RList_P1; assumption ].
 Qed.
 
 Lemma RList_P3 :
- forall (l:Rlist) (x:R),
-   In x l <-> (exists i : nat, x = pos_Rl l i /\ (i < Rlength l)%nat).
-intros; split; intro;
- [ induction  l as [| r l Hrecl] | induction  l as [| r l Hrecl] ].
-elim H.
-elim H; intro;
- [ exists 0%nat; split; [ apply H0 | simpl in |- *; apply lt_O_Sn ]
- | elim (Hrecl H0); intros; elim H1; clear H1; intros; exists (S x0); split;
-    [ apply H1 | simpl in |- *; apply lt_n_S; assumption ] ].
-elim H; intros; elim H0; intros; elim (lt_n_O _ H2).
-simpl in |- *; elim H; intros; elim H0; clear H0; intros;
- induction  x0 as [| x0 Hrecx0];
- [ left; apply H0
- | right; apply Hrecl; exists x0; split;
-    [ apply H0 | simpl in H1; apply lt_S_n; assumption ] ].
+  forall (l:Rlist) (x:R),
+    In x l <-> (exists i : nat, x = pos_Rl l i /\ (i < Rlength l)%nat).
+Proof.
+  intros; split; intro;
+    [ induction  l as [| r l Hrecl] | induction  l as [| r l Hrecl] ].
+  elim H.
+  elim H; intro;
+    [ exists 0%nat; split; [ apply H0 | simpl in |- *; apply lt_O_Sn ]
+      | elim (Hrecl H0); intros; elim H1; clear H1; intros; exists (S x0); split;
+        [ apply H1 | simpl in |- *; apply lt_n_S; assumption ] ].
+  elim H; intros; elim H0; intros; elim (lt_n_O _ H2).
+  simpl in |- *; elim H; intros; elim H0; clear H0; intros;
+    induction  x0 as [| x0 Hrecx0];
+      [ left; apply H0
+        | right; apply Hrecl; exists x0; split;
+          [ apply H0 | simpl in H1; apply lt_S_n; assumption ] ].
 Qed.
 
 Lemma RList_P4 :
- forall (l1:Rlist) (a:R), ordered_Rlist (cons a l1) -> ordered_Rlist l1.
-intros; unfold ordered_Rlist in |- *; intros; apply (H (S i)); simpl in |- *;
- replace (Rlength l1) with (S (pred (Rlength l1)));
- [ apply lt_n_S; assumption
- | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
-    intro; rewrite <- H1 in H0; elim (lt_n_O _ H0) ].
+  forall (l1:Rlist) (a:R), ordered_Rlist (cons a l1) -> ordered_Rlist l1.
+Proof.
+  intros; unfold ordered_Rlist in |- *; intros; apply (H (S i)); simpl in |- *;
+    replace (Rlength l1) with (S (pred (Rlength l1)));
+    [ apply lt_n_S; assumption
+      | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+        intro; rewrite <- H1 in H0; elim (lt_n_O _ H0) ].
 Qed.
 
 Lemma RList_P5 :
- forall (l:Rlist) (x:R), ordered_Rlist l -> In x l -> pos_Rl l 0 <= x.
-intros; induction  l as [| r l Hrecl];
- [ elim H0
- | simpl in |- *; elim H0; intro;
-    [ rewrite H1; right; reflexivity
-    | apply Rle_trans with (pos_Rl l 0);
-       [ apply (H 0%nat); simpl in |- *; induction  l as [| r0 l Hrecl0];
-          [ elim H1 | simpl in |- *; apply lt_O_Sn ]
-       | apply Hrecl; [ eapply RList_P4; apply H | assumption ] ] ] ].
+  forall (l:Rlist) (x:R), ordered_Rlist l -> In x l -> pos_Rl l 0 <= x.
+Proof.
+  intros; induction  l as [| r l Hrecl];
+    [ elim H0
+      | simpl in |- *; elim H0; intro;
+        [ rewrite H1; right; reflexivity
+          | apply Rle_trans with (pos_Rl l 0);
+            [ apply (H 0%nat); simpl in |- *; induction  l as [| r0 l Hrecl0];
+              [ elim H1 | simpl in |- *; apply lt_O_Sn ]
+              | apply Hrecl; [ eapply RList_P4; apply H | assumption ] ] ] ].
 Qed.
 
 Lemma RList_P6 :
- forall l:Rlist,
-   ordered_Rlist l <->
-   (forall i j:nat,
+  forall l:Rlist,
+    ordered_Rlist l <->
+    (forall i j:nat,
       (i <= j)%nat -> (j < Rlength l)%nat -> pos_Rl l i <= pos_Rl l j).
-simple induction l; split; intro.
-intros; right; reflexivity.
-unfold ordered_Rlist in |- *; intros; simpl in H0; elim (lt_n_O _ H0).
-intros; induction  i as [| i Hreci];
- [ induction  j as [| j Hrecj];
-    [ right; reflexivity
-    | simpl in |- *; apply Rle_trans with (pos_Rl r0 0);
-       [ apply (H0 0%nat); simpl in |- *; simpl in H2; apply neq_O_lt;
-          red in |- *; intro; rewrite <- H3 in H2;
-          assert (H4 := lt_S_n _ _ H2); elim (lt_n_O _ H4)
-       | elim H; intros; apply H3;
-          [ apply RList_P4 with r; assumption
-          | apply le_O_n
-          | simpl in H2; apply lt_S_n; assumption ] ] ]
- | induction  j as [| j Hrecj];
-    [ elim (le_Sn_O _ H1)
-    | simpl in |- *; elim H; intros; apply H3;
-       [ apply RList_P4 with r; assumption
-       | apply le_S_n; assumption
-       | simpl in H2; apply lt_S_n; assumption ] ] ].
-unfold ordered_Rlist in |- *; intros; apply H0;
- [ apply le_n_Sn | simpl in |- *; simpl in H1; apply lt_n_S; assumption ].
+Proof.
+  simple induction l; split; intro.
+  intros; right; reflexivity.
+  unfold ordered_Rlist in |- *; intros; simpl in H0; elim (lt_n_O _ H0).
+  intros; induction  i as [| i Hreci];
+    [ induction  j as [| j Hrecj];
+      [ right; reflexivity
+        | simpl in |- *; apply Rle_trans with (pos_Rl r0 0);
+          [ apply (H0 0%nat); simpl in |- *; simpl in H2; apply neq_O_lt;
+            red in |- *; intro; rewrite <- H3 in H2;
+              assert (H4 := lt_S_n _ _ H2); elim (lt_n_O _ H4)
+            | elim H; intros; apply H3;
+              [ apply RList_P4 with r; assumption
+                | apply le_O_n
+                | simpl in H2; apply lt_S_n; assumption ] ] ]
+      | induction  j as [| j Hrecj];
+        [ elim (le_Sn_O _ H1)
+          | simpl in |- *; elim H; intros; apply H3;
+            [ apply RList_P4 with r; assumption
+              | apply le_S_n; assumption
+              | simpl in H2; apply lt_S_n; assumption ] ] ].
+  unfold ordered_Rlist in |- *; intros; apply H0;
+    [ apply le_n_Sn | simpl in |- *; simpl in H1; apply lt_n_S; assumption ].
 Qed.
 
 Lemma RList_P7 :
- forall (l:Rlist) (x:R),
-   ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (Rlength l)).
-intros; assert (H1 := RList_P6 l); elim H1; intros H2 _; assert (H3 := H2 H);
- clear H1 H2; assert (H1 := RList_P3 l x); elim H1; 
- clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; 
- intros; elim H4; clear H4; intros; rewrite H4;
- assert (H6 : Rlength l = S (pred (Rlength l))).
-apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
- rewrite <- H6 in H5; elim (lt_n_O _ H5).
-apply H3;
- [ rewrite H6 in H5; apply lt_n_Sm_le; assumption
- | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H7 in H5;
-    elim (lt_n_O _ H5) ].
+  forall (l:Rlist) (x:R),
+    ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (Rlength l)).
+Proof.
+  intros; assert (H1 := RList_P6 l); elim H1; intros H2 _; assert (H3 := H2 H);
+    clear H1 H2; assert (H1 := RList_P3 l x); elim H1; 
+      clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; 
+        intros; elim H4; clear H4; intros; rewrite H4;
+          assert (H6 : Rlength l = S (pred (Rlength l))).
+  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H6 in H5; elim (lt_n_O _ H5).
+  apply H3;
+    [ rewrite H6 in H5; apply lt_n_Sm_le; assumption
+      | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H7 in H5;
+        elim (lt_n_O _ H5) ].
 Qed.
 
 Lemma RList_P8 :
- forall (l:Rlist) (a x:R), In x (insert l a) <-> x = a \/ In x l.
-simple induction l.
-intros; split; intro; simpl in H; apply H.
-intros; split; intro;
- [ simpl in H0; generalize H0; case (Rle_dec r a); intros;
-    [ simpl in H1; elim H1; intro;
-       [ right; left; assumption
-       | elim (H a x); intros; elim (H3 H2); intro;
-          [ left; assumption | right; right; assumption ] ]
-    | simpl in H1; decompose [or] H1;
-       [ left; assumption
-       | right; left; assumption
-       | right; right; assumption ] ]
- | simpl in |- *; case (Rle_dec r a); intro;
-    [ simpl in H0; decompose [or] H0;
-       [ right; elim (H a x); intros; apply H3; left
-       | left
-       | right; elim (H a x); intros; apply H3; right ]
-    | simpl in H0; decompose [or] H0; [ left | right; left | right; right ] ];
-    assumption ].
+  forall (l:Rlist) (a x:R), In x (insert l a) <-> x = a \/ In x l.
+Proof.
+  simple induction l.
+  intros; split; intro; simpl in H; apply H.
+  intros; split; intro;
+    [ simpl in H0; generalize H0; case (Rle_dec r a); intros;
+      [ simpl in H1; elim H1; intro;
+        [ right; left; assumption
+          | elim (H a x); intros; elim (H3 H2); intro;
+            [ left; assumption | right; right; assumption ] ]
+        | simpl in H1; decompose [or] H1;
+          [ left; assumption
+            | right; left; assumption
+            | right; right; assumption ] ]
+      | simpl in |- *; case (Rle_dec r a); intro;
+        [ simpl in H0; decompose [or] H0;
+          [ right; elim (H a x); intros; apply H3; left
+            | left
+            | right; elim (H a x); intros; apply H3; right ]
+          | simpl in H0; decompose [or] H0; [ left | right; left | right; right ] ];
+        assumption ].
 Qed.
 
 Lemma RList_P9 :
- forall (l1 l2:Rlist) (x:R), In x (cons_ORlist l1 l2) <-> In x l1 \/ In x l2.
-simple induction l1.
-intros; split; intro;
- [ simpl in H; right; assumption
- | simpl in |- *; elim H; intro; [ elim H0 | assumption ] ].
-intros; split.
-simpl in |- *; intros; elim (H (insert l2 r) x); intros; assert (H3 := H1 H0);
- elim H3; intro;
- [ left; right; assumption
- | elim (RList_P8 l2 r x); intros H5 _; assert (H6 := H5 H4); elim H6; intro;
-    [ left; left; assumption | right; assumption ] ].
-intro; simpl in |- *; elim (H (insert l2 r) x); intros _ H1; apply H1;
- elim H0; intro;
- [ elim H2; intro;
-    [ right; elim (RList_P8 l2 r x); intros _ H4; apply H4; left; assumption
-    | left; assumption ]
- | right; elim (RList_P8 l2 r x); intros _ H3; apply H3; right; assumption ].
+  forall (l1 l2:Rlist) (x:R), In x (cons_ORlist l1 l2) <-> In x l1 \/ In x l2.
+Proof.
+  simple induction l1.
+  intros; split; intro;
+    [ simpl in H; right; assumption
+      | simpl in |- *; elim H; intro; [ elim H0 | assumption ] ].
+  intros; split.
+  simpl in |- *; intros; elim (H (insert l2 r) x); intros; assert (H3 := H1 H0);
+    elim H3; intro;
+      [ left; right; assumption
+        | elim (RList_P8 l2 r x); intros H5 _; assert (H6 := H5 H4); elim H6; intro;
+          [ left; left; assumption | right; assumption ] ].
+  intro; simpl in |- *; elim (H (insert l2 r) x); intros _ H1; apply H1;
+    elim H0; intro;
+      [ elim H2; intro;
+        [ right; elim (RList_P8 l2 r x); intros _ H4; apply H4; left; assumption
+          | left; assumption ]
+        | right; elim (RList_P8 l2 r x); intros _ H3; apply H3; right; assumption ].
 Qed.
 
 Lemma RList_P10 :
- forall (l:Rlist) (a:R), Rlength (insert l a) = S (Rlength l).
-intros; induction  l as [| r l Hrecl];
- [ reflexivity
- | simpl in |- *; case (Rle_dec r a); intro;
-    [ simpl in |- *; rewrite Hrecl; reflexivity | reflexivity ] ].
+  forall (l:Rlist) (a:R), Rlength (insert l a) = S (Rlength l).
+Proof.
+  intros; induction  l as [| r l Hrecl];
+    [ reflexivity
+      | simpl in |- *; case (Rle_dec r a); intro;
+        [ simpl in |- *; rewrite Hrecl; reflexivity | reflexivity ] ].
 Qed.
 
 Lemma RList_P11 :
- forall l1 l2:Rlist,
-   Rlength (cons_ORlist l1 l2) = (Rlength l1 + Rlength l2)%nat.
-simple induction l1;
- [ intro; reflexivity
- | intros; simpl in |- *; rewrite (H (insert l2 r)); rewrite RList_P10;
-    apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; 
-    rewrite S_INR; ring ].
+  forall l1 l2:Rlist,
+    Rlength (cons_ORlist l1 l2) = (Rlength l1 + Rlength l2)%nat.
+Proof.
+  simple induction l1;
+    [ intro; reflexivity
+      | intros; simpl in |- *; rewrite (H (insert l2 r)); rewrite RList_P10;
+        apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; 
+          rewrite S_INR; ring ].
 Qed.
 
 Lemma RList_P12 :
- forall (l:Rlist) (i:nat) (f:R -> R),
-   (i < Rlength l)%nat -> pos_Rl (app_Rlist l f) i = f (pos_Rl l i).
-simple induction l;
- [ intros; elim (lt_n_O _ H)
- | intros; induction  i as [| i Hreci];
-    [ reflexivity | simpl in |- *; apply H; apply lt_S_n; apply H0 ] ].
+  forall (l:Rlist) (i:nat) (f:R -> R),
+    (i < Rlength l)%nat -> pos_Rl (app_Rlist l f) i = f (pos_Rl l i).
+Proof.
+  simple induction l;
+    [ intros; elim (lt_n_O _ H)
+      | intros; induction  i as [| i Hreci];
+        [ reflexivity | simpl in |- *; apply H; apply lt_S_n; apply H0 ] ].
 Qed.
 
 Lemma RList_P13 :
- forall (l:Rlist) (i:nat) (a:R),
-   (i < pred (Rlength l))%nat ->
-   pos_Rl (mid_Rlist l a) (S i) = (pos_Rl l i + pos_Rl l (S i)) / 2.
-simple induction l.
-intros; simpl in H; elim (lt_n_O _ H).
-simple induction r0.
-intros; simpl in H0; elim (lt_n_O _ H0).
-intros; simpl in H1; induction  i as [| i Hreci].
-reflexivity.
-change
-  (pos_Rl (mid_Rlist (cons r1 r2) r) (S i) =
-   (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) 
- in |- *; apply H0; simpl in |- *; apply lt_S_n; assumption.
+  forall (l:Rlist) (i:nat) (a:R),
+    (i < pred (Rlength l))%nat ->
+    pos_Rl (mid_Rlist l a) (S i) = (pos_Rl l i + pos_Rl l (S i)) / 2.
+Proof.
+  simple induction l.
+  intros; simpl in H; elim (lt_n_O _ H).
+  simple induction r0.
+  intros; simpl in H0; elim (lt_n_O _ H0).
+  intros; simpl in H1; induction  i as [| i Hreci].
+  reflexivity.
+  change
+    (pos_Rl (mid_Rlist (cons r1 r2) r) (S i) =
+      (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) 
+    in |- *; apply H0; simpl in |- *; apply lt_S_n; assumption.
 Qed.
 
 Lemma RList_P14 : forall (l:Rlist) (a:R), Rlength (mid_Rlist l a) = Rlength l.
-simple induction l; intros;
- [ reflexivity | simpl in |- *; rewrite (H r); reflexivity ].
+Proof.
+  simple induction l; intros;
+    [ reflexivity | simpl in |- *; rewrite (H r); reflexivity ].
 Qed.
 
 Lemma RList_P15 :
- forall l1 l2:Rlist,
-   ordered_Rlist l1 ->
-   ordered_Rlist l2 ->
-   pos_Rl l1 0 = pos_Rl l2 0 -> pos_Rl (cons_ORlist l1 l2) 0 = pos_Rl l1 0.
-intros; apply Rle_antisym.
-induction  l1 as [| r l1 Hrecl1];
- [ simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption
- | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) 0)); intros;
-    assert
-     (H4 :
-      In (pos_Rl (cons r l1) 0) (cons r l1) \/ In (pos_Rl (cons r l1) 0) l2);
-    [ left; left; reflexivity
-    | assert (H5 := H3 H4); apply RList_P5;
-       [ apply RList_P2; assumption | assumption ] ] ].
-induction  l1 as [| r l1 Hrecl1];
- [ simpl in |- *; simpl in H1; right; assumption
- | assert
-    (H2 :
-     In (pos_Rl (cons_ORlist (cons r l1) l2) 0) (cons_ORlist (cons r l1) l2));
-    [ elim
-       (RList_P3 (cons_ORlist (cons r l1) l2)
-          (pos_Rl (cons_ORlist (cons r l1) l2) 0)); 
-       intros; apply H3; exists 0%nat; split;
-       [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]
-    | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) 0));
-       intros; assert (H5 := H3 H2); elim H5; intro;
-       [ apply RList_P5; assumption
-       | rewrite H1; apply RList_P5; assumption ] ] ].
+  forall l1 l2:Rlist,
+    ordered_Rlist l1 ->
+    ordered_Rlist l2 ->
+    pos_Rl l1 0 = pos_Rl l2 0 -> pos_Rl (cons_ORlist l1 l2) 0 = pos_Rl l1 0.
+Proof.
+  intros; apply Rle_antisym.
+  induction  l1 as [| r l1 Hrecl1];
+    [ simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption
+      | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) 0)); intros;
+        assert
+          (H4 :
+            In (pos_Rl (cons r l1) 0) (cons r l1) \/ In (pos_Rl (cons r l1) 0) l2);
+          [ left; left; reflexivity
+            | assert (H5 := H3 H4); apply RList_P5;
+              [ apply RList_P2; assumption | assumption ] ] ].
+  induction  l1 as [| r l1 Hrecl1];
+    [ simpl in |- *; simpl in H1; right; assumption
+      | assert
+        (H2 :
+          In (pos_Rl (cons_ORlist (cons r l1) l2) 0) (cons_ORlist (cons r l1) l2));
+        [ elim
+          (RList_P3 (cons_ORlist (cons r l1) l2)
+            (pos_Rl (cons_ORlist (cons r l1) l2) 0)); 
+          intros; apply H3; exists 0%nat; split;
+            [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]
+          | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) 0));
+            intros; assert (H5 := H3 H2); elim H5; intro;
+              [ apply RList_P5; assumption
+                | rewrite H1; apply RList_P5; assumption ] ] ].
 Qed.
 
 Lemma RList_P16 :
- forall l1 l2:Rlist,
-   ordered_Rlist l1 ->
-   ordered_Rlist l2 ->
-   pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 (pred (Rlength l2)) ->
-   pos_Rl (cons_ORlist l1 l2) (pred (Rlength (cons_ORlist l1 l2))) =
-   pos_Rl l1 (pred (Rlength l1)).
-intros; apply Rle_antisym.
-induction  l1 as [| r l1 Hrecl1].
-simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption. 
-assert
- (H2 :
-  In
-    (pos_Rl (cons_ORlist (cons r l1) l2)
-       (pred (Rlength (cons_ORlist (cons r l1) l2))))
-    (cons_ORlist (cons r l1) l2));
- [ elim
-    (RList_P3 (cons_ORlist (cons r l1) l2)
-       (pos_Rl (cons_ORlist (cons r l1) l2)
-          (pred (Rlength (cons_ORlist (cons r l1) l2))))); 
-    intros; apply H3; exists (pred (Rlength (cons_ORlist (cons r l1) l2)));
-    split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]
- | elim
-    (RList_P9 (cons r l1) l2
-       (pos_Rl (cons_ORlist (cons r l1) l2)
+  forall l1 l2:Rlist,
+    ordered_Rlist l1 ->
+    ordered_Rlist l2 ->
+    pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 (pred (Rlength l2)) ->
+    pos_Rl (cons_ORlist l1 l2) (pred (Rlength (cons_ORlist l1 l2))) =
+    pos_Rl l1 (pred (Rlength l1)).
+Proof.
+  intros; apply Rle_antisym.
+  induction  l1 as [| r l1 Hrecl1].
+  simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption. 
+  assert
+    (H2 :
+      In
+      (pos_Rl (cons_ORlist (cons r l1) l2)
+        (pred (Rlength (cons_ORlist (cons r l1) l2))))
+      (cons_ORlist (cons r l1) l2));
+    [ elim
+      (RList_P3 (cons_ORlist (cons r l1) l2)
+        (pos_Rl (cons_ORlist (cons r l1) l2)
           (pred (Rlength (cons_ORlist (cons r l1) l2))))); 
-    intros; assert (H5 := H3 H2); elim H5; intro;
-    [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ].
-induction  l1 as [| r l1 Hrecl1].
-simpl in |- *; simpl in H1; right; assumption.
-elim
- (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))));
- intros;
- assert
-  (H4 :
-   In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1) \/
-   In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2);
- [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)) in |- *;
-    elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); 
-    intros; apply H5; exists (Rlength l1); split;
-    [ reflexivity | simpl in |- *; apply lt_n_Sn ]
- | assert (H5 := H3 H4); apply RList_P7;
-    [ apply RList_P2; assumption
-    | elim
-       (RList_P9 (cons r l1) l2
-          (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); 
-       intros; apply H7; left;
-       elim
-        (RList_P3 (cons r l1)
-           (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); 
-       intros; apply H9; exists (pred (Rlength (cons r l1))); 
-       split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] ] ].
+      intros; apply H3; exists (pred (Rlength (cons_ORlist (cons r l1) l2)));
+        split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]
+      | elim
+        (RList_P9 (cons r l1) l2
+          (pos_Rl (cons_ORlist (cons r l1) l2)
+            (pred (Rlength (cons_ORlist (cons r l1) l2))))); 
+        intros; assert (H5 := H3 H2); elim H5; intro;
+          [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ].
+  induction  l1 as [| r l1 Hrecl1].
+  simpl in |- *; simpl in H1; right; assumption.
+  elim
+    (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))));
+    intros;
+      assert
+        (H4 :
+          In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1) \/
+          In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2);
+        [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)) in |- *;
+          elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); 
+            intros; apply H5; exists (Rlength l1); split;
+              [ reflexivity | simpl in |- *; apply lt_n_Sn ]
+          | assert (H5 := H3 H4); apply RList_P7;
+            [ apply RList_P2; assumption
+              | elim
+                (RList_P9 (cons r l1) l2
+                  (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); 
+                intros; apply H7; left;
+                  elim
+                    (RList_P3 (cons r l1)
+                      (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); 
+                    intros; apply H9; exists (pred (Rlength (cons r l1))); 
+                      split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] ] ].
 Qed.
 
 Lemma RList_P17 :
- forall (l1:Rlist) (x:R) (i:nat),
-   ordered_Rlist l1 ->
-   In x l1 ->
-   pos_Rl l1 i < x -> (i < pred (Rlength l1))%nat -> pos_Rl l1 (S i) <= x.
-simple induction l1.
-intros; elim H0.
-intros; induction  i as [| i Hreci].
-simpl in |- *; elim H1; intro;
- [ simpl in H2; rewrite H4 in H2; elim (Rlt_irrefl _ H2)
- | apply RList_P5; [ apply RList_P4 with r; assumption | assumption ] ].
-simpl in |- *; simpl in H2; elim H1; intro.
-rewrite H4 in H2; assert (H5 : r <= pos_Rl r0 i);
- [ apply Rle_trans with (pos_Rl r0 0);
-    [ apply (H0 0%nat); simpl in |- *; simpl in H3; apply neq_O_lt;
-       red in |- *; intro; rewrite <- H5 in H3; elim (lt_n_O _ H3)
-    | elim (RList_P6 r0); intros; apply H5;
-       [ apply RList_P4 with r; assumption
-       | apply le_O_n
-       | simpl in H3; apply lt_S_n; apply lt_trans with (Rlength r0);
-          [ apply H3 | apply lt_n_Sn ] ] ]
- | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H2)) ].
-apply H; try assumption;
- [ apply RList_P4 with r; assumption
- | simpl in H3; apply lt_S_n;
-    replace (S (pred (Rlength r0))) with (Rlength r0);
-    [ apply H3
-    | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
-       rewrite <- H5 in H3; elim (lt_n_O _ H3) ] ].
+  forall (l1:Rlist) (x:R) (i:nat),
+    ordered_Rlist l1 ->
+    In x l1 ->
+    pos_Rl l1 i < x -> (i < pred (Rlength l1))%nat -> pos_Rl l1 (S i) <= x.
+Proof.
+  simple induction l1.
+  intros; elim H0.
+  intros; induction  i as [| i Hreci].
+  simpl in |- *; elim H1; intro;
+    [ simpl in H2; rewrite H4 in H2; elim (Rlt_irrefl _ H2)
+      | apply RList_P5; [ apply RList_P4 with r; assumption | assumption ] ].
+  simpl in |- *; simpl in H2; elim H1; intro.
+  rewrite H4 in H2; assert (H5 : r <= pos_Rl r0 i);
+    [ apply Rle_trans with (pos_Rl r0 0);
+      [ apply (H0 0%nat); simpl in |- *; simpl in H3; apply neq_O_lt;
+        red in |- *; intro; rewrite <- H5 in H3; elim (lt_n_O _ H3)
+        | elim (RList_P6 r0); intros; apply H5;
+          [ apply RList_P4 with r; assumption
+            | apply le_O_n
+            | simpl in H3; apply lt_S_n; apply lt_trans with (Rlength r0);
+              [ apply H3 | apply lt_n_Sn ] ] ]
+      | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H2)) ].
+  apply H; try assumption;
+    [ apply RList_P4 with r; assumption
+      | simpl in H3; apply lt_S_n;
+        replace (S (pred (Rlength r0))) with (Rlength r0);
+        [ apply H3
+          | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+            rewrite <- H5 in H3; elim (lt_n_O _ H3) ] ].
 Qed.
 
 Lemma RList_P18 :
- forall (l:Rlist) (f:R -> R), Rlength (app_Rlist l f) = Rlength l.
-simple induction l; intros;
- [ reflexivity | simpl in |- *; rewrite H; reflexivity ].
+  forall (l:Rlist) (f:R -> R), Rlength (app_Rlist l f) = Rlength l.
+Proof.
+  simple induction l; intros;
+    [ reflexivity | simpl in |- *; rewrite H; reflexivity ].
 Qed.
 
 Lemma RList_P19 :
- forall l:Rlist,
-   l <> nil ->  exists r : R, (exists r0 : Rlist, l = cons r r0).
-intros; induction  l as [| r l Hrecl];
- [ elim H; reflexivity | exists r; exists l; reflexivity ].
+  forall l:Rlist,
+    l <> nil ->  exists r : R, (exists r0 : Rlist, l = cons r r0).
+Proof.
+  intros; induction  l as [| r l Hrecl];
+    [ elim H; reflexivity | exists r; exists l; reflexivity ].
 Qed.
 
 Lemma RList_P20 :
- forall l:Rlist,
-   (2 <= Rlength l)%nat ->
+  forall l:Rlist,
+    (2 <= Rlength l)%nat ->
     exists r : R,
-     (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). 
-intros; induction  l as [| r l Hrecl];
- [ simpl in H; elim (le_Sn_O _ H)
- | induction  l as [| r0 l Hrecl0];
-    [ simpl in H; elim (le_Sn_O _ (le_S_n _ _ H))
-    | exists r; exists r0; exists l; reflexivity ] ].
+      (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). 
+Proof.
+  intros; induction  l as [| r l Hrecl];
+    [ simpl in H; elim (le_Sn_O _ H)
+      | induction  l as [| r0 l Hrecl0];
+        [ simpl in H; elim (le_Sn_O _ (le_S_n _ _ H))
+          | exists r; exists r0; exists l; reflexivity ] ].
 Qed.
 
 Lemma RList_P21 : forall l l':Rlist, l = l' -> Rtail l = Rtail l'.
-intros; rewrite H; reflexivity.
+Proof.
+  intros; rewrite H; reflexivity.
 Qed.
 
 Lemma RList_P22 :
- forall l1 l2:Rlist, l1 <> nil -> pos_Rl (cons_Rlist l1 l2) 0 = pos_Rl l1 0.
-simple induction l1; [ intros; elim H; reflexivity | intros; reflexivity ].
+  forall l1 l2:Rlist, l1 <> nil -> pos_Rl (cons_Rlist l1 l2) 0 = pos_Rl l1 0.
+Proof.
+  simple induction l1; [ intros; elim H; reflexivity | intros; reflexivity ].
 Qed.
 
 Lemma RList_P23 :
- forall l1 l2:Rlist,
-   Rlength (cons_Rlist l1 l2) = (Rlength l1 + Rlength l2)%nat.
-simple induction l1;
- [ intro; reflexivity | intros; simpl in |- *; rewrite H; reflexivity ].
+  forall l1 l2:Rlist,
+    Rlength (cons_Rlist l1 l2) = (Rlength l1 + Rlength l2)%nat.
+Proof.
+  simple induction l1;
+    [ intro; reflexivity | intros; simpl in |- *; rewrite H; reflexivity ].
 Qed.
 
 Lemma RList_P24 :
- forall l1 l2:Rlist,
-   l2 <> nil ->
-   pos_Rl (cons_Rlist l1 l2) (pred (Rlength (cons_Rlist l1 l2))) =
-   pos_Rl l2 (pred (Rlength l2)).
-simple induction l1.
-intros; reflexivity.
-intros; rewrite <- (H l2 H0); induction  l2 as [| r1 l2 Hrecl2].
-elim H0; reflexivity.
-do 2 rewrite RList_P23;
- replace (Rlength (cons r r0) + Rlength (cons r1 l2))%nat with
-  (S (S (Rlength r0 + Rlength l2)));
- [ replace (Rlength r0 + Rlength (cons r1 l2))%nat with
-    (S (Rlength r0 + Rlength l2));
-    [ reflexivity
-    | simpl in |- *; apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR;
-       rewrite S_INR; ring ]
- | simpl in |- *; apply INR_eq; do 3 rewrite S_INR; do 2 rewrite plus_INR;
-    rewrite S_INR; ring ].
+  forall l1 l2:Rlist,
+    l2 <> nil ->
+    pos_Rl (cons_Rlist l1 l2) (pred (Rlength (cons_Rlist l1 l2))) =
+    pos_Rl l2 (pred (Rlength l2)).
+Proof.
+  simple induction l1.
+  intros; reflexivity.
+  intros; rewrite <- (H l2 H0); induction  l2 as [| r1 l2 Hrecl2].
+  elim H0; reflexivity.
+  do 2 rewrite RList_P23;
+    replace (Rlength (cons r r0) + Rlength (cons r1 l2))%nat with
+    (S (S (Rlength r0 + Rlength l2)));
+    [ replace (Rlength r0 + Rlength (cons r1 l2))%nat with
+      (S (Rlength r0 + Rlength l2));
+      [ reflexivity
+        | simpl in |- *; apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR;
+          rewrite S_INR; ring ]
+      | simpl in |- *; apply INR_eq; do 3 rewrite S_INR; do 2 rewrite plus_INR;
+        rewrite S_INR; ring ].
 Qed.
 
 Lemma RList_P25 :
- forall l1 l2:Rlist,
-   ordered_Rlist l1 ->
-   ordered_Rlist l2 ->
-   pos_Rl l1 (pred (Rlength l1)) <= pos_Rl l2 0 ->
-   ordered_Rlist (cons_Rlist l1 l2).
-simple induction l1.
-intros; simpl in |- *; assumption.
-simple induction r0.
-intros; simpl in |- *; simpl in H2; unfold ordered_Rlist in |- *; intros;
- simpl in H3.
-induction  i as [| i Hreci].
-simpl in |- *; assumption.
-change (pos_Rl l2 i <= pos_Rl l2 (S i)) in |- *; apply (H1 i); apply lt_S_n;
- replace (S (pred (Rlength l2))) with (Rlength l2);
- [ assumption
- | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
-    rewrite <- H4 in H3; elim (lt_n_O _ H3) ].
-intros; clear H; assert (H : ordered_Rlist (cons_Rlist (cons r1 r2) l2)).
-apply H0; try assumption.
-apply RList_P4 with r; assumption.
-unfold ordered_Rlist in |- *; intros; simpl in H4;
- induction  i as [| i Hreci].
-simpl in |- *; apply (H1 0%nat); simpl in |- *; apply lt_O_Sn.
-change
-  (pos_Rl (cons_Rlist (cons r1 r2) l2) i <=
-   pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *; 
- apply (H i); simpl in |- *; apply lt_S_n; assumption.
+  forall l1 l2:Rlist,
+    ordered_Rlist l1 ->
+    ordered_Rlist l2 ->
+    pos_Rl l1 (pred (Rlength l1)) <= pos_Rl l2 0 ->
+    ordered_Rlist (cons_Rlist l1 l2).
+Proof.
+  simple induction l1.
+  intros; simpl in |- *; assumption.
+  simple induction r0.
+  intros; simpl in |- *; simpl in H2; unfold ordered_Rlist in |- *; intros;
+    simpl in H3.
+  induction  i as [| i Hreci].
+  simpl in |- *; assumption.
+  change (pos_Rl l2 i <= pos_Rl l2 (S i)) in |- *; apply (H1 i); apply lt_S_n;
+    replace (S (pred (Rlength l2))) with (Rlength l2);
+    [ assumption
+      | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+        rewrite <- H4 in H3; elim (lt_n_O _ H3) ].
+  intros; clear H; assert (H : ordered_Rlist (cons_Rlist (cons r1 r2) l2)).
+  apply H0; try assumption.
+  apply RList_P4 with r; assumption.
+  unfold ordered_Rlist in |- *; intros; simpl in H4;
+    induction  i as [| i Hreci].
+  simpl in |- *; apply (H1 0%nat); simpl in |- *; apply lt_O_Sn.
+  change
+    (pos_Rl (cons_Rlist (cons r1 r2) l2) i <=
+      pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *; 
+    apply (H i); simpl in |- *; apply lt_S_n; assumption.
 Qed.
 
 Lemma RList_P26 :
- forall (l1 l2:Rlist) (i:nat),
-   (i < Rlength l1)%nat -> pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i.
-simple induction l1.
-intros; elim (lt_n_O _ H).
-intros; induction  i as [| i Hreci].
-apply RList_P22; discriminate.
-apply (H l2 i); simpl in H0; apply lt_S_n; assumption.
+  forall (l1 l2:Rlist) (i:nat),
+    (i < Rlength l1)%nat -> pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i.
+Proof.
+  simple induction l1.
+  intros; elim (lt_n_O _ H).
+  intros; induction  i as [| i Hreci].
+  apply RList_P22; discriminate.
+  apply (H l2 i); simpl in H0; apply lt_S_n; assumption.
 Qed.
 
 Lemma RList_P27 :
- forall l1 l2 l3:Rlist,
-   cons_Rlist l1 (cons_Rlist l2 l3) = cons_Rlist (cons_Rlist l1 l2) l3.
-simple induction l1; intros;
- [ reflexivity | simpl in |- *; rewrite (H l2 l3); reflexivity ].
+  forall l1 l2 l3:Rlist,
+    cons_Rlist l1 (cons_Rlist l2 l3) = cons_Rlist (cons_Rlist l1 l2) l3.
+Proof.
+  simple induction l1; intros;
+    [ reflexivity | simpl in |- *; rewrite (H l2 l3); reflexivity ].
 Qed.
 
 Lemma RList_P28 : forall l:Rlist, cons_Rlist l nil = l.
-simple induction l;
- [ reflexivity | intros; simpl in |- *; rewrite H; reflexivity ].
+Proof.
+  simple induction l;
+    [ reflexivity | intros; simpl in |- *; rewrite H; reflexivity ].
 Qed.
 
 Lemma RList_P29 :
- forall (l2 l1:Rlist) (i:nat),
-   (Rlength l1 <= i)%nat ->
-   (i < Rlength (cons_Rlist l1 l2))%nat ->
-   pos_Rl (cons_Rlist l1 l2) i = pos_Rl l2 (i - Rlength l1).
-simple induction l2.
-intros; rewrite RList_P28 in H0; elim (lt_irrefl _ (le_lt_trans _ _ _ H H0)).
-intros;
- replace (cons_Rlist l1 (cons r r0)) with
-  (cons_Rlist (cons_Rlist l1 (cons r nil)) r0).
-inversion H0.
-rewrite <- minus_n_n; simpl in |- *; rewrite RList_P26.
-clear l2 r0 H i H0 H1 H2; induction  l1 as [| r0 l1 Hrecl1].
-reflexivity.
-simpl in |- *; assumption.
-rewrite RList_P23; rewrite plus_comm; simpl in |- *; apply lt_n_Sn.
-replace (S m - Rlength l1)%nat with (S (S m - S (Rlength l1))).
-rewrite H3; simpl in |- *;
- replace (S (Rlength l1)) with (Rlength (cons_Rlist l1 (cons r nil))).
-apply (H (cons_Rlist l1 (cons r nil)) i).
-rewrite RList_P23; rewrite plus_comm; simpl in |- *; rewrite <- H3;
- apply le_n_S; assumption.
-repeat rewrite RList_P23; simpl in |- *; rewrite RList_P23 in H1;
- rewrite plus_comm in H1; simpl in H1; rewrite (plus_comm (Rlength l1));
- simpl in |- *; rewrite plus_comm; apply H1.
-rewrite RList_P23; rewrite plus_comm; reflexivity.
-change (S (m - Rlength l1) = (S m - Rlength l1)%nat) in |- *;
- apply minus_Sn_m; assumption.
-replace (cons r r0) with (cons_Rlist (cons r nil) r0);
- [ symmetry  in |- *; apply RList_P27 | reflexivity ].
+  forall (l2 l1:Rlist) (i:nat),
+    (Rlength l1 <= i)%nat ->
+    (i < Rlength (cons_Rlist l1 l2))%nat ->
+    pos_Rl (cons_Rlist l1 l2) i = pos_Rl l2 (i - Rlength l1).
+Proof.
+  simple induction l2.
+  intros; rewrite RList_P28 in H0; elim (lt_irrefl _ (le_lt_trans _ _ _ H H0)).
+  intros;
+    replace (cons_Rlist l1 (cons r r0)) with
+    (cons_Rlist (cons_Rlist l1 (cons r nil)) r0).
+  inversion H0.
+  rewrite <- minus_n_n; simpl in |- *; rewrite RList_P26.
+  clear l2 r0 H i H0 H1 H2; induction  l1 as [| r0 l1 Hrecl1].
+  reflexivity.
+  simpl in |- *; assumption.
+  rewrite RList_P23; rewrite plus_comm; simpl in |- *; apply lt_n_Sn.
+  replace (S m - Rlength l1)%nat with (S (S m - S (Rlength l1))).
+  rewrite H3; simpl in |- *;
+    replace (S (Rlength l1)) with (Rlength (cons_Rlist l1 (cons r nil))).
+  apply (H (cons_Rlist l1 (cons r nil)) i).
+  rewrite RList_P23; rewrite plus_comm; simpl in |- *; rewrite <- H3;
+    apply le_n_S; assumption.
+  repeat rewrite RList_P23; simpl in |- *; rewrite RList_P23 in H1;
+    rewrite plus_comm in H1; simpl in H1; rewrite (plus_comm (Rlength l1));
+      simpl in |- *; rewrite plus_comm; apply H1.
+  rewrite RList_P23; rewrite plus_comm; reflexivity.
+  change (S (m - Rlength l1) = (S m - Rlength l1)%nat) in |- *;
+    apply minus_Sn_m; assumption.
+  replace (cons r r0) with (cons_Rlist (cons r nil) r0);
+  [ symmetry  in |- *; apply RList_P27 | reflexivity ].
 Qed.
diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v
index 289b1921..82d7bebd 100644
--- a/theories/Reals/R_Ifp.v
+++ b/theories/Reals/R_Ifp.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_Ifp.v,v 1.14.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: R_Ifp.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (**********************************************************)
 (** Complements for the reals.Integer and fractional part *)
@@ -18,7 +18,7 @@ Require Import Omega.
 Open Local Scope R_scope.
 
 (*********************************************************)
-(**      Fractional part                                 *)
+(** *    Fractional part                                 *)
 (*********************************************************)
 
 (**********)
@@ -29,517 +29,534 @@ Definition frac_part (r:R) : R := r - IZR (Int_part r).
 
 (**********)
 Lemma tech_up : forall (r:R) (z:Z), r < IZR z -> IZR z <= r + 1 -> z = up r.
-intros; generalize (archimed r); intro; elim H1; intros; clear H1;
- unfold Rgt in H2; unfold Rminus in H3;
- generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3); 
- intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1;
- rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1;
- rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r))); 
- intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r));
- auto with zarith real.
+Proof.
+  intros; generalize (archimed r); intro; elim H1; intros; clear H1;
+    unfold Rgt in H2; unfold Rminus in H3;
+      generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3); 
+        intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1;
+          rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1;
+            rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r))); 
+              intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r));
+                auto with zarith real.
 Qed.
 
 (**********)
 Lemma up_tech :
- forall (r:R) (z:Z), IZR z <= r -> r < IZR (z + 1) -> (z + 1)%Z = up r.
-intros; generalize (Rplus_le_compat_l 1 (IZR z) r H); intro; clear H;
- rewrite (Rplus_comm 1 (IZR z)) in H1; rewrite (Rplus_comm 1 r) in H1;
- cut (1 = IZR 1); auto with zarith real.
-intro; generalize H1; pattern 1 at 1 in |- *; rewrite H; intro; clear H H1;
- rewrite <- (plus_IZR z 1) in H2; apply (tech_up r (z + 1));
- auto with zarith real.
+  forall (r:R) (z:Z), IZR z <= r -> r < IZR (z + 1) -> (z + 1)%Z = up r.
+Proof.
+  intros; generalize (Rplus_le_compat_l 1 (IZR z) r H); intro; clear H;
+    rewrite (Rplus_comm 1 (IZR z)) in H1; rewrite (Rplus_comm 1 r) in H1;
+      cut (1 = IZR 1); auto with zarith real.
+  intro; generalize H1; pattern 1 at 1 in |- *; rewrite H; intro; clear H H1;
+    rewrite <- (plus_IZR z 1) in H2; apply (tech_up r (z + 1));
+      auto with zarith real.
 Qed.
 
 (**********)
 Lemma fp_R0 : frac_part 0 = 0.
-unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros;
- unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1))); 
- intros a b; rewrite b; clear a b; rewrite <- Z_R_minus; 
- cut (up 0 = 1%Z).
-intro; rewrite H1;
- rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1))); 
- apply Ropp_0. 
-elim (archimed 0); intros; clear H2; unfold Rgt in H1;
- rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1);
- intro; clear H1; generalize (le_IZR_R1 (up 0) H0); 
- intro; clear H H0; omega.
+Proof.
+  unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros;
+    unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1))); 
+      intros a b; rewrite b; clear a b; rewrite <- Z_R_minus; 
+        cut (up 0 = 1%Z).
+  intro; rewrite H1;
+    rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1))); 
+      apply Ropp_0. 
+  elim (archimed 0); intros; clear H2; unfold Rgt in H1;
+    rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1);
+      intro; clear H1; generalize (le_IZR_R1 (up 0) H0); 
+        intro; clear H H0; omega.
 Qed.
 
 (**********)
 Lemma for_base_fp : forall r:R, IZR (up r) - r > 0 /\ IZR (up r) - r <= 1.
-intro; split; cut (IZR (up r) > r /\ IZR (up r) - r <= 1).
-intro; elim H; intros.
-apply (Rgt_minus (IZR (up r)) r H0).
-apply archimed.
-intro; elim H; intros.
-exact H1.
-apply archimed.
+Proof.
+  intro; split; cut (IZR (up r) > r /\ IZR (up r) - r <= 1).
+  intro; elim H; intros.
+  apply (Rgt_minus (IZR (up r)) r H0).
+  apply archimed.
+  intro; elim H; intros.
+  exact H1.
+  apply archimed.
 Qed.
 
 (**********)
 Lemma base_fp : forall r:R, frac_part r >= 0 /\ frac_part r < 1.
-intro; unfold frac_part in |- *; unfold Int_part in |- *; split.
+Proof.
+  intro; unfold frac_part in |- *; unfold Int_part in |- *; split.
      (*sup a O*)
-cut (r - IZR (up r) >= -1).
-rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
- rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
- fold (r - IZR (up r)) in |- *; fold (r - IZR (up r) - -1) in |- *;
- apply Rge_minus; auto with zarith real.
-rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r);
- auto with zarith real.
+  cut (r - IZR (up r) >= -1).
+  rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
+    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
+      fold (r - IZR (up r)) in |- *; fold (r - IZR (up r) - -1) in |- *;
+        apply Rge_minus; auto with zarith real.
+  rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r);
+    auto with zarith real.
     (*inf a 1*) 
-cut (r - IZR (up r) < 0).
-rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
- rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
- fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive; 
- elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *; 
- rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1);
- apply Rplus_lt_compat_l; auto with zarith real.
-elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr;
- apply Ropp_gt_lt_contravar; auto with zarith real.
+  cut (r - IZR (up r) < 0).
+  rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
+    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
+      fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive; 
+        elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *; 
+          rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1);
+            apply Rplus_lt_compat_l; auto with zarith real.
+  elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr;
+    apply Ropp_gt_lt_contravar; auto with zarith real.
 Qed.
 
 (*********************************************************)
-(**      Properties                                      *)
+(** *    Properties                                      *)
 (*********************************************************)
 
 (**********)
 Lemma base_Int_part :
- forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. 
-intro; unfold Int_part in |- *; elim (archimed r); intros.
-split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *.
-generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1;
- rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1;
- rewrite (Rplus_comm (- r) (-1)) in H1;
- rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1;
- fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1;
- apply Rminus_le; auto with zarith real.
-generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro;
- rewrite (Rplus_comm (-1) (IZR (up r))) in H1;
- generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); 
- intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2;
- fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2;
- rewrite (Rplus_comm (- r) (-1 + r)) in H2;
- rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2;
- elim (Rplus_ne (-1)); intros a b; rewrite a in H2; 
- clear a b; auto with zarith real.  
+  forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. 
+Proof.
+  intro; unfold Int_part in |- *; elim (archimed r); intros.
+  split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *.
+  generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1;
+    rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1;
+      rewrite (Rplus_comm (- r) (-1)) in H1;
+        rewrite <- (Rplus_assoc (IZR (up r)) (-1) (- r)) in H1;
+          fold (IZR (up r) - 1) in H1; fold (IZR (up r) - 1 - r) in H1;
+            apply Rminus_le; auto with zarith real.
+  generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro;
+    rewrite (Rplus_comm (-1) (IZR (up r))) in H1;
+      generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); 
+        intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2;
+          fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2;
+            rewrite (Rplus_comm (- r) (-1 + r)) in H2;
+              rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2;
+                elim (Rplus_ne (-1)); intros a b; rewrite a in H2; 
+                  clear a b; auto with zarith real.  
 Qed.
 
 (**********)
 Lemma Int_part_INR : forall n:nat, Int_part (INR n) = Z_of_nat n.
-intros n; unfold Int_part in |- *.
-cut (up (INR n) = (Z_of_nat n + Z_of_nat 1)%Z).
-intros H'; rewrite H'; simpl in |- *; ring.
-apply sym_equal; apply tech_up; auto.
-replace (Z_of_nat n + Z_of_nat 1)%Z with (Z_of_nat (S n)).
-repeat rewrite <- INR_IZR_INZ.
-apply lt_INR; auto.
-rewrite Zplus_comm; rewrite <- Znat.inj_plus; simpl in |- *; auto.
-rewrite plus_IZR; simpl in |- *; auto with real.
-repeat rewrite <- INR_IZR_INZ; auto with real.
+Proof.
+  intros n; unfold Int_part in |- *.
+  cut (up (INR n) = (Z_of_nat n + Z_of_nat 1)%Z).
+  intros H'; rewrite H'; simpl in |- *; ring.
+  apply sym_equal; apply tech_up; auto.
+  replace (Z_of_nat n + Z_of_nat 1)%Z with (Z_of_nat (S n)).
+  repeat rewrite <- INR_IZR_INZ.
+  apply lt_INR; auto.
+  rewrite Zplus_comm; rewrite <- Znat.inj_plus; simpl in |- *; auto.
+  rewrite plus_IZR; simpl in |- *; auto with real.
+  repeat rewrite <- INR_IZR_INZ; auto with real.
 Qed.
 
 (**********)
 Lemma fp_nat : forall r:R, frac_part r = 0 ->  exists c : Z, r = IZR c.
-unfold frac_part in |- *; intros; split with (Int_part r);
- apply Rminus_diag_uniq; auto with zarith real.
+Proof.
+  unfold frac_part in |- *; intros; split with (Int_part r);
+    apply Rminus_diag_uniq; auto with zarith real.
 Qed.
 
 (**********)
 Lemma R0_fp_O : forall r:R, 0 <> frac_part r -> 0 <> r.
-red in |- *; intros; rewrite <- H0 in H; generalize fp_R0; intro;
- auto with zarith real.
+Proof.
+  red in |- *; intros; rewrite <- H0 in H; generalize fp_R0; intro;
+    auto with zarith real.
 Qed.
 
 (**********)
 Lemma Rminus_Int_part1 :
- forall r1 r2:R,
-   frac_part r1 >= frac_part r2 ->
-   Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z.
-intros; elim (base_fp r1); elim (base_fp r2); intros;
- generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
- generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); 
- intro; clear H4; rewrite Ropp_0 in H0;
- generalize (Rge_le 0 (- frac_part r2) H0); intro; 
- clear H0; generalize (Rge_le (frac_part r1) 0 H2); 
- intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
- intro; clear H1; unfold Rgt in H2;
- generalize
-  (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
- intro; elim H1; intros; clear H1; elim (Rplus_ne 1); 
- intros a b; rewrite a in H6; clear a b H5;
- generalize (Rge_minus (frac_part r1) (frac_part r2) H); 
- intro; clear H; fold (frac_part r1 - frac_part r2) in H6;
- generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1); 
- intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H;
- unfold Rminus in H6, H;
- rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H;
- rewrite (Ropp_involutive (IZR (Int_part r2))) in H;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
-   in H;
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
-   in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H;
- rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
- rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
-   in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
- fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H;
- generalize
-  (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0
-     (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H); 
- intro; clear H;
- rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
- rewrite <-
-  (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
-     (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
-   in H0; unfold Rminus in H0; fold (r1 - r2) in H0;
- rewrite
-  (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
-     (IZR (Int_part r2) + - IZR (Int_part r1))) in H0;
- rewrite <-
-  (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
-     (- IZR (Int_part r1))) in H0;
- rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0;
- elim (Rplus_ne (- IZR (Int_part r1))); intros a b; 
- rewrite b in H0; clear a b;
- elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2))); 
- intros a b; rewrite a in H0; clear a b;
- rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2));
- intros a b; rewrite b in H0; clear a b;
- fold (IZR (Int_part r1) - IZR (Int_part r2)) in H0;
- rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H6;
- rewrite (Ropp_involutive (IZR (Int_part r2))) in H6;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
-   in H6;
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
-   in H6; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H6;
- rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
- rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
-   in H6;
- rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
- fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6;
- generalize
-  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
-     (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6); 
- intro; clear H6;
- rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
- rewrite <-
-  (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
-     (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
-   in H;
- rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
- rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H;
- elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; 
- clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
- rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; 
- cut (1 = IZR 1); auto with zarith real.
-intro; rewrite H1 in H; clear H1;
- rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
- generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); 
- intros; clear H H0; unfold Int_part at 1 in |- *; 
- omega.
+  forall r1 r2:R,
+    frac_part r1 >= frac_part r2 ->
+    Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z.
+Proof.
+  intros; elim (base_fp r1); elim (base_fp r2); intros;
+    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
+      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); 
+        intro; clear H4; rewrite Ropp_0 in H0;
+          generalize (Rge_le 0 (- frac_part r2) H0); intro; 
+            clear H0; generalize (Rge_le (frac_part r1) 0 H2); 
+              intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
+                intro; clear H1; unfold Rgt in H2;
+                  generalize
+                    (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
+                    intro; elim H1; intros; clear H1; elim (Rplus_ne 1); 
+                      intros a b; rewrite a in H6; clear a b H5;
+                        generalize (Rge_minus (frac_part r1) (frac_part r2) H); 
+                          intro; clear H; fold (frac_part r1 - frac_part r2) in H6;
+                            generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1); 
+                              intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H;
+                                unfold Rminus in H6, H;
+                                  rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H;
+                                    rewrite (Ropp_involutive (IZR (Int_part r2))) in H;
+                                      rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
+                                        in H;
+                                        rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
+                                          in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H;
+                                            rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
+                                              rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
+                                                in H; rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H;
+                                                  fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H;
+                                                    generalize
+                                                      (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0
+                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H); 
+                                                      intro; clear H;
+                                                        rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
+                                                          rewrite <-
+                                                            (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
+                                                              (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
+                                                            in H0; unfold Rminus in H0; fold (r1 - r2) in H0;
+                                                              rewrite
+                                                                (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
+                                                                  (IZR (Int_part r2) + - IZR (Int_part r1))) in H0;
+                                                                rewrite <-
+                                                                  (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
+                                                                    (- IZR (Int_part r1))) in H0;
+                                                                  rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0;
+                                                                    elim (Rplus_ne (- IZR (Int_part r1))); intros a b; 
+                                                                      rewrite b in H0; clear a b;
+                                                                        elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2))); 
+                                                                          intros a b; rewrite a in H0; clear a b;
+                                                                            rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2));
+                                                                              intros a b; rewrite b in H0; clear a b;
+                                                                                fold (IZR (Int_part r1) - IZR (Int_part r2)) in H0;
+                                                                                  rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H6;
+                                                                                    rewrite (Ropp_involutive (IZR (Int_part r2))) in H6;
+                                                                                      rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
+                                                                                        in H6;
+                                                                                        rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
+                                                                                          in H6; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H6;
+                                                                                            rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
+                                                                                              rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
+                                                                                                in H6;
+                                                                                                rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H6;
+                                                                                                  fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6;
+                                                                                                    generalize
+                                                                                                      (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
+                                                                                                        (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6); 
+                                                                                                      intro; clear H6;
+                                                                                                        rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
+                                                                                                          rewrite <-
+                                                                                                            (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
+                                                                                                              (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
+                                                                                                            in H;
+                                                                                                            rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
+                                                                                                              rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H;
+                                                                                                                elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; 
+                                                                                                                  clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
+                                                                                                                    rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; 
+                                                                                                                      cut (1 = IZR 1); auto with zarith real.
+  intro; rewrite H1 in H; clear H1;
+    rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
+      generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); 
+        intros; clear H H0; unfold Int_part at 1 in |- *; 
+          omega.
 Qed.
 
 (**********)
 Lemma Rminus_Int_part2 :
- forall r1 r2:R,
-   frac_part r1 < frac_part r2 ->
-   Int_part (r1 - r2) = (Int_part r1 - Int_part r2 - 1)%Z.
-intros; elim (base_fp r1); elim (base_fp r2); intros;
- generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
- generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); 
- intro; clear H4; rewrite Ropp_0 in H0;
- generalize (Rge_le 0 (- frac_part r2) H0); intro; 
- clear H0; generalize (Rge_le (frac_part r1) 0 H2); 
- intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
- intro; clear H1; unfold Rgt in H2;
- generalize
-  (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
- intro; elim H1; intros; clear H1; elim (Rplus_ne (-1)); 
- intros a b; rewrite b in H5; clear a b H6;
- generalize (Rlt_minus (frac_part r1) (frac_part r2) H); 
- intro; clear H; fold (frac_part r1 - frac_part r2) in H5; 
- clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1;
- rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5;
- rewrite (Ropp_involutive (IZR (Int_part r2))) in H5;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
-   in H5;
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
-   in H5; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H5;
- rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
- rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
-   in H5;
- rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
- fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5;
- generalize
-  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1)
-     (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5); 
- intro; clear H5;
- rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
- rewrite <-
-  (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
-     (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
-   in H; unfold Rminus in H; fold (r1 - r2) in H;
- rewrite
-  (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
-     (IZR (Int_part r2) + - IZR (Int_part r1))) in H;
- rewrite <-
-  (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
-     (- IZR (Int_part r1))) in H;
- rewrite (Rplus_opp_l (IZR (Int_part r2))) in H;
- elim (Rplus_ne (- IZR (Int_part r1))); intros a b; 
- rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H;
- elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; 
- clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H;
- fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H;
- rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1;
- rewrite (Ropp_involutive (IZR (Int_part r2))) in H1;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
-   in H1;
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
-   in H1; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H1;
- rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
- rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
-   in H1;
- rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
- fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1;
- generalize
-  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
-     (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1); 
- intro; clear H1;
- rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
- rewrite <-
-  (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
-     (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
-   in H0;
- rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
- rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0;
- elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; 
- clear a b; rewrite <- (Rplus_opp_l 1) in H0;
- rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1)
-   in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0;
- rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
- rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; 
- cut (1 = IZR 1); auto with zarith real.
-intro; rewrite H1 in H; rewrite H1 in H0; clear H1;
- rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H;
- rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0;
- rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0;
- generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); 
- intro; clear H;
- generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); 
- intros; clear H0 H1; unfold Int_part at 1 in |- *; 
- omega.
+  forall r1 r2:R,
+    frac_part r1 < frac_part r2 ->
+    Int_part (r1 - r2) = (Int_part r1 - Int_part r2 - 1)%Z.
+Proof.
+  intros; elim (base_fp r1); elim (base_fp r2); intros;
+    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
+      generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); 
+        intro; clear H4; rewrite Ropp_0 in H0;
+          generalize (Rge_le 0 (- frac_part r2) H0); intro; 
+            clear H0; generalize (Rge_le (frac_part r1) 0 H2); 
+              intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1);
+                intro; clear H1; unfold Rgt in H2;
+                  generalize
+                    (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4);
+                    intro; elim H1; intros; clear H1; elim (Rplus_ne (-1)); 
+                      intros a b; rewrite b in H5; clear a b H6;
+                        generalize (Rlt_minus (frac_part r1) (frac_part r2) H); 
+                          intro; clear H; fold (frac_part r1 - frac_part r2) in H5; 
+                            clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1;
+                              rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5;
+                                rewrite (Ropp_involutive (IZR (Int_part r2))) in H5;
+                                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
+                                    in H5;
+                                    rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
+                                      in H5; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H5;
+                                        rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
+                                          rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
+                                            in H5;
+                                            rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H5;
+                                              fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5;
+                                                generalize
+                                                  (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1)
+                                                    (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5); 
+                                                  intro; clear H5;
+                                                    rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H;
+                                                      rewrite <-
+                                                        (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
+                                                          (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
+                                                        in H; unfold Rminus in H; fold (r1 - r2) in H;
+                                                          rewrite
+                                                            (Rplus_assoc (IZR (Int_part r1)) (- IZR (Int_part r2))
+                                                              (IZR (Int_part r2) + - IZR (Int_part r1))) in H;
+                                                            rewrite <-
+                                                              (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2))
+                                                                (- IZR (Int_part r1))) in H;
+                                                              rewrite (Rplus_opp_l (IZR (Int_part r2))) in H;
+                                                                elim (Rplus_ne (- IZR (Int_part r1))); intros a b; 
+                                                                  rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H;
+                                                                    elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; 
+                                                                      clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H;
+                                                                        fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H;
+                                                                          rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1;
+                                                                            rewrite (Ropp_involutive (IZR (Int_part r2))) in H1;
+                                                                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)))
+                                                                                in H1;
+                                                                                rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)))
+                                                                                  in H1; rewrite (Rplus_comm (- IZR (Int_part r1)) (- r2)) in H1;
+                                                                                    rewrite (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
+                                                                                      rewrite <- (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)))
+                                                                                        in H1;
+                                                                                        rewrite (Rplus_comm (- IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
+                                                                                          fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1;
+                                                                                            generalize
+                                                                                              (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2))
+                                                                                                (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1); 
+                                                                                              intro; clear H1;
+                                                                                                rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0;
+                                                                                                  rewrite <-
+                                                                                                    (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2))
+                                                                                                      (IZR (Int_part r2) - IZR (Int_part r1)) (r1 - r2))
+                                                                                                    in H0;
+                                                                                                    rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
+                                                                                                      rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0;
+                                                                                                        elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; 
+                                                                                                          clear a b; rewrite <- (Rplus_opp_l 1) in H0;
+                                                                                                            rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1)
+                                                                                                              in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0;
+                                                                                                                rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
+                                                                                                                  rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; 
+                                                                                                                    cut (1 = IZR 1); auto with zarith real.
+  intro; rewrite H1 in H; rewrite H1 in H0; clear H1;
+    rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H;
+      rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0;
+        rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0;
+          generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); 
+            intro; clear H;
+              generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); 
+                intros; clear H0 H1; unfold Int_part at 1 in |- *; 
+                  omega.
 Qed.
 
 (**********)
 Lemma Rminus_fp1 :
- forall r1 r2:R,
-   frac_part r1 >= frac_part r2 ->
-   frac_part (r1 - r2) = frac_part r1 - frac_part r2.
-intros; unfold frac_part in |- *; generalize (Rminus_Int_part1 r1 r2 H);
- intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
- unfold Rminus in |- *;
- rewrite (Ropp_plus_distr (IZR (Int_part r1)) (- IZR (Int_part r2)));
- rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
- rewrite (Ropp_involutive (IZR (Int_part r2)));
- rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
- rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
- rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); 
- auto with zarith real.
+  forall r1 r2:R,
+    frac_part r1 >= frac_part r2 ->
+    frac_part (r1 - r2) = frac_part r1 - frac_part r2.
+Proof.
+  intros; unfold frac_part in |- *; generalize (Rminus_Int_part1 r1 r2 H);
+    intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
+      unfold Rminus in |- *;
+        rewrite (Ropp_plus_distr (IZR (Int_part r1)) (- IZR (Int_part r2)));
+          rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
+            rewrite (Ropp_involutive (IZR (Int_part r2)));
+              rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
+                rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
+                  rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
+                    rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
+                      rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); 
+                        auto with zarith real.
 Qed.
 
 (**********)
 Lemma Rminus_fp2 :
- forall r1 r2:R,
-   frac_part r1 < frac_part r2 ->
-   frac_part (r1 - r2) = frac_part r1 - frac_part r2 + 1.
-intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H);
- intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1);
- rewrite <- (Z_R_minus (Int_part r1) (Int_part r2)); 
- unfold Rminus in |- *;
- rewrite
-  (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1))
-  ; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
- rewrite (Ropp_involutive (IZR 1));
- rewrite (Ropp_involutive (IZR (Int_part r2)));
- rewrite (Ropp_plus_distr (IZR (Int_part r1)));
- rewrite (Ropp_involutive (IZR (Int_part r2))); simpl in |- *;
- rewrite <-
-  (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1)
-  ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
- rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
- rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); 
- auto with zarith real.
+  forall r1 r2:R,
+    frac_part r1 < frac_part r2 ->
+    frac_part (r1 - r2) = frac_part r1 - frac_part r2 + 1.
+Proof.
+  intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H);
+    intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1);
+      rewrite <- (Z_R_minus (Int_part r1) (Int_part r2)); 
+        unfold Rminus in |- *;
+          rewrite
+            (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1))
+            ; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
+              rewrite (Ropp_involutive (IZR 1));
+                rewrite (Ropp_involutive (IZR (Int_part r2)));
+                  rewrite (Ropp_plus_distr (IZR (Int_part r1)));
+                    rewrite (Ropp_involutive (IZR (Int_part r2))); simpl in |- *;
+                      rewrite <-
+                        (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1)
+                        ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
+                          rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2)));
+                            rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2)));
+                              rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2)));
+                                rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); 
+                                  auto with zarith real.
 Qed.
 
 (**********)
 Lemma plus_Int_part1 :
- forall r1 r2:R,
-   frac_part r1 + frac_part r2 >= 1 ->
-   Int_part (r1 + r2) = (Int_part r1 + Int_part r2 + 1)%Z.
-intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H;
- elim (base_fp r1); elim (base_fp r2); intros; clear H H2;
- generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); 
- intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); 
- intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2;
- generalize
-  (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); 
- intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1;
- unfold frac_part in H0, H1; unfold Rminus in H0, H1;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
-   in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
-   in H1;
- rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
- rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
-   in H1;
- rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
-   in H0; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H0;
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
-   in H0;
- rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H0;
- rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
-   in H0;
- rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
- generalize
-  (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1
-     (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); 
- intro; clear H0;
- generalize
-  (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
-     (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); 
- intro; clear H1;
- rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
-   in H;
- rewrite <-
-  (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
-     (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
-   in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H;
- elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; 
- clear a b;
- rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
-   in H0;
- rewrite <-
-  (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
-     (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
-   in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
- elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; 
- clear a b;
- rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0;
- cut (1 = IZR 1); auto with zarith real.
-intro; rewrite H1 in H0; rewrite H1 in H; clear H1;
- rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H;
- rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
- rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H;
- rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
- rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
- generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); 
- intro; clear H H0; unfold Int_part at 1 in |- *; omega.
+  forall r1 r2:R,
+    frac_part r1 + frac_part r2 >= 1 ->
+    Int_part (r1 + r2) = (Int_part r1 + Int_part r2 + 1)%Z.
+Proof.
+  intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H;
+    elim (base_fp r1); elim (base_fp r2); intros; clear H H2;
+      generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); 
+        intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); 
+          intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2;
+            generalize
+              (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); 
+              intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1;
+                unfold frac_part in H0, H1; unfold Rminus in H0, H1;
+                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
+                    in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
+                      rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
+                        in H1;
+                        rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
+                          rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
+                            in H1;
+                            rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
+                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
+                                in H0; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H0;
+                                  rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
+                                    in H0;
+                                    rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H0;
+                                      rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
+                                        in H0;
+                                        rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
+                                          generalize
+                                            (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1
+                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); 
+                                            intro; clear H0;
+                                              generalize
+                                                (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
+                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); 
+                                                intro; clear H1;
+                                                  rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
+                                                    in H;
+                                                    rewrite <-
+                                                      (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
+                                                        (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
+                                                      in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H;
+                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; 
+                                                          clear a b;
+                                                            rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
+                                                              in H0;
+                                                              rewrite <-
+                                                                (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
+                                                                  (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
+                                                                in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
+                                                                  elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; 
+                                                                    clear a b;
+                                                                      rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0;
+                                                                        cut (1 = IZR 1); auto with zarith real.
+  intro; rewrite H1 in H0; rewrite H1 in H; clear H1;
+    rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H;
+      rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
+        rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H;
+          rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
+            rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
+              generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); 
+                intro; clear H H0; unfold Int_part at 1 in |- *; omega.
 Qed.
 
 (**********)
 Lemma plus_Int_part2 :
- forall r1 r2:R,
-   frac_part r1 + frac_part r2 < 1 ->
-   Int_part (r1 + r2) = (Int_part r1 + Int_part r2)%Z.
-intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3;
- generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
- generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2;
- generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); 
- intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; 
- rewrite a in H2; clear a b;
- generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2);
- intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
-   in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
-   in H1;
- rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
- rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
-   in H1;
- rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
-   in H; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H;
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) in H;
- rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H;
- rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
-   in H;
- rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
- generalize
-  (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0
-     (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); 
- intro; clear H1;
- generalize
-  (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
-     (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); 
- intro; clear H;
- rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
-   in H1;
- rewrite <-
-  (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
-     (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
-   in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1;
- elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; 
- clear a b;
- rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
-   in H0;
- rewrite <-
-  (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
-     (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
-   in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
- elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); 
- intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2));
- intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1);
- auto with zarith real.
-intro; rewrite H in H1; clear H;
- rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
- rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
- rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
- generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); 
- intro; clear H0 H1; unfold Int_part at 1 in |- *; 
- omega.
+  forall r1 r2:R,
+    frac_part r1 + frac_part r2 < 1 ->
+    Int_part (r1 + r2) = (Int_part r1 + Int_part r2)%Z.
+Proof.
+  intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3;
+    generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0;
+      generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2;
+        generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); 
+          intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; 
+            rewrite a in H2; clear a b;
+              generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2);
+                intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1;
+                  rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
+                    in H1; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H1;
+                      rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2)
+                        in H1;
+                        rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H1;
+                          rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
+                            in H1;
+                            rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
+                              rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)))
+                                in H; rewrite (Rplus_comm r2 (- IZR (Int_part r2))) in H;
+                                  rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2) in H;
+                                    rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2) in H;
+                                      rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)))
+                                        in H;
+                                        rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
+                                          generalize
+                                            (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0
+                                              (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); 
+                                            intro; clear H1;
+                                              generalize
+                                                (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2))
+                                                  (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); 
+                                                intro; clear H;
+                                                  rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
+                                                    in H1;
+                                                    rewrite <-
+                                                      (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
+                                                        (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
+                                                      in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1;
+                                                        elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; 
+                                                          clear a b;
+                                                            rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))))
+                                                              in H0;
+                                                              rewrite <-
+                                                                (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2))
+                                                                  (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2))
+                                                                in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0;
+                                                                  elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); 
+                                                                    intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2));
+                                                                      intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1);
+                                                                        auto with zarith real.
+  intro; rewrite H in H1; clear H;
+    rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0;
+      rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
+        rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
+          generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); 
+            intro; clear H0 H1; unfold Int_part at 1 in |- *; 
+              omega.
 Qed.
 
 (**********)
 Lemma plus_frac_part1 :
- forall r1 r2:R,
-   frac_part r1 + frac_part r2 >= 1 ->
-   frac_part (r1 + r2) = frac_part r1 + frac_part r2 - 1.
-intros; unfold frac_part in |- *; generalize (plus_Int_part1 r1 r2 H); intro;
- rewrite H0; rewrite (plus_IZR (Int_part r1 + Int_part r2) 1);
- rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl in |- *;
- unfold Rminus at 3 4 in |- *;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
- rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
- rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
- rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
- rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
- unfold Rminus in |- *;
- rewrite
-  (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1))
-  ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1);
- trivial with zarith real.
+  forall r1 r2:R,
+    frac_part r1 + frac_part r2 >= 1 ->
+    frac_part (r1 + r2) = frac_part r1 + frac_part r2 - 1.
+Proof.
+  intros; unfold frac_part in |- *; generalize (plus_Int_part1 r1 r2 H); intro;
+    rewrite H0; rewrite (plus_IZR (Int_part r1 + Int_part r2) 1);
+      rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl in |- *;
+        unfold Rminus at 3 4 in |- *;
+          rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
+            rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
+              rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
+                rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
+                  rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
+                    rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
+                      unfold Rminus in |- *;
+                        rewrite
+                          (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1))
+                          ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1);
+                            trivial with zarith real.
 Qed.
 
 (**********)
 Lemma plus_frac_part2 :
- forall r1 r2:R,
-   frac_part r1 + frac_part r2 < 1 ->
-   frac_part (r1 + r2) = frac_part r1 + frac_part r2.
-intros; unfold frac_part in |- *; generalize (plus_Int_part2 r1 r2 H); intro;
- rewrite H0; rewrite (plus_IZR (Int_part r1) (Int_part r2));
- unfold Rminus at 2 3 in |- *;
- rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
- rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
- rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
- rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
- rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
- rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
- unfold Rminus in |- *; trivial with zarith real.
-Qed.
\ No newline at end of file
+  forall r1 r2:R,
+    frac_part r1 + frac_part r2 < 1 ->
+    frac_part (r1 + r2) = frac_part r1 + frac_part r2.
+Proof.
+  intros; unfold frac_part in |- *; generalize (plus_Int_part2 r1 r2 H); intro;
+    rewrite H0; rewrite (plus_IZR (Int_part r1) (Int_part r2));
+      unfold Rminus at 2 3 in |- *;
+        rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
+          rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
+            rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
+              rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
+                rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
+                  rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
+                    unfold Rminus in |- *; trivial with zarith real.
+Qed.
diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
index 0abf9064..270ea6da 100644
--- a/theories/Reals/R_sqr.v
+++ b/theories/Reals/R_sqr.v
@@ -6,325 +6,359 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_sqr.v,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: R_sqr.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rbasic_fun. Open Local Scope R_scope.
 
 (****************************************************)
-(* Rsqr : some results                              *)
+(** Rsqr : some results                             *)
 (****************************************************)
 
 Ltac ring_Rsqr := unfold Rsqr in |- *; ring.
 
 Lemma Rsqr_neg : forall x:R, Rsqr x = Rsqr (- x).
-intros; ring_Rsqr.
+Proof.
+  intros; ring_Rsqr.
 Qed.
 
 Lemma Rsqr_mult : forall x y:R, Rsqr (x * y) = Rsqr x * Rsqr y.
-intros; ring_Rsqr.
+Proof.
+  intros; ring_Rsqr.
 Qed.
 
 Lemma Rsqr_plus : forall x y:R, Rsqr (x + y) = Rsqr x + Rsqr y + 2 * x * y.
-intros; ring_Rsqr.
+Proof.
+  intros; ring_Rsqr.
 Qed.
 
 Lemma Rsqr_minus : forall x y:R, Rsqr (x - y) = Rsqr x + Rsqr y - 2 * x * y.
-intros; ring_Rsqr.
+Proof.
+  intros; ring_Rsqr.
 Qed.
 
 Lemma Rsqr_neg_minus : forall x y:R, Rsqr (x - y) = Rsqr (y - x).
-intros; ring_Rsqr.
+Proof.
+  intros; ring_Rsqr.
 Qed.
 
 Lemma Rsqr_1 : Rsqr 1 = 1.
-ring_Rsqr.
+Proof.
+  ring_Rsqr.
 Qed.
 
 Lemma Rsqr_gt_0_0 : forall x:R, 0 < Rsqr x -> x <> 0.
-intros; red in |- *; intro; rewrite H0 in H; rewrite Rsqr_0 in H;
- elim (Rlt_irrefl 0 H).
+Proof.
+  intros; red in |- *; intro; rewrite H0 in H; rewrite Rsqr_0 in H;
+    elim (Rlt_irrefl 0 H).
 Qed.
 
 Lemma Rsqr_pos_lt : forall x:R, x <> 0 -> 0 < Rsqr x.
-intros; case (Rtotal_order 0 x); intro;
- [ unfold Rsqr in |- *; apply Rmult_lt_0_compat; assumption
- | elim H0; intro;
-    [ elim H; symmetry  in |- *; exact H1
-    | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1);
-       rewrite Ropp_0; intro; unfold Rsqr in |- *; 
-       apply Rmult_lt_0_compat; assumption ] ].
+Proof.
+  intros; case (Rtotal_order 0 x); intro;
+    [ unfold Rsqr in |- *; apply Rmult_lt_0_compat; assumption
+      | elim H0; intro;
+        [ elim H; symmetry  in |- *; exact H1
+          | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1);
+            rewrite Ropp_0; intro; unfold Rsqr in |- *; 
+              apply Rmult_lt_0_compat; assumption ] ].
 Qed.
 
 Lemma Rsqr_div : forall x y:R, y <> 0 -> Rsqr (x / y) = Rsqr x / Rsqr y.
-intros; unfold Rsqr in |- *.
-unfold Rdiv in |- *.
-rewrite Rinv_mult_distr.
-repeat rewrite Rmult_assoc.
-apply Rmult_eq_compat_l.
-pattern x at 2 in |- *; rewrite Rmult_comm.
-repeat rewrite Rmult_assoc.
-apply Rmult_eq_compat_l.
-reflexivity.
-assumption.
-assumption.
+Proof.
+  intros; unfold Rsqr in |- *.
+  unfold Rdiv in |- *.
+  rewrite Rinv_mult_distr.
+  repeat rewrite Rmult_assoc.
+  apply Rmult_eq_compat_l.
+  pattern x at 2 in |- *; rewrite Rmult_comm.
+  repeat rewrite Rmult_assoc.
+  apply Rmult_eq_compat_l.
+  reflexivity.
+  assumption.
+  assumption.
 Qed.
 
 Lemma Rsqr_eq_0 : forall x:R, Rsqr x = 0 -> x = 0.
-unfold Rsqr in |- *; intros; generalize (Rmult_integral x x H); intro;
- elim H0; intro; assumption.
+Proof.
+  unfold Rsqr in |- *; intros; generalize (Rmult_integral x x H); intro;
+    elim H0; intro; assumption.
 Qed.
 
 Lemma Rsqr_minus_plus : forall a b:R, (a - b) * (a + b) = Rsqr a - Rsqr b.
-intros; ring_Rsqr.
+Proof.
+  intros; ring_Rsqr.
 Qed.
 
 Lemma Rsqr_plus_minus : forall a b:R, (a + b) * (a - b) = Rsqr a - Rsqr b.
-intros; ring_Rsqr.
+Proof.
+  intros; ring_Rsqr.
 Qed.
 
 Lemma Rsqr_incr_0 :
- forall x y:R, Rsqr x <= Rsqr y -> 0 <= x -> 0 <= y -> x <= y.
-intros; case (Rle_dec x y); intro;
- [ assumption
- | cut (y < x);
-    [ intro; unfold Rsqr in H;
-       generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); 
-       intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); 
-       intro; elim (Rlt_irrefl (x * x) H4)
-    | auto with real ] ].
+  forall x y:R, Rsqr x <= Rsqr y -> 0 <= x -> 0 <= y -> x <= y.
+Proof.
+  intros; case (Rle_dec x y); intro;
+    [ assumption
+      | cut (y < x);
+        [ intro; unfold Rsqr in H;
+          generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); 
+            intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); 
+              intro; elim (Rlt_irrefl (x * x) H4)
+          | auto with real ] ].
 Qed.
 
 Lemma Rsqr_incr_0_var : forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> x <= y.
-intros; case (Rle_dec x y); intro;
- [ assumption
- | cut (y < x);
-    [ intro; unfold Rsqr in H;
-       generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); 
-       intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); 
-       intro; elim (Rlt_irrefl (x * x) H3)
-    | auto with real ] ].
+Proof.
+  intros; case (Rle_dec x y); intro;
+    [ assumption
+      | cut (y < x);
+        [ intro; unfold Rsqr in H;
+          generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); 
+            intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); 
+              intro; elim (Rlt_irrefl (x * x) H3)
+          | auto with real ] ].
 Qed.
 
 Lemma Rsqr_incr_1 :
- forall x y:R, x <= y -> 0 <= x -> 0 <= y -> Rsqr x <= Rsqr y.
-intros; unfold Rsqr in |- *; apply Rmult_le_compat; assumption.
+  forall x y:R, x <= y -> 0 <= x -> 0 <= y -> Rsqr x <= Rsqr y.
+Proof.
+  intros; unfold Rsqr in |- *; apply Rmult_le_compat; assumption.
 Qed.
 
 Lemma Rsqr_incrst_0 :
- forall x y:R, Rsqr x < Rsqr y -> 0 <= x -> 0 <= y -> x < y.
-intros; case (Rtotal_order x y); intro;
- [ assumption
- | elim H2; intro;
-    [ rewrite H3 in H; elim (Rlt_irrefl (Rsqr y) H)
-    | generalize (Rmult_le_0_lt_compat y x y x H1 H1 H3 H3); intro;
-       unfold Rsqr in H; generalize (Rlt_trans (x * x) (y * y) (x * x) H H4);
-       intro; elim (Rlt_irrefl (x * x) H5) ] ].
+  forall x y:R, Rsqr x < Rsqr y -> 0 <= x -> 0 <= y -> x < y.
+Proof.
+  intros; case (Rtotal_order x y); intro;
+    [ assumption
+      | elim H2; intro;
+        [ rewrite H3 in H; elim (Rlt_irrefl (Rsqr y) H)
+          | generalize (Rmult_le_0_lt_compat y x y x H1 H1 H3 H3); intro;
+            unfold Rsqr in H; generalize (Rlt_trans (x * x) (y * y) (x * x) H H4);
+              intro; elim (Rlt_irrefl (x * x) H5) ] ].
 Qed.
 
 Lemma Rsqr_incrst_1 :
- forall x y:R, x < y -> 0 <= x -> 0 <= y -> Rsqr x < Rsqr y.
-intros; unfold Rsqr in |- *; apply Rmult_le_0_lt_compat; assumption.
+  forall x y:R, x < y -> 0 <= x -> 0 <= y -> Rsqr x < Rsqr y.
+Proof.
+  intros; unfold Rsqr in |- *; apply Rmult_le_0_lt_compat; assumption.
 Qed.
 
 Lemma Rsqr_neg_pos_le_0 :
- forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> - y <= x.
-intros; case (Rcase_abs x); intro.
-generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
- generalize (Rlt_le 0 (- x) H1); intro; rewrite (Rsqr_neg x) in H;
- generalize (Rsqr_incr_0 (- x) y H H2 H0); intro;
- rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar; 
- apply Rle_ge; assumption.
-apply Rle_trans with 0;
- [ rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption
- | apply Rge_le; assumption ].
+  forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> - y <= x.
+Proof.
+  intros; case (Rcase_abs x); intro.
+  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
+    generalize (Rlt_le 0 (- x) H1); intro; rewrite (Rsqr_neg x) in H;
+      generalize (Rsqr_incr_0 (- x) y H H2 H0); intro;
+        rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar; 
+          apply Rle_ge; assumption.
+  apply Rle_trans with 0;
+    [ rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption
+      | apply Rge_le; assumption ].
 Qed.
 
 Lemma Rsqr_neg_pos_le_1 :
- forall x y:R, - y <= x -> x <= y -> 0 <= y -> Rsqr x <= Rsqr y.
-intros; case (Rcase_abs x); intro.
-generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
- generalize (Rlt_le 0 (- x) H2); intro;
- generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; 
- intro; generalize (Rge_le y (- x) H4); intro; rewrite (Rsqr_neg x);
- apply Rsqr_incr_1; assumption.
-generalize (Rge_le x 0 r); intro; apply Rsqr_incr_1; assumption.
+  forall x y:R, - y <= x -> x <= y -> 0 <= y -> Rsqr x <= Rsqr y.
+Proof.
+  intros; case (Rcase_abs x); intro.
+  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
+    generalize (Rlt_le 0 (- x) H2); intro;
+      generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; 
+        intro; generalize (Rge_le y (- x) H4); intro; rewrite (Rsqr_neg x);
+          apply Rsqr_incr_1; assumption.
+  generalize (Rge_le x 0 r); intro; apply Rsqr_incr_1; assumption.
 Qed.
 
 Lemma neg_pos_Rsqr_le : forall x y:R, - y <= x -> x <= y -> Rsqr x <= Rsqr y.
-intros; case (Rcase_abs x); intro.
-generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
- generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; 
- intro; generalize (Rge_le y (- x) H2); intro; generalize (Rlt_le 0 (- x) H1);
- intro; generalize (Rle_trans 0 (- x) y H4 H3); intro; 
- rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption.
-generalize (Rge_le x 0 r); intro; generalize (Rle_trans 0 x y H1 H0); intro;
- apply Rsqr_incr_1; assumption.
+Proof.
+  intros; case (Rcase_abs x); intro.
+  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
+    generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; 
+      intro; generalize (Rge_le y (- x) H2); intro; generalize (Rlt_le 0 (- x) H1);
+        intro; generalize (Rle_trans 0 (- x) y H4 H3); intro; 
+          rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption.
+  generalize (Rge_le x 0 r); intro; generalize (Rle_trans 0 x y H1 H0); intro;
+    apply Rsqr_incr_1; assumption.
 Qed.
 
 Lemma Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x).
-intro; unfold Rabs in |- *; case (Rcase_abs x); intro;
- [ apply Rsqr_neg | reflexivity ].
+Proof.
+  intro; unfold Rabs in |- *; case (Rcase_abs x); intro;
+    [ apply Rsqr_neg | reflexivity ].
 Qed.
 
 Lemma Rsqr_le_abs_0 : forall x y:R, Rsqr x <= Rsqr y -> Rabs x <= Rabs y.
-intros; apply Rsqr_incr_0; repeat rewrite <- Rsqr_abs;
- [ assumption | apply Rabs_pos | apply Rabs_pos ].
+Proof.
+  intros; apply Rsqr_incr_0; repeat rewrite <- Rsqr_abs;
+    [ assumption | apply Rabs_pos | apply Rabs_pos ].
 Qed.
 
 Lemma Rsqr_le_abs_1 : forall x y:R, Rabs x <= Rabs y -> Rsqr x <= Rsqr y.
-intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y);
- apply (Rsqr_incr_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)).
+Proof.
+  intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y);
+    apply (Rsqr_incr_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)).
 Qed.
 
 Lemma Rsqr_lt_abs_0 : forall x y:R, Rsqr x < Rsqr y -> Rabs x < Rabs y.
-intros; apply Rsqr_incrst_0; repeat rewrite <- Rsqr_abs;
- [ assumption | apply Rabs_pos | apply Rabs_pos ].
+Proof.
+  intros; apply Rsqr_incrst_0; repeat rewrite <- Rsqr_abs;
+    [ assumption | apply Rabs_pos | apply Rabs_pos ].
 Qed.
 
 Lemma Rsqr_lt_abs_1 : forall x y:R, Rabs x < Rabs y -> Rsqr x < Rsqr y.
-intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y);
- apply (Rsqr_incrst_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)).
+Proof.
+  intros; rewrite (Rsqr_abs x); rewrite (Rsqr_abs y);
+    apply (Rsqr_incrst_1 (Rabs x) (Rabs y) H (Rabs_pos x) (Rabs_pos y)).
 Qed.
 
 Lemma Rsqr_inj : forall x y:R, 0 <= x -> 0 <= y -> Rsqr x = Rsqr y -> x = y.
-intros; generalize (Rle_le_eq (Rsqr x) (Rsqr y)); intro; elim H2; intros _ H3;
- generalize (H3 H1); intro; elim H4; intros; apply Rle_antisym;
- apply Rsqr_incr_0; assumption.
+Proof.
+  intros; generalize (Rle_le_eq (Rsqr x) (Rsqr y)); intro; elim H2; intros _ H3;
+    generalize (H3 H1); intro; elim H4; intros; apply Rle_antisym;
+      apply Rsqr_incr_0; assumption.
 Qed.
 
 Lemma Rsqr_eq_abs_0 : forall x y:R, Rsqr x = Rsqr y -> Rabs x = Rabs y.
-intros; unfold Rabs in |- *; case (Rcase_abs x); case (Rcase_abs y); intros.
-rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H;
- generalize (Ropp_lt_gt_contravar y 0 r);
- generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; 
- intros; generalize (Rlt_le 0 (- x) H0); generalize (Rlt_le 0 (- y) H1);
- intros; apply Rsqr_inj; assumption.
-rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 r); intro;
- generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; 
- intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj; 
- assumption.
-rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 r0); intro;
- generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0; 
- intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj; 
- assumption.
-generalize (Rge_le x 0 r0); generalize (Rge_le y 0 r); intros; apply Rsqr_inj;
- assumption.
+Proof.
+  intros; unfold Rabs in |- *; case (Rcase_abs x); case (Rcase_abs y); intros.
+  rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H;
+    generalize (Ropp_lt_gt_contravar y 0 r);
+      generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; 
+        intros; generalize (Rlt_le 0 (- x) H0); generalize (Rlt_le 0 (- y) H1);
+          intros; apply Rsqr_inj; assumption.
+  rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 r); intro;
+    generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; 
+      intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj; 
+        assumption.
+  rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 r0); intro;
+    generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0; 
+      intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj; 
+        assumption.
+  generalize (Rge_le x 0 r0); generalize (Rge_le y 0 r); intros; apply Rsqr_inj;
+    assumption.
 Qed.
 
 Lemma Rsqr_eq_asb_1 : forall x y:R, Rabs x = Rabs y -> Rsqr x = Rsqr y.
-intros; cut (Rsqr (Rabs x) = Rsqr (Rabs y)).
-intro; repeat rewrite <- Rsqr_abs in H0; assumption.
-rewrite H; reflexivity.
+Proof.
+  intros; cut (Rsqr (Rabs x) = Rsqr (Rabs y)).
+  intro; repeat rewrite <- Rsqr_abs in H0; assumption.
+  rewrite H; reflexivity.
 Qed.
 
 Lemma triangle_rectangle :
- forall x y z:R,
-   0 <= z -> Rsqr x + Rsqr y <= Rsqr z -> - z <= x <= z /\ - z <= y <= z.
-intros;
- generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H0);
- rewrite Rplus_comm in H0;
- generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H0);
- intros; split;
- [ split;
-    [ apply Rsqr_neg_pos_le_0; assumption
-    | apply Rsqr_incr_0_var; assumption ]
- | split;
-    [ apply Rsqr_neg_pos_le_0; assumption
-    | apply Rsqr_incr_0_var; assumption ] ].
+  forall x y z:R,
+    0 <= z -> Rsqr x + Rsqr y <= Rsqr z -> - z <= x <= z /\ - z <= y <= z.
+Proof.
+  intros;
+    generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H0);
+      rewrite Rplus_comm in H0;
+        generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H0);
+          intros; split;
+            [ split;
+              [ apply Rsqr_neg_pos_le_0; assumption
+                | apply Rsqr_incr_0_var; assumption ]
+              | split;
+                [ apply Rsqr_neg_pos_le_0; assumption
+                  | apply Rsqr_incr_0_var; assumption ] ].
 Qed.
 
 Lemma triangle_rectangle_lt :
- forall x y z:R,
-   Rsqr x + Rsqr y < Rsqr z -> Rabs x < Rabs z /\ Rabs y < Rabs z.
-intros; split;
- [ generalize (plus_lt_is_lt (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H);
-    intro; apply Rsqr_lt_abs_0; assumption
- | rewrite Rplus_comm in H;
-    generalize (plus_lt_is_lt (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H);
-    intro; apply Rsqr_lt_abs_0; assumption ].
+  forall x y z:R,
+    Rsqr x + Rsqr y < Rsqr z -> Rabs x < Rabs z /\ Rabs y < Rabs z.
+Proof.
+  intros; split;
+    [ generalize (plus_lt_is_lt (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H);
+      intro; apply Rsqr_lt_abs_0; assumption
+      | rewrite Rplus_comm in H;
+        generalize (plus_lt_is_lt (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H);
+          intro; apply Rsqr_lt_abs_0; assumption ].
 Qed.
 
 Lemma triangle_rectangle_le :
- forall x y z:R,
-   Rsqr x + Rsqr y <= Rsqr z -> Rabs x <= Rabs z /\ Rabs y <= Rabs z.
-intros; split;
- [ generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H);
-    intro; apply Rsqr_le_abs_0; assumption
- | rewrite Rplus_comm in H;
-    generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H);
-    intro; apply Rsqr_le_abs_0; assumption ].
+  forall x y z:R,
+    Rsqr x + Rsqr y <= Rsqr z -> Rabs x <= Rabs z /\ Rabs y <= Rabs z.
+Proof.
+  intros; split;
+    [ generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (Rle_0_sqr y) H);
+      intro; apply Rsqr_le_abs_0; assumption
+      | rewrite Rplus_comm in H;
+        generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (Rle_0_sqr x) H);
+          intro; apply Rsqr_le_abs_0; assumption ].
 Qed.
 
 Lemma Rsqr_inv : forall x:R, x <> 0 -> Rsqr (/ x) = / Rsqr x.
-intros; unfold Rsqr in |- *.
-rewrite Rinv_mult_distr; try reflexivity || assumption.
+Proof.
+  intros; unfold Rsqr in |- *.
+  rewrite Rinv_mult_distr; try reflexivity || assumption.
 Qed.
 
 Lemma canonical_Rsqr :
- forall (a:nonzeroreal) (b c x:R),
-   a * Rsqr x + b * x + c =
-   a * Rsqr (x + b / (2 * a)) + (4 * a * c - Rsqr b) / (4 * a).
-intros.
-rewrite Rsqr_plus.
-repeat rewrite Rmult_plus_distr_l.
-repeat rewrite Rplus_assoc.
-apply Rplus_eq_compat_l.
-unfold Rdiv, Rminus in |- *.
-replace (2 * 1 + 2 * 1) with 4; [ idtac | ring ].
-rewrite (Rmult_plus_distr_r (4 * a * c) (- Rsqr b) (/ (4 * a))).
-rewrite Rsqr_mult.
-repeat rewrite Rinv_mult_distr.
-repeat rewrite (Rmult_comm a).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm 2).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm (/ 2)).
-rewrite (Rmult_comm 2).
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm a).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm 2).
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-repeat rewrite Rplus_assoc.
-rewrite (Rplus_comm (Rsqr b * (Rsqr (/ a * / 2) * a))).
-repeat rewrite Rplus_assoc.
-rewrite (Rmult_comm x).
-apply Rplus_eq_compat_l.
-rewrite (Rmult_comm (/ a)).
-unfold Rsqr in |- *; repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-ring.
-apply (cond_nonzero a).
-discrR.
-apply (cond_nonzero a).
-discrR.
-discrR.
-apply (cond_nonzero a).
-discrR.
-discrR.
-discrR.
-apply (cond_nonzero a).
-discrR.
-apply (cond_nonzero a).
+  forall (a:nonzeroreal) (b c x:R),
+    a * Rsqr x + b * x + c =
+    a * Rsqr (x + b / (2 * a)) + (4 * a * c - Rsqr b) / (4 * a).
+Proof.
+  intros.
+  rewrite Rsqr_plus.
+  repeat rewrite Rmult_plus_distr_l.
+  repeat rewrite Rplus_assoc.
+  apply Rplus_eq_compat_l.
+  unfold Rdiv, Rminus in |- *.
+  replace (2 * 1 + 2 * 1) with 4; [ idtac | ring ].
+  rewrite (Rmult_plus_distr_r (4 * a * c) (- Rsqr b) (/ (4 * a))).
+  rewrite Rsqr_mult.
+  repeat rewrite Rinv_mult_distr.
+  repeat rewrite (Rmult_comm a).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm 2).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm (/ 2)).
+  rewrite (Rmult_comm 2).
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm a).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm 2).
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  repeat rewrite Rplus_assoc.
+  rewrite (Rplus_comm (Rsqr b * (Rsqr (/ a * / 2) * a))).
+  repeat rewrite Rplus_assoc.
+  rewrite (Rmult_comm x).
+  apply Rplus_eq_compat_l.
+  rewrite (Rmult_comm (/ a)).
+  unfold Rsqr in |- *; repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  ring.
+  apply (cond_nonzero a).
+  discrR.
+  apply (cond_nonzero a).
+  discrR.
+  discrR.
+  apply (cond_nonzero a).
+  discrR.
+  discrR.
+  discrR.
+  apply (cond_nonzero a).
+  discrR.
+  apply (cond_nonzero a).
 Qed.
 
 Lemma Rsqr_eq : forall x y:R, Rsqr x = Rsqr y -> x = y \/ x = - y.
-intros; unfold Rsqr in H;
- generalize (Rplus_eq_compat_l (- (y * y)) (x * x) (y * y) H);
- rewrite Rplus_opp_l; replace (- (y * y) + x * x) with ((x - y) * (x + y)).
-intro; generalize (Rmult_integral (x - y) (x + y) H0); intro; elim H1; intros.
-left; apply Rminus_diag_uniq; assumption.
-right; apply Rminus_diag_uniq; unfold Rminus in |- *; rewrite Ropp_involutive;
- assumption.
-ring.
-Qed.
\ No newline at end of file
+Proof.
+  intros; unfold Rsqr in H;
+    generalize (Rplus_eq_compat_l (- (y * y)) (x * x) (y * y) H);
+      rewrite Rplus_opp_l; replace (- (y * y) + x * x) with ((x - y) * (x + y)).
+  intro; generalize (Rmult_integral (x - y) (x + y) H0); intro; elim H1; intros.
+  left; apply Rminus_diag_uniq; assumption.
+  right; apply Rminus_diag_uniq; unfold Rminus in |- *; rewrite Ropp_involutive;
+    assumption.
+  ring.
+Qed.
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
index 660b0527..736365a0 100644
--- a/theories/Reals/R_sqrt.v
+++ b/theories/Reals/R_sqrt.v
@@ -6,219 +6,242 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: R_sqrt.v,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: R_sqrt.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rsqrt_def. Open Local Scope R_scope.
 
-(* Here is a continuous extension of Rsqrt on R *)
+(** * Continuous extension of Rsqrt on R *)
 Definition sqrt (x:R) : R :=
   match Rcase_abs x with
-  | left _ => 0
-  | right a => Rsqrt (mknonnegreal x (Rge_le _ _ a))
+    | left _ => 0
+    | right a => Rsqrt (mknonnegreal x (Rge_le _ _ a))
   end.
 
 Lemma sqrt_positivity : forall x:R, 0 <= x -> 0 <= sqrt x.
-intros.
-unfold sqrt in |- *.
-case (Rcase_abs x); intro.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
-apply Rsqrt_positivity.
+Proof.
+  intros.
+  unfold sqrt in |- *.
+  case (Rcase_abs x); intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
+  apply Rsqrt_positivity.
 Qed.
 
 Lemma sqrt_sqrt : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
-intros.
-unfold sqrt in |- *.
-case (Rcase_abs x); intro.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
-rewrite Rsqrt_Rsqrt; reflexivity.
+Proof.
+  intros.
+  unfold sqrt in |- *.
+  case (Rcase_abs x); intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
+  rewrite Rsqrt_Rsqrt; reflexivity.
 Qed.
 
 Lemma sqrt_0 : sqrt 0 = 0.
-apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity. 
+Proof.
+  apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity. 
 Qed.
 
 Lemma sqrt_1 : sqrt 1 = 1.
-apply (Rsqr_inj (sqrt 1) 1);
- [ apply sqrt_positivity; left
- | left
- | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ]; 
- apply Rlt_0_1.
+Proof.
+  apply (Rsqr_inj (sqrt 1) 1);
+    [ apply sqrt_positivity; left
+      | left
+      | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ]; 
+    apply Rlt_0_1.
 Qed.
 
 Lemma sqrt_eq_0 : forall x:R, 0 <= x -> sqrt x = 0 -> x = 0.
-intros; cut (Rsqr (sqrt x) = 0).
-intro; unfold Rsqr in H1; rewrite sqrt_sqrt in H1; assumption.
-rewrite H0; apply Rsqr_0.
+Proof.
+  intros; cut (Rsqr (sqrt x) = 0).
+  intro; unfold Rsqr in H1; rewrite sqrt_sqrt in H1; assumption.
+  rewrite H0; apply Rsqr_0.
 Qed.
 
 Lemma sqrt_lem_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = y -> y * y = x.
-intros; rewrite <- H1; apply (sqrt_sqrt x H).
+Proof.
+  intros; rewrite <- H1; apply (sqrt_sqrt x H).
 Qed.
 
-Lemma sqtr_lem_1 : forall x y:R, 0 <= x -> 0 <= y -> y * y = x -> sqrt x = y.
-intros; apply Rsqr_inj;
- [ apply (sqrt_positivity x H)
- | assumption
- | unfold Rsqr in |- *; rewrite H1; apply (sqrt_sqrt x H) ].
+Lemma sqrt_lem_1 : forall x y:R, 0 <= x -> 0 <= y -> y * y = x -> sqrt x = y.
+Proof.
+  intros; apply Rsqr_inj;
+    [ apply (sqrt_positivity x H)
+      | assumption
+      | unfold Rsqr in |- *; rewrite H1; apply (sqrt_sqrt x H) ].
 Qed.
 
 Lemma sqrt_def : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
-intros; apply (sqrt_sqrt x H).
+Proof.
+  intros; apply (sqrt_sqrt x H).
 Qed.
 
 Lemma sqrt_square : forall x:R, 0 <= x -> sqrt (x * x) = x.
-intros;
- apply
-  (Rsqr_inj (sqrt (Rsqr x)) x (sqrt_positivity (Rsqr x) (Rle_0_sqr x)) H);
- unfold Rsqr in |- *; apply (sqrt_sqrt (Rsqr x) (Rle_0_sqr x)).
+Proof.
+  intros;
+    apply
+      (Rsqr_inj (sqrt (Rsqr x)) x (sqrt_positivity (Rsqr x) (Rle_0_sqr x)) H);
+      unfold Rsqr in |- *; apply (sqrt_sqrt (Rsqr x) (Rle_0_sqr x)).
 Qed.
 
 Lemma sqrt_Rsqr : forall x:R, 0 <= x -> sqrt (Rsqr x) = x.
-intros; unfold Rsqr in |- *; apply sqrt_square; assumption.
+Proof.
+  intros; unfold Rsqr in |- *; apply sqrt_square; assumption.
 Qed.
 
 Lemma sqrt_Rsqr_abs : forall x:R, sqrt (Rsqr x) = Rabs x.
-intro x; rewrite Rsqr_abs; apply sqrt_Rsqr; apply Rabs_pos.
+Proof.
+  intro x; rewrite Rsqr_abs; apply sqrt_Rsqr; apply Rabs_pos.
 Qed.
 
 Lemma Rsqr_sqrt : forall x:R, 0 <= x -> Rsqr (sqrt x) = x.
-intros x H1; unfold Rsqr in |- *; apply (sqrt_sqrt x H1).
+Proof.
+  intros x H1; unfold Rsqr in |- *; apply (sqrt_sqrt x H1).
 Qed.
 
 Lemma sqrt_mult :
- forall x y:R, 0 <= x -> 0 <= y -> sqrt (x * y) = sqrt x * sqrt y.
-intros x y H1 H2;
- apply
-  (Rsqr_inj (sqrt (x * y)) (sqrt x * sqrt y)
-     (sqrt_positivity (x * y) (Rmult_le_pos x y H1 H2))
-     (Rmult_le_pos (sqrt x) (sqrt y) (sqrt_positivity x H1)
-        (sqrt_positivity y H2))); rewrite Rsqr_mult; 
- repeat rewrite Rsqr_sqrt;
- [ ring | assumption | assumption | apply (Rmult_le_pos x y H1 H2) ].
+  forall x y:R, 0 <= x -> 0 <= y -> sqrt (x * y) = sqrt x * sqrt y.
+Proof.
+  intros x y H1 H2;
+    apply
+      (Rsqr_inj (sqrt (x * y)) (sqrt x * sqrt y)
+        (sqrt_positivity (x * y) (Rmult_le_pos x y H1 H2))
+        (Rmult_le_pos (sqrt x) (sqrt y) (sqrt_positivity x H1)
+          (sqrt_positivity y H2))); rewrite Rsqr_mult; 
+      repeat rewrite Rsqr_sqrt;
+        [ ring | assumption | assumption | apply (Rmult_le_pos x y H1 H2) ].
 Qed.
 
 Lemma sqrt_lt_R0 : forall x:R, 0 < x -> 0 < sqrt x.
-intros x H1; apply Rsqr_incrst_0;
- [ rewrite Rsqr_0; rewrite Rsqr_sqrt; [ assumption | left; assumption ]
- | right; reflexivity
- | apply (sqrt_positivity x (Rlt_le 0 x H1)) ].
+Proof.
+  intros x H1; apply Rsqr_incrst_0;
+    [ rewrite Rsqr_0; rewrite Rsqr_sqrt; [ assumption | left; assumption ]
+      | right; reflexivity
+      | apply (sqrt_positivity x (Rlt_le 0 x H1)) ].
 Qed.
 
 Lemma sqrt_div :
- forall x y:R, 0 <= x -> 0 < y -> sqrt (x / y) = sqrt x / sqrt y.
-intros x y H1 H2; apply Rsqr_inj;
- [ apply sqrt_positivity; apply (Rmult_le_pos x (/ y));
-    [ assumption
-    | generalize (Rinv_0_lt_compat y H2); clear H2; intro H2; left;
-       assumption ]
- | apply (Rmult_le_pos (sqrt x) (/ sqrt y));
-    [ apply (sqrt_positivity x H1)
-    | generalize (sqrt_lt_R0 y H2); clear H2; intro H2;
-       generalize (Rinv_0_lt_compat (sqrt y) H2); clear H2; 
-       intro H2; left; assumption ]
- | rewrite Rsqr_div; repeat rewrite Rsqr_sqrt;
-    [ reflexivity
-    | left; assumption
-    | assumption
-    | generalize (Rinv_0_lt_compat y H2); intro H3;
-       generalize (Rlt_le 0 (/ y) H3); intro H4;
-       apply (Rmult_le_pos x (/ y) H1 H4)
-    | red in |- *; intro H3; generalize (Rlt_le 0 y H2); intro H4;
-       generalize (sqrt_eq_0 y H4 H3); intro H5; rewrite H5 in H2;
-       elim (Rlt_irrefl 0 H2) ] ].
+  forall x y:R, 0 <= x -> 0 < y -> sqrt (x / y) = sqrt x / sqrt y.
+Proof.
+  intros x y H1 H2; apply Rsqr_inj;
+    [ apply sqrt_positivity; apply (Rmult_le_pos x (/ y));
+      [ assumption
+        | generalize (Rinv_0_lt_compat y H2); clear H2; intro H2; left;
+          assumption ]
+      | apply (Rmult_le_pos (sqrt x) (/ sqrt y));
+        [ apply (sqrt_positivity x H1)
+          | generalize (sqrt_lt_R0 y H2); clear H2; intro H2;
+            generalize (Rinv_0_lt_compat (sqrt y) H2); clear H2; 
+              intro H2; left; assumption ]
+      | rewrite Rsqr_div; repeat rewrite Rsqr_sqrt;
+        [ reflexivity
+          | left; assumption
+          | assumption
+          | generalize (Rinv_0_lt_compat y H2); intro H3;
+            generalize (Rlt_le 0 (/ y) H3); intro H4;
+              apply (Rmult_le_pos x (/ y) H1 H4)
+          | red in |- *; intro H3; generalize (Rlt_le 0 y H2); intro H4;
+            generalize (sqrt_eq_0 y H4 H3); intro H5; rewrite H5 in H2;
+              elim (Rlt_irrefl 0 H2) ] ].
 Qed.
 
 Lemma sqrt_lt_0 : forall x y:R, 0 <= x -> 0 <= y -> sqrt x < sqrt y -> x < y.
-intros x y H1 H2 H3;
- generalize
-  (Rsqr_incrst_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1)
-     (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4;
- rewrite (Rsqr_sqrt y H2) in H4; assumption.
+Proof.
+  intros x y H1 H2 H3;
+    generalize
+      (Rsqr_incrst_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1)
+        (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4;
+      rewrite (Rsqr_sqrt y H2) in H4; assumption.
 Qed.
 
 Lemma sqrt_lt_1 : forall x y:R, 0 <= x -> 0 <= y -> x < y -> sqrt x < sqrt y.
-intros x y H1 H2 H3; apply Rsqr_incrst_0;
- [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption
- | apply (sqrt_positivity x H1)
- | apply (sqrt_positivity y H2) ].
+Proof.
+  intros x y H1 H2 H3; apply Rsqr_incrst_0;
+    [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption
+      | apply (sqrt_positivity x H1)
+      | apply (sqrt_positivity y H2) ].
 Qed.
 
 Lemma sqrt_le_0 :
- forall x y:R, 0 <= x -> 0 <= y -> sqrt x <= sqrt y -> x <= y.
-intros x y H1 H2 H3;
- generalize
-  (Rsqr_incr_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1)
-     (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4;
- rewrite (Rsqr_sqrt y H2) in H4; assumption.
+  forall x y:R, 0 <= x -> 0 <= y -> sqrt x <= sqrt y -> x <= y.
+Proof.
+  intros x y H1 H2 H3;
+    generalize
+      (Rsqr_incr_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1)
+        (sqrt_positivity y H2)); intro H4; rewrite (Rsqr_sqrt x H1) in H4;
+      rewrite (Rsqr_sqrt y H2) in H4; assumption.
 Qed.
 
 Lemma sqrt_le_1 :
- forall x y:R, 0 <= x -> 0 <= y -> x <= y -> sqrt x <= sqrt y.
-intros x y H1 H2 H3; apply Rsqr_incr_0;
- [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption
- | apply (sqrt_positivity x H1)
- | apply (sqrt_positivity y H2) ].
+  forall x y:R, 0 <= x -> 0 <= y -> x <= y -> sqrt x <= sqrt y.
+Proof.
+  intros x y H1 H2 H3; apply Rsqr_incr_0;
+    [ rewrite (Rsqr_sqrt x H1); rewrite (Rsqr_sqrt y H2); assumption
+      | apply (sqrt_positivity x H1)
+      | apply (sqrt_positivity y H2) ].
 Qed.
 
 Lemma sqrt_inj : forall x y:R, 0 <= x -> 0 <= y -> sqrt x = sqrt y -> x = y.
-intros; cut (Rsqr (sqrt x) = Rsqr (sqrt y)).
-intro; rewrite (Rsqr_sqrt x H) in H2; rewrite (Rsqr_sqrt y H0) in H2;
- assumption.
-rewrite H1; reflexivity.
+Proof.
+  intros; cut (Rsqr (sqrt x) = Rsqr (sqrt y)).
+  intro; rewrite (Rsqr_sqrt x H) in H2; rewrite (Rsqr_sqrt y H0) in H2;
+    assumption.
+  rewrite H1; reflexivity.
 Qed.
 
 Lemma sqrt_less : forall x:R, 0 <= x -> 1 < x -> sqrt x < x.
-intros x H1 H2; generalize (sqrt_lt_1 1 x (Rlt_le 0 1 Rlt_0_1) H1 H2);
- intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); 
- intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 2 in |- *;
- rewrite <- (sqrt_def x H1);
- apply
-  (Rmult_lt_compat_l (sqrt x) 1 (sqrt x)
-     (sqrt_lt_R0 x (Rlt_trans 0 1 x Rlt_0_1 H2)) H3).
+Proof.
+  intros x H1 H2; generalize (sqrt_lt_1 1 x (Rlt_le 0 1 Rlt_0_1) H1 H2);
+    intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); 
+      intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 2 in |- *;
+        rewrite <- (sqrt_def x H1);
+          apply
+            (Rmult_lt_compat_l (sqrt x) 1 (sqrt x)
+              (sqrt_lt_R0 x (Rlt_trans 0 1 x Rlt_0_1 H2)) H3).
 Qed.
 
 Lemma sqrt_more : forall x:R, 0 < x -> x < 1 -> x < sqrt x.
-intros x H1 H2;
- generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); 
- intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); 
- intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1 in |- *;
- rewrite <- (sqrt_def x (Rlt_le 0 x H1));
- apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3).
+Proof.
+  intros x H1 H2;
+    generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); 
+      intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); 
+        intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1 in |- *;
+          rewrite <- (sqrt_def x (Rlt_le 0 x H1));
+            apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3).
 Qed.
 
 Lemma sqrt_cauchy :
- forall a b c d:R,
-   a * c + b * d <= sqrt (Rsqr a + Rsqr b) * sqrt (Rsqr c + Rsqr d).
-intros a b c d; apply Rsqr_incr_0_var;
- [ rewrite Rsqr_mult; repeat rewrite Rsqr_sqrt; unfold Rsqr in |- *;
-    [ replace ((a * c + b * d) * (a * c + b * d)) with
-       (a * a * c * c + b * b * d * d + 2 * a * b * c * d);
-       [ replace ((a * a + b * b) * (c * c + d * d)) with
+  forall a b c d:R,
+    a * c + b * d <= sqrt (Rsqr a + Rsqr b) * sqrt (Rsqr c + Rsqr d).
+Proof.
+  intros a b c d; apply Rsqr_incr_0_var;
+    [ rewrite Rsqr_mult; repeat rewrite Rsqr_sqrt; unfold Rsqr in |- *;
+      [ replace ((a * c + b * d) * (a * c + b * d)) with
+        (a * a * c * c + b * b * d * d + 2 * a * b * c * d);
+        [ replace ((a * a + b * b) * (c * c + d * d)) with
           (a * a * c * c + b * b * d * d + (a * a * d * d + b * b * c * c));
           [ apply Rplus_le_compat_l;
-             replace (a * a * d * d + b * b * c * c) with
-              (2 * a * b * c * d +
-               (a * a * d * d + b * b * c * c - 2 * a * b * c * d));
-             [ pattern (2 * a * b * c * d) at 1 in |- *; rewrite <- Rplus_0_r;
-                apply Rplus_le_compat_l;
+            replace (a * a * d * d + b * b * c * c) with
+            (2 * a * b * c * d +
+              (a * a * d * d + b * b * c * c - 2 * a * b * c * d));
+            [ pattern (2 * a * b * c * d) at 1 in |- *; rewrite <- Rplus_0_r;
+              apply Rplus_le_compat_l;
                 replace (a * a * d * d + b * b * c * c - 2 * a * b * c * d)
-                 with (Rsqr (a * d - b * c));
+              with (Rsqr (a * d - b * c));
                 [ apply Rle_0_sqr | unfold Rsqr in |- *; ring ]
-             | ring ]
+              | ring ]
+            | ring ]
           | ring ]
-       | ring ]
-    | apply
-       (Rplus_le_le_0_compat (Rsqr c) (Rsqr d) (Rle_0_sqr c) (Rle_0_sqr d))
-    | apply
-       (Rplus_le_le_0_compat (Rsqr a) (Rsqr b) (Rle_0_sqr a) (Rle_0_sqr b)) ]
- | apply Rmult_le_pos; apply sqrt_positivity; apply Rplus_le_le_0_compat;
-    apply Rle_0_sqr ].
+        | apply
+          (Rplus_le_le_0_compat (Rsqr c) (Rsqr d) (Rle_0_sqr c) (Rle_0_sqr d))
+        | apply
+          (Rplus_le_le_0_compat (Rsqr a) (Rsqr b) (Rle_0_sqr a) (Rle_0_sqr b)) ]
+      | apply Rmult_le_pos; apply sqrt_positivity; apply Rplus_le_le_0_compat;
+        apply Rle_0_sqr ].
 Qed.
 
 (************************************************************)
-(* Resolution of [a*X^2+b*X+c=0]                            *)
+(** * Resolution of [a*X^2+b*X+c=0]                         *)
 (************************************************************)
 
 Definition Delta (a:nonzeroreal) (b c:R) : R := Rsqr b - 4 * a * c.
@@ -232,168 +255,170 @@ Definition sol_x2 (a:nonzeroreal) (b c:R) : R :=
   (- b - sqrt (Delta a b c)) / (2 * a).
 
 Lemma Rsqr_sol_eq_0_1 :
- forall (a:nonzeroreal) (b c x:R),
-   Delta_is_pos a b c ->
-   x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0.
-intros; elim H0; intro.
-unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
- repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg;
- rewrite Rsqr_sqrt.
-rewrite Rsqr_inv.
-unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr.
-repeat rewrite Rmult_assoc; rewrite (Rmult_comm a).
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite Rmult_plus_distr_r.
-repeat rewrite Rmult_assoc.
-pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite
- (Rmult_plus_distr_r (- b) (sqrt (b * b - 2 * (2 * (a * c)))) (/ 2 * / a))
- .
-rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
-replace
- (- b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) +
-  (b * (- b * (/ 2 * / a)) +
-   (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with
- (b * (- b * (/ 2 * / a)) + c).
-unfold Rminus in |- *; repeat rewrite <- Rplus_assoc.
-replace (b * b + b * b) with (2 * (b * b)).
-rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
- rewrite (Rmult_comm 2).
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc;
- rewrite (Rmult_comm 2).
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm a); rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite <- Rmult_opp_opp.
-ring.
-apply (cond_nonzero a).
-discrR.
-discrR.
-discrR.
-ring.
-ring.
-discrR.
-apply (cond_nonzero a).
-discrR.
-apply (cond_nonzero a).
-apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
-apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
-apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
-assumption.
-unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
- repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg;
- rewrite Rsqr_sqrt.
-rewrite Rsqr_inv.
-unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr;
- repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm a); repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
-rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
- pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r;
- rewrite
-  (Rmult_plus_distr_r (- b) (- sqrt (b * b + - (2 * (2 * (a * c)))))
-     (/ 2 * / a)).
-rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
-rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_involutive.
-replace
- (b * (sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) +
-  (b * (- b * (/ 2 * / a)) +
-   (b * (- sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + c))) with
- (b * (- b * (/ 2 * / a)) + c).
-repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)).
-rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc;
- rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; 
- rewrite <- Rinv_l_sym.
-rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; repeat rewrite Rmult_assoc; rewrite (Rmult_comm a);
- rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite <- Rmult_opp_opp; ring.
-apply (cond_nonzero a).
-discrR.
-discrR.
-discrR.
-ring.
-ring.
-discrR.
-apply (cond_nonzero a).
-discrR.
-discrR.
-apply (cond_nonzero a).
-apply prod_neq_R0; discrR || apply (cond_nonzero a).
-apply prod_neq_R0; discrR || apply (cond_nonzero a).
-apply prod_neq_R0; discrR || apply (cond_nonzero a).
-assumption.
+  forall (a:nonzeroreal) (b c x:R),
+    Delta_is_pos a b c ->
+    x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0.
+Proof.
+  intros; elim H0; intro.
+  unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
+    repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg;
+      rewrite Rsqr_sqrt.
+  rewrite Rsqr_inv.
+  unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr.
+  repeat rewrite Rmult_assoc; rewrite (Rmult_comm a).
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite Rmult_plus_distr_r.
+  repeat rewrite Rmult_assoc.
+  pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite
+    (Rmult_plus_distr_r (- b) (sqrt (b * b - 2 * (2 * (a * c)))) (/ 2 * / a))
+    .
+  rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
+  replace
+  (- b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) +
+    (b * (- b * (/ 2 * / a)) +
+      (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with
+  (b * (- b * (/ 2 * / a)) + c).
+  unfold Rminus in |- *; repeat rewrite <- Rplus_assoc.
+  replace (b * b + b * b) with (2 * (b * b)).
+  rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
+    rewrite (Rmult_comm 2).
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc;
+    rewrite (Rmult_comm 2).
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm a); rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite <- Rmult_opp_opp.
+  ring.
+  apply (cond_nonzero a).
+  discrR.
+  discrR.
+  discrR.
+  ring.
+  ring.
+  discrR.
+  apply (cond_nonzero a).
+  discrR.
+  apply (cond_nonzero a).
+  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
+  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
+  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
+  assumption.
+  unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
+    repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg;
+      rewrite Rsqr_sqrt.
+  rewrite Rsqr_inv.
+  unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr;
+    repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm a); repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
+  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
+    pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r;
+    rewrite
+      (Rmult_plus_distr_r (- b) (- sqrt (b * b + - (2 * (2 * (a * c)))))
+        (/ 2 * / a)).
+  rewrite Rmult_plus_distr_l; repeat rewrite Rplus_assoc.
+  rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_involutive.
+  replace
+  (b * (sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) +
+    (b * (- b * (/ 2 * / a)) +
+      (b * (- sqrt (b * b + - (2 * (2 * (a * c)))) * (/ 2 * / a)) + c))) with
+  (b * (- b * (/ 2 * / a)) + c).
+  repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)).
+  rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc;
+    rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; 
+      rewrite <- Rinv_l_sym.
+  rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; repeat rewrite Rmult_assoc; rewrite (Rmult_comm a);
+    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite <- Rmult_opp_opp; ring.
+  apply (cond_nonzero a).
+  discrR.
+  discrR.
+  discrR.
+  ring.
+  ring.
+  discrR.
+  apply (cond_nonzero a).
+  discrR.
+  discrR.
+  apply (cond_nonzero a).
+  apply prod_neq_R0; discrR || apply (cond_nonzero a).
+  apply prod_neq_R0; discrR || apply (cond_nonzero a).
+  apply prod_neq_R0; discrR || apply (cond_nonzero a).
+  assumption.
 Qed.
 
 Lemma Rsqr_sol_eq_0_0 :
- forall (a:nonzeroreal) (b c x:R),
-   Delta_is_pos a b c ->
-   a * Rsqr x + b * x + c = 0 -> x = sol_x1 a b c \/ x = sol_x2 a b c.
-intros; rewrite (canonical_Rsqr a b c x) in H0; rewrite Rplus_comm in H0;
- generalize
-  (Rplus_opp_r_uniq ((4 * a * c - Rsqr b) / (4 * a))
-     (a * Rsqr (x + b / (2 * a))) H0); cut (Rsqr b - 4 * a * c = Delta a b c).
-intro;
- replace (- ((4 * a * c - Rsqr b) / (4 * a))) with
-  ((Rsqr b - 4 * a * c) / (4 * a)).
-rewrite H1; intro;
- generalize
-  (Rmult_eq_compat_l (/ a) (a * Rsqr (x + b / (2 * a)))
-     (Delta a b c / (4 * a)) H2);
- replace (/ a * (a * Rsqr (x + b / (2 * a)))) with (Rsqr (x + b / (2 * a))).
-replace (/ a * (Delta a b c / (4 * a))) with
- (Rsqr (sqrt (Delta a b c) / (2 * a))).
-intro;
- generalize (Rsqr_eq (x + b / (2 * a)) (sqrt (Delta a b c) / (2 * a)) H3);
- intro; elim H4; intro.
-left; unfold sol_x1 in |- *;
- generalize
-  (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
-     (sqrt (Delta a b c) / (2 * a)) H5);
- replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
-intro; rewrite H6; unfold Rdiv in |- *; ring.
-ring.
-right; unfold sol_x2 in |- *;
- generalize
-  (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
-     (- (sqrt (Delta a b c) / (2 * a))) H5);
- replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
-intro; rewrite H6; unfold Rdiv in |- *; ring.
-ring.
-rewrite Rsqr_div.
-rewrite Rsqr_sqrt.
-unfold Rdiv in |- *.
-repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm (/ a)).
-rewrite Rmult_assoc.
-rewrite <- Rinv_mult_distr.
-replace (2 * (2 * a) * a) with (Rsqr (2 * a)).
-reflexivity.
-ring_Rsqr.
-rewrite <- Rmult_assoc; apply prod_neq_R0;
- [ discrR | apply (cond_nonzero a) ].
-apply (cond_nonzero a).
-assumption.
-apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-symmetry  in |- *; apply Rmult_1_l.
-apply (cond_nonzero a).
-unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
-rewrite Ropp_minus_distr.
-reflexivity.
-reflexivity.
-Qed.
\ No newline at end of file
+  forall (a:nonzeroreal) (b c x:R),
+    Delta_is_pos a b c ->
+    a * Rsqr x + b * x + c = 0 -> x = sol_x1 a b c \/ x = sol_x2 a b c.
+Proof.
+  intros; rewrite (canonical_Rsqr a b c x) in H0; rewrite Rplus_comm in H0;
+    generalize
+      (Rplus_opp_r_uniq ((4 * a * c - Rsqr b) / (4 * a))
+        (a * Rsqr (x + b / (2 * a))) H0); cut (Rsqr b - 4 * a * c = Delta a b c).
+  intro;
+    replace (- ((4 * a * c - Rsqr b) / (4 * a))) with
+    ((Rsqr b - 4 * a * c) / (4 * a)).
+  rewrite H1; intro;
+    generalize
+      (Rmult_eq_compat_l (/ a) (a * Rsqr (x + b / (2 * a)))
+        (Delta a b c / (4 * a)) H2);
+      replace (/ a * (a * Rsqr (x + b / (2 * a)))) with (Rsqr (x + b / (2 * a))).
+  replace (/ a * (Delta a b c / (4 * a))) with
+  (Rsqr (sqrt (Delta a b c) / (2 * a))).
+  intro;
+    generalize (Rsqr_eq (x + b / (2 * a)) (sqrt (Delta a b c) / (2 * a)) H3);
+      intro; elim H4; intro.
+  left; unfold sol_x1 in |- *;
+    generalize
+      (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
+        (sqrt (Delta a b c) / (2 * a)) H5);
+      replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
+  intro; rewrite H6; unfold Rdiv in |- *; ring.
+  ring.
+  right; unfold sol_x2 in |- *;
+    generalize
+      (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
+        (- (sqrt (Delta a b c) / (2 * a))) H5);
+      replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
+  intro; rewrite H6; unfold Rdiv in |- *; ring.
+  ring.
+  rewrite Rsqr_div.
+  rewrite Rsqr_sqrt.
+  unfold Rdiv in |- *.
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm (/ a)).
+  rewrite Rmult_assoc.
+  rewrite <- Rinv_mult_distr.
+  replace (2 * (2 * a) * a) with (Rsqr (2 * a)).
+  reflexivity.
+  ring_Rsqr.
+  rewrite <- Rmult_assoc; apply prod_neq_R0;
+    [ discrR | apply (cond_nonzero a) ].
+  apply (cond_nonzero a).
+  assumption.
+  apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  symmetry  in |- *; apply Rmult_1_l.
+  apply (cond_nonzero a).
+  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+  rewrite Ropp_minus_distr.
+  reflexivity.
+  reflexivity.
+Qed.
diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v
index 88af8b20..d712f74b 100644
--- a/theories/Reals/Ranalysis.v
+++ b/theories/Reals/Ranalysis.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Ranalysis.v,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*i $Id: Ranalysis.v 9319 2006-10-30 12:41:21Z barras $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -34,769 +34,768 @@ Axiom AppVar : R.
 (**********)
 Ltac intro_hyp_glob trm :=
   match constr:trm with
-  | (?X1 + ?X2)%F =>
+    | (?X1 + ?X2)%F =>
       match goal with
-      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
-      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
-      | _ => idtac
+        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+        | _ => idtac
       end
-  | (?X1 - ?X2)%F =>
+    | (?X1 - ?X2)%F =>
       match goal with
-      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
-      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
-      | _ => idtac
+        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+        | _ => idtac
       end
-  | (?X1 * ?X2)%F =>
+    | (?X1 * ?X2)%F =>
       match goal with
-      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
-      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
-      | _ => idtac
+        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+        | _ => idtac
       end
-  | (?X1 / ?X2)%F =>
+    | (?X1 / ?X2)%F =>
       let aux := constr:X2 in
+        match goal with
+          | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
+            intro_hyp_glob X1; intro_hyp_glob X2
+          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
+            intro_hyp_glob X1; intro_hyp_glob X2
+          |  |- (derivable _) =>
+            cut (forall x0:R, aux x0 <> 0);
+              [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
+          |  |- (continuity _) =>
+            cut (forall x0:R, aux x0 <> 0);
+              [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
+          | _ => idtac
+        end
+    | (comp ?X1 ?X2) =>
       match goal with
-      | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
-          intro_hyp_glob X1; intro_hyp_glob X2
-      | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
-          intro_hyp_glob X1; intro_hyp_glob X2
-      |  |- (derivable _) =>
-          cut (forall x0:R, aux x0 <> 0);
-           [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
-      |  |- (continuity _) =>
-          cut (forall x0:R, aux x0 <> 0);
-           [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
-      | _ => idtac
-      end
-  | (comp ?X1 ?X2) =>
-      match goal with
-      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
-      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
-      | _ => idtac
+        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+        | _ => idtac
       end
-  | (- ?X1)%F =>
+    | (- ?X1)%F =>
       match goal with
-      |  |- (derivable _) => intro_hyp_glob X1
-      |  |- (continuity _) => intro_hyp_glob X1
-      | _ => idtac
+        |  |- (derivable _) => intro_hyp_glob X1
+        |  |- (continuity _) => intro_hyp_glob X1
+        | _ => idtac
       end
-  | (/ ?X1)%F =>
+    | (/ ?X1)%F =>
       let aux := constr:X1 in
-      match goal with
-      | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
-          intro_hyp_glob X1
-      | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => 
-      intro_hyp_glob X1
-      |  |- (derivable _) =>
-          cut (forall x0:R, aux x0 <> 0);
-           [ intro; intro_hyp_glob X1 | try assumption ]
-      |  |- (continuity _) =>
-          cut (forall x0:R, aux x0 <> 0);
-           [ intro; intro_hyp_glob X1 | try assumption ]
-      | _ => idtac
-      end
-  | cos => idtac
-  | sin => idtac
-  | cosh => idtac
-  | sinh => idtac
-  | exp => idtac
-  | Rsqr => idtac
-  | sqrt => idtac
-  | id => idtac
-  | (fct_cte _) => idtac
-  | (pow_fct _) => idtac
-  | Rabs => idtac
-  | ?X1 =>
+        match goal with
+          | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
+            intro_hyp_glob X1
+          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => 
+            intro_hyp_glob X1
+          |  |- (derivable _) =>
+            cut (forall x0:R, aux x0 <> 0);
+              [ intro; intro_hyp_glob X1 | try assumption ]
+          |  |- (continuity _) =>
+            cut (forall x0:R, aux x0 <> 0);
+              [ intro; intro_hyp_glob X1 | try assumption ]
+          | _ => idtac
+        end
+    | cos => idtac
+    | sin => idtac
+    | cosh => idtac
+    | sinh => idtac
+    | exp => idtac
+    | Rsqr => idtac
+    | sqrt => idtac
+    | id => idtac
+    | (fct_cte _) => idtac
+    | (pow_fct _) => idtac
+    | Rabs => idtac
+    | ?X1 =>
       let p := constr:X1 in
-      match goal with
-      | _:(derivable p) |- _ => idtac
-      |  |- (derivable p) => idtac
-      |  |- (derivable _) =>
-          cut (True -> derivable p);
-           [ intro HYPPD; cut (derivable p);
-              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-           | idtac ]
-      | _:(continuity p) |- _ => idtac
-      |  |- (continuity p) => idtac
-      |  |- (continuity _) =>
-          cut (True -> continuity p);
-           [ intro HYPPD; cut (continuity p);
-              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-           | idtac ]
-      | _ => idtac
-      end
+        match goal with
+          | _:(derivable p) |- _ => idtac
+          |  |- (derivable p) => idtac
+          |  |- (derivable _) =>
+            cut (True -> derivable p);
+              [ intro HYPPD; cut (derivable p);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          | _:(continuity p) |- _ => idtac
+          |  |- (continuity p) => idtac
+          |  |- (continuity _) =>
+            cut (True -> continuity p);
+              [ intro HYPPD; cut (continuity p);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          | _ => idtac
+        end
   end.
 
 (**********)
 Ltac intro_hyp_pt trm pt :=
   match constr:trm with
-  | (?X1 + ?X2)%F =>
+    | (?X1 + ?X2)%F =>
       match goal with
-      |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      |  |- (derive_pt _ _ _ = _) =>
+        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (derive_pt _ _ _ = _) =>
           intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      | _ => idtac
+        | _ => idtac
       end
-  | (?X1 - ?X2)%F =>
+    | (?X1 - ?X2)%F =>
       match goal with
-      |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      |  |- (derive_pt _ _ _ = _) =>
+        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (derive_pt _ _ _ = _) =>
           intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      | _ => idtac
+        | _ => idtac
       end
-  | (?X1 * ?X2)%F =>
+    | (?X1 * ?X2)%F =>
       match goal with
-      |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      |  |- (derive_pt _ _ _ = _) =>
+        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (derive_pt _ _ _ = _) =>
           intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      | _ => idtac
+        | _ => idtac
       end
-  | (?X1 / ?X2)%F =>
+    | (?X1 / ?X2)%F =>
       let aux := constr:X2 in
+        match goal with
+          | _:(aux pt <> 0) |- (derivable_pt _ _) =>
+            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | _:(aux pt <> 0) |- (continuity_pt _ _) =>
+            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
+            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          |  |- (derivable_pt _ _) =>
+            cut (aux pt <> 0);
+              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+          |  |- (continuity_pt _ _) =>
+            cut (aux pt <> 0);
+              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+          |  |- (derive_pt _ _ _ = _) =>
+            cut (aux pt <> 0);
+              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+          | _ => idtac
+        end
+    | (comp ?X1 ?X2) =>
       match goal with
-      | _:(aux pt <> 0) |- (derivable_pt _ _) =>
-          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      | _:(aux pt <> 0) |- (continuity_pt _ _) =>
-          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
-          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
-          generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
-          generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
-          generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-      |  |- (derivable_pt _ _) =>
-          cut (aux pt <> 0);
-           [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
-      |  |- (continuity_pt _ _) =>
-          cut (aux pt <> 0);
-           [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
-      |  |- (derive_pt _ _ _ = _) =>
-          cut (aux pt <> 0);
-           [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
-      | _ => idtac
-      end
-  | (comp ?X1 ?X2) =>
-      match goal with
-      |  |- (derivable_pt _ _) =>
+        |  |- (derivable_pt _ _) =>
           let pt_f1 := eval cbv beta in (X2 pt) in
-          (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
-      |  |- (continuity_pt _ _) =>
+            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+        |  |- (continuity_pt _ _) =>
           let pt_f1 := eval cbv beta in (X2 pt) in
-          (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
-      |  |- (derive_pt _ _ _ = _) =>
+            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+        |  |- (derive_pt _ _ _ = _) =>
           let pt_f1 := eval cbv beta in (X2 pt) in
-          (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
-      | _ => idtac
+            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+        | _ => idtac
       end
-  | (- ?X1)%F =>
+    | (- ?X1)%F =>
       match goal with
-      |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt
-      |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt
-      |  |- (derive_pt _ _ _ = _) => intro_hyp_pt X1 pt
-      | _ => idtac
+        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt
+        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt
+        |  |- (derive_pt _ _ _ = _) => intro_hyp_pt X1 pt
+        | _ => idtac
       end
-  | (/ ?X1)%F =>
+    | (/ ?X1)%F =>
       let aux := constr:X1 in
+        match goal with
+          | _:(aux pt <> 0) |- (derivable_pt _ _) =>
+            intro_hyp_pt X1 pt
+          | _:(aux pt <> 0) |- (continuity_pt _ _) =>
+            intro_hyp_pt X1 pt
+          | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
+            intro_hyp_pt X1 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt
+          |  |- (derivable_pt _ _) =>
+            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+          |  |- (continuity_pt _ _) =>
+            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+          |  |- (derive_pt _ _ _ = _) =>
+            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+          | _ => idtac
+        end
+    | cos => idtac
+    | sin => idtac
+    | cosh => idtac
+    | sinh => idtac
+    | exp => idtac
+    | Rsqr => idtac
+    | id => idtac
+    | (fct_cte _) => idtac
+    | (pow_fct _) => idtac
+    | sqrt =>
       match goal with
-      | _:(aux pt <> 0) |- (derivable_pt _ _) =>
-          intro_hyp_pt X1 pt
-      | _:(aux pt <> 0) |- (continuity_pt _ _) =>
-          intro_hyp_pt X1 pt
-      | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
-          intro_hyp_pt X1 pt
-      | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
-          generalize (id pt); intro; intro_hyp_pt X1 pt
-      | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
-          generalize (id pt); intro; intro_hyp_pt X1 pt
-      | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
-          generalize (id pt); intro; intro_hyp_pt X1 pt
-      |  |- (derivable_pt _ _) =>
-          cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
-      |  |- (continuity_pt _ _) =>
-          cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
-      |  |- (derive_pt _ _ _ = _) =>
-          cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
-      | _ => idtac
-      end
-  | cos => idtac
-  | sin => idtac
-  | cosh => idtac
-  | sinh => idtac
-  | exp => idtac
-  | Rsqr => idtac
-  | id => idtac
-  | (fct_cte _) => idtac
-  | (pow_fct _) => idtac
-  | sqrt =>
-      match goal with
-      |  |- (derivable_pt _ _) => cut (0 < pt); [ intro | try assumption ]
-      |  |- (continuity_pt _ _) =>
+        |  |- (derivable_pt _ _) => cut (0 < pt); [ intro | try assumption ]
+        |  |- (continuity_pt _ _) =>
           cut (0 <= pt); [ intro | try assumption ]
-      |  |- (derive_pt _ _ _ = _) =>
+        |  |- (derive_pt _ _ _ = _) =>
           cut (0 < pt); [ intro | try assumption ]
-      | _ => idtac
+        | _ => idtac
       end
-  | Rabs =>
+    | Rabs =>
       match goal with
-      |  |- (derivable_pt _ _) =>
+        |  |- (derivable_pt _ _) =>
           cut (pt <> 0); [ intro | try assumption ]
-      | _ => idtac
+        | _ => idtac
       end
-  | ?X1 =>
+    | ?X1 =>
       let p := constr:X1 in
-      match goal with
-      | _:(derivable_pt p pt) |- _ => idtac
-      |  |- (derivable_pt p pt) => idtac
-      |  |- (derivable_pt _ _) =>
-          cut (True -> derivable_pt p pt);
-           [ intro HYPPD; cut (derivable_pt p pt);
-              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-           | idtac ]
-      | _:(continuity_pt p pt) |- _ => idtac
-      |  |- (continuity_pt p pt) => idtac
-      |  |- (continuity_pt _ _) =>
-          cut (True -> continuity_pt p pt);
-           [ intro HYPPD; cut (continuity_pt p pt);
-              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-           | idtac ]
-      |  |- (derive_pt _ _ _ = _) =>
-          cut (True -> derivable_pt p pt);
-           [ intro HYPPD; cut (derivable_pt p pt);
-              [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-           | idtac ]
-      | _ => idtac
-      end
+        match goal with
+          | _:(derivable_pt p pt) |- _ => idtac
+          |  |- (derivable_pt p pt) => idtac
+          |  |- (derivable_pt _ _) =>
+            cut (True -> derivable_pt p pt);
+              [ intro HYPPD; cut (derivable_pt p pt);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          | _:(continuity_pt p pt) |- _ => idtac
+          |  |- (continuity_pt p pt) => idtac
+          |  |- (continuity_pt _ _) =>
+            cut (True -> continuity_pt p pt);
+              [ intro HYPPD; cut (continuity_pt p pt);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          |  |- (derive_pt _ _ _ = _) =>
+            cut (True -> derivable_pt p pt);
+              [ intro HYPPD; cut (derivable_pt p pt);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          | _ => idtac
+        end
   end.
- 
+
 (**********)
 Ltac is_diff_pt :=
   match goal with
-  |  |- (derivable_pt Rsqr _) =>
+    |  |- (derivable_pt Rsqr _) =>
       
   (* fonctions de base *)
-  apply derivable_pt_Rsqr
-  |  |- (derivable_pt id ?X1) => apply (derivable_pt_id X1)
-  |  |- (derivable_pt (fct_cte _) _) => apply derivable_pt_const
-  |  |- (derivable_pt sin _) => apply derivable_pt_sin
-  |  |- (derivable_pt cos _) => apply derivable_pt_cos
-  |  |- (derivable_pt sinh _) => apply derivable_pt_sinh
-  |  |- (derivable_pt cosh _) => apply derivable_pt_cosh
-  |  |- (derivable_pt exp _) => apply derivable_pt_exp
-  |  |- (derivable_pt (pow_fct _) _) =>
+      apply derivable_pt_Rsqr
+    |  |- (derivable_pt id ?X1) => apply (derivable_pt_id X1)
+    |  |- (derivable_pt (fct_cte _) _) => apply derivable_pt_const
+    |  |- (derivable_pt sin _) => apply derivable_pt_sin
+    |  |- (derivable_pt cos _) => apply derivable_pt_cos
+    |  |- (derivable_pt sinh _) => apply derivable_pt_sinh
+    |  |- (derivable_pt cosh _) => apply derivable_pt_cosh
+    |  |- (derivable_pt exp _) => apply derivable_pt_exp
+    |  |- (derivable_pt (pow_fct _) _) =>
       unfold pow_fct in |- *; apply derivable_pt_pow
-  |  |- (derivable_pt sqrt ?X1) =>
+    |  |- (derivable_pt sqrt ?X1) =>
       apply (derivable_pt_sqrt X1);
-       assumption ||
-         unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
-          comp, id, fct_cte, pow_fct in |- *
-  |  |- (derivable_pt Rabs ?X1) =>
+        assumption ||
+          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+            comp, id, fct_cte, pow_fct in |- *
+    |  |- (derivable_pt Rabs ?X1) =>
       apply (Rderivable_pt_abs X1);
-       assumption ||
-         unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
-          comp, id, fct_cte, pow_fct in |- *
+        assumption ||
+          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+            comp, id, fct_cte, pow_fct in |- *
         (* regles de differentiabilite *)
         (* PLUS *)
-  |  |- (derivable_pt (?X1 + ?X2) ?X3) =>
+    |  |- (derivable_pt (?X1 + ?X2) ?X3) =>
       apply (derivable_pt_plus X1 X2 X3); is_diff_pt
        (* MOINS *)
-  |  |- (derivable_pt (?X1 - ?X2) ?X3) =>
+    |  |- (derivable_pt (?X1 - ?X2) ?X3) =>
       apply (derivable_pt_minus X1 X2 X3); is_diff_pt
        (* OPPOSE *)
-  |  |- (derivable_pt (- ?X1) ?X2) =>
+    |  |- (derivable_pt (- ?X1) ?X2) =>
       apply (derivable_pt_opp X1 X2);
-       is_diff_pt
+        is_diff_pt
        (* MULTIPLICATION PAR UN SCALAIRE *)
-  |  |- (derivable_pt (mult_real_fct ?X1 ?X2) ?X3) =>
+    |  |- (derivable_pt (mult_real_fct ?X1 ?X2) ?X3) =>
       apply (derivable_pt_scal X2 X1 X3); is_diff_pt
        (* MULTIPLICATION *)
-  |  |- (derivable_pt (?X1 * ?X2) ?X3) =>
+    |  |- (derivable_pt (?X1 * ?X2) ?X3) =>
       apply (derivable_pt_mult X1 X2 X3); is_diff_pt
        (* DIVISION *)
-  |  |- (derivable_pt (?X1 / ?X2) ?X3) =>
+    |  |- (derivable_pt (?X1 / ?X2) ?X3) =>
       apply (derivable_pt_div X1 X2 X3);
-       [ is_diff_pt
-       | is_diff_pt
-       | try
-          assumption ||
-            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-             comp, pow_fct, id, fct_cte in |- * ]
-  |  |- (derivable_pt (/ ?X1) ?X2) =>
+        [ is_diff_pt
+          | is_diff_pt
+          | try
+            assumption ||
+              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+                comp, pow_fct, id, fct_cte in |- * ]
+    |  |- (derivable_pt (/ ?X1) ?X2) =>
       
        (* INVERSION *)
-       apply (derivable_pt_inv X1 X2);
-       [ assumption ||
-           unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+      apply (derivable_pt_inv X1 X2);
+        [ assumption ||
+          unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
             comp, pow_fct, id, fct_cte in |- *
-       | is_diff_pt ]
-  |  |- (derivable_pt (comp ?X1 ?X2) ?X3) =>
+          | is_diff_pt ]
+    |  |- (derivable_pt (comp ?X1 ?X2) ?X3) =>
       
        (* COMPOSITION *)
-       apply (derivable_pt_comp X2 X1 X3); is_diff_pt
-  | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) =>
+      apply (derivable_pt_comp X2 X1 X3); is_diff_pt
+    | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) =>
       assumption
-  | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) =>
+    | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) =>
       cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ]
-  |  |- (True -> derivable_pt _ _) =>
+    |  |- (True -> derivable_pt _ _) =>
       intro HypTruE; clear HypTruE; is_diff_pt
-  | _ =>
+    | _ =>
       try
-       unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
-        fct_cte, comp, pow_fct in |- *
+        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+          fct_cte, comp, pow_fct in |- *
   end.
 
 (**********)
 Ltac is_diff_glob :=
   match goal with
-  |  |- (derivable Rsqr) => 
+    |  |- (derivable Rsqr) => 
   (* fonctions de base *)
-  apply derivable_Rsqr
-  |  |- (derivable id) => apply derivable_id
-  |  |- (derivable (fct_cte _)) => apply derivable_const
-  |  |- (derivable sin) => apply derivable_sin
-  |  |- (derivable cos) => apply derivable_cos
-  |  |- (derivable cosh) => apply derivable_cosh
-  |  |- (derivable sinh) => apply derivable_sinh
-  |  |- (derivable exp) => apply derivable_exp
-  |  |- (derivable (pow_fct _)) =>
+      apply derivable_Rsqr
+    |  |- (derivable id) => apply derivable_id
+    |  |- (derivable (fct_cte _)) => apply derivable_const
+    |  |- (derivable sin) => apply derivable_sin
+    |  |- (derivable cos) => apply derivable_cos
+    |  |- (derivable cosh) => apply derivable_cosh
+    |  |- (derivable sinh) => apply derivable_sinh
+    |  |- (derivable exp) => apply derivable_exp
+    |  |- (derivable (pow_fct _)) =>
       unfold pow_fct in |- *;
-       apply derivable_pow
+        apply derivable_pow
         (* regles de differentiabilite *)
         (* PLUS *)
-  |  |- (derivable (?X1 + ?X2)) =>
+    |  |- (derivable (?X1 + ?X2)) =>
       apply (derivable_plus X1 X2); is_diff_glob
        (* MOINS *)
-  |  |- (derivable (?X1 - ?X2)) =>
+    |  |- (derivable (?X1 - ?X2)) =>
       apply (derivable_minus X1 X2); is_diff_glob
        (* OPPOSE *)
-  |  |- (derivable (- ?X1)) =>
+    |  |- (derivable (- ?X1)) =>
       apply (derivable_opp X1);
-       is_diff_glob
+        is_diff_glob
        (* MULTIPLICATION PAR UN SCALAIRE *)
-  |  |- (derivable (mult_real_fct ?X1 ?X2)) =>
+    |  |- (derivable (mult_real_fct ?X1 ?X2)) =>
       apply (derivable_scal X2 X1); is_diff_glob
        (* MULTIPLICATION *)
-  |  |- (derivable (?X1 * ?X2)) =>
+    |  |- (derivable (?X1 * ?X2)) =>
       apply (derivable_mult X1 X2); is_diff_glob
        (* DIVISION *)
-  |  |- (derivable (?X1 / ?X2)) =>
+    |  |- (derivable (?X1 / ?X2)) =>
       apply (derivable_div X1 X2);
-       [ is_diff_glob
-       | is_diff_glob
-       | try
-          assumption ||
-            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-             id, fct_cte, comp, pow_fct in |- * ]
-  |  |- (derivable (/ ?X1)) =>
+        [ is_diff_glob
+          | is_diff_glob
+          | try
+            assumption ||
+              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+                id, fct_cte, comp, pow_fct in |- * ]
+    |  |- (derivable (/ ?X1)) =>
       
        (* INVERSION *)
-       apply (derivable_inv X1);
-       [ try
+      apply (derivable_inv X1);
+        [ try
           assumption ||
             unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-             id, fct_cte, comp, pow_fct in |- *
-       | is_diff_glob ]
-  |  |- (derivable (comp sqrt _)) =>
+              id, fct_cte, comp, pow_fct in |- *
+          | is_diff_glob ]
+    |  |- (derivable (comp sqrt _)) =>
       
        (* COMPOSITION *)
-       unfold derivable in |- *; intro; try is_diff_pt
-  |  |- (derivable (comp Rabs _)) =>
       unfold derivable in |- *; intro; try is_diff_pt
-  |  |- (derivable (comp ?X1 ?X2)) =>
+    |  |- (derivable (comp Rabs _)) =>
+      unfold derivable in |- *; intro; try is_diff_pt
+    |  |- (derivable (comp ?X1 ?X2)) =>
       apply (derivable_comp X2 X1); is_diff_glob
-  | _:(derivable ?X1) |- (derivable ?X1) => assumption
-  |  |- (True -> derivable _) =>
+    | _:(derivable ?X1) |- (derivable ?X1) => assumption
+    |  |- (True -> derivable _) =>
       intro HypTruE; clear HypTruE; is_diff_glob
-  | _ =>
+    | _ =>
       try
-       unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
-        fct_cte, comp, pow_fct in |- *
+        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+          fct_cte, comp, pow_fct in |- *
   end.
 
 (**********)
 Ltac is_cont_pt :=
   match goal with
-  |  |- (continuity_pt Rsqr _) =>
+    |  |- (continuity_pt Rsqr _) =>
       
        (* fonctions de base *)
-       apply derivable_continuous_pt; apply derivable_pt_Rsqr
-  |  |- (continuity_pt id ?X1) =>
+      apply derivable_continuous_pt; apply derivable_pt_Rsqr
+    |  |- (continuity_pt id ?X1) =>
       apply derivable_continuous_pt; apply (derivable_pt_id X1)
-  |  |- (continuity_pt (fct_cte _) _) =>
+    |  |- (continuity_pt (fct_cte _) _) =>
       apply derivable_continuous_pt; apply derivable_pt_const
-  |  |- (continuity_pt sin _) =>
+    |  |- (continuity_pt sin _) =>
       apply derivable_continuous_pt; apply derivable_pt_sin
-  |  |- (continuity_pt cos _) =>
+    |  |- (continuity_pt cos _) =>
       apply derivable_continuous_pt; apply derivable_pt_cos
-  |  |- (continuity_pt sinh _) =>
+    |  |- (continuity_pt sinh _) =>
       apply derivable_continuous_pt; apply derivable_pt_sinh
-  |  |- (continuity_pt cosh _) =>
+    |  |- (continuity_pt cosh _) =>
       apply derivable_continuous_pt; apply derivable_pt_cosh
-  |  |- (continuity_pt exp _) =>
+    |  |- (continuity_pt exp _) =>
       apply derivable_continuous_pt; apply derivable_pt_exp
-  |  |- (continuity_pt (pow_fct _) _) =>
+    |  |- (continuity_pt (pow_fct _) _) =>
       unfold pow_fct in |- *; apply derivable_continuous_pt;
-       apply derivable_pt_pow
-  |  |- (continuity_pt sqrt ?X1) =>
+        apply derivable_pt_pow
+    |  |- (continuity_pt sqrt ?X1) =>
       apply continuity_pt_sqrt;
-       assumption ||
-         unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
-          comp, id, fct_cte, pow_fct in |- *
-  |  |- (continuity_pt Rabs ?X1) =>
+        assumption ||
+          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+            comp, id, fct_cte, pow_fct in |- *
+    |  |- (continuity_pt Rabs ?X1) =>
       apply (Rcontinuity_abs X1)
        (* regles de differentiabilite *)
        (* PLUS *)
-  |  |- (continuity_pt (?X1 + ?X2) ?X3) =>
+    |  |- (continuity_pt (?X1 + ?X2) ?X3) =>
       apply (continuity_pt_plus X1 X2 X3); is_cont_pt
        (* MOINS *)
-  |  |- (continuity_pt (?X1 - ?X2) ?X3) =>
+    |  |- (continuity_pt (?X1 - ?X2) ?X3) =>
       apply (continuity_pt_minus X1 X2 X3); is_cont_pt
        (* OPPOSE *)
-  |  |- (continuity_pt (- ?X1) ?X2) =>
+    |  |- (continuity_pt (- ?X1) ?X2) =>
       apply (continuity_pt_opp X1 X2);
-       is_cont_pt
+        is_cont_pt
        (* MULTIPLICATION PAR UN SCALAIRE *)
-  |  |- (continuity_pt (mult_real_fct ?X1 ?X2) ?X3) =>
+    |  |- (continuity_pt (mult_real_fct ?X1 ?X2) ?X3) =>
       apply (continuity_pt_scal X2 X1 X3); is_cont_pt
        (* MULTIPLICATION *)
-  |  |- (continuity_pt (?X1 * ?X2) ?X3) =>
+    |  |- (continuity_pt (?X1 * ?X2) ?X3) =>
       apply (continuity_pt_mult X1 X2 X3); is_cont_pt
        (* DIVISION *)
-  |  |- (continuity_pt (?X1 / ?X2) ?X3) =>
+    |  |- (continuity_pt (?X1 / ?X2) ?X3) =>
       apply (continuity_pt_div X1 X2 X3);
-       [ is_cont_pt
-       | is_cont_pt
-       | try
-          assumption ||
-            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-             comp, id, fct_cte, pow_fct in |- * ]
-  |  |- (continuity_pt (/ ?X1) ?X2) =>
+        [ is_cont_pt
+          | is_cont_pt
+          | try
+            assumption ||
+              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+                comp, id, fct_cte, pow_fct in |- * ]
+    |  |- (continuity_pt (/ ?X1) ?X2) =>
       
        (* INVERSION *)
-       apply (continuity_pt_inv X1 X2);
-       [ is_cont_pt
-       | assumption ||
-           unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-            comp, id, fct_cte, pow_fct in |- * ]
-  |  |- (continuity_pt (comp ?X1 ?X2) ?X3) =>
+      apply (continuity_pt_inv X1 X2);
+        [ is_cont_pt
+          | assumption ||
+            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+              comp, id, fct_cte, pow_fct in |- * ]
+    |  |- (continuity_pt (comp ?X1 ?X2) ?X3) =>
       
        (* COMPOSITION *)
-       apply (continuity_pt_comp X2 X1 X3); is_cont_pt
-  | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
+      apply (continuity_pt_comp X2 X1 X3); is_cont_pt
+    | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
       assumption
-  | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) =>
+    | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) =>
       cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ]
-  | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
+    | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
       apply derivable_continuous_pt; assumption
-  | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) =>
+    | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) =>
       cut (continuity X1);
-       [ intro HypDDPT; apply HypDDPT
-       | apply derivable_continuous; assumption ]
-  |  |- (True -> continuity_pt _ _) =>
+        [ intro HypDDPT; apply HypDDPT
+          | apply derivable_continuous; assumption ]
+    |  |- (True -> continuity_pt _ _) =>
       intro HypTruE; clear HypTruE; is_cont_pt
-  | _ =>
+    | _ =>
       try
-       unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
-        fct_cte, comp, pow_fct in |- *
+        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+          fct_cte, comp, pow_fct in |- *
   end.
 
 (**********)
 Ltac is_cont_glob :=
   match goal with
-  |  |- (continuity Rsqr) =>
+    |  |- (continuity Rsqr) =>
       
        (* fonctions de base *)
-       apply derivable_continuous; apply derivable_Rsqr
-  |  |- (continuity id) => apply derivable_continuous; apply derivable_id
-  |  |- (continuity (fct_cte _)) =>
+      apply derivable_continuous; apply derivable_Rsqr
+    |  |- (continuity id) => apply derivable_continuous; apply derivable_id
+    |  |- (continuity (fct_cte _)) =>
       apply derivable_continuous; apply derivable_const
-  |  |- (continuity sin) => apply derivable_continuous; apply derivable_sin
-  |  |- (continuity cos) => apply derivable_continuous; apply derivable_cos
-  |  |- (continuity exp) => apply derivable_continuous; apply derivable_exp
-  |  |- (continuity (pow_fct _)) =>
+    |  |- (continuity sin) => apply derivable_continuous; apply derivable_sin
+    |  |- (continuity cos) => apply derivable_continuous; apply derivable_cos
+    |  |- (continuity exp) => apply derivable_continuous; apply derivable_exp
+    |  |- (continuity (pow_fct _)) =>
       unfold pow_fct in |- *; apply derivable_continuous; apply derivable_pow
-  |  |- (continuity sinh) =>
+    |  |- (continuity sinh) =>
       apply derivable_continuous; apply derivable_sinh
-  |  |- (continuity cosh) =>
+    |  |- (continuity cosh) =>
       apply derivable_continuous; apply derivable_cosh
-  |  |- (continuity Rabs) =>
+    |  |- (continuity Rabs) =>
       apply Rcontinuity_abs
        (* regles de continuite *)
        (* PLUS *)
-  |  |- (continuity (?X1 + ?X2)) =>
+    |  |- (continuity (?X1 + ?X2)) =>
       apply (continuity_plus X1 X2);
-       try is_cont_glob || assumption
+        try is_cont_glob || assumption
             (* MOINS *)
-  |  |- (continuity (?X1 - ?X2)) =>
+    |  |- (continuity (?X1 - ?X2)) =>
       apply (continuity_minus X1 X2);
-       try is_cont_glob || assumption
+        try is_cont_glob || assumption
             (* OPPOSE *)
-  |  |- (continuity (- ?X1)) =>
+    |  |- (continuity (- ?X1)) =>
       apply (continuity_opp X1); try is_cont_glob || assumption
                                       (* INVERSE *)
-  |  |- (continuity (/ ?X1)) =>
+    |  |- (continuity (/ ?X1)) =>
       apply (continuity_inv X1);
-       try is_cont_glob || assumption
+        try is_cont_glob || assumption
             (* MULTIPLICATION PAR UN SCALAIRE *)
-  |  |- (continuity (mult_real_fct ?X1 ?X2)) =>
+    |  |- (continuity (mult_real_fct ?X1 ?X2)) =>
       apply (continuity_scal X2 X1);
-       try is_cont_glob || assumption
+        try is_cont_glob || assumption
             (* MULTIPLICATION *)
-  |  |- (continuity (?X1 * ?X2)) =>
+    |  |- (continuity (?X1 * ?X2)) =>
       apply (continuity_mult X1 X2);
-       try is_cont_glob || assumption
+        try is_cont_glob || assumption
             (* DIVISION *)
-  |  |- (continuity (?X1 / ?X2)) =>
+    |  |- (continuity (?X1 / ?X2)) =>
       apply (continuity_div X1 X2);
-       [ try is_cont_glob || assumption
-       | try is_cont_glob || assumption
-       | try
-          assumption ||
-            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-             id, fct_cte, pow_fct in |- * ]
-  |  |- (continuity (comp sqrt _)) =>
+        [ try is_cont_glob || assumption
+          | try is_cont_glob || assumption
+          | try
+            assumption ||
+              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+                id, fct_cte, pow_fct in |- * ]
+    |  |- (continuity (comp sqrt _)) =>
       
        (* COMPOSITION *)
-       unfold continuity_pt in |- *; intro; try is_cont_pt
-  |  |- (continuity (comp ?X1 ?X2)) =>
+      unfold continuity_pt in |- *; intro; try is_cont_pt
+    |  |- (continuity (comp ?X1 ?X2)) =>
       apply (continuity_comp X2 X1); try is_cont_glob || assumption
-  | _:(continuity ?X1) |- (continuity ?X1) => assumption
-  |  |- (True -> continuity _) =>
+    | _:(continuity ?X1) |- (continuity ?X1) => assumption
+    |  |- (True -> continuity _) =>
       intro HypTruE; clear HypTruE; is_cont_glob
-  | _:(derivable ?X1) |- (continuity ?X1) =>
+    | _:(derivable ?X1) |- (continuity ?X1) =>
       apply derivable_continuous; assumption
-  | _ =>
+    | _ =>
       try
-       unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
-        fct_cte, comp, pow_fct in |- *
+        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+          fct_cte, comp, pow_fct in |- *
   end.
 
 (**********)
 Ltac rew_term trm :=
   match constr:trm with
-  | (?X1 + ?X2) =>
+    | (?X1 + ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-      match constr:p1 with
-      | (fct_cte ?X3) =>
-          match constr:p2 with
-          | (fct_cte ?X4) => constr:(fct_cte (X3 + X4))
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 + X4))
+              | _ => constr:(p1 + p2)%F
+            end
           | _ => constr:(p1 + p2)%F
-          end
-      | _ => constr:(p1 + p2)%F
-      end
-  | (?X1 - ?X2) =>
+        end
+    | (?X1 - ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-      match constr:p1 with
-      | (fct_cte ?X3) =>
-          match constr:p2 with
-          | (fct_cte ?X4) => constr:(fct_cte (X3 - X4))
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 - X4))
+              | _ => constr:(p1 - p2)%F
+            end
           | _ => constr:(p1 - p2)%F
-          end
-      | _ => constr:(p1 - p2)%F
-      end
-  | (?X1 / ?X2) =>
+        end
+    | (?X1 / ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-      match constr:p1 with
-      | (fct_cte ?X3) =>
-          match constr:p2 with
-          | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
-          | _ => constr:(p1 / p2)%F
-          end
-      | _ =>
-          match constr:p2 with
-          | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
-          | _ => constr:(p1 / p2)%F
-          end
-      end
-  | (?X1 * / ?X2) =>
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
+              | _ => constr:(p1 / p2)%F
+            end
+          | _ =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
+              | _ => constr:(p1 / p2)%F
+            end
+        end
+    | (?X1 * / ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-      match constr:p1 with
-      | (fct_cte ?X3) =>
-          match constr:p2 with
-          | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
-          | _ => constr:(p1 / p2)%F
-          end
-      | _ =>
-          match constr:p2 with
-          | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
-          | _ => constr:(p1 / p2)%F
-          end
-      end
-  | (?X1 * ?X2) =>
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
+              | _ => constr:(p1 / p2)%F
+            end
+          | _ =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
+              | _ => constr:(p1 / p2)%F
+            end
+        end
+    | (?X1 * ?X2) =>
       let p1 := rew_term X1 with p2 := rew_term X2 in
-      match constr:p1 with
-      | (fct_cte ?X3) =>
-          match constr:p2 with
-          | (fct_cte ?X4) => constr:(fct_cte (X3 * X4))
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 * X4))
+              | _ => constr:(p1 * p2)%F
+            end
           | _ => constr:(p1 * p2)%F
-          end
-      | _ => constr:(p1 * p2)%F
-      end
-  | (- ?X1) =>
+        end
+    | (- ?X1) =>
       let p := rew_term X1 in
-      match constr:p with
-      | (fct_cte ?X2) => constr:(fct_cte (- X2))
-      | _ => constr:(- p)%F
-      end
-  | (/ ?X1) =>
+        match constr:p with
+          | (fct_cte ?X2) => constr:(fct_cte (- X2))
+          | _ => constr:(- p)%F
+        end
+    | (/ ?X1) =>
       let p := rew_term X1 in
-      match constr:p with
-      | (fct_cte ?X2) => constr:(fct_cte (/ X2))
-      | _ => constr:(/ p)%F
-      end
-  | (?X1 AppVar) => constr:X1
-  | (?X1 ?X2) =>
+        match constr:p with
+          | (fct_cte ?X2) => constr:(fct_cte (/ X2))
+          | _ => constr:(/ p)%F
+        end
+    | (?X1 AppVar) => constr:X1
+    | (?X1 ?X2) =>
       let p := rew_term X2 in
-      match constr:p with
-      | (fct_cte ?X3) => constr:(fct_cte (X1 X3))
-      | _ => constr:(comp X1 p)
-      end
-  | AppVar => constr:id
-  | (AppVar ^ ?X1) => constr:(pow_fct X1)
-  | (?X1 ^ ?X2) =>
+        match constr:p with
+          | (fct_cte ?X3) => constr:(fct_cte (X1 X3))
+          | _ => constr:(comp X1 p)
+        end
+    | AppVar => constr:id
+    | (AppVar ^ ?X1) => constr:(pow_fct X1)
+    | (?X1 ^ ?X2) =>
       let p := rew_term X1 in
-      match constr:p with
-      | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3))
-      | _ => constr:(comp (pow_fct X2) p)
-      end
-  | ?X1 => constr:(fct_cte X1)
+        match constr:p with
+          | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3))
+          | _ => constr:(comp (pow_fct X2) p)
+        end
+    | ?X1 => constr:(fct_cte X1)
   end.
 
 (**********)
 Ltac deriv_proof trm pt :=
   match constr:trm with
-  | (?X1 + ?X2)%F =>
+    | (?X1 + ?X2)%F =>
       let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
-      constr:(derivable_pt_plus X1 X2 pt p1 p2)
-  | (?X1 - ?X2)%F =>
+        constr:(derivable_pt_plus X1 X2 pt p1 p2)
+    | (?X1 - ?X2)%F =>
       let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
-      constr:(derivable_pt_minus X1 X2 pt p1 p2)
-  | (?X1 * ?X2)%F =>
+        constr:(derivable_pt_minus X1 X2 pt p1 p2)
+    | (?X1 * ?X2)%F =>
       let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
-      constr:(derivable_pt_mult X1 X2 pt p1 p2)
-  | (?X1 / ?X2)%F =>
+        constr:(derivable_pt_mult X1 X2 pt p1 p2)
+    | (?X1 / ?X2)%F =>
       match goal with
-      | id:(?X2 pt <> 0) |- _ =>
+        | id:(?X2 pt <> 0) |- _ =>
           let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
-          constr:(derivable_pt_div X1 X2 pt p1 p2 id)
-      | _ => constr:False
+            constr:(derivable_pt_div X1 X2 pt p1 p2 id)
+        | _ => constr:False
       end
-  | (/ ?X1)%F =>
+    | (/ ?X1)%F =>
       match goal with
-      | id:(?X1 pt <> 0) |- _ =>
+        | id:(?X1 pt <> 0) |- _ =>
           let p1 := deriv_proof X1 pt in
-          constr:(derivable_pt_inv X1 pt p1 id)
-      | _ => constr:False
+            constr:(derivable_pt_inv X1 pt p1 id)
+        | _ => constr:False
       end
-  | (comp ?X1 ?X2) =>
+    | (comp ?X1 ?X2) =>
       let pt_f1 := eval cbv beta in (X2 pt) in
-      let p1 := deriv_proof X1 pt_f1 with p2 := deriv_proof X2 pt in
-      constr:(derivable_pt_comp X2 X1 pt p2 p1)
-  | (- ?X1)%F =>
+        let p1 := deriv_proof X1 pt_f1 with p2 := deriv_proof X2 pt in
+          constr:(derivable_pt_comp X2 X1 pt p2 p1)
+    | (- ?X1)%F =>
       let p1 := deriv_proof X1 pt in
-      constr:(derivable_pt_opp X1 pt p1)
-  | sin => constr:(derivable_pt_sin pt)
-  | cos => constr:(derivable_pt_cos pt)
-  | sinh => constr:(derivable_pt_sinh pt)
-  | cosh => constr:(derivable_pt_cosh pt)
-  | exp => constr:(derivable_pt_exp pt)
-  | id => constr:(derivable_pt_id pt)
-  | Rsqr => constr:(derivable_pt_Rsqr pt)
-  | sqrt =>
+        constr:(derivable_pt_opp X1 pt p1)
+    | sin => constr:(derivable_pt_sin pt)
+    | cos => constr:(derivable_pt_cos pt)
+    | sinh => constr:(derivable_pt_sinh pt)
+    | cosh => constr:(derivable_pt_cosh pt)
+    | exp => constr:(derivable_pt_exp pt)
+    | id => constr:(derivable_pt_id pt)
+    | Rsqr => constr:(derivable_pt_Rsqr pt)
+    | sqrt =>
       match goal with
-      | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id)
-      | _ => constr:False
+        | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id)
+        | _ => constr:False
       end
-  | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt)
-  | ?X1 =>
+    | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt)
+    | ?X1 =>
       let aux := constr:X1 in
-      match goal with
-      | id:(derivable_pt aux pt) |- _ => constr:id
-      | id:(derivable aux) |- _ => constr:(id pt)
-      | _ => constr:False
-      end
+        match goal with
+          | id:(derivable_pt aux pt) |- _ => constr:id
+          | id:(derivable aux) |- _ => constr:(id pt)
+          | _ => constr:False
+        end
   end.
 
 (**********)
 Ltac simplify_derive trm pt :=
   match constr:trm with
-  | (?X1 + ?X2)%F =>
+    | (?X1 + ?X2)%F =>
       try rewrite derive_pt_plus; simplify_derive X1 pt;
-       simplify_derive X2 pt
-  | (?X1 - ?X2)%F =>
+        simplify_derive X2 pt
+    | (?X1 - ?X2)%F =>
       try rewrite derive_pt_minus; simplify_derive X1 pt;
-       simplify_derive X2 pt
-  | (?X1 * ?X2)%F =>
+        simplify_derive X2 pt
+    | (?X1 * ?X2)%F =>
       try rewrite derive_pt_mult; simplify_derive X1 pt;
-       simplify_derive X2 pt
-  | (?X1 / ?X2)%F =>
+        simplify_derive X2 pt
+    | (?X1 / ?X2)%F =>
       try rewrite derive_pt_div; simplify_derive X1 pt; simplify_derive X2 pt
-  | (comp ?X1 ?X2) =>
+    | (comp ?X1 ?X2) =>
       let pt_f1 := eval cbv beta in (X2 pt) in
-      (try rewrite derive_pt_comp; simplify_derive X1 pt_f1;
-        simplify_derive X2 pt)
-  | (- ?X1)%F => try rewrite derive_pt_opp; simplify_derive X1 pt
-  | (/ ?X1)%F =>
+        (try rewrite derive_pt_comp; simplify_derive X1 pt_f1;
+          simplify_derive X2 pt)
+    | (- ?X1)%F => try rewrite derive_pt_opp; simplify_derive X1 pt
+    | (/ ?X1)%F =>
       try rewrite derive_pt_inv; simplify_derive X1 pt
-  | (fct_cte ?X1) => try rewrite derive_pt_const
-  | id => try rewrite derive_pt_id
-  | sin => try rewrite derive_pt_sin
-  | cos => try rewrite derive_pt_cos
-  | sinh => try rewrite derive_pt_sinh
-  | cosh => try rewrite derive_pt_cosh
-  | exp => try rewrite derive_pt_exp
-  | Rsqr => try rewrite derive_pt_Rsqr
-  | sqrt => try rewrite derive_pt_sqrt
-  | ?X1 =>
+    | (fct_cte ?X1) => try rewrite derive_pt_const
+    | id => try rewrite derive_pt_id
+    | sin => try rewrite derive_pt_sin
+    | cos => try rewrite derive_pt_cos
+    | sinh => try rewrite derive_pt_sinh
+    | cosh => try rewrite derive_pt_cosh
+    | exp => try rewrite derive_pt_exp
+    | Rsqr => try rewrite derive_pt_Rsqr
+    | sqrt => try rewrite derive_pt_sqrt
+    | ?X1 =>
       let aux := constr:X1 in
-      match goal with
-      | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ =>
-          try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2);
-           [ rewrite id | apply pr_nu ]
-      | id:(derive_pt aux pt ?X2 = _),H:(derivable_pt aux pt) |- _ =>
-          try replace (derive_pt aux pt H) with (derive_pt aux pt X2);
-           [ rewrite id | apply pr_nu ]
-      | _ => idtac
-      end
-  | _ => idtac
+        match goal with
+          | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ =>
+            try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2);
+              [ rewrite id | apply pr_nu ]
+          | id:(derive_pt aux pt ?X2 = _),H:(derivable_pt aux pt) |- _ =>
+            try replace (derive_pt aux pt H) with (derive_pt aux pt X2);
+              [ rewrite id | apply pr_nu ]
+          | _ => idtac
+        end
+    | _ => idtac
   end.
 
 (**********)
 Ltac reg :=
   match goal with
-  |  |- (derivable_pt ?X1 ?X2) =>
+    |  |- (derivable_pt ?X1 ?X2) =>
       let trm := eval cbv beta in (X1 AppVar) in
-      let aux := rew_term trm in
-      (intro_hyp_pt aux X2;
-        try (change (derivable_pt aux X2) in |- *; is_diff_pt) || is_diff_pt)
-  |  |- (derivable ?X1) =>
+        let aux := rew_term trm in
+          (intro_hyp_pt aux X2;
+            try (change (derivable_pt aux X2) in |- *; is_diff_pt) || is_diff_pt)
+    |  |- (derivable ?X1) =>
       let trm := eval cbv beta in (X1 AppVar) in
-      let aux := rew_term trm in
-      (intro_hyp_glob aux;
-        try (change (derivable aux) in |- *; is_diff_glob) || is_diff_glob)
-  |  |- (continuity ?X1) =>
+        let aux := rew_term trm in
+          (intro_hyp_glob aux;
+            try (change (derivable aux) in |- *; is_diff_glob) || is_diff_glob)
+    |  |- (continuity ?X1) =>
       let trm := eval cbv beta in (X1 AppVar) in
-      let aux := rew_term trm in
-      (intro_hyp_glob aux;
-        try (change (continuity aux) in |- *; is_cont_glob) || is_cont_glob)
-  |  |- (continuity_pt ?X1 ?X2) =>
+        let aux := rew_term trm in
+          (intro_hyp_glob aux;
+            try (change (continuity aux) in |- *; is_cont_glob) || is_cont_glob)
+    |  |- (continuity_pt ?X1 ?X2) =>
       let trm := eval cbv beta in (X1 AppVar) in
-      let aux := rew_term trm in
-      (intro_hyp_pt aux X2;
-        try (change (continuity_pt aux X2) in |- *; is_cont_pt) || is_cont_pt)
-  |  |- (derive_pt ?X1 ?X2 ?X3 = ?X4) =>
+        let aux := rew_term trm in
+          (intro_hyp_pt aux X2;
+            try (change (continuity_pt aux X2) in |- *; is_cont_pt) || is_cont_pt)
+    |  |- (derive_pt ?X1 ?X2 ?X3 = ?X4) =>
       let trm := eval cbv beta in (X1 AppVar) in
       let aux := rew_term trm in
-      (intro_hyp_pt aux X2;
-        let aux2 := deriv_proof aux X2 in
-        (try
-          (replace (derive_pt X1 X2 X3) with (derive_pt aux X2 aux2);
-            [ simplify_derive aux X2;
-               try
-                unfold plus_fct, minus_fct, mult_fct, div_fct, id, fct_cte,
-                 inv_fct, opp_fct in |- *; try ring
-            | try apply pr_nu ]) || is_diff_pt))
-  end.
\ No newline at end of file
+      intro_hyp_pt aux X2;
+      (let aux2 := deriv_proof aux X2 in
+       try
+         (replace (derive_pt X1 X2 X3) with (derive_pt aux X2 aux2);
+           [ simplify_derive aux X2;
+             try unfold plus_fct, minus_fct, mult_fct, div_fct, id, fct_cte,
+                        inv_fct, opp_fct in |- *; ring || ring_simplify
+           | try apply pr_nu ]) || is_diff_pt)
+  end.
diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v
index 918ebfc0..93a66e70 100644
--- a/theories/Reals/Ranalysis1.v
+++ b/theories/Reals/Ranalysis1.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis1.v,v 1.21.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Ranalysis1.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -15,7 +15,7 @@ Require Export Rderiv. Open Local Scope R_scope.
 Implicit Type f : R -> R.
 
 (****************************************************)
-(**           Basic operations on functions         *)
+(** *         Basic operations on functions         *)
 (****************************************************)
 Definition plus_fct f1 f2 (x:R) : R := f1 x + f2 x.
 Definition opp_fct f (x:R) : R := - f x.
@@ -27,6 +27,18 @@ Definition div_real_fct (a:R) f (x:R) : R := a / f x.
 Definition comp f1 f2 (x:R) : R := f1 (f2 x).
 Definition inv_fct f (x:R) : R := / f x.
 
+Delimit Scope Rfun_scope with F.
+
+Arguments Scope plus_fct [Rfun_scope Rfun_scope R_scope].
+Arguments Scope mult_fct [Rfun_scope Rfun_scope R_scope].
+Arguments Scope minus_fct [Rfun_scope Rfun_scope R_scope].
+Arguments Scope div_fct [Rfun_scope Rfun_scope R_scope].
+Arguments Scope inv_fct [Rfun_scope R_scope].
+Arguments Scope opp_fct [Rfun_scope R_scope].
+Arguments Scope mult_real_fct [R_scope Rfun_scope R_scope].
+Arguments Scope div_real_fct [R_scope Rfun_scope R_scope].
+Arguments Scope comp [Rfun_scope Rfun_scope R_scope].
+
 Infix "+" := plus_fct : Rfun_scope.
 Notation "- x" := (opp_fct x) : Rfun_scope.
 Infix "*" := mult_fct : Rfun_scope.
@@ -36,20 +48,18 @@ Notation Local "f1 'o' f2" := (comp f1 f2)
   (at level 20, right associativity) : Rfun_scope.
 Notation "/ x" := (inv_fct x) : Rfun_scope.
 
-Delimit Scope Rfun_scope with F.
-
 Definition fct_cte (a x:R) : R := a.
 Definition id (x:R) := x.
 
 (****************************************************)
-(**            Variations of functions              *)
+(** *          Variations of functions              *)
 (****************************************************)
 Definition increasing f : Prop := forall x y:R, x <= y -> f x <= f y.
 Definition decreasing f : Prop := forall x y:R, x <= y -> f y <= f x.
 Definition strict_increasing f : Prop := forall x y:R, x < y -> f x < f y.
 Definition strict_decreasing f : Prop := forall x y:R, x < y -> f y < f x.
 Definition constant f : Prop := forall x y:R, f x = f y.
-  
+
 (**********) 
 Definition no_cond (x:R) : Prop := True.
 
@@ -58,7 +68,7 @@ Definition constant_D_eq f (D:R -> Prop) (c:R) : Prop :=
   forall x:R, D x -> f x = c.
 
 (***************************************************)
-(**      Definition of continuity as a limit       *)
+(** *    Definition of continuity as a limit       *)
 (***************************************************)
 
 (**********)
@@ -70,173 +80,192 @@ Arguments Scope continuity [Rfun_scope].
 
 (**********)
 Lemma continuity_pt_plus :
- forall f1 f2 (x0:R),
-   continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 + f2) x0.
-unfold continuity_pt, plus_fct in |- *; unfold continue_in in |- *; intros;
- apply limit_plus; assumption.
+  forall f1 f2 (x0:R),
+    continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 + f2) x0.
+Proof.
+  unfold continuity_pt, plus_fct in |- *; unfold continue_in in |- *; intros;
+    apply limit_plus; assumption.
 Qed.
 
 Lemma continuity_pt_opp :
- forall f (x0:R), continuity_pt f x0 -> continuity_pt (- f) x0.
-unfold continuity_pt, opp_fct in |- *; unfold continue_in in |- *; intros;
- apply limit_Ropp; assumption.
+  forall f (x0:R), continuity_pt f x0 -> continuity_pt (- f) x0.
+Proof.
+  unfold continuity_pt, opp_fct in |- *; unfold continue_in in |- *; intros;
+    apply limit_Ropp; assumption.
 Qed.
- 
+
 Lemma continuity_pt_minus :
- forall f1 f2 (x0:R),
-   continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 - f2) x0.
-unfold continuity_pt, minus_fct in |- *; unfold continue_in in |- *; intros;
- apply limit_minus; assumption.
+  forall f1 f2 (x0:R),
+    continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 - f2) x0.
+Proof.
+  unfold continuity_pt, minus_fct in |- *; unfold continue_in in |- *; intros;
+    apply limit_minus; assumption.
 Qed.
 
 Lemma continuity_pt_mult :
- forall f1 f2 (x0:R),
-   continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 * f2) x0.
-unfold continuity_pt, mult_fct in |- *; unfold continue_in in |- *; intros;
- apply limit_mul; assumption.
+  forall f1 f2 (x0:R),
+    continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 * f2) x0.
+Proof.
+  unfold continuity_pt, mult_fct in |- *; unfold continue_in in |- *; intros;
+    apply limit_mul; assumption.
 Qed.
 
 Lemma continuity_pt_const : forall f (x0:R), constant f -> continuity_pt f x0.
-unfold constant, continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- intros; exists 1; split;
- [ apply Rlt_0_1
- | intros; generalize (H x x0); intro; rewrite H2; simpl in |- *;
-    rewrite R_dist_eq; assumption ].
+Proof.
+  unfold constant, continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      intros; exists 1; split;
+        [ apply Rlt_0_1
+          | intros; generalize (H x x0); intro; rewrite H2; simpl in |- *;
+            rewrite R_dist_eq; assumption ].
 Qed.
 
 Lemma continuity_pt_scal :
- forall f (a x0:R),
-   continuity_pt f x0 -> continuity_pt (mult_real_fct a f) x0.
-unfold continuity_pt, mult_real_fct in |- *; unfold continue_in in |- *;
- intros; apply (limit_mul (fun x:R => a) f (D_x no_cond x0) a (f x0) x0).
-unfold limit1_in in |- *; unfold limit_in in |- *; intros; exists 1; split.
-apply Rlt_0_1.
-intros; rewrite R_dist_eq; assumption.
-assumption.
+  forall f (a x0:R),
+    continuity_pt f x0 -> continuity_pt (mult_real_fct a f) x0.
+Proof.
+  unfold continuity_pt, mult_real_fct in |- *; unfold continue_in in |- *;
+    intros; apply (limit_mul (fun x:R => a) f (D_x no_cond x0) a (f x0) x0).
+  unfold limit1_in in |- *; unfold limit_in in |- *; intros; exists 1; split.
+  apply Rlt_0_1.
+  intros; rewrite R_dist_eq; assumption.
+  assumption.
 Qed.
 
 Lemma continuity_pt_inv :
- forall f (x0:R), continuity_pt f x0 -> f x0 <> 0 -> continuity_pt (/ f) x0.
-intros.
-replace (/ f)%F with (fun x:R => / f x).
-unfold continuity_pt in |- *; unfold continue_in in |- *; intros;
- apply limit_inv; assumption.
-unfold inv_fct in |- *; reflexivity.
-Qed.
- 
+  forall f (x0:R), continuity_pt f x0 -> f x0 <> 0 -> continuity_pt (/ f) x0.
+Proof.
+  intros.
+  replace (/ f)%F with (fun x:R => / f x).
+  unfold continuity_pt in |- *; unfold continue_in in |- *; intros;
+    apply limit_inv; assumption.
+  unfold inv_fct in |- *; reflexivity.
+Qed.
+
 Lemma div_eq_inv : forall f1 f2, (f1 / f2)%F = (f1 * / f2)%F.
-intros; reflexivity.
+Proof.
+  intros; reflexivity.
 Qed.
- 
+
 Lemma continuity_pt_div :
- forall f1 f2 (x0:R),
-   continuity_pt f1 x0 ->
-   continuity_pt f2 x0 -> f2 x0 <> 0 -> continuity_pt (f1 / f2) x0.
-intros; rewrite (div_eq_inv f1 f2); apply continuity_pt_mult;
- [ assumption | apply continuity_pt_inv; assumption ].
+  forall f1 f2 (x0:R),
+    continuity_pt f1 x0 ->
+    continuity_pt f2 x0 -> f2 x0 <> 0 -> continuity_pt (f1 / f2) x0.
+Proof.
+  intros; rewrite (div_eq_inv f1 f2); apply continuity_pt_mult;
+    [ assumption | apply continuity_pt_inv; assumption ].
 Qed.
 
 Lemma continuity_pt_comp :
- forall f1 f2 (x:R),
-   continuity_pt f1 x -> continuity_pt f2 (f1 x) -> continuity_pt (f2 o f1) x.
-unfold continuity_pt in |- *; unfold continue_in in |- *; intros;
- unfold comp in |- *.
-cut
- (limit1_in (fun x0:R => f2 (f1 x0))
-    (Dgf (D_x no_cond x) (D_x no_cond (f1 x)) f1) (
-    f2 (f1 x)) x ->
-  limit1_in (fun x0:R => f2 (f1 x0)) (D_x no_cond x) (f2 (f1 x)) x).
-intro; apply H1.
-eapply limit_comp.
-apply H.
-apply H0.
-unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
- simpl in |- *; unfold R_dist in |- *; intros.
-assert (H3 := H1 eps H2).
-elim H3; intros.
-exists x0.
-split.
-elim H4; intros; assumption.
-intros; case (Req_dec (f1 x) (f1 x1)); intro.
-rewrite H6; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- assumption.
-elim H4; intros; apply H8.
-split.
-unfold Dgf, D_x, no_cond in |- *.
-split.
-split.
-trivial.
-elim H5; unfold D_x, no_cond in |- *; intros.
-elim H9; intros; assumption.
-split.
-trivial.
-assumption.
-elim H5; intros; assumption.
+  forall f1 f2 (x:R),
+    continuity_pt f1 x -> continuity_pt f2 (f1 x) -> continuity_pt (f2 o f1) x.
+Proof.
+  unfold continuity_pt in |- *; unfold continue_in in |- *; intros;
+    unfold comp in |- *.
+  cut
+    (limit1_in (fun x0:R => f2 (f1 x0))
+      (Dgf (D_x no_cond x) (D_x no_cond (f1 x)) f1) (
+        f2 (f1 x)) x ->
+      limit1_in (fun x0:R => f2 (f1 x0)) (D_x no_cond x) (f2 (f1 x)) x).
+  intro; apply H1.
+  eapply limit_comp.
+  apply H.
+  apply H0.
+  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+    simpl in |- *; unfold R_dist in |- *; intros.
+  assert (H3 := H1 eps H2).
+  elim H3; intros.
+  exists x0.
+  split.
+  elim H4; intros; assumption.
+  intros; case (Req_dec (f1 x) (f1 x1)); intro.
+  rewrite H6; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    assumption.
+  elim H4; intros; apply H8.
+  split.
+  unfold Dgf, D_x, no_cond in |- *.
+  split.
+  split.
+  trivial.
+  elim H5; unfold D_x, no_cond in |- *; intros.
+  elim H9; intros; assumption.
+  split.
+  trivial.
+  assumption.
+  elim H5; intros; assumption.
 Qed.
 
 (**********) 
 Lemma continuity_plus :
- forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2).
-unfold continuity in |- *; intros;
- apply (continuity_pt_plus f1 f2 x (H x) (H0 x)).
+  forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2).
+Proof.
+  unfold continuity in |- *; intros;
+    apply (continuity_pt_plus f1 f2 x (H x) (H0 x)).
 Qed.
 
 Lemma continuity_opp : forall f, continuity f -> continuity (- f).
-unfold continuity in |- *; intros; apply (continuity_pt_opp f x (H x)).
+Proof.
+  unfold continuity in |- *; intros; apply (continuity_pt_opp f x (H x)).
 Qed.
 
 Lemma continuity_minus :
- forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 - f2).
-unfold continuity in |- *; intros;
- apply (continuity_pt_minus f1 f2 x (H x) (H0 x)).
+  forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 - f2).
+Proof.
+  unfold continuity in |- *; intros;
+    apply (continuity_pt_minus f1 f2 x (H x) (H0 x)).
 Qed.
- 
+
 Lemma continuity_mult :
- forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 * f2).
-unfold continuity in |- *; intros;
- apply (continuity_pt_mult f1 f2 x (H x) (H0 x)).
+  forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 * f2).
+Proof.
+  unfold continuity in |- *; intros;
+    apply (continuity_pt_mult f1 f2 x (H x) (H0 x)).
 Qed.
 
 Lemma continuity_const : forall f, constant f -> continuity f.
-unfold continuity in |- *; intros; apply (continuity_pt_const f x H).
+Proof.
+  unfold continuity in |- *; intros; apply (continuity_pt_const f x H).
 Qed.
 
 Lemma continuity_scal :
- forall f (a:R), continuity f -> continuity (mult_real_fct a f).
-unfold continuity in |- *; intros; apply (continuity_pt_scal f a x (H x)).
+  forall f (a:R), continuity f -> continuity (mult_real_fct a f).
+Proof.
+  unfold continuity in |- *; intros; apply (continuity_pt_scal f a x (H x)).
 Qed.
-  
+
 Lemma continuity_inv :
- forall f, continuity f -> (forall x:R, f x <> 0) -> continuity (/ f).
-unfold continuity in |- *; intros; apply (continuity_pt_inv f x (H x) (H0 x)).
+  forall f, continuity f -> (forall x:R, f x <> 0) -> continuity (/ f).
+Proof.
+  unfold continuity in |- *; intros; apply (continuity_pt_inv f x (H x) (H0 x)).
 Qed.
 
 Lemma continuity_div :
- forall f1 f2,
-   continuity f1 ->
-   continuity f2 -> (forall x:R, f2 x <> 0) -> continuity (f1 / f2).
-unfold continuity in |- *; intros;
- apply (continuity_pt_div f1 f2 x (H x) (H0 x) (H1 x)).
+  forall f1 f2,
+    continuity f1 ->
+    continuity f2 -> (forall x:R, f2 x <> 0) -> continuity (f1 / f2).
+Proof.
+  unfold continuity in |- *; intros;
+    apply (continuity_pt_div f1 f2 x (H x) (H0 x) (H1 x)).
 Qed.
- 
+
 Lemma continuity_comp :
- forall f1 f2, continuity f1 -> continuity f2 -> continuity (f2 o f1).
-unfold continuity in |- *; intros.
-apply (continuity_pt_comp f1 f2 x (H x) (H0 (f1 x))).
+  forall f1 f2, continuity f1 -> continuity f2 -> continuity (f2 o f1).
+Proof.
+  unfold continuity in |- *; intros.
+  apply (continuity_pt_comp f1 f2 x (H x) (H0 (f1 x))).
 Qed.
 
 
 (*****************************************************)
-(**  Derivative's definition using Landau's kernel   *)
+(** * Derivative's definition using Landau's kernel  *)
 (*****************************************************)
 
 Definition derivable_pt_lim f (x l:R) : Prop :=
   forall eps:R,
     0 < eps ->
-     exists delta : posreal,
+    exists delta : posreal,
       (forall h:R,
-         h <> 0 -> Rabs h < delta -> Rabs ((f (x + h) - f x) / h - l) < eps).
+        h <> 0 -> Rabs h < delta -> Rabs ((f (x + h) - f x) / h - l) < eps).
 
 Definition derivable_pt_abs f (x l:R) : Prop := derivable_pt_lim f x l.
 
@@ -255,1225 +284,1279 @@ Arguments Scope derive [Rfun_scope _].
 
 Definition antiderivative f (g:R -> R) (a b:R) : Prop :=
   (forall x:R,
-     a <= x <= b ->  exists pr : derivable_pt g x, f x = derive_pt g x pr) /\
+    a <= x <= b ->  exists pr : derivable_pt g x, f x = derive_pt g x pr) /\
   a <= b.
-(************************************)
-(** Class of differential functions *)
-(************************************)
+(**************************************)
+(** * Class of differential functions *)
+(**************************************)
 Record Differential : Type := mkDifferential
   {d1 :> R -> R; cond_diff : derivable d1}.
- 
+
 Record Differential_D2 : Type := mkDifferential_D2
   {d2 :> R -> R;
-   cond_D1 : derivable d2;
-   cond_D2 : derivable (derive d2 cond_D1)}.
+    cond_D1 : derivable d2;
+    cond_D2 : derivable (derive d2 cond_D1)}.
 
 (**********)
 Lemma uniqueness_step1 :
- forall f (x l1 l2:R),
-   limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l1 0 ->
-   limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l2 0 ->
-   l1 = l2.
-intros;
- apply
-  (single_limit (fun h:R => (f (x + h) - f x) / h) (
-     fun h:R => h <> 0) l1 l2 0); try assumption.
-unfold adhDa in |- *; intros; exists (alp / 2).
-split.
-unfold Rdiv in |- *; apply prod_neq_R0.
-red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
-apply Rinv_neq_0_compat; discrR.
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; unfold Rdiv in |- *; rewrite Rabs_mult.
-replace (Rabs (/ 2)) with (/ 2).
-replace (Rabs alp) with alp.
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
- [ idtac | discrR ]; rewrite Rmult_1_r; rewrite double;
- pattern alp at 1 in |- *; replace alp with (alp + 0); 
- [ idtac | ring ]; apply Rplus_lt_compat_l; assumption.
-symmetry  in |- *; apply Rabs_right; left; assumption.
-symmetry  in |- *; apply Rabs_right; left; change (0 < / 2) in |- *;
- apply Rinv_0_lt_compat; prove_sup0. 
+  forall f (x l1 l2:R),
+    limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l1 0 ->
+    limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l2 0 ->
+    l1 = l2.
+Proof.
+  intros;
+    apply
+      (single_limit (fun h:R => (f (x + h) - f x) / h) (
+        fun h:R => h <> 0) l1 l2 0); try assumption.
+  unfold adhDa in |- *; intros; exists (alp / 2).
+  split.
+  unfold Rdiv in |- *; apply prod_neq_R0.
+  red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
+  apply Rinv_neq_0_compat; discrR.
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; unfold Rdiv in |- *; rewrite Rabs_mult.
+  replace (Rabs (/ 2)) with (/ 2).
+  replace (Rabs alp) with alp.
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
+    [ idtac | discrR ]; rewrite Rmult_1_r; rewrite double;
+      pattern alp at 1 in |- *; replace alp with (alp + 0); 
+        [ idtac | ring ]; apply Rplus_lt_compat_l; assumption.
+  symmetry  in |- *; apply Rabs_right; left; assumption.
+  symmetry  in |- *; apply Rabs_right; left; change (0 < / 2) in |- *;
+    apply Rinv_0_lt_compat; prove_sup0. 
 Qed.
 
 Lemma uniqueness_step2 :
- forall f (x l:R),
-   derivable_pt_lim f x l ->
-   limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0.
-unfold derivable_pt_lim in |- *; intros; unfold limit1_in in |- *;
- unfold limit_in in |- *; intros.
-assert (H1 := H eps H0).
-elim H1; intros.
-exists (pos x0).
-split.
-apply (cond_pos x0).
-simpl in |- *; unfold R_dist in |- *; intros.
-elim H3; intros.
-apply H2;
- [ assumption
- | unfold Rminus in H5; rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5;
-    assumption ].
+  forall f (x l:R),
+    derivable_pt_lim f x l ->
+    limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0.
+Proof. 
+  unfold derivable_pt_lim in |- *; intros; unfold limit1_in in |- *;
+    unfold limit_in in |- *; intros.
+  assert (H1 := H eps H0).
+  elim H1; intros.
+  exists (pos x0).
+  split.
+  apply (cond_pos x0).
+  simpl in |- *; unfold R_dist in |- *; intros.
+  elim H3; intros.
+  apply H2;
+    [ assumption
+      | unfold Rminus in H5; rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5;
+        assumption ].
 Qed.
 
 Lemma uniqueness_step3 :
- forall f (x l:R),
-   limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 ->
-   derivable_pt_lim f x l.
-unfold limit1_in, derivable_pt_lim in |- *; unfold limit_in in |- *;
- unfold dist in |- *; simpl in |- *; intros.
-elim (H eps H0).
-intros; elim H1; intros.
-exists (mkposreal x0 H2).
-simpl in |- *; intros; unfold R_dist in H3; apply (H3 h).
-split;
- [ assumption
- | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; assumption ].
+  forall f (x l:R),
+    limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 ->
+    derivable_pt_lim f x l.
+Proof.
+  unfold limit1_in, derivable_pt_lim in |- *; unfold limit_in in |- *;
+    unfold dist in |- *; simpl in |- *; intros.
+  elim (H eps H0).
+  intros; elim H1; intros.
+  exists (mkposreal x0 H2).
+  simpl in |- *; intros; unfold R_dist in H3; apply (H3 h).
+  split;
+    [ assumption
+      | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; assumption ].
 Qed.
 
 Lemma uniqueness_limite :
- forall f (x l1 l2:R),
-   derivable_pt_lim f x l1 -> derivable_pt_lim f x l2 -> l1 = l2.
-intros.
-assert (H1 := uniqueness_step2 _ _ _ H).
-assert (H2 := uniqueness_step2 _ _ _ H0).
-assert (H3 := uniqueness_step1 _ _ _ _ H1 H2).
-assumption.
+  forall f (x l1 l2:R),
+    derivable_pt_lim f x l1 -> derivable_pt_lim f x l2 -> l1 = l2.
+Proof.
+  intros.
+  assert (H1 := uniqueness_step2 _ _ _ H).
+  assert (H2 := uniqueness_step2 _ _ _ H0).
+  assert (H3 := uniqueness_step1 _ _ _ _ H1 H2).
+  assumption.
 Qed.
 
 Lemma derive_pt_eq :
- forall f (x l:R) (pr:derivable_pt f x),
-   derive_pt f x pr = l <-> derivable_pt_lim f x l.
-intros; split.
-intro; assert (H1 := projT2 pr); unfold derive_pt in H; rewrite H in H1;
- assumption.
-intro; assert (H1 := projT2 pr); unfold derivable_pt_abs in H1.
-assert (H2 := uniqueness_limite _ _ _ _ H H1).
-unfold derive_pt in |- *; unfold derivable_pt_abs in |- *.
-symmetry  in |- *; assumption.
+  forall f (x l:R) (pr:derivable_pt f x),
+    derive_pt f x pr = l <-> derivable_pt_lim f x l.
+Proof.
+  intros; split.
+  intro; assert (H1 := projT2 pr); unfold derive_pt in H; rewrite H in H1;
+    assumption.
+  intro; assert (H1 := projT2 pr); unfold derivable_pt_abs in H1.
+  assert (H2 := uniqueness_limite _ _ _ _ H H1).
+  unfold derive_pt in |- *; unfold derivable_pt_abs in |- *.
+  symmetry  in |- *; assumption.
 Qed.
 
 (**********)
 Lemma derive_pt_eq_0 :
- forall f (x l:R) (pr:derivable_pt f x),
-   derivable_pt_lim f x l -> derive_pt f x pr = l.
-intros; elim (derive_pt_eq f x l pr); intros.
-apply (H1 H).
+  forall f (x l:R) (pr:derivable_pt f x),
+    derivable_pt_lim f x l -> derive_pt f x pr = l.
+Proof.
+  intros; elim (derive_pt_eq f x l pr); intros.
+  apply (H1 H).
 Qed.
 
 (**********)
 Lemma derive_pt_eq_1 :
- forall f (x l:R) (pr:derivable_pt f x),
-   derive_pt f x pr = l -> derivable_pt_lim f x l.
-intros; elim (derive_pt_eq f x l pr); intros.
-apply (H0 H).
+  forall f (x l:R) (pr:derivable_pt f x),
+    derive_pt f x pr = l -> derivable_pt_lim f x l.
+Proof.
+  intros; elim (derive_pt_eq f x l pr); intros.
+  apply (H0 H).
 Qed.
 
 
-(********************************************************************)
-(** Equivalence of this definition with the one using limit concept *)
-(********************************************************************)
+(**********************************************************************)
+(** * Equivalence of this definition with the one using limit concept *)
+(**********************************************************************)
 Lemma derive_pt_D_in :
- forall f (df:R -> R) (x:R) (pr:derivable_pt f x),
-   D_in f df no_cond x <-> derive_pt f x pr = df x.
-intros; split.
-unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
- simpl in |- *; unfold R_dist in |- *; intros.
-apply derive_pt_eq_0. 
-unfold derivable_pt_lim in |- *.
-intros; elim (H eps H0); intros alpha H1; elim H1; intros;
- exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); 
- intro; cut (x + h - x = h);
- [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
-    [ intro; generalize (H6 H8); rewrite H7; intro; assumption
-    | split;
-       [ unfold D_x in |- *; split;
-          [ unfold no_cond in |- *; trivial
-          | apply Rminus_not_eq_right; rewrite H7; assumption ]
-       | rewrite H7; assumption ] ]
- | ring ].
-intro.
-assert (H0 := derive_pt_eq_1 f x (df x) pr H).
-unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
- unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros.
-elim (H0 eps H1); intros alpha H2; exists (pos alpha); split.
-apply (cond_pos alpha).
-intros; elim H3; intros; unfold D_x in H4; elim H4; intros; cut (x0 - x <> 0).
-intro; generalize (H2 (x0 - x) H8 H5); replace (x + (x0 - x)) with x0.
-intro; assumption.
-ring.
-auto with real.
+  forall f (df:R -> R) (x:R) (pr:derivable_pt f x),
+    D_in f df no_cond x <-> derive_pt f x pr = df x.
+Proof.
+  intros; split.
+  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
+    simpl in |- *; unfold R_dist in |- *; intros.
+  apply derive_pt_eq_0. 
+  unfold derivable_pt_lim in |- *.
+  intros; elim (H eps H0); intros alpha H1; elim H1; intros;
+    exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); 
+      intro; cut (x + h - x = h);
+        [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
+          [ intro; generalize (H6 H8); rewrite H7; intro; assumption
+            | split;
+              [ unfold D_x in |- *; split;
+                [ unfold no_cond in |- *; trivial
+                  | apply Rminus_not_eq_right; rewrite H7; assumption ]
+                | rewrite H7; assumption ] ]
+          | ring ].
+  intro.
+  assert (H0 := derive_pt_eq_1 f x (df x) pr H).
+  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
+    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+      intros.
+  elim (H0 eps H1); intros alpha H2; exists (pos alpha); split.
+  apply (cond_pos alpha).
+  intros; elim H3; intros; unfold D_x in H4; elim H4; intros; cut (x0 - x <> 0).
+  intro; generalize (H2 (x0 - x) H8 H5); replace (x + (x0 - x)) with x0.
+  intro; assumption.
+  ring.
+  auto with real.
 Qed.
 
 Lemma derivable_pt_lim_D_in :
- forall f (df:R -> R) (x:R),
-   D_in f df no_cond x <-> derivable_pt_lim f x (df x).
-intros; split.
-unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
- simpl in |- *; unfold R_dist in |- *; intros.
-unfold derivable_pt_lim in |- *.
-intros; elim (H eps H0); intros alpha H1; elim H1; intros;
- exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); 
- intro; cut (x + h - x = h);
- [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
-    [ intro; generalize (H6 H8); rewrite H7; intro; assumption
-    | split;
-       [ unfold D_x in |- *; split;
-          [ unfold no_cond in |- *; trivial
-          | apply Rminus_not_eq_right; rewrite H7; assumption ]
-       | rewrite H7; assumption ] ]
- | ring ].
-intro.
-unfold derivable_pt_lim in H.
-unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
- unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros.
-elim (H eps H0); intros alpha H2; exists (pos alpha); split.
-apply (cond_pos alpha).
-intros.
-elim H1; intros; unfold D_x in H3; elim H3; intros; cut (x0 - x <> 0).
-intro; generalize (H2 (x0 - x) H7 H4); replace (x + (x0 - x)) with x0.
-intro; assumption.
-ring.
-auto with real.
+  forall f (df:R -> R) (x:R),
+    D_in f df no_cond x <-> derivable_pt_lim f x (df x).
+Proof.
+  intros; split.
+  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
+    simpl in |- *; unfold R_dist in |- *; intros.
+  unfold derivable_pt_lim in |- *.
+  intros; elim (H eps H0); intros alpha H1; elim H1; intros;
+    exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); 
+      intro; cut (x + h - x = h);
+        [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
+          [ intro; generalize (H6 H8); rewrite H7; intro; assumption
+            | split;
+              [ unfold D_x in |- *; split;
+                [ unfold no_cond in |- *; trivial
+                  | apply Rminus_not_eq_right; rewrite H7; assumption ]
+                | rewrite H7; assumption ] ]
+          | ring ].
+  intro.
+  unfold derivable_pt_lim in H.
+  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
+    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+      intros.
+  elim (H eps H0); intros alpha H2; exists (pos alpha); split.
+  apply (cond_pos alpha).
+  intros.
+  elim H1; intros; unfold D_x in H3; elim H3; intros; cut (x0 - x <> 0).
+  intro; generalize (H2 (x0 - x) H7 H4); replace (x + (x0 - x)) with x0.
+  intro; assumption.
+  ring.
+  auto with real.
 Qed.
 
 
 (***********************************)
-(**   derivability -> continuity   *)
+(** * derivability -> continuity   *)
 (***********************************)
 (**********)
 Lemma derivable_derive :
- forall f (x:R) (pr:derivable_pt f x),  exists l : R, derive_pt f x pr = l.
-intros; exists (projT1 pr).
-unfold derive_pt in |- *; reflexivity.
+  forall f (x:R) (pr:derivable_pt f x),  exists l : R, derive_pt f x pr = l.
+Proof.
+  intros; exists (projT1 pr).
+  unfold derive_pt in |- *; reflexivity.
 Qed.
 
 Theorem derivable_continuous_pt :
- forall f (x:R), derivable_pt f x -> continuity_pt f x.
-intros.
-generalize (derivable_derive f x X); intro.
-elim H; intros l H1.
-cut (l = fct_cte l x).
-intro.
-rewrite H0 in H1.
-generalize (derive_pt_D_in f (fct_cte l) x); intro.
-elim (H2 X); intros.
-generalize (H4 H1); intro.
-unfold continuity_pt in |- *.
-apply (cont_deriv f (fct_cte l) no_cond x H5).
-unfold fct_cte in |- *; reflexivity.
+  forall f (x:R), derivable_pt f x -> continuity_pt f x.
+Proof.
+  intros f x X.
+  generalize (derivable_derive f x X); intro.
+  elim H; intros l H1.
+  cut (l = fct_cte l x).
+  intro.
+  rewrite H0 in H1.
+  generalize (derive_pt_D_in f (fct_cte l) x); intro.
+  elim (H2 X); intros.
+  generalize (H4 H1); intro.
+  unfold continuity_pt in |- *.
+  apply (cont_deriv f (fct_cte l) no_cond x H5).
+  unfold fct_cte in |- *; reflexivity.
 Qed.
 
 Theorem derivable_continuous : forall f, derivable f -> continuity f.
-unfold derivable, continuity in |- *; intros.
-apply (derivable_continuous_pt f x (X x)).
+Proof.
+  unfold derivable, continuity in |- *; intros f X x.
+  apply (derivable_continuous_pt f x (X x)).
 Qed.
 
 (****************************************************************)
-(**                      Main rules                             *)
+(** *                    Main rules                             *)
 (****************************************************************)
 
 Lemma derivable_pt_lim_plus :
- forall f1 f2 (x l1 l2:R),
-   derivable_pt_lim f1 x l1 ->
-   derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 + f2) x (l1 + l2).
-intros.
-apply uniqueness_step3.
-assert (H1 := uniqueness_step2 _ _ _ H).
-assert (H2 := uniqueness_step2 _ _ _ H0).
-unfold plus_fct in |- *.
-cut
- (forall h:R,
-    (f1 (x + h) + f2 (x + h) - (f1 x + f2 x)) / h =
-    (f1 (x + h) - f1 x) / h + (f2 (x + h) - f2 x) / h).
-intro.
-generalize
- (limit_plus (fun h':R => (f1 (x + h') - f1 x) / h')
-    (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
-unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
- simpl in |- *; unfold R_dist in |- *; intros.
-elim (H4 eps H5); intros.
-exists x0.
-elim H6; intros.
-split.
-assumption.
-intros; rewrite H3; apply H8; assumption.
-intro; unfold Rdiv in |- *; ring.
+  forall f1 f2 (x l1 l2:R),
+    derivable_pt_lim f1 x l1 ->
+    derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 + f2) x (l1 + l2).
+  intros.
+  apply uniqueness_step3.
+  assert (H1 := uniqueness_step2 _ _ _ H).
+  assert (H2 := uniqueness_step2 _ _ _ H0).
+  unfold plus_fct in |- *.
+  cut
+    (forall h:R,
+      (f1 (x + h) + f2 (x + h) - (f1 x + f2 x)) / h =
+      (f1 (x + h) - f1 x) / h + (f2 (x + h) - f2 x) / h).
+  intro.
+  generalize
+    (limit_plus (fun h':R => (f1 (x + h') - f1 x) / h')
+      (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
+  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+    simpl in |- *; unfold R_dist in |- *; intros.
+  elim (H4 eps H5); intros.
+  exists x0.
+  elim H6; intros.
+  split.
+  assumption.
+  intros; rewrite H3; apply H8; assumption.
+  intro; unfold Rdiv in |- *; ring.
 Qed.
 
 Lemma derivable_pt_lim_opp :
- forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l).
-intros.
-apply uniqueness_step3.
-assert (H1 := uniqueness_step2 _ _ _ H).
-unfold opp_fct in |- *.
-cut (forall h:R, (- f (x + h) - - f x) / h = - ((f (x + h) - f x) / h)).
-intro.
-generalize
- (limit_Ropp (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 H1).
-unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
- simpl in |- *; unfold R_dist in |- *; intros.
-elim (H2 eps H3); intros.
-exists x0.
-elim H4; intros.
-split.
-assumption.
-intros; rewrite H0; apply H6; assumption.
-intro; unfold Rdiv in |- *; ring.
+  forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l).
+Proof. 
+  intros.
+  apply uniqueness_step3.
+  assert (H1 := uniqueness_step2 _ _ _ H).
+  unfold opp_fct in |- *.
+  cut (forall h:R, (- f (x + h) - - f x) / h = - ((f (x + h) - f x) / h)).
+  intro.
+  generalize
+    (limit_Ropp (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 H1).
+  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+    simpl in |- *; unfold R_dist in |- *; intros.
+  elim (H2 eps H3); intros.
+  exists x0.
+  elim H4; intros.
+  split.
+  assumption.
+  intros; rewrite H0; apply H6; assumption.
+  intro; unfold Rdiv in |- *; ring.
 Qed.
 
 Lemma derivable_pt_lim_minus :
- forall f1 f2 (x l1 l2:R),
-   derivable_pt_lim f1 x l1 ->
-   derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 - f2) x (l1 - l2).
-intros.
-apply uniqueness_step3.
-assert (H1 := uniqueness_step2 _ _ _ H).
-assert (H2 := uniqueness_step2 _ _ _ H0).
-unfold minus_fct in |- *.
-cut
- (forall h:R,
-    (f1 (x + h) - f1 x) / h - (f2 (x + h) - f2 x) / h =
-    (f1 (x + h) - f2 (x + h) - (f1 x - f2 x)) / h).
-intro.
-generalize
- (limit_minus (fun h':R => (f1 (x + h') - f1 x) / h')
-    (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
-unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
- simpl in |- *; unfold R_dist in |- *; intros.
-elim (H4 eps H5); intros.
-exists x0.
-elim H6; intros.
-split.
-assumption.
-intros; rewrite <- H3; apply H8; assumption.
-intro; unfold Rdiv in |- *; ring.
+  forall f1 f2 (x l1 l2:R),
+    derivable_pt_lim f1 x l1 ->
+    derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 - f2) x (l1 - l2).
+Proof.
+  intros.
+  apply uniqueness_step3.
+  assert (H1 := uniqueness_step2 _ _ _ H).
+  assert (H2 := uniqueness_step2 _ _ _ H0).
+  unfold minus_fct in |- *.
+  cut
+    (forall h:R,
+      (f1 (x + h) - f1 x) / h - (f2 (x + h) - f2 x) / h =
+      (f1 (x + h) - f2 (x + h) - (f1 x - f2 x)) / h).
+  intro.
+  generalize
+    (limit_minus (fun h':R => (f1 (x + h') - f1 x) / h')
+      (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
+  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+    simpl in |- *; unfold R_dist in |- *; intros.
+  elim (H4 eps H5); intros.
+  exists x0.
+  elim H6; intros.
+  split.
+  assumption.
+  intros; rewrite <- H3; apply H8; assumption.
+  intro; unfold Rdiv in |- *; ring.
 Qed.
 
 Lemma derivable_pt_lim_mult :
- forall f1 f2 (x l1 l2:R),
-   derivable_pt_lim f1 x l1 ->
-   derivable_pt_lim f2 x l2 ->
-   derivable_pt_lim (f1 * f2) x (l1 * f2 x + f1 x * l2).
-intros.
-assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x).
-elim H1; intros.
-assert (H4 := H3 H).
-assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) x).
-elim H5; intros.
-assert (H8 := H7 H0).
-clear H1 H2 H3 H5 H6 H7.
-assert
- (H1 :=
-  derivable_pt_lim_D_in (f1 * f2)%F (fun y:R => l1 * f2 x + f1 x * l2) x).
-elim H1; intros.
-clear H1 H3.
-apply H2.
-unfold mult_fct in |- *.
-apply (Dmult no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); assumption.
+  forall f1 f2 (x l1 l2:R),
+    derivable_pt_lim f1 x l1 ->
+    derivable_pt_lim f2 x l2 ->
+    derivable_pt_lim (f1 * f2) x (l1 * f2 x + f1 x * l2).
+Proof.
+  intros.
+  assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x).
+  elim H1; intros.
+  assert (H4 := H3 H).
+  assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) x).
+  elim H5; intros.
+  assert (H8 := H7 H0).
+  clear H1 H2 H3 H5 H6 H7.
+  assert
+    (H1 :=
+      derivable_pt_lim_D_in (f1 * f2)%F (fun y:R => l1 * f2 x + f1 x * l2) x).
+  elim H1; intros.
+  clear H1 H3.
+  apply H2.
+  unfold mult_fct in |- *.
+  apply (Dmult no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); assumption.
 Qed.
 
 Lemma derivable_pt_lim_const : forall a x:R, derivable_pt_lim (fct_cte a) x 0.
-intros; unfold fct_cte, derivable_pt_lim in |- *.
-intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Rminus in |- *;
- rewrite Rplus_opp_r; unfold Rdiv in |- *; rewrite Rmult_0_l;
- rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+Proof.
+  intros; unfold fct_cte, derivable_pt_lim in |- *.
+  intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Rminus in |- *;
+    rewrite Rplus_opp_r; unfold Rdiv in |- *; rewrite Rmult_0_l;
+      rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
 Qed.
 
 Lemma derivable_pt_lim_scal :
- forall f (a x l:R),
-   derivable_pt_lim f x l -> derivable_pt_lim (mult_real_fct a f) x (a * l).
-intros.
-assert (H0 := derivable_pt_lim_const a x).
-replace (mult_real_fct a f) with (fct_cte a * f)%F.
-replace (a * l) with (0 * f x + a * l); [ idtac | ring ].
-apply (derivable_pt_lim_mult (fct_cte a) f x 0 l); assumption.
-unfold mult_real_fct, mult_fct, fct_cte in |- *; reflexivity.
+  forall f (a x l:R),
+    derivable_pt_lim f x l -> derivable_pt_lim (mult_real_fct a f) x (a * l).
+Proof.
+  intros.
+  assert (H0 := derivable_pt_lim_const a x).
+  replace (mult_real_fct a f) with (fct_cte a * f)%F.
+  replace (a * l) with (0 * f x + a * l); [ idtac | ring ].
+  apply (derivable_pt_lim_mult (fct_cte a) f x 0 l); assumption.
+  unfold mult_real_fct, mult_fct, fct_cte in |- *; reflexivity.
 Qed.
 
 Lemma derivable_pt_lim_id : forall x:R, derivable_pt_lim id x 1.
-intro; unfold derivable_pt_lim in |- *.
-intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2;
- unfold id in |- *; replace ((x + h - x) / h - 1) with 0.
-rewrite Rabs_R0; apply Rle_lt_trans with (Rabs h).
-apply Rabs_pos.
-assumption.
-unfold Rminus in |- *; rewrite Rplus_assoc; rewrite (Rplus_comm x);
- rewrite Rplus_assoc.
-rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv in |- *;
- rewrite <- Rinv_r_sym.
-symmetry  in |- *; apply Rplus_opp_r.
-assumption.
+Proof.
+  intro; unfold derivable_pt_lim in |- *.
+  intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2;
+    unfold id in |- *; replace ((x + h - x) / h - 1) with 0.
+  rewrite Rabs_R0; apply Rle_lt_trans with (Rabs h).
+  apply Rabs_pos.
+  assumption.
+  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite (Rplus_comm x);
+    rewrite Rplus_assoc.
+  rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv in |- *;
+    rewrite <- Rinv_r_sym.
+  symmetry  in |- *; apply Rplus_opp_r.
+  assumption.
 Qed.
 
 Lemma derivable_pt_lim_Rsqr : forall x:R, derivable_pt_lim Rsqr x (2 * x).
-intro; unfold derivable_pt_lim in |- *.
-unfold Rsqr in |- *; intros eps Heps; exists (mkposreal eps Heps);
- intros h H1 H2; replace (((x + h) * (x + h) - x * x) / h - 2 * x) with h.
-assumption.
-replace ((x + h) * (x + h) - x * x) with (2 * x * h + h * h);
- [ idtac | ring ].
-unfold Rdiv in |- *; rewrite Rmult_plus_distr_r.
-repeat rewrite Rmult_assoc.
-repeat rewrite <- Rinv_r_sym; [ idtac | assumption ].
-ring.
+Proof.
+  intro; unfold derivable_pt_lim in |- *.
+  unfold Rsqr in |- *; intros eps Heps; exists (mkposreal eps Heps);
+    intros h H1 H2; replace (((x + h) * (x + h) - x * x) / h - 2 * x) with h.
+  assumption.
+  replace ((x + h) * (x + h) - x * x) with (2 * x * h + h * h);
+  [ idtac | ring ].
+  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r.
+  repeat rewrite Rmult_assoc.
+  repeat rewrite <- Rinv_r_sym; [ idtac | assumption ].
+  ring.
 Qed.
 
 Lemma derivable_pt_lim_comp :
- forall f1 f2 (x l1 l2:R),
-   derivable_pt_lim f1 x l1 ->
-   derivable_pt_lim f2 (f1 x) l2 -> derivable_pt_lim (f2 o f1) x (l2 * l1).
-intros; assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x).
-elim H1; intros.
-assert (H4 := H3 H).
-assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) (f1 x)).
-elim H5; intros.
-assert (H8 := H7 H0).
-clear H1 H2 H3 H5 H6 H7.
-assert (H1 := derivable_pt_lim_D_in (f2 o f1)%F (fun y:R => l2 * l1) x).
-elim H1; intros.
-clear H1 H3; apply H2.
-unfold comp in |- *;
- cut
-  (D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1)
-     (Dgf no_cond no_cond f1) x ->
-   D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) no_cond x).
-intro; apply H1.
-rewrite Rmult_comm;
- apply (Dcomp no_cond no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x);
- assumption.
-unfold Dgf, D_in, no_cond in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; unfold dist in |- *; simpl in |- *;
- unfold R_dist in |- *; intros.
-elim (H1 eps H3); intros.
-exists x0; intros; split.
-elim H5; intros; assumption.
-intros; elim H5; intros; apply H9; split.
-unfold D_x in |- *; split.
-split; trivial.
-elim H6; intros; unfold D_x in H10; elim H10; intros; assumption.
-elim H6; intros; assumption.
+  forall f1 f2 (x l1 l2:R),
+    derivable_pt_lim f1 x l1 ->
+    derivable_pt_lim f2 (f1 x) l2 -> derivable_pt_lim (f2 o f1) x (l2 * l1).
+Proof.
+  intros; assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x).
+  elim H1; intros.
+  assert (H4 := H3 H).
+  assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) (f1 x)).
+  elim H5; intros.
+  assert (H8 := H7 H0).
+  clear H1 H2 H3 H5 H6 H7.
+  assert (H1 := derivable_pt_lim_D_in (f2 o f1)%F (fun y:R => l2 * l1) x).
+  elim H1; intros.
+  clear H1 H3; apply H2.
+  unfold comp in |- *;
+    cut
+      (D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1)
+        (Dgf no_cond no_cond f1) x ->
+        D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) no_cond x).
+  intro; apply H1.
+  rewrite Rmult_comm;
+    apply (Dcomp no_cond no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x);
+      assumption.
+  unfold Dgf, D_in, no_cond in |- *; unfold limit1_in in |- *;
+    unfold limit_in in |- *; unfold dist in |- *; simpl in |- *;
+      unfold R_dist in |- *; intros.
+  elim (H1 eps H3); intros.
+  exists x0; intros; split.
+  elim H5; intros; assumption.
+  intros; elim H5; intros; apply H9; split.
+  unfold D_x in |- *; split.
+  split; trivial.
+  elim H6; intros; unfold D_x in H10; elim H10; intros; assumption.
+  elim H6; intros; assumption.
 Qed.
 
 Lemma derivable_pt_plus :
- forall f1 f2 (x:R),
-   derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x.
-unfold derivable_pt in |- *; intros.
-elim X; intros.
-elim X0; intros.
-apply existT with (x0 + x1).
-apply derivable_pt_lim_plus; assumption.
+  forall f1 f2 (x:R),
+    derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x.
+Proof.
+  unfold derivable_pt in |- *; intros f1 f2 x X X0.
+  elim X; intros.
+  elim X0; intros.
+  apply existT with (x0 + x1).
+  apply derivable_pt_lim_plus; assumption.
 Qed.
 
 Lemma derivable_pt_opp :
- forall f (x:R), derivable_pt f x -> derivable_pt (- f) x.
-unfold derivable_pt in |- *; intros.
-elim X; intros.
-apply existT with (- x0).
-apply derivable_pt_lim_opp; assumption.
+  forall f (x:R), derivable_pt f x -> derivable_pt (- f) x.
+Proof.
+  unfold derivable_pt in |- *; intros f x X.
+  elim X; intros.
+  apply existT with (- x0).
+  apply derivable_pt_lim_opp; assumption.
 Qed.
 
 Lemma derivable_pt_minus :
- forall f1 f2 (x:R),
-   derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x.
-unfold derivable_pt in |- *; intros.
-elim X; intros.
-elim X0; intros.
-apply existT with (x0 - x1).
-apply derivable_pt_lim_minus; assumption.
+  forall f1 f2 (x:R),
+    derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x.
+Proof.
+  unfold derivable_pt in |- *; intros f1 f2 x X X0.
+  elim X; intros.
+  elim X0; intros.
+  apply existT with (x0 - x1).
+  apply derivable_pt_lim_minus; assumption.
 Qed.
 
 Lemma derivable_pt_mult :
- forall f1 f2 (x:R),
-   derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 * f2) x.
-unfold derivable_pt in |- *; intros.
-elim X; intros.
-elim X0; intros.
-apply existT with (x0 * f2 x + f1 x * x1).
-apply derivable_pt_lim_mult; assumption.
+  forall f1 f2 (x:R),
+    derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 * f2) x.
+Proof.
+  unfold derivable_pt in |- *; intros f1 f2 x X X0.
+  elim X; intros.
+  elim X0; intros.
+  apply existT with (x0 * f2 x + f1 x * x1).
+  apply derivable_pt_lim_mult; assumption.
 Qed.
 
 Lemma derivable_pt_const : forall a x:R, derivable_pt (fct_cte a) x.
-intros; unfold derivable_pt in |- *.
-apply existT with 0.
-apply derivable_pt_lim_const.
+Proof.
+  intros; unfold derivable_pt in |- *.
+  apply existT with 0.
+  apply derivable_pt_lim_const.
 Qed.
 
 Lemma derivable_pt_scal :
- forall f (a x:R), derivable_pt f x -> derivable_pt (mult_real_fct a f) x.
-unfold derivable_pt in |- *; intros.
-elim X; intros.
-apply existT with (a * x0).
-apply derivable_pt_lim_scal; assumption.
+  forall f (a x:R), derivable_pt f x -> derivable_pt (mult_real_fct a f) x.
+Proof.
+  unfold derivable_pt in |- *; intros f1 a x X.
+  elim X; intros.
+  apply existT with (a * x0).
+  apply derivable_pt_lim_scal; assumption.
 Qed.
 
 Lemma derivable_pt_id : forall x:R, derivable_pt id x.
-unfold derivable_pt in |- *; intro.
-exists 1.
-apply derivable_pt_lim_id.
+Proof.
+  unfold derivable_pt in |- *; intro.
+  exists 1.
+  apply derivable_pt_lim_id.
 Qed.
 
 Lemma derivable_pt_Rsqr : forall x:R, derivable_pt Rsqr x.
-unfold derivable_pt in |- *; intro; apply existT with (2 * x).
-apply derivable_pt_lim_Rsqr.
+Proof.
+  unfold derivable_pt in |- *; intro; apply existT with (2 * x).
+  apply derivable_pt_lim_Rsqr.
 Qed.
 
 Lemma derivable_pt_comp :
- forall f1 f2 (x:R),
-   derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x.
-unfold derivable_pt in |- *; intros.
-elim X; intros.
-elim X0; intros.
-apply existT with (x1 * x0).
-apply derivable_pt_lim_comp; assumption.
+  forall f1 f2 (x:R),
+    derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x.
+Proof.
+  unfold derivable_pt in |- *; intros f1 f2 x X X0.
+  elim X; intros.
+  elim X0; intros.
+  apply existT with (x1 * x0).
+  apply derivable_pt_lim_comp; assumption.
 Qed.
 
 Lemma derivable_plus :
- forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2).
-unfold derivable in |- *; intros.
-apply (derivable_pt_plus _ _ x (X _) (X0 _)).
+  forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2).
+Proof.
+  unfold derivable in |- *; intros f1 f2 X X0 x.
+  apply (derivable_pt_plus _ _ x (X _) (X0 _)).
 Qed.
 
 Lemma derivable_opp : forall f, derivable f -> derivable (- f).
-unfold derivable in |- *; intros.
-apply (derivable_pt_opp _ x (X _)).
+Proof.
+  unfold derivable in |- *; intros f X x.
+  apply (derivable_pt_opp _ x (X _)).
 Qed.
 
 Lemma derivable_minus :
- forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 - f2).
-unfold derivable in |- *; intros.
-apply (derivable_pt_minus _ _ x (X _) (X0 _)).
+  forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 - f2).
+Proof.
+  unfold derivable in |- *; intros f1 f2 X X0 x.
+  apply (derivable_pt_minus _ _ x (X _) (X0 _)).
 Qed.
 
 Lemma derivable_mult :
- forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 * f2).
-unfold derivable in |- *; intros.
-apply (derivable_pt_mult _ _ x (X _) (X0 _)).
+  forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 * f2).
+Proof.
+  unfold derivable in |- *; intros f1 f2 X X0 x.
+  apply (derivable_pt_mult _ _ x (X _) (X0 _)).
 Qed.
 
 Lemma derivable_const : forall a:R, derivable (fct_cte a).
-unfold derivable in |- *; intros.
-apply derivable_pt_const.
+Proof.
+  unfold derivable in |- *; intros.
+  apply derivable_pt_const.
 Qed.
 
 Lemma derivable_scal :
- forall f (a:R), derivable f -> derivable (mult_real_fct a f).
-unfold derivable in |- *; intros.
-apply (derivable_pt_scal _ a x (X _)).
+  forall f (a:R), derivable f -> derivable (mult_real_fct a f).
+Proof.
+  unfold derivable in |- *; intros f a X x.
+  apply (derivable_pt_scal _ a x (X _)).
 Qed.
 
 Lemma derivable_id : derivable id.
-unfold derivable in |- *; intro; apply derivable_pt_id.
+Proof.
+  unfold derivable in |- *; intro; apply derivable_pt_id.
 Qed.
 
 Lemma derivable_Rsqr : derivable Rsqr.
-unfold derivable in |- *; intro; apply derivable_pt_Rsqr.
+Proof.
+  unfold derivable in |- *; intro; apply derivable_pt_Rsqr.
 Qed.
 
 Lemma derivable_comp :
- forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1).
-unfold derivable in |- *; intros.
-apply (derivable_pt_comp _ _ x (X _) (X0 _)).
+  forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1).
+Proof.
+  unfold derivable in |- *; intros f1 f2 X X0 x.
+  apply (derivable_pt_comp _ _ x (X _) (X0 _)).
 Qed.
 
 Lemma derive_pt_plus :
- forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
-   derive_pt (f1 + f2) x (derivable_pt_plus _ _ _ pr1 pr2) =
-   derive_pt f1 x pr1 + derive_pt f2 x pr2.
-intros.
-assert (H := derivable_derive f1 x pr1).
-assert (H0 := derivable_derive f2 x pr2).
-assert
- (H1 := derivable_derive (f1 + f2)%F x (derivable_pt_plus _ _ _ pr1 pr2)).
-elim H; clear H; intros l1 H.
-elim H0; clear H0; intros l2 H0.
-elim H1; clear H1; intros l H1.
-rewrite H; rewrite H0; apply derive_pt_eq_0.
-assert (H3 := projT2 pr1).
-unfold derive_pt in H; rewrite H in H3.
-assert (H4 := projT2 pr2).
-unfold derive_pt in H0; rewrite H0 in H4.
-apply derivable_pt_lim_plus; assumption.
+  forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
+    derive_pt (f1 + f2) x (derivable_pt_plus _ _ _ pr1 pr2) =
+    derive_pt f1 x pr1 + derive_pt f2 x pr2.
+Proof.
+  intros.
+  assert (H := derivable_derive f1 x pr1).
+  assert (H0 := derivable_derive f2 x pr2).
+  assert
+    (H1 := derivable_derive (f1 + f2)%F x (derivable_pt_plus _ _ _ pr1 pr2)).
+  elim H; clear H; intros l1 H.
+  elim H0; clear H0; intros l2 H0.
+  elim H1; clear H1; intros l H1.
+  rewrite H; rewrite H0; apply derive_pt_eq_0.
+  assert (H3 := projT2 pr1).
+  unfold derive_pt in H; rewrite H in H3.
+  assert (H4 := projT2 pr2).
+  unfold derive_pt in H0; rewrite H0 in H4.
+  apply derivable_pt_lim_plus; assumption.
 Qed.
 
 Lemma derive_pt_opp :
- forall f (x:R) (pr1:derivable_pt f x),
-   derive_pt (- f) x (derivable_pt_opp _ _ pr1) = - derive_pt f x pr1.
-intros.
-assert (H := derivable_derive f x pr1).
-assert (H0 := derivable_derive (- f)%F x (derivable_pt_opp _ _ pr1)).
-elim H; clear H; intros l1 H.
-elim H0; clear H0; intros l2 H0.
-rewrite H; apply derive_pt_eq_0.
-assert (H3 := projT2 pr1).
-unfold derive_pt in H; rewrite H in H3.
-apply derivable_pt_lim_opp; assumption.
+  forall f (x:R) (pr1:derivable_pt f x),
+    derive_pt (- f) x (derivable_pt_opp _ _ pr1) = - derive_pt f x pr1.
+Proof.
+  intros.
+  assert (H := derivable_derive f x pr1).
+  assert (H0 := derivable_derive (- f)%F x (derivable_pt_opp _ _ pr1)).
+  elim H; clear H; intros l1 H.
+  elim H0; clear H0; intros l2 H0.
+  rewrite H; apply derive_pt_eq_0.
+  assert (H3 := projT2 pr1).
+  unfold derive_pt in H; rewrite H in H3.
+  apply derivable_pt_lim_opp; assumption.
 Qed.
 
 Lemma derive_pt_minus :
- forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
-   derive_pt (f1 - f2) x (derivable_pt_minus _ _ _ pr1 pr2) =
-   derive_pt f1 x pr1 - derive_pt f2 x pr2.
-intros.
-assert (H := derivable_derive f1 x pr1).
-assert (H0 := derivable_derive f2 x pr2).
-assert
- (H1 := derivable_derive (f1 - f2)%F x (derivable_pt_minus _ _ _ pr1 pr2)).
-elim H; clear H; intros l1 H.
-elim H0; clear H0; intros l2 H0.
-elim H1; clear H1; intros l H1.
-rewrite H; rewrite H0; apply derive_pt_eq_0.
-assert (H3 := projT2 pr1).
-unfold derive_pt in H; rewrite H in H3.
-assert (H4 := projT2 pr2).
-unfold derive_pt in H0; rewrite H0 in H4.
-apply derivable_pt_lim_minus; assumption.
+  forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
+    derive_pt (f1 - f2) x (derivable_pt_minus _ _ _ pr1 pr2) =
+    derive_pt f1 x pr1 - derive_pt f2 x pr2.
+Proof.
+  intros.
+  assert (H := derivable_derive f1 x pr1).
+  assert (H0 := derivable_derive f2 x pr2).
+  assert
+    (H1 := derivable_derive (f1 - f2)%F x (derivable_pt_minus _ _ _ pr1 pr2)).
+  elim H; clear H; intros l1 H.
+  elim H0; clear H0; intros l2 H0.
+  elim H1; clear H1; intros l H1.
+  rewrite H; rewrite H0; apply derive_pt_eq_0.
+  assert (H3 := projT2 pr1).
+  unfold derive_pt in H; rewrite H in H3.
+  assert (H4 := projT2 pr2).
+  unfold derive_pt in H0; rewrite H0 in H4.
+  apply derivable_pt_lim_minus; assumption.
 Qed.
 
 Lemma derive_pt_mult :
- forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
-   derive_pt (f1 * f2) x (derivable_pt_mult _ _ _ pr1 pr2) =
-   derive_pt f1 x pr1 * f2 x + f1 x * derive_pt f2 x pr2.
-intros.
-assert (H := derivable_derive f1 x pr1).
-assert (H0 := derivable_derive f2 x pr2).
-assert
- (H1 := derivable_derive (f1 * f2)%F x (derivable_pt_mult _ _ _ pr1 pr2)).
-elim H; clear H; intros l1 H.
-elim H0; clear H0; intros l2 H0.
-elim H1; clear H1; intros l H1.
-rewrite H; rewrite H0; apply derive_pt_eq_0.
-assert (H3 := projT2 pr1).
-unfold derive_pt in H; rewrite H in H3.
-assert (H4 := projT2 pr2).
-unfold derive_pt in H0; rewrite H0 in H4.
-apply derivable_pt_lim_mult; assumption.
+  forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
+    derive_pt (f1 * f2) x (derivable_pt_mult _ _ _ pr1 pr2) =
+    derive_pt f1 x pr1 * f2 x + f1 x * derive_pt f2 x pr2.
+Proof.
+  intros.
+  assert (H := derivable_derive f1 x pr1).
+  assert (H0 := derivable_derive f2 x pr2).
+  assert
+    (H1 := derivable_derive (f1 * f2)%F x (derivable_pt_mult _ _ _ pr1 pr2)).
+  elim H; clear H; intros l1 H.
+  elim H0; clear H0; intros l2 H0.
+  elim H1; clear H1; intros l H1.
+  rewrite H; rewrite H0; apply derive_pt_eq_0.
+  assert (H3 := projT2 pr1).
+  unfold derive_pt in H; rewrite H in H3.
+  assert (H4 := projT2 pr2).
+  unfold derive_pt in H0; rewrite H0 in H4.
+  apply derivable_pt_lim_mult; assumption.
 Qed.
 
 Lemma derive_pt_const :
- forall a x:R, derive_pt (fct_cte a) x (derivable_pt_const a x) = 0.
-intros.
-apply derive_pt_eq_0.
-apply derivable_pt_lim_const.
+  forall a x:R, derive_pt (fct_cte a) x (derivable_pt_const a x) = 0.
+Proof.
+  intros.
+  apply derive_pt_eq_0.
+  apply derivable_pt_lim_const.
 Qed.
 
 Lemma derive_pt_scal :
- forall f (a x:R) (pr:derivable_pt f x),
-   derive_pt (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr) =
-   a * derive_pt f x pr.
-intros.
-assert (H := derivable_derive f x pr).
-assert
- (H0 := derivable_derive (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr)).
-elim H; clear H; intros l1 H.
-elim H0; clear H0; intros l2 H0.
-rewrite H; apply derive_pt_eq_0.
-assert (H3 := projT2 pr).
-unfold derive_pt in H; rewrite H in H3.
-apply derivable_pt_lim_scal; assumption.
+  forall f (a x:R) (pr:derivable_pt f x),
+    derive_pt (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr) =
+    a * derive_pt f x pr.
+Proof.
+  intros.
+  assert (H := derivable_derive f x pr).
+  assert
+    (H0 := derivable_derive (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr)).
+  elim H; clear H; intros l1 H.
+  elim H0; clear H0; intros l2 H0.
+  rewrite H; apply derive_pt_eq_0.
+  assert (H3 := projT2 pr).
+  unfold derive_pt in H; rewrite H in H3.
+  apply derivable_pt_lim_scal; assumption.
 Qed.
 
 Lemma derive_pt_id : forall x:R, derive_pt id x (derivable_pt_id _) = 1.
-intros.
-apply derive_pt_eq_0.
-apply derivable_pt_lim_id.
+Proof.
+  intros.
+  apply derive_pt_eq_0.
+  apply derivable_pt_lim_id.
 Qed.
 
 Lemma derive_pt_Rsqr :
- forall x:R, derive_pt Rsqr x (derivable_pt_Rsqr _) = 2 * x.
-intros.
-apply derive_pt_eq_0.
-apply derivable_pt_lim_Rsqr.
+  forall x:R, derive_pt Rsqr x (derivable_pt_Rsqr _) = 2 * x.
+Proof.
+  intros.
+  apply derive_pt_eq_0.
+  apply derivable_pt_lim_Rsqr.
 Qed.
 
 Lemma derive_pt_comp :
- forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 (f1 x)),
-   derive_pt (f2 o f1) x (derivable_pt_comp _ _ _ pr1 pr2) =
-   derive_pt f2 (f1 x) pr2 * derive_pt f1 x pr1.
-intros.
-assert (H := derivable_derive f1 x pr1).
-assert (H0 := derivable_derive f2 (f1 x) pr2).
-assert
- (H1 := derivable_derive (f2 o f1)%F x (derivable_pt_comp _ _ _ pr1 pr2)).
-elim H; clear H; intros l1 H.
-elim H0; clear H0; intros l2 H0.
-elim H1; clear H1; intros l H1.
-rewrite H; rewrite H0; apply derive_pt_eq_0.
-assert (H3 := projT2 pr1).
-unfold derive_pt in H; rewrite H in H3.
-assert (H4 := projT2 pr2).
-unfold derive_pt in H0; rewrite H0 in H4.
-apply derivable_pt_lim_comp; assumption.
+  forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 (f1 x)),
+    derive_pt (f2 o f1) x (derivable_pt_comp _ _ _ pr1 pr2) =
+    derive_pt f2 (f1 x) pr2 * derive_pt f1 x pr1.
+Proof.
+  intros.
+  assert (H := derivable_derive f1 x pr1).
+  assert (H0 := derivable_derive f2 (f1 x) pr2).
+  assert
+    (H1 := derivable_derive (f2 o f1)%F x (derivable_pt_comp _ _ _ pr1 pr2)).
+  elim H; clear H; intros l1 H.
+  elim H0; clear H0; intros l2 H0.
+  elim H1; clear H1; intros l H1.
+  rewrite H; rewrite H0; apply derive_pt_eq_0.
+  assert (H3 := projT2 pr1).
+  unfold derive_pt in H; rewrite H in H3.
+  assert (H4 := projT2 pr2).
+  unfold derive_pt in H0; rewrite H0 in H4.
+  apply derivable_pt_lim_comp; assumption.
 Qed.
 
 (* Pow *)
 Definition pow_fct (n:nat) (y:R) : R := y ^ n.
 
 Lemma derivable_pt_lim_pow_pos :
- forall (x:R) (n:nat),
-   (0 < n)%nat -> derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n).
-intros.
-induction  n as [| n Hrecn].
-elim (lt_irrefl _ H).
-cut (n = 0%nat \/ (0 < n)%nat).
-intro; elim H0; intro.
-rewrite H1; simpl in |- *.
-replace (fun y:R => y * 1) with (id * fct_cte 1)%F.
-replace (1 * 1) with (1 * fct_cte 1 x + id x * 0).
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_const.
-unfold fct_cte, id in |- *; ring.
-reflexivity.
-replace (fun y:R => y ^ S n) with (fun y:R => y * y ^ n).
-replace (pred (S n)) with n; [ idtac | reflexivity ].
-replace (fun y:R => y * y ^ n) with (id * (fun y:R => y ^ n))%F.
-set (f := fun y:R => y ^ n).
-replace (INR (S n) * x ^ n) with (1 * f x + id x * (INR n * x ^ pred n)).
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_id.
-unfold f in |- *; apply Hrecn; assumption.
-unfold f in |- *.
-pattern n at 1 5 in |- *; replace n with (S (pred n)).
-unfold id in |- *; rewrite S_INR; simpl in |- *.
-ring.
-symmetry  in |- *; apply S_pred with 0%nat; assumption.
-unfold mult_fct, id in |- *; reflexivity.
-reflexivity.
-inversion H.
-left; reflexivity.
-right.
-apply lt_le_trans with 1%nat.
-apply lt_O_Sn.
-assumption.
+  forall (x:R) (n:nat),
+    (0 < n)%nat -> derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n).
+Proof.
+  intros.
+  induction  n as [| n Hrecn].
+  elim (lt_irrefl _ H).
+  cut (n = 0%nat \/ (0 < n)%nat).
+  intro; elim H0; intro.
+  rewrite H1; simpl in |- *.
+  replace (fun y:R => y * 1) with (id * fct_cte 1)%F.
+  replace (1 * 1) with (1 * fct_cte 1 x + id x * 0).
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_const.
+  unfold fct_cte, id in |- *; ring.
+  reflexivity.
+  replace (fun y:R => y ^ S n) with (fun y:R => y * y ^ n).
+  replace (pred (S n)) with n; [ idtac | reflexivity ].
+  replace (fun y:R => y * y ^ n) with (id * (fun y:R => y ^ n))%F.
+  set (f := fun y:R => y ^ n).
+  replace (INR (S n) * x ^ n) with (1 * f x + id x * (INR n * x ^ pred n)).
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_id.
+  unfold f in |- *; apply Hrecn; assumption.
+  unfold f in |- *.
+  pattern n at 1 5 in |- *; replace n with (S (pred n)).
+  unfold id in |- *; rewrite S_INR; simpl in |- *.
+  ring.
+  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  unfold mult_fct, id in |- *; reflexivity.
+  reflexivity.
+  inversion H.
+  left; reflexivity.
+  right.
+  apply lt_le_trans with 1%nat.
+  apply lt_O_Sn.
+  assumption.
 Qed.
 
 Lemma derivable_pt_lim_pow :
- forall (x:R) (n:nat),
-   derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n).
-intros.
-induction  n as [| n Hrecn].
-simpl in |- *.
-rewrite Rmult_0_l.
-replace (fun _:R => 1) with (fct_cte 1);
- [ apply derivable_pt_lim_const | reflexivity ].
-apply derivable_pt_lim_pow_pos.
-apply lt_O_Sn.
+  forall (x:R) (n:nat),
+    derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n).
+Proof.
+  intros.
+  induction  n as [| n Hrecn].
+  simpl in |- *.
+  rewrite Rmult_0_l.
+  replace (fun _:R => 1) with (fct_cte 1);
+  [ apply derivable_pt_lim_const | reflexivity ].
+  apply derivable_pt_lim_pow_pos.
+  apply lt_O_Sn.
 Qed.
 
 Lemma derivable_pt_pow :
- forall (n:nat) (x:R), derivable_pt (fun y:R => y ^ n) x.
-intros; unfold derivable_pt in |- *.
-apply existT with (INR n * x ^ pred n).
-apply derivable_pt_lim_pow.
+  forall (n:nat) (x:R), derivable_pt (fun y:R => y ^ n) x.
+Proof.
+  intros; unfold derivable_pt in |- *.
+  apply existT with (INR n * x ^ pred n).
+  apply derivable_pt_lim_pow.
 Qed.
 
 Lemma derivable_pow : forall n:nat, derivable (fun y:R => y ^ n).
-intro; unfold derivable in |- *; intro; apply derivable_pt_pow.
+Proof.
+  intro; unfold derivable in |- *; intro; apply derivable_pt_pow.
 Qed.
 
 Lemma derive_pt_pow :
- forall (n:nat) (x:R),
-   derive_pt (fun y:R => y ^ n) x (derivable_pt_pow n x) = INR n * x ^ pred n.
-intros; apply derive_pt_eq_0.
-apply derivable_pt_lim_pow.
+  forall (n:nat) (x:R),
+    derive_pt (fun y:R => y ^ n) x (derivable_pt_pow n x) = INR n * x ^ pred n.
+Proof.
+  intros; apply derive_pt_eq_0.
+  apply derivable_pt_lim_pow.
 Qed.
 
 Lemma pr_nu :
- forall f (x:R) (pr1 pr2:derivable_pt f x),
-   derive_pt f x pr1 = derive_pt f x pr2. 
-intros.
-unfold derivable_pt in pr1.
-unfold derivable_pt in pr2.
-elim pr1; intros.
-elim pr2; intros.
-unfold derivable_pt_abs in p.
-unfold derivable_pt_abs in p0.
-simpl in |- *.
-apply (uniqueness_limite f x x0 x1 p p0).
+  forall f (x:R) (pr1 pr2:derivable_pt f x),
+    derive_pt f x pr1 = derive_pt f x pr2. 
+Proof.
+  intros.
+  unfold derivable_pt in pr1.
+  unfold derivable_pt in pr2.
+  elim pr1; intros.
+  elim pr2; intros.
+  unfold derivable_pt_abs in p.
+  unfold derivable_pt_abs in p0.
+  simpl in |- *.
+  apply (uniqueness_limite f x x0 x1 p p0).
 Qed.
 
 
 (************************************************************)
-(**             Local extremum's condition                  *)
+(** *           Local extremum's condition                  *)
 (************************************************************)
 
 Theorem deriv_maximum :
- forall f (a b c:R) (pr:derivable_pt f c),
-   a < c ->
-   c < b ->
-   (forall x:R, a < x -> x < b -> f x <= f c) -> derive_pt f c pr = 0.
-intros; case (Rtotal_order 0 (derive_pt f c pr)); intro.
-assert (H3 := derivable_derive f c pr).
-elim H3; intros l H4; rewrite H4 in H2.
-assert (H5 := derive_pt_eq_1 f c l pr H4).
-cut (0 < l / 2);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
-elim (H5 (l / 2) H6); intros delta H7.
-cut (0 < (b - c) / 2).
-intro; cut (Rmin (delta / 2) ((b - c) / 2) <> 0).
-intro; cut (Rabs (Rmin (delta / 2) ((b - c) / 2)) < delta).
-intro.
-assert (H11 := H7 (Rmin (delta / 2) ((b - c) / 2)) H9 H10).
-cut (0 < Rmin (delta / 2) ((b - c) / 2)).
-intro; cut (a < c + Rmin (delta / 2) ((b - c) / 2)).
-intro; cut (c + Rmin (delta / 2) ((b - c) / 2) < b).
-intro; assert (H15 := H1 (c + Rmin (delta / 2) ((b - c) / 2)) H13 H14).
-cut
- ((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) /
-  Rmin (delta / 2) ((b - c) / 2) <= 0).
-intro; cut (- l < 0).
-intro; unfold Rminus in H11.
-cut
- ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-  Rmin (delta / 2) ((b + - c) / 2) + - l < 0).
-intro;
- cut
-  (Rabs
-     ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-      Rmin (delta / 2) ((b + - c) / 2) + - l) < l / 2).
-unfold Rabs in |- *;
- case
-  (Rcase_abs
-     ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-      Rmin (delta / 2) ((b + - c) / 2) + - l)); intro.
-replace
- (-
-  ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-   Rmin (delta / 2) ((b + - c) / 2) + - l)) with
- (l +
-  -
-  ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-   Rmin (delta / 2) ((b + - c) / 2))).
-intro;
- generalize
-  (Rplus_lt_compat_l (- l)
-     (l +
-      -
+  forall f (a b c:R) (pr:derivable_pt f c),
+    a < c ->
+    c < b ->
+    (forall x:R, a < x -> x < b -> f x <= f c) -> derive_pt f c pr = 0.
+Proof.
+  intros; case (Rtotal_order 0 (derive_pt f c pr)); intro.
+  assert (H3 := derivable_derive f c pr).
+  elim H3; intros l H4; rewrite H4 in H2.
+  assert (H5 := derive_pt_eq_1 f c l pr H4).
+  cut (0 < l / 2);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (H5 (l / 2) H6); intros delta H7.
+  cut (0 < (b - c) / 2).
+  intro; cut (Rmin (delta / 2) ((b - c) / 2) <> 0).
+  intro; cut (Rabs (Rmin (delta / 2) ((b - c) / 2)) < delta).
+  intro.
+  assert (H11 := H7 (Rmin (delta / 2) ((b - c) / 2)) H9 H10).
+  cut (0 < Rmin (delta / 2) ((b - c) / 2)).
+  intro; cut (a < c + Rmin (delta / 2) ((b - c) / 2)).
+  intro; cut (c + Rmin (delta / 2) ((b - c) / 2) < b).
+  intro; assert (H15 := H1 (c + Rmin (delta / 2) ((b - c) / 2)) H13 H14).
+  cut
+    ((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) /
+      Rmin (delta / 2) ((b - c) / 2) <= 0).
+  intro; cut (- l < 0).
+  intro; unfold Rminus in H11.
+  cut
+    ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+      Rmin (delta / 2) ((b + - c) / 2) + - l < 0).
+  intro;
+    cut
+      (Rabs
+        ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+          Rmin (delta / 2) ((b + - c) / 2) + - l) < l / 2).
+  unfold Rabs in |- *;
+    case
+    (Rcase_abs
       ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-       Rmin (delta / 2) ((b + - c) / 2))) (l / 2) H19);
- repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; 
- rewrite Rplus_0_l; replace (- l + l / 2) with (- (l / 2)).
-intro;
- generalize
-  (Ropp_lt_gt_contravar
-     (-
+        Rmin (delta / 2) ((b + - c) / 2) + - l)); intro.
+  replace
+  (-
+    ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+      Rmin (delta / 2) ((b + - c) / 2) + - l)) with
+  (l +
+    -
+    ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+      Rmin (delta / 2) ((b + - c) / 2))).
+  intro;
+    generalize
+      (Rplus_lt_compat_l (- l)
+        (l +
+          -
+          ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+            Rmin (delta / 2) ((b + - c) / 2))) (l / 2) H19);
+      repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; 
+        rewrite Rplus_0_l; replace (- l + l / 2) with (- (l / 2)).
+  intro;
+    generalize
+      (Ropp_lt_gt_contravar
+        (-
+          ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+            Rmin (delta / 2) ((b + - c) / 2))) (- (l / 2)) H20);
+      repeat rewrite Ropp_involutive; intro;
+        generalize
+          (Rlt_trans 0 (l / 2)
+            ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+              Rmin (delta / 2) ((b + - c) / 2)) H6 H21); intro;
+          elim
+            (Rlt_irrefl 0
+              (Rlt_le_trans 0
+                ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
+                  Rmin (delta / 2) ((b + - c) / 2)) 0 H22 H16)).
+  pattern l at 2 in |- *; rewrite double_var.
+  ring.
+  ring.
+  intro.
+  assert
+    (H20 :=
+      Rge_le
       ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-       Rmin (delta / 2) ((b + - c) / 2))) (- (l / 2)) H20);
- repeat rewrite Ropp_involutive; intro;
- generalize
-  (Rlt_trans 0 (l / 2)
-     ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-      Rmin (delta / 2) ((b + - c) / 2)) H6 H21); intro;
- elim
-  (Rlt_irrefl 0
-     (Rlt_le_trans 0
-        ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-         Rmin (delta / 2) ((b + - c) / 2)) 0 H22 H16)).
-pattern l at 2 in |- *; rewrite double_var.
-ring.
-ring.
-intro.
-assert
- (H20 :=
-  Rge_le
+        Rmin (delta / 2) ((b + - c) / 2) + - l) 0 r).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). 
+  assumption.
+  rewrite <- Ropp_0;
+    replace
     ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-     Rmin (delta / 2) ((b + - c) / 2) + - l) 0 r).
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). 
-assumption.
-rewrite <- Ropp_0;
- replace
-  ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-   Rmin (delta / 2) ((b + - c) / 2) + - l) with
+      Rmin (delta / 2) ((b + - c) / 2) + - l) with
+    (-
+      (l +
+        -
+        ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
+          Rmin (delta / 2) ((b + - c) / 2)))).
+  apply Ropp_gt_lt_contravar;
+    change
+      (0 <
+        l +
+        -
+        ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
+          Rmin (delta / 2) ((b + - c) / 2))) in |- *; apply Rplus_lt_le_0_compat;
+      [ assumption
+        | rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption ].
+  unfold Rminus; ring.
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
+  replace
+  ((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) /
+    Rmin (delta / 2) ((b - c) / 2)) with
   (-
-   (l +
-    -
-    ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
-     Rmin (delta / 2) ((b + - c) / 2)))).
-apply Ropp_gt_lt_contravar;
- change
-   (0 <
-    l +
-    -
-    ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
-     Rmin (delta / 2) ((b + - c) / 2))) in |- *; apply Rplus_lt_le_0_compat;
- [ assumption
- | rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption ].
-ring.
-rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
-replace
- ((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) /
-  Rmin (delta / 2) ((b - c) / 2)) with
- (-
-  ((f c - f (c + Rmin (delta / 2) ((b - c) / 2))) /
-   Rmin (delta / 2) ((b - c) / 2))).
-rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge;
- unfold Rdiv in |- *; apply Rmult_le_pos;
- [ generalize
-    (Rplus_le_compat_r (- f (c + Rmin (delta * / 2) ((b - c) * / 2)))
-       (f (c + Rmin (delta * / 2) ((b - c) * / 2))) (
-       f c) H15); rewrite Rplus_opp_r; intro; assumption
- | left; apply Rinv_0_lt_compat; assumption ].
-unfold Rdiv in |- *.
-rewrite <- Ropp_mult_distr_l_reverse.
-repeat rewrite <- (Rmult_comm (/ Rmin (delta * / 2) ((b - c) * / 2))).
-apply Rmult_eq_reg_l with (Rmin (delta * / 2) ((b - c) * / 2)).
-repeat rewrite <- Rmult_assoc.
-rewrite <- Rinv_r_sym.
-repeat rewrite Rmult_1_l.
-ring.
-red in |- *; intro.
-unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
-red in |- *; intro.
-unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
-assert (H14 := Rmin_r (delta / 2) ((b - c) / 2)).
-assert
- (H15 :=
-  Rplus_le_compat_l c (Rmin (delta / 2) ((b - c) / 2)) ((b - c) / 2) H14).
-apply Rle_lt_trans with (c + (b - c) / 2).
-assumption.
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-replace (2 * (c + (b - c) / 2)) with (c + b).
-replace (2 * b) with (b + b).
-apply Rplus_lt_compat_r; assumption.
-ring.
-unfold Rdiv in |- *; rewrite Rmult_plus_distr_l.
-repeat rewrite (Rmult_comm 2).
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-ring.
-discrR.
-apply Rlt_trans with c.
-assumption.
-pattern c at 1 in |- *; rewrite <- (Rplus_0_r c); apply Rplus_lt_compat_l;
- assumption.
-cut (0 < delta / 2).
-intro;
- apply
-  (Rmin_stable_in_posreal (mkposreal (delta / 2) H12)
-     (mkposreal ((b - c) / 2) H8)).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-unfold Rabs in |- *; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))).
-intro.
-cut (0 < delta / 2).
-intro.
-generalize
- (Rmin_stable_in_posreal (mkposreal (delta / 2) H10)
-    (mkposreal ((b - c) / 2) H8)); simpl in |- *; intro;
- elim (Rlt_irrefl 0 (Rlt_trans 0 (Rmin (delta / 2) ((b - c) / 2)) 0 H11 r)).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-intro; apply Rle_lt_trans with (delta / 2).
-apply Rmin_l.
-unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
-prove_sup0.
-rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l.
-replace (2 * delta) with (delta + delta). 
-pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
- apply Rplus_lt_compat_l.
-rewrite Rplus_0_r; apply (cond_pos delta).
-symmetry  in |- *; apply double.
-discrR.
-cut (0 < delta / 2).
-intro;
- generalize
-  (Rmin_stable_in_posreal (mkposreal (delta / 2) H9)
-     (mkposreal ((b - c) / 2) H8)); simpl in |- *; 
- intro; red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-generalize (Rplus_lt_compat_r (- c) c b H0); rewrite Rplus_opp_r; intro;
- assumption.
-apply Rinv_0_lt_compat; prove_sup0.
-elim H2; intro.
-symmetry  in |- *; assumption.
-generalize (derivable_derive f c pr); intro; elim H4; intros l H5.
-rewrite H5 in H3; generalize (derive_pt_eq_1 f c l pr H5); intro;
- cut (0 < - (l / 2)).
-intro; elim (H6 (- (l / 2)) H7); intros delta H9.
-cut (0 < (c - a) / 2).
-intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) < 0).
-intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) <> 0).
-intro; cut (Rabs (Rmax (- (delta / 2)) ((a - c) / 2)) < delta).
-intro; generalize (H9 (Rmax (- (delta / 2)) ((a - c) / 2)) H11 H12); intro;
- cut (a < c + Rmax (- (delta / 2)) ((a - c) / 2)).
-cut (c + Rmax (- (delta / 2)) ((a - c) / 2) < b).
-intros; generalize (H1 (c + Rmax (- (delta / 2)) ((a - c) / 2)) H15 H14);
- intro;
- cut
-  (0 <=
-   (f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) /
-   Rmax (- (delta / 2)) ((a - c) / 2)).
-intro; cut (0 < - l).
-intro; unfold Rminus in H13;
- cut
-  (0 <
-   (f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-   Rmax (- (delta / 2)) ((a + - c) / 2) + - l).
-intro;
- cut
-  (Rabs
-     ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-      Rmax (- (delta / 2)) ((a + - c) / 2) + - l) < 
-   - (l / 2)).
-unfold Rabs in |- *;
- case
-  (Rcase_abs
-     ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-      Rmax (- (delta / 2)) ((a + - c) / 2) + - l)).
-intro;
- elim
-  (Rlt_irrefl 0
-     (Rlt_trans 0
+    ((f c - f (c + Rmin (delta / 2) ((b - c) / 2))) /
+      Rmin (delta / 2) ((b - c) / 2))).
+  rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge;
+    unfold Rdiv in |- *; apply Rmult_le_pos;
+      [ generalize
+        (Rplus_le_compat_r (- f (c + Rmin (delta * / 2) ((b - c) * / 2)))
+          (f (c + Rmin (delta * / 2) ((b - c) * / 2))) (
+            f c) H15); rewrite Rplus_opp_r; intro; assumption
+        | left; apply Rinv_0_lt_compat; assumption ].
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  repeat rewrite <- (Rmult_comm (/ Rmin (delta * / 2) ((b - c) * / 2))).
+  apply Rmult_eq_reg_l with (Rmin (delta * / 2) ((b - c) * / 2)).
+  repeat rewrite <- Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  repeat rewrite Rmult_1_l.
+  ring.
+  red in |- *; intro.
+  unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
+  red in |- *; intro.
+  unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
+  assert (H14 := Rmin_r (delta / 2) ((b - c) / 2)).
+  assert
+    (H15 :=
+      Rplus_le_compat_l c (Rmin (delta / 2) ((b - c) / 2)) ((b - c) / 2) H14).
+  apply Rle_lt_trans with (c + (b - c) / 2).
+  assumption.
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  replace (2 * (c + (b - c) / 2)) with (c + b).
+  replace (2 * b) with (b + b).
+  apply Rplus_lt_compat_r; assumption.
+  ring.
+  unfold Rdiv in |- *; rewrite Rmult_plus_distr_l.
+  repeat rewrite (Rmult_comm 2).
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  ring.
+  discrR.
+  apply Rlt_trans with c.
+  assumption.
+  pattern c at 1 in |- *; rewrite <- (Rplus_0_r c); apply Rplus_lt_compat_l;
+    assumption.
+  cut (0 < delta / 2).
+  intro;
+    apply
+      (Rmin_stable_in_posreal (mkposreal (delta / 2) H12)
+        (mkposreal ((b - c) / 2) H8)).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+  unfold Rabs in |- *; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))).
+  intro.
+  cut (0 < delta / 2).
+  intro.
+  generalize
+    (Rmin_stable_in_posreal (mkposreal (delta / 2) H10)
+      (mkposreal ((b - c) / 2) H8)); simpl in |- *; intro;
+    elim (Rlt_irrefl 0 (Rlt_trans 0 (Rmin (delta / 2) ((b - c) / 2)) 0 H11 r)).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+  intro; apply Rle_lt_trans with (delta / 2).
+  apply Rmin_l.
+  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l.
+  replace (2 * delta) with (delta + delta). 
+  pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
+    apply Rplus_lt_compat_l.
+  rewrite Rplus_0_r; apply (cond_pos delta).
+  symmetry  in |- *; apply double.
+  discrR.
+  cut (0 < delta / 2).
+  intro;
+    generalize
+      (Rmin_stable_in_posreal (mkposreal (delta / 2) H9)
+        (mkposreal ((b - c) / 2) H8)); simpl in |- *; 
+      intro; red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  generalize (Rplus_lt_compat_r (- c) c b H0); rewrite Rplus_opp_r; intro;
+    assumption.
+  apply Rinv_0_lt_compat; prove_sup0.
+  elim H2; intro.
+  symmetry  in |- *; assumption.
+  generalize (derivable_derive f c pr); intro; elim H4; intros l H5.
+  rewrite H5 in H3; generalize (derive_pt_eq_1 f c l pr H5); intro;
+    cut (0 < - (l / 2)).
+  intro; elim (H6 (- (l / 2)) H7); intros delta H9.
+  cut (0 < (c - a) / 2).
+  intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) < 0).
+  intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) <> 0).
+  intro; cut (Rabs (Rmax (- (delta / 2)) ((a - c) / 2)) < delta).
+  intro; generalize (H9 (Rmax (- (delta / 2)) ((a - c) / 2)) H11 H12); intro;
+    cut (a < c + Rmax (- (delta / 2)) ((a - c) / 2)).
+  cut (c + Rmax (- (delta / 2)) ((a - c) / 2) < b).
+  intros; generalize (H1 (c + Rmax (- (delta / 2)) ((a - c) / 2)) H15 H14);
+    intro;
+      cut
+        (0 <=
+          (f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) /
+          Rmax (- (delta / 2)) ((a - c) / 2)).
+  intro; cut (0 < - l).
+  intro; unfold Rminus in H13;
+    cut
+      (0 <
+        (f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+        Rmax (- (delta / 2)) ((a + - c) / 2) + - l).
+  intro;
+    cut
+      (Rabs
+        ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+          Rmax (- (delta / 2)) ((a + - c) / 2) + - l) < 
+        - (l / 2)).
+  unfold Rabs in |- *;
+    case
+    (Rcase_abs
+      ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+        Rmax (- (delta / 2)) ((a + - c) / 2) + - l)).
+  intro;
+    elim
+      (Rlt_irrefl 0
+        (Rlt_trans 0
+          ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+            Rmax (- (delta / 2)) ((a + - c) / 2) + - l) 0 H19 r)).
+  intros;
+    generalize
+      (Rplus_lt_compat_r l
         ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-         Rmax (- (delta / 2)) ((a + - c) / 2) + - l) 0 H19 r)).
-intros;
- generalize
-  (Rplus_lt_compat_r l
-     ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-      Rmax (- (delta / 2)) ((a + - c) / 2) + - l) (
-     - (l / 2)) H20); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l;
- rewrite Rplus_0_r; replace (- (l / 2) + l) with (l / 2).
-cut (l / 2 < 0).
-intros;
- generalize
-  (Rlt_trans
-     ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-      Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); 
- intro;
- elim
-  (Rlt_irrefl 0
-     (Rle_lt_trans 0
-        ((f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) /
-         Rmax (- (delta / 2)) ((a - c) / 2)) 0 H17 H23)).
-rewrite <- (Ropp_involutive (l / 2)); rewrite <- Ropp_0;
- apply Ropp_lt_gt_contravar; assumption.
-pattern l at 3 in |- *; rewrite double_var.
-ring.
-assumption.
-apply Rplus_le_lt_0_compat; assumption.
-rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
-unfold Rdiv in |- *;
- replace
-  ((f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
-   / Rmax (- (delta * / 2)) ((a - c) * / 2)) with
-  (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
-   / - Rmax (- (delta * / 2)) ((a - c) * / 2)).
-apply Rmult_le_pos.
-generalize
- (Rplus_le_compat_l (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)))
-    (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2))) (
-    f c) H16); rewrite Rplus_opp_l;
- replace (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c)) with
-  (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) + f c).
-intro; assumption.
-ring.
-left; apply Rinv_0_lt_compat; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar;
- assumption.
-unfold Rdiv in |- *.
-rewrite <- Ropp_inv_permute.
-rewrite Rmult_opp_opp.
-reflexivity.
-unfold Rdiv in H11; assumption.
-generalize (Rplus_lt_compat_l c (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H10);
- rewrite Rplus_0_r; intro; apply Rlt_trans with c; 
- assumption.
-generalize (RmaxLess2 (- (delta / 2)) ((a - c) / 2)); intro;
- generalize
-  (Rplus_le_compat_l c ((a - c) / 2) (Rmax (- (delta / 2)) ((a - c) / 2)) H14);
- intro; apply Rlt_le_trans with (c + (a - c) / 2).
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-replace (2 * (c + (a - c) / 2)) with (a + c).
-rewrite double.
-apply Rplus_lt_compat_l; assumption.
-ring.
-rewrite <- Rplus_assoc.
-rewrite <- double_var.
-ring.
-assumption.
-unfold Rabs in |- *; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))).
-intro; generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro;
- generalize
-  (Ropp_le_ge_contravar (- (delta / 2)) (Rmax (- (delta / 2)) ((a - c) / 2))
-     H12); rewrite Ropp_involutive; intro;
- generalize (Rge_le (delta / 2) (- Rmax (- (delta / 2)) ((a - c) / 2)) H13);
- intro; apply Rle_lt_trans with (delta / 2).
-assumption.
-apply Rmult_lt_reg_l with 2. 
-prove_sup0.
-unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; rewrite double.
-pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
- apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta).
-discrR. 
-cut (- (delta / 2) < 0).
-cut ((a - c) / 2 < 0).
-intros;
- generalize
-  (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13)
-     (mknegreal ((a - c) / 2) H12)); simpl in |- *; 
- intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r); 
- intro;
- elim
-  (Rlt_irrefl 0
-     (Rle_lt_trans 0 (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H15 H14)).
-rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
- apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
-assumption.
-unfold Rdiv in |- *.
-rewrite <- Ropp_mult_distr_l_reverse. 
-rewrite (Ropp_minus_distr a c).
-reflexivity.
-rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
- apply Rmult_lt_0_compat;
- [ apply (cond_pos delta)
- | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
-red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
-cut ((a - c) / 2 < 0).
-intro; cut (- (delta / 2) < 0).
-intro;
- apply
-  (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H11)
-     (mknegreal ((a - c) / 2) H10)).
-rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
- apply Rmult_lt_0_compat;
- [ apply (cond_pos delta)
- | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
-rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
- apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
-assumption.
-unfold Rdiv in |- *.
-rewrite <- Ropp_mult_distr_l_reverse. 
-rewrite (Ropp_minus_distr a c).
-reflexivity.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ generalize (Rplus_lt_compat_r (- a) a c H); rewrite Rplus_opp_r; intro;
-    assumption
- | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
-replace (- (l / 2)) with (- l / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
-assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ].
-unfold Rdiv in |- *; apply Ropp_mult_distr_l_reverse.
+          Rmax (- (delta / 2)) ((a + - c) / 2) + - l) (
+            - (l / 2)) H20); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l;
+      rewrite Rplus_0_r; replace (- (l / 2) + l) with (l / 2).
+  cut (l / 2 < 0).
+  intros;
+    generalize
+      (Rlt_trans
+        ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
+          Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); 
+      intro;
+        elim
+          (Rlt_irrefl 0
+            (Rle_lt_trans 0
+              ((f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) /
+                Rmax (- (delta / 2)) ((a - c) / 2)) 0 H17 H23)).
+  rewrite <- (Ropp_involutive (l / 2)); rewrite <- Ropp_0;
+    apply Ropp_lt_gt_contravar; assumption.
+  pattern l at 3 in |- *; rewrite double_var.
+  ring.
+  assumption.
+  apply Rplus_le_lt_0_compat; assumption.
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
+  unfold Rdiv in |- *;
+    replace
+    ((f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
+      / Rmax (- (delta * / 2)) ((a - c) * / 2)) with
+    (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
+      / - Rmax (- (delta * / 2)) ((a - c) * / 2)).
+  apply Rmult_le_pos.
+  generalize
+    (Rplus_le_compat_l (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)))
+      (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2))) (
+        f c) H16); rewrite Rplus_opp_l;
+    replace (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c)) with
+    (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) + f c).
+  intro; assumption.
+  ring.
+  left; apply Rinv_0_lt_compat; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar;
+    assumption.
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_inv_permute.
+  rewrite Rmult_opp_opp.
+  reflexivity.
+  unfold Rdiv in H11; assumption.
+  generalize (Rplus_lt_compat_l c (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H10);
+    rewrite Rplus_0_r; intro; apply Rlt_trans with c; 
+      assumption.
+  generalize (RmaxLess2 (- (delta / 2)) ((a - c) / 2)); intro;
+    generalize
+      (Rplus_le_compat_l c ((a - c) / 2) (Rmax (- (delta / 2)) ((a - c) / 2)) H14);
+      intro; apply Rlt_le_trans with (c + (a - c) / 2).
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  replace (2 * (c + (a - c) / 2)) with (a + c).
+  rewrite double.
+  apply Rplus_lt_compat_l; assumption.
+  field; discrR.
+  assumption.
+  unfold Rabs in |- *; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))).
+  intro; generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro;
+    generalize
+      (Ropp_le_ge_contravar (- (delta / 2)) (Rmax (- (delta / 2)) ((a - c) / 2))
+        H12); rewrite Ropp_involutive; intro;
+      generalize (Rge_le (delta / 2) (- Rmax (- (delta / 2)) ((a - c) / 2)) H13);
+        intro; apply Rle_lt_trans with (delta / 2).
+  assumption.
+  apply Rmult_lt_reg_l with 2. 
+  prove_sup0.
+  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite double.
+  pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
+    apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta).
+  discrR. 
+  cut (- (delta / 2) < 0).
+  cut ((a - c) / 2 < 0).
+  intros;
+    generalize
+      (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13)
+        (mknegreal ((a - c) / 2) H12)); simpl in |- *; 
+      intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r); 
+        intro;
+          elim
+            (Rlt_irrefl 0
+              (Rle_lt_trans 0 (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H15 H14)).
+  rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
+    apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
+  assumption.
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse. 
+  rewrite (Ropp_minus_distr a c).
+  reflexivity.
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
+    apply Rmult_lt_0_compat;
+      [ apply (cond_pos delta)
+        | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
+  red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
+  cut ((a - c) / 2 < 0).
+  intro; cut (- (delta / 2) < 0).
+  intro;
+    apply
+      (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H11)
+        (mknegreal ((a - c) / 2) H10)).
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
+    apply Rmult_lt_0_compat;
+      [ apply (cond_pos delta)
+        | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
+  rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
+    apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
+  assumption.
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse. 
+  rewrite (Ropp_minus_distr a c).
+  reflexivity.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ generalize (Rplus_lt_compat_r (- a) a c H); rewrite Rplus_opp_r; intro;
+      assumption
+      | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
+  replace (- (l / 2)) with (- l / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
+  assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ].
+  unfold Rdiv in |- *; apply Ropp_mult_distr_l_reverse.
 Qed.
 
 Theorem deriv_minimum :
- forall f (a b c:R) (pr:derivable_pt f c),
-   a < c ->
-   c < b ->
-   (forall x:R, a < x -> x < b -> f c <= f x) -> derive_pt f c pr = 0.
-intros.
-rewrite <- (Ropp_involutive (derive_pt f c pr)).
-apply Ropp_eq_0_compat.
-rewrite <- (derive_pt_opp f c pr).
-cut (forall x:R, a < x -> x < b -> (- f)%F x <= (- f)%F c).
-intro.
-apply (deriv_maximum (- f)%F a b c (derivable_pt_opp _ _ pr) H H0 H2).
-intros; unfold opp_fct in |- *; apply Ropp_ge_le_contravar; apply Rle_ge.
-apply (H1 x H2 H3).
-Qed.
- 
+  forall f (a b c:R) (pr:derivable_pt f c),
+    a < c ->
+    c < b ->
+    (forall x:R, a < x -> x < b -> f c <= f x) -> derive_pt f c pr = 0.
+Proof.
+  intros.
+  rewrite <- (Ropp_involutive (derive_pt f c pr)).
+  apply Ropp_eq_0_compat.
+  rewrite <- (derive_pt_opp f c pr).
+  cut (forall x:R, a < x -> x < b -> (- f)%F x <= (- f)%F c).
+  intro.
+  apply (deriv_maximum (- f)%F a b c (derivable_pt_opp _ _ pr) H H0 H2).
+  intros; unfold opp_fct in |- *; apply Ropp_ge_le_contravar; apply Rle_ge.
+  apply (H1 x H2 H3).
+Qed.
+
 Theorem deriv_constant2 :
- forall f (a b c:R) (pr:derivable_pt f c),
-   a < c ->
-   c < b -> (forall x:R, a < x -> x < b -> f x = f c) -> derive_pt f c pr = 0.
-intros.
-eapply deriv_maximum with a b; try assumption.
-intros; right; apply (H1 x H2 H3).
+  forall f (a b c:R) (pr:derivable_pt f c),
+    a < c ->
+    c < b -> (forall x:R, a < x -> x < b -> f x = f c) -> derive_pt f c pr = 0.
+Proof.
+  intros.
+  eapply deriv_maximum with a b; try assumption.
+  intros; right; apply (H1 x H2 H3).
 Qed.
 
 (**********)
 Lemma nonneg_derivative_0 :
- forall f (pr:derivable f),
-   increasing f -> forall x:R, 0 <= derive_pt f x (pr x).
-intros; unfold increasing in H.
-assert (H0 := derivable_derive f x (pr x)).
-elim H0; intros l H1.
-rewrite H1; case (Rtotal_order 0 l); intro.
-left; assumption.
-elim H2; intro.
-right; assumption.
-assert (H4 := derive_pt_eq_1 f x l (pr x) H1).
-cut (0 < - (l / 2)).
-intro; elim (H4 (- (l / 2)) H5); intros delta H6.
-cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta).
-intro; decompose [and] H7; intros; generalize (H6 (delta / 2) H8 H11);
- cut (0 <= (f (x + delta / 2) - f x) / (delta / 2)).
-intro; cut (0 <= (f (x + delta / 2) - f x) / (delta / 2) - l).
-intro; unfold Rabs in |- *;
- case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
-intro;
- elim
-  (Rlt_irrefl 0
-     (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 H12 r)).
-intros;
- generalize
-  (Rplus_lt_compat_r l ((f (x + delta / 2) - f x) / (delta / 2) - l)
-     (- (l / 2)) H13); unfold Rminus in |- *;
- replace (- (l / 2) + l) with (l / 2).
-rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; intro;
- generalize
-  (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) (l / 2) H9 H14);
- intro; cut (l / 2 < 0).
-intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (l / 2) 0 H15 H16)).
-rewrite <- Ropp_0 in H5;
- generalize (Ropp_lt_gt_contravar (-0) (- (l / 2)) H5);
- repeat rewrite Ropp_involutive; intro; assumption.
-pattern l at 3 in |- *; rewrite double_var.
-ring.
-unfold Rminus in |- *; apply Rplus_le_le_0_compat.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-cut (x <= x + delta * / 2).
-intro; generalize (H x (x + delta * / 2) H12); intro;
- generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H13);
- rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
-pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
- left; assumption.
-left; apply Rinv_0_lt_compat; assumption.
-left; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-cut (x <= x + delta * / 2).
-intro; generalize (H x (x + delta * / 2) H9); intro;
- generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12);
- rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
-pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
- left; assumption. 
-left; apply Rinv_0_lt_compat; assumption.
-split.
-unfold Rdiv in |- *; apply prod_neq_R0.
-generalize (cond_pos delta); intro; red in |- *; intro H9; rewrite H9 in H7;
- elim (Rlt_irrefl 0 H7).
-apply Rinv_neq_0_compat; discrR.
-split.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-replace (Rabs (delta / 2)) with (delta / 2).
-unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
-prove_sup0.
-rewrite (Rmult_comm 2).
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
-rewrite Rmult_1_r.
-rewrite double.
-pattern (pos delta) at 1 in |- *; rewrite <- Rplus_0_r.
-apply Rplus_lt_compat_l; apply (cond_pos delta).
-symmetry  in |- *; apply Rabs_right.
-left; change (0 < delta / 2) in |- *; unfold Rdiv in |- *;
- apply Rmult_lt_0_compat;
- [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse;
- apply Rmult_lt_0_compat.
-apply Rplus_lt_reg_r with l.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption.
-apply Rinv_0_lt_compat; prove_sup0.
+  forall f (pr:derivable f),
+    increasing f -> forall x:R, 0 <= derive_pt f x (pr x).
+Proof.
+  intros; unfold increasing in H.
+  assert (H0 := derivable_derive f x (pr x)).
+  elim H0; intros l H1.
+  rewrite H1; case (Rtotal_order 0 l); intro.
+  left; assumption.
+  elim H2; intro.
+  right; assumption.
+  assert (H4 := derive_pt_eq_1 f x l (pr x) H1).
+  cut (0 < - (l / 2)).
+  intro; elim (H4 (- (l / 2)) H5); intros delta H6.
+  cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta).
+  intro; decompose [and] H7; intros; generalize (H6 (delta / 2) H8 H11);
+    cut (0 <= (f (x + delta / 2) - f x) / (delta / 2)).
+  intro; cut (0 <= (f (x + delta / 2) - f x) / (delta / 2) - l).
+  intro; unfold Rabs in |- *;
+    case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
+  intro;
+    elim
+      (Rlt_irrefl 0
+        (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 H12 r)).
+  intros;
+    generalize
+      (Rplus_lt_compat_r l ((f (x + delta / 2) - f x) / (delta / 2) - l)
+        (- (l / 2)) H13); unfold Rminus in |- *;
+      replace (- (l / 2) + l) with (l / 2).
+  rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; intro;
+    generalize
+      (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) (l / 2) H9 H14);
+      intro; cut (l / 2 < 0).
+  intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (l / 2) 0 H15 H16)).
+  rewrite <- Ropp_0 in H5;
+    generalize (Ropp_lt_gt_contravar (-0) (- (l / 2)) H5);
+      repeat rewrite Ropp_involutive; intro; assumption.
+  pattern l at 3 in |- *; rewrite double_var.
+  ring.
+  unfold Rminus in |- *; apply Rplus_le_le_0_compat.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  cut (x <= x + delta * / 2).
+  intro; generalize (H x (x + delta * / 2) H12); intro;
+    generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H13);
+      rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
+  pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+    left; assumption.
+  left; apply Rinv_0_lt_compat; assumption.
+  left; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  cut (x <= x + delta * / 2).
+  intro; generalize (H x (x + delta * / 2) H9); intro;
+    generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12);
+      rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
+  pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+    left; assumption. 
+  left; apply Rinv_0_lt_compat; assumption.
+  split.
+  unfold Rdiv in |- *; apply prod_neq_R0.
+  generalize (cond_pos delta); intro; red in |- *; intro H9; rewrite H9 in H7;
+    elim (Rlt_irrefl 0 H7).
+  apply Rinv_neq_0_compat; discrR.
+  split.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+  replace (Rabs (delta / 2)) with (delta / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  rewrite (Rmult_comm 2).
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+  rewrite Rmult_1_r.
+  rewrite double.
+  pattern (pos delta) at 1 in |- *; rewrite <- Rplus_0_r.
+  apply Rplus_lt_compat_l; apply (cond_pos delta).
+  symmetry  in |- *; apply Rabs_right.
+  left; change (0 < delta / 2) in |- *; unfold Rdiv in |- *;
+    apply Rmult_lt_0_compat;
+      [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
+  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+    apply Rmult_lt_0_compat.
+  apply Rplus_lt_reg_r with l.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption.
+  apply Rinv_0_lt_compat; prove_sup0.
 Qed.
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
index 35f7eab8..fb89da67 100644
--- a/theories/Reals/Ranalysis2.v
+++ b/theories/Reals/Ranalysis2.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis2.v,v 1.11.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Ranalysis2.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -14,437 +14,450 @@ Require Import Ranalysis1. Open Local Scope R_scope.
 
 (**********)
 Lemma formule :
- forall (x h l1 l2:R) (f1 f2:R -> R),
-   h <> 0 ->
-   f2 x <> 0 ->
-   f2 (x + h) <> 0 ->
-   (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h -
-   (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) =
-   / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) +
-   l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) -
-   f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
-   l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
-intros; unfold Rdiv, Rminus, Rsqr in |- *.
-repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
- repeat rewrite Rinv_mult_distr; try assumption.
-replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x));
- [ idtac | ring ].
-replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with
- (l1 * / f2 (x + h) * (f2 x * / f2 x)); [ idtac | ring ].
-replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
- (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ].
-replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
- (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); 
- [ idtac | ring ].
-replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
- (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); 
- [ idtac | ring ].
-replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
- (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h)));
- [ idtac | ring ].
-replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
- (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); 
- [ idtac | ring ].
-repeat rewrite <- Rinv_r_sym; try assumption || ring.
-apply prod_neq_R0; assumption.
+  forall (x h l1 l2:R) (f1 f2:R -> R),
+    h <> 0 ->
+    f2 x <> 0 ->
+    f2 (x + h) <> 0 ->
+    (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h -
+    (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) =
+    / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) +
+    l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) -
+    f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
+    l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
+Proof.
+  intros; unfold Rdiv, Rminus, Rsqr in |- *.
+  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
+    repeat rewrite Rinv_mult_distr; try assumption.
+  replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x));
+  [ idtac | ring ].
+  replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with
+  (l1 * / f2 (x + h) * (f2 x * / f2 x)); [ idtac | ring ].
+  replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
+  (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ].
+  replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
+  (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); 
+  [ idtac | ring ].
+  replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
+  (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); 
+  [ idtac | ring ].
+  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
+  (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h)));
+  [ idtac | ring ].
+  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
+  (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); 
+  [ idtac | ring ].
+  repeat rewrite <- Rinv_r_sym; try assumption || ring.
+  apply prod_neq_R0; assumption.
 Qed.
 
 Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
-intros; unfold Rmin in |- *.
-case (Rle_dec x y); intro; assumption.
+Proof.
+  intros; unfold Rmin in |- *.
+  case (Rle_dec x y); intro; assumption.
 Qed.
 
 Lemma maj_term1 :
- forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) 
-   (f1 f2:R -> R),
-   0 < eps ->
-   f2 x <> 0 ->
-   f2 (x + h) <> 0 ->
-   (forall h:R,
+  forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) 
+    (f1 f2:R -> R),
+    0 < eps ->
+    f2 x <> 0 ->
+    f2 (x + h) <> 0 ->
+    (forall h:R,
       h <> 0 ->
       Rabs h < alp_f1d ->
       Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / 8)) ->
-   (forall a:R,
+    (forall a:R,
       Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
-   h <> 0 ->
-   Rabs h < alp_f1d ->
-   Rabs h < Rmin eps_f2 alp_f2 ->
-   Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / 4.
-intros.
-assert (H7 := H3 h H6).
-assert (H8 := H2 h H4 H5).
-apply Rle_lt_trans with
- (2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)).
-rewrite Rabs_mult.
-apply Rmult_le_compat_r.
-apply Rabs_pos.
-rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
-apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)).
-apply Rmult_lt_compat_l.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
-exact H8.
-right; unfold Rdiv in |- *.
-repeat rewrite Rabs_mult.
-rewrite Rabs_Rinv; discrR.
-replace (Rabs 8) with 8.
-replace 8 with 8; [ idtac | ring ].
-rewrite Rinv_mult_distr; [ idtac | discrR | discrR ].
-replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with
- (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x)));
- [ idtac | ring ].
-replace (Rabs eps) with eps.
-repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
-ring.
-symmetry  in |- *; apply Rabs_right; left; assumption.
-symmetry  in |- *; apply Rabs_right; left; prove_sup.
+    h <> 0 ->
+    Rabs h < alp_f1d ->
+    Rabs h < Rmin eps_f2 alp_f2 ->
+    Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / 4.
+Proof.
+  intros.
+  assert (H7 := H3 h H6).
+  assert (H8 := H2 h H4 H5).
+  apply Rle_lt_trans with
+    (2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)).
+  rewrite Rabs_mult.
+  apply Rmult_le_compat_r.
+  apply Rabs_pos.
+  rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
+  apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)).
+  apply Rmult_lt_compat_l.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
+  exact H8.
+  right; unfold Rdiv in |- *.
+  repeat rewrite Rabs_mult.
+  rewrite Rabs_Rinv; discrR.
+  replace (Rabs 8) with 8.
+  replace 8 with 8; [ idtac | ring ].
+  rewrite Rinv_mult_distr; [ idtac | discrR | discrR ].
+  replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with
+  (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x)));
+  [ idtac | ring ].
+  replace (Rabs eps) with eps.
+  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
+  ring.
+  symmetry  in |- *; apply Rabs_right; left; assumption.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup.
 Qed.
 
 Lemma maj_term2 :
- forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) 
-   (f2:R -> R),
-   0 < eps ->
-   f2 x <> 0 ->
-   f2 (x + h) <> 0 ->
-   (forall a:R,
+  forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) 
+    (f2:R -> R),
+    0 < eps ->
+    f2 x <> 0 ->
+    f2 (x + h) <> 0 ->
+    (forall a:R,
       Rabs a < alp_f2t2 ->
       Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))) ->
-   (forall a:R,
+    (forall a:R,
       Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
-   h <> 0 ->
-   Rabs h < alp_f2t2 ->
-   Rabs h < Rmin eps_f2 alp_f2 ->
-   l1 <> 0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / 4.
-intros.
-assert (H8 := H3 h H6).
-assert (H9 := H2 h H5).
-apply Rle_lt_trans with
- (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
-rewrite Rabs_mult; apply Rmult_le_compat_l.
-apply Rabs_pos.
-rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr.
-left; apply H9.
-apply Rlt_le_trans with
- (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
-apply Rmult_lt_compat_r.
-apply Rabs_pos_lt.
-unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
- try assumption || discrR.
-red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
-apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
-unfold Rdiv in |- *.
-repeat rewrite Rinv_mult_distr; try assumption.
-repeat rewrite Rabs_mult.
-replace (Rabs 2) with 2.
-rewrite (Rmult_comm 2).
-replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
- (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); 
- [ idtac | ring ].
-repeat apply Rmult_lt_compat_l.
-apply Rabs_pos_lt; assumption.
-apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
-repeat rewrite Rabs_Rinv; try assumption.
-rewrite <- (Rmult_comm 2).
-unfold Rdiv in H8; exact H8.
-symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-right.
-unfold Rsqr, Rdiv in |- *.
-do 1 rewrite Rinv_mult_distr; try assumption || discrR.
-do 1 rewrite Rinv_mult_distr; try assumption || discrR.
-repeat rewrite Rabs_mult.
-repeat rewrite Rabs_Rinv; try assumption || discrR.
-replace (Rabs eps) with eps.
-replace (Rabs 8) with 8.
-replace (Rabs 2) with 2.
-replace 8 with (4 * 2); [ idtac | ring ].
-rewrite Rinv_mult_distr; discrR.
-replace
- (2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) *
-  (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ 4 * / 2 * / Rabs l1))) with
- (eps * / 4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) *
-  (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
-repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
-ring.
-symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-symmetry  in |- *; apply Rabs_right; left; prove_sup.
-symmetry  in |- *; apply Rabs_right; left; assumption.
+    h <> 0 ->
+    Rabs h < alp_f2t2 ->
+    Rabs h < Rmin eps_f2 alp_f2 ->
+    l1 <> 0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / 4.
+Proof.
+  intros.
+  assert (H8 := H3 h H6).
+  assert (H9 := H2 h H5).
+  apply Rle_lt_trans with
+    (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+  rewrite Rabs_mult; apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr.
+  left; apply H9.
+  apply Rlt_le_trans with
+    (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+  apply Rmult_lt_compat_r.
+  apply Rabs_pos_lt.
+  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+    try assumption || discrR.
+  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
+  apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
+  unfold Rdiv in |- *.
+  repeat rewrite Rinv_mult_distr; try assumption.
+  repeat rewrite Rabs_mult.
+  replace (Rabs 2) with 2.
+  rewrite (Rmult_comm 2).
+  replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
+  (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); 
+  [ idtac | ring ].
+  repeat apply Rmult_lt_compat_l.
+  apply Rabs_pos_lt; assumption.
+  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
+  repeat rewrite Rabs_Rinv; try assumption.
+  rewrite <- (Rmult_comm 2).
+  unfold Rdiv in H8; exact H8.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+  right.
+  unfold Rsqr, Rdiv in |- *.
+  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
+  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
+  repeat rewrite Rabs_mult.
+  repeat rewrite Rabs_Rinv; try assumption || discrR.
+  replace (Rabs eps) with eps.
+  replace (Rabs 8) with 8.
+  replace (Rabs 2) with 2.
+  replace 8 with (4 * 2); [ idtac | ring ].
+  rewrite Rinv_mult_distr; discrR.
+  replace
+  (2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) *
+    (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ 4 * / 2 * / Rabs l1))) with
+  (eps * / 4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) *
+    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
+  repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
+  ring.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup.
+  symmetry  in |- *; apply Rabs_right; left; assumption.
 Qed.
 
 Lemma maj_term3 :
- forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) 
-   (f1 f2:R -> R),
-   0 < eps ->
-   f2 x <> 0 ->
-   f2 (x + h) <> 0 ->
-   (forall h:R,
+  forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) 
+    (f1 f2:R -> R),
+    0 < eps ->
+    f2 x <> 0 ->
+    f2 (x + h) <> 0 ->
+    (forall h:R,
       h <> 0 ->
       Rabs h < alp_f2d ->
       Rabs ((f2 (x + h) - f2 x) / h - l2) <
       Rabs (Rsqr (f2 x) * eps / (8 * f1 x))) ->
-   (forall a:R,
+    (forall a:R,
       Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
-   h <> 0 ->
-   Rabs h < alp_f2d ->
-   Rabs h < Rmin eps_f2 alp_f2 ->
-   f1 x <> 0 ->
-   Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) <
-   eps / 4.
-intros.
-assert (H8 := H2 h H4 H5).
-assert (H9 := H3 h H6).
-apply Rle_lt_trans with
- (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
-rewrite Rabs_mult.
-apply Rmult_le_compat_l.
-apply Rabs_pos.
-left; apply H8.
-apply Rlt_le_trans with
- (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
-apply Rmult_lt_compat_r.
-apply Rabs_pos_lt.
-unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
- try assumption.
-red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
-apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption.
-unfold Rdiv in |- *.
-repeat rewrite Rinv_mult_distr; try assumption.
-repeat rewrite Rabs_mult.
-replace (Rabs 2) with 2.
-rewrite (Rmult_comm 2).
-replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
- (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); 
- [ idtac | ring ].
-repeat apply Rmult_lt_compat_l.
-apply Rabs_pos_lt; assumption.
-apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
-repeat rewrite Rabs_Rinv; assumption || idtac.
-rewrite <- (Rmult_comm 2).
-unfold Rdiv in H9; exact H9.
-symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-right.
-unfold Rsqr, Rdiv in |- *.
-rewrite Rinv_mult_distr; try assumption || discrR.
-rewrite Rinv_mult_distr; try assumption || discrR.
-repeat rewrite Rabs_mult.
-repeat rewrite Rabs_Rinv; try assumption || discrR.
-replace (Rabs eps) with eps.
-replace (Rabs 8) with 8.
-replace (Rabs 2) with 2.
-replace 8 with (4 * 2); [ idtac | ring ].
-rewrite Rinv_mult_distr; discrR.
-replace
- (2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) *
-  (Rabs (f2 x) * Rabs (f2 x) * eps * (/ 4 * / 2 * / Rabs (f1 x)))) with
- (eps * / 4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
-  (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ].
-repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
-ring.
-symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-symmetry  in |- *; apply Rabs_right; left; prove_sup.
-symmetry  in |- *; apply Rabs_right; left; assumption.
+    h <> 0 ->
+    Rabs h < alp_f2d ->
+    Rabs h < Rmin eps_f2 alp_f2 ->
+    f1 x <> 0 ->
+    Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) <
+    eps / 4.
+Proof.
+  intros.
+  assert (H8 := H2 h H4 H5).
+  assert (H9 := H3 h H6).
+  apply Rle_lt_trans with
+    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
+  rewrite Rabs_mult.
+  apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  left; apply H8.
+  apply Rlt_le_trans with
+    (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
+  apply Rmult_lt_compat_r.
+  apply Rabs_pos_lt.
+  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+    try assumption.
+  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
+  apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption.
+  unfold Rdiv in |- *.
+  repeat rewrite Rinv_mult_distr; try assumption.
+  repeat rewrite Rabs_mult.
+  replace (Rabs 2) with 2.
+  rewrite (Rmult_comm 2).
+  replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
+  (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); 
+  [ idtac | ring ].
+  repeat apply Rmult_lt_compat_l.
+  apply Rabs_pos_lt; assumption.
+  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
+  repeat rewrite Rabs_Rinv; assumption || idtac.
+  rewrite <- (Rmult_comm 2).
+  unfold Rdiv in H9; exact H9.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+  right.
+  unfold Rsqr, Rdiv in |- *.
+  rewrite Rinv_mult_distr; try assumption || discrR.
+  rewrite Rinv_mult_distr; try assumption || discrR.
+  repeat rewrite Rabs_mult.
+  repeat rewrite Rabs_Rinv; try assumption || discrR.
+  replace (Rabs eps) with eps.
+  replace (Rabs 8) with 8.
+  replace (Rabs 2) with 2.
+  replace 8 with (4 * 2); [ idtac | ring ].
+  rewrite Rinv_mult_distr; discrR.
+  replace
+  (2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) *
+    (Rabs (f2 x) * Rabs (f2 x) * eps * (/ 4 * / 2 * / Rabs (f1 x)))) with
+  (eps * / 4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
+    (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ].
+  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
+  ring.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup.
+  symmetry  in |- *; apply Rabs_right; left; assumption.
 Qed.
 
 Lemma maj_term4 :
- forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) 
-   (f1 f2:R -> R),
-   0 < eps ->
-   f2 x <> 0 ->
-   f2 (x + h) <> 0 ->
-   (forall a:R,
+  forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) 
+    (f1 f2:R -> R),
+    0 < eps ->
+    f2 x <> 0 ->
+    f2 (x + h) <> 0 ->
+    (forall a:R,
       Rabs a < alp_f2c ->
       Rabs (f2 (x + a) - f2 x) <
       Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) ->
-   (forall a:R,
+    (forall a:R,
       Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
-   h <> 0 ->
-   Rabs h < alp_f2c ->
-   Rabs h < Rmin eps_f2 alp_f2 ->
-   f1 x <> 0 ->
-   l2 <> 0 ->
-   Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) <
-   eps / 4.
-intros.
-assert (H9 := H2 h H5).
-assert (H10 := H3 h H6).
-apply Rle_lt_trans with
- (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) *
-  Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
-rewrite Rabs_mult.
-apply Rmult_le_compat_l.
-apply Rabs_pos.
-left; apply H9.
-apply Rlt_le_trans with
- (Rabs (2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) *
-  Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
-apply Rmult_lt_compat_r.
-apply Rabs_pos_lt.
-unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
- assumption || idtac.
-red in |- *; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
-apply Rinv_neq_0_compat; apply prod_neq_R0.
-apply prod_neq_R0.
-discrR.
-assumption.
-assumption.
-unfold Rdiv in |- *.
-repeat rewrite Rinv_mult_distr;
- try assumption || (unfold Rsqr in |- *; apply prod_neq_R0; assumption).
-repeat rewrite Rabs_mult.
-replace (Rabs 2) with 2.
-replace
- (2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with
- (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * 2))));
- [ idtac | ring ].
-replace
- (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with
- (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))));
- [ idtac | ring ].
-repeat apply Rmult_lt_compat_l.
-apply Rabs_pos_lt; assumption.
-apply Rabs_pos_lt; assumption.
-apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr in |- *;
- apply prod_neq_R0; assumption.
-repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
-rewrite <- (Rmult_comm 2).
-unfold Rdiv in H10; exact H10.
-symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-right; unfold Rsqr, Rdiv in |- *.
-rewrite Rinv_mult_distr; try assumption || discrR.
-rewrite Rinv_mult_distr; try assumption || discrR.
-rewrite Rinv_mult_distr; try assumption || discrR.
-rewrite Rinv_mult_distr; try assumption || discrR.
-repeat rewrite Rabs_mult.
-repeat rewrite Rabs_Rinv; try assumption || discrR.
-replace (Rabs eps) with eps.
-replace (Rabs 8) with 8.
-replace (Rabs 2) with 2.
-replace 8 with (4 * 2); [ idtac | ring ].
-rewrite Rinv_mult_distr; discrR.
-replace
- (2 * Rabs l2 *
-  (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) *
-  (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps *
-   (/ 4 * / 2 * / Rabs (f1 x) * / Rabs l2))) with
- (eps * / 4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) *
-  (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
-  (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
-repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
-ring.
-symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-symmetry  in |- *; apply Rabs_right; left; prove_sup.
-symmetry  in |- *; apply Rabs_right; left; assumption.
-apply prod_neq_R0; assumption || discrR.
-apply prod_neq_R0; assumption.
+    h <> 0 ->
+    Rabs h < alp_f2c ->
+    Rabs h < Rmin eps_f2 alp_f2 ->
+    f1 x <> 0 ->
+    l2 <> 0 ->
+    Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) <
+    eps / 4.
+Proof.
+  intros.
+  assert (H9 := H2 h H5).
+  assert (H10 := H3 h H6).
+  apply Rle_lt_trans with
+    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) *
+      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
+  rewrite Rabs_mult.
+  apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  left; apply H9.
+  apply Rlt_le_trans with
+    (Rabs (2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) *
+      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
+  apply Rmult_lt_compat_r.
+  apply Rabs_pos_lt.
+  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+    assumption || idtac.
+  red in |- *; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
+  apply Rinv_neq_0_compat; apply prod_neq_R0.
+  apply prod_neq_R0.
+  discrR.
+  assumption.
+  assumption.
+  unfold Rdiv in |- *.
+  repeat rewrite Rinv_mult_distr;
+    try assumption || (unfold Rsqr in |- *; apply prod_neq_R0; assumption).
+  repeat rewrite Rabs_mult.
+  replace (Rabs 2) with 2.
+  replace
+  (2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with
+  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * 2))));
+  [ idtac | ring ].
+  replace
+  (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with
+  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))));
+  [ idtac | ring ].
+  repeat apply Rmult_lt_compat_l.
+  apply Rabs_pos_lt; assumption.
+  apply Rabs_pos_lt; assumption.
+  apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr in |- *;
+    apply prod_neq_R0; assumption.
+  repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
+  rewrite <- (Rmult_comm 2).
+  unfold Rdiv in H10; exact H10.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+  right; unfold Rsqr, Rdiv in |- *.
+  rewrite Rinv_mult_distr; try assumption || discrR.
+  rewrite Rinv_mult_distr; try assumption || discrR.
+  rewrite Rinv_mult_distr; try assumption || discrR.
+  rewrite Rinv_mult_distr; try assumption || discrR.
+  repeat rewrite Rabs_mult.
+  repeat rewrite Rabs_Rinv; try assumption || discrR.
+  replace (Rabs eps) with eps.
+  replace (Rabs 8) with 8.
+  replace (Rabs 2) with 2.
+  replace 8 with (4 * 2); [ idtac | ring ].
+  rewrite Rinv_mult_distr; discrR.
+  replace
+  (2 * Rabs l2 *
+    (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) *
+    (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps *
+      (/ 4 * / 2 * / Rabs (f1 x) * / Rabs l2))) with
+  (eps * / 4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) *
+    (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
+    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
+  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
+  ring.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+  symmetry  in |- *; apply Rabs_right; left; prove_sup.
+  symmetry  in |- *; apply Rabs_right; left; assumption.
+  apply prod_neq_R0; assumption || discrR.
+  apply prod_neq_R0; assumption.
 Qed.
 
 Lemma D_x_no_cond : forall x a:R, a <> 0 -> D_x no_cond x (x + a).
-intros.
-unfold D_x, no_cond in |- *.
-split.
-trivial.
-apply Rminus_not_eq.
-unfold Rminus in |- *.
-rewrite Ropp_plus_distr.
-rewrite <- Rplus_assoc.
-rewrite Rplus_opp_r.
-rewrite Rplus_0_l.
-apply Ropp_neq_0_compat; assumption.
+Proof.
+  intros.
+  unfold D_x, no_cond in |- *.
+  split.
+  trivial.
+  apply Rminus_not_eq.
+  unfold Rminus in |- *.
+  rewrite Ropp_plus_distr.
+  rewrite <- Rplus_assoc.
+  rewrite Rplus_opp_r.
+  rewrite Rplus_0_l.
+  apply Ropp_neq_0_compat; assumption.
 Qed.
 
 Lemma Rabs_4 :
- forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d.
-intros.
-apply Rle_trans with (Rabs (a + b) + Rabs (c + d)).
-replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | ring ].
-apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)).
-apply Rplus_le_compat_r.
-apply Rabs_triang.
-repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
-apply Rabs_triang.
+  forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d.
+Proof.
+  intros.
+  apply Rle_trans with (Rabs (a + b) + Rabs (c + d)).
+  replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | ring ].
+  apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)).
+  apply Rplus_le_compat_r.
+  apply Rabs_triang.
+  repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
+  apply Rabs_triang.
 Qed.
 
 Lemma Rlt_4 :
- forall a b c d e f g h:R,
-   a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h.
-intros; apply Rlt_trans with (b + c + e + g).
-repeat apply Rplus_lt_compat_r; assumption.
-repeat rewrite Rplus_assoc; apply Rplus_lt_compat_l.
-apply Rlt_trans with (d + e + g).
-rewrite Rplus_assoc; apply Rplus_lt_compat_r; assumption.
-rewrite Rplus_assoc; apply Rplus_lt_compat_l; apply Rlt_trans with (f + g).
-apply Rplus_lt_compat_r; assumption.
-apply Rplus_lt_compat_l; assumption.
+  forall a b c d e f g h:R,
+    a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h.
+Proof.
+  intros; apply Rlt_trans with (b + c + e + g).
+  repeat apply Rplus_lt_compat_r; assumption.
+  repeat rewrite Rplus_assoc; apply Rplus_lt_compat_l.
+  apply Rlt_trans with (d + e + g).
+  rewrite Rplus_assoc; apply Rplus_lt_compat_r; assumption.
+  rewrite Rplus_assoc; apply Rplus_lt_compat_l; apply Rlt_trans with (f + g).
+  apply Rplus_lt_compat_r; assumption.
+  apply Rplus_lt_compat_l; assumption.
 Qed.
 
 Lemma Rmin_2 : forall a b c:R, a < b -> a < c -> a < Rmin b c.
-intros; unfold Rmin in |- *; case (Rle_dec b c); intro; assumption.
+Proof.
+  intros; unfold Rmin in |- *; case (Rle_dec b c); intro; assumption.
 Qed.
 
 Lemma quadruple : forall x:R, 4 * x = x + x + x + x.
-intro; ring.
+Proof.
+  intro; ring.
 Qed.
 
 Lemma quadruple_var : forall x:R, x = x / 4 + x / 4 + x / 4 + x / 4.
-intro; rewrite <- quadruple.
-unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
-reflexivity.
+Proof.
+  intro; rewrite <- quadruple.
+  unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
+  reflexivity.
 Qed.
 
 (**********)
 Lemma continuous_neq_0 :
- forall (f:R -> R) (x0:R),
-   continuity_pt f x0 ->
-   f x0 <> 0 ->
+  forall (f:R -> R) (x0:R),
+    continuity_pt f x0 ->
+    f x0 <> 0 ->
     exists eps : posreal, (forall h:R, Rabs h < eps -> f (x0 + h) <> 0).
-intros; unfold continuity_pt in H; unfold continue_in in H;
- unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / 2))).
-intros; elim H1; intros.
-exists (mkposreal x H2).
-intros; assert (H5 := H3 (x0 + h)).
-cut
- (dist R_met (x0 + h) x0 < x ->
-  dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)).
-unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
- replace (x0 + h - x0) with h.
-intros; assert (H7 := H6 H4).
-red in |- *; intro.
-rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
- rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
- pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
-cut (0 < Rabs (f x0)).
-intro; assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7).
-cut (Rabs (/ 2) = / 2).
-assert (Hyp : 0 < 2).
-prove_sup0.
-intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10);
- rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12; 
- [ idtac | discrR ].
-cut (IZR 1 < IZR 2).
-unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro;
- elim (Rlt_irrefl 1 (Rlt_trans _ _ _ H13 H12)).
-apply IZR_lt; omega.
-unfold Rabs in |- *; case (Rcase_abs (/ 2)); intro.
-assert (Hyp : 0 < 2).
-prove_sup0.
-assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp r); rewrite Rmult_0_r in H11;
- rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
-elim (Rlt_irrefl 0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
-reflexivity.
-apply (Rabs_pos_lt _ H0).
-ring.
-assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
-intro; rewrite <- H7; unfold dist, R_met in |- *; unfold R_dist in |- *;
- unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- apply Rabs_pos_lt.
-unfold Rdiv in |- *; apply prod_neq_R0;
- [ assumption | apply Rinv_neq_0_compat; discrR ].
-intro; apply H5.
-split.
-unfold D_x, no_cond in |- *.
-split; trivial || assumption.
-assumption.
-change (0 < Rabs (f x0 / 2)) in |- *.
-apply Rabs_pos_lt; unfold Rdiv in |- *; apply prod_neq_R0.
-assumption.
-apply Rinv_neq_0_compat; discrR.
-Qed.
\ No newline at end of file
+Proof.
+  intros; unfold continuity_pt in H; unfold continue_in in H;
+    unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / 2))).
+  intros; elim H1; intros.
+  exists (mkposreal x H2).
+  intros; assert (H5 := H3 (x0 + h)).
+  cut
+    (dist R_met (x0 + h) x0 < x ->
+      dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)).
+  unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
+    replace (x0 + h - x0) with h.
+  intros; assert (H7 := H6 H4).
+  red in |- *; intro.
+  rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
+    rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
+      pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
+  cut (0 < Rabs (f x0)).
+  intro; assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7).
+  cut (Rabs (/ 2) = / 2).
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10);
+    rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12; 
+      [ idtac | discrR ].
+  cut (IZR 1 < IZR 2).
+  unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro;
+    elim (Rlt_irrefl 1 (Rlt_trans _ _ _ H13 H12)).
+  apply IZR_lt; omega.
+  unfold Rabs in |- *; case (Rcase_abs (/ 2)); intro.
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp r); rewrite Rmult_0_r in H11;
+    rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
+  elim (Rlt_irrefl 0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
+  reflexivity.
+  apply (Rabs_pos_lt _ H0).
+  ring.
+  assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
+  intro; rewrite <- H7; unfold dist, R_met in |- *; unfold R_dist in |- *;
+    unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+      apply Rabs_pos_lt.
+  unfold Rdiv in |- *; apply prod_neq_R0;
+    [ assumption | apply Rinv_neq_0_compat; discrR ].
+  intro; apply H5.
+  split.
+  unfold D_x, no_cond in |- *.
+  split; trivial || assumption.
+  assumption.
+  change (0 < Rabs (f x0 / 2)) in |- *.
+  apply Rabs_pos_lt; unfold Rdiv in |- *; apply prod_neq_R0.
+  assumption.
+  apply Rinv_neq_0_compat; discrR.
+Qed.
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
index 9f85b00a..f50aa2ad 100644
--- a/theories/Reals/Ranalysis3.v
+++ b/theories/Reals/Ranalysis3.v
@@ -6,788 +6,792 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis3.v,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Ranalysis3.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis1.
 Require Import Ranalysis2. Open Local Scope R_scope.
 
-(* Division *)
+(** Division *)
 Theorem derivable_pt_lim_div :
- forall (f1 f2:R -> R) (x l1 l2:R),
-   derivable_pt_lim f1 x l1 ->
-   derivable_pt_lim f2 x l2 ->
-   f2 x <> 0 ->
-   derivable_pt_lim (f1 / f2) x ((l1 * f2 x - l2 * f1 x) / Rsqr (f2 x)).
-intros.
-cut (derivable_pt f2 x);
- [ intro | unfold derivable_pt in |- *; apply existT with l2; exact H0 ].
-assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1).
-elim H2; clear H2; intros eps_f2 H2.
-unfold div_fct in |- *.
-assert (H3 := derivable_continuous_pt _ _ X).
-unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3;
- unfold limit_in in H3; unfold dist in H3.
-simpl in H3; unfold R_dist in H3.
-elim (H3 (Rabs (f2 x) / 2));
- [ idtac
- | unfold Rdiv in |- *; change (0 < Rabs (f2 x) * / 2) in |- *;
-    apply Rmult_lt_0_compat;
-    [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
-clear H3; intros alp_f2 H3.
-cut
- (forall x0:R,
-    Rabs (x0 - x) < alp_f2 -> Rabs (f2 x0 - f2 x) < Rabs (f2 x) / 2).
-intro H4.
-cut (forall a:R, Rabs (a - x) < alp_f2 -> Rabs (f2 x) / 2 < Rabs (f2 a)).
-intro H5.
-cut
- (forall a:R,
-    Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)).
-intro Maj.
-unfold derivable_pt_lim in |- *; intros.
-elim (H (Rabs (eps * f2 x / 8)));
- [ idtac
- | unfold Rdiv in |- *; change (0 < Rabs (eps * f2 x * / 8)) in |- *;
-    apply Rabs_pos_lt; repeat apply prod_neq_R0;
-    [ red in |- *; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6)
-    | assumption
-    | apply Rinv_neq_0_compat; discrR ] ].
-intros alp_f1d H7.
-case (Req_dec (f1 x) 0); intro.
-case (Req_dec l1 0); intro.
+  forall (f1 f2:R -> R) (x l1 l2:R),
+    derivable_pt_lim f1 x l1 ->
+    derivable_pt_lim f2 x l2 ->
+    f2 x <> 0 ->
+    derivable_pt_lim (f1 / f2) x ((l1 * f2 x - l2 * f1 x) / Rsqr (f2 x)).
+Proof.
+  intros f1 f2 x l1 l2 H H0 H1.
+  cut (derivable_pt f2 x);
+    [ intro X | unfold derivable_pt in |- *; apply existT with l2; exact H0 ].
+  assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1).
+  elim H2; clear H2; intros eps_f2 H2.
+  unfold div_fct in |- *.
+  assert (H3 := derivable_continuous_pt _ _ X).
+  unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3;
+    unfold limit_in in H3; unfold dist in H3.
+  simpl in H3; unfold R_dist in H3.
+  elim (H3 (Rabs (f2 x) / 2));
+    [ idtac
+      | unfold Rdiv in |- *; change (0 < Rabs (f2 x) * / 2) in |- *;
+        apply Rmult_lt_0_compat;
+          [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  clear H3; intros alp_f2 H3.
+  cut
+    (forall x0:R,
+      Rabs (x0 - x) < alp_f2 -> Rabs (f2 x0 - f2 x) < Rabs (f2 x) / 2).
+  intro H4.
+  cut (forall a:R, Rabs (a - x) < alp_f2 -> Rabs (f2 x) / 2 < Rabs (f2 a)).
+  intro H5.
+  cut
+    (forall a:R,
+      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)).
+  intro Maj.
+  unfold derivable_pt_lim in |- *; intros.
+  elim (H (Rabs (eps * f2 x / 8)));
+    [ idtac
+      | unfold Rdiv in |- *; change (0 < Rabs (eps * f2 x * / 8)) in |- *;
+        apply Rabs_pos_lt; repeat apply prod_neq_R0;
+          [ red in |- *; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6)
+            | assumption
+            | apply Rinv_neq_0_compat; discrR ] ].
+  intros alp_f1d H7.
+  case (Req_dec (f1 x) 0); intro.
+  case (Req_dec l1 0); intro.
 (***********************************)
 (*              Cas n° 1           *)
 (*           (f1 x)=0  l1 =0       *)
 (***********************************)
-cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d));
- [ intro
- | repeat apply Rmin_pos;
-    [ apply (cond_pos eps_f2)
-    | elim H3; intros; assumption
-    | apply (cond_pos alp_f1d) ] ].
-exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10).
-simpl in |- *; intros.
-assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)).
-assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)).
-assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)).
-assert (H16 := Rlt_le_trans _ _ _ H13 (Rmin_l _ _)).
-assert (H17 := H7 _ H11 H15).
-rewrite formule; [ idtac | assumption | assumption | apply H2; apply H14 ].
-apply Rle_lt_trans with
- (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
-  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
-  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
-  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-unfold Rminus in |- *.
-rewrite <-
- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
- .
-apply Rabs_4.
-repeat rewrite Rabs_mult.
-apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
-cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
-cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
-cut
- (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
-  eps / 4).
-cut
- (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
-  eps / 4).
-intros.
-apply Rlt_4; assumption.
-rewrite H8.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite H8.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite H9.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite <- Rabs_mult.
-apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2);
- try assumption || apply H2.
-apply H14.
-apply Rmin_2; assumption.
-right; symmetry  in |- *; apply quadruple_var.
+  cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d));
+    [ intro
+      | repeat apply Rmin_pos;
+        [ apply (cond_pos eps_f2)
+          | elim H3; intros; assumption
+          | apply (cond_pos alp_f1d) ] ].
+  exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10).
+  simpl in |- *; intros.
+  assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)).
+  assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)).
+  assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)).
+  assert (H16 := Rlt_le_trans _ _ _ H13 (Rmin_l _ _)).
+  assert (H17 := H7 _ H11 H15).
+  rewrite formule; [ idtac | assumption | assumption | apply H2; apply H14 ].
+  apply Rle_lt_trans with
+    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+  unfold Rminus in |- *.
+  rewrite <-
+    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+    .
+  apply Rabs_4.
+  repeat rewrite Rabs_mult.
+  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+  cut
+    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+      eps / 4).
+  cut
+    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+      eps / 4).
+  intros.
+  apply Rlt_4; assumption.
+  rewrite H8.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite H8.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite H9.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite <- Rabs_mult.
+  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2);
+    try assumption || apply H2.
+  apply H14.
+  apply Rmin_2; assumption.
+  right; symmetry  in |- *; apply quadruple_var.
 (***********************************)
 (*              Cas n° 2           *)
 (*           (f1 x)=0  l1<>0       *)
 (***********************************)
-assert (H10 := derivable_continuous_pt _ _ X).
-unfold continuity_pt in H10.
-unfold continue_in in H10.
-unfold limit1_in in H10.
-unfold limit_in in H10.
-unfold dist in H10.
-simpl in H10.
-unfold R_dist in H10.
-elim (H10 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
-clear H10; intros alp_f2t2 H10.
-cut
- (forall a:R,
-    Rabs a < alp_f2t2 ->
-    Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
-intro H11.
-cut (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)).
-intro.
-exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12).
-simpl in |- *.
-intros.
-assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
-assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
-assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
-assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
-assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
-assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
-clear H14 H15 H16.
-rewrite formule; try assumption.
-apply Rle_lt_trans with
- (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
-  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
-  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
-  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-unfold Rminus in |- *.
-rewrite <-
- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
- .
-apply Rabs_4.
-repeat rewrite Rabs_mult.
-apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
-cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
-cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
-cut
- (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
-  eps / 4).
-cut
- (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
-  eps / 4).
-intros.
-apply Rlt_4; assumption.
-rewrite H8.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite H8.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite <- Rabs_mult.
-apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-right; symmetry  in |- *; apply quadruple_var.
-apply H2; assumption.
-repeat apply Rmin_pos.
-apply (cond_pos eps_f2).
-apply (cond_pos alp_f1d).
-elim H3; intros; assumption.
-elim H10; intros; assumption.
-intros.
-elim H10; intros.
-case (Req_dec a 0); intro.
-rewrite H14; rewrite Rplus_0_r.
-unfold Rminus in |- *; rewrite Rplus_opp_r.
-rewrite Rabs_R0.
-apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc.
-repeat apply prod_neq_R0; try assumption.
-red in |- *; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6).
-apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption.
-apply H13.
-split.
-apply D_x_no_cond; assumption.
-replace (x + a - x) with a; [ assumption | ring ].
-change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
-apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
- repeat apply prod_neq_R0.
-red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
-assumption. 
-assumption.
-apply Rinv_neq_0_compat; repeat apply prod_neq_R0;
- [ discrR | discrR | discrR | assumption ].
+  assert (H10 := derivable_continuous_pt _ _ X).
+  unfold continuity_pt in H10.
+  unfold continue_in in H10.
+  unfold limit1_in in H10.
+  unfold limit_in in H10.
+  unfold dist in H10.
+  simpl in H10.
+  unfold R_dist in H10.
+  elim (H10 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
+  clear H10; intros alp_f2t2 H10.
+  cut
+    (forall a:R,
+      Rabs a < alp_f2t2 ->
+      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+  intro H11.
+  cut (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)).
+  intro.
+  exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12).
+  simpl in |- *.
+  intros.
+  assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
+  assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
+  assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
+  assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
+  assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
+  assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
+  clear H14 H15 H16.
+  rewrite formule; try assumption.
+  apply Rle_lt_trans with
+    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+  unfold Rminus in |- *.
+  rewrite <-
+    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+    .
+  apply Rabs_4.
+  repeat rewrite Rabs_mult.
+  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+  cut
+    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+      eps / 4).
+  cut
+    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+      eps / 4).
+  intros.
+  apply Rlt_4; assumption.
+  rewrite H8.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite H8.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite <- Rabs_mult.
+  apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  right; symmetry  in |- *; apply quadruple_var.
+  apply H2; assumption.
+  repeat apply Rmin_pos.
+  apply (cond_pos eps_f2).
+  apply (cond_pos alp_f1d).
+  elim H3; intros; assumption.
+  elim H10; intros; assumption.
+  intros.
+  elim H10; intros.
+  case (Req_dec a 0); intro.
+  rewrite H14; rewrite Rplus_0_r.
+  unfold Rminus in |- *; rewrite Rplus_opp_r.
+  rewrite Rabs_R0.
+  apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc.
+  repeat apply prod_neq_R0; try assumption.
+  red in |- *; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6).
+  apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption.
+  apply H13.
+  split.
+  apply D_x_no_cond; assumption.
+  replace (x + a - x) with a; [ assumption | ring ].
+  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
+  apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
+    repeat apply prod_neq_R0.
+  red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
+  assumption. 
+  assumption.
+  apply Rinv_neq_0_compat; repeat apply prod_neq_R0;
+    [ discrR | discrR | discrR | assumption ].
 (***********************************)
 (*              Cas n° 3           *)
 (*     (f1 x)<>0  l1=0  l2=0       *)
 (***********************************)
-case (Req_dec l1 0); intro.
-case (Req_dec l2 0); intro.
-elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
- [ idtac
- | apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
-    repeat apply prod_neq_R0;
-    [ assumption
-    | assumption
-    | red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6)
-    | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ].
-intros alp_f2d H12.
-cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)).
-intro.
-exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11).
-simpl in |- *.
-intros.
-assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
-assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
-assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
-assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
-assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
-assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
-clear H15 H16.
-rewrite formule; try assumption.
-apply Rle_lt_trans with
- (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
-  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
-  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
-  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-unfold Rminus in |- *.
-rewrite <-
- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
- .
-apply Rabs_4.
-repeat rewrite Rabs_mult.
-apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
-cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
-cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
-cut
- (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
-  eps / 4).
-cut
- (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
-  eps / 4).
-intros.
-apply Rlt_4; assumption.
-rewrite H10.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite <- Rabs_mult.
-apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite H9.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite <- Rabs_mult.
-apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac.
-apply H2; assumption.
-apply Rmin_2; assumption.
-right; symmetry  in |- *; apply quadruple_var.
-apply H2; assumption.
-repeat apply Rmin_pos.
-apply (cond_pos eps_f2).
-elim H3; intros; assumption.
-apply (cond_pos alp_f1d).
-apply (cond_pos alp_f2d).
+  case (Req_dec l1 0); intro.
+  case (Req_dec l2 0); intro.
+  elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
+    [ idtac
+      | apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
+        repeat apply prod_neq_R0;
+          [ assumption
+            | assumption
+            | red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6)
+            | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ].
+  intros alp_f2d H12.
+  cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)).
+  intro.
+  exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11).
+  simpl in |- *.
+  intros.
+  assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
+  assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
+  assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
+  assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
+  assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
+  assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
+  clear H15 H16.
+  rewrite formule; try assumption.
+  apply Rle_lt_trans with
+    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+  unfold Rminus in |- *.
+  rewrite <-
+    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+    .
+  apply Rabs_4.
+  repeat rewrite Rabs_mult.
+  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+  cut
+    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+      eps / 4).
+  cut
+    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+      eps / 4).
+  intros.
+  apply Rlt_4; assumption.
+  rewrite H10.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite <- Rabs_mult.
+  apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite H9.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite <- Rabs_mult.
+  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  right; symmetry  in |- *; apply quadruple_var.
+  apply H2; assumption.
+  repeat apply Rmin_pos.
+  apply (cond_pos eps_f2).
+  elim H3; intros; assumption.
+  apply (cond_pos alp_f1d).
+  apply (cond_pos alp_f2d).
 (***********************************)
 (*              Cas n° 4           *)
 (*    (f1 x)<>0  l1=0  l2<>0       *)
 (***********************************)
-elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
- [ idtac
- | apply Rabs_pos_lt; unfold Rsqr, Rdiv in |- *;
-    repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0;
-    try assumption || discrR ].
-intros alp_f2d H11.
-assert (H12 := derivable_continuous_pt _ _ X).
-unfold continuity_pt in H12.
-unfold continue_in in H12.
-unfold limit1_in in H12.
-unfold limit_in in H12.
-unfold dist in H12.
-simpl in H12.
-unfold R_dist in H12.
-elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
-intros alp_f2c H13.
-cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))).
-intro.
-exists
- (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c)))
-    H14).
-simpl in |- *; intros.
-assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
-assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
-assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
-assert (H20 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
-assert (H21 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
-assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
-assert (H23 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
-assert (H24 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
-clear H16 H17 H18 H19.
-cut
- (forall a:R,
-    Rabs a < alp_f2c ->
-    Rabs (f2 (x + a) - f2 x) <
-    Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
-intro.
-rewrite formule; try assumption.
-apply Rle_lt_trans with
- (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
-  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
-  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
-  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-unfold Rminus in |- *.
-rewrite <-
- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
- .
-apply Rabs_4.
-repeat rewrite Rabs_mult.
-apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
-cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
-cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
-cut
- (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
-  eps / 4).
-cut
- (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
-  eps / 4).
-intros.
-apply Rlt_4; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite H9.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite <- Rabs_mult.
-apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-right; symmetry  in |- *; apply quadruple_var.
-apply H2; assumption.
-intros.
-case (Req_dec a 0); intro.
-rewrite H17; rewrite Rplus_0_r.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0.
-apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *.
-repeat rewrite Rinv_mult_distr; try assumption.
-repeat apply prod_neq_R0; try assumption.
-red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). 
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; assumption.
-apply Rinv_neq_0_compat; assumption.
-discrR.
-discrR.
-discrR.
-discrR.
-discrR.
-apply prod_neq_R0; [ discrR | assumption ].
-elim H13; intros.
-apply H19.
-split.
-apply D_x_no_cond; assumption.
-replace (x + a - x) with a; [ assumption | ring ].
-repeat apply Rmin_pos.
-apply (cond_pos eps_f2).
-elim H3; intros; assumption.
-apply (cond_pos alp_f1d).
-apply (cond_pos alp_f2d).
-elim H13; intros; assumption.
-change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *.
-apply Rabs_pos_lt.
-unfold Rsqr, Rdiv in |- *.
-repeat rewrite Rinv_mult_distr; try assumption || discrR.
-repeat apply prod_neq_R0; try assumption.
-red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). 
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; assumption.
-apply Rinv_neq_0_compat; assumption.
-apply prod_neq_R0; [ discrR | assumption ].
-red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). 
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; discrR.
-apply Rinv_neq_0_compat; assumption.
+  elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
+    [ idtac
+      | apply Rabs_pos_lt; unfold Rsqr, Rdiv in |- *;
+        repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0;
+          try assumption || discrR ].
+  intros alp_f2d H11.
+  assert (H12 := derivable_continuous_pt _ _ X).
+  unfold continuity_pt in H12.
+  unfold continue_in in H12.
+  unfold limit1_in in H12.
+  unfold limit_in in H12.
+  unfold dist in H12.
+  simpl in H12.
+  unfold R_dist in H12.
+  elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
+  intros alp_f2c H13.
+  cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))).
+  intro.
+  exists
+    (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c)))
+      H14).
+  simpl in |- *; intros.
+  assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
+  assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
+  assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
+  assert (H20 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
+  assert (H21 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
+  assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
+  assert (H23 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
+  assert (H24 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
+  clear H16 H17 H18 H19.
+  cut
+    (forall a:R,
+      Rabs a < alp_f2c ->
+      Rabs (f2 (x + a) - f2 x) <
+      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
+  intro.
+  rewrite formule; try assumption.
+  apply Rle_lt_trans with
+    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+  unfold Rminus in |- *.
+  rewrite <-
+    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+    .
+  apply Rabs_4.
+  repeat rewrite Rabs_mult.
+  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+  cut
+    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+      eps / 4).
+  cut
+    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+      eps / 4).
+  intros.
+  apply Rlt_4; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite H9.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite <- Rabs_mult.
+  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  right; symmetry  in |- *; apply quadruple_var.
+  apply H2; assumption.
+  intros.
+  case (Req_dec a 0); intro.
+  rewrite H17; rewrite Rplus_0_r.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0.
+  apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *.
+  repeat rewrite Rinv_mult_distr; try assumption.
+  repeat apply prod_neq_R0; try assumption.
+  red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). 
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; assumption.
+  apply Rinv_neq_0_compat; assumption.
+  discrR.
+  discrR.
+  discrR.
+  discrR.
+  discrR.
+  apply prod_neq_R0; [ discrR | assumption ].
+  elim H13; intros.
+  apply H19.
+  split.
+  apply D_x_no_cond; assumption.
+  replace (x + a - x) with a; [ assumption | ring ].
+  repeat apply Rmin_pos.
+  apply (cond_pos eps_f2).
+  elim H3; intros; assumption.
+  apply (cond_pos alp_f1d).
+  apply (cond_pos alp_f2d).
+  elim H13; intros; assumption.
+  change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *.
+  apply Rabs_pos_lt.
+  unfold Rsqr, Rdiv in |- *.
+  repeat rewrite Rinv_mult_distr; try assumption || discrR.
+  repeat apply prod_neq_R0; try assumption.
+  red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). 
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; assumption.
+  apply Rinv_neq_0_compat; assumption.
+  apply prod_neq_R0; [ discrR | assumption ].
+  red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). 
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; discrR.
+  apply Rinv_neq_0_compat; assumption.
 (***********************************)
 (*              Cas n° 5           *)
 (*    (f1 x)<>0  l1<>0  l2=0       *)
 (***********************************)
-case (Req_dec l2 0); intro.
-assert (H11 := derivable_continuous_pt _ _ X).
-unfold continuity_pt in H11.
-unfold continue_in in H11.
-unfold limit1_in in H11.
-unfold limit_in in H11.
-unfold dist in H11.
-simpl in H11.
-unfold R_dist in H11.
-elim (H11 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
-clear H11; intros alp_f2t2 H11.
-elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
-intros alp_f2d H12.
-cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))).
-intro.
-exists
- (mkposreal
-    (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13).
-simpl in |- *.
-intros.
-cut
- (forall a:R,
-    Rabs a < alp_f2t2 ->
-    Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
-intro.
-assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
-assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
-assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
-assert (H20 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
-assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
-assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
-assert (H23 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
-assert (H24 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
-clear H15 H17 H18 H21.
-rewrite formule; try assumption.
-apply Rle_lt_trans with
- (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
-  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
-  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
-  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-unfold Rminus in |- *.
-rewrite <-
- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
- .
-apply Rabs_4.
-repeat rewrite Rabs_mult.
-apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
-cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
-cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
-cut
- (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
-  eps / 4).
-cut
- (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
-  eps / 4).
-intros.
-apply Rlt_4; assumption.
-rewrite H10.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
-rewrite Rabs_R0; rewrite Rmult_0_l.
-apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
-rewrite <- Rabs_mult.
-apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-right; symmetry  in |- *; apply quadruple_var.
-apply H2; assumption.
-intros.
-case (Req_dec a 0); intro.
-rewrite H17; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0.
-apply Rabs_pos_lt.
-unfold Rdiv in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
-unfold Rsqr in |- *.
-repeat apply prod_neq_R0;
- assumption ||
-   (apply Rinv_neq_0_compat; assumption) ||
-     (apply Rinv_neq_0_compat; discrR) ||
-       (red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6)).
-elim H11; intros.
-apply H19.
-split.
-apply D_x_no_cond; assumption.
-replace (x + a - x) with a; [ assumption | ring ].
-repeat apply Rmin_pos.
-apply (cond_pos eps_f2).
-elim H3; intros; assumption.
-apply (cond_pos alp_f1d). 
-apply (cond_pos alp_f2d).
-elim H11; intros; assumption.
-apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
-repeat apply prod_neq_R0;
- assumption ||
-   (apply Rinv_neq_0_compat; assumption) ||
-     (apply Rinv_neq_0_compat; discrR) ||
-       (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
-change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
-apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
-repeat apply prod_neq_R0;
- assumption ||
-   (apply Rinv_neq_0_compat; assumption) ||
-     (apply Rinv_neq_0_compat; discrR) ||
-       (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
+  case (Req_dec l2 0); intro.
+  assert (H11 := derivable_continuous_pt _ _ X).
+  unfold continuity_pt in H11.
+  unfold continue_in in H11.
+  unfold limit1_in in H11.
+  unfold limit_in in H11.
+  unfold dist in H11.
+  simpl in H11.
+  unfold R_dist in H11.
+  elim (H11 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
+  clear H11; intros alp_f2t2 H11.
+  elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
+  intros alp_f2d H12.
+  cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))).
+  intro.
+  exists
+    (mkposreal
+      (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13).
+  simpl in |- *.
+  intros.
+  cut
+    (forall a:R,
+      Rabs a < alp_f2t2 ->
+      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+  intro.
+  assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
+  assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
+  assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
+  assert (H20 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
+  assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
+  assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
+  assert (H23 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
+  assert (H24 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
+  clear H15 H17 H18 H21.
+  rewrite formule; try assumption.
+  apply Rle_lt_trans with
+    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+  unfold Rminus in |- *.
+  rewrite <-
+    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+    .
+  apply Rabs_4.
+  repeat rewrite Rabs_mult.
+  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+  cut
+    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+      eps / 4).
+  cut
+    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+      eps / 4).
+  intros.
+  apply Rlt_4; assumption.
+  rewrite H10.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  rewrite Rabs_R0; rewrite Rmult_0_l.
+  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
+  rewrite <- Rabs_mult.
+  apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  right; symmetry  in |- *; apply quadruple_var.
+  apply H2; assumption.
+  intros.
+  case (Req_dec a 0); intro.
+  rewrite H17; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0.
+  apply Rabs_pos_lt.
+  unfold Rdiv in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+  unfold Rsqr in |- *.
+  repeat apply prod_neq_R0;
+    assumption ||
+      (apply Rinv_neq_0_compat; assumption) ||
+        (apply Rinv_neq_0_compat; discrR) ||
+          (red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6)).
+  elim H11; intros.
+  apply H19.
+  split.
+  apply D_x_no_cond; assumption.
+  replace (x + a - x) with a; [ assumption | ring ].
+  repeat apply Rmin_pos.
+  apply (cond_pos eps_f2).
+  elim H3; intros; assumption.
+  apply (cond_pos alp_f1d). 
+  apply (cond_pos alp_f2d).
+  elim H11; intros; assumption.
+  apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+  repeat apply prod_neq_R0;
+    assumption ||
+      (apply Rinv_neq_0_compat; assumption) ||
+        (apply Rinv_neq_0_compat; discrR) ||
+          (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
+  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
+  apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+  repeat apply prod_neq_R0;
+    assumption ||
+      (apply Rinv_neq_0_compat; assumption) ||
+        (apply Rinv_neq_0_compat; discrR) ||
+          (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
 (***********************************)
 (*              Cas n° 6           *)
 (*    (f1 x)<>0  l1<>0  l2<>0      *)
 (***********************************)
-elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
-intros alp_f2d H11.
-assert (H12 := derivable_continuous_pt _ _ X).
-unfold continuity_pt in H12.
-unfold continue_in in H12.
-unfold limit1_in in H12.
-unfold limit_in in H12.
-unfold dist in H12.
-simpl in H12.
-unfold R_dist in H12.
-elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
-intros alp_f2c H13.
-elim (H12 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
-intros alp_f2t2 H14.
-cut
- (0 <
-  Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
-    (Rmin alp_f2c alp_f2t2)).
-intro.
-exists
- (mkposreal
-    (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
-       (Rmin alp_f2c alp_f2t2)) H15).
-simpl in |- *.
-intros.
-assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
-assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
-assert (H20 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
-assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
-assert (H22 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
-assert (H23 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
-assert (H24 := Rlt_le_trans _ _ _ H20 (Rmin_l _ _)).
-assert (H25 := Rlt_le_trans _ _ _ H20 (Rmin_r _ _)).
-assert (H26 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
-assert (H27 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
-clear H17 H18 H19 H20 H21.
-cut
- (forall a:R,
-    Rabs a < alp_f2t2 ->
-    Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
-cut
- (forall a:R,
-    Rabs a < alp_f2c ->
-    Rabs (f2 (x + a) - f2 x) <
-    Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
-intros.
-rewrite formule; try assumption.
-apply Rle_lt_trans with
- (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
-  Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
-  Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
-  Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-unfold Rminus in |- *.
-rewrite <-
- (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
- .
-apply Rabs_4.
-repeat rewrite Rabs_mult.
-apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
-cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
-cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
-cut
- (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
-  eps / 4).
-cut
- (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
-  eps / 4).
-intros.
-apply Rlt_4; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-rewrite <- Rabs_mult.
-apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
-apply H2; assumption.
-apply Rmin_2; assumption.
-right; symmetry  in |- *; apply quadruple_var.
-apply H2; assumption.
-intros.
-case (Req_dec a 0); intro.
-rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
-repeat apply prod_neq_R0;
- assumption ||
-   (apply Rinv_neq_0_compat; assumption) ||
-     (apply Rinv_neq_0_compat; discrR) ||
-       (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
-apply prod_neq_R0; [ discrR | assumption ].
-apply prod_neq_R0; [ discrR | assumption ].
-assumption.
-elim H13; intros.
-apply H20.
-split.
-apply D_x_no_cond; assumption.
-replace (x + a - x) with a; [ assumption | ring ].
-intros.
-case (Req_dec a 0); intro.
-rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
-repeat apply prod_neq_R0;
- assumption ||
-   (apply Rinv_neq_0_compat; assumption) ||
-     (apply Rinv_neq_0_compat; discrR) ||
-       (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
-discrR.
-assumption.
-elim H14; intros.
-apply H20.
-split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-apply Rminus_not_eq_right.
-replace (x + a - x) with a; [ assumption | ring ].
-replace (x + a - x) with a; [ assumption | ring ].
-repeat apply Rmin_pos.
-apply (cond_pos eps_f2).
-elim H3; intros; assumption.
-apply (cond_pos alp_f1d).
-apply (cond_pos alp_f2d).
-elim H13; intros; assumption.
-elim H14; intros; assumption.
-change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *; apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
-repeat apply prod_neq_R0;
- assumption ||
-   (apply Rinv_neq_0_compat; assumption) ||
-     (apply Rinv_neq_0_compat; discrR) ||
-       (red in |- *; intro H14; rewrite H14 in H6; elim (Rlt_irrefl _ H6)).
-change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *;
- apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
-repeat apply prod_neq_R0;
- assumption ||
-   (apply Rinv_neq_0_compat; assumption) ||
-     (apply Rinv_neq_0_compat; discrR) ||
-       (red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6)).
-apply prod_neq_R0; [ discrR | assumption ].
-apply prod_neq_R0; [ discrR | assumption ].
-assumption.
-apply Rabs_pos_lt.
-unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr;
- [ idtac | discrR | assumption ].
-repeat apply prod_neq_R0;
- assumption ||
-   (apply Rinv_neq_0_compat; assumption) ||
-     (apply Rinv_neq_0_compat; discrR) ||
-       (red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6)).
-intros.
-unfold Rdiv in |- *.
-apply Rmult_lt_reg_l with (Rabs (f2 (x + a))).
-apply Rabs_pos_lt; apply H2.
-apply Rlt_le_trans with (Rmin eps_f2 alp_f2).
-assumption.
-apply Rmin_l.
-rewrite <- Rinv_r_sym.
-apply Rmult_lt_reg_l with (Rabs (f2 x)).
-apply Rabs_pos_lt; assumption.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm (Rabs (f2 x))).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-apply Rmult_lt_reg_l with (/ 2).
-apply Rinv_0_lt_compat; prove_sup0.
-repeat rewrite (Rmult_comm (/ 2)).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r.
-unfold Rdiv in H5; apply H5.
-replace (x + a - x) with a.
-assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_r _ _)); assumption.
-ring.
-discrR.
-apply Rabs_no_R0; assumption.
-apply Rabs_no_R0; apply H2.
-assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_l _ _)); assumption.
-intros.
-assert (H6 := H4 a H5).
-rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6.
-rewrite Ropp_minus_distr in H6.
-assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6).
-apply Rplus_lt_reg_r with (- Rabs (f2 a) + Rabs (f2 x) / 2).
-rewrite Rplus_assoc.
-rewrite <- double_var.
-do 2 rewrite (Rplus_comm (- Rabs (f2 a))).
-rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
-unfold Rminus in H7; assumption.
-intros.
-case (Req_dec x x0); intro.
-rewrite <- H5; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim H3; intros.
-apply H7.
-split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-assumption.
-assumption.
+  elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
+  intros alp_f2d H11.
+  assert (H12 := derivable_continuous_pt _ _ X).
+  unfold continuity_pt in H12.
+  unfold continue_in in H12.
+  unfold limit1_in in H12.
+  unfold limit_in in H12.
+  unfold dist in H12.
+  simpl in H12.
+  unfold R_dist in H12.
+  elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
+  intros alp_f2c H13.
+  elim (H12 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
+  intros alp_f2t2 H14.
+  cut
+    (0 <
+      Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
+      (Rmin alp_f2c alp_f2t2)).
+  intro.
+  exists
+    (mkposreal
+      (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
+        (Rmin alp_f2c alp_f2t2)) H15).
+  simpl in |- *.
+  intros.
+  assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
+  assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
+  assert (H20 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
+  assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
+  assert (H22 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
+  assert (H23 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
+  assert (H24 := Rlt_le_trans _ _ _ H20 (Rmin_l _ _)).
+  assert (H25 := Rlt_le_trans _ _ _ H20 (Rmin_r _ _)).
+  assert (H26 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
+  assert (H27 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
+  clear H17 H18 H19 H20 H21.
+  cut
+    (forall a:R,
+      Rabs a < alp_f2t2 ->
+      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+  cut
+    (forall a:R,
+      Rabs a < alp_f2c ->
+      Rabs (f2 (x + a) - f2 x) <
+      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
+  intros.
+  rewrite formule; try assumption.
+  apply Rle_lt_trans with
+    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
+      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
+      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
+      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
+  unfold Rminus in |- *.
+  rewrite <-
+    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
+    .
+  apply Rabs_4.
+  repeat rewrite Rabs_mult.
+  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
+  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
+  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
+  cut
+    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
+      eps / 4).
+  cut
+    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
+      eps / 4).
+  intros.
+  apply Rlt_4; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  rewrite <- Rabs_mult.
+  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
+  apply H2; assumption.
+  apply Rmin_2; assumption.
+  right; symmetry  in |- *; apply quadruple_var.
+  apply H2; assumption.
+  intros.
+  case (Req_dec a 0); intro.
+  rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+  repeat apply prod_neq_R0;
+    assumption ||
+      (apply Rinv_neq_0_compat; assumption) ||
+        (apply Rinv_neq_0_compat; discrR) ||
+          (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
+  apply prod_neq_R0; [ discrR | assumption ].
+  apply prod_neq_R0; [ discrR | assumption ].
+  assumption.
+  elim H13; intros.
+  apply H20.
+  split.
+  apply D_x_no_cond; assumption.
+  replace (x + a - x) with a; [ assumption | ring ].
+  intros.
+  case (Req_dec a 0); intro.
+  rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+  repeat apply prod_neq_R0;
+    assumption ||
+      (apply Rinv_neq_0_compat; assumption) ||
+        (apply Rinv_neq_0_compat; discrR) ||
+          (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
+  discrR.
+  assumption.
+  elim H14; intros.
+  apply H20.
+  split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  apply Rminus_not_eq_right.
+  replace (x + a - x) with a; [ assumption | ring ].
+  replace (x + a - x) with a; [ assumption | ring ].
+  repeat apply Rmin_pos.
+  apply (cond_pos eps_f2).
+  elim H3; intros; assumption.
+  apply (cond_pos alp_f1d).
+  apply (cond_pos alp_f2d).
+  elim H13; intros; assumption.
+  elim H14; intros; assumption.
+  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *; apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+  repeat apply prod_neq_R0;
+    assumption ||
+      (apply Rinv_neq_0_compat; assumption) ||
+        (apply Rinv_neq_0_compat; discrR) ||
+          (red in |- *; intro H14; rewrite H14 in H6; elim (Rlt_irrefl _ H6)).
+  change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *;
+    apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+  repeat apply prod_neq_R0;
+    assumption ||
+      (apply Rinv_neq_0_compat; assumption) ||
+        (apply Rinv_neq_0_compat; discrR) ||
+          (red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6)).
+  apply prod_neq_R0; [ discrR | assumption ].
+  apply prod_neq_R0; [ discrR | assumption ].
+  assumption.
+  apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr;
+    [ idtac | discrR | assumption ].
+  repeat apply prod_neq_R0;
+    assumption ||
+      (apply Rinv_neq_0_compat; assumption) ||
+        (apply Rinv_neq_0_compat; discrR) ||
+          (red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6)).
+  intros.
+  unfold Rdiv in |- *.
+  apply Rmult_lt_reg_l with (Rabs (f2 (x + a))).
+  apply Rabs_pos_lt; apply H2.
+  apply Rlt_le_trans with (Rmin eps_f2 alp_f2).
+  assumption.
+  apply Rmin_l.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_lt_reg_l with (Rabs (f2 x)).
+  apply Rabs_pos_lt; assumption.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm (Rabs (f2 x))).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  apply Rmult_lt_reg_l with (/ 2).
+  apply Rinv_0_lt_compat; prove_sup0.
+  repeat rewrite (Rmult_comm (/ 2)).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r.
+  unfold Rdiv in H5; apply H5.
+  replace (x + a - x) with a.
+  assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_r _ _)); assumption.
+  ring.
+  discrR.
+  apply Rabs_no_R0; assumption.
+  apply Rabs_no_R0; apply H2.
+  assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_l _ _)); assumption.
+  intros.
+  assert (H6 := H4 a H5).
+  rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6.
+  rewrite Ropp_minus_distr in H6.
+  assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6).
+  apply Rplus_lt_reg_r with (- Rabs (f2 a) + Rabs (f2 x) / 2).
+  rewrite Rplus_assoc.
+  rewrite <- double_var.
+  do 2 rewrite (Rplus_comm (- Rabs (f2 a))).
+  rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
+  unfold Rminus in H7; assumption.
+  intros.
+  case (Req_dec x x0); intro.
+  rewrite <- H5; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim H3; intros.
+  apply H7.
+  split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  assumption.
+  assumption.
 Qed.
 
 Lemma derivable_pt_div :
- forall (f1 f2:R -> R) (x:R),
-   derivable_pt f1 x ->
-   derivable_pt f2 x -> f2 x <> 0 -> derivable_pt (f1 / f2) x.
-unfold derivable_pt in |- *.
-intros.
-elim X; intros.
-elim X0; intros.
-apply existT with ((x0 * f2 x - x1 * f1 x) / Rsqr (f2 x)).
-apply derivable_pt_lim_div; assumption.
+  forall (f1 f2:R -> R) (x:R),
+    derivable_pt f1 x ->
+    derivable_pt f2 x -> f2 x <> 0 -> derivable_pt (f1 / f2) x.
+Proof.
+  unfold derivable_pt in |- *.
+  intros f1 f2 x X X0 H.
+  elim X; intros.
+  elim X0; intros.
+  apply existT with ((x0 * f2 x - x1 * f1 x) / Rsqr (f2 x)).
+  apply derivable_pt_lim_div; assumption.
 Qed.
 
 Lemma derivable_div :
- forall f1 f2:R -> R,
-   derivable f1 ->
-   derivable f2 -> (forall x:R, f2 x <> 0) -> derivable (f1 / f2).
-unfold derivable in |- *; intros.
-apply (derivable_pt_div _ _ _ (X x) (X0 x) (H x)).
+  forall f1 f2:R -> R,
+    derivable f1 ->
+    derivable f2 -> (forall x:R, f2 x <> 0) -> derivable (f1 / f2).
+Proof.
+  unfold derivable in |- *; intros f1 f2 X X0 H x.
+  apply (derivable_pt_div _ _ _ (X x) (X0 x) (H x)).
 Qed.
 
 Lemma derive_pt_div :
- forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) 
-   (pr2:derivable_pt f2 x) (na:f2 x <> 0),
-   derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) =
-   (derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x).
-intros.
-assert (H := derivable_derive f1 x pr1).
-assert (H0 := derivable_derive f2 x pr2).
-assert
- (H1 := derivable_derive (f1 / f2)%F x (derivable_pt_div _ _ _ pr1 pr2 na)).
-elim H; clear H; intros l1 H.
-elim H0; clear H0; intros l2 H0.
-elim H1; clear H1; intros l H1.
-rewrite H; rewrite H0; apply derive_pt_eq_0.
-assert (H3 := projT2 pr1).
-unfold derive_pt in H; rewrite H in H3.
-assert (H4 := projT2 pr2).
-unfold derive_pt in H0; rewrite H0 in H4.
-apply derivable_pt_lim_div; assumption.
-Qed.
\ No newline at end of file
+  forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) 
+    (pr2:derivable_pt f2 x) (na:f2 x <> 0),
+    derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) =
+    (derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x).
+Proof.
+  intros.
+  assert (H := derivable_derive f1 x pr1).
+  assert (H0 := derivable_derive f2 x pr2).
+  assert
+    (H1 := derivable_derive (f1 / f2)%F x (derivable_pt_div _ _ _ pr1 pr2 na)).
+  elim H; clear H; intros l1 H.
+  elim H0; clear H0; intros l2 H0.
+  elim H1; clear H1; intros l H1.
+  rewrite H; rewrite H0; apply derive_pt_eq_0.
+  assert (H3 := projT2 pr1).
+  unfold derive_pt in H; rewrite H in H3.
+  assert (H4 := projT2 pr2).
+  unfold derive_pt in H0; rewrite H0 in H4.
+  apply derivable_pt_lim_div; assumption.
+Qed.
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
index 86f49cd4..205c06b4 100644
--- a/theories/Reals/Ranalysis4.v
+++ b/theories/Reals/Ranalysis4.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Ranalysis4.v,v 1.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Ranalysis4.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -18,367 +18,392 @@ Require Import Exp_prop. Open Local Scope R_scope.
 
 (**********)
 Lemma derivable_pt_inv :
- forall (f:R -> R) (x:R),
-   f x <> 0 -> derivable_pt f x -> derivable_pt (/ f) x.
-intros; cut (derivable_pt (fct_cte 1 / f) x -> derivable_pt (/ f) x).
-intro; apply X0.
-apply derivable_pt_div.
-apply derivable_pt_const.
-assumption.
-assumption.
-unfold div_fct, inv_fct, fct_cte in |- *; intro; elim X0; intros;
- unfold derivable_pt in |- *; apply existT with x0;
- unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
- unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; 
- intros; elim (p eps H0); intros; exists x1; intros; 
- unfold Rdiv in H1; unfold Rdiv in |- *; rewrite <- (Rmult_1_l (/ f x));
- rewrite <- (Rmult_1_l (/ f (x + h))).
-apply H1; assumption.
+  forall (f:R -> R) (x:R),
+    f x <> 0 -> derivable_pt f x -> derivable_pt (/ f) x.
+Proof.
+  intros f x H X; cut (derivable_pt (fct_cte 1 / f) x -> derivable_pt (/ f) x).
+  intro X0; apply X0.
+  apply derivable_pt_div.
+  apply derivable_pt_const.
+  assumption.
+  assumption.
+  unfold div_fct, inv_fct, fct_cte in |- *; intro X0; elim X0; intros;
+    unfold derivable_pt in |- *; apply existT with x0;
+      unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
+        unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; 
+          intros; elim (p eps H0); intros; exists x1; intros; 
+            unfold Rdiv in H1; unfold Rdiv in |- *; rewrite <- (Rmult_1_l (/ f x));
+              rewrite <- (Rmult_1_l (/ f (x + h))).
+  apply H1; assumption.
 Qed.
 
 (**********)
 Lemma pr_nu_var :
- forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
-   f = g -> derive_pt f x pr1 = derive_pt g x pr2.
-unfold derivable_pt, derive_pt in |- *; intros.
-elim pr1; intros.
-elim pr2; intros.
-simpl in |- *.
-rewrite H in p.
-apply uniqueness_limite with g x; assumption.
+  forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
+    f = g -> derive_pt f x pr1 = derive_pt g x pr2.
+Proof.
+  unfold derivable_pt, derive_pt in |- *; intros.
+  elim pr1; intros.
+  elim pr2; intros.
+  simpl in |- *.
+  rewrite H in p.
+  apply uniqueness_limite with g x; assumption.
 Qed.
 
 (**********)
 Lemma pr_nu_var2 :
- forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
-   (forall h:R, f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2.
-unfold derivable_pt, derive_pt in |- *; intros.
-elim pr1; intros.
-elim pr2; intros.
-simpl in |- *.
-assert (H0 := uniqueness_step2 _ _ _ p). 
-assert (H1 := uniqueness_step2 _ _ _ p0). 
-cut (limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) x1 0).
-intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). 
-assumption.
-unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
- simpl in |- *; unfold R_dist in |- *; unfold limit1_in in H1;
- unfold limit_in in H1; unfold dist in H1; simpl in H1; 
- unfold R_dist in H1.
-intros; elim (H1 eps H2); intros.
-elim H3; intros.
-exists x2.
-split.
-assumption.
-intros; do 2 rewrite H; apply H5; assumption.
+  forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
+    (forall h:R, f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2.
+Proof.
+  unfold derivable_pt, derive_pt in |- *; intros.
+  elim pr1; intros.
+  elim pr2; intros.
+  simpl in |- *.
+  assert (H0 := uniqueness_step2 _ _ _ p). 
+  assert (H1 := uniqueness_step2 _ _ _ p0). 
+  cut (limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) x1 0).
+  intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). 
+  assumption.
+  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
+    simpl in |- *; unfold R_dist in |- *; unfold limit1_in in H1;
+      unfold limit_in in H1; unfold dist in H1; simpl in H1; 
+        unfold R_dist in H1.
+  intros; elim (H1 eps H2); intros.
+  elim H3; intros.
+  exists x2.
+  split.
+  assumption.
+  intros; do 2 rewrite H; apply H5; assumption.
 Qed.
 
 (**********)
 Lemma derivable_inv :
- forall f:R -> R, (forall x:R, f x <> 0) -> derivable f -> derivable (/ f).
-intros.
-unfold derivable in |- *; intro.
-apply derivable_pt_inv.
-apply (H x).
-apply (X x).
+  forall f:R -> R, (forall x:R, f x <> 0) -> derivable f -> derivable (/ f).
+Proof.
+  intros f H X.
+  unfold derivable in |- *; intro x.
+  apply derivable_pt_inv.
+  apply (H x).
+  apply (X x).
 Qed.
 
 Lemma derive_pt_inv :
- forall (f:R -> R) (x:R) (pr:derivable_pt f x) (na:f x <> 0),
-   derive_pt (/ f) x (derivable_pt_inv f x na pr) =
-   - derive_pt f x pr / Rsqr (f x).
-intros;
- replace (derive_pt (/ f) x (derivable_pt_inv f x na pr)) with
-  (derive_pt (fct_cte 1 / f) x
-     (derivable_pt_div (fct_cte 1) f x (derivable_pt_const 1 x) pr na)).
-rewrite derive_pt_div; rewrite derive_pt_const; unfold fct_cte in |- *;
- rewrite Rmult_0_l; rewrite Rmult_1_r; unfold Rminus in |- *;
- rewrite Rplus_0_l; reflexivity.
-apply pr_nu_var2.
-intro; unfold div_fct, fct_cte, inv_fct in |- *.
-unfold Rdiv in |- *; ring.
+  forall (f:R -> R) (x:R) (pr:derivable_pt f x) (na:f x <> 0),
+    derive_pt (/ f) x (derivable_pt_inv f x na pr) =
+    - derive_pt f x pr / Rsqr (f x).
+Proof.
+  intros;
+    replace (derive_pt (/ f) x (derivable_pt_inv f x na pr)) with
+    (derive_pt (fct_cte 1 / f) x
+      (derivable_pt_div (fct_cte 1) f x (derivable_pt_const 1 x) pr na)).
+  rewrite derive_pt_div; rewrite derive_pt_const; unfold fct_cte in |- *;
+    rewrite Rmult_0_l; rewrite Rmult_1_r; unfold Rminus in |- *;
+      rewrite Rplus_0_l; reflexivity.
+  apply pr_nu_var2.
+  intro; unfold div_fct, fct_cte, inv_fct in |- *.
+  unfold Rdiv in |- *; ring.
 Qed.
 
-(* Rabsolu *)
+(** Rabsolu *)
 Lemma Rabs_derive_1 : forall x:R, 0 < x -> derivable_pt_lim Rabs x 1.
-intros.
-unfold derivable_pt_lim in |- *; intros.
-exists (mkposreal x H); intros.
-rewrite (Rabs_right x).
-rewrite (Rabs_right (x + h)).
-rewrite Rplus_comm.
-unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r.
-rewrite Rplus_0_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
-rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0.
-apply H1.
-apply Rle_ge.
-case (Rcase_abs h); intro.
-rewrite (Rabs_left h r) in H2.
-left; rewrite Rplus_comm; apply Rplus_lt_reg_r with (- h); rewrite Rplus_0_r;
- rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; 
- apply H2.
-apply Rplus_le_le_0_compat.
-left; apply H.
-apply Rge_le; apply r.
-left; apply H.
+Proof.
+  intros.
+  unfold derivable_pt_lim in |- *; intros.
+  exists (mkposreal x H); intros.
+  rewrite (Rabs_right x).
+  rewrite (Rabs_right (x + h)).
+  rewrite Rplus_comm.
+  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r.
+  rewrite Rplus_0_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
+  rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0.
+  apply H1.
+  apply Rle_ge.
+  case (Rcase_abs h); intro.
+  rewrite (Rabs_left h r) in H2.
+  left; rewrite Rplus_comm; apply Rplus_lt_reg_r with (- h); rewrite Rplus_0_r;
+    rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; 
+      apply H2.
+  apply Rplus_le_le_0_compat.
+  left; apply H.
+  apply Rge_le; apply r.
+  left; apply H.
 Qed.
 
 Lemma Rabs_derive_2 : forall x:R, x < 0 -> derivable_pt_lim Rabs x (-1).
-intros.
-unfold derivable_pt_lim in |- *; intros.
-cut (0 < - x).
-intro; exists (mkposreal (- x) H1); intros.
-rewrite (Rabs_left x).
-rewrite (Rabs_left (x + h)).
-rewrite Rplus_comm.
-rewrite Ropp_plus_distr.
-unfold Rminus in |- *; rewrite Ropp_involutive; rewrite Rplus_assoc;
- rewrite Rplus_opp_l.
-rewrite Rplus_0_r; unfold Rdiv in |- *.
-rewrite Ropp_mult_distr_l_reverse.
-rewrite <- Rinv_r_sym.
-rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0.
-apply H2.
-case (Rcase_abs h); intro.
-apply Ropp_lt_cancel.
-rewrite Ropp_0; rewrite Ropp_plus_distr; apply Rplus_lt_0_compat.
-apply H1.
-apply Ropp_0_gt_lt_contravar; apply r.
-rewrite (Rabs_right h r) in H3.
-apply Rplus_lt_reg_r with (- x); rewrite Rplus_0_r; rewrite <- Rplus_assoc;
- rewrite Rplus_opp_l; rewrite Rplus_0_l; apply H3.
-apply H.
-apply Ropp_0_gt_lt_contravar; apply H.
+Proof.
+  intros.
+  unfold derivable_pt_lim in |- *; intros.
+  cut (0 < - x).
+  intro; exists (mkposreal (- x) H1); intros.
+  rewrite (Rabs_left x).
+  rewrite (Rabs_left (x + h)).
+  rewrite Rplus_comm.
+  rewrite Ropp_plus_distr.
+  unfold Rminus in |- *; rewrite Ropp_involutive; rewrite Rplus_assoc;
+    rewrite Rplus_opp_l.
+  rewrite Rplus_0_r; unfold Rdiv in |- *.
+  rewrite Ropp_mult_distr_l_reverse.
+  rewrite <- Rinv_r_sym.
+  rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0.
+  apply H2.
+  case (Rcase_abs h); intro.
+  apply Ropp_lt_cancel.
+  rewrite Ropp_0; rewrite Ropp_plus_distr; apply Rplus_lt_0_compat.
+  apply H1.
+  apply Ropp_0_gt_lt_contravar; apply r.
+  rewrite (Rabs_right h r) in H3.
+  apply Rplus_lt_reg_r with (- x); rewrite Rplus_0_r; rewrite <- Rplus_assoc;
+    rewrite Rplus_opp_l; rewrite Rplus_0_l; apply H3.
+  apply H.
+  apply Ropp_0_gt_lt_contravar; apply H.
 Qed.
 
-(* Rabsolu is derivable for all x <> 0 *)
+(** Rabsolu is derivable for all x <> 0 *)
 Lemma Rderivable_pt_abs : forall x:R, x <> 0 -> derivable_pt Rabs x.
-intros.
-case (total_order_T x 0); intro.
-elim s; intro.
-unfold derivable_pt in |- *; apply existT with (-1).
-apply (Rabs_derive_2 x a).
-elim H; exact b.
-unfold derivable_pt in |- *; apply existT with 1.
-apply (Rabs_derive_1 x r).
+Proof.
+  intros.
+  case (total_order_T x 0); intro.
+  elim s; intro.
+  unfold derivable_pt in |- *; apply existT with (-1).
+  apply (Rabs_derive_2 x a).
+  elim H; exact b.
+  unfold derivable_pt in |- *; apply existT with 1.
+  apply (Rabs_derive_1 x r).
 Qed.
 
-(* Rabsolu is continuous for all x *)
+(** Rabsolu is continuous for all x *)
 Lemma Rcontinuity_abs : continuity Rabs.
-unfold continuity in |- *; intro.
-case (Req_dec x 0); intro.
-unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; unfold R_dist in |- *; intros; exists eps; 
- split.
-apply H0.
-intros; rewrite H; rewrite Rabs_R0; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; 
- intros; rewrite H in H3; unfold Rminus in H3; rewrite Ropp_0 in H3;
- rewrite Rplus_0_r in H3; apply H3.
-apply derivable_continuous_pt; apply (Rderivable_pt_abs x H).
+Proof.
+  unfold continuity in |- *; intro.
+  case (Req_dec x 0); intro.
+  unfold continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      simpl in |- *; unfold R_dist in |- *; intros; exists eps; 
+        split.
+  apply H0.
+  intros; rewrite H; rewrite Rabs_R0; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; 
+      intros; rewrite H in H3; unfold Rminus in H3; rewrite Ropp_0 in H3;
+        rewrite Rplus_0_r in H3; apply H3.
+  apply derivable_continuous_pt; apply (Rderivable_pt_abs x H).
 Qed.
 
-(* Finite sums : Sum a_k x^k *)
+(** Finite sums : Sum a_k x^k *)
 Lemma continuity_finite_sum :
- forall (An:nat -> R) (N:nat),
-   continuity (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N).
-intros; unfold continuity in |- *; intro.
-induction  N as [| N HrecN].
-simpl in |- *.
-apply continuity_pt_const.
-unfold constant in |- *; intros; reflexivity.
-replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with
- ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) +
-  (fun y:R => (An (S N) * y ^ S N)%R))%F.
-apply continuity_pt_plus.
-apply HrecN.
-replace (fun y:R => An (S N) * y ^ S N) with
- (mult_real_fct (An (S N)) (fun y:R => y ^ S N)).
-apply continuity_pt_scal.
-apply derivable_continuous_pt.
-apply derivable_pt_pow.
-reflexivity.
-reflexivity.
+  forall (An:nat -> R) (N:nat),
+    continuity (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N).
+Proof.
+  intros; unfold continuity in |- *; intro.
+  induction  N as [| N HrecN].
+  simpl in |- *.
+  apply continuity_pt_const.
+  unfold constant in |- *; intros; reflexivity.
+  replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with
+  ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) +
+    (fun y:R => (An (S N) * y ^ S N)%R))%F.
+  apply continuity_pt_plus.
+  apply HrecN.
+  replace (fun y:R => An (S N) * y ^ S N) with
+  (mult_real_fct (An (S N)) (fun y:R => y ^ S N)).
+  apply continuity_pt_scal.
+  apply derivable_continuous_pt.
+  apply derivable_pt_pow.
+  reflexivity.
+  reflexivity.
 Qed.
 
 Lemma derivable_pt_lim_fs :
- forall (An:nat -> R) (x:R) (N:nat),
-   (0 < N)%nat ->
-   derivable_pt_lim (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x
-     (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N)).
-intros; induction  N as [| N HrecN].
-elim (lt_irrefl _ H).
-cut (N = 0%nat \/ (0 < N)%nat).
-intro; elim H0; intro.
-rewrite H1.
-simpl in |- *.
-replace (fun y:R => An 0%nat * 1 + An 1%nat * (y * 1)) with
- (fct_cte (An 0%nat * 1) + mult_real_fct (An 1%nat) (id * fct_cte 1))%F.
-replace (1 * An 1%nat * 1) with (0 + An 1%nat * (1 * fct_cte 1 x + id x * 0)).
-apply derivable_pt_lim_plus.
-apply derivable_pt_lim_const.
-apply derivable_pt_lim_scal.
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_const.
-unfold fct_cte, id in |- *; ring.
-reflexivity.
-replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with
- ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) +
-  (fun y:R => (An (S N) * y ^ S N)%R))%F.
-replace (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N)))
- with
- (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N) +
-  An (S N) * (INR (S (pred (S N))) * x ^ pred (S N))).
-apply derivable_pt_lim_plus.
-apply HrecN.
-assumption.
-replace (fun y:R => An (S N) * y ^ S N) with
- (mult_real_fct (An (S N)) (fun y:R => y ^ S N)).
-apply derivable_pt_lim_scal.
-replace (pred (S N)) with N; [ idtac | reflexivity ].
-pattern N at 3 in |- *; replace N with (pred (S N)).
-apply derivable_pt_lim_pow.
-reflexivity.
-reflexivity.
-cut (pred (S N) = S (pred N)).
-intro; rewrite H2.
-rewrite tech5.
-apply Rplus_eq_compat_l.
-rewrite <- H2.
-replace (pred (S N)) with N; [ idtac | reflexivity ].
-ring.
-simpl in |- *.
-apply S_pred with 0%nat; assumption.
-unfold plus_fct in |- *.
-simpl in |- *; reflexivity.
-inversion H.
-left; reflexivity.
-right; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
+  forall (An:nat -> R) (x:R) (N:nat),
+    (0 < N)%nat ->
+    derivable_pt_lim (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x
+    (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N)).
+Proof.
+  intros; induction  N as [| N HrecN].
+  elim (lt_irrefl _ H).
+  cut (N = 0%nat \/ (0 < N)%nat).
+  intro; elim H0; intro.
+  rewrite H1.
+  simpl in |- *.
+  replace (fun y:R => An 0%nat * 1 + An 1%nat * (y * 1)) with
+  (fct_cte (An 0%nat * 1) + mult_real_fct (An 1%nat) (id * fct_cte 1))%F.
+  replace (1 * An 1%nat * 1) with (0 + An 1%nat * (1 * fct_cte 1 x + id x * 0)).
+  apply derivable_pt_lim_plus.
+  apply derivable_pt_lim_const.
+  apply derivable_pt_lim_scal.
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_const.
+  unfold fct_cte, id in |- *; ring.
+  reflexivity.
+  replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with
+  ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) +
+    (fun y:R => (An (S N) * y ^ S N)%R))%F.
+  replace (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N)))
+    with
+      (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N) +
+        An (S N) * (INR (S (pred (S N))) * x ^ pred (S N))).
+  apply derivable_pt_lim_plus.
+  apply HrecN.
+  assumption.
+  replace (fun y:R => An (S N) * y ^ S N) with
+  (mult_real_fct (An (S N)) (fun y:R => y ^ S N)).
+  apply derivable_pt_lim_scal.
+  replace (pred (S N)) with N; [ idtac | reflexivity ].
+  pattern N at 3 in |- *; replace N with (pred (S N)).
+  apply derivable_pt_lim_pow.
+  reflexivity.
+  reflexivity.
+  cut (pred (S N) = S (pred N)).
+  intro; rewrite H2.
+  rewrite tech5.
+  apply Rplus_eq_compat_l.
+  rewrite <- H2.
+  replace (pred (S N)) with N; [ idtac | reflexivity ].
+  ring.
+  simpl in |- *.
+  apply S_pred with 0%nat; assumption.
+  unfold plus_fct in |- *.
+  simpl in |- *; reflexivity.
+  inversion H.
+  left; reflexivity.
+  right; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
 Qed.
 
 Lemma derivable_pt_lim_finite_sum :
- forall (An:nat -> R) (x:R) (N:nat),
-   derivable_pt_lim (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x
-     match N with
-     | O => 0
-     | _ => sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N)
-     end.
-intros.
-induction  N as [| N HrecN].
-simpl in |- *.
-rewrite Rmult_1_r.
-replace (fun _:R => An 0%nat) with (fct_cte (An 0%nat));
- [ apply derivable_pt_lim_const | reflexivity ].
-apply derivable_pt_lim_fs; apply lt_O_Sn.
+  forall (An:nat -> R) (x:R) (N:nat),
+    derivable_pt_lim (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x
+    match N with
+      | O => 0
+      | _ => sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred N)
+    end.
+Proof.
+  intros.
+  induction  N as [| N HrecN].
+  simpl in |- *.
+  rewrite Rmult_1_r.
+  replace (fun _:R => An 0%nat) with (fct_cte (An 0%nat));
+  [ apply derivable_pt_lim_const | reflexivity ].
+  apply derivable_pt_lim_fs; apply lt_O_Sn.
 Qed.
 
 Lemma derivable_pt_finite_sum :
- forall (An:nat -> R) (N:nat) (x:R),
-   derivable_pt (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x.
-intros.
-unfold derivable_pt in |- *.
-assert (H := derivable_pt_lim_finite_sum An x N).
-induction  N as [| N HrecN].
-apply existT with 0; apply H.
-apply existT with
- (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); 
- apply H.
+  forall (An:nat -> R) (N:nat) (x:R),
+    derivable_pt (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x.
+Proof.
+  intros.
+  unfold derivable_pt in |- *.
+  assert (H := derivable_pt_lim_finite_sum An x N).
+  induction  N as [| N HrecN].
+  apply existT with 0; apply H.
+  apply existT with
+    (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); 
+    apply H.
 Qed.
 
 Lemma derivable_finite_sum :
- forall (An:nat -> R) (N:nat),
-   derivable (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N).
-intros; unfold derivable in |- *; intro; apply derivable_pt_finite_sum.
+  forall (An:nat -> R) (N:nat),
+    derivable (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N).
+Proof.
+  intros; unfold derivable in |- *; intro; apply derivable_pt_finite_sum.
 Qed.
 
-(* Regularity of hyperbolic functions *)
+(** Regularity of hyperbolic functions *)
 Lemma derivable_pt_lim_cosh : forall x:R, derivable_pt_lim cosh x (sinh x).
-intro.
-unfold cosh, sinh in |- *; unfold Rdiv in |- *.
-replace (fun x0:R => (exp x0 + exp (- x0)) * / 2) with
- ((exp + comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
-replace ((exp x - exp (- x)) * / 2) with
- ((exp x + exp (- x) * -1) * fct_cte (/ 2) x +
-  (exp + comp exp (- id))%F x * 0). 
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_plus.
-apply derivable_pt_lim_exp.
-apply derivable_pt_lim_comp.
-apply derivable_pt_lim_opp.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_exp.
-apply derivable_pt_lim_const.
-unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte in |- *; ring.
+Proof.
+  intro.
+  unfold cosh, sinh in |- *; unfold Rdiv in |- *.
+  replace (fun x0:R => (exp x0 + exp (- x0)) * / 2) with
+  ((exp + comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
+  replace ((exp x - exp (- x)) * / 2) with
+  ((exp x + exp (- x) * -1) * fct_cte (/ 2) x +
+    (exp + comp exp (- id))%F x * 0). 
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_plus.
+  apply derivable_pt_lim_exp.
+  apply derivable_pt_lim_comp.
+  apply derivable_pt_lim_opp.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_exp.
+  apply derivable_pt_lim_const.
+  unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte in |- *; ring.
 Qed.
 
 Lemma derivable_pt_lim_sinh : forall x:R, derivable_pt_lim sinh x (cosh x).
-intro.
-unfold cosh, sinh in |- *; unfold Rdiv in |- *.
-replace (fun x0:R => (exp x0 - exp (- x0)) * / 2) with
- ((exp - comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
-replace ((exp x + exp (- x)) * / 2) with
- ((exp x - exp (- x) * -1) * fct_cte (/ 2) x +
-  (exp - comp exp (- id))%F x * 0). 
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_minus.
-apply derivable_pt_lim_exp.
-apply derivable_pt_lim_comp.
-apply derivable_pt_lim_opp.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_exp.
-apply derivable_pt_lim_const.
-unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte in |- *; ring.
+Proof.
+  intro.
+  unfold cosh, sinh in |- *; unfold Rdiv in |- *.
+  replace (fun x0:R => (exp x0 - exp (- x0)) * / 2) with
+  ((exp - comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
+  replace ((exp x + exp (- x)) * / 2) with
+  ((exp x - exp (- x) * -1) * fct_cte (/ 2) x +
+    (exp - comp exp (- id))%F x * 0). 
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_minus.
+  apply derivable_pt_lim_exp.
+  apply derivable_pt_lim_comp.
+  apply derivable_pt_lim_opp.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_exp.
+  apply derivable_pt_lim_const.
+  unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte in |- *; ring.
 Qed.
 
 Lemma derivable_pt_exp : forall x:R, derivable_pt exp x.
-intro.
-unfold derivable_pt in |- *.
-apply existT with (exp x).
-apply derivable_pt_lim_exp.
+Proof.
+  intro.
+  unfold derivable_pt in |- *.
+  apply existT with (exp x).
+  apply derivable_pt_lim_exp.
 Qed.
 
 Lemma derivable_pt_cosh : forall x:R, derivable_pt cosh x.
-intro.
-unfold derivable_pt in |- *.
-apply existT with (sinh x).
-apply derivable_pt_lim_cosh.
+Proof.
+  intro.
+  unfold derivable_pt in |- *.
+  apply existT with (sinh x).
+  apply derivable_pt_lim_cosh.
 Qed.
 
 Lemma derivable_pt_sinh : forall x:R, derivable_pt sinh x.
-intro.
-unfold derivable_pt in |- *.
-apply existT with (cosh x).
-apply derivable_pt_lim_sinh.
+Proof.
+  intro.
+  unfold derivable_pt in |- *.
+  apply existT with (cosh x).
+  apply derivable_pt_lim_sinh.
 Qed.
 
 Lemma derivable_exp : derivable exp.
-unfold derivable in |- *; apply derivable_pt_exp.
+Proof.
+  unfold derivable in |- *; apply derivable_pt_exp.
 Qed.
 
 Lemma derivable_cosh : derivable cosh.
-unfold derivable in |- *; apply derivable_pt_cosh.
+Proof.
+  unfold derivable in |- *; apply derivable_pt_cosh.
 Qed.
 
 Lemma derivable_sinh : derivable sinh.
-unfold derivable in |- *; apply derivable_pt_sinh.
+Proof.
+  unfold derivable in |- *; apply derivable_pt_sinh.
 Qed.
 
 Lemma derive_pt_exp :
- forall x:R, derive_pt exp x (derivable_pt_exp x) = exp x.
-intro; apply derive_pt_eq_0.
-apply derivable_pt_lim_exp.
+  forall x:R, derive_pt exp x (derivable_pt_exp x) = exp x.
+Proof.
+  intro; apply derive_pt_eq_0.
+  apply derivable_pt_lim_exp.
 Qed.
 
 Lemma derive_pt_cosh :
- forall x:R, derive_pt cosh x (derivable_pt_cosh x) = sinh x.
-intro; apply derive_pt_eq_0.
-apply derivable_pt_lim_cosh.
+  forall x:R, derive_pt cosh x (derivable_pt_cosh x) = sinh x.
+Proof.
+  intro; apply derive_pt_eq_0.
+  apply derivable_pt_lim_cosh.
 Qed.
 
 Lemma derive_pt_sinh :
- forall x:R, derive_pt sinh x (derivable_pt_sinh x) = cosh x.
-intro; apply derive_pt_eq_0.
-apply derivable_pt_lim_sinh.
-Qed.
\ No newline at end of file
+  forall x:R, derive_pt sinh x (derivable_pt_sinh x) = cosh x.
+Proof.
+  intro; apply derive_pt_eq_0.
+  apply derivable_pt_lim_sinh.
+Qed.
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index bef9f89c..aaea59f4 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Raxioms.v,v 1.20.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Raxioms.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (*********************************************************)
 (**    Axiomatisation of the classical reals             *)
@@ -17,11 +17,11 @@ Require Export Rdefinitions.
 Open Local Scope R_scope.
 
 (*********************************************************)
-(*               Field axioms                            *)
+(** *            Field axioms                            *)
 (*********************************************************)
 
 (*********************************************************)
-(**      Addition                                        *)
+(** **   Addition                                        *)
 (*********************************************************)
 
 (**********)
@@ -41,7 +41,7 @@ Axiom Rplus_0_l : forall r:R, 0 + r = r.
 Hint Resolve Rplus_0_l: real.
 
 (***********************************************************)       
-(**       Multiplication                                   *)
+(** **    Multiplication                                   *)
 (***********************************************************)
 
 (**********)
@@ -65,7 +65,7 @@ Axiom R1_neq_R0 : 1 <> 0.
 Hint Resolve R1_neq_R0: real.
 
 (*********************************************************)
-(**      Distributivity                                  *)
+(** **   Distributivity                                  *)
 (*********************************************************)
 
 (**********)
@@ -74,17 +74,17 @@ Axiom
 Hint Resolve Rmult_plus_distr_l: real v62.
 
 (*********************************************************)
-(**      Order axioms                                    *)
+(** *    Order axioms                                    *)
 (*********************************************************)
 (*********************************************************)
-(**      Total Order                                     *)
+(** **   Total Order                                     *)
 (*********************************************************)
 
 (**********)
 Axiom total_order_T : forall r1 r2:R, {r1 < r2} + {r1 = r2} + {r1 > r2}.
 
 (*********************************************************)
-(**      Lower                                           *)
+(** **   Lower                                           *)
 (*********************************************************)
 
 (**********)
@@ -103,11 +103,11 @@ Axiom
 Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real.
 
 (**********************************************************) 
-(**      Injection from N to R                            *)
+(** *    Injection from N to R                            *)
 (**********************************************************)
 
 (**********)
-Fixpoint INR (n:nat) : R :=
+Boxed Fixpoint INR (n:nat) : R :=
   match n with
   | O => 0
   | S O => 1
@@ -117,7 +117,7 @@ Arguments Scope INR [nat_scope].
 
 
 (**********************************************************) 
-(**      Injection from [Z] to [R]                        *)
+(** *    Injection from [Z] to [R]                        *)
 (**********************************************************)
 
 (**********)
@@ -130,14 +130,14 @@ Definition IZR (z:Z) : R :=
 Arguments Scope IZR [Z_scope].
 
 (**********************************************************)
-(**      [R] Archimedian                                  *)
+(** *    [R] Archimedian                                  *)
 (**********************************************************)
 
 (**********)
 Axiom archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1.
 
 (**********************************************************)
-(**      [R] Complete                                     *)
+(** *    [R] Complete                                     *)
 (**********************************************************)
 
 (**********)
diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v
index 773819a2..5bee0f82 100644
--- a/theories/Reals/Rbase.v
+++ b/theories/Reals/Rbase.v
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rbase.v,v 1.39.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Rbase.v 9178 2006-09-26 11:18:22Z barras $ i*)
 
 Require Export Rdefinitions.
 Require Export Raxioms.
 Require Export RIneq.
-Require Export DiscrR.
\ No newline at end of file
+Require Export DiscrR.
diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
index 49ba48f7..98bd607b 100644
--- a/theories/Reals/Rbasic_fun.v
+++ b/theories/Reals/Rbasic_fun.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rbasic_fun.v,v 1.22.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Rbasic_fun.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (*********************************************************)
 (**          Complements for the real numbers            *)
@@ -20,451 +20,489 @@ Require Import Fourier. Open Local Scope R_scope.
 Implicit Type r : R.
 
 (*******************************)
-(**          Rmin              *)
+(** *        Rmin              *)
 (*******************************)
 
 (*********)
 Definition Rmin (x y:R) : R :=
   match Rle_dec x y with
-  | left _ => x
-  | right _ => y
+    | left _ => x
+    | right _ => y
   end.
 
 (*********)
 Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r.
-intros r1 r2 r; unfold Rmin in |- *; case (Rle_dec r1 r2); intros.
-split.
-assumption.
-unfold Rgt in |- *; unfold Rgt in H; exact (Rlt_le_trans r r1 r2 H r0).
-split.
-generalize (Rnot_le_lt r1 r2 n); intro; exact (Rgt_trans r1 r2 r H0 H).
-assumption.
+Proof.
+  intros r1 r2 r; unfold Rmin in |- *; case (Rle_dec r1 r2); intros.
+  split.
+  assumption.
+  unfold Rgt in |- *; unfold Rgt in H; exact (Rlt_le_trans r r1 r2 H r0).
+  split.
+  generalize (Rnot_le_lt r1 r2 n); intro; exact (Rgt_trans r1 r2 r H0 H).
+  assumption.
 Qed.
 
 (*********)
 Lemma Rmin_Rgt_r : forall r1 r2 r, r1 > r /\ r2 > r -> Rmin r1 r2 > r.
-intros; unfold Rmin in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
- assumption.
+Proof.
+  intros; unfold Rmin in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
+    assumption.
 Qed.
 
 (*********)
 Lemma Rmin_Rgt : forall r1 r2 r, Rmin r1 r2 > r <-> r1 > r /\ r2 > r.
-intros; split.
-exact (Rmin_Rgt_l r1 r2 r).
-exact (Rmin_Rgt_r r1 r2 r).
+Proof.
+  intros; split.
+  exact (Rmin_Rgt_l r1 r2 r).
+  exact (Rmin_Rgt_r r1 r2 r).
 Qed.
 
 (*********)
 Lemma Rmin_l : forall x y:R, Rmin x y <= x.
-intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
- [ right; reflexivity | auto with real ].
+Proof.
+  intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
+    [ right; reflexivity | auto with real ].
 Qed.
- 
+
 (*********)
 Lemma Rmin_r : forall x y:R, Rmin x y <= y.
-intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
- [ assumption | auto with real ].
+Proof.
+  intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
+    [ assumption | auto with real ].
 Qed.
 
 (*********)
 Lemma Rmin_comm : forall a b:R, Rmin a b = Rmin b a.
-intros; unfold Rmin in |- *; case (Rle_dec a b); case (Rle_dec b a); intros;
- try reflexivity || (apply Rle_antisym; assumption || auto with real).
+Proof.
+  intros; unfold Rmin in |- *; case (Rle_dec a b); case (Rle_dec b a); intros;
+    try reflexivity || (apply Rle_antisym; assumption || auto with real).
 Qed.
 
 (*********)
 Lemma Rmin_stable_in_posreal : forall x y:posreal, 0 < Rmin x y.
-intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ].
+Proof.
+  intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ].
 Qed.
 
 (*******************************)
-(**          Rmax              *)
+(** *        Rmax              *)
 (*******************************)
 
 (*********)
 Definition Rmax (x y:R) : R :=
   match Rle_dec x y with
-  | left _ => y
-  | right _ => x
+    | left _ => y
+    | right _ => x
   end.
 
 (*********)
 Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
-intros; split.
-unfold Rmax in |- *; case (Rle_dec r1 r2); intros; auto.
-intro; unfold Rmax in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
- auto.
-apply (Rle_trans r r1 r2); auto.
-generalize (Rnot_le_lt r1 r2 n); clear n; intro; unfold Rgt in H0;
- apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
+Proof.
+  intros; split.
+  unfold Rmax in |- *; case (Rle_dec r1 r2); intros; auto.
+  intro; unfold Rmax in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
+    auto.
+  apply (Rle_trans r r1 r2); auto.
+  generalize (Rnot_le_lt r1 r2 n); clear n; intro; unfold Rgt in H0;
+    apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
 Qed.
 
 Lemma RmaxLess1 : forall r1 r2, r1 <= Rmax r1 r2.
-intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real.
+Proof.
+  intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real.
 Qed.
- 
+
 Lemma RmaxLess2 : forall r1 r2, r2 <= Rmax r1 r2.
-intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real.
+Proof.
+  intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real.
 Qed.
- 
-Lemma RmaxSym : forall p q:R, Rmax p q = Rmax q p.
-intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto;
- intros H1 H2; apply Rle_antisym; auto with real.
+
+Lemma Rmax_comm : forall p q:R, Rmax p q = Rmax q p.
+Proof.
+  intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto;
+    intros H1 H2; apply Rle_antisym; auto with real.
 Qed.
 
+Notation RmaxSym := Rmax_comm (only parsing).
+
 Lemma RmaxRmult :
- forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
-intros p q r H; unfold Rmax in |- *.
-case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto.
-case H; intros E1.
-case H1; auto with real.
-rewrite <- E1; repeat rewrite Rmult_0_l; auto.
-case H; intros E1.
-case H2; auto with real.
-apply Rmult_le_reg_l with (r := r); auto.
-rewrite <- E1; repeat rewrite Rmult_0_l; auto.
+  forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
+Proof.
+  intros p q r H; unfold Rmax in |- *.
+  case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto.
+  case H; intros E1.
+  case H1; auto with real.
+  rewrite <- E1; repeat rewrite Rmult_0_l; auto.
+  case H; intros E1.
+  case H2; auto with real.
+  apply Rmult_le_reg_l with (r := r); auto.
+  rewrite <- E1; repeat rewrite Rmult_0_l; auto.
 Qed.
 
 Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0.
-intros; unfold Rmax in |- *; case (Rle_dec x y); intro;
- [ apply (cond_neg y) | apply (cond_neg x) ].
+Proof.
+  intros; unfold Rmax in |- *; case (Rle_dec x y); intro;
+    [ apply (cond_neg y) | apply (cond_neg x) ].
 Qed.
 
 (*******************************)
-(**          Rabsolu           *)
+(** *        Rabsolu           *)
 (*******************************)
 
 (*********)
 Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}. 
-intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X.
-right; apply (Rle_ge 0 r a).
-left; fold (0 > r) in |- *; apply (Rnot_le_lt 0 r b).
+Proof.
+  intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X.
+  right; apply (Rle_ge 0 r a).
+  left; fold (0 > r) in |- *; apply (Rnot_le_lt 0 r b).
 Qed.
 
 (*********)
 Definition Rabs r : R :=
   match Rcase_abs r with
-  | left _ => - r
-  | right _ => r
+    | left _ => - r
+    | right _ => r
   end.
 
 (*********)
 Lemma Rabs_R0 : Rabs 0 = 0.
-unfold Rabs in |- *; case (Rcase_abs 0); auto; intro.
-generalize (Rlt_irrefl 0); intro; elimtype False; auto.
+Proof.
+  unfold Rabs in |- *; case (Rcase_abs 0); auto; intro.
+  generalize (Rlt_irrefl 0); intro; elimtype False; auto.
 Qed.
 
 Lemma Rabs_R1 : Rabs 1 = 1.
+Proof.
 unfold Rabs in |- *; case (Rcase_abs 1); auto with real.
 intros H; absurd (1 < 0); auto with real.
 Qed.
 
 (*********)
 Lemma Rabs_no_R0 : forall r, r <> 0 -> Rabs r <> 0.
-intros; unfold Rabs in |- *; case (Rcase_abs r); intro; auto.
-apply Ropp_neq_0_compat; auto.
+Proof.
+  intros; unfold Rabs in |- *; case (Rcase_abs r); intro; auto.
+  apply Ropp_neq_0_compat; auto.
 Qed.
 
 (*********)
 Lemma Rabs_left : forall r, r < 0 -> Rabs r = - r.
-intros; unfold Rabs in |- *; case (Rcase_abs r); trivial; intro;
- absurd (r >= 0).
-exact (Rlt_not_ge r 0 H).
-assumption.
+Proof.
+  intros; unfold Rabs in |- *; case (Rcase_abs r); trivial; intro;
+    absurd (r >= 0).
+  exact (Rlt_not_ge r 0 H).
+  assumption.
 Qed.
 
 (*********)
 Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r.
-intros; unfold Rabs in |- *; case (Rcase_abs r); intro.
-absurd (r >= 0).
-exact (Rlt_not_ge r 0 r0).
-assumption.
-trivial.
+Proof.
+  intros; unfold Rabs in |- *; case (Rcase_abs r); intro.
+  absurd (r >= 0).
+  exact (Rlt_not_ge r 0 r0).
+  assumption.
+  trivial.
 Qed.
 
 Lemma Rabs_left1 : forall a:R, a <= 0 -> Rabs a = - a.
-intros a H; case H; intros H1.
-apply Rabs_left; auto.
-rewrite H1; simpl in |- *; rewrite Rabs_right; auto with real.
+Proof.
+  intros a H; case H; intros H1.
+  apply Rabs_left; auto.
+  rewrite H1; simpl in |- *; rewrite Rabs_right; auto with real.
 Qed.
 
 (*********)
 Lemma Rabs_pos : forall x:R, 0 <= Rabs x.
-intros; unfold Rabs in |- *; case (Rcase_abs x); intro.
-generalize (Ropp_lt_gt_contravar x 0 r); intro; unfold Rgt in H;
- rewrite Ropp_0 in H; unfold Rle in |- *; left; assumption.
-apply Rge_le; assumption.
+Proof.
+  intros; unfold Rabs in |- *; case (Rcase_abs x); intro.
+  generalize (Ropp_lt_gt_contravar x 0 r); intro; unfold Rgt in H;
+    rewrite Ropp_0 in H; unfold Rle in |- *; left; assumption.
+  apply Rge_le; assumption.
 Qed.
 
 Lemma RRle_abs : forall x:R, x <= Rabs x.
-intro; unfold Rabs in |- *; case (Rcase_abs x); intros; fourier.
+Proof.
+  intro; unfold Rabs in |- *; case (Rcase_abs x); intros; fourier.
 Qed.
 
 (*********)
 Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x.
-intros; unfold Rabs in |- *; case (Rcase_abs x); intro;
- [ generalize (Rgt_not_le 0 x r); intro; elimtype False; auto | trivial ].
+Proof.
+  intros; unfold Rabs in |- *; case (Rcase_abs x); intro;
+    [ generalize (Rgt_not_le 0 x r); intro; elimtype False; auto | trivial ].
 Qed.
 
 (*********)
 Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x.
-intro; apply (Rabs_pos_eq (Rabs x) (Rabs_pos x)).
+Proof.
+  intro; apply (Rabs_pos_eq (Rabs x) (Rabs_pos x)).
 Qed.
 
 (*********)
 Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x.
-intros; generalize (Rabs_pos x); intro; unfold Rle in H0; elim H0; intro;
- auto.
-elimtype False; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *;
- case (Rcase_abs x); intros; auto.
-clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0);
- rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x); 
- trivial.
+Proof.
+  intros; generalize (Rabs_pos x); intro; unfold Rle in H0; elim H0; intro;
+    auto.
+  elimtype False; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *;
+    case (Rcase_abs x); intros; auto.
+  clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0);
+    rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x); 
+      trivial.
 Qed.
 
 (*********)
 Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x).
-intros; unfold Rabs in |- *; case (Rcase_abs (x - y));
- case (Rcase_abs (y - x)); intros.
- generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros;
-  generalize (Rlt_asym x y H); intro; elimtype False; 
-  auto.
-rewrite (Ropp_minus_distr x y); trivial.
-rewrite (Ropp_minus_distr y x); trivial.
-unfold Rge in r, r0; elim r; elim r0; intros; clear r r0.
-generalize (Ropp_lt_gt_0_contravar (x - y) H); rewrite (Ropp_minus_distr x y);
- intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0); 
- intro; elimtype False; auto.
-rewrite (Rminus_diag_uniq x y H); trivial.
-rewrite (Rminus_diag_uniq y x H0); trivial.
-rewrite (Rminus_diag_uniq y x H0); trivial.
+Proof.
+  intros; unfold Rabs in |- *; case (Rcase_abs (x - y));
+    case (Rcase_abs (y - x)); intros.
+  generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros;
+    generalize (Rlt_asym x y H); intro; elimtype False; 
+      auto.
+  rewrite (Ropp_minus_distr x y); trivial.
+  rewrite (Ropp_minus_distr y x); trivial.
+  unfold Rge in r, r0; elim r; elim r0; intros; clear r r0.
+  generalize (Ropp_lt_gt_0_contravar (x - y) H); rewrite (Ropp_minus_distr x y);
+    intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0); 
+      intro; elimtype False; auto.
+  rewrite (Rminus_diag_uniq x y H); trivial.
+  rewrite (Rminus_diag_uniq y x H0); trivial.
+  rewrite (Rminus_diag_uniq y x H0); trivial.
 Qed.
 
 (*********)
 Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.
-intros; unfold Rabs in |- *; case (Rcase_abs (x * y)); case (Rcase_abs x);
- case (Rcase_abs y); intros; auto.
-generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro;
- rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1); 
- intro; unfold Rgt in H; elimtype False; rewrite (Rmult_comm y x) in H; 
- auto.
-rewrite (Ropp_mult_distr_l_reverse x y); trivial. 
-rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x);
- rewrite (Rmult_comm x y); trivial.
-unfold Rge in r, r0; elim r; elim r0; clear r r0; intros; unfold Rgt in H, H0.
-generalize (Rmult_lt_compat_l x 0 y H H0); intro; rewrite (Rmult_0_r x) in H1;
- generalize (Rlt_asym (x * y) 0 r1); intro; elimtype False; 
- auto.
-rewrite H in r1; rewrite (Rmult_0_l y) in r1; generalize (Rlt_irrefl 0);
- intro; elimtype False; auto.
-rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
- intro; elimtype False; auto.
-rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
- intro; elimtype False; auto.
-rewrite (Rmult_opp_opp x y); trivial.
-unfold Rge in r, r1; elim r; elim r1; clear r r1; intros; unfold Rgt in H0, H.
-generalize (Rmult_lt_compat_l y x 0 H0 r0); intro;
- rewrite (Rmult_0_r y) in H1; rewrite (Rmult_comm y x) in H1;
- generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; 
- auto.
-generalize (Rlt_dichotomy_converse x 0 (or_introl (x > 0) r0));
- generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0)); 
- intros; generalize (Rmult_integral x y H); intro; 
- elim H3; intro; elimtype False; auto.  
-rewrite H0 in H; rewrite (Rmult_0_r x) in H; unfold Rgt in H;
- generalize (Rlt_irrefl 0); intro; elimtype False; 
- auto.
-rewrite H0; rewrite (Rmult_0_r x); rewrite (Rmult_0_r (- x)); trivial.
-unfold Rge in r0, r1; elim r0; elim r1; clear r0 r1; intros;
- unfold Rgt in H0, H.
-generalize (Rmult_lt_compat_l x y 0 H0 r); intro; rewrite (Rmult_0_r x) in H1;
- generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; 
- auto.
-generalize (Rlt_dichotomy_converse y 0 (or_introl (y > 0) r));
- generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0)); 
- intros; generalize (Rmult_integral x y H); intro; 
- elim H3; intro; elimtype False; auto.  
-rewrite H0 in H; rewrite (Rmult_0_l y) in H; unfold Rgt in H;
- generalize (Rlt_irrefl 0); intro; elimtype False; 
- auto.
-rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- y)); trivial.
+Proof.
+  intros; unfold Rabs in |- *; case (Rcase_abs (x * y)); case (Rcase_abs x);
+    case (Rcase_abs y); intros; auto.
+  generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro;
+    rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1); 
+      intro; unfold Rgt in H; elimtype False; rewrite (Rmult_comm y x) in H; 
+        auto.
+  rewrite (Ropp_mult_distr_l_reverse x y); trivial. 
+  rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x);
+    rewrite (Rmult_comm x y); trivial.
+  unfold Rge in r, r0; elim r; elim r0; clear r r0; intros; unfold Rgt in H, H0.
+  generalize (Rmult_lt_compat_l x 0 y H H0); intro; rewrite (Rmult_0_r x) in H1;
+    generalize (Rlt_asym (x * y) 0 r1); intro; elimtype False; 
+      auto.
+  rewrite H in r1; rewrite (Rmult_0_l y) in r1; generalize (Rlt_irrefl 0);
+    intro; elimtype False; auto.
+  rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
+    intro; elimtype False; auto.
+  rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
+    intro; elimtype False; auto.
+  rewrite (Rmult_opp_opp x y); trivial.
+  unfold Rge in r, r1; elim r; elim r1; clear r r1; intros; unfold Rgt in H0, H.
+  generalize (Rmult_lt_compat_l y x 0 H0 r0); intro;
+    rewrite (Rmult_0_r y) in H1; rewrite (Rmult_comm y x) in H1;
+      generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; 
+        auto.
+  generalize (Rlt_dichotomy_converse x 0 (or_introl (x > 0) r0));
+    generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0)); 
+      intros; generalize (Rmult_integral x y H); intro; 
+        elim H3; intro; elimtype False; auto.  
+  rewrite H0 in H; rewrite (Rmult_0_r x) in H; unfold Rgt in H;
+    generalize (Rlt_irrefl 0); intro; elimtype False; 
+      auto.
+  rewrite H0; rewrite (Rmult_0_r x); rewrite (Rmult_0_r (- x)); trivial.
+  unfold Rge in r0, r1; elim r0; elim r1; clear r0 r1; intros;
+    unfold Rgt in H0, H.
+  generalize (Rmult_lt_compat_l x y 0 H0 r); intro; rewrite (Rmult_0_r x) in H1;
+    generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; 
+      auto.
+  generalize (Rlt_dichotomy_converse y 0 (or_introl (y > 0) r));
+    generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0)); 
+      intros; generalize (Rmult_integral x y H); intro; 
+        elim H3; intro; elimtype False; auto.  
+  rewrite H0 in H; rewrite (Rmult_0_l y) in H; unfold Rgt in H;
+    generalize (Rlt_irrefl 0); intro; elimtype False; 
+      auto.
+  rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- y)); trivial.
 Qed.
 
 (*********)
 Lemma Rabs_Rinv : forall r, r <> 0 -> Rabs (/ r) = / Rabs r.
-intro; unfold Rabs in |- *; case (Rcase_abs r); case (Rcase_abs (/ r)); auto;
- intros.
-apply Ropp_inv_permute; auto.
-generalize (Rinv_lt_0_compat r r1); intro; unfold Rge in r0; elim r0; intros.
-unfold Rgt in H1; generalize (Rlt_asym 0 (/ r) H1); intro; elimtype False;
- auto.
-generalize (Rlt_dichotomy_converse (/ r) 0 (or_introl (/ r > 0) H0)); intro;
- elimtype False; auto.
-unfold Rge in r1; elim r1; clear r1; intro.
-unfold Rgt in H0; generalize (Rlt_asym 0 (/ r) (Rinv_0_lt_compat r H0));
- intro; elimtype False; auto.
-elimtype False; auto.
+Proof.
+  intro; unfold Rabs in |- *; case (Rcase_abs r); case (Rcase_abs (/ r)); auto;
+    intros.
+  apply Ropp_inv_permute; auto.
+  generalize (Rinv_lt_0_compat r r1); intro; unfold Rge in r0; elim r0; intros.
+  unfold Rgt in H1; generalize (Rlt_asym 0 (/ r) H1); intro; elimtype False;
+    auto.
+  generalize (Rlt_dichotomy_converse (/ r) 0 (or_introl (/ r > 0) H0)); intro;
+    elimtype False; auto.
+  unfold Rge in r1; elim r1; clear r1; intro.
+  unfold Rgt in H0; generalize (Rlt_asym 0 (/ r) (Rinv_0_lt_compat r H0));
+    intro; elimtype False; auto.
+  elimtype False; auto.
 Qed. 
 
 Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
-intro; cut (- x = -1 * x).
-intros; rewrite H.
-rewrite Rabs_mult.
-cut (Rabs (-1) = 1).
-intros; rewrite H0.
-ring.
-unfold Rabs in |- *; case (Rcase_abs (-1)).
-intro; ring.
-intro H0; generalize (Rge_le (-1) 0 H0); intros.
-generalize (Ropp_le_ge_contravar 0 (-1) H1).
-rewrite Ropp_involutive; rewrite Ropp_0.
-intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2);
- intro; elimtype False; auto.  
-ring.
+Proof.
+  intro; cut (- x = -1 * x).
+  intros; rewrite H.
+  rewrite Rabs_mult.
+  cut (Rabs (-1) = 1).
+  intros; rewrite H0.
+  ring.
+  unfold Rabs in |- *; case (Rcase_abs (-1)).
+  intro; ring.
+  intro H0; generalize (Rge_le (-1) 0 H0); intros.
+  generalize (Ropp_le_ge_contravar 0 (-1) H1).
+  rewrite Ropp_involutive; rewrite Ropp_0.
+  intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2);
+    intro; elimtype False; auto.  
+  ring.
 Qed.
 
 (*********)
 Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
-intros a b; unfold Rabs in |- *; case (Rcase_abs (a + b)); case (Rcase_abs a);
- case (Rcase_abs b); intros.
-apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b);
- reflexivity.
+Proof.
+  intros a b; unfold Rabs in |- *; case (Rcase_abs (a + b)); case (Rcase_abs a);
+    case (Rcase_abs b); intros.
+  apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b);
+    reflexivity.
 (**)
-rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
- unfold Rle in |- *; unfold Rge in r; elim r; intro.
-left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
- elim (Rplus_ne (- b)); intros v w; rewrite v in H0; 
- clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
-right; rewrite H; apply Ropp_0.
+  rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
+    unfold Rle in |- *; unfold Rge in r; elim r; intro.
+  left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
+    elim (Rplus_ne (- b)); intros v w; rewrite v in H0; 
+      clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
+  right; rewrite H; apply Ropp_0.
 (**)
-rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b));
- rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
- unfold Rle in |- *; unfold Rge in r0; elim r0; intro.
-left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
- elim (Rplus_ne (- a)); intros v w; rewrite v in H0; 
- clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
-right; rewrite H; apply Ropp_0.
+  rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b));
+    rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
+      unfold Rle in |- *; unfold Rge in r0; elim r0; intro.
+  left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
+    elim (Rplus_ne (- a)); intros v w; rewrite v in H0; 
+      clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
+  right; rewrite H; apply Ropp_0.
 (**)
-elimtype False; generalize (Rplus_ge_compat_l a b 0 r); intro;
- elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
- generalize (Rge_trans (a + b) a 0 H r0); intro; clear H; 
- unfold Rge in H0; elim H0; intro; clear H0.
-unfold Rgt in H; generalize (Rlt_asym (a + b) 0 r1); intro; auto.
-absurd (a + b = 0); auto.
-apply (Rlt_dichotomy_converse (a + b) 0); left; assumption.
+  elimtype False; generalize (Rplus_ge_compat_l a b 0 r); intro;
+    elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
+      generalize (Rge_trans (a + b) a 0 H r0); intro; clear H; 
+        unfold Rge in H0; elim H0; intro; clear H0.
+  unfold Rgt in H; generalize (Rlt_asym (a + b) 0 r1); intro; auto.
+  absurd (a + b = 0); auto.
+  apply (Rlt_dichotomy_converse (a + b) 0); left; assumption.
 (**)
-elimtype False; generalize (Rplus_lt_compat_l a b 0 r); intro;
- elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
- generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H; 
- unfold Rge in r1; elim r1; clear r1; intro.
-unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro;
- apply (Rlt_irrefl (a + b)); assumption.
-rewrite H in H0; apply (Rlt_irrefl 0); assumption.
+  elimtype False; generalize (Rplus_lt_compat_l a b 0 r); intro;
+    elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
+      generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H; 
+        unfold Rge in r1; elim r1; clear r1; intro.
+  unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro;
+    apply (Rlt_irrefl (a + b)); assumption.
+  rewrite H in H0; apply (Rlt_irrefl 0); assumption.
 (**)
-rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
- apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
- unfold Rminus in |- *; rewrite (Ropp_involutive a);
- generalize (Rplus_lt_compat_l a a 0 r0); clear r r1; 
- intro; elim (Rplus_ne a); intros v w; rewrite v in H; 
- clear v w; generalize (Rlt_trans (a + a) a 0 H r0); 
- intro; apply (Rlt_le (a + a) 0 H0).
+  rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
+    apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
+      unfold Rminus in |- *; rewrite (Ropp_involutive a);
+        generalize (Rplus_lt_compat_l a a 0 r0); clear r r1; 
+          intro; elim (Rplus_ne a); intros v w; rewrite v in H; 
+            clear v w; generalize (Rlt_trans (a + a) a 0 H r0); 
+              intro; apply (Rlt_le (a + a) 0 H0).
 (**)
-apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
- unfold Rminus in |- *; rewrite (Ropp_involutive b);
- generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1; 
- intro; elim (Rplus_ne b); intros v w; rewrite v in H; 
- clear v w; generalize (Rlt_trans (b + b) b 0 H r); 
- intro; apply (Rlt_le (b + b) 0 H0).
+  apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
+    unfold Rminus in |- *; rewrite (Ropp_involutive b);
+      generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1; 
+        intro; elim (Rplus_ne b); intros v w; rewrite v in H; 
+          clear v w; generalize (Rlt_trans (b + b) b 0 H r); 
+            intro; apply (Rlt_le (b + b) 0 H0).
 (**)
-unfold Rle in |- *; right; reflexivity.
+  unfold Rle in |- *; right; reflexivity.
 Qed.
 
 (*********)
 Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b).
-intros; apply (Rplus_le_reg_l (Rabs b) (Rabs a - Rabs b) (Rabs (a - b)));
- unfold Rminus in |- *; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b));
- rewrite (Rplus_comm (Rabs b) (Rabs a));
- rewrite (Rplus_assoc (Rabs a) (Rabs b) (- Rabs b));
- rewrite (Rplus_opp_r (Rabs b)); rewrite (proj1 (Rplus_ne (Rabs a)));
- replace (Rabs a) with (Rabs (a + 0)).
- rewrite <- (Rplus_opp_r b); rewrite <- (Rplus_assoc a b (- b));
-  rewrite (Rplus_comm a b); rewrite (Rplus_assoc b a (- b)).
- exact (Rabs_triang b (a + - b)).
- rewrite (proj1 (Rplus_ne a)); trivial.
+Proof.
+  intros; apply (Rplus_le_reg_l (Rabs b) (Rabs a - Rabs b) (Rabs (a - b)));
+    unfold Rminus in |- *; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b));
+      rewrite (Rplus_comm (Rabs b) (Rabs a));
+        rewrite (Rplus_assoc (Rabs a) (Rabs b) (- Rabs b));
+          rewrite (Rplus_opp_r (Rabs b)); rewrite (proj1 (Rplus_ne (Rabs a)));
+            replace (Rabs a) with (Rabs (a + 0)).
+  rewrite <- (Rplus_opp_r b); rewrite <- (Rplus_assoc a b (- b));
+    rewrite (Rplus_comm a b); rewrite (Rplus_assoc b a (- b)).
+  exact (Rabs_triang b (a + - b)).
+  rewrite (proj1 (Rplus_ne a)); trivial.
 Qed.
 
 (* ||a|-|b||<=|a-b| *)
 Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b). 
-cut
- (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). 
-intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]].
-rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b));
- do 2 rewrite Ropp_minus_distr. 
-apply H; left; assumption. 
-rewrite Heq; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- apply Rabs_pos. 
-apply H; left; assumption. 
-intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). 
-apply Rabs_triang_inv. 
-rewrite (Rabs_right (Rabs a - Rabs b));
- [ reflexivity
- | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r;
-    replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); 
-    [ assumption | ring ] ]. 
+Proof.
+  cut
+    (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). 
+  intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]].
+  rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b));
+    do 2 rewrite Ropp_minus_distr. 
+  apply H; left; assumption. 
+  rewrite Heq; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    apply Rabs_pos. 
+  apply H; left; assumption. 
+  intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). 
+  apply Rabs_triang_inv. 
+  rewrite (Rabs_right (Rabs a - Rabs b));
+    [ reflexivity
+      | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r;
+        replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); 
+        [ assumption | ring ] ]. 
 Qed. 
 
 (*********)
 Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a.
-unfold Rabs in |- *; intros; case (Rcase_abs x); intro.
-generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt in |- *;
- rewrite Ropp_involutive; intro; assumption.
-assumption.
+Proof.
+  unfold Rabs in |- *; intros; case (Rcase_abs x); intro.
+  generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt in |- *;
+    rewrite Ropp_involutive; intro; assumption.
+  assumption.
 Qed.
 
 (*********)
 Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
-unfold Rabs in |- *; intro x; case (Rcase_abs x); intros.
-generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt in |- *; intro;
- generalize (Rlt_trans 0 (- x) a H0 H); intro; split. 
-apply (Rlt_trans x 0 a r H1).
-generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
- unfold Rgt in |- *; trivial.
-fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro;
- generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a) in |- *;
- generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *; 
- intro; split; assumption.
+Proof.
+  unfold Rabs in |- *; intro x; case (Rcase_abs x); intros.
+  generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt in |- *; intro;
+    generalize (Rlt_trans 0 (- x) a H0 H); intro; split. 
+  apply (Rlt_trans x 0 a r H1).
+  generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
+    unfold Rgt in |- *; trivial.
+  fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro;
+    generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a) in |- *;
+      generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *; 
+        intro; split; assumption.
 Qed.
 
 Lemma RmaxAbs :
- forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).
-intros p q r H' H'0; case (Rle_or_lt 0 p); intros H'1.
-repeat rewrite Rabs_right; auto with real.
-apply Rle_trans with r; auto with real.
-apply RmaxLess2; auto.
-apply Rge_trans with p; auto with real; apply Rge_trans with q;
- auto with real.
-apply Rge_trans with p; auto with real.
-rewrite (Rabs_left p); auto.
-case (Rle_or_lt 0 q); intros H'2.
-repeat rewrite Rabs_right; auto with real.
-apply Rle_trans with r; auto.
-apply RmaxLess2; auto.
-apply Rge_trans with q; auto with real.
-rewrite (Rabs_left q); auto.
-case (Rle_or_lt 0 r); intros H'3.
-repeat rewrite Rabs_right; auto with real.
-apply Rle_trans with (- p); auto with real.
-apply RmaxLess1; auto.
-rewrite (Rabs_left r); auto.
-apply Rle_trans with (- p); auto with real.
-apply RmaxLess1; auto.
+  forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).
+Proof.
+  intros p q r H' H'0; case (Rle_or_lt 0 p); intros H'1.
+  repeat rewrite Rabs_right; auto with real.
+  apply Rle_trans with r; auto with real.
+  apply RmaxLess2; auto.
+  apply Rge_trans with p; auto with real; apply Rge_trans with q;
+    auto with real.
+  apply Rge_trans with p; auto with real.
+  rewrite (Rabs_left p); auto.
+  case (Rle_or_lt 0 q); intros H'2.
+  repeat rewrite Rabs_right; auto with real.
+  apply Rle_trans with r; auto.
+  apply RmaxLess2; auto.
+  apply Rge_trans with q; auto with real.
+  rewrite (Rabs_left q); auto.
+  case (Rle_or_lt 0 r); intros H'3.
+  repeat rewrite Rabs_right; auto with real.
+  apply Rle_trans with (- p); auto with real.
+  apply RmaxLess1; auto.
+  rewrite (Rabs_left r); auto.
+  apply Rle_trans with (- p); auto with real.
+  apply RmaxLess1; auto.
 Qed.
 
 Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Zabs z).
-intros z; case z; simpl in |- *; auto with real.
-apply Rabs_right; auto with real.
-intros p0; apply Rabs_right; auto with real zarith.
-intros p0; rewrite Rabs_Ropp.
-apply Rabs_right; auto with real zarith.
+Proof.
+  intros z; case z; simpl in |- *; auto with real.
+  apply Rabs_right; auto with real.
+  intros p0; apply Rabs_right; auto with real zarith.
+  intros p0; rewrite Rabs_Ropp.
+  apply Rabs_right; auto with real zarith.
 Qed.
- 
\ No newline at end of file
+ 
diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v
index dd8379cb..16e12d7f 100644
--- a/theories/Reals/Rcomplete.v
+++ b/theories/Reals/Rcomplete.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Rcomplete.v,v 1.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*i $Id: Rcomplete.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -24,175 +24,176 @@ Open Local Scope R_scope.
 (****************************************************)
 
 Theorem R_complete :
- forall Un:nat -> R, Cauchy_crit Un -> sigT (fun l:R => Un_cv Un l).
-intros.
-set (Vn := sequence_minorant Un (cauchy_min Un H)).
-set (Wn := sequence_majorant Un (cauchy_maj Un H)).
-assert (H0 := maj_cv Un H).
-fold Wn in H0.
-assert (H1 := min_cv Un H).
-fold Vn in H1.
-elim H0; intros.
-elim H1; intros.
-cut (x = x0).
-intros.
-apply existT with x.
-rewrite <- H2 in p0.
-unfold Un_cv in |- *.
-intros.
-unfold Un_cv in p; unfold Un_cv in p0.
-cut (0 < eps / 3).
-intro.
-elim (p (eps / 3) H4); intros.
-elim (p0 (eps / 3) H4); intros.
-exists (max x1 x2).
-intros.
-unfold R_dist in |- *.
-apply Rle_lt_trans with (Rabs (Un n - Vn n) + Rabs (Vn n - x)).
-replace (Un n - x) with (Un n - Vn n + (Vn n - x));
- [ apply Rabs_triang | ring ].
-apply Rle_lt_trans with (Rabs (Wn n - Vn n) + Rabs (Vn n - x)).
-do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
-apply Rplus_le_compat_l.
-repeat rewrite Rabs_right.
-unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- Vn n));
- apply Rplus_le_compat_l.
-assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
-fold Vn Wn in H8.
-elim (H8 n); intros.
-assumption.
-apply Rle_ge.
-unfold Rminus in |- *; apply Rplus_le_reg_l with (Vn n).
-rewrite Rplus_0_r.
-replace (Vn n + (Wn n + - Vn n)) with (Wn n); [ idtac | ring ].
-assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
-fold Vn Wn in H8.
-elim (H8 n); intros.
-apply Rle_trans with (Un n); assumption.
-apply Rle_ge.
-unfold Rminus in |- *; apply Rplus_le_reg_l with (Vn n).
-rewrite Rplus_0_r.
-replace (Vn n + (Un n + - Vn n)) with (Un n); [ idtac | ring ].
-assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
-fold Vn Wn in H8.
-elim (H8 n); intros.
-assumption.
-apply Rle_lt_trans with (Rabs (Wn n - x) + Rabs (x - Vn n) + Rabs (Vn n - x)).
-do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
-apply Rplus_le_compat_l.
-replace (Wn n - Vn n) with (Wn n - x + (x - Vn n));
- [ apply Rabs_triang | ring ].
-apply Rlt_le_trans with (eps / 3 + eps / 3 + eps / 3).
-repeat apply Rplus_lt_compat.
-unfold R_dist in H5.
-apply H5.
-unfold ge in |- *; apply le_trans with (max x1 x2).
-apply le_max_l.
-assumption.
-rewrite <- Rabs_Ropp.
-replace (- (x - Vn n)) with (Vn n - x); [ idtac | ring ].
-unfold R_dist in H6.
-apply H6.
-unfold ge in |- *; apply le_trans with (max x1 x2).
-apply le_max_r.
-assumption.
-unfold R_dist in H6.
-apply H6.
-unfold ge in |- *; apply le_trans with (max x1 x2).
-apply le_max_r.
-assumption.
-right.
-pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
-ring.
-unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-apply cond_eq.
-intros.
-cut (0 < eps / 5).
-intro.
-unfold Un_cv in p; unfold Un_cv in p0.
-unfold R_dist in p; unfold R_dist in p0.
-elim (p (eps / 5) H3); intros N1 H4.
-elim (p0 (eps / 5) H3); intros N2 H5.
-unfold Cauchy_crit in H.
-unfold R_dist in H.
-elim (H (eps / 5) H3); intros N3 H6.
-set (N := max (max N1 N2) N3).
-apply Rle_lt_trans with (Rabs (x - Wn N) + Rabs (Wn N - x0)).
-replace (x - x0) with (x - Wn N + (Wn N - x0)); [ apply Rabs_triang | ring ].
-apply Rle_lt_trans with
- (Rabs (x - Wn N) + Rabs (Wn N - Vn N) + Rabs (Vn N - x0)).
-rewrite Rplus_assoc.
-apply Rplus_le_compat_l.
-replace (Wn N - x0) with (Wn N - Vn N + (Vn N - x0));
- [ apply Rabs_triang | ring ].
-replace eps with (eps / 5 + 3 * (eps / 5) + eps / 5).
-repeat apply Rplus_lt_compat.
-rewrite <- Rabs_Ropp.
-replace (- (x - Wn N)) with (Wn N - x); [ apply H4 | ring ].
-unfold ge, N in |- *.
-apply le_trans with (max N1 N2); apply le_max_l.
-unfold Wn, Vn in |- *.
-unfold sequence_majorant, sequence_minorant in |- *.
-assert
- (H7 :=
-  approx_maj (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
-assert
- (H8 :=
-  approx_min (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
-cut
- (Wn N =
-  majorant (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
-cut
- (Vn N =
-  minorant (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
-intros.
-rewrite <- H9; rewrite <- H10.
-rewrite <- H9 in H8.
-rewrite <- H10 in H7.
-elim (H7 (eps / 5) H3); intros k2 H11.
-elim (H8 (eps / 5) H3); intros k1 H12.
-apply Rle_lt_trans with
- (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Vn N)).
-replace (Wn N - Vn N) with
- (Wn N - Un (N + k2)%nat + (Un (N + k2)%nat - Vn N));
- [ apply Rabs_triang | ring ].
-apply Rle_lt_trans with
- (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Un (N + k1)%nat) +
-  Rabs (Un (N + k1)%nat - Vn N)).
-rewrite Rplus_assoc.
-apply Rplus_le_compat_l.
-replace (Un (N + k2)%nat - Vn N) with
- (Un (N + k2)%nat - Un (N + k1)%nat + (Un (N + k1)%nat - Vn N));
- [ apply Rabs_triang | ring ].
-replace (3 * (eps / 5)) with (eps / 5 + eps / 5 + eps / 5);
- [ repeat apply Rplus_lt_compat | ring ].
-assumption.
-apply H6.
-unfold ge in |- *.
-apply le_trans with N.
-unfold N in |- *; apply le_max_r.
-apply le_plus_l.
-unfold ge in |- *.
-apply le_trans with N.
-unfold N in |- *; apply le_max_r.
-apply le_plus_l.
-rewrite <- Rabs_Ropp.
-replace (- (Un (N + k1)%nat - Vn N)) with (Vn N - Un (N + k1)%nat);
- [ assumption | ring ].
-reflexivity.
-reflexivity.
-apply H5.
-unfold ge in |- *; apply le_trans with (max N1 N2).
-apply le_max_r.
-unfold N in |- *; apply le_max_l.
-pattern eps at 4 in |- *; replace eps with (5 * (eps / 5)).
-ring.
-unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
-discrR.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-assumption.
-apply Rinv_0_lt_compat.
-prove_sup0; try apply lt_O_Sn.
-Qed.
\ No newline at end of file
+  forall Un:nat -> R, Cauchy_crit Un -> sigT (fun l:R => Un_cv Un l).
+Proof.
+  intros.
+  set (Vn := sequence_minorant Un (cauchy_min Un H)).
+  set (Wn := sequence_majorant Un (cauchy_maj Un H)).
+  assert (H0 := maj_cv Un H).
+  fold Wn in H0.
+  assert (H1 := min_cv Un H).
+  fold Vn in H1.
+  elim H0; intros.
+  elim H1; intros.
+  cut (x = x0).
+  intros.
+  apply existT with x.
+  rewrite <- H2 in p0.
+  unfold Un_cv in |- *.
+  intros.
+  unfold Un_cv in p; unfold Un_cv in p0.
+  cut (0 < eps / 3).
+  intro.
+  elim (p (eps / 3) H4); intros.
+  elim (p0 (eps / 3) H4); intros.
+  exists (max x1 x2).
+  intros.
+  unfold R_dist in |- *.
+  apply Rle_lt_trans with (Rabs (Un n - Vn n) + Rabs (Vn n - x)).
+  replace (Un n - x) with (Un n - Vn n + (Vn n - x));
+  [ apply Rabs_triang | ring ].
+  apply Rle_lt_trans with (Rabs (Wn n - Vn n) + Rabs (Vn n - x)).
+  do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
+  apply Rplus_le_compat_l.
+  repeat rewrite Rabs_right.
+  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- Vn n));
+    apply Rplus_le_compat_l.
+  assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
+  fold Vn Wn in H8.
+  elim (H8 n); intros.
+  assumption.
+  apply Rle_ge.
+  unfold Rminus in |- *; apply Rplus_le_reg_l with (Vn n).
+  rewrite Rplus_0_r.
+  replace (Vn n + (Wn n + - Vn n)) with (Wn n); [ idtac | ring ].
+  assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
+  fold Vn Wn in H8.
+  elim (H8 n); intros.
+  apply Rle_trans with (Un n); assumption.
+  apply Rle_ge.
+  unfold Rminus in |- *; apply Rplus_le_reg_l with (Vn n).
+  rewrite Rplus_0_r.
+  replace (Vn n + (Un n + - Vn n)) with (Un n); [ idtac | ring ].
+  assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
+  fold Vn Wn in H8.
+  elim (H8 n); intros.
+  assumption.
+  apply Rle_lt_trans with (Rabs (Wn n - x) + Rabs (x - Vn n) + Rabs (Vn n - x)).
+  do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
+  apply Rplus_le_compat_l.
+  replace (Wn n - Vn n) with (Wn n - x + (x - Vn n));
+  [ apply Rabs_triang | ring ].
+  apply Rlt_le_trans with (eps / 3 + eps / 3 + eps / 3).
+  repeat apply Rplus_lt_compat.
+  unfold R_dist in H5.
+  apply H5.
+  unfold ge in |- *; apply le_trans with (max x1 x2).
+  apply le_max_l.
+  assumption.
+  rewrite <- Rabs_Ropp.
+  replace (- (x - Vn n)) with (Vn n - x); [ idtac | ring ].
+  unfold R_dist in H6.
+  apply H6.
+  unfold ge in |- *; apply le_trans with (max x1 x2).
+  apply le_max_r.
+  assumption.
+  unfold R_dist in H6.
+  apply H6.
+  unfold ge in |- *; apply le_trans with (max x1 x2).
+  apply le_max_r.
+  assumption.
+  right.
+  pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
+  ring.
+  unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  apply cond_eq.
+  intros.
+  cut (0 < eps / 5).
+  intro.
+  unfold Un_cv in p; unfold Un_cv in p0.
+  unfold R_dist in p; unfold R_dist in p0.
+  elim (p (eps / 5) H3); intros N1 H4.
+  elim (p0 (eps / 5) H3); intros N2 H5.
+  unfold Cauchy_crit in H.
+  unfold R_dist in H.
+  elim (H (eps / 5) H3); intros N3 H6.
+  set (N := max (max N1 N2) N3).
+  apply Rle_lt_trans with (Rabs (x - Wn N) + Rabs (Wn N - x0)).
+  replace (x - x0) with (x - Wn N + (Wn N - x0)); [ apply Rabs_triang | ring ].
+  apply Rle_lt_trans with
+    (Rabs (x - Wn N) + Rabs (Wn N - Vn N) + Rabs (Vn N - x0)).
+  rewrite Rplus_assoc.
+  apply Rplus_le_compat_l.
+  replace (Wn N - x0) with (Wn N - Vn N + (Vn N - x0));
+  [ apply Rabs_triang | ring ].
+  replace eps with (eps / 5 + 3 * (eps / 5) + eps / 5).
+  repeat apply Rplus_lt_compat.
+  rewrite <- Rabs_Ropp.
+  replace (- (x - Wn N)) with (Wn N - x); [ apply H4 | ring ].
+  unfold ge, N in |- *.
+  apply le_trans with (max N1 N2); apply le_max_l.
+  unfold Wn, Vn in |- *.
+  unfold sequence_majorant, sequence_minorant in |- *.
+  assert
+    (H7 :=
+      approx_maj (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
+  assert
+    (H8 :=
+      approx_min (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
+  cut
+    (Wn N =
+      majorant (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
+  cut
+    (Vn N =
+      minorant (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
+  intros.
+  rewrite <- H9; rewrite <- H10.
+  rewrite <- H9 in H8.
+  rewrite <- H10 in H7.
+  elim (H7 (eps / 5) H3); intros k2 H11.
+  elim (H8 (eps / 5) H3); intros k1 H12.
+  apply Rle_lt_trans with
+    (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Vn N)).
+  replace (Wn N - Vn N) with
+  (Wn N - Un (N + k2)%nat + (Un (N + k2)%nat - Vn N));
+  [ apply Rabs_triang | ring ].
+  apply Rle_lt_trans with
+    (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Un (N + k1)%nat) +
+      Rabs (Un (N + k1)%nat - Vn N)).
+  rewrite Rplus_assoc.
+  apply Rplus_le_compat_l.
+  replace (Un (N + k2)%nat - Vn N) with
+  (Un (N + k2)%nat - Un (N + k1)%nat + (Un (N + k1)%nat - Vn N));
+  [ apply Rabs_triang | ring ].
+  replace (3 * (eps / 5)) with (eps / 5 + eps / 5 + eps / 5);
+  [ repeat apply Rplus_lt_compat | ring ].
+  assumption.
+  apply H6.
+  unfold ge in |- *.
+  apply le_trans with N.
+  unfold N in |- *; apply le_max_r.
+  apply le_plus_l.
+  unfold ge in |- *.
+  apply le_trans with N.
+  unfold N in |- *; apply le_max_r.
+  apply le_plus_l.
+  rewrite <- Rabs_Ropp.
+  replace (- (Un (N + k1)%nat - Vn N)) with (Vn N - Un (N + k1)%nat);
+  [ assumption | ring ].
+  reflexivity.
+  reflexivity.
+  apply H5.
+  unfold ge in |- *; apply le_trans with (max N1 N2).
+  apply le_max_r.
+  unfold N in |- *; apply le_max_l.
+  pattern eps at 4 in |- *; replace eps with (5 * (eps / 5)).
+  ring.
+  unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+  discrR.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  assumption.
+  apply Rinv_0_lt_compat.
+  prove_sup0; try apply lt_O_Sn.
+Qed.
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
index 33f494df..330c0042 100644
--- a/theories/Reals/Rdefinitions.v
+++ b/theories/Reals/Rdefinitions.v
@@ -5,12 +5,11 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Rdefinitions.v,v 1.14.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Rdefinitions.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 
 (*********************************************************)
 (**          Definitions for the axiomatization          *)
-(*                                                       *)
 (*********************************************************)
 
 Require Export ZArith_base.
@@ -56,6 +55,8 @@ Definition Rminus (r1 r2:R) : R := (r1 + - r2)%R.
 (**********)
 Definition Rdiv (r1 r2:R) : R := (r1 * / r2)%R.
 
+(**********)
+
 Infix "-" := Rminus : R_scope.
 Infix "/" := Rdiv : R_scope.
 
@@ -66,4 +67,4 @@ Infix ">" := Rgt : R_scope.
 Notation "x <= y <= z" := ((x <= y)%R /\ (y <= z)%R) : R_scope.
 Notation "x <= y < z" := ((x <= y)%R /\ (y < z)%R) : R_scope.
 Notation "x < y < z" := ((x < y)%R /\ (y < z)%R) : R_scope.
-Notation "x < y <= z" := ((x < y)%R /\ (y <= z)%R) : R_scope.
\ No newline at end of file
+Notation "x < y <= z" := ((x < y)%R /\ (y <= z)%R) : R_scope.
diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
index 81db80ab..e2fd2efe 100644
--- a/theories/Reals/Rderiv.v
+++ b/theories/Reals/Rderiv.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rderiv.v,v 1.15.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Rderiv.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (*********************************************************)
 (**     Definition of the derivative,continuity          *)
@@ -34,398 +34,409 @@ Definition D_in (f d:R -> R) (D:R -> Prop) (x0:R) : Prop :=
 
 (*********)
 Lemma cont_deriv :
- forall (f d:R -> R) (D:R -> Prop) (x0:R),
-   D_in f d D x0 -> continue_in f D x0.
-unfold continue_in in |- *; unfold D_in in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *; 
- intros; elim (H eps H0); clear H; intros; elim H; 
- clear H; intros; elim (Req_dec (d x0) 0); intro.
-split with (Rmin 1 x); split.
-elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)).
-intros; elim H3; clear H3; intros;
- generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1);
- unfold Rgt in |- *; intro; elim (H5 H4); clear H5; 
- intros; generalize (H1 x1 (conj H3 H6)); clear H1; 
- intro; unfold D_x in H3; elim H3; intros.
-rewrite H2 in H1; unfold R_dist in |- *; unfold R_dist in H1;
- cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)).
-intro; unfold R_dist in H5;
- generalize (Rmult_lt_compat_l eps (Rabs (x1 - x0)) 1 H0 H5);
- rewrite Rmult_1_r; intro; apply Rlt_trans with (r2 := eps * Rabs (x1 - x0));
- assumption.
-rewrite (Rminus_0_r ((f x1 - f x0) * / (x1 - x0))) in H1;
- rewrite Rabs_mult in H1; cut (x1 - x0 <> 0).
-intro; rewrite (Rabs_Rinv (x1 - x0) H9) in H1;
- generalize
-  (Rmult_lt_compat_l (Rabs (x1 - x0)) (Rabs (f x1 - f x0) * / Rabs (x1 - x0))
-     eps (Rabs_pos_lt (x1 - x0) H9) H1); intro; rewrite Rmult_comm in H10;
- rewrite Rmult_assoc in H10; rewrite Rinv_l in H10.
-rewrite Rmult_1_r in H10; rewrite Rmult_comm; assumption.
-apply Rabs_no_R0; auto.
-apply Rminus_eq_contra; auto.
+  forall (f d:R -> R) (D:R -> Prop) (x0:R),
+    D_in f d D x0 -> continue_in f D x0.
+Proof.
+  unfold continue_in in |- *; unfold D_in in |- *; unfold limit1_in in |- *;
+    unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *; 
+      intros; elim (H eps H0); clear H; intros; elim H; 
+        clear H; intros; elim (Req_dec (d x0) 0); intro.
+  split with (Rmin 1 x); split.
+  elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)).
+  intros; elim H3; clear H3; intros;
+    generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1);
+      unfold Rgt in |- *; intro; elim (H5 H4); clear H5; 
+        intros; generalize (H1 x1 (conj H3 H6)); clear H1; 
+          intro; unfold D_x in H3; elim H3; intros.
+  rewrite H2 in H1; unfold R_dist in |- *; unfold R_dist in H1;
+    cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)).
+  intro; unfold R_dist in H5;
+    generalize (Rmult_lt_compat_l eps (Rabs (x1 - x0)) 1 H0 H5);
+      rewrite Rmult_1_r; intro; apply Rlt_trans with (r2 := eps * Rabs (x1 - x0));
+        assumption.
+  rewrite (Rminus_0_r ((f x1 - f x0) * / (x1 - x0))) in H1;
+    rewrite Rabs_mult in H1; cut (x1 - x0 <> 0).
+  intro; rewrite (Rabs_Rinv (x1 - x0) H9) in H1;
+    generalize
+      (Rmult_lt_compat_l (Rabs (x1 - x0)) (Rabs (f x1 - f x0) * / Rabs (x1 - x0))
+        eps (Rabs_pos_lt (x1 - x0) H9) H1); intro; rewrite Rmult_comm in H10;
+      rewrite Rmult_assoc in H10; rewrite Rinv_l in H10.
+  rewrite Rmult_1_r in H10; rewrite Rmult_comm; assumption.
+  apply Rabs_no_R0; auto.
+  apply Rminus_eq_contra; auto.
 (**)
- split with (Rmin (Rmin (/ 2) x) (eps * / Rabs (2 * d x0))); split.
-cut (Rmin (/ 2) x > 0).
-cut (eps * / Rabs (2 * d x0) > 0).
-intros; elim (Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) 0);
- intros a b; apply (b (conj H4 H3)).
-apply Rmult_gt_0_compat; auto.
-unfold Rgt in |- *; apply Rinv_0_lt_compat; apply Rabs_pos_lt;
- apply Rmult_integral_contrapositive; split.
-discrR.
-assumption.
-elim (Rmin_Rgt (/ 2) x 0); intros a b; cut (0 < 2).
-intro; generalize (Rinv_0_lt_compat 2 H3); intro; fold (/ 2 > 0) in H4;
- apply (b (conj H4 H)).
-fourier.
-intros; elim H3; clear H3; intros;
- generalize
-  (let (H1, H2) :=
-       Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in
-   H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5; 
- intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1);
- unfold Rgt in |- *; intro; elim (H7 H5); clear H7; 
- intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); 
- clear H1; intro; unfold D_x in H3; elim H3; intros;
- generalize (sym_not_eq H5); clear H5; intro H5;
- generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1;
- pattern (d x0) at 1 in |- *;
- rewrite <- (let (H1, H2) := Rmult_ne (d x0) in H2);
- rewrite <- (Rinv_l (x1 - x0) H9); unfold R_dist in |- *;
- unfold Rminus at 1 in |- *; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0)));
- rewrite (Rmult_comm (/ (x1 - x0) * (x1 - x0)) (d x0));
- rewrite <- (Ropp_mult_distr_l_reverse (d x0) (/ (x1 - x0) * (x1 - x0)));
- rewrite (Rmult_comm (- d x0) (/ (x1 - x0) * (x1 - x0)));
- rewrite (Rmult_assoc (/ (x1 - x0)) (x1 - x0) (- d x0));
- rewrite <-
-  (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) ((x1 - x0) * - d x0))
-  ; rewrite (Rabs_mult (/ (x1 - x0)) (f x1 - f x0 + (x1 - x0) * - d x0));
- clear H1; intro;
- generalize
-  (Rmult_lt_compat_l (Rabs (x1 - x0))
-     (Rabs (/ (x1 - x0)) * Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) eps
-     (Rabs_pos_lt (x1 - x0) H9) H1);
- rewrite <-
-  (Rmult_assoc (Rabs (x1 - x0)) (Rabs (/ (x1 - x0)))
-     (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)));
- rewrite (Rabs_Rinv (x1 - x0) H9);
- rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9));
- rewrite
-  (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2)
-  ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); 
- intro; rewrite (Rmult_comm (x1 - x0) (- d x0));
- rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0));
- fold (f x1 - f x0 - d x0 * (x1 - x0)) in |- *;
- rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; 
- intro;
- generalize
-  (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0)))
-     (Rabs (f x1 - f x0 - d x0 * (x1 - x0))) (Rabs (x1 - x0) * eps) H10 H1);
- clear H1; intro;
- generalize
-  (Rplus_lt_compat_l (Rabs (d x0 * (x1 - x0)))
-     (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) (
-     Rabs (x1 - x0) * eps) H1); unfold Rminus at 2 in |- *;
- rewrite (Rplus_comm (Rabs (f x1 - f x0)) (- Rabs (d x0 * (x1 - x0))));
- rewrite <-
-  (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0)))
-     (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0))));
- rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); 
- clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps).
-intro;
- apply
-  (Rlt_trans (Rabs (f x1 - f x0))
-     (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). 
-clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro;
- unfold Rgt in H0;
- generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7); 
- clear H7; intro;
- generalize
-  (Rmult_lt_compat_l (Rabs (d x0)) (R_dist x1 x0) (
-     eps * / Rabs (2 * d x0)) H1 H6); clear H6; intro;
- rewrite (Rmult_comm eps (R_dist x1 x0)) in H3; unfold R_dist in H3, H5;
- rewrite <- (Rabs_mult (d x0) (x1 - x0)) in H5;
- rewrite (Rabs_mult 2 (d x0)) in H5; cut (Rabs 2 <> 0).
-intro; fold (Rabs (d x0) > 0) in H1;
- rewrite
-  (Rinv_mult_distr (Rabs 2) (Rabs (d x0)) H6
-     (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
-   in H5;
- rewrite (Rmult_comm (Rabs (d x0)) (eps * (/ Rabs 2 * / Rabs (d x0)))) in H5;
- rewrite <- (Rmult_assoc eps (/ Rabs 2) (/ Rabs (d x0))) in H5;
- rewrite (Rmult_assoc (eps * / Rabs 2) (/ Rabs (d x0)) (Rabs (d x0))) in H5;
- rewrite
-  (Rinv_l (Rabs (d x0))
-     (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
-   in H5; rewrite (let (H1, H2) := Rmult_ne (eps * / Rabs 2) in H1) in H5;
- cut (Rabs 2 = 2).
-intro; rewrite H7 in H5;
- generalize
-  (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2)
-     (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; 
- rewrite eps2 in H10; assumption.
-unfold Rabs in |- *; case (Rcase_abs 2); auto.
- intro; cut (0 < 2).
-intro; generalize (Rlt_asym 0 2 H7); intro; elimtype False; auto.
-fourier.
-apply Rabs_no_R0.
-discrR.
+  split with (Rmin (Rmin (/ 2) x) (eps * / Rabs (2 * d x0))); split.
+  cut (Rmin (/ 2) x > 0).
+  cut (eps * / Rabs (2 * d x0) > 0).
+  intros; elim (Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) 0);
+    intros a b; apply (b (conj H4 H3)).
+  apply Rmult_gt_0_compat; auto.
+  unfold Rgt in |- *; apply Rinv_0_lt_compat; apply Rabs_pos_lt;
+    apply Rmult_integral_contrapositive; split.
+  discrR.
+  assumption.
+  elim (Rmin_Rgt (/ 2) x 0); intros a b; cut (0 < 2).
+  intro; generalize (Rinv_0_lt_compat 2 H3); intro; fold (/ 2 > 0) in H4;
+    apply (b (conj H4 H)).
+  fourier.
+  intros; elim H3; clear H3; intros;
+    generalize
+      (let (H1, H2) :=
+        Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in
+        H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5; 
+      intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1);
+        unfold Rgt in |- *; intro; elim (H7 H5); clear H7; 
+          intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); 
+            clear H1; intro; unfold D_x in H3; elim H3; intros;
+              generalize (sym_not_eq H5); clear H5; intro H5;
+                generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1;
+                  pattern (d x0) at 1 in |- *;
+                    rewrite <- (let (H1, H2) := Rmult_ne (d x0) in H2);
+                      rewrite <- (Rinv_l (x1 - x0) H9); unfold R_dist in |- *;
+                        unfold Rminus at 1 in |- *; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0)));
+                          rewrite (Rmult_comm (/ (x1 - x0) * (x1 - x0)) (d x0));
+                            rewrite <- (Ropp_mult_distr_l_reverse (d x0) (/ (x1 - x0) * (x1 - x0)));
+                              rewrite (Rmult_comm (- d x0) (/ (x1 - x0) * (x1 - x0)));
+                                rewrite (Rmult_assoc (/ (x1 - x0)) (x1 - x0) (- d x0));
+                                  rewrite <-
+                                    (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) ((x1 - x0) * - d x0))
+                                    ; rewrite (Rabs_mult (/ (x1 - x0)) (f x1 - f x0 + (x1 - x0) * - d x0));
+                                      clear H1; intro;
+                                        generalize
+                                          (Rmult_lt_compat_l (Rabs (x1 - x0))
+                                            (Rabs (/ (x1 - x0)) * Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) eps
+                                            (Rabs_pos_lt (x1 - x0) H9) H1);
+                                          rewrite <-
+                                            (Rmult_assoc (Rabs (x1 - x0)) (Rabs (/ (x1 - x0)))
+                                              (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)));
+                                            rewrite (Rabs_Rinv (x1 - x0) H9);
+                                              rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9));
+                                                rewrite
+                                                  (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2)
+                                                  ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); 
+                                                    intro; rewrite (Rmult_comm (x1 - x0) (- d x0));
+                                                      rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0));
+                                                        fold (f x1 - f x0 - d x0 * (x1 - x0)) in |- *;
+                                                          rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; 
+                                                            intro;
+                                                              generalize
+                                                                (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0)))
+                                                                  (Rabs (f x1 - f x0 - d x0 * (x1 - x0))) (Rabs (x1 - x0) * eps) H10 H1);
+                                                                clear H1; intro;
+                                                                  generalize
+                                                                    (Rplus_lt_compat_l (Rabs (d x0 * (x1 - x0)))
+                                                                      (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) (
+                                                                        Rabs (x1 - x0) * eps) H1); unfold Rminus at 2 in |- *;
+                                                                    rewrite (Rplus_comm (Rabs (f x1 - f x0)) (- Rabs (d x0 * (x1 - x0))));
+                                                                      rewrite <-
+                                                                        (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0)))
+                                                                          (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0))));
+                                                                        rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); 
+                                                                          clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps).
+  intro;
+    apply
+      (Rlt_trans (Rabs (f x1 - f x0))
+        (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). 
+  clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro;
+    unfold Rgt in H0;
+      generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7); 
+        clear H7; intro;
+          generalize
+            (Rmult_lt_compat_l (Rabs (d x0)) (R_dist x1 x0) (
+              eps * / Rabs (2 * d x0)) H1 H6); clear H6; intro;
+            rewrite (Rmult_comm eps (R_dist x1 x0)) in H3; unfold R_dist in H3, H5;
+              rewrite <- (Rabs_mult (d x0) (x1 - x0)) in H5;
+                rewrite (Rabs_mult 2 (d x0)) in H5; cut (Rabs 2 <> 0).
+  intro; fold (Rabs (d x0) > 0) in H1;
+    rewrite
+      (Rinv_mult_distr (Rabs 2) (Rabs (d x0)) H6
+        (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
+      in H5;
+      rewrite (Rmult_comm (Rabs (d x0)) (eps * (/ Rabs 2 * / Rabs (d x0)))) in H5;
+        rewrite <- (Rmult_assoc eps (/ Rabs 2) (/ Rabs (d x0))) in H5;
+          rewrite (Rmult_assoc (eps * / Rabs 2) (/ Rabs (d x0)) (Rabs (d x0))) in H5;
+            rewrite
+              (Rinv_l (Rabs (d x0))
+                (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
+              in H5; rewrite (let (H1, H2) := Rmult_ne (eps * / Rabs 2) in H1) in H5;
+                cut (Rabs 2 = 2).
+  intro; rewrite H7 in H5;
+    generalize
+      (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2)
+        (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; 
+      rewrite eps2 in H10; assumption.
+  unfold Rabs in |- *; case (Rcase_abs 2); auto.
+  intro; cut (0 < 2).
+  intro; generalize (Rlt_asym 0 2 H7); intro; elimtype False; auto.
+  fourier.
+  apply Rabs_no_R0.
+  discrR.
 Qed.
 
 
 (*********)
 Lemma Dconst :
- forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0.
-unfold D_in in |- *; intros; unfold limit1_in in |- *;
- unfold limit_in in |- *; unfold Rdiv in |- *; intros; 
- simpl in |- *; split with eps; split; auto.
-intros; rewrite (Rminus_diag_eq y y (refl_equal y)); rewrite Rmult_0_l;
- unfold R_dist in |- *; rewrite (Rminus_diag_eq 0 0 (refl_equal 0));
- unfold Rabs in |- *; case (Rcase_abs 0); intro.
-absurd (0 < 0); auto.
-red in |- *; intro; apply (Rlt_irrefl 0 H1).
-unfold Rgt in H0; assumption.
+  forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0.
+Proof.
+  unfold D_in in |- *; intros; unfold limit1_in in |- *;
+    unfold limit_in in |- *; unfold Rdiv in |- *; intros; 
+      simpl in |- *; split with eps; split; auto.
+  intros; rewrite (Rminus_diag_eq y y (refl_equal y)); rewrite Rmult_0_l;
+    unfold R_dist in |- *; rewrite (Rminus_diag_eq 0 0 (refl_equal 0));
+      unfold Rabs in |- *; case (Rcase_abs 0); intro.
+  absurd (0 < 0); auto.
+  red in |- *; intro; apply (Rlt_irrefl 0 H1).
+  unfold Rgt in H0; assumption.
 Qed.
 
 (*********)
 Lemma Dx :
- forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0.
-unfold D_in in |- *; unfold Rdiv in |- *; intros; unfold limit1_in in |- *;
- unfold limit_in in |- *; intros; simpl in |- *; split with eps; 
- split; auto.
-intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros;
- rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3)));
- unfold R_dist in |- *; rewrite (Rminus_diag_eq 1 1 (refl_equal 1));
- unfold Rabs in |- *; case (Rcase_abs 0); intro.
-absurd (0 < 0); auto.
-red in |- *; intro; apply (Rlt_irrefl 0 r).
-unfold Rgt in H; assumption.
+  forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0.
+Proof.
+  unfold D_in in |- *; unfold Rdiv in |- *; intros; unfold limit1_in in |- *;
+    unfold limit_in in |- *; intros; simpl in |- *; split with eps; 
+      split; auto.
+  intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros;
+    rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3)));
+      unfold R_dist in |- *; rewrite (Rminus_diag_eq 1 1 (refl_equal 1));
+        unfold Rabs in |- *; case (Rcase_abs 0); intro.
+  absurd (0 < 0); auto.
+  red in |- *; intro; apply (Rlt_irrefl 0 r).
+  unfold Rgt in H; assumption.
 Qed. 
 
 (*********)
 Lemma Dadd :
- forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
-   D_in f df D x0 ->
-   D_in g dg D x0 ->
-   D_in (fun x:R => f x + g x) (fun x:R => df x + dg x) D x0.
-unfold D_in in |- *; intros;
- generalize
-  (limit_plus (fun x:R => (f x - f x0) * / (x - x0))
-     (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) (
-     df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in in |- *;
- unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0); 
- clear H; intros; elim H; clear H; intros; split with x; 
- split; auto; intros; generalize (H1 x1 H2); clear H1; 
- intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
- rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
- rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0))
-   in H1;
- rewrite (Rmult_comm (/ (x1 - x0)) (f x1 - f x0 + (g x1 - g x0))) in H1;
- cut (f x1 - f x0 + (g x1 - g x0) = f x1 + g x1 - (f x0 + g x0)).
-intro; rewrite H3 in H1; assumption.
-ring.
+  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
+    D_in f df D x0 ->
+    D_in g dg D x0 ->
+    D_in (fun x:R => f x + g x) (fun x:R => df x + dg x) D x0.
+Proof.
+  unfold D_in in |- *; intros;
+    generalize
+      (limit_plus (fun x:R => (f x - f x0) * / (x - x0))
+        (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) (
+          df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in in |- *;
+      unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0); 
+        clear H; intros; elim H; clear H; intros; split with x; 
+          split; auto; intros; generalize (H1 x1 H2); clear H1; 
+            intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
+              rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
+                rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0))
+                  in H1;
+                  rewrite (Rmult_comm (/ (x1 - x0)) (f x1 - f x0 + (g x1 - g x0))) in H1;
+                    cut (f x1 - f x0 + (g x1 - g x0) = f x1 + g x1 - (f x0 + g x0)).
+  intro; rewrite H3 in H1; assumption.
+  ring.
 Qed.
 
 (*********)
 Lemma Dmult :
- forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
-   D_in f df D x0 ->
-   D_in g dg D x0 ->
-   D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0.
-intros; unfold D_in in |- *; generalize H H0; intros; unfold D_in in H, H0;
- generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *; 
- intro;
- generalize
-  (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) (
-     fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); 
- intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0).
-intro;
- generalize
-  (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
-     fun _:R => g x0) (D_x D x0) (df x0) (g x0) x0 H H5);
- clear H H0 H1 H2 H3 H5; intro;
- generalize
-  (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0)
-     (fun x:R => (g x - g x0) * / (x - x0) * f x) (
-     D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); 
- clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; 
- simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; intros; elim (H eps H0); clear H; intros; 
- elim H; clear H; intros; split with x; split; auto; 
- intros; generalize (H1 x1 H2); clear H1; intro;
- rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
- rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
- rewrite (Rmult_assoc (/ (x1 - x0)) (f x1 - f x0) (g x0)) in H1;
- rewrite (Rmult_assoc (/ (x1 - x0)) (g x1 - g x0) (f x1)) in H1;
- rewrite <-
-  (Rmult_plus_distr_l (/ (x1 - x0)) ((f x1 - f x0) * g x0)
-     ((g x1 - g x0) * f x1)) in H1;
- rewrite
-  (Rmult_comm (/ (x1 - x0)) ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1))
-   in H1; rewrite (Rmult_comm (dg x0) (f x0)) in H1;
- cut
-  ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1 = f x1 * g x1 - f x0 * g x0).
-intro; rewrite H3 in H1; assumption.
-ring.
-unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
- split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0));
- intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H; 
- assumption.
+  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
+    D_in f df D x0 ->
+    D_in g dg D x0 ->
+    D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0.
+Proof.
+  intros; unfold D_in in |- *; generalize H H0; intros; unfold D_in in H, H0;
+    generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *; 
+      intro;
+        generalize
+          (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) (
+            fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); 
+          intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0).
+  intro;
+    generalize
+      (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
+        fun _:R => g x0) (D_x D x0) (df x0) (g x0) x0 H H5);
+      clear H H0 H1 H2 H3 H5; intro;
+        generalize
+          (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0)
+            (fun x:R => (g x - g x0) * / (x - x0) * f x) (
+              D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); 
+          clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; 
+            simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *; 
+              simpl in |- *; intros; elim (H eps H0); clear H; intros; 
+                elim H; clear H; intros; split with x; split; auto; 
+                  intros; generalize (H1 x1 H2); clear H1; intro;
+                    rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
+                      rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
+                        rewrite (Rmult_assoc (/ (x1 - x0)) (f x1 - f x0) (g x0)) in H1;
+                          rewrite (Rmult_assoc (/ (x1 - x0)) (g x1 - g x0) (f x1)) in H1;
+                            rewrite <-
+                              (Rmult_plus_distr_l (/ (x1 - x0)) ((f x1 - f x0) * g x0)
+                                ((g x1 - g x0) * f x1)) in H1;
+                              rewrite
+                                (Rmult_comm (/ (x1 - x0)) ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1))
+                                in H1; rewrite (Rmult_comm (dg x0) (f x0)) in H1;
+                                  cut
+                                    ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1 = f x1 * g x1 - f x0 * g x0).
+  intro; rewrite H3 in H1; assumption.
+  ring.
+  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+    split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0));
+      intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H; 
+        assumption.
 Qed.
 
 (*********)
 Lemma Dmult_const :
- forall (D:R -> Prop) (f df:R -> R) (x0 a:R),
-   D_in f df D x0 -> D_in (fun x:R => a * f x) (fun x:R => a * df x) D x0.
-intros;
- generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H);
- unfold D_in in |- *; intros; rewrite (Rmult_0_l (f x0)) in H0;
- rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; 
- assumption.
+  forall (D:R -> Prop) (f df:R -> R) (x0 a:R),
+    D_in f df D x0 -> D_in (fun x:R => a * f x) (fun x:R => a * df x) D x0.
+Proof.
+  intros;
+    generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H);
+      unfold D_in in |- *; intros; rewrite (Rmult_0_l (f x0)) in H0;
+        rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; 
+          assumption.
 Qed.
 
 (*********)
 Lemma Dopp :
- forall (D:R -> Prop) (f df:R -> R) (x0:R),
-   D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0.
-intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- intros; generalize (H0 eps H1); clear H0; intro; elim H0; 
- clear H0; intros; elim H0; clear H0; simpl in |- *; 
- intros; split with x; split; auto.
-intros; generalize (H2 x1 H3); clear H2; intro;
- rewrite Ropp_mult_distr_l_reverse in H2;
- rewrite Ropp_mult_distr_l_reverse in H2;
- rewrite Ropp_mult_distr_l_reverse in H2;
- rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2;
- rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2;
- rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; 
- assumption.
+  forall (D:R -> Prop) (f df:R -> R) (x0:R),
+    D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0.
+Proof.
+  intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      intros; generalize (H0 eps H1); clear H0; intro; elim H0; 
+        clear H0; intros; elim H0; clear H0; simpl in |- *; 
+          intros; split with x; split; auto.
+  intros; generalize (H2 x1 H3); clear H2; intro;
+    rewrite Ropp_mult_distr_l_reverse in H2;
+      rewrite Ropp_mult_distr_l_reverse in H2;
+        rewrite Ropp_mult_distr_l_reverse in H2;
+          rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2;
+            rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2;
+              rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; 
+                assumption.
 Qed.
 
 (*********)
 Lemma Dminus :
- forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
-   D_in f df D x0 ->
-   D_in g dg D x0 ->
-   D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0.
-unfold Rminus in |- *; intros; generalize (Dopp D g dg x0 H0); intro;
- apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); 
- assumption. 
+  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
+    D_in f df D x0 ->
+    D_in g dg D x0 ->
+    D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0.
+Proof.
+  unfold Rminus in |- *; intros; generalize (Dopp D g dg x0 H0); intro;
+    apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); 
+      assumption. 
 Qed.
 
 (*********)
 Lemma Dx_pow_n :
- forall (n:nat) (D:R -> Prop) (x0:R),
-   D_in (fun x:R => x ^ n) (fun x:R => INR n * x ^ (n - 1)) D x0.
-simple induction n; intros.
-simpl in |- *; rewrite Rmult_0_l; apply Dconst.
-intros; cut (n0 = (S n0 - 1)%nat);
- [ intro a; rewrite <- a; clear a | simpl in |- *; apply minus_n_O ].
-generalize
- (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) (
-    fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) (
-    H D x0)); unfold D_in in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1); 
- clear H0; intros; elim H0; clear H0; intros; split with x; 
- split; auto.
-intros; generalize (H2 x1 H3); clear H2 H3; intro;
- rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2;
- rewrite (tech_pow_Rmult x1 n0) in H2; rewrite (tech_pow_Rmult x0 n0) in H2;
- rewrite (Rmult_comm (INR n0) (x0 ^ (n0 - 1))) in H2;
- rewrite <- (Rmult_assoc x0 (x0 ^ (n0 - 1)) (INR n0)) in H2;
- rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (classic (n0 = 0%nat));
- intro cond.
-rewrite cond in H2; rewrite cond; simpl in H2; simpl in |- *;
- cut (1 + x0 * 1 * 0 = 1 * 1);
- [ intro A; rewrite A in H2; assumption | ring ].
-cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | omega ];
- rewrite (H3 cond) in H2; rewrite (Rmult_comm (x0 ^ n0) (INR n0)) in H2;
- rewrite (tech_pow_Rplus x0 n0 n0) in H2; assumption.
+  forall (n:nat) (D:R -> Prop) (x0:R),
+    D_in (fun x:R => x ^ n) (fun x:R => INR n * x ^ (n - 1)) D x0.
+Proof.
+  simple induction n; intros.
+  simpl in |- *; rewrite Rmult_0_l; apply Dconst.
+  intros; cut (n0 = (S n0 - 1)%nat);
+    [ intro a; rewrite <- a; clear a | simpl in |- *; apply minus_n_O ].
+  generalize
+    (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) (
+      fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) (
+        H D x0)); unfold D_in in |- *; unfold limit1_in in |- *;
+    unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1); 
+      clear H0; intros; elim H0; clear H0; intros; split with x; 
+        split; auto.
+  intros; generalize (H2 x1 H3); clear H2 H3; intro;
+    rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2;
+      rewrite (tech_pow_Rmult x1 n0) in H2; rewrite (tech_pow_Rmult x0 n0) in H2;
+        rewrite (Rmult_comm (INR n0) (x0 ^ (n0 - 1))) in H2;
+          rewrite <- (Rmult_assoc x0 (x0 ^ (n0 - 1)) (INR n0)) in H2;
+            rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (classic (n0 = 0%nat));
+              intro cond.
+  rewrite cond in H2; rewrite cond; simpl in H2; simpl in |- *;
+    cut (1 + x0 * 1 * 0 = 1 * 1);
+      [ intro A; rewrite A in H2; assumption | ring ].
+  cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | omega ];
+    rewrite (H3 cond) in H2; rewrite (Rmult_comm (x0 ^ n0) (INR n0)) in H2;
+      rewrite (tech_pow_Rplus x0 n0 n0) in H2; assumption.
 Qed.
 
 (*********)
 Lemma Dcomp :
- forall (Df Dg:R -> Prop) (df dg f g:R -> R) (x0:R),
-   D_in f df Df x0 ->
-   D_in g dg Dg (f x0) ->
-   D_in (fun x:R => g (f x)) (fun x:R => df x * dg (f x)) (Dgf Df Dg f) x0.
-intros Df Dg df dg f g x0 H H0; generalize H H0; unfold D_in in |- *;
- unfold Rdiv in |- *; intros;
- generalize
-  (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) (
-     D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); 
- intro; generalize (cont_deriv f df Df x0 H); intro; 
- unfold continue_in in H4; generalize (H3 H4 H2); clear H3; 
- intro;
- generalize
-  (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0))
-     (fun x:R => (f x - f x0) * / (x - x0))
-     (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (dg (f x0)) (
-     df x0) x0 H3); intro;
- cut
-  (limit1_in (fun x:R => (f x - f x0) * / (x - x0))
-     (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (df x0) x0).
-intro; generalize (H5 H6); clear H5; intro;
- generalize
-  (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
-     fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1
-     (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); 
- intro; unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; unfold limit1_in in H5, H7; unfold limit_in in H5, H7;
- simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); 
- clear H5 H7; intros; elim H5; elim H7; clear H5 H7; 
- intros; split with (Rmin x x1); split.
-elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b.
-intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0));
- intros a b; clear b; unfold Rgt in a; elim (a H12); 
- clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; 
- clear H12; elim (classic (f x2 = f x0)); intro.
-elim H11; clear H11; intros; elim H11; clear H11; intros;
- generalize (H10 x2 (conj (conj H11 H14) H5)); intro;
- rewrite (Rminus_diag_eq (f x2) (f x0) H12) in H16;
- rewrite (Rmult_0_l (/ (x2 - x0))) in H16;
- rewrite (Rmult_0_l (dg (f x0))) in H16; rewrite H12;
- rewrite (Rminus_diag_eq (g (f x0)) (g (f x0)) (refl_equal (g (f x0))));
- rewrite (Rmult_0_l (/ (x2 - x0))); assumption.
-clear H10 H5; elim H11; clear H11; intros; elim H5; clear H5; intros;
- cut
-  (((Df x2 /\ x0 <> x2) /\ Dg (f x2) /\ f x0 <> f x2) /\ R_dist x2 x0 < x1);
- auto; intro; generalize (H7 x2 H14); intro;
- generalize (Rminus_eq_contra (f x2) (f x0) H12); intro;
- rewrite
-  (Rmult_assoc (g (f x2) - g (f x0)) (/ (f x2 - f x0))
-     ((f x2 - f x0) * / (x2 - x0))) in H15;
- rewrite <- (Rmult_assoc (/ (f x2 - f x0)) (f x2 - f x0) (/ (x2 - x0)))
-   in H15; rewrite (Rinv_l (f x2 - f x0) H16) in H15;
- rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15;
- rewrite (Rmult_comm (df x0) (dg (f x0))); assumption.
-clear H5 H3 H4 H2; unfold limit1_in in |- *; unfold limit_in in |- *;
- simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1; 
- simpl in H1; intros; elim (H1 eps H2); clear H1; intros; 
- elim H1; clear H1; intros; split with x; split; auto; 
- intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; 
- intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)).
+  forall (Df Dg:R -> Prop) (df dg f g:R -> R) (x0:R),
+    D_in f df Df x0 ->
+    D_in g dg Dg (f x0) ->
+    D_in (fun x:R => g (f x)) (fun x:R => df x * dg (f x)) (Dgf Df Dg f) x0.
+Proof.
+  intros Df Dg df dg f g x0 H H0; generalize H H0; unfold D_in in |- *;
+    unfold Rdiv in |- *; intros;
+      generalize
+        (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) (
+          D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); 
+        intro; generalize (cont_deriv f df Df x0 H); intro; 
+          unfold continue_in in H4; generalize (H3 H4 H2); clear H3; 
+            intro;
+              generalize
+                (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0))
+                  (fun x:R => (f x - f x0) * / (x - x0))
+                  (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (dg (f x0)) (
+                    df x0) x0 H3); intro;
+                cut
+                  (limit1_in (fun x:R => (f x - f x0) * / (x - x0))
+                    (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (df x0) x0).
+  intro; generalize (H5 H6); clear H5; intro;
+    generalize
+      (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
+        fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1
+      (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); 
+      intro; unfold limit1_in in |- *; unfold limit_in in |- *; 
+        simpl in |- *; unfold limit1_in in H5, H7; unfold limit_in in H5, H7;
+          simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); 
+            clear H5 H7; intros; elim H5; elim H7; clear H5 H7; 
+              intros; split with (Rmin x x1); split.
+  elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b.
+  intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0));
+    intros a b; clear b; unfold Rgt in a; elim (a H12); 
+      clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; 
+        clear H12; elim (classic (f x2 = f x0)); intro.
+  elim H11; clear H11; intros; elim H11; clear H11; intros;
+    generalize (H10 x2 (conj (conj H11 H14) H5)); intro;
+      rewrite (Rminus_diag_eq (f x2) (f x0) H12) in H16;
+        rewrite (Rmult_0_l (/ (x2 - x0))) in H16;
+          rewrite (Rmult_0_l (dg (f x0))) in H16; rewrite H12;
+            rewrite (Rminus_diag_eq (g (f x0)) (g (f x0)) (refl_equal (g (f x0))));
+              rewrite (Rmult_0_l (/ (x2 - x0))); assumption.
+  clear H10 H5; elim H11; clear H11; intros; elim H5; clear H5; intros;
+    cut
+      (((Df x2 /\ x0 <> x2) /\ Dg (f x2) /\ f x0 <> f x2) /\ R_dist x2 x0 < x1);
+      auto; intro; generalize (H7 x2 H14); intro;
+        generalize (Rminus_eq_contra (f x2) (f x0) H12); intro;
+          rewrite
+            (Rmult_assoc (g (f x2) - g (f x0)) (/ (f x2 - f x0))
+              ((f x2 - f x0) * / (x2 - x0))) in H15;
+            rewrite <- (Rmult_assoc (/ (f x2 - f x0)) (f x2 - f x0) (/ (x2 - x0)))
+              in H15; rewrite (Rinv_l (f x2 - f x0) H16) in H15;
+                rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15;
+                  rewrite (Rmult_comm (df x0) (dg (f x0))); assumption.
+  clear H5 H3 H4 H2; unfold limit1_in in |- *; unfold limit_in in |- *;
+    simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1; 
+      simpl in H1; intros; elim (H1 eps H2); clear H1; intros; 
+        elim H1; clear H1; intros; split with x; split; auto; 
+          intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; 
+            intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)).
 Qed.   
 
 (*********)
 Lemma D_pow_n :
- forall (n:nat) (D:R -> Prop) (x0:R) (expr dexpr:R -> R),
-   D_in expr dexpr D x0 ->
-   D_in (fun x:R => expr x ^ n)
-     (fun x:R => INR n * expr x ^ (n - 1) * dexpr x) (
-     Dgf D D expr) x0.
-intros n D x0 expr dexpr H;
- generalize
-  (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr (
-     fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); 
- intro; unfold D_in in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; simpl in |- *; intros; unfold D_in in H0;
- unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; 
- elim (H0 eps H1); clear H0; intros; elim H0; clear H0; 
- intros; split with x; split; intros; auto.
-cut
- (dexpr x0 * (INR n * expr x0 ^ (n - 1)) =
-  INR n * expr x0 ^ (n - 1) * dexpr x0);
- [ intro Rew; rewrite <- Rew; exact (H2 x1 H3) | ring ].
+  forall (n:nat) (D:R -> Prop) (x0:R) (expr dexpr:R -> R),
+    D_in expr dexpr D x0 ->
+    D_in (fun x:R => expr x ^ n)
+    (fun x:R => INR n * expr x ^ (n - 1) * dexpr x) (
+      Dgf D D expr) x0.
+Proof.
+  intros n D x0 expr dexpr H;
+    generalize
+      (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr (
+        fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); 
+      intro; unfold D_in in |- *; unfold limit1_in in |- *;
+        unfold limit_in in |- *; simpl in |- *; intros; unfold D_in in H0;
+          unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; 
+            elim (H0 eps H1); clear H0; intros; elim H0; clear H0; 
+              intros; split with x; split; intros; auto.
+  cut
+    (dexpr x0 * (INR n * expr x0 ^ (n - 1)) =
+      INR n * expr x0 ^ (n - 1) * dexpr x0);
+    [ intro Rew; rewrite <- Rew; exact (H2 x1 H3) | ring ].
 Qed.
diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v
index 5e4b3e7b..906f4977 100644
--- a/theories/Reals/Reals.v
+++ b/theories/Reals/Reals.v
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Reals.v,v 1.24.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Reals.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
-(* The library REALS is divided in 6 parts :
+(** The library REALS is divided in 6 parts :
    - Rbase: basic lemmas on R
             equalities and inequalities
             Ring and Field are instantiated on R
diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
index cdff9fcb..3d1c0375 100644
--- a/theories/Reals/Rfunctions.v
+++ b/theories/Reals/Rfunctions.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rfunctions.v,v 1.31.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+(*i $Id: Rfunctions.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 (*i Some properties about pow and sum have been made with John Harrison i*)
 (*i Some Lemmas (about pow and powerRZ) have been done by Laurent Thery i*)
@@ -15,8 +15,10 @@
 (**          Definition of the sum functions            *)
 (*                                                      *)
 (********************************************************)
+Require Export ArithRing.
 
 Require Import Rbase.
+Require Export Rpow_def.
 Require Export R_Ifp.
 Require Export Rbasic_fun.
 Require Export R_sqr.
@@ -29,498 +31,491 @@ Open Local Scope nat_scope.
 Open Local Scope R_scope.
 
 (*******************************)
-(**  Lemmas about factorial    *)
+(** * Lemmas about factorial   *)
 (*******************************)
 (*********)
 Lemma INR_fact_neq_0 : forall n:nat, INR (fact n) <> 0.
 Proof.
-intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n));
- assumption.
+  intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n));
+    assumption.
 Qed.    
 
 (*********)
 Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n)%nat.
 Proof.
-intro; reflexivity.
+  intro; reflexivity.
 Qed. 
 
 (*********)
 Lemma simpl_fact :
- forall n:nat, / INR (fact (S n)) * / / INR (fact n) = / INR (S n).
+  forall n:nat, / INR (fact (S n)) * / / INR (fact n) = / INR (S n).
 Proof.
-intro; rewrite (Rinv_involutive (INR (fact n)) (INR_fact_neq_0 n));
- unfold fact at 1 in |- *; cbv beta iota in |- *; fold fact in |- *;
- rewrite (mult_INR (S n) (fact n));
- rewrite (Rinv_mult_distr (INR (S n)) (INR (fact n))).
-rewrite (Rmult_assoc (/ INR (S n)) (/ INR (fact n)) (INR (fact n)));
- rewrite (Rinv_l (INR (fact n)) (INR_fact_neq_0 n));
- apply (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1).
-apply not_O_INR; auto.
-apply INR_fact_neq_0.
+  intro; rewrite (Rinv_involutive (INR (fact n)) (INR_fact_neq_0 n));
+    unfold fact at 1 in |- *; cbv beta iota in |- *; fold fact in |- *;
+      rewrite (mult_INR (S n) (fact n));
+        rewrite (Rinv_mult_distr (INR (S n)) (INR (fact n))).
+  rewrite (Rmult_assoc (/ INR (S n)) (/ INR (fact n)) (INR (fact n)));
+    rewrite (Rinv_l (INR (fact n)) (INR_fact_neq_0 n));
+      apply (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1).
+  apply not_O_INR; auto.
+  apply INR_fact_neq_0.
 Qed.
 
 (*******************************)
-(*          Power              *)
+(** *       Power              *)
 (*******************************)
 (*********)
-Fixpoint pow (r:R) (n:nat) {struct n} : R :=
-  match n with
-  | O => 1
-  | S n => r * pow r n
-  end.
 
 Infix "^" := pow : R_scope.
 
 Lemma pow_O : forall x:R, x ^ 0 = 1.
 Proof.
-reflexivity.
+  reflexivity.
 Qed.
- 
+
 Lemma pow_1 : forall x:R, x ^ 1 = x.
 Proof.
-simpl in |- *; auto with real.
+  simpl in |- *; auto with real.
 Qed.
- 
+
 Lemma pow_add : forall (x:R) (n m:nat), x ^ (n + m) = x ^ n * x ^ m.
 Proof.
-intros x n; elim n; simpl in |- *; auto with real.
-intros n0 H' m; rewrite H'; auto with real.
+  intros x n; elim n; simpl in |- *; auto with real.
+  intros n0 H' m; rewrite H'; auto with real.
 Qed.
 
 Lemma pow_nonzero : forall (x:R) (n:nat), x <> 0 -> x ^ n <> 0.
 Proof.
-intro; simple induction n; simpl in |- *.
-intro; red in |- *; intro; apply R1_neq_R0; assumption.
-intros; red in |- *; intro; elim (Rmult_integral x (x ^ n0) H1).
-intro; auto.
-apply H; assumption.
+  intro; simple induction n; simpl in |- *.
+  intro; red in |- *; intro; apply R1_neq_R0; assumption.
+  intros; red in |- *; intro; elim (Rmult_integral x (x ^ n0) H1).
+  intro; auto.
+  apply H; assumption.
 Qed.
 
 Hint Resolve pow_O pow_1 pow_add pow_nonzero: real.
- 
+
 Lemma pow_RN_plus :
- forall (x:R) (n m:nat), x <> 0 -> x ^ n = x ^ (n + m) * / x ^ m.
+  forall (x:R) (n m:nat), x <> 0 -> x ^ n = x ^ (n + m) * / x ^ m.
 Proof.
-intros x n; elim n; simpl in |- *; auto with real.
-intros n0 H' m H'0.
-rewrite Rmult_assoc; rewrite <- H'; auto.
+  intros x n; elim n; simpl in |- *; auto with real.
+  intros n0 H' m H'0.
+  rewrite Rmult_assoc; rewrite <- H'; auto.
 Qed.
 
 Lemma pow_lt : forall (x:R) (n:nat), 0 < x -> 0 < x ^ n.
 Proof.
-intros x n; elim n; simpl in |- *; auto with real.
-intros n0 H' H'0; replace 0 with (x * 0); auto with real.
+  intros x n; elim n; simpl in |- *; auto with real.
+  intros n0 H' H'0; replace 0 with (x * 0); auto with real.
 Qed.
 Hint Resolve pow_lt: real.
 
 Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n.
 Proof.
-intros x n; elim n; simpl in |- *; auto with real.
-intros H' H'0; elimtype False; omega.
-intros n0; case n0.
-simpl in |- *; rewrite Rmult_1_r; auto.
-intros n1 H' H'0 H'1.
-replace 1 with (1 * 1); auto with real.
-apply Rlt_trans with (r2 := x * 1); auto with real.
-apply Rmult_lt_compat_l; auto with real.
-apply Rlt_trans with (r2 := 1); auto with real.
-apply H'; auto with arith.
+  intros x n; elim n; simpl in |- *; auto with real.
+  intros H' H'0; elimtype False; omega.
+  intros n0; case n0.
+  simpl in |- *; rewrite Rmult_1_r; auto.
+  intros n1 H' H'0 H'1.
+  replace 1 with (1 * 1); auto with real.
+  apply Rlt_trans with (r2 := x * 1); auto with real.
+  apply Rmult_lt_compat_l; auto with real.
+  apply Rlt_trans with (r2 := 1); auto with real.
+  apply H'; auto with arith.
 Qed.
 Hint Resolve Rlt_pow_R1: real.
 
 Lemma Rlt_pow : forall (x:R) (n m:nat), 1 < x -> (n < m)%nat -> x ^ n < x ^ m.
 Proof.
-intros x n m H' H'0; replace m with (m - n + n)%nat.
-rewrite pow_add.
-pattern (x ^ n) at 1 in |- *; replace (x ^ n) with (1 * x ^ n);
- auto with real.
-apply Rminus_lt.
-repeat rewrite (fun y:R => Rmult_comm y (x ^ n));
- rewrite <- Rmult_minus_distr_l.
-replace 0 with (x ^ n * 0); auto with real.
-apply Rmult_lt_compat_l; auto with real.
-apply pow_lt; auto with real.
-apply Rlt_trans with (r2 := 1); auto with real.
-apply Rlt_minus; auto with real.
-apply Rlt_pow_R1; auto with arith.
-apply plus_lt_reg_l with (p := n); auto with arith.
-rewrite le_plus_minus_r; auto with arith; rewrite <- plus_n_O; auto.
-rewrite plus_comm; auto with arith.
+  intros x n m H' H'0; replace m with (m - n + n)%nat.
+  rewrite pow_add.
+  pattern (x ^ n) at 1 in |- *; replace (x ^ n) with (1 * x ^ n);
+    auto with real.
+  apply Rminus_lt.
+  repeat rewrite (fun y:R => Rmult_comm y (x ^ n));
+    rewrite <- Rmult_minus_distr_l.
+  replace 0 with (x ^ n * 0); auto with real.
+  apply Rmult_lt_compat_l; auto with real.
+  apply pow_lt; auto with real.
+  apply Rlt_trans with (r2 := 1); auto with real.
+  apply Rlt_minus; auto with real.
+  apply Rlt_pow_R1; auto with arith.
+  apply plus_lt_reg_l with (p := n); auto with arith.
+  rewrite le_plus_minus_r; auto with arith; rewrite <- plus_n_O; auto.
+  rewrite plus_comm; auto with arith.
 Qed.
 Hint Resolve Rlt_pow: real.
 
 (*********)
 Lemma tech_pow_Rmult : forall (x:R) (n:nat), x * x ^ n = x ^ S n.
 Proof.
-simple induction n; simpl in |- *; trivial.
+  simple induction n; simpl in |- *; trivial.
 Qed.
 
 (*********)
 Lemma tech_pow_Rplus :
- forall (x:R) (a n:nat), x ^ a + INR n * x ^ a = INR (S n) * x ^ a.
+  forall (x:R) (a n:nat), x ^ a + INR n * x ^ a = INR (S n) * x ^ a.
 Proof.
-intros; pattern (x ^ a) at 1 in |- *;
- rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1);
- rewrite (Rmult_comm (INR n) (x ^ a));
- rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n));
- rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); 
- apply Rmult_comm.
+  intros; pattern (x ^ a) at 1 in |- *;
+    rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1);
+      rewrite (Rmult_comm (INR n) (x ^ a));
+        rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n));
+          rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); 
+            apply Rmult_comm.
 Qed.
 
 Lemma poly : forall (n:nat) (x:R), 0 < x -> 1 + INR n * x <= (1 + x) ^ n.
 Proof.
-intros; elim n.
-simpl in |- *; cut (1 + 0 * x = 1).
-intro; rewrite H0; unfold Rle in |- *; right; reflexivity.
-ring.
-intros; unfold pow in |- *; fold pow in |- *;
- apply
-  (Rle_trans (1 + INR (S n0) * x) ((1 + x) * (1 + INR n0 * x))
-     ((1 + x) * (1 + x) ^ n0)).
-cut ((1 + x) * (1 + INR n0 * x) = 1 + INR (S n0) * x + INR n0 * (x * x)).
-intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1 in |- *;
- rewrite <- (let (H1, H2) := Rplus_ne (1 + INR (S n0) * x) in H1);
- apply Rplus_le_compat_l; elim n0; intros.
-simpl in |- *; rewrite Rmult_0_l; unfold Rle in |- *; right; auto.
-unfold Rle in |- *; left; generalize Rmult_gt_0_compat; unfold Rgt in |- *;
- intro; fold (Rsqr x) in |- *;
- apply (H3 (INR (S n1)) (Rsqr x) (lt_INR_0 (S n1) (lt_O_Sn n1)));
- fold (x > 0) in H;
- apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))).
-rewrite (S_INR n0); ring.
-unfold Rle in H0; elim H0; intro. 
-unfold Rle in |- *; left; apply Rmult_lt_compat_l.
-rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)).
-assumption.
-rewrite H1; unfold Rle in |- *; right; trivial.
+  intros; elim n.
+  simpl in |- *; cut (1 + 0 * x = 1).
+  intro; rewrite H0; unfold Rle in |- *; right; reflexivity.
+  ring.
+  intros; unfold pow in |- *; fold pow in |- *;
+    apply
+      (Rle_trans (1 + INR (S n0) * x) ((1 + x) * (1 + INR n0 * x))
+        ((1 + x) * (1 + x) ^ n0)).
+  cut ((1 + x) * (1 + INR n0 * x) = 1 + INR (S n0) * x + INR n0 * (x * x)).
+  intro; rewrite H1; pattern (1 + INR (S n0) * x) at 1 in |- *;
+    rewrite <- (let (H1, H2) := Rplus_ne (1 + INR (S n0) * x) in H1);
+      apply Rplus_le_compat_l; elim n0; intros.
+  simpl in |- *; rewrite Rmult_0_l; unfold Rle in |- *; right; auto.
+  unfold Rle in |- *; left; generalize Rmult_gt_0_compat; unfold Rgt in |- *;
+    intro; fold (Rsqr x) in |- *;
+      apply (H3 (INR (S n1)) (Rsqr x) (lt_INR_0 (S n1) (lt_O_Sn n1)));
+        fold (x > 0) in H;
+          apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))).
+  rewrite (S_INR n0); ring.
+  unfold Rle in H0; elim H0; intro. 
+  unfold Rle in |- *; left; apply Rmult_lt_compat_l.
+  rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)).
+  assumption.
+  rewrite H1; unfold Rle in |- *; right; trivial.
 Qed.
 
 Lemma Power_monotonic :
- forall (x:R) (m n:nat),
-   Rabs x > 1 -> (m <= n)%nat -> Rabs (x ^ m) <= Rabs (x ^ n).
-Proof.
-intros x m n H; induction  n as [| n Hrecn]; intros; inversion H0.
-unfold Rle in |- *; right; reflexivity.
-unfold Rle in |- *; right; reflexivity.
-apply (Rle_trans (Rabs (x ^ m)) (Rabs (x ^ n)) (Rabs (x ^ S n))).
-apply Hrecn; assumption.
-simpl in |- *; rewrite Rabs_mult.
-pattern (Rabs (x ^ n)) at 1 in |- *.
-rewrite <- Rmult_1_r.
-rewrite (Rmult_comm (Rabs x) (Rabs (x ^ n))).
-apply Rmult_le_compat_l.
-apply Rabs_pos.
-unfold Rgt in H.
-apply Rlt_le; assumption.
+  forall (x:R) (m n:nat),
+    Rabs x > 1 -> (m <= n)%nat -> Rabs (x ^ m) <= Rabs (x ^ n).
+Proof.
+  intros x m n H; induction  n as [| n Hrecn]; intros; inversion H0.
+  unfold Rle in |- *; right; reflexivity.
+  unfold Rle in |- *; right; reflexivity.
+  apply (Rle_trans (Rabs (x ^ m)) (Rabs (x ^ n)) (Rabs (x ^ S n))).
+  apply Hrecn; assumption.
+  simpl in |- *; rewrite Rabs_mult.
+  pattern (Rabs (x ^ n)) at 1 in |- *.
+  rewrite <- Rmult_1_r.
+  rewrite (Rmult_comm (Rabs x) (Rabs (x ^ n))).
+  apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  unfold Rgt in H.
+  apply Rlt_le; assumption.
 Qed.
 
 Lemma RPow_abs : forall (x:R) (n:nat), Rabs x ^ n = Rabs (x ^ n).
 Proof.
-intro; simple induction n; simpl in |- *.
-apply sym_eq; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1.
-intros; rewrite H; apply sym_eq; apply Rabs_mult.
+  intro; simple induction n; simpl in |- *.
+  apply sym_eq; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1.
+  intros; rewrite H; apply sym_eq; apply Rabs_mult.
 Qed.
 
 
 Lemma Pow_x_infinity :
- forall x:R,
-   Rabs x > 1 ->
-   forall b:R,
+  forall x:R,
+    Rabs x > 1 ->
+    forall b:R,
       exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) >= b).
 Proof.
-intros; elim (archimed (b * / (Rabs x - 1))); intros; clear H1;
- cut (exists N : nat, INR N >= b * / (Rabs x - 1)).
-intro; elim H1; clear H1; intros; exists x0; intros;
- apply (Rge_trans (Rabs (x ^ n)) (Rabs (x ^ x0)) b).
-apply Rle_ge; apply Power_monotonic; assumption.
-rewrite <- RPow_abs; cut (Rabs x = 1 + (Rabs x - 1)).
-intro; rewrite H3;
- apply (Rge_trans ((1 + (Rabs x - 1)) ^ x0) (1 + INR x0 * (Rabs x - 1)) b).
-apply Rle_ge; apply poly; fold (Rabs x - 1 > 0) in |- *; apply Rgt_minus;
- assumption.
-apply (Rge_trans (1 + INR x0 * (Rabs x - 1)) (INR x0 * (Rabs x - 1)) b).
-apply Rle_ge; apply Rlt_le; rewrite (Rplus_comm 1 (INR x0 * (Rabs x - 1)));
- pattern (INR x0 * (Rabs x - 1)) at 1 in |- *;
- rewrite <- (let (H1, H2) := Rplus_ne (INR x0 * (Rabs x - 1)) in H1);
- apply Rplus_lt_compat_l; apply Rlt_0_1.
-cut (b = b * / (Rabs x - 1) * (Rabs x - 1)).
-intros; rewrite H4; apply Rmult_ge_compat_r.
-apply Rge_minus; unfold Rge in |- *; left; assumption.
-assumption.
-rewrite Rmult_assoc; rewrite Rinv_l.
-ring.
-apply Rlt_dichotomy_converse; right; apply Rgt_minus; assumption.
-ring.
-cut ((0 <= up (b * / (Rabs x - 1)))%Z \/ (up (b * / (Rabs x - 1)) <= 0)%Z).
-intros; elim H1; intro.
-elim (IZN (up (b * / (Rabs x - 1))) H2); intros; exists x0;
- apply
-  (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
-rewrite INR_IZR_INZ; apply IZR_ge; omega.
-unfold Rge in |- *; left; assumption.
-exists 0%nat;
- apply
-  (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
-rewrite INR_IZR_INZ; apply IZR_ge; simpl in |- *; omega.
-unfold Rge in |- *; left; assumption.
-omega.
+  intros; elim (archimed (b * / (Rabs x - 1))); intros; clear H1;
+    cut (exists N : nat, INR N >= b * / (Rabs x - 1)).
+  intro; elim H1; clear H1; intros; exists x0; intros;
+    apply (Rge_trans (Rabs (x ^ n)) (Rabs (x ^ x0)) b).
+  apply Rle_ge; apply Power_monotonic; assumption.
+  rewrite <- RPow_abs; cut (Rabs x = 1 + (Rabs x - 1)).
+  intro; rewrite H3;
+    apply (Rge_trans ((1 + (Rabs x - 1)) ^ x0) (1 + INR x0 * (Rabs x - 1)) b).
+  apply Rle_ge; apply poly; fold (Rabs x - 1 > 0) in |- *; apply Rgt_minus;
+    assumption.
+  apply (Rge_trans (1 + INR x0 * (Rabs x - 1)) (INR x0 * (Rabs x - 1)) b).
+  apply Rle_ge; apply Rlt_le; rewrite (Rplus_comm 1 (INR x0 * (Rabs x - 1)));
+    pattern (INR x0 * (Rabs x - 1)) at 1 in |- *;
+      rewrite <- (let (H1, H2) := Rplus_ne (INR x0 * (Rabs x - 1)) in H1);
+        apply Rplus_lt_compat_l; apply Rlt_0_1.
+  cut (b = b * / (Rabs x - 1) * (Rabs x - 1)).
+  intros; rewrite H4; apply Rmult_ge_compat_r.
+  apply Rge_minus; unfold Rge in |- *; left; assumption.
+  assumption.
+  rewrite Rmult_assoc; rewrite Rinv_l.
+  ring.
+  apply Rlt_dichotomy_converse; right; apply Rgt_minus; assumption.
+  ring.
+  cut ((0 <= up (b * / (Rabs x - 1)))%Z \/ (up (b * / (Rabs x - 1)) <= 0)%Z).
+  intros; elim H1; intro.
+  elim (IZN (up (b * / (Rabs x - 1))) H2); intros; exists x0;
+    apply
+      (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
+  rewrite INR_IZR_INZ; apply IZR_ge; omega.
+  unfold Rge in |- *; left; assumption.
+  exists 0%nat;
+    apply
+      (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))).
+  rewrite INR_IZR_INZ; apply IZR_ge; simpl in |- *; omega.
+  unfold Rge in |- *; left; assumption.
+  omega.
 Qed.
 
 Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0.
 Proof.
-simple induction n.
-simpl in |- *; auto.
-intros; elim H; reflexivity.
-intros; simpl in |- *; apply Rmult_0_l.
+  simple induction n.
+  simpl in |- *; auto.
+  intros; elim H; reflexivity.
+  intros; simpl in |- *; apply Rmult_0_l.
 Qed.
 
 Lemma Rinv_pow : forall (x:R) (n:nat), x <> 0 -> / x ^ n = (/ x) ^ n.
 Proof.
-intros; elim n; simpl in |- *.
-apply Rinv_1.
-intro m; intro; rewrite Rinv_mult_distr.
-rewrite H0; reflexivity; assumption.
-assumption.
-apply pow_nonzero; assumption.
+  intros; elim n; simpl in |- *.
+  apply Rinv_1.
+  intro m; intro; rewrite Rinv_mult_distr.
+  rewrite H0; reflexivity; assumption.
+  assumption.
+  apply pow_nonzero; assumption.
 Qed.
 
 Lemma pow_lt_1_zero :
- forall x:R,
-   Rabs x < 1 ->
-   forall y:R,
-     0 < y ->
+  forall x:R,
+    Rabs x < 1 ->
+    forall y:R,
+      0 < y ->
       exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) < y).
 Proof.
-intros; elim (Req_dec x 0); intro. 
-exists 1%nat; rewrite H1; intros n GE; rewrite pow_ne_zero.
-rewrite Rabs_R0; assumption.
-inversion GE; auto.
-cut (Rabs (/ x) > 1).
-intros; elim (Pow_x_infinity (/ x) H2 (/ y + 1)); intros N.
-exists N; intros; rewrite <- (Rinv_involutive y).
-rewrite <- (Rinv_involutive (Rabs (x ^ n))).
-apply Rinv_lt_contravar.
-apply Rmult_lt_0_compat.
-apply Rinv_0_lt_compat.
-assumption.
-apply Rinv_0_lt_compat.
-apply Rabs_pos_lt.
-apply pow_nonzero.
-assumption.
-rewrite <- Rabs_Rinv.
-rewrite Rinv_pow.
-apply (Rlt_le_trans (/ y) (/ y + 1) (Rabs ((/ x) ^ n))).
-pattern (/ y) at 1 in |- *.
-rewrite <- (let (H1, H2) := Rplus_ne (/ y) in H1).
-apply Rplus_lt_compat_l.
-apply Rlt_0_1.
-apply Rge_le.
-apply H3.
-assumption.
-assumption.
-apply pow_nonzero.
-assumption.
-apply Rabs_no_R0.
-apply pow_nonzero.
-assumption.
-apply Rlt_dichotomy_converse.
-right; unfold Rgt in |- *; assumption.
-rewrite <- (Rinv_involutive 1).
-rewrite Rabs_Rinv.
-unfold Rgt in |- *; apply Rinv_lt_contravar.
-apply Rmult_lt_0_compat.
-apply Rabs_pos_lt.
-assumption.
-rewrite Rinv_1; apply Rlt_0_1.
-rewrite Rinv_1; assumption.
-assumption.
-red in |- *; intro; apply R1_neq_R0; assumption.
+  intros; elim (Req_dec x 0); intro. 
+  exists 1%nat; rewrite H1; intros n GE; rewrite pow_ne_zero.
+  rewrite Rabs_R0; assumption.
+  inversion GE; auto.
+  cut (Rabs (/ x) > 1).
+  intros; elim (Pow_x_infinity (/ x) H2 (/ y + 1)); intros N.
+  exists N; intros; rewrite <- (Rinv_involutive y).
+  rewrite <- (Rinv_involutive (Rabs (x ^ n))).
+  apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat.
+  apply Rinv_0_lt_compat.
+  assumption.
+  apply Rinv_0_lt_compat.
+  apply Rabs_pos_lt.
+  apply pow_nonzero.
+  assumption.
+  rewrite <- Rabs_Rinv.
+  rewrite Rinv_pow.
+  apply (Rlt_le_trans (/ y) (/ y + 1) (Rabs ((/ x) ^ n))).
+  pattern (/ y) at 1 in |- *.
+  rewrite <- (let (H1, H2) := Rplus_ne (/ y) in H1).
+  apply Rplus_lt_compat_l.
+  apply Rlt_0_1.
+  apply Rge_le.
+  apply H3.
+  assumption.
+  assumption.
+  apply pow_nonzero.
+  assumption.
+  apply Rabs_no_R0.
+  apply pow_nonzero.
+  assumption.
+  apply Rlt_dichotomy_converse.
+  right; unfold Rgt in |- *; assumption.
+  rewrite <- (Rinv_involutive 1).
+  rewrite Rabs_Rinv.
+  unfold Rgt in |- *; apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat.
+  apply Rabs_pos_lt.
+  assumption.
+  rewrite Rinv_1; apply Rlt_0_1.
+  rewrite Rinv_1; assumption.
+  assumption.
+  red in |- *; intro; apply R1_neq_R0; assumption.
 Qed.
 
 Lemma pow_R1 : forall (r:R) (n:nat), r ^ n = 1 -> Rabs r = 1 \/ n = 0%nat.
 Proof.
-intros r n H'.
-case (Req_dec (Rabs r) 1); auto; intros H'1.
-case (Rdichotomy _ _ H'1); intros H'2.
-generalize H'; case n; auto.
-intros n0 H'0.
-cut (r <> 0); [ intros Eq1 | idtac ].
-cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
-absurd (Rabs (/ r) ^ 0 < Rabs (/ r) ^ S n0); auto.
-replace (Rabs (/ r) ^ S n0) with 1.
-simpl in |- *; apply Rlt_irrefl; auto.
-rewrite Rabs_Rinv; auto.
-rewrite <- Rinv_pow; auto.
-rewrite RPow_abs; auto.
-rewrite H'0; rewrite Rabs_right; auto with real.
-apply Rle_ge; auto with real.
-apply Rlt_pow; auto with arith.
-rewrite Rabs_Rinv; auto.
-apply Rmult_lt_reg_l with (r := Rabs r).
-case (Rabs_pos r); auto.
-intros H'3; case Eq2; auto.
-rewrite Rmult_1_r; rewrite Rinv_r; auto with real.
-red in |- *; intro; absurd (r ^ S n0 = 1); auto.
-simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
-generalize H'; case n; auto.
-intros n0 H'0.
-cut (r <> 0); [ intros Eq1 | auto with real ].
-cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
-absurd (Rabs r ^ 0 < Rabs r ^ S n0); auto with real arith.
-repeat rewrite RPow_abs; rewrite H'0; simpl in |- *; auto with real.
-red in |- *; intro; absurd (r ^ S n0 = 1); auto.
-simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
+  intros r n H'.
+  case (Req_dec (Rabs r) 1); auto; intros H'1.
+  case (Rdichotomy _ _ H'1); intros H'2.
+  generalize H'; case n; auto.
+  intros n0 H'0.
+  cut (r <> 0); [ intros Eq1 | idtac ].
+  cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
+  absurd (Rabs (/ r) ^ 0 < Rabs (/ r) ^ S n0); auto.
+  replace (Rabs (/ r) ^ S n0) with 1.
+  simpl in |- *; apply Rlt_irrefl; auto.
+  rewrite Rabs_Rinv; auto.
+  rewrite <- Rinv_pow; auto.
+  rewrite RPow_abs; auto.
+  rewrite H'0; rewrite Rabs_right; auto with real.
+  apply Rle_ge; auto with real.
+  apply Rlt_pow; auto with arith.
+  rewrite Rabs_Rinv; auto.
+  apply Rmult_lt_reg_l with (r := Rabs r).
+  case (Rabs_pos r); auto.
+  intros H'3; case Eq2; auto.
+  rewrite Rmult_1_r; rewrite Rinv_r; auto with real.
+  red in |- *; intro; absurd (r ^ S n0 = 1); auto.
+  simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
+  generalize H'; case n; auto.
+  intros n0 H'0.
+  cut (r <> 0); [ intros Eq1 | auto with real ].
+  cut (Rabs r <> 0); [ intros Eq2 | apply Rabs_no_R0 ]; auto.
+  absurd (Rabs r ^ 0 < Rabs r ^ S n0); auto with real arith.
+  repeat rewrite RPow_abs; rewrite H'0; simpl in |- *; auto with real.
+  red in |- *; intro; absurd (r ^ S n0 = 1); auto.
+  simpl in |- *; rewrite H; rewrite Rmult_0_l; auto with real.
 Qed.
 
 Lemma pow_Rsqr : forall (x:R) (n:nat), x ^ (2 * n) = Rsqr x ^ n.
 Proof.
-intros; induction  n as [| n Hrecn].
-reflexivity.
-replace (2 * S n)%nat with (S (S (2 * n))).
-replace (x ^ S (S (2 * n))) with (x * x * x ^ (2 * n)).
-rewrite Hrecn; reflexivity.
-simpl in |- *; ring.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
+  intros; induction  n as [| n Hrecn].
+  reflexivity.
+  replace (2 * S n)%nat with (S (S (2 * n))).
+  replace (x ^ S (S (2 * n))) with (x * x * x ^ (2 * n)).
+  rewrite Hrecn; reflexivity.
+  simpl in |- *; ring.
+  ring.
 Qed.
 
 Lemma pow_le : forall (a:R) (n:nat), 0 <= a -> 0 <= a ^ n.
 Proof.
-intros; induction  n as [| n Hrecn].
-simpl in |- *; left; apply Rlt_0_1.
-simpl in |- *; apply Rmult_le_pos; assumption.
+  intros; induction  n as [| n Hrecn].
+  simpl in |- *; left; apply Rlt_0_1.
+  simpl in |- *; apply Rmult_le_pos; assumption.
 Qed.
 
 (**********)
 Lemma pow_1_even : forall n:nat, (-1) ^ (2 * n) = 1.
 Proof.
-intro; induction  n as [| n Hrecn].
-reflexivity.
-replace (2 * S n)%nat with (2 + 2 * n)%nat.
-rewrite pow_add; rewrite Hrecn; simpl in |- *; ring.
-replace (S n) with (n + 1)%nat; [ ring | ring ].
+  intro; induction  n as [| n Hrecn].
+  reflexivity.
+  replace (2 * S n)%nat with (2 + 2 * n)%nat by ring.
+  rewrite pow_add; rewrite Hrecn; simpl in |- *; ring.
 Qed.
 
 (**********)
 Lemma pow_1_odd : forall n:nat, (-1) ^ S (2 * n) = -1.
 Proof.
-intro; replace (S (2 * n)) with (2 * n + 1)%nat; [ idtac | ring ].
-rewrite pow_add; rewrite pow_1_even; simpl in |- *; ring.
+  intro; replace (S (2 * n)) with (2 * n + 1)%nat by ring.
+  rewrite pow_add; rewrite pow_1_even; simpl in |- *; ring.
 Qed.
 
 (**********)
 Lemma pow_1_abs : forall n:nat, Rabs ((-1) ^ n) = 1.
 Proof.
-intro; induction  n as [| n Hrecn].
-simpl in |- *; apply Rabs_R1.
-replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ].
-rewrite Rabs_mult.
-rewrite Hrecn; rewrite Rmult_1_l; simpl in |- *; rewrite Rmult_1_r;
- rewrite Rabs_Ropp; apply Rabs_R1.
+  intro; induction  n as [| n Hrecn].
+  simpl in |- *; apply Rabs_R1.
+  replace (S n) with (n + 1)%nat; [ rewrite pow_add | ring ].
+  rewrite Rabs_mult.
+  rewrite Hrecn; rewrite Rmult_1_l; simpl in |- *; rewrite Rmult_1_r;
+    rewrite Rabs_Ropp; apply Rabs_R1.
 Qed.
 
 Lemma pow_mult : forall (x:R) (n1 n2:nat), x ^ (n1 * n2) = (x ^ n1) ^ n2.
 Proof.
-intros; induction  n2 as [| n2 Hrecn2].
-simpl in |- *; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ].
-replace (n1 * S n2)%nat with (n1 * n2 + n1)%nat.
-replace (S n2) with (n2 + 1)%nat; [ idtac | ring ].
-do 2 rewrite pow_add.
-rewrite Hrecn2.
-simpl in |- *.
-ring.
-apply INR_eq; rewrite plus_INR; do 2 rewrite mult_INR; rewrite S_INR; ring.
+  intros; induction  n2 as [| n2 Hrecn2].
+  simpl in |- *; replace (n1 * 0)%nat with 0%nat; [ reflexivity | ring ].
+  replace (n1 * S n2)%nat with (n1 * n2 + n1)%nat.
+  replace (S n2) with (n2 + 1)%nat by ring.
+  do 2 rewrite pow_add.
+  rewrite Hrecn2.
+  simpl in |- *.
+  ring.
+  ring.
 Qed.
 
 Lemma pow_incr : forall (x y:R) (n:nat), 0 <= x <= y -> x ^ n <= y ^ n.
 Proof.
-intros.
-induction  n as [| n Hrecn].
-right; reflexivity.
-simpl in |- *.
-elim H; intros.
-apply Rle_trans with (y * x ^ n).
-do 2 rewrite <- (Rmult_comm (x ^ n)).
-apply Rmult_le_compat_l.
-apply pow_le; assumption.
-assumption.
-apply Rmult_le_compat_l.
-apply Rle_trans with x; assumption.
-apply Hrecn.
+  intros.
+  induction  n as [| n Hrecn].
+  right; reflexivity.
+  simpl in |- *.
+  elim H; intros.
+  apply Rle_trans with (y * x ^ n).
+  do 2 rewrite <- (Rmult_comm (x ^ n)).
+  apply Rmult_le_compat_l.
+  apply pow_le; assumption.
+  assumption.
+  apply Rmult_le_compat_l.
+  apply Rle_trans with x; assumption.
+  apply Hrecn.
 Qed.
 
 Lemma pow_R1_Rle : forall (x:R) (k:nat), 1 <= x -> 1 <= x ^ k.
 Proof.
-intros.
-induction  k as [| k Hreck].
-right; reflexivity.
-simpl in |- *.
-apply Rle_trans with (x * 1).
-rewrite Rmult_1_r; assumption.
-apply Rmult_le_compat_l.
-left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
-exact Hreck.
+  intros.
+  induction  k as [| k Hreck].
+  right; reflexivity.
+  simpl in |- *.
+  apply Rle_trans with (x * 1).
+  rewrite Rmult_1_r; assumption.
+  apply Rmult_le_compat_l.
+  left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
+  exact Hreck.
 Qed.
 
 Lemma Rle_pow :
- forall (x:R) (m n:nat), 1 <= x -> (m <= n)%nat -> x ^ m <= x ^ n.
+  forall (x:R) (m n:nat), 1 <= x -> (m <= n)%nat -> x ^ m <= x ^ n.
 Proof.
-intros.
-replace n with (n - m + m)%nat.
-rewrite pow_add.
-rewrite Rmult_comm.
-pattern (x ^ m) at 1 in |- *; rewrite <- Rmult_1_r.
-apply Rmult_le_compat_l.
-apply pow_le; left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
-apply pow_R1_Rle; assumption.
-rewrite plus_comm.
-symmetry  in |- *; apply le_plus_minus; assumption.
+  intros.
+  replace n with (n - m + m)%nat.
+  rewrite pow_add.
+  rewrite Rmult_comm.
+  pattern (x ^ m) at 1 in |- *; rewrite <- Rmult_1_r.
+  apply Rmult_le_compat_l.
+  apply pow_le; left; apply Rlt_le_trans with 1; [ apply Rlt_0_1 | assumption ].
+  apply pow_R1_Rle; assumption.
+  rewrite plus_comm.
+  symmetry  in |- *; apply le_plus_minus; assumption.
 Qed.
 
 Lemma pow1 : forall n:nat, 1 ^ n = 1.
 Proof.
-intro; induction  n as [| n Hrecn].
-reflexivity.
-simpl in |- *; rewrite Hrecn; rewrite Rmult_1_r; reflexivity.
+  intro; induction  n as [| n Hrecn].
+  reflexivity.
+  simpl in |- *; rewrite Hrecn; rewrite Rmult_1_r; reflexivity.
 Qed.
 
 Lemma pow_Rabs : forall (x:R) (n:nat), x ^ n <= Rabs x ^ n.
 Proof.
-intros; induction  n as [| n Hrecn].
-right; reflexivity.
-simpl in |- *; case (Rcase_abs x); intro.
-apply Rle_trans with (Rabs (x * x ^ n)).
-apply RRle_abs.
-rewrite Rabs_mult.
-apply Rmult_le_compat_l.
-apply Rabs_pos.
-right; symmetry  in |- *; apply RPow_abs.
-pattern (Rabs x) at 1 in |- *; rewrite (Rabs_right x r);
- apply Rmult_le_compat_l.
-apply Rge_le; exact r.
-apply Hrecn.
+  intros; induction  n as [| n Hrecn].
+  right; reflexivity.
+  simpl in |- *; case (Rcase_abs x); intro.
+  apply Rle_trans with (Rabs (x * x ^ n)).
+  apply RRle_abs.
+  rewrite Rabs_mult.
+  apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  right; symmetry  in |- *; apply RPow_abs.
+  pattern (Rabs x) at 1 in |- *; rewrite (Rabs_right x r);
+    apply Rmult_le_compat_l.
+  apply Rge_le; exact r.
+  apply Hrecn.
 Qed.
 
 Lemma pow_maj_Rabs : forall (x y:R) (n:nat), Rabs y <= x -> y ^ n <= x ^ n.
 Proof.
-intros; cut (0 <= x).
-intro; apply Rle_trans with (Rabs y ^ n).
-apply pow_Rabs.
-induction  n as [| n Hrecn].
-right; reflexivity.
-simpl in |- *; apply Rle_trans with (x * Rabs y ^ n).
-do 2 rewrite <- (Rmult_comm (Rabs y ^ n)).
-apply Rmult_le_compat_l.
-apply pow_le; apply Rabs_pos.
-assumption.
-apply Rmult_le_compat_l.
-apply H0.
-apply Hrecn.
-apply Rle_trans with (Rabs y); [ apply Rabs_pos | exact H ].
+  intros; cut (0 <= x).
+  intro; apply Rle_trans with (Rabs y ^ n).
+  apply pow_Rabs.
+  induction  n as [| n Hrecn].
+  right; reflexivity.
+  simpl in |- *; apply Rle_trans with (x * Rabs y ^ n).
+  do 2 rewrite <- (Rmult_comm (Rabs y ^ n)).
+  apply Rmult_le_compat_l.
+  apply pow_le; apply Rabs_pos.
+  assumption.
+  apply Rmult_le_compat_l.
+  apply H0.
+  apply Hrecn.
+  apply Rle_trans with (Rabs y); [ apply Rabs_pos | exact H ].
 Qed.
 
 (*******************************)
-(**         PowerRZ            *)
+(** *       PowerRZ            *)
 (*******************************)
 (*i Due to L.Thery i*)
 
@@ -529,151 +524,151 @@ Ltac case_eq name :=
 
 Definition powerRZ (x:R) (n:Z) :=
   match n with
-  | Z0 => 1
-  | Zpos p => x ^ nat_of_P p
-  | Zneg p => / x ^ nat_of_P p
+    | Z0 => 1
+    | Zpos p => x ^ nat_of_P p
+    | Zneg p => / x ^ nat_of_P p
   end.
 
 Infix Local "^Z" := powerRZ (at level 30, right associativity) : R_scope.
 
 Lemma Zpower_NR0 :
- forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z.
+  forall (x:Z) (n:nat), (0 <= x)%Z -> (0 <= Zpower_nat x n)%Z.
 Proof.
-induction n; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith.
+  induction n; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith.
 Qed.
 
 Lemma powerRZ_O : forall x:R, x ^Z 0 = 1.
 Proof.
-reflexivity.
+  reflexivity.
 Qed.
- 
+
 Lemma powerRZ_1 : forall x:R, x ^Z Zsucc 0 = x.
 Proof.
-simpl in |- *; auto with real.
+  simpl in |- *; auto with real.
 Qed.
- 
+
 Lemma powerRZ_NOR : forall (x:R) (z:Z), x <> 0 -> x ^Z z <> 0.
 Proof.
-destruct z; simpl in |- *; auto with real.
+  destruct z; simpl in |- *; auto with real.
 Qed.
- 
+
 Lemma powerRZ_add :
- forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m.
+  forall (x:R) (n m:Z), x <> 0 -> x ^Z (n + m) = x ^Z n * x ^Z m.
 Proof.
-intro x; destruct n as [| n1| n1]; destruct m as [| m1| m1]; simpl in |- *;
- auto with real.
+  intro x; destruct n as [| n1| n1]; destruct m as [| m1| m1]; simpl in |- *;
+    auto with real.
 (* POS/POS *)
-rewrite nat_of_P_plus_morphism; auto with real.
+  rewrite nat_of_P_plus_morphism; auto with real.
 (* POS/NEG *)
-case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
-intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
-intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
-rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
- auto with real.
-rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
-rewrite Rinv_mult_distr; auto with real.
-rewrite Rinv_involutive; auto with real.
-apply lt_le_weak.
-apply nat_of_P_lt_Lt_compare_morphism; auto.
-apply ZC2; auto.
-intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
-rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
- auto with real.
-rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
-apply lt_le_weak.
-change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
-apply nat_of_P_gt_Gt_compare_morphism; auto.
+  case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
+  intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
+  intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
+  rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
+    auto with real.
+  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
+  rewrite Rinv_mult_distr; auto with real.
+  rewrite Rinv_involutive; auto with real.
+  apply lt_le_weak.
+  apply nat_of_P_lt_Lt_compare_morphism; auto.
+  apply ZC2; auto.
+  intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
+  rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
+    auto with real.
+  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
+  apply lt_le_weak.
+  change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
+  apply nat_of_P_gt_Gt_compare_morphism; auto.
 (* NEG/POS *)
-case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
-intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
-intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
-rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
- auto with real.
-rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
-apply lt_le_weak.
-apply nat_of_P_lt_Lt_compare_morphism; auto.
-apply ZC2; auto.
-intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
-rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
- auto with real.
-rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
-rewrite Rinv_mult_distr; auto with real.
-apply lt_le_weak.
-change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
-apply nat_of_P_gt_Gt_compare_morphism; auto.
+  case_eq ((n1 ?= m1)%positive Datatypes.Eq); simpl in |- *; auto with real.
+  intros H' H'0; rewrite Pcompare_Eq_eq with (1 := H'); auto with real.
+  intros H' H'0; rewrite (nat_of_P_minus_morphism m1 n1); auto with real.
+  rewrite (pow_RN_plus x (nat_of_P m1 - nat_of_P n1) (nat_of_P n1));
+    auto with real.
+  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
+  apply lt_le_weak.
+  apply nat_of_P_lt_Lt_compare_morphism; auto.
+  apply ZC2; auto.
+  intros H' H'0; rewrite (nat_of_P_minus_morphism n1 m1); auto with real.
+  rewrite (pow_RN_plus x (nat_of_P n1 - nat_of_P m1) (nat_of_P m1));
+    auto with real.
+  rewrite plus_comm; rewrite le_plus_minus_r; auto with real.
+  rewrite Rinv_mult_distr; auto with real.
+  apply lt_le_weak.
+  change (nat_of_P n1 > nat_of_P m1)%nat in |- *.
+  apply nat_of_P_gt_Gt_compare_morphism; auto.
 (* NEG/NEG *)
-rewrite nat_of_P_plus_morphism; auto with real.
-intros H'; rewrite pow_add; auto with real.
-apply Rinv_mult_distr; auto.
-apply pow_nonzero; auto.
-apply pow_nonzero; auto.
+  rewrite nat_of_P_plus_morphism; auto with real.
+  intros H'; rewrite pow_add; auto with real.
+  apply Rinv_mult_distr; auto.
+  apply pow_nonzero; auto.
+  apply pow_nonzero; auto.
 Qed.
 Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real.
- 
+
 Lemma Zpower_nat_powerRZ :
- forall n m:nat, IZR (Zpower_nat (Z_of_nat n) m) = INR n ^Z Z_of_nat m.
-Proof.
-intros n m; elim m; simpl in |- *; auto with real.
-intros m1 H'; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl in |- *.
-replace (Zpower_nat (Z_of_nat n) (S m1)) with
- (Z_of_nat n * Zpower_nat (Z_of_nat n) m1)%Z.
-rewrite mult_IZR; auto with real.
-repeat rewrite <- INR_IZR_INZ; simpl in |- *.
-rewrite H'; simpl in |- *.
-case m1; simpl in |- *; auto with real.
-intros m2; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto.
-unfold Zpower_nat in |- *; auto.
-Qed.
- 
+  forall n m:nat, IZR (Zpower_nat (Z_of_nat n) m) = INR n ^Z Z_of_nat m.
+Proof.
+  intros n m; elim m; simpl in |- *; auto with real.
+  intros m1 H'; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl in |- *.
+  replace (Zpower_nat (Z_of_nat n) (S m1)) with
+  (Z_of_nat n * Zpower_nat (Z_of_nat n) m1)%Z.
+  rewrite mult_IZR; auto with real.
+  repeat rewrite <- INR_IZR_INZ; simpl in |- *.
+  rewrite H'; simpl in |- *.
+  case m1; simpl in |- *; auto with real.
+  intros m2; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto.
+  unfold Zpower_nat in |- *; auto.
+Qed.
+
 Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z.
 Proof.
-intros x z; case z; simpl in |- *; auto with real.
+  intros x z; case z; simpl in |- *; auto with real.
 Qed.
 Hint Resolve powerRZ_lt: real.
- 
+
 Lemma powerRZ_le : forall (x:R) (z:Z), 0 < x -> 0 <= x ^Z z.
 Proof.
-intros x z H'; apply Rlt_le; auto with real.
+  intros x z H'; apply Rlt_le; auto with real.
 Qed.
 Hint Resolve powerRZ_le: real.
- 
+
 Lemma Zpower_nat_powerRZ_absolu :
- forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Zabs_nat m)) = IZR n ^Z m.
+  forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Zabs_nat m)) = IZR n ^Z m.
 Proof.
-intros n m; case m; simpl in |- *; auto with zarith.
-intros p H'; elim (nat_of_P p); simpl in |- *; auto with zarith.
-intros n0 H'0; rewrite <- H'0; simpl in |- *; auto with zarith.
-rewrite <- mult_IZR; auto.
-intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith.
+  intros n m; case m; simpl in |- *; auto with zarith.
+  intros p H'; elim (nat_of_P p); simpl in |- *; auto with zarith.
+  intros n0 H'0; rewrite <- H'0; simpl in |- *; auto with zarith.
+  rewrite <- mult_IZR; auto.
+  intros p H'; absurd (0 <= Zneg p)%Z; auto with zarith.
 Qed.
 
 Lemma powerRZ_R1 : forall n:Z, 1 ^Z n = 1.
 Proof.
-intros n; case n; simpl in |- *; auto.
-intros p; elim (nat_of_P p); simpl in |- *; auto; intros n0 H'; rewrite H';
- ring.
-intros p; elim (nat_of_P p); simpl in |- *.
-exact Rinv_1.
-intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H';
- auto with real.
+  intros n; case n; simpl in |- *; auto.
+  intros p; elim (nat_of_P p); simpl in |- *; auto; intros n0 H'; rewrite H';
+    ring.
+  intros p; elim (nat_of_P p); simpl in |- *.
+  exact Rinv_1.
+  intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H';
+    auto with real.
 Qed.
 
 (*******************************)
 (* For easy interface          *)
 (*******************************)
 (* decimal_exp r z is defined as r 10^z *)
- 
+
 Definition decimal_exp (r:R) (z:Z) : R := (r * 10 ^Z z).
 
 
 (*******************************)
-(** Sum of n first naturals    *)
+(** * Sum of n first naturals  *)
 (*******************************)
 (*********)
-Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat :=
+Boxed Fixpoint sum_nat_f_O (f:nat -> nat) (n:nat) {struct n} : nat :=
   match n with
-  | O => f 0%nat
-  | S n' => (sum_nat_f_O f n' + f (S n'))%nat
+    | O => f 0%nat
+    | S n' => (sum_nat_f_O f n' + f (S n'))%nat
   end.
 
 (*********)
@@ -687,13 +682,13 @@ Definition sum_nat_O (n:nat) : nat := sum_nat_f_O (fun x:nat => x) n.
 Definition sum_nat (s n:nat) : nat := sum_nat_f s n (fun x:nat => x).
 
 (*******************************)
-(**            Sum             *)
+(** *          Sum             *)
 (*******************************)
 (*********)
 Fixpoint sum_f_R0 (f:nat -> R) (N:nat) {struct N} : R :=
   match N with
-  | O => f 0%nat
-  | S i => sum_f_R0 f i + f (S i)
+    | O => f 0%nat
+    | S i => sum_f_R0 f i + f (S i)
   end.
 
 (*********)
@@ -701,35 +696,35 @@ Definition sum_f (s n:nat) (f:nat -> R) : R :=
   sum_f_R0 (fun x:nat => f (x + s)%nat) (n - s).
 
 Lemma GP_finite :
- forall (x:R) (n:nat),
-   sum_f_R0 (fun n:nat => x ^ n) n * (x - 1) = x ^ (n + 1) - 1.
+  forall (x:R) (n:nat),
+    sum_f_R0 (fun n:nat => x ^ n) n * (x - 1) = x ^ (n + 1) - 1.
 Proof.
-intros; induction  n as [| n Hrecn]; simpl in |- *.
-ring.
-rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n).
-intro H; rewrite H; simpl in |- *; ring.
-omega.
+  intros; induction  n as [| n Hrecn]; simpl in |- *.
+  ring.
+  rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n).
+  intro H; rewrite H; simpl in |- *; ring.
+  omega.
 Qed.
 
 Lemma sum_f_R0_triangle :
- forall (x:nat -> R) (n:nat),
-   Rabs (sum_f_R0 x n) <= sum_f_R0 (fun i:nat => Rabs (x i)) n.
-Proof.
-intro; simple induction n; simpl in |- *.
-unfold Rle in |- *; right; reflexivity.
-intro m; intro;
- apply
-  (Rle_trans (Rabs (sum_f_R0 x m + x (S m)))
-     (Rabs (sum_f_R0 x m) + Rabs (x (S m)))
-     (sum_f_R0 (fun i:nat => Rabs (x i)) m + Rabs (x (S m)))).
-apply Rabs_triang.
-rewrite Rplus_comm;
- rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (x i)) m) (Rabs (x (S m))));
- apply Rplus_le_compat_l; assumption.
+  forall (x:nat -> R) (n:nat),
+    Rabs (sum_f_R0 x n) <= sum_f_R0 (fun i:nat => Rabs (x i)) n.
+Proof.
+  intro; simple induction n; simpl in |- *.
+  unfold Rle in |- *; right; reflexivity.
+  intro m; intro;
+    apply
+      (Rle_trans (Rabs (sum_f_R0 x m + x (S m)))
+        (Rabs (sum_f_R0 x m) + Rabs (x (S m)))
+        (sum_f_R0 (fun i:nat => Rabs (x i)) m + Rabs (x (S m)))).
+  apply Rabs_triang.
+  rewrite Rplus_comm;
+    rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (x i)) m) (Rabs (x (S m))));
+      apply Rplus_le_compat_l; assumption.
 Qed.
 
 (*******************************)
-(*        Distance  in R       *)
+(** *     Distance  in R       *)
 (*******************************)
 
 (*********)
@@ -738,64 +733,64 @@ Definition R_dist (x y:R) : R := Rabs (x - y).
 (*********)
 Lemma R_dist_pos : forall x y:R, R_dist x y >= 0.
 Proof.
-intros; unfold R_dist in |- *; unfold Rabs in |- *; case (Rcase_abs (x - y));
- intro l.
-unfold Rge in |- *; left; apply (Ropp_gt_lt_0_contravar (x - y) l).
-trivial.
+  intros; unfold R_dist in |- *; unfold Rabs in |- *; case (Rcase_abs (x - y));
+    intro l.
+  unfold Rge in |- *; left; apply (Ropp_gt_lt_0_contravar (x - y) l).
+  trivial.
 Qed.
 
 (*********)
 Lemma R_dist_sym : forall x y:R, R_dist x y = R_dist y x.
 Proof.
-unfold R_dist in |- *; intros; split_Rabs; ring.
-generalize (Ropp_gt_lt_0_contravar (y - x) r); intro;
- rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0);
- intro; unfold Rgt in H; elimtype False; auto.
-generalize (minus_Rge y x r); intro; generalize (minus_Rge x y r0); intro;
- generalize (Rge_antisym x y H0 H); intro; rewrite H1; 
- ring.
+  unfold R_dist in |- *; intros; split_Rabs; try ring.
+  generalize (Ropp_gt_lt_0_contravar (y - x) r); intro;
+    rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0);
+      intro; unfold Rgt in H; elimtype False; auto.
+  generalize (minus_Rge y x r); intro; generalize (minus_Rge x y r0); intro;
+    generalize (Rge_antisym x y H0 H); intro; rewrite H1; 
+      ring.
 Qed.
 
 (*********)
 Lemma R_dist_refl : forall x y:R, R_dist x y = 0 <-> x = y.
 Proof.
-unfold R_dist in |- *; intros; split_Rabs; split; intros.
-rewrite (Ropp_minus_distr x y) in H; apply sym_eq;
- apply (Rminus_diag_uniq y x H).
-rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro;
- apply (Rminus_diag_eq y x H0).
-apply (Rminus_diag_uniq x y H).
-apply (Rminus_diag_eq x y H). 
+  unfold R_dist in |- *; intros; split_Rabs; split; intros.
+  rewrite (Ropp_minus_distr x y) in H; apply sym_eq;
+    apply (Rminus_diag_uniq y x H).
+  rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro;
+    apply (Rminus_diag_eq y x H0).
+  apply (Rminus_diag_uniq x y H).
+  apply (Rminus_diag_eq x y H). 
 Qed.
 
 Lemma R_dist_eq : forall x:R, R_dist x x = 0.
 Proof.
-unfold R_dist in |- *; intros; split_Rabs; intros; ring.
+  unfold R_dist in |- *; intros; split_Rabs; intros; ring.
 Qed.
 
 (***********)
 Lemma R_dist_tri : forall x y z:R, R_dist x y <= R_dist x z + R_dist z y.
 Proof.
-intros; unfold R_dist in |- *; replace (x - y) with (x - z + (z - y));
- [ apply (Rabs_triang (x - z) (z - y)) | ring ].
+  intros; unfold R_dist in |- *; replace (x - y) with (x - z + (z - y));
+    [ apply (Rabs_triang (x - z) (z - y)) | ring ].
 Qed.
 
 (*********)
 Lemma R_dist_plus :
- forall a b c d:R, R_dist (a + c) (b + d) <= R_dist a b + R_dist c d.
+  forall a b c d:R, R_dist (a + c) (b + d) <= R_dist a b + R_dist c d.
 Proof.
-intros; unfold R_dist in |- *;
- replace (a + c - (b + d)) with (a - b + (c - d)).
-exact (Rabs_triang (a - b) (c - d)).
-ring.
+  intros; unfold R_dist in |- *;
+    replace (a + c - (b + d)) with (a - b + (c - d)).
+  exact (Rabs_triang (a - b) (c - d)).
+  ring.
 Qed.
 
 (*******************************)
-(**       Infinit Sum          *)
+(** *     Infinit Sum          *)
 (*******************************)
 (*********)
 Definition infinit_sum (s:nat -> R) (l:R) : Prop :=
   forall eps:R,
     eps > 0 ->
-     exists N : nat,
+    exists N : nat,
       (forall n:nat, (n >= N)%nat -> R_dist (sum_f_R0 s n) l < eps).
diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v
index a01e7b52..8ac9c07f 100644
--- a/theories/Reals/Rgeom.v
+++ b/theories/Reals/Rgeom.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rgeom.v,v 1.13.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+(*i $Id: Rgeom.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -14,174 +14,188 @@ Require Import SeqSeries.
 Require Import Rtrigo.
 Require Import R_sqrt. Open Local Scope R_scope.
 
+(** * Distance *)
+
 Definition dist_euc (x0 y0 x1 y1:R) : R :=
   sqrt (Rsqr (x0 - x1) + Rsqr (y0 - y1)).
 
 Lemma distance_refl : forall x0 y0:R, dist_euc x0 y0 x0 y0 = 0.
-intros x0 y0; unfold dist_euc in |- *; apply Rsqr_inj;
- [ apply sqrt_positivity; apply Rplus_le_le_0_compat;
-    [ apply Rle_0_sqr | apply Rle_0_sqr ]
- | right; reflexivity
- | rewrite Rsqr_0; rewrite Rsqr_sqrt;
-    [ unfold Rsqr in |- *; ring
-    | apply Rplus_le_le_0_compat; [ apply Rle_0_sqr | apply Rle_0_sqr ] ] ].
+Proof.
+  intros x0 y0; unfold dist_euc in |- *; apply Rsqr_inj;
+    [ apply sqrt_positivity; apply Rplus_le_le_0_compat;
+      [ apply Rle_0_sqr | apply Rle_0_sqr ]
+      | right; reflexivity
+      | rewrite Rsqr_0; rewrite Rsqr_sqrt;
+        [ unfold Rsqr in |- *; ring
+          | apply Rplus_le_le_0_compat; [ apply Rle_0_sqr | apply Rle_0_sqr ] ] ].
 Qed.
 
 Lemma distance_symm :
- forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0. 
-intros x0 y0 x1 y1; unfold dist_euc in |- *; apply Rsqr_inj;
- [ apply sqrt_positivity; apply Rplus_le_le_0_compat
- | apply sqrt_positivity; apply Rplus_le_le_0_compat
- | repeat rewrite Rsqr_sqrt;
-    [ unfold Rsqr in |- *; ring
-    | apply Rplus_le_le_0_compat
-    | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
+  forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0. 
+Proof.
+  intros x0 y0 x1 y1; unfold dist_euc in |- *; apply Rsqr_inj;
+    [ apply sqrt_positivity; apply Rplus_le_le_0_compat
+      | apply sqrt_positivity; apply Rplus_le_le_0_compat
+      | repeat rewrite Rsqr_sqrt;
+        [ unfold Rsqr in |- *; ring
+          | apply Rplus_le_le_0_compat
+          | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
 Qed.
 
 Lemma law_cosines :
- forall x0 y0 x1 y1 x2 y2 ac:R,
-   let a := dist_euc x1 y1 x0 y0 in
-   let b := dist_euc x2 y2 x0 y0 in
-   let c := dist_euc x2 y2 x1 y1 in
-   a * c * cos ac = (x0 - x1) * (x2 - x1) + (y0 - y1) * (y2 - y1) ->
-   Rsqr b = Rsqr c + Rsqr a - 2 * (a * c * cos ac).
-unfold dist_euc in |- *; intros; repeat rewrite Rsqr_sqrt;
- [ rewrite H; unfold Rsqr in |- *; ring
- | apply Rplus_le_le_0_compat
- | apply Rplus_le_le_0_compat
- | apply Rplus_le_le_0_compat ]; apply Rle_0_sqr.
+  forall x0 y0 x1 y1 x2 y2 ac:R,
+    let a := dist_euc x1 y1 x0 y0 in
+      let b := dist_euc x2 y2 x0 y0 in
+        let c := dist_euc x2 y2 x1 y1 in
+          a * c * cos ac = (x0 - x1) * (x2 - x1) + (y0 - y1) * (y2 - y1) ->
+          Rsqr b = Rsqr c + Rsqr a - 2 * (a * c * cos ac).
+Proof.
+  unfold dist_euc in |- *; intros; repeat rewrite Rsqr_sqrt;
+    [ rewrite H; unfold Rsqr in |- *; ring
+      | apply Rplus_le_le_0_compat
+      | apply Rplus_le_le_0_compat
+      | apply Rplus_le_le_0_compat ]; apply Rle_0_sqr.
 Qed.
 
 Lemma triangle :
- forall x0 y0 x1 y1 x2 y2:R,
-   dist_euc x0 y0 x1 y1 <= dist_euc x0 y0 x2 y2 + dist_euc x2 y2 x1 y1.
-intros; unfold dist_euc in |- *; apply Rsqr_incr_0;
- [ rewrite Rsqr_plus; repeat rewrite Rsqr_sqrt;
-    [ replace (Rsqr (x0 - x1)) with
-       (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1));
-       [ replace (Rsqr (y0 - y1)) with
+  forall x0 y0 x1 y1 x2 y2:R,
+    dist_euc x0 y0 x1 y1 <= dist_euc x0 y0 x2 y2 + dist_euc x2 y2 x1 y1.
+Proof.
+  intros; unfold dist_euc in |- *; apply Rsqr_incr_0;
+    [ rewrite Rsqr_plus; repeat rewrite Rsqr_sqrt;
+      [ replace (Rsqr (x0 - x1)) with
+        (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1));
+        [ replace (Rsqr (y0 - y1)) with
           (Rsqr (y0 - y2) + Rsqr (y2 - y1) + 2 * (y0 - y2) * (y2 - y1));
           [ apply Rplus_le_reg_l with
-             (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
+            (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
               Rsqr (y2 - y1));
-             replace
-              (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
-               Rsqr (y2 - y1) +
-               (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1) +
+            replace
+            (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
+              Rsqr (y2 - y1) +
+              (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1) +
                 (Rsqr (y0 - y2) + Rsqr (y2 - y1) + 2 * (y0 - y2) * (y2 - y1))))
-              with (2 * ((x0 - x2) * (x2 - x1) + (y0 - y2) * (y2 - y1)));
-             [ replace
+            with (2 * ((x0 - x2) * (x2 - x1) + (y0 - y2) * (y2 - y1)));
+              [ replace
                 (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
-                 Rsqr (y2 - y1) +
-                 (Rsqr (x0 - x2) + Rsqr (y0 - y2) +
-                  (Rsqr (x2 - x1) + Rsqr (y2 - y1)) +
-                  2 * sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
-                  sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1)))) with
+                  Rsqr (y2 - y1) +
+                  (Rsqr (x0 - x2) + Rsqr (y0 - y2) +
+                    (Rsqr (x2 - x1) + Rsqr (y2 - y1)) +
+                    2 * sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
+                    sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1)))) with
                 (2 *
-                 (sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
-                  sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1))));
+                  (sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
+                    sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1))));
                 [ apply Rmult_le_compat_l;
-                   [ left; cut (0%nat <> 2%nat);
-                      [ intros; generalize (lt_INR_0 2 (neq_O_lt 2 H));
-                         intro H0; assumption
+                  [ left; cut (0%nat <> 2%nat);
+                    [ intros; generalize (lt_INR_0 2 (neq_O_lt 2 H));
+                      intro H0; assumption
                       | discriminate ]
-                   | apply sqrt_cauchy ]
+                    | apply sqrt_cauchy ]
+                  | ring ]
                 | ring ]
-             | ring ]
+            | ring_Rsqr ]
           | ring_Rsqr ]
-       | ring_Rsqr ]
-    | apply Rplus_le_le_0_compat; apply Rle_0_sqr
-    | apply Rplus_le_le_0_compat; apply Rle_0_sqr
-    | apply Rplus_le_le_0_compat; apply Rle_0_sqr ]
- | apply sqrt_positivity; apply Rplus_le_le_0_compat; apply Rle_0_sqr
- | apply Rplus_le_le_0_compat; apply sqrt_positivity;
-    apply Rplus_le_le_0_compat; apply Rle_0_sqr ].
+        | apply Rplus_le_le_0_compat; apply Rle_0_sqr
+        | apply Rplus_le_le_0_compat; apply Rle_0_sqr
+        | apply Rplus_le_le_0_compat; apply Rle_0_sqr ]
+      | apply sqrt_positivity; apply Rplus_le_le_0_compat; apply Rle_0_sqr
+      | apply Rplus_le_le_0_compat; apply sqrt_positivity;
+        apply Rplus_le_le_0_compat; apply Rle_0_sqr ].
 Qed.
 
 (******************************************************************)
-(**                         Translation                           *)
+(** *                       Translation                           *)
 (******************************************************************)
 
 Definition xt (x tx:R) : R := x + tx.
 Definition yt (y ty:R) : R := y + ty.
 
 Lemma translation_0 : forall x y:R, xt x 0 = x /\ yt y 0 = y.
-intros x y; split; [ unfold xt in |- * | unfold yt in |- * ]; ring.
+Proof.
+  intros x y; split; [ unfold xt in |- * | unfold yt in |- * ]; ring.
 Qed.
 
 Lemma isometric_translation :
- forall x1 x2 y1 y2 tx ty:R,
-   Rsqr (x1 - x2) + Rsqr (y1 - y2) =
-   Rsqr (xt x1 tx - xt x2 tx) + Rsqr (yt y1 ty - yt y2 ty).
-intros; unfold Rsqr, xt, yt in |- *; ring.
+  forall x1 x2 y1 y2 tx ty:R,
+    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
+    Rsqr (xt x1 tx - xt x2 tx) + Rsqr (yt y1 ty - yt y2 ty).
+Proof.
+  intros; unfold Rsqr, xt, yt in |- *; ring.
 Qed.
 
 (******************************************************************)
-(**                           Rotation                            *)
+(** *                         Rotation                            *)
 (******************************************************************)
 
 Definition xr (x y theta:R) : R := x * cos theta + y * sin theta.
 Definition yr (x y theta:R) : R := - x * sin theta + y * cos theta.
 
 Lemma rotation_0 : forall x y:R, xr x y 0 = x /\ yr x y 0 = y.
-intros x y; unfold xr, yr in |- *; split; rewrite cos_0; rewrite sin_0; ring.
+Proof.
+  intros x y; unfold xr, yr in |- *; split; rewrite cos_0; rewrite sin_0; ring.
 Qed.
 
 Lemma rotation_PI2 :
- forall x y:R, xr x y (PI / 2) = y /\ yr x y (PI / 2) = - x.
-intros x y; unfold xr, yr in |- *; split; rewrite cos_PI2; rewrite sin_PI2;
- ring.
+  forall x y:R, xr x y (PI / 2) = y /\ yr x y (PI / 2) = - x.
+Proof.
+  intros x y; unfold xr, yr in |- *; split; rewrite cos_PI2; rewrite sin_PI2;
+    ring.
 Qed.
 
 Lemma isometric_rotation_0 :
- forall x1 y1 x2 y2 theta:R,
-   Rsqr (x1 - x2) + Rsqr (y1 - y2) =
-   Rsqr (xr x1 y1 theta - xr x2 y2 theta) +
-   Rsqr (yr x1 y1 theta - yr x2 y2 theta).
-intros; unfold xr, yr in |- *;
- replace
-  (x1 * cos theta + y1 * sin theta - (x2 * cos theta + y2 * sin theta)) with
-  (cos theta * (x1 - x2) + sin theta * (y1 - y2));
- [ replace
-    (- x1 * sin theta + y1 * cos theta - (- x2 * sin theta + y2 * cos theta))
-    with (cos theta * (y1 - y2) + sin theta * (x2 - x1));
-    [ repeat rewrite Rsqr_plus; repeat rewrite Rsqr_mult; repeat rewrite cos2;
-       ring; replace (x2 - x1) with (- (x1 - x2));
-       [ rewrite <- Rsqr_neg; ring | ring ]
-    | ring ]
- | ring ].
+  forall x1 y1 x2 y2 theta:R,
+    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
+    Rsqr (xr x1 y1 theta - xr x2 y2 theta) +
+    Rsqr (yr x1 y1 theta - yr x2 y2 theta).
+Proof.
+  intros; unfold xr, yr in |- *;
+    replace
+    (x1 * cos theta + y1 * sin theta - (x2 * cos theta + y2 * sin theta)) with
+    (cos theta * (x1 - x2) + sin theta * (y1 - y2));
+    [ replace
+      (- x1 * sin theta + y1 * cos theta - (- x2 * sin theta + y2 * cos theta))
+      with (cos theta * (y1 - y2) + sin theta * (x2 - x1));
+        [ repeat rewrite Rsqr_plus; repeat rewrite Rsqr_mult; repeat rewrite cos2;
+          ring_simplify; replace (x2 - x1) with (- (x1 - x2));
+          [ rewrite <- Rsqr_neg; ring | ring ]
+          | ring ]
+      | ring ].
 Qed.
 
 Lemma isometric_rotation :
- forall x1 y1 x2 y2 theta:R,
-   dist_euc x1 y1 x2 y2 =
-   dist_euc (xr x1 y1 theta) (yr x1 y1 theta) (xr x2 y2 theta)
-     (yr x2 y2 theta).
-unfold dist_euc in |- *; intros; apply Rsqr_inj;
- [ apply sqrt_positivity; apply Rplus_le_le_0_compat
- | apply sqrt_positivity; apply Rplus_le_le_0_compat
- | repeat rewrite Rsqr_sqrt;
-    [ apply isometric_rotation_0
-    | apply Rplus_le_le_0_compat
-    | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
+  forall x1 y1 x2 y2 theta:R,
+    dist_euc x1 y1 x2 y2 =
+    dist_euc (xr x1 y1 theta) (yr x1 y1 theta) (xr x2 y2 theta)
+    (yr x2 y2 theta).
+Proof.
+  unfold dist_euc in |- *; intros; apply Rsqr_inj;
+    [ apply sqrt_positivity; apply Rplus_le_le_0_compat
+      | apply sqrt_positivity; apply Rplus_le_le_0_compat
+      | repeat rewrite Rsqr_sqrt;
+        [ apply isometric_rotation_0
+          | apply Rplus_le_le_0_compat
+          | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
 Qed.
 
 (******************************************************************)
-(**                         Similarity                            *)
+(** *                       Similarity                            *)
 (******************************************************************)
 
 Lemma isometric_rot_trans :
- forall x1 y1 x2 y2 tx ty theta:R,
-   Rsqr (x1 - x2) + Rsqr (y1 - y2) =
-   Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) +
-   Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). 
-intros; rewrite <- isometric_rotation_0; apply isometric_translation.
+  forall x1 y1 x2 y2 tx ty theta:R,
+    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
+    Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) +
+    Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). 
+Proof.
+  intros; rewrite <- isometric_rotation_0; apply isometric_translation.
 Qed.
 
 Lemma isometric_trans_rot :
- forall x1 y1 x2 y2 tx ty theta:R,
-   Rsqr (x1 - x2) + Rsqr (y1 - y2) =
-   Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) +
-   Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). 
-intros; rewrite <- isometric_translation; apply isometric_rotation_0.
-Qed.
\ No newline at end of file
+  forall x1 y1 x2 y2 tx ty theta:R,
+    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
+    Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) +
+    Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). 
+Proof.
+  intros; rewrite <- isometric_translation; apply isometric_rotation_0.
+Qed.
diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v
index ce33afdb..1cba821e 100644
--- a/theories/Reals/RiemannInt.v
+++ b/theories/Reals/RiemannInt.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: RiemannInt.v,v 1.18.2.2 2005/07/13 23:18:52 herbelin Exp $ i*)
+
+(*i $Id: RiemannInt.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rfunctions.
 Require Import SeqSeries.
@@ -20,3244 +20,3298 @@ Require Import Max. Open Local Scope R_scope.
 Set Implicit Arguments.
 
 (********************************************)
-(*            Riemann's Integral            *)
+(**           Riemann's Integral            *)
 (********************************************)
 
 Definition Riemann_integrable (f:R -> R) (a b:R) : Type :=
   forall eps:posreal,
     sigT
-      (fun phi:StepFun a b =>
-         sigT
-           (fun psi:StepFun a b =>
-              (forall t:R,
-                 Rmin a b <= t <= Rmax a b -> Rabs (f t - phi t) <= psi t) /\
-              Rabs (RiemannInt_SF psi) < eps)).
+    (fun phi:StepFun a b =>
+      sigT
+      (fun psi:StepFun a b =>
+        (forall t:R,
+          Rmin a b <= t <= Rmax a b -> Rabs (f t - phi t) <= psi t) /\
+        Rabs (RiemannInt_SF psi) < eps)).
 
 Definition phi_sequence (un:nat -> posreal) (f:R -> R) 
   (a b:R) (pr:Riemann_integrable f a b) (n:nat) := 
   projT1 (pr (un n)).
 
 Lemma phi_sequence_prop :
- forall (un:nat -> posreal) (f:R -> R) (a b:R) (pr:Riemann_integrable f a b)
-   (N:nat),
-   sigT
-     (fun psi:StepFun a b =>
-        (forall t:R,
-           Rmin a b <= t <= Rmax a b ->
-           Rabs (f t - phi_sequence un pr N t) <= psi t) /\
-        Rabs (RiemannInt_SF psi) < un N).
-intros; apply (projT2 (pr (un N))).
+  forall (un:nat -> posreal) (f:R -> R) (a b:R) (pr:Riemann_integrable f a b)
+    (N:nat),
+    sigT
+    (fun psi:StepFun a b =>
+      (forall t:R,
+        Rmin a b <= t <= Rmax a b ->
+        Rabs (f t - phi_sequence un pr N t) <= psi t) /\
+      Rabs (RiemannInt_SF psi) < un N).
+Proof.
+  intros; apply (projT2 (pr (un N))).
 Qed.
 
 Lemma RiemannInt_P1 :
- forall (f:R -> R) (a b:R),
-   Riemann_integrable f a b -> Riemann_integrable f b a.
-unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; intros;
- elim p; clear p; intros; apply existT with (mkStepFun (StepFun_P6 (pre x)));
- apply existT with (mkStepFun (StepFun_P6 (pre x0))); 
- elim p; clear p; intros; split.
-intros; apply (H t); elim H1; clear H1; intros; split;
- [ apply Rle_trans with (Rmin b a); try assumption; right;
-    unfold Rmin in |- *
- | apply Rle_trans with (Rmax b a); try assumption; right;
-    unfold Rmax in |- * ];
- (case (Rle_dec a b); case (Rle_dec b a); intros;
-   try reflexivity || apply Rle_antisym;
-   [ assumption | assumption | auto with real | auto with real ]).
-generalize H0; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
- case (Rle_dec b a); intros;
- (replace
-   (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre x0))))
-      (subdivision (mkStepFun (StepFun_P6 (pre x0))))) with
-   (Int_SF (subdivision_val x0) (subdivision x0));
-   [ idtac
-   | apply StepFun_P17 with (fe x0) a b;
-      [ apply StepFun_P1
-      | apply StepFun_P2;
-         apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre x0)))) ] ]).
-apply H1.
-rewrite Rabs_Ropp; apply H1.
-rewrite Rabs_Ropp in H1; apply H1.
-apply H1.
+  forall (f:R -> R) (a b:R),
+    Riemann_integrable f a b -> Riemann_integrable f b a.
+Proof.
+  unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; intros;
+    elim p; clear p; intros; apply existT with (mkStepFun (StepFun_P6 (pre x)));
+      apply existT with (mkStepFun (StepFun_P6 (pre x0))); 
+        elim p; clear p; intros; split.
+  intros; apply (H t); elim H1; clear H1; intros; split;
+    [ apply Rle_trans with (Rmin b a); try assumption; right;
+      unfold Rmin in |- *
+      | apply Rle_trans with (Rmax b a); try assumption; right;
+        unfold Rmax in |- * ];
+    (case (Rle_dec a b); case (Rle_dec b a); intros;
+      try reflexivity || apply Rle_antisym;
+        [ assumption | assumption | auto with real | auto with real ]).
+  generalize H0; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
+    case (Rle_dec b a); intros;
+      (replace
+        (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre x0))))
+          (subdivision (mkStepFun (StepFun_P6 (pre x0))))) with
+        (Int_SF (subdivision_val x0) (subdivision x0));
+        [ idtac
+          | apply StepFun_P17 with (fe x0) a b;
+            [ apply StepFun_P1
+              | apply StepFun_P2;
+                apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre x0)))) ] ]).
+  apply H1.
+  rewrite Rabs_Ropp; apply H1.
+  rewrite Rabs_Ropp in H1; apply H1.
+  apply H1.
 Qed.
 
 Lemma RiemannInt_P2 :
- forall (f:R -> R) (a b:R) (un:nat -> posreal) (vn wn:nat -> StepFun a b),
-   Un_cv un 0 ->
-   a <= b ->
-   (forall n:nat,
+  forall (f:R -> R) (a b:R) (un:nat -> posreal) (vn wn:nat -> StepFun a b),
+    Un_cv un 0 ->
+    a <= b ->
+    (forall n:nat,
       (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - vn n t) <= wn n t) /\
       Rabs (RiemannInt_SF (wn n)) < un n) ->
-   sigT (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (vn N)) l).
-intros; apply R_complete; unfold Un_cv in H; unfold Cauchy_crit in |- *;
- intros; assert (H3 : 0 < eps / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H _ H3); intros N0 H4; exists N0; intros; unfold R_dist in |- *;
- unfold R_dist in H4; elim (H1 n); elim (H1 m); intros;
- replace (RiemannInt_SF (vn n) - RiemannInt_SF (vn m)) with
-  (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); 
- [ idtac | ring ]; rewrite <- StepFun_P30;
- apply Rle_lt_trans with
-  (RiemannInt_SF
-     (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (vn n) (vn m)))))).
-apply StepFun_P34; assumption.
-apply Rle_lt_trans with
- (RiemannInt_SF (mkStepFun (StepFun_P28 1 (wn n) (wn m)))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *;
- apply Rle_trans with (Rabs (vn n x - f x) + Rabs (f x - vn m x)).
-replace (vn n x + -1 * vn m x) with (vn n x - f x + (f x - vn m x));
- [ apply Rabs_triang | ring ].
-assert (H12 : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-assert (H13 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-rewrite <- H12 in H11; pattern b at 2 in H11; rewrite <- H13 in H11;
- rewrite Rmult_1_l; apply Rplus_le_compat.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9.
-elim H11; intros; split; left; assumption.
-apply H7.
-elim H11; intros; split; left; assumption.
-rewrite StepFun_P30; rewrite Rmult_1_l; apply Rlt_trans with (un n + un m).
-apply Rle_lt_trans with
- (Rabs (RiemannInt_SF (wn n)) + Rabs (RiemannInt_SF (wn m))).
-apply Rplus_le_compat; apply RRle_abs.
-apply Rplus_lt_compat; assumption.
-apply Rle_lt_trans with (Rabs (un n) + Rabs (un m)).
-apply Rplus_le_compat; apply RRle_abs.
-replace (pos (un n)) with (un n - 0); [ idtac | ring ];
- replace (pos (un m)) with (un m - 0); [ idtac | ring ];
- rewrite (double_var eps); apply Rplus_lt_compat; apply H4; 
- assumption.
+    sigT (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (vn N)) l).
+Proof.
+  intros; apply R_complete; unfold Un_cv in H; unfold Cauchy_crit in |- *;
+    intros; assert (H3 : 0 < eps / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H _ H3); intros N0 H4; exists N0; intros; unfold R_dist in |- *;
+    unfold R_dist in H4; elim (H1 n); elim (H1 m); intros;
+      replace (RiemannInt_SF (vn n) - RiemannInt_SF (vn m)) with
+      (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); 
+      [ idtac | ring ]; rewrite <- StepFun_P30;
+        apply Rle_lt_trans with
+          (RiemannInt_SF
+            (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (vn n) (vn m)))))).
+  apply StepFun_P34; assumption.
+  apply Rle_lt_trans with
+    (RiemannInt_SF (mkStepFun (StepFun_P28 1 (wn n) (wn m)))).
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *;
+    apply Rle_trans with (Rabs (vn n x - f x) + Rabs (f x - vn m x)).
+  replace (vn n x + -1 * vn m x) with (vn n x - f x + (f x - vn m x));
+  [ apply Rabs_triang | ring ].
+  assert (H12 : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  assert (H13 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  rewrite <- H12 in H11; pattern b at 2 in H11; rewrite <- H13 in H11;
+    rewrite Rmult_1_l; apply Rplus_le_compat.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9.
+  elim H11; intros; split; left; assumption.
+  apply H7.
+  elim H11; intros; split; left; assumption.
+  rewrite StepFun_P30; rewrite Rmult_1_l; apply Rlt_trans with (un n + un m).
+  apply Rle_lt_trans with
+    (Rabs (RiemannInt_SF (wn n)) + Rabs (RiemannInt_SF (wn m))).
+  apply Rplus_le_compat; apply RRle_abs.
+  apply Rplus_lt_compat; assumption.
+  apply Rle_lt_trans with (Rabs (un n) + Rabs (un m)).
+  apply Rplus_le_compat; apply RRle_abs.
+  replace (pos (un n)) with (un n - 0); [ idtac | ring ];
+  replace (pos (un m)) with (un m - 0); [ idtac | ring ];
+  rewrite (double_var eps); apply Rplus_lt_compat; apply H4; 
+    assumption.
 Qed.
 
 Lemma RiemannInt_P3 :
- forall (f:R -> R) (a b:R) (un:nat -> posreal) (vn wn:nat -> StepFun a b),
-   Un_cv un 0 ->
-   (forall n:nat,
+  forall (f:R -> R) (a b:R) (un:nat -> posreal) (vn wn:nat -> StepFun a b),
+    Un_cv un 0 ->
+    (forall n:nat,
       (forall t:R, Rmin a b <= t <= Rmax a b -> Rabs (f t - vn n t) <= wn n t) /\
       Rabs (RiemannInt_SF (wn n)) < un n) ->
-   sigT (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (vn N)) l).
-intros; case (Rle_dec a b); intro.
-apply RiemannInt_P2 with f un wn; assumption.
-assert (H1 : b <= a); auto with real.
-set (vn' := fun n:nat => mkStepFun (StepFun_P6 (pre (vn n))));
- set (wn' := fun n:nat => mkStepFun (StepFun_P6 (pre (wn n))));
- assert
-  (H2 :
-   forall n:nat,
-     (forall t:R,
-        Rmin b a <= t <= Rmax b a -> Rabs (f t - vn' n t) <= wn' n t) /\
-     Rabs (RiemannInt_SF (wn' n)) < un n).
-intro; elim (H0 n0); intros; split.
-intros; apply (H2 t); elim H4; clear H4; intros; split;
- [ apply Rle_trans with (Rmin b a); try assumption; right;
-    unfold Rmin in |- *
- | apply Rle_trans with (Rmax b a); try assumption; right;
-    unfold Rmax in |- * ];
- (case (Rle_dec a b); case (Rle_dec b a); intros;
-   try reflexivity || apply Rle_antisym;
-   [ assumption | assumption | auto with real | auto with real ]).
-generalize H3; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
- case (Rle_dec b a); unfold wn' in |- *; intros;
- (replace
-   (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (wn n0)))))
-      (subdivision (mkStepFun (StepFun_P6 (pre (wn n0)))))) with
-   (Int_SF (subdivision_val (wn n0)) (subdivision (wn n0)));
-   [ idtac
-   | apply StepFun_P17 with (fe (wn n0)) a b;
-      [ apply StepFun_P1
-      | apply StepFun_P2;
-         apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (wn n0))))) ] ]).
-apply H4.
-rewrite Rabs_Ropp; apply H4.
-rewrite Rabs_Ropp in H4; apply H4.
-apply H4.
-assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros;
- apply existT with (- x); unfold Un_cv in |- *; unfold Un_cv in p; 
- intros; elim (p _ H4); intros; exists x0; intros; 
- generalize (H5 _ H6); unfold R_dist, RiemannInt_SF in |- *;
- case (Rle_dec b a); case (Rle_dec a b); intros.
-elim n; assumption.
-unfold vn' in H7;
- replace (Int_SF (subdivision_val (vn n0)) (subdivision (vn n0))) with
-  (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0)))))
-     (subdivision (mkStepFun (StepFun_P6 (pre (vn n0))))));
- [ unfold Rminus in |- *; rewrite Ropp_involutive; rewrite <- Rabs_Ropp;
-    rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
-    apply H7
- | symmetry  in |- *; apply StepFun_P17 with (fe (vn n0)) a b;
-    [ apply StepFun_P1
-    | apply StepFun_P2;
-       apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n0))))) ] ].
-elim n1; assumption.
-elim n2; assumption.
+    sigT (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (vn N)) l).
+Proof.
+  intros; case (Rle_dec a b); intro.
+  apply RiemannInt_P2 with f un wn; assumption.
+  assert (H1 : b <= a); auto with real.
+  set (vn' := fun n:nat => mkStepFun (StepFun_P6 (pre (vn n))));
+    set (wn' := fun n:nat => mkStepFun (StepFun_P6 (pre (wn n))));
+      assert
+        (H2 :
+          forall n:nat,
+            (forall t:R,
+              Rmin b a <= t <= Rmax b a -> Rabs (f t - vn' n t) <= wn' n t) /\
+            Rabs (RiemannInt_SF (wn' n)) < un n).
+  intro; elim (H0 n0); intros; split.
+  intros; apply (H2 t); elim H4; clear H4; intros; split;
+    [ apply Rle_trans with (Rmin b a); try assumption; right;
+      unfold Rmin in |- *
+      | apply Rle_trans with (Rmax b a); try assumption; right;
+        unfold Rmax in |- * ];
+    (case (Rle_dec a b); case (Rle_dec b a); intros;
+      try reflexivity || apply Rle_antisym;
+        [ assumption | assumption | auto with real | auto with real ]).
+  generalize H3; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
+    case (Rle_dec b a); unfold wn' in |- *; intros;
+      (replace
+        (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (wn n0)))))
+          (subdivision (mkStepFun (StepFun_P6 (pre (wn n0)))))) with
+        (Int_SF (subdivision_val (wn n0)) (subdivision (wn n0)));
+        [ idtac
+          | apply StepFun_P17 with (fe (wn n0)) a b;
+            [ apply StepFun_P1
+              | apply StepFun_P2;
+                apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (wn n0))))) ] ]).
+  apply H4.
+  rewrite Rabs_Ropp; apply H4.
+  rewrite Rabs_Ropp in H4; apply H4.
+  apply H4.
+  assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros;
+    apply existT with (- x); unfold Un_cv in |- *; unfold Un_cv in p; 
+      intros; elim (p _ H4); intros; exists x0; intros; 
+        generalize (H5 _ H6); unfold R_dist, RiemannInt_SF in |- *;
+          case (Rle_dec b a); case (Rle_dec a b); intros.
+  elim n; assumption.
+  unfold vn' in H7;
+    replace (Int_SF (subdivision_val (vn n0)) (subdivision (vn n0))) with
+    (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0)))))
+      (subdivision (mkStepFun (StepFun_P6 (pre (vn n0))))));
+    [ unfold Rminus in |- *; rewrite Ropp_involutive; rewrite <- Rabs_Ropp;
+      rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+        apply H7
+      | symmetry  in |- *; apply StepFun_P17 with (fe (vn n0)) a b;
+        [ apply StepFun_P1
+          | apply StepFun_P2;
+            apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n0))))) ] ].
+  elim n1; assumption.
+  elim n2; assumption.
 Qed.
 
 Lemma RiemannInt_exists :
- forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) 
-   (un:nat -> posreal),
-   Un_cv un 0 ->
-   sigT
-     (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l).
-intros f; intros;
- apply RiemannInt_P3 with
-  f un (fun n:nat => projT1 (phi_sequence_prop un pr n));
- [ apply H | intro; apply (projT2 (phi_sequence_prop un pr n)) ].
+  forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) 
+    (un:nat -> posreal),
+    Un_cv un 0 ->
+    sigT
+    (fun l:R => Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l).
+Proof.
+  intros f; intros;
+    apply RiemannInt_P3 with
+      f un (fun n:nat => projT1 (phi_sequence_prop un pr n));
+      [ apply H | intro; apply (projT2 (phi_sequence_prop un pr n)) ].
 Qed.
 
 Lemma RiemannInt_P4 :
- forall (f:R -> R) (a b l:R) (pr1 pr2:Riemann_integrable f a b)
-   (un vn:nat -> posreal),
-   Un_cv un 0 ->
-   Un_cv vn 0 ->
-   Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr1 N)) l ->
-   Un_cv (fun N:nat => RiemannInt_SF (phi_sequence vn pr2 N)) l.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros f; intros;
- assert (H3 : 0 < eps / 3).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H _ H3); clear H; intros N0 H; elim (H0 _ H3); clear H0; intros N1 H0;
- elim (H1 _ H3); clear H1; intros N2 H1; set (N := max (max N0 N1) N2);
- exists N; intros;
- apply Rle_lt_trans with
-  (Rabs
-     (RiemannInt_SF (phi_sequence vn pr2 n) -
-      RiemannInt_SF (phi_sequence un pr1 n)) +
-   Rabs (RiemannInt_SF (phi_sequence un pr1 n) - l)).
-replace (RiemannInt_SF (phi_sequence vn pr2 n) - l) with
- (RiemannInt_SF (phi_sequence vn pr2 n) -
-  RiemannInt_SF (phi_sequence un pr1 n) +
-  (RiemannInt_SF (phi_sequence un pr1 n) - l)); [ apply Rabs_triang | ring ].
-replace eps with (2 * (eps / 3) + eps / 3).
-apply Rplus_lt_compat.
-elim (phi_sequence_prop vn pr2 n); intros psi_vn H5;
- elim (phi_sequence_prop un pr1 n); intros psi_un H6;
- replace
+  forall (f:R -> R) (a b l:R) (pr1 pr2:Riemann_integrable f a b)
+    (un vn:nat -> posreal),
+    Un_cv un 0 ->
+    Un_cv vn 0 ->
+    Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr1 N)) l ->
+    Un_cv (fun N:nat => RiemannInt_SF (phi_sequence vn pr2 N)) l.
+Proof.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros f; intros;
+    assert (H3 : 0 < eps / 3).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H _ H3); clear H; intros N0 H; elim (H0 _ H3); clear H0; intros N1 H0;
+    elim (H1 _ H3); clear H1; intros N2 H1; set (N := max (max N0 N1) N2);
+      exists N; intros;
+        apply Rle_lt_trans with
+          (Rabs
+            (RiemannInt_SF (phi_sequence vn pr2 n) -
+              RiemannInt_SF (phi_sequence un pr1 n)) +
+            Rabs (RiemannInt_SF (phi_sequence un pr1 n) - l)).
+  replace (RiemannInt_SF (phi_sequence vn pr2 n) - l) with
   (RiemannInt_SF (phi_sequence vn pr2 n) -
-   RiemannInt_SF (phi_sequence un pr1 n)) with
-  (RiemannInt_SF (phi_sequence vn pr2 n) +
-   -1 * RiemannInt_SF (phi_sequence un pr1 n)); [ idtac | ring ];
- rewrite <- StepFun_P30.
-case (Rle_dec a b); intro.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P32
+    RiemannInt_SF (phi_sequence un pr1 n) +
+    (RiemannInt_SF (phi_sequence un pr1 n) - l)); [ apply Rabs_triang | ring ].
+  replace eps with (2 * (eps / 3) + eps / 3).
+  apply Rplus_lt_compat.
+  elim (phi_sequence_prop vn pr2 n); intros psi_vn H5;
+    elim (phi_sequence_prop un pr1 n); intros psi_un H6;
+      replace
+      (RiemannInt_SF (phi_sequence vn pr2 n) -
+        RiemannInt_SF (phi_sequence un pr1 n)) with
+      (RiemannInt_SF (phi_sequence vn pr2 n) +
+        -1 * RiemannInt_SF (phi_sequence un pr1 n)); [ idtac | ring ];
+      rewrite <- StepFun_P30.
+  case (Rle_dec a b); intro.
+  apply Rle_lt_trans with
+    (RiemannInt_SF
+      (mkStepFun
+        (StepFun_P32
           (mkStepFun
-             (StepFun_P28 (-1) (phi_sequence vn pr2 n)
-                (phi_sequence un pr1 n)))))).
-apply StepFun_P34; assumption.
-apply Rle_lt_trans with
- (RiemannInt_SF (mkStepFun (StepFun_P28 1 psi_un psi_vn))).
-apply StepFun_P37; try assumption; intros; simpl in |- *; rewrite Rmult_1_l;
- apply Rle_trans with
-  (Rabs (phi_sequence vn pr2 n x - f x) +
-   Rabs (f x - phi_sequence un pr1 n x)).
-replace (phi_sequence vn pr2 n x + -1 * phi_sequence un pr1 n x) with
- (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
- [ apply Rabs_triang | ring ].
-assert (H10 : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-assert (H11 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-rewrite (Rplus_comm (psi_un x)); apply Rplus_le_compat.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
-rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
-elim H6; intros; apply H8.
-rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
-rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
-apply Rlt_trans with (pos (un n)).
-elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)).
-apply RRle_abs.
-assumption.
-replace (pos (un n)) with (Rabs (un n - 0));
- [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
+            (StepFun_P28 (-1) (phi_sequence vn pr2 n)
+              (phi_sequence un pr1 n)))))).
+  apply StepFun_P34; assumption.
+  apply Rle_lt_trans with
+    (RiemannInt_SF (mkStepFun (StepFun_P28 1 psi_un psi_vn))).
+  apply StepFun_P37; try assumption; intros; simpl in |- *; rewrite Rmult_1_l;
+    apply Rle_trans with
+      (Rabs (phi_sequence vn pr2 n x - f x) +
+        Rabs (f x - phi_sequence un pr1 n x)).
+  replace (phi_sequence vn pr2 n x + -1 * phi_sequence un pr1 n x) with
+  (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
+  [ apply Rabs_triang | ring ].
+  assert (H10 : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  assert (H11 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  rewrite (Rplus_comm (psi_un x)); apply Rplus_le_compat.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
+  rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
+  elim H6; intros; apply H8.
+  rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
+  rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
+  apply Rlt_trans with (pos (un n)).
+  elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)).
+  apply RRle_abs.
+  assumption.
+  replace (pos (un n)) with (Rabs (un n - 0));
+  [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
     unfold N in |- *; apply le_trans with (max N0 N1); 
-    apply le_max_l
- | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
-    apply Rle_ge; left; apply (cond_pos (un n)) ].
-apply Rlt_trans with (pos (vn n)).
-elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)).
-apply RRle_abs; assumption.
-assumption.
-replace (pos (vn n)) with (Rabs (vn n - 0));
- [ apply H0; unfold ge in |- *; apply le_trans with N; try assumption;
+      apply le_max_l
+    | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+      apply Rle_ge; left; apply (cond_pos (un n)) ].
+  apply Rlt_trans with (pos (vn n)).
+  elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)).
+  apply RRle_abs; assumption.
+  assumption.
+  replace (pos (vn n)) with (Rabs (vn n - 0));
+  [ apply H0; unfold ge in |- *; apply le_trans with N; try assumption;
     unfold N in |- *; apply le_trans with (max N0 N1);
-    [ apply le_max_r | apply le_max_l ]
- | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
-    apply Rle_ge; left; apply (cond_pos (vn n)) ].
-rewrite StepFun_P39; rewrite Rabs_Ropp;
- apply Rle_lt_trans with
-  (RiemannInt_SF
-     (mkStepFun
-        (StepFun_P32
-           (mkStepFun
+      [ apply le_max_r | apply le_max_l ]
+    | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+      apply Rle_ge; left; apply (cond_pos (vn n)) ].
+  rewrite StepFun_P39; rewrite Rabs_Ropp;
+    apply Rle_lt_trans with
+      (RiemannInt_SF
+        (mkStepFun
+          (StepFun_P32
+            (mkStepFun
               (StepFun_P6
-                 (pre
-                    (mkStepFun
-                       (StepFun_P28 (-1) (phi_sequence vn pr2 n)
-                          (phi_sequence un pr1 n))))))))).
-apply StepFun_P34; try auto with real.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 psi_vn psi_un)))))).
-apply StepFun_P37.
-auto with real.
-intros; simpl in |- *; rewrite Rmult_1_l;
- apply Rle_trans with
-  (Rabs (phi_sequence vn pr2 n x - f x) +
-   Rabs (f x - phi_sequence un pr1 n x)).
-replace (phi_sequence vn pr2 n x + -1 * phi_sequence un pr1 n x) with
- (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
- [ apply Rabs_triang | ring ].
-assert (H10 : Rmin a b = b).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ elim n0; assumption | reflexivity ].
-assert (H11 : Rmax a b = a).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ elim n0; assumption | reflexivity ].
-apply Rplus_le_compat.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
-rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
-elim H6; intros; apply H8.
-rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
-rewrite <-
- (Ropp_involutive
+                (pre
+                  (mkStepFun
+                    (StepFun_P28 (-1) (phi_sequence vn pr2 n)
+                      (phi_sequence un pr1 n))))))))).
+  apply StepFun_P34; try auto with real.
+  apply Rle_lt_trans with
     (RiemannInt_SF
-       (mkStepFun
+      (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 psi_vn psi_un)))))).
+  apply StepFun_P37.
+  auto with real.
+  intros; simpl in |- *; rewrite Rmult_1_l;
+    apply Rle_trans with
+      (Rabs (phi_sequence vn pr2 n x - f x) +
+        Rabs (f x - phi_sequence un pr1 n x)).
+  replace (phi_sequence vn pr2 n x + -1 * phi_sequence un pr1 n x) with
+  (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
+  [ apply Rabs_triang | ring ].
+  assert (H10 : Rmin a b = b).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ elim n0; assumption | reflexivity ].
+  assert (H11 : Rmax a b = a).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ elim n0; assumption | reflexivity ].
+  apply Rplus_le_compat.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
+  rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
+  elim H6; intros; apply H8.
+  rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
+  rewrite <-
+    (Ropp_involutive
+      (RiemannInt_SF
+        (mkStepFun
           (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 psi_vn psi_un)))))))
- ; rewrite <- StepFun_P39; rewrite StepFun_P30; rewrite Rmult_1_l;
- rewrite double; rewrite Ropp_plus_distr; apply Rplus_lt_compat.
-apply Rlt_trans with (pos (vn n)).
-elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)).
-rewrite <- Rabs_Ropp; apply RRle_abs.
-assumption.
-replace (pos (vn n)) with (Rabs (vn n - 0));
- [ apply H0; unfold ge in |- *; apply le_trans with N; try assumption;
+    ; rewrite <- StepFun_P39; rewrite StepFun_P30; rewrite Rmult_1_l;
+      rewrite double; rewrite Ropp_plus_distr; apply Rplus_lt_compat.
+  apply Rlt_trans with (pos (vn n)).
+  elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)).
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  assumption.
+  replace (pos (vn n)) with (Rabs (vn n - 0));
+  [ apply H0; unfold ge in |- *; apply le_trans with N; try assumption;
     unfold N in |- *; apply le_trans with (max N0 N1);
-    [ apply le_max_r | apply le_max_l ]
- | unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
-    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
-    left; apply (cond_pos (vn n)) ].
-apply Rlt_trans with (pos (un n)).
-elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)).
-rewrite <- Rabs_Ropp; apply RRle_abs; assumption.
-assumption.
-replace (pos (un n)) with (Rabs (un n - 0));
- [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
+      [ apply le_max_r | apply le_max_l ]
+    | unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+      rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+        left; apply (cond_pos (vn n)) ].
+  apply Rlt_trans with (pos (un n)).
+  elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)).
+  rewrite <- Rabs_Ropp; apply RRle_abs; assumption.
+  assumption.
+  replace (pos (un n)) with (Rabs (un n - 0));
+  [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
     unfold N in |- *; apply le_trans with (max N0 N1); 
-    apply le_max_l
- | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
-    apply Rle_ge; left; apply (cond_pos (un n)) ].
-apply H1; unfold ge in |- *; apply le_trans with N; try assumption;
- unfold N in |- *; apply le_max_r.
-apply Rmult_eq_reg_l with 3;
- [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
-    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | discrR ]
- | discrR ].
+      apply le_max_l
+    | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+      apply Rle_ge; left; apply (cond_pos (un n)) ].
+  apply H1; unfold ge in |- *; apply le_trans with N; try assumption;
+    unfold N in |- *; apply le_max_r.
+  apply Rmult_eq_reg_l with 3;
+    [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+      do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+        rewrite <- Rinv_l_sym; [ ring | discrR ]
+      | discrR ].
 Qed.
 
 Lemma RinvN_pos : forall n:nat, 0 < / (INR n + 1).
-intro; apply Rinv_0_lt_compat; apply Rplus_le_lt_0_compat;
- [ apply pos_INR | apply Rlt_0_1 ].
+Proof.
+  intro; apply Rinv_0_lt_compat; apply Rplus_le_lt_0_compat;
+    [ apply pos_INR | apply Rlt_0_1 ].
 Qed.
 
 Definition RinvN (N:nat) : posreal := mkposreal _ (RinvN_pos N).
- 
+
 Lemma RinvN_cv : Un_cv RinvN 0.
-unfold Un_cv in |- *; intros; assert (H0 := archimed (/ eps)); elim H0;
- clear H0; intros; assert (H2 : (0 <= up (/ eps))%Z).
-apply le_IZR; left; apply Rlt_trans with (/ eps);
- [ apply Rinv_0_lt_compat; assumption | assumption ].
-elim (IZN _ H2); intros; exists x; intros; unfold R_dist in |- *;
- simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0; 
- rewrite Rplus_0_r; assert (H5 : 0 < INR n + 1).
-apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
-rewrite Rabs_right;
- [ idtac
- | left; change (0 < / (INR n + 1)) in |- *; apply Rinv_0_lt_compat;
-    assumption ]; apply Rle_lt_trans with (/ (INR x + 1)).
-apply Rle_Rinv.
-apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
-assumption.
-do 2 rewrite <- (Rplus_comm 1); apply Rplus_le_compat_l; apply le_INR;
- apply H4.
-rewrite <- (Rinv_involutive eps).
-apply Rinv_lt_contravar.
-apply Rmult_lt_0_compat.
-apply Rinv_0_lt_compat; assumption.
-apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
-apply Rlt_trans with (INR x);
- [ rewrite INR_IZR_INZ; rewrite <- H3; apply H0
- | pattern (INR x) at 1 in |- *; rewrite <- Rplus_0_r;
-    apply Rplus_lt_compat_l; apply Rlt_0_1 ].
-red in |- *; intro; rewrite H6 in H; elim (Rlt_irrefl _ H).
+Proof.
+  unfold Un_cv in |- *; intros; assert (H0 := archimed (/ eps)); elim H0;
+    clear H0; intros; assert (H2 : (0 <= up (/ eps))%Z).
+  apply le_IZR; left; apply Rlt_trans with (/ eps);
+    [ apply Rinv_0_lt_compat; assumption | assumption ].
+  elim (IZN _ H2); intros; exists x; intros; unfold R_dist in |- *;
+    simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0; 
+      rewrite Rplus_0_r; assert (H5 : 0 < INR n + 1).
+  apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
+  rewrite Rabs_right;
+    [ idtac
+      | left; change (0 < / (INR n + 1)) in |- *; apply Rinv_0_lt_compat;
+        assumption ]; apply Rle_lt_trans with (/ (INR x + 1)).
+  apply Rle_Rinv.
+  apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
+  assumption.
+  do 2 rewrite <- (Rplus_comm 1); apply Rplus_le_compat_l; apply le_INR;
+    apply H4.
+  rewrite <- (Rinv_involutive eps).
+  apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat.
+  apply Rinv_0_lt_compat; assumption.
+  apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
+  apply Rlt_trans with (INR x);
+    [ rewrite INR_IZR_INZ; rewrite <- H3; apply H0
+      | pattern (INR x) at 1 in |- *; rewrite <- Rplus_0_r;
+        apply Rplus_lt_compat_l; apply Rlt_0_1 ].
+  red in |- *; intro; rewrite H6 in H; elim (Rlt_irrefl _ H).
 Qed.
 
 (**********) 
 Definition RiemannInt (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) : R :=
   match RiemannInt_exists pr RinvN RinvN_cv with
-  | existT a' b' => a'
+    | existT a' b' => a'
   end.
 
 Lemma RiemannInt_P5 :
- forall (f:R -> R) (a b:R) (pr1 pr2:Riemann_integrable f a b),
-   RiemannInt pr1 = RiemannInt pr2.
-intros; unfold RiemannInt in |- *;
- case (RiemannInt_exists pr1 RinvN RinvN_cv);
- case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; 
- eapply UL_sequence;
- [ apply u0
- | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ].
+  forall (f:R -> R) (a b:R) (pr1 pr2:Riemann_integrable f a b),
+    RiemannInt pr1 = RiemannInt pr2.
+Proof.
+  intros; unfold RiemannInt in |- *;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; 
+      eapply UL_sequence;
+        [ apply u0
+          | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ].
 Qed.
 
-(**************************************)
-(* C°([a,b]) is included in L1([a,b]) *)
-(**************************************)
+(***************************************)
+(** C°([a,b]) is included in L1([a,b]) *)
+(***************************************)
 
 Lemma maxN :
- forall (a b:R) (del:posreal),
-   a < b ->
-   sigT (fun n:nat => a + INR n * del < b /\ b <= a + INR (S n) * del).
-intros; set (I := fun n:nat => a + INR n * del < b);
- assert (H0 :  exists n : nat, I n).
-exists 0%nat; unfold I in |- *; rewrite Rmult_0_l; rewrite Rplus_0_r;
- assumption.
-cut (Nbound I).
-intro; assert (H2 := Nzorn H0 H1); elim H2; intros; exists x; elim p; intros;
- split.
-apply H3.
-case (total_order_T (a + INR (S x) * del) b); intro.
-elim s; intro.
-assert (H5 := H4 (S x) a0); elim (le_Sn_n _ H5).
-right; symmetry  in |- *; assumption.
-left; apply r.
-assert (H1 : 0 <= (b - a) / del).
-unfold Rdiv in |- *; apply Rmult_le_pos;
- [ apply Rge_le; apply Rge_minus; apply Rle_ge; left; apply H
- | left; apply Rinv_0_lt_compat; apply (cond_pos del) ].
-elim (archimed ((b - a) / del)); intros;
- assert (H4 : (0 <= up ((b - a) / del))%Z).
-apply le_IZR; simpl in |- *; left; apply Rle_lt_trans with ((b - a) / del);
- assumption.
-assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5;
- unfold Nbound in |- *; exists N; intros; unfold I in H6; 
- apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; 
- left; apply Rle_lt_trans with ((b - a) / del); try assumption;
- apply Rmult_le_reg_l with (pos del);
- [ apply (cond_pos del)
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ del));
-    rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite Rmult_comm; apply Rplus_le_reg_l with a;
-       replace (a + (b - a)) with b; [ left; assumption | ring ]
-    | assert (H7 := cond_pos del); red in |- *; intro; rewrite H8 in H7;
-       elim (Rlt_irrefl _ H7) ] ].
+  forall (a b:R) (del:posreal),
+    a < b ->
+    sigT (fun n:nat => a + INR n * del < b /\ b <= a + INR (S n) * del).
+Proof.
+  intros; set (I := fun n:nat => a + INR n * del < b);
+    assert (H0 :  exists n : nat, I n).
+  exists 0%nat; unfold I in |- *; rewrite Rmult_0_l; rewrite Rplus_0_r;
+    assumption.
+  cut (Nbound I).
+  intro; assert (H2 := Nzorn H0 H1); elim H2; intros; exists x; elim p; intros;
+    split.
+  apply H3.
+  case (total_order_T (a + INR (S x) * del) b); intro.
+  elim s; intro.
+  assert (H5 := H4 (S x) a0); elim (le_Sn_n _ H5).
+  right; symmetry  in |- *; assumption.
+  left; apply r.
+  assert (H1 : 0 <= (b - a) / del).
+  unfold Rdiv in |- *; apply Rmult_le_pos;
+    [ apply Rge_le; apply Rge_minus; apply Rle_ge; left; apply H
+      | left; apply Rinv_0_lt_compat; apply (cond_pos del) ].
+  elim (archimed ((b - a) / del)); intros;
+    assert (H4 : (0 <= up ((b - a) / del))%Z).
+  apply le_IZR; simpl in |- *; left; apply Rle_lt_trans with ((b - a) / del);
+    assumption.
+  assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5;
+    unfold Nbound in |- *; exists N; intros; unfold I in H6; 
+      apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; 
+        left; apply Rle_lt_trans with ((b - a) / del); try assumption;
+          apply Rmult_le_reg_l with (pos del);
+            [ apply (cond_pos del)
+              | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ del));
+                rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+                  [ rewrite Rmult_1_l; rewrite Rmult_comm; apply Rplus_le_reg_l with a;
+                    replace (a + (b - a)) with b; [ left; assumption | ring ]
+                    | assert (H7 := cond_pos del); red in |- *; intro; rewrite H8 in H7;
+                      elim (Rlt_irrefl _ H7) ] ].
 Qed.
 
 Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) {struct N} : Rlist :=
   match N with
-  | O => cons y nil
-  | S p => cons x (SubEquiN p (x + del) y del)
+    | O => cons y nil
+    | S p => cons x (SubEquiN p (x + del) y del)
   end.
 
 Definition max_N (a b:R) (del:posreal) (h:a < b) : nat :=
   match maxN del h with
-  | existT N H0 => N
+    | existT N H0 => N
   end.
 
 Definition SubEqui (a b:R) (del:posreal) (h:a < b) : Rlist :=
   SubEquiN (S (max_N del h)) a b del.
 
 Lemma Heine_cor1 :
- forall (f:R -> R) (a b:R),
-   a < b ->
-   (forall x:R, a <= x <= b -> continuity_pt f x) ->
-   forall eps:posreal,
-     sigT
-       (fun delta:posreal =>
-          delta <= b - a /\
+  forall (f:R -> R) (a b:R),
+    a < b ->
+    (forall x:R, a <= x <= b -> continuity_pt f x) ->
+    forall eps:posreal,
+      sigT
+      (fun delta:posreal =>
+        delta <= b - a /\
+        (forall x y:R,
+          a <= x <= b ->
+          a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps)).
+Proof.
+  intro f; intros;
+    set
+      (E :=
+        fun l:R =>
+          0 < l <= b - a /\
           (forall x y:R,
-             a <= x <= b ->
-             a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps)).
-intro f; intros;
- set
-  (E :=
-   fun l:R =>
-     0 < l <= b - a /\
-     (forall x y:R,
-        a <= x <= b ->
-        a <= y <= b -> Rabs (x - y) < l -> Rabs (f x - f y) < eps));
- assert (H1 : bound E).
-unfold bound in |- *; exists (b - a); unfold is_upper_bound in |- *; intros;
- unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; 
- intros; assumption.
-assert (H2 :  exists x : R, E x).
-assert (H2 := Heine f (fun x:R => a <= x <= b) (compact_P3 a b) H0 eps);
- elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *; 
- split;
- [ split;
-    [ unfold Rmin in |- *; case (Rle_dec x (b - a)); intro;
-       [ apply (cond_pos x) | apply Rlt_Rminus; assumption ]
-    | apply Rmin_r ]
- | intros; apply H3; try assumption; apply Rlt_le_trans with (Rmin x (b - a));
-    [ assumption | apply Rmin_l ] ].
-assert (H3 := completeness E H1 H2); elim H3; intros; cut (0 < x <= b - a).
-intro; elim H4; clear H4; intros; apply existT with (mkposreal _ H4); split.
-apply H5.
-unfold is_lub in p; elim p; intros; unfold is_upper_bound in H6;
- set (D := Rabs (x0 - y)); elim (classic (exists y : R, D < y /\ E y));
- intro.
-elim H11; intros; elim H12; clear H12; intros; unfold E in H13; elim H13;
- intros; apply H15; assumption.
-assert (H12 := not_ex_all_not _ (fun y:R => D < y /\ E y) H11);
- assert (H13 : is_upper_bound E D).
-unfold is_upper_bound in |- *; intros; assert (H14 := H12 x1);
- elim (not_and_or (D < x1) (E x1) H14); intro.
-case (Rle_dec x1 D); intro.
-assumption.
-elim H15; auto with real.
-elim H15; assumption.
-assert (H14 := H7 _ H13); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H10)).
-unfold is_lub in p; unfold is_upper_bound in p; elim p; clear p; intros;
- split.
-elim H2; intros; assert (H7 := H4 _ H6); unfold E in H6; elim H6; clear H6;
- intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; 
- assumption.
-apply H5; intros; unfold E in H6; elim H6; clear H6; intros H6 _; elim H6;
- intros; assumption.
+            a <= x <= b ->
+            a <= y <= b -> Rabs (x - y) < l -> Rabs (f x - f y) < eps));
+      assert (H1 : bound E).
+  unfold bound in |- *; exists (b - a); unfold is_upper_bound in |- *; intros;
+    unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; 
+      intros; assumption.
+  assert (H2 :  exists x : R, E x).
+  assert (H2 := Heine f (fun x:R => a <= x <= b) (compact_P3 a b) H0 eps);
+    elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *; 
+      split;
+        [ split;
+          [ unfold Rmin in |- *; case (Rle_dec x (b - a)); intro;
+            [ apply (cond_pos x) | apply Rlt_Rminus; assumption ]
+            | apply Rmin_r ]
+          | intros; apply H3; try assumption; apply Rlt_le_trans with (Rmin x (b - a));
+            [ assumption | apply Rmin_l ] ].
+  assert (H3 := completeness E H1 H2); elim H3; intros; cut (0 < x <= b - a).
+  intro; elim H4; clear H4; intros; apply existT with (mkposreal _ H4); split.
+  apply H5.
+  unfold is_lub in p; elim p; intros; unfold is_upper_bound in H6;
+    set (D := Rabs (x0 - y)); elim (classic (exists y : R, D < y /\ E y));
+      intro.
+  elim H11; intros; elim H12; clear H12; intros; unfold E in H13; elim H13;
+    intros; apply H15; assumption.
+  assert (H12 := not_ex_all_not _ (fun y:R => D < y /\ E y) H11);
+    assert (H13 : is_upper_bound E D).
+  unfold is_upper_bound in |- *; intros; assert (H14 := H12 x1);
+    elim (not_and_or (D < x1) (E x1) H14); intro.
+  case (Rle_dec x1 D); intro.
+  assumption.
+  elim H15; auto with real.
+  elim H15; assumption.
+  assert (H14 := H7 _ H13); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H10)).
+  unfold is_lub in p; unfold is_upper_bound in p; elim p; clear p; intros;
+    split.
+  elim H2; intros; assert (H7 := H4 _ H6); unfold E in H6; elim H6; clear H6;
+    intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; 
+      assumption.
+  apply H5; intros; unfold E in H6; elim H6; clear H6; intros H6 _; elim H6;
+    intros; assumption.
 Qed.
 
 Lemma Heine_cor2 :
- forall (f:R -> R) (a b:R),
-   (forall x:R, a <= x <= b -> continuity_pt f x) ->
-   forall eps:posreal,
-     sigT
-       (fun delta:posreal =>
-          forall x y:R,
-            a <= x <= b ->
-            a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps).
-intro f; intros; case (total_order_T a b); intro.
-elim s; intro.
-assert (H0 := Heine_cor1 a0 H eps); elim H0; intros; apply existT with x;
- elim p; intros; apply H2; assumption.
-apply existT with (mkposreal _ Rlt_0_1); intros; assert (H3 : x = y);
- [ elim H0; elim H1; intros; rewrite b0 in H3; rewrite b0 in H5;
-    apply Rle_antisym; apply Rle_trans with b; assumption
- | rewrite H3; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
-    apply (cond_pos eps) ].
-apply existT with (mkposreal _ Rlt_0_1); intros; elim H0; intros;
- elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) r)).
+  forall (f:R -> R) (a b:R),
+    (forall x:R, a <= x <= b -> continuity_pt f x) ->
+    forall eps:posreal,
+      sigT
+      (fun delta:posreal =>
+        forall x y:R,
+          a <= x <= b ->
+          a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps).
+Proof.
+  intro f; intros; case (total_order_T a b); intro.
+  elim s; intro.
+  assert (H0 := Heine_cor1 a0 H eps); elim H0; intros; apply existT with x;
+    elim p; intros; apply H2; assumption.
+  apply existT with (mkposreal _ Rlt_0_1); intros; assert (H3 : x = y);
+    [ elim H0; elim H1; intros; rewrite b0 in H3; rewrite b0 in H5;
+      apply Rle_antisym; apply Rle_trans with b; assumption
+      | rewrite H3; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+        apply (cond_pos eps) ].
+  apply existT with (mkposreal _ Rlt_0_1); intros; elim H0; intros;
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) r)).
 Qed.
 
 Lemma SubEqui_P1 :
- forall (a b:R) (del:posreal) (h:a < b), pos_Rl (SubEqui del h) 0 = a.
-intros; unfold SubEqui in |- *; case (maxN del h); intros; reflexivity.
+  forall (a b:R) (del:posreal) (h:a < b), pos_Rl (SubEqui del h) 0 = a.
+Proof.
+  intros; unfold SubEqui in |- *; case (maxN del h); intros; reflexivity.
 Qed.
 
 Lemma SubEqui_P2 :
- forall (a b:R) (del:posreal) (h:a < b),
-   pos_Rl (SubEqui del h) (pred (Rlength (SubEqui del h))) = b.
-intros; unfold SubEqui in |- *; case (maxN del h); intros; clear a0;
- cut
-  (forall (x:nat) (a:R) (del:posreal),
-     pos_Rl (SubEquiN (S x) a b del)
-       (pred (Rlength (SubEquiN (S x) a b del))) = b);
- [ intro; apply H
- | simple induction x0;
-    [ intros; reflexivity
-    | intros;
-       change
-         (pos_Rl (SubEquiN (S n) (a0 + del0) b del0)
-            (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) 
-        in |- *; apply H ] ].
+  forall (a b:R) (del:posreal) (h:a < b),
+    pos_Rl (SubEqui del h) (pred (Rlength (SubEqui del h))) = b.
+Proof.
+  intros; unfold SubEqui in |- *; case (maxN del h); intros; clear a0;
+    cut
+      (forall (x:nat) (a:R) (del:posreal),
+        pos_Rl (SubEquiN (S x) a b del)
+        (pred (Rlength (SubEquiN (S x) a b del))) = b);
+      [ intro; apply H
+        | simple induction x0;
+          [ intros; reflexivity
+            | intros;
+              change
+                (pos_Rl (SubEquiN (S n) (a0 + del0) b del0)
+                  (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) 
+                in |- *; apply H ] ].
 Qed.
 
 Lemma SubEqui_P3 :
- forall (N:nat) (a b:R) (del:posreal), Rlength (SubEquiN N a b del) = S N.
-simple induction N; intros;
- [ reflexivity | simpl in |- *; rewrite H; reflexivity ].
+  forall (N:nat) (a b:R) (del:posreal), Rlength (SubEquiN N a b del) = S N.
+Proof.
+  simple induction N; intros;
+    [ reflexivity | simpl in |- *; rewrite H; reflexivity ].
 Qed.
 
 Lemma SubEqui_P4 :
- forall (N:nat) (a b:R) (del:posreal) (i:nat),
-   (i < S N)%nat -> pos_Rl (SubEquiN (S N) a b del) i = a + INR i * del.
-simple induction N;
- [ intros; inversion H; [ simpl in |- *; ring | elim (le_Sn_O _ H1) ]
- | intros; induction  i as [| i Hreci];
-    [ simpl in |- *; ring
-    | change
-        (pos_Rl (SubEquiN (S n) (a + del) b del) i = a + INR (S i) * del)
-       in |- *; rewrite H; [ rewrite S_INR; ring | apply lt_S_n; apply H0 ] ] ].
+  forall (N:nat) (a b:R) (del:posreal) (i:nat),
+    (i < S N)%nat -> pos_Rl (SubEquiN (S N) a b del) i = a + INR i * del.
+Proof.
+  simple induction N;
+    [ intros; inversion H; [ simpl in |- *; ring | elim (le_Sn_O _ H1) ]
+      | intros; induction  i as [| i Hreci];
+        [ simpl in |- *; ring
+          | change
+            (pos_Rl (SubEquiN (S n) (a + del) b del) i = a + INR (S i) * del)
+            in |- *; rewrite H; [ rewrite S_INR; ring | apply lt_S_n; apply H0 ] ] ].
 Qed.
 
 Lemma SubEqui_P5 :
- forall (a b:R) (del:posreal) (h:a < b),
-   Rlength (SubEqui del h) = S (S (max_N del h)).
-intros; unfold SubEqui in |- *; apply SubEqui_P3.
+  forall (a b:R) (del:posreal) (h:a < b),
+    Rlength (SubEqui del h) = S (S (max_N del h)).
+Proof.
+  intros; unfold SubEqui in |- *; apply SubEqui_P3.
 Qed.
 
 Lemma SubEqui_P6 :
- forall (a b:R) (del:posreal) (h:a < b) (i:nat),
-   (i < S (max_N del h))%nat -> pos_Rl (SubEqui del h) i = a + INR i * del.
-intros; unfold SubEqui in |- *; apply SubEqui_P4; assumption.
+  forall (a b:R) (del:posreal) (h:a < b) (i:nat),
+    (i < S (max_N del h))%nat -> pos_Rl (SubEqui del h) i = a + INR i * del.
+Proof.
+  intros; unfold SubEqui in |- *; apply SubEqui_P4; assumption.
 Qed.
 
 Lemma SubEqui_P7 :
- forall (a b:R) (del:posreal) (h:a < b), ordered_Rlist (SubEqui del h).
-intros; unfold ordered_Rlist in |- *; intros; rewrite SubEqui_P5 in H;
- simpl in H; inversion H.
-rewrite (SubEqui_P6 del h (i:=(max_N del h))).
-replace (S (max_N del h)) with (pred (Rlength (SubEqui del h))).
-rewrite SubEqui_P2; unfold max_N in |- *; case (maxN del h); intros; left;
- elim a0; intros; assumption.
-rewrite SubEqui_P5; reflexivity.
-apply lt_n_Sn.
-repeat rewrite SubEqui_P6.
-3: assumption.
-2: apply le_lt_n_Sm; assumption.
-apply Rplus_le_compat_l; rewrite S_INR; rewrite Rmult_plus_distr_r;
- pattern (INR i * del) at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_le_compat_l; rewrite Rmult_1_l; left; 
- apply (cond_pos del).
+  forall (a b:R) (del:posreal) (h:a < b), ordered_Rlist (SubEqui del h).
+Proof.
+  intros; unfold ordered_Rlist in |- *; intros; rewrite SubEqui_P5 in H;
+    simpl in H; inversion H.
+  rewrite (SubEqui_P6 del h (i:=(max_N del h))).
+  replace (S (max_N del h)) with (pred (Rlength (SubEqui del h))).
+  rewrite SubEqui_P2; unfold max_N in |- *; case (maxN del h); intros; left;
+    elim a0; intros; assumption.
+  rewrite SubEqui_P5; reflexivity.
+  apply lt_n_Sn.
+  repeat rewrite SubEqui_P6.
+  3: assumption.
+  2: apply le_lt_n_Sm; assumption.
+  apply Rplus_le_compat_l; rewrite S_INR; rewrite Rmult_plus_distr_r;
+    pattern (INR i * del) at 1 in |- *; rewrite <- Rplus_0_r;
+      apply Rplus_le_compat_l; rewrite Rmult_1_l; left; 
+        apply (cond_pos del).
 Qed.
 
 Lemma SubEqui_P8 :
- forall (a b:R) (del:posreal) (h:a < b) (i:nat),
-   (i < Rlength (SubEqui del h))%nat -> a <= pos_Rl (SubEqui del h) i <= b.
-intros; split.
-pattern a at 1 in |- *; rewrite <- (SubEqui_P1 del h); apply RList_P5.
-apply SubEqui_P7.
-elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros; apply H1;
- exists i; split; [ reflexivity | assumption ].
-pattern b at 2 in |- *; rewrite <- (SubEqui_P2 del h); apply RList_P7;
- [ apply SubEqui_P7
- | elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros;
-    apply H1; exists i; split; [ reflexivity | assumption ] ].
+  forall (a b:R) (del:posreal) (h:a < b) (i:nat),
+    (i < Rlength (SubEqui del h))%nat -> a <= pos_Rl (SubEqui del h) i <= b.
+Proof.
+  intros; split.
+  pattern a at 1 in |- *; rewrite <- (SubEqui_P1 del h); apply RList_P5.
+  apply SubEqui_P7.
+  elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros; apply H1;
+    exists i; split; [ reflexivity | assumption ].
+  pattern b at 2 in |- *; rewrite <- (SubEqui_P2 del h); apply RList_P7;
+    [ apply SubEqui_P7
+      | elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros;
+        apply H1; exists i; split; [ reflexivity | assumption ] ].
 Qed.
 
 Lemma SubEqui_P9 :
- forall (a b:R) (del:posreal) (f:R -> R) (h:a < b),
-   sigT
-     (fun g:StepFun a b =>
-        g b = f b /\
-        (forall i:nat,
-           (i < pred (Rlength (SubEqui del h)))%nat ->
-           constant_D_eq g
-             (co_interval (pos_Rl (SubEqui del h) i)
-                (pos_Rl (SubEqui del h) (S i)))
-             (f (pos_Rl (SubEqui del h) i)))).
-intros; apply StepFun_P38;
- [ apply SubEqui_P7 | apply SubEqui_P1 | apply SubEqui_P2 ].
+  forall (a b:R) (del:posreal) (f:R -> R) (h:a < b),
+    sigT
+    (fun g:StepFun a b =>
+      g b = f b /\
+      (forall i:nat,
+        (i < pred (Rlength (SubEqui del h)))%nat ->
+        constant_D_eq g
+        (co_interval (pos_Rl (SubEqui del h) i)
+          (pos_Rl (SubEqui del h) (S i)))
+        (f (pos_Rl (SubEqui del h) i)))).
+Proof.
+  intros; apply StepFun_P38;
+    [ apply SubEqui_P7 | apply SubEqui_P1 | apply SubEqui_P2 ].
 Qed.
 
 Lemma RiemannInt_P6 :
- forall (f:R -> R) (a b:R),
-   a < b ->
-   (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
-intros; unfold Riemann_integrable in |- *; intro;
- assert (H1 : 0 < eps / (2 * (b - a))).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos eps)
- | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
-    [ prove_sup0 | apply Rlt_Rminus; assumption ] ].
-assert (H2 : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; left; assumption ].
-assert (H3 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; left; assumption ].
-elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4;
- elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi;
- split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); 
- split.
-2: rewrite StepFun_P18; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
-2: do 2 rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-2: rewrite Rmult_1_r; rewrite Rabs_right.
-2: apply Rmult_lt_reg_l with 2.
-2: prove_sup0.
-2: rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+  forall (f:R -> R) (a b:R),
+    a < b ->
+    (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
+Proof.
+  intros; unfold Riemann_integrable in |- *; intro;
+    assert (H1 : 0 < eps / (2 * (b - a))).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos eps)
+      | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+        [ prove_sup0 | apply Rlt_Rminus; assumption ] ].
+  assert (H2 : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; left; assumption ].
+  assert (H3 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; left; assumption ].
+  elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4;
+    elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi;
+      split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); 
+        split.
+  2: rewrite StepFun_P18; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  2: do 2 rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  2: rewrite Rmult_1_r; rewrite Rabs_right.
+  2: apply Rmult_lt_reg_l with 2.
+  2: prove_sup0.
+  2: rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
-2: rewrite Rmult_1_l; pattern (pos eps) at 1 in |- *; rewrite <- Rplus_0_r;
+  2: rewrite Rmult_1_l; pattern (pos eps) at 1 in |- *; rewrite <- Rplus_0_r;
     rewrite double; apply Rplus_lt_compat_l; apply (cond_pos eps).
-2: discrR.
-2: apply Rle_ge; left; apply Rmult_lt_0_compat.
-2: apply (cond_pos eps).
-2: apply Rinv_0_lt_compat; prove_sup0.
-2: apply Rminus_eq_contra; red in |- *; intro; clear H6; rewrite H7 in H;
+  2: discrR.
+  2: apply Rle_ge; left; apply Rmult_lt_0_compat.
+  2: apply (cond_pos eps).
+  2: apply Rinv_0_lt_compat; prove_sup0.
+  2: apply Rminus_eq_contra; red in |- *; intro; clear H6; rewrite H7 in H;
     elim (Rlt_irrefl _ H).
-2: discrR.
-2: apply Rminus_eq_contra; red in |- *; intro; clear H6; rewrite H7 in H;
+  2: discrR.
+  2: apply Rminus_eq_contra; red in |- *; intro; clear H6; rewrite H7 in H;
     elim (Rlt_irrefl _ H).
-intros; rewrite H2 in H7; rewrite H3 in H7; simpl in |- *;
- unfold fct_cte in |- *;
- cut
-  (forall t:R,
-     a <= t <= b ->
-     t = b \/
-     (exists i : nat,
-        (i < pred (Rlength (SubEqui del H)))%nat /\
-        co_interval (pos_Rl (SubEqui del H) i) (pos_Rl (SubEqui del H) (S i))
-          t)).
-intro; elim (H8 _ H7); intro.
-rewrite H9; rewrite H5; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; left; assumption.
-elim H9; clear H9; intros I [H9 H10]; assert (H11 := H6 I H9 t H10);
- rewrite H11; left; apply H4.
-assumption.
-apply SubEqui_P8; apply lt_trans with (pred (Rlength (SubEqui del H))).
-assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H9;
- elim (lt_n_O _ H9).
-unfold co_interval in H10; elim H10; clear H10; intros; rewrite Rabs_right.
-rewrite SubEqui_P5 in H9; simpl in H9; inversion H9.
-apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) (max_N del H)).
-replace
- (pos_Rl (SubEqui del H) (max_N del H) +
-  (t - pos_Rl (SubEqui del H) (max_N del H))) with t; 
- [ idtac | ring ]; apply Rlt_le_trans with b.
-rewrite H14 in H12;
- assert (H13 : S (max_N del H) = pred (Rlength (SubEqui del H))).
-rewrite SubEqui_P5; reflexivity.
-rewrite H13 in H12; rewrite SubEqui_P2 in H12; apply H12.
-rewrite SubEqui_P6.
-2: apply lt_n_Sn.
-unfold max_N in |- *; case (maxN del H); intros; elim a0; clear a0;
- intros _ H13; replace (a + INR x * del + del) with (a + INR (S x) * del);
- [ assumption | rewrite S_INR; ring ].
-apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) I);
- replace (pos_Rl (SubEqui del H) I + (t - pos_Rl (SubEqui del H) I)) with t;
- [ idtac | ring ];
- replace (pos_Rl (SubEqui del H) I + del) with (pos_Rl (SubEqui del H) (S I)).
-assumption.
-repeat rewrite SubEqui_P6.
-rewrite S_INR; ring.
-assumption.
-apply le_lt_n_Sm; assumption.
-apply Rge_minus; apply Rle_ge; assumption.
-intros; clear H0 H1 H4 phi H5 H6 t H7; case (Req_dec t0 b); intro.
-left; assumption.
-right; set (I := fun j:nat => a + INR j * del <= t0);
- assert (H1 :  exists n : nat, I n).
-exists 0%nat; unfold I in |- *; rewrite Rmult_0_l; rewrite Rplus_0_r; elim H8;
- intros; assumption.
-assert (H4 : Nbound I).
-unfold Nbound in |- *; exists (S (max_N del H)); intros; unfold max_N in |- *;
- case (maxN del H); intros; elim a0; clear a0; intros _ H5; 
- apply INR_le; apply Rmult_le_reg_l with (pos del).
-apply (cond_pos del).
-apply Rplus_le_reg_l with a; do 2 rewrite (Rmult_comm del);
- apply Rle_trans with t0; unfold I in H4; try assumption;
- apply Rle_trans with b; try assumption; elim H8; intros; 
- assumption.
-elim (Nzorn H1 H4); intros N [H5 H6]; assert (H7 : (N < S (max_N del H))%nat).
-unfold max_N in |- *; case (maxN del H); intros; apply INR_lt;
- apply Rmult_lt_reg_l with (pos del).
-apply (cond_pos del).
-apply Rplus_lt_reg_r with a; do 2 rewrite (Rmult_comm del);
- apply Rle_lt_trans with t0; unfold I in H5; try assumption; 
- elim a0; intros; apply Rlt_le_trans with b; try assumption; 
- elim H8; intros.
-elim H11; intro.
-assumption.
-elim H0; assumption.
-exists N; split.
-rewrite SubEqui_P5; simpl in |- *; assumption.
-unfold co_interval in |- *; split.
-rewrite SubEqui_P6.
-apply H5.
-assumption.
-inversion H7.
-replace (S (max_N del H)) with (pred (Rlength (SubEqui del H))).
-rewrite (SubEqui_P2 del H); elim H8; intros.
-elim H11; intro.
-assumption.
-elim H0; assumption.
-rewrite SubEqui_P5; reflexivity.
-rewrite SubEqui_P6.
-case (Rle_dec (a + INR (S N) * del) t0); intro.
-assert (H11 := H6 (S N) r); elim (le_Sn_n _ H11).
-auto with real.
-apply le_lt_n_Sm; assumption.
+  intros; rewrite H2 in H7; rewrite H3 in H7; simpl in |- *;
+    unfold fct_cte in |- *;
+      cut
+        (forall t:R,
+          a <= t <= b ->
+          t = b \/
+          (exists i : nat,
+            (i < pred (Rlength (SubEqui del H)))%nat /\
+            co_interval (pos_Rl (SubEqui del H) i) (pos_Rl (SubEqui del H) (S i))
+            t)).
+  intro; elim (H8 _ H7); intro.
+  rewrite H9; rewrite H5; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; left; assumption.
+  elim H9; clear H9; intros I [H9 H10]; assert (H11 := H6 I H9 t H10);
+    rewrite H11; left; apply H4.
+  assumption.
+  apply SubEqui_P8; apply lt_trans with (pred (Rlength (SubEqui del H))).
+  assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H9;
+    elim (lt_n_O _ H9).
+  unfold co_interval in H10; elim H10; clear H10; intros; rewrite Rabs_right.
+  rewrite SubEqui_P5 in H9; simpl in H9; inversion H9.
+  apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) (max_N del H)).
+  replace
+  (pos_Rl (SubEqui del H) (max_N del H) +
+    (t - pos_Rl (SubEqui del H) (max_N del H))) with t; 
+  [ idtac | ring ]; apply Rlt_le_trans with b.
+  rewrite H14 in H12;
+    assert (H13 : S (max_N del H) = pred (Rlength (SubEqui del H))).
+  rewrite SubEqui_P5; reflexivity.
+  rewrite H13 in H12; rewrite SubEqui_P2 in H12; apply H12.
+  rewrite SubEqui_P6.
+  2: apply lt_n_Sn.
+  unfold max_N in |- *; case (maxN del H); intros; elim a0; clear a0;
+    intros _ H13; replace (a + INR x * del + del) with (a + INR (S x) * del);
+      [ assumption | rewrite S_INR; ring ].
+  apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) I);
+    replace (pos_Rl (SubEqui del H) I + (t - pos_Rl (SubEqui del H) I)) with t;
+    [ idtac | ring ];
+    replace (pos_Rl (SubEqui del H) I + del) with (pos_Rl (SubEqui del H) (S I)).
+  assumption.
+  repeat rewrite SubEqui_P6.
+  rewrite S_INR; ring.
+  assumption.
+  apply le_lt_n_Sm; assumption.
+  apply Rge_minus; apply Rle_ge; assumption.
+  intros; clear H0 H1 H4 phi H5 H6 t H7; case (Req_dec t0 b); intro.
+  left; assumption.
+  right; set (I := fun j:nat => a + INR j * del <= t0);
+    assert (H1 :  exists n : nat, I n).
+  exists 0%nat; unfold I in |- *; rewrite Rmult_0_l; rewrite Rplus_0_r; elim H8;
+    intros; assumption.
+  assert (H4 : Nbound I).
+  unfold Nbound in |- *; exists (S (max_N del H)); intros; unfold max_N in |- *;
+    case (maxN del H); intros; elim a0; clear a0; intros _ H5; 
+      apply INR_le; apply Rmult_le_reg_l with (pos del).
+  apply (cond_pos del).
+  apply Rplus_le_reg_l with a; do 2 rewrite (Rmult_comm del);
+    apply Rle_trans with t0; unfold I in H4; try assumption;
+      apply Rle_trans with b; try assumption; elim H8; intros; 
+        assumption.
+  elim (Nzorn H1 H4); intros N [H5 H6]; assert (H7 : (N < S (max_N del H))%nat).
+  unfold max_N in |- *; case (maxN del H); intros; apply INR_lt;
+    apply Rmult_lt_reg_l with (pos del).
+  apply (cond_pos del).
+  apply Rplus_lt_reg_r with a; do 2 rewrite (Rmult_comm del);
+    apply Rle_lt_trans with t0; unfold I in H5; try assumption; 
+      elim a0; intros; apply Rlt_le_trans with b; try assumption; 
+        elim H8; intros.
+  elim H11; intro.
+  assumption.
+  elim H0; assumption.
+  exists N; split.
+  rewrite SubEqui_P5; simpl in |- *; assumption.
+  unfold co_interval in |- *; split.
+  rewrite SubEqui_P6.
+  apply H5.
+  assumption.
+  inversion H7.
+  replace (S (max_N del H)) with (pred (Rlength (SubEqui del H))).
+  rewrite (SubEqui_P2 del H); elim H8; intros.
+  elim H11; intro.
+  assumption.
+  elim H0; assumption.
+  rewrite SubEqui_P5; reflexivity.
+  rewrite SubEqui_P6.
+  case (Rle_dec (a + INR (S N) * del) t0); intro.
+  assert (H11 := H6 (S N) r); elim (le_Sn_n _ H11).
+  auto with real.
+  apply le_lt_n_Sm; assumption.
 Qed.
 
 Lemma RiemannInt_P7 : forall (f:R -> R) (a:R), Riemann_integrable f a a.
-unfold Riemann_integrable in |- *; intro f; intros;
- split with (mkStepFun (StepFun_P4 a a (f a)));
- split with (mkStepFun (StepFun_P4 a a 0)); split.
-intros; simpl in |- *; unfold fct_cte in |- *; replace t with a.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; right;
- reflexivity.
-generalize H; unfold Rmin, Rmax in |- *; case (Rle_dec a a); intros; elim H0;
- intros; apply Rle_antisym; assumption.
-rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos eps).
+Proof.
+  unfold Riemann_integrable in |- *; intro f; intros;
+    split with (mkStepFun (StepFun_P4 a a (f a)));
+      split with (mkStepFun (StepFun_P4 a a 0)); split.
+  intros; simpl in |- *; unfold fct_cte in |- *; replace t with a.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; right;
+    reflexivity.
+  generalize H; unfold Rmin, Rmax in |- *; case (Rle_dec a a); intros; elim H0;
+    intros; apply Rle_antisym; assumption.
+  rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos eps).
 Qed.
 
 Lemma continuity_implies_RiemannInt :
- forall (f:R -> R) (a b:R),
-   a <= b ->
-   (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
-intros; case (total_order_T a b); intro;
- [ elim s; intro;
-    [ apply RiemannInt_P6; assumption | rewrite b0; apply RiemannInt_P7 ]
- | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)) ].
+  forall (f:R -> R) (a b:R),
+    a <= b ->
+    (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
+Proof.
+  intros; case (total_order_T a b); intro;
+    [ elim s; intro;
+      [ apply RiemannInt_P6; assumption | rewrite b0; apply RiemannInt_P7 ]
+      | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)) ].
 Qed.
 
 Lemma RiemannInt_P8 :
- forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
-   (pr2:Riemann_integrable f b a), RiemannInt pr1 = - RiemannInt pr2.
-intro f; intros; eapply UL_sequence.
-unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv);
- intros; apply u.
-unfold RiemannInt in |- *; case (RiemannInt_exists pr2 RinvN RinvN_cv);
- intros;
- cut
-  (exists psi1 : nat -> StepFun a b,
-     (forall n:nat,
+  forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
+    (pr2:Riemann_integrable f b a), RiemannInt pr1 = - RiemannInt pr2.
+Proof.
+  intro f; intros; eapply UL_sequence.
+  unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv);
+    intros; apply u.
+  unfold RiemannInt in |- *; case (RiemannInt_exists pr2 RinvN RinvN_cv);
+    intros;
+      cut
+        (exists psi1 : nat -> StepFun a b,
+          (forall n:nat,
+            (forall t:R,
+              Rmin a b <= t /\ t <= Rmax a b ->
+              Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
+            Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+  cut
+    (exists psi2 : nat -> StepFun b a,
+      (forall n:nat,
         (forall t:R,
-           Rmin a b <= t /\ t <= Rmax a b ->
-           Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
-        Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
-cut
- (exists psi2 : nat -> StepFun b a,
-    (forall n:nat,
-       (forall t:R,
           Rmin a b <= t /\ t <= Rmax a b ->
           Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
-       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
-intros; elim H; clear H; intros psi2 H; elim H0; clear H0; intros psi1 H0;
- assert (H1 := RinvN_cv); unfold Un_cv in |- *; intros;
- assert (H3 : 0 < eps / 3).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-unfold Un_cv in H1; elim (H1 _ H3); clear H1; intros N0 H1;
- unfold R_dist in H1; simpl in H1;
- assert (H4 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3).
-intros; assert (H5 := H1 _ H4);
- replace (pos (RinvN n)) with (Rabs (/ (INR n + 1) - 0));
- [ assumption
- | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
-    left; apply (cond_pos (RinvN n)) ].
-clear H1; unfold Un_cv in u; elim (u _ H3); clear u; intros N1 H1;
- exists (max N0 N1); intros; unfold R_dist in |- *;
- apply Rle_lt_trans with
-  (Rabs
-     (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-      RiemannInt_SF (phi_sequence RinvN pr2 n)) +
-   Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)).
-rewrite <- (Rabs_Ropp (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
- replace (RiemannInt_SF (phi_sequence RinvN pr1 n) - - x) with
-  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-   RiemannInt_SF (phi_sequence RinvN pr2 n) +
-   - (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
- [ apply Rabs_triang | ring ].
-replace eps with (2 * (eps / 3) + eps / 3).
-apply Rplus_lt_compat.
-rewrite (StepFun_P39 (phi_sequence RinvN pr2 n));
- replace
-  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-   - RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))))
-  with
-  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-   -1 *
-   RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))));
- [ idtac | ring ]; rewrite <- StepFun_P30.
-case (Rle_dec a b); intro.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P32
-          (mkStepFun
-             (StepFun_P28 (-1) (phi_sequence RinvN pr1 n)
-                (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n))))))))).
-apply StepFun_P34; assumption.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P28 1 (psi1 n) (mkStepFun (StepFun_P6 (pre (psi2 n))))))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *; rewrite Rmult_1_l;
- apply Rle_trans with
-  (Rabs (phi_sequence RinvN pr1 n x0 - f x0) +
-   Rabs (f x0 - phi_sequence RinvN pr2 n x0)).
-replace (phi_sequence RinvN pr1 n x0 + -1 * phi_sequence RinvN pr2 n x0) with
- (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
- [ apply Rabs_triang | ring ].
-assert (H7 : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-assert (H8 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-apply Rplus_le_compat.
-elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
- rewrite H7; rewrite H8.
-elim H6; intros; split; left; assumption.
-elim (H n); intros; apply H9; rewrite H7; rewrite H8.
-elim H6; intros; split; left; assumption.
-rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
-elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
- [ apply RRle_abs
- | apply Rlt_trans with (pos (RinvN n));
-    [ assumption
-    | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
-       [ apply le_max_l | assumption ] ] ].
-elim (H n); intros;
- rewrite <-
-  (Ropp_involutive (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi2 n))))))
-  ; rewrite <- StepFun_P39;
- apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
- [ rewrite <- Rabs_Ropp; apply RRle_abs
- | apply Rlt_trans with (pos (RinvN n));
+        Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+  intros; elim H; clear H; intros psi2 H; elim H0; clear H0; intros psi1 H0;
+    assert (H1 := RinvN_cv); unfold Un_cv in |- *; intros;
+      assert (H3 : 0 < eps / 3).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  unfold Un_cv in H1; elim (H1 _ H3); clear H1; intros N0 H1;
+    unfold R_dist in H1; simpl in H1;
+      assert (H4 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3).
+  intros; assert (H5 := H1 _ H4);
+    replace (pos (RinvN n)) with (Rabs (/ (INR n + 1) - 0));
     [ assumption
-    | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
-       [ apply le_max_l | assumption ] ] ].
-assert (Hyp : b <= a).
-auto with real.
-rewrite StepFun_P39; rewrite Rabs_Ropp;
- apply Rle_lt_trans with
-  (RiemannInt_SF
-     (mkStepFun
+      | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+        left; apply (cond_pos (RinvN n)) ].
+  clear H1; unfold Un_cv in u; elim (u _ H3); clear u; intros N1 H1;
+    exists (max N0 N1); intros; unfold R_dist in |- *;
+      apply Rle_lt_trans with
+        (Rabs
+          (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+            RiemannInt_SF (phi_sequence RinvN pr2 n)) +
+          Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)).
+  rewrite <- (Rabs_Ropp (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
+    replace (RiemannInt_SF (phi_sequence RinvN pr1 n) - - x) with
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      RiemannInt_SF (phi_sequence RinvN pr2 n) +
+      - (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
+    [ apply Rabs_triang | ring ].
+  replace eps with (2 * (eps / 3) + eps / 3).
+  apply Rplus_lt_compat.
+  rewrite (StepFun_P39 (phi_sequence RinvN pr2 n));
+    replace
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      - RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))))
+    with
+      (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+        -1 *
+        RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))));
+      [ idtac | ring ]; rewrite <- StepFun_P30.
+  case (Rle_dec a b); intro.
+  apply Rle_lt_trans with
+    (RiemannInt_SF
+      (mkStepFun
         (StepFun_P32
-           (mkStepFun
+          (mkStepFun
+            (StepFun_P28 (-1) (phi_sequence RinvN pr1 n)
+              (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n))))))))).
+  apply StepFun_P34; assumption.
+  apply Rle_lt_trans with
+    (RiemannInt_SF
+      (mkStepFun
+        (StepFun_P28 1 (psi1 n) (mkStepFun (StepFun_P6 (pre (psi2 n))))))).
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *; rewrite Rmult_1_l;
+    apply Rle_trans with
+      (Rabs (phi_sequence RinvN pr1 n x0 - f x0) +
+        Rabs (f x0 - phi_sequence RinvN pr2 n x0)).
+  replace (phi_sequence RinvN pr1 n x0 + -1 * phi_sequence RinvN pr2 n x0) with
+  (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
+  [ apply Rabs_triang | ring ].
+  assert (H7 : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  assert (H8 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  apply Rplus_le_compat.
+  elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
+    rewrite H7; rewrite H8.
+  elim H6; intros; split; left; assumption.
+  elim (H n); intros; apply H9; rewrite H7; rewrite H8.
+  elim H6; intros; split; left; assumption.
+  rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
+  elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
+    [ apply RRle_abs
+      | apply Rlt_trans with (pos (RinvN n));
+        [ assumption
+          | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+            [ apply le_max_l | assumption ] ] ].
+  elim (H n); intros;
+    rewrite <-
+      (Ropp_involutive (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi2 n))))))
+      ; rewrite <- StepFun_P39;
+        apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
+          [ rewrite <- Rabs_Ropp; apply RRle_abs
+            | apply Rlt_trans with (pos (RinvN n));
+              [ assumption
+                | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+                  [ apply le_max_l | assumption ] ] ].
+  assert (Hyp : b <= a).
+  auto with real.
+  rewrite StepFun_P39; rewrite Rabs_Ropp;
+    apply Rle_lt_trans with
+      (RiemannInt_SF
+        (mkStepFun
+          (StepFun_P32
+            (mkStepFun
               (StepFun_P6
-                 (StepFun_P28 (-1) (phi_sequence RinvN pr1 n)
-                    (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))))))))).
-apply StepFun_P34; assumption.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P28 1 (mkStepFun (StepFun_P6 (pre (psi1 n)))) (psi2 n)))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *; rewrite Rmult_1_l;
- apply Rle_trans with
-  (Rabs (phi_sequence RinvN pr1 n x0 - f x0) +
-   Rabs (f x0 - phi_sequence RinvN pr2 n x0)).
-replace (phi_sequence RinvN pr1 n x0 + -1 * phi_sequence RinvN pr2 n x0) with
- (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
- [ apply Rabs_triang | ring ].
-assert (H7 : Rmin a b = b).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ elim n0; assumption | reflexivity ].
-assert (H8 : Rmax a b = a).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ elim n0; assumption | reflexivity ].
-apply Rplus_le_compat.
-elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
- rewrite H7; rewrite H8.
-elim H6; intros; split; left; assumption.
-elim (H n); intros; apply H9; rewrite H7; rewrite H8; elim H6; intros; split;
- left; assumption.
-rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
-elim (H0 n); intros;
- rewrite <-
-  (Ropp_involutive (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi1 n))))))
-  ; rewrite <- StepFun_P39;
- apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
- [ rewrite <- Rabs_Ropp; apply RRle_abs
- | apply Rlt_trans with (pos (RinvN n));
-    [ assumption
-    | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
-       [ apply le_max_l | assumption ] ] ].
-elim (H n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
- [ apply RRle_abs
- | apply Rlt_trans with (pos (RinvN n));
-    [ assumption
-    | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
-       [ apply le_max_l | assumption ] ] ].
-unfold R_dist in H1; apply H1; unfold ge in |- *;
- apply le_trans with (max N0 N1); [ apply le_max_r | assumption ].
-apply Rmult_eq_reg_l with 3;
- [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
-    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | discrR ]
- | discrR ].
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
- rewrite Rmin_comm; rewrite RmaxSym;
- apply (projT2 (phi_sequence_prop RinvN pr2 n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr1 n)).
+                (StepFun_P28 (-1) (phi_sequence RinvN pr1 n)
+                  (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))))))))).
+  apply StepFun_P34; assumption.
+  apply Rle_lt_trans with
+    (RiemannInt_SF
+      (mkStepFun
+        (StepFun_P28 1 (mkStepFun (StepFun_P6 (pre (psi1 n)))) (psi2 n)))).
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *; rewrite Rmult_1_l;
+    apply Rle_trans with
+      (Rabs (phi_sequence RinvN pr1 n x0 - f x0) +
+        Rabs (f x0 - phi_sequence RinvN pr2 n x0)).
+  replace (phi_sequence RinvN pr1 n x0 + -1 * phi_sequence RinvN pr2 n x0) with
+  (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
+  [ apply Rabs_triang | ring ].
+  assert (H7 : Rmin a b = b).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ elim n0; assumption | reflexivity ].
+  assert (H8 : Rmax a b = a).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ elim n0; assumption | reflexivity ].
+  apply Rplus_le_compat.
+  elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
+    rewrite H7; rewrite H8.
+  elim H6; intros; split; left; assumption.
+  elim (H n); intros; apply H9; rewrite H7; rewrite H8; elim H6; intros; split;
+    left; assumption.
+  rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
+  elim (H0 n); intros;
+    rewrite <-
+      (Ropp_involutive (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi1 n))))))
+      ; rewrite <- StepFun_P39;
+        apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
+          [ rewrite <- Rabs_Ropp; apply RRle_abs
+            | apply Rlt_trans with (pos (RinvN n));
+              [ assumption
+                | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+                  [ apply le_max_l | assumption ] ] ].
+  elim (H n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
+    [ apply RRle_abs
+      | apply Rlt_trans with (pos (RinvN n));
+        [ assumption
+          | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+            [ apply le_max_l | assumption ] ] ].
+  unfold R_dist in H1; apply H1; unfold ge in |- *;
+    apply le_trans with (max N0 N1); [ apply le_max_r | assumption ].
+  apply Rmult_eq_reg_l with 3;
+    [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+      do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+        rewrite <- Rinv_l_sym; [ ring | discrR ]
+      | discrR ].
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+    rewrite Rmin_comm; rewrite RmaxSym;
+      apply (projT2 (phi_sequence_prop RinvN pr2 n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr1 n)).
 Qed.
 
 Lemma RiemannInt_P9 :
- forall (f:R -> R) (a:R) (pr:Riemann_integrable f a a), RiemannInt pr = 0.
-intros; assert (H := RiemannInt_P8 pr pr); apply Rmult_eq_reg_l with 2;
- [ rewrite Rmult_0_r; rewrite double; pattern (RiemannInt pr) at 2 in |- *;
-    rewrite H; apply Rplus_opp_r
- | discrR ].
+  forall (f:R -> R) (a:R) (pr:Riemann_integrable f a a), RiemannInt pr = 0.
+Proof.
+  intros; assert (H := RiemannInt_P8 pr pr); apply Rmult_eq_reg_l with 2;
+    [ rewrite Rmult_0_r; rewrite double; pattern (RiemannInt pr) at 2 in |- *;
+      rewrite H; apply Rplus_opp_r
+      | discrR ].
 Qed.
 
 Lemma Req_EM_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
-intros; elim (total_order_T r1 r2); intros;
- [ elim a; intro;
-    [ right; red in |- *; intro; rewrite H in a0; elim (Rlt_irrefl r2 a0)
-    | left; assumption ]
- | right; red in |- *; intro; rewrite H in b; elim (Rlt_irrefl r2 b) ].
+Proof.
+  intros; elim (total_order_T r1 r2); intros;
+    [ elim a; intro;
+      [ right; red in |- *; intro; rewrite H in a0; elim (Rlt_irrefl r2 a0)
+        | left; assumption ]
+      | right; red in |- *; intro; rewrite H in b; elim (Rlt_irrefl r2 b) ].
 Qed.
 
 (* L1([a,b]) is a vectorial space *)
 Lemma RiemannInt_P10 :
- forall (f g:R -> R) (a b l:R),
-   Riemann_integrable f a b ->
-   Riemann_integrable g a b ->
-   Riemann_integrable (fun x:R => f x + l * g x) a b.
-unfold Riemann_integrable in |- *; intros f g; intros; case (Req_EM_T l 0);
- intro.
-elim (X eps); intros; split with x; elim p; intros; split with x0; elim p0;
- intros; split; try assumption; rewrite e; intros; 
- rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption.
-assert (H : 0 < eps / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
-assert (H0 : 0 < eps / (2 * Rabs l)).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos eps)
- | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
-    [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
-elim (X (mkposreal _ H)); intros; elim (X0 (mkposreal _ H0)); intros;
- split with (mkStepFun (StepFun_P28 l x x0)); elim p0; 
- elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); 
- elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split.
-intros; simpl in |- *;
- apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))).
-replace (f t + l * g t - (x t + l * x0 t)) with
- (f t - x t + l * (g t - x0 t)); [ apply Rabs_triang | ring ].
-apply Rplus_le_compat;
- [ apply H3; assumption
- | rewrite Rabs_mult; apply Rmult_le_compat_l;
-    [ apply Rabs_pos | apply H1; assumption ] ].
-rewrite StepFun_P30;
- apply Rle_lt_trans with
-  (Rabs (RiemannInt_SF x1) + Rabs (Rabs l * RiemannInt_SF x2)).
-apply Rabs_triang.
-rewrite (double_var eps); apply Rplus_lt_compat.
-apply H4.
-rewrite Rabs_mult; rewrite Rabs_Rabsolu; apply Rmult_lt_reg_l with (/ Rabs l).
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym;
- [ rewrite Rmult_1_l;
-    replace (/ Rabs l * (eps / 2)) with (eps / (2 * Rabs l));
-    [ apply H2
-    | unfold Rdiv in |- *; rewrite Rinv_mult_distr;
-       [ ring | discrR | apply Rabs_no_R0; assumption ] ]
- | apply Rabs_no_R0; assumption ].
+  forall (f g:R -> R) (a b l:R),
+    Riemann_integrable f a b ->
+    Riemann_integrable g a b ->
+    Riemann_integrable (fun x:R => f x + l * g x) a b.
+Proof.
+  unfold Riemann_integrable in |- *; intros f g; intros; case (Req_EM_T l 0);
+    intro.
+  elim (X eps); intros; split with x; elim p; intros; split with x0; elim p0;
+    intros; split; try assumption; rewrite e; intros; 
+      rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption.
+  assert (H : 0 < eps / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+  assert (H0 : 0 < eps / (2 * Rabs l)).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos eps)
+      | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+        [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
+  elim (X (mkposreal _ H)); intros; elim (X0 (mkposreal _ H0)); intros;
+    split with (mkStepFun (StepFun_P28 l x x0)); elim p0; 
+      elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); 
+        elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split.
+  intros; simpl in |- *;
+    apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))).
+  replace (f t + l * g t - (x t + l * x0 t)) with
+  (f t - x t + l * (g t - x0 t)); [ apply Rabs_triang | ring ].
+  apply Rplus_le_compat;
+    [ apply H3; assumption
+      | rewrite Rabs_mult; apply Rmult_le_compat_l;
+        [ apply Rabs_pos | apply H1; assumption ] ].
+  rewrite StepFun_P30;
+    apply Rle_lt_trans with
+      (Rabs (RiemannInt_SF x1) + Rabs (Rabs l * RiemannInt_SF x2)).
+  apply Rabs_triang.
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  apply H4.
+  rewrite Rabs_mult; rewrite Rabs_Rabsolu; apply Rmult_lt_reg_l with (/ Rabs l).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym;
+    [ rewrite Rmult_1_l;
+      replace (/ Rabs l * (eps / 2)) with (eps / (2 * Rabs l));
+      [ apply H2
+        | unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+          [ ring | discrR | apply Rabs_no_R0; assumption ] ]
+      | apply Rabs_no_R0; assumption ].
 Qed.
 
 Lemma RiemannInt_P11 :
- forall (f:R -> R) (a b l:R) (un:nat -> posreal)
-   (phi1 phi2 psi1 psi2:nat -> StepFun a b),
-   Un_cv un 0 ->
-   (forall n:nat,
+  forall (f:R -> R) (a b l:R) (un:nat -> posreal)
+    (phi1 phi2 psi1 psi2:nat -> StepFun a b),
+    Un_cv un 0 ->
+    (forall n:nat,
       (forall t:R,
-         Rmin a b <= t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi1 n t) /\
+        Rmin a b <= t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi1 n t) /\
       Rabs (RiemannInt_SF (psi1 n)) < un n) ->
-   (forall n:nat,
+    (forall n:nat,
       (forall t:R,
-         Rmin a b <= t <= Rmax a b -> Rabs (f t - phi2 n t) <= psi2 n t) /\
+        Rmin a b <= t <= Rmax a b -> Rabs (f t - phi2 n t) <= psi2 n t) /\
       Rabs (RiemannInt_SF (psi2 n)) < un n) ->
-   Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) l ->
-   Un_cv (fun N:nat => RiemannInt_SF (phi2 N)) l.
-unfold Un_cv in |- *; intro f; intros; intros.
-case (Rle_dec a b); intro Hyp.
-assert (H4 : 0 < eps / 3).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H _ H4); clear H; intros N0 H.
-elim (H2 _ H4); clear H2; intros N1 H2.
-set (N := max N0 N1); exists N; intros; unfold R_dist in |- *.
-apply Rle_lt_trans with
- (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) +
-  Rabs (RiemannInt_SF (phi1 n) - l)).
-replace (RiemannInt_SF (phi2 n) - l) with
- (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n) +
-  (RiemannInt_SF (phi1 n) - l)); [ apply Rabs_triang | ring ].
-replace eps with (2 * (eps / 3) + eps / 3).
-apply Rplus_lt_compat.
-replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with
- (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); 
- [ idtac | ring ].
-rewrite <- StepFun_P30.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (phi2 n) (phi1 n)))))).
-apply StepFun_P34; assumption.
-apply Rle_lt_trans with
- (RiemannInt_SF (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n)))).
-apply StepFun_P37; try assumption; intros; simpl in |- *; rewrite Rmult_1_l.
-apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)).
-replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x));
- [ apply Rabs_triang | ring ].
-rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
-assert (H10 : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-assert (H11 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
-elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-assert (H11 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
-rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
-apply Rlt_trans with (pos (un n)).
-elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
-apply RRle_abs.
-assumption.
-replace (pos (un n)) with (R_dist (un n) 0).
-apply H; unfold ge in |- *; apply le_trans with N; try assumption.
-unfold N in |- *; apply le_max_l.
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; apply Rabs_right.
-apply Rle_ge; left; apply (cond_pos (un n)).
-apply Rlt_trans with (pos (un n)).
-elim (H1 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
-apply RRle_abs; assumption.
-assumption.
-replace (pos (un n)) with (R_dist (un n) 0).
-apply H; unfold ge in |- *; apply le_trans with N; try assumption;
- unfold N in |- *; apply le_max_l.
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
- left; apply (cond_pos (un n)).
-unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
- try assumption; unfold N in |- *; apply le_max_r.
-apply Rmult_eq_reg_l with 3;
- [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
-    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | discrR ]
- | discrR ].
-assert (H4 : 0 < eps / 3).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H _ H4); clear H; intros N0 H.
-elim (H2 _ H4); clear H2; intros N1 H2.
-set (N := max N0 N1); exists N; intros; unfold R_dist in |- *.
-apply Rle_lt_trans with
- (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) +
-  Rabs (RiemannInt_SF (phi1 n) - l)).
-replace (RiemannInt_SF (phi2 n) - l) with
- (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n) +
-  (RiemannInt_SF (phi1 n) - l)); [ apply Rabs_triang | ring ].
-assert (Hyp_b : b <= a).
-auto with real.
-replace eps with (2 * (eps / 3) + eps / 3).
-apply Rplus_lt_compat.
-replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with
- (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); 
- [ idtac | ring ].
-rewrite <- StepFun_P30.
-rewrite StepFun_P39.
-rewrite Rabs_Ropp.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P32
+    Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) l ->
+    Un_cv (fun N:nat => RiemannInt_SF (phi2 N)) l.
+Proof.
+  unfold Un_cv in |- *; intro f; intros; intros.
+  case (Rle_dec a b); intro Hyp.
+  assert (H4 : 0 < eps / 3).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H _ H4); clear H; intros N0 H.
+  elim (H2 _ H4); clear H2; intros N1 H2.
+  set (N := max N0 N1); exists N; intros; unfold R_dist in |- *.
+  apply Rle_lt_trans with
+    (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) +
+      Rabs (RiemannInt_SF (phi1 n) - l)).
+  replace (RiemannInt_SF (phi2 n) - l) with
+  (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n) +
+    (RiemannInt_SF (phi1 n) - l)); [ apply Rabs_triang | ring ].
+  replace eps with (2 * (eps / 3) + eps / 3).
+  apply Rplus_lt_compat.
+  replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with
+  (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); 
+  [ idtac | ring ].
+  rewrite <- StepFun_P30.
+  apply Rle_lt_trans with
+    (RiemannInt_SF
+      (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (phi2 n) (phi1 n)))))).
+  apply StepFun_P34; assumption.
+  apply Rle_lt_trans with
+    (RiemannInt_SF (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n)))).
+  apply StepFun_P37; try assumption; intros; simpl in |- *; rewrite Rmult_1_l.
+  apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)).
+  replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x));
+  [ apply Rabs_triang | ring ].
+  rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
+  assert (H10 : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  assert (H11 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
+  elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  assert (H11 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
+  rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
+  apply Rlt_trans with (pos (un n)).
+  elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
+  apply RRle_abs.
+  assumption.
+  replace (pos (un n)) with (R_dist (un n) 0).
+  apply H; unfold ge in |- *; apply le_trans with N; try assumption.
+  unfold N in |- *; apply le_max_l.
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; apply Rabs_right.
+  apply Rle_ge; left; apply (cond_pos (un n)).
+  apply Rlt_trans with (pos (un n)).
+  elim (H1 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
+  apply RRle_abs; assumption.
+  assumption.
+  replace (pos (un n)) with (R_dist (un n) 0).
+  apply H; unfold ge in |- *; apply le_trans with N; try assumption;
+    unfold N in |- *; apply le_max_l.
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+      left; apply (cond_pos (un n)).
+  unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
+    try assumption; unfold N in |- *; apply le_max_r.
+  apply Rmult_eq_reg_l with 3;
+    [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+      do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+        rewrite <- Rinv_l_sym; [ ring | discrR ]
+      | discrR ].
+  assert (H4 : 0 < eps / 3).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H _ H4); clear H; intros N0 H.
+  elim (H2 _ H4); clear H2; intros N1 H2.
+  set (N := max N0 N1); exists N; intros; unfold R_dist in |- *.
+  apply Rle_lt_trans with
+    (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) +
+      Rabs (RiemannInt_SF (phi1 n) - l)).
+  replace (RiemannInt_SF (phi2 n) - l) with
+  (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n) +
+    (RiemannInt_SF (phi1 n) - l)); [ apply Rabs_triang | ring ].
+  assert (Hyp_b : b <= a).
+  auto with real.
+  replace eps with (2 * (eps / 3) + eps / 3).
+  apply Rplus_lt_compat.
+  replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with
+  (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); 
+  [ idtac | ring ].
+  rewrite <- StepFun_P30.
+  rewrite StepFun_P39.
+  rewrite Rabs_Ropp.
+  apply Rle_lt_trans with
+    (RiemannInt_SF
+      (mkStepFun
+        (StepFun_P32
           (mkStepFun
-             (StepFun_P6
-                (pre (mkStepFun (StepFun_P28 (-1) (phi2 n) (phi1 n))))))))).
-apply StepFun_P34; try assumption.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n))))))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *; rewrite Rmult_1_l.
-apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)).
-replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x));
- [ apply Rabs_triang | ring ].
-rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
-assert (H10 : Rmin a b = b).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ elim Hyp; assumption | reflexivity ].
-assert (H11 : Rmax a b = a).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ elim Hyp; assumption | reflexivity ].
-rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
-elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = b).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ elim Hyp; assumption | reflexivity ].
-assert (H11 : Rmax a b = a).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ elim Hyp; assumption | reflexivity ].
-rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
-rewrite <-
- (Ropp_involutive
+            (StepFun_P6
+              (pre (mkStepFun (StepFun_P28 (-1) (phi2 n) (phi1 n))))))))).
+  apply StepFun_P34; try assumption.
+  apply Rle_lt_trans with
     (RiemannInt_SF
-       (mkStepFun
+      (mkStepFun
+        (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n))))))).
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *; rewrite Rmult_1_l.
+  apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)).
+  replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x));
+  [ apply Rabs_triang | ring ].
+  rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
+  assert (H10 : Rmin a b = b).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ elim Hyp; assumption | reflexivity ].
+  assert (H11 : Rmax a b = a).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ elim Hyp; assumption | reflexivity ].
+  rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
+  elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = b).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ elim Hyp; assumption | reflexivity ].
+  assert (H11 : Rmax a b = a).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ elim Hyp; assumption | reflexivity ].
+  rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
+  rewrite <-
+    (Ropp_involutive
+      (RiemannInt_SF
+        (mkStepFun
           (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n))))))))
- .
-rewrite <- StepFun_P39.
-rewrite StepFun_P30.
-rewrite Rmult_1_l; rewrite double.
-rewrite Ropp_plus_distr; apply Rplus_lt_compat.
-apply Rlt_trans with (pos (un n)).
-elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
-rewrite <- Rabs_Ropp; apply RRle_abs.
-assumption.
-replace (pos (un n)) with (R_dist (un n) 0).
-apply H; unfold ge in |- *; apply le_trans with N; try assumption.
-unfold N in |- *; apply le_max_l.
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; apply Rabs_right.
-apply Rle_ge; left; apply (cond_pos (un n)).
-apply Rlt_trans with (pos (un n)).
-elim (H1 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
-rewrite <- Rabs_Ropp; apply RRle_abs; assumption.
-assumption.
-replace (pos (un n)) with (R_dist (un n) 0).
-apply H; unfold ge in |- *; apply le_trans with N; try assumption;
- unfold N in |- *; apply le_max_l.
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
- left; apply (cond_pos (un n)).
-unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
- try assumption; unfold N in |- *; apply le_max_r.
-apply Rmult_eq_reg_l with 3;
- [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
-    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | discrR ]
- | discrR ].
+    .
+  rewrite <- StepFun_P39.
+  rewrite StepFun_P30.
+  rewrite Rmult_1_l; rewrite double.
+  rewrite Ropp_plus_distr; apply Rplus_lt_compat.
+  apply Rlt_trans with (pos (un n)).
+  elim (H0 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  assumption.
+  replace (pos (un n)) with (R_dist (un n) 0).
+  apply H; unfold ge in |- *; apply le_trans with N; try assumption.
+  unfold N in |- *; apply le_max_l.
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; apply Rabs_right.
+  apply Rle_ge; left; apply (cond_pos (un n)).
+  apply Rlt_trans with (pos (un n)).
+  elim (H1 n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
+  rewrite <- Rabs_Ropp; apply RRle_abs; assumption.
+  assumption.
+  replace (pos (un n)) with (R_dist (un n) 0).
+  apply H; unfold ge in |- *; apply le_trans with N; try assumption;
+    unfold N in |- *; apply le_max_l.
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+      left; apply (cond_pos (un n)).
+  unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
+    try assumption; unfold N in |- *; apply le_max_r.
+  apply Rmult_eq_reg_l with 3;
+    [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+      do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+        rewrite <- Rinv_l_sym; [ ring | discrR ]
+      | discrR ].
 Qed.
 
 Lemma RiemannInt_P12 :
- forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b)
-   (pr2:Riemann_integrable g a b)
-   (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b),
-   a <= b -> RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
-intro f; intros; case (Req_dec l 0); intro.
-pattern l at 2 in |- *; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r;
- unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
- case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; 
- eapply UL_sequence;
- [ apply u0
- | set (psi1 := fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n));
-    set (psi2 := fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n));
-    apply RiemannInt_P11 with f RinvN (phi_sequence RinvN pr1) psi1 psi2;
-    [ apply RinvN_cv
-    | intro; apply (projT2 (phi_sequence_prop RinvN pr1 n))
-    | intro;
-       assert
-        (H1 :
-         (forall t:R,
-            Rmin a b <= t /\ t <= Rmax a b ->
-            Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi2 n t) /\
-         Rabs (RiemannInt_SF (psi2 n)) < RinvN n);
-       [ apply (projT2 (phi_sequence_prop RinvN pr3 n))
-       | elim H1; intros; split; try assumption; intros;
-          replace (f t) with (f t + l * g t);
-          [ apply H2; assumption | rewrite H0; ring ] ]
-    | assumption ] ].
-eapply UL_sequence.
-unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
- intros; apply u.
-unfold Un_cv in |- *; intros; unfold RiemannInt in |- *;
- case (RiemannInt_exists pr1 RinvN RinvN_cv);
- case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *; 
- intros; assert (H2 : 0 < eps / 5).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (u0 _ H2); clear u0; intros N0 H3; assert (H4 := RinvN_cv);
- unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4;
- assert (H5 : 0 < eps / (5 * Rabs l)). 
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption
- | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
-    [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
-elim (u _ H5); clear u; intros N2 H6; assert (H7 := RinvN_cv);
- unfold Un_cv in H7; elim (H7 _ H5); clear H7 H5; intros N3 H5;
- unfold R_dist in H3, H4, H5, H6; set (N := max (max N0 N1) (max N2 N3)).
-assert (H7 : forall n:nat, (n >= N1)%nat -> RinvN n < eps / 5).
-intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0));
- [ unfold RinvN in |- *; apply H4; assumption
- | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
-    left; apply (cond_pos (RinvN n)) ].
-clear H4; assert (H4 := H7); clear H7;
- assert (H7 : forall n:nat, (n >= N3)%nat -> RinvN n < eps / (5 * Rabs l)).
-intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0));
- [ unfold RinvN in |- *; apply H5; assumption
- | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
-    left; apply (cond_pos (RinvN n)) ].
-clear H5; assert (H5 := H7); clear H7; exists N; intros;
- unfold R_dist in |- *.
-apply Rle_lt_trans with
- (Rabs
-    (RiemannInt_SF (phi_sequence RinvN pr3 n) -
-     (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-      l * RiemannInt_SF (phi_sequence RinvN pr2 n))) +
-  Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0) +
-  Rabs l * Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)).
-apply Rle_trans with
- (Rabs
-    (RiemannInt_SF (phi_sequence RinvN pr3 n) -
-     (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-      l * RiemannInt_SF (phi_sequence RinvN pr2 n))) +
-  Rabs
-    (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
-     l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x))).
-replace (RiemannInt_SF (phi_sequence RinvN pr3 n) - (x0 + l * x)) with
- (RiemannInt_SF (phi_sequence RinvN pr3 n) -
-  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-   l * RiemannInt_SF (phi_sequence RinvN pr2 n)) +
-  (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
-   l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)));
- [ apply Rabs_triang | ring ].
-rewrite Rplus_assoc; apply Rplus_le_compat_l; rewrite <- Rabs_mult;
- replace
-  (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
-   l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)) with
-  (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
-   l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
- [ apply Rabs_triang | ring ].
-replace eps with (3 * (eps / 5) + eps / 5 + eps / 5).
-repeat apply Rplus_lt_compat.
-assert
- (H7 :
-   exists psi1 : nat -> StepFun a b,
-    (forall n:nat,
-       (forall t:R,
-          Rmin a b <= t /\ t <= Rmax a b ->
-          Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
-       Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr1 n0)).
-assert
- (H8 :
-   exists psi2 : nat -> StepFun a b,
-    (forall n:nat,
-       (forall t:R,
-          Rmin a b <= t /\ t <= Rmax a b ->
-          Rabs (g t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
-       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr2 n0)).
-assert
- (H9 :
-   exists psi3 : nat -> StepFun a b,
-    (forall n:nat,
-       (forall t:R,
-          Rmin a b <= t /\ t <= Rmax a b ->
-          Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\
-       Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr3 n0)).
-elim H7; clear H7; intros psi1 H7; elim H8; clear H8; intros psi2 H8; elim H9;
- clear H9; intros psi3 H9;
- replace
+  forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b)
+    (pr2:Riemann_integrable g a b)
+    (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b),
+    a <= b -> RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
+Proof.
+  intro f; intros; case (Req_dec l 0); intro.
+  pattern l at 2 in |- *; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r;
+    unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
+      case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; 
+        eapply UL_sequence;
+          [ apply u0
+            | set (psi1 := fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n));
+              set (psi2 := fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n));
+                apply RiemannInt_P11 with f RinvN (phi_sequence RinvN pr1) psi1 psi2;
+                  [ apply RinvN_cv
+                    | intro; apply (projT2 (phi_sequence_prop RinvN pr1 n))
+                    | intro;
+                      assert
+                        (H1 :
+                          (forall t:R,
+                            Rmin a b <= t /\ t <= Rmax a b ->
+                            Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi2 n t) /\
+                          Rabs (RiemannInt_SF (psi2 n)) < RinvN n);
+                        [ apply (projT2 (phi_sequence_prop RinvN pr3 n))
+                          | elim H1; intros; split; try assumption; intros;
+                            replace (f t) with (f t + l * g t);
+                            [ apply H2; assumption | rewrite H0; ring ] ]
+                    | assumption ] ].
+  eapply UL_sequence.
+  unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
+    intros; apply u.
+  unfold Un_cv in |- *; intros; unfold RiemannInt in |- *;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *; 
+      intros; assert (H2 : 0 < eps / 5).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (u0 _ H2); clear u0; intros N0 H3; assert (H4 := RinvN_cv);
+    unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4;
+      assert (H5 : 0 < eps / (5 * Rabs l)). 
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption
+      | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+        [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
+  elim (u _ H5); clear u; intros N2 H6; assert (H7 := RinvN_cv);
+    unfold Un_cv in H7; elim (H7 _ H5); clear H7 H5; intros N3 H5;
+      unfold R_dist in H3, H4, H5, H6; set (N := max (max N0 N1) (max N2 N3)).
+  assert (H7 : forall n:nat, (n >= N1)%nat -> RinvN n < eps / 5).
+  intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0));
+    [ unfold RinvN in |- *; apply H4; assumption
+      | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+        left; apply (cond_pos (RinvN n)) ].
+  clear H4; assert (H4 := H7); clear H7;
+    assert (H7 : forall n:nat, (n >= N3)%nat -> RinvN n < eps / (5 * Rabs l)).
+  intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0));
+    [ unfold RinvN in |- *; apply H5; assumption
+      | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+        left; apply (cond_pos (RinvN n)) ].
+  clear H5; assert (H5 := H7); clear H7; exists N; intros;
+    unfold R_dist in |- *.
+  apply Rle_lt_trans with
+    (Rabs
+      (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+        (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+          l * RiemannInt_SF (phi_sequence RinvN pr2 n))) +
+      Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0) +
+      Rabs l * Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)).
+  apply Rle_trans with
+    (Rabs
+      (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+        (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+          l * RiemannInt_SF (phi_sequence RinvN pr2 n))) +
+      Rabs
+      (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
+        l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x))).
+  replace (RiemannInt_SF (phi_sequence RinvN pr3 n) - (x0 + l * x)) with
   (RiemannInt_SF (phi_sequence RinvN pr3 n) -
-   (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-    l * RiemannInt_SF (phi_sequence RinvN pr2 n))) with
-  (RiemannInt_SF (phi_sequence RinvN pr3 n) +
-   -1 *
-   (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-    l * RiemannInt_SF (phi_sequence RinvN pr2 n))); 
- [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-assert (H11 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-rewrite H10 in H7; rewrite H10 in H8; rewrite H10 in H9; rewrite H11 in H7;
- rewrite H11 in H8; rewrite H11 in H9;
- apply Rle_lt_trans with
-  (RiemannInt_SF
-     (mkStepFun
-        (StepFun_P32
-           (mkStepFun
-              (StepFun_P28 (-1) (phi_sequence RinvN pr3 n)
-                 (mkStepFun
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      l * RiemannInt_SF (phi_sequence RinvN pr2 n)) +
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
+      l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)));
+  [ apply Rabs_triang | ring ].
+  rewrite Rplus_assoc; apply Rplus_le_compat_l; rewrite <- Rabs_mult;
+    replace
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
+      l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x)) with
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) - x0 +
+      l * (RiemannInt_SF (phi_sequence RinvN pr2 n) - x));
+    [ apply Rabs_triang | ring ].
+  replace eps with (3 * (eps / 5) + eps / 5 + eps / 5).
+  repeat apply Rplus_lt_compat.
+  assert
+    (H7 :
+      exists psi1 : nat -> StepFun a b,
+        (forall n:nat,
+          (forall t:R,
+            Rmin a b <= t /\ t <= Rmax a b ->
+            Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
+          Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr1 n0)).
+  assert
+    (H8 :
+      exists psi2 : nat -> StepFun a b,
+        (forall n:nat,
+          (forall t:R,
+            Rmin a b <= t /\ t <= Rmax a b ->
+            Rabs (g t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
+          Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr2 n0)).
+  assert
+    (H9 :
+      exists psi3 : nat -> StepFun a b,
+        (forall n:nat,
+          (forall t:R,
+            Rmin a b <= t /\ t <= Rmax a b ->
+            Rabs (f t + l * g t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\
+          Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr3 n0)).
+  elim H7; clear H7; intros psi1 H7; elim H8; clear H8; intros psi2 H8; elim H9;
+    clear H9; intros psi3 H9;
+      replace
+      (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+        (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+          l * RiemannInt_SF (phi_sequence RinvN pr2 n))) with
+      (RiemannInt_SF (phi_sequence RinvN pr3 n) +
+        -1 *
+        (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+          l * RiemannInt_SF (phi_sequence RinvN pr2 n))); 
+      [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  assert (H11 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  rewrite H10 in H7; rewrite H10 in H8; rewrite H10 in H9; rewrite H11 in H7;
+    rewrite H11 in H8; rewrite H11 in H9;
+      apply Rle_lt_trans with
+        (RiemannInt_SF
+          (mkStepFun
+            (StepFun_P32
+              (mkStepFun
+                (StepFun_P28 (-1) (phi_sequence RinvN pr3 n)
+                  (mkStepFun
                     (StepFun_P28 l (phi_sequence RinvN pr1 n)
-                       (phi_sequence RinvN pr2 n)))))))).
-apply StepFun_P34; assumption.
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P28 1 (psi3 n)
+                      (phi_sequence RinvN pr2 n)))))))).
+  apply StepFun_P34; assumption.
+  apply Rle_lt_trans with
+    (RiemannInt_SF
+      (mkStepFun
+        (StepFun_P28 1 (psi3 n)
           (mkStepFun (StepFun_P28 (Rabs l) (psi1 n) (psi2 n)))))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *; rewrite Rmult_1_l.
-apply Rle_trans with
- (Rabs (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1)) +
-  Rabs
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *; rewrite Rmult_1_l.
+  apply Rle_trans with
+    (Rabs (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1)) +
+      Rabs
+      (f x1 + l * g x1 +
+        -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1))).
+  replace
+  (phi_sequence RinvN pr3 n x1 +
+    -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)) with
+  (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1) +
     (f x1 + l * g x1 +
-     -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1))).
-replace
- (phi_sequence RinvN pr3 n x1 +
-  -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)) with
- (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1) +
-  (f x1 + l * g x1 +
-   -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)));
- [ apply Rabs_triang | ring ].
-rewrite Rplus_assoc; apply Rplus_le_compat.
-elim (H9 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
- apply H13.
-elim H12; intros; split; left; assumption. 
-apply Rle_trans with
- (Rabs (f x1 - phi_sequence RinvN pr1 n x1) +
-  Rabs l * Rabs (g x1 - phi_sequence RinvN pr2 n x1)).
-rewrite <- Rabs_mult;
- replace
-  (f x1 +
-   (l * g x1 +
-    -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)))
-  with
-  (f x1 - phi_sequence RinvN pr1 n x1 +
-   l * (g x1 - phi_sequence RinvN pr2 n x1)); [ apply Rabs_triang | ring ].
-apply Rplus_le_compat.
-elim (H7 n); intros; apply H13.
-elim H12; intros; split; left; assumption.
-apply Rmult_le_compat_l;
- [ apply Rabs_pos
- | elim (H8 n); intros; apply H13; elim H12; intros; split; left; assumption ].
-do 2 rewrite StepFun_P30; rewrite Rmult_1_l;
- replace (3 * (eps / 5)) with (eps / 5 + (eps / 5 + eps / 5));
- [ repeat apply Rplus_lt_compat | ring ].
-apply Rlt_trans with (pos (RinvN n));
- [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n)));
-    [ apply RRle_abs | elim (H9 n); intros; assumption ]
- | apply H4; unfold ge in |- *; apply le_trans with N;
-    [ apply le_trans with (max N0 N1);
-       [ apply le_max_r | unfold N in |- *; apply le_max_l ]
-    | assumption ] ].
-apply Rlt_trans with (pos (RinvN n));
- [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
-    [ apply RRle_abs | elim (H7 n); intros; assumption ]
- | apply H4; unfold ge in |- *; apply le_trans with N;
-    [ apply le_trans with (max N0 N1);
-       [ apply le_max_r | unfold N in |- *; apply le_max_l ]
-    | assumption ] ].
-apply Rmult_lt_reg_l with (/ Rabs l).
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)).
-apply Rlt_trans with (pos (RinvN n));
- [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
-    [ apply RRle_abs | elim (H8 n); intros; assumption ]
- | apply H5; unfold ge in |- *; apply le_trans with N;
-    [ apply le_trans with (max N2 N3);
-       [ apply le_max_r | unfold N in |- *; apply le_max_r ]
-    | assumption ] ].
-unfold Rdiv in |- *; rewrite Rinv_mult_distr;
- [ ring | discrR | apply Rabs_no_R0; assumption ].
-apply Rabs_no_R0; assumption.
-apply H3; unfold ge in |- *; apply le_trans with (max N0 N1);
- [ apply le_max_l
- | apply le_trans with N; [ unfold N in |- *; apply le_max_l | assumption ] ].
-apply Rmult_lt_reg_l with (/ Rabs l).
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)).
-apply H6; unfold ge in |- *; apply le_trans with (max N2 N3);
- [ apply le_max_l
- | apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ] ].
-unfold Rdiv in |- *; rewrite Rinv_mult_distr;
- [ ring | discrR | apply Rabs_no_R0; assumption ].
-apply Rabs_no_R0; assumption.
-apply Rmult_eq_reg_l with 5;
- [ unfold Rdiv in |- *; do 2 rewrite Rmult_plus_distr_l;
-    do 3 rewrite (Rmult_comm 5); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | discrR ]
- | discrR ]. 
+      -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)));
+  [ apply Rabs_triang | ring ].
+  rewrite Rplus_assoc; apply Rplus_le_compat.
+  elim (H9 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
+    apply H13.
+  elim H12; intros; split; left; assumption. 
+  apply Rle_trans with
+    (Rabs (f x1 - phi_sequence RinvN pr1 n x1) +
+      Rabs l * Rabs (g x1 - phi_sequence RinvN pr2 n x1)).
+  rewrite <- Rabs_mult;
+    replace
+    (f x1 +
+      (l * g x1 +
+        -1 * (phi_sequence RinvN pr1 n x1 + l * phi_sequence RinvN pr2 n x1)))
+    with
+      (f x1 - phi_sequence RinvN pr1 n x1 +
+        l * (g x1 - phi_sequence RinvN pr2 n x1)); [ apply Rabs_triang | ring ].
+  apply Rplus_le_compat.
+  elim (H7 n); intros; apply H13.
+  elim H12; intros; split; left; assumption.
+  apply Rmult_le_compat_l;
+    [ apply Rabs_pos
+      | elim (H8 n); intros; apply H13; elim H12; intros; split; left; assumption ].
+  do 2 rewrite StepFun_P30; rewrite Rmult_1_l;
+    replace (3 * (eps / 5)) with (eps / 5 + (eps / 5 + eps / 5));
+    [ repeat apply Rplus_lt_compat | ring ].
+  apply Rlt_trans with (pos (RinvN n));
+    [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n)));
+      [ apply RRle_abs | elim (H9 n); intros; assumption ]
+      | apply H4; unfold ge in |- *; apply le_trans with N;
+        [ apply le_trans with (max N0 N1);
+          [ apply le_max_r | unfold N in |- *; apply le_max_l ]
+          | assumption ] ].
+  apply Rlt_trans with (pos (RinvN n));
+    [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
+      [ apply RRle_abs | elim (H7 n); intros; assumption ]
+      | apply H4; unfold ge in |- *; apply le_trans with N;
+        [ apply le_trans with (max N0 N1);
+          [ apply le_max_r | unfold N in |- *; apply le_max_l ]
+          | assumption ] ].
+  apply Rmult_lt_reg_l with (/ Rabs l).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)).
+  apply Rlt_trans with (pos (RinvN n));
+    [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
+      [ apply RRle_abs | elim (H8 n); intros; assumption ]
+      | apply H5; unfold ge in |- *; apply le_trans with N;
+        [ apply le_trans with (max N2 N3);
+          [ apply le_max_r | unfold N in |- *; apply le_max_r ]
+          | assumption ] ].
+  unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+    [ ring | discrR | apply Rabs_no_R0; assumption ].
+  apply Rabs_no_R0; assumption.
+  apply H3; unfold ge in |- *; apply le_trans with (max N0 N1);
+    [ apply le_max_l
+      | apply le_trans with N; [ unfold N in |- *; apply le_max_l | assumption ] ].
+  apply Rmult_lt_reg_l with (/ Rabs l).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)).
+  apply H6; unfold ge in |- *; apply le_trans with (max N2 N3);
+    [ apply le_max_l
+      | apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ] ].
+  unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+    [ ring | discrR | apply Rabs_no_R0; assumption ].
+  apply Rabs_no_R0; assumption.
+  apply Rmult_eq_reg_l with 5;
+    [ unfold Rdiv in |- *; do 2 rewrite Rmult_plus_distr_l;
+      do 3 rewrite (Rmult_comm 5); repeat rewrite Rmult_assoc;
+        rewrite <- Rinv_l_sym; [ ring | discrR ]
+      | discrR ]. 
 Qed.
 
 Lemma RiemannInt_P13 :
- forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b)
-   (pr2:Riemann_integrable g a b)
-   (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b),
-   RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
-intros; case (Rle_dec a b); intro;
- [ apply RiemannInt_P12; assumption
- | assert (H : b <= a);
-    [ auto with real
-    | replace (RiemannInt pr3) with (- RiemannInt (RiemannInt_P1 pr3));
-       [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
-       replace (RiemannInt pr2) with (- RiemannInt (RiemannInt_P1 pr2));
-       [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
-       replace (RiemannInt pr1) with (- RiemannInt (RiemannInt_P1 pr1));
-       [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
-       rewrite
-        (RiemannInt_P12 (RiemannInt_P1 pr1) (RiemannInt_P1 pr2)
-           (RiemannInt_P1 pr3) H); ring ] ].
+  forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b)
+    (pr2:Riemann_integrable g a b)
+    (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b),
+    RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
+Proof.
+  intros; case (Rle_dec a b); intro;
+    [ apply RiemannInt_P12; assumption
+      | assert (H : b <= a);
+        [ auto with real
+          | replace (RiemannInt pr3) with (- RiemannInt (RiemannInt_P1 pr3));
+            [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+            replace (RiemannInt pr2) with (- RiemannInt (RiemannInt_P1 pr2));
+            [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+            replace (RiemannInt pr1) with (- RiemannInt (RiemannInt_P1 pr1));
+            [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+            rewrite
+              (RiemannInt_P12 (RiemannInt_P1 pr1) (RiemannInt_P1 pr2)
+                (RiemannInt_P1 pr3) H); ring ] ].
 Qed.
 
 Lemma RiemannInt_P14 : forall a b c:R, Riemann_integrable (fct_cte c) a b.
-unfold Riemann_integrable in |- *; intros;
- split with (mkStepFun (StepFun_P4 a b c));
- split with (mkStepFun (StepFun_P4 a b 0)); split;
- [ intros; simpl in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
-    rewrite Rabs_R0; unfold fct_cte in |- *; right; 
-    reflexivity
- | rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
-    apply (cond_pos eps) ].
+Proof.
+  unfold Riemann_integrable in |- *; intros;
+    split with (mkStepFun (StepFun_P4 a b c));
+      split with (mkStepFun (StepFun_P4 a b 0)); split;
+        [ intros; simpl in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+          rewrite Rabs_R0; unfold fct_cte in |- *; right; 
+            reflexivity
+          | rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
+            apply (cond_pos eps) ].
 Qed.
 
 Lemma RiemannInt_P15 :
- forall (a b c:R) (pr:Riemann_integrable (fct_cte c) a b),
-   RiemannInt pr = c * (b - a).
-intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr RinvN RinvN_cv);
- intros; eapply UL_sequence.
-apply u.
-set (phi1 := fun N:nat => phi_sequence RinvN pr N);
- change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) (c * (b - a))) in |- *;
- set (f := fct_cte c);
- assert
-  (H1 :
-    exists psi1 : nat -> StepFun a b,
-     (forall n:nat,
-        (forall t:R,
-           Rmin a b <= t /\ t <= Rmax a b ->
-           Rabs (f t - phi_sequence RinvN pr n t) <= psi1 n t) /\
-        Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr n)).
-elim H1; clear H1; intros psi1 H1;
- set (phi2 := fun n:nat => mkStepFun (StepFun_P4 a b c));
- set (psi2 := fun n:nat => mkStepFun (StepFun_P4 a b 0));
- apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; 
- try assumption.
-apply RinvN_cv.
-intro; split.
-intros; unfold f in |- *; simpl in |- *; unfold Rminus in |- *;
- rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *; 
- right; reflexivity.
-unfold psi2 in |- *; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
- apply (cond_pos (RinvN n)).
-unfold Un_cv in |- *; intros; split with 0%nat; intros; unfold R_dist in |- *;
- unfold phi2 in |- *; rewrite StepFun_P18; unfold Rminus in |- *;
- rewrite Rplus_opp_r; rewrite Rabs_R0; apply H.
+  forall (a b c:R) (pr:Riemann_integrable (fct_cte c) a b),
+    RiemannInt pr = c * (b - a).
+Proof.
+  intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr RinvN RinvN_cv);
+    intros; eapply UL_sequence.
+  apply u.
+  set (phi1 := fun N:nat => phi_sequence RinvN pr N);
+    change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) (c * (b - a))) in |- *;
+      set (f := fct_cte c);
+        assert
+          (H1 :
+            exists psi1 : nat -> StepFun a b,
+              (forall n:nat,
+                (forall t:R,
+                  Rmin a b <= t /\ t <= Rmax a b ->
+                  Rabs (f t - phi_sequence RinvN pr n t) <= psi1 n t) /\
+                Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr n)).
+  elim H1; clear H1; intros psi1 H1;
+    set (phi2 := fun n:nat => mkStepFun (StepFun_P4 a b c));
+      set (psi2 := fun n:nat => mkStepFun (StepFun_P4 a b 0));
+        apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; 
+          try assumption.
+  apply RinvN_cv.
+  intro; split.
+  intros; unfold f in |- *; simpl in |- *; unfold Rminus in |- *;
+    rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *; 
+      right; reflexivity.
+  unfold psi2 in |- *; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
+    apply (cond_pos (RinvN n)).
+  unfold Un_cv in |- *; intros; split with 0%nat; intros; unfold R_dist in |- *;
+    unfold phi2 in |- *; rewrite StepFun_P18; unfold Rminus in |- *;
+      rewrite Rplus_opp_r; rewrite Rabs_R0; apply H.
 Qed.
 
 Lemma RiemannInt_P16 :
- forall (f:R -> R) (a b:R),
-   Riemann_integrable f a b -> Riemann_integrable (fun x:R => Rabs (f x)) a b.
-unfold Riemann_integrable in |- *; intro f; intros; elim (X eps); clear X;
- intros phi [psi [H H0]]; split with (mkStepFun (StepFun_P32 phi));
- split with psi; split; try assumption; intros; simpl in |- *;
- apply Rle_trans with (Rabs (f t - phi t));
- [ apply Rabs_triang_inv2 | apply H; assumption ].
+  forall (f:R -> R) (a b:R),
+    Riemann_integrable f a b -> Riemann_integrable (fun x:R => Rabs (f x)) a b.
+Proof.
+  unfold Riemann_integrable in |- *; intro f; intros; elim (X eps); clear X;
+    intros phi [psi [H H0]]; split with (mkStepFun (StepFun_P32 phi));
+      split with psi; split; try assumption; intros; simpl in |- *;
+        apply Rle_trans with (Rabs (f t - phi t));
+          [ apply Rabs_triang_inv2 | apply H; assumption ].
 Qed.
 
 Lemma Rle_cv_lim :
- forall (Un Vn:nat -> R) (l1 l2:R),
-   (forall n:nat, Un n <= Vn n) -> Un_cv Un l1 -> Un_cv Vn l2 -> l1 <= l2.
-intros; case (Rle_dec l1 l2); intro.
-assumption.
-assert (H2 : l2 < l1).
-auto with real.
-clear n; assert (H3 : 0 < (l1 - l2) / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply Rlt_Rminus; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H1 _ H3); elim (H0 _ H3); clear H0 H1; unfold R_dist in |- *; intros;
- set (N := max x x0); cut (Vn N < Un N).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (H N) H4)).
-apply Rlt_trans with ((l1 + l2) / 2).
-apply Rplus_lt_reg_r with (- l2);
- replace (- l2 + (l1 + l2) / 2) with ((l1 - l2) / 2).
-rewrite Rplus_comm; apply Rle_lt_trans with (Rabs (Vn N - l2)).
-apply RRle_abs.
-apply H1; unfold ge in |- *; unfold N in |- *; apply le_max_r.
-apply Rmult_eq_reg_l with 2;
- [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
-    rewrite (Rmult_plus_distr_r (- l2) ((l1 + l2) * / 2) 2);
-    repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; 
-    [ ring | discrR ]
- | discrR ].
-apply Ropp_lt_cancel; apply Rplus_lt_reg_r with l1;
- replace (l1 + - ((l1 + l2) / 2)) with ((l1 - l2) / 2).
-apply Rle_lt_trans with (Rabs (Un N - l1)).
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
-apply H0; unfold ge in |- *; unfold N in |- *; apply le_max_l.
-apply Rmult_eq_reg_l with 2;
- [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
-    rewrite (Rmult_plus_distr_r l1 (- ((l1 + l2) * / 2)) 2);
-    rewrite <- Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | discrR ]
- | discrR ].
+  forall (Un Vn:nat -> R) (l1 l2:R),
+    (forall n:nat, Un n <= Vn n) -> Un_cv Un l1 -> Un_cv Vn l2 -> l1 <= l2.
+Proof.
+  intros; case (Rle_dec l1 l2); intro.
+  assumption.
+  assert (H2 : l2 < l1).
+  auto with real.
+  clear n; assert (H3 : 0 < (l1 - l2) / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply Rlt_Rminus; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H1 _ H3); elim (H0 _ H3); clear H0 H1; unfold R_dist in |- *; intros;
+    set (N := max x x0); cut (Vn N < Un N).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (H N) H4)).
+  apply Rlt_trans with ((l1 + l2) / 2).
+  apply Rplus_lt_reg_r with (- l2);
+    replace (- l2 + (l1 + l2) / 2) with ((l1 - l2) / 2).
+  rewrite Rplus_comm; apply Rle_lt_trans with (Rabs (Vn N - l2)).
+  apply RRle_abs.
+  apply H1; unfold ge in |- *; unfold N in |- *; apply le_max_r.
+  apply Rmult_eq_reg_l with 2;
+    [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
+      rewrite (Rmult_plus_distr_r (- l2) ((l1 + l2) * / 2) 2);
+        repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; 
+          [ ring | discrR ]
+      | discrR ].
+  apply Ropp_lt_cancel; apply Rplus_lt_reg_r with l1;
+    replace (l1 + - ((l1 + l2) / 2)) with ((l1 - l2) / 2).
+  apply Rle_lt_trans with (Rabs (Un N - l1)).
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
+  apply H0; unfold ge in |- *; unfold N in |- *; apply le_max_l.
+  apply Rmult_eq_reg_l with 2;
+    [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
+      rewrite (Rmult_plus_distr_r l1 (- ((l1 + l2) * / 2)) 2);
+        rewrite <- Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
+          rewrite <- Rinv_l_sym; [ ring | discrR ]
+      | discrR ].
 Qed.
 
 Lemma RiemannInt_P17 :
- forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
-   (pr2:Riemann_integrable (fun x:R => Rabs (f x)) a b),
-   a <= b -> Rabs (RiemannInt pr1) <= RiemannInt pr2.
-intro f; intros; unfold RiemannInt in |- *;
- case (RiemannInt_exists pr1 RinvN RinvN_cv);
- case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
- set (phi1 := phi_sequence RinvN pr1) in u0;
- set (phi2 := fun N:nat => mkStepFun (StepFun_P32 (phi1 N)));
- apply Rle_cv_lim with
-  (fun N:nat => Rabs (RiemannInt_SF (phi1 N)))
-  (fun N:nat => RiemannInt_SF (phi2 N)).
-intro; unfold phi2 in |- *; apply StepFun_P34; assumption.
- apply (continuity_seq Rabs (fun N:nat => RiemannInt_SF (phi1 N)) x0);
- try assumption.
-apply Rcontinuity_abs.
-set (phi3 := phi_sequence RinvN pr2);
- assert
-  (H0 :
-    exists psi3 : nat -> StepFun a b,
-     (forall n:nat,
-        (forall t:R,
-           Rmin a b <= t /\ t <= Rmax a b ->
-           Rabs (Rabs (f t) - phi3 n t) <= psi3 n t) /\
-        Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
-assert
- (H1 :
-   exists psi2 : nat -> StepFun a b,
-    (forall n:nat,
-       (forall t:R,
-          Rmin a b <= t /\ t <= Rmax a b ->
-          Rabs (Rabs (f t) - phi2 n t) <= psi2 n t) /\
-       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
-assert
- (H1 :
-   exists psi2 : nat -> StepFun a b,
-    (forall n:nat,
-       (forall t:R,
-          Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi2 n t) /\
-       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr1 n)).
-elim H1; clear H1; intros psi2 H1; split with psi2; intros; elim (H1 n);
- clear H1; intros; split; try assumption.
-intros; unfold phi2 in |- *; simpl in |- *;
- apply Rle_trans with (Rabs (f t - phi1 n t)).
-apply Rabs_triang_inv2.
-apply H1; assumption.
-elim H0; clear H0; intros psi3 H0; elim H1; clear H1; intros psi2 H1;
- apply RiemannInt_P11 with (fun x:R => Rabs (f x)) RinvN phi3 psi3 psi2;
- try assumption; apply RinvN_cv.
+  forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
+    (pr2:Riemann_integrable (fun x:R => Rabs (f x)) a b),
+    a <= b -> Rabs (RiemannInt pr1) <= RiemannInt pr2.
+Proof.
+  intro f; intros; unfold RiemannInt in |- *;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
+      set (phi1 := phi_sequence RinvN pr1) in u0;
+        set (phi2 := fun N:nat => mkStepFun (StepFun_P32 (phi1 N)));
+          apply Rle_cv_lim with
+            (fun N:nat => Rabs (RiemannInt_SF (phi1 N)))
+            (fun N:nat => RiemannInt_SF (phi2 N)).
+  intro; unfold phi2 in |- *; apply StepFun_P34; assumption.
+  apply (continuity_seq Rabs (fun N:nat => RiemannInt_SF (phi1 N)) x0);
+    try assumption.
+  apply Rcontinuity_abs.
+  set (phi3 := phi_sequence RinvN pr2);
+    assert
+      (H0 :
+        exists psi3 : nat -> StepFun a b,
+          (forall n:nat,
+            (forall t:R,
+              Rmin a b <= t /\ t <= Rmax a b ->
+              Rabs (Rabs (f t) - phi3 n t) <= psi3 n t) /\
+            Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
+  assert
+    (H1 :
+      exists psi2 : nat -> StepFun a b,
+        (forall n:nat,
+          (forall t:R,
+            Rmin a b <= t /\ t <= Rmax a b ->
+            Rabs (Rabs (f t) - phi2 n t) <= psi2 n t) /\
+          Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+  assert
+    (H1 :
+      exists psi2 : nat -> StepFun a b,
+        (forall n:nat,
+          (forall t:R,
+            Rmin a b <= t /\ t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi2 n t) /\
+          Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr1 n)).
+  elim H1; clear H1; intros psi2 H1; split with psi2; intros; elim (H1 n);
+    clear H1; intros; split; try assumption.
+  intros; unfold phi2 in |- *; simpl in |- *;
+    apply Rle_trans with (Rabs (f t - phi1 n t)).
+  apply Rabs_triang_inv2.
+  apply H1; assumption.
+  elim H0; clear H0; intros psi3 H0; elim H1; clear H1; intros psi2 H1;
+    apply RiemannInt_P11 with (fun x:R => Rabs (f x)) RinvN phi3 psi3 psi2;
+      try assumption; apply RinvN_cv.
 Qed.
 
 Lemma RiemannInt_P18 :
- forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
-   (pr2:Riemann_integrable g a b),
-   a <= b ->
-   (forall x:R, a < x < b -> f x = g x) -> RiemannInt pr1 = RiemannInt pr2.
-intro f; intros; unfold RiemannInt in |- *;
- case (RiemannInt_exists pr1 RinvN RinvN_cv);
- case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; 
- eapply UL_sequence.
-apply u0.
-set (phi1 := fun N:nat => phi_sequence RinvN pr1 N);
- change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) x) in |- *;
- assert
-  (H1 :
-    exists psi1 : nat -> StepFun a b,
-     (forall n:nat,
-        (forall t:R,
-           Rmin a b <= t /\ t <= Rmax a b ->
-           Rabs (f t - phi1 n t) <= psi1 n t) /\
-        Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr1 n)). 
-elim H1; clear H1; intros psi1 H1;
- set (phi2 := fun N:nat => phi_sequence RinvN pr2 N).
-set
- (phi2_aux :=
-  fun (N:nat) (x:R) =>
-    match Req_EM_T x a with
-    | left _ => f a
-    | right _ =>
-        match Req_EM_T x b with
-        | left _ => f b
-        | right _ => phi2 N x
-        end
-    end).
-cut (forall N:nat, IsStepFun (phi2_aux N) a b).
-intro; set (phi2_m := fun N:nat => mkStepFun (X N)).
-assert
- (H2 :
-   exists psi2 : nat -> StepFun a b,
-    (forall n:nat,
-       (forall t:R,
-          Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi2 n t) <= psi2 n t) /\
-       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
-elim H2; clear H2; intros psi2 H2;
- apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; 
- try assumption. 
-apply RinvN_cv.
-intro; elim (H2 n); intros; split; try assumption.
-intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
- case (Req_EM_T t a); case (Req_EM_T t b); intros.
-rewrite e0; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- apply Rle_trans with (Rabs (g t - phi2 n t)).
-apply Rabs_pos.
-pattern a at 3 in |- *; rewrite <- e0; apply H3; assumption.
-rewrite e; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- apply Rle_trans with (Rabs (g t - phi2 n t)).
-apply Rabs_pos.
-pattern a at 3 in |- *; rewrite <- e; apply H3; assumption.
-rewrite e; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- apply Rle_trans with (Rabs (g t - phi2 n t)).
-apply Rabs_pos.
-pattern b at 3 in |- *; rewrite <- e; apply H3; assumption.
-replace (f t) with (g t).
-apply H3; assumption.
-symmetry  in |- *; apply H0; elim H5; clear H5; intros.
-assert (H7 : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n2; assumption ].
-assert (H8 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n2; assumption ].
-rewrite H7 in H5; rewrite H8 in H6; split.
-elim H5; intro; [ assumption | elim n1; symmetry  in |- *; assumption ].
-elim H6; intro; [ assumption | elim n0; assumption ].
-cut (forall N:nat, RiemannInt_SF (phi2_m N) = RiemannInt_SF (phi2 N)).
-intro; unfold Un_cv in |- *; intros; elim (u _ H4); intros; exists x1; intros;
- rewrite (H3 n); apply H5; assumption.
-intro; apply Rle_antisym.
-apply StepFun_P37; try assumption.
-intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
- case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
-elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
-elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
-elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
-right; reflexivity.
-apply StepFun_P37; try assumption.
-intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
- case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
-elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
-elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
-elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
-right; reflexivity.
-intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2;
- unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2];
- split with l; split with lf; unfold adapted_couple in H2; 
- decompose [and] H2; clear H2; unfold adapted_couple in |- *; 
- repeat split; try assumption.
-intros; assert (H9 := H8 i H2); unfold constant_D_eq, open_interval in H9;
- unfold constant_D_eq, open_interval in |- *; intros; 
- rewrite <- (H9 x1 H7); assert (H10 : a <= pos_Rl l i).
-replace a with (Rmin a b).
-rewrite <- H5; elim (RList_P6 l); intros; apply H10.
-assumption.
-apply le_O_n.
-apply lt_trans with (pred (Rlength l)); [ assumption | apply lt_pred_n_n ].
-apply neq_O_lt; intro; rewrite <- H12 in H6; discriminate.
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-assert (H11 : pos_Rl l (S i) <= b).
-replace b with (Rmax a b).
-rewrite <- H4; elim (RList_P6 l); intros; apply H11.
-assumption.
-apply lt_le_S; assumption.
-apply lt_pred_n_n; apply neq_O_lt; intro; rewrite <- H13 in H6; discriminate.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-elim H7; clear H7; intros; unfold phi2_aux in |- *; case (Req_EM_T x1 a);
- case (Req_EM_T x1 b); intros.
-rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
-rewrite e in H7; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H7)).
-rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
-reflexivity.
+  forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
+    (pr2:Riemann_integrable g a b),
+    a <= b ->
+    (forall x:R, a < x < b -> f x = g x) -> RiemannInt pr1 = RiemannInt pr2.
+Proof.
+  intro f; intros; unfold RiemannInt in |- *;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; 
+      eapply UL_sequence.
+  apply u0.
+  set (phi1 := fun N:nat => phi_sequence RinvN pr1 N);
+    change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) x) in |- *;
+      assert
+        (H1 :
+          exists psi1 : nat -> StepFun a b,
+            (forall n:nat,
+              (forall t:R,
+                Rmin a b <= t /\ t <= Rmax a b ->
+                Rabs (f t - phi1 n t) <= psi1 n t) /\
+              Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr1 n)). 
+  elim H1; clear H1; intros psi1 H1;
+    set (phi2 := fun N:nat => phi_sequence RinvN pr2 N).
+  set
+    (phi2_aux :=
+      fun (N:nat) (x:R) =>
+        match Req_EM_T x a with
+          | left _ => f a
+          | right _ =>
+            match Req_EM_T x b with
+              | left _ => f b
+              | right _ => phi2 N x
+            end
+        end).
+  cut (forall N:nat, IsStepFun (phi2_aux N) a b).
+  intro; set (phi2_m := fun N:nat => mkStepFun (X N)).
+  assert
+    (H2 :
+      exists psi2 : nat -> StepFun a b,
+        (forall n:nat,
+          (forall t:R,
+            Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi2 n t) <= psi2 n t) /\
+          Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
+  elim H2; clear H2; intros psi2 H2;
+    apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; 
+      try assumption. 
+  apply RinvN_cv.
+  intro; elim (H2 n); intros; split; try assumption.
+  intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+    case (Req_EM_T t a); case (Req_EM_T t b); intros.
+  rewrite e0; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    apply Rle_trans with (Rabs (g t - phi2 n t)).
+  apply Rabs_pos.
+  pattern a at 3 in |- *; rewrite <- e0; apply H3; assumption.
+  rewrite e; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    apply Rle_trans with (Rabs (g t - phi2 n t)).
+  apply Rabs_pos.
+  pattern a at 3 in |- *; rewrite <- e; apply H3; assumption.
+  rewrite e; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    apply Rle_trans with (Rabs (g t - phi2 n t)).
+  apply Rabs_pos.
+  pattern b at 3 in |- *; rewrite <- e; apply H3; assumption.
+  replace (f t) with (g t).
+  apply H3; assumption.
+  symmetry  in |- *; apply H0; elim H5; clear H5; intros.
+  assert (H7 : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n2; assumption ].
+  assert (H8 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n2; assumption ].
+  rewrite H7 in H5; rewrite H8 in H6; split.
+  elim H5; intro; [ assumption | elim n1; symmetry  in |- *; assumption ].
+  elim H6; intro; [ assumption | elim n0; assumption ].
+  cut (forall N:nat, RiemannInt_SF (phi2_m N) = RiemannInt_SF (phi2 N)).
+  intro; unfold Un_cv in |- *; intros; elim (u _ H4); intros; exists x1; intros;
+    rewrite (H3 n); apply H5; assumption.
+  intro; apply Rle_antisym.
+  apply StepFun_P37; try assumption.
+  intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+    case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
+  elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
+  elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
+  elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
+  right; reflexivity.
+  apply StepFun_P37; try assumption.
+  intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+    case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
+  elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
+  elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
+  elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
+  right; reflexivity.
+  intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2;
+    unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2];
+      split with l; split with lf; unfold adapted_couple in H2; 
+        decompose [and] H2; clear H2; unfold adapted_couple in |- *; 
+          repeat split; try assumption.
+  intros; assert (H9 := H8 i H2); unfold constant_D_eq, open_interval in H9;
+    unfold constant_D_eq, open_interval in |- *; intros; 
+      rewrite <- (H9 x1 H7); assert (H10 : a <= pos_Rl l i).
+  replace a with (Rmin a b).
+  rewrite <- H5; elim (RList_P6 l); intros; apply H10.
+  assumption.
+  apply le_O_n.
+  apply lt_trans with (pred (Rlength l)); [ assumption | apply lt_pred_n_n ].
+  apply neq_O_lt; intro; rewrite <- H12 in H6; discriminate.
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  assert (H11 : pos_Rl l (S i) <= b).
+  replace b with (Rmax a b).
+  rewrite <- H4; elim (RList_P6 l); intros; apply H11.
+  assumption.
+  apply lt_le_S; assumption.
+  apply lt_pred_n_n; apply neq_O_lt; intro; rewrite <- H13 in H6; discriminate.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  elim H7; clear H7; intros; unfold phi2_aux in |- *; case (Req_EM_T x1 a);
+    case (Req_EM_T x1 b); intros.
+  rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
+  rewrite e in H7; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H7)).
+  rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
+  reflexivity.
 Qed.
 
 Lemma RiemannInt_P19 :
- forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
-   (pr2:Riemann_integrable g a b),
-   a <= b ->
-   (forall x:R, a < x < b -> f x <= g x) -> RiemannInt pr1 <= RiemannInt pr2.
-intro f; intros; apply Rplus_le_reg_l with (- RiemannInt pr1);
- rewrite Rplus_opp_l; rewrite Rplus_comm;
- apply Rle_trans with (Rabs (RiemannInt (RiemannInt_P10 (-1) pr2 pr1))).
-apply Rabs_pos.
-replace (RiemannInt pr2 + - RiemannInt pr1) with
- (RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))).
-apply
- (RiemannInt_P17 (RiemannInt_P10 (-1) pr2 pr1)
-    (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); 
- assumption.
-replace (RiemannInt pr2 + - RiemannInt pr1) with
- (RiemannInt (RiemannInt_P10 (-1) pr2 pr1)).
-apply RiemannInt_P18; try assumption.
-intros; apply Rabs_right.
-apply Rle_ge; apply Rplus_le_reg_l with (f x); rewrite Rplus_0_r;
- replace (f x + (g x + -1 * f x)) with (g x); [ apply H0; assumption | ring ].
-rewrite (RiemannInt_P12 pr2 pr1 (RiemannInt_P10 (-1) pr2 pr1));
- [ ring | assumption ].
+  forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
+    (pr2:Riemann_integrable g a b),
+    a <= b ->
+    (forall x:R, a < x < b -> f x <= g x) -> RiemannInt pr1 <= RiemannInt pr2.
+Proof.
+  intro f; intros; apply Rplus_le_reg_l with (- RiemannInt pr1);
+    rewrite Rplus_opp_l; rewrite Rplus_comm;
+      apply Rle_trans with (Rabs (RiemannInt (RiemannInt_P10 (-1) pr2 pr1))).
+  apply Rabs_pos.
+  replace (RiemannInt pr2 + - RiemannInt pr1) with
+  (RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))).
+  apply
+    (RiemannInt_P17 (RiemannInt_P10 (-1) pr2 pr1)
+      (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); 
+    assumption.
+  replace (RiemannInt pr2 + - RiemannInt pr1) with
+  (RiemannInt (RiemannInt_P10 (-1) pr2 pr1)).
+  apply RiemannInt_P18; try assumption.
+  intros; apply Rabs_right.
+  apply Rle_ge; apply Rplus_le_reg_l with (f x); rewrite Rplus_0_r;
+    replace (f x + (g x + -1 * f x)) with (g x); [ apply H0; assumption | ring ].
+  rewrite (RiemannInt_P12 pr2 pr1 (RiemannInt_P10 (-1) pr2 pr1));
+    [ ring | assumption ].
 Qed.
 
 Lemma FTC_P1 :
- forall (f:R -> R) (a b:R),
-   a <= b ->
-   (forall x:R, a <= x <= b -> continuity_pt f x) ->
-   forall x:R, a <= x -> x <= b -> Riemann_integrable f a x.
-intros; apply continuity_implies_RiemannInt;
- [ assumption
- | intros; apply H0; elim H3; intros; split;
-    assumption || apply Rle_trans with x; assumption ].
+  forall (f:R -> R) (a b:R),
+    a <= b ->
+    (forall x:R, a <= x <= b -> continuity_pt f x) ->
+    forall x:R, a <= x -> x <= b -> Riemann_integrable f a x.
+Proof.
+  intros; apply continuity_implies_RiemannInt;
+    [ assumption
+      | intros; apply H0; elim H3; intros; split;
+        assumption || apply Rle_trans with x; assumption ].
 Qed.
 
 Definition primitive (f:R -> R) (a b:R) (h:a <= b)
   (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) 
   (x:R) : R :=
   match Rle_dec a x with
-  | left r =>
+    | left r =>
       match Rle_dec x b with
-      | left r0 => RiemannInt (pr x r r0)
-      | right _ => f b * (x - b) + RiemannInt (pr b h (Rle_refl b))
+        | left r0 => RiemannInt (pr x r r0)
+        | right _ => f b * (x - b) + RiemannInt (pr b h (Rle_refl b))
       end
-  | right _ => f a * (x - a)
+    | right _ => f a * (x - a)
   end.
 
 Lemma RiemannInt_P20 :
- forall (f:R -> R) (a b:R) (h:a <= b)
-   (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x)
-   (pr0:Riemann_integrable f a b),
-   RiemannInt pr0 = primitive h pr b - primitive h pr a.
-intros; replace (primitive h pr a) with 0.
-replace (RiemannInt pr0) with (primitive h pr b).
-ring.
-unfold primitive in |- *; case (Rle_dec a b); case (Rle_dec b b); intros;
- [ apply RiemannInt_P5
- | elim n; right; reflexivity
- | elim n; assumption
- | elim n0; assumption ].
-symmetry  in |- *; unfold primitive in |- *; case (Rle_dec a a);
- case (Rle_dec a b); intros;
- [ apply RiemannInt_P9
- | elim n; assumption
- | elim n; right; reflexivity
- | elim n0; right; reflexivity ].
+  forall (f:R -> R) (a b:R) (h:a <= b)
+    (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x)
+    (pr0:Riemann_integrable f a b),
+    RiemannInt pr0 = primitive h pr b - primitive h pr a.
+Proof.
+  intros; replace (primitive h pr a) with 0.
+  replace (RiemannInt pr0) with (primitive h pr b).
+  ring.
+  unfold primitive in |- *; case (Rle_dec a b); case (Rle_dec b b); intros;
+    [ apply RiemannInt_P5
+      | elim n; right; reflexivity
+      | elim n; assumption
+      | elim n0; assumption ].
+  symmetry  in |- *; unfold primitive in |- *; case (Rle_dec a a);
+    case (Rle_dec a b); intros;
+      [ apply RiemannInt_P9
+        | elim n; assumption
+        | elim n; right; reflexivity
+        | elim n0; right; reflexivity ].
 Qed.
 
 Lemma RiemannInt_P21 :
- forall (f:R -> R) (a b c:R),
-   a <= b ->
-   b <= c ->
-   Riemann_integrable f a b ->
-   Riemann_integrable f b c -> Riemann_integrable f a c.
-unfold Riemann_integrable in |- *; intros f a b c Hyp1 Hyp2 X X0 eps.
-assert (H : 0 < eps / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (X (mkposreal _ H)); clear X; intros phi1 [psi1 H1];
- elim (X0 (mkposreal _ H)); clear X0; intros phi2 [psi2 H2].
-set
- (phi3 :=
-  fun x:R =>
-    match Rle_dec a x with
-    | left _ =>
-        match Rle_dec x b with
-        | left _ => phi1 x
-        | right _ => phi2 x
-        end
-    | right _ => 0
-    end).
-set
- (psi3 :=
-  fun x:R =>
-    match Rle_dec a x with
-    | left _ =>
-        match Rle_dec x b with
-        | left _ => psi1 x
-        | right _ => psi2 x
-        end
-    | right _ => 0
-    end).
-cut (IsStepFun phi3 a c).
-intro; cut (IsStepFun psi3 a b).
-intro; cut (IsStepFun psi3 b c).
-intro; cut (IsStepFun psi3 a c).
-intro; split with (mkStepFun X); split with (mkStepFun X2); simpl in |- *;
- split.
-intros; unfold phi3, psi3 in |- *; case (Rle_dec t b); case (Rle_dec a t);
- intros.
-elim H1; intros; apply H3.
-replace (Rmin a b) with a.
-replace (Rmax a b) with b.
-split; assumption.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-elim n; replace a with (Rmin a c).
-elim H0; intros; assumption.
-unfold Rmin in |- *; case (Rle_dec a c); intro;
- [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
-elim H2; intros; apply H3.
-replace (Rmax b c) with (Rmax a c).
-elim H0; intros; split; try assumption.
-replace (Rmin b c) with b.
-auto with real.
-unfold Rmin in |- *; case (Rle_dec b c); intro;
- [ reflexivity | elim n0; assumption ].
-unfold Rmax in |- *; case (Rle_dec a c); case (Rle_dec b c); intros;
- try (elim n0; assumption || elim n0; apply Rle_trans with b; assumption).
-reflexivity.
-elim n; replace a with (Rmin a c).
-elim H0; intros; assumption.
-unfold Rmin in |- *; case (Rle_dec a c); intro;
- [ reflexivity | elim n1; apply Rle_trans with b; assumption ].
-rewrite <- (StepFun_P43 X0 X1 X2).
-apply Rle_lt_trans with
- (Rabs (RiemannInt_SF (mkStepFun X0)) + Rabs (RiemannInt_SF (mkStepFun X1))).
-apply Rabs_triang.
-rewrite (double_var eps);
- replace (RiemannInt_SF (mkStepFun X0)) with (RiemannInt_SF psi1).
-replace (RiemannInt_SF (mkStepFun X1)) with (RiemannInt_SF psi2).
-apply Rplus_lt_compat.
-elim H1; intros; assumption.
-elim H2; intros; assumption.
-apply Rle_antisym.
-apply StepFun_P37; try assumption.
-simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
- case (Rle_dec a x); case (Rle_dec x b); intros;
- [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
- | right; reflexivity
- | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
- | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
-apply StepFun_P37; try assumption.
-simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
- case (Rle_dec a x); case (Rle_dec x b); intros;
- [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
- | right; reflexivity
- | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
- | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
-apply Rle_antisym.
-apply StepFun_P37; try assumption.
-simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
- case (Rle_dec a x); case (Rle_dec x b); intros;
- [ right; reflexivity
- | elim n; left; assumption
- | elim n; left; assumption
- | elim n0; left; assumption ].
-apply StepFun_P37; try assumption.
-simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
- case (Rle_dec a x); case (Rle_dec x b); intros;
- [ right; reflexivity
- | elim n; left; assumption
- | elim n; left; assumption
- | elim n0; left; assumption ].
-apply StepFun_P46 with b; assumption.
-assert (H3 := pre psi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
- elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
- split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
- clear H3; unfold adapted_couple in |- *; repeat split; 
- try assumption.
-intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
- unfold constant_D_eq, open_interval in H9; intros; 
- rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
-apply Rle_lt_trans with (pos_Rl l1 i).
-replace b with (Rmin b c).
-rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
-apply le_O_n.
-apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
- apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; 
- discriminate. 
-unfold Rmin in |- *; case (Rle_dec b c); intro;
- [ reflexivity | elim n; assumption ].
-elim H7; intros; assumption.
-case (Rle_dec a x); case (Rle_dec x b); intros;
- [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
- | reflexivity
- | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
- | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
-assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
- elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
- split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
- clear H3; unfold adapted_couple in |- *; repeat split; 
- try assumption.
-intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
- unfold constant_D_eq, open_interval in H9; intros; 
- rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
-apply Rle_trans with (pos_Rl l1 (S i)).
-elim H7; intros; left; assumption.
-replace b with (Rmax a b).
-rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
- discriminate. 
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-assert (H11 : a <= x).
-apply Rle_trans with (pos_Rl l1 i).
-replace a with (Rmin a b).
-rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
-apply le_O_n.
-apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
- apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; 
- discriminate. 
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-left; elim H7; intros; assumption.
-case (Rle_dec a x); case (Rle_dec x b); intros; reflexivity || elim n;
- assumption.
-apply StepFun_P46 with b.
-assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
- elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
- split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
- clear H3; unfold adapted_couple in |- *; repeat split; 
- try assumption.
-intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
- unfold constant_D_eq, open_interval in H9; intros; 
- rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
-apply Rle_trans with (pos_Rl l1 (S i)).
-elim H7; intros; left; assumption.
-replace b with (Rmax a b).
-rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
- discriminate. 
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-assert (H11 : a <= x).
-apply Rle_trans with (pos_Rl l1 i).
-replace a with (Rmin a b).
-rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
-apply le_O_n.
-apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
- apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; 
- discriminate. 
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-left; elim H7; intros; assumption.
-unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
- reflexivity || elim n; assumption.
-assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
- elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
- split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
- clear H3; unfold adapted_couple in |- *; repeat split; 
- try assumption.
-intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
- unfold constant_D_eq, open_interval in H9; intros; 
- rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
-apply Rle_lt_trans with (pos_Rl l1 i).
-replace b with (Rmin b c).
-rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
-apply le_O_n.
-apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
- apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; 
- discriminate. 
-unfold Rmin in |- *; case (Rle_dec b c); intro;
- [ reflexivity | elim n; assumption ].
-elim H7; intros; assumption.
-unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
- [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
- | reflexivity
- | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
- | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+  forall (f:R -> R) (a b c:R),
+    a <= b ->
+    b <= c ->
+    Riemann_integrable f a b ->
+    Riemann_integrable f b c -> Riemann_integrable f a c.
+Proof.
+  unfold Riemann_integrable in |- *; intros f a b c Hyp1 Hyp2 X X0 eps.
+  assert (H : 0 < eps / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (X (mkposreal _ H)); clear X; intros phi1 [psi1 H1];
+    elim (X0 (mkposreal _ H)); clear X0; intros phi2 [psi2 H2].
+  set
+    (phi3 :=
+      fun x:R =>
+        match Rle_dec a x with
+          | left _ =>
+            match Rle_dec x b with
+              | left _ => phi1 x
+              | right _ => phi2 x
+            end
+          | right _ => 0
+        end).
+  set
+    (psi3 :=
+      fun x:R =>
+        match Rle_dec a x with
+          | left _ =>
+            match Rle_dec x b with
+              | left _ => psi1 x
+              | right _ => psi2 x
+            end
+          | right _ => 0
+        end).
+  cut (IsStepFun phi3 a c).
+  intro; cut (IsStepFun psi3 a b).
+  intro; cut (IsStepFun psi3 b c).
+  intro; cut (IsStepFun psi3 a c).
+  intro; split with (mkStepFun X); split with (mkStepFun X2); simpl in |- *;
+    split.
+  intros; unfold phi3, psi3 in |- *; case (Rle_dec t b); case (Rle_dec a t);
+    intros.
+  elim H1; intros; apply H3.
+  replace (Rmin a b) with a.
+  replace (Rmax a b) with b.
+  split; assumption.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  elim n; replace a with (Rmin a c).
+  elim H0; intros; assumption.
+  unfold Rmin in |- *; case (Rle_dec a c); intro;
+    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+  elim H2; intros; apply H3.
+  replace (Rmax b c) with (Rmax a c).
+  elim H0; intros; split; try assumption.
+  replace (Rmin b c) with b.
+  auto with real.
+  unfold Rmin in |- *; case (Rle_dec b c); intro;
+    [ reflexivity | elim n0; assumption ].
+  unfold Rmax in |- *; case (Rle_dec a c); case (Rle_dec b c); intros;
+    try (elim n0; assumption || elim n0; apply Rle_trans with b; assumption).
+  reflexivity.
+  elim n; replace a with (Rmin a c).
+  elim H0; intros; assumption.
+  unfold Rmin in |- *; case (Rle_dec a c); intro;
+    [ reflexivity | elim n1; apply Rle_trans with b; assumption ].
+  rewrite <- (StepFun_P43 X0 X1 X2).
+  apply Rle_lt_trans with
+    (Rabs (RiemannInt_SF (mkStepFun X0)) + Rabs (RiemannInt_SF (mkStepFun X1))).
+  apply Rabs_triang.
+  rewrite (double_var eps);
+    replace (RiemannInt_SF (mkStepFun X0)) with (RiemannInt_SF psi1).
+  replace (RiemannInt_SF (mkStepFun X1)) with (RiemannInt_SF psi2).
+  apply Rplus_lt_compat.
+  elim H1; intros; assumption.
+  elim H2; intros; assumption.
+  apply Rle_antisym.
+  apply StepFun_P37; try assumption.
+  simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+    case (Rle_dec a x); case (Rle_dec x b); intros;
+      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
+        | right; reflexivity
+        | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
+        | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+  apply StepFun_P37; try assumption.
+  simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+    case (Rle_dec a x); case (Rle_dec x b); intros;
+      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
+        | right; reflexivity
+        | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
+        | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+  apply Rle_antisym.
+  apply StepFun_P37; try assumption.
+  simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+    case (Rle_dec a x); case (Rle_dec x b); intros;
+      [ right; reflexivity
+        | elim n; left; assumption
+        | elim n; left; assumption
+        | elim n0; left; assumption ].
+  apply StepFun_P37; try assumption.
+  simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+    case (Rle_dec a x); case (Rle_dec x b); intros;
+      [ right; reflexivity
+        | elim n; left; assumption
+        | elim n; left; assumption
+        | elim n0; left; assumption ].
+  apply StepFun_P46 with b; assumption.
+  assert (H3 := pre psi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
+    elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
+      split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
+        clear H3; unfold adapted_couple in |- *; repeat split; 
+          try assumption.
+  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+    unfold constant_D_eq, open_interval in H9; intros; 
+      rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
+  apply Rle_lt_trans with (pos_Rl l1 i).
+  replace b with (Rmin b c).
+  rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
+  apply le_O_n.
+  apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
+    apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; 
+      discriminate. 
+  unfold Rmin in |- *; case (Rle_dec b c); intro;
+    [ reflexivity | elim n; assumption ].
+  elim H7; intros; assumption.
+  case (Rle_dec a x); case (Rle_dec x b); intros;
+    [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
+      | reflexivity
+      | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
+      | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+  assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
+    elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
+      split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
+        clear H3; unfold adapted_couple in |- *; repeat split; 
+          try assumption.
+  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+    unfold constant_D_eq, open_interval in H9; intros; 
+      rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
+  apply Rle_trans with (pos_Rl l1 (S i)).
+  elim H7; intros; left; assumption.
+  replace b with (Rmax a b).
+  rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+    discriminate. 
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  assert (H11 : a <= x).
+  apply Rle_trans with (pos_Rl l1 i).
+  replace a with (Rmin a b).
+  rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
+  apply le_O_n.
+  apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
+    apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; 
+      discriminate. 
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  left; elim H7; intros; assumption.
+  case (Rle_dec a x); case (Rle_dec x b); intros; reflexivity || elim n;
+    assumption.
+  apply StepFun_P46 with b.
+  assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
+    elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
+      split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
+        clear H3; unfold adapted_couple in |- *; repeat split; 
+          try assumption.
+  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+    unfold constant_D_eq, open_interval in H9; intros; 
+      rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
+  apply Rle_trans with (pos_Rl l1 (S i)).
+  elim H7; intros; left; assumption.
+  replace b with (Rmax a b).
+  rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+    discriminate. 
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  assert (H11 : a <= x).
+  apply Rle_trans with (pos_Rl l1 i).
+  replace a with (Rmin a b).
+  rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
+  apply le_O_n.
+  apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
+    apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; 
+      discriminate. 
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  left; elim H7; intros; assumption.
+  unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
+    reflexivity || elim n; assumption.
+  assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
+    elim H3; clear H3; intros l1 [lf1 H3]; split with l1; 
+      split with lf1; unfold adapted_couple in H3; decompose [and] H3; 
+        clear H3; unfold adapted_couple in |- *; repeat split; 
+          try assumption.
+  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+    unfold constant_D_eq, open_interval in H9; intros; 
+      rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
+  apply Rle_lt_trans with (pos_Rl l1 i).
+  replace b with (Rmin b c).
+  rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
+  apply le_O_n.
+  apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
+    apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; 
+      discriminate. 
+  unfold Rmin in |- *; case (Rle_dec b c); intro;
+    [ reflexivity | elim n; assumption ].
+  elim H7; intros; assumption.
+  unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
+    [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
+      | reflexivity
+      | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
+      | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
 Qed.
 
 Lemma RiemannInt_P22 :
- forall (f:R -> R) (a b c:R),
-   Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c.
-unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
- intros phi [psi H0]; elim H; elim H0; clear H H0; 
- intros; assert (H3 : IsStepFun phi a c).
-apply StepFun_P44 with b.
-apply (pre phi).
-split; assumption.
-assert (H4 : IsStepFun psi a c).
-apply StepFun_P44 with b.
-apply (pre psi).
-split; assumption.
-split with (mkStepFun H3); split with (mkStepFun H4); split.
-simpl in |- *; intros; apply H.
-replace (Rmin a b) with (Rmin a c).
-elim H5; intros; split; try assumption.
-apply Rle_trans with (Rmax a c); try assumption.
-replace (Rmax a b) with b.
-replace (Rmax a c) with c.
-assumption.
-unfold Rmax in |- *; case (Rle_dec a c); intro;
- [ reflexivity | elim n; assumption ].
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-unfold Rmin in |- *; case (Rle_dec a c); case (Rle_dec a b); intros;
- [ reflexivity
- | elim n; apply Rle_trans with c; assumption
- | elim n; assumption
- | elim n0; assumption ].
-rewrite Rabs_right.
-assert (H5 : IsStepFun psi c b).
-apply StepFun_P46 with a.
-apply StepFun_P6; assumption.
-apply (pre psi).
-replace (RiemannInt_SF (mkStepFun H4)) with
- (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)).
-apply Rle_lt_trans with (RiemannInt_SF psi).
-unfold Rminus in |- *; pattern (RiemannInt_SF psi) at 2 in |- *;
- rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0;
- apply Ropp_ge_le_contravar; apply Rle_ge;
- replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *; unfold fct_cte in |- *;
- apply Rle_trans with (Rabs (f x - phi x)).
-apply Rabs_pos.
-apply H.
-replace (Rmin a b) with a.
-replace (Rmax a b) with b.
-elim H6; intros; split; left.
-apply Rle_lt_trans with c; assumption.
-assumption.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-rewrite StepFun_P18; ring.
-apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
-apply RRle_abs.
-assumption.
-assert (H6 : IsStepFun psi a b).
-apply (pre psi).
-replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
-rewrite <- (StepFun_P43 H4 H5 H6); ring.
-unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
-eapply StepFun_P17.
-apply StepFun_P1.
-simpl in |- *; apply StepFun_P1.
-apply Ropp_eq_compat; eapply StepFun_P17.
-apply StepFun_P1.
-simpl in |- *; apply StepFun_P1.
-apply Rle_ge; replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *; unfold fct_cte in |- *;
- apply Rle_trans with (Rabs (f x - phi x)).
-apply Rabs_pos.
-apply H.
-replace (Rmin a b) with a.
-replace (Rmax a b) with b.
-elim H5; intros; split; left.
-assumption.
-apply Rlt_le_trans with c; assumption.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-rewrite StepFun_P18; ring.
+  forall (f:R -> R) (a b c:R),
+    Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c.
+Proof.
+  unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
+    intros phi [psi H0]; elim H; elim H0; clear H H0; 
+      intros; assert (H3 : IsStepFun phi a c).
+  apply StepFun_P44 with b.
+  apply (pre phi).
+  split; assumption.
+  assert (H4 : IsStepFun psi a c).
+  apply StepFun_P44 with b.
+  apply (pre psi).
+  split; assumption.
+  split with (mkStepFun H3); split with (mkStepFun H4); split.
+  simpl in |- *; intros; apply H.
+  replace (Rmin a b) with (Rmin a c).
+  elim H5; intros; split; try assumption.
+  apply Rle_trans with (Rmax a c); try assumption.
+  replace (Rmax a b) with b.
+  replace (Rmax a c) with c.
+  assumption.
+  unfold Rmax in |- *; case (Rle_dec a c); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a c); case (Rle_dec a b); intros;
+    [ reflexivity
+      | elim n; apply Rle_trans with c; assumption
+      | elim n; assumption
+      | elim n0; assumption ].
+  rewrite Rabs_right.
+  assert (H5 : IsStepFun psi c b).
+  apply StepFun_P46 with a.
+  apply StepFun_P6; assumption.
+  apply (pre psi).
+  replace (RiemannInt_SF (mkStepFun H4)) with
+  (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)).
+  apply Rle_lt_trans with (RiemannInt_SF psi).
+  unfold Rminus in |- *; pattern (RiemannInt_SF psi) at 2 in |- *;
+    rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0;
+      apply Ropp_ge_le_contravar; apply Rle_ge;
+        replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))).
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *; unfold fct_cte in |- *;
+    apply Rle_trans with (Rabs (f x - phi x)).
+  apply Rabs_pos.
+  apply H.
+  replace (Rmin a b) with a.
+  replace (Rmax a b) with b.
+  elim H6; intros; split; left.
+  apply Rle_lt_trans with c; assumption.
+  assumption.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  rewrite StepFun_P18; ring.
+  apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
+  apply RRle_abs.
+  assumption.
+  assert (H6 : IsStepFun psi a b).
+  apply (pre psi).
+  replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
+  rewrite <- (StepFun_P43 H4 H5 H6); ring.
+  unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  eapply StepFun_P17.
+  apply StepFun_P1.
+  simpl in |- *; apply StepFun_P1.
+  apply Ropp_eq_compat; eapply StepFun_P17.
+  apply StepFun_P1.
+  simpl in |- *; apply StepFun_P1.
+  apply Rle_ge; replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))).
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *; unfold fct_cte in |- *;
+    apply Rle_trans with (Rabs (f x - phi x)).
+  apply Rabs_pos.
+  apply H.
+  replace (Rmin a b) with a.
+  replace (Rmax a b) with b.
+  elim H5; intros; split; left.
+  assumption.
+  apply Rlt_le_trans with c; assumption.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  rewrite StepFun_P18; ring.
 Qed.
 
 Lemma RiemannInt_P23 :
- forall (f:R -> R) (a b c:R),
-   Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b.
-unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
- intros phi [psi H0]; elim H; elim H0; clear H H0; 
- intros; assert (H3 : IsStepFun phi c b).
-apply StepFun_P45 with a.
-apply (pre phi).
-split; assumption.
-assert (H4 : IsStepFun psi c b).
-apply StepFun_P45 with a.
-apply (pre psi).
-split; assumption.
-split with (mkStepFun H3); split with (mkStepFun H4); split.
-simpl in |- *; intros; apply H.
-replace (Rmax a b) with (Rmax c b).
-elim H5; intros; split; try assumption.
-apply Rle_trans with (Rmin c b); try assumption.
-replace (Rmin a b) with a.
-replace (Rmin c b) with c.
-assumption.
-unfold Rmin in |- *; case (Rle_dec c b); intro;
- [ reflexivity | elim n; assumption ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-unfold Rmax in |- *; case (Rle_dec c b); case (Rle_dec a b); intros;
- [ reflexivity
- | elim n; apply Rle_trans with c; assumption
- | elim n; assumption
- | elim n0; assumption ].
-rewrite Rabs_right.
-assert (H5 : IsStepFun psi a c).
-apply StepFun_P46 with b.
-apply (pre psi).
-apply StepFun_P6; assumption.
-replace (RiemannInt_SF (mkStepFun H4)) with
- (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)).
-apply Rle_lt_trans with (RiemannInt_SF psi).
-unfold Rminus in |- *; pattern (RiemannInt_SF psi) at 2 in |- *;
- rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0;
- apply Ropp_ge_le_contravar; apply Rle_ge;
- replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *; unfold fct_cte in |- *;
- apply Rle_trans with (Rabs (f x - phi x)).
-apply Rabs_pos.
-apply H.
-replace (Rmin a b) with a.
-replace (Rmax a b) with b.
-elim H6; intros; split; left.
-assumption.
-apply Rlt_le_trans with c; assumption.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-rewrite StepFun_P18; ring.
-apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
-apply RRle_abs.
-assumption.
-assert (H6 : IsStepFun psi a b).
-apply (pre psi).
-replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
-rewrite <- (StepFun_P43 H5 H4 H6); ring.
-unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
-eapply StepFun_P17.
-apply StepFun_P1.
-simpl in |- *; apply StepFun_P1.
-apply Ropp_eq_compat; eapply StepFun_P17.
-apply StepFun_P1.
-simpl in |- *; apply StepFun_P1.
-apply Rle_ge; replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))).
-apply StepFun_P37; try assumption.
-intros; simpl in |- *; unfold fct_cte in |- *;
- apply Rle_trans with (Rabs (f x - phi x)).
-apply Rabs_pos.
-apply H.
-replace (Rmin a b) with a.
-replace (Rmax a b) with b.
-elim H5; intros; split; left.
-apply Rle_lt_trans with c; assumption.
-assumption.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-rewrite StepFun_P18; ring.
+  forall (f:R -> R) (a b c:R),
+    Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b.
+Proof.
+  unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
+    intros phi [psi H0]; elim H; elim H0; clear H H0; 
+      intros; assert (H3 : IsStepFun phi c b).
+  apply StepFun_P45 with a.
+  apply (pre phi).
+  split; assumption.
+  assert (H4 : IsStepFun psi c b).
+  apply StepFun_P45 with a.
+  apply (pre psi).
+  split; assumption.
+  split with (mkStepFun H3); split with (mkStepFun H4); split.
+  simpl in |- *; intros; apply H.
+  replace (Rmax a b) with (Rmax c b).
+  elim H5; intros; split; try assumption.
+  apply Rle_trans with (Rmin c b); try assumption.
+  replace (Rmin a b) with a.
+  replace (Rmin c b) with c.
+  assumption.
+  unfold Rmin in |- *; case (Rle_dec c b); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  unfold Rmax in |- *; case (Rle_dec c b); case (Rle_dec a b); intros;
+    [ reflexivity
+      | elim n; apply Rle_trans with c; assumption
+      | elim n; assumption
+      | elim n0; assumption ].
+  rewrite Rabs_right.
+  assert (H5 : IsStepFun psi a c).
+  apply StepFun_P46 with b.
+  apply (pre psi).
+  apply StepFun_P6; assumption.
+  replace (RiemannInt_SF (mkStepFun H4)) with
+  (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)).
+  apply Rle_lt_trans with (RiemannInt_SF psi).
+  unfold Rminus in |- *; pattern (RiemannInt_SF psi) at 2 in |- *;
+    rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0;
+      apply Ropp_ge_le_contravar; apply Rle_ge;
+        replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))).
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *; unfold fct_cte in |- *;
+    apply Rle_trans with (Rabs (f x - phi x)).
+  apply Rabs_pos.
+  apply H.
+  replace (Rmin a b) with a.
+  replace (Rmax a b) with b.
+  elim H6; intros; split; left.
+  assumption.
+  apply Rlt_le_trans with c; assumption.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  rewrite StepFun_P18; ring.
+  apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
+  apply RRle_abs.
+  assumption.
+  assert (H6 : IsStepFun psi a b).
+  apply (pre psi).
+  replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
+  rewrite <- (StepFun_P43 H5 H4 H6); ring.
+  unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  eapply StepFun_P17.
+  apply StepFun_P1.
+  simpl in |- *; apply StepFun_P1.
+  apply Ropp_eq_compat; eapply StepFun_P17.
+  apply StepFun_P1.
+  simpl in |- *; apply StepFun_P1.
+  apply Rle_ge; replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))).
+  apply StepFun_P37; try assumption.
+  intros; simpl in |- *; unfold fct_cte in |- *;
+    apply Rle_trans with (Rabs (f x - phi x)).
+  apply Rabs_pos.
+  apply H.
+  replace (Rmin a b) with a.
+  replace (Rmax a b) with b.
+  elim H5; intros; split; left.
+  apply Rle_lt_trans with c; assumption.
+  assumption.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
+  rewrite StepFun_P18; ring.
 Qed.
 
 Lemma RiemannInt_P24 :
- forall (f:R -> R) (a b c:R),
-   Riemann_integrable f a b ->
-   Riemann_integrable f b c -> Riemann_integrable f a c.
-intros; case (Rle_dec a b); case (Rle_dec b c); intros.
-apply RiemannInt_P21 with b; assumption.
-case (Rle_dec a c); intro.
-apply RiemannInt_P22 with b; try assumption.
-split; [ assumption | auto with real ].
-apply RiemannInt_P1; apply RiemannInt_P22 with b.
-apply RiemannInt_P1; assumption.
-split; auto with real.
-case (Rle_dec a c); intro.
-apply RiemannInt_P23 with b; try assumption.
-split; auto with real.
-apply RiemannInt_P1; apply RiemannInt_P23 with b.
-apply RiemannInt_P1; assumption.
-split; [ assumption | auto with real ].
-apply RiemannInt_P1; apply RiemannInt_P21 with b;
- auto with real || apply RiemannInt_P1; assumption.
+  forall (f:R -> R) (a b c:R),
+    Riemann_integrable f a b ->
+    Riemann_integrable f b c -> Riemann_integrable f a c.
+Proof.
+  intros; case (Rle_dec a b); case (Rle_dec b c); intros.
+  apply RiemannInt_P21 with b; assumption.
+  case (Rle_dec a c); intro.
+  apply RiemannInt_P22 with b; try assumption.
+  split; [ assumption | auto with real ].
+  apply RiemannInt_P1; apply RiemannInt_P22 with b.
+  apply RiemannInt_P1; assumption.
+  split; auto with real.
+  case (Rle_dec a c); intro.
+  apply RiemannInt_P23 with b; try assumption.
+  split; auto with real.
+  apply RiemannInt_P1; apply RiemannInt_P23 with b.
+  apply RiemannInt_P1; assumption.
+  split; [ assumption | auto with real ].
+  apply RiemannInt_P1; apply RiemannInt_P21 with b;
+    auto with real || apply RiemannInt_P1; assumption.
 Qed.
 
 Lemma RiemannInt_P25 :
- forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b)
-   (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
-   a <= b -> b <= c -> RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
-intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt in |- *;
- case (RiemannInt_exists pr1 RinvN RinvN_cv);
- case (RiemannInt_exists pr2 RinvN RinvN_cv);
- case (RiemannInt_exists pr3 RinvN RinvN_cv); intros; 
- symmetry  in |- *; eapply UL_sequence.
-apply u.
-unfold Un_cv in |- *; intros; assert (H0 : 0 < eps / 3).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (u1 _ H0); clear u1; intros N1 H1; elim (u0 _ H0); clear u0;
- intros N2 H2;
- cut
-  (Un_cv
-     (fun n:nat =>
-        RiemannInt_SF (phi_sequence RinvN pr3 n) -
-        (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-         RiemannInt_SF (phi_sequence RinvN pr2 n))) 0).
-intro; elim (H3 _ H0); clear H3; intros N3 H3;
- set (N0 := max (max N1 N2) N3); exists N0; intros; 
- unfold R_dist in |- *;
- apply Rle_lt_trans with
-  (Rabs
-     (RiemannInt_SF (phi_sequence RinvN pr3 n) -
-      (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-       RiemannInt_SF (phi_sequence RinvN pr2 n))) +
-   Rabs
-     (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-      RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0))).
-replace (RiemannInt_SF (phi_sequence RinvN pr3 n) - (x1 + x0)) with
- (RiemannInt_SF (phi_sequence RinvN pr3 n) -
-  (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-   RiemannInt_SF (phi_sequence RinvN pr2 n)) +
+  forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b)
+    (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
+    a <= b -> b <= c -> RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
+Proof.
+  intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt in |- *;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv);
+    case (RiemannInt_exists pr3 RinvN RinvN_cv); intros; 
+      symmetry  in |- *; eapply UL_sequence.
+  apply u.
+  unfold Un_cv in |- *; intros; assert (H0 : 0 < eps / 3).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (u1 _ H0); clear u1; intros N1 H1; elim (u0 _ H0); clear u0;
+    intros N2 H2;
+      cut
+        (Un_cv
+          (fun n:nat =>
+            RiemannInt_SF (phi_sequence RinvN pr3 n) -
+            (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+              RiemannInt_SF (phi_sequence RinvN pr2 n))) 0).
+  intro; elim (H3 _ H0); clear H3; intros N3 H3;
+    set (N0 := max (max N1 N2) N3); exists N0; intros; 
+      unfold R_dist in |- *;
+        apply Rle_lt_trans with
+          (Rabs
+            (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+              (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+                RiemannInt_SF (phi_sequence RinvN pr2 n))) +
+            Rabs
+            (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+              RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0))).
+  replace (RiemannInt_SF (phi_sequence RinvN pr3 n) - (x1 + x0)) with
+  (RiemannInt_SF (phi_sequence RinvN pr3 n) -
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      RiemannInt_SF (phi_sequence RinvN pr2 n)) +
+    (RiemannInt_SF (phi_sequence RinvN pr1 n) +
+      RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0)));
+  [ apply Rabs_triang | ring ].
+  replace eps with (eps / 3 + eps / 3 + eps / 3).
+  rewrite Rplus_assoc; apply Rplus_lt_compat.
+  unfold R_dist in H3; cut (n >= N3)%nat.
+  intro; assert (H6 := H3 _ H5); unfold Rminus in H6; rewrite Ropp_0 in H6;
+    rewrite Rplus_0_r in H6; apply H6.
+  unfold ge in |- *; apply le_trans with N0;
+    [ unfold N0 in |- *; apply le_max_r | assumption ].
+  apply Rle_lt_trans with
+    (Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1) +
+      Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0)).
+  replace
   (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-   RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0)));
- [ apply Rabs_triang | ring ].
-replace eps with (eps / 3 + eps / 3 + eps / 3).
-rewrite Rplus_assoc; apply Rplus_lt_compat.
-unfold R_dist in H3; cut (n >= N3)%nat.
-intro; assert (H6 := H3 _ H5); unfold Rminus in H6; rewrite Ropp_0 in H6;
- rewrite Rplus_0_r in H6; apply H6.
-unfold ge in |- *; apply le_trans with N0;
- [ unfold N0 in |- *; apply le_max_r | assumption ].
-apply Rle_lt_trans with
- (Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1) +
-  Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0)).
-replace
- (RiemannInt_SF (phi_sequence RinvN pr1 n) +
-  RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0)) with
- (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1 +
-  (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0));
- [ apply Rabs_triang | ring ].
-apply Rplus_lt_compat.
-unfold R_dist in H1; apply H1.
-unfold ge in |- *; apply le_trans with N0;
- [ apply le_trans with (max N1 N2);
-    [ apply le_max_l | unfold N0 in |- *; apply le_max_l ]
- | assumption ].
-unfold R_dist in H2; apply H2.
-unfold ge in |- *; apply le_trans with N0;
- [ apply le_trans with (max N1 N2);
-    [ apply le_max_r | unfold N0 in |- *; apply le_max_l ]
- | assumption ].
-apply Rmult_eq_reg_l with 3;
- [ unfold Rdiv in |- *; repeat rewrite Rmult_plus_distr_l;
-    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | discrR ]
- | discrR ].
-clear x u x0 x1 eps H H0 N1 H1 N2 H2;
- assert
-  (H1 :
-    exists psi1 : nat -> StepFun a b,
-     (forall n:nat,
-        (forall t:R,
-           Rmin a b <= t /\ t <= Rmax a b ->
-           Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
-        Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr1 n)). 
-assert
- (H2 :
-   exists psi2 : nat -> StepFun b c,
-    (forall n:nat,
-       (forall t:R,
-          Rmin b c <= t /\ t <= Rmax b c ->
-          Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
-       Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
-assert
- (H3 :
-   exists psi3 : nat -> StepFun a c,
-    (forall n:nat,
-       (forall t:R,
-          Rmin a c <= t /\ t <= Rmax a c ->
-          Rabs (f t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\
-       Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
-split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); intro;
- apply (projT2 (phi_sequence_prop RinvN pr3 n)). 
-elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3;
- clear H3; intros psi3 H3; assert (H := RinvN_cv); 
- unfold Un_cv in |- *; intros; assert (H4 : 0 < eps / 3).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H _ H4); clear H; intros N0 H;
- assert (H5 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3).
-intros;
- replace (pos (RinvN n)) with
-  (R_dist (mkposreal (/ (INR n + 1)) (RinvN_pos n)) 0).
-apply H; assumption.
-unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
- left; apply (cond_pos (RinvN n)).
-exists N0; intros; elim (H1 n); elim (H2 n); elim (H3 n); clear H1 H2 H3;
- intros; unfold R_dist in |- *; unfold Rminus in |- *; 
- rewrite Ropp_0; rewrite Rplus_0_r; 
- set (phi1 := phi_sequence RinvN pr1 n) in H8 |- *;
- set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *; 
- set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *; 
- assert (H10 : IsStepFun phi3 a b).
-apply StepFun_P44 with c.
-apply (pre phi3).
-split; assumption.
-assert (H11 : IsStepFun (psi3 n) a b).
-apply StepFun_P44 with c.
-apply (pre (psi3 n)).
-split; assumption.
-assert (H12 : IsStepFun phi3 b c).
-apply StepFun_P45 with a.
-apply (pre phi3).
-split; assumption.
-assert (H13 : IsStepFun (psi3 n) b c).
-apply StepFun_P45 with a.
-apply (pre (psi3 n)).
-split; assumption.
-replace (RiemannInt_SF phi3) with
- (RiemannInt_SF (mkStepFun H10) + RiemannInt_SF (mkStepFun H12)).
-apply Rle_lt_trans with
- (Rabs (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1) +
-  Rabs (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2)).
-replace
- (RiemannInt_SF (mkStepFun H10) + RiemannInt_SF (mkStepFun H12) +
-  - (RiemannInt_SF phi1 + RiemannInt_SF phi2)) with
- (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1 +
-  (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2));
- [ apply Rabs_triang | ring ].
-replace (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1) with
- (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))).
-replace (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2) with
- (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))).
-apply Rle_lt_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) +
-  RiemannInt_SF
-    (mkStepFun
-       (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))).
-apply Rle_trans with
- (Rabs (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))) +
-  RiemannInt_SF
-    (mkStepFun
-       (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))).
-apply Rplus_le_compat_l.
-apply StepFun_P34; try assumption.
-do 2
- rewrite <-
-  (Rplus_comm
-     (RiemannInt_SF
-        (mkStepFun
-           (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))))
-  ; apply Rplus_le_compat_l; apply StepFun_P34; try assumption.
-apply Rle_lt_trans with
- (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H11) (psi1 n))) +
-  RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))).
-apply Rle_trans with
- (RiemannInt_SF
-    (mkStepFun
-       (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) +
-  RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))).
-apply Rplus_le_compat_l; apply StepFun_P37; try assumption.
-intros; simpl in |- *; rewrite Rmult_1_l;
- apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi2 x)).
-rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr;
- replace (phi3 x + -1 * phi2 x) with (phi3 x - f x + (f x - phi2 x));
- [ apply Rabs_triang | ring ].
-apply Rplus_le_compat.
-apply H1.
-elim H14; intros; split.
-replace (Rmin a c) with a.
-apply Rle_trans with b; try assumption.
-left; assumption.
-unfold Rmin in |- *; case (Rle_dec a c); intro;
- [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
-replace (Rmax a c) with c.
-left; assumption.
-unfold Rmax in |- *; case (Rle_dec a c); intro;
- [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
-apply H3.
-elim H14; intros; split.
-replace (Rmin b c) with b.
-left; assumption.
-unfold Rmin in |- *; case (Rle_dec b c); intro;
- [ reflexivity | elim n0; assumption ].
-replace (Rmax b c) with c.
-left; assumption.
-unfold Rmax in |- *; case (Rle_dec b c); intro;
- [ reflexivity | elim n0; assumption ].
-do 2
- rewrite <-
-  (Rplus_comm
-     (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))))
-  ; apply Rplus_le_compat_l; apply StepFun_P37; try assumption.
-intros; simpl in |- *; rewrite Rmult_1_l;
- apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi1 x)).
-rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr;
- replace (phi3 x + -1 * phi1 x) with (phi3 x - f x + (f x - phi1 x));
- [ apply Rabs_triang | ring ].
-apply Rplus_le_compat.
-apply H1.
-elim H14; intros; split.
-replace (Rmin a c) with a.
-left; assumption.
-unfold Rmin in |- *; case (Rle_dec a c); intro;
- [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
-replace (Rmax a c) with c.
-apply Rle_trans with b.
-left; assumption.
-assumption.
-unfold Rmax in |- *; case (Rle_dec a c); intro;
- [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
-apply H8.
-elim H14; intros; split.
-replace (Rmin a b) with a.
-left; assumption.
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-replace (Rmax a b) with b.
-left; assumption.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n0; assumption ].
-do 2 rewrite StepFun_P30.
-do 2 rewrite Rmult_1_l;
- replace
-  (RiemannInt_SF (mkStepFun H11) + RiemannInt_SF (psi1 n) +
-   (RiemannInt_SF (mkStepFun H13) + RiemannInt_SF (psi2 n))) with
-  (RiemannInt_SF (psi3 n) + RiemannInt_SF (psi1 n) + RiemannInt_SF (psi2 n)).
-replace eps with (eps / 3 + eps / 3 + eps / 3).
-repeat rewrite Rplus_assoc; repeat apply Rplus_lt_compat.
-apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n))).
-apply RRle_abs.
-apply Rlt_trans with (pos (RinvN n)).
-assumption.
-apply H5; assumption.
-apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
-apply RRle_abs.
-apply Rlt_trans with (pos (RinvN n)).
-assumption.
-apply H5; assumption.
-apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
-apply RRle_abs.
-apply Rlt_trans with (pos (RinvN n)).
-assumption.
-apply H5; assumption.
-apply Rmult_eq_reg_l with 3;
- [ unfold Rdiv in |- *; repeat rewrite Rmult_plus_distr_l;
-    do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | discrR ]
- | discrR ].
-replace (RiemannInt_SF (psi3 n)) with
- (RiemannInt_SF (mkStepFun (pre (psi3 n)))).
-rewrite <- (StepFun_P43 H11 H13 (pre (psi3 n))); ring.
-reflexivity.
-rewrite StepFun_P30; ring.
-rewrite StepFun_P30; ring.
-apply (StepFun_P43 H10 H12 (pre phi3)).
+    RiemannInt_SF (phi_sequence RinvN pr2 n) - (x1 + x0)) with
+  (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1 +
+    (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0));
+  [ apply Rabs_triang | ring ].
+  apply Rplus_lt_compat.
+  unfold R_dist in H1; apply H1.
+  unfold ge in |- *; apply le_trans with N0;
+    [ apply le_trans with (max N1 N2);
+      [ apply le_max_l | unfold N0 in |- *; apply le_max_l ]
+      | assumption ].
+  unfold R_dist in H2; apply H2.
+  unfold ge in |- *; apply le_trans with N0;
+    [ apply le_trans with (max N1 N2);
+      [ apply le_max_r | unfold N0 in |- *; apply le_max_l ]
+      | assumption ].
+  apply Rmult_eq_reg_l with 3;
+    [ unfold Rdiv in |- *; repeat rewrite Rmult_plus_distr_l;
+      do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+        rewrite <- Rinv_l_sym; [ ring | discrR ]
+      | discrR ].
+  clear x u x0 x1 eps H H0 N1 H1 N2 H2;
+    assert
+      (H1 :
+        exists psi1 : nat -> StepFun a b,
+          (forall n:nat,
+            (forall t:R,
+              Rmin a b <= t /\ t <= Rmax a b ->
+              Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\
+            Rabs (RiemannInt_SF (psi1 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr1 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr1 n)). 
+  assert
+    (H2 :
+      exists psi2 : nat -> StepFun b c,
+        (forall n:nat,
+          (forall t:R,
+            Rmin b c <= t /\ t <= Rmax b c ->
+            Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
+          Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr2 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr2 n)). 
+  assert
+    (H3 :
+      exists psi3 : nat -> StepFun a c,
+        (forall n:nat,
+          (forall t:R,
+            Rmin a c <= t /\ t <= Rmax a c ->
+            Rabs (f t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\
+          Rabs (RiemannInt_SF (psi3 n)) < RinvN n)).
+  split with (fun n:nat => projT1 (phi_sequence_prop RinvN pr3 n)); intro;
+    apply (projT2 (phi_sequence_prop RinvN pr3 n)). 
+  elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3;
+    clear H3; intros psi3 H3; assert (H := RinvN_cv); 
+      unfold Un_cv in |- *; intros; assert (H4 : 0 < eps / 3).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H _ H4); clear H; intros N0 H;
+    assert (H5 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3).
+  intros;
+    replace (pos (RinvN n)) with
+    (R_dist (mkposreal (/ (INR n + 1)) (RinvN_pos n)) 0).
+  apply H; assumption.
+  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; 
+      left; apply (cond_pos (RinvN n)).
+  exists N0; intros; elim (H1 n); elim (H2 n); elim (H3 n); clear H1 H2 H3;
+    intros; unfold R_dist in |- *; unfold Rminus in |- *; 
+      rewrite Ropp_0; rewrite Rplus_0_r; 
+        set (phi1 := phi_sequence RinvN pr1 n) in H8 |- *;
+          set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *; 
+            set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *; 
+              assert (H10 : IsStepFun phi3 a b).
+  apply StepFun_P44 with c.
+  apply (pre phi3).
+  split; assumption.
+  assert (H11 : IsStepFun (psi3 n) a b).
+  apply StepFun_P44 with c.
+  apply (pre (psi3 n)).
+  split; assumption.
+  assert (H12 : IsStepFun phi3 b c).
+  apply StepFun_P45 with a.
+  apply (pre phi3).
+  split; assumption.
+  assert (H13 : IsStepFun (psi3 n) b c).
+  apply StepFun_P45 with a.
+  apply (pre (psi3 n)).
+  split; assumption.
+  replace (RiemannInt_SF phi3) with
+  (RiemannInt_SF (mkStepFun H10) + RiemannInt_SF (mkStepFun H12)).
+  apply Rle_lt_trans with
+    (Rabs (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1) +
+      Rabs (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2)).
+  replace
+  (RiemannInt_SF (mkStepFun H10) + RiemannInt_SF (mkStepFun H12) +
+    - (RiemannInt_SF phi1 + RiemannInt_SF phi2)) with
+  (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1 +
+    (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2));
+  [ apply Rabs_triang | ring ].
+  replace (RiemannInt_SF (mkStepFun H10) - RiemannInt_SF phi1) with
+  (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))).
+  replace (RiemannInt_SF (mkStepFun H12) - RiemannInt_SF phi2) with
+  (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))).
+  apply Rle_lt_trans with
+    (RiemannInt_SF
+      (mkStepFun
+        (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) +
+      RiemannInt_SF
+      (mkStepFun
+        (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))).
+  apply Rle_trans with
+    (Rabs (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))) +
+      RiemannInt_SF
+      (mkStepFun
+        (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))).
+  apply Rplus_le_compat_l.
+  apply StepFun_P34; try assumption.
+  do 2
+    rewrite <-
+      (Rplus_comm
+        (RiemannInt_SF
+          (mkStepFun
+            (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2))))))
+      ; apply Rplus_le_compat_l; apply StepFun_P34; try assumption.
+  apply Rle_lt_trans with
+    (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H11) (psi1 n))) +
+      RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))).
+  apply Rle_trans with
+    (RiemannInt_SF
+      (mkStepFun
+        (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) +
+      RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))).
+  apply Rplus_le_compat_l; apply StepFun_P37; try assumption.
+  intros; simpl in |- *; rewrite Rmult_1_l;
+    apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi2 x)).
+  rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr;
+    replace (phi3 x + -1 * phi2 x) with (phi3 x - f x + (f x - phi2 x));
+    [ apply Rabs_triang | ring ].
+  apply Rplus_le_compat.
+  apply H1.
+  elim H14; intros; split.
+  replace (Rmin a c) with a.
+  apply Rle_trans with b; try assumption.
+  left; assumption.
+  unfold Rmin in |- *; case (Rle_dec a c); intro;
+    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+  replace (Rmax a c) with c.
+  left; assumption.
+  unfold Rmax in |- *; case (Rle_dec a c); intro;
+    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+  apply H3.
+  elim H14; intros; split.
+  replace (Rmin b c) with b.
+  left; assumption.
+  unfold Rmin in |- *; case (Rle_dec b c); intro;
+    [ reflexivity | elim n0; assumption ].
+  replace (Rmax b c) with c.
+  left; assumption.
+  unfold Rmax in |- *; case (Rle_dec b c); intro;
+    [ reflexivity | elim n0; assumption ].
+  do 2
+    rewrite <-
+      (Rplus_comm
+        (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))))
+      ; apply Rplus_le_compat_l; apply StepFun_P37; try assumption.
+  intros; simpl in |- *; rewrite Rmult_1_l;
+    apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi1 x)).
+  rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr;
+    replace (phi3 x + -1 * phi1 x) with (phi3 x - f x + (f x - phi1 x));
+    [ apply Rabs_triang | ring ].
+  apply Rplus_le_compat.
+  apply H1.
+  elim H14; intros; split.
+  replace (Rmin a c) with a.
+  left; assumption.
+  unfold Rmin in |- *; case (Rle_dec a c); intro;
+    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+  replace (Rmax a c) with c.
+  apply Rle_trans with b.
+  left; assumption.
+  assumption.
+  unfold Rmax in |- *; case (Rle_dec a c); intro;
+    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+  apply H8.
+  elim H14; intros; split.
+  replace (Rmin a b) with a.
+  left; assumption.
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  replace (Rmax a b) with b.
+  left; assumption.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n0; assumption ].
+  do 2 rewrite StepFun_P30.
+  do 2 rewrite Rmult_1_l;
+    replace
+    (RiemannInt_SF (mkStepFun H11) + RiemannInt_SF (psi1 n) +
+      (RiemannInt_SF (mkStepFun H13) + RiemannInt_SF (psi2 n))) with
+    (RiemannInt_SF (psi3 n) + RiemannInt_SF (psi1 n) + RiemannInt_SF (psi2 n)).
+  replace eps with (eps / 3 + eps / 3 + eps / 3).
+  repeat rewrite Rplus_assoc; repeat apply Rplus_lt_compat.
+  apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n))).
+  apply RRle_abs.
+  apply Rlt_trans with (pos (RinvN n)).
+  assumption.
+  apply H5; assumption.
+  apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n))).
+  apply RRle_abs.
+  apply Rlt_trans with (pos (RinvN n)).
+  assumption.
+  apply H5; assumption.
+  apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n))).
+  apply RRle_abs.
+  apply Rlt_trans with (pos (RinvN n)).
+  assumption.
+  apply H5; assumption.
+  apply Rmult_eq_reg_l with 3;
+    [ unfold Rdiv in |- *; repeat rewrite Rmult_plus_distr_l;
+      do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
+        rewrite <- Rinv_l_sym; [ ring | discrR ]
+      | discrR ].
+  replace (RiemannInt_SF (psi3 n)) with
+  (RiemannInt_SF (mkStepFun (pre (psi3 n)))).
+  rewrite <- (StepFun_P43 H11 H13 (pre (psi3 n))); ring.
+  reflexivity.
+  rewrite StepFun_P30; ring.
+  rewrite StepFun_P30; ring.
+  apply (StepFun_P43 H10 H12 (pre phi3)).
 Qed.
 
 Lemma RiemannInt_P26 :
- forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b)
-   (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
-   RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
-intros; case (Rle_dec a b); case (Rle_dec b c); intros.
-apply RiemannInt_P25; assumption.
-case (Rle_dec a c); intro.
-assert (H : c <= b).
-auto with real.
-rewrite <- (RiemannInt_P25 pr3 (RiemannInt_P1 pr2) pr1 r0 H);
- rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); ring.
-assert (H : c <= a).
-auto with real.
-rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2));
- rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr3) pr1 (RiemannInt_P1 pr2) H r);
- rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring.
-assert (H : b <= a).
-auto with real.
-case (Rle_dec a c); intro.
-rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr1) pr3 pr2 H r0);
- rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); ring.
-assert (H0 : c <= a).
-auto with real.
-rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1));
- rewrite <- (RiemannInt_P25 pr2 (RiemannInt_P1 pr3) (RiemannInt_P1 pr1) r H0);
- rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring.
-rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1));
- rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2));
- rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3));
- rewrite <-
-  (RiemannInt_P25 (RiemannInt_P1 pr2) (RiemannInt_P1 pr1) (RiemannInt_P1 pr3))
-  ; [ ring | auto with real | auto with real ].
+  forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b)
+    (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
+    RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
+Proof.
+  intros; case (Rle_dec a b); case (Rle_dec b c); intros.
+  apply RiemannInt_P25; assumption.
+  case (Rle_dec a c); intro.
+  assert (H : c <= b).
+  auto with real.
+  rewrite <- (RiemannInt_P25 pr3 (RiemannInt_P1 pr2) pr1 r0 H);
+    rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); ring.
+  assert (H : c <= a).
+  auto with real.
+  rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2));
+    rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr3) pr1 (RiemannInt_P1 pr2) H r);
+      rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring.
+  assert (H : b <= a).
+  auto with real.
+  case (Rle_dec a c); intro.
+  rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr1) pr3 pr2 H r0);
+    rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); ring.
+  assert (H0 : c <= a).
+  auto with real.
+  rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1));
+    rewrite <- (RiemannInt_P25 pr2 (RiemannInt_P1 pr3) (RiemannInt_P1 pr1) r H0);
+      rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring.
+  rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1));
+    rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2));
+      rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3));
+        rewrite <-
+          (RiemannInt_P25 (RiemannInt_P1 pr2) (RiemannInt_P1 pr1) (RiemannInt_P1 pr3))
+          ; [ ring | auto with real | auto with real ].
 Qed.
 
 Lemma RiemannInt_P27 :
- forall (f:R -> R) (a b x:R) (h:a <= b)
-   (C0:forall x:R, a <= x <= b -> continuity_pt f x),
-   a < x < b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x).
-intro f; intros; elim H; clear H; intros; assert (H1 : continuity_pt f x).
-apply C0; split; left; assumption.
-unfold derivable_pt_lim in |- *; intros; assert (Hyp : 0 < eps / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H1 _ Hyp); unfold dist, D_x, no_cond in |- *; simpl in |- *;
- unfold R_dist in |- *; intros; set (del := Rmin x0 (Rmin (b - x) (x - a)));
- assert (H4 : 0 < del).
-unfold del in |- *; unfold Rmin in |- *; case (Rle_dec (b - x) (x - a));
- intro.
-case (Rle_dec x0 (b - x)); intro;
- [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
-case (Rle_dec x0 (x - a)); intro;
- [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
-split with (mkposreal _ H4); intros;
- assert (H7 : Riemann_integrable f x (x + h0)).
-case (Rle_dec x (x + h0)); intro.
-apply continuity_implies_RiemannInt; try assumption.
-intros; apply C0; elim H7; intros; split.
-apply Rle_trans with x; [ left; assumption | assumption ].
-apply Rle_trans with (x + h0).
-assumption.
-left; apply Rlt_le_trans with (x + del).
-apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h0);
- [ apply RRle_abs | apply H6 ].
-unfold del in |- *; apply Rle_trans with (x + Rmin (b - x) (x - a)).
-apply Rplus_le_compat_l; apply Rmin_r.
-pattern b at 2 in |- *; replace b with (x + (b - x));
- [ apply Rplus_le_compat_l; apply Rmin_l | ring ].
-apply RiemannInt_P1; apply continuity_implies_RiemannInt; auto with real.
-intros; apply C0; elim H7; intros; split.
-apply Rle_trans with (x + h0).
-left; apply Rle_lt_trans with (x - del).
-unfold del in |- *; apply Rle_trans with (x - Rmin (b - x) (x - a)).
-pattern a at 1 in |- *; replace a with (x + (a - x)); [ idtac | ring ].
-unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
-rewrite Ropp_involutive; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
- rewrite (Rplus_comm x); apply Rmin_r.
-unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
-do 2 rewrite Ropp_involutive; apply Rmin_r.
-unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_cancel.
-rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0);
- [ rewrite <- Rabs_Ropp; apply RRle_abs | apply H6 ].
-assumption.
-apply Rle_trans with x; [ assumption | left; assumption ].
-replace (primitive h (FTC_P1 h C0) (x + h0) - primitive h (FTC_P1 h C0) x)
- with (RiemannInt H7).
-replace (f x) with (RiemannInt (RiemannInt_P14 x (x + h0) (f x)) / h0).
-replace
- (RiemannInt H7 / h0 - RiemannInt (RiemannInt_P14 x (x + h0) (f x)) / h0)
- with ((RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) / h0).
-replace (RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) with
- (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))).
-unfold Rdiv in |- *; rewrite Rabs_mult; case (Rle_dec x (x + h0)); intro.
-apply Rle_lt_trans with
- (RiemannInt
-    (RiemannInt_P16
-       (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) *
-  Rabs (/ h0)).
-do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
-apply Rabs_pos.
-apply
- (RiemannInt_P17 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))
-    (RiemannInt_P16
-       (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))));
- assumption.
-apply Rle_lt_trans with
- (RiemannInt (RiemannInt_P14 x (x + h0) (eps / 2)) * Rabs (/ h0)).
-do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
-apply Rabs_pos.
-apply RiemannInt_P19; try assumption.
-intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
-unfold fct_cte in |- *; case (Req_dec x x1); intro.
-rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
- assumption.
-elim H3; intros; left; apply H11.
-repeat split.
-assumption.
-rewrite Rabs_right.
-apply Rplus_lt_reg_r with x; replace (x + (x1 - x)) with x1; [ idtac | ring ].
-apply Rlt_le_trans with (x + h0).
-elim H8; intros; assumption.
-apply Rplus_le_compat_l; apply Rle_trans with del.
-left; apply Rle_lt_trans with (Rabs h0); [ apply RRle_abs | assumption ].
-unfold del in |- *; apply Rmin_l.
-apply Rge_minus; apply Rle_ge; left; elim H8; intros; assumption.
-unfold fct_cte in |- *; ring.
-rewrite RiemannInt_P15.
-rewrite Rmult_assoc; replace ((x + h0 - x) * Rabs (/ h0)) with 1.
-rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
-       rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-rewrite Rabs_right.
-replace (x + h0 - x) with h0; [ idtac | ring ].
-apply Rinv_r_sym.
-assumption.
-apply Rle_ge; left; apply Rinv_0_lt_compat.
-elim r; intro.
-apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
-elim H5; symmetry  in |- *; apply Rplus_eq_reg_l with x; rewrite Rplus_0_r;
- assumption.
-apply Rle_lt_trans with
- (RiemannInt
-    (RiemannInt_P16
-       (RiemannInt_P1
+  forall (f:R -> R) (a b x:R) (h:a <= b)
+    (C0:forall x:R, a <= x <= b -> continuity_pt f x),
+    a < x < b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x).
+Proof.
+  intro f; intros; elim H; clear H; intros; assert (H1 : continuity_pt f x).
+  apply C0; split; left; assumption.
+  unfold derivable_pt_lim in |- *; intros; assert (Hyp : 0 < eps / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H1 _ Hyp); unfold dist, D_x, no_cond in |- *; simpl in |- *;
+    unfold R_dist in |- *; intros; set (del := Rmin x0 (Rmin (b - x) (x - a)));
+      assert (H4 : 0 < del).
+  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec (b - x) (x - a));
+    intro.
+  case (Rle_dec x0 (b - x)); intro;
+    [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
+  case (Rle_dec x0 (x - a)); intro;
+    [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
+  split with (mkposreal _ H4); intros;
+    assert (H7 : Riemann_integrable f x (x + h0)).
+  case (Rle_dec x (x + h0)); intro.
+  apply continuity_implies_RiemannInt; try assumption.
+  intros; apply C0; elim H7; intros; split.
+  apply Rle_trans with x; [ left; assumption | assumption ].
+  apply Rle_trans with (x + h0).
+  assumption.
+  left; apply Rlt_le_trans with (x + del).
+  apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h0);
+    [ apply RRle_abs | apply H6 ].
+  unfold del in |- *; apply Rle_trans with (x + Rmin (b - x) (x - a)).
+  apply Rplus_le_compat_l; apply Rmin_r.
+  pattern b at 2 in |- *; replace b with (x + (b - x));
+    [ apply Rplus_le_compat_l; apply Rmin_l | ring ].
+  apply RiemannInt_P1; apply continuity_implies_RiemannInt; auto with real.
+  intros; apply C0; elim H7; intros; split.
+  apply Rle_trans with (x + h0).
+  left; apply Rle_lt_trans with (x - del).
+  unfold del in |- *; apply Rle_trans with (x - Rmin (b - x) (x - a)).
+  pattern a at 1 in |- *; replace a with (x + (a - x)); [ idtac | ring ].
+  unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+  rewrite Ropp_involutive; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+    rewrite (Rplus_comm x); apply Rmin_r.
+  unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+  do 2 rewrite Ropp_involutive; apply Rmin_r.
+  unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_cancel.
+  rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0);
+    [ rewrite <- Rabs_Ropp; apply RRle_abs | apply H6 ].
+  assumption.
+  apply Rle_trans with x; [ assumption | left; assumption ].
+  replace (primitive h (FTC_P1 h C0) (x + h0) - primitive h (FTC_P1 h C0) x)
+    with (RiemannInt H7).
+  replace (f x) with (RiemannInt (RiemannInt_P14 x (x + h0) (f x)) / h0).
+  replace
+  (RiemannInt H7 / h0 - RiemannInt (RiemannInt_P14 x (x + h0) (f x)) / h0)
+    with ((RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) / h0).
+  replace (RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) with
+  (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))).
+  unfold Rdiv in |- *; rewrite Rabs_mult; case (Rle_dec x (x + h0)); intro.
+  apply Rle_lt_trans with
+    (RiemannInt
+      (RiemannInt_P16
+        (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) *
+      Rabs (/ h0)).
+  do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply
+    (RiemannInt_P17 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))
+      (RiemannInt_P16
+        (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))));
+    assumption.
+  apply Rle_lt_trans with
+    (RiemannInt (RiemannInt_P14 x (x + h0) (eps / 2)) * Rabs (/ h0)).
+  do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply RiemannInt_P19; try assumption.
+  intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
+  unfold fct_cte in |- *; case (Req_dec x x1); intro.
+  rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
+    assumption.
+  elim H3; intros; left; apply H11.
+  repeat split.
+  assumption.
+  rewrite Rabs_right.
+  apply Rplus_lt_reg_r with x; replace (x + (x1 - x)) with x1; [ idtac | ring ].
+  apply Rlt_le_trans with (x + h0).
+  elim H8; intros; assumption.
+  apply Rplus_le_compat_l; apply Rle_trans with del.
+  left; apply Rle_lt_trans with (Rabs h0); [ apply RRle_abs | assumption ].
+  unfold del in |- *; apply Rmin_l.
+  apply Rge_minus; apply Rle_ge; left; elim H8; intros; assumption.
+  unfold fct_cte in |- *; ring.
+  rewrite RiemannInt_P15.
+  rewrite Rmult_assoc; replace ((x + h0 - x) * Rabs (/ h0)) with 1.
+  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+            rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  rewrite Rabs_right.
+  replace (x + h0 - x) with h0; [ idtac | ring ].
+  apply Rinv_r_sym.
+  assumption.
+  apply Rle_ge; left; apply Rinv_0_lt_compat.
+  elim r; intro.
+  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
+  elim H5; symmetry  in |- *; apply Rplus_eq_reg_l with x; rewrite Rplus_0_r;
+    assumption.
+  apply Rle_lt_trans with
+    (RiemannInt
+      (RiemannInt_P16
+        (RiemannInt_P1
           (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))) *
-  Rabs (/ h0)).
-do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
-apply Rabs_pos.
-replace
- (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) with
- (-
-  RiemannInt
+      Rabs (/ h0)).
+  do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  replace
+  (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))) with
+  (-
+    RiemannInt
     (RiemannInt_P1 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))).
-rewrite Rabs_Ropp;
- apply
-  (RiemannInt_P17
-     (RiemannInt_P1
-        (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))
-     (RiemannInt_P16
+  rewrite Rabs_Ropp;
+    apply
+      (RiemannInt_P17
         (RiemannInt_P1
-           (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))));
- auto with real.
-symmetry  in |- *; apply RiemannInt_P8.
-apply Rle_lt_trans with
- (RiemannInt (RiemannInt_P14 (x + h0) x (eps / 2)) * Rabs (/ h0)).
-do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
-apply Rabs_pos.
-apply RiemannInt_P19.
-auto with real.
-intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
-unfold fct_cte in |- *; case (Req_dec x x1); intro.
-rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
- assumption.
-elim H3; intros; left; apply H11.
-repeat split.
-assumption.
-rewrite Rabs_left.
-apply Rplus_lt_reg_r with (x1 - x0); replace (x1 - x0 + x0) with x1;
- [ idtac | ring ].
-replace (x1 - x0 + - (x1 - x)) with (x - x0); [ idtac | ring ].
-apply Rle_lt_trans with (x + h0).
-unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
-rewrite Ropp_involutive; apply Rle_trans with (Rabs h0).
-rewrite <- Rabs_Ropp; apply RRle_abs.
-apply Rle_trans with del;
- [ left; assumption | unfold del in |- *; apply Rmin_l ].
-elim H8; intros; assumption.
-apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
- replace (x + (x1 - x)) with x1; [ elim H8; intros; assumption | ring ].
-unfold fct_cte in |- *; ring.
-rewrite RiemannInt_P15.
-rewrite Rmult_assoc; replace ((x - (x + h0)) * Rabs (/ h0)) with 1.
-rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
-       rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-rewrite Rabs_left.
-replace (x - (x + h0)) with (- h0); [ idtac | ring ].
-rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_mult_distr_r_reverse;
- rewrite Ropp_involutive; apply Rinv_r_sym.
-assumption.
-apply Rinv_lt_0_compat.
-assert (H8 : x + h0 < x).
-auto with real.
-apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
-rewrite
- (RiemannInt_P13 H7 (RiemannInt_P14 x (x + h0) (f x))
-    (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))
- .
-ring.
-unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
-rewrite RiemannInt_P15; apply Rmult_eq_reg_l with h0;
- [ unfold Rdiv in |- *; rewrite (Rmult_comm h0); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ ring | assumption ]
- | assumption ].
-cut (a <= x + h0).
-cut (x + h0 <= b).
-intros; unfold primitive in |- *.
-case (Rle_dec a (x + h0)); case (Rle_dec (x + h0) b); case (Rle_dec a x);
- case (Rle_dec x b); intros; try (elim n; assumption || left; assumption).
-rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r0 r) H7 (FTC_P1 h C0 r2 r1)); ring.
-apply Rplus_le_reg_l with (- x); replace (- x + (x + h0)) with h0;
- [ idtac | ring ].
-rewrite Rplus_comm; apply Rle_trans with (Rabs h0).
-apply RRle_abs.
-apply Rle_trans with del;
- [ left; assumption
- | unfold del in |- *; apply Rle_trans with (Rmin (b - x) (x - a));
-    [ apply Rmin_r | apply Rmin_l ] ].
-apply Ropp_le_cancel; apply Rplus_le_reg_l with x;
- replace (x + - (x + h0)) with (- h0); [ idtac | ring ].
-apply Rle_trans with (Rabs h0);
- [ rewrite <- Rabs_Ropp; apply RRle_abs
- | apply Rle_trans with del;
+          (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))
+        (RiemannInt_P16
+          (RiemannInt_P1
+            (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))));
+      auto with real.
+  symmetry  in |- *; apply RiemannInt_P8.
+  apply Rle_lt_trans with
+    (RiemannInt (RiemannInt_P14 (x + h0) x (eps / 2)) * Rabs (/ h0)).
+  do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply RiemannInt_P19.
+  auto with real.
+  intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
+  unfold fct_cte in |- *; case (Req_dec x x1); intro.
+  rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
+    assumption.
+  elim H3; intros; left; apply H11.
+  repeat split.
+  assumption.
+  rewrite Rabs_left.
+  apply Rplus_lt_reg_r with (x1 - x0); replace (x1 - x0 + x0) with x1;
+    [ idtac | ring ].
+  replace (x1 - x0 + - (x1 - x)) with (x - x0); [ idtac | ring ].
+  apply Rle_lt_trans with (x + h0).
+  unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+  rewrite Ropp_involutive; apply Rle_trans with (Rabs h0).
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  apply Rle_trans with del;
+    [ left; assumption | unfold del in |- *; apply Rmin_l ].
+  elim H8; intros; assumption.
+  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+    replace (x + (x1 - x)) with x1; [ elim H8; intros; assumption | ring ].
+  unfold fct_cte in |- *; ring.
+  rewrite RiemannInt_P15.
+  rewrite Rmult_assoc; replace ((x - (x + h0)) * Rabs (/ h0)) with 1.
+  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+            rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  rewrite Rabs_left.
+  replace (x - (x + h0)) with (- h0); [ idtac | ring ].
+  rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_mult_distr_r_reverse;
+    rewrite Ropp_involutive; apply Rinv_r_sym.
+  assumption.
+  apply Rinv_lt_0_compat.
+  assert (H8 : x + h0 < x).
+  auto with real.
+  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
+  rewrite
+    (RiemannInt_P13 H7 (RiemannInt_P14 x (x + h0) (f x))
+      (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))
+    .
+  ring.
+  unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+  rewrite RiemannInt_P15; apply Rmult_eq_reg_l with h0;
+    [ unfold Rdiv in |- *; rewrite (Rmult_comm h0); repeat rewrite Rmult_assoc;
+      rewrite <- Rinv_l_sym; [ ring | assumption ]
+      | assumption ].
+  cut (a <= x + h0).
+  cut (x + h0 <= b).
+  intros; unfold primitive in |- *.
+  case (Rle_dec a (x + h0)); case (Rle_dec (x + h0) b); case (Rle_dec a x);
+  case (Rle_dec x b); intros; try (elim n; assumption || left; assumption).
+  rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r0 r) H7 (FTC_P1 h C0 r2 r1)); ring.
+  apply Rplus_le_reg_l with (- x); replace (- x + (x + h0)) with h0;
+    [ idtac | ring ].
+  rewrite Rplus_comm; apply Rle_trans with (Rabs h0).
+  apply RRle_abs.
+  apply Rle_trans with del;
     [ left; assumption
-    | unfold del in |- *; apply Rle_trans with (Rmin (b - x) (x - a));
-       apply Rmin_r ] ].
+      | unfold del in |- *; apply Rle_trans with (Rmin (b - x) (x - a));
+        [ apply Rmin_r | apply Rmin_l ] ].
+  apply Ropp_le_cancel; apply Rplus_le_reg_l with x;
+    replace (x + - (x + h0)) with (- h0); [ idtac | ring ].
+  apply Rle_trans with (Rabs h0);
+    [ rewrite <- Rabs_Ropp; apply RRle_abs
+      | apply Rle_trans with del;
+        [ left; assumption
+          | unfold del in |- *; apply Rle_trans with (Rmin (b - x) (x - a));
+            apply Rmin_r ] ].
 Qed.
 
 Lemma RiemannInt_P28 :
- forall (f:R -> R) (a b x:R) (h:a <= b)
-   (C0:forall x:R, a <= x <= b -> continuity_pt f x),
-   a <= x <= b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x).
-intro f; intros; elim h; intro.
-elim H; clear H; intros; elim H; intro.
-elim H1; intro.
-apply RiemannInt_P27; split; assumption.
-set
- (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b)));
- rewrite H3.
-assert (H4 : derivable_pt_lim f_b b (f b)).
-unfold f_b in |- *; pattern (f b) at 2 in |- *; replace (f b) with (f b + 0).
-change
-  (derivable_pt_lim
-     ((fct_cte (f b) * (id - fct_cte b))%F +
-      fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
-     f b + 0)) in |- *. 
-apply derivable_pt_lim_plus.
-pattern (f b) at 2 in |- *;
- replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_const.
-replace 1 with (1 - 0); [ idtac | ring ].
-apply derivable_pt_lim_minus.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_const.
-unfold fct_cte in |- *; ring.
-apply derivable_pt_lim_const.
-ring.
-unfold derivable_pt_lim in |- *; intros; elim (H4 _ H5); intros;
- assert (H7 : continuity_pt f b).
-apply C0; split; [ left; assumption | right; reflexivity ].
-assert (H8 : 0 < eps / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H7 _ H8); unfold D_x, no_cond, dist in |- *; simpl in |- *;
- unfold R_dist in |- *; intros; set (del := Rmin x0 (Rmin x1 (b - a)));
- assert (H10 : 0 < del).
-unfold del in |- *; unfold Rmin in |- *; case (Rle_dec x1 (b - a)); intros.
-case (Rle_dec x0 x1); intro;
- [ apply (cond_pos x0) | elim H9; intros; assumption ].
-case (Rle_dec x0 (b - a)); intro;
- [ apply (cond_pos x0) | apply Rlt_Rminus; assumption ].
-split with (mkposreal _ H10); intros; case (Rcase_abs h0); intro.
-assert (H14 : b + h0 < b).
-pattern b at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- assumption.
-assert (H13 : Riemann_integrable f (b + h0) b).
-apply continuity_implies_RiemannInt.
-left; assumption.
-intros; apply C0; elim H13; intros; split; try assumption.
-apply Rle_trans with (b + h0); try assumption.
-apply Rplus_le_reg_l with (- a - h0).
-replace (- a - h0 + a) with (- h0); [ idtac | ring ].
-replace (- a - h0 + (b + h0)) with (b - a); [ idtac | ring ].
-apply Rle_trans with del.
-apply Rle_trans with (Rabs h0).
-rewrite <- Rabs_Ropp; apply RRle_abs.
-left; assumption.
-unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
-replace (primitive h (FTC_P1 h C0) (b + h0) - primitive h (FTC_P1 h C0) b)
- with (- RiemannInt H13).
-replace (f b) with (- RiemannInt (RiemannInt_P14 (b + h0) b (f b)) / h0).
-rewrite <- Rabs_Ropp; unfold Rminus in |- *; unfold Rdiv in |- *;
- rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_plus_distr;
- repeat rewrite Ropp_involutive;
- replace
-  (RiemannInt H13 * / h0 +
-   - RiemannInt (RiemannInt_P14 (b + h0) b (f b)) * / h0) with
-  ((RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) / h0).
-replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) with
- (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))).
-unfold Rdiv in |- *; rewrite Rabs_mult;
- apply Rle_lt_trans with
-  (RiemannInt
-     (RiemannInt_P16
-        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))) *
-   Rabs (/ h0)).
-do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
-apply Rabs_pos.
-apply
- (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))
-    (RiemannInt_P16
-       (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); 
- left; assumption.
-apply Rle_lt_trans with
- (RiemannInt (RiemannInt_P14 (b + h0) b (eps / 2)) * Rabs (/ h0)).
-do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
-apply Rabs_pos.
-apply RiemannInt_P19.
-left; assumption.
-intros; replace (f x2 + -1 * fct_cte (f b) x2) with (f x2 - f b).
-unfold fct_cte in |- *; case (Req_dec b x2); intro.
-rewrite H16; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- left; assumption.
-elim H9; intros; left; apply H18.
-repeat split.
-assumption.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
-apply Rplus_lt_reg_r with (x2 - x1);
- replace (x2 - x1 + (b - x2)) with (b - x1); [ idtac | ring ].
-replace (x2 - x1 + x1) with x2; [ idtac | ring ].
-apply Rlt_le_trans with (b + h0).
-2: elim H15; intros; left; assumption.
-unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_cancel;
- rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0).
-rewrite <- Rabs_Ropp; apply RRle_abs.
-apply Rlt_le_trans with del;
- [ assumption
- | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a));
-    [ apply Rmin_r | apply Rmin_l ] ].
-apply Rle_ge; left; apply Rlt_Rminus; elim H15; intros; assumption.
-unfold fct_cte in |- *; ring.
-rewrite RiemannInt_P15.
-rewrite Rmult_assoc; replace ((b - (b + h0)) * Rabs (/ h0)) with 1.
-rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
-       rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-rewrite Rabs_left.
-apply Rmult_eq_reg_l with h0;
- [ do 2 rewrite (Rmult_comm h0); rewrite Rmult_assoc;
-    rewrite Ropp_mult_distr_l_reverse; rewrite <- Rinv_l_sym;
-    [ ring | assumption ]
- | assumption ].
-apply Rinv_lt_0_compat; assumption.
-rewrite
- (RiemannInt_P13 H13 (RiemannInt_P14 (b + h0) b (f b))
-    (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))
- ; ring.
-unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
-rewrite RiemannInt_P15.
-rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_eq_reg_l with h0;
- [ repeat rewrite (Rmult_comm h0); unfold Rdiv in |- *;
-    repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; 
-    [ ring | assumption ]
- | assumption ].
-cut (a <= b + h0).
-cut (b + h0 <= b).
-intros; unfold primitive in |- *; case (Rle_dec a (b + h0));
- case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); 
- intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
-rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); ring.
-elim n; assumption.
-left; assumption.
-apply Rplus_le_reg_l with (- a - h0).
-replace (- a - h0 + a) with (- h0); [ idtac | ring ].
-replace (- a - h0 + (b + h0)) with (b - a); [ idtac | ring ].
-apply Rle_trans with del.
-apply Rle_trans with (Rabs h0).
-rewrite <- Rabs_Ropp; apply RRle_abs.
-left; assumption.
-unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
-cut (primitive h (FTC_P1 h C0) b = f_b b).
-intro; cut (primitive h (FTC_P1 h C0) (b + h0) = f_b (b + h0)).
-intro; rewrite H13; rewrite H14; apply H6.
-assumption.
-apply Rlt_le_trans with del;
- [ assumption | unfold del in |- *; apply Rmin_l ].
-assert (H14 : b < b + h0).
-pattern b at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
-assert (H14 := Rge_le _ _ r); elim H14; intro.
-assumption.
-elim H11; symmetry  in |- *; assumption.
-unfold primitive in |- *; case (Rle_dec a (b + h0));
- case (Rle_dec (b + h0) b); intros;
- [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14))
- | unfold f_b in |- *; reflexivity
- | elim n; left; apply Rlt_trans with b; assumption
- | elim n0; left; apply Rlt_trans with b; assumption ].
-unfold f_b in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rmult_0_r; rewrite Rplus_0_l; unfold primitive in |- *;
- case (Rle_dec a b); case (Rle_dec b b); intros;
- [ apply RiemannInt_P5
- | elim n; right; reflexivity
- | elim n; left; assumption
- | elim n; right; reflexivity ].
+  forall (f:R -> R) (a b x:R) (h:a <= b)
+    (C0:forall x:R, a <= x <= b -> continuity_pt f x),
+    a <= x <= b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x).
+Proof.
+  intro f; intros; elim h; intro.
+  elim H; clear H; intros; elim H; intro.
+  elim H1; intro.
+  apply RiemannInt_P27; split; assumption.
+  set
+    (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b)));
+    rewrite H3.
+  assert (H4 : derivable_pt_lim f_b b (f b)).
+  unfold f_b in |- *; pattern (f b) at 2 in |- *; replace (f b) with (f b + 0).
+  change
+    (derivable_pt_lim
+      ((fct_cte (f b) * (id - fct_cte b))%F +
+        fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
+          f b + 0)) in |- *. 
+  apply derivable_pt_lim_plus.
+  pattern (f b) at 2 in |- *;
+    replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_const.
+  replace 1 with (1 - 0); [ idtac | ring ].
+  apply derivable_pt_lim_minus.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_const.
+  unfold fct_cte in |- *; ring.
+  apply derivable_pt_lim_const.
+  ring.
+  unfold derivable_pt_lim in |- *; intros; elim (H4 _ H5); intros;
+    assert (H7 : continuity_pt f b).
+  apply C0; split; [ left; assumption | right; reflexivity ].
+  assert (H8 : 0 < eps / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H7 _ H8); unfold D_x, no_cond, dist in |- *; simpl in |- *;
+    unfold R_dist in |- *; intros; set (del := Rmin x0 (Rmin x1 (b - a)));
+      assert (H10 : 0 < del).
+  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec x1 (b - a)); intros.
+  case (Rle_dec x0 x1); intro;
+    [ apply (cond_pos x0) | elim H9; intros; assumption ].
+  case (Rle_dec x0 (b - a)); intro;
+    [ apply (cond_pos x0) | apply Rlt_Rminus; assumption ].
+  split with (mkposreal _ H10); intros; case (Rcase_abs h0); intro.
+  assert (H14 : b + h0 < b).
+  pattern b at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    assumption.
+  assert (H13 : Riemann_integrable f (b + h0) b).
+  apply continuity_implies_RiemannInt.
+  left; assumption.
+  intros; apply C0; elim H13; intros; split; try assumption.
+  apply Rle_trans with (b + h0); try assumption.
+  apply Rplus_le_reg_l with (- a - h0).
+  replace (- a - h0 + a) with (- h0); [ idtac | ring ].
+  replace (- a - h0 + (b + h0)) with (b - a); [ idtac | ring ].
+  apply Rle_trans with del.
+  apply Rle_trans with (Rabs h0).
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  left; assumption.
+  unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+  replace (primitive h (FTC_P1 h C0) (b + h0) - primitive h (FTC_P1 h C0) b)
+    with (- RiemannInt H13).
+  replace (f b) with (- RiemannInt (RiemannInt_P14 (b + h0) b (f b)) / h0).
+  rewrite <- Rabs_Ropp; unfold Rminus in |- *; unfold Rdiv in |- *;
+    rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_plus_distr;
+      repeat rewrite Ropp_involutive;
+        replace
+        (RiemannInt H13 * / h0 +
+          - RiemannInt (RiemannInt_P14 (b + h0) b (f b)) * / h0) with
+        ((RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) / h0).
+  replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) with
+  (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))).
+  unfold Rdiv in |- *; rewrite Rabs_mult;
+    apply Rle_lt_trans with
+      (RiemannInt
+        (RiemannInt_P16
+          (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))) *
+        Rabs (/ h0)).
+  do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply
+    (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))
+      (RiemannInt_P16
+        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); 
+    left; assumption.
+  apply Rle_lt_trans with
+    (RiemannInt (RiemannInt_P14 (b + h0) b (eps / 2)) * Rabs (/ h0)).
+  do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply RiemannInt_P19.
+  left; assumption.
+  intros; replace (f x2 + -1 * fct_cte (f b) x2) with (f x2 - f b).
+  unfold fct_cte in |- *; case (Req_dec b x2); intro.
+  rewrite H16; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    left; assumption.
+  elim H9; intros; left; apply H18.
+  repeat split.
+  assumption.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
+  apply Rplus_lt_reg_r with (x2 - x1);
+    replace (x2 - x1 + (b - x2)) with (b - x1); [ idtac | ring ].
+  replace (x2 - x1 + x1) with x2; [ idtac | ring ].
+  apply Rlt_le_trans with (b + h0).
+  2: elim H15; intros; left; assumption.
+  unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_cancel;
+    rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0).
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  apply Rlt_le_trans with del;
+    [ assumption
+      | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a));
+        [ apply Rmin_r | apply Rmin_l ] ].
+  apply Rle_ge; left; apply Rlt_Rminus; elim H15; intros; assumption.
+  unfold fct_cte in |- *; ring.
+  rewrite RiemannInt_P15.
+  rewrite Rmult_assoc; replace ((b - (b + h0)) * Rabs (/ h0)) with 1.
+  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+            rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  rewrite Rabs_left.
+  apply Rmult_eq_reg_l with h0;
+    [ do 2 rewrite (Rmult_comm h0); rewrite Rmult_assoc;
+      rewrite Ropp_mult_distr_l_reverse; rewrite <- Rinv_l_sym;
+        [ ring | assumption ]
+      | assumption ].
+  apply Rinv_lt_0_compat; assumption.
+  rewrite
+    (RiemannInt_P13 H13 (RiemannInt_P14 (b + h0) b (f b))
+      (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))
+    ; ring.
+  unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+  rewrite RiemannInt_P15.
+  rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_eq_reg_l with h0;
+    [ repeat rewrite (Rmult_comm h0); unfold Rdiv in |- *;
+      repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; 
+        [ ring | assumption ]
+      | assumption ].
+  cut (a <= b + h0).
+  cut (b + h0 <= b).
+  intros; unfold primitive in |- *; case (Rle_dec a (b + h0));
+    case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); 
+    intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
+  rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); ring.
+  elim n; assumption.
+  left; assumption.
+  apply Rplus_le_reg_l with (- a - h0).
+  replace (- a - h0 + a) with (- h0); [ idtac | ring ].
+  replace (- a - h0 + (b + h0)) with (b - a); [ idtac | ring ].
+  apply Rle_trans with del.
+  apply Rle_trans with (Rabs h0).
+  rewrite <- Rabs_Ropp; apply RRle_abs.
+  left; assumption.
+  unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+  cut (primitive h (FTC_P1 h C0) b = f_b b).
+  intro; cut (primitive h (FTC_P1 h C0) (b + h0) = f_b (b + h0)).
+  intro; rewrite H13; rewrite H14; apply H6.
+  assumption.
+  apply Rlt_le_trans with del;
+    [ assumption | unfold del in |- *; apply Rmin_l ].
+  assert (H14 : b < b + h0).
+  pattern b at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+  assert (H14 := Rge_le _ _ r); elim H14; intro.
+  assumption.
+  elim H11; symmetry  in |- *; assumption.
+  unfold primitive in |- *; case (Rle_dec a (b + h0));
+    case (Rle_dec (b + h0) b); intros;
+      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14))
+        | unfold f_b in |- *; reflexivity
+        | elim n; left; apply Rlt_trans with b; assumption
+        | elim n0; left; apply Rlt_trans with b; assumption ].
+  unfold f_b in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rmult_0_r; rewrite Rplus_0_l; unfold primitive in |- *;
+      case (Rle_dec a b); case (Rle_dec b b); intros;
+        [ apply RiemannInt_P5
+          | elim n; right; reflexivity
+          | elim n; left; assumption
+          | elim n; right; reflexivity ].
 (*****)
-set (f_a := fun x:R => f a * (x - a)); rewrite <- H2;
- assert (H3 : derivable_pt_lim f_a a (f a)).
-unfold f_a in |- *;
- change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a))
-  in |- *; pattern (f a) at 2 in |- *;
- replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1).
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_const.
-replace 1 with (1 - 0); [ idtac | ring ].
-apply derivable_pt_lim_minus.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_const.
-unfold fct_cte in |- *; ring.
-unfold derivable_pt_lim in |- *; intros; elim (H3 _ H4); intros.
-assert (H6 : continuity_pt f a).
-apply C0; split; [ right; reflexivity | left; assumption ].
-assert (H7 : 0 < eps / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-elim (H6 _ H7); unfold D_x, no_cond, dist in |- *; simpl in |- *;
- unfold R_dist in |- *; intros.
-set (del := Rmin x0 (Rmin x1 (b - a))).
-assert (H9 : 0 < del).
-unfold del in |- *; unfold Rmin in |- *.
-case (Rle_dec x1 (b - a)); intros.
-case (Rle_dec x0 x1); intro.
-apply (cond_pos x0).
-elim H8; intros; assumption.
-case (Rle_dec x0 (b - a)); intro.
-apply (cond_pos x0).
-apply Rlt_Rminus; assumption.
-split with (mkposreal _ H9).
-intros; case (Rcase_abs h0); intro.
-assert (H12 : a + h0 < a).
-pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- assumption.
-unfold primitive in |- *.
-case (Rle_dec a (a + h0)); case (Rle_dec (a + h0) b); case (Rle_dec a a);
- case (Rle_dec a b); intros;
- try (elim n; left; assumption) || (elim n; right; reflexivity).
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H12)).
-elim n; left; apply Rlt_trans with a; assumption.
-rewrite RiemannInt_P9; replace 0 with (f_a a).
-replace (f a * (a + h0 - a)) with (f_a (a + h0)).
-apply H5; try assumption.
-apply Rlt_le_trans with del;
- [ assumption | unfold del in |- *; apply Rmin_l ].
-unfold f_a in |- *; ring.
-unfold f_a in |- *; ring.
-elim n; left; apply Rlt_trans with a; assumption.
-assert (H12 : a < a + h0).
-pattern a at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
-assert (H12 := Rge_le _ _ r); elim H12; intro.
-assumption.
-elim H10; symmetry  in |- *; assumption.
-assert (H13 : Riemann_integrable f a (a + h0)).
-apply continuity_implies_RiemannInt.
-left; assumption.
-intros; apply C0; elim H13; intros; split; try assumption.
-apply Rle_trans with (a + h0); try assumption.
-apply Rplus_le_reg_l with (- b - h0).
-replace (- b - h0 + b) with (- h0); [ idtac | ring ].
-replace (- b - h0 + (a + h0)) with (a - b); [ idtac | ring ].
-apply Ropp_le_cancel; rewrite Ropp_involutive; rewrite Ropp_minus_distr;
- apply Rle_trans with del.
-apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ].
-unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
-replace (primitive h (FTC_P1 h C0) (a + h0) - primitive h (FTC_P1 h C0) a)
- with (RiemannInt H13).
-replace (f a) with (RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0).
-replace
- (RiemannInt H13 / h0 - RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0)
- with ((RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) / h0).
-replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) with
- (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))).
-unfold Rdiv in |- *; rewrite Rabs_mult;
- apply Rle_lt_trans with
-  (RiemannInt
-     (RiemannInt_P16
-        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))) *
-   Rabs (/ h0)).
-do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
-apply Rabs_pos.
-apply
- (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))
-    (RiemannInt_P16
-       (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); 
- left; assumption.
-apply Rle_lt_trans with
- (RiemannInt (RiemannInt_P14 a (a + h0) (eps / 2)) * Rabs (/ h0)).
-do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
-apply Rabs_pos.
-apply RiemannInt_P19.
-left; assumption.
-intros; replace (f x2 + -1 * fct_cte (f a) x2) with (f x2 - f a).
-unfold fct_cte in |- *; case (Req_dec a x2); intro.
-rewrite H15; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- left; assumption.
-elim H8; intros; left; apply H17; repeat split.
-assumption.
-rewrite Rabs_right.
-apply Rplus_lt_reg_r with a; replace (a + (x2 - a)) with x2; [ idtac | ring ].
-apply Rlt_le_trans with (a + h0).
-elim H14; intros; assumption.
-apply Rplus_le_compat_l; left; apply Rle_lt_trans with (Rabs h0).
-apply RRle_abs.
-apply Rlt_le_trans with del;
- [ assumption
- | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a));
-    [ apply Rmin_r | apply Rmin_l ] ].
-apply Rle_ge; left; apply Rlt_Rminus; elim H14; intros; assumption.
-unfold fct_cte in |- *; ring.
-rewrite RiemannInt_P15.
-rewrite Rmult_assoc; replace ((a + h0 - a) * Rabs (/ h0)) with 1.
-rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
-       rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-rewrite Rabs_right.
-rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
- rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym;
- [ reflexivity | assumption ].
-apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ r);
- elim H14; intro.
-assumption.
-elim H10; symmetry  in |- *; assumption.
-rewrite
- (RiemannInt_P13 H13 (RiemannInt_P14 a (a + h0) (f a))
-    (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))
- ; ring.
-unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
-rewrite RiemannInt_P15.
-rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
- rewrite Rplus_opp_r; rewrite Rplus_0_r; unfold Rdiv in |- *;
- rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ ring | assumption ].
-cut (a <= a + h0).
-cut (a + h0 <= b).
-intros; unfold primitive in |- *; case (Rle_dec a (a + h0));
- case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); 
- intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
-rewrite RiemannInt_P9; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; apply RiemannInt_P5.
-elim n; assumption.
-elim n; assumption.
-2: left; assumption.
-apply Rplus_le_reg_l with (- a); replace (- a + (a + h0)) with h0;
- [ idtac | ring ].
-rewrite Rplus_comm; apply Rle_trans with del;
- [ apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ]
- | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r ].
+  set (f_a := fun x:R => f a * (x - a)); rewrite <- H2;
+    assert (H3 : derivable_pt_lim f_a a (f a)).
+  unfold f_a in |- *;
+    change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a))
+      in |- *; pattern (f a) at 2 in |- *;
+        replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1).
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_const.
+  replace 1 with (1 - 0); [ idtac | ring ].
+  apply derivable_pt_lim_minus.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_const.
+  unfold fct_cte in |- *; ring.
+  unfold derivable_pt_lim in |- *; intros; elim (H3 _ H4); intros.
+  assert (H6 : continuity_pt f a).
+  apply C0; split; [ right; reflexivity | left; assumption ].
+  assert (H7 : 0 < eps / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim (H6 _ H7); unfold D_x, no_cond, dist in |- *; simpl in |- *;
+    unfold R_dist in |- *; intros.
+  set (del := Rmin x0 (Rmin x1 (b - a))).
+  assert (H9 : 0 < del).
+  unfold del in |- *; unfold Rmin in |- *.
+  case (Rle_dec x1 (b - a)); intros.
+  case (Rle_dec x0 x1); intro.
+  apply (cond_pos x0).
+  elim H8; intros; assumption.
+  case (Rle_dec x0 (b - a)); intro.
+  apply (cond_pos x0).
+  apply Rlt_Rminus; assumption.
+  split with (mkposreal _ H9).
+  intros; case (Rcase_abs h0); intro.
+  assert (H12 : a + h0 < a).
+  pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    assumption.
+  unfold primitive in |- *.
+  case (Rle_dec a (a + h0)); case (Rle_dec (a + h0) b); case (Rle_dec a a);
+  case (Rle_dec a b); intros;
+    try (elim n; left; assumption) || (elim n; right; reflexivity).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H12)).
+  elim n; left; apply Rlt_trans with a; assumption.
+  rewrite RiemannInt_P9; replace 0 with (f_a a).
+  replace (f a * (a + h0 - a)) with (f_a (a + h0)).
+  apply H5; try assumption.
+  apply Rlt_le_trans with del;
+    [ assumption | unfold del in |- *; apply Rmin_l ].
+  unfold f_a in |- *; ring.
+  unfold f_a in |- *; ring.
+  elim n; left; apply Rlt_trans with a; assumption.
+  assert (H12 : a < a + h0).
+  pattern a at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+  assert (H12 := Rge_le _ _ r); elim H12; intro.
+  assumption.
+  elim H10; symmetry  in |- *; assumption.
+  assert (H13 : Riemann_integrable f a (a + h0)).
+  apply continuity_implies_RiemannInt.
+  left; assumption.
+  intros; apply C0; elim H13; intros; split; try assumption.
+  apply Rle_trans with (a + h0); try assumption.
+  apply Rplus_le_reg_l with (- b - h0).
+  replace (- b - h0 + b) with (- h0); [ idtac | ring ].
+  replace (- b - h0 + (a + h0)) with (a - b); [ idtac | ring ].
+  apply Ropp_le_cancel; rewrite Ropp_involutive; rewrite Ropp_minus_distr;
+    apply Rle_trans with del.
+  apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ].
+  unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+  replace (primitive h (FTC_P1 h C0) (a + h0) - primitive h (FTC_P1 h C0) a)
+    with (RiemannInt H13).
+  replace (f a) with (RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0).
+  replace
+  (RiemannInt H13 / h0 - RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0)
+    with ((RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) / h0).
+  replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) with
+  (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))).
+  unfold Rdiv in |- *; rewrite Rabs_mult;
+    apply Rle_lt_trans with
+      (RiemannInt
+        (RiemannInt_P16
+          (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))) *
+        Rabs (/ h0)).
+  do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply
+    (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))
+      (RiemannInt_P16
+        (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); 
+    left; assumption.
+  apply Rle_lt_trans with
+    (RiemannInt (RiemannInt_P14 a (a + h0) (eps / 2)) * Rabs (/ h0)).
+  do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply RiemannInt_P19.
+  left; assumption.
+  intros; replace (f x2 + -1 * fct_cte (f a) x2) with (f x2 - f a).
+  unfold fct_cte in |- *; case (Req_dec a x2); intro.
+  rewrite H15; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    left; assumption.
+  elim H8; intros; left; apply H17; repeat split.
+  assumption.
+  rewrite Rabs_right.
+  apply Rplus_lt_reg_r with a; replace (a + (x2 - a)) with x2; [ idtac | ring ].
+  apply Rlt_le_trans with (a + h0).
+  elim H14; intros; assumption.
+  apply Rplus_le_compat_l; left; apply Rle_lt_trans with (Rabs h0).
+  apply RRle_abs.
+  apply Rlt_le_trans with del;
+    [ assumption
+      | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a));
+        [ apply Rmin_r | apply Rmin_l ] ].
+  apply Rle_ge; left; apply Rlt_Rminus; elim H14; intros; assumption.
+  unfold fct_cte in |- *; ring.
+  rewrite RiemannInt_P15.
+  rewrite Rmult_assoc; replace ((a + h0 - a) * Rabs (/ h0)) with 1.
+  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+            rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  rewrite Rabs_right.
+  rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym;
+      [ reflexivity | assumption ].
+  apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ r);
+    elim H14; intro.
+  assumption.
+  elim H10; symmetry  in |- *; assumption.
+  rewrite
+    (RiemannInt_P13 H13 (RiemannInt_P14 a (a + h0) (f a))
+      (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))
+    ; ring.
+  unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+  rewrite RiemannInt_P15.
+  rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_r; unfold Rdiv in |- *;
+      rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ ring | assumption ].
+  cut (a <= a + h0).
+  cut (a + h0 <= b).
+  intros; unfold primitive in |- *; case (Rle_dec a (a + h0));
+    case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); 
+    intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
+  rewrite RiemannInt_P9; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; apply RiemannInt_P5.
+  elim n; assumption.
+  elim n; assumption.
+  2: left; assumption.
+  apply Rplus_le_reg_l with (- a); replace (- a + (a + h0)) with h0;
+    [ idtac | ring ].
+  rewrite Rplus_comm; apply Rle_trans with del;
+    [ apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ]
+      | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r ].
 (*****)
-assert (H1 : x = a).
-rewrite <- H0 in H; elim H; intros; apply Rle_antisym; assumption.
-set (f_a := fun x:R => f a * (x - a)).
-assert (H2 : derivable_pt_lim f_a a (f a)).
-unfold f_a in |- *;
- change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a))
-  in |- *; pattern (f a) at 2 in |- *;
- replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1).
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_const.
-replace 1 with (1 - 0); [ idtac | ring ].
-apply derivable_pt_lim_minus.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_const.
-unfold fct_cte in |- *; ring.
-set
- (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b))).
-assert (H3 : derivable_pt_lim f_b b (f b)).
-unfold f_b in |- *; pattern (f b) at 2 in |- *; replace (f b) with (f b + 0).
-change
-  (derivable_pt_lim
-     ((fct_cte (f b) * (id - fct_cte b))%F +
-      fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
-     f b + 0)) in |- *. 
-apply derivable_pt_lim_plus.
-pattern (f b) at 2 in |- *;
- replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
-apply derivable_pt_lim_mult.
-apply derivable_pt_lim_const.
-replace 1 with (1 - 0); [ idtac | ring ].
-apply derivable_pt_lim_minus.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_const.
-unfold fct_cte in |- *; ring.
-apply derivable_pt_lim_const.
-ring.
-unfold derivable_pt_lim in |- *; intros; elim (H2 _ H4); intros;
- elim (H3 _ H4); intros; set (del := Rmin x0 x1).
-assert (H7 : 0 < del).
-unfold del in |- *; unfold Rmin in |- *; case (Rle_dec x0 x1); intro.
-apply (cond_pos x0).
-apply (cond_pos x1).
-split with (mkposreal _ H7); intros; case (Rcase_abs h0); intro.
-assert (H10 : a + h0 < a).
-pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- assumption.
-rewrite H1; unfold primitive in |- *; case (Rle_dec a (a + h0));
- case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); 
- intros; try (elim n; right; assumption || reflexivity).
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H10)).
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
-rewrite RiemannInt_P9; replace 0 with (f_a a).
-replace (f a * (a + h0 - a)) with (f_a (a + h0)).
-apply H5; try assumption.
-apply Rlt_le_trans with del; try assumption.
-unfold del in |- *; apply Rmin_l.
-unfold f_a in |- *; ring.
-unfold f_a in |- *; ring.
-elim n; rewrite <- H0; left; assumption.
-assert (H10 : a < a + h0).
-pattern a at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
-assert (H10 := Rge_le _ _ r); elim H10; intro.
-assumption.
-elim H8; symmetry  in |- *; assumption.
-rewrite H0 in H1; rewrite H1; unfold primitive in |- *;
- case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b); 
- case (Rle_dec a b); case (Rle_dec b b); intros;
- try (elim n; right; assumption || reflexivity).
-rewrite H0 in H10; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
-repeat rewrite RiemannInt_P9.
-replace (RiemannInt (FTC_P1 h C0 r1 r0)) with (f_b b).
-fold (f_b (b + h0)) in |- *.
-apply H6; try assumption.
-apply Rlt_le_trans with del; try assumption.
-unfold del in |- *; apply Rmin_r.
-unfold f_b in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rmult_0_r; rewrite Rplus_0_l; apply RiemannInt_P5.
-elim n; rewrite <- H0; left; assumption.
-elim n0; rewrite <- H0; left; assumption.
+  assert (H1 : x = a).
+  rewrite <- H0 in H; elim H; intros; apply Rle_antisym; assumption.
+  set (f_a := fun x:R => f a * (x - a)).
+  assert (H2 : derivable_pt_lim f_a a (f a)).
+  unfold f_a in |- *;
+    change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a))
+      in |- *; pattern (f a) at 2 in |- *;
+        replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1).
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_const.
+  replace 1 with (1 - 0); [ idtac | ring ].
+  apply derivable_pt_lim_minus.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_const.
+  unfold fct_cte in |- *; ring.
+  set
+    (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b))).
+  assert (H3 : derivable_pt_lim f_b b (f b)).
+  unfold f_b in |- *; pattern (f b) at 2 in |- *; replace (f b) with (f b + 0).
+  change
+    (derivable_pt_lim
+      ((fct_cte (f b) * (id - fct_cte b))%F +
+        fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
+          f b + 0)) in |- *. 
+  apply derivable_pt_lim_plus.
+  pattern (f b) at 2 in |- *;
+    replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
+  apply derivable_pt_lim_mult.
+  apply derivable_pt_lim_const.
+  replace 1 with (1 - 0); [ idtac | ring ].
+  apply derivable_pt_lim_minus.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_const.
+  unfold fct_cte in |- *; ring.
+  apply derivable_pt_lim_const.
+  ring.
+  unfold derivable_pt_lim in |- *; intros; elim (H2 _ H4); intros;
+    elim (H3 _ H4); intros; set (del := Rmin x0 x1).
+  assert (H7 : 0 < del).
+  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec x0 x1); intro.
+  apply (cond_pos x0).
+  apply (cond_pos x1).
+  split with (mkposreal _ H7); intros; case (Rcase_abs h0); intro.
+  assert (H10 : a + h0 < a).
+  pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    assumption.
+  rewrite H1; unfold primitive in |- *; case (Rle_dec a (a + h0));
+    case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); 
+    intros; try (elim n; right; assumption || reflexivity).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H10)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
+  rewrite RiemannInt_P9; replace 0 with (f_a a).
+  replace (f a * (a + h0 - a)) with (f_a (a + h0)).
+  apply H5; try assumption.
+  apply Rlt_le_trans with del; try assumption.
+  unfold del in |- *; apply Rmin_l.
+  unfold f_a in |- *; ring.
+  unfold f_a in |- *; ring.
+  elim n; rewrite <- H0; left; assumption.
+  assert (H10 : a < a + h0).
+  pattern a at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+  assert (H10 := Rge_le _ _ r); elim H10; intro.
+  assumption.
+  elim H8; symmetry  in |- *; assumption.
+  rewrite H0 in H1; rewrite H1; unfold primitive in |- *;
+    case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b); 
+    case (Rle_dec a b); case (Rle_dec b b); intros;
+      try (elim n; right; assumption || reflexivity).
+  rewrite H0 in H10; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
+  repeat rewrite RiemannInt_P9.
+  replace (RiemannInt (FTC_P1 h C0 r1 r0)) with (f_b b).
+  fold (f_b (b + h0)) in |- *.
+  apply H6; try assumption.
+  apply Rlt_le_trans with del; try assumption.
+  unfold del in |- *; apply Rmin_r.
+  unfold f_b in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rmult_0_r; rewrite Rplus_0_l; apply RiemannInt_P5.
+  elim n; rewrite <- H0; left; assumption.
+  elim n0; rewrite <- H0; left; assumption.
 Qed.
 
 Lemma RiemannInt_P29 :
- forall (f:R -> R) a b (h:a <= b)
-   (C0:forall x:R, a <= x <= b -> continuity_pt f x),
-   antiderivative f (primitive h (FTC_P1 h C0)) a b.
-intro f; intros; unfold antiderivative in |- *; split; try assumption; intros;
- assert (H0 := RiemannInt_P28 h C0 H);
- assert (H1 : derivable_pt (primitive h (FTC_P1 h C0)) x);
- [ unfold derivable_pt in |- *; split with (f x); apply H0
- | split with H1; symmetry  in |- *; apply derive_pt_eq_0; apply H0 ].
+  forall (f:R -> R) a b (h:a <= b)
+    (C0:forall x:R, a <= x <= b -> continuity_pt f x),
+    antiderivative f (primitive h (FTC_P1 h C0)) a b.
+Proof.
+  intro f; intros; unfold antiderivative in |- *; split; try assumption; intros;
+    assert (H0 := RiemannInt_P28 h C0 H);
+      assert (H1 : derivable_pt (primitive h (FTC_P1 h C0)) x);
+        [ unfold derivable_pt in |- *; split with (f x); apply H0
+          | split with H1; symmetry  in |- *; apply derive_pt_eq_0; apply H0 ].
 Qed.
 
 Lemma RiemannInt_P30 :
- forall (f:R -> R) (a b:R),
-   a <= b ->
-   (forall x:R, a <= x <= b -> continuity_pt f x) ->
-   sigT (fun g:R -> R => antiderivative f g a b).
-intros; split with (primitive H (FTC_P1 H H0)); apply RiemannInt_P29.
+  forall (f:R -> R) (a b:R),
+    a <= b ->
+    (forall x:R, a <= x <= b -> continuity_pt f x) ->
+    sigT (fun g:R -> R => antiderivative f g a b).
+Proof.
+  intros; split with (primitive H (FTC_P1 H H0)); apply RiemannInt_P29.
 Qed.
 
 Record C1_fun : Type := mkC1
   {c1 :> R -> R; diff0 : derivable c1; cont1 : continuity (derive c1 diff0)}.
 
 Lemma RiemannInt_P31 :
- forall (f:C1_fun) (a b:R),
-   a <= b -> antiderivative (derive f (diff0 f)) f a b.
-intro f; intros; unfold antiderivative in |- *; split; try assumption; intros;
- split with (diff0 f x); reflexivity.
+  forall (f:C1_fun) (a b:R),
+    a <= b -> antiderivative (derive f (diff0 f)) f a b.
+Proof.
+  intro f; intros; unfold antiderivative in |- *; split; try assumption; intros;
+    split with (diff0 f x); reflexivity.
 Qed.
 
 Lemma RiemannInt_P32 :
- forall (f:C1_fun) (a b:R), Riemann_integrable (derive f (diff0 f)) a b.
-intro f; intros; case (Rle_dec a b); intro;
- [ apply continuity_implies_RiemannInt; try assumption; intros;
-    apply (cont1 f)
- | assert (H : b <= a);
-    [ auto with real
-    | apply RiemannInt_P1; apply continuity_implies_RiemannInt;
-       try assumption; intros; apply (cont1 f) ] ].
+  forall (f:C1_fun) (a b:R), Riemann_integrable (derive f (diff0 f)) a b.
+Proof.
+  intro f; intros; case (Rle_dec a b); intro;
+    [ apply continuity_implies_RiemannInt; try assumption; intros;
+      apply (cont1 f)
+      | assert (H : b <= a);
+        [ auto with real
+          | apply RiemannInt_P1; apply continuity_implies_RiemannInt;
+            try assumption; intros; apply (cont1 f) ] ].
 Qed.
 
 Lemma RiemannInt_P33 :
- forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
-   a <= b -> RiemannInt pr = f b - f a.
-intro f; intros;
- assert
-  (H0 : forall x:R, a <= x <= b -> continuity_pt (derive f (diff0 f)) x).
-intros; apply (cont1 f).
-rewrite (RiemannInt_P20 H (FTC_P1 H H0) pr);
- assert (H1 := RiemannInt_P29 H H0); assert (H2 := RiemannInt_P31 f H);
- elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); 
- intros C H3; repeat rewrite H3;
- [ ring
- | split; [ right; reflexivity | assumption ]
- | split; [ assumption | right; reflexivity ] ].
+  forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
+    a <= b -> RiemannInt pr = f b - f a.
+Proof.
+  intro f; intros;
+    assert
+      (H0 : forall x:R, a <= x <= b -> continuity_pt (derive f (diff0 f)) x).
+  intros; apply (cont1 f).
+  rewrite (RiemannInt_P20 H (FTC_P1 H H0) pr);
+    assert (H1 := RiemannInt_P29 H H0); assert (H2 := RiemannInt_P31 f H);
+      elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); 
+        intros C H3; repeat rewrite H3;
+          [ ring
+            | split; [ right; reflexivity | assumption ]
+            | split; [ assumption | right; reflexivity ] ].
 Qed.
 
 Lemma FTC_Riemann :
- forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
-   RiemannInt pr = f b - f a.
-intro f; intros; case (Rle_dec a b); intro;
- [ apply RiemannInt_P33; assumption
- | assert (H : b <= a);
-    [ auto with real
-    | assert (H0 := RiemannInt_P1 pr); rewrite (RiemannInt_P8 pr H0);
-       rewrite (RiemannInt_P33 _ H0 H); ring ] ].
+  forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
+    RiemannInt pr = f b - f a.
+Proof.
+  intro f; intros; case (Rle_dec a b); intro;
+    [ apply RiemannInt_P33; assumption
+      | assert (H : b <= a);
+        [ auto with real
+          | assert (H0 := RiemannInt_P1 pr); rewrite (RiemannInt_P8 pr H0);
+            rewrite (RiemannInt_P33 _ H0 H); ring ] ].
 Qed.
diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
index 0ae8f9f2..0f91d006 100644
--- a/theories/Reals/RiemannInt_SF.v
+++ b/theories/Reals/RiemannInt_SF.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: RiemannInt_SF.v,v 1.16.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+(*i $Id: RiemannInt_SF.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -16,98 +16,100 @@ Open Local Scope R_scope.
 
 Set Implicit Arguments.
 
-(**************************************************)
-(* Each bounded subset of N has a maximal element *)
-(**************************************************)
+(*****************************************************)
+(** * Each bounded subset of N has a maximal element *)
+(*****************************************************)
 
 Definition Nbound (I:nat -> Prop) : Prop :=
-   exists n : nat, (forall i:nat, I i -> (i <= n)%nat).
+  exists n : nat, (forall i:nat, I i -> (i <= n)%nat).
 
 Lemma IZN_var : forall z:Z, (0 <= z)%Z -> {n : nat | z = Z_of_nat n}.
-intros; apply Z_of_nat_complete_inf; assumption.
+Proof.
+  intros; apply Z_of_nat_complete_inf; assumption.
 Qed.
 
 Lemma Nzorn :
- forall I:nat -> Prop,
-   (exists n : nat, I n) ->
-   Nbound I -> sigT (fun n:nat => I n /\ (forall i:nat, I i -> (i <= n)%nat)).
-intros I H H0; set (E := fun x:R =>  exists i : nat, I i /\ INR i = x);
- assert (H1 : bound E).
-unfold Nbound in H0; elim H0; intros N H1; unfold bound in |- *;
- exists (INR N); unfold is_upper_bound in |- *; intros; 
- unfold E in H2; elim H2; intros; elim H3; intros; 
- rewrite <- H5; apply le_INR; apply H1; assumption.
-assert (H2 :  exists x : R, E x).
-elim H; intros; exists (INR x); unfold E in |- *; exists x; split;
- [ assumption | reflexivity ].
-assert (H3 := completeness E H1 H2); elim H3; intros; unfold is_lub in p;
- elim p; clear p; intros; unfold is_upper_bound in H4, H5;
- assert (H6 : 0 <= x).
-elim H2; intros; unfold E in H6; elim H6; intros; elim H7; intros;
- apply Rle_trans with x0;
- [ rewrite <- H9; change (INR 0 <= INR x1) in |- *; apply le_INR;
-    apply le_O_n
- | apply H4; assumption ].
-assert (H7 := archimed x); elim H7; clear H7; intros;
- assert (H9 : x <= IZR (up x) - 1).
-apply H5; intros; assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros;
- elim H11; intros; rewrite <- H13; apply Rplus_le_reg_l with 1;
- replace (1 + (IZR (up x) - 1)) with (IZR (up x)); 
- [ idtac | ring ]; replace (1 + INR x1) with (INR (S x1));
- [ idtac | rewrite S_INR; ring ].
-assert (H14 : (0 <= up x)%Z).
-apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
-assert (H15 := IZN _ H14); elim H15; clear H15; intros; rewrite H15;
- rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S; 
- apply INR_lt; rewrite H13; apply Rle_lt_trans with x;
- [ assumption | rewrite INR_IZR_INZ; rewrite <- H15; assumption ].
-assert (H10 : x = IZR (up x) - 1).
-apply Rle_antisym;
- [ assumption
- | apply Rplus_le_reg_l with (- x + 1);
-    replace (- x + 1 + (IZR (up x) - 1)) with (IZR (up x) - x);
-    [ idtac | ring ]; replace (- x + 1 + x) with 1; 
-    [ assumption | ring ] ].
-assert (H11 : (0 <= up x)%Z).
-apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
-assert (H12 := IZN_var H11); elim H12; clear H12; intros; assert (H13 : E x).
-elim (classic (E x)); intro; try assumption.
-cut (forall y:R, E y -> y <= x - 1).
-intro; assert (H14 := H5 _ H13); cut (x - 1 < x).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H15)).
-apply Rminus_lt; replace (x - 1 - x) with (-1); [ idtac | ring ];
- rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply Rlt_0_1.
-intros; assert (H14 := H4 _ H13); elim H14; intro; unfold E in H13; elim H13;
- intros; elim H16; intros; apply Rplus_le_reg_l with 1.
-replace (1 + (x - 1)) with x; [ idtac | ring ]; rewrite <- H18;
- replace (1 + INR x1) with (INR (S x1)); [ idtac | rewrite S_INR; ring ].
-cut (x = INR (pred x0)).
-intro; rewrite H19; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H18;
- rewrite <- H19; assumption.
-rewrite H10; rewrite p; rewrite <- INR_IZR_INZ; replace 1 with (INR 1);
- [ idtac | reflexivity ]; rewrite <- minus_INR.
-replace (x0 - 1)%nat with (pred x0);
- [ reflexivity
- | case x0; [ reflexivity | intro; simpl in |- *; apply minus_n_O ] ].
-induction  x0 as [| x0 Hrecx0];
- [ rewrite p in H7; rewrite <- INR_IZR_INZ in H7; simpl in H7;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7))
- | apply le_n_S; apply le_O_n ].
-rewrite H15 in H13; elim H12; assumption.
-split with (pred x0); unfold E in H13; elim H13; intros; elim H12; intros;
- rewrite H10 in H15; rewrite p in H15; rewrite <- INR_IZR_INZ in H15;
- assert (H16 : INR x0 = INR x1 + 1).
-rewrite H15; ring.
-rewrite <- S_INR in H16; assert (H17 := INR_eq _ _ H16); rewrite H17;
- simpl in |- *; split.
-assumption.
-intros; apply INR_le; rewrite H15; rewrite <- H15; elim H12; intros;
- rewrite H20; apply H4; unfold E in |- *; exists i; 
- split; [ assumption | reflexivity ].
+  forall I:nat -> Prop,
+    (exists n : nat, I n) ->
+    Nbound I -> sigT (fun n:nat => I n /\ (forall i:nat, I i -> (i <= n)%nat)).
+Proof.
+  intros I H H0; set (E := fun x:R =>  exists i : nat, I i /\ INR i = x);
+    assert (H1 : bound E).
+  unfold Nbound in H0; elim H0; intros N H1; unfold bound in |- *;
+    exists (INR N); unfold is_upper_bound in |- *; intros; 
+      unfold E in H2; elim H2; intros; elim H3; intros; 
+        rewrite <- H5; apply le_INR; apply H1; assumption.
+  assert (H2 :  exists x : R, E x).
+  elim H; intros; exists (INR x); unfold E in |- *; exists x; split;
+    [ assumption | reflexivity ].
+  assert (H3 := completeness E H1 H2); elim H3; intros; unfold is_lub in p;
+    elim p; clear p; intros; unfold is_upper_bound in H4, H5;
+      assert (H6 : 0 <= x).
+  elim H2; intros; unfold E in H6; elim H6; intros; elim H7; intros;
+    apply Rle_trans with x0;
+      [ rewrite <- H9; change (INR 0 <= INR x1) in |- *; apply le_INR;
+        apply le_O_n
+        | apply H4; assumption ].
+  assert (H7 := archimed x); elim H7; clear H7; intros;
+    assert (H9 : x <= IZR (up x) - 1).
+  apply H5; intros; assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros;
+    elim H11; intros; rewrite <- H13; apply Rplus_le_reg_l with 1;
+      replace (1 + (IZR (up x) - 1)) with (IZR (up x)); 
+      [ idtac | ring ]; replace (1 + INR x1) with (INR (S x1));
+      [ idtac | rewrite S_INR; ring ].
+  assert (H14 : (0 <= up x)%Z).
+  apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
+  assert (H15 := IZN _ H14); elim H15; clear H15; intros; rewrite H15;
+    rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S; 
+      apply INR_lt; rewrite H13; apply Rle_lt_trans with x;
+        [ assumption | rewrite INR_IZR_INZ; rewrite <- H15; assumption ].
+  assert (H10 : x = IZR (up x) - 1).
+  apply Rle_antisym;
+    [ assumption
+      | apply Rplus_le_reg_l with (- x + 1);
+        replace (- x + 1 + (IZR (up x) - 1)) with (IZR (up x) - x);
+        [ idtac | ring ]; replace (- x + 1 + x) with 1; 
+        [ assumption | ring ] ].
+  assert (H11 : (0 <= up x)%Z).
+  apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
+  assert (H12 := IZN_var H11); elim H12; clear H12; intros; assert (H13 : E x).
+  elim (classic (E x)); intro; try assumption.
+  cut (forall y:R, E y -> y <= x - 1).
+  intro; assert (H14 := H5 _ H13); cut (x - 1 < x).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H15)).
+  apply Rminus_lt; replace (x - 1 - x) with (-1); [ idtac | ring ];
+    rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply Rlt_0_1.
+  intros; assert (H14 := H4 _ H13); elim H14; intro; unfold E in H13; elim H13;
+    intros; elim H16; intros; apply Rplus_le_reg_l with 1.
+  replace (1 + (x - 1)) with x; [ idtac | ring ]; rewrite <- H18;
+    replace (1 + INR x1) with (INR (S x1)); [ idtac | rewrite S_INR; ring ].
+  cut (x = INR (pred x0)).
+  intro; rewrite H19; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H18;
+    rewrite <- H19; assumption.
+  rewrite H10; rewrite p; rewrite <- INR_IZR_INZ; replace 1 with (INR 1);
+    [ idtac | reflexivity ]; rewrite <- minus_INR.
+  replace (x0 - 1)%nat with (pred x0);
+  [ reflexivity
+    | case x0; [ reflexivity | intro; simpl in |- *; apply minus_n_O ] ].
+  induction  x0 as [| x0 Hrecx0];
+    [ rewrite p in H7; rewrite <- INR_IZR_INZ in H7; simpl in H7;
+      elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7))
+      | apply le_n_S; apply le_O_n ].
+  rewrite H15 in H13; elim H12; assumption.
+  split with (pred x0); unfold E in H13; elim H13; intros; elim H12; intros;
+    rewrite H10 in H15; rewrite p in H15; rewrite <- INR_IZR_INZ in H15;
+      assert (H16 : INR x0 = INR x1 + 1).
+  rewrite H15; ring.
+  rewrite <- S_INR in H16; assert (H17 := INR_eq _ _ H16); rewrite H17;
+    simpl in |- *; split.
+  assumption.
+  intros; apply INR_le; rewrite H15; rewrite <- H15; elim H12; intros;
+    rewrite H20; apply H4; unfold E in |- *; exists i; 
+      split; [ assumption | reflexivity ].
 Qed.
 
 (*******************************************)
-(*             Step functions              *)
+(** *          Step functions              *)
 (*******************************************)
 
 Definition open_interval (a b x:R) : Prop := a < x < b.
@@ -119,15 +121,15 @@ Definition adapted_couple (f:R -> R) (a b:R) (l lf:Rlist) : Prop :=
   pos_Rl l (pred (Rlength l)) = Rmax a b /\
   Rlength l = S (Rlength lf) /\
   (forall i:nat,
-     (i < pred (Rlength l))%nat ->
-     constant_D_eq f (open_interval (pos_Rl l i) (pos_Rl l (S i)))
-       (pos_Rl lf i)).
+    (i < pred (Rlength l))%nat ->
+    constant_D_eq f (open_interval (pos_Rl l i) (pos_Rl l (S i)))
+    (pos_Rl lf i)).
 
 Definition adapted_couple_opt (f:R -> R) (a b:R) (l lf:Rlist) :=
   adapted_couple f a b l lf /\
   (forall i:nat,
-     (i < pred (Rlength lf))%nat ->
-     pos_Rl lf i <> pos_Rl lf (S i) \/ f (pos_Rl l (S i)) <> pos_Rl lf i) /\
+    (i < pred (Rlength lf))%nat ->
+    pos_Rl lf i <> pos_Rl lf (S i) \/ f (pos_Rl l (S i)) <> pos_Rl lf i) /\
   (forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <> pos_Rl l (S i)).
 
 Definition is_subdivision (f:R -> R) (a b:R) (l:Rlist) : Type :=
@@ -136,7 +138,7 @@ Definition is_subdivision (f:R -> R) (a b:R) (l:Rlist) : Type :=
 Definition IsStepFun (f:R -> R) (a b:R) : Type :=
   sigT (fun l:Rlist => is_subdivision f a b l).
 
-(* Class of step functions *)
+(** ** Class of step functions *)
 Record StepFun (a b:R) : Type := mkStepFun
   {fe :> R -> R; pre : IsStepFun fe a b}.
 
@@ -144,2489 +146,2521 @@ Definition subdivision (a b:R) (f:StepFun a b) : Rlist := projT1 (pre f).
 
 Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist :=
   match projT2 (pre f) with
-  | existT a b => a
+    | existT a b => a
   end.
 
-Fixpoint Int_SF (l k:Rlist) {struct l} : R :=
+Boxed Fixpoint Int_SF (l k:Rlist) {struct l} : R :=
   match l with
-  | nil => 0
-  | cons a l' =>
+    | nil => 0
+    | cons a l' =>
       match k with
-      | nil => 0
-      | cons x nil => 0
-      | cons x (cons y k') => a * (y - x) + Int_SF l' (cons y k')
+        | nil => 0
+        | cons x nil => 0
+        | cons x (cons y k') => a * (y - x) + Int_SF l' (cons y k')
       end
   end.
 
-(* Integral of step functions *)
+(** ** Integral of step functions *)
 Definition RiemannInt_SF (a b:R) (f:StepFun a b) : R :=
   match Rle_dec a b with
-  | left _ => Int_SF (subdivision_val f) (subdivision f)
-  | right _ => - Int_SF (subdivision_val f) (subdivision f)
+    | left _ => Int_SF (subdivision_val f) (subdivision f)
+    | right _ => - Int_SF (subdivision_val f) (subdivision f)
   end.
 
-(********************************)
-(* Properties of step functions *)
-(********************************)
+(************************************)
+(** ** Properties of step functions *)
+(************************************)
 
 Lemma StepFun_P1 :
- forall (a b:R) (f:StepFun a b),
-   adapted_couple f a b (subdivision f) (subdivision_val f).
-intros a b f; unfold subdivision_val in |- *; case (projT2 (pre f)); intros;
- apply a0.
+  forall (a b:R) (f:StepFun a b),
+    adapted_couple f a b (subdivision f) (subdivision_val f).
+Proof. 
+  intros a b f; unfold subdivision_val in |- *; case (projT2 (pre f)); intros;
+    apply a0.
 Qed.
 
 Lemma StepFun_P2 :
- forall (a b:R) (f:R -> R) (l lf:Rlist),
-   adapted_couple f a b l lf -> adapted_couple f b a l lf.
-unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
- repeat split; try assumption.
-rewrite H2; unfold Rmin in |- *; case (Rle_dec a b); intro;
- case (Rle_dec b a); intro; try reflexivity.
-apply Rle_antisym; assumption.
-apply Rle_antisym; auto with real.
-rewrite H1; unfold Rmax in |- *; case (Rle_dec a b); intro;
- case (Rle_dec b a); intro; try reflexivity.
-apply Rle_antisym; assumption.
-apply Rle_antisym; auto with real.
+  forall (a b:R) (f:R -> R) (l lf:Rlist),
+    adapted_couple f a b l lf -> adapted_couple f b a l lf.
+Proof. 
+  unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
+    repeat split; try assumption.
+  rewrite H2; unfold Rmin in |- *; case (Rle_dec a b); intro;
+    case (Rle_dec b a); intro; try reflexivity.
+  apply Rle_antisym; assumption.
+  apply Rle_antisym; auto with real.
+  rewrite H1; unfold Rmax in |- *; case (Rle_dec a b); intro;
+    case (Rle_dec b a); intro; try reflexivity.
+  apply Rle_antisym; assumption.
+  apply Rle_antisym; auto with real.
 Qed.
 
 Lemma StepFun_P3 :
- forall a b c:R,
-   a <= b ->
-   adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil).
-intros; unfold adapted_couple in |- *; repeat split.
-unfold ordered_Rlist in |- *; intros; simpl in H0; inversion H0;
- [ simpl in |- *; assumption | elim (le_Sn_O _ H2) ].
-simpl in |- *; unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-simpl in |- *; unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-unfold constant_D_eq, open_interval in |- *; intros; simpl in H0;
- inversion H0; [ reflexivity | elim (le_Sn_O _ H3) ].
+  forall a b c:R,
+    a <= b ->
+    adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil).
+Proof. 
+  intros; unfold adapted_couple in |- *; repeat split.
+  unfold ordered_Rlist in |- *; intros; simpl in H0; inversion H0;
+    [ simpl in |- *; assumption | elim (le_Sn_O _ H2) ].
+  simpl in |- *; unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  simpl in |- *; unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold constant_D_eq, open_interval in |- *; intros; simpl in H0;
+    inversion H0; [ reflexivity | elim (le_Sn_O _ H3) ].
 Qed.
 
 Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b.
-intros; unfold IsStepFun in |- *; case (Rle_dec a b); intro.
-apply existT with (cons a (cons b nil)); unfold is_subdivision in |- *;
- apply existT with (cons c nil); apply (StepFun_P3 c r).
-apply existT with (cons b (cons a nil)); unfold is_subdivision in |- *;
- apply existT with (cons c nil); apply StepFun_P2; 
- apply StepFun_P3; auto with real.
+Proof. 
+  intros; unfold IsStepFun in |- *; case (Rle_dec a b); intro.
+  apply existT with (cons a (cons b nil)); unfold is_subdivision in |- *;
+    apply existT with (cons c nil); apply (StepFun_P3 c r).
+  apply existT with (cons b (cons a nil)); unfold is_subdivision in |- *;
+    apply existT with (cons c nil); apply StepFun_P2; 
+      apply StepFun_P3; auto with real.
 Qed.
 
 Lemma StepFun_P5 :
- forall (a b:R) (f:R -> R) (l:Rlist),
-   is_subdivision f a b l -> is_subdivision f b a l.
-unfold is_subdivision in |- *; intros; elim X; intros; exists x;
- unfold adapted_couple in p; decompose [and] p; clear p;
- unfold adapted_couple in |- *; repeat split; try assumption.
-rewrite H1; unfold Rmin in |- *; case (Rle_dec a b); intro;
- case (Rle_dec b a); intro; try reflexivity.
-apply Rle_antisym; assumption.
-apply Rle_antisym; auto with real.
-rewrite H0; unfold Rmax in |- *; case (Rle_dec a b); intro;
- case (Rle_dec b a); intro; try reflexivity.
-apply Rle_antisym; assumption.
-apply Rle_antisym; auto with real.
+  forall (a b:R) (f:R -> R) (l:Rlist),
+    is_subdivision f a b l -> is_subdivision f b a l.
+Proof. 
+  destruct 1 as (x,(H0,(H1,(H2,(H3,H4))))); exists x;
+    repeat split; try assumption.
+  rewrite H1; apply Rmin_comm.
+  rewrite H2; apply Rmax_comm.
 Qed.
 
 Lemma StepFun_P6 :
- forall (f:R -> R) (a b:R), IsStepFun f a b -> IsStepFun f b a.
-unfold IsStepFun in |- *; intros; elim X; intros; apply existT with x;
- apply StepFun_P5; assumption.
+  forall (f:R -> R) (a b:R), IsStepFun f a b -> IsStepFun f b a.
+Proof. 
+  unfold IsStepFun in |- *; intros; elim X; intros; apply existT with x;
+    apply StepFun_P5; assumption.
 Qed.
 
 Lemma StepFun_P7 :
- forall (a b r1 r2 r3:R) (f:R -> R) (l lf:Rlist),
-   a <= b ->
-   adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) ->
-   adapted_couple f r2 b (cons r2 l) lf.
-unfold adapted_couple in |- *; intros; decompose [and] H0; clear H0;
- assert (H5 : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-assert (H7 : r2 <= b).
-rewrite H5 in H2; rewrite <- H2; apply RList_P7;
- [ assumption | simpl in |- *; right; left; reflexivity ].
-repeat split.
-apply RList_P4 with r1; assumption.
-rewrite H5 in H2; unfold Rmin in |- *; case (Rle_dec r2 b); intro;
- [ reflexivity | elim n; assumption ].
-unfold Rmax in |- *; case (Rle_dec r2 b); intro;
- [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; assumption ].
-simpl in H4; simpl in |- *; apply INR_eq; apply Rplus_eq_reg_l with 1;
- do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; 
- rewrite H4; reflexivity.
-intros; unfold constant_D_eq, open_interval in |- *; intros;
- unfold constant_D_eq, open_interval in H6;
- assert (H9 : (S i < pred (Rlength (cons r1 (cons r2 l))))%nat).
-simpl in |- *; simpl in H0; apply lt_n_S; assumption.
-assert (H10 := H6 _ H9); apply H10; assumption.
+  forall (a b r1 r2 r3:R) (f:R -> R) (l lf:Rlist),
+    a <= b ->
+    adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) ->
+    adapted_couple f r2 b (cons r2 l) lf.
+Proof. 
+  unfold adapted_couple in |- *; intros; decompose [and] H0; clear H0;
+    assert (H5 : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  assert (H7 : r2 <= b).
+  rewrite H5 in H2; rewrite <- H2; apply RList_P7;
+    [ assumption | simpl in |- *; right; left; reflexivity ].
+  repeat split.
+  apply RList_P4 with r1; assumption.
+  rewrite H5 in H2; unfold Rmin in |- *; case (Rle_dec r2 b); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold Rmax in |- *; case (Rle_dec r2 b); intro;
+    [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; assumption ].
+  simpl in H4; simpl in |- *; apply INR_eq; apply Rplus_eq_reg_l with 1;
+    do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; 
+      rewrite H4; reflexivity.
+  intros; unfold constant_D_eq, open_interval in |- *; intros;
+    unfold constant_D_eq, open_interval in H6;
+      assert (H9 : (S i < pred (Rlength (cons r1 (cons r2 l))))%nat).
+  simpl in |- *; simpl in H0; apply lt_n_S; assumption.
+  assert (H10 := H6 _ H9); apply H10; assumption.
 Qed.
 
 Lemma StepFun_P8 :
- forall (f:R -> R) (l1 lf1:Rlist) (a b:R),
-   adapted_couple f a b l1 lf1 -> a = b -> Int_SF lf1 l1 = 0.
-simple induction l1.
-intros; induction  lf1 as [| r lf1 Hreclf1]; reflexivity.
-simple induction r0.
-intros; induction  lf1 as [| r1 lf1 Hreclf1].
-reflexivity.
-unfold adapted_couple in H0; decompose [and] H0; clear H0; simpl in H5;
- discriminate.
-intros; induction  lf1 as [| r3 lf1 Hreclf1].
-reflexivity.
-simpl in |- *; cut (r = r1).
-intro; rewrite H3; rewrite (H0 lf1 r b).
-ring.
-rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ].
-clear H H0 Hreclf1 r0; unfold adapted_couple in H1; decompose [and] H1;
- intros; simpl in H4; rewrite H4; unfold Rmin in |- *; 
- case (Rle_dec a b); intro; [ assumption | reflexivity ].
-unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym.
-apply (H3 0%nat); simpl in |- *; apply lt_O_Sn.
-simpl in H5; rewrite H2 in H5; rewrite H5; replace (Rmin b b) with (Rmax a b);
- [ rewrite <- H4; apply RList_P7;
-    [ assumption | simpl in |- *; right; left; reflexivity ]
- | unfold Rmin, Rmax in |- *; case (Rle_dec b b); case (Rle_dec a b); intros;
-    try assumption || reflexivity ].
+  forall (f:R -> R) (l1 lf1:Rlist) (a b:R),
+    adapted_couple f a b l1 lf1 -> a = b -> Int_SF lf1 l1 = 0.
+Proof. 
+  simple induction l1.
+  intros; induction  lf1 as [| r lf1 Hreclf1]; reflexivity.
+  simple induction r0.
+  intros; induction  lf1 as [| r1 lf1 Hreclf1].
+  reflexivity.
+  unfold adapted_couple in H0; decompose [and] H0; clear H0; simpl in H5;
+    discriminate.
+  intros; induction  lf1 as [| r3 lf1 Hreclf1].
+  reflexivity.
+  simpl in |- *; cut (r = r1).
+  intro; rewrite H3; rewrite (H0 lf1 r b).
+  ring.
+  rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ].
+  clear H H0 Hreclf1 r0; unfold adapted_couple in H1; decompose [and] H1;
+    intros; simpl in H4; rewrite H4; unfold Rmin in |- *; 
+      case (Rle_dec a b); intro; [ assumption | reflexivity ].
+  unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym.
+  apply (H3 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl in H5; rewrite H2 in H5; rewrite H5; replace (Rmin b b) with (Rmax a b);
+    [ rewrite <- H4; apply RList_P7;
+      [ assumption | simpl in |- *; right; left; reflexivity ]
+      | unfold Rmin, Rmax in |- *; case (Rle_dec b b); case (Rle_dec a b); intros;
+        try assumption || reflexivity ].
 Qed.
 
 Lemma StepFun_P9 :
- forall (a b:R) (f:R -> R) (l lf:Rlist),
-   adapted_couple f a b l lf -> a <> b -> (2 <= Rlength l)%nat.
-intros; unfold adapted_couple in H; decompose [and] H; clear H;
- induction  l as [| r l Hrecl];
- [ simpl in H4; discriminate
- | induction  l as [| r0 l Hrecl0];
-    [ simpl in H3; simpl in H2; generalize H3; generalize H2;
-       unfold Rmin, Rmax in |- *; case (Rle_dec a b); 
-       intros; elim H0; rewrite <- H5; rewrite <- H7; 
-       reflexivity
-    | simpl in |- *; do 2 apply le_n_S; apply le_O_n ] ].
+  forall (a b:R) (f:R -> R) (l lf:Rlist),
+    adapted_couple f a b l lf -> a <> b -> (2 <= Rlength l)%nat.
+Proof. 
+  intros; unfold adapted_couple in H; decompose [and] H; clear H;
+    induction  l as [| r l Hrecl];
+      [ simpl in H4; discriminate
+        | induction  l as [| r0 l Hrecl0];
+          [ simpl in H3; simpl in H2; generalize H3; generalize H2;
+            unfold Rmin, Rmax in |- *; case (Rle_dec a b); 
+              intros; elim H0; rewrite <- H5; rewrite <- H7; 
+                reflexivity
+            | simpl in |- *; do 2 apply le_n_S; apply le_O_n ] ].
 Qed.
 
 Lemma StepFun_P10 :
- forall (f:R -> R) (l lf:Rlist) (a b:R),
-   a <= b ->
-   adapted_couple f a b l lf ->
+  forall (f:R -> R) (l lf:Rlist) (a b:R),
+    a <= b ->
+    adapted_couple f a b l lf ->
     exists l' : Rlist,
-     (exists lf' : Rlist, adapted_couple_opt f a b l' lf').
-simple induction l.
-intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4;
- discriminate.
-intros; case (Req_dec a b); intro.
-exists (cons a nil); exists nil; unfold adapted_couple_opt in |- *;
- unfold adapted_couple in |- *; unfold ordered_Rlist in |- *; 
- repeat split; try (intros; simpl in H3; elim (lt_n_O _ H3)).
-simpl in |- *; rewrite <- H2; unfold Rmin in |- *; case (Rle_dec a a); intro;
- reflexivity.
-simpl in |- *; rewrite <- H2; unfold Rmax in |- *; case (Rle_dec a a); intro;
- reflexivity.
-elim (RList_P20 _ (StepFun_P9 H1 H2)); intros t1 [t2 [t3 H3]];
- induction  lf as [| r1 lf Hreclf].
-unfold adapted_couple in H1; decompose [and] H1; rewrite H3 in H7;
- simpl in H7; discriminate.
-clear Hreclf; assert (H4 : adapted_couple f t2 b r0 lf).
-rewrite H3 in H1; assert (H4 := RList_P21 _ _ H3); simpl in H4; rewrite H4;
- eapply StepFun_P7; [ apply H0 | apply H1 ].
-cut (t2 <= b).
-intro; assert (H6 := H _ _ _ H5 H4); case (Req_dec t1 t2); intro Hyp_eq.
-replace a with t2.
-apply H6.
-rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1;
- decompose [and] H1; clear H1; simpl in H9; rewrite H9; 
- unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro.
-exists (cons a (cons b nil)); exists (cons r1 nil);
- unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
- repeat split.
-unfold ordered_Rlist in |- *; intros; simpl in H8; inversion H8;
- [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
-simpl in |- *; unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-simpl in |- *; unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-intros; simpl in H8; inversion H8.
-unfold constant_D_eq, open_interval in |- *; intros; simpl in |- *;
- simpl in H9; rewrite H3 in H1; unfold adapted_couple in H1;
- decompose [and] H1; apply (H16 0%nat).
-simpl in |- *; apply lt_O_Sn.
-unfold open_interval in |- *; simpl in |- *; rewrite H7; simpl in H13;
- rewrite H13; unfold Rmin in |- *; case (Rle_dec a b); 
- intro; [ assumption | elim n; assumption ].
-elim (le_Sn_O _ H10).
-intros; simpl in H8; elim (lt_n_O _ H8).
-intros; simpl in H8; inversion H8;
- [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
-assert (Hyp_min : Rmin t2 b = t2).
-unfold Rmin in |- *; case (Rle_dec t2 b); intro;
- [ reflexivity | elim n; assumption ].
-unfold adapted_couple in H6; elim H6; clear H6; intros;
- elim (RList_P20 _ (StepFun_P9 H6 H7)); intros s1 [s2 [s3 H9]];
- induction  lf' as [| r2 lf' Hreclf'].
-unfold adapted_couple in H6; decompose [and] H6; rewrite H9 in H13;
- simpl in H13; discriminate.
-clear Hreclf'; case (Req_dec r1 r2); intro.
-case (Req_dec (f t2) r1); intro.
-exists (cons t1 (cons s2 s3)); exists (cons r1 lf'); rewrite H3 in H1;
- rewrite H9 in H6; unfold adapted_couple in H6, H1; 
- decompose [and] H1; decompose [and] H6; clear H1 H6;
- unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
- repeat split.
-unfold ordered_Rlist in |- *; intros; simpl in H1;
- induction  i as [| i Hreci].
-simpl in |- *; apply Rle_trans with s1.
-replace s1 with t2.
-apply (H12 0%nat).
-simpl in |- *; apply lt_O_Sn.
-simpl in H19; rewrite H19; symmetry  in |- *; apply Hyp_min.
-apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
-change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)) in |- *;
- apply (H16 (S i)); simpl in |- *; assumption.
-simpl in |- *; simpl in H14; rewrite H14; reflexivity.
-simpl in |- *; simpl in H18; rewrite H18; unfold Rmax in |- *;
- case (Rle_dec a b); case (Rle_dec t2 b); intros; reflexivity || elim n;
- assumption.
-simpl in |- *; simpl in H20; apply H20.
-intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
- induction  i as [| i Hreci].
-simpl in |- *; simpl in H6; case (total_order_T x t2); intro.
-elim s; intro.
-apply (H17 0%nat);
- [ simpl in |- *; apply lt_O_Sn
- | unfold open_interval in |- *; simpl in |- *; elim H6; intros; split;
-    assumption ].
-rewrite b0; assumption.
-rewrite H10; apply (H22 0%nat);
- [ simpl in |- *; apply lt_O_Sn
- | unfold open_interval in |- *; simpl in |- *; replace s1 with t2;
-    [ elim H6; intros; split; assumption
-    | simpl in H19; rewrite H19; rewrite Hyp_min; reflexivity ] ].
-simpl in |- *; simpl in H6; apply (H22 (S i));
- [ simpl in |- *; assumption
- | unfold open_interval in |- *; simpl in |- *; apply H6 ].
-intros; simpl in H1; rewrite H10;
- change
-   (pos_Rl (cons r2 lf') i <> pos_Rl (cons r2 lf') (S i) \/
-    f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r2 lf') i)
-  in |- *; rewrite <- H9; elim H8; intros; apply H6; 
- simpl in |- *; apply H1.
-intros; induction  i as [| i Hreci].
-simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
-apply (H12 0%nat); simpl in |- *; apply lt_O_Sn.
-rewrite <- Hyp_min; rewrite H6; simpl in H19; rewrite <- H19;
- apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
-elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl in |- *;
- simpl in H1; apply H1.
-exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
- rewrite H3 in H1; unfold adapted_couple in H1, H6; 
- decompose [and] H6; decompose [and] H1; clear H6 H1;
- unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
- repeat split.
-rewrite H9; unfold ordered_Rlist in |- *; intros; simpl in H1;
- induction  i as [| i Hreci].
-simpl in |- *; replace s1 with t2.
-apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
-simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
-change
-  (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
- in |- *; apply (H12 i); simpl in |- *; apply lt_S_n; 
- assumption.
-simpl in |- *; simpl in H19; apply H19.
-rewrite H9; simpl in |- *; simpl in H13; rewrite H13; unfold Rmax in |- *;
- case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
- assumption.
-rewrite H9; simpl in |- *; simpl in H15; rewrite H15; reflexivity.
-intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
- induction  i as [| i Hreci].
-simpl in |- *; rewrite H9 in H6; simpl in H6; apply (H22 0%nat).
-simpl in |- *; apply lt_O_Sn.
-unfold open_interval in |- *; simpl in |- *.
-replace t2 with s1.
-assumption.
-simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
-change (f x = pos_Rl (cons r2 lf') i) in |- *; clear Hreci; apply (H17 i).
-simpl in |- *; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
-rewrite H9 in H6; unfold open_interval in |- *; apply H6.
-intros; simpl in H1; induction  i as [| i Hreci].
-simpl in |- *; rewrite H9; right; simpl in |- *; replace s1 with t2.
-assumption.
-simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
-elim H8; intros; apply (H6 i).
-simpl in |- *; apply lt_S_n; apply H1.
-intros; rewrite H9; induction  i as [| i Hreci].
-simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
-apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
-rewrite <- Hyp_min; rewrite H6; simpl in H14; rewrite <- H14; right;
- reflexivity.
-elim H8; intros; rewrite <- H9; apply (H21 i); rewrite H9; rewrite H9 in H1;
- simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
-exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
- rewrite H3 in H1; unfold adapted_couple in H1, H6; 
- decompose [and] H6; decompose [and] H1; clear H6 H1;
- unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
- repeat split.
-rewrite H9; unfold ordered_Rlist in |- *; intros; simpl in H1;
- induction  i as [| i Hreci].
-simpl in |- *; replace s1 with t2.
-apply (H15 0%nat); simpl in |- *; apply lt_O_Sn.
-simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
-change
-  (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
- in |- *; apply (H11 i); simpl in |- *; apply lt_S_n; 
- assumption.
-simpl in |- *; simpl in H18; apply H18.
-rewrite H9; simpl in |- *; simpl in H12; rewrite H12; unfold Rmax in |- *;
- case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
- assumption.
-rewrite H9; simpl in |- *; simpl in H14; rewrite H14; reflexivity.
-intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
- induction  i as [| i Hreci].
-simpl in |- *; rewrite H9 in H6; simpl in H6; apply (H21 0%nat).
-simpl in |- *; apply lt_O_Sn.
-unfold open_interval in |- *; simpl in |- *; replace t2 with s1.
-assumption.
-simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
-change (f x = pos_Rl (cons r2 lf') i) in |- *; clear Hreci; apply (H16 i).
-simpl in |- *; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
-rewrite H9 in H6; unfold open_interval in |- *; apply H6.
-intros; simpl in H1; induction  i as [| i Hreci].
-simpl in |- *; left; assumption.
-elim H8; intros; apply (H6 i).
-simpl in |- *; apply lt_S_n; apply H1.
-intros; rewrite H9; induction  i as [| i Hreci].
-simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
-apply (H15 0%nat); simpl in |- *; apply lt_O_Sn.
-rewrite <- Hyp_min; rewrite H6; simpl in H13; rewrite <- H13; right;
- reflexivity.
-elim H8; intros; rewrite <- H9; apply (H20 i); rewrite H9; rewrite H9 in H1;
- simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
-rewrite H3 in H1; clear H4; unfold adapted_couple in H1; decompose [and] H1;
- clear H1; clear H H7 H9; cut (Rmax a b = b);
- [ intro; rewrite H in H5; rewrite <- H5; apply RList_P7;
-    [ assumption | simpl in |- *; right; left; reflexivity ]
- | unfold Rmax in |- *; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ] ].
+      (exists lf' : Rlist, adapted_couple_opt f a b l' lf').
+Proof. 
+  simple induction l.
+  intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4;
+    discriminate.
+  intros; case (Req_dec a b); intro.
+  exists (cons a nil); exists nil; unfold adapted_couple_opt in |- *;
+    unfold adapted_couple in |- *; unfold ordered_Rlist in |- *; 
+      repeat split; try (intros; simpl in H3; elim (lt_n_O _ H3)).
+  simpl in |- *; rewrite <- H2; unfold Rmin in |- *; case (Rle_dec a a); intro;
+    reflexivity.
+  simpl in |- *; rewrite <- H2; unfold Rmax in |- *; case (Rle_dec a a); intro;
+    reflexivity.
+  elim (RList_P20 _ (StepFun_P9 H1 H2)); intros t1 [t2 [t3 H3]];
+    induction  lf as [| r1 lf Hreclf].
+  unfold adapted_couple in H1; decompose [and] H1; rewrite H3 in H7;
+    simpl in H7; discriminate.
+  clear Hreclf; assert (H4 : adapted_couple f t2 b r0 lf).
+  rewrite H3 in H1; assert (H4 := RList_P21 _ _ H3); simpl in H4; rewrite H4;
+    eapply StepFun_P7; [ apply H0 | apply H1 ].
+  cut (t2 <= b).
+  intro; assert (H6 := H _ _ _ H5 H4); case (Req_dec t1 t2); intro Hyp_eq.
+  replace a with t2.
+  apply H6.
+  rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1;
+    decompose [and] H1; clear H1; simpl in H9; rewrite H9; 
+      unfold Rmin in |- *; case (Rle_dec a b); intro;
+        [ reflexivity | elim n; assumption ].
+  elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro.
+  exists (cons a (cons b nil)); exists (cons r1 nil);
+    unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+      repeat split.
+  unfold ordered_Rlist in |- *; intros; simpl in H8; inversion H8;
+    [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
+  simpl in |- *; unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  simpl in |- *; unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  intros; simpl in H8; inversion H8.
+  unfold constant_D_eq, open_interval in |- *; intros; simpl in |- *;
+    simpl in H9; rewrite H3 in H1; unfold adapted_couple in H1;
+      decompose [and] H1; apply (H16 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  unfold open_interval in |- *; simpl in |- *; rewrite H7; simpl in H13;
+    rewrite H13; unfold Rmin in |- *; case (Rle_dec a b); 
+      intro; [ assumption | elim n; assumption ].
+  elim (le_Sn_O _ H10).
+  intros; simpl in H8; elim (lt_n_O _ H8).
+  intros; simpl in H8; inversion H8;
+    [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
+  assert (Hyp_min : Rmin t2 b = t2).
+  unfold Rmin in |- *; case (Rle_dec t2 b); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold adapted_couple in H6; elim H6; clear H6; intros;
+    elim (RList_P20 _ (StepFun_P9 H6 H7)); intros s1 [s2 [s3 H9]];
+      induction  lf' as [| r2 lf' Hreclf'].
+  unfold adapted_couple in H6; decompose [and] H6; rewrite H9 in H13;
+    simpl in H13; discriminate.
+  clear Hreclf'; case (Req_dec r1 r2); intro.
+  case (Req_dec (f t2) r1); intro.
+  exists (cons t1 (cons s2 s3)); exists (cons r1 lf'); rewrite H3 in H1;
+    rewrite H9 in H6; unfold adapted_couple in H6, H1; 
+      decompose [and] H1; decompose [and] H6; clear H1 H6;
+        unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+          repeat split.
+  unfold ordered_Rlist in |- *; intros; simpl in H1;
+    induction  i as [| i Hreci].
+  simpl in |- *; apply Rle_trans with s1.
+  replace s1 with t2.
+  apply (H12 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  simpl in H19; rewrite H19; symmetry  in |- *; apply Hyp_min.
+  apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+  change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)) in |- *;
+    apply (H16 (S i)); simpl in |- *; assumption.
+  simpl in |- *; simpl in H14; rewrite H14; reflexivity.
+  simpl in |- *; simpl in H18; rewrite H18; unfold Rmax in |- *;
+    case (Rle_dec a b); case (Rle_dec t2 b); intros; reflexivity || elim n;
+      assumption.
+  simpl in |- *; simpl in H20; apply H20.
+  intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+    induction  i as [| i Hreci].
+  simpl in |- *; simpl in H6; case (total_order_T x t2); intro.
+  elim s; intro.
+  apply (H17 0%nat);
+    [ simpl in |- *; apply lt_O_Sn
+      | unfold open_interval in |- *; simpl in |- *; elim H6; intros; split;
+        assumption ].
+  rewrite b0; assumption.
+  rewrite H10; apply (H22 0%nat);
+    [ simpl in |- *; apply lt_O_Sn
+      | unfold open_interval in |- *; simpl in |- *; replace s1 with t2;
+        [ elim H6; intros; split; assumption
+          | simpl in H19; rewrite H19; rewrite Hyp_min; reflexivity ] ].
+  simpl in |- *; simpl in H6; apply (H22 (S i));
+    [ simpl in |- *; assumption
+      | unfold open_interval in |- *; simpl in |- *; apply H6 ].
+  intros; simpl in H1; rewrite H10;
+    change
+      (pos_Rl (cons r2 lf') i <> pos_Rl (cons r2 lf') (S i) \/
+        f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r2 lf') i)
+      in |- *; rewrite <- H9; elim H8; intros; apply H6; 
+        simpl in |- *; apply H1.
+  intros; induction  i as [| i Hreci].
+  simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
+  apply (H12 0%nat); simpl in |- *; apply lt_O_Sn.
+  rewrite <- Hyp_min; rewrite H6; simpl in H19; rewrite <- H19;
+    apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+  elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl in |- *;
+    simpl in H1; apply H1.
+  exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
+    rewrite H3 in H1; unfold adapted_couple in H1, H6; 
+      decompose [and] H6; decompose [and] H1; clear H6 H1;
+        unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+          repeat split.
+  rewrite H9; unfold ordered_Rlist in |- *; intros; simpl in H1;
+    induction  i as [| i Hreci].
+  simpl in |- *; replace s1 with t2.
+  apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
+  change
+    (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
+    in |- *; apply (H12 i); simpl in |- *; apply lt_S_n; 
+      assumption.
+  simpl in |- *; simpl in H19; apply H19.
+  rewrite H9; simpl in |- *; simpl in H13; rewrite H13; unfold Rmax in |- *;
+    case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
+      assumption.
+  rewrite H9; simpl in |- *; simpl in H15; rewrite H15; reflexivity.
+  intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+    induction  i as [| i Hreci].
+  simpl in |- *; rewrite H9 in H6; simpl in H6; apply (H22 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  unfold open_interval in |- *; simpl in |- *.
+  replace t2 with s1.
+  assumption.
+  simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
+  change (f x = pos_Rl (cons r2 lf') i) in |- *; clear Hreci; apply (H17 i).
+  simpl in |- *; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
+  rewrite H9 in H6; unfold open_interval in |- *; apply H6.
+  intros; simpl in H1; induction  i as [| i Hreci].
+  simpl in |- *; rewrite H9; right; simpl in |- *; replace s1 with t2.
+  assumption.
+  simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
+  elim H8; intros; apply (H6 i).
+  simpl in |- *; apply lt_S_n; apply H1.
+  intros; rewrite H9; induction  i as [| i Hreci].
+  simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
+  apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+  rewrite <- Hyp_min; rewrite H6; simpl in H14; rewrite <- H14; right;
+    reflexivity.
+  elim H8; intros; rewrite <- H9; apply (H21 i); rewrite H9; rewrite H9 in H1;
+    simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
+  exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
+    rewrite H3 in H1; unfold adapted_couple in H1, H6; 
+      decompose [and] H6; decompose [and] H1; clear H6 H1;
+        unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+          repeat split.
+  rewrite H9; unfold ordered_Rlist in |- *; intros; simpl in H1;
+    induction  i as [| i Hreci].
+  simpl in |- *; replace s1 with t2.
+  apply (H15 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
+  change
+    (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
+    in |- *; apply (H11 i); simpl in |- *; apply lt_S_n; 
+      assumption.
+  simpl in |- *; simpl in H18; apply H18.
+  rewrite H9; simpl in |- *; simpl in H12; rewrite H12; unfold Rmax in |- *;
+    case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
+      assumption.
+  rewrite H9; simpl in |- *; simpl in H14; rewrite H14; reflexivity.
+  intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+    induction  i as [| i Hreci].
+  simpl in |- *; rewrite H9 in H6; simpl in H6; apply (H21 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  unfold open_interval in |- *; simpl in |- *; replace t2 with s1.
+  assumption.
+  simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
+  change (f x = pos_Rl (cons r2 lf') i) in |- *; clear Hreci; apply (H16 i).
+  simpl in |- *; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
+  rewrite H9 in H6; unfold open_interval in |- *; apply H6.
+  intros; simpl in H1; induction  i as [| i Hreci].
+  simpl in |- *; left; assumption.
+  elim H8; intros; apply (H6 i).
+  simpl in |- *; apply lt_S_n; apply H1.
+  intros; rewrite H9; induction  i as [| i Hreci].
+  simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
+  apply (H15 0%nat); simpl in |- *; apply lt_O_Sn.
+  rewrite <- Hyp_min; rewrite H6; simpl in H13; rewrite <- H13; right;
+    reflexivity.
+  elim H8; intros; rewrite <- H9; apply (H20 i); rewrite H9; rewrite H9 in H1;
+    simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
+  rewrite H3 in H1; clear H4; unfold adapted_couple in H1; decompose [and] H1;
+    clear H1; clear H H7 H9; cut (Rmax a b = b);
+      [ intro; rewrite H in H5; rewrite <- H5; apply RList_P7;
+        [ assumption | simpl in |- *; right; left; reflexivity ]
+        | unfold Rmax in |- *; case (Rle_dec a b); intro;
+          [ reflexivity | elim n; assumption ] ].
 Qed.
 
 Lemma StepFun_P11 :
- forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) 
-   (f:R -> R),
-   a < b ->
-   adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
-   adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
-intros; unfold adapted_couple_opt in H1; elim H1; clear H1; intros;
- unfold adapted_couple in H0, H1; decompose [and] H0; 
- decompose [and] H1; clear H0 H1; assert (H12 : r = s1).
-simpl in H10; simpl in H5; rewrite H10; rewrite H5; reflexivity.
-assert (H14 := H3 0%nat (lt_O_Sn _)); simpl in H14; elim H14; intro.
-assert (H15 := H7 0%nat (lt_O_Sn _)); simpl in H15; elim H15; intro.
-rewrite <- H12 in H1; case (Rle_dec r1 s2); intro; try assumption.
-assert (H16 : s2 < r1); auto with real.
-induction  s3 as [| r0 s3 Hrecs3].
-simpl in H9; rewrite H9 in H16; cut (r1 <= Rmax a b).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H17 H16)).
-rewrite <- H4; apply RList_P7;
- [ assumption | simpl in |- *; right; left; reflexivity ].
-clear Hrecs3; induction  lf2 as [| r5 lf2 Hreclf2].
-simpl in H11; discriminate.
-clear Hreclf2; assert (H17 : r3 = r4).
-set (x := (r + s2) / 2); assert (H17 := H8 0%nat (lt_O_Sn _));
- assert (H18 := H13 0%nat (lt_O_Sn _));
- unfold constant_D_eq, open_interval in H17, H18; simpl in H17; 
- simpl in H18; rewrite <- (H17 x).
-rewrite <- (H18 x).
-reflexivity.
-rewrite <- H12; unfold x in |- *; split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite (Rplus_comm r); rewrite double;
-       apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-unfold x in |- *; split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-apply Rlt_trans with s2;
- [ apply Rmult_lt_reg_l with 2;
+  forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) 
+    (f:R -> R),
+    a < b ->
+    adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
+    adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
+Proof. 
+  intros; unfold adapted_couple_opt in H1; elim H1; clear H1; intros;
+    unfold adapted_couple in H0, H1; decompose [and] H0; 
+      decompose [and] H1; clear H0 H1; assert (H12 : r = s1).
+  simpl in H10; simpl in H5; rewrite H10; rewrite H5; reflexivity.
+  assert (H14 := H3 0%nat (lt_O_Sn _)); simpl in H14; elim H14; intro.
+  assert (H15 := H7 0%nat (lt_O_Sn _)); simpl in H15; elim H15; intro.
+  rewrite <- H12 in H1; case (Rle_dec r1 s2); intro; try assumption.
+  assert (H16 : s2 < r1); auto with real.
+  induction  s3 as [| r0 s3 Hrecs3].
+  simpl in H9; rewrite H9 in H16; cut (r1 <= Rmax a b).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H17 H16)).
+  rewrite <- H4; apply RList_P7;
+    [ assumption | simpl in |- *; right; left; reflexivity ].
+  clear Hrecs3; induction  lf2 as [| r5 lf2 Hreclf2].
+  simpl in H11; discriminate.
+  clear Hreclf2; assert (H17 : r3 = r4).
+  set (x := (r + s2) / 2); assert (H17 := H8 0%nat (lt_O_Sn _));
+    assert (H18 := H13 0%nat (lt_O_Sn _));
+      unfold constant_D_eq, open_interval in H17, H18; simpl in H17; 
+        simpl in H18; rewrite <- (H17 x).
+  rewrite <- (H18 x).
+  reflexivity.
+  rewrite <- H12; unfold x in |- *; split.
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite (Rplus_comm r); rewrite double;
+            apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  unfold x in |- *; split.
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  apply Rlt_trans with s2;
+    [ apply Rmult_lt_reg_l with 2;
+      [ prove_sup0
+        | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+          rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+            [ rewrite Rmult_1_l; rewrite (Rplus_comm r); rewrite double;
+              apply Rplus_lt_compat_l; assumption
+              | discrR ] ]
+      | assumption ].
+  assert (H18 : f s2 = r3).
+  apply (H8 0%nat);
+    [ simpl in |- *; apply lt_O_Sn
+      | unfold open_interval in |- *; simpl in |- *; split; assumption ].
+  assert (H19 : r3 = r5).
+  assert (H19 := H7 1%nat); simpl in H19;
+    assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20; 
+      intro.
+  set (x := (s2 + Rmin r1 r0) / 2); assert (H22 := H8 0%nat);
+    assert (H23 := H13 1%nat); simpl in H22; simpl in H23;
+      rewrite <- (H22 (lt_O_Sn _) x).
+  rewrite <- (H23 (lt_n_S _ _ (lt_O_Sn _)) x).
+  reflexivity.
+  unfold open_interval in |- *; simpl in |- *; unfold x in |- *; split.
+  apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-    | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
-       rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
-       [ rewrite Rmult_1_l; rewrite (Rplus_comm r); rewrite double;
-          apply Rplus_lt_compat_l; assumption
-       | discrR ] ]
- | assumption ].
-assert (H18 : f s2 = r3).
-apply (H8 0%nat);
- [ simpl in |- *; apply lt_O_Sn
- | unfold open_interval in |- *; simpl in |- *; split; assumption ].
-assert (H19 : r3 = r5).
-assert (H19 := H7 1%nat); simpl in H19;
- assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20; 
- intro.
-set (x := (s2 + Rmin r1 r0) / 2); assert (H22 := H8 0%nat);
- assert (H23 := H13 1%nat); simpl in H22; simpl in H23;
- rewrite <- (H22 (lt_O_Sn _) x).
-rewrite <- (H23 (lt_n_S _ _ (lt_O_Sn _)) x).
-reflexivity.
-unfold open_interval in |- *; simpl in |- *; unfold x in |- *; split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
-       unfold Rmin in |- *; case (Rle_dec r1 r0); intro; 
-       assumption
-    | discrR ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double;
-       apply Rlt_le_trans with (r0 + Rmin r1 r0);
-       [ do 2 rewrite <- (Rplus_comm (Rmin r1 r0)); apply Rplus_lt_compat_l;
-          assumption
-       | apply Rplus_le_compat_l; apply Rmin_r ]
-    | discrR ] ].
-unfold open_interval in |- *; simpl in |- *; unfold x in |- *; split.
-apply Rlt_trans with s2;
- [ assumption
- | apply Rmult_lt_reg_l with 2;
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
+            unfold Rmin in |- *; case (Rle_dec r1 r0); intro; 
+              assumption
+            | discrR ] ].
+  apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-    | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
-       rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
-       [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
-          unfold Rmin in |- *; case (Rle_dec r1 r0); 
-          intro; assumption
-       | discrR ] ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double;
-       apply Rlt_le_trans with (r1 + Rmin r1 r0);
-       [ do 2 rewrite <- (Rplus_comm (Rmin r1 r0)); apply Rplus_lt_compat_l;
-          assumption
-       | apply Rplus_le_compat_l; apply Rmin_l ]
-    | discrR ] ].
-elim H2; clear H2; intros; assert (H23 := H22 1%nat); simpl in H23;
- assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24; 
- assumption.
-elim H2; intros; assert (H22 := H20 0%nat); simpl in H22;
- assert (H23 := H22 (lt_O_Sn _)); elim H23; intro;
- [ elim H24; rewrite <- H17; rewrite <- H19; reflexivity
- | elim H24; rewrite <- H17; assumption ].
-elim H2; clear H2; intros; assert (H17 := H16 0%nat); simpl in H17;
- elim (H17 (lt_O_Sn _)); assumption.
-rewrite <- H0; rewrite H12; apply (H7 0%nat); simpl in |- *; apply lt_O_Sn.
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double;
+            apply Rlt_le_trans with (r0 + Rmin r1 r0);
+              [ do 2 rewrite <- (Rplus_comm (Rmin r1 r0)); apply Rplus_lt_compat_l;
+                assumption
+                | apply Rplus_le_compat_l; apply Rmin_r ]
+            | discrR ] ].
+  unfold open_interval in |- *; simpl in |- *; unfold x in |- *; split.
+  apply Rlt_trans with s2;
+    [ assumption
+      | apply Rmult_lt_reg_l with 2;
+        [ prove_sup0
+          | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+            rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+              [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
+                unfold Rmin in |- *; case (Rle_dec r1 r0); 
+                  intro; assumption
+                | discrR ] ] ].
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double;
+            apply Rlt_le_trans with (r1 + Rmin r1 r0);
+              [ do 2 rewrite <- (Rplus_comm (Rmin r1 r0)); apply Rplus_lt_compat_l;
+                assumption
+                | apply Rplus_le_compat_l; apply Rmin_l ]
+            | discrR ] ].
+  elim H2; clear H2; intros; assert (H23 := H22 1%nat); simpl in H23;
+    assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24; 
+      assumption.
+  elim H2; intros; assert (H22 := H20 0%nat); simpl in H22;
+    assert (H23 := H22 (lt_O_Sn _)); elim H23; intro;
+      [ elim H24; rewrite <- H17; rewrite <- H19; reflexivity
+        | elim H24; rewrite <- H17; assumption ].
+  elim H2; clear H2; intros; assert (H17 := H16 0%nat); simpl in H17;
+    elim (H17 (lt_O_Sn _)); assumption.
+  rewrite <- H0; rewrite H12; apply (H7 0%nat); simpl in |- *; apply lt_O_Sn.
 Qed.
 
 Lemma StepFun_P12 :
- forall (a b:R) (f:R -> R) (l lf:Rlist),
-   adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf.
-unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; intros;
- decompose [and] H; clear H; repeat split; try assumption.
-rewrite H0; unfold Rmin in |- *; case (Rle_dec a b); intro;
- case (Rle_dec b a); intro; try reflexivity.
-apply Rle_antisym; assumption.
-apply Rle_antisym; auto with real.
-rewrite H3; unfold Rmax in |- *; case (Rle_dec a b); intro;
- case (Rle_dec b a); intro; try reflexivity.
-apply Rle_antisym; assumption.
-apply Rle_antisym; auto with real.
+  forall (a b:R) (f:R -> R) (l lf:Rlist),
+    adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf.
+Proof. 
+  unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; intros;
+    decompose [and] H; clear H; repeat split; try assumption.
+  rewrite H0; unfold Rmin in |- *; case (Rle_dec a b); intro;
+    case (Rle_dec b a); intro; try reflexivity.
+  apply Rle_antisym; assumption.
+  apply Rle_antisym; auto with real.
+  rewrite H3; unfold Rmax in |- *; case (Rle_dec a b); intro;
+    case (Rle_dec b a); intro; try reflexivity.
+  apply Rle_antisym; assumption.
+  apply Rle_antisym; auto with real.
 Qed.
 
 Lemma StepFun_P13 :
- forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) 
-   (f:R -> R),
-   a <> b ->
-   adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
-   adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
-intros; case (total_order_T a b); intro.
-elim s; intro.
-eapply StepFun_P11; [ apply a0 | apply H0 | apply H1 ].
-elim H; assumption.
-eapply StepFun_P11;
- [ apply r0 | apply StepFun_P2; apply H0 | apply StepFun_P12; apply H1 ].
+  forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) 
+    (f:R -> R),
+    a <> b ->
+    adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
+    adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
+Proof. 
+  intros; case (total_order_T a b); intro.
+  elim s; intro.
+  eapply StepFun_P11; [ apply a0 | apply H0 | apply H1 ].
+  elim H; assumption.
+  eapply StepFun_P11;
+    [ apply r0 | apply StepFun_P2; apply H0 | apply StepFun_P12; apply H1 ].
 Qed.
 
 Lemma StepFun_P14 :
- forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
-   a <= b ->
-   adapted_couple f a b l1 lf1 ->
-   adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
-simple induction l1.
-intros l2 lf1 lf2 a b Hyp H H0; unfold adapted_couple in H; decompose [and] H;
- clear H H0 H2 H3 H1 H6; simpl in H4; discriminate.
-simple induction r0.
-intros; case (Req_dec a b); intro.
-unfold adapted_couple_opt in H2; elim H2; intros; rewrite (StepFun_P8 H4 H3);
- rewrite (StepFun_P8 H1 H3); reflexivity.
-assert (H4 := StepFun_P9 H1 H3); simpl in H4;
- elim (le_Sn_O _ (le_S_n _ _ H4)).
-intros; clear H; unfold adapted_couple_opt in H3; elim H3; clear H3; intros;
- case (Req_dec a b); intro.
-rewrite (StepFun_P8 H2 H4); rewrite (StepFun_P8 H H4); reflexivity.
-assert (Hyp_min : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-assert (Hyp_max : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-elim (RList_P20 _ (StepFun_P9 H H4)); intros s1 [s2 [s3 H5]]; rewrite H5 in H;
- rewrite H5; induction  lf1 as [| r3 lf1 Hreclf1].
-unfold adapted_couple in H2; decompose [and] H2;
- clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate.
-clear Hreclf1; induction  lf2 as [| r4 lf2 Hreclf2].
-unfold adapted_couple in H; decompose [and] H;
- clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate.
-clear Hreclf2; assert (H6 : r = s1).
-unfold adapted_couple in H, H2; decompose [and] H; decompose [and] H2;
- clear H H2; simpl in H13; simpl in H8; rewrite H13; 
- rewrite H8; reflexivity.
-assert (H7 : r3 = r4 \/ r = r1).
-case (Req_dec r r1); intro.
-right; assumption.
-left; cut (r1 <= s2).
-intro; unfold adapted_couple in H2, H; decompose [and] H; decompose [and] H2;
- clear H H2; set (x := (r + r1) / 2); assert (H18 := H14 0%nat);
- assert (H20 := H19 0%nat); unfold constant_D_eq, open_interval in H18, H20;
- simpl in H18; simpl in H20; rewrite <- (H18 (lt_O_Sn _) x).
-rewrite <- (H20 (lt_O_Sn _) x).
-reflexivity.
-assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; intro;
- [ idtac | elim H7; assumption ]; unfold x in |- *; 
- split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H
-    | discrR ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite <- (Rplus_comm r1); rewrite double;
-       apply Rplus_lt_compat_l; apply H
-    | discrR ] ].
-rewrite <- H6; assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21;
- intro; [ idtac | elim H7; assumption ]; unfold x in |- *; 
- split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H
-    | discrR ] ].
-apply Rlt_le_trans with r1;
- [ apply Rmult_lt_reg_l with 2;
+  forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
+    a <= b ->
+    adapted_couple f a b l1 lf1 ->
+    adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
+Proof. 
+  simple induction l1.
+  intros l2 lf1 lf2 a b Hyp H H0; unfold adapted_couple in H; decompose [and] H;
+    clear H H0 H2 H3 H1 H6; simpl in H4; discriminate.
+  simple induction r0.
+  intros; case (Req_dec a b); intro.
+  unfold adapted_couple_opt in H2; elim H2; intros; rewrite (StepFun_P8 H4 H3);
+    rewrite (StepFun_P8 H1 H3); reflexivity.
+  assert (H4 := StepFun_P9 H1 H3); simpl in H4;
+    elim (le_Sn_O _ (le_S_n _ _ H4)).
+  intros; clear H; unfold adapted_couple_opt in H3; elim H3; clear H3; intros;
+    case (Req_dec a b); intro.
+  rewrite (StepFun_P8 H2 H4); rewrite (StepFun_P8 H H4); reflexivity.
+  assert (Hyp_min : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  assert (Hyp_max : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  elim (RList_P20 _ (StepFun_P9 H H4)); intros s1 [s2 [s3 H5]]; rewrite H5 in H;
+    rewrite H5; induction  lf1 as [| r3 lf1 Hreclf1].
+  unfold adapted_couple in H2; decompose [and] H2;
+    clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate.
+  clear Hreclf1; induction  lf2 as [| r4 lf2 Hreclf2].
+  unfold adapted_couple in H; decompose [and] H;
+    clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate.
+  clear Hreclf2; assert (H6 : r = s1).
+  unfold adapted_couple in H, H2; decompose [and] H; decompose [and] H2;
+    clear H H2; simpl in H13; simpl in H8; rewrite H13; 
+      rewrite H8; reflexivity.
+  assert (H7 : r3 = r4 \/ r = r1).
+  case (Req_dec r r1); intro.
+  right; assumption.
+  left; cut (r1 <= s2).
+  intro; unfold adapted_couple in H2, H; decompose [and] H; decompose [and] H2;
+    clear H H2; set (x := (r + r1) / 2); assert (H18 := H14 0%nat);
+      assert (H20 := H19 0%nat); unfold constant_D_eq, open_interval in H18, H20;
+        simpl in H18; simpl in H20; rewrite <- (H18 (lt_O_Sn _) x).
+  rewrite <- (H20 (lt_O_Sn _) x).
+  reflexivity.
+  assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; intro;
+    [ idtac | elim H7; assumption ]; unfold x in |- *; 
+      split.
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H
+            | discrR ] ].
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite <- (Rplus_comm r1); rewrite double;
+            apply Rplus_lt_compat_l; apply H
+            | discrR ] ].
+  rewrite <- H6; assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21;
+    intro; [ idtac | elim H7; assumption ]; unfold x in |- *; 
+      split.
+  apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-    | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
-       rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
-       [ rewrite Rmult_1_l; rewrite <- (Rplus_comm r1); rewrite double;
-          apply Rplus_lt_compat_l; apply H
-       | discrR ] ]
- | assumption ].
-eapply StepFun_P13.
-apply H4.
-apply H2.
-unfold adapted_couple_opt in |- *; split.
-apply H.
-rewrite H5 in H3; apply H3.
-assert (H8 : r1 <= s2).
-eapply StepFun_P13.
-apply H4.
-apply H2.
-unfold adapted_couple_opt in |- *; split.
-apply H.
-rewrite H5 in H3; apply H3.
-elim H7; intro.
-simpl in |- *; elim H8; intro.
-replace (r4 * (s2 - s1)) with (r3 * (r1 - r) + r3 * (s2 - r1));
- [ idtac | rewrite H9; rewrite H6; ring ].
-rewrite Rplus_assoc; apply Rplus_eq_compat_l;
- change
-   (Int_SF lf1 (cons r1 r2) = Int_SF (cons r3 lf2) (cons r1 (cons s2 s3)))
-  in |- *; apply H0 with r1 b.
-unfold adapted_couple in H2; decompose [and] H2; clear H2;
- replace b with (Rmax a b).
-rewrite <- H12; apply RList_P7;
- [ assumption | simpl in |- *; right; left; reflexivity ].
-eapply StepFun_P7.
-apply H1.
-apply H2.
-unfold adapted_couple_opt in |- *; split.
-apply StepFun_P7 with a a r3.
-apply H1.
-unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H;
- clear H H2; assert (H20 : r = a).
-simpl in H13; rewrite H13; apply Hyp_min.
-unfold adapted_couple in |- *; repeat split.
-unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
-simpl in |- *; rewrite <- H20; apply (H11 0%nat).
-simpl in |- *; apply lt_O_Sn.
-induction  i as [| i Hreci0].
-simpl in |- *; assumption.
-change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)) in |- *;
- apply (H15 (S i)); simpl in |- *; apply lt_S_n; assumption.
-simpl in |- *; symmetry  in |- *; apply Hyp_min.
-rewrite <- H17; reflexivity.
-simpl in H19; simpl in |- *; rewrite H19; reflexivity.
-intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
- induction  i as [| i Hreci].
-simpl in |- *; apply (H16 0%nat).
-simpl in |- *; apply lt_O_Sn.
-simpl in H2; rewrite <- H20 in H2; unfold open_interval in |- *;
- simpl in |- *; apply H2.
-clear Hreci; induction  i as [| i Hreci].
-simpl in |- *; simpl in H2; rewrite H9; apply (H21 0%nat).
-simpl in |- *; apply lt_O_Sn.
-unfold open_interval in |- *; simpl in |- *; elim H2; intros; split.
-apply Rle_lt_trans with r1; try assumption; rewrite <- H6; apply (H11 0%nat);
- simpl in |- *; apply lt_O_Sn.
-assumption.
-clear Hreci; simpl in |- *; apply (H21 (S i)).
-simpl in |- *; apply lt_S_n; assumption.
-unfold open_interval in |- *; apply H2.
-elim H3; clear H3; intros; split.
-rewrite H9;
- change
-   (forall i:nat,
-      (i < pred (Rlength (cons r4 lf2)))%nat ->
-      pos_Rl (cons r4 lf2) i <> pos_Rl (cons r4 lf2) (S i) \/
-      f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r4 lf2) i)
-  in |- *; rewrite <- H5; apply H3.
-rewrite H5 in H11; intros; simpl in H12; induction  i as [| i Hreci].
-simpl in |- *; red in |- *; intro; rewrite H13 in H10;
- elim (Rlt_irrefl _ H10).
-clear Hreci; apply (H11 (S i)); simpl in |- *; apply H12.
-rewrite H9; rewrite H10; rewrite H6; apply Rplus_eq_compat_l; rewrite <- H10;
- apply H0 with r1 b.
-unfold adapted_couple in H2; decompose [and] H2; clear H2;
- replace b with (Rmax a b).
-rewrite <- H12; apply RList_P7;
- [ assumption | simpl in |- *; right; left; reflexivity ].
-eapply StepFun_P7.
-apply H1.
-apply H2.
-unfold adapted_couple_opt in |- *; split.
-apply StepFun_P7 with a a r3.
-apply H1.
-unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H;
- clear H H2; assert (H20 : r = a).
-simpl in H13; rewrite H13; apply Hyp_min.
-unfold adapted_couple in |- *; repeat split.
-unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
-simpl in |- *; rewrite <- H20; apply (H11 0%nat); simpl in |- *;
- apply lt_O_Sn.
-rewrite H10; apply (H15 (S i)); simpl in |- *; assumption.
-simpl in |- *; symmetry  in |- *; apply Hyp_min.
-rewrite <- H17; rewrite H10; reflexivity.
-simpl in H19; simpl in |- *; apply H19.
-intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
- induction  i as [| i Hreci].
-simpl in |- *; apply (H16 0%nat).
-simpl in |- *; apply lt_O_Sn.
-simpl in H2; rewrite <- H20 in H2; unfold open_interval in |- *;
- simpl in |- *; apply H2.
-clear Hreci; simpl in |- *; apply (H21 (S i)).
-simpl in |- *; assumption.
-rewrite <- H10; unfold open_interval in |- *; apply H2.
-elim H3; clear H3; intros; split.
-rewrite H5 in H3; intros; apply (H3 (S i)).
-simpl in |- *; replace (Rlength lf2) with (S (pred (Rlength lf2))).
-apply lt_n_S; apply H12.
-symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
- intro; rewrite <- H13 in H12; elim (lt_n_O _ H12).
-intros; simpl in H12; rewrite H10; rewrite H5 in H11; apply (H11 (S i));
- simpl in |- *; apply lt_n_S; apply H12.
-simpl in |- *; rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rmult_0_r; rewrite Rplus_0_l;
- change
-   (Int_SF lf1 (cons r1 r2) = Int_SF (cons r4 lf2) (cons s1 (cons s2 s3)))
-  in |- *; eapply H0.
-apply H1.
-2: rewrite H5 in H3; unfold adapted_couple_opt in |- *; split; assumption.
-assert (H10 : r = a).
-unfold adapted_couple in H2; decompose [and] H2; clear H2; simpl in H12;
- rewrite H12; apply Hyp_min.
-rewrite <- H9; rewrite H10; apply StepFun_P7 with a r r3;
- [ apply H1
- | pattern a at 2 in |- *; rewrite <- H10; pattern r at 2 in |- *; rewrite H9;
-    apply H2 ].
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H
+            | discrR ] ].
+  apply Rlt_le_trans with r1;
+    [ apply Rmult_lt_reg_l with 2;
+      [ prove_sup0
+        | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+          rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+            [ rewrite Rmult_1_l; rewrite <- (Rplus_comm r1); rewrite double;
+              apply Rplus_lt_compat_l; apply H
+              | discrR ] ]
+      | assumption ].
+  eapply StepFun_P13.
+  apply H4.
+  apply H2.
+  unfold adapted_couple_opt in |- *; split.
+  apply H.
+  rewrite H5 in H3; apply H3.
+  assert (H8 : r1 <= s2).
+  eapply StepFun_P13.
+  apply H4.
+  apply H2.
+  unfold adapted_couple_opt in |- *; split.
+  apply H.
+  rewrite H5 in H3; apply H3.
+  elim H7; intro.
+  simpl in |- *; elim H8; intro.
+  replace (r4 * (s2 - s1)) with (r3 * (r1 - r) + r3 * (s2 - r1));
+  [ idtac | rewrite H9; rewrite H6; ring ].
+  rewrite Rplus_assoc; apply Rplus_eq_compat_l;
+    change
+      (Int_SF lf1 (cons r1 r2) = Int_SF (cons r3 lf2) (cons r1 (cons s2 s3)))
+      in |- *; apply H0 with r1 b.
+  unfold adapted_couple in H2; decompose [and] H2; clear H2;
+    replace b with (Rmax a b).
+  rewrite <- H12; apply RList_P7;
+    [ assumption | simpl in |- *; right; left; reflexivity ].
+  eapply StepFun_P7.
+  apply H1.
+  apply H2.
+  unfold adapted_couple_opt in |- *; split.
+  apply StepFun_P7 with a a r3.
+  apply H1.
+  unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H;
+    clear H H2; assert (H20 : r = a).
+  simpl in H13; rewrite H13; apply Hyp_min.
+  unfold adapted_couple in |- *; repeat split.
+  unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
+  simpl in |- *; rewrite <- H20; apply (H11 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  induction  i as [| i Hreci0].
+  simpl in |- *; assumption.
+  change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)) in |- *;
+    apply (H15 (S i)); simpl in |- *; apply lt_S_n; assumption.
+  simpl in |- *; symmetry  in |- *; apply Hyp_min.
+  rewrite <- H17; reflexivity.
+  simpl in H19; simpl in |- *; rewrite H19; reflexivity.
+  intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+    induction  i as [| i Hreci].
+  simpl in |- *; apply (H16 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  simpl in H2; rewrite <- H20 in H2; unfold open_interval in |- *;
+    simpl in |- *; apply H2.
+  clear Hreci; induction  i as [| i Hreci].
+  simpl in |- *; simpl in H2; rewrite H9; apply (H21 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  unfold open_interval in |- *; simpl in |- *; elim H2; intros; split.
+  apply Rle_lt_trans with r1; try assumption; rewrite <- H6; apply (H11 0%nat);
+    simpl in |- *; apply lt_O_Sn.
+  assumption.
+  clear Hreci; simpl in |- *; apply (H21 (S i)).
+  simpl in |- *; apply lt_S_n; assumption.
+  unfold open_interval in |- *; apply H2.
+  elim H3; clear H3; intros; split.
+  rewrite H9;
+    change
+      (forall i:nat,
+        (i < pred (Rlength (cons r4 lf2)))%nat ->
+        pos_Rl (cons r4 lf2) i <> pos_Rl (cons r4 lf2) (S i) \/
+        f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r4 lf2) i)
+      in |- *; rewrite <- H5; apply H3.
+  rewrite H5 in H11; intros; simpl in H12; induction  i as [| i Hreci].
+  simpl in |- *; red in |- *; intro; rewrite H13 in H10;
+    elim (Rlt_irrefl _ H10).
+  clear Hreci; apply (H11 (S i)); simpl in |- *; apply H12.
+  rewrite H9; rewrite H10; rewrite H6; apply Rplus_eq_compat_l; rewrite <- H10;
+    apply H0 with r1 b.
+  unfold adapted_couple in H2; decompose [and] H2; clear H2;
+    replace b with (Rmax a b).
+  rewrite <- H12; apply RList_P7;
+    [ assumption | simpl in |- *; right; left; reflexivity ].
+  eapply StepFun_P7.
+  apply H1.
+  apply H2.
+  unfold adapted_couple_opt in |- *; split.
+  apply StepFun_P7 with a a r3.
+  apply H1.
+  unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H;
+    clear H H2; assert (H20 : r = a).
+  simpl in H13; rewrite H13; apply Hyp_min.
+  unfold adapted_couple in |- *; repeat split.
+  unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
+  simpl in |- *; rewrite <- H20; apply (H11 0%nat); simpl in |- *;
+    apply lt_O_Sn.
+  rewrite H10; apply (H15 (S i)); simpl in |- *; assumption.
+  simpl in |- *; symmetry  in |- *; apply Hyp_min.
+  rewrite <- H17; rewrite H10; reflexivity.
+  simpl in H19; simpl in |- *; apply H19.
+  intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+    induction  i as [| i Hreci].
+  simpl in |- *; apply (H16 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  simpl in H2; rewrite <- H20 in H2; unfold open_interval in |- *;
+    simpl in |- *; apply H2.
+  clear Hreci; simpl in |- *; apply (H21 (S i)).
+  simpl in |- *; assumption.
+  rewrite <- H10; unfold open_interval in |- *; apply H2.
+  elim H3; clear H3; intros; split.
+  rewrite H5 in H3; intros; apply (H3 (S i)).
+  simpl in |- *; replace (Rlength lf2) with (S (pred (Rlength lf2))).
+  apply lt_n_S; apply H12.
+  symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+    intro; rewrite <- H13 in H12; elim (lt_n_O _ H12).
+  intros; simpl in H12; rewrite H10; rewrite H5 in H11; apply (H11 (S i));
+    simpl in |- *; apply lt_n_S; apply H12.
+  simpl in |- *; rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rmult_0_r; rewrite Rplus_0_l;
+      change
+        (Int_SF lf1 (cons r1 r2) = Int_SF (cons r4 lf2) (cons s1 (cons s2 s3)))
+        in |- *; eapply H0.
+  apply H1.
+  2: rewrite H5 in H3; unfold adapted_couple_opt in |- *; split; assumption.
+  assert (H10 : r = a).
+  unfold adapted_couple in H2; decompose [and] H2; clear H2; simpl in H12;
+    rewrite H12; apply Hyp_min.
+  rewrite <- H9; rewrite H10; apply StepFun_P7 with a r r3;
+    [ apply H1
+      | pattern a at 2 in |- *; rewrite <- H10; pattern r at 2 in |- *; rewrite H9;
+        apply H2 ].
 Qed.
 
 Lemma StepFun_P15 :
- forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
-   adapted_couple f a b l1 lf1 ->
-   adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
-intros; case (Rle_dec a b); intro;
- [ apply (StepFun_P14 r H H0)
- | assert (H1 : b <= a);
-    [ auto with real
-    | eapply StepFun_P14;
-       [ apply H1 | apply StepFun_P2; apply H | apply StepFun_P12; apply H0 ] ] ].
+  forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
+    adapted_couple f a b l1 lf1 ->
+    adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
+Proof. 
+  intros; case (Rle_dec a b); intro;
+    [ apply (StepFun_P14 r H H0)
+      | assert (H1 : b <= a);
+        [ auto with real
+          | eapply StepFun_P14;
+            [ apply H1 | apply StepFun_P2; apply H | apply StepFun_P12; apply H0 ] ] ].
 Qed.
 
 Lemma StepFun_P16 :
- forall (f:R -> R) (l lf:Rlist) (a b:R),
-   adapted_couple f a b l lf ->
+  forall (f:R -> R) (l lf:Rlist) (a b:R),
+    adapted_couple f a b l lf ->
     exists l' : Rlist,
-     (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). 
-intros; case (Rle_dec a b); intro;
- [ apply (StepFun_P10 r H)
- | assert (H1 : b <= a);
-    [ auto with real
-    | assert (H2 := StepFun_P10 H1 (StepFun_P2 H)); elim H2;
-       intros l' [lf' H3]; exists l'; exists lf'; apply StepFun_P12;
-       assumption ] ].
+      (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). 
+Proof. 
+  intros; case (Rle_dec a b); intro;
+    [ apply (StepFun_P10 r H)
+      | assert (H1 : b <= a);
+        [ auto with real
+          | assert (H2 := StepFun_P10 H1 (StepFun_P2 H)); elim H2;
+            intros l' [lf' H3]; exists l'; exists lf'; apply StepFun_P12;
+              assumption ] ].
 Qed.
 
 Lemma StepFun_P17 :
- forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
-   adapted_couple f a b l1 lf1 ->
-   adapted_couple f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
-intros; elim (StepFun_P16 H); intros l' [lf' H1]; rewrite (StepFun_P15 H H1);
- rewrite (StepFun_P15 H0 H1); reflexivity.
+  forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R),
+    adapted_couple f a b l1 lf1 ->
+    adapted_couple f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
+Proof. 
+  intros; elim (StepFun_P16 H); intros l' [lf' H1]; rewrite (StepFun_P15 H H1);
+    rewrite (StepFun_P15 H0 H1); reflexivity.
 Qed.
 
 Lemma StepFun_P18 :
- forall a b c:R, RiemannInt_SF (mkStepFun (StepFun_P4 a b c)) = c * (b - a).
-intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
-replace
- (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
+  forall a b c:R, RiemannInt_SF (mkStepFun (StepFun_P4 a b c)) = c * (b - a).
+Proof. 
+  intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  replace
+  (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
     (subdivision (mkStepFun (StepFun_P4 a b c)))) with
- (Int_SF (cons c nil) (cons a (cons b nil)));
- [ simpl in |- *; ring
- | apply StepFun_P17 with (fct_cte c) a b;
-    [ apply StepFun_P3; assumption
-    | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ].
-replace
- (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
+  (Int_SF (cons c nil) (cons a (cons b nil)));
+  [ simpl in |- *; ring
+    | apply StepFun_P17 with (fct_cte c) a b;
+      [ apply StepFun_P3; assumption
+        | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ].
+  replace
+  (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
     (subdivision (mkStepFun (StepFun_P4 a b c)))) with
- (Int_SF (cons c nil) (cons b (cons a nil)));
- [ simpl in |- *; ring
- | apply StepFun_P17 with (fct_cte c) a b;
-    [ apply StepFun_P2; apply StepFun_P3; auto with real
-    | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ].
+  (Int_SF (cons c nil) (cons b (cons a nil)));
+  [ simpl in |- *; ring
+    | apply StepFun_P17 with (fct_cte c) a b;
+      [ apply StepFun_P2; apply StepFun_P3; auto with real
+        | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ].
 Qed.
 
 Lemma StepFun_P19 :
- forall (l1:Rlist) (f g:R -> R) (l:R),
-   Int_SF (FF l1 (fun x:R => f x + l * g x)) l1 =
-   Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1.
-intros; induction  l1 as [| r l1 Hrecl1];
- [ simpl in |- *; ring
- | induction  l1 as [| r0 l1 Hrecl0]; simpl in |- *;
-    [ ring | simpl in Hrecl1; rewrite Hrecl1; ring ] ].
+  forall (l1:Rlist) (f g:R -> R) (l:R),
+    Int_SF (FF l1 (fun x:R => f x + l * g x)) l1 =
+    Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1.
+Proof. 
+  intros; induction  l1 as [| r l1 Hrecl1];
+    [ simpl in |- *; ring
+      | induction  l1 as [| r0 l1 Hrecl0]; simpl in |- *;
+        [ ring | simpl in Hrecl1; rewrite Hrecl1; ring ] ].
 Qed.
 
 Lemma StepFun_P20 :
- forall (l:Rlist) (f:R -> R),
-   (0 < Rlength l)%nat -> Rlength l = S (Rlength (FF l f)).
-intros l f H; induction l;
- [ elim (lt_irrefl _ H)
- | simpl in |- *; rewrite RList_P18; rewrite RList_P14; reflexivity ].
+  forall (l:Rlist) (f:R -> R),
+    (0 < Rlength l)%nat -> Rlength l = S (Rlength (FF l f)).
+Proof. 
+  intros l f H; induction l;
+    [ elim (lt_irrefl _ H)
+      | simpl in |- *; rewrite RList_P18; rewrite RList_P14; reflexivity ].
 Qed.
 
 Lemma StepFun_P21 :
- forall (a b:R) (f:R -> R) (l:Rlist),
-   is_subdivision f a b l -> adapted_couple f a b l (FF l f).
-intros; unfold adapted_couple in |- *; unfold is_subdivision in X;
- unfold adapted_couple in X; elim X; clear X; intros; 
- decompose [and] p; clear p; repeat split; try assumption.
-apply StepFun_P20; rewrite H2; apply lt_O_Sn.
-intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5;
- unfold constant_D_eq, open_interval in |- *; intros;
- induction  l as [| r l Hrecl].
-discriminate.
-unfold FF in |- *; rewrite RList_P12.
-simpl in |- *;
- change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i))) in |- *;
- rewrite RList_P13; try assumption; rewrite (H5 x0 H6); 
- rewrite H5.
-reflexivity.
-split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; elim H6;
-       intros; apply Rlt_trans with x0; assumption
-    | discrR ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double;
-       rewrite (Rplus_comm (pos_Rl (cons r l) i)); 
-       apply Rplus_lt_compat_l; elim H6; intros; apply Rlt_trans with x0;
-       assumption
-    | discrR ] ].
-rewrite RList_P14; simpl in H3; apply H3.
+  forall (a b:R) (f:R -> R) (l:Rlist),
+    is_subdivision f a b l -> adapted_couple f a b l (FF l f).
+Proof. 
+  intros; unfold adapted_couple in |- *; unfold is_subdivision in X;
+    unfold adapted_couple in X; elim X; clear X; intros; 
+      decompose [and] p; clear p; repeat split; try assumption.
+  apply StepFun_P20; rewrite H2; apply lt_O_Sn.
+  intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5;
+    unfold constant_D_eq, open_interval in |- *; intros;
+      induction  l as [| r l Hrecl].
+  discriminate.
+  unfold FF in |- *; rewrite RList_P12.
+  simpl in |- *;
+    change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i))) in |- *;
+      rewrite RList_P13; try assumption; rewrite (H5 x0 H6); 
+        rewrite H5.
+  reflexivity.
+  split.
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; elim H6;
+            intros; apply Rlt_trans with x0; assumption
+            | discrR ] ].
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double;
+            rewrite (Rplus_comm (pos_Rl (cons r l) i)); 
+              apply Rplus_lt_compat_l; elim H6; intros; apply Rlt_trans with x0;
+                assumption
+            | discrR ] ].
+  rewrite RList_P14; simpl in H3; apply H3.
 Qed.
 
 Lemma StepFun_P22 :
- forall (a b:R) (f g:R -> R) (lf lg:Rlist),
-   a <= b ->
-   is_subdivision f a b lf ->
-   is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
-unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
- clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-assert (Hyp_max : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0;
- decompose [and] p; decompose [and] p0; clear p p0; 
- rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0;
- rewrite Hyp_max in H5; unfold adapted_couple in |- *; 
- repeat split.
-apply RList_P2; assumption.
-rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
-induction  lf as [| r lf Hreclf].
-simpl in |- *; right; symmetry  in |- *; assumption.
-assert
- (H10 :
-  In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
-elim
- (RList_P3 (cons_ORlist (cons r lf) lg)
-    (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; 
- apply H10; exists 0%nat; split;
- [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
-elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
- intros H12 _; assert (H13 := H12 H10); elim H13; intro.
-elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
- intros H11 _; assert (H14 := H11 H8); elim H14; intros; 
- elim H15; clear H15; intros; rewrite H15; rewrite <- H6;
- elim (RList_P6 (cons r lf)); intros; apply H17;
- [ assumption | apply le_O_n | assumption ].
-elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _;
- assert (H14 := H11 H8); elim H14; intros; elim H15; 
- clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); 
- intros; apply H17; [ assumption | apply le_O_n | assumption ].
-induction  lf as [| r lf Hreclf].
-simpl in |- *; right; assumption.
-assert (H8 : In a (cons_ORlist (cons r lf) lg)).
-elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
- elim (RList_P3 (cons r lf) a); intros; apply H12; 
- exists 0%nat; split;
- [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
-apply RList_P5; [ apply RList_P2; assumption | assumption ].
-rewrite Hyp_max; apply Rle_antisym.
-induction  lf as [| r lf Hreclf].
-simpl in |- *; right; assumption.
-assert
- (H8 :
-  In
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))
-    (cons_ORlist (cons r lf) lg)).
-elim
- (RList_P3 (cons_ORlist (cons r lf) lg)
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
- intros _ H10; apply H10;
- exists (pred (Rlength (cons_ORlist (cons r lf) lg))); 
- split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
-elim
- (RList_P9 (cons r lf) lg
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
- intros H10 _.
-assert (H11 := H10 H8); elim H11; intro.
-elim
- (RList_P3 (cons r lf)
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
- intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
- elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
- elim (RList_P6 (cons r lf)); intros; apply H17;
- [ assumption
- | simpl in |- *; simpl in H14; apply lt_n_Sm_le; assumption
- | simpl in |- *; apply lt_n_Sn ].
-elim
- (RList_P3 lg
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
- intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
- elim H15; clear H15; intros.
-rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))).
-apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
- rewrite <- H17 in H16; elim (lt_n_O _ H16).
-rewrite <- H0; elim (RList_P6 lg); intros; apply H18;
- [ assumption
- | rewrite H17 in H16; apply lt_n_Sm_le; assumption
- | apply lt_pred_n_n; rewrite H17; apply lt_O_Sn ].
-induction  lf as [| r lf Hreclf].
-simpl in |- *; right; symmetry  in |- *; assumption.
-assert (H8 : In b (cons_ORlist (cons r lf) lg)).
-elim (RList_P9 (cons r lf) lg b); intros; apply H10; left;
- elim (RList_P3 (cons r lf) b); intros; apply H12;
- exists (pred (Rlength (cons r lf))); split;
- [ symmetry  in |- *; assumption | simpl in |- *; apply lt_n_Sn ].
-apply RList_P7; [ apply RList_P2; assumption | assumption ].
-apply StepFun_P20; rewrite RList_P11; rewrite H2; rewrite H7; simpl in |- *;
- apply lt_O_Sn.
-intros; unfold constant_D_eq, open_interval in |- *; intros;
- cut
-  (exists l : R,
-     constant_D_eq f
-       (open_interval (pos_Rl (cons_ORlist lf lg) i)
+  forall (a b:R) (f g:R -> R) (lf lg:Rlist),
+    a <= b ->
+    is_subdivision f a b lf ->
+    is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
+Proof. 
+  unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
+    clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  assert (Hyp_max : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0;
+    decompose [and] p; decompose [and] p0; clear p p0; 
+      rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0;
+        rewrite Hyp_max in H5; unfold adapted_couple in |- *; 
+          repeat split.
+  apply RList_P2; assumption.
+  rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
+  induction  lf as [| r lf Hreclf].
+  simpl in |- *; right; symmetry  in |- *; assumption.
+  assert
+    (H10 :
+      In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
+  elim
+    (RList_P3 (cons_ORlist (cons r lf) lg)
+      (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; 
+    apply H10; exists 0%nat; split;
+      [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
+  elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
+    intros H12 _; assert (H13 := H12 H10); elim H13; intro.
+  elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
+    intros H11 _; assert (H14 := H11 H8); elim H14; intros; 
+      elim H15; clear H15; intros; rewrite H15; rewrite <- H6;
+        elim (RList_P6 (cons r lf)); intros; apply H17;
+          [ assumption | apply le_O_n | assumption ].
+  elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _;
+    assert (H14 := H11 H8); elim H14; intros; elim H15; 
+      clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); 
+        intros; apply H17; [ assumption | apply le_O_n | assumption ].
+  induction  lf as [| r lf Hreclf].
+  simpl in |- *; right; assumption.
+  assert (H8 : In a (cons_ORlist (cons r lf) lg)).
+  elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
+    elim (RList_P3 (cons r lf) a); intros; apply H12; 
+      exists 0%nat; split;
+        [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
+  apply RList_P5; [ apply RList_P2; assumption | assumption ].
+  rewrite Hyp_max; apply Rle_antisym.
+  induction  lf as [| r lf Hreclf].
+  simpl in |- *; right; assumption.
+  assert
+    (H8 :
+      In
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))
+      (cons_ORlist (cons r lf) lg)).
+  elim
+    (RList_P3 (cons_ORlist (cons r lf) lg)
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+    intros _ H10; apply H10;
+      exists (pred (Rlength (cons_ORlist (cons r lf) lg))); 
+        split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
+  elim
+    (RList_P9 (cons r lf) lg
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+    intros H10 _.
+  assert (H11 := H10 H8); elim H11; intro.
+  elim
+    (RList_P3 (cons r lf)
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+    intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+      elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
+        elim (RList_P6 (cons r lf)); intros; apply H17;
+          [ assumption
+            | simpl in |- *; simpl in H14; apply lt_n_Sm_le; assumption
+            | simpl in |- *; apply lt_n_Sn ].
+  elim
+    (RList_P3 lg
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+    intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+      elim H15; clear H15; intros.
+  rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))).
+  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H17 in H16; elim (lt_n_O _ H16).
+  rewrite <- H0; elim (RList_P6 lg); intros; apply H18;
+    [ assumption
+      | rewrite H17 in H16; apply lt_n_Sm_le; assumption
+      | apply lt_pred_n_n; rewrite H17; apply lt_O_Sn ].
+  induction  lf as [| r lf Hreclf].
+  simpl in |- *; right; symmetry  in |- *; assumption.
+  assert (H8 : In b (cons_ORlist (cons r lf) lg)).
+  elim (RList_P9 (cons r lf) lg b); intros; apply H10; left;
+    elim (RList_P3 (cons r lf) b); intros; apply H12;
+      exists (pred (Rlength (cons r lf))); split;
+        [ symmetry  in |- *; assumption | simpl in |- *; apply lt_n_Sn ].
+  apply RList_P7; [ apply RList_P2; assumption | assumption ].
+  apply StepFun_P20; rewrite RList_P11; rewrite H2; rewrite H7; simpl in |- *;
+    apply lt_O_Sn.
+  intros; unfold constant_D_eq, open_interval in |- *; intros;
+    cut
+      (exists l : R,
+        constant_D_eq f
+        (open_interval (pos_Rl (cons_ORlist lf lg) i)
           (pos_Rl (cons_ORlist lf lg) (S i))) l).
-intros; elim H11; clear H11; intros; assert (H12 := H11);
- assert
-  (Hyp_cons :
-    exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)).
-apply RList_P19; red in |- *; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
-elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons;
- unfold FF in |- *; rewrite RList_P12.
-change (f x = f (pos_Rl (mid_Rlist (cons r r0) r) (S i))) in |- *;
- rewrite <- Hyp_cons; rewrite RList_P13.
-assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro.
-unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10);
- assert
-  (H15 :
-   pos_Rl (cons_ORlist lf lg) i <
-   (pos_Rl (cons_ORlist lf lg) i + pos_Rl (cons_ORlist lf lg) (S i)) / 2 <
-   pos_Rl (cons_ORlist lf lg) (S i)).
-split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double;
-       rewrite (Rplus_comm (pos_Rl (cons_ORlist lf lg) i));
-       apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-rewrite (H11 _ H15); reflexivity.
-elim H10; intros; rewrite H14 in H15;
- elim (Rlt_irrefl _ (Rlt_trans _ _ _ H16 H15)).
-apply H8.
-rewrite RList_P14; rewrite Hyp_cons in H8; simpl in H8; apply H8.
-assert (H11 : a < b).
-apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i).
-rewrite <- H6; rewrite <- (RList_P15 lf lg).
-elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
-apply RList_P2; assumption.
-apply le_O_n.
-apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
- [ assumption
- | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
-    rewrite <- H13 in H8; elim (lt_n_O _ H8) ].
-assumption.
-assumption.
-rewrite H1; assumption.
-apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
-elim H10; intros; apply Rlt_trans with x; assumption.
-rewrite <- H5; rewrite <- (RList_P16 lf lg); try assumption.
-elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
-apply RList_P2; assumption.
-apply lt_n_Sm_le; apply lt_n_S; assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H8;
- elim (lt_n_O _ H8).
-rewrite H0; assumption.
-set
- (I :=
-  fun j:nat =>
-    pos_Rl lf j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lf)%nat);
- assert (H12 : Nbound I).
-unfold Nbound in |- *; exists (Rlength lf); intros; unfold I in H12; elim H12;
- intros; apply lt_le_weak; assumption.
-assert (H13 :  exists n : nat, I n).
-exists 0%nat; unfold I in |- *; split.
-apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0).
-right; symmetry  in |- *.
-apply RList_P15; try assumption; rewrite H1; assumption.
-elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13.
-apply RList_P2; assumption.
-apply le_O_n.
-apply lt_trans with (pred (Rlength (cons_ORlist lf lg))).
-assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H15 in H8;
- elim (lt_n_O _ H8).
-apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H5;
- rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11).
-assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
- exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *; 
- intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (Rlength lf))%nat).
-elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
- apply lt_S_n; replace (S (pred (Rlength lf))) with (Rlength lf).
-inversion H18.
-2: apply lt_n_S; assumption.
-cut (x0 = pred (Rlength lf)).
-intro; rewrite H19 in H14; rewrite H5 in H14;
- cut (pos_Rl (cons_ORlist lf lg) i < b).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)).
-apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
-elim H10; intros; apply Rlt_trans with x; assumption.
-rewrite <- H5;
- apply Rle_trans with
-  (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))).
-elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21.
-apply RList_P2; assumption.
-apply lt_n_Sm_le; apply lt_n_S; assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H23 in H8;
- elim (lt_n_O _ H8).
-right; apply RList_P16; try assumption; rewrite H0; assumption.
-rewrite <- H20; reflexivity.
-apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
- rewrite <- H19 in H18; elim (lt_n_O _ H18).
-assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
- rewrite (H18 x1).
-reflexivity.
-elim H15; clear H15; intros; elim H14; clear H14; intros; unfold I in H14;
- elim H14; clear H14; intros; split.
-apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption.
-apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption.
-assert (H22 : (S x0 < Rlength lf)%nat).
-replace (Rlength lf) with (S (pred (Rlength lf)));
- [ apply lt_n_S; assumption
- | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
-    intro; rewrite <- H22 in H21; elim (lt_n_O _ H21) ].
-elim (Rle_dec (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
-assert (H23 : (S x0 <= x0)%nat).
-apply H20; unfold I in |- *; split; assumption.
-elim (le_Sn_n _ H23).
-assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lf (S x0)).
-auto with real.
-clear b0; apply RList_P17; try assumption.
-apply RList_P2; assumption.
-elim (RList_P9 lf lg (pos_Rl lf (S x0))); intros; apply H25; left;
- elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27; 
- exists (S x0); split; [ reflexivity | apply H22 ].
+  intros; elim H11; clear H11; intros; assert (H12 := H11);
+    assert
+      (Hyp_cons :
+        exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)).
+  apply RList_P19; red in |- *; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
+  elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons;
+    unfold FF in |- *; rewrite RList_P12.
+  change (f x = f (pos_Rl (mid_Rlist (cons r r0) r) (S i))) in |- *;
+    rewrite <- Hyp_cons; rewrite RList_P13.
+  assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro.
+  unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10);
+    assert
+      (H15 :
+        pos_Rl (cons_ORlist lf lg) i <
+        (pos_Rl (cons_ORlist lf lg) i + pos_Rl (cons_ORlist lf lg) (S i)) / 2 <
+        pos_Rl (cons_ORlist lf lg) (S i)).
+  split.
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double;
+            rewrite (Rplus_comm (pos_Rl (cons_ORlist lf lg) i));
+              apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  rewrite (H11 _ H15); reflexivity.
+  elim H10; intros; rewrite H14 in H15;
+    elim (Rlt_irrefl _ (Rlt_trans _ _ _ H16 H15)).
+  apply H8.
+  rewrite RList_P14; rewrite Hyp_cons in H8; simpl in H8; apply H8.
+  assert (H11 : a < b).
+  apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i).
+  rewrite <- H6; rewrite <- (RList_P15 lf lg).
+  elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
+  apply RList_P2; assumption.
+  apply le_O_n.
+  apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
+    [ assumption
+      | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+        rewrite <- H13 in H8; elim (lt_n_O _ H8) ].
+  assumption.
+  assumption.
+  rewrite H1; assumption.
+  apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
+  elim H10; intros; apply Rlt_trans with x; assumption.
+  rewrite <- H5; rewrite <- (RList_P16 lf lg); try assumption.
+  elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
+  apply RList_P2; assumption.
+  apply lt_n_Sm_le; apply lt_n_S; assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H8;
+    elim (lt_n_O _ H8).
+  rewrite H0; assumption.
+  set
+    (I :=
+      fun j:nat =>
+        pos_Rl lf j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lf)%nat);
+    assert (H12 : Nbound I).
+  unfold Nbound in |- *; exists (Rlength lf); intros; unfold I in H12; elim H12;
+    intros; apply lt_le_weak; assumption.
+  assert (H13 :  exists n : nat, I n).
+  exists 0%nat; unfold I in |- *; split.
+  apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0).
+  right; symmetry  in |- *.
+  apply RList_P15; try assumption; rewrite H1; assumption.
+  elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13.
+  apply RList_P2; assumption.
+  apply le_O_n.
+  apply lt_trans with (pred (Rlength (cons_ORlist lf lg))).
+  assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H15 in H8;
+    elim (lt_n_O _ H8).
+  apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H5;
+    rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11).
+  assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
+    exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *; 
+      intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (Rlength lf))%nat).
+  elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
+    apply lt_S_n; replace (S (pred (Rlength lf))) with (Rlength lf).
+  inversion H18.
+  2: apply lt_n_S; assumption.
+  cut (x0 = pred (Rlength lf)).
+  intro; rewrite H19 in H14; rewrite H5 in H14;
+    cut (pos_Rl (cons_ORlist lf lg) i < b).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)).
+  apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
+  elim H10; intros; apply Rlt_trans with x; assumption.
+  rewrite <- H5;
+    apply Rle_trans with
+      (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))).
+  elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21.
+  apply RList_P2; assumption.
+  apply lt_n_Sm_le; apply lt_n_S; assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H23 in H8;
+    elim (lt_n_O _ H8).
+  right; apply RList_P16; try assumption; rewrite H0; assumption.
+  rewrite <- H20; reflexivity.
+  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H19 in H18; elim (lt_n_O _ H18).
+  assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
+    rewrite (H18 x1).
+  reflexivity.
+  elim H15; clear H15; intros; elim H14; clear H14; intros; unfold I in H14;
+    elim H14; clear H14; intros; split.
+  apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption.
+  apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption.
+  assert (H22 : (S x0 < Rlength lf)%nat).
+  replace (Rlength lf) with (S (pred (Rlength lf)));
+  [ apply lt_n_S; assumption
+    | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+      intro; rewrite <- H22 in H21; elim (lt_n_O _ H21) ].
+  elim (Rle_dec (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
+  assert (H23 : (S x0 <= x0)%nat).
+  apply H20; unfold I in |- *; split; assumption.
+  elim (le_Sn_n _ H23).
+  assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lf (S x0)).
+  auto with real.
+  clear b0; apply RList_P17; try assumption.
+  apply RList_P2; assumption.
+  elim (RList_P9 lf lg (pos_Rl lf (S x0))); intros; apply H25; left;
+    elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27; 
+      exists (S x0); split; [ reflexivity | apply H22 ].
 Qed.
 
 Lemma StepFun_P23 :
- forall (a b:R) (f g:R -> R) (lf lg:Rlist),
-   is_subdivision f a b lf ->
-   is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
-intros; case (Rle_dec a b); intro;
- [ apply StepFun_P22 with g; assumption
- | apply StepFun_P5; apply StepFun_P22 with g;
-    [ auto with real
-    | apply StepFun_P5; assumption
-    | apply StepFun_P5; assumption ] ].
+  forall (a b:R) (f g:R -> R) (lf lg:Rlist),
+    is_subdivision f a b lf ->
+    is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
+Proof. 
+  intros; case (Rle_dec a b); intro;
+    [ apply StepFun_P22 with g; assumption
+      | apply StepFun_P5; apply StepFun_P22 with g;
+        [ auto with real
+          | apply StepFun_P5; assumption
+          | apply StepFun_P5; assumption ] ].
 Qed.
 
 Lemma StepFun_P24 :
- forall (a b:R) (f g:R -> R) (lf lg:Rlist),
-   a <= b ->
-   is_subdivision f a b lf ->
-   is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
-unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
- clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-assert (Hyp_max : Rmax a b = b).
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0;
- decompose [and] p; decompose [and] p0; clear p p0; 
- rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0;
- rewrite Hyp_max in H5; unfold adapted_couple in |- *; 
- repeat split.
-apply RList_P2; assumption.
-rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
-induction  lf as [| r lf Hreclf].
-simpl in |- *; right; symmetry  in |- *; assumption.
-assert
- (H10 :
-  In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
-elim
- (RList_P3 (cons_ORlist (cons r lf) lg)
-    (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; 
- apply H10; exists 0%nat; split;
- [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
-elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
- intros H12 _; assert (H13 := H12 H10); elim H13; intro.
-elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
- intros H11 _; assert (H14 := H11 H8); elim H14; intros; 
- elim H15; clear H15; intros; rewrite H15; rewrite <- H6;
- elim (RList_P6 (cons r lf)); intros; apply H17;
- [ assumption | apply le_O_n | assumption ].
-elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _;
- assert (H14 := H11 H8); elim H14; intros; elim H15; 
- clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); 
- intros; apply H17; [ assumption | apply le_O_n | assumption ].
-induction  lf as [| r lf Hreclf].
-simpl in |- *; right; assumption.
-assert (H8 : In a (cons_ORlist (cons r lf) lg)).
-elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
- elim (RList_P3 (cons r lf) a); intros; apply H12; 
- exists 0%nat; split;
- [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
-apply RList_P5; [ apply RList_P2; assumption | assumption ].
-rewrite Hyp_max; apply Rle_antisym.
-induction  lf as [| r lf Hreclf].
-simpl in |- *; right; assumption.
-assert
- (H8 :
-  In
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))
-    (cons_ORlist (cons r lf) lg)).
-elim
- (RList_P3 (cons_ORlist (cons r lf) lg)
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
- intros _ H10; apply H10;
- exists (pred (Rlength (cons_ORlist (cons r lf) lg))); 
- split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
-elim
- (RList_P9 (cons r lf) lg
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
- intros H10 _; assert (H11 := H10 H8); elim H11; intro.
-elim
- (RList_P3 (cons r lf)
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
- intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
- elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
- elim (RList_P6 (cons r lf)); intros; apply H17;
- [ assumption
- | simpl in |- *; simpl in H14; apply lt_n_Sm_le; assumption
- | simpl in |- *; apply lt_n_Sn ].
-elim
- (RList_P3 lg
-    (pos_Rl (cons_ORlist (cons r lf) lg)
-       (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
- intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
- elim H15; clear H15; intros; rewrite H15;
- assert (H17 : Rlength lg = S (pred (Rlength lg))).
-apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
- rewrite <- H17 in H16; elim (lt_n_O _ H16).
-rewrite <- H0; elim (RList_P6 lg); intros; apply H18;
- [ assumption
- | rewrite H17 in H16; apply lt_n_Sm_le; assumption
- | apply lt_pred_n_n; rewrite H17; apply lt_O_Sn ].
-induction  lf as [| r lf Hreclf].
-simpl in |- *; right; symmetry  in |- *; assumption.
-assert (H8 : In b (cons_ORlist (cons r lf) lg)).
-elim (RList_P9 (cons r lf) lg b); intros; apply H10; left;
- elim (RList_P3 (cons r lf) b); intros; apply H12;
- exists (pred (Rlength (cons r lf))); split;
- [ symmetry  in |- *; assumption | simpl in |- *; apply lt_n_Sn ].
-apply RList_P7; [ apply RList_P2; assumption | assumption ].
-apply StepFun_P20; rewrite RList_P11; rewrite H7; rewrite H2; simpl in |- *;
- apply lt_O_Sn.
-unfold constant_D_eq, open_interval in |- *; intros;
- cut
-  (exists l : R,
-     constant_D_eq g
-       (open_interval (pos_Rl (cons_ORlist lf lg) i)
+  forall (a b:R) (f g:R -> R) (lf lg:Rlist),
+    a <= b ->
+    is_subdivision f a b lf ->
+    is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
+Proof. 
+  unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
+    clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  assert (Hyp_max : Rmax a b = b).
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0;
+    decompose [and] p; decompose [and] p0; clear p p0; 
+      rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0;
+        rewrite Hyp_max in H5; unfold adapted_couple in |- *; 
+          repeat split.
+  apply RList_P2; assumption.
+  rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
+  induction  lf as [| r lf Hreclf].
+  simpl in |- *; right; symmetry  in |- *; assumption.
+  assert
+    (H10 :
+      In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
+  elim
+    (RList_P3 (cons_ORlist (cons r lf) lg)
+      (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; 
+    apply H10; exists 0%nat; split;
+      [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
+  elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
+    intros H12 _; assert (H13 := H12 H10); elim H13; intro.
+  elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
+    intros H11 _; assert (H14 := H11 H8); elim H14; intros; 
+      elim H15; clear H15; intros; rewrite H15; rewrite <- H6;
+        elim (RList_P6 (cons r lf)); intros; apply H17;
+          [ assumption | apply le_O_n | assumption ].
+  elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _;
+    assert (H14 := H11 H8); elim H14; intros; elim H15; 
+      clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); 
+        intros; apply H17; [ assumption | apply le_O_n | assumption ].
+  induction  lf as [| r lf Hreclf].
+  simpl in |- *; right; assumption.
+  assert (H8 : In a (cons_ORlist (cons r lf) lg)).
+  elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
+    elim (RList_P3 (cons r lf) a); intros; apply H12; 
+      exists 0%nat; split;
+        [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
+  apply RList_P5; [ apply RList_P2; assumption | assumption ].
+  rewrite Hyp_max; apply Rle_antisym.
+  induction  lf as [| r lf Hreclf].
+  simpl in |- *; right; assumption.
+  assert
+    (H8 :
+      In
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))
+      (cons_ORlist (cons r lf) lg)).
+  elim
+    (RList_P3 (cons_ORlist (cons r lf) lg)
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+    intros _ H10; apply H10;
+      exists (pred (Rlength (cons_ORlist (cons r lf) lg))); 
+        split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
+  elim
+    (RList_P9 (cons r lf) lg
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+    intros H10 _; assert (H11 := H10 H8); elim H11; intro.
+  elim
+    (RList_P3 (cons r lf)
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+    intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+      elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
+        elim (RList_P6 (cons r lf)); intros; apply H17;
+          [ assumption
+            | simpl in |- *; simpl in H14; apply lt_n_Sm_le; assumption
+            | simpl in |- *; apply lt_n_Sn ].
+  elim
+    (RList_P3 lg
+      (pos_Rl (cons_ORlist (cons r lf) lg)
+        (pred (Rlength (cons_ORlist (cons r lf) lg))))); 
+    intros H13 _; assert (H14 := H13 H12); elim H14; intros; 
+      elim H15; clear H15; intros; rewrite H15;
+        assert (H17 : Rlength lg = S (pred (Rlength lg))).
+  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H17 in H16; elim (lt_n_O _ H16).
+  rewrite <- H0; elim (RList_P6 lg); intros; apply H18;
+    [ assumption
+      | rewrite H17 in H16; apply lt_n_Sm_le; assumption
+      | apply lt_pred_n_n; rewrite H17; apply lt_O_Sn ].
+  induction  lf as [| r lf Hreclf].
+  simpl in |- *; right; symmetry  in |- *; assumption.
+  assert (H8 : In b (cons_ORlist (cons r lf) lg)).
+  elim (RList_P9 (cons r lf) lg b); intros; apply H10; left;
+    elim (RList_P3 (cons r lf) b); intros; apply H12;
+      exists (pred (Rlength (cons r lf))); split;
+        [ symmetry  in |- *; assumption | simpl in |- *; apply lt_n_Sn ].
+  apply RList_P7; [ apply RList_P2; assumption | assumption ].
+  apply StepFun_P20; rewrite RList_P11; rewrite H7; rewrite H2; simpl in |- *;
+    apply lt_O_Sn.
+  unfold constant_D_eq, open_interval in |- *; intros;
+    cut
+      (exists l : R,
+        constant_D_eq g
+        (open_interval (pos_Rl (cons_ORlist lf lg) i)
           (pos_Rl (cons_ORlist lf lg) (S i))) l).
-intros; elim H11; clear H11; intros; assert (H12 := H11);
- assert
-  (Hyp_cons :
-    exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)).
-apply RList_P19; red in |- *; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
-elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons;
- unfold FF in |- *; rewrite RList_P12.
-change (g x = g (pos_Rl (mid_Rlist (cons r r0) r) (S i))) in |- *;
- rewrite <- Hyp_cons; rewrite RList_P13.
-assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro.
-unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10);
- assert
-  (H15 :
-   pos_Rl (cons_ORlist lf lg) i <
-   (pos_Rl (cons_ORlist lf lg) i + pos_Rl (cons_ORlist lf lg) (S i)) / 2 <
-   pos_Rl (cons_ORlist lf lg) (S i)).
-split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double;
-       rewrite (Rplus_comm (pos_Rl (cons_ORlist lf lg) i));
-       apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-rewrite (H11 _ H15); reflexivity.
-elim H10; intros; rewrite H14 in H15;
- elim (Rlt_irrefl _ (Rlt_trans _ _ _ H16 H15)).
-apply H8.
-rewrite RList_P14; rewrite Hyp_cons in H8; simpl in H8; apply H8.
-assert (H11 : a < b).
-apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i).
-rewrite <- H6; rewrite <- (RList_P15 lf lg); try assumption.
-elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
-apply RList_P2; assumption.
-apply le_O_n.
-apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
- [ assumption
- | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
-    rewrite <- H13 in H8; elim (lt_n_O _ H8) ].
-rewrite H1; assumption.
-apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
-elim H10; intros; apply Rlt_trans with x; assumption.
-rewrite <- H5; rewrite <- (RList_P16 lf lg); try assumption.
-elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
-apply RList_P2; assumption.
-apply lt_n_Sm_le; apply lt_n_S; assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H8;
- elim (lt_n_O _ H8).
-rewrite H0; assumption.
-set
- (I :=
-  fun j:nat =>
-    pos_Rl lg j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lg)%nat);
- assert (H12 : Nbound I).
-unfold Nbound in |- *; exists (Rlength lg); intros; unfold I in H12; elim H12;
- intros; apply lt_le_weak; assumption.
-assert (H13 :  exists n : nat, I n).
-exists 0%nat; unfold I in |- *; split.
-apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0).
-right; symmetry  in |- *; rewrite H1; rewrite <- H6; apply RList_P15;
- try assumption; rewrite H1; assumption.
-elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13;
- [ apply RList_P2; assumption
- | apply le_O_n
- | apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
+  intros; elim H11; clear H11; intros; assert (H12 := H11);
+    assert
+      (Hyp_cons :
+        exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)).
+  apply RList_P19; red in |- *; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
+  elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons;
+    unfold FF in |- *; rewrite RList_P12.
+  change (g x = g (pos_Rl (mid_Rlist (cons r r0) r) (S i))) in |- *;
+    rewrite <- Hyp_cons; rewrite RList_P13.
+  assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro.
+  unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10);
+    assert
+      (H15 :
+        pos_Rl (cons_ORlist lf lg) i <
+        (pos_Rl (cons_ORlist lf lg) i + pos_Rl (cons_ORlist lf lg) (S i)) / 2 <
+        pos_Rl (cons_ORlist lf lg) (S i)).
+  split.
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double;
+            rewrite (Rplus_comm (pos_Rl (cons_ORlist lf lg) i));
+              apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  rewrite (H11 _ H15); reflexivity.
+  elim H10; intros; rewrite H14 in H15;
+    elim (Rlt_irrefl _ (Rlt_trans _ _ _ H16 H15)).
+  apply H8.
+  rewrite RList_P14; rewrite Hyp_cons in H8; simpl in H8; apply H8.
+  assert (H11 : a < b).
+  apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i).
+  rewrite <- H6; rewrite <- (RList_P15 lf lg); try assumption.
+  elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
+  apply RList_P2; assumption.
+  apply le_O_n.
+  apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
     [ assumption
-    | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
-       rewrite <- H15 in H8; elim (lt_n_O _ H8) ] ].
-apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H0;
- rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11).
-assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
- exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *; 
- intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (Rlength lg))%nat).
-elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
- apply lt_S_n; replace (S (pred (Rlength lg))) with (Rlength lg).
-inversion H18.
-2: apply lt_n_S; assumption.
-cut (x0 = pred (Rlength lg)).
-intro; rewrite H19 in H14; rewrite H0 in H14;
- cut (pos_Rl (cons_ORlist lf lg) i < b).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)).
-apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
-elim H10; intros; apply Rlt_trans with x; assumption.
-rewrite <- H0;
- apply Rle_trans with
-  (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))).
-elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21.
-apply RList_P2; assumption.
-apply lt_n_Sm_le; apply lt_n_S; assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H23 in H8;
- elim (lt_n_O _ H8).
-right; rewrite H0; rewrite <- H5; apply RList_P16; try assumption.
-rewrite H0; assumption.
-rewrite <- H20; reflexivity.
-apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
- rewrite <- H19 in H18; elim (lt_n_O _ H18).
-assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
- rewrite (H18 x1).
-reflexivity.
-elim H15; clear H15; intros; elim H14; clear H14; intros; unfold I in H14;
- elim H14; clear H14; intros; split.
-apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption.
-apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption.
-assert (H22 : (S x0 < Rlength lg)%nat).
-replace (Rlength lg) with (S (pred (Rlength lg))).
-apply lt_n_S; assumption.
-symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
- intro; rewrite <- H22 in H21; elim (lt_n_O _ H21).
-elim (Rle_dec (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
-assert (H23 : (S x0 <= x0)%nat);
- [ apply H20; unfold I in |- *; split; assumption | elim (le_Sn_n _ H23) ].
-assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lg (S x0)).
-auto with real.
-clear b0; apply RList_P17; try assumption;
- [ apply RList_P2; assumption
- | elim (RList_P9 lf lg (pos_Rl lg (S x0))); intros; apply H25; right;
-    elim (RList_P3 lg (pos_Rl lg (S x0))); intros; 
-    apply H27; exists (S x0); split; [ reflexivity | apply H22 ] ].
+      | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+        rewrite <- H13 in H8; elim (lt_n_O _ H8) ].
+  rewrite H1; assumption.
+  apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
+  elim H10; intros; apply Rlt_trans with x; assumption.
+  rewrite <- H5; rewrite <- (RList_P16 lf lg); try assumption.
+  elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
+  apply RList_P2; assumption.
+  apply lt_n_Sm_le; apply lt_n_S; assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H8;
+    elim (lt_n_O _ H8).
+  rewrite H0; assumption.
+  set
+    (I :=
+      fun j:nat =>
+        pos_Rl lg j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lg)%nat);
+    assert (H12 : Nbound I).
+  unfold Nbound in |- *; exists (Rlength lg); intros; unfold I in H12; elim H12;
+    intros; apply lt_le_weak; assumption.
+  assert (H13 :  exists n : nat, I n).
+  exists 0%nat; unfold I in |- *; split.
+  apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0).
+  right; symmetry  in |- *; rewrite H1; rewrite <- H6; apply RList_P15;
+    try assumption; rewrite H1; assumption.
+  elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13;
+    [ apply RList_P2; assumption
+      | apply le_O_n
+      | apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
+        [ assumption
+          | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+            rewrite <- H15 in H8; elim (lt_n_O _ H8) ] ].
+  apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H0;
+    rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11).
+  assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
+    exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *; 
+      intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (Rlength lg))%nat).
+  elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
+    apply lt_S_n; replace (S (pred (Rlength lg))) with (Rlength lg).
+  inversion H18.
+  2: apply lt_n_S; assumption.
+  cut (x0 = pred (Rlength lg)).
+  intro; rewrite H19 in H14; rewrite H0 in H14;
+    cut (pos_Rl (cons_ORlist lf lg) i < b).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)).
+  apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
+  elim H10; intros; apply Rlt_trans with x; assumption.
+  rewrite <- H0;
+    apply Rle_trans with
+      (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))).
+  elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21.
+  apply RList_P2; assumption.
+  apply lt_n_Sm_le; apply lt_n_S; assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H23 in H8;
+    elim (lt_n_O _ H8).
+  right; rewrite H0; rewrite <- H5; apply RList_P16; try assumption.
+  rewrite H0; assumption.
+  rewrite <- H20; reflexivity.
+  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H19 in H18; elim (lt_n_O _ H18).
+  assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
+    rewrite (H18 x1).
+  reflexivity.
+  elim H15; clear H15; intros; elim H14; clear H14; intros; unfold I in H14;
+    elim H14; clear H14; intros; split.
+  apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption.
+  apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption.
+  assert (H22 : (S x0 < Rlength lg)%nat).
+  replace (Rlength lg) with (S (pred (Rlength lg))).
+  apply lt_n_S; assumption.
+  symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+    intro; rewrite <- H22 in H21; elim (lt_n_O _ H21).
+  elim (Rle_dec (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
+  assert (H23 : (S x0 <= x0)%nat);
+    [ apply H20; unfold I in |- *; split; assumption | elim (le_Sn_n _ H23) ].
+  assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lg (S x0)).
+  auto with real.
+  clear b0; apply RList_P17; try assumption;
+    [ apply RList_P2; assumption
+      | elim (RList_P9 lf lg (pos_Rl lg (S x0))); intros; apply H25; right;
+        elim (RList_P3 lg (pos_Rl lg (S x0))); intros; 
+          apply H27; exists (S x0); split; [ reflexivity | apply H22 ] ].
 Qed.
 
 Lemma StepFun_P25 :
- forall (a b:R) (f g:R -> R) (lf lg:Rlist),
-   is_subdivision f a b lf ->
-   is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
-intros a b f g lf lg H H0; case (Rle_dec a b); intro;
- [ apply StepFun_P24 with f; assumption
- | apply StepFun_P5; apply StepFun_P24 with f;
-    [ auto with real
-    | apply StepFun_P5; assumption
-    | apply StepFun_P5; assumption ] ].
+  forall (a b:R) (f g:R -> R) (lf lg:Rlist),
+    is_subdivision f a b lf ->
+    is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
+Proof. 
+  intros a b f g lf lg H H0; case (Rle_dec a b); intro;
+    [ apply StepFun_P24 with f; assumption
+      | apply StepFun_P5; apply StepFun_P24 with f;
+        [ auto with real
+          | apply StepFun_P5; assumption
+          | apply StepFun_P5; assumption ] ].
 Qed.
 
 Lemma StepFun_P26 :
- forall (a b l:R) (f g:R -> R) (l1:Rlist),
-   is_subdivision f a b l1 ->
-   is_subdivision g a b l1 ->
-   is_subdivision (fun x:R => f x + l * g x) a b l1.
-intros a b l f g l1; unfold is_subdivision in |- *; intros; elim X; elim X0;
- intros; clear X X0; unfold adapted_couple in p, p0; 
- decompose [and] p; decompose [and] p0; clear p p0;
- apply existT with (FF l1 (fun x:R => f x + l * g x));
- unfold adapted_couple in |- *; repeat split; try assumption.
-apply StepFun_P20; apply neq_O_lt; red in |- *; intro; rewrite <- H8 in H7;
- discriminate.
-intros; unfold constant_D_eq, open_interval in |- *;
- unfold constant_D_eq, open_interval in H9, H4; intros;
- rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); 
- assert (H11 : l1 <> nil).
-red in |- *; intro; rewrite H11 in H8; elim (lt_n_O _ H8).
-assert (H12 := RList_P19 _ H11); elim H12; clear H12; intros r [r0 H12];
- rewrite H12; unfold FF in |- *;
- change
-   (pos_Rl x0 i + l * pos_Rl x i =
-    pos_Rl
-      (app_Rlist (mid_Rlist (cons r r0) r) (fun x2:R => f x2 + l * g x2))
-      (S i)) in |- *; rewrite RList_P12.
-rewrite RList_P13.
-rewrite <- H12; rewrite (H9 _ H8); try rewrite (H4 _ H8);
- reflexivity ||
-   (elim H10; clear H10; intros; split;
-     [ apply Rmult_lt_reg_l with 2;
-        [ prove_sup0
-        | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
-           rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
-           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
-              apply Rlt_trans with x1; assumption
-           | discrR ] ]
-     | apply Rmult_lt_reg_l with 2;
-        [ prove_sup0
-        | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
-           rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
-           [ rewrite Rmult_1_l; rewrite double;
-              rewrite (Rplus_comm (pos_Rl l1 i)); apply Rplus_lt_compat_l;
-              apply Rlt_trans with x1; assumption
-           | discrR ] ] ]).
-rewrite <- H12; assumption.
-rewrite RList_P14; simpl in |- *; rewrite H12 in H8; simpl in H8;
- apply lt_n_S; apply H8.
+  forall (a b l:R) (f g:R -> R) (l1:Rlist),
+    is_subdivision f a b l1 ->
+    is_subdivision g a b l1 ->
+    is_subdivision (fun x:R => f x + l * g x) a b l1.
+Proof.
+  intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4))))) 
+    (x,(_,(_,(_,(_,H9))))).
+  exists (FF l1 (fun x:R => f x + l * g x)); repeat split; try assumption.
+  apply StepFun_P20; rewrite H3; auto with arith.
+  intros i H8 x1 H10; unfold open_interval in H10, H9, H4; 
+    rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); 
+      assert (H11 : l1 <> nil).
+  red in |- *; intro H11; rewrite H11 in H8; elim (lt_n_O _ H8).
+  destruct (RList_P19 _ H11) as (r,(r0,H12));
+    rewrite H12; unfold FF in |- *;
+      change
+        (pos_Rl x0 i + l * pos_Rl x i =
+          pos_Rl
+          (app_Rlist (mid_Rlist (cons r r0) r) (fun x2:R => f x2 + l * g x2))
+          (S i)) in |- *; rewrite RList_P12.
+  rewrite RList_P13.
+  rewrite <- H12; rewrite (H9 _ H8); try rewrite (H4 _ H8);
+    reflexivity ||
+      (elim H10; clear H10; intros; split;
+        [ apply Rmult_lt_reg_l with 2;
+          [ prove_sup0
+            | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+              rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+                [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
+                  apply Rlt_trans with x1; assumption
+                  | discrR ] ]
+          | apply Rmult_lt_reg_l with 2;
+            [ prove_sup0
+              | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+                rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
+                  [ rewrite Rmult_1_l; rewrite double;
+                    rewrite (Rplus_comm (pos_Rl l1 i)); apply Rplus_lt_compat_l;
+                      apply Rlt_trans with x1; assumption
+                    | discrR ] ] ]).
+  rewrite <- H12; assumption.
+  rewrite RList_P14; simpl in |- *; rewrite H12 in H8; simpl in H8;
+    apply lt_n_S; apply H8.
 Qed.
 
 Lemma StepFun_P27 :
- forall (a b l:R) (f g:R -> R) (lf lg:Rlist),
-   is_subdivision f a b lf ->
-   is_subdivision g a b lg ->
-   is_subdivision (fun x:R => f x + l * g x) a b (cons_ORlist lf lg).
-intros a b l f g lf lg H H0; apply StepFun_P26;
- [ apply StepFun_P23 with g; assumption
- | apply StepFun_P25 with f; assumption ].
+  forall (a b l:R) (f g:R -> R) (lf lg:Rlist),
+    is_subdivision f a b lf ->
+    is_subdivision g a b lg ->
+    is_subdivision (fun x:R => f x + l * g x) a b (cons_ORlist lf lg).
+Proof. 
+  intros a b l f g lf lg H H0; apply StepFun_P26;
+    [ apply StepFun_P23 with g; assumption
+      | apply StepFun_P25 with f; assumption ].
 Qed.
 
-(* The set of step functions on [a,b] is a vectorial space *)
+(** The set of step functions on [a,b] is a vectorial space *)
 Lemma StepFun_P28 :
- forall (a b l:R) (f g:StepFun a b), IsStepFun (fun x:R => f x + l * g x) a b.
-intros a b l f g; unfold IsStepFun in |- *; assert (H := pre f);
- assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; 
- elim H0; intros; apply existT with (cons_ORlist x0 x); 
- apply StepFun_P27; assumption.
+  forall (a b l:R) (f g:StepFun a b), IsStepFun (fun x:R => f x + l * g x) a b.
+Proof. 
+  intros a b l f g; unfold IsStepFun in |- *; assert (H := pre f);
+    assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; 
+      elim H0; intros; apply existT with (cons_ORlist x0 x); 
+        apply StepFun_P27; assumption.
 Qed.
 
 Lemma StepFun_P29 :
- forall (a b:R) (f:StepFun a b), is_subdivision f a b (subdivision f).
-intros a b f; unfold is_subdivision in |- *;
- apply existT with (subdivision_val f); apply StepFun_P1.
+  forall (a b:R) (f:StepFun a b), is_subdivision f a b (subdivision f).
+Proof. 
+  intros a b f; unfold is_subdivision in |- *;
+    apply existT with (subdivision_val f); apply StepFun_P1.
 Qed.
 
 Lemma StepFun_P30 :
- forall (a b l:R) (f g:StepFun a b),
-   RiemannInt_SF (mkStepFun (StepFun_P28 l f g)) =
-   RiemannInt_SF f + l * RiemannInt_SF g.
-intros a b l f g; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
- (intro;
-   replace
-    (Int_SF (subdivision_val (mkStepFun (StepFun_P28 l f g)))
-       (subdivision (mkStepFun (StepFun_P28 l f g)))) with
-    (Int_SF
-       (FF (cons_ORlist (subdivision f) (subdivision g))
-          (fun x:R => f x + l * g x))
-       (cons_ORlist (subdivision f) (subdivision g)));
-   [ rewrite StepFun_P19;
+  forall (a b l:R) (f g:StepFun a b),
+    RiemannInt_SF (mkStepFun (StepFun_P28 l f g)) =
+    RiemannInt_SF f + l * RiemannInt_SF g.
+Proof. 
+  intros a b l f g; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
+    (intro;
       replace
-       (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) f)
+      (Int_SF (subdivision_val (mkStepFun (StepFun_P28 l f g)))
+        (subdivision (mkStepFun (StepFun_P28 l f g)))) with
+      (Int_SF
+        (FF (cons_ORlist (subdivision f) (subdivision g))
+          (fun x:R => f x + l * g x))
+        (cons_ORlist (subdivision f) (subdivision g)));
+      [ rewrite StepFun_P19;
+        replace
+        (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) f)
           (cons_ORlist (subdivision f) (subdivision g))) with
-       (Int_SF (subdivision_val f) (subdivision f));
-      [ replace
-         (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) g)
+        (Int_SF (subdivision_val f) (subdivision f));
+        [ replace
+          (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) g)
             (cons_ORlist (subdivision f) (subdivision g))) with
-         (Int_SF (subdivision_val g) (subdivision g));
-         [ ring
-         | apply StepFun_P17 with (fe g) a b;
+          (Int_SF (subdivision_val g) (subdivision g));
+          [ ring
+            | apply StepFun_P17 with (fe g) a b;
+              [ apply StepFun_P1
+                | apply StepFun_P21; apply StepFun_P25 with (fe f);
+                  apply StepFun_P29 ] ]
+          | apply StepFun_P17 with (fe f) a b;
             [ apply StepFun_P1
-            | apply StepFun_P21; apply StepFun_P25 with (fe f);
-               apply StepFun_P29 ] ]
-      | apply StepFun_P17 with (fe f) a b;
-         [ apply StepFun_P1
-         | apply StepFun_P21; apply StepFun_P23 with (fe g);
-            apply StepFun_P29 ] ]
-   | apply StepFun_P17 with (fun x:R => f x + l * g x) a b;
-      [ apply StepFun_P21; apply StepFun_P27; apply StepFun_P29
-      | apply (StepFun_P1 (mkStepFun (StepFun_P28 l f g))) ] ]).
+              | apply StepFun_P21; apply StepFun_P23 with (fe g);
+                apply StepFun_P29 ] ]
+        | apply StepFun_P17 with (fun x:R => f x + l * g x) a b;
+          [ apply StepFun_P21; apply StepFun_P27; apply StepFun_P29
+            | apply (StepFun_P1 (mkStepFun (StepFun_P28 l f g))) ] ]).
 Qed.
 
 Lemma StepFun_P31 :
- forall (a b:R) (f:R -> R) (l lf:Rlist),
-   adapted_couple f a b l lf ->
-   adapted_couple (fun x:R => Rabs (f x)) a b l (app_Rlist lf Rabs).
-unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
- repeat split; try assumption.
-symmetry  in |- *; rewrite H3; rewrite RList_P18; reflexivity.
-intros; unfold constant_D_eq, open_interval in |- *;
- unfold constant_D_eq, open_interval in H5; intros; 
- rewrite (H5 _ H _ H4); rewrite RList_P12;
- [ reflexivity | rewrite H3 in H; simpl in H; apply H ].
+  forall (a b:R) (f:R -> R) (l lf:Rlist),
+    adapted_couple f a b l lf ->
+    adapted_couple (fun x:R => Rabs (f x)) a b l (app_Rlist lf Rabs).
+Proof. 
+  unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
+    repeat split; try assumption.
+  symmetry  in |- *; rewrite H3; rewrite RList_P18; reflexivity.
+  intros; unfold constant_D_eq, open_interval in |- *;
+    unfold constant_D_eq, open_interval in H5; intros; 
+      rewrite (H5 _ H _ H4); rewrite RList_P12;
+        [ reflexivity | rewrite H3 in H; simpl in H; apply H ].
 Qed.
 
 Lemma StepFun_P32 :
- forall (a b:R) (f:StepFun a b), IsStepFun (fun x:R => Rabs (f x)) a b.
-intros a b f; unfold IsStepFun in |- *; apply existT with (subdivision f);
- unfold is_subdivision in |- *;
- apply existT with (app_Rlist (subdivision_val f) Rabs); 
- apply StepFun_P31; apply StepFun_P1.
+  forall (a b:R) (f:StepFun a b), IsStepFun (fun x:R => Rabs (f x)) a b.
+Proof. 
+  intros a b f; unfold IsStepFun in |- *; apply existT with (subdivision f);
+    unfold is_subdivision in |- *;
+      apply existT with (app_Rlist (subdivision_val f) Rabs); 
+        apply StepFun_P31; apply StepFun_P1.
 Qed.
 
 Lemma StepFun_P33 :
- forall l2 l1:Rlist,
-   ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (app_Rlist l2 Rabs) l1.
-simple induction l2; intros.
-simpl in |- *; rewrite Rabs_R0; right; reflexivity.
-simpl in |- *; induction  l1 as [| r1 l1 Hrecl1].
-rewrite Rabs_R0; right; reflexivity.
-induction  l1 as [| r2 l1 Hrecl0].
-rewrite Rabs_R0; right; reflexivity.
-apply Rle_trans with (Rabs (r * (r2 - r1)) + Rabs (Int_SF r0 (cons r2 l1))).
-apply Rabs_triang.
-rewrite Rabs_mult; rewrite (Rabs_right (r2 - r1));
- [ apply Rplus_le_compat_l; apply H; apply RList_P4 with r1; assumption
- | apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl in |- *;
-    apply lt_O_Sn ].
+  forall l2 l1:Rlist,
+    ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (app_Rlist l2 Rabs) l1.
+Proof. 
+  simple induction l2; intros.
+  simpl in |- *; rewrite Rabs_R0; right; reflexivity.
+  simpl in |- *; induction  l1 as [| r1 l1 Hrecl1].
+  rewrite Rabs_R0; right; reflexivity.
+  induction  l1 as [| r2 l1 Hrecl0].
+  rewrite Rabs_R0; right; reflexivity.
+  apply Rle_trans with (Rabs (r * (r2 - r1)) + Rabs (Int_SF r0 (cons r2 l1))).
+  apply Rabs_triang.
+  rewrite Rabs_mult; rewrite (Rabs_right (r2 - r1));
+    [ apply Rplus_le_compat_l; apply H; apply RList_P4 with r1; assumption
+      | apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl in |- *;
+        apply lt_O_Sn ].
 Qed.
 
 Lemma StepFun_P34 :
- forall (a b:R) (f:StepFun a b),
-   a <= b ->
-   Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)).
-intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
-replace
- (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f)))
+  forall (a b:R) (f:StepFun a b),
+    a <= b ->
+    Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)).
+Proof. 
+  intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  replace
+  (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f)))
     (subdivision (mkStepFun (StepFun_P32 f)))) with
- (Int_SF (app_Rlist (subdivision_val f) Rabs) (subdivision f)).
-apply StepFun_P33; assert (H0 := StepFun_P29 f); unfold is_subdivision in H0;
- elim H0; intros; unfold adapted_couple in p; decompose [and] p; 
- assumption.
-apply StepFun_P17 with (fun x:R => Rabs (f x)) a b;
- [ apply StepFun_P31; apply StepFun_P1
- | apply (StepFun_P1 (mkStepFun (StepFun_P32 f))) ].
-elim n; assumption.
+  (Int_SF (app_Rlist (subdivision_val f) Rabs) (subdivision f)).
+  apply StepFun_P33; assert (H0 := StepFun_P29 f); unfold is_subdivision in H0;
+    elim H0; intros; unfold adapted_couple in p; decompose [and] p; 
+      assumption.
+  apply StepFun_P17 with (fun x:R => Rabs (f x)) a b;
+    [ apply StepFun_P31; apply StepFun_P1
+      | apply (StepFun_P1 (mkStepFun (StepFun_P32 f))) ].
+  elim n; assumption.
 Qed.
 
 Lemma StepFun_P35 :
- forall (l:Rlist) (a b:R) (f g:R -> R),
-   ordered_Rlist l ->
-   pos_Rl l 0 = a ->
-   pos_Rl l (pred (Rlength l)) = b ->
-   (forall x:R, a < x < b -> f x <= g x) ->
-   Int_SF (FF l f) l <= Int_SF (FF l g) l.
-simple induction l; intros.
-right; reflexivity.
-simpl in |- *; induction  r0 as [| r0 r1 Hrecr0].
-right; reflexivity.
-simpl in |- *; apply Rplus_le_compat.
-case (Req_dec r r0); intro.
-rewrite H4; right; ring.
-do 2 rewrite <- (Rmult_comm (r0 - r)); apply Rmult_le_compat_l.
-apply Rge_le; apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl in |- *;
- apply lt_O_Sn.
-apply H3; split.
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-assert (H5 : r = a).
-apply H1.
-rewrite H5; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l.
-assert (H6 := H0 0%nat (lt_O_Sn _)).
-simpl in H6.
-elim H6; intro.
-rewrite H5 in H7; apply H7.
-elim H4; assumption.
-discrR.
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; rewrite double; assert (H5 : r0 <= b).
-replace b with
- (pos_Rl (cons r (cons r0 r1)) (pred (Rlength (cons r (cons r0 r1))))).
-replace r0 with (pos_Rl (cons r (cons r0 r1)) 1).
-elim (RList_P6 (cons r (cons r0 r1))); intros; apply H5.
-assumption.
-simpl in |- *; apply le_n_S.
-apply le_O_n.
-simpl in |- *; apply lt_n_Sn.
-reflexivity.
-apply Rle_lt_trans with (r + b).
-apply Rplus_le_compat_l; assumption.
-rewrite (Rplus_comm r); apply Rplus_lt_compat_l.
-apply Rlt_le_trans with r0.
-assert (H6 := H0 0%nat (lt_O_Sn _)).
-simpl in H6.
-elim H6; intro.
-apply H7.
-elim H4; assumption.
-assumption.
-discrR.
-simpl in H; apply H with r0 b.
-apply RList_P4 with r; assumption.
-reflexivity.
-rewrite <- H2; reflexivity.
-intros; apply H3; elim H4; intros; split; try assumption.
-apply Rle_lt_trans with r0; try assumption.
-rewrite <- H1.
-simpl in |- *; apply (H0 0%nat); simpl in |- *; apply lt_O_Sn.
+  forall (l:Rlist) (a b:R) (f g:R -> R),
+    ordered_Rlist l ->
+    pos_Rl l 0 = a ->
+    pos_Rl l (pred (Rlength l)) = b ->
+    (forall x:R, a < x < b -> f x <= g x) ->
+    Int_SF (FF l f) l <= Int_SF (FF l g) l.
+Proof. 
+  simple induction l; intros.
+  right; reflexivity.
+  simpl in |- *; induction  r0 as [| r0 r1 Hrecr0].
+  right; reflexivity.
+  simpl in |- *; apply Rplus_le_compat.
+  case (Req_dec r r0); intro.
+  rewrite H4; right; ring.
+  do 2 rewrite <- (Rmult_comm (r0 - r)); apply Rmult_le_compat_l.
+  apply Rge_le; apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl in |- *;
+    apply lt_O_Sn.
+  apply H3; split.
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  assert (H5 : r = a).
+  apply H1.
+  rewrite H5; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l.
+  assert (H6 := H0 0%nat (lt_O_Sn _)).
+  simpl in H6.
+  elim H6; intro.
+  rewrite H5 in H7; apply H7.
+  elim H4; assumption.
+  discrR.
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite double; assert (H5 : r0 <= b).
+  replace b with
+  (pos_Rl (cons r (cons r0 r1)) (pred (Rlength (cons r (cons r0 r1))))).
+  replace r0 with (pos_Rl (cons r (cons r0 r1)) 1).
+  elim (RList_P6 (cons r (cons r0 r1))); intros; apply H5.
+  assumption.
+  simpl in |- *; apply le_n_S.
+  apply le_O_n.
+  simpl in |- *; apply lt_n_Sn.
+  reflexivity.
+  apply Rle_lt_trans with (r + b).
+  apply Rplus_le_compat_l; assumption.
+  rewrite (Rplus_comm r); apply Rplus_lt_compat_l.
+  apply Rlt_le_trans with r0.
+  assert (H6 := H0 0%nat (lt_O_Sn _)).
+  simpl in H6.
+  elim H6; intro.
+  apply H7.
+  elim H4; assumption.
+  assumption.
+  discrR.
+  simpl in H; apply H with r0 b.
+  apply RList_P4 with r; assumption.
+  reflexivity.
+  rewrite <- H2; reflexivity.
+  intros; apply H3; elim H4; intros; split; try assumption.
+  apply Rle_lt_trans with r0; try assumption.
+  rewrite <- H1.
+  simpl in |- *; apply (H0 0%nat); simpl in |- *; apply lt_O_Sn.
 Qed.
 
 Lemma StepFun_P36 :
- forall (a b:R) (f g:StepFun a b) (l:Rlist),
-   a <= b ->
-   is_subdivision f a b l ->
-   is_subdivision g a b l ->
-   (forall x:R, a < x < b -> f x <= g x) ->
-   RiemannInt_SF f <= RiemannInt_SF g.
-intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
-replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l).
-replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l).
-unfold is_subdivision in X; elim X; clear X; intros;
- unfold adapted_couple in p; decompose [and] p; clear p;
- assert (H5 : Rmin a b = a);
- [ unfold Rmin in |- *; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ]
- | assert (H7 : Rmax a b = b);
-    [ unfold Rmax in |- *; case (Rle_dec a b); intro;
-       [ reflexivity | elim n; assumption ]
-    | rewrite H5 in H3; rewrite H7 in H2; eapply StepFun_P35 with a b;
-       assumption ] ].
-apply StepFun_P17 with (fe g) a b;
- [ apply StepFun_P21; assumption | apply StepFun_P1 ].
-apply StepFun_P17 with (fe f) a b;
- [ apply StepFun_P21; assumption | apply StepFun_P1 ].
-elim n; assumption.
+  forall (a b:R) (f g:StepFun a b) (l:Rlist),
+    a <= b ->
+    is_subdivision f a b l ->
+    is_subdivision g a b l ->
+    (forall x:R, a < x < b -> f x <= g x) ->
+    RiemannInt_SF f <= RiemannInt_SF g.
+Proof. 
+  intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l).
+  replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l).
+  unfold is_subdivision in X; elim X; clear X; intros;
+    unfold adapted_couple in p; decompose [and] p; clear p;
+      assert (H5 : Rmin a b = a);
+        [ unfold Rmin in |- *; case (Rle_dec a b); intro;
+          [ reflexivity | elim n; assumption ]
+          | assert (H7 : Rmax a b = b);
+            [ unfold Rmax in |- *; case (Rle_dec a b); intro;
+              [ reflexivity | elim n; assumption ]
+              | rewrite H5 in H3; rewrite H7 in H2; eapply StepFun_P35 with a b;
+                assumption ] ].
+  apply StepFun_P17 with (fe g) a b;
+    [ apply StepFun_P21; assumption | apply StepFun_P1 ].
+  apply StepFun_P17 with (fe f) a b;
+    [ apply StepFun_P21; assumption | apply StepFun_P1 ].
+  elim n; assumption.
 Qed.
 
 Lemma StepFun_P37 :
- forall (a b:R) (f g:StepFun a b),
-   a <= b ->
-   (forall x:R, a < x < b -> f x <= g x) ->
-   RiemannInt_SF f <= RiemannInt_SF g.
-intros; eapply StepFun_P36; try assumption.
-eapply StepFun_P25; apply StepFun_P29.
-eapply StepFun_P23; apply StepFun_P29.
+  forall (a b:R) (f g:StepFun a b),
+    a <= b ->
+    (forall x:R, a < x < b -> f x <= g x) ->
+    RiemannInt_SF f <= RiemannInt_SF g.
+Proof. 
+  intros; eapply StepFun_P36; try assumption.
+  eapply StepFun_P25; apply StepFun_P29.
+  eapply StepFun_P23; apply StepFun_P29.
 Qed.
 
 Lemma StepFun_P38 :
- forall (l:Rlist) (a b:R) (f:R -> R),
-   ordered_Rlist l ->
-   pos_Rl l 0 = a ->
-   pos_Rl l (pred (Rlength l)) = b ->
-   sigT
-     (fun g:StepFun a b =>
-        g b = f b /\
-        (forall i:nat,
-           (i < pred (Rlength l))%nat ->
-           constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i)))
-             (f (pos_Rl l i)))).
-intros l a b f; generalize a; clear a; induction l. 
-intros a H H0 H1; simpl in H0; simpl in H1;
- exists (mkStepFun (StepFun_P4 a b (f b))); split.
-reflexivity.
-intros; elim (lt_n_O _ H2).
-intros; destruct l as [| r1 l].
-simpl in H1; simpl in H0; exists (mkStepFun (StepFun_P4 a b (f b))); split.
-reflexivity.
-intros i H2; elim (lt_n_O _ H2).
-intros; assert (H2 : ordered_Rlist (cons r1 l)).
-apply RList_P4 with r; assumption.
-assert (H3 : pos_Rl (cons r1 l) 0 = r1).
-reflexivity.
-assert (H4 : pos_Rl (cons r1 l) (pred (Rlength (cons r1 l))) = b).
-rewrite <- H1; reflexivity.
-elim (IHl r1 H2 H3 H4); intros g [H5 H6].
-set
- (g' :=
-  fun x:R => match Rle_dec r1 x with
-             | left _ => g x
-             | right _ => f a
-             end).
-assert (H7 : r1 <= b).
-rewrite <- H4; apply RList_P7; [ assumption | left; reflexivity ].
-assert (H8 : IsStepFun g' a b).
-unfold IsStepFun in |- *; assert (H8 := pre g); unfold IsStepFun in H8;
- elim H8; intros lg H9; unfold is_subdivision in H9; 
- elim H9; clear H9; intros lg2 H9; split with (cons a lg);
- unfold is_subdivision in |- *; split with (cons (f a) lg2);
- unfold adapted_couple in H9; decompose [and] H9; clear H9;
- unfold adapted_couple in |- *; repeat split.
-unfold ordered_Rlist in |- *; intros; simpl in H9;
- induction  i as [| i Hreci].
-simpl in |- *; rewrite H12; replace (Rmin r1 b) with r1.
-simpl in H0; rewrite <- H0; apply (H 0%nat); simpl in |- *; apply lt_O_Sn.
-unfold Rmin in |- *; case (Rle_dec r1 b); intro;
- [ reflexivity | elim n; assumption ].
-apply (H10 i); apply lt_S_n.
-replace (S (pred (Rlength lg))) with (Rlength lg).
-apply H9.
-apply S_pred with 0%nat; apply neq_O_lt; intro; rewrite <- H14 in H9;
- elim (lt_n_O _ H9).
-simpl in |- *; assert (H14 : a <= b).
-rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
- [ assumption | left; reflexivity ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-assert (H14 : a <= b).
-rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
- [ assumption | left; reflexivity ].
-replace (Rmax a b) with (Rmax r1 b).
-rewrite <- H11; induction  lg as [| r0 lg Hreclg].
-simpl in H13; discriminate.
-reflexivity.
-unfold Rmax in |- *; case (Rle_dec a b); case (Rle_dec r1 b); intros;
- reflexivity || elim n; assumption.
-simpl in |- *; rewrite H13; reflexivity.
-intros; simpl in H9; induction  i as [| i Hreci].
-unfold constant_D_eq, open_interval in |- *; simpl in |- *; intros;
- assert (H16 : Rmin r1 b = r1).
-unfold Rmin in |- *; case (Rle_dec r1 b); intro;
- [ reflexivity | elim n; assumption ].
-rewrite H16 in H12; rewrite H12 in H14; elim H14; clear H14; intros _ H14;
- unfold g' in |- *; case (Rle_dec r1 x); intro r3.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H14)).
-reflexivity.
-change
-  (constant_D_eq g' (open_interval (pos_Rl lg i) (pos_Rl lg (S i)))
-     (pos_Rl lg2 i)) in |- *; clear Hreci; assert (H16 := H15 i);
- assert (H17 : (i < pred (Rlength lg))%nat).
-apply lt_S_n.
-replace (S (pred (Rlength lg))) with (Rlength lg).
-assumption.
-apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
- rewrite <- H14 in H9; elim (lt_n_O _ H9).
-assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
- unfold constant_D_eq, open_interval in |- *; intros;
- assert (H19 := H18 _ H14); rewrite <- H19; unfold g' in |- *;
- case (Rle_dec r1 x); intro.
-reflexivity.
-elim n; replace r1 with (Rmin r1 b).
-rewrite <- H12; elim H14; clear H14; intros H14 _; left;
- apply Rle_lt_trans with (pos_Rl lg i); try assumption.
-apply RList_P5.
-assumption.
-elim (RList_P3 lg (pos_Rl lg i)); intros; apply H21; exists i; split.
-reflexivity.
-apply lt_trans with (pred (Rlength lg)); try assumption.
-apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H22 in H17;
- elim (lt_n_O _ H17).
-unfold Rmin in |- *; case (Rle_dec r1 b); intro;
- [ reflexivity | elim n0; assumption ].
-exists (mkStepFun H8); split.
-simpl in |- *; unfold g' in |- *; case (Rle_dec r1 b); intro.
-assumption.
-elim n; assumption.
-intros; simpl in H9; induction  i as [| i Hreci].
-unfold constant_D_eq, co_interval in |- *; simpl in |- *; intros; simpl in H0;
- rewrite H0; elim H10; clear H10; intros; unfold g' in |- *;
- case (Rle_dec r1 x); intro r3.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H11)).
-reflexivity.
-clear Hreci;
- change
-   (constant_D_eq (mkStepFun H8)
-      (co_interval (pos_Rl (cons r1 l) i) (pos_Rl (cons r1 l) (S i)))
-      (f (pos_Rl (cons r1 l) i))) in |- *; assert (H10 := H6 i);
- assert (H11 : (i < pred (Rlength (cons r1 l)))%nat).
-simpl in |- *; apply lt_S_n; assumption.
-assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12;
- unfold constant_D_eq, co_interval in |- *; intros; 
- rewrite <- (H12 _ H13); simpl in |- *; unfold g' in |- *;
- case (Rle_dec r1 x); intro.
-reflexivity.
-elim n; elim H13; clear H13; intros;
- apply Rle_trans with (pos_Rl (cons r1 l) i); try assumption;
- change (pos_Rl (cons r1 l) 0 <= pos_Rl (cons r1 l) i) in |- *;
- elim (RList_P6 (cons r1 l)); intros; apply H15;
- [ assumption
- | apply le_O_n
- | simpl in |- *; apply lt_trans with (Rlength l);
-    [ apply lt_S_n; assumption | apply lt_n_Sn ] ].
+  forall (l:Rlist) (a b:R) (f:R -> R),
+    ordered_Rlist l ->
+    pos_Rl l 0 = a ->
+    pos_Rl l (pred (Rlength l)) = b ->
+    sigT
+    (fun g:StepFun a b =>
+      g b = f b /\
+      (forall i:nat,
+        (i < pred (Rlength l))%nat ->
+        constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i)))
+        (f (pos_Rl l i)))).
+Proof. 
+  intros l a b f; generalize a; clear a; induction l. 
+  intros a H H0 H1; simpl in H0; simpl in H1;
+    exists (mkStepFun (StepFun_P4 a b (f b))); split.
+  reflexivity.
+  intros; elim (lt_n_O _ H2).
+  intros; destruct l as [| r1 l].
+  simpl in H1; simpl in H0; exists (mkStepFun (StepFun_P4 a b (f b))); split.
+  reflexivity.
+  intros i H2; elim (lt_n_O _ H2).
+  intros; assert (H2 : ordered_Rlist (cons r1 l)).
+  apply RList_P4 with r; assumption.
+  assert (H3 : pos_Rl (cons r1 l) 0 = r1).
+  reflexivity.
+  assert (H4 : pos_Rl (cons r1 l) (pred (Rlength (cons r1 l))) = b).
+  rewrite <- H1; reflexivity.
+  elim (IHl r1 H2 H3 H4); intros g [H5 H6].
+  set
+    (g' :=
+      fun x:R => match Rle_dec r1 x with
+                   | left _ => g x
+                   | right _ => f a
+                 end).
+  assert (H7 : r1 <= b).
+  rewrite <- H4; apply RList_P7; [ assumption | left; reflexivity ].
+  assert (H8 : IsStepFun g' a b).
+  unfold IsStepFun in |- *; assert (H8 := pre g); unfold IsStepFun in H8;
+    elim H8; intros lg H9; unfold is_subdivision in H9; 
+      elim H9; clear H9; intros lg2 H9; split with (cons a lg);
+        unfold is_subdivision in |- *; split with (cons (f a) lg2);
+          unfold adapted_couple in H9; decompose [and] H9; clear H9;
+            unfold adapted_couple in |- *; repeat split.
+  unfold ordered_Rlist in |- *; intros; simpl in H9;
+    induction  i as [| i Hreci].
+  simpl in |- *; rewrite H12; replace (Rmin r1 b) with r1.
+  simpl in H0; rewrite <- H0; apply (H 0%nat); simpl in |- *; apply lt_O_Sn.
+  unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+    [ reflexivity | elim n; assumption ].
+  apply (H10 i); apply lt_S_n.
+  replace (S (pred (Rlength lg))) with (Rlength lg).
+  apply H9.
+  apply S_pred with 0%nat; apply neq_O_lt; intro; rewrite <- H14 in H9;
+    elim (lt_n_O _ H9).
+  simpl in |- *; assert (H14 : a <= b).
+  rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
+    [ assumption | left; reflexivity ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  assert (H14 : a <= b).
+  rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
+    [ assumption | left; reflexivity ].
+  replace (Rmax a b) with (Rmax r1 b).
+  rewrite <- H11; induction  lg as [| r0 lg Hreclg].
+  simpl in H13; discriminate.
+  reflexivity.
+  unfold Rmax in |- *; case (Rle_dec a b); case (Rle_dec r1 b); intros;
+    reflexivity || elim n; assumption.
+  simpl in |- *; rewrite H13; reflexivity.
+  intros; simpl in H9; induction  i as [| i Hreci].
+  unfold constant_D_eq, open_interval in |- *; simpl in |- *; intros;
+    assert (H16 : Rmin r1 b = r1).
+  unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+    [ reflexivity | elim n; assumption ].
+  rewrite H16 in H12; rewrite H12 in H14; elim H14; clear H14; intros _ H14;
+    unfold g' in |- *; case (Rle_dec r1 x); intro r3.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H14)).
+  reflexivity.
+  change
+    (constant_D_eq g' (open_interval (pos_Rl lg i) (pos_Rl lg (S i)))
+      (pos_Rl lg2 i)) in |- *; clear Hreci; assert (H16 := H15 i);
+    assert (H17 : (i < pred (Rlength lg))%nat).
+  apply lt_S_n.
+  replace (S (pred (Rlength lg))) with (Rlength lg).
+  assumption.
+  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+    rewrite <- H14 in H9; elim (lt_n_O _ H9).
+  assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
+    unfold constant_D_eq, open_interval in |- *; intros;
+      assert (H19 := H18 _ H14); rewrite <- H19; unfold g' in |- *;
+        case (Rle_dec r1 x); intro.
+  reflexivity.
+  elim n; replace r1 with (Rmin r1 b).
+  rewrite <- H12; elim H14; clear H14; intros H14 _; left;
+    apply Rle_lt_trans with (pos_Rl lg i); try assumption.
+  apply RList_P5.
+  assumption.
+  elim (RList_P3 lg (pos_Rl lg i)); intros; apply H21; exists i; split.
+  reflexivity.
+  apply lt_trans with (pred (Rlength lg)); try assumption.
+  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H22 in H17;
+    elim (lt_n_O _ H17).
+  unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+    [ reflexivity | elim n0; assumption ].
+  exists (mkStepFun H8); split.
+  simpl in |- *; unfold g' in |- *; case (Rle_dec r1 b); intro.
+  assumption.
+  elim n; assumption.
+  intros; simpl in H9; induction  i as [| i Hreci].
+  unfold constant_D_eq, co_interval in |- *; simpl in |- *; intros; simpl in H0;
+    rewrite H0; elim H10; clear H10; intros; unfold g' in |- *;
+      case (Rle_dec r1 x); intro r3.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H11)).
+  reflexivity.
+  clear Hreci;
+    change
+      (constant_D_eq (mkStepFun H8)
+        (co_interval (pos_Rl (cons r1 l) i) (pos_Rl (cons r1 l) (S i)))
+        (f (pos_Rl (cons r1 l) i))) in |- *; assert (H10 := H6 i);
+      assert (H11 : (i < pred (Rlength (cons r1 l)))%nat).
+  simpl in |- *; apply lt_S_n; assumption.
+  assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12;
+    unfold constant_D_eq, co_interval in |- *; intros; 
+      rewrite <- (H12 _ H13); simpl in |- *; unfold g' in |- *;
+        case (Rle_dec r1 x); intro.
+  reflexivity.
+  elim n; elim H13; clear H13; intros;
+    apply Rle_trans with (pos_Rl (cons r1 l) i); try assumption;
+      change (pos_Rl (cons r1 l) 0 <= pos_Rl (cons r1 l) i) in |- *;
+        elim (RList_P6 (cons r1 l)); intros; apply H15;
+          [ assumption
+            | apply le_O_n
+            | simpl in |- *; apply lt_trans with (Rlength l);
+              [ apply lt_S_n; assumption | apply lt_n_Sn ] ].
 Qed.
 
 Lemma StepFun_P39 :
- forall (a b:R) (f:StepFun a b),
-   RiemannInt_SF f = - RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))).
-intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); case (Rle_dec b a);
- intros.
-assert (H : adapted_couple f a b (subdivision f) (subdivision_val f));
- [ apply StepFun_P1
- | assert
-    (H0 :
-     adapted_couple (mkStepFun (StepFun_P6 (pre f))) b a
-       (subdivision (mkStepFun (StepFun_P6 (pre f))))
-       (subdivision_val (mkStepFun (StepFun_P6 (pre f)))));
+  forall (a b:R) (f:StepFun a b),
+    RiemannInt_SF f = - RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))).
+Proof. 
+  intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); case (Rle_dec b a);
+    intros.
+  assert (H : adapted_couple f a b (subdivision f) (subdivision_val f));
+    [ apply StepFun_P1
+      | assert
+        (H0 :
+          adapted_couple (mkStepFun (StepFun_P6 (pre f))) b a
+          (subdivision (mkStepFun (StepFun_P6 (pre f))))
+          (subdivision_val (mkStepFun (StepFun_P6 (pre f)))));
+        [ apply StepFun_P1
+          | assert (H1 : a = b);
+            [ apply Rle_antisym; assumption
+              | rewrite (StepFun_P8 H H1); assert (H2 : b = a);
+                [ symmetry  in |- *; apply H1 | rewrite (StepFun_P8 H0 H2); ring ] ] ] ].
+  rewrite Ropp_involutive; eapply StepFun_P17;
+    [ apply StepFun_P1
+      | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
+        elim H; intros; unfold is_subdivision in |- *; 
+          elim p; intros; apply p0 ].
+  apply Ropp_eq_compat; eapply StepFun_P17;
     [ apply StepFun_P1
-    | assert (H1 : a = b);
-       [ apply Rle_antisym; assumption
-       | rewrite (StepFun_P8 H H1); assert (H2 : b = a);
-          [ symmetry  in |- *; apply H1 | rewrite (StepFun_P8 H0 H2); ring ] ] ] ].
-rewrite Ropp_involutive; eapply StepFun_P17;
- [ apply StepFun_P1
- | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
-    elim H; intros; unfold is_subdivision in |- *; 
-    elim p; intros; apply p0 ].
-apply Ropp_eq_compat; eapply StepFun_P17;
- [ apply StepFun_P1
- | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
-    elim H; intros; unfold is_subdivision in |- *; 
-    elim p; intros; apply p0 ].
-assert (H : a < b);
- [ auto with real
- | assert (H0 : b < a);
-    [ auto with real | elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H0)) ] ].
+      | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
+        elim H; intros; unfold is_subdivision in |- *; 
+          elim p; intros; apply p0 ].
+  assert (H : a < b);
+    [ auto with real
+      | assert (H0 : b < a);
+        [ auto with real | elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H0)) ] ].
 Qed.
 
 Lemma StepFun_P40 :
- forall (f:R -> R) (a b c:R) (l1 l2 lf1 lf2:Rlist),
-   a < b ->
-   b < c ->
-   adapted_couple f a b l1 lf1 ->
-   adapted_couple f b c l2 lf2 ->
-   adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f).
-intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2;
- unfold adapted_couple in |- *; decompose [and] H1; 
- decompose [and] H2; clear H1 H2; repeat split.
-apply RList_P25; try assumption.
-rewrite H10; rewrite H4; unfold Rmin, Rmax in |- *; case (Rle_dec a b);
- case (Rle_dec b c); intros;
- (right; reflexivity) || (elim n; left; assumption).
-rewrite RList_P22.
-rewrite H5; unfold Rmin, Rmax in |- *; case (Rle_dec a b); case (Rle_dec a c);
- intros;
- [ reflexivity
- | elim n; apply Rle_trans with b; left; assumption
- | elim n; left; assumption
- | elim n0; left; assumption ].
-red in |- *; intro; rewrite H1 in H6; discriminate.
-rewrite RList_P24.
-rewrite H9; unfold Rmin, Rmax in |- *; case (Rle_dec b c); case (Rle_dec a c);
- intros;
- [ reflexivity
- | elim n; apply Rle_trans with b; left; assumption
- | elim n; left; assumption
- | elim n0; left; assumption ].
-red in |- *; intro; rewrite H1 in H11; discriminate.
-apply StepFun_P20.
-rewrite RList_P23; apply neq_O_lt; red in |- *; intro.
-assert (H2 : (Rlength l1 + Rlength l2)%nat = 0%nat).
-symmetry  in |- *; apply H1.
-elim (plus_is_O _ _ H2); intros; rewrite H12 in H6; discriminate.
-unfold constant_D_eq, open_interval in |- *; intros;
- elim (le_or_lt (S (S i)) (Rlength l1)); intro.
-assert (H14 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i).
-apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; apply le_S_n;
- apply le_trans with (Rlength l1); [ assumption | apply le_n_Sn ].
-assert (H15 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l1 (S i)).
-apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; assumption.
-rewrite H14 in H2; rewrite H15 in H2; assert (H16 : (2 <= Rlength l1)%nat).
-apply le_trans with (S (S i));
- [ repeat apply le_n_S; apply le_O_n | assumption ].
-elim (RList_P20 _ H16); intros r1 [r2 [r3 H17]]; rewrite H17;
- change
-   (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i)
-  in |- *; rewrite RList_P12.
-induction  i as [| i Hreci].
-simpl in |- *; assert (H18 := H8 0%nat);
- unfold constant_D_eq, open_interval in H18;
- assert (H19 : (0 < pred (Rlength l1))%nat).
-rewrite H17; simpl in |- *; apply lt_O_Sn.
-assert (H20 := H18 H19); repeat rewrite H20.
-reflexivity.
-assert (H21 : r1 <= r2).
-rewrite H17 in H3; apply (H3 0%nat).
-simpl in |- *; apply lt_O_Sn.
-elim H21; intro.
-split.
-rewrite H17; simpl in |- *; apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-rewrite H17; simpl in |- *; apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite (Rplus_comm r1); rewrite double;
-       apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-elim H2; intros; rewrite H17 in H23; rewrite H17 in H24; simpl in H24;
- simpl in H23; rewrite H22 in H23;
- elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)).
-assumption.
-clear Hreci; rewrite RList_P13.
-rewrite H17 in H14; rewrite H17 in H15;
- change
-   (pos_Rl (cons_Rlist (cons r2 r3) l2) i =
-    pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; rewrite H14;
- change
-   (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) =
-    pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; 
- rewrite H15; assert (H18 := H8 (S i));
- unfold constant_D_eq, open_interval in H18;
- assert (H19 : (S i < pred (Rlength l1))%nat).
-apply lt_pred; apply lt_S_n; apply le_lt_n_Sm; assumption.
-assert (H20 := H18 H19); repeat rewrite H20.
-reflexivity.
-rewrite <- H17; assert (H21 : pos_Rl l1 (S i) <= pos_Rl l1 (S (S i))).
-apply (H3 (S i)); apply lt_pred; apply lt_S_n; apply le_lt_n_Sm; assumption.
-elim H21; intro.
-split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l1 (S i)));
-       rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-elim H2; intros; rewrite H22 in H23;
- elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)).
-assumption.
-simpl in |- *; rewrite H17 in H1; simpl in H1; apply lt_S_n; assumption.
-rewrite RList_P14; rewrite H17 in H1; simpl in H1; apply H1.
-inversion H12.
-assert (H16 : pos_Rl (cons_Rlist l1 l2) (S i) = b).
-rewrite RList_P29.
-rewrite H15; rewrite <- minus_n_n; rewrite H10; unfold Rmin in |- *;
- case (Rle_dec b c); intro; [ reflexivity | elim n; left; assumption ].
-rewrite H15; apply le_n.
-induction  l1 as [| r l1 Hrecl1].
-simpl in H15; discriminate.
-clear Hrecl1; simpl in H1; simpl in |- *; apply lt_n_S; assumption.
-assert (H17 : pos_Rl (cons_Rlist l1 l2) i = b).
-rewrite RList_P26.
-replace i with (pred (Rlength l1));
- [ rewrite H4; unfold Rmax in |- *; case (Rle_dec a b); intro;
+  forall (f:R -> R) (a b c:R) (l1 l2 lf1 lf2:Rlist),
+    a < b ->
+    b < c ->
+    adapted_couple f a b l1 lf1 ->
+    adapted_couple f b c l2 lf2 ->
+    adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f).
+Proof. 
+  intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2;
+    unfold adapted_couple in |- *; decompose [and] H1; 
+      decompose [and] H2; clear H1 H2; repeat split.
+  apply RList_P25; try assumption.
+  rewrite H10; rewrite H4; unfold Rmin, Rmax in |- *; case (Rle_dec a b);
+    case (Rle_dec b c); intros;
+      (right; reflexivity) || (elim n; left; assumption).
+  rewrite RList_P22.
+  rewrite H5; unfold Rmin, Rmax in |- *; case (Rle_dec a b); case (Rle_dec a c);
+    intros;
+      [ reflexivity
+        | elim n; apply Rle_trans with b; left; assumption
+        | elim n; left; assumption
+        | elim n0; left; assumption ].
+  red in |- *; intro; rewrite H1 in H6; discriminate.
+  rewrite RList_P24.
+  rewrite H9; unfold Rmin, Rmax in |- *; case (Rle_dec b c); case (Rle_dec a c);
+    intros;
+      [ reflexivity
+        | elim n; apply Rle_trans with b; left; assumption
+        | elim n; left; assumption
+        | elim n0; left; assumption ].
+  red in |- *; intro; rewrite H1 in H11; discriminate.
+  apply StepFun_P20.
+  rewrite RList_P23; apply neq_O_lt; red in |- *; intro.
+  assert (H2 : (Rlength l1 + Rlength l2)%nat = 0%nat).
+  symmetry  in |- *; apply H1.
+  elim (plus_is_O _ _ H2); intros; rewrite H12 in H6; discriminate.
+  unfold constant_D_eq, open_interval in |- *; intros;
+    elim (le_or_lt (S (S i)) (Rlength l1)); intro.
+  assert (H14 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i).
+  apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; apply le_S_n;
+    apply le_trans with (Rlength l1); [ assumption | apply le_n_Sn ].
+  assert (H15 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l1 (S i)).
+  apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; assumption.
+  rewrite H14 in H2; rewrite H15 in H2; assert (H16 : (2 <= Rlength l1)%nat).
+  apply le_trans with (S (S i));
+    [ repeat apply le_n_S; apply le_O_n | assumption ].
+  elim (RList_P20 _ H16); intros r1 [r2 [r3 H17]]; rewrite H17;
+    change
+      (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i)
+      in |- *; rewrite RList_P12.
+  induction  i as [| i Hreci].
+  simpl in |- *; assert (H18 := H8 0%nat);
+    unfold constant_D_eq, open_interval in H18;
+      assert (H19 : (0 < pred (Rlength l1))%nat).
+  rewrite H17; simpl in |- *; apply lt_O_Sn.
+  assert (H20 := H18 H19); repeat rewrite H20.
+  reflexivity.
+  assert (H21 : r1 <= r2).
+  rewrite H17 in H3; apply (H3 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  elim H21; intro.
+  split.
+  rewrite H17; simpl in |- *; apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  rewrite H17; simpl in |- *; apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite (Rplus_comm r1); rewrite double;
+            apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  elim H2; intros; rewrite H17 in H23; rewrite H17 in H24; simpl in H24;
+    simpl in H23; rewrite H22 in H23;
+      elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)).
+  assumption.
+  clear Hreci; rewrite RList_P13.
+  rewrite H17 in H14; rewrite H17 in H15;
+    change
+      (pos_Rl (cons_Rlist (cons r2 r3) l2) i =
+        pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; rewrite H14;
+      change
+        (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) =
+          pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; 
+        rewrite H15; assert (H18 := H8 (S i));
+          unfold constant_D_eq, open_interval in H18;
+            assert (H19 : (S i < pred (Rlength l1))%nat).
+  apply lt_pred; apply lt_S_n; apply le_lt_n_Sm; assumption.
+  assert (H20 := H18 H19); repeat rewrite H20.
+  reflexivity.
+  rewrite <- H17; assert (H21 : pos_Rl l1 (S i) <= pos_Rl l1 (S (S i))).
+  apply (H3 (S i)); apply lt_pred; apply lt_S_n; apply le_lt_n_Sm; assumption.
+  elim H21; intro.
+  split.
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l1 (S i)));
+            rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  elim H2; intros; rewrite H22 in H23;
+    elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)).
+  assumption.
+  simpl in |- *; rewrite H17 in H1; simpl in H1; apply lt_S_n; assumption.
+  rewrite RList_P14; rewrite H17 in H1; simpl in H1; apply H1.
+  inversion H12.
+  assert (H16 : pos_Rl (cons_Rlist l1 l2) (S i) = b).
+  rewrite RList_P29.
+  rewrite H15; rewrite <- minus_n_n; rewrite H10; unfold Rmin in |- *;
+    case (Rle_dec b c); intro; [ reflexivity | elim n; left; assumption ].
+  rewrite H15; apply le_n.
+  induction  l1 as [| r l1 Hrecl1].
+  simpl in H15; discriminate.
+  clear Hrecl1; simpl in H1; simpl in |- *; apply lt_n_S; assumption.
+  assert (H17 : pos_Rl (cons_Rlist l1 l2) i = b).
+  rewrite RList_P26.
+  replace i with (pred (Rlength l1));
+  [ rewrite H4; unfold Rmax in |- *; case (Rle_dec a b); intro;
     [ reflexivity | elim n; left; assumption ]
- | rewrite H15; reflexivity ].
-rewrite H15; apply lt_n_Sn.
-rewrite H16 in H2; rewrite H17 in H2; elim H2; intros;
- elim (Rlt_irrefl _ (Rlt_trans _ _ _ H14 H18)).
-assert (H16 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l2 (i - Rlength l1)).
-apply RList_P29.
-apply le_S_n; assumption.
-apply lt_le_trans with (pred (Rlength (cons_Rlist l1 l2)));
- [ assumption | apply le_pred_n ].
-assert
- (H17 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S (i - Rlength l1))).
-replace (S (i - Rlength l1)) with (S i - Rlength l1)%nat.
-apply RList_P29.
-apply le_S_n; apply le_trans with (S i); [ assumption | apply le_n_Sn ].
-induction  l1 as [| r l1 Hrecl1].
-simpl in H6; discriminate.
-clear Hrecl1; simpl in H1; simpl in |- *; apply lt_n_S; assumption.
-symmetry  in |- *; apply minus_Sn_m; apply le_S_n; assumption.
-assert (H18 : (2 <= Rlength l1)%nat).
-clear f c l2 lf2 H0 H3 H8 H7 H10 H9 H11 H13 i H1 x H2 H12 m H14 H15 H16 H17;
- induction  l1 as [| r l1 Hrecl1].
-discriminate.
-clear Hrecl1; induction  l1 as [| r0 l1 Hrecl1].
-simpl in H5; simpl in H4; assert (H0 : Rmin a b < Rmax a b).
-unfold Rmin, Rmax in |- *; case (Rle_dec a b); intro;
- [ assumption | elim n; left; assumption ].
-rewrite <- H5 in H0; rewrite <- H4 in H0; elim (Rlt_irrefl _ H0).
-clear Hrecl1; simpl in |- *; repeat apply le_n_S; apply le_O_n.
-elim (RList_P20 _ H18); intros r1 [r2 [r3 H19]]; rewrite H19;
- change
-   (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i)
-  in |- *; rewrite RList_P12.
-induction  i as [| i Hreci].
-assert (H20 := le_S_n _ _ H15); assert (H21 := le_trans _ _ _ H18 H20);
- elim (le_Sn_O _ H21).
-clear Hreci; rewrite RList_P13.
-rewrite H19 in H16; rewrite H19 in H17;
- change
-   (pos_Rl (cons_Rlist (cons r2 r3) l2) i =
-    pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) 
-  in H16; rewrite H16;
- change
-   (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) =
-    pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) 
-  in H17; rewrite H17; assert (H20 := H13 (S i - Rlength l1)%nat);
- unfold constant_D_eq, open_interval in H20;
- assert (H21 : (S i - Rlength l1 < pred (Rlength l2))%nat).
-apply lt_pred; rewrite minus_Sn_m.
-apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus.
-rewrite H19 in H1; simpl in H1; rewrite H19; simpl in |- *;
- rewrite RList_P23 in H1; apply lt_n_S; assumption.
-apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ].
-apply le_S_n; assumption.
-assert (H22 := H20 H21); repeat rewrite H22.
-reflexivity.
-rewrite <- H19;
- assert
-  (H23 : pos_Rl l2 (S i - Rlength l1) <= pos_Rl l2 (S (S i - Rlength l1))).
-apply H7; apply lt_pred.
-rewrite minus_Sn_m.
-apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus.
-rewrite H19 in H1; simpl in H1; rewrite H19; simpl in |- *;
- rewrite RList_P23 in H1; apply lt_n_S; assumption.
-apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ].
-apply le_S_n; assumption.
-elim H23; intro.
-split.
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-apply Rmult_lt_reg_l with 2;
- [ prove_sup0
- | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
-    rewrite <- Rinv_r_sym;
-    [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l2 (S i - Rlength l1)));
-       rewrite double; apply Rplus_lt_compat_l; assumption
-    | discrR ] ].
-rewrite <- H19 in H16; rewrite <- H19 in H17; elim H2; intros;
- rewrite H19 in H25; rewrite H19 in H26; simpl in H25; 
- simpl in H16; rewrite H16 in H25; simpl in H26; simpl in H17;
- rewrite H17 in H26; simpl in H24; rewrite H24 in H25;
- elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)).
-assert (H23 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S i - Rlength l1)).
-rewrite H19; simpl in |- *; simpl in H16; apply H16.
-assert
- (H24 :
-  pos_Rl (cons_Rlist l1 l2) (S (S i)) = pos_Rl l2 (S (S i - Rlength l1))).
-rewrite H19; simpl in |- *; simpl in H17; apply H17.
-rewrite <- H23; rewrite <- H24; assumption.
-simpl in |- *; rewrite H19 in H1; simpl in H1; apply lt_S_n; assumption.
-rewrite RList_P14; rewrite H19 in H1; simpl in H1; simpl in |- *; apply H1.
+    | rewrite H15; reflexivity ].
+  rewrite H15; apply lt_n_Sn.
+  rewrite H16 in H2; rewrite H17 in H2; elim H2; intros;
+    elim (Rlt_irrefl _ (Rlt_trans _ _ _ H14 H18)).
+  assert (H16 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l2 (i - Rlength l1)).
+  apply RList_P29.
+  apply le_S_n; assumption.
+  apply lt_le_trans with (pred (Rlength (cons_Rlist l1 l2)));
+    [ assumption | apply le_pred_n ].
+  assert
+    (H17 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S (i - Rlength l1))).
+  replace (S (i - Rlength l1)) with (S i - Rlength l1)%nat.
+  apply RList_P29.
+  apply le_S_n; apply le_trans with (S i); [ assumption | apply le_n_Sn ].
+  induction  l1 as [| r l1 Hrecl1].
+  simpl in H6; discriminate.
+  clear Hrecl1; simpl in H1; simpl in |- *; apply lt_n_S; assumption.
+  symmetry  in |- *; apply minus_Sn_m; apply le_S_n; assumption.
+  assert (H18 : (2 <= Rlength l1)%nat).
+  clear f c l2 lf2 H0 H3 H8 H7 H10 H9 H11 H13 i H1 x H2 H12 m H14 H15 H16 H17;
+    induction  l1 as [| r l1 Hrecl1].
+  discriminate.
+  clear Hrecl1; induction  l1 as [| r0 l1 Hrecl1].
+  simpl in H5; simpl in H4; assert (H0 : Rmin a b < Rmax a b).
+  unfold Rmin, Rmax in |- *; case (Rle_dec a b); intro;
+    [ assumption | elim n; left; assumption ].
+  rewrite <- H5 in H0; rewrite <- H4 in H0; elim (Rlt_irrefl _ H0).
+  clear Hrecl1; simpl in |- *; repeat apply le_n_S; apply le_O_n.
+  elim (RList_P20 _ H18); intros r1 [r2 [r3 H19]]; rewrite H19;
+    change
+      (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i)
+      in |- *; rewrite RList_P12.
+  induction  i as [| i Hreci].
+  assert (H20 := le_S_n _ _ H15); assert (H21 := le_trans _ _ _ H18 H20);
+    elim (le_Sn_O _ H21).
+  clear Hreci; rewrite RList_P13.
+  rewrite H19 in H16; rewrite H19 in H17;
+    change
+      (pos_Rl (cons_Rlist (cons r2 r3) l2) i =
+        pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) 
+      in H16; rewrite H16;
+        change
+          (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) =
+            pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) 
+          in H17; rewrite H17; assert (H20 := H13 (S i - Rlength l1)%nat);
+            unfold constant_D_eq, open_interval in H20;
+              assert (H21 : (S i - Rlength l1 < pred (Rlength l2))%nat).
+  apply lt_pred; rewrite minus_Sn_m.
+  apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus.
+  rewrite H19 in H1; simpl in H1; rewrite H19; simpl in |- *;
+    rewrite RList_P23 in H1; apply lt_n_S; assumption.
+  apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ].
+  apply le_S_n; assumption.
+  assert (H22 := H20 H21); repeat rewrite H22.
+  reflexivity.
+  rewrite <- H19;
+    assert
+      (H23 : pos_Rl l2 (S i - Rlength l1) <= pos_Rl l2 (S (S i - Rlength l1))).
+  apply H7; apply lt_pred.
+  rewrite minus_Sn_m.
+  apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus.
+  rewrite H19 in H1; simpl in H1; rewrite H19; simpl in |- *;
+    rewrite RList_P23 in H1; apply lt_n_S; assumption.
+  apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ].
+  apply le_S_n; assumption.
+  elim H23; intro.
+  split.
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  apply Rmult_lt_reg_l with 2;
+    [ prove_sup0
+      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+        rewrite <- Rinv_r_sym;
+          [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l2 (S i - Rlength l1)));
+            rewrite double; apply Rplus_lt_compat_l; assumption
+            | discrR ] ].
+  rewrite <- H19 in H16; rewrite <- H19 in H17; elim H2; intros;
+    rewrite H19 in H25; rewrite H19 in H26; simpl in H25; 
+      simpl in H16; rewrite H16 in H25; simpl in H26; simpl in H17;
+        rewrite H17 in H26; simpl in H24; rewrite H24 in H25;
+          elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)).
+  assert (H23 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S i - Rlength l1)).
+  rewrite H19; simpl in |- *; simpl in H16; apply H16.
+  assert
+    (H24 :
+      pos_Rl (cons_Rlist l1 l2) (S (S i)) = pos_Rl l2 (S (S i - Rlength l1))).
+  rewrite H19; simpl in |- *; simpl in H17; apply H17.
+  rewrite <- H23; rewrite <- H24; assumption.
+  simpl in |- *; rewrite H19 in H1; simpl in H1; apply lt_S_n; assumption.
+  rewrite RList_P14; rewrite H19 in H1; simpl in H1; simpl in |- *; apply H1.
 Qed.
 
 Lemma StepFun_P41 :
- forall (f:R -> R) (a b c:R),
-   a <= b -> b <= c -> IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c.
-unfold IsStepFun in |- *; unfold is_subdivision in |- *; intros; elim X;
- clear X; intros l1 [lf1 H1]; elim X0; clear X0; intros l2 [lf2 H2];
- case (total_order_T a b); intro.
-elim s; intro.
-case (total_order_T b c); intro.
-elim s0; intro.
-split with (cons_Rlist l1 l2); split with (FF (cons_Rlist l1 l2) f);
- apply StepFun_P40 with b lf1 lf2; assumption.
-split with l1; split with lf1; rewrite b0 in H1; assumption.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
-split with l2; split with lf2; rewrite <- b0 in H2; assumption.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  forall (f:R -> R) (a b c:R),
+    a <= b -> b <= c -> IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c.
+Proof.
+  intros f a b c H H0 (l1,(lf1,H1)) (l2,(lf2,H2));
+    destruct (total_order_T a b) as [[Hltab|Hab]|Hgtab].
+  destruct (total_order_T b c) as [[Hltbc|Hbc]|Hgtbc].
+  exists (cons_Rlist l1 l2); exists (FF (cons_Rlist l1 l2) f);
+    apply StepFun_P40 with b lf1 lf2; assumption.
+  exists l1; exists lf1; rewrite Hbc in H1; assumption.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgtbc)).
+  exists l2; exists lf2; rewrite <- Hab in H2; assumption.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgtab)).
 Qed.
 
 Lemma StepFun_P42 :
- forall (l1 l2:Rlist) (f:R -> R),
-   pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 0 ->
-   Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2) =
-   Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2.
-intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H;
- [ simpl in |- *; ring
- | destruct l1 as [| r0 r1];
-    [ simpl in H; simpl in |- *; destruct l2 as [| r0 r1];
-       [ simpl in |- *; ring | simpl in |- *; simpl in H; rewrite H; ring ]
-    | simpl in |- *; rewrite Rplus_assoc; apply Rplus_eq_compat_l; apply IHl1;
-       rewrite <- H; reflexivity ] ].
+  forall (l1 l2:Rlist) (f:R -> R),
+    pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 0 ->
+    Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2) =
+    Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2.
+Proof. 
+  intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H;
+    [ simpl in |- *; ring
+      | destruct l1 as [| r0 r1];
+        [ simpl in H; simpl in |- *; destruct l2 as [| r0 r1];
+          [ simpl in |- *; ring | simpl in |- *; simpl in H; rewrite H; ring ]
+          | simpl in |- *; rewrite Rplus_assoc; apply Rplus_eq_compat_l; apply IHl1;
+            rewrite <- H; reflexivity ] ].
 Qed.
 
 Lemma StepFun_P43 :
- forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) 
-   (pr2:IsStepFun f b c) (pr3:IsStepFun f a c),
-   RiemannInt_SF (mkStepFun pr1) + RiemannInt_SF (mkStepFun pr2) =
-   RiemannInt_SF (mkStepFun pr3).
-intros f; intros;
- assert
-  (H1 :
-   sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a b l l0))).
-apply pr1.
-assert
- (H2 :
-  sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f b c l l0))).
-apply pr2.
-assert
- (H3 :
-  sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a c l l0))).
-apply pr3.
-elim H1; clear H1; intros l1 [lf1 H1]; elim H2; clear H2; intros l2 [lf2 H2];
- elim H3; clear H3; intros l3 [lf3 H3].
-replace (RiemannInt_SF (mkStepFun pr1)) with
- match Rle_dec a b with
- | left _ => Int_SF lf1 l1
- | right _ => - Int_SF lf1 l1
- end.
-replace (RiemannInt_SF (mkStepFun pr2)) with
- match Rle_dec b c with
- | left _ => Int_SF lf2 l2
- | right _ => - Int_SF lf2 l2
- end.
-replace (RiemannInt_SF (mkStepFun pr3)) with
- match Rle_dec a c with
- | left _ => Int_SF lf3 l3
- | right _ => - Int_SF lf3 l3
- end.
-case (Rle_dec a b); case (Rle_dec b c); case (Rle_dec a c); intros.
-elim r1; intro.
-elim r0; intro.
-replace (Int_SF lf3 l3) with
- (Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)).
-replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-symmetry  in |- *; apply StepFun_P42.
-unfold adapted_couple in H1, H2; decompose [and] H1; decompose [and] H2;
- clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
- case (Rle_dec a b); case (Rle_dec b c); intros; reflexivity || elim n;
- assumption.
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2;
-    assumption
- | assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
- | assumption ].
-eapply StepFun_P17; [ apply (StepFun_P40 H H0 H1 H2) | apply H3 ].
-replace (Int_SF lf2 l2) with 0.
-rewrite Rplus_0_r; eapply StepFun_P17;
- [ apply H1 | rewrite <- H0 in H3; apply H3 ].
-symmetry  in |- *; eapply StepFun_P8; [ apply H2 | assumption ].
-replace (Int_SF lf1 l1) with 0.
-rewrite Rplus_0_l; eapply StepFun_P17;
- [ apply H2 | rewrite H in H3; apply H3 ].
-symmetry  in |- *; eapply StepFun_P8; [ apply H1 | assumption ].
-elim n; apply Rle_trans with b; assumption.
-apply Rplus_eq_reg_l with (Int_SF lf2 l2);
- replace (Int_SF lf2 l2 + (Int_SF lf1 l1 + - Int_SF lf2 l2)) with
-  (Int_SF lf1 l1); [ idtac | ring ].
-assert (H : c < b).
-auto with real.
-elim r; intro.
-rewrite Rplus_comm;
- replace (Int_SF lf1 l1) with
-  (Int_SF (FF (cons_Rlist l3 l2) f) (cons_Rlist l3 l2)).
-replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
-replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-apply StepFun_P42.
-unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
- clear H3 H2; rewrite H10; rewrite H6; unfold Rmax, Rmin in |- *;
- case (Rle_dec a c); case (Rle_dec b c); intros;
- [ elim n; assumption
- | reflexivity
- | elim n0; assumption
- | elim n1; assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
- | assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
- | assumption ].
-eapply StepFun_P17;
- [ apply (StepFun_P40 H0 H H3 (StepFun_P2 H2)) | apply H1 ].
-replace (Int_SF lf3 l3) with 0.
-rewrite Rplus_0_r; eapply StepFun_P17;
- [ apply H1 | apply StepFun_P2; rewrite <- H0 in H2; apply H2 ].
-symmetry  in |- *; eapply StepFun_P8; [ apply H3 | assumption ].
-replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
-ring.
-elim r; intro.
-replace (Int_SF lf2 l2) with
- (Int_SF (FF (cons_Rlist l3 l1) f) (cons_Rlist l3 l1)).
-replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
-replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-symmetry  in |- *; apply StepFun_P42.
-unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
- clear H3 H1; rewrite H9; rewrite H5; unfold Rmax, Rmin in |- *;
- case (Rle_dec a c); case (Rle_dec a b); intros;
- [ elim n; assumption
- | elim n1; assumption
- | reflexivity
- | elim n1; assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
- | assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
- | assumption ].
-eapply StepFun_P17.
-assert (H0 : c < a).
-auto with real.
-apply (StepFun_P40 H0 H (StepFun_P2 H3) H1).
-apply StepFun_P2; apply H2.
-replace (Int_SF lf1 l1) with 0.
-rewrite Rplus_0_r; eapply StepFun_P17;
- [ apply H3 | rewrite <- H in H2; apply H2 ].
-symmetry  in |- *; eapply StepFun_P8; [ apply H1 | assumption ].
-assert (H : b < a).
-auto with real.
-replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
-ring.
-rewrite Rplus_comm; elim r; intro.
-replace (Int_SF lf2 l2) with
- (Int_SF (FF (cons_Rlist l1 l3) f) (cons_Rlist l1 l3)).
-replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
-replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-symmetry  in |- *; apply StepFun_P42.
-unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
- clear H3 H1; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
- case (Rle_dec a c); case (Rle_dec a b); intros;
- [ elim n; assumption
- | reflexivity
- | elim n0; assumption
- | elim n1; assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
- | assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
- | assumption ].
-eapply StepFun_P17.
-apply (StepFun_P40 H H0 (StepFun_P2 H1) H3).
-apply H2.
-replace (Int_SF lf3 l3) with 0.
-rewrite Rplus_0_r; eapply StepFun_P17;
- [ apply H1 | rewrite <- H0 in H2; apply StepFun_P2; apply H2 ].
-symmetry  in |- *; eapply StepFun_P8; [ apply H3 | assumption ].
-assert (H : c < a).
-auto with real.
-replace (Int_SF lf1 l1) with (Int_SF lf2 l2 + Int_SF lf3 l3).
-ring.
-elim r; intro.
-replace (Int_SF lf1 l1) with
- (Int_SF (FF (cons_Rlist l2 l3) f) (cons_Rlist l2 l3)).
-replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
-replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-symmetry  in |- *; apply StepFun_P42.
-unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
- clear H3 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
- case (Rle_dec a c); case (Rle_dec b c); intros;
- [ elim n; assumption
- | elim n1; assumption
- | reflexivity
- | elim n1; assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
- | assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
- | assumption ].
-eapply StepFun_P17.
-apply (StepFun_P40 H0 H H2 (StepFun_P2 H3)).
-apply StepFun_P2; apply H1.
-replace (Int_SF lf2 l2) with 0.
-rewrite Rplus_0_l; eapply StepFun_P17;
- [ apply H3 | rewrite H0 in H1; apply H1 ].
-symmetry  in |- *; eapply StepFun_P8; [ apply H2 | assumption ].
-elim n; apply Rle_trans with a; try assumption.
-auto with real.
-assert (H : c < b).
-auto with real.
-assert (H0 : b < a).
-auto with real.
-replace (Int_SF lf3 l3) with (Int_SF lf2 l2 + Int_SF lf1 l1).
-ring.
-replace (Int_SF lf3 l3) with
- (Int_SF (FF (cons_Rlist l2 l1) f) (cons_Rlist l2 l1)).
-replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-symmetry  in |- *; apply StepFun_P42.
-unfold adapted_couple in H2, H1; decompose [and] H2; decompose [and] H1;
- clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
- case (Rle_dec a b); case (Rle_dec b c); intros;
- [ elim n1; assumption
- | elim n1; assumption
- | elim n0; assumption
- | reflexivity ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
- | assumption ].
-eapply StepFun_P17;
- [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
- | assumption ].
-eapply StepFun_P17.
-apply (StepFun_P40 H H0 (StepFun_P2 H2) (StepFun_P2 H1)).
-apply StepFun_P2; apply H3.
-unfold RiemannInt_SF in |- *; case (Rle_dec a c); intro.
-eapply StepFun_P17.
-apply H3.
-change
-  (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun pr3))
-     (subdivision_val (mkStepFun pr3))) in |- *; apply StepFun_P1.
-apply Ropp_eq_compat; eapply StepFun_P17.
-apply H3.
-change
-  (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun pr3))
-     (subdivision_val (mkStepFun pr3))) in |- *; apply StepFun_P1.
-unfold RiemannInt_SF in |- *; case (Rle_dec b c); intro.
-eapply StepFun_P17.
-apply H2.
-change
-  (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun pr2))
-     (subdivision_val (mkStepFun pr2))) in |- *; apply StepFun_P1.
-apply Ropp_eq_compat; eapply StepFun_P17.
-apply H2.
-change
-  (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun pr2))
-     (subdivision_val (mkStepFun pr2))) in |- *; apply StepFun_P1.
-unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
-eapply StepFun_P17.
-apply H1.
-change
-  (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun pr1))
-     (subdivision_val (mkStepFun pr1))) in |- *; apply StepFun_P1.
-apply Ropp_eq_compat; eapply StepFun_P17.
-apply H1.
-change
-  (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun pr1))
-     (subdivision_val (mkStepFun pr1))) in |- *; apply StepFun_P1.
+  forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) 
+    (pr2:IsStepFun f b c) (pr3:IsStepFun f a c),
+    RiemannInt_SF (mkStepFun pr1) + RiemannInt_SF (mkStepFun pr2) =
+    RiemannInt_SF (mkStepFun pr3).
+Proof. 
+  intros f; intros;
+    assert
+      (H1 :
+        sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a b l l0))).
+  apply pr1.
+  assert
+    (H2 :
+      sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f b c l l0))).
+  apply pr2.
+  assert
+    (H3 :
+      sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a c l l0))).
+  apply pr3.
+  elim H1; clear H1; intros l1 [lf1 H1]; elim H2; clear H2; intros l2 [lf2 H2];
+    elim H3; clear H3; intros l3 [lf3 H3].
+  replace (RiemannInt_SF (mkStepFun pr1)) with
+  match Rle_dec a b with
+    | left _ => Int_SF lf1 l1
+    | right _ => - Int_SF lf1 l1
+  end.
+  replace (RiemannInt_SF (mkStepFun pr2)) with
+  match Rle_dec b c with
+    | left _ => Int_SF lf2 l2
+    | right _ => - Int_SF lf2 l2
+  end.
+  replace (RiemannInt_SF (mkStepFun pr3)) with
+  match Rle_dec a c with
+    | left _ => Int_SF lf3 l3
+    | right _ => - Int_SF lf3 l3
+  end.
+  case (Rle_dec a b); case (Rle_dec b c); case (Rle_dec a c); intros.
+  elim r1; intro.
+  elim r0; intro.
+  replace (Int_SF lf3 l3) with
+  (Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)).
+  replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
+  replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
+  symmetry  in |- *; apply StepFun_P42.
+  unfold adapted_couple in H1, H2; decompose [and] H1; decompose [and] H2;
+    clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+      case (Rle_dec a b); case (Rle_dec b c); intros; reflexivity || elim n;
+        assumption.
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2;
+      assumption
+      | assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+      | assumption ].
+  eapply StepFun_P17; [ apply (StepFun_P40 H H0 H1 H2) | apply H3 ].
+  replace (Int_SF lf2 l2) with 0.
+  rewrite Rplus_0_r; eapply StepFun_P17;
+    [ apply H1 | rewrite <- H0 in H3; apply H3 ].
+  symmetry  in |- *; eapply StepFun_P8; [ apply H2 | assumption ].
+  replace (Int_SF lf1 l1) with 0.
+  rewrite Rplus_0_l; eapply StepFun_P17;
+    [ apply H2 | rewrite H in H3; apply H3 ].
+  symmetry  in |- *; eapply StepFun_P8; [ apply H1 | assumption ].
+  elim n; apply Rle_trans with b; assumption.
+  apply Rplus_eq_reg_l with (Int_SF lf2 l2);
+    replace (Int_SF lf2 l2 + (Int_SF lf1 l1 + - Int_SF lf2 l2)) with
+    (Int_SF lf1 l1); [ idtac | ring ].
+  assert (H : c < b).
+  auto with real.
+  elim r; intro.
+  rewrite Rplus_comm;
+    replace (Int_SF lf1 l1) with
+    (Int_SF (FF (cons_Rlist l3 l2) f) (cons_Rlist l3 l2)).
+  replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
+  replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
+  apply StepFun_P42.
+  unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
+    clear H3 H2; rewrite H10; rewrite H6; unfold Rmax, Rmin in |- *;
+      case (Rle_dec a c); case (Rle_dec b c); intros;
+        [ elim n; assumption
+          | reflexivity
+          | elim n0; assumption
+          | elim n1; assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+      | assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+      | assumption ].
+  eapply StepFun_P17;
+    [ apply (StepFun_P40 H0 H H3 (StepFun_P2 H2)) | apply H1 ].
+  replace (Int_SF lf3 l3) with 0.
+  rewrite Rplus_0_r; eapply StepFun_P17;
+    [ apply H1 | apply StepFun_P2; rewrite <- H0 in H2; apply H2 ].
+  symmetry  in |- *; eapply StepFun_P8; [ apply H3 | assumption ].
+  replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
+  ring.
+  elim r; intro.
+  replace (Int_SF lf2 l2) with
+  (Int_SF (FF (cons_Rlist l3 l1) f) (cons_Rlist l3 l1)).
+  replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
+  replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
+  symmetry  in |- *; apply StepFun_P42.
+  unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
+    clear H3 H1; rewrite H9; rewrite H5; unfold Rmax, Rmin in |- *;
+      case (Rle_dec a c); case (Rle_dec a b); intros;
+        [ elim n; assumption
+          | elim n1; assumption
+          | reflexivity
+          | elim n1; assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+      | assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+      | assumption ].
+  eapply StepFun_P17.
+  assert (H0 : c < a).
+  auto with real.
+  apply (StepFun_P40 H0 H (StepFun_P2 H3) H1).
+  apply StepFun_P2; apply H2.
+  replace (Int_SF lf1 l1) with 0.
+  rewrite Rplus_0_r; eapply StepFun_P17;
+    [ apply H3 | rewrite <- H in H2; apply H2 ].
+  symmetry  in |- *; eapply StepFun_P8; [ apply H1 | assumption ].
+  assert (H : b < a).
+  auto with real.
+  replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
+  ring.
+  rewrite Rplus_comm; elim r; intro.
+  replace (Int_SF lf2 l2) with
+  (Int_SF (FF (cons_Rlist l1 l3) f) (cons_Rlist l1 l3)).
+  replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
+  replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
+  symmetry  in |- *; apply StepFun_P42.
+  unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
+    clear H3 H1; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+      case (Rle_dec a c); case (Rle_dec a b); intros;
+        [ elim n; assumption
+          | reflexivity
+          | elim n0; assumption
+          | elim n1; assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+      | assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+      | assumption ].
+  eapply StepFun_P17.
+  apply (StepFun_P40 H H0 (StepFun_P2 H1) H3).
+  apply H2.
+  replace (Int_SF lf3 l3) with 0.
+  rewrite Rplus_0_r; eapply StepFun_P17;
+    [ apply H1 | rewrite <- H0 in H2; apply StepFun_P2; apply H2 ].
+  symmetry  in |- *; eapply StepFun_P8; [ apply H3 | assumption ].
+  assert (H : c < a).
+  auto with real.
+  replace (Int_SF lf1 l1) with (Int_SF lf2 l2 + Int_SF lf3 l3).
+  ring.
+  elim r; intro.
+  replace (Int_SF lf1 l1) with
+  (Int_SF (FF (cons_Rlist l2 l3) f) (cons_Rlist l2 l3)).
+  replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
+  replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
+  symmetry  in |- *; apply StepFun_P42.
+  unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
+    clear H3 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+      case (Rle_dec a c); case (Rle_dec b c); intros;
+        [ elim n; assumption
+          | elim n1; assumption
+          | reflexivity
+          | elim n1; assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+      | assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+      | assumption ].
+  eapply StepFun_P17.
+  apply (StepFun_P40 H0 H H2 (StepFun_P2 H3)).
+  apply StepFun_P2; apply H1.
+  replace (Int_SF lf2 l2) with 0.
+  rewrite Rplus_0_l; eapply StepFun_P17;
+    [ apply H3 | rewrite H0 in H1; apply H1 ].
+  symmetry  in |- *; eapply StepFun_P8; [ apply H2 | assumption ].
+  elim n; apply Rle_trans with a; try assumption.
+  auto with real.
+  assert (H : c < b).
+  auto with real.
+  assert (H0 : b < a).
+  auto with real.
+  replace (Int_SF lf3 l3) with (Int_SF lf2 l2 + Int_SF lf1 l1).
+  ring.
+  replace (Int_SF lf3 l3) with
+  (Int_SF (FF (cons_Rlist l2 l1) f) (cons_Rlist l2 l1)).
+  replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
+  replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
+  symmetry  in |- *; apply StepFun_P42.
+  unfold adapted_couple in H2, H1; decompose [and] H2; decompose [and] H1;
+    clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+      case (Rle_dec a b); case (Rle_dec b c); intros;
+        [ elim n1; assumption
+          | elim n1; assumption
+          | elim n0; assumption
+          | reflexivity ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+      | assumption ].
+  eapply StepFun_P17;
+    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+      | assumption ].
+  eapply StepFun_P17.
+  apply (StepFun_P40 H H0 (StepFun_P2 H2) (StepFun_P2 H1)).
+  apply StepFun_P2; apply H3.
+  unfold RiemannInt_SF in |- *; case (Rle_dec a c); intro.
+  eapply StepFun_P17.
+  apply H3.
+  change
+    (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun pr3))
+      (subdivision_val (mkStepFun pr3))) in |- *; apply StepFun_P1.
+  apply Ropp_eq_compat; eapply StepFun_P17.
+  apply H3.
+  change
+    (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun pr3))
+      (subdivision_val (mkStepFun pr3))) in |- *; apply StepFun_P1.
+  unfold RiemannInt_SF in |- *; case (Rle_dec b c); intro.
+  eapply StepFun_P17.
+  apply H2.
+  change
+    (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun pr2))
+      (subdivision_val (mkStepFun pr2))) in |- *; apply StepFun_P1.
+  apply Ropp_eq_compat; eapply StepFun_P17.
+  apply H2.
+  change
+    (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun pr2))
+      (subdivision_val (mkStepFun pr2))) in |- *; apply StepFun_P1.
+  unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  eapply StepFun_P17.
+  apply H1.
+  change
+    (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun pr1))
+      (subdivision_val (mkStepFun pr1))) in |- *; apply StepFun_P1.
+  apply Ropp_eq_compat; eapply StepFun_P17.
+  apply H1.
+  change
+    (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun pr1))
+      (subdivision_val (mkStepFun pr1))) in |- *; apply StepFun_P1.
 Qed.
 
 Lemma StepFun_P44 :
- forall (f:R -> R) (a b c:R),
-   IsStepFun f a b -> a <= c <= b -> IsStepFun f a c.
-intros f; intros; assert (H0 : a <= b).
-elim H; intros; apply Rle_trans with c; assumption.
-elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
- elim X; clear X; intros l1 [lf1 H2];
- cut
-  (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R),
-     adapted_couple f a b l1 lf1 ->
-     a <= c <= b ->
-     sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a c l l0))).
-intros; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X.
-apply H2.
-split; assumption.
-clear f a b c H0 H H1 H2 l1 lf1; simple induction l1.
-intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
- discriminate.
-simple induction r0.
-intros; assert (H1 : a = b).
-unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3;
- simpl in H2; assert (H7 : a <= b).
-elim H0; intros; apply Rle_trans with c; assumption.
-replace a with (Rmin a b).
-pattern b at 2 in |- *; replace b with (Rmax a b).
-rewrite <- H2; rewrite H3; reflexivity.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-split with (cons r nil); split with lf1; assert (H2 : c = b).
-rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
-rewrite H2; assumption.
-intros; clear X; induction  lf1 as [| r3 lf1 Hreclf1].
-unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
- discriminate.
-clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}).
-case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
-elim H1; intro.
-split with (cons r (cons c nil)); split with (cons r3 nil);
- unfold adapted_couple in H; decompose [and] H; clear H; 
- assert (H6 : r = a).
-simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity
- | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
-elim H0; clear H0; intros; unfold adapted_couple in |- *; repeat split.
-rewrite H6; unfold ordered_Rlist in |- *; intros; simpl in H8; inversion H8;
- [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
-simpl in |- *; unfold Rmin in |- *; case (Rle_dec a c); intro;
- [ assumption | elim n; assumption ].
-simpl in |- *; unfold Rmax in |- *; case (Rle_dec a c); intro;
- [ reflexivity | elim n; assumption ].
-unfold constant_D_eq, open_interval in |- *; intros; simpl in H8;
- inversion H8.
-simpl in |- *; assert (H10 := H7 0%nat);
- assert (H12 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
-simpl in |- *; apply lt_O_Sn.
-apply (H10 H12); unfold open_interval in |- *; simpl in |- *;
- rewrite H11 in H9; simpl in H9; elim H9; clear H9; 
- intros; split; try assumption.
-apply Rlt_le_trans with c; assumption.
-elim (le_Sn_O _ H11).
-cut (adapted_couple f r1 b (cons r1 r2) lf1).
-cut (r1 <= c <= b).
-intros.
-elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with (cons r l1');
- split with (cons r3 lf1'); unfold adapted_couple in H, H4; 
- decompose [and] H; decompose [and] H4; clear H H4 X0; 
- assert (H14 : a <= b).
-elim H0; intros; apply Rle_trans with c; assumption.
-assert (H16 : r = a).
-simpl in H7; rewrite H7; unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-induction  l1' as [| r4 l1' Hrecl1'].
-simpl in H13; discriminate.
-clear Hrecl1'; unfold adapted_couple in |- *; repeat split.
-unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
-simpl in |- *; replace r4 with r1.
-apply (H5 0%nat).
-simpl in |- *; apply lt_O_Sn.
-simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
- [ reflexivity | elim n; left; assumption ].
-apply (H9 i); simpl in |- *; apply lt_S_n; assumption.
-simpl in |- *; unfold Rmin in |- *; case (Rle_dec a c); intro;
- [ assumption | elim n; elim H0; intros; assumption ].
-replace (Rmax a c) with (Rmax r1 c).
-rewrite <- H11; reflexivity.
-unfold Rmax in |- *; case (Rle_dec r1 c); case (Rle_dec a c); intros;
- [ reflexivity
- | elim n; elim H0; intros; assumption
- | elim n; left; assumption
- | elim n0; left; assumption ].
-simpl in |- *; simpl in H13; rewrite H13; reflexivity.
-intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
- induction  i as [| i Hreci].
-simpl in |- *; assert (H17 := H10 0%nat);
- assert (H18 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
-simpl in |- *; apply lt_O_Sn.
-apply (H17 H18); unfold open_interval in |- *; simpl in |- *; simpl in H4;
- elim H4; clear H4; intros; split; try assumption; 
- replace r1 with r4.
-assumption.
-simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
- [ reflexivity | elim n; left; assumption ].
-clear Hreci; simpl in |- *; apply H15.
-simpl in |- *; apply lt_S_n; assumption.
-unfold open_interval in |- *; apply H4.
-split.
-left; assumption.
-elim H0; intros; assumption.
-eapply StepFun_P7;
- [ elim H0; intros; apply Rle_trans with c; [ apply H2 | apply H3 ]
- | apply H ].
+  forall (f:R -> R) (a b c:R),
+    IsStepFun f a b -> a <= c <= b -> IsStepFun f a c.
+Proof. 
+  intros f; intros; assert (H0 : a <= b).
+  elim H; intros; apply Rle_trans with c; assumption.
+  elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
+    elim X; clear X; intros l1 [lf1 H2];
+      cut
+        (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R),
+          adapted_couple f a b l1 lf1 ->
+          a <= c <= b ->
+          sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f a c l l0))).
+  intro X; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X.
+  apply H2.
+  split; assumption.
+  clear f a b c H0 H H1 H2 l1 lf1; simple induction l1.
+  intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
+    discriminate.
+  simple induction r0.
+  intros X lf1 a b c f H H0; assert (H1 : a = b).
+  unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3;
+    simpl in H2; assert (H7 : a <= b).
+  elim H0; intros; apply Rle_trans with c; assumption.
+  replace a with (Rmin a b).
+  pattern b at 2 in |- *; replace b with (Rmax a b).
+  rewrite <- H2; rewrite H3; reflexivity.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  split with (cons r nil); split with lf1; assert (H2 : c = b).
+  rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
+  rewrite H2; assumption.
+  intros r1 r2 _ X0 lf1 a b c f H H0; induction  lf1 as [| r3 lf1 Hreclf1].
+  unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
+    discriminate.
+  clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}).
+  case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
+  elim H1; intro.
+  split with (cons r (cons c nil)); split with (cons r3 nil);
+    unfold adapted_couple in H; decompose [and] H; clear H; 
+      assert (H6 : r = a).
+  simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity
+      | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
+  elim H0; clear H0; intros; unfold adapted_couple in |- *; repeat split.
+  rewrite H6; unfold ordered_Rlist in |- *; intros; simpl in H8; inversion H8;
+    [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
+  simpl in |- *; unfold Rmin in |- *; case (Rle_dec a c); intro;
+    [ assumption | elim n; assumption ].
+  simpl in |- *; unfold Rmax in |- *; case (Rle_dec a c); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold constant_D_eq, open_interval in |- *; intros; simpl in H8;
+    inversion H8.
+  simpl in |- *; assert (H10 := H7 0%nat);
+    assert (H12 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
+  simpl in |- *; apply lt_O_Sn.
+  apply (H10 H12); unfold open_interval in |- *; simpl in |- *;
+    rewrite H11 in H9; simpl in H9; elim H9; clear H9; 
+      intros; split; try assumption.
+  apply Rlt_le_trans with c; assumption.
+  elim (le_Sn_O _ H11).
+  cut (adapted_couple f r1 b (cons r1 r2) lf1).
+  cut (r1 <= c <= b).
+  intros.
+  elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with (cons r l1');
+    split with (cons r3 lf1'); unfold adapted_couple in H, H4; 
+      decompose [and] H; decompose [and] H4; clear H H4 X0; 
+        assert (H14 : a <= b).
+  elim H0; intros; apply Rle_trans with c; assumption.
+  assert (H16 : r = a).
+  simpl in H7; rewrite H7; unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  induction  l1' as [| r4 l1' Hrecl1'].
+  simpl in H13; discriminate.
+  clear Hrecl1'; unfold adapted_couple in |- *; repeat split.
+  unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
+  simpl in |- *; replace r4 with r1.
+  apply (H5 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
+    [ reflexivity | elim n; left; assumption ].
+  apply (H9 i); simpl in |- *; apply lt_S_n; assumption.
+  simpl in |- *; unfold Rmin in |- *; case (Rle_dec a c); intro;
+    [ assumption | elim n; elim H0; intros; assumption ].
+  replace (Rmax a c) with (Rmax r1 c).
+  rewrite <- H11; reflexivity.
+  unfold Rmax in |- *; case (Rle_dec r1 c); case (Rle_dec a c); intros;
+    [ reflexivity
+      | elim n; elim H0; intros; assumption
+      | elim n; left; assumption
+      | elim n0; left; assumption ].
+  simpl in |- *; simpl in H13; rewrite H13; reflexivity.
+  intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+    induction  i as [| i Hreci].
+  simpl in |- *; assert (H17 := H10 0%nat);
+    assert (H18 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
+  simpl in |- *; apply lt_O_Sn.
+  apply (H17 H18); unfold open_interval in |- *; simpl in |- *; simpl in H4;
+    elim H4; clear H4; intros; split; try assumption; 
+      replace r1 with r4.
+  assumption.
+  simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
+    [ reflexivity | elim n; left; assumption ].
+  clear Hreci; simpl in |- *; apply H15.
+  simpl in |- *; apply lt_S_n; assumption.
+  unfold open_interval in |- *; apply H4.
+  split.
+  left; assumption.
+  elim H0; intros; assumption.
+  eapply StepFun_P7;
+    [ elim H0; intros; apply Rle_trans with c; [ apply H2 | apply H3 ]
+      | apply H ].
 Qed.
 
 Lemma StepFun_P45 :
- forall (f:R -> R) (a b c:R),
-   IsStepFun f a b -> a <= c <= b -> IsStepFun f c b.
-intros f; intros; assert (H0 : a <= b).
-elim H; intros; apply Rle_trans with c; assumption.
-elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
- elim X; clear X; intros l1 [lf1 H2];
- cut
-  (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R),
-     adapted_couple f a b l1 lf1 ->
-     a <= c <= b ->
-     sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f c b l l0))).
-intros; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X;
- [ apply H2 | split; assumption ].
-clear f a b c H0 H H1 H2 l1 lf1; simple induction l1.
-intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
- discriminate.
-simple induction r0.
-intros; assert (H1 : a = b).
-unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3;
- simpl in H2; assert (H7 : a <= b).
-elim H0; intros; apply Rle_trans with c; assumption.
-replace a with (Rmin a b).
-pattern b at 2 in |- *; replace b with (Rmax a b).
-rewrite <- H2; rewrite H3; reflexivity.
-unfold Rmax in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-unfold Rmin in |- *; case (Rle_dec a b); intro;
- [ reflexivity | elim n; assumption ].
-split with (cons r nil); split with lf1; assert (H2 : c = b).
-rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
-rewrite <- H2 in H1; rewrite <- H1; assumption.
-intros; clear X; induction  lf1 as [| r3 lf1 Hreclf1].
-unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
- discriminate.
-clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}).
-case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
-elim H1; intro.
-split with (cons c (cons r1 r2)); split with (cons r3 lf1);
- unfold adapted_couple in H; decompose [and] H; clear H;
- unfold adapted_couple in |- *; repeat split.
-unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
-simpl in |- *; assumption.
-clear Hreci; apply (H2 (S i)); simpl in |- *; assumption.
-simpl in |- *; unfold Rmin in |- *; case (Rle_dec c b); intro;
- [ reflexivity | elim n; elim H0; intros; assumption ].
-replace (Rmax c b) with (Rmax a b).
-rewrite <- H3; reflexivity.
-unfold Rmax in |- *; case (Rle_dec a b); case (Rle_dec c b); intros;
- [ reflexivity
- | elim n; elim H0; intros; assumption
- | elim n; elim H0; intros; apply Rle_trans with c; assumption
- | elim n0; elim H0; intros; apply Rle_trans with c; assumption ].
-simpl in |- *; simpl in H5; apply H5.
-intros; simpl in H; induction  i as [| i Hreci].
-unfold constant_D_eq, open_interval in |- *; intros; simpl in |- *;
- apply (H7 0%nat).
-simpl in |- *; apply lt_O_Sn.
-unfold open_interval in |- *; simpl in |- *; simpl in H6; elim H6; clear H6;
- intros; split; try assumption; apply Rle_lt_trans with c; 
- try assumption; replace r with a.
-elim H0; intros; assumption.
-simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intros;
- [ reflexivity
- | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
-clear Hreci; apply (H7 (S i)); simpl in |- *; assumption.
-cut (adapted_couple f r1 b (cons r1 r2) lf1).
-cut (r1 <= c <= b).
-intros; elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with l1';
- split with lf1'; assumption.
-split; [ left; assumption | elim H0; intros; assumption ].
-eapply StepFun_P7;
- [ elim H0; intros; apply Rle_trans with c; [ apply H2 | apply H3 ]
- | apply H ].
+  forall (f:R -> R) (a b c:R),
+    IsStepFun f a b -> a <= c <= b -> IsStepFun f c b.
+Proof. 
+  intros f; intros; assert (H0 : a <= b).
+  elim H; intros; apply Rle_trans with c; assumption.
+  elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X;
+    elim X; clear X; intros l1 [lf1 H2];
+      cut
+        (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R),
+          adapted_couple f a b l1 lf1 ->
+          a <= c <= b ->
+          sigT (fun l:Rlist => sigT (fun l0:Rlist => adapted_couple f c b l l0))).
+  intro X; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X;
+    [ apply H2 | split; assumption ].
+  clear f a b c H0 H H1 H2 l1 lf1; simple induction l1.
+  intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
+    discriminate.
+  simple induction r0.
+  intros X lf1 a b c f H H0; assert (H1 : a = b).
+  unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3;
+    simpl in H2; assert (H7 : a <= b).
+  elim H0; intros; apply Rle_trans with c; assumption.
+  replace a with (Rmin a b).
+  pattern b at 2 in |- *; replace b with (Rmax a b).
+  rewrite <- H2; rewrite H3; reflexivity.
+  unfold Rmax in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  unfold Rmin in |- *; case (Rle_dec a b); intro;
+    [ reflexivity | elim n; assumption ].
+  split with (cons r nil); split with lf1; assert (H2 : c = b).
+  rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
+  rewrite <- H2 in H1; rewrite <- H1; assumption.
+  intros r1 r2 _ X0 lf1 a b c f H H0; induction  lf1 as [| r3 lf1 Hreclf1].
+  unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
+    discriminate.
+  clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}).
+  case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
+  elim H1; intro.
+  split with (cons c (cons r1 r2)); split with (cons r3 lf1);
+    unfold adapted_couple in H; decompose [and] H; clear H;
+      unfold adapted_couple in |- *; repeat split.
+  unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
+  simpl in |- *; assumption.
+  clear Hreci; apply (H2 (S i)); simpl in |- *; assumption.
+  simpl in |- *; unfold Rmin in |- *; case (Rle_dec c b); intro;
+    [ reflexivity | elim n; elim H0; intros; assumption ].
+  replace (Rmax c b) with (Rmax a b).
+  rewrite <- H3; reflexivity.
+  unfold Rmax in |- *; case (Rle_dec a b); case (Rle_dec c b); intros;
+    [ reflexivity
+      | elim n; elim H0; intros; assumption
+      | elim n; elim H0; intros; apply Rle_trans with c; assumption
+      | elim n0; elim H0; intros; apply Rle_trans with c; assumption ].
+  simpl in |- *; simpl in H5; apply H5.
+  intros; simpl in H; induction  i as [| i Hreci].
+  unfold constant_D_eq, open_interval in |- *; intros; simpl in |- *;
+    apply (H7 0%nat).
+  simpl in |- *; apply lt_O_Sn.
+  unfold open_interval in |- *; simpl in |- *; simpl in H6; elim H6; clear H6;
+    intros; split; try assumption; apply Rle_lt_trans with c; 
+      try assumption; replace r with a.
+  elim H0; intros; assumption.
+  simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intros;
+    [ reflexivity
+      | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
+  clear Hreci; apply (H7 (S i)); simpl in |- *; assumption.
+  cut (adapted_couple f r1 b (cons r1 r2) lf1).
+  cut (r1 <= c <= b).
+  intros; elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with l1';
+    split with lf1'; assumption.
+  split; [ left; assumption | elim H0; intros; assumption ].
+  eapply StepFun_P7;
+    [ elim H0; intros; apply Rle_trans with c; [ apply H2 | apply H3 ]
+      | apply H ].
 Qed.
 
 Lemma StepFun_P46 :
- forall (f:R -> R) (a b c:R),
-   IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c.
-intros f; intros; case (Rle_dec a b); case (Rle_dec b c); intros.
-apply StepFun_P41 with b; assumption.
-case (Rle_dec a c); intro.
-apply StepFun_P44 with b; try assumption.
-split; [ assumption | auto with real ].
-apply StepFun_P6; apply StepFun_P44 with b.
-apply StepFun_P6; assumption.
-split; auto with real.
-case (Rle_dec a c); intro.
-apply StepFun_P45 with b; try assumption.
-split; auto with real.
-apply StepFun_P6; apply StepFun_P45 with b.
-apply StepFun_P6; assumption.
-split; [ assumption | auto with real ].
-apply StepFun_P6; apply StepFun_P41 with b;
- auto with real || apply StepFun_P6; assumption.
+  forall (f:R -> R) (a b c:R),
+    IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c.
+Proof. 
+  intros f; intros; case (Rle_dec a b); case (Rle_dec b c); intros.
+  apply StepFun_P41 with b; assumption.
+  case (Rle_dec a c); intro.
+  apply StepFun_P44 with b; try assumption.
+  split; [ assumption | auto with real ].
+  apply StepFun_P6; apply StepFun_P44 with b.
+  apply StepFun_P6; assumption.
+  split; auto with real.
+  case (Rle_dec a c); intro.
+  apply StepFun_P45 with b; try assumption.
+  split; auto with real.
+  apply StepFun_P6; apply StepFun_P45 with b.
+  apply StepFun_P6; assumption.
+  split; [ assumption | auto with real ].
+  apply StepFun_P6; apply StepFun_P41 with b;
+    auto with real || apply StepFun_P6; assumption.
 Qed.
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
index 0fbb17c6..76579ccb 100644
--- a/theories/Reals/Rlimit.v
+++ b/theories/Reals/Rlimit.v
@@ -6,10 +6,10 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rlimit.v,v 1.23.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+(*i $Id: Rlimit.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (*********************************************************)
-(*           Definition of the limit                     *)
+(**          Definition of the limit                     *)
 (*                                                       *)
 (*********************************************************)
 
@@ -19,76 +19,82 @@ Require Import Classical_Prop.
 Require Import Fourier. Open Local Scope R_scope.
 
 (*******************************)
-(*      Calculus               *)
+(** *   Calculus               *)
 (*******************************)
 (*********)
 Lemma eps2_Rgt_R0 : forall eps:R, eps > 0 -> eps * / 2 > 0.
-intros; fourier.
+Proof.
+  intros; fourier.
 Qed.
 
 (*********)
 Lemma eps2 : forall eps:R, eps * / 2 + eps * / 2 = eps.
-intro esp.
-assert (H := double_var esp).
-unfold Rdiv in H.
-symmetry  in |- *; exact H.
+Proof.
+  intro esp.
+  assert (H := double_var esp).
+  unfold Rdiv in H.
+  symmetry  in |- *; exact H.
 Qed.
 
 (*********)
 Lemma eps4 : forall eps:R, eps * / (2 + 2) + eps * / (2 + 2) = eps * / 2.
-intro eps.
-replace (2 + 2) with 4.
-pattern eps at 3 in |- *; rewrite double_var.
-rewrite (Rmult_plus_distr_r (eps / 2) (eps / 2) (/ 2)).
-unfold Rdiv in |- *.
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_mult_distr.
-reflexivity.
-discrR.
-discrR.
-ring.
+Proof.
+  intro eps.
+  replace (2 + 2) with 4.
+  pattern eps at 3 in |- *; rewrite double_var.
+  rewrite (Rmult_plus_distr_r (eps / 2) (eps / 2) (/ 2)).
+  unfold Rdiv in |- *.
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_mult_distr.
+  reflexivity.
+  discrR.
+  discrR.
+  ring.
 Qed.
 
 (*********)
 Lemma Rlt_eps2_eps : forall eps:R, eps > 0 -> eps * / 2 < eps.
-intros.
-pattern eps at 2 in |- *; rewrite <- Rmult_1_r.
-repeat rewrite (Rmult_comm eps).
-apply Rmult_lt_compat_r.
-exact H.
-apply Rmult_lt_reg_l with 2.
-fourier.
-rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
-fourier.
-discrR.
+Proof.
+  intros.
+  pattern eps at 2 in |- *; rewrite <- Rmult_1_r.
+  repeat rewrite (Rmult_comm eps).
+  apply Rmult_lt_compat_r.
+  exact H.
+  apply Rmult_lt_reg_l with 2.
+  fourier.
+  rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
+  fourier.
+  discrR.
 Qed.
 
 (*********)
 Lemma Rlt_eps4_eps : forall eps:R, eps > 0 -> eps * / (2 + 2) < eps.
-intros.
-replace (2 + 2) with 4.
-pattern eps at 2 in |- *; rewrite <- Rmult_1_r.
-repeat rewrite (Rmult_comm eps).
-apply Rmult_lt_compat_r.
-exact H.
-apply Rmult_lt_reg_l with 4.
-replace 4 with 4.
-apply Rmult_lt_0_compat; fourier.
-ring.
-rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
-fourier.
-discrR.
-ring.
+Proof.
+  intros.
+  replace (2 + 2) with 4.
+  pattern eps at 2 in |- *; rewrite <- Rmult_1_r.
+  repeat rewrite (Rmult_comm eps).
+  apply Rmult_lt_compat_r.
+  exact H.
+  apply Rmult_lt_reg_l with 4.
+  replace 4 with 4.
+  apply Rmult_lt_0_compat; fourier.
+  ring.
+  rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
+  fourier.
+  discrR.
+  ring.
 Qed. 
 
 (*********)
 Lemma prop_eps : forall r:R, (forall eps:R, eps > 0 -> r < eps) -> r <= 0.
-intros; elim (Rtotal_order r 0); intro.
-apply Rlt_le; assumption.
-elim H0; intro.
-apply Req_le; assumption.
-clear H0; generalize (H r H1); intro; generalize (Rlt_irrefl r); intro;
- elimtype False; auto.
+Proof.
+  intros; elim (Rtotal_order r 0); intro.
+  apply Rlt_le; assumption.
+  elim H0; intro.
+  apply Req_le; assumption.
+  clear H0; generalize (H r H1); intro; generalize (Rlt_irrefl r); intro;
+    elimtype False; auto.
 Qed.
 
 (*********)
@@ -96,59 +102,61 @@ Definition mul_factor (l l':R) := / (1 + (Rabs l + Rabs l')).
 
 (*********)
 Lemma mul_factor_wd : forall l l':R, 1 + (Rabs l + Rabs l') <> 0.
-intros; rewrite (Rplus_comm 1 (Rabs l + Rabs l')); apply tech_Rplus.
-cut (Rabs (l + l') <= Rabs l + Rabs l').
-cut (0 <= Rabs (l + l')).
-exact (Rle_trans _ _ _).
-exact (Rabs_pos (l + l')).
-exact (Rabs_triang _ _).
-exact Rlt_0_1.
+Proof.
+  intros; rewrite (Rplus_comm 1 (Rabs l + Rabs l')); apply tech_Rplus.
+  cut (Rabs (l + l') <= Rabs l + Rabs l').
+  cut (0 <= Rabs (l + l')).
+  exact (Rle_trans _ _ _).
+  exact (Rabs_pos (l + l')).
+  exact (Rabs_triang _ _).
+  exact Rlt_0_1.
 Qed.
 
 (*********)
 Lemma mul_factor_gt : forall eps l l':R, eps > 0 -> eps * mul_factor l l' > 0.
-intros; unfold Rgt in |- *; rewrite <- (Rmult_0_r eps);
- apply Rmult_lt_compat_l.
-assumption.
-unfold mul_factor in |- *; apply Rinv_0_lt_compat;
- cut (1 <= 1 + (Rabs l + Rabs l')).
-cut (0 < 1).
-exact (Rlt_le_trans _ _ _).
-exact Rlt_0_1.
-replace (1 <= 1 + (Rabs l + Rabs l')) with (1 + 0 <= 1 + (Rabs l + Rabs l')).
-apply Rplus_le_compat_l.
-cut (Rabs (l + l') <= Rabs l + Rabs l').
-cut (0 <= Rabs (l + l')).
-exact (Rle_trans _ _ _).
-exact (Rabs_pos _).
-exact (Rabs_triang _ _).
-rewrite (proj1 (Rplus_ne 1)); trivial.
+Proof.
+  intros; unfold Rgt in |- *; rewrite <- (Rmult_0_r eps);
+    apply Rmult_lt_compat_l.
+  assumption.
+  unfold mul_factor in |- *; apply Rinv_0_lt_compat;
+    cut (1 <= 1 + (Rabs l + Rabs l')).
+  cut (0 < 1).
+  exact (Rlt_le_trans _ _ _).
+  exact Rlt_0_1.
+  replace (1 <= 1 + (Rabs l + Rabs l')) with (1 + 0 <= 1 + (Rabs l + Rabs l')).
+  apply Rplus_le_compat_l.
+  cut (Rabs (l + l') <= Rabs l + Rabs l').
+  cut (0 <= Rabs (l + l')).
+  exact (Rle_trans _ _ _).
+  exact (Rabs_pos _).
+  exact (Rabs_triang _ _).
+  rewrite (proj1 (Rplus_ne 1)); trivial.
 Qed.
 
 (*********)
 Lemma mul_factor_gt_f :
- forall eps l l':R, eps > 0 -> Rmin 1 (eps * mul_factor l l') > 0.
-intros; apply Rmin_Rgt_r; split.
-exact Rlt_0_1.
-exact (mul_factor_gt eps l l' H).
+  forall eps l l':R, eps > 0 -> Rmin 1 (eps * mul_factor l l') > 0.
+  intros; apply Rmin_Rgt_r; split.
+  exact Rlt_0_1.
+  exact (mul_factor_gt eps l l' H).
 Qed.
 
 
 (*******************************)
-(*      Metric space           *)
+(** *   Metric space           *)
 (*******************************)
 
 (*********)
 Record Metric_Space : Type := 
   {Base : Type;
-   dist : Base -> Base -> R;
-   dist_pos : forall x y:Base, dist x y >= 0;
-   dist_sym : forall x y:Base, dist x y = dist y x;
-   dist_refl : forall x y:Base, dist x y = 0 <-> x = y;
-   dist_tri : forall x y z:Base, dist x y <= dist x z + dist z y}.
+    dist : Base -> Base -> R;
+    dist_pos : forall x y:Base, dist x y >= 0;
+    dist_sym : forall x y:Base, dist x y = dist y x;
+    dist_refl : forall x y:Base, dist x y = 0 <-> x = y;
+    dist_tri : forall x y z:Base, dist x y <= dist x z + dist z y}.
 
 (*******************************)
-(*     Limit in Metric space   *)
+(** ** Limit in Metric space   *)
 (*******************************)
 
 (*********)
@@ -156,12 +164,12 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X')
   (D:Base X -> Prop) (x0:Base X) (l:Base X') :=
   forall eps:R,
     eps > 0 ->
-     exists alp : R,
+    exists alp : R,
       alp > 0 /\
       (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps). 
 
 (*******************************)
-(*    R is a metric space      *)
+(** **  R is a metric space    *)
 (*******************************)
 
 (*********)
@@ -169,7 +177,7 @@ Definition R_met : Metric_Space :=
   Build_Metric_Space R R_dist R_dist_pos R_dist_sym R_dist_refl R_dist_tri.
 
 (*******************************)
-(*         Limit 1 arg         *)
+(** *      Limit 1 arg         *)
 (*******************************)
 (*********)
 Definition Dgf (Df Dg:R -> Prop) (f:R -> R) (x:R) := Df x /\ Dg (f x).
@@ -180,145 +188,153 @@ Definition limit1_in (f:R -> R) (D:R -> Prop) (l x0:R) : Prop :=
 
 (*********)
 Lemma tech_limit :
- forall (f:R -> R) (D:R -> Prop) (l x0:R),
-   D x0 -> limit1_in f D l x0 -> l = f x0.
-intros f D l x0 H H0.
-case (Rabs_pos (f x0 - l)); intros H1.
-absurd (dist R_met (f x0) l < dist R_met (f x0) l).
-apply Rlt_irrefl.
-case (H0 (dist R_met (f x0) l)); auto.
-intros alpha1 [H2 H3]; apply H3; auto; split; auto.
-case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto.
-case (dist_refl R_met (f x0) l); intros Hr1 Hr2; apply sym_eq; auto.
+  forall (f:R -> R) (D:R -> Prop) (l x0:R),
+    D x0 -> limit1_in f D l x0 -> l = f x0.
+Proof.
+  intros f D l x0 H H0.
+  case (Rabs_pos (f x0 - l)); intros H1.
+  absurd (dist R_met (f x0) l < dist R_met (f x0) l).
+  apply Rlt_irrefl.
+  case (H0 (dist R_met (f x0) l)); auto.
+  intros alpha1 [H2 H3]; apply H3; auto; split; auto.
+  case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto.
+  case (dist_refl R_met (f x0) l); intros Hr1 Hr2; apply sym_eq; auto.
 Qed.
 
 (*********)
 Lemma tech_limit_contr :
- forall (f:R -> R) (D:R -> Prop) (l x0:R),
-   D x0 -> l <> f x0 -> ~ limit1_in f D l x0.
-intros; generalize (tech_limit f D l x0); tauto.
+  forall (f:R -> R) (D:R -> Prop) (l x0:R),
+    D x0 -> l <> f x0 -> ~ limit1_in f D l x0.
+Proof.
+  intros; generalize (tech_limit f D l x0); tauto.
 Qed.
 
 (*********)
 Lemma lim_x : forall (D:R -> Prop) (x0:R), limit1_in (fun x:R => x) D x0 x0.
-unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
- split with eps; split; auto; intros; elim H0; intros; 
- auto.
+Proof.
+  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+    split with eps; split; auto; intros; elim H0; intros; 
+      auto.
 Qed.
 
 (*********)
 Lemma limit_plus :
- forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
-   limit1_in f D l x0 ->
-   limit1_in g D l' x0 -> limit1_in (fun x:R => f x + g x) D (l + l') x0.
-intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
- intros; elim (H (eps * / 2) (eps2_Rgt_R0 eps H1));
- elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *; 
- clear H H0; intros; elim H; elim H0; clear H H0; intros;
- split with (Rmin x1 x); split.
-exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
-intros; elim H4; clear H4; intros;
- cut (R_dist (f x2) l + R_dist (g x2) l' < eps).
- cut (R_dist (f x2 + g x2) (l + l') <= R_dist (f x2) l + R_dist (g x2) l').
-exact (Rle_lt_trans _ _ _).
-exact (R_dist_plus _ _ _ _).
-elim (Rmin_Rgt_l x1 x (R_dist x2 x0) H5); clear H5; intros.
-generalize (H3 x2 (conj H4 H6)); generalize (H0 x2 (conj H4 H5)); intros;
- replace eps with (eps * / 2 + eps * / 2).
-exact (Rplus_lt_compat _ _ _ _ H7 H8).
-exact (eps2 eps).
+  forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
+    limit1_in f D l x0 ->
+    limit1_in g D l' x0 -> limit1_in (fun x:R => f x + g x) D (l + l') x0.
+Proof.
+  intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
+    intros; elim (H (eps * / 2) (eps2_Rgt_R0 eps H1));
+      elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *; 
+        clear H H0; intros; elim H; elim H0; clear H H0; intros;
+          split with (Rmin x1 x); split.
+  exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
+  intros; elim H4; clear H4; intros;
+    cut (R_dist (f x2) l + R_dist (g x2) l' < eps).
+  cut (R_dist (f x2 + g x2) (l + l') <= R_dist (f x2) l + R_dist (g x2) l').
+  exact (Rle_lt_trans _ _ _).
+  exact (R_dist_plus _ _ _ _).
+  elim (Rmin_Rgt_l x1 x (R_dist x2 x0) H5); clear H5; intros.
+  generalize (H3 x2 (conj H4 H6)); generalize (H0 x2 (conj H4 H5)); intros;
+    replace eps with (eps * / 2 + eps * / 2).
+  exact (Rplus_lt_compat _ _ _ _ H7 H8).
+  exact (eps2 eps).
 Qed.
 
 (*********)
 Lemma limit_Ropp :
- forall (f:R -> R) (D:R -> Prop) (l x0:R),
-   limit1_in f D l x0 -> limit1_in (fun x:R => - f x) D (- l) x0.
-unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
- elim (H eps H0); clear H; intros; elim H; clear H; 
- intros; split with x; split; auto; intros; generalize (H1 x1 H2); 
- clear H1; intro; unfold R_dist in |- *; unfold Rminus in |- *;
- rewrite (Ropp_involutive l); rewrite (Rplus_comm (- f x1) l);
- fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *; 
- rewrite R_dist_sym; assumption.
+  forall (f:R -> R) (D:R -> Prop) (l x0:R),
+    limit1_in f D l x0 -> limit1_in (fun x:R => - f x) D (- l) x0.
+Proof.
+  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+    elim (H eps H0); clear H; intros; elim H; clear H; 
+      intros; split with x; split; auto; intros; generalize (H1 x1 H2); 
+        clear H1; intro; unfold R_dist in |- *; unfold Rminus in |- *;
+          rewrite (Ropp_involutive l); rewrite (Rplus_comm (- f x1) l);
+            fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *; 
+              rewrite R_dist_sym; assumption.
 Qed.
 
 (*********)
 Lemma limit_minus :
- forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
-   limit1_in f D l x0 ->
-   limit1_in g D l' x0 -> limit1_in (fun x:R => f x - g x) D (l - l') x0.
-intros; unfold Rminus in |- *; generalize (limit_Ropp g D l' x0 H0); intro;
- exact (limit_plus f (fun x:R => - g x) D l (- l') x0 H H1).
+  forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
+    limit1_in f D l x0 ->
+    limit1_in g D l' x0 -> limit1_in (fun x:R => f x - g x) D (l - l') x0.
+Proof.
+  intros; unfold Rminus in |- *; generalize (limit_Ropp g D l' x0 H0); intro;
+    exact (limit_plus f (fun x:R => - g x) D l (- l') x0 H H1).
 Qed.
 
 (*********)
 Lemma limit_free :
- forall (f:R -> R) (D:R -> Prop) (x x0:R),
-   limit1_in (fun h:R => f x) D (f x) x0.
-unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
- split with eps; split; auto; intros; elim (R_dist_refl (f x) (f x));
- intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H; 
- assumption.
+  forall (f:R -> R) (D:R -> Prop) (x x0:R),
+    limit1_in (fun h:R => f x) D (f x) x0.
+Proof.
+  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+    split with eps; split; auto; intros; elim (R_dist_refl (f x) (f x));
+      intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H; 
+        assumption.
 Qed.
 
 (*********)
 Lemma limit_mul :
- forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
-   limit1_in f D l x0 ->
-   limit1_in g D l' x0 -> limit1_in (fun x:R => f x * g x) D (l * l') x0.
-intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
- intros;
- elim (H (Rmin 1 (eps * mul_factor l l')) (mul_factor_gt_f eps l l' H1));
- elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); 
- clear H H0; simpl in |- *; intros; elim H; elim H0; 
- clear H H0; intros; split with (Rmin x1 x); split.
-exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
-intros; elim H4; clear H4; intros; unfold R_dist in |- *;
- replace (f x2 * g x2 - l * l') with (f x2 * (g x2 - l') + l' * (f x2 - l)).
-cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). 
-cut
- (Rabs (f x2 * (g x2 - l') + l' * (f x2 - l)) <=
-  Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l))).
-exact (Rle_lt_trans _ _ _).
-exact (Rabs_triang _ _).
-rewrite (Rabs_mult (f x2) (g x2 - l')); rewrite (Rabs_mult l' (f x2 - l));
- cut
-  ((1 + Rabs l) * (eps * mul_factor l l') + Rabs l' * (eps * mul_factor l l') <=
-   eps).
-cut
- (Rabs (f x2) * Rabs (g x2 - l') + Rabs l' * Rabs (f x2 - l) <
-  (1 + Rabs l) * (eps * mul_factor l l') + Rabs l' * (eps * mul_factor l l')).
-exact (Rlt_le_trans _ _ _).
-elim (Rmin_Rgt_l x1 x (R_dist x2 x0) H5); clear H5; intros;
- generalize (H0 x2 (conj H4 H5)); intro; generalize (Rmin_Rgt_l _ _ _ H7);
- intro; elim H8; intros; clear H0 H8; apply Rplus_lt_le_compat.
-apply Rmult_ge_0_gt_0_lt_compat.
-apply Rle_ge.
-exact (Rabs_pos (g x2 - l')).
-rewrite (Rplus_comm 1 (Rabs l)); unfold Rgt in |- *; apply Rle_lt_0_plus_1;
- exact (Rabs_pos l).
-unfold R_dist in H9;
- apply (Rplus_lt_reg_r (- Rabs l) (Rabs (f x2)) (1 + Rabs l)).
-rewrite <- (Rplus_assoc (- Rabs l) 1 (Rabs l));
- rewrite (Rplus_comm (- Rabs l) 1);
- rewrite (Rplus_assoc 1 (- Rabs l) (Rabs l)); rewrite (Rplus_opp_l (Rabs l));
- rewrite (proj1 (Rplus_ne 1)); rewrite (Rplus_comm (- Rabs l) (Rabs (f x2)));
- generalize H9; cut (Rabs (f x2) - Rabs l <= Rabs (f x2 - l)).
-exact (Rle_lt_trans _ _ _).
-exact (Rabs_triang_inv _ _).
-generalize (H3 x2 (conj H4 H6)); trivial.
-apply Rmult_le_compat_l.
-exact (Rabs_pos l').
-unfold Rle in |- *; left; assumption.
-rewrite (Rmult_comm (1 + Rabs l) (eps * mul_factor l l'));
- rewrite (Rmult_comm (Rabs l') (eps * mul_factor l l'));
- rewrite <-
-  (Rmult_plus_distr_l (eps * mul_factor l l') (1 + Rabs l) (Rabs l'))
-  ; rewrite (Rmult_assoc eps (mul_factor l l') (1 + Rabs l + Rabs l'));
- rewrite (Rplus_assoc 1 (Rabs l) (Rabs l')); unfold mul_factor in |- *;
- rewrite (Rinv_l (1 + (Rabs l + Rabs l')) (mul_factor_wd l l'));
- rewrite (proj1 (Rmult_ne eps)); apply Req_le; trivial.
-ring.
+  forall (f g:R -> R) (D:R -> Prop) (l l' x0:R),
+    limit1_in f D l x0 ->
+    limit1_in g D l' x0 -> limit1_in (fun x:R => f x * g x) D (l * l') x0.
+Proof.
+  intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
+    intros;
+      elim (H (Rmin 1 (eps * mul_factor l l')) (mul_factor_gt_f eps l l' H1));
+        elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); 
+          clear H H0; simpl in |- *; intros; elim H; elim H0; 
+            clear H H0; intros; split with (Rmin x1 x); split.
+  exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
+  intros; elim H4; clear H4; intros; unfold R_dist in |- *;
+    replace (f x2 * g x2 - l * l') with (f x2 * (g x2 - l') + l' * (f x2 - l)).
+  cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). 
+  cut
+    (Rabs (f x2 * (g x2 - l') + l' * (f x2 - l)) <=
+      Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l))).
+  exact (Rle_lt_trans _ _ _).
+  exact (Rabs_triang _ _).
+  rewrite (Rabs_mult (f x2) (g x2 - l')); rewrite (Rabs_mult l' (f x2 - l));
+    cut
+      ((1 + Rabs l) * (eps * mul_factor l l') + Rabs l' * (eps * mul_factor l l') <=
+        eps).
+  cut
+    (Rabs (f x2) * Rabs (g x2 - l') + Rabs l' * Rabs (f x2 - l) <
+      (1 + Rabs l) * (eps * mul_factor l l') + Rabs l' * (eps * mul_factor l l')).
+  exact (Rlt_le_trans _ _ _).
+  elim (Rmin_Rgt_l x1 x (R_dist x2 x0) H5); clear H5; intros;
+    generalize (H0 x2 (conj H4 H5)); intro; generalize (Rmin_Rgt_l _ _ _ H7);
+      intro; elim H8; intros; clear H0 H8; apply Rplus_lt_le_compat.
+  apply Rmult_ge_0_gt_0_lt_compat.
+  apply Rle_ge.
+  exact (Rabs_pos (g x2 - l')).
+  rewrite (Rplus_comm 1 (Rabs l)); unfold Rgt in |- *; apply Rle_lt_0_plus_1;
+    exact (Rabs_pos l).
+  unfold R_dist in H9;
+    apply (Rplus_lt_reg_r (- Rabs l) (Rabs (f x2)) (1 + Rabs l)).
+  rewrite <- (Rplus_assoc (- Rabs l) 1 (Rabs l));
+    rewrite (Rplus_comm (- Rabs l) 1);
+      rewrite (Rplus_assoc 1 (- Rabs l) (Rabs l)); rewrite (Rplus_opp_l (Rabs l));
+        rewrite (proj1 (Rplus_ne 1)); rewrite (Rplus_comm (- Rabs l) (Rabs (f x2)));
+          generalize H9; cut (Rabs (f x2) - Rabs l <= Rabs (f x2 - l)).
+  exact (Rle_lt_trans _ _ _).
+  exact (Rabs_triang_inv _ _).
+  generalize (H3 x2 (conj H4 H6)); trivial.
+  apply Rmult_le_compat_l.
+  exact (Rabs_pos l').
+  unfold Rle in |- *; left; assumption.
+  rewrite (Rmult_comm (1 + Rabs l) (eps * mul_factor l l'));
+    rewrite (Rmult_comm (Rabs l') (eps * mul_factor l l'));
+      rewrite <-
+        (Rmult_plus_distr_l (eps * mul_factor l l') (1 + Rabs l) (Rabs l'))
+        ; rewrite (Rmult_assoc eps (mul_factor l l') (1 + Rabs l + Rabs l'));
+          rewrite (Rplus_assoc 1 (Rabs l) (Rabs l')); unfold mul_factor in |- *;
+            rewrite (Rinv_l (1 + (Rabs l + Rabs l')) (mul_factor_wd l l'));
+              rewrite (proj1 (Rmult_ne eps)); apply Req_le; trivial.
+  ring.
 Qed.
 
 (*********)
@@ -327,231 +343,234 @@ Definition adhDa (D:R -> Prop) (a:R) : Prop :=
 
 (*********)
 Lemma single_limit :
- forall (f:R -> R) (D:R -> Prop) (l l' x0:R),
-   adhDa D x0 -> limit1_in f D l x0 -> limit1_in f D l' x0 -> l = l'.
-unfold limit1_in in |- *; unfold limit_in in |- *; intros.
-cut (forall eps:R, eps > 0 -> dist R_met l l' < 2 * eps).
-clear H0 H1; unfold dist in |- *; unfold R_met in |- *; unfold R_dist in |- *;
- unfold Rabs in |- *; case (Rcase_abs (l - l')); intros.
-cut (forall eps:R, eps > 0 -> - (l - l') < eps).
-intro; generalize (prop_eps (- (l - l')) H1); intro;
- generalize (Ropp_gt_lt_0_contravar (l - l') r); intro; 
- unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); 
- intro; elimtype False; auto.
-intros; cut (eps * / 2 > 0).
-intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
- rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
-elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
-apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
- unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); 
- intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; 
- clear a b; apply (Rlt_trans 0 1 2 H3 H4).
-unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
- rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); 
- auto.
-apply (Rinv_0_lt_compat 2); cut (1 < 2).
-intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2).
-generalize (Rplus_lt_compat_l 1 0 1 Rlt_0_1); elim (Rplus_ne 1); intros a b;
- rewrite a; clear a b; trivial.
+  forall (f:R -> R) (D:R -> Prop) (l l' x0:R),
+    adhDa D x0 -> limit1_in f D l x0 -> limit1_in f D l' x0 -> l = l'.
+Proof.
+  unfold limit1_in in |- *; unfold limit_in in |- *; intros.
+  cut (forall eps:R, eps > 0 -> dist R_met l l' < 2 * eps).
+  clear H0 H1; unfold dist in |- *; unfold R_met in |- *; unfold R_dist in |- *;
+    unfold Rabs in |- *; case (Rcase_abs (l - l')); intros.
+  cut (forall eps:R, eps > 0 -> - (l - l') < eps).
+  intro; generalize (prop_eps (- (l - l')) H1); intro;
+    generalize (Ropp_gt_lt_0_contravar (l - l') r); intro; 
+      unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); 
+        intro; elimtype False; auto.
+  intros; cut (eps * / 2 > 0).
+  intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
+    rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
+  elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
+  apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
+    unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); 
+      intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; 
+        clear a b; apply (Rlt_trans 0 1 2 H3 H4).
+  unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
+    rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); 
+      auto.
+  apply (Rinv_0_lt_compat 2); cut (1 < 2).
+  intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2).
+  generalize (Rplus_lt_compat_l 1 0 1 Rlt_0_1); elim (Rplus_ne 1); intros a b;
+    rewrite a; clear a b; trivial.
 (**)
-cut (forall eps:R, eps > 0 -> l - l' < eps).
-intro; generalize (prop_eps (l - l') H1); intro; elim (Rle_le_eq (l - l') 0);
- intros a b; clear b; apply (Rminus_diag_uniq l l'); 
- apply a; split.
-assumption.
-apply (Rge_le (l - l') 0 r).
-intros; cut (eps * / 2 > 0).
-intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
- rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
-elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
-apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
- unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); 
- intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; 
- clear a b; apply (Rlt_trans 0 1 2 H3 H4).
-unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
- rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); 
- auto.
-apply (Rinv_0_lt_compat 2); cut (1 < 2).
-intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2).
-generalize (Rplus_lt_compat_l 1 0 1 Rlt_0_1); elim (Rplus_ne 1); intros a b;
- rewrite a; clear a b; trivial.
+  cut (forall eps:R, eps > 0 -> l - l' < eps).
+  intro; generalize (prop_eps (l - l') H1); intro; elim (Rle_le_eq (l - l') 0);
+    intros a b; clear b; apply (Rminus_diag_uniq l l'); 
+      apply a; split.
+  assumption.
+  apply (Rge_le (l - l') 0 r).
+  intros; cut (eps * / 2 > 0).
+  intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
+    rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
+  elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
+  apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
+    unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); 
+      intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; 
+        clear a b; apply (Rlt_trans 0 1 2 H3 H4).
+  unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
+    rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); 
+      auto.
+  apply (Rinv_0_lt_compat 2); cut (1 < 2).
+  intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2).
+  generalize (Rplus_lt_compat_l 1 0 1 Rlt_0_1); elim (Rplus_ne 1); intros a b;
+    rewrite a; clear a b; trivial.
 (**)
-intros; unfold adhDa in H; elim (H0 eps H2); intros; elim (H1 eps H2); intros;
- clear H0 H1; elim H3; elim H4; clear H3 H4; intros; 
- simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); 
- intro; elim H5; intros; clear H5; elim (H (Rmin x x1) (H7 (conj H3 H0)));
- intros; elim H5; intros; clear H5 H H6 H7;
- generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro; 
- elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); 
- intros; clear H5 H9; generalize (H1 x2 (conj H8 H6));
- generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; 
- intros;
- generalize
-  (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0);
- unfold R_dist in |- *; intros; rewrite (Rabs_minus_sym (f x2) l) in H1;
- rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1);
- elim (Rmult_ne eps); intros a b; rewrite a; clear a b;
- generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *; 
- intros;
- apply
-  (Rle_lt_trans (Rabs (l - l')) (Rabs (l - f x2) + Rabs (f x2 - l'))
-     (eps + eps) H3 H1).
+  intros; unfold adhDa in H; elim (H0 eps H2); intros; elim (H1 eps H2); intros;
+    clear H0 H1; elim H3; elim H4; clear H3 H4; intros; 
+      simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); 
+        intro; elim H5; intros; clear H5; elim (H (Rmin x x1) (H7 (conj H3 H0)));
+          intros; elim H5; intros; clear H5 H H6 H7;
+            generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro; 
+              elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); 
+                intros; clear H5 H9; generalize (H1 x2 (conj H8 H6));
+                  generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; 
+                    intros;
+                      generalize
+                        (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0);
+                        unfold R_dist in |- *; intros; rewrite (Rabs_minus_sym (f x2) l) in H1;
+                          rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1);
+                            elim (Rmult_ne eps); intros a b; rewrite a; clear a b;
+                              generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *; 
+                                intros;
+                                  apply
+                                    (Rle_lt_trans (Rabs (l - l')) (Rabs (l - f x2) + Rabs (f x2 - l'))
+                                      (eps + eps) H3 H1).
 Qed.
 
 (*********)
 Lemma limit_comp :
- forall (f g:R -> R) (Df Dg:R -> Prop) (l l' x0:R),
-   limit1_in f Df l x0 ->
-   limit1_in g Dg l' l -> limit1_in (fun x:R => g (f x)) (Dgf Df Dg f) l' x0.
-unfold limit1_in, limit_in, Dgf in |- *; simpl in |- *.
-intros f g Df Dg l l' x0 Hf Hg eps eps_pos.
-elim (Hg eps eps_pos).
-intros alpg lg.
-elim (Hf alpg).
-2: tauto.
-intros alpf lf.
-exists alpf.
-intuition.
+  forall (f g:R -> R) (Df Dg:R -> Prop) (l l' x0:R),
+    limit1_in f Df l x0 ->
+    limit1_in g Dg l' l -> limit1_in (fun x:R => g (f x)) (Dgf Df Dg f) l' x0.
+Proof.
+  unfold limit1_in, limit_in, Dgf in |- *; simpl in |- *.
+  intros f g Df Dg l l' x0 Hf Hg eps eps_pos.
+  elim (Hg eps eps_pos).
+  intros alpg lg.
+  elim (Hf alpg).
+  2: tauto.
+  intros alpf lf.
+  exists alpf.
+  intuition.
 Qed.
 
 (*********)
 
 Lemma limit_inv :
- forall (f:R -> R) (D:R -> Prop) (l x0:R),
-   limit1_in f D l x0 -> l <> 0 -> limit1_in (fun x:R => / f x) D (/ l) x0.
-unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
- unfold R_dist in |- *; intros; elim (H (Rabs l / 2)).
-intros delta1 H2; elim (H (eps * (Rsqr l / 2))).
-intros delta2 H3; elim H2; elim H3; intros; exists (Rmin delta1 delta2);
- split.
-unfold Rmin in |- *; case (Rle_dec delta1 delta2); intro; assumption.
-intro; generalize (H5 x); clear H5; intro H5; generalize (H7 x); clear H7;
- intro H7; intro H10; elim H10; intros; cut (D x /\ Rabs (x - x0) < delta1).
-cut (D x /\ Rabs (x - x0) < delta2).
-intros; generalize (H5 H11); clear H5; intro H5; generalize (H7 H12);
- clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); 
- intro; rewrite Rabs_minus_sym in H7;
- generalize
-  (Rle_lt_trans (Rabs l - Rabs (f x)) (Rabs (l - f x)) (Rabs l / 2) H13 H7);
- intro;
- generalize
-  (Rplus_lt_compat_l (Rabs (f x) - Rabs l / 2) (Rabs l - Rabs (f x))
-     (Rabs l / 2) H14);
- replace (Rabs (f x) - Rabs l / 2 + (Rabs l - Rabs (f x))) with (Rabs l / 2).
-unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
- rewrite Rplus_0_r; intro; cut (f x <> 0).
-intro; replace (/ f x + - / l) with ((l - f x) * / (l * f x)).
-rewrite Rabs_mult; rewrite Rabs_Rinv.
-cut (/ Rabs (l * f x) < 2 / Rsqr l).
-intro; rewrite Rabs_minus_sym in H5; cut (0 <= / Rabs (l * f x)).
-intro;
- generalize
-  (Rmult_le_0_lt_compat (Rabs (l - f x)) (eps * (Rsqr l / 2))
-     (/ Rabs (l * f x)) (2 / Rsqr l) (Rabs_pos (l - f x)) H18 H5 H17);
- replace (eps * (Rsqr l / 2) * (2 / Rsqr l)) with eps.
-intro; assumption.
-unfold Rdiv in |- *; unfold Rsqr in |- *; rewrite Rinv_mult_distr.
-repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm l).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm l).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; reflexivity.
-discrR.
-exact H0.
-exact H0.
-exact H0.
-exact H0.
-left; apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply prod_neq_R0;
- assumption.
-rewrite Rmult_comm; rewrite Rabs_mult; rewrite Rinv_mult_distr.
-rewrite (Rsqr_abs l); unfold Rsqr in |- *; unfold Rdiv in |- *;
- rewrite Rinv_mult_distr.
-repeat rewrite <- Rmult_assoc; apply Rmult_lt_compat_r.
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-apply Rmult_lt_reg_l with (Rabs (f x) * Rabs l * / 2).
-repeat apply Rmult_lt_0_compat.
-apply Rabs_pos_lt; assumption.
-apply Rabs_pos_lt; assumption.
-apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
- [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR in |- *;
-    intro H18; assumption
- | discriminate ].
-replace (Rabs (f x) * Rabs l * / 2 * / Rabs (f x)) with (Rabs l / 2).
-replace (Rabs (f x) * Rabs l * / 2 * (2 * / Rabs l)) with (Rabs (f x)).
-assumption.
-repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm (Rabs l)).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; reflexivity.
-discrR.
-apply Rabs_no_R0.
-assumption.
-unfold Rdiv in |- *.
-repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm (Rabs (f x))).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-reflexivity.
-apply Rabs_no_R0; assumption.
-apply Rabs_no_R0; assumption.
-apply Rabs_no_R0; assumption.
-apply Rabs_no_R0; assumption.
-apply Rabs_no_R0; assumption.
-apply prod_neq_R0; assumption.
-rewrite (Rinv_mult_distr _ _ H0 H16).
-unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
-rewrite <- Rmult_assoc.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l.
-rewrite Ropp_mult_distr_l_reverse.
-rewrite (Rmult_comm (f x)).
-rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-reflexivity.
-assumption.
-assumption.
-red in |- *; intro; rewrite H16 in H15; rewrite Rabs_R0 in H15;
- cut (0 < Rabs l / 2).
-intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (Rabs l / 2) 0 H17 H15)).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply Rabs_pos_lt; assumption.
-apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
- [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR in |- *;
-    intro; assumption
- | discriminate ].
-pattern (Rabs l) at 3 in |- *; rewrite double_var.
-ring.
-split;
- [ assumption
- | apply Rlt_le_trans with (Rmin delta1 delta2);
-    [ assumption | apply Rmin_r ] ].
-split;
- [ assumption
- | apply Rlt_le_trans with (Rmin delta1 delta2);
-    [ assumption | apply Rmin_l ] ].
-change (0 < eps * (Rsqr l / 2)) in |- *; unfold Rdiv in |- *;
- repeat rewrite Rmult_assoc; repeat apply Rmult_lt_0_compat.
-assumption.
-apply Rsqr_pos_lt; assumption.
-apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
- [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *;
-    intro; assumption
- | discriminate ].
-change (0 < Rabs l / 2) in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply Rabs_pos_lt; assumption
- | apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
+  forall (f:R -> R) (D:R -> Prop) (l x0:R),
+    limit1_in f D l x0 -> l <> 0 -> limit1_in (fun x:R => / f x) D (/ l) x0.
+Proof.
+  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
+    unfold R_dist in |- *; intros; elim (H (Rabs l / 2)).
+  intros delta1 H2; elim (H (eps * (Rsqr l / 2))).
+  intros delta2 H3; elim H2; elim H3; intros; exists (Rmin delta1 delta2);
+    split.
+  unfold Rmin in |- *; case (Rle_dec delta1 delta2); intro; assumption.
+  intro; generalize (H5 x); clear H5; intro H5; generalize (H7 x); clear H7;
+    intro H7; intro H10; elim H10; intros; cut (D x /\ Rabs (x - x0) < delta1).
+  cut (D x /\ Rabs (x - x0) < delta2).
+  intros; generalize (H5 H11); clear H5; intro H5; generalize (H7 H12);
+    clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); 
+      intro; rewrite Rabs_minus_sym in H7;
+        generalize
+          (Rle_lt_trans (Rabs l - Rabs (f x)) (Rabs (l - f x)) (Rabs l / 2) H13 H7);
+          intro;
+            generalize
+              (Rplus_lt_compat_l (Rabs (f x) - Rabs l / 2) (Rabs l - Rabs (f x))
+                (Rabs l / 2) H14);
+              replace (Rabs (f x) - Rabs l / 2 + (Rabs l - Rabs (f x))) with (Rabs l / 2).
+  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+    rewrite Rplus_0_r; intro; cut (f x <> 0).
+  intro; replace (/ f x + - / l) with ((l - f x) * / (l * f x)).
+  rewrite Rabs_mult; rewrite Rabs_Rinv.
+  cut (/ Rabs (l * f x) < 2 / Rsqr l).
+  intro; rewrite Rabs_minus_sym in H5; cut (0 <= / Rabs (l * f x)).
+  intro;
+    generalize
+      (Rmult_le_0_lt_compat (Rabs (l - f x)) (eps * (Rsqr l / 2))
+        (/ Rabs (l * f x)) (2 / Rsqr l) (Rabs_pos (l - f x)) H18 H5 H17);
+      replace (eps * (Rsqr l / 2) * (2 / Rsqr l)) with eps.
+  intro; assumption.
+  unfold Rdiv in |- *; unfold Rsqr in |- *; rewrite Rinv_mult_distr.
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm l).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm l).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; reflexivity.
+  discrR.
+  exact H0.
+  exact H0.
+  exact H0.
+  exact H0.
+  left; apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply prod_neq_R0;
+    assumption.
+  rewrite Rmult_comm; rewrite Rabs_mult; rewrite Rinv_mult_distr.
+  rewrite (Rsqr_abs l); unfold Rsqr in |- *; unfold Rdiv in |- *;
+    rewrite Rinv_mult_distr.
+  repeat rewrite <- Rmult_assoc; apply Rmult_lt_compat_r.
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+  apply Rmult_lt_reg_l with (Rabs (f x) * Rabs l * / 2).
+  repeat apply Rmult_lt_0_compat.
+  apply Rabs_pos_lt; assumption.
+  apply Rabs_pos_lt; assumption.
+  apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
+    [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR in |- *;
+      intro H18; assumption
+      | discriminate ].
+  replace (Rabs (f x) * Rabs l * / 2 * / Rabs (f x)) with (Rabs l / 2).
+  replace (Rabs (f x) * Rabs l * / 2 * (2 * / Rabs l)) with (Rabs (f x)).
+  assumption.
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm (Rabs l)).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; reflexivity.
+  discrR.
+  apply Rabs_no_R0.
+  assumption.
+  unfold Rdiv in |- *.
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm (Rabs (f x))).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  reflexivity.
+  apply Rabs_no_R0; assumption.
+  apply Rabs_no_R0; assumption.
+  apply Rabs_no_R0; assumption.
+  apply Rabs_no_R0; assumption.
+  apply Rabs_no_R0; assumption.
+  apply prod_neq_R0; assumption.
+  rewrite (Rinv_mult_distr _ _ H0 H16).
+  unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
+  rewrite <- Rmult_assoc.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l.
+  rewrite Ropp_mult_distr_l_reverse.
+  rewrite (Rmult_comm (f x)).
+  rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  reflexivity.
+  assumption.
+  assumption.
+  red in |- *; intro; rewrite H16 in H15; rewrite Rabs_R0 in H15;
+    cut (0 < Rabs l / 2).
+  intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (Rabs l / 2) 0 H17 H15)).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply Rabs_pos_lt; assumption.
+  apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
+    [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR in |- *;
+      intro; assumption
+      | discriminate ].
+  pattern (Rabs l) at 3 in |- *; rewrite double_var.
+  ring.
+  split;
+    [ assumption
+      | apply Rlt_le_trans with (Rmin delta1 delta2);
+        [ assumption | apply Rmin_r ] ].
+  split;
+    [ assumption
+      | apply Rlt_le_trans with (Rmin delta1 delta2);
+        [ assumption | apply Rmin_l ] ].
+  change (0 < eps * (Rsqr l / 2)) in |- *; unfold Rdiv in |- *;
+    repeat rewrite Rmult_assoc; repeat apply Rmult_lt_0_compat.
+  assumption.
+  apply Rsqr_pos_lt; assumption.
+  apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
     [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *;
-       intro; assumption
-    | discriminate ] ].
+      intro; assumption
+      | discriminate ].
+  change (0 < Rabs l / 2) in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply Rabs_pos_lt; assumption
+      | apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
+        [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *;
+          intro; assumption
+          | discriminate ] ].
 Qed.
diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v
new file mode 100644
index 00000000..5bdbb76b
--- /dev/null
+++ b/theories/Reals/Rpow_def.v
@@ -0,0 +1,7 @@
+Require Import Rdefinitions.
+
+Fixpoint pow (r:R) (n:nat) {struct n} : R :=
+  match n with
+    | O => R1
+    | S n => Rmult r (pow r n)
+  end.
diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v
index 7575d929..cb6c59d5 100644
--- a/theories/Reals/Rpower.v
+++ b/theories/Reals/Rpower.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Rpower.v,v 1.17.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+(*i $Id: Rpower.v 9245 2006-10-17 12:53:34Z notin $ i*)
 (*i Due to L.Thery i*) 
 
 (************************************************************)
@@ -25,637 +25,674 @@ Require Import MVT.
 Require Import Ranalysis4. Open Local Scope R_scope.
 
 Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y).
-intros P x y H1 H2; unfold Rmin in |- *; case (Rle_dec x y); intro;
- assumption.
+Proof.
+  intros P x y H1 H2; unfold Rmin in |- *; case (Rle_dec x y); intro;
+    assumption.
 Qed.
 
 Lemma exp_le_3 : exp 1 <= 3.
-assert (exp_1 : exp 1 <> 0).
-assert (H0 := exp_pos 1); red in |- *; intro; rewrite H in H0;
- elim (Rlt_irrefl _ H0).
-apply Rmult_le_reg_l with (/ exp 1).
-apply Rinv_0_lt_compat; apply exp_pos.
-rewrite <- Rinv_l_sym.
-apply Rmult_le_reg_l with (/ 3).
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)).
-unfold exp in |- *; case (exist_exp (-1)); intros; simpl in |- *;
- unfold exp_in in e;
- assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1).
-cut
- (sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (S (2 * 1)) <= x <=
-  sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (2 * 1)).
-intro; elim H0; clear H0; intros H0 _; simpl in H0; unfold tg_alt in H0;
- simpl in H0.
-replace (/ 3) with
- (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 +
-  -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)).
-apply H0.
-repeat rewrite Rinv_1; repeat rewrite Rmult_1_r;
- rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
- rewrite Ropp_involutive; rewrite Rplus_opp_r; rewrite Rmult_1_r;
- rewrite Rplus_0_l; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 6.
-rewrite Rmult_plus_distr_l; replace (2 + 1 + 1 + 1 + 1) with 6.
-rewrite <- (Rmult_comm (/ 6)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; replace 6 with 6.
-do 2 rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; rewrite (Rmult_comm 3); rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-ring.
-discrR.
-discrR.
-ring.
-discrR.
-ring.
-discrR.
-apply H.
-unfold Un_decreasing in |- *; intros;
- apply Rmult_le_reg_l with (INR (fact n)).
-apply INR_fact_lt_0.
-apply Rmult_le_reg_l with (INR (fact (S n))).
-apply INR_fact_lt_0.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; apply le_INR; apply fact_le; apply le_n_Sn.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-assert (H0 := cv_speed_pow_fact 1); unfold Un_cv in |- *; unfold Un_cv in H0;
- intros; elim (H0 _ H1); intros; exists x0; intros; 
- unfold R_dist in H2; unfold R_dist in |- *;
- replace (/ INR (fact n)) with (1 ^ n / INR (fact n)).
-apply (H2 _ H3).
-unfold Rdiv in |- *; rewrite pow1; rewrite Rmult_1_l; reflexivity.
-unfold infinit_sum in e; unfold Un_cv, tg_alt in |- *; intros; elim (e _ H0);
- intros; exists x0; intros;
- replace (sum_f_R0 (fun i:nat => (-1) ^ i * / INR (fact i)) n) with
-  (sum_f_R0 (fun i:nat => / INR (fact i) * (-1) ^ i) n).
-apply (H1 _ H2).
-apply sum_eq; intros; apply Rmult_comm.
-apply Rmult_eq_reg_l with (exp 1).
-rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
- rewrite <- Rinv_r_sym.
-reflexivity.
-assumption.
-assumption.
-discrR.
-assumption.
+Proof.
+  assert (exp_1 : exp 1 <> 0).
+  assert (H0 := exp_pos 1); red in |- *; intro; rewrite H in H0;
+    elim (Rlt_irrefl _ H0).
+  apply Rmult_le_reg_l with (/ exp 1).
+  apply Rinv_0_lt_compat; apply exp_pos.
+  rewrite <- Rinv_l_sym.
+  apply Rmult_le_reg_l with (/ 3).
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)).
+  unfold exp in |- *; case (exist_exp (-1)); intros; simpl in |- *;
+    unfold exp_in in e;
+      assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1).
+  cut
+    (sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (S (2 * 1)) <= x <=
+      sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (2 * 1)).
+  intro; elim H0; clear H0; intros H0 _; simpl in H0; unfold tg_alt in H0;
+    simpl in H0.
+  replace (/ 3) with
+  (1 * / 1 + -1 * 1 * / 1 + -1 * (-1 * 1) * / 2 +
+    -1 * (-1 * (-1 * 1)) * / (2 + 1 + 1 + 1 + 1)).
+  apply H0.
+  repeat rewrite Rinv_1; repeat rewrite Rmult_1_r;
+    rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
+      rewrite Ropp_involutive; rewrite Rplus_opp_r; rewrite Rmult_1_r;
+        rewrite Rplus_0_l; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 6.
+  rewrite Rmult_plus_distr_l; replace (2 + 1 + 1 + 1 + 1) with 6.
+  rewrite <- (Rmult_comm (/ 6)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; replace 6 with 6.
+  do 2 rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; rewrite (Rmult_comm 3); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  ring.
+  discrR.
+  discrR.
+  ring.
+  discrR.
+  ring.
+  discrR.
+  apply H.
+  unfold Un_decreasing in |- *; intros;
+    apply Rmult_le_reg_l with (INR (fact n)).
+  apply INR_fact_lt_0.
+  apply Rmult_le_reg_l with (INR (fact (S n))).
+  apply INR_fact_lt_0.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; apply le_INR; apply fact_le; apply le_n_Sn.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  assert (H0 := cv_speed_pow_fact 1); unfold Un_cv in |- *; unfold Un_cv in H0;
+    intros; elim (H0 _ H1); intros; exists x0; intros; 
+      unfold R_dist in H2; unfold R_dist in |- *;
+        replace (/ INR (fact n)) with (1 ^ n / INR (fact n)).
+  apply (H2 _ H3).
+  unfold Rdiv in |- *; rewrite pow1; rewrite Rmult_1_l; reflexivity.
+  unfold infinit_sum in e; unfold Un_cv, tg_alt in |- *; intros; elim (e _ H0);
+    intros; exists x0; intros;
+      replace (sum_f_R0 (fun i:nat => (-1) ^ i * / INR (fact i)) n) with
+      (sum_f_R0 (fun i:nat => / INR (fact i) * (-1) ^ i) n).
+  apply (H1 _ H2).
+  apply sum_eq; intros; apply Rmult_comm.
+  apply Rmult_eq_reg_l with (exp 1).
+  rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
+    rewrite <- Rinv_r_sym.
+  reflexivity.
+  assumption.
+  assumption.
+  discrR.
+  assumption.
 Qed.
 
 (******************************************************************)
-(*                        Properties of  Exp                      *)
+(** *                     Properties of  Exp                      *)
 (******************************************************************)
 
 Theorem exp_increasing : forall x y:R, x < y -> exp x < exp y.
-intros x y H.
-assert (H0 : derivable exp).
-apply derivable_exp.
-assert (H1 := positive_derivative _ H0).
-unfold strict_increasing in H1.
-apply H1.
-intro.
-replace (derive_pt exp x0 (H0 x0)) with (exp x0).
-apply exp_pos.
-symmetry  in |- *; apply derive_pt_eq_0.
-apply (derivable_pt_lim_exp x0).
-apply H.
-Qed.
- 
+Proof.
+  intros x y H.
+  assert (H0 : derivable exp).
+  apply derivable_exp.
+  assert (H1 := positive_derivative _ H0).
+  unfold strict_increasing in H1.
+  apply H1.
+  intro.
+  replace (derive_pt exp x0 (H0 x0)) with (exp x0).
+  apply exp_pos.
+  symmetry  in |- *; apply derive_pt_eq_0.
+  apply (derivable_pt_lim_exp x0).
+  apply H.
+Qed.
+
 Theorem exp_lt_inv : forall x y:R, exp x < exp y -> x < y.
-intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ].
-assumption.
-rewrite H1 in H; elim (Rlt_irrefl _ H).
-assert (H2 := exp_increasing _ _ H1).
-elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H2)).
+Proof.
+  intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ].
+  assumption.
+  rewrite H1 in H; elim (Rlt_irrefl _ H).
+  assert (H2 := exp_increasing _ _ H1).
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H2)).
 Qed.
- 
+
 Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x.
-intros; apply Rplus_lt_reg_r with (- exp 0); rewrite <- (Rplus_comm (exp x));
- assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; 
- intros; elim H1; intros; unfold Rminus in H2; rewrite H2; 
- rewrite Ropp_0; rewrite Rplus_0_r;
- replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
-rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
- pattern x at 1 in |- *; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0));
- apply Rmult_lt_compat_l.
-apply H.
-rewrite <- exp_0; apply exp_increasing; elim H3; intros; assumption.
-symmetry  in |- *; apply derive_pt_eq_0; apply derivable_pt_lim_exp.
+Proof.
+  intros; apply Rplus_lt_reg_r with (- exp 0); rewrite <- (Rplus_comm (exp x));
+    assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; 
+      intros; elim H1; intros; unfold Rminus in H2; rewrite H2; 
+        rewrite Ropp_0; rewrite Rplus_0_r;
+          replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
+  rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+    pattern x at 1 in |- *; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0));
+      apply Rmult_lt_compat_l.
+  apply H.
+  rewrite <- exp_0; apply exp_increasing; elim H3; intros; assumption.
+  symmetry  in |- *; apply derive_pt_eq_0; apply derivable_pt_lim_exp.
 Qed.
 
 Lemma ln_exists1 : forall y:R, 0 < y -> 1 <= y -> sigT (fun z:R => y = exp z).
-intros; set (f := fun x:R => exp x - y); cut (f 0 <= 0).
-intro; cut (continuity f).
-intro; cut (0 <= f y).
-intro; cut (f 0 * f y <= 0).
-intro; assert (X := IVT_cor f 0 y H2 (Rlt_le _ _ H) H4); elim X; intros t H5;
- apply existT with t; elim H5; intros; unfold f in H7;
- apply Rminus_diag_uniq_sym; exact H7.
-pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y));
- rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; 
- assumption.
-unfold f in |- *; apply Rplus_le_reg_l with y; left;
- apply Rlt_trans with (1 + y).
-rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1.
-replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H) | ring ].
-unfold f in |- *; change (continuity (exp - fct_cte y)) in |- *;
- apply continuity_minus;
- [ apply derivable_continuous; apply derivable_exp
- | apply derivable_continuous; apply derivable_const ].
-unfold f in |- *; rewrite exp_0; apply Rplus_le_reg_l with y;
- rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H0 | ring ].
+Proof.
+  intros; set (f := fun x:R => exp x - y); cut (f 0 <= 0).
+  intro; cut (continuity f).
+  intro; cut (0 <= f y).
+  intro; cut (f 0 * f y <= 0).
+  intro; assert (X := IVT_cor f 0 y H2 (Rlt_le _ _ H) H4); elim X; intros t H5;
+    apply existT with t; elim H5; intros; unfold f in H7;
+      apply Rminus_diag_uniq_sym; exact H7.
+  pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y));
+    rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; 
+      assumption.
+  unfold f in |- *; apply Rplus_le_reg_l with y; left;
+    apply Rlt_trans with (1 + y).
+  rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1.
+  replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H) | ring ].
+  unfold f in |- *; change (continuity (exp - fct_cte y)) in |- *;
+    apply continuity_minus;
+      [ apply derivable_continuous; apply derivable_exp
+        | apply derivable_continuous; apply derivable_const ].
+  unfold f in |- *; rewrite exp_0; apply Rplus_le_reg_l with y;
+    rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H0 | ring ].
 Qed.
 
 (**********)
 Lemma ln_exists : forall y:R, 0 < y -> sigT (fun z:R => y = exp z).
-intros; case (Rle_dec 1 y); intro.
-apply (ln_exists1 _ H r).
-assert (H0 : 1 <= / y).
-apply Rmult_le_reg_l with y.
-apply H.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ n).
-red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
-assert (H1 : 0 < / y).
-apply Rinv_0_lt_compat; apply H.
-assert (H2 := ln_exists1 _ H1 H0); elim H2; intros; apply existT with (- x);
- apply Rmult_eq_reg_l with (exp x / y).
-unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc;
- rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; 
- rewrite Rmult_1_r; symmetry  in |- *; apply p.
-red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
-unfold Rdiv in |- *; apply prod_neq_R0.
-assert (H3 := exp_pos x); red in |- *; intro; rewrite H4 in H3;
- elim (Rlt_irrefl _ H3).
-apply Rinv_neq_0_compat; red in |- *; intro; rewrite H3 in H;
- elim (Rlt_irrefl _ H).
+Proof.
+  intros; case (Rle_dec 1 y); intro.
+  apply (ln_exists1 _ H r).
+  assert (H0 : 1 <= / y).
+  apply Rmult_le_reg_l with y.
+  apply H.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ n).
+  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+  assert (H1 : 0 < / y).
+  apply Rinv_0_lt_compat; apply H.
+  assert (H2 := ln_exists1 _ H1 H0); elim H2; intros; apply existT with (- x);
+    apply Rmult_eq_reg_l with (exp x / y).
+  unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc;
+    rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; 
+      rewrite Rmult_1_r; symmetry  in |- *; apply p.
+  red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
+  unfold Rdiv in |- *; apply prod_neq_R0.
+  assert (H3 := exp_pos x); red in |- *; intro; rewrite H4 in H3;
+    elim (Rlt_irrefl _ H3).
+  apply Rinv_neq_0_compat; red in |- *; intro; rewrite H3 in H;
+    elim (Rlt_irrefl _ H).
 Qed.
 
 (* Definition of log R+* -> R *)
 Definition Rln (y:posreal) : R :=
   match ln_exists (pos y) (cond_pos y) with
-  | existT a b => a
+    | existT a b => a
   end.
 
 (* Extension on R *)
 Definition ln (x:R) : R :=
   match Rlt_dec 0 x with
-  | left a => Rln (mkposreal x a)
-  | right a => 0
+    | left a => Rln (mkposreal x a)
+    | right a => 0
   end.
 
 Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x.
-intros; unfold ln in |- *; case (Rlt_dec 0 x); intro.
-unfold Rln in |- *;
- case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); 
- intros.
-simpl in e; symmetry  in |- *; apply e.
-elim n; apply H.
+Proof.
+  intros; unfold ln in |- *; case (Rlt_dec 0 x); intro.
+  unfold Rln in |- *;
+    case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); 
+    intros.
+  simpl in e; symmetry  in |- *; apply e.
+  elim n; apply H.
 Qed.
 
 Theorem exp_inv : forall x y:R, exp x = exp y -> x = y.
-intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]; auto;
- assert (H2 := exp_increasing _ _ H1); rewrite H in H2;
- elim (Rlt_irrefl _ H2).
+Proof.
+  intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]; auto;
+    assert (H2 := exp_increasing _ _ H1); rewrite H in H2;
+      elim (Rlt_irrefl _ H2).
 Qed.
- 
+
 Theorem exp_Ropp : forall x:R, exp (- x) = / exp x.
-intros x; assert (H : exp x <> 0).
-assert (H := exp_pos x); red in |- *; intro; rewrite H0 in H;
- elim (Rlt_irrefl _ H).
-apply Rmult_eq_reg_l with (r := exp x).
-rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0.
-apply Rinv_r_sym.
-apply H.
-apply H.
-Qed.
- 
+Proof.
+  intros x; assert (H : exp x <> 0).
+  assert (H := exp_pos x); red in |- *; intro; rewrite H0 in H;
+    elim (Rlt_irrefl _ H).
+  apply Rmult_eq_reg_l with (r := exp x).
+  rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0.
+  apply Rinv_r_sym.
+  apply H.
+  apply H.
+Qed.
+
 (******************************************************************)
-(*                        Properties of  Ln                       *)
+(** *                     Properties of  Ln                       *)
 (******************************************************************)
 
 Theorem ln_increasing : forall x y:R, 0 < x -> x < y -> ln x < ln y.
-intros x y H H0; apply exp_lt_inv.
-repeat rewrite exp_ln. 
-apply H0.
-apply Rlt_trans with x; assumption.
-apply H.
+Proof.
+  intros x y H H0; apply exp_lt_inv.
+  repeat rewrite exp_ln. 
+  apply H0.
+  apply Rlt_trans with x; assumption.
+  apply H.
 Qed.
 
 Theorem ln_exp : forall x:R, ln (exp x) = x.
-intros x; apply exp_inv.
-apply exp_ln.
-apply exp_pos.
+Proof.
+  intros x; apply exp_inv.
+  apply exp_ln.
+  apply exp_pos.
 Qed.
- 
+
 Theorem ln_1 : ln 1 = 0.
-rewrite <- exp_0; rewrite ln_exp; reflexivity.
+Proof.
+  rewrite <- exp_0; rewrite ln_exp; reflexivity.
 Qed.
- 
+
 Theorem ln_lt_inv : forall x y:R, 0 < x -> 0 < y -> ln x < ln y -> x < y.
-intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y).
-apply exp_increasing; apply H1.
-assumption. 
-assumption.
+Proof.
+  intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y).
+  apply exp_increasing; apply H1.
+  assumption. 
+  assumption.
 Qed.
- 
+
 Theorem ln_inv : forall x y:R, 0 < x -> 0 < y -> ln x = ln y -> x = y.
-intros x y H H0 H'0; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ];
- auto.
-assert (H2 := ln_increasing _ _ H H1); rewrite H'0 in H2;
- elim (Rlt_irrefl _ H2).
-assert (H2 := ln_increasing _ _ H0 H1); rewrite H'0 in H2;
- elim (Rlt_irrefl _ H2).
-Qed.
- 
+Proof.
+  intros x y H H0 H'0; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ];
+    auto.
+  assert (H2 := ln_increasing _ _ H H1); rewrite H'0 in H2;
+    elim (Rlt_irrefl _ H2).
+  assert (H2 := ln_increasing _ _ H0 H1); rewrite H'0 in H2;
+    elim (Rlt_irrefl _ H2).
+Qed.
+
 Theorem ln_mult : forall x y:R, 0 < x -> 0 < y -> ln (x * y) = ln x + ln y.
-intros x y H H0; apply exp_inv.
-rewrite exp_plus.
-repeat rewrite exp_ln.
-reflexivity.
-assumption.
-assumption.
-apply Rmult_lt_0_compat; assumption.
+Proof.
+  intros x y H H0; apply exp_inv.
+  rewrite exp_plus.
+  repeat rewrite exp_ln.
+  reflexivity.
+  assumption.
+  assumption.
+  apply Rmult_lt_0_compat; assumption.
 Qed.
 
 Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x.
-intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp.
-reflexivity.
-assumption. 
-apply Rinv_0_lt_compat; assumption.
+Proof.
+  intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp.
+  reflexivity.
+  assumption. 
+  apply Rinv_0_lt_compat; assumption.
 Qed.
 
 Theorem ln_continue :
- forall y:R, 0 < y -> continue_in ln (fun x:R => 0 < x) y.
-intros y H.
-unfold continue_in, limit1_in, limit_in in |- *; intros eps Heps.
-cut (1 < exp eps); [ intros H1 | idtac ].
-cut (exp (- eps) < 1); [ intros H2 | idtac ].
-exists (Rmin (y * (exp eps - 1)) (y * (1 - exp (- eps)))); split.
-red in |- *; apply P_Rmin.
-apply Rmult_lt_0_compat.
-assumption.
-apply Rplus_lt_reg_r with 1.
-rewrite Rplus_0_r; replace (1 + (exp eps - 1)) with (exp eps);
- [ apply H1 | ring ].
-apply Rmult_lt_0_compat.
-assumption.
-apply Rplus_lt_reg_r with (exp (- eps)).
-rewrite Rplus_0_r; replace (exp (- eps) + (1 - exp (- eps))) with 1;
- [ apply H2 | ring ].
-unfold dist, R_met, R_dist in |- *; simpl in |- *.
-intros x [[H3 H4] H5].
-cut (y * (x * / y) = x).
-intro Hxyy. 
-replace (ln x - ln y) with (ln (x * / y)).
-case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ].
-rewrite Rabs_left.
-apply Ropp_lt_cancel; rewrite Ropp_involutive.
-apply exp_lt_inv.
-rewrite exp_ln.
-apply Rmult_lt_reg_l with (r := y).
-apply H.
-rewrite Hxyy.
-apply Ropp_lt_cancel.
-apply Rplus_lt_reg_r with (r := y).
-replace (y + - (y * exp (- eps))) with (y * (1 - exp (- eps)));
- [ idtac | ring ].
-replace (y + - x) with (Rabs (x - y)); [ idtac | ring ].
-apply Rlt_le_trans with (1 := H5); apply Rmin_r.
-rewrite Rabs_left; [ ring | idtac ].
-apply (Rlt_minus _ _ Hxy).
-apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
-rewrite <- ln_1.
-apply ln_increasing.
-apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
-apply Rmult_lt_reg_l with (r := y).
-apply H.
-rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
-rewrite Hxy; rewrite Rinv_r.
-rewrite ln_1; rewrite Rabs_R0; apply Heps.
-red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
-rewrite Rabs_right.
-apply exp_lt_inv.
-rewrite exp_ln.
-apply Rmult_lt_reg_l with (r := y).
-apply H.
-rewrite Hxyy.
-apply Rplus_lt_reg_r with (r := - y).
-replace (- y + y * exp eps) with (y * (exp eps - 1)); [ idtac | ring ].
-replace (- y + x) with (Rabs (x - y)); [ idtac | ring ].
-apply Rlt_le_trans with (1 := H5); apply Rmin_l.
-rewrite Rabs_right; [ ring | idtac ].
-left; apply (Rgt_minus _ _ Hxy).
-apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
-rewrite <- ln_1.
-apply Rgt_ge; red in |- *; apply ln_increasing.
-apply Rlt_0_1.
-apply Rmult_lt_reg_l with (r := y).
-apply H.
-rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
-rewrite ln_mult.
-rewrite ln_Rinv.
-ring.
-assumption.
-assumption.
-apply Rinv_0_lt_compat; assumption.
-rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-ring.
-red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
-apply Rmult_lt_reg_l with (exp eps).
-apply exp_pos.
-rewrite <- exp_plus; rewrite Rmult_1_r; rewrite Rplus_opp_r; rewrite exp_0;
- apply H1.
-rewrite <- exp_0.
-apply exp_increasing; apply Heps.
+  forall y:R, 0 < y -> continue_in ln (fun x:R => 0 < x) y.
+Proof.
+  intros y H.
+  unfold continue_in, limit1_in, limit_in in |- *; intros eps Heps.
+  cut (1 < exp eps); [ intros H1 | idtac ].
+  cut (exp (- eps) < 1); [ intros H2 | idtac ].
+  exists (Rmin (y * (exp eps - 1)) (y * (1 - exp (- eps)))); split.
+  red in |- *; apply P_Rmin.
+  apply Rmult_lt_0_compat.
+  assumption.
+  apply Rplus_lt_reg_r with 1.
+  rewrite Rplus_0_r; replace (1 + (exp eps - 1)) with (exp eps);
+    [ apply H1 | ring ].
+  apply Rmult_lt_0_compat.
+  assumption.
+  apply Rplus_lt_reg_r with (exp (- eps)).
+  rewrite Rplus_0_r; replace (exp (- eps) + (1 - exp (- eps))) with 1;
+    [ apply H2 | ring ].
+  unfold dist, R_met, R_dist in |- *; simpl in |- *.
+  intros x [[H3 H4] H5].
+  cut (y * (x * / y) = x).
+  intro Hxyy. 
+  replace (ln x - ln y) with (ln (x * / y)).
+  case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ].
+  rewrite Rabs_left.
+  apply Ropp_lt_cancel; rewrite Ropp_involutive.
+  apply exp_lt_inv.
+  rewrite exp_ln.
+  apply Rmult_lt_reg_l with (r := y).
+  apply H.
+  rewrite Hxyy.
+  apply Ropp_lt_cancel.
+  apply Rplus_lt_reg_r with (r := y).
+  replace (y + - (y * exp (- eps))) with (y * (1 - exp (- eps)));
+  [ idtac | ring ].
+  replace (y + - x) with (Rabs (x - y)).
+  apply Rlt_le_trans with (1 := H5); apply Rmin_r.
+  rewrite Rabs_left; [ ring | idtac ].
+  apply (Rlt_minus _ _ Hxy).
+  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
+  rewrite <- ln_1.
+  apply ln_increasing.
+  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
+  apply Rmult_lt_reg_l with (r := y).
+  apply H.
+  rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
+  rewrite Hxy; rewrite Rinv_r.
+  rewrite ln_1; rewrite Rabs_R0; apply Heps.
+  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+  rewrite Rabs_right.
+  apply exp_lt_inv.
+  rewrite exp_ln.
+  apply Rmult_lt_reg_l with (r := y).
+  apply H.
+  rewrite Hxyy.
+  apply Rplus_lt_reg_r with (r := - y).
+  replace (- y + y * exp eps) with (y * (exp eps - 1)); [ idtac | ring ].
+  replace (- y + x) with (Rabs (x - y)).
+  apply Rlt_le_trans with (1 := H5); apply Rmin_l.
+  rewrite Rabs_right; [ ring | idtac ].
+  left; apply (Rgt_minus _ _ Hxy).
+  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
+  rewrite <- ln_1.
+  apply Rgt_ge; red in |- *; apply ln_increasing.
+  apply Rlt_0_1.
+  apply Rmult_lt_reg_l with (r := y).
+  apply H.
+  rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
+  rewrite ln_mult.
+  rewrite ln_Rinv.
+  ring.
+  assumption.
+  assumption.
+  apply Rinv_0_lt_compat; assumption.
+  rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+  ring.
+  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+  apply Rmult_lt_reg_l with (exp eps).
+  apply exp_pos.
+  rewrite <- exp_plus; rewrite Rmult_1_r; rewrite Rplus_opp_r; rewrite exp_0;
+    apply H1.
+  rewrite <- exp_0.
+  apply exp_increasing; apply Heps.
 Qed.
 
 (******************************************************************)
-(*                        Definition of  Rpower                   *)
+(** *                     Definition of  Rpower                   *)
 (******************************************************************)
- 
+
 Definition Rpower (x y:R) := exp (y * ln x).
 
 Infix Local "^R" := Rpower (at level 30, right associativity) : R_scope.
 
 (******************************************************************)
-(*                        Properties of  Rpower                   *)
+(** *                     Properties of  Rpower                   *)
 (******************************************************************)
- 
+
 Theorem Rpower_plus : forall x y z:R, z ^R (x + y) = z ^R x * z ^R y.
-intros x y z; unfold Rpower in |- *.
-rewrite Rmult_plus_distr_r; rewrite exp_plus; auto.
+Proof.
+  intros x y z; unfold Rpower in |- *.
+  rewrite Rmult_plus_distr_r; rewrite exp_plus; auto.
 Qed.
- 
+
 Theorem Rpower_mult : forall x y z:R, (x ^R y) ^R z = x ^R (y * z).
-intros x y z; unfold Rpower in |- *.
-rewrite ln_exp.
-replace (z * (y * ln x)) with (y * z * ln x).
-reflexivity.
-ring.
+Proof.
+  intros x y z; unfold Rpower in |- *.
+  rewrite ln_exp.
+  replace (z * (y * ln x)) with (y * z * ln x).
+  reflexivity.
+  ring.
 Qed.
- 
+
 Theorem Rpower_O : forall x:R, 0 < x -> x ^R 0 = 1.
-intros x H; unfold Rpower in |- *.
-rewrite Rmult_0_l; apply exp_0.
+Proof.
+  intros x H; unfold Rpower in |- *.
+  rewrite Rmult_0_l; apply exp_0.
 Qed.
- 
+
 Theorem Rpower_1 : forall x:R, 0 < x -> x ^R 1 = x.
-intros x H; unfold Rpower in |- *.
-rewrite Rmult_1_l; apply exp_ln; apply H.
+Proof.
+  intros x H; unfold Rpower in |- *.
+  rewrite Rmult_1_l; apply exp_ln; apply H.
 Qed.
- 
+
 Theorem Rpower_pow : forall (n:nat) (x:R), 0 < x -> x ^R INR n = x ^ n.
-intros n; elim n; simpl in |- *; auto; fold INR in |- *.
-intros x H; apply Rpower_O; auto.
-intros n1; case n1.
-intros H x H0; simpl in |- *; rewrite Rmult_1_r; apply Rpower_1; auto.
-intros n0 H x H0; rewrite Rpower_plus; rewrite H; try rewrite Rpower_1;
- try apply Rmult_comm || assumption.
-Qed.
- 
+Proof.
+  intros n; elim n; simpl in |- *; auto; fold INR in |- *.
+  intros x H; apply Rpower_O; auto.
+  intros n1; case n1.
+  intros H x H0; simpl in |- *; rewrite Rmult_1_r; apply Rpower_1; auto.
+  intros n0 H x H0; rewrite Rpower_plus; rewrite H; try rewrite Rpower_1;
+    try apply Rmult_comm || assumption.
+Qed.
+
 Theorem Rpower_lt :
- forall x y z:R, 1 < x -> 0 <= y -> y < z -> x ^R y < x ^R z.
-intros x y z H H0 H1.
-unfold Rpower in |- *.
-apply exp_increasing.
-apply Rmult_lt_compat_r.
-rewrite <- ln_1; apply ln_increasing.
-apply Rlt_0_1.
-apply H.
-apply H1.
-Qed.
- 
+  forall x y z:R, 1 < x -> 0 <= y -> y < z -> x ^R y < x ^R z.
+Proof.
+  intros x y z H H0 H1.
+  unfold Rpower in |- *.
+  apply exp_increasing.
+  apply Rmult_lt_compat_r.
+  rewrite <- ln_1; apply ln_increasing.
+  apply Rlt_0_1.
+  apply H.
+  apply H1.
+Qed.
+
 Theorem Rpower_sqrt : forall x:R, 0 < x -> x ^R (/ 2) = sqrt x.
-intros x H.
-apply ln_inv.
-unfold Rpower in |- *; apply exp_pos.
-apply sqrt_lt_R0; apply H.
-apply Rmult_eq_reg_l with (INR 2).
-apply exp_inv.
-fold Rpower in |- *.
-cut ((x ^R (/ 2)) ^R INR 2 = sqrt x ^R INR 2).
-unfold Rpower in |- *; auto.
-rewrite Rpower_mult.
-rewrite Rinv_l.
-replace 1 with (INR 1); auto.
-repeat rewrite Rpower_pow; simpl in |- *.
-pattern x at 1 in |- *; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)).
-ring.
-apply sqrt_lt_R0; apply H.
-apply H.
-apply not_O_INR; discriminate.
-apply not_O_INR; discriminate.
-Qed.
- 
+Proof.
+  intros x H.
+  apply ln_inv.
+  unfold Rpower in |- *; apply exp_pos.
+  apply sqrt_lt_R0; apply H.
+  apply Rmult_eq_reg_l with (INR 2).
+  apply exp_inv.
+  fold Rpower in |- *.
+  cut ((x ^R (/ 2)) ^R INR 2 = sqrt x ^R INR 2).
+  unfold Rpower in |- *; auto.
+  rewrite Rpower_mult.
+  rewrite Rinv_l.
+  replace 1 with (INR 1); auto.
+  repeat rewrite Rpower_pow; simpl in |- *.
+  pattern x at 1 in |- *; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)).
+  ring.
+  apply sqrt_lt_R0; apply H.
+  apply H.
+  apply not_O_INR; discriminate.
+  apply not_O_INR; discriminate.
+Qed.
+
 Theorem Rpower_Ropp : forall x y:R, x ^R (- y) = / x ^R y.
-unfold Rpower in |- *.
-intros x y; rewrite Ropp_mult_distr_l_reverse.
-apply exp_Ropp.
+Proof.
+  unfold Rpower in |- *.
+  intros x y; rewrite Ropp_mult_distr_l_reverse.
+  apply exp_Ropp.
 Qed.
- 
+
 Theorem Rle_Rpower :
- forall e n m:R, 1 < e -> 0 <= n -> n <= m -> e ^R n <= e ^R m.
-intros e n m H H0 H1; case H1.
-intros H2; left; apply Rpower_lt; assumption.
-intros H2; rewrite H2; right; reflexivity.
+  forall e n m:R, 1 < e -> 0 <= n -> n <= m -> e ^R n <= e ^R m.
+Proof.
+  intros e n m H H0 H1; case H1.
+  intros H2; left; apply Rpower_lt; assumption.
+  intros H2; rewrite H2; right; reflexivity.
 Qed.
-  
+
 Theorem ln_lt_2 : / 2 < ln 2.
-apply Rmult_lt_reg_l with (r := 2).
-prove_sup0.
-rewrite Rinv_r.
-apply exp_lt_inv.
-apply Rle_lt_trans with (1 := exp_le_3).
-change (3 < 2 ^R 2) in |- *.
-repeat rewrite Rpower_plus; repeat rewrite Rpower_1.
-repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
- repeat rewrite Rmult_1_l.
-pattern 3 at 1 in |- *; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1);
- [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ].
-prove_sup0.
-discrR.
-Qed.
-
-(**************************************)
-(* Differentiability of Ln and Rpower *)
-(**************************************)
+Proof.
+  apply Rmult_lt_reg_l with (r := 2).
+  prove_sup0.
+  rewrite Rinv_r.
+  apply exp_lt_inv.
+  apply Rle_lt_trans with (1 := exp_le_3).
+  change (3 < 2 ^R 2) in |- *.
+  repeat rewrite Rpower_plus; repeat rewrite Rpower_1.
+  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
+    repeat rewrite Rmult_1_l.
+  pattern 3 at 1 in |- *; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1);
+    [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ].
+  prove_sup0.
+  discrR.
+Qed.
+
+(*****************************************)
+(** * Differentiability of Ln and Rpower *)
+(*****************************************)
 
 Theorem limit1_ext :
- forall (f g:R -> R) (D:R -> Prop) (l x:R),
-   (forall x:R, D x -> f x = g x) -> limit1_in f D l x -> limit1_in g D l x.
-intros f g D l x H; unfold limit1_in, limit_in in |- *.
-intros H0 eps H1; case (H0 eps); auto.
-intros x0 [H2 H3]; exists x0; split; auto.
-intros x1 [H4 H5]; rewrite <- H; auto.
+  forall (f g:R -> R) (D:R -> Prop) (l x:R),
+    (forall x:R, D x -> f x = g x) -> limit1_in f D l x -> limit1_in g D l x.
+Proof.
+  intros f g D l x H; unfold limit1_in, limit_in in |- *.
+  intros H0 eps H1; case (H0 eps); auto.
+  intros x0 [H2 H3]; exists x0; split; auto.
+  intros x1 [H4 H5]; rewrite <- H; auto.
 Qed.
 
 Theorem limit1_imp :
- forall (f:R -> R) (D D1:R -> Prop) (l x:R),
-   (forall x:R, D1 x -> D x) -> limit1_in f D l x -> limit1_in f D1 l x.
-intros f D D1 l x H; unfold limit1_in, limit_in in |- *.
-intros H0 eps H1; case (H0 eps H1); auto.
-intros alpha [H2 H3]; exists alpha; split; auto.
-intros d [H4 H5]; apply H3; split; auto.
+  forall (f:R -> R) (D D1:R -> Prop) (l x:R),
+    (forall x:R, D1 x -> D x) -> limit1_in f D l x -> limit1_in f D1 l x.
+Proof.
+  intros f D D1 l x H; unfold limit1_in, limit_in in |- *.
+  intros H0 eps H1; case (H0 eps H1); auto.
+  intros alpha [H2 H3]; exists alpha; split; auto.
+  intros d [H4 H5]; apply H3; split; auto.
 Qed.
 
 Theorem Rinv_Rdiv : forall x y:R, x <> 0 -> y <> 0 -> / (x / y) = y / x.
-intros x y H1 H2; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
-rewrite Rinv_involutive.
-apply Rmult_comm.
-assumption.
-assumption.
-apply Rinv_neq_0_compat; assumption.
+Proof.
+  intros x y H1 H2; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  rewrite Rinv_involutive.
+  apply Rmult_comm.
+  assumption.
+  assumption.
+  apply Rinv_neq_0_compat; assumption.
 Qed.
 
 Theorem Dln : forall y:R, 0 < y -> D_in ln Rinv (fun x:R => 0 < x) y.
-intros y Hy; unfold D_in in |- *.
-apply limit1_ext with
- (f := fun x:R => / ((exp (ln x) - exp (ln y)) / (ln x - ln y))).
-intros x [HD1 HD2]; repeat rewrite exp_ln.
-unfold Rdiv in |- *; rewrite Rinv_mult_distr.
-rewrite Rinv_involutive.
-apply Rmult_comm.
-apply Rminus_eq_contra.
-red in |- *; intros H2; case HD2.
-symmetry  in |- *; apply (ln_inv _ _ HD1 Hy H2).
-apply Rminus_eq_contra; apply (sym_not_eq HD2).
-apply Rinv_neq_0_compat; apply Rminus_eq_contra; red in |- *; intros H2;
- case HD2; apply ln_inv; auto.
-assumption.
-assumption.
-apply limit_inv with
- (f := fun x:R => (exp (ln x) - exp (ln y)) / (ln x - ln y)).
-apply limit1_imp with
- (f := fun x:R => (fun x:R => (exp x - exp (ln y)) / (x - ln y)) (ln x))
- (D := Dgf (D_x (fun x:R => 0 < x) y) (D_x (fun x:R => True) (ln y)) ln).
-intros x [H1 H2]; split.
-split; auto.
-split; auto.
-red in |- *; intros H3; case H2; apply ln_inv; auto.
-apply limit_comp with
- (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln).
-apply ln_continue; auto.
-assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H); 
- intros; exists (pos x); split.
-apply (cond_pos x).
-intros; pattern y at 3 in |- *; rewrite <- exp_ln.
-pattern x0 at 1 in |- *; replace x0 with (ln y + (x0 - ln y));
- [ idtac | ring ].
-apply H1.
-elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3;
- apply Rminus_eq_contra; apply (sym_not_eq (A:=R)); 
- apply H3.
-elim H2; clear H2; intros _ H2; apply H2.
-assumption.
-red in |- *; intro; rewrite H in Hy; elim (Rlt_irrefl _ Hy).
+Proof.
+  intros y Hy; unfold D_in in |- *.
+  apply limit1_ext with
+    (f := fun x:R => / ((exp (ln x) - exp (ln y)) / (ln x - ln y))).
+  intros x [HD1 HD2]; repeat rewrite exp_ln.
+  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  rewrite Rinv_involutive.
+  apply Rmult_comm.
+  apply Rminus_eq_contra.
+  red in |- *; intros H2; case HD2.
+  symmetry  in |- *; apply (ln_inv _ _ HD1 Hy H2).
+  apply Rminus_eq_contra; apply (sym_not_eq HD2).
+  apply Rinv_neq_0_compat; apply Rminus_eq_contra; red in |- *; intros H2;
+    case HD2; apply ln_inv; auto.
+  assumption.
+  assumption.
+  apply limit_inv with
+    (f := fun x:R => (exp (ln x) - exp (ln y)) / (ln x - ln y)).
+  apply limit1_imp with
+    (f := fun x:R => (fun x:R => (exp x - exp (ln y)) / (x - ln y)) (ln x))
+    (D := Dgf (D_x (fun x:R => 0 < x) y) (D_x (fun x:R => True) (ln y)) ln).
+  intros x [H1 H2]; split.
+  split; auto.
+  split; auto.
+  red in |- *; intros H3; case H2; apply ln_inv; auto.
+  apply limit_comp with
+    (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln).
+  apply ln_continue; auto.
+  assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H); 
+        intros; exists (pos x); split.
+  apply (cond_pos x).
+  intros; pattern y at 3 in |- *; rewrite <- exp_ln.
+  pattern x0 at 1 in |- *; replace x0 with (ln y + (x0 - ln y));
+    [ idtac | ring ].
+  apply H1.
+  elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3;
+    apply Rminus_eq_contra; apply (sym_not_eq (A:=R)); 
+      apply H3.
+  elim H2; clear H2; intros _ H2; apply H2.
+  assumption.
+  red in |- *; intro; rewrite H in Hy; elim (Rlt_irrefl _ Hy).
 Qed.
 
 Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x).
-intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0;
- unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
- unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1); 
- intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2));
- assert (H4 : 0 < alp).
-unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec x0 (x / 2)); intro.
-apply H2.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-exists (mkposreal _ H4); intros; pattern h at 2 in |- *;
- replace h with (x + h - x); [ idtac | ring ].
-apply H3; split.
-unfold D_x in |- *; split.
-case (Rcase_abs h); intro.
-assert (H7 : Rabs h < x / 2).
-apply Rlt_le_trans with alp.
-apply H6.
-unfold alp in |- *; apply Rmin_r.
-apply Rlt_trans with (x / 2).
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-rewrite Rabs_left in H7.
-apply Rplus_lt_reg_r with (- h - x / 2).
-replace (- h - x / 2 + x / 2) with (- h); [ idtac | ring ].
-pattern x at 2 in |- *; rewrite double_var.
-replace (- h - x / 2 + (x / 2 + x / 2 + h)) with (x / 2); [ apply H7 | ring ].
-apply r.
-apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply r ].
-apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
- [ apply H5 | ring ].
-replace (x + h - x) with h;
- [ apply Rlt_le_trans with alp;
+Proof.
+  intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0;
+    unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
+      unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1); 
+        intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2));
+          assert (H4 : 0 < alp).
+  unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec x0 (x / 2)); intro.
+  apply H2.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  exists (mkposreal _ H4); intros; pattern h at 2 in |- *;
+    replace h with (x + h - x); [ idtac | ring ].
+  apply H3; split.
+  unfold D_x in |- *; split.
+  case (Rcase_abs h); intro.
+  assert (H7 : Rabs h < x / 2).
+  apply Rlt_le_trans with alp.
+  apply H6.
+  unfold alp in |- *; apply Rmin_r.
+  apply Rlt_trans with (x / 2).
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+  rewrite Rabs_left in H7.
+  apply Rplus_lt_reg_r with (- h - x / 2).
+  replace (- h - x / 2 + x / 2) with (- h); [ idtac | ring ].
+  pattern x at 2 in |- *; rewrite double_var.
+  replace (- h - x / 2 + (x / 2 + x / 2 + h)) with (x / 2); [ apply H7 | ring ].
+  apply r.
+  apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply r ].
+  apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
+    [ apply H5 | ring ].
+  replace (x + h - x) with h;
+  [ apply Rlt_le_trans with alp;
     [ apply H6 | unfold alp in |- *; apply Rmin_l ]
- | ring ].
+    | ring ].
 Qed.
 
 Theorem D_in_imp :
- forall (f g:R -> R) (D D1:R -> Prop) (x:R),
-   (forall x:R, D1 x -> D x) -> D_in f g D x -> D_in f g D1 x.
-intros f g D D1 x H; unfold D_in in |- *.
-intros H0; apply limit1_imp with (D := D_x D x); auto.
-intros x1 [H1 H2]; split; auto.
+  forall (f g:R -> R) (D D1:R -> Prop) (x:R),
+    (forall x:R, D1 x -> D x) -> D_in f g D x -> D_in f g D1 x.
+Proof.
+  intros f g D D1 x H; unfold D_in in |- *.
+  intros H0; apply limit1_imp with (D := D_x D x); auto.
+  intros x1 [H1 H2]; split; auto.
 Qed.
 
 Theorem D_in_ext :
- forall (f g h:R -> R) (D:R -> Prop) (x:R),
-   f x = g x -> D_in h f D x -> D_in h g D x.
-intros f g h D x H; unfold D_in in |- *.
-rewrite H; auto.
+  forall (f g h:R -> R) (D:R -> Prop) (x:R),
+    f x = g x -> D_in h f D x -> D_in h g D x.
+Proof.
+  intros f g h D x H; unfold D_in in |- *.
+  rewrite H; auto.
 Qed.
 
 Theorem Dpower :
- forall y z:R,
-   0 < y ->
-   D_in (fun x:R => x ^R z) (fun x:R => z * x ^R (z - 1)) (
-     fun x:R => 0 < x) y.
-intros y z H;
- apply D_in_imp with (D := Dgf (fun x:R => 0 < x) (fun x:R => True) ln).
-intros x H0; repeat split.
-assumption.
-apply D_in_ext with (f := fun x:R => / x * (z * exp (z * ln x))).
-unfold Rminus in |- *; rewrite Rpower_plus; rewrite Rpower_Ropp;
- rewrite (Rpower_1 _ H); ring.
-apply Dcomp with
- (f := ln)
- (g := fun x:R => exp (z * x))
- (df := Rinv)
- (dg := fun x:R => z * exp (z * x)).
-apply (Dln _ H).
-apply D_in_imp with
- (D := Dgf (fun x:R => True) (fun x:R => True) (fun x:R => z * x)).
-intros x H1; repeat split; auto.
-apply
- (Dcomp (fun _:R => True) (fun _:R => True) (fun x => z) exp
-    (fun x:R => z * x) exp); simpl in |- *.
-apply D_in_ext with (f := fun x:R => z * 1).
-apply Rmult_1_r.
-apply (Dmult_const (fun x => True) (fun x => x) (fun x => 1)); apply Dx.
-assert (H0 := derivable_pt_lim_D_in exp exp (z * ln y)); elim H0; clear H0;
- intros _ H0; apply H0; apply derivable_pt_lim_exp.
+  forall y z:R,
+    0 < y ->
+    D_in (fun x:R => x ^R z) (fun x:R => z * x ^R (z - 1)) (
+      fun x:R => 0 < x) y.
+Proof.
+  intros y z H;
+    apply D_in_imp with (D := Dgf (fun x:R => 0 < x) (fun x:R => True) ln).
+  intros x H0; repeat split.
+  assumption.
+  apply D_in_ext with (f := fun x:R => / x * (z * exp (z * ln x))).
+  unfold Rminus in |- *; rewrite Rpower_plus; rewrite Rpower_Ropp;
+    rewrite (Rpower_1 _ H); unfold Rpower; ring.
+  apply Dcomp with
+    (f := ln)
+    (g := fun x:R => exp (z * x))
+    (df := Rinv)
+    (dg := fun x:R => z * exp (z * x)).
+  apply (Dln _ H).
+  apply D_in_imp with
+    (D := Dgf (fun x:R => True) (fun x:R => True) (fun x:R => z * x)).
+  intros x H1; repeat split; auto.
+  apply
+    (Dcomp (fun _:R => True) (fun _:R => True) (fun x => z) exp
+      (fun x:R => z * x) exp); simpl in |- *.
+  apply D_in_ext with (f := fun x:R => z * 1).
+  apply Rmult_1_r.
+  apply (Dmult_const (fun x => True) (fun x => x) (fun x => 1)); apply Dx.
+  assert (H0 := derivable_pt_lim_D_in exp exp (z * ln y)); elim H0; clear H0;
+    intros _ H0; apply H0; apply derivable_pt_lim_exp.
 Qed.
 
 Theorem derivable_pt_lim_power :
- forall x y:R,
-   0 < x -> derivable_pt_lim (fun x => x ^R y) x (y * x ^R (y - 1)).
-intros x y H.
-unfold Rminus in |- *; rewrite Rpower_plus.
-rewrite Rpower_Ropp.
-rewrite Rpower_1; auto.
-rewrite <- Rmult_assoc.
-unfold Rpower in |- *.
-apply derivable_pt_lim_comp with (f1 := ln) (f2 := fun x => exp (y * x)).
-apply derivable_pt_lim_ln; assumption.
-rewrite (Rmult_comm y).
-apply derivable_pt_lim_comp with (f1 := fun x => y * x) (f2 := exp).
-pattern y at 2 in |- *; replace y with (0 * ln x + y * 1).
-apply derivable_pt_lim_mult with (f1 := fun x:R => y) (f2 := fun x:R => x).
-apply derivable_pt_lim_const with (a := y).
-apply derivable_pt_lim_id.
-ring.
-apply derivable_pt_lim_exp.
-Qed.
\ No newline at end of file
+  forall x y:R,
+    0 < x -> derivable_pt_lim (fun x => x ^R y) x (y * x ^R (y - 1)).
+Proof.
+  intros x y H.
+  unfold Rminus in |- *; rewrite Rpower_plus.
+  rewrite Rpower_Ropp.
+  rewrite Rpower_1; auto.
+  rewrite <- Rmult_assoc.
+  unfold Rpower in |- *.
+  apply derivable_pt_lim_comp with (f1 := ln) (f2 := fun x => exp (y * x)).
+  apply derivable_pt_lim_ln; assumption.
+  rewrite (Rmult_comm y).
+  apply derivable_pt_lim_comp with (f1 := fun x => y * x) (f2 := exp).
+  pattern y at 2 in |- *; replace y with (0 * ln x + y * 1).
+  apply derivable_pt_lim_mult with (f1 := fun x:R => y) (f2 := fun x:R => x).
+  apply derivable_pt_lim_const with (a := y).
+  apply derivable_pt_lim_id.
+  ring.
+  apply derivable_pt_lim_exp.
+Qed.
diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v
index 6577146f..a84d5149 100644
--- a/theories/Reals/Rprod.v
+++ b/theories/Reals/Rprod.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Rprod.v,v 1.10.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+(*i $Id: Rprod.v 9298 2006-10-27 13:05:29Z notin $ i*)
 
 Require Import Compare.
 Require Import Rbase.
@@ -16,176 +16,156 @@ Require Import PartSum.
 Require Import Binomial.
 Open Local Scope R_scope.
 
-(* TT Ak; 1<=k<=N *)
-Fixpoint prod_f_SO (An:nat -> R) (N:nat) {struct N} : R :=
+(** TT Ak; 1<=k<=N *)
+Boxed Fixpoint prod_f_SO (An:nat -> R) (N:nat) {struct N} : R :=
   match N with
-  | O => 1
-  | S p => prod_f_SO An p * An (S p)
+    | O => 1
+    | S p => prod_f_SO An p * An (S p)
   end.
 
 (**********)
 Lemma prod_SO_split :
- forall (An:nat -> R) (n k:nat),
-   (k <= n)%nat ->
-   prod_f_SO An n =
-   prod_f_SO An k * prod_f_SO (fun l:nat => An (k + l)%nat) (n - k).
-intros; induction  n as [| n Hrecn].
-cut (k = 0%nat);
- [ intro; rewrite H0; simpl in |- *; ring | inversion H; reflexivity ].
-cut (k = S n \/ (k <= n)%nat).
-intro; elim H0; intro.
-rewrite H1; simpl in |- *; rewrite <- minus_n_n; simpl in |- *; ring.
-replace (S n - k)%nat with (S (n - k)).
-simpl in |- *; replace (k + S (n - k))%nat with (S n).
-rewrite Hrecn; [ ring | assumption ].
-apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite S_INR;
- rewrite minus_INR; [ ring | assumption ].
-apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
-rewrite S_INR; ring.
-apply le_trans with n; [ assumption | apply le_n_Sn ].
-assumption.
-inversion H; [ left; reflexivity | right; assumption ].
+  forall (An:nat -> R) (n k:nat),
+    (k <= n)%nat ->
+    prod_f_SO An n =
+    prod_f_SO An k * prod_f_SO (fun l:nat => An (k + l)%nat) (n - k).
+Proof.
+  intros; induction  n as [| n Hrecn].
+  cut (k = 0%nat);
+    [ intro; rewrite H0; simpl in |- *; ring | inversion H; reflexivity ].
+  cut (k = S n \/ (k <= n)%nat).
+  intro; elim H0; intro.
+  rewrite H1; simpl in |- *; rewrite <- minus_n_n; simpl in |- *; ring.
+  replace (S n - k)%nat with (S (n - k)).
+  simpl in |- *; replace (k + S (n - k))%nat with (S n).
+  rewrite Hrecn; [ ring | assumption ].
+  omega.
+  omega.
+  omega.
 Qed.
 
 (**********)
 Lemma prod_SO_pos :
- forall (An:nat -> R) (N:nat),
-   (forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_SO An N.
-intros; induction  N as [| N HrecN].
-simpl in |- *; left; apply Rlt_0_1.
-simpl in |- *; apply Rmult_le_pos.
-apply HrecN; intros; apply H; apply le_trans with N;
- [ assumption | apply le_n_Sn ].
-apply H; apply le_n.
+  forall (An:nat -> R) (N:nat),
+    (forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_SO An N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  simpl in |- *; left; apply Rlt_0_1.
+  simpl in |- *; apply Rmult_le_pos.
+  apply HrecN; intros; apply H; apply le_trans with N;
+    [ assumption | apply le_n_Sn ].
+  apply H; apply le_n.
 Qed.
 
 (**********)
 Lemma prod_SO_Rle :
- forall (An Bn:nat -> R) (N:nat),
-   (forall n:nat, (n <= N)%nat -> 0 <= An n <= Bn n) ->
-   prod_f_SO An N <= prod_f_SO Bn N.
-intros; induction  N as [| N HrecN].
-right; reflexivity.
-simpl in |- *; apply Rle_trans with (prod_f_SO An N * Bn (S N)).
-apply Rmult_le_compat_l.
-apply prod_SO_pos; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
- assumption.
-elim (H (S N) (le_n (S N))); intros; assumption.
-do 2 rewrite <- (Rmult_comm (Bn (S N))); apply Rmult_le_compat_l.
-elim (H (S N) (le_n (S N))); intros.
-apply Rle_trans with (An (S N)); assumption.
-apply HrecN; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
- split; assumption.
+  forall (An Bn:nat -> R) (N:nat),
+    (forall n:nat, (n <= N)%nat -> 0 <= An n <= Bn n) ->
+    prod_f_SO An N <= prod_f_SO Bn N.
+Proof.
+  intros; induction  N as [| N HrecN].
+  right; reflexivity.
+  simpl in |- *; apply Rle_trans with (prod_f_SO An N * Bn (S N)).
+  apply Rmult_le_compat_l.
+  apply prod_SO_pos; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
+    assumption.
+  elim (H (S N) (le_n (S N))); intros; assumption.
+  do 2 rewrite <- (Rmult_comm (Bn (S N))); apply Rmult_le_compat_l.
+  elim (H (S N) (le_n (S N))); intros.
+  apply Rle_trans with (An (S N)); assumption.
+  apply HrecN; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
+    split; assumption.
 Qed.
 
-(* Application to factorial *)
+(** Application to factorial *)
 Lemma fact_prodSO :
- forall n:nat, INR (fact n) = prod_f_SO (fun k:nat => INR k) n.
-intro; induction  n as [| n Hrecn].
-reflexivity.
-change (INR (S n * fact n) = prod_f_SO (fun k:nat => INR k) (S n)) in |- *.
-rewrite mult_INR; rewrite Rmult_comm; rewrite Hrecn; reflexivity.
+  forall n:nat, INR (fact n) = prod_f_SO (fun k:nat => INR k) n.
+Proof.
+  intro; induction  n as [| n Hrecn].
+  reflexivity.
+  change (INR (S n * fact n) = prod_f_SO (fun k:nat => INR k) (S n)) in |- *.
+  rewrite mult_INR; rewrite Rmult_comm; rewrite Hrecn; reflexivity.
 Qed.
 
 Lemma le_n_2n : forall n:nat, (n <= 2 * n)%nat.
-simple induction n.
-replace (2 * 0)%nat with 0%nat; [ apply le_n | ring ].
-intros; replace (2 * S n0)%nat with (S (S (2 * n0))).
-apply le_n_S; apply le_S; assumption.
-replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ].
-replace (S n0) with (n0 + 1)%nat; [ idtac | ring ].
-ring.
+Proof.
+  simple induction n.
+  replace (2 * 0)%nat with 0%nat; [ apply le_n | ring ].
+  intros; replace (2 * S n0)%nat with (S (S (2 * n0))).
+  apply le_n_S; apply le_S; assumption.
+  replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ].
+  replace (S n0) with (n0 + 1)%nat; [ idtac | ring ].
+  ring.
 Qed. 
 
-(* We prove that (N!)²<=(2N-k)!*k! forall k in [|O;2N|] *)
+(** We prove that (N!)^2<=(2N-k)!*k! forall k in [|O;2N|] *)
 Lemma RfactN_fact2N_factk :
- forall N k:nat,
-   (k <= 2 * N)%nat ->
-   Rsqr (INR (fact N)) <= INR (fact (2 * N - k)) * INR (fact k).
-intros; unfold Rsqr in |- *; repeat rewrite fact_prodSO.
-cut ((k <= N)%nat \/ (N <= k)%nat).
-intro; elim H0; intro.
-rewrite (prod_SO_split (fun l:nat => INR l) (2 * N - k) N).
-rewrite Rmult_assoc; apply Rmult_le_compat_l.
-apply prod_SO_pos; intros; apply pos_INR.
-replace (2 * N - k - N)%nat with (N - k)%nat.
-rewrite Rmult_comm; rewrite (prod_SO_split (fun l:nat => INR l) N k).
-apply Rmult_le_compat_l.
-apply prod_SO_pos; intros; apply pos_INR.
-apply prod_SO_Rle; intros; split.
-apply pos_INR.
-apply le_INR; apply plus_le_compat_r; assumption.
-assumption.
-apply INR_eq; repeat rewrite minus_INR.
-rewrite mult_INR; repeat rewrite S_INR; ring.
-apply le_trans with N; [ assumption | apply le_n_2n ].
-apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
-replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
-apply plus_le_compat_r; assumption.
-assumption.
-assumption.
-apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
-replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
-apply plus_le_compat_r; assumption.
-assumption.
-rewrite <- (Rmult_comm (prod_f_SO (fun l:nat => INR l) k));
- rewrite (prod_SO_split (fun l:nat => INR l) k N).
-rewrite Rmult_assoc; apply Rmult_le_compat_l.
-apply prod_SO_pos; intros; apply pos_INR.
-rewrite Rmult_comm;
- rewrite (prod_SO_split (fun l:nat => INR l) N (2 * N - k)).
-apply Rmult_le_compat_l.
-apply prod_SO_pos; intros; apply pos_INR.
-replace (N - (2 * N - k))%nat with (k - N)%nat.
-apply prod_SO_Rle; intros; split.
-apply pos_INR.
-apply le_INR; apply plus_le_compat_r.
-apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
-replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ];
- apply plus_le_compat_r; assumption.
-assumption.
-apply INR_eq; repeat rewrite minus_INR.
-rewrite mult_INR; do 2 rewrite S_INR; ring.
-assumption.
-apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
-replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ];
- apply plus_le_compat_r; assumption.
-assumption.
-assumption.
-apply (fun p n m:nat => plus_le_reg_l n m p) with k; rewrite <- le_plus_minus.
-replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ];
- apply plus_le_compat_r; assumption.
-assumption.
-assumption.
-elim (le_dec k N); intro; [ left; assumption | right; assumption ].
+  forall N k:nat,
+    (k <= 2 * N)%nat ->
+    Rsqr (INR (fact N)) <= INR (fact (2 * N - k)) * INR (fact k).
+Proof.
+  intros; unfold Rsqr in |- *; repeat rewrite fact_prodSO.
+  cut ((k <= N)%nat \/ (N <= k)%nat).
+  intro; elim H0; intro.
+  rewrite (prod_SO_split (fun l:nat => INR l) (2 * N - k) N).
+  rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  apply prod_SO_pos; intros; apply pos_INR.
+  replace (2 * N - k - N)%nat with (N - k)%nat.
+  rewrite Rmult_comm; rewrite (prod_SO_split (fun l:nat => INR l) N k).
+  apply Rmult_le_compat_l.
+  apply prod_SO_pos; intros; apply pos_INR.
+  apply prod_SO_Rle; intros; split.
+  apply pos_INR.
+  apply le_INR; apply plus_le_compat_r; assumption.
+  assumption.
+  omega.
+  omega.
+  rewrite <- (Rmult_comm (prod_f_SO (fun l:nat => INR l) k));
+    rewrite (prod_SO_split (fun l:nat => INR l) k N).
+  rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  apply prod_SO_pos; intros; apply pos_INR.
+  rewrite Rmult_comm;
+    rewrite (prod_SO_split (fun l:nat => INR l) N (2 * N - k)).
+  apply Rmult_le_compat_l.
+  apply prod_SO_pos; intros; apply pos_INR.
+  replace (N - (2 * N - k))%nat with (k - N)%nat.
+  apply prod_SO_Rle; intros; split.
+  apply pos_INR.
+  apply le_INR; apply plus_le_compat_r.
+  omega.
+  omega.
+  omega.
+  assumption.
+  omega.
 Qed.
 
 (**********)
 Lemma INR_fact_lt_0 : forall n:nat, 0 < INR (fact n).
-intro; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
- elim (fact_neq_0 n); symmetry  in |- *; assumption.
+Proof.
+  intro; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
+    elim (fact_neq_0 n); symmetry  in |- *; assumption.
 Qed.
 
-(* We have the following inequality : (C 2N k) <= (C 2N N) forall k in [|O;2N|] *)
+(** We have the following inequality : (C 2N k) <= (C 2N N) forall k in [|O;2N|] *)
 Lemma C_maj : forall N k:nat, (k <= 2 * N)%nat -> C (2 * N) k <= C (2 * N) N.
-intros; unfold C in |- *; unfold Rdiv in |- *; apply Rmult_le_compat_l.
-apply pos_INR.
-replace (2 * N - N)%nat with N.
-apply Rmult_le_reg_l with (INR (fact N) * INR (fact N)).
-apply Rmult_lt_0_compat; apply INR_fact_lt_0.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_comm;
- apply Rmult_le_reg_l with (INR (fact k) * INR (fact (2 * N - k))).
-apply Rmult_lt_0_compat; apply INR_fact_lt_0.
-rewrite Rmult_1_r; rewrite <- mult_INR; rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; rewrite mult_INR; rewrite (Rmult_comm (INR (fact k)));
- replace (INR (fact N) * INR (fact N)) with (Rsqr (INR (fact N))).
-apply RfactN_fact2N_factk.
-assumption.
-reflexivity.
-rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0.
-apply prod_neq_R0; apply INR_fact_neq_0.
-apply INR_eq; rewrite minus_INR;
- [ rewrite mult_INR; do 2 rewrite S_INR; ring | apply le_n_2n ].
-Qed.
\ No newline at end of file
+Proof.
+  intros; unfold C in |- *; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+  apply pos_INR.
+  replace (2 * N - N)%nat with N.
+  apply Rmult_le_reg_l with (INR (fact N) * INR (fact N)).
+  apply Rmult_lt_0_compat; apply INR_fact_lt_0.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_comm;
+    apply Rmult_le_reg_l with (INR (fact k) * INR (fact (2 * N - k))).
+  apply Rmult_lt_0_compat; apply INR_fact_lt_0.
+  rewrite Rmult_1_r; rewrite <- mult_INR; rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite mult_INR; rewrite (Rmult_comm (INR (fact k)));
+    replace (INR (fact N) * INR (fact N)) with (Rsqr (INR (fact N))).
+  apply RfactN_fact2N_factk.
+  assumption.
+  reflexivity.
+  rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0.
+  apply prod_neq_R0; apply INR_fact_neq_0.
+  omega.
+Qed.
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
index cbf93278..38c39bae 100644
--- a/theories/Reals/Rseries.v
+++ b/theories/Reals/Rseries.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rseries.v,v 1.11.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+(*i $Id: Rseries.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -18,258 +18,266 @@ Implicit Type r : R.
 
 (* classical is needed for [Un_cv_crit] *)
 (*********************************************************)
-(*           Definition of sequence and properties       *)
+(** *        Definition of sequence and properties       *)
 (*                                                       *)
 (*********************************************************)
 
 Section sequence.
 
 (*********)
-Variable Un : nat -> R.
+  Variable Un : nat -> R.
 
 (*********)
-Fixpoint Rmax_N (N:nat) : R :=
-  match N with
-  | O => Un 0
-  | S n => Rmax (Un (S n)) (Rmax_N n)
-  end.
+  Boxed Fixpoint Rmax_N (N:nat) : R :=
+    match N with
+      | O => Un 0
+      | S n => Rmax (Un (S n)) (Rmax_N n)
+    end.
 
 (*********)
-Definition EUn r : Prop :=  exists i : nat, r = Un i.
+  Definition EUn r : Prop :=  exists i : nat, r = Un i.
 
 (*********)
-Definition Un_cv (l:R) : Prop :=
-  forall eps:R,
-    eps > 0 ->
-     exists N : nat, (forall n:nat, (n >= N)%nat -> R_dist (Un n) l < eps).
+  Definition Un_cv (l:R) : Prop :=
+    forall eps:R,
+      eps > 0 ->
+      exists N : nat, (forall n:nat, (n >= N)%nat -> R_dist (Un n) l < eps).
 
 (*********)
-Definition Cauchy_crit : Prop :=
-  forall eps:R,
-    eps > 0 ->
-     exists N : nat,
-      (forall n m:nat,
-         (n >= N)%nat -> (m >= N)%nat -> R_dist (Un n) (Un m) < eps).
+  Definition Cauchy_crit : Prop :=
+    forall eps:R,
+      eps > 0 ->
+      exists N : nat,
+        (forall n m:nat,
+          (n >= N)%nat -> (m >= N)%nat -> R_dist (Un n) (Un m) < eps).
 
 (*********)
-Definition Un_growing : Prop := forall n:nat, Un n <= Un (S n).
+  Definition Un_growing : Prop := forall n:nat, Un n <= Un (S n).
 
 (*********)
-Lemma EUn_noempty :  exists r : R, EUn r.
-unfold EUn in |- *; split with (Un 0); split with 0%nat; trivial.
-Qed.
+  Lemma EUn_noempty :  exists r : R, EUn r.
+  Proof.
+    unfold EUn in |- *; split with (Un 0); split with 0%nat; trivial.
+  Qed.
 
 (*********)
-Lemma Un_in_EUn : forall n:nat, EUn (Un n).
-intro; unfold EUn in |- *; split with n; trivial.
-Qed.
+  Lemma Un_in_EUn : forall n:nat, EUn (Un n).
+  Proof.
+    intro; unfold EUn in |- *; split with n; trivial.
+  Qed.
 
 (*********)
-Lemma Un_bound_imp :
- forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x.
-intros; unfold is_upper_bound in |- *; intros; unfold EUn in H0; elim H0;
- clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; 
- trivial.
-Qed.
+  Lemma Un_bound_imp :
+    forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x.
+  Proof.
+    intros; unfold is_upper_bound in |- *; intros; unfold EUn in H0; elim H0;
+      clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; 
+        trivial.
+  Qed.
 
 (*********)
-Lemma growing_prop :
- forall n m:nat, Un_growing -> (n >= m)%nat -> Un n >= Un m.
-double induction n m; intros.
-unfold Rge in |- *; right; trivial.
-elimtype False; unfold ge in H1; generalize (le_Sn_O n0); intro; auto.
-cut (n0 >= 0)%nat.
-generalize H0; intros; unfold Un_growing in H0;
- apply
-  (Rge_trans (Un (S n0)) (Un n0) (Un 0) (Rle_ge (Un n0) (Un (S n0)) (H0 n0))
-     (H 0%nat H2 H3)).
-elim n0; auto.
-elim (lt_eq_lt_dec n1 n0); intro y.
-elim y; clear y; intro y.
-unfold ge in H2; generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2)); intro;
- elimtype False; auto.
-rewrite y; unfold Rge in |- *; right; trivial.
-unfold ge in H0; generalize (H0 (S n0) H1 (lt_le_S n0 n1 y)); intro;
- unfold Un_growing in H1;
- apply
-  (Rge_trans (Un (S n1)) (Un n1) (Un (S n0))
-     (Rle_ge (Un n1) (Un (S n1)) (H1 n1)) H3).
-Qed.
+  Lemma growing_prop :
+    forall n m:nat, Un_growing -> (n >= m)%nat -> Un n >= Un m.
+  Proof.
+    double induction n m; intros.
+    unfold Rge in |- *; right; trivial.
+    elimtype False; unfold ge in H1; generalize (le_Sn_O n0); intro; auto.
+    cut (n0 >= 0)%nat.
+    generalize H0; intros; unfold Un_growing in H0;
+      apply
+        (Rge_trans (Un (S n0)) (Un n0) (Un 0) (Rle_ge (Un n0) (Un (S n0)) (H0 n0))
+          (H 0%nat H2 H3)).
+    elim n0; auto.
+    elim (lt_eq_lt_dec n1 n0); intro y.
+    elim y; clear y; intro y.
+    unfold ge in H2; generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2)); intro;
+      elimtype False; auto.
+    rewrite y; unfold Rge in |- *; right; trivial.
+    unfold ge in H0; generalize (H0 (S n0) H1 (lt_le_S n0 n1 y)); intro;
+      unfold Un_growing in H1;
+        apply
+          (Rge_trans (Un (S n1)) (Un n1) (Un (S n0))
+            (Rle_ge (Un n1) (Un (S n1)) (H1 n1)) H3).
+  Qed.
 
 
-(* classical is needed: [not_all_not_ex] *)
+(** classical is needed: [not_all_not_ex] *)
 (*********)
-Lemma Un_cv_crit : Un_growing -> bound EUn ->  exists l : R, Un_cv l.
-unfold Un_growing, Un_cv in |- *; intros;
- generalize (completeness_weak EUn H0 EUn_noempty); 
- intro; elim H1; clear H1; intros; split with x; intros; 
- unfold is_lub in H1; unfold bound in H0; unfold is_upper_bound in H0, H1;
- elim H0; clear H0; intros; elim H1; clear H1; intros; 
- generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); 
- intro.
-cut (exists N : nat, x - eps < Un N).
-intro; elim H6; clear H6; intros; split with x1.
-intros; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
-unfold Rgt in H2;
- apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H2).
-fold Un_growing in H; generalize (growing_prop n x1 H H7); intro;
- generalize
-  (Rlt_le_trans (x - eps) (Un x1) (Un n) H6 (Rge_le (Un n) (Un x1) H8));
- intro; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
- unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
- rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
- rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
- trivial.
-cut (~ (forall N:nat, x - eps >= Un N)).
-intro; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)); red in |- *;
- intro; red in H6; elim H6; clear H6; intro;
- apply (Rnot_lt_ge (x - eps) (Un N) (H7 N)).
-red in |- *; intro; cut (forall N:nat, Un N <= x - eps).
-intro; generalize (Un_bound_imp (x - eps) H7); intro;
- unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); 
- intro; generalize (Rle_minus x (x - eps) H9); unfold Rminus in |- *;
- rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
- rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); 
- rewrite Ropp_involutive; intro; unfold Rgt in H2;
- generalize (Rgt_not_le eps 0 H2); intro; auto.
-intro; elim (H6 N); intro; unfold Rle in |- *.
-left; unfold Rgt in H7; assumption.
-right; auto.
-apply (H1 (Un n) (Un_in_EUn n)).
-Qed.
+  Lemma Un_cv_crit : Un_growing -> bound EUn ->  exists l : R, Un_cv l.
+  Proof.
+    unfold Un_growing, Un_cv in |- *; intros;
+      generalize (completeness_weak EUn H0 EUn_noempty); 
+        intro; elim H1; clear H1; intros; split with x; intros; 
+          unfold is_lub in H1; unfold bound in H0; unfold is_upper_bound in H0, H1;
+            elim H0; clear H0; intros; elim H1; clear H1; intros; 
+              generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); 
+                intro.
+    cut (exists N : nat, x - eps < Un N).
+    intro; elim H6; clear H6; intros; split with x1.
+    intros; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
+    unfold Rgt in H2;
+      apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H2).
+    fold Un_growing in H; generalize (growing_prop n x1 H H7); intro;
+      generalize
+        (Rlt_le_trans (x - eps) (Un x1) (Un n) H6 (Rge_le (Un n) (Un x1) H8));
+        intro; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
+          unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
+            rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
+              rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
+                trivial.
+    cut (~ (forall N:nat, x - eps >= Un N)).
+    intro; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)); red in |- *;
+      intro; red in H6; elim H6; clear H6; intro;
+        apply (Rnot_lt_ge (x - eps) (Un N) (H7 N)).
+    red in |- *; intro; cut (forall N:nat, Un N <= x - eps).
+    intro; generalize (Un_bound_imp (x - eps) H7); intro;
+      unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); 
+        intro; generalize (Rle_minus x (x - eps) H9); unfold Rminus in |- *;
+          rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
+            rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); 
+              rewrite Ropp_involutive; intro; unfold Rgt in H2;
+                generalize (Rgt_not_le eps 0 H2); intro; auto.
+    intro; elim (H6 N); intro; unfold Rle in |- *.
+    left; unfold Rgt in H7; assumption.
+    right; auto.
+    apply (H1 (Un n) (Un_in_EUn n)).
+  Qed.
 
 (*********)
-Lemma finite_greater :
- forall N:nat,  exists M : R, (forall n:nat, (n <= N)%nat -> Un n <= M).
-intro; induction  N as [| N HrecN].
-split with (Un 0); intros; rewrite (le_n_O_eq n H);
- apply (Req_le (Un n) (Un n) (refl_equal (Un n))).
-elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros;
- elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; 
- inversion H0.
-rewrite <- H1; rewrite <- H1 in H2;
- apply
-  (H2 (or_introl (Un n <= x) (Req_le (Un n) (Un n) (refl_equal (Un n))))).
-apply (H2 (or_intror (Un n <= Un (S N)) (H n H3))).
-Qed.
+  Lemma finite_greater :
+    forall N:nat,  exists M : R, (forall n:nat, (n <= N)%nat -> Un n <= M).
+  Proof.
+    intro; induction  N as [| N HrecN].
+    split with (Un 0); intros; rewrite (le_n_O_eq n H);
+      apply (Req_le (Un n) (Un n) (refl_equal (Un n))).
+    elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros;
+      elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; 
+        inversion H0.
+    rewrite <- H1; rewrite <- H1 in H2;
+      apply
+        (H2 (or_introl (Un n <= x) (Req_le (Un n) (Un n) (refl_equal (Un n))))).
+    apply (H2 (or_intror (Un n <= Un (S N)) (H n H3))).
+  Qed.
 
 (*********)
-Lemma cauchy_bound : Cauchy_crit -> bound EUn.
-unfold Cauchy_crit, bound in |- *; intros; unfold is_upper_bound in |- *;
- unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; 
- generalize (H x); intro; generalize (le_dec x); intro;
- elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); 
- clear H; intros; unfold EUn in H; elim H; clear H; 
- intros; elim (H1 x2); clear H1; intro y.
-unfold ge in H0; generalize (H0 x2 (le_n x) y); clear H0; intro;
- rewrite <- H in H0; unfold R_dist in H0; elim (Rabs_def2 (Un x - x1) 1 H0);
- clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); 
- intros; apply H4; clear H3 H4; right; clear H H0 y;
- apply (Rlt_le x1 (Un x + 1)); generalize (Rlt_minus (-1) (Un x - x1) H1);
- clear H1; intro; apply (Rminus_lt x1 (Un x + 1));
- cut (-1 - (Un x - x1) = x1 - (Un x + 1));
- [ intro; rewrite H0 in H; assumption | ring ].
-generalize (H2 x2 y); clear H2 H0; intro; rewrite <- H in H0;
- elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; 
- apply H2; left; assumption.
-Qed.
+  Lemma cauchy_bound : Cauchy_crit -> bound EUn.
+  Proof.
+    unfold Cauchy_crit, bound in |- *; intros; unfold is_upper_bound in |- *;
+      unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; 
+        generalize (H x); intro; generalize (le_dec x); intro;
+          elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); 
+            clear H; intros; unfold EUn in H; elim H; clear H; 
+              intros; elim (H1 x2); clear H1; intro y.
+    unfold ge in H0; generalize (H0 x2 (le_n x) y); clear H0; intro;
+      rewrite <- H in H0; unfold R_dist in H0; elim (Rabs_def2 (Un x - x1) 1 H0);
+        clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); 
+          intros; apply H4; clear H3 H4; right; clear H H0 y;
+            apply (Rlt_le x1 (Un x + 1)); generalize (Rlt_minus (-1) (Un x - x1) H1);
+              clear H1; intro; apply (Rminus_lt x1 (Un x + 1));
+                cut (-1 - (Un x - x1) = x1 - (Un x + 1));
+                  [ intro; rewrite H0 in H; assumption | ring ].
+    generalize (H2 x2 y); clear H2 H0; intro; rewrite <- H in H0;
+      elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; 
+        apply H2; left; assumption.
+  Qed.
 
 End sequence.
 
 (*****************************************************************)
-(*           Definition of Power Series and properties           *)
+(**  *       Definition of Power Series and properties           *)
 (*                                                               *)
 (*****************************************************************)
 
 Section Isequence.
 
 (*********)
-Variable An : nat -> R.
+  Variable An : nat -> R.
 
 (*********)
-Definition Pser (x l:R) : Prop := infinit_sum (fun n:nat => An n * x ^ n) l.
+  Definition Pser (x l:R) : Prop := infinit_sum (fun n:nat => An n * x ^ n) l.
 
 End Isequence.
 
 Lemma GP_infinite :
- forall x:R, Rabs x < 1 -> Pser (fun n:nat => 1) x (/ (1 - x)).
-intros; unfold Pser in |- *; unfold infinit_sum in |- *; intros;
- elim (Req_dec x 0).
-intros; exists 0%nat; intros; rewrite H1; rewrite Rminus_0_r; rewrite Rinv_1;
- cut (sum_f_R0 (fun n0:nat => 1 * 0 ^ n0) n = 1).
-intros; rewrite H3; rewrite R_dist_eq; auto.
-elim n; simpl in |- *.
-ring.
-intros; rewrite H3; ring.
-intro; cut (0 < eps * (Rabs (1 - x) * Rabs (/ x))).
-intro; elim (pow_lt_1_zero x H (eps * (Rabs (1 - x) * Rabs (/ x))) H2);
- intro N; intros; exists N; intros;
- cut
-  (sum_f_R0 (fun n0:nat => 1 * x ^ n0) n = sum_f_R0 (fun n0:nat => x ^ n0) n).
-intros; rewrite H5;
- apply
-  (Rmult_lt_reg_l (Rabs (1 - x))
-     (R_dist (sum_f_R0 (fun n0:nat => x ^ n0) n) (/ (1 - x))) eps).
-apply Rabs_pos_lt.
-apply Rminus_eq_contra.
-apply Rlt_dichotomy_converse.
-right; unfold Rgt in |- *.
-apply (Rle_lt_trans x (Rabs x) 1).
-apply RRle_abs.
-assumption.
-unfold R_dist in |- *; rewrite <- Rabs_mult.
-rewrite Rmult_minus_distr_l.
-cut
- ((1 - x) * sum_f_R0 (fun n0:nat => x ^ n0) n =
-  - (sum_f_R0 (fun n0:nat => x ^ n0) n * (x - 1))).
-intro; rewrite H6.
-rewrite GP_finite.
-rewrite Rinv_r.
-cut (- (x ^ (n + 1) - 1) - 1 = - x ^ (n + 1)).
-intro; rewrite H7.
-rewrite Rabs_Ropp; cut ((n + 1)%nat = S n); auto.
-intro H8; rewrite H8; simpl in |- *; rewrite Rabs_mult;
- apply
-  (Rlt_le_trans (Rabs x * Rabs (x ^ n))
-     (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x)))) (
-     Rabs (1 - x) * eps)).
-apply Rmult_lt_compat_l.
-apply Rabs_pos_lt.
-assumption.
-auto.
-cut
- (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x))) =
-  Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))).
-clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r.  
-rewrite Rabs_R1; cut (1 * (eps * Rabs (1 - x)) = Rabs (1 - x) * eps).
-intros; rewrite H9; unfold Rle in |- *; right; reflexivity.
-ring.
-assumption.
-ring.
-ring.
-ring.
-apply Rminus_eq_contra.
-apply Rlt_dichotomy_converse.
-right; unfold Rgt in |- *.
-apply (Rle_lt_trans x (Rabs x) 1).
-apply RRle_abs.
-assumption.
-ring; ring.
-elim n; simpl in |- *.
-ring.
-intros; rewrite H5.
-ring.
-apply Rmult_lt_0_compat.
-auto.
-apply Rmult_lt_0_compat.
-apply Rabs_pos_lt.
-apply Rminus_eq_contra.
-apply Rlt_dichotomy_converse.
-right; unfold Rgt in |- *.
-apply (Rle_lt_trans x (Rabs x) 1).
-apply RRle_abs.
-assumption.
-apply Rabs_pos_lt.
-apply Rinv_neq_0_compat.
-assumption.
+  forall x:R, Rabs x < 1 -> Pser (fun n:nat => 1) x (/ (1 - x)).
+Proof.
+  intros; unfold Pser in |- *; unfold infinit_sum in |- *; intros;
+    elim (Req_dec x 0).
+  intros; exists 0%nat; intros; rewrite H1; rewrite Rminus_0_r; rewrite Rinv_1;
+    cut (sum_f_R0 (fun n0:nat => 1 * 0 ^ n0) n = 1).
+  intros; rewrite H3; rewrite R_dist_eq; auto.
+  elim n; simpl in |- *.
+  ring.
+  intros; rewrite H3; ring.
+  intro; cut (0 < eps * (Rabs (1 - x) * Rabs (/ x))).
+  intro; elim (pow_lt_1_zero x H (eps * (Rabs (1 - x) * Rabs (/ x))) H2);
+    intro N; intros; exists N; intros;
+      cut
+        (sum_f_R0 (fun n0:nat => 1 * x ^ n0) n = sum_f_R0 (fun n0:nat => x ^ n0) n).
+  intros; rewrite H5;
+    apply
+      (Rmult_lt_reg_l (Rabs (1 - x))
+        (R_dist (sum_f_R0 (fun n0:nat => x ^ n0) n) (/ (1 - x))) eps).
+  apply Rabs_pos_lt.
+  apply Rminus_eq_contra.
+  apply Rlt_dichotomy_converse.
+  right; unfold Rgt in |- *.
+  apply (Rle_lt_trans x (Rabs x) 1).
+  apply RRle_abs.
+  assumption.
+  unfold R_dist in |- *; rewrite <- Rabs_mult.
+  rewrite Rmult_minus_distr_l.
+  cut
+    ((1 - x) * sum_f_R0 (fun n0:nat => x ^ n0) n =
+      - (sum_f_R0 (fun n0:nat => x ^ n0) n * (x - 1))).
+  intro; rewrite H6.
+  rewrite GP_finite.
+  rewrite Rinv_r.
+  cut (- (x ^ (n + 1) - 1) - 1 = - x ^ (n + 1)).
+  intro; rewrite H7.
+  rewrite Rabs_Ropp; cut ((n + 1)%nat = S n); auto.
+  intro H8; rewrite H8; simpl in |- *; rewrite Rabs_mult;
+    apply
+      (Rlt_le_trans (Rabs x * Rabs (x ^ n))
+        (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x)))) (
+          Rabs (1 - x) * eps)).
+  apply Rmult_lt_compat_l.
+  apply Rabs_pos_lt.
+  assumption.
+  auto.
+  cut
+    (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x))) =
+      Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))).
+  clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r.  
+  rewrite Rabs_R1; cut (1 * (eps * Rabs (1 - x)) = Rabs (1 - x) * eps).
+  intros; rewrite H9; unfold Rle in |- *; right; reflexivity.
+  ring.
+  assumption.
+  ring.
+  ring.
+  ring.
+  apply Rminus_eq_contra.
+  apply Rlt_dichotomy_converse.
+  right; unfold Rgt in |- *.
+  apply (Rle_lt_trans x (Rabs x) 1).
+  apply RRle_abs.
+  assumption.
+  ring; ring.
+  elim n; simpl in |- *.
+  ring.
+  intros; rewrite H5.
+  ring.
+  apply Rmult_lt_0_compat.
+  auto.
+  apply Rmult_lt_0_compat.
+  apply Rabs_pos_lt.
+  apply Rminus_eq_contra.
+  apply Rlt_dichotomy_converse.
+  right; unfold Rgt in |- *.
+  apply (Rle_lt_trans x (Rabs x) 1).
+  apply RRle_abs.
+  assumption.
+  apply Rabs_pos_lt.
+  apply Rinv_neq_0_compat.
+  assumption.
 Qed.
diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v
index e54c3675..cb31d3b2 100644
--- a/theories/Reals/Rsigma.v
+++ b/theories/Reals/Rsigma.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rsigma.v,v 1.12.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+(*i $Id: Rsigma.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -18,123 +18,117 @@ Set Implicit Arguments.
 
 Section Sigma.
 
-Variable f : nat -> R.
+  Variable f : nat -> R.
 
-Definition sigma (low high:nat) : R :=
-  sum_f_R0 (fun k:nat => f (low + k)) (high - low).
+  Definition sigma (low high:nat) : R :=
+    sum_f_R0 (fun k:nat => f (low + k)) (high - low).
 
-Theorem sigma_split :
- forall low high k:nat,
-   (low <= k)%nat ->
-   (k < high)%nat -> sigma low high = sigma low k + sigma (S k) high.
-intros; induction  k as [| k Hreck].
-cut (low = 0%nat).
-intro; rewrite H1; unfold sigma in |- *; rewrite <- minus_n_n;
- rewrite <- minus_n_O; simpl in |- *; replace (high - 1)%nat with (pred high).
-apply (decomp_sum (fun k:nat => f k)).
-assumption.
-apply pred_of_minus.
-inversion H; reflexivity.
-cut ((low <= k)%nat \/ low = S k).
-intro; elim H1; intro.
-replace (sigma low (S k)) with (sigma low k + f (S k)).
-rewrite Rplus_assoc;
- replace (f (S k) + sigma (S (S k)) high) with (sigma (S k) high).
-apply Hreck.
-assumption.
-apply lt_trans with (S k); [ apply lt_n_Sn | assumption ].
-unfold sigma in |- *; replace (high - S (S k))%nat with (pred (high - S k)).
-pattern (S k) at 3 in |- *; replace (S k) with (S k + 0)%nat;
- [ idtac | ring ].
-replace (sum_f_R0 (fun k0:nat => f (S (S k) + k0)) (pred (high - S k))) with
- (sum_f_R0 (fun k0:nat => f (S k + S k0)) (pred (high - S k))).
-apply (decomp_sum (fun i:nat => f (S k + i))).
-apply lt_minus_O_lt; assumption.
-apply sum_eq; intros; replace (S k + S i)%nat with (S (S k) + i)%nat.
-reflexivity.
-apply INR_eq; do 2 rewrite plus_INR; do 3 rewrite S_INR; ring.
-replace (high - S (S k))%nat with (high - S k - 1)%nat.
-apply pred_of_minus.
-apply INR_eq; repeat rewrite minus_INR.
-do 4 rewrite S_INR; ring.
-apply lt_le_S; assumption.
-apply lt_le_weak; assumption.
-apply lt_le_S; apply lt_minus_O_lt; assumption.
-unfold sigma in |- *; replace (S k - low)%nat with (S (k - low)).
-pattern (S k) at 1 in |- *; replace (S k) with (low + S (k - low))%nat.
-symmetry  in |- *; apply (tech5 (fun i:nat => f (low + i))).
-apply INR_eq; rewrite plus_INR; do 2 rewrite S_INR; rewrite minus_INR.
-ring.
-assumption.
-apply minus_Sn_m; assumption.
-rewrite <- H2; unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
- replace (high - S low)%nat with (pred (high - low)).
-replace (sum_f_R0 (fun k0:nat => f (S (low + k0))) (pred (high - low))) with
- (sum_f_R0 (fun k0:nat => f (low + S k0)) (pred (high - low))).
-apply (decomp_sum (fun k0:nat => f (low + k0))).
-apply lt_minus_O_lt.
-apply le_lt_trans with (S k); [ rewrite H2; apply le_n | assumption ].
-apply sum_eq; intros; replace (S (low + i)) with (low + S i)%nat.
-reflexivity.
-apply INR_eq; rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR; ring.
-replace (high - S low)%nat with (high - low - 1)%nat.
-apply pred_of_minus.
-apply INR_eq; repeat rewrite minus_INR.
-do 2 rewrite S_INR; ring.
-apply lt_le_S; rewrite H2; assumption.
-rewrite H2; apply lt_le_weak; assumption.
-apply lt_le_S; apply lt_minus_O_lt; rewrite H2; assumption.
-inversion H; [ right; reflexivity | left; assumption ].
-Qed.
+  Theorem sigma_split :
+    forall low high k:nat,
+      (low <= k)%nat ->
+      (k < high)%nat -> sigma low high = sigma low k + sigma (S k) high.
+  Proof.
+    intros; induction  k as [| k Hreck].
+    cut (low = 0%nat).
+    intro; rewrite H1; unfold sigma in |- *; rewrite <- minus_n_n;
+      rewrite <- minus_n_O; simpl in |- *; replace (high - 1)%nat with (pred high).
+    apply (decomp_sum (fun k:nat => f k)).
+    assumption.
+    apply pred_of_minus.
+    inversion H; reflexivity.
+    cut ((low <= k)%nat \/ low = S k).
+    intro; elim H1; intro.
+    replace (sigma low (S k)) with (sigma low k + f (S k)).
+    rewrite Rplus_assoc;
+      replace (f (S k) + sigma (S (S k)) high) with (sigma (S k) high).
+    apply Hreck.
+    assumption.
+    apply lt_trans with (S k); [ apply lt_n_Sn | assumption ].
+    unfold sigma in |- *; replace (high - S (S k))%nat with (pred (high - S k)).
+    pattern (S k) at 3 in |- *; replace (S k) with (S k + 0)%nat;
+      [ idtac | ring ].
+    replace (sum_f_R0 (fun k0:nat => f (S (S k) + k0)) (pred (high - S k))) with
+    (sum_f_R0 (fun k0:nat => f (S k + S k0)) (pred (high - S k))).
+    apply (decomp_sum (fun i:nat => f (S k + i))).
+    apply lt_minus_O_lt; assumption.
+    apply sum_eq; intros; replace (S k + S i)%nat with (S (S k) + i)%nat.
+    reflexivity.
+    ring.
+    replace (high - S (S k))%nat with (high - S k - 1)%nat.
+    apply pred_of_minus.
+    omega.
+    unfold sigma in |- *; replace (S k - low)%nat with (S (k - low)).
+    pattern (S k) at 1 in |- *; replace (S k) with (low + S (k - low))%nat.
+    symmetry  in |- *; apply (tech5 (fun i:nat => f (low + i))).
+    omega.
+    omega.
+    rewrite <- H2; unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
+      replace (high - S low)%nat with (pred (high - low)).
+    replace (sum_f_R0 (fun k0:nat => f (S (low + k0))) (pred (high - low))) with
+    (sum_f_R0 (fun k0:nat => f (low + S k0)) (pred (high - low))).
+    apply (decomp_sum (fun k0:nat => f (low + k0))).
+    apply lt_minus_O_lt.
+    apply le_lt_trans with (S k); [ rewrite H2; apply le_n | assumption ].
+    apply sum_eq; intros; replace (S (low + i)) with (low + S i)%nat.
+    reflexivity.
+    ring.
+    omega.
+    inversion H; [ right; reflexivity | left; assumption ].
+  Qed.
 
-Theorem sigma_diff :
- forall low high k:nat,
-   (low <= k)%nat ->
-   (k < high)%nat -> sigma low high - sigma low k = sigma (S k) high.
-intros low high k H1 H2; symmetry  in |- *; rewrite (sigma_split H1 H2); ring.
-Qed.
+  Theorem sigma_diff :
+    forall low high k:nat,
+      (low <= k)%nat ->
+      (k < high)%nat -> sigma low high - sigma low k = sigma (S k) high.
+  Proof.
+    intros low high k H1 H2; symmetry  in |- *; rewrite (sigma_split H1 H2); ring.
+  Qed.
 
-Theorem sigma_diff_neg :
- forall low high k:nat,
-   (low <= k)%nat ->
-   (k < high)%nat -> sigma low k - sigma low high = - sigma (S k) high.
-intros low high k H1 H2; rewrite (sigma_split H1 H2); ring.
-Qed.
+  Theorem sigma_diff_neg :
+    forall low high k:nat,
+      (low <= k)%nat ->
+      (k < high)%nat -> sigma low k - sigma low high = - sigma (S k) high.
+  Proof.
+    intros low high k H1 H2; rewrite (sigma_split H1 H2); ring.
+  Qed.
 
-Theorem sigma_first :
- forall low high:nat,
-   (low < high)%nat -> sigma low high = f low + sigma (S low) high.
-intros low high H1; generalize (lt_le_S low high H1); intro H2;
- generalize (lt_le_weak low high H1); intro H3;
- replace (f low) with (sigma low low).
-apply sigma_split.
-apply le_n.
-assumption.
-unfold sigma in |- *; rewrite <- minus_n_n.
-simpl in |- *.
-replace (low + 0)%nat with low; [ reflexivity | ring ].
-Qed.
+  Theorem sigma_first :
+    forall low high:nat,
+      (low < high)%nat -> sigma low high = f low + sigma (S low) high.
+  Proof.
+    intros low high H1; generalize (lt_le_S low high H1); intro H2;
+      generalize (lt_le_weak low high H1); intro H3;
+        replace (f low) with (sigma low low).
+    apply sigma_split.
+    apply le_n.
+    assumption.
+    unfold sigma in |- *; rewrite <- minus_n_n.
+    simpl in |- *.
+    replace (low + 0)%nat with low; [ reflexivity | ring ].
+  Qed.
 
-Theorem sigma_last :
- forall low high:nat,
-   (low < high)%nat -> sigma low high = f high + sigma low (pred high).
-intros low high H1; generalize (lt_le_S low high H1); intro H2;
- generalize (lt_le_weak low high H1); intro H3;
- replace (f high) with (sigma high high).
-rewrite Rplus_comm; cut (high = S (pred high)).
-intro; pattern high at 3 in |- *; rewrite H.
-apply sigma_split.
-apply le_S_n; rewrite <- H; apply lt_le_S; assumption.
-apply lt_pred_n_n; apply le_lt_trans with low; [ apply le_O_n | assumption ].
-apply S_pred with 0%nat; apply le_lt_trans with low;
- [ apply le_O_n | assumption ].
-unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
- replace (high + 0)%nat with high; [ reflexivity | ring ].
-Qed.
+  Theorem sigma_last :
+    forall low high:nat,
+      (low < high)%nat -> sigma low high = f high + sigma low (pred high).
+  Proof.
+    intros low high H1; generalize (lt_le_S low high H1); intro H2;
+      generalize (lt_le_weak low high H1); intro H3;
+        replace (f high) with (sigma high high).
+    rewrite Rplus_comm; cut (high = S (pred high)).
+    intro; pattern high at 3 in |- *; rewrite H.
+    apply sigma_split.
+    apply le_S_n; rewrite <- H; apply lt_le_S; assumption.
+    apply lt_pred_n_n; apply le_lt_trans with low; [ apply le_O_n | assumption ].
+    apply S_pred with 0%nat; apply le_lt_trans with low;
+      [ apply le_O_n | assumption ].
+    unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
+      replace (high + 0)%nat with high; [ reflexivity | ring ].
+  Qed.
 
-Theorem sigma_eq_arg : forall low:nat, sigma low low = f low.
-intro; unfold sigma in |- *; rewrite <- minus_n_n.
-simpl in |- *; replace (low + 0)%nat with low; [ reflexivity | ring ].
-Qed.
+  Theorem sigma_eq_arg : forall low:nat, sigma low low = f low.
+  Proof.
+    intro; unfold sigma in |- *; rewrite <- minus_n_n.
+    simpl in |- *; replace (low + 0)%nat with low; [ reflexivity | ring ].
+  Qed.
 
-End Sigma.
\ No newline at end of file
+End Sigma.
diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v
index 459f2716..0a9f7754 100644
--- a/theories/Reals/Rsqrt_def.v
+++ b/theories/Reals/Rsqrt_def.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Rsqrt_def.v,v 1.14.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+(*i $Id: Rsqrt_def.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Sumbool.
 Require Import Rbase.
@@ -15,748 +15,771 @@ Require Import SeqSeries.
 Require Import Ranalysis1.
 Open Local Scope R_scope.
 
-Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
+Boxed Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
   match N with
-  | O => x
-  | S n =>
+    | O => x
+    | S n =>
       let down := Dichotomy_lb x y P n in
-      let up := Dichotomy_ub x y P n in
-      let z := (down + up) / 2 in if P z then down else z
+        let up := Dichotomy_ub x y P n in
+          let z := (down + up) / 2 in if P z then down else z
   end
- 
- with Dichotomy_ub (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
-  match N with
-  | O => y
-  | S n =>
-      let down := Dichotomy_lb x y P n in
-      let up := Dichotomy_ub x y P n in
-      let z := (down + up) / 2 in if P z then z else up
-  end.
+  
+  with Dichotomy_ub (x y:R) (P:R -> bool) (N:nat) {struct N} : R :=
+    match N with
+      | O => y
+      | S n =>
+        let down := Dichotomy_lb x y P n in
+          let up := Dichotomy_ub x y P n in
+            let z := (down + up) / 2 in if P z then z else up
+    end.
 
 Definition dicho_lb (x y:R) (P:R -> bool) (N:nat) : R := Dichotomy_lb x y P N.
 Definition dicho_up (x y:R) (P:R -> bool) (N:nat) : R := Dichotomy_ub x y P N.
 
 (**********)
 Lemma dicho_comp :
- forall (x y:R) (P:R -> bool) (n:nat),
-   x <= y -> dicho_lb x y P n <= dicho_up x y P n.
-intros.
-induction  n as [| n Hrecn].
-simpl in |- *; assumption.
-simpl in |- *.
-case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
-unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
-prove_sup0.
-pattern 2 at 1 in |- *; rewrite Rmult_comm.
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
-rewrite Rmult_1_r.
-rewrite double.
-apply Rplus_le_compat_l.
-assumption.
-unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
-prove_sup0.
-pattern 2 at 3 in |- *; rewrite Rmult_comm.
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
-rewrite Rmult_1_r.
-rewrite double.
-rewrite <- (Rplus_comm (Dichotomy_ub x y P n)).
-apply Rplus_le_compat_l.
-assumption.
+  forall (x y:R) (P:R -> bool) (n:nat),
+    x <= y -> dicho_lb x y P n <= dicho_up x y P n.
+Proof.
+  intros.
+  induction  n as [| n Hrecn].
+  simpl in |- *; assumption.
+  simpl in |- *.
+  case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  prove_sup0.
+  pattern 2 at 1 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+  rewrite Rmult_1_r.
+  rewrite double.
+  apply Rplus_le_compat_l.
+  assumption.
+  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  prove_sup0.
+  pattern 2 at 3 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+  rewrite Rmult_1_r.
+  rewrite double.
+  rewrite <- (Rplus_comm (Dichotomy_ub x y P n)).
+  apply Rplus_le_compat_l.
+  assumption.
 Qed.
 
 Lemma dicho_lb_growing :
- forall (x y:R) (P:R -> bool), x <= y -> Un_growing (dicho_lb x y P).
-intros.
-unfold Un_growing in |- *.
-intro.
-simpl in |- *.
-case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
-right; reflexivity.
-unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
-prove_sup0.
-pattern 2 at 1 in |- *; rewrite Rmult_comm.
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
-rewrite Rmult_1_r.
-rewrite double.
-apply Rplus_le_compat_l.
-replace (Dichotomy_ub x y P n) with (dicho_up x y P n);
- [ apply dicho_comp; assumption | reflexivity ].
+  forall (x y:R) (P:R -> bool), x <= y -> Un_growing (dicho_lb x y P).
+Proof.
+  intros.
+  unfold Un_growing in |- *.
+  intro.
+  simpl in |- *.
+  case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+  right; reflexivity.
+  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  prove_sup0.
+  pattern 2 at 1 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+  rewrite Rmult_1_r.
+  rewrite double.
+  apply Rplus_le_compat_l.
+  replace (Dichotomy_ub x y P n) with (dicho_up x y P n);
+  [ apply dicho_comp; assumption | reflexivity ].
 Qed.
 
 Lemma dicho_up_decreasing :
- forall (x y:R) (P:R -> bool), x <= y -> Un_decreasing (dicho_up x y P).
-intros.
-unfold Un_decreasing in |- *.
-intro.
-simpl in |- *.
-case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
-unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
-prove_sup0.
-pattern 2 at 3 in |- *; rewrite Rmult_comm.
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
-rewrite Rmult_1_r.
-rewrite double.
-replace (Dichotomy_ub x y P n) with (dicho_up x y P n);
- [ idtac | reflexivity ].
-replace (Dichotomy_lb x y P n) with (dicho_lb x y P n);
- [ idtac | reflexivity ].
-rewrite <- (Rplus_comm (dicho_up x y P n)).
-apply Rplus_le_compat_l.
-apply dicho_comp; assumption.
-right; reflexivity.
+  forall (x y:R) (P:R -> bool), x <= y -> Un_decreasing (dicho_up x y P).
+Proof.
+  intros.
+  unfold Un_decreasing in |- *.
+  intro.
+  simpl in |- *.
+  case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  prove_sup0.
+  pattern 2 at 3 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
+  rewrite Rmult_1_r.
+  rewrite double.
+  replace (Dichotomy_ub x y P n) with (dicho_up x y P n);
+  [ idtac | reflexivity ].
+  replace (Dichotomy_lb x y P n) with (dicho_lb x y P n);
+  [ idtac | reflexivity ].
+  rewrite <- (Rplus_comm (dicho_up x y P n)).
+  apply Rplus_le_compat_l.
+  apply dicho_comp; assumption.
+  right; reflexivity.
 Qed.
 
 Lemma dicho_lb_maj_y :
- forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, dicho_lb x y P n <= y.
-intros.
-induction  n as [| n Hrecn].
-simpl in |- *; assumption.
-simpl in |- *.
-case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
-assumption.
-unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
-prove_sup0.
-pattern 2 at 3 in |- *; rewrite Rmult_comm.
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
-rewrite double; apply Rplus_le_compat.
-assumption.
-pattern y at 2 in |- *; replace y with (Dichotomy_ub x y P 0);
- [ idtac | reflexivity ].
-apply decreasing_prop.
-assert (H0 := dicho_up_decreasing x y P H).
-assumption.
-apply le_O_n.
+  forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, dicho_lb x y P n <= y.
+Proof.
+  intros.
+  induction  n as [| n Hrecn].
+  simpl in |- *; assumption.
+  simpl in |- *.
+  case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+  assumption.
+  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  prove_sup0.
+  pattern 2 at 3 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
+  rewrite double; apply Rplus_le_compat.
+  assumption.
+  pattern y at 2 in |- *; replace y with (Dichotomy_ub x y P 0);
+    [ idtac | reflexivity ].
+  apply decreasing_prop.
+  assert (H0 := dicho_up_decreasing x y P H).
+  assumption.
+  apply le_O_n.
 Qed.
 
 Lemma dicho_lb_maj :
- forall (x y:R) (P:R -> bool), x <= y -> has_ub (dicho_lb x y P).
-intros.
-cut (forall n:nat, dicho_lb x y P n <= y).
-intro.
-unfold has_ub in |- *.
-unfold bound in |- *.
-exists y.
-unfold is_upper_bound in |- *.
-intros.
-elim H1; intros.
-rewrite H2; apply H0.
-apply dicho_lb_maj_y; assumption.
+  forall (x y:R) (P:R -> bool), x <= y -> has_ub (dicho_lb x y P).
+Proof.
+  intros.
+  cut (forall n:nat, dicho_lb x y P n <= y).
+  intro.
+  unfold has_ub in |- *.
+  unfold bound in |- *.
+  exists y.
+  unfold is_upper_bound in |- *.
+  intros.
+  elim H1; intros.
+  rewrite H2; apply H0.
+  apply dicho_lb_maj_y; assumption.
 Qed.
 
 Lemma dicho_up_min_x :
- forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, x <= dicho_up x y P n.
-intros.
-induction  n as [| n Hrecn].
-simpl in |- *; assumption.
-simpl in |- *.
-case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
-unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
-prove_sup0.
-pattern 2 at 1 in |- *; rewrite Rmult_comm.
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
-rewrite double; apply Rplus_le_compat.
-pattern x at 1 in |- *; replace x with (Dichotomy_lb x y P 0);
- [ idtac | reflexivity ].
-apply tech9.
-assert (H0 := dicho_lb_growing x y P H).
-assumption.
-apply le_O_n.
-assumption.
-assumption.
+  forall (x y:R) (P:R -> bool), x <= y -> forall n:nat, x <= dicho_up x y P n.
+Proof.
+  intros.
+  induction  n as [| n Hrecn].
+  simpl in |- *; assumption.
+  simpl in |- *.
+  case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  prove_sup0.
+  pattern 2 at 1 in |- *; rewrite Rmult_comm.
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
+  rewrite double; apply Rplus_le_compat.
+  pattern x at 1 in |- *; replace x with (Dichotomy_lb x y P 0);
+    [ idtac | reflexivity ].
+  apply tech9.
+  assert (H0 := dicho_lb_growing x y P H).
+  assumption.
+  apply le_O_n.
+  assumption.
+  assumption.
 Qed.
 
 Lemma dicho_up_min :
- forall (x y:R) (P:R -> bool), x <= y -> has_lb (dicho_up x y P).
-intros.
-cut (forall n:nat, x <= dicho_up x y P n).
-intro.
-unfold has_lb in |- *.
-unfold bound in |- *.
-exists (- x).
-unfold is_upper_bound in |- *.
-intros.
-elim H1; intros.
-rewrite H2.
-unfold opp_seq in |- *.
-apply Ropp_le_contravar.
-apply H0.
-apply dicho_up_min_x; assumption.
+  forall (x y:R) (P:R -> bool), x <= y -> has_lb (dicho_up x y P).
+Proof.
+  intros.
+  cut (forall n:nat, x <= dicho_up x y P n).
+  intro.
+  unfold has_lb in |- *.
+  unfold bound in |- *.
+  exists (- x).
+  unfold is_upper_bound in |- *.
+  intros.
+  elim H1; intros.
+  rewrite H2.
+  unfold opp_seq in |- *.
+  apply Ropp_le_contravar.
+  apply H0.
+  apply dicho_up_min_x; assumption.
 Qed.
 
 Lemma dicho_lb_cv :
- forall (x y:R) (P:R -> bool),
-   x <= y -> sigT (fun l:R => Un_cv (dicho_lb x y P) l).
-intros.
-apply growing_cv.
-apply dicho_lb_growing; assumption.
-apply dicho_lb_maj; assumption.
+  forall (x y:R) (P:R -> bool),
+    x <= y -> sigT (fun l:R => Un_cv (dicho_lb x y P) l).
+Proof.
+  intros.
+  apply growing_cv.
+  apply dicho_lb_growing; assumption.
+  apply dicho_lb_maj; assumption.
 Qed.
 
 Lemma dicho_up_cv :
- forall (x y:R) (P:R -> bool),
-   x <= y -> sigT (fun l:R => Un_cv (dicho_up x y P) l).
-intros.
-apply decreasing_cv.
-apply dicho_up_decreasing; assumption.
-apply dicho_up_min; assumption.
+  forall (x y:R) (P:R -> bool),
+    x <= y -> sigT (fun l:R => Un_cv (dicho_up x y P) l).
+Proof.
+  intros.
+  apply decreasing_cv.
+  apply dicho_up_decreasing; assumption.
+  apply dicho_up_min; assumption.
 Qed.
 
 Lemma dicho_lb_dicho_up :
- forall (x y:R) (P:R -> bool) (n:nat),
-   x <= y -> dicho_up x y P n - dicho_lb x y P n = (y - x) / 2 ^ n.
-intros.
-induction  n as [| n Hrecn].
-simpl in |- *.
-unfold Rdiv in |- *; rewrite Rinv_1; ring.
-simpl in |- *.
-case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
-unfold Rdiv in |- *.
-replace
- ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) * / 2 - Dichotomy_lb x y P n)
- with ((dicho_up x y P n - dicho_lb x y P n) / 2).
-unfold Rdiv in |- *; rewrite Hrecn.
-unfold Rdiv in |- *.
-rewrite Rinv_mult_distr.
-ring.
-discrR.
-apply pow_nonzero; discrR.
-pattern (Dichotomy_lb x y P n) at 2 in |- *;
- rewrite (double_var (Dichotomy_lb x y P n));
- unfold dicho_up, dicho_lb, Rminus, Rdiv in |- *; ring.
-replace
- (Dichotomy_ub x y P n - (Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)
- with ((dicho_up x y P n - dicho_lb x y P n) / 2).
-unfold Rdiv in |- *; rewrite Hrecn.
-unfold Rdiv in |- *.
-rewrite Rinv_mult_distr.
-ring.
-discrR.
-apply pow_nonzero; discrR.
-pattern (Dichotomy_ub x y P n) at 1 in |- *;
- rewrite (double_var (Dichotomy_ub x y P n));
- unfold dicho_up, dicho_lb, Rminus, Rdiv in |- *; ring.
+  forall (x y:R) (P:R -> bool) (n:nat),
+    x <= y -> dicho_up x y P n - dicho_lb x y P n = (y - x) / 2 ^ n.
+Proof.
+  intros.
+  induction  n as [| n Hrecn].
+  simpl in |- *.
+  unfold Rdiv in |- *; rewrite Rinv_1; ring.
+  simpl in |- *.
+  case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
+  unfold Rdiv in |- *.
+  replace
+  ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) * / 2 - Dichotomy_lb x y P n)
+    with ((dicho_up x y P n - dicho_lb x y P n) / 2).
+  unfold Rdiv in |- *; rewrite Hrecn.
+  unfold Rdiv in |- *.
+  rewrite Rinv_mult_distr.
+  ring.
+  discrR.
+  apply pow_nonzero; discrR.
+  pattern (Dichotomy_lb x y P n) at 2 in |- *;
+    rewrite (double_var (Dichotomy_lb x y P n));
+      unfold dicho_up, dicho_lb, Rminus, Rdiv in |- *; ring.
+  replace
+  (Dichotomy_ub x y P n - (Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)
+    with ((dicho_up x y P n - dicho_lb x y P n) / 2).
+  unfold Rdiv in |- *; rewrite Hrecn.
+  unfold Rdiv in |- *.
+  rewrite Rinv_mult_distr.
+  ring.
+  discrR.
+  apply pow_nonzero; discrR.
+  pattern (Dichotomy_ub x y P n) at 1 in |- *;
+    rewrite (double_var (Dichotomy_ub x y P n));
+      unfold dicho_up, dicho_lb, Rminus, Rdiv in |- *; ring.
 Qed.
 
 Definition pow_2_n (n:nat) := 2 ^ n.
 
 Lemma pow_2_n_neq_R0 : forall n:nat, pow_2_n n <> 0.
-intro.
-unfold pow_2_n in |- *.
-apply pow_nonzero.
-discrR.
+Proof.
+  intro.
+  unfold pow_2_n in |- *.
+  apply pow_nonzero.
+  discrR.
 Qed.
 
 Lemma pow_2_n_growing : Un_growing pow_2_n.
-unfold Un_growing in |- *.
-intro.
-replace (S n) with (n + 1)%nat;
- [ unfold pow_2_n in |- *; rewrite pow_add | ring ].
-pattern (2 ^ n) at 1 in |- *; rewrite <- Rmult_1_r.
-apply Rmult_le_compat_l.
-left; apply pow_lt; prove_sup0.
-simpl in |- *.
-rewrite Rmult_1_r.
-pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
- apply Rlt_0_1.
+Proof.
+  unfold Un_growing in |- *.
+  intro.
+  replace (S n) with (n + 1)%nat;
+  [ unfold pow_2_n in |- *; rewrite pow_add | ring ].
+  pattern (2 ^ n) at 1 in |- *; rewrite <- Rmult_1_r.
+  apply Rmult_le_compat_l.
+  left; apply pow_lt; prove_sup0.
+  simpl in |- *.
+  rewrite Rmult_1_r.
+  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+    apply Rlt_0_1.
 Qed.
 
 Lemma pow_2_n_infty : cv_infty pow_2_n.
-cut (forall N:nat, INR N <= 2 ^ N).
-intros.
-unfold cv_infty in |- *.
-intro.
-case (total_order_T 0 M); intro.
-elim s; intro.
-set (N := up M).
-cut (0 <= N)%Z.
-intro.
-elim (IZN N H0); intros N0 H1.
-exists N0.
-intros.
-apply Rlt_le_trans with (INR N0).
-rewrite INR_IZR_INZ.
-rewrite <- H1.
-unfold N in |- *.
-assert (H3 := archimed M).
-elim H3; intros; assumption.
-apply Rle_trans with (pow_2_n N0).
-unfold pow_2_n in |- *; apply H.
-apply Rge_le.
-apply growing_prop.
-apply pow_2_n_growing.
-assumption.
-apply le_IZR.
-unfold N in |- *.
-simpl in |- *.
-assert (H0 := archimed M); elim H0; intros.
-left; apply Rlt_trans with M; assumption.
-exists 0%nat; intros.
-rewrite <- b.
-unfold pow_2_n in |- *; apply pow_lt; prove_sup0.
-exists 0%nat; intros.
-apply Rlt_trans with 0.
-assumption.
-unfold pow_2_n in |- *; apply pow_lt; prove_sup0.
-simple induction N.
-simpl in |- *.
-left; apply Rlt_0_1.
-intros.
-pattern (S n) at 2 in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
-rewrite S_INR; rewrite pow_add.
-simpl in |- *.
-rewrite Rmult_1_r.
-apply Rle_trans with (2 ^ n).
-rewrite <- (Rplus_comm 1).
-rewrite <- (Rmult_1_r (INR n)).
-apply (poly n 1).
-apply Rlt_0_1.
-pattern (2 ^ n) at 1 in |- *; rewrite <- Rplus_0_r.
-rewrite <- (Rmult_comm 2).
-rewrite double.
-apply Rplus_le_compat_l.
-left; apply pow_lt; prove_sup0.
+Proof.
+  cut (forall N:nat, INR N <= 2 ^ N).
+  intros.
+  unfold cv_infty in |- *.
+  intro.
+  case (total_order_T 0 M); intro.
+  elim s; intro.
+  set (N := up M).
+  cut (0 <= N)%Z.
+  intro.
+  elim (IZN N H0); intros N0 H1.
+  exists N0.
+  intros.
+  apply Rlt_le_trans with (INR N0).
+  rewrite INR_IZR_INZ.
+  rewrite <- H1.
+  unfold N in |- *.
+  assert (H3 := archimed M).
+  elim H3; intros; assumption.
+  apply Rle_trans with (pow_2_n N0).
+  unfold pow_2_n in |- *; apply H.
+  apply Rge_le.
+  apply growing_prop.
+  apply pow_2_n_growing.
+  assumption.
+  apply le_IZR.
+  unfold N in |- *.
+  simpl in |- *.
+  assert (H0 := archimed M); elim H0; intros.
+  left; apply Rlt_trans with M; assumption.
+  exists 0%nat; intros.
+  rewrite <- b.
+  unfold pow_2_n in |- *; apply pow_lt; prove_sup0.
+  exists 0%nat; intros.
+  apply Rlt_trans with 0.
+  assumption.
+  unfold pow_2_n in |- *; apply pow_lt; prove_sup0.
+  simple induction N.
+  simpl in |- *.
+  left; apply Rlt_0_1.
+  intros.
+  pattern (S n) at 2 in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  rewrite S_INR; rewrite pow_add.
+  simpl in |- *.
+  rewrite Rmult_1_r.
+  apply Rle_trans with (2 ^ n).
+  rewrite <- (Rplus_comm 1).
+  rewrite <- (Rmult_1_r (INR n)).
+  apply (poly n 1).
+  apply Rlt_0_1.
+  pattern (2 ^ n) at 1 in |- *; rewrite <- Rplus_0_r.
+  rewrite <- (Rmult_comm 2).
+  rewrite double.
+  apply Rplus_le_compat_l.
+  left; apply pow_lt; prove_sup0.
 Qed.
 
 Lemma cv_dicho :
- forall (x y l1 l2:R) (P:R -> bool),
-   x <= y ->
-   Un_cv (dicho_lb x y P) l1 -> Un_cv (dicho_up x y P) l2 -> l1 = l2.
-intros.
-assert (H2 := CV_minus _ _ _ _ H0 H1).
-cut (Un_cv (fun i:nat => dicho_lb x y P i - dicho_up x y P i) 0).
-intro.
-assert (H4 := UL_sequence _ _ _ H2 H3).
-symmetry  in |- *; apply Rminus_diag_uniq_sym; assumption.
-unfold Un_cv in |- *; unfold R_dist in |- *.
-intros.
-assert (H4 := cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
-case (total_order_T x y); intro.
-elim s; intro.
-unfold Un_cv in H4; unfold R_dist in H4.
-cut (0 < y - x).
-intro Hyp.
-cut (0 < eps / (y - x)).
-intro.
-elim (H4 (eps / (y - x)) H5); intros N H6.
-exists N; intros.
-replace (dicho_lb x y P n - dicho_up x y P n - 0) with
- (dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ].
-rewrite <- Rabs_Ropp.
-rewrite Ropp_minus_distr'.
-rewrite dicho_lb_dicho_up.
-unfold Rdiv in |- *; rewrite Rabs_mult.
-rewrite (Rabs_right (y - x)).
-apply Rmult_lt_reg_l with (/ (y - x)).
-apply Rinv_0_lt_compat; assumption.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-replace (/ 2 ^ n) with (/ 2 ^ n - 0);
- [ unfold pow_2_n, Rdiv in H6; rewrite <- (Rmult_comm eps); apply H6;
+  forall (x y l1 l2:R) (P:R -> bool),
+    x <= y ->
+    Un_cv (dicho_lb x y P) l1 -> Un_cv (dicho_up x y P) l2 -> l1 = l2.
+Proof.
+  intros.
+  assert (H2 := CV_minus _ _ _ _ H0 H1).
+  cut (Un_cv (fun i:nat => dicho_lb x y P i - dicho_up x y P i) 0).
+  intro.
+  assert (H4 := UL_sequence _ _ _ H2 H3).
+  symmetry  in |- *; apply Rminus_diag_uniq_sym; assumption.
+  unfold Un_cv in |- *; unfold R_dist in |- *.
+  intros.
+  assert (H4 := cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
+  case (total_order_T x y); intro.
+  elim s; intro.
+  unfold Un_cv in H4; unfold R_dist in H4.
+  cut (0 < y - x).
+  intro Hyp.
+  cut (0 < eps / (y - x)).
+  intro.
+  elim (H4 (eps / (y - x)) H5); intros N H6.
+  exists N; intros.
+  replace (dicho_lb x y P n - dicho_up x y P n - 0) with
+  (dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ].
+  rewrite <- Rabs_Ropp.
+  rewrite Ropp_minus_distr'.
+  rewrite dicho_lb_dicho_up.
+  unfold Rdiv in |- *; rewrite Rabs_mult.
+  rewrite (Rabs_right (y - x)).
+  apply Rmult_lt_reg_l with (/ (y - x)).
+  apply Rinv_0_lt_compat; assumption.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  replace (/ 2 ^ n) with (/ 2 ^ n - 0);
+  [ unfold pow_2_n, Rdiv in H6; rewrite <- (Rmult_comm eps); apply H6;
     assumption
- | ring ].
-red in |- *; intro; rewrite H8 in Hyp; elim (Rlt_irrefl _ Hyp).
-apply Rle_ge.
-apply Rplus_le_reg_l with x; rewrite Rplus_0_r.
-replace (x + (y - x)) with y; [ assumption | ring ].
-assumption.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; assumption ].
-apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
-replace (x + (y - x)) with y; [ assumption | ring ].
-exists 0%nat; intros.
-replace (dicho_lb x y P n - dicho_up x y P n - 0) with
- (dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ].
-rewrite <- Rabs_Ropp.
-rewrite Ropp_minus_distr'.
-rewrite dicho_lb_dicho_up.
-rewrite b.
-unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; rewrite Rmult_0_l;
- rewrite Rabs_R0; assumption.
-assumption.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+    | ring ].
+  red in |- *; intro; rewrite H8 in Hyp; elim (Rlt_irrefl _ Hyp).
+  apply Rle_ge.
+  apply Rplus_le_reg_l with x; rewrite Rplus_0_r.
+  replace (x + (y - x)) with y; [ assumption | ring ].
+  assumption.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; assumption ].
+  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
+  replace (x + (y - x)) with y; [ assumption | ring ].
+  exists 0%nat; intros.
+  replace (dicho_lb x y P n - dicho_up x y P n - 0) with
+  (dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ].
+  rewrite <- Rabs_Ropp.
+  rewrite Ropp_minus_distr'.
+  rewrite dicho_lb_dicho_up.
+  rewrite b.
+  unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; rewrite Rmult_0_l;
+    rewrite Rabs_R0; assumption.
+  assumption.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
 Qed.
 
 Definition cond_positivity (x:R) : bool :=
   match Rle_dec 0 x with
-  | left _ => true
-  | right _ => false
+    | left _ => true
+    | right _ => false
   end.
 
-(* Sequential caracterisation of continuity *)
+(** Sequential caracterisation of continuity *)
 Lemma continuity_seq :
- forall (f:R -> R) (Un:nat -> R) (l:R),
-   continuity_pt f l -> Un_cv Un l -> Un_cv (fun i:nat => f (Un i)) (f l).
-unfold continuity_pt, Un_cv in |- *; unfold continue_in in |- *.
-unfold limit1_in in |- *.
-unfold limit_in in |- *.
-unfold dist in |- *.
-simpl in |- *.
-unfold R_dist in |- *.
-intros.
-elim (H eps H1); intros alp H2.
-elim H2; intros.
-elim (H0 alp H3); intros N H5.
-exists N; intros.
-case (Req_dec (Un n) l); intro.
-rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- assumption.
-apply H4.
-split.
-unfold D_x, no_cond in |- *.
-split.
-trivial.
-apply (sym_not_eq (A:=R)); assumption.
-apply H5; assumption.
+  forall (f:R -> R) (Un:nat -> R) (l:R),
+    continuity_pt f l -> Un_cv Un l -> Un_cv (fun i:nat => f (Un i)) (f l).
+Proof.
+  unfold continuity_pt, Un_cv in |- *; unfold continue_in in |- *.
+  unfold limit1_in in |- *.
+  unfold limit_in in |- *.
+  unfold dist in |- *.
+  simpl in |- *.
+  unfold R_dist in |- *.
+  intros.
+  elim (H eps H1); intros alp H2.
+  elim H2; intros.
+  elim (H0 alp H3); intros N H5.
+  exists N; intros.
+  case (Req_dec (Un n) l); intro.
+  rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    assumption.
+  apply H4.
+  split.
+  unfold D_x, no_cond in |- *.
+  split.
+  trivial.
+  apply (sym_not_eq (A:=R)); assumption.
+  apply H5; assumption.
 Qed.
 
 Lemma dicho_lb_car :
- forall (x y:R) (P:R -> bool) (n:nat),
-   P x = false -> P (dicho_lb x y P n) = false.
-intros.
-induction  n as [| n Hrecn].
-simpl in |- *.
-assumption.
-simpl in |- *.
-assert
- (X :=
-  sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
-elim X; intro.
-rewrite a.
-unfold dicho_lb in Hrecn; assumption.
-rewrite b.
-assumption.
+  forall (x y:R) (P:R -> bool) (n:nat),
+    P x = false -> P (dicho_lb x y P n) = false.
+Proof.
+  intros.
+  induction  n as [| n Hrecn].
+  simpl in |- *.
+  assumption.
+  simpl in |- *.
+  assert
+    (X :=
+      sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
+  elim X; intro.
+  rewrite a.
+  unfold dicho_lb in Hrecn; assumption.
+  rewrite b.
+  assumption.
 Qed.
 
 Lemma dicho_up_car :
- forall (x y:R) (P:R -> bool) (n:nat),
-   P y = true -> P (dicho_up x y P n) = true.
-intros.
-induction  n as [| n Hrecn].
-simpl in |- *.
-assumption.
-simpl in |- *.
-assert
- (X :=
-  sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
-elim X; intro.
-rewrite a.
-unfold dicho_lb in Hrecn; assumption.
-rewrite b.
-assumption.
+  forall (x y:R) (P:R -> bool) (n:nat),
+    P y = true -> P (dicho_up x y P n) = true.
+Proof.
+  intros.
+  induction  n as [| n Hrecn].
+  simpl in |- *.
+  assumption.
+  simpl in |- *.
+  assert
+    (X :=
+      sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
+  elim X; intro.
+  rewrite a.
+  unfold dicho_lb in Hrecn; assumption.
+  rewrite b.
+  assumption.
 Qed.
 
-(* Intermediate Value Theorem *)
+(** Intermediate Value Theorem *)
 Lemma IVT :
- forall (f:R -> R) (x y:R),
-   continuity f ->
-   x < y -> f x < 0 -> 0 < f y -> sigT (fun z:R => x <= z <= y /\ f z = 0).
-intros.
-cut (x <= y).
-intro.
-generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). 
-generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). 
-intros.
-elim X; intros.
-elim X0; intros.
-assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
-rewrite H4 in p0.
-apply existT with x0.
-split.
-split.
-apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0).
-simpl in |- *.
-right; reflexivity.
-apply growing_ineq.
-apply dicho_lb_growing; assumption.
-assumption.
-apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0).
-apply decreasing_ineq.
-apply dicho_up_decreasing; assumption.
-assumption.
-right; reflexivity.
-2: left; assumption.
-set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n).
-set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n).
-cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0).
-cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0).
-intros.
-cut (forall n:nat, f (Vn n) <= 0).
-cut (forall n:nat, 0 <= f (Wn n)).
-intros.
-assert (H9 := H6 H8).
-assert (H10 := H5 H7).
-apply Rle_antisym; assumption.
-intro.
-unfold Wn in |- *.
-cut (forall z:R, cond_positivity z = true <-> 0 <= z).
-intro.
-assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n).
-elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros.
-apply H9.
-apply H8.
-elim (H7 (f y)); intros.
-apply H12.
-left; assumption.
-intro.
-unfold cond_positivity in |- *.
-case (Rle_dec 0 z); intro.
-split.
-intro; assumption.
-intro; reflexivity.
-split.
-intro; elim diff_false_true; assumption.
-intro.
-elim n0; assumption.
-unfold Vn in |- *.
-cut (forall z:R, cond_positivity z = false <-> z < 0).
-intros.
-assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n).
-left.
-elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros.
-apply H9.
-apply H8.
-elim (H7 (f x)); intros.
-apply H12.
-assumption.
-intro.
-unfold cond_positivity in |- *.
-case (Rle_dec 0 z); intro.
-split.
-intro; elim diff_true_false; assumption.
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)).
-split.
-intro; auto with real.
-intro; reflexivity.
-cut (Un_cv Wn x0).
-intros.
-assert (H7 := continuity_seq f Wn x0 (H x0) H5).
-case (total_order_T 0 (f x0)); intro.
-elim s; intro.
-left; assumption.
-rewrite <- b; right; reflexivity.
-unfold Un_cv in H7; unfold R_dist in H7.
-cut (0 < - f x0).
-intro.
-elim (H7 (- f x0) H8); intros.
-cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
-assert (H11 := H9 x2 H10).
-rewrite Rabs_right in H11.
-pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
-unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
-assert (H12 := Rplus_lt_reg_r _ _ _ H11).
-assert (H13 := H6 x2).
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
-apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat.
-apply H6.
-exact H8.
-apply Ropp_0_gt_lt_contravar; assumption.
-unfold Wn in |- *; assumption.
-cut (Un_cv Vn x0).
-intros.
-assert (H7 := continuity_seq f Vn x0 (H x0) H5).
-case (total_order_T 0 (f x0)); intro.
-elim s; intro.
-unfold Un_cv in H7; unfold R_dist in H7.
-elim (H7 (f x0) a); intros.
-cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
-assert (H10 := H8 x2 H9).
-rewrite Rabs_left in H10.
-pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
-rewrite Ropp_minus_distr' in H10.
-unfold Rminus in H10.
-assert (H11 := Rplus_lt_reg_r _ _ _ H10).
-assert (H12 := H6 x2).
-cut (0 < f (Vn x2)).
-intro.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
-rewrite <- (Ropp_involutive (f (Vn x2))).
-apply Ropp_0_gt_lt_contravar; assumption.
-apply Rplus_lt_reg_r with (f x0 - f (Vn x2)).
-rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
- [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ].
-assumption.
-apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
-right; rewrite <- b; reflexivity.
-left; assumption.
-unfold Vn in |- *; assumption.
+  forall (f:R -> R) (x y:R),
+    continuity f ->
+    x < y -> f x < 0 -> 0 < f y -> sigT (fun z:R => x <= z <= y /\ f z = 0).
+Proof.
+  intros.
+  cut (x <= y).
+  intro.
+  generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). 
+  generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). 
+  intros X X0.
+  elim X; intros.
+  elim X0; intros.
+  assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
+  rewrite H4 in p0.
+  apply existT with x0.
+  split.
+  split.
+  apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0).
+  simpl in |- *.
+  right; reflexivity.
+  apply growing_ineq.
+  apply dicho_lb_growing; assumption.
+  assumption.
+  apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0).
+  apply decreasing_ineq.
+  apply dicho_up_decreasing; assumption.
+  assumption.
+  right; reflexivity.
+  2: left; assumption.
+  set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n).
+  set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n).
+  cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0).
+  cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0).
+  intros.
+  cut (forall n:nat, f (Vn n) <= 0).
+  cut (forall n:nat, 0 <= f (Wn n)).
+  intros.
+  assert (H9 := H6 H8).
+  assert (H10 := H5 H7).
+  apply Rle_antisym; assumption.
+  intro.
+  unfold Wn in |- *.
+  cut (forall z:R, cond_positivity z = true <-> 0 <= z).
+  intro.
+  assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n).
+  elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros.
+  apply H9.
+  apply H8.
+  elim (H7 (f y)); intros.
+  apply H12.
+  left; assumption.
+  intro.
+  unfold cond_positivity in |- *.
+  case (Rle_dec 0 z); intro.
+  split.
+  intro; assumption.
+  intro; reflexivity.
+  split.
+  intro feqt;discriminate feqt.
+  intro.
+  elim n0; assumption.
+  unfold Vn in |- *.
+  cut (forall z:R, cond_positivity z = false <-> z < 0).
+  intros.
+  assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n).
+  left.
+  elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros.
+  apply H9.
+  apply H8.
+  elim (H7 (f x)); intros.
+  apply H12.
+  assumption.
+  intro.
+  unfold cond_positivity in |- *.
+  case (Rle_dec 0 z); intro.
+  split.
+  intro feqt; discriminate feqt.
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)).
+  split.
+  intro; auto with real.
+  intro; reflexivity.
+  cut (Un_cv Wn x0).
+  intros.
+  assert (H7 := continuity_seq f Wn x0 (H x0) H5).
+  case (total_order_T 0 (f x0)); intro.
+  elim s; intro.
+  left; assumption.
+  rewrite <- b; right; reflexivity.
+  unfold Un_cv in H7; unfold R_dist in H7.
+  cut (0 < - f x0).
+  intro.
+  elim (H7 (- f x0) H8); intros.
+  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+  assert (H11 := H9 x2 H10).
+  rewrite Rabs_right in H11.
+  pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
+  unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
+  assert (H12 := Rplus_lt_reg_r _ _ _ H11).
+  assert (H13 := H6 x2).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
+  apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat.
+  apply H6.
+  exact H8.
+  apply Ropp_0_gt_lt_contravar; assumption.
+  unfold Wn in |- *; assumption.
+  cut (Un_cv Vn x0).
+  intros.
+  assert (H7 := continuity_seq f Vn x0 (H x0) H5).
+  case (total_order_T 0 (f x0)); intro.
+  elim s; intro.
+  unfold Un_cv in H7; unfold R_dist in H7.
+  elim (H7 (f x0) a); intros.
+  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+  assert (H10 := H8 x2 H9).
+  rewrite Rabs_left in H10.
+  pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
+  rewrite Ropp_minus_distr' in H10.
+  unfold Rminus in H10.
+  assert (H11 := Rplus_lt_reg_r _ _ _ H10).
+  assert (H12 := H6 x2).
+  cut (0 < f (Vn x2)).
+  intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
+  rewrite <- (Ropp_involutive (f (Vn x2))).
+  apply Ropp_0_gt_lt_contravar; assumption.
+  apply Rplus_lt_reg_r with (f x0 - f (Vn x2)).
+  rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
+    [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ].
+  assumption.
+  apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
+  right; rewrite <- b; reflexivity.
+  left; assumption.
+  unfold Vn in |- *; assumption.
 Qed.
 
 Lemma IVT_cor :
- forall (f:R -> R) (x y:R),
-   continuity f ->
-   x <= y -> f x * f y <= 0 -> sigT (fun z:R => x <= z <= y /\ f z = 0).
-intros.
-case (total_order_T 0 (f x)); intro.
-case (total_order_T 0 (f y)); intro.
-elim s; intro.
-elim s0; intro.
-cut (0 < f x * f y);
- [ intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 H2))
- | apply Rmult_lt_0_compat; assumption ].
-exists y.
-split.
-split; [ assumption | right; reflexivity ].
-symmetry  in |- *; exact b.
-exists x.
-split.
-split; [ right; reflexivity | assumption ].
-symmetry  in |- *; exact b.
-elim s; intro.
-cut (x < y).
-intro.
-assert (H3 := IVT (- f)%F x y (continuity_opp f H) H2).
-cut ((- f)%F x < 0).
-cut (0 < (- f)%F y).
-intros.
-elim (H3 H5 H4); intros.
-apply existT with x0.
-elim p; intros.
-split.
-assumption.
-unfold opp_fct in H7.
-rewrite <- (Ropp_involutive (f x0)).
-apply Ropp_eq_0_compat; assumption.
-unfold opp_fct in |- *; apply Ropp_0_gt_lt_contravar; assumption.
-unfold opp_fct in |- *.
-apply Rplus_lt_reg_r with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r;
- assumption.
-inversion H0.
-assumption.
-rewrite H2 in a.
-elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)).
-apply existT with x.
-split.
-split; [ right; reflexivity | assumption ].
-symmetry  in |- *; assumption.
-case (total_order_T 0 (f y)); intro.
-elim s; intro.
-cut (x < y).
-intro.
-apply IVT; assumption.
-inversion H0.
-assumption.
-rewrite H2 in r.
-elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)).
-apply existT with y.
-split.
-split; [ assumption | right; reflexivity ].
-symmetry  in |- *; assumption.
-cut (0 < f x * f y).
-intro.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H2 H1)).
-rewrite <- Rmult_opp_opp; apply Rmult_lt_0_compat;
- apply Ropp_0_gt_lt_contravar; assumption.
+  forall (f:R -> R) (x y:R),
+    continuity f ->
+    x <= y -> f x * f y <= 0 -> sigT (fun z:R => x <= z <= y /\ f z = 0).
+Proof.
+  intros.
+  case (total_order_T 0 (f x)); intro.
+  case (total_order_T 0 (f y)); intro.
+  elim s; intro.
+  elim s0; intro.
+  cut (0 < f x * f y);
+    [ intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 H2))
+      | apply Rmult_lt_0_compat; assumption ].
+  exists y.
+  split.
+  split; [ assumption | right; reflexivity ].
+  symmetry  in |- *; exact b.
+  exists x.
+  split.
+  split; [ right; reflexivity | assumption ].
+  symmetry  in |- *; exact b.
+  elim s; intro.
+  cut (x < y).
+  intro.
+  assert (H3 := IVT (- f)%F x y (continuity_opp f H) H2).
+  cut ((- f)%F x < 0).
+  cut (0 < (- f)%F y).
+  intros.
+  elim (H3 H5 H4); intros.
+  apply existT with x0.
+  elim p; intros.
+  split.
+  assumption.
+  unfold opp_fct in H7.
+  rewrite <- (Ropp_involutive (f x0)).
+  apply Ropp_eq_0_compat; assumption.
+  unfold opp_fct in |- *; apply Ropp_0_gt_lt_contravar; assumption.
+  unfold opp_fct in |- *.
+  apply Rplus_lt_reg_r with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r;
+    assumption.
+  inversion H0.
+  assumption.
+  rewrite H2 in a.
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)).
+  apply existT with x.
+  split.
+  split; [ right; reflexivity | assumption ].
+  symmetry  in |- *; assumption.
+  case (total_order_T 0 (f y)); intro.
+  elim s; intro.
+  cut (x < y).
+  intro.
+  apply IVT; assumption.
+  inversion H0.
+  assumption.
+  rewrite H2 in r.
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)).
+  apply existT with y.
+  split.
+  split; [ assumption | right; reflexivity ].
+  symmetry  in |- *; assumption.
+  cut (0 < f x * f y).
+  intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H2 H1)).
+  rewrite <- Rmult_opp_opp; apply Rmult_lt_0_compat;
+    apply Ropp_0_gt_lt_contravar; assumption.
 Qed.
 
-(* We can now define the square root function as the reciprocal transformation of the square root function *)
+(** We can now define the square root function as the reciprocal 
+   transformation of the square root function *)
 Lemma Rsqrt_exists :
- forall y:R, 0 <= y -> sigT (fun z:R => 0 <= z /\ y = Rsqr z).
-intros.
-set (f := fun x:R => Rsqr x - y).
-cut (f 0 <= 0).
-intro.
-cut (continuity f).
-intro.
-case (total_order_T y 1); intro.
-elim s; intro.
-cut (0 <= f 1).
-intro.
-cut (f 0 * f 1 <= 0).
-intro.
-assert (X := IVT_cor f 0 1 H1 (Rlt_le _ _ Rlt_0_1) H3).
-elim X; intros t H4.
-apply existT with t.
-elim H4; intros.
-split.
-elim H5; intros; assumption.
-unfold f in H6.
-apply Rminus_diag_uniq_sym; exact H6.
-rewrite Rmult_comm; pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f 1)).
-apply Rmult_le_compat_l; assumption.
-unfold f in |- *.
-rewrite Rsqr_1.
-apply Rplus_le_reg_l with y.
-rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
- rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
- left; assumption.
-apply existT with 1.
-split.
-left; apply Rlt_0_1.
-rewrite b; symmetry  in |- *; apply Rsqr_1.
-cut (0 <= f y).
-intro.
-cut (f 0 * f y <= 0).
-intro.
-assert (X := IVT_cor f 0 y H1 H H3).
-elim X; intros t H4.
-apply existT with t.
-elim H4; intros.
-split.
-elim H5; intros; assumption.
-unfold f in H6.
-apply Rminus_diag_uniq_sym; exact H6.
-rewrite Rmult_comm; pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y)).
-apply Rmult_le_compat_l; assumption.
-unfold f in |- *.
-apply Rplus_le_reg_l with y.
-rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
- rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
-pattern y at 1 in |- *; rewrite <- Rmult_1_r.
-unfold Rsqr in |- *; apply Rmult_le_compat_l.
-assumption.
-left; exact r.
-replace f with (Rsqr - fct_cte y)%F.
-apply continuity_minus.
-apply derivable_continuous; apply derivable_Rsqr.
-apply derivable_continuous; apply derivable_const.
-reflexivity.
-unfold f in |- *; rewrite Rsqr_0.
-unfold Rminus in |- *; rewrite Rplus_0_l.
-apply Rge_le.
-apply Ropp_0_le_ge_contravar; assumption.
+  forall y:R, 0 <= y -> sigT (fun z:R => 0 <= z /\ y = Rsqr z).
+Proof.
+  intros.
+  set (f := fun x:R => Rsqr x - y).
+  cut (f 0 <= 0).
+  intro.
+  cut (continuity f).
+  intro.
+  case (total_order_T y 1); intro.
+  elim s; intro.
+  cut (0 <= f 1).
+  intro.
+  cut (f 0 * f 1 <= 0).
+  intro.
+  assert (X := IVT_cor f 0 1 H1 (Rlt_le _ _ Rlt_0_1) H3).
+  elim X; intros t H4.
+  apply existT with t.
+  elim H4; intros.
+  split.
+  elim H5; intros; assumption.
+  unfold f in H6.
+  apply Rminus_diag_uniq_sym; exact H6.
+  rewrite Rmult_comm; pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f 1)).
+  apply Rmult_le_compat_l; assumption.
+  unfold f in |- *.
+  rewrite Rsqr_1.
+  apply Rplus_le_reg_l with y.
+  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+      left; assumption.
+  apply existT with 1.
+  split.
+  left; apply Rlt_0_1.
+  rewrite b; symmetry  in |- *; apply Rsqr_1.
+  cut (0 <= f y).
+  intro.
+  cut (f 0 * f y <= 0).
+  intro.
+  assert (X := IVT_cor f 0 y H1 H H3).
+  elim X; intros t H4.
+  apply existT with t.
+  elim H4; intros.
+  split.
+  elim H5; intros; assumption.
+  unfold f in H6.
+  apply Rminus_diag_uniq_sym; exact H6.
+  rewrite Rmult_comm; pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y)).
+  apply Rmult_le_compat_l; assumption.
+  unfold f in |- *.
+  apply Rplus_le_reg_l with y.
+  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
+  pattern y at 1 in |- *; rewrite <- Rmult_1_r.
+  unfold Rsqr in |- *; apply Rmult_le_compat_l.
+  assumption.
+  left; exact r.
+  replace f with (Rsqr - fct_cte y)%F.
+  apply continuity_minus.
+  apply derivable_continuous; apply derivable_Rsqr.
+  apply derivable_continuous; apply derivable_const.
+  reflexivity.
+  unfold f in |- *; rewrite Rsqr_0.
+  unfold Rminus in |- *; rewrite Rplus_0_l.
+  apply Rge_le.
+  apply Ropp_0_le_ge_contravar; assumption.
 Qed.
 
 (* Definition of the square root: R+->R *)
 Definition Rsqrt (y:nonnegreal) : R :=
   match Rsqrt_exists (nonneg y) (cond_nonneg y) with
-  | existT a b => a
+    | existT a b => a
   end.
 
 (**********)
 Lemma Rsqrt_positivity : forall x:nonnegreal, 0 <= Rsqrt x.
-intro.
-assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)).
-elim X; intros.
-cut (x0 = Rsqrt x).
-intros.
-elim p; intros.
-rewrite H in H0; assumption.
-unfold Rsqrt in |- *.
-case (Rsqrt_exists x (cond_nonneg x)).
-intros.
-elim p; elim a; intros.
-apply Rsqr_inj.
-assumption.
-assumption.
-rewrite <- H0; rewrite <- H2; reflexivity.
+Proof.
+  intro.
+  assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)).
+  elim X; intros.
+  cut (x0 = Rsqrt x).
+  intros.
+  elim p; intros.
+  rewrite H in H0; assumption.
+  unfold Rsqrt in |- *.
+  case (Rsqrt_exists x (cond_nonneg x)).
+  intros.
+  elim p; elim a; intros.
+  apply Rsqr_inj.
+  assumption.
+  assumption.
+  rewrite <- H0; rewrite <- H2; reflexivity.
 Qed.
 
 (**********)
 Lemma Rsqrt_Rsqrt : forall x:nonnegreal, Rsqrt x * Rsqrt x = x.
-intros.
-assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)).
-elim X; intros.
-cut (x0 = Rsqrt x).
-intros.
-rewrite <- H.
-elim p; intros.
-rewrite H1; reflexivity.
-unfold Rsqrt in |- *.
-case (Rsqrt_exists x (cond_nonneg x)).
-intros.
-elim p; elim a; intros.
-apply Rsqr_inj.
-assumption.
-assumption.
-rewrite <- H0; rewrite <- H2; reflexivity.
-Qed.
\ No newline at end of file
+Proof.
+  intros.
+  assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)).
+  elim X; intros.
+  cut (x0 = Rsqrt x).
+  intros.
+  rewrite <- H.
+  elim p; intros.
+  rewrite H1; reflexivity.
+  unfold Rsqrt in |- *.
+  case (Rsqrt_exists x (cond_nonneg x)).
+  intros.
+  elim p; elim a; intros.
+  apply Rsqr_inj.
+  assumption.
+  assumption.
+  rewrite <- H0; rewrite <- H2; reflexivity.
+Qed.
diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v
index 1c112bf1..aa47d72f 100644
--- a/theories/Reals/Rtopology.v
+++ b/theories/Reals/Rtopology.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Rtopology.v,v 1.19.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+(*i $Id: Rtopology.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -15,10 +15,13 @@ Require Import RList.
 Require Import Classical_Prop.
 Require Import Classical_Pred_Type. Open Local Scope R_scope.
 
+
+(** * General definitions and propositions *)
+
 Definition included (D1 D2:R -> Prop) : Prop := forall x:R, D1 x -> D2 x.
 Definition disc (x:R) (delta:posreal) (y:R) : Prop := Rabs (y - x) < delta.
 Definition neighbourhood (V:R -> Prop) (x:R) : Prop :=
-   exists delta : posreal, included (disc x delta) V.
+  exists delta : posreal, included (disc x delta) V.
 Definition open_set (D:R -> Prop) : Prop :=
   forall x:R, D x -> neighbourhood D x.
 Definition complementary (D:R -> Prop) (c:R) : Prop := ~ D c.
@@ -28,15 +31,17 @@ Definition union_domain (D1 D2:R -> Prop) (c:R) : Prop := D1 c \/ D2 c.
 Definition interior (D:R -> Prop) (x:R) : Prop := neighbourhood D x.
 
 Lemma interior_P1 : forall D:R -> Prop, included (interior D) D.
-intros; unfold included in |- *; unfold interior in |- *; intros;
- unfold neighbourhood in H; elim H; intros; unfold included in H0; 
- apply H0; unfold disc in |- *; unfold Rminus in |- *; 
- rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos x0).
+Proof.
+  intros; unfold included in |- *; unfold interior in |- *; intros;
+    unfold neighbourhood in H; elim H; intros; unfold included in H0; 
+      apply H0; unfold disc in |- *; unfold Rminus in |- *; 
+        rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos x0).
 Qed.
 
 Lemma interior_P2 : forall D:R -> Prop, open_set D -> included D (interior D).
-intros; unfold open_set in H; unfold included in |- *; intros;
- assert (H1 := H _ H0); unfold interior in |- *; apply H1.
+Proof.
+  intros; unfold open_set in H; unfold included in |- *; intros;
+    assert (H1 := H _ H0); unfold interior in |- *; apply H1.
 Qed.
 
 Definition point_adherent (D:R -> Prop) (x:R) : Prop :=
@@ -45,94 +50,100 @@ Definition point_adherent (D:R -> Prop) (x:R) : Prop :=
 Definition adherence (D:R -> Prop) (x:R) : Prop := point_adherent D x.
 
 Lemma adherence_P1 : forall D:R -> Prop, included D (adherence D).
-intro; unfold included in |- *; intros; unfold adherence in |- *;
- unfold point_adherent in |- *; intros; exists x;
- unfold intersection_domain in |- *; split.
-unfold neighbourhood in H0; elim H0; intros; unfold included in H1; apply H1;
- unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; apply (cond_pos x0).
-apply H.
+Proof.
+  intro; unfold included in |- *; intros; unfold adherence in |- *;
+    unfold point_adherent in |- *; intros; exists x;
+      unfold intersection_domain in |- *; split.
+  unfold neighbourhood in H0; elim H0; intros; unfold included in H1; apply H1;
+    unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+      rewrite Rabs_R0; apply (cond_pos x0).
+  apply H.
 Qed.
 
 Lemma included_trans :
- forall D1 D2 D3:R -> Prop,
-   included D1 D2 -> included D2 D3 -> included D1 D3.
-unfold included in |- *; intros; apply H0; apply H; apply H1.
+  forall D1 D2 D3:R -> Prop,
+    included D1 D2 -> included D2 D3 -> included D1 D3.
+Proof.
+  unfold included in |- *; intros; apply H0; apply H; apply H1.
 Qed.
 
 Lemma interior_P3 : forall D:R -> Prop, open_set (interior D).
-intro; unfold open_set, interior in |- *; unfold neighbourhood in |- *;
- intros; elim H; intros.
-exists x0; unfold included in |- *; intros.
-set (del := x0 - Rabs (x - x1)).
-cut (0 < del).
-intro; exists (mkposreal del H2); intros.
-cut (included (disc x1 (mkposreal del H2)) (disc x x0)).
-intro; assert (H5 := included_trans _ _ _ H4 H0).
-apply H5; apply H3.
-unfold included in |- *; unfold disc in |- *; intros.
-apply Rle_lt_trans with (Rabs (x3 - x1) + Rabs (x1 - x)).
-replace (x3 - x) with (x3 - x1 + (x1 - x)); [ apply Rabs_triang | ring ].
-replace (pos x0) with (del + Rabs (x1 - x)).
-do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l;
- apply H4.
-unfold del in |- *; rewrite <- (Rabs_Ropp (x - x1)); rewrite Ropp_minus_distr;
- ring.
-unfold del in |- *; apply Rplus_lt_reg_r with (Rabs (x - x1));
- rewrite Rplus_0_r;
- replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
- [ idtac | ring ].
-unfold disc in H1; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1.
+Proof.
+  intro; unfold open_set, interior in |- *; unfold neighbourhood in |- *;
+    intros; elim H; intros.
+  exists x0; unfold included in |- *; intros.
+  set (del := x0 - Rabs (x - x1)).
+  cut (0 < del).
+  intro; exists (mkposreal del H2); intros.
+  cut (included (disc x1 (mkposreal del H2)) (disc x x0)).
+  intro; assert (H5 := included_trans _ _ _ H4 H0).
+  apply H5; apply H3.
+  unfold included in |- *; unfold disc in |- *; intros.
+  apply Rle_lt_trans with (Rabs (x3 - x1) + Rabs (x1 - x)).
+  replace (x3 - x) with (x3 - x1 + (x1 - x)); [ apply Rabs_triang | ring ].
+  replace (pos x0) with (del + Rabs (x1 - x)).
+  do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l;
+    apply H4.
+  unfold del in |- *; rewrite <- (Rabs_Ropp (x - x1)); rewrite Ropp_minus_distr;
+    ring.
+  unfold del in |- *; apply Rplus_lt_reg_r with (Rabs (x - x1));
+    rewrite Rplus_0_r;
+      replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
+      [ idtac | ring ].
+  unfold disc in H1; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1.
 Qed.
 
 Lemma complementary_P1 :
- forall D:R -> Prop,
-   ~ (exists y : R, intersection_domain D (complementary D) y).
-intro; red in |- *; intro; elim H; intros;
- unfold intersection_domain, complementary in H0; elim H0; 
- intros; elim H2; assumption.
+  forall D:R -> Prop,
+    ~ (exists y : R, intersection_domain D (complementary D) y).
+Proof.
+  intro; red in |- *; intro; elim H; intros;
+    unfold intersection_domain, complementary in H0; elim H0; 
+      intros; elim H2; assumption.
 Qed.
 
 Lemma adherence_P2 :
- forall D:R -> Prop, closed_set D -> included (adherence D) D.
-unfold closed_set in |- *; unfold open_set, complementary in |- *; intros;
- unfold included, adherence in |- *; intros; assert (H1 := classic (D x));
- elim H1; intro.
-assumption.
-assert (H3 := H _ H2); assert (H4 := H0 _ H3); elim H4; intros;
- unfold intersection_domain in H5; elim H5; intros; 
- elim H6; assumption.
+  forall D:R -> Prop, closed_set D -> included (adherence D) D.
+Proof.
+  unfold closed_set in |- *; unfold open_set, complementary in |- *; intros;
+    unfold included, adherence in |- *; intros; assert (H1 := classic (D x));
+      elim H1; intro.
+  assumption.
+  assert (H3 := H _ H2); assert (H4 := H0 _ H3); elim H4; intros;
+    unfold intersection_domain in H5; elim H5; intros; 
+      elim H6; assumption.
 Qed.
 
 Lemma adherence_P3 : forall D:R -> Prop, closed_set (adherence D).
-intro; unfold closed_set, adherence in |- *;
- unfold open_set, complementary, point_adherent in |- *; 
- intros;
- set
-  (P :=
-   fun V:R -> Prop =>
-     neighbourhood V x ->  exists y : R, intersection_domain V D y);
- assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; 
- unfold P in H1; assert (H2 := imply_to_and _ _ H1);
- unfold neighbourhood in |- *; elim H2; intros; unfold neighbourhood in H3;
- elim H3; intros; exists x0; unfold included in |- *; 
- intros; red in |- *; intro.
-assert (H8 := H7 V0);
- cut (exists delta : posreal, (forall x:R, disc x1 delta x -> V0 x)).
-intro; assert (H10 := H8 H9); elim H4; assumption.
-cut (0 < x0 - Rabs (x - x1)).
-intro; set (del := mkposreal _ H9); exists del; intros;
- unfold included in H5; apply H5; unfold disc in |- *;
- apply Rle_lt_trans with (Rabs (x2 - x1) + Rabs (x1 - x)).
-replace (x2 - x) with (x2 - x1 + (x1 - x)); [ apply Rabs_triang | ring ].
-replace (pos x0) with (del + Rabs (x1 - x)).
-do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l;
- apply H10.
-unfold del in |- *; simpl in |- *; rewrite <- (Rabs_Ropp (x - x1));
- rewrite Ropp_minus_distr; ring.
-apply Rplus_lt_reg_r with (Rabs (x - x1)); rewrite Rplus_0_r;
- replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
- [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H6 | ring ].
+Proof.
+  intro; unfold closed_set, adherence in |- *;
+    unfold open_set, complementary, point_adherent in |- *; 
+      intros;
+        set
+          (P :=
+            fun V:R -> Prop =>
+              neighbourhood V x ->  exists y : R, intersection_domain V D y);
+          assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; 
+            unfold P in H1; assert (H2 := imply_to_and _ _ H1);
+              unfold neighbourhood in |- *; elim H2; intros; unfold neighbourhood in H3;
+                elim H3; intros; exists x0; unfold included in |- *; 
+                  intros; red in |- *; intro.
+  assert (H8 := H7 V0);
+    cut (exists delta : posreal, (forall x:R, disc x1 delta x -> V0 x)).
+  intro; assert (H10 := H8 H9); elim H4; assumption.
+  cut (0 < x0 - Rabs (x - x1)).
+  intro; set (del := mkposreal _ H9); exists del; intros;
+    unfold included in H5; apply H5; unfold disc in |- *;
+      apply Rle_lt_trans with (Rabs (x2 - x1) + Rabs (x1 - x)).
+  replace (x2 - x) with (x2 - x1 + (x1 - x)); [ apply Rabs_triang | ring ].
+  replace (pos x0) with (del + Rabs (x1 - x)).
+  do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l;
+    apply H10.
+  unfold del in |- *; simpl in |- *; rewrite <- (Rabs_Ropp (x - x1));
+    rewrite Ropp_minus_distr; ring.
+  apply Rplus_lt_reg_r with (Rabs (x - x1)); rewrite Rplus_0_r;
+    replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
+    [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H6 | ring ].
 Qed.
 
 Definition eq_Dom (D1 D2:R -> Prop) : Prop :=
@@ -141,231 +152,243 @@ Definition eq_Dom (D1 D2:R -> Prop) : Prop :=
 Infix "=_D" := eq_Dom (at level 70, no associativity).
 
 Lemma open_set_P1 : forall D:R -> Prop, open_set D <-> D =_D interior D.
-intro; split.
-intro; unfold eq_Dom in |- *; split.
-apply interior_P2; assumption.
-apply interior_P1.
-intro; unfold eq_Dom in H; elim H; clear H; intros; unfold open_set in |- *;
- intros; unfold included, interior in H; unfold included in H0;
- apply (H _ H1).
+Proof.
+  intro; split.
+  intro; unfold eq_Dom in |- *; split.
+  apply interior_P2; assumption.
+  apply interior_P1.
+  intro; unfold eq_Dom in H; elim H; clear H; intros; unfold open_set in |- *;
+    intros; unfold included, interior in H; unfold included in H0;
+      apply (H _ H1).
 Qed.
 
 Lemma closed_set_P1 : forall D:R -> Prop, closed_set D <-> D =_D adherence D.
-intro; split.
-intro; unfold eq_Dom in |- *; split.
-apply adherence_P1.
-apply adherence_P2; assumption.
-unfold eq_Dom in |- *; unfold included in |- *; intros;
- assert (H0 := adherence_P3 D); unfold closed_set in H0;
- unfold closed_set in |- *; unfold open_set in |- *; 
- unfold open_set in H0; intros; assert (H2 : complementary (adherence D) x).
-unfold complementary in |- *; unfold complementary in H1; red in |- *; intro;
- elim H; clear H; intros _ H; elim H1; apply (H _ H2).
-assert (H3 := H0 _ H2); unfold neighbourhood in |- *;
- unfold neighbourhood in H3; elim H3; intros; exists x0;
- unfold included in |- *; unfold included in H4; intros;
- assert (H6 := H4 _ H5); unfold complementary in H6;
- unfold complementary in |- *; red in |- *; intro; 
- elim H; clear H; intros H _; elim H6; apply (H _ H7).
+Proof.
+  intro; split.
+  intro; unfold eq_Dom in |- *; split.
+  apply adherence_P1.
+  apply adherence_P2; assumption.
+  unfold eq_Dom in |- *; unfold included in |- *; intros;
+    assert (H0 := adherence_P3 D); unfold closed_set in H0;
+      unfold closed_set in |- *; unfold open_set in |- *; 
+        unfold open_set in H0; intros; assert (H2 : complementary (adherence D) x).
+  unfold complementary in |- *; unfold complementary in H1; red in |- *; intro;
+    elim H; clear H; intros _ H; elim H1; apply (H _ H2).
+  assert (H3 := H0 _ H2); unfold neighbourhood in |- *;
+    unfold neighbourhood in H3; elim H3; intros; exists x0;
+      unfold included in |- *; unfold included in H4; intros;
+        assert (H6 := H4 _ H5); unfold complementary in H6;
+          unfold complementary in |- *; red in |- *; intro; 
+            elim H; clear H; intros H _; elim H6; apply (H _ H7).
 Qed.
 
 Lemma neighbourhood_P1 :
- forall (D1 D2:R -> Prop) (x:R),
-   included D1 D2 -> neighbourhood D1 x -> neighbourhood D2 x.
-unfold included, neighbourhood in |- *; intros; elim H0; intros; exists x0;
- intros; unfold included in |- *; unfold included in H1; 
- intros; apply (H _ (H1 _ H2)).
+  forall (D1 D2:R -> Prop) (x:R),
+    included D1 D2 -> neighbourhood D1 x -> neighbourhood D2 x.
+Proof.
+  unfold included, neighbourhood in |- *; intros; elim H0; intros; exists x0;
+    intros; unfold included in |- *; unfold included in H1; 
+      intros; apply (H _ (H1 _ H2)).
 Qed.
 
 Lemma open_set_P2 :
- forall D1 D2:R -> Prop,
-   open_set D1 -> open_set D2 -> open_set (union_domain D1 D2).
-unfold open_set in |- *; intros; unfold union_domain in H1; elim H1; intro.
-apply neighbourhood_P1 with D1.
-unfold included, union_domain in |- *; tauto.
-apply H; assumption.
-apply neighbourhood_P1 with D2.
-unfold included, union_domain in |- *; tauto.
-apply H0; assumption.
+  forall D1 D2:R -> Prop,
+    open_set D1 -> open_set D2 -> open_set (union_domain D1 D2).
+Proof.
+  unfold open_set in |- *; intros; unfold union_domain in H1; elim H1; intro.
+  apply neighbourhood_P1 with D1.
+  unfold included, union_domain in |- *; tauto.
+  apply H; assumption.
+  apply neighbourhood_P1 with D2.
+  unfold included, union_domain in |- *; tauto.
+  apply H0; assumption.
 Qed.
 
 Lemma open_set_P3 :
- forall D1 D2:R -> Prop,
-   open_set D1 -> open_set D2 -> open_set (intersection_domain D1 D2).
-unfold open_set in |- *; intros; unfold intersection_domain in H1; elim H1;
- intros.
-assert (H4 := H _ H2); assert (H5 := H0 _ H3);
- unfold intersection_domain in |- *; unfold neighbourhood in H4, H5; 
- elim H4; clear H; intros del1 H; elim H5; clear H0; 
- intros del2 H0; cut (0 < Rmin del1 del2).
-intro; set (del := mkposreal _ H6).
-exists del; unfold included in |- *; intros; unfold included in H, H0;
- unfold disc in H, H0, H7.
-split.
-apply H; apply Rlt_le_trans with (pos del).
-apply H7.
-unfold del in |- *; simpl in |- *; apply Rmin_l.
-apply H0; apply Rlt_le_trans with (pos del).
-apply H7.
-unfold del in |- *; simpl in |- *; apply Rmin_r.
-unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
-apply (cond_pos del1).
-apply (cond_pos del2).
+  forall D1 D2:R -> Prop,
+    open_set D1 -> open_set D2 -> open_set (intersection_domain D1 D2).
+Proof.
+  unfold open_set in |- *; intros; unfold intersection_domain in H1; elim H1;
+    intros.
+  assert (H4 := H _ H2); assert (H5 := H0 _ H3);
+    unfold intersection_domain in |- *; unfold neighbourhood in H4, H5; 
+      elim H4; clear H; intros del1 H; elim H5; clear H0; 
+        intros del2 H0; cut (0 < Rmin del1 del2).
+  intro; set (del := mkposreal _ H6).
+  exists del; unfold included in |- *; intros; unfold included in H, H0;
+    unfold disc in H, H0, H7.
+  split.
+  apply H; apply Rlt_le_trans with (pos del).
+  apply H7.
+  unfold del in |- *; simpl in |- *; apply Rmin_l.
+  apply H0; apply Rlt_le_trans with (pos del).
+  apply H7.
+  unfold del in |- *; simpl in |- *; apply Rmin_r.
+  unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
+  apply (cond_pos del1).
+  apply (cond_pos del2).
 Qed.
 
 Lemma open_set_P4 : open_set (fun x:R => False).
-unfold open_set in |- *; intros; elim H.
+Proof.
+  unfold open_set in |- *; intros; elim H.
 Qed.
 
 Lemma open_set_P5 : open_set (fun x:R => True).
-unfold open_set in |- *; intros; unfold neighbourhood in |- *.
-exists (mkposreal 1 Rlt_0_1); unfold included in |- *; intros; trivial.
+Proof.
+  unfold open_set in |- *; intros; unfold neighbourhood in |- *.
+  exists (mkposreal 1 Rlt_0_1); unfold included in |- *; intros; trivial.
 Qed.
 
 Lemma disc_P1 : forall (x:R) (del:posreal), open_set (disc x del).
-intros; assert (H := open_set_P1 (disc x del)).
-elim H; intros; apply H1.
-unfold eq_Dom in |- *; split.
-unfold included, interior, disc in |- *; intros;
- cut (0 < del - Rabs (x - x0)).
-intro; set (del2 := mkposreal _ H3).
-exists del2; unfold included in |- *; intros.
-apply Rle_lt_trans with (Rabs (x1 - x0) + Rabs (x0 - x)).
-replace (x1 - x) with (x1 - x0 + (x0 - x)); [ apply Rabs_triang | ring ].
-replace (pos del) with (del2 + Rabs (x0 - x)).
-do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l.
-apply H4.
-unfold del2 in |- *; simpl in |- *; rewrite <- (Rabs_Ropp (x - x0));
- rewrite Ropp_minus_distr; ring.
-apply Rplus_lt_reg_r with (Rabs (x - x0)); rewrite Rplus_0_r;
- replace (Rabs (x - x0) + (del - Rabs (x - x0))) with (pos del);
- [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2 | ring ].
-apply interior_P1.
+Proof.
+  intros; assert (H := open_set_P1 (disc x del)).
+  elim H; intros; apply H1.
+  unfold eq_Dom in |- *; split.
+  unfold included, interior, disc in |- *; intros;
+    cut (0 < del - Rabs (x - x0)).
+  intro; set (del2 := mkposreal _ H3).
+  exists del2; unfold included in |- *; intros.
+  apply Rle_lt_trans with (Rabs (x1 - x0) + Rabs (x0 - x)).
+  replace (x1 - x) with (x1 - x0 + (x0 - x)); [ apply Rabs_triang | ring ].
+  replace (pos del) with (del2 + Rabs (x0 - x)).
+  do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l.
+  apply H4.
+  unfold del2 in |- *; simpl in |- *; rewrite <- (Rabs_Ropp (x - x0));
+    rewrite Ropp_minus_distr; ring.
+  apply Rplus_lt_reg_r with (Rabs (x - x0)); rewrite Rplus_0_r;
+    replace (Rabs (x - x0) + (del - Rabs (x - x0))) with (pos del);
+    [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2 | ring ].
+  apply interior_P1.
 Qed.
 
 Lemma continuity_P1 :
- forall (f:R -> R) (x:R),
-   continuity_pt f x <->
-   (forall W:R -> Prop,
+  forall (f:R -> R) (x:R),
+    continuity_pt f x <->
+    (forall W:R -> Prop,
       neighbourhood W (f x) ->
-       exists V : R -> Prop,
+      exists V : R -> Prop,
         neighbourhood V x /\ (forall y:R, V y -> W (f y))).
-intros; split.
-intros; unfold neighbourhood in H0.
-elim H0; intros del1 H1.
-unfold continuity_pt in H; unfold continue_in in H; unfold limit1_in in H;
- unfold limit_in in H; simpl in H; unfold R_dist in H.
-assert (H2 := H del1 (cond_pos del1)).
-elim H2; intros del2 H3.
-elim H3; intros.
-exists (disc x (mkposreal del2 H4)).
-intros; unfold included in H1; split.
-unfold neighbourhood, disc in |- *.
-exists (mkposreal del2 H4).
-unfold included in |- *; intros; assumption.
-intros; apply H1; unfold disc in |- *; case (Req_dec y x); intro.
-rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- apply (cond_pos del1).
-apply H5; split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-apply (sym_not_eq (A:=R)); apply H7.
-unfold disc in H6; apply H6.
-intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- intros.
-assert (H1 := H (disc (f x) (mkposreal eps H0))).
-cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)).
-intro; assert (H3 := H1 H2).
-elim H3; intros D H4; elim H4; intros; unfold neighbourhood in H5; elim H5;
- intros del1 H7.
-exists (pos del1); split.
-apply (cond_pos del1).
-intros; elim H8; intros; simpl in H10; unfold R_dist in H10; simpl in |- *;
- unfold R_dist in |- *; apply (H6 _ (H7 _ H10)).
-unfold neighbourhood, disc in |- *; exists (mkposreal eps H0);
- unfold included in |- *; intros; assumption.
+Proof.
+  intros; split.
+  intros; unfold neighbourhood in H0.
+  elim H0; intros del1 H1.
+  unfold continuity_pt in H; unfold continue_in in H; unfold limit1_in in H;
+    unfold limit_in in H; simpl in H; unfold R_dist in H.
+  assert (H2 := H del1 (cond_pos del1)).
+  elim H2; intros del2 H3.
+  elim H3; intros.
+  exists (disc x (mkposreal del2 H4)).
+  intros; unfold included in H1; split.
+  unfold neighbourhood, disc in |- *.
+  exists (mkposreal del2 H4).
+  unfold included in |- *; intros; assumption.
+  intros; apply H1; unfold disc in |- *; case (Req_dec y x); intro.
+  rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    apply (cond_pos del1).
+  apply H5; split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  apply (sym_not_eq (A:=R)); apply H7.
+  unfold disc in H6; apply H6.
+  intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      intros.
+  assert (H1 := H (disc (f x) (mkposreal eps H0))).
+  cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)).
+  intro; assert (H3 := H1 H2).
+  elim H3; intros D H4; elim H4; intros; unfold neighbourhood in H5; elim H5;
+    intros del1 H7.
+  exists (pos del1); split.
+  apply (cond_pos del1).
+  intros; elim H8; intros; simpl in H10; unfold R_dist in H10; simpl in |- *;
+    unfold R_dist in |- *; apply (H6 _ (H7 _ H10)).
+  unfold neighbourhood, disc in |- *; exists (mkposreal eps H0);
+    unfold included in |- *; intros; assumption.
 Qed.
 
 Definition image_rec (f:R -> R) (D:R -> Prop) (x:R) : Prop := D (f x).
 
 (**********)
 Lemma continuity_P2 :
- forall (f:R -> R) (D:R -> Prop),
-   continuity f -> open_set D -> open_set (image_rec f D).
-intros; unfold open_set in H0; unfold open_set in |- *; intros;
- assert (H2 := continuity_P1 f x); elim H2; intros H3 _;
- assert (H4 := H3 (H x)); unfold neighbourhood, image_rec in |- *;
- unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); 
- elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; 
- elim H7; intros del H9; exists del; unfold included in H9;
- unfold included in |- *; intros; apply (H8 _ (H9 _ H10)).
+  forall (f:R -> R) (D:R -> Prop),
+    continuity f -> open_set D -> open_set (image_rec f D).
+Proof.
+  intros; unfold open_set in H0; unfold open_set in |- *; intros;
+    assert (H2 := continuity_P1 f x); elim H2; intros H3 _;
+      assert (H4 := H3 (H x)); unfold neighbourhood, image_rec in |- *;
+        unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); 
+          elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; 
+            elim H7; intros del H9; exists del; unfold included in H9;
+              unfold included in |- *; intros; apply (H8 _ (H9 _ H10)).
 Qed.
 
 (**********)
 Lemma continuity_P3 :
- forall f:R -> R,
-   continuity f <->
-   (forall D:R -> Prop, open_set D -> open_set (image_rec f D)).
-intros; split.
-intros; apply continuity_P2; assumption.
-intros; unfold continuity in |- *; unfold continuity_pt in |- *;
- unfold continue_in in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros; cut (open_set (disc (f x) (mkposreal _ H0))).
-intro; assert (H2 := H _ H1).
-unfold open_set, image_rec in H2; cut (disc (f x) (mkposreal _ H0) (f x)).
-intro; assert (H4 := H2 _ H3).
-unfold neighbourhood in H4; elim H4; intros del H5.
-exists (pos del); split.
-apply (cond_pos del).
-intros; unfold included in H5; apply H5; elim H6; intros; apply H8.
-unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; apply H0.
-apply disc_P1.
+  forall f:R -> R,
+    continuity f <->
+    (forall D:R -> Prop, open_set D -> open_set (image_rec f D)).
+Proof.
+  intros; split.
+  intros; apply continuity_P2; assumption.
+  intros; unfold continuity in |- *; unfold continuity_pt in |- *;
+    unfold continue_in in |- *; unfold limit1_in in |- *;
+      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+        intros; cut (open_set (disc (f x) (mkposreal _ H0))).
+  intro; assert (H2 := H _ H1).
+  unfold open_set, image_rec in H2; cut (disc (f x) (mkposreal _ H0) (f x)).
+  intro; assert (H4 := H2 _ H3).
+  unfold neighbourhood in H4; elim H4; intros del H5.
+  exists (pos del); split.
+  apply (cond_pos del).
+  intros; unfold included in H5; apply H5; elim H6; intros; apply H8.
+  unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; apply H0.
+  apply disc_P1.
 Qed.
 
 (**********)
 Theorem Rsepare :
- forall x y:R,
-   x <> y ->
+  forall x y:R,
+    x <> y ->
     exists V : R -> Prop,
-     (exists W : R -> Prop,
+      (exists W : R -> Prop,
         neighbourhood V x /\
         neighbourhood W y /\ ~ (exists y : R, intersection_domain V W y)).
-intros x y Hsep; set (D := Rabs (x - y)).
-cut (0 < D / 2).
-intro; exists (disc x (mkposreal _ H)).
-exists (disc y (mkposreal _ H)); split.
-unfold neighbourhood in |- *; exists (mkposreal _ H); unfold included in |- *;
- tauto.
-split.
-unfold neighbourhood in |- *; exists (mkposreal _ H); unfold included in |- *;
- tauto.
-red in |- *; intro; elim H0; intros; unfold intersection_domain in H1;
- elim H1; intros.
-cut (D < D).
-intro; elim (Rlt_irrefl _ H4).
-change (Rabs (x - y) < D) in |- *;
- apply Rle_lt_trans with (Rabs (x - x0) + Rabs (x0 - y)).
-replace (x - y) with (x - x0 + (x0 - y)); [ apply Rabs_triang | ring ].
-rewrite (double_var D); apply Rplus_lt_compat.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2.
-apply H3.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-unfold D in |- *; apply Rabs_pos_lt; apply (Rminus_eq_contra _ _ Hsep).
-apply Rinv_0_lt_compat; prove_sup0.
+Proof.
+  intros x y Hsep; set (D := Rabs (x - y)).
+  cut (0 < D / 2).
+  intro; exists (disc x (mkposreal _ H)).
+  exists (disc y (mkposreal _ H)); split.
+  unfold neighbourhood in |- *; exists (mkposreal _ H); unfold included in |- *;
+    tauto.
+  split.
+  unfold neighbourhood in |- *; exists (mkposreal _ H); unfold included in |- *;
+    tauto.
+  red in |- *; intro; elim H0; intros; unfold intersection_domain in H1;
+    elim H1; intros.
+  cut (D < D).
+  intro; elim (Rlt_irrefl _ H4).
+  change (Rabs (x - y) < D) in |- *;
+    apply Rle_lt_trans with (Rabs (x - x0) + Rabs (x0 - y)).
+  replace (x - y) with (x - x0 + (x0 - y)); [ apply Rabs_triang | ring ].
+  rewrite (double_var D); apply Rplus_lt_compat.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2.
+  apply H3.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold D in |- *; apply Rabs_pos_lt; apply (Rminus_eq_contra _ _ Hsep).
+  apply Rinv_0_lt_compat; prove_sup0.
 Qed.
 
 Record family : Type := mkfamily
   {ind : R -> Prop;
-   f :> R -> R -> Prop;
-   cond_fam : forall x:R, (exists y : R, f x y) -> ind x}.
+    f :> R -> R -> Prop;
+    cond_fam : forall x:R, (exists y : R, f x y) -> ind x}.
 
 Definition family_open_set (f:family) : Prop := forall x:R, open_set (f x).
 
 Definition domain_finite (D:R -> Prop) : Prop :=
-   exists l : Rlist, (forall x:R, D x <-> In x l).
+  exists l : Rlist, (forall x:R, D x <-> In x l).
 
 Definition family_finite (f:family) : Prop := domain_finite (ind f).
 
@@ -379,897 +402,913 @@ Definition covering_finite (D:R -> Prop) (f:family) : Prop :=
   covering D f /\ family_finite f.
 
 Lemma restriction_family :
- forall (f:family) (D:R -> Prop) (x:R),
-   (exists y : R, (fun z1 z2:R => f z1 z2 /\ D z1) x y) ->
-   intersection_domain (ind f) D x.
-intros; elim H; intros; unfold intersection_domain in |- *; elim H0; intros;
- split.
-apply (cond_fam f0); exists x0; assumption.
-assumption.
+  forall (f:family) (D:R -> Prop) (x:R),
+    (exists y : R, (fun z1 z2:R => f z1 z2 /\ D z1) x y) ->
+    intersection_domain (ind f) D x.
+Proof.
+  intros; elim H; intros; unfold intersection_domain in |- *; elim H0; intros;
+    split.
+  apply (cond_fam f0); exists x0; assumption.
+  assumption.
 Qed.
 
 Definition subfamily (f:family) (D:R -> Prop) : family :=
   mkfamily (intersection_domain (ind f) D) (fun x y:R => f x y /\ D x)
-    (restriction_family f D).
+  (restriction_family f D).
 
 Definition compact (X:R -> Prop) : Prop :=
   forall f:family,
     covering_open_set X f ->
-     exists D : R -> Prop, covering_finite X (subfamily f D).
+    exists D : R -> Prop, covering_finite X (subfamily f D).
 
 (**********)
 Lemma family_P1 :
- forall (f:family) (D:R -> Prop),
-   family_open_set f -> family_open_set (subfamily f D).
-unfold family_open_set in |- *; intros; unfold subfamily in |- *;
- simpl in |- *; assert (H0 := classic (D x)).
-elim H0; intro.
-cut (open_set (f0 x) -> open_set (fun y:R => f0 x y /\ D x)).
-intro; apply H2; apply H.
-unfold open_set in |- *; unfold neighbourhood in |- *; intros; elim H3;
- intros; assert (H6 := H2 _ H4); elim H6; intros; exists x1;
- unfold included in |- *; intros; split.
-apply (H7 _ H8).
-assumption.
-cut (open_set (fun y:R => False) -> open_set (fun y:R => f0 x y /\ D x)).
-intro; apply H2; apply open_set_P4.
-unfold open_set in |- *; unfold neighbourhood in |- *; intros; elim H3;
- intros; elim H1; assumption.
+  forall (f:family) (D:R -> Prop),
+    family_open_set f -> family_open_set (subfamily f D).
+Proof.
+  unfold family_open_set in |- *; intros; unfold subfamily in |- *;
+    simpl in |- *; assert (H0 := classic (D x)).
+  elim H0; intro.
+  cut (open_set (f0 x) -> open_set (fun y:R => f0 x y /\ D x)).
+  intro; apply H2; apply H.
+  unfold open_set in |- *; unfold neighbourhood in |- *; intros; elim H3;
+    intros; assert (H6 := H2 _ H4); elim H6; intros; exists x1;
+      unfold included in |- *; intros; split.
+  apply (H7 _ H8).
+  assumption.
+  cut (open_set (fun y:R => False) -> open_set (fun y:R => f0 x y /\ D x)).
+  intro; apply H2; apply open_set_P4.
+  unfold open_set in |- *; unfold neighbourhood in |- *; intros; elim H3;
+    intros; elim H1; assumption.
 Qed.
 
 Definition bounded (D:R -> Prop) : Prop :=
-   exists m : R, (exists M : R, (forall x:R, D x -> m <= x <= M)).
+  exists m : R, (exists M : R, (forall x:R, D x -> m <= x <= M)).
 
 Lemma open_set_P6 :
- forall D1 D2:R -> Prop, open_set D1 -> D1 =_D D2 -> open_set D2.
-unfold open_set in |- *; unfold neighbourhood in |- *; intros.
-unfold eq_Dom in H0; elim H0; intros.
-assert (H4 := H _ (H3 _ H1)).
-elim H4; intros.
-exists x0; apply included_trans with D1; assumption.
+  forall D1 D2:R -> Prop, open_set D1 -> D1 =_D D2 -> open_set D2.
+Proof.
+  unfold open_set in |- *; unfold neighbourhood in |- *; intros.
+  unfold eq_Dom in H0; elim H0; intros.
+  assert (H4 := H _ (H3 _ H1)).
+  elim H4; intros.
+  exists x0; apply included_trans with D1; assumption.
 Qed.
 
 (**********)
 Lemma compact_P1 : forall X:R -> Prop, compact X -> bounded X.
-intros; unfold compact in H; set (D := fun x:R => True);
- set (g := fun x y:R => Rabs y < x);
- cut (forall x:R, (exists y : _, g x y) -> True);
- [ intro | intro; trivial ].
-set (f0 := mkfamily D g H0); assert (H1 := H f0);
- cut (covering_open_set X f0).
-intro; assert (H3 := H1 H2); elim H3; intros D' H4;
- unfold covering_finite in H4; elim H4; intros; unfold family_finite in H6;
- unfold domain_finite in H6; elim H6; intros l H7; 
- unfold bounded in |- *; set (r := MaxRlist l).
-exists (- r); exists r; intros.
-unfold covering in H5; assert (H9 := H5 _ H8); elim H9; intros;
- unfold subfamily in H10; simpl in H10; elim H10; intros;
- assert (H13 := H7 x0); simpl in H13; cut (intersection_domain D D' x0).
-elim H13; clear H13; intros.
-assert (H16 := H13 H15); unfold g in H11; split.
-cut (x0 <= r).
-intro; cut (Rabs x < r).
-intro; assert (H19 := Rabs_def2 x r H18); elim H19; intros; left; assumption.
-apply Rlt_le_trans with x0; assumption.
-apply (MaxRlist_P1 l x0 H16).
-cut (x0 <= r).
-intro; apply Rle_trans with (Rabs x).
-apply RRle_abs.
-apply Rle_trans with x0.
-left; apply H11.
-assumption.
-apply (MaxRlist_P1 l x0 H16).
-unfold intersection_domain, D in |- *; tauto.
-unfold covering_open_set in |- *; split.
-unfold covering in |- *; intros; simpl in |- *; exists (Rabs x + 1);
- unfold g in |- *; pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_lt_compat_l; apply Rlt_0_1.
-unfold family_open_set in |- *; intro; case (Rtotal_order 0 x); intro.
-apply open_set_P6 with (disc 0 (mkposreal _ H2)).
-apply disc_P1.
-unfold eq_Dom in |- *; unfold f0 in |- *; simpl in |- *;
- unfold g, disc in |- *; split.
-unfold included in |- *; intros; unfold Rminus in H3; rewrite Ropp_0 in H3;
- rewrite Rplus_0_r in H3; apply H3.
-unfold included in |- *; intros; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; apply H3.
-apply open_set_P6 with (fun x:R => False).
-apply open_set_P4.
-unfold eq_Dom in |- *; split.
-unfold included in |- *; intros; elim H3.
-unfold included, f0 in |- *; simpl in |- *; unfold g in |- *; intros; elim H2;
- intro;
- [ rewrite <- H4 in H3; assert (H5 := Rabs_pos x0);
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3))
- | assert (H6 := Rabs_pos x0); assert (H7 := Rlt_trans _ _ _ H3 H4);
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7)) ].
+Proof.
+  intros; unfold compact in H; set (D := fun x:R => True);
+    set (g := fun x y:R => Rabs y < x);
+      cut (forall x:R, (exists y : _, g x y) -> True);
+        [ intro | intro; trivial ].
+  set (f0 := mkfamily D g H0); assert (H1 := H f0);
+    cut (covering_open_set X f0).
+  intro; assert (H3 := H1 H2); elim H3; intros D' H4;
+    unfold covering_finite in H4; elim H4; intros; unfold family_finite in H6;
+      unfold domain_finite in H6; elim H6; intros l H7; 
+        unfold bounded in |- *; set (r := MaxRlist l).
+  exists (- r); exists r; intros.
+  unfold covering in H5; assert (H9 := H5 _ H8); elim H9; intros;
+    unfold subfamily in H10; simpl in H10; elim H10; intros;
+      assert (H13 := H7 x0); simpl in H13; cut (intersection_domain D D' x0).
+  elim H13; clear H13; intros.
+  assert (H16 := H13 H15); unfold g in H11; split.
+  cut (x0 <= r).
+  intro; cut (Rabs x < r).
+  intro; assert (H19 := Rabs_def2 x r H18); elim H19; intros; left; assumption.
+  apply Rlt_le_trans with x0; assumption.
+  apply (MaxRlist_P1 l x0 H16).
+  cut (x0 <= r).
+  intro; apply Rle_trans with (Rabs x).
+  apply RRle_abs.
+  apply Rle_trans with x0.
+  left; apply H11.
+  assumption.
+  apply (MaxRlist_P1 l x0 H16).
+  unfold intersection_domain, D in |- *; tauto.
+  unfold covering_open_set in |- *; split.
+  unfold covering in |- *; intros; simpl in |- *; exists (Rabs x + 1);
+    unfold g in |- *; pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r;
+      apply Rplus_lt_compat_l; apply Rlt_0_1.
+  unfold family_open_set in |- *; intro; case (Rtotal_order 0 x); intro.
+  apply open_set_P6 with (disc 0 (mkposreal _ H2)).
+  apply disc_P1.
+  unfold eq_Dom in |- *; unfold f0 in |- *; simpl in |- *;
+    unfold g, disc in |- *; split.
+  unfold included in |- *; intros; unfold Rminus in H3; rewrite Ropp_0 in H3;
+    rewrite Rplus_0_r in H3; apply H3.
+  unfold included in |- *; intros; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; apply H3.
+  apply open_set_P6 with (fun x:R => False).
+  apply open_set_P4.
+  unfold eq_Dom in |- *; split.
+  unfold included in |- *; intros; elim H3.
+  unfold included, f0 in |- *; simpl in |- *; unfold g in |- *; intros; elim H2;
+    intro;
+      [ rewrite <- H4 in H3; assert (H5 := Rabs_pos x0);
+        elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3))
+        | assert (H6 := Rabs_pos x0); assert (H7 := Rlt_trans _ _ _ H3 H4);
+          elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7)) ].
 Qed.
 
 (**********)
 Lemma compact_P2 : forall X:R -> Prop, compact X -> closed_set X.
-intros; assert (H0 := closed_set_P1 X); elim H0; clear H0; intros _ H0;
- apply H0; clear H0.
-unfold eq_Dom in |- *; split.
-apply adherence_P1.
-unfold included in |- *; unfold adherence in |- *;
- unfold point_adherent in |- *; intros; unfold compact in H;
- assert (H1 := classic (X x)); elim H1; clear H1; intro.
-assumption.
-cut (forall y:R, X y -> 0 < Rabs (y - x) / 2).
-intro; set (D := X);
- set (g := fun y z:R => Rabs (y - z) < Rabs (y - x) / 2 /\ D y);
- cut (forall x:R, (exists y : _, g x y) -> D x).
-intro; set (f0 := mkfamily D g H3); assert (H4 := H f0);
- cut (covering_open_set X f0).
-intro; assert (H6 := H4 H5); elim H6; clear H6; intros D' H6.
-unfold covering_finite in H6; decompose [and] H6;
- unfold covering, subfamily in H7; simpl in H7;
- unfold family_finite, subfamily in H8; simpl in H8;
- unfold domain_finite in H8; elim H8; clear H8; intros l H8;
- set (alp := MinRlist (AbsList l x)); cut (0 < alp).
-intro; assert (H10 := H0 (disc x (mkposreal _ H9)));
- cut (neighbourhood (disc x (mkposreal alp H9)) x).
-intro; assert (H12 := H10 H11); elim H12; clear H12; intros y H12;
- unfold intersection_domain in H12; elim H12; clear H12; 
- intros; assert (H14 := H7 _ H13); elim H14; clear H14; 
- intros y0 H14; elim H14; clear H14; intros; unfold g in H14; 
- elim H14; clear H14; intros; unfold disc in H12; simpl in H12;
- cut (alp <= Rabs (y0 - x) / 2).
-intro; assert (H18 := Rlt_le_trans _ _ _ H12 H17);
- cut (Rabs (y0 - x) < Rabs (y0 - x)).
-intro; elim (Rlt_irrefl _ H19).
-apply Rle_lt_trans with (Rabs (y0 - y) + Rabs (y - x)).
-replace (y0 - x) with (y0 - y + (y - x)); [ apply Rabs_triang | ring ].
-rewrite (double_var (Rabs (y0 - x))); apply Rplus_lt_compat; assumption.
-apply (MinRlist_P1 (AbsList l x) (Rabs (y0 - x) / 2)); apply AbsList_P1;
- elim (H8 y0); clear H8; intros; apply H8; unfold intersection_domain in |- *;
- split; assumption.
-assert (H11 := disc_P1 x (mkposreal alp H9)); unfold open_set in H11;
- apply H11.
-unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; apply H9.
-unfold alp in |- *; apply MinRlist_P2; intros;
- assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; 
- intros z H10; elim H10; clear H10; intros; rewrite H11; 
- apply H2; elim (H8 z); clear H8; intros; assert (H13 := H12 H10);
- unfold intersection_domain, D in H13; elim H13; clear H13; 
- intros; assumption.
-unfold covering_open_set in |- *; split.
-unfold covering in |- *; intros; exists x0; simpl in |- *; unfold g in |- *;
- split.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- unfold Rminus in H2; apply (H2 _ H5).
-apply H5.
-unfold family_open_set in |- *; intro; simpl in |- *; unfold g in |- *;
- elim (classic (D x0)); intro.
-apply open_set_P6 with (disc x0 (mkposreal _ (H2 _ H5))).
-apply disc_P1.
-unfold eq_Dom in |- *; split.
-unfold included, disc in |- *; simpl in |- *; intros; split.
-rewrite <- (Rabs_Ropp (x0 - x1)); rewrite Ropp_minus_distr; apply H6.
-apply H5.
-unfold included, disc in |- *; simpl in |- *; intros; elim H6; intros;
- rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; 
- apply H7.
-apply open_set_P6 with (fun z:R => False).
-apply open_set_P4.
-unfold eq_Dom in |- *; split.
-unfold included in |- *; intros; elim H6.
-unfold included in |- *; intros; elim H6; intros; elim H5; assumption.
-intros; elim H3; intros; unfold g in H4; elim H4; clear H4; intros _ H4;
- apply H4.
-intros; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply Rabs_pos_lt; apply Rminus_eq_contra; red in |- *; intro;
- rewrite H3 in H2; elim H1; apply H2.
-apply Rinv_0_lt_compat; prove_sup0.
+Proof.
+  intros; assert (H0 := closed_set_P1 X); elim H0; clear H0; intros _ H0;
+    apply H0; clear H0.
+  unfold eq_Dom in |- *; split.
+  apply adherence_P1.
+  unfold included in |- *; unfold adherence in |- *;
+    unfold point_adherent in |- *; intros; unfold compact in H;
+      assert (H1 := classic (X x)); elim H1; clear H1; intro.
+  assumption.
+  cut (forall y:R, X y -> 0 < Rabs (y - x) / 2).
+  intro; set (D := X);
+    set (g := fun y z:R => Rabs (y - z) < Rabs (y - x) / 2 /\ D y);
+      cut (forall x:R, (exists y : _, g x y) -> D x).
+  intro; set (f0 := mkfamily D g H3); assert (H4 := H f0);
+    cut (covering_open_set X f0).
+  intro; assert (H6 := H4 H5); elim H6; clear H6; intros D' H6.
+  unfold covering_finite in H6; decompose [and] H6;
+    unfold covering, subfamily in H7; simpl in H7;
+      unfold family_finite, subfamily in H8; simpl in H8;
+        unfold domain_finite in H8; elim H8; clear H8; intros l H8;
+          set (alp := MinRlist (AbsList l x)); cut (0 < alp).
+  intro; assert (H10 := H0 (disc x (mkposreal _ H9)));
+    cut (neighbourhood (disc x (mkposreal alp H9)) x).
+  intro; assert (H12 := H10 H11); elim H12; clear H12; intros y H12;
+    unfold intersection_domain in H12; elim H12; clear H12; 
+      intros; assert (H14 := H7 _ H13); elim H14; clear H14; 
+        intros y0 H14; elim H14; clear H14; intros; unfold g in H14; 
+          elim H14; clear H14; intros; unfold disc in H12; simpl in H12;
+            cut (alp <= Rabs (y0 - x) / 2).
+  intro; assert (H18 := Rlt_le_trans _ _ _ H12 H17);
+    cut (Rabs (y0 - x) < Rabs (y0 - x)).
+  intro; elim (Rlt_irrefl _ H19).
+  apply Rle_lt_trans with (Rabs (y0 - y) + Rabs (y - x)).
+  replace (y0 - x) with (y0 - y + (y - x)); [ apply Rabs_triang | ring ].
+  rewrite (double_var (Rabs (y0 - x))); apply Rplus_lt_compat; assumption.
+  apply (MinRlist_P1 (AbsList l x) (Rabs (y0 - x) / 2)); apply AbsList_P1;
+    elim (H8 y0); clear H8; intros; apply H8; unfold intersection_domain in |- *;
+      split; assumption.
+  assert (H11 := disc_P1 x (mkposreal alp H9)); unfold open_set in H11;
+    apply H11.
+  unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; apply H9.
+  unfold alp in |- *; apply MinRlist_P2; intros;
+    assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; 
+      intros z H10; elim H10; clear H10; intros; rewrite H11; 
+        apply H2; elim (H8 z); clear H8; intros; assert (H13 := H12 H10);
+          unfold intersection_domain, D in H13; elim H13; clear H13; 
+            intros; assumption.
+  unfold covering_open_set in |- *; split.
+  unfold covering in |- *; intros; exists x0; simpl in |- *; unfold g in |- *;
+    split.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    unfold Rminus in H2; apply (H2 _ H5).
+  apply H5.
+  unfold family_open_set in |- *; intro; simpl in |- *; unfold g in |- *;
+    elim (classic (D x0)); intro.
+  apply open_set_P6 with (disc x0 (mkposreal _ (H2 _ H5))).
+  apply disc_P1.
+  unfold eq_Dom in |- *; split.
+  unfold included, disc in |- *; simpl in |- *; intros; split.
+  rewrite <- (Rabs_Ropp (x0 - x1)); rewrite Ropp_minus_distr; apply H6.
+  apply H5.
+  unfold included, disc in |- *; simpl in |- *; intros; elim H6; intros;
+    rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; 
+      apply H7.
+  apply open_set_P6 with (fun z:R => False).
+  apply open_set_P4.
+  unfold eq_Dom in |- *; split.
+  unfold included in |- *; intros; elim H6.
+  unfold included in |- *; intros; elim H6; intros; elim H5; assumption.
+  intros; elim H3; intros; unfold g in H4; elim H4; clear H4; intros _ H4;
+    apply H4.
+  intros; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply Rabs_pos_lt; apply Rminus_eq_contra; red in |- *; intro;
+    rewrite H3 in H2; elim H1; apply H2.
+  apply Rinv_0_lt_compat; prove_sup0.
 Qed.
 
 (**********)
 Lemma compact_EMP : compact (fun _:R => False).
-unfold compact in |- *; intros; exists (fun x:R => False);
- unfold covering_finite in |- *; split.
-unfold covering in |- *; intros; elim H0.
-unfold family_finite in |- *; unfold domain_finite in |- *; exists nil; intro.
-split.
-simpl in |- *; unfold intersection_domain in |- *; intros; elim H0.
-elim H0; clear H0; intros _ H0; elim H0.
-simpl in |- *; intro; elim H0.
+Proof.
+  unfold compact in |- *; intros; exists (fun x:R => False);
+    unfold covering_finite in |- *; split.
+  unfold covering in |- *; intros; elim H0.
+  unfold family_finite in |- *; unfold domain_finite in |- *; exists nil; intro.
+  split.
+  simpl in |- *; unfold intersection_domain in |- *; intros; elim H0.
+  elim H0; clear H0; intros _ H0; elim H0.
+  simpl in |- *; intro; elim H0.
 Qed.
 
 Lemma compact_eqDom :
- forall X1 X2:R -> Prop, compact X1 -> X1 =_D X2 -> compact X2.
-unfold compact in |- *; intros; unfold eq_Dom in H0; elim H0; clear H0;
- unfold included in |- *; intros; assert (H3 : covering_open_set X1 f0).
-unfold covering_open_set in |- *; unfold covering_open_set in H1; elim H1;
- clear H1; intros; split.
-unfold covering in H1; unfold covering in |- *; intros;
- apply (H1 _ (H0 _ H4)).
-apply H3.
-elim (H _ H3); intros D H4; exists D; unfold covering_finite in |- *;
- unfold covering_finite in H4; elim H4; intros; split.
-unfold covering in H5; unfold covering in |- *; intros;
- apply (H5 _ (H2 _ H7)).
-apply H6.
+  forall X1 X2:R -> Prop, compact X1 -> X1 =_D X2 -> compact X2.
+Proof.
+  unfold compact in |- *; intros; unfold eq_Dom in H0; elim H0; clear H0;
+    unfold included in |- *; intros; assert (H3 : covering_open_set X1 f0).
+  unfold covering_open_set in |- *; unfold covering_open_set in H1; elim H1;
+    clear H1; intros; split.
+  unfold covering in H1; unfold covering in |- *; intros;
+    apply (H1 _ (H0 _ H4)).
+  apply H3.
+  elim (H _ H3); intros D H4; exists D; unfold covering_finite in |- *;
+    unfold covering_finite in H4; elim H4; intros; split.
+  unfold covering in H5; unfold covering in |- *; intros;
+    apply (H5 _ (H2 _ H7)).
+  apply H6.
 Qed.
 
-(* Borel-Lebesgue's lemma *)
+(** Borel-Lebesgue's lemma *)
 Lemma compact_P3 : forall a b:R, compact (fun c:R => a <= c <= b).
-intros; case (Rle_dec a b); intro.
-unfold compact in |- *; intros;
- set
-  (A :=
-   fun x:R =>
-     a <= x <= b /\
-     (exists D : R -> Prop,
-        covering_finite (fun c:R => a <= c <= x) (subfamily f0 D)));
- cut (A a).
-intro; cut (bound A).
-intro; cut (exists a0 : R, A a0).
-intro; assert (H3 := completeness A H1 H2); elim H3; clear H3; intros m H3;
- unfold is_lub in H3; cut (a <= m <= b).
-intro; unfold covering_open_set in H; elim H; clear H; intros;
- unfold covering in H; assert (H6 := H m H4); elim H6; 
- clear H6; intros y0 H6; unfold family_open_set in H5; 
- assert (H7 := H5 y0); unfold open_set in H7; assert (H8 := H7 m H6);
- unfold neighbourhood in H8; elim H8; clear H8; intros eps H8;
- cut (exists x : R, A x /\ m - eps < x <= m).
-intro; elim H9; clear H9; intros x H9; elim H9; clear H9; intros;
- case (Req_dec m b); intro.
-rewrite H11 in H10; rewrite H11 in H8; unfold A in H9; elim H9; clear H9;
- intros; elim H12; clear H12; intros Dx H12;
- set (Db := fun x:R => Dx x \/ x = y0); exists Db;
- unfold covering_finite in |- *; split.
-unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
- intros; unfold covering in H12; case (Rle_dec x0 x); 
- intro.
-cut (a <= x0 <= x).
-intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
- simpl in H16; simpl in |- *; unfold Db in |- *; elim H16; 
- clear H16; intros; split; [ apply H16 | left; apply H17 ].
-split.
-elim H14; intros; assumption.
-assumption.
-exists y0; simpl in |- *; split.
-apply H8; unfold disc in |- *; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
- rewrite Rabs_right.
-apply Rlt_trans with (b - x).
-unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
- auto with real.
-elim H10; intros H15 _; apply Rplus_lt_reg_r with (x - eps);
- replace (x - eps + (b - x)) with (b - eps);
- [ replace (x - eps + eps) with x; [ apply H15 | ring ] | ring ].
-apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15.
-unfold Db in |- *; right; reflexivity.
-unfold family_finite in |- *; unfold domain_finite in |- *;
- unfold covering_finite in H12; elim H12; clear H12; 
- intros; unfold family_finite in H13; unfold domain_finite in H13; 
- elim H13; clear H13; intros l H13; exists (cons y0 l); 
- intro; split.
-intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
- clear H13; intros; case (Req_dec x0 y0); intro.
-simpl in |- *; left; apply H16.
-simpl in |- *; right; apply H13.
-simpl in |- *; unfold intersection_domain in |- *; unfold Db in H14;
- decompose [and or] H14.
-split; assumption.
-elim H16; assumption.
-intro; simpl in H14; elim H14; intro; simpl in |- *;
- unfold intersection_domain in |- *.
-split.
-apply (cond_fam f0); rewrite H15; exists m; apply H6.
-unfold Db in |- *; right; assumption.
-simpl in |- *; unfold intersection_domain in |- *; elim (H13 x0).
-intros _ H16; assert (H17 := H16 H15); simpl in H17;
- unfold intersection_domain in H17; split.
-elim H17; intros; assumption.
-unfold Db in |- *; left; elim H17; intros; assumption.
-set (m' := Rmin (m + eps / 2) b); cut (A m').
-intro; elim H3; intros; unfold is_upper_bound in H13;
- assert (H15 := H13 m' H12); cut (m < m').
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H15 H16)).
-unfold m' in |- *; unfold Rmin in |- *; case (Rle_dec (m + eps / 2) b); intro.
-pattern m at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
-elim H4; intros.
-elim H17; intro.
-assumption.
-elim H11; assumption.
-unfold A in |- *; split.
-split.
-apply Rle_trans with m.
-elim H4; intros; assumption.
-unfold m' in |- *; unfold Rmin in |- *; case (Rle_dec (m + eps / 2) b); intro.
-pattern m at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
- unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
-elim H4; intros.
-elim H13; intro.
-assumption.
-elim H11; assumption.
-unfold m' in |- *; apply Rmin_r.
-unfold A in H9; elim H9; clear H9; intros; elim H12; clear H12; intros Dx H12;
- set (Db := fun x:R => Dx x \/ x = y0); exists Db;
- unfold covering_finite in |- *; split.
-unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
- intros; unfold covering in H12; case (Rle_dec x0 x); 
- intro.
-cut (a <= x0 <= x).
-intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
- simpl in H16; simpl in |- *; unfold Db in |- *.
-elim H16; clear H16; intros; split; [ apply H16 | left; apply H17 ].
-elim H14; intros; split; assumption.
-exists y0; simpl in |- *; split.
-apply H8; unfold disc in |- *; unfold Rabs in |- *; case (Rcase_abs (x0 - m));
- intro.
-rewrite Ropp_minus_distr; apply Rlt_trans with (m - x).
-unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
- auto with real.
-apply Rplus_lt_reg_r with (x - eps);
- replace (x - eps + (m - x)) with (m - eps).
-replace (x - eps + eps) with x.
-elim H10; intros; assumption.
-ring.
-ring.
-apply Rle_lt_trans with (m' - m).
-unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- m));
- apply Rplus_le_compat_l; elim H14; intros; assumption.
-apply Rplus_lt_reg_r with m; replace (m + (m' - m)) with m'.
-apply Rle_lt_trans with (m + eps / 2).
-unfold m' in |- *; apply Rmin_l.
-apply Rplus_lt_compat_l; apply Rmult_lt_reg_l with 2.
-prove_sup0.
-unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; pattern (pos eps) at 1 in |- *; rewrite <- Rplus_0_r;
- rewrite double; apply Rplus_lt_compat_l; apply (cond_pos eps).
-discrR.
-ring.
-unfold Db in |- *; right; reflexivity.
-unfold family_finite in |- *; unfold domain_finite in |- *;
- unfold covering_finite in H12; elim H12; clear H12; 
- intros; unfold family_finite in H13; unfold domain_finite in H13; 
- elim H13; clear H13; intros l H13; exists (cons y0 l); 
- intro; split.
-intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
- clear H13; intros; case (Req_dec x0 y0); intro.
-simpl in |- *; left; apply H16.
-simpl in |- *; right; apply H13; simpl in |- *;
- unfold intersection_domain in |- *; unfold Db in H14; 
- decompose [and or] H14.
-split; assumption.
-elim H16; assumption.
-intro; simpl in H14; elim H14; intro; simpl in |- *;
- unfold intersection_domain in |- *.
-split.
-apply (cond_fam f0); rewrite H15; exists m; apply H6.
-unfold Db in |- *; right; assumption.
-elim (H13 x0); intros _ H16.
-assert (H17 := H16 H15).
-simpl in H17.
-unfold intersection_domain in H17.
-split.
-elim H17; intros; assumption.
-unfold Db in |- *; left; elim H17; intros; assumption.
-elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro.
-assumption.
-elim H3; intros; cut (is_upper_bound A (m - eps)).
-intro; assert (H13 := H11 _ H12); cut (m - eps < m).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H14)).
-pattern m at 2 in |- *; rewrite <- Rplus_0_r; unfold Rminus in |- *;
- apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_involutive;
- rewrite Ropp_0; apply (cond_pos eps).
-set (P := fun n:R => A n /\ m - eps < n <= m);
- assert (H12 := not_ex_all_not _ P H9); unfold P in H12;
- unfold is_upper_bound in |- *; intros;
- assert (H14 := not_and_or _ _ (H12 x)); elim H14; 
- intro.
-elim H15; apply H13.
-elim (not_and_or _ _ H15); intro.
-case (Rle_dec x (m - eps)); intro.
-assumption.
-elim H16; auto with real.
-unfold is_upper_bound in H10; assert (H17 := H10 x H13); elim H16; apply H17.
-elim H3; clear H3; intros.
-unfold is_upper_bound in H3.
-split.
-apply (H3 _ H0).
-apply (H4 b); unfold is_upper_bound in |- *; intros; unfold A in H5; elim H5;
- clear H5; intros H5 _; elim H5; clear H5; intros _ H5; 
- apply H5.
-exists a; apply H0.
-unfold bound in |- *; exists b; unfold is_upper_bound in |- *; intros;
- unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; 
- clear H1; intros _ H1; apply H1.
-unfold A in |- *; split.
-split; [ right; reflexivity | apply r ].
-unfold covering_open_set in H; elim H; clear H; intros; unfold covering in H;
- cut (a <= a <= b).
-intro; elim (H _ H1); intros y0 H2; set (D' := fun x:R => x = y0); exists D';
- unfold covering_finite in |- *; split.
-unfold covering in |- *; simpl in |- *; intros; cut (x = a).
-intro; exists y0; split.
-rewrite H4; apply H2.
-unfold D' in |- *; reflexivity.
-elim H3; intros; apply Rle_antisym; assumption.
-unfold family_finite in |- *; unfold domain_finite in |- *;
- exists (cons y0 nil); intro; split.
-simpl in |- *; unfold intersection_domain in |- *; intro; elim H3; clear H3;
- intros; unfold D' in H4; left; apply H4.
-simpl in |- *; unfold intersection_domain in |- *; intro; elim H3; intro.
-split; [ rewrite H4; apply (cond_fam f0); exists a; apply H2 | apply H4 ].
-elim H4.
-split; [ right; reflexivity | apply r ].
-apply compact_eqDom with (fun c:R => False).
-apply compact_EMP.
-unfold eq_Dom in |- *; split.
-unfold included in |- *; intros; elim H.
-unfold included in |- *; intros; elim H; clear H; intros;
- assert (H1 := Rle_trans _ _ _ H H0); elim n; apply H1.
+Proof.
+  intros; case (Rle_dec a b); intro.
+  unfold compact in |- *; intros;
+    set
+      (A :=
+        fun x:R =>
+          a <= x <= b /\
+          (exists D : R -> Prop,
+            covering_finite (fun c:R => a <= c <= x) (subfamily f0 D)));
+      cut (A a).
+  intro; cut (bound A).
+  intro; cut (exists a0 : R, A a0).
+  intro; assert (H3 := completeness A H1 H2); elim H3; clear H3; intros m H3;
+    unfold is_lub in H3; cut (a <= m <= b).
+  intro; unfold covering_open_set in H; elim H; clear H; intros;
+    unfold covering in H; assert (H6 := H m H4); elim H6; 
+      clear H6; intros y0 H6; unfold family_open_set in H5; 
+        assert (H7 := H5 y0); unfold open_set in H7; assert (H8 := H7 m H6);
+          unfold neighbourhood in H8; elim H8; clear H8; intros eps H8;
+            cut (exists x : R, A x /\ m - eps < x <= m).
+  intro; elim H9; clear H9; intros x H9; elim H9; clear H9; intros;
+    case (Req_dec m b); intro.
+  rewrite H11 in H10; rewrite H11 in H8; unfold A in H9; elim H9; clear H9;
+    intros; elim H12; clear H12; intros Dx H12;
+      set (Db := fun x:R => Dx x \/ x = y0); exists Db;
+        unfold covering_finite in |- *; split.
+  unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
+    intros; unfold covering in H12; case (Rle_dec x0 x); 
+      intro.
+  cut (a <= x0 <= x).
+  intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
+    simpl in H16; simpl in |- *; unfold Db in |- *; elim H16; 
+      clear H16; intros; split; [ apply H16 | left; apply H17 ].
+  split.
+  elim H14; intros; assumption.
+  assumption.
+  exists y0; simpl in |- *; split.
+  apply H8; unfold disc in |- *; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
+    rewrite Rabs_right.
+  apply Rlt_trans with (b - x).
+  unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
+    auto with real.
+  elim H10; intros H15 _; apply Rplus_lt_reg_r with (x - eps);
+    replace (x - eps + (b - x)) with (b - eps);
+    [ replace (x - eps + eps) with x; [ apply H15 | ring ] | ring ].
+  apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15.
+  unfold Db in |- *; right; reflexivity.
+  unfold family_finite in |- *; unfold domain_finite in |- *;
+    unfold covering_finite in H12; elim H12; clear H12; 
+      intros; unfold family_finite in H13; unfold domain_finite in H13; 
+        elim H13; clear H13; intros l H13; exists (cons y0 l); 
+          intro; split.
+  intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
+    clear H13; intros; case (Req_dec x0 y0); intro.
+  simpl in |- *; left; apply H16.
+  simpl in |- *; right; apply H13.
+  simpl in |- *; unfold intersection_domain in |- *; unfold Db in H14;
+    decompose [and or] H14.
+  split; assumption.
+  elim H16; assumption.
+  intro; simpl in H14; elim H14; intro; simpl in |- *;
+    unfold intersection_domain in |- *.
+  split.
+  apply (cond_fam f0); rewrite H15; exists m; apply H6.
+  unfold Db in |- *; right; assumption.
+  simpl in |- *; unfold intersection_domain in |- *; elim (H13 x0).
+  intros _ H16; assert (H17 := H16 H15); simpl in H17;
+    unfold intersection_domain in H17; split.
+  elim H17; intros; assumption.
+  unfold Db in |- *; left; elim H17; intros; assumption.
+  set (m' := Rmin (m + eps / 2) b); cut (A m').
+  intro; elim H3; intros; unfold is_upper_bound in H13;
+    assert (H15 := H13 m' H12); cut (m < m').
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H15 H16)).
+  unfold m' in |- *; unfold Rmin in |- *; case (Rle_dec (m + eps / 2) b); intro.
+  pattern m at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim H4; intros.
+  elim H17; intro.
+  assumption.
+  elim H11; assumption.
+  unfold A in |- *; split.
+  split.
+  apply Rle_trans with m.
+  elim H4; intros; assumption.
+  unfold m' in |- *; unfold Rmin in |- *; case (Rle_dec (m + eps / 2) b); intro.
+  pattern m at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+    unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim H4; intros.
+  elim H13; intro.
+  assumption.
+  elim H11; assumption.
+  unfold m' in |- *; apply Rmin_r.
+  unfold A in H9; elim H9; clear H9; intros; elim H12; clear H12; intros Dx H12;
+    set (Db := fun x:R => Dx x \/ x = y0); exists Db;
+      unfold covering_finite in |- *; split.
+  unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
+    intros; unfold covering in H12; case (Rle_dec x0 x); 
+      intro.
+  cut (a <= x0 <= x).
+  intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
+    simpl in H16; simpl in |- *; unfold Db in |- *.
+  elim H16; clear H16; intros; split; [ apply H16 | left; apply H17 ].
+  elim H14; intros; split; assumption.
+  exists y0; simpl in |- *; split.
+  apply H8; unfold disc in |- *; unfold Rabs in |- *; case (Rcase_abs (x0 - m));
+    intro.
+  rewrite Ropp_minus_distr; apply Rlt_trans with (m - x).
+  unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
+    auto with real.
+  apply Rplus_lt_reg_r with (x - eps);
+    replace (x - eps + (m - x)) with (m - eps).
+  replace (x - eps + eps) with x.
+  elim H10; intros; assumption.
+  ring.
+  ring.
+  apply Rle_lt_trans with (m' - m).
+  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- m));
+    apply Rplus_le_compat_l; elim H14; intros; assumption.
+  apply Rplus_lt_reg_r with m; replace (m + (m' - m)) with m'.
+  apply Rle_lt_trans with (m + eps / 2).
+  unfold m' in |- *; apply Rmin_l.
+  apply Rplus_lt_compat_l; apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; pattern (pos eps) at 1 in |- *; rewrite <- Rplus_0_r;
+    rewrite double; apply Rplus_lt_compat_l; apply (cond_pos eps).
+  discrR.
+  ring.
+  unfold Db in |- *; right; reflexivity.
+  unfold family_finite in |- *; unfold domain_finite in |- *;
+    unfold covering_finite in H12; elim H12; clear H12; 
+      intros; unfold family_finite in H13; unfold domain_finite in H13; 
+        elim H13; clear H13; intros l H13; exists (cons y0 l); 
+          intro; split.
+  intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
+    clear H13; intros; case (Req_dec x0 y0); intro.
+  simpl in |- *; left; apply H16.
+  simpl in |- *; right; apply H13; simpl in |- *;
+    unfold intersection_domain in |- *; unfold Db in H14; 
+      decompose [and or] H14.
+  split; assumption.
+  elim H16; assumption.
+  intro; simpl in H14; elim H14; intro; simpl in |- *;
+    unfold intersection_domain in |- *.
+  split.
+  apply (cond_fam f0); rewrite H15; exists m; apply H6.
+  unfold Db in |- *; right; assumption.
+  elim (H13 x0); intros _ H16.
+  assert (H17 := H16 H15).
+  simpl in H17.
+  unfold intersection_domain in H17.
+  split.
+  elim H17; intros; assumption.
+  unfold Db in |- *; left; elim H17; intros; assumption.
+  elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro.
+  assumption.
+  elim H3; intros; cut (is_upper_bound A (m - eps)).
+  intro; assert (H13 := H11 _ H12); cut (m - eps < m).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H14)).
+  pattern m at 2 in |- *; rewrite <- Rplus_0_r; unfold Rminus in |- *;
+    apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_involutive;
+      rewrite Ropp_0; apply (cond_pos eps).
+  set (P := fun n:R => A n /\ m - eps < n <= m);
+    assert (H12 := not_ex_all_not _ P H9); unfold P in H12;
+      unfold is_upper_bound in |- *; intros;
+        assert (H14 := not_and_or _ _ (H12 x)); elim H14; 
+          intro.
+  elim H15; apply H13.
+  elim (not_and_or _ _ H15); intro.
+  case (Rle_dec x (m - eps)); intro.
+  assumption.
+  elim H16; auto with real.
+  unfold is_upper_bound in H10; assert (H17 := H10 x H13); elim H16; apply H17.
+  elim H3; clear H3; intros.
+  unfold is_upper_bound in H3.
+  split.
+  apply (H3 _ H0).
+  apply (H4 b); unfold is_upper_bound in |- *; intros; unfold A in H5; elim H5;
+    clear H5; intros H5 _; elim H5; clear H5; intros _ H5; 
+      apply H5.
+  exists a; apply H0.
+  unfold bound in |- *; exists b; unfold is_upper_bound in |- *; intros;
+    unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; 
+      clear H1; intros _ H1; apply H1.
+  unfold A in |- *; split.
+  split; [ right; reflexivity | apply r ].
+  unfold covering_open_set in H; elim H; clear H; intros; unfold covering in H;
+    cut (a <= a <= b).
+  intro; elim (H _ H1); intros y0 H2; set (D' := fun x:R => x = y0); exists D';
+    unfold covering_finite in |- *; split.
+  unfold covering in |- *; simpl in |- *; intros; cut (x = a).
+  intro; exists y0; split.
+  rewrite H4; apply H2.
+  unfold D' in |- *; reflexivity.
+  elim H3; intros; apply Rle_antisym; assumption.
+  unfold family_finite in |- *; unfold domain_finite in |- *;
+    exists (cons y0 nil); intro; split.
+  simpl in |- *; unfold intersection_domain in |- *; intro; elim H3; clear H3;
+    intros; unfold D' in H4; left; apply H4.
+  simpl in |- *; unfold intersection_domain in |- *; intro; elim H3; intro.
+  split; [ rewrite H4; apply (cond_fam f0); exists a; apply H2 | apply H4 ].
+  elim H4.
+  split; [ right; reflexivity | apply r ].
+  apply compact_eqDom with (fun c:R => False).
+  apply compact_EMP.
+  unfold eq_Dom in |- *; split.
+  unfold included in |- *; intros; elim H.
+  unfold included in |- *; intros; elim H; clear H; intros;
+    assert (H1 := Rle_trans _ _ _ H H0); elim n; apply H1.
 Qed.
 
 Lemma compact_P4 :
- forall X F:R -> Prop, compact X -> closed_set F -> included F X -> compact F.
-unfold compact in |- *; intros; elim (classic (exists z : R, F z));
- intro Hyp_F_NE.
-set (D := ind f0); set (g := f f0); unfold closed_set in H0.
-set (g' := fun x y:R => f0 x y \/ complementary F y /\ D x).
-set (D' := D).
-cut (forall x:R, (exists y : R, g' x y) -> D' x).
-intro; set (f' := mkfamily D' g' H3); cut (covering_open_set X f').
-intro; elim (H _ H4); intros DX H5; exists DX.
-unfold covering_finite in |- *; unfold covering_finite in H5; elim H5;
- clear H5; intros.
-split.
-unfold covering in |- *; unfold covering in H5; intros.
-elim (H5 _ (H1 _ H7)); intros y0 H8; exists y0; simpl in H8; simpl in |- *;
- elim H8; clear H8; intros.
-split.
-unfold g' in H8; elim H8; intro.
-apply H10.
-elim H10; intros H11 _; unfold complementary in H11; elim H11; apply H7.
-apply H9.
-unfold family_finite in |- *; unfold domain_finite in |- *;
- unfold family_finite in H6; unfold domain_finite in H6; 
- elim H6; clear H6; intros l H6; exists l; intro; assert (H7 := H6 x);
- elim H7; clear H7; intros.
-split.
-intro; apply H7; simpl in |- *; unfold intersection_domain in |- *;
- simpl in H9; unfold intersection_domain in H9; unfold D' in |- *; 
- apply H9.
-intro; assert (H10 := H8 H9); simpl in H10; unfold intersection_domain in H10;
- simpl in |- *; unfold intersection_domain in |- *; 
- unfold D' in H10; apply H10.
-unfold covering_open_set in |- *; unfold covering_open_set in H2; elim H2;
- clear H2; intros.
-split.
-unfold covering in |- *; unfold covering in H2; intros.
-elim (classic (F x)); intro.
-elim (H2 _ H6); intros y0 H7; exists y0; simpl in |- *; unfold g' in |- *;
- left; assumption.
-cut (exists z : R, D z).
-intro; elim H7; clear H7; intros x0 H7; exists x0; simpl in |- *;
- unfold g' in |- *; right.
-split.
-unfold complementary in |- *; apply H6.
-apply H7.
-elim Hyp_F_NE; intros z0 H7.
-assert (H8 := H2 _ H7).
-elim H8; clear H8; intros t H8; exists t; apply (cond_fam f0); exists z0;
- apply H8.
-unfold family_open_set in |- *; intro; simpl in |- *; unfold g' in |- *;
- elim (classic (D x)); intro.
-apply open_set_P6 with (union_domain (f0 x) (complementary F)).
-apply open_set_P2.
-unfold family_open_set in H4; apply H4.
-apply H0.
-unfold eq_Dom in |- *; split.
-unfold included, union_domain, complementary in |- *; intros.
-elim H6; intro; [ left; apply H7 | right; split; assumption ].
-unfold included, union_domain, complementary in |- *; intros.
-elim H6; intro; [ left; apply H7 | right; elim H7; intros; apply H8 ].
-apply open_set_P6 with (f0 x).
-unfold family_open_set in H4; apply H4.
-unfold eq_Dom in |- *; split.
-unfold included, complementary in |- *; intros; left; apply H6.
-unfold included, complementary in |- *; intros.
-elim H6; intro.
-apply H7.
-elim H7; intros _ H8; elim H5; apply H8.
-intros; elim H3; intros y0 H4; unfold g' in H4; elim H4; intro.
-apply (cond_fam f0); exists y0; apply H5.
-elim H5; clear H5; intros _ H5; apply H5.
+  forall X F:R -> Prop, compact X -> closed_set F -> included F X -> compact F.
+Proof.
+  unfold compact in |- *; intros; elim (classic (exists z : R, F z));
+    intro Hyp_F_NE.
+  set (D := ind f0); set (g := f f0); unfold closed_set in H0.
+  set (g' := fun x y:R => f0 x y \/ complementary F y /\ D x).
+  set (D' := D).
+  cut (forall x:R, (exists y : R, g' x y) -> D' x).
+  intro; set (f' := mkfamily D' g' H3); cut (covering_open_set X f').
+  intro; elim (H _ H4); intros DX H5; exists DX.
+  unfold covering_finite in |- *; unfold covering_finite in H5; elim H5;
+    clear H5; intros.
+  split.
+  unfold covering in |- *; unfold covering in H5; intros.
+  elim (H5 _ (H1 _ H7)); intros y0 H8; exists y0; simpl in H8; simpl in |- *;
+    elim H8; clear H8; intros.
+  split.
+  unfold g' in H8; elim H8; intro.
+  apply H10.
+  elim H10; intros H11 _; unfold complementary in H11; elim H11; apply H7.
+  apply H9.
+  unfold family_finite in |- *; unfold domain_finite in |- *;
+    unfold family_finite in H6; unfold domain_finite in H6; 
+      elim H6; clear H6; intros l H6; exists l; intro; assert (H7 := H6 x);
+        elim H7; clear H7; intros.
+  split.
+  intro; apply H7; simpl in |- *; unfold intersection_domain in |- *;
+    simpl in H9; unfold intersection_domain in H9; unfold D' in |- *; 
+      apply H9.
+  intro; assert (H10 := H8 H9); simpl in H10; unfold intersection_domain in H10;
+    simpl in |- *; unfold intersection_domain in |- *; 
+      unfold D' in H10; apply H10.
+  unfold covering_open_set in |- *; unfold covering_open_set in H2; elim H2;
+    clear H2; intros.
+  split.
+  unfold covering in |- *; unfold covering in H2; intros.
+  elim (classic (F x)); intro.
+  elim (H2 _ H6); intros y0 H7; exists y0; simpl in |- *; unfold g' in |- *;
+    left; assumption.
+  cut (exists z : R, D z).
+  intro; elim H7; clear H7; intros x0 H7; exists x0; simpl in |- *;
+    unfold g' in |- *; right.
+  split.
+  unfold complementary in |- *; apply H6.
+  apply H7.
+  elim Hyp_F_NE; intros z0 H7.
+  assert (H8 := H2 _ H7).
+  elim H8; clear H8; intros t H8; exists t; apply (cond_fam f0); exists z0;
+    apply H8.
+  unfold family_open_set in |- *; intro; simpl in |- *; unfold g' in |- *;
+    elim (classic (D x)); intro.
+  apply open_set_P6 with (union_domain (f0 x) (complementary F)).
+  apply open_set_P2.
+  unfold family_open_set in H4; apply H4.
+  apply H0.
+  unfold eq_Dom in |- *; split.
+  unfold included, union_domain, complementary in |- *; intros.
+  elim H6; intro; [ left; apply H7 | right; split; assumption ].
+  unfold included, union_domain, complementary in |- *; intros.
+  elim H6; intro; [ left; apply H7 | right; elim H7; intros; apply H8 ].
+  apply open_set_P6 with (f0 x).
+  unfold family_open_set in H4; apply H4.
+  unfold eq_Dom in |- *; split.
+  unfold included, complementary in |- *; intros; left; apply H6.
+  unfold included, complementary in |- *; intros.
+  elim H6; intro.
+  apply H7.
+  elim H7; intros _ H8; elim H5; apply H8.
+  intros; elim H3; intros y0 H4; unfold g' in H4; elim H4; intro.
+  apply (cond_fam f0); exists y0; apply H5.
+  elim H5; clear H5; intros _ H5; apply H5.
 (* Cas ou F est l'ensemble vide *)
-cut (compact F).
-intro; apply (H3 f0 H2).
-apply compact_eqDom with (fun _:R => False).
-apply compact_EMP.
-unfold eq_Dom in |- *; split.
-unfold included in |- *; intros; elim H3.
-assert (H3 := not_ex_all_not _ _ Hyp_F_NE); unfold included in |- *; intros;
- elim (H3 x); apply H4.
+  cut (compact F).
+  intro; apply (H3 f0 H2).
+  apply compact_eqDom with (fun _:R => False).
+  apply compact_EMP.
+  unfold eq_Dom in |- *; split.
+  unfold included in |- *; intros; elim H3.
+  assert (H3 := not_ex_all_not _ _ Hyp_F_NE); unfold included in |- *; intros;
+    elim (H3 x); apply H4.
 Qed.
 
 (**********)
 Lemma compact_P5 : forall X:R -> Prop, closed_set X -> bounded X -> compact X.
-intros; unfold bounded in H0.
-elim H0; clear H0; intros m H0.
-elim H0; clear H0; intros M H0.
-assert (H1 := compact_P3 m M).
-apply (compact_P4 (fun c:R => m <= c <= M) X H1 H H0).
+Proof.
+  intros; unfold bounded in H0.
+  elim H0; clear H0; intros m H0.
+  elim H0; clear H0; intros M H0.
+  assert (H1 := compact_P3 m M).
+  apply (compact_P4 (fun c:R => m <= c <= M) X H1 H H0).
 Qed.
 
 (**********)
 Lemma compact_carac :
- forall X:R -> Prop, compact X <-> closed_set X /\ bounded X.
-intro; split.
-intro; split; [ apply (compact_P2 _ H) | apply (compact_P1 _ H) ].
-intro; elim H; clear H; intros; apply (compact_P5 _ H H0).
+  forall X:R -> Prop, compact X <-> closed_set X /\ bounded X.
+Proof.
+  intro; split.
+  intro; split; [ apply (compact_P2 _ H) | apply (compact_P1 _ H) ].
+  intro; elim H; clear H; intros; apply (compact_P5 _ H H0).
 Qed.
 
 Definition image_dir (f:R -> R) (D:R -> Prop) (x:R) : Prop :=
-   exists y : R, x = f y /\ D y.
+  exists y : R, x = f y /\ D y.
 
 (**********)
 Lemma continuity_compact :
- forall (f:R -> R) (X:R -> Prop),
-   (forall x:R, continuity_pt f x) -> compact X -> compact (image_dir f X).
-unfold compact in |- *; intros; unfold covering_open_set in H1.
-elim H1; clear H1; intros.
-set (D := ind f1).
-set (g := fun x y:R => image_rec f0 (f1 x) y).
-cut (forall x:R, (exists y : R, g x y) -> D x).
-intro; set (f' := mkfamily D g H3).
-cut (covering_open_set X f').
-intro; elim (H0 f' H4); intros D' H5; exists D'.
-unfold covering_finite in H5; elim H5; clear H5; intros;
- unfold covering_finite in |- *; split.
-unfold covering, image_dir in |- *; simpl in |- *; unfold covering in H5;
- intros; elim H7; intros y H8; elim H8; intros; assert (H11 := H5 _ H10);
- simpl in H11; elim H11; intros z H12; exists z; unfold g in H12;
- unfold image_rec in H12; rewrite H9; apply H12.
-unfold family_finite in H6; unfold domain_finite in H6;
- unfold family_finite in |- *; unfold domain_finite in |- *; 
- elim H6; intros l H7; exists l; intro; elim (H7 x); 
- intros; split; intro.
-apply H8; simpl in H10; simpl in |- *; apply H10.
-apply (H9 H10).
-unfold covering_open_set in |- *; split.
-unfold covering in |- *; intros; simpl in |- *; unfold covering in H1;
- unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *; 
- apply H1.
-exists x; split; [ reflexivity | apply H4 ].
-unfold family_open_set in |- *; unfold family_open_set in H2; intro;
- simpl in |- *; unfold g in |- *;
- cut ((fun y:R => image_rec f0 (f1 x) y) = image_rec f0 (f1 x)).
-intro; rewrite H4.
-apply (continuity_P2 f0 (f1 x) H (H2 x)).
-reflexivity.
-intros; apply (cond_fam f1); unfold g in H3; unfold image_rec in H3; elim H3;
- intros; exists (f0 x0); apply H4.
+  forall (f:R -> R) (X:R -> Prop),
+    (forall x:R, continuity_pt f x) -> compact X -> compact (image_dir f X).
+Proof.
+  unfold compact in |- *; intros; unfold covering_open_set in H1.
+  elim H1; clear H1; intros.
+  set (D := ind f1).
+  set (g := fun x y:R => image_rec f0 (f1 x) y).
+  cut (forall x:R, (exists y : R, g x y) -> D x).
+  intro; set (f' := mkfamily D g H3).
+  cut (covering_open_set X f').
+  intro; elim (H0 f' H4); intros D' H5; exists D'.
+  unfold covering_finite in H5; elim H5; clear H5; intros;
+    unfold covering_finite in |- *; split.
+  unfold covering, image_dir in |- *; simpl in |- *; unfold covering in H5;
+    intros; elim H7; intros y H8; elim H8; intros; assert (H11 := H5 _ H10);
+      simpl in H11; elim H11; intros z H12; exists z; unfold g in H12;
+        unfold image_rec in H12; rewrite H9; apply H12.
+  unfold family_finite in H6; unfold domain_finite in H6;
+    unfold family_finite in |- *; unfold domain_finite in |- *; 
+      elim H6; intros l H7; exists l; intro; elim (H7 x); 
+        intros; split; intro.
+  apply H8; simpl in H10; simpl in |- *; apply H10.
+  apply (H9 H10).
+  unfold covering_open_set in |- *; split.
+  unfold covering in |- *; intros; simpl in |- *; unfold covering in H1;
+    unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *; 
+      apply H1.
+  exists x; split; [ reflexivity | apply H4 ].
+  unfold family_open_set in |- *; unfold family_open_set in H2; intro;
+    simpl in |- *; unfold g in |- *;
+      cut ((fun y:R => image_rec f0 (f1 x) y) = image_rec f0 (f1 x)).
+  intro; rewrite H4.
+  apply (continuity_P2 f0 (f1 x) H (H2 x)).
+  reflexivity.
+  intros; apply (cond_fam f1); unfold g in H3; unfold image_rec in H3; elim H3;
+    intros; exists (f0 x0); apply H4.
 Qed.
 
 Lemma Rlt_Rminus : forall a b:R, a < b -> 0 < b - a.
-intros; apply Rplus_lt_reg_r with a; rewrite Rplus_0_r;
- replace (a + (b - a)) with b; [ assumption | ring ].
+Proof.
+  intros; apply Rplus_lt_reg_r with a; rewrite Rplus_0_r;
+    replace (a + (b - a)) with b; [ assumption | ring ].
 Qed.
 
 Lemma prolongement_C0 :
- forall (f:R -> R) (a b:R),
-   a <= b ->
-   (forall c:R, a <= c <= b -> continuity_pt f c) ->
+  forall (f:R -> R) (a b:R),
+    a <= b ->
+    (forall c:R, a <= c <= b -> continuity_pt f c) ->
     exists g : R -> R,
-     continuity g /\ (forall c:R, a <= c <= b -> g c = f c).
-intros; elim H; intro.
-set
- (h :=
-  fun x:R =>
-    match Rle_dec x a with
-    | left _ => f0 a
-    | right _ =>
-        match Rle_dec x b with
-        | left _ => f0 x
-        | right _ => f0 b
-        end
-    end).
-assert (H2 : 0 < b - a).
-apply Rlt_Rminus; assumption.
-exists h; split.
-unfold continuity in |- *; intro; case (Rtotal_order x a); intro.
-unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; unfold R_dist in |- *; intros; exists (a - x); 
- split.
-change (0 < a - x) in |- *; apply Rlt_Rminus; assumption.
-intros; elim H5; clear H5; intros _ H5; unfold h in |- *.
-case (Rle_dec x a); intro.
-case (Rle_dec x0 a); intro.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-elim n; left; apply Rplus_lt_reg_r with (- x);
- do 2 rewrite (Rplus_comm (- x)); apply Rle_lt_trans with (Rabs (x0 - x)).
-apply RRle_abs.
-assumption.
-elim n; left; assumption.
-elim H3; intro.
-assert (H5 : a <= a <= b).
-split; [ right; reflexivity | left; assumption ].
-assert (H6 := H0 _ H5); unfold continuity_pt in H6; unfold continue_in in H6;
- unfold limit1_in in H6; unfold limit_in in H6; simpl in H6;
- unfold R_dist in H6; unfold continuity_pt in |- *;
- unfold continue_in in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); 
- split.
-unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
-elim H8; intros; assumption.
-change (0 < b - a) in |- *; apply Rlt_Rminus; assumption.
-intros; elim H9; clear H9; intros _ H9; cut (x1 < b).
-intro; unfold h in |- *; case (Rle_dec x a); intro.
-case (Rle_dec x1 a); intro.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-case (Rle_dec x1 b); intro.
-elim H8; intros; apply H12; split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-red in |- *; intro; elim n; right; symmetry  in |- *; assumption.
-apply Rlt_le_trans with (Rmin x0 (b - a)).
-rewrite H4 in H9; apply H9.
-apply Rmin_l.
-elim n0; left; assumption.
-elim n; right; assumption.
-apply Rplus_lt_reg_r with (- a); do 2 rewrite (Rplus_comm (- a));
- rewrite H4 in H9; apply Rle_lt_trans with (Rabs (x1 - a)).
-apply RRle_abs.
-apply Rlt_le_trans with (Rmin x0 (b - a)).
-assumption.
-apply Rmin_r.
-case (Rtotal_order x b); intro.
-assert (H6 : a <= x <= b).
-split; left; assumption.
-assert (H7 := H0 _ H6); unfold continuity_pt in H7; unfold continue_in in H7;
- unfold limit1_in in H7; unfold limit_in in H7; simpl in H7;
- unfold R_dist in H7; unfold continuity_pt in |- *;
- unfold continue_in in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros; elim (H7 _ H8); intros; elim H9; clear H9; 
- intros.
-assert (H11 : 0 < x - a).
-apply Rlt_Rminus; assumption.
-assert (H12 : 0 < b - x).
-apply Rlt_Rminus; assumption.
-exists (Rmin x0 (Rmin (x - a) (b - x))); split.
-unfold Rmin in |- *; case (Rle_dec (x - a) (b - x)); intro.
-case (Rle_dec x0 (x - a)); intro.
-assumption.
-assumption.
-case (Rle_dec x0 (b - x)); intro.
-assumption.
-assumption.
-intros; elim H13; clear H13; intros; cut (a < x1 < b).
-intro; elim H15; clear H15; intros; unfold h in |- *; case (Rle_dec x a);
- intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
-case (Rle_dec x b); intro.
-case (Rle_dec x1 a); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H15)).
-case (Rle_dec x1 b); intro.
-apply H10; split.
-assumption.
-apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
-assumption.
-apply Rmin_l.
-elim n1; left; assumption.
-elim n0; left; assumption.
-split.
-apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
- apply Rle_lt_trans with (Rabs (x1 - x)).
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
-apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
-assumption.
-apply Rle_trans with (Rmin (x - a) (b - x)).
-apply Rmin_r.
-apply Rmin_l.
-apply Rplus_lt_reg_r with (- x); do 2 rewrite (Rplus_comm (- x));
- apply Rle_lt_trans with (Rabs (x1 - x)).
-apply RRle_abs.
-apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
-assumption.
-apply Rle_trans with (Rmin (x - a) (b - x)); apply Rmin_r.
-elim H5; intro.
-assert (H7 : a <= b <= b).
-split; [ left; assumption | right; reflexivity ].
-assert (H8 := H0 _ H7); unfold continuity_pt in H8; unfold continue_in in H8;
- unfold limit1_in in H8; unfold limit_in in H8; simpl in H8;
- unfold R_dist in H8; unfold continuity_pt in |- *;
- unfold continue_in in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); 
- split.
-unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
-elim H10; intros; assumption.
-change (0 < b - a) in |- *; apply Rlt_Rminus; assumption.
-intros; elim H11; clear H11; intros _ H11; cut (a < x1).
-intro; unfold h in |- *; case (Rle_dec x a); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
-case (Rle_dec x1 a); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H12)).
-case (Rle_dec x b); intro.
-case (Rle_dec x1 b); intro.
-rewrite H6; elim H10; intros; elim r0; intro.
-apply H14; split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-red in |- *; intro; rewrite <- H16 in H15; elim (Rlt_irrefl _ H15).
-rewrite H6 in H11; apply Rlt_le_trans with (Rmin x0 (b - a)).
-apply H11.
-apply Rmin_l.
-rewrite H15; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- assumption.
-rewrite H6; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- assumption.
-elim n1; right; assumption.
-rewrite H6 in H11; apply Ropp_lt_cancel; apply Rplus_lt_reg_r with b;
- apply Rle_lt_trans with (Rabs (x1 - b)).
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
-apply Rlt_le_trans with (Rmin x0 (b - a)).
-assumption.
-apply Rmin_r.
-unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; unfold R_dist in |- *; intros; exists (x - b); 
- split.
-change (0 < x - b) in |- *; apply Rlt_Rminus; assumption.
-intros; elim H8; clear H8; intros.
-assert (H10 : b < x0).
-apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
- apply Rle_lt_trans with (Rabs (x0 - x)).
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
-assumption.
-unfold h in |- *; case (Rle_dec x a); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
-case (Rle_dec x b); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H6)).
-case (Rle_dec x0 a); intro.
-elim (Rlt_irrefl _ (Rlt_trans _ _ _ H1 (Rlt_le_trans _ _ _ H10 r))).
-case (Rle_dec x0 b); intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10)).
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-intros; elim H3; intros; unfold h in |- *; case (Rle_dec c a); intro.
-elim r; intro.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 H6)).
-rewrite H6; reflexivity.
-case (Rle_dec c b); intro.
-reflexivity.
-elim n0; assumption.
-exists (fun _:R => f0 a); split.
-apply derivable_continuous; apply (derivable_const (f0 a)).
-intros; elim H2; intros; rewrite H1 in H3; cut (b = c).
-intro; rewrite <- H5; rewrite H1; reflexivity.
-apply Rle_antisym; assumption.
+      continuity g /\ (forall c:R, a <= c <= b -> g c = f c).
+Proof.
+  intros; elim H; intro.
+  set
+    (h :=
+      fun x:R =>
+        match Rle_dec x a with
+          | left _ => f0 a
+          | right _ =>
+            match Rle_dec x b with
+              | left _ => f0 x
+              | right _ => f0 b
+            end
+        end).
+  assert (H2 : 0 < b - a).
+  apply Rlt_Rminus; assumption.
+  exists h; split.
+  unfold continuity in |- *; intro; case (Rtotal_order x a); intro.
+  unfold continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      simpl in |- *; unfold R_dist in |- *; intros; exists (a - x); 
+        split.
+  change (0 < a - x) in |- *; apply Rlt_Rminus; assumption.
+  intros; elim H5; clear H5; intros _ H5; unfold h in |- *.
+  case (Rle_dec x a); intro.
+  case (Rle_dec x0 a); intro.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  elim n; left; apply Rplus_lt_reg_r with (- x);
+    do 2 rewrite (Rplus_comm (- x)); apply Rle_lt_trans with (Rabs (x0 - x)).
+  apply RRle_abs.
+  assumption.
+  elim n; left; assumption.
+  elim H3; intro.
+  assert (H5 : a <= a <= b).
+  split; [ right; reflexivity | left; assumption ].
+  assert (H6 := H0 _ H5); unfold continuity_pt in H6; unfold continue_in in H6;
+    unfold limit1_in in H6; unfold limit_in in H6; simpl in H6;
+      unfold R_dist in H6; unfold continuity_pt in |- *;
+        unfold continue_in in |- *; unfold limit1_in in |- *;
+          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+            intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); 
+              split.
+  unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
+  elim H8; intros; assumption.
+  change (0 < b - a) in |- *; apply Rlt_Rminus; assumption.
+  intros; elim H9; clear H9; intros _ H9; cut (x1 < b).
+  intro; unfold h in |- *; case (Rle_dec x a); intro.
+  case (Rle_dec x1 a); intro.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  case (Rle_dec x1 b); intro.
+  elim H8; intros; apply H12; split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  red in |- *; intro; elim n; right; symmetry  in |- *; assumption.
+  apply Rlt_le_trans with (Rmin x0 (b - a)).
+  rewrite H4 in H9; apply H9.
+  apply Rmin_l.
+  elim n0; left; assumption.
+  elim n; right; assumption.
+  apply Rplus_lt_reg_r with (- a); do 2 rewrite (Rplus_comm (- a));
+    rewrite H4 in H9; apply Rle_lt_trans with (Rabs (x1 - a)).
+  apply RRle_abs.
+  apply Rlt_le_trans with (Rmin x0 (b - a)).
+  assumption.
+  apply Rmin_r.
+  case (Rtotal_order x b); intro.
+  assert (H6 : a <= x <= b).
+  split; left; assumption.
+  assert (H7 := H0 _ H6); unfold continuity_pt in H7; unfold continue_in in H7;
+    unfold limit1_in in H7; unfold limit_in in H7; simpl in H7;
+      unfold R_dist in H7; unfold continuity_pt in |- *;
+        unfold continue_in in |- *; unfold limit1_in in |- *;
+          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+            intros; elim (H7 _ H8); intros; elim H9; clear H9; 
+              intros.
+  assert (H11 : 0 < x - a).
+  apply Rlt_Rminus; assumption.
+  assert (H12 : 0 < b - x).
+  apply Rlt_Rminus; assumption.
+  exists (Rmin x0 (Rmin (x - a) (b - x))); split.
+  unfold Rmin in |- *; case (Rle_dec (x - a) (b - x)); intro.
+  case (Rle_dec x0 (x - a)); intro.
+  assumption.
+  assumption.
+  case (Rle_dec x0 (b - x)); intro.
+  assumption.
+  assumption.
+  intros; elim H13; clear H13; intros; cut (a < x1 < b).
+  intro; elim H15; clear H15; intros; unfold h in |- *; case (Rle_dec x a);
+    intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
+  case (Rle_dec x b); intro.
+  case (Rle_dec x1 a); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H15)).
+  case (Rle_dec x1 b); intro.
+  apply H10; split.
+  assumption.
+  apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
+  assumption.
+  apply Rmin_l.
+  elim n1; left; assumption.
+  elim n0; left; assumption.
+  split.
+  apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
+    apply Rle_lt_trans with (Rabs (x1 - x)).
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
+  apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
+  assumption.
+  apply Rle_trans with (Rmin (x - a) (b - x)).
+  apply Rmin_r.
+  apply Rmin_l.
+  apply Rplus_lt_reg_r with (- x); do 2 rewrite (Rplus_comm (- x));
+    apply Rle_lt_trans with (Rabs (x1 - x)).
+  apply RRle_abs.
+  apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
+  assumption.
+  apply Rle_trans with (Rmin (x - a) (b - x)); apply Rmin_r.
+  elim H5; intro.
+  assert (H7 : a <= b <= b).
+  split; [ left; assumption | right; reflexivity ].
+  assert (H8 := H0 _ H7); unfold continuity_pt in H8; unfold continue_in in H8;
+    unfold limit1_in in H8; unfold limit_in in H8; simpl in H8;
+      unfold R_dist in H8; unfold continuity_pt in |- *;
+        unfold continue_in in |- *; unfold limit1_in in |- *;
+          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+            intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); 
+              split.
+  unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
+  elim H10; intros; assumption.
+  change (0 < b - a) in |- *; apply Rlt_Rminus; assumption.
+  intros; elim H11; clear H11; intros _ H11; cut (a < x1).
+  intro; unfold h in |- *; case (Rle_dec x a); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
+  case (Rle_dec x1 a); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H12)).
+  case (Rle_dec x b); intro.
+  case (Rle_dec x1 b); intro.
+  rewrite H6; elim H10; intros; elim r0; intro.
+  apply H14; split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  red in |- *; intro; rewrite <- H16 in H15; elim (Rlt_irrefl _ H15).
+  rewrite H6 in H11; apply Rlt_le_trans with (Rmin x0 (b - a)).
+  apply H11.
+  apply Rmin_l.
+  rewrite H15; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    assumption.
+  rewrite H6; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    assumption.
+  elim n1; right; assumption.
+  rewrite H6 in H11; apply Ropp_lt_cancel; apply Rplus_lt_reg_r with b;
+    apply Rle_lt_trans with (Rabs (x1 - b)).
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
+  apply Rlt_le_trans with (Rmin x0 (b - a)).
+  assumption.
+  apply Rmin_r.
+  unfold continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      simpl in |- *; unfold R_dist in |- *; intros; exists (x - b); 
+        split.
+  change (0 < x - b) in |- *; apply Rlt_Rminus; assumption.
+  intros; elim H8; clear H8; intros.
+  assert (H10 : b < x0).
+  apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
+    apply Rle_lt_trans with (Rabs (x0 - x)).
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
+  assumption.
+  unfold h in |- *; case (Rle_dec x a); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
+  case (Rle_dec x b); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H6)).
+  case (Rle_dec x0 a); intro.
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H1 (Rlt_le_trans _ _ _ H10 r))).
+  case (Rle_dec x0 b); intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10)).
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  intros; elim H3; intros; unfold h in |- *; case (Rle_dec c a); intro.
+  elim r; intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 H6)).
+  rewrite H6; reflexivity.
+  case (Rle_dec c b); intro.
+  reflexivity.
+  elim n0; assumption.
+  exists (fun _:R => f0 a); split.
+  apply derivable_continuous; apply (derivable_const (f0 a)).
+  intros; elim H2; intros; rewrite H1 in H3; cut (b = c).
+  intro; rewrite <- H5; rewrite H1; reflexivity.
+  apply Rle_antisym; assumption.
 Qed.
 
 (**********)
 Lemma continuity_ab_maj :
- forall (f:R -> R) (a b:R),
-   a <= b ->
-   (forall c:R, a <= c <= b -> continuity_pt f c) ->
+  forall (f:R -> R) (a b:R),
+    a <= b ->
+    (forall c:R, a <= c <= b -> continuity_pt f c) ->
     exists Mx : R, (forall c:R, a <= c <= b -> f c <= f Mx) /\ a <= Mx <= b.
-intros;
- cut
-  (exists g : R -> R,
-     continuity g /\ (forall c:R, a <= c <= b -> g c = f0 c)).
-intro HypProl.
-elim HypProl; intros g Hcont_eq.
-elim Hcont_eq; clear Hcont_eq; intros Hcont Heq.
-assert (H1 := compact_P3 a b).
-assert (H2 := continuity_compact g (fun c:R => a <= c <= b) Hcont H1).
-assert (H3 := compact_P2 _ H2).
-assert (H4 := compact_P1 _ H2).
-cut (bound (image_dir g (fun c:R => a <= c <= b))).
-cut (exists x : R, image_dir g (fun c:R => a <= c <= b) x).
-intros; assert (H7 := completeness _ H6 H5).
-elim H7; clear H7; intros M H7; cut (image_dir g (fun c:R => a <= c <= b) M).
-intro; unfold image_dir in H8; elim H8; clear H8; intros Mxx H8; elim H8;
- clear H8; intros; exists Mxx; split.
-intros; rewrite <- (Heq c H10); rewrite <- (Heq Mxx H9); intros;
- rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; 
- intros H7 _; unfold is_upper_bound in H7; apply H7; 
- unfold image_dir in |- *; exists c; split; [ reflexivity | apply H10 ].
-apply H9.
-elim (classic (image_dir g (fun c:R => a <= c <= b) M)); intro.
-assumption.
-cut
- (exists eps : posreal,
-    (forall y:R,
-       ~
-       intersection_domain (disc M eps)
-         (image_dir g (fun c:R => a <= c <= b)) y)).
-intro; elim H9; clear H9; intros eps H9; unfold is_lub in H7; elim H7;
- clear H7; intros;
- cut (is_upper_bound (image_dir g (fun c:R => a <= c <= b)) (M - eps)).
-intro; assert (H12 := H10 _ H11); cut (M - eps < M).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H12 H13)).
-pattern M at 2 in |- *; rewrite <- Rplus_0_r; unfold Rminus in |- *;
- apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_0;
- rewrite Ropp_involutive; apply (cond_pos eps).
-unfold is_upper_bound, image_dir in |- *; intros; cut (x <= M).
-intro; case (Rle_dec x (M - eps)); intro.
-apply r.
-elim (H9 x); unfold intersection_domain, disc, image_dir in |- *; split.
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
-apply Rplus_lt_reg_r with (x - eps);
- replace (x - eps + (M - x)) with (M - eps).
-replace (x - eps + eps) with x.
-auto with real.
-ring.
-ring.
-apply Rge_minus; apply Rle_ge; apply H12.
-apply H11.
-apply H7; apply H11.
-cut
- (exists V : R -> Prop,
-    neighbourhood V M /\
-    (forall y:R,
-       ~ intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y)).
-intro; elim H9; intros V H10; elim H10; clear H10; intros.
-unfold neighbourhood in H10; elim H10; intros del H12; exists del; intros;
- red in |- *; intro; elim (H11 y).
-unfold intersection_domain in |- *; unfold intersection_domain in H13;
- elim H13; clear H13; intros; split.
-apply (H12 _ H13).
-apply H14.
-cut (~ point_adherent (image_dir g (fun c:R => a <= c <= b)) M).
-intro; unfold point_adherent in H9.
-assert
- (H10 :=
-  not_all_ex_not _
-    (fun V:R -> Prop =>
-       neighbourhood V M ->
+Proof.
+  intros;
+    cut
+      (exists g : R -> R,
+        continuity g /\ (forall c:R, a <= c <= b -> g c = f0 c)).
+  intro HypProl.
+  elim HypProl; intros g Hcont_eq.
+  elim Hcont_eq; clear Hcont_eq; intros Hcont Heq.
+  assert (H1 := compact_P3 a b).
+  assert (H2 := continuity_compact g (fun c:R => a <= c <= b) Hcont H1).
+  assert (H3 := compact_P2 _ H2).
+  assert (H4 := compact_P1 _ H2).
+  cut (bound (image_dir g (fun c:R => a <= c <= b))).
+  cut (exists x : R, image_dir g (fun c:R => a <= c <= b) x).
+  intros; assert (H7 := completeness _ H6 H5).
+  elim H7; clear H7; intros M H7; cut (image_dir g (fun c:R => a <= c <= b) M).
+  intro; unfold image_dir in H8; elim H8; clear H8; intros Mxx H8; elim H8;
+    clear H8; intros; exists Mxx; split.
+  intros; rewrite <- (Heq c H10); rewrite <- (Heq Mxx H9); intros;
+    rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; 
+      intros H7 _; unfold is_upper_bound in H7; apply H7; 
+        unfold image_dir in |- *; exists c; split; [ reflexivity | apply H10 ].
+  apply H9.
+  elim (classic (image_dir g (fun c:R => a <= c <= b) M)); intro.
+  assumption.
+  cut
+    (exists eps : posreal,
+      (forall y:R,
+        ~
+        intersection_domain (disc M eps)
+        (image_dir g (fun c:R => a <= c <= b)) y)).
+  intro; elim H9; clear H9; intros eps H9; unfold is_lub in H7; elim H7;
+    clear H7; intros;
+      cut (is_upper_bound (image_dir g (fun c:R => a <= c <= b)) (M - eps)).
+  intro; assert (H12 := H10 _ H11); cut (M - eps < M).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H12 H13)).
+  pattern M at 2 in |- *; rewrite <- Rplus_0_r; unfold Rminus in |- *;
+    apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_0;
+      rewrite Ropp_involutive; apply (cond_pos eps).
+  unfold is_upper_bound, image_dir in |- *; intros; cut (x <= M).
+  intro; case (Rle_dec x (M - eps)); intro.
+  apply r.
+  elim (H9 x); unfold intersection_domain, disc, image_dir in |- *; split.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
+  apply Rplus_lt_reg_r with (x - eps);
+    replace (x - eps + (M - x)) with (M - eps).
+  replace (x - eps + eps) with x.
+  auto with real.
+  ring.
+  ring.
+  apply Rge_minus; apply Rle_ge; apply H12.
+  apply H11.
+  apply H7; apply H11.
+  cut
+    (exists V : R -> Prop,
+      neighbourhood V M /\
+      (forall y:R,
+        ~ intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y)).
+  intro; elim H9; intros V H10; elim H10; clear H10; intros.
+  unfold neighbourhood in H10; elim H10; intros del H12; exists del; intros;
+    red in |- *; intro; elim (H11 y).
+  unfold intersection_domain in |- *; unfold intersection_domain in H13;
+    elim H13; clear H13; intros; split.
+  apply (H12 _ H13).
+  apply H14.
+  cut (~ point_adherent (image_dir g (fun c:R => a <= c <= b)) M).
+  intro; unfold point_adherent in H9.
+  assert
+    (H10 :=
+      not_all_ex_not _
+      (fun V:R -> Prop =>
+        neighbourhood V M ->
         exists y : R,
-         intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y) H9).
-elim H10; intros V0 H11; exists V0; assert (H12 := imply_to_and _ _ H11);
- elim H12; clear H12; intros.
-split.
-apply H12.
-apply (not_ex_all_not _ _ H13).
-red in |- *; intro; cut (adherence (image_dir g (fun c:R => a <= c <= b)) M).
-intro; elim (closed_set_P1 (image_dir g (fun c:R => a <= c <= b)));
- intros H11 _; assert (H12 := H11 H3).
-elim H8.
-unfold eq_Dom in H12; elim H12; clear H12; intros.
-apply (H13 _ H10).
-apply H9.
-exists (g a); unfold image_dir in |- *; exists a; split.
-reflexivity.
-split; [ right; reflexivity | apply H ].
-unfold bound in |- *; unfold bounded in H4; elim H4; clear H4; intros m H4;
- elim H4; clear H4; intros M H4; exists M; unfold is_upper_bound in |- *;
- intros; elim (H4 _ H5); intros _ H6; apply H6.
-apply prolongement_C0; assumption.
+          intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y) H9).
+  elim H10; intros V0 H11; exists V0; assert (H12 := imply_to_and _ _ H11);
+    elim H12; clear H12; intros.
+  split.
+  apply H12.
+  apply (not_ex_all_not _ _ H13).
+  red in |- *; intro; cut (adherence (image_dir g (fun c:R => a <= c <= b)) M).
+  intro; elim (closed_set_P1 (image_dir g (fun c:R => a <= c <= b)));
+    intros H11 _; assert (H12 := H11 H3).
+  elim H8.
+  unfold eq_Dom in H12; elim H12; clear H12; intros.
+  apply (H13 _ H10).
+  apply H9.
+  exists (g a); unfold image_dir in |- *; exists a; split.
+  reflexivity.
+  split; [ right; reflexivity | apply H ].
+  unfold bound in |- *; unfold bounded in H4; elim H4; clear H4; intros m H4;
+    elim H4; clear H4; intros M H4; exists M; unfold is_upper_bound in |- *;
+      intros; elim (H4 _ H5); intros _ H6; apply H6.
+  apply prolongement_C0; assumption.
 Qed.
 
 (**********)
 Lemma continuity_ab_min :
- forall (f:R -> R) (a b:R),
-   a <= b ->
-   (forall c:R, a <= c <= b -> continuity_pt f c) ->
+  forall (f:R -> R) (a b:R),
+    a <= b ->
+    (forall c:R, a <= c <= b -> continuity_pt f c) ->
     exists mx : R, (forall c:R, a <= c <= b -> f mx <= f c) /\ a <= mx <= b.
-intros.
-cut (forall c:R, a <= c <= b -> continuity_pt (- f0) c).
-intro; assert (H2 := continuity_ab_maj (- f0)%F a b H H1); elim H2;
- intros x0 H3; exists x0; intros; split.
-intros; rewrite <- (Ropp_involutive (f0 x0));
- rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; 
- elim H3; intros; unfold opp_fct in H5; apply H5; apply H4.
-elim H3; intros; assumption.
-intros.
-assert (H2 := H0 _ H1).
-apply (continuity_pt_opp _ _ H2).
+Proof.
+  intros.
+  cut (forall c:R, a <= c <= b -> continuity_pt (- f0) c).
+  intro; assert (H2 := continuity_ab_maj (- f0)%F a b H H1); elim H2;
+    intros x0 H3; exists x0; intros; split.
+  intros; rewrite <- (Ropp_involutive (f0 x0));
+    rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; 
+      elim H3; intros; unfold opp_fct in H5; apply H5; apply H4.
+  elim H3; intros; assumption.
+  intros.
+  assert (H2 := H0 _ H1).
+  apply (continuity_pt_opp _ _ H2).
 Qed.
 
 
 (********************************************************)
-(*         Proof of Bolzano-Weierstrass theorem         *)
+(** *      Proof of Bolzano-Weierstrass theorem         *)
 (********************************************************)
 
 Definition ValAdh (un:nat -> R) (x:R) : Prop :=
@@ -1280,66 +1319,69 @@ Definition intersection_family (f:family) (x:R) : Prop :=
   forall y:R, ind f y -> f y x.
 
 Lemma ValAdh_un_exists :
- forall (un:nat -> R) (D:=fun x:R =>  exists n : nat, x = INR n)
-   (f:=
-    fun x:R =>
-      adherence
+  forall (un:nat -> R) (D:=fun x:R =>  exists n : nat, x = INR n)
+    (f:=
+      fun x:R =>
+        adherence
         (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x))
-   (x:R), (exists y : R, f x y) -> D x.
-intros; elim H; intros; unfold f in H0; unfold adherence in H0;
- unfold point_adherent in H0;
- assert (H1 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0).
-unfold neighbourhood, disc in |- *; exists (mkposreal _ Rlt_0_1);
- unfold included in |- *; trivial.
-elim (H0 _ H1); intros; unfold intersection_domain in H2; elim H2; intros;
- elim H4; intros; apply H6.
+    (x:R), (exists y : R, f x y) -> D x.
+Proof.
+  intros; elim H; intros; unfold f in H0; unfold adherence in H0;
+    unfold point_adherent in H0;
+      assert (H1 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0).
+  unfold neighbourhood, disc in |- *; exists (mkposreal _ Rlt_0_1);
+    unfold included in |- *; trivial.
+  elim (H0 _ H1); intros; unfold intersection_domain in H2; elim H2; intros;
+    elim H4; intros; apply H6.
 Qed.
 
 Definition ValAdh_un (un:nat -> R) : R -> Prop :=
   let D := fun x:R =>  exists n : nat, x = INR n in
-  let f :=
-    fun x:R =>
-      adherence
+    let f :=
+      fun x:R =>
+        adherence
         (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x) in
-  intersection_family (mkfamily D f (ValAdh_un_exists un)).
+        intersection_family (mkfamily D f (ValAdh_un_exists un)).
 
 Lemma ValAdh_un_prop :
- forall (un:nat -> R) (x:R), ValAdh un x <-> ValAdh_un un x.
-intros; split; intro.
-unfold ValAdh in H; unfold ValAdh_un in |- *;
- unfold intersection_family in |- *; simpl in |- *; 
- intros; elim H0; intros N H1; unfold adherence in |- *;
- unfold point_adherent in |- *; intros; elim (H V N H2); 
- intros; exists (un x0); unfold intersection_domain in |- *; 
- elim H3; clear H3; intros; split.
-assumption.
-split.
-exists x0; split; [ reflexivity | rewrite H1; apply (le_INR _ _ H3) ].
-exists N; assumption.
-unfold ValAdh in |- *; intros; unfold ValAdh_un in H;
- unfold intersection_family in H; simpl in H;
- assert
-  (H1 :
-   adherence
-     (fun y0:R =>
-        (exists p : nat, y0 = un p /\ INR N <= INR p) /\
-        (exists n : nat, INR N = INR n)) x).
-apply H; exists N; reflexivity.
-unfold adherence in H1; unfold point_adherent in H1; assert (H2 := H1 _ H0);
- elim H2; intros; unfold intersection_domain in H3; 
- elim H3; clear H3; intros; elim H4; clear H4; intros; 
- elim H4; clear H4; intros; elim H4; clear H4; intros; 
- exists x1; split.
-apply (INR_le _ _ H6).
-rewrite H4 in H3; apply H3.
+  forall (un:nat -> R) (x:R), ValAdh un x <-> ValAdh_un un x.
+Proof.
+  intros; split; intro.
+  unfold ValAdh in H; unfold ValAdh_un in |- *;
+    unfold intersection_family in |- *; simpl in |- *; 
+      intros; elim H0; intros N H1; unfold adherence in |- *;
+        unfold point_adherent in |- *; intros; elim (H V N H2); 
+          intros; exists (un x0); unfold intersection_domain in |- *; 
+            elim H3; clear H3; intros; split.
+  assumption.
+  split.
+  exists x0; split; [ reflexivity | rewrite H1; apply (le_INR _ _ H3) ].
+  exists N; assumption.
+  unfold ValAdh in |- *; intros; unfold ValAdh_un in H;
+    unfold intersection_family in H; simpl in H;
+      assert
+        (H1 :
+          adherence
+          (fun y0:R =>
+            (exists p : nat, y0 = un p /\ INR N <= INR p) /\
+            (exists n : nat, INR N = INR n)) x).
+  apply H; exists N; reflexivity.
+  unfold adherence in H1; unfold point_adherent in H1; assert (H2 := H1 _ H0);
+    elim H2; intros; unfold intersection_domain in H3; 
+      elim H3; clear H3; intros; elim H4; clear H4; intros; 
+        elim H4; clear H4; intros; elim H4; clear H4; intros; 
+          exists x1; split.
+  apply (INR_le _ _ H6).
+  rewrite H4 in H3; apply H3.
 Qed.
 
 Lemma adherence_P4 :
- forall F G:R -> Prop, included F G -> included (adherence F) (adherence G).
-unfold adherence, included in |- *; unfold point_adherent in |- *; intros;
- elim (H0 _ H1); unfold intersection_domain in |- *; 
- intros; elim H2; clear H2; intros; exists x0; split;
- [ assumption | apply (H _ H3) ].
+  forall F G:R -> Prop, included F G -> included (adherence F) (adherence G).
+Proof.
+  unfold adherence, included in |- *; unfold point_adherent in |- *; intros;
+    elim (H0 _ H1); unfold intersection_domain in |- *; 
+      intros; elim H2; clear H2; intros; exists x0; split;
+        [ assumption | apply (H _ H3) ].
 Qed.
 
 Definition family_closed_set (f:family) : Prop :=
@@ -1355,471 +1397,476 @@ Definition intersection_vide_finite_in (D:R -> Prop)
 
 (**********)
 Lemma compact_P6 :
- forall X:R -> Prop,
-   compact X ->
-   (exists z : R, X z) ->
-   forall g:family,
-     family_closed_set g ->
-     intersection_vide_in X g ->
+  forall X:R -> Prop,
+    compact X ->
+    (exists z : R, X z) ->
+    forall g:family,
+      family_closed_set g ->
+      intersection_vide_in X g ->
       exists D : R -> Prop, intersection_vide_finite_in X (subfamily g D).
-intros X H Hyp g H0 H1.
-set (D' := ind g).
-set (f' := fun x y:R => complementary (g x) y /\ D' x).
-assert (H2 : forall x:R, (exists y : R, f' x y) -> D' x).
-intros; elim H2; intros; unfold f' in H3; elim H3; intros; assumption.
-set (f0 := mkfamily D' f' H2).
-unfold compact in H; assert (H3 : covering_open_set X f0).
-unfold covering_open_set in |- *; split.
-unfold covering in |- *; intros; unfold intersection_vide_in in H1;
- elim (H1 x); intros; unfold intersection_family in H5;
- assert
-  (H6 := not_ex_all_not _ (fun y:R => forall y0:R, ind g y0 -> g y0 y) H5 x);
- assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); 
- elim H7; intros; exists x0; elim (imply_to_and _ _ H8); 
- intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *; 
- split; [ apply H10 | apply H9 ].
-unfold family_open_set in |- *; intro; elim (classic (D' x)); intro.
-apply open_set_P6 with (complementary (g x)).
-unfold family_closed_set in H0; unfold closed_set in H0; apply H0.
-unfold f0 in |- *; simpl in |- *; unfold f' in |- *; unfold eq_Dom in |- *;
- split.
-unfold included in |- *; intros; split; [ apply H4 | apply H3 ].
-unfold included in |- *; intros; elim H4; intros; assumption.
-apply open_set_P6 with (fun _:R => False).
-apply open_set_P4.
-unfold eq_Dom in |- *; unfold included in |- *; split; intros;
- [ elim H4
- | simpl in H4; unfold f' in H4; elim H4; intros; elim H3; assumption ].
-elim (H _ H3); intros SF H4; exists SF;
- unfold intersection_vide_finite_in in |- *; split.
-unfold intersection_vide_in in |- *; simpl in |- *; intros; split.
-intros; unfold included in |- *; intros; unfold intersection_vide_in in H1;
- elim (H1 x); intros; elim H6; intros; apply H7.
-unfold intersection_domain in H5; elim H5; intros; assumption.
-assumption.
-elim (classic (exists y : R, intersection_domain (ind g) SF y)); intro Hyp'.
-red in |- *; intro; elim H5; intros; unfold intersection_family in H6;
- simpl in H6.
-cut (X x0).
-intro; unfold covering_finite in H4; elim H4; clear H4; intros H4 _;
- unfold covering in H4; elim (H4 x0 H7); intros; simpl in H8;
- unfold intersection_domain in H6; cut (ind g x1 /\ SF x1).
-intro; assert (H10 := H6 x1 H9); elim H10; clear H10; intros H10 _; elim H8;
- clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; 
- elim H8; clear H8; intros H8 _; elim H8; assumption.
-split.
-apply (cond_fam f0).
-exists x0; elim H8; intros; assumption.
-elim H8; intros; assumption.
-unfold intersection_vide_in in H1; elim Hyp'; intros; assert (H8 := H6 _ H7);
- elim H8; intros; cut (ind g x1).
-intro; elim (H1 x1); intros; apply H12.
-apply H11.
-apply H9.
-apply (cond_fam g); exists x0; assumption.
-unfold covering_finite in H4; elim H4; clear H4; intros H4 _;
- cut (exists z : R, X z).
-intro; elim H5; clear H5; intros; unfold covering in H4; elim (H4 x0 H5);
- intros; simpl in H6; elim Hyp'; exists x1; elim H6; 
- intros; unfold intersection_domain in |- *; split.
-apply (cond_fam f0); exists x0; apply H7.
-apply H8.
-apply Hyp.
-unfold covering_finite in H4; elim H4; clear H4; intros;
- unfold family_finite in H5; unfold domain_finite in H5;
- unfold family_finite in |- *; unfold domain_finite in |- *; 
- elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); 
- intros; split; intro;
- [ apply H6; simpl in |- *; simpl in H8; apply H8 | apply (H7 H8) ].
+Proof.
+  intros X H Hyp g H0 H1.
+  set (D' := ind g).
+  set (f' := fun x y:R => complementary (g x) y /\ D' x).
+  assert (H2 : forall x:R, (exists y : R, f' x y) -> D' x).
+  intros; elim H2; intros; unfold f' in H3; elim H3; intros; assumption.
+  set (f0 := mkfamily D' f' H2).
+  unfold compact in H; assert (H3 : covering_open_set X f0).
+  unfold covering_open_set in |- *; split.
+  unfold covering in |- *; intros; unfold intersection_vide_in in H1;
+    elim (H1 x); intros; unfold intersection_family in H5;
+      assert
+        (H6 := not_ex_all_not _ (fun y:R => forall y0:R, ind g y0 -> g y0 y) H5 x);
+        assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); 
+          elim H7; intros; exists x0; elim (imply_to_and _ _ H8); 
+            intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *; 
+              split; [ apply H10 | apply H9 ].
+  unfold family_open_set in |- *; intro; elim (classic (D' x)); intro.
+  apply open_set_P6 with (complementary (g x)).
+  unfold family_closed_set in H0; unfold closed_set in H0; apply H0.
+  unfold f0 in |- *; simpl in |- *; unfold f' in |- *; unfold eq_Dom in |- *;
+    split.
+  unfold included in |- *; intros; split; [ apply H4 | apply H3 ].
+  unfold included in |- *; intros; elim H4; intros; assumption.
+  apply open_set_P6 with (fun _:R => False).
+  apply open_set_P4.
+  unfold eq_Dom in |- *; unfold included in |- *; split; intros;
+    [ elim H4
+      | simpl in H4; unfold f' in H4; elim H4; intros; elim H3; assumption ].
+  elim (H _ H3); intros SF H4; exists SF;
+    unfold intersection_vide_finite_in in |- *; split.
+  unfold intersection_vide_in in |- *; simpl in |- *; intros; split.
+  intros; unfold included in |- *; intros; unfold intersection_vide_in in H1;
+    elim (H1 x); intros; elim H6; intros; apply H7.
+  unfold intersection_domain in H5; elim H5; intros; assumption.
+  assumption.
+  elim (classic (exists y : R, intersection_domain (ind g) SF y)); intro Hyp'.
+  red in |- *; intro; elim H5; intros; unfold intersection_family in H6;
+    simpl in H6.
+  cut (X x0).
+  intro; unfold covering_finite in H4; elim H4; clear H4; intros H4 _;
+    unfold covering in H4; elim (H4 x0 H7); intros; simpl in H8;
+      unfold intersection_domain in H6; cut (ind g x1 /\ SF x1).
+  intro; assert (H10 := H6 x1 H9); elim H10; clear H10; intros H10 _; elim H8;
+    clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; 
+      elim H8; clear H8; intros H8 _; elim H8; assumption.
+  split.
+  apply (cond_fam f0).
+  exists x0; elim H8; intros; assumption.
+  elim H8; intros; assumption.
+  unfold intersection_vide_in in H1; elim Hyp'; intros; assert (H8 := H6 _ H7);
+    elim H8; intros; cut (ind g x1).
+  intro; elim (H1 x1); intros; apply H12.
+  apply H11.
+  apply H9.
+  apply (cond_fam g); exists x0; assumption.
+  unfold covering_finite in H4; elim H4; clear H4; intros H4 _;
+    cut (exists z : R, X z).
+  intro; elim H5; clear H5; intros; unfold covering in H4; elim (H4 x0 H5);
+    intros; simpl in H6; elim Hyp'; exists x1; elim H6; 
+      intros; unfold intersection_domain in |- *; split.
+  apply (cond_fam f0); exists x0; apply H7.
+  apply H8.
+  apply Hyp.
+  unfold covering_finite in H4; elim H4; clear H4; intros;
+    unfold family_finite in H5; unfold domain_finite in H5;
+      unfold family_finite in |- *; unfold domain_finite in |- *; 
+        elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); 
+          intros; split; intro;
+            [ apply H6; simpl in |- *; simpl in H8; apply H8 | apply (H7 H8) ].
 Qed.
 
 Theorem Bolzano_Weierstrass :
- forall (un:nat -> R) (X:R -> Prop),
-   compact X -> (forall n:nat, X (un n)) ->  exists l : R, ValAdh un l.
-intros; cut (exists l : R, ValAdh_un un l).
-intro; elim H1; intros; exists x; elim (ValAdh_un_prop un x); intros;
- apply (H4 H2).
-assert (H1 :  exists z : R, X z).
-exists (un 0%nat); apply H0.
-set (D := fun x:R =>  exists n : nat, x = INR n).
-set
- (g :=
-  fun x:R =>
-    adherence (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x)).
-assert (H2 : forall x:R, (exists y : R, g x y) -> D x).
-intros; elim H2; intros; unfold g in H3; unfold adherence in H3;
- unfold point_adherent in H3.
-assert (H4 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0).
-unfold neighbourhood in |- *; exists (mkposreal _ Rlt_0_1);
- unfold included in |- *; trivial.
-elim (H3 _ H4); intros; unfold intersection_domain in H5; decompose [and] H5;
- assumption.
-set (f0 := mkfamily D g H2).
-assert (H3 := compact_P6 X H H1 f0).
-elim (classic (exists l : R, ValAdh_un un l)); intro.
-assumption.
-cut (family_closed_set f0).
-intro; cut (intersection_vide_in X f0).
-intro; assert (H7 := H3 H5 H6).
-elim H7; intros SF H8; unfold intersection_vide_finite_in in H8; elim H8;
- clear H8; intros; unfold intersection_vide_in in H8; 
- elim (H8 0); intros _ H10; elim H10; unfold family_finite in H9;
- unfold domain_finite in H9; elim H9; clear H9; intros l H9;
- set (r := MaxRlist l); cut (D r).
-intro; unfold D in H11; elim H11; intros; exists (un x);
- unfold intersection_family in |- *; simpl in |- *;
- unfold intersection_domain in |- *; intros; split.
-unfold g in |- *; apply adherence_P1; split.
-exists x; split;
- [ reflexivity
- | rewrite <- H12; unfold r in |- *; apply MaxRlist_P1; elim (H9 y); intros;
-    apply H14; simpl in |- *; apply H13 ].
-elim H13; intros; assumption.
-elim H13; intros; assumption.
-elim (H9 r); intros.
-simpl in H12; unfold intersection_domain in H12; cut (In r l).
-intro; elim (H12 H13); intros; assumption.
-unfold r in |- *; apply MaxRlist_P2;
- cut (exists z : R, intersection_domain (ind f0) SF z).
-intro; elim H13; intros; elim (H9 x); intros; simpl in H15;
- assert (H17 := H15 H14); exists x; apply H17.
-elim (classic (exists z : R, intersection_domain (ind f0) SF z)); intro.
-assumption.
-elim (H8 0); intros _ H14; elim H1; intros;
- assert
-  (H16 :=
-   not_ex_all_not _ (fun y:R => intersection_family (subfamily f0 SF) y) H14);
- assert
-  (H17 :=
-   not_ex_all_not _ (fun z:R => intersection_domain (ind f0) SF z) H13);
- assert (H18 := H16 x); unfold intersection_family in H18; 
- simpl in H18;
- assert
-  (H19 :=
-   not_all_ex_not _ (fun y:R => intersection_domain D SF y -> g y x /\ SF y)
-     H18); elim H19; intros; assert (H21 := imply_to_and _ _ H20);
- elim (H17 x0); elim H21; intros; assumption.
-unfold intersection_vide_in in |- *; intros; split.
-intro; simpl in H6; unfold f0 in |- *; simpl in |- *; unfold g in |- *;
- apply included_trans with (adherence X).
-apply adherence_P4.
-unfold included in |- *; intros; elim H7; intros; elim H8; intros; elim H10;
- intros; rewrite H11; apply H0.
-apply adherence_P2; apply compact_P2; assumption.
-apply H4.
-unfold family_closed_set in |- *; unfold f0 in |- *; simpl in |- *;
- unfold g in |- *; intro; apply adherence_P3.
+  forall (un:nat -> R) (X:R -> Prop),
+    compact X -> (forall n:nat, X (un n)) ->  exists l : R, ValAdh un l.
+Proof.
+  intros; cut (exists l : R, ValAdh_un un l).
+  intro; elim H1; intros; exists x; elim (ValAdh_un_prop un x); intros;
+    apply (H4 H2).
+  assert (H1 :  exists z : R, X z).
+  exists (un 0%nat); apply H0.
+  set (D := fun x:R =>  exists n : nat, x = INR n).
+  set
+    (g :=
+      fun x:R =>
+        adherence (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x)).
+  assert (H2 : forall x:R, (exists y : R, g x y) -> D x).
+  intros; elim H2; intros; unfold g in H3; unfold adherence in H3;
+    unfold point_adherent in H3.
+  assert (H4 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0).
+  unfold neighbourhood in |- *; exists (mkposreal _ Rlt_0_1);
+    unfold included in |- *; trivial.
+  elim (H3 _ H4); intros; unfold intersection_domain in H5; decompose [and] H5;
+    assumption.
+  set (f0 := mkfamily D g H2).
+  assert (H3 := compact_P6 X H H1 f0).
+  elim (classic (exists l : R, ValAdh_un un l)); intro.
+  assumption.
+  cut (family_closed_set f0).
+  intro; cut (intersection_vide_in X f0).
+  intro; assert (H7 := H3 H5 H6).
+  elim H7; intros SF H8; unfold intersection_vide_finite_in in H8; elim H8;
+    clear H8; intros; unfold intersection_vide_in in H8; 
+      elim (H8 0); intros _ H10; elim H10; unfold family_finite in H9;
+        unfold domain_finite in H9; elim H9; clear H9; intros l H9;
+          set (r := MaxRlist l); cut (D r).
+  intro; unfold D in H11; elim H11; intros; exists (un x);
+    unfold intersection_family in |- *; simpl in |- *;
+      unfold intersection_domain in |- *; intros; split.
+  unfold g in |- *; apply adherence_P1; split.
+  exists x; split;
+    [ reflexivity
+      | rewrite <- H12; unfold r in |- *; apply MaxRlist_P1; elim (H9 y); intros;
+        apply H14; simpl in |- *; apply H13 ].
+  elim H13; intros; assumption.
+  elim H13; intros; assumption.
+  elim (H9 r); intros.
+  simpl in H12; unfold intersection_domain in H12; cut (In r l).
+  intro; elim (H12 H13); intros; assumption.
+  unfold r in |- *; apply MaxRlist_P2;
+    cut (exists z : R, intersection_domain (ind f0) SF z).
+  intro; elim H13; intros; elim (H9 x); intros; simpl in H15;
+    assert (H17 := H15 H14); exists x; apply H17.
+  elim (classic (exists z : R, intersection_domain (ind f0) SF z)); intro.
+  assumption.
+  elim (H8 0); intros _ H14; elim H1; intros;
+    assert
+      (H16 :=
+        not_ex_all_not _ (fun y:R => intersection_family (subfamily f0 SF) y) H14);
+      assert
+        (H17 :=
+          not_ex_all_not _ (fun z:R => intersection_domain (ind f0) SF z) H13);
+        assert (H18 := H16 x); unfold intersection_family in H18; 
+          simpl in H18;
+            assert
+              (H19 :=
+                not_all_ex_not _ (fun y:R => intersection_domain D SF y -> g y x /\ SF y)
+                H18); elim H19; intros; assert (H21 := imply_to_and _ _ H20);
+              elim (H17 x0); elim H21; intros; assumption.
+  unfold intersection_vide_in in |- *; intros; split.
+  intro; simpl in H6; unfold f0 in |- *; simpl in |- *; unfold g in |- *;
+    apply included_trans with (adherence X).
+  apply adherence_P4.
+  unfold included in |- *; intros; elim H7; intros; elim H8; intros; elim H10;
+    intros; rewrite H11; apply H0.
+  apply adherence_P2; apply compact_P2; assumption.
+  apply H4.
+  unfold family_closed_set in |- *; unfold f0 in |- *; simpl in |- *;
+    unfold g in |- *; intro; apply adherence_P3.
 Qed.
 
 (********************************************************)
-(*               Proof of Heine's theorem               *)
+(** *            Proof of Heine's theorem               *)
 (********************************************************)
 
 Definition uniform_continuity (f:R -> R) (X:R -> Prop) : Prop :=
   forall eps:posreal,
-     exists delta : posreal,
+    exists delta : posreal,
       (forall x y:R,
-         X x -> X y -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps).
+        X x -> X y -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps).
 
 Lemma is_lub_u :
- forall (E:R -> Prop) (x y:R), is_lub E x -> is_lub E y -> x = y.
-unfold is_lub in |- *; intros; elim H; elim H0; intros; apply Rle_antisym;
- [ apply (H4 _ H1) | apply (H2 _ H3) ].
+  forall (E:R -> Prop) (x y:R), is_lub E x -> is_lub E y -> x = y.
+Proof.
+  unfold is_lub in |- *; intros; elim H; elim H0; intros; apply Rle_antisym;
+    [ apply (H4 _ H1) | apply (H2 _ H3) ].
 Qed.
 
 Lemma domain_P1 :
- forall X:R -> Prop,
-   ~ (exists y : R, X y) \/
-   (exists y : R, X y /\ (forall x:R, X x -> x = y)) \/
-   (exists x : R, (exists y : R, X x /\ X y /\ x <> y)).
-intro; elim (classic (exists y : R, X y)); intro.
-right; elim H; intros; elim (classic (exists y : R, X y /\ y <> x)); intro.
-right; elim H1; intros; elim H2; intros; exists x; exists x0; intros.
-split;
- [ assumption
- | split; [ assumption | apply (sym_not_eq (A:=R)); assumption ] ].
-left; exists x; split.
-assumption.
-intros; case (Req_dec x0 x); intro.
-assumption.
-elim H1; exists x0; split; assumption.
-left; assumption.
+  forall X:R -> Prop,
+    ~ (exists y : R, X y) \/
+    (exists y : R, X y /\ (forall x:R, X x -> x = y)) \/
+    (exists x : R, (exists y : R, X x /\ X y /\ x <> y)).
+Proof.
+  intro; elim (classic (exists y : R, X y)); intro.
+  right; elim H; intros; elim (classic (exists y : R, X y /\ y <> x)); intro.
+  right; elim H1; intros; elim H2; intros; exists x; exists x0; intros.
+  split;
+    [ assumption
+      | split; [ assumption | apply (sym_not_eq (A:=R)); assumption ] ].
+  left; exists x; split.
+  assumption.
+  intros; case (Req_dec x0 x); intro.
+  assumption.
+  elim H1; exists x0; split; assumption.
+  left; assumption.
 Qed.
 
 Theorem Heine :
- forall (f:R -> R) (X:R -> Prop),
-   compact X ->
-   (forall x:R, X x -> continuity_pt f x) -> uniform_continuity f X.
-intros f0 X H0 H; elim (domain_P1 X); intro Hyp.
+  forall (f:R -> R) (X:R -> Prop),
+    compact X ->
+    (forall x:R, X x -> continuity_pt f x) -> uniform_continuity f X.
+Proof.
+  intros f0 X H0 H; elim (domain_P1 X); intro Hyp.
 (* X est vide *)
-unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
- intros; elim Hyp; exists x; assumption.
-elim Hyp; clear Hyp; intro Hyp.
+  unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
+    intros; elim Hyp; exists x; assumption.
+  elim Hyp; clear Hyp; intro Hyp.
 (* X possède un seul élément *)
-unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
- intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; 
- intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); 
- rewrite H6; rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; apply (cond_pos eps).
+  unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
+    intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; 
+      intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); 
+        rewrite H6; rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r;
+          rewrite Rabs_R0; apply (cond_pos eps).
 (* X possède au moins deux éléments distincts *)
-assert
- (X_enc :
-   exists m : R, (exists M : R, (forall x:R, X x -> m <= x <= M) /\ m < M)).
-assert (H1 := compact_P1 X H0); unfold bounded in H1; elim H1; intros;
- elim H2; intros; exists x; exists x0; split.
-apply H3.
-elim Hyp; intros; elim H4; intros; decompose [and] H5;
- assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); 
- elim H10; intros; elim H11; intros; case (total_order_T x x0); 
- intro.
-elim s; intro.
-assumption.
-rewrite b in H13; rewrite b in H7; elim H9; apply Rle_antisym;
- apply Rle_trans with x0; assumption.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H13 H14) r)).
-elim X_enc; clear X_enc; intros m X_enc; elim X_enc; clear X_enc;
- intros M X_enc; elim X_enc; clear X_enc Hyp; intros X_enc Hyp;
- unfold uniform_continuity in |- *; intro;
- assert (H1 : forall t:posreal, 0 < t / 2).
-intro; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply (cond_pos t) | apply Rinv_0_lt_compat; prove_sup0 ].
-set
- (g :=
-  fun x y:R =>
-    X x /\
-    (exists del : posreal,
-       (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
-       is_lub
-         (fun zeta:R =>
+  assert
+    (X_enc :
+      exists m : R, (exists M : R, (forall x:R, X x -> m <= x <= M) /\ m < M)).
+  assert (H1 := compact_P1 X H0); unfold bounded in H1; elim H1; intros;
+    elim H2; intros; exists x; exists x0; split.
+  apply H3.
+  elim Hyp; intros; elim H4; intros; decompose [and] H5;
+    assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); 
+      elim H10; intros; elim H11; intros; case (total_order_T x x0); 
+        intro.
+  elim s; intro.
+  assumption.
+  rewrite b in H13; rewrite b in H7; elim H9; apply Rle_antisym;
+    apply Rle_trans with x0; assumption.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H13 H14) r)).
+  elim X_enc; clear X_enc; intros m X_enc; elim X_enc; clear X_enc;
+    intros M X_enc; elim X_enc; clear X_enc Hyp; intros X_enc Hyp;
+      unfold uniform_continuity in |- *; intro;
+        assert (H1 : forall t:posreal, 0 < t / 2).
+  intro; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply (cond_pos t) | apply Rinv_0_lt_compat; prove_sup0 ].
+  set
+    (g :=
+      fun x y:R =>
+        X x /\
+        (exists del : posreal,
+          (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
+          is_lub
+          (fun zeta:R =>
             0 < zeta <= M - m /\
             (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2))
-         del /\ disc x (mkposreal (del / 2) (H1 del)) y)).
-assert (H2 : forall x:R, (exists y : R, g x y) -> X x).
-intros; elim H2; intros; unfold g in H3; elim H3; clear H3; intros H3 _;
- apply H3.
-set (f' := mkfamily X g H2); unfold compact in H0;
- assert (H3 : covering_open_set X f').
-unfold covering_open_set in |- *; split.
-unfold covering in |- *; intros; exists x; simpl in |- *; unfold g in |- *;
- split.
-assumption.
-assert (H4 := H _ H3); unfold continuity_pt in H4; unfold continue_in in H4;
- unfold limit1_in in H4; unfold limit_in in H4; simpl in H4;
- unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps)); 
- intros;
- set
-  (E :=
-   fun zeta:R =>
-     0 < zeta <= M - m /\
-     (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
- assert (H6 : bound E).
-unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
- unfold E in |- *; intros; elim H6; clear H6; intros H6 _; 
- elim H6; clear H6; intros _ H6; apply H6.
-assert (H7 :  exists x : R, E x).
-elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros;
- split.
-split.
-unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro.
-apply H5.
-apply Rlt_Rminus; apply Hyp.
-apply Rmin_r.
-intros; case (Req_dec x z); intro.
-rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- apply (H1 eps).
-apply H7; split.
-unfold D_x, no_cond in |- *; split; [ trivial | assumption ].
-apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H8 | apply Rmin_l ].
-assert (H8 := completeness _ H6 H7); elim H8; clear H8; intros;
- cut (0 < x1 <= M - m).
-intro; elim H8; clear H8; intros; exists (mkposreal _ H8); split.
-intros; cut (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp).
-intros; elim H11; intros; elim H12; clear H12; intros; unfold E in H13;
- elim H13; intros; apply H15.
-elim H12; intros; assumption.
-elim (classic (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp)); intro.
-assumption.
-assert
- (H12 :=
-  not_ex_all_not _ (fun alp:R => Rabs (z - x) < alp <= x1 /\ E alp) H11);
- unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))).
-intro; assert (H16 := H14 _ H15);
- elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H16)).
-unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H13;
- assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); 
- intro.
-assumption.
-elim (H12 x2); split; [ split; [ auto with real | assumption ] | assumption ].
-split.
-apply p.
-unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
- rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *; 
- apply Rmult_lt_0_compat; [ apply H8 | apply Rinv_0_lt_compat; prove_sup0 ].
-elim H7; intros; unfold E in H8; elim H8; intros H9 _; elim H9; intros H10 _;
- unfold is_lub in p; elim p; intros; unfold is_upper_bound in H12;
- unfold is_upper_bound in H11; split.
-apply Rlt_le_trans with x2; [ assumption | apply (H11 _ H8) ].
-apply H12; intros; unfold E in H13; elim H13; intros; elim H14; intros;
- assumption.
-unfold family_open_set in |- *; intro; simpl in |- *; elim (classic (X x));
- intro.
-unfold g in |- *; unfold open_set in |- *; intros; elim H4; clear H4;
- intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; 
- intros; unfold neighbourhood in |- *; case (Req_dec x x0); 
- intro.
-exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included in |- *; intros;
- split.
-assumption.
-exists x1; split.
-apply H4.
-split.
-elim H5; intros; apply H8.
-apply H7.
-set (d := x1 / 2 - Rabs (x0 - x)); assert (H7 : 0 < d).
-unfold d in |- *; apply Rlt_Rminus; elim H5; clear H5; intros;
- unfold disc in H7; apply H7.
-exists (mkposreal _ H7); unfold included in |- *; intros; split.
-assumption.
-exists x1; split.
-apply H4.
-elim H5; intros; split.
-assumption.
-unfold disc in H8; simpl in H8; unfold disc in |- *; simpl in |- *;
- unfold disc in H10; simpl in H10;
- apply Rle_lt_trans with (Rabs (x2 - x0) + Rabs (x0 - x)).
-replace (x2 - x) with (x2 - x0 + (x0 - x)); [ apply Rabs_triang | ring ].
-replace (x1 / 2) with (d + Rabs (x0 - x)); [ idtac | unfold d in |- *; ring ].
-do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l;
- apply H8.
-apply open_set_P6 with (fun _:R => False).
-apply open_set_P4.
-unfold eq_Dom in |- *; unfold included in |- *; intros; split.
-intros; elim H4.
-intros; unfold g in H4; elim H4; clear H4; intros H4 _; elim H3; apply H4.
-elim (H0 _ H3); intros DF H4; unfold covering_finite in H4; elim H4; clear H4;
- intros; unfold family_finite in H5; unfold domain_finite in H5;
- unfold covering in H4; simpl in H4; simpl in H5; elim H5; 
- clear H5; intros l H5; unfold intersection_domain in H5;
- cut
-  (forall x:R,
-     In x l ->
-      exists del : R,
-       0 < del /\
-       (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
-       included (g x) (fun z:R => Rabs (z - x) < del / 2)).
-intros;
- assert
-  (H7 :=
-   Rlist_P1 l
-     (fun x del:R =>
-        0 < del /\
-        (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
-        included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); 
- elim H7; clear H7; intros l' H7; elim H7; clear H7; 
- intros; set (D := MinRlist l'); cut (0 < D / 2).
-intro; exists (mkposreal _ H9); intros; assert (H13 := H4 _ H10); elim H13;
- clear H13; intros xi H13; assert (H14 : In xi l).
-unfold g in H13; decompose [and] H13; elim (H5 xi); intros; apply H14; split;
- assumption.
-elim (pos_Rl_P2 l xi); intros H15 _; elim (H15 H14); intros i H16; elim H16;
- intros; apply Rle_lt_trans with (Rabs (f0 x - f0 xi) + Rabs (f0 xi - f0 y)).
-replace (f0 x - f0 y) with (f0 x - f0 xi + (f0 xi - f0 y));
- [ apply Rabs_triang | ring ].
-rewrite (double_var eps); apply Rplus_lt_compat.
-assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20;
- elim H20; clear H20; intros; apply H20; unfold included in H21;
- apply Rlt_trans with (pos_Rl l' i / 2).
-apply H21.
-elim H13; clear H13; intros; assumption.
-unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
-prove_sup0.
-rewrite Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; pattern (pos_Rl l' i) at 1 in |- *; rewrite <- Rplus_0_r;
- rewrite double; apply Rplus_lt_compat_l; apply H19.
-discrR.
-assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20;
- elim H20; clear H20; intros; rewrite <- Rabs_Ropp; 
- rewrite Ropp_minus_distr; apply H20; unfold included in H21; 
- elim H13; intros; assert (H24 := H21 x H22);
- apply Rle_lt_trans with (Rabs (y - x) + Rabs (x - xi)).
-replace (y - xi) with (y - x + (x - xi)); [ apply Rabs_triang | ring ].
-rewrite (double_var (pos_Rl l' i)); apply Rplus_lt_compat.
-apply Rlt_le_trans with (D / 2).
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H12.
-unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
- apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; prove_sup0.
-unfold D in |- *; apply MinRlist_P1; elim (pos_Rl_P2 l' (pos_Rl l' i));
- intros; apply H26; exists i; split;
- [ rewrite <- H7; assumption | reflexivity ].
-assumption.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ unfold D in |- *; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros;
-    elim (H10 H9); intros; elim H12; intros; rewrite H14;
-    rewrite <- H7 in H13; elim (H8 x H13); intros; 
-    apply H15
- | apply Rinv_0_lt_compat; prove_sup0 ].
-intros; elim (H5 x); intros; elim (H8 H6); intros;
- set
-  (E :=
-   fun zeta:R =>
-     0 < zeta <= M - m /\
-     (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
- assert (H11 : bound E).
-unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
- unfold E in |- *; intros; elim H11; clear H11; intros H11 _; 
- elim H11; clear H11; intros _ H11; apply H11.
-assert (H12 :  exists x : R, E x).
-assert (H13 := H _ H9); unfold continuity_pt in H13;
- unfold continue_in in H13; unfold limit1_in in H13; 
- unfold limit_in in H13; simpl in H13; unfold R_dist in H13;
- elim (H13 _ (H1 eps)); intros; elim H12; clear H12; 
- intros; exists (Rmin x0 (M - m)); unfold E in |- *; 
- intros; split.
-split;
- [ unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro;
-    [ apply H12 | apply Rlt_Rminus; apply Hyp ]
- | apply Rmin_r ].
-intros; case (Req_dec x z); intro.
-rewrite H16; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
- apply (H1 eps).
-apply H14; split;
- [ unfold D_x, no_cond in |- *; split; [ trivial | assumption ]
- | apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H15 | apply Rmin_l ] ].
-assert (H13 := completeness _ H11 H12); elim H13; clear H13; intros;
- cut (0 < x0 <= M - m).
-intro; elim H13; clear H13; intros; exists x0; split.
-assumption.
-split.
-intros; cut (exists alp : R, Rabs (z - x) < alp <= x0 /\ E alp).
-intros; elim H16; intros; elim H17; clear H17; intros; unfold E in H18;
- elim H18; intros; apply H20; elim H17; intros; assumption.
-elim (classic (exists alp : R, Rabs (z - x) < alp <= x0 /\ E alp)); intro.
-assumption.
-assert
- (H17 :=
-  not_ex_all_not _ (fun alp:R => Rabs (z - x) < alp <= x0 /\ E alp) H16);
- unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))).
-intro; assert (H21 := H19 _ H20);
- elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H15 H21)).
-unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H18;
- assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); 
- intro.
-assumption.
-elim (H17 x1); split.
-split; [ auto with real | assumption ].
-assumption.
-unfold included, g in |- *; intros; elim H15; intros; elim H17; intros;
- decompose [and] H18; cut (x0 = x2).
-intro; rewrite H20; apply H22.
-unfold E in p; eapply is_lub_u.
-apply p.
-apply H21.
-elim H12; intros; unfold E in H13; elim H13; intros H14 _; elim H14;
- intros H15 _; unfold is_lub in p; elim p; intros;
- unfold is_upper_bound in H16; unfold is_upper_bound in H17; 
- split.
-apply Rlt_le_trans with x1; [ assumption | apply (H16 _ H13) ].
-apply H17; intros; unfold E in H18; elim H18; intros; elim H19; intros;
- assumption.
+          del /\ disc x (mkposreal (del / 2) (H1 del)) y)).
+  assert (H2 : forall x:R, (exists y : R, g x y) -> X x).
+  intros; elim H2; intros; unfold g in H3; elim H3; clear H3; intros H3 _;
+    apply H3.
+  set (f' := mkfamily X g H2); unfold compact in H0;
+    assert (H3 : covering_open_set X f').
+  unfold covering_open_set in |- *; split.
+  unfold covering in |- *; intros; exists x; simpl in |- *; unfold g in |- *;
+    split.
+  assumption.
+  assert (H4 := H _ H3); unfold continuity_pt in H4; unfold continue_in in H4;
+    unfold limit1_in in H4; unfold limit_in in H4; simpl in H4;
+      unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps)); 
+        intros;
+          set
+            (E :=
+              fun zeta:R =>
+                0 < zeta <= M - m /\
+                (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
+            assert (H6 : bound E).
+  unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
+    unfold E in |- *; intros; elim H6; clear H6; intros H6 _; 
+      elim H6; clear H6; intros _ H6; apply H6.
+  assert (H7 :  exists x : R, E x).
+  elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros;
+    split.
+  split.
+  unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro.
+  apply H5.
+  apply Rlt_Rminus; apply Hyp.
+  apply Rmin_r.
+  intros; case (Req_dec x z); intro.
+  rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    apply (H1 eps).
+  apply H7; split.
+  unfold D_x, no_cond in |- *; split; [ trivial | assumption ].
+  apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H8 | apply Rmin_l ].
+  assert (H8 := completeness _ H6 H7); elim H8; clear H8; intros;
+    cut (0 < x1 <= M - m).
+  intro; elim H8; clear H8; intros; exists (mkposreal _ H8); split.
+  intros; cut (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp).
+  intros; elim H11; intros; elim H12; clear H12; intros; unfold E in H13;
+    elim H13; intros; apply H15.
+  elim H12; intros; assumption.
+  elim (classic (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp)); intro.
+  assumption.
+  assert
+    (H12 :=
+      not_ex_all_not _ (fun alp:R => Rabs (z - x) < alp <= x1 /\ E alp) H11);
+    unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))).
+  intro; assert (H16 := H14 _ H15);
+    elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H16)).
+  unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H13;
+    assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); 
+      intro.
+  assumption.
+  elim (H12 x2); split; [ split; [ auto with real | assumption ] | assumption ].
+  split.
+  apply p.
+  unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *; 
+      apply Rmult_lt_0_compat; [ apply H8 | apply Rinv_0_lt_compat; prove_sup0 ].
+  elim H7; intros; unfold E in H8; elim H8; intros H9 _; elim H9; intros H10 _;
+    unfold is_lub in p; elim p; intros; unfold is_upper_bound in H12;
+      unfold is_upper_bound in H11; split.
+  apply Rlt_le_trans with x2; [ assumption | apply (H11 _ H8) ].
+  apply H12; intros; unfold E in H13; elim H13; intros; elim H14; intros;
+    assumption.
+  unfold family_open_set in |- *; intro; simpl in |- *; elim (classic (X x));
+    intro.
+  unfold g in |- *; unfold open_set in |- *; intros; elim H4; clear H4;
+    intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; 
+      intros; unfold neighbourhood in |- *; case (Req_dec x x0); 
+        intro.
+  exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included in |- *; intros;
+    split.
+  assumption.
+  exists x1; split.
+  apply H4.
+  split.
+  elim H5; intros; apply H8.
+  apply H7.
+  set (d := x1 / 2 - Rabs (x0 - x)); assert (H7 : 0 < d).
+  unfold d in |- *; apply Rlt_Rminus; elim H5; clear H5; intros;
+    unfold disc in H7; apply H7.
+  exists (mkposreal _ H7); unfold included in |- *; intros; split.
+  assumption.
+  exists x1; split.
+  apply H4.
+  elim H5; intros; split.
+  assumption.
+  unfold disc in H8; simpl in H8; unfold disc in |- *; simpl in |- *;
+    unfold disc in H10; simpl in H10;
+      apply Rle_lt_trans with (Rabs (x2 - x0) + Rabs (x0 - x)).
+  replace (x2 - x) with (x2 - x0 + (x0 - x)); [ apply Rabs_triang | ring ].
+  replace (x1 / 2) with (d + Rabs (x0 - x)); [ idtac | unfold d in |- *; ring ].
+  do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l;
+    apply H8.
+  apply open_set_P6 with (fun _:R => False).
+  apply open_set_P4.
+  unfold eq_Dom in |- *; unfold included in |- *; intros; split.
+  intros; elim H4.
+  intros; unfold g in H4; elim H4; clear H4; intros H4 _; elim H3; apply H4.
+  elim (H0 _ H3); intros DF H4; unfold covering_finite in H4; elim H4; clear H4;
+    intros; unfold family_finite in H5; unfold domain_finite in H5;
+      unfold covering in H4; simpl in H4; simpl in H5; elim H5; 
+        clear H5; intros l H5; unfold intersection_domain in H5;
+          cut
+            (forall x:R,
+              In x l ->
+              exists del : R,
+                0 < del /\
+                (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
+                included (g x) (fun z:R => Rabs (z - x) < del / 2)).
+  intros;
+    assert
+      (H7 :=
+        Rlist_P1 l
+        (fun x del:R =>
+          0 < del /\
+          (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\
+          included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); 
+      elim H7; clear H7; intros l' H7; elim H7; clear H7; 
+        intros; set (D := MinRlist l'); cut (0 < D / 2).
+  intro; exists (mkposreal _ H9); intros; assert (H13 := H4 _ H10); elim H13;
+    clear H13; intros xi H13; assert (H14 : In xi l).
+  unfold g in H13; decompose [and] H13; elim (H5 xi); intros; apply H14; split;
+    assumption.
+  elim (pos_Rl_P2 l xi); intros H15 _; elim (H15 H14); intros i H16; elim H16;
+    intros; apply Rle_lt_trans with (Rabs (f0 x - f0 xi) + Rabs (f0 xi - f0 y)).
+  replace (f0 x - f0 y) with (f0 x - f0 xi + (f0 xi - f0 y));
+  [ apply Rabs_triang | ring ].
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20;
+    elim H20; clear H20; intros; apply H20; unfold included in H21;
+      apply Rlt_trans with (pos_Rl l' i / 2).
+  apply H21.
+  elim H13; clear H13; intros; assumption.
+  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  rewrite Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; pattern (pos_Rl l' i) at 1 in |- *; rewrite <- Rplus_0_r;
+    rewrite double; apply Rplus_lt_compat_l; apply H19.
+  discrR.
+  assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20;
+    elim H20; clear H20; intros; rewrite <- Rabs_Ropp; 
+      rewrite Ropp_minus_distr; apply H20; unfold included in H21; 
+        elim H13; intros; assert (H24 := H21 x H22);
+          apply Rle_lt_trans with (Rabs (y - x) + Rabs (x - xi)).
+  replace (y - xi) with (y - x + (x - xi)); [ apply Rabs_triang | ring ].
+  rewrite (double_var (pos_Rl l' i)); apply Rplus_lt_compat.
+  apply Rlt_le_trans with (D / 2).
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H12.
+  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
+    apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; prove_sup0.
+  unfold D in |- *; apply MinRlist_P1; elim (pos_Rl_P2 l' (pos_Rl l' i));
+    intros; apply H26; exists i; split;
+      [ rewrite <- H7; assumption | reflexivity ].
+  assumption.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ unfold D in |- *; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros;
+      elim (H10 H9); intros; elim H12; intros; rewrite H14;
+        rewrite <- H7 in H13; elim (H8 x H13); intros; 
+          apply H15
+      | apply Rinv_0_lt_compat; prove_sup0 ].
+  intros; elim (H5 x); intros; elim (H8 H6); intros;
+    set
+      (E :=
+        fun zeta:R =>
+          0 < zeta <= M - m /\
+          (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
+      assert (H11 : bound E).
+  unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
+    unfold E in |- *; intros; elim H11; clear H11; intros H11 _; 
+      elim H11; clear H11; intros _ H11; apply H11.
+  assert (H12 :  exists x : R, E x).
+  assert (H13 := H _ H9); unfold continuity_pt in H13;
+    unfold continue_in in H13; unfold limit1_in in H13; 
+      unfold limit_in in H13; simpl in H13; unfold R_dist in H13;
+        elim (H13 _ (H1 eps)); intros; elim H12; clear H12; 
+          intros; exists (Rmin x0 (M - m)); unfold E in |- *; 
+            intros; split.
+  split;
+    [ unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro;
+      [ apply H12 | apply Rlt_Rminus; apply Hyp ]
+      | apply Rmin_r ].
+  intros; case (Req_dec x z); intro.
+  rewrite H16; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    apply (H1 eps).
+  apply H14; split;
+    [ unfold D_x, no_cond in |- *; split; [ trivial | assumption ]
+      | apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H15 | apply Rmin_l ] ].
+  assert (H13 := completeness _ H11 H12); elim H13; clear H13; intros;
+    cut (0 < x0 <= M - m).
+  intro; elim H13; clear H13; intros; exists x0; split.
+  assumption.
+  split.
+  intros; cut (exists alp : R, Rabs (z - x) < alp <= x0 /\ E alp).
+  intros; elim H16; intros; elim H17; clear H17; intros; unfold E in H18;
+    elim H18; intros; apply H20; elim H17; intros; assumption.
+  elim (classic (exists alp : R, Rabs (z - x) < alp <= x0 /\ E alp)); intro.
+  assumption.
+  assert
+    (H17 :=
+      not_ex_all_not _ (fun alp:R => Rabs (z - x) < alp <= x0 /\ E alp) H16);
+    unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))).
+  intro; assert (H21 := H19 _ H20);
+    elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H15 H21)).
+  unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H18;
+    assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); 
+      intro.
+  assumption.
+  elim (H17 x1); split.
+  split; [ auto with real | assumption ].
+  assumption.
+  unfold included, g in |- *; intros; elim H15; intros; elim H17; intros;
+    decompose [and] H18; cut (x0 = x2).
+  intro; rewrite H20; apply H22.
+  unfold E in p; eapply is_lub_u.
+  apply p.
+  apply H21.
+  elim H12; intros; unfold E in H13; elim H13; intros H14 _; elim H14;
+    intros H15 _; unfold is_lub in p; elim p; intros;
+      unfold is_upper_bound in H16; unfold is_upper_bound in H17; 
+        split.
+  apply Rlt_le_trans with x1; [ assumption | apply (H16 _ H13) ].
+  apply H17; intros; unfold E in H18; elim H18; intros; elim H19; intros;
+    assumption.
 Qed.
diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v
index e4cae6c6..b744c788 100644
--- a/theories/Reals/Rtrigo.v
+++ b/theories/Reals/Rtrigo.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo.v,v 1.40.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+(*i $Id: Rtrigo.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -27,312 +27,356 @@ Axiom sin_PI2 : sin (PI / 2) = 1.
 
 (**********)
 Lemma PI_neq0 : PI <> 0.
-red in |- *; intro; assert (H0 := PI_RGT_0); rewrite H in H0;
- elim (Rlt_irrefl _ H0).
+Proof.
+  red in |- *; intro; assert (H0 := PI_RGT_0); rewrite H in H0;
+    elim (Rlt_irrefl _ H0).
 Qed.
 
 (**********) 
 Lemma cos_minus : forall x y:R, cos (x - y) = cos x * cos y + sin x * sin y.
-intros; unfold Rminus in |- *; rewrite cos_plus.
-rewrite <- cos_sym; rewrite sin_antisym; ring.
+Proof.
+  intros; unfold Rminus in |- *; rewrite cos_plus.
+  rewrite <- cos_sym; rewrite sin_antisym; ring.
 Qed.
 
 (**********)
 Lemma sin2_cos2 : forall x:R, Rsqr (sin x) + Rsqr (cos x) = 1.
-intro; unfold Rsqr in |- *; rewrite Rplus_comm; rewrite <- (cos_minus x x);
- unfold Rminus in |- *; rewrite Rplus_opp_r; apply cos_0.
+Proof.
+  intro; unfold Rsqr in |- *; rewrite Rplus_comm; rewrite <- (cos_minus x x);
+    unfold Rminus in |- *; rewrite Rplus_opp_r; apply cos_0.
 Qed.
 
 Lemma cos2 : forall x:R, Rsqr (cos x) = 1 - Rsqr (sin x).
-intro x; generalize (sin2_cos2 x); intro H1; rewrite <- H1;
- unfold Rminus in |- *; rewrite <- (Rplus_comm (Rsqr (cos x)));
- rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry  in |- *; 
- apply Rplus_0_r.
+Proof.
+  intro x; generalize (sin2_cos2 x); intro H1; rewrite <- H1;
+    unfold Rminus in |- *; rewrite <- (Rplus_comm (Rsqr (cos x)));
+      rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry  in |- *; 
+        apply Rplus_0_r.
 Qed.
 
 (**********)
 Lemma cos_PI2 : cos (PI / 2) = 0.
-apply Rsqr_eq_0; rewrite cos2; rewrite sin_PI2; rewrite Rsqr_1;
- unfold Rminus in |- *; apply Rplus_opp_r.
+Proof.
+  apply Rsqr_eq_0; rewrite cos2; rewrite sin_PI2; rewrite Rsqr_1;
+    unfold Rminus in |- *; apply Rplus_opp_r.
 Qed.
 
 (**********)
 Lemma cos_PI : cos PI = -1.
-replace PI with (PI / 2 + PI / 2).
-rewrite cos_plus.
-rewrite sin_PI2; rewrite cos_PI2.
-ring.
-symmetry  in |- *; apply double_var.
+Proof.
+  replace PI with (PI / 2 + PI / 2).
+  rewrite cos_plus.
+  rewrite sin_PI2; rewrite cos_PI2.
+  ring.
+  symmetry  in |- *; apply double_var.
 Qed.
 
 Lemma sin_PI : sin PI = 0.
-assert (H := sin2_cos2 PI).
-rewrite cos_PI in H.
-rewrite <- Rsqr_neg in H.
-rewrite Rsqr_1 in H.
-cut (Rsqr (sin PI) = 0).
-intro; apply (Rsqr_eq_0 _ H0).
-apply Rplus_eq_reg_l with 1.
-rewrite Rplus_0_r; rewrite Rplus_comm; exact H.
+Proof.
+  assert (H := sin2_cos2 PI).
+  rewrite cos_PI in H.
+  rewrite <- Rsqr_neg in H.
+  rewrite Rsqr_1 in H.
+  cut (Rsqr (sin PI) = 0).
+  intro; apply (Rsqr_eq_0 _ H0).
+  apply Rplus_eq_reg_l with 1.
+  rewrite Rplus_0_r; rewrite Rplus_comm; exact H.
 Qed.
 
 (**********)
 Lemma neg_cos : forall x:R, cos (x + PI) = - cos x.
-intro x; rewrite cos_plus; rewrite sin_PI; rewrite cos_PI; ring.
+Proof.
+  intro x; rewrite cos_plus; rewrite sin_PI; rewrite cos_PI; ring.
 Qed.
 
 (**********)
 Lemma sin_cos : forall x:R, sin x = - cos (PI / 2 + x).
-intro x; rewrite cos_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Proof.
+  intro x; rewrite cos_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
 Qed.
 
 (**********)
 Lemma sin_plus : forall x y:R, sin (x + y) = sin x * cos y + cos x * sin y.
-intros.
-rewrite (sin_cos (x + y)).
-replace (PI / 2 + (x + y)) with (PI / 2 + x + y); [ rewrite cos_plus | ring ].
-rewrite (sin_cos (PI / 2 + x)).
-replace (PI / 2 + (PI / 2 + x)) with (x + PI).
-rewrite neg_cos.
-replace (cos (PI / 2 + x)) with (- sin x).
-ring.
-rewrite sin_cos; rewrite Ropp_involutive; reflexivity.
-pattern PI at 1 in |- *; rewrite (double_var PI); ring.
+Proof.
+  intros.
+  rewrite (sin_cos (x + y)).
+  replace (PI / 2 + (x + y)) with (PI / 2 + x + y); [ rewrite cos_plus | ring ].
+  rewrite (sin_cos (PI / 2 + x)).
+  replace (PI / 2 + (PI / 2 + x)) with (x + PI).
+  rewrite neg_cos.
+  replace (cos (PI / 2 + x)) with (- sin x).
+  ring.
+  rewrite sin_cos; rewrite Ropp_involutive; reflexivity.
+  pattern PI at 1 in |- *; rewrite (double_var PI); ring.
 Qed.
 
 Lemma sin_minus : forall x y:R, sin (x - y) = sin x * cos y - cos x * sin y.
-intros; unfold Rminus in |- *; rewrite sin_plus.
-rewrite <- cos_sym; rewrite sin_antisym; ring.
+Proof.
+  intros; unfold Rminus in |- *; rewrite sin_plus.
+  rewrite <- cos_sym; rewrite sin_antisym; ring.
 Qed.
 
 (**********)
 Definition tan (x:R) : R := sin x / cos x.
 
 Lemma tan_plus :
- forall x y:R,
-   cos x <> 0 ->
-   cos y <> 0 ->
-   cos (x + y) <> 0 ->
-   1 - tan x * tan y <> 0 ->
-   tan (x + y) = (tan x + tan y) / (1 - tan x * tan y).
-intros; unfold tan in |- *; rewrite sin_plus; rewrite cos_plus;
- unfold Rdiv in |- *;
- replace (cos x * cos y - sin x * sin y) with
-  (cos x * cos y * (1 - sin x * / cos x * (sin y * / cos y))).
-rewrite Rinv_mult_distr.
-repeat rewrite <- Rmult_assoc;
- replace ((sin x * cos y + cos x * sin y) * / (cos x * cos y)) with
-  (sin x * / cos x + sin y * / cos y).
-reflexivity.
-rewrite Rmult_plus_distr_r; rewrite Rinv_mult_distr.
-repeat rewrite Rmult_assoc; repeat rewrite (Rmult_comm (sin x));
- repeat rewrite <- Rmult_assoc.
-repeat rewrite Rinv_r_simpl_m; [ reflexivity | assumption | assumption ].
-assumption.
-assumption.
-apply prod_neq_R0; assumption.
-assumption.
-unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
- apply Rplus_eq_compat_l; repeat rewrite Rmult_assoc;
- rewrite (Rmult_comm (sin x)); rewrite (Rmult_comm (cos y));
- rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite <- Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; rewrite (Rmult_comm (sin x));
- rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc;
- apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); 
- rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-apply Rmult_1_r.
-assumption.
-assumption.
+  forall x y:R,
+    cos x <> 0 ->
+    cos y <> 0 ->
+    cos (x + y) <> 0 ->
+    1 - tan x * tan y <> 0 ->
+    tan (x + y) = (tan x + tan y) / (1 - tan x * tan y).
+Proof.
+  intros; unfold tan in |- *; rewrite sin_plus; rewrite cos_plus;
+    unfold Rdiv in |- *;
+      replace (cos x * cos y - sin x * sin y) with
+      (cos x * cos y * (1 - sin x * / cos x * (sin y * / cos y))).
+  rewrite Rinv_mult_distr.
+  repeat rewrite <- Rmult_assoc;
+    replace ((sin x * cos y + cos x * sin y) * / (cos x * cos y)) with
+    (sin x * / cos x + sin y * / cos y).
+  reflexivity.
+  rewrite Rmult_plus_distr_r; rewrite Rinv_mult_distr.
+  repeat rewrite Rmult_assoc; repeat rewrite (Rmult_comm (sin x));
+    repeat rewrite <- Rmult_assoc.
+  repeat rewrite Rinv_r_simpl_m; [ reflexivity | assumption | assumption ].
+  assumption.
+  assumption.
+  apply prod_neq_R0; assumption.
+  assumption.
+  unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
+    apply Rplus_eq_compat_l; repeat rewrite Rmult_assoc;
+      rewrite (Rmult_comm (sin x)); rewrite (Rmult_comm (cos y));
+        rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite <- Rmult_assoc;
+          rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite (Rmult_comm (sin x));
+    rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc;
+      apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); 
+        rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  apply Rmult_1_r.
+  assumption.
+  assumption.
 Qed.
 
 (*******************************************************)
-(* Some properties of cos, sin and tan                 *)
+(** * Some properties of cos, sin and tan              *)
 (*******************************************************)
 
 Lemma sin2 : forall x:R, Rsqr (sin x) = 1 - Rsqr (cos x).
-intro x; generalize (cos2 x); intro H1; rewrite H1.
-unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
- rewrite Rplus_opp_r; rewrite Rplus_0_l; symmetry  in |- *;
- apply Ropp_involutive.
+Proof.
+  intro x; generalize (cos2 x); intro H1; rewrite H1.
+  unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_l; symmetry  in |- *;
+      apply Ropp_involutive.
 Qed.
 
 Lemma sin_2a : forall x:R, sin (2 * x) = 2 * sin x * cos x.
-intro x; rewrite double; rewrite sin_plus.
-rewrite <- (Rmult_comm (sin x)); symmetry  in |- *; rewrite Rmult_assoc;
- apply double.
+Proof.
+  intro x; rewrite double; rewrite sin_plus.
+  rewrite <- (Rmult_comm (sin x)); symmetry  in |- *; rewrite Rmult_assoc;
+    apply double.
 Qed.
 
 Lemma cos_2a : forall x:R, cos (2 * x) = cos x * cos x - sin x * sin x.
-intro x; rewrite double; apply cos_plus.
+Proof.
+  intro x; rewrite double; apply cos_plus.
 Qed.
 
 Lemma cos_2a_cos : forall x:R, cos (2 * x) = 2 * cos x * cos x - 1.
-intro x; rewrite double; unfold Rminus in |- *; rewrite Rmult_assoc;
- rewrite cos_plus; generalize (sin2_cos2 x); rewrite double; 
- intro H1; rewrite <- H1; ring_Rsqr.
+Proof.
+  intro x; rewrite double; unfold Rminus in |- *; rewrite Rmult_assoc;
+    rewrite cos_plus; generalize (sin2_cos2 x); rewrite double; 
+      intro H1; rewrite <- H1; ring_Rsqr.
 Qed.
 
 Lemma cos_2a_sin : forall x:R, cos (2 * x) = 1 - 2 * sin x * sin x.
-intro x; rewrite Rmult_assoc; unfold Rminus in |- *; repeat rewrite double.
-generalize (sin2_cos2 x); intro H1; rewrite <- H1; rewrite cos_plus;
- ring_Rsqr.
+Proof.
+  intro x; rewrite Rmult_assoc; unfold Rminus in |- *; repeat rewrite double.
+  generalize (sin2_cos2 x); intro H1; rewrite <- H1; rewrite cos_plus;
+    ring_Rsqr.
 Qed.
 
 Lemma tan_2a :
- forall x:R,
-   cos x <> 0 ->
-   cos (2 * x) <> 0 ->
-   1 - tan x * tan x <> 0 -> tan (2 * x) = 2 * tan x / (1 - tan x * tan x).
-repeat rewrite double; intros; repeat rewrite double; rewrite double in H0;
- apply tan_plus; assumption.
+  forall x:R,
+    cos x <> 0 ->
+    cos (2 * x) <> 0 ->
+    1 - tan x * tan x <> 0 -> tan (2 * x) = 2 * tan x / (1 - tan x * tan x).
+Proof.
+  repeat rewrite double; intros; repeat rewrite double; rewrite double in H0;
+    apply tan_plus; assumption.
 Qed.
 
 Lemma sin_neg : forall x:R, sin (- x) = - sin x.
-apply sin_antisym.
+Proof.
+  apply sin_antisym.
 Qed.
 
 Lemma cos_neg : forall x:R, cos (- x) = cos x.
-intro; symmetry  in |- *; apply cos_sym.
+Proof.
+  intro; symmetry  in |- *; apply cos_sym.
 Qed.
 
 Lemma tan_0 : tan 0 = 0.
-unfold tan in |- *; rewrite sin_0; rewrite cos_0.
-unfold Rdiv in |- *; apply Rmult_0_l. 
+Proof.
+  unfold tan in |- *; rewrite sin_0; rewrite cos_0.
+  unfold Rdiv in |- *; apply Rmult_0_l. 
 Qed.
 
 Lemma tan_neg : forall x:R, tan (- x) = - tan x.
-intros x; unfold tan in |- *; rewrite sin_neg; rewrite cos_neg;
- unfold Rdiv in |- *.
-apply Ropp_mult_distr_l_reverse.
+Proof.
+  intros x; unfold tan in |- *; rewrite sin_neg; rewrite cos_neg;
+    unfold Rdiv in |- *.
+  apply Ropp_mult_distr_l_reverse.
 Qed.
 
 Lemma tan_minus :
- forall x y:R,
-   cos x <> 0 ->
-   cos y <> 0 ->
-   cos (x - y) <> 0 ->
-   1 + tan x * tan y <> 0 ->
-   tan (x - y) = (tan x - tan y) / (1 + tan x * tan y).
-intros; unfold Rminus in |- *; rewrite tan_plus.
-rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
- rewrite Rmult_opp_opp; reflexivity.
-assumption.
-rewrite cos_neg; assumption.
-assumption.
-rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
- rewrite Rmult_opp_opp; assumption.
+  forall x y:R,
+    cos x <> 0 ->
+    cos y <> 0 ->
+    cos (x - y) <> 0 ->
+    1 + tan x * tan y <> 0 ->
+    tan (x - y) = (tan x - tan y) / (1 + tan x * tan y).
+Proof.
+  intros; unfold Rminus in |- *; rewrite tan_plus.
+  rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+    rewrite Rmult_opp_opp; reflexivity.
+  assumption.
+  rewrite cos_neg; assumption.
+  assumption.
+  rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+    rewrite Rmult_opp_opp; assumption.
 Qed.
 
 Lemma cos_3PI2 : cos (3 * (PI / 2)) = 0.
-replace (3 * (PI / 2)) with (PI + PI / 2).
-rewrite cos_plus; rewrite sin_PI; rewrite cos_PI2; ring.
-pattern PI at 1 in |- *; rewrite (double_var PI).
-ring.
+Proof.
+  replace (3 * (PI / 2)) with (PI + PI / 2).
+  rewrite cos_plus; rewrite sin_PI; rewrite cos_PI2; ring.
+  pattern PI at 1 in |- *; rewrite (double_var PI).
+  ring.
 Qed.
 
 Lemma sin_2PI : sin (2 * PI) = 0.
-rewrite sin_2a; rewrite sin_PI; ring.
+Proof.
+  rewrite sin_2a; rewrite sin_PI; ring.
 Qed.
 
 Lemma cos_2PI : cos (2 * PI) = 1.
-rewrite cos_2a; rewrite sin_PI; rewrite cos_PI; ring.
+Proof.
+  rewrite cos_2a; rewrite sin_PI; rewrite cos_PI; ring.
 Qed.
 
 Lemma neg_sin : forall x:R, sin (x + PI) = - sin x.
-intro x; rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; ring.
+Proof.
+  intro x; rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; ring.
 Qed.
 
 Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x.
-intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l;
- unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse;
- rewrite Ropp_involutive; apply Rmult_1_l.
+Proof.
+  intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l;
+    unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse;
+      rewrite Ropp_involutive; apply Rmult_1_l.
 Qed.
 
 Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x.
-intros x k; induction  k as [| k Hreck].
-cut (x + 2 * INR 0 * PI = x); [ intro; rewrite H; reflexivity | ring ].
-replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI);
- [ rewrite sin_plus; rewrite sin_2PI; rewrite cos_2PI; ring; apply Hreck
- | rewrite S_INR; ring ].
+Proof.
+  intros x k; induction  k as [| k Hreck].
+  simpl in |- *;  ring_simplify (x + 2 * 0 * PI).
+  trivial.
+
+  replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI).
+  rewrite sin_plus in |- *; rewrite sin_2PI in |- *; rewrite cos_2PI in |- *.
+  ring_simplify; trivial.
+  rewrite S_INR in |- *;  ring.
 Qed.
 
 Lemma cos_period : forall (x:R) (k:nat), cos (x + 2 * INR k * PI) = cos x.
-intros x k; induction  k as [| k Hreck].
-cut (x + 2 * INR 0 * PI = x); [ intro; rewrite H; reflexivity | ring ].
-replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI);
- [ rewrite cos_plus; rewrite sin_2PI; rewrite cos_2PI; ring; apply Hreck
- | rewrite S_INR; ring ].
+Proof.
+  intros x k; induction  k as [| k Hreck].
+  simpl in |- *;  ring_simplify (x + 2 * 0 * PI).
+  trivial.
+
+  replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI).
+  rewrite cos_plus in |- *; rewrite sin_2PI in |- *; rewrite cos_2PI in |- *.
+  ring_simplify; trivial.
+  rewrite S_INR in |- *;  ring.
 Qed.
 
 Lemma sin_shift : forall x:R, sin (PI / 2 - x) = cos x.
-intro x; rewrite sin_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Proof.
+  intro x; rewrite sin_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
 Qed.
 
 Lemma cos_shift : forall x:R, cos (PI / 2 - x) = sin x.
-intro x; rewrite cos_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Proof.
+  intro x; rewrite cos_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
 Qed.
 
 Lemma cos_sin : forall x:R, cos x = sin (PI / 2 + x).
-intro x; rewrite sin_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Proof.
+  intro x; rewrite sin_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
 Qed.
 
 Lemma PI2_RGT_0 : 0 < PI / 2.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ].
+Proof.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ].
 Qed. 
 
 Lemma SIN_bound : forall x:R, -1 <= sin x <= 1.
-intro; case (Rle_dec (-1) (sin x)); intro.
-case (Rle_dec (sin x) 1); intro.
-split; assumption.
-cut (1 < sin x).
-intro;
- generalize
-  (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1)
-     (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); 
- rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0;
- generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
- repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; 
- rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
- generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
- repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); 
- intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
-auto with real.
-cut (sin x < -1).
-intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H);
- rewrite Ropp_involutive; clear H; intro;
- generalize
-  (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1)
-     (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H)));
- rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; 
- rewrite sin2 in H0; unfold Rminus in H0;
- generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
- repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; 
- rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
- generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
- repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); 
- intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
-auto with real.
+Proof.
+  intro; case (Rle_dec (-1) (sin x)); intro.
+  case (Rle_dec (sin x) 1); intro.
+  split; assumption.
+  cut (1 < sin x).
+  intro;
+    generalize
+      (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1)
+        (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); 
+      rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0;
+        generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
+          repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; 
+            rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
+              generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
+                repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); 
+                  intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
+  auto with real.
+  cut (sin x < -1).
+  intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H);
+    rewrite Ropp_involutive; clear H; intro;
+      generalize
+        (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1)
+          (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H)));
+        rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; 
+          rewrite sin2 in H0; unfold Rminus in H0;
+            generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
+              repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; 
+                rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
+                  generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
+                    repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); 
+                      intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
+  auto with real.
 Qed.
 
 Lemma COS_bound : forall x:R, -1 <= cos x <= 1.
-intro; rewrite <- sin_shift; apply SIN_bound.
+Proof.
+  intro; rewrite <- sin_shift; apply SIN_bound.
 Qed.
 
 Lemma cos_sin_0 : forall x:R, ~ (cos x = 0 /\ sin x = 0).
-intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro;
- rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2;
- rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; 
- rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3).
+Proof.
+  intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro;
+    rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2;
+      rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; 
+        rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3).
 Qed.
-  
+
 Lemma cos_sin_0_var : forall x:R, cos x <> 0 \/ sin x <> 0.
-intro; apply not_and_or; apply cos_sin_0.
+Proof.
+  intro; apply not_and_or; apply cos_sin_0.
 Qed.
 
 (*****************************************************************)
-(* Using series definitions of cos and sin                       *)
+(** * Using series definitions of cos and sin                    *)
 (*****************************************************************)
 
 Definition sin_lb (a:R) : R := sin_approx a 3.
@@ -341,1367 +385,1419 @@ Definition cos_lb (a:R) : R := cos_approx a 3.
 Definition cos_ub (a:R) : R := cos_approx a 4.
 
 Lemma sin_lb_gt_0 : forall a:R, 0 < a -> a <= PI / 2 -> 0 < sin_lb a.
-intros.
-unfold sin_lb in |- *; unfold sin_approx in |- *; unfold sin_term in |- *.
-set (Un := fun i:nat => a ^ (2 * i + 1) / INR (fact (2 * i + 1))).
-replace
- (sum_f_R0
+Proof.
+  intros.
+  unfold sin_lb in |- *; unfold sin_approx in |- *; unfold sin_term in |- *.
+  set (Un := fun i:nat => a ^ (2 * i + 1) / INR (fact (2 * i + 1))).
+  replace
+  (sum_f_R0
     (fun i:nat => (-1) ^ i * (a ^ (2 * i + 1) / INR (fact (2 * i + 1)))) 3)
- with (sum_f_R0 (fun i:nat => (-1) ^ i * Un i) 3);
- [ idtac | apply sum_eq; intros; unfold Un in |- *; reflexivity ].
-cut (forall n:nat, Un (S n) < Un n).
-intro; simpl in |- *.
-repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r;
- replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ];
- replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ];
- replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); 
- [ idtac | ring ];
- replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with
-  (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ].
-apply Rplus_lt_0_compat.
-unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 1%nat);
- rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat)); 
- rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
- apply H1.
-unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 3%nat);
- rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); 
- rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
- apply H1.
-intro; unfold Un in |- *.
-cut ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat).
-intro; rewrite H1.
-rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
- apply Rmult_lt_compat_l.
-apply pow_lt; assumption.
-rewrite <- H1; apply Rmult_lt_reg_l with (INR (fact (2 * n + 1))).
-apply lt_INR_0; apply neq_O_lt.
-assert (H2 := fact_neq_0 (2 * n + 1)).
-red in |- *; intro; elim H2; symmetry  in |- *; assumption.
-rewrite <- Rinv_r_sym.
-apply Rmult_lt_reg_l with (INR (fact (2 * S n + 1))).
-apply lt_INR_0; apply neq_O_lt.
-assert (H2 := fact_neq_0 (2 * S n + 1)).
-red in |- *; intro; elim H2; symmetry  in |- *; assumption.
-rewrite (Rmult_comm (INR (fact (2 * S n + 1)))); repeat rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-do 2 rewrite Rmult_1_r; apply Rle_lt_trans with (INR (fact (2 * n + 1)) * 4).
-apply Rmult_le_compat_l.
-replace 0 with (INR 0); [ idtac | reflexivity ]; apply le_INR; apply le_O_n.
-simpl in |- *; rewrite Rmult_1_r; replace 4 with (Rsqr 2);
- [ idtac | ring_Rsqr ]; replace (a * a) with (Rsqr a);
- [ idtac | reflexivity ]; apply Rsqr_incr_1.
-apply Rle_trans with (PI / 2);
- [ assumption
- | unfold Rdiv in |- *; apply Rmult_le_reg_l with 2;
-    [ prove_sup0
-    | rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m;
-       [ replace 4 with 4; [ apply PI_4 | ring ] | discrR ] ] ].
-left; assumption.
-left; prove_sup0.
-rewrite H1; replace (2 * n + 1 + 2)%nat with (S (S (2 * n + 1))).
-do 2 rewrite fact_simpl; do 2 rewrite mult_INR.
-repeat rewrite <- Rmult_assoc.
-rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))).
-rewrite Rmult_assoc.
-apply Rmult_lt_compat_l.
-apply lt_INR_0; apply neq_O_lt.
-assert (H2 := fact_neq_0 (2 * n + 1)).
-red in |- *; intro; elim H2; symmetry  in |- *; assumption.
-do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n);
- unfold INR in |- *.
-replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6);
- [ idtac | ring ].
-apply Rplus_lt_reg_r with (-4); rewrite Rplus_opp_l;
- replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2);
- [ idtac | ring ].
-apply Rplus_le_lt_0_compat.
-cut (0 <= x).
-intro; apply Rplus_le_le_0_compat; repeat apply Rmult_le_pos;
- assumption || left; prove_sup.
-unfold x in |- *; replace 0 with (INR 0);
- [ apply le_INR; apply le_O_n | reflexivity ].
-prove_sup0.
-apply INR_eq; do 2 rewrite S_INR; do 3 rewrite plus_INR; rewrite mult_INR;
- repeat rewrite S_INR; ring.
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_eq; do 3 rewrite plus_INR; do 2 rewrite mult_INR;
- repeat rewrite S_INR; ring.
+    with (sum_f_R0 (fun i:nat => (-1) ^ i * Un i) 3);
+      [ idtac | apply sum_eq; intros; unfold Un in |- *; reflexivity ].
+  cut (forall n:nat, Un (S n) < Un n).
+  intro; simpl in |- *.
+  repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r;
+    replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ];
+    replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ];
+    replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); 
+    [ idtac | ring ];
+    replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with
+    (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ].
+  apply Rplus_lt_0_compat.
+  unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 1%nat);
+    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat)); 
+      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+        apply H1.
+  unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 3%nat);
+    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); 
+      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
+        apply H1.
+  intro; unfold Un in |- *.
+  cut ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat).
+  intro; rewrite H1.
+  rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
+    apply Rmult_lt_compat_l.
+  apply pow_lt; assumption.
+  rewrite <- H1; apply Rmult_lt_reg_l with (INR (fact (2 * n + 1))).
+  apply lt_INR_0; apply neq_O_lt.
+  assert (H2 := fact_neq_0 (2 * n + 1)).
+  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_lt_reg_l with (INR (fact (2 * S n + 1))).
+  apply lt_INR_0; apply neq_O_lt.
+  assert (H2 := fact_neq_0 (2 * S n + 1)).
+  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+  rewrite (Rmult_comm (INR (fact (2 * S n + 1)))); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  do 2 rewrite Rmult_1_r; apply Rle_lt_trans with (INR (fact (2 * n + 1)) * 4).
+  apply Rmult_le_compat_l.
+  replace 0 with (INR 0); [ idtac | reflexivity ]; apply le_INR; apply le_O_n.
+  simpl in |- *; rewrite Rmult_1_r; replace 4 with (Rsqr 2);
+    [ idtac | ring_Rsqr ]; replace (a * a) with (Rsqr a);
+    [ idtac | reflexivity ]; apply Rsqr_incr_1.
+  apply Rle_trans with (PI / 2);
+    [ assumption
+      | unfold Rdiv in |- *; apply Rmult_le_reg_l with 2;
+        [ prove_sup0
+          | rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m;
+            [ replace 4 with 4; [ apply PI_4 | ring ] | discrR ] ] ].
+  left; assumption.
+  left; prove_sup0.
+  rewrite H1; replace (2 * n + 1 + 2)%nat with (S (S (2 * n + 1))).
+  do 2 rewrite fact_simpl; do 2 rewrite mult_INR.
+  repeat rewrite <- Rmult_assoc.
+  rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))).
+  rewrite Rmult_assoc.
+  apply Rmult_lt_compat_l.
+  apply lt_INR_0; apply neq_O_lt.
+  assert (H2 := fact_neq_0 (2 * n + 1)).
+  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+  do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n);
+    unfold INR in |- *.
+  replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6);
+  [ idtac | ring ].
+  apply Rplus_lt_reg_r with (-4); rewrite Rplus_opp_l;
+    replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2);
+    [ idtac | ring ].
+  apply Rplus_le_lt_0_compat.
+  cut (0 <= x).
+  intro; apply Rplus_le_le_0_compat; repeat apply Rmult_le_pos;
+    assumption || left; prove_sup.
+  unfold x in |- *; replace 0 with (INR 0);
+    [ apply le_INR; apply le_O_n | reflexivity ].
+  prove_sup0.
+  ring.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  ring.
 Qed.
 
 Lemma SIN : forall a:R, 0 <= a -> a <= PI -> sin_lb a <= sin a <= sin_ub a.
-intros; unfold sin_lb, sin_ub in |- *; apply (sin_bound a 1 H H0).
+  intros; unfold sin_lb, sin_ub in |- *; apply (sin_bound a 1 H H0).
 Qed.
 
 Lemma COS :
- forall a:R, - PI / 2 <= a -> a <= PI / 2 -> cos_lb a <= cos a <= cos_ub a.
-intros; unfold cos_lb, cos_ub in |- *; apply (cos_bound a 1 H H0).
+  forall a:R, - PI / 2 <= a -> a <= PI / 2 -> cos_lb a <= cos a <= cos_ub a.
+  intros; unfold cos_lb, cos_ub in |- *; apply (cos_bound a 1 H H0).
 Qed.
 
 (**********)
 Lemma _PI2_RLT_0 : - (PI / 2) < 0.
-rewrite <- Ropp_0; apply Ropp_lt_contravar; apply PI2_RGT_0.
+Proof.
+  rewrite <- Ropp_0; apply Ropp_lt_contravar; apply PI2_RGT_0.
 Qed.
 
 Lemma PI4_RLT_PI2 : PI / 4 < PI / 2.
-unfold Rdiv in |- *; apply Rmult_lt_compat_l.
-apply PI_RGT_0.
-apply Rinv_lt_contravar.
-apply Rmult_lt_0_compat; prove_sup0.
-pattern 2 at 1 in |- *; rewrite <- Rplus_0_r.
-replace 4 with (2 + 2); [ apply Rplus_lt_compat_l; prove_sup0 | ring ].
+Proof.
+  unfold Rdiv in |- *; apply Rmult_lt_compat_l.
+  apply PI_RGT_0.
+  apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat; prove_sup0.
+  pattern 2 at 1 in |- *; rewrite <- Rplus_0_r.
+  replace 4 with (2 + 2); [ apply Rplus_lt_compat_l; prove_sup0 | ring ].
 Qed.
 
 Lemma PI2_Rlt_PI : PI / 2 < PI.
-unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r.
-apply Rmult_lt_compat_l.
-apply PI_RGT_0.
-pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar.
-rewrite Rmult_1_l; prove_sup0.
-pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- apply Rlt_0_1.
-Qed.
-
-(********************************************)
-(* Increasing and decreasing of COS and SIN *)
-(********************************************)
+Proof.
+  unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r.
+  apply Rmult_lt_compat_l.
+  apply PI_RGT_0.
+  pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar.
+  rewrite Rmult_1_l; prove_sup0.
+  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    apply Rlt_0_1.
+Qed.
+
+(***************************************************)
+(** * Increasing and decreasing of [cos] and [sin] *)
+(***************************************************)
 Theorem sin_gt_0 : forall x:R, 0 < x -> x < PI -> 0 < sin x.
-intros; elim (SIN x (Rlt_le 0 x H) (Rlt_le x PI H0)); intros H1 _;
- case (Rtotal_order x (PI / 2)); intro H2.
-apply Rlt_le_trans with (sin_lb x).
-apply sin_lb_gt_0; [ assumption | left; assumption ].
-assumption.
-elim H2; intro H3.
-rewrite H3; rewrite sin_PI2; apply Rlt_0_1.
-rewrite <- sin_PI_x; generalize (Ropp_gt_lt_contravar x (PI / 2) H3);
- intro H4; generalize (Rplus_lt_compat_l PI (- x) (- (PI / 2)) H4).
-replace (PI + - x) with (PI - x).
-replace (PI + - (PI / 2)) with (PI / 2).
-intro H5; generalize (Ropp_lt_gt_contravar x PI H0); intro H6;
- change (- PI < - x) in H6; generalize (Rplus_lt_compat_l PI (- PI) (- x) H6).
-rewrite Rplus_opp_r.
-replace (PI + - x) with (PI - x).
-intro H7;
- elim
-  (SIN (PI - x) (Rlt_le 0 (PI - x) H7)
-     (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI)));
- intros H8 _;
- generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); 
- intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8).
-reflexivity.
-pattern PI at 2 in |- *; rewrite double_var; ring.
-reflexivity.
+Proof.
+  intros; elim (SIN x (Rlt_le 0 x H) (Rlt_le x PI H0)); intros H1 _;
+    case (Rtotal_order x (PI / 2)); intro H2.
+  apply Rlt_le_trans with (sin_lb x).
+  apply sin_lb_gt_0; [ assumption | left; assumption ].
+  assumption.
+  elim H2; intro H3.
+  rewrite H3; rewrite sin_PI2; apply Rlt_0_1.
+  rewrite <- sin_PI_x; generalize (Ropp_gt_lt_contravar x (PI / 2) H3);
+    intro H4; generalize (Rplus_lt_compat_l PI (- x) (- (PI / 2)) H4).
+  replace (PI + - x) with (PI - x).
+  replace (PI + - (PI / 2)) with (PI / 2).
+  intro H5; generalize (Ropp_lt_gt_contravar x PI H0); intro H6;
+    change (- PI < - x) in H6; generalize (Rplus_lt_compat_l PI (- PI) (- x) H6).
+  rewrite Rplus_opp_r.
+  replace (PI + - x) with (PI - x).
+  intro H7;
+    elim
+      (SIN (PI - x) (Rlt_le 0 (PI - x) H7)
+        (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI)));
+      intros H8 _;
+        generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); 
+          intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8).
+  reflexivity.
+  pattern PI at 2 in |- *; rewrite double_var; ring.
+  reflexivity.
 Qed.
 
 Theorem cos_gt_0 : forall x:R, - (PI / 2) < x -> x < PI / 2 -> 0 < cos x.
-intros; rewrite cos_sin;
- generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H).
-rewrite Rplus_opp_r; intro H1;
- generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); 
- rewrite <- double_var; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2).
+Proof.
+  intros; rewrite cos_sin;
+    generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H).
+  rewrite Rplus_opp_r; intro H1;
+    generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); 
+      rewrite <- double_var; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2).
 Qed.
 
 Lemma sin_ge_0 : forall x:R, 0 <= x -> x <= PI -> 0 <= sin x.
-intros x H1 H2; elim H1; intro H3;
- [ elim H2; intro H4;
-    [ left; apply (sin_gt_0 x H3 H4)
-    | rewrite H4; right; symmetry  in |- *; apply sin_PI ]
- | rewrite <- H3; right; symmetry  in |- *; apply sin_0 ].
+Proof.
+  intros x H1 H2; elim H1; intro H3;
+    [ elim H2; intro H4;
+      [ left; apply (sin_gt_0 x H3 H4)
+        | rewrite H4; right; symmetry  in |- *; apply sin_PI ]
+      | rewrite <- H3; right; symmetry  in |- *; apply sin_0 ].
 Qed.
 
 Lemma cos_ge_0 : forall x:R, - (PI / 2) <= x -> x <= PI / 2 -> 0 <= cos x.
-intros x H1 H2; elim H1; intro H3;
- [ elim H2; intro H4;
-    [ left; apply (cos_gt_0 x H3 H4)
-    | rewrite H4; right; symmetry  in |- *; apply cos_PI2 ]
- | rewrite <- H3; rewrite cos_neg; right; symmetry  in |- *; apply cos_PI2 ].
+Proof.
+  intros x H1 H2; elim H1; intro H3;
+    [ elim H2; intro H4;
+      [ left; apply (cos_gt_0 x H3 H4)
+        | rewrite H4; right; symmetry  in |- *; apply cos_PI2 ]
+      | rewrite <- H3; rewrite cos_neg; right; symmetry  in |- *; apply cos_PI2 ].
 Qed.
 
 Lemma sin_le_0 : forall x:R, PI <= x -> x <= 2 * PI -> sin x <= 0.
-intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
- rewrite <- (Ropp_involutive (sin x)); apply Ropp_le_ge_contravar;
- rewrite <- neg_sin; replace (x + PI) with (x - PI + 2 * INR 1 * PI);
- [ rewrite (sin_period (x - PI) 1); apply sin_ge_0;
-    [ replace (x - PI) with (x + - PI);
-       [ rewrite Rplus_comm; replace 0 with (- PI + PI);
-          [ apply Rplus_le_compat_l; assumption | ring ]
-       | ring ]
-    | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
-       [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
-          [ apply Rplus_le_compat_l; assumption | ring ]
-       | ring ] ]
- | unfold INR in |- *; ring ].
+Proof.
+  intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
+    rewrite <- (Ropp_involutive (sin x)); apply Ropp_le_ge_contravar;
+      rewrite <- neg_sin; replace (x + PI) with (x - PI + 2 * INR 1 * PI);
+        [ rewrite (sin_period (x - PI) 1); apply sin_ge_0;
+          [ replace (x - PI) with (x + - PI);
+            [ rewrite Rplus_comm; replace 0 with (- PI + PI);
+              [ apply Rplus_le_compat_l; assumption | ring ]
+              | ring ]
+            | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
+              [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
+                [ apply Rplus_le_compat_l; assumption | ring ]
+                | ring ] ]
+          | unfold INR in |- *; ring ].
 Qed.
 
 Lemma cos_le_0 : forall x:R, PI / 2 <= x -> x <= 3 * (PI / 2) -> cos x <= 0.
-intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
- rewrite <- (Ropp_involutive (cos x)); apply Ropp_le_ge_contravar;
- rewrite <- neg_cos; replace (x + PI) with (x - PI + 2 * INR 1 * PI).
-rewrite cos_period; apply cos_ge_0.
-replace (- (PI / 2)) with (- PI + PI / 2).
-unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_le_compat_l;
- assumption.
-pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
- ring.
-unfold Rminus in |- *; rewrite Rplus_comm;
- replace (PI / 2) with (- PI + 3 * (PI / 2)).
-apply Rplus_le_compat_l; assumption.
-pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
- ring. 
-unfold INR in |- *; ring.
+Proof.
+  intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
+    rewrite <- (Ropp_involutive (cos x)); apply Ropp_le_ge_contravar;
+      rewrite <- neg_cos; replace (x + PI) with (x - PI + 2 * INR 1 * PI).
+  rewrite cos_period; apply cos_ge_0.
+  replace (- (PI / 2)) with (- PI + PI / 2).
+  unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_le_compat_l;
+    assumption.
+  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+    ring.
+  unfold Rminus in |- *; rewrite Rplus_comm;
+    replace (PI / 2) with (- PI + 3 * (PI / 2)).
+  apply Rplus_le_compat_l; assumption.
+  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+    ring. 
+  unfold INR in |- *; ring.
 Qed.
 
 Lemma sin_lt_0 : forall x:R, PI < x -> x < 2 * PI -> sin x < 0.
-intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (sin x));
- apply Ropp_lt_gt_contravar; rewrite <- neg_sin;
- replace (x + PI) with (x - PI + 2 * INR 1 * PI);
- [ rewrite (sin_period (x - PI) 1); apply sin_gt_0;
-    [ replace (x - PI) with (x + - PI);
-       [ rewrite Rplus_comm; replace 0 with (- PI + PI);
-          [ apply Rplus_lt_compat_l; assumption | ring ]
-       | ring ]
-    | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
-       [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
-          [ apply Rplus_lt_compat_l; assumption | ring ]
-       | ring ] ]
- | unfold INR in |- *; ring ].
+Proof.
+  intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (sin x));
+    apply Ropp_lt_gt_contravar; rewrite <- neg_sin;
+      replace (x + PI) with (x - PI + 2 * INR 1 * PI);
+      [ rewrite (sin_period (x - PI) 1); apply sin_gt_0;
+        [ replace (x - PI) with (x + - PI);
+          [ rewrite Rplus_comm; replace 0 with (- PI + PI);
+            [ apply Rplus_lt_compat_l; assumption | ring ]
+            | ring ]
+          | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
+            [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
+              [ apply Rplus_lt_compat_l; assumption | ring ]
+              | ring ] ]
+        | unfold INR in |- *; ring ].
 Qed.
 
 Lemma sin_lt_0_var : forall x:R, - PI < x -> x < 0 -> sin x < 0.
-intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H);
- replace (2 * PI + - PI) with PI;
- [ intro H1; rewrite Rplus_comm in H1;
-    generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); 
-    intro H2; rewrite (Rplus_comm (2 * PI)) in H2;
-    rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2;
-    rewrite <- (sin_period x 1); unfold INR in |- *;
-    replace (2 * 1 * PI) with (2 * PI);
-    [ apply (sin_lt_0 (x + 2 * PI) H1 H2) | ring ]
- | ring ].
+Proof.
+  intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H);
+    replace (2 * PI + - PI) with PI;
+    [ intro H1; rewrite Rplus_comm in H1;
+      generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); 
+        intro H2; rewrite (Rplus_comm (2 * PI)) in H2;
+          rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2;
+            rewrite <- (sin_period x 1); unfold INR in |- *;
+              replace (2 * 1 * PI) with (2 * PI);
+              [ apply (sin_lt_0 (x + 2 * PI) H1 H2) | ring ]
+      | ring ].
 Qed.
 
 Lemma cos_lt_0 : forall x:R, PI / 2 < x -> x < 3 * (PI / 2) -> cos x < 0.
-intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (cos x));
- apply Ropp_lt_gt_contravar; rewrite <- neg_cos;
- replace (x + PI) with (x - PI + 2 * INR 1 * PI).
-rewrite cos_period; apply cos_gt_0.
-replace (- (PI / 2)) with (- PI + PI / 2).
-unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l;
- assumption.
-pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
- ring. 
-unfold Rminus in |- *; rewrite Rplus_comm;
- replace (PI / 2) with (- PI + 3 * (PI / 2)).
-apply Rplus_lt_compat_l; assumption.
-pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
- ring. 
-unfold INR in |- *; ring.
+Proof.
+  intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (cos x));
+    apply Ropp_lt_gt_contravar; rewrite <- neg_cos;
+      replace (x + PI) with (x - PI + 2 * INR 1 * PI).
+  rewrite cos_period; apply cos_gt_0.
+  replace (- (PI / 2)) with (- PI + PI / 2).
+  unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l;
+    assumption.
+  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+    ring. 
+  unfold Rminus in |- *; rewrite Rplus_comm;
+    replace (PI / 2) with (- PI + 3 * (PI / 2)).
+  apply Rplus_lt_compat_l; assumption.
+  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+    ring. 
+  unfold INR in |- *; ring.
 Qed.
 
 Lemma tan_gt_0 : forall x:R, 0 < x -> x < PI / 2 -> 0 < tan x.
-intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0;
- generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros;
- generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5;
- generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); 
- intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply sin_gt_0; assumption.
-apply Rinv_0_lt_compat; apply cos_gt_0; assumption.
+Proof.
+  intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0;
+    generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros;
+      generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5;
+        generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); 
+          intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply sin_gt_0; assumption.
+  apply Rinv_0_lt_compat; apply cos_gt_0; assumption.
 Qed.
 
 Lemma tan_lt_0 : forall x:R, - (PI / 2) < x -> x < 0 -> tan x < 0.
-intros x H1 H2; unfold tan in |- *;
- generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); 
- intro H3; rewrite <- Ropp_0;
- replace (sin x / cos x) with (- (- sin x / cos x)).
-rewrite <- sin_neg; apply Ropp_gt_lt_contravar;
- change (0 < sin (- x) / cos x) in |- *; unfold Rdiv in |- *;
- apply Rmult_lt_0_compat.
-apply sin_gt_0.
-rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; assumption.
-apply Rlt_trans with (PI / 2).
-rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_gt_lt_contravar; assumption.
-apply PI2_Rlt_PI.
-apply Rinv_0_lt_compat; assumption.
-unfold Rdiv in |- *; ring.
+Proof.
+  intros x H1 H2; unfold tan in |- *;
+    generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); 
+      intro H3; rewrite <- Ropp_0;
+        replace (sin x / cos x) with (- (- sin x / cos x)).
+  rewrite <- sin_neg; apply Ropp_gt_lt_contravar;
+    change (0 < sin (- x) / cos x) in |- *; unfold Rdiv in |- *;
+      apply Rmult_lt_0_compat.
+  apply sin_gt_0.
+  rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; assumption.
+  apply Rlt_trans with (PI / 2).
+  rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_gt_lt_contravar; assumption.
+  apply PI2_Rlt_PI.
+  apply Rinv_0_lt_compat; assumption.
+  unfold Rdiv in |- *; ring.
 Qed.
 
 Lemma cos_ge_0_3PI2 :
- forall x:R, 3 * (PI / 2) <= x -> x <= 2 * PI -> 0 <= cos x.
-intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1);
- unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x).
-generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1;
- generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; 
- intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1).
-rewrite Rplus_opp_r. 
-intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3;
- generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; 
- intro H3;
- generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3).
-replace (2 * PI + - (3 * (PI / 2))) with (PI / 2).
-intro H4;
- apply
-  (cos_ge_0 (2 * PI - x)
-     (Rlt_le (- (PI / 2)) (2 * PI - x)
-        (Rlt_le_trans (- (PI / 2)) 0 (2 * PI - x) _PI2_RLT_0 H2)) H4).
-rewrite double; pattern PI at 2 3 in |- *; rewrite double_var; ring.
-ring.
+  forall x:R, 3 * (PI / 2) <= x -> x <= 2 * PI -> 0 <= cos x.
+Proof.
+  intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1);
+    unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x).
+  generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1;
+    generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; 
+      intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1).
+  rewrite Rplus_opp_r. 
+  intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3;
+    generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; 
+      intro H3;
+        generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3).
+  replace (2 * PI + - (3 * (PI / 2))) with (PI / 2).
+  intro H4;
+    apply
+      (cos_ge_0 (2 * PI - x)
+        (Rlt_le (- (PI / 2)) (2 * PI - x)
+          (Rlt_le_trans (- (PI / 2)) 0 (2 * PI - x) _PI2_RLT_0 H2)) H4).
+  rewrite double; pattern PI at 2 3 in |- *; rewrite double_var; ring.
+  ring.
 Qed.
 
 Lemma form1 :
- forall p q:R, cos p + cos q = 2 * cos ((p - q) / 2) * cos ((p + q) / 2).
-intros p q; pattern p at 1 in |- *;
- replace p with ((p - q) / 2 + (p + q) / 2).
-rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
-rewrite cos_plus; rewrite cos_minus; ring.
-pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  forall p q:R, cos p + cos q = 2 * cos ((p - q) / 2) * cos ((p + q) / 2).
+Proof.
+  intros p q; pattern p at 1 in |- *;
+    replace p with ((p - q) / 2 + (p + q) / 2).
+  rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
+  rewrite cos_plus; rewrite cos_minus; ring.
+  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
 Qed.
 
 Lemma form2 :
- forall p q:R, cos p - cos q = -2 * sin ((p - q) / 2) * sin ((p + q) / 2).
-intros p q; pattern p at 1 in |- *;
- replace p with ((p - q) / 2 + (p + q) / 2).
-rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
-rewrite cos_plus; rewrite cos_minus; ring.
-pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  forall p q:R, cos p - cos q = -2 * sin ((p - q) / 2) * sin ((p + q) / 2).
+Proof.
+  intros p q; pattern p at 1 in |- *;
+    replace p with ((p - q) / 2 + (p + q) / 2).
+  rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
+  rewrite cos_plus; rewrite cos_minus; ring.
+  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
 Qed.
 
 Lemma form3 :
- forall p q:R, sin p + sin q = 2 * cos ((p - q) / 2) * sin ((p + q) / 2).
-intros p q; pattern p at 1 in |- *;
- replace p with ((p - q) / 2 + (p + q) / 2).
-pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
-rewrite sin_plus; rewrite sin_minus; ring.
-pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  forall p q:R, sin p + sin q = 2 * cos ((p - q) / 2) * sin ((p + q) / 2).
+Proof.
+  intros p q; pattern p at 1 in |- *;
+    replace p with ((p - q) / 2 + (p + q) / 2).
+  pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
+  rewrite sin_plus; rewrite sin_minus; ring.
+  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
 Qed.
 
 Lemma form4 :
- forall p q:R, sin p - sin q = 2 * cos ((p + q) / 2) * sin ((p - q) / 2).
-intros p q; pattern p at 1 in |- *;
- replace p with ((p - q) / 2 + (p + q) / 2).
-pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
-rewrite sin_plus; rewrite sin_minus; ring.
-pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  forall p q:R, sin p - sin q = 2 * cos ((p + q) / 2) * sin ((p - q) / 2).
+Proof.
+  intros p q; pattern p at 1 in |- *;
+    replace p with ((p - q) / 2 + (p + q) / 2).
+  pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
+  rewrite sin_plus; rewrite sin_minus; ring.
+  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
 
 Qed.
 
 Lemma sin_increasing_0 :
- forall x y:R,
-   - (PI / 2) <= x ->
-   x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x < sin y -> x < y.
-intros; cut (sin ((x - y) / 2) < 0).
-intro H4; case (Rtotal_order ((x - y) / 2) 0); intro H5.
-assert (Hyp : 0 < 2).
-prove_sup0.
-generalize (Rmult_lt_compat_l 2 ((x - y) / 2) 0 Hyp H5).
-unfold Rdiv in |- *.
-rewrite <- Rmult_assoc.
-rewrite Rinv_r_simpl_m.
-rewrite Rmult_0_r.
-clear H5; intro H5; apply Rminus_lt; assumption.
-discrR.
-elim H5; intro H6.
-rewrite H6 in H4; rewrite sin_0 in H4; elim (Rlt_irrefl 0 H4).
-change (0 < (x - y) / 2) in H6;
- generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1).
-rewrite Ropp_involutive.
-intro H7; generalize (Rge_le (PI / 2) (- y) H7); clear H7; intro H7;
- generalize (Rplus_le_compat x (PI / 2) (- y) (PI / 2) H0 H7).
-rewrite <- double_var.
-intro H8.
-assert (Hyp : 0 < 2).
-prove_sup0.
-generalize
- (Rmult_le_compat_l (/ 2) (x - y) PI
-    (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8).
-repeat rewrite (Rmult_comm (/ 2)). 
-intro H9;
- generalize
-  (sin_gt_0 ((x - y) / 2) H6
-     (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); 
- intro H10;
- elim
-  (Rlt_irrefl (sin ((x - y) / 2))
-     (Rlt_trans (sin ((x - y) / 2)) 0 (sin ((x - y) / 2)) H4 H10)).
-generalize (Rlt_minus (sin x) (sin y) H3); clear H3; intro H3;
- rewrite form4 in H3;
- generalize (Rplus_le_compat x (PI / 2) y (PI / 2) H0 H2).
-rewrite <- double_var.
-assert (Hyp : 0 < 2).
-prove_sup0.
-intro H4;
- generalize
-  (Rmult_le_compat_l (/ 2) (x + y) PI
-     (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4).
-repeat rewrite (Rmult_comm (/ 2)). 
-clear H4; intro H4;
- generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1);
- replace (- (PI / 2) + - (PI / 2)) with (- PI).
-intro H5;
- generalize
-  (Rmult_le_compat_l (/ 2) (- PI) (x + y)
-     (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H5).
-replace (/ 2 * (x + y)) with ((x + y) / 2).
-replace (/ 2 * - PI) with (- (PI / 2)).
-clear H5; intro H5; elim H4; intro H40.
-elim H5; intro H50.
-generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6;
- generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6).
-rewrite Rmult_0_r. 
-clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7.
-assumption.
-generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7;
- generalize
-  (Rmult_le_pos (2 * cos ((x + y) / 2)) (sin ((x - y) / 2))
-     (Rlt_le 0 (2 * cos ((x + y) / 2)) H6) H7); intro H8;
- generalize
-  (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3);
- intro H9; elim (Rlt_irrefl 0 H9).
-rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3;
- rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; 
- elim (Rlt_irrefl 0 H3).
-unfold Rdiv in H3.
-rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50;
- rewrite H50 in H3; rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3;
- elim (Rlt_irrefl 0 H3).
-unfold Rdiv in |- *.
-rewrite <- Ropp_mult_distr_l_reverse.
-apply Rmult_comm.
-unfold Rdiv in |- *; apply Rmult_comm.
-pattern PI at 1 in |- *; rewrite double_var.
-rewrite Ropp_plus_distr.
-reflexivity.
+  forall x y:R,
+    - (PI / 2) <= x ->
+    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x < sin y -> x < y.
+Proof.
+  intros; cut (sin ((x - y) / 2) < 0).
+  intro H4; case (Rtotal_order ((x - y) / 2) 0); intro H5.
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  generalize (Rmult_lt_compat_l 2 ((x - y) / 2) 0 Hyp H5).
+  unfold Rdiv in |- *.
+  rewrite <- Rmult_assoc.
+  rewrite Rinv_r_simpl_m.
+  rewrite Rmult_0_r.
+  clear H5; intro H5; apply Rminus_lt; assumption.
+  discrR.
+  elim H5; intro H6.
+  rewrite H6 in H4; rewrite sin_0 in H4; elim (Rlt_irrefl 0 H4).
+  change (0 < (x - y) / 2) in H6;
+    generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1).
+  rewrite Ropp_involutive.
+  intro H7; generalize (Rge_le (PI / 2) (- y) H7); clear H7; intro H7;
+    generalize (Rplus_le_compat x (PI / 2) (- y) (PI / 2) H0 H7).
+  rewrite <- double_var.
+  intro H8.
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  generalize
+    (Rmult_le_compat_l (/ 2) (x - y) PI
+      (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8).
+  repeat rewrite (Rmult_comm (/ 2)). 
+  intro H9;
+    generalize
+      (sin_gt_0 ((x - y) / 2) H6
+        (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); 
+      intro H10;
+        elim
+          (Rlt_irrefl (sin ((x - y) / 2))
+            (Rlt_trans (sin ((x - y) / 2)) 0 (sin ((x - y) / 2)) H4 H10)).
+  generalize (Rlt_minus (sin x) (sin y) H3); clear H3; intro H3;
+    rewrite form4 in H3;
+      generalize (Rplus_le_compat x (PI / 2) y (PI / 2) H0 H2).
+  rewrite <- double_var.
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  intro H4;
+    generalize
+      (Rmult_le_compat_l (/ 2) (x + y) PI
+        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4).
+  repeat rewrite (Rmult_comm (/ 2)). 
+  clear H4; intro H4;
+    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1);
+      replace (- (PI / 2) + - (PI / 2)) with (- PI).
+  intro H5;
+    generalize
+      (Rmult_le_compat_l (/ 2) (- PI) (x + y)
+        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H5).
+  replace (/ 2 * (x + y)) with ((x + y) / 2).
+  replace (/ 2 * - PI) with (- (PI / 2)).
+  clear H5; intro H5; elim H4; intro H40.
+  elim H5; intro H50.
+  generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6;
+    generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6).
+  rewrite Rmult_0_r. 
+  clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7.
+  assumption.
+  generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7;
+    generalize
+      (Rmult_le_pos (2 * cos ((x + y) / 2)) (sin ((x - y) / 2))
+        (Rlt_le 0 (2 * cos ((x + y) / 2)) H6) H7); intro H8;
+      generalize
+        (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3);
+        intro H9; elim (Rlt_irrefl 0 H9).
+  rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3;
+    rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; 
+      elim (Rlt_irrefl 0 H3).
+  unfold Rdiv in H3.
+  rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50;
+    rewrite H50 in H3; rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3;
+      elim (Rlt_irrefl 0 H3).
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rmult_comm.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  pattern PI at 1 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  reflexivity.
 Qed.
 
 Lemma sin_increasing_1 :
- forall x y:R,
-   - (PI / 2) <= x ->
-   x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x < y -> sin x < sin y.
-intros; generalize (Rplus_lt_compat_l x x y H3); intro H4;
- generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) x H H);
- replace (- (PI / 2) + - (PI / 2)) with (- PI).
-assert (Hyp : 0 < 2).
-prove_sup0.
-intro H5; generalize (Rle_lt_trans (- PI) (x + x) (x + y) H5 H4); intro H6;
- generalize
-  (Rmult_lt_compat_l (/ 2) (- PI) (x + y) (Rinv_0_lt_compat 2 Hyp) H6);
- replace (/ 2 * - PI) with (- (PI / 2)).
-replace (/ 2 * (x + y)) with ((x + y) / 2).
-clear H4 H5 H6; intro H4; generalize (Rplus_lt_compat_l y x y H3); intro H5;
- rewrite Rplus_comm in H5;
- generalize (Rplus_le_compat y (PI / 2) y (PI / 2) H2 H2).
-rewrite <- double_var.
-intro H6; generalize (Rlt_le_trans (x + y) (y + y) PI H5 H6); intro H7;
- generalize (Rmult_lt_compat_l (/ 2) (x + y) PI (Rinv_0_lt_compat 2 Hyp) H7);
- replace (/ 2 * PI) with (PI / 2).
-replace (/ 2 * (x + y)) with ((x + y) / 2).
-clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1);
- rewrite Ropp_involutive; clear H1; intro H1;
- generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1;
- generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; 
- intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); 
- clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3);
- replace (- y + x) with (x - y).
-rewrite Rplus_opp_l.
-intro H6;
- generalize (Rmult_lt_compat_l (/ 2) (x - y) 0 (Rinv_0_lt_compat 2 Hyp) H6);
- rewrite Rmult_0_r; replace (/ 2 * (x - y)) with ((x - y) / 2).
-clear H6; intro H6;
- generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) (- y) H H2);
- replace (- (PI / 2) + - (PI / 2)) with (- PI).
-replace (x + - y) with (x - y).
-intro H7;
- generalize
-  (Rmult_le_compat_l (/ 2) (- PI) (x - y)
-     (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H7);
- replace (/ 2 * - PI) with (- (PI / 2)).
-replace (/ 2 * (x - y)) with ((x - y) / 2).
-clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4;
- generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8;
- generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); 
- clear H8; intro H8; cut (- PI < - (PI / 2)).
-intro H9;
- generalize
-  (sin_lt_0_var ((x - y) / 2)
-     (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); 
- intro H10;
- generalize
-  (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 (
-     2 * cos ((x + y) / 2)) H10 H8); intro H11; rewrite Rmult_0_r in H11;
- rewrite Rmult_comm; assumption.
-apply Ropp_lt_gt_contravar; apply PI2_Rlt_PI.
-unfold Rdiv in |- *; apply Rmult_comm.
-unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_comm.
-reflexivity.
-pattern PI at 1 in |- *; rewrite double_var.
-rewrite Ropp_plus_distr.
-reflexivity.
-unfold Rdiv in |- *; apply Rmult_comm.
-unfold Rminus in |- *; apply Rplus_comm.
-unfold Rdiv in |- *; apply Rmult_comm.
-unfold Rdiv in |- *; apply Rmult_comm.
-unfold Rdiv in |- *; apply Rmult_comm.
-unfold Rdiv in |- *.
-rewrite <- Ropp_mult_distr_l_reverse.
-apply Rmult_comm.
-pattern PI at 1 in |- *; rewrite double_var.
-rewrite Ropp_plus_distr.
-reflexivity.
+  forall x y:R,
+    - (PI / 2) <= x ->
+    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x < y -> sin x < sin y.
+Proof.
+  intros; generalize (Rplus_lt_compat_l x x y H3); intro H4;
+    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) x H H);
+      replace (- (PI / 2) + - (PI / 2)) with (- PI).
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  intro H5; generalize (Rle_lt_trans (- PI) (x + x) (x + y) H5 H4); intro H6;
+    generalize
+      (Rmult_lt_compat_l (/ 2) (- PI) (x + y) (Rinv_0_lt_compat 2 Hyp) H6);
+      replace (/ 2 * - PI) with (- (PI / 2)).
+  replace (/ 2 * (x + y)) with ((x + y) / 2).
+  clear H4 H5 H6; intro H4; generalize (Rplus_lt_compat_l y x y H3); intro H5;
+    rewrite Rplus_comm in H5;
+      generalize (Rplus_le_compat y (PI / 2) y (PI / 2) H2 H2).
+  rewrite <- double_var.
+  intro H6; generalize (Rlt_le_trans (x + y) (y + y) PI H5 H6); intro H7;
+    generalize (Rmult_lt_compat_l (/ 2) (x + y) PI (Rinv_0_lt_compat 2 Hyp) H7);
+      replace (/ 2 * PI) with (PI / 2).
+  replace (/ 2 * (x + y)) with ((x + y) / 2).
+  clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1);
+    rewrite Ropp_involutive; clear H1; intro H1;
+      generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1;
+        generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; 
+          intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); 
+            clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3);
+              replace (- y + x) with (x - y).
+  rewrite Rplus_opp_l.
+  intro H6;
+    generalize (Rmult_lt_compat_l (/ 2) (x - y) 0 (Rinv_0_lt_compat 2 Hyp) H6);
+      rewrite Rmult_0_r; replace (/ 2 * (x - y)) with ((x - y) / 2).
+  clear H6; intro H6;
+    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) (- y) H H2);
+      replace (- (PI / 2) + - (PI / 2)) with (- PI).
+  replace (x + - y) with (x - y).
+  intro H7;
+    generalize
+      (Rmult_le_compat_l (/ 2) (- PI) (x - y)
+        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H7);
+      replace (/ 2 * - PI) with (- (PI / 2)).
+  replace (/ 2 * (x - y)) with ((x - y) / 2).
+  clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4;
+    generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8;
+      generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); 
+        clear H8; intro H8; cut (- PI < - (PI / 2)).
+  intro H9;
+    generalize
+      (sin_lt_0_var ((x - y) / 2)
+        (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); 
+      intro H10;
+        generalize
+          (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 (
+            2 * cos ((x + y) / 2)) H10 H8); intro H11; rewrite Rmult_0_r in H11;
+          rewrite Rmult_comm; assumption.
+  apply Ropp_lt_gt_contravar; apply PI2_Rlt_PI.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_comm.
+  reflexivity.
+  pattern PI at 1 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  reflexivity.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rminus in |- *; apply Rplus_comm.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rmult_comm.
+  pattern PI at 1 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  reflexivity.
 Qed.
 
 Lemma sin_decreasing_0 :
- forall x y:R,
-   x <= 3 * (PI / 2) ->
-   PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x < sin y -> y < x.
-intros; rewrite <- (sin_PI_x x) in H3; rewrite <- (sin_PI_x y) in H3;
- generalize (Ropp_lt_gt_contravar (sin (PI - x)) (sin (PI - y)) H3);
- repeat rewrite <- sin_neg;
- generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
- generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
- generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
- generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
- replace (- PI + x) with (x - PI).
-replace (- PI + PI / 2) with (- (PI / 2)).
-replace (- PI + y) with (y - PI).
-replace (- PI + 3 * (PI / 2)) with (PI / 2).
-replace (- (PI - x)) with (x - PI).
-replace (- (PI - y)) with (y - PI).
-intros; change (sin (y - PI) < sin (x - PI)) in H8;
- apply Rplus_lt_reg_r with (- PI); rewrite Rplus_comm;
- replace (y + - PI) with (y - PI).
-rewrite Rplus_comm; replace (x + - PI) with (x - PI).
-apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8).
-reflexivity.
-reflexivity.
-unfold Rminus in |- *; rewrite Ropp_plus_distr.
-rewrite Ropp_involutive.
-apply Rplus_comm.
-unfold Rminus in |- *; rewrite Ropp_plus_distr.
-rewrite Ropp_involutive.
-apply Rplus_comm.
-pattern PI at 2 in |- *; rewrite double_var.
-rewrite Ropp_plus_distr.
-ring.
-unfold Rminus in |- *; apply Rplus_comm.
-pattern PI at 2 in |- *; rewrite double_var.
-rewrite Ropp_plus_distr.
-ring.
-unfold Rminus in |- *; apply Rplus_comm.
+  forall x y:R,
+    x <= 3 * (PI / 2) ->
+    PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x < sin y -> y < x.
+Proof.
+  intros; rewrite <- (sin_PI_x x) in H3; rewrite <- (sin_PI_x y) in H3;
+    generalize (Ropp_lt_gt_contravar (sin (PI - x)) (sin (PI - y)) H3);
+      repeat rewrite <- sin_neg;
+        generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
+          generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
+            generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
+              generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
+                replace (- PI + x) with (x - PI).
+  replace (- PI + PI / 2) with (- (PI / 2)).
+  replace (- PI + y) with (y - PI).
+  replace (- PI + 3 * (PI / 2)) with (PI / 2).
+  replace (- (PI - x)) with (x - PI).
+  replace (- (PI - y)) with (y - PI).
+  intros; change (sin (y - PI) < sin (x - PI)) in H8;
+    apply Rplus_lt_reg_r with (- PI); rewrite Rplus_comm;
+      replace (y + - PI) with (y - PI).
+  rewrite Rplus_comm; replace (x + - PI) with (x - PI).
+  apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8).
+  reflexivity.
+  reflexivity.
+  unfold Rminus in |- *; rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  apply Rplus_comm.
+  unfold Rminus in |- *; rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  apply Rplus_comm.
+  pattern PI at 2 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  ring.
+  unfold Rminus in |- *; apply Rplus_comm.
+  pattern PI at 2 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  ring.
+  unfold Rminus in |- *; apply Rplus_comm.
 Qed.
 
 Lemma sin_decreasing_1 :
- forall x y:R,
-   x <= 3 * (PI / 2) ->
-   PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> x < y -> sin y < sin x.
-intros; rewrite <- (sin_PI_x x); rewrite <- (sin_PI_x y);
- generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
- generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
- generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
- generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
- generalize (Rplus_lt_compat_l (- PI) x y H3);
- replace (- PI + PI / 2) with (- (PI / 2)).
-replace (- PI + y) with (y - PI).
-replace (- PI + 3 * (PI / 2)) with (PI / 2).
-replace (- PI + x) with (x - PI).
-intros; apply Ropp_lt_cancel; repeat rewrite <- sin_neg;
- replace (- (PI - x)) with (x - PI).
-replace (- (PI - y)) with (y - PI).
-apply (sin_increasing_1 (x - PI) (y - PI) H7 H8 H5 H6 H4).
-unfold Rminus in |- *; rewrite Ropp_plus_distr.
-rewrite Ropp_involutive.
-apply Rplus_comm.
-unfold Rminus in |- *; rewrite Ropp_plus_distr.
-rewrite Ropp_involutive.
-apply Rplus_comm.
-unfold Rminus in |- *; apply Rplus_comm.
-pattern PI at 2 in |- *; rewrite double_var; ring.
-unfold Rminus in |- *; apply Rplus_comm.
-pattern PI at 2 in |- *; rewrite double_var; ring.
+  forall x y:R,
+    x <= 3 * (PI / 2) ->
+    PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> x < y -> sin y < sin x.
+Proof.
+  intros; rewrite <- (sin_PI_x x); rewrite <- (sin_PI_x y);
+    generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
+      generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
+        generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
+          generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
+            generalize (Rplus_lt_compat_l (- PI) x y H3);
+              replace (- PI + PI / 2) with (- (PI / 2)).
+  replace (- PI + y) with (y - PI).
+  replace (- PI + 3 * (PI / 2)) with (PI / 2).
+  replace (- PI + x) with (x - PI).
+  intros; apply Ropp_lt_cancel; repeat rewrite <- sin_neg;
+    replace (- (PI - x)) with (x - PI).
+  replace (- (PI - y)) with (y - PI).
+  apply (sin_increasing_1 (x - PI) (y - PI) H7 H8 H5 H6 H4).
+  unfold Rminus in |- *; rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  apply Rplus_comm.
+  unfold Rminus in |- *; rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  apply Rplus_comm.
+  unfold Rminus in |- *; apply Rplus_comm.
+  pattern PI at 2 in |- *; rewrite double_var; ring.
+  unfold Rminus in |- *; apply Rplus_comm.
+  pattern PI at 2 in |- *; rewrite double_var; ring.
 Qed.
 
 Lemma cos_increasing_0 :
- forall x y:R,
-   PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x < cos y -> x < y.
-intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y);
- rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
- unfold INR in |- *;
- replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
-replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
-repeat rewrite cos_shift; intro H5;
- generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
- generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
- generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
- generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4).
-replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
-replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
-replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
-replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
-clear H1 H2 H3 H4; intros H1 H2 H3 H4;
- apply Rplus_lt_reg_r with (-3 * (PI / 2));
- replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
-replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
-apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5).
-unfold Rminus in |- *.
-rewrite Ropp_mult_distr_l_reverse. 
-apply Rplus_comm. 
-unfold Rminus in |- *.
-rewrite Ropp_mult_distr_l_reverse. 
-apply Rplus_comm. 
-pattern PI at 3 in |- *; rewrite double_var.
-ring.
-rewrite double; pattern PI at 3 4 in |- *; rewrite double_var.
-ring.
-unfold Rminus in |- *.
-rewrite Ropp_mult_distr_l_reverse. 
-apply Rplus_comm. 
-unfold Rminus in |- *.
-rewrite Ropp_mult_distr_l_reverse. 
-apply Rplus_comm. 
-rewrite Rmult_1_r.
-rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-ring.
-rewrite Rmult_1_r.
-rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-ring.
+  forall x y:R,
+    PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x < cos y -> x < y.
+Proof.
+  intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y);
+    rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
+      unfold INR in |- *;
+        replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
+  replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
+  repeat rewrite cos_shift; intro H5;
+    generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
+      generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
+        generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
+          generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4).
+  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
+  replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
+  clear H1 H2 H3 H4; intros H1 H2 H3 H4;
+    apply Rplus_lt_reg_r with (-3 * (PI / 2));
+      replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+  apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5).
+  unfold Rminus in |- *.
+  rewrite Ropp_mult_distr_l_reverse. 
+  apply Rplus_comm. 
+  unfold Rminus in |- *.
+  rewrite Ropp_mult_distr_l_reverse. 
+  apply Rplus_comm. 
+  pattern PI at 3 in |- *; rewrite double_var.
+  ring.
+  rewrite double; pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  unfold Rminus in |- *.
+  rewrite Ropp_mult_distr_l_reverse. 
+  apply Rplus_comm. 
+  unfold Rminus in |- *.
+  rewrite Ropp_mult_distr_l_reverse. 
+  apply Rplus_comm. 
+  rewrite Rmult_1_r.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  rewrite Rmult_1_r.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
 Qed.
 
 Lemma cos_increasing_1 :
- forall x y:R,
-   PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x < y -> cos x < cos y.
-intros x y H1 H2 H3 H4 H5;
- generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
- generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
- generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
- generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4);
- generalize (Rplus_lt_compat_l (-3 * (PI / 2)) x y H5);
- rewrite <- (cos_neg x); rewrite <- (cos_neg y);
- rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
- unfold INR in |- *; replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
-replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
-replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
-replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
-clear H1 H2 H3 H4 H5; intros H1 H2 H3 H4 H5;
- replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
-replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
-repeat rewrite cos_shift;
- apply
-  (sin_increasing_1 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H5 H4 H3 H2 H1).
-rewrite Rmult_1_r.
-rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-ring.
-rewrite Rmult_1_r.
-rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-ring.
-rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-ring.
-pattern PI at 3 in |- *; rewrite double_var; ring.
-unfold Rminus in |- *.
-rewrite <- Ropp_mult_distr_l_reverse.
-apply Rplus_comm.
-unfold Rminus in |- *.
-rewrite <- Ropp_mult_distr_l_reverse.
-apply Rplus_comm.
+  forall x y:R,
+    PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x < y -> cos x < cos y.
+Proof.
+  intros x y H1 H2 H3 H4 H5;
+    generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
+      generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
+        generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
+          generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4);
+            generalize (Rplus_lt_compat_l (-3 * (PI / 2)) x y H5);
+              rewrite <- (cos_neg x); rewrite <- (cos_neg y);
+                rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
+                  unfold INR in |- *; replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
+  replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
+  clear H1 H2 H3 H4 H5; intros H1 H2 H3 H4 H5;
+    replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
+  replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
+  repeat rewrite cos_shift;
+    apply
+      (sin_increasing_1 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H5 H4 H3 H2 H1).
+  rewrite Rmult_1_r.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  rewrite Rmult_1_r.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  pattern PI at 3 in |- *; rewrite double_var; ring.
+  unfold Rminus in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
+  unfold Rminus in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
 Qed.
 
 Lemma cos_decreasing_0 :
- forall x y:R,
-   0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x < cos y -> y < x.
-intros; generalize (Ropp_lt_gt_contravar (cos x) (cos y) H3);
- repeat rewrite <- neg_cos; intro H4;
- change (cos (y + PI) < cos (x + PI)) in H4; rewrite (Rplus_comm x) in H4;
- rewrite (Rplus_comm y) in H4; generalize (Rplus_le_compat_l PI 0 x H);
- generalize (Rplus_le_compat_l PI x PI H0);
- generalize (Rplus_le_compat_l PI 0 y H1);
- generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
-rewrite <- double.
-clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_r with PI;
- apply (cos_increasing_0 (PI + y) (PI + x) H0 H H2 H1 H4).
+  forall x y:R,
+    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x < cos y -> y < x.
+Proof.
+  intros; generalize (Ropp_lt_gt_contravar (cos x) (cos y) H3);
+    repeat rewrite <- neg_cos; intro H4;
+      change (cos (y + PI) < cos (x + PI)) in H4; rewrite (Rplus_comm x) in H4;
+        rewrite (Rplus_comm y) in H4; generalize (Rplus_le_compat_l PI 0 x H);
+          generalize (Rplus_le_compat_l PI x PI H0);
+            generalize (Rplus_le_compat_l PI 0 y H1);
+              generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
+  rewrite <- double.
+  clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_r with PI;
+    apply (cos_increasing_0 (PI + y) (PI + x) H0 H H2 H1 H4).
 Qed.
 
 Lemma cos_decreasing_1 :
- forall x y:R,
-   0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x < y -> cos y < cos x.
-intros; apply Ropp_lt_cancel; repeat rewrite <- neg_cos;
- rewrite (Rplus_comm x); rewrite (Rplus_comm y);
- generalize (Rplus_le_compat_l PI 0 x H);
- generalize (Rplus_le_compat_l PI x PI H0);
- generalize (Rplus_le_compat_l PI 0 y H1);
- generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
-rewrite <- double.
-generalize (Rplus_lt_compat_l PI x y H3); clear H H0 H1 H2 H3; intros;
- apply (cos_increasing_1 (PI + x) (PI + y) H3 H2 H1 H0 H).
+  forall x y:R,
+    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x < y -> cos y < cos x.
+Proof.
+  intros; apply Ropp_lt_cancel; repeat rewrite <- neg_cos;
+    rewrite (Rplus_comm x); rewrite (Rplus_comm y);
+      generalize (Rplus_le_compat_l PI 0 x H);
+        generalize (Rplus_le_compat_l PI x PI H0);
+          generalize (Rplus_le_compat_l PI 0 y H1);
+            generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
+  rewrite <- double.
+  generalize (Rplus_lt_compat_l PI x y H3); clear H H0 H1 H2 H3; intros;
+    apply (cos_increasing_1 (PI + x) (PI + y) H3 H2 H1 H0 H).
 Qed.
 
 Lemma tan_diff :
- forall x y:R,
-   cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y).
-intros; unfold tan in |- *; rewrite sin_minus.
-unfold Rdiv in |- *. 
-unfold Rminus in |- *.
-rewrite Rmult_plus_distr_r.
-rewrite Rinv_mult_distr.
-repeat rewrite (Rmult_comm (sin x)).
-repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm (cos y)).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-rewrite (Rmult_comm (sin x)).
-apply Rplus_eq_compat_l.
-rewrite <- Ropp_mult_distr_l_reverse.
-rewrite <- Ropp_mult_distr_r_reverse.
-rewrite (Rmult_comm (/ cos x)).
-repeat rewrite Rmult_assoc.
-rewrite (Rmult_comm (cos x)).
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-reflexivity.
-assumption.
-assumption.
-assumption.
-assumption.
+  forall x y:R,
+    cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y).
+Proof.
+  intros; unfold tan in |- *; rewrite sin_minus.
+  unfold Rdiv in |- *. 
+  unfold Rminus in |- *.
+  rewrite Rmult_plus_distr_r.
+  rewrite Rinv_mult_distr.
+  repeat rewrite (Rmult_comm (sin x)).
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm (cos y)).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm (sin x)).
+  apply Rplus_eq_compat_l.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  rewrite <- Ropp_mult_distr_r_reverse.
+  rewrite (Rmult_comm (/ cos x)).
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm (cos x)).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  reflexivity.
+  assumption.
+  assumption.
+  assumption.
+  assumption.
 Qed.
 
 Lemma tan_increasing_0 :
- forall x y:R,
-   - (PI / 4) <= x ->
-   x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y.
-intros; generalize PI4_RLT_PI2; intro H4;
- generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); 
- intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
- generalize
-  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-     (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
- generalize
-  (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-     (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
- generalize
-  (sym_not_eq
-     (Rlt_not_eq 0 (cos x)
-        (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-           (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); 
- intro H6;
- generalize
-  (sym_not_eq
-     (Rlt_not_eq 0 (cos y)
-        (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-           (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); 
- intro H7; generalize (tan_diff x y H6 H7); intro H8;
- generalize (Rlt_minus (tan x) (tan y) H3); clear H3; 
- intro H3; rewrite H8 in H3; cut (sin (x - y) < 0).
-intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1);
- rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10);
- clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
- intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); 
- clear H11; intro H11;
- generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
- generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10);
- replace (x + - y) with (x - y).
-replace (PI / 4 + PI / 4) with (PI / 2).
-replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
-intros; case (Rtotal_order 0 (x - y)); intro H14.
-generalize
- (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI));
- intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)).
-elim H14; intro H15.
-rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). 
-apply Rminus_lt; assumption.
-pattern PI at 1 in |- *; rewrite double_var.
-unfold Rdiv in |- *.
-rewrite Rmult_plus_distr_r.
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_mult_distr.
-rewrite Ropp_plus_distr.
-replace 4 with 4.
-reflexivity.
-ring.
-discrR.
-discrR.
-pattern PI at 1 in |- *; rewrite double_var.
-unfold Rdiv in |- *.
-rewrite Rmult_plus_distr_r.
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_mult_distr.
-replace 4 with 4.
-reflexivity.
-ring.
-discrR.
-discrR.
-reflexivity.
-case (Rcase_abs (sin (x - y))); intro H9.
-assumption.
-generalize (Rge_le (sin (x - y)) 0 H9); clear H9; intro H9;
- generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
- generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
- generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
- replace (/ cos x * / cos y) with (/ (cos x * cos y)).
-intro H12;
- generalize
-  (Rmult_le_pos (sin (x - y)) (/ (cos x * cos y)) H9
-     (Rlt_le 0 (/ (cos x * cos y)) H12)); intro H13;
- elim
-  (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)).
-rewrite Rinv_mult_distr.
-reflexivity. 
-assumption.
-assumption.
+  forall x y:R,
+    - (PI / 4) <= x ->
+    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y.
+Proof.
+  intros; generalize PI4_RLT_PI2; intro H4;
+    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); 
+      intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
+        generalize
+          (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+            (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
+          generalize
+            (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+              (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
+            generalize
+              (sym_not_eq
+                (Rlt_not_eq 0 (cos x)
+                  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); 
+              intro H6;
+                generalize
+                  (sym_not_eq
+                    (Rlt_not_eq 0 (cos y)
+                      (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); 
+                  intro H7; generalize (tan_diff x y H6 H7); intro H8;
+                    generalize (Rlt_minus (tan x) (tan y) H3); clear H3; 
+                      intro H3; rewrite H8 in H3; cut (sin (x - y) < 0).
+  intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1);
+    rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10);
+      clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
+        intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); 
+          clear H11; intro H11;
+            generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
+              generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10);
+                replace (x + - y) with (x - y).
+  replace (PI / 4 + PI / 4) with (PI / 2).
+  replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
+  intros; case (Rtotal_order 0 (x - y)); intro H14.
+  generalize
+    (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI));
+    intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)).
+  elim H14; intro H15.
+  rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). 
+  apply Rminus_lt; assumption.
+  pattern PI at 1 in |- *; rewrite double_var.
+  unfold Rdiv in |- *.
+  rewrite Rmult_plus_distr_r.
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_mult_distr.
+  rewrite Ropp_plus_distr.
+  replace 4 with 4.
+  reflexivity.
+  ring.
+  discrR.
+  discrR.
+  pattern PI at 1 in |- *; rewrite double_var.
+  unfold Rdiv in |- *.
+  rewrite Rmult_plus_distr_r.
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_mult_distr.
+  replace 4 with 4.
+  reflexivity.
+  ring.
+  discrR.
+  discrR.
+  reflexivity.
+  case (Rcase_abs (sin (x - y))); intro H9.
+  assumption.
+  generalize (Rge_le (sin (x - y)) 0 H9); clear H9; intro H9;
+    generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
+      generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
+        generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
+          replace (/ cos x * / cos y) with (/ (cos x * cos y)).
+  intro H12;
+    generalize
+      (Rmult_le_pos (sin (x - y)) (/ (cos x * cos y)) H9
+        (Rlt_le 0 (/ (cos x * cos y)) H12)); intro H13;
+      elim
+        (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)).
+  rewrite Rinv_mult_distr.
+  reflexivity. 
+  assumption.
+  assumption.
 Qed.
 
 Lemma tan_increasing_1 :
- forall x y:R,
-   - (PI / 4) <= x ->
-   x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y.
-intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4;
- generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); 
- intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
- generalize
-  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-     (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
- generalize
-  (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-     (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
- generalize
-  (sym_not_eq
-     (Rlt_not_eq 0 (cos x)
-        (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-           (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); 
- intro H6;
- generalize
-  (sym_not_eq
-     (Rlt_not_eq 0 (cos y)
-        (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-           (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); 
- intro H7; rewrite (tan_diff x y H6 H7);
- generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
- generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
- generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
- replace (/ cos x * / cos y) with (/ (cos x * cos y)).
-clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
- intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); 
- clear H11; intro H11;
- generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
- replace (x + - y) with (x - y).
-replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
-clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3;
- clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; 
- intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); 
- clear H1; intro H1;
- generalize
-  (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3);
- intro H2;
- generalize
-  (Rmult_lt_gt_compat_neg_l (sin (x - y)) 0 (/ (cos x * cos y)) H2 H8);
- rewrite Rmult_0_r; intro H4; assumption.
-pattern PI at 1 in |- *; rewrite double_var.
-unfold Rdiv in |- *.
-rewrite Rmult_plus_distr_r.
-repeat rewrite Rmult_assoc.
-rewrite <- Rinv_mult_distr.
-replace 4 with 4.
-rewrite Ropp_plus_distr.
-reflexivity.
-ring.
-discrR.
-discrR.
-reflexivity.
-apply Rinv_mult_distr; assumption.
+  forall x y:R,
+    - (PI / 4) <= x ->
+    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y.
+Proof.
+  intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4;
+    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); 
+      intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
+        generalize
+          (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+            (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
+          generalize
+            (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+              (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
+            generalize
+              (sym_not_eq
+                (Rlt_not_eq 0 (cos x)
+                  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); 
+              intro H6;
+                generalize
+                  (sym_not_eq
+                    (Rlt_not_eq 0 (cos y)
+                      (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); 
+                  intro H7; rewrite (tan_diff x y H6 H7);
+                    generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
+                      generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
+                        generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
+                          replace (/ cos x * / cos y) with (/ (cos x * cos y)).
+  clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
+    intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); 
+      clear H11; intro H11;
+        generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
+          replace (x + - y) with (x - y).
+  replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
+  clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3;
+    clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; 
+      intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); 
+        clear H1; intro H1;
+          generalize
+            (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3);
+            intro H2;
+              generalize
+                (Rmult_lt_gt_compat_neg_l (sin (x - y)) 0 (/ (cos x * cos y)) H2 H8);
+                rewrite Rmult_0_r; intro H4; assumption.
+  pattern PI at 1 in |- *; rewrite double_var.
+  unfold Rdiv in |- *.
+  rewrite Rmult_plus_distr_r.
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_mult_distr.
+  replace 4 with 4.
+  rewrite Ropp_plus_distr.
+  reflexivity.
+  ring.
+  discrR.
+  discrR.
+  reflexivity.
+  apply Rinv_mult_distr; assumption.
 Qed.
 
 Lemma sin_incr_0 :
- forall x y:R,
-   - (PI / 2) <= x ->
-   x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x <= sin y -> x <= y.
-intros; case (Rtotal_order (sin x) (sin y)); intro H4;
- [ left; apply (sin_increasing_0 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order x y); intro H6;
-       [ left; assumption
-       | elim H6; intro H7;
-          [ right; assumption
-          | generalize (sin_increasing_1 y x H1 H2 H H0 H7); intro H8;
-             rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8) ] ]
-    | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
+  forall x y:R,
+    - (PI / 2) <= x ->
+    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x <= sin y -> x <= y.
+Proof.
+  intros; case (Rtotal_order (sin x) (sin y)); intro H4;
+    [ left; apply (sin_increasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (sin_increasing_1 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8) ] ]
+          | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
 Qed.
 
 Lemma sin_incr_1 :
- forall x y:R,
-   - (PI / 2) <= x ->
-   x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x <= y -> sin x <= sin y.
-intros; case (Rtotal_order x y); intro H4;
- [ left; apply (sin_increasing_1 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order (sin x) (sin y)); intro H6;
-       [ left; assumption
-       | elim H6; intro H7;
-          [ right; assumption
-          | generalize (sin_increasing_0 y x H1 H2 H H0 H7); intro H8;
-             rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
-    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+  forall x y:R,
+    - (PI / 2) <= x ->
+    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x <= y -> sin x <= sin y.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (sin_increasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (sin x) (sin y)); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (sin_increasing_0 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
 Qed.
 
 Lemma sin_decr_0 :
- forall x y:R,
-   x <= 3 * (PI / 2) ->
-   PI / 2 <= x ->
-   y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x <= sin y -> y <= x.
-intros; case (Rtotal_order (sin x) (sin y)); intro H4;
- [ left; apply (sin_decreasing_0 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order x y); intro H6;
-       [ generalize (sin_decreasing_1 x y H H0 H1 H2 H6); intro H8;
-          rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8)
-       | elim H6; intro H7;
-          [ right; symmetry  in |- *; assumption | left; assumption ] ]
-    | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
+  forall x y:R,
+    x <= 3 * (PI / 2) ->
+    PI / 2 <= x ->
+    y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x <= sin y -> y <= x.
+Proof.
+  intros; case (Rtotal_order (sin x) (sin y)); intro H4;
+    [ left; apply (sin_decreasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ generalize (sin_decreasing_1 x y H H0 H1 H2 H6); intro H8;
+            rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8)
+            | elim H6; intro H7;
+              [ right; symmetry  in |- *; assumption | left; assumption ] ]
+          | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
 Qed.
 
 Lemma sin_decr_1 :
- forall x y:R,
-   x <= 3 * (PI / 2) ->
-   PI / 2 <= x ->
-   y <= 3 * (PI / 2) -> PI / 2 <= y -> x <= y -> sin y <= sin x.
-intros; case (Rtotal_order x y); intro H4;
- [ left; apply (sin_decreasing_1 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order (sin x) (sin y)); intro H6;
-       [ generalize (sin_decreasing_0 x y H H0 H1 H2 H6); intro H8;
-          rewrite H5 in H8; elim (Rlt_irrefl y H8)
-       | elim H6; intro H7;
-          [ right; symmetry  in |- *; assumption | left; assumption ] ]
-    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+  forall x y:R,
+    x <= 3 * (PI / 2) ->
+    PI / 2 <= x ->
+    y <= 3 * (PI / 2) -> PI / 2 <= y -> x <= y -> sin y <= sin x.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (sin_decreasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (sin x) (sin y)); intro H6;
+          [ generalize (sin_decreasing_0 x y H H0 H1 H2 H6); intro H8;
+            rewrite H5 in H8; elim (Rlt_irrefl y H8)
+            | elim H6; intro H7;
+              [ right; symmetry  in |- *; assumption | left; assumption ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
 Qed.
 
 Lemma cos_incr_0 :
- forall x y:R,
-   PI <= x ->
-   x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x <= cos y -> x <= y.
-intros; case (Rtotal_order (cos x) (cos y)); intro H4;
- [ left; apply (cos_increasing_0 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order x y); intro H6;
-       [ left; assumption
-       | elim H6; intro H7;
-          [ right; assumption
-          | generalize (cos_increasing_1 y x H1 H2 H H0 H7); intro H8;
-             rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8) ] ]
-    | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
+  forall x y:R,
+    PI <= x ->
+    x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x <= cos y -> x <= y.
+Proof.
+  intros; case (Rtotal_order (cos x) (cos y)); intro H4;
+    [ left; apply (cos_increasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (cos_increasing_1 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8) ] ]
+          | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
 Qed.
 
 Lemma cos_incr_1 :
- forall x y:R,
-   PI <= x ->
-   x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x <= y -> cos x <= cos y.
-intros; case (Rtotal_order x y); intro H4;
- [ left; apply (cos_increasing_1 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order (cos x) (cos y)); intro H6;
-       [ left; assumption
-       | elim H6; intro H7;
-          [ right; assumption
-          | generalize (cos_increasing_0 y x H1 H2 H H0 H7); intro H8;
-             rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
-    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+  forall x y:R,
+    PI <= x ->
+    x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x <= y -> cos x <= cos y.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (cos_increasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (cos x) (cos y)); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (cos_increasing_0 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
 Qed.
 
 Lemma cos_decr_0 :
- forall x y:R,
-   0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x <= cos y -> y <= x.
-intros; case (Rtotal_order (cos x) (cos y)); intro H4;
- [ left; apply (cos_decreasing_0 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order x y); intro H6;
-       [ generalize (cos_decreasing_1 x y H H0 H1 H2 H6); intro H8;
-          rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8)
-       | elim H6; intro H7;
-          [ right; symmetry  in |- *; assumption | left; assumption ] ]
-    | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
+  forall x y:R,
+    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x <= cos y -> y <= x.
+Proof.
+  intros; case (Rtotal_order (cos x) (cos y)); intro H4;
+    [ left; apply (cos_decreasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ generalize (cos_decreasing_1 x y H H0 H1 H2 H6); intro H8;
+            rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8)
+            | elim H6; intro H7;
+              [ right; symmetry  in |- *; assumption | left; assumption ] ]
+          | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
 Qed.
 
 Lemma cos_decr_1 :
- forall x y:R,
-   0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x <= y -> cos y <= cos x.
-intros; case (Rtotal_order x y); intro H4;
- [ left; apply (cos_decreasing_1 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order (cos x) (cos y)); intro H6;
-       [ generalize (cos_decreasing_0 x y H H0 H1 H2 H6); intro H8;
-          rewrite H5 in H8; elim (Rlt_irrefl y H8)
-       | elim H6; intro H7;
-          [ right; symmetry  in |- *; assumption | left; assumption ] ]
-    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+  forall x y:R,
+    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x <= y -> cos y <= cos x.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (cos_decreasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (cos x) (cos y)); intro H6;
+          [ generalize (cos_decreasing_0 x y H H0 H1 H2 H6); intro H8;
+            rewrite H5 in H8; elim (Rlt_irrefl y H8)
+            | elim H6; intro H7;
+              [ right; symmetry  in |- *; assumption | left; assumption ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
 Qed.
 
 Lemma tan_incr_0 :
- forall x y:R,
-   - (PI / 4) <= x ->
-   x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x <= tan y -> x <= y.
-intros; case (Rtotal_order (tan x) (tan y)); intro H4;
- [ left; apply (tan_increasing_0 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order x y); intro H6;
-       [ left; assumption
-       | elim H6; intro H7;
-          [ right; assumption
-          | generalize (tan_increasing_1 y x H1 H2 H H0 H7); intro H8;
-             rewrite H5 in H8; elim (Rlt_irrefl (tan y) H8) ] ]
-    | elim (Rlt_irrefl (tan x) (Rle_lt_trans (tan x) (tan y) (tan x) H3 H5)) ] ].
+  forall x y:R,
+    - (PI / 4) <= x ->
+    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x <= tan y -> x <= y.
+Proof.
+  intros; case (Rtotal_order (tan x) (tan y)); intro H4;
+    [ left; apply (tan_increasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (tan_increasing_1 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl (tan y) H8) ] ]
+          | elim (Rlt_irrefl (tan x) (Rle_lt_trans (tan x) (tan y) (tan x) H3 H5)) ] ].
 Qed.
 
 Lemma tan_incr_1 :
- forall x y:R,
-   - (PI / 4) <= x ->
-   x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x <= y -> tan x <= tan y.
-intros; case (Rtotal_order x y); intro H4;
- [ left; apply (tan_increasing_1 x y H H0 H1 H2 H4)
- | elim H4; intro H5;
-    [ case (Rtotal_order (tan x) (tan y)); intro H6;
-       [ left; assumption
-       | elim H6; intro H7;
-          [ right; assumption
-          | generalize (tan_increasing_0 y x H1 H2 H H0 H7); intro H8;
-             rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
-    | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+  forall x y:R,
+    - (PI / 4) <= x ->
+    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x <= y -> tan x <= tan y.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (tan_increasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (tan x) (tan y)); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (tan_increasing_0 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
 Qed.
 
 (**********)
 Lemma sin_eq_0_1 : forall x:R, (exists k : Z, x = IZR k * PI) -> sin x = 0.
-intros.
-elim H; intros.
-apply (Zcase_sign x0).
-intro.
-rewrite H1 in H0.
-simpl in H0.
-rewrite H0; rewrite Rmult_0_l; apply sin_0.
-intro.
-cut (0 <= x0)%Z.
-intro.
-elim (IZN x0 H2); intros.
-rewrite H3 in H0.
-rewrite <- INR_IZR_INZ in H0.
-rewrite H0.
-elim (even_odd_cor x1); intros.
-elim H4; intro.
-rewrite H5.
-rewrite mult_INR.
-simpl in |- *.
-rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
-rewrite sin_period.
-apply sin_0.
-rewrite H5.
-rewrite S_INR; rewrite mult_INR.
-simpl in |- *.
-rewrite Rmult_plus_distr_r.
-rewrite Rmult_1_l; rewrite sin_plus.
-rewrite sin_PI.
-rewrite Rmult_0_r.
-rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
-rewrite sin_period.
-rewrite sin_0; ring.
-apply le_IZR.
-left; apply IZR_lt.
-assert (H2 := Zorder.Zgt_iff_lt).
-elim (H2 x0 0%Z); intros.
-apply H3; assumption.
-intro.
-rewrite H0.
-replace (sin (IZR x0 * PI)) with (- sin (- IZR x0 * PI)).
-cut (0 <= - x0)%Z.
-intro.
-rewrite <- Ropp_Ropp_IZR.
-elim (IZN (- x0) H2); intros.
-rewrite H3.
-rewrite <- INR_IZR_INZ.
-elim (even_odd_cor x1); intros.
-elim H4; intro.
-rewrite H5.
-rewrite mult_INR.
-simpl in |- *.
-rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
-rewrite sin_period.
-rewrite sin_0; ring.
-rewrite H5.
-rewrite S_INR; rewrite mult_INR.
-simpl in |- *.
-rewrite Rmult_plus_distr_r.
-rewrite Rmult_1_l; rewrite sin_plus.
-rewrite sin_PI.
-rewrite Rmult_0_r.
-rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
-rewrite sin_period.
-rewrite sin_0; ring.
-apply le_IZR.
-apply Rplus_le_reg_l with (IZR x0).
-rewrite Rplus_0_r.
-rewrite Ropp_Ropp_IZR.
-rewrite Rplus_opp_r.
-left; replace 0 with (IZR 0); [ apply IZR_lt | reflexivity ].
-assumption.
-rewrite <- sin_neg.
-rewrite Ropp_mult_distr_l_reverse.
-rewrite Ropp_involutive.
-reflexivity.
+Proof.
+  intros.
+  elim H; intros.
+  apply (Zcase_sign x0).
+  intro.
+  rewrite H1 in H0.
+  simpl in H0.
+  rewrite H0; rewrite Rmult_0_l; apply sin_0.
+  intro.
+  cut (0 <= x0)%Z.
+  intro.
+  elim (IZN x0 H2); intros.
+  rewrite H3 in H0.
+  rewrite <- INR_IZR_INZ in H0.
+  rewrite H0.
+  elim (even_odd_cor x1); intros.
+  elim H4; intro.
+  rewrite H5.
+  rewrite mult_INR.
+  simpl in |- *.
+  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite sin_period.
+  apply sin_0.
+  rewrite H5.
+  rewrite S_INR; rewrite mult_INR.
+  simpl in |- *.
+  rewrite Rmult_plus_distr_r.
+  rewrite Rmult_1_l; rewrite sin_plus.
+  rewrite sin_PI.
+  rewrite Rmult_0_r.
+  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite sin_period.
+  rewrite sin_0; ring.
+  apply le_IZR.
+  left; apply IZR_lt.
+  assert (H2 := Zorder.Zgt_iff_lt).
+  elim (H2 x0 0%Z); intros.
+  apply H3; assumption.
+  intro.
+  rewrite H0.
+  replace (sin (IZR x0 * PI)) with (- sin (- IZR x0 * PI)).
+  cut (0 <= - x0)%Z.
+  intro.
+  rewrite <- Ropp_Ropp_IZR.
+  elim (IZN (- x0) H2); intros.
+  rewrite H3.
+  rewrite <- INR_IZR_INZ.
+  elim (even_odd_cor x1); intros.
+  elim H4; intro.
+  rewrite H5.
+  rewrite mult_INR.
+  simpl in |- *.
+  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite sin_period.
+  rewrite sin_0; ring.
+  rewrite H5.
+  rewrite S_INR; rewrite mult_INR.
+  simpl in |- *.
+  rewrite Rmult_plus_distr_r.
+  rewrite Rmult_1_l; rewrite sin_plus.
+  rewrite sin_PI.
+  rewrite Rmult_0_r.
+  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite sin_period.
+  rewrite sin_0; ring.
+  apply le_IZR.
+  apply Rplus_le_reg_l with (IZR x0).
+  rewrite Rplus_0_r.
+  rewrite Ropp_Ropp_IZR.
+  rewrite Rplus_opp_r.
+  left; replace 0 with (IZR 0); [ apply IZR_lt | reflexivity ].
+  assumption.
+  rewrite <- sin_neg.
+  rewrite Ropp_mult_distr_l_reverse.
+  rewrite Ropp_involutive.
+  reflexivity.
 Qed.
 
 Lemma sin_eq_0_0 : forall x:R, sin x = 0 ->  exists k : Z, x = IZR k * PI.
-intros.
-assert (H0 := euclidian_division x PI PI_neq0).
-elim H0; intros q H1.
-elim H1; intros r H2.
-exists q.
-cut (r = 0).
-intro.
-elim H2; intros H4 _; rewrite H4; rewrite H3.
-apply Rplus_0_r.
-elim H2; intros.
-rewrite H3 in H.
-rewrite sin_plus in H.
-cut (sin (IZR q * PI) = 0).
-intro.
-rewrite H5 in H.
-rewrite Rmult_0_l in H.
-rewrite Rplus_0_l in H.
-assert (H6 := Rmult_integral _ _ H).
-elim H6; intro.
-assert (H8 := sin2_cos2 (IZR q * PI)).
-rewrite H5 in H8; rewrite H7 in H8.
-rewrite Rsqr_0 in H8.
-rewrite Rplus_0_r in H8.
-elim R1_neq_R0; symmetry  in |- *; assumption.
-cut (r = 0 \/ 0 < r < PI).
-intro; elim H8; intro.
-assumption.
-elim H9; intros.
-assert (H12 := sin_gt_0 _ H10 H11).
-rewrite H7 in H12; elim (Rlt_irrefl _ H12).
-rewrite Rabs_right in H4.
-elim H4; intros.
-case (Rtotal_order 0 r); intro.
-right; split; assumption.
-elim H10; intro.
-left; symmetry  in |- *; assumption.
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 H11)).
-apply Rle_ge.
-left; apply PI_RGT_0.
-apply sin_eq_0_1.
-exists q; reflexivity.
+Proof.
+  intros.
+  assert (H0 := euclidian_division x PI PI_neq0).
+  elim H0; intros q H1.
+  elim H1; intros r H2.
+  exists q.
+  cut (r = 0).
+  intro.
+  elim H2; intros H4 _; rewrite H4; rewrite H3.
+  apply Rplus_0_r.
+  elim H2; intros.
+  rewrite H3 in H.
+  rewrite sin_plus in H.
+  cut (sin (IZR q * PI) = 0).
+  intro.
+  rewrite H5 in H.
+  rewrite Rmult_0_l in H.
+  rewrite Rplus_0_l in H.
+  assert (H6 := Rmult_integral _ _ H).
+  elim H6; intro.
+  assert (H8 := sin2_cos2 (IZR q * PI)).
+  rewrite H5 in H8; rewrite H7 in H8.
+  rewrite Rsqr_0 in H8.
+  rewrite Rplus_0_r in H8.
+  elim R1_neq_R0; symmetry  in |- *; assumption.
+  cut (r = 0 \/ 0 < r < PI).
+  intro; elim H8; intro.
+  assumption.
+  elim H9; intros.
+  assert (H12 := sin_gt_0 _ H10 H11).
+  rewrite H7 in H12; elim (Rlt_irrefl _ H12).
+  rewrite Rabs_right in H4.
+  elim H4; intros.
+  case (Rtotal_order 0 r); intro.
+  right; split; assumption.
+  elim H10; intro.
+  left; symmetry  in |- *; assumption.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 H11)).
+  apply Rle_ge.
+  left; apply PI_RGT_0.
+  apply sin_eq_0_1.
+  exists q; reflexivity.
 Qed.
 
 Lemma cos_eq_0_0 :
- forall x:R, cos x = 0 ->  exists k : Z, x = IZR k * PI + PI / 2. 
-intros x H; rewrite cos_sin in H; generalize (sin_eq_0_0 (PI / INR 2 + x) H);
- intro H2; elim H2; intros x0 H3; exists (x0 - Z_of_nat 1)%Z;
- rewrite <- Z_R_minus; ring; rewrite Rmult_comm; rewrite <- H3;
- unfold INR in |- *.
-rewrite (double_var (- PI)); unfold Rdiv in |- *; ring.
+  forall x:R, cos x = 0 ->  exists k : Z, x = IZR k * PI + PI / 2. 
+Proof.
+  intros x H; rewrite cos_sin in H; generalize (sin_eq_0_0 (PI / INR 2 + x) H);
+    intro H2; elim H2; intros x0 H3; exists (x0 - Z_of_nat 1)%Z;
+      rewrite <- Z_R_minus; simpl.
+unfold INR in H3. field_simplify [(sym_eq H3)]. field.
+(** 
+  ring_simplify.
+ (* rewrite (Rmult_comm PI);*) (* old ring compat *)
+        rewrite <- H3; simpl;
+          field;repeat split; discrR.
+*)
 Qed.
 
 Lemma cos_eq_0_1 :
- forall x:R, (exists k : Z, x = IZR k * PI + PI / 2) -> cos x = 0.
-intros x H1; rewrite cos_sin; elim H1; intros x0 H2; rewrite H2;
- replace (PI / 2 + (IZR x0 * PI + PI / 2)) with (IZR x0 * PI + PI).
-rewrite neg_sin; rewrite <- Ropp_0.
-apply Ropp_eq_compat; apply sin_eq_0_1; exists x0; reflexivity.
-pattern PI at 2 in |- *; rewrite (double_var PI); ring.
+  forall x:R, (exists k : Z, x = IZR k * PI + PI / 2) -> cos x = 0.
+Proof.
+  intros x H1; rewrite cos_sin; elim H1; intros x0 H2; rewrite H2;
+    replace (PI / 2 + (IZR x0 * PI + PI / 2)) with (IZR x0 * PI + PI).
+  rewrite neg_sin; rewrite <- Ropp_0.
+  apply Ropp_eq_compat; apply sin_eq_0_1; exists x0; reflexivity.
+  pattern PI at 2 in |- *; rewrite (double_var PI); ring.
 Qed.
 
 Lemma sin_eq_O_2PI_0 :
- forall x:R,
-   0 <= x -> x <= 2 * PI -> sin x = 0 -> x = 0 \/ x = PI \/ x = 2 * PI.
-intros; generalize (sin_eq_0_0 x H1); intro.
-elim H2; intros k0 H3.
-case (Rtotal_order PI x); intro.
-rewrite H3 in H4; rewrite H3 in H0.
-right; right.
-generalize
- (Rmult_lt_compat_r (/ PI) PI (IZR k0 * PI) (Rinv_0_lt_compat PI PI_RGT_0) H4);
- rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; intro;
- generalize
-  (Rmult_le_compat_r (/ PI) (IZR k0 * PI) (2 * PI)
-     (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H0);
- repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
-repeat rewrite Rmult_1_r; intro;
- generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5); 
- rewrite <- plus_IZR.
-replace (IZR (-2) + 1) with (-1).
-intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) 2 H6);
- rewrite <- plus_IZR.
-replace (IZR (-2) + 2) with 0.
-intro; cut (-1 < IZR (-2 + k0) < 1).
-intro; generalize (one_IZR_lt1 (-2 + k0) H9); intro.
-cut (k0 = 2%Z).
-intro; rewrite H11 in H3; rewrite H3; simpl in |- *.
-reflexivity.
-rewrite <- (Zplus_opp_l 2) in H10; generalize (Zplus_reg_l (-2) k0 2 H10);
- intro; assumption.
-split.
-assumption.
-apply Rle_lt_trans with 0.
-assumption.
-apply Rlt_0_1.
-simpl in |- *; ring.
-simpl in |- *; ring.
-apply PI_neq0.
-apply PI_neq0.
-elim H4; intro.
-right; left.
-symmetry  in |- *; assumption.
-left.
-rewrite H3 in H5; rewrite H3 in H;
- generalize
-  (Rmult_lt_compat_r (/ PI) (IZR k0 * PI) PI (Rinv_0_lt_compat PI PI_RGT_0)
-     H5); rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; intro;
- generalize
-  (Rmult_le_compat_r (/ PI) 0 (IZR k0 * PI)
-     (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H);
- repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; rewrite Rmult_0_l; intro.
-cut (-1 < IZR k0 < 1).
-intro; generalize (one_IZR_lt1 k0 H8); intro; rewrite H9 in H3; rewrite H3;
- simpl in |- *; apply Rmult_0_l.
-split.
-apply Rlt_le_trans with 0.
-rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; apply Rlt_0_1.
-assumption.
-assumption.
-apply PI_neq0.
-apply PI_neq0.
+  forall x:R,
+    0 <= x -> x <= 2 * PI -> sin x = 0 -> x = 0 \/ x = PI \/ x = 2 * PI.
+Proof.
+  intros; generalize (sin_eq_0_0 x H1); intro.
+  elim H2; intros k0 H3.
+  case (Rtotal_order PI x); intro.
+  rewrite H3 in H4; rewrite H3 in H0.
+  right; right.
+  generalize
+    (Rmult_lt_compat_r (/ PI) PI (IZR k0 * PI) (Rinv_0_lt_compat PI PI_RGT_0) H4);
+    rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; intro;
+    generalize
+      (Rmult_le_compat_r (/ PI) (IZR k0 * PI) (2 * PI)
+        (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H0);
+      repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
+  repeat rewrite Rmult_1_r; intro;
+    generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5); 
+      rewrite <- plus_IZR.
+  replace (IZR (-2) + 1) with (-1).
+  intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) 2 H6);
+    rewrite <- plus_IZR.
+  replace (IZR (-2) + 2) with 0.
+  intro; cut (-1 < IZR (-2 + k0) < 1).
+  intro; generalize (one_IZR_lt1 (-2 + k0) H9); intro.
+  cut (k0 = 2%Z).
+  intro; rewrite H11 in H3; rewrite H3; simpl in |- *.
+  reflexivity.
+  rewrite <- (Zplus_opp_l 2) in H10; generalize (Zplus_reg_l (-2) k0 2 H10);
+    intro; assumption.
+  split.
+  assumption.
+  apply Rle_lt_trans with 0.
+  assumption.
+  apply Rlt_0_1.
+  simpl in |- *; ring.
+  simpl in |- *; ring.
+  apply PI_neq0.
+  apply PI_neq0.
+  elim H4; intro.
+  right; left.
+  symmetry  in |- *; assumption.
+  left.
+  rewrite H3 in H5; rewrite H3 in H;
+    generalize
+      (Rmult_lt_compat_r (/ PI) (IZR k0 * PI) PI (Rinv_0_lt_compat PI PI_RGT_0)
+        H5); rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; intro;
+    generalize
+      (Rmult_le_compat_r (/ PI) 0 (IZR k0 * PI)
+        (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H);
+      repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; rewrite Rmult_0_l; intro.
+  cut (-1 < IZR k0 < 1).
+  intro; generalize (one_IZR_lt1 k0 H8); intro; rewrite H9 in H3; rewrite H3;
+    simpl in |- *; apply Rmult_0_l.
+  split.
+  apply Rlt_le_trans with 0.
+  rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; apply Rlt_0_1.
+  assumption.
+  assumption.
+  apply PI_neq0.
+  apply PI_neq0.
 Qed.
 
 Lemma sin_eq_O_2PI_1 :
- forall x:R,
-   0 <= x -> x <= 2 * PI -> x = 0 \/ x = PI \/ x = 2 * PI -> sin x = 0.
-intros x H1 H2 H3; elim H3; intro H4;
- [ rewrite H4; rewrite sin_0; reflexivity
- | elim H4; intro H5;
-    [ rewrite H5; rewrite sin_PI; reflexivity
-    | rewrite H5; rewrite sin_2PI; reflexivity ] ].
+  forall x:R,
+    0 <= x -> x <= 2 * PI -> x = 0 \/ x = PI \/ x = 2 * PI -> sin x = 0.
+Proof.
+  intros x H1 H2 H3; elim H3; intro H4;
+    [ rewrite H4; rewrite sin_0; reflexivity
+      | elim H4; intro H5;
+        [ rewrite H5; rewrite sin_PI; reflexivity
+          | rewrite H5; rewrite sin_2PI; reflexivity ] ].
 Qed.
 
 Lemma cos_eq_0_2PI_0 :
- forall x:R,
-   0 <= x -> x <= 2 * PI -> cos x = 0 -> x = PI / 2 \/ x = 3 * (PI / 2).
-intros; case (Rtotal_order x (3 * (PI / 2))); intro.
-rewrite cos_sin in H1.
-cut (0 <= PI / 2 + x).
-cut (PI / 2 + x <= 2 * PI).
-intros; generalize (sin_eq_O_2PI_0 (PI / 2 + x) H4 H3 H1); intros.
-decompose [or] H5.
-generalize (Rplus_le_compat_l (PI / 2) 0 x H); rewrite Rplus_0_r; rewrite H6;
- intro.
-elim (Rlt_irrefl 0 (Rlt_le_trans 0 (PI / 2) 0 PI2_RGT_0 H7)).
-left.
-generalize (Rplus_eq_compat_l (- (PI / 2)) (PI / 2 + x) PI H7).
-replace (- (PI / 2) + (PI / 2 + x)) with x.
-replace (- (PI / 2) + PI) with (PI / 2).
-intro; assumption.
-pattern PI at 3 in |- *; rewrite (double_var PI); ring.
-ring.
-right.
-generalize (Rplus_eq_compat_l (- (PI / 2)) (PI / 2 + x) (2 * PI) H7).
-replace (- (PI / 2) + (PI / 2 + x)) with x.
-replace (- (PI / 2) + 2 * PI) with (3 * (PI / 2)).
-intro; assumption.
-rewrite double; pattern PI at 3 4 in |- *; rewrite (double_var PI); ring.
-ring.
-left; replace (2 * PI) with (PI / 2 + 3 * (PI / 2)).
-apply Rplus_lt_compat_l; assumption.
-rewrite (double PI); pattern PI at 3 4 in |- *; rewrite (double_var PI); ring.
-apply Rplus_le_le_0_compat.
-left; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply PI_RGT_0.
-apply Rinv_0_lt_compat; prove_sup0. 
-assumption.
-elim H2; intro.
-right; assumption.
-generalize (cos_eq_0_0 x H1); intro; elim H4; intros k0 H5.
-rewrite H5 in H3; rewrite H5 in H0;
- generalize
-  (Rplus_lt_compat_l (- (PI / 2)) (3 * (PI / 2)) (IZR k0 * PI + PI / 2) H3);
- generalize
-  (Rplus_le_compat_l (- (PI / 2)) (IZR k0 * PI + PI / 2) (2 * PI) H0).
-replace (- (PI / 2) + 3 * (PI / 2)) with PI.
-replace (- (PI / 2) + (IZR k0 * PI + PI / 2)) with (IZR k0 * PI).
-replace (- (PI / 2) + 2 * PI) with (3 * (PI / 2)).
-intros;
- generalize
-  (Rmult_lt_compat_l (/ PI) PI (IZR k0 * PI) (Rinv_0_lt_compat PI PI_RGT_0)
-     H7);
- generalize
-  (Rmult_le_compat_l (/ PI) (IZR k0 * PI) (3 * (PI / 2))
-     (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H6).
-replace (/ PI * (IZR k0 * PI)) with (IZR k0).
-replace (/ PI * (3 * (PI / 2))) with (3 * / 2).
-rewrite <- Rinv_l_sym.
-intros; generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H9);
- rewrite <- plus_IZR.
-replace (IZR (-2) + 1) with (-1).
-intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) (3 * / 2) H8);
- rewrite <- plus_IZR.
-replace (IZR (-2) + 2) with 0.
-intro; cut (-1 < IZR (-2 + k0) < 1).
-intro; generalize (one_IZR_lt1 (-2 + k0) H12); intro.
-cut (k0 = 2%Z).
-intro; rewrite H14 in H8.
-assert (Hyp : 0 < 2).
-prove_sup0.
-generalize (Rmult_le_compat_l 2 (IZR 2) (3 * / 2) (Rlt_le 0 2 Hyp) H8);
- simpl in |- *.
-replace 4 with 4.
-replace (2 * (3 * / 2)) with 3.
-intro; cut (3 < 4).
-intro; elim (Rlt_irrefl 3 (Rlt_le_trans 3 4 3 H16 H15)).
-generalize (Rplus_lt_compat_l 3 0 1 Rlt_0_1); rewrite Rplus_0_r.
-replace (3 + 1) with 4.
-intro; assumption.
-ring.
-symmetry  in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
-discrR.
-ring.
-rewrite <- (Zplus_opp_l 2) in H13; generalize (Zplus_reg_l (-2) k0 2 H13);
- intro; assumption.
-split.
-assumption.
-apply Rle_lt_trans with (IZR (-2) + 3 * / 2).
-assumption.
-simpl in |- *; replace (-2 + 3 * / 2) with (- (1 * / 2)).
-apply Rlt_trans with 0.
-rewrite <- Ropp_0; apply Ropp_lt_gt_contravar.
-apply Rmult_lt_0_compat;
- [ apply Rlt_0_1 | apply Rinv_0_lt_compat; prove_sup0 ].
-apply Rlt_0_1.
-rewrite Rmult_1_l; apply Rmult_eq_reg_l with 2.
-rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_r_sym.
-rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m.
-ring.
-discrR.
-discrR.
-discrR.
-simpl in |- *; ring.
-simpl in |- *; ring.
-apply PI_neq0.
-unfold Rdiv in |- *; pattern 3 at 1 in |- *; rewrite (Rmult_comm 3);
- repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; apply Rmult_comm.
-apply PI_neq0.
-symmetry  in |- *; rewrite (Rmult_comm (/ PI)); rewrite Rmult_assoc;
- rewrite <- Rinv_r_sym.
-apply Rmult_1_r.
-apply PI_neq0.
-rewrite double; pattern PI at 3 4 in |- *; rewrite double_var; ring.
-ring.
-pattern PI at 1 in |- *; rewrite double_var; ring.
+  forall x:R,
+    0 <= x -> x <= 2 * PI -> cos x = 0 -> x = PI / 2 \/ x = 3 * (PI / 2).
+Proof.
+  intros; case (Rtotal_order x (3 * (PI / 2))); intro.
+  rewrite cos_sin in H1.
+  cut (0 <= PI / 2 + x).
+  cut (PI / 2 + x <= 2 * PI).
+  intros; generalize (sin_eq_O_2PI_0 (PI / 2 + x) H4 H3 H1); intros.
+  decompose [or] H5.
+  generalize (Rplus_le_compat_l (PI / 2) 0 x H); rewrite Rplus_0_r; rewrite H6;
+    intro.
+  elim (Rlt_irrefl 0 (Rlt_le_trans 0 (PI / 2) 0 PI2_RGT_0 H7)).
+  left.
+  generalize (Rplus_eq_compat_l (- (PI / 2)) (PI / 2 + x) PI H7).
+  replace (- (PI / 2) + (PI / 2 + x)) with x.
+  replace (- (PI / 2) + PI) with (PI / 2).
+  intro; assumption.
+  pattern PI at 3 in |- *; rewrite (double_var PI); ring.
+  ring.
+  right.
+  generalize (Rplus_eq_compat_l (- (PI / 2)) (PI / 2 + x) (2 * PI) H7).
+  replace (- (PI / 2) + (PI / 2 + x)) with x.
+  replace (- (PI / 2) + 2 * PI) with (3 * (PI / 2)).
+  intro; assumption.
+  rewrite double; pattern PI at 3 4 in |- *; rewrite (double_var PI); ring.
+  ring.
+  left; replace (2 * PI) with (PI / 2 + 3 * (PI / 2)).
+  apply Rplus_lt_compat_l; assumption.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite (double_var PI); ring.
+  apply Rplus_le_le_0_compat.
+  left; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply PI_RGT_0.
+  apply Rinv_0_lt_compat; prove_sup0. 
+  assumption.
+  elim H2; intro.
+  right; assumption.
+  generalize (cos_eq_0_0 x H1); intro; elim H4; intros k0 H5.
+  rewrite H5 in H3; rewrite H5 in H0;
+    generalize
+      (Rplus_lt_compat_l (- (PI / 2)) (3 * (PI / 2)) (IZR k0 * PI + PI / 2) H3);
+      generalize
+        (Rplus_le_compat_l (- (PI / 2)) (IZR k0 * PI + PI / 2) (2 * PI) H0).
+  replace (- (PI / 2) + 3 * (PI / 2)) with PI.
+  replace (- (PI / 2) + (IZR k0 * PI + PI / 2)) with (IZR k0 * PI).
+  replace (- (PI / 2) + 2 * PI) with (3 * (PI / 2)).
+  intros;
+    generalize
+      (Rmult_lt_compat_l (/ PI) PI (IZR k0 * PI) (Rinv_0_lt_compat PI PI_RGT_0)
+        H7);
+      generalize
+        (Rmult_le_compat_l (/ PI) (IZR k0 * PI) (3 * (PI / 2))
+          (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H6).
+  replace (/ PI * (IZR k0 * PI)) with (IZR k0).
+  replace (/ PI * (3 * (PI / 2))) with (3 * / 2).
+  rewrite <- Rinv_l_sym.
+  intros; generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H9);
+    rewrite <- plus_IZR.
+  replace (IZR (-2) + 1) with (-1).
+  intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) (3 * / 2) H8);
+    rewrite <- plus_IZR.
+  replace (IZR (-2) + 2) with 0.
+  intro; cut (-1 < IZR (-2 + k0) < 1).
+  intro; generalize (one_IZR_lt1 (-2 + k0) H12); intro.
+  cut (k0 = 2%Z).
+  intro; rewrite H14 in H8.
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  generalize (Rmult_le_compat_l 2 (IZR 2) (3 * / 2) (Rlt_le 0 2 Hyp) H8);
+    simpl in |- *.
+  replace 4 with 4.
+  replace (2 * (3 * / 2)) with 3.
+  intro; cut (3 < 4).
+  intro; elim (Rlt_irrefl 3 (Rlt_le_trans 3 4 3 H16 H15)).
+  generalize (Rplus_lt_compat_l 3 0 1 Rlt_0_1); rewrite Rplus_0_r.
+  replace (3 + 1) with 4.
+  intro; assumption.
+  ring.
+  symmetry  in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+  discrR.
+  ring.
+  rewrite <- (Zplus_opp_l 2) in H13; generalize (Zplus_reg_l (-2) k0 2 H13);
+    intro; assumption.
+  split.
+  assumption.
+  apply Rle_lt_trans with (IZR (-2) + 3 * / 2).
+  assumption.
+  simpl in |- *; replace (-2 + 3 * / 2) with (- (1 * / 2)).
+  apply Rlt_trans with 0.
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar.
+  apply Rmult_lt_0_compat;
+    [ apply Rlt_0_1 | apply Rinv_0_lt_compat; prove_sup0 ].
+  apply Rlt_0_1.
+  rewrite Rmult_1_l; apply Rmult_eq_reg_l with 2.
+  rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_r_sym.
+  rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m.
+  ring.
+  discrR.
+  discrR.
+  discrR.
+  simpl in |- *; ring.
+  simpl in |- *; ring.
+  apply PI_neq0.
+  unfold Rdiv in |- *; pattern 3 at 1 in |- *; rewrite (Rmult_comm 3);
+    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; apply Rmult_comm.
+  apply PI_neq0.
+  symmetry  in |- *; rewrite (Rmult_comm (/ PI)); rewrite Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  apply Rmult_1_r.
+  apply PI_neq0.
+  rewrite double; pattern PI at 3 4 in |- *; rewrite double_var; ring.
+  ring.
+  pattern PI at 1 in |- *; rewrite double_var; ring.
 Qed.
 
 Lemma cos_eq_0_2PI_1 :
- forall x:R,
-   0 <= x -> x <= 2 * PI -> x = PI / 2 \/ x = 3 * (PI / 2) -> cos x = 0.
-intros x H1 H2 H3; elim H3; intro H4;
- [ rewrite H4; rewrite cos_PI2; reflexivity
- | rewrite H4; rewrite cos_3PI2; reflexivity ].
-Qed.
\ No newline at end of file
+  forall x:R,
+    0 <= x -> x <= 2 * PI -> x = PI / 2 \/ x = 3 * (PI / 2) -> cos x = 0.
+Proof.
+  intros x H1 H2 H3; elim H3; intro H4;
+    [ rewrite H4; rewrite cos_PI2; reflexivity
+      | rewrite H4; rewrite cos_3PI2; reflexivity ].
+Qed.
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
index 3cda9290..89ee1745 100644
--- a/theories/Reals/Rtrigo_alt.v
+++ b/theories/Reals/Rtrigo_alt.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Rtrigo_alt.v,v 1.16.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+(*i $Id: Rtrigo_alt.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -14,9 +14,9 @@ Require Import SeqSeries.
 Require Import Rtrigo_def.
 Open Local Scope R_scope.
 
-(*****************************************************************)
-(* Using series definitions of cos and sin                       *)
-(*****************************************************************)
+(***************************************************************)
+(** Using series definitions of cos and sin                    *)
+(***************************************************************)
 
 Definition sin_term (a:R) (i:nat) : R :=
   (-1) ^ i * (a ^ (2 * i + 1) / INR (fact (2 * i + 1))).
@@ -30,397 +30,390 @@ Definition cos_approx (a:R) (n:nat) : R := sum_f_R0 (cos_term a) n.
 
 (**********)
 Lemma PI_4 : PI <= 4.
-assert (H0 := PI_ineq 0).
-elim H0; clear H0; intros _ H0.
-unfold tg_alt, PI_tg in H0; simpl in H0.
-rewrite Rinv_1 in H0; rewrite Rmult_1_r in H0; unfold Rdiv in H0.
-apply Rmult_le_reg_l with (/ 4).
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite <- Rinv_l_sym; [ rewrite Rmult_comm; assumption | discrR ].
+Proof.
+  assert (H0 := PI_ineq 0).
+  elim H0; clear H0; intros _ H0.
+  unfold tg_alt, PI_tg in H0; simpl in H0.
+  rewrite Rinv_1 in H0; rewrite Rmult_1_r in H0; unfold Rdiv in H0.
+  apply Rmult_le_reg_l with (/ 4).
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite <- Rinv_l_sym; [ rewrite Rmult_comm; assumption | discrR ].
 Qed.
 
 (**********)
 Theorem sin_bound :
- forall (a:R) (n:nat),
-   0 <= a ->
-   a <= PI -> sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)).
-intros; case (Req_dec a 0); intro Hyp_a.
-rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx in |- *;
- apply sum_eq_R0 || (symmetry  in |- *; apply sum_eq_R0); 
- intros; unfold sin_term in |- *; rewrite pow_add; 
- simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l; 
- ring.
-unfold sin_approx in |- *; cut (0 < a).
-intro Hyp_a_pos.
-rewrite (decomp_sum (sin_term a) (2 * n + 1)).
-rewrite (decomp_sum (sin_term a) (2 * (n + 1))).
-replace (sin_term a 0) with a.
-cut
- (sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a - a /\
-  sin a - a <= sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1))) ->
-  a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a /\
-  sin a <= a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1)))).
-intro; apply H1.
-set (Un := fun n:nat => a ^ (2 * S n + 1) / INR (fact (2 * S n + 1))).
-replace (pred (2 * n + 1)) with (2 * n)%nat.
-replace (pred (2 * (n + 1))) with (S (2 * n)).
-replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (2 * n)) with
- (- sum_f_R0 (tg_alt Un) (2 * n)).
-replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (S (2 * n))) with
- (- sum_f_R0 (tg_alt Un) (S (2 * n))).
-cut
- (sum_f_R0 (tg_alt Un) (S (2 * n)) <= a - sin a <=
-  sum_f_R0 (tg_alt Un) (2 * n) ->
-  - sum_f_R0 (tg_alt Un) (2 * n) <= sin a - a <=
-  - sum_f_R0 (tg_alt Un) (S (2 * n))).
-intro; apply H2.
-apply alternated_series_ineq.
-unfold Un_decreasing, Un in |- *; intro;
- cut ((2 * S (S n0) + 1)%nat = S (S (2 * S n0 + 1))).
-intro; rewrite H3.
-replace (a ^ S (S (2 * S n0 + 1))) with (a ^ (2 * S n0 + 1) * (a * a)).
-unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
-left; apply pow_lt; assumption.
-apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n0 + 1))))).
-rewrite <- H3; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
- assert (H5 := sym_eq H4); elim (fact_neq_0 _ H5).
-rewrite <- H3; rewrite (Rmult_comm (INR (fact (2 * S (S n0) + 1))));
- rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite H3; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
- repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r.
-do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
- simpl in |- *;
- replace
-  (((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1 + 1) *
-   ((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1)) with
-  (4 * INR n0 * INR n0 + 18 * INR n0 + 20); [ idtac | ring ].
-apply Rle_trans with 20.
-apply Rle_trans with 16.
-replace 16 with (Rsqr 4); [ idtac | ring_Rsqr ].
-replace (a * a) with (Rsqr a); [ idtac | reflexivity ].
-apply Rsqr_incr_1.
-apply Rle_trans with PI; [ assumption | apply PI_4 ].
-assumption.
-left; prove_sup0.
-rewrite <- (Rplus_0_r 16); replace 20 with (16 + 4);
- [ apply Rplus_le_compat_l; left; prove_sup0 | ring ].
-rewrite <- (Rplus_comm 20); pattern 20 at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_le_compat_l.
-apply Rplus_le_le_0_compat.
-repeat apply Rmult_le_pos.
-left; prove_sup0.
-left; prove_sup0.
-replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
-replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
-apply Rmult_le_pos.
-left; prove_sup0.
-replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-simpl in |- *; ring.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite plus_INR;
- do 2 rewrite mult_INR; repeat rewrite S_INR; ring.
-assert (H3 := cv_speed_pow_fact a); unfold Un in |- *; unfold Un_cv in H3;
- unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *; 
- intros; elim (H3 eps H4); intros N H5.
-exists N; intros; apply H5.
-replace (2 * S n0 + 1)%nat with (S (2 * S n0)).
-unfold ge in |- *; apply le_trans with (2 * S n0)%nat.
-apply le_trans with (2 * S N)%nat.
-apply le_trans with (2 * N)%nat.
-apply le_n_2n.
-apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
-apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
-apply le_n_Sn.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR; reflexivity.
-assert (X := exist_sin (Rsqr a)); elim X; intros.
-cut (x = sin a / a).
-intro; rewrite H3 in p; unfold sin_in in p; unfold infinit_sum in p;
- unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; 
- intros.
-cut (0 < eps / Rabs a).
-intro; elim (p _ H5); intros N H6.
-exists N; intros.
-replace (sum_f_R0 (tg_alt Un) n0) with
- (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))).
-unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
- rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
- repeat rewrite Rplus_assoc; rewrite (Rplus_comm a);
- rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; 
- rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a).
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-pattern (/ Rabs a) at 1 in |- *; rewrite <- (Rabs_Rinv a Hyp_a).
-rewrite <- Rabs_mult; rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc;
- rewrite <- Rinv_l_sym; [ rewrite Rmult_1_l | assumption ];
- rewrite (Rmult_comm (/ a)); rewrite (Rmult_comm (/ Rabs a));
- rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
- unfold Rminus, Rdiv in H6; apply H6; unfold ge in |- *;
- apply le_trans with n0; [ exact H7 | apply le_n_Sn ].
-rewrite (decomp_sum (fun i:nat => sin_n i * Rsqr a ^ i) (S n0)).
-replace (sin_n 0) with 1.
-simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
- rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
- rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse;
- rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; 
- apply sum_eq.
-intros; unfold sin_n, Un, tg_alt in |- *;
- replace ((-1) ^ S i) with (- (-1) ^ i).
-replace (a ^ (2 * S i + 1)) with (Rsqr a * Rsqr a ^ i * a).
-unfold Rdiv in |- *; ring.
-rewrite pow_add; rewrite pow_Rsqr; simpl in |- *; ring.
-simpl in |- *; ring.
-unfold sin_n in |- *; unfold Rdiv in |- *; simpl in |- *; rewrite Rinv_1;
- rewrite Rmult_1_r; reflexivity.
-apply lt_O_Sn.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-assumption.
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-unfold sin in |- *; case (exist_sin (Rsqr a)).
-intros; cut (x = x0).
-intro; rewrite H3; unfold Rdiv in |- *.
-symmetry  in |- *; apply Rinv_r_simpl_m; assumption.
-unfold sin_in in p; unfold sin_in in s; eapply uniqueness_sum.
-apply p.
-apply s.
-intros; elim H2; intros.
-replace (sin a - a) with (- (a - sin a)); [ idtac | ring ].
-split; apply Ropp_le_contravar; assumption.
-replace (- sum_f_R0 (tg_alt Un) (S (2 * n))) with
- (-1 * sum_f_R0 (tg_alt Un) (S (2 * n))); [ rewrite scal_sum | ring ].
-apply sum_eq; intros; unfold sin_term, Un, tg_alt in |- *;
- replace ((-1) ^ S i) with (-1 * (-1) ^ i).
-unfold Rdiv in |- *; ring.
-reflexivity.
-replace (- sum_f_R0 (tg_alt Un) (2 * n)) with
- (-1 * sum_f_R0 (tg_alt Un) (2 * n)); [ rewrite scal_sum | ring ].
-apply sum_eq; intros.
-unfold sin_term, Un, tg_alt in |- *;
- replace ((-1) ^ S i) with (-1 * (-1) ^ i).
-unfold Rdiv in |- *; ring.
-reflexivity.
-replace (2 * (n + 1))%nat with (S (S (2 * n))).
-reflexivity.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; rewrite plus_INR;
- repeat rewrite S_INR; ring.
-replace (2 * n + 1)%nat with (S (2 * n)).
-reflexivity.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
- repeat rewrite S_INR; ring.
-intro; elim H1; intros.
-split.
-apply Rplus_le_reg_l with (- a).
-rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
- rewrite (Rplus_comm (- a)); apply H2.
-apply Rplus_le_reg_l with (- a).
-rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
- rewrite (Rplus_comm (- a)); apply H3.
-unfold sin_term in |- *; simpl in |- *; unfold Rdiv in |- *; rewrite Rinv_1;
- ring.
-replace (2 * (n + 1))%nat with (S (S (2 * n))).
-apply lt_O_Sn.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; rewrite plus_INR;
- repeat rewrite S_INR; ring.
-replace (2 * n + 1)%nat with (S (2 * n)).
-apply lt_O_Sn.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
- repeat rewrite S_INR; ring.
-inversion H; [ assumption | elim Hyp_a; symmetry  in |- *; assumption ].
+  forall (a:R) (n:nat),
+    0 <= a ->
+    a <= PI -> sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)).
+Proof.
+  intros; case (Req_dec a 0); intro Hyp_a.
+  rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx in |- *;
+    apply sum_eq_R0 || (symmetry  in |- *; apply sum_eq_R0); 
+      intros; unfold sin_term in |- *; rewrite pow_add; 
+        simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l; 
+          ring.
+  unfold sin_approx in |- *; cut (0 < a).
+  intro Hyp_a_pos.
+  rewrite (decomp_sum (sin_term a) (2 * n + 1)).
+  rewrite (decomp_sum (sin_term a) (2 * (n + 1))).
+  replace (sin_term a 0) with a.
+  cut
+    (sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a - a /\
+      sin a - a <= sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1))) ->
+      a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a /\
+      sin a <= a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1)))).
+  intro; apply H1.
+  set (Un := fun n:nat => a ^ (2 * S n + 1) / INR (fact (2 * S n + 1))).
+  replace (pred (2 * n + 1)) with (2 * n)%nat.
+  replace (pred (2 * (n + 1))) with (S (2 * n)).
+  replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (2 * n)) with
+  (- sum_f_R0 (tg_alt Un) (2 * n)).
+  replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (S (2 * n))) with
+  (- sum_f_R0 (tg_alt Un) (S (2 * n))).
+  cut
+    (sum_f_R0 (tg_alt Un) (S (2 * n)) <= a - sin a <=
+      sum_f_R0 (tg_alt Un) (2 * n) ->
+      - sum_f_R0 (tg_alt Un) (2 * n) <= sin a - a <=
+      - sum_f_R0 (tg_alt Un) (S (2 * n))).
+  intro; apply H2.
+  apply alternated_series_ineq.
+  unfold Un_decreasing, Un in |- *; intro;
+    cut ((2 * S (S n0) + 1)%nat = S (S (2 * S n0 + 1))).
+  intro; rewrite H3.
+  replace (a ^ S (S (2 * S n0 + 1))) with (a ^ (2 * S n0 + 1) * (a * a)).
+  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  left; apply pow_lt; assumption.
+  apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n0 + 1))))).
+  rewrite <- H3; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
+    assert (H5 := sym_eq H4); elim (fact_neq_0 _ H5).
+  rewrite <- H3; rewrite (Rmult_comm (INR (fact (2 * S (S n0) + 1))));
+    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite H3; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
+    repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r.
+  do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
+    simpl in |- *;
+      replace
+      (((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1 + 1) *
+        ((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1)) with
+      (4 * INR n0 * INR n0 + 18 * INR n0 + 20); [ idtac | ring ].
+  apply Rle_trans with 20.
+  apply Rle_trans with 16.
+  replace 16 with (Rsqr 4); [ idtac | ring_Rsqr ].
+  replace (a * a) with (Rsqr a); [ idtac | reflexivity ].
+  apply Rsqr_incr_1.
+  apply Rle_trans with PI; [ assumption | apply PI_4 ].
+  assumption.
+  left; prove_sup0.
+  rewrite <- (Rplus_0_r 16); replace 20 with (16 + 4);
+    [ apply Rplus_le_compat_l; left; prove_sup0 | ring ].
+  rewrite <- (Rplus_comm 20); pattern 20 at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_le_compat_l.
+  apply Rplus_le_le_0_compat.
+  repeat apply Rmult_le_pos.
+  left; prove_sup0.
+  left; prove_sup0.
+  replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+  replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+  apply Rmult_le_pos.
+  left; prove_sup0.
+  replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  simpl in |- *; ring.
+  ring.
+  assert (H3 := cv_speed_pow_fact a); unfold Un in |- *; unfold Un_cv in H3;
+    unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *; 
+      intros; elim (H3 eps H4); intros N H5.
+  exists N; intros; apply H5.
+  replace (2 * S n0 + 1)%nat with (S (2 * S n0)).
+  unfold ge in |- *; apply le_trans with (2 * S n0)%nat.
+  apply le_trans with (2 * S N)%nat.
+  apply le_trans with (2 * N)%nat.
+  apply le_n_2n.
+  apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
+  apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
+  apply le_n_Sn.
+  ring.
+  assert (X := exist_sin (Rsqr a)); elim X; intros.
+  cut (x = sin a / a).
+  intro; rewrite H3 in p; unfold sin_in in p; unfold infinit_sum in p;
+    unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; 
+      intros.
+  cut (0 < eps / Rabs a).
+  intro; elim (p _ H5); intros N H6.
+  exists N; intros.
+  replace (sum_f_R0 (tg_alt Un) n0) with
+  (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))).
+  unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
+    rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+      repeat rewrite Rplus_assoc; rewrite (Rplus_comm a);
+        rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; 
+          rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+  pattern (/ Rabs a) at 1 in |- *; rewrite <- (Rabs_Rinv a Hyp_a).
+  rewrite <- Rabs_mult; rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc;
+    rewrite <- Rinv_l_sym; [ rewrite Rmult_1_l | assumption ];
+      rewrite (Rmult_comm (/ a)); rewrite (Rmult_comm (/ Rabs a));
+        rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+          unfold Rminus, Rdiv in H6; apply H6; unfold ge in |- *;
+            apply le_trans with n0; [ exact H7 | apply le_n_Sn ].
+  rewrite (decomp_sum (fun i:nat => sin_n i * Rsqr a ^ i) (S n0)).
+  replace (sin_n 0) with 1.
+  simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
+    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
+      rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse;
+        rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; 
+          apply sum_eq.
+  intros; unfold sin_n, Un, tg_alt in |- *;
+    replace ((-1) ^ S i) with (- (-1) ^ i).
+  replace (a ^ (2 * S i + 1)) with (Rsqr a * Rsqr a ^ i * a).
+  unfold Rdiv in |- *; ring.
+  rewrite pow_add; rewrite pow_Rsqr; simpl in |- *; ring.
+  simpl in |- *; ring.
+  unfold sin_n in |- *; unfold Rdiv in |- *; simpl in |- *; rewrite Rinv_1;
+    rewrite Rmult_1_r; reflexivity.
+  apply lt_O_Sn.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  assumption.
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+  unfold sin in |- *; case (exist_sin (Rsqr a)).
+  intros; cut (x = x0).
+  intro; rewrite H3; unfold Rdiv in |- *.
+  symmetry  in |- *; apply Rinv_r_simpl_m; assumption.
+  unfold sin_in in p; unfold sin_in in s; eapply uniqueness_sum.
+  apply p.
+  apply s.
+  intros; elim H2; intros.
+  replace (sin a - a) with (- (a - sin a)); [ idtac | ring ].
+  split; apply Ropp_le_contravar; assumption.
+  replace (- sum_f_R0 (tg_alt Un) (S (2 * n))) with
+  (-1 * sum_f_R0 (tg_alt Un) (S (2 * n))); [ rewrite scal_sum | ring ].
+  apply sum_eq; intros; unfold sin_term, Un, tg_alt in |- *;
+    replace ((-1) ^ S i) with (-1 * (-1) ^ i).
+  unfold Rdiv in |- *; ring.
+  reflexivity.
+  replace (- sum_f_R0 (tg_alt Un) (2 * n)) with
+  (-1 * sum_f_R0 (tg_alt Un) (2 * n)); [ rewrite scal_sum | ring ].
+  apply sum_eq; intros.
+  unfold sin_term, Un, tg_alt in |- *;
+    replace ((-1) ^ S i) with (-1 * (-1) ^ i).
+  unfold Rdiv in |- *; ring.
+  reflexivity.
+  replace (2 * (n + 1))%nat with (S (S (2 * n))).
+  reflexivity.
+  ring.
+  replace (2 * n + 1)%nat with (S (2 * n)).
+  reflexivity.
+  ring.
+  intro; elim H1; intros.
+  split.
+  apply Rplus_le_reg_l with (- a).
+  rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+    rewrite (Rplus_comm (- a)); apply H2.
+  apply Rplus_le_reg_l with (- a).
+  rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+    rewrite (Rplus_comm (- a)); apply H3.
+  unfold sin_term in |- *; simpl in |- *; unfold Rdiv in |- *; rewrite Rinv_1;
+    ring.
+  replace (2 * (n + 1))%nat with (S (S (2 * n))).
+  apply lt_O_Sn.
+  ring.
+  replace (2 * n + 1)%nat with (S (2 * n)).
+  apply lt_O_Sn.
+  ring.
+  inversion H; [ assumption | elim Hyp_a; symmetry  in |- *; assumption ].
 Qed.
 
 (**********)
 Lemma cos_bound :
- forall (a:R) (n:nat),
-   - PI / 2 <= a ->
-   a <= PI / 2 ->
-   cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). 
-cut
- ((forall (a:R) (n:nat),
-     0 <= a ->
-     a <= PI / 2 ->
-     cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))) ->
   forall (a:R) (n:nat),
     - PI / 2 <= a ->
     a <= PI / 2 ->
-    cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))).
-intros H a n; apply H.
-intros; unfold cos_approx in |- *.
-rewrite (decomp_sum (cos_term a0) (2 * n0 + 1)).
-rewrite (decomp_sum (cos_term a0) (2 * (n0 + 1))).
-replace (cos_term a0 0) with 1.
-cut
- (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 - 1 /\
-  cos a0 - 1 <=
-  sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1))) ->
-  1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 /\
-  cos a0 <=
-  1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1)))).
-intro; apply H2.
-set (Un := fun n:nat => a0 ^ (2 * S n) / INR (fact (2 * S n))).
-replace (pred (2 * n0 + 1)) with (2 * n0)%nat.
-replace (pred (2 * (n0 + 1))) with (S (2 * n0)).
-replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (2 * n0)) with
- (- sum_f_R0 (tg_alt Un) (2 * n0)).
-replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (S (2 * n0))) with
- (- sum_f_R0 (tg_alt Un) (S (2 * n0))).
-cut
- (sum_f_R0 (tg_alt Un) (S (2 * n0)) <= 1 - cos a0 <=
-  sum_f_R0 (tg_alt Un) (2 * n0) ->
-  - sum_f_R0 (tg_alt Un) (2 * n0) <= cos a0 - 1 <=
-  - sum_f_R0 (tg_alt Un) (S (2 * n0))).
-intro; apply H3.
-apply alternated_series_ineq.
-unfold Un_decreasing in |- *; intro; unfold Un in |- *.
-cut ((2 * S (S n1))%nat = S (S (2 * S n1))).
-intro; rewrite H4;
- replace (a0 ^ S (S (2 * S n1))) with (a0 ^ (2 * S n1) * (a0 * a0)).
-unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
-apply pow_le; assumption.
-apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n1))))).
-rewrite <- H4; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
- assert (H6 := sym_eq H5); elim (fact_neq_0 _ H6).
-rewrite <- H4; rewrite (Rmult_comm (INR (fact (2 * S (S n1)))));
- rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; rewrite H4; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
- repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; do 2 rewrite S_INR; rewrite mult_INR; repeat rewrite S_INR;
- simpl in |- *;
- replace
-  (((0 + 1 + 1) * (INR n1 + 1) + 1 + 1) * ((0 + 1 + 1) * (INR n1 + 1) + 1))
-  with (4 * INR n1 * INR n1 + 14 * INR n1 + 12); [ idtac | ring ].
-apply Rle_trans with 12.
-apply Rle_trans with 4.
-replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
-replace (a0 * a0) with (Rsqr a0); [ idtac | reflexivity ].
-apply Rsqr_incr_1.
-apply Rle_trans with (PI / 2).
-assumption.
-unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
-prove_sup0.
-rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m.
-replace 4 with 4; [ apply PI_4 | ring ].
-discrR.
-assumption.
-left; prove_sup0.
-pattern 4 at 1 in |- *; rewrite <- Rplus_0_r; replace 12 with (4 + 8);
- [ apply Rplus_le_compat_l; left; prove_sup0 | ring ].
-rewrite <- (Rplus_comm 12); pattern 12 at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_le_compat_l.
-apply Rplus_le_le_0_compat.
-repeat apply Rmult_le_pos.
-left; prove_sup0.
-left; prove_sup0.
-replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
-replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
-apply Rmult_le_pos.
-left; prove_sup0.
-replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-simpl in |- *; ring.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-assert (H4 := cv_speed_pow_fact a0); unfold Un in |- *; unfold Un_cv in H4;
- unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *; 
- intros; elim (H4 eps H5); intros N H6; exists N; intros.
-apply H6; unfold ge in |- *; apply le_trans with (2 * S N)%nat.
-apply le_trans with (2 * N)%nat.
-apply le_n_2n.
-apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
-apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
-assert (X := exist_cos (Rsqr a0)); elim X; intros.
-cut (x = cos a0).
-intro; rewrite H4 in p; unfold cos_in in p; unfold infinit_sum in p;
- unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; 
- intros.
-elim (p _ H5); intros N H6.
-exists N; intros.
-replace (sum_f_R0 (tg_alt Un) n1) with
- (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
-unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
- repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1);
- rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; 
- rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp;
- rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
- unfold Rminus in H6; apply H6.
-unfold ge in |- *; apply le_trans with n1.
-exact H7.
-apply le_n_Sn.
-rewrite (decomp_sum (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
-replace (cos_n 0) with 1.
-simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
- rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
- rewrite Rplus_0_l;
- replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1)
-  with
-  (-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1);
- [ idtac | ring ]; rewrite scal_sum; apply sum_eq; 
- intros; unfold cos_n, Un, tg_alt in |- *.
-replace ((-1) ^ S i) with (- (-1) ^ i).
-replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i).
-unfold Rdiv in |- *; ring.
-rewrite pow_Rsqr; reflexivity.
-simpl in |- *; ring.
-unfold cos_n in |- *; unfold Rdiv in |- *; simpl in |- *; rewrite Rinv_1;
- rewrite Rmult_1_r; reflexivity.
-apply lt_O_Sn.
-unfold cos in |- *; case (exist_cos (Rsqr a0)); intros; unfold cos_in in p;
- unfold cos_in in c; eapply uniqueness_sum.
-apply p.
-apply c.
-intros; elim H3; intros; replace (cos a0 - 1) with (- (1 - cos a0));
- [ idtac | ring ].
-split; apply Ropp_le_contravar; assumption.
-replace (- sum_f_R0 (tg_alt Un) (S (2 * n0))) with
- (-1 * sum_f_R0 (tg_alt Un) (S (2 * n0))); [ rewrite scal_sum | ring ].
-apply sum_eq; intros; unfold cos_term, Un, tg_alt in |- *;
- replace ((-1) ^ S i) with (-1 * (-1) ^ i).
-unfold Rdiv in |- *; ring.
-reflexivity.
-replace (- sum_f_R0 (tg_alt Un) (2 * n0)) with
- (-1 * sum_f_R0 (tg_alt Un) (2 * n0)); [ rewrite scal_sum | ring ];
- apply sum_eq; intros; unfold cos_term, Un, tg_alt in |- *;
- replace ((-1) ^ S i) with (-1 * (-1) ^ i).
-unfold Rdiv in |- *; ring.
-reflexivity.
-replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
-reflexivity.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; rewrite plus_INR;
- repeat rewrite S_INR; ring.
-replace (2 * n0 + 1)%nat with (S (2 * n0)).
-reflexivity.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
- repeat rewrite S_INR; ring.
-intro; elim H2; intros; split.
-apply Rplus_le_reg_l with (-1).
-rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
- rewrite (Rplus_comm (-1)); apply H3.
-apply Rplus_le_reg_l with (-1).
-rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
- rewrite (Rplus_comm (-1)); apply H4.
-unfold cos_term in |- *; simpl in |- *; unfold Rdiv in |- *; rewrite Rinv_1;
- ring.
-replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
-apply lt_O_Sn.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; rewrite plus_INR;
- repeat rewrite S_INR; ring.
-replace (2 * n0 + 1)%nat with (S (2 * n0)).
-apply lt_O_Sn.
-apply INR_eq; rewrite S_INR; rewrite plus_INR; rewrite mult_INR;
- repeat rewrite S_INR; ring.
-intros; case (total_order_T 0 a); intro.
-elim s; intro.
-apply H; [ left; assumption | assumption ].
-apply H; [ right; assumption | assumption ].
-cut (0 < - a).
-intro; cut (forall (x:R) (n:nat), cos_approx x n = cos_approx (- x) n).
-intro; rewrite H3; rewrite (H3 a (2 * (n + 1))%nat); rewrite cos_sym; apply H.
-left; assumption.
-rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_le_contravar;
- unfold Rdiv in |- *; unfold Rdiv in H0; rewrite <- Ropp_mult_distr_l_reverse;
- exact H0.
-intros; unfold cos_approx in |- *; apply sum_eq; intros;
- unfold cos_term in |- *; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg;
- unfold Rdiv in |- *; reflexivity.
-apply Ropp_0_gt_lt_contravar; assumption.
-Qed.
\ No newline at end of file
+    cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). 
+Proof.
+  cut
+    ((forall (a:R) (n:nat),
+      0 <= a ->
+      a <= PI / 2 ->
+      cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))) ->
+    forall (a:R) (n:nat),
+      - PI / 2 <= a ->
+      a <= PI / 2 ->
+      cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))).
+  intros H a n; apply H.
+  intros; unfold cos_approx in |- *.
+  rewrite (decomp_sum (cos_term a0) (2 * n0 + 1)).
+  rewrite (decomp_sum (cos_term a0) (2 * (n0 + 1))).
+  replace (cos_term a0 0) with 1.
+  cut
+    (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 - 1 /\
+      cos a0 - 1 <=
+      sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1))) ->
+      1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 /\
+      cos a0 <=
+      1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1)))).
+  intro; apply H2.
+  set (Un := fun n:nat => a0 ^ (2 * S n) / INR (fact (2 * S n))).
+  replace (pred (2 * n0 + 1)) with (2 * n0)%nat.
+  replace (pred (2 * (n0 + 1))) with (S (2 * n0)).
+  replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (2 * n0)) with
+  (- sum_f_R0 (tg_alt Un) (2 * n0)).
+  replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (S (2 * n0))) with
+  (- sum_f_R0 (tg_alt Un) (S (2 * n0))).
+  cut
+    (sum_f_R0 (tg_alt Un) (S (2 * n0)) <= 1 - cos a0 <=
+      sum_f_R0 (tg_alt Un) (2 * n0) ->
+      - sum_f_R0 (tg_alt Un) (2 * n0) <= cos a0 - 1 <=
+      - sum_f_R0 (tg_alt Un) (S (2 * n0))).
+  intro; apply H3.
+  apply alternated_series_ineq.
+  unfold Un_decreasing in |- *; intro; unfold Un in |- *.
+  cut ((2 * S (S n1))%nat = S (S (2 * S n1))).
+  intro; rewrite H4;
+    replace (a0 ^ S (S (2 * S n1))) with (a0 ^ (2 * S n1) * (a0 * a0)).
+  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  apply pow_le; assumption.
+  apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n1))))).
+  rewrite <- H4; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
+    assert (H6 := sym_eq H5); elim (fact_neq_0 _ H6).
+  rewrite <- H4; rewrite (Rmult_comm (INR (fact (2 * S (S n1)))));
+    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; rewrite H4; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
+    repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; do 2 rewrite S_INR; rewrite mult_INR; repeat rewrite S_INR;
+    simpl in |- *;
+      replace
+      (((0 + 1 + 1) * (INR n1 + 1) + 1 + 1) * ((0 + 1 + 1) * (INR n1 + 1) + 1))
+    with (4 * INR n1 * INR n1 + 14 * INR n1 + 12); [ idtac | ring ].
+  apply Rle_trans with 12.
+  apply Rle_trans with 4.
+  replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
+  replace (a0 * a0) with (Rsqr a0); [ idtac | reflexivity ].
+  apply Rsqr_incr_1.
+  apply Rle_trans with (PI / 2).
+  assumption.
+  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  prove_sup0.
+  rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m.
+  replace 4 with 4; [ apply PI_4 | ring ].
+  discrR.
+  assumption.
+  left; prove_sup0.
+  pattern 4 at 1 in |- *; rewrite <- Rplus_0_r; replace 12 with (4 + 8);
+    [ apply Rplus_le_compat_l; left; prove_sup0 | ring ].
+  rewrite <- (Rplus_comm 12); pattern 12 at 1 in |- *; rewrite <- Rplus_0_r;
+    apply Rplus_le_compat_l.
+  apply Rplus_le_le_0_compat.
+  repeat apply Rmult_le_pos.
+  left; prove_sup0.
+  left; prove_sup0.
+  replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+  replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+  apply Rmult_le_pos.
+  left; prove_sup0.
+  replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  simpl in |- *; ring.
+  ring.
+  assert (H4 := cv_speed_pow_fact a0); unfold Un in |- *; unfold Un_cv in H4;
+    unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *; 
+      intros; elim (H4 eps H5); intros N H6; exists N; intros.
+  apply H6; unfold ge in |- *; apply le_trans with (2 * S N)%nat.
+  apply le_trans with (2 * N)%nat.
+  apply le_n_2n.
+  apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
+  apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
+  assert (X := exist_cos (Rsqr a0)); elim X; intros.
+  cut (x = cos a0).
+  intro; rewrite H4 in p; unfold cos_in in p; unfold infinit_sum in p;
+    unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; 
+      intros.
+  elim (p _ H5); intros N H6.
+  exists N; intros.
+  replace (sum_f_R0 (tg_alt Un) n1) with
+  (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
+  unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+    repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1);
+      rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; 
+        rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp;
+          rewrite Ropp_plus_distr; rewrite Ropp_involutive; 
+            unfold Rminus in H6; apply H6.
+  unfold ge in |- *; apply le_trans with n1.
+  exact H7.
+  apply le_n_Sn.
+  rewrite (decomp_sum (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
+  replace (cos_n 0) with 1.
+  simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
+    rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
+      rewrite Rplus_0_l;
+        replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1)
+    with
+      (-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1);
+      [ idtac | ring ]; rewrite scal_sum; apply sum_eq; 
+        intros; unfold cos_n, Un, tg_alt in |- *.
+  replace ((-1) ^ S i) with (- (-1) ^ i).
+  replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i).
+  unfold Rdiv in |- *; ring.
+  rewrite pow_Rsqr; reflexivity.
+  simpl in |- *; ring.
+  unfold cos_n in |- *; unfold Rdiv in |- *; simpl in |- *; rewrite Rinv_1;
+    rewrite Rmult_1_r; reflexivity.
+  apply lt_O_Sn.
+  unfold cos in |- *; case (exist_cos (Rsqr a0)); intros; unfold cos_in in p;
+    unfold cos_in in c; eapply uniqueness_sum.
+  apply p.
+  apply c.
+  intros; elim H3; intros; replace (cos a0 - 1) with (- (1 - cos a0));
+    [ idtac | ring ].
+  split; apply Ropp_le_contravar; assumption.
+  replace (- sum_f_R0 (tg_alt Un) (S (2 * n0))) with
+  (-1 * sum_f_R0 (tg_alt Un) (S (2 * n0))); [ rewrite scal_sum | ring ].
+  apply sum_eq; intros; unfold cos_term, Un, tg_alt in |- *;
+    replace ((-1) ^ S i) with (-1 * (-1) ^ i).
+  unfold Rdiv in |- *; ring.
+  reflexivity.
+  replace (- sum_f_R0 (tg_alt Un) (2 * n0)) with
+  (-1 * sum_f_R0 (tg_alt Un) (2 * n0)); [ rewrite scal_sum | ring ];
+  apply sum_eq; intros; unfold cos_term, Un, tg_alt in |- *;
+    replace ((-1) ^ S i) with (-1 * (-1) ^ i).
+  unfold Rdiv in |- *; ring.
+  reflexivity.
+  replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
+  reflexivity.
+  ring.
+  replace (2 * n0 + 1)%nat with (S (2 * n0)).
+  reflexivity.
+  ring.
+  intro; elim H2; intros; split.
+  apply Rplus_le_reg_l with (-1).
+  rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+    rewrite (Rplus_comm (-1)); apply H3.
+  apply Rplus_le_reg_l with (-1).
+  rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
+    rewrite (Rplus_comm (-1)); apply H4.
+  unfold cos_term in |- *; simpl in |- *; unfold Rdiv in |- *; rewrite Rinv_1;
+    ring.
+  replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
+  apply lt_O_Sn.
+  ring.
+  replace (2 * n0 + 1)%nat with (S (2 * n0)).
+  apply lt_O_Sn.
+  ring.
+  intros; case (total_order_T 0 a); intro.
+  elim s; intro.
+  apply H; [ left; assumption | assumption ].
+  apply H; [ right; assumption | assumption ].
+  cut (0 < - a).
+  intro; cut (forall (x:R) (n:nat), cos_approx x n = cos_approx (- x) n).
+  intro; rewrite H3; rewrite (H3 a (2 * (n + 1))%nat); rewrite cos_sym; apply H.
+  left; assumption.
+  rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_le_contravar;
+    unfold Rdiv in |- *; unfold Rdiv in H0; rewrite <- Ropp_mult_distr_l_reverse;
+      exact H0.
+  intros; unfold cos_approx in |- *; apply sum_eq; intros;
+    unfold cos_term in |- *; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg;
+      unfold Rdiv in |- *; reflexivity.
+  apply Ropp_0_gt_lt_contravar; assumption.
+Qed.
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
index 0ef87322..baf0fa4b 100644
--- a/theories/Reals/Rtrigo_calc.v
+++ b/theories/Reals/Rtrigo_calc.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_calc.v,v 1.15.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+(*i $Id: Rtrigo_calc.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -16,365 +16,388 @@ Require Import R_sqrt.
 Open Local Scope R_scope.
 
 Lemma tan_PI : tan PI = 0.
-unfold tan in |- *; rewrite sin_PI; rewrite cos_PI; unfold Rdiv in |- *;
- apply Rmult_0_l. 
+Proof.
+  unfold tan in |- *; rewrite sin_PI; rewrite cos_PI; unfold Rdiv in |- *;
+    apply Rmult_0_l. 
 Qed.
 
 Lemma sin_3PI2 : sin (3 * (PI / 2)) = -1.
-replace (3 * (PI / 2)) with (PI + PI / 2).
-rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; rewrite sin_PI2; ring.
-pattern PI at 1 in |- *; rewrite (double_var PI); ring.
+Proof.
+  replace (3 * (PI / 2)) with (PI + PI / 2).
+  rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; rewrite sin_PI2; ring.
+  pattern PI at 1 in |- *; rewrite (double_var PI); ring.
 Qed.
 
 Lemma tan_2PI : tan (2 * PI) = 0.
-unfold tan in |- *; rewrite sin_2PI; unfold Rdiv in |- *; apply Rmult_0_l.
+Proof.
+  unfold tan in |- *; rewrite sin_2PI; unfold Rdiv in |- *; apply Rmult_0_l.
 Qed.
 
 Lemma sin_cos_PI4 : sin (PI / 4) = cos (PI / 4).
 Proof with trivial.
-rewrite cos_sin...
-replace (PI / 2 + PI / 4) with (- (PI / 4) + PI)...
-rewrite neg_sin; rewrite sin_neg; ring...
-cut (PI = PI / 2 + PI / 2); [ intro | apply double_var ]...
-pattern PI at 2 3 in |- *; rewrite H; pattern PI at 2 3 in |- *; rewrite H...
-assert (H0 : 2 <> 0);
- [ discrR | unfold Rdiv in |- *; rewrite Rinv_mult_distr; try ring ]...
+  rewrite cos_sin...
+  replace (PI / 2 + PI / 4) with (- (PI / 4) + PI)...
+  rewrite neg_sin; rewrite sin_neg; ring...
+  cut (PI = PI / 2 + PI / 2); [ intro | apply double_var ]...
+  pattern PI at 2 3 in |- *; rewrite H; pattern PI at 2 3 in |- *; rewrite H...
+  assert (H0 : 2 <> 0);
+    [ discrR | unfold Rdiv in |- *; rewrite Rinv_mult_distr; try ring ]...
 Qed.
 
 Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6).
 Proof with trivial.
-replace (PI / 6) with (PI / 2 - PI / 3)...
-rewrite cos_shift...
-assert (H0 : 6 <> 0); [ discrR | idtac ]...
-assert (H1 : 3 <> 0); [ discrR | idtac ]...
-assert (H2 : 2 <> 0); [ discrR | idtac ]...
-apply Rmult_eq_reg_l with 6...
-rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
-unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
-rewrite <- Rinv_l_sym...
-rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
-pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
- repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
-ring...
+  replace (PI / 6) with (PI / 2 - PI / 3)...
+  rewrite cos_shift...
+  assert (H0 : 6 <> 0); [ discrR | idtac ]...
+  assert (H1 : 3 <> 0); [ discrR | idtac ]...
+  assert (H2 : 2 <> 0); [ discrR | idtac ]...
+  apply Rmult_eq_reg_l with 6...
+  rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
+  unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
+  rewrite <- Rinv_l_sym...
+  rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
+  pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
+    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
+  ring...
 Qed.
 
 Lemma sin_PI6_cos_PI3 : cos (PI / 3) = sin (PI / 6).
 Proof with trivial.
-replace (PI / 6) with (PI / 2 - PI / 3)...
-rewrite sin_shift...
-assert (H0 : 6 <> 0); [ discrR | idtac ]...
-assert (H1 : 3 <> 0); [ discrR | idtac ]...
-assert (H2 : 2 <> 0); [ discrR | idtac ]...
-apply Rmult_eq_reg_l with 6...
-rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
-unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
-rewrite <- Rinv_l_sym...
-rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
-pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
- repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
-ring...
+  replace (PI / 6) with (PI / 2 - PI / 3)...
+  rewrite sin_shift...
+  assert (H0 : 6 <> 0); [ discrR | idtac ]...
+  assert (H1 : 3 <> 0); [ discrR | idtac ]...
+  assert (H2 : 2 <> 0); [ discrR | idtac ]...
+  apply Rmult_eq_reg_l with 6...
+  rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
+  unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
+  rewrite <- Rinv_l_sym...
+  rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
+  pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
+    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
+  ring...
 Qed.
 
 Lemma PI6_RGT_0 : 0 < PI / 6.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
+Proof.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
 Lemma PI6_RLT_PI2 : PI / 6 < PI / 2.
-unfold Rdiv in |- *; apply Rmult_lt_compat_l.
-apply PI_RGT_0.
-apply Rinv_lt_contravar; prove_sup.
+Proof.
+  unfold Rdiv in |- *; apply Rmult_lt_compat_l.
+  apply PI_RGT_0.
+  apply Rinv_lt_contravar; prove_sup.
 Qed.
 
 Lemma sin_PI6 : sin (PI / 6) = 1 / 2.
 Proof with trivial.
-assert (H : 2 <> 0); [ discrR | idtac ]...
-apply Rmult_eq_reg_l with (2 * cos (PI / 6))...
-replace (2 * cos (PI / 6) * sin (PI / 6)) with
- (2 * sin (PI / 6) * cos (PI / 6))...
-rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)...
-rewrite sin_PI3_cos_PI6...
-unfold Rdiv in |- *; rewrite Rmult_1_l; rewrite Rmult_assoc;
- pattern 2 at 2 in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym...
-rewrite Rmult_1_r...
-unfold Rdiv in |- *; rewrite Rinv_mult_distr...
-rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2);
- repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-rewrite Rmult_1_r...
-discrR...
-ring...
-apply prod_neq_R0...
-cut (0 < cos (PI / 6));
- [ intro H1; auto with real
- | apply cos_gt_0;
-    [ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)
-    | apply PI6_RLT_PI2 ] ]...
+  assert (H : 2 <> 0); [ discrR | idtac ]...
+  apply Rmult_eq_reg_l with (2 * cos (PI / 6))...
+  replace (2 * cos (PI / 6) * sin (PI / 6)) with
+  (2 * sin (PI / 6) * cos (PI / 6))...
+  rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)...
+  rewrite sin_PI3_cos_PI6...
+  unfold Rdiv in |- *; rewrite Rmult_1_l; rewrite Rmult_assoc;
+    pattern 2 at 2 in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
+      rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_r...
+  unfold Rdiv in |- *; rewrite Rinv_mult_distr...
+  rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2);
+    repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_r...
+  discrR...
+  ring...
+  apply prod_neq_R0...
+  cut (0 < cos (PI / 6));
+    [ intro H1; auto with real
+      | apply cos_gt_0;
+        [ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)
+          | apply PI6_RLT_PI2 ] ]...
 Qed.
 
 Lemma sqrt2_neq_0 : sqrt 2 <> 0.
-assert (Hyp : 0 < 2);
- [ prove_sup0
- | generalize (Rlt_le 0 2 Hyp); intro H1; red in |- *; intro H2;
-    generalize (sqrt_eq_0 2 H1 H2); intro H; absurd (2 = 0);
-    [ discrR | assumption ] ].
+Proof.
+  assert (Hyp : 0 < 2);
+    [ prove_sup0
+      | generalize (Rlt_le 0 2 Hyp); intro H1; red in |- *; intro H2;
+        generalize (sqrt_eq_0 2 H1 H2); intro H; absurd (2 = 0);
+          [ discrR | assumption ] ].
 Qed.
 
 Lemma R1_sqrt2_neq_0 : 1 / sqrt 2 <> 0.
-generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H;
- generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); 
- intro H0; assumption.
+Proof.
+  generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H;
+    generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); 
+      intro H0; assumption.
 Qed.
 
 Lemma sqrt3_2_neq_0 : 2 * sqrt 3 <> 0.
-apply prod_neq_R0;
- [ discrR
- | assert (Hyp : 0 < 3);
-    [ prove_sup0
-    | generalize (Rlt_le 0 3 Hyp); intro H1; red in |- *; intro H2;
-       generalize (sqrt_eq_0 3 H1 H2); intro H; absurd (3 = 0);
-       [ discrR | assumption ] ] ].
+Proof.
+  apply prod_neq_R0;
+    [ discrR
+      | assert (Hyp : 0 < 3);
+        [ prove_sup0
+          | generalize (Rlt_le 0 3 Hyp); intro H1; red in |- *; intro H2;
+            generalize (sqrt_eq_0 3 H1 H2); intro H; absurd (3 = 0);
+              [ discrR | assumption ] ] ].
 Qed.
 
 Lemma Rlt_sqrt2_0 : 0 < sqrt 2.
-assert (Hyp : 0 < 2);
- [ prove_sup0
- | generalize (sqrt_positivity 2 (Rlt_le 0 2 Hyp)); intro H1; elim H1;
-    intro H2;
-    [ assumption
-    | absurd (0 = sqrt 2);
-       [ apply (sym_not_eq (A:=R)); apply sqrt2_neq_0 | assumption ] ] ].
+Proof.
+  assert (Hyp : 0 < 2);
+    [ prove_sup0
+      | generalize (sqrt_positivity 2 (Rlt_le 0 2 Hyp)); intro H1; elim H1;
+        intro H2;
+          [ assumption
+            | absurd (0 = sqrt 2);
+              [ apply (sym_not_eq (A:=R)); apply sqrt2_neq_0 | assumption ] ] ].
 Qed.
 
 Lemma Rlt_sqrt3_0 : 0 < sqrt 3.
-cut (0%nat <> 1%nat);
- [ intro H0; assert (Hyp : 0 < 2);
-    [ prove_sup0
-    | generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3);
-       [ prove_sup0
-       | generalize (Rlt_le 0 3 Hyp2); intro H2;
-          generalize (lt_INR_0 1 (neq_O_lt 1 H0)); 
-          unfold INR in |- *; intro H3;
-          generalize (Rplus_lt_compat_l 2 0 1 H3); 
-          rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3;
-          [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3;
-             apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3)
-          | ring ] ] ]
- | discriminate ].
+Proof.
+  cut (0%nat <> 1%nat);
+    [ intro H0; assert (Hyp : 0 < 2);
+      [ prove_sup0
+        | generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3);
+          [ prove_sup0
+            | generalize (Rlt_le 0 3 Hyp2); intro H2;
+              generalize (lt_INR_0 1 (neq_O_lt 1 H0)); 
+                unfold INR in |- *; intro H3;
+                  generalize (Rplus_lt_compat_l 2 0 1 H3); 
+                    rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3;
+                      [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3;
+                        apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3)
+                        | ring ] ] ]
+      | discriminate ].
 Qed.
 
 Lemma PI4_RGT_0 : 0 < PI / 4.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
+Proof.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
 Lemma cos_PI4 : cos (PI / 4) = 1 / sqrt 2.
 Proof with trivial.
-apply Rsqr_inj...
-apply cos_ge_0...
-left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 4) _PI2_RLT_0 PI4_RGT_0)...
-left; apply PI4_RLT_PI2...
-left; apply (Rmult_lt_0_compat 1 (/ sqrt 2))...
-prove_sup...
-apply Rinv_0_lt_compat; apply Rlt_sqrt2_0...
-rewrite Rsqr_div...
-rewrite Rsqr_1; rewrite Rsqr_sqrt...
-assert (H : 2 <> 0); [ discrR | idtac ]...
-unfold Rsqr in |- *; pattern (cos (PI / 4)) at 1 in |- *;
- rewrite <- sin_cos_PI4;
- replace (sin (PI / 4) * cos (PI / 4)) with
-  (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))...
-rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)...
-rewrite sin_PI2...
-apply Rmult_1_r...
-unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr...
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-rewrite Rmult_1_r...
-unfold Rdiv in |- *; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc...
-rewrite <- Rinv_l_sym...
-rewrite Rmult_1_l...
-left; prove_sup...
-apply sqrt2_neq_0...
+  apply Rsqr_inj...
+  apply cos_ge_0...
+  left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 4) _PI2_RLT_0 PI4_RGT_0)...
+  left; apply PI4_RLT_PI2...
+  left; apply (Rmult_lt_0_compat 1 (/ sqrt 2))...
+  prove_sup...
+  apply Rinv_0_lt_compat; apply Rlt_sqrt2_0...
+  rewrite Rsqr_div...
+  rewrite Rsqr_1; rewrite Rsqr_sqrt...
+  assert (H : 2 <> 0); [ discrR | idtac ]...
+  unfold Rsqr in |- *; pattern (cos (PI / 4)) at 1 in |- *;
+    rewrite <- sin_cos_PI4;
+      replace (sin (PI / 4) * cos (PI / 4)) with
+      (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))...
+  rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)...
+  rewrite sin_PI2...
+  apply Rmult_1_r...
+  unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr...
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_r...
+  unfold Rdiv in |- *; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc...
+  rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_l...
+  left; prove_sup...
+  apply sqrt2_neq_0...
 Qed.
 
 Lemma sin_PI4 : sin (PI / 4) = 1 / sqrt 2.
-rewrite sin_cos_PI4; apply cos_PI4.
+Proof.
+  rewrite sin_cos_PI4; apply cos_PI4.
 Qed.
 
 Lemma tan_PI4 : tan (PI / 4) = 1.
-unfold tan in |- *; rewrite sin_cos_PI4.
-unfold Rdiv in |- *; apply Rinv_r.
-change (cos (PI / 4) <> 0) in |- *; rewrite cos_PI4; apply R1_sqrt2_neq_0.
+Proof.
+  unfold tan in |- *; rewrite sin_cos_PI4.
+  unfold Rdiv in |- *; apply Rinv_r.
+  change (cos (PI / 4) <> 0) in |- *; rewrite cos_PI4; apply R1_sqrt2_neq_0.
 Qed.
 
 Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2.
 Proof with trivial.
-replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
-rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4...
-unfold Rdiv in |- *; rewrite Ropp_mult_distr_l_reverse...
-unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
- rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
- repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
- [ ring | discrR | discrR ]...
+  replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
+  rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4...
+  unfold Rdiv in |- *; rewrite Ropp_mult_distr_l_reverse...
+  unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
+    rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+      repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
+        [ ring | discrR | discrR ]...
 Qed.
 
 Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2.
 Proof with trivial.
-replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
-rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4...
-unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
- rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
- repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
- [ ring | discrR | discrR ]...
+  replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
+  rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4...
+  unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
+    rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+      repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
+        [ ring | discrR | discrR ]...
 Qed.
 
 Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2.
 Proof with trivial.
-apply Rsqr_inj...
-apply cos_ge_0...
-left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)...
-left; apply PI6_RLT_PI2...
-left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))...
-apply Rlt_sqrt3_0...
-apply Rinv_0_lt_compat; prove_sup0...
-assert (H : 2 <> 0); [ discrR | idtac ]...
-assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
-rewrite Rsqr_div...
-rewrite cos2; unfold Rsqr in |- *; rewrite sin_PI6; rewrite sqrt_def...
-unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
-rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3);
- repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
-rewrite Rmult_1_l; rewrite Rmult_1_r...
-rewrite <- (Rmult_comm (/ 2)); repeat rewrite <- Rmult_assoc...
-rewrite <- Rinv_l_sym...
-rewrite Rmult_1_l; rewrite <- Rinv_r_sym...
-ring...
-left; prove_sup0...
+  apply Rsqr_inj...
+  apply cos_ge_0...
+  left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)...
+  left; apply PI6_RLT_PI2...
+  left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))...
+  apply Rlt_sqrt3_0...
+  apply Rinv_0_lt_compat; prove_sup0...
+  assert (H : 2 <> 0); [ discrR | idtac ]...
+  assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
+  rewrite Rsqr_div...
+  rewrite cos2; unfold Rsqr in |- *; rewrite sin_PI6; rewrite sqrt_def...
+  unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
+  rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3);
+    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
+  rewrite Rmult_1_l; rewrite Rmult_1_r...
+  rewrite <- (Rmult_comm (/ 2)); repeat rewrite <- Rmult_assoc...
+  rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_l; rewrite <- Rinv_r_sym...
+  ring...
+  left; prove_sup0...
 Qed.
 
 Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3.
-unfold tan in |- *; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv in |- *;
- repeat rewrite Rmult_1_l; rewrite Rinv_mult_distr.
-rewrite Rinv_involutive.
-rewrite (Rmult_comm (/ 2)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-apply Rmult_1_r.
-discrR.
-discrR.
-red in |- *; intro; assert (H1 := Rlt_sqrt3_0); rewrite H in H1;
- elim (Rlt_irrefl 0 H1).
-apply Rinv_neq_0_compat; discrR.
+Proof.
+  unfold tan in |- *; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv in |- *;
+    repeat rewrite Rmult_1_l; rewrite Rinv_mult_distr.
+  rewrite Rinv_involutive.
+  rewrite (Rmult_comm (/ 2)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  apply Rmult_1_r.
+  discrR.
+  discrR.
+  red in |- *; intro; assert (H1 := Rlt_sqrt3_0); rewrite H in H1;
+    elim (Rlt_irrefl 0 H1).
+  apply Rinv_neq_0_compat; discrR.
 Qed.
 
 Lemma sin_PI3 : sin (PI / 3) = sqrt 3 / 2.
-rewrite sin_PI3_cos_PI6; apply cos_PI6.
+Proof.
+  rewrite sin_PI3_cos_PI6; apply cos_PI6.
 Qed.
 
 Lemma cos_PI3 : cos (PI / 3) = 1 / 2.
-rewrite sin_PI6_cos_PI3; apply sin_PI6.
+Proof.
+  rewrite sin_PI6_cos_PI3; apply sin_PI6.
 Qed.
 
 Lemma tan_PI3 : tan (PI / 3) = sqrt 3.
-unfold tan in |- *; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv in |- *;
- rewrite Rmult_1_l; rewrite Rinv_involutive.
-rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-apply Rmult_1_r.
-discrR.
-discrR.
+Proof.
+  unfold tan in |- *; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv in |- *;
+    rewrite Rmult_1_l; rewrite Rinv_involutive.
+  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  apply Rmult_1_r.
+  discrR.
+  discrR.
 Qed.
 
 Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2.
-rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3;
- unfold Rdiv in |- *; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2));
- repeat rewrite <- Rmult_assoc; rewrite double_var; 
- reflexivity.
+Proof.
+  rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3;
+    unfold Rdiv in |- *; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2));
+      repeat rewrite <- Rmult_assoc; rewrite double_var; 
+        reflexivity.
 Qed.
 
 Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2.
 Proof with trivial.
-assert (H : 2 <> 0); [ discrR | idtac ]...
-assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
-rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3;
- unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
-rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc;
- rewrite (Rmult_comm 2)...
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-rewrite Rmult_1_r; rewrite <- Rinv_r_sym...
-pattern 2 at 4 in |- *; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym...
-rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r...
-rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-rewrite Rmult_1_r; rewrite (Rmult_comm 2); rewrite (Rmult_comm (/ 2))...
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
-rewrite Rmult_1_r; rewrite sqrt_def...
-ring...
-left; prove_sup...
+  assert (H : 2 <> 0); [ discrR | idtac ]...
+  assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
+  rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3;
+    unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
+  rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc;
+    rewrite (Rmult_comm 2)...
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_r; rewrite <- Rinv_r_sym...
+  pattern 2 at 4 in |- *; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r...
+  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_r; rewrite (Rmult_comm 2); rewrite (Rmult_comm (/ 2))...
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_r; rewrite sqrt_def...
+  ring...
+  left; prove_sup...
 Qed.
 
 Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3.
 Proof with trivial.
-assert (H : 2 <> 0); [ discrR | idtac ]...
-unfold tan in |- *; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv in |- *;
- rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
- rewrite <- Ropp_inv_permute...
-rewrite Rinv_involutive...
-rewrite Rmult_assoc; rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_l_sym...
-ring...
-apply Rinv_neq_0_compat...
+  assert (H : 2 <> 0); [ discrR | idtac ]...
+  unfold tan in |- *; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv in |- *;
+    rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
+      rewrite <- Ropp_inv_permute...
+  rewrite Rinv_involutive...
+  rewrite Rmult_assoc; rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_l_sym...
+  ring...
+  apply Rinv_neq_0_compat...
 Qed.
 
 Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2.
 Proof with trivial.
-replace (5 * (PI / 4)) with (PI / 4 + PI)...
-rewrite neg_cos; rewrite cos_PI4; unfold Rdiv in |- *;
- rewrite Ropp_mult_distr_l_reverse...
-pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
- rewrite double_var; assert (H : 2 <> 0);
- [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
+  replace (5 * (PI / 4)) with (PI / 4 + PI)...
+  rewrite neg_cos; rewrite cos_PI4; unfold Rdiv in |- *;
+    rewrite Ropp_mult_distr_l_reverse...
+  pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
+    rewrite double_var; assert (H : 2 <> 0);
+      [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
 Qed.
 
 Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2.
 Proof with trivial.
-replace (5 * (PI / 4)) with (PI / 4 + PI)...
-rewrite neg_sin; rewrite sin_PI4; unfold Rdiv in |- *;
- rewrite Ropp_mult_distr_l_reverse...
-pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
- rewrite double_var; assert (H : 2 <> 0);
- [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
+  replace (5 * (PI / 4)) with (PI / 4 + PI)...
+  rewrite neg_sin; rewrite sin_PI4; unfold Rdiv in |- *;
+    rewrite Ropp_mult_distr_l_reverse...
+  pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
+    rewrite double_var; assert (H : 2 <> 0);
+      [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
 Qed.
 
 Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)).
-rewrite cos_5PI4; rewrite sin_5PI4; reflexivity.
+Proof.
+  rewrite cos_5PI4; rewrite sin_5PI4; reflexivity.
 Qed.
 
 Lemma Rgt_3PI2_0 : 0 < 3 * (PI / 2).
-apply Rmult_lt_0_compat;
- [ prove_sup0
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ] ].
+Proof.
+  apply Rmult_lt_0_compat;
+    [ prove_sup0
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ] ].
 Qed.
 
 Lemma Rgt_2PI_0 : 0 < 2 * PI.
-apply Rmult_lt_0_compat; [ prove_sup0 | apply PI_RGT_0 ].
+Proof.
+  apply Rmult_lt_0_compat; [ prove_sup0 | apply PI_RGT_0 ].
 Qed.
 
 Lemma Rlt_PI_3PI2 : PI < 3 * (PI / 2).
-generalize PI2_RGT_0; intro H1;
- generalize (Rplus_lt_compat_l PI 0 (PI / 2) H1);
- replace (PI + PI / 2) with (3 * (PI / 2)).
-rewrite Rplus_0_r; intro H2; assumption.
-pattern PI at 2 in |- *; rewrite double_var; ring.
+Proof.
+  generalize PI2_RGT_0; intro H1;
+    generalize (Rplus_lt_compat_l PI 0 (PI / 2) H1);
+      replace (PI + PI / 2) with (3 * (PI / 2)).
+  rewrite Rplus_0_r; intro H2; assumption.
+  pattern PI at 2 in |- *; rewrite double_var; ring.
 Qed. 
- 
+
 Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI.
-generalize PI2_RGT_0; intro H1;
- generalize (Rplus_lt_compat_l (3 * (PI / 2)) 0 (PI / 2) H1);
- replace (3 * (PI / 2) + PI / 2) with (2 * PI).
-rewrite Rplus_0_r; intro H2; assumption.
-rewrite double; pattern PI at 1 2 in |- *; rewrite double_var; ring.
+Proof.
+  generalize PI2_RGT_0; intro H1;
+    generalize (Rplus_lt_compat_l (3 * (PI / 2)) 0 (PI / 2) H1);
+      replace (3 * (PI / 2) + PI / 2) with (2 * PI).
+  rewrite Rplus_0_r; intro H2; assumption.
+  rewrite double; pattern PI at 1 2 in |- *; rewrite double_var; ring.
 Qed.
 
 (***************************************************************)
-(* Radian -> Degree | Degree -> Radian                         *)
+(** Radian -> Degree | Degree -> Radian                        *)
 (***************************************************************)
 
 Definition plat : R := 180.
@@ -382,27 +405,30 @@ Definition toRad (x:R) : R := x * PI * / plat.
 Definition toDeg (x:R) : R := x * plat * / PI.
 
 Lemma rad_deg : forall x:R, toRad (toDeg x) = x.
-intro; unfold toRad, toDeg in |- *;
- replace (x * plat * / PI * PI * / plat) with
-  (x * (plat * / plat) * (PI * / PI)); [ idtac | ring ].
-repeat rewrite <- Rinv_r_sym.
-ring.
-apply PI_neq0.
-unfold plat in |- *; discrR.
+Proof.
+  intro; unfold toRad, toDeg in |- *;
+    replace (x * plat * / PI * PI * / plat) with
+    (x * (plat * / plat) * (PI * / PI)); [ idtac | ring ].
+  repeat rewrite <- Rinv_r_sym.
+  ring.
+  apply PI_neq0.
+  unfold plat in |- *; discrR.
 Qed.
 
 Lemma toRad_inj : forall x y:R, toRad x = toRad y -> x = y.
-intros; unfold toRad in H; apply Rmult_eq_reg_l with PI.
-rewrite <- (Rmult_comm x); rewrite <- (Rmult_comm y).
-apply Rmult_eq_reg_l with (/ plat).
-rewrite <- (Rmult_comm (x * PI)); rewrite <- (Rmult_comm (y * PI));
- assumption.
-apply Rinv_neq_0_compat; unfold plat in |- *; discrR.
-apply PI_neq0.
+Proof.
+  intros; unfold toRad in H; apply Rmult_eq_reg_l with PI.
+  rewrite <- (Rmult_comm x); rewrite <- (Rmult_comm y).
+  apply Rmult_eq_reg_l with (/ plat).
+  rewrite <- (Rmult_comm (x * PI)); rewrite <- (Rmult_comm (y * PI));
+    assumption.
+  apply Rinv_neq_0_compat; unfold plat in |- *; discrR.
+  apply PI_neq0.
 Qed.
 
 Lemma deg_rad : forall x:R, toDeg (toRad x) = x.
-intro x; apply toRad_inj; rewrite (rad_deg (toRad x)); reflexivity.
+Proof.
+  intro x; apply toRad_inj; rewrite (rad_deg (toRad x)); reflexivity.
 Qed.
 
 Definition sind (x:R) : R := sin (toRad x).
@@ -410,25 +436,27 @@ Definition cosd (x:R) : R := cos (toRad x).
 Definition tand (x:R) : R := tan (toRad x).
 
 Lemma Rsqr_sin_cos_d_one : forall x:R, Rsqr (sind x) + Rsqr (cosd x) = 1.
-intro x; unfold sind in |- *; unfold cosd in |- *; apply sin2_cos2.
+Proof.
+  intro x; unfold sind in |- *; unfold cosd in |- *; apply sin2_cos2.
 Qed.
 
 (***************************************************)
-(*                Other properties                 *)
+(**               Other properties                 *)
 (***************************************************)
 
 Lemma sin_lb_ge_0 : forall a:R, 0 <= a -> a <= PI / 2 -> 0 <= sin_lb a.
-intros; case (Rtotal_order 0 a); intro.
-left; apply sin_lb_gt_0; assumption.
-elim H1; intro.
-rewrite <- H2; unfold sin_lb in |- *; unfold sin_approx in |- *;
- unfold sum_f_R0 in |- *; unfold sin_term in |- *; 
- repeat rewrite pow_ne_zero.
-unfold Rdiv in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
- repeat rewrite Rplus_0_r; right; reflexivity.
-discriminate.
-discriminate.
-discriminate.
-discriminate.
-elim (Rlt_irrefl 0 (Rle_lt_trans 0 a 0 H H2)).
-Qed.
\ No newline at end of file
+Proof.
+  intros; case (Rtotal_order 0 a); intro.
+  left; apply sin_lb_gt_0; assumption.
+  elim H1; intro.
+  rewrite <- H2; unfold sin_lb in |- *; unfold sin_approx in |- *;
+    unfold sum_f_R0 in |- *; unfold sin_term in |- *; 
+      repeat rewrite pow_ne_zero.
+  unfold Rdiv in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
+    repeat rewrite Rplus_0_r; right; reflexivity.
+  discriminate.
+  discriminate.
+  discriminate.
+  discriminate.
+  elim (Rlt_irrefl 0 (Rle_lt_trans 0 a 0 H H2)).
+Qed.
diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v
index 92ec68ce..b2aeb766 100644
--- a/theories/Reals/Rtrigo_def.v
+++ b/theories/Reals/Rtrigo_def.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Rtrigo_def.v,v 1.17.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+(*i $Id: Rtrigo_def.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -15,212 +15,222 @@ Require Import Rtrigo_fun.
 Require Import Max.
 Open Local Scope R_scope.
 
-(*****************************)
-(* Definition of exponential *)
-(*****************************)
+(********************************)
+(** * Definition of exponential *)
+(********************************)
 Definition exp_in (x l:R) : Prop :=
   infinit_sum (fun i:nat => / INR (fact i) * x ^ i) l.
 
 Lemma exp_cof_no_R0 : forall n:nat, / INR (fact n) <> 0.
-intro.
-apply Rinv_neq_0_compat.
-apply INR_fact_neq_0.
+Proof.
+  intro.
+  apply Rinv_neq_0_compat.
+  apply INR_fact_neq_0.
 Qed.
 
 Lemma exist_exp : forall x:R, sigT (fun l:R => exp_in x l).
-intro;
- generalize
-  (Alembert_C3 (fun n:nat => / INR (fact n)) x exp_cof_no_R0 Alembert_exp).
-unfold Pser, exp_in in |- *.
-trivial.
+Proof.
+  intro;
+    generalize
+      (Alembert_C3 (fun n:nat => / INR (fact n)) x exp_cof_no_R0 Alembert_exp).
+  unfold Pser, exp_in in |- *.
+  trivial.
 Defined.
 
 Definition exp (x:R) : R := projT1 (exist_exp x).
 
 Lemma pow_i : forall i:nat, (0 < i)%nat -> 0 ^ i = 0.
-intros; apply pow_ne_zero.
-red in |- *; intro; rewrite H0 in H; elim (lt_irrefl _ H).
+Proof.
+  intros; apply pow_ne_zero.
+  red in |- *; intro; rewrite H0 in H; elim (lt_irrefl _ H).
 Qed.
 
 (*i Calculus of $e^0$ *)
 Lemma exist_exp0 : sigT (fun l:R => exp_in 0 l).
-apply existT with 1.
-unfold exp_in in |- *; unfold infinit_sum in |- *; intros.
-exists 0%nat.
-intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1.
-unfold R_dist in |- *; replace (1 - 1) with 0;
- [ rewrite Rabs_R0; assumption | ring ].
-induction  n as [| n Hrecn].
-simpl in |- *; rewrite Rinv_1; ring.
-rewrite tech5.
-rewrite <- Hrecn.
-simpl in |- *.
-ring.
-unfold ge in |- *; apply le_O_n.
+Proof.
+  apply existT with 1.
+  unfold exp_in in |- *; unfold infinit_sum in |- *; intros.
+  exists 0%nat.
+  intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1.
+  unfold R_dist in |- *; replace (1 - 1) with 0;
+    [ rewrite Rabs_R0; assumption | ring ].
+  induction  n as [| n Hrecn].
+  simpl in |- *; rewrite Rinv_1; ring.
+  rewrite tech5.
+  rewrite <- Hrecn.
+  simpl in |- *.
+  ring.
+  unfold ge in |- *; apply le_O_n.
 Defined.
 
 Lemma exp_0 : exp 0 = 1. 
-cut (exp_in 0 (exp 0)).
-cut (exp_in 0 1).
-unfold exp_in in |- *; intros; eapply uniqueness_sum.
-apply H0.
-apply H.
-exact (projT2 exist_exp0).
-exact (projT2 (exist_exp 0)).
+Proof.
+  cut (exp_in 0 (exp 0)).
+  cut (exp_in 0 1).
+  unfold exp_in in |- *; intros; eapply uniqueness_sum.
+  apply H0.
+  apply H.
+  exact (projT2 exist_exp0).
+  exact (projT2 (exist_exp 0)).
 Qed.
 
-(**************************************)
-(* Definition of hyperbolic functions *)
-(**************************************)
+(*****************************************)
+(** * Definition of hyperbolic functions *)
+(*****************************************)
 Definition cosh (x:R) : R := (exp x + exp (- x)) / 2.
 Definition sinh (x:R) : R := (exp x - exp (- x)) / 2.
 Definition tanh (x:R) : R := sinh x / cosh x.
 
 Lemma cosh_0 : cosh 0 = 1.
-unfold cosh in |- *; rewrite Ropp_0; rewrite exp_0.
-unfold Rdiv in |- *; rewrite <- Rinv_r_sym; [ reflexivity | discrR ].
+Proof.
+  unfold cosh in |- *; rewrite Ropp_0; rewrite exp_0.
+  unfold Rdiv in |- *; rewrite <- Rinv_r_sym; [ reflexivity | discrR ].
 Qed.
 
 Lemma sinh_0 : sinh 0 = 0.
-unfold sinh in |- *; rewrite Ropp_0; rewrite exp_0.
-unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; apply Rmult_0_l.
+Proof.
+  unfold sinh in |- *; rewrite Ropp_0; rewrite exp_0.
+  unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; apply Rmult_0_l.
 Qed.
 
 Definition cos_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n)).
 
 Lemma simpl_cos_n :
- forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). 
-intro; unfold cos_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
-rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
-rewrite Rinv_involutive.
-replace
- ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1))) *
-  (/ (-1) ^ n * INR (fact (2 * n)))) with
- ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1))) * INR (fact (2 * n)) *
-  (-1) ^ 1); [ idtac | ring ].
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; unfold pow in |- *; rewrite Rmult_1_r.
-replace (2 * (n + 1))%nat with (S (S (2 * n))); [ idtac | ring ].
-do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
- repeat rewrite Rinv_mult_distr; try (apply not_O_INR; discriminate).
-rewrite <- (Rmult_comm (-1)).
-repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r.
-replace (S (2 * n)) with (2 * n + 1)%nat; [ idtac | ring ].
-rewrite mult_INR; rewrite Rinv_mult_distr.
-ring.
-apply not_O_INR; discriminate.
-replace (2 * n + 1)%nat with (S (2 * n));
- [ apply not_O_INR; discriminate | ring ].
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
-apply pow_nonzero; discrR.
-apply INR_fact_neq_0.
-apply pow_nonzero; discrR.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). 
+Proof.
+  intro; unfold cos_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  rewrite Rinv_involutive.
+  replace
+  ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1))) *
+    (/ (-1) ^ n * INR (fact (2 * n)))) with
+  ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1))) * INR (fact (2 * n)) *
+    (-1) ^ 1); [ idtac | ring ].
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; unfold pow in |- *; rewrite Rmult_1_r.
+  replace (2 * (n + 1))%nat with (S (S (2 * n))); [ idtac | ring ].
+  do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
+    repeat rewrite Rinv_mult_distr; try (apply not_O_INR; discriminate).
+  rewrite <- (Rmult_comm (-1)).
+  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  replace (S (2 * n)) with (2 * n + 1)%nat; [ idtac | ring ].
+  rewrite mult_INR; rewrite Rinv_mult_distr.
+  ring.
+  apply not_O_INR; discriminate.
+  replace (2 * n + 1)%nat with (S (2 * n));
+  [ apply not_O_INR; discriminate | ring ].
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+  apply pow_nonzero; discrR.
+  apply INR_fact_neq_0.
+  apply pow_nonzero; discrR.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
 Qed.
 
 Lemma archimed_cor1 :
- forall eps:R, 0 < eps ->  exists N : nat, / INR N < eps /\ (0 < N)%nat.
-intros; cut (/ eps < IZR (up (/ eps))).
-intro; cut (0 <= up (/ eps))%Z.
-intro; assert (H2 := IZN _ H1); elim H2; intros; exists (max x 1).
-split.
-cut (0 < IZR (Z_of_nat x)).
-intro; rewrite INR_IZR_INZ; apply Rle_lt_trans with (/ IZR (Z_of_nat x)).
-apply Rmult_le_reg_l with (IZR (Z_of_nat x)).
-assumption.
-rewrite <- Rinv_r_sym;
- [ idtac | red in |- *; intro; rewrite H5 in H4; elim (Rlt_irrefl _ H4) ].
-apply Rmult_le_reg_l with (IZR (Z_of_nat (max x 1))).
-apply Rlt_le_trans with (IZR (Z_of_nat x)).
-assumption.
-repeat rewrite <- INR_IZR_INZ; apply le_INR; apply le_max_l.
-rewrite Rmult_1_r; rewrite (Rmult_comm (IZR (Z_of_nat (max x 1))));
- rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; repeat rewrite <- INR_IZR_INZ; apply le_INR;
- apply le_max_l.
-rewrite <- INR_IZR_INZ; apply not_O_INR.
-red in |- *; intro; assert (H6 := le_max_r x 1); cut (0 < 1)%nat;
- [ intro | apply lt_O_Sn ]; assert (H8 := lt_le_trans _ _ _ H7 H6);
- rewrite H5 in H8; elim (lt_irrefl _ H8).
-pattern eps at 1 in |- *; rewrite <- Rinv_involutive.
-apply Rinv_lt_contravar.
-apply Rmult_lt_0_compat; [ apply Rinv_0_lt_compat; assumption | assumption ].
-rewrite H3 in H0; assumption.
-red in |- *; intro; rewrite H5 in H; elim (Rlt_irrefl _ H).
-apply Rlt_trans with (/ eps).
-apply Rinv_0_lt_compat; assumption.
-rewrite H3 in H0; assumption.
-apply lt_le_trans with 1%nat; [ apply lt_O_Sn | apply le_max_r ].
-apply le_IZR; replace (IZR 0) with 0; [ idtac | reflexivity ]; left;
- apply Rlt_trans with (/ eps);
- [ apply Rinv_0_lt_compat; assumption | assumption ].
-assert (H0 := archimed (/ eps)).
-elim H0; intros; assumption.
+  forall eps:R, 0 < eps ->  exists N : nat, / INR N < eps /\ (0 < N)%nat.
+Proof.
+  intros; cut (/ eps < IZR (up (/ eps))).
+  intro; cut (0 <= up (/ eps))%Z.
+  intro; assert (H2 := IZN _ H1); elim H2; intros; exists (max x 1).
+  split.
+  cut (0 < IZR (Z_of_nat x)).
+  intro; rewrite INR_IZR_INZ; apply Rle_lt_trans with (/ IZR (Z_of_nat x)).
+  apply Rmult_le_reg_l with (IZR (Z_of_nat x)).
+  assumption.
+  rewrite <- Rinv_r_sym;
+    [ idtac | red in |- *; intro; rewrite H5 in H4; elim (Rlt_irrefl _ H4) ].
+  apply Rmult_le_reg_l with (IZR (Z_of_nat (max x 1))).
+  apply Rlt_le_trans with (IZR (Z_of_nat x)).
+  assumption.
+  repeat rewrite <- INR_IZR_INZ; apply le_INR; apply le_max_l.
+  rewrite Rmult_1_r; rewrite (Rmult_comm (IZR (Z_of_nat (max x 1))));
+    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; repeat rewrite <- INR_IZR_INZ; apply le_INR;
+    apply le_max_l.
+  rewrite <- INR_IZR_INZ; apply not_O_INR.
+  red in |- *; intro; assert (H6 := le_max_r x 1); cut (0 < 1)%nat;
+    [ intro | apply lt_O_Sn ]; assert (H8 := lt_le_trans _ _ _ H7 H6);
+      rewrite H5 in H8; elim (lt_irrefl _ H8).
+  pattern eps at 1 in |- *; rewrite <- Rinv_involutive.
+  apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat; [ apply Rinv_0_lt_compat; assumption | assumption ].
+  rewrite H3 in H0; assumption.
+  red in |- *; intro; rewrite H5 in H; elim (Rlt_irrefl _ H).
+  apply Rlt_trans with (/ eps).
+  apply Rinv_0_lt_compat; assumption.
+  rewrite H3 in H0; assumption.
+  apply lt_le_trans with 1%nat; [ apply lt_O_Sn | apply le_max_r ].
+  apply le_IZR; replace (IZR 0) with 0; [ idtac | reflexivity ]; left;
+    apply Rlt_trans with (/ eps);
+      [ apply Rinv_0_lt_compat; assumption | assumption ].
+  assert (H0 := archimed (/ eps)).
+  elim H0; intros; assumption.
 Qed.
 
 Lemma Alembert_cos : Un_cv (fun n:nat => Rabs (cos_n (S n) / cos_n n)) 0.
-unfold Un_cv in |- *; intros.
-assert (H0 := archimed_cor1 eps H).
-elim H0; intros; exists x.
-intros; rewrite simpl_cos_n; unfold R_dist in |- *; unfold Rminus in |- *;
- rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
- rewrite Rabs_Ropp; rewrite Rabs_right.
-rewrite mult_INR; rewrite Rinv_mult_distr.
-cut (/ INR (2 * S n) < 1).
-intro; cut (/ INR (2 * n + 1) < eps).
-intro; rewrite <- (Rmult_1_l eps).
-apply Rmult_gt_0_lt_compat; try assumption.
-change (0 < / INR (2 * n + 1)) in |- *; apply Rinv_0_lt_compat;
- apply lt_INR_0.
-replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
-apply Rlt_0_1.
-cut (x < 2 * n + 1)%nat.
-intro; assert (H5 := lt_INR _ _ H4).
-apply Rlt_trans with (/ INR x).
-apply Rinv_lt_contravar.
-apply Rmult_lt_0_compat.
-apply lt_INR_0.
-elim H1; intros; assumption.
-apply lt_INR_0; replace (2 * n + 1)%nat with (S (2 * n));
- [ apply lt_O_Sn | ring ].
-assumption.
-elim H1; intros; assumption.
-apply lt_le_trans with (S n).
-unfold ge in H2; apply le_lt_n_Sm; assumption.
-replace (2 * n + 1)%nat with (S (2 * n)); [ idtac | ring ].
-apply le_n_S; apply le_n_2n.
-apply Rmult_lt_reg_l with (INR (2 * S n)).
-apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n))).
-apply lt_O_Sn.
-replace (S n) with (n + 1)%nat; [ idtac | ring ].
-ring.
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; replace 1 with (INR 1); [ apply lt_INR | reflexivity ].
-replace (2 * S n)%nat with (S (S (2 * n))).
-apply lt_n_S; apply lt_O_Sn.
-replace (S n) with (n + 1)%nat; [ ring | ring ].
-apply not_O_INR; discriminate.
-apply not_O_INR; discriminate.
-replace (2 * n + 1)%nat with (S (2 * n));
- [ apply not_O_INR; discriminate | ring ].
-apply Rle_ge; left; apply Rinv_0_lt_compat.
-apply lt_INR_0.
-replace (2 * S n * (2 * n + 1))%nat with (S (S (4 * (n * n) + 6 * n))).
-apply lt_O_Sn.
-apply INR_eq.
-repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR;
- rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
- replace (INR 0) with 0; [ ring | reflexivity ].
+Proof.
+  unfold Un_cv in |- *; intros.
+  assert (H0 := archimed_cor1 eps H).
+  elim H0; intros; exists x.
+  intros; rewrite simpl_cos_n; unfold R_dist in |- *; unfold Rminus in |- *;
+    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+      rewrite Rabs_Ropp; rewrite Rabs_right.
+  rewrite mult_INR; rewrite Rinv_mult_distr.
+  cut (/ INR (2 * S n) < 1).
+  intro; cut (/ INR (2 * n + 1) < eps).
+  intro; rewrite <- (Rmult_1_l eps).
+  apply Rmult_gt_0_lt_compat; try assumption.
+  change (0 < / INR (2 * n + 1)) in |- *; apply Rinv_0_lt_compat;
+    apply lt_INR_0.
+  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
+  apply Rlt_0_1.
+  cut (x < 2 * n + 1)%nat.
+  intro; assert (H5 := lt_INR _ _ H4).
+  apply Rlt_trans with (/ INR x).
+  apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat.
+  apply lt_INR_0.
+  elim H1; intros; assumption.
+  apply lt_INR_0; replace (2 * n + 1)%nat with (S (2 * n));
+    [ apply lt_O_Sn | ring ].
+  assumption.
+  elim H1; intros; assumption.
+  apply lt_le_trans with (S n).
+  unfold ge in H2; apply le_lt_n_Sm; assumption.
+  replace (2 * n + 1)%nat with (S (2 * n)); [ idtac | ring ].
+  apply le_n_S; apply le_n_2n.
+  apply Rmult_lt_reg_l with (INR (2 * S n)).
+  apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n))).
+  apply lt_O_Sn.
+  replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  ring.
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; replace 1 with (INR 1); [ apply lt_INR | reflexivity ].
+  replace (2 * S n)%nat with (S (S (2 * n))).
+  apply lt_n_S; apply lt_O_Sn.
+  replace (S n) with (n + 1)%nat; [ ring | ring ].
+  apply not_O_INR; discriminate.
+  apply not_O_INR; discriminate.
+  replace (2 * n + 1)%nat with (S (2 * n));
+  [ apply not_O_INR; discriminate | ring ].
+  apply Rle_ge; left; apply Rinv_0_lt_compat.
+  apply lt_INR_0.
+  replace (2 * S n * (2 * n + 1))%nat with (S (S (4 * (n * n) + 6 * n))).
+  apply lt_O_Sn.
+  apply INR_eq.
+  repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR;
+    rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
+      replace (INR 0) with 0; [ ring | reflexivity ].
 Qed.
 
 Lemma cosn_no_R0 : forall n:nat, cos_n n <> 0.
-intro; unfold cos_n in |- *; unfold Rdiv in |- *; apply prod_neq_R0.
-apply pow_nonzero; discrR.
-apply Rinv_neq_0_compat.
-apply INR_fact_neq_0.
+  intro; unfold cos_n in |- *; unfold Rdiv in |- *; apply prod_neq_R0.
+  apply pow_nonzero; discrR.
+  apply Rinv_neq_0_compat.
+  apply INR_fact_neq_0.
 Qed.
 
 (**********)
@@ -229,119 +239,122 @@ Definition cos_in (x l:R) : Prop :=
 
 (**********)
 Lemma exist_cos : forall x:R, sigT (fun l:R => cos_in x l).
-intro; generalize (Alembert_C3 cos_n x cosn_no_R0 Alembert_cos).
-unfold Pser, cos_in in |- *; trivial.
+  intro; generalize (Alembert_C3 cos_n x cosn_no_R0 Alembert_cos).
+  unfold Pser, cos_in in |- *; trivial.
 Qed.
 
-(* Definition of cosinus *)
-(*************************)
+
+(** Definition of cosinus *)
 Definition cos (x:R) : R :=
   match exist_cos (Rsqr x) with
-  | existT a b => a
+    | existT a b => a
   end.
 
 
 Definition sin_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n + 1)).
 
 Lemma simpl_sin_n :
- forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). 
-intro; unfold sin_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
-rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
-rewrite Rinv_involutive.
-replace
- ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1) + 1)) *
-  (/ (-1) ^ n * INR (fact (2 * n + 1)))) with
- ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1) + 1)) *
-  INR (fact (2 * n + 1)) * (-1) ^ 1); [ idtac | ring ].
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; unfold pow in |- *; rewrite Rmult_1_r;
- replace (2 * (n + 1) + 1)%nat with (S (S (2 * n + 1))).
-do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
- repeat rewrite Rinv_mult_distr.
-rewrite <- (Rmult_comm (-1)); repeat rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; replace (S (2 * n + 1)) with (2 * (n + 1))%nat.
-repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
-ring.
-apply not_O_INR; discriminate.
-replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
-apply not_O_INR; discriminate.
-apply prod_neq_R0.
-apply not_O_INR; discriminate.
-replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
-apply not_O_INR; discriminate.
-replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
-rewrite mult_plus_distr_l; cut (forall n:nat, S n = (n + 1)%nat).
-intros; rewrite (H (2 * n + 1)%nat).
-ring.
-intros; ring.
-apply INR_fact_neq_0.
-apply not_O_INR; discriminate.
-apply INR_fact_neq_0.
-apply not_O_INR; discriminate.
-apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
-cut (forall n:nat, S (S n) = (n + 2)%nat);
- [ intros; rewrite (H (2 * n + 1)%nat); ring | intros; ring ].
-apply pow_nonzero; discrR.
-apply INR_fact_neq_0.
-apply pow_nonzero; discrR.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). 
+Proof.
+  intro; unfold sin_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  rewrite Rinv_involutive.
+  replace
+  ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1) + 1)) *
+    (/ (-1) ^ n * INR (fact (2 * n + 1)))) with
+  ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1) + 1)) *
+    INR (fact (2 * n + 1)) * (-1) ^ 1); [ idtac | ring ].
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; unfold pow in |- *; rewrite Rmult_1_r;
+    replace (2 * (n + 1) + 1)%nat with (S (S (2 * n + 1))).
+  do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
+    repeat rewrite Rinv_mult_distr.
+  rewrite <- (Rmult_comm (-1)); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; replace (S (2 * n + 1)) with (2 * (n + 1))%nat.
+  repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
+  ring.
+  apply not_O_INR; discriminate.
+  replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
+  apply not_O_INR; discriminate.
+  apply prod_neq_R0.
+  apply not_O_INR; discriminate.
+  replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
+  apply not_O_INR; discriminate.
+  replace (n + 1)%nat with (S n); [ apply not_O_INR; discriminate | ring ].
+  rewrite mult_plus_distr_l; cut (forall n:nat, S n = (n + 1)%nat).
+  intros; rewrite (H (2 * n + 1)%nat).
+  ring.
+  intros; ring.
+  apply INR_fact_neq_0.
+  apply not_O_INR; discriminate.
+  apply INR_fact_neq_0.
+  apply not_O_INR; discriminate.
+  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
+  cut (forall n:nat, S (S n) = (n + 2)%nat);
+    [ intros; rewrite (H (2 * n + 1)%nat); ring | intros; ring ].
+  apply pow_nonzero; discrR.
+  apply INR_fact_neq_0.
+  apply pow_nonzero; discrR.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
 Qed.
 
 Lemma Alembert_sin : Un_cv (fun n:nat => Rabs (sin_n (S n) / sin_n n)) 0.
-unfold Un_cv in |- *; intros; assert (H0 := archimed_cor1 eps H).
-elim H0; intros; exists x.
-intros; rewrite simpl_sin_n; unfold R_dist in |- *; unfold Rminus in |- *;
- rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
- rewrite Rabs_Ropp; rewrite Rabs_right.
-rewrite mult_INR; rewrite Rinv_mult_distr.
-cut (/ INR (2 * S n) < 1).
-intro; cut (/ INR (2 * S n + 1) < eps).
-intro; rewrite <- (Rmult_1_l eps); rewrite (Rmult_comm (/ INR (2 * S n + 1)));
- apply Rmult_gt_0_lt_compat; try assumption.
-change (0 < / INR (2 * S n + 1)) in |- *; apply Rinv_0_lt_compat;
- apply lt_INR_0; replace (2 * S n + 1)%nat with (S (2 * S n));
- [ apply lt_O_Sn | ring ].
-apply Rlt_0_1.
-cut (x < 2 * S n + 1)%nat.
-intro; assert (H5 := lt_INR _ _ H4); apply Rlt_trans with (/ INR x).
-apply Rinv_lt_contravar.
-apply Rmult_lt_0_compat.
-apply lt_INR_0; elim H1; intros; assumption.
-apply lt_INR_0; replace (2 * S n + 1)%nat with (S (2 * S n));
- [ apply lt_O_Sn | ring ].
-assumption.
-elim H1; intros; assumption.
-apply lt_le_trans with (S n).
-unfold ge in H2; apply le_lt_n_Sm; assumption.
-replace (2 * S n + 1)%nat with (S (2 * S n)); [ idtac | ring ].
-apply le_S; apply le_n_2n.
-apply Rmult_lt_reg_l with (INR (2 * S n)).
-apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n)));
- [ apply lt_O_Sn | replace (S n) with (n + 1)%nat; [ idtac | ring ]; ring ].
-rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; replace 1 with (INR 1); [ apply lt_INR | reflexivity ].
-replace (2 * S n)%nat with (S (S (2 * n))).
-apply lt_n_S; apply lt_O_Sn.
-replace (S n) with (n + 1)%nat; [ ring | ring ].
-apply not_O_INR; discriminate.
-apply not_O_INR; discriminate.
-apply not_O_INR; discriminate.
-left; change (0 < / INR ((2 * S n + 1) * (2 * S n))) in |- *;
- apply Rinv_0_lt_compat.
-apply lt_INR_0.
-replace ((2 * S n + 1) * (2 * S n))%nat with
- (S (S (S (S (S (S (4 * (n * n) + 10 * n))))))).
-apply lt_O_Sn.
-apply INR_eq; repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR;
- rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
- replace (INR 0) with 0; [ ring | reflexivity ].
+Proof.
+  unfold Un_cv in |- *; intros; assert (H0 := archimed_cor1 eps H).
+  elim H0; intros; exists x.
+  intros; rewrite simpl_sin_n; unfold R_dist in |- *; unfold Rminus in |- *;
+    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; 
+      rewrite Rabs_Ropp; rewrite Rabs_right.
+  rewrite mult_INR; rewrite Rinv_mult_distr.
+  cut (/ INR (2 * S n) < 1).
+  intro; cut (/ INR (2 * S n + 1) < eps).
+  intro; rewrite <- (Rmult_1_l eps); rewrite (Rmult_comm (/ INR (2 * S n + 1)));
+    apply Rmult_gt_0_lt_compat; try assumption.
+  change (0 < / INR (2 * S n + 1)) in |- *; apply Rinv_0_lt_compat;
+    apply lt_INR_0; replace (2 * S n + 1)%nat with (S (2 * S n));
+      [ apply lt_O_Sn | ring ].
+  apply Rlt_0_1.
+  cut (x < 2 * S n + 1)%nat.
+  intro; assert (H5 := lt_INR _ _ H4); apply Rlt_trans with (/ INR x).
+  apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat.
+  apply lt_INR_0; elim H1; intros; assumption.
+  apply lt_INR_0; replace (2 * S n + 1)%nat with (S (2 * S n));
+    [ apply lt_O_Sn | ring ].
+  assumption.
+  elim H1; intros; assumption.
+  apply lt_le_trans with (S n).
+  unfold ge in H2; apply le_lt_n_Sm; assumption.
+  replace (2 * S n + 1)%nat with (S (2 * S n)); [ idtac | ring ].
+  apply le_S; apply le_n_2n.
+  apply Rmult_lt_reg_l with (INR (2 * S n)).
+  apply lt_INR_0; replace (2 * S n)%nat with (S (S (2 * n)));
+    [ apply lt_O_Sn | replace (S n) with (n + 1)%nat; [ idtac | ring ]; ring ].
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; replace 1 with (INR 1); [ apply lt_INR | reflexivity ].
+  replace (2 * S n)%nat with (S (S (2 * n))).
+  apply lt_n_S; apply lt_O_Sn.
+  replace (S n) with (n + 1)%nat; [ ring | ring ].
+  apply not_O_INR; discriminate.
+  apply not_O_INR; discriminate.
+  apply not_O_INR; discriminate.
+  left; change (0 < / INR ((2 * S n + 1) * (2 * S n))) in |- *;
+    apply Rinv_0_lt_compat.
+  apply lt_INR_0.
+  replace ((2 * S n + 1) * (2 * S n))%nat with
+  (S (S (S (S (S (S (4 * (n * n) + 10 * n))))))).
+  apply lt_O_Sn.
+  apply INR_eq; repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR;
+    rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
+      replace (INR 0) with 0; [ ring | reflexivity ].
 Qed.
 
 Lemma sin_no_R0 : forall n:nat, sin_n n <> 0.
-intro; unfold sin_n in |- *; unfold Rdiv in |- *; apply prod_neq_R0.
-apply pow_nonzero; discrR.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+Proof.
+  intro; unfold sin_n in |- *; unfold Rdiv in |- *; apply prod_neq_R0.
+  apply pow_nonzero; discrR.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
 Qed.
 
 (**********)
@@ -350,63 +363,69 @@ Definition sin_in (x l:R) : Prop :=
 
 (**********)
 Lemma exist_sin : forall x:R, sigT (fun l:R => sin_in x l).
-intro; generalize (Alembert_C3 sin_n x sin_no_R0 Alembert_sin).
-unfold Pser, sin_n in |- *; trivial.
+Proof.
+  intro; generalize (Alembert_C3 sin_n x sin_no_R0 Alembert_sin).
+  unfold Pser, sin_n in |- *; trivial.
 Qed.
 
 (***********************)
 (* Definition of sinus *)
 Definition sin (x:R) : R :=
   match exist_sin (Rsqr x) with
-  | existT a b => x * a
+    | existT a b => x * a
   end.
 
 (*********************************************)
-(*                 PROPERTIES                *)
+(** *              Properties                *)
 (*********************************************)
 
 Lemma cos_sym : forall x:R, cos x = cos (- x).
-intros; unfold cos in |- *; replace (Rsqr (- x)) with (Rsqr x).
-reflexivity.
-apply Rsqr_neg.
+Proof.
+  intros; unfold cos in |- *; replace (Rsqr (- x)) with (Rsqr x).
+  reflexivity.
+  apply Rsqr_neg.
 Qed.
 
 Lemma sin_antisym : forall x:R, sin (- x) = - sin x.
-intro; unfold sin in |- *; replace (Rsqr (- x)) with (Rsqr x);
- [ idtac | apply Rsqr_neg ]. 
-case (exist_sin (Rsqr x)); intros; ring.
+Proof.
+  intro; unfold sin in |- *; replace (Rsqr (- x)) with (Rsqr x);
+    [ idtac | apply Rsqr_neg ]. 
+  case (exist_sin (Rsqr x)); intros; ring.
 Qed.
 
 Lemma sin_0 : sin 0 = 0.
-unfold sin in |- *; case (exist_sin (Rsqr 0)).
-intros; ring.
+Proof.
+  unfold sin in |- *; case (exist_sin (Rsqr 0)).
+  intros; ring.
 Qed.
 
 Lemma exist_cos0 : sigT (fun l:R => cos_in 0 l).
-apply existT with 1.
-unfold cos_in in |- *; unfold infinit_sum in |- *; intros; exists 0%nat.
-intros.
-unfold R_dist in |- *.
-induction  n as [| n Hrecn].
-unfold cos_n in |- *; simpl in |- *.
-unfold Rdiv in |- *; rewrite Rinv_1.
-do 2 rewrite Rmult_1_r.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-rewrite tech5.
-replace (cos_n (S n) * 0 ^ S n) with 0.
-rewrite Rplus_0_r.
-apply Hrecn; unfold ge in |- *; apply le_O_n.
-simpl in |- *; ring.
+Proof.
+  apply existT with 1.
+  unfold cos_in in |- *; unfold infinit_sum in |- *; intros; exists 0%nat.
+  intros.
+  unfold R_dist in |- *.
+  induction  n as [| n Hrecn].
+  unfold cos_n in |- *; simpl in |- *.
+  unfold Rdiv in |- *; rewrite Rinv_1.
+  do 2 rewrite Rmult_1_r.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  rewrite tech5.
+  replace (cos_n (S n) * 0 ^ S n) with 0.
+  rewrite Rplus_0_r.
+  apply Hrecn; unfold ge in |- *; apply le_O_n.
+  simpl in |- *; ring.
 Defined.
 
 (* Calculus of (cos 0) *)
 Lemma cos_0 : cos 0 = 1.
-cut (cos_in 0 (cos 0)).
-cut (cos_in 0 1).
-unfold cos_in in |- *; intros; eapply uniqueness_sum.
-apply H0.
-apply H.
-exact (projT2 exist_cos0).
-assert (H := projT2 (exist_cos (Rsqr 0))); unfold cos in |- *;
- pattern 0 at 1 in |- *; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ].
-Qed.
\ No newline at end of file
+Proof.
+  cut (cos_in 0 (cos 0)).
+  cut (cos_in 0 1).
+  unfold cos_in in |- *; intros; eapply uniqueness_sum.
+  apply H0.
+  apply H.
+  exact (projT2 exist_cos0).
+  assert (H := projT2 (exist_cos (Rsqr 0))); unfold cos in |- *;
+    pattern 0 at 1 in |- *; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ].
+Qed.
diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v
index b0f29e5c..78ef847f 100644
--- a/theories/Reals/Rtrigo_fun.v
+++ b/theories/Reals/Rtrigo_fun.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rtrigo_fun.v,v 1.7.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+(*i $Id: Rtrigo_fun.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -14,96 +14,89 @@ Require Import SeqSeries.
 Open Local Scope R_scope.
 
 (*****************************************************************)
-(*           To define transcendental functions                  *)
-(*                                                               *)
-(*****************************************************************)
-(*****************************************************************)
-(*           For exponential function                            *)
+(**           To define transcendental functions                 *)
+(**           for exponential function                           *)
 (*                                                               *)
 (*****************************************************************)
 
 (*********)
 Lemma Alembert_exp :
- Un_cv (fun n:nat => Rabs (/ INR (fact (S n)) * / / INR (fact n))) 0.
-unfold Un_cv in |- *; intros; elim (Rgt_dec eps 1); intro.
-split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist in |- *;
- rewrite (Rminus_0_r (Rabs (/ INR (S n))));
- rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
-intro; rewrite (Rabs_pos_eq (/ INR (S n))).
-cut (/ eps - 1 < 0).
-intro; generalize (Rlt_le_trans (/ eps - 1) 0 (INR n) H2 (pos_INR n));
- clear H2; intro; unfold Rminus in H2;
- generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H2);
- replace (1 + (/ eps + -1)) with (/ eps); [ clear H2; intro | ring ].
-rewrite (Rplus_comm 1 (INR n)) in H2; rewrite <- (S_INR n) in H2;
- generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H); 
- intro; unfold Rgt in H3;
- generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H3 H2);
- intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H4;
- rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
-   in H4; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H4;
- rewrite (Rmult_comm (/ INR (S n))) in H4;
- rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4;
- rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H4;
- rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4; 
- assumption.
-apply Rlt_minus; unfold Rgt in a; rewrite <- Rinv_1;
- apply (Rinv_lt_contravar 1 eps); auto;
- rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H; 
- assumption.
-unfold Rgt in H1; apply Rlt_le; assumption.
-unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  Un_cv (fun n:nat => Rabs (/ INR (fact (S n)) * / / INR (fact n))) 0.
+Proof.
+  unfold Un_cv in |- *; intros; elim (Rgt_dec eps 1); intro.
+  split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist in |- *;
+    rewrite (Rminus_0_r (Rabs (/ INR (S n))));
+      rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
+  intro; rewrite (Rabs_pos_eq (/ INR (S n))).
+  cut (/ eps - 1 < 0).
+  intro; generalize (Rlt_le_trans (/ eps - 1) 0 (INR n) H2 (pos_INR n));
+    clear H2; intro; unfold Rminus in H2;
+      generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H2);
+        replace (1 + (/ eps + -1)) with (/ eps); [ clear H2; intro | ring ].
+  rewrite (Rplus_comm 1 (INR n)) in H2; rewrite <- (S_INR n) in H2;
+    generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H); 
+      intro; unfold Rgt in H3;
+        generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H3 H2);
+          intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H4;
+            rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
+              in H4; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H4;
+                rewrite (Rmult_comm (/ INR (S n))) in H4;
+                  rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4;
+                    rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H4;
+                      rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4; 
+                        assumption.
+  apply Rlt_minus; unfold Rgt in a; rewrite <- Rinv_1;
+    apply (Rinv_lt_contravar 1 eps); auto;
+      rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H; 
+        assumption.
+  unfold Rgt in H1; apply Rlt_le; assumption.
+  unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
 (**)
-cut (0 <= up (/ eps - 1))%Z.
-intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros;
- rewrite (simpl_fact n); unfold R_dist in |- *;
- rewrite (Rminus_0_r (Rabs (/ INR (S n))));
- rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
-intro; rewrite (Rabs_pos_eq (/ INR (S n))).
-cut (/ eps - 1 < INR x).
-intro;
- generalize
-  (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4
-     (le_INR x n ((fun (n m:nat) (H:(m >= n)%nat) => H) x n H2))); 
- clear H4; intro; unfold Rminus in H4;
- generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4);
- replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ].
-rewrite (Rplus_comm 1 (INR n)) in H4; rewrite <- (S_INR n) in H4;
- generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H); 
- intro; unfold Rgt in H5;
- generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H5 H4);
- intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H6;
- rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
-   in H6; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H6;
- rewrite (Rmult_comm (/ INR (S n))) in H6;
- rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6;
- rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H6;
- rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6; 
- assumption.
-cut (IZR (up (/ eps - 1)) = IZR (Z_of_nat x));
- [ intro | rewrite H1; trivial ].
-elim (archimed (/ eps - 1)); intros; clear H6; unfold Rgt in H5;
- rewrite H4 in H5; rewrite INR_IZR_INZ; assumption.
-unfold Rgt in H1; apply Rlt_le; assumption.
-unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
-apply (le_O_IZR (up (/ eps - 1)));
- apply (Rle_trans 0 (/ eps - 1) (IZR (up (/ eps - 1)))).
-generalize (Rnot_gt_le eps 1 b); clear b; unfold Rle in |- *; intro; elim H0;
- clear H0; intro.
-left; unfold Rgt in H;
- generalize (Rmult_lt_compat_l (/ eps) eps 1 (Rinv_0_lt_compat eps H) H0);
- rewrite
-  (Rinv_l eps
-     (sym_not_eq (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H))))
-  ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); 
- intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus; 
- unfold Rgt in |- *; assumption.
-right; rewrite H0; rewrite Rinv_1; apply sym_eq; apply Rminus_diag_eq; auto.
-elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le;
- assumption.
+  cut (0 <= up (/ eps - 1))%Z.
+  intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros;
+    rewrite (simpl_fact n); unfold R_dist in |- *;
+      rewrite (Rminus_0_r (Rabs (/ INR (S n))));
+        rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
+  intro; rewrite (Rabs_pos_eq (/ INR (S n))).
+  cut (/ eps - 1 < INR x).
+  intro ;
+    generalize
+      (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4
+        (le_INR x n H2)); 
+      clear H4; intro; unfold Rminus in H4;
+        generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4);
+          replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ].
+  rewrite (Rplus_comm 1 (INR n)) in H4; rewrite <- (S_INR n) in H4;
+    generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H); 
+      intro; unfold Rgt in H5;
+        generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H5 H4);
+          intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H6;
+            rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
+              in H6; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H6;
+                rewrite (Rmult_comm (/ INR (S n))) in H6;
+                  rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6;
+                    rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H6;
+                      rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6; 
+                        assumption.
+  cut (IZR (up (/ eps - 1)) = IZR (Z_of_nat x));
+    [ intro | rewrite H1; trivial ].
+  elim (archimed (/ eps - 1)); intros; clear H6; unfold Rgt in H5;
+    rewrite H4 in H5; rewrite INR_IZR_INZ; assumption.
+  unfold Rgt in H1; apply Rlt_le; assumption.
+  unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  apply (le_O_IZR (up (/ eps - 1)));
+    apply (Rle_trans 0 (/ eps - 1) (IZR (up (/ eps - 1)))).
+  generalize (Rnot_gt_le eps 1 b); clear b; unfold Rle in |- *; intro; elim H0;
+    clear H0; intro.
+  left; unfold Rgt in H;
+    generalize (Rmult_lt_compat_l (/ eps) eps 1 (Rinv_0_lt_compat eps H) H0);
+      rewrite
+        (Rinv_l eps
+          (sym_not_eq (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H))))
+        ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); 
+          intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus; 
+            unfold Rgt in |- *; assumption.
+  right; rewrite H0; rewrite Rinv_1; apply sym_eq; apply Rminus_diag_eq; auto.
+  elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le;
+    assumption.
 Qed.
-
-
-
-
-
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
index 9d3b60c6..b105ca69 100644
--- a/theories/Reals/Rtrigo_reg.v
+++ b/theories/Reals/Rtrigo_reg.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Rtrigo_reg.v,v 1.15.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+(*i $Id: Rtrigo_reg.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -18,591 +18,603 @@ Open Local Scope nat_scope.
 Open Local Scope R_scope.
 
 Lemma CVN_R_cos :
- forall fn:nat -> R -> R,
-   fn = (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)) ->
-   CVN_R fn.
-unfold CVN_R in |- *; intros.
-cut ((r:R) <> 0).
-intro hyp_r; unfold CVN_r in |- *.
-apply existT with (fun n:nat => / INR (fact (2 * n)) * r ^ (2 * n)).
-cut
- (sigT
-    (fun l:R =>
-       Un_cv
-         (fun n:nat =>
-            sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k)))
-              n) l)).
-intro; elim X; intros.
-apply existT with x.
-split.
-apply p.
-intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult.
-rewrite pow_1_abs; rewrite Rmult_1_l.
-cut (0 < / INR (fact (2 * n))).
-intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
-apply Rmult_le_compat_l.
-left; apply H1.
-rewrite <- RPow_abs; apply pow_maj_Rabs.
-rewrite Rabs_Rabsolu.
-unfold Boule in H0; rewrite Rminus_0_r in H0.
-left; apply H0.
-apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-apply Alembert_C2.
-intro; apply Rabs_no_R0.
-apply prod_neq_R0.
-apply Rinv_neq_0_compat.
-apply INR_fact_neq_0.
-apply pow_nonzero; assumption.
-assert (H0 := Alembert_cos).
-unfold cos_n in H0; unfold Un_cv in H0; unfold Un_cv in |- *; intros.
-cut (0 < eps / Rsqr r).
-intro; elim (H0 _ H2); intros N0 H3.
-exists N0; intros.
-unfold R_dist in |- *; assert (H5 := H3 _ H4).
-unfold R_dist in H5;
- replace
-  (Rabs
-     (Rabs (/ INR (fact (2 * S n)) * r ^ (2 * S n)) /
-      Rabs (/ INR (fact (2 * n)) * r ^ (2 * n)))) with
-  (Rsqr r *
-   Rabs ((-1) ^ S n / INR (fact (2 * S n)) / ((-1) ^ n / INR (fact (2 * n))))).
-apply Rmult_lt_reg_l with (/ Rsqr r).
-apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
-pattern (/ Rsqr r) at 1 in |- *; replace (/ Rsqr r) with (Rabs (/ Rsqr r)).
-rewrite <- Rabs_mult; rewrite Rmult_minus_distr_l; rewrite Rmult_0_r;
- rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); apply H5.
-unfold Rsqr in |- *; apply prod_neq_R0; assumption.
-rewrite Rabs_Rinv.
-rewrite Rabs_right.
-reflexivity.
-apply Rle_ge; apply Rle_0_sqr.
-unfold Rsqr in |- *; apply prod_neq_R0; assumption.
-rewrite (Rmult_comm (Rsqr r)); unfold Rdiv in |- *; repeat rewrite Rabs_mult;
- rewrite Rabs_Rabsolu; rewrite pow_1_abs; rewrite Rmult_1_l;
- repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
-rewrite Rabs_Rinv.
-rewrite Rabs_mult; rewrite (pow_1_abs n); rewrite Rmult_1_l;
- rewrite <- Rabs_Rinv.
-rewrite Rinv_involutive.
-rewrite Rinv_mult_distr.
-rewrite Rabs_Rinv.
-rewrite Rinv_involutive.
-rewrite (Rmult_comm (Rabs (Rabs (r ^ (2 * S n))))); rewrite Rabs_mult;
- rewrite Rabs_Rabsolu; rewrite Rmult_assoc; apply Rmult_eq_compat_l.
-rewrite Rabs_Rinv.
-do 2 rewrite Rabs_Rabsolu; repeat rewrite Rabs_right.
-replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
-repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-unfold Rsqr in |- *; ring.
-apply pow_nonzero; assumption.
-replace (2 * S n)%nat with (S (S (2 * n))).
-simpl in |- *; ring.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-apply Rle_ge; apply pow_le; left; apply (cond_pos r).
-apply Rle_ge; apply pow_le; left; apply (cond_pos r).
-apply Rabs_no_R0; apply pow_nonzero; assumption.
-apply Rabs_no_R0; apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply Rabs_no_R0; apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-apply Rabs_no_R0; apply pow_nonzero; assumption.
-apply INR_fact_neq_0.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-apply prod_neq_R0.
-apply pow_nonzero; discrR.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply H1.
-apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
-assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
- elim (Rlt_irrefl _ H0).
+  forall fn:nat -> R -> R,
+    fn = (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)) ->
+    CVN_R fn.
+Proof.
+  unfold CVN_R in |- *; intros.
+  cut ((r:R) <> 0).
+  intro hyp_r; unfold CVN_r in |- *.
+  apply existT with (fun n:nat => / INR (fact (2 * n)) * r ^ (2 * n)).
+  cut
+    (sigT
+      (fun l:R =>
+        Un_cv
+        (fun n:nat =>
+          sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k)))
+          n) l)).
+  intro X; elim X; intros.
+  apply existT with x.
+  split.
+  apply p.
+  intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult.
+  rewrite pow_1_abs; rewrite Rmult_1_l.
+  cut (0 < / INR (fact (2 * n))).
+  intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
+  apply Rmult_le_compat_l.
+  left; apply H1.
+  rewrite <- RPow_abs; apply pow_maj_Rabs.
+  rewrite Rabs_Rabsolu.
+  unfold Boule in H0; rewrite Rminus_0_r in H0.
+  left; apply H0.
+  apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Alembert_C2.
+  intro; apply Rabs_no_R0.
+  apply prod_neq_R0.
+  apply Rinv_neq_0_compat.
+  apply INR_fact_neq_0.
+  apply pow_nonzero; assumption.
+  assert (H0 := Alembert_cos).
+  unfold cos_n in H0; unfold Un_cv in H0; unfold Un_cv in |- *; intros.
+  cut (0 < eps / Rsqr r).
+  intro; elim (H0 _ H2); intros N0 H3.
+  exists N0; intros.
+  unfold R_dist in |- *; assert (H5 := H3 _ H4).
+  unfold R_dist in H5;
+    replace
+    (Rabs
+      (Rabs (/ INR (fact (2 * S n)) * r ^ (2 * S n)) /
+        Rabs (/ INR (fact (2 * n)) * r ^ (2 * n)))) with
+    (Rsqr r *
+      Rabs ((-1) ^ S n / INR (fact (2 * S n)) / ((-1) ^ n / INR (fact (2 * n))))).
+  apply Rmult_lt_reg_l with (/ Rsqr r).
+  apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+  pattern (/ Rsqr r) at 1 in |- *; replace (/ Rsqr r) with (Rabs (/ Rsqr r)).
+  rewrite <- Rabs_mult; rewrite Rmult_minus_distr_l; rewrite Rmult_0_r;
+    rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); apply H5.
+  unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+  rewrite Rabs_Rinv.
+  rewrite Rabs_right.
+  reflexivity.
+  apply Rle_ge; apply Rle_0_sqr.
+  unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+  rewrite (Rmult_comm (Rsqr r)); unfold Rdiv in |- *; repeat rewrite Rabs_mult;
+    rewrite Rabs_Rabsolu; rewrite pow_1_abs; rewrite Rmult_1_l;
+      repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+  rewrite Rabs_Rinv.
+  rewrite Rabs_mult; rewrite (pow_1_abs n); rewrite Rmult_1_l;
+    rewrite <- Rabs_Rinv.
+  rewrite Rinv_involutive.
+  rewrite Rinv_mult_distr.
+  rewrite Rabs_Rinv.
+  rewrite Rinv_involutive.
+  rewrite (Rmult_comm (Rabs (Rabs (r ^ (2 * S n))))); rewrite Rabs_mult;
+    rewrite Rabs_Rabsolu; rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+  rewrite Rabs_Rinv.
+  do 2 rewrite Rabs_Rabsolu; repeat rewrite Rabs_right.
+  replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
+  repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  unfold Rsqr in |- *; ring.
+  apply pow_nonzero; assumption.
+  replace (2 * S n)%nat with (S (S (2 * n))).
+  simpl in |- *; ring.
+  ring.
+  apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+  apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+  apply Rabs_no_R0; apply pow_nonzero; assumption.
+  apply Rabs_no_R0; apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply Rabs_no_R0; apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  apply Rabs_no_R0; apply pow_nonzero; assumption.
+  apply INR_fact_neq_0.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  apply prod_neq_R0.
+  apply pow_nonzero; discrR.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply H1.
+  apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+  assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
+    elim (Rlt_irrefl _ H0).
 Qed.
 
 (**********)
 Lemma continuity_cos : continuity cos.
-set (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)).
-cut (CVN_R fn).
-intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
-intro cv; cut (forall n:nat, continuity (fn n)).
-intro; cut (forall x:R, cos x = SFL fn cv x).
-intro; cut (continuity (SFL fn cv) -> continuity cos).
-intro; apply H1.
-apply SFL_continuity; assumption.
-unfold continuity in |- *; unfold continuity_pt in |- *;
- unfold continue_in in |- *; unfold limit1_in in |- *;
- unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros.
-elim (H1 x _ H2); intros.
-exists x0; intros.
-elim H3; intros.
-split.
-apply H4.
-intros; rewrite (H0 x); rewrite (H0 x1); apply H5; apply H6.
-intro; unfold cos, SFL in |- *.
-case (cv x); case (exist_cos (Rsqr x)); intros.
-symmetry  in |- *; eapply UL_sequence.
-apply u.
-unfold cos_in in c; unfold infinit_sum in c; unfold Un_cv in |- *; intros.
-elim (c _ H0); intros N0 H1.
-exists N0; intros.
-unfold R_dist in H1; unfold R_dist, SP in |- *.
-replace (sum_f_R0 (fun k:nat => fn k x) n) with
- (sum_f_R0 (fun i:nat => cos_n i * Rsqr x ^ i) n).
-apply H1; assumption.
-apply sum_eq; intros.
-unfold cos_n, fn in |- *; apply Rmult_eq_compat_l.
-unfold Rsqr in |- *; rewrite pow_sqr; reflexivity.
-intro; unfold fn in |- *;
- replace (fun x:R => (-1) ^ n / INR (fact (2 * n)) * x ^ (2 * n)) with
-  (fct_cte ((-1) ^ n / INR (fact (2 * n))) * pow_fct (2 * n))%F;
- [ idtac | reflexivity ].
-apply continuity_mult.
-apply derivable_continuous; apply derivable_const.
-apply derivable_continuous; apply (derivable_pow (2 * n)).
-apply CVN_R_CVS; apply X.
-apply CVN_R_cos; unfold fn in |- *; reflexivity.
+Proof.
+  set (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)).
+  cut (CVN_R fn).
+  intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
+  intro cv; cut (forall n:nat, continuity (fn n)).
+  intro; cut (forall x:R, cos x = SFL fn cv x).
+  intro; cut (continuity (SFL fn cv) -> continuity cos).
+  intro; apply H1.
+  apply SFL_continuity; assumption.
+  unfold continuity in |- *; unfold continuity_pt in |- *;
+    unfold continue_in in |- *; unfold limit1_in in |- *;
+      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; 
+        intros.
+  elim (H1 x _ H2); intros.
+  exists x0; intros.
+  elim H3; intros.
+  split.
+  apply H4.
+  intros; rewrite (H0 x); rewrite (H0 x1); apply H5; apply H6.
+  intro; unfold cos, SFL in |- *.
+  case (cv x); case (exist_cos (Rsqr x)); intros.
+  symmetry  in |- *; eapply UL_sequence.
+  apply u.
+  unfold cos_in in c; unfold infinit_sum in c; unfold Un_cv in |- *; intros.
+  elim (c _ H0); intros N0 H1.
+  exists N0; intros.
+  unfold R_dist in H1; unfold R_dist, SP in |- *.
+  replace (sum_f_R0 (fun k:nat => fn k x) n) with
+  (sum_f_R0 (fun i:nat => cos_n i * Rsqr x ^ i) n).
+  apply H1; assumption.
+  apply sum_eq; intros.
+  unfold cos_n, fn in |- *; apply Rmult_eq_compat_l.
+  unfold Rsqr in |- *; rewrite pow_sqr; reflexivity.
+  intro; unfold fn in |- *;
+    replace (fun x:R => (-1) ^ n / INR (fact (2 * n)) * x ^ (2 * n)) with
+    (fct_cte ((-1) ^ n / INR (fact (2 * n))) * pow_fct (2 * n))%F;
+    [ idtac | reflexivity ].
+  apply continuity_mult.
+  apply derivable_continuous; apply derivable_const.
+  apply derivable_continuous; apply (derivable_pow (2 * n)).
+  apply CVN_R_CVS; apply X.
+  apply CVN_R_cos; unfold fn in |- *; reflexivity.
 Qed.
 
 (**********)
 Lemma continuity_sin : continuity sin.
-unfold continuity in |- *; intro.
-assert (H0 := continuity_cos (PI / 2 - x)).
-unfold continuity_pt in H0; unfold continue_in in H0; unfold limit1_in in H0;
- unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
- unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; unfold R_dist in |- *; intros.
-elim (H0 _ H); intros.
-exists x0; intros.
-elim H1; intros.
-split.
-assumption.
-intros; rewrite <- (cos_shift x); rewrite <- (cos_shift x1); apply H3.
-elim H4; intros.
-split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-red in |- *; intro; unfold D_x, no_cond in H5; elim H5; intros _ H8; elim H8;
- rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive x1);
- apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2); 
- apply H7.
-replace (PI / 2 - x1 - (PI / 2 - x)) with (x - x1); [ idtac | ring ];
- rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H6.
+Proof.
+  unfold continuity in |- *; intro.
+  assert (H0 := continuity_cos (PI / 2 - x)).
+  unfold continuity_pt in H0; unfold continue_in in H0; unfold limit1_in in H0;
+    unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
+      unfold continuity_pt in |- *; unfold continue_in in |- *;
+        unfold limit1_in in |- *; unfold limit_in in |- *; 
+          simpl in |- *; unfold R_dist in |- *; intros.
+  elim (H0 _ H); intros.
+  exists x0; intros.
+  elim H1; intros.
+  split.
+  assumption.
+  intros; rewrite <- (cos_shift x); rewrite <- (cos_shift x1); apply H3.
+  elim H4; intros.
+  split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  red in |- *; intro; unfold D_x, no_cond in H5; elim H5; intros _ H8; elim H8;
+    rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive x1);
+      apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2); 
+        apply H7.
+  replace (PI / 2 - x1 - (PI / 2 - x)) with (x - x1); [ idtac | ring ];
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H6.
 Qed.
 
 Lemma CVN_R_sin :
- forall fn:nat -> R -> R,
-   fn =
-   (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)) ->
-   CVN_R fn.
-unfold CVN_R in |- *; unfold CVN_r in |- *; intros fn H r.
-apply existT with (fun n:nat => / INR (fact (2 * n + 1)) * r ^ (2 * n)).
-cut
- (sigT
-    (fun l:R =>
-       Un_cv
-         (fun n:nat =>
-            sum_f_R0
-              (fun k:nat => Rabs (/ INR (fact (2 * k + 1)) * r ^ (2 * k))) n)
-         l)).
-intro; elim X; intros.
-apply existT with x.
-split.
-apply p.
-intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult;
- rewrite pow_1_abs; rewrite Rmult_1_l.
-cut (0 < / INR (fact (2 * n + 1))).
-intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
-apply Rmult_le_compat_l.
-left; apply H1.
-rewrite <- RPow_abs; apply pow_maj_Rabs.
-rewrite Rabs_Rabsolu; unfold Boule in H0; rewrite Rminus_0_r in H0; left;
- apply H0.
-apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-cut ((r:R) <> 0).
-intro; apply Alembert_C2.
-intro; apply Rabs_no_R0.
-apply prod_neq_R0.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-apply pow_nonzero; assumption.
-assert (H1 := Alembert_sin).
-unfold sin_n in H1; unfold Un_cv in H1; unfold Un_cv in |- *; intros.
-cut (0 < eps / Rsqr r).
-intro; elim (H1 _ H3); intros N0 H4.
-exists N0; intros.
-unfold R_dist in |- *; assert (H6 := H4 _ H5).
-unfold R_dist in H5;
- replace
-  (Rabs
-     (Rabs (/ INR (fact (2 * S n + 1)) * r ^ (2 * S n)) /
-      Rabs (/ INR (fact (2 * n + 1)) * r ^ (2 * n)))) with
-  (Rsqr r *
-   Rabs
-     ((-1) ^ S n / INR (fact (2 * S n + 1)) /
-      ((-1) ^ n / INR (fact (2 * n + 1))))).
-apply Rmult_lt_reg_l with (/ Rsqr r).
-apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
-pattern (/ Rsqr r) at 1 in |- *; rewrite <- (Rabs_right (/ Rsqr r)).
-rewrite <- Rabs_mult.
-rewrite Rmult_minus_distr_l.
-rewrite Rmult_0_r; rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
-apply H6.
-unfold Rsqr in |- *; apply prod_neq_R0; assumption.
-apply Rle_ge; left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
-unfold Rdiv in |- *; rewrite (Rmult_comm (Rsqr r)); repeat rewrite Rabs_mult;
- rewrite Rabs_Rabsolu; rewrite pow_1_abs.
-rewrite Rmult_1_l.
-repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
-rewrite Rinv_mult_distr.
-rewrite Rinv_involutive.
-rewrite Rabs_mult.
-rewrite Rabs_Rinv.
-rewrite pow_1_abs; rewrite Rinv_1; rewrite Rmult_1_l.
-rewrite Rinv_mult_distr.
-rewrite <- Rabs_Rinv.
-rewrite Rinv_involutive.
-rewrite Rabs_mult.
-do 2 rewrite Rabs_Rabsolu.
-rewrite (Rmult_comm (Rabs (r ^ (2 * S n)))).
-rewrite Rmult_assoc; apply Rmult_eq_compat_l.
-rewrite Rabs_Rinv.
-rewrite Rabs_Rabsolu.
-repeat rewrite Rabs_right.
-replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
-do 2 rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-unfold Rsqr in |- *; ring.
-apply pow_nonzero; assumption.
-replace (2 * S n)%nat with (S (S (2 * n))).
-simpl in |- *; ring.
-apply INR_eq; do 2 rewrite S_INR; do 2 rewrite mult_INR; repeat rewrite S_INR;
- ring.
-apply Rle_ge; apply pow_le; left; apply (cond_pos r).
-apply Rle_ge; apply pow_le; left; apply (cond_pos r).
-apply Rabs_no_R0; apply pow_nonzero; assumption.
-apply INR_fact_neq_0.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-apply Rabs_no_R0; apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-apply Rabs_no_R0; apply pow_nonzero; assumption.
-apply pow_nonzero; discrR.
-apply INR_fact_neq_0.
-apply pow_nonzero; discrR.
-apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption ].
-assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
- elim (Rlt_irrefl _ H0).
+  forall fn:nat -> R -> R,
+    fn =
+    (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)) ->
+    CVN_R fn.
+Proof.
+  unfold CVN_R in |- *; unfold CVN_r in |- *; intros fn H r.
+  apply existT with (fun n:nat => / INR (fact (2 * n + 1)) * r ^ (2 * n)).
+  cut
+    (sigT
+      (fun l:R =>
+        Un_cv
+        (fun n:nat =>
+          sum_f_R0
+          (fun k:nat => Rabs (/ INR (fact (2 * k + 1)) * r ^ (2 * k))) n)
+        l)).
+  intro X; elim X; intros.
+  apply existT with x.
+  split.
+  apply p.
+  intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult;
+    rewrite pow_1_abs; rewrite Rmult_1_l.
+  cut (0 < / INR (fact (2 * n + 1))).
+  intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
+  apply Rmult_le_compat_l.
+  left; apply H1.
+  rewrite <- RPow_abs; apply pow_maj_Rabs.
+  rewrite Rabs_Rabsolu; unfold Boule in H0; rewrite Rminus_0_r in H0; left;
+    apply H0.
+  apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  cut ((r:R) <> 0).
+  intro; apply Alembert_C2.
+  intro; apply Rabs_no_R0.
+  apply prod_neq_R0.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  apply pow_nonzero; assumption.
+  assert (H1 := Alembert_sin).
+  unfold sin_n in H1; unfold Un_cv in H1; unfold Un_cv in |- *; intros.
+  cut (0 < eps / Rsqr r).
+  intro; elim (H1 _ H3); intros N0 H4.
+  exists N0; intros.
+  unfold R_dist in |- *; assert (H6 := H4 _ H5).
+  unfold R_dist in H5;
+    replace
+    (Rabs
+      (Rabs (/ INR (fact (2 * S n + 1)) * r ^ (2 * S n)) /
+        Rabs (/ INR (fact (2 * n + 1)) * r ^ (2 * n)))) with
+    (Rsqr r *
+      Rabs
+      ((-1) ^ S n / INR (fact (2 * S n + 1)) /
+        ((-1) ^ n / INR (fact (2 * n + 1))))).
+  apply Rmult_lt_reg_l with (/ Rsqr r).
+  apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+  pattern (/ Rsqr r) at 1 in |- *; rewrite <- (Rabs_right (/ Rsqr r)).
+  rewrite <- Rabs_mult.
+  rewrite Rmult_minus_distr_l.
+  rewrite Rmult_0_r; rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
+  apply H6.
+  unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+  unfold Rdiv in |- *; rewrite (Rmult_comm (Rsqr r)); repeat rewrite Rabs_mult;
+    rewrite Rabs_Rabsolu; rewrite pow_1_abs.
+  rewrite Rmult_1_l.
+  repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+  rewrite Rinv_mult_distr.
+  rewrite Rinv_involutive.
+  rewrite Rabs_mult.
+  rewrite Rabs_Rinv.
+  rewrite pow_1_abs; rewrite Rinv_1; rewrite Rmult_1_l.
+  rewrite Rinv_mult_distr.
+  rewrite <- Rabs_Rinv.
+  rewrite Rinv_involutive.
+  rewrite Rabs_mult.
+  do 2 rewrite Rabs_Rabsolu.
+  rewrite (Rmult_comm (Rabs (r ^ (2 * S n)))).
+  rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+  rewrite Rabs_Rinv.
+  rewrite Rabs_Rabsolu.
+  repeat rewrite Rabs_right.
+  replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
+  do 2 rewrite <- Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  unfold Rsqr in |- *; ring.
+  apply pow_nonzero; assumption.
+  replace (2 * S n)%nat with (S (S (2 * n))).
+  simpl in |- *; ring.
+  ring.
+  apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+  apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+  apply Rabs_no_R0; apply pow_nonzero; assumption.
+  apply INR_fact_neq_0.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  apply Rabs_no_R0; apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  apply Rabs_no_R0; apply pow_nonzero; assumption.
+  apply pow_nonzero; discrR.
+  apply INR_fact_neq_0.
+  apply pow_nonzero; discrR.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption ].
+  assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
+    elim (Rlt_irrefl _ H0).
 Qed.
 
-(* (sin h)/h -> 1 when h -> 0 *)
+(** (sin h)/h -> 1 when h -> 0 *)
 Lemma derivable_pt_lim_sin_0 : derivable_pt_lim sin 0 1.
-unfold derivable_pt_lim in |- *; intros.
-set
- (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)).
-cut (CVN_R fn).
-intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
-intro cv.
-set (r := mkposreal _ Rlt_0_1).
-cut (CVN_r fn r).
-intro; cut (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y).
-intro; cut (Boule 0 r 0).
-intro; assert (H2 := SFL_continuity_pt _ cv _ X0 H0 _ H1).
-unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
- unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
-elim (H2 _ H); intros alp H3.
-elim H3; intros.
-exists (mkposreal _ H4).
-simpl in |- *; intros.
-rewrite sin_0; rewrite Rplus_0_l; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r.
-cut (Rabs (SFL fn cv h - SFL fn cv 0) < eps).
-intro; cut (SFL fn cv 0 = 1).
-intro; cut (SFL fn cv h = sin h / h).
-intro; rewrite H9 in H8; rewrite H10 in H8.
-apply H8.
-unfold SFL, sin in |- *.
-case (cv h); intros.
-case (exist_sin (Rsqr h)); intros.
-unfold Rdiv in |- *; rewrite (Rinv_r_simpl_m h x0 H6).
-eapply UL_sequence.
-apply u.
-unfold sin_in in s; unfold sin_n, infinit_sum in s;
- unfold SP, fn, Un_cv in |- *; intros.
-elim (s _ H10); intros N0 H11.
-exists N0; intros.
-unfold R_dist in |- *; unfold R_dist in H11.
-replace
- (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * h ^ (2 * k)) n)
- with
- (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * Rsqr h ^ i) n).
-apply H11; assumption.
-apply sum_eq; intros; apply Rmult_eq_compat_l; unfold Rsqr in |- *;
- rewrite pow_sqr; reflexivity.
-unfold SFL, sin in |- *.
-case (cv 0); intros.
-eapply UL_sequence.
-apply u.
-unfold SP, fn in |- *; unfold Un_cv in |- *; intros; exists 1%nat; intros.
-unfold R_dist in |- *;
- replace
-  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k)) n)
-  with 1.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-rewrite decomp_sum.
-simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite Rinv_1;
- rewrite Rmult_1_r; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
- apply Rplus_eq_compat_l.
-symmetry  in |- *; apply sum_eq_R0; intros.
-rewrite Rmult_0_l; rewrite Rmult_0_r; reflexivity.
-unfold ge in H10; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H10 ].
-apply H5.
-split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-apply (sym_not_eq (A:=R)); apply H6.
-unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply H7.
-unfold Boule in |- *; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; rewrite Rabs_R0; apply (cond_pos r).
-intros; unfold fn in |- *;
- replace (fun x:R => (-1) ^ n / INR (fact (2 * n + 1)) * x ^ (2 * n)) with
-  (fct_cte ((-1) ^ n / INR (fact (2 * n + 1))) * pow_fct (2 * n))%F;
- [ idtac | reflexivity ].
-apply continuity_pt_mult.
-apply derivable_continuous_pt.
-apply derivable_pt_const.
-apply derivable_continuous_pt.
-apply (derivable_pt_pow (2 * n) y).
-apply (X r).
-apply (CVN_R_CVS _ X).
-apply CVN_R_sin; unfold fn in |- *; reflexivity.
+Proof.
+  unfold derivable_pt_lim in |- *; intros.
+  set
+    (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)).
+  cut (CVN_R fn).
+  intro; cut (forall x:R, sigT (fun l:R => Un_cv (fun N:nat => SP fn N x) l)).
+  intro cv.
+  set (r := mkposreal _ Rlt_0_1).
+  cut (CVN_r fn r).
+  intro; cut (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y).
+  intro; cut (Boule 0 r 0).
+  intro; assert (H2 := SFL_continuity_pt _ cv _ X0 H0 _ H1).
+  unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
+    unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
+  elim (H2 _ H); intros alp H3.
+  elim H3; intros.
+  exists (mkposreal _ H4).
+  simpl in |- *; intros.
+  rewrite sin_0; rewrite Rplus_0_l; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r.
+  cut (Rabs (SFL fn cv h - SFL fn cv 0) < eps).
+  intro; cut (SFL fn cv 0 = 1).
+  intro; cut (SFL fn cv h = sin h / h).
+  intro; rewrite H9 in H8; rewrite H10 in H8.
+  apply H8.
+  unfold SFL, sin in |- *.
+  case (cv h); intros.
+  case (exist_sin (Rsqr h)); intros.
+  unfold Rdiv in |- *; rewrite (Rinv_r_simpl_m h x0 H6).
+  eapply UL_sequence.
+  apply u.
+  unfold sin_in in s; unfold sin_n, infinit_sum in s;
+    unfold SP, fn, Un_cv in |- *; intros.
+  elim (s _ H10); intros N0 H11.
+  exists N0; intros.
+  unfold R_dist in |- *; unfold R_dist in H11.
+  replace
+  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * h ^ (2 * k)) n)
+    with
+      (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * Rsqr h ^ i) n).
+  apply H11; assumption.
+  apply sum_eq; intros; apply Rmult_eq_compat_l; unfold Rsqr in |- *;
+    rewrite pow_sqr; reflexivity.
+  unfold SFL, sin in |- *.
+  case (cv 0); intros.
+  eapply UL_sequence.
+  apply u.
+  unfold SP, fn in |- *; unfold Un_cv in |- *; intros; exists 1%nat; intros.
+  unfold R_dist in |- *;
+    replace
+    (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k)) n)
+    with 1.
+  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  rewrite decomp_sum.
+  simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite Rinv_1;
+    rewrite Rmult_1_r; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+      apply Rplus_eq_compat_l.
+  symmetry  in |- *; apply sum_eq_R0; intros.
+  rewrite Rmult_0_l; rewrite Rmult_0_r; reflexivity.
+  unfold ge in H10; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H10 ].
+  apply H5.
+  split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  apply (sym_not_eq (A:=R)); apply H6.
+  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply H7.
+  unfold Boule in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; rewrite Rabs_R0; apply (cond_pos r).
+  intros; unfold fn in |- *;
+    replace (fun x:R => (-1) ^ n / INR (fact (2 * n + 1)) * x ^ (2 * n)) with
+    (fct_cte ((-1) ^ n / INR (fact (2 * n + 1))) * pow_fct (2 * n))%F;
+    [ idtac | reflexivity ].
+  apply continuity_pt_mult.
+  apply derivable_continuous_pt.
+  apply derivable_pt_const.
+  apply derivable_continuous_pt.
+  apply (derivable_pt_pow (2 * n) y).
+  apply (X r).
+  apply (CVN_R_CVS _ X).
+  apply CVN_R_sin; unfold fn in |- *; reflexivity.
 Qed.
 
-(* ((cos h)-1)/h -> 0 when h -> 0 *)
+(** ((cos h)-1)/h -> 0 when h -> 0 *)
 Lemma derivable_pt_lim_cos_0 : derivable_pt_lim cos 0 0.
-unfold derivable_pt_lim in |- *; intros.
-assert (H0 := derivable_pt_lim_sin_0).
-unfold derivable_pt_lim in H0.
-cut (0 < eps / 2).
-intro; elim (H0 _ H1); intros del H2.
-cut (continuity_pt sin 0).
-intro; unfold continuity_pt in H3; unfold continue_in in H3;
- unfold limit1_in in H3; unfold limit_in in H3; simpl in H3;
- unfold R_dist in H3.
-cut (0 < eps / 2); [ intro | assumption ].
-elim (H3 _ H4); intros del_c H5.
-cut (0 < Rmin del del_c).
-intro; set (delta := mkposreal _ H6).
-exists delta; intros.
-rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))).
-unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
-unfold Rdiv in |- *; do 2 rewrite Ropp_mult_distr_l_reverse.
-rewrite Rabs_Ropp.
-replace (2 * Rsqr (sin (h * / 2)) * / h) with
- (sin (h / 2) * (sin (h / 2) / (h / 2) - 1) + sin (h / 2)).
-apply Rle_lt_trans with
- (Rabs (sin (h / 2) * (sin (h / 2) / (h / 2) - 1)) + Rabs (sin (h / 2))).
-apply Rabs_triang.
-rewrite (double_var eps); apply Rplus_lt_compat.
-apply Rle_lt_trans with (Rabs (sin (h / 2) / (h / 2) - 1)).
-rewrite Rabs_mult; rewrite Rmult_comm;
- pattern (Rabs (sin (h / 2) / (h / 2) - 1)) at 2 in |- *;
- rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
-apply Rabs_pos.
-assert (H9 := SIN_bound (h / 2)).
-unfold Rabs in |- *; case (Rcase_abs (sin (h / 2))); intro.
-pattern 1 at 3 in |- *; rewrite <- (Ropp_involutive 1).
-apply Ropp_le_contravar.
-elim H9; intros; assumption.
-elim H9; intros; assumption.
-cut (Rabs (h / 2) < del).
-intro; cut (h / 2 <> 0).
-intro; assert (H11 := H2 _ H10 H9). 
-rewrite Rplus_0_l in H11; rewrite sin_0 in H11.
-rewrite Rminus_0_r in H11; apply H11.
-unfold Rdiv in |- *; apply prod_neq_R0.
-apply H7.
-apply Rinv_neq_0_compat; discrR.
-apply Rlt_trans with (del / 2).
-unfold Rdiv in |- *; rewrite Rabs_mult.
-rewrite (Rabs_right (/ 2)).
-do 2 rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
-apply Rinv_0_lt_compat; prove_sup0.
-apply Rlt_le_trans with (pos delta).
-apply H8.
-unfold delta in |- *; simpl in |- *; apply Rmin_l.
-apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
-rewrite <- (Rplus_0_r (del / 2)); pattern del at 1 in |- *;
- rewrite (double_var del); apply Rplus_lt_compat_l; 
- unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply (cond_pos del).
-apply Rinv_0_lt_compat; prove_sup0.
-elim H5; intros; assert (H11 := H10 (h / 2)).
-rewrite sin_0 in H11; do 2 rewrite Rminus_0_r in H11.
-apply H11.
-split.
-unfold D_x, no_cond in |- *; split.
-trivial.
-apply (sym_not_eq (A:=R)); unfold Rdiv in |- *; apply prod_neq_R0.
-apply H7.
-apply Rinv_neq_0_compat; discrR.
-apply Rlt_trans with (del_c / 2).
-unfold Rdiv in |- *; rewrite Rabs_mult.
-rewrite (Rabs_right (/ 2)).
-do 2 rewrite <- (Rmult_comm (/ 2)).
-apply Rmult_lt_compat_l.
-apply Rinv_0_lt_compat; prove_sup0.
-apply Rlt_le_trans with (pos delta).
-apply H8.
-unfold delta in |- *; simpl in |- *; apply Rmin_r.
-apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
-rewrite <- (Rplus_0_r (del_c / 2)); pattern del_c at 2 in |- *;
- rewrite (double_var del_c); apply Rplus_lt_compat_l.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply H9.
-apply Rinv_0_lt_compat; prove_sup0.
-rewrite Rmult_minus_distr_l; rewrite Rmult_1_r; unfold Rminus in |- *;
- rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
- rewrite (Rmult_comm 2); unfold Rdiv, Rsqr in |- *.
-repeat rewrite Rmult_assoc.
-repeat apply Rmult_eq_compat_l.
-rewrite Rinv_mult_distr.
-rewrite Rinv_involutive.
-apply Rmult_comm.
-discrR.
-apply H7.
-apply Rinv_neq_0_compat; discrR.
-pattern h at 2 in |- *; replace h with (2 * (h / 2)).
-rewrite (cos_2a_sin (h / 2)).
-rewrite cos_0; unfold Rsqr in |- *; ring.
-unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
-discrR.
-unfold Rmin in |- *; case (Rle_dec del del_c); intro.
-apply (cond_pos del).
-elim H5; intros; assumption.
-apply continuity_sin.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
+Proof.
+  unfold derivable_pt_lim in |- *; intros.
+  assert (H0 := derivable_pt_lim_sin_0).
+  unfold derivable_pt_lim in H0.
+  cut (0 < eps / 2).
+  intro; elim (H0 _ H1); intros del H2.
+  cut (continuity_pt sin 0).
+  intro; unfold continuity_pt in H3; unfold continue_in in H3;
+    unfold limit1_in in H3; unfold limit_in in H3; simpl in H3;
+      unfold R_dist in H3.
+  cut (0 < eps / 2); [ intro | assumption ].
+  elim (H3 _ H4); intros del_c H5.
+  cut (0 < Rmin del del_c).
+  intro; set (delta := mkposreal _ H6).
+  exists delta; intros.
+  rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))).
+  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
+  unfold Rdiv in |- *; do 2 rewrite Ropp_mult_distr_l_reverse.
+  rewrite Rabs_Ropp.
+  replace (2 * Rsqr (sin (h * / 2)) * / h) with
+  (sin (h / 2) * (sin (h / 2) / (h / 2) - 1) + sin (h / 2)).
+  apply Rle_lt_trans with
+    (Rabs (sin (h / 2) * (sin (h / 2) / (h / 2) - 1)) + Rabs (sin (h / 2))).
+  apply Rabs_triang.
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  apply Rle_lt_trans with (Rabs (sin (h / 2) / (h / 2) - 1)).
+  rewrite Rabs_mult; rewrite Rmult_comm;
+    pattern (Rabs (sin (h / 2) / (h / 2) - 1)) at 2 in |- *;
+      rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  assert (H9 := SIN_bound (h / 2)).
+  unfold Rabs in |- *; case (Rcase_abs (sin (h / 2))); intro.
+  pattern 1 at 3 in |- *; rewrite <- (Ropp_involutive 1).
+  apply Ropp_le_contravar.
+  elim H9; intros; assumption.
+  elim H9; intros; assumption.
+  cut (Rabs (h / 2) < del).
+  intro; cut (h / 2 <> 0).
+  intro; assert (H11 := H2 _ H10 H9). 
+  rewrite Rplus_0_l in H11; rewrite sin_0 in H11.
+  rewrite Rminus_0_r in H11; apply H11.
+  unfold Rdiv in |- *; apply prod_neq_R0.
+  apply H7.
+  apply Rinv_neq_0_compat; discrR.
+  apply Rlt_trans with (del / 2).
+  unfold Rdiv in |- *; rewrite Rabs_mult.
+  rewrite (Rabs_right (/ 2)).
+  do 2 rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
+  apply Rinv_0_lt_compat; prove_sup0.
+  apply Rlt_le_trans with (pos delta).
+  apply H8.
+  unfold delta in |- *; simpl in |- *; apply Rmin_l.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
+  rewrite <- (Rplus_0_r (del / 2)); pattern del at 1 in |- *;
+    rewrite (double_var del); apply Rplus_lt_compat_l; 
+      unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply (cond_pos del).
+  apply Rinv_0_lt_compat; prove_sup0.
+  elim H5; intros; assert (H11 := H10 (h / 2)).
+  rewrite sin_0 in H11; do 2 rewrite Rminus_0_r in H11.
+  apply H11.
+  split.
+  unfold D_x, no_cond in |- *; split.
+  trivial.
+  apply (sym_not_eq (A:=R)); unfold Rdiv in |- *; apply prod_neq_R0.
+  apply H7.
+  apply Rinv_neq_0_compat; discrR.
+  apply Rlt_trans with (del_c / 2).
+  unfold Rdiv in |- *; rewrite Rabs_mult.
+  rewrite (Rabs_right (/ 2)).
+  do 2 rewrite <- (Rmult_comm (/ 2)).
+  apply Rmult_lt_compat_l.
+  apply Rinv_0_lt_compat; prove_sup0.
+  apply Rlt_le_trans with (pos delta).
+  apply H8.
+  unfold delta in |- *; simpl in |- *; apply Rmin_r.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
+  rewrite <- (Rplus_0_r (del_c / 2)); pattern del_c at 2 in |- *;
+    rewrite (double_var del_c); apply Rplus_lt_compat_l.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply H9.
+  apply Rinv_0_lt_compat; prove_sup0.
+  rewrite Rmult_minus_distr_l; rewrite Rmult_1_r; unfold Rminus in |- *;
+    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
+      rewrite (Rmult_comm 2); unfold Rdiv, Rsqr in |- *.
+  repeat rewrite Rmult_assoc.
+  repeat apply Rmult_eq_compat_l.
+  rewrite Rinv_mult_distr.
+  rewrite Rinv_involutive.
+  apply Rmult_comm.
+  discrR.
+  apply H7.
+  apply Rinv_neq_0_compat; discrR.
+  pattern h at 2 in |- *; replace h with (2 * (h / 2)).
+  rewrite (cos_2a_sin (h / 2)).
+  rewrite cos_0; unfold Rsqr in |- *; ring.
+  unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+  discrR.
+  unfold Rmin in |- *; case (Rle_dec del del_c); intro.
+  apply (cond_pos del).
+  elim H5; intros; assumption.
+  apply continuity_sin.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
 (**********)
 Theorem derivable_pt_lim_sin : forall x:R, derivable_pt_lim sin x (cos x).
-intro; assert (H0 := derivable_pt_lim_sin_0).
-assert (H := derivable_pt_lim_cos_0).
-unfold derivable_pt_lim in H0, H.
-unfold derivable_pt_lim in |- *; intros.
-cut (0 < eps / 2);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ apply H1 | apply Rinv_0_lt_compat; prove_sup0 ] ].
-elim (H0 _ H2); intros alp1 H3.
-elim (H _ H2); intros alp2 H4.
-set (alp := Rmin alp1 alp2).
-cut (0 < alp).
-intro; exists (mkposreal _ H5); intros.
-replace ((sin (x + h) - sin x) / h - cos x) with
- (sin x * ((cos h - 1) / h) + cos x * (sin h / h - 1)).
-apply Rle_lt_trans with
- (Rabs (sin x * ((cos h - 1) / h)) + Rabs (cos x * (sin h / h - 1))).
-apply Rabs_triang.
-rewrite (double_var eps); apply Rplus_lt_compat.
-apply Rle_lt_trans with (Rabs ((cos h - 1) / h)).
-rewrite Rabs_mult; rewrite Rmult_comm;
- pattern (Rabs ((cos h - 1) / h)) at 2 in |- *; rewrite <- Rmult_1_r;
- apply Rmult_le_compat_l.
-apply Rabs_pos.
-assert (H8 := SIN_bound x); elim H8; intros.
-unfold Rabs in |- *; case (Rcase_abs (sin x)); intro.
-rewrite <- (Ropp_involutive 1).
-apply Ropp_le_contravar; assumption.
-assumption.
-cut (Rabs h < alp2).
-intro; assert (H9 := H4 _ H6 H8).
-rewrite cos_0 in H9; rewrite Rplus_0_l in H9; rewrite Rminus_0_r in H9;
- apply H9.
-apply Rlt_le_trans with alp.
-apply H7.
-unfold alp in |- *; apply Rmin_r.
-apply Rle_lt_trans with (Rabs (sin h / h - 1)).
-rewrite Rabs_mult; rewrite Rmult_comm;
- pattern (Rabs (sin h / h - 1)) at 2 in |- *; rewrite <- Rmult_1_r;
- apply Rmult_le_compat_l.
-apply Rabs_pos.
-assert (H8 := COS_bound x); elim H8; intros.
-unfold Rabs in |- *; case (Rcase_abs (cos x)); intro.
-rewrite <- (Ropp_involutive 1); apply Ropp_le_contravar; assumption.
-assumption.
-cut (Rabs h < alp1).
-intro; assert (H9 := H3 _ H6 H8).
-rewrite sin_0 in H9; rewrite Rplus_0_l in H9; rewrite Rminus_0_r in H9;
- apply H9.
-apply Rlt_le_trans with alp.
-apply H7.
-unfold alp in |- *; apply Rmin_l.
-rewrite sin_plus; unfold Rminus, Rdiv in |- *;
- repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
- repeat rewrite Rmult_assoc; repeat rewrite Rplus_assoc;
- apply Rplus_eq_compat_l.
-rewrite (Rplus_comm (sin x * (-1 * / h))); repeat rewrite Rplus_assoc;
- apply Rplus_eq_compat_l.
-rewrite Ropp_mult_distr_r_reverse; rewrite Ropp_mult_distr_l_reverse;
- rewrite Rmult_1_r; rewrite Rmult_1_l; rewrite Ropp_mult_distr_r_reverse;
- rewrite <- Ropp_mult_distr_l_reverse; apply Rplus_comm.
-unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec alp1 alp2); intro.
-apply (cond_pos alp1).
-apply (cond_pos alp2).
+Proof.
+  intro; assert (H0 := derivable_pt_lim_sin_0).
+  assert (H := derivable_pt_lim_cos_0).
+  unfold derivable_pt_lim in H0, H.
+  unfold derivable_pt_lim in |- *; intros.
+  cut (0 < eps / 2);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ apply H1 | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (H0 _ H2); intros alp1 H3.
+  elim (H _ H2); intros alp2 H4.
+  set (alp := Rmin alp1 alp2).
+  cut (0 < alp).
+  intro; exists (mkposreal _ H5); intros.
+  replace ((sin (x + h) - sin x) / h - cos x) with
+  (sin x * ((cos h - 1) / h) + cos x * (sin h / h - 1)).
+  apply Rle_lt_trans with
+    (Rabs (sin x * ((cos h - 1) / h)) + Rabs (cos x * (sin h / h - 1))).
+  apply Rabs_triang.
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  apply Rle_lt_trans with (Rabs ((cos h - 1) / h)).
+  rewrite Rabs_mult; rewrite Rmult_comm;
+    pattern (Rabs ((cos h - 1) / h)) at 2 in |- *; rewrite <- Rmult_1_r;
+      apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  assert (H8 := SIN_bound x); elim H8; intros.
+  unfold Rabs in |- *; case (Rcase_abs (sin x)); intro.
+  rewrite <- (Ropp_involutive 1).
+  apply Ropp_le_contravar; assumption.
+  assumption.
+  cut (Rabs h < alp2).
+  intro; assert (H9 := H4 _ H6 H8).
+  rewrite cos_0 in H9; rewrite Rplus_0_l in H9; rewrite Rminus_0_r in H9;
+    apply H9.
+  apply Rlt_le_trans with alp.
+  apply H7.
+  unfold alp in |- *; apply Rmin_r.
+  apply Rle_lt_trans with (Rabs (sin h / h - 1)).
+  rewrite Rabs_mult; rewrite Rmult_comm;
+    pattern (Rabs (sin h / h - 1)) at 2 in |- *; rewrite <- Rmult_1_r;
+      apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  assert (H8 := COS_bound x); elim H8; intros.
+  unfold Rabs in |- *; case (Rcase_abs (cos x)); intro.
+  rewrite <- (Ropp_involutive 1); apply Ropp_le_contravar; assumption.
+  assumption.
+  cut (Rabs h < alp1).
+  intro; assert (H9 := H3 _ H6 H8).
+  rewrite sin_0 in H9; rewrite Rplus_0_l in H9; rewrite Rminus_0_r in H9;
+    apply H9.
+  apply Rlt_le_trans with alp.
+  apply H7.
+  unfold alp in |- *; apply Rmin_l.
+  rewrite sin_plus; unfold Rminus, Rdiv in |- *;
+    repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
+      repeat rewrite Rmult_assoc; repeat rewrite Rplus_assoc;
+        apply Rplus_eq_compat_l.
+  rewrite (Rplus_comm (sin x * (-1 * / h))); repeat rewrite Rplus_assoc;
+    apply Rplus_eq_compat_l.
+  rewrite Ropp_mult_distr_r_reverse; rewrite Ropp_mult_distr_l_reverse;
+    rewrite Rmult_1_r; rewrite Rmult_1_l; rewrite Ropp_mult_distr_r_reverse;
+      rewrite <- Ropp_mult_distr_l_reverse; apply Rplus_comm.
+  unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec alp1 alp2); intro.
+  apply (cond_pos alp1).
+  apply (cond_pos alp2).
 Qed.
 
 Lemma derivable_pt_lim_cos : forall x:R, derivable_pt_lim cos x (- sin x).
-intro; cut (forall h:R, sin (h + PI / 2) = cos h).
-intro; replace (- sin x) with (cos (x + PI / 2) * (1 + 0)).
-generalize (derivable_pt_lim_comp (id + fct_cte (PI / 2))%F sin); intros.
-cut (derivable_pt_lim (id + fct_cte (PI / 2)) x (1 + 0)).
-cut (derivable_pt_lim sin ((id + fct_cte (PI / 2))%F x) (cos (x + PI / 2))).
-intros; generalize (H0 _ _ _ H2 H1);
- replace (comp sin (id + fct_cte (PI / 2))%F) with
-  (fun x:R => sin (x + PI / 2)); [ idtac | reflexivity ].
-unfold derivable_pt_lim in |- *; intros.
-elim (H3 eps H4); intros.
-exists x0.
-intros; rewrite <- (H (x + h)); rewrite <- (H x); apply H5; assumption.
-apply derivable_pt_lim_sin.
-apply derivable_pt_lim_plus.
-apply derivable_pt_lim_id.
-apply derivable_pt_lim_const.
-rewrite sin_cos; rewrite <- (Rplus_comm x); ring.
-intro; rewrite cos_sin; rewrite Rplus_comm; reflexivity.
+Proof.
+  intro; cut (forall h:R, sin (h + PI / 2) = cos h).
+  intro; replace (- sin x) with (cos (x + PI / 2) * (1 + 0)).
+  generalize (derivable_pt_lim_comp (id + fct_cte (PI / 2))%F sin); intros.
+  cut (derivable_pt_lim (id + fct_cte (PI / 2)) x (1 + 0)).
+  cut (derivable_pt_lim sin ((id + fct_cte (PI / 2))%F x) (cos (x + PI / 2))).
+  intros; generalize (H0 _ _ _ H2 H1);
+    replace (comp sin (id + fct_cte (PI / 2))%F) with
+    (fun x:R => sin (x + PI / 2)); [ idtac | reflexivity ].
+  unfold derivable_pt_lim in |- *; intros.
+  elim (H3 eps H4); intros.
+  exists x0.
+  intros; rewrite <- (H (x + h)); rewrite <- (H x); apply H5; assumption.
+  apply derivable_pt_lim_sin.
+  apply derivable_pt_lim_plus.
+  apply derivable_pt_lim_id.
+  apply derivable_pt_lim_const.
+  rewrite sin_cos; rewrite <- (Rplus_comm x); ring.
+  intro; rewrite cos_sin; rewrite Rplus_comm; reflexivity.
 Qed.
 
 Lemma derivable_pt_sin : forall x:R, derivable_pt sin x.
-unfold derivable_pt in |- *; intro.
-apply existT with (cos x).
-apply derivable_pt_lim_sin.
+Proof.
+  unfold derivable_pt in |- *; intro.
+  apply existT with (cos x).
+  apply derivable_pt_lim_sin.
 Qed.
 
 Lemma derivable_pt_cos : forall x:R, derivable_pt cos x.
-unfold derivable_pt in |- *; intro.
-apply existT with (- sin x).
-apply derivable_pt_lim_cos.
+Proof.
+  unfold derivable_pt in |- *; intro.
+  apply existT with (- sin x).
+  apply derivable_pt_lim_cos.
 Qed.
 
 Lemma derivable_sin : derivable sin.
-unfold derivable in |- *; intro; apply derivable_pt_sin.
+Proof.
+  unfold derivable in |- *; intro; apply derivable_pt_sin.
 Qed.
 
 Lemma derivable_cos : derivable cos.
-unfold derivable in |- *; intro; apply derivable_pt_cos.
+Proof.
+  unfold derivable in |- *; intro; apply derivable_pt_cos.
 Qed.
 
 Lemma derive_pt_sin :
- forall x:R, derive_pt sin x (derivable_pt_sin _) = cos x.
-intros; apply derive_pt_eq_0.
-apply derivable_pt_lim_sin.
+  forall x:R, derive_pt sin x (derivable_pt_sin _) = cos x.
+Proof.
+  intros; apply derive_pt_eq_0.
+  apply derivable_pt_lim_sin.
 Qed.
 
 Lemma derive_pt_cos :
- forall x:R, derive_pt cos x (derivable_pt_cos _) = - sin x.
-intros; apply derive_pt_eq_0.
-apply derivable_pt_lim_cos.
-Qed.
\ No newline at end of file
+  forall x:R, derive_pt cos x (derivable_pt_cos _) = - sin x.
+Proof.
+  intros; apply derive_pt_eq_0.
+  apply derivable_pt_lim_cos.
+Qed.
diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v
index 34f9fd72..96351618 100644
--- a/theories/Reals/SeqProp.v
+++ b/theories/Reals/SeqProp.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: SeqProp.v,v 1.13.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+(*i $Id: SeqProp.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -23,1273 +23,1309 @@ Definition has_lb (Un:nat -> R) : Prop := bound (EUn (opp_seq Un)).
 
 (**********)
 Lemma growing_cv :
- forall Un:nat -> R,
-   Un_growing Un -> has_ub Un -> sigT (fun l:R => Un_cv Un l).
-unfold Un_growing, Un_cv in |- *; intros;
- destruct (completeness (EUn Un) H0 (EUn_noempty Un)) as [x [H2 H3]].
- exists x; intros eps H1.
- unfold is_upper_bound in H2, H3.
-assert (H5 : forall n:nat, Un n <= x).
+  forall Un:nat -> R,
+    Un_growing Un -> has_ub Un -> sigT (fun l:R => Un_cv Un l).
+Proof.
+  unfold Un_growing, Un_cv in |- *; intros;
+    destruct (completeness (EUn Un) H0 (EUn_noempty Un)) as [x [H2 H3]].
+  exists x; intros eps H1.
+  unfold is_upper_bound in H2, H3.
+  assert (H5 : forall n:nat, Un n <= x).
   intro n; apply (H2 (Un n) (Un_in_EUn Un n)).
-cut (exists N : nat, x - eps < Un N).
-intro H6; destruct H6 as [N H6]; exists N.
-intros n H7; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
-unfold Rgt in H1.
- apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H1).
-fold Un_growing in H; generalize (growing_prop Un n N H H7); intro H8.
- generalize
-  (Rlt_le_trans (x - eps) (Un N) (Un n) H6 (Rge_le (Un n) (Un N) H8));
-  intro H9; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
-  unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
-  rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
-  rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
-  trivial.
-cut (~ (forall N:nat, Un N <= x - eps)).
-intro H6; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)).
- intro H7; apply H6; intro N; apply Rnot_lt_le; apply H7.
-intro H7; generalize (Un_bound_imp Un (x - eps) H7); intro H8;
- unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); 
- apply Rlt_not_le; apply tech_Rgt_minus; exact H1.
+  cut (exists N : nat, x - eps < Un N).
+  intro H6; destruct H6 as [N H6]; exists N.
+  intros n H7; unfold R_dist in |- *; apply (Rabs_def1 (Un n - x) eps).
+  unfold Rgt in H1.
+  apply (Rle_lt_trans (Un n - x) 0 eps (Rle_minus (Un n) x (H5 n)) H1).
+  fold Un_growing in H; generalize (growing_prop Un n N H H7); intro H8.
+  generalize
+    (Rlt_le_trans (x - eps) (Un N) (Un n) H6 (Rge_le (Un n) (Un N) H8));
+    intro H9; generalize (Rplus_lt_compat_l (- x) (x - eps) (Un n) H9);
+      unfold Rminus in |- *; rewrite <- (Rplus_assoc (- x) x (- eps));
+        rewrite (Rplus_comm (- x) (Un n)); fold (Un n - x) in |- *;
+          rewrite Rplus_opp_l; rewrite (let (H1, H2) := Rplus_ne (- eps) in H2);
+            trivial.
+  cut (~ (forall N:nat, Un N <= x - eps)).
+  intro H6; apply (not_all_not_ex nat (fun N:nat => x - eps < Un N)).
+  intro H7; apply H6; intro N; apply Rnot_lt_le; apply H7.
+  intro H7; generalize (Un_bound_imp Un (x - eps) H7); intro H8;
+    unfold is_upper_bound in H8; generalize (H3 (x - eps) H8);
+      apply Rlt_not_le; apply tech_Rgt_minus; exact H1.
 Qed.
 
 Lemma decreasing_growing :
- forall Un:nat -> R, Un_decreasing Un -> Un_growing (opp_seq Un).
-intro.
-unfold Un_growing, opp_seq, Un_decreasing in |- *.
-intros.
-apply Ropp_le_contravar.
-apply H.
+  forall Un:nat -> R, Un_decreasing Un -> Un_growing (opp_seq Un).
+Proof.
+  intro.
+  unfold Un_growing, opp_seq, Un_decreasing in |- *.
+  intros.
+  apply Ropp_le_contravar.
+  apply H.
 Qed.
 
 Lemma decreasing_cv :
- forall Un:nat -> R,
-   Un_decreasing Un -> has_lb Un -> sigT (fun l:R => Un_cv Un l).
-intros.
-cut (sigT (fun l:R => Un_cv (opp_seq Un) l) -> sigT (fun l:R => Un_cv Un l)).
-intro.
-apply X.
-apply growing_cv.
-apply decreasing_growing; assumption.
-exact H0.
-intro.
-elim X; intros.
-apply existT with (- x).
-unfold Un_cv in p.
-unfold R_dist in p.
-unfold opp_seq in p.
-unfold Un_cv in |- *.
-unfold R_dist in |- *.
-intros.
-elim (p eps H1); intros.
-exists x0; intros.
-assert (H4 := H2 n H3).
-rewrite <- Rabs_Ropp.
-replace (- (Un n - - x)) with (- Un n - x); [ assumption | ring ].
+  forall Un:nat -> R,
+    Un_decreasing Un -> has_lb Un -> sigT (fun l:R => Un_cv Un l).
+Proof.
+  intros.
+  cut (sigT (fun l:R => Un_cv (opp_seq Un) l) -> sigT (fun l:R => Un_cv Un l)).
+  intro X.
+  apply X.
+  apply growing_cv.
+  apply decreasing_growing; assumption.
+  exact H0.
+  intro X.
+  elim X; intros.
+  apply existT with (- x).
+  unfold Un_cv in p.
+  unfold R_dist in p.
+  unfold opp_seq in p.
+  unfold Un_cv in |- *.
+  unfold R_dist in |- *.
+  intros.
+  elim (p eps H1); intros.
+  exists x0; intros.
+  assert (H4 := H2 n H3).
+  rewrite <- Rabs_Ropp.
+  replace (- (Un n - - x)) with (- Un n - x); [ assumption | ring ].
 Qed.
 
 (***********)
 Lemma maj_sup :
- forall Un:nat -> R, has_ub Un -> sigT (fun l:R => is_lub (EUn Un) l).
-intros.
-unfold has_ub in H.
-apply completeness.
-assumption.
-exists (Un 0%nat).
-unfold EUn in |- *.
-exists 0%nat; reflexivity.
+  forall Un:nat -> R, has_ub Un -> sigT (fun l:R => is_lub (EUn Un) l).
+Proof.
+  intros.
+  unfold has_ub in H.
+  apply completeness.
+  assumption.
+  exists (Un 0%nat).
+  unfold EUn in |- *.
+  exists 0%nat; reflexivity.
 Qed.
 
 (**********)
 Lemma min_inf :
- forall Un:nat -> R,
-   has_lb Un -> sigT (fun l:R => is_lub (EUn (opp_seq Un)) l).
-intros; unfold has_lb in H.
-apply completeness.
-assumption.
-exists (- Un 0%nat).
-exists 0%nat.
-reflexivity.
+  forall Un:nat -> R,
+    has_lb Un -> sigT (fun l:R => is_lub (EUn (opp_seq Un)) l).
+Proof.
+  intros; unfold has_lb in H.
+  apply completeness.
+  assumption.
+  exists (- Un 0%nat).
+  exists 0%nat.
+  reflexivity.
 Qed.
 
 Definition majorant (Un:nat -> R) (pr:has_ub Un) : R :=
   match maj_sup Un pr with
-  | existT a b => a
+    | existT a b => a
   end.
 
 Definition minorant (Un:nat -> R) (pr:has_lb Un) : R :=
   match min_inf Un pr with
-  | existT a b => - a
+    | existT a b => - a
   end.
 
 Lemma maj_ss :
- forall (Un:nat -> R) (k:nat),
-   has_ub Un -> has_ub (fun i:nat => Un (k + i)%nat).
-intros.
-unfold has_ub in H.
-unfold bound in H.
-elim H; intros.
-unfold is_upper_bound in H0.
-unfold has_ub in |- *.
-exists x.
-unfold is_upper_bound in |- *.
-intros.
-apply H0.
-elim H1; intros.
-exists (k + x1)%nat; assumption.
+  forall (Un:nat -> R) (k:nat),
+    has_ub Un -> has_ub (fun i:nat => Un (k + i)%nat).
+Proof.
+  intros.
+  unfold has_ub in H.
+  unfold bound in H.
+  elim H; intros.
+  unfold is_upper_bound in H0.
+  unfold has_ub in |- *.
+  exists x.
+  unfold is_upper_bound in |- *.
+  intros.
+  apply H0.
+  elim H1; intros.
+  exists (k + x1)%nat; assumption.
 Qed.
 
 Lemma min_ss :
- forall (Un:nat -> R) (k:nat),
-   has_lb Un -> has_lb (fun i:nat => Un (k + i)%nat).
-intros.
-unfold has_lb in H.
-unfold bound in H.
-elim H; intros.
-unfold is_upper_bound in H0.
-unfold has_lb in |- *.
-exists x.
-unfold is_upper_bound in |- *.
-intros.
-apply H0.
-elim H1; intros.
-exists (k + x1)%nat; assumption.
+  forall (Un:nat -> R) (k:nat),
+    has_lb Un -> has_lb (fun i:nat => Un (k + i)%nat).
+Proof.
+  intros.
+  unfold has_lb in H.
+  unfold bound in H.
+  elim H; intros.
+  unfold is_upper_bound in H0.
+  unfold has_lb in |- *.
+  exists x.
+  unfold is_upper_bound in |- *.
+  intros.
+  apply H0.
+  elim H1; intros.
+  exists (k + x1)%nat; assumption.
 Qed.
 
-Definition sequence_majorant (Un:nat -> R) (pr:has_ub Un) 
+Definition sequence_majorant (Un:nat -> R) (pr:has_ub Un)
   (i:nat) : R := majorant (fun k:nat => Un (i + k)%nat) (maj_ss Un i pr).
 
-Definition sequence_minorant (Un:nat -> R) (pr:has_lb Un) 
+Definition sequence_minorant (Un:nat -> R) (pr:has_lb Un)
   (i:nat) : R := minorant (fun k:nat => Un (i + k)%nat) (min_ss Un i pr).
 
 Lemma Wn_decreasing :
- forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_majorant Un pr). 
-intros.
-unfold Un_decreasing in |- *.
-intro.
-unfold sequence_majorant in |- *.
-assert (H := maj_sup (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
-assert (H0 := maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
-elim H; intros.
-elim H0; intros.
-cut (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr) = x);
- [ intro Maj1; rewrite Maj1 | idtac ].
-cut (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0);
- [ intro Maj2; rewrite Maj2 | idtac ].
-unfold is_lub in p.
-unfold is_lub in p0.
-elim p; intros.
-apply H2.
-elim p0; intros.
-unfold is_upper_bound in |- *.
-intros.
-unfold is_upper_bound in H3.
-apply H3.
-elim H5; intros.
-exists (1 + x2)%nat.
-replace (n + (1 + x2))%nat with (S n + x2)%nat.
-assumption.
-replace (S n) with (1 + n)%nat; [ ring | ring ].
-cut
- (is_lub (EUn (fun k:nat => Un (n + k)%nat))
-    (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr))).
-intro.
-unfold is_lub in p0; unfold is_lub in H1.
-elim p0; intros; elim H1; intros.
-assert (H6 := H5 x0 H2).
-assert
- (H7 := H3 (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4).
-apply Rle_antisym; assumption.
-unfold majorant in |- *.
-case (maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
-trivial.
-cut
- (is_lub (EUn (fun k:nat => Un (S n + k)%nat))
-    (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr))).
-intro.
-unfold is_lub in p; unfold is_lub in H1.
-elim p; intros; elim H1; intros.
-assert (H6 := H5 x H2).
-assert
- (H7 :=
-  H3 (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4).
-apply Rle_antisym; assumption.
-unfold majorant in |- *.
-case (maj_sup (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
-trivial.
+  forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_majorant Un pr).
+Proof.
+  intros.
+  unfold Un_decreasing in |- *.
+  intro.
+  unfold sequence_majorant in |- *.
+  assert (H := maj_sup (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
+  assert (H0 := maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
+  elim H; intros.
+  elim H0; intros.
+  cut (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr) = x);
+    [ intro Maj1; rewrite Maj1 | idtac ].
+  cut (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0);
+    [ intro Maj2; rewrite Maj2 | idtac ].
+  unfold is_lub in p.
+  unfold is_lub in p0.
+  elim p; intros.
+  apply H2.
+  elim p0; intros.
+  unfold is_upper_bound in |- *.
+  intros.
+  unfold is_upper_bound in H3.
+  apply H3.
+  elim H5; intros.
+  exists (1 + x2)%nat.
+  replace (n + (1 + x2))%nat with (S n + x2)%nat.
+  assumption.
+  replace (S n) with (1 + n)%nat; [ ring | ring ].
+  cut
+    (is_lub (EUn (fun k:nat => Un (n + k)%nat))
+      (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr))).
+  intro.
+  unfold is_lub in p0; unfold is_lub in H1.
+  elim p0; intros; elim H1; intros.
+  assert (H6 := H5 x0 H2).
+  assert
+    (H7 := H3 (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4).
+  apply Rle_antisym; assumption.
+  unfold majorant in |- *.
+  case (maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
+  trivial.
+  cut
+    (is_lub (EUn (fun k:nat => Un (S n + k)%nat))
+      (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr))).
+  intro.
+  unfold is_lub in p; unfold is_lub in H1.
+  elim p; intros; elim H1; intros.
+  assert (H6 := H5 x H2).
+  assert
+    (H7 :=
+      H3 (majorant (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4).
+  apply Rle_antisym; assumption.
+  unfold majorant in |- *.
+  case (maj_sup (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
+  trivial.
 Qed.
 
 Lemma Vn_growing :
- forall (Un:nat -> R) (pr:has_lb Un), Un_growing (sequence_minorant Un pr).
-intros.
-unfold Un_growing in |- *.
-intro.
-unfold sequence_minorant in |- *.
-assert (H := min_inf (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)).
-assert (H0 := min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)).
-elim H; intros.
-elim H0; intros.
-cut (minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr) = - x);
- [ intro Maj1; rewrite Maj1 | idtac ].
-cut (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr) = - x0);
- [ intro Maj2; rewrite Maj2 | idtac ].
-unfold is_lub in p.
-unfold is_lub in p0.
-elim p; intros.
-apply Ropp_le_contravar.
-apply H2.
-elim p0; intros.
-unfold is_upper_bound in |- *.
-intros.
-unfold is_upper_bound in H3.
-apply H3.
-elim H5; intros.
-exists (1 + x2)%nat.
-unfold opp_seq in H6.
-unfold opp_seq in |- *.
-replace (n + (1 + x2))%nat with (S n + x2)%nat.
-assumption.
-replace (S n) with (1 + n)%nat; [ ring | ring ].
-cut
- (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
-    (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))).
-intro.
-unfold is_lub in p0; unfold is_lub in H1.
-elim p0; intros; elim H1; intros.
-assert (H6 := H5 x0 H2).
-assert
- (H7 := H3 (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)) H4).
-rewrite <-
- (Ropp_involutive (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)))
- .
-apply Ropp_eq_compat; apply Rle_antisym; assumption.
-unfold minorant in |- *.
-case (min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)).
-intro; rewrite Ropp_involutive.
-trivial.
-cut
- (is_lub (EUn (opp_seq (fun k:nat => Un (S n + k)%nat)))
-    (- minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))).
-intro.
-unfold is_lub in p; unfold is_lub in H1.
-elim p; intros; elim H1; intros.
-assert (H6 := H5 x H2).
-assert
- (H7 :=
-  H3 (- minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)) H4).
-rewrite <-
- (Ropp_involutive
-    (minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)))
- .
-apply Ropp_eq_compat; apply Rle_antisym; assumption.
-unfold minorant in |- *.
-case (min_inf (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)).
-intro; rewrite Ropp_involutive.
-trivial.
+  forall (Un:nat -> R) (pr:has_lb Un), Un_growing (sequence_minorant Un pr).
+Proof.
+  intros.
+  unfold Un_growing in |- *.
+  intro.
+  unfold sequence_minorant in |- *.
+  assert (H := min_inf (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)).
+  assert (H0 := min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)).
+  elim H; intros.
+  elim H0; intros.
+  cut (minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr) = - x);
+    [ intro Maj1; rewrite Maj1 | idtac ].
+  cut (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr) = - x0);
+    [ intro Maj2; rewrite Maj2 | idtac ].
+  unfold is_lub in p.
+  unfold is_lub in p0.
+  elim p; intros.
+  apply Ropp_le_contravar.
+  apply H2.
+  elim p0; intros.
+  unfold is_upper_bound in |- *.
+  intros.
+  unfold is_upper_bound in H3.
+  apply H3.
+  elim H5; intros.
+  exists (1 + x2)%nat.
+  unfold opp_seq in H6.
+  unfold opp_seq in |- *.
+  replace (n + (1 + x2))%nat with (S n + x2)%nat.
+  assumption.
+  replace (S n) with (1 + n)%nat; [ ring | ring ].
+  cut
+    (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
+      (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr))).
+  intro.
+  unfold is_lub in p0; unfold is_lub in H1.
+  elim p0; intros; elim H1; intros.
+  assert (H6 := H5 x0 H2).
+  assert
+    (H7 := H3 (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)) H4).
+  rewrite <-
+    (Ropp_involutive (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)))
+    .
+  apply Ropp_eq_compat; apply Rle_antisym; assumption.
+  unfold minorant in |- *.
+  case (min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)).
+  intro; rewrite Ropp_involutive.
+  trivial.
+  cut
+    (is_lub (EUn (opp_seq (fun k:nat => Un (S n + k)%nat)))
+      (- minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr))).
+  intro.
+  unfold is_lub in p; unfold is_lub in H1.
+  elim p; intros; elim H1; intros.
+  assert (H6 := H5 x H2).
+  assert
+    (H7 :=
+      H3 (- minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)) H4).
+  rewrite <-
+    (Ropp_involutive
+      (minorant (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)))
+    .
+  apply Ropp_eq_compat; apply Rle_antisym; assumption.
+  unfold minorant in |- *.
+  case (min_inf (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)).
+  intro; rewrite Ropp_involutive.
+  trivial.
 Qed.
 
 (**********)
 Lemma Vn_Un_Wn_order :
- forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un) 
-   (n:nat), sequence_minorant Un pr2 n <= Un n <= sequence_majorant Un pr1 n. 
-intros.
-split.
-unfold sequence_minorant in |- *.
-cut
- (sigT (fun l:R => is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l)).
-intro.
-elim X; intros.
-replace (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) with (- x).
-unfold is_lub in p.
-elim p; intros.
-unfold is_upper_bound in H.
-rewrite <- (Ropp_involutive (Un n)).
-apply Ropp_le_contravar.
-apply H.
-exists 0%nat.
-unfold opp_seq in |- *.
-replace (n + 0)%nat with n; [ reflexivity | ring ].
-cut
- (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
-    (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))).
-intro.
-unfold is_lub in p; unfold is_lub in H.
-elim p; intros; elim H; intros.
-assert (H4 := H3 x H0).
-assert
- (H5 := H1 (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) H2).
-rewrite <-
- (Ropp_involutive (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)))
- .
-apply Ropp_eq_compat; apply Rle_antisym; assumption.
-unfold minorant in |- *.
-case (min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)).
-intro; rewrite Ropp_involutive.
-trivial.
-apply min_inf.
-apply min_ss; assumption.
-unfold sequence_majorant in |- *.
-cut (sigT (fun l:R => is_lub (EUn (fun i:nat => Un (n + i)%nat)) l)).
-intro.
-elim X; intros.
-replace (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) with x.
-unfold is_lub in p.
-elim p; intros.
-unfold is_upper_bound in H.
-apply H.
-exists 0%nat.
-replace (n + 0)%nat with n; [ reflexivity | ring ].
-cut
- (is_lub (EUn (fun k:nat => Un (n + k)%nat))
-    (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1))).
-intro.
-unfold is_lub in p; unfold is_lub in H.
-elim p; intros; elim H; intros.
-assert (H4 := H3 x H0).
-assert
- (H5 := H1 (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) H2).
-apply Rle_antisym; assumption.
-unfold majorant in |- *.
-case (maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)).
-intro; trivial.
-apply maj_sup.
-apply maj_ss; assumption.
+  forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un)
+    (n:nat), sequence_minorant Un pr2 n <= Un n <= sequence_majorant Un pr1 n.
+Proof.
+  intros.
+  split.
+  unfold sequence_minorant in |- *.
+  cut
+    (sigT (fun l:R => is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l)).
+  intro X.
+  elim X; intros.
+  replace (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) with (- x).
+  unfold is_lub in p.
+  elim p; intros.
+  unfold is_upper_bound in H.
+  rewrite <- (Ropp_involutive (Un n)).
+  apply Ropp_le_contravar.
+  apply H.
+  exists 0%nat.
+  unfold opp_seq in |- *.
+  replace (n + 0)%nat with n; [ reflexivity | ring ].
+  cut
+    (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
+      (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2))).
+  intro.
+  unfold is_lub in p; unfold is_lub in H.
+  elim p; intros; elim H; intros.
+  assert (H4 := H3 x H0).
+  assert
+    (H5 := H1 (- minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)) H2).
+  rewrite <-
+    (Ropp_involutive (minorant (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)))
+    .
+  apply Ropp_eq_compat; apply Rle_antisym; assumption.
+  unfold minorant in |- *.
+  case (min_inf (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)).
+  intro; rewrite Ropp_involutive.
+  trivial.
+  apply min_inf.
+  apply min_ss; assumption.
+  unfold sequence_majorant in |- *.
+  cut (sigT (fun l:R => is_lub (EUn (fun i:nat => Un (n + i)%nat)) l)).
+  intro X.
+  elim X; intros.
+  replace (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) with x.
+  unfold is_lub in p.
+  elim p; intros.
+  unfold is_upper_bound in H.
+  apply H.
+  exists 0%nat.
+  replace (n + 0)%nat with n; [ reflexivity | ring ].
+  cut
+    (is_lub (EUn (fun k:nat => Un (n + k)%nat))
+      (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1))).
+  intro.
+  unfold is_lub in p; unfold is_lub in H.
+  elim p; intros; elim H; intros.
+  assert (H4 := H3 x H0).
+  assert
+    (H5 := H1 (majorant (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) H2).
+  apply Rle_antisym; assumption.
+  unfold majorant in |- *.
+  case (maj_sup (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)).
+  intro; trivial.
+  apply maj_sup.
+  apply maj_ss; assumption.
 Qed.
 
 Lemma min_maj :
- forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un),
-   has_ub (sequence_minorant Un pr2).
-intros.
-assert (H := Vn_Un_Wn_order Un pr1 pr2).
-unfold has_ub in |- *.
-unfold bound in |- *.
-unfold has_ub in pr1.
-unfold bound in pr1.
-elim pr1; intros.
-exists x.
-unfold is_upper_bound in |- *.
-intros.
-unfold is_upper_bound in H0.
-elim H1; intros.
-rewrite H2.
-apply Rle_trans with (Un x1).
-assert (H3 := H x1); elim H3; intros; assumption.
-apply H0.
-exists x1; reflexivity.
+  forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un),
+    has_ub (sequence_minorant Un pr2).
+Proof.
+  intros.
+  assert (H := Vn_Un_Wn_order Un pr1 pr2).
+  unfold has_ub in |- *.
+  unfold bound in |- *.
+  unfold has_ub in pr1.
+  unfold bound in pr1.
+  elim pr1; intros.
+  exists x.
+  unfold is_upper_bound in |- *.
+  intros.
+  unfold is_upper_bound in H0.
+  elim H1; intros.
+  rewrite H2.
+  apply Rle_trans with (Un x1).
+  assert (H3 := H x1); elim H3; intros; assumption.
+  apply H0.
+  exists x1; reflexivity.
 Qed.
 
 Lemma maj_min :
- forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un),
-   has_lb (sequence_majorant Un pr1). 
-intros.
-assert (H := Vn_Un_Wn_order Un pr1 pr2).
-unfold has_lb in |- *.
-unfold bound in |- *.
-unfold has_lb in pr2.
-unfold bound in pr2.
-elim pr2; intros.
-exists x.
-unfold is_upper_bound in |- *.
-intros.
-unfold is_upper_bound in H0.
-elim H1; intros.
-rewrite H2.
-apply Rle_trans with (opp_seq Un x1).
-assert (H3 := H x1); elim H3; intros.
-unfold opp_seq in |- *; apply Ropp_le_contravar.
-assumption.
-apply H0.
-exists x1; reflexivity.
+  forall (Un:nat -> R) (pr1:has_ub Un) (pr2:has_lb Un),
+    has_lb (sequence_majorant Un pr1).
+Proof.
+  intros.
+  assert (H := Vn_Un_Wn_order Un pr1 pr2).
+  unfold has_lb in |- *.
+  unfold bound in |- *.
+  unfold has_lb in pr2.
+  unfold bound in pr2.
+  elim pr2; intros.
+  exists x.
+  unfold is_upper_bound in |- *.
+  intros.
+  unfold is_upper_bound in H0.
+  elim H1; intros.
+  rewrite H2.
+  apply Rle_trans with (opp_seq Un x1).
+  assert (H3 := H x1); elim H3; intros.
+  unfold opp_seq in |- *; apply Ropp_le_contravar.
+  assumption.
+  apply H0.
+  exists x1; reflexivity.
 Qed.
 
 (**********)
 Lemma cauchy_maj : forall Un:nat -> R, Cauchy_crit Un -> has_ub Un.
-intros.
-unfold has_ub in |- *.
-apply cauchy_bound.
-assumption.
+Proof.
+  intros.
+  unfold has_ub in |- *.
+  apply cauchy_bound.
+  assumption.
 Qed.
 
 (**********)
 Lemma cauchy_opp :
- forall Un:nat -> R, Cauchy_crit Un -> Cauchy_crit (opp_seq Un).
-intro.
-unfold Cauchy_crit in |- *.
-unfold R_dist in |- *.
-intros.
-elim (H eps H0); intros.
-exists x; intros.
-unfold opp_seq in |- *.
-rewrite <- Rabs_Ropp.
-replace (- (- Un n - - Un m)) with (Un n - Un m);
- [ apply H1; assumption | ring ].
+  forall Un:nat -> R, Cauchy_crit Un -> Cauchy_crit (opp_seq Un).
+Proof.
+  intro.
+  unfold Cauchy_crit in |- *.
+  unfold R_dist in |- *.
+  intros.
+  elim (H eps H0); intros.
+  exists x; intros.
+  unfold opp_seq in |- *.
+  rewrite <- Rabs_Ropp.
+  replace (- (- Un n - - Un m)) with (Un n - Un m);
+  [ apply H1; assumption | ring ].
 Qed.
 
 (**********)
 Lemma cauchy_min : forall Un:nat -> R, Cauchy_crit Un -> has_lb Un.
-intros.
-unfold has_lb in |- *.
-assert (H0 := cauchy_opp _ H).
-apply cauchy_bound.
-assumption.
+Proof.
+  intros.
+  unfold has_lb in |- *.
+  assert (H0 := cauchy_opp _ H).
+  apply cauchy_bound.
+  assumption.
 Qed.
 
 (**********)
 Lemma maj_cv :
- forall (Un:nat -> R) (pr:Cauchy_crit Un),
-   sigT (fun l:R => Un_cv (sequence_majorant Un (cauchy_maj Un pr)) l).
-intros.
-apply decreasing_cv.
-apply Wn_decreasing.
-apply maj_min.
-apply cauchy_min.
-assumption.
+  forall (Un:nat -> R) (pr:Cauchy_crit Un),
+    sigT (fun l:R => Un_cv (sequence_majorant Un (cauchy_maj Un pr)) l).
+Proof.
+  intros.
+  apply decreasing_cv.
+  apply Wn_decreasing.
+  apply maj_min.
+  apply cauchy_min.
+  assumption.
 Qed.
 
 (**********)
 Lemma min_cv :
- forall (Un:nat -> R) (pr:Cauchy_crit Un),
-   sigT (fun l:R => Un_cv (sequence_minorant Un (cauchy_min Un pr)) l).
-intros.
-apply growing_cv.
-apply Vn_growing.
-apply min_maj.
-apply cauchy_maj.
-assumption.
+  forall (Un:nat -> R) (pr:Cauchy_crit Un),
+    sigT (fun l:R => Un_cv (sequence_minorant Un (cauchy_min Un pr)) l).
+Proof.
+  intros.
+  apply growing_cv.
+  apply Vn_growing.
+  apply min_maj.
+  apply cauchy_maj.
+  assumption.
 Qed.
 
 Lemma cond_eq :
- forall x y:R, (forall eps:R, 0 < eps -> Rabs (x - y) < eps) -> x = y.
-intros.
-case (total_order_T x y); intro.
-elim s; intro.
-cut (0 < y - x).
-intro.
-assert (H1 := H (y - x) H0).
-rewrite <- Rabs_Ropp in H1.
-cut (- (x - y) = y - x); [ intro; rewrite H2 in H1 | ring ].
-rewrite Rabs_right in H1.
-elim (Rlt_irrefl _ H1).
-left; assumption.
-apply Rplus_lt_reg_r with x.
-rewrite Rplus_0_r; replace (x + (y - x)) with y; [ assumption | ring ].
-assumption.
-cut (0 < x - y).
-intro.
-assert (H1 := H (x - y) H0).
-rewrite Rabs_right in H1.
-elim (Rlt_irrefl _ H1).
-left; assumption.
-apply Rplus_lt_reg_r with y.
-rewrite Rplus_0_r; replace (y + (x - y)) with x; [ assumption | ring ].
+  forall x y:R, (forall eps:R, 0 < eps -> Rabs (x - y) < eps) -> x = y.
+Proof.
+  intros.
+  case (total_order_T x y); intro.
+  elim s; intro.
+  cut (0 < y - x).
+  intro.
+  assert (H1 := H (y - x) H0).
+  rewrite <- Rabs_Ropp in H1.
+  cut (- (x - y) = y - x); [ intro; rewrite H2 in H1 | ring ].
+  rewrite Rabs_right in H1.
+  elim (Rlt_irrefl _ H1).
+  left; assumption.
+  apply Rplus_lt_reg_r with x.
+  rewrite Rplus_0_r; replace (x + (y - x)) with y; [ assumption | ring ].
+  assumption.
+  cut (0 < x - y).
+  intro.
+  assert (H1 := H (x - y) H0).
+  rewrite Rabs_right in H1.
+  elim (Rlt_irrefl _ H1).
+  left; assumption.
+  apply Rplus_lt_reg_r with y.
+  rewrite Rplus_0_r; replace (y + (x - y)) with x; [ assumption | ring ].
 Qed.
 
 Lemma not_Rlt : forall r1 r2:R, ~ r1 < r2 -> r1 >= r2.
-intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rge in |- *.
-tauto.
-Qed. 
+Proof.
+  intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rge in |- *.
+  tauto.
+Qed.
 
 (**********)
 Lemma approx_maj :
- forall (Un:nat -> R) (pr:has_ub Un) (eps:R),
-   0 < eps ->  exists k : nat, Rabs (majorant Un pr - Un k) < eps.
-intros.
-set (P := fun k:nat => Rabs (majorant Un pr - Un k) < eps).
-unfold P in |- *.
-cut
- ((exists k : nat, P k) ->
-   exists k : nat, Rabs (majorant Un pr - Un k) < eps).
-intros.
-apply H0.
-apply not_all_not_ex.
-red in |- *; intro.
-2: unfold P in |- *; trivial.
-unfold P in H1.
-cut (forall n:nat, Rabs (majorant Un pr - Un n) >= eps).
-intro.
-cut (is_lub (EUn Un) (majorant Un pr)).
-intro.
-unfold is_lub in H3.
-unfold is_upper_bound in H3.
-elim H3; intros.
-cut (forall n:nat, eps <= majorant Un pr - Un n).
-intro.
-cut (forall n:nat, Un n <= majorant Un pr - eps).
-intro.
-cut (forall x:R, EUn Un x -> x <= majorant Un pr - eps).
-intro.
-assert (H9 := H5 (majorant Un pr - eps) H8).
-cut (eps <= 0).
-intro.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
-apply Rplus_le_reg_l with (majorant Un pr - eps).
-rewrite Rplus_0_r.
-replace (majorant Un pr - eps + eps) with (majorant Un pr);
- [ assumption | ring ].
-intros.
-unfold EUn in H8.
-elim H8; intros.
-rewrite H9; apply H7.
-intro.
-assert (H7 := H6 n).
-apply Rplus_le_reg_l with (eps - Un n).
-replace (eps - Un n + Un n) with eps.
-replace (eps - Un n + (majorant Un pr - eps)) with (majorant Un pr - Un n).
-assumption.
-ring.
-ring.
-intro.
-assert (H6 := H2 n).
-rewrite Rabs_right in H6.
-apply Rge_le.
-assumption.
-apply Rle_ge.
-apply Rplus_le_reg_l with (Un n).
-rewrite Rplus_0_r;
- replace (Un n + (majorant Un pr - Un n)) with (majorant Un pr);
- [ apply H4 | ring ].
-exists n; reflexivity.
-unfold majorant in |- *.
-case (maj_sup Un pr).
-trivial.
-intro.
-assert (H2 := H1 n).
-apply not_Rlt; assumption.
+  forall (Un:nat -> R) (pr:has_ub Un) (eps:R),
+    0 < eps ->  exists k : nat, Rabs (majorant Un pr - Un k) < eps.
+Proof.
+  intros.
+  set (P := fun k:nat => Rabs (majorant Un pr - Un k) < eps).
+  unfold P in |- *.
+  cut
+    ((exists k : nat, P k) ->
+      exists k : nat, Rabs (majorant Un pr - Un k) < eps).
+  intros.
+  apply H0.
+  apply not_all_not_ex.
+  red in |- *; intro.
+  2: unfold P in |- *; trivial.
+  unfold P in H1.
+  cut (forall n:nat, Rabs (majorant Un pr - Un n) >= eps).
+  intro.
+  cut (is_lub (EUn Un) (majorant Un pr)).
+  intro.
+  unfold is_lub in H3.
+  unfold is_upper_bound in H3.
+  elim H3; intros.
+  cut (forall n:nat, eps <= majorant Un pr - Un n).
+  intro.
+  cut (forall n:nat, Un n <= majorant Un pr - eps).
+  intro.
+  cut (forall x:R, EUn Un x -> x <= majorant Un pr - eps).
+  intro.
+  assert (H9 := H5 (majorant Un pr - eps) H8).
+  cut (eps <= 0).
+  intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
+  apply Rplus_le_reg_l with (majorant Un pr - eps).
+  rewrite Rplus_0_r.
+  replace (majorant Un pr - eps + eps) with (majorant Un pr);
+  [ assumption | ring ].
+  intros.
+  unfold EUn in H8.
+  elim H8; intros.
+  rewrite H9; apply H7.
+  intro.
+  assert (H7 := H6 n).
+  apply Rplus_le_reg_l with (eps - Un n).
+  replace (eps - Un n + Un n) with eps.
+  replace (eps - Un n + (majorant Un pr - eps)) with (majorant Un pr - Un n).
+  assumption.
+  ring.
+  ring.
+  intro.
+  assert (H6 := H2 n).
+  rewrite Rabs_right in H6.
+  apply Rge_le.
+  assumption.
+  apply Rle_ge.
+  apply Rplus_le_reg_l with (Un n).
+  rewrite Rplus_0_r;
+    replace (Un n + (majorant Un pr - Un n)) with (majorant Un pr);
+    [ apply H4 | ring ].
+  exists n; reflexivity.
+  unfold majorant in |- *.
+  case (maj_sup Un pr).
+  trivial.
+  intro.
+  assert (H2 := H1 n).
+  apply not_Rlt; assumption.
 Qed.
 
 (**********)
 Lemma approx_min :
- forall (Un:nat -> R) (pr:has_lb Un) (eps:R),
-   0 < eps ->  exists k : nat, Rabs (minorant Un pr - Un k) < eps.
-intros.
-set (P := fun k:nat => Rabs (minorant Un pr - Un k) < eps).
-unfold P in |- *.
-cut
- ((exists k : nat, P k) ->
-   exists k : nat, Rabs (minorant Un pr - Un k) < eps).
-intros.
-apply H0.
-apply not_all_not_ex.
-red in |- *; intro.
-2: unfold P in |- *; trivial.
-unfold P in H1.
-cut (forall n:nat, Rabs (minorant Un pr - Un n) >= eps).
-intro.
-cut (is_lub (EUn (opp_seq Un)) (- minorant Un pr)).
-intro.
-unfold is_lub in H3.
-unfold is_upper_bound in H3.
-elim H3; intros.
-cut (forall n:nat, eps <= Un n - minorant Un pr).
-intro.
-cut (forall n:nat, opp_seq Un n <= - minorant Un pr - eps).
-intro.
-cut (forall x:R, EUn (opp_seq Un) x -> x <= - minorant Un pr - eps).
-intro.
-assert (H9 := H5 (- minorant Un pr - eps) H8).
-cut (eps <= 0).
-intro.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
-apply Rplus_le_reg_l with (- minorant Un pr - eps).
-rewrite Rplus_0_r.
-replace (- minorant Un pr - eps + eps) with (- minorant Un pr);
- [ assumption | ring ].
-intros.
-unfold EUn in H8.
-elim H8; intros.
-rewrite H9; apply H7.
-intro.
-assert (H7 := H6 n).
-unfold opp_seq in |- *.
-apply Rplus_le_reg_l with (eps + Un n).
-replace (eps + Un n + - Un n) with eps.
-replace (eps + Un n + (- minorant Un pr - eps)) with (Un n - minorant Un pr).
-assumption.
-ring.
-ring.
-intro.
-assert (H6 := H2 n).
-rewrite Rabs_left1 in H6.
-apply Rge_le.
-replace (Un n - minorant Un pr) with (- (minorant Un pr - Un n));
- [ assumption | ring ].
-apply Rplus_le_reg_l with (- minorant Un pr).
-rewrite Rplus_0_r;
- replace (- minorant Un pr + (minorant Un pr - Un n)) with (- Un n).
-apply H4.
-exists n; reflexivity.
-ring.
-unfold minorant in |- *.
-case (min_inf Un pr).
-intro.
-rewrite Ropp_involutive.
-trivial.
-intro.
-assert (H2 := H1 n).
-apply not_Rlt; assumption.
+  forall (Un:nat -> R) (pr:has_lb Un) (eps:R),
+    0 < eps ->  exists k : nat, Rabs (minorant Un pr - Un k) < eps.
+Proof.
+  intros.
+  set (P := fun k:nat => Rabs (minorant Un pr - Un k) < eps).
+  unfold P in |- *.
+  cut
+    ((exists k : nat, P k) ->
+      exists k : nat, Rabs (minorant Un pr - Un k) < eps).
+  intros.
+  apply H0.
+  apply not_all_not_ex.
+  red in |- *; intro.
+  2: unfold P in |- *; trivial.
+  unfold P in H1.
+  cut (forall n:nat, Rabs (minorant Un pr - Un n) >= eps).
+  intro.
+  cut (is_lub (EUn (opp_seq Un)) (- minorant Un pr)).
+  intro.
+  unfold is_lub in H3.
+  unfold is_upper_bound in H3.
+  elim H3; intros.
+  cut (forall n:nat, eps <= Un n - minorant Un pr).
+  intro.
+  cut (forall n:nat, opp_seq Un n <= - minorant Un pr - eps).
+  intro.
+  cut (forall x:R, EUn (opp_seq Un) x -> x <= - minorant Un pr - eps).
+  intro.
+  assert (H9 := H5 (- minorant Un pr - eps) H8).
+  cut (eps <= 0).
+  intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H H10)).
+  apply Rplus_le_reg_l with (- minorant Un pr - eps).
+  rewrite Rplus_0_r.
+  replace (- minorant Un pr - eps + eps) with (- minorant Un pr);
+  [ assumption | ring ].
+  intros.
+  unfold EUn in H8.
+  elim H8; intros.
+  rewrite H9; apply H7.
+  intro.
+  assert (H7 := H6 n).
+  unfold opp_seq in |- *.
+  apply Rplus_le_reg_l with (eps + Un n).
+  replace (eps + Un n + - Un n) with eps.
+  replace (eps + Un n + (- minorant Un pr - eps)) with (Un n - minorant Un pr).
+  assumption.
+  ring.
+  ring.
+  intro.
+  assert (H6 := H2 n).
+  rewrite Rabs_left1 in H6.
+  apply Rge_le.
+  replace (Un n - minorant Un pr) with (- (minorant Un pr - Un n));
+  [ assumption | ring ].
+  apply Rplus_le_reg_l with (- minorant Un pr).
+  rewrite Rplus_0_r;
+    replace (- minorant Un pr + (minorant Un pr - Un n)) with (- Un n).
+  apply H4.
+  exists n; reflexivity.
+  ring.
+  unfold minorant in |- *.
+  case (min_inf Un pr).
+  intro.
+  rewrite Ropp_involutive.
+  trivial.
+  intro.
+  assert (H2 := H1 n).
+  apply not_Rlt; assumption.
 Qed.
 
-(* Unicity of limit for convergent sequences *) 
+(** Unicity of limit for convergent sequences *)
 Lemma UL_sequence :
- forall (Un:nat -> R) (l1 l2:R), Un_cv Un l1 -> Un_cv Un l2 -> l1 = l2. 
-intros Un l1 l2; unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
-apply cond_eq. 
-intros; cut (0 < eps / 2);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
-elim (H (eps / 2) H2); intros. 
-elim (H0 (eps / 2) H2); intros. 
-set (N := max x x0). 
-apply Rle_lt_trans with (Rabs (l1 - Un N) + Rabs (Un N - l2)). 
-replace (l1 - l2) with (l1 - Un N + (Un N - l2));
- [ apply Rabs_triang | ring ]. 
-rewrite (double_var eps); apply Rplus_lt_compat. 
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H3;
- unfold ge, N in |- *; apply le_max_l. 
-apply H4; unfold ge, N in |- *; apply le_max_r. 
+  forall (Un:nat -> R) (l1 l2:R), Un_cv Un l1 -> Un_cv Un l2 -> l1 = l2.
+Proof.
+  intros Un l1 l2; unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  apply cond_eq.
+  intros; cut (0 < eps / 2);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (H (eps / 2) H2); intros.
+  elim (H0 (eps / 2) H2); intros.
+  set (N := max x x0).
+  apply Rle_lt_trans with (Rabs (l1 - Un N) + Rabs (Un N - l2)).
+  replace (l1 - l2) with (l1 - Un N + (Un N - l2));
+  [ apply Rabs_triang | ring ].
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H3;
+    unfold ge, N in |- *; apply le_max_l.
+  apply H4; unfold ge, N in |- *; apply le_max_r.
 Qed.
 
-(**********) 
+(**********)
 Lemma CV_plus :
- forall (An Bn:nat -> R) (l1 l2:R),
-   Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i + Bn i) (l1 + l2). 
-unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
-cut (0 < eps / 2);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
-elim (H (eps / 2) H2); intros. 
-elim (H0 (eps / 2) H2); intros. 
-set (N := max x x0). 
-exists N; intros. 
-replace (An n + Bn n - (l1 + l2)) with (An n - l1 + (Bn n - l2));
- [ idtac | ring ]. 
-apply Rle_lt_trans with (Rabs (An n - l1) + Rabs (Bn n - l2)). 
-apply Rabs_triang. 
-rewrite (double_var eps); apply Rplus_lt_compat. 
-apply H3; unfold ge in |- *; apply le_trans with N;
- [ unfold N in |- *; apply le_max_l | assumption ]. 
-apply H4; unfold ge in |- *; apply le_trans with N;
- [ unfold N in |- *; apply le_max_r | assumption ]. 
+  forall (An Bn:nat -> R) (l1 l2:R),
+    Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i + Bn i) (l1 + l2).
+Proof.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  cut (0 < eps / 2);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (H (eps / 2) H2); intros.
+  elim (H0 (eps / 2) H2); intros.
+  set (N := max x x0).
+  exists N; intros.
+  replace (An n + Bn n - (l1 + l2)) with (An n - l1 + (Bn n - l2));
+  [ idtac | ring ].
+  apply Rle_lt_trans with (Rabs (An n - l1) + Rabs (Bn n - l2)).
+  apply Rabs_triang.
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  apply H3; unfold ge in |- *; apply le_trans with N;
+    [ unfold N in |- *; apply le_max_l | assumption ].
+  apply H4; unfold ge in |- *; apply le_trans with N;
+    [ unfold N in |- *; apply le_max_r | assumption ].
 Qed.
 
-(**********) 
+(**********)
 Lemma cv_cvabs :
- forall (Un:nat -> R) (l:R),
-   Un_cv Un l -> Un_cv (fun i:nat => Rabs (Un i)) (Rabs l). 
-unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
-elim (H eps H0); intros. 
-exists x; intros. 
-apply Rle_lt_trans with (Rabs (Un n - l)). 
-apply Rabs_triang_inv2. 
-apply H1; assumption. 
-Qed. 
+  forall (Un:nat -> R) (l:R),
+    Un_cv Un l -> Un_cv (fun i:nat => Rabs (Un i)) (Rabs l).
+Proof.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  elim (H eps H0); intros.
+  exists x; intros.
+  apply Rle_lt_trans with (Rabs (Un n - l)).
+  apply Rabs_triang_inv2.
+  apply H1; assumption.
+Qed.
 
-(**********) 
+(**********)
 Lemma CV_Cauchy :
- forall Un:nat -> R, sigT (fun l:R => Un_cv Un l) -> Cauchy_crit Un. 
-intros; elim X; intros. 
-unfold Cauchy_crit in |- *; intros. 
-unfold Un_cv in p; unfold R_dist in p. 
-cut (0 < eps / 2);
- [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. 
-elim (p (eps / 2) H0); intros. 
-exists x0; intros. 
-unfold R_dist in |- *;
- apply Rle_lt_trans with (Rabs (Un n - x) + Rabs (x - Un m)). 
-replace (Un n - Un m) with (Un n - x + (x - Un m));
- [ apply Rabs_triang | ring ]. 
-rewrite (double_var eps); apply Rplus_lt_compat. 
-apply H1; assumption. 
-rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1; assumption. 
-Qed. 
+  forall Un:nat -> R, sigT (fun l:R => Un_cv Un l) -> Cauchy_crit Un.
+Proof.
+  intros Un X; elim X; intros.
+  unfold Cauchy_crit in |- *; intros.
+  unfold Un_cv in p; unfold R_dist in p.
+  cut (0 < eps / 2);
+    [ intro
+      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
+  elim (p (eps / 2) H0); intros.
+  exists x0; intros.
+  unfold R_dist in |- *;
+    apply Rle_lt_trans with (Rabs (Un n - x) + Rabs (x - Un m)).
+  replace (Un n - Un m) with (Un n - x + (x - Un m));
+  [ apply Rabs_triang | ring ].
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  apply H1; assumption.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H1; assumption.
+Qed.
 
 (**********)
 Lemma maj_by_pos :
- forall Un:nat -> R,
-   sigT (fun l:R => Un_cv Un l) ->
-    exists l : R, 0 < l /\ (forall n:nat, Rabs (Un n) <= l). 
-intros; elim X; intros. 
-cut (sigT (fun l:R => Un_cv (fun k:nat => Rabs (Un k)) l)). 
-intro. 
-assert (H := CV_Cauchy (fun k:nat => Rabs (Un k)) X0). 
-assert (H0 := cauchy_bound (fun k:nat => Rabs (Un k)) H). 
-elim H0; intros. 
-exists (x0 + 1). 
-cut (0 <= x0). 
-intro. 
-split. 
-apply Rplus_le_lt_0_compat; [ assumption | apply Rlt_0_1 ]. 
-intros. 
-apply Rle_trans with x0. 
-unfold is_upper_bound in H1. 
-apply H1. 
-exists n; reflexivity. 
-pattern x0 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
- apply Rlt_0_1. 
-apply Rle_trans with (Rabs (Un 0%nat)). 
-apply Rabs_pos. 
-unfold is_upper_bound in H1. 
-apply H1. 
-exists 0%nat; reflexivity. 
-apply existT with (Rabs x). 
-apply cv_cvabs; assumption. 
-Qed. 
- 
-(**********) 
+  forall Un:nat -> R,
+    sigT (fun l:R => Un_cv Un l) ->
+    exists l : R, 0 < l /\ (forall n:nat, Rabs (Un n) <= l).
+Proof.
+  intros Un X; elim X; intros.
+  cut (sigT (fun l:R => Un_cv (fun k:nat => Rabs (Un k)) l)).
+  intro X0.
+  assert (H := CV_Cauchy (fun k:nat => Rabs (Un k)) X0).
+  assert (H0 := cauchy_bound (fun k:nat => Rabs (Un k)) H).
+  elim H0; intros.
+  exists (x0 + 1).
+  cut (0 <= x0).
+  intro.
+  split.
+  apply Rplus_le_lt_0_compat; [ assumption | apply Rlt_0_1 ].
+  intros.
+  apply Rle_trans with x0.
+  unfold is_upper_bound in H1.
+  apply H1.
+  exists n; reflexivity.
+  pattern x0 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+    apply Rlt_0_1.
+  apply Rle_trans with (Rabs (Un 0%nat)).
+  apply Rabs_pos.
+  unfold is_upper_bound in H1.
+  apply H1.
+  exists 0%nat; reflexivity.
+  apply existT with (Rabs x).
+  apply cv_cvabs; assumption.
+Qed.
+
+(**********)
 Lemma CV_mult :
- forall (An Bn:nat -> R) (l1 l2:R),
-   Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i * Bn i) (l1 * l2). 
-intros. 
-cut (sigT (fun l:R => Un_cv An l)). 
-intro. 
-assert (H1 := maj_by_pos An X). 
-elim H1; intros M H2. 
-elim H2; intros. 
-unfold Un_cv in |- *; unfold R_dist in |- *; intros. 
-cut (0 < eps / (2 * M)). 
-intro. 
-case (Req_dec l2 0); intro. 
-unfold Un_cv in H0; unfold R_dist in H0. 
-elim (H0 (eps / (2 * M)) H6); intros. 
-exists x; intros. 
-apply Rle_lt_trans with
- (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). 
-replace (An n * Bn n - l1 * l2) with
- (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2));
- [ apply Rabs_triang | ring ]. 
-replace (Rabs (An n * Bn n - An n * l2)) with
- (Rabs (An n) * Rabs (Bn n - l2)). 
-replace (Rabs (An n * l2 - l1 * l2)) with 0. 
-rewrite Rplus_0_r. 
-apply Rle_lt_trans with (M * Rabs (Bn n - l2)). 
-do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). 
-apply Rmult_le_compat_l. 
-apply Rabs_pos. 
-apply H4. 
-apply Rmult_lt_reg_l with (/ M). 
-apply Rinv_0_lt_compat; apply H3. 
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. 
-rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). 
-apply Rlt_trans with (eps / (2 * M)). 
-apply H8; assumption. 
-unfold Rdiv in |- *; rewrite Rinv_mult_distr. 
-apply Rmult_lt_reg_l with 2. 
-prove_sup0.
-replace (2 * (eps * (/ 2 * / M))) with (2 * / 2 * (eps * / M));
- [ idtac | ring ]. 
-rewrite <- Rinv_r_sym. 
-rewrite Rmult_1_l; rewrite double. 
-pattern (eps * / M) at 1 in |- *; rewrite <- Rplus_0_r. 
-apply Rplus_lt_compat_l; apply Rmult_lt_0_compat;
- [ assumption | apply Rinv_0_lt_compat; assumption ]. 
-discrR. 
-discrR. 
-red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). 
-red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3). 
-rewrite H7; do 2 rewrite Rmult_0_r; unfold Rminus in |- *;
- rewrite Rplus_opp_r; rewrite Rabs_R0; reflexivity. 
-replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); [ idtac | ring ]. 
-symmetry  in |- *; apply Rabs_mult. 
-cut (0 < eps / (2 * Rabs l2)). 
-intro. 
-unfold Un_cv in H; unfold R_dist in H; unfold Un_cv in H0;
- unfold R_dist in H0. 
-elim (H (eps / (2 * Rabs l2)) H8); intros N1 H9. 
-elim (H0 (eps / (2 * M)) H6); intros N2 H10. 
-set (N := max N1 N2). 
-exists N; intros. 
-apply Rle_lt_trans with
- (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)). 
-replace (An n * Bn n - l1 * l2) with
- (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2));
- [ apply Rabs_triang | ring ]. 
-replace (Rabs (An n * Bn n - An n * l2)) with
- (Rabs (An n) * Rabs (Bn n - l2)). 
-replace (Rabs (An n * l2 - l1 * l2)) with (Rabs l2 * Rabs (An n - l1)). 
-rewrite (double_var eps); apply Rplus_lt_compat. 
-apply Rle_lt_trans with (M * Rabs (Bn n - l2)). 
-do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))). 
-apply Rmult_le_compat_l. 
-apply Rabs_pos. 
-apply H4. 
-apply Rmult_lt_reg_l with (/ M). 
-apply Rinv_0_lt_compat; apply H3. 
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. 
-rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)). 
-apply Rlt_le_trans with (eps / (2 * M)). 
-apply H10. 
-unfold ge in |- *; apply le_trans with N. 
-unfold N in |- *; apply le_max_r. 
-assumption. 
-unfold Rdiv in |- *; rewrite Rinv_mult_distr. 
-right; ring. 
-discrR. 
-red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). 
-red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3). 
-apply Rmult_lt_reg_l with (/ Rabs l2). 
-apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. 
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym. 
-rewrite Rmult_1_l; apply Rlt_le_trans with (eps / (2 * Rabs l2)). 
-apply H9. 
-unfold ge in |- *; apply le_trans with N. 
-unfold N in |- *; apply le_max_l. 
-assumption. 
-unfold Rdiv in |- *; right; rewrite Rinv_mult_distr. 
-ring. 
-discrR. 
-apply Rabs_no_R0; assumption. 
-apply Rabs_no_R0; assumption. 
-replace (An n * l2 - l1 * l2) with (l2 * (An n - l1));
- [ symmetry  in |- *; apply Rabs_mult | ring ]. 
-replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2));
- [ symmetry  in |- *; apply Rabs_mult | ring ]. 
-unfold Rdiv in |- *; apply Rmult_lt_0_compat. 
-assumption. 
-apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
- [ prove_sup0 | apply Rabs_pos_lt; assumption ]. 
-unfold Rdiv in |- *; apply Rmult_lt_0_compat;
- [ assumption
- | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
-    [ prove_sup0 | assumption ] ]. 
-apply existT with l1; assumption. 
-Qed. 
+  forall (An Bn:nat -> R) (l1 l2:R),
+    Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i * Bn i) (l1 * l2).
+Proof.
+  intros.
+  cut (sigT (fun l:R => Un_cv An l)).
+  intro X.
+  assert (H1 := maj_by_pos An X).
+  elim H1; intros M H2.
+  elim H2; intros.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  cut (0 < eps / (2 * M)).
+  intro.
+  case (Req_dec l2 0); intro.
+  unfold Un_cv in H0; unfold R_dist in H0.
+  elim (H0 (eps / (2 * M)) H6); intros.
+  exists x; intros.
+  apply Rle_lt_trans with
+    (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)).
+  replace (An n * Bn n - l1 * l2) with
+  (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2));
+  [ apply Rabs_triang | ring ].
+  replace (Rabs (An n * Bn n - An n * l2)) with
+  (Rabs (An n) * Rabs (Bn n - l2)).
+  replace (Rabs (An n * l2 - l1 * l2)) with 0.
+  rewrite Rplus_0_r.
+  apply Rle_lt_trans with (M * Rabs (Bn n - l2)).
+  do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))).
+  apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply H4.
+  apply Rmult_lt_reg_l with (/ M).
+  apply Rinv_0_lt_compat; apply H3.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)).
+  apply Rlt_trans with (eps / (2 * M)).
+  apply H8; assumption.
+  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  replace (2 * (eps * (/ 2 * / M))) with (2 * / 2 * (eps * / M));
+  [ idtac | ring ].
+  rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite double.
+  pattern (eps * / M) at 1 in |- *; rewrite <- Rplus_0_r.
+  apply Rplus_lt_compat_l; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; assumption ].
+  discrR.
+  discrR.
+  red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3).
+  red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3).
+  rewrite H7; do 2 rewrite Rmult_0_r; unfold Rminus in |- *;
+    rewrite Rplus_opp_r; rewrite Rabs_R0; reflexivity.
+  replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); [ idtac | ring ].
+  symmetry  in |- *; apply Rabs_mult.
+  cut (0 < eps / (2 * Rabs l2)).
+  intro.
+  unfold Un_cv in H; unfold R_dist in H; unfold Un_cv in H0;
+    unfold R_dist in H0.
+  elim (H (eps / (2 * Rabs l2)) H8); intros N1 H9.
+  elim (H0 (eps / (2 * M)) H6); intros N2 H10.
+  set (N := max N1 N2).
+  exists N; intros.
+  apply Rle_lt_trans with
+    (Rabs (An n * Bn n - An n * l2) + Rabs (An n * l2 - l1 * l2)).
+  replace (An n * Bn n - l1 * l2) with
+  (An n * Bn n - An n * l2 + (An n * l2 - l1 * l2));
+  [ apply Rabs_triang | ring ].
+  replace (Rabs (An n * Bn n - An n * l2)) with
+  (Rabs (An n) * Rabs (Bn n - l2)).
+  replace (Rabs (An n * l2 - l1 * l2)) with (Rabs l2 * Rabs (An n - l1)).
+  rewrite (double_var eps); apply Rplus_lt_compat.
+  apply Rle_lt_trans with (M * Rabs (Bn n - l2)).
+  do 2 rewrite <- (Rmult_comm (Rabs (Bn n - l2))).
+  apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  apply H4.
+  apply Rmult_lt_reg_l with (/ M).
+  apply Rinv_0_lt_compat; apply H3.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)).
+  apply Rlt_le_trans with (eps / (2 * M)).
+  apply H10.
+  unfold ge in |- *; apply le_trans with N.
+  unfold N in |- *; apply le_max_r.
+  assumption.
+  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  right; ring.
+  discrR.
+  red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3).
+  red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3).
+  apply Rmult_lt_reg_l with (/ Rabs l2).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; apply Rlt_le_trans with (eps / (2 * Rabs l2)).
+  apply H9.
+  unfold ge in |- *; apply le_trans with N.
+  unfold N in |- *; apply le_max_l.
+  assumption.
+  unfold Rdiv in |- *; right; rewrite Rinv_mult_distr.
+  ring.
+  discrR.
+  apply Rabs_no_R0; assumption.
+  apply Rabs_no_R0; assumption.
+  replace (An n * l2 - l1 * l2) with (l2 * (An n - l1));
+  [ symmetry  in |- *; apply Rabs_mult | ring ].
+  replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2));
+  [ symmetry  in |- *; apply Rabs_mult | ring ].
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  assumption.
+  apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+    [ prove_sup0 | apply Rabs_pos_lt; assumption ].
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption
+      | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
+        [ prove_sup0 | assumption ] ].
+  apply existT with l1; assumption.
+Qed.
 
 Lemma tech9 :
- forall Un:nat -> R,
-   Un_growing Un -> forall m n:nat, (m <= n)%nat -> Un m <= Un n.
-intros; unfold Un_growing in H.
-induction  n as [| n Hrecn].
-induction  m as [| m Hrecm].
-right; reflexivity.
-elim (le_Sn_O _ H0).
-cut ((m <= n)%nat \/ m = S n).
-intro; elim H1; intro.
-apply Rle_trans with (Un n).
-apply Hrecn; assumption.
-apply H.
-rewrite H2; right; reflexivity.
-inversion H0.
-right; reflexivity.
-left; assumption.
+  forall Un:nat -> R,
+    Un_growing Un -> forall m n:nat, (m <= n)%nat -> Un m <= Un n.
+Proof.
+  intros; unfold Un_growing in H.
+  induction  n as [| n Hrecn].
+  induction  m as [| m Hrecm].
+  right; reflexivity.
+  elim (le_Sn_O _ H0).
+  cut ((m <= n)%nat \/ m = S n).
+  intro; elim H1; intro.
+  apply Rle_trans with (Un n).
+  apply Hrecn; assumption.
+  apply H.
+  rewrite H2; right; reflexivity.
+  inversion H0.
+  right; reflexivity.
+  left; assumption.
 Qed.
 
 Lemma tech10 :
- forall (Un:nat -> R) (x:R), Un_growing Un -> is_lub (EUn Un) x -> Un_cv Un x.
-intros; cut (bound (EUn Un)).
-intro; assert (H2 := Un_cv_crit _ H H1).
-elim H2; intros.
-case (total_order_T x x0); intro.
-elim s; intro.
-cut (forall n:nat, Un n <= x).
-intro; unfold Un_cv in H3; cut (0 < x0 - x).
-intro; elim (H3 (x0 - x) H5); intros.
-cut (x1 >= x1)%nat.
-intro; assert (H8 := H6 x1 H7).
-unfold R_dist in H8; rewrite Rabs_left1 in H8.
-rewrite Ropp_minus_distr in H8; unfold Rminus in H8.
-assert (H9 := Rplus_lt_reg_r x0 _ _ H8).
-assert (H10 := Ropp_lt_cancel _ _ H9).
-assert (H11 := H4 x1).
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H11)).
-apply Rle_minus; apply Rle_trans with x.
-apply H4.
-left; assumption.
-unfold ge in |- *; apply le_n.
-apply Rgt_minus; assumption.
-intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
-apply H4; unfold EUn in |- *; exists n; reflexivity.
-rewrite b; assumption.
-cut (forall n:nat, Un n <= x0).
-intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
-cut (forall y:R, EUn Un y -> y <= x0).
-intro; assert (H8 := H6 _ H7). 
-elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 r)).
-unfold EUn in |- *; intros; elim H7; intros.
-rewrite H8; apply H4.
-intro; case (Rle_dec (Un n) x0); intro.
-assumption.
-cut (forall n0:nat, (n <= n0)%nat -> x0 < Un n0). 
-intro; unfold Un_cv in H3; cut (0 < Un n - x0).
-intro; elim (H3 (Un n - x0) H5); intros.
-cut (max n x1 >= x1)%nat.
-intro; assert (H8 := H6 (max n x1) H7).
-unfold R_dist in H8.
-rewrite Rabs_right in H8.
-unfold Rminus in H8; do 2 rewrite <- (Rplus_comm (- x0)) in H8.
-assert (H9 := Rplus_lt_reg_r _ _ _ H8).
-cut (Un n <= Un (max n x1)).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H9)).
-apply tech9; [ assumption | apply le_max_l ].
-apply Rge_trans with (Un n - x0).
-unfold Rminus in |- *; apply Rle_ge; do 2 rewrite <- (Rplus_comm (- x0));
- apply Rplus_le_compat_l.
-apply tech9; [ assumption | apply le_max_l ].
-left; assumption.
-unfold ge in |- *; apply le_max_r.
-apply Rplus_lt_reg_r with x0.
-rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm x0);
- rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; 
- apply H4; apply le_n.
-intros; apply Rlt_le_trans with (Un n).
-case (Rlt_le_dec x0 (Un n)); intro.
-assumption.
-elim n0; assumption.
-apply tech9; assumption.
-unfold bound in |- *; exists x; unfold is_lub in H0; elim H0; intros;
- assumption.
+  forall (Un:nat -> R) (x:R), Un_growing Un -> is_lub (EUn Un) x -> Un_cv Un x.
+Proof.
+  intros; cut (bound (EUn Un)).
+  intro; assert (H2 := Un_cv_crit _ H H1).
+  elim H2; intros.
+  case (total_order_T x x0); intro.
+  elim s; intro.
+  cut (forall n:nat, Un n <= x).
+  intro; unfold Un_cv in H3; cut (0 < x0 - x).
+  intro; elim (H3 (x0 - x) H5); intros.
+  cut (x1 >= x1)%nat.
+  intro; assert (H8 := H6 x1 H7).
+  unfold R_dist in H8; rewrite Rabs_left1 in H8.
+  rewrite Ropp_minus_distr in H8; unfold Rminus in H8.
+  assert (H9 := Rplus_lt_reg_r x0 _ _ H8).
+  assert (H10 := Ropp_lt_cancel _ _ H9).
+  assert (H11 := H4 x1).
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H11)).
+  apply Rle_minus; apply Rle_trans with x.
+  apply H4.
+  left; assumption.
+  unfold ge in |- *; apply le_n.
+  apply Rgt_minus; assumption.
+  intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
+  apply H4; unfold EUn in |- *; exists n; reflexivity.
+  rewrite b; assumption.
+  cut (forall n:nat, Un n <= x0).
+  intro; unfold is_lub in H0; unfold is_upper_bound in H0; elim H0; intros.
+  cut (forall y:R, EUn Un y -> y <= x0).
+  intro; assert (H8 := H6 _ H7).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 r)).
+  unfold EUn in |- *; intros; elim H7; intros.
+  rewrite H8; apply H4.
+  intro; case (Rle_dec (Un n) x0); intro.
+  assumption.
+  cut (forall n0:nat, (n <= n0)%nat -> x0 < Un n0).
+  intro; unfold Un_cv in H3; cut (0 < Un n - x0).
+  intro; elim (H3 (Un n - x0) H5); intros.
+  cut (max n x1 >= x1)%nat.
+  intro; assert (H8 := H6 (max n x1) H7).
+  unfold R_dist in H8.
+  rewrite Rabs_right in H8.
+  unfold Rminus in H8; do 2 rewrite <- (Rplus_comm (- x0)) in H8.
+  assert (H9 := Rplus_lt_reg_r _ _ _ H8).
+  cut (Un n <= Un (max n x1)).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H9)).
+  apply tech9; [ assumption | apply le_max_l ].
+  apply Rge_trans with (Un n - x0).
+  unfold Rminus in |- *; apply Rle_ge; do 2 rewrite <- (Rplus_comm (- x0));
+    apply Rplus_le_compat_l.
+  apply tech9; [ assumption | apply le_max_l ].
+  left; assumption.
+  unfold ge in |- *; apply le_max_r.
+  apply Rplus_lt_reg_r with x0.
+  rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm x0);
+    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
+      apply H4; apply le_n.
+  intros; apply Rlt_le_trans with (Un n).
+  case (Rlt_le_dec x0 (Un n)); intro.
+  assumption.
+  elim n0; assumption.
+  apply tech9; assumption.
+  unfold bound in |- *; exists x; unfold is_lub in H0; elim H0; intros;
+    assumption.
 Qed.
 
 Lemma tech13 :
- forall (An:nat -> R) (k:R),
-   0 <= k < 1 ->
-   Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
+  forall (An:nat -> R) (k:R),
+    0 <= k < 1 ->
+    Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
     exists k0 : R,
-     k < k0 < 1 /\
-     (exists N : nat,
+      k < k0 < 1 /\
+      (exists N : nat,
         (forall n:nat, (N <= n)%nat -> Rabs (An (S n) / An n) < k0)).
-intros; exists (k + (1 - k) / 2).
-split.
-split.
-pattern k at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1;
- [ elim H; intros; assumption | ring ].
-apply Rinv_0_lt_compat; prove_sup0.
-apply Rmult_lt_reg_l with 2.
-prove_sup0.
-unfold Rdiv in |- *; rewrite Rmult_1_r; rewrite Rmult_plus_distr_l;
- pattern 2 at 1 in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym; [ idtac | discrR ]; rewrite Rmult_1_r;
- replace (2 * k + (1 - k)) with (1 + k); [ idtac | ring ].
-elim H; intros.
-apply Rplus_lt_compat_l; assumption.
-unfold Un_cv in H0; cut (0 < (1 - k) / 2).
-intro; elim (H0 ((1 - k) / 2) H1); intros.
-exists x; intros.
-assert (H4 := H2 n H3).
-unfold R_dist in H4; rewrite <- Rabs_Rabsolu;
- replace (Rabs (An (S n) / An n)) with (Rabs (An (S n) / An n) - k + k);
- [ idtac | ring ];
- apply Rle_lt_trans with (Rabs (Rabs (An (S n) / An n) - k) + Rabs k).
-apply Rabs_triang.
-rewrite (Rabs_right k).
-apply Rplus_lt_reg_r with (- k); rewrite <- (Rplus_comm k);
- repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; 
- repeat rewrite Rplus_0_l; apply H4.
-apply Rle_ge; elim H; intros; assumption.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; elim H; intros;
- replace (k + (1 - k)) with 1; [ assumption | ring ].
-apply Rinv_0_lt_compat; prove_sup0.
+Proof.
+  intros; exists (k + (1 - k) / 2).
+  split.
+  split.
+  pattern k at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1;
+    [ elim H; intros; assumption | ring ].
+  apply Rinv_0_lt_compat; prove_sup0.
+  apply Rmult_lt_reg_l with 2.
+  prove_sup0.
+  unfold Rdiv in |- *; rewrite Rmult_1_r; rewrite Rmult_plus_distr_l;
+    pattern 2 at 1 in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
+      rewrite <- Rinv_l_sym; [ idtac | discrR ]; rewrite Rmult_1_r;
+        replace (2 * k + (1 - k)) with (1 + k); [ idtac | ring ].
+  elim H; intros.
+  apply Rplus_lt_compat_l; assumption.
+  unfold Un_cv in H0; cut (0 < (1 - k) / 2).
+  intro; elim (H0 ((1 - k) / 2) H1); intros.
+  exists x; intros.
+  assert (H4 := H2 n H3).
+  unfold R_dist in H4; rewrite <- Rabs_Rabsolu;
+    replace (Rabs (An (S n) / An n)) with (Rabs (An (S n) / An n) - k + k);
+    [ idtac | ring ];
+    apply Rle_lt_trans with (Rabs (Rabs (An (S n) / An n) - k) + Rabs k).
+  apply Rabs_triang.
+  rewrite (Rabs_right k).
+  apply Rplus_lt_reg_r with (- k); rewrite <- (Rplus_comm k);
+    repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
+      repeat rewrite Rplus_0_l; apply H4.
+  apply Rle_ge; elim H; intros; assumption.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; elim H; intros;
+    replace (k + (1 - k)) with 1; [ assumption | ring ].
+  apply Rinv_0_lt_compat; prove_sup0.
 Qed.
 
 (**********)
 Lemma growing_ineq :
- forall (Un:nat -> R) (l:R),
-   Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l. 
-intros; case (total_order_T (Un n) l); intro.
-elim s; intro.
-left; assumption.
-right; assumption.
-cut (0 < Un n - l).
-intro; unfold Un_cv in H0; unfold R_dist in H0.
-elim (H0 (Un n - l) H1); intros N1 H2.
-set (N := max n N1).
-cut (Un n - l <= Un N - l).
-intro; cut (Un N - l < Un n - l).
-intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 H4)).
-apply Rle_lt_trans with (Rabs (Un N - l)).
-apply RRle_abs.
-apply H2.
-unfold ge, N in |- *; apply le_max_r.
-unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
- apply Rplus_le_compat_l.
-apply tech9.
-assumption.
-unfold N in |- *; apply le_max_l.
-apply Rplus_lt_reg_r with l.
-rewrite Rplus_0_r.
-replace (l + (Un n - l)) with (Un n); [ assumption | ring ].
+  forall (Un:nat -> R) (l:R),
+    Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l.
+Proof.
+  intros; case (total_order_T (Un n) l); intro.
+  elim s; intro.
+  left; assumption.
+  right; assumption.
+  cut (0 < Un n - l).
+  intro; unfold Un_cv in H0; unfold R_dist in H0.
+  elim (H0 (Un n - l) H1); intros N1 H2.
+  set (N := max n N1).
+  cut (Un n - l <= Un N - l).
+  intro; cut (Un N - l < Un n - l).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 H4)).
+  apply Rle_lt_trans with (Rabs (Un N - l)).
+  apply RRle_abs.
+  apply H2.
+  unfold ge, N in |- *; apply le_max_r.
+  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
+    apply Rplus_le_compat_l.
+  apply tech9.
+  assumption.
+  unfold N in |- *; apply le_max_l.
+  apply Rplus_lt_reg_r with l.
+  rewrite Rplus_0_r.
+  replace (l + (Un n - l)) with (Un n); [ assumption | ring ].
 Qed.
 
-(* Un->l => (-Un) -> (-l) *)
+(** Un->l => (-Un) -> (-l) *)
 Lemma CV_opp :
- forall (An:nat -> R) (l:R), Un_cv An l -> Un_cv (opp_seq An) (- l).
-intros An l.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
-elim (H eps H0); intros.
-exists x; intros.
-unfold opp_seq in |- *; replace (- An n - - l) with (- (An n - l));
- [ rewrite Rabs_Ropp | ring ].
-apply H1; assumption.
+  forall (An:nat -> R) (l:R), Un_cv An l -> Un_cv (opp_seq An) (- l).
+Proof.
+  intros An l.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  elim (H eps H0); intros.
+  exists x; intros.
+  unfold opp_seq in |- *; replace (- An n - - l) with (- (An n - l));
+    [ rewrite Rabs_Ropp | ring ].
+  apply H1; assumption.
 Qed.
 
 (**********)
 Lemma decreasing_ineq :
- forall (Un:nat -> R) (l:R),
-   Un_decreasing Un -> Un_cv Un l -> forall n:nat, l <= Un n.
-intros.
-assert (H1 := decreasing_growing _ H).
-assert (H2 := CV_opp _ _ H0).
-assert (H3 := growing_ineq _ _ H1 H2).
-apply Ropp_le_cancel.
-unfold opp_seq in H3; apply H3.
+  forall (Un:nat -> R) (l:R),
+    Un_decreasing Un -> Un_cv Un l -> forall n:nat, l <= Un n.
+Proof.
+  intros.
+  assert (H1 := decreasing_growing _ H).
+  assert (H2 := CV_opp _ _ H0).
+  assert (H3 := growing_ineq _ _ H1 H2).
+  apply Ropp_le_cancel.
+  unfold opp_seq in H3; apply H3.
 Qed.
 
 (**********)
 Lemma CV_minus :
- forall (An Bn:nat -> R) (l1 l2:R),
-   Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i - Bn i) (l1 - l2). 
-intros. 
-replace (fun i:nat => An i - Bn i) with (fun i:nat => An i + opp_seq Bn i). 
-unfold Rminus in |- *; apply CV_plus. 
-assumption. 
-apply CV_opp; assumption. 
-unfold Rminus, opp_seq in |- *; reflexivity. 
-Qed. 
+  forall (An Bn:nat -> R) (l1 l2:R),
+    Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i - Bn i) (l1 - l2).
+Proof.
+  intros.
+  replace (fun i:nat => An i - Bn i) with (fun i:nat => An i + opp_seq Bn i).
+  unfold Rminus in |- *; apply CV_plus.
+  assumption.
+  apply CV_opp; assumption.
+  unfold Rminus, opp_seq in |- *; reflexivity.
+Qed.
 
-(* Un -> +oo *)
+(** Un -> +oo *)
 Definition cv_infty (Un:nat -> R) : Prop :=
   forall M:R,  exists N : nat, (forall n:nat, (N <= n)%nat -> M < Un n).
 
-(* Un -> +oo => /Un -> O *)
+(** Un -> +oo => /Un -> O *)
 Lemma cv_infty_cv_R0 :
- forall Un:nat -> R,
-   (forall n:nat, Un n <> 0) -> cv_infty Un -> Un_cv (fun n:nat => / Un n) 0.
-unfold cv_infty, Un_cv in |- *; unfold R_dist in |- *; intros.
-elim (H0 (/ eps)); intros N0 H2.
-exists N0; intros.
-unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
- rewrite (Rabs_Rinv _ (H n)).
-apply Rmult_lt_reg_l with (Rabs (Un n)).
-apply Rabs_pos_lt; apply H.
-rewrite <- Rinv_r_sym.
-apply Rmult_lt_reg_l with (/ eps).
-apply Rinv_0_lt_compat; assumption.
-rewrite Rmult_1_r; rewrite (Rmult_comm (/ eps)); rewrite Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; apply Rlt_le_trans with (Un n).
-apply H2; assumption.
-apply RRle_abs.
-red in |- *; intro; rewrite H4 in H1; elim (Rlt_irrefl _ H1).
-apply Rabs_no_R0; apply H.
+  forall Un:nat -> R,
+    (forall n:nat, Un n <> 0) -> cv_infty Un -> Un_cv (fun n:nat => / Un n) 0.
+Proof.
+  unfold cv_infty, Un_cv in |- *; unfold R_dist in |- *; intros.
+  elim (H0 (/ eps)); intros N0 H2.
+  exists N0; intros.
+  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+    rewrite (Rabs_Rinv _ (H n)).
+  apply Rmult_lt_reg_l with (Rabs (Un n)).
+  apply Rabs_pos_lt; apply H.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_lt_reg_l with (/ eps).
+  apply Rinv_0_lt_compat; assumption.
+  rewrite Rmult_1_r; rewrite (Rmult_comm (/ eps)); rewrite Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; apply Rlt_le_trans with (Un n).
+  apply H2; assumption.
+  apply RRle_abs.
+  red in |- *; intro; rewrite H4 in H1; elim (Rlt_irrefl _ H1).
+  apply Rabs_no_R0; apply H.
 Qed.
 
 (**********)
 Lemma decreasing_prop :
- forall (Un:nat -> R) (m n:nat),
-   Un_decreasing Un -> (m <= n)%nat -> Un n <= Un m.
-unfold Un_decreasing in |- *; intros.
-induction  n as [| n Hrecn].
-induction  m as [| m Hrecm].
-right; reflexivity.
-elim (le_Sn_O _ H0).
-cut ((m <= n)%nat \/ m = S n).
-intro; elim H1; intro.
-apply Rle_trans with (Un n).
-apply H.
-apply Hrecn; assumption.
-rewrite H2; right; reflexivity.
-inversion H0; [ right; reflexivity | left; assumption ].
+  forall (Un:nat -> R) (m n:nat),
+    Un_decreasing Un -> (m <= n)%nat -> Un n <= Un m.
+Proof.
+  unfold Un_decreasing in |- *; intros.
+  induction  n as [| n Hrecn].
+  induction  m as [| m Hrecm].
+  right; reflexivity.
+  elim (le_Sn_O _ H0).
+  cut ((m <= n)%nat \/ m = S n).
+  intro; elim H1; intro.
+  apply Rle_trans with (Un n).
+  apply H.
+  apply Hrecn; assumption.
+  rewrite H2; right; reflexivity.
+  inversion H0; [ right; reflexivity | left; assumption ].
 Qed.
 
-(* |x|^n/n! -> 0 *)
+(** |x|^n/n! -> 0 *)
 Lemma cv_speed_pow_fact :
- forall x:R, Un_cv (fun n:nat => x ^ n / INR (fact n)) 0.
-intro;
- cut
-  (Un_cv (fun n:nat => Rabs x ^ n / INR (fact n)) 0 ->
-   Un_cv (fun n:nat => x ^ n / INR (fact n)) 0).
-intro; apply H.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros; case (Req_dec x 0);
- intro.
-exists 1%nat; intros.
-rewrite H1; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
- rewrite Rabs_R0; rewrite pow_ne_zero;
- [ unfold Rdiv in |- *; rewrite Rmult_0_l; rewrite Rabs_R0; assumption
- | red in |- *; intro; rewrite H3 in H2; elim (le_Sn_n _ H2) ].
-assert (H2 := Rabs_pos_lt x H1); set (M := up (Rabs x)); cut (0 <= M)%Z.
-intro; elim (IZN M H3); intros M_nat H4.
-set (Un := fun n:nat => Rabs x ^ (M_nat + n) / INR (fact (M_nat + n))).
-cut (Un_cv Un 0); unfold Un_cv in |- *; unfold R_dist in |- *; intros.
-elim (H5 eps H0); intros N H6.
-exists (M_nat + N)%nat; intros;
- cut (exists p : nat, (p >= N)%nat /\ n = (M_nat + p)%nat).
-intro; elim H8; intros p H9.
-elim H9; intros; rewrite H11; unfold Un in H6; apply H6; assumption.
-exists (n - M_nat)%nat.
-split.
-unfold ge in |- *; apply (fun p n m:nat => plus_le_reg_l n m p) with M_nat;
- rewrite <- le_plus_minus.
-assumption.
-apply le_trans with (M_nat + N)%nat.
-apply le_plus_l.
-assumption.
-apply le_plus_minus; apply le_trans with (M_nat + N)%nat;
- [ apply le_plus_l | assumption ].
-set (Vn := fun n:nat => Rabs x * (Un 0%nat / INR (S n))).
-cut (1 <= M_nat)%nat.
-intro; cut (forall n:nat, 0 < Un n).
-intro; cut (Un_decreasing Un).
-intro; cut (forall n:nat, Un (S n) <= Vn n).
-intro; cut (Un_cv Vn 0).
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
-elim (H10 eps0 H5); intros N1 H11.
-exists (S N1); intros.
-cut (forall n:nat, 0 < Vn n).
-intro; apply Rle_lt_trans with (Rabs (Vn (pred n) - 0)).
-repeat rewrite Rabs_right.
-unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
- replace n with (S (pred n)).
-apply H9.
-inversion H12; simpl in |- *; reflexivity.
-apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
- apply H13.
-apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
- apply H7.
-apply H11; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n;
- [ unfold ge in H12; exact H12 | inversion H12; simpl in |- *; reflexivity ].
-intro; apply Rlt_le_trans with (Un (S n0)); [ apply H7 | apply H9 ].
-cut (cv_infty (fun n:nat => INR (S n))).
-intro; cut (Un_cv (fun n:nat => / INR (S n)) 0).
-unfold Un_cv, R_dist in |- *; intros; unfold Vn in |- *.
-cut (0 < eps1 / (Rabs x * Un 0%nat)).
-intro; elim (H11 _ H13); intros N H14.
-exists N; intros;
- replace (Rabs x * (Un 0%nat / INR (S n)) - 0) with
-  (Rabs x * Un 0%nat * (/ INR (S n) - 0));
- [ idtac | unfold Rdiv in |- *; ring ].
-rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs (Rabs x * Un 0%nat)).
-apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-apply prod_neq_R0.
-apply Rabs_no_R0; assumption.
-assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
- elim (Rlt_irrefl _ H16).
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l.
-replace (/ Rabs (Rabs x * Un 0%nat) * eps1) with (eps1 / (Rabs x * Un 0%nat)).
-apply H14; assumption.
-unfold Rdiv in |- *; rewrite (Rabs_right (Rabs x * Un 0%nat)).
-apply Rmult_comm.
-apply Rle_ge; apply Rmult_le_pos.
-apply Rabs_pos.
-left; apply H7.
-apply Rabs_no_R0.
-apply prod_neq_R0;
- [ apply Rabs_no_R0; assumption
- | assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
-    elim (Rlt_irrefl _ H16) ].
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-assumption.
-apply Rinv_0_lt_compat; apply Rmult_lt_0_compat.
-apply Rabs_pos_lt; assumption.
-apply H7.
-apply (cv_infty_cv_R0 (fun n:nat => INR (S n))).
-intro; apply not_O_INR; discriminate.
-assumption.
-unfold cv_infty in |- *; intro; case (total_order_T M0 0); intro.
-elim s; intro.
-exists 0%nat; intros.
-apply Rlt_trans with 0; [ assumption | apply lt_INR_0; apply lt_O_Sn ].
-exists 0%nat; intros; rewrite b; apply lt_INR_0; apply lt_O_Sn.
-set (M0_z := up M0).
-assert (H10 := archimed M0).
-cut (0 <= M0_z)%Z.
-intro; elim (IZN _ H11); intros M0_nat H12.
-exists M0_nat; intros.
-apply Rlt_le_trans with (IZR M0_z).
-elim H10; intros; assumption.
-rewrite H12; rewrite <- INR_IZR_INZ; apply le_INR.
-apply le_trans with n; [ assumption | apply le_n_Sn ].
-apply le_IZR; left; simpl in |- *; unfold M0_z in |- *;
- apply Rlt_trans with M0; [ assumption | elim H10; intros; assumption ].
-intro; apply Rle_trans with (Rabs x * Un n * / INR (S n)).
-unfold Un in |- *; replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
-rewrite pow_add; replace (Rabs x ^ 1) with (Rabs x);
- [ idtac | simpl in |- *; ring ].
-unfold Rdiv in |- *; rewrite <- (Rmult_comm (Rabs x));
- repeat rewrite Rmult_assoc; repeat apply Rmult_le_compat_l.
-apply Rabs_pos.
-left; apply pow_lt; assumption.
-replace (M_nat + n + 1)%nat with (S (M_nat + n)).
-rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR;
- rewrite Rinv_mult_distr.
-apply Rmult_le_compat_l.
-left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
- intro; assert (H10 := sym_eq H9); elim (fact_neq_0 _ H10).
-left; apply Rinv_lt_contravar.
-apply Rmult_lt_0_compat; apply lt_INR_0; apply lt_O_Sn.
-apply lt_INR; apply lt_n_S.
-pattern n at 1 in |- *; replace n with (0 + n)%nat; [ idtac | reflexivity ].
-apply plus_lt_compat_r.
-apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
-apply INR_fact_neq_0.
-apply not_O_INR; discriminate.
-apply INR_eq; rewrite S_INR; do 3 rewrite plus_INR; reflexivity.
-apply INR_eq; do 3 rewrite plus_INR; do 2 rewrite S_INR; ring.
-unfold Vn in |- *; rewrite Rmult_assoc; unfold Rdiv in |- *;
- rewrite (Rmult_comm (Un 0%nat)); rewrite (Rmult_comm (Un n)).
-repeat apply Rmult_le_compat_l.
-apply Rabs_pos.
-left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
-apply decreasing_prop; [ assumption | apply le_O_n ].
-unfold Un_decreasing in |- *; intro; unfold Un in |- *.
-replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
-rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
- apply Rmult_le_compat_l.
-left; apply pow_lt; assumption.
-replace (Rabs x ^ 1) with (Rabs x); [ idtac | simpl in |- *; ring ].
-replace (M_nat + n + 1)%nat with (S (M_nat + n)).
-apply Rmult_le_reg_l with (INR (fact (S (M_nat + n)))).
-apply lt_INR_0; apply neq_O_lt; red in |- *; intro; assert (H9 := sym_eq H8);
- elim (fact_neq_0 _ H9).
-rewrite (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l.
-rewrite fact_simpl; rewrite mult_INR; rewrite Rmult_assoc;
- rewrite <- Rinv_r_sym.
-rewrite Rmult_1_r; apply Rle_trans with (INR M_nat).
-left; rewrite INR_IZR_INZ.
-rewrite <- H4; assert (H8 := archimed (Rabs x)); elim H8; intros; assumption.
-apply le_INR; apply le_trans with (S M_nat);
- [ apply le_n_Sn | apply le_n_S; apply le_plus_l ].
-apply INR_fact_neq_0.
-apply INR_fact_neq_0.
-apply INR_eq; rewrite S_INR; do 3 rewrite plus_INR; reflexivity.
-apply INR_eq; do 3 rewrite plus_INR; do 2 rewrite S_INR; ring.
-intro; unfold Un in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply pow_lt; assumption.
-apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
- assert (H8 := sym_eq H7); elim (fact_neq_0 _ H8).
-clear Un Vn; apply INR_le; simpl in |- *.
-induction  M_nat as [| M_nat HrecM_nat].
-assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros. 
-rewrite H4 in H7; rewrite <- INR_IZR_INZ in H7.
-simpl in H7; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H2 H7)).
-replace 1 with (INR 1); [ apply le_INR | reflexivity ]; apply le_n_S;
- apply le_O_n.
-apply le_IZR; simpl in |- *; left; apply Rlt_trans with (Rabs x).
-assumption.
-elim (archimed (Rabs x)); intros; assumption.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H eps H0); intros.
-exists x0; intros;
- apply Rle_lt_trans with (Rabs (Rabs x ^ n / INR (fact n) - 0)).
-unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
- rewrite (Rabs_right (Rabs x ^ n / INR (fact n))).
-unfold Rdiv in |- *; rewrite Rabs_mult; rewrite (Rabs_right (/ INR (fact n))).
-rewrite RPow_abs; right; reflexivity.
-apply Rle_ge; left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt;
- red in |- *; intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
-apply Rle_ge; unfold Rdiv in |- *; apply Rmult_le_pos.
-case (Req_dec x 0); intro.
-rewrite H3; rewrite Rabs_R0.
-induction  n as [| n Hrecn];
- [ simpl in |- *; left; apply Rlt_0_1
- | simpl in |- *; rewrite Rmult_0_l; right; reflexivity ].
-left; apply pow_lt; apply Rabs_pos_lt; assumption.
-left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
- intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
-apply H1; assumption.
+  forall x:R, Un_cv (fun n:nat => x ^ n / INR (fact n)) 0.
+Proof.
+  intro;
+    cut
+      (Un_cv (fun n:nat => Rabs x ^ n / INR (fact n)) 0 ->
+        Un_cv (fun n:nat => x ^ n / INR (fact n)) 0).
+  intro; apply H.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros; case (Req_dec x 0);
+    intro.
+  exists 1%nat; intros.
+  rewrite H1; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+    rewrite Rabs_R0; rewrite pow_ne_zero;
+      [ unfold Rdiv in |- *; rewrite Rmult_0_l; rewrite Rabs_R0; assumption
+        | red in |- *; intro; rewrite H3 in H2; elim (le_Sn_n _ H2) ].
+  assert (H2 := Rabs_pos_lt x H1); set (M := up (Rabs x)); cut (0 <= M)%Z.
+  intro; elim (IZN M H3); intros M_nat H4.
+  set (Un := fun n:nat => Rabs x ^ (M_nat + n) / INR (fact (M_nat + n))).
+  cut (Un_cv Un 0); unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  elim (H5 eps H0); intros N H6.
+  exists (M_nat + N)%nat; intros;
+    cut (exists p : nat, (p >= N)%nat /\ n = (M_nat + p)%nat).
+  intro; elim H8; intros p H9.
+  elim H9; intros; rewrite H11; unfold Un in H6; apply H6; assumption.
+  exists (n - M_nat)%nat.
+  split.
+  unfold ge in |- *; apply (fun p n m:nat => plus_le_reg_l n m p) with M_nat;
+    rewrite <- le_plus_minus.
+  assumption.
+  apply le_trans with (M_nat + N)%nat.
+  apply le_plus_l.
+  assumption.
+  apply le_plus_minus; apply le_trans with (M_nat + N)%nat;
+    [ apply le_plus_l | assumption ].
+  set (Vn := fun n:nat => Rabs x * (Un 0%nat / INR (S n))).
+  cut (1 <= M_nat)%nat.
+  intro; cut (forall n:nat, 0 < Un n).
+  intro; cut (Un_decreasing Un).
+  intro; cut (forall n:nat, Un (S n) <= Vn n).
+  intro; cut (Un_cv Vn 0).
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  elim (H10 eps0 H5); intros N1 H11.
+  exists (S N1); intros.
+  cut (forall n:nat, 0 < Vn n).
+  intro; apply Rle_lt_trans with (Rabs (Vn (pred n) - 0)).
+  repeat rewrite Rabs_right.
+  unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
+    replace n with (S (pred n)).
+  apply H9.
+  inversion H12; simpl in |- *; reflexivity.
+  apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
+    apply H13.
+  apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
+    apply H7.
+  apply H11; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n;
+    [ unfold ge in H12; exact H12 | inversion H12; simpl in |- *; reflexivity ].
+  intro; apply Rlt_le_trans with (Un (S n0)); [ apply H7 | apply H9 ].
+  cut (cv_infty (fun n:nat => INR (S n))).
+  intro; cut (Un_cv (fun n:nat => / INR (S n)) 0).
+  unfold Un_cv, R_dist in |- *; intros; unfold Vn in |- *.
+  cut (0 < eps1 / (Rabs x * Un 0%nat)).
+  intro; elim (H11 _ H13); intros N H14.
+  exists N; intros;
+    replace (Rabs x * (Un 0%nat / INR (S n)) - 0) with
+    (Rabs x * Un 0%nat * (/ INR (S n) - 0));
+    [ idtac | unfold Rdiv in |- *; ring ].
+  rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs (Rabs x * Un 0%nat)).
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
+  apply prod_neq_R0.
+  apply Rabs_no_R0; assumption.
+  assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
+    elim (Rlt_irrefl _ H16).
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l.
+  replace (/ Rabs (Rabs x * Un 0%nat) * eps1) with (eps1 / (Rabs x * Un 0%nat)).
+  apply H14; assumption.
+  unfold Rdiv in |- *; rewrite (Rabs_right (Rabs x * Un 0%nat)).
+  apply Rmult_comm.
+  apply Rle_ge; apply Rmult_le_pos.
+  apply Rabs_pos.
+  left; apply H7.
+  apply Rabs_no_R0.
+  apply prod_neq_R0;
+    [ apply Rabs_no_R0; assumption
+      | assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
+        elim (Rlt_irrefl _ H16) ].
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  assumption.
+  apply Rinv_0_lt_compat; apply Rmult_lt_0_compat.
+  apply Rabs_pos_lt; assumption.
+  apply H7.
+  apply (cv_infty_cv_R0 (fun n:nat => INR (S n))).
+  intro; apply not_O_INR; discriminate.
+  assumption.
+  unfold cv_infty in |- *; intro; case (total_order_T M0 0); intro.
+  elim s; intro.
+  exists 0%nat; intros.
+  apply Rlt_trans with 0; [ assumption | apply lt_INR_0; apply lt_O_Sn ].
+  exists 0%nat; intros; rewrite b; apply lt_INR_0; apply lt_O_Sn.
+  set (M0_z := up M0).
+  assert (H10 := archimed M0).
+  cut (0 <= M0_z)%Z.
+  intro; elim (IZN _ H11); intros M0_nat H12.
+  exists M0_nat; intros.
+  apply Rlt_le_trans with (IZR M0_z).
+  elim H10; intros; assumption.
+  rewrite H12; rewrite <- INR_IZR_INZ; apply le_INR.
+  apply le_trans with n; [ assumption | apply le_n_Sn ].
+  apply le_IZR; left; simpl in |- *; unfold M0_z in |- *;
+    apply Rlt_trans with M0; [ assumption | elim H10; intros; assumption ].
+  intro; apply Rle_trans with (Rabs x * Un n * / INR (S n)).
+  unfold Un in |- *; replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
+  rewrite pow_add; replace (Rabs x ^ 1) with (Rabs x);
+    [ idtac | simpl in |- *; ring ].
+  unfold Rdiv in |- *; rewrite <- (Rmult_comm (Rabs x));
+    repeat rewrite Rmult_assoc; repeat apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  left; apply pow_lt; assumption.
+  replace (M_nat + n + 1)%nat with (S (M_nat + n)).
+  rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR;
+    rewrite Rinv_mult_distr.
+  apply Rmult_le_compat_l.
+  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
+    intro; assert (H10 := sym_eq H9); elim (fact_neq_0 _ H10).
+  left; apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat; apply lt_INR_0; apply lt_O_Sn.
+  apply lt_INR; apply lt_n_S.
+  pattern n at 1 in |- *; replace n with (0 + n)%nat; [ idtac | reflexivity ].
+  apply plus_lt_compat_r.
+  apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
+  apply INR_fact_neq_0.
+  apply not_O_INR; discriminate.
+  ring.
+  ring.
+  unfold Vn in |- *; rewrite Rmult_assoc; unfold Rdiv in |- *;
+    rewrite (Rmult_comm (Un 0%nat)); rewrite (Rmult_comm (Un n)).
+  repeat apply Rmult_le_compat_l.
+  apply Rabs_pos.
+  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  apply decreasing_prop; [ assumption | apply le_O_n ].
+  unfold Un_decreasing in |- *; intro; unfold Un in |- *.
+  replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
+  rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
+    apply Rmult_le_compat_l.
+  left; apply pow_lt; assumption.
+  replace (Rabs x ^ 1) with (Rabs x); [ idtac | simpl in |- *; ring ].
+  replace (M_nat + n + 1)%nat with (S (M_nat + n)).
+  apply Rmult_le_reg_l with (INR (fact (S (M_nat + n)))).
+  apply lt_INR_0; apply neq_O_lt; red in |- *; intro; assert (H9 := sym_eq H8);
+    elim (fact_neq_0 _ H9).
+  rewrite (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l.
+  rewrite fact_simpl; rewrite mult_INR; rewrite Rmult_assoc;
+    rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_r; apply Rle_trans with (INR M_nat).
+  left; rewrite INR_IZR_INZ.
+  rewrite <- H4; assert (H8 := archimed (Rabs x)); elim H8; intros; assumption.
+  apply le_INR; omega.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  ring.
+  ring.
+  intro; unfold Un in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply pow_lt; assumption.
+  apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
+    assert (H8 := sym_eq H7); elim (fact_neq_0 _ H8).
+  clear Un Vn; apply INR_le; simpl in |- *.
+  induction  M_nat as [| M_nat HrecM_nat].
+  assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros.
+  rewrite H4 in H7; rewrite <- INR_IZR_INZ in H7.
+  simpl in H7; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H2 H7)).
+  replace 1 with (INR 1); [ apply le_INR | reflexivity ]; apply le_n_S;
+    apply le_O_n.
+  apply le_IZR; simpl in |- *; left; apply Rlt_trans with (Rabs x).
+  assumption.
+  elim (archimed (Rabs x)); intros; assumption.
+  unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H eps H0); intros.
+  exists x0; intros;
+    apply Rle_lt_trans with (Rabs (Rabs x ^ n / INR (fact n) - 0)).
+  unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
+    rewrite (Rabs_right (Rabs x ^ n / INR (fact n))).
+  unfold Rdiv in |- *; rewrite Rabs_mult; rewrite (Rabs_right (/ INR (fact n))).
+  rewrite RPow_abs; right; reflexivity.
+  apply Rle_ge; left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt;
+    red in |- *; intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
+  apply Rle_ge; unfold Rdiv in |- *; apply Rmult_le_pos.
+  case (Req_dec x 0); intro.
+  rewrite H3; rewrite Rabs_R0.
+  induction  n as [| n Hrecn];
+    [ simpl in |- *; left; apply Rlt_0_1
+      | simpl in |- *; rewrite Rmult_0_l; right; reflexivity ].
+  left; apply pow_lt; apply Rabs_pos_lt; assumption.
+  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
+    intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
+  apply H1; assumption.
 Qed.
diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v
index deb98492..bc17cd43 100644
--- a/theories/Reals/SeqSeries.v
+++ b/theories/Reals/SeqSeries.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: SeqSeries.v,v 1.14.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+(*i $Id: SeqSeries.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -25,393 +25,395 @@ Open Local Scope R_scope.
 
 (**********)
 Lemma sum_maj1 :
- forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R) 
-   (N:nat),
-   Un_cv (fun n:nat => SP fn n x) l1 ->
-   Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
-   (forall n:nat, Rabs (fn n x) <= An n) ->
-   Rabs (l1 - SP fn N x) <= l2 - sum_f_R0 An N.
-intros;
- cut
-  (sigT
-     (fun l:R =>
-        Un_cv (fun n:nat => sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) l)).
-intro;
- cut
-  (sigT
-     (fun l:R =>
-        Un_cv (fun n:nat => sum_f_R0 (fun l:nat => An (S N + l)%nat) n) l)).
-intro; elim X; intros l1N H2.
-elim X0; intros l2N H3.
-cut (l1 - SP fn N x = l1N).
-intro; cut (l2 - sum_f_R0 An N = l2N).
-intro; rewrite H4; rewrite H5.
-apply sum_cv_maj with
- (fun l:nat => An (S N + l)%nat) (fun (l:nat) (x:R) => fn (S N + l)%nat x) x.
-unfold SP in |- *; apply H2.
-apply H3.
-intros; apply H1.
-symmetry  in |- *; eapply UL_sequence.
-apply H3.
-unfold Un_cv in H0; unfold Un_cv in |- *; intros; elim (H0 eps H5);
- intros N0 H6.
-unfold R_dist in H6; exists N0; intros.
-unfold R_dist in |- *;
- replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
-  with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
- [ idtac | ring ].
-replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
- (sum_f_R0 An (S (N + n))).
-apply H6; unfold ge in |- *; apply le_trans with n.
-apply H7.
-apply le_trans with (N + n)%nat.
-apply le_plus_r.
-apply le_n_Sn.
-cut (0 <= N)%nat.
-cut (N < S (N + n))%nat.
-intros; assert (H10 := sigma_split An H9 H8).
-unfold sigma in H10.
-do 2 rewrite <- minus_n_O in H10.
-replace (sum_f_R0 An (S (N + n))) with
- (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
-replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
-cut ((S (N + n) - S N)%nat = n).
-intro; rewrite H11 in H10.
-apply H10.
-apply INR_eq; rewrite minus_INR.
-do 2 rewrite S_INR; rewrite plus_INR; ring.
-apply le_n_S; apply le_plus_l.
-apply sum_eq; intros.
-reflexivity.
-apply sum_eq; intros.
-reflexivity.
-apply le_lt_n_Sm; apply le_plus_l.
-apply le_O_n.
-symmetry  in |- *; eapply UL_sequence.
-apply H2.
-unfold Un_cv in H; unfold Un_cv in |- *; intros.
-elim (H eps H4); intros N0 H5.
-unfold R_dist in H5; exists N0; intros.
-unfold R_dist, SP in |- *;
- replace
+  forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R) 
+    (N:nat),
+    Un_cv (fun n:nat => SP fn n x) l1 ->
+    Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
+    (forall n:nat, Rabs (fn n x) <= An n) ->
+    Rabs (l1 - SP fn N x) <= l2 - sum_f_R0 An N.
+Proof.
+  intros;
+    cut
+      (sigT
+        (fun l:R =>
+          Un_cv (fun n:nat => sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) l)).
+  intro X;
+    cut
+      (sigT
+        (fun l:R =>
+          Un_cv (fun n:nat => sum_f_R0 (fun l:nat => An (S N + l)%nat) n) l)).
+  intro X0; elim X; intros l1N H2.
+  elim X0; intros l2N H3.
+  cut (l1 - SP fn N x = l1N).
+  intro; cut (l2 - sum_f_R0 An N = l2N).
+  intro; rewrite H4; rewrite H5.
+  apply sum_cv_maj with
+    (fun l:nat => An (S N + l)%nat) (fun (l:nat) (x:R) => fn (S N + l)%nat x) x.
+  unfold SP in |- *; apply H2.
+  apply H3.
+  intros; apply H1.
+  symmetry  in |- *; eapply UL_sequence.
+  apply H3.
+  unfold Un_cv in H0; unfold Un_cv in |- *; intros; elim (H0 eps H5);
+    intros N0 H6.
+  unfold R_dist in H6; exists N0; intros.
+  unfold R_dist in |- *;
+    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
+    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
+      [ idtac | ring ].
+  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
+  (sum_f_R0 An (S (N + n))).
+  apply H6; unfold ge in |- *; apply le_trans with n.
+  apply H7.
+  apply le_trans with (N + n)%nat.
+  apply le_plus_r.
+  apply le_n_Sn.
+  cut (0 <= N)%nat.
+  cut (N < S (N + n))%nat.
+  intros; assert (H10 := sigma_split An H9 H8).
+  unfold sigma in H10.
+  do 2 rewrite <- minus_n_O in H10.
+  replace (sum_f_R0 An (S (N + n))) with
+  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
+  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
+  cut ((S (N + n) - S N)%nat = n).
+  intro; rewrite H11 in H10.
+  apply H10.
+  apply INR_eq; rewrite minus_INR.
+  do 2 rewrite S_INR; rewrite plus_INR; ring.
+  apply le_n_S; apply le_plus_l.
+  apply sum_eq; intros.
+  reflexivity.
+  apply sum_eq; intros.
+  reflexivity.
+  apply le_lt_n_Sm; apply le_plus_l.
+  apply le_O_n.
+  symmetry  in |- *; eapply UL_sequence.
+  apply H2.
+  unfold Un_cv in H; unfold Un_cv in |- *; intros.
+  elim (H eps H4); intros N0 H5.
+  unfold R_dist in H5; exists N0; intros.
+  unfold R_dist, SP in |- *;
+    replace
+    (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
+      (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
+    (sum_f_R0 (fun k:nat => fn k x) N +
+      sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); 
+    [ idtac | ring ].
+  replace
+  (sum_f_R0 (fun k:nat => fn k x) N +
+    sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
+  (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
+  unfold SP in H5; apply H5; unfold ge in |- *; apply le_trans with n.
+  apply H6.
+  apply le_trans with (N + n)%nat.
+  apply le_plus_r.
+  apply le_n_Sn.
+  cut (0 <= N)%nat.
+  cut (N < S (N + n))%nat.
+  intros; assert (H9 := sigma_split (fun k:nat => fn k x) H8 H7).
+  unfold sigma in H9.
+  do 2 rewrite <- minus_n_O in H9.
+  replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with
+  (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))).
+  replace (sum_f_R0 (fun k:nat => fn k x) N) with
+  (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N).
+  cut ((S (N + n) - S N)%nat = n).
+  intro; rewrite H10 in H9.
+  apply H9.
+  apply INR_eq; rewrite minus_INR.
+  do 2 rewrite S_INR; rewrite plus_INR; ring.
+  apply le_n_S; apply le_plus_l.
+  apply sum_eq; intros.
+  reflexivity.
+  apply sum_eq; intros.
+  reflexivity.
+  apply le_lt_n_Sm.
+  apply le_plus_l.
+  apply le_O_n.
+  apply existT with (l2 - sum_f_R0 An N).
+  unfold Un_cv in H0; unfold Un_cv in |- *; intros.
+  elim (H0 eps H2); intros N0 H3.
+  unfold R_dist in H3; exists N0; intros.
+  unfold R_dist in |- *;
+    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
+    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
+      [ idtac | ring ].
+  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
+  (sum_f_R0 An (S (N + n))).
+  apply H3; unfold ge in |- *; apply le_trans with n.
+  apply H4.
+  apply le_trans with (N + n)%nat.
+  apply le_plus_r.
+  apply le_n_Sn.
+  cut (0 <= N)%nat.
+  cut (N < S (N + n))%nat.
+  intros; assert (H7 := sigma_split An H6 H5).
+  unfold sigma in H7.
+  do 2 rewrite <- minus_n_O in H7.
+  replace (sum_f_R0 An (S (N + n))) with
+  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
+  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
+  cut ((S (N + n) - S N)%nat = n).
+  intro; rewrite H8 in H7.
+  apply H7.
+  apply INR_eq; rewrite minus_INR.
+  do 2 rewrite S_INR; rewrite plus_INR; ring.
+  apply le_n_S; apply le_plus_l.
+  apply sum_eq; intros.
+  reflexivity.
+  apply sum_eq; intros.
+  reflexivity.
+  apply le_lt_n_Sm.
+  apply le_plus_l.
+  apply le_O_n.
+  apply existT with (l1 - SP fn N x).
+  unfold Un_cv in H; unfold Un_cv in |- *; intros.
+  elim (H eps H2); intros N0 H3.
+  unfold R_dist in H3; exists N0; intros.
+  unfold R_dist, SP in |- *.
+  replace
   (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
-   (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
+    (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
+  (sum_f_R0 (fun k:nat => fn k x) N +
+    sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); 
+  [ idtac | ring ].
+  replace
   (sum_f_R0 (fun k:nat => fn k x) N +
-   sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); 
- [ idtac | ring ].
-replace
- (sum_f_R0 (fun k:nat => fn k x) N +
-  sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
- (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
-unfold SP in H5; apply H5; unfold ge in |- *; apply le_trans with n.
-apply H6.
-apply le_trans with (N + n)%nat.
-apply le_plus_r.
-apply le_n_Sn.
-cut (0 <= N)%nat.
-cut (N < S (N + n))%nat.
-intros; assert (H9 := sigma_split (fun k:nat => fn k x) H8 H7).
-unfold sigma in H9.
-do 2 rewrite <- minus_n_O in H9.
-replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with
- (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))).
-replace (sum_f_R0 (fun k:nat => fn k x) N) with
- (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N).
-cut ((S (N + n) - S N)%nat = n).
-intro; rewrite H10 in H9.
-apply H9.
-apply INR_eq; rewrite minus_INR.
-do 2 rewrite S_INR; rewrite plus_INR; ring.
-apply le_n_S; apply le_plus_l.
-apply sum_eq; intros.
-reflexivity.
-apply sum_eq; intros.
-reflexivity.
-apply le_lt_n_Sm.
-apply le_plus_l.
-apply le_O_n.
-apply existT with (l2 - sum_f_R0 An N).
-unfold Un_cv in H0; unfold Un_cv in |- *; intros.
-elim (H0 eps H2); intros N0 H3.
-unfold R_dist in H3; exists N0; intros.
-unfold R_dist in |- *;
- replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
-  with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
- [ idtac | ring ].
-replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
- (sum_f_R0 An (S (N + n))).
-apply H3; unfold ge in |- *; apply le_trans with n.
-apply H4.
-apply le_trans with (N + n)%nat.
-apply le_plus_r.
-apply le_n_Sn.
-cut (0 <= N)%nat.
-cut (N < S (N + n))%nat.
-intros; assert (H7 := sigma_split An H6 H5).
-unfold sigma in H7.
-do 2 rewrite <- minus_n_O in H7.
-replace (sum_f_R0 An (S (N + n))) with
- (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
-replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
-cut ((S (N + n) - S N)%nat = n).
-intro; rewrite H8 in H7.
-apply H7.
-apply INR_eq; rewrite minus_INR.
-do 2 rewrite S_INR; rewrite plus_INR; ring.
-apply le_n_S; apply le_plus_l.
-apply sum_eq; intros.
-reflexivity.
-apply sum_eq; intros.
-reflexivity.
-apply le_lt_n_Sm.
-apply le_plus_l.
-apply le_O_n.
-apply existT with (l1 - SP fn N x).
-unfold Un_cv in H; unfold Un_cv in |- *; intros.
-elim (H eps H2); intros N0 H3.
-unfold R_dist in H3; exists N0; intros.
-unfold R_dist, SP in |- *.
-replace
- (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
-  (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
- (sum_f_R0 (fun k:nat => fn k x) N +
-  sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); 
- [ idtac | ring ].
-replace
- (sum_f_R0 (fun k:nat => fn k x) N +
-  sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
- (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
-unfold SP in H3; apply H3.
-unfold ge in |- *; apply le_trans with n.
-apply H4.
-apply le_trans with (N + n)%nat.
-apply le_plus_r.
-apply le_n_Sn.
-cut (0 <= N)%nat.
-cut (N < S (N + n))%nat.
-intros; assert (H7 := sigma_split (fun k:nat => fn k x) H6 H5).
-unfold sigma in H7.
-do 2 rewrite <- minus_n_O in H7.
-replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with
- (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))).
-replace (sum_f_R0 (fun k:nat => fn k x) N) with
- (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N).
-cut ((S (N + n) - S N)%nat = n).
-intro; rewrite H8 in H7.
-apply H7.
-apply INR_eq; rewrite minus_INR.
-do 2 rewrite S_INR; rewrite plus_INR; ring.
-apply le_n_S; apply le_plus_l.
-apply sum_eq; intros.
-reflexivity.
-apply sum_eq; intros.
-reflexivity.
-apply le_lt_n_Sm.
-apply le_plus_l.
-apply le_O_n.
+    sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
+  (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
+  unfold SP in H3; apply H3.
+  unfold ge in |- *; apply le_trans with n.
+  apply H4.
+  apply le_trans with (N + n)%nat.
+  apply le_plus_r.
+  apply le_n_Sn.
+  cut (0 <= N)%nat.
+  cut (N < S (N + n))%nat.
+  intros; assert (H7 := sigma_split (fun k:nat => fn k x) H6 H5).
+  unfold sigma in H7.
+  do 2 rewrite <- minus_n_O in H7.
+  replace (sum_f_R0 (fun k:nat => fn k x) (S (N + n))) with
+  (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) (S (N + n))).
+  replace (sum_f_R0 (fun k:nat => fn k x) N) with
+  (sum_f_R0 (fun k:nat => fn (0 + k)%nat x) N).
+  cut ((S (N + n) - S N)%nat = n).
+  intro; rewrite H8 in H7.
+  apply H7.
+  apply INR_eq; rewrite minus_INR.
+  do 2 rewrite S_INR; rewrite plus_INR; ring.
+  apply le_n_S; apply le_plus_l.
+  apply sum_eq; intros.
+  reflexivity.
+  apply sum_eq; intros.
+  reflexivity.
+  apply le_lt_n_Sm.
+  apply le_plus_l.
+  apply le_O_n.
 Qed.
 
-(* Comparaison of convergence for series *)
+(** Comparaison of convergence for series *)
 Lemma Rseries_CV_comp :
- forall An Bn:nat -> R,
-   (forall n:nat, 0 <= An n <= Bn n) ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 Bn N) l) ->
-   sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
-intros; apply cv_cauchy_2.
-assert (H0 := cv_cauchy_1 _ X).
-unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
-intros; elim (H0 eps H1); intros.
-exists x; intros.
-cut
- (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
-  R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
-intro; apply Rle_lt_trans with (R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
-assumption.
-apply H2; assumption.
-assert (H5 := lt_eq_lt_dec n m).
-elim H5; intro.
-elim a; intro.
-rewrite (tech2 An n m); [ idtac | assumption ].
-rewrite (tech2 Bn n m); [ idtac | assumption ].
-unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Ropp_plus_distr;
- do 2 rewrite <- Rplus_assoc; do 2 rewrite Rplus_opp_r;
- do 2 rewrite Rplus_0_l; do 2 rewrite Rabs_Ropp; repeat rewrite Rabs_right.
-apply sum_Rle; intros.
-elim (H (S n + n0)%nat); intros.
-apply H8.
-apply Rle_ge; apply cond_pos_sum; intro.
-elim (H (S n + n0)%nat); intros.
-apply Rle_trans with (An (S n + n0)%nat); assumption.
-apply Rle_ge; apply cond_pos_sum; intro.
-elim (H (S n + n0)%nat); intros; assumption.
-rewrite b; unfold R_dist in |- *; unfold Rminus in |- *;
- do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right; 
- reflexivity.
-rewrite (tech2 An m n); [ idtac | assumption ].
-rewrite (tech2 Bn m n); [ idtac | assumption ].
-unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Rplus_assoc;
- rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m));
- do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l; 
- do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right.
-apply sum_Rle; intros.
-elim (H (S m + n0)%nat); intros; apply H8.
-apply Rle_ge; apply cond_pos_sum; intro.
-elim (H (S m + n0)%nat); intros.
-apply Rle_trans with (An (S m + n0)%nat); assumption.
-apply Rle_ge.
-apply cond_pos_sum; intro.
-elim (H (S m + n0)%nat); intros; assumption.
+  forall An Bn:nat -> R,
+    (forall n:nat, 0 <= An n <= Bn n) ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 Bn N) l) ->
+    sigT (fun l:R => Un_cv (fun N:nat => sum_f_R0 An N) l).
+Proof.
+  intros An Bn H X; apply cv_cauchy_2.
+  assert (H0 := cv_cauchy_1 _ X).
+  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+  intros; elim (H0 eps H1); intros.
+  exists x; intros.
+  cut
+    (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
+      R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
+  intro; apply Rle_lt_trans with (R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
+  assumption.
+  apply H2; assumption.
+  assert (H5 := lt_eq_lt_dec n m).
+  elim H5; intro.
+  elim a; intro.
+  rewrite (tech2 An n m); [ idtac | assumption ].
+  rewrite (tech2 Bn n m); [ idtac | assumption ].
+  unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Ropp_plus_distr;
+    do 2 rewrite <- Rplus_assoc; do 2 rewrite Rplus_opp_r;
+      do 2 rewrite Rplus_0_l; do 2 rewrite Rabs_Ropp; repeat rewrite Rabs_right.
+  apply sum_Rle; intros.
+  elim (H (S n + n0)%nat); intros.
+  apply H8.
+  apply Rle_ge; apply cond_pos_sum; intro.
+  elim (H (S n + n0)%nat); intros.
+  apply Rle_trans with (An (S n + n0)%nat); assumption.
+  apply Rle_ge; apply cond_pos_sum; intro.
+  elim (H (S n + n0)%nat); intros; assumption.
+  rewrite b; unfold R_dist in |- *; unfold Rminus in |- *;
+    do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right; 
+      reflexivity.
+  rewrite (tech2 An m n); [ idtac | assumption ].
+  rewrite (tech2 Bn m n); [ idtac | assumption ].
+  unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Rplus_assoc;
+    rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m));
+      do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l; 
+        do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right.
+  apply sum_Rle; intros.
+  elim (H (S m + n0)%nat); intros; apply H8.
+  apply Rle_ge; apply cond_pos_sum; intro.
+  elim (H (S m + n0)%nat); intros.
+  apply Rle_trans with (An (S m + n0)%nat); assumption.
+  apply Rle_ge.
+  apply cond_pos_sum; intro.
+  elim (H (S m + n0)%nat); intros; assumption.
 Qed.
 
-(* Cesaro's theorem *)
+(** Cesaro's theorem *)
 Lemma Cesaro :
- forall (An Bn:nat -> R) (l:R),
-   Un_cv Bn l ->
-   (forall n:nat, 0 < An n) ->
-   cv_infty (fun n:nat => sum_f_R0 An n) ->
-   Un_cv (fun n:nat => sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n)
-     l.
+  forall (An Bn:nat -> R) (l:R),
+    Un_cv Bn l ->
+    (forall n:nat, 0 < An n) ->
+    cv_infty (fun n:nat => sum_f_R0 An n) ->
+    Un_cv (fun n:nat => sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n)
+    l.
 Proof with trivial.
-unfold Un_cv in |- *; intros; assert (H3 : forall n:nat, 0 < sum_f_R0 An n)...
-intro; apply tech1...
-assert (H4 : forall n:nat, sum_f_R0 An n <> 0)...
-intro; red in |- *; intro; assert (H5 := H3 n); rewrite H4 in H5;
- elim (Rlt_irrefl _ H5)...
-assert (H5 := cv_infty_cv_R0 _ H4 H1); assert (H6 : 0 < eps / 2)...
-unfold Rdiv in |- *; apply Rmult_lt_0_compat...
-apply Rinv_0_lt_compat; prove_sup...
-elim (H _ H6); clear H; intros N1 H;
- set (C := Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1));
- assert
-  (H7 :
-    exists N : nat,
-     (forall n:nat, (N <= n)%nat -> C / sum_f_R0 An n < eps / 2))...
-case (Req_dec C 0); intro...
-exists 0%nat; intros...
-rewrite H7; unfold Rdiv in |- *; rewrite Rmult_0_l; apply Rmult_lt_0_compat...
-apply Rinv_0_lt_compat; prove_sup...
-assert (H8 : 0 < eps / (2 * Rabs C))...
-unfold Rdiv in |- *; apply Rmult_lt_0_compat...
-apply Rinv_0_lt_compat; apply Rmult_lt_0_compat...
-prove_sup...
-apply Rabs_pos_lt...
-elim (H5 _ H8); intros; exists x; intros; assert (H11 := H9 _ H10);
- unfold R_dist in H11; unfold Rminus in H11; rewrite Ropp_0 in H11;
- rewrite Rplus_0_r in H11...
-apply Rle_lt_trans with (Rabs (C / sum_f_R0 An n))...
-apply RRle_abs...
-unfold Rdiv in |- *; rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs C)...
-apply Rinv_0_lt_compat; apply Rabs_pos_lt...
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
-rewrite Rmult_1_l; replace (/ Rabs C * (eps * / 2)) with (eps / (2 * Rabs C))...
-unfold Rdiv in |- *; rewrite Rinv_mult_distr...
-ring...
-discrR...
-apply Rabs_no_R0...
-apply Rabs_no_R0...
-elim H7; clear H7; intros N2 H7; set (N := max N1 N2); exists (S N); intros;
- unfold R_dist in |- *;
- replace (sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n - l) with
-  (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n / sum_f_R0 An n)...
-assert (H9 : (N1 < n)%nat)...
-apply lt_le_trans with (S N)...
-apply le_lt_n_Sm; unfold N in |- *; apply le_max_l...
-rewrite (tech2 (fun k:nat => An k * (Bn k - l)) _ _ H9); unfold Rdiv in |- *;
- rewrite Rmult_plus_distr_r;
- apply Rle_lt_trans with
-  (Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1 / sum_f_R0 An n) +
-   Rabs
-     (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))
-        (n - S N1) / sum_f_R0 An n))...
-apply Rabs_triang...
-rewrite (double_var eps); apply Rplus_lt_compat...
-unfold Rdiv in |- *; rewrite Rabs_mult; fold C in |- *; rewrite Rabs_right...
-apply (H7 n); apply le_trans with (S N)...
-apply le_trans with N; [ unfold N in |- *; apply le_max_r | apply le_n_Sn ]...
-apply Rle_ge; left; apply Rinv_0_lt_compat...
+  unfold Un_cv in |- *; intros; assert (H3 : forall n:nat, 0 < sum_f_R0 An n)...
+  intro; apply tech1...
+  assert (H4 : forall n:nat, sum_f_R0 An n <> 0)...
+  intro; red in |- *; intro; assert (H5 := H3 n); rewrite H4 in H5;
+    elim (Rlt_irrefl _ H5)...
+  assert (H5 := cv_infty_cv_R0 _ H4 H1); assert (H6 : 0 < eps / 2)...
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat...
+  apply Rinv_0_lt_compat; prove_sup...
+  elim (H _ H6); clear H; intros N1 H;
+    set (C := Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1));
+      assert
+        (H7 :
+          exists N : nat,
+            (forall n:nat, (N <= n)%nat -> C / sum_f_R0 An n < eps / 2))...
+  case (Req_dec C 0); intro...
+  exists 0%nat; intros...
+  rewrite H7; unfold Rdiv in |- *; rewrite Rmult_0_l; apply Rmult_lt_0_compat...
+  apply Rinv_0_lt_compat; prove_sup...
+  assert (H8 : 0 < eps / (2 * Rabs C))...
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat...
+  apply Rinv_0_lt_compat; apply Rmult_lt_0_compat...
+  prove_sup...
+  apply Rabs_pos_lt...
+  elim (H5 _ H8); intros; exists x; intros; assert (H11 := H9 _ H10);
+    unfold R_dist in H11; unfold Rminus in H11; rewrite Ropp_0 in H11;
+      rewrite Rplus_0_r in H11...
+  apply Rle_lt_trans with (Rabs (C / sum_f_R0 An n))...
+  apply RRle_abs...
+  unfold Rdiv in |- *; rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs C)...
+  apply Rinv_0_lt_compat; apply Rabs_pos_lt...
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
+  rewrite Rmult_1_l; replace (/ Rabs C * (eps * / 2)) with (eps / (2 * Rabs C))...
+  unfold Rdiv in |- *; rewrite Rinv_mult_distr...
+  ring...
+  discrR...
+  apply Rabs_no_R0...
+  apply Rabs_no_R0...
+  elim H7; clear H7; intros N2 H7; set (N := max N1 N2); exists (S N); intros;
+    unfold R_dist in |- *;
+      replace (sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n - l) with
+      (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n / sum_f_R0 An n)...
+  assert (H9 : (N1 < n)%nat)...
+  apply lt_le_trans with (S N)...
+  apply le_lt_n_Sm; unfold N in |- *; apply le_max_l...
+  rewrite (tech2 (fun k:nat => An k * (Bn k - l)) _ _ H9); unfold Rdiv in |- *;
+    rewrite Rmult_plus_distr_r;
+      apply Rle_lt_trans with
+        (Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1 / sum_f_R0 An n) +
+          Rabs
+          (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))
+            (n - S N1) / sum_f_R0 An n))...
+  apply Rabs_triang...
+  rewrite (double_var eps); apply Rplus_lt_compat...
+  unfold Rdiv in |- *; rewrite Rabs_mult; fold C in |- *; rewrite Rabs_right...
+  apply (H7 n); apply le_trans with (S N)...
+  apply le_trans with N; [ unfold N in |- *; apply le_max_r | apply le_n_Sn ]...
+  apply Rle_ge; left; apply Rinv_0_lt_compat...
 
-unfold R_dist in H; unfold Rdiv in |- *; rewrite Rabs_mult;
- rewrite (Rabs_right (/ sum_f_R0 An n))...
-apply Rle_lt_trans with
- (sum_f_R0 (fun i:nat => Rabs (An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l)))
-    (n - S N1) * / sum_f_R0 An n)...
-do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
-left; apply Rinv_0_lt_compat...
-apply
- (Rsum_abs (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))
-    (n - S N1))...
-apply Rle_lt_trans with
- (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (eps / 2)) (n - S N1) *
-  / sum_f_R0 An n)...
-do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
-left; apply Rinv_0_lt_compat...
-apply sum_Rle; intros; rewrite Rabs_mult;
- pattern (An (S N1 + n0)%nat) at 2 in |- *;
- rewrite <- (Rabs_right (An (S N1 + n0)%nat))...
-apply Rmult_le_compat_l...
-apply Rabs_pos...
-left; apply H; unfold ge in |- *; apply le_trans with (S N1);
- [ apply le_n_Sn | apply le_plus_l ]...
-apply Rle_ge; left...
-rewrite <- (scal_sum (fun i:nat => An (S N1 + i)%nat) (n - S N1) (eps / 2));
- unfold Rdiv in |- *; repeat rewrite Rmult_assoc; apply Rmult_lt_compat_l...
-pattern (/ 2) at 2 in |- *; rewrite <- Rmult_1_r; apply Rmult_lt_compat_l...
-apply Rinv_0_lt_compat; prove_sup...
-rewrite Rmult_comm; apply Rmult_lt_reg_l with (sum_f_R0 An n)...
-rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
-rewrite Rmult_1_l; rewrite Rmult_1_r; rewrite (tech2 An N1 n)...
-rewrite Rplus_comm;
- pattern (sum_f_R0 (fun i:nat => An (S N1 + i)%nat) (n - S N1)) at 1 in |- *;
- rewrite <- Rplus_0_r; apply Rplus_lt_compat_l...
-apply Rle_ge; left; apply Rinv_0_lt_compat...
-replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with
- (sum_f_R0 (fun k:nat => An k * Bn k) n +
-  sum_f_R0 (fun k:nat => An k * - l) n)...
-rewrite <- (scal_sum An n (- l)); field...
-rewrite <- plus_sum; apply sum_eq; intros; ring...
+  unfold R_dist in H; unfold Rdiv in |- *; rewrite Rabs_mult;
+    rewrite (Rabs_right (/ sum_f_R0 An n))...
+  apply Rle_lt_trans with
+    (sum_f_R0 (fun i:nat => Rabs (An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l)))
+      (n - S N1) * / sum_f_R0 An n)...
+  do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
+  left; apply Rinv_0_lt_compat...
+  apply
+    (Rsum_abs (fun i:nat => An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l))
+      (n - S N1))...
+  apply Rle_lt_trans with
+    (sum_f_R0 (fun i:nat => An (S N1 + i)%nat * (eps / 2)) (n - S N1) *
+      / sum_f_R0 An n)...
+  do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
+  left; apply Rinv_0_lt_compat...
+  apply sum_Rle; intros; rewrite Rabs_mult;
+    pattern (An (S N1 + n0)%nat) at 2 in |- *;
+      rewrite <- (Rabs_right (An (S N1 + n0)%nat))...
+  apply Rmult_le_compat_l...
+  apply Rabs_pos...
+  left; apply H; unfold ge in |- *; apply le_trans with (S N1);
+    [ apply le_n_Sn | apply le_plus_l ]...
+  apply Rle_ge; left...
+  rewrite <- (scal_sum (fun i:nat => An (S N1 + i)%nat) (n - S N1) (eps / 2));
+    unfold Rdiv in |- *; repeat rewrite Rmult_assoc; apply Rmult_lt_compat_l...
+  pattern (/ 2) at 2 in |- *; rewrite <- Rmult_1_r; apply Rmult_lt_compat_l...
+  apply Rinv_0_lt_compat; prove_sup...
+  rewrite Rmult_comm; apply Rmult_lt_reg_l with (sum_f_R0 An n)...
+  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
+  rewrite Rmult_1_l; rewrite Rmult_1_r; rewrite (tech2 An N1 n)...
+  rewrite Rplus_comm;
+    pattern (sum_f_R0 (fun i:nat => An (S N1 + i)%nat) (n - S N1)) at 1 in |- *;
+      rewrite <- Rplus_0_r; apply Rplus_lt_compat_l...
+  apply Rle_ge; left; apply Rinv_0_lt_compat...
+  replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with
+  (sum_f_R0 (fun k:nat => An k * Bn k) n +
+    sum_f_R0 (fun k:nat => An k * - l) n)...
+  rewrite <- (scal_sum An n (- l)); field...
+  rewrite <- plus_sum; apply sum_eq; intros; ring...
 Qed.
 
 Lemma Cesaro_1 :
- forall (An:nat -> R) (l:R),
-   Un_cv An l -> Un_cv (fun n:nat => sum_f_R0 An (pred n) / INR n) l.
+  forall (An:nat -> R) (l:R),
+    Un_cv An l -> Un_cv (fun n:nat => sum_f_R0 An (pred n) / INR n) l.
 Proof with trivial.
-intros Bn l H; set (An := fun _:nat => 1)...
-assert (H0 : forall n:nat, 0 < An n)...
-intro; unfold An in |- *; apply Rlt_0_1...
-assert (H1 : forall n:nat, 0 < sum_f_R0 An n)...
-intro; apply tech1...
-assert (H2 : cv_infty (fun n:nat => sum_f_R0 An n))...
-unfold cv_infty in |- *; intro; case (Rle_dec M 0); intro...
-exists 0%nat; intros; apply Rle_lt_trans with 0...
-assert (H2 : 0 < M)...
-auto with real...
-clear n; set (m := up M); elim (archimed M); intros;
- assert (H5 : (0 <= m)%Z)...
-apply le_IZR; unfold m in |- *; simpl in |- *; left; apply Rlt_trans with M...
-elim (IZN _ H5); intros; exists x; intros; unfold An in |- *; rewrite sum_cte;
- rewrite Rmult_1_l; apply Rlt_trans with (IZR (up M))...
-apply Rle_lt_trans with (INR x)...
-rewrite INR_IZR_INZ; fold m in |- *; rewrite <- H6; right...
-apply lt_INR; apply le_lt_n_Sm...
-assert (H3 := Cesaro _ _ _ H H0 H2)...
-unfold Un_cv in |- *; unfold Un_cv in H3; intros; elim (H3 _ H4); intros;
- exists (S x); intros; unfold R_dist in |- *; unfold R_dist in H5;
- apply Rle_lt_trans with
-  (Rabs
-     (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l))...
-right;
- replace (sum_f_R0 Bn (pred n) / INR n - l) with
-  (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l)...
-unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
- apply Rplus_eq_compat_l...
-unfold An in |- *;
- replace (sum_f_R0 (fun k:nat => 1 * Bn k) (pred n)) with
-  (sum_f_R0 Bn (pred n))...
-rewrite sum_cte; rewrite Rmult_1_l; replace (S (pred n)) with n...
-apply S_pred with 0%nat; apply lt_le_trans with (S x)...
-apply lt_O_Sn...
-apply sum_eq; intros; ring...
-apply H5; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n...
-apply S_pred with 0%nat; apply lt_le_trans with (S x)...
-apply lt_O_Sn...
+  intros Bn l H; set (An := fun _:nat => 1)...
+  assert (H0 : forall n:nat, 0 < An n)...
+  intro; unfold An in |- *; apply Rlt_0_1...
+  assert (H1 : forall n:nat, 0 < sum_f_R0 An n)...
+  intro; apply tech1...
+  assert (H2 : cv_infty (fun n:nat => sum_f_R0 An n))...
+  unfold cv_infty in |- *; intro; case (Rle_dec M 0); intro...
+  exists 0%nat; intros; apply Rle_lt_trans with 0...
+  assert (H2 : 0 < M)...
+  auto with real...
+  clear n; set (m := up M); elim (archimed M); intros;
+    assert (H5 : (0 <= m)%Z)...
+  apply le_IZR; unfold m in |- *; simpl in |- *; left; apply Rlt_trans with M...
+  elim (IZN _ H5); intros; exists x; intros; unfold An in |- *; rewrite sum_cte;
+    rewrite Rmult_1_l; apply Rlt_trans with (IZR (up M))...
+  apply Rle_lt_trans with (INR x)...
+  rewrite INR_IZR_INZ; fold m in |- *; rewrite <- H6; right...
+  apply lt_INR; apply le_lt_n_Sm...
+  assert (H3 := Cesaro _ _ _ H H0 H2)...
+  unfold Un_cv in |- *; unfold Un_cv in H3; intros; elim (H3 _ H4); intros;
+    exists (S x); intros; unfold R_dist in |- *; unfold R_dist in H5;
+      apply Rle_lt_trans with
+        (Rabs
+          (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l))...
+  right;
+    replace (sum_f_R0 Bn (pred n) / INR n - l) with
+    (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l)...
+  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
+    apply Rplus_eq_compat_l...
+  unfold An in |- *;
+    replace (sum_f_R0 (fun k:nat => 1 * Bn k) (pred n)) with
+    (sum_f_R0 Bn (pred n))...
+  rewrite sum_cte; rewrite Rmult_1_l; replace (S (pred n)) with n...
+  apply S_pred with 0%nat; apply lt_le_trans with (S x)...
+  apply lt_O_Sn...
+  apply sum_eq; intros; ring...
+  apply H5; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n...
+  apply S_pred with 0%nat; apply lt_le_trans with (S x)...
+  apply lt_O_Sn...
 Qed.
diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v
index b4026e67..08dbd67b 100644
--- a/theories/Reals/SplitAbsolu.v
+++ b/theories/Reals/SplitAbsolu.v
@@ -6,20 +6,20 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i      $Id: SplitAbsolu.v,v 1.6.2.1 2004/07/16 19:31:15 herbelin Exp $       i*)
+(*i      $Id: SplitAbsolu.v 9245 2006-10-17 12:53:34Z notin $       i*)
 
 Require Import Rbasic_fun.
 
 Ltac split_case_Rabs :=
   match goal with
-  |  |- context [(Rcase_abs ?X1)] =>
+    |  |- context [(Rcase_abs ?X1)] =>
       case (Rcase_abs X1); try split_case_Rabs
   end.
 
 
 Ltac split_Rabs :=
   match goal with
-  | id:context [(Rabs _)] |- _ => generalize id; clear id; try split_Rabs
-  |  |- context [(Rabs ?X1)] =>
+    | id:context [(Rabs _)] |- _ => generalize id; clear id; try split_Rabs
+    |  |- context [(Rabs ?X1)] =>
       unfold Rabs in |- *; try split_case_Rabs; intros
-  end.
\ No newline at end of file
+  end.
diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v
index 19df2afa..4f3fab24 100644
--- a/theories/Reals/SplitRmult.v
+++ b/theories/Reals/SplitRmult.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: SplitRmult.v,v 1.7.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+(*i $Id: SplitRmult.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*)
 
@@ -15,6 +15,6 @@ Require Import Rbase.
 
 Ltac split_Rmult :=
   match goal with
-  |  |- ((?X1 * ?X2)%R <> 0%R) =>
+    |  |- ((?X1 * ?X2)%R <> 0%R) =>
       apply Rmult_integral_contrapositive; split; try split_Rmult
   end.
diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v
index b11e51f0..ff0a72e8 100644
--- a/theories/Reals/Sqrt_reg.v
+++ b/theories/Reals/Sqrt_reg.v
@@ -5,8 +5,8 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
- 
-(*i $Id: Sqrt_reg.v,v 1.9.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+(*i $Id: Sqrt_reg.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rbase.
 Require Import Rfunctions.
@@ -15,337 +15,344 @@ Require Import R_sqrt. Open Local Scope R_scope.
 
 (**********)
 Lemma sqrt_var_maj :
- forall h:R, Rabs h <= 1 -> Rabs (sqrt (1 + h) - 1) <= Rabs h.
-intros; cut (0 <= 1 + h).
-intro; apply Rle_trans with (Rabs (sqrt (Rsqr (1 + h)) - 1)).
-case (total_order_T h 0); intro.
-elim s; intro.
-repeat rewrite Rabs_left.
-unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1)).
-do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive;
- apply Rplus_le_compat_l.
-apply Ropp_le_contravar; apply sqrt_le_1.
-apply Rle_0_sqr.
-apply H0.
-pattern (1 + h) at 2 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
- apply Rmult_le_compat_l.
-apply H0.
-pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
- assumption.
-apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
- unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
- rewrite Rplus_0_r.
-pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
-apply Rle_0_sqr.
-left; apply Rlt_0_1.
-pattern 1 at 2 in |- *; rewrite <- Rsqr_1; apply Rsqr_incrst_1.
-pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- assumption.
-apply H0.
-left; apply Rlt_0_1.
-apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
- unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
- rewrite Rplus_0_r.
-pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
-apply H0.
-left; apply Rlt_0_1.
-pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- assumption.
-rewrite b; rewrite Rplus_0_r; rewrite Rsqr_1; rewrite sqrt_1; right;
- reflexivity.
-repeat rewrite Rabs_right.
-unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1));
- apply Rplus_le_compat_l.
-apply sqrt_le_1.
-apply H0.
-apply Rle_0_sqr.
-pattern (1 + h) at 1 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
- apply Rmult_le_compat_l.
-apply H0.
-pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
- assumption.
-apply Rle_ge; apply Rplus_le_reg_l with 1.
-rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
- rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
-pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_le_1.
-left; apply Rlt_0_1.
-apply Rle_0_sqr.
-pattern 1 at 1 in |- *; rewrite <- Rsqr_1; apply Rsqr_incr_1.
-pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
- assumption.
-left; apply Rlt_0_1.
-apply H0.
-apply Rle_ge; left; apply Rplus_lt_reg_r with 1.
-rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
- rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
-pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
-left; apply Rlt_0_1.
-apply H0.
-pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
- assumption.
-rewrite sqrt_Rsqr.
-replace (1 + h - 1) with h; [ right; reflexivity | ring ].
-apply H0.
-case (total_order_T h 0); intro.
-elim s; intro.
-rewrite (Rabs_left h a) in H.
-apply Rplus_le_reg_l with (- h).
-rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
- rewrite Rplus_opp_r; rewrite Rplus_0_r; exact H.
-left; rewrite b; rewrite Rplus_0_r; apply Rlt_0_1.
-left; apply Rplus_lt_0_compat.
-apply Rlt_0_1.
-apply r.
+  forall h:R, Rabs h <= 1 -> Rabs (sqrt (1 + h) - 1) <= Rabs h.
+Proof.
+  intros; cut (0 <= 1 + h).
+  intro; apply Rle_trans with (Rabs (sqrt (Rsqr (1 + h)) - 1)).
+  case (total_order_T h 0); intro.
+  elim s; intro.
+  repeat rewrite Rabs_left.
+  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1)).
+  do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+    apply Rplus_le_compat_l.
+  apply Ropp_le_contravar; apply sqrt_le_1.
+  apply Rle_0_sqr.
+  apply H0.
+  pattern (1 + h) at 2 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
+    apply Rmult_le_compat_l.
+  apply H0.
+  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+    assumption.
+  apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
+    unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+      rewrite Rplus_0_r.
+  pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+  apply Rle_0_sqr.
+  left; apply Rlt_0_1.
+  pattern 1 at 2 in |- *; rewrite <- Rsqr_1; apply Rsqr_incrst_1.
+  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    assumption.
+  apply H0.
+  left; apply Rlt_0_1.
+  apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
+    unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+      rewrite Rplus_0_r.
+  pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+  apply H0.
+  left; apply Rlt_0_1.
+  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    assumption.
+  rewrite b; rewrite Rplus_0_r; rewrite Rsqr_1; rewrite sqrt_1; right;
+    reflexivity.
+  repeat rewrite Rabs_right.
+  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1));
+    apply Rplus_le_compat_l.
+  apply sqrt_le_1.
+  apply H0.
+  apply Rle_0_sqr.
+  pattern (1 + h) at 1 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
+    apply Rmult_le_compat_l.
+  apply H0.
+  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+    assumption.
+  apply Rle_ge; apply Rplus_le_reg_l with 1.
+  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
+  pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_le_1.
+  left; apply Rlt_0_1.
+  apply Rle_0_sqr.
+  pattern 1 at 1 in |- *; rewrite <- Rsqr_1; apply Rsqr_incr_1.
+  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+    assumption.
+  left; apply Rlt_0_1.
+  apply H0.
+  apply Rle_ge; left; apply Rplus_lt_reg_r with 1.
+  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
+  pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+  left; apply Rlt_0_1.
+  apply H0.
+  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    assumption.
+  rewrite sqrt_Rsqr.
+  replace (1 + h - 1) with h; [ right; reflexivity | ring ].
+  apply H0.
+  case (total_order_T h 0); intro.
+  elim s; intro.
+  rewrite (Rabs_left h a) in H.
+  apply Rplus_le_reg_l with (- h).
+  rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_r; exact H.
+  left; rewrite b; rewrite Rplus_0_r; apply Rlt_0_1.
+  left; apply Rplus_lt_0_compat.
+  apply Rlt_0_1.
+  apply r.
 Qed.
 
-(* sqrt is continuous in 1 *)
+(** sqrt is continuous in 1 *)
 Lemma sqrt_continuity_pt_R1 : continuity_pt sqrt 1.
-unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros.
-set (alpha := Rmin eps 1).
-exists alpha; intros.
-split.
-unfold alpha in |- *; unfold Rmin in |- *; case (Rle_dec eps 1); intro.
-assumption.
-apply Rlt_0_1.
-intros; elim H0; intros.
-rewrite sqrt_1; replace x with (1 + (x - 1)); [ idtac | ring ];
- apply Rle_lt_trans with (Rabs (x - 1)).
-apply sqrt_var_maj.
-apply Rle_trans with alpha.
-left; apply H2.
-unfold alpha in |- *; apply Rmin_r.
-apply Rlt_le_trans with alpha;
- [ apply H2 | unfold alpha in |- *; apply Rmin_l ].
+Proof.
+  unfold continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+        intros.
+  set (alpha := Rmin eps 1).
+  exists alpha; intros.
+  split.
+  unfold alpha in |- *; unfold Rmin in |- *; case (Rle_dec eps 1); intro.
+  assumption.
+  apply Rlt_0_1.
+  intros; elim H0; intros.
+  rewrite sqrt_1; replace x with (1 + (x - 1)); [ idtac | ring ];
+    apply Rle_lt_trans with (Rabs (x - 1)).
+  apply sqrt_var_maj.
+  apply Rle_trans with alpha.
+  left; apply H2.
+  unfold alpha in |- *; apply Rmin_r.
+  apply Rlt_le_trans with alpha;
+    [ apply H2 | unfold alpha in |- *; apply Rmin_l ].
 Qed.
 
-(* sqrt is continuous forall x>0 *)
+(** sqrt is continuous forall x>0 *)
 Lemma sqrt_continuity_pt : forall x:R, 0 < x -> continuity_pt sqrt x.
-intros; generalize sqrt_continuity_pt_R1.
-unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
- intros.
-cut (0 < eps / sqrt x).
-intro; elim (H0 _ H2); intros alp_1 H3.
-elim H3; intros.
-set (alpha := alp_1 * x).
-exists (Rmin alpha x); intros.
-split.
-change (0 < Rmin alpha x) in |- *; unfold Rmin in |- *;
- case (Rle_dec alpha x); intro.
-unfold alpha in |- *; apply Rmult_lt_0_compat; assumption.
-apply H.
-intros; replace x0 with (x + (x0 - x)); [ idtac | ring ];
- replace (sqrt (x + (x0 - x)) - sqrt x) with
-  (sqrt x * (sqrt (1 + (x0 - x) / x) - sqrt 1)).
-rewrite Rabs_mult; rewrite (Rabs_right (sqrt x)).
-apply Rmult_lt_reg_l with (/ sqrt x).
-apply Rinv_0_lt_compat; apply sqrt_lt_R0; assumption.
-rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; rewrite Rmult_comm.
-unfold Rdiv in H5.
-case (Req_dec x x0); intro.
-rewrite H7; unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r;
- rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; 
- rewrite Rabs_R0.
-apply Rmult_lt_0_compat.
-assumption.
-apply Rinv_0_lt_compat; rewrite <- H7; apply sqrt_lt_R0; assumption.
-apply H5.
-split.
-unfold D_x, no_cond in |- *.
-split.
-trivial.
-red in |- *; intro.
-cut ((x0 - x) * / x = 0).
-intro.
-elim (Rmult_integral _ _ H9); intro.
-elim H7.
-apply (Rminus_diag_uniq_sym _ _ H10).
-assert (H11 := Rmult_eq_0_compat_r _ x H10).
-rewrite <- Rinv_l_sym in H11.
-elim R1_neq_R0; exact H11.
-red in |- *; intro; rewrite H12 in H; elim (Rlt_irrefl _ H).
-symmetry  in |- *; apply Rplus_eq_reg_l with 1; rewrite Rplus_0_r;
- unfold Rdiv in H8; exact H8.
-unfold Rminus in |- *; rewrite Rplus_comm; rewrite <- Rplus_assoc;
- rewrite Rplus_opp_l; rewrite Rplus_0_l; elim H6; intros.
-unfold Rdiv in |- *; rewrite Rabs_mult.
-rewrite Rabs_Rinv.
-rewrite (Rabs_right x).
-rewrite Rmult_comm; apply Rmult_lt_reg_l with x.
-apply H.
-rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-rewrite Rmult_1_l; rewrite Rmult_comm; fold alpha in |- *.
-apply Rlt_le_trans with (Rmin alpha x).
-apply H9.
-apply Rmin_l.
-red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
-apply Rle_ge; left; apply H.
-red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
-assert (H7 := sqrt_lt_R0 x H).
-red in |- *; intro; rewrite H8 in H7; elim (Rlt_irrefl _ H7).
-apply Rle_ge; apply sqrt_positivity.
-left; apply H.
-unfold Rminus in |- *; rewrite Rmult_plus_distr_l;
- rewrite Ropp_mult_distr_r_reverse; repeat rewrite <- sqrt_mult.
-rewrite Rmult_1_r; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
- unfold Rdiv in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; reflexivity.
-red in |- *; intro; rewrite H7 in H; elim (Rlt_irrefl _ H).
-left; apply H.
-left; apply Rlt_0_1.
-left; apply H.
-elim H6; intros.
-case (Rcase_abs (x0 - x)); intro.
-rewrite (Rabs_left (x0 - x) r) in H8.
-rewrite Rplus_comm.
-apply Rplus_le_reg_l with (- ((x0 - x) / x)).
-rewrite Rplus_0_r; rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
- rewrite Rplus_0_l; unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
-apply Rmult_le_reg_l with x.
-apply H.
-rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
- rewrite <- Rinv_l_sym.
-rewrite Rmult_1_r; left; apply Rlt_le_trans with (Rmin alpha x).
-apply H8.
-apply Rmin_r.
-red in |- *; intro; rewrite H9 in H; elim (Rlt_irrefl _ H).
-apply Rplus_le_le_0_compat.
-left; apply Rlt_0_1.
-unfold Rdiv in |- *; apply Rmult_le_pos.
-apply Rge_le; exact r.
-left; apply Rinv_0_lt_compat; apply H.
-unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-apply H1.
-apply Rinv_0_lt_compat; apply sqrt_lt_R0; apply H.
+Proof.
+  intros; generalize sqrt_continuity_pt_R1.
+  unfold continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; 
+        intros.
+  cut (0 < eps / sqrt x).
+  intro; elim (H0 _ H2); intros alp_1 H3.
+  elim H3; intros.
+  set (alpha := alp_1 * x).
+  exists (Rmin alpha x); intros.
+  split.
+  change (0 < Rmin alpha x) in |- *; unfold Rmin in |- *;
+    case (Rle_dec alpha x); intro.
+  unfold alpha in |- *; apply Rmult_lt_0_compat; assumption.
+  apply H.
+  intros; replace x0 with (x + (x0 - x)); [ idtac | ring ];
+    replace (sqrt (x + (x0 - x)) - sqrt x) with
+    (sqrt x * (sqrt (1 + (x0 - x) / x) - sqrt 1)).
+  rewrite Rabs_mult; rewrite (Rabs_right (sqrt x)).
+  apply Rmult_lt_reg_l with (/ sqrt x).
+  apply Rinv_0_lt_compat; apply sqrt_lt_R0; assumption.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite Rmult_comm.
+  unfold Rdiv in H5.
+  case (Req_dec x x0); intro.
+  rewrite H7; unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r;
+    rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; 
+      rewrite Rabs_R0.
+  apply Rmult_lt_0_compat.
+  assumption.
+  apply Rinv_0_lt_compat; rewrite <- H7; apply sqrt_lt_R0; assumption.
+  apply H5.
+  split.
+  unfold D_x, no_cond in |- *.
+  split.
+  trivial.
+  red in |- *; intro.
+  cut ((x0 - x) * / x = 0).
+  intro.
+  elim (Rmult_integral _ _ H9); intro.
+  elim H7.
+  apply (Rminus_diag_uniq_sym _ _ H10).
+  assert (H11 := Rmult_eq_0_compat_r _ x H10).
+  rewrite <- Rinv_l_sym in H11.
+  elim R1_neq_R0; exact H11.
+  red in |- *; intro; rewrite H12 in H; elim (Rlt_irrefl _ H).
+  symmetry  in |- *; apply Rplus_eq_reg_l with 1; rewrite Rplus_0_r;
+    unfold Rdiv in H8; exact H8.
+  unfold Rminus in |- *; rewrite Rplus_comm; rewrite <- Rplus_assoc;
+    rewrite Rplus_opp_l; rewrite Rplus_0_l; elim H6; intros.
+  unfold Rdiv in |- *; rewrite Rabs_mult.
+  rewrite Rabs_Rinv.
+  rewrite (Rabs_right x).
+  rewrite Rmult_comm; apply Rmult_lt_reg_l with x.
+  apply H.
+  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite Rmult_comm; fold alpha in |- *.
+  apply Rlt_le_trans with (Rmin alpha x).
+  apply H9.
+  apply Rmin_l.
+  red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
+  apply Rle_ge; left; apply H.
+  red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
+  assert (H7 := sqrt_lt_R0 x H).
+  red in |- *; intro; rewrite H8 in H7; elim (Rlt_irrefl _ H7).
+  apply Rle_ge; apply sqrt_positivity.
+  left; apply H.
+  unfold Rminus in |- *; rewrite Rmult_plus_distr_l;
+    rewrite Ropp_mult_distr_r_reverse; repeat rewrite <- sqrt_mult.
+  rewrite Rmult_1_r; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
+    unfold Rdiv in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
+      rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; reflexivity.
+  red in |- *; intro; rewrite H7 in H; elim (Rlt_irrefl _ H).
+  left; apply H.
+  left; apply Rlt_0_1.
+  left; apply H.
+  elim H6; intros.
+  case (Rcase_abs (x0 - x)); intro.
+  rewrite (Rabs_left (x0 - x) r) in H8.
+  rewrite Rplus_comm.
+  apply Rplus_le_reg_l with (- ((x0 - x) / x)).
+  rewrite Rplus_0_r; rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
+    rewrite Rplus_0_l; unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rmult_le_reg_l with x.
+  apply H.
+  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; left; apply Rlt_le_trans with (Rmin alpha x).
+  apply H8.
+  apply Rmin_r.
+  red in |- *; intro; rewrite H9 in H; elim (Rlt_irrefl _ H).
+  apply Rplus_le_le_0_compat.
+  left; apply Rlt_0_1.
+  unfold Rdiv in |- *; apply Rmult_le_pos.
+  apply Rge_le; exact r.
+  left; apply Rinv_0_lt_compat; apply H.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply H1.
+  apply Rinv_0_lt_compat; apply sqrt_lt_R0; apply H.
 Qed.
 
-(* sqrt is derivable for all x>0 *)
+(** sqrt is derivable for all x>0 *)
 Lemma derivable_pt_lim_sqrt :
- forall x:R, 0 < x -> derivable_pt_lim sqrt x (/ (2 * sqrt x)).
-intros; set (g := fun h:R => sqrt x + sqrt (x + h)).
-cut (continuity_pt g 0).
-intro; cut (g 0 <> 0).
-intro; assert (H2 := continuity_pt_inv g 0 H0 H1).
-unfold derivable_pt_lim in |- *; intros; unfold continuity_pt in H2;
- unfold continue_in in H2; unfold limit1_in in H2; 
- unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
-elim (H2 eps H3); intros alpha H4.
-elim H4; intros.
-set (alpha1 := Rmin alpha x).
-cut (0 < alpha1).
-intro; exists (mkposreal alpha1 H7); intros.
-replace ((sqrt (x + h) - sqrt x) / h) with (/ (sqrt x + sqrt (x + h))).
-unfold inv_fct, g in H6; replace (2 * sqrt x) with (sqrt x + sqrt (x + 0)).
-apply H6.
-split.
-unfold D_x, no_cond in |- *.
-split.
-trivial.
-apply (sym_not_eq (A:=R)); exact H8.
-unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
- apply Rlt_le_trans with alpha1.
-exact H9.
-unfold alpha1 in |- *; apply Rmin_l.
-rewrite Rplus_0_r; ring.
-cut (0 <= x + h).
-intro; cut (0 < sqrt x + sqrt (x + h)).
-intro; apply Rmult_eq_reg_l with (sqrt x + sqrt (x + h)).
-rewrite <- Rinv_r_sym.
-rewrite Rplus_comm; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
- rewrite Rsqr_plus_minus; repeat rewrite Rsqr_sqrt.
-rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
- rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym.
-reflexivity.
-apply H8.
-left; apply H.
-assumption.
-red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
-red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
-apply Rplus_lt_le_0_compat.
-apply sqrt_lt_R0; apply H.
-apply sqrt_positivity; apply H10.
-case (Rcase_abs h); intro.
-rewrite (Rabs_left h r) in H9.
-apply Rplus_le_reg_l with (- h).
-rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
- rewrite Rplus_opp_r; rewrite Rplus_0_r; left; apply Rlt_le_trans with alpha1.
-apply H9.
-unfold alpha1 in |- *; apply Rmin_r.
-apply Rplus_le_le_0_compat.
-left; assumption.
-apply Rge_le; apply r.
-unfold alpha1 in |- *; unfold Rmin in |- *; case (Rle_dec alpha x); intro.
-apply H5.
-apply H.
-unfold g in |- *; rewrite Rplus_0_r.
-cut (0 < sqrt x + sqrt x).
-intro; red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
-apply Rplus_lt_0_compat; apply sqrt_lt_R0; apply H.
-replace g with (fct_cte (sqrt x) + comp sqrt (fct_cte x + id))%F;
- [ idtac | reflexivity ].
-apply continuity_pt_plus.
-apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
- reflexivity.
-apply continuity_pt_comp.
-apply continuity_pt_plus.
-apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
- reflexivity.
-apply derivable_continuous_pt; apply derivable_pt_id.
-apply sqrt_continuity_pt.
-unfold plus_fct, fct_cte, id in |- *; rewrite Rplus_0_r; apply H.
+  forall x:R, 0 < x -> derivable_pt_lim sqrt x (/ (2 * sqrt x)).
+Proof.
+  intros; set (g := fun h:R => sqrt x + sqrt (x + h)).
+  cut (continuity_pt g 0).
+  intro; cut (g 0 <> 0).
+  intro; assert (H2 := continuity_pt_inv g 0 H0 H1).
+  unfold derivable_pt_lim in |- *; intros; unfold continuity_pt in H2;
+    unfold continue_in in H2; unfold limit1_in in H2; 
+      unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
+  elim (H2 eps H3); intros alpha H4.
+  elim H4; intros.
+  set (alpha1 := Rmin alpha x).
+  cut (0 < alpha1).
+  intro; exists (mkposreal alpha1 H7); intros.
+  replace ((sqrt (x + h) - sqrt x) / h) with (/ (sqrt x + sqrt (x + h))).
+  unfold inv_fct, g in H6; replace (2 * sqrt x) with (sqrt x + sqrt (x + 0)).
+  apply H6.
+  split.
+  unfold D_x, no_cond in |- *.
+  split.
+  trivial.
+  apply (sym_not_eq (A:=R)); exact H8.
+  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+    apply Rlt_le_trans with alpha1.
+  exact H9.
+  unfold alpha1 in |- *; apply Rmin_l.
+  rewrite Rplus_0_r; ring.
+  cut (0 <= x + h).
+  intro; cut (0 < sqrt x + sqrt (x + h)).
+  intro; apply Rmult_eq_reg_l with (sqrt x + sqrt (x + h)).
+  rewrite <- Rinv_r_sym.
+  rewrite Rplus_comm; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+    rewrite Rsqr_plus_minus; repeat rewrite Rsqr_sqrt.
+  rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym.
+  reflexivity.
+  apply H8.
+  left; apply H.
+  assumption.
+  red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
+  red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
+  apply Rplus_lt_le_0_compat.
+  apply sqrt_lt_R0; apply H.
+  apply sqrt_positivity; apply H10.
+  case (Rcase_abs h); intro.
+  rewrite (Rabs_left h r) in H9.
+  apply Rplus_le_reg_l with (- h).
+  rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_r; left; apply Rlt_le_trans with alpha1.
+  apply H9.
+  unfold alpha1 in |- *; apply Rmin_r.
+  apply Rplus_le_le_0_compat.
+  left; assumption.
+  apply Rge_le; apply r.
+  unfold alpha1 in |- *; unfold Rmin in |- *; case (Rle_dec alpha x); intro.
+  apply H5.
+  apply H.
+  unfold g in |- *; rewrite Rplus_0_r.
+  cut (0 < sqrt x + sqrt x).
+  intro; red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
+  apply Rplus_lt_0_compat; apply sqrt_lt_R0; apply H.
+  replace g with (fct_cte (sqrt x) + comp sqrt (fct_cte x + id))%F;
+  [ idtac | reflexivity ].
+  apply continuity_pt_plus.
+  apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
+    reflexivity.
+  apply continuity_pt_comp.
+  apply continuity_pt_plus.
+  apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
+    reflexivity.
+  apply derivable_continuous_pt; apply derivable_pt_id.
+  apply sqrt_continuity_pt.
+  unfold plus_fct, fct_cte, id in |- *; rewrite Rplus_0_r; apply H.
 Qed.
 
 (**********)
 Lemma derivable_pt_sqrt : forall x:R, 0 < x -> derivable_pt sqrt x.
-unfold derivable_pt in |- *; intros.
-apply existT with (/ (2 * sqrt x)).
-apply derivable_pt_lim_sqrt; assumption.
+Proof.
+  unfold derivable_pt in |- *; intros.
+  apply existT with (/ (2 * sqrt x)).
+  apply derivable_pt_lim_sqrt; assumption.
 Qed.
 
 (**********)
 Lemma derive_pt_sqrt :
- forall (x:R) (pr:0 < x),
-   derive_pt sqrt x (derivable_pt_sqrt _ pr) = / (2 * sqrt x).
-intros.
-apply derive_pt_eq_0.
-apply derivable_pt_lim_sqrt; assumption.
+  forall (x:R) (pr:0 < x),
+    derive_pt sqrt x (derivable_pt_sqrt _ pr) = / (2 * sqrt x).
+Proof.
+  intros.
+  apply derive_pt_eq_0.
+  apply derivable_pt_lim_sqrt; assumption.
 Qed.
 
-(* We show that sqrt is continuous for all x>=0 *)
-(* Remark : by definition of sqrt (as extension of Rsqrt on |R), *)
-(*          we could also show that sqrt is continuous for all x *)
+(** We show that sqrt is continuous for all x>=0 *)
+(** Remark : by definition of sqrt (as extension of Rsqrt on |R),
+   we could also show that sqrt is continuous for all x *)
 Lemma continuity_pt_sqrt : forall x:R, 0 <= x -> continuity_pt sqrt x.
-intros; case (Rtotal_order 0 x); intro.
-apply (sqrt_continuity_pt x H0).
-elim H0; intro.
-unfold continuity_pt in |- *; unfold continue_in in |- *;
- unfold limit1_in in |- *; unfold limit_in in |- *; 
- simpl in |- *; unfold R_dist in |- *; intros.
-exists (Rsqr eps); intros.
-split.
-change (0 < Rsqr eps) in |- *; apply Rsqr_pos_lt.
-red in |- *; intro; rewrite H3 in H2; elim (Rlt_irrefl _ H2).
-intros; elim H3; intros.
-rewrite <- H1; rewrite sqrt_0; unfold Rminus in |- *; rewrite Ropp_0;
- rewrite Rplus_0_r; rewrite <- H1 in H5; unfold Rminus in H5;
- rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5.
-case (Rcase_abs x0); intro.
-unfold sqrt in |- *; case (Rcase_abs x0); intro.
-rewrite Rabs_R0; apply H2.
-assert (H6 := Rge_le _ _ r0); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 r)).
-rewrite Rabs_right.
-apply Rsqr_incrst_0.
-rewrite Rsqr_sqrt.
-rewrite (Rabs_right x0 r) in H5; apply H5.
-apply Rge_le; exact r.
-apply sqrt_positivity; apply Rge_le; exact r.
-left; exact H2.
-apply Rle_ge; apply sqrt_positivity; apply Rge_le; exact r.
-elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H1 H)).
-Qed.
\ No newline at end of file
+Proof.
+  intros; case (Rtotal_order 0 x); intro.
+  apply (sqrt_continuity_pt x H0).
+  elim H0; intro.
+  unfold continuity_pt in |- *; unfold continue_in in |- *;
+    unfold limit1_in in |- *; unfold limit_in in |- *; 
+      simpl in |- *; unfold R_dist in |- *; intros.
+  exists (Rsqr eps); intros.
+  split.
+  change (0 < Rsqr eps) in |- *; apply Rsqr_pos_lt.
+  red in |- *; intro; rewrite H3 in H2; elim (Rlt_irrefl _ H2).
+  intros; elim H3; intros.
+  rewrite <- H1; rewrite sqrt_0; unfold Rminus in |- *; rewrite Ropp_0;
+    rewrite Rplus_0_r; rewrite <- H1 in H5; unfold Rminus in H5;
+      rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5.
+  case (Rcase_abs x0); intro.
+  unfold sqrt in |- *; case (Rcase_abs x0); intro.
+  rewrite Rabs_R0; apply H2.
+  assert (H6 := Rge_le _ _ r0); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 r)).
+  rewrite Rabs_right.
+  apply Rsqr_incrst_0.
+  rewrite Rsqr_sqrt.
+  rewrite (Rabs_right x0 r) in H5; apply H5.
+  apply Rge_le; exact r.
+  apply sqrt_positivity; apply Rge_le; exact r.
+  left; exact H2.
+  apply Rle_ge; apply sqrt_positivity; apply Rge_le; exact r.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H1 H)).
+Qed.
diff --git a/theories/Relations/Newman.v b/theories/Relations/Newman.v
index 3cf604d8..e7bb66eb 100755..100644
--- a/theories/Relations/Newman.v
+++ b/theories/Relations/Newman.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Newman.v,v 1.7.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+(*i $Id: Newman.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Rstar.
 
@@ -23,24 +23,23 @@ Let Rstar_Rstar' := Rstar_Rstar' A R.
 Definition coherence (x y:A) := ex2 (Rstar x) (Rstar y).
 
 Theorem coherence_intro :
- forall x y z:A, Rstar x z -> Rstar y z -> coherence x y.
-Proof
-  fun (x y z:A) (h1:Rstar x z) (h2:Rstar y z) =>
-    ex_intro2 (Rstar x) (Rstar y) z h1 h2.
+  forall x y z:A, Rstar x z -> Rstar y z -> coherence x y.
+Proof fun (x y z:A) (h1:Rstar x z) (h2:Rstar y z) =>
+  ex_intro2 (Rstar x) (Rstar y) z h1 h2.
   
 (** A very simple case of coherence : *)
 
 Lemma Rstar_coherence : forall x y:A, Rstar x y -> coherence x y.
- Proof
-   fun (x y:A) (h:Rstar x y) => coherence_intro x y y h (Rstar_reflexive y).  
+Proof
+  fun (x y:A) (h:Rstar x y) => coherence_intro x y y h (Rstar_reflexive y).  
   
 (** coherence is symmetric *)
 Lemma coherence_sym : forall x y:A, coherence x y -> coherence y x.
- Proof
-   fun (x y:A) (h:coherence x y) =>
-     ex2_ind
-       (fun (w:A) (h1:Rstar x w) (h2:Rstar y w) =>
-          coherence_intro y x w h2 h1) h.
+Proof
+  fun (x y:A) (h:coherence x y) =>
+    ex2_ind
+      (fun (w:A) (h1:Rstar x w) (h2:Rstar y w) =>
+        coherence_intro y x w h2 h1) h.
 
 Definition confluence (x:A) :=
   forall y z:A, Rstar x y -> Rstar x z -> coherence y z.  
@@ -54,68 +53,67 @@ Definition noetherian :=
   
 Section Newman_section.
 
-(** The general hypotheses of the theorem *)
+  (** The general hypotheses of the theorem *)
 
-Hypothesis Hyp1 : noetherian.
-Hypothesis Hyp2 : forall x:A, local_confluence x.  
+  Hypothesis Hyp1 : noetherian.
+  Hypothesis Hyp2 : forall x:A, local_confluence x.  
   
-(** The induction hypothesis *)
+  (** The induction hypothesis *)
 
-Section Induct.
-  Variable x : A.
-  Hypothesis hyp_ind : forall u:A, R x u -> confluence u.  
+  Section Induct.
+    Variable x : A.
+    Hypothesis hyp_ind : forall u:A, R x u -> confluence u.  
   
-(** Confluence in [x] *)
+    (** Confluence in [x] *)
 
-  Variables y z : A.  
-  Hypothesis h1 : Rstar x y.  
-  Hypothesis h2 : Rstar x z.  
+    Variables y z : A.  
+    Hypothesis h1 : Rstar x y.  
+    Hypothesis h2 : Rstar x z.  
   
-(** particular case [x->u] and [u->*y]   *)
-Section Newman_.
-  Variable u : A.  
-  Hypothesis t1 : R x u.  
-  Hypothesis t2 : Rstar u y.  
+    (** particular case [x->u] and [u->*y]   *)
+    Section Newman_.
+      Variable u : A.  
+      Hypothesis t1 : R x u.  
+      Hypothesis t2 : Rstar u y.  
+      
+      (** In the usual diagram, we assume also [x->v] and [v->*z] *)
+      
+      Theorem Diagram : forall (v:A) (u1:R x v) (u2:Rstar v z), coherence y z.
+      Proof
+       (* We draw the diagram ! *)
+      fun (v:A) (u1:R x v) (u2:Rstar v z) =>
+	ex2_ind
+	 (* local confluence in x for u,v *)
+	 (* gives w, u->*w and v->*w *)
+	(fun (w:A) (s1:Rstar u w) (s2:Rstar v w) =>
+          ex2_ind
+              (* confluence in u => coherence(y,w) *)
+              (* gives a, y->*a and z->*a *)
+          (fun (a:A) (v1:Rstar y a) (v2:Rstar w a) =>
+            ex2_ind
+              (* confluence in v => coherence(a,z) *)
+              (* gives b, a->*b and z->*b *)
+            (fun (b:A) (w1:Rstar a b) (w2:Rstar z b) =>
+              coherence_intro y z b (Rstar_transitive y a b v1 w1) w2)
+            (hyp_ind v u1 a z (Rstar_transitive v w a s2 v2) u2))
+          (hyp_ind u t1 y w t2 s1)) (Hyp2 x u v t1 u1).
   
-(** In the usual diagram, we assume also [x->v] and [v->*z] *)
-
-Theorem Diagram : forall (v:A) (u1:R x v) (u2:Rstar v z), coherence y z.
-
-Proof
-   (* We draw the diagram ! *)
-  fun (v:A) (u1:R x v) (u2:Rstar v z) =>
-    ex2_ind
-       (* local confluence in x for u,v *)
-       (* gives w, u->*w and v->*w *)
-      (fun (w:A) (s1:Rstar u w) (s2:Rstar v w) =>
-         ex2_ind
-            (* confluence in u => coherence(y,w) *)
-            (* gives a, y->*a and z->*a *)
-           (fun (a:A) (v1:Rstar y a) (v2:Rstar w a) =>
-              ex2_ind
-                 (* confluence in v => coherence(a,z) *)
-                 (* gives b, a->*b and z->*b *)
-                (fun (b:A) (w1:Rstar a b) (w2:Rstar z b) =>
-                   coherence_intro y z b (Rstar_transitive y a b v1 w1) w2)
-                (hyp_ind v u1 a z (Rstar_transitive v w a s2 v2) u2))
-           (hyp_ind u t1 y w t2 s1)) (Hyp2 x u v t1 u1).
-  
-Theorem caseRxy : coherence y z.
-Proof
-  Rstar_Rstar' x z h2 (fun v w:A => coherence y w)
-    (coherence_sym x y (Rstar_coherence x y h1)) (*i case x=z i*)
-    Diagram.                                     (*i case x->v->*z i*)
-End Newman_.
-
-Theorem Ind_proof : coherence y z.
-Proof
-  Rstar_Rstar' x y h1 (fun u v:A => coherence v z)
-    (Rstar_coherence x z h2) (*i case x=y i*)
-    caseRxy.                                   (*i case x->u->*z i*)
-End Induct.
-
-Theorem Newman : forall x:A, confluence x.
-Proof fun x:A => Hyp1 x confluence Ind_proof.  
+      Theorem caseRxy : coherence y z.
+      Proof
+        Rstar_Rstar' x z h2 (fun v w:A => coherence y w)
+	(coherence_sym x y (Rstar_coherence x y h1)) (*i case x=z i*)
+	Diagram.                                     (*i case x->v->*z i*)
+    End Newman_.
+
+    Theorem Ind_proof : coherence y z.
+    Proof
+      Rstar_Rstar' x y h1 (fun u v:A => coherence v z)
+      (Rstar_coherence x z h2) (*i case x=y i*)
+      caseRxy.                                   (*i case x->u->*z i*)
+  End Induct.
+
+  Theorem Newman : forall x:A, confluence x.
+  Proof fun x:A => Hyp1 x confluence Ind_proof.  
 
 End Newman_section.
 
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
index 5e0e9ec8..7e202359 100755..100644
--- a/theories/Relations/Operators_Properties.v
+++ b/theories/Relations/Operators_Properties.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Operators_Properties.v,v 1.7.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+(*i $Id: Operators_Properties.v 9597 2007-02-06 19:44:05Z herbelin $ i*)
 
 (****************************************************************************)
 (*                            Bruno Barras                                  *)
@@ -18,79 +18,81 @@ Require Import Relation_Operators.
 
 Section Properties.
 
-  Variable A : Set.
+  Variable A : Type.
   Variable R : relation A.
 
   Let incl (R1 R2:relation A) : Prop := forall x y:A, R1 x y -> R2 x y.
-
-Section Clos_Refl_Trans.
-
-  Lemma clos_rt_is_preorder : preorder A (clos_refl_trans A R).
-apply Build_preorder.
-exact (rt_refl A R).
-
-exact (rt_trans A R).
-Qed.
-
-
-
-Lemma clos_rt_idempotent :
- incl (clos_refl_trans A (clos_refl_trans A R)) (clos_refl_trans A R).
-red in |- *.
-induction 1; auto with sets.
-intros.
-apply rt_trans with y; auto with sets.
-Qed.
-
-  Lemma clos_refl_trans_ind_left :
-   forall (A:Set) (R:A -> A -> Prop) (M:A) (P:A -> Prop),
-     P M ->
-     (forall P0 N:A, clos_refl_trans A R M P0 -> P P0 -> R P0 N -> P N) ->
-     forall a:A, clos_refl_trans A R M a -> P a.
-intros.
-generalize H H0.
-clear H H0.
-elim H1; intros; auto with sets.
-apply H2 with x; auto with sets.
-
-apply H3.
-apply H0; auto with sets.
-
-intros.
-apply H5 with P0; auto with sets.
-apply rt_trans with y; auto with sets.
-Qed.
-
-
-End Clos_Refl_Trans.
-
-
-Section Clos_Refl_Sym_Trans.
-
-  Lemma clos_rt_clos_rst :
-   inclusion A (clos_refl_trans A R) (clos_refl_sym_trans A R).
-red in |- *.
-induction 1; auto with sets.
-apply rst_trans with y; auto with sets.
-Qed.
-
-  Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans A R).
-apply Build_equivalence.
-exact (rst_refl A R).
-
-exact (rst_trans A R).
-
-exact (rst_sym A R).
-Qed.
-
-  Lemma clos_rst_idempotent :
-   incl (clos_refl_sym_trans A (clos_refl_sym_trans A R))
-     (clos_refl_sym_trans A R).
-red in |- *.
-induction 1; auto with sets.
-apply rst_trans with y; auto with sets.
-Qed.
-
-End Clos_Refl_Sym_Trans.
-
-End Properties.
\ No newline at end of file
+  
+  Section Clos_Refl_Trans.
+
+    Lemma clos_rt_is_preorder : preorder A (clos_refl_trans A R).
+    Proof.
+      apply Build_preorder.
+      exact (rt_refl A R).
+      
+      exact (rt_trans A R).
+    Qed.
+
+    Lemma clos_rt_idempotent :
+      incl (clos_refl_trans A (clos_refl_trans A R)) (clos_refl_trans A R).
+    Proof.
+      red in |- *.
+      induction 1; auto with sets.
+      intros.
+      apply rt_trans with y; auto with sets.
+    Qed.
+
+    Lemma clos_refl_trans_ind_left :
+      forall (A:Type) (R:A -> A -> Prop) (M:A) (P:A -> Prop),
+	P M ->
+	(forall P0 N:A, clos_refl_trans A R M P0 -> P P0 -> R P0 N -> P N) ->
+	forall a:A, clos_refl_trans A R M a -> P a.
+    Proof.
+      intros.
+      generalize H H0.
+      clear H H0.
+      elim H1; intros; auto with sets.
+      apply H2 with x; auto with sets.
+      
+      apply H3.
+      apply H0; auto with sets.
+
+      intros.
+      apply H5 with P0; auto with sets.
+      apply rt_trans with y; auto with sets.
+    Qed.
+
+
+  End Clos_Refl_Trans.
+
+
+  Section Clos_Refl_Sym_Trans.
+
+    Lemma clos_rt_clos_rst :
+      inclusion A (clos_refl_trans A R) (clos_refl_sym_trans A R).
+    Proof.
+      red in |- *.
+      induction 1; auto with sets.
+      apply rst_trans with y; auto with sets.
+    Qed.
+
+    Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans A R).
+    Proof.
+      apply Build_equivalence.
+      exact (rst_refl A R).
+      exact (rst_trans A R).
+      exact (rst_sym A R).
+    Qed.
+
+    Lemma clos_rst_idempotent :
+      incl (clos_refl_sym_trans A (clos_refl_sym_trans A R))
+      (clos_refl_sym_trans A R).
+    Proof.
+      red in |- *.
+      induction 1; auto with sets.
+      apply rst_trans with y; auto with sets.
+    Qed.
+  
+  End Clos_Refl_Sym_Trans.
+
+End Properties.
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
index e115b0b0..762da1ff 100755..100644
--- a/theories/Relations/Relation_Definitions.v
+++ b/theories/Relations/Relation_Definitions.v
@@ -6,67 +6,66 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relation_Definitions.v,v 1.6.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+(*i $Id: Relation_Definitions.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Section Relation_Definition.
 
-   Variable A : Type.
-   
-   Definition relation := A -> A -> Prop.
+  Variable A : Type.
+  
+  Definition relation := A -> A -> Prop.
 
-   Variable R : relation.
+  Variable R : relation.
    
 
-Section General_Properties_of_Relations.
-
-  Definition reflexive : Prop := forall x:A, R x x.
-  Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z.
-  Definition symmetric : Prop := forall x y:A, R x y -> R y x.
-  Definition antisymmetric : Prop := forall x y:A, R x y -> R y x -> x = y.
-
-  (* for compatibility with Equivalence in  ../PROGRAMS/ALG/  *)
-  Definition equiv := reflexive /\ transitive /\ symmetric.
-
-End General_Properties_of_Relations.
-
+  Section General_Properties_of_Relations.
+    
+    Definition reflexive : Prop := forall x:A, R x x.
+    Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z.
+    Definition symmetric : Prop := forall x y:A, R x y -> R y x.
+    Definition antisymmetric : Prop := forall x y:A, R x y -> R y x -> x = y.
 
+    (* for compatibility with Equivalence in  ../PROGRAMS/ALG/  *)
+    Definition equiv := reflexive /\ transitive /\ symmetric.
 
-Section Sets_of_Relations.
+  End General_Properties_of_Relations.
 
-   Record preorder : Prop := 
-     {preord_refl : reflexive; preord_trans : transitive}.
 
-   Record order : Prop := 
-     {ord_refl : reflexive;
-      ord_trans : transitive;
-      ord_antisym : antisymmetric}.
 
-   Record equivalence : Prop := 
-     {equiv_refl : reflexive;
-      equiv_trans : transitive;
-      equiv_sym : symmetric}.
-   
-   Record PER : Prop :=  {per_sym : symmetric; per_trans : transitive}.
-
-End Sets_of_Relations.
+  Section Sets_of_Relations.
+    
+    Record preorder : Prop := 
+      { preord_refl : reflexive; preord_trans : transitive}.
+    
+    Record order : Prop := 
+      { ord_refl : reflexive;
+	ord_trans : transitive;
+	ord_antisym : antisymmetric}.
+    
+    Record equivalence : Prop := 
+      { equiv_refl : reflexive;
+	equiv_trans : transitive;
+	equiv_sym : symmetric}.
+    
+    Record PER : Prop :=  {per_sym : symmetric; per_trans : transitive}.
 
+  End Sets_of_Relations.
 
 
-Section Relations_of_Relations.
+  Section Relations_of_Relations.
+    
+    Definition inclusion (R1 R2:relation) : Prop :=
+      forall x y:A, R1 x y -> R2 x y.
+    
+    Definition same_relation (R1 R2:relation) : Prop :=
+      inclusion R1 R2 /\ inclusion R2 R1.
+    
+    Definition commut (R1 R2:relation) : Prop :=
+      forall x y:A,
+	R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.
 
-  Definition inclusion (R1 R2:relation) : Prop :=
-    forall x y:A, R1 x y -> R2 x y.
+  End Relations_of_Relations.
 
-  Definition same_relation (R1 R2:relation) : Prop :=
-    inclusion R1 R2 /\ inclusion R2 R1.
-   
-  Definition commut (R1 R2:relation) : Prop :=
-    forall x y:A,
-      R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.
 
-End Relations_of_Relations.
-
-   
 End Relation_Definition.
 
 Hint Unfold reflexive transitive antisymmetric symmetric: sets v62.
@@ -75,4 +74,4 @@ Hint Resolve Build_preorder Build_order Build_equivalence Build_PER
   preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl
   equiv_trans equiv_sym per_sym per_trans: sets v62.
 
-Hint Unfold inclusion same_relation commut: sets v62.
\ No newline at end of file
+Hint Unfold inclusion same_relation commut: sets v62.
diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v
index b6359ada..4c5a6519 100755..100644
--- a/theories/Relations/Relation_Operators.v
+++ b/theories/Relations/Relation_Operators.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relation_Operators.v,v 1.8.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+(*i $Id: Relation_Operators.v 9610 2007-02-07 14:45:18Z herbelin $ i*)
 
 (****************************************************************************)
 (*                      Bruno Barras, Cristina Cornes                       *)
@@ -22,47 +22,47 @@ Require Import List.
 (** Some operators to build relations *)
 
 Section Transitive_Closure.
-  Variable A : Set.
+  Variable A : Type.
   Variable R : relation A.
-
-  Inductive clos_trans : A -> A -> Prop :=
-    | t_step : forall x y:A, R x y -> clos_trans x y
+  
+  Inductive clos_trans (x: A) : A -> Prop :=
+    | t_step : forall y:A, R x y -> clos_trans x y
     | t_trans :
-        forall x y z:A, clos_trans x y -> clos_trans y z -> clos_trans x z.
+        forall y z:A, clos_trans x y -> clos_trans y z -> clos_trans x z.
 End Transitive_Closure.
 
 
 Section Reflexive_Transitive_Closure.
-  Variable A : Set.
+  Variable A : Type.
   Variable R : relation A.
 
-  Inductive clos_refl_trans : relation A :=
-    | rt_step : forall x y:A, R x y -> clos_refl_trans x y
-    | rt_refl : forall x:A, clos_refl_trans x x
+  Inductive clos_refl_trans (x:A) : A -> Prop:=
+    | rt_step : forall y:A, R x y -> clos_refl_trans x y
+    | rt_refl : clos_refl_trans x x
     | rt_trans :
-        forall x y z:A,
+        forall y z:A,
           clos_refl_trans x y -> clos_refl_trans y z -> clos_refl_trans x z.
 End Reflexive_Transitive_Closure.
 
 
 Section Reflexive_Symetric_Transitive_Closure.
-  Variable A : Set.
+  Variable A : Type.
   Variable R : relation A.
-
+  
   Inductive clos_refl_sym_trans : relation A :=
     | rst_step : forall x y:A, R x y -> clos_refl_sym_trans x y
     | rst_refl : forall x:A, clos_refl_sym_trans x x
     | rst_sym :
-        forall x y:A, clos_refl_sym_trans x y -> clos_refl_sym_trans y x
+      forall x y:A, clos_refl_sym_trans x y -> clos_refl_sym_trans y x
     | rst_trans :
-        forall x y z:A,
-          clos_refl_sym_trans x y ->
-          clos_refl_sym_trans y z -> clos_refl_sym_trans x z.
+      forall x y z:A,
+        clos_refl_sym_trans x y ->
+        clos_refl_sym_trans y z -> clos_refl_sym_trans x z.
 End Reflexive_Symetric_Transitive_Closure.
 
 
 Section Transposee.
-  Variable A : Set.
+  Variable A : Type.
   Variable R : relation A.
 
   Definition transp (x y:A) := R y x.
@@ -70,7 +70,7 @@ End Transposee.
 
 
 Section Union.
-  Variable A : Set.
+  Variable A : Type.
   Variables R1 R2 : relation A.
 
   Definition union (x y:A) := R1 x y \/ R2 x y.
@@ -78,7 +78,7 @@ End Union.
 
 
 Section Disjoint_Union.
-Variables A B : Set.
+Variables A B : Type.
 Variable leA : A -> A -> Prop.
 Variable leB : B -> B -> Prop.
 
@@ -92,76 +92,76 @@ End Disjoint_Union.
 
 
 Section Lexicographic_Product.
-(* Lexicographic order on dependent pairs *)
+  (* Lexicographic order on dependent pairs *)
 
-Variable A : Set.
-Variable B : A -> Set.
-Variable leA : A -> A -> Prop.
-Variable leB : forall x:A, B x -> B x -> Prop.
+  Variable A : Type.
+  Variable B : A -> Type.
+  Variable leA : A -> A -> Prop.
+  Variable leB : forall x:A, B x -> B x -> Prop.
 
-Inductive lexprod : sigS B -> sigS B -> Prop :=
-  | left_lex :
+  Inductive lexprod : sigS B -> sigS B -> Prop :=
+    | left_lex :
       forall (x x':A) (y:B x) (y':B x'),
         leA x x' -> lexprod (existS B x y) (existS B x' y')
-  | right_lex :
+    | right_lex :
       forall (x:A) (y y':B x),
         leB x y y' -> lexprod (existS B x y) (existS B x y').
 End Lexicographic_Product.
 
 
 Section Symmetric_Product.
-  Variable A : Set.
-  Variable B : Set.
+  Variable A : Type.
+  Variable B : Type.
   Variable leA : A -> A -> Prop.
   Variable leB : B -> B -> Prop.
 
   Inductive symprod : A * B -> A * B -> Prop :=
     | left_sym :
-        forall x x':A, leA x x' -> forall y:B, symprod (x, y) (x', y)
+      forall x x':A, leA x x' -> forall y:B, symprod (x, y) (x', y)
     | right_sym :
-        forall y y':B, leB y y' -> forall x:A, symprod (x, y) (x, y').
+      forall y y':B, leB y y' -> forall x:A, symprod (x, y) (x, y').
 
 End Symmetric_Product.
 
 
 Section Swap.
-  Variable A : Set.
+  Variable A : Type.
   Variable R : A -> A -> Prop.
 
   Inductive swapprod : A * A -> A * A -> Prop :=
     | sp_noswap : forall x x':A * A, symprod A A R R x x' -> swapprod x x'
     | sp_swap :
-        forall (x y:A) (p:A * A),
-          symprod A A R R (x, y) p -> swapprod (y, x) p.
+      forall (x y:A) (p:A * A),
+        symprod A A R R (x, y) p -> swapprod (y, x) p.
 End Swap.
 
 
 Section Lexicographic_Exponentiation.
-
-Variable A : Set.
-Variable leA : A -> A -> Prop.
-Let Nil := nil (A:=A).
-Let List := list A.
-
-Inductive Ltl : List -> List -> Prop :=
-  | Lt_nil : forall (a:A) (x:List), Ltl Nil (a :: x)
-  | Lt_hd : forall a b:A, leA a b -> forall x y:list A, Ltl (a :: x) (b :: y)
-  | Lt_tl : forall (a:A) (x y:List), Ltl x y -> Ltl (a :: x) (a :: y).
-
-
-Inductive Desc : List -> Prop :=
-  | d_nil : Desc Nil
-  | d_one : forall x:A, Desc (x :: Nil)
-  | d_conc :
+  
+  Variable A : Set.
+  Variable leA : A -> A -> Prop.
+  Let Nil := nil (A:=A).
+  Let List := list A.
+  
+  Inductive Ltl : List -> List -> Prop :=
+    | Lt_nil : forall (a:A) (x:List), Ltl Nil (a :: x)
+    | Lt_hd : forall a b:A, leA a b -> forall x y:list A, Ltl (a :: x) (b :: y)
+    | Lt_tl : forall (a:A) (x y:List), Ltl x y -> Ltl (a :: x) (a :: y).
+
+
+  Inductive Desc : List -> Prop :=
+    | d_nil : Desc Nil
+    | d_one : forall x:A, Desc (x :: Nil)
+    | d_conc :
       forall (x y:A) (l:List),
         leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil).
 
-Definition Pow : Set := sig Desc.
-
-Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b).
+  Definition Pow : Set := sig Desc.
+  
+  Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b).
 
 End Lexicographic_Exponentiation.
 
 Hint Unfold transp union: sets v62.
 Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets v62.
-Hint Immediate rst_sym: sets v62.
\ No newline at end of file
+Hint Immediate rst_sym: sets v62.
diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v
index 6c96f14d..9da30e9b 100755..100644
--- a/theories/Relations/Relations.v
+++ b/theories/Relations/Relations.v
@@ -6,23 +6,26 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Relations.v,v 1.6.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+(*i $Id: Relations.v 9597 2007-02-06 19:44:05Z herbelin $ i*)
 
 Require Export Relation_Definitions.
 Require Export Relation_Operators.
 Require Export Operators_Properties.
 
 Lemma inverse_image_of_equivalence :
- forall (A B:Set) (f:A -> B) (r:relation B),
-   equivalence B r -> equivalence A (fun x y:A => r (f x) (f y)).
-intros; split; elim H; red in |- *; auto.
-intros _ equiv_trans _ x y z H0 H1; apply equiv_trans with (f y); assumption.
+  forall (A B:Type) (f:A -> B) (r:relation B),
+    equivalence B r -> equivalence A (fun x y:A => r (f x) (f y)).
+Proof.
+  intros; split; elim H; red in |- *; auto.
+  intros _ equiv_trans _ x y z H0 H1; apply equiv_trans with (f y); assumption.
 Qed.
 
 Lemma inverse_image_of_eq :
- forall (A B:Set) (f:A -> B), equivalence A (fun x y:A => f x = f y).
-split; red in |- *;
- [  (* reflexivity *) reflexivity
- |  (* transitivity *) intros; transitivity (f y); assumption
- |  (* symmetry *) intros; symmetry  in |- *; assumption ].
-Qed.
\ No newline at end of file
+  forall (A B:Type) (f:A -> B), equivalence A (fun x y:A => f x = f y).
+Proof.
+  split; red in |- *;
+    [  (* reflexivity *) reflexivity
+      |  (* transitivity *) intros; transitivity (f y); assumption
+      |  (* symmetry *) intros; symmetry  in |- *; assumption ].
+Qed.
+
diff --git a/theories/Relations/Rstar.v b/theories/Relations/Rstar.v
index 7bb3ee93..91d2aaa4 100755..100644
--- a/theories/Relations/Rstar.v
+++ b/theories/Relations/Rstar.v
@@ -6,82 +6,89 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Rstar.v,v 1.8.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+(*i $Id: Rstar.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Properties of a binary relation [R] on type [A] *)
 
 Section Rstar.
+  
+  Variable A : Type.  
+  Variable R : A -> A -> Prop.  
 
-Variable A : Type.  
-Variable R : A -> A -> Prop.  
-
-(** Definition of the reflexive-transitive closure [R*] of [R] *)
-(** Smallest reflexive [P] containing [R o P] *)
-
-Definition Rstar (x y:A) :=
-  forall P:A -> A -> Prop,
-    (forall u:A, P u u) -> (forall u v w:A, R u v -> P v w -> P u w) -> P x y.  
+  (** Definition of the reflexive-transitive closure [R*] of [R] *)
+  (** Smallest reflexive [P] containing [R o P] *)
 
-Theorem Rstar_reflexive : forall x:A, Rstar x x.
- Proof
-   fun (x:A) (P:A -> A -> Prop) (h1:forall u:A, P u u)
-     (h2:forall u v w:A, R u v -> P v w -> P u w) => 
-     h1 x.  
+  Definition Rstar (x y:A) :=
+    forall P:A -> A -> Prop,
+      (forall u:A, P u u) -> (forall u v w:A, R u v -> P v w -> P u w) -> P x y.  
   
-Theorem Rstar_R : forall x y z:A, R x y -> Rstar y z -> Rstar x z.
- Proof
-   fun (x y z:A) (t1:R x y) (t2:Rstar y z) (P:A -> A -> Prop)
-     (h1:forall u:A, P u u) (h2:forall u v w:A, R u v -> P v w -> P u w) =>
-     h2 x y z t1 (t2 P h1 h2).  
+  Theorem Rstar_reflexive : forall x:A, Rstar x x.
+  Proof.
+    unfold Rstar. intros x P P_refl RoP. apply P_refl.
+  Qed.
+
+  Theorem Rstar_R : forall x y z:A, R x y -> Rstar y z -> Rstar x z.
+  Proof.
+    intros x y z R_xy Rstar_yz.
+    unfold Rstar.
+    intros P P_refl RoP. apply RoP with (v:=y).
+      assumption.
+      apply Rstar_yz; assumption.
+  Qed.
+
+  (** We conclude with transitivity of [Rstar] : *)
+
+  Theorem Rstar_transitive :
+    forall x y z:A, Rstar x y -> Rstar y z -> Rstar x z.
+  Proof.
+    intros x y z Rstar_xy; unfold Rstar in Rstar_xy.
+    apply Rstar_xy; trivial.
+    intros u v w R_uv fz Rstar_wz.
+    apply Rstar_R with (y:=v); auto.
+  Qed.
+
+  (** Another characterization of [R*] *)
+  (** Smallest reflexive [P] containing [R o R*] *)
+
+  Definition Rstar' (x y:A) :=
+    forall P:A -> A -> Prop,
+      P x x -> (forall u:A, R x u -> Rstar u y -> P x y) -> P x y.  
+
+  Theorem Rstar'_reflexive : forall x:A, Rstar' x x.
+  Proof.
+    unfold Rstar'; intros; assumption.
+  Qed.
   
-(** We conclude with transitivity of [Rstar] : *)
-
-Theorem Rstar_transitive :
- forall x y z:A, Rstar x y -> Rstar y z -> Rstar x z.
- Proof
-   fun (x y z:A) (h:Rstar x y) =>
-     h (fun u v:A => Rstar v z -> Rstar u z) (fun (u:A) (t:Rstar u z) => t)
-       (fun (u v w:A) (t1:R u v) (t2:Rstar w z -> Rstar v z)
-          (t3:Rstar w z) => Rstar_R u v z t1 (t2 t3)).  
-
-(** Another characterization of [R*] *)
-(** Smallest reflexive [P] containing [R o R*] *)
-
-Definition Rstar' (x y:A) :=
-  forall P:A -> A -> Prop,
-    P x x -> (forall u:A, R x u -> Rstar u y -> P x y) -> P x y.  
-
-Theorem Rstar'_reflexive : forall x:A, Rstar' x x.
- Proof
-   fun (x:A) (P:A -> A -> Prop) (h:P x x)
-     (h':forall u:A, R x u -> Rstar u x -> P x x) => h.
+  Theorem Rstar'_R : forall x y z:A, R x z -> Rstar z y -> Rstar' x y.
+  Proof.
+    unfold Rstar'. intros x y z Rxz Rstar_zy P Pxx RoP.
+    apply RoP with (u:=z); trivial.
+  Qed.
   
-Theorem Rstar'_R : forall x y z:A, R x z -> Rstar z y -> Rstar' x y.
- Proof
-   fun (x y z:A) (t1:R x z) (t2:Rstar z y) (P:A -> A -> Prop) 
-     (h1:P x x) (h2:forall u:A, R x u -> Rstar u y -> P x y) => 
-     h2 z t1 t2.  
+  (** Equivalence of the two definitions: *)
+
+  Theorem Rstar'_Rstar : forall x y:A, Rstar' x y -> Rstar x y.
+  Proof.
+    intros x z Rstar'_xz; unfold Rstar' in Rstar'_xz.
+    apply Rstar'_xz.
+      exact (Rstar_reflexive x).
+      intro y; generalize x y z; exact Rstar_R.
+  Qed.
   
-(** Equivalence of the two definitions: *)
-
-Theorem Rstar'_Rstar : forall x y:A, Rstar' x y -> Rstar x y.
- Proof
-   fun (x y:A) (h:Rstar' x y) =>
-     h Rstar (Rstar_reflexive x) (fun u:A => Rstar_R x u y).  
+  Theorem Rstar_Rstar' : forall x y:A, Rstar x y -> Rstar' x y.
+  Proof.
+    intros.
+    apply H.
+      exact Rstar'_reflexive.
+      intros u v  w R_uv Rs'_vw. apply Rstar'_R with (z:=v).
+        assumption.
+        apply Rstar'_Rstar; assumption.
+  Qed.
+
+  (** Property of Commutativity of two relations *)
   
-Theorem Rstar_Rstar' : forall x y:A, Rstar x y -> Rstar' x y.
- Proof
-   fun (x y:A) (h:Rstar x y) =>
-     h Rstar' (fun u:A => Rstar'_reflexive u)
-       (fun (u v w:A) (h1:R u v) (h2:Rstar' v w) =>
-          Rstar'_R u w v h1 (Rstar'_Rstar v w h2)).  
-
-
-(** Property of Commutativity of two relations *)
-
-Definition commut (A:Set) (R1 R2:A -> A -> Prop) :=
-  forall x y:A,
-    R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.
-
+  Definition commut (A:Set) (R1 R2:A -> A -> Prop) :=
+    forall x y:A,
+      R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.
 
 End Rstar.
diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
index 63f21fed..84af7d5d 100644
--- a/theories/Setoids/Setoid.v
+++ b/theories/Setoids/Setoid.v
@@ -1,3 +1,4 @@
+
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
@@ -6,66 +7,694 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Setoid.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $: i*)
+(*i $Id: Setoid.v 9245 2006-10-17 12:53:34Z notin $: i*)
+
+Require Export Relation_Definitions.
+
+Set Implicit Arguments.
+
+(** * Definitions of [Relation_Class] and n-ary [Morphism_Theory] *)
+
+(* X will be used to distinguish covariant arguments whose type is an   *)
+(* Asymmetric* relation from contravariant arguments of the same type *)
+Inductive X_Relation_Class (X: Type) : Type :=
+   SymmetricReflexive :
+     forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> X_Relation_Class X
+ | AsymmetricReflexive : X -> forall A Aeq, reflexive A Aeq -> X_Relation_Class X
+ | SymmetricAreflexive : forall A Aeq, symmetric A Aeq -> X_Relation_Class X
+ | AsymmetricAreflexive : X -> forall A (Aeq : relation A), X_Relation_Class X
+ | Leibniz : Type -> X_Relation_Class X.
+
+Inductive variance : Set :=
+   Covariant
+ | Contravariant.
+
+Definition Argument_Class := X_Relation_Class variance.
+Definition Relation_Class := X_Relation_Class unit.
+
+Inductive Reflexive_Relation_Class : Type :=
+   RSymmetric :
+     forall A Aeq, symmetric A Aeq -> reflexive _ Aeq -> Reflexive_Relation_Class
+ | RAsymmetric :
+     forall A Aeq, reflexive A Aeq -> Reflexive_Relation_Class
+ | RLeibniz : Type -> Reflexive_Relation_Class.
+
+Inductive Areflexive_Relation_Class  : Type :=
+ | ASymmetric : forall A Aeq, symmetric A Aeq -> Areflexive_Relation_Class
+ | AAsymmetric : forall A (Aeq : relation A), Areflexive_Relation_Class.
+
+Implicit Type Hole Out: Relation_Class.
+
+Definition relation_class_of_argument_class : Argument_Class -> Relation_Class.
+  destruct 1.
+  exact (SymmetricReflexive _ s r).
+  exact (AsymmetricReflexive tt r).
+  exact (SymmetricAreflexive _ s).
+  exact (AsymmetricAreflexive tt Aeq).
+  exact (Leibniz _ T).
+Defined.
+
+Definition carrier_of_relation_class : forall X, X_Relation_Class X -> Type.
+  destruct 1.
+  exact A.
+  exact A.
+  exact A.
+  exact A.
+  exact T.
+Defined.
+
+Definition relation_of_relation_class :
+  forall X R, @carrier_of_relation_class X R -> carrier_of_relation_class R -> Prop.
+  destruct R.
+  exact Aeq.
+  exact Aeq.
+  exact Aeq.
+  exact Aeq.
+  exact (@eq T).
+Defined.
+
+Lemma about_carrier_of_relation_class_and_relation_class_of_argument_class :
+  forall R,
+    carrier_of_relation_class (relation_class_of_argument_class R) =
+    carrier_of_relation_class R.
+  destruct R; reflexivity.
+Defined.
+
+Inductive nelistT (A : Type) : Type :=
+   singl : A -> nelistT A
+ | necons : A -> nelistT A -> nelistT A.
+
+Definition Arguments := nelistT Argument_Class.
+
+Implicit Type In: Arguments.
+
+Definition function_type_of_morphism_signature :
+  Arguments -> Relation_Class -> Type.
+  intros In Out.
+  induction In.
+    exact (carrier_of_relation_class a -> carrier_of_relation_class Out).
+    exact (carrier_of_relation_class a -> IHIn).
+Defined. 
+
+Definition make_compatibility_goal_aux:
+  forall In Out
+    (f g: function_type_of_morphism_signature In Out), Prop.
+  intros; induction In; simpl in f, g.
+    induction a; simpl in f, g.
+      exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)).
+      destruct x.
+        exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)).
+        exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)).
+      exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)).
+      destruct x.
+        exact (forall x1 x2, Aeq x1 x2 -> relation_of_relation_class Out (f x1) (g x2)).
+        exact (forall x1 x2, Aeq x2 x1 -> relation_of_relation_class Out (f x1) (g x2)).
+      exact (forall x, relation_of_relation_class Out (f x) (g x)).
+  induction a; simpl in f, g.
+    exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)).
+    destruct x.
+      exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)).
+      exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)).
+    exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)).
+    destruct x.
+      exact (forall x1 x2, Aeq x1 x2 -> IHIn (f x1) (g x2)).
+      exact (forall x1 x2, Aeq x2 x1 -> IHIn (f x1) (g x2)).
+    exact (forall x, IHIn (f x) (g x)).
+Defined. 
+
+Definition make_compatibility_goal :=
+  (fun In Out f => make_compatibility_goal_aux In Out f f).
+
+Record Morphism_Theory In Out : Type :=
+  { Function : function_type_of_morphism_signature In Out;
+    Compat : make_compatibility_goal In Out Function }.
+
+(** The [iff] relation class *)
+
+Definition Iff_Relation_Class : Relation_Class.
+  eapply (@SymmetricReflexive unit _ iff).
+  exact iff_sym.
+  exact iff_refl.
+Defined.
+
+(** The [impl] relation class *)
+
+Definition impl (A B: Prop) := A -> B.
+
+Theorem impl_refl: reflexive _ impl.
+Proof.
+  hnf; unfold impl; tauto.
+Qed.
+
+Definition Impl_Relation_Class : Relation_Class.
+  eapply (@AsymmetricReflexive unit tt _ impl).
+  exact impl_refl.
+Defined.
+
+(** Every function is a morphism from Leibniz+ to Leibniz *)
+
+Definition list_of_Leibniz_of_list_of_types: nelistT Type -> Arguments.
+ induction 1.
+   exact (singl (Leibniz _ a)).
+   exact (necons (Leibniz _ a) IHX).
+Defined.
+
+Definition morphism_theory_of_function :
+  forall (In: nelistT Type) (Out: Type),
+    let In' := list_of_Leibniz_of_list_of_types In in
+      let Out' := Leibniz _ Out in
+	function_type_of_morphism_signature In' Out' ->
+	Morphism_Theory In' Out'.
+  intros.
+  exists X.
+  induction In;  unfold make_compatibility_goal; simpl.
+    reflexivity.
+    intro; apply (IHIn (X x)).
+Defined.
+
+(** Every predicate is a morphism from Leibniz+ to Iff_Relation_Class *)
+
+Definition morphism_theory_of_predicate :
+  forall (In: nelistT Type),
+    let In' := list_of_Leibniz_of_list_of_types In in
+      function_type_of_morphism_signature In' Iff_Relation_Class ->
+      Morphism_Theory In' Iff_Relation_Class.
+  intros.
+  exists X.
+  induction In;  unfold make_compatibility_goal; simpl.
+    intro; apply iff_refl.
+    intro; apply (IHIn (X x)).
+Defined.
+
+(** * Utility functions to prove that every transitive relation is a morphism *)
+
+Definition equality_morphism_of_symmetric_areflexive_transitive_relation:
+ forall (A: Type)(Aeq: relation A)(sym: symmetric _ Aeq)(trans: transitive _ Aeq),
+  let ASetoidClass := SymmetricAreflexive _ sym in
+   (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class).
+ intros.
+ exists Aeq.
+ unfold make_compatibility_goal; simpl; split; eauto.
+Defined.
+
+Definition equality_morphism_of_symmetric_reflexive_transitive_relation:
+ forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(sym: symmetric _ Aeq)
+  (trans: transitive _ Aeq), let ASetoidClass := SymmetricReflexive _ sym refl in
+   (Morphism_Theory (necons ASetoidClass (singl ASetoidClass)) Iff_Relation_Class).
+ intros.
+ exists Aeq.
+ unfold make_compatibility_goal; simpl; split; eauto.
+Defined.
+
+Definition equality_morphism_of_asymmetric_areflexive_transitive_relation:
+ forall (A: Type)(Aeq: relation A)(trans: transitive _ Aeq),
+  let ASetoidClass1 := AsymmetricAreflexive Contravariant Aeq in
+  let ASetoidClass2 := AsymmetricAreflexive Covariant Aeq in
+   (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class).
+ intros.
+ exists Aeq.
+ unfold make_compatibility_goal; simpl; unfold impl; eauto.
+Defined.
+
+Definition equality_morphism_of_asymmetric_reflexive_transitive_relation:
+ forall (A: Type)(Aeq: relation A)(refl: reflexive _ Aeq)(trans: transitive _ Aeq),
+  let ASetoidClass1 := AsymmetricReflexive Contravariant refl in
+  let ASetoidClass2 := AsymmetricReflexive Covariant refl in
+   (Morphism_Theory (necons ASetoidClass1 (singl ASetoidClass2)) Impl_Relation_Class).
+ intros.
+ exists Aeq.
+ unfold make_compatibility_goal; simpl; unfold impl; eauto.
+Defined.
+
+(** * A few examples on [iff] *)
+
+(** [iff] as a relation *)
+
+Add Relation Prop iff
+  reflexivity proved by iff_refl
+  symmetry proved by iff_sym
+  transitivity proved by iff_trans
+as iff_relation.
+
+(** [impl] as a relation *)
+
+Theorem impl_trans: transitive _ impl.
+Proof.
+  hnf; unfold impl; tauto.
+Qed.
+
+Add Relation Prop impl
+  reflexivity proved by impl_refl
+  transitivity proved by impl_trans
+as impl_relation.
+
+(** [impl] is a morphism *)
 
-Section Setoid.
+Add Morphism impl with signature iff ==> iff ==> iff as Impl_Morphism.
+Proof.
+  unfold impl; tauto.
+Qed.
+
+(** [and] is a morphism *)
+
+Add Morphism and with signature iff ==> iff ==> iff as And_Morphism.
+ tauto.
+Qed.
 
-Variable A : Type.
-Variable Aeq : A -> A -> Prop.
+(** [or] is a morphism *)
 
-Record Setoid_Theory : Prop := 
-  {Seq_refl : forall x:A, Aeq x x;
-   Seq_sym : forall x y:A, Aeq x y -> Aeq y x;
-   Seq_trans : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z}.
+Add Morphism or with signature iff ==> iff ==> iff as Or_Morphism.
+Proof.
+  tauto.
+Qed.
 
-End Setoid.
+(** [not] is a morphism *)
 
-Definition Prop_S : Setoid_Theory Prop iff.
-split; [ exact iff_refl | exact iff_sym | exact iff_trans ].
+Add Morphism not with signature iff ==> iff as Not_Morphism.
+Proof.
+  tauto.
 Qed.
 
-Add Setoid Prop iff Prop_S.
+(** The same examples on [impl] *)
 
-Hint Resolve (Seq_refl Prop iff Prop_S): setoid.
-Hint Resolve (Seq_sym Prop iff Prop_S): setoid.
-Hint Resolve (Seq_trans Prop iff Prop_S): setoid.
+Add Morphism and with signature impl ++> impl ++> impl as And_Morphism2.
+Proof.
+  unfold impl; tauto.
+Qed.
 
-Add Morphism or : or_ext.
-intros.
-inversion H1.
-left.
-inversion H.
-apply (H3 H2).
+Add Morphism or with signature impl ++> impl ++> impl as Or_Morphism2.
+Proof.
+  unfold impl; tauto.
+Qed.
 
-right.
-inversion H0.
-apply (H3 H2).
+Add Morphism not with signature impl --> impl as Not_Morphism2.
+Proof.
+  unfold impl; tauto.
 Qed.
 
-Add Morphism and : and_ext.
-intros.
-inversion H1.
-split.
-inversion H.
-apply (H4 H2).
+(** * The CIC part of the reflexive tactic ([setoid_rewrite]) *)
+
+Inductive rewrite_direction : Type :=
+  | Left2Right
+  | Right2Left.
+
+Implicit Type dir: rewrite_direction.
+
+Definition variance_of_argument_class : Argument_Class -> option variance.
+  destruct 1.
+  exact None.
+  exact (Some v).
+  exact None.
+  exact (Some v).
+  exact None.
+Defined.
+
+Definition opposite_direction :=
+  fun dir =>
+    match dir with
+      | Left2Right => Right2Left
+      | Right2Left => Left2Right
+   end.
+
+Lemma opposite_direction_idempotent:
+  forall dir, (opposite_direction (opposite_direction dir)) = dir.
+Proof.
+  destruct dir; reflexivity.
+Qed.
+
+Inductive check_if_variance_is_respected :
+  option variance -> rewrite_direction -> rewrite_direction ->  Prop :=
+  | MSNone : forall dir dir', check_if_variance_is_respected None dir dir'
+  | MSCovariant : forall dir, check_if_variance_is_respected (Some Covariant) dir dir
+  | MSContravariant :
+    forall dir,
+      check_if_variance_is_respected (Some Contravariant) dir (opposite_direction dir).
+
+Definition relation_class_of_reflexive_relation_class:
+  Reflexive_Relation_Class -> Relation_Class.
+  induction 1.
+  exact (SymmetricReflexive _ s r).
+  exact (AsymmetricReflexive tt r).
+  exact (Leibniz _ T).
+Defined.
+
+Definition relation_class_of_areflexive_relation_class:
+  Areflexive_Relation_Class -> Relation_Class.
+  induction 1.
+    exact (SymmetricAreflexive _ s).
+    exact (AsymmetricAreflexive tt Aeq).
+Defined.
+
+Definition carrier_of_reflexive_relation_class :=
+  fun R => carrier_of_relation_class (relation_class_of_reflexive_relation_class R).
+
+Definition carrier_of_areflexive_relation_class :=
+  fun R => carrier_of_relation_class (relation_class_of_areflexive_relation_class R).
+
+Definition relation_of_areflexive_relation_class :=
+  fun R => relation_of_relation_class (relation_class_of_areflexive_relation_class R).
+
+Inductive Morphism_Context Hole dir : Relation_Class -> rewrite_direction ->  Type :=
+  | App :
+    forall In Out dir',
+      Morphism_Theory In Out -> Morphism_Context_List Hole dir dir' In ->
+      Morphism_Context Hole dir Out dir'
+  | ToReplace : Morphism_Context Hole dir Hole dir
+  | ToKeep :
+    forall S dir',
+      carrier_of_reflexive_relation_class S ->
+      Morphism_Context Hole dir (relation_class_of_reflexive_relation_class S) dir'
+  | ProperElementToKeep :
+    forall S dir' (x: carrier_of_areflexive_relation_class S),
+      relation_of_areflexive_relation_class S x x ->
+      Morphism_Context Hole dir (relation_class_of_areflexive_relation_class S) dir'
+with Morphism_Context_List Hole dir :
+   rewrite_direction -> Arguments -> Type
+:=
+    fcl_singl :
+      forall S dir' dir'',
+       check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' ->
+        Morphism_Context Hole dir (relation_class_of_argument_class S) dir' ->
+         Morphism_Context_List Hole dir dir'' (singl S)
+ | fcl_cons :
+      forall S L dir' dir'',
+       check_if_variance_is_respected (variance_of_argument_class S) dir' dir'' ->
+        Morphism_Context Hole dir (relation_class_of_argument_class S) dir' ->
+         Morphism_Context_List Hole dir dir'' L ->
+          Morphism_Context_List Hole dir dir'' (necons S L).
+
+Scheme Morphism_Context_rect2 := Induction for Morphism_Context  Sort Type
+with Morphism_Context_List_rect2 := Induction for Morphism_Context_List Sort Type.
+
+Definition product_of_arguments : Arguments -> Type.
+  induction 1.
+  exact (carrier_of_relation_class a).
+  exact (prod (carrier_of_relation_class a) IHX).
+Defined.
+
+Definition get_rewrite_direction: rewrite_direction -> Argument_Class -> rewrite_direction.
+  intros dir R.
+  destruct (variance_of_argument_class R).
+  destruct v.
+    exact dir.                      (* covariant *)
+    exact (opposite_direction dir). (* contravariant *)
+   exact dir.                       (* symmetric relation *)
+Defined.
 
-inversion H0.
-apply (H4 H3).
+Definition directed_relation_of_relation_class:
+  forall dir (R: Relation_Class),
+    carrier_of_relation_class R -> carrier_of_relation_class R -> Prop.
+  destruct 1.
+    exact (@relation_of_relation_class unit).
+    intros; exact (relation_of_relation_class _ X0 X).
+Defined.
+
+Definition directed_relation_of_argument_class:
+  forall dir (R: Argument_Class),
+    carrier_of_relation_class R -> carrier_of_relation_class R -> Prop.
+  intros dir R.
+  rewrite <-
+    (about_carrier_of_relation_class_and_relation_class_of_argument_class R).
+  exact (directed_relation_of_relation_class dir (relation_class_of_argument_class R)).
+Defined.
+
+
+Definition relation_of_product_of_arguments:
+  forall dir In,
+    product_of_arguments In -> product_of_arguments In -> Prop.
+  induction In.
+    simpl.
+      exact (directed_relation_of_argument_class (get_rewrite_direction dir a) a).
+
+    simpl; intros.
+      destruct X; destruct X0.
+   apply and.
+     exact
+      (directed_relation_of_argument_class (get_rewrite_direction dir a) a c c0).
+     exact (IHIn p p0).
+Defined. 
+
+Definition apply_morphism:
+  forall In Out (m: function_type_of_morphism_signature In Out)
+    (args: product_of_arguments In), carrier_of_relation_class Out.
+  intros.
+  induction In.
+    exact (m args).
+    simpl in m, args.
+    destruct args.
+    exact (IHIn (m c) p).
+Defined.
+
+Theorem apply_morphism_compatibility_Right2Left:
+  forall In Out (m1 m2: function_type_of_morphism_signature In Out)
+    (args1 args2: product_of_arguments In),
+    make_compatibility_goal_aux _ _ m1 m2 ->
+    relation_of_product_of_arguments Right2Left _ args1 args2 ->
+    directed_relation_of_relation_class Right2Left _
+    (apply_morphism _ _ m2 args1)
+    (apply_morphism _ _ m1 args2).
+  induction In; intros.
+    simpl in m1, m2, args1, args2, H0 |- *.
+    destruct a; simpl in H; hnf in H0.
+      apply H; exact H0.
+      destruct v; simpl in H0; apply H; exact H0.
+      apply H; exact H0.
+      destruct v; simpl in H0; apply H; exact H0.
+      rewrite H0; apply H; exact H0.
+
+   simpl in m1, m2, args1, args2, H0 |- *.
+   destruct args1; destruct args2; simpl.
+   destruct H0.
+   simpl in H.
+   destruct a; simpl in H.
+     apply IHIn.
+       apply H; exact H0.
+       exact H1.
+     destruct v.
+       apply IHIn.
+         apply H; exact H0.
+         exact H1.
+       apply IHIn.
+         apply H; exact H0.       
+          exact H1.
+     apply IHIn.
+       apply H; exact H0.
+       exact H1.
+     destruct v.
+       apply IHIn.
+         apply H; exact H0.
+         exact H1.
+       apply IHIn.
+         apply H; exact H0.       
+          exact H1.
+    rewrite H0; apply IHIn.
+      apply H.
+      exact H1.
 Qed.
 
-Add Morphism not : not_ext.
-red in |- *; intros.
-apply H0.
-inversion H.
-apply (H3 H1).
+Theorem apply_morphism_compatibility_Left2Right:
+  forall In Out (m1 m2: function_type_of_morphism_signature In Out)
+    (args1 args2: product_of_arguments In),
+    make_compatibility_goal_aux _ _ m1 m2 ->
+    relation_of_product_of_arguments Left2Right _ args1 args2 ->
+    directed_relation_of_relation_class Left2Right _
+    (apply_morphism _ _ m1 args1)
+    (apply_morphism _ _ m2 args2).
+Proof.
+  induction In; intros.
+    simpl in m1, m2, args1, args2, H0 |- *.
+    destruct a; simpl in H; hnf in H0.
+      apply H; exact H0.
+      destruct v; simpl in H0; apply H; exact H0.
+      apply H; exact H0.
+      destruct v; simpl in H0; apply H; exact H0.
+      rewrite H0; apply H; exact H0.
+
+  simpl in m1, m2, args1, args2, H0 |- *.
+    destruct args1; destruct args2; simpl.
+    destruct H0.
+    simpl in H.
+    destruct a; simpl in H.
+      apply IHIn.
+        apply H; exact H0.
+        exact H1.
+      destruct v.
+        apply IHIn.
+          apply H; exact H0.
+          exact H1.
+        apply IHIn.
+          apply H; exact H0.       
+           exact H1.
+        apply IHIn.
+          apply H; exact H0.
+          exact H1.
+        apply IHIn.
+          destruct v; simpl in H, H0; apply H; exact H0. 
+            exact H1.
+      rewrite H0; apply IHIn.
+        apply H.
+        exact H1.
 Qed.
 
-Definition fleche (A B:Prop) := A -> B.
+Definition interp :
+ forall Hole dir Out dir', carrier_of_relation_class Hole ->
+  Morphism_Context Hole dir Out dir' -> carrier_of_relation_class Out.
+ intros Hole dir Out dir' H t.
+ elim t using
+  (@Morphism_Context_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S)
+    (fun _ L fcl => product_of_arguments L));
+  intros.
+   exact (apply_morphism _ _ (Function m) X).
+   exact H.
+   exact c.
+   exact x.
+   simpl;
+     rewrite <-
+       (about_carrier_of_relation_class_and_relation_class_of_argument_class S);
+     exact X.
+   split.
+     rewrite <-
+       (about_carrier_of_relation_class_and_relation_class_of_argument_class S);
+       exact X.
+       exact X0.
+Defined.
+
+(* CSC: interp and interp_relation_class_list should be mutually defined, since
+   the proof term of each one contains the proof term of the other one. However
+   I cannot do that interactively (I should write the Fix by hand) *)
+Definition interp_relation_class_list :
+  forall Hole dir dir' (L: Arguments), carrier_of_relation_class Hole ->
+    Morphism_Context_List Hole dir dir' L -> product_of_arguments L.
+  intros Hole dir dir' L H t.
+  elim t using
+    (@Morphism_Context_List_rect2 Hole dir (fun S _ _ => carrier_of_relation_class S)
+      (fun _ L fcl => product_of_arguments L));
+    intros.
+  exact (apply_morphism _ _ (Function m) X).
+  exact H.
+  exact c.
+  exact x.
+  simpl;
+    rewrite <-
+      (about_carrier_of_relation_class_and_relation_class_of_argument_class S);
+      exact X.
+  split.
+  rewrite <-
+    (about_carrier_of_relation_class_and_relation_class_of_argument_class S);
+    exact X.
+  exact X0.
+Defined.
+
+Theorem setoid_rewrite:
+  forall Hole dir Out dir' (E1 E2: carrier_of_relation_class Hole)
+    (E: Morphism_Context Hole dir Out dir'),
+    (directed_relation_of_relation_class dir Hole E1 E2) ->
+    (directed_relation_of_relation_class dir' Out (interp E1 E) (interp E2 E)).
+Proof.
+  intros.
+  elim E using
+    (@Morphism_Context_rect2 Hole dir
+      (fun S dir'' E => directed_relation_of_relation_class dir'' S (interp E1 E) (interp E2 E))
+      (fun dir'' L fcl =>
+        relation_of_product_of_arguments dir'' _
+        (interp_relation_class_list E1 fcl)
+        (interp_relation_class_list E2 fcl))); intros.
+  change (directed_relation_of_relation_class dir'0 Out0
+    (apply_morphism _ _ (Function m) (interp_relation_class_list E1 m0))
+    (apply_morphism _ _ (Function m) (interp_relation_class_list E2 m0))).
+  destruct dir'0.
+    apply apply_morphism_compatibility_Left2Right.
+      exact (Compat m).
+      exact H0.
+    apply apply_morphism_compatibility_Right2Left.
+      exact (Compat m).
+      exact H0.
+
+  exact H.
+
+  unfold interp, Morphism_Context_rect2.
+  (* CSC: reflexivity used here *)
+  destruct S; destruct dir'0; simpl; (apply r || reflexivity).
+  
+  destruct dir'0; exact r.
+
+  destruct S; unfold directed_relation_of_argument_class; simpl in H0 |- *;
+    unfold get_rewrite_direction; simpl.
+  destruct dir'0; destruct dir'';
+    (exact H0 ||
+      unfold directed_relation_of_argument_class; simpl; apply s; exact H0).
+  (* the following mess with generalize/clear/intros is to help Coq resolving *)
+  (* second order unification problems.                                       *)
+  generalize m c H0; clear H0 m c; inversion c;
+    generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros;
+      (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3).
+  destruct dir'0; destruct dir'';
+    (exact H0 ||
+      unfold directed_relation_of_argument_class; simpl; apply s; exact H0).
+  (* the following mess with generalize/clear/intros is to help Coq resolving *)
+  (* second order unification problems.                                       *)
+  generalize m c H0; clear H0 m c; inversion c;
+    generalize m c; clear m c; rewrite <- H1; rewrite <- H2; intros;
+      (exact H3 || rewrite (opposite_direction_idempotent dir'0); apply H3).
+  destruct dir'0; destruct dir''; (exact H0 || hnf; symmetry; exact H0).
+
+  change
+    (directed_relation_of_argument_class (get_rewrite_direction dir'' S) S
+       (eq_rect _ (fun T : Type => T) (interp E1 m) _
+         (about_carrier_of_relation_class_and_relation_class_of_argument_class S))
+       (eq_rect _ (fun T : Type => T) (interp E2 m) _
+         (about_carrier_of_relation_class_and_relation_class_of_argument_class S)) /\
+       relation_of_product_of_arguments dir'' _
+       (interp_relation_class_list E1 m0) (interp_relation_class_list E2 m0)).
+  split.
+  clear m0 H1; destruct S; simpl in H0 |- *; unfold get_rewrite_direction; simpl.
+    destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0).
+      inversion c.
+        rewrite <- H3; exact H0.
+        rewrite (opposite_direction_idempotent dir'0); exact H0.
+      destruct dir''; destruct dir'0; (exact H0 || hnf; apply s; exact H0).
+      inversion c.
+        rewrite <- H3; exact H0.
+        rewrite (opposite_direction_idempotent dir'0); exact H0.
+      destruct dir''; destruct dir'0; (exact H0 || hnf; symmetry; exact H0).
+    exact H1.
+  Qed.
+
+(** * Miscelenous *)
+
+(** For backwark compatibility *)
+
+Record Setoid_Theory  (A: Type) (Aeq: relation A) : Prop := 
+  { Seq_refl : forall x:A, Aeq x x;
+    Seq_sym : forall x y:A, Aeq x y -> Aeq y x;
+    Seq_trans : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z }.
+
+Implicit Arguments Setoid_Theory [].
+Implicit Arguments Seq_refl [].
+Implicit Arguments Seq_sym [].
+Implicit Arguments Seq_trans [].
+
+
+(** Some tactics for manipulating Setoid Theory not officially 
+    declared as Setoid. *)
+
+Ltac trans_st x := match goal with 
+		     | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+		       apply (Seq_trans _ _ H) with x; auto
+		   end.
+
+Ltac sym_st := match goal with 
+		 | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+		   apply (Seq_sym _ _ H); auto
+	       end.
+
+Ltac refl_st := match goal with 
+		  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+		    apply (Seq_refl _ _ H); auto
+		end.
 
-Add Morphism fleche : fleche_ext.
-unfold fleche in |- *.
-intros.
-inversion H0.
-inversion H.
-apply (H3 (H1 (H6 H2))).
+Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A).
+Proof. 
+  constructor; congruence. 
 Qed.
+  
diff --git a/theories/Setoids/intro.tex b/theories/Setoids/intro.tex
new file mode 100644
index 00000000..50cd025d
--- /dev/null
+++ b/theories/Setoids/intro.tex
@@ -0,0 +1 @@
+\section{Setoids}\label{Setoids}
diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v
index 98cb14e4..e6755898 100755..100644
--- a/theories/Sets/Classical_sets.v
+++ b/theories/Sets/Classical_sets.v
@@ -24,109 +24,104 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Classical_sets.v,v 1.4.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Classical_sets.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Ensembles.
 Require Export Constructive_sets.
 Require Export Classical_Type.
 
-(* Hints Unfold  not . *)
-
 Section Ensembles_classical.
-Variable U : Type.
-
-Lemma not_included_empty_Inhabited :
- forall A:Ensemble U, ~ Included U A (Empty_set U) -> Inhabited U A.
-Proof.
-intros A NI.
-elim (not_all_ex_not U (fun x:U => ~ In U A x)).
-intros x H; apply Inhabited_intro with x.
-apply NNPP; auto with sets.
-red in |- *; intro.
-apply NI; red in |- *.
-intros x H'; elim (H x); trivial with sets.
-Qed.
-Hint Resolve not_included_empty_Inhabited.
-
-Lemma not_empty_Inhabited :
- forall A:Ensemble U, A <> Empty_set U -> Inhabited U A.
-Proof.
-intros; apply not_included_empty_Inhabited.
-red in |- *; auto with sets.
-Qed.
-
-Lemma Inhabited_Setminus :
- forall X Y:Ensemble U,
-   Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X).
-Proof.
-intros X Y I NI. 
-elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI).
-intros x YX.
-apply Inhabited_intro with x.
-apply Setminus_intro.
-apply not_imply_elim with (In U X x); trivial with sets.
-auto with sets.
-Qed.
-Hint Resolve Inhabited_Setminus.
-
-Lemma Strict_super_set_contains_new_element :
- forall X Y:Ensemble U,
-   Included U X Y -> X <> Y -> Inhabited U (Setminus U Y X).
-Proof.
-auto 7 with sets.
-Qed.
-Hint Resolve Strict_super_set_contains_new_element.
-
-Lemma Subtract_intro :
- forall (A:Ensemble U) (x y:U), In U A y -> x <> y -> In U (Subtract U A x) y.
-Proof.
-unfold Subtract at 1 in |- *; auto with sets.
-Qed.
-Hint Resolve Subtract_intro.
-
-Lemma Subtract_inv :
- forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y.
-Proof.
-intros A x y H'; elim H'; auto with sets.
-Qed.
-
-Lemma Included_Strict_Included :
- forall X Y:Ensemble U, Included U X Y -> Strict_Included U X Y \/ X = Y.
-Proof.
-intros X Y H'; try assumption.
-elim (classic (X = Y)); auto with sets.
-Qed.
-
-Lemma Strict_Included_inv :
- forall X Y:Ensemble U,
-   Strict_Included U X Y -> Included U X Y /\ Inhabited U (Setminus U Y X).
-Proof.
-intros X Y H'; red in H'.
-split; [ tauto | idtac ].
-elim H'; intros H'0 H'1; try exact H'1; clear H'.
-apply Strict_super_set_contains_new_element; auto with sets.
-Qed.
-
-Lemma not_SIncl_empty :
- forall X:Ensemble U, ~ Strict_Included U X (Empty_set U).
-Proof.
-intro X; red in |- *; intro H'; try exact H'.
-lapply (Strict_Included_inv X (Empty_set U)); auto with sets.
-intro H'0; elim H'0; intros H'1 H'2; elim H'2; clear H'0.
-intros x H'0; elim H'0.
-intro H'3; elim H'3.
-Qed.
-
-Lemma Complement_Complement :
- forall A:Ensemble U, Complement U (Complement U A) = A.
-Proof.
-unfold Complement in |- *; intros; apply Extensionality_Ensembles;
- auto with sets.
-red in |- *; split; auto with sets.
-red in |- *; intros; apply NNPP; auto with sets.
-Qed.
+  Variable U : Type.
+
+  Lemma not_included_empty_Inhabited :
+    forall A:Ensemble U, ~ Included U A (Empty_set U) -> Inhabited U A.
+  Proof.
+    intros A NI.
+    elim (not_all_ex_not U (fun x:U => ~ In U A x)).
+    intros x H; apply Inhabited_intro with x.
+    apply NNPP; auto with sets.
+    red in |- *; intro.
+    apply NI; red in |- *.
+    intros x H'; elim (H x); trivial with sets.
+  Qed.
+
+  Lemma not_empty_Inhabited :
+    forall A:Ensemble U, A <> Empty_set U -> Inhabited U A.
+  Proof.
+    intros; apply not_included_empty_Inhabited.
+    red in |- *; auto with sets.
+  Qed.
+
+  Lemma Inhabited_Setminus :
+    forall X Y:Ensemble U,
+      Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X).
+  Proof.
+    intros X Y I NI. 
+    elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI).
+    intros x YX.
+    apply Inhabited_intro with x.
+    apply Setminus_intro.
+    apply not_imply_elim with (In U X x); trivial with sets.
+    auto with sets.
+  Qed.
+
+  Lemma Strict_super_set_contains_new_element :
+    forall X Y:Ensemble U,
+      Included U X Y -> X <> Y -> Inhabited U (Setminus U Y X).
+  Proof.
+    auto 7 using Inhabited_Setminus with sets.
+  Qed.
+
+  Lemma Subtract_intro :
+    forall (A:Ensemble U) (x y:U), In U A y -> x <> y -> In U (Subtract U A x) y.
+  Proof.
+    unfold Subtract at 1 in |- *; auto with sets.
+  Qed.
+  Hint Resolve Subtract_intro : sets.
+  
+  Lemma Subtract_inv :
+    forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y.
+  Proof.
+    intros A x y H'; elim H'; auto with sets.
+  Qed.
+
+  Lemma Included_Strict_Included :
+    forall X Y:Ensemble U, Included U X Y -> Strict_Included U X Y \/ X = Y.
+  Proof.
+    intros X Y H'; try assumption.
+    elim (classic (X = Y)); auto with sets.
+  Qed.
+
+  Lemma Strict_Included_inv :
+    forall X Y:Ensemble U,
+      Strict_Included U X Y -> Included U X Y /\ Inhabited U (Setminus U Y X).
+  Proof.
+    intros X Y H'; red in H'.
+    split; [ tauto | idtac ].
+    elim H'; intros H'0 H'1; try exact H'1; clear H'.
+    apply Strict_super_set_contains_new_element; auto with sets.
+  Qed.
+
+  Lemma not_SIncl_empty :
+    forall X:Ensemble U, ~ Strict_Included U X (Empty_set U).
+  Proof.
+    intro X; red in |- *; intro H'; try exact H'.
+    lapply (Strict_Included_inv X (Empty_set U)); auto with sets.
+    intro H'0; elim H'0; intros H'1 H'2; elim H'2; clear H'0.
+    intros x H'0; elim H'0.
+    intro H'3; elim H'3.
+  Qed.
+
+  Lemma Complement_Complement :
+    forall A:Ensemble U, Complement U (Complement U A) = A.
+  Proof.
+    unfold Complement in |- *; intros; apply Extensionality_Ensembles;
+      auto with sets.
+    red in |- *; split; auto with sets.
+    red in |- *; intros; apply NNPP; auto with sets.
+  Qed.
 
 End Ensembles_classical.
 
-Hint Resolve Strict_super_set_contains_new_element Subtract_intro
-  not_SIncl_empty: sets v62.
\ No newline at end of file
+ Hint Resolve Strict_super_set_contains_new_element Subtract_intro
+  not_SIncl_empty: sets v62.
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
index a2bc781d..ad81316d 100755..100644
--- a/theories/Sets/Constructive_sets.v
+++ b/theories/Sets/Constructive_sets.v
@@ -24,136 +24,123 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Constructive_sets.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Constructive_sets.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Ensembles.
 
 Section Ensembles_facts.
-Variable U : Type.
-
-Lemma Extension : forall B C:Ensemble U, B = C -> Same_set U B C.
-Proof.
-intros B C H'; rewrite H'; auto with sets.
-Qed.
-
-Lemma Noone_in_empty : forall x:U, ~ In U (Empty_set U) x.
-Proof.
-red in |- *; destruct 1.
-Qed.
-Hint Resolve Noone_in_empty.
-
-Lemma Included_Empty : forall A:Ensemble U, Included U (Empty_set U) A.
-Proof.
-intro; red in |- *.
-intros x H; elim (Noone_in_empty x); auto with sets.
-Qed.
-Hint Resolve Included_Empty.
-
-Lemma Add_intro1 :
- forall (A:Ensemble U) (x y:U), In U A y -> In U (Add U A x) y.
-Proof.
-unfold Add at 1 in |- *; auto with sets.
-Qed.
-Hint Resolve Add_intro1.
-
-Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x.
-Proof.
-unfold Add at 1 in |- *; auto with sets.
-Qed.
-Hint Resolve Add_intro2.
-
-Lemma Inhabited_add : forall (A:Ensemble U) (x:U), Inhabited U (Add U A x).
-Proof.
-intros A x.
-apply Inhabited_intro with (x := x); auto with sets.
-Qed.
-Hint Resolve Inhabited_add.
-
-Lemma Inhabited_not_empty :
- forall X:Ensemble U, Inhabited U X -> X <> Empty_set U.
-Proof.
-intros X H'; elim H'.
-intros x H'0; red in |- *; intro H'1.
-absurd (In U X x); auto with sets.
-rewrite H'1; auto with sets.
-Qed.
-Hint Resolve Inhabited_not_empty.
-
-Lemma Add_not_Empty : forall (A:Ensemble U) (x:U), Add U A x <> Empty_set U.
-Proof.
-auto with sets.
-Qed.
-Hint Resolve Add_not_Empty.
-
-Lemma not_Empty_Add : forall (A:Ensemble U) (x:U), Empty_set U <> Add U A x.
-Proof.
-intros; red in |- *; intro H; generalize (Add_not_Empty A x); auto with sets.
-Qed.
-Hint Resolve not_Empty_Add.
-
-Lemma Singleton_inv : forall x y:U, In U (Singleton U x) y -> x = y.
-Proof.
-intros x y H'; elim H'; trivial with sets.
-Qed.
-Hint Resolve Singleton_inv.
-
-Lemma Singleton_intro : forall x y:U, x = y -> In U (Singleton U x) y.
-Proof.
-intros x y H'; rewrite H'; trivial with sets.
-Qed.
-Hint Resolve Singleton_intro.
-
-Lemma Union_inv :
- forall (B C:Ensemble U) (x:U), In U (Union U B C) x -> In U B x \/ In U C x.
-Proof.
-intros B C x H'; elim H'; auto with sets.
-Qed.
-
-Lemma Add_inv :
- forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y.
-Proof.
-intros A x y H'; elim H'; auto with sets.
-Qed.
-
-Lemma Intersection_inv :
- forall (B C:Ensemble U) (x:U),
-   In U (Intersection U B C) x -> In U B x /\ In U C x.
-Proof.
-intros B C x H'; elim H'; auto with sets.
-Qed.
-Hint Resolve Intersection_inv.
-
-Lemma Couple_inv : forall x y z:U, In U (Couple U x y) z -> z = x \/ z = y.
-Proof.
-intros x y z H'; elim H'; auto with sets.
-Qed.
-Hint Resolve Couple_inv.
-
-Lemma Setminus_intro :
- forall (A B:Ensemble U) (x:U),
-   In U A x -> ~ In U B x -> In U (Setminus U A B) x.
-Proof.
-unfold Setminus at 1 in |- *; red in |- *; auto with sets.
-Qed.
-Hint Resolve Setminus_intro.
+  Variable U : Type.
+  
+  Lemma Extension : forall B C:Ensemble U, B = C -> Same_set U B C.
+  Proof.
+    intros B C H'; rewrite H'; auto with sets.
+  Qed.
+
+  Lemma Noone_in_empty : forall x:U, ~ In U (Empty_set U) x.
+  Proof.
+    red in |- *; destruct 1.
+  Qed.
+
+  Lemma Included_Empty : forall A:Ensemble U, Included U (Empty_set U) A.
+  Proof.
+    intro; red in |- *.
+    intros x H; elim (Noone_in_empty x); auto with sets.
+  Qed.
+
+  Lemma Add_intro1 :
+    forall (A:Ensemble U) (x y:U), In U A y -> In U (Add U A x) y.
+  Proof.
+    unfold Add at 1 in |- *; auto with sets.
+  Qed.
+  
+  Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x.
+  Proof.
+    unfold Add at 1 in |- *; auto with sets.
+  Qed.
+
+  Lemma Inhabited_add : forall (A:Ensemble U) (x:U), Inhabited U (Add U A x).
+  Proof.
+    intros A x.
+    apply Inhabited_intro with (x := x); auto using Add_intro2 with sets.
+  Qed.
+
+  Lemma Inhabited_not_empty :
+    forall X:Ensemble U, Inhabited U X -> X <> Empty_set U.
+  Proof.
+    intros X H'; elim H'.
+    intros x H'0; red in |- *; intro H'1.
+    absurd (In U X x); auto with sets.
+    rewrite H'1; auto using Noone_in_empty with sets.
+  Qed.
+
+  Lemma Add_not_Empty : forall (A:Ensemble U) (x:U), Add U A x <> Empty_set U.
+  Proof.
+    intros A x; apply Inhabited_not_empty; apply Inhabited_add.
+  Qed.
+
+  Lemma not_Empty_Add : forall (A:Ensemble U) (x:U), Empty_set U <> Add U A x.
+  Proof.
+    intros; red in |- *; intro H; generalize (Add_not_Empty A x); auto with sets.
+  Qed.
+
+  Lemma Singleton_inv : forall x y:U, In U (Singleton U x) y -> x = y.
+  Proof.
+    intros x y H'; elim H'; trivial with sets.
+  Qed.
+
+  Lemma Singleton_intro : forall x y:U, x = y -> In U (Singleton U x) y.
+  Proof.
+    intros x y H'; rewrite H'; trivial with sets.
+  Qed.
+
+  Lemma Union_inv :
+    forall (B C:Ensemble U) (x:U), In U (Union U B C) x -> In U B x \/ In U C x.
+  Proof.
+    intros B C x H'; elim H'; auto with sets.
+  Qed.
+  
+  Lemma Add_inv :
+    forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y.
+  Proof.
+    intros A x y H'; induction H'. 
+      left; assumption.
+      right; apply Singleton_inv; assumption.
+  Qed.
+  
+  Lemma Intersection_inv :
+    forall (B C:Ensemble U) (x:U),
+      In U (Intersection U B C) x -> In U B x /\ In U C x.
+  Proof.
+    intros B C x H'; elim H'; auto with sets.
+  Qed.
+
+  Lemma Couple_inv : forall x y z:U, In U (Couple U x y) z -> z = x \/ z = y.
+  Proof.
+    intros x y z H'; elim H'; auto with sets.
+  Qed.
+
+  Lemma Setminus_intro :
+    forall (A B:Ensemble U) (x:U),
+      In U A x -> ~ In U B x -> In U (Setminus U A B) x.
+  Proof.
+    unfold Setminus at 1 in |- *; red in |- *; auto with sets.
+  Qed.
  
-Lemma Strict_Included_intro :
- forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y.
-Proof.
-auto with sets.
-Qed.
-Hint Resolve Strict_Included_intro.
-
-Lemma Strict_Included_strict : forall X:Ensemble U, ~ Strict_Included U X X.
-Proof.
-intro X; red in |- *; intro H'; elim H'.
-intros H'0 H'1; elim H'1; auto with sets.
-Qed.
-Hint Resolve Strict_Included_strict.
+  Lemma Strict_Included_intro :
+    forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y.
+  Proof.
+    auto with sets.
+  Qed.
+
+  Lemma Strict_Included_strict : forall X:Ensemble U, ~ Strict_Included U X X.
+  Proof.
+    intro X; red in |- *; intro H'; elim H'.
+    intros H'0 H'1; elim H'1; auto with sets.
+  Qed.
 
 End Ensembles_facts.
 
 Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2
   Intersection_inv Couple_inv Setminus_intro Strict_Included_intro
   Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty
-  not_Empty_Add Inhabited_add Included_Empty: sets v62.
\ No newline at end of file
+  not_Empty_Add Inhabited_add Included_Empty: sets v62.
diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v
index 9fae12f5..1e1b70d5 100755..100644
--- a/theories/Sets/Cpo.v
+++ b/theories/Sets/Cpo.v
@@ -24,86 +24,87 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Cpo.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Cpo.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Ensembles.
 Require Export Relations_1.
 Require Export Partial_Order.
 
 Section Bounds.
-Variable U : Type.
-Variable D : PO U.
+  Variable U : Type.
+  Variable D : PO U.
 
-Let C := Carrier_of U D.
+  Let C := Carrier_of U D.
+  
+  Let R := Rel_of U D.
 
-Let R := Rel_of U D.
-
-Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop :=
+  Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop :=
     Upper_Bound_definition :
-      In U C x -> (forall y:U, In U B y -> R y x) -> Upper_Bound B x.
+    In U C x -> (forall y:U, In U B y -> R y x) -> Upper_Bound B x.
 
-Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop :=
+  Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop :=
     Lower_Bound_definition :
-      In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x.
-
-Inductive Lub (B:Ensemble U) (x:U) : Prop :=
+    In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x.
+  
+  Inductive Lub (B:Ensemble U) (x:U) : Prop :=
     Lub_definition :
-      Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x.
+    Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x.
 
-Inductive Glb (B:Ensemble U) (x:U) : Prop :=
+  Inductive Glb (B:Ensemble U) (x:U) : Prop :=
     Glb_definition :
-      Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x.
+    Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x.
 
-Inductive Bottom (bot:U) : Prop :=
+  Inductive Bottom (bot:U) : Prop :=
     Bottom_definition :
-      In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot.
-
-Inductive Totally_ordered (B:Ensemble U) : Prop :=
+    In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot.
+  
+  Inductive Totally_ordered (B:Ensemble U) : Prop :=
     Totally_ordered_definition :
-      (Included U B C ->
-       forall x y:U, Included U (Couple U x y) B -> R x y \/ R y x) ->
-      Totally_ordered B.
+    (Included U B C ->
+      forall x y:U, Included U (Couple U x y) B -> R x y \/ R y x) ->
+    Totally_ordered B.
 
-Definition Compatible : Relation U :=
-  fun x y:U =>
-    In U C x ->
-    In U C y ->  exists z : _, In U C z /\ Upper_Bound (Couple U x y) z.
-	
-Inductive Directed (X:Ensemble U) : Prop :=
-    Definition_of_Directed :
-      Included U X C ->
-      Inhabited U X ->
-      (forall x1 x2:U,
-         Included U (Couple U x1 x2) X ->
-          exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) ->
-      Directed X.
+  Definition Compatible : Relation U :=
+    fun x y:U =>
+      In U C x ->
+      In U C y ->  exists z : _, In U C z /\ Upper_Bound (Couple U x y) z.
 
-Inductive Complete : Prop :=
+  Inductive Directed (X:Ensemble U) : Prop :=
+    Definition_of_Directed :
+    Included U X C ->
+    Inhabited U X ->
+    (forall x1 x2:U,
+      Included U (Couple U x1 x2) X ->
+      exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) ->
+    Directed X.
+  
+  Inductive Complete : Prop :=
     Definition_of_Complete :
-      (exists bot : _, Bottom bot) ->
-      (forall X:Ensemble U, Directed X ->  exists bsup : _, Lub X bsup) ->
-      Complete.
+    (exists bot : _, Bottom bot) ->
+    (forall X:Ensemble U, Directed X ->  exists bsup : _, Lub X bsup) ->
+    Complete.
 
-Inductive Conditionally_complete : Prop :=
+  Inductive Conditionally_complete : Prop :=
     Definition_of_Conditionally_complete :
-      (forall X:Ensemble U,
-         Included U X C ->
-         (exists maj : _, Upper_Bound X maj) ->
-          exists bsup : _, Lub X bsup) -> Conditionally_complete.
+    (forall X:Ensemble U,
+      Included U X C ->
+      (exists maj : _, Upper_Bound X maj) ->
+      exists bsup : _, Lub X bsup) -> Conditionally_complete.
 End Bounds.
+
 Hint Resolve Totally_ordered_definition Upper_Bound_definition
   Lower_Bound_definition Lub_definition Glb_definition Bottom_definition
   Definition_of_Complete Definition_of_Complete
   Definition_of_Conditionally_complete.
 
 Section Specific_orders.
-Variable U : Type.
-
-Record Cpo : Type := Definition_of_cpo
-  {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}.
-
-Record Chain : Type := Definition_of_chain
-  {PO_of_chain : PO U;
-   Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}.
+  Variable U : Type.
+
+  Record Cpo : Type := Definition_of_cpo
+    {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}.
+  
+  Record Chain : Type := Definition_of_chain
+    {PO_of_chain : PO U;
+    Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}.
 
 End Specific_orders.
\ No newline at end of file
diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v
index 05afc298..c38a2fe1 100755..100644
--- a/theories/Sets/Ensembles.v
+++ b/theories/Sets/Ensembles.v
@@ -24,72 +24,71 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Ensembles.v,v 1.7.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Ensembles.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Section Ensembles.
-Variable U : Type.
-
-Definition Ensemble := U -> Prop. 
-
-Definition In (A:Ensemble) (x:U) : Prop := A x.
-
-Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x.
-
-Inductive Empty_set : Ensemble :=.
-
-Inductive Full_set : Ensemble :=
+  Variable U : Type.
+  
+  Definition Ensemble := U -> Prop. 
+
+  Definition In (A:Ensemble) (x:U) : Prop := A x.
+  
+  Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x.
+  
+  Inductive Empty_set : Ensemble :=.
+  
+  Inductive Full_set : Ensemble :=
     Full_intro : forall x:U, In Full_set x.
 
 (** NB: The following definition builds-in equality of elements in [U] as 
-   Leibniz equality. 
+     Leibniz equality. 
 
-   This may have to be changed if we replace [U] by a Setoid on [U] 
-   with its own equality [eqs], with  
-   [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *)
+     This may have to be changed if we replace [U] by a Setoid on [U] 
+     with its own equality [eqs], with  
+     [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *)
 
-Inductive Singleton (x:U) : Ensemble :=
+  Inductive Singleton (x:U) : Ensemble :=
     In_singleton : In (Singleton x) x.
 
-Inductive Union (B C:Ensemble) : Ensemble :=
-  | Union_introl : forall x:U, In B x -> In (Union B C) x
-  | Union_intror : forall x:U, In C x -> In (Union B C) x.
-
-Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x).
+  Inductive Union (B C:Ensemble) : Ensemble :=
+    | Union_introl : forall x:U, In B x -> In (Union B C) x
+    | Union_intror : forall x:U, In C x -> In (Union B C) x.
 
-Inductive Intersection (B C:Ensemble) : Ensemble :=
+  Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x).
+  
+  Inductive Intersection (B C:Ensemble) : Ensemble :=
     Intersection_intro :
-      forall x:U, In B x -> In C x -> In (Intersection B C) x.
-
-Inductive Couple (x y:U) : Ensemble :=
-  | Couple_l : In (Couple x y) x
-  | Couple_r : In (Couple x y) y.
-
-Inductive Triple (x y z:U) : Ensemble :=
-  | Triple_l : In (Triple x y z) x
-  | Triple_m : In (Triple x y z) y
-  | Triple_r : In (Triple x y z) z.
-
-Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x.
-
-Definition Setminus (B C:Ensemble) : Ensemble :=
-  fun x:U => In B x /\ ~ In C x.
-
-Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x).
-
-Inductive Disjoint (B C:Ensemble) : Prop :=
+    forall x:U, In B x -> In C x -> In (Intersection B C) x.
+
+  Inductive Couple (x y:U) : Ensemble :=
+    | Couple_l : In (Couple x y) x
+    | Couple_r : In (Couple x y) y.
+  
+  Inductive Triple (x y z:U) : Ensemble :=
+    | Triple_l : In (Triple x y z) x
+    | Triple_m : In (Triple x y z) y
+    | Triple_r : In (Triple x y z) z.
+  
+  Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x.
+  
+  Definition Setminus (B C:Ensemble) : Ensemble :=
+    fun x:U => In B x /\ ~ In C x.
+  
+  Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x).
+  
+  Inductive Disjoint (B C:Ensemble) : Prop :=
     Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C.
 
-Inductive Inhabited (B:Ensemble) : Prop :=
+  Inductive Inhabited (B:Ensemble) : Prop :=
     Inhabited_intro : forall x:U, In B x -> Inhabited B.
+  
+  Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C.
+  
+  Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B.
+  
+  (** Extensionality Axiom *)
 
-Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C.
-
-Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B.
-
-(** Extensionality Axiom *)
-
-Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B.
-Hint Resolve Extensionality_Ensembles.
+  Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B.
 
 End Ensembles.
 
@@ -98,4 +97,4 @@ Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets
 
 Hint Resolve Union_introl Union_intror Intersection_intro In_singleton
   Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro
-  Extensionality_Ensembles: sets v62.
\ No newline at end of file
+  Extensionality_Ensembles: sets v62.
diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v
index 5a2e4397..f5eae4ed 100755..100644
--- a/theories/Sets/Finite_sets.v
+++ b/theories/Sets/Finite_sets.v
@@ -24,22 +24,22 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Finite_sets.v,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Finite_sets.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Ensembles.
 
 Section Ensembles_finis.
-Variable U : Type.
+  Variable U : Type.
 
-Inductive Finite : Ensemble U -> Prop :=
-  | Empty_is_finite : Finite (Empty_set U)
-  | Union_is_finite :
+  Inductive Finite : Ensemble U -> Prop :=
+    | Empty_is_finite : Finite (Empty_set U)
+    | Union_is_finite :
       forall A:Ensemble U,
         Finite A -> forall x:U, ~ In U A x -> Finite (Add U A x).
 
-Inductive cardinal : Ensemble U -> nat -> Prop :=
-  | card_empty : cardinal (Empty_set U) 0
-  | card_add :
+  Inductive cardinal : Ensemble U -> nat -> Prop :=
+    | card_empty : cardinal (Empty_set U) 0
+    | card_add :
       forall (A:Ensemble U) (n:nat),
         cardinal A n -> forall x:U, ~ In U A x -> cardinal (Add U A x) (S n).
 
@@ -51,31 +51,31 @@ Hint Resolve card_empty card_add: sets v62.
 Require Import Constructive_sets.
 
 Section Ensembles_finis_facts.
-Variable U : Type.
+  Variable U : Type.
+  
+  Lemma cardinal_invert :
+    forall (X:Ensemble U) (p:nat),
+      cardinal U X p ->
+      match p with
+	| O => X = Empty_set U
+	| S n =>
+          exists A : _,
+            (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal U A n)
+      end.
+  Proof.
+    induction 1; simpl in |- *; auto.
+    exists A; exists x; auto.
+  Qed.
 
-Lemma cardinal_invert :
- forall (X:Ensemble U) (p:nat),
-   cardinal U X p ->
-   match p with
-   | O => X = Empty_set U
-   | S n =>
-        exists A : _,
-         (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal U A n)
-   end.
-Proof.
-induction 1; simpl in |- *; auto.
-exists A; exists x; auto.
-Qed.
-
-Lemma cardinal_elim :
- forall (X:Ensemble U) (p:nat),
-   cardinal U X p ->
-   match p with
-   | O => X = Empty_set U
-   | S n => Inhabited U X
-   end.
-Proof.
-intros X p C; elim C; simpl in |- *; trivial with sets.
-Qed.
+  Lemma cardinal_elim :
+    forall (X:Ensemble U) (p:nat),
+      cardinal U X p ->
+      match p with
+	| O => X = Empty_set U
+	| S n => Inhabited U X
+      end.
+  Proof.
+    intros X p C; elim C; simpl in |- *; trivial with sets.
+  Qed.
 
 End Ensembles_finis_facts.
diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v
index 952965e8..91717f9e 100755..100644
--- a/theories/Sets/Finite_sets_facts.v
+++ b/theories/Sets/Finite_sets_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Finite_sets_facts.v,v 1.7.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Finite_sets_facts.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
@@ -37,311 +37,308 @@ Require Export Gt.
 Require Export Lt.
 
 Section Finite_sets_facts.
-Variable U : Type.
+  Variable U : Type.
 
-Lemma finite_cardinal :
- forall X:Ensemble U, Finite U X ->  exists n : nat, cardinal U X n.
-Proof.
-induction 1 as [| A _ [n H]].
-exists 0; auto with sets.
-exists (S n); auto with sets.
-Qed.
+  Lemma finite_cardinal :
+    forall X:Ensemble U, Finite U X ->  exists n : nat, cardinal U X n.
+  Proof.
+    induction 1 as [| A _ [n H]].
+    exists 0; auto with sets.
+    exists (S n); auto with sets.
+  Qed.
 
-Lemma cardinal_finite :
- forall (X:Ensemble U) (n:nat), cardinal U X n -> Finite U X.
-Proof.
-induction 1; auto with sets.
-Qed.
+  Lemma cardinal_finite :
+    forall (X:Ensemble U) (n:nat), cardinal U X n -> Finite U X.
+  Proof.
+    induction 1; auto with sets.
+  Qed.
 
-Theorem Add_preserves_Finite :
- forall (X:Ensemble U) (x:U), Finite U X -> Finite U (Add U X x).
-Proof.
-intros X x H'.
-elim (classic (In U X x)); intro H'0; auto with sets.
-rewrite (Non_disjoint_union U X x); auto with sets.
-Qed.
-Hint Resolve Add_preserves_Finite.
+  Theorem Add_preserves_Finite :
+    forall (X:Ensemble U) (x:U), Finite U X -> Finite U (Add U X x).
+  Proof.
+    intros X x H'.
+    elim (classic (In U X x)); intro H'0; auto with sets.
+    rewrite (Non_disjoint_union U X x); auto with sets.
+  Qed.
 
-Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x).
-Proof.
-intro x; rewrite <- (Empty_set_zero U (Singleton U x)).
-change (Finite U (Add U (Empty_set U) x)) in |- *; auto with sets.
-Qed.
-Hint Resolve Singleton_is_finite.
+  Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x).
+  Proof.
+    intro x; rewrite <- (Empty_set_zero U (Singleton U x)).
+    change (Finite U (Add U (Empty_set U) x)) in |- *; auto with sets.
+  Qed.
 
-Theorem Union_preserves_Finite :
- forall X Y:Ensemble U, Finite U X -> Finite U Y -> Finite U (Union U X Y).
-Proof.
-intros X Y H'; elim H'.
-rewrite (Empty_set_zero U Y); auto with sets.
-intros A H'0 H'1 x H'2 H'3.
-rewrite (Union_commutative U (Add U A x) Y).
-rewrite <- (Union_add U Y A x).
-rewrite (Union_commutative U Y A); auto with sets.
-Qed.
+  Theorem Union_preserves_Finite :
+    forall X Y:Ensemble U, Finite U X -> Finite U Y -> Finite U (Union U X Y).
+  Proof.
+    intros X Y H; induction H as [|A Fin_A Hind x].
+    rewrite (Empty_set_zero U Y). trivial.
+    intros. 
+    rewrite (Union_commutative U (Add U A x) Y).
+    rewrite <- (Union_add U Y A x).
+    rewrite (Union_commutative U Y A).
+    apply Add_preserves_Finite.
+    apply Hind. assumption.
+  Qed.
 
-Lemma Finite_downward_closed :
- forall A:Ensemble U,
-   Finite U A -> forall X:Ensemble U, Included U X A -> Finite U X.
-Proof.
-intros A H'; elim H'; auto with sets.
-intros X H'0.
-rewrite (less_than_empty U X H'0); auto with sets.
-intros; elim Included_Add with U X A0 x; auto with sets.
-destruct 1 as [A' [H5 H6]].
-rewrite H5; auto with sets.
-Qed.
+  Lemma Finite_downward_closed :
+    forall A:Ensemble U,
+      Finite U A -> forall X:Ensemble U, Included U X A -> Finite U X.
+  Proof.
+    intros A H'; elim H'; auto with sets.
+    intros X H'0.
+    rewrite (less_than_empty U X H'0); auto with sets.
+    intros; elim Included_Add with U X A0 x; auto with sets.
+    destruct 1 as [A' [H5 H6]].
+    rewrite H5; auto with sets.
+  Qed.
 
-Lemma Intersection_preserves_finite :
- forall A:Ensemble U,
-   Finite U A -> forall X:Ensemble U, Finite U (Intersection U X A).
-Proof.
-intros A H' X; apply Finite_downward_closed with A; auto with sets.
-Qed.
+  Lemma Intersection_preserves_finite :
+    forall A:Ensemble U,
+      Finite U A -> forall X:Ensemble U, Finite U (Intersection U X A).
+  Proof.
+    intros A H' X; apply Finite_downward_closed with A; auto with sets.
+  Qed.
+  
+  Lemma cardinalO_empty :
+    forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U.
+  Proof.
+    intros X H; apply (cardinal_invert U X 0); trivial with sets.
+  Qed.
 
-Lemma cardinalO_empty :
- forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U.
-Proof.
-intros X H; apply (cardinal_invert U X 0); trivial with sets.
-Qed.
-Hint Resolve cardinalO_empty.
+  Lemma inh_card_gt_O :
+    forall X:Ensemble U, Inhabited U X -> forall n:nat, cardinal U X n -> n > 0.
+  Proof.
+    induction 1 as [x H'].
+    intros n H'0.
+    elim (gt_O_eq n); auto with sets.
+    intro H'1; generalize H'; generalize H'0.
+    rewrite <- H'1; intro H'2.
+    rewrite (cardinalO_empty X); auto with sets.
+    intro H'3; elim H'3.
+  Qed.
 
-Lemma inh_card_gt_O :
- forall X:Ensemble U, Inhabited U X -> forall n:nat, cardinal U X n -> n > 0.
-Proof.
-induction 1 as [x H'].
-intros n H'0.
-elim (gt_O_eq n); auto with sets.
-intro H'1; generalize H'; generalize H'0.
-rewrite <- H'1; intro H'2.
-rewrite (cardinalO_empty X); auto with sets.
-intro H'3; elim H'3.
-Qed.
+  Lemma card_soustr_1 :
+    forall (X:Ensemble U) (n:nat),
+      cardinal U X n ->
+      forall x:U, In U X x -> cardinal U (Subtract U X x) (pred n).
+  Proof.
+    intros X n H'; elim H'.
+    intros x H'0; elim H'0.
+    clear H' n X.
+    intros X n H' H'0 x H'1 x0 H'2.
+    elim (classic (In U X x0)).
+    intro H'4; rewrite (add_soustr_xy U X x x0).
+    elim (classic (x = x0)).
+    intro H'5.
+    absurd (In U X x0); auto with sets.
+    rewrite <- H'5; auto with sets.
+    intro H'3; try assumption.
+    cut (S (pred n) = pred (S n)).
+    intro H'5; rewrite <- H'5.
+    apply card_add; auto with sets.
+    red in |- *; intro H'6; elim H'6.
+    intros H'7 H'8; try assumption.
+    elim H'1; auto with sets.
+    unfold pred at 2 in |- *; symmetry  in |- *.
+    apply S_pred with (m := 0).
+    change (n > 0) in |- *.
+    apply inh_card_gt_O with (X := X); auto with sets.
+    apply Inhabited_intro with (x := x0); auto with sets.
+    red in |- *; intro H'3.
+    apply H'1.
+    elim H'3; auto with sets.
+    rewrite H'3; auto with sets.
+    elim (classic (x = x0)).
+    intro H'3; rewrite <- H'3.
+    cut (Subtract U (Add U X x) x = X); auto with sets.
+    intro H'4; rewrite H'4; auto with sets.
+    intros H'3 H'4; try assumption.
+    absurd (In U (Add U X x) x0); auto with sets.
+    red in |- *; intro H'5; try exact H'5.
+    lapply (Add_inv U X x x0); tauto.
+  Qed.
 
-Lemma card_soustr_1 :
- forall (X:Ensemble U) (n:nat),
-   cardinal U X n ->
-   forall x:U, In U X x -> cardinal U (Subtract U X x) (pred n).
-Proof.
-intros X n H'; elim H'.
-intros x H'0; elim H'0.
-clear H' n X.
-intros X n H' H'0 x H'1 x0 H'2.
-elim (classic (In U X x0)).
-intro H'4; rewrite (add_soustr_xy U X x x0).
-elim (classic (x = x0)).
-intro H'5.
-absurd (In U X x0); auto with sets.
-rewrite <- H'5; auto with sets.
-intro H'3; try assumption.
-cut (S (pred n) = pred (S n)).
-intro H'5; rewrite <- H'5.
-apply card_add; auto with sets.
-red in |- *; intro H'6; elim H'6.
-intros H'7 H'8; try assumption.
-elim H'1; auto with sets.
-unfold pred at 2 in |- *; symmetry  in |- *.
-apply S_pred with (m := 0).
-change (n > 0) in |- *.
-apply inh_card_gt_O with (X := X); auto with sets.
-apply Inhabited_intro with (x := x0); auto with sets.
-red in |- *; intro H'3.
-apply H'1.
-elim H'3; auto with sets.
-rewrite H'3; auto with sets.
-elim (classic (x = x0)).
-intro H'3; rewrite <- H'3.
-cut (Subtract U (Add U X x) x = X); auto with sets.
-intro H'4; rewrite H'4; auto with sets.
-intros H'3 H'4; try assumption.
-absurd (In U (Add U X x) x0); auto with sets.
-red in |- *; intro H'5; try exact H'5.
-lapply (Add_inv U X x x0); tauto.
-Qed.
+  Lemma cardinal_is_functional :
+    forall (X:Ensemble U) (c1:nat),
+      cardinal U X c1 ->
+      forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> X = Y -> c1 = c2.
+  Proof.
+    intros X c1 H'; elim H'.
+    intros Y c2 H'0; elim H'0; auto with sets.
+    intros A n H'1 H'2 x H'3 H'5.
+    elim (not_Empty_Add U A x); auto with sets.
+    clear H' c1 X.
+    intros X n H' H'0 x H'1 Y c2 H'2.
+    elim H'2.
+    intro H'3.
+    elim (not_Empty_Add U X x); auto with sets.
+    clear H'2 c2 Y.
+    intros X0 c2 H'2 H'3 x0 H'4 H'5.
+    elim (classic (In U X0 x)).
+    intro H'6; apply f_equal with nat.
+    apply H'0 with (Y := Subtract U (Add U X0 x0) x).
+    elimtype (pred (S c2) = c2); auto with sets.
+    apply card_soustr_1; auto with sets.
+    rewrite <- H'5.
+    apply Sub_Add_new; auto with sets.
+    elim (classic (x = x0)).
+    intros H'6 H'7; apply f_equal with nat.
+    apply H'0 with (Y := X0); auto with sets.
+    apply Simplify_add with (x := x); auto with sets.
+    pattern x at 2 in |- *; rewrite H'6; auto with sets.
+    intros H'6 H'7.
+    absurd (Add U X x = Add U X0 x0); auto with sets.
+    clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2.
+    red in |- *; intro H'.
+    lapply (Extension U (Add U X x) (Add U X0 x0)); auto with sets.
+    clear H'.
+    intro H'; red in H'.
+    elim H'; intros H'0 H'1; red in H'0; clear H' H'1.
+    absurd (In U (Add U X0 x0) x); auto with sets.
+    lapply (Add_inv U X0 x0 x); [ intuition | apply (H'0 x); apply Add_intro2 ].
+  Qed.
 
-Lemma cardinal_is_functional :
- forall (X:Ensemble U) (c1:nat),
-   cardinal U X c1 ->
-   forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> X = Y -> c1 = c2.
-Proof.
-intros X c1 H'; elim H'.
-intros Y c2 H'0; elim H'0; auto with sets.
-intros A n H'1 H'2 x H'3 H'5.
-elim (not_Empty_Add U A x); auto with sets.
-clear H' c1 X.
-intros X n H' H'0 x H'1 Y c2 H'2.
-elim H'2.
-intro H'3.
-elim (not_Empty_Add U X x); auto with sets.
-clear H'2 c2 Y.
-intros X0 c2 H'2 H'3 x0 H'4 H'5.
-elim (classic (In U X0 x)).
-intro H'6; apply f_equal with nat.
-apply H'0 with (Y := Subtract U (Add U X0 x0) x).
-elimtype (pred (S c2) = c2); auto with sets.
-apply card_soustr_1; auto with sets.
-rewrite <- H'5.
-apply Sub_Add_new; auto with sets.
-elim (classic (x = x0)).
-intros H'6 H'7; apply f_equal with nat.
-apply H'0 with (Y := X0); auto with sets.
-apply Simplify_add with (x := x); auto with sets.
-pattern x at 2 in |- *; rewrite H'6; auto with sets.
-intros H'6 H'7.
-absurd (Add U X x = Add U X0 x0); auto with sets.
-clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2.
-red in |- *; intro H'.
-lapply (Extension U (Add U X x) (Add U X0 x0)); auto with sets.
-clear H'.
-intro H'; red in H'.
-elim H'; intros H'0 H'1; red in H'0; clear H' H'1.
-absurd (In U (Add U X0 x0) x); auto with sets.
-lapply (Add_inv U X0 x0 x); [ intuition | apply (H'0 x); apply Add_intro2 ].
-Qed.
+  Lemma cardinal_Empty : forall m:nat, cardinal U (Empty_set U) m -> 0 = m.
+  Proof.
+    intros m Cm; generalize (cardinal_invert U (Empty_set U) m Cm).
+    elim m; auto with sets.
+    intros; elim H0; intros; elim H1; intros; elim H2; intros.
+    elim (not_Empty_Add U x x0 H3).
+  Qed.
 
-Lemma cardinal_Empty : forall m:nat, cardinal U (Empty_set U) m -> 0 = m.
-Proof.
-intros m Cm; generalize (cardinal_invert U (Empty_set U) m Cm).
-elim m; auto with sets.
-intros; elim H0; intros; elim H1; intros; elim H2; intros.
-elim (not_Empty_Add U x x0 H3).
-Qed.
+  Lemma cardinal_unicity :
+    forall (X:Ensemble U) (n:nat),
+      cardinal U X n -> forall m:nat, cardinal U X m -> n = m.
+  Proof.
+    intros; apply cardinal_is_functional with X X; auto with sets.
+  Qed.
+  
+  Lemma card_Add_gen :
+    forall (A:Ensemble U) (x:U) (n n':nat),
+      cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n.
+  Proof.
+    intros A x n n' H'.
+    elim (classic (In U A x)).
+    intro H'0.
+    rewrite (Non_disjoint_union U A x H'0).
+    intro H'1; cut (n = n').
+    intro E; rewrite E; auto with sets.
+    apply cardinal_unicity with A; auto with sets.
+    intros H'0 H'1.
+    cut (n' = S n).
+    intro E; rewrite E; auto with sets.
+    apply cardinal_unicity with (Add U A x); auto with sets.
+  Qed.
 
-Lemma cardinal_unicity :
- forall (X:Ensemble U) (n:nat),
-   cardinal U X n -> forall m:nat, cardinal U X m -> n = m.
-Proof.
-intros; apply cardinal_is_functional with X X; auto with sets.
-Qed.
+  Lemma incl_st_card_lt :
+    forall (X:Ensemble U) (c1:nat),
+      cardinal U X c1 ->
+      forall (Y:Ensemble U) (c2:nat),
+	cardinal U Y c2 -> Strict_Included U X Y -> c2 > c1.
+  Proof.
+    intros X c1 H'; elim H'.
+    intros Y c2 H'0; elim H'0; auto with sets arith.
+    intro H'1.
+    elim (Strict_Included_strict U (Empty_set U)); auto with sets arith.
+    clear H' c1 X.
+    intros X n H' H'0 x H'1 Y c2 H'2.
+    elim H'2.
+    intro H'3; elim (not_SIncl_empty U (Add U X x)); auto with sets arith.
+    clear H'2 c2 Y.
+    intros X0 c2 H'2 H'3 x0 H'4 H'5; elim (classic (In U X0 x)).
+    intro H'6; apply gt_n_S.
+    apply H'0 with (Y := Subtract U (Add U X0 x0) x).
+    elimtype (pred (S c2) = c2); auto with sets arith.
+    apply card_soustr_1; auto with sets arith.
+    apply incl_st_add_soustr; auto with sets arith.
+    elim (classic (x = x0)).
+    intros H'6 H'7; apply gt_n_S.
+    apply H'0 with (Y := X0); auto with sets arith.
+    apply sincl_add_x with (x := x0).
+    rewrite <- H'6; auto with sets arith.
+    pattern x0 at 1 in |- *; rewrite <- H'6; trivial with sets arith.
+    intros H'6 H'7; red in H'5.
+    elim H'5; intros H'8 H'9; try exact H'8; clear H'5.
+    red in H'8.
+    generalize (H'8 x).
+    intro H'5; lapply H'5; auto with sets arith.
+    intro H; elim Add_inv with U X0 x0 x; auto with sets arith.
+    intro; absurd (In U X0 x); auto with sets arith.
+    intro; absurd (x = x0); auto with sets arith.
+  Qed.
 
-Lemma card_Add_gen :
- forall (A:Ensemble U) (x:U) (n n':nat),
-   cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n.
-Proof.
-intros A x n n' H'.
-elim (classic (In U A x)).
-intro H'0.
-rewrite (Non_disjoint_union U A x H'0).
-intro H'1; cut (n = n').
-intro E; rewrite E; auto with sets.
-apply cardinal_unicity with A; auto with sets.
-intros H'0 H'1.
-cut (n' = S n).
-intro E; rewrite E; auto with sets.
-apply cardinal_unicity with (Add U A x); auto with sets.
-Qed.
+  Lemma incl_card_le :
+    forall (X Y:Ensemble U) (n m:nat),
+      cardinal U X n -> cardinal U Y m -> Included U X Y -> n <= m.
+  Proof.
+    intros; elim Included_Strict_Included with U X Y; auto with sets arith; intro.
+    cut (m > n); auto with sets arith.
+    apply incl_st_card_lt with (X := X) (Y := Y); auto with sets arith.
+    generalize H0; rewrite <- H2; intro.
+    cut (n = m).
+    intro E; rewrite E; auto with sets arith.
+    apply cardinal_unicity with X; auto with sets arith.
+  Qed.
+  
+  Lemma G_aux :
+    forall P:Ensemble U -> Prop,
+      (forall X:Ensemble U,
+	Finite U X ->
+	(forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
+      P (Empty_set U).
+  Proof.
+    intros P H'; try assumption.
+    apply H'; auto with sets.
+    clear H'; auto with sets.
+    intros Y H'; try assumption.
+    red in H'.
+    elim H'; intros H'0 H'1; try exact H'1; clear H'.
+    lapply (less_than_empty U Y); [ intro H'3; try exact H'3 | assumption ].
+    elim H'1; auto with sets.
+  Qed.
 
-Lemma incl_st_card_lt :
- forall (X:Ensemble U) (c1:nat),
-   cardinal U X c1 ->
-   forall (Y:Ensemble U) (c2:nat),
-     cardinal U Y c2 -> Strict_Included U X Y -> c2 > c1.
-Proof.
-intros X c1 H'; elim H'.
-intros Y c2 H'0; elim H'0; auto with sets arith.
-intro H'1.
-elim (Strict_Included_strict U (Empty_set U)); auto with sets arith.
-clear H' c1 X.
-intros X n H' H'0 x H'1 Y c2 H'2.
-elim H'2.
-intro H'3; elim (not_SIncl_empty U (Add U X x)); auto with sets arith.
-clear H'2 c2 Y.
-intros X0 c2 H'2 H'3 x0 H'4 H'5; elim (classic (In U X0 x)).
-intro H'6; apply gt_n_S.
-apply H'0 with (Y := Subtract U (Add U X0 x0) x).
-elimtype (pred (S c2) = c2); auto with sets arith.
-apply card_soustr_1; auto with sets arith.
-apply incl_st_add_soustr; auto with sets arith.
-elim (classic (x = x0)).
-intros H'6 H'7; apply gt_n_S.
-apply H'0 with (Y := X0); auto with sets arith.
-apply sincl_add_x with (x := x0).
-rewrite <- H'6; auto with sets arith.
-pattern x0 at 1 in |- *; rewrite <- H'6; trivial with sets arith.
-intros H'6 H'7; red in H'5.
-elim H'5; intros H'8 H'9; try exact H'8; clear H'5.
-red in H'8.
-generalize (H'8 x).
-intro H'5; lapply H'5; auto with sets arith.
-intro H; elim Add_inv with U X0 x0 x; auto with sets arith.
-intro; absurd (In U X0 x); auto with sets arith.
-intro; absurd (x = x0); auto with sets arith.
-Qed.
+  Lemma Generalized_induction_on_finite_sets :
+    forall P:Ensemble U -> Prop,
+      (forall X:Ensemble U,
+	Finite U X ->
+	(forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
+      forall X:Ensemble U, Finite U X -> P X.
+  Proof.
+    intros P H'0 X H'1.
+    generalize P H'0; clear H'0 P.
+    elim H'1.
+    intros P H'0.
+    apply G_aux; auto with sets.
+    clear H'1 X.
+    intros A H' H'0 x H'1 P H'3.
+    cut (forall Y:Ensemble U, Included U Y (Add U A x) -> P Y); auto with sets.
+    generalize H'1.
+    apply H'0.
+    intros X K H'5 L Y H'6; apply H'3; auto with sets.
+    apply Finite_downward_closed with (A := Add U X x); auto with sets.
+    intros Y0 H'7.
+    elim (Strict_inclusion_is_transitive_with_inclusion U Y0 Y (Add U X x));
+      auto with sets.
+    intros H'2 H'4.
+    elim (Included_Add U Y0 X x);
+      [ intro H'14
+	| intro H'14; elim H'14; intros A' E; elim E; intros H'15 H'16; clear E H'14
+	| idtac ]; auto with sets.
+    elim (Included_Strict_Included U Y0 X); auto with sets.
+    intro H'9; apply H'5 with (Y := Y0); auto with sets.
+    intro H'9; rewrite H'9.
+    apply H'3; auto with sets.
+    intros Y1 H'8; elim H'8.
+    intros H'10 H'11; apply H'5 with (Y := Y1); auto with sets.
+    elim (Included_Strict_Included U A' X); auto with sets.
+    intro H'8; apply H'5 with (Y := A'); auto with sets.
+    rewrite <- H'15; auto with sets.
+    intro H'8.
+    elim H'7.
+    intros H'9 H'10; apply H'10 || elim H'10; try assumption.
+    generalize H'6.
+    rewrite <- H'8.
+    rewrite <- H'15; auto with sets.
+  Qed.
 
-Lemma incl_card_le :
- forall (X Y:Ensemble U) (n m:nat),
-   cardinal U X n -> cardinal U Y m -> Included U X Y -> n <= m.
-Proof.
-intros; elim Included_Strict_Included with U X Y; auto with sets arith; intro.
-cut (m > n); auto with sets arith.
-apply incl_st_card_lt with (X := X) (Y := Y); auto with sets arith.
-generalize H0; rewrite <- H2; intro.
-cut (n = m).
-intro E; rewrite E; auto with sets arith.
-apply cardinal_unicity with X; auto with sets arith.
-Qed.
-
-Lemma G_aux :
- forall P:Ensemble U -> Prop,
-   (forall X:Ensemble U,
-      Finite U X ->
-      (forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
-   P (Empty_set U).
-Proof.
-intros P H'; try assumption.
-apply H'; auto with sets.
-clear H'; auto with sets.
-intros Y H'; try assumption.
-red in H'.
-elim H'; intros H'0 H'1; try exact H'1; clear H'.
-lapply (less_than_empty U Y); [ intro H'3; try exact H'3 | assumption ].
-elim H'1; auto with sets.
-Qed.
-
-Hint Unfold not.
-
-Lemma Generalized_induction_on_finite_sets :
- forall P:Ensemble U -> Prop,
-   (forall X:Ensemble U,
-      Finite U X ->
-      (forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
-   forall X:Ensemble U, Finite U X -> P X.
-Proof.
-intros P H'0 X H'1.
-generalize P H'0; clear H'0 P.
-elim H'1.
-intros P H'0.
-apply G_aux; auto with sets.
-clear H'1 X.
-intros A H' H'0 x H'1 P H'3.
-cut (forall Y:Ensemble U, Included U Y (Add U A x) -> P Y); auto with sets.
-generalize H'1.
-apply H'0.
-intros X K H'5 L Y H'6; apply H'3; auto with sets.
-apply Finite_downward_closed with (A := Add U X x); auto with sets.
-intros Y0 H'7.
-elim (Strict_inclusion_is_transitive_with_inclusion U Y0 Y (Add U X x));
- auto with sets.
-intros H'2 H'4.
-elim (Included_Add U Y0 X x);
- [ intro H'14
- | intro H'14; elim H'14; intros A' E; elim E; intros H'15 H'16; clear E H'14
- | idtac ]; auto with sets.
-elim (Included_Strict_Included U Y0 X); auto with sets.
-intro H'9; apply H'5 with (Y := Y0); auto with sets.
-intro H'9; rewrite H'9.
-apply H'3; auto with sets.
-intros Y1 H'8; elim H'8.
-intros H'10 H'11; apply H'5 with (Y := Y1); auto with sets.
-elim (Included_Strict_Included U A' X); auto with sets.
-intro H'8; apply H'5 with (Y := A'); auto with sets.
-rewrite <- H'15; auto with sets.
-intro H'8.
-elim H'7.
-intros H'9 H'10; apply H'10 || elim H'10; try assumption.
-generalize H'6.
-rewrite <- H'8.
-rewrite <- H'15; auto with sets.
-Qed.
-
-End Finite_sets_facts.
\ No newline at end of file
+End Finite_sets_facts.
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
index f58f2f81..d3591acf 100755..100644
--- a/theories/Sets/Image.v
+++ b/theories/Sets/Image.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Image.v,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Image.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
@@ -39,167 +39,167 @@ Require Export Le.
 Require Export Finite_sets_facts.
 
 Section Image.
-Variables U V : Type.
-
-Inductive Im (X:Ensemble U) (f:U -> V) : Ensemble V :=
+  Variables U V : Type.
+  
+  Inductive Im (X:Ensemble U) (f:U -> V) : Ensemble V :=
     Im_intro : forall x:U, In _ X x -> forall y:V, y = f x -> In _ (Im X f) y.
+  
+  Lemma Im_def :
+    forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x).
+  Proof.
+    intros X f x H'; try assumption.
+    apply Im_intro with (x := x); auto with sets.
+  Qed.
+
+  Lemma Im_add :
+    forall (X:Ensemble U) (x:U) (f:U -> V),
+      Im (Add _ X x) f = Add _ (Im X f) (f x).
+  Proof.
+    intros X x f.
+    apply Extensionality_Ensembles.
+    split; red in |- *; intros x0 H'.
+    elim H'; intros.
+    rewrite H0.
+    elim Add_inv with U X x x1; auto using Im_def with sets.
+    destruct 1; auto using Im_def with sets.
+    elim Add_inv with V (Im X f) (f x) x0. 
+    destruct 1 as [x0 H y H0].
+    rewrite H0; auto using Im_def with sets.
+    destruct 1; auto using Im_def with sets.
+    trivial.
+  Qed.
+  
+  Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V.
+  Proof.
+    intro f; try assumption.
+    apply Extensionality_Ensembles.
+    split; auto with sets.
+    red in |- *.
+    intros x H'; elim H'.
+    intros x0 H'0; elim H'0; auto with sets.
+  Qed.
+
+  Lemma finite_image :
+    forall (X:Ensemble U) (f:U -> V), Finite _ X -> Finite _ (Im X f).
+  Proof.
+    intros X f H'; elim H'.
+    rewrite (image_empty f); auto with sets.
+    intros A H'0 H'1 x H'2; clear H' X.
+    rewrite (Im_add A x f); auto with sets.
+    apply Add_preserves_Finite; auto with sets.
+  Qed.
+  
+  Lemma Im_inv :
+    forall (X:Ensemble U) (f:U -> V) (y:V),
+      In _ (Im X f) y ->  exists x : U, In _ X x /\ f x = y.
+  Proof.
+    intros X f y H'; elim H'.
+    intros x H'0 y0 H'1; rewrite H'1.
+    exists x; auto with sets.
+  Qed.
+  
+  Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y.
+  
+  Lemma not_injective_elim :
+    forall f:U -> V,
+      ~ injective f ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
+  Proof.
+    unfold injective in |- *; intros f H.
+    cut (exists x : _, ~ (forall y:U, f x = f y -> x = y)).
+    2: apply not_all_ex_not with (P := fun x:U => forall y:U, f x = f y -> x = y);
+      trivial with sets.
+    destruct 1 as [x C]; exists x.
+    cut (exists y : _, ~ (f x = f y -> x = y)).
+    2: apply not_all_ex_not with (P := fun y:U => f x = f y -> x = y);
+      trivial with sets.
+    destruct 1 as [y D]; exists y.
+    apply imply_to_and; trivial with sets.
+  Qed.
+  
+  Lemma cardinal_Im_intro :
+    forall (A:Ensemble U) (f:U -> V) (n:nat),
+      cardinal _ A n ->  exists p : nat, cardinal _ (Im A f) p.
+  Proof.
+    intros.
+    apply finite_cardinal; apply finite_image.
+    apply cardinal_finite with n; trivial with sets.
+  Qed.
+  
+  Lemma In_Image_elim :
+    forall (A:Ensemble U) (f:U -> V),
+      injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x.
+  Proof.
+    intros.
+    elim Im_inv with A f (f x); trivial with sets.
+    intros z C; elim C; intros InAz E.
+    elim (H z x E); trivial with sets.
+  Qed.
+  
+  Lemma injective_preserves_cardinal :
+    forall (A:Ensemble U) (f:U -> V) (n:nat),
+      injective f ->
+      cardinal _ A n -> forall n':nat, cardinal _ (Im A f) n' -> n' = n.
+  Proof.
+    induction 2 as [| A n H'0 H'1 x H'2]; auto with sets.
+    rewrite (image_empty f).
+    intros n' CE.
+    apply cardinal_unicity with V (Empty_set V); auto with sets.
+    intro n'.
+    rewrite (Im_add A x f).
+    intro H'3.
+    elim cardinal_Im_intro with A f n; trivial with sets.
+    intros i CI.
+    lapply (H'1 i); trivial with sets.
+    cut (~ In _ (Im A f) (f x)).
+    intros H0 H1.
+    apply cardinal_unicity with V (Add _ (Im A f) (f x)); trivial with sets.
+    apply card_add; auto with sets.
+    rewrite <- H1; trivial with sets.
+    red in |- *; intro; apply H'2.
+    apply In_Image_elim with f; trivial with sets.
+  Qed.
+  
+  Lemma cardinal_decreases :
+    forall (A:Ensemble U) (f:U -> V) (n:nat),
+      cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n.
+  Proof.
+    induction 1 as [| A n H'0 H'1 x H'2]; auto with sets.
+    rewrite (image_empty f); intros.
+    cut (n' = 0).
+    intro E; rewrite E; trivial with sets.
+    apply cardinal_unicity with V (Empty_set V); auto with sets.
+    intro n'.
+    rewrite (Im_add A x f).
+    elim cardinal_Im_intro with A f n; trivial with sets.
+    intros p C H'3.
+    apply le_trans with (S p).
+    apply card_Add_gen with V (Im A f) (f x); trivial with sets.
+    apply le_n_S; auto with sets.
+  Qed.
+
+  Theorem Pigeonhole :
+    forall (A:Ensemble U) (f:U -> V) (n:nat),
+      cardinal U A n ->
+      forall n':nat, cardinal V (Im A f) n' -> n' < n -> ~ injective f.
+  Proof.
+    unfold not in |- *; intros A f n CAn n' CIfn' ltn'n I.
+    cut (n' = n).
+    intro E; generalize ltn'n; rewrite E; exact (lt_irrefl n).
+    apply injective_preserves_cardinal with (A := A) (f := f) (n := n);
+      trivial with sets.
+  Qed.
+  
+  Lemma Pigeonhole_principle :
+    forall (A:Ensemble U) (f:U -> V) (n:nat),
+      cardinal _ A n ->
+      forall n':nat,
+	cardinal _ (Im A f) n' ->
+	n' < n ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
+  Proof.
+    intros; apply not_injective_elim.
+    apply Pigeonhole with A n n'; trivial with sets.
+  Qed.
 
-Lemma Im_def :
- forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x).
-Proof.
-intros X f x H'; try assumption.
-apply Im_intro with (x := x); auto with sets.
-Qed.
-Hint Resolve Im_def.
-
-Lemma Im_add :
- forall (X:Ensemble U) (x:U) (f:U -> V),
-   Im (Add _ X x) f = Add _ (Im X f) (f x).
-Proof.
-intros X x f.
-apply Extensionality_Ensembles.
-split; red in |- *; intros x0 H'.
-elim H'; intros.
-rewrite H0.
-elim Add_inv with U X x x1; auto with sets.
-destruct 1; auto with sets.
-elim Add_inv with V (Im X f) (f x) x0; auto with sets.
-destruct 1 as [x0 H y H0].
-rewrite H0; auto with sets.
-destruct 1; auto with sets.
-Qed.
-
-Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V.
-Proof.
-intro f; try assumption.
-apply Extensionality_Ensembles.
-split; auto with sets.
-red in |- *.
-intros x H'; elim H'.
-intros x0 H'0; elim H'0; auto with sets.
-Qed.
-Hint Resolve image_empty.
-
-Lemma finite_image :
- forall (X:Ensemble U) (f:U -> V), Finite _ X -> Finite _ (Im X f).
-Proof.
-intros X f H'; elim H'.
-rewrite (image_empty f); auto with sets.
-intros A H'0 H'1 x H'2; clear H' X.
-rewrite (Im_add A x f); auto with sets.
-apply Add_preserves_Finite; auto with sets.
-Qed.
-Hint Resolve finite_image.
-
-Lemma Im_inv :
- forall (X:Ensemble U) (f:U -> V) (y:V),
-   In _ (Im X f) y ->  exists x : U, In _ X x /\ f x = y.
-Proof.
-intros X f y H'; elim H'.
-intros x H'0 y0 H'1; rewrite H'1.
-exists x; auto with sets.
-Qed.
-
-Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y.
-
-Lemma not_injective_elim :
- forall f:U -> V,
-   ~ injective f ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
-Proof.
-unfold injective in |- *; intros f H.
-cut (exists x : _, ~ (forall y:U, f x = f y -> x = y)).
-2: apply not_all_ex_not with (P := fun x:U => forall y:U, f x = f y -> x = y);
-    trivial with sets.
-destruct 1 as [x C]; exists x.
-cut (exists y : _, ~ (f x = f y -> x = y)).
-2: apply not_all_ex_not with (P := fun y:U => f x = f y -> x = y);
-    trivial with sets.
-destruct 1 as [y D]; exists y.
-apply imply_to_and; trivial with sets.
-Qed.
-
-Lemma cardinal_Im_intro :
- forall (A:Ensemble U) (f:U -> V) (n:nat),
-   cardinal _ A n ->  exists p : nat, cardinal _ (Im A f) p.
-Proof.
-intros.
-apply finite_cardinal; apply finite_image.
-apply cardinal_finite with n; trivial with sets.
-Qed.
-
-Lemma In_Image_elim :
- forall (A:Ensemble U) (f:U -> V),
-   injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x.
-Proof.
-intros.
-elim Im_inv with A f (f x); trivial with sets.
-intros z C; elim C; intros InAz E.
-elim (H z x E); trivial with sets.
-Qed.
-
-Lemma injective_preserves_cardinal :
- forall (A:Ensemble U) (f:U -> V) (n:nat),
-   injective f ->
-   cardinal _ A n -> forall n':nat, cardinal _ (Im A f) n' -> n' = n.
-Proof.
-induction 2 as [| A n H'0 H'1 x H'2]; auto with sets.
-rewrite (image_empty f).
-intros n' CE.
-apply cardinal_unicity with V (Empty_set V); auto with sets.
-intro n'.
-rewrite (Im_add A x f).
-intro H'3.
-elim cardinal_Im_intro with A f n; trivial with sets.
-intros i CI.
-lapply (H'1 i); trivial with sets.
-cut (~ In _ (Im A f) (f x)).
-intros H0 H1.
-apply cardinal_unicity with V (Add _ (Im A f) (f x)); trivial with sets.
-apply card_add; auto with sets.
-rewrite <- H1; trivial with sets.
-red in |- *; intro; apply H'2.
-apply In_Image_elim with f; trivial with sets.
-Qed.
-
-Lemma cardinal_decreases :
- forall (A:Ensemble U) (f:U -> V) (n:nat),
-   cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n.
-Proof.
-induction 1 as [| A n H'0 H'1 x H'2]; auto with sets.
-rewrite (image_empty f); intros.
-cut (n' = 0).
-intro E; rewrite E; trivial with sets.
-apply cardinal_unicity with V (Empty_set V); auto with sets.
-intro n'.
-rewrite (Im_add A x f).
-elim cardinal_Im_intro with A f n; trivial with sets.
-intros p C H'3.
-apply le_trans with (S p).
-apply card_Add_gen with V (Im A f) (f x); trivial with sets.
-apply le_n_S; auto with sets.
-Qed.
-
-Theorem Pigeonhole :
- forall (A:Ensemble U) (f:U -> V) (n:nat),
-   cardinal U A n ->
-   forall n':nat, cardinal V (Im A f) n' -> n' < n -> ~ injective f.
-Proof.
-unfold not in |- *; intros A f n CAn n' CIfn' ltn'n I.
-cut (n' = n).
-intro E; generalize ltn'n; rewrite E; exact (lt_irrefl n).
-apply injective_preserves_cardinal with (A := A) (f := f) (n := n);
- trivial with sets.
-Qed.
-
-Lemma Pigeonhole_principle :
- forall (A:Ensemble U) (f:U -> V) (n:nat),
-   cardinal _ A n ->
-   forall n':nat,
-     cardinal _ (Im A f) n' ->
-     n' < n ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
-Proof.
-intros; apply not_injective_elim.
-apply Pigeonhole with A n n'; trivial with sets.
-Qed.
 End Image.
+
 Hint Resolve Im_def image_empty finite_image: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v
index c357e26c..47554ac4 100755..100644
--- a/theories/Sets/Infinite_sets.v
+++ b/theories/Sets/Infinite_sets.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Infinite_sets.v,v 1.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Infinite_sets.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
@@ -40,205 +40,205 @@ Require Export Finite_sets_facts.
 Require Export Image.
 
 Section Approx.
-Variable U : Type.
+  Variable U : Type.
 
-Inductive Approximant (A X:Ensemble U) : Prop :=
+  Inductive Approximant (A X:Ensemble U) : Prop :=
     Defn_of_Approximant : Finite U X -> Included U X A -> Approximant A X.
 End Approx.
 
 Hint Resolve Defn_of_Approximant.
 
 Section Infinite_sets.
-Variable U : Type.
-
-Lemma make_new_approximant :
- forall A X:Ensemble U,
-   ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X).
-Proof.
-intros A X H' H'0.
-elim H'0; intros H'1 H'2.
-apply Strict_super_set_contains_new_element; auto with sets.
-red in |- *; intro H'3; apply H'.
-rewrite <- H'3; auto with sets.
-Qed.
-
-Lemma approximants_grow :
- forall A X:Ensemble U,
-   ~ Finite U A ->
-   forall n:nat,
-     cardinal U X n ->
-     Included U X A ->  exists Y : _, cardinal U Y (S n) /\ Included U Y A.
-Proof.
-intros A X H' n H'0; elim H'0; auto with sets.
-intro H'1.
-cut (Inhabited U (Setminus U A (Empty_set U))).
-intro H'2; elim H'2.
-intros x H'3.
-exists (Add U (Empty_set U) x); auto with sets.
-split.
-apply card_add; auto with sets.
-cut (In U A x).
-intro H'4; red in |- *; auto with sets.
-intros x0 H'5; elim H'5; auto with sets.
-intros x1 H'6; elim H'6; auto with sets.
-elim H'3; auto with sets.
-apply make_new_approximant; auto with sets.
-intros A0 n0 H'1 H'2 x H'3 H'5.
-lapply H'2; [ intro H'6; elim H'6; clear H'2 | clear H'2 ]; auto with sets.
-intros x0 H'2; try assumption.
-elim H'2; intros H'7 H'8; try exact H'8; clear H'2.
-elim (make_new_approximant A x0); auto with sets.
-intros x1 H'2; try assumption.
-exists (Add U x0 x1); auto with sets.
-split.
-apply card_add; auto with sets.
-elim H'2; auto with sets.
-red in |- *.
-intros x2 H'9; elim H'9; auto with sets.
-intros x3 H'10; elim H'10; auto with sets.
-elim H'2; auto with sets.
-auto with sets.
-apply Defn_of_Approximant; auto with sets.
-apply cardinal_finite with (n := S n0); auto with sets.
-Qed.
-
-Lemma approximants_grow' :
- forall A X:Ensemble U,
-   ~ Finite U A ->
-   forall n:nat,
-     cardinal U X n ->
-     Approximant U A X ->
-      exists Y : _, cardinal U Y (S n) /\ Approximant U A Y.
-Proof.
-intros A X H' n H'0 H'1; try assumption.
-elim H'1.
-intros H'2 H'3.
-elimtype (exists Y : _, cardinal U Y (S n) /\ Included U Y A).
-intros x H'4; elim H'4; intros H'5 H'6; try exact H'5; clear H'4.
-exists x; auto with sets.
-split; [ auto with sets | idtac ].
-apply Defn_of_Approximant; auto with sets.
-apply cardinal_finite with (n := S n); auto with sets.
-apply approximants_grow with (X := X); auto with sets.
-Qed.
-
-Lemma approximant_can_be_any_size :
- forall A X:Ensemble U,
-   ~ Finite U A ->
-   forall n:nat,  exists Y : _, cardinal U Y n /\ Approximant U A Y.
-Proof.
-intros A H' H'0 n; elim n.
-exists (Empty_set U); auto with sets.
-intros n0 H'1; elim H'1.
-intros x H'2.
-apply approximants_grow' with (X := x); tauto.
-Qed.
-
-Variable V : Type.
-
-Theorem Image_set_continuous :
- forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
-   Finite V X ->
-   Included V X (Im U V A f) ->
-    exists n : _,
-     (exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X).
-Proof.
-intros A f X H'; elim H'.
-intro H'0; exists 0.
-exists (Empty_set U); auto with sets.
-intros A0 H'0 H'1 x H'2 H'3; try assumption.
-lapply H'1;
- [ intro H'4; elim H'4; intros n E; elim E; clear H'4 H'1 | clear H'1 ];
- auto with sets.
-intros x0 H'1; try assumption.
-exists (S n); try assumption.
-elim H'1; intros H'4 H'5; elim H'4; intros H'6 H'7; try exact H'6;
- clear H'4 H'1.
-clear E.
-generalize H'2.
-rewrite <- H'5.
-intro H'1; try assumption.
-red in H'3.
-generalize (H'3 x).
-intro H'4; lapply H'4; [ intro H'8; try exact H'8; clear H'4 | clear H'4 ];
- auto with sets.
-specialize  5Im_inv with (U := U) (V := V) (X := A) (f := f) (y := x);
- intro H'11; lapply H'11; [ intro H'13; elim H'11; clear H'11 | clear H'11 ];
- auto with sets.
-intros x1 H'4; try assumption.
-apply ex_intro with (x := Add U x0 x1).
-split; [ split; [ try assumption | idtac ] | idtac ].
-apply card_add; auto with sets.
-red in |- *; intro H'9; try exact H'9.
-apply H'1.
-elim H'4; intros H'10 H'11; rewrite <- H'11; clear H'4; auto with sets.
-elim H'4; intros H'9 H'10; try exact H'9; clear H'4; auto with sets.
-red in |- *; auto with sets.
-intros x2 H'4; elim H'4; auto with sets.
-intros x3 H'11; elim H'11; auto with sets.
-elim H'4; intros H'9 H'10; rewrite <- H'10; clear H'4; auto with sets.
-apply Im_add; auto with sets.
-Qed.
-
-Theorem Image_set_continuous' :
- forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
-   Approximant V (Im U V A f) X ->
-    exists Y : _, Approximant U A Y /\ Im U V Y f = X.
-Proof.
-intros A f X H'; try assumption.
-cut
- (exists n : _,
-    (exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X)).
-intro H'0; elim H'0; intros n E; elim E; clear H'0.
-intros x H'0; try assumption.
-elim H'0; intros H'1 H'2; elim H'1; intros H'3 H'4; try exact H'3;
- clear H'1 H'0; auto with sets.
-exists x.
-split; [ idtac | try assumption ].
-apply Defn_of_Approximant; auto with sets.
-apply cardinal_finite with (n := n); auto with sets.
-apply Image_set_continuous; auto with sets.
-elim H'; auto with sets.
-elim H'; auto with sets.
-Qed.
-
-Theorem Pigeonhole_bis :
- forall (A:Ensemble U) (f:U -> V),
-   ~ Finite U A -> Finite V (Im U V A f) -> ~ injective U V f.
-Proof.
-intros A f H'0 H'1; try assumption.
-elim (Image_set_continuous' A f (Im U V A f)); auto with sets.
-intros x H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
-elim (make_new_approximant A x); auto with sets.
-intros x0 H'2; elim H'2.
-intros H'5 H'6.
-elim (finite_cardinal V (Im U V A f)); auto with sets.
-intros n E.
-elim (finite_cardinal U x); auto with sets.
-intros n0 E0.
-apply Pigeonhole with (A := Add U x x0) (n := S n0) (n' := n).
-apply card_add; auto with sets.
-rewrite (Im_add U V x x0 f); auto with sets.
-cut (In V (Im U V x f) (f x0)).
-intro H'8.
-rewrite (Non_disjoint_union V (Im U V x f) (f x0)); auto with sets.
-rewrite H'4; auto with sets.
-elim (Extension V (Im U V x f) (Im U V A f)); auto with sets.
-apply le_lt_n_Sm.
-apply cardinal_decreases with (U := U) (V := V) (A := x) (f := f);
- auto with sets.
-rewrite H'4; auto with sets.
-elim H'3; auto with sets.
-Qed.
-
-Theorem Pigeonhole_ter :
- forall (A:Ensemble U) (f:U -> V) (n:nat),
-   injective U V f -> Finite V (Im U V A f) -> Finite U A.
-Proof.
-intros A f H' H'0 H'1.
-apply NNPP.
-red in |- *; intro H'2.
-elim (Pigeonhole_bis A f); auto with sets.
-Qed.
+  Variable U : Type.
+  
+  Lemma make_new_approximant :
+    forall A X:Ensemble U,
+      ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X).
+  Proof.
+    intros A X H' H'0.
+    elim H'0; intros H'1 H'2.
+    apply Strict_super_set_contains_new_element; auto with sets.
+    red in |- *; intro H'3; apply H'.
+    rewrite <- H'3; auto with sets.
+  Qed.
+  
+  Lemma approximants_grow :
+    forall A X:Ensemble U,
+      ~ Finite U A ->
+      forall n:nat,
+	cardinal U X n ->
+	Included U X A ->  exists Y : _, cardinal U Y (S n) /\ Included U Y A.
+  Proof.
+    intros A X H' n H'0; elim H'0; auto with sets.
+    intro H'1.
+    cut (Inhabited U (Setminus U A (Empty_set U))).
+    intro H'2; elim H'2.
+    intros x H'3.
+    exists (Add U (Empty_set U) x); auto with sets.
+    split.
+    apply card_add; auto with sets.
+    cut (In U A x).
+    intro H'4; red in |- *; auto with sets.
+    intros x0 H'5; elim H'5; auto with sets.
+    intros x1 H'6; elim H'6; auto with sets.
+    elim H'3; auto with sets.
+    apply make_new_approximant; auto with sets.
+    intros A0 n0 H'1 H'2 x H'3 H'5.
+    lapply H'2; [ intro H'6; elim H'6; clear H'2 | clear H'2 ]; auto with sets.
+    intros x0 H'2; try assumption.
+    elim H'2; intros H'7 H'8; try exact H'8; clear H'2.
+    elim (make_new_approximant A x0); auto with sets.
+    intros x1 H'2; try assumption.
+    exists (Add U x0 x1); auto with sets.
+    split.
+    apply card_add; auto with sets.
+    elim H'2; auto with sets.
+    red in |- *.
+    intros x2 H'9; elim H'9; auto with sets.
+    intros x3 H'10; elim H'10; auto with sets.
+    elim H'2; auto with sets.
+    auto with sets.
+    apply Defn_of_Approximant; auto with sets.
+    apply cardinal_finite with (n := S n0); auto with sets.
+  Qed.
+  
+  Lemma approximants_grow' :
+    forall A X:Ensemble U,
+      ~ Finite U A ->
+      forall n:nat,
+	cardinal U X n ->
+	Approximant U A X ->
+	exists Y : _, cardinal U Y (S n) /\ Approximant U A Y.
+  Proof.
+    intros A X H' n H'0 H'1; try assumption.
+    elim H'1.
+    intros H'2 H'3.
+    elimtype (exists Y : _, cardinal U Y (S n) /\ Included U Y A).
+    intros x H'4; elim H'4; intros H'5 H'6; try exact H'5; clear H'4.
+    exists x; auto with sets.
+    split; [ auto with sets | idtac ].
+    apply Defn_of_Approximant; auto with sets.
+    apply cardinal_finite with (n := S n); auto with sets.
+    apply approximants_grow with (X := X); auto with sets.
+  Qed.
+  
+  Lemma approximant_can_be_any_size :
+    forall A X:Ensemble U,
+      ~ Finite U A ->
+      forall n:nat,  exists Y : _, cardinal U Y n /\ Approximant U A Y.
+  Proof.
+    intros A H' H'0 n; elim n.
+    exists (Empty_set U); auto with sets.
+    intros n0 H'1; elim H'1.
+    intros x H'2.
+    apply approximants_grow' with (X := x); tauto.
+  Qed.
+
+  Variable V : Type.
+  
+  Theorem Image_set_continuous :
+    forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
+      Finite V X ->
+      Included V X (Im U V A f) ->
+      exists n : _,
+	(exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X).
+  Proof.
+    intros A f X H'; elim H'.
+    intro H'0; exists 0.
+    exists (Empty_set U); auto with sets.
+    intros A0 H'0 H'1 x H'2 H'3; try assumption.
+    lapply H'1;
+      [ intro H'4; elim H'4; intros n E; elim E; clear H'4 H'1 | clear H'1 ];
+      auto with sets.
+    intros x0 H'1; try assumption.
+    exists (S n); try assumption.
+    elim H'1; intros H'4 H'5; elim H'4; intros H'6 H'7; try exact H'6;
+      clear H'4 H'1.
+    clear E.
+    generalize H'2.
+    rewrite <- H'5.
+    intro H'1; try assumption.
+    red in H'3.
+    generalize (H'3 x).
+    intro H'4; lapply H'4; [ intro H'8; try exact H'8; clear H'4 | clear H'4 ];
+      auto with sets.
+    specialize  5Im_inv with (U := U) (V := V) (X := A) (f := f) (y := x);
+      intro H'11; lapply H'11; [ intro H'13; elim H'11; clear H'11 | clear H'11 ];
+	auto with sets.
+    intros x1 H'4; try assumption.
+    apply ex_intro with (x := Add U x0 x1).
+    split; [ split; [ try assumption | idtac ] | idtac ].
+    apply card_add; auto with sets.
+    red in |- *; intro H'9; try exact H'9.
+    apply H'1.
+    elim H'4; intros H'10 H'11; rewrite <- H'11; clear H'4; auto with sets.
+    elim H'4; intros H'9 H'10; try exact H'9; clear H'4; auto with sets.
+    red in |- *; auto with sets.
+    intros x2 H'4; elim H'4; auto with sets.
+    intros x3 H'11; elim H'11; auto with sets.
+    elim H'4; intros H'9 H'10; rewrite <- H'10; clear H'4; auto with sets.
+    apply Im_add; auto with sets.
+  Qed.
+
+  Theorem Image_set_continuous' :
+    forall (A:Ensemble U) (f:U -> V) (X:Ensemble V),
+      Approximant V (Im U V A f) X ->
+      exists Y : _, Approximant U A Y /\ Im U V Y f = X.
+  Proof.
+    intros A f X H'; try assumption.
+    cut
+      (exists n : _,
+	(exists Y : _, (cardinal U Y n /\ Included U Y A) /\ Im U V Y f = X)).
+    intro H'0; elim H'0; intros n E; elim E; clear H'0.
+    intros x H'0; try assumption.
+    elim H'0; intros H'1 H'2; elim H'1; intros H'3 H'4; try exact H'3;
+      clear H'1 H'0; auto with sets.
+    exists x.
+    split; [ idtac | try assumption ].
+    apply Defn_of_Approximant; auto with sets.
+    apply cardinal_finite with (n := n); auto with sets.
+    apply Image_set_continuous; auto with sets.
+    elim H'; auto with sets.
+    elim H'; auto with sets.
+  Qed.
+
+  Theorem Pigeonhole_bis :
+    forall (A:Ensemble U) (f:U -> V),
+      ~ Finite U A -> Finite V (Im U V A f) -> ~ injective U V f.
+  Proof.
+    intros A f H'0 H'1; try assumption.
+    elim (Image_set_continuous' A f (Im U V A f)); auto with sets.
+    intros x H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
+    elim (make_new_approximant A x); auto with sets.
+    intros x0 H'2; elim H'2.
+    intros H'5 H'6.
+    elim (finite_cardinal V (Im U V A f)); auto with sets.
+    intros n E.
+    elim (finite_cardinal U x); auto with sets.
+    intros n0 E0.
+    apply Pigeonhole with (A := Add U x x0) (n := S n0) (n' := n).
+    apply card_add; auto with sets.
+    rewrite (Im_add U V x x0 f); auto with sets.
+    cut (In V (Im U V x f) (f x0)).
+    intro H'8.
+    rewrite (Non_disjoint_union V (Im U V x f) (f x0)); auto with sets.
+    rewrite H'4; auto with sets.
+    elim (Extension V (Im U V x f) (Im U V A f)); auto with sets.
+    apply le_lt_n_Sm.
+    apply cardinal_decreases with (U := U) (V := V) (A := x) (f := f);
+      auto with sets.
+    rewrite H'4; auto with sets.
+    elim H'3; auto with sets.
+  Qed.
+  
+  Theorem Pigeonhole_ter :
+    forall (A:Ensemble U) (f:U -> V) (n:nat),
+      injective U V f -> Finite V (Im U V A f) -> Finite U A.
+  Proof.
+    intros A f H' H'0 H'1.
+    apply NNPP.
+    red in |- *; intro H'2.
+    elim (Pigeonhole_bis A f); auto with sets.
+  Qed.
 
 End Infinite_sets.
diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v
index 26f29c96..c969ad9c 100755..100644
--- a/theories/Sets/Integers.v
+++ b/theories/Sets/Integers.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Integers.v,v 1.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Integers.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
@@ -45,120 +45,117 @@ Require Export Partial_Order.
 Require Export Cpo.
 
 Section Integers_sect.
-
-Inductive Integers : Ensemble nat :=
+  
+  Inductive Integers : Ensemble nat :=
     Integers_defn : forall x:nat, In nat Integers x.
-Hint Resolve Integers_defn.
-
-Lemma le_reflexive : Reflexive nat le.
-Proof.
-red in |- *; auto with arith.
-Qed.
-
-Lemma le_antisym : Antisymmetric nat le.
-Proof.
-red in |- *; intros x y H H'; rewrite (le_antisym x y); auto.
-Qed.
-
-Lemma le_trans : Transitive nat le.
-Proof.
-red in |- *; intros; apply le_trans with y; auto.
-Qed.
-Hint Resolve le_reflexive le_antisym le_trans.
-
-Lemma le_Order : Order nat le.
-Proof.
-auto with sets arith.
-Qed.
-Hint Resolve le_Order.
-
-Lemma triv_nat : forall n:nat, In nat Integers n.
-Proof.
-auto with sets arith.
-Qed.
-Hint Resolve triv_nat.
-
-Definition nat_po : PO nat.
-apply Definition_of_PO with (Carrier_of := Integers) (Rel_of := le);
- auto with sets arith.
-apply Inhabited_intro with (x := 0); auto with sets arith.
-Defined.
-Hint Unfold nat_po.
-
-Lemma le_total_order : Totally_ordered nat nat_po Integers.
-Proof.
-apply Totally_ordered_definition.
-simpl in |- *.
-intros H' x y H'0.
-specialize  2le_or_lt with (n := x) (m := y); intro H'2; elim H'2.
-intro H'1; left; auto with sets arith.
-intro H'1; right.
-cut (y <= x); auto with sets arith.
-Qed.
-Hint Resolve le_total_order.
-
-Lemma Finite_subset_has_lub :
- forall X:Ensemble nat,
-   Finite nat X ->  exists m : nat, Upper_Bound nat nat_po X m.
-Proof.
-intros X H'; elim H'.
-exists 0.
-apply Upper_Bound_definition; auto with sets arith.
-intros y H'0; elim H'0; auto with sets arith.
-intros A H'0 H'1 x H'2; try assumption.
-elim H'1; intros x0 H'3; clear H'1.
-elim le_total_order.
-simpl in |- *.
-intro H'1; try assumption.
-lapply H'1; [ intro H'4; idtac | try assumption ]; auto with sets arith.
-generalize (H'4 x0 x).
-clear H'4.
-clear H'1.
-intro H'1; lapply H'1;
- [ intro H'4; elim H'4;
-    [ intro H'5; try exact H'5; clear H'4 H'1 | intro H'5; clear H'4 H'1 ]
- | clear H'1 ].
-exists x.
-apply Upper_Bound_definition; auto with sets arith; simpl in |- *.
-intros y H'1; elim H'1.
-generalize le_trans.
-intro H'4; red in H'4.
-intros x1 H'6; try assumption.
-apply H'4 with (y := x0); auto with sets arith.
-elim H'3; simpl in |- *; auto with sets arith.
-intros x1 H'4; elim H'4; auto with sets arith.
-exists x0.
-apply Upper_Bound_definition; auto with sets arith; simpl in |- *.
-intros y H'1; elim H'1.
-intros x1 H'4; try assumption.
-elim H'3; simpl in |- *; auto with sets arith.
-intros x1 H'4; elim H'4; auto with sets arith.
-red in |- *.
-intros x1 H'1; elim H'1; auto with sets arith.
-Qed.
-
-Lemma Integers_has_no_ub :
- ~ (exists m : nat, Upper_Bound nat nat_po Integers m).
-Proof.
-red in |- *; intro H'; elim H'.
-intros x H'0.
-elim H'0; intros H'1 H'2.
-cut (In nat Integers (S x)).
-intro H'3.
-specialize  1H'2 with (y := S x); intro H'4; lapply H'4;
- [ intro H'5; clear H'4 | try assumption; clear H'4 ].
-simpl in H'5.
-absurd (S x <= x); auto with arith.
-auto with sets arith.
-Qed.
 
-Lemma Integers_infinite : ~ Finite nat Integers.
-Proof.
-generalize Integers_has_no_ub.
-intro H'; red in |- *; intro H'0; try exact H'0.
-apply H'.
-apply Finite_subset_has_lub; auto with sets arith.
-Qed.
+  Lemma le_reflexive : Reflexive nat le.
+  Proof.
+    red in |- *; auto with arith.
+  Qed.
+  
+  Lemma le_antisym : Antisymmetric nat le.
+  Proof.
+    red in |- *; intros x y H H'; rewrite (le_antisym x y); auto.
+  Qed.
+
+  Lemma le_trans : Transitive nat le.
+  Proof.
+    red in |- *; intros; apply le_trans with y; auto.
+  Qed.
+  
+  Lemma le_Order : Order nat le.
+  Proof.
+    split; [exact le_reflexive | exact le_trans | exact le_antisym]. 
+  Qed.
+  
+  Lemma triv_nat : forall n:nat, In nat Integers n.
+  Proof.
+    exact Integers_defn.
+  Qed.
+
+  Definition nat_po : PO nat.
+    apply Definition_of_PO with (Carrier_of := Integers) (Rel_of := le);
+      auto with sets arith.
+    apply Inhabited_intro with (x := 0). 
+      apply Integers_defn.
+      exact le_Order.
+  Defined.
+  
+  Lemma le_total_order : Totally_ordered nat nat_po Integers.
+  Proof.
+    apply Totally_ordered_definition.
+    simpl in |- *.
+    intros H' x y H'0.
+    specialize  2le_or_lt with (n := x) (m := y); intro H'2; elim H'2.
+    intro H'1; left; auto with sets arith.
+    intro H'1; right.
+    cut (y <= x); auto with sets arith.
+  Qed.
+  
+  Lemma Finite_subset_has_lub :
+    forall X:Ensemble nat,
+      Finite nat X ->  exists m : nat, Upper_Bound nat nat_po X m.
+  Proof.
+    intros X H'; elim H'.
+    exists 0.
+    apply Upper_Bound_definition.
+      unfold nat_po. simpl. apply triv_nat.
+    intros y H'0; elim H'0; auto with sets arith.
+    intros A H'0 H'1 x H'2; try assumption.
+    elim H'1; intros x0 H'3; clear H'1.
+    elim le_total_order.
+    simpl in |- *.
+    intro H'1; try assumption.
+    lapply H'1; [ intro H'4; idtac | try assumption ]; auto with sets arith.
+    generalize (H'4 x0 x).
+    clear H'4.
+    clear H'1.
+    intro H'1; lapply H'1;
+      [ intro H'4; elim H'4;
+	[ intro H'5; try exact H'5; clear H'4 H'1 | intro H'5; clear H'4 H'1 ]
+	| clear H'1 ].
+    exists x.
+    apply Upper_Bound_definition. simpl in |- *. apply triv_nat.
+    intros y H'1; elim H'1.
+    generalize le_trans.
+    intro H'4; red in H'4.
+    intros x1 H'6; try assumption.
+    apply H'4 with (y := x0). elim H'3; simpl in |- *; auto with sets arith. trivial.
+    intros x1 H'4; elim H'4. unfold nat_po; simpl; trivial.
+    exists x0.
+    apply Upper_Bound_definition. 
+      unfold nat_po. simpl. apply triv_nat.
+    intros y H'1; elim H'1.
+    intros x1 H'4; try assumption.
+    elim H'3; simpl in |- *; auto with sets arith.
+    intros x1 H'4; elim H'4; auto with sets arith.
+    red in |- *.
+    intros x1 H'1; elim H'1; apply triv_nat.
+  Qed.
+
+  Lemma Integers_has_no_ub :
+    ~ (exists m : nat, Upper_Bound nat nat_po Integers m).
+  Proof.
+    red in |- *; intro H'; elim H'.
+    intros x H'0.
+    elim H'0; intros H'1 H'2.
+    cut (In nat Integers (S x)).
+    intro H'3.
+    specialize  1H'2 with (y := S x); intro H'4; lapply H'4;
+      [ intro H'5; clear H'4 | try assumption; clear H'4 ].
+    simpl in H'5.
+    absurd (S x <= x); auto with arith.
+    apply triv_nat.
+ Qed.
+  
+  Lemma Integers_infinite : ~ Finite nat Integers.
+  Proof.
+    generalize Integers_has_no_ub.
+    intro H'; red in |- *; intro H'0; try exact H'0.
+    apply H'.
+    apply Finite_subset_has_lub; auto with sets arith.
+  Qed.
 
 End Integers_sect.
 
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
index a308282b..7084a82d 100755..100644
--- a/theories/Sets/Multiset.v
+++ b/theories/Sets/Multiset.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Multiset.v,v 1.9.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+(*i $Id: Multiset.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (* G. Huet 1-9-95 *)
 
@@ -16,162 +16,156 @@ Set Implicit Arguments.
 
 Section multiset_defs.
 
-Variable A : Set.
-Variable eqA : A -> A -> Prop.
-Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+  Variable A : Set.
+  Variable eqA : A -> A -> Prop.
+  Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
 
-Inductive multiset : Set :=
+  Inductive multiset : Set :=
     Bag : (A -> nat) -> multiset.
-
-Definition EmptyBag := Bag (fun a:A => 0).
-Definition SingletonBag (a:A) :=
-  Bag (fun a':A => match Aeq_dec a a' with
-                   | left _ => 1
-                   | right _ => 0
-                   end).
-
-Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a.
-
-(** multiset equality *)
-Definition meq (m1 m2:multiset) :=
-  forall a:A, multiplicity m1 a = multiplicity m2 a.
-
-Hint Unfold meq multiplicity.
-
-Lemma meq_refl : forall x:multiset, meq x x.
-Proof.
-destruct x; auto.
-Qed.
-Hint Resolve meq_refl.
-
-Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z.
-Proof.
-unfold meq in |- *.
-destruct x; destruct y; destruct z.
-intros; rewrite H; auto.
-Qed.
-
-Lemma meq_sym : forall x y:multiset, meq x y -> meq y x.
-Proof.
-unfold meq in |- *.
-destruct x; destruct y; auto.
-Qed.
-Hint Immediate meq_sym.
-
-(** multiset union *)
-Definition munion (m1 m2:multiset) :=
-  Bag (fun a:A => multiplicity m1 a + multiplicity m2 a).
-
-Lemma munion_empty_left : forall x:multiset, meq x (munion EmptyBag x).
-Proof.
-unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
-Qed.
-Hint Resolve munion_empty_left.
-
-Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag).
-Proof.
-unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
-Qed.
-
-
-Require Import Plus. (* comm. and ass. of plus *)
-
-Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x).
-Proof.
-unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *.
-destruct x; destruct y; auto with arith.
-Qed.
-Hint Resolve munion_comm.
-
-Lemma munion_ass :
- forall x y z:multiset, meq (munion (munion x y) z) (munion x (munion y z)).
-Proof.
-unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
-destruct x; destruct y; destruct z; auto with arith.
-Qed.
-Hint Resolve munion_ass.
-
-Lemma meq_left :
- forall x y z:multiset, meq x y -> meq (munion x z) (munion y z).
-Proof.
-unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
-destruct x; destruct y; destruct z.
-intros; elim H; auto with arith.
-Qed.
-Hint Resolve meq_left.
-
-Lemma meq_right :
- forall x y z:multiset, meq x y -> meq (munion z x) (munion z y).
-Proof.
-unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
-destruct x; destruct y; destruct z.
-intros; elim H; auto.
-Qed.
-Hint Resolve meq_right.
-
-
-(** Here we should make multiset an abstract datatype, by hiding [Bag],
-    [munion], [multiplicity]; all further properties are proved abstractly *)
-
-Lemma munion_rotate :
- forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)).
-Proof.
-intros; apply (op_rotate multiset munion meq); auto.
-exact meq_trans.
-Qed.
-
-Lemma meq_congr :
- forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t).
-Proof.
-intros; apply (cong_congr multiset munion meq); auto.
-exact meq_trans.
-Qed.
-
-Lemma munion_perm_left :
- forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)).
-Proof.
-intros; apply (perm_left multiset munion meq); auto.
-exact meq_trans.
-Qed.
-
-Lemma multiset_twist1 :
- forall x y z t:multiset,
-   meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z).
-Proof.
-intros; apply (twist multiset munion meq); auto.
-exact meq_trans.
-Qed.
-
-Lemma multiset_twist2 :
- forall x y z t:multiset,
-   meq (munion x (munion (munion y z) t)) (munion (munion y (munion x z)) t).
-Proof.
-intros; apply meq_trans with (munion (munion x (munion y z)) t).
-apply meq_sym; apply munion_ass.
-apply meq_left; apply munion_perm_left.
-Qed.
-
-(** specific for treesort *)
-
-Lemma treesort_twist1 :
- forall x y z t u:multiset,
-   meq u (munion y z) ->
-   meq (munion x (munion u t)) (munion (munion y (munion x t)) z).
-Proof.
-intros; apply meq_trans with (munion x (munion (munion y z) t)).
-apply meq_right; apply meq_left; trivial.
-apply multiset_twist1.
-Qed.
-
-Lemma treesort_twist2 :
- forall x y z t u:multiset,
-   meq u (munion y z) ->
-   meq (munion x (munion u t)) (munion (munion y (munion x z)) t).
-Proof.
-intros; apply meq_trans with (munion x (munion (munion y z) t)).
-apply meq_right; apply meq_left; trivial.
-apply multiset_twist2.
-Qed.
+  
+  Definition EmptyBag := Bag (fun a:A => 0).
+  Definition SingletonBag (a:A) :=
+    Bag (fun a':A => match Aeq_dec a a' with
+                       | left _ => 1
+                       | right _ => 0
+                     end).
+
+  Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a.
+  
+  (** multiset equality *)
+  Definition meq (m1 m2:multiset) :=
+    forall a:A, multiplicity m1 a = multiplicity m2 a.
+  
+  Lemma meq_refl : forall x:multiset, meq x x.
+  Proof.
+    destruct x; unfold meq; reflexivity.
+  Qed.
+  
+  Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z.
+  Proof.
+    unfold meq in |- *.
+    destruct x; destruct y; destruct z.
+    intros; rewrite H; auto.
+  Qed.
+  
+  Lemma meq_sym : forall x y:multiset, meq x y -> meq y x.
+  Proof.
+    unfold meq in |- *.
+    destruct x; destruct y; auto.
+  Qed.
+
+  (** multiset union *)
+  Definition munion (m1 m2:multiset) :=
+    Bag (fun a:A => multiplicity m1 a + multiplicity m2 a).
+
+  Lemma munion_empty_left : forall x:multiset, meq x (munion EmptyBag x).
+  Proof.
+    unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
+  Qed.
+  
+  Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag).
+  Proof.
+    unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
+  Qed.
+
+
+  Require Plus. (* comm. and ass. of plus *)
+  
+  Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x).
+  Proof.
+    unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *.
+    destruct x; destruct y; auto with arith.
+  Qed.
+
+  Lemma munion_ass :
+    forall x y z:multiset, meq (munion (munion x y) z) (munion x (munion y z)).
+  Proof.
+    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+    destruct x; destruct y; destruct z; auto with arith.
+  Qed.
+
+  Lemma meq_left :
+    forall x y z:multiset, meq x y -> meq (munion x z) (munion y z).
+  Proof.
+    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+    destruct x; destruct y; destruct z.
+    intros; elim H; auto with arith.
+  Qed.
+
+  Lemma meq_right :
+    forall x y z:multiset, meq x y -> meq (munion z x) (munion z y).
+  Proof.
+    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+    destruct x; destruct y; destruct z.
+    intros; elim H; auto.
+  Qed.
+
+  (** Here we should make multiset an abstract datatype, by hiding [Bag],
+      [munion], [multiplicity]; all further properties are proved abstractly *)
+
+  Lemma munion_rotate :
+    forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)).
+  Proof.
+    intros; apply (op_rotate multiset munion meq). 
+      apply munion_comm.
+      apply munion_ass.
+      exact meq_trans.
+      exact meq_sym.
+      trivial.
+  Qed.
+  
+  Lemma meq_congr :
+    forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t).
+  Proof.
+    intros; apply (cong_congr multiset munion meq); auto using meq_left, meq_right.
+      exact meq_trans.
+  Qed.
+  
+  Lemma munion_perm_left :
+    forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)).
+  Proof.
+    intros; apply (perm_left multiset munion meq); auto using munion_comm, munion_ass, meq_left, meq_right, meq_sym.
+      exact meq_trans.
+  Qed.
+  
+  Lemma multiset_twist1 :
+    forall x y z t:multiset,
+      meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z).
+  Proof.
+    intros; apply (twist multiset munion meq); auto using munion_comm, munion_ass, meq_sym, meq_left, meq_right.
+    exact meq_trans.
+  Qed.
+
+  Lemma multiset_twist2 :
+    forall x y z t:multiset,
+      meq (munion x (munion (munion y z) t)) (munion (munion y (munion x z)) t).
+  Proof.
+    intros; apply meq_trans with (munion (munion x (munion y z)) t).
+    apply meq_sym; apply munion_ass.
+    apply meq_left; apply munion_perm_left.
+  Qed.
+
+  (** specific for treesort *)
+
+  Lemma treesort_twist1 :
+    forall x y z t u:multiset,
+      meq u (munion y z) ->
+      meq (munion x (munion u t)) (munion (munion y (munion x t)) z).
+  Proof.
+    intros; apply meq_trans with (munion x (munion (munion y z) t)).
+    apply meq_right; apply meq_left; trivial.
+    apply multiset_twist1.
+  Qed.
+  
+  Lemma treesort_twist2 :
+    forall x y z t u:multiset,
+      meq u (munion y z) ->
+      meq (munion x (munion u t)) (munion (munion y (munion x z)) t).
+  Proof.
+    intros; apply meq_trans with (munion x (munion (munion y z) t)).
+    apply meq_right; apply meq_left; trivial.
+    apply multiset_twist2.
+  Qed.
 
 
 (*i theory of minter to do similarly 
@@ -188,4 +182,4 @@ Unset Implicit Arguments.
 Hint Unfold meq multiplicity: v62 datatypes.
 Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right
   munion_empty_left: v62 datatypes.
-Hint Immediate meq_sym: v62 datatypes.
\ No newline at end of file
+Hint Immediate meq_sym: v62 datatypes.
diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
index b3e59886..6210913c 100755..100644
--- a/theories/Sets/Partial_Order.v
+++ b/theories/Sets/Partial_Order.v
@@ -24,32 +24,32 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Partial_Order.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Partial_Order.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Ensembles.
 Require Export Relations_1.
 
 Section Partial_orders.
-Variable U : Type.
-
-Definition Carrier := Ensemble U.
-
-Definition Rel := Relation U.
-
-Record PO : Type := Definition_of_PO
-  {Carrier_of : Ensemble U;
-   Rel_of : Relation U;
-   PO_cond1 : Inhabited U Carrier_of;
-   PO_cond2 : Order U Rel_of}.
-Variable p : PO.
-
-Definition Strict_Rel_of : Rel := fun x y:U => Rel_of p x y /\ x <> y.
-
-Inductive covers (y x:U) : Prop :=
+  Variable U : Type.
+  
+  Definition Carrier := Ensemble U.
+  
+  Definition Rel := Relation U.
+  
+  Record PO : Type := Definition_of_PO
+    { Carrier_of : Ensemble U;
+      Rel_of : Relation U;
+      PO_cond1 : Inhabited U Carrier_of;
+      PO_cond2 : Order U Rel_of }.
+  Variable p : PO.
+  
+  Definition Strict_Rel_of : Rel := fun x y:U => Rel_of p x y /\ x <> y.
+  
+  Inductive covers (y x:U) : Prop :=
     Definition_of_covers :
-      Strict_Rel_of x y ->
-      ~ (exists z : _, Strict_Rel_of x z /\ Strict_Rel_of z y) ->
-      covers y x.
+    Strict_Rel_of x y ->
+    ~ (exists z : _, Strict_Rel_of x z /\ Strict_Rel_of z y) ->
+    covers y x.
 
 End Partial_orders.
 
@@ -58,43 +58,45 @@ Hint Resolve Definition_of_covers: sets v62.
 
 
 Section Partial_order_facts.
-Variable U : Type.
-Variable D : PO U.
-
-Lemma Strict_Rel_Transitive_with_Rel :
- forall x y z:U,
-   Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z.
-unfold Strict_Rel_of at 1 in |- *.
-red in |- *.
-elim D; simpl in |- *.
-intros C R H' H'0; elim H'0.
-intros H'1 H'2 H'3 x y z H'4 H'5; split.
-apply H'2 with (y := y); tauto.
-red in |- *; intro H'6.
-elim H'4; intros H'7 H'8; apply H'8; clear H'4.
-apply H'3; auto.
-rewrite H'6; tauto.
-Qed.
+  Variable U : Type.
+  Variable D : PO U.
+  
+  Lemma Strict_Rel_Transitive_with_Rel :
+    forall x y z:U,
+      Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z.
+  Proof.
+    unfold Strict_Rel_of at 1 in |- *.
+    red in |- *.
+    elim D; simpl in |- *.
+    intros C R H' H'0; elim H'0.
+    intros H'1 H'2 H'3 x y z H'4 H'5; split.
+    apply H'2 with (y := y); tauto.
+    red in |- *; intro H'6.
+    elim H'4; intros H'7 H'8; apply H'8; clear H'4.
+    apply H'3; auto.
+    rewrite H'6; tauto.
+  Qed.
 
-Lemma Strict_Rel_Transitive_with_Rel_left :
- forall x y z:U,
-   Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z.
-unfold Strict_Rel_of at 1 in |- *.
-red in |- *.
-elim D; simpl in |- *.
-intros C R H' H'0; elim H'0.
-intros H'1 H'2 H'3 x y z H'4 H'5; split.
-apply H'2 with (y := y); tauto.
-red in |- *; intro H'6.
-elim H'5; intros H'7 H'8; apply H'8; clear H'5.
-apply H'3; auto.
-rewrite <- H'6; auto.
-Qed.
+  Lemma Strict_Rel_Transitive_with_Rel_left :
+    forall x y z:U,
+      Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z.
+  Proof.
+    unfold Strict_Rel_of at 1 in |- *.
+    red in |- *.
+    elim D; simpl in |- *.
+    intros C R H' H'0; elim H'0.
+    intros H'1 H'2 H'3 x y z H'4 H'5; split.
+    apply H'2 with (y := y); tauto.
+    red in |- *; intro H'6.
+    elim H'5; intros H'7 H'8; apply H'8; clear H'5.
+    apply H'3; auto.
+    rewrite <- H'6; auto.
+  Qed.
 
-Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D).
-red in |- *.
-intros x y z H' H'0.
-apply Strict_Rel_Transitive_with_Rel with (y := y);
- [ intuition | unfold Strict_Rel_of in H', H'0; intuition ].
-Qed.
+  Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D).
+    red in |- *.
+    intros x y z H' H'0.
+    apply Strict_Rel_Transitive_with_Rel with (y := y);
+      [ intuition | unfold Strict_Rel_of in H', H'0; intuition ].
+  Qed.
 End Partial_order_facts.
\ No newline at end of file
diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v
index af6151bf..a7c3db3a 100755..100644
--- a/theories/Sets/Permut.v
+++ b/theories/Sets/Permut.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Permut.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Permut.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (* G. Huet 1-9-95 *)
 
@@ -15,77 +15,75 @@
 
 Section Axiomatisation.
 
-Variable U : Set.
-
-Variable op : U -> U -> U.
-
-Variable cong : U -> U -> Prop.
-
-Hypothesis op_comm : forall x y:U, cong (op x y) (op y x).
-Hypothesis op_ass : forall x y z:U, cong (op (op x y) z) (op x (op y z)).
-
-Hypothesis cong_left : forall x y z:U, cong x y -> cong (op x z) (op y z).
-Hypothesis cong_right : forall x y z:U, cong x y -> cong (op z x) (op z y).
-Hypothesis cong_trans : forall x y z:U, cong x y -> cong y z -> cong x z.
-Hypothesis cong_sym : forall x y:U, cong x y -> cong y x.
-
-(** Remark. we do not need: [Hypothesis cong_refl : (x:U)(cong x x)]. *)
-
-Lemma cong_congr :
- forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t).
-Proof.
-intros; apply cong_trans with (op y z).
-apply cong_left; trivial.
-apply cong_right; trivial.
-Qed.
-
-Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)).
-Proof.
-intros; apply cong_right; apply op_comm.
-Qed.
-
-Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z).
-Proof.
-intros; apply cong_left; apply op_comm.
-Qed.
-
-Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y).
-Proof.
-intros.
-apply cong_trans with (op x (op y z)).
-apply op_ass.
-apply cong_trans with (op x (op z y)). 
-apply cong_right; apply op_comm.
-apply cong_sym; apply op_ass.
-Qed.
-
-Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)).
-Proof.
-intros.
-apply cong_trans with (op (op x y) z).
-apply cong_sym; apply op_ass.
-apply cong_trans with (op (op y x) z).
-apply cong_left; apply op_comm.
-apply op_ass.
-Qed.
-
-Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)).
-Proof.
-intros; apply cong_trans with (op (op x y) z).
-apply cong_sym; apply op_ass.
-apply op_comm.
-Qed.
-
-(* Needed for treesort ... *)
-Lemma twist :
- forall x y z t:U, cong (op x (op (op y z) t)) (op (op y (op x t)) z).
-Proof.
-intros.
-apply cong_trans with (op x (op (op y t) z)).
-apply cong_right; apply perm_right.
-apply cong_trans with (op (op x (op y t)) z).
-apply cong_sym; apply op_ass.
-apply cong_left; apply perm_left.
-Qed.
+  Variable U : Set.
+  Variable op : U -> U -> U.
+  Variable cong : U -> U -> Prop.
+
+  Hypothesis op_comm : forall x y:U, cong (op x y) (op y x).
+  Hypothesis op_ass : forall x y z:U, cong (op (op x y) z) (op x (op y z)).
+
+  Hypothesis cong_left : forall x y z:U, cong x y -> cong (op x z) (op y z).
+  Hypothesis cong_right : forall x y z:U, cong x y -> cong (op z x) (op z y).
+  Hypothesis cong_trans : forall x y z:U, cong x y -> cong y z -> cong x z.
+  Hypothesis cong_sym : forall x y:U, cong x y -> cong y x.
+
+  (** Remark. we do not need: [Hypothesis cong_refl : (x:U)(cong x x)]. *)
+
+  Lemma cong_congr :
+    forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t).
+  Proof.
+    intros; apply cong_trans with (op y z).
+    apply cong_left; trivial.
+    apply cong_right; trivial.
+  Qed.
+  
+  Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)).
+  Proof.
+    intros; apply cong_right; apply op_comm.
+  Qed.
+  
+  Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z).
+  Proof.
+    intros; apply cong_left; apply op_comm.
+  Qed.
+  
+  Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y).
+  Proof.
+    intros.
+    apply cong_trans with (op x (op y z)).
+    apply op_ass.
+    apply cong_trans with (op x (op z y)). 
+    apply cong_right; apply op_comm.
+    apply cong_sym; apply op_ass.
+  Qed.
+
+  Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)).
+  Proof.
+    intros.
+    apply cong_trans with (op (op x y) z).
+    apply cong_sym; apply op_ass.
+    apply cong_trans with (op (op y x) z).
+    apply cong_left; apply op_comm.
+    apply op_ass.
+  Qed.
+  
+  Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)).
+  Proof.
+    intros; apply cong_trans with (op (op x y) z).
+    apply cong_sym; apply op_ass.
+    apply op_comm.
+  Qed.
+
+  (** Needed for treesort ... *)
+  Lemma twist :
+    forall x y z t:U, cong (op x (op (op y z) t)) (op (op y (op x t)) z).
+  Proof.
+    intros.
+    apply cong_trans with (op x (op (op y t) z)).
+    apply cong_right; apply perm_right.
+    apply cong_trans with (op (op x (op y t)) z).
+    apply cong_sym; apply op_ass.
+    apply cong_left; apply perm_left.
+  Qed.
 
 End Axiomatisation.
\ No newline at end of file
diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v
index a7f5e9f4..c9a52ac2 100755..100644
--- a/theories/Sets/Powerset.v
+++ b/theories/Sets/Powerset.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset.v,v 1.5.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Powerset.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Require Export Ensembles.
 Require Export Relations_1.
diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v
index 05c60def..47857705 100755..100644
--- a/theories/Sets/Powerset_Classical_facts.v
+++ b/theories/Sets/Powerset_Classical_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset_Classical_facts.v,v 1.5.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Powerset_Classical_facts.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Ensembles.
 Require Export Constructive_sets.
@@ -39,298 +39,294 @@ Require Export Classical_sets.
 
 Section Sets_as_an_algebra.
 
-Variable U : Type.
+  Variable U : Type.
+  
+  Lemma sincl_add_x :
+    forall (A B:Ensemble U) (x:U),
+      ~ In U A x ->
+      Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B.
+  Proof.
+    intros A B x H' H'0; red in |- *.
+    lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets.
+    clear H'0; intro H'0; split.
+    apply incl_add_x with (x := x); tauto.
+    elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2.
+    intros x0 H'0.
+    red in |- *; intro H'2.
+    elim H'0; clear H'0.
+    rewrite <- H'2; auto with sets.
+  Qed.
 
-Lemma sincl_add_x :
- forall (A B:Ensemble U) (x:U),
-   ~ In U A x ->
-   Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B.
-Proof.
-intros A B x H' H'0; red in |- *.
-lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets.
-clear H'0; intro H'0; split.
-apply incl_add_x with (x := x); tauto.
-elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2.
-intros x0 H'0.
-red in |- *; intro H'2.
-elim H'0; clear H'0.
-rewrite <- H'2; auto with sets.
-Qed.
+  Lemma incl_soustr_in :
+    forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X.
+  Proof.
+    intros X x H'; red in |- *.
+    intros x0 H'0; elim H'0; auto with sets.
+  Qed.
+  
+  Lemma incl_soustr :
+    forall (X Y:Ensemble U) (x:U),
+      Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
+  Proof.
+    intros X Y x H'; red in |- *.
+    intros x0 H'0; elim H'0.
+    intros H'1 H'2.
+    apply Subtract_intro; auto with sets.
+  Qed.
+  
+  Lemma incl_soustr_add_l :
+    forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
+  Proof.
+    intros X x; red in |- *.
+    intros x0 H'; elim H'; auto with sets.
+    intro H'0; elim H'0; auto with sets.
+    intros t H'1 H'2; elim H'2; auto with sets.
+  Qed.
 
-Lemma incl_soustr_in :
- forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X.
-Proof.
-intros X x H'; red in |- *.
-intros x0 H'0; elim H'0; auto with sets.
-Qed.
-Hint Resolve incl_soustr_in: sets v62.
-
-Lemma incl_soustr :
- forall (X Y:Ensemble U) (x:U),
-   Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
-Proof.
-intros X Y x H'; red in |- *.
-intros x0 H'0; elim H'0.
-intros H'1 H'2.
-apply Subtract_intro; auto with sets.
-Qed.
-Hint Resolve incl_soustr: sets v62.
-
-
-Lemma incl_soustr_add_l :
- forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
-Proof.
-intros X x; red in |- *.
-intros x0 H'; elim H'; auto with sets.
-intro H'0; elim H'0; auto with sets.
-intros t H'1 H'2; elim H'2; auto with sets.
-Qed.
-Hint Resolve incl_soustr_add_l: sets v62.
+  Lemma incl_soustr_add_r :
+    forall (X:Ensemble U) (x:U),
+      ~ In U X x -> Included U X (Subtract U (Add U X x) x).
+  Proof.
+    intros X x H'; red in |- *.
+    intros x0 H'0; try assumption.
+    apply Subtract_intro; auto with sets.
+    red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets.
+  Qed.
+  Hint Resolve incl_soustr_add_r: sets v62.
+  
+  Lemma add_soustr_2 :
+    forall (X:Ensemble U) (x:U),
+      In U X x -> Included U X (Add U (Subtract U X x) x).
+  Proof.
+    intros X x H'; red in |- *.
+    intros x0 H'0; try assumption.
+    elim (classic (x = x0)); intro K; auto with sets.
+    elim K; auto with sets.
+  Qed.
+  
+  Lemma add_soustr_1 :
+    forall (X:Ensemble U) (x:U),
+      In U X x -> Included U (Add U (Subtract U X x) x) X.
+  Proof.
+    intros X x H'; red in |- *.
+    intros x0 H'0; elim H'0; auto with sets.
+    intros y H'1; elim H'1; auto with sets.
+    intros t H'1; try assumption.
+    rewrite <- (Singleton_inv U x t); auto with sets.
+  Qed.
+  
+  Lemma add_soustr_xy :
+    forall (X:Ensemble U) (x y:U),
+      x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
+  Proof.
+    intros X x y H'; apply Extensionality_Ensembles.
+    split; red in |- *.
+    intros x0 H'0; elim H'0; auto with sets.
+    intro H'1; elim H'1.
+    intros u H'2 H'3; try assumption.
+    apply Add_intro1.
+    apply Subtract_intro; auto with sets.
+    intros t H'2 H'3; try assumption.
+    elim (Singleton_inv U x t); auto with sets.
+    intros u H'2; try assumption.
+    elim (Add_inv U (Subtract U X y) x u); auto with sets.
+    intro H'0; elim H'0; auto with sets.
+    intro H'0; rewrite <- H'0; auto with sets.
+  Qed.
+  
+  Lemma incl_st_add_soustr :
+    forall (X Y:Ensemble U) (x:U),
+      ~ In U X x ->
+      Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x).
+  Proof.
+    intros X Y x H' H'0; apply sincl_add_x with (x := x); auto using add_soustr_1 with sets.
+    split.
+    elim H'0.
+    intros H'1 H'2.
+    generalize (Inclusion_is_transitive U).
+    intro H'4; red in H'4.
+    apply H'4 with (y := Y); auto using add_soustr_2 with sets.
+    red in H'0.
+    elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *)
+    red in |- *; intro H'0; apply H'2.
+    rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
+  Qed.
+  
+  Lemma Sub_Add_new :
+    forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x.
+  Proof.
+    auto using incl_soustr_add_l with sets.
+  Qed.
+  
+  Lemma Simplify_add :
+    forall (X X0:Ensemble U) (x:U),
+      ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0.
+  Proof.
+    intros X X0 x H' H'0 H'1; try assumption.
+    rewrite (Sub_Add_new X x); auto with sets.
+    rewrite (Sub_Add_new X0 x); auto with sets.
+    rewrite H'1; auto with sets.
+  Qed.
+  
+  Lemma Included_Add :
+    forall (X A:Ensemble U) (x:U),
+      Included U X (Add U A x) ->
+      Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A).
+  Proof.
+    intros X A x H'0; try assumption.
+    elim (classic (In U X x)).
+    intro H'1; right; try assumption.
+    exists (Subtract U X x).
+    split; auto using incl_soustr_in, add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
+    red in H'0.
+    red in |- *.
+    intros x0 H'2; try assumption.
+    lapply (Subtract_inv U X x x0); auto with sets.
+    intro H'3; elim H'3; intros K K'; clear H'3.
+    lapply (H'0 x0); auto with sets.
+    intro H'3; try assumption.
+    lapply (Add_inv U A x x0); auto with sets.
+    intro H'4; elim H'4;
+      [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
+    elim K'; auto with sets.
+    intro H'1; left; try assumption.
+    red in H'0.
+    red in |- *.
+    intros x0 H'2; try assumption.
+    lapply (H'0 x0); auto with sets.
+    intro H'3; try assumption.
+    lapply (Add_inv U A x x0); auto with sets.
+    intro H'4; elim H'4;
+      [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
+    absurd (In U X x0); auto with sets.
+    rewrite <- H'5; auto with sets.
+  Qed.
+  
+  Lemma setcover_inv :
+    forall A x y:Ensemble U,
+      covers (Ensemble U) (Power_set_PO U A) y x ->
+      Strict_Included U x y /\
+      (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y).
+  Proof.
+    intros A x y H'; elim H'.
+    unfold Strict_Rel_of in |- *; simpl in |- *.
+    intros H'0 H'1; split; [ auto with sets | idtac ].
+    intros z H'2 H'3; try assumption.
+    elim (classic (x = z)); auto with sets.
+    intro H'4; right; try assumption.
+    elim (classic (z = y)); auto with sets.
+    intro H'5; try assumption.
+    elim H'1.
+    exists z; auto with sets.
+  Qed.
+  
+  Theorem Add_covers :
+    forall A a:Ensemble U,
+      Included U a A ->
+      forall x:U,
+	In U A x ->
+	~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a.
+  Proof.
+    intros A a H' x H'0 H'1; try assumption.
+    apply setcover_intro; auto with sets.
+    red in |- *.
+    split; [ idtac | red in |- *; intro H'2; try exact H'2 ]; auto with sets.
+    apply H'1.
+    rewrite H'2; auto with sets.
+    red in |- *; intro H'2; elim H'2; clear H'2.
+    intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
+    lapply (Strict_Included_inv U a z); auto with sets; clear H'3.
+    intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5.
+    intros x0 H'2; elim H'2.
+    intros H'5 H'6; try assumption.
+    generalize H'4; intro K.
+    red in H'4.
+    elim H'4; intros H'8 H'9; red in H'8; clear H'4.
+    lapply (H'8 x0); auto with sets.
+    intro H'7; try assumption.
+    elim (Add_inv U a x x0); auto with sets.
+    intro H'15.
+    cut (Included U (Add U a x) z).
+    intro H'10; try assumption.
+    red in K.
+    elim K; intros H'11 H'12; apply H'12; clear K; auto with sets.
+    rewrite H'15.
+    red in |- *.
+    intros x1 H'10; elim H'10; auto with sets.
+    intros x2 H'11; elim H'11; auto with sets.
+  Qed.
+  
+  Theorem covers_Add :
+    forall A a a':Ensemble U,
+      Included U a A ->
+      Included U a' A ->
+      covers (Ensemble U) (Power_set_PO U A) a' a ->
+      exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x.
+  Proof.
+    intros A a a' H' H'0 H'1; try assumption.
+    elim (setcover_inv A a a'); auto with sets.
+    intros H'6 H'7.
+    clear H'1.
+    elim (Strict_Included_inv U a a'); auto with sets.
+    intros H'5 H'8; elim H'8.
+    intros x H'1; elim H'1.
+    intros H'2 H'3; try assumption.
+    exists x.
+    split; [ try assumption | idtac ].
+    clear H'8 H'1.
+    elim (H'7 (Add U a x)); auto with sets.
+    intro H'1.
+    absurd (a = Add U a x); auto with sets.
+    red in |- *; intro H'8; try exact H'8.
+    apply H'3.
+    rewrite H'8; auto with sets.
+    auto with sets.
+    red in |- *.
+    intros x0 H'1; elim H'1; auto with sets.
+    intros x1 H'8; elim H'8; auto with sets.
+    split; [ idtac | try assumption ].
+    red in H'0; auto with sets.
+  Qed.
 
-Lemma incl_soustr_add_r :
- forall (X:Ensemble U) (x:U),
-   ~ In U X x -> Included U X (Subtract U (Add U X x) x).
-Proof.
-intros X x H'; red in |- *.
-intros x0 H'0; try assumption.
-apply Subtract_intro; auto with sets.
-red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets.
-Qed.
-Hint Resolve incl_soustr_add_r: sets v62.
-
-Lemma add_soustr_2 :
- forall (X:Ensemble U) (x:U),
-   In U X x -> Included U X (Add U (Subtract U X x) x).
-Proof.
-intros X x H'; red in |- *.
-intros x0 H'0; try assumption.
-elim (classic (x = x0)); intro K; auto with sets.
-elim K; auto with sets.
-Qed.
-
-Lemma add_soustr_1 :
- forall (X:Ensemble U) (x:U),
-   In U X x -> Included U (Add U (Subtract U X x) x) X.
-Proof.
-intros X x H'; red in |- *.
-intros x0 H'0; elim H'0; auto with sets.
-intros y H'1; elim H'1; auto with sets.
-intros t H'1; try assumption.
-rewrite <- (Singleton_inv U x t); auto with sets.
-Qed.
-Hint Resolve add_soustr_1 add_soustr_2: sets v62.
-
-Lemma add_soustr_xy :
- forall (X:Ensemble U) (x y:U),
-   x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
-Proof.
-intros X x y H'; apply Extensionality_Ensembles.
-split; red in |- *.
-intros x0 H'0; elim H'0; auto with sets.
-intro H'1; elim H'1.
-intros u H'2 H'3; try assumption.
-apply Add_intro1.
-apply Subtract_intro; auto with sets.
-intros t H'2 H'3; try assumption.
-elim (Singleton_inv U x t); auto with sets.
-intros u H'2; try assumption.
-elim (Add_inv U (Subtract U X y) x u); auto with sets.
-intro H'0; elim H'0; auto with sets.
-intro H'0; rewrite <- H'0; auto with sets.
-Qed.
-Hint Resolve add_soustr_xy: sets v62.
-
-Lemma incl_st_add_soustr :
- forall (X Y:Ensemble U) (x:U),
-   ~ In U X x ->
-   Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x).
-Proof.
-intros X Y x H' H'0; apply sincl_add_x with (x := x); auto with sets.
-split.
-elim H'0.
-intros H'1 H'2.
-generalize (Inclusion_is_transitive U).
-intro H'4; red in H'4.
-apply H'4 with (y := Y); auto with sets.
-red in H'0.
-elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *)
-red in |- *; intro H'0; apply H'2.
-rewrite H'0; auto 8 with sets.
-Qed.
-
-Lemma Sub_Add_new :
- forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x.
-Proof.
-auto with sets.
-Qed.
-
-Lemma Simplify_add :
- forall (X X0:Ensemble U) (x:U),
-   ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0.
-Proof.
-intros X X0 x H' H'0 H'1; try assumption.
-rewrite (Sub_Add_new X x); auto with sets.
-rewrite (Sub_Add_new X0 x); auto with sets.
-rewrite H'1; auto with sets.
-Qed.
-
-Lemma Included_Add :
- forall (X A:Ensemble U) (x:U),
-   Included U X (Add U A x) ->
-   Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A).
-Proof.
-intros X A x H'0; try assumption.
-elim (classic (In U X x)).
-intro H'1; right; try assumption.
-exists (Subtract U X x).
-split; auto with sets.
-red in H'0.
-red in |- *.
-intros x0 H'2; try assumption.
-lapply (Subtract_inv U X x x0); auto with sets.
-intro H'3; elim H'3; intros K K'; clear H'3.
-lapply (H'0 x0); auto with sets.
-intro H'3; try assumption.
-lapply (Add_inv U A x x0); auto with sets.
-intro H'4; elim H'4;
- [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
-elim K'; auto with sets.
-intro H'1; left; try assumption.
-red in H'0.
-red in |- *.
-intros x0 H'2; try assumption.
-lapply (H'0 x0); auto with sets.
-intro H'3; try assumption.
-lapply (Add_inv U A x x0); auto with sets.
-intro H'4; elim H'4;
- [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
-absurd (In U X x0); auto with sets.
-rewrite <- H'5; auto with sets.
-Qed.
-
-Lemma setcover_inv :
- forall A x y:Ensemble U,
-   covers (Ensemble U) (Power_set_PO U A) y x ->
-   Strict_Included U x y /\
-   (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y).
-Proof.
-intros A x y H'; elim H'.
-unfold Strict_Rel_of in |- *; simpl in |- *.
-intros H'0 H'1; split; [ auto with sets | idtac ].
-intros z H'2 H'3; try assumption.
-elim (classic (x = z)); auto with sets.
-intro H'4; right; try assumption.
-elim (classic (z = y)); auto with sets.
-intro H'5; try assumption.
-elim H'1.
-exists z; auto with sets.
-Qed.
-
-Theorem Add_covers :
- forall A a:Ensemble U,
-   Included U a A ->
-   forall x:U,
-     In U A x ->
-     ~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a.
-Proof.
-intros A a H' x H'0 H'1; try assumption.
-apply setcover_intro; auto with sets.
-red in |- *.
-split; [ idtac | red in |- *; intro H'2; try exact H'2 ]; auto with sets.
-apply H'1.
-rewrite H'2; auto with sets.
-red in |- *; intro H'2; elim H'2; clear H'2.
-intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
-lapply (Strict_Included_inv U a z); auto with sets; clear H'3.
-intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5.
-intros x0 H'2; elim H'2.
-intros H'5 H'6; try assumption.
-generalize H'4; intro K.
-red in H'4.
-elim H'4; intros H'8 H'9; red in H'8; clear H'4.
-lapply (H'8 x0); auto with sets.
-intro H'7; try assumption.
-elim (Add_inv U a x x0); auto with sets.
-intro H'15.
-cut (Included U (Add U a x) z).
-intro H'10; try assumption.
-red in K.
-elim K; intros H'11 H'12; apply H'12; clear K; auto with sets.
-rewrite H'15.
-red in |- *.
-intros x1 H'10; elim H'10; auto with sets.
-intros x2 H'11; elim H'11; auto with sets.
-Qed.
-
-Theorem covers_Add :
- forall A a a':Ensemble U,
-   Included U a A ->
-   Included U a' A ->
-   covers (Ensemble U) (Power_set_PO U A) a' a ->
-    exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x.
-Proof.
-intros A a a' H' H'0 H'1; try assumption.
-elim (setcover_inv A a a'); auto with sets.
-intros H'6 H'7.
-clear H'1.
-elim (Strict_Included_inv U a a'); auto with sets.
-intros H'5 H'8; elim H'8.
-intros x H'1; elim H'1.
-intros H'2 H'3; try assumption.
-exists x.
-split; [ try assumption | idtac ].
-clear H'8 H'1.
-elim (H'7 (Add U a x)); auto with sets.
-intro H'1.
-absurd (a = Add U a x); auto with sets.
-red in |- *; intro H'8; try exact H'8.
-apply H'3.
-rewrite H'8; auto with sets.
-auto with sets.
-red in |- *.
-intros x0 H'1; elim H'1; auto with sets.
-intros x1 H'8; elim H'8; auto with sets.
-split; [ idtac | try assumption ].
-red in H'0; auto with sets.
-Qed.
-
-Theorem covers_is_Add :
- forall A a a':Ensemble U,
-   Included U a A ->
-   Included U a' A ->
-   (covers (Ensemble U) (Power_set_PO U A) a' a <->
-    (exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)).
-Proof.
-intros A a a' H' H'0; split; intro K.
-apply covers_Add with (A := A); auto with sets.
-elim K.
-intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1.
-apply Add_covers; intuition.
-Qed.
-
-Theorem Singleton_atomic :
- forall (x:U) (A:Ensemble U),
-   In U A x ->
-   covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U).
-intros x A H'.
-rewrite <- (Empty_set_zero' U x).
-apply Add_covers; auto with sets.
-Qed.
-
-Lemma less_than_singleton :
- forall (X:Ensemble U) (x:U),
-   Strict_Included U X (Singleton U x) -> X = Empty_set U.
-intros X x H'; try assumption.
-red in H'.
-lapply (Singleton_atomic x (Full_set U));
- [ intro H'2; try exact H'2 | apply Full_intro ].
-elim H'; intros H'0 H'1; try exact H'1; clear H'.
-elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x));
- [ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets.
-elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ];
- auto with sets.
-elim H'1; auto with sets.
-Qed.
+  Theorem covers_is_Add :
+    forall A a a':Ensemble U,
+      Included U a A ->
+      Included U a' A ->
+      (covers (Ensemble U) (Power_set_PO U A) a' a <->
+	(exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)).
+  Proof.
+    intros A a a' H' H'0; split; intro K.
+    apply covers_Add with (A := A); auto with sets.
+    elim K.
+    intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1.
+    apply Add_covers; intuition.
+  Qed.
+  
+  Theorem Singleton_atomic :
+    forall (x:U) (A:Ensemble U),
+      In U A x ->
+      covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U).
+  Proof.
+    intros x A H'.
+    rewrite <- (Empty_set_zero' U x).
+    apply Add_covers; auto with sets.
+  Qed.
+  
+  Lemma less_than_singleton :
+    forall (X:Ensemble U) (x:U),
+      Strict_Included U X (Singleton U x) -> X = Empty_set U.
+  Proof.
+    intros X x H'; try assumption.
+    red in H'.
+    lapply (Singleton_atomic x (Full_set U));
+      [ intro H'2; try exact H'2 | apply Full_intro ].
+    elim H'; intros H'0 H'1; try exact H'1; clear H'.
+    elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x));
+      [ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets.
+    elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ];
+      auto with sets.
+    elim H'1; auto with sets.
+  Qed.
 
 End Sets_as_an_algebra.
 
@@ -339,4 +335,4 @@ Hint Resolve incl_soustr: sets v62.
 Hint Resolve incl_soustr_add_l: sets v62.
 Hint Resolve incl_soustr_add_r: sets v62.
 Hint Resolve add_soustr_1 add_soustr_2: sets v62.
-Hint Resolve add_soustr_xy: sets v62.
\ No newline at end of file
+Hint Resolve add_soustr_xy: sets v62.
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
index 2c71f529..edb6a215 100755..100644
--- a/theories/Sets/Powerset_facts.v
+++ b/theories/Sets/Powerset_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Powerset_facts.v,v 1.8.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Powerset_facts.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Export Ensembles.
 Require Export Constructive_sets.
@@ -35,231 +35,223 @@ Require Export Cpo.
 Require Export Powerset.
 
 Section Sets_as_an_algebra.
-Variable U : Type.
-Hint Unfold not.
+  Variable U : Type.
 
-Theorem Empty_set_zero : forall X:Ensemble U, Union U (Empty_set U) X = X.
-Proof.
-auto 6 with sets.
-Qed.
-Hint Resolve Empty_set_zero.
+  Theorem Empty_set_zero : forall X:Ensemble U, Union U (Empty_set U) X = X.
+  Proof.
+    auto 6 with sets.
+  Qed.
+  
+  Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x.
+  Proof.
+    unfold Add at 1 in |- *; auto using Empty_set_zero with sets.
+  Qed.
+  
+  Lemma less_than_empty :
+    forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U.
+  Proof.
+    auto with sets.
+  Qed.
+  
+  Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A.
+  Proof.
+    auto with sets.
+  Qed.
+  
+  Theorem Union_associative :
+    forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C).
+  Proof.
+    auto 9 with sets.
+  Qed.
+  
+  Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A.
+  Proof.
+    auto 7 with sets.
+  Qed.
+  
+  Lemma Union_absorbs :
+    forall A B:Ensemble U, Included U B A -> Union U A B = A.
+  Proof.
+    auto 7 with sets.
+  Qed.
 
-Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x.
-Proof.
-unfold Add at 1 in |- *; auto with sets.
-Qed.
-Hint Resolve Empty_set_zero'.
+  Theorem Couple_as_union :
+    forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y.
+  Proof.
+    intros x y; apply Extensionality_Ensembles; split; red in |- *.
+    intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets).
+    intros x0 H'; elim H'; auto with sets.
+  Qed.
+  
+  Theorem Triple_as_union :
+    forall x y z:U,
+      Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) =
+      Triple U x y z.
+  Proof.
+    intros x y z; apply Extensionality_Ensembles; split; red in |- *.
+    intros x0 H'; elim H'.
+    intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets).
+    intros x1 H'0; elim H'0; auto with sets.
+    intros x0 H'; elim H'; auto with sets.
+  Qed.
+  
+  Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y.
+  Proof.
+    intros x y.
+    rewrite <- (Couple_as_union x y).
+    rewrite <- (Union_idempotent (Singleton U x)).
+    apply Triple_as_union.
+  Qed.
+  
+  Theorem Triple_as_Couple_Singleton :
+    forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z).
+  Proof.
+    intros x y z.
+    rewrite <- (Triple_as_union x y z).
+    rewrite <- (Couple_as_union x y); auto with sets.
+  Qed.
+  
+  Theorem Intersection_commutative :
+    forall A B:Ensemble U, Intersection U A B = Intersection U B A.
+  Proof.
+    intros A B.
+    apply Extensionality_Ensembles.
+    split; red in |- *; intros x H'; elim H'; auto with sets.
+  Qed.
+  
+  Theorem Distributivity :
+    forall A B C:Ensemble U,
+      Intersection U A (Union U B C) =
+      Union U (Intersection U A B) (Intersection U A C).
+  Proof.
+    intros A B C.
+    apply Extensionality_Ensembles.
+    split; red in |- *; intros x H'.
+    elim H'.
+    intros x0 H'0 H'1; generalize H'0.
+    elim H'1; auto with sets.
+    elim H'; intros x0 H'0; elim H'0; auto with sets.
+  Qed.
+  
+  Theorem Distributivity' :
+    forall A B C:Ensemble U,
+      Union U A (Intersection U B C) =
+      Intersection U (Union U A B) (Union U A C).
+  Proof.
+    intros A B C.
+    apply Extensionality_Ensembles.
+    split; red in |- *; intros x H'.
+    elim H'; auto with sets.
+    intros x0 H'0; elim H'0; auto with sets.
+    elim H'.
+    intros x0 H'0; elim H'0; auto with sets.
+    intros x1 H'1 H'2; try exact H'2.
+    generalize H'1.
+    elim H'2; auto with sets.
+  Qed.
+  
+  Theorem Union_add :
+    forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x).
+  Proof.
+    unfold Add in |- *; auto using Union_associative with sets.
+  Qed.
+  
+  Theorem Non_disjoint_union :
+    forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X.
+  Proof.
+    intros X x H'; unfold Add in |- *.
+    apply Extensionality_Ensembles; red in |- *.
+    split; red in |- *; auto with sets.
+    intros x0 H'0; elim H'0; auto with sets.
+    intros t H'1; elim H'1; auto with sets.
+  Qed.
+  
+  Theorem Non_disjoint_union' :
+    forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X.
+  Proof.
+    intros X x H'; unfold Subtract in |- *.
+    apply Extensionality_Ensembles.
+    split; red in |- *; auto with sets.
+    intros x0 H'0; elim H'0; auto with sets.
+    intros x0 H'0; apply Setminus_intro; auto with sets.
+    red in |- *; intro H'1; elim H'1.
+    lapply (Singleton_inv U x x0); auto with sets.
+    intro H'4; apply H'; rewrite H'4; auto with sets.
+  Qed.
+  
+  Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y.
+  Proof.
+    intro x; rewrite (Empty_set_zero' x); auto with sets.
+  Qed.
+  
+  Lemma incl_add :
+    forall (A B:Ensemble U) (x:U),
+      Included U A B -> Included U (Add U A x) (Add U B x).
+  Proof.
+    intros A B x H'; red in |- *; auto with sets.
+    intros x0 H'0.
+    lapply (Add_inv U A x x0); auto with sets.
+    intro H'1; elim H'1;
+      [ intro H'2; clear H'1 | intro H'2; rewrite <- H'2; clear H'1 ];
+      auto with sets.
+  Qed.
 
-Lemma less_than_empty :
- forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U.
-Proof.
-auto with sets.
-Qed.
-Hint Resolve less_than_empty.
+  Lemma incl_add_x :
+    forall (A B:Ensemble U) (x:U),
+      ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B.
+  Proof.
+    unfold Included in |- *.
+    intros A B x H' H'0 x0 H'1.
+    lapply (H'0 x0); auto with sets.
+    intro H'2; lapply (Add_inv U B x x0); auto with sets.
+    intro H'3; elim H'3;
+      [ intro H'4; try exact H'4; clear H'3 | intro H'4; clear H'3 ].
+    absurd (In U A x0); auto with sets.
+    rewrite <- H'4; auto with sets.
+  Qed.
+  
+  Lemma Add_commutative :
+    forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x.
+  Proof.
+    intros A x y.
+    unfold Add in |- *.
+    rewrite (Union_associative A (Singleton U x) (Singleton U y)).
+    rewrite (Union_commutative (Singleton U x) (Singleton U y)).
+    rewrite <- (Union_associative A (Singleton U y) (Singleton U x));
+      auto with sets.
+  Qed.
+  
+  Lemma Add_commutative' :
+    forall (A:Ensemble U) (x y z:U),
+      Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y.
+  Proof.
+    intros A x y z.
+    rewrite (Add_commutative (Add U A x) y z).
+    rewrite (Add_commutative A x z); auto with sets.
+  Qed.
+  
+  Lemma Add_distributes :
+    forall (A B:Ensemble U) (x y:U),
+      Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y).
+  Proof.
+    intros A B x y H'; try assumption.
+    rewrite <- (Union_add (Add U A x) B y).
+    unfold Add at 4 in |- *.
+    rewrite (Union_commutative A (Singleton U x)).
+    rewrite Union_associative.
+    rewrite (Union_absorbs A B H').
+    rewrite (Union_commutative (Singleton U x) A).
+    auto with sets.
+  Qed.
 
-Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A.
-Proof.
-auto with sets.
-Qed.
-
-Theorem Union_associative :
- forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C).
-Proof.
-auto 9 with sets.
-Qed.
-Hint Resolve Union_associative.
-
-Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A.
-Proof.
-auto 7 with sets.
-Qed.
-
-Lemma Union_absorbs :
- forall A B:Ensemble U, Included U B A -> Union U A B = A.
-Proof.
-auto 7 with sets.
-Qed.
-
-Theorem Couple_as_union :
- forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y.
-Proof.
-intros x y; apply Extensionality_Ensembles; split; red in |- *.
-intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets).
-intros x0 H'; elim H'; auto with sets.
-Qed.
-
-Theorem Triple_as_union :
- forall x y z:U,
-   Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) =
-   Triple U x y z.
-Proof.
-intros x y z; apply Extensionality_Ensembles; split; red in |- *.
-intros x0 H'; elim H'.
-intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets).
-intros x1 H'0; elim H'0; auto with sets.
-intros x0 H'; elim H'; auto with sets.
-Qed.
-
-Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y.
-Proof.
-intros x y.
-rewrite <- (Couple_as_union x y).
-rewrite <- (Union_idempotent (Singleton U x)).
-apply Triple_as_union.
-Qed.
-
-Theorem Triple_as_Couple_Singleton :
- forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z).
-Proof.
-intros x y z.
-rewrite <- (Triple_as_union x y z).
-rewrite <- (Couple_as_union x y); auto with sets.
-Qed.
-
-Theorem Intersection_commutative :
- forall A B:Ensemble U, Intersection U A B = Intersection U B A.
-Proof.
-intros A B.
-apply Extensionality_Ensembles.
-split; red in |- *; intros x H'; elim H'; auto with sets.
-Qed.
-
-Theorem Distributivity :
- forall A B C:Ensemble U,
-   Intersection U A (Union U B C) =
-   Union U (Intersection U A B) (Intersection U A C).
-Proof.
-intros A B C.
-apply Extensionality_Ensembles.
-split; red in |- *; intros x H'.
-elim H'.
-intros x0 H'0 H'1; generalize H'0.
-elim H'1; auto with sets.
-elim H'; intros x0 H'0; elim H'0; auto with sets.
-Qed.
-
-Theorem Distributivity' :
- forall A B C:Ensemble U,
-   Union U A (Intersection U B C) =
-   Intersection U (Union U A B) (Union U A C).
-Proof.
-intros A B C.
-apply Extensionality_Ensembles.
-split; red in |- *; intros x H'.
-elim H'; auto with sets.
-intros x0 H'0; elim H'0; auto with sets.
-elim H'.
-intros x0 H'0; elim H'0; auto with sets.
-intros x1 H'1 H'2; try exact H'2.
-generalize H'1.
-elim H'2; auto with sets.
-Qed.
-
-Theorem Union_add :
- forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x).
-Proof.
-unfold Add in |- *; auto with sets.
-Qed.
-Hint Resolve Union_add.
-
-Theorem Non_disjoint_union :
- forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X.
-intros X x H'; unfold Add in |- *.
-apply Extensionality_Ensembles; red in |- *.
-split; red in |- *; auto with sets.
-intros x0 H'0; elim H'0; auto with sets.
-intros t H'1; elim H'1; auto with sets.
-Qed.
-
-Theorem Non_disjoint_union' :
- forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X.
-Proof.
-intros X x H'; unfold Subtract in |- *.
-apply Extensionality_Ensembles.
-split; red in |- *; auto with sets.
-intros x0 H'0; elim H'0; auto with sets.
-intros x0 H'0; apply Setminus_intro; auto with sets.
-red in |- *; intro H'1; elim H'1.
-lapply (Singleton_inv U x x0); auto with sets.
-intro H'4; apply H'; rewrite H'4; auto with sets.
-Qed.
-
-Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y.
-Proof.
-intro x; rewrite (Empty_set_zero' x); auto with sets.
-Qed.
-Hint Resolve singlx.
-
-Lemma incl_add :
- forall (A B:Ensemble U) (x:U),
-   Included U A B -> Included U (Add U A x) (Add U B x).
-Proof.
-intros A B x H'; red in |- *; auto with sets.
-intros x0 H'0.
-lapply (Add_inv U A x x0); auto with sets.
-intro H'1; elim H'1;
- [ intro H'2; clear H'1 | intro H'2; rewrite <- H'2; clear H'1 ];
- auto with sets.
-Qed.
-Hint Resolve incl_add.
-
-Lemma incl_add_x :
- forall (A B:Ensemble U) (x:U),
-   ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B.
-Proof.
-unfold Included in |- *.
-intros A B x H' H'0 x0 H'1.
-lapply (H'0 x0); auto with sets.
-intro H'2; lapply (Add_inv U B x x0); auto with sets.
-intro H'3; elim H'3;
- [ intro H'4; try exact H'4; clear H'3 | intro H'4; clear H'3 ].
-absurd (In U A x0); auto with sets.
-rewrite <- H'4; auto with sets.
-Qed.
-
-Lemma Add_commutative :
- forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x.
-Proof.
-intros A x y.
-unfold Add in |- *.
-rewrite (Union_associative A (Singleton U x) (Singleton U y)).
-rewrite (Union_commutative (Singleton U x) (Singleton U y)).
-rewrite <- (Union_associative A (Singleton U y) (Singleton U x));
- auto with sets.
-Qed.
-
-Lemma Add_commutative' :
- forall (A:Ensemble U) (x y z:U),
-   Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y.
-Proof.
-intros A x y z.
-rewrite (Add_commutative (Add U A x) y z).
-rewrite (Add_commutative A x z); auto with sets.
-Qed.
-
-Lemma Add_distributes :
- forall (A B:Ensemble U) (x y:U),
-   Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y).
-Proof.
-intros A B x y H'; try assumption.
-rewrite <- (Union_add (Add U A x) B y).
-unfold Add at 4 in |- *.
-rewrite (Union_commutative A (Singleton U x)).
-rewrite Union_associative.
-rewrite (Union_absorbs A B H').
-rewrite (Union_commutative (Singleton U x) A).
-auto with sets.
-Qed.
-
-Lemma setcover_intro :
- forall (U:Type) (A x y:Ensemble U),
-   Strict_Included U x y ->
-   ~ (exists z : _, Strict_Included U x z /\ Strict_Included U z y) ->
-   covers (Ensemble U) (Power_set_PO U A) y x.
-Proof.
-intros; apply Definition_of_covers; auto with sets.
-Qed.
-Hint Resolve setcover_intro.
+  Lemma setcover_intro :
+    forall (U:Type) (A x y:Ensemble U),
+      Strict_Included U x y ->
+      ~ (exists z : _, Strict_Included U x z /\ Strict_Included U z y) ->
+      covers (Ensemble U) (Power_set_PO U A) y x.
+  Proof.
+    intros; apply Definition_of_covers; auto with sets.
+  Qed.
 
 End Sets_as_an_algebra.
 
diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
index e33746a9..64c4c654 100755..100644
--- a/theories/Sets/Relations_1.v
+++ b/theories/Sets/Relations_1.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_1.v,v 1.4.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Relations_1.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Section Relations_1.
    Variable U : Type.
diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v
index 62688895..6ee7f5e2 100755..100644
--- a/theories/Sets/Relations_1_facts.v
+++ b/theories/Sets/Relations_1_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_1_facts.v,v 1.7.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Relations_1_facts.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Require Export Relations_1.
 
diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v
index 15d3ee2d..a74102fd 100755..100644
--- a/theories/Sets/Relations_2.v
+++ b/theories/Sets/Relations_2.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_2.v,v 1.4.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Relations_2.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Require Export Relations_1.
 
@@ -32,18 +32,18 @@ Section Relations_2.
 Variable U : Type.
 Variable R : Relation U.
 
-Inductive Rstar : Relation U :=
-  | Rstar_0 : forall x:U, Rstar x x
-  | Rstar_n : forall x y z:U, R x y -> Rstar y z -> Rstar x z.
+Inductive Rstar (x:U) : U -> Prop :=
+  | Rstar_0 : Rstar x x
+  | Rstar_n : forall y z:U, R x y -> Rstar y z -> Rstar x z.
 
-Inductive Rstar1 : Relation U :=
-  | Rstar1_0 : forall x:U, Rstar1 x x
-  | Rstar1_1 : forall x y:U, R x y -> Rstar1 x y
-  | Rstar1_n : forall x y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z.
+Inductive Rstar1 (x:U) : U -> Prop :=
+  | Rstar1_0 : Rstar1 x x
+  | Rstar1_1 : forall y:U, R x y -> Rstar1 x y
+  | Rstar1_n : forall y z:U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z.
 
-Inductive Rplus : Relation U :=
-  | Rplus_0 : forall x y:U, R x y -> Rplus x y
-  | Rplus_n : forall x y z:U, R x y -> Rplus y z -> Rplus x z.
+Inductive Rplus (x:U) : U -> Prop :=
+  | Rplus_0 : forall y:U, R x y -> Rplus x y
+  | Rplus_n : forall y z:U, R x y -> Rplus y z -> Rplus x z.
 
 Definition Strongly_confluent : Prop :=
   forall x a b:U, R x a -> R x b -> ex (fun z:U => R a z /\ R b z).
diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v
index 4c729fe7..3291f3ee 100755..100644
--- a/theories/Sets/Relations_2_facts.v
+++ b/theories/Sets/Relations_2_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_2_facts.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Relations_2_facts.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Require Export Relations_1.
 Require Export Relations_1_facts.
diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v
index 6a254819..b8c65148 100755..100644
--- a/theories/Sets/Relations_3.v
+++ b/theories/Sets/Relations_3.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_3.v,v 1.7.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Relations_3.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Require Export Relations_1.
 Require Export Relations_2.
@@ -46,9 +46,9 @@ Section Relations_3.
    
    Definition Confluent : Prop := forall x:U, confluent x.
    
-   Inductive noetherian : U -> Prop :=
+   Inductive noetherian (x: U) : Prop :=
        definition_of_noetherian :
-         forall x:U, (forall y:U, R x y -> noetherian y) -> noetherian x.
+         (forall y:U, R x y -> noetherian y) -> noetherian x.
    
    Definition Noetherian : Prop := forall x:U, noetherian x.
    
diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v
index 34322dc7..38ff9eae 100755..100644
--- a/theories/Sets/Relations_3_facts.v
+++ b/theories/Sets/Relations_3_facts.v
@@ -24,7 +24,7 @@
 (* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
 (****************************************************************************)
 
-(*i $Id: Relations_3_facts.v,v 1.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Relations_3_facts.v 8642 2006-03-17 10:09:02Z notin $ i*)
 
 Require Export Relations_1.
 Require Export Relations_1_facts.
diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v
index 10d26f22..42c96191 100644
--- a/theories/Sets/Uniset.v
+++ b/theories/Sets/Uniset.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Uniset.v,v 1.9.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+(*i $Id: Uniset.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (** Sets as characteristic functions *)
 
diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v
index 41594749..e1e026f5 100644
--- a/theories/Sorting/Heap.v
+++ b/theories/Sorting/Heap.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Heap.v,v 1.3.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Heap.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** A development of Treesort on Heap trees *)
 
@@ -21,207 +21,216 @@ Require Import Sorting.
 
 Section defs.
 
-Variable A : Set.
-Variable leA : relation A.
-Variable eqA : relation A.
+  (** * Trees and heap trees *)
 
-Let gtA (x y:A) := ~ leA x y.
+  (** ** Definition of trees over an ordered set *)
 
-Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
-Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
-Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
-Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
-Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
+  Variable A : Set.
+  Variable leA : relation A.
+  Variable eqA : relation A.
 
-Hint Resolve leA_refl.
-Hint Immediate eqA_dec leA_dec leA_antisym.
+  Let gtA (x y:A) := ~ leA x y.
+  
+  Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
+  Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+  Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
+  Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
+  Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
 
-Let emptyBag := EmptyBag A.
-Let singletonBag := SingletonBag _ eqA_dec.
+  Hint Resolve leA_refl.
+  Hint Immediate eqA_dec leA_dec leA_antisym.
 
-Inductive Tree : Set :=
-  | Tree_Leaf : Tree
-  | Tree_Node : A -> Tree -> Tree -> Tree.
+  Let emptyBag := EmptyBag A.
+  Let singletonBag := SingletonBag _ eqA_dec.
+  
+  Inductive Tree : Set :=
+    | Tree_Leaf : Tree
+    | Tree_Node : A -> Tree -> Tree -> Tree.
 
-(** [a] is lower than a Tree [T] if [T] is a Leaf
-    or [T] is a Node holding [b>a] *)
+  (** [a] is lower than a Tree [T] if [T] is a Leaf
+      or [T] is a Node holding [b>a] *)
 
-Definition leA_Tree (a:A) (t:Tree) :=
-  match t with
-  | Tree_Leaf => True
-  | Tree_Node b T1 T2 => leA a b
-  end.
+  Definition leA_Tree (a:A) (t:Tree) :=
+    match t with
+      | Tree_Leaf => True
+      | Tree_Node b T1 T2 => leA a b
+    end.
 
-Lemma leA_Tree_Leaf : forall a:A, leA_Tree a Tree_Leaf.
-Proof.
-simpl in |- *; auto with datatypes.
-Qed.
+  Lemma leA_Tree_Leaf : forall a:A, leA_Tree a Tree_Leaf.
+  Proof.
+    simpl in |- *; auto with datatypes.
+  Qed.
 
-Lemma leA_Tree_Node :
- forall (a b:A) (G D:Tree), leA a b -> leA_Tree a (Tree_Node b G D).
-Proof.
-simpl in |- *; auto with datatypes.
-Qed.
+  Lemma leA_Tree_Node :
+    forall (a b:A) (G D:Tree), leA a b -> leA_Tree a (Tree_Node b G D).
+  Proof.
+    simpl in |- *; auto with datatypes.
+  Qed.
 
-Hint Resolve leA_Tree_Leaf leA_Tree_Node.
 
+  (** ** The heap property *)
 
-(** The heap property *)
-
-Inductive is_heap : Tree -> Prop :=
-  | nil_is_heap : is_heap Tree_Leaf
-  | node_is_heap :
+  Inductive is_heap : Tree -> Prop :=
+    | nil_is_heap : is_heap Tree_Leaf
+    | node_is_heap :
       forall (a:A) (T1 T2:Tree),
         leA_Tree a T1 ->
         leA_Tree a T2 ->
         is_heap T1 -> is_heap T2 -> is_heap (Tree_Node a T1 T2).
 
-Hint Constructors is_heap.
-
-Lemma invert_heap :
- forall (a:A) (T1 T2:Tree),
-   is_heap (Tree_Node a T1 T2) ->
-   leA_Tree a T1 /\ leA_Tree a T2 /\ is_heap T1 /\ is_heap T2.
-Proof.
-intros; inversion H; auto with datatypes.
-Qed.
-
-(* This lemma ought to be generated automatically by the Inversion tools *)
-Lemma is_heap_rec :
- forall P:Tree -> Set,
-   P Tree_Leaf ->
-   (forall (a:A) (T1 T2:Tree),
-      leA_Tree a T1 ->
-      leA_Tree a T2 ->
-      is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) ->
-   forall T:Tree, is_heap T -> P T.
-Proof.
-simple induction T; auto with datatypes.
-intros a G PG D PD PN. 
-elim (invert_heap a G D); auto with datatypes.
-intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
-apply H0; auto with datatypes.
-Qed.
-
-Lemma low_trans :
- forall (T:Tree) (a b:A), leA a b -> leA_Tree b T -> leA_Tree a T.
-Proof.
-simple induction T; auto with datatypes.
-intros; simpl in |- *; apply leA_trans with b; auto with datatypes.
-Qed.
-
-(** contents of a tree as a multiset *)
-
-(** Nota Bene : In what follows the definition of SingletonBag
-    in not used. Actually, we could just take as postulate:
-    [Parameter SingletonBag : A->multiset].  *)
-
-Fixpoint contents (t:Tree) : multiset A :=
-  match t with
-  | Tree_Leaf => emptyBag
-  | Tree_Node a t1 t2 =>
-      munion (contents t1) (munion (contents t2) (singletonBag a))
-  end.
-
-
-(** equivalence of two trees is equality of corresponding multisets *)
-
-Definition equiv_Tree (t1 t2:Tree) := meq (contents t1) (contents t2).
-
-
-(** specification of heap insertion *)
-
-Inductive insert_spec (a:A) (T:Tree) : Set :=
+  Lemma invert_heap :
+    forall (a:A) (T1 T2:Tree),
+      is_heap (Tree_Node a T1 T2) ->
+      leA_Tree a T1 /\ leA_Tree a T2 /\ is_heap T1 /\ is_heap T2.
+  Proof.
+    intros; inversion H; auto with datatypes.
+  Qed.
+
+  (* This lemma ought to be generated automatically by the Inversion tools *)
+  Lemma is_heap_rec :
+    forall P:Tree -> Set,
+      P Tree_Leaf ->
+      (forall (a:A) (T1 T2:Tree),
+	leA_Tree a T1 ->
+	leA_Tree a T2 ->
+	is_heap T1 -> P T1 -> is_heap T2 -> P T2 -> P (Tree_Node a T1 T2)) ->
+      forall T:Tree, is_heap T -> P T.
+  Proof.
+    simple induction T; auto with datatypes.
+    intros a G PG D PD PN. 
+    elim (invert_heap a G D); auto with datatypes.
+    intros H1 H2; elim H2; intros H3 H4; elim H4; intros.
+    apply H0; auto with datatypes.
+  Qed.
+
+  Lemma low_trans :
+    forall (T:Tree) (a b:A), leA a b -> leA_Tree b T -> leA_Tree a T.
+  Proof.
+    simple induction T; auto with datatypes.
+    intros; simpl in |- *; apply leA_trans with b; auto with datatypes.
+  Qed.
+
+
+  (** ** From trees to multisets *)
+
+  (** contents of a tree as a multiset *)
+
+  (** Nota Bene : In what follows the definition of SingletonBag
+      in not used. Actually, we could just take as postulate:
+      [Parameter SingletonBag : A->multiset].  *)
+
+  Fixpoint contents (t:Tree) : multiset A :=
+    match t with
+      | Tree_Leaf => emptyBag
+      | Tree_Node a t1 t2 =>
+	munion (contents t1) (munion (contents t2) (singletonBag a))
+    end.
+
+
+  (** equivalence of two trees is equality of corresponding multisets *)
+  Definition equiv_Tree (t1 t2:Tree) := meq (contents t1) (contents t2).
+
+
+
+  (** * From lists to sorted lists *)
+
+  (** ** Specification of heap insertion *)
+
+  Inductive insert_spec (a:A) (T:Tree) : Set :=
     insert_exist :
-      forall T1:Tree,
-        is_heap T1 ->
-        meq (contents T1) (munion (contents T) (singletonBag a)) ->
-        (forall b:A, leA b a -> leA_Tree b T -> leA_Tree b T1) ->
-        insert_spec a T.
-
-
-Lemma insert : forall T:Tree, is_heap T -> forall a:A, insert_spec a T.
-Proof.
-simple induction 1; intros.
-apply insert_exist with (Tree_Node a Tree_Leaf Tree_Leaf);
- auto with datatypes.
-simpl in |- *; unfold meq, munion in |- *; auto with datatypes.
-elim (leA_dec a a0); intros.
-elim (H3 a0); intros.
-apply insert_exist with (Tree_Node a T2 T0); auto with datatypes.
-simpl in |- *; apply treesort_twist1; trivial with datatypes. 
-elim (H3 a); intros T3 HeapT3 ConT3 LeA.
-apply insert_exist with (Tree_Node a0 T2 T3); auto with datatypes.
-apply node_is_heap; auto with datatypes.
-apply low_trans with a; auto with datatypes.
-apply LeA; auto with datatypes.
-apply low_trans with a; auto with datatypes.
-simpl in |- *; apply treesort_twist2; trivial with datatypes. 
-Qed.
-
-(** building a heap from a list *)
-
-Inductive build_heap (l:list A) : Set :=
+    forall T1:Tree,
+      is_heap T1 ->
+      meq (contents T1) (munion (contents T) (singletonBag a)) ->
+      (forall b:A, leA b a -> leA_Tree b T -> leA_Tree b T1) ->
+      insert_spec a T.
+
+
+  Lemma insert : forall T:Tree, is_heap T -> forall a:A, insert_spec a T.
+  Proof.
+    simple induction 1; intros.
+    apply insert_exist with (Tree_Node a Tree_Leaf Tree_Leaf);
+      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
+    simpl in |- *; unfold meq, munion in |- *; auto using node_is_heap with datatypes.
+    elim (leA_dec a a0); intros.
+    elim (H3 a0); intros.
+    apply insert_exist with (Tree_Node a T2 T0);
+      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
+    simpl in |- *; apply treesort_twist1; trivial with datatypes. 
+    elim (H3 a); intros T3 HeapT3 ConT3 LeA.
+    apply insert_exist with (Tree_Node a0 T2 T3); 
+      auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
+    apply node_is_heap; auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
+    apply low_trans with a; auto with datatypes. 
+    apply LeA; auto with datatypes.
+    apply low_trans with a; auto with datatypes.
+    simpl in |- *; apply treesort_twist2; trivial with datatypes. 
+  Qed.
+
+
+  (** ** Building a heap from a list *)
+
+  Inductive build_heap (l:list A) : Set :=
     heap_exist :
-      forall T:Tree,
-        is_heap T ->
-        meq (list_contents _ eqA_dec l) (contents T) -> build_heap l.
-
-Lemma list_to_heap : forall l:list A, build_heap l.
-Proof.
-simple induction l.
-apply (heap_exist nil Tree_Leaf); auto with datatypes.
-simpl in |- *; unfold meq in |- *; auto with datatypes.
-simple induction 1.
-intros T i m; elim (insert T i a).
-intros; apply heap_exist with T1; simpl in |- *; auto with datatypes.
-apply meq_trans with (munion (contents T) (singletonBag a)).
-apply meq_trans with (munion (singletonBag a) (contents T)).
-apply meq_right; trivial with datatypes.
-apply munion_comm.
-apply meq_sym; trivial with datatypes.
-Qed.
-
-
-(** building the sorted list *)
-
-Inductive flat_spec (T:Tree) : Set :=
+    forall T:Tree,
+      is_heap T ->
+      meq (list_contents _ eqA_dec l) (contents T) -> build_heap l.
+  
+  Lemma list_to_heap : forall l:list A, build_heap l.
+  Proof.
+    simple induction l.
+    apply (heap_exist nil Tree_Leaf); auto with datatypes.
+    simpl in |- *; unfold meq in |- *; exact nil_is_heap.
+    simple induction 1.
+    intros T i m; elim (insert T i a).
+    intros; apply heap_exist with T1; simpl in |- *; auto with datatypes.
+    apply meq_trans with (munion (contents T) (singletonBag a)).
+    apply meq_trans with (munion (singletonBag a) (contents T)).
+    apply meq_right; trivial with datatypes.
+    apply munion_comm.
+    apply meq_sym; trivial with datatypes.
+  Qed.
+
+
+  (** ** Building the sorted list *)
+  
+  Inductive flat_spec (T:Tree) : Set :=
     flat_exist :
-      forall l:list A,
-        sort leA l ->
-        (forall a:A, leA_Tree a T -> lelistA leA a l) ->
-        meq (contents T) (list_contents _ eqA_dec l) -> flat_spec T.
-
-Lemma heap_to_list : forall T:Tree, is_heap T -> flat_spec T.
-Proof.
-  intros T h; elim h; intros.
-  apply flat_exist with (nil (A:=A)); auto with datatypes.
-  elim H2; intros l1 s1 i1 m1; elim H4; intros l2 s2 i2 m2.
-  elim (merge _ leA_dec eqA_dec s1 s2); intros.
-  apply flat_exist with (a :: l); simpl in |- *; auto with datatypes.
-  apply meq_trans with
-   (munion (list_contents _ eqA_dec l1)
-      (munion (list_contents _ eqA_dec l2) (singletonBag a))).
-  apply meq_congr; auto with datatypes.
-  apply meq_trans with
-   (munion (singletonBag a)
-      (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2))).
-  apply munion_rotate.
-  apply meq_right; apply meq_sym; trivial with datatypes.
-Qed.
-
-(** specification of treesort *)
-
-Theorem treesort :
- forall l:list A, {m : list A | sort leA m &  permutation _ eqA_dec l m}.
-Proof.
-  intro l; unfold permutation in |- *.
-  elim (list_to_heap l).
-  intros.
-  elim (heap_to_list T); auto with datatypes.
-  intros.
-  exists l0; auto with datatypes.
-  apply meq_trans with (contents T); trivial with datatypes.
-Qed.
+    forall l:list A,
+      sort leA l ->
+      (forall a:A, leA_Tree a T -> lelistA leA a l) ->
+      meq (contents T) (list_contents _ eqA_dec l) -> flat_spec T.
+
+  Lemma heap_to_list : forall T:Tree, is_heap T -> flat_spec T.
+  Proof.
+    intros T h; elim h; intros.
+    apply flat_exist with (nil (A:=A)); auto with datatypes.
+    elim H2; intros l1 s1 i1 m1; elim H4; intros l2 s2 i2 m2.
+    elim (merge _ leA_dec eqA_dec s1 s2); intros.
+    apply flat_exist with (a :: l); simpl in |- *; auto with datatypes.
+    apply meq_trans with
+      (munion (list_contents _ eqA_dec l1)
+	(munion (list_contents _ eqA_dec l2) (singletonBag a))).
+    apply meq_congr; auto with datatypes.
+    apply meq_trans with
+      (munion (singletonBag a)
+	(munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2))).
+    apply munion_rotate.
+    apply meq_right; apply meq_sym; trivial with datatypes.
+  Qed.
+
+
+  (** * Specification of treesort *)
+
+  Theorem treesort :
+    forall l:list A, {m : list A | sort leA m &  permutation _ eqA_dec l m}.
+  Proof.
+    intro l; unfold permutation in |- *.
+    elim (list_to_heap l).
+    intros.
+    elim (heap_to_list T); auto with datatypes.
+    intros.
+    exists l0; auto with datatypes.
+    apply meq_trans with (contents T); trivial with datatypes.
+  Qed.
 
 End defs.
\ No newline at end of file
diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v
new file mode 100644
index 00000000..f4986198
--- /dev/null
+++ b/theories/Sorting/PermutEq.v
@@ -0,0 +1,241 @@
+(************************************************************************)
+(*  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: PermutEq.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+Require Import Omega.
+Require Import Relations.
+Require Import Setoid.
+Require Import List.
+Require Import Multiset.
+Require Import Permutation. 
+
+Set Implicit Arguments.
+
+(** This file is similar to [PermutSetoid], except that the equality used here
+    is Coq usual one instead of a setoid equality. In particular, we can then 
+    prove the equivalence between [List.Permutation] and 
+    [Permutation.permutation].
+*)
+
+Section Perm.
+  
+  Variable A : Set.
+  Hypothesis eq_dec : forall x y:A, {x=y} + {~ x=y}.
+  
+  Notation permutation := (permutation _ eq_dec).
+  Notation list_contents := (list_contents _ eq_dec).
+
+  (** we can use [multiplicity] to define [In] and [NoDup]. *)
+
+  Lemma multiplicity_In : 
+    forall l a, In a l <-> 0 < multiplicity (list_contents l) a.
+  Proof.
+    induction l.
+    simpl.
+    split; inversion 1.
+    simpl.
+    split; intros.
+    inversion_clear H.
+    subst a0.
+    destruct (eq_dec a a) as [_|H]; auto with arith; destruct H; auto.
+    destruct (eq_dec a a0) as [H1|H1]; auto with arith; simpl.
+    rewrite <- IHl; auto.
+    destruct (eq_dec a a0); auto.
+    simpl in H.
+    right; rewrite IHl; auto.
+  Qed.
+
+  Lemma multiplicity_In_O :
+    forall l a, ~ In a l -> multiplicity (list_contents l) a = 0.
+  Proof.
+    intros l a; rewrite multiplicity_In; 
+      destruct (multiplicity (list_contents l) a); auto.
+    destruct 1; auto with arith.
+  Qed.
+  
+  Lemma multiplicity_In_S :
+    forall l a, In a l -> multiplicity (list_contents l) a >= 1.
+  Proof.
+    intros l a; rewrite multiplicity_In; auto.
+  Qed.
+
+  Lemma multiplicity_NoDup : 
+    forall l, NoDup l <-> (forall a, multiplicity (list_contents l) a <= 1).
+  Proof.
+    induction l.
+    simpl.
+    split; auto with arith.
+    intros; apply NoDup_nil.
+    split; simpl.
+    inversion_clear 1.
+    rewrite IHl in H1.
+    intros; destruct (eq_dec a a0) as [H2|H2]; simpl; auto.
+    subst a0.
+    rewrite multiplicity_In_O; auto.
+    intros; constructor.
+    rewrite multiplicity_In.
+    generalize (H a).
+    destruct (eq_dec a a) as [H0|H0].
+    destruct (multiplicity (list_contents l) a); auto with arith.
+    simpl; inversion 1. 
+    inversion H3.
+    destruct H0; auto.
+    rewrite IHl; intros.
+    generalize (H a0); auto with arith.
+    destruct (eq_dec a a0); simpl; auto with arith.
+  Qed.
+
+  Lemma NoDup_permut : 
+    forall l l', NoDup l -> NoDup l' -> 
+      (forall x, In x l <-> In x l') -> permutation l l'.
+  Proof.
+    intros.
+    red; unfold meq; intros.
+    rewrite multiplicity_NoDup in H, H0. 
+    generalize (H a) (H0 a) (H1 a); clear H H0 H1.
+    do 2 rewrite multiplicity_In.
+    destruct 3; omega.
+  Qed.
+
+  (** Permutation is compatible with In. *)
+  Lemma permut_In_In :
+    forall l1 l2 e, permutation l1 l2 -> In e l1 -> In e l2.
+  Proof.
+    unfold Permutation.permutation, meq; intros l1 l2 e P IN.
+    generalize (P e); clear P.
+    destruct (In_dec eq_dec e l2) as [H|H]; auto.
+    rewrite (multiplicity_In_O _ _ H).
+    intros.
+    generalize (multiplicity_In_S _ _ IN).
+    rewrite H0.
+    inversion 1.
+  Qed.
+
+  Lemma permut_cons_In :
+    forall l1 l2 e, permutation (e :: l1) l2 -> In e l2.
+  Proof.
+    intros; eapply permut_In_In; eauto.
+    red; auto.
+  Qed.
+
+  (** Permutation of an empty list. *)
+  Lemma permut_nil :
+    forall l, permutation l nil -> l = nil.
+  Proof.
+    intro l; destruct l as [ | e l ]; trivial.
+    assert (In e (e::l)) by (red; auto).
+    intro Abs; generalize (permut_In_In _ Abs H).
+    inversion 1.
+  Qed.
+  
+  (** When used with [eq], this permutation notion is equivalent to 
+      the one defined in [List.v]. *)
+
+  Lemma permutation_Permutation : 
+    forall l l', Permutation l l' <-> permutation l l'.
+  Proof.
+    split.
+    induction 1.
+    apply permut_refl.
+    apply permut_cons; auto.
+    change (permutation (y::x::l) ((x::nil)++y::l)).
+    apply permut_add_cons_inside; simpl; apply permut_refl.
+    apply permut_tran with l'; auto.
+    revert l'.
+    induction l.
+    intros.
+    rewrite (permut_nil (permut_sym H)).
+    apply Permutation_refl.
+    intros.
+    destruct (In_split _ _ (permut_cons_In H)) as (h2,(t2,H1)).
+    subst l'.
+    apply Permutation_cons_app.
+    apply IHl.
+    apply permut_remove_hd with a; auto.
+  Qed.
+
+  (** Permutation for short lists. *)
+
+  Lemma permut_length_1:
+    forall a b, permutation (a :: nil) (b :: nil)  -> a=b.
+  Proof.
+    intros a b; unfold Permutation.permutation, meq; intro P;
+      generalize (P b); clear P; simpl.
+    destruct (eq_dec b b) as [H|H]; [ | destruct H; auto].
+    destruct (eq_dec a b); simpl; auto; intros; discriminate.
+  Qed.
+  
+  Lemma permut_length_2 :
+    forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
+      (a1=a2) /\ (b1=b2) \/ (a1=b2) /\ (a2=b1).
+  Proof.
+    intros a1 b1 a2 b2 P.
+    assert (H:=permut_cons_In P).
+    inversion_clear H.
+    left; split; auto.
+    apply permut_length_1.
+    red; red; intros.
+    generalize (P a); clear P; simpl.
+    destruct (eq_dec a1 a) as [H2|H2]; 
+      destruct (eq_dec a2 a) as [H3|H3]; auto.
+    destruct H3; transitivity a1; auto.
+    destruct H2; transitivity a2; auto.
+    right.
+    inversion_clear H0; [|inversion H].
+    split; auto.
+    apply permut_length_1.
+    red; red; intros.
+    generalize (P a); clear P; simpl.
+    destruct (eq_dec a1 a) as [H2|H2]; 
+      destruct (eq_dec b2 a) as [H3|H3]; auto.
+    simpl; rewrite <- plus_n_Sm; inversion 1; auto.
+    destruct H3; transitivity a1; auto.
+    destruct H2; transitivity b2; auto.
+  Qed.
+
+  (** Permutation is compatible with length. *)
+  Lemma permut_length :
+    forall l1 l2, permutation l1 l2 -> length l1 = length l2.
+  Proof.
+    induction l1; intros l2 H.
+    rewrite (permut_nil (permut_sym H)); auto.
+    destruct (In_split _ _ (permut_cons_In H)) as (h2,(t2,H1)).
+    subst l2.
+    rewrite app_length.
+    simpl; rewrite <- plus_n_Sm; f_equal.
+    rewrite <- app_length.
+    apply IHl1.
+    apply permut_remove_hd with a; auto.
+  Qed.
+
+  Variable B : Set.
+  Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. 
+
+  (** Permutation is compatible with map. *)
+
+  Lemma permutation_map :
+    forall f l1 l2, permutation l1 l2 -> 
+      Permutation.permutation _ eqB_dec (map f l1) (map f l2).
+  Proof.
+    intros f; induction l1.
+    intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl.
+    intros l2 P.
+    simpl.
+    destruct (In_split _ _ (permut_cons_In P)) as (h2,(t2,H1)).
+    subst l2.
+    rewrite map_app.
+    simpl.
+    apply permut_add_cons_inside.
+    rewrite <- map_app.
+    apply IHl1; auto.
+    apply permut_remove_hd with a; auto.
+  Qed.
+
+End Perm.
+
diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v
new file mode 100644
index 00000000..65369a01
--- /dev/null
+++ b/theories/Sorting/PermutSetoid.v
@@ -0,0 +1,243 @@
+(************************************************************************)
+(*  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: PermutSetoid.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+Require Import Omega.
+Require Import Relations.
+Require Import List.
+Require Import Multiset.
+Require Import Permutation. 
+Require Import SetoidList.
+
+Set Implicit Arguments.
+
+(** This file contains additional results about permutations 
+     with respect to an setoid equality (i.e. an equivalence relation). 
+*)
+
+Section Perm.
+
+Variable A : Set.
+Variable eqA : relation A.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+
+Notation permutation := (permutation _ eqA_dec).
+Notation list_contents := (list_contents _ eqA_dec).
+
+(** The following lemmas need some knowledge on [eqA] *)
+
+Variable eqA_refl : forall x, eqA x x.
+Variable eqA_sym : forall x y, eqA x y -> eqA y x.
+Variable eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z.
+
+(** we can use [multiplicity] to define [InA] and [NoDupA]. *)
+
+Lemma multiplicity_InA : 
+  forall l a, InA eqA a l <-> 0 < multiplicity (list_contents l) a.
+Proof.
+  induction l.
+  simpl.
+  split; inversion 1.
+  simpl.
+  split; intros.
+  inversion_clear H.
+  destruct (eqA_dec a a0) as [_|H1]; auto with arith.
+  destruct H1; auto.
+  destruct (eqA_dec a a0); auto with arith.
+  simpl; rewrite <- IHl; auto.
+  destruct (eqA_dec a a0) as [H0|H0]; auto.
+  simpl in H.
+  constructor 2; rewrite IHl; auto.
+Qed.
+
+Lemma multiplicity_InA_O :
+  forall l a, ~ InA eqA a l -> multiplicity (list_contents l) a = 0.
+Proof.
+  intros l a; rewrite multiplicity_InA; 
+    destruct (multiplicity (list_contents l) a); auto with arith.
+  destruct 1; auto with arith.
+Qed.
+
+Lemma multiplicity_InA_S :
+  forall l a, InA eqA a l -> multiplicity (list_contents l) a >= 1.
+Proof.
+  intros l a; rewrite multiplicity_InA; auto with arith.
+Qed.
+
+Lemma multiplicity_NoDupA : forall l, 
+  NoDupA eqA l <-> (forall a, multiplicity (list_contents l) a <= 1).
+Proof.
+  induction l.
+  simpl.
+  split; auto with arith.
+  split; simpl.
+  inversion_clear 1.
+  rewrite IHl in H1.
+  intros; destruct (eqA_dec a a0) as [H2|H2]; simpl; auto.
+  rewrite multiplicity_InA_O; auto.
+  swap H0.
+  apply InA_eqA with a0; auto.
+  intros; constructor.
+  rewrite multiplicity_InA.
+  generalize (H a).
+  destruct (eqA_dec a a) as [H0|H0].
+  destruct (multiplicity (list_contents l) a); auto with arith.
+  simpl; inversion 1. 
+  inversion H3.
+  destruct H0; auto.
+  rewrite IHl; intros.
+  generalize (H a0); auto with arith.
+  destruct (eqA_dec a a0); simpl; auto with arith.
+Qed.
+
+
+(** Permutation is compatible with InA. *)
+Lemma permut_InA_InA :
+  forall l1 l2 e, permutation l1 l2 -> InA eqA e l1 -> InA eqA e l2.
+Proof.
+  intros l1 l2 e.
+  do 2 rewrite multiplicity_InA.
+  unfold Permutation.permutation, meq.
+  intros H;rewrite H; auto.
+Qed.
+
+Lemma permut_cons_InA :
+  forall l1 l2 e, permutation (e :: l1) l2 -> InA eqA e l2.
+Proof.
+  intros; apply (permut_InA_InA (e:=e) H); auto.
+Qed.
+
+(** Permutation of an empty list. *)
+Lemma permut_nil :
+  forall l, permutation l nil -> l = nil.
+Proof.
+  intro l; destruct l as [ | e l ]; trivial.
+  assert (InA eqA e (e::l)) by auto.
+  intro Abs; generalize (permut_InA_InA Abs H).
+  inversion 1.
+Qed.
+
+(** Permutation for short lists. *)
+
+Lemma permut_length_1:
+  forall a b, permutation (a :: nil) (b :: nil)  -> eqA a b.
+Proof.
+  intros a b; unfold Permutation.permutation, meq; intro P;
+  generalize (P b); clear P; simpl.
+  destruct (eqA_dec b b) as [H|H]; [ | destruct H; auto].
+  destruct (eqA_dec a b); simpl; auto; intros; discriminate.
+Qed.
+
+Lemma permut_length_2 :
+  forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
+    (eqA a1 a2) /\ (eqA b1 b2) \/ (eqA a1 b2) /\ (eqA a2 b1).
+Proof.
+  intros a1 b1 a2 b2 P.
+  assert (H:=permut_cons_InA P).
+  inversion_clear H.
+  left; split; auto.
+  apply permut_length_1.
+  red; red; intros.
+  generalize (P a); clear P; simpl.
+  destruct (eqA_dec a1 a) as [H2|H2]; 
+    destruct (eqA_dec a2 a) as [H3|H3]; auto.
+  destruct H3; apply eqA_trans with a1; auto.
+  destruct H2; apply eqA_trans with a2; auto.
+  right.
+  inversion_clear H0; [|inversion H].
+  split; auto.
+  apply permut_length_1.
+  red; red; intros.
+  generalize (P a); clear P; simpl.
+  destruct (eqA_dec a1 a) as [H2|H2]; 
+    destruct (eqA_dec b2 a) as [H3|H3]; auto.
+  simpl; rewrite <- plus_n_Sm; inversion 1; auto.
+  destruct H3; apply eqA_trans with a1; auto.
+  destruct H2; apply eqA_trans with b2; auto.
+Qed.
+
+(** Permutation is compatible with length. *)
+Lemma permut_length :
+  forall l1 l2, permutation l1 l2 -> length l1 = length l2.
+Proof.
+  induction l1; intros l2 H.
+  rewrite (permut_nil (permut_sym H)); auto.
+  assert (H0:=permut_cons_InA H).
+  destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))).
+  subst l2.
+  rewrite app_length.
+  simpl; rewrite <- plus_n_Sm; f_equal.
+  rewrite <- app_length.
+  apply IHl1.
+  apply permut_remove_hd with b.
+  apply permut_tran with (a::l1); auto.
+  revert H1; unfold Permutation.permutation, meq; simpl.
+  intros; f_equal; auto.
+  destruct (eqA_dec b a0) as [H2|H2]; 
+    destruct (eqA_dec a a0) as [H3|H3]; auto.
+  destruct H3; apply eqA_trans with b; auto.
+  destruct H2; apply eqA_trans with a; auto.
+Qed.
+
+Lemma NoDupA_eqlistA_permut : 
+  forall l l', NoDupA eqA l -> NoDupA eqA l' -> 
+    eqlistA eqA l l' -> permutation l l'.
+Proof.
+  intros.
+  red; unfold meq; intros.
+  rewrite multiplicity_NoDupA in H, H0. 
+  generalize (H a) (H0 a) (H1 a); clear H H0 H1.
+  do 2 rewrite multiplicity_InA.
+  destruct 3; omega.
+Qed.
+
+
+Variable B : Set.
+Variable eqB : B->B->Prop.
+Variable eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. 
+Variable eqB_trans : forall x y z, eqB x y -> eqB y z -> eqB x z.
+
+(** Permutation is compatible with map. *)
+
+Lemma permut_map :
+  forall f, 
+    (forall x y, eqA x y -> eqB (f x) (f y)) ->
+    forall l1 l2, permutation l1 l2 -> 
+      Permutation.permutation _ eqB_dec (map f l1) (map f l2).
+Proof.
+  intros f; induction l1.
+  intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl.
+  intros l2 P.
+  simpl.
+  assert (H0:=permut_cons_InA P).
+  destruct (InA_split H0) as (h2,(b,(t2,(H1,H2)))).
+  subst l2.
+  rewrite map_app.
+  simpl.
+  apply permut_tran with (f b :: map f l1).
+  revert H1; unfold Permutation.permutation, meq; simpl.
+  intros; f_equal; auto.
+  destruct (eqB_dec (f b) a0) as [H2|H2]; 
+    destruct (eqB_dec (f a) a0) as [H3|H3]; auto.
+  destruct H3; apply eqB_trans with (f b); auto.
+  destruct H2; apply eqB_trans with (f a); auto.
+  apply permut_add_cons_inside.
+  rewrite <- map_app.
+  apply IHl1; auto.
+  apply permut_remove_hd with b.
+  apply permut_tran with (a::l1); auto.
+  revert H1; unfold Permutation.permutation, meq; simpl.
+  intros; f_equal; auto.
+  destruct (eqA_dec b a0) as [H2|H2]; 
+    destruct (eqA_dec a a0) as [H3|H3]; auto.
+  destruct H3; apply eqA_trans with b; auto.
+  destruct H2; apply eqA_trans with a; auto.
+Qed.
+
+End Perm.
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
index 43a0f0bc..3ff026c2 100644
--- a/theories/Sorting/Permutation.v
+++ b/theories/Sorting/Permutation.v
@@ -6,115 +6,202 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Permutation.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Permutation.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Relations.
 Require Import List.
 Require Import Multiset.
+Require Import Arith.
+
+(** This file define a notion of permutation for lists, based on multisets: 
+    there exists a permutation between two lists iff every elements have 
+    the same multiplicities in the two lists. 
+
+    Unlike [List.Permutation], the present notion of permutation requires
+    a decidable equality. At the same time, this definition can be used 
+    with a non-standard equality, whereas [List.Permutation] cannot.
+      
+    The present file contains basic results, obtained without any particular
+    assumption on the decidable equality used.
+	
+    File [PermutSetoid] contains additional results about permutations 
+    with respect to an setoid equality (i.e. an equivalence relation). 
+
+    Finally, file [PermutEq] concerns Coq equality : this file is similar 
+    to the previous one, but proves in addition that [List.Permutation]
+    and [permutation] are equivalent in this context.
+x*)
 
 Set Implicit Arguments.
 
 Section defs.
 
-Variable A : Set.
-Variable leA : relation A.
-Variable eqA : relation A.
-
-Let gtA (x y:A) := ~ leA x y.
-
-Hypothesis leA_dec : forall x y:A, {leA x y} + {~ leA x y}.
-Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
-Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
-Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
-Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
-
-Hint Resolve leA_refl: default.
-Hint Immediate eqA_dec leA_dec leA_antisym: default.
-
-Let emptyBag := EmptyBag A.
-Let singletonBag := SingletonBag _ eqA_dec.
-
-(** contents of a list *)
-
-Fixpoint list_contents (l:list A) : multiset A :=
-  match l with
-  | nil => emptyBag
-  | a :: l => munion (singletonBag a) (list_contents l)
-  end.
-
-Lemma list_contents_app :
- forall l m:list A,
-   meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)).
-Proof.
-simple induction l; simpl in |- *; auto with datatypes.
-intros.
-apply meq_trans with
- (munion (singletonBag a) (munion (list_contents l0) (list_contents m)));
- auto with datatypes.
-Qed.
-Hint Resolve list_contents_app.
-
-Definition permutation (l m:list A) :=
-  meq (list_contents l) (list_contents m).
-
-Lemma permut_refl : forall l:list A, permutation l l.
-Proof.
-unfold permutation in |- *; auto with datatypes.
-Qed.
-Hint Resolve permut_refl.
-
-Lemma permut_tran :
- forall l m n:list A, permutation l m -> permutation m n -> permutation l n.
-Proof.
-unfold permutation in |- *; intros.
-apply meq_trans with (list_contents m); auto with datatypes.
-Qed.
-
-Lemma permut_right :
- forall l m:list A,
-   permutation l m -> forall a:A, permutation (a :: l) (a :: m).
-Proof.
-unfold permutation in |- *; simpl in |- *; auto with datatypes.
-Qed.
-Hint Resolve permut_right.
-
-Lemma permut_app :
- forall l l' m m':list A,
-   permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m').
-Proof.
-unfold permutation in |- *; intros.
-apply meq_trans with (munion (list_contents l) (list_contents m));
- auto with datatypes.
-apply meq_trans with (munion (list_contents l') (list_contents m'));
- auto with datatypes.
-apply meq_trans with (munion (list_contents l') (list_contents m));
- auto with datatypes.
-Qed.
-Hint Resolve permut_app.
-
-Lemma permut_cons :
- forall l m:list A,
-   permutation l m -> forall a:A, permutation (a :: l) (a :: m).
-Proof.
-intros l m H a.
-change (permutation ((a :: nil) ++ l) ((a :: nil) ++ m)) in |- *.
-apply permut_app; auto with datatypes.
-Qed.
-Hint Resolve permut_cons.
-
-Lemma permut_middle :
- forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m).
-Proof.
-unfold permutation in |- *.
-simple induction l; simpl in |- *; auto with datatypes.
-intros.
-apply meq_trans with
- (munion (singletonBag a)
-    (munion (singletonBag a0) (list_contents (l0 ++ m))));
- auto with datatypes.
-apply munion_perm_left; auto with datatypes.
-Qed.
-Hint Resolve permut_middle.
+  (** * From lists to multisets *)
+
+  Variable A : Set.
+  Variable eqA : relation A.
+  Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+
+  Let emptyBag := EmptyBag A.
+  Let singletonBag := SingletonBag _ eqA_dec.
+
+  (** contents of a list *)
+
+  Fixpoint list_contents (l:list A) : multiset A :=
+    match l with
+      | nil => emptyBag
+      | a :: l => munion (singletonBag a) (list_contents l)
+    end.
+
+  Lemma list_contents_app :
+    forall l m:list A,
+      meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)).
+  Proof.
+    simple induction l; simpl in |- *; auto with datatypes.
+    intros.
+    apply meq_trans with
+      (munion (singletonBag a) (munion (list_contents l0) (list_contents m)));
+      auto with datatypes.
+  Qed.
+
+  
+  (** * [permutation]: definition and basic properties *)
+  
+  Definition permutation (l m:list A) :=
+    meq (list_contents l) (list_contents m).
+
+  Lemma permut_refl : forall l:list A, permutation l l.
+  Proof.
+    unfold permutation in |- *; auto with datatypes.
+  Qed.
+  
+  Lemma permut_sym :
+    forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1.
+  Proof.
+    unfold permutation, meq; intros; apply sym_eq; trivial.
+  Qed.
+  
+  Lemma permut_tran :
+    forall l m n:list A, permutation l m -> permutation m n -> permutation l n.
+  Proof.
+    unfold permutation in |- *; intros.
+    apply meq_trans with (list_contents m); auto with datatypes.
+  Qed.
+  
+  Lemma permut_cons :
+    forall l m:list A,
+      permutation l m -> forall a:A, permutation (a :: l) (a :: m).
+  Proof.
+    unfold permutation in |- *; simpl in |- *; auto with datatypes.
+  Qed.
+  
+  Lemma permut_app :
+    forall l l' m m':list A,
+      permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m').
+  Proof.
+    unfold permutation in |- *; intros.
+    apply meq_trans with (munion (list_contents l) (list_contents m)); 
+      auto using permut_cons, list_contents_app with datatypes.
+    apply meq_trans with (munion (list_contents l') (list_contents m')); 
+      auto using permut_cons, list_contents_app with datatypes.
+    apply meq_trans with (munion (list_contents l') (list_contents m));
+      auto using permut_cons, list_contents_app with datatypes.
+  Qed.
+
+  Lemma permut_add_inside :
+    forall a l1 l2 l3 l4, 
+      permutation (l1 ++ l2) (l3 ++ l4) ->
+      permutation (l1 ++ a :: l2) (l3 ++ a :: l4).
+  Proof.
+    unfold permutation, meq in *; intros.
+    generalize (H a0); clear H.
+    do 4 rewrite list_contents_app.
+    simpl.
+    destruct (eqA_dec a a0); simpl; auto with arith.
+    do 2 rewrite <- plus_n_Sm; f_equal; auto.
+  Qed.
+  
+  Lemma permut_add_cons_inside :
+    forall a l l1 l2, 
+      permutation l (l1 ++ l2) ->
+      permutation (a :: l) (l1 ++ a :: l2).
+  Proof.
+    intros;
+      replace (a :: l) with (nil ++ a :: l); trivial;
+	apply permut_add_inside; trivial.
+  Qed.
+
+  Lemma permut_middle :
+    forall (l m:list A) (a:A), permutation (a :: l ++ m) (l ++ a :: m).
+  Proof.
+    intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl.
+  Qed.
+  
+  Lemma permut_sym_app :
+    forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1).
+  Proof.
+    intros l1 l2;
+      unfold permutation, meq; 
+	intro a; do 2 rewrite list_contents_app; simpl; 
+	  auto with arith.
+  Qed.
+
+  Lemma permut_rev : 
+    forall l, permutation l (rev l).
+  Proof.
+    induction l.
+    simpl; trivial using permut_refl.
+    simpl.
+    apply permut_add_cons_inside.
+    rewrite <- app_nil_end. trivial.
+  Qed.
+
+  (** * Some inversion results. *)
+  Lemma permut_conv_inv :
+    forall e l1 l2, permutation (e :: l1) (e :: l2) -> permutation l1 l2.
+  Proof.
+    intros e l1 l2; unfold permutation, meq; simpl; intros H a;
+      generalize (H a); apply plus_reg_l.
+  Qed.
+
+  Lemma permut_app_inv1 : 
+    forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2.
+  Proof.
+    intros l l1 l2; unfold permutation, meq; simpl;
+      intros H a; generalize (H a); clear H.
+    do 2 rewrite list_contents_app.
+    simpl.
+    intros; apply plus_reg_l with (multiplicity (list_contents l) a).
+    rewrite plus_comm; rewrite H; rewrite plus_comm.
+    trivial.
+  Qed.
+
+  Lemma permut_app_inv2 : 
+    forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2.
+  Proof.
+    intros l l1 l2; unfold permutation, meq; simpl;
+      intros H a; generalize (H a); clear H.
+    do 2 rewrite list_contents_app.
+    simpl.
+    intros; apply plus_reg_l with (multiplicity (list_contents l) a).
+    trivial.
+  Qed.
+
+  Lemma permut_remove_hd :
+    forall l l1 l2 a,   
+      permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2).
+  Proof.
+    intros l l1 l2 a; unfold permutation, meq; simpl; intros H a0; generalize (H a0); clear H.
+    do 2 rewrite list_contents_app; simpl; intro H.
+    apply plus_reg_l with (if eqA_dec a a0 then 1 else 0).
+    rewrite H; clear H.
+    symmetry; rewrite plus_comm.
+    repeat rewrite <- plus_assoc; f_equal.
+    apply plus_comm.
+  Qed.
 
 End defs.
+
+(** For compatibilty *) 
+Notation permut_right := permut_cons.
 Unset Implicit Arguments.
diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v
index aa829fea..f895d79e 100644
--- a/theories/Sorting/Sorting.v
+++ b/theories/Sorting/Sorting.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Sorting.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Sorting.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import List.
 Require Import Multiset.
@@ -17,107 +17,107 @@ Set Implicit Arguments.
 
 Section defs.
 
-Variable A : Set.
-Variable leA : relation A.
-Variable eqA : relation A.
+  Variable A : Set.
+  Variable leA : relation A.
+  Variable eqA : relation A.
 
-Let gtA (x y:A) := ~ leA x y.
+  Let gtA (x y:A) := ~ leA x y.
+  
+  Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
+  Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+  Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
+  Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
+  Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
 
-Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}.
-Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
-Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y.
-Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z.
-Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y.
+  Hint Resolve leA_refl.
+  Hint Immediate eqA_dec leA_dec leA_antisym.
 
-Hint Resolve leA_refl.
-Hint Immediate eqA_dec leA_dec leA_antisym.
+  Let emptyBag := EmptyBag A.
+  Let singletonBag := SingletonBag _ eqA_dec.
 
-Let emptyBag := EmptyBag A.
-Let singletonBag := SingletonBag _ eqA_dec.
+  (** [lelistA] *)
 
-(** [lelistA] *)
+  Inductive lelistA (a:A) : list A -> Prop :=
+    | nil_leA : lelistA a nil
+    | cons_leA : forall (b:A) (l:list A), leA a b -> lelistA a (b :: l).
 
-Inductive lelistA (a:A) : list A -> Prop :=
-  | nil_leA : lelistA a nil
-  | cons_leA : forall (b:A) (l:list A), leA a b -> lelistA a (b :: l).
-Hint Constructors lelistA.
+  Lemma lelistA_inv : forall (a b:A) (l:list A), lelistA a (b :: l) -> leA a b.
+  Proof.
+    intros; inversion H; trivial with datatypes.
+  Qed.
 
-Lemma lelistA_inv : forall (a b:A) (l:list A), lelistA a (b :: l) -> leA a b.
-Proof.
-  intros; inversion H; trivial with datatypes.
-Qed.
+  (** * Definition for a list to be sorted *)
 
-(** definition for a list to be sorted *)
-
-Inductive sort : list A -> Prop :=
-  | nil_sort : sort nil
-  | cons_sort :
+  Inductive sort : list A -> Prop :=
+    | nil_sort : sort nil
+    | cons_sort :
       forall (a:A) (l:list A), sort l -> lelistA a l -> sort (a :: l).
-Hint Constructors sort.
-
-Lemma sort_inv :
- forall (a:A) (l:list A), sort (a :: l) -> sort l /\ lelistA a l.
-Proof.
-intros; inversion H; auto with datatypes.
-Qed.
-
-Lemma sort_rec :
- forall P:list A -> Set,
-   P nil ->
-   (forall (a:A) (l:list A), sort l -> P l -> lelistA a l -> P (a :: l)) ->
-   forall y:list A, sort y -> P y.
-Proof.
-simple induction y; auto with datatypes.
-intros; elim (sort_inv (a:=a) (l:=l)); auto with datatypes.
-Qed.
-
-(** merging two sorted lists *)
-
-Inductive merge_lem (l1 l2:list A) : Set :=
+
+  Lemma sort_inv :
+    forall (a:A) (l:list A), sort (a :: l) -> sort l /\ lelistA a l.
+  Proof.
+    intros; inversion H; auto with datatypes.
+  Qed.
+
+  Lemma sort_rec :
+    forall P:list A -> Set,
+      P nil ->
+      (forall (a:A) (l:list A), sort l -> P l -> lelistA a l -> P (a :: l)) ->
+      forall y:list A, sort y -> P y.
+  Proof.
+    simple induction y; auto with datatypes.
+    intros; elim (sort_inv (a:=a) (l:=l)); auto with datatypes.
+  Qed.
+
+  (** * Merging two sorted lists *)
+
+  Inductive merge_lem (l1 l2:list A) : Set :=
     merge_exist :
-      forall l:list A,
-        sort l ->
-        meq (list_contents _ eqA_dec l)
-          (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
-        (forall a:A, lelistA a l1 -> lelistA a l2 -> lelistA a l) ->
-        merge_lem l1 l2.
-
-Lemma merge :
- forall l1:list A, sort l1 -> forall l2:list A, sort l2 -> merge_lem l1 l2.
-Proof.
-  simple induction 1; intros.
-  apply merge_exist with l2; auto with datatypes.
-  elim H3; intros.
-  apply merge_exist with (a :: l); simpl in |- *; auto with datatypes.
-  elim (leA_dec a a0); intros.
-
-(* 1 (leA a a0) *)
-  cut (merge_lem l (a0 :: l0)); auto with datatypes.
-  intros [l3 l3sorted l3contents Hrec].
-  apply merge_exist with (a :: l3); simpl in |- *; auto with datatypes.
-  apply meq_trans with
-   (munion (singletonBag a)
-      (munion (list_contents _ eqA_dec l)
-         (list_contents _ eqA_dec (a0 :: l0)))).
-  apply meq_right; trivial with datatypes.
-  apply meq_sym; apply munion_ass.
-  intros; apply cons_leA.
-  apply lelistA_inv with l; trivial with datatypes.
-
-(* 2 (leA a0 a) *)
-  elim H5; simpl in |- *; intros.
-  apply merge_exist with (a0 :: l3); simpl in |- *; auto with datatypes.
-  apply meq_trans with
-   (munion (singletonBag a0)
-      (munion (munion (singletonBag a) (list_contents _ eqA_dec l))
-         (list_contents _ eqA_dec l0))).
-  apply meq_right; trivial with datatypes.
-  apply munion_perm_left.
-  intros; apply cons_leA; apply lelistA_inv with l0; trivial with datatypes.
-Qed.
+    forall l:list A,
+      sort l ->
+      meq (list_contents _ eqA_dec l)
+      (munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
+      (forall a:A, lelistA a l1 -> lelistA a l2 -> lelistA a l) ->
+      merge_lem l1 l2.
+
+  Lemma merge :
+    forall l1:list A, sort l1 -> forall l2:list A, sort l2 -> merge_lem l1 l2.
+  Proof.
+    simple induction 1; intros.
+    apply merge_exist with l2; auto with datatypes.
+    elim H3; intros.
+    apply merge_exist with (a :: l); simpl in |- *; auto using cons_sort with datatypes.
+    elim (leA_dec a a0); intros.
+
+    (* 1 (leA a a0) *)
+    cut (merge_lem l (a0 :: l0)); auto using cons_sort with datatypes.
+    intros [l3 l3sorted l3contents Hrec].
+    apply merge_exist with (a :: l3); simpl in |- *;
+      auto using cons_sort, cons_leA with datatypes.
+    apply meq_trans with
+      (munion (singletonBag a)
+	(munion (list_contents _ eqA_dec l)
+          (list_contents _ eqA_dec (a0 :: l0)))).
+    apply meq_right; trivial with datatypes.
+    apply meq_sym; apply munion_ass.
+    intros; apply cons_leA.
+    apply lelistA_inv with l; trivial with datatypes.
+
+    (* 2 (leA a0 a) *)
+    elim H5; simpl in |- *; intros.
+    apply merge_exist with (a0 :: l3); simpl in |- *; 
+      auto using cons_sort, cons_leA with datatypes.
+    apply meq_trans with
+      (munion (singletonBag a0)
+	(munion (munion (singletonBag a) (list_contents _ eqA_dec l))
+          (list_contents _ eqA_dec l0))).
+    apply meq_right; trivial with datatypes.
+    apply munion_perm_left.
+    intros; apply cons_leA; apply lelistA_inv with l0; trivial with datatypes.
+  Qed.
 
 End defs.
 
 Unset Implicit Arguments.
 Hint Constructors sort: datatypes v62.
-Hint Constructors lelistA: datatypes v62.
\ No newline at end of file
+Hint Constructors lelistA: datatypes v62.
diff --git a/theories/Sorting/intro.tex b/theories/Sorting/intro.tex
new file mode 100644
index 00000000..64ae4c88
--- /dev/null
+++ b/theories/Sorting/intro.tex
@@ -0,0 +1 @@
+\section{Sorting}\label{Sorting}
diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v
new file mode 100644
index 00000000..1c02be7f
--- /dev/null
+++ b/theories/Strings/Ascii.v
@@ -0,0 +1,133 @@
+(************************************************************************)
+(*  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: Ascii.v 9245 2006-10-17 12:53:34Z notin $ *)
+
+(** Contributed by Laurent Théry (INRIA);
+    Adapted to Coq V8 by the Coq Development Team *)
+
+Require Import Bool.
+Require Import BinPos.
+
+(** * Definition of ascii characters *)
+
+(** Definition of ascii character as a 8 bits constructor *)
+ 
+Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool).
+
+Delimit Scope char_scope with char.
+Bind Scope char_scope with ascii.
+ 
+Definition zero := Ascii false false false false false false false false.
+ 
+Definition one := Ascii true false false false false false false false.
+ 
+Definition app1 (f : bool -> bool) (a : ascii) :=
+  match a with
+    | Ascii a1 a2 a3 a4 a5 a6 a7 a8 =>
+      Ascii (f a1) (f a2) (f a3) (f a4) (f a5) (f a6) (f a7) (f a8)
+  end.
+ 
+Definition app2 (f : bool -> bool -> bool) (a b : ascii) :=
+  match a, b with
+    | Ascii a1 a2 a3 a4 a5 a6 a7 a8, Ascii b1 b2 b3 b4 b5 b6 b7 b8 =>
+      Ascii (f a1 b1) (f a2 b2) (f a3 b3) (f a4 b4) 
+      (f a5 b5) (f a6 b6) (f a7 b7) (f a8 b8)
+  end.
+
+Definition shift (c : bool) (a : ascii) :=
+  match a with
+    | Ascii a1 a2 a3 a4 a5 a6 a7 a8 => Ascii c a1 a2 a3 a4 a5 a6 a7
+  end.
+
+(** Definition of a decidable function that is effective *)
+ 
+Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}.
+  decide equality; apply bool_dec.
+Defined.
+
+(** * Conversion between natural numbers modulo 256 and ascii characters *)
+
+(** Auxillary function that turns a positive into an ascii by
+   looking at the last n bits, ie z mod 2^n *)
+
+Fixpoint ascii_of_pos_aux (res acc : ascii) (z : positive) 
+  (n : nat) {struct n} : ascii :=
+  match n with
+    | O => res
+    | S n1 =>
+      match z with
+	| xH => app2 orb res acc
+	| xI z' => ascii_of_pos_aux (app2 orb res acc) (shift false acc) z' n1
+	| xO z' => ascii_of_pos_aux res (shift false acc) z' n1
+      end
+  end.
+
+
+(** Function that turns a positive into an ascii by
+    looking at the last 8 bits, ie a mod 8 *)
+ 
+Definition ascii_of_pos (a : positive) := ascii_of_pos_aux zero one a 8.
+
+(** Function that turns a Peano number into an ascii by converting it
+    to positive *)
+
+Definition ascii_of_nat (a : nat) :=
+  match a with
+    | O => zero
+    | S a' => ascii_of_pos (P_of_succ_nat a')
+  end.
+ 
+(** The opposite function *)
+
+Definition nat_of_ascii (a : ascii) : nat :=
+  let (a1, a2, a3, a4, a5, a6, a7, a8) := a in
+    2 *
+    (2 *
+      (2 *
+        (2 *
+          (2 *
+            (2 *
+              (2 * (if a8 then 1 else 0)
+		+ (if a7 then 1 else 0))
+              + (if a6 then 1 else 0))
+            + (if a5 then 1 else 0))
+          + (if a4 then 1 else 0))
+        + (if a3 then 1 else 0))
+      + (if a2 then 1 else 0))
+    + (if a1 then 1 else 0).
+
+Theorem ascii_nat_embedding : 
+  forall a : ascii, ascii_of_nat (nat_of_ascii a) = a.
+Proof.
+  destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity.
+Qed.
+
+(** * Concrete syntax *)
+
+(**
+  Ascii characters can be represented in scope char_scope as follows:
+  - ["c"]   represents itself if c is a character of code < 128,
+  - [""""]  is an exception: it represents the ascii character 34
+            (double quote),
+  - ["nnn"] represents the ascii character of decimal code nnn.
+
+  For instance, both ["065"] and ["A"] denote the character `uppercase
+  A', and both ["034"] and [""""] denote the character `double quote'.
+
+  Notice that the ascii characters of code >= 128 do not denote
+  stand-alone utf8 characters so that only the notation "nnn" is
+  available for them (unless your terminal is able to represent them,
+  which is typically not the case in coqide). 
+*)
+
+Open Local Scope char_scope.
+
+Example Space := " ".
+Example DoubleQuote := """".
+Example Beep := "007".
diff --git a/theories/Strings/String.v b/theories/Strings/String.v
new file mode 100644
index 00000000..f2c58364
--- /dev/null
+++ b/theories/Strings/String.v
@@ -0,0 +1,392 @@
+(************************************************************************)
+(*  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: String.v 8026 2006-02-11 19:40:49Z herbelin $ *)
+
+(** Contributed by Laurent Théry (INRIA);
+    Adapted to Coq V8 by the Coq Development Team *)
+
+Require Import Arith.
+Require Import Ascii.
+
+(** *** Definition of strings *)
+
+(** Implementation of string as list of ascii characters *)
+ 
+Inductive string : Set :=
+  | EmptyString : string
+  | String : ascii -> string -> string.
+
+Delimit Scope string_scope with string.
+Bind Scope string_scope with string.
+Open Local Scope string_scope.
+
+(** Equality is decidable *)
+
+Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
+ decide equality; apply ascii_dec.
+Defined.
+
+(** *** Concatenation of strings *)
+
+Reserved Notation "x ++ y" (right associativity, at level 60).
+
+Fixpoint append (s1 s2 : string) {struct s1} : string :=
+  match s1 with
+  | EmptyString => s2
+  | String c s1' => String c (s1' ++ s2)
+  end
+
+where "s1 ++ s2" := (append s1 s2) : string_scope.
+
+(******************************)
+(** Length                    *)
+(******************************)
+ 
+Fixpoint length (s : string) : nat :=
+  match s with
+  | EmptyString => 0
+  | String c s' => S (length s')
+  end.
+
+(******************************)
+(** Nth character of a string *)
+(******************************)
+ 
+Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
+  match s with
+  | EmptyString => None
+  | String c s' => match n with
+                   | O => Some c
+                   | S n' => get n' s'
+                   end
+  end.
+
+(** Two lists that are identical through get are syntactically equal *)
+ 
+Theorem get_correct :
+  forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
+Proof.
+intros s1; elim s1; simpl in |- *.
+intros s2; case s2; simpl in |- *; split; auto.
+intros H; generalize (H 0); intros H1; inversion H1.
+intros; discriminate.
+intros a s1' Rec s2; case s2; simpl in |- *; split; auto.
+intros H; generalize (H 0); intros H1; inversion H1.
+intros; discriminate.
+intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1.
+case (Rec s).
+intros H0; rewrite H0; auto.
+intros n; exact (H (S n)).
+intros H; injection H; intros H1 H2 n; case n; auto.
+rewrite H2; trivial.
+rewrite H1; auto.
+Qed.
+
+(** The first elements of [s1 ++ s2] are the ones of [s1] *)
+ 
+Theorem append_correct1 :
+ forall (s1 s2 : string) (n : nat),
+ n < length s1 -> get n s1 = get n (s1 ++ s2).
+Proof.
+intros s1; elim s1; simpl in |- *; auto.
+intros s2 n H; inversion H.
+intros a s1' Rec s2 n; case n; simpl in |- *; auto.
+intros n0 H; apply Rec; auto.
+apply lt_S_n; auto.
+Qed.
+
+(** The last elements of [s1 ++ s2] are the ones of [s2] *)
+ 
+Theorem append_correct2 :
+ forall (s1 s2 : string) (n : nat),
+ get n s2 = get (n + length s1) (s1 ++ s2).
+Proof.
+intros s1; elim s1; simpl in |- *; auto.
+intros s2 n; rewrite plus_comm; simpl in |- *; auto.
+intros a s1' Rec s2 n; case n; simpl in |- *; auto.
+generalize (Rec s2 0); simpl in |- *; auto.
+intros n0; rewrite <- Plus.plus_Snm_nSm; auto.
+Qed.
+
+(** *** Substrings *)
+
+(** [substring n m s] returns the substring of [s] that starts
+    at position [n] and of length [m];
+    if this does not make sense it returns [""] *)
+ 
+Fixpoint substring (n m : nat) (s : string) {struct s} : string :=
+  match n, m, s with
+  | 0, 0, _ => EmptyString
+  | 0, S m', EmptyString => s
+  | 0, S m', String c s' => String c (substring 0 m' s')
+  | S n', _, EmptyString => s
+  | S n', _, String c s' => substring n' m s'
+  end.
+
+(** The substring is included in the initial string *)
+ 
+Theorem substring_correct1 :
+ forall (s : string) (n m p : nat),
+ p < m -> get p (substring n m s) = get (p + n) s.
+Proof.
+intros s; elim s; simpl in |- *; auto.
+intros n; case n; simpl in |- *; auto.
+intros m; case m; simpl in |- *; auto.
+intros a s' Rec; intros n; case n; simpl in |- *; auto.
+intros m; case m; simpl in |- *; auto.
+intros p H; inversion H.
+intros m' p; case p; simpl in |- *; auto.
+intros n0 H; apply Rec; simpl in |- *; auto.
+apply Lt.lt_S_n; auto.
+intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
+Qed.
+
+(** The substring has at most [m] elements *)
+ 
+Theorem substring_correct2 :
+ forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None.
+Proof.
+intros s; elim s; simpl in |- *; auto.
+intros n; case n; simpl in |- *; auto.
+intros m; case m; simpl in |- *; auto.
+intros a s' Rec; intros n; case n; simpl in |- *; auto.
+intros m; case m; simpl in |- *; auto.
+intros m' p; case p; simpl in |- *; auto.
+intros H; inversion H.
+intros n0 H; apply Rec; simpl in |- *; auto.
+apply Le.le_S_n; auto.
+Qed.
+
+(** *** Test functions *)
+
+(** Test if [s1] is a prefix of [s2] *)
+ 
+Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
+  match s1 with
+  | EmptyString => true
+  | String a s1' =>
+      match s2 with
+      | EmptyString => false
+      | String b s2' =>
+          match ascii_dec a b with
+          | left _ => prefix s1' s2'
+          | right _ => false
+          end
+      end
+  end.
+
+(** If [s1] is a prefix of [s2], it is the [substring] of length
+    [length s1] starting at position [O] of [s2] *)
+ 
+Theorem prefix_correct :
+ forall s1 s2 : string,
+ prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
+Proof.
+intros s1; elim s1; simpl in |- *; auto.
+intros s2; case s2; simpl in |- *; split; auto.
+intros a s1' Rec s2; case s2; simpl in |- *; auto.
+split; intros; discriminate.
+intros b s2'; case (ascii_dec a b); simpl in |- *; auto.
+intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
+rewrite e; rewrite H1; auto.
+apply H2; injection H3; auto.
+intros n; split; intros; try discriminate.
+case n; injection H; auto.
+Qed.
+
+(** Test if, starting at position [n], [s1] occurs in [s2]; if
+    so it returns the position *)
+ 
+Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat :=
+  match s2, n with
+  | EmptyString, 0 =>
+      match s1 with
+      | EmptyString => Some 0
+      | String a s1' => None
+      end
+  | EmptyString, S n' => None
+  | String b s2', 0 => 
+      if prefix s1 s2 then Some 0
+      else
+        match index 0 s1 s2' with
+        | Some n => Some (S n)
+        | None => None
+        end
+   | String b s2', S n' =>
+      match index n' s1 s2' with
+      | Some n => Some (S n)
+      | None => None
+      end
+  end.
+
+(* Dirty trick to evaluate locally that prefix reduces itself *)
+Opaque prefix.
+
+(** If the result of [index] is [Some m], [s1] in [s2] at position [m] *)
+ 
+Theorem index_correct1 :
+ forall (n m : nat) (s1 s2 : string),
+ index n s1 s2 = Some m -> substring m (length s1) s2 = s1.
+Proof.
+intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
+ auto.
+intros n; case n; simpl in |- *; auto.
+intros m s1; case s1; simpl in |- *; auto.
+intros H; injection H; intros H1; rewrite <- H1; auto.
+intros; discriminate.
+intros; discriminate.
+intros b s2' Rec n m s1.
+case n; simpl in |- *; auto.
+generalize (prefix_correct s1 (String b s2'));
+ case (prefix s1 (String b s2')).
+intros H0 H; injection H; intros H1; rewrite <- H1; auto.
+case H0; simpl in |- *; auto.
+case m; simpl in |- *; auto.
+case (index 0 s1 s2'); intros; discriminate.
+intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
+intros x H H0 H1; apply H; injection H1; intros H2; injection H2; auto.
+intros; discriminate.
+intros n'; case m; simpl in |- *; auto.
+case (index n' s1 s2'); intros; discriminate.
+intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
+intros x H H1; apply H; injection H1; intros H2; injection H2; auto.
+intros; discriminate.
+Qed.
+
+(** If the result of [index] is [Some m], 
+    [s1] does not occur in [s2] before [m] *)
+ 
+Theorem index_correct2 :
+ forall (n m : nat) (s1 s2 : string),
+ index n s1 s2 = Some m ->
+ forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
+Proof.
+intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
+ auto.
+intros n; case n; simpl in |- *; auto.
+intros m s1; case s1; simpl in |- *; auto.
+intros H; injection H; intros H1; rewrite <- H1.
+intros p H0 H2; inversion H2.
+intros; discriminate.
+intros; discriminate.
+intros b s2' Rec n m s1.
+case n; simpl in |- *; auto.
+generalize (prefix_correct s1 (String b s2'));
+ case (prefix s1 (String b s2')).
+intros H0 H; injection H; intros H1; rewrite <- H1; auto.
+intros p H2 H3; inversion H3.
+case m; simpl in |- *; auto.
+case (index 0 s1 s2'); intros; discriminate.
+intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
+intros x H H0 H1 p; try case p; simpl in |- *; auto.
+intros H2 H3; red in |- *; intros H4; case H0.
+intros H5 H6; absurd (false = true); auto with bool.
+intros n0 H2 H3; apply H; auto.
+injection H1; intros H4; injection H4; auto.
+apply Le.le_O_n.
+apply Lt.lt_S_n; auto.
+intros; discriminate.
+intros n'; case m; simpl in |- *; auto.
+case (index n' s1 s2'); intros; discriminate.
+intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
+intros x H H0 p; case p; simpl in |- *; auto.
+intros H1; inversion H1; auto.
+intros n0 H1 H2; apply H; auto.
+injection H0; intros H3; injection H3; auto.
+apply Le.le_S_n; auto.
+apply Lt.lt_S_n; auto.
+intros; discriminate.
+Qed.
+
+(** If the result of [index] is [None], [s1] does not occur in [s2] 
+    after [n] *)
+ 
+Theorem index_correct3 :
+ forall (n m : nat) (s1 s2 : string),
+ index n s1 s2 = None ->
+ s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
+Proof.
+intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
+ auto.
+intros n; case n; simpl in |- *; auto.
+intros m s1; case s1; simpl in |- *; auto.
+case m; intros; red in |- *; intros; discriminate.
+intros n' m; case m; auto.
+intros s1; case s1; simpl in |- *; auto.
+intros b s2' Rec n m s1.
+case n; simpl in |- *; auto.
+generalize (prefix_correct s1 (String b s2'));
+ case (prefix s1 (String b s2')).
+intros; discriminate.
+case m; simpl in |- *; auto with bool.
+case s1; simpl in |- *; auto.
+intros a s H H0 H1 H2; red in |- *; intros H3; case H.
+intros H4 H5; absurd (false = true); auto with bool.
+case s1; simpl in |- *; auto.
+intros a s n0 H H0 H1 H2;
+ change (substring n0 (length (String a s)) s2' <> String a s) in |- *;
+ apply (Rec 0); auto.
+generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros;
+ discriminate.
+apply Le.le_O_n.
+intros n'; case m; simpl in |- *; auto.
+intros H H0 H1; inversion H1.
+intros n0 H H0 H1; apply (Rec n'); auto.
+generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros;
+ discriminate.
+apply Le.le_S_n; auto.
+Qed.
+
+(* Back to normal for prefix *)
+Transparent prefix.
+
+(** If we are searching for the [Empty] string and the answer is no
+    this means that [n] is greater than the size of [s] *)
+ 
+Theorem index_correct4 :
+ forall (n : nat) (s : string),
+ index n EmptyString s = None -> length s < n.
+Proof.
+intros n s; generalize n; clear n; elim s; simpl in |- *; auto.
+intros n; case n; simpl in |- *; auto.
+intros; discriminate.
+intros; apply Lt.lt_O_Sn.
+intros a s' H n; case n; simpl in |- *; auto.
+intros; discriminate.
+intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *;
+ auto.
+intros; discriminate.
+intros H0 H1; apply Lt.lt_n_S; auto.
+Qed.
+
+(** Same as [index] but with no optional type, we return [0] when it
+    does not occur *)
+ 
+Definition findex n s1 s2 :=
+  match index n s1 s2 with
+  | Some n => n
+  | None => 0
+  end.
+
+(** *** Concrete syntax *)
+
+(**
+  The concrete syntax for strings in scope string_scope follows the
+  Coq convention for strings: all ascii characters of code less than
+  128 are litteral to the exception of the character `double quote'
+  which must be doubled.
+
+  Strings that involve ascii characters of code >= 128 which are not
+  part of a valid utf8 sequence of characters are not representable
+  using the Coq string notation (use explicitly the String constructor
+  with the ascii codes of the characters).
+*)
+
+Example HelloWorld := "	""Hello world!""
+".
diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v
index a3f16888..1e22730b 100644
--- a/theories/Wellfounded/Disjoint_Union.v
+++ b/theories/Wellfounded/Disjoint_Union.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Disjoint_Union.v,v 1.9.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Disjoint_Union.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Author: Cristina Cornes
     From : Constructing Recursion Operators in Type Theory                 
@@ -15,41 +15,41 @@
 Require Import Relation_Operators.
 
 Section Wf_Disjoint_Union.
-Variables A B : Set.
-Variable leA : A -> A -> Prop.
-Variable leB : B -> B -> Prop.
-
-Notation Le_AsB := (le_AsB A B leA leB).
-
-Lemma acc_A_sum : forall x:A, Acc leA x -> Acc Le_AsB (inl B x).
-Proof.
- induction 1.
- apply Acc_intro; intros y H2.
- inversion_clear H2.
- auto with sets.
-Qed.
-
-Lemma acc_B_sum :
- well_founded leA -> forall x:B, Acc leB x -> Acc Le_AsB (inr A x).
-Proof.
- induction 2.
- apply Acc_intro; intros y H3.
- inversion_clear H3; auto with sets.
- apply acc_A_sum; auto with sets.
-Qed.
-
-
-Lemma wf_disjoint_sum :
- well_founded leA -> well_founded leB -> well_founded Le_AsB.
-Proof.
- intros.
- unfold well_founded in |- *.
- destruct a as [a| b].
- apply (acc_A_sum a).
- apply (H a).
-
- apply (acc_B_sum H b).
- apply (H0 b).
-Qed.
+  Variables A B : Set.
+  Variable leA : A -> A -> Prop.
+  Variable leB : B -> B -> Prop.
+
+  Notation Le_AsB := (le_AsB A B leA leB).
+  
+  Lemma acc_A_sum : forall x:A, Acc leA x -> Acc Le_AsB (inl B x).
+  Proof.
+    induction 1.
+    apply Acc_intro; intros y H2.
+    inversion_clear H2.
+    auto with sets.
+  Qed.
+
+  Lemma acc_B_sum :
+    well_founded leA -> forall x:B, Acc leB x -> Acc Le_AsB (inr A x).
+  Proof.
+    induction 2.
+    apply Acc_intro; intros y H3.
+    inversion_clear H3; auto with sets.
+    apply acc_A_sum; auto with sets.
+  Qed.
+
+
+  Lemma wf_disjoint_sum :
+    well_founded leA -> well_founded leB -> well_founded Le_AsB.
+  Proof.
+    intros.
+    unfold well_founded in |- *.
+    destruct a as [a| b].
+    apply (acc_A_sum a).
+    apply (H a).
+    
+    apply (acc_B_sum H b).
+    apply (H0 b).
+  Qed.
 
 End Wf_Disjoint_Union.
\ No newline at end of file
diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v
index 1677659c..44e07d0b 100644
--- a/theories/Wellfounded/Inclusion.v
+++ b/theories/Wellfounded/Inclusion.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Inclusion.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Inclusion.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Author: Bruno Barras *)
 
@@ -21,7 +21,7 @@ Section WfInclusion.
     induction 2.
     apply Acc_intro; auto with sets.
   Qed.
-
+  
   Hint Resolve Acc_incl.
 
   Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1.
diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v
index f2cf1d2e..210cc757 100644
--- a/theories/Wellfounded/Inverse_Image.v
+++ b/theories/Wellfounded/Inverse_Image.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Inverse_Image.v,v 1.10.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Inverse_Image.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Author: Bruno Barras *)
 
@@ -19,6 +19,7 @@ Section Inverse_Image.
   Let Rof (x y:A) : Prop := R (f x) (f y).
 
   Remark Acc_lemma : forall y:B, Acc R y -> forall x:A, y = f x -> Acc Rof x.
+  Proof.
     induction 1 as [y _ IHAcc]; intros x H.
     apply Acc_intro; intros y0 H1.
     apply (IHAcc (f y0)); try trivial.
@@ -26,30 +27,34 @@ Section Inverse_Image.
   Qed.
 
   Lemma Acc_inverse_image : forall x:A, Acc R (f x) -> Acc Rof x.
+  Proof.
     intros; apply (Acc_lemma (f x)); trivial.
   Qed.
 
   Theorem wf_inverse_image : well_founded R -> well_founded Rof.
+  Proof.
     red in |- *; intros; apply Acc_inverse_image; auto.
   Qed.
 
   Variable F : A -> B -> Prop.
   Let RoF (x y:A) : Prop :=
-     exists2 b : B, F x b & (forall c:B, F y c -> R b c).
-
-Lemma Acc_inverse_rel : forall b:B, Acc R b -> forall x:A, F x b -> Acc RoF x.
-induction 1 as [x _ IHAcc]; intros x0 H2.
-constructor; intros y H3.
-destruct H3.
-apply (IHAcc x1); auto.
-Qed.
-
-
-Theorem wf_inverse_rel : well_founded R -> well_founded RoF.
+    exists2 b : B, F x b & (forall c:B, F y c -> R b c).
+
+  Lemma Acc_inverse_rel : forall b:B, Acc R b -> forall x:A, F x b -> Acc RoF x.
+  Proof.
+    induction 1 as [x _ IHAcc]; intros x0 H2.
+    constructor; intros y H3.
+    destruct H3.
+    apply (IHAcc x1); auto.
+  Qed.
+  
+  
+  Theorem wf_inverse_rel : well_founded R -> well_founded RoF.
+  Proof.
     red in |- *; constructor; intros.
     case H0; intros.
     apply (Acc_inverse_rel x); auto.
-Qed.
+  Qed.
 
 End Inverse_Image.
 
diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
index d8a4d37c..efdf0495 100644
--- a/theories/Wellfounded/Lexicographic_Exponentiation.v
+++ b/theories/Wellfounded/Lexicographic_Exponentiation.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lexicographic_Exponentiation.v,v 1.10.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Lexicographic_Exponentiation.v 9610 2007-02-07 14:45:18Z herbelin $ i*)
 
 (** Author: Cristina Cornes
 
@@ -19,356 +19,350 @@ Require Import Relation_Operators.
 Require Import Transitive_Closure.
 
 Section Wf_Lexicographic_Exponentiation.
-Variable A : Set.
-Variable leA : A -> A -> Prop.
-
-Notation Power := (Pow A leA).
-Notation Lex_Exp := (lex_exp A leA).
-Notation ltl := (Ltl A leA).
-Notation Descl := (Desc A leA).
-
-Notation List := (list A).
-Notation Nil := (nil (A:=A)).
-(* useless but symmetric *)
-Notation Cons := (cons (A:=A)).
-Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100).
-
-Hint Resolve d_one d_nil t_step.
-
-Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z.
-Proof.
- simple induction x.
- simple induction z.
- simpl in |- *; intros H.
- inversion_clear H. 
- simpl in |- *; intros; apply (Lt_nil A leA).
- intros a l HInd.
- simpl in |- *.
- intros.
- inversion_clear H.
- apply (Lt_hd A leA); auto with sets.
- apply (Lt_tl A leA).
- apply (HInd y y0); auto with sets.
-Qed.
-
-
-Lemma right_prefix :
- forall x y z:List,
-   ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z).
-Proof.
- intros x y; generalize x.
- elim y; simpl in |- *.
- right.
- exists x0; auto with sets.
- intros.
- inversion H0.
- left; apply (Lt_nil A leA).
- left; apply (Lt_hd A leA); auto with sets.
- generalize (H x1 z H3).
- simple induction 1.
- left; apply (Lt_tl A leA); auto with sets.
- simple induction 1.
- simple induction 1; intros.
- rewrite H8.
- right; exists x2; auto with sets.
-Qed.
-
-
-
-Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x.
-Proof.
- intros.
- inversion H.
- generalize (app_cons_not_nil _ _ _ H1); simple induction 1. 
- cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets.
- intro.
- generalize (app_eq_unit _ _ H0).
- simple induction 1; simple induction 1; intros.
- rewrite H4; auto with sets.
- discriminate H5.
- generalize (app_inj_tail _ _ _ _ H0).
- simple induction 1; intros.
- rewrite <- H4; auto with sets.
-Qed.
-
-Lemma desc_tail :
- forall (x:List) (a b:A),
-   Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b.
-Proof.
- intro.
- apply rev_ind with
-  (A := A)
-  (P := fun x:List =>
-          forall a b:A,
-            Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b).
- intros.
-
- inversion H.
- cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil);
-  auto with sets; intro.
- generalize H0.
- intro.
- generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4);
-  simple induction 1.
- intros.
-
- generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
- generalize H1.
- rewrite <- H10; rewrite <- H7; intro.
- apply (t_step A leA); auto with sets.
-
-
-
- intros.
- inversion H0.
- generalize (app_cons_not_nil _ _ _ H3); intro.
- elim H1.
-
- generalize H0.
- generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b);
-  simple induction 1.
- intro.
- generalize (desc_prefix (Cons b (l ++ Cons x0 Nil)) a H5); intro.
- generalize (H x0 b H6).
- intro.
- apply t_trans with (A := A) (y := x0); auto with sets.
-
- apply t_step.
- generalize H1.
- rewrite H4; intro.
-
- generalize (app_inj_tail _ _ _ _ H8); simple induction 1.
- intros.
- generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b).
- intro.
- generalize H10.
- rewrite H12; intro.
- generalize (app_inj_tail _ _ _ _ H13); simple induction 1.
- intros.
- rewrite <- H11; rewrite <- H16; auto with sets.
-Qed.
-
-
-Lemma dist_aux :
- forall z:List, Descl z -> forall x y:List, z = x ++ y -> Descl x /\ Descl y.
-Proof.
- intros z D.
- elim D.
- intros.
- cut (x ++ y = Nil); auto with sets; intro.
- generalize (app_eq_nil _ _ H0); simple induction 1.
- intros.
- rewrite H2; rewrite H3; split; apply d_nil.
-
- intros.
- cut (x0 ++ y = Cons x Nil); auto with sets.
- intros E.
- generalize (app_eq_unit _ _ E); simple induction 1.
- simple induction 1; intros.
- rewrite H2; rewrite H3; split.
- apply d_nil.
-
- apply d_one.
-
- simple induction 1; intros.
- rewrite H2; rewrite H3; split.
- apply d_one.
-
- apply d_nil.
-
- do 5 intro.
- intros Hind.
- do 2 intro.
- generalize x0.
- apply rev_ind with
-  (A := A)
-  (P := fun y0:List =>
-          forall x0:List,
-            (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 ->
-            Descl x0 /\ Descl y0).
-
- intro.
- generalize (app_nil_end x1); simple induction 1; simple induction 1.
- split. apply d_conc; auto with sets.
-
- apply d_nil.
-
- do 3 intro.
- generalize x1.
- apply rev_ind with
-  (A := A)
-  (P := fun l0:List =>
-          forall (x1:A) (x0:List),
-            (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ l0 ++ Cons x1 Nil ->
-            Descl x0 /\ Descl (l0 ++ Cons x1 Nil)).
-
-
- simpl in |- *.
- split.
- generalize (app_inj_tail _ _ _ _ H2); simple induction 1.
- simple induction 1; auto with sets.
-
- apply d_one.
- do 5 intro.
- generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)).
- simple induction 1.
- generalize (app_ass x4 l1 (Cons x2 Nil)); simple induction 1.
- intro E.
- generalize (app_inj_tail _ _ _ _ E).
- simple induction 1; intros.
- generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
- rewrite <- H7; rewrite <- H10; generalize H6.
- generalize (app_ass x4 l1 (Cons x2 Nil)); intro E1.
- rewrite E1.
- intro.
- generalize (Hind x4 (l1 ++ Cons x2 Nil) H11).
- simple induction 1; split.
- auto with sets.
-
- generalize H14.
- rewrite <- H10; intro.
- apply d_conc; auto with sets.
-Qed.
-
-
-
-Lemma dist_Desc_concat :
- forall x y:List, Descl (x ++ y) -> Descl x /\ Descl y.
-Proof.
-  intros.
-  apply (dist_aux (x ++ y) H x y); auto with sets.
-Qed.
-
-
-Lemma desc_end :
- forall (a b:A) (x:List),
-   Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) ->
-   clos_trans A leA a b. 
-
-Proof.
- intros a b x.
- case x.
- simpl in |- *.
- simple induction 1.
- intros.
- inversion H1; auto with sets.
- inversion H3.
-
- simple induction 1.
- generalize (app_comm_cons l (Cons a Nil) a0).
- intros E; rewrite <- E; intros.
- generalize (desc_tail l a a0 H0); intro.
- inversion H1.
- apply t_trans with (y := a0); auto with sets.
-
- inversion H4.
-Qed.
-
-
-
-
-Lemma ltl_unit :
- forall (x:List) (a b:A),
-   Descl (x ++ Cons a Nil) ->
-   ltl (x ++ Cons a Nil) (Cons b Nil) -> ltl x (Cons b Nil).
-Proof.
- intro.
- case x.
- intros; apply (Lt_nil A leA).
-
- simpl in |- *; intros.
- inversion_clear H0.
- apply (Lt_hd A leA a b); auto with sets.
- 
- inversion_clear H1.
-Qed.
-
-
-Lemma acc_app :
- forall (x1 x2:List) (y1:Descl (x1 ++ x2)),
-   Acc Lex_Exp << x1 ++ x2, y1 >> ->
-   forall (x:List) (y:Descl x), ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>.
-Proof.
- intros.
- apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)).
- auto with sets.
-
- unfold lex_exp in |- *; simpl in |- *; auto with sets.
-Qed.
-
-
-Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp.
-Proof.
- unfold well_founded at 2 in |- *.
- simple induction a; intros x y.
- apply Acc_intro.
- simple induction y0.
- unfold lex_exp at 1 in |- *; simpl in |- *.
- apply rev_ind with
-  (A := A)
-  (P := fun x:List =>
-          forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>).
- intros.
- inversion_clear H0.
-
- intro.
- generalize (well_founded_ind (wf_clos_trans A leA H)).
- intros GR.
- apply GR with
-  (P := fun x0:A =>
-          forall l:List,
-            (forall (x1:List) (y:Descl x1),
-               ltl x1 l -> Acc Lex_Exp << x1, y >>) ->
-            forall (x1:List) (y:Descl x1),
-              ltl x1 (l ++ Cons x0 Nil) -> Acc Lex_Exp << x1, y >>).
- intro; intros HInd; intros.
- generalize (right_prefix x2 l (Cons x1 Nil) H1).
- simple induction 1.
- intro; apply (H0 x2 y1 H3).
-
- simple induction 1.
- intro; simple induction 1.
- clear H4 H2.
- intro; generalize y1; clear y1.
- rewrite H2.
- apply rev_ind with
-  (A := A)
-  (P := fun x3:List =>
-          forall y1:Descl (l ++ x3),
-            ltl x3 (Cons x1 Nil) -> Acc Lex_Exp << l ++ x3, y1 >>).
- intros.
- generalize (app_nil_end l); intros Heq.
- generalize y1.
- clear y1.
- rewrite <- Heq.
- intro.
- apply Acc_intro.
- simple induction y2.
- unfold lex_exp at 1 in |- *.
- simpl in |- *; intros x4 y3. intros.
- apply (H0 x4 y3); auto with sets.
-
- intros. 
- generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1).
- simple induction 1.
- intros.
- generalize (desc_end x4 x1 l0 (conj H8 H5)); intros.
- generalize y1.
- rewrite <- (app_ass l l0 (Cons x4 Nil)); intro.
- generalize (HInd x4 H9 (l ++ l0)); intros HInd2.
- generalize (ltl_unit l0 x4 x1 H8 H5); intro.
- generalize (dist_Desc_concat (l ++ l0) (Cons x4 Nil) y2).
- simple induction 1; intros.
- generalize (H4 H12 H10); intro.
- generalize (Acc_inv H14).
- generalize (acc_app l l0 H12 H14).
- intros f g.
- generalize (HInd2 f); intro.
- apply Acc_intro.
- simple induction y3.
- unfold lex_exp at 1 in |- *; simpl in |- *; intros.
- apply H15; auto with sets.
-Qed.
+  Variable A : Set.
+  Variable leA : A -> A -> Prop.
+  
+  Notation Power := (Pow A leA).
+  Notation Lex_Exp := (lex_exp A leA).
+  Notation ltl := (Ltl A leA).
+  Notation Descl := (Desc A leA).
+  
+  Notation List := (list A).
+  Notation Nil := (nil (A:=A)).
+  (* useless but symmetric *)
+  Notation Cons := (cons (A:=A)).
+  Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100).
+
+  (* Hint Resolve d_one d_nil t_step. *)
+  
+  Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z.
+  Proof.
+    simple induction x.
+    simple induction z.
+    simpl in |- *; intros H.
+    inversion_clear H. 
+    simpl in |- *; intros; apply (Lt_nil A leA).
+    intros a l HInd.
+    simpl in |- *.
+    intros.
+    inversion_clear H.
+    apply (Lt_hd A leA); auto with sets.
+    apply (Lt_tl A leA).
+    apply (HInd y y0); auto with sets.
+  Qed.
+
+
+  Lemma right_prefix :
+    forall x y z:List,
+      ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z).
+  Proof.
+    intros x y; generalize x.
+    elim y; simpl in |- *.
+    right.
+    exists x0; auto with sets.
+    intros.
+    inversion H0.
+    left; apply (Lt_nil A leA).
+    left; apply (Lt_hd A leA); auto with sets.
+    generalize (H x1 z H3).
+    simple induction 1.
+    left; apply (Lt_tl A leA); auto with sets.
+    simple induction 1.
+    simple induction 1; intros.
+    rewrite H8.
+    right; exists x2; auto with sets.
+  Qed.
+  
+  Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x.
+  Proof.
+    intros.
+    inversion H.
+    generalize (app_cons_not_nil _ _ _ H1); simple induction 1. 
+    cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets.
+    intro.
+    generalize (app_eq_unit _ _ H0).
+    simple induction 1; simple induction 1; intros.
+    rewrite H4; auto using d_nil with sets.
+    discriminate H5.
+    generalize (app_inj_tail _ _ _ _ H0).
+    simple induction 1; intros.
+    rewrite <- H4; auto with sets.
+  Qed.
+  
+  Lemma desc_tail :
+    forall (x:List) (a b:A),
+      Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b.
+  Proof.
+    intro.
+    apply rev_ind with
+      (A := A)
+      (P := fun x:List =>
+        forall a b:A,
+          Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b).
+    intros.
+    
+    inversion H.
+    cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil);
+      auto with sets; intro.
+    generalize H0.
+    intro.
+    generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4);
+      simple induction 1.
+    intros.
+    
+    generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
+    generalize H1.
+    rewrite <- H10; rewrite <- H7; intro.
+    apply (t_step A leA); auto with sets.
+    
+    intros.
+    inversion H0.
+    generalize (app_cons_not_nil _ _ _ H3); intro.
+    elim H1.
+    
+    generalize H0.
+    generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b);
+      simple induction 1.
+    intro.
+    generalize (desc_prefix (Cons b (l ++ Cons x0 Nil)) a H5); intro.
+    generalize (H x0 b H6).
+    intro.
+    apply t_trans with (A := A) (y := x0); auto with sets.
+    
+    apply t_step.
+    generalize H1.
+    rewrite H4; intro.
+    
+    generalize (app_inj_tail _ _ _ _ H8); simple induction 1.
+    intros.
+    generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b).
+    intro.
+    generalize H10.
+    rewrite H12; intro.
+    generalize (app_inj_tail _ _ _ _ H13); simple induction 1.
+    intros.
+    rewrite <- H11; rewrite <- H16; auto with sets.
+  Qed.
+
+
+  Lemma dist_aux :
+    forall z:List, Descl z -> forall x y:List, z = x ++ y -> Descl x /\ Descl y.
+  Proof.
+    intros z D.
+    elim D.
+    intros.
+    cut (x ++ y = Nil); auto with sets; intro.
+    generalize (app_eq_nil _ _ H0); simple induction 1.
+    intros.
+    rewrite H2; rewrite H3; split; apply d_nil.
+    
+    intros.
+    cut (x0 ++ y = Cons x Nil); auto with sets.
+    intros E.
+    generalize (app_eq_unit _ _ E); simple induction 1.
+    simple induction 1; intros.
+    rewrite H2; rewrite H3; split.
+    apply d_nil.
+    
+    apply d_one.
+    
+    simple induction 1; intros.
+    rewrite H2; rewrite H3; split.
+    apply d_one.
+    
+    apply d_nil.
+    
+    do 5 intro.
+    intros Hind.
+    do 2 intro.
+    generalize x0.
+    apply rev_ind with
+      (A := A)
+      (P := fun y0:List =>
+        forall x0:List,
+          (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 ->
+          Descl x0 /\ Descl y0).
+    
+    intro.
+    generalize (app_nil_end x1); simple induction 1; simple induction 1.
+    split. apply d_conc; auto with sets.
+    
+    apply d_nil.
+    
+    do 3 intro.
+    generalize x1.
+    apply rev_ind with
+      (A := A)
+      (P := fun l0:List =>
+        forall (x1:A) (x0:List),
+          (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ l0 ++ Cons x1 Nil ->
+          Descl x0 /\ Descl (l0 ++ Cons x1 Nil)).
+
+
+    simpl in |- *.
+    split.
+    generalize (app_inj_tail _ _ _ _ H2); simple induction 1.
+    simple induction 1; auto with sets.
+    
+    apply d_one.
+    do 5 intro.
+    generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)).
+    simple induction 1.
+    generalize (app_ass x4 l1 (Cons x2 Nil)); simple induction 1.
+    intro E.
+    generalize (app_inj_tail _ _ _ _ E).
+    simple induction 1; intros.
+    generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
+    rewrite <- H7; rewrite <- H10; generalize H6.
+    generalize (app_ass x4 l1 (Cons x2 Nil)); intro E1.
+    rewrite E1.
+    intro.
+    generalize (Hind x4 (l1 ++ Cons x2 Nil) H11).
+    simple induction 1; split.
+    auto with sets.
+    
+    generalize H14.
+    rewrite <- H10; intro.
+    apply d_conc; auto with sets.
+  Qed.
+
+
+
+  Lemma dist_Desc_concat :
+    forall x y:List, Descl (x ++ y) -> Descl x /\ Descl y.
+  Proof.
+    intros.
+    apply (dist_aux (x ++ y) H x y); auto with sets.
+  Qed.
+  
+  Lemma desc_end :
+    forall (a b:A) (x:List),
+      Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) ->
+      clos_trans A leA a b. 
+  Proof.
+    intros a b x.
+    case x.
+    simpl in |- *.
+    simple induction 1.
+    intros.
+    inversion H1; auto with sets.
+    inversion H3.
+    
+    simple induction 1.
+    generalize (app_comm_cons l (Cons a Nil) a0).
+    intros E; rewrite <- E; intros.
+    generalize (desc_tail l a a0 H0); intro.
+    inversion H1.
+    apply t_trans with (y := a0); auto with sets.
+    
+    inversion H4.
+  Qed.
+
+
+
+
+  Lemma ltl_unit :
+    forall (x:List) (a b:A),
+      Descl (x ++ Cons a Nil) ->
+      ltl (x ++ Cons a Nil) (Cons b Nil) -> ltl x (Cons b Nil).
+  Proof.
+    intro.
+    case x.
+    intros; apply (Lt_nil A leA).
+    
+    simpl in |- *; intros.
+    inversion_clear H0.
+    apply (Lt_hd A leA a b); auto with sets.
+    
+    inversion_clear H1.
+  Qed.
+  
+  
+  Lemma acc_app :
+    forall (x1 x2:List) (y1:Descl (x1 ++ x2)),
+      Acc Lex_Exp << x1 ++ x2, y1 >> ->
+      forall (x:List) (y:Descl x), ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>.
+  Proof.
+    intros.
+    apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)).
+    auto with sets.
+    
+    unfold lex_exp in |- *; simpl in |- *; auto with sets.
+  Qed.
+  
+  
+  Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp.
+  Proof.
+    unfold well_founded at 2 in |- *.
+    simple induction a; intros x y.
+    apply Acc_intro.
+    simple induction y0.
+    unfold lex_exp at 1 in |- *; simpl in |- *.
+    apply rev_ind with
+      (A := A)
+      (P := fun x:List =>
+	forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>).
+    intros.
+    inversion_clear H0.
+    
+    intro.
+    generalize (well_founded_ind (wf_clos_trans A leA H)).
+    intros GR.
+    apply GR with
+      (P := fun x0:A =>
+        forall l:List,
+          (forall (x1:List) (y:Descl x1),
+            ltl x1 l -> Acc Lex_Exp << x1, y >>) ->
+          forall (x1:List) (y:Descl x1),
+            ltl x1 (l ++ Cons x0 Nil) -> Acc Lex_Exp << x1, y >>).
+    intro; intros HInd; intros.
+    generalize (right_prefix x2 l (Cons x1 Nil) H1).
+    simple induction 1.
+    intro; apply (H0 x2 y1 H3).
+    
+    simple induction 1.
+    intro; simple induction 1.
+    clear H4 H2.
+    intro; generalize y1; clear y1.
+    rewrite H2.
+    apply rev_ind with
+      (A := A)
+      (P := fun x3:List =>
+        forall y1:Descl (l ++ x3),
+          ltl x3 (Cons x1 Nil) -> Acc Lex_Exp << l ++ x3, y1 >>).
+    intros.
+    generalize (app_nil_end l); intros Heq.
+    generalize y1.
+    clear y1.
+    rewrite <- Heq.
+    intro.
+    apply Acc_intro.
+    simple induction y2.
+    unfold lex_exp at 1 in |- *.
+    simpl in |- *; intros x4 y3. intros.
+    apply (H0 x4 y3); auto with sets.
+    
+    intros. 
+    generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1).
+    simple induction 1.
+    intros.
+    generalize (desc_end x4 x1 l0 (conj H8 H5)); intros.
+    generalize y1.
+    rewrite <- (app_ass l l0 (Cons x4 Nil)); intro.
+    generalize (HInd x4 H9 (l ++ l0)); intros HInd2.
+    generalize (ltl_unit l0 x4 x1 H8 H5); intro.
+    generalize (dist_Desc_concat (l ++ l0) (Cons x4 Nil) y2).
+    simple induction 1; intros.
+    generalize (H4 H12 H10); intro.
+    generalize (Acc_inv H14).
+    generalize (acc_app l l0 H12 H14).
+    intros f g.
+    generalize (HInd2 f); intro.
+    apply Acc_intro.
+    simple induction y3.
+    unfold lex_exp at 1 in |- *; simpl in |- *; intros.
+    apply H15; auto with sets.
+  Qed.
 
 
 End Wf_Lexicographic_Exponentiation.
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
index 8ac178fc..051c8127 100644
--- a/theories/Wellfounded/Lexicographic_Product.v
+++ b/theories/Wellfounded/Lexicographic_Product.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Lexicographic_Product.v,v 1.12.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Lexicographic_Product.v 9597 2007-02-06 19:44:05Z herbelin $ i*)
 
 (** Authors: Bruno Barras, Cristina Cornes *)
 
@@ -18,175 +18,154 @@ Require Import Transitive_Closure.
      L. Paulson  JSC (1986) 2, 325-355 *)
 
 Section WfLexicographic_Product.
-Variable A : Set.
-Variable B : A -> Set.
-Variable leA : A -> A -> Prop.
-Variable leB : forall x:A, B x -> B x -> Prop.
-
-Notation LexProd := (lexprod A B leA leB).
-
-Hint Resolve t_step Acc_clos_trans wf_clos_trans.
-
-Lemma acc_A_B_lexprod :
- forall x:A,
-   Acc leA x ->
-   (forall x0:A, clos_trans A leA x0 x -> well_founded (leB x0)) ->
-   forall y:B x, Acc (leB x) y -> Acc LexProd (existS B x y).
-Proof.
- induction 1 as [x _ IHAcc]; intros H2 y.
- induction 1 as [x0 H IHAcc0]; intros.
- apply Acc_intro.
- destruct y as [x2 y1]; intro H6.
- simple inversion H6; intro.
- cut (leA x2 x); intros.
- apply IHAcc; auto with sets.
- intros.
- apply H2.
- apply t_trans with x2; auto with sets.
-
- red in H2.
- apply H2.
- auto with sets.
-
- injection H1.
- destruct 2.
- injection H3.
- destruct 2; auto with sets.
-
- rewrite <- H1.
- injection H3; intros _ Hx1.
- subst x1.
- apply IHAcc0.
- elim inj_pair2 with A B x y' x0; assumption.
-Qed.
-
-Theorem wf_lexprod :
- well_founded leA ->
- (forall x:A, well_founded (leB x)) -> well_founded LexProd.
-Proof.
- intros wfA wfB; unfold well_founded in |- *.
- destruct a.
- apply acc_A_B_lexprod; auto with sets; intros.
- red in wfB.
- auto with sets.
-Qed.
+  Variable A : Type.
+  Variable B : A -> Type.
+  Variable leA : A -> A -> Prop.
+  Variable leB : forall x:A, B x -> B x -> Prop.
+
+  Notation LexProd := (lexprod A B leA leB).
+  
+  Lemma acc_A_B_lexprod :
+    forall x:A,
+      Acc leA x ->
+      (forall x0:A, clos_trans A leA x0 x -> well_founded (leB x0)) ->
+      forall y:B x, Acc (leB x) y -> Acc LexProd (existS B x y).
+  Proof.
+    induction 1 as [x _ IHAcc]; intros H2 y.
+    induction 1 as [x0 H IHAcc0]; intros.
+    apply Acc_intro.
+    destruct y as [x2 y1]; intro H6.
+    simple inversion H6; intro.
+    cut (leA x2 x); intros.
+    apply IHAcc; auto with sets.
+    intros.
+    apply H2.
+    apply t_trans with x2; auto with sets.
+    
+    red in H2.
+    apply H2.
+    auto with sets.
+    
+    injection H1.
+    destruct 2.
+    injection H3.
+    destruct 2; auto with sets.
+    
+    rewrite <- H1.
+    injection H3; intros _ Hx1.
+    subst x1.
+    apply IHAcc0.
+    elim inj_pair2 with A B x y' x0; assumption.
+  Qed.
+
+  Theorem wf_lexprod :
+    well_founded leA ->
+    (forall x:A, well_founded (leB x)) -> well_founded LexProd.
+  Proof.
+    intros wfA wfB; unfold well_founded in |- *.
+    destruct a.
+    apply acc_A_B_lexprod; auto with sets; intros.
+    red in wfB.
+    auto with sets.
+  Qed.
 
 
 End WfLexicographic_Product.
 
 
 Section Wf_Symmetric_Product.
-  Variable A : Set.
-  Variable B : Set.
+  Variable A : Type.
+  Variable B : Type.
   Variable leA : A -> A -> Prop.
   Variable leB : B -> B -> Prop.
 
   Notation Symprod := (symprod A B leA leB).
 
-(*i
-  Local sig_prod:=
-         [x:A*B]<{_:A&B}>Case x of [a:A][b:B](existS A [_:A]B a b) end.
-
-Lemma incl_sym_lexprod: (included (A*B) Symprod  
-            (R_o_f (A*B) {_:A&B} sig_prod (lexprod A [_:A]B leA [_:A]leB))).
-Proof.
- Red.
- Induction x.
- (Induction y1;Intros).
- Red.
- Unfold sig_prod .
- Inversion_clear H.
- (Apply left_lex;Auto with sets).
-
- (Apply right_lex;Auto with sets).
-Qed.
-i*)
-
   Lemma Acc_symprod :
-   forall x:A, Acc leA x -> forall y:B, Acc leB y -> Acc Symprod (x, y).
- Proof.
- induction 1 as [x _ IHAcc]; intros y H2.
- induction H2 as [x1 H3 IHAcc1].
- apply Acc_intro; intros y H5.
- inversion_clear H5; auto with sets.
- apply IHAcc; auto.
- apply Acc_intro; trivial.
-Qed.
-
-
-Lemma wf_symprod :
- well_founded leA -> well_founded leB -> well_founded Symprod.
-Proof.
- red in |- *.
- destruct a.
- apply Acc_symprod; auto with sets.
-Qed.
+    forall x:A, Acc leA x -> forall y:B, Acc leB y -> Acc Symprod (x, y).
+  Proof.
+    induction 1 as [x _ IHAcc]; intros y H2.
+    induction H2 as [x1 H3 IHAcc1].
+    apply Acc_intro; intros y H5.
+    inversion_clear H5; auto with sets.
+    apply IHAcc; auto.
+    apply Acc_intro; trivial.
+  Qed.
+
+
+  Lemma wf_symprod :
+    well_founded leA -> well_founded leB -> well_founded Symprod.
+  Proof.
+    red in |- *.
+    destruct a.
+    apply Acc_symprod; auto with sets.
+  Qed.
 
 End Wf_Symmetric_Product.
 
 
 Section Swap.
-
-  Variable A : Set.
+  
+  Variable A : Type.
   Variable R : A -> A -> Prop.
 
   Notation SwapProd := (swapprod A R).
 
 
   Lemma swap_Acc : forall x y:A, Acc SwapProd (x, y) -> Acc SwapProd (y, x).
-Proof.
- intros.
- inversion_clear H.
- apply Acc_intro.
- destruct y0; intros.
- inversion_clear H; inversion_clear H1; apply H0.
- apply sp_swap.
- apply right_sym; auto with sets.
-
- apply sp_swap.
- apply left_sym; auto with sets.
-
- apply sp_noswap.
- apply right_sym; auto with sets.
-
- apply sp_noswap.
- apply left_sym; auto with sets.
-Qed.
+  Proof.
+    intros.
+    inversion_clear H.
+    apply Acc_intro.
+    destruct y0; intros.
+    inversion_clear H; inversion_clear H1; apply H0.
+    apply sp_swap.
+    apply right_sym; auto with sets.
+    
+    apply sp_swap.
+    apply left_sym; auto with sets.
+    
+    apply sp_noswap.
+    apply right_sym; auto with sets.
+    
+    apply sp_noswap.
+    apply left_sym; auto with sets.
+  Qed.
 
 
   Lemma Acc_swapprod :
-   forall x y:A, Acc R x -> Acc R y -> Acc SwapProd (x, y).
-Proof.
- induction 1 as [x0 _ IHAcc0]; intros H2.
- cut (forall y0:A, R y0 x0 -> Acc SwapProd (y0, y)).
- clear IHAcc0.
- induction H2 as [x1 _ IHAcc1]; intros H4.
- cut (forall y:A, R y x1 -> Acc SwapProd (x0, y)).
- clear IHAcc1.
- intro.
- apply Acc_intro.
- destruct y; intro H5.
- inversion_clear H5.
- inversion_clear H0; auto with sets.
-
- apply swap_Acc.
- inversion_clear H0; auto with sets.
-
- intros.
- apply IHAcc1; auto with sets; intros.
- apply Acc_inv with (y0, x1); auto with sets.
- apply sp_noswap.
- apply right_sym; auto with sets.
-
- auto with sets.
-Qed.
-
-
+    forall x y:A, Acc R x -> Acc R y -> Acc SwapProd (x, y).
+  Proof.
+    induction 1 as [x0 _ IHAcc0]; intros H2.
+    cut (forall y0:A, R y0 x0 -> Acc SwapProd (y0, y)).
+    clear IHAcc0.
+    induction H2 as [x1 _ IHAcc1]; intros H4.
+    cut (forall y:A, R y x1 -> Acc SwapProd (x0, y)).
+    clear IHAcc1.
+    intro.
+    apply Acc_intro.
+    destruct y; intro H5.
+    inversion_clear H5.
+    inversion_clear H0; auto with sets.
+    
+    apply swap_Acc.
+    inversion_clear H0; auto with sets.
+    
+    intros.
+    apply IHAcc1; auto with sets; intros.
+    apply Acc_inv with (y0, x1); auto with sets.
+    apply sp_noswap.
+    apply right_sym; auto with sets.
+    
+    auto with sets.
+  Qed.
+
+  
   Lemma wf_swapprod : well_founded R -> well_founded SwapProd.
-Proof.
- red in |- *.
- destruct a; intros.
- apply Acc_swapprod; auto with sets.
-Qed.
+  Proof.
+    red in |- *.
+    destruct a; intros.
+    apply Acc_swapprod; auto with sets.
+  Qed.
 
-End Swap.
\ No newline at end of file
+End Swap.
diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v
index 2e9d497b..bd4e4fec 100644
--- a/theories/Wellfounded/Transitive_Closure.v
+++ b/theories/Wellfounded/Transitive_Closure.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Transitive_Closure.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Transitive_Closure.v 9597 2007-02-06 19:44:05Z herbelin $ i*)
 
 (** Author: Bruno Barras *)
 
@@ -14,7 +14,7 @@ Require Import Relation_Definitions.
 Require Import Relation_Operators.
 
 Section Wf_Transitive_Closure.
-  Variable A : Set.
+  Variable A : Type.
   Variable R : relation A.
 
   Notation trans_clos := (clos_trans A R).
@@ -44,4 +44,4 @@ Section Wf_Transitive_Closure.
     unfold well_founded in |- *; auto with sets.
   Qed.
 
-End Wf_Transitive_Closure.
\ No newline at end of file
+End Wf_Transitive_Closure.
diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v
index 8f31ce9f..634576ad 100644
--- a/theories/Wellfounded/Union.v
+++ b/theories/Wellfounded/Union.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Union.v,v 1.9.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Union.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Author: Bruno Barras *)
 
@@ -18,60 +18,58 @@ Section WfUnion.
   Variable A : Set.
   Variables R1 R2 : relation A.
   
- Notation Union := (union A R1 R2).
-
- Hint Resolve Acc_clos_trans wf_clos_trans.
-
-Remark strip_commut :
- commut A R1 R2 ->
- forall x y:A,
-   clos_trans A R1 y x ->
-   forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & clos_trans A R1 z y'.
-Proof.
- induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
- elim H with y x z; auto with sets; intros x0 H2 H3.
- exists x0; auto with sets.
-
- elim IH1 with z0; auto with sets; intros.
- elim IH2 with x0; auto with sets; intros.
- exists x1; auto with sets.
- apply t_trans with x0; auto with sets.
-Qed.
+  Notation Union := (union A R1 R2).
+  
+  Remark strip_commut :
+    commut A R1 R2 ->
+    forall x y:A,
+      clos_trans A R1 y x ->
+      forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & clos_trans A R1 z y'.
+  Proof.
+    induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
+    elim H with y x z; auto with sets; intros x0 H2 H3.
+    exists x0; auto with sets.
+    
+    elim IH1 with z0; auto with sets; intros.
+    elim IH2 with x0; auto with sets; intros.
+    exists x1; auto with sets.
+    apply t_trans with x0; auto with sets.
+  Qed.
 
 
   Lemma Acc_union :
-   commut A R1 R2 ->
-   (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a.
-Proof.
- induction 3 as [x H1 H2].
- apply Acc_intro; intros.
- elim H3; intros; auto with sets.
- cut (clos_trans A R1 y x); auto with sets.
- elimtype (Acc (clos_trans A R1) y); intros.
- apply Acc_intro; intros.
- elim H8; intros.
- apply H6; auto with sets.
- apply t_trans with x0; auto with sets.
-
- elim strip_commut with x x0 y0; auto with sets; intros.
- apply Acc_inv_trans with x1; auto with sets.
- unfold union in |- *.
- elim H11; auto with sets; intros.
- apply t_trans with y1; auto with sets.
-
- apply (Acc_clos_trans A).
- apply Acc_inv with x; auto with sets.
- apply H0.
- apply Acc_intro; auto with sets.
-Qed.
+    commut A R1 R2 ->
+    (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a.
+  Proof.
+    induction 3 as [x H1 H2].
+    apply Acc_intro; intros.
+    elim H3; intros; auto with sets.
+    cut (clos_trans A R1 y x); auto with sets.
+    elimtype (Acc (clos_trans A R1) y); intros.
+    apply Acc_intro; intros.
+    elim H8; intros.
+    apply H6; auto with sets.
+    apply t_trans with x0; auto with sets.
+    
+    elim strip_commut with x x0 y0; auto with sets; intros.
+    apply Acc_inv_trans with x1; auto with sets.
+    unfold union in |- *.
+    elim H11; auto with sets; intros.
+    apply t_trans with y1; auto with sets.
 
+    apply (Acc_clos_trans A).
+    apply Acc_inv with x; auto with sets.
+    apply H0.
+    apply Acc_intro; auto with sets.
+  Qed.
 
+  
   Theorem wf_union :
-   commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
-Proof.
- unfold well_founded in |- *.
- intros.
- apply Acc_union; auto with sets.
-Qed.
+    commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
+  Proof.
+    unfold well_founded in |- *.
+    intros.
+    apply Acc_union; auto with sets.
+  Qed.
 
 End WfUnion.
\ No newline at end of file
diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v
index 4a20c518..f691f2b7 100644
--- a/theories/Wellfounded/Well_Ordering.v
+++ b/theories/Wellfounded/Well_Ordering.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Well_Ordering.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Well_Ordering.v 9597 2007-02-06 19:44:05Z herbelin $ i*)
 
 (** Author: Cristina Cornes.
     From: Constructing Recursion Operators in Type Theory
@@ -15,58 +15,57 @@
 Require Import Eqdep.
 
 Section WellOrdering.
-Variable A : Set.
-Variable B : A -> Set. 
-
-Inductive WO : Set :=
+  Variable A : Type.
+  Variable B : A -> Type. 
+  
+  Inductive WO : Type :=
     sup : forall (a:A) (f:B a -> WO), WO.
 
 
-Inductive le_WO : WO -> WO -> Prop :=
+  Inductive le_WO : WO -> WO -> Prop :=
     le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup a f).
  
-
-Theorem wf_WO : well_founded le_WO.
-Proof.
- unfold well_founded in |- *; intro.
- apply Acc_intro.
- elim a.
- intros.
- inversion H0.
- apply Acc_intro.
- generalize H4; generalize H1; generalize f0; generalize v.
- rewrite H3.
- intros.
- apply (H v0 y0).
- cut (f = f1).
- intros E; rewrite E; auto.
- symmetry  in |- *.
- apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5).
-Qed.
+  Theorem wf_WO : well_founded le_WO.
+  Proof.
+    unfold well_founded in |- *; intro.
+    apply Acc_intro.
+    elim a.
+    intros.
+    inversion H0.
+    apply Acc_intro.
+    generalize H4; generalize H1; generalize f0; generalize v.
+    rewrite H3.
+    intros.
+    apply (H v0 y0).
+    cut (f = f1).
+    intros E; rewrite E; auto.
+    symmetry  in |- *.
+    apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5).
+  Qed.
 
 End WellOrdering.
 
 
 Section Characterisation_wf_relations.
 
-(** Wellfounded relations are the inverse image of wellordering types *)
-(*  in course of development                                          *)
+  (** Wellfounded relations are the inverse image of wellordering types *)
+  (*  in course of development                                          *)
 
 
-Variable A : Set.
-Variable leA : A -> A -> Prop.
+  Variable A : Type.
+  Variable leA : A -> A -> Prop.
 
-Definition B (a:A) := {x : A | leA x a}.
+  Definition B (a:A) := {x : A | leA x a}.
 
-Definition wof : well_founded leA -> A -> WO A B.
-Proof.
- intros.
- apply (well_founded_induction H (fun a:A => WO A B)); auto.
- intros.
- apply (sup A B x).
- unfold B at 1 in |- *.
- destruct 1 as [x0].
- apply (H1 x0); auto.
+  Definition wof : well_founded leA -> A -> WO A B.
+  Proof.
+    intros.
+    apply (well_founded_induction_type H (fun a:A => WO A B)); auto.
+    intros x H1.
+    apply (sup A B x).
+    unfold B at 1 in |- *.
+    destruct 1 as [x0].
+    apply (H1 x0); auto.
 Qed.
 
-End Characterisation_wf_relations.
\ No newline at end of file
+End Characterisation_wf_relations.
diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v
index 87c00b47..d5dfd072 100644
--- a/theories/Wellfounded/Wellfounded.v
+++ b/theories/Wellfounded/Wellfounded.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wellfounded.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+(*i $Id: Wellfounded.v 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 Require Export Disjoint_Union.
 Require Export Inclusion.
diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
index 11fa3872..71e48360 100644
--- a/theories/ZArith/BinInt.v
+++ b/theories/ZArith/BinInt.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: BinInt.v,v 1.5.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+(*i $Id: BinInt.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (***********************************************************)
 (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
@@ -17,190 +17,192 @@ Require Export Pnat.
 Require Import BinNat.
 Require Import Plus.
 Require Import Mult.
-(**********************************************************************)
-(** Binary integer numbers *)
+
+Unset Boxed Definitions.
+
+(*****************************)
+(** * Binary integer numbers *)
 
 Inductive Z : Set :=
   | Z0 : Z
   | Zpos : positive -> Z
   | Zneg : positive -> Z.
 
-(** Declare Scope Z_scope with Key Z *)
-Delimit Scope Z_scope with Z.
 
 (** Automatically open scope positive_scope for the constructors of Z *)
+Delimit Scope Z_scope with Z.
 Bind Scope Z_scope with Z.
 Arguments Scope Zpos [positive_scope].
 Arguments Scope Zneg [positive_scope].
 
-(** Subtraction of positive into Z *)
+(** ** Subtraction of positive into Z *)
 
 Definition Zdouble_plus_one (x:Z) :=
   match x with
-  | Z0 => Zpos 1
-  | Zpos p => Zpos (xI p)
-  | Zneg p => Zneg (Pdouble_minus_one p)
+    | Z0 => Zpos 1
+    | Zpos p => Zpos (xI p)
+    | Zneg p => Zneg (Pdouble_minus_one p)
   end.
 
 Definition Zdouble_minus_one (x:Z) :=
   match x with
-  | Z0 => Zneg 1
-  | Zneg p => Zneg (xI p)
-  | Zpos p => Zpos (Pdouble_minus_one p)
+    | Z0 => Zneg 1
+    | Zneg p => Zneg (xI p)
+    | Zpos p => Zpos (Pdouble_minus_one p)
   end.
 
 Definition Zdouble (x:Z) :=
   match x with
-  | Z0 => Z0
-  | Zpos p => Zpos (xO p)
-  | Zneg p => Zneg (xO p)
+    | Z0 => Z0
+    | Zpos p => Zpos (xO p)
+    | Zneg p => Zneg (xO p)
   end.
 
 Fixpoint ZPminus (x y:positive) {struct y} : Z :=
   match x, y with
-  | xI x', xI y' => Zdouble (ZPminus x' y')
-  | xI x', xO y' => Zdouble_plus_one (ZPminus x' y')
-  | xI x', xH => Zpos (xO x')
-  | xO x', xI y' => Zdouble_minus_one (ZPminus x' y')
-  | xO x', xO y' => Zdouble (ZPminus x' y')
-  | xO x', xH => Zpos (Pdouble_minus_one x')
-  | xH, xI y' => Zneg (xO y')
-  | xH, xO y' => Zneg (Pdouble_minus_one y')
-  | xH, xH => Z0
+    | xI x', xI y' => Zdouble (ZPminus x' y')
+    | xI x', xO y' => Zdouble_plus_one (ZPminus x' y')
+    | xI x', xH => Zpos (xO x')
+    | xO x', xI y' => Zdouble_minus_one (ZPminus x' y')
+    | xO x', xO y' => Zdouble (ZPminus x' y')
+    | xO x', xH => Zpos (Pdouble_minus_one x')
+    | xH, xI y' => Zneg (xO y')
+    | xH, xO y' => Zneg (Pdouble_minus_one y')
+    | xH, xH => Z0
   end.
 
-(** Addition on integers *)
+(** ** Addition on integers *)
 
 Definition Zplus (x y:Z) :=
   match x, y with
-  | Z0, y => y
-  | x, Z0 => x
-  | Zpos x', Zpos y' => Zpos (x' + y')
-  | Zpos x', Zneg y' =>
+    | Z0, y => y
+    | x, Z0 => x
+    | Zpos x', Zpos y' => Zpos (x' + y')
+    | Zpos x', Zneg y' =>
       match (x' ?= y')%positive Eq with
-      | Eq => Z0
-      | Lt => Zneg (y' - x')
-      | Gt => Zpos (x' - y')
+	| Eq => Z0
+	| Lt => Zneg (y' - x')
+	| Gt => Zpos (x' - y')
       end
-  | Zneg x', Zpos y' =>
+    | Zneg x', Zpos y' =>
       match (x' ?= y')%positive Eq with
-      | Eq => Z0
-      | Lt => Zpos (y' - x')
-      | Gt => Zneg (x' - y')
+	| Eq => Z0
+	| Lt => Zpos (y' - x')
+	| Gt => Zneg (x' - y')
       end
-  | Zneg x', Zneg y' => Zneg (x' + y')
+    | Zneg x', Zneg y' => Zneg (x' + y')
   end.
 
 Infix "+" := Zplus : Z_scope.
 
-(** Opposite *)
+(** ** Opposite *)
 
 Definition Zopp (x:Z) :=
   match x with
-  | Z0 => Z0
-  | Zpos x => Zneg x
-  | Zneg x => Zpos x
+    | Z0 => Z0
+    | Zpos x => Zneg x
+    | Zneg x => Zpos x
   end.
 
 Notation "- x" := (Zopp x) : Z_scope.
 
-(** Successor on integers *)
+(** ** Successor on integers *)
 
 Definition Zsucc (x:Z) := (x + Zpos 1)%Z.
 
-(** Predecessor on integers *)
+(** ** Predecessor on integers *)
 
 Definition Zpred (x:Z) := (x + Zneg 1)%Z.
 
-(** Subtraction on integers *)
+(** ** Subtraction on integers *)
 
 Definition Zminus (m n:Z) := (m + - n)%Z.
 
 Infix "-" := Zminus : Z_scope.
 
-(** Multiplication on integers *)
+(** ** Multiplication on integers *)
 
 Definition Zmult (x y:Z) :=
   match x, y with
-  | Z0, _ => Z0
-  | _, Z0 => Z0
-  | Zpos x', Zpos y' => Zpos (x' * y')
-  | Zpos x', Zneg y' => Zneg (x' * y')
-  | Zneg x', Zpos y' => Zneg (x' * y')
-  | Zneg x', Zneg y' => Zpos (x' * y')
+    | Z0, _ => Z0
+    | _, Z0 => Z0
+    | Zpos x', Zpos y' => Zpos (x' * y')
+    | Zpos x', Zneg y' => Zneg (x' * y')
+    | Zneg x', Zpos y' => Zneg (x' * y')
+    | Zneg x', Zneg y' => Zpos (x' * y')
   end.
 
 Infix "*" := Zmult : Z_scope.
 
-(** Comparison of integers *)
+(** ** Comparison of integers *)
 
 Definition Zcompare (x y:Z) :=
   match x, y with
-  | Z0, Z0 => Eq
-  | Z0, Zpos y' => Lt
-  | Z0, Zneg y' => Gt
-  | Zpos x', Z0 => Gt
-  | Zpos x', Zpos y' => (x' ?= y')%positive Eq
-  | Zpos x', Zneg y' => Gt
-  | Zneg x', Z0 => Lt
-  | Zneg x', Zpos y' => Lt
-  | Zneg x', Zneg y' => CompOpp ((x' ?= y')%positive Eq)
+    | Z0, Z0 => Eq
+    | Z0, Zpos y' => Lt
+    | Z0, Zneg y' => Gt
+    | Zpos x', Z0 => Gt
+    | Zpos x', Zpos y' => (x' ?= y')%positive Eq
+    | Zpos x', Zneg y' => Gt
+    | Zneg x', Z0 => Lt
+    | Zneg x', Zpos y' => Lt
+    | Zneg x', Zneg y' => CompOpp ((x' ?= y')%positive Eq)
   end.
 
 Infix "?=" := Zcompare (at level 70, no associativity) : Z_scope.
 
 Ltac elim_compare com1 com2 :=
   case (Dcompare (com1 ?= com2)%Z);
-   [ idtac | let x := fresh "H" in
-             (intro x; case x; clear x) ].
+    [ idtac | let x := fresh "H" in
+      (intro x; case x; clear x) ].
 
-(** Sign function *)
+(** ** Sign function *)
 
 Definition Zsgn (z:Z) : Z :=
   match z with
-  | Z0 => Z0
-  | Zpos p => Zpos 1
-  | Zneg p => Zneg 1
+    | Z0 => Z0
+    | Zpos p => Zpos 1
+    | Zneg p => Zneg 1
   end.
 
-(** Direct, easier to handle variants of successor and addition *)
+(** ** Direct, easier to handle variants of successor and addition *)
 
 Definition Zsucc' (x:Z) :=
   match x with
-  | Z0 => Zpos 1
-  | Zpos x' => Zpos (Psucc x')
-  | Zneg x' => ZPminus 1 x'
+    | Z0 => Zpos 1
+    | Zpos x' => Zpos (Psucc x')
+    | Zneg x' => ZPminus 1 x'
   end.
 
 Definition Zpred' (x:Z) :=
   match x with
-  | Z0 => Zneg 1
-  | Zpos x' => ZPminus x' 1
-  | Zneg x' => Zneg (Psucc x')
+    | Z0 => Zneg 1
+    | Zpos x' => ZPminus x' 1
+    | Zneg x' => Zneg (Psucc x')
   end.
 
 Definition Zplus' (x y:Z) :=
   match x, y with
-  | Z0, y => y
-  | x, Z0 => x
-  | Zpos x', Zpos y' => Zpos (x' + y')
-  | Zpos x', Zneg y' => ZPminus x' y'
-  | Zneg x', Zpos y' => ZPminus y' x'
-  | Zneg x', Zneg y' => Zneg (x' + y')
+    | Z0, y => y
+    | x, Z0 => x
+    | Zpos x', Zpos y' => Zpos (x' + y')
+    | Zpos x', Zneg y' => ZPminus x' y'
+    | Zneg x', Zpos y' => ZPminus y' x'
+    | Zneg x', Zneg y' => Zneg (x' + y')
   end.
 
 Open Local Scope Z_scope.
 
 (**********************************************************************)
-(** Inductive specification of Z *)
+(** ** Inductive specification of Z *)
 
 Theorem Zind :
- forall P:Z -> Prop,
-   P Z0 ->
-   (forall x:Z, P x -> P (Zsucc' x)) ->
-   (forall x:Z, P x -> P (Zpred' x)) -> forall n:Z, P n.
+  forall P:Z -> Prop,
+    P Z0 ->
+    (forall x:Z, P x -> P (Zsucc' x)) ->
+    (forall x:Z, P x -> P (Zpred' x)) -> forall n:Z, P n.
 Proof.
-intros P H0 Hs Hp z; destruct z.
+  intros P H0 Hs Hp z; destruct z.
   assumption.
   apply Pind with (P := fun p => P (Zpos p)).
     change (P (Zsucc' Z0)) in |- *; apply Hs; apply H0.
@@ -211,52 +213,56 @@ intros P H0 Hs Hp z; destruct z.
 Qed.
 
 (**********************************************************************)
-(** Properties of opposite on binary integer numbers *)
+(** * Misc properties about binary integer operations *)
+
+
+(**********************************************************************)
+(** ** Properties of opposite on binary integer numbers *)
 
 Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p.
 Proof.
-reflexivity.
+  reflexivity.
 Qed.
 
 (** [opp] is involutive *)
 
 Theorem Zopp_involutive : forall n:Z, - - n = n.
 Proof.
-intro x; destruct x; reflexivity.
+  intro x; destruct x; reflexivity.
 Qed.
 
 (** Injectivity of the opposite *)
 
 Theorem Zopp_inj : forall n m:Z, - n = - m -> n = m.
 Proof.
-intros x y; case x; case y; simpl in |- *; intros;
- [ trivial
- | discriminate H
- | discriminate H
- | discriminate H
- | simplify_eq H; intro E; rewrite E; trivial
- | discriminate H
- | discriminate H
- | discriminate H
- | simplify_eq H; intro E; rewrite E; trivial ].
+  intros x y; case x; case y; simpl in |- *; intros;
+    [ trivial
+      | discriminate H
+      | discriminate H
+      | discriminate H
+      | simplify_eq H; intro E; rewrite E; trivial
+      | discriminate H
+      | discriminate H
+      | discriminate H
+      | simplify_eq H; intro E; rewrite E; trivial ].
 Qed.
 
-(**********************************************************************)
-(* Properties of the direct definition of successor and predecessor *)
+(*************************************************************************)
+(** **  Properties of the direct definition of successor and predecessor *)
 
 Lemma Zpred'_succ' : forall n:Z, Zpred' (Zsucc' n) = n.
 Proof.
-intro x; destruct x; simpl in |- *.
-  reflexivity.
-destruct p; simpl in |- *; try rewrite Pdouble_minus_one_o_succ_eq_xI;
- reflexivity.
-destruct p; simpl in |- *; try rewrite Psucc_o_double_minus_one_eq_xO;
- reflexivity.
+  intro x; destruct x; simpl in |- *.
+    reflexivity.
+  destruct p; simpl in |- *; try rewrite Pdouble_minus_one_o_succ_eq_xI;
+    reflexivity.
+  destruct p; simpl in |- *; try rewrite Psucc_o_double_minus_one_eq_xO;
+    reflexivity.
 Qed.
 
 Lemma Zsucc'_discr : forall n:Z, n <> Zsucc' n.
 Proof.
-intro x; destruct x; simpl in |- *.
+  intro x; destruct x; simpl in |- *.
   discriminate.
   injection; apply Psucc_discr.
   destruct p; simpl in |- *.
@@ -266,506 +272,517 @@ intro x; destruct x; simpl in |- *.
 Qed.
 
 (**********************************************************************)
-(** Other properties of binary integer numbers *)
+(** ** Other properties of binary integer numbers *)
 
 Lemma ZL0 : 2%nat = (1 + 1)%nat.
 Proof.
-reflexivity.
+  reflexivity.
 Qed.
 
 (**********************************************************************)
-(** Properties of the addition on integers *)
+(** * Properties of the addition on integers *)
 
-(** zero is left neutral for addition *)
+(** ** zero is left neutral for addition *)
 
 Theorem Zplus_0_l : forall n:Z, Z0 + n = n.
 Proof.
-intro x; destruct x; reflexivity.
+  intro x; destruct x; reflexivity.
 Qed.
 
-(** zero is right neutral for addition *)
+(** *** zero is right neutral for addition *)
 
 Theorem Zplus_0_r : forall n:Z, n + Z0 = n.
 Proof.
-intro x; destruct x; reflexivity.
+  intro x; destruct x; reflexivity.
 Qed.
 
-(** addition is commutative *)
+(** ** addition is commutative *)
 
 Theorem Zplus_comm : forall n m:Z, n + m = m + n.
 Proof.
-intro x; induction x as [| p| p]; intro y; destruct y as [| q| q];
- simpl in |- *; try reflexivity.
+  intro x; induction x as [| p| p]; intro y; destruct y as [| q| q];
+    simpl in |- *; try reflexivity.
   rewrite Pplus_comm; reflexivity.
   rewrite ZC4; destruct ((q ?= p)%positive Eq); reflexivity.
   rewrite ZC4; destruct ((q ?= p)%positive Eq); reflexivity.
   rewrite Pplus_comm; reflexivity.
 Qed.
 
-(** opposite distributes over addition *)
+(** ** opposite distributes over addition *)
 
 Theorem Zopp_plus_distr : forall n m:Z, - (n + m) = - n + - m.
 Proof.
-intro x; destruct x as [| p| p]; intro y; destruct y as [| q| q];
- simpl in |- *; reflexivity || destruct ((p ?= q)%positive Eq); 
- reflexivity.
+  intro x; destruct x as [| p| p]; intro y; destruct y as [| q| q];
+    simpl in |- *; reflexivity || destruct ((p ?= q)%positive Eq); 
+      reflexivity.
 Qed.
 
-(** opposite is inverse for addition *)
+(** ** opposite is inverse for addition *)
 
 Theorem Zplus_opp_r : forall n:Z, n + - n = Z0.
 Proof.
-intro x; destruct x as [| p| p]; simpl in |- *;
- [ reflexivity
- | rewrite (Pcompare_refl p); reflexivity
- | rewrite (Pcompare_refl p); reflexivity ].
+  intro x; destruct x as [| p| p]; simpl in |- *;
+    [ reflexivity
+      | rewrite (Pcompare_refl p); reflexivity
+      | rewrite (Pcompare_refl p); reflexivity ].
 Qed.
 
 Theorem Zplus_opp_l : forall n:Z, - n + n = Z0.
 Proof.
-intro; rewrite Zplus_comm; apply Zplus_opp_r.
+  intro; rewrite Zplus_comm; apply Zplus_opp_r.
 Qed.
 
 Hint Local Resolve Zplus_0_l Zplus_0_r.
 
-(** addition is associative *)
+(** ** addition is associative *)
 
 Lemma weak_assoc :
- forall (p q:positive) (n:Z), Zpos p + (Zpos q + n) = Zpos p + Zpos q + n.
-Proof.
-intros x y z'; case z';
- [ auto with arith
- | intros z; simpl in |- *; rewrite Pplus_assoc; auto with arith
- | intros z; simpl in |- *; ElimPcompare y z; intros E0; rewrite E0;
-    ElimPcompare (x + y)%positive z; intros E1; rewrite E1;
-    [ absurd ((x + y ?= z)%positive Eq = Eq);
-       [  (* Case 1 *)
-          rewrite nat_of_P_gt_Gt_compare_complement_morphism;
-          [ discriminate
-          | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0);
-             elim (ZL4 x); intros k E2; rewrite E2; 
-             simpl in |- *; unfold gt, lt in |- *; 
-             apply le_n_S; apply le_plus_r ]
-       | assumption ]
-    | absurd ((x + y ?= z)%positive Eq = Lt);
-       [  (* Case 2 *)
-          rewrite nat_of_P_gt_Gt_compare_complement_morphism;
-          [ discriminate
-          | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0);
-             elim (ZL4 x); intros k E2; rewrite E2; 
-             simpl in |- *; unfold gt, lt in |- *; 
-             apply le_n_S; apply le_plus_r ]
-       | assumption ]
-    | rewrite (Pcompare_Eq_eq y z E0);
-        (* Case 3 *)
-       elim (Pminus_mask_Gt (x + z) z);
-       [ intros t H; elim H; intros H1 H2; elim H2; intros H3 H4;
-          unfold Pminus in |- *; rewrite H1; cut (x = t);
-          [ intros E; rewrite E; auto with arith
-          | apply Pplus_reg_r with (r := z); rewrite <- H3;
-             rewrite Pplus_comm; trivial with arith ]
-       | pattern z at 1 in |- *; rewrite <- (Pcompare_Eq_eq y z E0);
-          assumption ]
-    | elim (Pminus_mask_Gt z y);
-       [  (* Case 4 *)
-          intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
-          unfold Pminus at 1 in |- *; rewrite H1; cut (x = k);
-          [ intros E; rewrite E; rewrite (Pcompare_refl k);
-             trivial with arith
-          | apply Pplus_reg_r with (r := y); rewrite (Pplus_comm k y);
-             rewrite H3; apply Pcompare_Eq_eq; assumption ]
-       | apply ZC2; assumption ]
-    | elim (Pminus_mask_Gt z y);
-       [  (* Case 5 *)
-          intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
-          unfold Pminus at 1 3 5 in |- *; rewrite H1;
-          cut ((x ?= k)%positive Eq = Lt);
-          [ intros E2; rewrite E2; elim (Pminus_mask_Gt k x);
-             [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9;
-                elim (Pminus_mask_Gt z (x + y));
-                [ intros j H10; elim H10; intros H11 H12; elim H12;
-                   intros H13 H14; unfold Pminus in |- *; 
-                   rewrite H6; rewrite H11; cut (i = j);
-                   [ intros E; rewrite E; auto with arith
-                   | apply (Pplus_reg_l (x + y)); rewrite H13;
-                      rewrite (Pplus_comm x y); rewrite <- Pplus_assoc;
-                      rewrite H8; assumption ]
-                | apply ZC2; assumption ]
-             | apply ZC2; assumption ]
-          | apply nat_of_P_lt_Lt_compare_complement_morphism;
-             apply plus_lt_reg_l with (p := nat_of_P y);
-             do 2 rewrite <- nat_of_P_plus_morphism;
-             apply nat_of_P_lt_Lt_compare_morphism; 
-             rewrite H3; rewrite Pplus_comm; assumption ]
-       | apply ZC2; assumption ]
-    | elim (Pminus_mask_Gt z y);
-       [  (* Case 6 *)
-          intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
-          elim (Pminus_mask_Gt (x + y) z);
-          [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9;
-             unfold Pminus in |- *; rewrite H1; rewrite H6;
-             cut ((x ?= k)%positive Eq = Gt);
-             [ intros H10; elim (Pminus_mask_Gt x k H10); intros j H11;
-                elim H11; intros H12 H13; elim H13; 
-                intros H14 H15; rewrite H10; rewrite H12; 
-                cut (i = j);
-                [ intros H16; rewrite H16; auto with arith
-                | apply (Pplus_reg_l (z + k)); rewrite <- (Pplus_assoc z k j);
-                   rewrite H14; rewrite (Pplus_comm z k);
-                   rewrite <- Pplus_assoc; rewrite H8;
-                   rewrite (Pplus_comm x y); rewrite Pplus_assoc;
-                   rewrite (Pplus_comm k y); rewrite H3; 
-                   trivial with arith ]
-             | apply nat_of_P_gt_Gt_compare_complement_morphism;
-                unfold lt, gt in |- *;
-                apply plus_lt_reg_l with (p := nat_of_P y);
-                do 2 rewrite <- nat_of_P_plus_morphism;
-                apply nat_of_P_lt_Lt_compare_morphism; 
-                rewrite H3; rewrite Pplus_comm; apply ZC1; 
-                assumption ]
-          | assumption ]
-       | apply ZC2; assumption ]
-    | absurd ((x + y ?= z)%positive Eq = Eq);
-       [  (* Case 7 *)
-          rewrite nat_of_P_gt_Gt_compare_complement_morphism;
-          [ discriminate
-          | rewrite nat_of_P_plus_morphism; unfold gt in |- *;
-             apply lt_le_trans with (m := nat_of_P y);
-             [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
-             | apply le_plus_r ] ]
-       | assumption ]
-    | absurd ((x + y ?= z)%positive Eq = Lt);
-       [  (* Case 8 *)
-          rewrite nat_of_P_gt_Gt_compare_complement_morphism;
-          [ discriminate
-          | unfold gt in |- *; apply lt_le_trans with (m := nat_of_P y);
-             [ exact (nat_of_P_gt_Gt_compare_morphism y z E0)
-             | rewrite nat_of_P_plus_morphism; apply le_plus_r ] ]
-       | assumption ]
-    | elim Pminus_mask_Gt with (1 := E0); intros k H1;
-        (* Case 9 *)
-       elim Pminus_mask_Gt with (1 := E1); intros i H2; 
-       elim H1; intros H3 H4; elim H4; intros H5 H6; 
-       elim H2; intros H7 H8; elim H8; intros H9 H10; 
-       unfold Pminus in |- *; rewrite H3; rewrite H7;
-       cut ((x + k)%positive = i);
-       [ intros E; rewrite E; auto with arith
-       | apply (Pplus_reg_l z); rewrite (Pplus_comm x k); rewrite Pplus_assoc;
-          rewrite H5; rewrite H9; rewrite Pplus_comm; 
-          trivial with arith ] ] ].
+  forall (p q:positive) (n:Z), Zpos p + (Zpos q + n) = Zpos p + Zpos q + n.
+Proof.
+  intros x y z'; case z';
+    [ auto with arith
+      | intros z; simpl in |- *; rewrite Pplus_assoc; auto with arith
+      | intros z; simpl in |- *; ElimPcompare y z; intros E0; rewrite E0;
+	ElimPcompare (x + y)%positive z; intros E1; rewrite E1;
+	  [ absurd ((x + y ?= z)%positive Eq = Eq);
+	    [  (* Case 1 *)
+              rewrite nat_of_P_gt_Gt_compare_complement_morphism;
+		[ discriminate
+		  | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0);
+		    elim (ZL4 x); intros k E2; rewrite E2; 
+		      simpl in |- *; unfold gt, lt in |- *; 
+			apply le_n_S; apply le_plus_r ]
+	      | assumption ]
+	    | absurd ((x + y ?= z)%positive Eq = Lt);
+	      [  (* Case 2 *)
+		rewrite nat_of_P_gt_Gt_compare_complement_morphism;
+		  [ discriminate
+		    | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0);
+		      elim (ZL4 x); intros k E2; rewrite E2; 
+			simpl in |- *; unfold gt, lt in |- *; 
+			  apply le_n_S; apply le_plus_r ]
+		| assumption ]
+	    | rewrite (Pcompare_Eq_eq y z E0);
+          (* Case 3 *)
+	      elim (Pminus_mask_Gt (x + z) z);
+		[ intros t H; elim H; intros H1 H2; elim H2; intros H3 H4;
+		  unfold Pminus in |- *; rewrite H1; cut (x = t);
+		    [ intros E; rewrite E; auto with arith
+		      | apply Pplus_reg_r with (r := z); rewrite <- H3;
+			rewrite Pplus_comm; trivial with arith ]
+		  | pattern z at 1 in |- *; rewrite <- (Pcompare_Eq_eq y z E0);
+		    assumption ]
+	    | elim (Pminus_mask_Gt z y);
+	      [  (* Case 4 *)
+		intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
+		  unfold Pminus at 1 in |- *; rewrite H1; cut (x = k);
+		    [ intros E; rewrite E; rewrite (Pcompare_refl k);
+		      trivial with arith
+		      | apply Pplus_reg_r with (r := y); rewrite (Pplus_comm k y);
+			rewrite H3; apply Pcompare_Eq_eq; assumption ]
+		| apply ZC2; assumption ]
+	    | elim (Pminus_mask_Gt z y);
+	      [  (* Case 5 *)
+		intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
+		  unfold Pminus at 1 3 5 in |- *; rewrite H1;
+		    cut ((x ?= k)%positive Eq = Lt);
+		      [ intros E2; rewrite E2; elim (Pminus_mask_Gt k x);
+			[ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9;
+			  elim (Pminus_mask_Gt z (x + y));
+			    [ intros j H10; elim H10; intros H11 H12; elim H12;
+			      intros H13 H14; unfold Pminus in |- *; 
+				rewrite H6; rewrite H11; cut (i = j);
+				  [ intros E; rewrite E; auto with arith
+				    | apply (Pplus_reg_l (x + y)); rewrite H13;
+				      rewrite (Pplus_comm x y); rewrite <- Pplus_assoc;
+					rewrite H8; assumption ]
+			      | apply ZC2; assumption ]
+			  | apply ZC2; assumption ]
+			| apply nat_of_P_lt_Lt_compare_complement_morphism;
+			  apply plus_lt_reg_l with (p := nat_of_P y);
+			    do 2 rewrite <- nat_of_P_plus_morphism;
+			      apply nat_of_P_lt_Lt_compare_morphism; 
+				rewrite H3; rewrite Pplus_comm; assumption ]
+		| apply ZC2; assumption ]
+	    | elim (Pminus_mask_Gt z y);
+	      [  (* Case 6 *)
+		intros k H; elim H; intros H1 H2; elim H2; intros H3 H4;
+		  elim (Pminus_mask_Gt (x + y) z);
+		    [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9;
+		      unfold Pminus in |- *; rewrite H1; rewrite H6;
+			cut ((x ?= k)%positive Eq = Gt);
+			  [ intros H10; elim (Pminus_mask_Gt x k H10); intros j H11;
+			    elim H11; intros H12 H13; elim H13; 
+			      intros H14 H15; rewrite H10; rewrite H12; 
+				cut (i = j);
+				  [ intros H16; rewrite H16; auto with arith
+				    | apply (Pplus_reg_l (z + k)); rewrite <- (Pplus_assoc z k j);
+				      rewrite H14; rewrite (Pplus_comm z k);
+					rewrite <- Pplus_assoc; rewrite H8;
+					  rewrite (Pplus_comm x y); rewrite Pplus_assoc;
+					    rewrite (Pplus_comm k y); rewrite H3; 
+					      trivial with arith ]
+			    | apply nat_of_P_gt_Gt_compare_complement_morphism;
+			      unfold lt, gt in |- *;
+				apply plus_lt_reg_l with (p := nat_of_P y);
+				  do 2 rewrite <- nat_of_P_plus_morphism;
+				    apply nat_of_P_lt_Lt_compare_morphism; 
+				      rewrite H3; rewrite Pplus_comm; apply ZC1; 
+					assumption ]
+		      | assumption ]
+		| apply ZC2; assumption ]
+	    | absurd ((x + y ?= z)%positive Eq = Eq);
+	      [  (* Case 7 *)
+		rewrite nat_of_P_gt_Gt_compare_complement_morphism;
+		  [ discriminate
+		    | rewrite nat_of_P_plus_morphism; unfold gt in |- *;
+		      apply lt_le_trans with (m := nat_of_P y);
+			[ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
+			  | apply le_plus_r ] ]
+		| assumption ]
+	    | absurd ((x + y ?= z)%positive Eq = Lt);
+	      [  (* Case 8 *)
+		rewrite nat_of_P_gt_Gt_compare_complement_morphism;
+		  [ discriminate
+		    | unfold gt in |- *; apply lt_le_trans with (m := nat_of_P y);
+		      [ exact (nat_of_P_gt_Gt_compare_morphism y z E0)
+			| rewrite nat_of_P_plus_morphism; apply le_plus_r ] ]
+		| assumption ]
+	    | elim Pminus_mask_Gt with (1 := E0); intros k H1;
+          (* Case 9 *)
+	      elim Pminus_mask_Gt with (1 := E1); intros i H2; 
+		elim H1; intros H3 H4; elim H4; intros H5 H6; 
+		  elim H2; intros H7 H8; elim H8; intros H9 H10; 
+		    unfold Pminus in |- *; rewrite H3; rewrite H7;
+		      cut ((x + k)%positive = i);
+			[ intros E; rewrite E; auto with arith
+			  | apply (Pplus_reg_l z); rewrite (Pplus_comm x k); rewrite Pplus_assoc;
+			    rewrite H5; rewrite H9; rewrite Pplus_comm; 
+			      trivial with arith ] ] ].
 Qed.
 
 Hint Local Resolve weak_assoc.
 
 Theorem Zplus_assoc : forall n m p:Z, n + (m + p) = n + m + p.
 Proof.
-intros x y z; case x; case y; case z; auto with arith; intros;
- [ rewrite (Zplus_comm (Zneg p0)); rewrite weak_assoc;
-    rewrite (Zplus_comm (Zpos p1 + Zneg p0)); rewrite weak_assoc;
-    rewrite (Zplus_comm (Zpos p1)); trivial with arith
- | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
-    rewrite Zplus_comm; rewrite <- weak_assoc;
-    rewrite (Zplus_comm (- Zpos p1));
-    rewrite (Zplus_comm (Zpos p0 + - Zpos p1)); rewrite (weak_assoc p);
-    rewrite weak_assoc; rewrite (Zplus_comm (Zpos p0)); 
-    trivial with arith
- | rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0) (Zpos p));
-    rewrite <- weak_assoc; rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0));
-    trivial with arith
- | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
-    rewrite (Zplus_comm (- Zpos p0)); rewrite weak_assoc;
-    rewrite (Zplus_comm (Zpos p1 + - Zpos p0)); rewrite weak_assoc;
-    rewrite (Zplus_comm (Zpos p)); trivial with arith
- | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
-    apply weak_assoc
- | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
-    apply weak_assoc ].
+  intros x y z; case x; case y; case z; auto with arith; intros;
+    [ rewrite (Zplus_comm (Zneg p0)); rewrite weak_assoc;
+      rewrite (Zplus_comm (Zpos p1 + Zneg p0)); rewrite weak_assoc;
+	rewrite (Zplus_comm (Zpos p1)); trivial with arith
+      | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
+	rewrite Zplus_comm; rewrite <- weak_assoc;
+	  rewrite (Zplus_comm (- Zpos p1));
+	    rewrite (Zplus_comm (Zpos p0 + - Zpos p1)); rewrite (weak_assoc p);
+	      rewrite weak_assoc; rewrite (Zplus_comm (Zpos p0)); 
+		trivial with arith
+      | rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0) (Zpos p));
+	rewrite <- weak_assoc; rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0));
+	  trivial with arith
+      | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
+	rewrite (Zplus_comm (- Zpos p0)); rewrite weak_assoc;
+	  rewrite (Zplus_comm (Zpos p1 + - Zpos p0)); rewrite weak_assoc;
+	    rewrite (Zplus_comm (Zpos p)); trivial with arith
+      | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
+	apply weak_assoc
+      | apply Zopp_inj; do 4 rewrite Zopp_plus_distr; do 2 rewrite Zopp_neg;
+	apply weak_assoc ].
 Qed.
 
 
 Lemma Zplus_assoc_reverse : forall n m p:Z, n + m + p = n + (m + p).
 Proof.
-intros; symmetry  in |- *; apply Zplus_assoc.
+  intros; symmetry  in |- *; apply Zplus_assoc.
 Qed.
 
-(** Associativity mixed with commutativity *)
+(** ** Associativity mixed with commutativity *)
 
 Theorem Zplus_permute : forall n m p:Z, n + (m + p) = m + (n + p).
 Proof.
-intros n m p; rewrite Zplus_comm; rewrite <- Zplus_assoc;
- rewrite (Zplus_comm p n); trivial with arith.
+  intros n m p; rewrite Zplus_comm; rewrite <- Zplus_assoc;
+    rewrite (Zplus_comm p n); trivial with arith.
 Qed.
 
-(** addition simplifies *)
+(** ** addition simplifies *)
 
 Theorem Zplus_reg_l : forall n m p:Z, n + m = n + p -> m = p.
-intros n m p H; cut (- n + (n + m) = - n + (n + p));
- [ do 2 rewrite Zplus_assoc; rewrite (Zplus_comm (- n) n);
-    rewrite Zplus_opp_r; simpl in |- *; trivial with arith
- | rewrite H; trivial with arith ].
+  intros n m p H; cut (- n + (n + m) = - n + (n + p));
+    [ do 2 rewrite Zplus_assoc; rewrite (Zplus_comm (- n) n);
+      rewrite Zplus_opp_r; simpl in |- *; trivial with arith
+      | rewrite H; trivial with arith ].
 Qed.
 
-(** addition and successor permutes *)
+(** ** addition and successor permutes *)
 
 Lemma Zplus_succ_l : forall n m:Z, Zsucc n + m = Zsucc (n + m).
 Proof.
-intros x y; unfold Zsucc in |- *; rewrite (Zplus_comm (x + y));
- rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1)); 
- trivial with arith.
+  intros x y; unfold Zsucc in |- *; rewrite (Zplus_comm (x + y));
+    rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1)); 
+      trivial with arith.
 Qed.
 
 Lemma Zplus_succ_r : forall n m:Z, Zsucc (n + m) = n + Zsucc m.
 Proof.
-intros n m; unfold Zsucc in |- *; rewrite Zplus_assoc; trivial with arith.
+  intros n m; unfold Zsucc in |- *; rewrite Zplus_assoc; trivial with arith.
 Qed.
 
 Lemma Zplus_succ_comm : forall n m:Z, Zsucc n + m = n + Zsucc m.
 Proof.
-unfold Zsucc in |- *; intros n m; rewrite <- Zplus_assoc;
- rewrite (Zplus_comm (Zpos 1)); trivial with arith.
+  unfold Zsucc in |- *; intros n m; rewrite <- Zplus_assoc;
+    rewrite (Zplus_comm (Zpos 1)); trivial with arith.
 Qed.
 
-(** Misc properties, usually redundant or non natural *)
+(** ** Misc properties, usually redundant or non natural *)
 
 Lemma Zplus_0_r_reverse : forall n:Z, n = n + Z0.
 Proof.
-symmetry  in |- *; apply Zplus_0_r.
+  symmetry  in |- *; apply Zplus_0_r.
 Qed.
 
 Lemma Zplus_0_simpl_l : forall n m:Z, n + Z0 = m -> n = m.
 Proof.
-intros n m; rewrite Zplus_0_r; intro; assumption.
+  intros n m; rewrite Zplus_0_r; intro; assumption.
 Qed.
 
 Lemma Zplus_0_simpl_l_reverse : forall n m:Z, n = m + Z0 -> n = m.
 Proof.
-intros n m; rewrite Zplus_0_r; intro; assumption.
+  intros n m; rewrite Zplus_0_r; intro; assumption.
 Qed.
 
 Lemma Zplus_eq_compat : forall n m p q:Z, n = m -> p = q -> n + p = m + q.
 Proof.
-intros; rewrite H; rewrite H0; reflexivity.
+  intros; rewrite H; rewrite H0; reflexivity.
 Qed.
 
 Lemma Zplus_opp_expand : forall n m p:Z, n + - m = n + - p + (p + - m).
 Proof.
-intros x y z.
-rewrite <- (Zplus_assoc x).
-rewrite (Zplus_assoc (- z)).
-rewrite Zplus_opp_l.
-reflexivity.
+  intros x y z.
+  rewrite <- (Zplus_assoc x).
+  rewrite (Zplus_assoc (- z)).
+  rewrite Zplus_opp_l.
+  reflexivity.
 Qed.
 
-(**********************************************************************)
-(** Properties of successor and predecessor on binary integer numbers *)
+(************************************************************************)
+(** * Properties of successor and predecessor on binary integer numbers *)
 
 Theorem Zsucc_discr : forall n:Z, n <> Zsucc n.
 Proof.
-intros n; cut (Z0 <> Zpos 1);
- [ unfold not in |- *; intros H1 H2; apply H1; apply (Zplus_reg_l n);
-    rewrite Zplus_0_r; exact H2
- | discriminate ].
+  intros n; cut (Z0 <> Zpos 1);
+    [ unfold not in |- *; intros H1 H2; apply H1; apply (Zplus_reg_l n);
+      rewrite Zplus_0_r; exact H2
+      | discriminate ].
 Qed.
 
 Theorem Zpos_succ_morphism :
- forall p:positive, Zpos (Psucc p) = Zsucc (Zpos p).
+  forall p:positive, Zpos (Psucc p) = Zsucc (Zpos p).
 Proof.
-intro; rewrite Pplus_one_succ_r; unfold Zsucc in |- *; simpl in |- *;
- trivial with arith.
+  intro; rewrite Pplus_one_succ_r; unfold Zsucc in |- *; simpl in |- *;
+    trivial with arith.
 Qed.
 
 (** successor and predecessor are inverse functions *)
 
 Theorem Zsucc_pred : forall n:Z, n = Zsucc (Zpred n).
 Proof.
-intros n; unfold Zsucc, Zpred in |- *; rewrite <- Zplus_assoc; simpl in |- *;
- rewrite Zplus_0_r; trivial with arith.
+  intros n; unfold Zsucc, Zpred in |- *; rewrite <- Zplus_assoc; simpl in |- *;
+    rewrite Zplus_0_r; trivial with arith.
 Qed. 
 
 Hint Immediate Zsucc_pred: zarith.
  
 Theorem Zpred_succ : forall n:Z, n = Zpred (Zsucc n).
 Proof.
-intros m; unfold Zpred, Zsucc in |- *; rewrite <- Zplus_assoc; simpl in |- *;
- rewrite Zplus_comm; auto with arith.
+  intros m; unfold Zpred, Zsucc in |- *; rewrite <- Zplus_assoc; simpl in |- *;
+    rewrite Zplus_comm; auto with arith.
 Qed.
 
 Theorem Zsucc_inj : forall n m:Z, Zsucc n = Zsucc m -> n = m.
 Proof.
-intros n m H.
-change (Zneg 1 + Zpos 1 + n = Zneg 1 + Zpos 1 + m) in |- *;
- do 2 rewrite <- Zplus_assoc; do 2 rewrite (Zplus_comm (Zpos 1));
- unfold Zsucc in H; rewrite H; trivial with arith.
+  intros n m H.
+  change (Zneg 1 + Zpos 1 + n = Zneg 1 + Zpos 1 + m) in |- *;
+    do 2 rewrite <- Zplus_assoc; do 2 rewrite (Zplus_comm (Zpos 1));
+      unfold Zsucc in H; rewrite H; trivial with arith.
 Qed.
  
 (** Misc properties, usually redundant or non natural *)
 
 Lemma Zsucc_eq_compat : forall n m:Z, n = m -> Zsucc n = Zsucc m.
 Proof.
-intros n m H; rewrite H; reflexivity.
+  intros n m H; rewrite H; reflexivity.
 Qed.
 
 Lemma Zsucc_inj_contrapositive : forall n m:Z, n <> m -> Zsucc n <> Zsucc m.
 Proof.
-unfold not in |- *; intros n m H1 H2; apply H1; apply Zsucc_inj; assumption.
+  unfold not in |- *; intros n m H1 H2; apply H1; apply Zsucc_inj; assumption.
 Qed.
 
 (**********************************************************************)
-(** Properties of subtraction on binary integer numbers *)
+(** * Properties of subtraction on binary integer numbers *)
+
+(** ** [minus] and [Z0] *)
 
 Lemma Zminus_0_r : forall n:Z, n - Z0 = n.
 Proof.
-intro; unfold Zminus in |- *; simpl in |- *; rewrite Zplus_0_r;
- trivial with arith.
+  intro; unfold Zminus in |- *; simpl in |- *; rewrite Zplus_0_r;
+    trivial with arith.
 Qed.
 
 Lemma Zminus_0_l_reverse : forall n:Z, n = n - Z0.
 Proof.
-intro; symmetry  in |- *; apply Zminus_0_r.
+  intro; symmetry  in |- *; apply Zminus_0_r.
 Qed.
 
 Lemma Zminus_diag : forall n:Z, n - n = Z0.
 Proof.
-intro; unfold Zminus in |- *; rewrite Zplus_opp_r; trivial with arith.
+  intro; unfold Zminus in |- *; rewrite Zplus_opp_r; trivial with arith.
 Qed.
 
 Lemma Zminus_diag_reverse : forall n:Z, Z0 = n - n.
 Proof.
-intro; symmetry  in |- *; apply Zminus_diag.
+  intro; symmetry  in |- *; apply Zminus_diag.
 Qed.
 
+
+(** ** Relating [minus] with [plus] and [Zsucc] *)
+
 Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m.
 Proof.
-intros n m p H; unfold Zminus in |- *; apply (Zplus_reg_l m);
- rewrite (Zplus_comm m (n + - m)); rewrite <- Zplus_assoc;
- rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H; 
- trivial with arith.
+  intros n m p H; unfold Zminus in |- *; apply (Zplus_reg_l m);
+    rewrite (Zplus_comm m (n + - m)); rewrite <- Zplus_assoc;
+      rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H; 
+	trivial with arith.
 Qed.
 
 Lemma Zminus_plus : forall n m:Z, n + m - n = m.
 Proof.
-intros n m; unfold Zminus in |- *; rewrite (Zplus_comm n m);
- rewrite <- Zplus_assoc; rewrite Zplus_opp_r; apply Zplus_0_r.
+  intros n m; unfold Zminus in |- *; rewrite (Zplus_comm n m);
+    rewrite <- Zplus_assoc; rewrite Zplus_opp_r; apply Zplus_0_r.
 Qed.
 
 Lemma Zplus_minus : forall n m:Z, n + (m - n) = m.
 Proof.
-unfold Zminus in |- *; intros n m; rewrite Zplus_permute; rewrite Zplus_opp_r;
- apply Zplus_0_r.
+  unfold Zminus in |- *; intros n m; rewrite Zplus_permute; rewrite Zplus_opp_r;
+    apply Zplus_0_r.
 Qed.
 
 Lemma Zminus_succ_l : forall n m:Z, Zsucc (n - m) = Zsucc n - m.
 Proof.
-intros n m; unfold Zminus, Zsucc in |- *; rewrite (Zplus_comm n (- m));
- rewrite <- Zplus_assoc; apply Zplus_comm.
+  intros n m; unfold Zminus, Zsucc in |- *; rewrite (Zplus_comm n (- m));
+    rewrite <- Zplus_assoc; apply Zplus_comm.
 Qed.
 
 Lemma Zminus_plus_simpl_l : forall n m p:Z, p + n - (p + m) = n - m.
 Proof.
-intros n m p; unfold Zminus in |- *; rewrite Zopp_plus_distr;
- rewrite Zplus_assoc; rewrite (Zplus_comm p); rewrite <- (Zplus_assoc n p);
- rewrite Zplus_opp_r; rewrite Zplus_0_r; trivial with arith.
+  intros n m p; unfold Zminus in |- *; rewrite Zopp_plus_distr;
+    rewrite Zplus_assoc; rewrite (Zplus_comm p); rewrite <- (Zplus_assoc n p);
+      rewrite Zplus_opp_r; rewrite Zplus_0_r; trivial with arith.
 Qed.
 
 Lemma Zminus_plus_simpl_l_reverse : forall n m p:Z, n - m = p + n - (p + m).
 Proof.
-intros; symmetry  in |- *; apply Zminus_plus_simpl_l.
+  intros; symmetry  in |- *; apply Zminus_plus_simpl_l.
 Qed.
 
 Lemma Zminus_plus_simpl_r : forall n m p:Z, n + p - (m + p) = n - m.
-intros x y n.
-unfold Zminus in |- *.
-rewrite Zopp_plus_distr.
-rewrite (Zplus_comm (- y) (- n)).
-rewrite Zplus_assoc.
-rewrite <- (Zplus_assoc x n (- n)).
-rewrite (Zplus_opp_r n).
-rewrite <- Zplus_0_r_reverse.
-reflexivity.
+Proof.
+  intros x y n.
+  unfold Zminus in |- *.
+  rewrite Zopp_plus_distr.
+  rewrite (Zplus_comm (- y) (- n)).
+  rewrite Zplus_assoc.
+  rewrite <- (Zplus_assoc x n (- n)).
+  rewrite (Zplus_opp_r n).
+  rewrite <- Zplus_0_r_reverse.
+  reflexivity.
 Qed.
 
-(** Misc redundant properties *)
-
+(** ** Misc redundant properties *)
 
 Lemma Zeq_minus : forall n m:Z, n = m -> n - m = Z0.
 Proof.
-intros x y H; rewrite H; symmetry  in |- *; apply Zminus_diag_reverse.
+  intros x y H; rewrite H; symmetry  in |- *; apply Zminus_diag_reverse.
 Qed.
 
 Lemma Zminus_eq : forall n m:Z, n - m = Z0 -> n = m.
 Proof.
-intros x y H; rewrite <- (Zplus_minus y x); rewrite H; apply Zplus_0_r.
+  intros x y H; rewrite <- (Zplus_minus y x); rewrite H; apply Zplus_0_r.
 Qed.
 
 
 (**********************************************************************)
-(** Properties of multiplication on binary integer numbers *)
+(** * Properties of multiplication on binary integer numbers *)
 
-(** One is neutral for multiplication *)
+Theorem Zpos_mult_morphism : 
+  forall p q:positive, Zpos (p*q) = Zpos p * Zpos q.
+Proof.
+  auto.
+Qed.
+
+(** ** One is neutral for multiplication *)
 
 Theorem Zmult_1_l : forall n:Z, Zpos 1 * n = n.
 Proof.
-intro x; destruct x; reflexivity.
+  intro x; destruct x; reflexivity.
 Qed.
 
 Theorem Zmult_1_r : forall n:Z, n * Zpos 1 = n.
 Proof.
-intro x; destruct x; simpl in |- *; try rewrite Pmult_1_r; reflexivity.
+  intro x; destruct x; simpl in |- *; try rewrite Pmult_1_r; reflexivity.
 Qed.
 
-(** Zero property of multiplication *)
+(** ** Zero property of multiplication *)
 
 Theorem Zmult_0_l : forall n:Z, Z0 * n = Z0.
 Proof.
-intro x; destruct x; reflexivity.
+  intro x; destruct x; reflexivity.
 Qed.
 
 Theorem Zmult_0_r : forall n:Z, n * Z0 = Z0.
 Proof.
-intro x; destruct x; reflexivity.
+  intro x; destruct x; reflexivity.
 Qed.
 
 Hint Local Resolve Zmult_0_l Zmult_0_r.
 
 Lemma Zmult_0_r_reverse : forall n:Z, Z0 = n * Z0.
 Proof.
-intro x; destruct x; reflexivity.
+  intro x; destruct x; reflexivity.
 Qed.
 
-(** Commutativity of multiplication *)
+(** ** Commutativity of multiplication *)
 
 Theorem Zmult_comm : forall n m:Z, n * m = m * n.
 Proof.
-intros x y; destruct x as [| p| p]; destruct y as [| q| q]; simpl in |- *;
- try rewrite (Pmult_comm p q); reflexivity.
+  intros x y; destruct x as [| p| p]; destruct y as [| q| q]; simpl in |- *;
+    try rewrite (Pmult_comm p q); reflexivity.
 Qed.
 
-(** Associativity of multiplication *)
+(** ** Associativity of multiplication *)
 
 Theorem Zmult_assoc : forall n m p:Z, n * (m * p) = n * m * p.
 Proof.
-intros x y z; destruct x; destruct y; destruct z; simpl in |- *;
- try rewrite Pmult_assoc; reflexivity.
+  intros x y z; destruct x; destruct y; destruct z; simpl in |- *;
+    try rewrite Pmult_assoc; reflexivity.
 Qed.
 
 Lemma Zmult_assoc_reverse : forall n m p:Z, n * m * p = n * (m * p).
 Proof.
-intros n m p; rewrite Zmult_assoc; trivial with arith.
+  intros n m p; rewrite Zmult_assoc; trivial with arith.
 Qed.
 
-(** Associativity mixed with commutativity *)
+(** ** Associativity mixed with commutativity *)
 
 Theorem Zmult_permute : forall n m p:Z, n * (m * p) = m * (n * p).
 Proof.
-intros x y z; rewrite (Zmult_assoc y x z); rewrite (Zmult_comm y x).
-apply Zmult_assoc.
+  intros x y z; rewrite (Zmult_assoc y x z); rewrite (Zmult_comm y x).
+  apply Zmult_assoc.
 Qed.
 
-(** Z is integral *)
+(** ** Z is integral *)
 
 Theorem Zmult_integral_l : forall n m:Z, n <> Z0 -> m * n = Z0 -> m = Z0.
 Proof.
-intros x y; destruct x as [| p| p].
+  intros x y; destruct x as [| p| p].
   intro H; absurd (Z0 = Z0); trivial.
   intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
   intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
@@ -774,212 +791,220 @@ Qed.
 
 Theorem Zmult_integral : forall n m:Z, n * m = Z0 -> n = Z0 \/ m = Z0.
 Proof.
-intros x y; destruct x; destruct y; auto; simpl in |- *; intro H;
- discriminate H.
+  intros x y; destruct x; destruct y; auto; simpl in |- *; intro H;
+    discriminate H.
 Qed.
 
 
 Lemma Zmult_1_inversion_l :
- forall n m:Z, n * m = Zpos 1 -> n = Zpos 1 \/ n = Zneg 1.
+  forall n m:Z, n * m = Zpos 1 -> n = Zpos 1 \/ n = Zneg 1.
 Proof.
-intros x y; destruct x as [| p| p]; intro; [ discriminate | left | right ];
- (destruct y as [| q| q]; try discriminate; simpl in H; injection H; clear H;
-   intro H; rewrite Pmult_1_inversion_l with (1 := H); 
-   reflexivity).
+  intros x y; destruct x as [| p| p]; intro; [ discriminate | left | right ];
+    (destruct y as [| q| q]; try discriminate; simpl in H; injection H; clear H;
+      intro H; rewrite Pmult_1_inversion_l with (1 := H); 
+	reflexivity).
 Qed.
 
-(** Multiplication and Opposite *)
+(** ** Multiplication and Opposite *)
 
 Theorem Zopp_mult_distr_l : forall n m:Z, - (n * m) = - n * m.
 Proof.
-intros x y; destruct x; destruct y; reflexivity.
+  intros x y; destruct x; destruct y; reflexivity.
 Qed.
 
 Theorem Zopp_mult_distr_r : forall n m:Z, - (n * m) = n * - m.
-intros x y; rewrite (Zmult_comm x y); rewrite Zopp_mult_distr_l;
- apply Zmult_comm.
+Proof.
+  intros x y; rewrite (Zmult_comm x y); rewrite Zopp_mult_distr_l;
+    apply Zmult_comm.
 Qed.
 
 Lemma Zopp_mult_distr_l_reverse : forall n m:Z, - n * m = - (n * m).
 Proof.
-intros x y; symmetry  in |- *; apply Zopp_mult_distr_l.
+  intros x y; symmetry  in |- *; apply Zopp_mult_distr_l.
 Qed.
 
 Theorem Zmult_opp_comm : forall n m:Z, - n * m = n * - m.
-intros x y; rewrite Zopp_mult_distr_l_reverse; rewrite Zopp_mult_distr_r;
- trivial with arith.
+Proof.
+  intros x y; rewrite Zopp_mult_distr_l_reverse; rewrite Zopp_mult_distr_r;
+    trivial with arith.
 Qed.
 
 Theorem Zmult_opp_opp : forall n m:Z, - n * - m = n * m.
 Proof.
-intros x y; destruct x; destruct y; reflexivity.
+  intros x y; destruct x; destruct y; reflexivity.
 Qed.
 
 Theorem Zopp_eq_mult_neg_1 : forall n:Z, - n = n * Zneg 1.
-intro x; induction x; intros; rewrite Zmult_comm; auto with arith.
+Proof.
+  intro x; induction x; intros; rewrite Zmult_comm; auto with arith.
 Qed.
 
-(** Distributivity of multiplication over addition *)
+(** ** Distributivity of multiplication over addition *)
 
 Lemma weak_Zmult_plus_distr_r :
- forall (p:positive) (n m:Z), Zpos p * (n + m) = Zpos p * n + Zpos p * m.
-Proof.
-intros x y' z'; case y'; case z'; auto with arith; intros y z;
- (simpl in |- *; rewrite Pmult_plus_distr_l; trivial with arith) ||
-   (simpl in |- *; ElimPcompare z y; intros E0; rewrite E0;
-     [ rewrite (Pcompare_Eq_eq z y E0); rewrite (Pcompare_refl (x * y));
-        trivial with arith
-     | cut ((x * z ?= x * y)%positive Eq = Lt);
-        [ intros E; rewrite E; rewrite Pmult_minus_distr_l;
-           [ trivial with arith | apply ZC2; assumption ]
-        | apply nat_of_P_lt_Lt_compare_complement_morphism;
-           do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); 
-           intros h H1; rewrite H1; apply mult_S_lt_compat_l;
-           exact (nat_of_P_lt_Lt_compare_morphism z y E0) ]
-     | cut ((x * z ?= x * y)%positive Eq = Gt);
-        [ intros E; rewrite E; rewrite Pmult_minus_distr_l; auto with arith
-        | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *;
-           do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); 
-           intros h H1; rewrite H1; apply mult_S_lt_compat_l;
-           exact (nat_of_P_gt_Gt_compare_morphism z y E0) ] ]).
+  forall (p:positive) (n m:Z), Zpos p * (n + m) = Zpos p * n + Zpos p * m.
+Proof.
+  intros x y' z'; case y'; case z'; auto with arith; intros y z;
+    (simpl in |- *; rewrite Pmult_plus_distr_l; trivial with arith) ||
+      (simpl in |- *; ElimPcompare z y; intros E0; rewrite E0;
+	[ rewrite (Pcompare_Eq_eq z y E0); rewrite (Pcompare_refl (x * y));
+          trivial with arith
+	  | cut ((x * z ?= x * y)%positive Eq = Lt);
+            [ intros E; rewrite E; rewrite Pmult_minus_distr_l;
+              [ trivial with arith | apply ZC2; assumption ]
+              | apply nat_of_P_lt_Lt_compare_complement_morphism;
+		do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); 
+		  intros h H1; rewrite H1; apply mult_S_lt_compat_l;
+		    exact (nat_of_P_lt_Lt_compare_morphism z y E0) ]
+	  | cut ((x * z ?= x * y)%positive Eq = Gt);
+            [ intros E; rewrite E; rewrite Pmult_minus_distr_l; auto with arith
+              | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *;
+		do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); 
+		  intros h H1; rewrite H1; apply mult_S_lt_compat_l;
+		    exact (nat_of_P_gt_Gt_compare_morphism z y E0) ] ]).
 Qed.
 
 Theorem Zmult_plus_distr_r : forall n m p:Z, n * (m + p) = n * m + n * p.
 Proof.
-intros x y z; case x;
- [ auto with arith
- | intros x'; apply weak_Zmult_plus_distr_r
- | intros p; apply Zopp_inj; rewrite Zopp_plus_distr;
-    do 3 rewrite <- Zopp_mult_distr_l_reverse; rewrite Zopp_neg;
-    apply weak_Zmult_plus_distr_r ].
+  intros x y z; case x;
+    [ auto with arith
+      | intros x'; apply weak_Zmult_plus_distr_r
+      | intros p; apply Zopp_inj; rewrite Zopp_plus_distr;
+	do 3 rewrite <- Zopp_mult_distr_l_reverse; rewrite Zopp_neg;
+	  apply weak_Zmult_plus_distr_r ].
 Qed.
 
 Theorem Zmult_plus_distr_l : forall n m p:Z, (n + m) * p = n * p + m * p.
 Proof.
-intros n m p; rewrite Zmult_comm; rewrite Zmult_plus_distr_r;
- do 2 rewrite (Zmult_comm p); trivial with arith.
+  intros n m p; rewrite Zmult_comm; rewrite Zmult_plus_distr_r;
+    do 2 rewrite (Zmult_comm p); trivial with arith.
 Qed.
 
-(** Distributivity of multiplication over subtraction *)
+(** ** Distributivity of multiplication over subtraction *)
 
 Lemma Zmult_minus_distr_r : forall n m p:Z, (n - m) * p = n * p - m * p.
 Proof.
-intros x y z; unfold Zminus in |- *.
-rewrite <- Zopp_mult_distr_l_reverse.
-apply Zmult_plus_distr_l.
+  intros x y z; unfold Zminus in |- *.
+  rewrite <- Zopp_mult_distr_l_reverse.
+  apply Zmult_plus_distr_l.
 Qed.
 
  
 Lemma Zmult_minus_distr_l : forall n m p:Z, p * (n - m) = p * n - p * m.
 Proof.
-intros x y z; rewrite (Zmult_comm z (x - y)).
-rewrite (Zmult_comm z x).
-rewrite (Zmult_comm z y).
-apply Zmult_minus_distr_r.
+  intros x y z; rewrite (Zmult_comm z (x - y)).
+  rewrite (Zmult_comm z x).
+  rewrite (Zmult_comm z y).
+  apply Zmult_minus_distr_r.
 Qed.
 
-(** Simplification of multiplication for non-zero integers *)
+(** ** Simplification of multiplication for non-zero integers *)
 
 Lemma Zmult_reg_l : forall n m p:Z, p <> Z0 -> p * n = p * m -> n = m.
 Proof.
-intros x y z H H0.
-generalize (Zeq_minus _ _ H0).
-intro.
-apply Zminus_eq.
-rewrite <- Zmult_minus_distr_l in H1.
-clear H0; destruct (Zmult_integral _ _ H1).
-contradiction.
-trivial.
+  intros x y z H H0.
+  generalize (Zeq_minus _ _ H0).
+  intro.
+  apply Zminus_eq.
+  rewrite <- Zmult_minus_distr_l in H1.
+  clear H0; destruct (Zmult_integral _ _ H1).
+  contradiction.
+  trivial.
 Qed.
 
 Lemma Zmult_reg_r : forall n m p:Z, p <> Z0 -> n * p = m * p -> n = m.
 Proof.
-intros x y z Hz.
-rewrite (Zmult_comm x z).
-rewrite (Zmult_comm y z).
-intro; apply Zmult_reg_l with z; assumption.
+  intros x y z Hz.
+  rewrite (Zmult_comm x z).
+  rewrite (Zmult_comm y z).
+  intro; apply Zmult_reg_l with z; assumption.
 Qed.
 
-(** Addition and multiplication by 2 *)
+(** ** Addition and multiplication by 2 *)
 
 Lemma Zplus_diag_eq_mult_2 : forall n:Z, n + n = n * Zpos 2.
 Proof.
-intros x; pattern x at 1 2 in |- *; rewrite <- (Zmult_1_r x);
- rewrite <- Zmult_plus_distr_r; reflexivity.
+  intros x; pattern x at 1 2 in |- *; rewrite <- (Zmult_1_r x);
+    rewrite <- Zmult_plus_distr_r; reflexivity.
 Qed.
 
-(** Multiplication and successor *)
+(** ** Multiplication and successor *)
 
 Lemma Zmult_succ_r : forall n m:Z, n * Zsucc m = n * m + n.
 Proof.
-intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_r;
- rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l; 
- trivial with arith.
+  intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_r;
+    rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l; 
+      trivial with arith.
 Qed.
 
 Lemma Zmult_succ_r_reverse : forall n m:Z, n * m + n = n * Zsucc m.
 Proof.
-intros; symmetry  in |- *; apply Zmult_succ_r.
+  intros; symmetry  in |- *; apply Zmult_succ_r.
 Qed.
 
 Lemma Zmult_succ_l : forall n m:Z, Zsucc n * m = n * m + m.
 Proof.
-intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_l;
- rewrite Zmult_1_l; trivial with arith.
+  intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_l;
+    rewrite Zmult_1_l; trivial with arith.
 Qed.
 
 Lemma Zmult_succ_l_reverse : forall n m:Z, n * m + m = Zsucc n * m.
 Proof.
-intros; symmetry  in |- *; apply Zmult_succ_l.
+  intros; symmetry  in |- *; apply Zmult_succ_l.
 Qed.
 
-(** Misc redundant properties *)
+
+
+(** ** Misc redundant properties *)
 
 Lemma Z_eq_mult : forall n m:Z, m = Z0 -> m * n = Z0.
-intros x y H; rewrite H; auto with arith.
+Proof.
+  intros x y H; rewrite H; auto with arith.
 Qed.
 
+
+
 (**********************************************************************)
-(** Relating binary positive numbers and binary integers *)
+(** * Relating binary positive numbers and binary integers *)
 
 Lemma Zpos_xI : forall p:positive, Zpos (xI p) = Zpos 2 * Zpos p + Zpos 1.
 Proof.
-intro; apply refl_equal.
+  intro; apply refl_equal.
 Qed.
 
 Lemma Zpos_xO : forall p:positive, Zpos (xO p) = Zpos 2 * Zpos p.
 Proof.
-intro; apply refl_equal.
+  intro; apply refl_equal.
 Qed.
 
 Lemma Zneg_xI : forall p:positive, Zneg (xI p) = Zpos 2 * Zneg p - Zpos 1.
 Proof.
-intro; apply refl_equal.
+  intro; apply refl_equal.
 Qed.
 
 Lemma Zneg_xO : forall p:positive, Zneg (xO p) = Zpos 2 * Zneg p.
 Proof.
-reflexivity.
+  reflexivity.
 Qed.
 
 Lemma Zpos_plus_distr : forall p q:positive, Zpos (p + q) = Zpos p + Zpos q.
 Proof.
-intros p p'; destruct p;
- [ destruct p' as [p0| p0| ]
- | destruct p' as [p0| p0| ]
- | destruct p' as [p| p| ] ]; reflexivity.
+  intros p p'; destruct p;
+    [ destruct p' as [p0| p0| ]
+      | destruct p' as [p0| p0| ]
+      | destruct p' as [p| p| ] ]; reflexivity.
 Qed.
 
 Lemma Zneg_plus_distr : forall p q:positive, Zneg (p + q) = Zneg p + Zneg q.
 Proof.
-intros p p'; destruct p;
- [ destruct p' as [p0| p0| ]
- | destruct p' as [p0| p0| ]
- | destruct p' as [p| p| ] ]; reflexivity.
+  intros p p'; destruct p;
+    [ destruct p' as [p0| p0| ]
+      | destruct p' as [p0| p0| ]
+      | destruct p' as [p| p| ] ]; reflexivity.
 Qed.
 
 (**********************************************************************)
-(** Order relations *)
+(** * Order relations *)
 
 Definition Zlt (x y:Z) := (x ?= y) = Lt.
 Definition Zgt (x y:Z) := (x ?= y) = Gt.
@@ -998,41 +1023,41 @@ Notation "x < y < z" := (x < y /\ y < z) : Z_scope.
 Notation "x < y <= z" := (x < y /\ y <= z) : Z_scope.
 
 (**********************************************************************)
-(** Absolute value on integers *)
+(** * Absolute value on integers *)
 
 Definition Zabs_nat (x:Z) : nat :=
   match x with
-  | Z0 => 0%nat
-  | Zpos p => nat_of_P p
-  | Zneg p => nat_of_P p
+    | Z0 => 0%nat
+    | Zpos p => nat_of_P p
+    | Zneg p => nat_of_P p
   end.
 
 Definition Zabs (z:Z) : Z :=
   match z with
-  | Z0 => Z0
-  | Zpos p => Zpos p
-  | Zneg p => Zpos p
+    | Z0 => Z0
+    | Zpos p => Zpos p
+    | Zneg p => Zpos p
   end.
 
 (**********************************************************************)
-(** From [nat] to [Z] *)
+(** * From [nat] to [Z] *)
 
 Definition Z_of_nat (x:nat) :=
   match x with
-  | O => Z0
-  | S y => Zpos (P_of_succ_nat y)
+    | O => Z0
+    | S y => Zpos (P_of_succ_nat y)
   end.
 
 Require Import BinNat.
 
 Definition Zabs_N (z:Z) :=
   match z with
-  | Z0 => 0%N
-  | Zpos p => Npos p
-  | Zneg p => Npos p
+    | Z0 => 0%N
+    | Zpos p => Npos p
+    | Zneg p => Npos p
   end.
 
 Definition Z_of_N (x:N) := match x with
-                           | N0 => Z0
-                           | Npos p => Zpos p
-                           end.
\ No newline at end of file
+                             | N0 => Z0
+                             | Npos p => Zpos p
+                           end.
diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v
new file mode 100644
index 00000000..3cee9190
--- /dev/null
+++ b/theories/ZArith/Int.v
@@ -0,0 +1,430 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.  
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre 
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id: Int.v 9319 2006-10-30 12:41:21Z barras $ *)
+
+(** An axiomatization of integers. *) 
+
+(** We define a signature for an integer datatype based on [Z]. 
+    The goal is to allow a switch after extraction to ocaml's 
+    [big_int] or even [int] when finiteness isn't a problem 
+    (typically : when mesuring the height of an AVL tree). 
+*)
+
+Require Import ZArith. 
+Require Import ROmega. 
+Delimit Scope Int_scope with I.
+
+
+(** * a specification of integers *)
+
+Module Type Int.
+
+  Open Scope Int_scope.
+  
+  Parameter int : Set. 
+  
+  Parameter i2z : int -> Z.
+  Arguments Scope i2z [ Int_scope ].
+  
+  Parameter _0 : int. 
+  Parameter _1 : int. 
+  Parameter _2 : int. 
+  Parameter _3 : int.
+  Parameter plus : int -> int -> int. 
+  Parameter opp : int -> int.
+  Parameter minus : int -> int -> int. 
+  Parameter mult : int -> int -> int.
+  Parameter max : int -> int -> int. 
+ 
+  Notation "0" := _0 : Int_scope.
+  Notation "1" := _1 : Int_scope. 
+  Notation "2" := _2 : Int_scope. 
+  Notation "3" := _3 : Int_scope.
+  Infix "+" := plus : Int_scope.
+  Infix "-" := minus : Int_scope.
+  Infix "*" := mult : Int_scope.
+  Notation "- x" := (opp x) : Int_scope.
+
+  (** For logical relations, we can rely on their counterparts in Z, 
+      since they don't appear after extraction. Moreover, using tactics 
+      like omega is easier this way. *)
+
+  Notation "x == y" := (i2z x = i2z y)
+    (at level 70, y at next level, no associativity) : Int_scope.
+  Notation "x <= y" := (Zle (i2z x) (i2z y)): Int_scope.
+  Notation "x < y" := (Zlt (i2z x) (i2z y)) : Int_scope.
+  Notation "x >= y" := (Zge (i2z x) (i2z y)) : Int_scope.
+  Notation "x > y" := (Zgt (i2z x) (i2z y)): Int_scope.
+  Notation "x <= y <= z" := (x <= y /\ y <= z) : Int_scope.
+  Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope.
+  Notation "x < y < z" := (x < y /\ y < z) : Int_scope.
+  Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope.
+  
+  (** Some decidability fonctions (informative). *)
+  
+  Axiom gt_le_dec : forall x y: int, {x > y} + {x <= y}.
+  Axiom ge_lt_dec :  forall x y : int, {x >= y} + {x < y}.
+  Axiom eq_dec : forall x y : int, { x == y } + {~ x==y }.
+
+  (** Specifications *)
+
+  (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality 
+      [==] and the generic [=] are in fact equivalent. We define [==] 
+      nonetheless since the translation to [Z] for using automatic tactic is easier. *)
+
+  Axiom i2z_eq : forall n p : int, n == p -> n = p. 
+  
+   (** Then, we express the specifications of the above parameters using their 
+       Z counterparts. *)
+
+  Open Scope Z_scope.
+  Axiom i2z_0 : i2z _0 = 0.
+  Axiom i2z_1 : i2z _1 = 1.
+  Axiom i2z_2 : i2z _2 = 2.
+  Axiom i2z_3 : i2z _3 = 3.
+  Axiom i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.
+  Axiom i2z_opp : forall n, i2z (-n) = -i2z n.
+  Axiom i2z_minus : forall n p, i2z (n - p) = i2z n - i2z p.
+  Axiom i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p.
+  Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p).
+
+End Int. 
+
+
+(** * Facts and  tactics using [Int] *)
+
+Module MoreInt (I:Int).
+  Import I.
+  
+  Open Scope Int_scope.
+
+  (** A magic (but costly) tactic that goes from [int] back to the [Z] 
+      friendly world ... *)
+
+  Hint Rewrite -> 
+    i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z.
+
+  Ltac i2z := match goal with 
+		| H : (eq (A:=int) ?a ?b) |- _ => 
+		  generalize (f_equal i2z H); 
+		    try autorewrite with i2z; clear H; intro H; i2z
+		| |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); try autorewrite with i2z; i2z
+		| H : _ |- _ => progress autorewrite with i2z in H; i2z
+		| _ => try autorewrite with i2z
+	      end.
+
+  (** A reflexive version of the [i2z] tactic *)
+
+  (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a 
+      [i2z] is buried deep inside a subterm, [i2z_refl] may miss it. 
+      See also the limitation about [Set] or [Type] part below. 
+      Anyhow, [i2z_refl] is enough for applying [romega]. *)
+ 
+  Ltac i2z_gen := match goal with 
+    | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); i2z_gen
+    | H : (eq (A:=int) ?a ?b) |- _ => 
+       generalize (f_equal i2z H); clear H; i2z_gen
+    | H : (eq (A:=Z) ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : (Zlt ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : (Zle ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : (Zgt ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : (Zge ?a ?b) |- _ => generalize H; clear H; i2z_gen
+    | H : _ -> ?X |- _ => 
+      (* A [Set] or [Type] part cannot be dealt with easily
+         using the [ExprP] datatype. So we forget it, leaving 
+         a goal that can be weaker than the original. *)
+      match type of X with 
+       | Type => clear H; i2z_gen
+       | Prop => generalize H; clear H; i2z_gen
+      end
+    | H : _ <-> _ |- _ => generalize H; clear H; i2z_gen
+    | H : _ /\ _ |- _ => generalize H; clear H; i2z_gen
+    | H : _ \/ _ |- _ => generalize H; clear H; i2z_gen
+    | H : ~ _ |- _ => generalize H; clear H; i2z_gen
+    | _ => idtac
+   end.
+
+  Inductive ExprI : Set := 
+    | EI0 : ExprI
+    | EI1 : ExprI
+    | EI2 : ExprI 
+    | EI3 : ExprI
+    | EIplus : ExprI -> ExprI -> ExprI
+    | EIopp : ExprI -> ExprI
+    | EIminus : ExprI -> ExprI -> ExprI
+    | EImult : ExprI -> ExprI -> ExprI
+    | EImax : ExprI -> ExprI -> ExprI
+    | EIraw : int -> ExprI.
+
+  Inductive ExprZ : Set :=  
+    | EZplus : ExprZ -> ExprZ -> ExprZ
+    | EZopp : ExprZ -> ExprZ
+    | EZminus : ExprZ -> ExprZ -> ExprZ
+    | EZmult : ExprZ -> ExprZ -> ExprZ
+    | EZmax : ExprZ -> ExprZ -> ExprZ
+    | EZofI : ExprI -> ExprZ
+    | EZraw : Z -> ExprZ.
+
+  Inductive ExprP : Type := 
+    | EPeq : ExprZ -> ExprZ -> ExprP 
+    | EPlt : ExprZ -> ExprZ -> ExprP 
+    | EPle : ExprZ -> ExprZ -> ExprP 
+    | EPgt : ExprZ -> ExprZ -> ExprP 
+    | EPge : ExprZ -> ExprZ -> ExprP 
+    | EPimpl : ExprP -> ExprP -> ExprP
+    | EPequiv : ExprP -> ExprP -> ExprP
+    | EPand : ExprP -> ExprP -> ExprP
+    | EPor : ExprP -> ExprP -> ExprP
+    | EPneg : ExprP -> ExprP
+    | EPraw : Prop -> ExprP.
+
+  (** [int] to [ExprI] *)
+
+  Ltac i2ei trm := 
+    match constr:trm with 
+      | 0 => constr:EI0
+      | 1 => constr:EI1
+      | 2 => constr:EI2
+      | 3 => constr:EI3
+      | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIplus ex ey)
+      | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIminus ex ey)
+      | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImult ex ey)
+      | max ?x ?y => let ex := i2ei x with ey := i2ei y in constr:(EImax ex ey)
+      | - ?x => let ex := i2ei x in constr:(EIopp ex)
+      | ?x => constr:(EIraw x)
+    end
+
+  (** [Z] to [ExprZ] *)
+
+    with z2ez trm := 
+    match constr:trm with 
+      | (?x+?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
+      | (?x-?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
+      | (?x*?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
+      | (Zmax ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
+      | (-?x)%Z =>  let ex := z2ez x in constr:(EZopp ex)
+      | i2z ?x => let ex := i2ei x in constr:(EZofI ex)
+      | ?x => constr:(EZraw x)
+    end.
+
+  (** [Prop] to [ExprP] *)
+  
+  Ltac p2ep trm :=
+    match constr:trm with
+      | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey)
+      | (?x -> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPimpl ex ey)
+      | (?x /\ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPand ex ey)
+      | (?x \/ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPor ex ey)
+      | (~ ?x) => let ex := p2ep x in constr:(EPneg ex)
+      | (eq (A:=Z) ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EPeq ex ey)
+      | (?x<?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey)
+      | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey)   
+      | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey)   
+      | (?x>=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey)
+      | ?x =>  constr:(EPraw x)
+    end.   
+
+  (** [ExprI] to [int] *)
+
+  Fixpoint ei2i (e:ExprI) : int :=
+    match e with
+      | EI0 => 0
+      | EI1 => 1
+      | EI2 => 2
+      | EI3 => 3 
+      | EIplus e1 e2 => (ei2i e1)+(ei2i e2)
+      | EIminus e1 e2 => (ei2i e1)-(ei2i e2)
+      | EImult e1 e2 => (ei2i e1)*(ei2i e2)
+      | EImax e1 e2 => max (ei2i e1) (ei2i e2)
+      | EIopp e => -(ei2i e)
+      | EIraw i => i 
+    end. 
+
+  (** [ExprZ] to [Z] *)
+
+  Fixpoint ez2z (e:ExprZ) : Z := 
+    match e with 
+      | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z
+      | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z
+      | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z
+      | EZmax e1 e2 => Zmax (ez2z e1) (ez2z e2)
+      | EZopp e => (-(ez2z e))%Z
+      | EZofI e => i2z (ei2i e)
+      | EZraw z => z
+    end.
+
+  (** [ExprP] to [Prop] *)
+
+  Fixpoint ep2p (e:ExprP) : Prop := 
+    match e with 
+      | EPeq e1 e2 => (ez2z e1) = (ez2z e2)
+      | EPlt e1 e2 => ((ez2z e1)<(ez2z e2))%Z
+      | EPle e1 e2 => ((ez2z e1)<=(ez2z e2))%Z
+      | EPgt e1 e2 => ((ez2z e1)>(ez2z e2))%Z
+      | EPge e1 e2 => ((ez2z e1)>=(ez2z e2))%Z
+      | EPimpl e1 e2 => (ep2p e1) -> (ep2p e2)
+      | EPequiv e1 e2 => (ep2p e1) <-> (ep2p e2)
+      | EPand e1 e2 => (ep2p e1) /\ (ep2p e2)
+      | EPor e1 e2 => (ep2p e1) \/ (ep2p e2)
+      | EPneg e => ~ (ep2p e)
+      | EPraw p => p
+    end.
+
+  (** [ExprI] (supposed under a [i2z]) to a simplified [ExprZ] *)
+   
+  Fixpoint norm_ei (e:ExprI) : ExprZ := 
+    match e with 
+      | EI0 => EZraw (0%Z)
+      | EI1 => EZraw (1%Z)
+      | EI2 => EZraw (2%Z)
+      | EI3 => EZraw (3%Z) 
+      | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2)
+      | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2)
+      | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2)
+      | EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2)
+      | EIopp e => EZopp (norm_ei e)
+      | EIraw i => EZofI (EIraw i) 
+    end.
+
+  (** [ExprZ] to a simplified [ExprZ] *)
+
+  Fixpoint norm_ez (e:ExprZ) : ExprZ := 
+    match e with 
+      | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2)
+      | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2)
+      | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2)
+      | EZmax e1 e2 => EZmax (norm_ez e1) (norm_ez e2)
+      | EZopp e => EZopp (norm_ez e)
+      | EZofI e =>  norm_ei e
+      | EZraw z => EZraw z
+    end.
+
+  (** [ExprP] to a simplified [ExprP] *)
+  
+  Fixpoint norm_ep (e:ExprP) : ExprP := 
+    match e with 
+      | EPeq e1 e2 => EPeq (norm_ez e1) (norm_ez e2)
+      | EPlt e1 e2 => EPlt (norm_ez e1) (norm_ez e2)
+      | EPle e1 e2 => EPle (norm_ez e1) (norm_ez e2)
+      | EPgt e1 e2 => EPgt (norm_ez e1) (norm_ez e2)
+      | EPge e1 e2 => EPge (norm_ez e1) (norm_ez e2)
+      | EPimpl e1 e2 => EPimpl (norm_ep e1) (norm_ep e2)
+      | EPequiv e1 e2 => EPequiv (norm_ep e1) (norm_ep e2)
+      | EPand e1 e2 => EPand (norm_ep e1) (norm_ep e2)
+      | EPor e1 e2 => EPor (norm_ep e1) (norm_ep e2)
+      | EPneg e => EPneg (norm_ep e)
+      | EPraw p => EPraw p
+    end.
+
+  Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e).
+  Proof. 
+    induction e; simpl; intros; i2z; auto; try congruence.
+  Qed.
+
+  Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e.
+  Proof.
+    induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct.
+  Qed. 
+
+  Lemma norm_ep_correct : 
+    forall e:ExprP, ep2p (norm_ep e) <-> ep2p e.
+  Proof.
+    induction e; simpl; repeat (rewrite norm_ez_correct); intuition.
+  Qed.
+
+  Lemma norm_ep_correct2 : 
+    forall e:ExprP, ep2p (norm_ep e) -> ep2p e.
+  Proof.
+    intros; destruct (norm_ep_correct e); auto.
+  Qed.
+
+  Ltac i2z_refl := 
+    i2z_gen;
+    match goal with |- ?t => 
+      let e := p2ep t 
+	in 
+	(change (ep2p e); 
+	  apply norm_ep_correct2; 
+	    simpl)
+    end.
+
+  Ltac iauto := i2z_refl; auto.
+  Ltac iomega := i2z_refl; intros; romega.
+
+  Open Scope Z_scope.
+
+  Lemma max_spec : forall (x y:Z), 
+    x >= y /\ Zmax x y = x  \/
+    x < y /\ Zmax x y = y.
+  Proof.
+    intros; unfold Zmax, Zlt, Zge.
+    destruct (Zcompare x y); [ left | right | left ]; split; auto; discriminate.
+  Qed.
+
+  Ltac omega_max_genspec x y := 
+    generalize (max_spec x y); 
+    (let z := fresh "z" in let Hz := fresh "Hz" in 
+     set (z:=Zmax x y); clearbody z).
+
+  Ltac omega_max_loop := 
+    match goal with 
+      (* hack: we don't want [i2z (height ...)] to be reduced by romega later... *)
+      | |- context [ i2z (?f ?x) ] => 
+          let i := fresh "i2z" in (set (i:=i2z (f x)); clearbody i); omega_max_loop
+      | |- context [ Zmax ?x ?y ] => omega_max_genspec x y; omega_max_loop
+      | _ => intros
+    end.
+
+  Ltac omega_max := i2z_refl; omega_max_loop; try romega.
+  
+  Ltac false_omega := i2z_refl; intros; romega.
+  Ltac false_omega_max := elimtype False; omega_max.
+
+  Open Scope Int_scope.
+End MoreInt.
+
+
+
+(** * An implementation of [Int] *)
+
+(** It's always nice to know that our [Int] interface is realizable :-) *)
+
+Module Z_as_Int <: Int.
+  Open Scope Z_scope.
+  Definition int := Z.
+  Definition _0 := 0.
+  Definition _1 := 1.
+  Definition _2 := 2.
+  Definition _3 := 3.
+  Definition plus := Zplus.
+  Definition opp := Zopp.
+  Definition minus := Zminus.
+  Definition mult := Zmult.
+  Definition max := Zmax.
+  Definition gt_le_dec := Z_gt_le_dec. 
+  Definition ge_lt_dec := Z_ge_lt_dec.
+  Definition eq_dec := Z_eq_dec.
+  Definition i2z : int -> Z := fun n => n.
+  Lemma i2z_eq : forall n p, i2z n=i2z p -> n = p. Proof. auto. Qed.
+  Lemma i2z_0 : i2z _0 = 0.  Proof. auto. Qed.
+  Lemma i2z_1 : i2z _1 = 1.  Proof. auto. Qed.
+  Lemma i2z_2 : i2z _2 = 2.  Proof. auto. Qed.
+  Lemma i2z_3 : i2z _3 = 3.  Proof. auto. Qed.
+  Lemma i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.  Proof. auto. Qed.
+  Lemma i2z_opp : forall n, i2z (- n)  = - i2z n.  Proof. auto. Qed.
+  Lemma i2z_minus : forall n p, i2z (n - p)  = i2z n - i2z p.  Proof. auto. Qed.
+  Lemma i2z_mult : forall n p, i2z (n * p)  = i2z n * i2z p.  Proof. auto. Qed.
+  Lemma i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p). Proof. auto. Qed.
+End Z_as_Int.
+
diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v
index 069ddd42..1d7948a5 100644
--- a/theories/ZArith/Wf_Z.v
+++ b/theories/ZArith/Wf_Z.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Wf_Z.v,v 1.20.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+(*i $Id: Wf_Z.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import BinInt.
 Require Import Zcompare.
@@ -35,170 +35,229 @@ Open Local Scope Z_scope.
   Then the  diagram will be closed and the theorem proved. *)
 
 Lemma Z_of_nat_complete :
- forall x:Z, 0 <= x ->  exists n : nat, x = Z_of_nat n.
-intro x; destruct x; intros;
- [ exists 0%nat; auto with arith
- | specialize (ZL4 p); intros Hp; elim Hp; intros; exists (S x); intros;
-    simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x); 
-    intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
-    apply nat_of_P_inj; auto with arith
- | absurd (0 <= Zneg p);
-    [ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
-       auto with arith
-    | assumption ] ].
+  forall x:Z, 0 <= x ->  exists n : nat, x = Z_of_nat n.
+Proof.
+  intro x; destruct x; intros;
+    [ exists 0%nat; auto with arith
+      | specialize (ZL4 p); intros Hp; elim Hp; intros; exists (S x); intros;
+	simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x); 
+	  intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
+	    apply nat_of_P_inj; auto with arith
+      | absurd (0 <= Zneg p);
+	[ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
+	  auto with arith
+	  | assumption ] ].
 Qed.
 
 Lemma ZL4_inf : forall y:positive, {h : nat | nat_of_P y = S h}.
-intro y; induction y as [p H| p H1| ];
- [ elim H; intros x H1; exists (S x + S x)%nat; unfold nat_of_P in |- *;
-    simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
-    unfold nat_of_P in H1; rewrite H1; auto with arith
- | elim H1; intros x H2; exists (x + S x)%nat; unfold nat_of_P in |- *;
-    simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
-    unfold nat_of_P in H2; rewrite H2; auto with arith
- | exists 0%nat; auto with arith ].
+Proof.
+  intro y; induction y as [p H| p H1| ];
+    [ elim H; intros x H1; exists (S x + S x)%nat; unfold nat_of_P in |- *;
+      simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
+	unfold nat_of_P in H1; rewrite H1; auto with arith
+      | elim H1; intros x H2; exists (x + S x)%nat; unfold nat_of_P in |- *;
+	simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism;
+	  unfold nat_of_P in H2; rewrite H2; auto with arith
+      | exists 0%nat; auto with arith ].
 Qed.
 
 Lemma Z_of_nat_complete_inf :
  forall x:Z, 0 <= x -> {n : nat | x = Z_of_nat n}.
-intro x; destruct x; intros;
- [ exists 0%nat; auto with arith
- | specialize (ZL4_inf p); intros Hp; elim Hp; intros x0 H0; exists (S x0);
-    intros; simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x0);
-    intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
-    apply nat_of_P_inj; auto with arith
- | absurd (0 <= Zneg p);
-    [ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
-       auto with arith
-    | assumption ] ].
+Proof.
+  intro x; destruct x; intros;
+    [ exists 0%nat; auto with arith
+      | specialize (ZL4_inf p); intros Hp; elim Hp; intros x0 H0; exists (S x0);
+	intros; simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x0);
+	  intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos);
+	    apply nat_of_P_inj; auto with arith
+      | absurd (0 <= Zneg p);
+	[ unfold Zle in |- *; simpl in |- *; do 2 unfold not in |- *;
+	  auto with arith
+	  | assumption ] ].
 Qed.
 
 Lemma Z_of_nat_prop :
- forall P:Z -> Prop,
-   (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
-intros P H x H0.
-specialize (Z_of_nat_complete x H0).
-intros Hn; elim Hn; intros.
-rewrite H1; apply H.
+  forall P:Z -> Prop,
+    (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
+Proof.
+  intros P H x H0.
+  specialize (Z_of_nat_complete x H0).
+  intros Hn; elim Hn; intros.
+  rewrite H1; apply H.
 Qed.
 
 Lemma Z_of_nat_set :
  forall P:Z -> Set,
    (forall n:nat, P (Z_of_nat n)) -> forall x:Z, 0 <= x -> P x.
-intros P H x H0.
-specialize (Z_of_nat_complete_inf x H0).
-intros Hn; elim Hn; intros.
-rewrite p; apply H.
+Proof.
+  intros P H x H0.
+  specialize (Z_of_nat_complete_inf x H0).
+  intros Hn; elim Hn; intros.
+  rewrite p; apply H.
 Qed.
 
 Lemma natlike_ind :
  forall P:Z -> Prop,
    P 0 ->
    (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x.
-intros P H H0 x H1; apply Z_of_nat_prop;
- [ simple induction n;
-    [ simpl in |- *; assumption
-    | intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
- | assumption ].
+Proof.
+  intros P H H0 x H1; apply Z_of_nat_prop;
+    [ simple induction n;
+      [ simpl in |- *; assumption
+	| intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
+      | assumption ].
 Qed.
 
 Lemma natlike_rec :
  forall P:Z -> Set,
    P 0 ->
    (forall x:Z, 0 <= x -> P x -> P (Zsucc x)) -> forall x:Z, 0 <= x -> P x.
-intros P H H0 x H1; apply Z_of_nat_set;
- [ simple induction n;
-    [ simpl in |- *; assumption
-    | intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
- | assumption ].
+Proof.
+  intros P H H0 x H1; apply Z_of_nat_set;
+    [ simple induction n;
+      [ simpl in |- *; assumption
+	| intros; rewrite (inj_S n0); exact (H0 (Z_of_nat n0) (Zle_0_nat n0) H2) ]
+      | assumption ].
 Qed.
 
 Section Efficient_Rec. 
 
-(** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed 
-     to give a better extracted term. *)
+  (** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed 
+      to give a better extracted term. *)
 
-Let R (a b:Z) := 0 <= a /\ a < b.
+  Let R (a b:Z) := 0 <= a /\ a < b.
+  
+  Let R_wf : well_founded R.
+  Proof.
+    set
+      (f :=
+	fun z =>
+	  match z with
+	    | Zpos p => nat_of_P p
+	    | Z0 => 0%nat
+	    | Zneg _ => 0%nat
+	  end) in *.
+    apply well_founded_lt_compat with f.
+    unfold R, f in |- *; clear f R.
+    intros x y; case x; intros; elim H; clear H.
+    case y; intros; apply lt_O_nat_of_P || inversion H0.
+    case y; intros; apply nat_of_P_lt_Lt_compare_morphism || inversion H0; auto.
+    intros; elim H; auto.
+  Qed.
 
-Let R_wf : well_founded R.
-Proof.
-set
- (f :=
-  fun z =>
-    match z with
-    | Zpos p => nat_of_P p
-    | Z0 => 0%nat
-    | Zneg _ => 0%nat
-    end) in *.
-apply well_founded_lt_compat with f.
-unfold R, f in |- *; clear f R.
-intros x y; case x; intros; elim H; clear H.
-case y; intros; apply lt_O_nat_of_P || inversion H0.
-case y; intros; apply nat_of_P_lt_Lt_compare_morphism || inversion H0; auto.
-intros; elim H; auto.
-Qed.
+  Lemma natlike_rec2 :
+    forall P:Z -> Type,
+      P 0 ->
+      (forall z:Z, 0 <= z -> P z -> P (Zsucc z)) -> forall z:Z, 0 <= z -> P z.
+  Proof.
+    intros P Ho Hrec z; pattern z in |- *;
+      apply (well_founded_induction_type R_wf).
+    intro x; case x.
+    trivial.
+    intros.
+    assert (0 <= Zpred (Zpos p)).
+    apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
+    rewrite Zsucc_pred.
+    apply Hrec.
+    auto.
+    apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
+    intros; elim H; simpl in |- *; trivial.
+  Qed.
 
-Lemma natlike_rec2 :
- forall P:Z -> Type,
-   P 0 ->
-   (forall z:Z, 0 <= z -> P z -> P (Zsucc z)) -> forall z:Z, 0 <= z -> P z.
-Proof.
-intros P Ho Hrec z; pattern z in |- *;
- apply (well_founded_induction_type R_wf).
-intro x; case x.
-trivial.
-intros.
-assert (0 <= Zpred (Zpos p)).
-apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
-rewrite Zsucc_pred.
-apply Hrec.
-auto.
-apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
-intros; elim H; simpl in |- *; trivial.
-Qed.
+  (** A variant of the previous using [Zpred] instead of [Zs]. *)
 
-(** A variant of the previous using [Zpred] instead of [Zs]. *)
+  Lemma natlike_rec3 :
+    forall P:Z -> Type,
+      P 0 ->
+      (forall z:Z, 0 < z -> P (Zpred z) -> P z) -> forall z:Z, 0 <= z -> P z.
+  Proof.
+    intros P Ho Hrec z; pattern z in |- *;
+      apply (well_founded_induction_type R_wf).
+    intro x; case x.
+    trivial.
+    intros; apply Hrec.
+    unfold Zlt in |- *; trivial.
+    assert (0 <= Zpred (Zpos p)).
+    apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
+    apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
+    intros; elim H; simpl in |- *; trivial.
+  Qed.
 
-Lemma natlike_rec3 :
- forall P:Z -> Type,
-   P 0 ->
-   (forall z:Z, 0 < z -> P (Zpred z) -> P z) -> forall z:Z, 0 <= z -> P z.
-Proof.
-intros P Ho Hrec z; pattern z in |- *;
- apply (well_founded_induction_type R_wf).
-intro x; case x.
-trivial.
-intros; apply Hrec.
-unfold Zlt in |- *; trivial.
-assert (0 <= Zpred (Zpos p)).
-apply Zorder.Zlt_0_le_0_pred; unfold Zlt in |- *; simpl in |- *; trivial.
-apply X; auto; unfold R in |- *; intuition; apply Zlt_pred.
-intros; elim H; simpl in |- *; trivial.
-Qed.
+  (** A more general induction principle on non-negative numbers using [Zlt]. *)
 
-(** A more general induction principal using [Zlt]. *)
+  Lemma Zlt_0_rec :
+    forall P:Z -> Type,
+      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
+      forall x:Z, 0 <= x -> P x.
+  Proof.
+    intros P Hrec z; pattern z in |- *; apply (well_founded_induction_type R_wf).
+    intro x; case x; intros.
+    apply Hrec; intros.
+    assert (H2 : 0 < 0).
+    apply Zle_lt_trans with y; intuition.
+    inversion H2.
+    assumption.
+    firstorder.
+    unfold Zle, Zcompare in H; elim H; auto.
+  Defined.
 
-Lemma Z_lt_rec :
- forall P:Z -> Type,
-   (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
-   forall x:Z, 0 <= x -> P x.
-Proof.
-intros P Hrec z; pattern z in |- *; apply (well_founded_induction_type R_wf).
-intro x; case x; intros.
-apply Hrec; intros.
-assert (H2 : 0 < 0).
-  apply Zle_lt_trans with y; intuition.
-inversion H2.
-firstorder.
-unfold Zle, Zcompare in H; elim H; auto.
-Defined.
-
-Lemma Z_lt_induction :
- forall P:Z -> Prop,
-   (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
-   forall x:Z, 0 <= x -> P x.
-Proof.
-exact Z_lt_rec.
-Qed.
+  Lemma Zlt_0_ind :
+    forall P:Z -> Prop,
+      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
+      forall x:Z, 0 <= x -> P x.
+  Proof.
+    exact Zlt_0_rec.
+  Qed.
+
+  (** Obsolete version of [Zlt] induction principle on non-negative numbers *)
+
+  Lemma Z_lt_rec :
+    forall P:Z -> Type,
+      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
+      forall x:Z, 0 <= x -> P x.
+  Proof.
+    intros P Hrec; apply Zlt_0_rec; auto.
+  Qed.
+
+  Lemma Z_lt_induction :
+    forall P:Z -> Prop,
+      (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
+      forall x:Z, 0 <= x -> P x.
+  Proof.
+    exact Z_lt_rec.
+  Qed.
+
+  (** An even more general induction principle using [Zlt]. *)
+
+  Lemma Zlt_lower_bound_rec :
+    forall P:Z -> Type, forall z:Z,
+      (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
+      forall x:Z, z <= x -> P x.
+  Proof.
+    intros P z Hrec x.
+    assert (Hexpand : forall x, x = x - z + z).
+    intro; unfold Zminus; rewrite <- Zplus_assoc; rewrite Zplus_opp_l;
+      rewrite Zplus_0_r; trivial.
+    intro Hz.
+    rewrite (Hexpand x); pattern (x - z) in |- *; apply Zlt_0_rec.
+    2: apply Zplus_le_reg_r with z; rewrite <- Hexpand; assumption.
+    intros x0 Hlt_x0 H.
+    apply Hrec.
+    2: change z with (0+z); apply Zplus_le_compat_r; assumption.
+    intro y; rewrite (Hexpand y); intros.
+    destruct H0.
+    apply Hlt_x0.
+    split.
+    apply Zplus_le_reg_r with z; assumption.
+    apply Zplus_lt_reg_r with z; assumption.
+  Qed.
+
+  Lemma Zlt_lower_bound_ind :
+    forall P:Z -> Prop, forall z:Z,
+      (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
+      forall x:Z, z <= x -> P x.
+  Proof.
+    exact Zlt_lower_bound_rec.
+  Qed.
 
 End Efficient_Rec.
diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v
index 7e361621..66e0bda8 100644
--- a/theories/ZArith/ZArith.v
+++ b/theories/ZArith/ZArith.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZArith.v,v 1.5.2.2 2004/08/03 17:56:30 herbelin Exp $ i*)
+(*i $Id: ZArith.v 9210 2006-10-05 10:12:15Z barras $ i*)
 
 (** Library for manipulating integers based on binary encoding *)
 
@@ -19,3 +19,5 @@ Require Export Zsqrt.
 Require Export Zpower.
 Require Export Zdiv.
 Require Export Zlogarithm.
+
+Export ZArithRing.
diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v
index 694e071e..20fd6b5f 100644
--- a/theories/ZArith/ZArith_base.v
+++ b/theories/ZArith/ZArith_base.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ZArith_base.v,v 1.5.2.1 2004/07/16 19:31:20 herbelin Exp $ *)
+(* $Id: ZArith_base.v 8032 2006-02-12 21:20:48Z herbelin $ *)
 
 (** Library for manipulating integers based on binary encoding.
     These are the basic modules, required by [Omega] and [Ring] for instance. 
@@ -19,6 +19,8 @@ Require Export Zcompare.
 Require Export Zorder.
 Require Export Zeven.
 Require Export Zmin.
+Require Export Zmax.
+Require Export Zminmax.
 Require Export Zabs.
 Require Export Znat.
 Require Export auxiliary.
@@ -31,4 +33,4 @@ Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l
   Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l
   Zmult_plus_distr_r: zarith.
 
-Require Export Zhints.
\ No newline at end of file
+Require Export Zhints.
diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v
index dbd0df6c..84249955 100644
--- a/theories/ZArith/ZArith_dec.v
+++ b/theories/ZArith/ZArith_dec.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: ZArith_dec.v,v 1.11.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+(*i $Id: ZArith_dec.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import Sumbool.
 
@@ -17,210 +17,210 @@ Open Local Scope Z_scope.
 
 Lemma Dcompare_inf : forall r:comparison, {r = Eq} + {r = Lt} + {r = Gt}.
 Proof.
-simple induction r; auto with arith. 
+  simple induction r; auto with arith. 
 Defined.
 
 Lemma Zcompare_rec :
- forall (P:Set) (n m:Z),
-   ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
+  forall (P:Set) (n m:Z),
+    ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
 Proof.
-intros P x y H1 H2 H3.
-elim (Dcompare_inf (x ?= y)).
-intro H. elim H; auto with arith. auto with arith.
+  intros P x y H1 H2 H3.
+  elim (Dcompare_inf (x ?= y)).
+  intro H. elim H; auto with arith. auto with arith.
 Defined.
 
 Section decidability.
 
-Variables x y : Z.
-
-(** Decidability of equality on binary integers *)
-
-Definition Z_eq_dec : {x = y} + {x <> y}.
-Proof.
-apply Zcompare_rec with (n := x) (m := y).
-intro. left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
-intro H3. right. elim (Zcompare_Eq_iff_eq x y). intros H1 H2. unfold not in |- *. intro H4.
-  rewrite (H2 H4) in H3. discriminate H3.
-intro H3. right. elim (Zcompare_Eq_iff_eq x y). intros H1 H2. unfold not in |- *. intro H4.
-  rewrite (H2 H4) in H3. discriminate H3.
-Defined. 
-
-(** Decidability of order on binary integers *)
-
-Definition Z_lt_dec : {x < y} + {~ x < y}.
-Proof.
-unfold Zlt in |- *.
-apply Zcompare_rec with (n := x) (m := y); intro H.
-right. rewrite H. discriminate.
-left; assumption.
-right. rewrite H. discriminate.
-Defined.
-
-Definition Z_le_dec : {x <= y} + {~ x <= y}.
-Proof.
-unfold Zle in |- *.
-apply Zcompare_rec with (n := x) (m := y); intro H.
-left. rewrite H. discriminate.
-left. rewrite H. discriminate.
-right. tauto.
-Defined.
-
-Definition Z_gt_dec : {x > y} + {~ x > y}.
-Proof.
-unfold Zgt in |- *.
-apply Zcompare_rec with (n := x) (m := y); intro H.
-right. rewrite H. discriminate.
-right. rewrite H. discriminate.
-left; assumption.
-Defined.
-
-Definition Z_ge_dec : {x >= y} + {~ x >= y}.
-Proof.
-unfold Zge in |- *.
-apply Zcompare_rec with (n := x) (m := y); intro H.
-left. rewrite H. discriminate.
-right. tauto.
-left. rewrite H. discriminate.
-Defined.
-
-Definition Z_lt_ge_dec : {x < y} + {x >= y}.
-Proof.
-exact Z_lt_dec.
-Defined.
-
-Lemma Z_lt_le_dec : {x < y} + {y <= x}.
-Proof.
-intros.
-elim Z_lt_ge_dec.
-intros; left; assumption.
-intros; right; apply Zge_le; assumption.
-Qed.
-
-Definition Z_le_gt_dec : {x <= y} + {x > y}.
-Proof.
-elim Z_le_dec; auto with arith.
-intro. right. apply Znot_le_gt; auto with arith.
-Defined.
-
-Definition Z_gt_le_dec : {x > y} + {x <= y}.
-Proof.
-exact Z_gt_dec.
-Defined.
-
-Definition Z_ge_lt_dec : {x >= y} + {x < y}.
-Proof.
-elim Z_ge_dec; auto with arith.
-intro. right. apply Znot_ge_lt; auto with arith.
-Defined.
-
-Definition Z_le_lt_eq_dec : x <= y -> {x < y} + {x = y}.
-Proof.
-intro H.
-apply Zcompare_rec with (n := x) (m := y).
-intro. right. elim (Zcompare_Eq_iff_eq x y); auto with arith.
-intro. left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
-intro H1. absurd (x > y); auto with arith.
-Defined.
+  Variables x y : Z.
+  
+  (** * Decidability of equality on binary integers *)
+
+  Definition Z_eq_dec : {x = y} + {x <> y}.
+  Proof.
+    apply Zcompare_rec with (n := x) (m := y).
+    intro. left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
+    intro H3. right. elim (Zcompare_Eq_iff_eq x y). intros H1 H2. unfold not in |- *. intro H4.
+    rewrite (H2 H4) in H3. discriminate H3.
+    intro H3. right. elim (Zcompare_Eq_iff_eq x y). intros H1 H2. unfold not in |- *. intro H4.
+    rewrite (H2 H4) in H3. discriminate H3.
+  Defined. 
+
+  (** * Decidability of order on binary integers *)
+
+  Definition Z_lt_dec : {x < y} + {~ x < y}.
+  Proof.
+    unfold Zlt in |- *.
+    apply Zcompare_rec with (n := x) (m := y); intro H.
+    right. rewrite H. discriminate.
+    left; assumption.
+    right. rewrite H. discriminate.
+  Defined.
+
+  Definition Z_le_dec : {x <= y} + {~ x <= y}.
+  Proof.
+    unfold Zle in |- *.
+    apply Zcompare_rec with (n := x) (m := y); intro H.
+    left. rewrite H. discriminate.
+    left. rewrite H. discriminate.
+    right. tauto.
+  Defined.
+  
+  Definition Z_gt_dec : {x > y} + {~ x > y}.
+  Proof.
+    unfold Zgt in |- *.
+    apply Zcompare_rec with (n := x) (m := y); intro H.
+    right. rewrite H. discriminate.
+    right. rewrite H. discriminate.
+    left; assumption.
+  Defined.
+
+  Definition Z_ge_dec : {x >= y} + {~ x >= y}.
+  Proof.
+    unfold Zge in |- *.
+    apply Zcompare_rec with (n := x) (m := y); intro H.
+    left. rewrite H. discriminate.
+    right. tauto.
+    left. rewrite H. discriminate.
+  Defined.
+
+  Definition Z_lt_ge_dec : {x < y} + {x >= y}.
+  Proof.
+    exact Z_lt_dec.
+  Defined.
+
+  Lemma Z_lt_le_dec : {x < y} + {y <= x}.
+  Proof.
+    intros.
+    elim Z_lt_ge_dec.
+    intros; left; assumption.
+    intros; right; apply Zge_le; assumption.
+  Qed.
+
+  Definition Z_le_gt_dec : {x <= y} + {x > y}.
+  Proof.
+    elim Z_le_dec; auto with arith.
+    intro. right. apply Znot_le_gt; auto with arith.
+  Defined.
+
+  Definition Z_gt_le_dec : {x > y} + {x <= y}.
+  Proof.
+    exact Z_gt_dec.
+  Defined.
+
+  Definition Z_ge_lt_dec : {x >= y} + {x < y}.
+  Proof.
+    elim Z_ge_dec; auto with arith.
+    intro. right. apply Znot_ge_lt; auto with arith.
+  Defined.
+
+  Definition Z_le_lt_eq_dec : x <= y -> {x < y} + {x = y}.
+  Proof.
+    intro H.
+    apply Zcompare_rec with (n := x) (m := y).
+    intro. right. elim (Zcompare_Eq_iff_eq x y); auto with arith.
+    intro. left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
+    intro H1. absurd (x > y); auto with arith.
+  Defined.
 
 End decidability.
 
-(** Cotransitivity of order on binary integers *)
+(** * Cotransitivity of order on binary integers *)
 
 Lemma Zlt_cotrans : forall n m:Z, n < m -> forall p:Z, {n < p} + {p < m}.
 Proof.
- intros x y H z.
- case (Z_lt_ge_dec x z).
- intro.
- left.
- assumption.
- intro.
- right.
- apply Zle_lt_trans with (m := x).
- apply Zge_le.
- assumption.
- assumption.
+  intros x y H z.
+  case (Z_lt_ge_dec x z).
+  intro.
+  left.
+  assumption.
+  intro.
+  right.
+  apply Zle_lt_trans with (m := x).
+  apply Zge_le.
+  assumption.
+  assumption.
 Defined.
 
 Lemma Zlt_cotrans_pos : forall n m:Z, 0 < n + m -> {0 < n} + {0 < m}.
 Proof.
- intros x y H.
- case (Zlt_cotrans 0 (x + y) H x).
- intro.
- left.
- assumption.
- intro.
- right.
- apply Zplus_lt_reg_l with (p := x).
- rewrite Zplus_0_r.
- assumption.
+  intros x y H.
+  case (Zlt_cotrans 0 (x + y) H x).
+  intro.
+  left.
+  assumption.
+  intro.
+  right.
+  apply Zplus_lt_reg_l with (p := x).
+  rewrite Zplus_0_r.
+  assumption.
 Defined.
 
 Lemma Zlt_cotrans_neg : forall n m:Z, n + m < 0 -> {n < 0} + {m < 0}.
 Proof.
- intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy;
-  [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ];
-  assumption.
+  intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy;
+    [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ];
+    assumption.
 Defined.
 
 Lemma not_Zeq_inf : forall n m:Z, n <> m -> {n < m} + {m < n}.
 Proof.
- intros x y H.
- case Z_lt_ge_dec with x y.
- intro.
- left.
- assumption.
- intro H0.
- generalize (Zge_le _ _ H0).
- intro.
- case (Z_le_lt_eq_dec _ _ H1).
- intro.
- right.
- assumption.
- intro.
- apply False_rec.
- apply H.
- symmetry  in |- *.
- assumption.
+  intros x y H.
+  case Z_lt_ge_dec with x y.
+  intro.
+  left.
+  assumption.
+  intro H0.
+  generalize (Zge_le _ _ H0).
+  intro.
+  case (Z_le_lt_eq_dec _ _ H1).
+  intro.
+  right.
+  assumption.
+  intro.
+  apply False_rec.
+  apply H.
+  symmetry  in |- *.
+  assumption.
 Defined.
 
 Lemma Z_dec : forall n m:Z, {n < m} + {n > m} + {n = m}.
 Proof.
- intros x y.
- case (Z_lt_ge_dec x y).
- intro H.
- left.
- left.
- assumption.
- intro H.
- generalize (Zge_le _ _ H).
- intro H0.
- case (Z_le_lt_eq_dec y x H0).
- intro H1.
- left.
- right.
- apply Zlt_gt.
- assumption.
- intro.
- right.
- symmetry  in |- *.
- assumption.
+  intros x y.
+  case (Z_lt_ge_dec x y).
+  intro H.
+  left.
+  left.
+  assumption.
+  intro H.
+  generalize (Zge_le _ _ H).
+  intro H0.
+  case (Z_le_lt_eq_dec y x H0).
+  intro H1.
+  left.
+  right.
+  apply Zlt_gt.
+  assumption.
+  intro.
+  right.
+  symmetry  in |- *.
+  assumption.
 Defined.
 
 
 Lemma Z_dec' : forall n m:Z, {n < m} + {m < n} + {n = m}.
 Proof.
- intros x y.
- case (Z_eq_dec x y); intro H;
-  [ right; assumption | left; apply (not_Zeq_inf _ _ H) ].
+  intros x y.
+  case (Z_eq_dec x y); intro H;
+    [ right; assumption | left; apply (not_Zeq_inf _ _ H) ].
 Defined.
 
 
 
 Definition Z_zerop : forall x:Z, {x = 0} + {x <> 0}.
 Proof.
-exact (fun x:Z => Z_eq_dec x 0).
+  exact (fun x:Z => Z_eq_dec x 0).
 Defined.
 
 Definition Z_notzerop (x:Z) := sumbool_not _ _ (Z_zerop x).
 
-Definition Z_noteq_dec (x y:Z) := sumbool_not _ _ (Z_eq_dec x y).
\ No newline at end of file
+Definition Z_noteq_dec (x y:Z) := sumbool_not _ _ (Z_eq_dec x y).
diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v
index 90e4c2a4..ed641358 100644
--- a/theories/ZArith/Zabs.v
+++ b/theories/ZArith/Zabs.v
@@ -5,11 +5,11 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zabs.v,v 1.4.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+(*i $Id: Zabs.v 9302 2006-10-27 21:21:17Z barras $ i*)
 
 (** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
 
-Require Import Arith.
+Require Import Arith_base.
 Require Import BinPos.
 Require Import BinInt.
 Require Import Zorder.
@@ -18,111 +18,113 @@ Require Import ZArith_dec.
 Open Local Scope Z_scope.
 
 (**********************************************************************)
-(** Properties of absolute value *)
+(** * Properties of absolute value *)
 
 Lemma Zabs_eq : forall n:Z, 0 <= n -> Zabs n = n.
-intro x; destruct x; auto with arith.
-compute in |- *; intros; absurd (Gt = Gt); trivial with arith.
+Proof.
+  intro x; destruct x; auto with arith.
+  compute in |- *; intros; absurd (Gt = Gt); trivial with arith.
 Qed.
 
 Lemma Zabs_non_eq : forall n:Z, n <= 0 -> Zabs n = - n.
 Proof.
-intro x; destruct x; auto with arith.
-compute in |- *; intros; absurd (Gt = Gt); trivial with arith.
+  intro x; destruct x; auto with arith.
+  compute in |- *; intros; absurd (Gt = Gt); trivial with arith.
 Qed.
 
 Theorem Zabs_Zopp : forall n:Z, Zabs (- n) = Zabs n.
 Proof.
-intros z; case z; simpl in |- *; auto.
+  intros z; case z; simpl in |- *; auto.
 Qed.
 
-(** Proving a property of the absolute value by cases *)
+(** * Proving a property of the absolute value by cases *)
 
 Lemma Zabs_ind :
- forall (P:Z -> Prop) (n:Z),
-   (n >= 0 -> P n) -> (n <= 0 -> P (- n)) -> P (Zabs n).
+  forall (P:Z -> Prop) (n:Z),
+    (n >= 0 -> P n) -> (n <= 0 -> P (- n)) -> P (Zabs n).
 Proof.
-intros P x H H0; elim (Z_lt_ge_dec x 0); intro.
-assert (x <= 0). apply Zlt_le_weak; assumption.
-rewrite Zabs_non_eq. apply H0. assumption. assumption.
-rewrite Zabs_eq. apply H; assumption. apply Zge_le. assumption.
+  intros P x H H0; elim (Z_lt_ge_dec x 0); intro.
+  assert (x <= 0). apply Zlt_le_weak; assumption.
+  rewrite Zabs_non_eq. apply H0. assumption. assumption.
+  rewrite Zabs_eq. apply H; assumption. apply Zge_le. assumption.
 Qed.
 
 Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Zabs n).
-intros P z; case z; simpl in |- *; auto.
+Proof.
+  intros P z; case z; simpl in |- *; auto.
 Qed.
 
 Definition Zabs_dec : forall x:Z, {x = Zabs x} + {x = - Zabs x}.
 Proof.
-intro x; destruct x; auto with arith.
+  intro x; destruct x; auto with arith.
 Defined.
 
 Lemma Zabs_pos : forall n:Z, 0 <= Zabs n.
-intro x; destruct x; auto with arith; compute in |- *; intros H; inversion H.
+  intro x; destruct x; auto with arith; compute in |- *; intros H; inversion H.
 Qed.
 
 Theorem Zabs_eq_case : forall n m:Z, Zabs n = Zabs m -> n = m \/ n = - m.
 Proof.
-intros z1 z2; case z1; case z2; simpl in |- *; auto;
- try (intros; discriminate); intros p1 p2 H1; injection H1;
- (intros H2; rewrite H2); auto.
+  intros z1 z2; case z1; case z2; simpl in |- *; auto;
+    try (intros; discriminate); intros p1 p2 H1; injection H1;
+      (intros H2; rewrite H2); auto.
 Qed.
 
-(** Triangular inequality *)
+(** * Triangular inequality *)
 
 Hint Local Resolve Zle_neg_pos: zarith.
 
 Theorem Zabs_triangle : forall n m:Z, Zabs (n + m) <= Zabs n + Zabs m.
 Proof.
-intros z1 z2; case z1; case z2; try (simpl in |- *; auto with zarith; fail).
-intros p1 p2;
- apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1));
- try rewrite Zopp_plus_distr; auto with zarith.
-apply Zplus_le_compat; simpl in |- *; auto with zarith.
-apply Zplus_le_compat; simpl in |- *; auto with zarith.
-intros p1 p2;
- apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1));
- try rewrite Zopp_plus_distr; auto with zarith.
-apply Zplus_le_compat; simpl in |- *; auto with zarith.
-apply Zplus_le_compat; simpl in |- *; auto with zarith.
+  intros z1 z2; case z1; case z2; try (simpl in |- *; auto with zarith; fail).
+  intros p1 p2;
+    apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1));
+      try rewrite Zopp_plus_distr; auto with zarith.
+  apply Zplus_le_compat; simpl in |- *; auto with zarith.
+  apply Zplus_le_compat; simpl in |- *; auto with zarith.
+  intros p1 p2;
+    apply Zabs_intro with (P := fun x => x <= Zabs (Zpos p2) + Zabs (Zneg p1));
+      try rewrite Zopp_plus_distr; auto with zarith.
+  apply Zplus_le_compat; simpl in |- *; auto with zarith.
+  apply Zplus_le_compat; simpl in |- *; auto with zarith.
 Qed.
 
-(** Absolute value and multiplication *)
+(** * Absolute value and multiplication *)
 
 Lemma Zsgn_Zabs : forall n:Z, n * Zsgn n = Zabs n.
 Proof.
-intro x; destruct x; rewrite Zmult_comm; auto with arith.
+  intro x; destruct x; rewrite Zmult_comm; auto with arith.
 Qed.
 
 Lemma Zabs_Zsgn : forall n:Z, Zabs n * Zsgn n = n.
 Proof.
-intro x; destruct x; rewrite Zmult_comm; auto with arith.
+  intro x; destruct x; rewrite Zmult_comm; auto with arith.
 Qed.
 
 Theorem Zabs_Zmult : forall n m:Z, Zabs (n * m) = Zabs n * Zabs m.
 Proof.
-intros z1 z2; case z1; case z2; simpl in |- *; auto.
+  intros z1 z2; case z1; case z2; simpl in |- *; auto.
 Qed.
 
-(** absolute value in nat is compatible with order *)
+(** * Absolute value in nat is compatible with order *)
 
 Lemma Zabs_nat_lt :
- forall n m:Z, 0 <= n /\ n < m -> (Zabs_nat n < Zabs_nat m)%nat.
+  forall n m:Z, 0 <= n /\ n < m -> (Zabs_nat n < Zabs_nat m)%nat.
 Proof.
-intros x y. case x; simpl in |- *. case y; simpl in |- *.
-
-intro. absurd (0 < 0). compute in |- *. intro H0. discriminate H0. intuition.
-intros. elim (ZL4 p). intros. rewrite H0. auto with arith.
-intros. elim (ZL4 p). intros. rewrite H0. auto with arith.
-
-case y; simpl in |- *.
-intros. absurd (Zpos p < 0). compute in |- *. intro H0. discriminate H0. intuition.
-intros. change (nat_of_P p > nat_of_P p0)%nat in |- *.
-apply nat_of_P_gt_Gt_compare_morphism.
-elim H; auto with arith. intro. exact (ZC2 p0 p).
-
-intros. absurd (Zpos p0 < Zneg p).
-compute in |- *. intro H0. discriminate H0. intuition.
-
-intros. absurd (0 <= Zneg p). compute in |- *. auto with arith. intuition.
-Qed.
\ No newline at end of file
+  intros x y. case x; simpl in |- *. case y; simpl in |- *.
+
+  intro. absurd (0 < 0). compute in |- *. intro H0. discriminate H0. intuition.
+  intros. elim (ZL4 p). intros. rewrite H0. auto with arith.
+  intros. elim (ZL4 p). intros. rewrite H0. auto with arith.
+  
+  case y; simpl in |- *.
+  intros. absurd (Zpos p < 0). compute in |- *. intro H0. discriminate H0. intuition.
+  intros. change (nat_of_P p > nat_of_P p0)%nat in |- *.
+  apply nat_of_P_gt_Gt_compare_morphism.
+  elim H; auto with arith. intro. exact (ZC2 p0 p).
+
+  intros. absurd (Zpos p0 < Zneg p).
+  compute in |- *. intro H0. discriminate H0. intuition.
+
+  intros. absurd (0 <= Zneg p). compute in |- *. auto with arith. intuition.
+Qed.
diff --git a/theories/ZArith/Zbinary.v b/theories/ZArith/Zbinary.v
index fa5f00dc..08f08e12 100644
--- a/theories/ZArith/Zbinary.v
+++ b/theories/ZArith/Zbinary.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zbinary.v,v 1.6.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+(*i $Id: Zbinary.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** Bit vectors interpreted as integers. 
     Contribution by Jean Duprat (ENS Lyon). *)
@@ -16,11 +16,10 @@ Require Import ZArith.
 Require Export Zpower.
 Require Import Omega.
 
-(*
-L'évaluation des vecteurs de booléens se font à la fois en binaire et
-en complément à deux. Le nombre appartient à Z. 
-On utilise donc Omega pour faire les calculs dans Z.
-De plus, on utilise les fonctions 2^n où n est un naturel, ici la longueur.
+(** L'évaluation des vecteurs de booléens se font à la fois en binaire et
+    en complément à  deux. Le nombre appartient à  Z. 
+    On utilise donc Omega pour faire les calculs dans Z.
+    De plus, on utilise les fonctions 2^n où n est un naturel, ici la longueur.
 	two_power_nat = [n:nat](POS (shift_nat n xH))
      		: nat->Z
 	two_power_nat_S
@@ -32,395 +31,322 @@ De plus, on utilise les fonctions 2^n où n est un naturel, ici la longueur.
 
 Section VALUE_OF_BOOLEAN_VECTORS.
 
-(*
-Les calculs sont effectués dans la convention positive usuelle.
-Les valeurs correspondent soit à l'écriture binaire (nat), 
-soit au complément à deux (int).
-On effectue le calcul suivant le schéma de Horner.
-Le complément à deux n'a de sens que sur les vecteurs de taille 
-supérieure ou égale à un, le bit de signe étant évalué négativement.
+(** Les calculs sont effectués dans la convention positive usuelle.
+    Les valeurs correspondent soit à  l'écriture binaire (nat), 
+    soit au complément à  deux (int).
+    On effectue le calcul suivant le schéma de Horner.
+    Le complément à  deux n'a de sens que sur les vecteurs de taille 
+    supérieure ou égale à  un, le bit de signe étant évalué négativement.
 *)
 
-Definition bit_value (b:bool) : Z :=
-  match b with
-  | true => 1%Z
-  | false => 0%Z
-  end.
-
-Lemma binary_value : forall n:nat, Bvector n -> Z.
-Proof.
-	simple induction n; intros.
-	exact 0%Z.
-
-	inversion H0.
-	exact (bit_value a + 2 * H H2)%Z.
-Defined.
-
-Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z.
-Proof.
-	simple induction n; intros.
-	inversion H.
-	exact (- bit_value a)%Z.
-
-	inversion H0.
-	exact (bit_value a + 2 * H H2)%Z.
-Defined.
-
-(*
-Coq < Eval Compute in (binary_value (3) (Bcons true (2) (Bcons false (1) (Bcons true (0) Bnil)))).
-     = `5`
-     : Z
-*)
-
-(*
-Coq < Eval Compute in (two_compl_value (3) (Bcons true (3) (Bcons false (2) (Bcons true (1) (Bcons true (0) Bnil))))).
-     = `-3`
-     : Z
-*)
+  Definition bit_value (b:bool) : Z :=
+    match b with
+      | true => 1%Z
+      | false => 0%Z
+    end.
+  
+  Lemma binary_value : forall n:nat, Bvector n -> Z.
+  Proof.
+    simple induction n; intros.
+    exact 0%Z.
+    
+    inversion H0.
+    exact (bit_value a + 2 * H H2)%Z.
+  Defined.
+
+  Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z.
+  Proof.
+    simple induction n; intros.
+    inversion H.
+    exact (- bit_value a)%Z.
+
+    inversion H0.
+    exact (bit_value a + 2 * H H2)%Z.
+  Defined.
 
 End VALUE_OF_BOOLEAN_VECTORS.
 
 Section ENCODING_VALUE.
 
-(*
-On calcule la valeur binaire selon un schema de Horner.
-Le calcul s'arrete à la longueur du vecteur sans vérification.
-On definit une fonction Zmod2 calquee sur Zdiv2 mais donnant le quotient
-de la division z=2q+r avec 0<=r<=1.
-La valeur en complément à deux est calculée selon un schema de Horner
-avec Zmod2, le paramètre est la taille moins un.
-*)
-
-Definition Zmod2 (z:Z) :=
-  match z with
-  | Z0 => 0%Z
-  | Zpos p => match p with
-              | xI q => Zpos q
-              | xO q => Zpos q
-              | xH => 0%Z
-              end
-  | Zneg p =>
-      match p with
-      | xI q => (Zneg q - 1)%Z
-      | xO q => Zneg q
-      | xH => (-1)%Z
-      end
-  end.
-
-
-Lemma Zmod2_twice :
- forall z:Z, z = (2 * Zmod2 z + bit_value (Zeven.Zodd_bool z))%Z.
-Proof.
-	destruct z; simpl in |- *.
-	trivial.
-
-	destruct p; simpl in |- *; trivial.
-
-	destruct p; simpl in |- *.
-	destruct p as [p| p| ]; simpl in |- *.
-	rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial.
-
-	trivial.
-
-	trivial.
-
-	trivial.
-
-	trivial.
-Qed.
-
-Lemma Z_to_binary : forall n:nat, Z -> Bvector n.
-Proof.
-	simple induction n; intros.
-	exact Bnil.
-
-	exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))).
-Defined.
-
-(*
-Eval Compute in (Z_to_binary (5) `5`).
-     = (Vcons bool true (4)
-          (Vcons bool false (3)
-            (Vcons bool true (2)
-              (Vcons bool false (1) (Vcons bool false (0) (Vnil bool))))))
-     :  (Bvector (5))
+(** On calcule la valeur binaire selon un schema de Horner.
+    Le calcul s'arrete à  la longueur du vecteur sans vérification.
+    On definit une fonction Zmod2 calquee sur Zdiv2 mais donnant le quotient
+    de la division z=2q+r avec 0<=r<=1.
+    La valeur en complément à  deux est calculée selon un schema de Horner
+    avec Zmod2, le paramètre est la taille moins un.
 *)
 
-Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n).
-Proof.
-	simple induction n; intros.
-	exact (Bcons (Zeven.Zodd_bool H) 0 Bnil).
-
-	exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))).
-Defined.
-
-(*
-Eval Compute in (Z_to_two_compl (3) `0`).
-     =  (Vcons bool false (3)
-          (Vcons bool false (2)
-            (Vcons bool false (1) (Vcons bool false (0) (Vnil bool)))))
-     :  (vector bool (4))
-
-Eval Compute in (Z_to_two_compl (3) `5`).
-     = (Vcons bool true (3)
-          (Vcons bool false (2)
-            (Vcons bool true (1) (Vcons bool false (0) (Vnil bool)))))
-     :  (vector bool (4))
-
-Eval Compute in (Z_to_two_compl (3) `-5`).
-     =  (Vcons bool true (3)
-          (Vcons bool true (2)
-            (Vcons bool false (1) (Vcons bool true (0) (Vnil bool)))))
-     :  (vector bool (4))
-*)	
+  Definition Zmod2 (z:Z) :=
+    match z with
+      | Z0 => 0%Z
+      | Zpos p => match p with
+		    | xI q => Zpos q
+		    | xO q => Zpos q
+		    | xH => 0%Z
+		  end
+      | Zneg p =>
+	match p with
+	  | xI q => (Zneg q - 1)%Z
+	  | xO q => Zneg q
+	  | xH => (-1)%Z
+	end
+    end.
+
+
+  Lemma Zmod2_twice :
+    forall z:Z, z = (2 * Zmod2 z + bit_value (Zeven.Zodd_bool z))%Z.
+  Proof.
+    destruct z; simpl in |- *.
+    trivial.
+    
+    destruct p; simpl in |- *; trivial.
+    
+    destruct p; simpl in |- *.
+    destruct p as [p| p| ]; simpl in |- *.
+    rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial.
+
+    trivial.
+    
+    trivial.
+    
+    trivial.
+    
+    trivial.
+  Qed.
+
+  Lemma Z_to_binary : forall n:nat, Z -> Bvector n.
+  Proof.
+    simple induction n; intros.
+    exact Bnil.
+    
+    exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))).
+  Defined.
+
+  Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n).
+  Proof.
+    simple induction n; intros.
+    exact (Bcons (Zeven.Zodd_bool H) 0 Bnil).
+    
+    exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))).
+  Defined.
 
 End ENCODING_VALUE.
 
 Section Z_BRIC_A_BRAC.
 
-(*
-Bibliotheque de lemmes utiles dans la section suivante.
-Utilise largement ZArith.
-Meriterait d'etre reecrite.
-*)
-
-Lemma binary_value_Sn :
- forall (n:nat) (b:bool) (bv:Bvector n),
-   binary_value (S n) (Vcons bool b n bv) =
-   (bit_value b + 2 * binary_value n bv)%Z.
-Proof.
-	intros; auto.
-Qed.
-
-Lemma Z_to_binary_Sn :
- forall (n:nat) (b:bool) (z:Z),
-   (z >= 0)%Z ->
-   Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z).
-Proof.
-	destruct b; destruct z; simpl in |- *; auto.
-	intro H; elim H; trivial.
-Qed.
-
-Lemma binary_value_pos :
- forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z.
-Proof.
-	induction bv as [| a n v IHbv]; simpl in |- *.
-	omega.
-
-	destruct a; destruct (binary_value n v); simpl in |- *; auto.
-	auto with zarith.
-Qed.
-
-
-Lemma two_compl_value_Sn :
- forall (n:nat) (bv:Bvector (S n)) (b:bool),
-   two_compl_value (S n) (Bcons b (S n) bv) =
-   (bit_value b + 2 * two_compl_value n bv)%Z.
-Proof.
-	intros; auto.
-Qed.
-
-Lemma Z_to_two_compl_Sn :
- forall (n:nat) (b:bool) (z:Z),
-   Z_to_two_compl (S n) (bit_value b + 2 * z) =
-   Bcons b (S n) (Z_to_two_compl n z).
-Proof.
-	destruct b; destruct z as [| p| p]; auto.
-	destruct p as [p| p| ]; auto.
-	destruct p as [p| p| ]; simpl in |- *; auto.
-	intros; rewrite (Psucc_o_double_minus_one_eq_xO p); trivial.
-Qed.
-
-Lemma Z_to_binary_Sn_z :
- forall (n:nat) (z:Z),
-   Z_to_binary (S n) z =
-   Bcons (Zeven.Zodd_bool z) n (Z_to_binary n (Zeven.Zdiv2 z)).
-Proof.
-	intros; auto.
-Qed.
-
-Lemma Z_div2_value :
- forall z:Z,
-   (z >= 0)%Z -> (bit_value (Zeven.Zodd_bool z) + 2 * Zeven.Zdiv2 z)%Z = z.
-Proof.
-	destruct z as [| p| p]; auto.
-	destruct p; auto.
-  intro H; elim H; trivial.
-Qed.
-
-Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Zeven.Zdiv2 z >= 0)%Z.
-Proof.
-	destruct z as [| p| p].
-	auto.
-
-	destruct p; auto.
-	simpl in |- *; intros; omega.
-
-  intro H; elim H; trivial.
-
-Qed.
-
-Lemma Zdiv2_two_power_nat :
- forall (z:Z) (n:nat),
-   (z >= 0)%Z ->
-   (z < two_power_nat (S n))%Z -> (Zeven.Zdiv2 z < two_power_nat n)%Z.
-Proof.
-	intros.
-	cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros.
-	omega.
-
-	rewrite <- two_power_nat_S.
-	destruct (Zeven.Zeven_odd_dec z); intros.
-	rewrite <- Zeven.Zeven_div2; auto.
-
-	generalize (Zeven.Zodd_div2 z H z0); omega.
-Qed.
-
-(*
-
-Lemma Z_minus_one_or_zero : (z:Z)
-	`z >= -1` ->
-	`z < 1` ->
-	{`z=-1`} + {`z=0`}.
-Proof.
-	NewDestruct z; Auto.
-	NewDestruct p; Auto.
-	Tauto.
-
-	Tauto.
-
-	Intros.
-	Right; Omega.
-
-	NewDestruct p.
-	Tauto.
-
-	Tauto.
-
-	Intros; Left; Omega.
-Save.
-*)
-
-Lemma Z_to_two_compl_Sn_z :
- forall (n:nat) (z:Z),
-   Z_to_two_compl (S n) z =
-   Bcons (Zeven.Zodd_bool z) (S n) (Z_to_two_compl n (Zmod2 z)).
-Proof.
-	intros; auto.
-Qed.
-
-Lemma Zeven_bit_value :
- forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z.
-Proof.
-	destruct z; unfold bit_value in |- *; auto.
-	destruct p; tauto || (intro H; elim H).
- 	destruct p; tauto || (intro H; elim H).
-Qed.
-
-Lemma Zodd_bit_value :
- forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z.
-Proof.
-	destruct z; unfold bit_value in |- *; auto.
-  intros; elim H.
-  destruct p; tauto || (intros; elim H).
-  destruct p; tauto || (intros; elim H).
-Qed.
-
-Lemma Zge_minus_two_power_nat_S :
- forall (n:nat) (z:Z),
-   (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z.
-Proof.
-	intros n z; rewrite (two_power_nat_S n).
-	generalize (Zmod2_twice z).
-	destruct (Zeven.Zeven_odd_dec z) as [H| H].
-	rewrite (Zeven_bit_value z H); intros; omega.
-
-        rewrite (Zodd_bit_value z H); intros; omega.
-Qed.
-
-Lemma Zlt_two_power_nat_S :
- forall (n:nat) (z:Z),
-   (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z.
-Proof.
-	intros n z; rewrite (two_power_nat_S n).
-	generalize (Zmod2_twice z).
-	destruct (Zeven.Zeven_odd_dec z) as [H| H].
-	rewrite (Zeven_bit_value z H); intros; omega.
-
-	rewrite (Zodd_bit_value z H); intros; omega.
-Qed.
+  (** Bibliotheque de lemmes utiles dans la section suivante.
+      Utilise largement ZArith.
+      Mériterait d'être récrite.
+  *)
+
+  Lemma binary_value_Sn :
+    forall (n:nat) (b:bool) (bv:Bvector n),
+      binary_value (S n) (Vcons bool b n bv) =
+      (bit_value b + 2 * binary_value n bv)%Z.
+  Proof.
+    intros; auto.
+  Qed.
+
+  Lemma Z_to_binary_Sn :
+    forall (n:nat) (b:bool) (z:Z),
+      (z >= 0)%Z ->
+      Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z).
+  Proof.
+    destruct b; destruct z; simpl in |- *; auto.
+    intro H; elim H; trivial.
+  Qed.
+
+  Lemma binary_value_pos :
+    forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z.
+  Proof.
+    induction bv as [| a n v IHbv]; simpl in |- *.
+    omega.
+
+    destruct a; destruct (binary_value n v); simpl in |- *; auto.
+    auto with zarith.
+  Qed.
+
+  Lemma two_compl_value_Sn :
+    forall (n:nat) (bv:Bvector (S n)) (b:bool),
+      two_compl_value (S n) (Bcons b (S n) bv) =
+      (bit_value b + 2 * two_compl_value n bv)%Z.
+  Proof.
+    intros; auto.
+  Qed.
+
+  Lemma Z_to_two_compl_Sn :
+    forall (n:nat) (b:bool) (z:Z),
+      Z_to_two_compl (S n) (bit_value b + 2 * z) =
+      Bcons b (S n) (Z_to_two_compl n z).
+  Proof.
+    destruct b; destruct z as [| p| p]; auto.
+    destruct p as [p| p| ]; auto.
+    destruct p as [p| p| ]; simpl in |- *; auto.
+    intros; rewrite (Psucc_o_double_minus_one_eq_xO p); trivial.
+  Qed.
+
+  Lemma Z_to_binary_Sn_z :
+    forall (n:nat) (z:Z),
+      Z_to_binary (S n) z =
+      Bcons (Zeven.Zodd_bool z) n (Z_to_binary n (Zeven.Zdiv2 z)).
+  Proof.
+    intros; auto.
+  Qed.
+
+  Lemma Z_div2_value :
+    forall z:Z,
+      (z >= 0)%Z -> (bit_value (Zeven.Zodd_bool z) + 2 * Zeven.Zdiv2 z)%Z = z.
+  Proof.
+    destruct z as [| p| p]; auto.
+    destruct p; auto.
+    intro H; elim H; trivial.
+  Qed.
+
+  Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Zeven.Zdiv2 z >= 0)%Z.
+  Proof.
+    destruct z as [| p| p].
+    auto.
+    
+    destruct p; auto.
+    simpl in |- *; intros; omega.
+    
+    intro H; elim H; trivial.
+  Qed.
+
+  Lemma Zdiv2_two_power_nat :
+    forall (z:Z) (n:nat),
+      (z >= 0)%Z ->
+      (z < two_power_nat (S n))%Z -> (Zeven.Zdiv2 z < two_power_nat n)%Z.
+  Proof.
+    intros.
+    cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros.
+    omega.
+    
+    rewrite <- two_power_nat_S.
+    destruct (Zeven.Zeven_odd_dec z); intros.
+    rewrite <- Zeven.Zeven_div2; auto.
+    
+    generalize (Zeven.Zodd_div2 z H z0); omega.
+  Qed.
+
+  Lemma Z_to_two_compl_Sn_z :
+    forall (n:nat) (z:Z),
+      Z_to_two_compl (S n) z =
+      Bcons (Zeven.Zodd_bool z) (S n) (Z_to_two_compl n (Zmod2 z)).
+  Proof.
+    intros; auto.
+  Qed.
+  
+  Lemma Zeven_bit_value :
+    forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z.
+  Proof.
+    destruct z; unfold bit_value in |- *; auto.
+    destruct p; tauto || (intro H; elim H).
+    destruct p; tauto || (intro H; elim H).
+  Qed.
+  
+  Lemma Zodd_bit_value :
+    forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z.
+  Proof.
+    destruct z; unfold bit_value in |- *; auto.
+    intros; elim H.
+    destruct p; tauto || (intros; elim H).
+    destruct p; tauto || (intros; elim H).
+  Qed.
+  
+  Lemma Zge_minus_two_power_nat_S :
+    forall (n:nat) (z:Z),
+      (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z.
+  Proof.
+    intros n z; rewrite (two_power_nat_S n).
+    generalize (Zmod2_twice z).
+    destruct (Zeven.Zeven_odd_dec z) as [H| H].
+    rewrite (Zeven_bit_value z H); intros; omega.
+
+    rewrite (Zodd_bit_value z H); intros; omega.
+  Qed.
+  
+  Lemma Zlt_two_power_nat_S :
+    forall (n:nat) (z:Z),
+      (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z.
+  Proof.
+    intros n z; rewrite (two_power_nat_S n).
+    generalize (Zmod2_twice z).
+    destruct (Zeven.Zeven_odd_dec z) as [H| H].
+    rewrite (Zeven_bit_value z H); intros; omega.
+
+    rewrite (Zodd_bit_value z H); intros; omega.
+  Qed.
 
 End Z_BRIC_A_BRAC.
 
 Section COHERENT_VALUE.
 
-(*
-On vérifie que dans l'intervalle de définition les fonctions sont 
-réciproques l'une de l'autre.
-Elles utilisent les lemmes du bric-a-brac.
+(** On vérifie que dans l'intervalle de définition les fonctions sont 
+    réciproques l'une de l'autre. Elles utilisent les lemmes du bric-a-brac.
 *)
 
-Lemma binary_to_Z_to_binary :
- forall (n:nat) (bv:Bvector n), Z_to_binary n (binary_value n bv) = bv.
-Proof.
-	induction bv as [| a n bv IHbv].
-	auto.
-
-	rewrite binary_value_Sn.
-	rewrite Z_to_binary_Sn.
-	rewrite IHbv; trivial.
-
-	apply binary_value_pos.
-Qed.
-		
-Lemma two_compl_to_Z_to_two_compl :
- forall (n:nat) (bv:Bvector n) (b:bool),
-   Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv.
-Proof.
-	induction bv as [| a n bv IHbv]; intro b.
-	destruct b; auto.
-
-	rewrite two_compl_value_Sn.
-	rewrite Z_to_two_compl_Sn.
-	rewrite IHbv; trivial.
-Qed.
-
-Lemma Z_to_binary_to_Z :
- forall (n:nat) (z:Z),
-   (z >= 0)%Z ->
-   (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z.
-Proof.
-	induction n as [| n IHn].
-	unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega.
-
-	intros; rewrite Z_to_binary_Sn_z.
-	rewrite binary_value_Sn.
-	rewrite IHn.
-	apply Z_div2_value; auto.
-
-	apply Pdiv2; trivial.
-
-	apply Zdiv2_two_power_nat; trivial.
-Qed.
-
-Lemma Z_to_two_compl_to_Z :
- forall (n:nat) (z:Z),
-   (z >= - two_power_nat n)%Z ->
-   (z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z.
-Proof.
-	induction n as [| n IHn].
-	unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros.
-	assert (z = (-1)%Z \/ z = 0%Z). omega.
-intuition; subst z; trivial.
-
-	intros; rewrite Z_to_two_compl_Sn_z.
-	rewrite two_compl_value_Sn.
-	rewrite IHn.
-	generalize (Zmod2_twice z); omega.
-
-	apply Zge_minus_two_power_nat_S; auto.
-
-	apply Zlt_two_power_nat_S; auto.
-Qed.
+  Lemma binary_to_Z_to_binary :
+    forall (n:nat) (bv:Bvector n), Z_to_binary n (binary_value n bv) = bv.
+  Proof.
+    induction bv as [| a n bv IHbv].
+    auto.
+    
+    rewrite binary_value_Sn.
+    rewrite Z_to_binary_Sn.
+    rewrite IHbv; trivial.
+    
+    apply binary_value_pos.
+  Qed.
+  
+  Lemma two_compl_to_Z_to_two_compl :
+    forall (n:nat) (bv:Bvector n) (b:bool),
+      Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv.
+  Proof.
+    induction bv as [| a n bv IHbv]; intro b.
+    destruct b; auto.
+    
+    rewrite two_compl_value_Sn.
+    rewrite Z_to_two_compl_Sn.
+    rewrite IHbv; trivial.
+  Qed.
+  
+  Lemma Z_to_binary_to_Z :
+    forall (n:nat) (z:Z),
+      (z >= 0)%Z ->
+      (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z.
+  Proof.
+    induction n as [| n IHn].
+    unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega.
+    
+    intros; rewrite Z_to_binary_Sn_z.
+    rewrite binary_value_Sn.
+    rewrite IHn.
+    apply Z_div2_value; auto.
+    
+    apply Pdiv2; trivial.
+    
+    apply Zdiv2_two_power_nat; trivial.
+  Qed.
+  
+  Lemma Z_to_two_compl_to_Z :
+    forall (n:nat) (z:Z),
+      (z >= - two_power_nat n)%Z ->
+      (z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z.
+  Proof.
+    induction n as [| n IHn].
+    unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros.
+    assert (z = (-1)%Z \/ z = 0%Z). omega.
+    intuition; subst z; trivial.
+
+    intros; rewrite Z_to_two_compl_Sn_z.
+    rewrite two_compl_value_Sn.
+    rewrite IHn.
+    generalize (Zmod2_twice z); omega.
+
+    apply Zge_minus_two_power_nat_S; auto.
+    
+    apply Zlt_two_power_nat_S; auto.
+  Qed.
 
 End COHERENT_VALUE.
diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v
index bb8abef4..7da91c44 100644
--- a/theories/ZArith/Zbool.v
+++ b/theories/ZArith/Zbool.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zbool.v,v 1.4.2.1 2004/07/16 19:31:21 herbelin Exp $ *)
+(* $Id: Zbool.v 9245 2006-10-17 12:53:34Z notin $ *)
 
 Require Import BinInt.
 Require Import Zeven.
@@ -15,6 +15,10 @@ Require Import Zcompare.
 Require Import ZArith_dec.
 Require Import Sumbool.
 
+Unset Boxed Definitions.
+
+
+(** * Boolean operations from decidabilty of order *)
 (** The decidability of equality and order relations over
     type [Z] give some boolean functions with the adequate specification. *)
 
@@ -30,65 +34,70 @@ Definition Z_noteq_bool (x y:Z) := bool_of_sumbool (Z_noteq_dec x y).
 Definition Zeven_odd_bool (x:Z) := bool_of_sumbool (Zeven_odd_dec x).
 
 (**********************************************************************)
-(** Boolean comparisons of binary integers *)
+(** * Boolean comparisons of binary integers *)
 
 Definition Zle_bool (x y:Z) :=
   match (x ?= y)%Z with
-  | Gt => false
-  | _ => true
+    | Gt => false
+    | _ => true
   end.
+
 Definition Zge_bool (x y:Z) :=
   match (x ?= y)%Z with
-  | Lt => false
-  | _ => true
+    | Lt => false
+    | _ => true
   end.
+
 Definition Zlt_bool (x y:Z) :=
   match (x ?= y)%Z with
-  | Lt => true
-  | _ => false
+    | Lt => true
+    | _ => false
   end.
+
 Definition Zgt_bool (x y:Z) :=
   match (x ?= y)%Z with
-  | Gt => true
-  | _ => false
+    | Gt => true
+    | _ => false
   end.
+
 Definition Zeq_bool (x y:Z) :=
   match (x ?= y)%Z with
-  | Eq => true
-  | _ => false
+    | Eq => true
+    | _ => false
   end.
+
 Definition Zneq_bool (x y:Z) :=
   match (x ?= y)%Z with
-  | Eq => false
-  | _ => true
+    | Eq => false
+    | _ => true
   end.
 
 Lemma Zle_cases :
- forall n m:Z, if Zle_bool n m then (n <= m)%Z else (n > m)%Z.
+  forall n m:Z, if Zle_bool n m then (n <= m)%Z else (n > m)%Z.
 Proof.
-intros x y; unfold Zle_bool, Zle, Zgt in |- *.
-case (x ?= y)%Z; auto; discriminate.
+  intros x y; unfold Zle_bool, Zle, Zgt in |- *.
+  case (x ?= y)%Z; auto; discriminate.
 Qed.
 
 Lemma Zlt_cases :
- forall n m:Z, if Zlt_bool n m then (n < m)%Z else (n >= m)%Z.
+  forall n m:Z, if Zlt_bool n m then (n < m)%Z else (n >= m)%Z.
 Proof.
-intros x y; unfold Zlt_bool, Zlt, Zge in |- *.
-case (x ?= y)%Z; auto; discriminate.
+  intros x y; unfold Zlt_bool, Zlt, Zge in |- *.
+  case (x ?= y)%Z; auto; discriminate.
 Qed.
 
 Lemma Zge_cases :
- forall n m:Z, if Zge_bool n m then (n >= m)%Z else (n < m)%Z.
+  forall n m:Z, if Zge_bool n m then (n >= m)%Z else (n < m)%Z.
 Proof.
-intros x y; unfold Zge_bool, Zge, Zlt in |- *.
-case (x ?= y)%Z; auto; discriminate.
+  intros x y; unfold Zge_bool, Zge, Zlt in |- *.
+  case (x ?= y)%Z; auto; discriminate.
 Qed.
 
 Lemma Zgt_cases :
- forall n m:Z, if Zgt_bool n m then (n > m)%Z else (n <= m)%Z.
+  forall n m:Z, if Zgt_bool n m then (n > m)%Z else (n <= m)%Z.
 Proof.
-intros x y; unfold Zgt_bool, Zgt, Zle in |- *.
-case (x ?= y)%Z; auto; discriminate.
+  intros x y; unfold Zgt_bool, Zgt, Zle in |- *.
+  case (x ?= y)%Z; auto; discriminate.
 Qed.
 
 (** Lemmas on [Zle_bool] used in contrib/graphs *)
@@ -110,15 +119,15 @@ Proof.
 Qed.
 
 Lemma Zle_bool_antisym :
- forall n m:Z, Zle_bool n m = true -> Zle_bool m n = true -> n = m.
+  forall n m:Z, Zle_bool n m = true -> Zle_bool m n = true -> n = m.
 Proof.
   intros. apply Zle_antisym. apply Zle_bool_imp_le. assumption.
   apply Zle_bool_imp_le. assumption.
 Qed.
 
 Lemma Zle_bool_trans :
- forall n m p:Z,
-   Zle_bool n m = true -> Zle_bool m p = true -> Zle_bool n p = true.
+  forall n m p:Z,
+    Zle_bool n m = true -> Zle_bool m p = true -> Zle_bool n p = true.
 Proof.
   intros x y z; intros. apply Zle_imp_le_bool. apply Zle_trans with (m := y). apply Zle_bool_imp_le. assumption.
   apply Zle_bool_imp_le. assumption.
@@ -135,9 +144,9 @@ Proof.
 Defined.
 
 Lemma Zle_bool_plus_mono :
- forall n m p q:Z,
-   Zle_bool n m = true ->
-   Zle_bool p q = true -> Zle_bool (n + p) (m + q) = true.
+  forall n m p q:Z,
+    Zle_bool n m = true ->
+    Zle_bool p q = true -> Zle_bool (n + p) (m + q) = true.
 Proof.
   intros. apply Zle_imp_le_bool. apply Zplus_le_compat. apply Zle_bool_imp_le. assumption.
   apply Zle_bool_imp_le. assumption.
@@ -157,30 +166,30 @@ Proof.
 Qed.
 
 
- Lemma Zle_is_le_bool : forall n m:Z, (n <= m)%Z <-> Zle_bool n m = true.
-  Proof.
-    intros. split. intro. apply Zle_imp_le_bool. assumption.
-    intro. apply Zle_bool_imp_le. assumption.
-  Qed.
-
-  Lemma Zge_is_le_bool : forall n m:Z, (n >= m)%Z <-> Zle_bool m n = true.
-  Proof.
-    intros. split. intro. apply Zle_imp_le_bool. apply Zge_le. assumption.
-    intro. apply Zle_ge. apply Zle_bool_imp_le. assumption.
-  Qed.
-
-  Lemma Zlt_is_le_bool :
-   forall n m:Z, (n < m)%Z <-> Zle_bool n (m - 1) = true.
-  Proof.
-    intros x y. split. intro. apply Zle_imp_le_bool. apply Zlt_succ_le. rewrite (Zsucc_pred y) in H.
-    assumption.
-    intro. rewrite (Zsucc_pred y). apply Zle_lt_succ. apply Zle_bool_imp_le. assumption.
-  Qed.
-
-  Lemma Zgt_is_le_bool :
-   forall n m:Z, (n > m)%Z <-> Zle_bool m (n - 1) = true.
-  Proof.
-    intros x y. apply iff_trans with (y < x)%Z. split. exact (Zgt_lt x y).
-    exact (Zlt_gt y x).
-    exact (Zlt_is_le_bool y x).
-  Qed.
+Lemma Zle_is_le_bool : forall n m:Z, (n <= m)%Z <-> Zle_bool n m = true.
+Proof.
+  intros. split. intro. apply Zle_imp_le_bool. assumption.
+  intro. apply Zle_bool_imp_le. assumption.
+Qed.
+
+Lemma Zge_is_le_bool : forall n m:Z, (n >= m)%Z <-> Zle_bool m n = true.
+Proof.
+  intros. split. intro. apply Zle_imp_le_bool. apply Zge_le. assumption.
+  intro. apply Zle_ge. apply Zle_bool_imp_le. assumption.
+Qed.
+
+Lemma Zlt_is_le_bool :
+  forall n m:Z, (n < m)%Z <-> Zle_bool n (m - 1) = true.
+Proof.
+  intros x y. split. intro. apply Zle_imp_le_bool. apply Zlt_succ_le. rewrite (Zsucc_pred y) in H.
+  assumption.
+  intro. rewrite (Zsucc_pred y). apply Zle_lt_succ. apply Zle_bool_imp_le. assumption.
+Qed.
+
+Lemma Zgt_is_le_bool :
+  forall n m:Z, (n > m)%Z <-> Zle_bool m (n - 1) = true.
+Proof.
+  intros x y. apply iff_trans with (y < x)%Z. split. exact (Zgt_lt x y).
+  exact (Zlt_gt y x).
+  exact (Zlt_is_le_bool y x).
+Qed.
diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v
index 714abfc4..6c5b07d2 100644
--- a/theories/ZArith/Zcompare.v
+++ b/theories/ZArith/Zcompare.v
@@ -8,6 +8,10 @@
 
 (*i $$ i*)
 
+(**********************************************************************)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
+(**********************************************************************)
+
 Require Export BinPos.
 Require Export BinInt.
 Require Import Lt.
@@ -17,485 +21,480 @@ Require Import Mult.
 
 Open Local Scope Z_scope.
 
-(**********************************************************************)
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
-(**********************************************************************)
-
-(**********************************************************************)
-(** Comparison on integers *)
+(***************************)
+(** * Comparison on integers *)
 
 Lemma Zcompare_refl : forall n:Z, (n ?= n) = Eq.
 Proof.
-intro x; destruct x as [| p| p]; simpl in |- *;
- [ reflexivity | apply Pcompare_refl | rewrite Pcompare_refl; reflexivity ].
+  intro x; destruct x as [| p| p]; simpl in |- *;
+    [ reflexivity | apply Pcompare_refl | rewrite Pcompare_refl; reflexivity ].
 Qed.
 
 Lemma Zcompare_Eq_eq : forall n m:Z, (n ?= m) = Eq -> n = m.
 Proof.
-intros x y; destruct x as [| x'| x']; destruct y as [| y'| y']; simpl in |- *;
- intro H; reflexivity || (try discriminate H);
- [ rewrite (Pcompare_Eq_eq x' y' H); reflexivity
- | rewrite (Pcompare_Eq_eq x' y');
-    [ reflexivity
-    | destruct ((x' ?= y')%positive Eq); reflexivity || discriminate ] ].
+  intros x y; destruct x as [| x'| x']; destruct y as [| y'| y']; simpl in |- *;
+    intro H; reflexivity || (try discriminate H);
+      [ rewrite (Pcompare_Eq_eq x' y' H); reflexivity
+	| rewrite (Pcompare_Eq_eq x' y');
+	  [ reflexivity
+	    | destruct ((x' ?= y')%positive Eq); reflexivity || discriminate ] ].
 Qed.
 
 Lemma Zcompare_Eq_iff_eq : forall n m:Z, (n ?= m) = Eq <-> n = m.
 Proof.
-intros x y; split; intro E;
- [ apply Zcompare_Eq_eq; assumption | rewrite E; apply Zcompare_refl ].
+  intros x y; split; intro E;
+    [ apply Zcompare_Eq_eq; assumption | rewrite E; apply Zcompare_refl ].
 Qed.
 
 Lemma Zcompare_antisym : forall n m:Z, CompOpp (n ?= m) = (m ?= n).
 Proof.
-intros x y; destruct x; destruct y; simpl in |- *;
- reflexivity || discriminate H || rewrite Pcompare_antisym; 
- reflexivity.
+  intros x y; destruct x; destruct y; simpl in |- *;
+    reflexivity || discriminate H || rewrite Pcompare_antisym; 
+      reflexivity.
 Qed.
 
 Lemma Zcompare_Gt_Lt_antisym : forall n m:Z, (n ?= m) = Gt <-> (m ?= n) = Lt.
 Proof.
-intros x y; split; intro H;
- [ change Lt with (CompOpp Gt) in |- *; rewrite <- Zcompare_antisym;
-    rewrite H; reflexivity
- | change Gt with (CompOpp Lt) in |- *; rewrite <- Zcompare_antisym;
-    rewrite H; reflexivity ].
+  intros x y; split; intro H;
+    [ change Lt with (CompOpp Gt) in |- *; rewrite <- Zcompare_antisym;
+      rewrite H; reflexivity
+      | change Gt with (CompOpp Lt) in |- *; rewrite <- Zcompare_antisym;
+	rewrite H; reflexivity ].
 Qed.
 
-(** Transitivity of comparison *)
+(** * Transitivity of comparison *)
 
 Lemma Zcompare_Gt_trans :
- forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt.
+  forall n m p:Z, (n ?= m) = Gt -> (m ?= p) = Gt -> (n ?= p) = Gt.
 Proof.
-intros x y z; case x; case y; case z; simpl in |- *;
- try (intros; discriminate H || discriminate H0); auto with arith;
- [ intros p q r H H0; apply nat_of_P_gt_Gt_compare_complement_morphism;
-    unfold gt in |- *; apply lt_trans with (m := nat_of_P q);
-    apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; 
-    assumption
- | intros p q r; do 3 rewrite <- ZC4; intros H H0;
-    apply nat_of_P_gt_Gt_compare_complement_morphism; 
-    unfold gt in |- *; apply lt_trans with (m := nat_of_P q);
-    apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; 
-    assumption ].
+  intros x y z; case x; case y; case z; simpl in |- *;
+    try (intros; discriminate H || discriminate H0); auto with arith;
+      [ intros p q r H H0; apply nat_of_P_gt_Gt_compare_complement_morphism;
+	unfold gt in |- *; apply lt_trans with (m := nat_of_P q);
+	  apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; 
+	    assumption
+	| intros p q r; do 3 rewrite <- ZC4; intros H H0;
+	  apply nat_of_P_gt_Gt_compare_complement_morphism; 
+	    unfold gt in |- *; apply lt_trans with (m := nat_of_P q);
+	      apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; 
+		assumption ].
 Qed.
 
-(** Comparison and opposite *)
+(** * Comparison and opposite *)
 
 Lemma Zcompare_opp : forall n m:Z, (n ?= m) = (- m ?= - n).
 Proof.
-intros x y; case x; case y; simpl in |- *; auto with arith; intros;
- rewrite <- ZC4; trivial with arith.
+  intros x y; case x; case y; simpl in |- *; auto with arith; intros;
+    rewrite <- ZC4; trivial with arith.
 Qed.
 
 Hint Local Resolve Pcompare_refl.
 
-(** Comparison first-order specification *)
+(** * Comparison first-order specification *)
 
 Lemma Zcompare_Gt_spec :
- forall n m:Z, (n ?= m) = Gt ->  exists h : positive, n + - m = Zpos h.
+  forall n m:Z, (n ?= m) = Gt ->  exists h : positive, n + - m = Zpos h.
 Proof.
-intros x y; case x; case y;
- [ simpl in |- *; intros H; discriminate H
- | simpl in |- *; intros p H; discriminate H
- | intros p H; exists p; simpl in |- *; auto with arith
- | intros p H; exists p; simpl in |- *; auto with arith
- | intros q p H; exists (p - q)%positive; unfold Zplus, Zopp in |- *;
-    unfold Zcompare in H; rewrite H; trivial with arith
- | intros q p H; exists (p + q)%positive; simpl in |- *; trivial with arith
- | simpl in |- *; intros p H; discriminate H
- | simpl in |- *; intros q p H; discriminate H
- | unfold Zcompare in |- *; intros q p; rewrite <- ZC4; intros H;
-    exists (q - p)%positive; simpl in |- *; rewrite (ZC1 q p H);
-    trivial with arith ].
+  intros x y; case x; case y;
+    [ simpl in |- *; intros H; discriminate H
+      | simpl in |- *; intros p H; discriminate H
+      | intros p H; exists p; simpl in |- *; auto with arith
+      | intros p H; exists p; simpl in |- *; auto with arith
+      | intros q p H; exists (p - q)%positive; unfold Zplus, Zopp in |- *;
+	unfold Zcompare in H; rewrite H; trivial with arith
+      | intros q p H; exists (p + q)%positive; simpl in |- *; trivial with arith
+      | simpl in |- *; intros p H; discriminate H
+      | simpl in |- *; intros q p H; discriminate H
+      | unfold Zcompare in |- *; intros q p; rewrite <- ZC4; intros H;
+	exists (q - p)%positive; simpl in |- *; rewrite (ZC1 q p H);
+	  trivial with arith ].
 Qed.
 
-(** Comparison and addition *)
+(** * Comparison and addition *)
 
 Lemma weaken_Zcompare_Zplus_compatible :
- (forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m)) ->
- forall n m p:Z, (p + n ?= p + m) = (n ?= m).
+  (forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m)) ->
+  forall n m p:Z, (p + n ?= p + m) = (n ?= m).
 Proof.
-intros H x y z; destruct z;
- [ reflexivity
- | apply H
- | rewrite (Zcompare_opp x y); rewrite Zcompare_opp;
-    do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; 
-    apply H ].
+  intros H x y z; destruct z;
+    [ reflexivity
+      | apply H
+      | rewrite (Zcompare_opp x y); rewrite Zcompare_opp;
+	do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; 
+	  apply H ].
 Qed.
 
 Hint Local Resolve ZC4.
 
 Lemma weak_Zcompare_Zplus_compatible :
- forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m).
+  forall (n m:Z) (p:positive), (Zpos p + n ?= Zpos p + m) = (n ?= m).
 Proof.
-intros x y z; case x; case y; simpl in |- *; auto with arith;
- [ intros p; apply nat_of_P_lt_Lt_compare_complement_morphism; apply ZL17
- | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith;
-    apply nat_of_P_gt_Gt_compare_complement_morphism;
-    rewrite nat_of_P_minus_morphism;
-    [ unfold gt in |- *; apply ZL16 | assumption ]
- | intros p; ElimPcompare z p; intros E; auto with arith;
-    apply nat_of_P_gt_Gt_compare_complement_morphism; 
-    unfold gt in |- *; apply ZL17
- | intros p q; ElimPcompare q p; intros E; rewrite E;
-    [ rewrite (Pcompare_Eq_eq q p E); apply Pcompare_refl
-    | apply nat_of_P_lt_Lt_compare_complement_morphism;
-       do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l;
-       apply nat_of_P_lt_Lt_compare_morphism with (1 := E)
-    | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *;
-       do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l;
-       exact (nat_of_P_gt_Gt_compare_morphism q p E) ]
- | intros p q; ElimPcompare z p; intros E; rewrite E; auto with arith;
-    apply nat_of_P_gt_Gt_compare_complement_morphism;
-    rewrite nat_of_P_minus_morphism;
-    [ unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
-       [ apply ZL16 | apply ZL17 ]
-    | assumption ]
- | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith;
-    simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
-    rewrite nat_of_P_minus_morphism; [ apply ZL16 | assumption ]
- | intros p q; ElimPcompare z q; intros E; rewrite E; auto with arith;
-    simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
-    rewrite nat_of_P_minus_morphism;
-    [ apply lt_trans with (m := nat_of_P z); [ apply ZL16 | apply ZL17 ]
-    | assumption ]
- | intros p q; ElimPcompare z q; intros E0; rewrite E0; ElimPcompare z p;
-    intros E1; rewrite E1; ElimPcompare q p; intros E2; 
-    rewrite E2; auto with arith;
-    [ absurd ((q ?= p)%positive Eq = Lt);
-       [ rewrite <- (Pcompare_Eq_eq z q E0);
-          rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z);
-          discriminate
-       | assumption ]
-    | absurd ((q ?= p)%positive Eq = Gt);
-       [ rewrite <- (Pcompare_Eq_eq z q E0);
-          rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z);
-          discriminate
-       | assumption ]
-    | absurd ((z ?= p)%positive Eq = Lt);
-       [ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2);
-          rewrite (Pcompare_refl q); discriminate
-       | assumption ]
-    | absurd ((z ?= p)%positive Eq = Lt);
-       [ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate
-       | assumption ]
-    | absurd ((z ?= p)%positive Eq = Gt);
-       [ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2);
-          rewrite (Pcompare_refl q); discriminate
-       | assumption ]
-    | absurd ((z ?= p)%positive Eq = Gt);
-       [ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate
-       | assumption ]
-    | absurd ((z ?= q)%positive Eq = Lt);
-       [ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2);
-          rewrite (Pcompare_refl p); discriminate
-       | assumption ]
-    | absurd ((p ?= q)%positive Eq = Gt);
-       [ rewrite <- (Pcompare_Eq_eq z p E1); rewrite E0; discriminate
-       | apply ZC2; assumption ]
-    | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2);
-       rewrite (Pcompare_refl (p - z)); auto with arith
-    | simpl in |- *; rewrite <- ZC4;
-       apply nat_of_P_gt_Gt_compare_complement_morphism;
-       rewrite nat_of_P_minus_morphism;
-       [ rewrite nat_of_P_minus_morphism;
-          [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z);
-             rewrite le_plus_minus_r;
-             [ rewrite le_plus_minus_r;
-                [ apply nat_of_P_lt_Lt_compare_morphism; assumption
-                | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-                   assumption ]
-             | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-                assumption ]
-          | apply ZC2; assumption ]
-       | apply ZC2; assumption ]
-    | simpl in |- *; rewrite <- ZC4;
-       apply nat_of_P_lt_Lt_compare_complement_morphism;
-       rewrite nat_of_P_minus_morphism;
-       [ rewrite nat_of_P_minus_morphism;
-          [ apply plus_lt_reg_l with (p := nat_of_P z);
-             rewrite le_plus_minus_r;
-             [ rewrite le_plus_minus_r;
-                [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
-                   assumption
-                | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-                   assumption ]
-             | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-                assumption ]
-          | apply ZC2; assumption ]
-       | apply ZC2; assumption ]
-    | absurd ((z ?= q)%positive Eq = Lt);
-       [ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate
-       | assumption ]
-    | absurd ((q ?= p)%positive Eq = Lt);
-       [ cut ((q ?= p)%positive Eq = Gt);
-          [ intros E; rewrite E; discriminate
-          | apply nat_of_P_gt_Gt_compare_complement_morphism;
-             unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
-             [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
-             | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ]
-       | assumption ]
-    | absurd ((z ?= q)%positive Eq = Gt);
-       [ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2);
-          rewrite (Pcompare_refl p); discriminate
-       | assumption ]
-    | absurd ((z ?= q)%positive Eq = Gt);
-       [ rewrite (Pcompare_Eq_eq z p E1); rewrite ZC1;
-          [ discriminate | assumption ]
-       | assumption ]
-    | absurd ((z ?= q)%positive Eq = Gt);
-       [ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate
-       | assumption ]
-    | absurd ((q ?= p)%positive Eq = Gt);
-       [ rewrite ZC1;
-          [ discriminate
-          | apply nat_of_P_gt_Gt_compare_complement_morphism;
-             unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
-             [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
-             | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ]
-       | assumption ]
-    | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2); apply Pcompare_refl
-    | simpl in |- *; apply nat_of_P_gt_Gt_compare_complement_morphism;
-       unfold gt in |- *; rewrite nat_of_P_minus_morphism;
-       [ rewrite nat_of_P_minus_morphism;
-          [ apply plus_lt_reg_l with (p := nat_of_P p);
-             rewrite le_plus_minus_r;
-             [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P q);
-                rewrite plus_assoc; rewrite le_plus_minus_r;
-                [ rewrite (plus_comm (nat_of_P q)); apply plus_lt_compat_l;
-                   apply nat_of_P_lt_Lt_compare_morphism; 
-                   assumption
-                | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-                   apply ZC1; assumption ]
-             | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-                apply ZC1; assumption ]
-          | assumption ]
-       | assumption ]
-    | simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
-       rewrite nat_of_P_minus_morphism;
-       [ rewrite nat_of_P_minus_morphism;
-          [ apply plus_lt_reg_l with (p := nat_of_P q);
-             rewrite le_plus_minus_r;
-             [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p);
-                rewrite plus_assoc; rewrite le_plus_minus_r;
-                [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l;
-                   apply nat_of_P_lt_Lt_compare_morphism; 
-                   apply ZC1; assumption
-                | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-                   apply ZC1; assumption ]
-             | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
-                apply ZC1; assumption ]
-          | assumption ]
-       | assumption ] ] ].
+  intros x y z; case x; case y; simpl in |- *; auto with arith;
+    [ intros p; apply nat_of_P_lt_Lt_compare_complement_morphism; apply ZL17
+      | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith;
+	apply nat_of_P_gt_Gt_compare_complement_morphism;
+	  rewrite nat_of_P_minus_morphism;
+	    [ unfold gt in |- *; apply ZL16 | assumption ]
+      | intros p; ElimPcompare z p; intros E; auto with arith;
+	apply nat_of_P_gt_Gt_compare_complement_morphism; 
+	  unfold gt in |- *; apply ZL17
+      | intros p q; ElimPcompare q p; intros E; rewrite E;
+	[ rewrite (Pcompare_Eq_eq q p E); apply Pcompare_refl
+	  | apply nat_of_P_lt_Lt_compare_complement_morphism;
+	    do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l;
+	      apply nat_of_P_lt_Lt_compare_morphism with (1 := E)
+	  | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *;
+	    do 2 rewrite nat_of_P_plus_morphism; apply plus_lt_compat_l;
+	      exact (nat_of_P_gt_Gt_compare_morphism q p E) ]
+      | intros p q; ElimPcompare z p; intros E; rewrite E; auto with arith;
+	apply nat_of_P_gt_Gt_compare_complement_morphism;
+	  rewrite nat_of_P_minus_morphism;
+	    [ unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
+	      [ apply ZL16 | apply ZL17 ]
+	      | assumption ]
+      | intros p; ElimPcompare z p; intros E; rewrite E; auto with arith;
+	simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
+	  rewrite nat_of_P_minus_morphism; [ apply ZL16 | assumption ]
+      | intros p q; ElimPcompare z q; intros E; rewrite E; auto with arith;
+	simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
+	  rewrite nat_of_P_minus_morphism;
+	    [ apply lt_trans with (m := nat_of_P z); [ apply ZL16 | apply ZL17 ]
+	      | assumption ]
+      | intros p q; ElimPcompare z q; intros E0; rewrite E0; ElimPcompare z p;
+	intros E1; rewrite E1; ElimPcompare q p; intros E2; 
+	  rewrite E2; auto with arith;
+	    [ absurd ((q ?= p)%positive Eq = Lt);
+	      [ rewrite <- (Pcompare_Eq_eq z q E0);
+		rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z);
+		  discriminate
+		| assumption ]
+	      | absurd ((q ?= p)%positive Eq = Gt);
+		[ rewrite <- (Pcompare_Eq_eq z q E0);
+		  rewrite <- (Pcompare_Eq_eq z p E1); rewrite (Pcompare_refl z);
+		    discriminate
+		  | assumption ]
+	      | absurd ((z ?= p)%positive Eq = Lt);
+		[ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2);
+		  rewrite (Pcompare_refl q); discriminate
+		  | assumption ]
+	      | absurd ((z ?= p)%positive Eq = Lt);
+		[ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate
+		  | assumption ]
+	      | absurd ((z ?= p)%positive Eq = Gt);
+		[ rewrite (Pcompare_Eq_eq z q E0); rewrite <- (Pcompare_Eq_eq q p E2);
+		  rewrite (Pcompare_refl q); discriminate
+		  | assumption ]
+	      | absurd ((z ?= p)%positive Eq = Gt);
+		[ rewrite (Pcompare_Eq_eq z q E0); rewrite E2; discriminate
+		  | assumption ]
+	      | absurd ((z ?= q)%positive Eq = Lt);
+		[ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2);
+		  rewrite (Pcompare_refl p); discriminate
+		  | assumption ]
+	      | absurd ((p ?= q)%positive Eq = Gt);
+		[ rewrite <- (Pcompare_Eq_eq z p E1); rewrite E0; discriminate
+		  | apply ZC2; assumption ]
+	      | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2);
+		rewrite (Pcompare_refl (p - z)); auto with arith
+	      | simpl in |- *; rewrite <- ZC4;
+		apply nat_of_P_gt_Gt_compare_complement_morphism;
+		  rewrite nat_of_P_minus_morphism;
+		    [ rewrite nat_of_P_minus_morphism;
+		      [ unfold gt in |- *; apply plus_lt_reg_l with (p := nat_of_P z);
+			rewrite le_plus_minus_r;
+			  [ rewrite le_plus_minus_r;
+			    [ apply nat_of_P_lt_Lt_compare_morphism; assumption
+			      | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+				assumption ]
+			    | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+			      assumption ]
+			| apply ZC2; assumption ]
+		      | apply ZC2; assumption ]
+	      | simpl in |- *; rewrite <- ZC4;
+		apply nat_of_P_lt_Lt_compare_complement_morphism;
+		  rewrite nat_of_P_minus_morphism;
+		    [ rewrite nat_of_P_minus_morphism;
+		      [ apply plus_lt_reg_l with (p := nat_of_P z);
+			rewrite le_plus_minus_r;
+			  [ rewrite le_plus_minus_r;
+			    [ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
+			      assumption
+			      | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+				assumption ]
+			    | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+			      assumption ]
+			| apply ZC2; assumption ]
+		      | apply ZC2; assumption ]
+	      | absurd ((z ?= q)%positive Eq = Lt);
+		[ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate
+		  | assumption ]
+	      | absurd ((q ?= p)%positive Eq = Lt);
+		[ cut ((q ?= p)%positive Eq = Gt);
+		  [ intros E; rewrite E; discriminate
+		    | apply nat_of_P_gt_Gt_compare_complement_morphism;
+		      unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
+			[ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
+			  | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ]
+		  | assumption ]
+	      | absurd ((z ?= q)%positive Eq = Gt);
+		[ rewrite (Pcompare_Eq_eq z p E1); rewrite (Pcompare_Eq_eq q p E2);
+		  rewrite (Pcompare_refl p); discriminate
+		  | assumption ]
+	      | absurd ((z ?= q)%positive Eq = Gt);
+		[ rewrite (Pcompare_Eq_eq z p E1); rewrite ZC1;
+		  [ discriminate | assumption ]
+		  | assumption ]
+	      | absurd ((z ?= q)%positive Eq = Gt);
+		[ rewrite (Pcompare_Eq_eq q p E2); rewrite E1; discriminate
+		  | assumption ]
+	      | absurd ((q ?= p)%positive Eq = Gt);
+		[ rewrite ZC1;
+		  [ discriminate
+		    | apply nat_of_P_gt_Gt_compare_complement_morphism;
+		      unfold gt in |- *; apply lt_trans with (m := nat_of_P z);
+			[ apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption
+			  | apply nat_of_P_lt_Lt_compare_morphism; assumption ] ]
+		  | assumption ]
+	      | simpl in |- *; rewrite (Pcompare_Eq_eq q p E2); apply Pcompare_refl
+	      | simpl in |- *; apply nat_of_P_gt_Gt_compare_complement_morphism;
+		unfold gt in |- *; rewrite nat_of_P_minus_morphism;
+		  [ rewrite nat_of_P_minus_morphism;
+		    [ apply plus_lt_reg_l with (p := nat_of_P p);
+		      rewrite le_plus_minus_r;
+			[ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P q);
+			  rewrite plus_assoc; rewrite le_plus_minus_r;
+			    [ rewrite (plus_comm (nat_of_P q)); apply plus_lt_compat_l;
+			      apply nat_of_P_lt_Lt_compare_morphism; 
+				assumption
+			      | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+				apply ZC1; assumption ]
+			  | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+			    apply ZC1; assumption ]
+		      | assumption ]
+		    | assumption ]
+	      | simpl in |- *; apply nat_of_P_lt_Lt_compare_complement_morphism;
+		rewrite nat_of_P_minus_morphism;
+		  [ rewrite nat_of_P_minus_morphism;
+		    [ apply plus_lt_reg_l with (p := nat_of_P q);
+		      rewrite le_plus_minus_r;
+			[ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p);
+			  rewrite plus_assoc; rewrite le_plus_minus_r;
+			    [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l;
+			      apply nat_of_P_lt_Lt_compare_morphism; 
+				apply ZC1; assumption
+			      | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+				apply ZC1; assumption ]
+			  | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism;
+			    apply ZC1; assumption ]
+		      | assumption ]
+		    | assumption ] ] ].
 Qed.
 
 Lemma Zcompare_plus_compat : forall n m p:Z, (p + n ?= p + m) = (n ?= m).
 Proof.
-exact (weaken_Zcompare_Zplus_compatible weak_Zcompare_Zplus_compatible).
+  exact (weaken_Zcompare_Zplus_compatible weak_Zcompare_Zplus_compatible).
 Qed.
 
 Lemma Zplus_compare_compat :
- forall (r:comparison) (n m p q:Z),
-   (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r.
+  forall (r:comparison) (n m p q:Z),
+    (n ?= m) = r -> (p ?= q) = r -> (n + p ?= m + q) = r.
 Proof.
-intros r x y z t; case r;
- [ intros H1 H2; elim (Zcompare_Eq_iff_eq x y); elim (Zcompare_Eq_iff_eq z t);
-    intros H3 H4 H5 H6; rewrite H3;
-    [ rewrite H5;
-       [ elim (Zcompare_Eq_iff_eq (y + t) (y + t)); auto with arith
-       | auto with arith ]
-    | auto with arith ]
- | intros H1 H2; elim (Zcompare_Gt_Lt_antisym (y + t) (x + z)); intros H3 H4;
-    apply H3; apply Zcompare_Gt_trans with (m := y + z);
-    [ rewrite Zcompare_plus_compat; elim (Zcompare_Gt_Lt_antisym t z);
-       auto with arith
-    | do 2 rewrite <- (Zplus_comm z); rewrite Zcompare_plus_compat;
-       elim (Zcompare_Gt_Lt_antisym y x); auto with arith ]
- | intros H1 H2; apply Zcompare_Gt_trans with (m := x + t);
-    [ rewrite Zcompare_plus_compat; assumption
-    | do 2 rewrite <- (Zplus_comm t); rewrite Zcompare_plus_compat;
-       assumption ] ].
+  intros r x y z t; case r;
+    [ intros H1 H2; elim (Zcompare_Eq_iff_eq x y); elim (Zcompare_Eq_iff_eq z t);
+      intros H3 H4 H5 H6; rewrite H3;
+	[ rewrite H5;
+	  [ elim (Zcompare_Eq_iff_eq (y + t) (y + t)); auto with arith
+	    | auto with arith ]
+	  | auto with arith ]
+      | intros H1 H2; elim (Zcompare_Gt_Lt_antisym (y + t) (x + z)); intros H3 H4;
+	apply H3; apply Zcompare_Gt_trans with (m := y + z);
+	  [ rewrite Zcompare_plus_compat; elim (Zcompare_Gt_Lt_antisym t z);
+	    auto with arith
+	    | do 2 rewrite <- (Zplus_comm z); rewrite Zcompare_plus_compat;
+	      elim (Zcompare_Gt_Lt_antisym y x); auto with arith ]
+      | intros H1 H2; apply Zcompare_Gt_trans with (m := x + t);
+	[ rewrite Zcompare_plus_compat; assumption
+	  | do 2 rewrite <- (Zplus_comm t); rewrite Zcompare_plus_compat;
+	    assumption ] ].
 Qed.
 
 Lemma Zcompare_succ_Gt : forall n:Z, (Zsucc n ?= n) = Gt.
 Proof.
-intro x; unfold Zsucc in |- *; pattern x at 2 in |- *;
- rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; 
- reflexivity.
+  intro x; unfold Zsucc in |- *; pattern x at 2 in |- *;
+    rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; 
+      reflexivity.
 Qed.
 
 Lemma Zcompare_Gt_not_Lt : forall n m:Z, (n ?= m) = Gt <-> (n ?= m + 1) <> Lt.
 Proof.
-intros x y; split;
- [ intro H; elim_compare x (y + 1);
-    [ intro H1; rewrite H1; discriminate
-    | intros H1; elim Zcompare_Gt_spec with (1 := H); intros h H2;
-       absurd ((nat_of_P h > 0)%nat /\ (nat_of_P h < 1)%nat);
-       [ unfold not in |- *; intros H3; elim H3; intros H4 H5;
-          absurd (nat_of_P h > 0)%nat;
-          [ unfold gt in |- *; apply le_not_lt; apply le_S_n; exact H5
-          | assumption ]
-       | split;
-          [ elim (ZL4 h); intros i H3; rewrite H3; apply gt_Sn_O
-          | change (nat_of_P h < nat_of_P 1)%nat in |- *;
-             apply nat_of_P_lt_Lt_compare_morphism;
-             change ((Zpos h ?= 1) = Lt) in |- *; rewrite <- H2;
-             rewrite <- (fun m n:Z => Zcompare_plus_compat m n y);
-             rewrite (Zplus_comm x); rewrite Zplus_assoc; 
-             rewrite Zplus_opp_r; simpl in |- *; exact H1 ] ]
-    | intros H1; rewrite H1; discriminate ]
- | intros H; elim_compare x (y + 1);
-    [ intros H1; elim (Zcompare_Eq_iff_eq x (y + 1)); intros H2 H3;
-       rewrite (H2 H1); exact (Zcompare_succ_Gt y)
-    | intros H1; absurd ((x ?= y + 1) = Lt); assumption
-    | intros H1; apply Zcompare_Gt_trans with (m := Zsucc y);
-       [ exact H1 | exact (Zcompare_succ_Gt y) ] ] ].
+  intros x y; split;
+    [ intro H; elim_compare x (y + 1);
+      [ intro H1; rewrite H1; discriminate
+	| intros H1; elim Zcompare_Gt_spec with (1 := H); intros h H2;
+	  absurd ((nat_of_P h > 0)%nat /\ (nat_of_P h < 1)%nat);
+	    [ unfold not in |- *; intros H3; elim H3; intros H4 H5;
+              absurd (nat_of_P h > 0)%nat;
+		[ unfold gt in |- *; apply le_not_lt; apply le_S_n; exact H5
+		  | assumption ]
+	      | split;
+		[ elim (ZL4 h); intros i H3; rewrite H3; apply gt_Sn_O
+		  | change (nat_of_P h < nat_of_P 1)%nat in |- *;
+		    apply nat_of_P_lt_Lt_compare_morphism;
+		      change ((Zpos h ?= 1) = Lt) in |- *; rewrite <- H2;
+			rewrite <- (fun m n:Z => Zcompare_plus_compat m n y);
+			  rewrite (Zplus_comm x); rewrite Zplus_assoc; 
+			    rewrite Zplus_opp_r; simpl in |- *; exact H1 ] ]
+	| intros H1; rewrite H1; discriminate ]
+      | intros H; elim_compare x (y + 1);
+	[ intros H1; elim (Zcompare_Eq_iff_eq x (y + 1)); intros H2 H3;
+	  rewrite (H2 H1); exact (Zcompare_succ_Gt y)
+	  | intros H1; absurd ((x ?= y + 1) = Lt); assumption
+	  | intros H1; apply Zcompare_Gt_trans with (m := Zsucc y);
+	    [ exact H1 | exact (Zcompare_succ_Gt y) ] ] ].
 Qed.
 
-(** Successor and comparison *)
+(** * Successor and comparison *)
 
 Lemma Zcompare_succ_compat : forall n m:Z, (Zsucc n ?= Zsucc m) = (n ?= m).
 Proof.
-intros n m; unfold Zsucc in |- *; do 2 rewrite (fun t:Z => Zplus_comm t 1);
- rewrite Zcompare_plus_compat; auto with arith.
+  intros n m; unfold Zsucc in |- *; do 2 rewrite (fun t:Z => Zplus_comm t 1);
+    rewrite Zcompare_plus_compat; auto with arith.
 Qed.
  
-(** Multiplication and comparison *)
+(** * Multiplication and comparison *)
 
 Lemma Zcompare_mult_compat :
- forall (p:positive) (n m:Z), (Zpos p * n ?= Zpos p * m) = (n ?= m).
+  forall (p:positive) (n m:Z), (Zpos p * n ?= Zpos p * m) = (n ?= m).
 Proof.
-intros x; induction x as [p H| p H| ];
- [ intros y z; cut (Zpos (xI p) = Zpos p + Zpos p + 1);
-    [ intros E; rewrite E; do 4 rewrite Zmult_plus_distr_l;
-       do 2 rewrite Zmult_1_l; apply Zplus_compare_compat;
-       [ apply Zplus_compare_compat; apply H | trivial with arith ]
-    | simpl in |- *; rewrite (Pplus_diag p); trivial with arith ]
- | intros y z; cut (Zpos (xO p) = Zpos p + Zpos p);
-    [ intros E; rewrite E; do 2 rewrite Zmult_plus_distr_l;
-       apply Zplus_compare_compat; apply H
-    | simpl in |- *; rewrite (Pplus_diag p); trivial with arith ]
- | intros y z; do 2 rewrite Zmult_1_l; trivial with arith ].
+  intros x; induction x as [p H| p H| ];
+    [ intros y z; cut (Zpos (xI p) = Zpos p + Zpos p + 1);
+      [ intros E; rewrite E; do 4 rewrite Zmult_plus_distr_l;
+	do 2 rewrite Zmult_1_l; apply Zplus_compare_compat;
+	  [ apply Zplus_compare_compat; apply H | trivial with arith ]
+	| simpl in |- *; rewrite (Pplus_diag p); trivial with arith ]
+      | intros y z; cut (Zpos (xO p) = Zpos p + Zpos p);
+	[ intros E; rewrite E; do 2 rewrite Zmult_plus_distr_l;
+	  apply Zplus_compare_compat; apply H
+	  | simpl in |- *; rewrite (Pplus_diag p); trivial with arith ]
+      | intros y z; do 2 rewrite Zmult_1_l; trivial with arith ].
 Qed.
 
 
-(** Reverting [x ?= y] to trichotomy *)
+(** * Reverting [x ?= y] to trichotomy *)
 
 Lemma rename :
- forall (A:Set) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x.
+  forall (A:Type) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x.
 Proof.
-auto with arith. 
+  auto with arith. 
 Qed.
 
 Lemma Zcompare_elim :
- forall (c1 c2 c3:Prop) (n m:Z),
-   (n = m -> c1) ->
-   (n < m -> c2) ->
-   (n > m -> c3) -> match n ?= m with
-                    | Eq => c1
-                    | Lt => c2
-                    | Gt => c3
-                    end.
+  forall (c1 c2 c3:Prop) (n m:Z),
+    (n = m -> c1) ->
+    (n < m -> c2) ->
+    (n > m -> c3) -> match n ?= m with
+                       | Eq => c1
+                       | Lt => c2
+                       | Gt => c3
+                     end.
 Proof.
-intros c1 c2 c3 x y; intros.
-apply rename with (x := x ?= y); intro r; elim r;
- [ intro; apply H; apply (Zcompare_Eq_eq x y); assumption
- | unfold Zlt in H0; assumption
- | unfold Zgt in H1; assumption ].
+  intros c1 c2 c3 x y; intros.
+  apply rename with (x := x ?= y); intro r; elim r;
+    [ intro; apply H; apply (Zcompare_Eq_eq x y); assumption
+      | unfold Zlt in H0; assumption
+      | unfold Zgt in H1; assumption ].
 Qed.
 
 Lemma Zcompare_eq_case :
- forall (c1 c2 c3:Prop) (n m:Z),
-   c1 -> n = m -> match n ?= m with
-                  | Eq => c1
-                  | Lt => c2
-                  | Gt => c3
-                  end.
+  forall (c1 c2 c3:Prop) (n m:Z),
+    c1 -> n = m -> match n ?= m with
+                     | Eq => c1
+                     | Lt => c2
+                     | Gt => c3
+                   end.
 Proof.
-intros c1 c2 c3 x y; intros.
-rewrite H0; rewrite Zcompare_refl.
-assumption.
+  intros c1 c2 c3 x y; intros.
+  rewrite H0; rewrite Zcompare_refl.
+  assumption.
 Qed.
 
-(** Decompose an egality between two [?=] relations into 3 implications *)
+(** * Decompose an egality between two [?=] relations into 3 implications *)
 
 Lemma Zcompare_egal_dec :
- forall n m p q:Z,
-   (n < m -> p < q) ->
-   ((n ?= m) = Eq -> (p ?= q) = Eq) ->
-   (n > m -> p > q) -> (n ?= m) = (p ?= q).
+  forall n m p q:Z,
+    (n < m -> p < q) ->
+    ((n ?= m) = Eq -> (p ?= q) = Eq) ->
+    (n > m -> p > q) -> (n ?= m) = (p ?= q).
 Proof.
-intros x1 y1 x2 y2.
-unfold Zgt in |- *; unfold Zlt in |- *; case (x1 ?= y1); case (x2 ?= y2);
- auto with arith; symmetry  in |- *; auto with arith.
+  intros x1 y1 x2 y2.
+  unfold Zgt in |- *; unfold Zlt in |- *; case (x1 ?= y1); case (x2 ?= y2);
+    auto with arith; symmetry  in |- *; auto with arith.
 Qed.
 
-(** Relating [x ?= y] to [Zle], [Zlt], [Zge] or [Zgt] *)
+(** * Relating [x ?= y] to [Zle], [Zlt], [Zge] or [Zgt] *)
 
 Lemma Zle_compare :
- forall n m:Z,
-   n <= m -> match n ?= m with
-             | Eq => True
-             | Lt => True
-             | Gt => False
-             end.
+  forall n m:Z,
+    n <= m -> match n ?= m with
+		| Eq => True
+		| Lt => True
+		| Gt => False
+              end.
 Proof.
-intros x y; unfold Zle in |- *; elim (x ?= y); auto with arith.
+  intros x y; unfold Zle in |- *; elim (x ?= y); auto with arith.
 Qed.
 
 Lemma Zlt_compare :
- forall n m:Z,
+  forall n m:Z,
    n < m -> match n ?= m with
-            | Eq => False
-            | Lt => True
-            | Gt => False
+              | Eq => False
+              | Lt => True
+              | Gt => False
             end.
 Proof.
-intros x y; unfold Zlt in |- *; elim (x ?= y); intros;
- discriminate || trivial with arith.
+  intros x y; unfold Zlt in |- *; elim (x ?= y); intros;
+    discriminate || trivial with arith.
 Qed.
 
 Lemma Zge_compare :
- forall n m:Z,
-   n >= m -> match n ?= m with
-             | Eq => True
-             | Lt => False
-             | Gt => True
-             end.
+  forall n m:Z,
+    n >= m -> match n ?= m with
+		| Eq => True
+		| Lt => False
+		| Gt => True
+              end.
 Proof.
-intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. 
+  intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. 
 Qed.
 
 Lemma Zgt_compare :
- forall n m:Z,
-   n > m -> match n ?= m with
-            | Eq => False
-            | Lt => False
-            | Gt => True
-            end.
+  forall n m:Z,
+    n > m -> match n ?= m with
+               | Eq => False
+               | Lt => False
+               | Gt => True
+             end.
 Proof.
-intros x y; unfold Zgt in |- *; elim (x ?= y); intros;
- discriminate || trivial with arith.
+  intros x y; unfold Zgt in |- *; elim (x ?= y); intros;
+    discriminate || trivial with arith.
 Qed.
 
-(**********************************************************************)
-(* Other properties *)
-
+(*********************)
+(** * Other properties *)
 
 Lemma Zmult_compare_compat_l :
- forall n m p:Z, p > 0 -> (n ?= m) = (p * n ?= p * m).
+  forall n m p:Z, p > 0 -> (n ?= m) = (p * n ?= p * m).
 Proof.
-intros x y z H; destruct z.
+  intros x y z H; destruct z.
   discriminate H.
   rewrite Zcompare_mult_compat; reflexivity.
   discriminate H.
 Qed.
 
 Lemma Zmult_compare_compat_r :
- forall n m p:Z, p > 0 -> (n ?= m) = (n * p ?= m * p).
+  forall n m p:Z, p > 0 -> (n ?= m) = (n * p ?= m * p).
 Proof.
-intros x y z H; rewrite (Zmult_comm x z); rewrite (Zmult_comm y z);
- apply Zmult_compare_compat_l; assumption.
+  intros x y z H; rewrite (Zmult_comm x z); rewrite (Zmult_comm y z);
+    apply Zmult_compare_compat_l; assumption.
 Qed.
 
diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v
index b60cd37c..78c8a976 100644
--- a/theories/ZArith/Zcomplements.v
+++ b/theories/ZArith/Zcomplements.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zcomplements.v,v 1.26.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+(*i $Id: Zcomplements.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import ZArithRing.
 Require Import ZArith_base.
@@ -19,27 +19,27 @@ Open Local Scope Z_scope.
 (** About parity *)
 
 Lemma two_or_two_plus_one :
- forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. 
+  forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. 
 Proof.
-intro x; destruct x.
-left; split with 0; reflexivity.
-
-destruct p.
-right; split with (Zpos p); reflexivity.
-
-left; split with (Zpos p); reflexivity.
-
-right; split with 0; reflexivity.
-
-destruct p.
-right; split with (Zneg (1 + p)).
-rewrite BinInt.Zneg_xI.
-rewrite BinInt.Zneg_plus_distr.
-omega.
-
-left; split with (Zneg p); reflexivity.
-
-right; split with (-1); reflexivity.
+  intro x; destruct x.
+  left; split with 0; reflexivity.
+  
+  destruct p.
+  right; split with (Zpos p); reflexivity.
+  
+  left; split with (Zpos p); reflexivity.
+  
+  right; split with 0; reflexivity.
+  
+  destruct p.
+  right; split with (Zneg (1 + p)).
+  rewrite BinInt.Zneg_xI.
+  rewrite BinInt.Zneg_plus_distr.
+  omega.
+  
+  left; split with (Zneg p); reflexivity.
+  
+  right; split with (-1); reflexivity.
 Qed.
 
 (**********************************************************************)
@@ -50,109 +50,109 @@ Qed.
 
 Fixpoint floor_pos (a:positive) : positive :=
   match a with
-  | xH => 1%positive
-  | xO a' => xO (floor_pos a')
-  | xI b' => xO (floor_pos b')
+    | xH => 1%positive
+    | xO a' => xO (floor_pos a')
+    | xI b' => xO (floor_pos b')
   end.
 
 Definition floor (a:positive) := Zpos (floor_pos a).
 
 Lemma floor_gt0 : forall p:positive, floor p > 0.
 Proof.
-intro.
-compute in |- *.
-trivial.
+  intro.
+  compute in |- *.
+  trivial.
 Qed.
 
 Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. 
 Proof.
-unfold floor in |- *.
-intro a; induction a as [p| p| ].
-
-simpl in |- *.
-repeat rewrite BinInt.Zpos_xI.
-rewrite (BinInt.Zpos_xO (xO (floor_pos p))). 
-rewrite (BinInt.Zpos_xO (floor_pos p)).
-omega.
-
-simpl in |- *.
-repeat rewrite BinInt.Zpos_xI.
-rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
-rewrite (BinInt.Zpos_xO (floor_pos p)).
-rewrite (BinInt.Zpos_xO p).
-omega.
-
-simpl in |- *; omega.
+  unfold floor in |- *.
+  intro a; induction a as [p| p| ].
+  
+  simpl in |- *.
+  repeat rewrite BinInt.Zpos_xI.
+  rewrite (BinInt.Zpos_xO (xO (floor_pos p))). 
+  rewrite (BinInt.Zpos_xO (floor_pos p)).
+  omega.
+  
+  simpl in |- *.
+  repeat rewrite BinInt.Zpos_xI.
+  rewrite (BinInt.Zpos_xO (xO (floor_pos p))).
+  rewrite (BinInt.Zpos_xO (floor_pos p)).
+  rewrite (BinInt.Zpos_xO p).
+  omega.
+  
+  simpl in |- *; omega.
 Qed.
 
 (**********************************************************************)
 (** Two more induction principles over [Z]. *)
 
 Theorem Z_lt_abs_rec :
- forall P:Z -> Set,
-   (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
-   forall n:Z, P n.
+  forall P:Z -> Set,
+    (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
+    forall n:Z, P n.
 Proof.
-intros P HP p.
-set (Q := fun z => 0 <= z -> P z * P (- z)) in *.
-cut (Q (Zabs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ].
-elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
-unfold Q in |- *; clear Q; intros.
-apply pair; apply HP.
-rewrite Zabs_eq; auto; intros.
-elim (H (Zabs m)); intros; auto with zarith.
-elim (Zabs_dec m); intro eq; rewrite eq; trivial.
-rewrite Zabs_non_eq; auto with zarith.
-rewrite Zopp_involutive; intros.
-elim (H (Zabs m)); intros; auto with zarith.
-elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+  intros P HP p.
+  set (Q := fun z => 0 <= z -> P z * P (- z)) in *.
+  cut (Q (Zabs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ].
+  elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
+  unfold Q in |- *; clear Q; intros.
+  apply pair; apply HP.
+  rewrite Zabs_eq; auto; intros.
+  elim (H (Zabs m)); intros; auto with zarith.
+  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+  rewrite Zabs_non_eq; auto with zarith.
+  rewrite Zopp_involutive; intros.
+  elim (H (Zabs m)); intros; auto with zarith.
+  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
 Qed.
 
 Theorem Z_lt_abs_induction :
- forall P:Z -> Prop,
-   (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
-   forall n:Z, P n.
+  forall P:Z -> Prop,
+    (forall n:Z, (forall m:Z, Zabs m < Zabs n -> P m) -> P n) ->
+    forall n:Z, P n.
 Proof.
-intros P HP p.
-set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
-cut (Q (Zabs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ].
-elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
-unfold Q in |- *; clear Q; intros.
-split; apply HP.
-rewrite Zabs_eq; auto; intros.
-elim (H (Zabs m)); intros; auto with zarith.
-elim (Zabs_dec m); intro eq; rewrite eq; trivial.
-rewrite Zabs_non_eq; auto with zarith.
-rewrite Zopp_involutive; intros.
-elim (H (Zabs m)); intros; auto with zarith.
-elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+  intros P HP p.
+  set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
+  cut (Q (Zabs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ].
+  elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
+  unfold Q in |- *; clear Q; intros.
+  split; apply HP.
+  rewrite Zabs_eq; auto; intros.
+  elim (H (Zabs m)); intros; auto with zarith.
+  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+  rewrite Zabs_non_eq; auto with zarith.
+  rewrite Zopp_involutive; intros.
+  elim (H (Zabs m)); intros; auto with zarith.
+  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
 Qed.
 
 (** To do case analysis over the sign of [z] *) 
 
 Lemma Zcase_sign :
- forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
+  forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
 Proof.
-intros x P Hzero Hpos Hneg.
-induction  x as [| p| p].
-apply Hzero; trivial.
-apply Hpos; apply Zorder.Zgt_pos_0.
-apply Hneg; apply Zorder.Zlt_neg_0.
+  intros x P Hzero Hpos Hneg.
+  induction  x as [| p| p].
+  apply Hzero; trivial.
+  apply Hpos; apply Zorder.Zgt_pos_0.
+  apply Hneg; apply Zorder.Zlt_neg_0.
 Qed.
 
 Lemma sqr_pos : forall n:Z, n * n >= 0.
 Proof.
-intro x.
-apply (Zcase_sign x (x * x >= 0)).
-intros H; rewrite H; omega.
-intros H; replace 0 with (0 * 0).
-apply Zmult_ge_compat; omega.
-omega.
-intros H; replace 0 with (0 * 0).
-replace (x * x) with (- x * - x).
-apply Zmult_ge_compat; omega.
-ring.
-omega.
+  intro x.
+  apply (Zcase_sign x (x * x >= 0)).
+  intros H; rewrite H; omega.
+  intros H; replace 0 with (0 * 0).
+  apply Zmult_ge_compat; omega.
+  omega.
+  intros H; replace 0 with (0 * 0).
+  replace (x * x) with (- x * - x).
+  apply Zmult_ge_compat; omega.
+  ring.
+  omega.
 Qed.
 
 (**********************************************************************)
@@ -162,8 +162,8 @@ Require Import List.
 
 Fixpoint Zlength_aux (acc:Z) (A:Set) (l:list A) {struct l} : Z :=
   match l with
-  | nil => acc
-  | _ :: l => Zlength_aux (Zsucc acc) A l
+    | nil => acc
+    | _ :: l => Zlength_aux (Zsucc acc) A l
   end. 
 
 Definition Zlength := Zlength_aux 0.
@@ -171,42 +171,42 @@ Implicit Arguments Zlength [A].
 
 Section Zlength_properties.
 
-Variable A : Set.
-
-Implicit Type l : list A.
-
-Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l).
-Proof.
-assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). 
-simple induction l.
-simpl in |- *; auto with zarith.
-intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S.
-simpl in |- *; rewrite H; auto with zarith.
-unfold Zlength in |- *; intros; rewrite H; auto.
-Qed.
-
-Lemma Zlength_nil : Zlength (A:=A) nil = 0.
-Proof.
-auto.
-Qed.
-
-Lemma Zlength_cons : forall (x:A) l, Zlength (x :: l) = Zsucc (Zlength l).
-Proof.
-intros; do 2 rewrite Zlength_correct.
-simpl (length (x :: l)) in |- *; rewrite Znat.inj_S; auto.
-Qed.
-
-Lemma Zlength_nil_inv : forall l, Zlength l = 0 -> l = nil.
-Proof.
-intro l; rewrite Zlength_correct.
-case l; auto.
-intros x l'; simpl (length (x :: l')) in |- *.
-rewrite Znat.inj_S.
-intros; elimtype False; generalize (Zle_0_nat (length l')); omega.
-Qed.
+  Variable A : Set.
+
+  Implicit Type l : list A.
+
+  Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l).
+  Proof.
+    assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). 
+    simple induction l.
+    simpl in |- *; auto with zarith.
+    intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S.
+    simpl in |- *; rewrite H; auto with zarith.
+    unfold Zlength in |- *; intros; rewrite H; auto.
+  Qed.
+
+  Lemma Zlength_nil : Zlength (A:=A) nil = 0.
+  Proof.
+    auto.
+  Qed.
+
+  Lemma Zlength_cons : forall (x:A) l, Zlength (x :: l) = Zsucc (Zlength l).
+  Proof.
+    intros; do 2 rewrite Zlength_correct.
+    simpl (length (x :: l)) in |- *; rewrite Znat.inj_S; auto.
+  Qed.
+
+  Lemma Zlength_nil_inv : forall l, Zlength l = 0 -> l = nil.
+  Proof.
+    intro l; rewrite Zlength_correct.
+    case l; auto.
+    intros x l'; simpl (length (x :: l')) in |- *.
+    rewrite Znat.inj_S.
+    intros; elimtype False; generalize (Zle_0_nat (length l')); omega.
+  Qed.
 
 End Zlength_properties.
 
 Implicit Arguments Zlength_correct [A].
 Implicit Arguments Zlength_cons [A].
-Implicit Arguments Zlength_nil_inv [A].
\ No newline at end of file
+Implicit Arguments Zlength_nil_inv [A].
diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v
index 84eb2259..31f68207 100644
--- a/theories/ZArith/Zdiv.v
+++ b/theories/ZArith/Zdiv.v
@@ -6,17 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zdiv.v,v 1.21.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+(*i $Id: Zdiv.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (* Contribution by Claude Marché and Xavier Urbain *)
 
-(**
-
-Euclidean Division
-
-Defines first of function that allows Coq to normalize. 
-Then only after proves the main required property.
+(** Euclidean Division
 
+    Defines first of function that allows Coq to normalize. 
+    Then only after proves the main required property.
 *)
 
 Require Export ZArith_base.
@@ -26,40 +23,37 @@ Require Import ZArithRing.
 Require Import Zcomplements.
 Open Local Scope Z_scope.
 
-(**
+(** * Definitions of Euclidian operations *)
 
-  Euclidean division of a positive by a integer 
-  (that is supposed to be positive).
+(** Euclidean division of a positive by a integer 
+    (that is supposed to be positive).
 
-  total function than returns an arbitrary value when
-  divisor is not positive
+    Total function than returns an arbitrary value when
+    divisor is not positive
   
 *)
 
-Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : 
- Z * Z :=
+Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : 
+  Z * Z :=
   match a with
-  | xH => if Zge_bool b 2 then (0, 1) else (1, 0)
-  | xO a' =>
+    | xH => if Zge_bool b 2 then (0, 1) else (1, 0)
+    | xO a' =>
       let (q, r) := Zdiv_eucl_POS a' b in
-      let r' := 2 * r in
-      if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
-  | xI a' =>
+	let r' := 2 * r in
+	  if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
+    | xI a' =>
       let (q, r) := Zdiv_eucl_POS a' b in
-      let r' := 2 * r + 1 in
-      if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
+	let r' := 2 * r + 1 in
+	  if Zgt_bool b r' then (2 * q, r') else (2 * q + 1, r' - b)
   end.
 
 
-(**
-
-  Euclidean division of integers.
+(** Euclidean division of integers.
  
-  Total function than returns (0,0) when dividing by 0. 
-
+    Total function than returns (0,0) when dividing by 0. 
 *) 
     
-(* 
+(** 
 
   The pseudo-code is:
   
@@ -82,22 +76,22 @@ Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} :
 
 Definition Zdiv_eucl (a b:Z) : Z * Z :=
   match a, b with
-  | Z0, _ => (0, 0)
-  | _, Z0 => (0, 0)
-  | Zpos a', Zpos _ => Zdiv_eucl_POS a' b
-  | Zneg a', Zpos _ =>
+    | Z0, _ => (0, 0)
+    | _, Z0 => (0, 0)
+    | Zpos a', Zpos _ => Zdiv_eucl_POS a' b
+    | Zneg a', Zpos _ =>
       let (q, r) := Zdiv_eucl_POS a' b in
-      match r with
-      | Z0 => (- q, 0)
-      | _ => (- (q + 1), b - r)
-      end
-  | Zneg a', Zneg b' => let (q, r) := Zdiv_eucl_POS a' (Zpos b') in (q, - r)
-  | Zpos a', Zneg b' =>
+	match r with
+	  | Z0 => (- q, 0)
+	  | _ => (- (q + 1), b - r)
+	end
+    | Zneg a', Zneg b' => let (q, r) := Zdiv_eucl_POS a' (Zpos b') in (q, - r)
+    | Zpos a', Zneg b' =>
       let (q, r) := Zdiv_eucl_POS a' (Zpos b') in
-      match r with
-      | Z0 => (- q, 0)
-      | _ => (- (q + 1), b + r)
-      end
+	match r with
+	  | Z0 => (- q, 0)
+	  | _ => (- (q + 1), b + r)
+	end
   end.
 
 
@@ -107,6 +101,11 @@ Definition Zdiv (a b:Z) : Z := let (q, _) := Zdiv_eucl a b in q.
 
 Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r. 
 
+(** Syntax *)
+
+Infix "/" := Zdiv : Z_scope.
+Infix "mod" := Zmod (at level 40, no associativity) : Z_scope.
+
 (* Tests:
 
 Eval Compute in `(Zdiv_eucl 7 3)`. 
@@ -120,19 +119,15 @@ Eval Compute in `(Zdiv_eucl (-7) (-3))`.
 *)
 
 
-(**
-
-  Main division theorem. 
-
-  First a lemma for positive
+(** * Main division theorem *) 
 
-*)
+(** First a lemma for positive *)
 
 Lemma Z_div_mod_POS :
- forall b:Z,
-   b > 0 ->
-   forall a:positive,
-     let (q, r) := Zdiv_eucl_POS a b in Zpos a = b * q + r /\ 0 <= r < b.
+  forall b:Z,
+    b > 0 ->
+    forall a:positive,
+      let (q, r) := Zdiv_eucl_POS a b in Zpos a = b * q + r /\ 0 <= r < b.
 Proof.
 simple induction a; unfold Zdiv_eucl_POS in |- *; fold Zdiv_eucl_POS in |- *.
 
@@ -148,276 +143,269 @@ case (Zgt_bool b (2 * r)); rewrite BinInt.Zpos_xO;
  (split; [ ring | omega ]).
 
 generalize (Zge_cases b 2).
-case (Zge_bool b 2); (intros; split; [ ring | omega ]).
+case (Zge_bool b 2); (intros; split; [ try ring | omega ]).
 omega.
 Qed.
 
 
 Theorem Z_div_mod :
- forall a b:Z,
-   b > 0 -> let (q, r) := Zdiv_eucl a b in a = b * q + r /\ 0 <= r < b.
+  forall a b:Z,
+    b > 0 -> let (q, r) := Zdiv_eucl a b in a = b * q + r /\ 0 <= r < b.
 Proof.
-intros a b; case a; case b; try (simpl in |- *; intros; omega).
-unfold Zdiv_eucl in |- *; intros; apply Z_div_mod_POS; trivial.
-
-intros; discriminate.
-
-intros.
-generalize (Z_div_mod_POS (Zpos p) H p0).
-unfold Zdiv_eucl in |- *.
-case (Zdiv_eucl_POS p0 (Zpos p)).
-intros z z0.
-case z0.
-
-intros [H1 H2].
-split; trivial.
-replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
-
-intros p1 [H1 H2].
-split; trivial.
-replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
-generalize (Zorder.Zgt_pos_0 p1); omega.
-
-intros p1 [H1 H2].
-split; trivial.
-replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
-generalize (Zorder.Zlt_neg_0 p1); omega.
-
-intros; discriminate.
+  intros a b; case a; case b; try (simpl in |- *; intros; omega).
+  unfold Zdiv_eucl in |- *; intros; apply Z_div_mod_POS; trivial.
+  
+  intros; discriminate.
+
+  intros.
+  generalize (Z_div_mod_POS (Zpos p) H p0).
+  unfold Zdiv_eucl in |- *.
+  case (Zdiv_eucl_POS p0 (Zpos p)).
+  intros z z0.
+  case z0.
+  
+  intros [H1 H2].
+  split; trivial.
+  replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
+  
+  intros p1 [H1 H2].
+  split; trivial.
+  replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
+  generalize (Zorder.Zgt_pos_0 p1); omega.
+  
+  intros p1 [H1 H2].
+  split; trivial.
+  replace (Zneg p0) with (- Zpos p0); [ rewrite H1; ring | trivial ].
+  generalize (Zorder.Zlt_neg_0 p1); omega.
+  
+  intros; discriminate.
 Qed.
 
 (** Existence theorems *)
 
 Theorem Zdiv_eucl_exist :
- forall b:Z,
-   b > 0 ->
-   forall a:Z, {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}.
+  forall b:Z,
+    b > 0 ->
+    forall a:Z, {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < b}.
 Proof.
-intros b Hb a.
-exists (Zdiv_eucl a b).
-exact (Z_div_mod a b Hb).
+  intros b Hb a.
+  exists (Zdiv_eucl a b).
+  exact (Z_div_mod a b Hb).
 Qed.
 
 Implicit Arguments Zdiv_eucl_exist.
 
 Theorem Zdiv_eucl_extended :
- forall b:Z,
-   b <> 0 ->
-   forall a:Z,
-     {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Zabs b}.
+  forall b:Z,
+    b <> 0 ->
+    forall a:Z,
+      {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Zabs b}.
 Proof.
-intros b Hb a.
-elim (Z_le_gt_dec 0 b); intro Hb'.
-cut (b > 0); [ intro Hb'' | omega ].
-rewrite Zabs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
-cut (- b > 0); [ intro Hb'' | omega ].
-elim (Zdiv_eucl_exist Hb'' a); intros qr.
-elim qr; intros q r Hqr.
-exists (- q, r).
-elim Hqr; intros.
-split.
-rewrite <- Zmult_opp_comm; assumption.
-rewrite Zabs_non_eq; [ assumption | omega ].
+  intros b Hb a.
+  elim (Z_le_gt_dec 0 b); intro Hb'.
+  cut (b > 0); [ intro Hb'' | omega ].
+  rewrite Zabs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
+  cut (- b > 0); [ intro Hb'' | omega ].
+  elim (Zdiv_eucl_exist Hb'' a); intros qr.
+  elim qr; intros q r Hqr.
+  exists (- q, r).
+  elim Hqr; intros.
+  split.
+  rewrite <- Zmult_opp_comm; assumption.
+  rewrite Zabs_non_eq; [ assumption | omega ].
 Qed.
 
 Implicit Arguments Zdiv_eucl_extended.
 
-(** Auxiliary lemmas about [Zdiv] and [Zmod] *)
+(** * Auxiliary lemmas about [Zdiv] and [Zmod] *)
 
 Lemma Z_div_mod_eq : forall a b:Z, b > 0 -> a = b * Zdiv a b + Zmod a b.
 Proof.
-unfold Zdiv, Zmod in |- *.
-intros a b Hb.
-generalize (Z_div_mod a b Hb).
-case Zdiv_eucl; tauto.
+  unfold Zdiv, Zmod in |- *.
+  intros a b Hb.
+  generalize (Z_div_mod a b Hb).
+  case Zdiv_eucl; tauto.
 Qed.
 
 Lemma Z_mod_lt : forall a b:Z, b > 0 -> 0 <= Zmod a b < b.
 Proof.
-unfold Zmod in |- *.
-intros a b Hb.
-generalize (Z_div_mod a b Hb).
-case (Zdiv_eucl a b); tauto.
+  unfold Zmod in |- *.
+  intros a b Hb.
+  generalize (Z_div_mod a b Hb).
+  case (Zdiv_eucl a b); tauto.
 Qed.
 
 Lemma Z_div_POS_ge0 :
- forall (b:Z) (a:positive), let (q, _) := Zdiv_eucl_POS a b in q >= 0.
+  forall (b:Z) (a:positive), let (q, _) := Zdiv_eucl_POS a b in q >= 0.
 Proof.
-simple induction a; unfold Zdiv_eucl_POS in |- *; fold Zdiv_eucl_POS in |- *.
-intro p; case (Zdiv_eucl_POS p b).
-intros; case (Zgt_bool b (2 * z0 + 1)); intros; omega.
-intro p; case (Zdiv_eucl_POS p b).
-intros; case (Zgt_bool b (2 * z0)); intros; omega.
-case (Zge_bool b 2); simpl in |- *; omega.
+  simple induction a; unfold Zdiv_eucl_POS in |- *; fold Zdiv_eucl_POS in |- *.
+  intro p; case (Zdiv_eucl_POS p b).
+  intros; case (Zgt_bool b (2 * z0 + 1)); intros; omega.
+  intro p; case (Zdiv_eucl_POS p b).
+  intros; case (Zgt_bool b (2 * z0)); intros; omega.
+  case (Zge_bool b 2); simpl in |- *; omega.
 Qed.
 
 Lemma Z_div_ge0 : forall a b:Z, b > 0 -> a >= 0 -> Zdiv a b >= 0.
 Proof.
-intros a b Hb; unfold Zdiv, Zdiv_eucl in |- *; case a; simpl in |- *; intros.
-case b; simpl in |- *; trivial.
-generalize Hb; case b; try trivial.
-auto with zarith.
-intros p0 Hp0; generalize (Z_div_POS_ge0 (Zpos p0) p).
-case (Zdiv_eucl_POS p (Zpos p0)); simpl in |- *; tauto.
-intros; discriminate.
-elim H; trivial.
+  intros a b Hb; unfold Zdiv, Zdiv_eucl in |- *; case a; simpl in |- *; intros.
+  case b; simpl in |- *; trivial.
+  generalize Hb; case b; try trivial.
+  auto with zarith.
+  intros p0 Hp0; generalize (Z_div_POS_ge0 (Zpos p0) p).
+  case (Zdiv_eucl_POS p (Zpos p0)); simpl in |- *; tauto.
+  intros; discriminate.
+  elim H; trivial.
 Qed.
 
 Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> Zdiv a b < a.
 Proof.
-intros. cut (b > 0); [ intro Hb | omega ].
-generalize (Z_div_mod a b Hb).
-cut (a >= 0); [ intro Ha | omega ].
-generalize (Z_div_ge0 a b Hb Ha).
-unfold Zdiv in |- *; case (Zdiv_eucl a b); intros q r H1 [H2 H3].
-cut (a >= 2 * q -> q < a); [ intro h; apply h; clear h | intros; omega ].
-apply Zge_trans with (b * q).
-omega.
-auto with zarith.
+  intros. cut (b > 0); [ intro Hb | omega ].
+  generalize (Z_div_mod a b Hb).
+  cut (a >= 0); [ intro Ha | omega ].
+  generalize (Z_div_ge0 a b Hb Ha).
+  unfold Zdiv in |- *; case (Zdiv_eucl a b); intros q r H1 [H2 H3].
+  cut (a >= 2 * q -> q < a); [ intro h; apply h; clear h | intros; omega ].
+  apply Zge_trans with (b * q).
+  omega.
+  auto with zarith.
 Qed.
 
-(** Syntax *)
-
-
-
-Infix "/" := Zdiv : Z_scope.
-Infix "mod" := Zmod (at level 40, no associativity) : Z_scope.
-
-(** Other lemmas (now using the syntax for [Zdiv] and [Zmod]). *)
+(** * Other lemmas (now using the syntax for [Zdiv] and [Zmod]). *)
 
 Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a / c >= b / c.
 Proof.
-intros a b c cPos aGeb.
-generalize (Z_div_mod_eq a c cPos).
-generalize (Z_mod_lt a c cPos).
-generalize (Z_div_mod_eq b c cPos).
-generalize (Z_mod_lt b c cPos).
-intros.
-elim (Z_ge_lt_dec (a / c) (b / c)); trivial.
-intro.
-absurd (b - a >= 1).
-omega.
-rewrite H0.
-rewrite H2.
-assert
- (c * (b / c) + b mod c - (c * (a / c) + a mod c) =
-  c * (b / c - a / c) + b mod c - a mod c).
-ring.
-rewrite H3.
-assert (c * (b / c - a / c) >= c * 1).
-apply Zmult_ge_compat_l.
-omega.
-omega.
-assert (c * 1 = c).
-ring.
-omega.
+  intros a b c cPos aGeb.
+  generalize (Z_div_mod_eq a c cPos).
+  generalize (Z_mod_lt a c cPos).
+  generalize (Z_div_mod_eq b c cPos).
+  generalize (Z_mod_lt b c cPos).
+  intros.
+  elim (Z_ge_lt_dec (a / c) (b / c)); trivial.
+  intro.
+  absurd (b - a >= 1).
+  omega.
+  rewrite H0.
+  rewrite H2.
+  assert
+    (c * (b / c) + b mod c - (c * (a / c) + a mod c) =
+      c * (b / c - a / c) + b mod c - a mod c).
+  ring.
+  rewrite H3.
+  assert (c * (b / c - a / c) >= c * 1).
+  apply Zmult_ge_compat_l.
+  omega.
+  omega.
+  assert (c * 1 = c).
+  ring.
+  omega.
 Qed.
 
 Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c.
 Proof.
-intros a b c cPos.
-generalize (Z_div_mod_eq a c cPos).
-generalize (Z_mod_lt a c cPos).
-generalize (Z_div_mod_eq (a + b * c) c cPos).
-generalize (Z_mod_lt (a + b * c) c cPos).
-intros.
-
-assert ((a + b * c) mod c - a mod c = c * (b + a / c - (a + b * c) / c)).
-replace ((a + b * c) mod c) with (a + b * c - c * ((a + b * c) / c)).
-replace (a mod c) with (a - c * (a / c)).
-ring.
-omega.
-omega.
-set (q := b + a / c - (a + b * c) / c) in *.
-apply (Zcase_sign q); intros.
-assert (c * q = 0).
-rewrite H4; ring.
-rewrite H5 in H3.
-omega.
-
-assert (c * q >= c).
-pattern c at 2 in |- *; replace c with (c * 1).
-apply Zmult_ge_compat_l; omega.
-ring.
-omega.
-
-assert (c * q <= - c).
-replace (- c) with (c * -1).
-apply Zmult_le_compat_l; omega.
-ring.
-omega.
+  intros a b c cPos.
+  generalize (Z_div_mod_eq a c cPos).
+  generalize (Z_mod_lt a c cPos).
+  generalize (Z_div_mod_eq (a + b * c) c cPos).
+  generalize (Z_mod_lt (a + b * c) c cPos).
+  intros.
+
+  assert ((a + b * c) mod c - a mod c = c * (b + a / c - (a + b * c) / c)).
+  replace ((a + b * c) mod c) with (a + b * c - c * ((a + b * c) / c)).
+  replace (a mod c) with (a - c * (a / c)).
+  ring.
+  omega.
+  omega.
+  set (q := b + a / c - (a + b * c) / c) in *.
+  apply (Zcase_sign q); intros.
+  assert (c * q = 0).
+  rewrite H4; ring.
+  rewrite H5 in H3.
+  omega.
+
+  assert (c * q >= c).
+  pattern c at 2 in |- *; replace c with (c * 1).
+  apply Zmult_ge_compat_l; omega.
+  ring.
+  omega.
+
+  assert (c * q <= - c).
+  replace (- c) with (c * -1).
+  apply Zmult_le_compat_l; omega.
+  ring.
+  omega.
 Qed.
 
 Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b.
 Proof.
-intros a b c cPos.
-generalize (Z_div_mod_eq a c cPos).
-generalize (Z_mod_lt a c cPos).
-generalize (Z_div_mod_eq (a + b * c) c cPos).
-generalize (Z_mod_lt (a + b * c) c cPos).
-intros.
-apply Zmult_reg_l with c. omega.
-replace (c * ((a + b * c) / c)) with (a + b * c - (a + b * c) mod c).
-rewrite (Z_mod_plus a b c cPos).
-pattern a at 1 in |- *; rewrite H2.
-ring.
-pattern (a + b * c) at 1 in |- *; rewrite H0.
-ring.
+  intros a b c cPos.
+  generalize (Z_div_mod_eq a c cPos).
+  generalize (Z_mod_lt a c cPos).
+  generalize (Z_div_mod_eq (a + b * c) c cPos).
+  generalize (Z_mod_lt (a + b * c) c cPos).
+  intros.
+  apply Zmult_reg_l with c. omega.
+  replace (c * ((a + b * c) / c)) with (a + b * c - (a + b * c) mod c).
+  rewrite (Z_mod_plus a b c cPos).
+  pattern a at 1 in |- *; rewrite H2.
+  ring.
+  pattern (a + b * c) at 1 in |- *; rewrite H0.
+  ring.
 Qed.
 
 Lemma Z_div_mult : forall a b:Z, b > 0 -> a * b / b = a.
-intros; replace (a * b) with (0 + a * b); auto.
-rewrite Z_div_plus; auto.
+  intros; replace (a * b) with (0 + a * b); auto.
+  rewrite Z_div_plus; auto.
 Qed.
 
 Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b * (a / b) <= a.
 Proof.
-intros a b bPos.
-generalize (Z_div_mod_eq a _ bPos); intros.
-generalize (Z_mod_lt a _ bPos); intros.
-pattern a at 2 in |- *; rewrite H.
-omega.
+  intros a b bPos.
+  generalize (Z_div_mod_eq a _ bPos); intros.
+  generalize (Z_mod_lt a _ bPos); intros.
+  pattern a at 2 in |- *; rewrite H.
+  omega.
 Qed.
 
 Lemma Z_mod_same : forall a:Z, a > 0 -> a mod a = 0.
 Proof.
-intros a aPos.
-generalize (Z_mod_plus 0 1 a aPos).
-replace (0 + 1 * a) with a.
-intros.
-rewrite H.
-compute in |- *.
-trivial.
-ring.
+  intros a aPos.
+  generalize (Z_mod_plus 0 1 a aPos).
+  replace (0 + 1 * a) with a.
+  intros.
+  rewrite H.
+  compute in |- *.
+  trivial.
+  ring.
 Qed.
 
 Lemma Z_div_same : forall a:Z, a > 0 -> a / a = 1.
 Proof.
-intros a aPos.
-generalize (Z_div_plus 0 1 a aPos).
-replace (0 + 1 * a) with a.
-intros.
-rewrite H.
-compute in |- *.
-trivial.
-ring.
+  intros a aPos.
+  generalize (Z_div_plus 0 1 a aPos).
+  replace (0 + 1 * a) with a.
+  intros.
+  rewrite H.
+  compute in |- *.
+  trivial.
+  ring.
 Qed.
 
 Lemma Z_div_exact_1 : forall a b:Z, b > 0 -> a = b * (a / b) -> a mod b = 0.
-intros a b Hb; generalize (Z_div_mod a b Hb); unfold Zmod, Zdiv in |- *.
-case (Zdiv_eucl a b); intros q r; omega.
+  intros a b Hb; generalize (Z_div_mod a b Hb); unfold Zmod, Zdiv in |- *.
+  case (Zdiv_eucl a b); intros q r; omega.
 Qed.
 
 Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b * (a / b).
-intros a b Hb; generalize (Z_div_mod a b Hb); unfold Zmod, Zdiv in |- *.
-case (Zdiv_eucl a b); intros q r; omega.
+  intros a b Hb; generalize (Z_div_mod a b Hb); unfold Zmod, Zdiv in |- *.
+  case (Zdiv_eucl a b); intros q r; omega.
 Qed.
 
 Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> - a mod b = 0.
-intros a b Hb.
-intros.
-rewrite Z_div_exact_2 with a b; auto.
-replace (- (b * (a / b))) with (0 + - (a / b) * b).
-rewrite Z_mod_plus; auto.
-ring.
+  intros a b Hb.
+  intros.
+  rewrite Z_div_exact_2 with a b; auto.
+  replace (- (b * (a / b))) with (0 + - (a / b) * b).
+  rewrite Z_mod_plus; auto.
+  ring.
 Qed.
diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v
index a4a9abde..6fab4461 100644
--- a/theories/ZArith/Zeven.v
+++ b/theories/ZArith/Zeven.v
@@ -6,199 +6,203 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zeven.v,v 1.3.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+(*i $Id: Zeven.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import BinInt.
 
-(**********************************************************************)
+(*******************************************************************)
 (** About parity: even and odd predicates on Z, division by 2 on Z *)
 
-(**********************************************************************)
-(** [Zeven], [Zodd], [Zdiv2] and their related properties *)
+(***************************************************)
+(** * [Zeven], [Zodd] and their related properties *)
 
 Definition Zeven (z:Z) :=
   match z with
-  | Z0 => True
-  | Zpos (xO _) => True
-  | Zneg (xO _) => True
-  | _ => False
+    | Z0 => True
+    | Zpos (xO _) => True
+    | Zneg (xO _) => True
+    | _ => False
   end.
 
 Definition Zodd (z:Z) :=
   match z with
-  | Zpos xH => True
-  | Zneg xH => True
-  | Zpos (xI _) => True
-  | Zneg (xI _) => True
-  | _ => False
+    | Zpos xH => True
+    | Zneg xH => True
+    | Zpos (xI _) => True
+    | Zneg (xI _) => True
+    | _ => False
   end.
 
 Definition Zeven_bool (z:Z) :=
   match z with
-  | Z0 => true
-  | Zpos (xO _) => true
-  | Zneg (xO _) => true
-  | _ => false
+    | Z0 => true
+    | Zpos (xO _) => true
+    | Zneg (xO _) => true
+    | _ => false
   end.
 
 Definition Zodd_bool (z:Z) :=
   match z with
-  | Z0 => false
-  | Zpos (xO _) => false
-  | Zneg (xO _) => false
-  | _ => true
+    | Z0 => false
+    | Zpos (xO _) => false
+    | Zneg (xO _) => false
+    | _ => true
   end.
 
 Definition Zeven_odd_dec : forall z:Z, {Zeven z} + {Zodd z}.
 Proof.
   intro z. case z;
   [ left; compute in |- *; trivial
-  | intro p; case p; intros;
-     (right; compute in |- *; exact I) || (left; compute in |- *; exact I)
-  | intro p; case p; intros;
-     (right; compute in |- *; exact I) || (left; compute in |- *; exact I) ].
+    | intro p; case p; intros;
+      (right; compute in |- *; exact I) || (left; compute in |- *; exact I)
+    | intro p; case p; intros;
+      (right; compute in |- *; exact I) || (left; compute in |- *; exact I) ].
 Defined.
 
 Definition Zeven_dec : forall z:Z, {Zeven z} + {~ Zeven z}.
 Proof.
   intro z. case z;
   [ left; compute in |- *; trivial
-  | intro p; case p; intros;
-     (left; compute in |- *; exact I) || (right; compute in |- *; trivial)
-  | intro p; case p; intros;
-     (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ].
+    | intro p; case p; intros;
+      (left; compute in |- *; exact I) || (right; compute in |- *; trivial)
+    | intro p; case p; intros;
+      (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ].
 Defined.
 
 Definition Zodd_dec : forall z:Z, {Zodd z} + {~ Zodd z}.
 Proof.
   intro z. case z;
   [ right; compute in |- *; trivial
-  | intro p; case p; intros;
-     (left; compute in |- *; exact I) || (right; compute in |- *; trivial)
-  | intro p; case p; intros;
-     (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ].
+    | intro p; case p; intros;
+      (left; compute in |- *; exact I) || (right; compute in |- *; trivial)
+    | intro p; case p; intros;
+      (left; compute in |- *; exact I) || (right; compute in |- *; trivial) ].
 Defined.
 
 Lemma Zeven_not_Zodd : forall n:Z, Zeven n -> ~ Zodd n.
 Proof.
   intro z; destruct z; [ idtac | destruct p | destruct p ]; compute in |- *;
-   trivial.
+    trivial.
 Qed.
 
 Lemma Zodd_not_Zeven : forall n:Z, Zodd n -> ~ Zeven n.
 Proof.
   intro z; destruct z; [ idtac | destruct p | destruct p ]; compute in |- *;
-   trivial.
+    trivial.
 Qed.
 
 Lemma Zeven_Sn : forall n:Z, Zodd n -> Zeven (Zsucc n).
 Proof.
- intro z; destruct z; unfold Zsucc in |- *;
-  [ idtac | destruct p | destruct p ]; simpl in |- *; 
-  trivial. 
- unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+  intro z; destruct z; unfold Zsucc in |- *;
+    [ idtac | destruct p | destruct p ]; simpl in |- *; 
+      trivial. 
+  unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
 Qed.
 
 Lemma Zodd_Sn : forall n:Z, Zeven n -> Zodd (Zsucc n).
 Proof.
- intro z; destruct z; unfold Zsucc in |- *;
-  [ idtac | destruct p | destruct p ]; simpl in |- *; 
-  trivial. 
- unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+  intro z; destruct z; unfold Zsucc in |- *;
+    [ idtac | destruct p | destruct p ]; simpl in |- *; 
+      trivial. 
+  unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
 Qed.
 
 Lemma Zeven_pred : forall n:Z, Zodd n -> Zeven (Zpred n).
 Proof.
- intro z; destruct z; unfold Zpred in |- *;
-  [ idtac | destruct p | destruct p ]; simpl in |- *; 
-  trivial. 
- unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+  intro z; destruct z; unfold Zpred in |- *;
+    [ idtac | destruct p | destruct p ]; simpl in |- *; 
+      trivial. 
+  unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
 Qed.
 
 Lemma Zodd_pred : forall n:Z, Zeven n -> Zodd (Zpred n).
 Proof.
- intro z; destruct z; unfold Zpred in |- *;
-  [ idtac | destruct p | destruct p ]; simpl in |- *; 
-  trivial. 
- unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
+  intro z; destruct z; unfold Zpred in |- *;
+    [ idtac | destruct p | destruct p ]; simpl in |- *; 
+      trivial. 
+  unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto.
 Qed.
 
 Hint Unfold Zeven Zodd: zarith.
 
-(**********************************************************************)
+
+(******************************************************************)
+(** * Definition of [Zdiv2] and properties wrt [Zeven] and [Zodd] *)
+
 (** [Zdiv2] is defined on all [Z], but notice that for odd negative
-    integers it is not the euclidean quotient: in that case we have [n =
-    2*(n/2)-1] *)
+    integers it is not the euclidean quotient: in that case we have 
+      [n = 2*(n/2)-1] *)
 
 Definition Zdiv2 (z:Z) :=
   match z with
-  | Z0 => 0%Z
-  | Zpos xH => 0%Z
-  | Zpos p => Zpos (Pdiv2 p)
-  | Zneg xH => 0%Z
-  | Zneg p => Zneg (Pdiv2 p)
+    | Z0 => 0%Z
+    | Zpos xH => 0%Z
+    | Zpos p => Zpos (Pdiv2 p)
+    | Zneg xH => 0%Z
+    | Zneg p => Zneg (Pdiv2 p)
   end.
 
 Lemma Zeven_div2 : forall n:Z, Zeven n -> n = (2 * Zdiv2 n)%Z.
 Proof.
-intro x; destruct x.
-auto with arith.
-destruct p; auto with arith.
-intros. absurd (Zeven (Zpos (xI p))); red in |- *; auto with arith.
-intros. absurd (Zeven 1); red in |- *; auto with arith.
-destruct p; auto with arith.
-intros. absurd (Zeven (Zneg (xI p))); red in |- *; auto with arith.
-intros. absurd (Zeven (-1)); red in |- *; auto with arith.
+  intro x; destruct x.
+  auto with arith.
+  destruct p; auto with arith.
+  intros. absurd (Zeven (Zpos (xI p))); red in |- *; auto with arith.
+  intros. absurd (Zeven 1); red in |- *; auto with arith.
+  destruct p; auto with arith.
+  intros. absurd (Zeven (Zneg (xI p))); red in |- *; auto with arith.
+  intros. absurd (Zeven (-1)); red in |- *; auto with arith.
 Qed.
 
 Lemma Zodd_div2 : forall n:Z, (n >= 0)%Z -> Zodd n -> n = (2 * Zdiv2 n + 1)%Z.
 Proof.
-intro x; destruct x.
-intros. absurd (Zodd 0); red in |- *; auto with arith.
-destruct p; auto with arith.
-intros. absurd (Zodd (Zpos (xO p))); red in |- *; auto with arith.
-intros. absurd (Zneg p >= 0)%Z; red in |- *; auto with arith.
+  intro x; destruct x.
+  intros. absurd (Zodd 0); red in |- *; auto with arith.
+  destruct p; auto with arith.
+  intros. absurd (Zodd (Zpos (xO p))); red in |- *; auto with arith.
+  intros. absurd (Zneg p >= 0)%Z; red in |- *; auto with arith.
 Qed.
 
 Lemma Zodd_div2_neg :
- forall n:Z, (n <= 0)%Z -> Zodd n -> n = (2 * Zdiv2 n - 1)%Z.
+  forall n:Z, (n <= 0)%Z -> Zodd n -> n = (2 * Zdiv2 n - 1)%Z.
 Proof.
-intro x; destruct x.
-intros. absurd (Zodd 0); red in |- *; auto with arith.
-intros. absurd (Zneg p >= 0)%Z; red in |- *; auto with arith.
-destruct p; auto with arith.
-intros. absurd (Zodd (Zneg (xO p))); red in |- *; auto with arith.
+  intro x; destruct x.
+  intros. absurd (Zodd 0); red in |- *; auto with arith.
+  intros. absurd (Zneg p >= 0)%Z; red in |- *; auto with arith.
+  destruct p; auto with arith.
+  intros. absurd (Zodd (Zneg (xO p))); red in |- *; auto with arith.
 Qed.
 
 Lemma Z_modulo_2 :
- forall n:Z, {y : Z | n = (2 * y)%Z} + {y : Z | n = (2 * y + 1)%Z}.
+  forall n:Z, {y : Z | n = (2 * y)%Z} + {y : Z | n = (2 * y + 1)%Z}.
 Proof.
-intros x.
-elim (Zeven_odd_dec x); intro.
-left. split with (Zdiv2 x). exact (Zeven_div2 x a).
-right. generalize b; clear b; case x.
-intro b; inversion b.
-intro p; split with (Zdiv2 (Zpos p)). apply (Zodd_div2 (Zpos p)); trivial.
-unfold Zge, Zcompare in |- *; simpl in |- *; discriminate.
-intro p; split with (Zdiv2 (Zpred (Zneg p))).
-pattern (Zneg p) at 1 in |- *; rewrite (Zsucc_pred (Zneg p)).
-pattern (Zpred (Zneg p)) at 1 in |- *; rewrite (Zeven_div2 (Zpred (Zneg p))).
-reflexivity.
-apply Zeven_pred; assumption.
+  intros x.
+  elim (Zeven_odd_dec x); intro.
+  left. split with (Zdiv2 x). exact (Zeven_div2 x a).
+  right. generalize b; clear b; case x.
+  intro b; inversion b.
+  intro p; split with (Zdiv2 (Zpos p)). apply (Zodd_div2 (Zpos p)); trivial.
+  unfold Zge, Zcompare in |- *; simpl in |- *; discriminate.
+  intro p; split with (Zdiv2 (Zpred (Zneg p))).
+  pattern (Zneg p) at 1 in |- *; rewrite (Zsucc_pred (Zneg p)).
+  pattern (Zpred (Zneg p)) at 1 in |- *; rewrite (Zeven_div2 (Zpred (Zneg p))).
+  reflexivity.
+  apply Zeven_pred; assumption.
 Qed.
 
 Lemma Zsplit2 :
- forall n:Z,
-   {p : Z * Z |
-   let (x1, x2) := p in n = (x1 + x2)%Z /\ (x1 = x2 \/ x2 = (x1 + 1)%Z)}.
+  forall n:Z,
+    {p : Z * Z |
+      let (x1, x2) := p in n = (x1 + x2)%Z /\ (x1 = x2 \/ x2 = (x1 + 1)%Z)}.
 Proof.
-intros x.
-elim (Z_modulo_2 x); intros [y Hy]; rewrite Zmult_comm in Hy;
- rewrite <- Zplus_diag_eq_mult_2 in Hy.
-exists (y, y); split. 
-assumption.
-left; reflexivity.
-exists (y, (y + 1)%Z); split.
-rewrite Zplus_assoc; assumption.
-right; reflexivity.
-Qed.
\ No newline at end of file
+  intros x.
+  elim (Z_modulo_2 x); intros [y Hy]; rewrite Zmult_comm in Hy;
+    rewrite <- Zplus_diag_eq_mult_2 in Hy.
+  exists (y, y); split. 
+  assumption.
+  left; reflexivity.
+  exists (y, (y + 1)%Z); split.
+  rewrite Zplus_assoc; assumption.
+  right; reflexivity.
+Qed.
+
diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v
index a9ee2c87..b8f8ba30 100644
--- a/theories/ZArith/Zhints.v
+++ b/theories/ZArith/Zhints.v
@@ -6,26 +6,24 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zhints.v,v 1.8.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+(*i $Id: Zhints.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (** This file centralizes the lemmas about [Z], classifying them
     according to the way they can be used in automatic search  *)
 
-(*i*)
+(** Lemmas which clearly leads to simplification during proof search are *)
+(** declared as Hints. A definite status (Hint or not) for the other lemmas *)
+(** remains to be given *)
 
-(* Lemmas which clearly leads to simplification during proof search are *)
-(* declared as Hints. A definite status (Hint or not) for the other lemmas *)
-(* remains to be given *)
+(** Structure of the file *)
+(** - simplification lemmas (only those are declared as Hints) *)
+(** - reversible lemmas relating operators *)
+(** - useful Bottom-up lemmas              *)
+(** - irreversible lemmas with meta-variables *)
+(** - unclear or too specific lemmas       *)
+(** - lemmas to be used as rewrite rules   *)
 
-(* Structure of the file *)
-(* - simplification lemmas (only those are declared as Hints) *)
-(* - reversible lemmas relating operators *)
-(* - useful Bottom-up lemmas              *)
-(* - irreversible lemmas with meta-variables *)
-(* - unclear or too specific lemmas       *)
-(* - lemmas to be used as rewrite rules   *)
-
-(* Lemmas involving positive and compare are not taken into account *)
+(** Lemmas involving positive and compare are not taken into account *)
 
 Require Import BinInt.
 Require Import Zorder.
@@ -37,32 +35,33 @@ Require Import auxiliary.
 Require Import Zmisc.
 Require Import Wf_Z.
 
-(**********************************************************************)
-(*                  Simplification lemmas                             *)
-(* No subgoal or smaller subgoals                                     *)
+(************************************************************************)
+(** *                 Simplification lemmas                             *)
+
+(** No subgoal or smaller subgoals                                     *)
 
 Hint Resolve 
-  (* A) Reversible simplification lemmas (no loss of information)      *)
-  (* Should clearly declared as hints                                  *)
+  (** ** Reversible simplification lemmas (no loss of information)      *)
+  (** Should clearly be declared as hints                               *)
   
-  (* Lemmas ending by eq *)
+  (** Lemmas ending by eq *)
   Zsucc_eq_compat (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *)
   
-  (* Lemmas ending by Zgt *)
+  (** Lemmas ending by Zgt *)
   Zsucc_gt_compat (* :(n,m:Z)`m > n`->`(Zs m) > (Zs n)` *)
   Zgt_succ (* :(n:Z)`(Zs n) > n` *)
   Zorder.Zgt_pos_0 (* :(p:positive)`(POS p) > 0` *)
   Zplus_gt_compat_l (* :(n,m,p:Z)`n > m`->`p+n > p+m` *)
   Zplus_gt_compat_r (* :(n,m,p:Z)`n > m`->`n+p > m+p` *)
   
-  (* Lemmas ending by Zlt *)
+  (** Lemmas ending by Zlt *)
   Zlt_succ (* :(n:Z)`n < (Zs n)` *)
   Zsucc_lt_compat (* :(n,m:Z)`n < m`->`(Zs n) < (Zs m)` *)
   Zlt_pred (* :(n:Z)`(Zpred n) < n` *)
   Zplus_lt_compat_l (* :(n,m,p:Z)`n < m`->`p+n < p+m` *)
   Zplus_lt_compat_r (* :(n,m,p:Z)`n < m`->`n+p < m+p` *)
   
-  (* Lemmas ending by Zle *)
+  (** Lemmas ending by Zle *)
   Zle_0_nat (* :(n:nat)`0 <= (inject_nat n)` *)
   Zorder.Zle_0_pos (* :(p:positive)`0 <= (POS p)` *)
   Zle_refl (* :(n:Z)`n <= n` *)
@@ -75,24 +74,24 @@ Hint Resolve
   Zplus_le_compat_r (* :(a,b,c:Z)`a <= b`->`a+c <= b+c` *)
   Zabs_pos (* :(x:Z)`0 <= |x|` *)
   
-  (* B) Irreversible simplification lemmas : Probably to be declared as *)
-  (* hints, when no other simplification is possible *)
+  (** ** Irreversible simplification lemmas *)
+  (** Probably to be declared as hints, when no other simplification is possible *)
   
-  (* Lemmas ending by eq *)
+  (** Lemmas ending by eq *)
   BinInt.Z_eq_mult (* :(x,y:Z)`y = 0`->`y*x = 0` *)
   Zplus_eq_compat (* :(n,m,p,q:Z)`n = m`->`p = q`->`n+p = m+q` *)
   
-  (* Lemmas ending by Zge *)
+  (** Lemmas ending by Zge *)
   Zorder.Zmult_ge_compat_r (* :(a,b,c:Z)`a >= b`->`c >= 0`->`a*c >= b*c` *)
   Zorder.Zmult_ge_compat_l (* :(a,b,c:Z)`a >= b`->`c >= 0`->`c*a >= c*b` *)
   Zorder.Zmult_ge_compat (* :
       (a,b,c,d:Z)`a >= c`->`b >= d`->`c >= 0`->`d >= 0`->`a*b >= c*d` *)
   
-  (* Lemmas ending by Zlt *)
+  (** Lemmas ending by Zlt *)
   Zorder.Zmult_gt_0_compat (* :(a,b:Z)`a > 0`->`b > 0`->`a*b > 0` *)
   Zlt_lt_succ (* :(n,m:Z)`n < m`->`n < (Zs m)` *)
   
-  (* Lemmas ending by Zle *)
+  (** Lemmas ending by Zle *)
   Zorder.Zmult_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x*y` *)
   Zorder.Zmult_le_compat_r (* :(a,b,c:Z)`a <= b`->`0 <= c`->`a*c <= b*c` *)
   Zorder.Zmult_le_compat_l (* :(a,b,c:Z)`a <= b`->`0 <= c`->`c*a <= c*b` *)
@@ -103,68 +102,118 @@ Hint Resolve
   : zarith.
   
 (**********************************************************************)
-(*         Reversible lemmas relating operators                       *)
-(* Probably to be declared as hints but need to define precedences    *)
+(** *        Reversible lemmas relating operators                     *)
+(** Probably to be declared as hints but need to define precedences   *)
 
-(* A) Conversion between comparisons/predicates and arithmetic operators
+(** ** Conversion between comparisons/predicates and arithmetic operators *)
 
-(* Lemmas ending by eq *)
+(** Lemmas ending by eq *)
+(** 
+<<
 Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0`
 Zabs_eq: (x:Z)`0 <= x`->`|x| = x`
 Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)`
 Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1`
+>>
+*)
 
-(* Lemmas ending by Zgt *)
+(** Lemmas ending by Zgt *)
+(** 
+<<
 Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y`
 Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0`
+>>
+*)
 
-(* Lemmas ending by Zlt *)
+(** Lemmas ending by Zlt *)
+(** 
+<<
 Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y`
 Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)`
 Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n`
+>>
+*)
 
-(* Lemmas ending by Zle *)
+(** Lemmas ending by Zle *)
+(** 
+<<
 Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)`
 Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y`
 Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)`
 Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)`
 Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)`
+>>
+*)
 
-(* B) Conversion between nat comparisons and Z comparisons *)
+(** ** Conversion between nat comparisons and Z comparisons *)
 
-(* Lemmas ending by eq *)
+(** Lemmas ending by eq *)
+(** 
+<<
 inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)`
+>>
+*)
 
-(* Lemmas ending by Zge *)
+(** Lemmas ending by Zge *)
+(** 
+<<
 inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)`
+>>
+*)
 
-(* Lemmas ending by Zgt *)
+(** Lemmas ending by Zgt *)
+(** 
+<<
 inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)`
+>>
+*)
 
-(* Lemmas ending by Zlt *)
+(** Lemmas ending by Zlt *)
+(** 
+<<
 inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)`
+>>
+*)
 
-(* Lemmas ending by Zle *)
+(** Lemmas ending by Zle *)
+(** 
+<<
 inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)`
+>>
+*)
 
-(* C) Conversion between comparisons *)
+(** ** Conversion between comparisons *)
 
-(* Lemmas ending by Zge *)
+(** Lemmas ending by Zge *)
+(** 
+<<
 not_Zlt: (x,y:Z)~`x < y`->`x >= y`
 Zle_ge: (m,n:Z)`m <= n`->`n >= m`
+>>
+*)
 
-(* Lemmas ending by Zgt *)
+(** Lemmas ending by Zgt *)
+(** 
+<<
 Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n`
 not_Zle: (x,y:Z)~`x <= y`->`x > y`
 Zlt_gt: (m,n:Z)`m < n`->`n > m`
 Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n`
+>>
+*)
 
-(* Lemmas ending by Zlt *)
+(** Lemmas ending by Zlt *)
+(** 
+<<
 not_Zge: (x,y:Z)~`x >= y`->`x < y`
 Zgt_lt: (m,n:Z)`m > n`->`n < m`
 Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)`
+>>
+*)
 
-(* Lemmas ending by Zle *)
+(** Lemmas ending by Zle *)
+(** 
+<<
 Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)`
 not_Zgt: (x,y:Z)~`x > y`->`x <= y`
 Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p`
@@ -174,138 +223,226 @@ Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p`
 Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m`
 Zlt_le_weak: (n,m:Z)`n < m`->`n <= m`
 Zle_refl: (n,m:Z)`n = m`->`n <= m`
+>>
+*)
 
-(* D) Irreversible simplification involving several comparaisons, *)
-(*    useful with clear precedences *)
+(** ** Irreversible simplification involving several comparaisons *)
+(**    useful with clear precedences *)
 
-(* Lemmas ending by Zlt *)
+(** Lemmas ending by Zlt *)
+(** 
+<<
 Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d`
 Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d`
+>>
+*)
 
-(* D) What is decreasing here ? *)
+(** ** What is decreasing here ? *)
 
-(* Lemmas ending by eq *)
+(** Lemmas ending by eq *)
+(** 
+<<
 Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m`
+>>
+*)
 
-(* Lemmas ending by Zgt *)
+(** Lemmas ending by Zgt *)
+(** 
+<<
 Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n`
+>>
+*)
 
-(* Lemmas ending by Zlt *)
+(** Lemmas ending by Zlt *)
+(** 
+<<
 Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)`
-
+>>
 *)
 
 (**********************************************************************)
-(*                 Useful Bottom-up lemmas                            *)
+(** *                Useful Bottom-up lemmas                          *)
 
-(* A) Bottom-up simplification: should be used 
+(** ** Bottom-up simplification: should be used *)
 
-(* Lemmas ending by eq *)
+(** Lemmas ending by eq *)
+(** 
+<< 
 Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m`
 Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p`
 Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m`
 Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m`
+>>
+*)
 
-(* Lemmas ending by Zgt *)
+(** Lemmas ending by Zgt *)
+(** 
+<< 
 Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m`
 Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m`
-Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n`
+Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` 
+>> 
+*)
 
-(* Lemmas ending by Zlt *)
+(** Lemmas ending by Zlt *)
+(** 
+<< 
 Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m`
 Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m`
-Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m`
+Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` 
+>> 
+*)
 
-(* Lemmas ending by Zle *)
-Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m`
+(** Lemmas ending by Zle *)
+(** << Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m`
 Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m`
-Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n`
+Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *)
 
-(* B) Bottom-up irreversible (syntactic) simplification *)
+(** ** Bottom-up irreversible (syntactic) simplification *)
 
-(* Lemmas ending by Zle *)
+(** Lemmas ending by Zle *)
+(** 
+<<
 Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m`
+>>
+*)
 
-(* C) Other unclearly simplifying lemmas *)
+(** ** Other unclearly simplifying lemmas *)
 
-(* Lemmas ending by Zeq *)
-Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0`
+(** Lemmas ending by Zeq *)
+(** 
+<< 
+Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` 
+>> 
+*)
 
 (* Lemmas ending by Zgt *)
+(** 
+<< 
 Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0`
+>>
+*)
 
 (* Lemmas ending by Zlt *)
+(** 
+<< 
 pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y`
+>> 
+*)
 
 (* Lemmas ending by Zle *)
+(** 
+<< 
 Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y`
 OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y`
+>> 
 *)
 
+
 (**********************************************************************)
-(*           Irreversible lemmas with meta-variables                  *)
-(* To be used by EAuto                                                
+(** *        Irreversible lemmas with meta-variables                  *)
+(** To be used by EAuto                                               *) 
 
-Hints Immediate
-(* Lemmas ending by eq *)
+(* Hints Immediate *)
+(** Lemmas ending by eq *)
+(** 
+<< 
 Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m`
+>>
+*)
 
-(* Lemmas ending by Zge *)
+(** Lemmas ending by Zge *)
+(** 
+<< 
 Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p`
+>> 
+*)
 
-(* Lemmas ending by Zgt *)
+(** Lemmas ending by Zgt *)
+(** 
+<< 
 Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p`
 Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p`
 Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p`
 Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p`
+>> 
+*)
 
-(* Lemmas ending by Zlt *)
+(** Lemmas ending by Zlt *)
+(** 
+<< 
 Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p`
 Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p`
 Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p`
+>> 
+*)
 
-(* Lemmas ending by Zle *)
+(** Lemmas ending by Zle *)
+(** 
+<< 
 Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p`
+>> 
 *)
 
+
 (**********************************************************************)
-(*               Unclear or too specific lemmas                       *)
-(* Not to be used ??                                                  *)
+(** *               Unclear or too specific lemmas                    *)
+(** Not to be used ?                                                  *)
 
-(* A) Irreversible and too specific (not enough regular) 
+(** ** Irreversible and too specific (not enough regular) *)
 
-(* Lemmas ending by Zle *)
+(** Lemmas ending by Zle *)
+(**
+<<
 Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x`
 Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z`
 OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z`
 OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t`
+>>
+*)
 
+(** ** Expansion and too specific ? *)
 
-(* B) Expansion and too specific ? *)
-
-(* Lemmas ending by Zge *)
+(** Lemmas ending by Zge *)
+(**
+<<
 Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b`
+>>
+*)
 
-(* Lemmas ending by Zgt *)
+(** Lemmas ending by Zgt *)
+(**
+<<
 Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b`
 Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y`
+>>
+*)
 
-(* Lemmas ending by Zle *)
+(** Lemmas ending by Zle *)
+(**
+<<
 Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b`
 Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y`
+>>
+*)
 
-(* C) Reversible but too specific ? *)
+(** ** Reversible but too specific ? *)
 
-(* Lemmas ending by Zlt *)
+(** Lemmas ending by Zlt *)
+(**
+<<
 Zlt_minus: (n,m:Z)`0 < m`->`n-m < n`
+>>
 *)
 
 (**********************************************************************)
-(*               Lemmas to be used as rewrite rules                   *)
-(* but can also be used as hints                                      
+(** *               Lemmas to be used as rewrite rules                *)
+(** but can also be used as hints                                     *)
 
-(* Left-to-right simplification lemmas (a symbol disappears) *)
+(** Left-to-right simplification lemmas (a symbol disappears) *)
 
+(**
+<<
 Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m)
 Zmin_n_n: (n:Z)`(Zmin n n) = n`
 Zmult_1_n: (n:Z)`1*n = n`
@@ -322,9 +459,13 @@ Zmult_one: (x:Z)`1*x = x`
 Zero_mult_left: (x:Z)`0*x = 0`
 Zero_mult_right: (x:Z)`x*0 = 0`
 Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y`
+>>
+*)
 
-(* Right-to-left simplification lemmas (a symbol disappears) *)
+(** Right-to-left simplification lemmas (a symbol disappears) *)
 
+(**
+<<
 Zpred_Sn: (m:Z)`m = (Zpred (Zs m))`
 Zs_pred: (n:Z)`n = (Zs (Zpred n))`
 Zplus_n_O: (n:Z)`n = n+0`
@@ -333,9 +474,13 @@ Zminus_n_O: (n:Z)`n = n-0`
 Zminus_n_n: (n:Z)`0 = n-n`
 Zred_factor6: (x:Z)`x = x+0`
 Zred_factor0: (x:Z)`x = x*1`
+>>
+*)
 
-(* Unclear orientation (no symbol disappears) *)
+(** Unclear orientation (no symbol disappears) *)
 
+(**
+<<
 Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)`
 Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)`
 Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))`
@@ -370,17 +515,25 @@ Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)`
 Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)`
 Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y`
 Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n`
+>>
+*)
 
-(* nat <-> Z *)
+(** nat <-> Z *)
+(**
+<<
 inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))`
 inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)`
 inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)`
 inj_minus1:
  (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)`
 inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0`
+>>
+*)
 
-(* Too specific ? *)
+(** Too specific ? *)
+(**
+<<
 Zred_factor5: (x,y:Z)`x*0+y = y`
+>>
 *)
 
-(*i*)
\ No newline at end of file
diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v
index b575de88..d8f4f236 100644
--- a/theories/ZArith/Zlogarithm.v
+++ b/theories/ZArith/Zlogarithm.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zlogarithm.v,v 1.14.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+(*i $Id: Zlogarithm.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 (**********************************************************************)
 (** The integer logarithms with base 2. 
@@ -27,234 +27,221 @@ Require Import Zpower.
 Open Local Scope Z_scope.
 
 Section Log_pos. (* Log of positive integers *)
-
-(** First we build [log_inf] and [log_sup] *)
-
-Fixpoint log_inf (p:positive) : Z :=
-  match p with
-  | xH => 0	(* 1 *)
-  | xO q => Zsucc (log_inf q)	(* 2n *)
-  | xI q => Zsucc (log_inf q)	(* 2n+1 *)
-  end.
-Fixpoint log_sup (p:positive) : Z :=
-  match p with
-  | xH => 0	(* 1 *)
-  | xO n => Zsucc (log_sup n) (* 2n *)
-  | xI n => Zsucc (Zsucc (log_inf n))	(* 2n+1 *)
-  end.
-
-Hint Unfold log_inf log_sup.
-
-(** Then we give the specifications of [log_inf] and [log_sup] 
+  
+  (** First we build [log_inf] and [log_sup] *)
+
+  Fixpoint log_inf (p:positive) : Z :=
+    match p with
+      | xH => 0	(* 1 *)
+      | xO q => Zsucc (log_inf q)	(* 2n *)
+      | xI q => Zsucc (log_inf q)	(* 2n+1 *)
+    end.
+
+  Fixpoint log_sup (p:positive) : Z :=
+    match p with
+      | xH => 0	(* 1 *)
+      | xO n => Zsucc (log_sup n) (* 2n *)
+      | xI n => Zsucc (Zsucc (log_inf n))	(* 2n+1 *)
+    end.
+  
+  Hint Unfold log_inf log_sup.
+  
+  (** Then we give the specifications of [log_inf] and [log_sup] 
     and prove their validity *)
-
-(*i Hints Resolve ZERO_le_S : zarith. i*)
-Hint Resolve Zle_trans: zarith.
-
-Theorem log_inf_correct :
- forall x:positive,
-   0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Zsucc (log_inf x)).
-simple induction x; intros; simpl in |- *;
- [ elim H; intros Hp HR; clear H; split;
-    [ auto with zarith
-    | conditional apply Zle_le_succ; trivial rewrite
-       two_p_S with (x := Zsucc (log_inf p));
-       conditional trivial rewrite two_p_S;
-       conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xI p);
-       omega ]
- | elim H; intros Hp HR; clear H; split;
-    [ auto with zarith
-    | conditional apply Zle_le_succ; trivial rewrite
-       two_p_S with (x := Zsucc (log_inf p));
-       conditional trivial rewrite two_p_S;
-       conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xO p);
-       omega ]
- | unfold two_power_pos in |- *; unfold shift_pos in |- *; simpl in |- *;
-    omega ].
-Qed.
-
-Definition log_inf_correct1 (p:positive) := proj1 (log_inf_correct p).
-Definition log_inf_correct2 (p:positive) := proj2 (log_inf_correct p).
-
-Opaque log_inf_correct1 log_inf_correct2.
-
-Hint Resolve log_inf_correct1 log_inf_correct2: zarith.
-
-Lemma log_sup_correct1 : forall p:positive, 0 <= log_sup p.
-simple induction p; intros; simpl in |- *; auto with zarith.
-Qed.
-
-(** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)]
-    either [(log_sup p)=(log_inf p)+1] *)
-
-Theorem log_sup_log_inf :
- forall p:positive,
-    IF Zpos p = two_p (log_inf p) then Zpos p = two_p (log_sup p)
-   else log_sup p = Zsucc (log_inf p).
-
-simple induction p; intros;
- [ elim H; right; simpl in |- *;
-    rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-    rewrite BinInt.Zpos_xI; unfold Zsucc in |- *; omega
- | elim H; clear H; intro Hif;
-    [ left; simpl in |- *;
-       rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-       rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0));
-       rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); 
-       auto
-    | right; simpl in |- *;
-       rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-       rewrite BinInt.Zpos_xO; unfold Zsucc in |- *; 
-       omega ]
- | left; auto ].
-Qed.
-
-Theorem log_sup_correct2 :
- forall x:positive, two_p (Zpred (log_sup x)) < Zpos x <= two_p (log_sup x).
-
-intro.
-elim (log_sup_log_inf x).
-(* x is a power of two and [log_sup = log_inf] *)
-intros [E1 E2]; rewrite E2.
-split; [ apply two_p_pred; apply log_sup_correct1 | apply Zle_refl ].
-intros [E1 E2]; rewrite E2.
-rewrite <- (Zpred_succ (log_inf x)).
-generalize (log_inf_correct2 x); omega.
-Qed.
-
-Lemma log_inf_le_log_sup : forall p:positive, log_inf p <= log_sup p.
-simple induction p; simpl in |- *; intros; omega.
-Qed.
-
-Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Zsucc (log_inf p).
-simple induction p; simpl in |- *; intros; omega.
-Qed.
-
-(** Now it's possible to specify and build the [Log] rounded to the nearest *)
-
-Fixpoint log_near (x:positive) : Z :=
-  match x with
-  | xH => 0
-  | xO xH => 1
-  | xI xH => 2
-  | xO y => Zsucc (log_near y)
-  | xI y => Zsucc (log_near y)
-  end.    
-
-Theorem log_near_correct1 : forall p:positive, 0 <= log_near p.
-simple induction p; simpl in |- *; intros;
- [ elim p0; auto with zarith
- | elim p0; auto with zarith
- | trivial with zarith ].
-intros; apply Zle_le_succ.
-generalize H0; elim p1; intros; simpl in |- *;
- [ assumption | assumption | apply Zorder.Zle_0_pos ].
-intros; apply Zle_le_succ.
-generalize H0; elim p1; intros; simpl in |- *;
- [ assumption | assumption | apply Zorder.Zle_0_pos ].
-Qed.
-
-Theorem log_near_correct2 :
- forall p:positive, log_near p = log_inf p \/ log_near p = log_sup p.
-simple induction p.
-intros p0 [Einf| Esup].
-simpl in |- *. rewrite Einf.
-case p0; [ left | left | right ]; reflexivity.
-simpl in |- *; rewrite Esup.
-elim (log_sup_log_inf p0).
-generalize (log_inf_le_log_sup p0).
-generalize (log_sup_le_Slog_inf p0).
-case p0; auto with zarith.
-intros; omega.
-case p0; intros; auto with zarith.
-intros p0 [Einf| Esup].
-simpl in |- *.
-repeat rewrite Einf.
-case p0; intros; auto with zarith.
-simpl in |- *.
-repeat rewrite Esup.
-case p0; intros; auto with zarith.
-auto.
-Qed.
-
-(*i******************
-Theorem log_near_correct: (p:positive)
-  `| (two_p (log_near p)) - (POS p) | <= (POS p)-(two_p (log_inf p))`
-  /\`| (two_p (log_near p)) - (POS p) | <= (two_p (log_sup p))-(POS p)`.
-Intro.
-Induction p.
-Intros p0 [(Einf1,Einf2)|(Esup1,Esup2)].
-Unfold log_near log_inf log_sup. Fold log_near log_inf log_sup.
-Rewrite Einf1.
-Repeat Rewrite two_p_S.
-Case p0; [Left | Left | Right].
-
-Split.
-Simpl.
-Rewrite E1; Case p0; Try Reflexivity.
-Compute.
-Unfold log_near; Fold log_near.
-Unfold log_inf; Fold log_inf.
-Repeat Rewrite E1.
-Split.
-**********************************i*)
+  
+  Hint Resolve Zle_trans: zarith.
+
+  Theorem log_inf_correct :
+    forall x:positive,
+      0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Zsucc (log_inf x)).
+    simple induction x; intros; simpl in |- *;
+      [ elim H; intros Hp HR; clear H; split;
+	[ auto with zarith
+	  | conditional apply Zle_le_succ; trivial rewrite
+	    two_p_S with (x := Zsucc (log_inf p));
+	    conditional trivial rewrite two_p_S;
+	      conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xI p);
+		omega ]
+	| elim H; intros Hp HR; clear H; split;
+	  [ auto with zarith
+	    | conditional apply Zle_le_succ; trivial rewrite
+	      two_p_S with (x := Zsucc (log_inf p));
+	      conditional trivial rewrite two_p_S;
+		conditional trivial rewrite two_p_S in HR; rewrite (BinInt.Zpos_xO p);
+		  omega ]
+	| unfold two_power_pos in |- *; unfold shift_pos in |- *; simpl in |- *;
+	  omega ].
+  Qed.
+
+  Definition log_inf_correct1 (p:positive) := proj1 (log_inf_correct p).
+  Definition log_inf_correct2 (p:positive) := proj2 (log_inf_correct p).
+
+  Opaque log_inf_correct1 log_inf_correct2.
+
+  Hint Resolve log_inf_correct1 log_inf_correct2: zarith.
+
+  Lemma log_sup_correct1 : forall p:positive, 0 <= log_sup p.
+  Proof.
+    simple induction p; intros; simpl in |- *; auto with zarith.
+  Qed.
+
+  (** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)]
+      either [(log_sup p)=(log_inf p)+1] *)
+
+  Theorem log_sup_log_inf :
+    forall p:positive,
+      IF Zpos p = two_p (log_inf p) then Zpos p = two_p (log_sup p)
+    else log_sup p = Zsucc (log_inf p).
+  Proof.
+    simple induction p; intros;
+      [ elim H; right; simpl in |- *;
+	rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
+	  rewrite BinInt.Zpos_xI; unfold Zsucc in |- *; omega
+	| elim H; clear H; intro Hif;
+	  [ left; simpl in |- *;
+	    rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
+	      rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0));
+		rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); 
+		  auto
+	    | right; simpl in |- *;
+	      rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
+		rewrite BinInt.Zpos_xO; unfold Zsucc in |- *; 
+		  omega ]
+	| left; auto ].
+  Qed.
+
+  Theorem log_sup_correct2 :
+    forall x:positive, two_p (Zpred (log_sup x)) < Zpos x <= two_p (log_sup x).
+  Proof.
+    intro.
+    elim (log_sup_log_inf x).
+    (* x is a power of two and [log_sup = log_inf] *)
+    intros [E1 E2]; rewrite E2.
+    split; [ apply two_p_pred; apply log_sup_correct1 | apply Zle_refl ].
+    intros [E1 E2]; rewrite E2.
+    rewrite <- (Zpred_succ (log_inf x)).
+    generalize (log_inf_correct2 x); omega.
+  Qed.
+
+  Lemma log_inf_le_log_sup : forall p:positive, log_inf p <= log_sup p.
+  Proof.
+    simple induction p; simpl in |- *; intros; omega.
+  Qed.
+
+  Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Zsucc (log_inf p).
+  Proof.
+    simple induction p; simpl in |- *; intros; omega.
+  Qed.
+
+  (** Now it's possible to specify and build the [Log] rounded to the nearest *)
+
+  Fixpoint log_near (x:positive) : Z :=
+    match x with
+      | xH => 0
+      | xO xH => 1
+      | xI xH => 2
+      | xO y => Zsucc (log_near y)
+      | xI y => Zsucc (log_near y)
+    end.    
+
+  Theorem log_near_correct1 : forall p:positive, 0 <= log_near p.
+  Proof.
+    simple induction p; simpl in |- *; intros;
+      [ elim p0; auto with zarith
+	| elim p0; auto with zarith
+	| trivial with zarith ].
+    intros; apply Zle_le_succ.
+    generalize H0; elim p1; intros; simpl in |- *;
+      [ assumption | assumption | apply Zorder.Zle_0_pos ].
+    intros; apply Zle_le_succ.
+    generalize H0; elim p1; intros; simpl in |- *;
+      [ assumption | assumption | apply Zorder.Zle_0_pos ].
+  Qed.
+
+  Theorem log_near_correct2 :
+    forall p:positive, log_near p = log_inf p \/ log_near p = log_sup p.
+  Proof.
+    simple induction p.
+    intros p0 [Einf| Esup].
+    simpl in |- *. rewrite Einf.
+    case p0; [ left | left | right ]; reflexivity.
+    simpl in |- *; rewrite Esup.
+    elim (log_sup_log_inf p0).
+    generalize (log_inf_le_log_sup p0).
+    generalize (log_sup_le_Slog_inf p0).
+    case p0; auto with zarith.
+    intros; omega.
+    case p0; intros; auto with zarith.
+    intros p0 [Einf| Esup].
+    simpl in |- *.
+    repeat rewrite Einf.
+    case p0; intros; auto with zarith.
+    simpl in |- *.
+    repeat rewrite Esup.
+    case p0; intros; auto with zarith.
+    auto.
+  Qed.
 
 End Log_pos.
 
 Section divers.
 
-(** Number of significative digits. *)
-
-Definition N_digits (x:Z) :=
-  match x with
-  | Zpos p => log_inf p
-  | Zneg p => log_inf p
-  | Z0 => 0
-  end.
-
-Lemma ZERO_le_N_digits : forall x:Z, 0 <= N_digits x.
-simple induction x; simpl in |- *;
- [ apply Zle_refl | exact log_inf_correct1 | exact log_inf_correct1 ].
-Qed.
-
-Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z_of_nat n.
-simple induction n; intros;
- [ try trivial | rewrite Znat.inj_S; rewrite <- H; reflexivity ].
-Qed.
-
-Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z_of_nat n.
-simple induction n; intros;
- [ try trivial | rewrite Znat.inj_S; rewrite <- H; reflexivity ].
-Qed.
-
-(** [Is_power p] means that p is a power of two *)
-Fixpoint Is_power (p:positive) : Prop :=
-  match p with
-  | xH => True
-  | xO q => Is_power q
-  | xI q => False
-  end.
-
-Lemma Is_power_correct :
- forall p:positive, Is_power p <-> (exists y : nat, p = shift_nat y 1).
-
-split;
- [ elim p;
-    [ simpl in |- *; tauto
-    | simpl in |- *; intros; generalize (H H0); intro H1; elim H1;
-       intros y0 Hy0; exists (S y0); rewrite Hy0; reflexivity
-    | intro; exists 0%nat; reflexivity ]
- | intros; elim H; intros; rewrite H0; elim x; intros; simpl in |- *; trivial ].
-Qed.
-
-Lemma Is_power_or : forall p:positive, Is_power p \/ ~ Is_power p.
-simple induction p;
- [ intros; right; simpl in |- *; tauto
- | intros; elim H;
-    [ intros; left; simpl in |- *; exact H0
-    | intros; right; simpl in |- *; exact H0 ]
- | left; simpl in |- *; trivial ].
-Qed.
+  (** Number of significative digits. *)
+  
+  Definition N_digits (x:Z) :=
+    match x with
+      | Zpos p => log_inf p
+      | Zneg p => log_inf p
+      | Z0 => 0
+    end.
+
+  Lemma ZERO_le_N_digits : forall x:Z, 0 <= N_digits x.
+  Proof.
+    simple induction x; simpl in |- *;
+      [ apply Zle_refl | exact log_inf_correct1 | exact log_inf_correct1 ].
+  Qed.
+
+  Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z_of_nat n.
+  Proof.
+    simple induction n; intros;
+      [ try trivial | rewrite Znat.inj_S; rewrite <- H; reflexivity ].
+  Qed.
+
+  Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z_of_nat n.
+  Proof.
+    simple induction n; intros;
+      [ try trivial | rewrite Znat.inj_S; rewrite <- H; reflexivity ].
+  Qed.
+
+  (** [Is_power p] means that p is a power of two *)
+  Fixpoint Is_power (p:positive) : Prop :=
+    match p with
+      | xH => True
+      | xO q => Is_power q
+      | xI q => False
+    end.
+
+  Lemma Is_power_correct :
+    forall p:positive, Is_power p <-> (exists y : nat, p = shift_nat y 1).
+  Proof.
+    split;
+      [ elim p;
+	[ simpl in |- *; tauto
+	  | simpl in |- *; intros; generalize (H H0); intro H1; elim H1;
+	    intros y0 Hy0; exists (S y0); rewrite Hy0; reflexivity
+	  | intro; exists 0%nat; reflexivity ]
+	| intros; elim H; intros; rewrite H0; elim x; intros; simpl in |- *; trivial ].
+  Qed.
+
+  Lemma Is_power_or : forall p:positive, Is_power p \/ ~ Is_power p.
+  Proof.
+    simple induction p;
+      [ intros; right; simpl in |- *; tauto
+	| intros; elim H;
+	  [ intros; left; simpl in |- *; exact H0
+	    | intros; right; simpl in |- *; exact H0 ]
+	| left; simpl in |- *; trivial ].
+  Qed.
 
 End divers.
 
diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v
new file mode 100644
index 00000000..8af9b891
--- /dev/null
+++ b/theories/ZArith/Zmax.v
@@ -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: Zmax.v 9302 2006-10-27 21:21:17Z barras $ i*)
+
+Require Import Arith_base.
+Require Import BinInt.
+Require Import Zcompare.
+Require Import Zorder.
+
+Open Local Scope Z_scope.
+
+(******************************************)
+(** Maximum of two binary integer numbers *)
+
+Definition Zmax m n :=
+  match m ?= n with
+    | Eq | Gt => m
+    | Lt => n
+  end.
+
+(** * Characterization of maximum on binary integer numbers *)
+
+Lemma Zmax_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmax n m).
+Proof.
+  intros n m P H1 H2; unfold Zmax in |- *; case (n ?= m); auto with arith.
+Qed.
+
+Lemma Zmax_case_strong : forall (n m:Z) (P:Z -> Type), 
+  (m<=n -> P n) -> (n<=m -> P m) -> P (Zmax n m).
+Proof.
+  intros n m P H1 H2; unfold Zmax, Zle, Zge in *.
+  rewrite <- (Zcompare_antisym n m) in H1.
+  destruct (n ?= m); (apply H1|| apply H2); discriminate. 
+Qed.
+
+(** * Least upper bound properties of max *)
+
+Lemma Zle_max_l : forall n m:Z, n <= Zmax n m.
+Proof.
+  intros; apply Zmax_case_strong; auto with zarith.
+Qed.
+
+Notation Zmax1 := Zle_max_l (only parsing).
+
+Lemma Zle_max_r : forall n m:Z, m <= Zmax n m.
+Proof.
+  intros; apply Zmax_case_strong; auto with zarith.
+Qed.
+
+Notation Zmax2 := Zle_max_r (only parsing).
+
+Lemma Zmax_lub : forall n m p:Z, n <= p -> m <= p -> Zmax n m <= p.
+Proof.
+  intros; apply Zmax_case; assumption.
+Qed.
+
+(** * Semi-lattice properties of max *)
+
+Lemma Zmax_idempotent : forall n:Z, Zmax n n = n.
+Proof.
+  intros; apply Zmax_case; auto.
+Qed.
+
+Lemma Zmax_comm : forall n m:Z, Zmax n m = Zmax m n.
+Proof.
+  intros; do 2 apply Zmax_case_strong; intros; 
+    apply Zle_antisym; auto with zarith.
+Qed.
+
+Lemma Zmax_assoc : forall n m p:Z, Zmax n (Zmax m p) = Zmax (Zmax n m) p.
+Proof.
+  intros n m p; repeat apply Zmax_case_strong; intros; 
+    reflexivity || (try apply Zle_antisym); eauto with zarith.
+Qed.
+
+(** * Additional properties of max *)
+
+Lemma Zmax_irreducible_inf : forall n m:Z, Zmax n m = n \/ Zmax n m = m.
+Proof.
+  intros; apply Zmax_case; auto.
+Qed.
+
+Lemma Zmax_le_prime_inf : forall n m p:Z, p <= Zmax n m -> p <= n \/ p <= m.
+Proof.
+  intros n m p; apply Zmax_case; auto.
+Qed.
+
+(** * Operations preserving max *)
+
+Lemma Zsucc_max_distr : 
+  forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m).
+Proof.
+  intros n m; unfold Zmax in |- *; rewrite (Zcompare_succ_compat n m);
+    elim_compare n m; intros E; rewrite E; auto with arith.
+Qed.
+
+Lemma Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p.
+Proof.
+  intros x y n; unfold Zmax in |- *.
+  rewrite (Zplus_comm x n); rewrite (Zplus_comm y n);
+    rewrite (Zcompare_plus_compat x y n).
+  case (x ?= y); apply Zplus_comm.
+Qed.
diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v
index d48e62c5..37d78a74 100644
--- a/theories/ZArith/Zmin.v
+++ b/theories/ZArith/Zmin.v
@@ -5,102 +5,126 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zmin.v,v 1.3.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+(*i $Id: Zmin.v 9302 2006-10-27 21:21:17Z barras $ i*)
 
-(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+(** Initial version from Pierre Crégut (CNET, Lannion, France), 1996.
+    Further extensions by the Coq development team, with suggestions
+    from Russell O'Connor (Radbout U., Nijmegen, The Netherlands).
+ *)
 
-Require Import Arith.
+Require Import Arith_base.
 Require Import BinInt.
 Require Import Zcompare.
 Require Import Zorder.
 
 Open Local Scope Z_scope.
 
-(**********************************************************************)
+(**************************************)
 (** Minimum on binary integer numbers *)
 
-Definition Zmin (n m:Z) :=
-  match n ?= m return Z with
-  | Eq => n
-  | Lt => n
-  | Gt => m
+Unboxed Definition Zmin (n m:Z) :=
+  match n ?= m with
+    | Eq | Lt => n
+    | Gt => m
   end.
 
-(** Properties of minimum on binary integer numbers *)
+(** * Characterization of the minimum on binary integer numbers *)
 
-Lemma Zmin_SS : forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m).
+Lemma Zmin_case_strong : forall (n m:Z) (P:Z -> Type), 
+  (n<=m -> P n) -> (m<=n -> P m) -> P (Zmin n m).
 Proof.
-intros n m; unfold Zmin in |- *; rewrite (Zcompare_succ_compat n m);
- elim_compare n m; intros E; rewrite E; auto with arith.
+  intros n m P H1 H2; unfold Zmin, Zle, Zge in *.
+  rewrite <- (Zcompare_antisym n m) in H2.
+  destruct (n ?= m); (apply H1|| apply H2); discriminate. 
 Qed.
 
+Lemma Zmin_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmin n m).
+Proof.
+  intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith.
+Qed.
+
+(** * Greatest lower bound properties of min *)
+
 Lemma Zle_min_l : forall n m:Z, Zmin n m <= n.
 Proof.
-intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E;
- [ apply Zle_refl
- | apply Zle_refl
- | apply Zlt_le_weak; apply Zgt_lt; exact E ].
+  intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E;
+    [ apply Zle_refl
+      | apply Zle_refl
+      | apply Zlt_le_weak; apply Zgt_lt; exact E ].
 Qed.
 
 Lemma Zle_min_r : forall n m:Z, Zmin n m <= m.
 Proof.
-intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E;
- [ unfold Zle in |- *; rewrite E; discriminate
- | unfold Zle in |- *; rewrite E; discriminate
- | apply Zle_refl ].
+  intros n m; unfold Zmin in |- *; elim_compare n m; intros E; rewrite E;
+    [ unfold Zle in |- *; rewrite E; discriminate
+      | unfold Zle in |- *; rewrite E; discriminate
+      | apply Zle_refl ].
 Qed.
 
-Lemma Zmin_case : forall (n m:Z) (P:Z -> Set), P n -> P m -> P (Zmin n m).
+Lemma Zmin_glb : forall n m p:Z, p <= n -> p <= m -> p <= Zmin n m.
+Proof.
+  intros; apply Zmin_case; assumption.
+Qed.
+
+(** * Semi-lattice properties of min *)
+
+Lemma Zmin_idempotent : forall n:Z, Zmin n n = n.
 Proof.
-intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith.
+  unfold Zmin in |- *; intros; elim (n ?= n); auto.
 Qed.
 
-Lemma Zmin_or : forall n m:Z, Zmin n m = n \/ Zmin n m = m.
+Notation Zmin_n_n := Zmin_idempotent (only parsing).
+
+Lemma Zmin_comm : forall n m:Z, Zmin n m = Zmin m n.
 Proof.
-unfold Zmin in |- *; intros; elim (n ?= m); auto.
+  intros n m; unfold Zmin.
+  rewrite <- (Zcompare_antisym n m).
+  assert (H:=Zcompare_Eq_eq n m).
+  destruct (n ?= m); simpl; auto.
 Qed.
 
-Lemma Zmin_n_n : forall n:Z, Zmin n n = n.
+Lemma Zmin_assoc : forall n m p:Z, Zmin n (Zmin m p) = Zmin (Zmin n m) p.
 Proof.
-unfold Zmin in |- *; intros; elim (n ?= n); auto.
+  intros n m p; repeat apply Zmin_case_strong; intros; 
+    reflexivity || (try apply Zle_antisym); eauto with zarith.
 Qed.
 
-Lemma Zmin_plus : forall n m p:Z, Zmin (n + p) (m + p) = Zmin n m + p.
+(** * Additional properties of min *)
+
+Lemma Zmin_irreducible_inf : forall n m:Z, {Zmin n m = n} + {Zmin n m = m}.
 Proof.
-intros x y n; unfold Zmin in |- *.
-rewrite (Zplus_comm x n); rewrite (Zplus_comm y n);
- rewrite (Zcompare_plus_compat x y n).
-case (x ?= y); apply Zplus_comm.
+  unfold Zmin in |- *; intros; elim (n ?= m); auto.
 Qed.
 
-(**********************************************************************)
-(** Maximum of two binary integer numbers *)
+Lemma Zmin_irreducible : forall n m:Z, Zmin n m = n \/ Zmin n m = m.
+Proof.
+  intros n m; destruct (Zmin_irreducible_inf n m); [left|right]; trivial.
+Qed.
 
-Definition Zmax a b := match a ?= b with
-                       | Lt => b
-                       | _ => a
-                       end.
+Notation Zmin_or := Zmin_irreducible (only parsing).
 
-(** Properties of maximum on binary integer numbers *)
+Lemma Zmin_le_prime_inf : forall n m p:Z, Zmin n m <= p -> {n <= p} + {m <= p}.
+Proof.
+  intros n m p; apply Zmin_case; auto.
+Qed.
 
-Ltac CaseEq name :=
-  generalize (refl_equal name); pattern name at -1 in |- *; case name.
+(** * Operations preserving min *)
 
-Theorem Zmax1 : forall a b, a <= Zmax a b.
+Lemma Zsucc_min_distr : 
+  forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m).
 Proof.
-intros a b; unfold Zmax in |- *; CaseEq (a ?= b); simpl in |- *;
- auto with zarith.
-unfold Zle in |- *; intros H; rewrite H; red in |- *; intros; discriminate.
+  intros n m; unfold Zmin in |- *; rewrite (Zcompare_succ_compat n m);
+    elim_compare n m; intros E; rewrite E; auto with arith.
 Qed.
 
-Theorem Zmax2 : forall a b, b <= Zmax a b.
+Notation Zmin_SS := Zsucc_min_distr (only parsing).
+
+Lemma Zplus_min_distr_r : forall n m p:Z, Zmin (n + p) (m + p) = Zmin n m + p.
 Proof.
-intros a b; unfold Zmax in |- *; CaseEq (a ?= b); simpl in |- *;
- auto with zarith.
-intros H;
- (case (Zle_or_lt b a); auto; unfold Zlt in |- *; rewrite H; intros;
-   discriminate).
-intros H;
- (case (Zle_or_lt b a); auto; unfold Zlt in |- *; rewrite H; intros;
-   discriminate).
+  intros x y n; unfold Zmin in |- *.
+  rewrite (Zplus_comm x n); rewrite (Zplus_comm y n);
+    rewrite (Zcompare_plus_compat x y n).
+  case (x ?= y); apply Zplus_comm.
 Qed.
+
+Notation Zmin_plus := Zplus_min_distr_r (only parsing).
diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v
new file mode 100644
index 00000000..95668cf8
--- /dev/null
+++ b/theories/ZArith/Zminmax.v
@@ -0,0 +1,76 @@
+(************************************************************************)
+(*  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: Zminmax.v 9245 2006-10-17 12:53:34Z notin $ i*)
+
+Require Import Zmin Zmax.
+Require Import BinInt Zorder.
+
+Open Local Scope Z_scope.
+
+(** Lattice properties of min and max on Z *)
+
+(** Absorption *)
+
+Lemma Zmin_max_absorption_r_r : forall n m, Zmax n (Zmin n m) = n.
+Proof.
+  intros; apply Zmin_case_strong; intro; apply Zmax_case_strong; intro; 
+    reflexivity || apply Zle_antisym; trivial.
+Qed.
+
+Lemma Zmax_min_absorption_r_r : forall n m, Zmin n (Zmax n m) = n.
+Proof.
+  intros; apply Zmax_case_strong; intro; apply Zmin_case_strong; intro; 
+    reflexivity || apply Zle_antisym; trivial.
+Qed.
+
+(** Distributivity *)
+
+Lemma Zmax_min_distr_r : 
+  forall n m p, Zmax n (Zmin m p) = Zmin (Zmax n m) (Zmax n p).
+Proof.
+  intros.
+  repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; 
+    reflexivity ||
+      apply Zle_antisym; (assumption || eapply Zle_trans; eassumption).
+Qed.
+
+Lemma Zmin_max_distr_r : 
+  forall n m p, Zmin n (Zmax m p) = Zmax (Zmin n m) (Zmin n p).
+Proof.
+  intros.
+  repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; 
+    reflexivity ||
+      apply Zle_antisym; (assumption || eapply Zle_trans; eassumption).
+Qed.
+
+(** Modularity *)
+
+Lemma Zmax_min_modular_r :
+  forall n m p, Zmax n (Zmin m (Zmax n p)) = Zmin (Zmax n m) (Zmax n p).
+Proof.
+  intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros;
+    reflexivity ||
+      apply Zle_antisym; (assumption || eapply Zle_trans; eassumption).
+Qed.
+
+Lemma Zmin_max_modular_r :
+  forall n m p, Zmin n (Zmax m (Zmin n p)) = Zmax (Zmin n m) (Zmin n p).
+Proof.
+  intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros;
+    reflexivity ||
+      apply Zle_antisym; (assumption || eapply Zle_trans; eassumption).
+Qed.
+
+(** Disassociativity *)
+
+Lemma max_min_disassoc : forall n m p, Zmin n (Zmax m p) <= Zmax (Zmin n m) p.
+Proof.
+  intros; repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros;
+    apply Zle_refl || (assumption || eapply Zle_trans; eassumption).
+Qed.
+
diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v
index adcaf0ba..d01cada6 100644
--- a/theories/ZArith/Zmisc.v
+++ b/theories/ZArith/Zmisc.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zmisc.v,v 1.20.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+(*i $Id: Zmisc.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import BinInt.
 Require Import Zcompare.
@@ -20,78 +20,78 @@ Open Local Scope Z_scope.
 (** [n]th iteration of the function [f] *)
 Fixpoint iter_nat (n:nat) (A:Set) (f:A -> A) (x:A) {struct n} : A :=
   match n with
-  | O => x
-  | S n' => f (iter_nat n' A f x)
+    | O => x
+    | S n' => f (iter_nat n' A f x)
   end.
 
 Fixpoint iter_pos (n:positive) (A:Set) (f:A -> A) (x:A) {struct n} : A :=
   match n with
-  | xH => f x
-  | xO n' => iter_pos n' A f (iter_pos n' A f x)
-  | xI n' => f (iter_pos n' A f (iter_pos n' A f x))
+    | xH => f x
+    | xO n' => iter_pos n' A f (iter_pos n' A f x)
+    | xI n' => f (iter_pos n' A f (iter_pos n' A f x))
   end.
 
 Definition iter (n:Z) (A:Set) (f:A -> A) (x:A) :=
   match n with
-  | Z0 => x
-  | Zpos p => iter_pos p A f x
-  | Zneg p => x
+    | Z0 => x
+    | Zpos p => iter_pos p A f x
+    | Zneg p => x
   end.
 
 Theorem iter_nat_plus :
- forall (n m:nat) (A:Set) (f:A -> A) (x:A),
-   iter_nat (n + m) A f x = iter_nat n A f (iter_nat m A f x).
+  forall (n m:nat) (A:Set) (f:A -> A) (x:A),
+    iter_nat (n + m) A f x = iter_nat n A f (iter_nat m A f x).
 Proof.    
-simple induction n;
- [ simpl in |- *; auto with arith
- | intros; simpl in |- *; apply f_equal with (f := f); apply H ].  
+  simple induction n;
+    [ simpl in |- *; auto with arith
+      | intros; simpl in |- *; apply f_equal with (f := f); apply H ].  
 Qed.
 
 Theorem iter_nat_of_P :
- forall (p:positive) (A:Set) (f:A -> A) (x:A),
-   iter_pos p A f x = iter_nat (nat_of_P p) A f x.
+  forall (p:positive) (A:Set) (f:A -> A) (x:A),
+    iter_pos p A f x = iter_nat (nat_of_P p) A f x.
 Proof.    
-intro n; induction n as [p H| p H| ];
- [ intros; simpl in |- *; rewrite (H A f x);
-    rewrite (H A f (iter_nat (nat_of_P p) A f x)); 
-    rewrite (ZL6 p); symmetry  in |- *; apply f_equal with (f := f);
-    apply iter_nat_plus
- | intros; unfold nat_of_P in |- *; simpl in |- *; rewrite (H A f x);
-    rewrite (H A f (iter_nat (nat_of_P p) A f x)); 
-    rewrite (ZL6 p); symmetry  in |- *; apply iter_nat_plus
- | simpl in |- *; auto with arith ].
+  intro n; induction n as [p H| p H| ];
+    [ intros; simpl in |- *; rewrite (H A f x);
+      rewrite (H A f (iter_nat (nat_of_P p) A f x)); 
+	rewrite (ZL6 p); symmetry  in |- *; apply f_equal with (f := f);
+	  apply iter_nat_plus
+      | intros; unfold nat_of_P in |- *; simpl in |- *; rewrite (H A f x);
+	rewrite (H A f (iter_nat (nat_of_P p) A f x)); 
+	  rewrite (ZL6 p); symmetry  in |- *; apply iter_nat_plus
+      | simpl in |- *; auto with arith ].
 Qed.
 
 Theorem iter_pos_plus :
- forall (p q:positive) (A:Set) (f:A -> A) (x:A),
-   iter_pos (p + q) A f x = iter_pos p A f (iter_pos q A f x).
+  forall (p q:positive) (A:Set) (f:A -> A) (x:A),
+    iter_pos (p + q) A f x = iter_pos p A f (iter_pos q A f x).
 Proof.    
-intros n m; intros.
-rewrite (iter_nat_of_P m A f x).
-rewrite (iter_nat_of_P n A f (iter_nat (nat_of_P m) A f x)).
-rewrite (iter_nat_of_P (n + m) A f x).
-rewrite (nat_of_P_plus_morphism n m).
-apply iter_nat_plus.
+  intros n m; intros.
+  rewrite (iter_nat_of_P m A f x).
+  rewrite (iter_nat_of_P n A f (iter_nat (nat_of_P m) A f x)).
+  rewrite (iter_nat_of_P (n + m) A f x).
+  rewrite (nat_of_P_plus_morphism n m).
+  apply iter_nat_plus.
 Qed.
 
 (** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], 
     then the iterates of [f] also preserve it. *)
 
 Theorem iter_nat_invariant :
- forall (n:nat) (A:Set) (f:A -> A) (Inv:A -> Prop),
-   (forall x:A, Inv x -> Inv (f x)) ->
-   forall x:A, Inv x -> Inv (iter_nat n A f x).
+  forall (n:nat) (A:Set) (f:A -> A) (Inv:A -> Prop),
+    (forall x:A, Inv x -> Inv (f x)) ->
+    forall x:A, Inv x -> Inv (iter_nat n A f x).
 Proof.    
-simple induction n; intros;
- [ trivial with arith
- | simpl in |- *; apply H0 with (x := iter_nat n0 A f x); apply H;
-    trivial with arith ].
+  simple induction n; intros;
+    [ trivial with arith
+      | simpl in |- *; apply H0 with (x := iter_nat n0 A f x); apply H;
+	trivial with arith ].
 Qed.
 
 Theorem iter_pos_invariant :
- forall (p:positive) (A:Set) (f:A -> A) (Inv:A -> Prop),
-   (forall x:A, Inv x -> Inv (f x)) ->
-   forall x:A, Inv x -> Inv (iter_pos p A f x).
+  forall (p:positive) (A:Set) (f:A -> A) (Inv:A -> Prop),
+    (forall x:A, Inv x -> Inv (f x)) ->
+    forall x:A, Inv x -> Inv (iter_pos p A f x).
 Proof.    
-intros; rewrite iter_nat_of_P; apply iter_nat_invariant; trivial with arith.
+  intros; rewrite iter_nat_of_P; apply iter_nat_invariant; trivial with arith.
 Qed.
diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v
index d051ed74..f0a3d47b 100644
--- a/theories/ZArith/Znat.v
+++ b/theories/ZArith/Znat.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Znat.v,v 1.3.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+(*i $Id: Znat.v 9302 2006-10-27 21:21:17Z barras $ i*)
 
 (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
 
-Require Export Arith.
+Require Export Arith_base.
 Require Import BinPos.
 Require Import BinInt.
 Require Import Zcompare.
@@ -23,116 +23,116 @@ Open Local Scope Z_scope.
 
 Definition neq (x y:nat) := x <> y.
 
-(**********************************************************************)
+(************************************************)
 (** Properties of the injection from nat into Z *)
 
 Theorem inj_S : forall n:nat, Z_of_nat (S n) = Zsucc (Z_of_nat n).
 Proof.
-intro y; induction y as [| n H];
- [ unfold Zsucc in |- *; simpl in |- *; trivial with arith
- | change (Zpos (Psucc (P_of_succ_nat n)) = Zsucc (Z_of_nat (S n))) in |- *;
-    rewrite Zpos_succ_morphism; trivial with arith ].
+  intro y; induction y as [| n H];
+    [ unfold Zsucc in |- *; simpl in |- *; trivial with arith
+      | change (Zpos (Psucc (P_of_succ_nat n)) = Zsucc (Z_of_nat (S n))) in |- *;
+	rewrite Zpos_succ_morphism; trivial with arith ].
 Qed.
  
 Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m.
 Proof.
-intro x; induction x as [| n H]; intro y; destruct y as [| m];
- [ simpl in |- *; trivial with arith
- | simpl in |- *; trivial with arith
- | simpl in |- *; rewrite <- plus_n_O; trivial with arith
- | change (Z_of_nat (S (n + S m)) = Z_of_nat (S n) + Z_of_nat (S m)) in |- *;
-    rewrite inj_S; rewrite H; do 2 rewrite inj_S; rewrite Zplus_succ_l;
-    trivial with arith ].
+  intro x; induction x as [| n H]; intro y; destruct y as [| m];
+    [ simpl in |- *; trivial with arith
+      | simpl in |- *; trivial with arith
+      | simpl in |- *; rewrite <- plus_n_O; trivial with arith
+      | change (Z_of_nat (S (n + S m)) = Z_of_nat (S n) + Z_of_nat (S m)) in |- *;
+	rewrite inj_S; rewrite H; do 2 rewrite inj_S; rewrite Zplus_succ_l;
+	  trivial with arith ].
 Qed.
- 
+
 Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat m.
 Proof.
-intro x; induction x as [| n H];
- [ simpl in |- *; trivial with arith
- | intro y; rewrite inj_S; rewrite <- Zmult_succ_l_reverse; rewrite <- H;
-    rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; 
-    trivial with arith ].
+  intro x; induction x as [| n H];
+    [ simpl in |- *; trivial with arith
+      | intro y; rewrite inj_S; rewrite <- Zmult_succ_l_reverse; rewrite <- H;
+	rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; 
+	  trivial with arith ].
 Qed.
 
 Theorem inj_neq : forall n m:nat, neq n m -> Zne (Z_of_nat n) (Z_of_nat m).
 Proof.
-unfold neq, Zne, not in |- *; intros x y H1 H2; apply H1; generalize H2;
- case x; case y; intros;
- [ auto with arith
- | discriminate H0
- | discriminate H0
- | simpl in H0; injection H0;
-    do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ; 
-    intros E; rewrite E; auto with arith ].
+  unfold neq, Zne, not in |- *; intros x y H1 H2; apply H1; generalize H2;
+    case x; case y; intros;
+      [ auto with arith
+	| discriminate H0
+	| discriminate H0
+	| simpl in H0; injection H0;
+	  do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ; 
+	    intros E; rewrite E; auto with arith ].
 Qed. 
 
 Theorem inj_le : forall n m:nat, (n <= m)%nat -> Z_of_nat n <= Z_of_nat m.
 Proof.
-intros x y; intros H; elim H;
- [ unfold Zle in |- *; elim (Zcompare_Eq_iff_eq (Z_of_nat x) (Z_of_nat x));
-    intros H1 H2; rewrite H2; [ discriminate | trivial with arith ]
- | intros m H1 H2; apply Zle_trans with (Z_of_nat m);
-    [ assumption | rewrite inj_S; apply Zle_succ ] ].
+  intros x y; intros H; elim H;
+    [ unfold Zle in |- *; elim (Zcompare_Eq_iff_eq (Z_of_nat x) (Z_of_nat x));
+      intros H1 H2; rewrite H2; [ discriminate | trivial with arith ]
+      | intros m H1 H2; apply Zle_trans with (Z_of_nat m);
+	[ assumption | rewrite inj_S; apply Zle_succ ] ].
 Qed.
 
 Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m.
 Proof.
-intros x y H; apply Zgt_lt; apply Zlt_succ_gt; rewrite <- inj_S; apply inj_le;
- exact H.
+  intros x y H; apply Zgt_lt; apply Zlt_succ_gt; rewrite <- inj_S; apply inj_le;
+    exact H.
 Qed.
 
 Theorem inj_gt : forall n m:nat, (n > m)%nat -> Z_of_nat n > Z_of_nat m.
 Proof.
-intros x y H; apply Zlt_gt; apply inj_lt; exact H.
+  intros x y H; apply Zlt_gt; apply inj_lt; exact H.
 Qed.
 
 Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m.
 Proof.
-intros x y H; apply Zle_ge; apply inj_le; apply H.
+  intros x y H; apply Zle_ge; apply inj_le; apply H.
 Qed.
 
 Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat m.
 Proof.
-intros x y H; rewrite H; trivial with arith.
+  intros x y H; rewrite H; trivial with arith.
 Qed.
 
 Theorem intro_Z :
- forall n:nat,  exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
+  forall n:nat,  exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
 Proof.
-intros x; exists (Z_of_nat x); split;
- [ trivial with arith
- | rewrite Zmult_comm; rewrite Zmult_1_l; rewrite Zplus_0_r;
-    unfold Zle in |- *; elim x; intros; simpl in |- *; 
-    discriminate ].
+  intros x; exists (Z_of_nat x); split;
+    [ trivial with arith
+      | rewrite Zmult_comm; rewrite Zmult_1_l; rewrite Zplus_0_r;
+	unfold Zle in |- *; elim x; intros; simpl in |- *; 
+          discriminate ].
 Qed.
 
 Theorem inj_minus1 :
- forall n m:nat, (m <= n)%nat -> Z_of_nat (n - m) = Z_of_nat n - Z_of_nat m.
+  forall n m:nat, (m <= n)%nat -> Z_of_nat (n - m) = Z_of_nat n - Z_of_nat m.
 Proof.
-intros x y H; apply (Zplus_reg_l (Z_of_nat y)); unfold Zminus in |- *;
- rewrite Zplus_permute; rewrite Zplus_opp_r; rewrite <- inj_plus;
- rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; 
- trivial with arith.
+  intros x y H; apply (Zplus_reg_l (Z_of_nat y)); unfold Zminus in |- *;
+    rewrite Zplus_permute; rewrite Zplus_opp_r; rewrite <- inj_plus;
+      rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; 
+        trivial with arith.
 Qed.
  
 Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0.
 Proof.
-intros x y H; rewrite not_le_minus_0;
- [ trivial with arith | apply gt_not_le; assumption ].
+  intros x y H; rewrite not_le_minus_0;
+    [ trivial with arith | apply gt_not_le; assumption ].
 Qed.
 
 Theorem Zpos_eq_Z_of_nat_o_nat_of_P :
- forall p:positive, Zpos p = Z_of_nat (nat_of_P p).
+  forall p:positive, Zpos p = Z_of_nat (nat_of_P p).
 Proof.
-intros x; elim x; simpl in |- *; auto.
-intros p H; rewrite ZL6.
-apply f_equal with (f := Zpos).
-apply nat_of_P_inj.
-rewrite nat_of_P_o_P_of_succ_nat_eq_succ; unfold nat_of_P in |- *;
- simpl in |- *.
-rewrite ZL6; auto.
-intros p H; unfold nat_of_P in |- *; simpl in |- *.
-rewrite ZL6; simpl in |- *.
-rewrite inj_plus; repeat rewrite <- H.
-rewrite Zpos_xO; simpl in |- *; rewrite Pplus_diag; reflexivity.
+  intros x; elim x; simpl in |- *; auto.
+  intros p H; rewrite ZL6.
+  apply f_equal with (f := Zpos).
+  apply nat_of_P_inj.
+  rewrite nat_of_P_o_P_of_succ_nat_eq_succ; unfold nat_of_P in |- *;
+    simpl in |- *.
+  rewrite ZL6; auto.
+  intros p H; unfold nat_of_P in |- *; simpl in |- *.
+  rewrite ZL6; simpl in |- *.
+  rewrite inj_plus; repeat rewrite <- H.
+  rewrite Zpos_xO; simpl in |- *; rewrite Pplus_diag; reflexivity.
 Qed.
diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v
index 715cdc7d..d89ec052 100644
--- a/theories/ZArith/Znumtheory.v
+++ b/theories/ZArith/Znumtheory.v
@@ -6,21 +6,23 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Znumtheory.v,v 1.5.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+(*i $Id: Znumtheory.v 9245 2006-10-17 12:53:34Z notin $ i*)
 
 Require Import ZArith_base.
 Require Import ZArithRing.
 Require Import Zcomplements.
 Require Import Zdiv.
+Require Import Ndigits.
+Require Import Wf_nat.
 Open Local Scope Z_scope.
 
 (** This file contains some notions of number theory upon Z numbers: 
      - a divisibility predicate [Zdivide]
      - a gcd predicate [gcd]
      - Euclid algorithm [euclid]
-     - an efficient [Zgcd] function 
      - a relatively prime predicate [rel_prime]
      - a prime predicate [prime]
+     - an efficient [Zgcd] function 
 *)
 
 (** * Divisibility *)
@@ -36,91 +38,91 @@ Notation "( a | b )" := (Zdivide a b) (at level 0) : Z_scope.
 
 Lemma Zdivide_refl : forall a:Z, (a | a).
 Proof.
-intros; apply Zdivide_intro with 1; ring.
+  intros; apply Zdivide_intro with 1; ring.
 Qed.
 
 Lemma Zone_divide : forall a:Z, (1 | a).
 Proof.
-intros; apply Zdivide_intro with a; ring.
+  intros; apply Zdivide_intro with a; ring.
 Qed.
 
 Lemma Zdivide_0 : forall a:Z, (a | 0).
 Proof.
-intros; apply Zdivide_intro with 0; ring.
+  intros; apply Zdivide_intro with 0; ring.
 Qed.
 
 Hint Resolve Zdivide_refl Zone_divide Zdivide_0: zarith.
 
 Lemma Zmult_divide_compat_l : forall a b c:Z, (a | b) -> (c * a | c * b).
 Proof.
-simple induction 1; intros; apply Zdivide_intro with q.
-rewrite H0; ring.
+  simple induction 1; intros; apply Zdivide_intro with q.
+  rewrite H0; ring.
 Qed.
 
 Lemma Zmult_divide_compat_r : forall a b c:Z, (a | b) -> (a * c | b * c).
 Proof.
-intros a b c; rewrite (Zmult_comm a c); rewrite (Zmult_comm b c).
-apply Zmult_divide_compat_l; trivial.
+  intros a b c; rewrite (Zmult_comm a c); rewrite (Zmult_comm b c).
+  apply Zmult_divide_compat_l; trivial.
 Qed.
 
 Hint Resolve Zmult_divide_compat_l Zmult_divide_compat_r: zarith.
 
 Lemma Zdivide_plus_r : forall a b c:Z, (a | b) -> (a | c) -> (a | b + c).
 Proof.
-simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
-apply Zdivide_intro with (q + q').
-rewrite Hq; rewrite Hq'; ring.
+  simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
+  apply Zdivide_intro with (q + q').
+  rewrite Hq; rewrite Hq'; ring.
 Qed.
 
 Lemma Zdivide_opp_r : forall a b:Z, (a | b) -> (a | - b).
 Proof.
-simple induction 1; intros; apply Zdivide_intro with (- q).
-rewrite H0; ring.
+  simple induction 1; intros; apply Zdivide_intro with (- q).
+  rewrite H0; ring.
 Qed.
 
 Lemma Zdivide_opp_r_rev : forall a b:Z, (a | - b) -> (a | b).
 Proof.
-intros; replace b with (- - b). apply Zdivide_opp_r; trivial. ring.
+  intros; replace b with (- - b). apply Zdivide_opp_r; trivial. ring.
 Qed.
 
 Lemma Zdivide_opp_l : forall a b:Z, (a | b) -> (- a | b).
 Proof.
-simple induction 1; intros; apply Zdivide_intro with (- q).
-rewrite H0; ring.
+  simple induction 1; intros; apply Zdivide_intro with (- q).
+  rewrite H0; ring.
 Qed.
 
 Lemma Zdivide_opp_l_rev : forall a b:Z, (- a | b) -> (a | b).
 Proof.
-intros; replace a with (- - a). apply Zdivide_opp_l; trivial. ring.
+  intros; replace a with (- - a). apply Zdivide_opp_l; trivial. ring.
 Qed.
 
 Lemma Zdivide_minus_l : forall a b c:Z, (a | b) -> (a | c) -> (a | b - c).
 Proof.
-simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
-apply Zdivide_intro with (q - q').
-rewrite Hq; rewrite Hq'; ring.
+  simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
+  apply Zdivide_intro with (q - q').
+  rewrite Hq; rewrite Hq'; ring.
 Qed.
 
 Lemma Zdivide_mult_l : forall a b c:Z, (a | b) -> (a | b * c).
 Proof.
-simple induction 1; intros q Hq; apply Zdivide_intro with (q * c).
-rewrite Hq; ring.
+  simple induction 1; intros q Hq; apply Zdivide_intro with (q * c).
+  rewrite Hq; ring.
 Qed.
 
 Lemma Zdivide_mult_r : forall a b c:Z, (a | c) -> (a | b * c).
 Proof.
-simple induction 1; intros q Hq; apply Zdivide_intro with (q * b).
-rewrite Hq; ring.
+  simple induction 1; intros q Hq; apply Zdivide_intro with (q * b).
+  rewrite Hq; ring.
 Qed.
 
 Lemma Zdivide_factor_r : forall a b:Z, (a | a * b).
 Proof.
-intros; apply Zdivide_intro with b; ring.
+  intros; apply Zdivide_intro with b; ring.
 Qed.
 
 Lemma Zdivide_factor_l : forall a b:Z, (a | b * a).
 Proof.
-intros; apply Zdivide_intro with b; ring.
+  intros; apply Zdivide_intro with b; ring.
 Qed.
 
 Hint Resolve Zdivide_plus_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
@@ -131,7 +133,7 @@ Hint Resolve Zdivide_plus_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
 
 Lemma Zmult_one : forall x y:Z, x >= 0 -> x * y = 1 -> x = 1.
 Proof.
-intros x y H H0; destruct (Zmult_1_inversion_l _ _ H0) as [Hpos| Hneg].
+  intros x y H H0; destruct (Zmult_1_inversion_l _ _ H0) as [Hpos| Hneg].
   assumption.
   rewrite Hneg in H; simpl in H.
   contradiction (Zle_not_lt 0 (-1)).
@@ -143,11 +145,11 @@ Qed.
 
 Lemma Zdivide_1 : forall x:Z, (x | 1) -> x = 1 \/ x = -1.
 Proof.
-simple induction 1; intros.
-elim (Z_lt_ge_dec 0 x); [ left | right ].
-apply Zmult_one with q; auto with zarith; rewrite H0; ring.
-assert (- x = 1); auto with zarith.
-apply Zmult_one with (- q); auto with zarith; rewrite H0; ring.
+  simple induction 1; intros.
+  elim (Z_lt_ge_dec 0 x); [ left | right ].
+  apply Zmult_one with q; auto with zarith; rewrite H0; ring.
+  assert (- x = 1); auto with zarith.
+  apply Zmult_one with (- q); auto with zarith; rewrite H0; ring.
 Qed.
 
 (** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *)
@@ -162,7 +164,7 @@ left; rewrite H0; rewrite e; ring.
 assert (Hqq0 : q0 * q = 1).
 apply Zmult_reg_l with a.
 assumption.
-ring.
+ring_simplify.
 pattern a at 2 in |- *; rewrite H2; ring.
 assert (q | 1).
 rewrite <- Hqq0; auto with zarith.
@@ -175,21 +177,21 @@ Qed.
 
 Lemma Zdivide_bounds : forall a b:Z, (a | b) -> b <> 0 -> Zabs a <= Zabs b.
 Proof.
-simple induction 1; intros.
-assert (Zabs b = Zabs q * Zabs a).
- subst; apply Zabs_Zmult.
-rewrite H2.
-assert (H3 := Zabs_pos q).
-assert (H4 := Zabs_pos a).
-assert (Zabs q * Zabs a >= 1 * Zabs a); auto with zarith.
-apply Zmult_ge_compat; auto with zarith.
-elim (Z_lt_ge_dec (Zabs q) 1); [ intros | auto with zarith ].
-assert (Zabs q = 0).
- omega.
-assert (q = 0).
- rewrite <- (Zabs_Zsgn q).
-rewrite H5; auto with zarith.
-subst q; omega.
+  simple induction 1; intros.
+  assert (Zabs b = Zabs q * Zabs a).
+  subst; apply Zabs_Zmult.
+  rewrite H2.
+  assert (H3 := Zabs_pos q).
+  assert (H4 := Zabs_pos a).
+  assert (Zabs q * Zabs a >= 1 * Zabs a); auto with zarith.
+  apply Zmult_ge_compat; auto with zarith.
+  elim (Z_lt_ge_dec (Zabs q) 1); [ intros | auto with zarith ].
+  assert (Zabs q = 0).
+  omega.
+  assert (q = 0).
+  rewrite <- (Zabs_Zsgn q).
+  rewrite H5; auto with zarith.
+  subst q; omega.
 Qed.
 
 (** * Greatest common divisor (gcd). *)
@@ -199,30 +201,48 @@ Qed.
      (We show later that the [gcd] is actually unique if we discard its sign.) *)
 
 Inductive Zis_gcd (a b d:Z) : Prop :=
-    Zis_gcd_intro :
-      (d | a) ->
-      (d | b) -> (forall x:Z, (x | a) -> (x | b) -> (x | d)) -> Zis_gcd a b d.
+  Zis_gcd_intro :
+  (d | a) ->
+  (d | b) -> (forall x:Z, (x | a) -> (x | b) -> (x | d)) -> Zis_gcd a b d.
 
 (** Trivial properties of [gcd] *)
 
 Lemma Zis_gcd_sym : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a d.
 Proof.
-simple induction 1; constructor; intuition.
+  simple induction 1; constructor; intuition.
 Qed.
 
 Lemma Zis_gcd_0 : forall a:Z, Zis_gcd a 0 a.
 Proof.
-constructor; auto with zarith.
+  constructor; auto with zarith.
+Qed.
+
+Lemma Zis_gcd_1 : forall a, Zis_gcd a 1 1.
+Proof.
+  constructor; auto with zarith.
+Qed.
+
+Lemma Zis_gcd_refl : forall a, Zis_gcd a a a.
+Proof.
+  constructor; auto with zarith.
 Qed.
 
 Lemma Zis_gcd_minus : forall a b d:Z, Zis_gcd a (- b) d -> Zis_gcd b a d.
 Proof.
-simple induction 1; constructor; intuition.
+  simple induction 1; constructor; intuition.
 Qed.
 
 Lemma Zis_gcd_opp : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a (- d).
 Proof.
-simple induction 1; constructor; intuition.
+  simple induction 1; constructor; intuition.
+Qed.
+
+Lemma Zis_gcd_0_abs : forall a:Z, Zis_gcd 0 a (Zabs a).
+Proof.
+  intros a.
+  apply Zabs_ind.
+  intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
+  intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
 Qed.
 
 Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.
@@ -233,18 +253,18 @@ Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.
     the following property. *)
 
 Lemma Zis_gcd_for_euclid :
- forall a b d q:Z, Zis_gcd b (a - q * b) d -> Zis_gcd a b d.
+  forall a b d q:Z, Zis_gcd b (a - q * b) d -> Zis_gcd a b d.
 Proof.
-simple induction 1; constructor; intuition.
-replace a with (a - q * b + q * b). auto with zarith. ring.
+  simple induction 1; constructor; intuition.
+  replace a with (a - q * b + q * b). auto with zarith. ring.
 Qed.
 
 Lemma Zis_gcd_for_euclid2 :
- forall b d q r:Z, Zis_gcd r b d -> Zis_gcd b (b * q + r) d.
+  forall b d q r:Z, Zis_gcd r b d -> Zis_gcd b (b * q + r) d.
 Proof.
-simple induction 1; constructor; intuition.
-apply H2; auto.
-replace r with (b * q + r - b * q). auto with zarith. ring.
+  simple induction 1; constructor; intuition.
+  apply H2; auto.
+  replace r with (b * q + r - b * q). auto with zarith. ring.
 Qed.
 
 (** We implement the extended version of Euclid's algorithm,
@@ -254,182 +274,119 @@ Qed.
 
 Section extended_euclid_algorithm.
 
-Variables a b : Z.
+  Variables a b : Z.
 
-(** The specification of Euclid's algorithm is the existence of
-    [u], [v] and [d] such that [ua+vb=d] and [(gcd a b d)]. *)
+  (** The specification of Euclid's algorithm is the existence of
+      [u], [v] and [d] such that [ua+vb=d] and [(gcd a b d)]. *)
 
-Inductive Euclid : Set :=
+  Inductive Euclid : Set :=
     Euclid_intro :
-      forall u v d:Z, u * a + v * b = d -> Zis_gcd a b d -> Euclid.
-
-(** The recursive part of Euclid's algorithm uses well-founded
-    recursion of non-negative integers. It maintains 6 integers
-    [u1,u2,u3,v1,v2,v3] such that the following invariant holds:
-    [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. 
-    *)
-
-Lemma euclid_rec :
- forall v3:Z,
-   0 <= v3 ->
-   forall u1 u2 u3 v1 v2:Z,
-     u1 * a + u2 * b = u3 ->
-     v1 * a + v2 * b = v3 ->
-     (forall d:Z, Zis_gcd u3 v3 d -> Zis_gcd a b d) -> Euclid.
-Proof.
-intros v3 Hv3; generalize Hv3; pattern v3 in |- *.
-apply Z_lt_rec.
-clear v3 Hv3; intros.
-elim (Z_zerop x); intro.
-apply Euclid_intro with (u := u1) (v := u2) (d := u3).
-assumption.
-apply H2.
-rewrite a0; auto with zarith.
-set (q := u3 / x) in *.
-assert (Hq : 0 <= u3 - q * x < x).
-replace (u3 - q * x) with (u3 mod x).
-apply Z_mod_lt; omega.
-assert (xpos : x > 0). omega.
-generalize (Z_div_mod_eq u3 x xpos). 
-unfold q in |- *. 
-intro eq; pattern u3 at 2 in |- *; rewrite eq; ring.
-apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)).
-tauto.
-replace ((u1 - q * v1) * a + (u2 - q * v2) * b) with
- (u1 * a + u2 * b - q * (v1 * a + v2 * b)).
-rewrite H0; rewrite H1; trivial.
-ring.
-intros; apply H2.
-apply Zis_gcd_for_euclid with q; assumption.
-assumption.
-Qed.
-
-(** We get Euclid's algorithm by applying [euclid_rec] on
-    [1,0,a,0,1,b] when [b>=0] and [1,0,a,0,-1,-b] when [b<0]. *)
-
-Lemma euclid : Euclid.
-Proof.
-case (Z_le_gt_dec 0 b); intro.
-intros;
- apply euclid_rec with
-  (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := 1) (v3 := b);
- auto with zarith; ring.
-intros;
- apply euclid_rec with
-  (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := -1) (v3 := - b);
- auto with zarith; try ring.
-Qed.
+    forall u v d:Z, u * a + v * b = d -> Zis_gcd a b d -> Euclid.
+
+  (** The recursive part of Euclid's algorithm uses well-founded
+      recursion of non-negative integers. It maintains 6 integers
+      [u1,u2,u3,v1,v2,v3] such that the following invariant holds:
+      [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. 
+      *)
+
+  Lemma euclid_rec :
+    forall v3:Z,
+      0 <= v3 ->
+      forall u1 u2 u3 v1 v2:Z,
+	u1 * a + u2 * b = u3 ->
+	v1 * a + v2 * b = v3 ->
+	(forall d:Z, Zis_gcd u3 v3 d -> Zis_gcd a b d) -> Euclid.
+  Proof.
+    intros v3 Hv3; generalize Hv3; pattern v3 in |- *.
+    apply Zlt_0_rec.
+    clear v3 Hv3; intros.
+    elim (Z_zerop x); intro.
+    apply Euclid_intro with (u := u1) (v := u2) (d := u3).
+    assumption.
+    apply H3.
+    rewrite a0; auto with zarith.
+    set (q := u3 / x) in *.
+    assert (Hq : 0 <= u3 - q * x < x).
+    replace (u3 - q * x) with (u3 mod x).
+    apply Z_mod_lt; omega.
+    assert (xpos : x > 0). omega.
+    generalize (Z_div_mod_eq u3 x xpos). 
+    unfold q in |- *. 
+    intro eq; pattern u3 at 2 in |- *; rewrite eq; ring.
+    apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)).
+    tauto.
+    replace ((u1 - q * v1) * a + (u2 - q * v2) * b) with
+      (u1 * a + u2 * b - q * (v1 * a + v2 * b)).
+    rewrite H1; rewrite H2; trivial.
+    ring.
+    intros; apply H3.
+    apply Zis_gcd_for_euclid with q; assumption.
+    assumption.
+  Qed.
+
+  (** We get Euclid's algorithm by applying [euclid_rec] on
+      [1,0,a,0,1,b] when [b>=0] and [1,0,a,0,-1,-b] when [b<0]. *)
+
+  Lemma euclid : Euclid.
+  Proof.
+    case (Z_le_gt_dec 0 b); intro.
+    intros;
+      apply euclid_rec with
+	(u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := 1) (v3 := b);
+	auto with zarith; ring.
+    intros;
+      apply euclid_rec with
+	(u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := -1) (v3 := - b);
+	auto with zarith; try ring.
+  Qed.
 
 End extended_euclid_algorithm.
 
 Theorem Zis_gcd_uniqueness_apart_sign :
- forall a b d d':Z, Zis_gcd a b d -> Zis_gcd a b d' -> d = d' \/ d = - d'.
+  forall a b d d':Z, Zis_gcd a b d -> Zis_gcd a b d' -> d = d' \/ d = - d'.
 Proof.
-simple induction 1.
-intros H1 H2 H3; simple induction 1; intros.
-generalize (H3 d' H4 H5); intro Hd'd.
-generalize (H6 d H1 H2); intro Hdd'.
-exact (Zdivide_antisym d d' Hdd' Hd'd).
+  simple induction 1.
+  intros H1 H2 H3; simple induction 1; intros.
+  generalize (H3 d' H4 H5); intro Hd'd.
+  generalize (H6 d H1 H2); intro Hdd'.
+  exact (Zdivide_antisym d d' Hdd' Hd'd).
 Qed.
 
 (** * Bezout's coefficients *)
 
 Inductive Bezout (a b d:Z) : Prop :=
-    Bezout_intro : forall u v:Z, u * a + v * b = d -> Bezout a b d.
+  Bezout_intro : forall u v:Z, u * a + v * b = d -> Bezout a b d.
 
 (** Existence of Bezout's coefficients for the [gcd] of [a] and [b] *)
 
 Lemma Zis_gcd_bezout : forall a b d:Z, Zis_gcd a b d -> Bezout a b d.
 Proof.
-intros a b d Hgcd.
-elim (euclid a b); intros u v d0 e g.
-generalize (Zis_gcd_uniqueness_apart_sign a b d d0 Hgcd g).
-intro H; elim H; clear H; intros.
-apply Bezout_intro with u v.
-rewrite H; assumption.
-apply Bezout_intro with (- u) (- v).
-rewrite H; rewrite <- e; ring.
+  intros a b d Hgcd.
+  elim (euclid a b); intros u v d0 e g.
+  generalize (Zis_gcd_uniqueness_apart_sign a b d d0 Hgcd g).
+  intro H; elim H; clear H; intros.
+  apply Bezout_intro with u v.
+  rewrite H; assumption.
+  apply Bezout_intro with (- u) (- v).
+  rewrite H; rewrite <- e; ring.
 Qed.
 
 (** gcd of [ca] and [cb] is [c gcd(a,b)]. *)
 
 Lemma Zis_gcd_mult :
- forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d).
-Proof.
-intros a b c d; simple induction 1; constructor; intuition.
-elim (Zis_gcd_bezout a b d H); intros.
-elim H3; intros.
-elim H4; intros.
-apply Zdivide_intro with (u * q + v * q0).
-rewrite <- H5.
-replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)).
-rewrite H6; rewrite H7; ring.
-ring.
-Qed.
-
-(** We could obtain a [Zgcd] function via [euclid]. But we propose 
-  here a more direct version of a [Zgcd], with better extraction 
-  (no bezout coeffs). *)
-
-Definition Zgcd_pos :
-  forall a:Z,
-    0 <= a -> forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}.
-Proof.
-intros a Ha.
-apply
- (Z_lt_rec
-    (fun a:Z => forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}));
- try assumption.
-intro x; case x.
-intros _ b; exists (Zabs b).
-  elim (Z_le_lt_eq_dec _ _ (Zabs_pos b)).
-    intros H0; split.
-    apply Zabs_ind.
-    intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
-    intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
-    auto with zarith.
-    
-    intros H0; rewrite <- H0.
-    rewrite <- (Zabs_Zsgn b); rewrite <- H0; simpl in |- *.
-    split; [ apply Zis_gcd_0 | idtac ]; auto with zarith.
-  
-intros p Hrec b.
-generalize (Z_div_mod b (Zpos p)).
-case (Zdiv_eucl b (Zpos p)); intros q r Hqr.
-elim Hqr; clear Hqr; intros; auto with zarith.
-elim (Hrec r H0 (Zpos p)); intros g Hgkl.
-inversion_clear H0.
-elim (Hgkl H1); clear Hgkl; intros H3 H4.
-exists g; intros.
-split; auto.
-rewrite H.
-apply Zis_gcd_for_euclid2; auto.
-
-intros p Hrec b.
-exists 0; intros.
-elim H; auto.
-Defined.
-
-Definition Zgcd_spec : forall a b:Z, {g : Z | Zis_gcd a b g /\ g >= 0}.
-Proof.
-intros a; case (Z_gt_le_dec 0 a).
-intros; assert (0 <= - a).
-omega.
-elim (Zgcd_pos (- a) H b); intros g Hgkl.
-exists g.
-intuition.
-intros Ha b; elim (Zgcd_pos a Ha b); intros g; exists g; intuition.
-Defined.
-
-Definition Zgcd (a b:Z) := let (g, _) := Zgcd_spec a b in g.
-
-Lemma Zgcd_is_pos : forall a b:Z, Zgcd a b >= 0.
-intros a b; unfold Zgcd in |- *; case (Zgcd_spec a b); tauto.
-Qed.
-
-Lemma Zgcd_is_gcd : forall a b:Z, Zis_gcd a b (Zgcd a b).
-intros a b; unfold Zgcd in |- *; case (Zgcd_spec a b); tauto.
+  forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d).
+Proof.
+  intros a b c d; simple induction 1; constructor; intuition.
+  elim (Zis_gcd_bezout a b d H); intros.
+  elim H3; intros.
+  elim H4; intros.
+  apply Zdivide_intro with (u * q + v * q0).
+  rewrite <- H5.
+  replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)).
+  rewrite H6; rewrite H7; ring.
+  ring.
 Qed.
+  
 
 (** * Relative primality *)
 
@@ -440,13 +397,13 @@ Definition rel_prime (a b:Z) : Prop := Zis_gcd a b 1.
 
 Lemma rel_prime_bezout : forall a b:Z, rel_prime a b -> Bezout a b 1.
 Proof.
-intros a b; exact (Zis_gcd_bezout a b 1).
+  intros a b; exact (Zis_gcd_bezout a b 1).
 Qed.
 
 Lemma bezout_rel_prime : forall a b:Z, Bezout a b 1 -> rel_prime a b.
 Proof.
-simple induction 1; constructor; auto with zarith.
-intros. rewrite <- H0; auto with zarith.
+  simple induction 1; constructor; auto with zarith.
+  intros. rewrite <- H0; auto with zarith.
 Qed.
 
 (** Gauss's theorem: if [a] divides [bc] and if [a] and [b] are
@@ -454,141 +411,134 @@ Qed.
 
 Theorem Gauss : forall a b c:Z, (a | b * c) -> rel_prime a b -> (a | c).
 Proof.
-intros. elim (rel_prime_bezout a b H0); intros.
-replace c with (c * 1); [ idtac | ring ].
-rewrite <- H1.
-replace (c * (u * a + v * b)) with (c * u * a + v * (b * c));
- [ eauto with zarith | ring ].
+  intros. elim (rel_prime_bezout a b H0); intros.
+  replace c with (c * 1); [ idtac | ring ].
+  rewrite <- H1.
+  replace (c * (u * a + v * b)) with (c * u * a + v * (b * c));
+    [ eauto with zarith | ring ].
 Qed.
 
 (** If [a] is relatively prime to [b] and [c], then it is to [bc] *)
 
 Lemma rel_prime_mult :
- forall a b c:Z, rel_prime a b -> rel_prime a c -> rel_prime a (b * c).
+  forall a b c:Z, rel_prime a b -> rel_prime a c -> rel_prime a (b * c).
 Proof.
-intros a b c Hb Hc.
-elim (rel_prime_bezout a b Hb); intros.
-elim (rel_prime_bezout a c Hc); intros.
-apply bezout_rel_prime.
-apply Bezout_intro with
- (u := u * u0 * a + v0 * c * u + u0 * v * b) (v := v * v0).
-rewrite <- H.
-replace (u * a + v * b) with ((u * a + v * b) * 1); [ idtac | ring ].
-rewrite <- H0.
-ring.
+  intros a b c Hb Hc.
+  elim (rel_prime_bezout a b Hb); intros.
+  elim (rel_prime_bezout a c Hc); intros.
+  apply bezout_rel_prime.
+  apply Bezout_intro with
+    (u := u * u0 * a + v0 * c * u + u0 * v * b) (v := v * v0).
+  rewrite <- H.
+  replace (u * a + v * b) with ((u * a + v * b) * 1); [ idtac | ring ].
+  rewrite <- H0.
+  ring.
 Qed.
 
 Lemma rel_prime_cross_prod :
- forall a b c d:Z,
-   rel_prime a b ->
-   rel_prime c d -> b > 0 -> d > 0 -> a * d = b * c -> a = c /\ b = d.
-Proof.
-intros a b c d; intros.
-elim (Zdivide_antisym b d).
-split; auto with zarith.
-rewrite H4 in H3.
-rewrite Zmult_comm in H3.
-apply Zmult_reg_l with d; auto with zarith.
-intros; omega.
-apply Gauss with a.
-rewrite H3.
-auto with zarith.
-red in |- *; auto with zarith.
-apply Gauss with c.
-rewrite Zmult_comm.
-rewrite <- H3.
-auto with zarith.
-red in |- *; auto with zarith.
+  forall a b c d:Z,
+    rel_prime a b ->
+    rel_prime c d -> b > 0 -> d > 0 -> a * d = b * c -> a = c /\ b = d.
+Proof.
+  intros a b c d; intros.
+  elim (Zdivide_antisym b d).
+  split; auto with zarith.
+  rewrite H4 in H3.
+  rewrite Zmult_comm in H3.
+  apply Zmult_reg_l with d; auto with zarith.
+  intros; omega.
+  apply Gauss with a.
+  rewrite H3.
+  auto with zarith.
+  red in |- *; auto with zarith.
+  apply Gauss with c.
+  rewrite Zmult_comm.
+  rewrite <- H3.
+  auto with zarith.
+  red in |- *; auto with zarith.
 Qed.
 
 (** After factorization by a gcd, the original numbers are relatively prime. *)
 
 Lemma Zis_gcd_rel_prime :
- forall a b g:Z,
-   b > 0 -> g >= 0 -> Zis_gcd a b g -> rel_prime (a / g) (b / g).
-intros a b g; intros.
-assert (g <> 0).
- intro.
- elim H1; intros. 
- elim H4; intros.
- rewrite H2 in H6; subst b; omega.
-unfold rel_prime in |- *.
-elim (Zgcd_spec (a / g) (b / g)); intros g' [H3 H4].
-assert (H5 := Zis_gcd_mult _ _ g _ H3).
-rewrite <- Z_div_exact_2 in H5; auto with zarith.
-rewrite <- Z_div_exact_2 in H5; auto with zarith.
-elim (Zis_gcd_uniqueness_apart_sign _ _ _ _ H1 H5).
-intros; rewrite (Zmult_reg_l 1 g' g); auto with zarith.
-intros; rewrite (Zmult_reg_l 1 (- g') g); auto with zarith.
-pattern g at 1 in |- *; rewrite H6; ring.
-
-elim H1; intros.
-elim H7; intros.
-rewrite H9.
-replace (q * g) with (0 + q * g).
-rewrite Z_mod_plus.
-compute in |- *; auto.
-omega.
-ring.
-
-elim H1; intros.
-elim H6; intros.
-rewrite H9.
-replace (q * g) with (0 + q * g).
-rewrite Z_mod_plus.
-compute in |- *; auto.
-omega.
-ring.
+  forall a b g:Z,
+    b > 0 -> g >= 0 -> Zis_gcd a b g -> rel_prime (a / g) (b / g).
+  intros a b g; intros.
+  assert (g <> 0).
+  intro.
+  elim H1; intros. 
+  elim H4; intros.
+  rewrite H2 in H6; subst b; omega.
+  unfold rel_prime in |- *.
+  destruct H1.
+  destruct H1 as (a',H1).
+  destruct H3 as (b',H3).
+  replace (a/g) with a'; 
+    [|rewrite H1; rewrite Z_div_mult; auto with zarith].
+  replace (b/g) with b'; 
+    [|rewrite H3; rewrite Z_div_mult; auto with zarith].
+  constructor.
+  exists a'; auto with zarith.
+  exists b'; auto with zarith.
+  intros x (xa,H5) (xb,H6).
+  destruct (H4 (x*g)).
+  exists xa; rewrite Zmult_assoc; rewrite <- H5; auto.
+  exists xb; rewrite Zmult_assoc; rewrite <- H6; auto.
+  replace g with (1*g) in H7; auto with zarith.
+  do 2 rewrite Zmult_assoc in H7.
+  generalize (Zmult_reg_r _ _ _ H2 H7); clear H7; intros.
+  rewrite Zmult_1_r in H7.
+  exists q; auto with zarith.
 Qed.
 
 (** * Primality *)
 
 Inductive prime (p:Z) : Prop :=
-    prime_intro :
-      1 < p -> (forall n:Z, 1 <= n < p -> rel_prime n p) -> prime p.
+  prime_intro :
+    1 < p -> (forall n:Z, 1 <= n < p -> rel_prime n p) -> prime p.
 
 (** The sole divisors of a prime number [p] are [-1], [1], [p] and [-p]. *)
 
 Lemma prime_divisors :
- forall p:Z,
-   prime p -> forall a:Z, (a | p) -> a = -1 \/ a = 1 \/ a = p \/ a = - p.
-Proof.
-simple induction 1; intros.
-assert
- (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p).
-assert (Zabs a <= Zabs p). apply Zdivide_bounds; [ assumption | omega ].
-generalize H3. 
-pattern (Zabs a) in |- *; apply Zabs_ind; pattern (Zabs p) in |- *;
- apply Zabs_ind; intros; omega.
-intuition idtac.
-(* -p < a < -1 *)
-absurd (rel_prime (- a) p); intuition.
-inversion H3.
-assert (- a | - a); auto with zarith.
-assert (- a | p); auto with zarith.
-generalize (H8 (- a) H9 H10); intuition idtac.
-generalize (Zdivide_1 (- a) H11); intuition.
-(* a = 0 *)
-inversion H2. subst a; omega.
-(* 1 < a < p *)
-absurd (rel_prime a p); intuition.
-inversion H3.
-assert (a | a); auto with zarith.
-assert (a | p); auto with zarith.
-generalize (H8 a H9 H10); intuition idtac.
-generalize (Zdivide_1 a H11); intuition.
+  forall p:Z,
+    prime p -> forall a:Z, (a | p) -> a = -1 \/ a = 1 \/ a = p \/ a = - p.
+Proof.
+  simple induction 1; intros.
+  assert
+    (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p).
+  assert (Zabs a <= Zabs p). apply Zdivide_bounds; [ assumption | omega ].
+  generalize H3. 
+  pattern (Zabs a) in |- *; apply Zabs_ind; pattern (Zabs p) in |- *;
+    apply Zabs_ind; intros; omega.
+  intuition idtac.
+  (* -p < a < -1 *)
+  absurd (rel_prime (- a) p); intuition.
+  inversion H3.
+  assert (- a | - a); auto with zarith.
+  assert (- a | p); auto with zarith.
+  generalize (H8 (- a) H9 H10); intuition idtac.
+  generalize (Zdivide_1 (- a) H11); intuition.
+  (* a = 0 *)
+  inversion H2. subst a; omega.
+  (* 1 < a < p *)
+  absurd (rel_prime a p); intuition.
+  inversion H3.
+  assert (a | a); auto with zarith.
+  assert (a | p); auto with zarith.
+  generalize (H8 a H9 H10); intuition idtac.
+  generalize (Zdivide_1 a H11); intuition.
 Qed.
 
 (** A prime number is relatively prime with any number it does not divide *)
 
 Lemma prime_rel_prime :
- forall p:Z, prime p -> forall a:Z, ~ (p | a) -> rel_prime p a.
+  forall p:Z, prime p -> forall a:Z, ~ (p | a) -> rel_prime p a.
 Proof.
-simple induction 1; intros.
-constructor; intuition.
-elim (prime_divisors p H x H3); intuition; subst; auto with zarith.
-absurd (p | a); auto with zarith.
-absurd (p | a); intuition.
+  simple induction 1; intros.
+  constructor; intuition.
+  elim (prime_divisors p H x H3); intuition; subst; auto with zarith.
+  absurd (p | a); auto with zarith.
+  absurd (p | a); intuition.
 Qed.
 
 Hint Resolve prime_rel_prime: zarith.
@@ -596,45 +546,394 @@ Hint Resolve prime_rel_prime: zarith.
 (** [Zdivide] can be expressed using [Zmod]. *)
 
 Lemma Zmod_divide : forall a b:Z, b > 0 -> a mod b = 0 -> (b | a).
-intros a b H H0.
-apply Zdivide_intro with (a / b).
-pattern a at 1 in |- *; rewrite (Z_div_mod_eq a b H).
-rewrite H0; ring.
+Proof.
+  intros a b H H0.
+  apply Zdivide_intro with (a / b).
+  pattern a at 1 in |- *; rewrite (Z_div_mod_eq a b H).
+  rewrite H0; ring.
 Qed.
 
 Lemma Zdivide_mod : forall a b:Z, b > 0 -> (b | a) -> a mod b = 0.
-intros a b; simple destruct 2; intros; subst.
-change (q * b) with (0 + q * b) in |- *.
-rewrite Z_mod_plus; auto.
+Proof.
+  intros a b; simple destruct 2; intros; subst.
+  change (q * b) with (0 + q * b) in |- *.
+  rewrite Z_mod_plus; auto.
 Qed.
 
 (** [Zdivide] is hence decidable *)
 
 Lemma Zdivide_dec : forall a b:Z, {(a | b)} + {~ (a | b)}.
 Proof.
-intros a b; elim (Ztrichotomy_inf a 0).
-(* a<0 *)
-intros H; elim H; intros. 
-case (Z_eq_dec (b mod - a) 0).
-left; apply Zdivide_opp_l_rev; apply Zmod_divide; auto with zarith.
-intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
-(* a=0 *)
-case (Z_eq_dec b 0); intro.
-left; subst; auto with zarith.
-right; subst; intro H0; inversion H0; omega.
-(* a>0 *)
-intro H; case (Z_eq_dec (b mod a) 0).
-left; apply Zmod_divide; auto with zarith.
-intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
+  intros a b; elim (Ztrichotomy_inf a 0).
+  (* a<0 *)
+  intros H; elim H; intros. 
+  case (Z_eq_dec (b mod - a) 0).
+  left; apply Zdivide_opp_l_rev; apply Zmod_divide; auto with zarith.
+  intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
+  (* a=0 *)
+  case (Z_eq_dec b 0); intro.
+  left; subst; auto with zarith.
+  right; subst; intro H0; inversion H0; omega.
+  (* a>0 *)
+  intro H; case (Z_eq_dec (b mod a) 0).
+  left; apply Zmod_divide; auto with zarith.
+  intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
 Qed.
 
 (** If a prime [p] divides [ab] then it divides either [a] or [b] *)
 
 Lemma prime_mult :
- forall p:Z, prime p -> forall a b:Z, (p | a * b) -> (p | a) \/ (p | b).
+  forall p:Z, prime p -> forall a b:Z, (p | a * b) -> (p | a) \/ (p | b).
+Proof.
+  intro p; simple induction 1; intros.
+  case (Zdivide_dec p a); intuition.
+  right; apply Gauss with a; auto with zarith.
+Qed.
+
+
+(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose 
+  here a binary version of [Zgcd], faster and executable within Coq.
+
+   Algorithm: 
+
+   gcd 0 b = b
+   gcd a 0 = a
+   gcd (2a) (2b) = 2(gcd a b)
+   gcd (2a+1) (2b) = gcd (2a+1) b
+   gcd (2a) (2b+1) = gcd a (2b+1)
+   gcd (2a+1) (2b+1) = gcd (b-a) (2*a+1)
+                    or gcd (a-b) (2*b+1), depending on whether a<b 
+*)   
+
+Open Scope positive_scope.
+
+Fixpoint Pgcdn (n: nat) (a b : positive) { struct n } : positive := 
+  match n with 
+    | O => 1
+    | S n => 
+      match a,b with 
+	| xH, _ => 1 
+	| _, xH => 1
+	| xO a, xO b => xO (Pgcdn n a b)
+	| a, xO b => Pgcdn n a b
+	| xO a, b => Pgcdn n a b
+	| xI a', xI b' => match Pcompare a' b' Eq with 
+			    | Eq => a
+			    | Lt => Pgcdn  n (b'-a') a
+			    | Gt => Pgcdn n (a'-b') b
+			  end
+      end
+  end.
+
+Fixpoint Pggcdn (n: nat) (a b : positive) { struct n } : (positive*(positive*positive)) := 
+  match n with 
+    | O => (1,(a,b))
+    | S n => 
+      match a,b with 
+	| xH, b => (1,(1,b)) 
+	| a, xH => (1,(a,1))
+	| xO a, xO b => 
+          let (g,p) := Pggcdn n a b in 
+            (xO g,p)
+	| a, xO b => 
+          let (g,p) := Pggcdn n a b in 
+            let (aa,bb) := p in 
+              (g,(aa, xO bb))
+	| xO a, b => 
+          let (g,p) := Pggcdn n a b in 
+            let (aa,bb) := p in 
+              (g,(xO aa, bb))
+	| xI a', xI b' => match Pcompare a' b' Eq with 
+			    | Eq => (a,(1,1))
+			    | Lt => 
+			      let (g,p) := Pggcdn n (b'-a') a in 
+				let (ba,aa) := p in 
+				  (g,(aa, aa + xO ba))
+			    | Gt => 
+			      let (g,p) := Pggcdn n (a'-b') b in 
+				let (ab,bb) := p in 
+				  (g,(bb+xO ab, bb))
+			  end
+      end
+  end.
+
+Definition Pgcd (a b: positive) := Pgcdn (Psize a + Psize b)%nat a b.
+Definition Pggcd (a b: positive) := Pggcdn (Psize a + Psize b)%nat a b.
+
+Open Scope Z_scope.
+
+Definition Zgcd (a b : Z) : Z := match a,b with 
+				   | Z0, _ => Zabs b 
+				   | _, Z0 => Zabs a
+				   | Zpos a, Zpos b => Zpos (Pgcd a b)
+				   | Zpos a, Zneg b => Zpos (Pgcd a b)
+				   | Zneg a, Zpos b => Zpos (Pgcd a b)
+				   | Zneg a, Zneg b => Zpos (Pgcd a b)
+				 end.
+
+Definition Zggcd (a b : Z) : Z*(Z*Z) := match a,b with 
+					  | Z0, _ => (Zabs b,(0, Zsgn b)) 
+					  | _, Z0 => (Zabs a,(Zsgn a, 0))
+					  | Zpos a, Zpos b => 
+					    let (g,p) := Pggcd a b in 
+					      let (aa,bb) := p in 
+						(Zpos g, (Zpos aa, Zpos bb))
+					  | Zpos a, Zneg b => 
+					    let (g,p) := Pggcd a b in 
+					      let (aa,bb) := p in 
+						(Zpos g, (Zpos aa, Zneg bb))
+					  | Zneg a, Zpos b => 
+					    let (g,p) := Pggcd a b in 
+					      let (aa,bb) := p in 
+						(Zpos g, (Zneg aa, Zpos bb))
+					  | Zneg a, Zneg b =>
+					    let (g,p) := Pggcd a b in 
+					      let (aa,bb) := p in 
+						(Zpos g, (Zneg aa, Zneg bb))
+					end.
+
+Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b.
+Proof.
+  unfold Zgcd; destruct a; destruct b; auto with zarith.
+Qed.
+
+Lemma Psize_monotone : forall p q, Pcompare p q Eq = Lt -> (Psize p <= Psize q)%nat.
+Proof.
+  induction p; destruct q; simpl; auto with arith; intros; try discriminate.
+  intros; generalize (Pcompare_Gt_Lt _ _ H); auto with arith.
+  intros; destruct (Pcompare_Lt_Lt _ _ H); auto with arith; subst; auto.
+Qed.
+
+Lemma Pminus_Zminus : forall a b, Pcompare a b Eq = Lt -> 
+  Zpos (b-a) = Zpos b - Zpos a.
+Proof.
+  intros.
+  repeat rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
+  rewrite nat_of_P_minus_morphism.
+  apply inj_minus1.
+  apply lt_le_weak.
+  apply nat_of_P_lt_Lt_compare_morphism; auto.
+  rewrite ZC4; rewrite H; auto.
+Qed.
+
+Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g -> 
+  Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g. 
+Proof.
+  intros.
+  destruct H.
+  constructor; auto.
+  destruct H as (e,H2); exists (2*e); auto with zarith.
+  rewrite Zpos_xO; rewrite H2; ring.
+  intros.
+  apply H1; auto.
+  rewrite Zpos_xO in H2.
+  rewrite Zpos_xI in H3.
+  apply Gauss with 2; auto.
+  apply bezout_rel_prime.
+  destruct H3 as (bb, H3).
+  apply Bezout_intro with bb (-Zpos b).
+  omega.
+Qed.
+
+Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat -> 
+  Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)).
+Proof.
+  intro n; pattern n; apply lt_wf_ind; clear n; intros.
+  destruct n.
+  simpl.
+  destruct a; simpl in *; try inversion H0.
+  destruct a.
+  destruct b; simpl.
+  case_eq (Pcompare a b Eq); intros.
+  (* a = xI, b = xI, compare = Eq *)
+  rewrite (Pcompare_Eq_eq _ _ H1); apply Zis_gcd_refl.
+  (* a = xI, b = xI, compare = Lt *)
+  apply Zis_gcd_sym.
+  apply Zis_gcd_for_euclid with 1.
+  apply Zis_gcd_sym.
+  replace (Zpos (xI b) - 1 * Zpos (xI a)) with (Zpos(xO (b - a))).
+  apply Zis_gcd_even_odd.
+  apply H; auto.
+  simpl in *.
+  assert (Psize (b-a) <= Psize b)%nat.
+  apply Psize_monotone.
+  change (Zpos (b-a) < Zpos b).
+  rewrite (Pminus_Zminus _ _ H1).
+  assert (0 < Zpos a) by (compute; auto).
+  omega.
+  omega.  
+  rewrite Zpos_xO; do 2 rewrite Zpos_xI.
+  rewrite Pminus_Zminus; auto.
+  omega.
+  (* a = xI, b = xI, compare = Gt *)
+  apply Zis_gcd_for_euclid with 1.
+  replace (Zpos (xI a) - 1 * Zpos (xI b)) with (Zpos(xO (a - b))).
+  apply Zis_gcd_sym.
+  apply Zis_gcd_even_odd.
+  apply H; auto.
+  simpl in *.
+  assert (Psize (a-b) <= Psize a)%nat.
+  apply Psize_monotone.
+  change (Zpos (a-b) < Zpos a).
+  rewrite (Pminus_Zminus b a).
+  assert (0 < Zpos b) by (compute; auto).
+  omega.
+  rewrite ZC4; rewrite H1; auto.
+  omega.  
+  rewrite Zpos_xO; do 2 rewrite Zpos_xI.
+  rewrite Pminus_Zminus; auto.
+  omega.
+  rewrite ZC4; rewrite H1; auto.
+  (* a = xI, b = xO *)
+  apply Zis_gcd_sym.
+  apply Zis_gcd_even_odd.
+  apply Zis_gcd_sym.
+  apply H; auto.
+  simpl in *; omega.
+  (* a = xI, b = xH *)
+  apply Zis_gcd_1.
+  destruct b; simpl.
+  (* a = xO, b = xI *)
+  apply Zis_gcd_even_odd.
+  apply H; auto.
+  simpl in *; omega.
+  (* a = xO, b = xO *)
+  rewrite (Zpos_xO a); rewrite (Zpos_xO b); rewrite (Zpos_xO (Pgcdn n a b)).
+  apply Zis_gcd_mult.
+  apply H; auto.
+  simpl in *; omega.
+  (* a = xO, b = xH *)
+  apply Zis_gcd_1.
+  (* a = xH *)
+  simpl; apply Zis_gcd_sym; apply Zis_gcd_1.
+Qed.
+
+Lemma Pgcd_correct : forall a b, Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcd a b)).
+Proof.
+  unfold Pgcd; intros.
+  apply Pgcdn_correct; auto.
+Qed.
+
+Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd a b).
+Proof.
+  destruct a.
+  intros.
+  simpl.
+  apply Zis_gcd_0_abs.
+  destruct b; simpl.
+  apply Zis_gcd_0.
+  apply Pgcd_correct.
+  apply Zis_gcd_sym.
+  apply Zis_gcd_minus; simpl.
+  apply Pgcd_correct.
+  destruct b; simpl.
+  apply Zis_gcd_minus; simpl.
+  apply Zis_gcd_sym.
+  apply Zis_gcd_0.
+  apply Zis_gcd_minus; simpl.
+  apply Zis_gcd_sym.
+  apply Pgcd_correct.
+  apply Zis_gcd_sym.
+  apply Zis_gcd_minus; simpl.
+  apply Zis_gcd_minus; simpl.
+  apply Zis_gcd_sym.
+  apply Pgcd_correct.
+Qed.
+
+
+Lemma Pggcdn_gcdn : forall n a b, 
+  fst (Pggcdn n a b) = Pgcdn n a b.
+Proof.
+  induction n.
+  simpl; auto.
+  destruct a; destruct b; simpl; auto.
+  destruct (Pcompare a b Eq); simpl; auto.
+  rewrite <- IHn; destruct (Pggcdn n (b-a) (xI a)) as (g,(aa,bb)); simpl; auto.
+  rewrite <- IHn; destruct (Pggcdn n (a-b) (xI b)) as (g,(aa,bb)); simpl; auto.
+  rewrite <- IHn; destruct (Pggcdn n (xI a) b) as (g,(aa,bb)); simpl; auto.
+  rewrite <- IHn; destruct (Pggcdn n a (xI b)) as (g,(aa,bb)); simpl; auto.
+  rewrite <- IHn; destruct (Pggcdn n a b) as (g,(aa,bb)); simpl; auto.
+Qed.
+
+Lemma Pggcd_gcd : forall a b, fst (Pggcd a b) = Pgcd a b.
+Proof.
+  intros; exact (Pggcdn_gcdn (Psize a+Psize b)%nat a b).
+Qed.
+
+Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b.
+Proof.
+  destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd; 
+    destruct (Pggcd p p0) as (g,(aa,bb)); simpl; auto.
+Qed.
+
+Open Scope positive_scope.
+
+Lemma Pggcdn_correct_divisors : forall n a b, 
+  let (g,p) := Pggcdn n a b in 
+    let (aa,bb):=p in 
+      (a=g*aa) /\ (b=g*bb).
+Proof.
+  induction n.
+  simpl; auto.
+  destruct a; destruct b; simpl; auto.
+  case_eq (Pcompare a b Eq); intros.
+  (* Eq *)
+  rewrite Pmult_comm; simpl; auto.
+  rewrite (Pcompare_Eq_eq _ _ H); auto.
+  (* Lt *)
+  generalize (IHn (b-a) (xI a)); destruct (Pggcdn n (b-a) (xI a)) as (g,(ba,aa)); simpl.
+  intros (H0,H1); split; auto.
+  rewrite Pmult_plus_distr_l.
+  rewrite Pmult_xO_permute_r.
+  rewrite <- H1; rewrite <- H0.
+  simpl; f_equal; symmetry.
+  apply Pplus_minus; auto.
+  rewrite ZC4; rewrite H; auto.
+  (* Gt *)
+  generalize (IHn (a-b) (xI b)); destruct (Pggcdn n (a-b) (xI b)) as (g,(ab,bb)); simpl.
+  intros (H0,H1); split; auto.
+  rewrite Pmult_plus_distr_l.
+  rewrite Pmult_xO_permute_r.
+  rewrite <- H1; rewrite <- H0.
+  simpl; f_equal; symmetry.
+  apply Pplus_minus; auto.
+  (* Then... *) 
+  generalize (IHn (xI a) b); destruct (Pggcdn n (xI a) b) as (g,(ab,bb)); simpl.
+  intros (H0,H1); split; auto.
+  rewrite Pmult_xO_permute_r; rewrite H1; auto.
+  generalize (IHn a (xI b)); destruct (Pggcdn n a (xI b)) as (g,(ab,bb)); simpl.
+  intros (H0,H1); split; auto.
+  rewrite Pmult_xO_permute_r; rewrite H0; auto.
+  generalize (IHn a b); destruct (Pggcdn n a b) as (g,(ab,bb)); simpl.
+  intros (H0,H1); split; subst; auto.
+Qed.
+
+Lemma Pggcd_correct_divisors : forall a b, 
+  let (g,p) := Pggcd a b in 
+    let (aa,bb):=p in 
+      (a=g*aa) /\ (b=g*bb).
+Proof.
+  intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b).
+Qed.
+
+Open Scope Z_scope.
+
+Lemma Zggcd_correct_divisors : forall a b, 
+  let (g,p) := Zggcd a b in 
+    let (aa,bb):=p in 
+      (a=g*aa) /\ (b=g*bb).
+Proof.
+  destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto]; 
+    generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb)); 
+      destruct 1; subst; auto.
+Qed.
+
+Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}.
 Proof.
-intro p; simple induction 1; intros.
-case (Zdivide_dec p a); intuition.
-right; apply Gauss with a; auto with zarith.
+  intros x y; exists (Zgcd x y).
+  split; [apply Zgcd_is_gcd  | apply Zgcd_is_pos].
 Qed.
 
+
+
+
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
index 27eb02cd..47490be6 100644
--- a/theories/ZArith/Zorder.v
+++ b/theories/ZArith/Zorder.v
@@ -5,13 +5,13 @@
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zorder.v,v 1.6.2.3 2005/03/29 15:35:12 herbelin Exp $ i*)
+(*i $Id: Zorder.v 9302 2006-10-27 21:21:17Z barras $ i*)
 
 (** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
 
 Require Import BinPos.
 Require Import BinInt.
-Require Import Arith.
+Require Import Arith_base.
 Require Import Decidable.
 Require Import Zcompare.
 
@@ -19,178 +19,180 @@ Open Local Scope Z_scope.
 
 Implicit Types x y z : Z.
 
-(**********************************************************************)
+(*********************************************************)
 (** Properties of the order relations on binary integers *)
 
-(** Trichotomy *)
+(** * Trichotomy *)
 
 Theorem Ztrichotomy_inf : forall n m:Z, {n < m} + {n = m} + {n > m}.
 Proof.
-unfold Zgt, Zlt in |- *; intros m n; assert (H := refl_equal (m ?= n)).
+  unfold Zgt, Zlt in |- *; intros m n; assert (H := refl_equal (m ?= n)).
   set (x := m ?= n) in H at 2 |- *.
   destruct x;
-   [ left; right; rewrite Zcompare_Eq_eq with (1 := H) | left; left | right ];
-   reflexivity.
+    [ left; right; rewrite Zcompare_Eq_eq with (1 := H) | left; left | right ];
+    reflexivity.
 Qed.
 
 Theorem Ztrichotomy : forall n m:Z, n < m \/ n = m \/ n > m.
 Proof.
   intros m n; destruct (Ztrichotomy_inf m n) as [[Hlt| Heq]| Hgt];
-   [ left | right; left | right; right ]; assumption.
+    [ left | right; left | right; right ]; assumption.
 Qed.
 
 (**********************************************************************)
-(** Decidability of equality and order on Z *)
+(** * Decidability of equality and order on Z *)
 
 Theorem dec_eq : forall n m:Z, decidable (n = m).
 Proof.
-intros x y; unfold decidable in |- *; elim (Zcompare_Eq_iff_eq x y);
- intros H1 H2; elim (Dcompare (x ?= y));
- [ tauto
- | intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4);
-    intros H5; discriminate H5 ].
+  intros x y; unfold decidable in |- *; elim (Zcompare_Eq_iff_eq x y);
+    intros H1 H2; elim (Dcompare (x ?= y));
+      [ tauto
+	| intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4);
+	  intros H5; discriminate H5 ].
 Qed. 
 
 Theorem dec_Zne : forall n m:Z, decidable (Zne n m).
 Proof.
-intros x y; unfold decidable, Zne in |- *; elim (Zcompare_Eq_iff_eq x y).
-intros H1 H2; elim (Dcompare (x ?= y));
- [ right; rewrite H1; auto
- | left; unfold not in |- *; intro; absurd ((x ?= y) = Eq);
-    [ elim H; intros HR; rewrite HR; discriminate | auto ] ].
+  intros x y; unfold decidable, Zne in |- *; elim (Zcompare_Eq_iff_eq x y).
+  intros H1 H2; elim (Dcompare (x ?= y));
+    [ right; rewrite H1; auto
+      | left; unfold not in |- *; intro; absurd ((x ?= y) = Eq);
+	[ elim H; intros HR; rewrite HR; discriminate | auto ] ].
 Qed.
 
 Theorem dec_Zle : forall n m:Z, decidable (n <= m).
 Proof.
-intros x y; unfold decidable, Zle in |- *; elim (x ?= y);
- [ left; discriminate
- | left; discriminate
- | right; unfold not in |- *; intros H; apply H; trivial with arith ].
+  intros x y; unfold decidable, Zle in |- *; elim (x ?= y);
+    [ left; discriminate
+      | left; discriminate
+      | right; unfold not in |- *; intros H; apply H; trivial with arith ].
 Qed.
 
 Theorem dec_Zgt : forall n m:Z, decidable (n > m).
 Proof.
-intros x y; unfold decidable, Zgt in |- *; elim (x ?= y);
- [ right; discriminate | right; discriminate | auto with arith ].
+  intros x y; unfold decidable, Zgt in |- *; elim (x ?= y);
+    [ right; discriminate | right; discriminate | auto with arith ].
 Qed.
 
 Theorem dec_Zge : forall n m:Z, decidable (n >= m).
 Proof.
-intros x y; unfold decidable, Zge in |- *; elim (x ?= y);
- [ left; discriminate
- | right; unfold not in |- *; intros H; apply H; trivial with arith
- | left; discriminate ]. 
+  intros x y; unfold decidable, Zge in |- *; elim (x ?= y);
+    [ left; discriminate
+      | right; unfold not in |- *; intros H; apply H; trivial with arith
+      | left; discriminate ]. 
 Qed.
 
 Theorem dec_Zlt : forall n m:Z, decidable (n < m).
 Proof.
-intros x y; unfold decidable, Zlt in |- *; elim (x ?= y);
- [ right; discriminate | auto with arith | right; discriminate ].
+  intros x y; unfold decidable, Zlt in |- *; elim (x ?= y);
+    [ right; discriminate | auto with arith | right; discriminate ].
 Qed.
 
 Theorem not_Zeq : forall n m:Z, n <> m -> n < m \/ m < n.
 Proof.
-intros x y; elim (Dcompare (x ?= y));
- [ intros H1 H2; absurd (x = y);
-    [ assumption | elim (Zcompare_Eq_iff_eq x y); auto with arith ]
- | unfold Zlt in |- *; intros H; elim H; intros H1;
-    [ auto with arith
-    | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ].
+  intros x y; elim (Dcompare (x ?= y));
+    [ intros H1 H2; absurd (x = y);
+      [ assumption | elim (Zcompare_Eq_iff_eq x y); auto with arith ]
+      | unfold Zlt in |- *; intros H; elim H; intros H1;
+	[ auto with arith
+	  | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ].
 Qed. 
 
-(** Relating strict and large orders *)
+(** * Relating strict and large orders *)
 
 Lemma Zgt_lt : forall n m:Z, n > m -> m < n.
 Proof.
-unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym m n);
- auto with arith.
+  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym m n);
+    auto with arith.
 Qed.
 
 Lemma Zlt_gt : forall n m:Z, n < m -> m > n.
 Proof.
-unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym n m);
- auto with arith.
+  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym n m);
+    auto with arith.
 Qed.
 
 Lemma Zge_le : forall n m:Z, n >= m -> m <= n.
 Proof.
-intros m n; change (~ m < n -> ~ n > m) in |- *; unfold not in |- *;
- intros H1 H2; apply H1; apply Zgt_lt; assumption.
+  intros m n; change (~ m < n -> ~ n > m) in |- *; unfold not in |- *;
+    intros H1 H2; apply H1; apply Zgt_lt; assumption.
 Qed.
 
 Lemma Zle_ge : forall n m:Z, n <= m -> m >= n.
 Proof.
-intros m n; change (~ m > n -> ~ n < m) in |- *; unfold not in |- *;
- intros H1 H2; apply H1; apply Zlt_gt; assumption.
+  intros m n; change (~ m > n -> ~ n < m) in |- *; unfold not in |- *;
+    intros H1 H2; apply H1; apply Zlt_gt; assumption.
 Qed.
 
 Lemma Zle_not_gt : forall n m:Z, n <= m -> ~ n > m.
 Proof.
-trivial.
+  trivial.
 Qed.
 
 Lemma Zgt_not_le : forall n m:Z, n > m -> ~ n <= m.
 Proof.
-intros n m H1 H2; apply H2; assumption.
+  intros n m H1 H2; apply H2; assumption.
 Qed.
 
 Lemma Zle_not_lt : forall n m:Z, n <= m -> ~ m < n.
 Proof.
-intros n m H1 H2.
-assert (H3 := Zlt_gt _ _ H2).
-apply Zle_not_gt with n m; assumption.
+  intros n m H1 H2.
+  assert (H3 := Zlt_gt _ _ H2).
+  apply Zle_not_gt with n m; assumption.
 Qed.
 
 Lemma Zlt_not_le : forall n m:Z, n < m -> ~ m <= n.
 Proof.
-intros n m H1 H2.
-apply Zle_not_lt with m n; assumption.
+  intros n m H1 H2.
+  apply Zle_not_lt with m n; assumption.
 Qed.
 
 Lemma Znot_ge_lt : forall n m:Z, ~ n >= m -> n < m.
 Proof.
-unfold Zge, Zlt in |- *; intros x y H; apply dec_not_not;
- [ exact (dec_Zlt x y) | assumption ].
+  unfold Zge, Zlt in |- *; intros x y H; apply dec_not_not;
+    [ exact (dec_Zlt x y) | assumption ].
 Qed.
- 
+
 Lemma Znot_lt_ge : forall n m:Z, ~ n < m -> n >= m.
 Proof.
-unfold Zlt, Zge in |- *; auto with arith.
+  unfold Zlt, Zge in |- *; auto with arith.
 Qed.
 
 Lemma Znot_gt_le : forall n m:Z, ~ n > m -> n <= m.
 Proof.
-trivial.
+  trivial.
 Qed.
 
 Lemma Znot_le_gt : forall n m:Z, ~ n <= m -> n > m.
 Proof.
-unfold Zle, Zgt in |- *; intros x y H; apply dec_not_not;
- [ exact (dec_Zgt x y) | assumption ].
+  unfold Zle, Zgt in |- *; intros x y H; apply dec_not_not;
+    [ exact (dec_Zgt x y) | assumption ].
 Qed.
 
 Lemma Zge_iff_le : forall n m:Z, n >= m <-> m <= n.
 Proof.
-    intros x y; intros. split. intro. apply Zge_le. assumption.
-    intro. apply Zle_ge. assumption.
+  intros x y; intros. split. intro. apply Zge_le. assumption.
+  intro. apply Zle_ge. assumption.
 Qed.
 
 Lemma Zgt_iff_lt : forall n m:Z, n > m <-> m < n.
 Proof.
-    intros x y. split. intro. apply Zgt_lt. assumption.
-    intro. apply Zlt_gt. assumption.
+  intros x y. split. intro. apply Zgt_lt. assumption.
+  intro. apply Zlt_gt. assumption.
 Qed.
  
+(** * Equivalence and order properties *)
+
 (** Reflexivity *)
 
 Lemma Zle_refl : forall n:Z, n <= n.
 Proof.
-intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate.
+  intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate.
 Qed. 
 
 Lemma Zeq_le : forall n m:Z, n = m -> n <= m.
 Proof.
-intros; rewrite H; apply Zle_refl.
+  intros; rewrite H; apply Zle_refl.
 Qed.
 
 Hint Resolve Zle_refl: zarith.
@@ -199,7 +201,7 @@ Hint Resolve Zle_refl: zarith.
 
 Lemma Zle_antisym : forall n m:Z, n <= m -> m <= n -> n = m.
 Proof.
-intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. 
+  intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. 
   absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption.
   assumption.
   absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption.
@@ -209,138 +211,143 @@ Qed.
 
 Lemma Zgt_asym : forall n m:Z, n > m -> ~ m > n.
 Proof.
-unfold Zgt in |- *; intros n m H; elim (Zcompare_Gt_Lt_antisym n m);
- intros H1 H2; rewrite H1; [ discriminate | assumption ].
+  unfold Zgt in |- *; intros n m H; elim (Zcompare_Gt_Lt_antisym n m);
+    intros H1 H2; rewrite H1; [ discriminate | assumption ].
 Qed.
 
 Lemma Zlt_asym : forall n m:Z, n < m -> ~ m < n.
 Proof.
-intros n m H H1; assert (H2 : m > n). apply Zlt_gt; assumption.
-assert (H3 : n > m). apply Zlt_gt; assumption.
-apply Zgt_asym with m n; assumption.
+  intros n m H H1; assert (H2 : m > n). apply Zlt_gt; assumption.
+  assert (H3 : n > m). apply Zlt_gt; assumption.
+  apply Zgt_asym with m n; assumption.
 Qed.
 
 (** Irreflexivity *)
 
 Lemma Zgt_irrefl : forall n:Z, ~ n > n.
 Proof.
-intros n H; apply (Zgt_asym n n H H).
+  intros n H; apply (Zgt_asym n n H H).
 Qed.
 
 Lemma Zlt_irrefl : forall n:Z, ~ n < n.
 Proof.
-intros n H; apply (Zlt_asym n n H H).
+  intros n H; apply (Zlt_asym n n H H).
 Qed.
 
 Lemma Zlt_not_eq : forall n m:Z, n < m -> n <> m.
 Proof.
-unfold not in |- *; intros x y H H0.
-rewrite H0 in H.
-apply (Zlt_irrefl _ H).
+  unfold not in |- *; intros x y H H0.
+  rewrite H0 in H.
+  apply (Zlt_irrefl _ H).
 Qed.
 
 (** Large = strict or equal *)
 
 Lemma Zlt_le_weak : forall n m:Z, n < m -> n <= m.
 Proof.
-intros n m Hlt; apply Znot_gt_le; apply Zgt_asym; apply Zlt_gt; assumption.
+  intros n m Hlt; apply Znot_gt_le; apply Zgt_asym; apply Zlt_gt; assumption.
 Qed.
 
 Lemma Zle_lt_or_eq : forall n m:Z, n <= m -> n < m \/ n = m.
 Proof.
-intros n m H; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
- [ left; assumption
- | right; assumption
- | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ].
+  intros n m H; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
+    [ left; assumption
+      | right; assumption
+      | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ].
 Qed.
 
 (** Dichotomy *)
 
 Lemma Zle_or_lt : forall n m:Z, n <= m \/ m < n.
 Proof.
-intros n m; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
- [ left; apply Znot_gt_le; intro Hgt; assert (Hgt' := Zlt_gt _ _ Hlt);
-    apply Zgt_asym with m n; assumption
- | left; rewrite Heq; apply Zle_refl
- | right; apply Zgt_lt; assumption ].
+  intros n m; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
+    [ left; apply Znot_gt_le; intro Hgt; assert (Hgt' := Zlt_gt _ _ Hlt);
+      apply Zgt_asym with m n; assumption
+      | left; rewrite Heq; apply Zle_refl
+      | right; apply Zgt_lt; assumption ].
 Qed.
 
 (** Transitivity of strict orders *)
 
 Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p.
 Proof.
-exact Zcompare_Gt_trans.
+  exact Zcompare_Gt_trans.
 Qed.
 
 Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p.
 Proof.
-intros n m p H1 H2; apply Zgt_lt; apply Zgt_trans with (m := m); apply Zlt_gt;
- assumption.
+  intros n m p H1 H2; apply Zgt_lt; apply Zgt_trans with (m := m); apply Zlt_gt;
+    assumption.
 Qed.
 
 (** Mixed transitivity *)
 
 Lemma Zle_gt_trans : forall n m p:Z, m <= n -> m > p -> n > p.
 Proof.
-intros n m p H1 H2; destruct (Zle_lt_or_eq m n H1) as [Hlt| Heq];
- [ apply Zgt_trans with m; [ apply Zlt_gt; assumption | assumption ]
- | rewrite <- Heq; assumption ].
+  intros n m p H1 H2; destruct (Zle_lt_or_eq m n H1) as [Hlt| Heq];
+    [ apply Zgt_trans with m; [ apply Zlt_gt; assumption | assumption ]
+      | rewrite <- Heq; assumption ].
 Qed.
 
 Lemma Zgt_le_trans : forall n m p:Z, n > m -> p <= m -> n > p.
 Proof.
-intros n m p H1 H2; destruct (Zle_lt_or_eq p m H2) as [Hlt| Heq];
- [ apply Zgt_trans with m; [ assumption | apply Zlt_gt; assumption ]
- | rewrite Heq; assumption ].
+  intros n m p H1 H2; destruct (Zle_lt_or_eq p m H2) as [Hlt| Heq];
+    [ apply Zgt_trans with m; [ assumption | apply Zlt_gt; assumption ]
+      | rewrite Heq; assumption ].
 Qed.
 
 Lemma Zlt_le_trans : forall n m p:Z, n < m -> m <= p -> n < p.
-intros n m p H1 H2; apply Zgt_lt; apply Zle_gt_trans with (m := m);
- [ assumption | apply Zlt_gt; assumption ].
+  intros n m p H1 H2; apply Zgt_lt; apply Zle_gt_trans with (m := m);
+    [ assumption | apply Zlt_gt; assumption ].
 Qed.
 
 Lemma Zle_lt_trans : forall n m p:Z, n <= m -> m < p -> n < p.
 Proof.
-intros n m p H1 H2; apply Zgt_lt; apply Zgt_le_trans with (m := m);
- [ apply Zlt_gt; assumption | assumption ].
+  intros n m p H1 H2; apply Zgt_lt; apply Zgt_le_trans with (m := m);
+    [ apply Zlt_gt; assumption | assumption ].
 Qed.
 
 (** Transitivity of large orders *)
 
 Lemma Zle_trans : forall n m p:Z, n <= m -> m <= p -> n <= p.
 Proof.
-intros n m p H1 H2; apply Znot_gt_le.
-intro Hgt; apply Zle_not_gt with n m. assumption.
-exact (Zgt_le_trans n p m Hgt H2).
+  intros n m p H1 H2; apply Znot_gt_le.
+  intro Hgt; apply Zle_not_gt with n m. assumption.
+  exact (Zgt_le_trans n p m Hgt H2).
 Qed.
 
 Lemma Zge_trans : forall n m p:Z, n >= m -> m >= p -> n >= p.
 Proof.
-intros n m p H1 H2.
-apply Zle_ge.
-apply Zle_trans with m; apply Zge_le; trivial.
+  intros n m p H1 H2.
+  apply Zle_ge.
+  apply Zle_trans with m; apply Zge_le; trivial.
 Qed.
 
 Hint Resolve Zle_trans: zarith.
 
+
+(** * Compatibility of order and operations on Z *)
+
+(** ** Successor *)
+
 (** Compatibility of successor wrt to order *)
 
 Lemma Zsucc_le_compat : forall n m:Z, m <= n -> Zsucc m <= Zsucc n.
 Proof.
-unfold Zle, not in |- *; intros m n H1 H2; apply H1;
- rewrite <- (Zcompare_plus_compat n m 1); do 2 rewrite (Zplus_comm 1);
- exact H2.
+  unfold Zle, not in |- *; intros m n H1 H2; apply H1;
+    rewrite <- (Zcompare_plus_compat n m 1); do 2 rewrite (Zplus_comm 1);
+      exact H2.
 Qed.
 
 Lemma Zsucc_gt_compat : forall n m:Z, m > n -> Zsucc m > Zsucc n.
 Proof.
-unfold Zgt in |- *; intros n m H; rewrite Zcompare_succ_compat;
- auto with arith.
+  unfold Zgt in |- *; intros n m H; rewrite Zcompare_succ_compat;
+    auto with arith.
 Qed.
 
 Lemma Zsucc_lt_compat : forall n m:Z, n < m -> Zsucc n < Zsucc m.
 Proof.
-intros n m H; apply Zgt_lt; apply Zsucc_gt_compat; apply Zlt_gt; assumption.
+  intros n m H; apply Zgt_lt; apply Zsucc_gt_compat; apply Zlt_gt; assumption.
 Qed.
 
 Hint Resolve Zsucc_le_compat: zarith.
@@ -349,231 +356,119 @@ Hint Resolve Zsucc_le_compat: zarith.
 
 Lemma Zsucc_gt_reg : forall n m:Z, Zsucc m > Zsucc n -> m > n.
 Proof.
-unfold Zsucc, Zgt in |- *; intros n p;
- do 2 rewrite (fun m:Z => Zplus_comm m 1);
- rewrite (Zcompare_plus_compat p n 1); trivial with arith.
+  unfold Zsucc, Zgt in |- *; intros n p;
+    do 2 rewrite (fun m:Z => Zplus_comm m 1);
+      rewrite (Zcompare_plus_compat p n 1); trivial with arith.
 Qed.
 
 Lemma Zsucc_le_reg : forall n m:Z, Zsucc m <= Zsucc n -> m <= n.
 Proof.
-unfold Zle, not in |- *; intros m n H1 H2; apply H1; unfold Zsucc in |- *;
- do 2 rewrite <- (Zplus_comm 1); rewrite (Zcompare_plus_compat n m 1);
- assumption.
+  unfold Zle, not in |- *; intros m n H1 H2; apply H1; unfold Zsucc in |- *;
+    do 2 rewrite <- (Zplus_comm 1); rewrite (Zcompare_plus_compat n m 1);
+      assumption.
 Qed.
 
 Lemma Zsucc_lt_reg : forall n m:Z, Zsucc n < Zsucc m -> n < m.
 Proof.
-intros n m H; apply Zgt_lt; apply Zsucc_gt_reg; apply Zlt_gt; assumption.
-Qed.
-
-(** Compatibility of addition wrt to order *)
-
-Lemma Zplus_gt_compat_l : forall n m p:Z, n > m -> p + n > p + m.
-Proof.
-unfold Zgt in |- *; intros n m p H; rewrite (Zcompare_plus_compat n m p);
- assumption.
-Qed.
-
-Lemma Zplus_gt_compat_r : forall n m p:Z, n > m -> n + p > m + p.
-Proof.
-intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
- apply Zplus_gt_compat_l; trivial.
-Qed.
-
-Lemma Zplus_le_compat_l : forall n m p:Z, n <= m -> p + n <= p + m.
-Proof.
-intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
- rewrite <- (Zcompare_plus_compat n m p); assumption.
-Qed.
-
-Lemma Zplus_le_compat_r : forall n m p:Z, n <= m -> n + p <= m + p.
-Proof.
-intros a b c; do 2 rewrite (fun n:Z => Zplus_comm n c);
- exact (Zplus_le_compat_l a b c).
-Qed.
-
-Lemma Zplus_lt_compat_l : forall n m p:Z, n < m -> p + n < p + m.
-Proof.
-unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
- trivial with arith.
-Qed.
-
-Lemma Zplus_lt_compat_r : forall n m p:Z, n < m -> n + p < m + p.
-Proof.
-intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
- apply Zplus_lt_compat_l; trivial.
-Qed.
-
-Lemma Zplus_lt_le_compat : forall n m p q:Z, n < m -> p <= q -> n + p < m + q.
-Proof.
-intros a b c d H0 H1.
-apply Zlt_le_trans with (b + c).
-apply Zplus_lt_compat_r; trivial.
-apply Zplus_le_compat_l; trivial.
-Qed.
-
-Lemma Zplus_le_lt_compat : forall n m p q:Z, n <= m -> p < q -> n + p < m + q.
-Proof.
-intros a b c d H0 H1.
-apply Zle_lt_trans with (b + c).
-apply Zplus_le_compat_r; trivial.
-apply Zplus_lt_compat_l; trivial.
-Qed.
-
-Lemma Zplus_le_compat : forall n m p q:Z, n <= m -> p <= q -> n + p <= m + q.
-Proof.
-intros n m p q; intros H1 H2; apply Zle_trans with (m := n + q);
- [ apply Zplus_le_compat_l; assumption
- | apply Zplus_le_compat_r; assumption ].
-Qed.
-
-
-Lemma Zplus_lt_compat : forall n m p q:Z, n < m -> p < q -> n + p < m + q.
-intros; apply Zplus_le_lt_compat. apply Zlt_le_weak; assumption. assumption.
-Qed.
-
-
-(** Compatibility of addition wrt to being positive *)
-
-Lemma Zplus_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n + m.
-Proof.
-intros x y H1 H2; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; assumption.
-Qed.
-
-(** Simplification of addition wrt to order *)
-
-Lemma Zplus_gt_reg_l : forall n m p:Z, p + n > p + m -> n > m.
-Proof.
-unfold Zgt in |- *; intros n m p H; rewrite <- (Zcompare_plus_compat n m p);
- assumption.
-Qed.
-
-Lemma Zplus_gt_reg_r : forall n m p:Z, n + p > m + p -> n > m.
-Proof.
-intros n m p H; apply Zplus_gt_reg_l with p.
-rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+  intros n m H; apply Zgt_lt; apply Zsucc_gt_reg; apply Zlt_gt; assumption.
 Qed.
 
-Lemma Zplus_le_reg_l : forall n m p:Z, p + n <= p + m -> n <= m.
-Proof.
-intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
- rewrite (Zcompare_plus_compat n m p); assumption.
-Qed.
- 
-Lemma Zplus_le_reg_r : forall n m p:Z, n + p <= m + p -> n <= m.
-Proof.
-intros n m p H; apply Zplus_le_reg_l with p.
-rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
-Qed.
-
-Lemma Zplus_lt_reg_l : forall n m p:Z, p + n < p + m -> n < m.
-Proof.
-unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
- trivial with arith.
-Qed.
- 
-Lemma Zplus_lt_reg_r : forall n m p:Z, n + p < m + p -> n < m.
-Proof.
-intros n m p H; apply Zplus_lt_reg_l with p.
-rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
-Qed.
- 
 (** Special base instances of order *)
 
 Lemma Zgt_succ : forall n:Z, Zsucc n > n.
 Proof.
-exact Zcompare_succ_Gt.
+  exact Zcompare_succ_Gt.
 Qed.
 
 Lemma Znot_le_succ : forall n:Z, ~ Zsucc n <= n.
 Proof.
-intros n; apply Zgt_not_le; apply Zgt_succ.
+  intros n; apply Zgt_not_le; apply Zgt_succ.
 Qed.
 
 Lemma Zlt_succ : forall n:Z, n < Zsucc n.
 Proof.
-intro n; apply Zgt_lt; apply Zgt_succ.
+  intro n; apply Zgt_lt; apply Zgt_succ.
 Qed.
 
 Lemma Zlt_pred : forall n:Z, Zpred n < n.
 Proof.
-intros n; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; apply Zlt_succ.
+  intros n; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; apply Zlt_succ.
 Qed.
 
 (** Relating strict and large order using successor or predecessor *)
 
 Lemma Zgt_le_succ : forall n m:Z, m > n -> Zsucc n <= m.
 Proof.
-unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n);
- intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; 
- apply H1;
- [ assumption
- | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ].
+  unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n);
+    intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; 
+      apply H1;
+	[ assumption
+	  | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ].
 Qed.
 
 Lemma Zlt_gt_succ : forall n m:Z, n <= m -> Zsucc m > n.
 Proof.
-intros n p H; apply Zgt_le_trans with p.
+  intros n p H; apply Zgt_le_trans with p.
   apply Zgt_succ.
   assumption.
 Qed.
 
 Lemma Zle_lt_succ : forall n m:Z, n <= m -> n < Zsucc m.
 Proof.
-intros n m H; apply Zgt_lt; apply Zlt_gt_succ; assumption.
+  intros n m H; apply Zgt_lt; apply Zlt_gt_succ; assumption.
 Qed.
 
 Lemma Zlt_le_succ : forall n m:Z, n < m -> Zsucc n <= m.
 Proof.
-intros n p H; apply Zgt_le_succ; apply Zlt_gt; assumption.
+  intros n p H; apply Zgt_le_succ; apply Zlt_gt; assumption.
 Qed.
 
 Lemma Zgt_succ_le : forall n m:Z, Zsucc m > n -> n <= m.
 Proof.
-intros n p H; apply Zsucc_le_reg; apply Zgt_le_succ; assumption.
+  intros n p H; apply Zsucc_le_reg; apply Zgt_le_succ; assumption.
 Qed.
 
 Lemma Zlt_succ_le : forall n m:Z, n < Zsucc m -> n <= m.
 Proof.
-intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption.
+  intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption.
 Qed.
 
 Lemma Zlt_succ_gt : forall n m:Z, Zsucc n <= m -> m > n.
 Proof.
-intros n m H; apply Zle_gt_trans with (m := Zsucc n);
- [ assumption | apply Zgt_succ ].
+  intros n m H; apply Zle_gt_trans with (m := Zsucc n);
+    [ assumption | apply Zgt_succ ].
 Qed.
 
 (** Weakening order *)
 
 Lemma Zle_succ : forall n:Z, n <= Zsucc n.
 Proof.
-intros n; apply Zgt_succ_le; apply Zgt_trans with (m := Zsucc n);
- apply Zgt_succ.
+  intros n; apply Zgt_succ_le; apply Zgt_trans with (m := Zsucc n);
+    apply Zgt_succ.
 Qed.
 
 Hint Resolve Zle_succ: zarith.
 
 Lemma Zle_pred : forall n:Z, Zpred n <= n.
 Proof.
-intros n; pattern n at 2 in |- *; rewrite Zsucc_pred; apply Zle_succ.
+  intros n; pattern n at 2 in |- *; rewrite Zsucc_pred; apply Zle_succ.
 Qed.
 
 Lemma Zlt_lt_succ : forall n m:Z, n < m -> n < Zsucc m.
-intros n m H; apply Zgt_lt; apply Zgt_trans with (m := m);
- [ apply Zgt_succ | apply Zlt_gt; assumption ].
+  intros n m H; apply Zgt_lt; apply Zgt_trans with (m := m);
+    [ apply Zgt_succ | apply Zlt_gt; assumption ].
 Qed.
 
 Lemma Zle_le_succ : forall n m:Z, n <= m -> n <= Zsucc m.
 Proof.
-intros x y H.
-apply Zle_trans with y; trivial with zarith.
+  intros x y H.
+  apply Zle_trans with y; trivial with zarith.
 Qed.
 
 Lemma Zle_succ_le : forall n m:Z, Zsucc n <= m -> n <= m.
 Proof.
-intros n m H; apply Zle_trans with (m := Zsucc n);
- [ apply Zle_succ | assumption ].
+  intros n m H; apply Zle_trans with (m := Zsucc n);
+    [ apply Zle_succ | assumption ].
 Qed.
 
 Hint Resolve Zle_le_succ: zarith.
@@ -582,31 +477,32 @@ Hint Resolve Zle_le_succ: zarith.
 
 Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n.
 Proof.
-unfold Zgt, Zsucc, Zpred in |- *; intros n p H;
- rewrite <- (fun x y => Zcompare_plus_compat x y 1); 
- rewrite (Zplus_comm p); rewrite Zplus_assoc;
- rewrite (fun x => Zplus_comm x n); simpl in |- *; 
- assumption.
+  unfold Zgt, Zsucc, Zpred in |- *; intros n p H;
+    rewrite <- (fun x y => Zcompare_plus_compat x y 1); 
+      rewrite (Zplus_comm p); rewrite Zplus_assoc;
+	rewrite (fun x => Zplus_comm x n); simpl in |- *; 
+	  assumption.
 Qed.
 
 Lemma Zlt_succ_pred : forall n m:Z, Zsucc n < m -> n < Zpred m.
 Proof.
-intros n p H; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; assumption.
+  intros n p H; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; assumption.
 Qed.
 
 (** Relating strict order and large order on positive *)
 
 Lemma Zlt_0_le_0_pred : forall n:Z, 0 < n -> 0 <= Zpred n.
-intros x H.
-rewrite (Zsucc_pred x) in H.
-apply Zgt_succ_le.
-apply Zlt_gt.
-assumption.
+Proof.
+  intros x H.
+  rewrite (Zsucc_pred x) in H.
+  apply Zgt_succ_le.
+  apply Zlt_gt.
+  assumption.
 Qed.
 
-
 Lemma Zgt_0_le_0_pred : forall n:Z, n > 0 -> 0 <= Zpred n.
-intros; apply Zlt_0_le_0_pred; apply Zgt_lt. assumption.
+Proof.
+  intros; apply Zlt_0_le_0_pred; apply Zgt_lt. assumption.
 Qed.
 
 
@@ -614,35 +510,39 @@ Qed.
 
 Lemma Zlt_0_1 : 0 < 1.
 Proof.
-change (0 < Zsucc 0) in |- *. apply Zlt_succ.
+  change (0 < Zsucc 0) in |- *. apply Zlt_succ.
 Qed.
 
 Lemma Zle_0_1 : 0 <= 1.
 Proof.
-change (0 <= Zsucc 0) in |- *. apply Zle_succ.
+  change (0 <= Zsucc 0) in |- *. apply Zle_succ.
 Qed.
 
 Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q.
 Proof.
-intros p; red in |- *; simpl in |- *; red in |- *; intros H; discriminate.
+  intros p; red in |- *; simpl in |- *; red in |- *; intros H; discriminate.
 Qed.
 
 Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0.
-unfold Zgt in |- *; trivial.
+Proof.
+  unfold Zgt in |- *; trivial.
 Qed.
 
-  (* weaker but useful (in [Zpower] for instance) *)
+(* weaker but useful (in [Zpower] for instance) *)
 Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p.
-intro; unfold Zle in |- *; discriminate.
+Proof.
+  intro; unfold Zle in |- *; discriminate.
 Qed.
 
 Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0.
-unfold Zlt in |- *; trivial.
+Proof.
+  unfold Zlt in |- *; trivial.
 Qed.
 
 Lemma Zle_0_nat : forall n:nat, 0 <= Z_of_nat n.
-simple induction n; simpl in |- *; intros;
- [ apply Zle_refl | unfold Zle in |- *; simpl in |- *; discriminate ].
+Proof.
+  simple induction n; simpl in |- *; intros;
+    [ apply Zle_refl | unfold Zle in |- *; simpl in |- *; discriminate ].
 Qed.
 
 Hint Immediate Zeq_le: zarith.
@@ -651,178 +551,294 @@ Hint Immediate Zeq_le: zarith.
 
 Lemma Zge_trans_succ : forall n m p:Z, Zsucc n > m -> m > p -> n > p.
 Proof.
-intros n m p H1 H2; apply Zle_gt_trans with (m := m);
- [ apply Zgt_succ_le; assumption | assumption ].
+  intros n m p H1 H2; apply Zle_gt_trans with (m := m);
+    [ apply Zgt_succ_le; assumption | assumption ].
 Qed.
 
 (** Derived lemma *)
 
 Lemma Zgt_succ_gt_or_eq : forall n m:Z, Zsucc n > m -> n > m \/ m = n.
 Proof.
-intros n m H.
-assert (Hle : m <= n).
+  intros n m H.
+  assert (Hle : m <= n).
   apply Zgt_succ_le; assumption.
-destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq].
+  destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq].
   left; apply Zlt_gt; assumption.  
   right; assumption.
 Qed.
 
-(** Compatibility of multiplication by a positive wrt to order *)
+(** ** Addition *)
+(** Compatibility of addition wrt to order *)
+
+Lemma Zplus_gt_compat_l : forall n m p:Z, n > m -> p + n > p + m.
+Proof.
+  unfold Zgt in |- *; intros n m p H; rewrite (Zcompare_plus_compat n m p);
+    assumption.
+Qed.
+
+Lemma Zplus_gt_compat_r : forall n m p:Z, n > m -> n + p > m + p.
+Proof.
+  intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
+    apply Zplus_gt_compat_l; trivial.
+Qed.
+
+Lemma Zplus_le_compat_l : forall n m p:Z, n <= m -> p + n <= p + m.
+Proof.
+  intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
+    rewrite <- (Zcompare_plus_compat n m p); assumption.
+Qed.
+
+Lemma Zplus_le_compat_r : forall n m p:Z, n <= m -> n + p <= m + p.
+Proof.
+  intros a b c; do 2 rewrite (fun n:Z => Zplus_comm n c);
+    exact (Zplus_le_compat_l a b c).
+Qed.
+
+Lemma Zplus_lt_compat_l : forall n m p:Z, n < m -> p + n < p + m.
+Proof.
+  unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
+    trivial with arith.
+Qed.
+
+Lemma Zplus_lt_compat_r : forall n m p:Z, n < m -> n + p < m + p.
+Proof.
+  intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
+    apply Zplus_lt_compat_l; trivial.
+Qed.
+
+Lemma Zplus_lt_le_compat : forall n m p q:Z, n < m -> p <= q -> n + p < m + q.
+Proof.
+  intros a b c d H0 H1.
+  apply Zlt_le_trans with (b + c).
+  apply Zplus_lt_compat_r; trivial.
+  apply Zplus_le_compat_l; trivial.
+Qed.
+
+Lemma Zplus_le_lt_compat : forall n m p q:Z, n <= m -> p < q -> n + p < m + q.
+Proof.
+  intros a b c d H0 H1.
+  apply Zle_lt_trans with (b + c).
+  apply Zplus_le_compat_r; trivial.
+  apply Zplus_lt_compat_l; trivial.
+Qed.
+
+Lemma Zplus_le_compat : forall n m p q:Z, n <= m -> p <= q -> n + p <= m + q.
+Proof.
+  intros n m p q; intros H1 H2; apply Zle_trans with (m := n + q);
+    [ apply Zplus_le_compat_l; assumption
+      | apply Zplus_le_compat_r; assumption ].
+Qed.
+
+
+Lemma Zplus_lt_compat : forall n m p q:Z, n < m -> p < q -> n + p < m + q.
+  intros; apply Zplus_le_lt_compat. apply Zlt_le_weak; assumption. assumption.
+Qed.
+
+
+(** Compatibility of addition wrt to being positive *)
+
+Lemma Zplus_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n + m.
+Proof.
+  intros x y H1 H2; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; assumption.
+Qed.
 
+(** Simplification of addition wrt to order *)
+
+Lemma Zplus_gt_reg_l : forall n m p:Z, p + n > p + m -> n > m.
+Proof.
+  unfold Zgt in |- *; intros n m p H; rewrite <- (Zcompare_plus_compat n m p);
+    assumption.
+Qed.
+
+Lemma Zplus_gt_reg_r : forall n m p:Z, n + p > m + p -> n > m.
+Proof.
+  intros n m p H; apply Zplus_gt_reg_l with p.
+  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+Qed.
+
+Lemma Zplus_le_reg_l : forall n m p:Z, p + n <= p + m -> n <= m.
+Proof.
+  intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
+    rewrite (Zcompare_plus_compat n m p); assumption.
+Qed.
+
+Lemma Zplus_le_reg_r : forall n m p:Z, n + p <= m + p -> n <= m.
+Proof.
+  intros n m p H; apply Zplus_le_reg_l with p.
+  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+Qed.
+
+Lemma Zplus_lt_reg_l : forall n m p:Z, p + n < p + m -> n < m.
+Proof.
+  unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
+    trivial with arith.
+Qed.
+
+Lemma Zplus_lt_reg_r : forall n m p:Z, n + p < m + p -> n < m.
+Proof.
+  intros n m p H; apply Zplus_lt_reg_l with p.
+  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
+Qed.
+
+(** ** Multiplication *) 
+(** Compatibility of multiplication by a positive wrt to order *)
 
 Lemma Zmult_le_compat_r : forall n m p:Z, n <= m -> 0 <= p -> n * p <= m * p.
 Proof.
-intros a b c H H0; destruct c.
+  intros a b c H H0; destruct c.
   do 2 rewrite Zmult_0_r; assumption.
   rewrite (Zmult_comm a); rewrite (Zmult_comm b).
-    unfold Zle in |- *; rewrite Zcompare_mult_compat; assumption.
+  unfold Zle in |- *; rewrite Zcompare_mult_compat; assumption.
   unfold Zle in H0; contradiction H0; reflexivity.
 Qed.
 
 Lemma Zmult_le_compat_l : forall n m p:Z, n <= m -> 0 <= p -> p * n <= p * m.
 Proof.
-intros a b c H1 H2; rewrite (Zmult_comm c a); rewrite (Zmult_comm c b).
-apply Zmult_le_compat_r; trivial.
+  intros a b c H1 H2; rewrite (Zmult_comm c a); rewrite (Zmult_comm c b).
+  apply Zmult_le_compat_r; trivial.
 Qed.
 
 Lemma Zmult_lt_compat_r : forall n m p:Z, 0 < p -> n < m -> n * p < m * p.
 Proof.
-intros x y z H H0; destruct z.
+  intros x y z H H0; destruct z.
   contradiction (Zlt_irrefl 0).
   rewrite (Zmult_comm x); rewrite (Zmult_comm y).
-    unfold Zlt in |- *; rewrite Zcompare_mult_compat; assumption.
+  unfold Zlt in |- *; rewrite Zcompare_mult_compat; assumption.
   discriminate H.
 Qed.
 
 Lemma Zmult_gt_compat_r : forall n m p:Z, p > 0 -> n > m -> n * p > m * p.
 Proof.
-intros x y z; intros; apply Zlt_gt; apply Zmult_lt_compat_r; apply Zgt_lt;
- assumption.
+  intros x y z; intros; apply Zlt_gt; apply Zmult_lt_compat_r; apply Zgt_lt;
+    assumption.
 Qed.
 
 Lemma Zmult_gt_0_lt_compat_r :
- forall n m p:Z, p > 0 -> n < m -> n * p < m * p.
+  forall n m p:Z, p > 0 -> n < m -> n * p < m * p.
 Proof.
-intros x y z; intros; apply Zmult_lt_compat_r;
- [ apply Zgt_lt; assumption | assumption ].
+  intros x y z; intros; apply Zmult_lt_compat_r;
+    [ apply Zgt_lt; assumption | assumption ].
 Qed.
 
 Lemma Zmult_gt_0_le_compat_r :
- forall n m p:Z, p > 0 -> n <= m -> n * p <= m * p.
+  forall n m p:Z, p > 0 -> n <= m -> n * p <= m * p.
 Proof.
-intros x y z Hz Hxy.
-elim (Zle_lt_or_eq x y Hxy).
-intros; apply Zlt_le_weak.
-apply Zmult_gt_0_lt_compat_r; trivial.
-intros; apply Zeq_le.
-rewrite H; trivial.
+  intros x y z Hz Hxy.
+  elim (Zle_lt_or_eq x y Hxy).
+  intros; apply Zlt_le_weak.
+  apply Zmult_gt_0_lt_compat_r; trivial.
+  intros; apply Zeq_le.
+  rewrite H; trivial.
 Qed.
 
 Lemma Zmult_lt_0_le_compat_r :
- forall n m p:Z, 0 < p -> n <= m -> n * p <= m * p.
+  forall n m p:Z, 0 < p -> n <= m -> n * p <= m * p.
 Proof.
-intros x y z; intros; apply Zmult_gt_0_le_compat_r; try apply Zlt_gt;
- assumption.
+  intros x y z; intros; apply Zmult_gt_0_le_compat_r; try apply Zlt_gt;
+    assumption.
 Qed.
 
 Lemma Zmult_gt_0_lt_compat_l :
- forall n m p:Z, p > 0 -> n < m -> p * n < p * m.
+  forall n m p:Z, p > 0 -> n < m -> p * n < p * m.
 Proof.
-intros x y z; intros.
-rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
- apply Zmult_gt_0_lt_compat_r; assumption.
+  intros x y z; intros.
+  rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
+    apply Zmult_gt_0_lt_compat_r; assumption.
 Qed.
 
 Lemma Zmult_lt_compat_l : forall n m p:Z, 0 < p -> n < m -> p * n < p * m.
 Proof.
-intros x y z; intros.
-rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
- apply Zmult_gt_0_lt_compat_r; try apply Zlt_gt; assumption.
+  intros x y z; intros.
+  rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
+    apply Zmult_gt_0_lt_compat_r; try apply Zlt_gt; assumption.
 Qed.
 
 Lemma Zmult_gt_compat_l : forall n m p:Z, p > 0 -> n > m -> p * n > p * m.
 Proof.
-intros x y z; intros; rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
- apply Zmult_gt_compat_r; assumption.
+  intros x y z; intros; rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
+    apply Zmult_gt_compat_r; assumption.
 Qed.
 
 Lemma Zmult_ge_compat_r : forall n m p:Z, n >= m -> p >= 0 -> n * p >= m * p.
 Proof.
-intros a b c H1 H2; apply Zle_ge.
-apply Zmult_le_compat_r; apply Zge_le; trivial.
+  intros a b c H1 H2; apply Zle_ge.
+  apply Zmult_le_compat_r; apply Zge_le; trivial.
 Qed.
 
 Lemma Zmult_ge_compat_l : forall n m p:Z, n >= m -> p >= 0 -> p * n >= p * m.
 Proof.
-intros a b c H1 H2; apply Zle_ge.
-apply Zmult_le_compat_l; apply Zge_le; trivial.
+  intros a b c H1 H2; apply Zle_ge.
+  apply Zmult_le_compat_l; apply Zge_le; trivial.
 Qed.
 
 Lemma Zmult_ge_compat :
- forall n m p q:Z, n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q.
+  forall n m p q:Z, n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q.
 Proof.
-intros a b c d H0 H1 H2 H3.
-apply Zge_trans with (a * d).
-apply Zmult_ge_compat_l; trivial.
-apply Zge_trans with c; trivial. 
-apply Zmult_ge_compat_r; trivial.
+  intros a b c d H0 H1 H2 H3.
+  apply Zge_trans with (a * d).
+  apply Zmult_ge_compat_l; trivial.
+  apply Zge_trans with c; trivial. 
+  apply Zmult_ge_compat_r; trivial.
 Qed.
 
 Lemma Zmult_le_compat :
- forall n m p q:Z, n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q.
+  forall n m p q:Z, n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q.
 Proof.
-intros a b c d H0 H1 H2 H3.
-apply Zle_trans with (c * b).
-apply Zmult_le_compat_r; assumption.
-apply Zmult_le_compat_l.
-assumption.
-apply Zle_trans with a; assumption.
+  intros a b c d H0 H1 H2 H3.
+  apply Zle_trans with (c * b).
+  apply Zmult_le_compat_r; assumption.
+  apply Zmult_le_compat_l.
+  assumption.
+  apply Zle_trans with a; assumption.
 Qed.
 
 (** Simplification of multiplication by a positive wrt to being positive *)
 
 Lemma Zmult_gt_0_lt_reg_r : forall n m p:Z, p > 0 -> n * p < m * p -> n < m.
 Proof.
-intros x y z; intros; destruct z.
+  intros x y z; intros; destruct z.
   contradiction (Zgt_irrefl 0).
   rewrite (Zmult_comm x) in H0; rewrite (Zmult_comm y) in H0.
-    unfold Zlt in H0; rewrite Zcompare_mult_compat in H0; assumption.
+  unfold Zlt in H0; rewrite Zcompare_mult_compat in H0; assumption.
   discriminate H.
 Qed.
 
 Lemma Zmult_lt_reg_r : forall n m p:Z, 0 < p -> n * p < m * p -> n < m.
 Proof.
-intros a b c H0 H1.
-apply Zmult_gt_0_lt_reg_r with c; try apply Zlt_gt; assumption.
+  intros a b c H0 H1.
+  apply Zmult_gt_0_lt_reg_r with c; try apply Zlt_gt; assumption.
 Qed.
 
 Lemma Zmult_le_reg_r : forall n m p:Z, p > 0 -> n * p <= m * p -> n <= m.
 Proof.
-intros x y z Hz Hxy.
-elim (Zle_lt_or_eq (x * z) (y * z) Hxy).
-intros; apply Zlt_le_weak.
-apply Zmult_gt_0_lt_reg_r with z; trivial.
-intros; apply Zeq_le.
-apply Zmult_reg_r with z.
+  intros x y z Hz Hxy.
+  elim (Zle_lt_or_eq (x * z) (y * z) Hxy).
+  intros; apply Zlt_le_weak.
+  apply Zmult_gt_0_lt_reg_r with z; trivial.
+  intros; apply Zeq_le.
+  apply Zmult_reg_r with z.
   intro. rewrite H0 in Hz. contradiction (Zgt_irrefl 0).
-assumption.
+  assumption.
 Qed.
 
 Lemma Zmult_lt_0_le_reg_r : forall n m p:Z, 0 < p -> n * p <= m * p -> n <= m.
-intros x y z; intros; apply Zmult_le_reg_r with z.
-try apply Zlt_gt; assumption.
-assumption.
+Proof.
+  intros x y z; intros; apply Zmult_le_reg_r with z.
+  try apply Zlt_gt; assumption.
+  assumption.
 Qed.
 
 
 Lemma Zmult_ge_reg_r : forall n m p:Z, p > 0 -> n * p >= m * p -> n >= m.
-intros a b c H1 H2; apply Zle_ge; apply Zmult_le_reg_r with c; trivial.
-apply Zge_le; trivial.
+Proof.
+  intros a b c H1 H2; apply Zle_ge; apply Zmult_le_reg_r with c; trivial.
+  apply Zge_le; trivial.
 Qed.
 
 Lemma Zmult_gt_reg_r : forall n m p:Z, p > 0 -> n * p > m * p -> n > m.
-intros a b c H1 H2; apply Zlt_gt; apply Zmult_gt_0_lt_reg_r with c; trivial.
-apply Zgt_lt; trivial.
+Proof.
+  intros a b c H1 H2; apply Zlt_gt; apply Zmult_gt_0_lt_reg_r with c; trivial.
+  apply Zgt_lt; trivial.
 Qed.
 
 
@@ -830,142 +846,156 @@ Qed.
 
 Lemma Zmult_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n * m.
 Proof.
-intros x y; case x.
-intros; rewrite Zmult_0_l; trivial.
-intros p H1; unfold Zle in |- *.
+  intros x y; case x.
+  intros; rewrite Zmult_0_l; trivial.
+  intros p H1; unfold Zle in |- *.
   pattern 0 at 2 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
   rewrite Zcompare_mult_compat; trivial.
-intros p H1 H2; absurd (0 > Zneg p); trivial.
-unfold Zgt in |- *; simpl in |- *; auto with zarith.
+  intros p H1 H2; absurd (0 > Zneg p); trivial.
+  unfold Zgt in |- *; simpl in |- *; auto with zarith.
 Qed.
 
 Lemma Zmult_gt_0_compat : forall n m:Z, n > 0 -> m > 0 -> n * m > 0.
 Proof.
-intros x y; case x.
-intros H; discriminate H.
-intros p H1; unfold Zgt in |- *; pattern 0 at 2 in |- *;
- rewrite <- (Zmult_0_r (Zpos p)).
+  intros x y; case x.
+  intros H; discriminate H.
+  intros p H1; unfold Zgt in |- *; pattern 0 at 2 in |- *;
+    rewrite <- (Zmult_0_r (Zpos p)).
   rewrite Zcompare_mult_compat; trivial.
-intros p H; discriminate H.
+  intros p H; discriminate H.
 Qed.
 
 Lemma Zmult_lt_0_compat : forall n m:Z, 0 < n -> 0 < m -> 0 < n * m.
-intros a b apos bpos.
-apply Zgt_lt.
-apply Zmult_gt_0_compat; try apply Zlt_gt; assumption.
+Proof.
+  intros a b apos bpos.
+  apply Zgt_lt.
+  apply Zmult_gt_0_compat; try apply Zlt_gt; assumption.
 Qed.
 
-(* For compatibility *)
+(** For compatibility *)
 Notation Zmult_lt_O_compat := Zmult_lt_0_compat (only parsing).
 
 Lemma Zmult_gt_0_le_0_compat : forall n m:Z, n > 0 -> 0 <= m -> 0 <= m * n.
 Proof.
-intros x y H1 H2; apply Zmult_le_0_compat; trivial.
-apply Zlt_le_weak; apply Zgt_lt; trivial.
+  intros x y H1 H2; apply Zmult_le_0_compat; trivial.
+  apply Zlt_le_weak; apply Zgt_lt; trivial.
 Qed.
 
 (** Simplification of multiplication by a positive wrt to being positive *)
 
 Lemma Zmult_le_0_reg_r : forall n m:Z, n > 0 -> 0 <= m * n -> 0 <= m.
 Proof.
-intros x y; case x;
- [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
- | intros p H1; unfold Zle in |- *; rewrite Zmult_comm;
-    pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
-    rewrite Zcompare_mult_compat; auto with arith
- | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
+  intros x y; case x;
+    [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
+      | intros p H1; unfold Zle in |- *; rewrite Zmult_comm;
+	pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
+	  rewrite Zcompare_mult_compat; auto with arith
+      | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
 Qed.
 
 Lemma Zmult_gt_0_lt_0_reg_r : forall n m:Z, n > 0 -> 0 < m * n -> 0 < m.
 Proof.
-intros x y; case x;
- [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
- | intros p H1; unfold Zlt in |- *; rewrite Zmult_comm;
-    pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
-    rewrite Zcompare_mult_compat; auto with arith
- | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
+  intros x y; case x;
+    [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
+      | intros p H1; unfold Zlt in |- *; rewrite Zmult_comm;
+	pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
+	  rewrite Zcompare_mult_compat; auto with arith
+      | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
 Qed.
 
 Lemma Zmult_lt_0_reg_r : forall n m:Z, 0 < n -> 0 < m * n -> 0 < m.
 Proof.
-intros x y; intros; eapply Zmult_gt_0_lt_0_reg_r with x; try apply Zlt_gt;
- assumption.
+  intros x y; intros; eapply Zmult_gt_0_lt_0_reg_r with x; try apply Zlt_gt;
+    assumption.
 Qed.
 
 Lemma Zmult_gt_0_reg_l : forall n m:Z, n > 0 -> n * m > 0 -> m > 0.
 Proof.
-intros x y; case x.
- intros H; discriminate H.
- intros p H1; unfold Zgt in |- *.
- pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
- rewrite Zcompare_mult_compat; trivial.
-intros p H; discriminate H.
+  intros x y; case x.
+  intros H; discriminate H.
+  intros p H1; unfold Zgt in |- *.
+  pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
+  rewrite Zcompare_mult_compat; trivial.
+  intros p H; discriminate H.
 Qed.
 
+(** ** Square *)
 (** Simplification of square wrt order *)
 
 Lemma Zgt_square_simpl :
- forall n m:Z, n >= 0 -> m >= 0 -> n * n > m * m -> n > m.
+  forall n m:Z, n >= 0 -> n * n > m * m -> n > m.
 Proof.
-intros x y H0 H1 H2.
-case (dec_Zlt y x).
-intro; apply Zlt_gt; trivial.
-intros H3; cut (y >= x).
-intros H.
-elim Zgt_not_le with (1 := H2).
-apply Zge_le.
-apply Zmult_ge_compat; auto.
-apply Znot_lt_ge; trivial.
+  intros n m H0 H1.
+  case (dec_Zlt m n).
+  intro; apply Zlt_gt; trivial.
+  intros H2; cut (m >= n).
+  intros H.
+  elim Zgt_not_le with (1 := H1).
+  apply Zge_le.
+  apply Zmult_ge_compat; auto.
+  apply Znot_lt_ge; trivial.
 Qed.
 
 Lemma Zlt_square_simpl :
- forall n m:Z, 0 <= n -> 0 <= m -> m * m < n * n -> m < n.
+  forall n m:Z, 0 <= n -> m * m < n * n -> m < n.
 Proof.
-intros x y H0 H1 H2.
-apply Zgt_lt.
-apply Zgt_square_simpl; try apply Zle_ge; try apply Zlt_gt; assumption.
+  intros x y H0 H1.
+  apply Zgt_lt.
+  apply Zgt_square_simpl; try apply Zle_ge; try apply Zlt_gt; assumption.
 Qed.
 
-(** Equivalence between inequalities *)
+(** * Equivalence between inequalities *)
 
 Lemma Zle_plus_swap : forall n m p:Z, n + p <= m <-> n <= m - p.
 Proof.
-    intros x y z; intros. split. intro. rewrite <- (Zplus_0_r x). rewrite <- (Zplus_opp_r z).
-    rewrite Zplus_assoc. exact (Zplus_le_compat_r _ _ _ H).
-    intro. rewrite <- (Zplus_0_r y). rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc.
-    apply Zplus_le_compat_r. assumption.
+  intros x y z; intros. split. intro. rewrite <- (Zplus_0_r x). rewrite <- (Zplus_opp_r z).
+  rewrite Zplus_assoc. exact (Zplus_le_compat_r _ _ _ H).
+  intro. rewrite <- (Zplus_0_r y). rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc.
+  apply Zplus_le_compat_r. assumption.
 Qed.
 
 Lemma Zlt_plus_swap : forall n m p:Z, n + p < m <-> n < m - p.
 Proof.
-    intros x y z; intros. split. intro. unfold Zminus in |- *. rewrite Zplus_comm. rewrite <- (Zplus_0_l x).
-    rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm.
-    assumption.
-    intro. rewrite Zplus_comm. rewrite <- (Zplus_0_l y). rewrite <- (Zplus_opp_r z).
-    rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm. assumption.
+  intros x y z; intros. split. intro. unfold Zminus in |- *. rewrite Zplus_comm. rewrite <- (Zplus_0_l x).
+  rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm.
+  assumption.
+  intro. rewrite Zplus_comm. rewrite <- (Zplus_0_l y). rewrite <- (Zplus_opp_r z).
+  rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm. assumption.
 Qed.
 
 Lemma Zeq_plus_swap : forall n m p:Z, n + p = m <-> n = m - p.
 Proof.
-intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry  in |- *. rewrite Zplus_comm. 
+  intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry  in |- *. rewrite Zplus_comm. 
   assumption.
-intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. 
+  intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. 
   rewrite Zplus_opp_l. apply Zplus_0_r.
 Qed.
 
 Lemma Zlt_minus_simpl_swap : forall n m:Z, 0 < m -> n - m < n.
 Proof.
-intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus;
- pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); 
- rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; 
- assumption.
+  intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus;
+    pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); 
+      rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; 
+	assumption.
 Qed.
 
 Lemma Zlt_0_minus_lt : forall n m:Z, 0 < n - m -> m < n.
 Proof.
-intros n m H; apply Zplus_lt_reg_l with (p := - m); rewrite Zplus_opp_l;
- rewrite Zplus_comm; exact H.
+  intros n m H; apply Zplus_lt_reg_l with (p := - m); rewrite Zplus_opp_l;
+    rewrite Zplus_comm; exact H.
+Qed.
+
+Lemma Zle_0_minus_le : forall n m:Z, 0 <= n - m -> m <= n.
+Proof.
+  intros n m H; apply Zplus_le_reg_l with (p := - m); rewrite Zplus_opp_l;
+    rewrite Zplus_comm; exact H.
+Qed.
+
+Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m.
+Proof.
+  intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m); 
+    rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. 
 Qed.
 
-(* For compatibility *)
+(** For compatibility *)
 Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing).
diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v
new file mode 100644
index 00000000..b0f372de
--- /dev/null
+++ b/theories/ZArith/Zpow_def.v
@@ -0,0 +1,27 @@
+Require Import ZArith_base.
+Require Import Ring_theory.
+
+Open Local Scope Z_scope.
+ 
+(** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary
+      integer (type [positive]) and [z] a signed integer (type [Z]) *) 
+Definition Zpower_pos (z:Z) (n:positive) := iter_pos n Z (fun x:Z => z * x) 1.
+  
+Definition Zpower (x y:Z) :=
+    match y with
+      | Zpos p => Zpower_pos x p
+      | Z0 => 1
+      | Zneg p => 0
+    end.
+
+Lemma Zpower_theory : power_theory 1 Zmult (eq (A:=Z)) Z_of_N Zpower.
+Proof.
+ constructor. intros.
+ destruct n;simpl;trivial.
+ unfold Zpower_pos.
+ assert (forall k, iter_pos p Z (fun x : Z => r * x) k = pow_pos Zmult r p*k).
+ induction p;simpl;intros;repeat rewrite IHp;trivial;
+   repeat rewrite Zmult_assoc;trivial.
+ rewrite H;rewrite Zmult_1_r;trivial.
+Qed.
+ 
diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v
index e5bf8b04..c9cee31d 100644
--- a/theories/ZArith/Zpower.v
+++ b/theories/ZArith/Zpower.v
@@ -6,90 +6,82 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: Zpower.v,v 1.11.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+(*i $Id: Zpower.v 9551 2007-01-29 15:13:35Z bgregoir $ i*)
 
 Require Import ZArith_base.
+Require Export Zpow_def.
 Require Import Omega.
 Require Import Zcomplements.
 Open Local Scope Z_scope.
 
 Section section1.
 
+(** * Definition of powers over [Z]*)
+
 (** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary
     integer (type [nat]) and [z] a signed integer (type [Z]) *) 
 
-Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1.
-
-(** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for
-    [plus : nat->nat] and [Zmult : Z->Z] *)
-
-Lemma Zpower_nat_is_exp :
- forall (n m:nat) (z:Z),
-   Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m.
-
-intros; elim n;
- [ simpl in |- *; elim (Zpower_nat z m); auto with zarith
- | unfold Zpower_nat in |- *; intros; simpl in |- *; rewrite H;
-    apply Zmult_assoc ].
-Qed.
-
-(** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary
-    integer (type [positive]) and [z] a signed integer (type [Z]) *) 
-
-Definition Zpower_pos (z:Z) (n:positive) := iter_pos n Z (fun x:Z => z * x) 1.
-
-(** This theorem shows that powers of unary and binary integers
-   are the same thing, modulo the function convert : [positive -> nat] *)
-
-Theorem Zpower_pos_nat :
- forall (z:Z) (p:positive), Zpower_pos z p = Zpower_nat z (nat_of_P p).
-
-intros; unfold Zpower_pos in |- *; unfold Zpower_nat in |- *;
- apply iter_nat_of_P.
-Qed.
-
-(** Using the theorem [Zpower_pos_nat] and the lemma [Zpower_nat_is_exp] we
-   deduce that the function [[n:positive](Zpower_pos z n)] is a morphism
-   for [add : positive->positive] and [Zmult : Z->Z] *)
-
-Theorem Zpower_pos_is_exp :
- forall (n m:positive) (z:Z),
-   Zpower_pos z (n + m) = Zpower_pos z n * Zpower_pos z m.
-
-intros.
-rewrite (Zpower_pos_nat z n).
-rewrite (Zpower_pos_nat z m).
-rewrite (Zpower_pos_nat z (n + m)).
-rewrite (nat_of_P_plus_morphism n m).
-apply Zpower_nat_is_exp.
-Qed.
-
-Definition Zpower (x y:Z) :=
-  match y with
-  | Zpos p => Zpower_pos x p
-  | Z0 => 1
-  | Zneg p => 0
-  end.
-
-Infix "^" := Zpower : Z_scope.
-
-Hint Immediate Zpower_nat_is_exp: zarith.
-Hint Immediate Zpower_pos_is_exp: zarith.
-Hint Unfold Zpower_pos: zarith.
-Hint Unfold Zpower_nat: zarith.
-
-Lemma Zpower_exp :
- forall x n m:Z, n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m.
-destruct n; destruct m; auto with zarith.
-simpl in |- *; intros; apply Zred_factor0.
-simpl in |- *; auto with zarith.
-intros; compute in H0; absurd (Datatypes.Lt = Datatypes.Lt); auto with zarith.
-intros; compute in H0; absurd (Datatypes.Lt = Datatypes.Lt); auto with zarith.
-Qed.
+  Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1.
+
+  (** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for
+      [plus : nat->nat] and [Zmult : Z->Z] *)
+
+  Lemma Zpower_nat_is_exp :
+    forall (n m:nat) (z:Z),
+      Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m.
+  Proof.
+    intros; elim n;
+      [ simpl in |- *; elim (Zpower_nat z m); auto with zarith
+	| unfold Zpower_nat in |- *; intros; simpl in |- *; rewrite H;
+	  apply Zmult_assoc ].
+  Qed.
+
+  (** This theorem shows that powers of unary and binary integers
+     are the same thing, modulo the function convert : [positive -> nat] *)
+
+  Theorem Zpower_pos_nat :
+    forall (z:Z) (p:positive), Zpower_pos z p = Zpower_nat z (nat_of_P p).
+  Proof.
+    intros; unfold Zpower_pos in |- *; unfold Zpower_nat in |- *;
+      apply iter_nat_of_P.
+  Qed.
+
+  (** Using the theorem [Zpower_pos_nat] and the lemma [Zpower_nat_is_exp] we
+     deduce that the function [[n:positive](Zpower_pos z n)] is a morphism
+     for [add : positive->positive] and [Zmult : Z->Z] *)
+
+  Theorem Zpower_pos_is_exp :
+    forall (n m:positive) (z:Z),
+      Zpower_pos z (n + m) = Zpower_pos z n * Zpower_pos z m.
+  Proof.
+    intros.
+    rewrite (Zpower_pos_nat z n).
+    rewrite (Zpower_pos_nat z m).
+    rewrite (Zpower_pos_nat z (n + m)).
+    rewrite (nat_of_P_plus_morphism n m).
+    apply Zpower_nat_is_exp.
+  Qed.
+
+  Infix "^" := Zpower : Z_scope.
+
+  Hint Immediate Zpower_nat_is_exp: zarith.
+  Hint Immediate Zpower_pos_is_exp: zarith.
+  Hint Unfold Zpower_pos: zarith.
+  Hint Unfold Zpower_nat: zarith.
+
+  Lemma Zpower_exp :
+    forall x n m:Z, n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m.
+  Proof.
+    destruct n; destruct m; auto with zarith.
+    simpl in |- *; intros; apply Zred_factor0.
+    simpl in |- *; auto with zarith.
+    intros; compute in H0; absurd (Datatypes.Lt = Datatypes.Lt); auto with zarith.
+    intros; compute in H0; absurd (Datatypes.Lt = Datatypes.Lt); auto with zarith.
+  Qed.
 
 End section1.
 
-(* Exporting notation "^" *)
+(** Exporting notation "^" *)
 
 Infix "^" := Zpower : Z_scope.
 
@@ -100,273 +92,283 @@ Hint Unfold Zpower_nat: zarith.
 
 Section Powers_of_2.
 
-(** For the powers of two, that will be widely used, a more direct
-   calculus is possible. We will also prove some properties such
-   as [(x:positive) x < 2^x] that are true for all integers bigger
-   than 2 but more difficult to prove and useless. *)     
-
-(** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *)
-
-Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. 
-Definition shift_pos (n z:positive) := iter_pos n positive xO z. 
-Definition shift (n:Z) (z:positive) :=
-  match n with
-  | Z0 => z
-  | Zpos p => iter_pos p positive xO z
-  | Zneg p => z
-  end.
-
-Definition two_power_nat (n:nat) := Zpos (shift_nat n 1).
-Definition two_power_pos (x:positive) := Zpos (shift_pos x 1).
-
-Lemma two_power_nat_S :
- forall n:nat, two_power_nat (S n) = 2 * two_power_nat n.
-intro; simpl in |- *; apply refl_equal.
-Qed.
-
-Lemma shift_nat_plus :
- forall (n m:nat) (x:positive),
-   shift_nat (n + m) x = shift_nat n (shift_nat m x).
-
-intros; unfold shift_nat in |- *; apply iter_nat_plus.
-Qed.
-
-Theorem shift_nat_correct :
- forall (n:nat) (x:positive), Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x.
-
-unfold shift_nat in |- *; simple induction n;
- [ simpl in |- *; trivial with zarith
- | intros; replace (Zpower_nat 2 (S n0)) with (2 * Zpower_nat 2 n0);
-    [ rewrite <- Zmult_assoc; rewrite <- (H x); simpl in |- *; reflexivity
-    | auto with zarith ] ].
-Qed.
-
-Theorem two_power_nat_correct :
- forall n:nat, two_power_nat n = Zpower_nat 2 n.
-
-intro n.
-unfold two_power_nat in |- *.
-rewrite (shift_nat_correct n).
-omega.
-Qed.
+  (** * Powers of 2 *)
+
+  (** For the powers of two, that will be widely used, a more direct
+      calculus is possible. We will also prove some properties such
+      as [(x:positive) x < 2^x] that are true for all integers bigger
+      than 2 but more difficult to prove and useless. *)     
+
+  (** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *)
+
+  Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. 
+  Definition shift_pos (n z:positive) := iter_pos n positive xO z. 
+  Definition shift (n:Z) (z:positive) :=
+    match n with
+      | Z0 => z
+      | Zpos p => iter_pos p positive xO z
+      | Zneg p => z
+    end.
+
+  Definition two_power_nat (n:nat) := Zpos (shift_nat n 1).
+  Definition two_power_pos (x:positive) := Zpos (shift_pos x 1).
+
+  Lemma two_power_nat_S :
+    forall n:nat, two_power_nat (S n) = 2 * two_power_nat n.
+  Proof.
+    intro; simpl in |- *; apply refl_equal.
+  Qed.
+
+  Lemma shift_nat_plus :
+    forall (n m:nat) (x:positive),
+      shift_nat (n + m) x = shift_nat n (shift_nat m x).
+  Proof.
+    intros; unfold shift_nat in |- *; apply iter_nat_plus.
+  Qed.
+
+  Theorem shift_nat_correct :
+    forall (n:nat) (x:positive), Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x.
+  Proof.
+    unfold shift_nat in |- *; simple induction n;
+      [ simpl in |- *; trivial with zarith
+	| intros; replace (Zpower_nat 2 (S n0)) with (2 * Zpower_nat 2 n0);
+	  [ rewrite <- Zmult_assoc; rewrite <- (H x); simpl in |- *; reflexivity
+	    | auto with zarith ] ].
+  Qed.
+
+  Theorem two_power_nat_correct :
+    forall n:nat, two_power_nat n = Zpower_nat 2 n.
+  Proof.
+    intro n.
+    unfold two_power_nat in |- *.
+    rewrite (shift_nat_correct n).
+    omega.
+  Qed.
+  
+  (** Second we show that [two_power_pos] and [two_power_nat] are the same *)
+  Lemma shift_pos_nat :
+    forall p x:positive, shift_pos p x = shift_nat (nat_of_P p) x.
+  Proof.
+    unfold shift_pos in |- *.
+    unfold shift_nat in |- *.
+    intros; apply iter_nat_of_P.
+  Qed.
+
+  Lemma two_power_pos_nat :
+    forall p:positive, two_power_pos p = two_power_nat (nat_of_P p).
+  Proof.
+    intro; unfold two_power_pos in |- *; unfold two_power_nat in |- *.
+    apply f_equal with (f := Zpos).
+    apply shift_pos_nat.
+  Qed.
+
+  (** Then we deduce that [two_power_pos] is also correct *)
+
+  Theorem shift_pos_correct :
+    forall p x:positive, Zpos (shift_pos p x) = Zpower_pos 2 p * Zpos x.
+  Proof.
+    intros.
+    rewrite (shift_pos_nat p x).
+    rewrite (Zpower_pos_nat 2 p).
+    apply shift_nat_correct.
+  Qed.
+
+  Theorem two_power_pos_correct :
+    forall x:positive, two_power_pos x = Zpower_pos 2 x.
+  Proof.
+    intro.
+    rewrite two_power_pos_nat.
+    rewrite Zpower_pos_nat.
+    apply two_power_nat_correct.
+  Qed.
+
+  (** Some consequences *)
+
+  Theorem two_power_pos_is_exp :
+    forall x y:positive,
+      two_power_pos (x + y) = two_power_pos x * two_power_pos y.
+  Proof.
+    intros.
+    rewrite (two_power_pos_correct (x + y)).
+    rewrite (two_power_pos_correct x).
+    rewrite (two_power_pos_correct y).
+    apply Zpower_pos_is_exp.
+  Qed.
+
+  (** The exponentiation [z -> 2^z] for [z] a signed integer. 
+      For convenience, we assume that [2^z = 0] for all [z < 0]
+      We could also define a inductive type [Log_result] with
+      3 contructors [ Zero | Pos positive -> | minus_infty]
+      but it's more complexe and not so useful. *)
   
-(** Second we show that [two_power_pos] and [two_power_nat] are the same *)
-Lemma shift_pos_nat :
- forall p x:positive, shift_pos p x = shift_nat (nat_of_P p) x.
-
-unfold shift_pos in |- *.
-unfold shift_nat in |- *.
-intros; apply iter_nat_of_P.
-Qed.
-
-Lemma two_power_pos_nat :
- forall p:positive, two_power_pos p = two_power_nat (nat_of_P p).
-
-intro; unfold two_power_pos in |- *; unfold two_power_nat in |- *.
-apply f_equal with (f := Zpos).
-apply shift_pos_nat.
-Qed.
-
-(** Then we deduce that [two_power_pos] is also correct *)
-
-Theorem shift_pos_correct :
- forall p x:positive, Zpos (shift_pos p x) = Zpower_pos 2 p * Zpos x.
-
-intros.
-rewrite (shift_pos_nat p x).
-rewrite (Zpower_pos_nat 2 p).
-apply shift_nat_correct.
-Qed.
-
-Theorem two_power_pos_correct :
- forall x:positive, two_power_pos x = Zpower_pos 2 x.
-
-intro.
-rewrite two_power_pos_nat.
-rewrite Zpower_pos_nat.
-apply two_power_nat_correct.
-Qed.
-
-(** Some consequences *)
-
-Theorem two_power_pos_is_exp :
- forall x y:positive,
-   two_power_pos (x + y) = two_power_pos x * two_power_pos y.
-intros.
-rewrite (two_power_pos_correct (x + y)).
-rewrite (two_power_pos_correct x).
-rewrite (two_power_pos_correct y).
-apply Zpower_pos_is_exp.
-Qed.
-
-(** The exponentiation [z -> 2^z] for [z] a signed integer. 
-    For convenience, we assume that [2^z = 0] for all [z < 0]
-    We could also define a inductive type [Log_result] with
-    3 contructors [ Zero | Pos positive -> | minus_infty]
-    but it's more complexe and not so useful. *)
- 
-Definition two_p (x:Z) :=
-  match x with
-  | Z0 => 1
-  | Zpos y => two_power_pos y
-  | Zneg y => 0
-  end.
-
-Theorem two_p_is_exp :
- forall x y:Z, 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y.
-simple induction x;
- [ simple induction y; simpl in |- *; auto with zarith
- | simple induction y;
-    [ unfold two_p in |- *; rewrite (Zmult_comm (two_power_pos p) 1);
-       rewrite (Zmult_1_l (two_power_pos p)); auto with zarith
-    | unfold Zplus in |- *; unfold two_p in |- *; intros;
-       apply two_power_pos_is_exp
-    | intros; unfold Zle in H0; unfold Zcompare in H0;
-       absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ]
- | simple induction y;
-    [ simpl in |- *; auto with zarith
-    | intros; unfold Zle in H; unfold Zcompare in H;
-       absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith
-    | intros; unfold Zle in H; unfold Zcompare in H;
-       absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ] ].
-Qed.
-
-Lemma two_p_gt_ZERO : forall x:Z, 0 <= x -> two_p x > 0.
-simple induction x; intros;
- [ simpl in |- *; omega
- | simpl in |- *; unfold two_power_pos in |- *; apply Zorder.Zgt_pos_0
- | absurd (0 <= Zneg p);
-    [ simpl in |- *; unfold Zle in |- *; unfold Zcompare in |- *;
-       do 2 unfold not in |- *; auto with zarith
-    | assumption ] ].
-Qed.
-
-Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x.
-intros; unfold Zsucc in |- *. 
-rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)).
-apply Zmult_comm.
-Qed.
-
-Lemma two_p_pred : forall x:Z, 0 <= x -> two_p (Zpred x) < two_p x.
-intros; apply natlike_ind with (P := fun x:Z => two_p (Zpred x) < two_p x);
- [ simpl in |- *; unfold Zlt in |- *; auto with zarith
- | intros; elim (Zle_lt_or_eq 0 x0 H0);
-    [ intros;
-       replace (two_p (Zpred (Zsucc x0))) with (two_p (Zsucc (Zpred x0)));
-       [ rewrite (two_p_S (Zpred x0));
-          [ rewrite (two_p_S x0); [ omega | assumption ]
-          | apply Zorder.Zlt_0_le_0_pred; assumption ]
-       | rewrite <- (Zsucc_pred x0); rewrite <- (Zpred_succ x0);
-          trivial with zarith ]
-    | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *;
-       auto with zarith ]
- | assumption ].
-Qed. 
-
-Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y.
-intros; omega. Qed. 
-
-End Powers_of_2.
+  Definition two_p (x:Z) :=
+    match x with
+      | Z0 => 1
+      | Zpos y => two_power_pos y
+      | Zneg y => 0
+    end.
+
+  Theorem two_p_is_exp :
+    forall x y:Z, 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y.
+  Proof.
+    simple induction x;
+      [ simple induction y; simpl in |- *; auto with zarith
+	| simple induction y;
+	  [ unfold two_p in |- *; rewrite (Zmult_comm (two_power_pos p) 1);
+	    rewrite (Zmult_1_l (two_power_pos p)); auto with zarith
+	    | unfold Zplus in |- *; unfold two_p in |- *; intros;
+	      apply two_power_pos_is_exp
+	    | intros; unfold Zle in H0; unfold Zcompare in H0;
+	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ]
+	| simple induction y;
+	  [ simpl in |- *; auto with zarith
+	    | intros; unfold Zle in H; unfold Zcompare in H;
+	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith
+	    | intros; unfold Zle in H; unfold Zcompare in H;
+	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ] ].
+  Qed.
+
+  Lemma two_p_gt_ZERO : forall x:Z, 0 <= x -> two_p x > 0.
+  Proof.
+    simple induction x; intros;
+      [ simpl in |- *; omega
+	| simpl in |- *; unfold two_power_pos in |- *; apply Zorder.Zgt_pos_0
+	| absurd (0 <= Zneg p);
+	  [ simpl in |- *; unfold Zle in |- *; unfold Zcompare in |- *;
+	    do 2 unfold not in |- *; auto with zarith
+	    | assumption ] ].
+  Qed.
+
+  Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x.
+  Proof.
+    intros; unfold Zsucc in |- *. 
+    rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)).
+    apply Zmult_comm.
+  Qed.
+
+  Lemma two_p_pred : forall x:Z, 0 <= x -> two_p (Zpred x) < two_p x.
+  Proof.
+    intros; apply natlike_ind with (P := fun x:Z => two_p (Zpred x) < two_p x);
+      [ simpl in |- *; unfold Zlt in |- *; auto with zarith
+	| intros; elim (Zle_lt_or_eq 0 x0 H0);
+	  [ intros;
+	    replace (two_p (Zpred (Zsucc x0))) with (two_p (Zsucc (Zpred x0)));
+	      [ rewrite (two_p_S (Zpred x0));
+		[ rewrite (two_p_S x0); [ omega | assumption ]
+		  | apply Zorder.Zlt_0_le_0_pred; assumption ]
+		| rewrite <- (Zsucc_pred x0); rewrite <- (Zpred_succ x0);
+		  trivial with zarith ]
+	    | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *;
+	      auto with zarith ]
+	| assumption ].
+  Qed. 
+
+  Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y.
+    intros; omega. Qed. 
+
+  End Powers_of_2.
 
 Hint Resolve two_p_gt_ZERO: zarith.
 Hint Immediate two_p_pred two_p_S: zarith.
 
 Section power_div_with_rest.
 
-(** Division by a power of two.
-    To [n:Z] and [p:positive], [q],[r] are associated such that
-    [n = 2^p.q + r] and [0 <= r < 2^p] *)
-
-(** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<= r < d /\ 0 <= r' < d'] *)
-Definition Zdiv_rest_aux (qrd:Z * Z * Z) :=
-  let (qr, d) := qrd in
-  let (q, r) := qr in
-  (match q with
-   | Z0 => (0, r)
-   | Zpos xH => (0, d + r)
-   | Zpos (xI n) => (Zpos n, d + r)
-   | Zpos (xO n) => (Zpos n, r)
-   | Zneg xH => (-1, d + r)
-   | Zneg (xI n) => (Zneg n - 1, d + r)
-   | Zneg (xO n) => (Zneg n, r)
-   end, 2 * d).
-
-Definition Zdiv_rest (x:Z) (p:positive) :=
-  let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in qr.
-
-Lemma Zdiv_rest_correct1 :
- forall (x:Z) (p:positive),
-   let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p.
-
-intros x p; rewrite (iter_nat_of_P p _ Zdiv_rest_aux (x, 0, 1));
- rewrite (two_power_pos_nat p); elim (nat_of_P p); 
- simpl in |- *;
- [ trivial with zarith
- | intro n; rewrite (two_power_nat_S n); unfold Zdiv_rest_aux at 2 in |- *;
-    elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); 
-    destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z);
-    assumption ]. 
-Qed.
-
-Lemma Zdiv_rest_correct2 :
- forall (x:Z) (p:positive),
-   let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in
-   let (q, r) := qr in x = q * d + r /\ 0 <= r < d.
-
-intros;
- apply iter_pos_invariant with
-  (f := Zdiv_rest_aux)
-  (Inv := fun qrd:Z * Z * Z =>
-            let (qr, d) := qrd in
+  (** * Division by a power of two. *)
+
+  (** To [n:Z] and [p:positive], [q],[r] are associated such that
+      [n = 2^p.q + r] and [0 <= r < 2^p] *)
+
+  (** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<= r < d /\ 0 <= r' < d'] *)
+  Definition Zdiv_rest_aux (qrd:Z * Z * Z) :=
+    let (qr, d) := qrd in
+      let (q, r) := qr in
+	(match q with
+	   | Z0 => (0, r)
+	   | Zpos xH => (0, d + r)
+	   | Zpos (xI n) => (Zpos n, d + r)
+	   | Zpos (xO n) => (Zpos n, r)
+	   | Zneg xH => (-1, d + r)
+	   | Zneg (xI n) => (Zneg n - 1, d + r)
+	   | Zneg (xO n) => (Zneg n, r)
+	 end, 2 * d).
+
+  Definition Zdiv_rest (x:Z) (p:positive) :=
+    let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in qr.
+
+  Lemma Zdiv_rest_correct1 :
+    forall (x:Z) (p:positive),
+      let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p.
+  Proof.
+    intros x p; rewrite (iter_nat_of_P p _ Zdiv_rest_aux (x, 0, 1));
+      rewrite (two_power_pos_nat p); elim (nat_of_P p); 
+	simpl in |- *;
+	  [ trivial with zarith
+	    | intro n; rewrite (two_power_nat_S n); unfold Zdiv_rest_aux at 2 in |- *;
+	      elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); 
+		destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z);
+		  assumption ]. 
+  Qed.
+
+  Lemma Zdiv_rest_correct2 :
+    forall (x:Z) (p:positive),
+      let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in
+	let (q, r) := qr in x = q * d + r /\ 0 <= r < d.
+  Proof.
+    intros;
+      apply iter_pos_invariant with
+	(f := Zdiv_rest_aux)
+	(Inv := fun qrd:Z * Z * Z =>
+          let (qr, d) := qrd in
             let (q, r) := qr in x = q * d + r /\ 0 <= r < d);
- [ intro x0; elim x0; intro y0; elim y0; intros q r d;
-    unfold Zdiv_rest_aux in |- *; elim q;
-    [ omega
-    | destruct p0;
-       [ rewrite BinInt.Zpos_xI; intro; elim H; intros; split;
-          [ rewrite H0; rewrite Zplus_assoc; rewrite Zmult_plus_distr_l;
-             rewrite Zmult_1_l; rewrite Zmult_assoc;
-             rewrite (Zmult_comm (Zpos p0) 2); apply refl_equal
-          | omega ]
-       | rewrite BinInt.Zpos_xO; intro; elim H; intros; split;
-          [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zpos p0) 2);
-             apply refl_equal
-          | omega ]
-       | omega ]
-    | destruct p0;
-       [ rewrite BinInt.Zneg_xI; unfold Zminus in |- *; intro; elim H; intros;
-          split;
-          [ rewrite H0; rewrite Zplus_assoc;
-             apply f_equal with (f := fun z:Z => z + r);
-             do 2 rewrite Zmult_plus_distr_l; rewrite Zmult_assoc;
-             rewrite (Zmult_comm (Zneg p0) 2); rewrite <- Zplus_assoc;
-             apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); 
-             omega
-          | omega ]
-       | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros;
-          split;
-          [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zneg p0) 2);
-             apply refl_equal
-          | omega ]
-       | omega ] ]
- | omega ].
-Qed.
-
-Inductive Zdiv_rest_proofs (x:Z) (p:positive) : Set :=
+	[ intro x0; elim x0; intro y0; elim y0; intros q r d;
+	  unfold Zdiv_rest_aux in |- *; elim q;
+	    [ omega
+	      | destruct p0;
+		[ rewrite BinInt.Zpos_xI; intro; elim H; intros; split;
+		  [ rewrite H0; rewrite Zplus_assoc; rewrite Zmult_plus_distr_l;
+		    rewrite Zmult_1_l; rewrite Zmult_assoc;
+		      rewrite (Zmult_comm (Zpos p0) 2); apply refl_equal
+		    | omega ]
+		  | rewrite BinInt.Zpos_xO; intro; elim H; intros; split;
+		    [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zpos p0) 2);
+		      apply refl_equal
+		      | omega ]
+		  | omega ]
+	      | destruct p0;
+		[ rewrite BinInt.Zneg_xI; unfold Zminus in |- *; intro; elim H; intros;
+		  split;
+		    [ rewrite H0; rewrite Zplus_assoc;
+		      apply f_equal with (f := fun z:Z => z + r);
+			do 2 rewrite Zmult_plus_distr_l; rewrite Zmult_assoc;
+			  rewrite (Zmult_comm (Zneg p0) 2); rewrite <- Zplus_assoc;
+			    apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); 
+			      omega
+		      | omega ]
+		  | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros;
+		    split;
+		      [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zneg p0) 2);
+			apply refl_equal
+			| omega ]
+		  | omega ] ]
+	  | omega ].
+  Qed.
+
+  Inductive Zdiv_rest_proofs (x:Z) (p:positive) : Set :=
     Zdiv_rest_proof :
-      forall q r:Z,
-        x = q * two_power_pos p + r ->
-        0 <= r -> r < two_power_pos p -> Zdiv_rest_proofs x p.
-
-Lemma Zdiv_rest_correct : forall (x:Z) (p:positive), Zdiv_rest_proofs x p.
-intros x p.
-generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p).
-elim (iter_pos p (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)).
-simple induction a.
-intros.
-elim H; intros H1 H2; clear H.
-rewrite H0 in H1; rewrite H0 in H2; elim H2; intros;
- apply Zdiv_rest_proof with (q := a0) (r := b); assumption.
-Qed.
-
-End power_div_with_rest.
\ No newline at end of file
+    forall q r:Z,
+      x = q * two_power_pos p + r ->
+      0 <= r -> r < two_power_pos p -> Zdiv_rest_proofs x p.
+
+  Lemma Zdiv_rest_correct : forall (x:Z) (p:positive), Zdiv_rest_proofs x p.
+  Proof.
+    intros x p.
+    generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p).
+    elim (iter_pos p (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)).
+    simple induction a.
+    intros.
+    elim H; intros H1 H2; clear H.
+    rewrite H0 in H1; rewrite H0 in H2; elim H2; intros;
+      apply Zdiv_rest_proof with (q := a0) (r := b); assumption.
+  Qed.
+
+End power_div_with_rest.
diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v
index 583c5828..3f475a63 100644
--- a/theories/ZArith/Zsqrt.v
+++ b/theories/ZArith/Zsqrt.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zsqrt.v,v 1.11.2.1 2004/07/16 19:31:22 herbelin Exp $ *)
+(* $Id: Zsqrt.v 9551 2007-01-29 15:13:35Z bgregoir $ *)
 
+Require Import ZArithRing.
 Require Import Omega.
 Require Export ZArith_base.
-Require Export ZArithRing.
 Open Local Scope Z_scope.
 
 (**********************************************************************)
@@ -20,73 +20,73 @@ Open Local Scope Z_scope.
     `2*(POS ...)+1`, but only when ... is not made only with xO, XI, or xH. *)
 Ltac compute_POS :=
   match goal with
-  |  |- context [(Zpos (xI ?X1))] =>
+    |  |- context [(Zpos (xI ?X1))] =>
       match constr:X1 with
-      | context [1%positive] => fail
-      | _ => rewrite (BinInt.Zpos_xI X1)
+	| context [1%positive] => fail 1
+	| _ => rewrite (BinInt.Zpos_xI X1)
       end
-  |  |- context [(Zpos (xO ?X1))] =>
+    |  |- context [(Zpos (xO ?X1))] =>
       match constr:X1 with
-      | context [1%positive] => fail
-      | _ => rewrite (BinInt.Zpos_xO X1)
+	| context [1%positive] => fail 1
+	| _ => rewrite (BinInt.Zpos_xO X1)
       end
   end.
 
 Inductive sqrt_data (n:Z) : Set :=
-    c_sqrt : forall s r:Z, n = s * s + r -> 0 <= r <= 2 * s -> sqrt_data n.
+  c_sqrt : forall s r:Z, n = s * s + r -> 0 <= r <= 2 * s -> sqrt_data n.
 
 Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p).
-refine
- (fix sqrtrempos (p:positive) : sqrt_data (Zpos p) :=
-    match p return sqrt_data (Zpos p) with
-    | xH => c_sqrt 1 1 0 _ _
-    | xO xH => c_sqrt 2 1 1 _ _
-    | xI xH => c_sqrt 3 1 2 _ _
-    | xO (xO p') =>
-        match sqrtrempos p' with
-        | c_sqrt s' r' Heq Hint =>
-            match Z_le_gt_dec (4 * s' + 1) (4 * r') with
-            | left Hle =>
-                c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1)
+  refine
+    (fix sqrtrempos (p:positive) : sqrt_data (Zpos p) :=
+      match p return sqrt_data (Zpos p) with
+	| xH => c_sqrt 1 1 0 _ _
+	| xO xH => c_sqrt 2 1 1 _ _
+	| xI xH => c_sqrt 3 1 2 _ _
+	| xO (xO p') =>
+          match sqrtrempos p' with
+            | c_sqrt s' r' Heq Hint =>
+              match Z_le_gt_dec (4 * s' + 1) (4 * r') with
+		| left Hle =>
+                  c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1)
                   (4 * r' - (4 * s' + 1)) _ _
-            | right Hgt => c_sqrt (Zpos (xO (xO p'))) (2 * s') (4 * r') _ _
-            end
-        end
-    | xO (xI p') =>
-        match sqrtrempos p' with
-        | c_sqrt s' r' Heq Hint =>
-            match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with
-            | left Hle =>
-                c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1)
+		| right Hgt => c_sqrt (Zpos (xO (xO p'))) (2 * s') (4 * r') _ _
+              end
+          end
+	| xO (xI p') =>
+          match sqrtrempos p' with
+            | c_sqrt s' r' Heq Hint =>
+              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with
+		| left Hle =>
+                  c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1)
                   (4 * r' + 2 - (4 * s' + 1)) _ _
-            | right Hgt =>
-                c_sqrt (Zpos (xO (xI p'))) (2 * s') (4 * r' + 2) _ _
-            end
-        end
-    | xI (xO p') =>
-        match sqrtrempos p' with
-        | c_sqrt s' r' Heq Hint =>
-            match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with
-            | left Hle =>
-                c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1)
+		| right Hgt =>
+                  c_sqrt (Zpos (xO (xI p'))) (2 * s') (4 * r' + 2) _ _
+              end
+          end
+	| xI (xO p') =>
+          match sqrtrempos p' with
+            | c_sqrt s' r' Heq Hint =>
+              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with
+		| left Hle =>
+                  c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1)
                   (4 * r' + 1 - (4 * s' + 1)) _ _
-            | right Hgt =>
-                c_sqrt (Zpos (xI (xO p'))) (2 * s') (4 * r' + 1) _ _
-            end
-        end
-    | xI (xI p') =>
-        match sqrtrempos p' with
-        | c_sqrt s' r' Heq Hint =>
-            match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with
-            | left Hle =>
-                c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1)
+		| right Hgt =>
+                  c_sqrt (Zpos (xI (xO p'))) (2 * s') (4 * r' + 1) _ _
+              end
+          end
+	| xI (xI p') =>
+          match sqrtrempos p' with
+            | c_sqrt s' r' Heq Hint =>
+              match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with
+		| left Hle =>
+                  c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1)
                   (4 * r' + 3 - (4 * s' + 1)) _ _
             | right Hgt =>
                 c_sqrt (Zpos (xI (xI p'))) (2 * s') (4 * r' + 3) _ _
             end
         end
     end); clear sqrtrempos; repeat compute_POS;
- try (try rewrite Heq; ring; fail); try omega.
+ try (try rewrite Heq; ring); try omega.
 Defined.
 
 (** Define with integer input, but with a strong (readable) specification. *)
@@ -94,70 +94,71 @@ Definition Zsqrt :
   forall x:Z,
     0 <= x ->
     {s : Z &  {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}.
-refine
- (fun x =>
-    match
-      x
-      return
+  refine
+    (fun x =>
+      match
+	x
+	return
         0 <= x ->
         {s : Z &  {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}
-    with
-    | Zpos p =>
-        fun h =>
-          match sqrtrempos p with
-          | c_sqrt s r Heq Hint =>
-              existS
+	with
+	| Zpos p =>
+          fun h =>
+            match sqrtrempos p with
+              | c_sqrt s r Heq Hint =>
+		existS
                 (fun s:Z =>
-                   {r : Z |
-                   Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)})
+                  {r : Z |
+                    Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)})
                 s
                 (exist
-                   (fun r:Z =>
-                      Zpos p = s * s + r /\
-                      s * s <= Zpos p < (s + 1) * (s + 1)) r _)
-          end
-    | Zneg p =>
-        fun h =>
-          False_rec
+                  (fun r:Z =>
+                    Zpos p = s * s + r /\
+                    s * s <= Zpos p < (s + 1) * (s + 1)) r _)
+            end
+	| Zneg p =>
+          fun h =>
+            False_rec
             {s : Z & 
-            {r : Z |
-            Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}}
+              {r : Z |
+		Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}}
             (h (refl_equal Datatypes.Gt))
-    | Z0 =>
-        fun h =>
-          existS
+	| Z0 =>
+          fun h =>
+            existS
             (fun s:Z =>
-               {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0
+              {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0
             (exist
                (fun r:Z => 0 = 0 * 0 + r /\ 0 * 0 <= 0 < (0 + 1) * (0 + 1)) 0
                _)
     end); try omega.
-split; [ omega | rewrite Heq; ring ((s + 1) * (s + 1)); omega ].
+ split; [ omega | rewrite Heq; ring_simplify (s*s) ((s + 1) * (s + 1)); omega ].
 Defined.
 
 (** Define a function of type Z->Z that computes the integer square root,
     but only for positive numbers, and 0 for others. *)
 Definition Zsqrt_plain (x:Z) : Z :=
   match x with
-  | Zpos p =>
+    | Zpos p =>
       match Zsqrt (Zpos p) (Zorder.Zle_0_pos p) with
-      | existS s _ => s
+	| existS s _ => s
       end
-  | Zneg p => 0
-  | Z0 => 0
+    | Zneg p => 0
+    | Z0 => 0
   end.
 
 (** A basic theorem about Zsqrt_plain *)
 Theorem Zsqrt_interval :
- forall n:Z,
-   0 <= n ->
-   Zsqrt_plain n * Zsqrt_plain n <= n <
-   (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1).
-intros x; case x.
-unfold Zsqrt_plain in |- *; omega.
-intros p; unfold Zsqrt_plain in |- *;
- case (Zsqrt (Zpos p) (Zorder.Zle_0_pos p)).
-intros s [r [Heq Hint]] Hle; assumption.
-intros p Hle; elim Hle; auto.
+  forall n:Z,
+    0 <= n ->
+    Zsqrt_plain n * Zsqrt_plain n <= n <
+    (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1).
+Proof.
+  intros x; case x.
+  unfold Zsqrt_plain in |- *; omega.
+  intros p; unfold Zsqrt_plain in |- *;
+    case (Zsqrt (Zpos p) (Zorder.Zle_0_pos p)).
+  intros s [r [Heq Hint]] Hle; assumption.
+  intros p Hle; elim Hle; auto.
 Qed.
 
diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v
index 8633986b..bd617204 100644
--- a/theories/ZArith/Zwf.v
+++ b/theories/ZArith/Zwf.v
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: Zwf.v,v 1.7.2.1 2004/07/16 19:31:22 herbelin Exp $ *)
+(* $Id: Zwf.v 9245 2006-10-17 12:53:34Z notin $ *)
 
 Require Import ZArith_base.
 Require Export Wf_nat.
@@ -26,35 +26,35 @@ Definition Zwf (c x y:Z) := c <= y /\ x < y.
 
 Section wf_proof.
 
-Variable c : Z.
-
-(** The proof of well-foundness is classic: we do the proof by induction
-    on a measure in nat, which is here [|x-c|] *)
-
-Let f (z:Z) := Zabs_nat (z - c).
-
-Lemma Zwf_well_founded : well_founded (Zwf c).
-red in |- *; intros.
-assert (forall (n:nat) (a:Z), (f a < n)%nat \/ a < c -> Acc (Zwf c) a).
-clear a; simple induction n; intros.
-(** n= 0 *)
-case H; intros.
-case (lt_n_O (f a)); auto.
-apply Acc_intro; unfold Zwf in |- *; intros.
-assert False; omega || contradiction.
-(** inductive case *)
-case H0; clear H0; intro; auto.
-apply Acc_intro; intros.
-apply H.
-unfold Zwf in H1.
-case (Zle_or_lt c y); intro; auto with zarith.
-left.
-red in H0.
-apply lt_le_trans with (f a); auto with arith.
-unfold f in |- *.
-apply Zabs.Zabs_nat_lt; omega.
-apply (H (S (f a))); auto.
-Qed.
+  Variable c : Z.
+
+  (** The proof of well-foundness is classic: we do the proof by induction
+      on a measure in nat, which is here [|x-c|] *)
+
+  Let f (z:Z) := Zabs_nat (z - c).
+
+  Lemma Zwf_well_founded : well_founded (Zwf c).
+    red in |- *; intros.
+    assert (forall (n:nat) (a:Z), (f a < n)%nat \/ a < c -> Acc (Zwf c) a).
+    clear a; simple induction n; intros.
+  (** n= 0 *)
+    case H; intros.
+    case (lt_n_O (f a)); auto.
+    apply Acc_intro; unfold Zwf in |- *; intros.
+    assert False; omega || contradiction.
+  (** inductive case *)
+    case H0; clear H0; intro; auto.
+    apply Acc_intro; intros.
+    apply H.
+    unfold Zwf in H1.
+    case (Zle_or_lt c y); intro; auto with zarith.
+    left.
+    red in H0.
+    apply lt_le_trans with (f a); auto with arith.
+    unfold f in |- *.
+    apply Zabs.Zabs_nat_lt; omega.
+    apply (H (S (f a))); auto.
+  Qed.
 
 End wf_proof.
 
@@ -72,25 +72,25 @@ Definition Zwf_up (c x y:Z) := y < x <= c.
 
 Section wf_proof_up.
 
-Variable c : Z.
+  Variable c : Z.
 
-(** The proof of well-foundness is classic: we do the proof by induction
-    on a measure in nat, which is here [|c-x|] *)
+  (** The proof of well-foundness is classic: we do the proof by induction
+      on a measure in nat, which is here [|c-x|] *)
 
-Let f (z:Z) := Zabs_nat (c - z).
+  Let f (z:Z) := Zabs_nat (c - z).
 
-Lemma Zwf_up_well_founded : well_founded (Zwf_up c).
-Proof.
-apply well_founded_lt_compat with (f := f).
-unfold Zwf_up, f in |- *.
-intros.
-apply Zabs.Zabs_nat_lt.
-unfold Zminus in |- *. split.
-apply Zle_left; intuition.
-apply Zplus_lt_compat_l; unfold Zlt in |- *; rewrite <- Zcompare_opp;
- intuition.
-Qed.
+  Lemma Zwf_up_well_founded : well_founded (Zwf_up c).
+  Proof.
+    apply well_founded_lt_compat with (f := f).
+    unfold Zwf_up, f in |- *.
+    intros.
+    apply Zabs.Zabs_nat_lt.
+    unfold Zminus in |- *. split.
+    apply Zle_left; intuition.
+    apply Zplus_lt_compat_l; unfold Zlt in |- *; rewrite <- Zcompare_opp;
+      intuition.
+  Qed.
 
 End wf_proof_up.
 
-Hint Resolve Zwf_up_well_founded: datatypes v62.
\ No newline at end of file
+Hint Resolve Zwf_up_well_founded: datatypes v62.
diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v
index ecd2daab..726fb45a 100644
--- a/theories/ZArith/auxiliary.v
+++ b/theories/ZArith/auxiliary.v
@@ -6,11 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: auxiliary.v,v 1.12.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+(*i $Id: auxiliary.v 9302 2006-10-27 21:21:17Z barras $ i*)
 
 (** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
 
-Require Export Arith.
+Require Export Arith_base.
 Require Import BinInt.
 Require Import Zorder.
 Require Import Decidable.
@@ -19,132 +19,134 @@ Require Export Compare_dec.
 
 Open Local Scope Z_scope.
 
-(**********************************************************************)
-(** Moving terms from one side to the other of an inequality *)
+(***************************************************************)
+(** * Moving terms from one side to the other of an inequality *)
 
 Theorem Zne_left : forall n m:Z, Zne n m -> Zne (n + - m) 0.
 Proof.
-intros x y; unfold Zne in |- *; unfold not in |- *; intros H1 H2; apply H1;
- apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; 
- rewrite Zplus_comm; trivial with arith.
+  intros x y; unfold Zne in |- *; unfold not in |- *; intros H1 H2; apply H1;
+    apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; 
+      rewrite Zplus_comm; trivial with arith.
 Qed.
 
 Theorem Zegal_left : forall n m:Z, n = m -> n + - m = 0.
 Proof.
-intros x y H; apply (Zplus_reg_l y); rewrite Zplus_permute;
- rewrite Zplus_opp_r; do 2 rewrite Zplus_0_r; assumption.
+  intros x y H; apply (Zplus_reg_l y); rewrite Zplus_permute;
+    rewrite Zplus_opp_r; do 2 rewrite Zplus_0_r; assumption.
 Qed.
 
 Theorem Zle_left : forall n m:Z, n <= m -> 0 <= m + - n.
 Proof.
-intros x y H; replace 0 with (x + - x).
-apply Zplus_le_compat_r; trivial.
-apply Zplus_opp_r.
+  intros x y H; replace 0 with (x + - x).
+  apply Zplus_le_compat_r; trivial.
+  apply Zplus_opp_r.
 Qed.
 
 Theorem Zle_left_rev : forall n m:Z, 0 <= m + - n -> n <= m.
 Proof.
-intros x y H; apply Zplus_le_reg_r with (- x).
-rewrite Zplus_opp_r; trivial.
+  intros x y H; apply Zplus_le_reg_r with (- x).
+  rewrite Zplus_opp_r; trivial.
 Qed.
 
 Theorem Zlt_left_rev : forall n m:Z, 0 < m + - n -> n < m.
 Proof.
-intros x y H; apply Zplus_lt_reg_r with (- x).
-rewrite Zplus_opp_r; trivial.
+  intros x y H; apply Zplus_lt_reg_r with (- x).
+  rewrite Zplus_opp_r; trivial.
 Qed.
 
 Theorem Zlt_left : forall n m:Z, n < m -> 0 <= m + -1 + - n.
 Proof.
-intros x y H; apply Zle_left; apply Zsucc_le_reg;
- change (Zsucc x <= Zsucc (Zpred y)) in |- *; rewrite <- Zsucc_pred;
- apply Zlt_le_succ; assumption.
+  intros x y H; apply Zle_left; apply Zsucc_le_reg;
+    change (Zsucc x <= Zsucc (Zpred y)) in |- *; rewrite <- Zsucc_pred;
+      apply Zlt_le_succ; assumption.
 Qed.
 
 Theorem Zlt_left_lt : forall n m:Z, n < m -> 0 < m + - n.
 Proof.
-intros x y H; replace 0 with (x + - x).
-apply Zplus_lt_compat_r; trivial.
-apply Zplus_opp_r.
+  intros x y H; replace 0 with (x + - x).
+  apply Zplus_lt_compat_r; trivial.
+  apply Zplus_opp_r.
 Qed.
 
 Theorem Zge_left : forall n m:Z, n >= m -> 0 <= n + - m.
 Proof.
-intros x y H; apply Zle_left; apply Zge_le; assumption.
+  intros x y H; apply Zle_left; apply Zge_le; assumption.
 Qed.
 
 Theorem Zgt_left : forall n m:Z, n > m -> 0 <= n + -1 + - m.
 Proof.
-intros x y H; apply Zlt_left; apply Zgt_lt; assumption.
+  intros x y H; apply Zlt_left; apply Zgt_lt; assumption.
 Qed.
 
 Theorem Zgt_left_gt : forall n m:Z, n > m -> n + - m > 0.
 Proof.
-intros x y H; replace 0 with (y + - y).
-apply Zplus_gt_compat_r; trivial.
-apply Zplus_opp_r.
+  intros x y H; replace 0 with (y + - y).
+  apply Zplus_gt_compat_r; trivial.
+  apply Zplus_opp_r.
 Qed.
 
 Theorem Zgt_left_rev : forall n m:Z, n + - m > 0 -> n > m.
 Proof.
-intros x y H; apply Zplus_gt_reg_r with (- y).
-rewrite Zplus_opp_r; trivial.
+  intros x y H; apply Zplus_gt_reg_r with (- y).
+  rewrite Zplus_opp_r; trivial.
 Qed.
 
 (**********************************************************************)
-(** Factorization lemmas *)
+(** * Factorization lemmas *)
 
 Theorem Zred_factor0 : forall n:Z, n = n * 1.
-intro x; rewrite (Zmult_1_r x); reflexivity.
+  intro x; rewrite (Zmult_1_r x); reflexivity.
 Qed.
 
 Theorem Zred_factor1 : forall n:Z, n + n = n * 2.
 Proof.
-exact Zplus_diag_eq_mult_2.
+  exact Zplus_diag_eq_mult_2.
 Qed.
 
 Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m).
-
-intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x);
- rewrite <- Zmult_plus_distr_r; trivial with arith.
+Proof.
+  intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x);
+    rewrite <- Zmult_plus_distr_r; trivial with arith.
 Qed.
 
 Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m).
-
-intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x);
- rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; 
- trivial with arith.
+Proof.
+  intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x);
+    rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; 
+      trivial with arith.
 Qed.
+
 Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p).
-intros x y z; symmetry  in |- *; apply Zmult_plus_distr_r.
+Proof.
+  intros x y z; symmetry  in |- *; apply Zmult_plus_distr_r.
 Qed.
 
 Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m.
-
-intros x y; rewrite <- Zmult_0_r_reverse; auto with arith.
+Proof.
+  intros x y; rewrite <- Zmult_0_r_reverse; auto with arith.
 Qed.
 
 Theorem Zred_factor6 : forall n:Z, n = n + 0.
-
-intro; rewrite Zplus_0_r; trivial with arith.
+Proof.
+  intro; rewrite Zplus_0_r; trivial with arith.
 Qed.
 
 Theorem Zle_mult_approx :
- forall n m p:Z, n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p.
-
-intros x y z H1 H2 H3; apply Zle_trans with (m := y * x);
- [ apply Zmult_gt_0_le_0_compat; assumption
- | pattern (y * x) at 1 in |- *; rewrite <- Zplus_0_r;
-    apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; 
-    assumption ].
+  forall n m p:Z, n > 0 -> p > 0 -> 0 <= m -> 0 <= m * n + p.
+Proof.
+  intros x y z H1 H2 H3; apply Zle_trans with (m := y * x);
+    [ apply Zmult_gt_0_le_0_compat; assumption
+      | pattern (y * x) at 1 in |- *; rewrite <- Zplus_0_r;
+	apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; 
+	  assumption ].
 Qed.
 
 Theorem Zmult_le_approx :
- forall n m p:Z, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
-
-intros x y z H1 H2 H3; apply Zlt_succ_le; apply Zmult_gt_0_lt_0_reg_r with x;
- [ assumption
- | apply Zle_lt_trans with (1 := H3); rewrite <- Zmult_succ_l_reverse;
-    apply Zplus_lt_compat_l; apply Zgt_lt; assumption ].
-
+  forall n m p:Z, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
+Proof.
+  intros x y z H1 H2 H3; apply Zlt_succ_le; apply Zmult_gt_0_lt_0_reg_r with x;
+    [ assumption
+      | apply Zle_lt_trans with (1 := H3); rewrite <- Zmult_succ_l_reverse;
+	apply Zplus_lt_compat_l; apply Zgt_lt; assumption ].
 Qed.
+
diff --git a/theories7/Arith/Between.v b/theories7/Arith/Between.v
deleted file mode 100755
index b3fef325..00000000
--- a/theories7/Arith/Between.v
+++ /dev/null
@@ -1,185 +0,0 @@
-(************************************************************************)
-(*  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: Between.v,v 1.1.2.1 2004/07/16 19:31:23 herbelin Exp $ i*)
-
-Require Le.
-Require Lt.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type k,l,p,q,r:nat.
-
-Section Between.
-Variables P,Q : nat -> Prop.
-
-Inductive between [k:nat] : nat -> Prop
- := bet_emp : (between k k)
- | bet_S : (l:nat)(between k l)->(P l)->(between k (S l)).
-
-Hint constr_between : arith v62 := Constructors between.
-
-Lemma bet_eq : (k,l:nat)(l=k)->(between k l).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-
-Hints Resolve bet_eq : arith v62.
-
-Lemma between_le : (k,l:nat)(between k l)->(le k l).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-Hints Immediate between_le : arith v62.
-
-Lemma between_Sk_l : (k,l:nat)(between k l)->(le (S k) l)->(between (S k) l).
-Proof.
-NewInduction 1.
-Intros; Absurd (le (S k) k); Auto with arith.
-NewDestruct H; Auto with arith.
-Qed.
-Hints Resolve between_Sk_l : arith v62.
-
-Lemma between_restr : 
-  (k,l,m:nat)(le k l)->(le l m)->(between k m)->(between l m).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-
-Inductive exists [k:nat] : nat -> Prop
- := exists_S : (l:nat)(exists k l)->(exists k (S l))
- | exists_le: (l:nat)(le k l)->(Q l)->(exists k (S l)).
-
-Hint constr_exists : arith v62 := Constructors exists.
-
-Lemma exists_le_S : (k,l:nat)(exists k l)->(le (S k) l).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-
-Lemma exists_lt : (k,l:nat)(exists k l)->(lt k l).
-Proof exists_le_S.
-Hints Immediate exists_le_S exists_lt : arith v62.
-
-Lemma exists_S_le : (k,l:nat)(exists k (S l))->(le k l).
-Proof.
-Intros; Apply le_S_n; Auto with arith.
-Qed.
-Hints Immediate exists_S_le : arith v62.
-
-Definition in_int := [p,q,r:nat](le p r)/\(lt r q).
-
-Lemma in_int_intro : (p,q,r:nat)(le p r)->(lt r q)->(in_int p q r).
-Proof.
-Red; Auto with arith.
-Qed.
-Hints Resolve in_int_intro : arith v62.
-
-Lemma in_int_lt : (p,q,r:nat)(in_int p q r)->(lt p q).
-Proof.
-NewInduction 1; Intros.
-Apply le_lt_trans with r; Auto with arith.
-Qed.
-
-Lemma in_int_p_Sq : 
-  (p,q,r:nat)(in_int p (S q) r)->((in_int p q r) \/ <nat>r=q).
-Proof.
-NewInduction 1; Intros.
-Elim (le_lt_or_eq r q); Auto with arith.
-Qed.
-
-Lemma in_int_S : (p,q,r:nat)(in_int p q r)->(in_int p (S q) r).
-Proof.
-NewInduction 1;Auto with arith.
-Qed.
-Hints Resolve in_int_S : arith v62.
-
-Lemma in_int_Sp_q : (p,q,r:nat)(in_int (S p) q r)->(in_int p q r).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-Hints Immediate in_int_Sp_q : arith v62.
-
-Lemma between_in_int : (k,l:nat)(between k l)->(r:nat)(in_int k l r)->(P r).
-Proof.
-NewInduction 1; Intros.
-Absurd (lt k k); Auto with arith.
-Apply in_int_lt with r; Auto with arith.
-Elim (in_int_p_Sq k l r); Intros; Auto with arith.
-Rewrite H2; Trivial with arith.
-Qed.
-
-Lemma in_int_between : 
-  (k,l:nat)(le k l)->((r:nat)(in_int k l r)->(P r))->(between k l).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-
-Lemma exists_in_int : 
-  (k,l:nat)(exists k l)->(EX m:nat | (in_int k l m) & (Q m)).
-Proof.
-NewInduction 1.
-Case IHexists; Intros p inp Qp; Exists p; Auto with arith.
-Exists l; Auto with arith.
-Qed.
-
-Lemma in_int_exists : (k,l,r:nat)(in_int k l r)->(Q r)->(exists k l).
-Proof.
-NewDestruct 1; Intros.
-Elim H0; Auto with arith.
-Qed.
-
-Lemma between_or_exists : 
-  (k,l:nat)(le k l)->((n:nat)(in_int k l n)->((P n)\/(Q n)))
-     ->((between k l)\/(exists k l)).
-Proof.
-NewInduction 1; Intros; Auto with arith.
-Elim IHle; Intro; Auto with arith.
-Elim (H0 m); Auto with arith.
-Qed.
-
-Lemma between_not_exists : (k,l:nat)(between k l)->
-     ((n:nat)(in_int k l n) -> (P n) -> ~(Q n))
-     -> ~(exists k l).
-Proof.
-NewInduction 1; Red; Intros.
-Absurd (lt k k); Auto with arith.
-Absurd (Q l); Auto with arith.
-Elim (exists_in_int k (S l)); Auto with arith; Intros l' inl' Ql'.
-Replace l with l'; Auto with arith.
-Elim inl'; Intros.
-Elim (le_lt_or_eq l' l); Auto with arith; Intros.
-Absurd (exists k l); Auto with arith.
-Apply in_int_exists with l'; Auto with arith.
-Qed.
-
-Inductive P_nth [init:nat] : nat->nat->Prop
-  := nth_O : (P_nth init init O)
-  | nth_S : (k,l:nat)(n:nat)(P_nth init k n)->(between (S k) l)
-                        ->(Q l)->(P_nth init l (S n)).
-
-Lemma nth_le : (init,l,n:nat)(P_nth init l n)->(le init l).
-Proof.
-NewInduction 1; Intros; Auto with arith.
-Apply le_trans with (S k); Auto with arith.
-Qed.
-
-Definition eventually := [n:nat](EX k:nat | (le k n) & (Q k)).
-
-Lemma event_O : (eventually O)->(Q O).
-Proof.
-NewInduction 1; Intros.
-Replace O with x; Auto with arith.
-Qed.
-
-End Between.
-
-Hints Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le 
- in_int_S in_int_intro : arith v62. 
-Hints Immediate in_int_Sp_q exists_le_S exists_S_le : arith v62.
diff --git a/theories7/Arith/Bool_nat.v b/theories7/Arith/Bool_nat.v
deleted file mode 100644
index c36f8f15..00000000
--- a/theories7/Arith/Bool_nat.v
+++ /dev/null
@@ -1,43 +0,0 @@
-(************************************************************************)
-(*  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: Bool_nat.v,v 1.1.2.1 2004/07/16 19:31:23 herbelin Exp $ *)
-
-Require Export Compare_dec.
-Require Export Peano_dec.
-Require Sumbool.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,x,y:nat.
-
-(** The decidability of equality and order relations over
-    type [nat] give some boolean functions with the adequate specification. *)
-
-Definition notzerop := [n:nat] (sumbool_not ? ? (zerop n)).
-Definition lt_ge_dec : (x,y:nat){(lt x y)}+{(ge x y)} := 
-  [n,m:nat] (sumbool_not ? ? (le_lt_dec m n)).
-
-Definition nat_lt_ge_bool := 
-  [x,y:nat](bool_of_sumbool (lt_ge_dec x y)).
-Definition nat_ge_lt_bool := 
-  [x,y:nat](bool_of_sumbool (sumbool_not ? ? (lt_ge_dec x y))).
-
-Definition nat_le_gt_bool := 
-  [x,y:nat](bool_of_sumbool (le_gt_dec x y)).
-Definition nat_gt_le_bool := 
-  [x,y:nat](bool_of_sumbool (sumbool_not ? ? (le_gt_dec x y))).
-
-Definition nat_eq_bool :=
-  [x,y:nat](bool_of_sumbool (eq_nat_dec x y)).
-Definition nat_noteq_bool := 
-  [x,y:nat](bool_of_sumbool (sumbool_not ? ? (eq_nat_dec x y))).
-
-Definition zerop_bool := [x:nat](bool_of_sumbool (zerop x)).
-Definition notzerop_bool := [x:nat](bool_of_sumbool (notzerop x)).
diff --git a/theories7/Arith/Compare.v b/theories7/Arith/Compare.v
deleted file mode 100755
index 1bca3fbe..00000000
--- a/theories7/Arith/Compare.v
+++ /dev/null
@@ -1,60 +0,0 @@
-(************************************************************************)
-(*  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: Compare.v,v 1.1.2.1 2004/07/16 19:31:23 herbelin Exp $ i*)
-
-(** Equality is decidable on [nat] *)
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-(*
-Lemma not_eq_sym : (A:Set)(p,q:A)(~p=q) -> ~(q=p).
-Proof sym_not_eq.
-Hints Immediate not_eq_sym : arith.
-*)
-Notation not_eq_sym := sym_not_eq.
-
-Implicit Variables Type m,n,p,q:nat.
-
-Require Arith.
-Require Peano_dec.
-Require Compare_dec.
-
-Definition le_or_le_S := le_le_S_dec.
-
-Definition compare := gt_eq_gt_dec.
-
-Lemma le_dec : (n,m:nat) {le n m} + {le m n}.
-Proof le_ge_dec.
-
-Definition lt_or_eq := [n,m:nat]{(gt m n)}+{n=m}.
-
-Lemma le_decide : (n,m:nat)(le n m)->(lt_or_eq n m).
-Proof le_lt_eq_dec.
-
-Lemma le_le_S_eq : (p,q:nat)(le p q)->((le (S p) q)\/(p=q)).
-Proof le_lt_or_eq.
-
-(* By special request of G. Kahn - Used in Group Theory *)
-Lemma discrete_nat : (m, n: nat) (lt m n) ->
-   (S m) = n \/ (EX r: nat | n = (S (S (plus m r)))).
-Proof.
-Intros m n H.
-LApply (lt_le_S m n); Auto with arith.
-Intro H'; LApply (le_lt_or_eq (S m) n); Auto with arith.
-NewInduction 1; Auto with arith.
-Right; Exists (minus n (S (S m))); Simpl.
-Rewrite (plus_sym m (minus n (S (S m)))).
-Rewrite (plus_n_Sm (minus n (S (S m))) m).
-Rewrite (plus_n_Sm (minus n (S (S m))) (S m)).
-Rewrite (plus_sym (minus n (S (S m))) (S (S m))); Auto with arith.
-Qed.
-
-Require Export Wf_nat.
-
-Require Export Min.
diff --git a/theories7/Arith/Compare_dec.v b/theories7/Arith/Compare_dec.v
deleted file mode 100755
index 504c0562..00000000
--- a/theories7/Arith/Compare_dec.v
+++ /dev/null
@@ -1,109 +0,0 @@
-(************************************************************************)
-(*  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: Compare_dec.v,v 1.1.2.1 2004/07/16 19:31:23 herbelin Exp $ i*)
-
-Require Le.
-Require Lt.
-Require Gt.
-Require Decidable.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,x,y:nat.
-
-Definition zerop : (n:nat){n=O}+{lt O n}.
-NewDestruct n; Auto with arith.
-Defined.
-
-Definition lt_eq_lt_dec : (n,m:nat){(lt n m)}+{n=m}+{(lt m n)}.
-Proof.
-NewInduction n; Destruct m; Auto with arith.
-Intros m0; Elim (IHn m0); Auto with arith.
-NewInduction 1; Auto with arith.
-Defined.
-
-Lemma gt_eq_gt_dec : (n,m:nat)({(gt m n)}+{n=m})+{(gt n m)}.
-Proof lt_eq_lt_dec.
-
-Lemma le_lt_dec : (n,m:nat) {le n m} + {lt m n}.
-Proof.
-NewInduction n.
-Auto with arith.
-NewInduction m.
-Auto with arith.
-Elim (IHn m); Auto with arith.
-Defined.
-
-Definition le_le_S_dec : (n,m:nat) {le n m} + {le (S m) n}.
-Proof.
-Exact le_lt_dec.
-Defined.
-
-Definition le_ge_dec : (n,m:nat) {le n m} + {ge n m}.
-Proof.
-Intros; Elim (le_lt_dec n m); Auto with arith.
-Defined.
-
-Definition le_gt_dec : (n,m:nat){(le n m)}+{(gt n m)}.
-Proof.
-Exact le_lt_dec.
-Defined.
-
-Definition le_lt_eq_dec : (n,m:nat)(le n m)->({(lt n m)}+{n=m}).
-Proof.
-Intros; Elim (lt_eq_lt_dec n m); Auto with arith.
-Intros; Absurd (lt m n); Auto with arith.
-Defined.
-
-(** Proofs of decidability *)
-
-Theorem dec_le:(x,y:nat)(decidable (le x y)).
-Intros x y; Unfold decidable ; Elim (le_gt_dec x y); [
-  Auto with arith
-| Intro; Right; Apply gt_not_le; Assumption].
-Qed.
-
-Theorem dec_lt:(x,y:nat)(decidable (lt x y)).
-Intros x y; Unfold lt; Apply dec_le.
-Qed.
-
-Theorem dec_gt:(x,y:nat)(decidable (gt x y)).
-Intros x y; Unfold gt; Apply dec_lt.
-Qed.
-
-Theorem dec_ge:(x,y:nat)(decidable (ge x y)).
-Intros x y; Unfold ge; Apply dec_le.
-Qed.
-
-Theorem not_eq : (x,y:nat) ~ x=y -> (lt x y) \/ (lt y x).
-Intros x y H; Elim (lt_eq_lt_dec x y); [
-  Intros H1; Elim H1; [ Auto with arith | Intros H2; Absurd x=y; Assumption]
-| Auto with arith].
-Qed.
-
-
-Theorem not_le : (x,y:nat) ~(le x y) -> (gt x y).
-Intros x y H; Elim (le_gt_dec x y);
-  [ Intros H1; Absurd (le x y); Assumption | Trivial with arith ].
-Qed.
-
-Theorem not_gt : (x,y:nat) ~(gt x y) -> (le x y).
-Intros x y H; Elim (le_gt_dec x y);
-  [ Trivial with arith | Intros H1; Absurd (gt x y); Assumption].
-Qed.
-
-Theorem not_ge : (x,y:nat) ~(ge x y) -> (lt x y).
-Intros x y H; Exact (not_le y x H).
-Qed.
-
-Theorem not_lt : (x,y:nat) ~(lt x y) -> (ge x y).
-Intros x y H; Exact (not_gt y x H). 
-Qed.
-
diff --git a/theories7/Arith/Div.v b/theories7/Arith/Div.v
deleted file mode 100755
index 59694628..00000000
--- a/theories7/Arith/Div.v
+++ /dev/null
@@ -1,64 +0,0 @@
-(************************************************************************)
-(*  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: Div.v,v 1.1.2.1 2004/07/16 19:31:23 herbelin Exp $ i*)
-
-(** Euclidean division *)
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Require Le.
-Require Euclid_def.
-Require Compare_dec.
-
-Implicit Variables Type n,a,b,q,r:nat.
-
-Fixpoint inf_dec [n:nat] : nat->bool :=
-      [m:nat] Cases n m of
-                  O     _     => true
-              | (S n')  O     => false
-              | (S n') (S m') => (inf_dec n' m')
-             end.
-
-Theorem div1 : (b:nat)(gt b O)->(a:nat)(diveucl a b).
-Realizer Fix div1 {div1/2: nat->nat->diveucl :=
-  [b,a]Cases a of
-         O     => (O,O)
-       | (S n) =>
-           let (q,r) = (div1 b n) in
-             if (le_gt_dec b (S r)) then ((S q),O)
-	     else (q,(S r))
-       end}.
-Program_all.
-Rewrite e.
-Replace b with (S r).
-Simpl.
-Elim plus_n_O; Auto with arith.
-Apply le_antisym; Auto with arith.
-Elim plus_n_Sm; Auto with arith.
-Qed.
-
-Theorem div2 : (b:nat)(gt b O)->(a:nat)(diveucl a b).
-Realizer Fix div1 {div1/2: nat->nat->diveucl :=
-  [b,a]Cases a of
-         O     => (O,O)
-       | (S n) =>
-           let (q,r) = (div1 b n) in
-             if (inf_dec b (S r)) :: :: { {(le b (S r))}+{(gt b (S r))} }
-             then ((S q),O)
-	     else (q,(S r))
-       end}.
-Program_all.
-Rewrite e.
-Replace b with (S r).
-Simpl.
-Elim plus_n_O; Auto with arith.
-Apply le_antisym; Auto with arith.
-Elim plus_n_Sm; Auto with arith.
-Qed.
diff --git a/theories7/Arith/Div2.v b/theories7/Arith/Div2.v
deleted file mode 100644
index 8bd0160f..00000000
--- a/theories7/Arith/Div2.v
+++ /dev/null
@@ -1,174 +0,0 @@
-(************************************************************************)
-(*  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: Div2.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-Require Lt.
-Require Plus.
-Require Compare_dec.
-Require Even.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type n:nat.
-
-(** Here we define [n/2] and prove some of its properties *)
-
-Fixpoint div2 [n:nat] : nat :=
-  Cases n of
-    O => O
-  | (S O) => O
-  | (S (S n')) => (S (div2 n'))
-  end.
-
-(** Since [div2] is recursively defined on [0], [1] and [(S (S n))], it is
-    useful to prove the corresponding induction principle *)
-
-Lemma ind_0_1_SS : (P:nat->Prop)
-  (P O) -> (P (S O)) -> ((n:nat)(P n)->(P (S (S n)))) -> (n:nat)(P n).
-Proof.
-Intros.
-Cut (n:nat)(P n)/\(P (S n)).
-Intros. Elim (H2 n). Auto with arith.
-
-NewInduction n0. Auto with arith.
-Intros. Elim IHn0; Auto with arith.
-Qed.
-
-(** [0 <n  =>  n/2 < n] *)
-
-Lemma lt_div2 : (n:nat) (lt O n) -> (lt (div2 n) n).
-Proof.
-Intro n. Pattern n. Apply ind_0_1_SS.
-Intro. Inversion H.
-Auto with arith.
-Intros. Simpl.
-Case (zerop n0).
-Intro. Rewrite e. Auto with arith.
-Auto with arith.
-Qed.
-
-Hints Resolve lt_div2 : arith.
-
-(** Properties related to the parity *)
-
-Lemma even_odd_div2 : (n:nat) 
-  ((even n)<->(div2 n)=(div2 (S n))) /\ ((odd n)<->(S (div2 n))=(div2 (S n))).
-Proof.
-Intro n. Pattern n. Apply ind_0_1_SS.
-(* n  = 0 *)
-Split. Split; Auto with arith. 
-Split. Intro H. Inversion H.
-Intro H.  Absurd (S (div2 O))=(div2 (S O)); Auto with arith.
-(* n = 1 *)
-Split. Split. Intro. Inversion H. Inversion H1.
-Intro H.  Absurd (div2 (S O))=(div2 (S (S O))).
-Simpl. Discriminate. Assumption.
-Split; Auto with arith.
-(* n = (S (S n')) *)
-Intros. Decompose [and] H. Unfold iff in H0 H1.
-Decompose [and] H0. Decompose [and] H1. Clear H H0 H1.
-Split; Split; Auto with arith.
-Intro H. Inversion H. Inversion H1.
-Change (S (div2 n0))=(S (div2 (S n0))). Auto with arith.
-Intro H. Inversion H. Inversion H1.
-Change (S (S (div2 n0)))=(S (div2 (S n0))). Auto with arith.
-Qed.
-
-(** Specializations *)
-
-Lemma even_div2 : (n:nat) (even n) -> (div2 n)=(div2 (S n)).
-Proof [n:nat](proj1 ? ? (proj1 ? ? (even_odd_div2 n))).
-
-Lemma div2_even : (n:nat) (div2 n)=(div2 (S n)) -> (even n).
-Proof [n:nat](proj2 ? ? (proj1 ? ? (even_odd_div2 n))).
-
-Lemma odd_div2 : (n:nat) (odd n) -> (S (div2 n))=(div2 (S n)).
-Proof [n:nat](proj1 ? ? (proj2 ? ? (even_odd_div2 n))).
-
-Lemma div2_odd : (n:nat) (S (div2 n))=(div2 (S n)) -> (odd n).
-Proof [n:nat](proj2 ? ? (proj2 ? ? (even_odd_div2 n))).
-
-Hints Resolve even_div2 div2_even odd_div2 div2_odd : arith.
-
-(** Properties related to the double ([2n]) *)
-
-Definition double := [n:nat](plus n n).
-
-Hints Unfold double : arith.
-
-Lemma double_S : (n:nat) (double (S n))=(S (S (double n))).
-Proof.
-Intro. Unfold double. Simpl. Auto with arith.
-Qed.
-
-Lemma double_plus : (m,n:nat) (double (plus m n))=(plus (double m) (double n)).
-Proof.
-Intros m n. Unfold double.
-Do 2 Rewrite -> plus_assoc_r. Rewrite -> (plus_permute n).
-Reflexivity.
-Qed.
-
-Hints Resolve double_S : arith.
-
-Lemma even_odd_double : (n:nat) 
-  ((even n)<->n=(double (div2 n))) /\ ((odd n)<->n=(S (double (div2 n)))).
-Proof.
-Intro n. Pattern n. Apply ind_0_1_SS.
-(* n = 0 *)
-Split; Split; Auto with arith.
-Intro H. Inversion H.
-(* n = 1 *)
-Split; Split; Auto with arith.
-Intro H. Inversion H. Inversion H1.
-(* n = (S (S n')) *)
-Intros. Decompose [and] H. Unfold iff in H0 H1.
-Decompose [and] H0. Decompose [and] H1. Clear H H0 H1.
-Split; Split.
-Intro H. Inversion H. Inversion H1.
-Simpl. Rewrite (double_S (div2 n0)). Auto with arith.
-Simpl. Rewrite (double_S (div2 n0)). Intro H. Injection H. Auto with arith.
-Intro H. Inversion H. Inversion H1.
-Simpl. Rewrite (double_S (div2 n0)). Auto with arith.
-Simpl. Rewrite (double_S (div2 n0)). Intro H. Injection H. Auto with arith.
-Qed.
-
-
-(** Specializations *)
-
-Lemma even_double : (n:nat) (even n) -> n=(double (div2 n)).
-Proof [n:nat](proj1 ? ? (proj1 ? ? (even_odd_double n))).
-
-Lemma double_even : (n:nat) n=(double (div2 n)) -> (even n).
-Proof [n:nat](proj2 ? ? (proj1 ? ? (even_odd_double n))).
-
-Lemma odd_double : (n:nat) (odd n) -> n=(S (double (div2 n))).
-Proof [n:nat](proj1 ? ? (proj2 ? ? (even_odd_double n))).
-
-Lemma double_odd : (n:nat) n=(S (double (div2 n))) -> (odd n).
-Proof [n:nat](proj2 ? ? (proj2 ? ? (even_odd_double n))).
-
-Hints Resolve even_double double_even odd_double double_odd : arith.
-
-(** Application: 
-    - if [n] is even then there is a [p] such that [n = 2p]
-    - if [n] is odd  then there is a [p] such that [n = 2p+1]
-
-    (Immediate: it is [n/2]) *)
-
-Lemma even_2n : (n:nat) (even n) -> { p:nat | n=(double p) }.
-Proof.
-Intros n H. Exists (div2 n). Auto with arith.
-Qed.
-
-Lemma odd_S2n : (n:nat) (odd n) -> { p:nat | n=(S (double p)) }.
-Proof.
-Intros n H. Exists (div2 n). Auto with arith.
-Qed.
-
diff --git a/theories7/Arith/EqNat.v b/theories7/Arith/EqNat.v
deleted file mode 100755
index 9f5ee7ee..00000000
--- a/theories7/Arith/EqNat.v
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  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: EqNat.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-(** Equality on natural numbers *)
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,x,y:nat.
-
-Fixpoint  eq_nat [n:nat] : nat -> Prop :=
-  [m:nat]Cases n m of 
-                O      O     => True
-             |  O     (S _)  => False
-             | (S _)   O     => False
-             | (S n1) (S m1) => (eq_nat n1 m1)
-          end.
-
-Theorem eq_nat_refl : (n:nat)(eq_nat n n).
-NewInduction n; Simpl; Auto.
-Qed.
-Hints Resolve eq_nat_refl : arith v62.
-
-Theorem eq_eq_nat : (n,m:nat)(n=m)->(eq_nat n m).
-NewInduction 1; Trivial with arith.
-Qed.
-Hints Immediate eq_eq_nat : arith v62.
-
-Theorem eq_nat_eq : (n,m:nat)(eq_nat n m)->(n=m).
-NewInduction n; NewInduction m; Simpl; Contradiction Orelse Auto with arith.
-Qed.
-Hints Immediate eq_nat_eq : arith v62.
-
-Theorem eq_nat_elim : (n:nat)(P:nat->Prop)(P n)->(m:nat)(eq_nat n m)->(P m).
-Intros; Replace m with n; Auto with arith.
-Qed.
-
-Theorem eq_nat_decide : (n,m:nat){(eq_nat n m)}+{~(eq_nat n m)}.
-NewInduction n.
-NewDestruct m.
-Auto with arith.
-Intros; Right; Red; Trivial with arith.
-NewDestruct m.
-Right; Red; Auto with arith.
-Intros.
-Simpl.
-Apply IHn.
-Defined.
-
-Fixpoint  beq_nat [n:nat] : nat -> bool :=
-  [m:nat]Cases n m of 
-                O      O     => true
-             |  O     (S _)  => false
-             | (S _)   O     => false
-             | (S n1) (S m1) => (beq_nat n1 m1)
-          end.
-
-Lemma beq_nat_refl : (x:nat)true=(beq_nat x x).
-Proof.
-  Intro x; NewInduction x; Simpl; Auto.
-Qed.
-
-Definition beq_nat_eq : (x,y:nat)true=(beq_nat x y)->x=y.
-Proof.
-  Double Induction x y; Simpl.
-    Reflexivity.
-    Intros; Discriminate H0.
-    Intros; Discriminate H0.
-    Intros; Case (H0 ? H1); Reflexivity.
-Defined.
-
diff --git a/theories7/Arith/Euclid.v b/theories7/Arith/Euclid.v
deleted file mode 100644
index adeaf713..00000000
--- a/theories7/Arith/Euclid.v
+++ /dev/null
@@ -1,65 +0,0 @@
-(************************************************************************)
-(*  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: Euclid.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-Require Mult.
-Require Compare_dec.
-Require Wf_nat.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type a,b,n,q,r:nat.
-
-Inductive diveucl [a,b:nat] : Set 
-      := divex : (q,r:nat)(gt b r)->(a=(plus (mult q b) r))->(diveucl a b).
-
-
-Lemma eucl_dev : (b:nat)(gt b O)->(a:nat)(diveucl a b).
-Intros b H a; Pattern a; Apply gt_wf_rec; Intros n H0.
-Elim (le_gt_dec b n).
-Intro lebn.
-Elim (H0 (minus n b)); Auto with arith.
-Intros q r g e.
-Apply divex with (S q) r; Simpl; Auto with arith.
-Elim plus_assoc_l.
-Elim e; Auto with arith.
-Intros gtbn.
-Apply divex with O n; Simpl; Auto with arith.
-Qed.
-
-Lemma quotient : (b:nat)(gt b O)->
-     (a:nat){q:nat|(EX r:nat | (a=(plus (mult q b) r))/\(gt b r))}.
-Intros b H a; Pattern a; Apply gt_wf_rec; Intros n H0.
-Elim (le_gt_dec b n).
-Intro lebn.
-Elim (H0 (minus n b)); Auto with arith.
-Intros q Hq; Exists (S q).
-Elim Hq; Intros r Hr.
-Exists r; Simpl; Elim Hr; Intros.
-Elim plus_assoc_l.
-Elim H1; Auto with arith.
-Intros gtbn.
-Exists O; Exists n; Simpl; Auto with arith.
-Qed.
-
-Lemma modulo : (b:nat)(gt b O)->
-     (a:nat){r:nat|(EX q:nat | (a=(plus (mult q b) r))/\(gt b r))}.
-Intros b H a; Pattern a; Apply gt_wf_rec; Intros n H0.
-Elim (le_gt_dec b n).
-Intro lebn.
-Elim (H0 (minus n b)); Auto with arith.
-Intros r Hr; Exists r.
-Elim Hr; Intros q Hq.
-Elim Hq; Intros; Exists (S q); Simpl.
-Elim plus_assoc_l.
-Elim H1; Auto with arith.
-Intros gtbn.
-Exists n; Exists O; Simpl; Auto with arith.
-Qed.
diff --git a/theories7/Arith/Even.v b/theories7/Arith/Even.v
deleted file mode 100644
index bcc413f5..00000000
--- a/theories7/Arith/Even.v
+++ /dev/null
@@ -1,310 +0,0 @@
-(************************************************************************)
-(*  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: Even.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-(** Here we define the predicates [even] and [odd] by mutual induction
-    and we prove the decidability and the exclusion of those predicates.
-    The main results about parity are proved in the module Div2. *)
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n:nat.
-
-Inductive even : nat->Prop :=
-    even_O : (even O)
-  | even_S : (n:nat)(odd n)->(even (S n))
-with odd : nat->Prop :=
-    odd_S : (n:nat)(even n)->(odd (S n)).
-
-Hint constr_even : arith := Constructors even.
-Hint constr_odd : arith := Constructors odd.
-
-Lemma even_or_odd : (n:nat) (even n)\/(odd n).
-Proof.
-NewInduction n.
-Auto with arith.
-Elim IHn; Auto with arith.
-Qed.
-
-Lemma even_odd_dec : (n:nat) { (even n) }+{ (odd n) }.
-Proof.
-NewInduction n.
-Auto with arith.
-Elim IHn; Auto with arith.
-Qed.
-
-Lemma not_even_and_odd : (n:nat) (even n) -> (odd n) -> False.
-Proof.
-NewInduction n.
-Intros. Inversion H0.
-Intros. Inversion H. Inversion H0. Auto with arith.
-Qed.
-
-Lemma even_plus_aux:
-  (n,m:nat)
-   (iff (odd (plus n m)) (odd n) /\ (even m) \/ (even n) /\ (odd m)) /\
-   (iff (even (plus n m)) (even n) /\ (even m) \/ (odd n) /\ (odd m)).
-Proof.
-Intros n; Elim n; Simpl; Auto with arith.
-Intros m; Split; Auto.
-Split.
-Intros H; Right; Split; Auto with arith.
-Intros H'; Case H'; Auto with arith.
-Intros H'0; Elim H'0; Intros H'1 H'2; Inversion H'1.
-Intros H; Elim H; Auto.
-Split; Auto with arith.
-Intros H'; Elim H'; Auto with arith.
-Intros H; Elim H; Auto.
-Intros H'0; Elim H'0; Intros H'1 H'2; Inversion H'1.
-Intros n0 H' m; Elim (H' m); Intros H'1 H'2; Elim H'1; Intros E1 E2; Elim H'2;
- Intros E3 E4; Clear H'1 H'2.
-Split; Split.
-Intros H'0; Case E3.
-Inversion H'0; Auto.
-Intros H; Elim H; Intros H0 H1; Clear H; Auto with arith.
-Intros H; Elim H; Intros H0 H1; Clear H; Auto with arith.
-Intros H'0; Case H'0; Intros C0; Case C0; Intros C1 C2.
-Apply odd_S.
-Apply E4; Left; Split; Auto with arith.
-Inversion C1; Auto.
-Apply odd_S.
-Apply E4; Right; Split; Auto with arith.
-Inversion C1; Auto.
-Intros H'0.
-Case E1.
-Inversion H'0; Auto.
-Intros H; Elim H; Intros H0 H1; Clear H; Auto with arith.
-Intros H; Elim H; Intros H0 H1; Clear H; Auto with arith.
-Intros H'0; Case H'0; Intros C0; Case C0; Intros C1 C2.
-Apply even_S.
-Apply E2; Left; Split; Auto with arith.
-Inversion C1; Auto.
-Apply even_S.
-Apply E2; Right; Split; Auto with arith.
-Inversion C1; Auto.
-Qed.
- 
-Lemma even_even_plus : (n,m:nat) (even n) -> (even m) -> (even (plus n m)).
-Proof.
-Intros n m; Case (even_plus_aux n m).
-Intros H H0; Case H0; Auto.
-Qed.
- 
-Lemma odd_even_plus : (n,m:nat) (odd n) -> (odd m) -> (even (plus n m)).
-Proof.
-Intros n m; Case (even_plus_aux n m).
-Intros H H0; Case H0; Auto.
-Qed.
- 
-Lemma even_plus_even_inv_r :
-  (n,m:nat) (even (plus n m)) -> (even n) -> (even m).
-Proof.
-Intros n m H; Case (even_plus_aux n m).
-Intros H' H'0; Elim H'0.
-Intros H'1; Case H'1; Auto.
-Intros H0; Elim H0; Auto.
-Intros H0 H1 H2; Case (not_even_and_odd n); Auto.
-Case H0; Auto.
-Qed.
- 
-Lemma even_plus_even_inv_l :
-  (n,m:nat) (even (plus n m)) -> (even m) -> (even n).
-Proof.
-Intros n m H; Case (even_plus_aux n m).
-Intros H' H'0; Elim H'0.
-Intros H'1; Case H'1; Auto.
-Intros H0; Elim H0; Auto.
-Intros H0 H1 H2; Case (not_even_and_odd m); Auto.
-Case H0; Auto.
-Qed.
- 
-Lemma even_plus_odd_inv_r : (n,m:nat) (even (plus n m)) -> (odd n) -> (odd m).
-Proof.
-Intros n m H; Case (even_plus_aux n m).
-Intros H' H'0; Elim H'0.
-Intros H'1; Case H'1; Auto.
-Intros H0 H1 H2; Case (not_even_and_odd n); Auto.
-Case H0; Auto.
-Intros H0; Case H0; Auto.
-Qed.
- 
-Lemma even_plus_odd_inv_l : (n,m:nat) (even (plus n m)) -> (odd m) -> (odd n).
-Proof.
-Intros n m H; Case (even_plus_aux n m).
-Intros H' H'0; Elim H'0.
-Intros H'1; Case H'1; Auto.
-Intros H0 H1 H2; Case (not_even_and_odd m); Auto.
-Case H0; Auto.
-Intros H0; Case H0; Auto.
-Qed.
-Hints Resolve even_even_plus odd_even_plus :arith.
- 
-Lemma odd_plus_l : (n,m:nat) (odd n) -> (even m) -> (odd (plus n m)).
-Proof.
-Intros n m; Case (even_plus_aux n m).
-Intros H; Case H; Auto.
-Qed.
- 
-Lemma odd_plus_r : (n,m:nat) (even n) -> (odd m) -> (odd (plus n m)).
-Proof.
-Intros n m; Case (even_plus_aux n m).
-Intros H; Case H; Auto.
-Qed.
- 
-Lemma odd_plus_even_inv_l : (n,m:nat) (odd (plus n m)) -> (odd m) -> (even n).
-Proof.
-Intros n m H; Case (even_plus_aux n m).
-Intros H' H'0; Elim H'.
-Intros H'1; Case H'1; Auto.
-Intros H0 H1 H2; Case (not_even_and_odd m); Auto.
-Case H0; Auto.
-Intros H0; Case H0; Auto.
-Qed.
- 
-Lemma odd_plus_even_inv_r : (n,m:nat) (odd (plus n m)) -> (odd n) -> (even m).
-Proof.
-Intros n m H; Case (even_plus_aux n m).
-Intros H' H'0; Elim H'.
-Intros H'1; Case H'1; Auto.
-Intros H0; Case H0; Auto.
-Intros H0 H1 H2; Case (not_even_and_odd n); Auto.
-Case H0; Auto.
-Qed.
- 
-Lemma odd_plus_odd_inv_l : (n,m:nat) (odd (plus n m)) -> (even m) -> (odd n).
-Proof.
-Intros n m H; Case (even_plus_aux n m).
-Intros H' H'0; Elim H'.
-Intros H'1; Case H'1; Auto.
-Intros H0; Case H0; Auto.
-Intros H0 H1 H2; Case (not_even_and_odd m); Auto.
-Case H0; Auto.
-Qed.
- 
-Lemma odd_plus_odd_inv_r : (n,m:nat) (odd (plus n m)) -> (even n) -> (odd m).
-Proof.
-Intros n m H; Case (even_plus_aux n m).
-Intros H' H'0; Elim H'.
-Intros H'1; Case H'1; Auto.
-Intros H0 H1 H2; Case (not_even_and_odd n); Auto.
-Case H0; Auto.
-Intros H0; Case H0; Auto.
-Qed.
-Hints Resolve odd_plus_l odd_plus_r :arith.
- 
-Lemma even_mult_aux :
-  (n,m:nat)
-   (iff (odd (mult n m)) (odd n) /\ (odd m)) /\
-   (iff (even (mult n m)) (even n) \/ (even m)).
-Proof.
-Intros n; Elim n; Simpl; Auto with arith.
-Intros m; Split; Split; Auto with arith.
-Intros H'; Inversion H'.
-Intros H'; Elim H'; Auto.
-Intros n0 H' m; Split; Split; Auto with arith.
-Intros H'0.
-Elim (even_plus_aux m (mult n0 m)); Intros H'3 H'4; Case H'3; Intros H'1 H'2;
- Case H'1; Auto.
-Intros H'5; Elim H'5; Intros H'6 H'7; Auto with arith.
-Split; Auto with arith.
-Case (H' m).
-Intros H'8 H'9; Case H'9.
-Intros H'10; Case H'10; Auto with arith.
-Intros H'11 H'12; Case (not_even_and_odd m); Auto with arith.
-Intros H'5; Elim H'5; Intros H'6 H'7; Case (not_even_and_odd (mult n0 m)); Auto.
-Case (H' m).
-Intros H'8 H'9; Case H'9; Auto.
-Intros H'0; Elim H'0; Intros H'1 H'2; Clear H'0.
-Elim (even_plus_aux m (mult n0 m)); Auto.
-Intros H'0 H'3.
-Elim H'0.
-Intros H'4 H'5; Apply H'5; Auto.
-Left; Split; Auto with arith.
-Case (H' m).
-Intros H'6 H'7; Elim H'7.
-Intros H'8 H'9; Apply H'9.
-Left.
-Inversion H'1; Auto.
-Intros H'0.
-Elim (even_plus_aux m (mult n0 m)); Intros H'3 H'4; Case H'4.
-Intros H'1 H'2.
-Elim H'1; Auto.
-Intros H; Case H; Auto.
-Intros H'5; Elim H'5; Intros H'6 H'7; Auto with arith.
-Left.
-Case (H' m).
-Intros H'8; Elim H'8.
-Intros H'9; Elim H'9; Auto with arith.
-Intros H'0; Elim H'0; Intros H'1.
-Case (even_or_odd m); Intros H'2.
-Apply even_even_plus; Auto.
-Case (H' m).
-Intros H H0; Case H0; Auto.
-Apply odd_even_plus; Auto.
-Inversion H'1; Case (H' m); Auto.
-Intros H1; Case H1; Auto.
-Apply even_even_plus; Auto.
-Case (H' m).
-Intros H H0; Case H0; Auto.
-Qed.
- 
-Lemma even_mult_l : (n,m:nat) (even n) -> (even (mult n m)).
-Proof.
-Intros n m; Case (even_mult_aux n m); Auto.
-Intros H H0; Case H0; Auto.
-Qed.
- 
-Lemma even_mult_r: (n,m:nat) (even m) -> (even (mult n m)).
-Proof.
-Intros n m; Case (even_mult_aux n m); Auto.
-Intros H H0; Case H0; Auto.
-Qed.
-Hints Resolve even_mult_l even_mult_r :arith.
- 
-Lemma even_mult_inv_r: (n,m:nat) (even (mult n m)) -> (odd n) -> (even m).
-Proof.
-Intros n m H' H'0.
-Case (even_mult_aux n m).
-Intros H'1 H'2; Elim H'2.
-Intros H'3; Elim H'3; Auto.
-Intros H; Case (not_even_and_odd n); Auto.
-Qed.
- 
-Lemma even_mult_inv_l : (n,m:nat) (even (mult n m)) -> (odd m) -> (even n).
-Proof.
-Intros n m H' H'0.
-Case (even_mult_aux n m).
-Intros H'1 H'2; Elim H'2.
-Intros H'3; Elim H'3; Auto.
-Intros H; Case (not_even_and_odd m); Auto.
-Qed.
- 
-Lemma odd_mult : (n,m:nat) (odd n) -> (odd m) -> (odd (mult n m)).
-Proof.
-Intros n m; Case (even_mult_aux n m); Intros H; Case H; Auto.
-Qed.
-Hints Resolve even_mult_l even_mult_r odd_mult :arith.
- 
-Lemma odd_mult_inv_l : (n,m:nat) (odd (mult n m)) -> (odd n).
-Proof.
-Intros n m H'.
-Case (even_mult_aux n m).
-Intros H'1 H'2; Elim H'1.
-Intros H'3; Elim H'3; Auto.
-Qed.
- 
-Lemma odd_mult_inv_r : (n,m:nat) (odd (mult n m)) -> (odd m).
-Proof.
-Intros n m H'.
-Case (even_mult_aux n m).
-Intros H'1 H'2; Elim H'1.
-Intros H'3; Elim H'3; Auto.
-Qed.
-
diff --git a/theories7/Arith/Factorial.v b/theories7/Arith/Factorial.v
deleted file mode 100644
index a8a60c98..00000000
--- a/theories7/Arith/Factorial.v
+++ /dev/null
@@ -1,51 +0,0 @@
-(************************************************************************)
-(*  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: Factorial.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-Require Plus.
-Require Mult.
-Require Lt.
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-(** Factorial *)
-
-Fixpoint fact [n:nat]:nat:=
-  Cases n of
-     O     => (S O)
-    |(S n) => (mult (S n) (fact n))
-  end.
-
-Arguments Scope fact [ nat_scope ].
-
-Lemma lt_O_fact : (n:nat)(lt O (fact n)).
-Proof.
-Induction n; Unfold lt; Simpl; Auto with arith.
-Qed.
-
-Lemma fact_neq_0:(n:nat)~(fact n)=O.
-Proof.
-Intro.
-Apply sym_not_eq.
-Apply lt_O_neq.
-Apply lt_O_fact.
-Qed.
-
-Lemma fact_growing : (n,m:nat) (le n m) -> (le (fact n) (fact m)).
-Proof.
-NewInduction 1.
-Apply le_n.
-Assert (le (mult (S O) (fact n)) (mult (S m) (fact m))).
-Apply le_mult_mult.
-Apply lt_le_S; Apply lt_O_Sn.
-Assumption.
-Simpl (mult (S O) (fact n)) in H0.
-Rewrite <- plus_n_O in H0.
-Assumption.
-Qed.
diff --git a/theories7/Arith/Gt.v b/theories7/Arith/Gt.v
deleted file mode 100755
index 16b6f203..00000000
--- a/theories7/Arith/Gt.v
+++ /dev/null
@@ -1,149 +0,0 @@
-(************************************************************************)
-(*  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: Gt.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-Require Le.
-Require Lt.
-Require Plus.
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,p:nat.
-
-(** Order and successor *)
-
-Theorem gt_Sn_O : (n:nat)(gt (S n) O).
-Proof.
-  Auto with arith.
-Qed.
-Hints Resolve gt_Sn_O : arith v62.
-
-Theorem gt_Sn_n : (n:nat)(gt (S n) n).
-Proof.
-  Auto with arith.
-Qed.
-Hints Resolve gt_Sn_n : arith v62.
-
-Theorem gt_n_S : (n,m:nat)(gt n m)->(gt (S n) (S m)).
-Proof.
-  Auto with arith.
-Qed.
-Hints Resolve gt_n_S : arith v62.
-
-Lemma gt_S_n : (n,p:nat)(gt (S p) (S n))->(gt p n).
-Proof.
-  Auto with arith.
-Qed.
-Hints Immediate gt_S_n : arith v62.
-
-Theorem gt_S : (n,m:nat)(gt (S n) m)->((gt n m)\/(m=n)).
-Proof.
-  Intros n m H; Unfold gt; Apply le_lt_or_eq; Auto with arith.
-Qed.
-
-Lemma gt_pred : (n,p:nat)(gt p (S n))->(gt (pred p) n).
-Proof.
-  Auto with arith.
-Qed.
-Hints Immediate gt_pred : arith v62.
-
-(** Irreflexivity *)
-
-Lemma gt_antirefl : (n:nat)~(gt n n).
-Proof lt_n_n.
-Hints Resolve gt_antirefl : arith v62.
-
-(** Asymmetry *)
-
-Lemma gt_not_sym : (n,m:nat)(gt n m) -> ~(gt m n).
-Proof [n,m:nat](lt_not_sym m n).
-
-Hints Resolve gt_not_sym : arith v62.
-
-(** Relating strict and large orders *)
-
-Lemma le_not_gt : (n,m:nat)(le n m) -> ~(gt n m).
-Proof le_not_lt.
-Hints Resolve le_not_gt : arith v62.
-
-Lemma gt_not_le : (n,m:nat)(gt n m) -> ~(le n m).
-Proof.
-Auto with arith.
-Qed.
-
-Hints Resolve gt_not_le : arith v62.
-
-Theorem le_S_gt : (n,m:nat)(le (S n) m)->(gt m n).
-Proof.
-  Auto with arith.
-Qed.
-Hints Immediate le_S_gt : arith v62.
-
-Lemma gt_S_le : (n,p:nat)(gt (S p) n)->(le n p).
-Proof.
-  Intros n p; Exact (lt_n_Sm_le n p).
-Qed.
-Hints Immediate gt_S_le : arith v62.
-
-Lemma gt_le_S : (n,p:nat)(gt p n)->(le (S n) p).
-Proof.
-  Auto with arith.
-Qed.
-Hints Resolve gt_le_S : arith v62.
-
-Lemma le_gt_S : (n,p:nat)(le n p)->(gt (S p) n).
-Proof.
-  Auto with arith.
-Qed.
-Hints Resolve le_gt_S : arith v62.
-
-(** Transitivity *)
-
-Theorem le_gt_trans : (n,m,p:nat)(le m n)->(gt m p)->(gt n p).
-Proof.
-  Red; Intros; Apply lt_le_trans with m; Auto with arith.
-Qed.
-
-Theorem gt_le_trans : (n,m,p:nat)(gt n m)->(le p m)->(gt n p).
-Proof.
-  Red; Intros; Apply le_lt_trans with m; Auto with arith.
-Qed.
-
-Lemma gt_trans : (n,m,p:nat)(gt n m)->(gt m p)->(gt n p).
-Proof.
-  Red; Intros n m p H1 H2.
-  Apply lt_trans with m; Auto with arith.
-Qed.
-
-Theorem gt_trans_S : (n,m,p:nat)(gt (S n) m)->(gt m p)->(gt n p).
-Proof.
-  Red; Intros; Apply lt_le_trans with m; Auto with arith.
-Qed.
-
-Hints Resolve gt_trans_S le_gt_trans gt_le_trans : arith v62.
-
-(** Comparison to 0 *)
-
-Theorem gt_O_eq : (n:nat)((gt n O)\/(O=n)).
-Proof.
-  Intro n ; Apply gt_S ; Auto with arith.
-Qed.
-
-(** Simplification and compatibility *)
-
-Lemma simpl_gt_plus_l : (n,m,p:nat)(gt (plus p n) (plus p m))->(gt n m).
-Proof.
-  Red; Intros n m p H; Apply simpl_lt_plus_l with p; Auto with arith.
-Qed.
-
-Lemma gt_reg_l : (n,m,p:nat)(gt n m)->(gt (plus p n) (plus p m)).
-Proof.
-  Auto with arith.
-Qed.
-Hints Resolve gt_reg_l : arith v62.
diff --git a/theories7/Arith/Le.v b/theories7/Arith/Le.v
deleted file mode 100755
index cdb98645..00000000
--- a/theories7/Arith/Le.v
+++ /dev/null
@@ -1,122 +0,0 @@
-(************************************************************************)
-(*  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: Le.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-(** Order on natural numbers *)
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,p:nat.
-
-(** Reflexivity *)
-
-Theorem le_refl : (n:nat)(le n n).
-Proof.
-Exact le_n.
-Qed.
-
-(** Transitivity *)
-
-Theorem le_trans : (n,m,p:nat)(le n m)->(le m p)->(le n p).
-Proof.
-  NewInduction 2; Auto.
-Qed.
-Hints Resolve le_trans : arith v62.
-
-(** Order, successor and predecessor *)
-
-Theorem le_n_S : (n,m:nat)(le n m)->(le (S n) (S m)).
-Proof.
-  NewInduction 1; Auto.
-Qed.
-
-Theorem le_n_Sn : (n:nat)(le n (S n)).
-Proof.
-  Auto.
-Qed.
-
-Theorem le_O_n : (n:nat)(le O n).
-Proof.
-  NewInduction n ; Auto.
-Qed.
-
-Hints Resolve le_n_S le_n_Sn le_O_n le_n_S : arith v62.
-
-Theorem le_pred_n : (n:nat)(le (pred n) n).
-Proof.
-NewInduction n ; Auto with arith.
-Qed.
-Hints Resolve le_pred_n : arith v62.
-
-Theorem le_trans_S : (n,m:nat)(le (S n) m)->(le n m).
-Proof.
-Intros n m H ; Apply le_trans with (S n); Auto with arith.
-Qed.
-Hints Immediate le_trans_S : arith v62.
-
-Theorem le_S_n : (n,m:nat)(le (S n) (S m))->(le n m).
-Proof.
-Intros n m H ; Change (le (pred (S n)) (pred (S m))).
-Elim H ; Simpl ; Auto with arith.
-Qed.
-Hints Immediate le_S_n : arith v62.
-
-Theorem le_pred : (n,m:nat)(le n m)->(le (pred n) (pred m)).
-Proof.
-NewInduction n as [|n IHn]. Simpl. Auto with arith.
-NewDestruct m as [|m]. Simpl. Intro H. Inversion H.
-Simpl. Auto with arith.
-Qed.
-
-(** Comparison to 0 *)
-
-Theorem le_Sn_O : (n:nat)~(le (S n) O).
-Proof.
-Red ; Intros n H.
-Change (IsSucc O) ; Elim H ; Simpl ; Auto with arith.
-Qed.
-Hints Resolve le_Sn_O : arith v62.
-
-Theorem le_n_O_eq : (n:nat)(le n O)->(O=n).
-Proof.
-NewInduction n; Auto with arith.
-Intro; Contradiction le_Sn_O with n.
-Qed.
-Hints Immediate le_n_O_eq : arith v62.
-
-(** Negative properties *)
-
-Theorem le_Sn_n : (n:nat)~(le (S n) n).
-Proof.
-NewInduction n; Auto with arith.
-Qed.
-Hints Resolve le_Sn_n : arith v62.
-
-(** Antisymmetry *)
-
-Theorem le_antisym : (n,m:nat)(le n m)->(le m n)->(n=m).
-Proof.
-Intros n m h ; NewDestruct h as [|m0]; Auto with arith.
-Intros H1.
-Absurd (le (S m0) m0) ; Auto with arith.
-Apply le_trans with n ; Auto with arith.
-Qed.
-Hints Immediate le_antisym : arith v62.
-
-(** A different elimination principle for the order on natural numbers *)
-
-Lemma le_elim_rel : (P:nat->nat->Prop)
-     ((p:nat)(P O p))->
-     ((p,q:nat)(le p q)->(P p q)->(P (S p) (S q)))->
-     (n,m:nat)(le n m)->(P n m).
-Proof.
-NewInduction n; Auto with arith.
-Intros m Le.
-Elim Le; Auto with arith.
-Qed.
diff --git a/theories7/Arith/Lt.v b/theories7/Arith/Lt.v
deleted file mode 100755
index 9bb1d564..00000000
--- a/theories7/Arith/Lt.v
+++ /dev/null
@@ -1,176 +0,0 @@
-(************************************************************************)
-(*  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: Lt.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-Require Le.
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,p:nat.
-
-(** Irreflexivity *)
-
-Theorem lt_n_n : (n:nat)~(lt n n).
-Proof le_Sn_n.
-Hints Resolve lt_n_n : arith v62.
-
-(** Relationship between [le] and [lt] *) 
-
-Theorem lt_le_S : (n,p:nat)(lt n p)->(le (S n) p).
-Proof.
-Auto with arith.
-Qed.
-Hints Immediate lt_le_S : arith v62.
-
-Theorem lt_n_Sm_le : (n,m:nat)(lt n (S m))->(le n m).
-Proof.
-Auto with arith.
-Qed.
-Hints Immediate lt_n_Sm_le : arith v62.
-
-Theorem le_lt_n_Sm : (n,m:nat)(le n m)->(lt n (S m)).
-Proof.
-Auto with arith.
-Qed.
-Hints Immediate le_lt_n_Sm : arith v62.
-
-Theorem le_not_lt : (n,m:nat)(le n m) -> ~(lt m n).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-
-Theorem lt_not_le : (n,m:nat)(lt n m) -> ~(le m n).
-Proof.
-Red; Intros n m Lt Le; Exact (le_not_lt m n Le Lt).
-Qed.
-Hints Immediate le_not_lt lt_not_le : arith v62.
-
-(** Asymmetry *)
-
-Theorem lt_not_sym : (n,m:nat)(lt n m) -> ~(lt m n).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-
-(** Order and successor *)
-
-Theorem lt_n_Sn : (n:nat)(lt n (S n)).
-Proof.
-Auto with arith.
-Qed.
-Hints Resolve lt_n_Sn : arith v62.
-
-Theorem lt_S : (n,m:nat)(lt n m)->(lt n (S m)).
-Proof.
-Auto with arith.
-Qed.
-Hints Resolve lt_S : arith v62.
-
-Theorem lt_n_S : (n,m:nat)(lt n m)->(lt (S n) (S m)).
-Proof.
-Auto with arith.
-Qed.
-Hints Resolve lt_n_S : arith v62.
-
-Theorem lt_S_n : (n,m:nat)(lt (S n) (S m))->(lt n m).
-Proof.
-Auto with arith.
-Qed.
-Hints Immediate lt_S_n : arith v62.
-
-Theorem lt_O_Sn : (n:nat)(lt O (S n)).
-Proof.
-Auto with arith.
-Qed.
-Hints Resolve lt_O_Sn : arith v62.
-
-Theorem lt_n_O : (n:nat)~(lt n O).
-Proof le_Sn_O.
-Hints Resolve lt_n_O : arith v62.
-
-(** Predecessor *)
-
-Lemma S_pred : (n,m:nat)(lt m n)->n=(S (pred n)).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-
-Lemma lt_pred : (n,p:nat)(lt (S n) p)->(lt n (pred p)).
-Proof.
-NewInduction 1; Simpl; Auto with arith.
-Qed.
-Hints Immediate lt_pred : arith v62.
-
-Lemma lt_pred_n_n : (n:nat)(lt O n)->(lt (pred n) n).
-NewDestruct 1; Simpl; Auto with arith.
-Qed.
-Hints Resolve lt_pred_n_n : arith v62.
-
-(** Transitivity properties *)
-
-Theorem lt_trans : (n,m,p:nat)(lt n m)->(lt m p)->(lt n p).
-Proof.
-NewInduction 2; Auto with arith.
-Qed.
-
-Theorem lt_le_trans : (n,m,p:nat)(lt n m)->(le m p)->(lt n p).
-Proof.
-NewInduction 2; Auto with arith.
-Qed.
-
-Theorem le_lt_trans : (n,m,p:nat)(le n m)->(lt m p)->(lt n p).
-Proof.
-NewInduction 2; Auto with arith.
-Qed.
-
-Hints Resolve lt_trans lt_le_trans le_lt_trans : arith v62.
-
-(** Large = strict or equal *)
-
-Theorem le_lt_or_eq : (n,m:nat)(le n m)->((lt n m) \/ n=m).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-
-Theorem lt_le_weak : (n,m:nat)(lt n m)->(le n m).
-Proof.
-Auto with arith.
-Qed.
-Hints Immediate lt_le_weak : arith v62.
-
-(** Dichotomy *)
-
-Theorem le_or_lt : (n,m:nat)((le n m)\/(lt m n)).
-Proof.
-Intros n m; Pattern n m; Apply nat_double_ind; Auto with arith.
-NewInduction 1; Auto with arith.
-Qed.
-
-Theorem nat_total_order: (m,n: nat) ~ m = n -> (lt m n) \/ (lt n m).
-Proof.
-Intros m n diff.
-Elim (le_or_lt n m); [Intro H'0 | Auto with arith].
-Elim (le_lt_or_eq n m); Auto with arith.
-Intro H'; Elim diff; Auto with arith.
-Qed.
-
-(** Comparison to 0 *)
-
-Theorem neq_O_lt : (n:nat)(~O=n)->(lt O n).
-Proof.
-NewInduction n; Auto with arith.
-Intros; Absurd O=O; Trivial with arith.
-Qed.
-Hints Immediate neq_O_lt : arith v62.
-
-Theorem lt_O_neq : (n:nat)(lt O n)->(~O=n).
-Proof.
-NewInduction 1; Auto with arith.
-Qed.
-Hints Immediate lt_O_neq : arith v62.
diff --git a/theories7/Arith/Max.v b/theories7/Arith/Max.v
deleted file mode 100755
index aea389d1..00000000
--- a/theories7/Arith/Max.v
+++ /dev/null
@@ -1,87 +0,0 @@
-(************************************************************************)
-(*  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: Max.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-Require Arith.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n:nat.
-
-(** maximum of two natural numbers *)
-
-Fixpoint max [n:nat] : nat -> nat :=  
-[m:nat]Cases n m of
-          O      _     => m
-       | (S n')  O     => n
-       | (S n') (S m') => (S (max n' m'))
-       end.
-
-(** Simplifications of [max] *)
-
-Lemma max_SS : (n,m:nat)((S (max n m))=(max (S n) (S m))).
-Proof.
-Auto with arith.
-Qed.
-
-Lemma max_sym : (n,m:nat)(max n m)=(max m n).
-Proof.
-NewInduction n;NewInduction m;Simpl;Auto with arith.
-Qed.
-
-(** [max] and [le] *)
-
-Lemma max_l : (n,m:nat)(le m n)->(max n m)=n.
-Proof.
-NewInduction n;NewInduction m;Simpl;Auto with arith.
-Qed.
-
-Lemma max_r : (n,m:nat)(le n m)->(max n m)=m.
-Proof.
-NewInduction n;NewInduction m;Simpl;Auto with arith.
-Qed.
-
-Lemma le_max_l : (n,m:nat)(le n (max n m)).
-Proof.
-NewInduction n; Intros; Simpl; Auto with arith.
-Elim m; Intros; Simpl; Auto with arith.
-Qed.
-
-Lemma le_max_r : (n,m:nat)(le m (max n m)).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-NewInduction m; Simpl; Auto with arith.
-Qed.
-Hints Resolve max_r max_l le_max_l le_max_r: arith v62.
-
-
-(** [max n m] is equal to [n] or [m] *)
-
-Lemma max_dec : (n,m:nat){(max n m)=n}+{(max n m)=m}.
-Proof.
-NewInduction n;NewInduction m;Simpl;Auto with arith.
-Elim (IHn m);Intro H;Elim H;Auto.
-Qed.
-
-Lemma max_case : (n,m:nat)(P:nat->Set)(P n)->(P m)->(P (max n m)).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-NewInduction m; Intros; Simpl; Auto with arith.
-Pattern (max n m); Apply IHn ; Auto with arith.
-Qed.
-
-Lemma max_case2 : (n,m:nat)(P:nat->Prop)(P n)->(P m)->(P (max n m)).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-NewInduction m; Intros; Simpl; Auto with arith.
-Pattern (max n m); Apply IHn ; Auto with arith.
-Qed.
-
-
diff --git a/theories7/Arith/Min.v b/theories7/Arith/Min.v
deleted file mode 100755
index fd5da61a..00000000
--- a/theories7/Arith/Min.v
+++ /dev/null
@@ -1,84 +0,0 @@
-(************************************************************************)
-(*  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: Min.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-Require Arith.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n:nat.
-
-(** minimum of two natural numbers *)
-
-Fixpoint min [n:nat] : nat -> nat :=  
-[m:nat]Cases n m of
-          O      _     => O
-       | (S n')  O     => O
-       | (S n') (S m') => (S (min n' m'))
-       end.
-
-(** Simplifications of [min] *)
-
-Lemma min_SS : (n,m:nat)((S (min n m))=(min (S n) (S m))).
-Proof.
-Auto with arith.
-Qed.
-
-Lemma min_sym : (n,m:nat)(min n m)=(min m n).
-Proof.
-NewInduction n;NewInduction m;Simpl;Auto with arith.
-Qed.
-
-(** [min] and [le] *)
-
-Lemma min_l : (n,m:nat)(le n m)->(min n m)=n.
-Proof.
-NewInduction n;NewInduction m;Simpl;Auto with arith.
-Qed.
-
-Lemma min_r : (n,m:nat)(le m n)->(min n m)=m.
-Proof.
-NewInduction n;NewInduction m;Simpl;Auto with arith.
-Qed.
-
-Lemma le_min_l : (n,m:nat)(le (min n m) n).
-Proof.
-NewInduction n; Intros; Simpl; Auto with arith.
-Elim m; Intros; Simpl; Auto with arith.
-Qed.
-
-Lemma le_min_r : (n,m:nat)(le (min n m) m).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-NewInduction m; Simpl; Auto with arith.
-Qed.
-Hints Resolve min_l min_r le_min_l le_min_r : arith v62.
-
-(** [min n m] is equal to [n] or [m] *)
-
-Lemma min_dec : (n,m:nat){(min n m)=n}+{(min n m)=m}.
-Proof.
-NewInduction n;NewInduction m;Simpl;Auto with arith.
-Elim (IHn m);Intro H;Elim H;Auto.
-Qed.
-
-Lemma min_case : (n,m:nat)(P:nat->Set)(P n)->(P m)->(P (min n m)).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-NewInduction m; Intros; Simpl; Auto with arith.
-Pattern (min n m); Apply IHn ; Auto with arith.
-Qed.
-
-Lemma min_case2 : (n,m:nat)(P:nat->Prop)(P n)->(P m)->(P (min n m)).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-NewInduction m; Intros; Simpl; Auto with arith.
-Pattern (min n m); Apply IHn ; Auto with arith.
-Qed.
diff --git a/theories7/Arith/Minus.v b/theories7/Arith/Minus.v
deleted file mode 100755
index 709d5f0b..00000000
--- a/theories7/Arith/Minus.v
+++ /dev/null
@@ -1,120 +0,0 @@
-(************************************************************************)
-(*  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: Minus.v,v 1.1.2.1 2004/07/16 19:31:24 herbelin Exp $ i*)
-
-(** Subtraction (difference between two natural numbers) *)
-
-Require Lt.
-Require Le.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,p:nat.
-
-(** 0 is right neutral *)
-
-Lemma minus_n_O : (n:nat)(n=(minus n O)).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-Qed.
-Hints Resolve minus_n_O : arith v62.
-
-(** Permutation with successor *)
-
-Lemma minus_Sn_m : (n,m:nat)(le m n)->((S (minus n m))=(minus (S n) m)).
-Proof.
-Intros n m Le; Pattern m n; Apply le_elim_rel; Simpl; Auto with arith.
-Qed.
-Hints Resolve minus_Sn_m : arith v62.
-
-Theorem pred_of_minus : (x:nat)(pred x)=(minus x (S O)).
-Intro x; NewInduction x; Simpl; Auto with arith.
-Qed.
-
-(** Diagonal *)
-
-Lemma minus_n_n : (n:nat)(O=(minus n n)).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-Qed.
-Hints Resolve minus_n_n : arith v62.
-
-(** Simplification *)
-
-Lemma minus_plus_simpl : 
-	(n,m,p:nat)((minus n m)=(minus (plus p n) (plus p m))).
-Proof.
-  NewInduction p; Simpl; Auto with arith.
-Qed.
-Hints Resolve minus_plus_simpl : arith v62.
-
-(** Relation with plus *)
-
-Lemma plus_minus : (n,m,p:nat)(n=(plus m p))->(p=(minus n m)).
-Proof.
-Intros n m p; Pattern m n; Apply nat_double_ind; Simpl; Intros.
-Replace (minus n0 O) with n0; Auto with arith.
-Absurd O=(S (plus n0 p)); Auto with arith.
-Auto with arith.
-Qed.
-Hints Immediate plus_minus : arith v62.
-
-Lemma minus_plus : (n,m:nat)(minus (plus n m) n)=m.
-Symmetry; Auto with arith.
-Qed.
-Hints Resolve minus_plus : arith v62.
-
-Lemma le_plus_minus : (n,m:nat)(le n m)->(m=(plus n (minus m n))).
-Proof.
-Intros n m Le; Pattern n m; Apply le_elim_rel; Simpl; Auto with arith.
-Qed.
-Hints Resolve le_plus_minus : arith v62.
-
-Lemma le_plus_minus_r : (n,m:nat)(le n m)->(plus n (minus m n))=m.
-Proof.
-Symmetry; Auto with arith.
-Qed.
-Hints Resolve le_plus_minus_r : arith v62.
-
-(** Relation with order *)
-
-Theorem le_minus: (i,h:nat) (le (minus i h) i).
-Proof.
-Intros i h;Pattern i h; Apply nat_double_ind; [
-  Auto
-| Auto
-| Intros m n H; Simpl; Apply le_trans with m:=m; Auto ].
-Qed.
-
-Lemma lt_minus : (n,m:nat)(le m n)->(lt O m)->(lt (minus n m) n).
-Proof.
-Intros n m Le; Pattern m n; Apply le_elim_rel; Simpl; Auto with arith.
-Intros; Absurd (lt O O); Auto with arith.
-Intros p q lepq Hp gtp.
-Elim (le_lt_or_eq O p); Auto with arith.
-Auto with arith.
-NewInduction 1; Elim minus_n_O; Auto with arith.
-Qed.
-Hints Resolve lt_minus : arith v62.
-
-Lemma lt_O_minus_lt : (n,m:nat)(lt O (minus n m))->(lt m n).
-Proof.
-Intros n m; Pattern n m; Apply nat_double_ind; Simpl; Auto with arith.
-Intros; Absurd (lt O O); Trivial with arith.
-Qed.
-Hints Immediate lt_O_minus_lt : arith v62.
-
-Theorem inj_minus_aux: (x,y:nat) ~(le y x) -> (minus x y) = O.
-Intros y x; Pattern y x ; Apply nat_double_ind; [
-  Simpl; Trivial with arith
-| Intros n H; Absurd (le O (S n)); [ Assumption | Apply le_O_n]
-| Simpl; Intros n m H1 H2; Apply H1;
-  Unfold not ; Intros H3; Apply H2; Apply le_n_S; Assumption].
-Qed.
diff --git a/theories7/Arith/Mult.v b/theories7/Arith/Mult.v
deleted file mode 100755
index 9bd4aaf9..00000000
--- a/theories7/Arith/Mult.v
+++ /dev/null
@@ -1,224 +0,0 @@
-(************************************************************************)
-(*  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: Mult.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-Require Export Plus.
-Require Export Minus.
-Require Export Lt.
-Require Export Le.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,p:nat.
-
-(** Zero property *)
-
-Lemma mult_0_r : (n:nat) (mult n O)=O.
-Proof.
-Intro; Symmetry; Apply mult_n_O.
-Qed.
-
-Lemma mult_0_l : (n:nat) (mult O n)=O.
-Proof.
-Reflexivity.
-Qed.
-
-(** Distributivity *)
-
-Lemma mult_plus_distr : 
-      (n,m,p:nat)((mult (plus n m) p)=(plus (mult n p) (mult m p))).
-Proof.
-Intros; Elim n; Simpl; Intros; Auto with arith.
-Elim plus_assoc_l; Elim H; Auto with arith.
-Qed.
-Hints Resolve mult_plus_distr : arith v62.
-
-Lemma mult_plus_distr_r : (n,m,p:nat) (mult n (plus m p))=(plus (mult n m) (mult n p)).
-Proof.
-  NewInduction n. Trivial.
-  Intros. Simpl. Rewrite (IHn m p). Apply sym_eq. Apply plus_permute_2_in_4.
-Qed.
-
-Lemma mult_minus_distr : (n,m,p:nat)((mult (minus n m) p)=(minus (mult n p) (mult m p))).
-Proof.
-Intros; Pattern n m; Apply nat_double_ind; Simpl; Intros; Auto with arith.
-Elim minus_plus_simpl; Auto with arith.
-Qed.
-Hints Resolve mult_minus_distr : arith v62.
-
-(** Associativity *)
-
-Lemma mult_assoc_r : (n,m,p:nat)((mult (mult n m) p) = (mult n (mult m p))).
-Proof.
-Intros; Elim n; Intros; Simpl; Auto with arith.
-Rewrite mult_plus_distr.
-Elim H; Auto with arith.
-Qed.
-Hints Resolve mult_assoc_r : arith v62.
-
-Lemma mult_assoc_l : (n,m,p:nat)(mult n (mult m p)) = (mult (mult n m) p).
-Proof.
-Auto with arith.
-Qed.
-Hints Resolve mult_assoc_l : arith v62.
-
-(** Commutativity *)
-
-Lemma mult_sym : (n,m:nat)(mult n m)=(mult m n).
-Proof.
-Intros; Elim n; Intros; Simpl; Auto with arith.
-Elim mult_n_Sm.
-Elim H; Apply plus_sym.
-Qed.
-Hints Resolve mult_sym : arith v62.
-
-(** 1 is neutral *)
-
-Lemma mult_1_n : (n:nat)(mult (S O) n)=n.
-Proof.
-Simpl; Auto with arith.
-Qed.
-Hints Resolve mult_1_n : arith v62.
-
-Lemma mult_n_1 : (n:nat)(mult n (S O))=n.
-Proof.
-Intro; Elim mult_sym; Auto with arith.
-Qed.
-Hints Resolve mult_n_1 : arith v62.
-
-(** Compatibility with orders *)
-
-Lemma mult_O_le : (n,m:nat)(m=O)\/(le n (mult m n)).
-Proof.
-NewInduction m; Simpl; Auto with arith.
-Qed.
-Hints Resolve mult_O_le : arith v62.
-
-Lemma mult_le_compat_l : (n,m,p:nat) (le n m) -> (le (mult p n) (mult p m)).
-Proof.
-  NewInduction p as [|p IHp]. Intros. Simpl. Apply le_n.
-  Intros. Simpl. Apply le_plus_plus. Assumption.
-  Apply IHp. Assumption.
-Qed.
-Hints Resolve mult_le_compat_l : arith.
-V7only [
-Notation mult_le := [m,n,p:nat](mult_le_compat_l p n m).
-].
-
-
-Lemma le_mult_right : (m,n,p:nat)(le m n)->(le (mult m p) (mult n p)).
-Intros m n p H.
-Rewrite mult_sym. Rewrite (mult_sym n).
-Auto with arith.
-Qed.
-
-Lemma le_mult_mult :
-  (m,n,p,q:nat)(le m n)->(le p q)->(le (mult m p) (mult n q)).
-Proof.
-Intros m n p q Hmn Hpq; NewInduction Hmn.
-NewInduction Hpq.
-(* m*p<=m*p *)
-Apply le_n.
-(* m*p<=m*m0 -> m*p<=m*(S m0) *)
-Rewrite <- mult_n_Sm; Apply le_trans with (mult m m0).
-Assumption.
-Apply le_plus_l.
-(* m*p<=m0*q -> m*p<=(S m0)*q *)
-Simpl; Apply le_trans with (mult m0 q).
-Assumption.
-Apply le_plus_r.
-Qed.
-
-Lemma mult_lt : (m,n,p:nat) (lt n p) -> (lt (mult (S m) n) (mult (S m) p)).
-Proof.
-  Intro m; NewInduction m. Intros. Simpl. Rewrite <- plus_n_O. Rewrite <- plus_n_O. Assumption.
-  Intros. Exact (lt_plus_plus ? ? ? ? H (IHm ? ? H)).
-Qed.
-
-Hints Resolve mult_lt : arith.
-V7only [
-Notation lt_mult_left := mult_lt.
-(* Theorem lt_mult_left :
-   (x,y,z:nat) (lt x y) -> (lt (mult (S z) x) (mult (S z) y)).
-*)
-].
-
-Lemma lt_mult_right :
-  (m,n,p:nat) (lt m n) -> (lt (0) p) -> (lt (mult m p) (mult n p)).
-Intros m n p H H0.
-NewInduction p.
-Elim (lt_n_n ? H0).
-Rewrite mult_sym.
-Replace (mult n (S p)) with (mult (S p) n); Auto with arith.
-Qed.
-
-Lemma mult_le_conv_1 : (m,n,p:nat) (le (mult (S m) n) (mult (S m) p)) -> (le n p).
-Proof.
-  Intros m n p H. Elim (le_or_lt n p). Trivial.
-  Intro H0. Cut (lt (mult (S m) n) (mult (S m) n)). Intro. Elim (lt_n_n ? H1).
-  Apply le_lt_trans with m:=(mult (S m) p). Assumption.
-  Apply mult_lt. Assumption.
-Qed.
-
-(** n|->2*n and n|->2n+1 have disjoint image *)
-
-V7only [ (* From Zdivides *) ].
-Theorem odd_even_lem:
-  (p, q : ?)  ~ (plus (mult (2) p) (1)) = (mult (2) q).
-Intros p; Elim p; Auto.
-Intros q; Case q; Simpl.
-Red; Intros; Discriminate.
-Intros q'; Rewrite [x, y : ?]  (plus_sym x (S y)); Simpl; Red; Intros;
- Discriminate.
-Intros p' H q; Case q.
-Simpl; Red; Intros; Discriminate.
-Intros q'; Red; Intros H0; Case (H q').
-Replace (mult (S (S O)) q') with (minus (mult (S (S O)) (S q')) (2)).
-Rewrite <- H0; Simpl; Auto.
-Repeat Rewrite [x, y : ?]  (plus_sym x (S y)); Simpl; Auto.
-Simpl; Repeat Rewrite [x, y : ?]  (plus_sym x (S y)); Simpl; Auto.
-Case q'; Simpl; Auto.
-Qed.
-
-
-(** Tail-recursive mult *)
-
-(** [tail_mult] is an alternative definition for [mult] which is 
-    tail-recursive, whereas [mult] is not. This can be useful 
-    when extracting programs. *)
-
-Fixpoint mult_acc [s,m,n:nat] : nat := 
-   Cases n of 
-      O => s
-      | (S p) => (mult_acc (tail_plus m s) m p)
-    end.
-
-Lemma mult_acc_aux : (n,s,m:nat)(plus s (mult n m))= (mult_acc s m n).
-Proof.
-NewInduction n as [|p IHp]; Simpl;Auto.
-Intros s m; Rewrite <- plus_tail_plus; Rewrite <- IHp.
-Rewrite <- plus_assoc_r; Apply (f_equal2 nat nat);Auto.
-Rewrite plus_sym;Auto.
-Qed.
-
-Definition tail_mult := [n,m:nat](mult_acc O m n).
-
-Lemma mult_tail_mult : (n,m:nat)(mult n m)=(tail_mult n m).
-Proof.
-Intros; Unfold tail_mult; Rewrite <- mult_acc_aux;Auto.
-Qed.
-
-(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] 
-    and [mult] and simplify *)
-
-Tactic Definition TailSimpl := 
-   Repeat Rewrite <- plus_tail_plus; 
-   Repeat Rewrite <- mult_tail_mult; 
-   Simpl. 
diff --git a/theories7/Arith/Peano_dec.v b/theories7/Arith/Peano_dec.v
deleted file mode 100755
index 6646545a..00000000
--- a/theories7/Arith/Peano_dec.v
+++ /dev/null
@@ -1,36 +0,0 @@
-(************************************************************************)
-(*  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: Peano_dec.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-Require Decidable.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,x,y:nat.
-
-Theorem O_or_S : (n:nat)({m:nat|(S m)=n})+{O=n}.
-Proof.
-NewInduction n.
-Auto.
-Left; Exists n; Auto.
-Defined.
-
-Theorem eq_nat_dec : (n,m:nat){n=m}+{~(n=m)}.
-Proof.
-NewInduction n; NewInduction m; Auto.
-Elim (IHn m); Auto.
-Defined.
-
-Hints Resolve O_or_S eq_nat_dec : arith.
-
-Theorem dec_eq_nat:(x,y:nat)(decidable (x=y)).
-Intros x y; Unfold decidable; Elim (eq_nat_dec x y); Auto with arith.
-Defined.
-
diff --git a/theories7/Arith/Plus.v b/theories7/Arith/Plus.v
deleted file mode 100755
index 23488b4c..00000000
--- a/theories7/Arith/Plus.v
+++ /dev/null
@@ -1,223 +0,0 @@
-(************************************************************************)
-(*  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: Plus.v,v 1.5.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-(** Properties of addition *)
-
-Require Le.
-Require Lt.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,p,q:nat.
-
-(** Zero is neutral *)
-
-Lemma plus_0_l : (n:nat) (O+n)=n.
-Proof.
-Reflexivity.
-Qed.
-
-Lemma plus_0_r : (n:nat) (n+O)=n.
-Proof.
-Intro; Symmetry; Apply plus_n_O.
-Qed.
-
-(** Commutativity *)
-
-Lemma plus_sym : (n,m:nat)(n+m)=(m+n).
-Proof.
-Intros n m ; Elim n ; Simpl ; Auto with arith.
-Intros y H ; Elim (plus_n_Sm m y) ; Auto with arith.
-Qed.
-Hints Immediate plus_sym : arith v62.
-
-(** Associativity *)
-
-Lemma plus_Snm_nSm : (n,m:nat)((S n)+m)=(n+(S m)).
-Intros.
-Simpl.
-Rewrite -> (plus_sym n m).
-Rewrite -> (plus_sym n (S m)).
-Trivial with arith.
-Qed.
-
-Lemma plus_assoc_l : (n,m,p:nat)((n+(m+p))=((n+m)+p)).
-Proof.
-Intros n m p; Elim n; Simpl; Auto with arith.
-Qed.
-Hints Resolve plus_assoc_l : arith v62.
-
-Lemma plus_permute : (n,m,p:nat) ((n+(m+p))=(m+(n+p))).
-Proof. 
-Intros; Rewrite (plus_assoc_l m n p); Rewrite (plus_sym m n); Auto with arith.
-Qed.
-
-Lemma plus_assoc_r : (n,m,p:nat)(((n+m)+p)=(n+(m+p))).
-Proof.
-Auto with arith.
-Qed.
-Hints Resolve plus_assoc_r : arith v62.
-
-(** Simplification *)
-
-Lemma plus_reg_l : (m,p,n:nat)((n+m)=(n+p))->(m=p).
-Proof.
-Intros m p n; NewInduction n ; Simpl ; Auto with arith.
-Qed.
-V7only [
-(* Compatibility order of arguments *)
-Notation "'simpl_plus_l' c" := [a,b:nat](plus_reg_l a b c)
-  (at level 10, c at next level).
-Notation "'simpl_plus_l' c a" := [b:nat](plus_reg_l a b c)
-  (at level 10, a, c at next level).
-Notation "'simpl_plus_l' c a b" := (plus_reg_l a b c)
-  (at level 10, a, b, c at next level).
-Notation simpl_plus_l := plus_reg_l.
-].
-
-Lemma plus_le_reg_l : (n,m,p:nat)((p+n)<=(p+m))->(n<=m).
-Proof.
-NewInduction p; Simpl; Auto with arith.
-Qed.
-V7only [
-(* Compatibility order of arguments *)
-Notation "'simpl_le_plus_l' c" := [a,b:nat](plus_le_reg_l a b c)
-  (at level 10, c at next level).
-Notation "'simpl_le_plus_l' c a" := [b:nat](plus_le_reg_l a b c)
-  (at level 10, a, c at next level).
-Notation "'simpl_le_plus_l' c a b" := (plus_le_reg_l a b c)
-  (at level 10, a, b, c at next level).
-Notation simpl_le_plus_l := [p,n,m:nat](plus_le_reg_l n m p).
-].
-
-Lemma simpl_lt_plus_l : (n,m,p:nat) (p+n)<(p+m) -> n<m.
-Proof.
-NewInduction p; Simpl; Auto with arith.
-Qed.
-
-(** Compatibility with order *)
-
-Lemma le_reg_l : (n,m,p:nat) n<=m -> (p+n)<=(p+m).
-Proof.
-NewInduction p; Simpl; Auto with arith.
-Qed.
-Hints Resolve le_reg_l : arith v62.
-
-Lemma le_reg_r : (a,b,c:nat) a<=b -> (a+c)<=(b+c).
-Proof.
-NewInduction 1 ; Simpl; Auto with arith.
-Qed.
-Hints Resolve le_reg_r : arith v62.
-
-Lemma le_plus_l : (n,m:nat) n<=(n+m).
-Proof.
-NewInduction n; Simpl; Auto with arith.
-Qed.
-Hints Resolve le_plus_l : arith v62.
-
-Lemma le_plus_r : (n,m:nat) m<=(n+m).
-Proof.
-Intros n m; Elim n; Simpl; Auto with arith.
-Qed.
-Hints Resolve le_plus_r : arith v62.
-
-Theorem le_plus_trans : (n,m,p:nat) n<=m -> n<=(m+p).
-Proof.
-Intros; Apply le_trans with m:=m; Auto with arith.
-Qed.
-Hints Resolve le_plus_trans : arith v62.
-
-Theorem lt_plus_trans : (n,m,p:nat) n<m -> n<(m+p).
-Proof.
-Intros; Apply lt_le_trans with m:=m; Auto with arith.
-Qed.
-Hints Immediate lt_plus_trans : arith v62.
-
-Lemma lt_reg_l : (n,m,p:nat) n<m -> (p+n)<(p+m).
-Proof.
-NewInduction p; Simpl; Auto with arith.
-Qed.
-Hints Resolve lt_reg_l : arith v62.
-
-Lemma lt_reg_r : (n,m,p:nat) n<m -> (n+p)<(m+p).
-Proof.
-Intros n m p H ; Rewrite (plus_sym n p) ; Rewrite (plus_sym m p).
-Elim p; Auto with arith.
-Qed.
-Hints Resolve lt_reg_r : arith v62.
-
-Lemma le_plus_plus : (n,m,p,q:nat)  n<=m -> p<=q -> (n+p)<=(m+q).
-Proof.
-Intros n m p q H H0.
-Elim H; Simpl; Auto with arith.
-Qed.
-
-Lemma le_lt_plus_plus : (n,m,p,q:nat)  n<=m -> p<q -> (n+p)<(m+q).
-Proof.
-  Unfold lt. Intros. Change ((S n)+p)<=(m+q). Rewrite plus_Snm_nSm.
-  Apply le_plus_plus; Assumption.
-Qed.
-
-Lemma lt_le_plus_plus : (n,m,p,q:nat) n<m -> p<=q -> (n+p)<(m+q).
-Proof.
-  Unfold lt. Intros. Change ((S n)+p)<=(m+q). Apply le_plus_plus; Assumption.
-Qed.
-
-Lemma lt_plus_plus : (n,m,p,q:nat) n<m -> p<q -> (n+p)<(m+q).
-Proof.
-  Intros. Apply lt_le_plus_plus. Assumption.
-  Apply lt_le_weak. Assumption.
-Qed.
-
-(** Inversion lemmas *)
-
-Lemma plus_is_O : (m,n:nat) (m+n)=O -> m=O /\ n=O.
-Proof.
-  Intro m; NewDestruct m; Auto.
-  Intros. Discriminate H.
-Qed.
-
-Definition plus_is_one : 
-      (m,n:nat) (m+n)=(S O) -> {m=O /\ n=(S O)}+{m=(S O) /\ n=O}.
-Proof.
-  Intro m; NewDestruct m; Auto.
-  NewDestruct n; Auto.
-  Intros. 
-  Simpl in H. Discriminate H.
-Defined.
-
-(** Derived properties *)
-
-Lemma plus_permute_2_in_4 : (m,n,p,q:nat) ((m+n)+(p+q))=((m+p)+(n+q)).
-Proof.
-  Intros m n p q. 
-  Rewrite <- (plus_assoc_l m n (p+q)). Rewrite (plus_assoc_l n p q).
-  Rewrite (plus_sym n p). Rewrite <- (plus_assoc_l p n q). Apply plus_assoc_l.
-Qed.
-
-(** Tail-recursive plus *)
-
-(** [tail_plus] is an alternative definition for [plus] which is 
-    tail-recursive, whereas [plus] is not. This can be useful
-    when extracting programs. *)
-
-Fixpoint plus_acc [q,n:nat] : nat := 
-   Cases n of 
-      O => q
-      | (S p) => (plus_acc (S q) p)
-    end.
-
-Definition tail_plus := [n,m:nat](plus_acc m n).
-
-Lemma plus_tail_plus : (n,m:nat)(n+m)=(tail_plus n m).
-Unfold tail_plus; NewInduction n as [|n IHn]; Simpl; Auto.
-Intro m; Rewrite <- IHn; Simpl; Auto.
-Qed.
diff --git a/theories7/Arith/Wf_nat.v b/theories7/Arith/Wf_nat.v
deleted file mode 100755
index be1003ce..00000000
--- a/theories7/Arith/Wf_nat.v
+++ /dev/null
@@ -1,200 +0,0 @@
-(************************************************************************)
-(*  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: Wf_nat.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-(** Well-founded relations and natural numbers *)
-
-Require Lt.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Implicit Variables Type m,n,p:nat.
-
-Chapter  Well_founded_Nat.
-
-Variable A : Set.
-
-Variable f : A -> nat.
-Definition ltof := [a,b:A](lt (f a) (f b)).
-Definition gtof := [a,b:A](gt (f b) (f a)).
-
-Theorem well_founded_ltof : (well_founded A ltof).
-Proof.
-Red.
-Cut (n:nat)(a:A)(lt (f a) n)->(Acc A ltof a).
-Intros H a;  Apply (H (S (f a))); Auto with arith.
-NewInduction n.
-Intros; Absurd (lt (f a) O); Auto with arith.
-Intros a ltSma.
-Apply Acc_intro.
-Unfold ltof; Intros b ltfafb.
-Apply IHn.
-Apply lt_le_trans with (f a); Auto with arith.
-Qed.
-
-Theorem  well_founded_gtof : (well_founded A gtof).
-Proof well_founded_ltof.
-
-(** It is possible to directly prove the induction principle going
-   back to primitive recursion on natural numbers ([induction_ltof1])
-   or to use the previous lemmas to extract a program with a fixpoint
-   ([induction_ltof2]) 
-
-the ML-like program for [induction_ltof1] is : [[
-   let induction_ltof1 F a = indrec ((f a)+1) a 
-   where rec indrec = 
-        function 0    -> (function a -> error)
-               |(S m) -> (function a -> (F a (function y -> indrec y m)));;
-]]
-
-the ML-like program for [induction_ltof2] is : [[
-   let induction_ltof2 F a = indrec a
-   where rec indrec a = F a indrec;;
-]] *)
-
-Theorem induction_ltof1 
-  : (P:A->Set)((x:A)((y:A)(ltof y x)->(P y))->(P x))->(a:A)(P a).
-Proof.
-Intros P F; Cut (n:nat)(a:A)(lt (f a) n)->(P a).
-Intros H a;  Apply (H (S (f a))); Auto with arith.
-NewInduction n.
-Intros; Absurd (lt (f a) O); Auto with arith.
-Intros a ltSma.
-Apply F.
-Unfold ltof; Intros b ltfafb.
-Apply IHn.
-Apply lt_le_trans with (f a); Auto with arith.
-Defined. 
-
-Theorem induction_gtof1 
-  : (P:A->Set)((x:A)((y:A)(gtof y x)->(P y))->(P x))->(a:A)(P a).
-Proof.
-Exact induction_ltof1.
-Defined.
-
-Theorem induction_ltof2 
-  : (P:A->Set)((x:A)((y:A)(ltof y x)->(P y))->(P x))->(a:A)(P a).
-Proof.
-Exact (well_founded_induction A ltof well_founded_ltof).
-Defined.
-
-Theorem induction_gtof2 
-  : (P:A->Set)((x:A)((y:A)(gtof y x)->(P y))->(P x))->(a:A)(P a).
-Proof.
-Exact induction_ltof2.
-Defined.
-
-(** If a relation [R] is compatible with [lt] i.e. if [x R y => f(x) < f(y)]
-    then [R] is well-founded. *)
-
-Variable R : A->A->Prop.
-
-Hypothesis H_compat : (x,y:A) (R x y) -> (lt (f x) (f y)).
-
-Theorem well_founded_lt_compat : (well_founded A R).
-Proof.
-Red.
-Cut (n:nat)(a:A)(lt (f a) n)->(Acc A R a).
-Intros H a; Apply (H (S (f a))); Auto with arith.
-NewInduction n.
-Intros; Absurd (lt (f a) O); Auto with arith.
-Intros a ltSma.
-Apply Acc_intro.
-Intros b ltfafb.
-Apply IHn.
-Apply lt_le_trans with (f a); Auto with arith.
-Qed.
-
-End Well_founded_Nat.
-
-Lemma lt_wf : (well_founded nat lt).
-Proof (well_founded_ltof nat [m:nat]m).
-
-Lemma lt_wf_rec1 : (p:nat)(P:nat->Set)
-              ((n:nat)((m:nat)(lt m n)->(P m))->(P n)) -> (P p).
-Proof.
-Exact [p:nat][P:nat->Set][F:(n:nat)((m:nat)(lt m n)->(P m))->(P n)]
-     (induction_ltof1 nat [m:nat]m P F p).
-Defined.
-
-Lemma lt_wf_rec : (p:nat)(P:nat->Set)
-              ((n:nat)((m:nat)(lt m n)->(P m))->(P n)) -> (P p).
-Proof.
-Exact [p:nat][P:nat->Set][F:(n:nat)((m:nat)(lt m n)->(P m))->(P n)]
-     (induction_ltof2 nat [m:nat]m P F p).
-Defined.
-
-Lemma lt_wf_ind : (p:nat)(P:nat->Prop)
-              ((n:nat)((m:nat)(lt m n)->(P m))->(P n)) -> (P p).
-Intro p; Intros; Elim (lt_wf p); Auto with arith.
-Qed.
-
-Lemma gt_wf_rec : (p:nat)(P:nat->Set)
-              ((n:nat)((m:nat)(gt n m)->(P m))->(P n)) -> (P p).
-Proof.
-Exact lt_wf_rec.
-Defined.
-
-Lemma gt_wf_ind : (p:nat)(P:nat->Prop)
-              ((n:nat)((m:nat)(gt n m)->(P m))->(P n)) -> (P p).
-Proof lt_wf_ind.
-
-Lemma lt_wf_double_rec : 
-  (P:nat->nat->Set)
-  ((n,m:nat)((p,q:nat)(lt p n)->(P p q))->((p:nat)(lt p m)->(P n p))->(P n m))
-   -> (p,q:nat)(P p q).
-Intros P Hrec p; Pattern p; Apply lt_wf_rec.
-Intros n H q; Pattern q; Apply lt_wf_rec; Auto with arith.
-Defined.
-
-Lemma lt_wf_double_ind : 
-  (P:nat->nat->Prop)
-  ((n,m:nat)((p,q:nat)(lt p n)->(P p q))->((p:nat)(lt p m)->(P n p))->(P n m))
-   -> (p,q:nat)(P p q).
-Intros P Hrec p; Pattern p; Apply lt_wf_ind.
-Intros n H q; Pattern q; Apply lt_wf_ind; Auto with arith.
-Qed.
-
-Hints Resolve lt_wf : arith.
-Hints Resolve well_founded_lt_compat : arith.
-
-Section LT_WF_REL.
-Variable A :Set.
-Variable R:A->A->Prop.
-
-(* Relational form of inversion *)
-Variable F : A -> nat -> Prop.
-Definition inv_lt_rel 
- [x,y]:=(EX n | (F x n) & (m:nat)(F y m)->(lt n m)).
-
-Hypothesis F_compat : (x,y:A) (R x y) -> (inv_lt_rel x y).
-Remark acc_lt_rel : 
-  (x:A)(EX n | (F x n))->(Acc A R x).
-Intros x (n,fxn); Generalize x fxn; Clear x fxn.
-Pattern n; Apply lt_wf_ind; Intros.
-Constructor; Intros.
-Case (F_compat y x); Trivial; Intros.
-Apply (H x0); Auto.
-Save.
-
-Theorem well_founded_inv_lt_rel_compat : (well_founded A R).
-Constructor; Intros.
-Case (F_compat y a); Trivial; Intros.
-Apply acc_lt_rel; Trivial.
-Exists x; Trivial.
-Save.
-
-
-End LT_WF_REL.
-
-Lemma well_founded_inv_rel_inv_lt_rel 
-  : (A:Set)(F:A->nat->Prop)(well_founded A (inv_lt_rel A F)).
-Intros; Apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); Trivial.
-Save.
diff --git a/theories7/Bool/Bool.v b/theories7/Bool/Bool.v
deleted file mode 100755
index cd75cf30..00000000
--- a/theories7/Bool/Bool.v
+++ /dev/null
@@ -1,544 +0,0 @@
-(************************************************************************)
-(*  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: Bool.v,v 1.2.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-(** Booleans  *)
-
-(** The type [bool] is defined in the prelude as
-    [Inductive bool : Set := true : bool | false : bool] *)
-
-(** Interpretation of booleans as Proposition *)
-Definition Is_true := [b:bool](Cases b of
-                                 true  => True
-                               | false => False
-                               end).
-Hints Unfold Is_true : bool.
-
-Lemma Is_true_eq_left : (x:bool)x=true -> (Is_true x).
-Proof.
-  Intros; Rewrite H; Auto with bool.
-Qed.
-
-Lemma Is_true_eq_right : (x:bool)true=x -> (Is_true x).
-Proof.
-  Intros; Rewrite <- H; Auto with bool.
-Qed.
-
-Hints Immediate Is_true_eq_right Is_true_eq_left : bool.
-
-(*******************)
-(** Discrimination *)
-(*******************)
-
-Lemma diff_true_false : ~true=false.
-Proof.
-Unfold not; Intro contr; Change (Is_true false).
-Elim contr; Simpl; Trivial with bool.
-Qed.
-Hints Resolve diff_true_false : bool v62.
-
-Lemma diff_false_true : ~false=true.
-Proof.
-Red; Intros H; Apply diff_true_false.
-Symmetry.
-Assumption.
-Qed.
-Hints Resolve diff_false_true : bool v62.
-
-Lemma eq_true_false_abs : (b:bool)(b=true)->(b=false)->False.
-Intros b H; Rewrite H; Auto with bool.
-Qed.
-Hints Resolve eq_true_false_abs : bool.
-
-Lemma not_true_is_false : (b:bool)~b=true->b=false.
-NewDestruct b.
-Intros.
-Red in H; Elim H.
-Reflexivity.
-Intros abs.
-Reflexivity.
-Qed.
-
-Lemma not_false_is_true : (b:bool)~b=false->b=true.
-NewDestruct b.
-Intros.
-Reflexivity.
-Intro H; Red in H; Elim H.
-Reflexivity.
-Qed.
-
-(**********************)
-(** Order on booleans *)
-(**********************)
-
-Definition leb := [b1,b2:bool]
-  Cases b1 of 
-  | true => b2=true
-  | false => True 
-  end.
-Hints Unfold leb : bool v62.
-
-(*************)
-(** Equality *)
-(*************)
-
-Definition eqb : bool->bool->bool :=
- [b1,b2:bool]
-    Cases b1 b2 of
-      true  true  => true
-    | true  false => false
-    | false true  => false
-    | false false => true
-    end.
-
-Lemma eqb_refl : (x:bool)(Is_true (eqb x x)).
-NewDestruct x; Simpl; Auto with bool.
-Qed.
-
-Lemma eqb_eq : (x,y:bool)(Is_true (eqb x y))->x=y.
-NewDestruct x; NewDestruct y; Simpl; Tauto.
-Qed.
-
-Lemma Is_true_eq_true : (x:bool) (Is_true x) -> x=true.
-NewDestruct x; Simpl; Tauto.
-Qed.
- 
-Lemma Is_true_eq_true2 : (x:bool)  x=true -> (Is_true x).
-NewDestruct x; Simpl; Auto with bool.
-Qed.
-
-Lemma eqb_subst : 
-  (P:bool->Prop)(b1,b2:bool)(eqb b1 b2)=true->(P b1)->(P b2).
-Unfold eqb .
-Intros P b1.
-Intros b2.
-Case b1.
-Case b2.
-Trivial with bool.
-Intros H.
-Inversion_clear H.
-Case b2.
-Intros H.
-Inversion_clear H.
-Trivial with bool.
-Qed.
-
-Lemma eqb_reflx : (b:bool)(eqb b b)=true.
-Intro b.
-Case b.
-Trivial with bool.
-Trivial with bool.
-Qed.
-
-Lemma eqb_prop : (a,b:bool)(eqb a b)=true -> a=b.
-NewDestruct a; NewDestruct b; Simpl; Intro;
-  Discriminate H Orelse Reflexivity.
-Qed.
-
-
-(************************)
-(** Logical combinators *)
-(************************)
- 
-Definition ifb : bool -> bool -> bool -> bool
-     := [b1,b2,b3:bool](Cases b1 of true => b2 | false => b3 end).
-
-Definition andb : bool -> bool -> bool
-     := [b1,b2:bool](ifb b1 b2 false).
-
-Definition orb : bool -> bool -> bool
-     := [b1,b2:bool](ifb b1 true b2).
-
-Definition implb : bool -> bool -> bool
-     := [b1,b2:bool](ifb b1 b2 true).
-
-Definition xorb :  bool -> bool -> bool
-     := [b1,b2:bool]
-    Cases b1 b2 of
-      true  true  => false
-    | true  false => true
-    | false true  => true
-    | false false => false
-    end.
-
-Definition negb := [b:bool]Cases b of
-                             true  => false
-                           | false => true
-                           end.
-
-Infix "||" orb  (at level 4, left associativity) : bool_scope.
-Infix "&&" andb (at level 3, no associativity) : bool_scope
-  V8only (at level 40, left associativity).
-
-Open Scope bool_scope.
-
-Delimits Scope bool_scope with bool.
-
-Bind Scope bool_scope with bool.
-
-(**************************)
-(** Lemmas about [negb]   *)
-(**************************)
-
-Lemma negb_intro : (b:bool)b=(negb (negb b)).
-Proof.
-NewDestruct b; Reflexivity.
-Qed.
-
-Lemma negb_elim : (b:bool)(negb (negb b))=b.
-Proof.
-NewDestruct b; Reflexivity.
-Qed.
-       
-Lemma negb_orb : (b1,b2:bool)
-  (negb (orb b1 b2)) = (andb (negb b1) (negb b2)).
-Proof.
-  NewDestruct b1; NewDestruct b2; Simpl; Reflexivity.
-Qed.
-
-Lemma negb_andb : (b1,b2:bool)
-  (negb (andb b1 b2)) = (orb (negb b1) (negb b2)).
-Proof.
-  NewDestruct b1; NewDestruct b2; Simpl; Reflexivity.
-Qed.
-
-Lemma negb_sym : (b,b':bool)(b'=(negb b))->(b=(negb b')).
-Proof.
-NewDestruct b; NewDestruct b'; Intros; Simpl; Trivial with bool.
-Qed.
-
-Lemma no_fixpoint_negb : (b:bool)~(negb b)=b.
-Proof.
-NewDestruct b; Simpl; Intro; Apply diff_true_false; Auto with bool.
-Qed.
-
-Lemma eqb_negb1 : (b:bool)(eqb (negb b) b)=false.
-NewDestruct b.
-Trivial with bool.
-Trivial with bool.
-Qed.
- 
-Lemma eqb_negb2 : (b:bool)(eqb b (negb b))=false.
-NewDestruct b.
-Trivial with bool.
-Trivial with bool.
-Qed.
-
-
-Lemma if_negb : (A:Set) (b:bool) (x,y:A) (if (negb b) then x else y)=(if b then y else x).
-Proof.
-  NewDestruct b;Trivial.
-Qed.
-
-
-(****************************)
-(** A few lemmas about [or] *)
-(****************************)
-
-Lemma orb_prop : 
-  (a,b:bool)(orb a b)=true -> (a = true)\/(b = true).
-NewDestruct a; NewDestruct b; Simpl; Try (Intro H;Discriminate H); Auto with bool.
-Qed.
-
-Lemma orb_prop2 : 
-  (a,b:bool)(Is_true (orb a b)) -> (Is_true a)\/(Is_true b).
-NewDestruct a; NewDestruct b; Simpl; Try (Intro H;Discriminate H); Auto with bool.
-Qed.
-
-Lemma orb_true_intro 
-    : (b1,b2:bool)(b1=true)\/(b2=true)->(orb b1 b2)=true.
-NewDestruct b1; Auto with bool.
-NewDestruct 1; Intros.
-Elim diff_true_false; Auto with bool.
-Rewrite H; Trivial with bool.
-Qed.
-Hints Resolve orb_true_intro : bool v62.
-
-Lemma orb_b_true : (b:bool)(orb b true)=true.
-Auto with bool.
-Qed.
-Hints Resolve orb_b_true : bool v62.
-
-Lemma orb_true_b : (b:bool)(orb true b)=true.
-Trivial with bool.
-Qed.
-
-Definition orb_true_elim : (b1,b2:bool)(orb b1 b2)=true -> {b1=true}+{b2=true}.
-NewDestruct b1; Simpl; Auto with bool.
-Defined.
-
-Lemma orb_false_intro 
-    : (b1,b2:bool)(b1=false)->(b2=false)->(orb b1 b2)=false.
-Intros b1 b2 H1 H2; Rewrite H1; Rewrite H2; Trivial with bool.
-Qed.
-Hints Resolve orb_false_intro : bool v62.
-
-Lemma orb_b_false : (b:bool)(orb b false)=b.
-Proof.
-  NewDestruct b; Trivial with bool.
-Qed.
-Hints Resolve orb_b_false : bool v62.
-
-Lemma orb_false_b : (b:bool)(orb false b)=b.
-Proof.
-  NewDestruct b; Trivial with bool.
-Qed.
-Hints Resolve orb_false_b : bool v62.
-
-Lemma orb_false_elim : 
-    (b1,b2:bool)(orb b1 b2)=false -> (b1=false)/\(b2=false).
-Proof.
-  NewDestruct b1.
-  Intros; Elim diff_true_false; Auto with bool.
-  NewDestruct b2.
-  Intros; Elim diff_true_false; Auto with bool.
-  Auto with bool.
-Qed.
-
-Lemma orb_neg_b :
-  (b:bool)(orb b (negb b))=true.
-Proof.
-  NewDestruct b; Reflexivity.
-Qed.
-Hints Resolve orb_neg_b : bool v62.
-
-Lemma orb_sym : (b1,b2:bool)(orb b1 b2)=(orb b2 b1).
-NewDestruct b1; NewDestruct b2; Reflexivity.
-Qed.
-
-Lemma orb_assoc : (b1,b2,b3:bool)(orb b1 (orb b2 b3))=(orb (orb b1 b2) b3).
-Proof.
-  NewDestruct b1; NewDestruct b2; NewDestruct b3; Reflexivity.
-Qed.
-
-Hints Resolve orb_sym orb_assoc orb_b_false orb_false_b : bool v62.
-
-(*****************************)
-(** A few lemmas about [and] *)
-(*****************************)
-
-Lemma andb_prop : 
-  (a,b:bool)(andb a b) = true -> (a = true)/\(b = true).
-
-Proof.
-  NewDestruct a; NewDestruct b; Simpl; Try (Intro H;Discriminate H);
-  Auto with bool.
-Qed.
-Hints Resolve andb_prop : bool v62.
-
-Definition andb_true_eq : (a,b:bool) true = (andb a b) -> true = a /\ true = b.
-Proof.
-  NewDestruct a; NewDestruct b; Auto.
-Defined.
-
-Lemma andb_prop2 : 
-  (a,b:bool)(Is_true (andb a b)) -> (Is_true a)/\(Is_true b).
-Proof.
-  NewDestruct a; NewDestruct b; Simpl; Try (Intro H;Discriminate H);
-  Auto with bool.
-Qed.
-Hints Resolve andb_prop2 : bool v62.
-
-Lemma andb_true_intro : (b1,b2:bool)(b1=true)/\(b2=true)->(andb b1 b2)=true.
-Proof.
-  NewDestruct b1; NewDestruct b2; Simpl; Tauto Orelse Auto with bool.
-Qed.
-Hints Resolve andb_true_intro : bool v62.
-
-Lemma andb_true_intro2 : 
-  (b1,b2:bool)(Is_true b1)->(Is_true b2)->(Is_true (andb b1 b2)).
-Proof.
-  NewDestruct b1; NewDestruct b2; Simpl; Tauto.
-Qed.
-Hints Resolve andb_true_intro2 : bool v62.
-
-Lemma andb_false_intro1 
-    : (b1,b2:bool)(b1=false)->(andb b1 b2)=false.
-NewDestruct b1; NewDestruct b2; Simpl; Tauto Orelse Auto with bool.
-Qed.
-
-Lemma andb_false_intro2 
-    : (b1,b2:bool)(b2=false)->(andb b1 b2)=false.
-NewDestruct b1; NewDestruct b2; Simpl; Tauto Orelse Auto with bool.
-Qed.
-
-Lemma andb_b_false : (b:bool)(andb b false)=false.
-NewDestruct b; Auto with bool.
-Qed.
-
-Lemma andb_false_b : (b:bool)(andb false b)=false.
-Trivial with bool.
-Qed.
-
-Lemma andb_b_true : (b:bool)(andb b true)=b.
-NewDestruct b; Auto with bool.
-Qed.
-
-Lemma andb_true_b : (b:bool)(andb true b)=b.
-Trivial with bool.
-Qed.
-
-Definition andb_false_elim : 
-    (b1,b2:bool)(andb b1 b2)=false -> {b1=false}+{b2=false}.
-NewDestruct b1; Simpl; Auto with bool.
-Defined.
-Hints Resolve andb_false_elim : bool v62.
-
-Lemma andb_neg_b :
-   (b:bool)(andb b (negb b))=false.
-NewDestruct b; Reflexivity.
-Qed.   
-Hints Resolve andb_neg_b : bool v62.
-
-Lemma andb_sym : (b1,b2:bool)(andb b1 b2)=(andb b2 b1).
-NewDestruct b1; NewDestruct b2; Reflexivity.
-Qed.
-
-Lemma andb_assoc : (b1,b2,b3:bool)(andb b1 (andb b2 b3))=(andb (andb b1 b2) b3).
-NewDestruct b1; NewDestruct b2; NewDestruct b3; Reflexivity.
-Qed.
-
-Hints Resolve andb_sym andb_assoc : bool v62.
-
-(*******************************)
-(** Properties of [xorb]       *)
-(*******************************)
-
-Lemma xorb_false : (b:bool) (xorb b false)=b.
-Proof.
-  NewDestruct b; Trivial.
-Qed.
-
-Lemma false_xorb : (b:bool) (xorb false b)=b.
-Proof.
-  NewDestruct b; Trivial.
-Qed.
-
-Lemma xorb_true : (b:bool) (xorb b true)=(negb b).
-Proof.
-  Trivial.
-Qed.
-
-Lemma true_xorb : (b:bool) (xorb true b)=(negb b).
-Proof.
-  NewDestruct b; Trivial.
-Qed.
-
-Lemma xorb_nilpotent : (b:bool) (xorb b b)=false.
-Proof.
-  NewDestruct b; Trivial.
-Qed.
-
-Lemma xorb_comm : (b,b':bool) (xorb b b')=(xorb b' b).
-Proof.
-  NewDestruct b; NewDestruct b'; Trivial.
-Qed.
-
-Lemma xorb_assoc : (b,b',b'':bool) (xorb (xorb b b') b'')=(xorb b (xorb b' b'')).
-Proof.
-  NewDestruct b; NewDestruct b'; NewDestruct b''; Trivial.
-Qed.
-
-Lemma xorb_eq : (b,b':bool) (xorb b b')=false -> b=b'.
-Proof.
-  NewDestruct b; NewDestruct b'; Trivial.
-  Unfold xorb. Intros. Rewrite H. Reflexivity.
-Qed.
-
-Lemma xorb_move_l_r_1 : (b,b',b'':bool) (xorb b b')=b'' -> b'=(xorb b b'').
-Proof.
-  Intros. Rewrite <- (false_xorb b'). Rewrite <- (xorb_nilpotent b). Rewrite xorb_assoc.
-  Rewrite H. Reflexivity.
-Qed.
-
-Lemma xorb_move_l_r_2 : (b,b',b'':bool) (xorb b b')=b'' -> b=(xorb b'' b').
-Proof.
-  Intros. Rewrite xorb_comm in H. Rewrite (xorb_move_l_r_1 b' b b'' H). Apply xorb_comm.
-Qed.
-
-Lemma xorb_move_r_l_1 : (b,b',b'':bool) b=(xorb b' b'') -> (xorb b' b)=b''.
-Proof.
-  Intros. Rewrite H. Rewrite <- xorb_assoc. Rewrite xorb_nilpotent. Apply false_xorb.
-Qed.
-
-Lemma xorb_move_r_l_2 : (b,b',b'':bool) b=(xorb b' b'') -> (xorb b b'')=b'.
-Proof.
-  Intros. Rewrite H. Rewrite xorb_assoc. Rewrite xorb_nilpotent. Apply xorb_false.
-Qed.
-
-(*******************************)
-(** De Morgan's law            *)
-(*******************************)
-
-Lemma demorgan1 : (b1,b2,b3:bool)
-  (andb b1 (orb b2 b3)) = (orb (andb b1 b2) (andb b1 b3)).
-NewDestruct b1; NewDestruct b2; NewDestruct b3; Reflexivity.
-Qed.
-
-Lemma demorgan2 : (b1,b2,b3:bool)
-  (andb (orb b1 b2) b3) = (orb (andb b1 b3) (andb b2 b3)).
-NewDestruct b1; NewDestruct b2; NewDestruct b3; Reflexivity.
-Qed.
-
-Lemma demorgan3 : (b1,b2,b3:bool)
-  (orb b1 (andb b2 b3)) = (andb (orb b1 b2) (orb b1 b3)).
-NewDestruct b1; NewDestruct b2; NewDestruct b3; Reflexivity.
-Qed.
-
-Lemma demorgan4 : (b1,b2,b3:bool)
-  (orb (andb b1 b2) b3) = (andb (orb b1 b3) (orb b2 b3)).
-NewDestruct b1; NewDestruct b2; NewDestruct b3; Reflexivity.
-Qed.
-
-Lemma absoption_andb : (b1,b2:bool)
-  (andb b1 (orb b1 b2)) = b1.
-Proof.
-  NewDestruct b1; NewDestruct b2; Simpl; Reflexivity.
-Qed.
-
-Lemma absoption_orb : (b1,b2:bool)
-  (orb b1 (andb b1 b2)) = b1.
-Proof.
-  NewDestruct b1; NewDestruct b2; Simpl; Reflexivity.
-Qed.
-
-
-(** Misc. equalities between booleans (to be used by Auto) *)
-
-Lemma bool_1 : (b1,b2:bool)(b1=true <-> b2=true) -> b1=b2. 
-Proof. 
- Intros b1 b2; Case b1; Case b2; Intuition.
-Qed.
-
-Lemma bool_2 : (b1,b2:bool)b1=b2 -> b1=true -> b2=true.
-Proof. 
- Intros b1 b2; Case b1; Case b2; Intuition.
-Qed. 
-
-Lemma bool_3 : (b:bool) ~(negb b)=true -> b=true.
-Proof.
-  NewDestruct b; Intuition.
-Qed.
-
-Lemma bool_4 : (b:bool) b=true -> ~(negb b)=true.  
-Proof.
-  NewDestruct b; Intuition.
-Qed.
-
-Lemma bool_5 : (b:bool) (negb b)=true -> ~b=true.
-Proof.
-  NewDestruct b; Intuition.
-Qed.
-
-Lemma bool_6 : (b:bool) ~b=true -> (negb b)=true.  
-Proof.
-  NewDestruct b; Intuition.
-Qed.
-
-Hints Resolve bool_1 bool_2 bool_3 bool_4 bool_5 bool_6.
diff --git a/theories7/Bool/BoolEq.v b/theories7/Bool/BoolEq.v
deleted file mode 100644
index b670dbdd..00000000
--- a/theories7/Bool/BoolEq.v
+++ /dev/null
@@ -1,72 +0,0 @@
-(************************************************************************)
-(*  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: BoolEq.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-(* Cuihtlauac Alvarado - octobre 2000 *)
-
-(** Properties of a boolean equality   *)
-
-
-Require Export Bool.
-
-Section Bool_eq_dec.
-
-  Variable A : Set.
-
-  Variable beq : A -> A -> bool.
-
-  Variable beq_refl : (x:A)true=(beq x x).
-
-  Variable beq_eq : (x,y:A)true=(beq x y)->x=y.
-
-  Definition beq_eq_true : (x,y:A)x=y->true=(beq x y).
-  Proof.
-    Intros x y H.
-    Case H.
-    Apply beq_refl.
-  Defined.
-
-  Definition beq_eq_not_false : (x,y:A)x=y->~false=(beq x y).
-  Proof.
-    Intros x y e.
-    Rewrite <- beq_eq_true; Trivial; Discriminate.
-  Defined.
-
-  Definition beq_false_not_eq : (x,y:A)false=(beq x y)->~x=y.
-  Proof.
-    Exact [x,y:A; H:(false=(beq x y)); e:(x=y)](beq_eq_not_false x y e H).
-  Defined.
-
-  Definition exists_beq_eq : (x,y:A){b:bool | b=(beq x y)}.
-  Proof.
-    Intros.
-    Exists (beq x y).
-    Constructor.
-  Defined.
-
-  Definition not_eq_false_beq : (x,y:A)~x=y->false=(beq x y).
-  Proof.
-    Intros x y H.
-    Symmetry.
-    Apply not_true_is_false.
-    Intro.
-    Apply H.
-    Apply beq_eq.
-    Symmetry.
-    Assumption.
-  Defined.
-
-  Definition eq_dec : (x,y:A){x=y}+{~x=y}.
-  Proof.
-    Intros x y; Case (exists_beq_eq x y).
-    Intros b; Case b; Intro H.
-      Left; Apply beq_eq; Assumption.
-      Right; Apply beq_false_not_eq; Assumption.
-  Defined.
-
-End Bool_eq_dec.
diff --git a/theories7/Bool/Bvector.v b/theories7/Bool/Bvector.v
deleted file mode 100644
index e6545381..00000000
--- a/theories7/Bool/Bvector.v
+++ /dev/null
@@ -1,266 +0,0 @@
-(************************************************************************)
-(*  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: Bvector.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-(** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)
-
-Require Export Bool.
-Require Export Sumbool.
-Require Arith.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-(*  
-On s'inspire de PolyList pour fabriquer les vecteurs de bits.
-La dimension du vecteur est un paramètre trop important pour
-se contenter de la fonction "length".
-La première idée est de faire un record avec la liste et la longueur.
-Malheureusement, cette verification a posteriori amene a faire
-de nombreux lemmes pour gerer les longueurs.
-La seconde idée est de faire un type dépendant dans lequel la
-longueur est un paramètre de construction. Cela complique un
-peu les inductions structurelles, la solution qui a ma préférence
-est alors d'utiliser un terme de preuve comme définition.
-
-(En effet une définition comme :
-Fixpoint Vunaire [n:nat; v:(vector n)]: (vector n) :=
-Cases v of
-	| Vnil => Vnil
-	| (Vcons a p v') => (Vcons (f a) p (Vunaire p v'))
-end.
-provoque ce message d'erreur :
-Coq < Error: Inference of annotation not yet implemented in this case).
-
-
-	Inductive list [A : Set]  : Set :=
-		nil : (list A) | cons : A->(list A)->(list A).
-	head = [A:Set; l:(list A)] Cases l of
-			| nil => Error
- 			| (cons x _) => (Value x)
- 			end
-     		: (A:Set)(list A)->(option A).
-	tail = [A:Set; l:(list A)]Cases l of
-                   			| nil => (nil A)
-                   			| (cons _ m) => m
-                   			end
-     		: (A:Set)(list A)->(list A).
-	length = [A:Set] Fix length {length [l:(list A)] : nat :=
-      		Cases l of
-       			| nil => O
-      			| (cons _ m) => (S (length m))
-      		end}
-     		: (A:Set)(list A)->nat.
-	map = [A,B:Set; f:(A->B)] Fix map {map [l:(list A)] : (list B) :=
-		Cases l of
-			| nil => (nil B)
-			| (cons a t) => (cons (f a) (map t))
-		end}
-		: (A,B:Set)(A->B)->(list A)->(list B)
-*)
-
-Section VECTORS.
-
-(* 
-Un vecteur est une liste de taille n d'éléments d'un ensemble A.
-Si la taille est non nulle, on peut extraire la première composante et 
-le reste du vecteur, la dernière composante ou rajouter ou enlever 
-une composante (carry) ou repeter la dernière composante en fin de vecteur.
-On peut aussi tronquer le vecteur de ses p dernières composantes ou
-au contraire l'étendre (concaténer) d'un vecteur de longueur p.
-Une fonction unaire sur A génère une fonction des vecteurs de taille n
-dans les vecteurs de taille n en appliquant f terme à terme.
-Une fonction binaire sur A génère une fonction des couple de vecteurs 
-de taille n dans les vecteurs de taille n en appliquant f terme à terme.
-*)
-
-Variable A : Set.
-
-Inductive vector: nat -> Set :=
-	| Vnil : (vector O)
-	| Vcons  : (a:A) (n:nat) (vector n) -> (vector (S n)).
-
-Definition Vhead : (n:nat) (vector (S n)) -> A.
-Proof.
-	Intros n v; Inversion v; Exact a.
-Defined.
-
-Definition Vtail : (n:nat) (vector (S n)) -> (vector n).
-Proof.
-	Intros n v; Inversion v; Exact H0.
-Defined.
-
-Definition Vlast : (n:nat) (vector (S n)) -> A.
-Proof.
-	NewInduction n as [|n f]; Intro v.
-	Inversion v.
-	Exact a.
-
-	Inversion v.
-	Exact (f H0).
-Defined.
-
-Definition Vconst : (a:A) (n:nat) (vector n).
-Proof.
-	NewInduction n as [|n v].
-	Exact Vnil.
-
-	Exact (Vcons a n v).
-Defined.
-
-Lemma Vshiftout : (n:nat) (vector (S n)) -> (vector n).
-Proof.
-	NewInduction n as [|n f]; Intro v.
-	Exact Vnil.
-
-	Inversion v.
-	Exact (Vcons a n (f H0)).
-Defined.
-
-Lemma Vshiftin : (n:nat) A -> (vector n) -> (vector (S n)).
-Proof.
-	NewInduction n as [|n f]; Intros a v.
-	Exact (Vcons a O v).
-
-	Inversion v.
-	Exact (Vcons a (S n) (f a H0)).
-Defined.
-
-Lemma Vshiftrepeat : (n:nat) (vector (S n)) -> (vector (S (S n))).
-Proof.
-	NewInduction n as [|n f]; Intro v.
-	Inversion v.
-	Exact (Vcons a (1) v).
-
-	Inversion v.
-	Exact (Vcons a (S (S n)) (f H0)).
-Defined.
-
-(*
-Lemma S_minus_S : (n,p:nat) (gt n (S p)) -> (S (minus n (S p)))=(minus n p).
-Proof.
-  Intros.
-Save.
-*)
-
-Lemma Vtrunc : (n,p:nat) (gt n p) ->  (vector n) -> (vector (minus n p)).
-Proof.
-	NewInduction p as [|p f]; Intros H v.
-	Rewrite <- minus_n_O.
-	Exact v.
-
-	Apply (Vshiftout (minus n (S p))).
-
-Rewrite minus_Sn_m.
-Apply f.
-Auto with *.
-Exact v.
-Auto with *.
-Defined.
-
-Lemma Vextend : (n,p:nat) (vector n) ->  (vector p) -> (vector (plus n p)).
-Proof.
-	NewInduction n as [|n f]; Intros p v v0.
-	Simpl; Exact v0.
-
-	Inversion v.
-	Simpl; Exact (Vcons a (plus n p) (f p H0 v0)).
-Defined.
-
-Variable f : A -> A.
-
-Lemma Vunary : (n:nat)(vector n)->(vector n).
-Proof.
-	NewInduction n as [|n g]; Intro v.
-	Exact Vnil.
-
-	Inversion v.
-	Exact (Vcons (f a) n (g H0)).
-Defined.
-
-Variable g : A -> A -> A.
-
-Lemma Vbinary : (n:nat)(vector n)->(vector n)->(vector n).
-Proof.
-	NewInduction n as [|n h]; Intros v v0.
-	Exact Vnil.
-
-	Inversion v; Inversion v0.
-	Exact (Vcons (g a a0) n (h H0 H2)).
-Defined.
-
-End VECTORS.
-
-Section BOOLEAN_VECTORS.
-
-(* 
-Un vecteur de bits est un vecteur sur l'ensemble des booléens de longueur fixe. 
-ATTENTION : le stockage s'effectue poids FAIBLE en tête.
-On en extrait le bit  de poids faible (head) et la fin du vecteur (tail).
-On calcule la négation d'un vecteur, le et, le ou et le xor bit à bit de 2 vecteurs.
-On calcule les décalages d'une position vers la gauche (vers les poids forts, on
-utilise donc Vshiftout, vers la droite (vers les poids faibles, on utilise Vshiftin) en 
-insérant un bit 'carry' (logique) ou en répétant le bit de poids fort (arithmétique).
-ATTENTION : Tous les décalages prennent la taille moins un comme paramètre
-(ils ne travaillent que sur des vecteurs au moins de longueur un).
-*)
-
-Definition Bvector := (vector bool).
-
-Definition Bnil := (Vnil bool).
-
-Definition Bcons := (Vcons bool).
-
-Definition Bvect_true := (Vconst bool true).
-
-Definition Bvect_false := (Vconst bool false).
-
-Definition Blow := (Vhead bool).
-
-Definition Bhigh := (Vtail bool).
-
-Definition Bsign := (Vlast bool).
-
-Definition Bneg := (Vunary bool negb).
-
-Definition BVand := (Vbinary bool andb).
-
-Definition BVor := (Vbinary bool orb).
-
-Definition BVxor := (Vbinary bool xorb).
-
-Definition BshiftL := [n:nat; bv : (Bvector (S n)); carry:bool] 
-	(Bcons carry n (Vshiftout bool n bv)).
-
-Definition BshiftRl := [n:nat; bv : (Bvector (S n)); carry:bool] 
-	(Bhigh (S n) (Vshiftin bool (S n) carry bv)).
-
-Definition BshiftRa := [n:nat; bv : (Bvector (S n))] 
-	(Bhigh (S n) (Vshiftrepeat bool n bv)).
-
-Fixpoint BshiftL_iter [n:nat; bv:(Bvector (S n)); p:nat]:(Bvector (S n)) :=
-Cases p of
-	| O => bv
-	| (S p') => (BshiftL n (BshiftL_iter n bv p') false)
-end.
-
-Fixpoint BshiftRl_iter [n:nat; bv:(Bvector (S n)); p:nat]:(Bvector (S n)) :=
-Cases p of
-	| O => bv
-	| (S p') => (BshiftRl n (BshiftRl_iter n bv p') false)
-end.
-
-Fixpoint BshiftRa_iter [n:nat; bv:(Bvector (S n)); p:nat]:(Bvector (S n)) :=
-Cases p of
-	| O => bv
-	| (S p') => (BshiftRa n (BshiftRa_iter n bv p'))
-end.
-
-End BOOLEAN_VECTORS.
-
diff --git a/theories7/Bool/IfProp.v b/theories7/Bool/IfProp.v
deleted file mode 100755
index bcfa4be3..00000000
--- a/theories7/Bool/IfProp.v
+++ /dev/null
@@ -1,49 +0,0 @@
-(************************************************************************)
-(*  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: IfProp.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-Require Bool.
-
-Inductive IfProp [A,B:Prop] : bool-> Prop 
-  := Iftrue  : A -> (IfProp A B true)
-  |  Iffalse : B -> (IfProp A B false).
-
-Hints Resolve Iftrue Iffalse : bool v62.
-
-Lemma Iftrue_inv : (A,B:Prop)(b:bool) (IfProp A B b) -> b=true -> A.
-NewDestruct 1; Intros; Auto with bool.
-Case diff_true_false; Auto with bool.
-Qed.
-
-Lemma Iffalse_inv : (A,B:Prop)(b:bool) (IfProp A B b) -> b=false -> B.
-NewDestruct 1; Intros; Auto with bool.
-Case diff_true_false; Trivial with bool.
-Qed.
-
-Lemma IfProp_true : (A,B:Prop)(IfProp A B true) -> A.
-Intros.
-Inversion H.
-Assumption.
-Qed.
-
-Lemma IfProp_false : (A,B:Prop)(IfProp A B false) -> B.
-Intros.
-Inversion H.
-Assumption.
-Qed.
-
-Lemma IfProp_or : (A,B:Prop)(b:bool)(IfProp A B b) -> A\/B.
-NewDestruct 1; Auto with bool.
-Qed.
-
-Lemma IfProp_sum : (A,B:Prop)(b:bool)(IfProp A B b) -> {A}+{B}.
-NewDestruct b; Intro H.
-Left; Inversion H; Auto with bool.
-Right; Inversion H; Auto with bool.
-Qed.
diff --git a/theories7/Bool/Sumbool.v b/theories7/Bool/Sumbool.v
deleted file mode 100644
index 8d55cbb6..00000000
--- a/theories7/Bool/Sumbool.v
+++ /dev/null
@@ -1,77 +0,0 @@
-(************************************************************************)
-(*  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: Sumbool.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-(** Here are collected some results about the type sumbool (see INIT/Specif.v)
-   [sumbool A B], which is written [{A}+{B}], is the informative
-   disjunction "A or B", where A and B are logical propositions.
-   Its extraction is isomorphic to the type of booleans. *)
-
-(** A boolean is either [true] or [false], and this is decidable *)
-
-Definition sumbool_of_bool : (b:bool) {b=true}+{b=false}.
-Proof.
-  NewDestruct b; Auto.
-Defined.
-
-Hints Resolve sumbool_of_bool : bool.
-
-Definition bool_eq_rec : (b:bool)(P:bool->Set)
-                    ((b=true)->(P true))->((b=false)->(P false))->(P b).
-NewDestruct b; Auto.
-Defined.
-
-Definition bool_eq_ind : (b:bool)(P:bool->Prop)
-                    ((b=true)->(P true))->((b=false)->(P false))->(P b).
-NewDestruct b; Auto.
-Defined.
-
-
-(*i pourquoi ce machin-la est dans BOOL et pas dans LOGIC ?  Papageno i*)
-
-(** Logic connectives on type [sumbool] *)
-
-Section connectives.
-
-Variables A,B,C,D : Prop.
-
-Hypothesis H1 : {A}+{B}.
-Hypothesis H2 : {C}+{D}.
-
-Definition sumbool_and : {A/\C}+{B\/D}.
-Proof.
-Case H1; Case H2; Auto.
-Defined.
-
-Definition sumbool_or : {A\/C}+{B/\D}.
-Proof.
-Case H1; Case H2; Auto.
-Defined.
-
-Definition sumbool_not : {B}+{A}.
-Proof.
-Case H1; Auto.
-Defined.
-
-End connectives.
-
-Hints Resolve sumbool_and sumbool_or sumbool_not : core.
-
-
-(** Any decidability function in type [sumbool] can be turned into a function
-    returning a boolean with the corresponding specification: *)
-
-Definition bool_of_sumbool : 
-  (A,B:Prop) {A}+{B} -> { b:bool | if b then A else B }.
-Proof.
-Intros A B H.
-Elim H; [ Intro; Exists true; Assumption
-        | Intro; Exists false; Assumption ].
-Defined.
-Implicits bool_of_sumbool.
diff --git a/theories7/Bool/Zerob.v b/theories7/Bool/Zerob.v
deleted file mode 100755
index 24e48c28..00000000
--- a/theories7/Bool/Zerob.v
+++ /dev/null
@@ -1,36 +0,0 @@
-(************************************************************************)
-(*  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: Zerob.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
-
-Require Arith.
-Require Bool.
-
-V7only [Import nat_scope.].
-Open Local Scope nat_scope.
-
-Definition zerob : nat->bool 
-      := [n:nat]Cases n of O => true | (S _) => false end.
-
-Lemma zerob_true_intro : (n:nat)(n=O)->(zerob n)=true.
-NewDestruct n; [Trivial with bool | Inversion 1].
-Qed.
-Hints Resolve zerob_true_intro : bool.
-
-Lemma zerob_true_elim : (n:nat)(zerob n)=true->(n=O).
-NewDestruct n; [Trivial with bool | Inversion 1].
-Qed.
-
-Lemma zerob_false_intro : (n:nat)~(n=O)->(zerob n)=false.
-NewDestruct n; [NewDestruct 1; Auto with bool | Trivial with bool].
-Qed.
-Hints Resolve zerob_false_intro : bool.
-
-Lemma zerob_false_elim : (n:nat)(zerob n)=false -> ~(n=O).
-NewDestruct n; [Intro H; Inversion H | Auto with bool].
-Qed.
diff --git a/theories7/Init/Datatypes.v b/theories7/Init/Datatypes.v
deleted file mode 100755
index 006ec08e..00000000
--- a/theories7/Init/Datatypes.v
+++ /dev/null
@@ -1,125 +0,0 @@
-(************************************************************************)
-(*  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: Datatypes.v,v 1.3.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
-
-Require Notations.
-Require Logic.
-
-Set Implicit Arguments.
-V7only [Unset Implicit Arguments.].
-
-(** [unit] is a singleton datatype with sole inhabitant [tt] *)
-
-Inductive unit : Set := tt : unit.
-
-(** [bool] is the datatype of the booleans values [true] and [false] *)
-
-Inductive bool : Set := true : bool 
-                      | false : bool.
-
-Add Printing If bool.
-
-(** [nat] is the datatype of natural numbers built from [O] and successor [S];
-    note that zero is the letter O, not the numeral 0 *)
-
-Inductive nat : Set := O : nat 
-                     | S : nat->nat.
-
-Delimits Scope nat_scope with nat.
-Bind Scope nat_scope with nat.
-Arguments Scope S [ nat_scope ].
-
-(** [Empty_set] has no inhabitant *)
-
-Inductive Empty_set:Set :=.
-
-(** [identity A a] is the family of datatypes on [A] whose sole non-empty
-    member is the singleton datatype [identity A a a] whose
-    sole inhabitant is denoted [refl_identity A a] *)
-
-Inductive identity [A:Type; a:A] : A->Set :=
-     refl_identity: (identity A a a).
-Hints Resolve refl_identity : core v62.
-
-Implicits identity_ind [1].
-Implicits identity_rec [1].
-Implicits identity_rect [1].
-V7only [
-Implicits identity_ind [].
-Implicits identity_rec [].
-Implicits identity_rect [].
-].
-
-(** [option A] is the extension of A with a dummy element None *)
-
-Inductive option [A:Set] : Set := Some : A -> (option A) | None : (option A).
-
-Implicits None [1].
-V7only [Implicits None [].].
-
-(** [sum A B], equivalently [A + B], is the disjoint sum of [A] and [B] *)
-(* Syntax defined in Specif.v *)
-Inductive sum [A,B:Set] : Set
-    := inl : A -> (sum A B)
-     | inr : B -> (sum A B).
-
-Notation "x + y" := (sum x y) : type_scope.
-
-(** [prod A B], written [A * B], is the product of [A] and [B];
-    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)
-
-Inductive prod [A,B:Set] : Set := pair : A -> B -> (prod A B).
-Add Printing Let prod.
-
-Notation "x * y" := (prod x y) : type_scope.
-V7only [Notation "( x , y )" := (pair ? ? x y) : core_scope.].
-V8Notation "( x , y , .. , z )" := (pair ? ? .. (pair ? ? x y) .. z) : core_scope.
-
-Section projections.
-   Variables A,B:Set.
-   Definition fst := [p:(prod A B)]Cases p of (pair x y) => x end.
-   Definition snd := [p:(prod A B)]Cases p of (pair x y) => y end.
-End projections. 
-
-V7only [
-Notation Fst := (fst ? ?).
-Notation Snd := (snd ? ?).
-].
-Hints Resolve pair inl inr : core v62.
-
-Lemma surjective_pairing : (A,B:Set;p:A*B)p=(pair A B (Fst p) (Snd p)).
-Proof.
-NewDestruct p; Reflexivity.
-Qed.
-
-Lemma injective_projections : 
- (A,B:Set;p1,p2:A*B)(Fst p1)=(Fst p2)->(Snd p1)=(Snd p2)->p1=p2.
-Proof.
-NewDestruct p1; NewDestruct p2; Simpl; Intros Hfst Hsnd.
-Rewrite Hfst; Rewrite Hsnd; Reflexivity. 
-Qed.
-
-V7only[
-(** Parsing only of things in [Datatypes.v] *)
-Notation "< A , B > ( x , y )" := (pair A B x y) (at level 1, only parsing, A annot).
-Notation "< A , B > 'Fst' ( p )" := (fst A B p) (at level 1, only parsing, A annot).
-Notation "< A , B > 'Snd' ( p )" := (snd A B p) (at level 1, only parsing, A annot).
-].
-
-(** Comparison *)
-
-Inductive relation : Set := 
-  EGAL :relation | INFERIEUR : relation | SUPERIEUR : relation.
-
-Definition Op := [r:relation]
-  Cases r of
-    EGAL => EGAL
-  | INFERIEUR => SUPERIEUR
-  | SUPERIEUR => INFERIEUR
-  end.
diff --git a/theories7/Init/Logic.v b/theories7/Init/Logic.v
deleted file mode 100755
index 6ba9c7a1..00000000
--- a/theories7/Init/Logic.v
+++ /dev/null
@@ -1,306 +0,0 @@
-(************************************************************************)
-(*  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: Logic.v,v 1.6.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
-
-Set Implicit Arguments.
-V7only [Unset Implicit Arguments.].
-
-Require Notations.
-
-(** [True] is the always true proposition *)
-Inductive True : Prop := I : True. 
-
-(** [False] is the always false proposition *)
-Inductive False : Prop := . 
-
-(** [not A], written [~A], is the negation of [A] *)
-Definition not := [A:Prop]A->False.
-
-Notation "~ x" := (not x) : type_scope.
-
-Hints Unfold not : core.
-
-Inductive and [A,B:Prop] : Prop := conj : A -> B -> A /\ B
-
-where "A /\ B" := (and A B) : type_scope.
-
-V7only[
-Notation "< P , Q > { p , q }" := (conj P Q p q) (P annot, at level 1).
-].
-
-Section Conjunction.
-
-  (** [and A B], written [A /\ B], is the conjunction of [A] and [B]
-
-      [conj A B p q], written [<p,q>] is a proof of [A /\ B] as soon as 
-      [p] is a proof of [A] and [q] a proof of [B]
-
-      [proj1] and [proj2] are first and second projections of a conjunction *)
-
-  Variables A,B : Prop.
-
-  Theorem proj1 : (and A B) -> A.
-  Proof.
-  NewDestruct 1; Trivial.
-  Qed.
-
-  Theorem proj2 : (and A B) -> B.
-  Proof.
-  NewDestruct 1; Trivial.
-  Qed.
-
-End Conjunction.
-
-(** [or A B], written [A \/ B], is the disjunction of [A] and [B] *)
-
-Inductive or [A,B:Prop] : Prop :=
-     or_introl : A -> A \/ B 
-   | or_intror : B -> A \/ B
-
-where "A \/ B" := (or A B) : type_scope.
-
-(** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)
-
-Definition iff := [A,B:Prop] (and (A->B) (B->A)).
-
-Notation "A <-> B" := (iff A B) : type_scope.
-
-Section Equivalence.
-
-Theorem iff_refl : (A:Prop) (iff A A).
-  Proof.
-    Split; Auto.
-  Qed.
-
-Theorem iff_trans : (a,b,c:Prop) (iff a b) -> (iff b c) -> (iff a c).
-  Proof.
-    Intros A B C (H1,H2) (H3,H4); Split; Auto.
-  Qed.
-
-Theorem iff_sym : (A,B:Prop) (iff A B) -> (iff B A).
-  Proof.
-    Intros A B (H1,H2); Split; Auto.
-  Qed.
-
-End Equivalence.
-
-(** [(IF P Q R)], or more suggestively [(either P and_then Q or_else R)],
-    denotes either [P] and [Q], or [~P] and [Q] *)
-Definition IF_then_else := [P,Q,R:Prop] (or (and P Q) (and (not P) R)).
-V7only [Notation IF:=IF_then_else.].
-
-Notation "'IF' c1 'then' c2 'else' c3" := (IF c1 c2 c3)
-  (at level 1, c1, c2, c3 at level 8) : type_scope
-  V8only (at level 200).
-
-(** First-order quantifiers *)
-
-  (** [ex A P], or simply [exists x, P x], expresses the existence of an 
-      [x] of type [A] which satisfies the predicate [P] ([A] is of type 
-      [Set]). This is existential quantification. *)
-
-  (** [ex2 A P Q], or simply [exists2 x, P x & Q x], expresses the
-      existence of an [x] of type [A] which satisfies both the predicates
-      [P] and [Q] *)
-
-  (** Universal quantification (especially first-order one) is normally 
-      written [forall x:A, P x]. For duality with existential quantification, 
-      the construction [all P] is provided too *)
-
-Inductive ex [A:Type;P:A->Prop] : Prop 
-    := ex_intro : (x:A)(P x)->(ex A P).
-
-Inductive ex2 [A:Type;P,Q:A->Prop] : Prop
-    := ex_intro2 : (x:A)(P x)->(Q x)->(ex2 A P Q).
-
-Definition all := [A:Type][P:A->Prop](x:A)(P x). 
-
-(* Rule order is important to give printing priority to fully typed exists *)
-
-V7only [ Notation Ex  := (ex ?). ].
-Notation "'EX' x | p"      := (ex ? [x]p)
-  (at level 10, p at level 8) : type_scope
-  V8only "'exists' x , p" (at level 200, x ident, p at level 99).
-Notation "'EX' x : t | p"  := (ex ? [x:t]p)
-  (at level 10, p at level 8) : type_scope
-  V8only "'exists' x : t , p" (at level 200, x ident, p at level 99, format
-  "'exists'  '/  ' x  :  t ,  '/  ' p").
-
-V7only [ Notation Ex2 := (ex2 ?). ].
-Notation "'EX' x | p & q"       := (ex2 ? [x]p [x]q)
-  (at level 10, p, q at level 8) : type_scope
-  V8only "'exists2' x , p & q" (at level 200, x ident, p, q at level 99).
-Notation "'EX' x : t | p & q"   := (ex2 ? [x:t]p [x:t]q)
-  (at level 10, p, q at level 8) : type_scope
-  V8only "'exists2' x : t , p & q"
-    (at level 200, x ident, t at level 200, p, q at level 99, format
-    "'exists2'  '/  ' x  :  t ,  '/  ' '[' p  &  '/' q ']'").
-
-V7only [Notation All := (all ?).
-Notation "'ALL' x | p"     := (all ? [x]p)
-  (at level 10, p at level 8) : type_scope
-  V8only (at level 200, x ident, p at level 200).
-Notation "'ALL' x : t | p" := (all ? [x:t]p)
-  (at level 10, p at level 8) : type_scope
-  V8only (at level 200, x ident, t, p at level 200).
-].
-
-(** Universal quantification *)
-
-Section universal_quantification.
-
-  Variable A : Type.
-  Variable P : A->Prop.
-
-  Theorem inst : (x:A)(all ? [x](P x))->(P x).
-  Proof.
-  Unfold all; Auto.
-  Qed.
-
-  Theorem gen : (B:Prop)(f:(y:A)B->(P y))B->(all A P).
-  Proof.
-  Red; Auto.
-  Qed.
-
-  End universal_quantification.
-
-(** Equality *)
-
-(** [eq A x y], or simply [x=y], expresses the (Leibniz') equality
-    of [x] and [y]. Both [x] and [y] must belong to the same type [A].
-    The definition is inductive and states the reflexivity of the equality.
-    The others properties (symmetry, transitivity, replacement of 
-    equals) are proved below *)
-
-Inductive eq [A:Type;x:A] : A->Prop
-       := refl_equal : x = x :> A
-
-where "x = y :> A" := (!eq A x y) : type_scope.
-
-Notation "x = y" := (eq ? x y) : type_scope.
-Notation "x <> y  :> T" := ~ (!eq T x y) : type_scope.
-Notation "x <> y" := ~ x=y : type_scope.
-
-Implicits eq_ind [1].
-Implicits eq_rec [1].
-Implicits eq_rect [1].
-V7only [
-Implicits eq_ind [].
-Implicits eq_rec [].
-Implicits eq_rect [].
-].
-
-Hints Resolve I conj or_introl or_intror refl_equal : core v62.
-Hints Resolve ex_intro ex_intro2 : core v62.
-
-Section Logic_lemmas.
-
-  Theorem absurd : (A:Prop)(C:Prop) A -> (not A) -> C.
-  Proof.
-    Unfold not; Intros A C h1 h2.
-    NewDestruct (h2 h1).
-  Qed.
-
-  Section equality.
-    Variable A,B : Type.
-    Variable f   : A->B.
-    Variable x,y,z : A.
-
-    Theorem sym_eq : (eq ? x y) -> (eq ? y x).
-    Proof.
-     NewDestruct 1; Trivial.
-    Defined.
-    Opaque sym_eq.
-
-    Theorem trans_eq : (eq ? x y) -> (eq ? y z) -> (eq ? x z).
-    Proof.
-     NewDestruct 2; Trivial.
-    Defined.
-    Opaque trans_eq.
-
-    Theorem f_equal : (eq ? x y) -> (eq ? (f x) (f y)).
-    Proof.
-     NewDestruct 1; Trivial.
-    Defined.
-    Opaque f_equal.
-
-    Theorem sym_not_eq : (not (eq ? x y)) -> (not (eq ? y x)).
-    Proof.
-     Red; Intros h1 h2; Apply h1; NewDestruct h2; Trivial.
-    Qed.
-
-    Definition sym_equal     := sym_eq.
-    Definition sym_not_equal := sym_not_eq.
-    Definition trans_equal   := trans_eq.
-
-  End equality.
-
-(* Is now a primitive principle 
-  Theorem eq_rect: (A:Type)(x:A)(P:A->Type)(P x)->(y:A)(eq ? x y)->(P y).
-  Proof.
-   Intros.
-   Cut (identity A x y).
-   NewDestruct 1; Auto.
-   NewDestruct H; Auto.
-  Qed.
-*)
-
-  Definition eq_ind_r : (A:Type)(x:A)(P:A->Prop)(P x)->(y:A)(eq ? y x)->(P y).
-   Intros A x P H y H0; Elim sym_eq with 1:= H0; Assumption.
-  Defined.
-
-  Definition eq_rec_r : (A:Type)(x:A)(P:A->Set)(P x)->(y:A)(eq ? y x)->(P y).
-    Intros A x P H y H0; Elim sym_eq with 1:= H0; Assumption.
-  Defined.
-
-  Definition eq_rect_r : (A:Type)(x:A)(P:A->Type)(P x)->(y:A)(eq ? y x)->(P y).
-    Intros A x P H y H0; Elim sym_eq with 1:= H0; Assumption.
-  Defined.
-End Logic_lemmas.
-
-Theorem f_equal2 : (A1,A2,B:Type)(f:A1->A2->B)(x1,y1:A1)(x2,y2:A2)
-  (eq ? x1 y1) -> (eq ? x2 y2) -> (eq ? (f x1 x2) (f y1 y2)).
-Proof.
-  NewDestruct 1; NewDestruct 1; Reflexivity.
-Qed.
-
-Theorem f_equal3 : (A1,A2,A3,B:Type)(f:A1->A2->A3->B)(x1,y1:A1)(x2,y2:A2)
-  (x3,y3:A3)(eq ? x1 y1) -> (eq ? x2 y2) -> (eq ? x3 y3) 
-   -> (eq ? (f x1 x2 x3) (f y1 y2 y3)).
-Proof.
-  NewDestruct 1; NewDestruct 1; NewDestruct 1; Reflexivity.
-Qed.
-
-Theorem f_equal4 : (A1,A2,A3,A4,B:Type)(f:A1->A2->A3->A4->B)
-  (x1,y1:A1)(x2,y2:A2)(x3,y3:A3)(x4,y4:A4)
-  (eq ? x1 y1) -> (eq ? x2 y2) -> (eq ? x3 y3) -> (eq ? x4 y4)
-   -> (eq ? (f x1 x2 x3 x4) (f y1 y2 y3 y4)).
-Proof.
-  NewDestruct 1; NewDestruct 1; NewDestruct 1; NewDestruct 1; Reflexivity.
-Qed.
-
-Theorem f_equal5 : (A1,A2,A3,A4,A5,B:Type)(f:A1->A2->A3->A4->A5->B)
-  (x1,y1:A1)(x2,y2:A2)(x3,y3:A3)(x4,y4:A4)(x5,y5:A5)
-  (eq ? x1 y1) -> (eq ? x2 y2) -> (eq ? x3 y3) -> (eq ? x4 y4) -> (eq ? x5 y5)
-    -> (eq ? (f x1 x2 x3 x4 x5) (f y1 y2 y3 y4 y5)).
-Proof.
-  NewDestruct 1; NewDestruct 1; NewDestruct 1; NewDestruct 1; NewDestruct 1;
-  Reflexivity.
-Qed.
-
-Hints Immediate sym_eq sym_not_eq : core v62.
-
-V7only[
-(** Parsing only of things in [Logic.v] *)
-Notation "< A > 'All' ( P )" :=(all A P) (A annot, at level 1, only parsing).
-Notation "< A > x = y" := (eq A x y)
- (A annot, at level 1, x at level 0, only parsing).
-Notation "< A > x <> y" := ~(eq A x y)
-  (A annot, at level 1, x at level 0, only parsing).
-].
diff --git a/theories7/Init/Logic_Type.v b/theories7/Init/Logic_Type.v
deleted file mode 100755
index 793b671c..00000000
--- a/theories7/Init/Logic_Type.v
+++ /dev/null
@@ -1,304 +0,0 @@
-(************************************************************************)
-(*  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: Logic_Type.v,v 1.3.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
-
-Set Implicit Arguments.
-V7only [Unset Implicit Arguments.].
-
-(** This module defines quantification on the world [Type]
-    ([Logic.v] was defining it on the world [Set]) *)
-
-Require Datatypes.
-Require Export Logic.
-
-V7only [
-(*
-(** [allT A P], or simply [(ALLT x | P(x))], stands for [(x:A)(P x)]
-   when [A] is of type [Type] *)
-
-Definition allT := [A:Type][P:A->Prop](x:A)(P x). 
-*)
-
-Notation allT := all (only parsing).
-Notation inst := Logic.inst (only parsing).
-Notation gen := Logic.gen (only parsing).
-
-(* Order is important to give printing priority to fully typed ALL and EX *)
-
-Notation AllT := (all ?).
-Notation "'ALLT' x | p"     := (all ? [x]p)   (at level 10, p at level 8).
-Notation "'ALLT' x : t | p" := (all ? [x:t]p) (at level 10, p at level 8).
-
-(*
-Section universal_quantification.
-
-Variable A : Type.
-Variable P : A->Prop.
-
-Theorem inst :  (x:A)(allT ? [x](P x))->(P x).
-Proof.
-Unfold all; Auto.
-Qed.
-
-Theorem gen : (B:Prop)(f:(y:A)B->(P y))B->(allT A P).
-Proof.
-Red; Auto.
-Qed.
-
-End universal_quantification.
-*)
-
-(*
-(** * Existential Quantification *)
-
-(** [exT A P], or simply [(EXT x | P(x))], stands for the existential 
-    quantification on the predicate [P] when [A] is of type [Type] *)
-
-(** [exT2 A P Q], or simply [(EXT x | P(x) & Q(x))], stands for the
-    existential quantification on both [P] and [Q] when [A] is of
-    type [Type] *)
-Inductive  exT [A:Type;P:A->Prop] : Prop
-    := exT_intro : (x:A)(P x)->(exT A P).
-*)
-
-Notation exT := ex (only parsing).
-Notation exT_intro := ex_intro (only parsing).
-Notation exT_ind  := ex_ind (only parsing).
-
-Notation ExT  := (ex ?).
-Notation "'EXT' x | p"      := (ex ? [x]p)
-  (at level 10, p at level 8, only parsing).
-Notation "'EXT' x : t | p"  := (ex ? [x:t]p)
-  (at level 10, p at level 8, only parsing).
-
-(*
-Inductive exT2 [A:Type;P,Q:A->Prop] : Prop
-    := exT_intro2 : (x:A)(P x)->(Q x)->(exT2 A P Q).
-*)
-
-Notation exT2 := ex2 (only parsing).
-Notation exT_intro2 := ex_intro2 (only parsing).
-Notation exT2_ind  := ex2_ind (only parsing).
-
-Notation ExT2 := (ex2 ?).
-Notation "'EXT' x | p & q"     := (ex2 ? [x]p [x]q)
-  (at level 10, p, q at level 8).
-Notation "'EXT' x : t | p & q" := (ex2 ? [x:t]p [x:t]q)
-  (at level 10, p, q at level 8).
-
-(*
-(** Leibniz equality : [A:Type][x,y:A] (P:A->Prop)(P x)->(P y)
-
-   [eqT A x y], or simply [x==y], is Leibniz' equality when [A] is of 
-   type [Type]. This equality satisfies reflexivity (by definition), 
-   symmetry, transitivity and stability by congruence *)
-
-
-Inductive eqT [A:Type;x:A] : A -> Prop
-                       := refl_eqT : (eqT A x x).
-
-Hints Resolve refl_eqT (* exT_intro2 exT_intro *) : core v62.
-*)
-
-Notation eqT      := eq (only parsing).
-Notation refl_eqT := refl_equal (only parsing).
-Notation eqT_ind  := eq_ind (only parsing).
-Notation eqT_rect := eq_rect (only parsing).
-Notation eqT_rec  := eq_rec (only parsing).
-
-Notation "x == y"  := (eq ? x y) (at level 5, no associativity, only parsing).
-
-(** Parsing only of things in [Logic_type.v] *)
-
-Notation "< A > x == y"  := (eq A x y)
-   (A annot, at level 1, x at level 0, only parsing).
-
-(*
-Section Equality_is_a_congruence.
-
- Variables A,B : Type.
- Variable  f : A->B.
-
- Variable x,y,z : A.
- 
- Lemma sym_eqT : (eqT ? x y) -> (eqT ? y x).
- Proof.
-  NewDestruct 1; Trivial.
- Qed.
-
- Lemma trans_eqT : (eqT ? x y) -> (eqT ? y z) -> (eqT ? x z).
- Proof.
-  NewDestruct 2; Trivial.
- Qed.
-
- Lemma congr_eqT : (eqT ? x y)->(eqT ? (f x) (f y)).
- Proof.
-  NewDestruct 1; Trivial.
- Qed.
-
- Lemma sym_not_eqT : ~(eqT ? x y) -> ~(eqT ? y x).
- Proof.
-  Red; Intros H H'; Apply H; NewDestruct H'; Trivial.
- Qed.
-
-End Equality_is_a_congruence.
-*)
-
-Notation sym_eqT  := sym_eq (only parsing).
-Notation trans_eqT  := trans_eq (only parsing).
-Notation congr_eqT  := f_equal (only parsing).
-Notation sym_not_eqT  := sym_not_eq (only parsing).
-
-(*
-Hints Immediate sym_eqT sym_not_eqT : core v62.
-*)
-
-(** This states the replacement of equals by equals *)
-
-(*
-Definition eqT_ind_r : (A:Type)(x:A)(P:A->Prop)(P x)->(y:A)(eqT ? y x)->(P y).
-Intros A x P H y H0; Case sym_eqT with 1:=H0; Trivial.
-Defined.
-
-Definition eqT_rec_r : (A:Type)(x:A)(P:A->Set)(P x)->(y:A)(eqT ? y x)->(P y).
-Intros A x P H y H0; Case sym_eqT with 1:=H0; Trivial.
-Defined.
-
-Definition eqT_rect_r : (A:Type)(x:A)(P:A->Type)(P x)->(y:A)(eqT ? y x)->(P y).
-Intros A x P H y H0; Case sym_eqT with 1:=H0; Trivial.
-Defined.
-*)
-
-Notation eqT_ind_r  := eq_ind_r (only parsing).
-Notation eqT_rec_r  := eq_rec_r (only parsing).
-Notation eqT_rect_r  := eq_rect_r (only parsing).
-
-(** Some datatypes at the [Type] level *)
-(*
-Inductive EmptyT: Type :=.
-Inductive UnitT : Type := IT : UnitT.
-*)
-
-Notation EmptyT := False (only parsing).
-Notation UnitT := unit (only parsing).
-Notation IT := tt.
-].
-Definition notT := [A:Type] A->EmptyT.
-
-V7only [
-(** Have you an idea of what means [identityT A a b]? No matter! *)
-
-(*
-Inductive identityT [A:Type; a:A] : A -> Type :=
-     refl_identityT : (identityT A a a).
-*)
-
-Notation identityT := identity (only parsing).
-Notation refl_identityT := refl_identity (only parsing).
-
-Notation "< A > x === y" := (!identityT A x y)
-   (A annot, at level 1, x at level 0, only parsing) : type_scope.
-
-Notation "x === y" := (identityT ? x y)
-  (at level 5, no associativity, only parsing) : type_scope.
-
-(*
-Hints Resolve refl_identityT : core v62.
-*)
-].
-Section identity_is_a_congruence.
-
- Variables A,B : Type.
- Variable  f : A->B.
-
- Variable x,y,z : A.
- 
- Lemma sym_id : (identityT ? x y) -> (identityT ? y x).
- Proof.
-  NewDestruct 1; Trivial.
- Qed.
-
- Lemma trans_id : (identityT ? x y) -> (identityT ? y z) -> (identityT ? x z).
- Proof.
-  NewDestruct 2; Trivial.
- Qed.
-
- Lemma congr_id : (identityT ? x y)->(identityT ? (f x) (f y)).
- Proof.
-  NewDestruct 1; Trivial.
- Qed.
-
- Lemma sym_not_id : (notT (identityT ? x y)) -> (notT (identityT ? y x)).
- Proof.
-  Red; Intros H H'; Apply H; NewDestruct H'; Trivial.
- Qed.
-
-End identity_is_a_congruence.
-
-Definition identity_ind_r :
-     (A:Type)
-        (a:A)
-         (P:A->Prop)
-          (P a)->(y:A)(identityT ? y a)->(P y).
- Intros A x P H y H0; Case sym_id with 1:= H0; Trivial.
-Defined.
-
-Definition identity_rec_r :      
-     (A:Type)
-        (a:A)
-         (P:A->Set)
-          (P a)->(y:A)(identityT ? y a)->(P y).
- Intros A x P H y H0; Case sym_id with 1:= H0; Trivial.
-Defined.
-
-Definition identity_rect_r :      
-     (A:Type)
-        (a:A)
-         (P:A->Type)
-          (P a)->(y:A)(identityT ? y a)->(P y).
- Intros A x P H y H0; Case sym_id with 1:= H0; Trivial.
-Defined.
-
-V7only [
-Notation sym_idT  := sym_id (only parsing).
-Notation trans_idT  := trans_id (only parsing).
-Notation congr_idT  := congr_id (only parsing).
-Notation sym_not_idT  := sym_not_id (only parsing).
-Notation identityT_ind_r := identity_ind_r (only parsing).
-Notation identityT_rec_r  := identity_rec_r (only parsing).
-Notation identityT_rect_r := identity_rect_r (only parsing).
-].
-Inductive prodT [A,B:Type] : Type := pairT : A -> B -> (prodT A B).
-
-Section prodT_proj.
-
-  Variables A, B : Type.
-
-  Definition fstT := [H:(prodT A B)]Cases H of (pairT x _) => x end.
-  Definition sndT := [H:(prodT A B)]Cases H of (pairT _ y) => y end.
-
-End prodT_proj.
-
-Definition prodT_uncurry : (A,B,C:Type)((prodT A B)->C)->A->B->C :=
-  [A,B,C:Type; f:((prodT A B)->C); x:A; y:B]
-  (f (pairT A B x y)).
-
-Definition prodT_curry : (A,B,C:Type)(A->B->C)->(prodT A B)->C :=
-  [A,B,C:Type; f:(A->B->C); p:(prodT A B)]
-  Cases p of
-  | (pairT x y) => (f x y)
-  end.
-
-Hints Immediate sym_id sym_not_id : core v62.
-
-V7only [
-Implicits fstT [1 2].
-Implicits sndT [1 2].
-Implicits pairT [1 2].
-].
diff --git a/theories7/Init/Notations.v b/theories7/Init/Notations.v
deleted file mode 100644
index 34bfcbfa..00000000
--- a/theories7/Init/Notations.v
+++ /dev/null
@@ -1,94 +0,0 @@
-(************************************************************************)
-(*  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: Notations.v,v 1.5.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
-
-(** These are the notations whose level and associativity is imposed by Coq *)
-
-(** Notations for logical connectives *)
-
-Uninterpreted Notation "x <-> y" (at level 8, right associativity)
-  V8only (at level 95, no associativity).
-Uninterpreted Notation "x /\ y" (at level 6, right associativity) 
-  V8only (at level 80, right associativity).
-Uninterpreted Notation "x \/ y" (at level 7, right associativity)
-  V8only (at level 85, right associativity).
-Uninterpreted Notation "~ x" (at level 5, right associativity)
-  V8only (at level 75, right associativity).
-
-(** Notations for equality and inequalities *)
-
-Uninterpreted Notation "x = y  :> T" 
-  (at level 5, y at next level, no associativity).
-Uninterpreted Notation "x = y"
-  (at level 5, no associativity).
-Uninterpreted Notation "x = y = z"
-  (at level 5, no associativity, y at next level).
-
-Uninterpreted Notation "x <> y  :> T" 
-  (at level 5, y at next level, no associativity).
-Uninterpreted Notation "x <> y"
-  (at level 5, no associativity).
-
-Uninterpreted V8Notation "x <= y" (at level 70, no associativity).
-Uninterpreted V8Notation "x < y" (at level 70, no associativity).
-Uninterpreted V8Notation "x >= y" (at level 70, no associativity).
-Uninterpreted V8Notation "x > y" (at level 70, no associativity).
-
-Uninterpreted V8Notation "x <= y <= z" (at level 70, y at next level).
-Uninterpreted V8Notation "x <= y < z"  (at level 70, y at next level).
-Uninterpreted V8Notation "x < y < z"   (at level 70, y at next level).
-Uninterpreted V8Notation "x < y <= z"  (at level 70, y at next level).
-
-(** Arithmetical notations (also used for type constructors) *)
-
-Uninterpreted Notation "x + y" (at level 4, left associativity).
-Uninterpreted V8Notation "x - y" (at level 50, left associativity).
-Uninterpreted Notation "x * y" (at level 3, right associativity)
-  V8only (at level 40, left associativity).
-Uninterpreted V8Notation "x / y" (at level 40, left associativity).
-Uninterpreted V8Notation "- x" (at level 35, right associativity).
-Uninterpreted V8Notation "/ x" (at level 35, right associativity).
-Uninterpreted V8Notation "x ^ y" (at level 30, right associativity).
-
-(** Notations for pairs *)
-
-V7only [Uninterpreted Notation "( x , y )" (at level 0) V8only.].
-Uninterpreted V8Notation "( x , y , .. , z )" (at level 0).
-
-(** Notation "{ x }" is reserved and has a special status as component
-    of other notations; it is at level 1 to factor with {x:A|P} etc *)
-
-Uninterpreted Notation "{ x }" (at level 1)
-  V8only (at level 0, x at level 99).
-
-(** Notations for sum-types *)
-
-Uninterpreted Notation "{ A }  + { B }" (at level 4, left associativity)
-  V8only (at level 50, left associativity).
-
-Uninterpreted Notation "A + { B }" (at level 4, left associativity)
-  V8only (at level 50, left associativity).
-
-(** Notations for sigma-types or subsets *)
-
-Uninterpreted Notation "{ x : A  |  P }" (at level 1)
-  V8only (at level 0, x at level 99).
-Uninterpreted Notation "{ x : A  |  P  &  Q }" (at level 1)
-  V8only (at level 0, x at level 99).
-
-Uninterpreted Notation "{ x : A  &  P }" (at level 1)
-  V8only (at level 0, x at level 99).
-Uninterpreted Notation "{ x : A  &  P  &  Q }" (at level 1)
-  V8only (at level 0, x at level 99).
-
-Delimits Scope type_scope with type.
-Delimits Scope core_scope with core.
-
-Open Scope core_scope.
-Open Scope type_scope.
diff --git a/theories7/Init/Peano.v b/theories7/Init/Peano.v
deleted file mode 100755
index 72d19399..00000000
--- a/theories7/Init/Peano.v
+++ /dev/null
@@ -1,218 +0,0 @@
-(************************************************************************)
-(*  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: Peano.v,v 1.1.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
-
-(** Natural numbers [nat] built from [O] and [S] are defined in Datatypes.v *)
-
-(** This module defines the following operations on natural numbers :
-    - predecessor [pred]
-    - addition [plus]
-    - multiplication [mult]
-    - less or equal order [le]
-    - less [lt]
-    - greater or equal [ge]
-    - greater [gt]
-
-   This module states various lemmas and theorems about natural numbers,
-   including Peano's axioms of arithmetic (in Coq, these are in fact provable)
-   Case analysis on [nat] and induction on [nat * nat] are provided too *)
-
-Require Notations.
-Require Datatypes.
-Require Logic.
-
-Open Scope nat_scope.
-
-Definition eq_S := (f_equal nat nat S).
-
-Hint eq_S : v62 := Resolve (f_equal nat nat S).
-Hint eq_nat_unary : core := Resolve (f_equal nat).
-
-(** The predecessor function *)
-
-Definition pred : nat->nat := [n:nat](Cases n of O => O | (S u) => u end).
-Hint eq_pred : v62 := Resolve (f_equal nat nat pred).
-
-Theorem pred_Sn : (m:nat) m=(pred (S m)).
-Proof.
-  Auto.
-Qed.
-
-Theorem eq_add_S : (n,m:nat) (S n)=(S m) -> n=m.
-Proof.
-  Intros n m H ; Change (pred (S n))=(pred (S m)); Auto.
-Qed.
-
-Hints Immediate eq_add_S : core v62.
-
-(** A consequence of the previous axioms *)
-
-Theorem not_eq_S : (n,m:nat) ~(n=m) -> ~((S n)=(S m)).
-Proof.
-  Red; Auto.
-Qed.
-Hints Resolve not_eq_S : core v62.
-
-Definition IsSucc : nat->Prop
-  := [n:nat]Cases n of O => False | (S p) => True end.
-
-
-Theorem O_S : (n:nat)~(O=(S n)).
-Proof.
-  Red;Intros n H.
-  Change (IsSucc O).
-  Rewrite <- (sym_eq nat O (S n));[Exact I | Assumption].
-Qed.
-Hints Resolve O_S : core v62.
-
-Theorem n_Sn : (n:nat) ~(n=(S n)).
-Proof.
-  NewInduction n ; Auto.
-Qed.
-Hints Resolve n_Sn : core v62.
-
-(** Addition *)
-
-Fixpoint plus [n:nat] : nat -> nat := 
-   [m:nat]Cases n of 
-      O   => m 
-  | (S p) => (S (plus p m)) end.
-Hint eq_plus : v62 := Resolve (f_equal2 nat nat nat plus).
-Hint eq_nat_binary : core := Resolve (f_equal2 nat nat).
-
-V8Infix "+" plus : nat_scope.
-
-Lemma plus_n_O : (n:nat) n=(plus n O).
-Proof.
-  NewInduction n ; Simpl ; Auto.
-Qed.
-Hints Resolve plus_n_O : core v62.
-
-Lemma plus_O_n : (n:nat) (plus O n)=n.
-Proof.
-  Auto.
-Qed.
-
-Lemma plus_n_Sm : (n,m:nat) (S (plus n m))=(plus n (S m)).
-Proof.
-  Intros n m; NewInduction n; Simpl; Auto.
-Qed.
-Hints Resolve plus_n_Sm : core v62.
-
-Lemma plus_Sn_m : (n,m:nat)(plus (S n) m)=(S (plus n m)).
-Proof.
-  Auto.
-Qed.
-
-(** Multiplication *)
-
-Fixpoint  mult [n:nat] : nat -> nat := 
-   [m:nat]Cases n of O => O 
-               | (S p) => (plus m (mult p m)) end.
-Hint eq_mult : core v62 := Resolve (f_equal2 nat nat nat mult).
-
-V8Infix "*" mult : nat_scope.
-
-Lemma mult_n_O : (n:nat) O=(mult n O).
-Proof.
-  NewInduction n; Simpl; Auto.
-Qed.
-Hints Resolve mult_n_O : core v62.
-
-Lemma mult_n_Sm : (n,m:nat) (plus (mult n m) n)=(mult n (S m)).
-Proof.
-  Intros; NewInduction n as [|p H]; Simpl; Auto.
-  NewDestruct H; Rewrite <- plus_n_Sm; Apply (f_equal nat nat S).
-  Pattern 1 3 m; Elim m; Simpl; Auto.
-Qed.
-Hints Resolve mult_n_Sm : core v62.
-
-(** Definition of subtraction on [nat] : [m-n] is [0] if [n>=m] *)
-
-Fixpoint minus [n:nat] : nat -> nat := 
-  [m:nat]Cases n m of
-            O    _     =>  O
-         | (S k) O     => (S k)
-         | (S k) (S l) => (minus k l)
-        end. 
-
-V8Infix "-" minus : nat_scope.
-
-(** Definition of the usual orders, the basic properties of [le] and [lt] 
-    can be found in files Le and Lt *)
-
-(** An inductive definition to define the order *)
-
-Inductive le [n:nat] : nat -> Prop
-    := le_n : (le n n)
-     | le_S : (m:nat)(le n m)->(le n (S m)).
-
-V8Infix "<=" le : nat_scope.
-
-Hint constr_le : core v62 := Constructors le.
-(*i equivalent to : "Hints Resolve le_n le_S : core v62." i*)
-
-Definition lt := [n,m:nat](le (S n) m).
-Hints Unfold lt : core v62.
-
-V8Infix "<" lt : nat_scope.
-
-Definition ge := [n,m:nat](le m n).
-Hints Unfold ge : core v62.
-
-V8Infix ">=" ge : nat_scope.
-
-Definition gt := [n,m:nat](lt m n).
-Hints Unfold gt : core v62.
-
-V8Infix ">" gt : nat_scope.
-
-V8Notation "x <= y <= z" := (le x y)/\(le y z) : nat_scope.
-V8Notation "x <= y < z"  := (le x y)/\(lt y z) : nat_scope.
-V8Notation "x < y < z"   := (lt x y)/\(lt y z) : nat_scope.
-V8Notation "x < y <= z"  := (lt x y)/\(le y z) : nat_scope.
-
-(** Pattern-Matching on natural numbers *)
-
-Theorem nat_case : (n:nat)(P:nat->Prop)(P O)->((m:nat)(P (S m)))->(P n).
-Proof.
-  NewInduction n ; Auto.
-Qed.
-
-(** Principle of double induction *)
-
-Theorem nat_double_ind : (R:nat->nat->Prop)
-     ((n:nat)(R O n)) -> ((n:nat)(R (S n) O))
-     -> ((n,m:nat)(R n m)->(R (S n) (S m)))
-     -> (n,m:nat)(R n m).
-Proof.
-  NewInduction n; Auto.
-  NewDestruct m; Auto.
-Qed.
-
-(** Notations *)
-V7only[
-Syntax constr
-  level 0:
-    S [ (S $p) ] -> [$p:"nat_printer":9]
-  | O [ O ]      -> ["(0)"].
-].
-
-V7only [
-(* For parsing/printing based on scopes *)
-Module nat_scope.
-Infix 4 "+" plus : nat_scope.
-Infix 3 "*" mult : nat_scope.
-Infix 4 "-" minus : nat_scope.
-Infix NONA 5 "<=" le : nat_scope.
-Infix NONA 5 "<" lt : nat_scope.
-Infix NONA 5 ">=" ge : nat_scope.
-Infix NONA 5 ">" gt : nat_scope.
-End nat_scope.
-].
diff --git a/theories7/Init/Specif.v b/theories7/Init/Specif.v
deleted file mode 100755
index c39e5ed8..00000000
--- a/theories7/Init/Specif.v
+++ /dev/null
@@ -1,204 +0,0 @@
-(************************************************************************)
-(*  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: Specif.v,v 1.2.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
-
-Set Implicit Arguments.
-V7only [Unset Implicit Arguments.].
-
-(** Basic specifications : Sets containing logical information *)
-
-Require Notations.
-Require Datatypes.
-Require Logic.
-
-(** Subsets *)
-
-(** [(sig A P)], or more suggestively [{x:A | (P x)}], denotes the subset 
-    of elements of the Set [A] which satisfy the predicate [P].
-    Similarly [(sig2 A P Q)], or [{x:A | (P x) & (Q x)}], denotes the subset 
-    of elements of the Set [A] which satisfy both [P] and [Q]. *)
-
-Inductive sig [A:Set;P:A->Prop] : Set
-    := exist : (x:A)(P x) -> (sig A P).
-
-Inductive sig2 [A:Set;P,Q:A->Prop] : Set
-    := exist2 : (x:A)(P x) -> (Q x) -> (sig2 A P Q).
-
-(** [(sigS A P)], or more suggestively [{x:A & (P x)}], is a subtle variant
-    of subset where [P] is now of type [Set].
-    Similarly for [(sigS2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *)
-     
-Inductive sigS [A:Set;P:A->Set] : Set
-    := existS : (x:A)(P x) -> (sigS A P).
-
-Inductive sigS2 [A:Set;P,Q:A->Set] : Set
-    := existS2 : (x:A)(P x) -> (Q x) -> (sigS2 A P Q).
-
-Arguments Scope sig [type_scope type_scope].
-Arguments Scope sig2 [type_scope type_scope type_scope].
-Arguments Scope sigS [type_scope type_scope].
-Arguments Scope sigS2 [type_scope type_scope type_scope].
-
-Notation "{ x : A  |  P }" := (sig A [x:A]P) : type_scope.
-Notation "{ x : A  |  P  &  Q }" := (sig2 A [x:A]P [x:A]Q) : type_scope.
-Notation "{ x : A  &  P }" := (sigS A [x:A]P) : type_scope.
-Notation "{ x : A  &  P  &  Q }" := (sigS2 A [x:A]P [x:A]Q) : type_scope.
-
-Add Printing Let sig.
-Add Printing Let sig2.
-Add Printing Let sigS.
-Add Printing Let sigS2.
-
-
-(** Projections of sig *)
-
-Section Subset_projections.
-
-  Variable A:Set.
-  Variable P:A->Prop.
-
-  Definition proj1_sig :=
-   [e:(sig A P)]Cases e of (exist a b) => a  end.
-
-  Definition proj2_sig :=
-   [e:(sig A P)]
-     <[e:(sig A P)](P (proj1_sig e))>Cases e of (exist a b) => b  end.
-
-End Subset_projections.
-
-
-(** Projections of sigS *)
-
-Section Projections.
-
-  Variable A:Set.
-  Variable P:A->Set.
-
- (** An element [y] of a subset [{x:A & (P x)}] is the pair of an [a] of 
-     type [A] and of a proof [h] that [a] satisfies [P].
-     Then [(projS1 y)] is the witness [a]
-     and [(projS2 y)] is the proof of [(P a)] *)
-
-  Definition projS1 : (sigS A P) -> A
-           := [x:(sigS A P)]Cases x of (existS a _) => a end.
-  Definition projS2 : (x:(sigS A P))(P (projS1 x))
-           := [x:(sigS A P)]<[x:(sigS A P)](P (projS1 x))> 
-                  Cases x of (existS _ h) => h end.
-
-End Projections.
-
-
-(** Extended_booleans *)
-
-Inductive sumbool [A,B:Prop] : Set
-    := left  : A -> {A}+{B}
-     | right : B -> {A}+{B}
-
-where "{ A } + { B }" := (sumbool A B) : type_scope.
-
-Inductive sumor [A:Set;B:Prop] : Set
-    := inleft  : A -> A+{B}
-     | inright : B -> A+{B}
-
-where "A + { B }" := (sumor A B) : type_scope.
-
-(** Choice *)
-
-Section Choice_lemmas.
-
-  (** The following lemmas state various forms of the axiom of choice *)
-
-  Variables S,S':Set.
-  Variable R:S->S'->Prop.
-  Variable R':S->S'->Set.
-  Variables R1,R2 :S->Prop.
-
-  Lemma Choice : ((x:S)(sig ? [y:S'](R x y))) ->
-                     (sig ? [f:S->S'](z:S)(R z (f z))).
-  Proof.
-   Intro H.
-   Exists [z:S]Cases (H z) of (exist y _) => y end.
-   Intro z; NewDestruct (H z); Trivial.
-  Qed.
-
-  Lemma Choice2 : ((x:S)(sigS ? [y:S'](R' x y))) ->
-                     (sigS ? [f:S->S'](z:S)(R' z (f z))).
-  Proof.
-    Intro H.
-    Exists [z:S]Cases (H z) of (existS y _) => y end.
-    Intro z; NewDestruct (H z); Trivial.
-  Qed.
-
-  Lemma bool_choice : 
-    ((x:S)(sumbool (R1 x) (R2 x))) ->
-    (sig ? [f:S->bool] (x:S)( ((f x)=true  /\ (R1 x)) 
-                           \/ ((f x)=false /\ (R2 x)))).
-  Proof.
-    Intro H.
-    Exists [z:S]Cases (H z) of (left _) => true | (right _) => false end.
-    Intro z; NewDestruct (H z); Auto.
-  Qed.
-
-End Choice_lemmas.
-
- (** A result of type [(Exc A)] is either a normal value of type [A] or 
-     an [error] :
-     [Inductive Exc [A:Set] : Set := value : A->(Exc A) | error : (Exc A)]
-     it is implemented using the option type. *) 
-
-Definition Exc := option.
-Definition value := Some.
-Definition error := !None.
-
-Implicits error [1].
-
-Definition except := False_rec. (* for compatibility with previous versions *)
-
-Implicits except [1].
-
-V7only [
-Notation Except := (!except ?) (only parsing).
-Notation Error := (!error ?) (only parsing).
-V7only [Implicits error [].].
-V7only [Implicits except [].].
-].
-Theorem absurd_set : (A:Prop)(C:Set)A->(~A)->C.
-Proof.
-  Intros A C h1 h2.
-  Apply False_rec.
-  Apply (h2 h1).
-Qed.
-
-Hints Resolve left right inleft inright : core v62.
-
-(** Sigma Type at Type level [sigT] *)
-
-Inductive sigT [A:Type;P:A->Type] : Type
-    := existT : (x:A)(P x) -> (sigT A P).
-
-Section projections_sigT.
-
-  Variable A:Type.
-  Variable P:A->Type.
-
-  Definition projT1 : (sigT A P) -> A
-              := [H:(sigT A P)]Cases H of (existT x _) => x end.
-   
-  Definition projT2 : (x:(sigT A P))(P (projT1 x))
-              := [H:(sigT A P)]<[H:(sigT A P)](P (projT1 H))> 
-                     Cases H of (existT x h) => h end.
-
-End projections_sigT.
-
-V7only [
-Notation ProjS1 := (projS1 ? ?).
-Notation ProjS2 := (projS2 ? ?).
-Notation Value := (value ?).
-].
-
diff --git a/theories7/Init/Wf.v b/theories7/Init/Wf.v
deleted file mode 100755
index b65057eb..00000000
--- a/theories7/Init/Wf.v
+++ /dev/null
@@ -1,158 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-Set Implicit Arguments.
-V7only [Unset Implicit Arguments.].
-
-(*i $Id: Wf.v,v 1.1.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
-
-(** This module proves the validity of
-    - well-founded recursion (also called course of values)
-    - well-founded induction
-
-   from a well-founded ordering on a given set *)
-
-Require Notations.
-Require Logic.
-Require Datatypes.
-
-(** Well-founded induction principle on Prop *)
-
-Chapter Well_founded.
-
- Variable A : Set.
- Variable R : A -> A -> Prop.
-
- (** The accessibility predicate is defined to be non-informative *)
-
- Inductive  Acc : A -> Prop 
-    := Acc_intro : (x:A)((y:A)(R y x)->(Acc y))->(Acc x).
-
- Lemma Acc_inv : (x:A)(Acc x) -> (y:A)(R y x) -> (Acc y).
-  NewDestruct 1; Trivial.
- Defined.
-
-  (** the informative elimination :
-     [let Acc_rec F = let rec wf x = F x wf in wf] *)
-
- Section AccRecType.
-  Variable P : A -> Type.
-  Variable F : (x:A)((y:A)(R y x)->(Acc y))->((y:A)(R y x)->(P y))->(P x).
-
-  Fixpoint Acc_rect [x:A;a:(Acc x)] : (P x)
-     := (F x (Acc_inv x a) ([y:A][h:(R y x)](Acc_rect y (Acc_inv x a y h)))).
-
- End AccRecType.
-
- Definition Acc_rec [P:A->Set] := (Acc_rect P).
-
- (** A simplified version of Acc_rec(t) *)
-
- Section AccIter.
-  Variable P : A -> Type. 
-  Variable F : (x:A)((y:A)(R y x)-> (P y))->(P x).
-
-  Fixpoint Acc_iter [x:A;a:(Acc x)] : (P x)
-     := (F x ([y:A][h:(R y x)](Acc_iter y (Acc_inv x a y h)))).
-
- End AccIter.
-
- (** A relation is well-founded if every element is accessible *)
-
- Definition well_founded := (a:A)(Acc a).
-
- (** well-founded induction on Set and Prop *)
-
- Hypothesis Rwf : well_founded.
-
- Theorem well_founded_induction_type : 
-        (P:A->Type)((x:A)((y:A)(R y x)->(P y))->(P x))->(a:A)(P a).
- Proof.
-  Intros; Apply (Acc_iter P); Auto.
- Defined.
-
- Theorem well_founded_induction :
-        (P:A->Set)((x:A)((y:A)(R y x)->(P y))->(P x))->(a:A)(P a).
- Proof.
-  Exact [P:A->Set](well_founded_induction_type P).
- Defined.
-
- Theorem well_founded_ind : 
-         (P:A->Prop)((x:A)((y:A)(R y x)->(P y))->(P x))->(a:A)(P a).
- Proof.
-  Exact [P:A->Prop](well_founded_induction_type P).
- Defined.
-
-(** Building fixpoints  *) 
-
-Section FixPoint.
-
-Variable P : A -> Set.
-Variable F : (x:A)((y:A)(R y x)->(P y))->(P x).
-
-Fixpoint Fix_F [x:A;r:(Acc x)] : (P x) := 
-         (F x [y:A][p:(R y x)](Fix_F y (Acc_inv x r y p))).
-
-Definition fix := [x:A](Fix_F x (Rwf x)).
-
-(** Proof that [well_founded_induction] satisfies the fixpoint equation. 
-    It requires an extra property of the functional *)
-
-Hypothesis F_ext : 
-  (x:A)(f,g:(y:A)(R y x)->(P y))
-  ((y:A)(p:(R y x))((f y p)=(g y p)))->(F x f)=(F x g).
-
-Scheme Acc_inv_dep := Induction for Acc Sort Prop.
-
-Lemma Fix_F_eq
-  : (x:A)(r:(Acc x))
-    (F x [y:A][p:(R y x)](Fix_F y (Acc_inv x r y p)))=(Fix_F x r).
-NewDestruct r using  Acc_inv_dep; Auto.
-Qed.
-
-Lemma Fix_F_inv : (x:A)(r,s:(Acc x))(Fix_F x r)=(Fix_F x s).
-Intro x; NewInduction (Rwf x); Intros.
-Rewrite <- (Fix_F_eq x r); Rewrite <- (Fix_F_eq x s); Intros.
-Apply F_ext; Auto.
-Qed.
-
-
-Lemma Fix_eq : (x:A)(fix x)=(F x [y:A][p:(R y x)](fix y)).
-Intro x; Unfold fix.
-Rewrite <- (Fix_F_eq x).
-Apply F_ext; Intros.
-Apply Fix_F_inv.
-Qed.
-
-End FixPoint.
-
-End Well_founded. 
-
-(** A recursor over pairs *)
-
-Chapter Well_founded_2.
-
-  Variable A,B : Set.
-  Variable R : A * B -> A * B -> Prop.
-
-  Variable P : A -> B -> Type. 
-  Variable F : (x:A)(x':B)((y:A)(y':B)(R (y,y') (x,x'))-> (P y y'))->(P x x').
-
-  Fixpoint Acc_iter_2 [x:A;x':B;a:(Acc ? R (x,x'))] : (P x x')
-     := (F x x' ([y:A][y':B][h:(R (y,y') (x,x'))](Acc_iter_2 y y' (Acc_inv ? ? (x,x') a (y,y') h)))).
-
-  Hypothesis Rwf : (well_founded ? R).
-
-  Theorem well_founded_induction_type_2 : 
-     ((x:A)(x':B)((y:A)(y':B)(R (y,y') (x,x'))->(P y y'))->(P x x'))->(a:A)(b:B)(P a b).
-  Proof.
-   Intros; Apply Acc_iter_2; Auto.
-  Defined.
-
-End Well_founded_2.
-
diff --git a/theories7/IntMap/Adalloc.v b/theories7/IntMap/Adalloc.v
deleted file mode 100644
index 9e8dd1b3..00000000
--- a/theories7/IntMap/Adalloc.v
+++ /dev/null
@@ -1,339 +0,0 @@
-(************************************************************************)
-(*  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: Adalloc.v,v 1.1.2.1 2004/07/16 19:31:26 herbelin Exp $	 i*)
-
-Require Bool.
-Require Sumbool.
-Require ZArith.
-Require Arith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require Fset.
-
-Section AdAlloc.
-
-  Variable A : Set.
-
-  Definition nat_of_ad := [a:ad] Cases a of
-                                     ad_z => O
-				   | (ad_x p) => (convert p)
-			         end.
-
-  Fixpoint nat_le [m:nat] : nat -> bool :=
-    Cases m of
-        O => [_:nat] true
-      | (S m') => [n:nat] Cases n of
-                              O => false
-			    | (S n') => (nat_le m' n')
-			  end
-    end.
-
-  Lemma nat_le_correct : (m,n:nat) (le m n) -> (nat_le m n)=true.
-  Proof.
-    NewInduction m as [|m IHm]. Trivial.
-    NewDestruct n. Intro H. Elim (le_Sn_O ? H).
-    Intros. Simpl. Apply IHm. Apply le_S_n. Assumption.
-  Qed.
-
-  Lemma nat_le_complete : (m,n:nat) (nat_le m n)=true -> (le m n).
-  Proof.
-    NewInduction m. Trivial with arith.
-    NewDestruct n. Intro H. Discriminate H.
-    Auto with arith.
-  Qed.
-
-  Lemma nat_le_correct_conv : (m,n:nat) (lt m n) -> (nat_le n m)=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (nat_le n m)). Intro H0.
-    Elim (lt_n_n ? (lt_le_trans ? ? ? H (nat_le_complete ? ? H0))).
-    Trivial.
-  Qed.
-
-  Lemma nat_le_complete_conv : (m,n:nat) (nat_le n m)=false -> (lt m n).
-  Proof.
-    Intros. Elim (le_or_lt n m). Intro. Conditional Trivial Rewrite nat_le_correct in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Definition ad_of_nat := [n:nat] Cases n of
-                                      O => ad_z
-				    | (S n') => (ad_x (anti_convert n'))
-				  end.
-
-  Lemma ad_of_nat_of_ad : (a:ad) (ad_of_nat (nat_of_ad a))=a.
-  Proof.
-    NewDestruct a as [|p]. Reflexivity.
-    Simpl. Elim (ZL4 p). Intros n H. Rewrite H. Simpl. Rewrite <- bij1 in H.
-    Rewrite convert_intro with 1:=H. Reflexivity.
-  Qed.
-
-  Lemma nat_of_ad_of_nat : (n:nat) (nat_of_ad (ad_of_nat n))=n.
-  Proof.
-    NewInduction n. Trivial.
-    Intros. Simpl. Apply bij1.
-  Qed.
-
-  Definition ad_le := [a,b:ad] (nat_le (nat_of_ad a) (nat_of_ad b)).
-
-  Lemma ad_le_refl : (a:ad) (ad_le a a)=true.
-  Proof.
-    Intro. Unfold ad_le. Apply nat_le_correct. Apply le_n.
-  Qed.
-
-  Lemma ad_le_antisym : (a,b:ad) (ad_le a b)=true -> (ad_le b a)=true -> a=b.
-  Proof.
-    Unfold ad_le. Intros. Rewrite <- (ad_of_nat_of_ad a). Rewrite <- (ad_of_nat_of_ad b).
-    Rewrite (le_antisym ? ? (nat_le_complete ? ? H) (nat_le_complete ? ? H0)). Reflexivity.
-  Qed.
-
-  Lemma ad_le_trans : (a,b,c:ad) (ad_le a b)=true -> (ad_le b c)=true -> 
-      (ad_le a c)=true.
-  Proof.
-    Unfold ad_le. Intros. Apply nat_le_correct. Apply le_trans with m:=(nat_of_ad b).
-    Apply nat_le_complete. Assumption.
-    Apply nat_le_complete. Assumption.
-  Qed.
-
-  Lemma ad_le_lt_trans : (a,b,c:ad) (ad_le a b)=true -> (ad_le c b)=false -> 
-      (ad_le c a)=false.
-  Proof.
-    Unfold ad_le. Intros. Apply nat_le_correct_conv. Apply le_lt_trans with m:=(nat_of_ad b).
-    Apply nat_le_complete. Assumption.
-    Apply nat_le_complete_conv. Assumption.
-  Qed.
-
-  Lemma ad_lt_le_trans : (a,b,c:ad) (ad_le b a)=false -> (ad_le b c)=true -> 
-      (ad_le c a)=false.
-  Proof.
-    Unfold ad_le. Intros. Apply nat_le_correct_conv. Apply lt_le_trans with m:=(nat_of_ad b).
-    Apply nat_le_complete_conv. Assumption.
-    Apply nat_le_complete. Assumption.
-  Qed.
-
-  Lemma ad_lt_trans : (a,b,c:ad) (ad_le b a)=false -> (ad_le c b)=false -> 
-      (ad_le c a)=false.
-  Proof.
-    Unfold ad_le. Intros. Apply nat_le_correct_conv. Apply lt_trans with m:=(nat_of_ad b).
-    Apply nat_le_complete_conv. Assumption.
-    Apply nat_le_complete_conv. Assumption.
-  Qed.
-
-  Lemma ad_lt_le_weak : (a,b:ad) (ad_le b a)=false -> (ad_le a b)=true.
-  Proof.
-    Unfold ad_le. Intros. Apply nat_le_correct. Apply lt_le_weak.
-    Apply nat_le_complete_conv. Assumption.
-  Qed.
-
-  Definition ad_min := [a,b:ad] if (ad_le a b) then a else b.
-
-  Lemma ad_min_choice : (a,b:ad) {(ad_min a b)=a}+{(ad_min a b)=b}.
-  Proof.
-    Unfold ad_min. Intros. Elim (sumbool_of_bool (ad_le a b)). Intro H. Left . Rewrite H.
-    Reflexivity.
-    Intro H. Right . Rewrite H. Reflexivity.
-  Qed.
-
-  Lemma ad_min_le_1 : (a,b:ad) (ad_le (ad_min a b) a)=true.
-  Proof.
-    Unfold ad_min. Intros. Elim (sumbool_of_bool (ad_le a b)). Intro H. Rewrite H.
-    Apply ad_le_refl.
-    Intro H. Rewrite H. Apply ad_lt_le_weak. Assumption.
-  Qed.
-
-  Lemma ad_min_le_2 : (a,b:ad) (ad_le (ad_min a b) b)=true.
-  Proof.
-    Unfold ad_min. Intros. Elim (sumbool_of_bool (ad_le a b)). Intro H. Rewrite H. Assumption.
-    Intro H. Rewrite H. Apply ad_le_refl.
-  Qed.
-
-  Lemma ad_min_le_3 : (a,b,c:ad) (ad_le a (ad_min b c))=true -> (ad_le a b)=true.
-  Proof.
-    Unfold ad_min. Intros. Elim (sumbool_of_bool (ad_le b c)). Intro H0. Rewrite H0 in H.
-    Assumption.
-    Intro H0. Rewrite H0 in H. Apply ad_lt_le_weak. Apply ad_le_lt_trans with b:=c; Assumption.
-  Qed.
-
-  Lemma ad_min_le_4 : (a,b,c:ad) (ad_le a (ad_min b c))=true -> (ad_le a c)=true.
-  Proof.
-    Unfold ad_min. Intros. Elim (sumbool_of_bool (ad_le b c)). Intro H0. Rewrite H0 in H.
-    Apply ad_le_trans with b:=b; Assumption.
-    Intro H0. Rewrite H0 in H. Assumption.
-  Qed.
-
-  Lemma ad_min_le_5 : (a,b,c:ad) (ad_le a b)=true -> (ad_le a c)=true ->
-      (ad_le a (ad_min b c))=true.
-  Proof.
-    Intros. Elim (ad_min_choice b c). Intro H1. Rewrite H1. Assumption.
-    Intro H1. Rewrite H1. Assumption.
-  Qed.
-
-  Lemma ad_min_lt_3 : (a,b,c:ad) (ad_le (ad_min b c) a)=false -> (ad_le b a)=false.
-  Proof.
-    Unfold ad_min. Intros. Elim (sumbool_of_bool (ad_le b c)). Intro H0. Rewrite H0 in H.
-    Assumption.
-    Intro H0. Rewrite H0 in H. Apply ad_lt_trans with b:=c; Assumption.
-  Qed.
-
-  Lemma ad_min_lt_4 : (a,b,c:ad) (ad_le (ad_min b c) a)=false -> (ad_le c a)=false.
-  Proof.
-    Unfold ad_min. Intros. Elim (sumbool_of_bool (ad_le b c)). Intro H0. Rewrite H0 in H.
-    Apply ad_lt_le_trans with b:=b; Assumption.
-    Intro H0. Rewrite H0 in H. Assumption.
-  Qed.
-
-  (** Allocator: returns an address not in the domain of [m].
-  This allocator is optimal in that it returns the lowest possible address,
-  in the usual ordering on integers. It is not the most efficient, however. *)
-  Fixpoint ad_alloc_opt [m:(Map A)] : ad :=
-    Cases m of
-        M0 => ad_z
-      | (M1 a _) => if (ad_eq a ad_z)
-                    then (ad_x xH)
-		    else ad_z
-      | (M2 m1 m2) => (ad_min (ad_double (ad_alloc_opt m1))
-                              (ad_double_plus_un (ad_alloc_opt m2)))
-    end.
-
-  Lemma ad_alloc_opt_allocates_1 : (m:(Map A)) (MapGet A m (ad_alloc_opt m))=(NONE A).
-  Proof.
-    NewInduction m as [|a|m0 H m1 H0]. Reflexivity.
-    Simpl. Elim (sumbool_of_bool (ad_eq a ad_z)). Intro H. Rewrite H.
-    Rewrite (ad_eq_complete ? ? H). Reflexivity.
-    Intro H. Rewrite H. Rewrite H. Reflexivity.
-    Intros. Change (ad_alloc_opt (M2 A m0 m1)) with
-         (ad_min (ad_double (ad_alloc_opt m0)) (ad_double_plus_un (ad_alloc_opt m1))).
-    Elim (ad_min_choice (ad_double (ad_alloc_opt m0)) (ad_double_plus_un (ad_alloc_opt m1))).
-    Intro H1. Rewrite H1. Rewrite MapGet_M2_bit_0_0. Rewrite ad_double_div_2. Assumption.
-    Apply ad_double_bit_0.
-    Intro H1. Rewrite H1. Rewrite MapGet_M2_bit_0_1. Rewrite ad_double_plus_un_div_2. Assumption.
-    Apply ad_double_plus_un_bit_0.
-  Qed.
-
-  Lemma ad_alloc_opt_allocates : (m:(Map A)) (in_dom A (ad_alloc_opt m) m)=false.
-  Proof.
-    Unfold in_dom. Intro. Rewrite (ad_alloc_opt_allocates_1 m). Reflexivity.
-  Qed.
-
-  (** Moreover, this is optimal: all addresses below [(ad_alloc_opt m)]
-      are in [dom m]: *)
-
-  Lemma nat_of_ad_double : (a:ad) (nat_of_ad (ad_double a))=(mult (2) (nat_of_ad a)).
-  Proof.
-    NewDestruct a as [|p]. Trivial.
-    Exact (convert_xO p).
-  Qed.
-
-  Lemma nat_of_ad_double_plus_un : (a:ad)
-      (nat_of_ad (ad_double_plus_un a))=(S (mult (2) (nat_of_ad a))).
-  Proof.
-    NewDestruct a as [|p]. Trivial.
-    Exact (convert_xI p).
-  Qed.
-
-  Lemma ad_le_double_mono : (a,b:ad) (ad_le a b)=true -> 
-      (ad_le (ad_double a) (ad_double b))=true.
-  Proof.
-    Unfold ad_le. Intros. Rewrite nat_of_ad_double. Rewrite nat_of_ad_double. Apply nat_le_correct.
-    Simpl. Apply le_plus_plus. Apply nat_le_complete. Assumption.
-    Apply le_plus_plus. Apply nat_le_complete. Assumption.
-    Apply le_n.
-  Qed.
-
-  Lemma ad_le_double_plus_un_mono : (a,b:ad) (ad_le a b)=true ->
-      (ad_le (ad_double_plus_un a) (ad_double_plus_un b))=true.
-  Proof.
-    Unfold ad_le. Intros. Rewrite nat_of_ad_double_plus_un. Rewrite nat_of_ad_double_plus_un.
-    Apply nat_le_correct. Apply le_n_S. Simpl. Apply le_plus_plus. Apply nat_le_complete.
-    Assumption.
-    Apply le_plus_plus. Apply nat_le_complete. Assumption.
-    Apply le_n.
-  Qed.
-
-  Lemma ad_le_double_mono_conv : (a,b:ad) (ad_le (ad_double a) (ad_double b))=true ->
-      (ad_le a b)=true.
-  Proof.
-    Unfold ad_le. Intros a b. Rewrite nat_of_ad_double. Rewrite nat_of_ad_double. Intro.
-    Apply nat_le_correct. Apply (mult_le_conv_1 (1)). Apply nat_le_complete. Assumption.
-  Qed.
-
-  Lemma ad_le_double_plus_un_mono_conv : (a,b:ad)
-      (ad_le (ad_double_plus_un a) (ad_double_plus_un b))=true -> (ad_le a b)=true.
-  Proof.
-    Unfold ad_le. Intros a b. Rewrite nat_of_ad_double_plus_un. Rewrite nat_of_ad_double_plus_un.
-    Intro. Apply nat_le_correct. Apply (mult_le_conv_1 (1)). Apply le_S_n. Apply nat_le_complete.
-    Assumption.
-  Qed.
-
-  Lemma ad_lt_double_mono : (a,b:ad) (ad_le a b)=false ->
-      (ad_le (ad_double a) (ad_double b))=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_le (ad_double a) (ad_double b))). Intro H0.
-    Rewrite (ad_le_double_mono_conv ? ? H0) in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma ad_lt_double_plus_un_mono : (a,b:ad) (ad_le a b)=false ->
-      (ad_le (ad_double_plus_un a) (ad_double_plus_un b))=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_le (ad_double_plus_un a) (ad_double_plus_un b))). Intro H0.
-    Rewrite (ad_le_double_plus_un_mono_conv ? ? H0) in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma ad_lt_double_mono_conv : (a,b:ad) (ad_le (ad_double a) (ad_double b))=false ->
-      (ad_le a b)=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_le a b)). Intro H0. Rewrite (ad_le_double_mono ? ? H0) in H.
-    Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma ad_lt_double_plus_un_mono_conv : (a,b:ad)
-      (ad_le (ad_double_plus_un a) (ad_double_plus_un b))=false -> (ad_le a b)=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_le a b)). Intro H0.
-    Rewrite (ad_le_double_plus_un_mono ? ? H0) in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma ad_alloc_opt_optimal_1 : (m:(Map A)) (a:ad) (ad_le (ad_alloc_opt m) a)=false ->
-      {y:A | (MapGet A m a)=(SOME A y)}.
-  Proof.
-    NewInduction m as [|a y|m0 H m1 H0]. Simpl. Unfold ad_le. Simpl. Intros. Discriminate H.
-    Simpl. Intros b H. Elim (sumbool_of_bool (ad_eq a ad_z)). Intro H0. Rewrite H0 in H.
-    Unfold ad_le in H. Cut ad_z=b. Intro. Split with y. Rewrite <- H1. Rewrite H0. Reflexivity.
-    Rewrite <- (ad_of_nat_of_ad b).
-    Rewrite <- (le_n_O_eq ? (le_S_n ? ? (nat_le_complete_conv ? ? H))). Reflexivity.
-    Intro H0. Rewrite H0 in H. Discriminate H.
-    Intros. Simpl in H1. Elim (ad_double_or_double_plus_un a). Intro H2. Elim H2. Intros a0 H3.
-    Rewrite H3 in H1. Elim (H ? (ad_lt_double_mono_conv ? ? (ad_min_lt_3 ? ? ? H1))). Intros y H4.
-    Split with y. Rewrite H3. Rewrite MapGet_M2_bit_0_0. Rewrite ad_double_div_2. Assumption.
-    Apply ad_double_bit_0.
-    Intro H2. Elim H2. Intros a0 H3. Rewrite H3 in H1.
-    Elim (H0 ? (ad_lt_double_plus_un_mono_conv ? ? (ad_min_lt_4 ? ? ? H1))). Intros y H4.
-    Split with y. Rewrite H3. Rewrite MapGet_M2_bit_0_1. Rewrite ad_double_plus_un_div_2.
-    Assumption.
-    Apply ad_double_plus_un_bit_0.
-  Qed.
-
-  Lemma ad_alloc_opt_optimal : (m:(Map A)) (a:ad) (ad_le (ad_alloc_opt m) a)=false ->
-      (in_dom A a m)=true.
-  Proof.
-    Intros. Unfold in_dom. Elim (ad_alloc_opt_optimal_1 m a H). Intros y H0. Rewrite H0.
-    Reflexivity.
-  Qed.
-
-End AdAlloc.
-
-V7only [
-(* Moved to NArith *)
-Notation positive_to_nat_2 := positive_to_nat_2.
-Notation positive_to_nat_4 := positive_to_nat_4.
-].
diff --git a/theories7/IntMap/Addec.v b/theories7/IntMap/Addec.v
deleted file mode 100644
index 50dc1480..00000000
--- a/theories7/IntMap/Addec.v
+++ /dev/null
@@ -1,179 +0,0 @@
-(************************************************************************)
-(*  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: Addec.v,v 1.1.2.1 2004/07/16 19:31:26 herbelin Exp $	 i*)
-
-(** Equality on adresses *)
-
-Require Bool.
-Require Sumbool.
-Require ZArith.
-Require Addr.
-
-Fixpoint ad_eq_1 [p1,p2:positive] : bool :=
-  Cases p1 p2 of
-      xH xH => true
-    | (xO p'1) (xO p'2) => (ad_eq_1 p'1 p'2)
-    | (xI p'1) (xI p'2) => (ad_eq_1 p'1 p'2)
-    | _ _ => false
-  end.
-
-Definition ad_eq := [a,a':ad]
-  Cases a a' of
-      ad_z ad_z => true
-    | (ad_x p) (ad_x p') => (ad_eq_1 p p')
-    | _ _ => false
-  end.
-
-Lemma ad_eq_correct : (a:ad) (ad_eq a a)=true.
-Proof.
-  NewDestruct a; Trivial.
-  NewInduction p; Trivial.
-Qed.
-
-Lemma ad_eq_complete : (a,a':ad) (ad_eq a a')=true -> a=a'.
-Proof.
-  NewDestruct a. NewDestruct a'; Trivial. NewDestruct p.
-  Discriminate 1.
-  Discriminate 1.
-  Discriminate 1.
-  NewDestruct a'. Intros. Discriminate H.
-  Unfold ad_eq. Intros. Cut p=p0. Intros. Rewrite H0. Reflexivity.
-  Generalize Dependent p0.
-  NewInduction p as [p IHp|p IHp|]. NewDestruct p0; Intro H.
-  Rewrite (IHp p0). Reflexivity.
-  Exact H.
-  Discriminate H.
-  Discriminate H.
-  NewDestruct p0; Intro H. Discriminate H.
-  Rewrite (IHp p0 H). Reflexivity.
-  Discriminate H.
-  NewDestruct p0; Intro H. Discriminate H.
-  Discriminate H.
-  Trivial.
-Qed.
-
-Lemma ad_eq_comm : (a,a':ad) (ad_eq a a')=(ad_eq a' a).
-Proof.
-  Intros. Cut (b,b':bool)(ad_eq a a')=b->(ad_eq a' a)=b'->b=b'.
-  Intros. Apply H. Reflexivity.
-  Reflexivity.
-  NewDestruct b. Intros. Cut a=a'.
-  Intro. Rewrite H1 in H0. Rewrite (ad_eq_correct a') in H0. Exact H0.
-  Apply ad_eq_complete. Exact H.
-  NewDestruct b'. Intros. Cut a'=a.
-  Intro. Rewrite H1 in H. Rewrite H1 in H0. Rewrite <- H. Exact H0.
-  Apply ad_eq_complete. Exact H0.
-  Trivial.
-Qed.
-
-Lemma ad_xor_eq_true : (a,a':ad) (ad_xor a a')=ad_z -> (ad_eq a a')=true.
-Proof.
-  Intros. Rewrite (ad_xor_eq a a' H). Apply ad_eq_correct.
-Qed.
-
-Lemma ad_xor_eq_false :
-    (a,a':ad) (p:positive) (ad_xor a a')=(ad_x p) -> (ad_eq a a')=false.
-Proof.
-  Intros. Elim (sumbool_of_bool (ad_eq a a')). Intro H0.
-  Rewrite (ad_eq_complete a a' H0) in H. Rewrite (ad_xor_nilpotent a') in H. Discriminate H.
-  Trivial.
-Qed.
-
-Lemma ad_bit_0_1_not_double : (a:ad) (ad_bit_0 a)=true ->
-      (a0:ad) (ad_eq (ad_double a0) a)=false.
-Proof.
-  Intros. Elim (sumbool_of_bool (ad_eq (ad_double a0) a)). Intro H0.
-  Rewrite <- (ad_eq_complete ? ? H0) in H. Rewrite (ad_double_bit_0 a0) in H. Discriminate H.
-  Trivial.
-Qed.
-
-Lemma ad_not_div_2_not_double : (a,a0:ad) (ad_eq (ad_div_2 a) a0)=false ->
-      (ad_eq a (ad_double a0))=false.
-Proof.
-  Intros. Elim (sumbool_of_bool (ad_eq (ad_double a0) a)). Intro H0.
-  Rewrite <- (ad_eq_complete ? ? H0) in H. Rewrite (ad_double_div_2 a0) in H.
-  Rewrite (ad_eq_correct a0) in H. Discriminate H.
-  Intro. Rewrite ad_eq_comm. Assumption.
-Qed.
-
-Lemma ad_bit_0_0_not_double_plus_un : (a:ad) (ad_bit_0 a)=false ->
-      (a0:ad) (ad_eq (ad_double_plus_un a0) a)=false.
-Proof.
-  Intros. Elim (sumbool_of_bool (ad_eq (ad_double_plus_un a0) a)). Intro H0.
-  Rewrite <- (ad_eq_complete ? ? H0) in H. Rewrite (ad_double_plus_un_bit_0 a0) in H.
-  Discriminate H.
-  Trivial.
-Qed.
-
-Lemma ad_not_div_2_not_double_plus_un : (a,a0:ad) (ad_eq (ad_div_2 a) a0)=false ->
-      (ad_eq (ad_double_plus_un a0) a)=false.
-Proof.
-  Intros. Elim (sumbool_of_bool (ad_eq a (ad_double_plus_un a0))). Intro H0.
-  Rewrite (ad_eq_complete ? ? H0) in H. Rewrite (ad_double_plus_un_div_2 a0) in H.
-  Rewrite (ad_eq_correct a0) in H. Discriminate H.
-  Intro H0. Rewrite ad_eq_comm. Assumption.
-Qed.
-
-Lemma ad_bit_0_neq :
-    (a,a':ad) (ad_bit_0 a)=false -> (ad_bit_0 a')=true -> (ad_eq a a')=false.
-Proof.
-  Intros. Elim (sumbool_of_bool (ad_eq a a')). Intro H1. Rewrite (ad_eq_complete ? ? H1) in H.
-  Rewrite H in H0. Discriminate H0.
-  Trivial.
-Qed.
-
-Lemma ad_div_eq :
-    (a,a':ad) (ad_eq a a')=true -> (ad_eq (ad_div_2 a) (ad_div_2 a'))=true.
-Proof.
-  Intros. Cut a=a'. Intros. Rewrite H0. Apply ad_eq_correct.
-  Apply ad_eq_complete. Exact H.
-Qed.
-
-Lemma ad_div_neq : (a,a':ad) (ad_eq (ad_div_2 a) (ad_div_2 a'))=false -> 
-    (ad_eq a a')=false.
-Proof.
-  Intros. Elim (sumbool_of_bool (ad_eq a a')). Intro H0.
-  Rewrite (ad_eq_complete ? ? H0) in H. Rewrite (ad_eq_correct (ad_div_2 a')) in H. Discriminate H.
-  Trivial.
-Qed.
-
-Lemma ad_div_bit_eq : (a,a':ad) (ad_bit_0 a)=(ad_bit_0 a') ->
-    (ad_div_2 a)=(ad_div_2 a') -> a=a'.
-Proof.
-  Intros. Apply ad_faithful. Unfold eqf. NewDestruct n.
-  Rewrite ad_bit_0_correct. Rewrite ad_bit_0_correct. Assumption.
-  Rewrite <- ad_div_2_correct. Rewrite <- ad_div_2_correct.
-  Rewrite H0. Reflexivity.
-Qed.
-
-Lemma ad_div_bit_neq : (a,a':ad) (ad_eq a a')=false -> (ad_bit_0 a)=(ad_bit_0 a') ->
-    (ad_eq (ad_div_2 a) (ad_div_2 a'))=false.
-Proof.
-  Intros. Elim (sumbool_of_bool (ad_eq (ad_div_2 a) (ad_div_2 a'))). Intro H1.
-  Rewrite (ad_div_bit_eq ? ? H0 (ad_eq_complete ? ? H1)) in H.
-  Rewrite (ad_eq_correct a') in H. Discriminate H.
-  Trivial.
-Qed.
-
-Lemma ad_neq : (a,a':ad) (ad_eq a a')=false ->
-    (ad_bit_0 a)=(negb (ad_bit_0 a')) \/ (ad_eq (ad_div_2 a) (ad_div_2 a'))=false.
-Proof.
-  Intros. Cut (ad_bit_0 a)=(ad_bit_0 a')\/(ad_bit_0 a)=(negb (ad_bit_0 a')).
-  Intros. Elim H0. Intro. Right . Apply ad_div_bit_neq. Assumption.
-  Assumption.
-  Intro. Left . Assumption.
-  Case (ad_bit_0 a); Case (ad_bit_0 a'); Auto.
-Qed.
-
-Lemma ad_double_or_double_plus_un : (a:ad)
-    {a0:ad | a=(ad_double a0)}+{a1:ad | a=(ad_double_plus_un a1)}.
-Proof.
-  Intro. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H. Right . Split with (ad_div_2 a).
-  Rewrite (ad_div_2_double_plus_un a H). Reflexivity.
-  Intro H. Left . Split with (ad_div_2 a). Rewrite (ad_div_2_double a H). Reflexivity.
-Qed.
diff --git a/theories7/IntMap/Addr.v b/theories7/IntMap/Addr.v
deleted file mode 100644
index 9f362772..00000000
--- a/theories7/IntMap/Addr.v
+++ /dev/null
@@ -1,456 +0,0 @@
-(************************************************************************)
-(*  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: Addr.v,v 1.1.2.1 2004/07/16 19:31:27 herbelin Exp $	 i*)
-
-(** Representation of adresses by the [positive] type of binary numbers *)
-
-Require Bool.
-Require ZArith.
-
-Inductive ad : Set :=
-    ad_z : ad
-  | ad_x : positive -> ad.
-
-Lemma ad_sum : (a:ad) {p:positive | a=(ad_x p)}+{a=ad_z}.
-Proof.
-  NewDestruct a; Auto.
-  Left; Exists p; Trivial.
-Qed.
-
-Fixpoint p_xor [p:positive] : positive -> ad :=
-  [p2] Cases p of
-      xH => Cases p2 of
-	        xH => ad_z
-	      | (xO p'2) => (ad_x (xI p'2))
-	      | (xI p'2) => (ad_x (xO p'2))
-	    end
-    | (xO p') => Cases p2 of
-                     xH => (ad_x (xI p'))
-		   | (xO p'2) => Cases (p_xor p' p'2) of
-		                     ad_z => ad_z
-				   | (ad_x p'') => (ad_x (xO p''))
-				 end
-		   | (xI p'2) => Cases (p_xor p' p'2) of
-		                     ad_z => (ad_x xH)
-				   | (ad_x p'') => (ad_x (xI p''))
-				 end
-                 end
-    | (xI p') => Cases p2 of
-		     xH => (ad_x (xO p'))
-		   | (xO p'2) => Cases (p_xor p' p'2) of
-		                     ad_z => (ad_x xH)
-				   | (ad_x p'') => (ad_x (xI p''))
-				 end
-		   | (xI p'2) => Cases (p_xor p' p'2) of
-		                     ad_z => ad_z
-				   | (ad_x p'') => (ad_x (xO p''))
-				 end
-                 end
-  end.
-
-Definition ad_xor := [a,a':ad]
-  Cases a of
-      ad_z => a'
-    | (ad_x p) => Cases a' of
-                      ad_z => a
-	            | (ad_x p') => (p_xor p p')
-                  end
-  end.
-
-Lemma ad_xor_neutral_left : (a:ad) (ad_xor ad_z a)=a.
-Proof.
-  Trivial.
-Qed.
-
-Lemma ad_xor_neutral_right : (a:ad) (ad_xor a ad_z)=a.
-Proof.
-  NewDestruct a; Trivial.
-Qed.
-
-Lemma ad_xor_comm : (a,a':ad) (ad_xor a a')=(ad_xor a' a).
-Proof.
-  NewDestruct a; NewDestruct a'; Simpl; Auto.
-  Generalize p0; Clear p0; NewInduction p as [p Hrecp|p Hrecp|]; Simpl; Auto.
-  NewDestruct p0; Simpl; Trivial; Intros.
-  Rewrite Hrecp; Trivial.
-  Rewrite Hrecp; Trivial.
-  NewDestruct p0; Simpl; Trivial; Intros.
-  Rewrite Hrecp; Trivial.
-  Rewrite Hrecp; Trivial.
-  NewDestruct p0; Simpl; Auto.
-Qed.
-
-Lemma ad_xor_nilpotent : (a:ad) (ad_xor a a)=ad_z.
-Proof.
-  NewDestruct a; Trivial.
-  Simpl. NewInduction p as [p IHp|p IHp|]; Trivial.
-  Simpl. Rewrite IHp; Reflexivity.
-  Simpl. Rewrite IHp; Reflexivity.
-Qed.
-
-Fixpoint ad_bit_1 [p:positive] : nat -> bool :=
-  Cases p of
-      xH => [n:nat] Cases n of
-                        O => true
-		      | (S _) => false
-		    end
-    | (xO p) => [n:nat] Cases n of
-                            O => false
-			  | (S n') => (ad_bit_1 p n')
-		        end
-    | (xI p) => [n:nat] Cases n of
-                            O => true
-			  | (S n') => (ad_bit_1 p n')
-		        end
-  end.
-
-Definition ad_bit := [a:ad]
-  Cases a of
-      ad_z => [_:nat] false
-    | (ad_x p) => (ad_bit_1 p)
-  end.
-
-Definition eqf := [f,g:nat->bool] (n:nat) (f n)=(g n).
-
-Lemma ad_faithful_1 : (a:ad) (eqf (ad_bit ad_z) (ad_bit a)) -> ad_z=a.
-Proof.
-  NewDestruct a. Trivial.
-  NewInduction p as [p IHp|p IHp|];Intro H. Absurd ad_z=(ad_x p). Discriminate.
-  Exact (IHp [n:nat](H (S n))).
-  Absurd ad_z=(ad_x p). Discriminate.
-  Exact (IHp [n:nat](H (S n))).
-  Absurd false=true. Discriminate.
-  Exact (H O).
-Qed.
-
-Lemma ad_faithful_2 : (a:ad) (eqf (ad_bit (ad_x xH)) (ad_bit a)) -> (ad_x xH)=a.
-Proof.
-  NewDestruct a. Intros. Absurd true=false. Discriminate.
-  Exact (H O).
-  NewDestruct p. Intro H. Absurd ad_z=(ad_x p). Discriminate.
-  Exact (ad_faithful_1 (ad_x p) [n:nat](H (S n))).
-  Intros. Absurd true=false. Discriminate.
-  Exact (H O).
-  Trivial.
-Qed.
-
-Lemma ad_faithful_3 :
-    (a:ad) (p:positive)
-      ((p':positive) (eqf (ad_bit (ad_x p)) (ad_bit (ad_x p'))) -> p=p') ->
-        (eqf (ad_bit (ad_x (xO p))) (ad_bit a)) ->
-          (ad_x (xO p))=a.
-Proof.
-  NewDestruct a. Intros. Cut (eqf (ad_bit ad_z) (ad_bit (ad_x (xO p)))).
-  Intro. Rewrite (ad_faithful_1 (ad_x (xO p)) H1). Reflexivity.
-  Unfold eqf. Intro. Unfold eqf in H0. Rewrite H0. Reflexivity.
-  Case p. Intros. Absurd false=true. Discriminate.
-  Exact (H0 O).
-  Intros. Rewrite (H p0 [n:nat](H0 (S n))). Reflexivity.
-  Intros. Absurd false=true. Discriminate.
-  Exact (H0 O).
-Qed.
-
-Lemma ad_faithful_4 :
-    (a:ad) (p:positive)
-      ((p':positive) (eqf (ad_bit (ad_x p)) (ad_bit (ad_x p'))) -> p=p') ->
-        (eqf (ad_bit (ad_x (xI p))) (ad_bit a)) ->
-          (ad_x (xI p))=a.
-Proof.
-  NewDestruct a. Intros. Cut (eqf (ad_bit ad_z) (ad_bit (ad_x (xI p)))).
-  Intro. Rewrite (ad_faithful_1 (ad_x (xI p)) H1). Reflexivity.
-  Unfold eqf. Intro. Unfold eqf in H0. Rewrite H0. Reflexivity.
-  Case p. Intros. Rewrite (H p0 [n:nat](H0 (S n))). Reflexivity.
-  Intros. Absurd true=false. Discriminate.
-  Exact (H0 O).
-  Intros. Absurd ad_z=(ad_x p0). Discriminate.
-  Cut (eqf (ad_bit (ad_x xH)) (ad_bit (ad_x (xI p0)))).
-  Intro. Exact (ad_faithful_1 (ad_x p0) [n:nat](H1 (S n))).
-  Unfold eqf. Unfold eqf in H0. Intro. Rewrite H0. Reflexivity.
-Qed.
-
-Lemma ad_faithful : (a,a':ad) (eqf (ad_bit a) (ad_bit a')) -> a=a'.
-Proof.
-  NewDestruct a. Exact ad_faithful_1.
-  NewInduction p. Intros a' H. Apply ad_faithful_4. Intros. Cut (ad_x p)=(ad_x p').
-  Intro. Inversion H1. Reflexivity.
-  Exact (IHp (ad_x p') H0).
-  Assumption.
-  Intros. Apply ad_faithful_3. Intros. Cut (ad_x p)=(ad_x p'). Intro. Inversion H1. Reflexivity.
-  Exact (IHp (ad_x p') H0).
-  Assumption.
-  Exact ad_faithful_2.
-Qed.
-
-Definition adf_xor := [f,g:nat->bool; n:nat] (xorb (f n) (g n)).
-
-Lemma ad_xor_sem_1 : (a':ad) (ad_bit (ad_xor ad_z a') O)=(ad_bit a' O).
-Proof.
-  Trivial.
-Qed.
-
-Lemma ad_xor_sem_2 : (a':ad) (ad_bit (ad_xor (ad_x xH) a') O)=(negb (ad_bit a' O)).
-Proof.
-  Intro. Case a'. Trivial.
-  Simpl. Intro. 
-  Case p; Trivial.
-Qed.
-
-Lemma ad_xor_sem_3 :
-    (p:positive) (a':ad) (ad_bit (ad_xor (ad_x (xO p)) a') O)=(ad_bit a' O).
-Proof.
-  Intros. Case a'. Trivial.
-  Simpl. Intro. 
-  Case p0; Trivial. Intro. 
-  Case (p_xor p p1); Trivial.
-  Intro. Case (p_xor p p1); Trivial.
-Qed.
-
-Lemma ad_xor_sem_4 : (p:positive) (a':ad)
-    (ad_bit (ad_xor (ad_x (xI p)) a') O)=(negb (ad_bit a' O)).
-Proof.
-  Intros. Case a'. Trivial.
-  Simpl. Intro. Case p0; Trivial. Intro. 
-  Case (p_xor p p1); Trivial.
-  Intro. 
-  Case (p_xor p p1); Trivial.
-Qed.
-
-Lemma ad_xor_sem_5 :
-    (a,a':ad) (ad_bit (ad_xor a a') O)=(adf_xor (ad_bit a) (ad_bit a') O).
-Proof.
-  NewDestruct a. Intro. Change (ad_bit a' O)=(xorb false (ad_bit a' O)). Rewrite false_xorb. Trivial.
-  Case p. Exact ad_xor_sem_4.
-  Intros. Change (ad_bit (ad_xor (ad_x (xO p0)) a') O)=(xorb false (ad_bit a' O)).
-  Rewrite false_xorb. Apply ad_xor_sem_3. Exact ad_xor_sem_2.
-Qed.
-
-Lemma ad_xor_sem_6 : (n:nat)
-    ((a,a':ad) (ad_bit (ad_xor a a') n)=(adf_xor (ad_bit a) (ad_bit a') n)) ->
-      (a,a':ad) (ad_bit (ad_xor a a') (S n))=(adf_xor (ad_bit a) (ad_bit a') (S n)).
-Proof.
-  Intros. Case a. Unfold adf_xor. Unfold 2 ad_bit. Rewrite false_xorb. Reflexivity.
-  Case a'. Unfold adf_xor. Unfold 3 ad_bit. Intro. Rewrite xorb_false. Reflexivity.
-  Intros. Case p0. Case p. Intros.
-  Change (ad_bit (ad_xor (ad_x (xI p2)) (ad_x (xI p1))) (S n))
-        =(adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n).
-  Rewrite <- H. Simpl. 
-  Case (p_xor p2 p1); Trivial.
-  Intros.
-  Change (ad_bit (ad_xor (ad_x (xI p2)) (ad_x (xO p1))) (S n))
-        =(adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n).
-  Rewrite <- H. Simpl. 
-  Case (p_xor p2 p1); Trivial.
-  Intro. Unfold adf_xor. Unfold 3 ad_bit. Unfold ad_bit_1. Rewrite xorb_false. Reflexivity.
-  Case p. Intros.
-  Change (ad_bit (ad_xor (ad_x (xO p2)) (ad_x (xI p1))) (S n))
-        =(adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n).
-  Rewrite <- H. Simpl. 
-  Case (p_xor p2 p1); Trivial.
-  Intros.
-  Change (ad_bit (ad_xor (ad_x (xO p2)) (ad_x (xO p1))) (S n))
-        =(adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n).
-  Rewrite <- H. Simpl. 
-  Case (p_xor p2 p1); Trivial.
-  Intro. Unfold adf_xor. Unfold 3 ad_bit. Unfold ad_bit_1. Rewrite xorb_false. Reflexivity.
-  Unfold adf_xor. Unfold 2 ad_bit. Unfold ad_bit_1. Rewrite false_xorb. Simpl.   Case p; Trivial.
-Qed.
-
-Lemma ad_xor_semantics :
-    (a,a':ad) (eqf (ad_bit (ad_xor a a')) (adf_xor (ad_bit a) (ad_bit a'))).
-Proof.
-  Unfold eqf. Intros. Generalize a a'. Elim n. Exact ad_xor_sem_5.
-  Exact ad_xor_sem_6.
-Qed.
-
-Lemma eqf_sym : (f,f':nat->bool) (eqf f f') -> (eqf f' f).
-Proof.
-  Unfold eqf. Intros. Rewrite H. Reflexivity.
-Qed.
-
-Lemma eqf_refl :  (f:nat->bool) (eqf f f).
-Proof.
-  Unfold eqf. Trivial.
-Qed.
-
-Lemma eqf_trans : (f,f',f'':nat->bool) (eqf f f') -> (eqf f' f'') -> (eqf f f'').
-Proof.
-  Unfold eqf. Intros. Rewrite H. Exact (H0 n).
-Qed.
-
-Lemma adf_xor_eq : (f,f':nat->bool) (eqf (adf_xor f f') [n:nat] false) -> (eqf f f').
-Proof.
-  Unfold eqf. Unfold adf_xor. Intros. Apply xorb_eq. Apply H.
-Qed.
-
-Lemma ad_xor_eq : (a,a':ad) (ad_xor a a')=ad_z -> a=a'.
-Proof.
-  Intros. Apply ad_faithful. Apply adf_xor_eq. Apply eqf_trans with f':=(ad_bit (ad_xor a a')).
-  Apply eqf_sym. Apply ad_xor_semantics.
-  Rewrite H. Unfold eqf. Trivial.
-Qed.
-
-Lemma adf_xor_assoc : (f,f',f'':nat->bool)
-    (eqf (adf_xor (adf_xor f f') f'') (adf_xor f (adf_xor f' f''))).
-Proof.
-  Unfold eqf. Unfold adf_xor. Intros. Apply xorb_assoc.
-Qed.
-
-Lemma eqf_xor_1 : (f,f',f'',f''':nat->bool) (eqf f f') -> (eqf f'' f''') ->
-    (eqf (adf_xor f f'') (adf_xor f' f''')).
-Proof.
-  Unfold eqf. Intros. Unfold adf_xor. Rewrite H. Rewrite H0. Reflexivity.
-Qed.
-
-Lemma ad_xor_assoc :
-    (a,a',a'':ad) (ad_xor (ad_xor a a') a'')=(ad_xor a (ad_xor a' a'')).
-Proof.
-  Intros. Apply ad_faithful.
-  Apply eqf_trans with f':=(adf_xor (adf_xor (ad_bit a) (ad_bit a')) (ad_bit a'')).
-  Apply eqf_trans with f':=(adf_xor (ad_bit (ad_xor a a')) (ad_bit a'')).
-  Apply ad_xor_semantics.
-  Apply eqf_xor_1. Apply ad_xor_semantics.
-  Apply eqf_refl.
-  Apply eqf_trans with f':=(adf_xor (ad_bit a) (adf_xor (ad_bit a') (ad_bit a''))).
-  Apply adf_xor_assoc.
-  Apply eqf_trans with f':=(adf_xor (ad_bit a) (ad_bit (ad_xor a' a''))).
-  Apply eqf_xor_1. Apply eqf_refl.
-  Apply eqf_sym. Apply ad_xor_semantics.
-  Apply eqf_sym. Apply ad_xor_semantics.
-Qed.
-
-Definition ad_double := [a:ad]
-  Cases a of
-      ad_z => ad_z
-    | (ad_x p) => (ad_x (xO p))
-  end.
-
-Definition ad_double_plus_un := [a:ad]
-  Cases a of
-      ad_z => (ad_x xH)
-    | (ad_x p) => (ad_x (xI p))
-  end.
-
-Definition ad_div_2 := [a:ad]
-  Cases a of
-      ad_z => ad_z
-    | (ad_x xH) => ad_z
-    | (ad_x (xO p)) => (ad_x p)
-    | (ad_x (xI p)) => (ad_x p)
-  end.
-
-Lemma ad_double_div_2 : (a:ad) (ad_div_2 (ad_double a))=a.
-Proof.
-  NewDestruct a; Trivial.
-Qed.
-
-Lemma ad_double_plus_un_div_2 : (a:ad) (ad_div_2 (ad_double_plus_un a))=a.
-Proof.
-  NewDestruct a; Trivial.
-Qed.
-
-Lemma ad_double_inj : (a0,a1:ad) (ad_double a0)=(ad_double a1) -> a0=a1.
-Proof.
-  Intros. Rewrite <- (ad_double_div_2 a0). Rewrite H. Apply ad_double_div_2.
-Qed.
-
-Lemma ad_double_plus_un_inj :
-    (a0,a1:ad) (ad_double_plus_un a0)=(ad_double_plus_un a1) -> a0=a1.
-Proof.
-  Intros. Rewrite <- (ad_double_plus_un_div_2 a0). Rewrite H. Apply ad_double_plus_un_div_2.
-Qed.
-
-Definition ad_bit_0 := [a:ad]
-  Cases a of
-      ad_z => false
-    | (ad_x (xO _)) => false
-    | _ => true
-  end.
-
-Lemma ad_double_bit_0 : (a:ad) (ad_bit_0 (ad_double a))=false.
-Proof.
-  NewDestruct a; Trivial.
-Qed.
-
-Lemma ad_double_plus_un_bit_0 : (a:ad) (ad_bit_0 (ad_double_plus_un a))=true.
-Proof.
-  NewDestruct a; Trivial.
-Qed.
-
-Lemma ad_div_2_double : (a:ad) (ad_bit_0 a)=false -> (ad_double (ad_div_2 a))=a.
-Proof.
-  NewDestruct a. Trivial. NewDestruct p. Intro H. Discriminate H.
-  Intros. Reflexivity.
-  Intro H. Discriminate H.
-Qed.
-
-Lemma ad_div_2_double_plus_un :
-    (a:ad) (ad_bit_0 a)=true -> (ad_double_plus_un (ad_div_2 a))=a.
-Proof.
-  NewDestruct a. Intro. Discriminate H.
-  NewDestruct p. Intros. Reflexivity.
-  Intro H. Discriminate H.
-  Intro. Reflexivity.
-Qed.
-
-Lemma ad_bit_0_correct : (a:ad) (ad_bit a O)=(ad_bit_0 a).
-Proof.
-  NewDestruct a; Trivial.
-  NewDestruct p; Trivial.
-Qed.
-
-Lemma ad_div_2_correct : (a:ad) (n:nat) (ad_bit (ad_div_2 a) n)=(ad_bit a (S n)).
-Proof.
-  NewDestruct a; Trivial.
-  NewDestruct p; Trivial.
-Qed.
-
-Lemma ad_xor_bit_0 :
-    (a,a':ad) (ad_bit_0 (ad_xor a a'))=(xorb (ad_bit_0 a) (ad_bit_0 a')).
-Proof.
-  Intros. Rewrite <- ad_bit_0_correct. Rewrite (ad_xor_semantics a a' O).
-  Unfold adf_xor. Rewrite ad_bit_0_correct. Rewrite ad_bit_0_correct. Reflexivity.
-Qed.
-
-Lemma ad_xor_div_2 :
-    (a,a':ad) (ad_div_2 (ad_xor a a'))=(ad_xor (ad_div_2 a) (ad_div_2 a')).
-Proof.
-  Intros. Apply ad_faithful. Unfold eqf. Intro.
-  Rewrite (ad_xor_semantics (ad_div_2 a) (ad_div_2 a') n).
-  Rewrite ad_div_2_correct.
-  Rewrite (ad_xor_semantics a a' (S n)).
-  Unfold adf_xor. Rewrite ad_div_2_correct. Rewrite ad_div_2_correct.
-  Reflexivity.
-Qed.
-
-Lemma ad_neg_bit_0 : (a,a':ad) (ad_bit_0 (ad_xor a a'))=true ->
-    (ad_bit_0 a)=(negb (ad_bit_0 a')).
-Proof.
-  Intros. Rewrite <- true_xorb. Rewrite <- H. Rewrite ad_xor_bit_0.
-  Rewrite xorb_assoc. Rewrite xorb_nilpotent. Rewrite xorb_false. Reflexivity.
-Qed.
-
-Lemma ad_neg_bit_0_1 :
-    (a,a':ad) (ad_xor a a')=(ad_x xH) -> (ad_bit_0 a)=(negb (ad_bit_0 a')).
-Proof.
-  Intros. Apply ad_neg_bit_0. Rewrite H. Reflexivity.
-Qed.
-
-Lemma ad_neg_bit_0_2 : (a,a':ad) (p:positive) (ad_xor a a')=(ad_x (xI p)) ->
-    (ad_bit_0 a)=(negb (ad_bit_0 a')).
-Proof.
-  Intros. Apply ad_neg_bit_0. Rewrite H. Reflexivity.
-Qed.
-
-Lemma ad_same_bit_0 : (a,a':ad) (p:positive) (ad_xor a a')=(ad_x (xO p)) ->
-    (ad_bit_0 a)=(ad_bit_0 a').
-Proof.
-  Intros. Rewrite <- (xorb_false (ad_bit_0 a)). Cut (ad_bit_0 (ad_x (xO p)))=false.
-  Intro. Rewrite <- H0. Rewrite <- H. Rewrite ad_xor_bit_0. Rewrite <- xorb_assoc.
-  Rewrite xorb_nilpotent. Rewrite false_xorb. Reflexivity.
-  Reflexivity.
-Qed.
diff --git a/theories7/IntMap/Adist.v b/theories7/IntMap/Adist.v
deleted file mode 100644
index a7948c72..00000000
--- a/theories7/IntMap/Adist.v
+++ /dev/null
@@ -1,321 +0,0 @@
-(************************************************************************)
-(*  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: Adist.v,v 1.1.2.1 2004/07/16 19:31:27 herbelin Exp $	      i*)
-
-Require Bool.
-Require ZArith.
-Require Arith.
-Require Min.
-Require Addr.
-
-Fixpoint ad_plength_1 [p:positive] : nat :=
-  Cases p of
-      xH => O
-    | (xI _) => O
-    | (xO p') => (S (ad_plength_1 p'))
-  end.
-
-Inductive natinf : Set :=
-    infty : natinf
-  | ni : nat -> natinf.
-
-Definition ad_plength := [a:ad]
-  Cases a of
-      ad_z => infty
-    | (ad_x p) => (ni (ad_plength_1 p))
-  end.
-
-Lemma ad_plength_infty : (a:ad) (ad_plength a)=infty -> a=ad_z.
-Proof.
-  Induction a; Trivial. 
-  Unfold ad_plength; Intros; Discriminate H.
-Qed.
-
-Lemma ad_plength_zeros : (a:ad) (n:nat) (ad_plength a)=(ni n) ->
-    (k:nat) (lt k n) -> (ad_bit a k)=false.
-Proof.
-  Induction a; Trivial. 
-  Induction p. Induction n. Intros. Inversion H1.
-  Induction k. Simpl in H1. Discriminate H1.
-  Intros. Simpl in H1. Discriminate H1.
-  Induction k. Trivial.
-  Generalize H0. Case n. Intros. Inversion H3.
-  Intros. Simpl. Unfold ad_bit in H. Apply (H n0). Simpl in H1. Inversion H1. Reflexivity.
-  Exact (lt_S_n n1 n0 H3).
-  Simpl. Intros n H. Inversion H. Intros. Inversion H0.
-Qed.
-
-Lemma ad_plength_one : (a:ad) (n:nat) (ad_plength a)=(ni n) -> (ad_bit a n)=true.
-Proof.
-  Induction a. Intros. Inversion H.
-  Induction p. Intros. Simpl in H0. Inversion H0. Reflexivity.
-  Intros. Simpl in H0. Inversion H0. Simpl. Unfold ad_bit in H. Apply H. Reflexivity.
-  Intros. Simpl in H. Inversion H. Reflexivity.
-Qed.
-
-Lemma ad_plength_first_one : (a:ad) (n:nat)
-    ((k:nat) (lt k n) -> (ad_bit a k)=false) -> (ad_bit a n)=true ->
-      (ad_plength a)=(ni n).
-Proof.
-  Induction a. Intros. Simpl in H0. Discriminate H0.
-  Induction p. Intros. Generalize H0. Case n. Intros. Reflexivity.
-  Intros. Absurd (ad_bit (ad_x (xI p0)) O)=false. Trivial with bool.
-  Auto with bool arith.
-  Intros. Generalize H0 H1. Case n. Intros. Simpl in H3. Discriminate H3.
-  Intros. Simpl. Unfold ad_plength in H.
-  Cut (ni (ad_plength_1 p0))=(ni n0). Intro. Inversion H4. Reflexivity.
-  Apply H. Intros. Change (ad_bit (ad_x (xO p0)) (S k))=false. Apply H2. Apply lt_n_S. Exact H4.
-  Exact H3.
-  Intro. Case n. Trivial.
-  Intros. Simpl in H0. Discriminate H0.
-Qed.
-
-Definition ni_min := [d,d':natinf]
-  Cases d of
-      infty => d'
-    | (ni n) => Cases d' of
-                    infty => d
-		  | (ni n') => (ni (min n n'))
-		end
-  end.
-
-Lemma ni_min_idemp : (d:natinf) (ni_min d d)=d.
-Proof.
-  Induction d; Trivial.
-  Unfold ni_min.
-  Induction n; Trivial.
-  Intros.
-  Simpl.
-  Inversion H.
-  Rewrite H1.
-  Rewrite H1.
-  Reflexivity.
-Qed.
-
-Lemma ni_min_comm : (d,d':natinf) (ni_min d d')=(ni_min d' d).
-Proof.
-  Induction d. Induction d'; Trivial.
-  Induction d'; Trivial. Elim n. Induction n0; Trivial.
-  Intros. Elim n1; Trivial. Intros. Unfold ni_min in H. Cut (min n0 n2)=(min n2 n0).
-  Intro. Unfold ni_min. Simpl. Rewrite H1. Reflexivity.
-  Cut (ni (min n0 n2))=(ni (min n2 n0)). Intros.
-  Inversion H1; Trivial.
-  Exact (H n2).
-Qed.
-
-Lemma ni_min_assoc : (d,d',d'':natinf) (ni_min (ni_min d d') d'')=(ni_min d (ni_min d' d'')).
-Proof.
-  Induction d; Trivial. Induction d'; Trivial. 
-  Induction d''; Trivial.
-  Unfold ni_min. Intro. Cut (min (min n n0) n1)=(min n (min n0 n1)).
-  Intro. Rewrite H. Reflexivity.
-  Generalize n0 n1. Elim n; Trivial. 
-  Induction n3; Trivial. Induction n5; Trivial.
-  Intros. Simpl. Auto.
-Qed.
-
-Lemma ni_min_O_l : (d:natinf) (ni_min (ni O) d)=(ni O).
-Proof.
-  Induction d; Trivial.
-Qed.
-
-Lemma ni_min_O_r : (d:natinf) (ni_min d (ni O))=(ni O).
-Proof.
-  Intros. Rewrite ni_min_comm. Apply ni_min_O_l.
-Qed.
-
-Lemma ni_min_inf_l : (d:natinf) (ni_min infty d)=d.
-Proof.
-  Trivial.
-Qed.
-
-Lemma ni_min_inf_r : (d:natinf) (ni_min d infty)=d.
-Proof.
-  Induction d; Trivial.
-Qed.
-
-Definition ni_le := [d,d':natinf] (ni_min d d')=d.
-
-Lemma ni_le_refl : (d:natinf) (ni_le d d).
-Proof.
-  Exact ni_min_idemp.
-Qed.
-
-Lemma ni_le_antisym : (d,d':natinf) (ni_le d d') -> (ni_le d' d) -> d=d'.
-Proof.
-  Unfold ni_le. Intros d d'. Rewrite ni_min_comm. Intro H. Rewrite H. Trivial.
-Qed.
-
-Lemma ni_le_trans : (d,d',d'':natinf) (ni_le d d') -> (ni_le d' d'') -> (ni_le d d'').
-Proof.
-  Unfold ni_le. Intros. Rewrite <- H. Rewrite ni_min_assoc. Rewrite H0. Reflexivity.
-Qed.
-
-Lemma ni_le_min_1 : (d,d':natinf) (ni_le (ni_min d d') d).
-Proof.
-  Unfold ni_le. Intros. Rewrite (ni_min_comm d d'). Rewrite ni_min_assoc.
-  Rewrite ni_min_idemp. Reflexivity.
-Qed.
-
-Lemma ni_le_min_2 : (d,d':natinf) (ni_le (ni_min d d') d').
-Proof.
-  Unfold ni_le. Intros. Rewrite ni_min_assoc. Rewrite ni_min_idemp. Reflexivity.
-Qed.
-
-Lemma ni_min_case : (d,d':natinf) (ni_min d d')=d \/ (ni_min d d')=d'.
-Proof.
-  Induction d. Intro. Right . Exact (ni_min_inf_l d').
-  Induction d'. Left . Exact (ni_min_inf_r (ni n)).
-  Unfold ni_min. Cut (n0:nat)(min n n0)=n\/(min n n0)=n0.
-  Intros. Case (H n0). Intro. Left . Rewrite H0. Reflexivity.
-  Intro. Right . Rewrite H0. Reflexivity.
-  Elim n. Intro. Left . Reflexivity.
-  Induction n1. Right . Reflexivity.
-  Intros. Case (H n2). Intro. Left . Simpl. Rewrite H1. Reflexivity.
-  Intro. Right . Simpl. Rewrite H1. Reflexivity.
-Qed.
-
-Lemma ni_le_total : (d,d':natinf) (ni_le d d') \/ (ni_le d' d).
-Proof.
-  Unfold ni_le. Intros. Rewrite (ni_min_comm d' d). Apply ni_min_case.
-Qed.
-
-Lemma ni_le_min_induc : (d,d',dm:natinf) (ni_le dm d) -> (ni_le dm d') ->
-    ((d'':natinf) (ni_le d'' d) -> (ni_le d'' d') -> (ni_le d'' dm)) ->
-      (ni_min d d')=dm.
-Proof.
-  Intros. Case (ni_min_case d d'). Intro. Rewrite H2.
-  Apply ni_le_antisym. Apply H1. Apply ni_le_refl.
-  Exact H2.
-  Exact H.
-  Intro. Rewrite H2. Apply ni_le_antisym. Apply H1. Unfold ni_le. Rewrite ni_min_comm. Exact H2.
-  Apply ni_le_refl.
-  Exact H0.
-Qed.
-
-Lemma le_ni_le : (m,n:nat) (le m n) -> (ni_le (ni m) (ni n)).
-Proof.
-  Cut (m,n:nat)(le m n)->(min m n)=m.
-  Intros. Unfold ni_le ni_min. Rewrite (H m n H0). Reflexivity.
-  Induction m. Trivial.
-  Induction n0. Intro. Inversion H0.
-  Intros. Simpl. Rewrite (H n1 (le_S_n n n1 H1)). Reflexivity.
-Qed.
-
-Lemma ni_le_le : (m,n:nat) (ni_le (ni m) (ni n)) -> (le m n).
-Proof.
-  Unfold ni_le. Unfold ni_min. Intros. Inversion H. Apply le_min_r.
-Qed.
-
-Lemma ad_plength_lb : (a:ad) (n:nat) ((k:nat) (lt k n) -> (ad_bit a k)=false) ->
-    (ni_le (ni n) (ad_plength a)).
-Proof.
-  Induction a. Intros. Exact (ni_min_inf_r (ni n)).
-  Intros. Unfold ad_plength. Apply le_ni_le. Case (le_or_lt n (ad_plength_1 p)). Trivial.
-  Intro. Absurd (ad_bit (ad_x p) (ad_plength_1 p))=false.
-  Rewrite (ad_plength_one (ad_x p) (ad_plength_1 p)
-          (refl_equal natinf (ad_plength (ad_x p)))).
-  Discriminate.
-  Apply H. Exact H0.
-Qed.
-
-Lemma ad_plength_ub : (a:ad) (n:nat) (ad_bit a n)=true ->
-    (ni_le (ad_plength a) (ni n)).
-Proof.
-  Induction a. Intros. Discriminate H.
-  Intros. Unfold ad_plength. Apply le_ni_le. Case (le_or_lt (ad_plength_1 p) n). Trivial.
-  Intro. Absurd (ad_bit (ad_x p) n)=true.
-  Rewrite (ad_plength_zeros (ad_x p) (ad_plength_1 p)
-          (refl_equal natinf (ad_plength (ad_x p))) n H0).
-  Discriminate.
-  Exact H.
-Qed.
-
-
-(** We define an ultrametric distance between addresses: 
-    $d(a,a')=1/2^pd(a,a')$, 
-    where $pd(a,a')$ is the number of identical bits at the beginning 
-    of $a$ and $a'$ (infinity if $a=a'$).  
-    Instead of working with $d$, we work with $pd$, namely
-    [ad_pdist]: *)
-
-Definition ad_pdist := [a,a':ad] (ad_plength (ad_xor a a')).
-
-(** d is a distance, so $d(a,a')=0$ iff $a=a'$; this means that
-    $pd(a,a')=infty$ iff $a=a'$: *)
-
-Lemma ad_pdist_eq_1 : (a:ad) (ad_pdist a a)=infty.
-Proof.
-  Intros. Unfold ad_pdist. Rewrite ad_xor_nilpotent. Reflexivity.
-Qed.
-
-Lemma ad_pdist_eq_2 : (a,a':ad) (ad_pdist a a')=infty -> a=a'.
-Proof.
-  Intros. Apply ad_xor_eq. Apply ad_plength_infty. Exact H.
-Qed.
-
-(** $d$ is a distance, so $d(a,a')=d(a',a)$: *)
-
-Lemma ad_pdist_comm : (a,a':ad) (ad_pdist a a')=(ad_pdist a' a).
-Proof.
-  Unfold ad_pdist. Intros. Rewrite ad_xor_comm. Reflexivity.
-Qed.
-
-(** $d$ is an ultrametric distance, that is, not only $d(a,a')\leq
-    d(a,a'')+d(a'',a')$,
-  but in fact $d(a,a')\leq max(d(a,a''),d(a'',a'))$.
-  This means that $min(pd(a,a''),pd(a'',a'))<=pd(a,a')$ (lemma [ad_pdist_ultra] below).
-  This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{ad\_plength}}(a))$
-  is an ultrametric norm, i.e. that $|a-a'| \leq max (|a-a''|, |a''-a'|)$,
-  or equivalently that $|a+b|<=max(|a|,|b|)$, i.e. that
-  min $(\texttt{ad\_plength}(a), \texttt{ad\_plength}(b)) \leq 
-  \texttt{ad\_plength} (a~\texttt{xor}~ b)$
-  (lemma [ad_plength_ultra]).
-*)
-
-Lemma ad_plength_ultra_1 : (a,a':ad)
-    (ni_le (ad_plength a) (ad_plength a')) ->
-      (ni_le (ad_plength a) (ad_plength (ad_xor a a'))).
-Proof.
-  Induction a. Intros. Unfold ni_le in H. Unfold 1 3 ad_plength in H.
-  Rewrite (ni_min_inf_l (ad_plength a')) in H.
-  Rewrite (ad_plength_infty a' H). Simpl. Apply ni_le_refl.
-  Intros. Unfold 1 ad_plength. Apply ad_plength_lb. Intros.
-  Cut (a'':ad)(ad_xor (ad_x p) a')=a''->(ad_bit a'' k)=false.
-  Intros. Apply H1. Reflexivity.
-  Intro a''. Case a''. Intro. Reflexivity.
-  Intros. Rewrite <- H1. Rewrite (ad_xor_semantics (ad_x p) a' k). Unfold adf_xor.
-  Rewrite (ad_plength_zeros (ad_x p) (ad_plength_1 p)
-          (refl_equal natinf (ad_plength (ad_x p))) k H0).
-  Generalize H. Case a'. Trivial.
-  Intros. Cut (ad_bit (ad_x p1) k)=false. Intros. Rewrite H3. Reflexivity.
-  Apply ad_plength_zeros with n:=(ad_plength_1 p1). Reflexivity.
-  Apply (lt_le_trans k (ad_plength_1 p) (ad_plength_1 p1)). Exact H0.
-  Apply ni_le_le. Exact H2.
-Qed.
-
-Lemma ad_plength_ultra : (a,a':ad)
-    (ni_le (ni_min (ad_plength a) (ad_plength a')) (ad_plength (ad_xor a a'))).
-Proof.
-  Intros. Case (ni_le_total (ad_plength a) (ad_plength a')). Intro.
-  Cut (ni_min (ad_plength a) (ad_plength a'))=(ad_plength a).
-  Intro. Rewrite H0. Apply ad_plength_ultra_1. Exact H.
-  Exact H.
-  Intro. Cut (ni_min (ad_plength a) (ad_plength a'))=(ad_plength a').
-  Intro. Rewrite H0. Rewrite ad_xor_comm. Apply ad_plength_ultra_1. Exact H.
-  Rewrite ni_min_comm. Exact H.
-Qed.
-
-Lemma ad_pdist_ultra : (a,a',a'':ad)
-    (ni_le (ni_min (ad_pdist a a'') (ad_pdist a'' a')) (ad_pdist a a')).
-Proof.
-  Intros. Unfold ad_pdist. Cut (ad_xor (ad_xor a a'') (ad_xor a'' a'))=(ad_xor a a').
-  Intro. Rewrite <- H. Apply ad_plength_ultra.
-  Rewrite ad_xor_assoc. Rewrite <- (ad_xor_assoc a'' a'' a'). Rewrite ad_xor_nilpotent.
-  Rewrite ad_xor_neutral_left. Reflexivity.
-Qed.
diff --git a/theories7/IntMap/Allmaps.v b/theories7/IntMap/Allmaps.v
deleted file mode 100644
index e76e210f..00000000
--- a/theories7/IntMap/Allmaps.v
+++ /dev/null
@@ -1,26 +0,0 @@
-(************************************************************************)
-(*  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: Allmaps.v,v 1.1.2.1 2004/07/16 19:31:27 herbelin Exp $	 i*)
-
-Require Export Addr.
-Require Export Adist.
-Require Export Addec.
-Require Export Map.
-
-Require Export Fset.
-Require Export Mapaxioms.
-Require Export Mapiter.
-
-Require Export Mapsubset.
-Require Export Lsort.
-Require Export Mapfold.
-Require Export Mapcard.
-Require Export Mapcanon.
-Require Export Mapc.
-Require Export Maplists.
-Require Export Adalloc.
diff --git a/theories7/IntMap/Fset.v b/theories7/IntMap/Fset.v
deleted file mode 100644
index 545c1716..00000000
--- a/theories7/IntMap/Fset.v
+++ /dev/null
@@ -1,338 +0,0 @@
-(************************************************************************)
-(*  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: Fset.v,v 1.1.2.1 2004/07/16 19:31:27 herbelin Exp $	 i*)
-
-(*s Sets operations on maps *)
-
-Require Bool.
-Require Sumbool.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-
-Section Dom.
-
-  Variable A, B : Set.
-
-  Fixpoint MapDomRestrTo [m:(Map A)] : (Map B) -> (Map A) :=
-    Cases m of
-        M0 => [_:(Map B)] (M0 A)
-      | (M1 a y) => [m':(Map B)] Cases (MapGet B m' a) of
-                                 NONE => (M0 A)
-			       | _ => m
-			     end
-      | (M2 m1 m2) => [m':(Map B)] Cases m' of
-                                   M0 => (M0 A)
-				 | (M1 a' y') => Cases (MapGet A m a') of
-				                     NONE => (M0 A)
-						   | (SOME y) => (M1 A a' y)
-						 end
-				 | (M2 m'1 m'2) => (makeM2 A (MapDomRestrTo m1 m'1)
-				                             (MapDomRestrTo m2 m'2))
-			       end
-    end.
-
-  Lemma MapDomRestrTo_semantics : (m:(Map A)) (m':(Map B))
-      (eqm A (MapGet A (MapDomRestrTo m m'))
-             [a0:ad] Cases (MapGet B m' a0) of
-	               NONE => (NONE A)
-		     | _ => (MapGet A m a0)
-		   end).
-  Proof.
-    Unfold eqm. Induction m. Simpl. Intros. Case (MapGet B m' a); Trivial.
-    Intros. Simpl. Elim (sumbool_of_bool (ad_eq a a1)). Intro H. Rewrite H.
-    Rewrite <- (ad_eq_complete ? ? H). Case (MapGet B m' a). Reflexivity.
-    Intro. Apply M1_semantics_1.
-    Intro H. Rewrite H. Case (MapGet B m' a). 
-    Case (MapGet B m' a1); Reflexivity.
-    Case (MapGet B m' a1); Intros; Exact (M1_semantics_2 A a a1 a0 H).
-    Induction m'. Trivial.
-    Unfold MapDomRestrTo. Intros. Elim (sumbool_of_bool (ad_eq a a1)).
-    Intro H1.
-    Rewrite (ad_eq_complete ? ? H1). Rewrite (M1_semantics_1 B a1 a0).
-    Case (MapGet A (M2 A m0 m1) a1). Reflexivity.
-    Intro. Apply M1_semantics_1.
-    Intro H1. Rewrite (M1_semantics_2 B a a1 a0 H1). Case (MapGet A (M2 A m0 m1) a). Reflexivity.
-    Intro. Exact (M1_semantics_2 A a a1 a2 H1).
-    Intros. Change (MapGet A (makeM2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3)) a)
-        =(Cases (MapGet B (M2 B m2 m3) a) of
-            NONE => (NONE A)
-          | (SOME _) => (MapGet A (M2 A m0 m1) a)
-          end).
-    Rewrite (makeM2_M2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3) a).
-    Rewrite MapGet_M2_bit_0_if. Rewrite (H0 m3 (ad_div_2 a)). Rewrite (H m2 (ad_div_2 a)).
-    Rewrite (MapGet_M2_bit_0_if B m2 m3 a). Rewrite (MapGet_M2_bit_0_if A m0 m1 a).
-    Case (ad_bit_0 a); Reflexivity.
-  Qed.
-
-  Fixpoint MapDomRestrBy [m:(Map A)] : (Map B) -> (Map A) :=
-    Cases m of
-        M0 => [_:(Map B)] (M0 A)
-      | (M1 a y) => [m':(Map B)] Cases (MapGet B m' a) of
-                                 NONE => m
-			       | _ => (M0 A)
-			     end
-      | (M2 m1 m2) => [m':(Map B)] Cases m' of
-                                   M0 => m
-				 | (M1 a' y') => (MapRemove A m a')
-				 | (M2 m'1 m'2) => (makeM2 A (MapDomRestrBy m1 m'1)
-				                             (MapDomRestrBy m2 m'2))
-			       end
-    end.
-
-  Lemma MapDomRestrBy_semantics : (m:(Map A)) (m':(Map B))
-      (eqm A (MapGet A (MapDomRestrBy m m'))
-             [a0:ad] Cases (MapGet B m' a0) of
-	               NONE => (MapGet A m a0)
-		     | _ => (NONE A)
-		   end).
-  Proof.
-    Unfold eqm. Induction m. Simpl. Intros. Case (MapGet B m' a); Trivial.
-    Intros. Simpl. Elim (sumbool_of_bool (ad_eq a a1)). Intro H. Rewrite H.
-    Rewrite (ad_eq_complete ? ? H). Case (MapGet B m' a1). Apply M1_semantics_1.
-    Trivial.
-    Intro H. Rewrite H. Case (MapGet B m' a). Rewrite (M1_semantics_2 A a a1 a0 H).
-    Case (MapGet B m' a1); Trivial.
-    Case (MapGet B m' a1); Trivial.
-    Induction m'. Trivial.
-    Unfold MapDomRestrBy. Intros. Rewrite (MapRemove_semantics A (M2 A m0 m1) a a1).
-    Elim (sumbool_of_bool (ad_eq a a1)). Intro H1. Rewrite H1. Rewrite (ad_eq_complete ? ? H1).
-    Rewrite (M1_semantics_1 B a1 a0). Reflexivity.
-    Intro H1. Rewrite H1. Rewrite (M1_semantics_2 B a a1 a0 H1). Reflexivity.
-    Intros. Change (MapGet A (makeM2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3)) a)
-        =(Cases (MapGet B (M2 B m2 m3) a) of
-            NONE => (MapGet A (M2 A m0 m1) a)
-          | (SOME _) => (NONE A)
-          end).
-    Rewrite (makeM2_M2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3) a).
-    Rewrite MapGet_M2_bit_0_if. Rewrite (H0 m3 (ad_div_2 a)). Rewrite (H m2 (ad_div_2 a)).
-    Rewrite (MapGet_M2_bit_0_if B m2 m3 a). Rewrite (MapGet_M2_bit_0_if A m0 m1 a).
-    Case (ad_bit_0 a); Reflexivity.
-  Qed.
-
-  Definition in_dom := [a:ad; m:(Map A)]
-    Cases (MapGet A m a) of
-        NONE => false
-      | _ => true
-    end.
-
-  Lemma in_dom_M0 : (a:ad) (in_dom a (M0 A))=false.
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma in_dom_M1 : (a,a0:ad) (y:A) (in_dom a0 (M1 A a y))=(ad_eq a a0).
-  Proof.
-    Unfold in_dom. Intros. Simpl. Case (ad_eq a a0); Reflexivity.
-  Qed.
-
-  Lemma in_dom_M1_1 : (a:ad) (y:A) (in_dom a (M1 A a y))=true.
-  Proof.
-    Intros. Rewrite in_dom_M1. Apply ad_eq_correct.
-  Qed.
-
-  Lemma in_dom_M1_2 : (a,a0:ad) (y:A) (in_dom a0 (M1 A a y))=true -> a=a0.
-  Proof.
-    Intros. Apply (ad_eq_complete a a0). Rewrite (in_dom_M1 a a0 y) in H. Assumption.
-  Qed.
-
-  Lemma in_dom_some : (m:(Map A)) (a:ad) (in_dom a m)=true ->
-      {y:A | (MapGet A m a)=(SOME A y)}.
-  Proof.
-    Unfold in_dom. Intros. Elim (option_sum ? (MapGet A m a)). Trivial.
-    Intro H0. Rewrite H0 in H. Discriminate H.
-  Qed.
-
-  Lemma in_dom_none : (m:(Map A)) (a:ad) (in_dom a m)=false ->
-      (MapGet A m a)=(NONE A).
-  Proof.
-    Unfold in_dom. Intros. Elim (option_sum ? (MapGet A m a)). Intro H0. Elim H0.
-    Intros y H1. Rewrite H1 in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma in_dom_put : (m:(Map A)) (a0:ad) (y0:A) (a:ad)
-      (in_dom a (MapPut A m a0 y0))=(orb (ad_eq a a0) (in_dom a m)).
-  Proof.
-    Unfold in_dom. Intros. Rewrite (MapPut_semantics A m a0 y0 a).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H. Rewrite H. Rewrite (ad_eq_comm a a0) in H.
-    Rewrite H. Rewrite orb_true_b. Reflexivity.
-    Intro H. Rewrite H. Rewrite (ad_eq_comm a a0) in H. Rewrite H. Rewrite orb_false_b.
-    Reflexivity.
-  Qed.
-
-  Lemma in_dom_put_behind : (m:(Map A)) (a0:ad) (y0:A) (a:ad)
-      (in_dom a (MapPut_behind A m a0 y0))=(orb (ad_eq a a0) (in_dom a m)).
-  Proof.
-    Unfold in_dom. Intros. Rewrite (MapPut_behind_semantics A m a0 y0 a).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H. Rewrite H. Rewrite (ad_eq_comm a a0) in H.
-    Rewrite H. Case (MapGet A m a); Reflexivity.
-    Intro H. Rewrite H. Rewrite (ad_eq_comm a a0) in H. Rewrite H. Case (MapGet A m a); Trivial.
-  Qed.
-
-  Lemma in_dom_remove : (m:(Map A)) (a0:ad) (a:ad)
-      (in_dom a (MapRemove A m a0))=(andb (negb (ad_eq a a0)) (in_dom a m)).
-  Proof.
-    Unfold in_dom. Intros. Rewrite (MapRemove_semantics A m a0 a).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H. Rewrite H. Rewrite (ad_eq_comm a a0) in H.
-    Rewrite H. Reflexivity.
-    Intro H. Rewrite H. Rewrite (ad_eq_comm a a0) in H. Rewrite H.
-    Case (MapGet A m a); Reflexivity.
-  Qed.
-
-  Lemma in_dom_merge : (m,m':(Map A)) (a:ad)
-      (in_dom a (MapMerge A m m'))=(orb (in_dom a m) (in_dom a m')).
-  Proof.
-    Unfold in_dom. Intros. Rewrite (MapMerge_semantics A m m' a).
-    Elim (option_sum A (MapGet A m' a)). Intro H. Elim H. Intros y H0. Rewrite H0.
-    Case (MapGet A m a); Reflexivity.
-    Intro H. Rewrite H. Rewrite orb_b_false. Reflexivity.
-  Qed.
-
-  Lemma in_dom_delta : (m,m':(Map A)) (a:ad)
-      (in_dom a (MapDelta A m m'))=(xorb (in_dom a m) (in_dom a m')).
-  Proof.
-    Unfold in_dom. Intros. Rewrite (MapDelta_semantics A m m' a).
-    Elim (option_sum A (MapGet A m' a)). Intro H. Elim H. Intros y H0. Rewrite H0.
-    Case (MapGet A m a); Reflexivity.
-    Intro H. Rewrite H. Case (MapGet A m a); Reflexivity.
-  Qed.
-
-End Dom.
-
-Section InDom.
-
-  Variable A, B : Set.
-
-  Lemma in_dom_restrto : (m:(Map A)) (m':(Map B)) (a:ad)
-    (in_dom A a (MapDomRestrTo A B m m'))=(andb (in_dom A a m) (in_dom B a m')).
-  Proof.
-    Unfold in_dom. Intros. Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Elim (option_sum B (MapGet B m' a)). Intro H. Elim H. Intros y H0. Rewrite H0.
-    Rewrite andb_b_true. Reflexivity.
-    Intro H. Rewrite H. Rewrite andb_b_false. Reflexivity.
-  Qed.
-
-  Lemma in_dom_restrby : (m:(Map A)) (m':(Map B)) (a:ad)
-    (in_dom A a (MapDomRestrBy A B m m'))=(andb (in_dom A a m) (negb (in_dom B a m'))).
-  Proof.
-    Unfold in_dom. Intros. Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Elim (option_sum B (MapGet B m' a)). Intro H. Elim H. Intros y H0. Rewrite H0.
-    Unfold negb. Rewrite andb_b_false. Reflexivity.
-    Intro H. Rewrite H. Unfold negb. Rewrite andb_b_true. Reflexivity.
-  Qed.
-
-End InDom.
-
-Definition FSet := (Map unit).
-
-Section FSetDefs.
-
-  Variable A : Set.
-
-  Definition in_FSet : ad -> FSet -> bool := (in_dom unit).
-
-  Fixpoint MapDom [m:(Map A)] : FSet :=
-    Cases m of
-      	M0 => (M0 unit)
-      | (M1 a _) => (M1 unit a tt)
-      | (M2 m m') => (M2 unit (MapDom m) (MapDom m'))
-    end.
-
-  Lemma MapDom_semantics_1 : (m:(Map A)) (a:ad) 
-      (y:A) (MapGet A m a)=(SOME A y) -> (in_FSet a (MapDom m))=true.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Unfold MapDom. Unfold in_FSet. Unfold in_dom. Unfold MapGet. Intros a y a0 y0.
-    Case (ad_eq a a0). Trivial.
-    Intro. Discriminate H.
-    Intros m0 H m1 H0 a y. Rewrite (MapGet_M2_bit_0_if A m0 m1 a). Simpl. Unfold in_FSet.
-    Unfold in_dom. Rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
-    Case (ad_bit_0 a). Unfold in_FSet in_dom in H0. Intro. Apply H0 with y:=y. Assumption.
-    Unfold in_FSet in_dom in H. Intro. Apply H with y:=y. Assumption.
-  Qed.
-
-  Lemma MapDom_semantics_2 : (m:(Map A)) (a:ad) 
-      (in_FSet a (MapDom m))=true -> {y:A | (MapGet A m a)=(SOME A y)}.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Unfold MapDom. Unfold in_FSet. Unfold in_dom. Unfold MapGet. Intros a y a0. Case (ad_eq a a0).
-    Intro. Split with y. Reflexivity.
-    Intro. Discriminate H.
-    Intros m0 H m1 H0 a. Rewrite (MapGet_M2_bit_0_if A m0 m1 a). Simpl. Unfold in_FSet.
-    Unfold in_dom. Rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
-    Case (ad_bit_0 a). Unfold in_FSet in_dom in H0. Intro. Apply H0. Assumption.
-    Unfold in_FSet in_dom in H. Intro. Apply H. Assumption.
-  Qed.
-
-  Lemma MapDom_semantics_3 : (m:(Map A)) (a:ad) 
-      (MapGet A m a)=(NONE A) -> (in_FSet a (MapDom m))=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (in_FSet a (MapDom m))). Intro H0.
-    Elim (MapDom_semantics_2 m a H0). Intros y H1. Rewrite H in H1. Discriminate H1.
-    Trivial.
-  Qed.
-
-  Lemma MapDom_semantics_4 : (m:(Map A)) (a:ad) 
-      (in_FSet a (MapDom m))=false -> (MapGet A m a)=(NONE A).
-  Proof.
-    Intros. Elim (option_sum A (MapGet A m a)). Intro H0. Elim H0. Intros y H1.
-    Rewrite (MapDom_semantics_1 m a y H1) in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma MapDom_Dom : (m:(Map A)) (a:ad) (in_dom A a m)=(in_FSet a (MapDom m)).
-  Proof.
-    Intros. Elim (sumbool_of_bool (in_FSet a (MapDom m))). Intro H.
-    Elim (MapDom_semantics_2 m a H). Intros y H0. Rewrite H. Unfold in_dom. Rewrite H0.
-    Reflexivity.
-    Intro H. Rewrite H. Unfold in_dom. Rewrite (MapDom_semantics_4 m a H). Reflexivity.
-  Qed.
-
-  Definition FSetUnion : FSet -> FSet -> FSet := [s,s':FSet] (MapMerge unit s s').
-
-  Lemma in_FSet_union : (s,s':FSet) (a:ad)
-      (in_FSet a (FSetUnion s s'))=(orb (in_FSet a s) (in_FSet a s')).
-  Proof.
-    Exact (in_dom_merge unit).
-  Qed.
-
-  Definition FSetInter : FSet -> FSet -> FSet := [s,s':FSet] (MapDomRestrTo unit unit s s').
-
-  Lemma in_FSet_inter : (s,s':FSet) (a:ad)
-      (in_FSet a (FSetInter s s'))=(andb (in_FSet a s) (in_FSet a s')).
-  Proof.
-    Exact (in_dom_restrto unit unit).
-  Qed.
-
-  Definition FSetDiff : FSet -> FSet -> FSet := [s,s':FSet] (MapDomRestrBy unit unit s s').
-
-  Lemma in_FSet_diff : (s,s':FSet) (a:ad)
-      (in_FSet a (FSetDiff s s'))=(andb (in_FSet a s) (negb (in_FSet a s'))).
-  Proof.
-    Exact (in_dom_restrby unit unit).
-  Qed.
-
-  Definition FSetDelta : FSet -> FSet -> FSet := [s,s':FSet] (MapDelta unit s s').
-
-  Lemma in_FSet_delta : (s,s':FSet) (a:ad)
-      (in_FSet a (FSetDelta s s'))=(xorb (in_FSet a s) (in_FSet a s')).
-  Proof.
-    Exact (in_dom_delta unit).
-  Qed.
-
-End FSetDefs.
-
-Lemma FSet_Dom : (s:FSet) (MapDom unit s)=s.
-Proof.
-  Induction s. Trivial.
-  Simpl. Intros a t. Elim t. Reflexivity.
-  Intros. Simpl. Rewrite H. Rewrite H0. Reflexivity.
-Qed.
diff --git a/theories7/IntMap/Lsort.v b/theories7/IntMap/Lsort.v
deleted file mode 100644
index 31b71c62..00000000
--- a/theories7/IntMap/Lsort.v
+++ /dev/null
@@ -1,537 +0,0 @@
-(************************************************************************)
-(*  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: Lsort.v,v 1.1.2.1 2004/07/16 19:31:27 herbelin Exp $	 i*)
-
-Require Bool.
-Require Sumbool.
-Require Arith.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require PolyList.
-Require Mapiter.
-
-Section LSort.
-
-  Variable A : Set.
-
-  Fixpoint ad_less_1 [a,a':ad; p:positive] : bool :=
-    Cases p of
-        (xO p') => (ad_less_1 (ad_div_2 a) (ad_div_2 a') p')
-      | _ => (andb (negb (ad_bit_0 a)) (ad_bit_0 a'))
-    end.
-
-  Definition ad_less := [a,a':ad] Cases (ad_xor a a') of
-      	                              ad_z => false
-				    | (ad_x p) => (ad_less_1 a a' p)
-				  end.
-
-  Lemma ad_bit_0_less : (a,a':ad) (ad_bit_0 a)=false -> (ad_bit_0 a')=true -> 
-      (ad_less a a')=true.
-  Proof.
-    Intros. Elim (ad_sum (ad_xor a a')). Intro H1. Elim H1. Intros p H2. Unfold ad_less.
-    Rewrite H2. Generalize H2. Elim p. Intros. Simpl. Rewrite H. Rewrite H0. Reflexivity.
-    Intros. Cut (ad_bit_0 (ad_xor a a'))=false. Intro. Rewrite (ad_xor_bit_0 a a') in H5.
-    Rewrite H in H5. Rewrite H0 in H5. Discriminate H5.
-    Rewrite H4. Reflexivity.
-    Intro. Simpl. Rewrite H. Rewrite H0. Reflexivity.
-    Intro H1. Cut (ad_bit_0 (ad_xor a a'))=false. Intro. Rewrite (ad_xor_bit_0 a a') in H2.
-    Rewrite H in H2. Rewrite H0 in H2. Discriminate H2.
-    Rewrite H1. Reflexivity.
-  Qed.
-
-  Lemma ad_bit_0_gt : (a,a':ad) (ad_bit_0 a)=true -> (ad_bit_0 a')=false -> 
-      (ad_less a a')=false.
-  Proof.
-    Intros. Elim (ad_sum (ad_xor a a')). Intro H1. Elim H1. Intros p H2. Unfold ad_less.
-    Rewrite H2. Generalize H2. Elim p. Intros. Simpl. Rewrite H. Rewrite H0. Reflexivity.
-    Intros. Cut (ad_bit_0 (ad_xor a a'))=false. Intro. Rewrite (ad_xor_bit_0 a a') in H5.
-    Rewrite H in H5. Rewrite H0 in H5. Discriminate H5.
-    Rewrite H4. Reflexivity.
-    Intro. Simpl. Rewrite H. Rewrite H0. Reflexivity.
-    Intro H1. Unfold ad_less. Rewrite H1. Reflexivity.
-  Qed.
-
-  Lemma ad_less_not_refl : (a:ad) (ad_less a a)=false.
-  Proof.
-    Intro. Unfold ad_less. Rewrite (ad_xor_nilpotent a). Reflexivity.
-  Qed.
-
-  Lemma ad_ind_double : 
-      (a:ad)(P:ad->Prop) (P ad_z) ->
-      	((a:ad) (P a) -> (P (ad_double a))) ->
-      	((a:ad) (P a) -> (P (ad_double_plus_un a))) -> (P a).
-  Proof.
-    Intros; Elim a. Trivial.
-    Induction p. Intros. 
-    Apply (H1 (ad_x p0)); Trivial.
-    Intros; Apply (H0 (ad_x p0)); Trivial.
-    Intros; Apply (H1 ad_z); Assumption.
-  Qed.
-
-  Lemma ad_rec_double : 
-      (a:ad)(P:ad->Set) (P ad_z) ->
-      	((a:ad) (P a) -> (P (ad_double a))) ->
-      	((a:ad) (P a) -> (P (ad_double_plus_un a))) -> (P a).
-  Proof.
-    Intros; Elim a. Trivial.
-    Induction p. Intros. 
-    Apply (H1 (ad_x p0)); Trivial.
-    Intros; Apply (H0 (ad_x p0)); Trivial.
-    Intros; Apply (H1 ad_z); Assumption.
-  Qed.
-
-  Lemma ad_less_def_1 : (a,a':ad) (ad_less (ad_double a) (ad_double a'))=(ad_less a a').
-  Proof.
-    Induction a. Induction a'. Reflexivity.
-    Trivial.
-    Induction a'. Unfold ad_less. Simpl. (Elim p; Trivial).
-    Unfold ad_less. Simpl. Intro. Case (p_xor p p0). Reflexivity.
-    Trivial.
-  Qed.
-
-  Lemma ad_less_def_2 : (a,a':ad)
-      (ad_less (ad_double_plus_un a) (ad_double_plus_un a'))=(ad_less a a').
-  Proof.
-    Induction a. Induction a'. Reflexivity.
-    Trivial.
-    Induction a'. Unfold ad_less. Simpl. (Elim p; Trivial).
-    Unfold ad_less. Simpl. Intro. Case (p_xor p p0). Reflexivity.
-    Trivial.
-  Qed.
-
-  Lemma ad_less_def_3 : (a,a':ad) (ad_less (ad_double a) (ad_double_plus_un a'))=true.
-  Proof.
-    Intros. Apply ad_bit_0_less. Apply ad_double_bit_0.
-    Apply ad_double_plus_un_bit_0.
-  Qed.
-
-  Lemma ad_less_def_4 : (a,a':ad) (ad_less (ad_double_plus_un a) (ad_double a'))=false.
-  Proof.
-    Intros. Apply ad_bit_0_gt. Apply ad_double_plus_un_bit_0.
-    Apply ad_double_bit_0.
-  Qed.
-
-  Lemma ad_less_z : (a:ad) (ad_less a ad_z)=false.
-  Proof.
-    Induction a. Reflexivity.
-    Unfold ad_less. Intro. Rewrite (ad_xor_neutral_right (ad_x p)). (Elim p; Trivial).
-  Qed.
-
-  Lemma ad_z_less_1 : (a:ad) (ad_less ad_z a)=true -> {p:positive | a=(ad_x p)}.
-  Proof.
-    Induction a. Intro. Discriminate H.
-    Intros. Split with p. Reflexivity.
-  Qed.
-
-  Lemma ad_z_less_2 : (a:ad) (ad_less ad_z a)=false -> a=ad_z.
-  Proof.
-    Induction a. Trivial.
-    Unfold ad_less. Simpl. Cut (p:positive)(ad_less_1 ad_z (ad_x p) p)=false->False.
-    Intros. Elim (H p H0).
-    Induction p. Intros. Discriminate H0.
-    Intros. Exact (H H0).
-    Intro. Discriminate H.
-  Qed.
-
-  Lemma ad_less_trans : (a,a',a'':ad)
-      (ad_less a a')=true -> (ad_less a' a'')=true -> (ad_less a a'')=true.
-  Proof.
-    Intro a. Apply ad_ind_double with P:=[a:ad]
-          (a',a'':ad)
-           (ad_less a a')=true
-            ->(ad_less a' a'')=true->(ad_less a a'')=true.
-    Intros. Elim (sumbool_of_bool (ad_less ad_z a'')). Trivial.
-    Intro H1. Rewrite (ad_z_less_2 a'' H1) in H0. Rewrite (ad_less_z a') in H0. Discriminate H0.
-    Intros a0 H a'. Apply ad_ind_double with P:=[a':ad]
-          (a'':ad)
-           (ad_less (ad_double a0) a')=true
-            ->(ad_less a' a'')=true->(ad_less (ad_double a0) a'')=true.
-    Intros. Rewrite (ad_less_z (ad_double a0)) in H0. Discriminate H0.
-    Intros a1 H0 a'' H1. Rewrite (ad_less_def_1 a0 a1) in H1.
-    Apply ad_ind_double with P:=[a'':ad]
-          (ad_less (ad_double a1) a'')=true
-           ->(ad_less (ad_double a0) a'')=true.
-    Intro. Rewrite (ad_less_z (ad_double a1)) in H2. Discriminate H2.
-    Intros. Rewrite (ad_less_def_1 a1 a2) in H3. Rewrite (ad_less_def_1 a0 a2).
-    Exact (H a1 a2 H1 H3).
-    Intros. Apply ad_less_def_3.
-    Intros a1 H0 a'' H1. Apply ad_ind_double with P:=[a'':ad]
-          (ad_less (ad_double_plus_un a1) a'')=true
-           ->(ad_less (ad_double a0) a'')=true.
-    Intro. Rewrite (ad_less_z (ad_double_plus_un a1)) in H2. Discriminate H2.
-    Intros. Rewrite (ad_less_def_4 a1 a2) in H3. Discriminate H3.
-    Intros. Apply ad_less_def_3.
-    Intros a0 H a'. Apply ad_ind_double with P:=[a':ad]
-          (a'':ad)
-           (ad_less (ad_double_plus_un a0) a')=true
-            ->(ad_less a' a'')=true
-               ->(ad_less (ad_double_plus_un a0) a'')=true.
-    Intros. Rewrite (ad_less_z (ad_double_plus_un a0)) in H0. Discriminate H0.
-    Intros. Rewrite (ad_less_def_4 a0 a1) in H1. Discriminate H1.
-    Intros a1 H0 a'' H1. Apply ad_ind_double with P:=[a'':ad]
-          (ad_less (ad_double_plus_un a1) a'')=true
-           ->(ad_less (ad_double_plus_un a0) a'')=true.
-    Intro. Rewrite (ad_less_z (ad_double_plus_un a1)) in H2. Discriminate H2.
-    Intros. Rewrite (ad_less_def_4 a1 a2) in H3. Discriminate H3.
-    Rewrite (ad_less_def_2 a0 a1) in H1. Intros. Rewrite (ad_less_def_2 a1 a2) in H3.
-    Rewrite (ad_less_def_2 a0 a2). Exact (H a1 a2 H1 H3).
-  Qed.
-
-  Fixpoint alist_sorted [l:(alist A)] : bool :=
-    Cases l of
-      	nil => true
-      | (cons (a, _) l') => Cases l' of
-                                nil => true
-			      | (cons (a', y') l'') => (andb (ad_less a a')
-			                                     (alist_sorted l'))
-			    end
-    end.
-
-  Fixpoint alist_nth_ad [n:nat; l:(alist A)] : ad :=
-    Cases l of
-      	nil => ad_z (* dummy *)
-      | (cons (a, y) l') => Cases n of
-                                O => a
-			      | (S n') => (alist_nth_ad n' l')
-			    end
-    end.
-
-  Definition alist_sorted_1 := [l:(alist A)]
-      (n:nat) (le (S (S n)) (length l)) ->
-      	(ad_less (alist_nth_ad n l) (alist_nth_ad (S n) l))=true.
-
-  Lemma alist_sorted_imp_1 : (l:(alist A)) (alist_sorted l)=true -> (alist_sorted_1 l).
-  Proof.
-    Unfold alist_sorted_1. Induction l. Intros. Elim (le_Sn_O (S n) H0).
-    Intro r. Elim r. Intros a y. Induction l0. Intros. Simpl in H1.
-    Elim (le_Sn_O n (le_S_n (S n) O H1)).
-    Intro r0. Elim r0. Intros a0 y0. Induction n. Intros. Simpl. Simpl in H1.
-    Exact (proj1 ? ? (andb_prop ? ? H1)).
-    Intros. Change (ad_less (alist_nth_ad n0 (cons (a0,y0) l1))
-      	                    (alist_nth_ad (S n0) (cons (a0,y0) l1)))=true.
-    Apply H0. Exact (proj2 ? ? (andb_prop ? ? H1)).
-    Apply le_S_n. Exact H3.
-  Qed.
-
-  Definition alist_sorted_2 := [l:(alist A)]
-    (m,n:nat) (lt m n) -> (le (S n) (length l)) ->
-      	(ad_less (alist_nth_ad m l) (alist_nth_ad n l))=true.
-
-  Lemma alist_sorted_1_imp_2 : (l:(alist A)) (alist_sorted_1 l) -> (alist_sorted_2 l).
-  Proof.
-    Unfold alist_sorted_1 alist_sorted_2 lt. Intros l H m n H0. Elim H0. Exact (H m).
-    Intros. Apply ad_less_trans with a':=(alist_nth_ad m0 l). Apply H2. Apply le_trans_S.
-    Assumption.
-    Apply H. Assumption.
-  Qed.
-
-  Lemma alist_sorted_2_imp : (l:(alist A)) (alist_sorted_2 l) -> (alist_sorted l)=true.
-  Proof.
-    Unfold alist_sorted_2 lt. Induction l. Trivial.
-    Intro r. Elim r. Intros a y. Induction l0. Trivial.
-    Intro r0. Elim r0. Intros a0 y0. Intros.
-    Change (andb (ad_less a a0) (alist_sorted (cons (a0,y0) l1)))=true.
-    Apply andb_true_intro. Split. Apply (H1 (0) (1)). Apply le_n.
-    Simpl. Apply le_n_S. Apply le_n_S. Apply le_O_n.
-    Apply H0. Intros. Apply (H1 (S m) (S n)). Apply le_n_S. Assumption.
-    Exact (le_n_S ? ? H3).
-  Qed.
-
-  Lemma app_length : (C:Set) (l,l':(list C)) (length (app l l'))=(plus (length l) (length l')).
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite (H l'). Reflexivity.
-  Qed.
-
-  Lemma aapp_length : (l,l':(alist A)) (length (aapp A l l'))=(plus (length l) (length l')).
-  Proof.
-    Exact (app_length ad*A).
-  Qed.
-
-  Lemma alist_nth_ad_aapp_1 : (l,l':(alist A)) (n:nat)
-      (le (S n) (length l)) -> (alist_nth_ad n (aapp A l l'))=(alist_nth_ad n l).
-  Proof.
-    Induction l. Intros. Elim (le_Sn_O n H).
-    Intro r. Elim r. Intros a y l' H l''. Induction n. Trivial.
-    Intros. Simpl. Apply H. Apply le_S_n. Exact H1.
-  Qed.
-
-  Lemma alist_nth_ad_aapp_2 : (l,l':(alist A)) (n:nat)
-      (le (S n) (length l')) ->
-      	(alist_nth_ad (plus (length l) n) (aapp A l l'))=(alist_nth_ad n l').
-  Proof.
-    Induction l. Trivial.
-    Intro r. Elim r. Intros a y l' H l'' n H0. Simpl. Apply H. Exact H0.
-  Qed.
-
-  Lemma interval_split : (p,q,n:nat) (le (S n) (plus p q)) ->
-      {n' : nat | (le (S n') q) /\ n=(plus p n')}+{(le (S n) p)}.
-  Proof.
-    Induction p. Simpl. Intros. Left . Split with n. (Split; [ Assumption | Reflexivity ]).
-    Intros p' H q. Induction n. Intros. Right . Apply le_n_S. Apply le_O_n.
-    Intros. Elim (H ? ? (le_S_n ? ? H1)). Intro H2. Left . Elim H2. Intros n' H3.
-    Elim H3. Intros H4 H5. Split with n'. (Split; [ Assumption | Rewrite H5; Reflexivity ]).
-    Intro H2. Right . Apply le_n_S. Assumption.
-  Qed.
-
-  Lemma alist_conc_sorted : (l,l':(alist A)) (alist_sorted_2 l) -> (alist_sorted_2 l') ->
-      ((n,n':nat) (le (S n) (length l)) -> (le (S n') (length l')) ->
-      	  (ad_less (alist_nth_ad n l) (alist_nth_ad n' l'))=true) ->
-      	(alist_sorted_2 (aapp A l l')).
-  Proof.
-    Unfold alist_sorted_2 lt. Intros. Rewrite (aapp_length l l') in H3.
-    Elim (interval_split (length l) (length l') m
-            (le_trans ? ? ? (le_n_S ? ? (lt_le_weak m n H2)) H3)).
-    Intro H4. Elim H4. Intros m' H5. Elim H5. Intros. Rewrite H7.
-    Rewrite (alist_nth_ad_aapp_2 l l' m' H6). Elim (interval_split (length l) (length l') n H3).
-    Intro H8. Elim H8. Intros n' H9. Elim H9. Intros. Rewrite H11.
-    Rewrite (alist_nth_ad_aapp_2 l l' n' H10). Apply H0. Rewrite H7 in H2. Rewrite H11 in H2.
-    Change (le (plus (S (length l)) m') (plus (length l) n')) in H2.
-    Rewrite (plus_Snm_nSm (length l) m') in H2. Exact (simpl_le_plus_l (length l) (S m') n' H2).
-    Exact H10.
-    Intro H8. Rewrite H7 in H2. Cut (le (S (length l)) (length l)). Intros. Elim (le_Sn_n ? H9).
-    Apply le_trans with m:=(S n). Apply le_n_S. Apply le_trans with m:=(S (plus (length l) m')).
-    Apply le_trans with m:=(plus (length l) m'). Apply le_plus_l.
-    Apply le_n_Sn.
-    Exact H2.
-    Exact H8.
-    Intro H4. Rewrite (alist_nth_ad_aapp_1 l l' m H4).
-    Elim (interval_split (length l) (length l') n H3). Intro H5. Elim H5. Intros n' H6. Elim H6.
-    Intros. Rewrite H8. Rewrite (alist_nth_ad_aapp_2 l l' n' H7). Exact (H1 m n' H4 H7).
-    Intro H5. Rewrite (alist_nth_ad_aapp_1 l l' n H5). Exact (H m n H2 H5).
-  Qed.
-
-  Lemma alist_nth_ad_semantics : (l:(alist A)) (n:nat) (le (S n) (length l)) ->
-      {y:A | (alist_semantics A l (alist_nth_ad n l))=(SOME A y)}.
-  Proof.
-    Induction l. Intros. Elim (le_Sn_O ? H).
-    Intro r. Elim r. Intros a y l0 H. Induction n. Simpl. Intro. Split with y.
-    Rewrite (ad_eq_correct a). Reflexivity.
-    Intros. Elim (H ? (le_S_n ? ? H1)). Intros y0 H2.
-    Elim (sumbool_of_bool (ad_eq a (alist_nth_ad n0 l0))). Intro H3. Split with y.
-    Rewrite (ad_eq_complete ? ? H3). Simpl. Rewrite (ad_eq_correct (alist_nth_ad n0 l0)).
-    Reflexivity.
-    Intro H3. Split with y0. Simpl. Rewrite H3. Assumption.
-  Qed.
-
-  Lemma alist_of_Map_nth_ad : (m:(Map A)) (pf:ad->ad)
-      (l:(alist A)) l=(MapFold1 A (alist A) (anil A) (aapp A)
-                                [a0:ad][y:A](acons A (a0,y) (anil A)) pf m) ->
-      	(n:nat) (le (S n) (length l)) -> {a':ad | (alist_nth_ad n l)=(pf a')}.
-  Proof.
-    Intros. Elim (alist_nth_ad_semantics l n H0). Intros y H1.
-    Apply (alist_of_Map_semantics_1_1 A m pf (alist_nth_ad n l) y).
-    Rewrite <- H. Assumption.
-  Qed.
-
-  Definition ad_monotonic := [pf:ad->ad] (a,a':ad)
-      (ad_less a a')=true -> (ad_less (pf a) (pf a'))=true.
-
-  Lemma ad_double_monotonic : (ad_monotonic ad_double).
-  Proof.
-    Unfold ad_monotonic. Intros. Rewrite ad_less_def_1. Assumption.
-  Qed.
-
-  Lemma ad_double_plus_un_monotonic : (ad_monotonic ad_double_plus_un).
-  Proof.
-    Unfold ad_monotonic. Intros. Rewrite ad_less_def_2. Assumption.
-  Qed.
-
-  Lemma ad_comp_monotonic : (pf,pf':ad->ad) (ad_monotonic pf) -> (ad_monotonic pf') ->
-      (ad_monotonic [a0:ad] (pf (pf' a0))).
-  Proof.
-    Unfold ad_monotonic. Intros. Apply H. Apply H0. Exact H1.
-  Qed.
-
-  Lemma ad_comp_double_monotonic : (pf:ad->ad) (ad_monotonic pf) ->
-      (ad_monotonic [a0:ad] (pf (ad_double a0))).
-  Proof.
-    Intros. Apply ad_comp_monotonic. Assumption.
-    Exact ad_double_monotonic.
-  Qed.
-
-  Lemma ad_comp_double_plus_un_monotonic : (pf:ad->ad) (ad_monotonic pf) ->
-      (ad_monotonic [a0:ad] (pf (ad_double_plus_un a0))).
-  Proof.
-    Intros. Apply ad_comp_monotonic. Assumption.
-    Exact ad_double_plus_un_monotonic.
-  Qed.
-
-  Lemma alist_of_Map_sorts_1 : (m:(Map A)) (pf:ad->ad) (ad_monotonic pf) ->
-      (alist_sorted_2 (MapFold1 A (alist A) (anil A) (aapp A)
-                                [a:ad][y:A](acons A (a,y) (anil A)) pf m)).
-  Proof.
-    Induction m. Simpl. Intros. Apply alist_sorted_1_imp_2. Apply alist_sorted_imp_1. Reflexivity.
-    Intros. Simpl. Apply alist_sorted_1_imp_2. Apply alist_sorted_imp_1. Reflexivity.
-    Intros. Simpl. Apply alist_conc_sorted.
-    Exact (H [a0:ad](pf (ad_double a0)) (ad_comp_double_monotonic pf H1)).
-    Exact (H0 [a0:ad](pf (ad_double_plus_un a0)) (ad_comp_double_plus_un_monotonic pf H1)).
-    Intros. Elim (alist_of_Map_nth_ad m0 [a0:ad](pf (ad_double a0))
-       (MapFold1 A (alist A) (anil A) (aapp A)
-         [a0:ad][y:A](acons A (a0,y) (anil A))
-         [a0:ad](pf (ad_double a0)) m0) (refl_equal ? ?) n H2).
-    Intros a H4. Rewrite H4. Elim (alist_of_Map_nth_ad m1 [a0:ad](pf (ad_double_plus_un a0))
-       (MapFold1 A (alist A) (anil A) (aapp A)
-         [a0:ad][y:A](acons A (a0,y) (anil A))
-         [a0:ad](pf (ad_double_plus_un a0)) m1) (refl_equal ? ?) n' H3).
-    Intros a' H5. Rewrite H5. Unfold ad_monotonic in H1. Apply H1. Apply ad_less_def_3.
-  Qed.
-
-  Lemma alist_of_Map_sorts : (m:(Map A)) (alist_sorted (alist_of_Map A m))=true.
-  Proof.
-    Intro. Apply alist_sorted_2_imp.
-    Exact (alist_of_Map_sorts_1 m [a0:ad]a0 [a,a':ad][p:(ad_less a a')=true]p).
-  Qed.
-
-  Lemma alist_of_Map_sorts1 : (m:(Map A)) (alist_sorted_1 (alist_of_Map A m)).
-  Proof.
-    Intro. Apply alist_sorted_imp_1. Apply alist_of_Map_sorts.
-  Qed.
- 
-  Lemma alist_of_Map_sorts2 : (m:(Map A)) (alist_sorted_2 (alist_of_Map A m)).
-  Proof.
-    Intro. Apply alist_sorted_1_imp_2. Apply alist_of_Map_sorts1.
-  Qed.
- 
-  Lemma ad_less_total : (a,a':ad) {(ad_less a a')=true}+{(ad_less a' a)=true}+{a=a'}.
-  Proof.
-    Intro a. Refine (ad_rec_double a [a:ad] (a':ad){(ad_less a a')=true}+{(ad_less a' a)=true}+{a=a'}
-                            ? ? ?).
-    Intro. Elim (sumbool_of_bool (ad_less ad_z a')). Intro H. Left . Left . Assumption.
-    Intro H. Right . Rewrite (ad_z_less_2 a' H). Reflexivity.
-    Intros a0 H a'. Refine (ad_rec_double a' [a':ad] {(ad_less (ad_double a0) a')=true}
-                                 +{(ad_less a' (ad_double a0))=true}+{(ad_double a0)=a'} ? ? ?).
-    Elim (sumbool_of_bool (ad_less ad_z (ad_double a0))). Intro H0. Left . Right . Assumption.
-    Intro H0. Right . Exact (ad_z_less_2 ? H0).
-    Intros a1 H0. Rewrite ad_less_def_1. Rewrite ad_less_def_1. Elim (H a1). Intro H1.
-    Left . Assumption.
-    Intro H1. Right . Rewrite H1. Reflexivity.
-    Intros a1 H0. Left . Left . Apply ad_less_def_3.
-    Intros a0 H a'. Refine (ad_rec_double a' [a':ad] {(ad_less (ad_double_plus_un a0) a')=true}
-                                 +{(ad_less a' (ad_double_plus_un a0))=true}
-                                 +{(ad_double_plus_un a0)=a'} ? ? ?).
-    Left . Right . (Case a0; Reflexivity).
-    Intros a1 H0. Left . Right . Apply ad_less_def_3.
-    Intros a1 H0. Rewrite ad_less_def_2. Rewrite ad_less_def_2. Elim (H a1). Intro H1.
-    Left . Assumption.
-    Intro H1. Right . Rewrite H1. Reflexivity.
-  Qed.
-
-  Lemma alist_too_low : (l:(alist A)) (a,a':ad) (y:A)
-      (ad_less a a')=true -> (alist_sorted_2 (cons (a',y) l)) ->
-      	(alist_semantics A (cons (a',y) l) a)=(NONE A).
-  Proof.
-    Induction l. Intros. Simpl. Elim (sumbool_of_bool (ad_eq a' a)). Intro H1.
-    Rewrite (ad_eq_complete ? ? H1) in H. Rewrite (ad_less_not_refl a) in H. Discriminate H.
-    Intro H1. Rewrite H1. Reflexivity.
-    Intro r. Elim r. Intros a y l0 H a0 a1 y0 H0 H1.
-    Change (Case (ad_eq a1 a0) of
-               (SOME A y0)
-               (alist_semantics A (cons (a,y) l0) a0)
-               end)=(NONE A).
-    Elim (sumbool_of_bool (ad_eq a1 a0)). Intro H2. Rewrite (ad_eq_complete ? ? H2) in H0.
-    Rewrite (ad_less_not_refl a0) in H0. Discriminate H0.
-    Intro H2. Rewrite H2. Apply H. Apply ad_less_trans with a':=a1. Assumption.
-    Unfold alist_sorted_2 in H1. Apply (H1 (0) (1)). Apply lt_n_Sn.
-    Simpl. Apply le_n_S. Apply le_n_S. Apply le_O_n.
-    Apply alist_sorted_1_imp_2. Apply alist_sorted_imp_1.
-    Cut (alist_sorted (cons (a1,y0) (cons (a,y) l0)))=true. Intro H3.
-    Exact (proj2 ? ? (andb_prop ? ? H3)).
-    Apply alist_sorted_2_imp. Assumption.
-  Qed.
-
-  Lemma alist_semantics_nth_ad : (l:(alist A)) (a:ad) (y:A)
-      (alist_semantics A l a)=(SOME A y) ->
-      	{n:nat | (le (S n) (length l)) /\ (alist_nth_ad n l)=a}.
-  Proof.
-    Induction l. Intros. Discriminate H.
-    Intro r. Elim r. Intros a y l0 H a0 y0 H0. Simpl in H0. Elim (sumbool_of_bool (ad_eq a a0)).
-    Intro H1. Rewrite H1 in H0. Split with O. Split. Simpl. Apply le_n_S. Apply le_O_n.
-    Simpl. Exact (ad_eq_complete ? ? H1).
-    Intro H1. Rewrite H1 in H0. Elim (H a0 y0 H0). Intros n' H2. Split with (S n'). Split.
-    Simpl. Apply le_n_S. Exact (proj1 ? ? H2).
-    Exact (proj2 ? ? H2).
-  Qed.
-
-  Lemma alist_semantics_tail : (l:(alist A)) (a:ad) (y:A)
-      (alist_sorted_2 (cons (a,y) l)) ->
-      	(eqm A (alist_semantics A l) [a0:ad] if (ad_eq a a0)
-                                             then (NONE A)
-					     else (alist_semantics A (cons (a,y) l) a0)).
-  Proof.
-    Unfold eqm. Intros. Elim (sumbool_of_bool (ad_eq a a0)). Intro H0. Rewrite H0.
-    Rewrite <- (ad_eq_complete ? ? H0). Unfold alist_sorted_2 in H.
-    Elim (option_sum A (alist_semantics A l a)). Intro H1. Elim H1. Intros y0 H2.
-    Elim (alist_semantics_nth_ad l a y0 H2). Intros n H3. Elim H3. Intros.
-    Cut (ad_less (alist_nth_ad (0) (cons (a,y) l)) (alist_nth_ad (S n) (cons (a,y) l)))=true.
-    Intro. Simpl in H6. Rewrite H5 in H6. Rewrite (ad_less_not_refl a) in H6. Discriminate H6.
-    Apply H. Apply lt_O_Sn.
-    Simpl. Apply le_n_S. Assumption.
-    Trivial.
-    Intro H0. Simpl. Rewrite H0. Reflexivity.
-  Qed.
-
-  Lemma alist_semantics_same_tail : (l,l':(alist A)) (a:ad) (y:A)
-      (alist_sorted_2 (cons (a,y) l)) -> (alist_sorted_2 (cons (a,y) l')) ->
-      	(eqm A (alist_semantics A (cons (a,y) l)) (alist_semantics A (cons (a,y) l'))) ->
-	  (eqm A (alist_semantics A l) (alist_semantics A l')).
-  Proof.
-    Unfold eqm. Intros. Rewrite (alist_semantics_tail ? ? ? H a0).
-    Rewrite (alist_semantics_tail ? ? ? H0 a0). Case (ad_eq a a0). Reflexivity.
-    Exact (H1 a0).
-  Qed.
-
-  Lemma alist_sorted_tail : (l:(alist A)) (a:ad) (y:A)
-      (alist_sorted_2 (cons (a,y) l)) -> (alist_sorted_2 l).
-  Proof.
-    Unfold alist_sorted_2. Intros. Apply (H (S m) (S n)). Apply lt_n_S. Assumption.
-    Simpl. Apply le_n_S. Assumption.
-  Qed.
-
-  Lemma alist_canonical : (l,l':(alist A))
-      (eqm A (alist_semantics A l) (alist_semantics A l')) ->
-      	(alist_sorted_2 l) -> (alist_sorted_2 l') -> l=l'.
-  Proof.
-    Unfold eqm. Induction l. Induction l'. Trivial.
-    Intro r. Elim r. Intros a y l0 H H0 H1 H2. Simpl in H0.
-    Cut (NONE A)=(Case (ad_eq a a) of (SOME A y)
-                           (alist_semantics A l0 a)
-                           end).
-    Rewrite (ad_eq_correct a). Intro. Discriminate H3.
-    Exact (H0 a).
-    Intro r. Elim r. Intros a y l0 H. Induction l'. Intros. Simpl in H0.
-    Cut (Case (ad_eq a a) of (SOME A y)
-                         (alist_semantics A l0 a)
-                         end)=(NONE A).
-    Rewrite (ad_eq_correct a). Intro. Discriminate H3.
-    Exact (H0 a).
-    Intro r'. Elim r'. Intros a' y' l'0 H0 H1 H2 H3. Elim (ad_less_total a a'). Intro H4.
-    Elim H4. Intro H5.
-    Cut (alist_semantics A (cons (a,y) l0) a)=(alist_semantics A (cons (a',y') l'0) a).
-    Intro. Rewrite (alist_too_low l'0 a a' y' H5 H3) in H6. Simpl in H6.
-    Rewrite (ad_eq_correct a) in H6. Discriminate H6.
-    Exact (H1 a).
-    Intro H5. Cut (alist_semantics A (cons (a,y) l0) a')=(alist_semantics A (cons (a',y') l'0) a').
-    Intro. Rewrite (alist_too_low l0 a' a y H5 H2) in H6. Simpl in H6.
-    Rewrite (ad_eq_correct a') in H6. Discriminate H6.
-    Exact (H1 a').
-    Intro H4. Rewrite H4.
-    Cut (alist_semantics A (cons (a,y) l0) a)=(alist_semantics A (cons (a',y') l'0) a).
-    Intro. Simpl in H5. Rewrite H4 in H5. Rewrite (ad_eq_correct a') in H5. Inversion H5.
-    Rewrite H4 in H1. Rewrite H7 in H1. Cut l0=l'0. Intro. Rewrite H6. Reflexivity.
-    Apply H. Rewrite H4 in H2. Rewrite H7 in H2.
-    Exact (alist_semantics_same_tail l0 l'0 a' y' H2 H3 H1).
-    Exact (alist_sorted_tail ? ? ? H2).
-    Exact (alist_sorted_tail ? ? ? H3).
-    Exact (H1 a).
-  Qed.
-
-End LSort.
diff --git a/theories7/IntMap/Map.v b/theories7/IntMap/Map.v
deleted file mode 100644
index 00ba3f8a..00000000
--- a/theories7/IntMap/Map.v
+++ /dev/null
@@ -1,786 +0,0 @@
-(************************************************************************)
-(*  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: Map.v,v 1.1.2.1 2004/07/16 19:31:27 herbelin Exp $	 i*)
-
-(** Definition of finite sets as trees indexed by adresses *)
-
-Require Bool.
-Require Sumbool.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-
-
-Section MapDefs.
-
-(** We define maps from ad to A. *)
-  Variable A : Set.  
-
-  Inductive Map : Set :=
-      M0 : Map
-    | M1 : ad -> A -> Map
-    | M2 : Map -> Map -> Map.
-
-  Inductive option : Set :=
-      NONE : option
-    | SOME : A -> option.
-
-  Lemma option_sum : (o:option) {y:A | o=(SOME y)}+{o=NONE}.
-  Proof.
-    Induction o. Right . Reflexivity.
-    Left . Split with a. Reflexivity.
-  Qed.
-
-  (** The semantics of maps is given by the function [MapGet].
-      The semantics of a map [m] is a partial, finite function from
-      [ad] to [A]: *)
-
-  Fixpoint MapGet [m:Map] : ad -> option :=
-    Cases m of
-        M0 => [a:ad] NONE
-      | (M1 x y) => [a:ad]
-          if (ad_eq x a)
-	     then (SOME y)
-	  else NONE
-      | (M2 m1 m2) => [a:ad]
-          Cases a of
-	      ad_z => (MapGet m1 ad_z)
-	    | (ad_x xH) => (MapGet m2 ad_z)
-	    | (ad_x (xO p)) => (MapGet m1 (ad_x p))
-	    | (ad_x (xI p)) => (MapGet m2 (ad_x p))
-	  end
-    end.
-
-  Definition newMap := M0.
-
-  Definition MapSingleton := M1.
-
-  Definition eqm := [g,g':ad->option] (a:ad) (g a)=(g' a).
-
-  Lemma newMap_semantics : (eqm (MapGet newMap) [a:ad] NONE).
-  Proof.
-    Simpl. Unfold eqm. Trivial.
-  Qed.
-
-  Lemma MapSingleton_semantics : (a:ad) (y:A)
-      (eqm (MapGet (MapSingleton a y)) [a':ad] if (ad_eq a a') then (SOME y) else NONE).
-  Proof.
-    Simpl. Unfold eqm. Trivial.
-  Qed.
-
-  Lemma M1_semantics_1 : (a:ad) (y:A) (MapGet (M1 a y) a)=(SOME y).
-  Proof.
-    Unfold MapGet. Intros. Rewrite (ad_eq_correct a). Reflexivity.
-  Qed.
-
-  Lemma M1_semantics_2 :
-      (a,a':ad) (y:A) (ad_eq a a')=false -> (MapGet (M1 a y) a')=NONE.
-  Proof.
-    Intros. Simpl. Rewrite H. Reflexivity.
-  Qed.
-
-  Lemma Map2_semantics_1 :
-      (m,m':Map) (eqm (MapGet m) [a:ad] (MapGet (M2 m m') (ad_double a))).
-  Proof.
-    Unfold eqm. Induction a; Trivial.
-  Qed.
-
-  Lemma Map2_semantics_1_eq : (m,m':Map) (f:ad->option) (eqm (MapGet (M2 m m')) f)
-      -> (eqm (MapGet m) [a:ad] (f (ad_double a))).
-  Proof.
-    Unfold eqm.
-    Intros.
-    Rewrite <- (H (ad_double a)).
-    Exact (Map2_semantics_1 m m' a).
-  Qed.
-
-  Lemma Map2_semantics_2 :
-      (m,m':Map) (eqm (MapGet m') [a:ad] (MapGet (M2 m m') (ad_double_plus_un a))).
-  Proof.
-    Unfold eqm. Induction a; Trivial.
-  Qed.
-
-  Lemma Map2_semantics_2_eq : (m,m':Map) (f:ad->option) (eqm (MapGet (M2 m m')) f)
-      -> (eqm (MapGet m') [a:ad] (f (ad_double_plus_un a))).
-  Proof.
-    Unfold eqm.
-    Intros.
-    Rewrite <- (H (ad_double_plus_un a)).
-    Exact (Map2_semantics_2 m m' a).
-  Qed.
-
-  Lemma MapGet_M2_bit_0_0 : (a:ad) (ad_bit_0 a)=false
-      -> (m,m':Map) (MapGet (M2 m m') a)=(MapGet m (ad_div_2 a)).
-  Proof.
-    Induction a; Trivial. Induction p. Intros. Discriminate H0.
-    Trivial.
-    Intros. Discriminate H.
-  Qed.
-
-  Lemma MapGet_M2_bit_0_1 : (a:ad) (ad_bit_0 a)=true
-      -> (m,m':Map) (MapGet (M2 m m') a)=(MapGet m' (ad_div_2 a)).
-  Proof.
-    Induction a. Intros. Discriminate H.
-    Induction p. Trivial.
-    Intros. Discriminate H0.
-    Trivial.
-  Qed.
-
-  Lemma MapGet_M2_bit_0_if : (m,m':Map) (a:ad) (MapGet (M2 m m') a)=
-      (if (ad_bit_0 a) then (MapGet m' (ad_div_2 a)) else (MapGet m (ad_div_2 a))).
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H. Rewrite H.
-    Apply MapGet_M2_bit_0_1; Assumption.
-    Intro H. Rewrite H. Apply MapGet_M2_bit_0_0; Assumption.
-  Qed.
-
-  Lemma MapGet_M2_bit_0 : (m,m',m'':Map)
-      (a:ad) (if (ad_bit_0 a) then (MapGet (M2 m' m) a) else (MapGet (M2 m m'') a))=
-             (MapGet m (ad_div_2 a)).
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H. Rewrite H.
-    Apply MapGet_M2_bit_0_1; Assumption.
-    Intro H. Rewrite H. Apply MapGet_M2_bit_0_0; Assumption.
-  Qed.
-
-  Lemma Map2_semantics_3 : (m,m':Map) (eqm (MapGet (M2 m m'))
-      [a:ad] Cases (ad_bit_0 a) of
-                 false => (MapGet m (ad_div_2 a))
-	       | true => (MapGet m' (ad_div_2 a))
-	     end).
-  Proof.
-    Unfold eqm.
-    Induction a; Trivial.
-    Induction p; Trivial.
-  Qed.
-
-  Lemma Map2_semantics_3_eq : (m,m':Map) (f,f':ad->option)
-      (eqm (MapGet m) f) -> (eqm (MapGet m') f') -> (eqm (MapGet (M2 m m'))
-      [a:ad] Cases (ad_bit_0 a) of
-                 false => (f (ad_div_2 a))
-	       | true => (f' (ad_div_2 a))
-	     end).
-  Proof.
-    Unfold eqm.
-    Intros.
-    Rewrite <- (H (ad_div_2 a)).
-    Rewrite <- (H0 (ad_div_2 a)).
-    Exact (Map2_semantics_3 m m' a).
-  Qed.
-
-  Fixpoint MapPut1 [a:ad; y:A; a':ad; y':A; p:positive] : Map :=
-    Cases p of
-        (xO p') => let m = (MapPut1 (ad_div_2 a) y (ad_div_2 a') y' p') in
-      	           Cases (ad_bit_0 a) of
-      	               false => (M2 m M0)
-		     | true => (M2 M0 m)
-		   end
-      | _ => Cases (ad_bit_0 a) of
-                 false => (M2 (M1 (ad_div_2 a) y) (M1 (ad_div_2 a') y'))
-	       | true => (M2 (M1 (ad_div_2 a') y') (M1 (ad_div_2 a) y))
-	     end
-    end.
-
-  Lemma MapGet_if_commute : (b:bool) (m,m':Map) (a:ad)
-      (MapGet (if b then m else m') a)=(if b then (MapGet m a) else (MapGet m' a)).
-  Proof.
-    Intros. Case b; Trivial.
-  Qed.
-
-  (*i
-  Lemma MapGet_M2_bit_0_1' : (m,m',m'',m''':Map)
-      (a:ad) (MapGet (if (ad_bit_0 a) then (M2 m m') else (M2 m'' m''')) a)=
-             (MapGet (if (ad_bit_0 a) then m' else m'') (ad_div_2 a)).
-  Proof.
-    Intros. Rewrite (MapGet_if_commute (ad_bit_0 a)). Rewrite (MapGet_if_commute (ad_bit_0 a)).
-    Cut (ad_bit_0 a)=false\/(ad_bit_0 a)=true. Intros. Elim H. Intros. Rewrite H0.
-    Apply MapGet_M2_bit_0_0. Assumption.
-    Intros. Rewrite H0. Apply MapGet_M2_bit_0_1. Assumption.
-    Case (ad_bit_0 a); Auto.
-  Qed.
-  i*)
-
-  Lemma MapGet_if_same : (m:Map) (b:bool) (a:ad) 
-      (MapGet (if b then m else m) a)=(MapGet m a).
-  Proof.
-    Induction b;Trivial.
-  Qed.
-
-  Lemma MapGet_M2_bit_0_2 : (m,m',m'':Map)
-      (a:ad) (MapGet (if (ad_bit_0 a) then (M2 m m') else (M2 m' m'')) a)=
-             (MapGet m' (ad_div_2 a)).
-  Proof.
-    Intros. Rewrite MapGet_if_commute. Apply MapGet_M2_bit_0.
-  Qed.
-
-  Lemma MapPut1_semantics_1 : (p:positive) (a,a':ad) (y,y':A)
-      (ad_xor a a')=(ad_x p)
-      	-> (MapGet (MapPut1 a y a' y' p) a)=(SOME y).
-  Proof.
-    Induction p. Intros. Unfold MapPut1. Rewrite MapGet_M2_bit_0_2. Apply M1_semantics_1.
-    Intros. Simpl. Rewrite MapGet_M2_bit_0_2. Apply H. Rewrite <- ad_xor_div_2. Rewrite H0.
-    Reflexivity.
-    Intros. Unfold MapPut1. Rewrite MapGet_M2_bit_0_2. Apply M1_semantics_1.
-  Qed.
-
-  Lemma MapPut1_semantics_2 : (p:positive) (a,a':ad) (y,y':A)
-      (ad_xor a a')=(ad_x p)
-      	-> (MapGet (MapPut1 a y a' y' p) a')=(SOME y').
-  Proof.
-    Induction p. Intros. Unfold MapPut1. Rewrite (ad_neg_bit_0_2 a a' p0 H0).
-    Rewrite if_negb. Rewrite MapGet_M2_bit_0_2. Apply M1_semantics_1.
-    Intros. Simpl. Rewrite (ad_same_bit_0 a a' p0 H0). Rewrite MapGet_M2_bit_0_2.
-    Apply H. Rewrite <- ad_xor_div_2. Rewrite H0. Reflexivity.
-    Intros. Unfold MapPut1. Rewrite (ad_neg_bit_0_1 a a' H). Rewrite if_negb.
-    Rewrite MapGet_M2_bit_0_2. Apply M1_semantics_1.
-  Qed.
-
-  Lemma MapGet_M2_both_NONE : (m,m':Map) (a:ad)
-      (MapGet m (ad_div_2 a))=NONE -> (MapGet m' (ad_div_2 a))=NONE -> 
-        (MapGet (M2 m m') a)=NONE.
-  Proof.
-    Intros. Rewrite (Map2_semantics_3 m m' a). 
-    Case (ad_bit_0 a); Assumption.
-  Qed.
- 
-  Lemma MapPut1_semantics_3 : (p:positive) (a,a',a0:ad) (y,y':A)
-      	(ad_xor a a')=(ad_x p) -> (ad_eq a a0)=false -> (ad_eq a' a0)=false ->
-	  (MapGet (MapPut1 a y a' y' p) a0)=NONE.
-  Proof.
-    Induction p. Intros. Unfold MapPut1. Elim (ad_neq a a0 H1). Intro. Rewrite H3. Rewrite if_negb.
-    Rewrite MapGet_M2_bit_0_2. Apply M1_semantics_2. Apply ad_div_bit_neq. Assumption.
-    Rewrite (ad_neg_bit_0_2 a a' p0 H0) in H3. Rewrite (negb_intro (ad_bit_0 a')).
-    Rewrite (negb_intro (ad_bit_0 a0)). Rewrite H3. Reflexivity.
-    Intro. Elim (ad_neq a' a0 H2). Intro. Rewrite (ad_neg_bit_0_2 a a' p0 H0). Rewrite H4.
-    Rewrite (negb_elim (ad_bit_0 a0)). Rewrite MapGet_M2_bit_0_2.
-    Apply M1_semantics_2; Assumption.
-    Intro; Case (ad_bit_0 a); Apply MapGet_M2_both_NONE; 
-	Apply M1_semantics_2; Assumption.
-    Intros. Simpl. Elim (ad_neq a a0 H1). Intro. Rewrite H3. Rewrite if_negb.
-    Rewrite MapGet_M2_bit_0_2. Reflexivity.
-    Intro. Elim (ad_neq a' a0 H2). Intro. Rewrite (ad_same_bit_0 a a' p0 H0). Rewrite H4.
-    Rewrite if_negb. Rewrite MapGet_M2_bit_0_2. Reflexivity.
-    Intro. Cut (ad_xor (ad_div_2 a) (ad_div_2 a'))=(ad_x p0). Intro.
-    Case (ad_bit_0 a); Apply MapGet_M2_both_NONE; Trivial; 
-	Apply H; Assumption.
-    Rewrite <- ad_xor_div_2. Rewrite H0. Reflexivity.
-    Intros. Simpl. Elim (ad_neq a a0 H0). Intro. Rewrite H2. Rewrite if_negb.
-    Rewrite MapGet_M2_bit_0_2. Apply M1_semantics_2. Apply ad_div_bit_neq. Assumption.
-    Rewrite (ad_neg_bit_0_1 a a' H) in H2. Rewrite (negb_intro (ad_bit_0 a')).
-    Rewrite (negb_intro (ad_bit_0 a0)). Rewrite H2. Reflexivity.
-    Intro. Elim (ad_neq a' a0 H1). Intro. Rewrite (ad_neg_bit_0_1 a a' H). Rewrite H3.
-    Rewrite (negb_elim (ad_bit_0 a0)). Rewrite MapGet_M2_bit_0_2.
-    Apply M1_semantics_2; Assumption.
-    Intro. Case (ad_bit_0 a); Apply MapGet_M2_both_NONE; Apply M1_semantics_2; Assumption.
-  Qed.
-
-  Lemma MapPut1_semantics : (p:positive) (a,a':ad) (y,y':A)
-      (ad_xor a a')=(ad_x p)
-        -> (eqm (MapGet (MapPut1 a y a' y' p))
-	        [a0:ad] if (ad_eq a a0) then (SOME y)
-		        else if (ad_eq a' a0) then (SOME y') else NONE).
-  Proof.
-    Unfold eqm. Intros. Elim (sumbool_of_bool (ad_eq a a0)). Intro H0. Rewrite H0.
-    Rewrite <- (ad_eq_complete ? ? H0). Exact (MapPut1_semantics_1 p a a' y y' H).
-    Intro H0. Rewrite H0. Elim (sumbool_of_bool (ad_eq a' a0)). Intro H1.
-    Rewrite <- (ad_eq_complete ? ? H1). Rewrite (ad_eq_correct a').
-    Exact (MapPut1_semantics_2 p a a' y y' H).
-    Intro H1. Rewrite H1. Exact (MapPut1_semantics_3 p a a' a0 y y' H H0 H1).
-  Qed.
-
-  Lemma MapPut1_semantics' : (p:positive) (a,a':ad) (y,y':A)
-      (ad_xor a a')=(ad_x p)
-        -> (eqm (MapGet (MapPut1 a y a' y' p))
-	        [a0:ad] if (ad_eq a' a0) then (SOME y')
-		        else if (ad_eq a a0) then (SOME y) else NONE).
-  Proof.
-    Unfold eqm. Intros. Rewrite (MapPut1_semantics p a a' y y' H a0).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H0. Rewrite H0.
-    Rewrite <- (ad_eq_complete a a0 H0). Rewrite (ad_eq_comm a' a).
-    Rewrite (ad_xor_eq_false a a' p H). Reflexivity.
-    Intro H0. Rewrite H0. Reflexivity.
-  Qed.
-
-  Fixpoint MapPut [m:Map] : ad -> A -> Map :=
-    Cases m of
-        M0 => M1
-      | (M1 a y) => [a':ad; y':A]
-          Cases (ad_xor a a') of
-	      ad_z => (M1 a' y')
-	    | (ad_x p) => (MapPut1 a y a' y' p)
-          end
-      | (M2 m1 m2) => [a:ad; y:A]
-          Cases a of
-	      ad_z => (M2 (MapPut m1 ad_z y) m2)
-	    | (ad_x xH) => (M2 m1 (MapPut m2 ad_z y))
-	    | (ad_x (xO p)) => (M2 (MapPut m1 (ad_x p) y) m2)
-	    | (ad_x (xI p)) => (M2 m1 (MapPut m2 (ad_x p) y))
-	  end
-    end.
-
-  Lemma MapPut_semantics_1 : (a:ad) (y:A) (a0:ad)
-      (MapGet (MapPut M0 a y) a0)=(MapGet (M1 a y) a0).
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma MapPut_semantics_2_1 : (a:ad) (y,y':A) (a0:ad)
-      (MapGet (MapPut (M1 a y) a y') a0)=(if (ad_eq a a0) then (SOME y') else NONE).
-  Proof.
-    Simpl. Intros. Rewrite (ad_xor_nilpotent a). Trivial.
-  Qed.
-
-  Lemma MapPut_semantics_2_2 : (a,a':ad) (y,y':A) (a0:ad) (a'':ad) (ad_xor a a')=a'' ->
-      (MapGet (MapPut (M1 a y) a' y') a0)=
-      (if (ad_eq a' a0) then (SOME y') else
-       if (ad_eq a a0) then (SOME y) else NONE).
-  Proof.
-    Induction a''. Intro. Rewrite (ad_xor_eq ? ? H). Rewrite MapPut_semantics_2_1.
-    Case (ad_eq a' a0); Trivial.
-    Intros. Simpl. Rewrite H. Rewrite (MapPut1_semantics p a a' y y' H a0).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H0. Rewrite H0. Rewrite <- (ad_eq_complete ? ? H0).
-    Rewrite (ad_eq_comm a' a). Rewrite (ad_xor_eq_false ? ? ? H). Reflexivity.
-    Intro H0. Rewrite H0. Reflexivity.
-  Qed.
-
-  Lemma MapPut_semantics_2 : (a,a':ad) (y,y':A) (a0:ad)
-      (MapGet (MapPut (M1 a y) a' y') a0)=
-      (if (ad_eq a' a0) then (SOME y') else
-       if (ad_eq a a0) then (SOME y) else NONE).
-  Proof.
-    Intros. Apply MapPut_semantics_2_2 with a'':=(ad_xor a a'); Trivial.
-  Qed.
-
-  Lemma MapPut_semantics_3_1 : (m,m':Map) (a:ad) (y:A)
-      (MapPut (M2 m m') a y)=(if (ad_bit_0 a) then (M2 m (MapPut m' (ad_div_2 a) y))
-                                              else (M2 (MapPut m (ad_div_2 a) y) m')).
-  Proof.
-    Induction a. Trivial.
-    Induction p; Trivial.
-  Qed.
-
-  Lemma MapPut_semantics : (m:Map) (a:ad) (y:A)
-      (eqm (MapGet (MapPut m a y)) [a':ad] if (ad_eq a a') then (SOME y) else (MapGet m a')).
-  Proof.
-    Unfold eqm. Induction m. Exact MapPut_semantics_1.
-    Intros. Unfold 2 MapGet. Apply MapPut_semantics_2; Assumption.
-    Intros. Rewrite MapPut_semantics_3_1. Rewrite (MapGet_M2_bit_0_if m0 m1 a0).
-    Elim (sumbool_of_bool (ad_bit_0 a)). Intro H1. Rewrite H1. Rewrite MapGet_M2_bit_0_if.
-    Elim (sumbool_of_bool (ad_bit_0 a0)). Intro H2. Rewrite H2.
-    Rewrite (H0 (ad_div_2 a) y (ad_div_2 a0)). Elim (sumbool_of_bool (ad_eq a a0)).
-    Intro H3. Rewrite H3. Rewrite (ad_div_eq ? ? H3). Reflexivity.
-    Intro H3. Rewrite H3. Rewrite <- H2 in H1. Rewrite (ad_div_bit_neq ? ? H3 H1). Reflexivity.
-    Intro H2. Rewrite H2. Rewrite (ad_eq_comm a a0). Rewrite (ad_bit_0_neq a0 a H2 H1).
-    Reflexivity.
-    Intro H1. Rewrite H1. Rewrite MapGet_M2_bit_0_if. Elim (sumbool_of_bool (ad_bit_0 a0)).
-    Intro H2. Rewrite H2. Rewrite (ad_bit_0_neq a a0 H1 H2). Reflexivity.
-    Intro H2. Rewrite H2. Rewrite (H (ad_div_2 a) y (ad_div_2 a0)).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H3. Rewrite H3.
-    Rewrite (ad_div_eq a a0 H3). Reflexivity.
-    Intro H3. Rewrite H3. Rewrite <- H2 in H1. Rewrite (ad_div_bit_neq a a0 H3 H1). Reflexivity.
-  Qed.
-
-  Fixpoint MapPut_behind [m:Map] : ad -> A -> Map :=
-    Cases m of
-        M0 => M1
-      | (M1 a y) => [a':ad; y':A]
-          Cases (ad_xor a a') of
-	      ad_z => m
-	    | (ad_x p) => (MapPut1 a y a' y' p)
-          end
-      | (M2 m1 m2) => [a:ad; y:A]
-          Cases a of
-	      ad_z => (M2 (MapPut_behind m1 ad_z y) m2)
-	    | (ad_x xH) => (M2 m1 (MapPut_behind m2 ad_z y))
-	    | (ad_x (xO p)) => (M2 (MapPut_behind m1 (ad_x p) y) m2)
-	    | (ad_x (xI p)) => (M2 m1 (MapPut_behind m2 (ad_x p) y))
-	  end
-    end.
-
-  Lemma MapPut_behind_semantics_3_1 : (m,m':Map) (a:ad) (y:A)
-      (MapPut_behind (M2 m m') a y)=
-      (if (ad_bit_0 a) then (M2 m (MapPut_behind m' (ad_div_2 a) y))
-                       else (M2 (MapPut_behind m (ad_div_2 a) y) m')).
-  Proof.
-    Induction a. Trivial.
-    Induction p; Trivial.
-  Qed.
-
-  Lemma MapPut_behind_as_before_1 : (a,a',a0:ad) (ad_eq a' a0)=false ->
-      (y,y':A) (MapGet (MapPut (M1 a y) a' y') a0)
-               =(MapGet (MapPut_behind (M1 a y) a' y') a0).
-  Proof.
-    Intros a a' a0. Simpl. Intros H y y'. Elim (ad_sum (ad_xor a a')). Intro H0. Elim H0.
-    Intros p H1. Rewrite H1. Reflexivity.
-    Intro H0. Rewrite H0. Rewrite (ad_xor_eq ? ? H0). Rewrite (M1_semantics_2 a' a0 y H).
-    Exact (M1_semantics_2 a' a0 y' H).
-  Qed.
-
-  Lemma MapPut_behind_as_before : (m:Map) (a:ad) (y:A)
-      (a0:ad) (ad_eq a a0)=false ->
-         (MapGet (MapPut m a y) a0)=(MapGet (MapPut_behind m a y) a0).
-  Proof.
-    Induction m. Trivial.
-    Intros a y a' y' a0 H. Exact (MapPut_behind_as_before_1 a a' a0 H y y').
-    Intros. Rewrite MapPut_semantics_3_1. Rewrite MapPut_behind_semantics_3_1.
-    Elim (sumbool_of_bool (ad_bit_0 a)). Intro H2. Rewrite H2. Rewrite MapGet_M2_bit_0_if.
-    Rewrite MapGet_M2_bit_0_if. Elim (sumbool_of_bool (ad_bit_0 a0)). Intro H3.
-    Rewrite H3. Apply H0. Rewrite <- H3 in H2. Exact (ad_div_bit_neq a a0 H1 H2).
-    Intro H3. Rewrite H3. Reflexivity.
-    Intro H2. Rewrite H2. Rewrite MapGet_M2_bit_0_if. Rewrite MapGet_M2_bit_0_if.
-    Elim (sumbool_of_bool (ad_bit_0 a0)). Intro H3. Rewrite H3. Reflexivity.
-    Intro H3. Rewrite H3. Apply H. Rewrite <- H3 in H2. Exact (ad_div_bit_neq a a0 H1 H2).
-  Qed.
-
-  Lemma MapPut_behind_new : (m:Map) (a:ad) (y:A)
-      (MapGet (MapPut_behind m a y) a)=(Cases (MapGet m a) of
-                                            (SOME y') => (SOME y')
-					  | _ => (SOME y)
-				        end).
-  Proof.
-    Induction m. Simpl. Intros. Rewrite (ad_eq_correct a). Reflexivity.
-    Intros. Elim (ad_sum (ad_xor a a1)). Intro H. Elim H. Intros p H0. Simpl.
-    Rewrite H0. Rewrite (ad_xor_eq_false a a1 p). Exact (MapPut1_semantics_2 p a a1 a0 y H0).
-    Assumption.
-    Intro H. Simpl. Rewrite H. Rewrite <- (ad_xor_eq ? ? H). Rewrite (ad_eq_correct a).
-    Exact (M1_semantics_1 a a0).
-    Intros. Rewrite MapPut_behind_semantics_3_1. Rewrite (MapGet_M2_bit_0_if m0 m1 a).
-    Elim (sumbool_of_bool (ad_bit_0 a)). Intro H1. Rewrite H1. Rewrite (MapGet_M2_bit_0_1 a H1).
-    Exact (H0 (ad_div_2 a) y).
-    Intro H1. Rewrite H1. Rewrite (MapGet_M2_bit_0_0 a H1). Exact (H (ad_div_2 a) y).
-  Qed.
-
-  Lemma MapPut_behind_semantics : (m:Map) (a:ad) (y:A)
-      (eqm (MapGet (MapPut_behind m a y))
-           [a':ad] Cases (MapGet m a') of
-                       (SOME y') => (SOME y')
-		     | _ => if (ad_eq a a') then (SOME y) else NONE
-		   end).
-  Proof.
-    Unfold eqm. Intros. Elim (sumbool_of_bool (ad_eq a a0)). Intro H. Rewrite H.
-    Rewrite (ad_eq_complete ? ? H). Apply MapPut_behind_new.
-    Intro H. Rewrite H. Rewrite <- (MapPut_behind_as_before m a y a0 H).
-    Rewrite (MapPut_semantics m a y a0). Rewrite H. Case (MapGet m a0); Trivial.
-  Qed.
-
-  Definition makeM2 := [m,m':Map] Cases m m' of
-                                      M0 M0 => M0
-				    | M0 (M1 a y) => (M1 (ad_double_plus_un a) y)
-				    | (M1 a y) M0 => (M1 (ad_double a) y)
-				    | _ _ => (M2 m m')
-				  end.
-
-  Lemma makeM2_M2 : (m,m':Map) (eqm (MapGet (makeM2 m m')) (MapGet (M2 m m'))).
-  Proof.
-    Unfold eqm. Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H.
-    Rewrite (MapGet_M2_bit_0_1 a H m m'). Case m'. Case m. Reflexivity.
-    Intros a0 y. Simpl. Rewrite (ad_bit_0_1_not_double a H a0). Reflexivity.
-    Intros m1 m2. Unfold makeM2. Rewrite MapGet_M2_bit_0_1. Reflexivity.
-    Assumption.
-    Case m. Intros a0 y. Simpl. Elim (sumbool_of_bool (ad_eq a0 (ad_div_2 a))).
-    Intro H0. Rewrite H0. Rewrite (ad_eq_complete ? ? H0). Rewrite (ad_div_2_double_plus_un a H).
-    Rewrite (ad_eq_correct a). Reflexivity.
-    Intro H0. Rewrite H0. Rewrite (ad_eq_comm a0 (ad_div_2 a)) in H0.
-    Rewrite (ad_not_div_2_not_double_plus_un a a0 H0). Reflexivity.
-    Intros a0 y0 a1 y1. Unfold makeM2. Rewrite MapGet_M2_bit_0_1. Reflexivity.
-    Assumption.
-    Intros m1 m2 a0 y. Unfold makeM2. Rewrite MapGet_M2_bit_0_1. Reflexivity.
-    Assumption.
-    Intros m1 m2. Unfold makeM2.
-    Cut (MapGet (M2 m (M2 m1 m2)) a)=(MapGet (M2 m1 m2) (ad_div_2 a)). 
-    Case m; Trivial.
-    Exact (MapGet_M2_bit_0_1 a H m (M2 m1 m2)).
-    Intro H. Rewrite (MapGet_M2_bit_0_0 a H m m'). Case m. Case m'. Reflexivity.
-    Intros a0 y. Simpl. Rewrite (ad_bit_0_0_not_double_plus_un a H a0). Reflexivity.
-    Intros m1 m2. Unfold makeM2. Rewrite MapGet_M2_bit_0_0. Reflexivity.
-    Assumption.
-    Case m'. Intros a0 y. Simpl. Elim (sumbool_of_bool (ad_eq a0 (ad_div_2 a))). Intro H0.
-    Rewrite H0. Rewrite (ad_eq_complete ? ? H0). Rewrite (ad_div_2_double a H).
-    Rewrite (ad_eq_correct a). Reflexivity.
-    Intro H0. Rewrite H0. Rewrite (ad_eq_comm (ad_double a0) a).
-    Rewrite (ad_eq_comm a0 (ad_div_2 a)) in H0. Rewrite (ad_not_div_2_not_double a a0 H0).
-    Reflexivity.
-    Intros a0 y0 a1 y1. Unfold makeM2. Rewrite MapGet_M2_bit_0_0. Reflexivity.
-    Assumption.
-    Intros m1 m2 a0 y. Unfold makeM2. Rewrite MapGet_M2_bit_0_0. Reflexivity.
-    Assumption.
-    Intros m1 m2. Unfold makeM2. Exact (MapGet_M2_bit_0_0 a H (M2 m1 m2) m').
-  Qed.
-
-  Fixpoint MapRemove [m:Map] : ad -> Map :=
-    Cases m of
-        M0 => [_:ad] M0
-      | (M1 a y) => [a':ad]
-          Cases (ad_eq a a') of
-	      true => M0
-	    | false => m
-          end
-      | (M2 m1 m2) => [a:ad]
-          if (ad_bit_0 a)
-	  then (makeM2 m1 (MapRemove m2 (ad_div_2 a)))
-	  else (makeM2 (MapRemove m1 (ad_div_2 a)) m2)
-    end.
-
-  Lemma MapRemove_semantics : (m:Map) (a:ad)
-      (eqm (MapGet (MapRemove m a)) [a':ad] if (ad_eq a a') then NONE else (MapGet m a')).
-  Proof.
-    Unfold eqm. Induction m. Simpl. Intros. Case (ad_eq a a0); Trivial.
-    Intros. Simpl. Elim (sumbool_of_bool (ad_eq a1 a2)). Intro H. Rewrite H.
-    Elim (sumbool_of_bool (ad_eq a a1)). Intro H0. Rewrite H0. Reflexivity.
-    Intro H0. Rewrite H0. Rewrite (ad_eq_complete ? ? H) in H0. Exact (M1_semantics_2 a a2 a0 H0).
-    Intro H. Elim (sumbool_of_bool (ad_eq a a1)). Intro H0. Rewrite H0. Rewrite H.
-    Rewrite <- (ad_eq_complete ? ? H0) in H. Rewrite H. Reflexivity.
-    Intro H0. Rewrite H0. Rewrite H. Reflexivity.
-    Intros. Change (MapGet (if (ad_bit_0 a)
-                            then (makeM2 m0 (MapRemove m1 (ad_div_2 a)))
-                            else (makeM2 (MapRemove m0 (ad_div_2 a)) m1))
-			   a0)
-                   =(if (ad_eq a a0) then NONE else (MapGet (M2 m0 m1) a0)).
-    Elim (sumbool_of_bool (ad_bit_0 a)). Intro H1. Rewrite H1.
-    Rewrite (makeM2_M2 m0 (MapRemove m1 (ad_div_2 a)) a0). Elim (sumbool_of_bool (ad_bit_0 a0)).
-    Intro H2. Rewrite MapGet_M2_bit_0_1. Rewrite (H0 (ad_div_2 a) (ad_div_2 a0)).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H3. Rewrite H3. Rewrite (ad_div_eq ? ? H3).
-    Reflexivity.
-    Intro H3. Rewrite H3. Rewrite <- H2 in H1. Rewrite (ad_div_bit_neq ? ? H3 H1).
-    Rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). Reflexivity.
-    Assumption.
-    Intro H2. Rewrite (MapGet_M2_bit_0_0 a0 H2 m0 (MapRemove m1 (ad_div_2 a))).
-    Rewrite (ad_eq_comm a a0). Rewrite (ad_bit_0_neq ? ? H2 H1).
-    Rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). Reflexivity.
-    Intro H1. Rewrite H1. Rewrite (makeM2_M2 (MapRemove m0 (ad_div_2 a)) m1 a0).
-    Elim (sumbool_of_bool (ad_bit_0 a0)). Intro H2. Rewrite MapGet_M2_bit_0_1.
-    Rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). Rewrite (ad_bit_0_neq a a0 H1 H2). Reflexivity.
-    Assumption.
-    Intro H2. Rewrite MapGet_M2_bit_0_0. Rewrite (H (ad_div_2 a) (ad_div_2 a0)).
-    Rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). Elim (sumbool_of_bool (ad_eq a a0)). Intro H3.
-    Rewrite H3. Rewrite (ad_div_eq ? ? H3). Reflexivity.
-    Intro H3. Rewrite H3. Rewrite <- H2 in H1. Rewrite (ad_div_bit_neq ? ? H3 H1). Reflexivity.
-    Assumption.
-  Qed.
-
-  Fixpoint MapCard [m:Map] : nat :=
-    Cases m of
-        M0 => O
-      | (M1 _ _) => (S O)
-      | (M2 m m') => (plus (MapCard m) (MapCard m'))
-    end.
-
-  Fixpoint MapMerge [m:Map] : Map -> Map :=
-    Cases m of
-        M0 => [m':Map] m'
-      | (M1 a y) => [m':Map] (MapPut_behind m' a y)
-      | (M2 m1 m2) => [m':Map] Cases m' of
-      	                           M0 => m
-				 | (M1 a' y') => (MapPut m a' y')
-				 | (M2 m'1 m'2) => (M2 (MapMerge m1 m'1) 
-	                                               (MapMerge m2 m'2))
-			       end
-    end.
-
-  Lemma MapMerge_semantics : (m,m':Map)
-      (eqm (MapGet (MapMerge m m'))
-           [a0:ad] Cases (MapGet m' a0) of
-	               (SOME y') => (SOME y')
-		     | NONE => (MapGet m a0)
-                   end).
-  Proof.
-    Unfold eqm. Induction m. Intros. Simpl. Case (MapGet m' a); Trivial.
-    Intros. Simpl. Rewrite (MapPut_behind_semantics m' a a0 a1). Reflexivity.
-    Induction m'. Trivial.
-    Intros. Unfold MapMerge. Rewrite (MapPut_semantics (M2 m0 m1) a a0 a1).
-    Elim (sumbool_of_bool (ad_eq a a1)). Intro H1. Rewrite H1. Rewrite (ad_eq_complete ? ? H1).
-    Rewrite (M1_semantics_1 a1 a0). Reflexivity.
-    Intro H1. Rewrite H1. Rewrite (M1_semantics_2 a a1 a0 H1). Reflexivity.
-    Intros. Cut (MapMerge (M2 m0 m1) (M2 m2 m3))=(M2 (MapMerge m0 m2) (MapMerge m1 m3)).
-    Intro. Rewrite H3. Rewrite MapGet_M2_bit_0_if. Rewrite (H0 m3 (ad_div_2 a)).
-    Rewrite (H m2 (ad_div_2 a)). Rewrite (MapGet_M2_bit_0_if m2 m3 a).
-    Rewrite (MapGet_M2_bit_0_if m0 m1 a). Case (ad_bit_0 a); Trivial.
-    Reflexivity.
-  Qed.
-
-  (** [MapInter], [MapRngRestrTo], [MapRngRestrBy], [MapInverse] 
-      not implemented: need a decidable equality on [A]. *)
-
-  Fixpoint MapDelta [m:Map] : Map -> Map :=
-    Cases m of
-        M0 => [m':Map] m'
-      | (M1 a y) => [m':Map] Cases (MapGet m' a) of
-                                 NONE => (MapPut m' a y)
-			       | _ => (MapRemove m' a)
-			     end
-      | (M2 m1 m2) => [m':Map] Cases m' of
-                                   M0 => m
-				 | (M1 a' y') => Cases (MapGet m a') of
-				                     NONE => (MapPut m a' y')
-						   | _ => (MapRemove m a')
-						 end
-				 | (M2 m'1 m'2) => (makeM2 (MapDelta m1 m'1)
-				                           (MapDelta m2 m'2))
-			       end
-    end.
-
-  Lemma MapDelta_semantics_comm : (m,m':Map)
-      (eqm (MapGet (MapDelta m m')) (MapGet (MapDelta m' m))).
-  Proof.
-    Unfold eqm. Induction m. Induction m'; Reflexivity.
-    Induction m'. Reflexivity.
-    Unfold MapDelta. Intros. Elim (sumbool_of_bool (ad_eq a a1)). Intro H.
-    Rewrite <- (ad_eq_complete ? ? H). Rewrite (M1_semantics_1 a a2).
-    Rewrite (M1_semantics_1 a a0). Simpl. Rewrite (ad_eq_correct a). Reflexivity.
-    Intro H. Rewrite (M1_semantics_2 a a1 a0 H). Rewrite (ad_eq_comm a a1) in H.
-    Rewrite (M1_semantics_2 a1 a a2 H). Rewrite (MapPut_semantics (M1 a a0) a1 a2 a3).
-    Rewrite (MapPut_semantics (M1 a1 a2) a a0 a3). Elim (sumbool_of_bool (ad_eq a a3)).
-    Intro H0. Rewrite H0. Rewrite (ad_eq_complete ? ? H0) in H. Rewrite H.
-    Rewrite (ad_eq_complete ? ? H0). Rewrite (M1_semantics_1 a3 a0). Reflexivity.
-    Intro H0. Rewrite H0. Rewrite (M1_semantics_2 a a3 a0 H0).
-    Elim (sumbool_of_bool (ad_eq a1 a3)). Intro H1. Rewrite H1.
-    Rewrite (ad_eq_complete ? ? H1). Exact (M1_semantics_1 a3 a2).
-    Intro H1. Rewrite H1. Exact (M1_semantics_2 a1 a3 a2 H1).
-    Intros. Reflexivity.
-    Induction m'. Reflexivity.
-    Reflexivity.
-    Intros. Simpl. Rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
-    Rewrite (makeM2_M2 (MapDelta m2 m0) (MapDelta m3 m1) a).
-    Rewrite (MapGet_M2_bit_0_if (MapDelta m0 m2) (MapDelta m1 m3) a).
-    Rewrite (MapGet_M2_bit_0_if (MapDelta m2 m0) (MapDelta m3 m1) a).
-    Rewrite (H0 m3 (ad_div_2 a)). Rewrite (H m2 (ad_div_2 a)). Reflexivity.
-  Qed.
-
-  Lemma MapDelta_semantics_1_1 : (a:ad) (y:A) (m':Map) (a0:ad)
-    (MapGet (M1 a y) a0)=NONE -> (MapGet m' a0)=NONE -> 
-      (MapGet (MapDelta (M1 a y) m') a0)=NONE.
-  Proof.
-    Intros. Unfold MapDelta. Elim (sumbool_of_bool (ad_eq a a0)). Intro H1.
-    Rewrite (ad_eq_complete ? ? H1) in H. Rewrite (M1_semantics_1 a0 y) in H. Discriminate H.
-    Intro H1. Case (MapGet m' a). Rewrite (MapPut_semantics m' a y a0). Rewrite H1. Assumption.
-    Rewrite (MapRemove_semantics m' a a0). Rewrite H1. Trivial.
-  Qed.
-
-  Lemma MapDelta_semantics_1 : (m,m':Map) (a:ad)
-    (MapGet m a)=NONE -> (MapGet m' a)=NONE -> 
-      (MapGet (MapDelta m m') a)=NONE.
-  Proof.
-    Induction m. Trivial.
-    Exact MapDelta_semantics_1_1.
-    Induction m'. Trivial.
-    Intros. Rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
-    Apply MapDelta_semantics_1_1; Trivial.
-    Intros. Simpl. Rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
-    Rewrite MapGet_M2_bit_0_if. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H5. Rewrite H5.
-    Apply H0. Rewrite (MapGet_M2_bit_0_1 a H5 m0 m1) in H3. Exact H3.
-    Rewrite (MapGet_M2_bit_0_1 a H5 m2 m3) in H4. Exact H4.
-    Intro H5. Rewrite H5. Apply H. Rewrite (MapGet_M2_bit_0_0 a H5 m0 m1) in H3. Exact H3.
-    Rewrite (MapGet_M2_bit_0_0 a H5 m2 m3) in H4. Exact H4.
-  Qed.
-
-  Lemma MapDelta_semantics_2_1 : (a:ad) (y:A) (m':Map) (a0:ad) (y0:A)
-    (MapGet (M1 a y) a0)=NONE -> (MapGet m' a0)=(SOME y0) ->
-      (MapGet (MapDelta (M1 a y) m') a0)=(SOME y0).
-  Proof.
-    Intros. Unfold MapDelta. Elim (sumbool_of_bool (ad_eq a a0)). Intro H1.
-    Rewrite (ad_eq_complete ? ? H1) in H. Rewrite (M1_semantics_1 a0 y) in H. Discriminate H.
-    Intro H1. Case (MapGet m' a). Rewrite (MapPut_semantics m' a y a0). Rewrite H1. Assumption.
-    Rewrite (MapRemove_semantics m' a a0). Rewrite H1. Trivial.
-  Qed.
-
-  Lemma MapDelta_semantics_2_2 : (a:ad) (y:A) (m':Map) (a0:ad) (y0:A)
-    (MapGet (M1 a y) a0)=(SOME y0) -> (MapGet m' a0)=NONE ->
-      (MapGet (MapDelta (M1 a y) m') a0)=(SOME y0).
-  Proof.
-    Intros. Unfold MapDelta. Elim (sumbool_of_bool (ad_eq a a0)). Intro H1.
-    Rewrite (ad_eq_complete ? ? H1) in H. Rewrite (ad_eq_complete ? ? H1).
-    Rewrite H0. Rewrite (MapPut_semantics m' a0 y a0). Rewrite (ad_eq_correct a0).
-    Rewrite (M1_semantics_1 a0 y) in H. Simple Inversion H. Assumption.
-    Intro H1. Rewrite (M1_semantics_2 a a0 y H1) in H. Discriminate H.
-  Qed.
-
-  Lemma MapDelta_semantics_2 : (m,m':Map) (a:ad) (y:A)
-    (MapGet m a)=NONE -> (MapGet m' a)=(SOME y) -> 
-      (MapGet (MapDelta m m') a)=(SOME y).
-  Proof.
-    Induction m. Trivial.
-    Exact MapDelta_semantics_2_1.
-    Induction m'. Intros. Discriminate H2.
-    Intros. Rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
-    Apply MapDelta_semantics_2_2; Assumption.
-    Intros. Simpl. Rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
-    Rewrite MapGet_M2_bit_0_if. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H5. Rewrite H5.
-    Apply H0. Rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). Assumption.
-    Rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). Assumption.
-    Intro H5. Rewrite H5. Apply H. Rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). Assumption.
-    Rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). Assumption.
-  Qed.
-
-  Lemma MapDelta_semantics_3_1 : (a0:ad) (y0:A) (m':Map) (a:ad) (y,y':A)
-    (MapGet (M1 a0 y0) a)=(SOME y) -> (MapGet m' a)=(SOME y') ->
-      (MapGet (MapDelta (M1 a0 y0) m') a)=NONE.
-  Proof.
-    Intros. Unfold MapDelta. Elim (sumbool_of_bool (ad_eq a0 a)). Intro H1.
-    Rewrite (ad_eq_complete a0 a H1). Rewrite H0. Rewrite (MapRemove_semantics m' a a).
-    Rewrite (ad_eq_correct a). Reflexivity.
-    Intro H1. Rewrite (M1_semantics_2 a0 a y0 H1) in H. Discriminate H.
-  Qed.
-
-  Lemma MapDelta_semantics_3 : (m,m':Map) (a:ad) (y,y':A)
-    (MapGet m a)=(SOME y) -> (MapGet m' a)=(SOME y') -> 
-      (MapGet (MapDelta m m') a)=NONE.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Exact MapDelta_semantics_3_1.
-    Induction m'. Intros. Discriminate H2.
-    Intros. Rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
-    Exact (MapDelta_semantics_3_1 a a0 (M2 m0 m1) a1 y' y H2 H1).
-    Intros. Simpl. Rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
-    Rewrite MapGet_M2_bit_0_if. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H5. Rewrite H5.
-    Apply (H0 m3 (ad_div_2 a) y y'). Rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). Assumption.
-    Rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). Assumption.
-    Intro H5. Rewrite H5. Apply (H m2 (ad_div_2 a) y y').
-    Rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). Assumption.
-    Rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). Assumption.
-  Qed.
-
-  Lemma MapDelta_semantics : (m,m':Map)
-      (eqm (MapGet (MapDelta m m'))
-           [a0:ad] Cases (MapGet m a0) (MapGet m' a0) of
-	               NONE (SOME y') => (SOME y')
-		     | (SOME y) NONE => (SOME y)
-		     | _ _ => NONE
-		   end).
-  Proof.
-    Unfold eqm. Intros. Elim (option_sum (MapGet m' a)). Intro H. Elim H. Intros a0 H0.
-    Rewrite H0. Elim (option_sum (MapGet m a)). Intro H1. Elim H1. Intros a1 H2. Rewrite H2.
-    Exact (MapDelta_semantics_3 m m' a a1 a0 H2 H0).
-    Intro H1. Rewrite H1. Exact (MapDelta_semantics_2 m m' a a0 H1 H0).
-    Intro H. Rewrite H. Elim (option_sum (MapGet m a)). Intro H0. Elim H0. Intros a0 H1.
-    Rewrite H1. Rewrite (MapDelta_semantics_comm m m' a).
-    Exact (MapDelta_semantics_2 m' m a a0 H H1).
-    Intro H0. Rewrite H0. Exact (MapDelta_semantics_1 m m' a H0 H).
-  Qed.
-
-  Definition MapEmptyp := [m:Map]
-    Cases m of
-      	M0 => true
-      | _ => false
-    end.
-
-  Lemma MapEmptyp_correct : (MapEmptyp M0)=true.
-  Proof.
-    Reflexivity.
-  Qed.
-
-  Lemma MapEmptyp_complete : (m:Map) (MapEmptyp m)=true -> m=M0.
-  Proof.
-    Induction m; Trivial. Intros. Discriminate H.
-    Intros. Discriminate H1.
-  Qed.
-
-  (** [MapSplit] not implemented: not the preferred way of recursing over Maps
-      (use [MapSweep], [MapCollect], or [MapFold] in Mapiter.v. *)
-
-End MapDefs.
diff --git a/theories7/IntMap/Mapaxioms.v b/theories7/IntMap/Mapaxioms.v
deleted file mode 100644
index 085afd69..00000000
--- a/theories7/IntMap/Mapaxioms.v
+++ /dev/null
@@ -1,670 +0,0 @@
-(************************************************************************)
-(*  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: Mapaxioms.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $	 i*)
-
-Require Bool.
-Require Sumbool.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require Fset.
-
-Section MapAxioms.
-
-  Variable A, B, C : Set.
-
-  Lemma eqm_sym : (f,f':ad->(option A)) (eqm A f f') -> (eqm A f' f).
-  Proof.
-    Unfold eqm. Intros. Rewrite H. Reflexivity.
-  Qed.
-
-  Lemma eqm_refl :  (f:ad->(option A)) (eqm A f f).
-  Proof.
-    Unfold eqm. Trivial.
-  Qed.
-
-  Lemma eqm_trans : (f,f',f'':ad->(option A)) (eqm A f f') -> (eqm A f' f'') -> (eqm A f f'').
-  Proof.
-    Unfold eqm. Intros. Rewrite H. Exact (H0 a).
-  Qed.
-
-  Definition eqmap := [m,m':(Map A)] (eqm A (MapGet A m) (MapGet A m')).
-
-  Lemma eqmap_sym : (m,m':(Map A)) (eqmap m m') -> (eqmap m' m).
-  Proof.
-    Intros. Unfold eqmap. Apply eqm_sym. Assumption.
-  Qed.
-
-  Lemma eqmap_refl :  (m:(Map A)) (eqmap m m).
-  Proof.
-    Intros. Unfold eqmap. Apply eqm_refl.
-  Qed.
-
-  Lemma eqmap_trans : (m,m',m'':(Map A)) (eqmap m m') -> (eqmap m' m'') -> (eqmap m m'').
-  Proof.
-    Intros. Exact (eqm_trans (MapGet A m) (MapGet A m') (MapGet A m'') H H0).
-  Qed.
-
-  Lemma MapPut_as_Merge : (m:(Map A)) (a:ad) (y:A)
-      (eqmap (MapPut A m a y) (MapMerge A m (M1 A a y))).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapPut_semantics A m a y a0).
-    Rewrite (MapMerge_semantics A m (M1 A a y) a0). Unfold 2 MapGet.
-    Elim (sumbool_of_bool (ad_eq a a0)); Intro H; Rewrite H; Reflexivity.
-  Qed.
-
-  Lemma MapPut_ext : (m,m':(Map A)) (eqmap m m') ->
-      (a:ad) (y:A) (eqmap (MapPut A m a y) (MapPut A m' a y)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapPut_semantics A m' a y a0).
-    Rewrite (MapPut_semantics A m a y a0). 
-    Case (ad_eq a a0); [ Reflexivity | Apply H ].
-  Qed.
-
-  Lemma MapPut_behind_as_Merge : (m:(Map A)) (a:ad) (y:A)
-      (eqmap (MapPut_behind A m a y) (MapMerge A (M1 A a y) m)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapPut_behind_semantics A m a y a0).
-    Rewrite (MapMerge_semantics A (M1 A a y) m a0). Reflexivity.
-  Qed.
-
-  Lemma MapPut_behind_ext : (m,m':(Map A)) (eqmap m m') ->
-      (a:ad) (y:A) (eqmap (MapPut_behind A m a y) (MapPut_behind A m' a y)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapPut_behind_semantics A m' a y a0).
-    Rewrite (MapPut_behind_semantics A m a y a0). Rewrite (H a0). Reflexivity.
-  Qed.
-
-  Lemma MapMerge_empty_m_1 : (m:(Map A)) (MapMerge A (M0 A) m)=m.
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma MapMerge_empty_m : (m:(Map A)) (eqmap (MapMerge A (M0 A) m) m).
-  Proof.
-    Unfold eqmap eqm. Trivial.
-  Qed.
-
-  Lemma MapMerge_m_empty_1 : (m:(Map A)) (MapMerge A m (M0 A))=m.
-  Proof.
-    Induction m;Trivial.
-  Qed.
-
-  Lemma MapMerge_m_empty : (m:(Map A)) (eqmap (MapMerge A m (M0 A)) m).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite MapMerge_m_empty_1. Reflexivity.
-  Qed.
-
-  Lemma MapMerge_empty_l : (m,m':(Map A)) (eqmap (MapMerge A m m') (M0 A)) ->
-      (eqmap m (M0 A)).
-  Proof.
-    Unfold eqmap eqm. Intros. Cut (MapGet A (MapMerge A m m') a)=(MapGet A (M0 A) a).
-    Rewrite (MapMerge_semantics A m m' a). Case (MapGet A m' a). Trivial.
-    Intros. Discriminate H0.
-    Exact (H a).
-  Qed.
-
-  Lemma MapMerge_empty_r : (m,m':(Map A)) (eqmap (MapMerge A m m') (M0 A)) ->
-      (eqmap m' (M0 A)).
-  Proof.
-    Unfold eqmap eqm. Intros. Cut (MapGet A (MapMerge A m m') a)=(MapGet A (M0 A) a).
-    Rewrite (MapMerge_semantics A m m' a). Case (MapGet A m' a). Trivial.
-    Intros. Discriminate H0.
-    Exact (H a).
-  Qed.
-
-  Lemma MapMerge_assoc : (m,m',m'':(Map A)) (eqmap
-      (MapMerge A (MapMerge A m m') m'')
-      (MapMerge A m (MapMerge A m' m''))).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapMerge_semantics A (MapMerge A m m') m'' a).
-    Rewrite (MapMerge_semantics A m (MapMerge A m' m'') a). Rewrite (MapMerge_semantics A m m' a).
-    Rewrite (MapMerge_semantics A m' m'' a).
-    Case (MapGet A m'' a); Case (MapGet A m' a); Trivial.
-  Qed.
-
-  Lemma MapMerge_idempotent : (m:(Map A)) (eqmap (MapMerge A m m) m).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapMerge_semantics A m m a).
-    Case (MapGet A m a); Trivial.
-  Qed.
-
-  Lemma MapMerge_ext : (m1,m2,m'1,m'2:(Map A))
-      (eqmap m1 m'1) -> (eqmap m2 m'2) -> 
-        (eqmap (MapMerge A m1 m2) (MapMerge A m'1 m'2)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapMerge_semantics A m1 m2 a).
-    Rewrite (MapMerge_semantics A m'1 m'2 a). Rewrite (H a). Rewrite (H0 a). Reflexivity.
-  Qed.
-
-  Lemma MapMerge_ext_l : (m1,m'1,m2:(Map A))
-      (eqmap m1 m'1) -> (eqmap (MapMerge A m1 m2) (MapMerge A m'1 m2)).
-  Proof.
-    Intros. Apply MapMerge_ext. Assumption.
-    Apply eqmap_refl.
-  Qed.
-
-  Lemma MapMerge_ext_r : (m1,m2,m'2:(Map A))
-      (eqmap m2 m'2) -> (eqmap (MapMerge A m1 m2) (MapMerge A m1 m'2)).
-  Proof.
-    Intros. Apply MapMerge_ext. Apply eqmap_refl.
-    Assumption.
-  Qed.
-
-  Lemma MapMerge_RestrTo_l : (m,m',m'':(Map A))
-      (eqmap (MapMerge A (MapDomRestrTo A A m m') m'')
-             (MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m''))).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapMerge_semantics A (MapDomRestrTo A A m m') m'' a).
-    Rewrite (MapDomRestrTo_semantics A A m m' a).
-    Rewrite (MapDomRestrTo_semantics A A (MapMerge A m m'') (MapMerge A m' m'') a).
-    Rewrite (MapMerge_semantics A m' m'' a). Rewrite (MapMerge_semantics A m m'' a).
-    Case (MapGet A m'' a); Case (MapGet A m' a); Reflexivity.
-  Qed.
-
-  Lemma MapRemove_as_RestrBy : (m:(Map A)) (a:ad) (y:B)
-      (eqmap (MapRemove A m a) (MapDomRestrBy A B m (M1 B a y))).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapRemove_semantics A m a a0).
-    Rewrite (MapDomRestrBy_semantics A B m (M1 B a y) a0). Elim (sumbool_of_bool (ad_eq a a0)).
-    Intro H. Rewrite H. Rewrite (ad_eq_complete a a0 H). Rewrite (M1_semantics_1 B a0 y).
-    Reflexivity.
-    Intro H. Rewrite H. Rewrite (M1_semantics_2 B a a0 y H). Reflexivity.
-  Qed.
-
-  Lemma MapRemove_ext : (m,m':(Map A)) (eqmap m m') ->
-      (a:ad) (eqmap (MapRemove A m a) (MapRemove A m' a)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapRemove_semantics A m' a a0).
-    Rewrite (MapRemove_semantics A m a a0). 
-    Case (ad_eq a a0); [ Reflexivity | Apply H ].
-  Qed.
-
-  Lemma MapDomRestrTo_empty_m_1 : 
-      (m:(Map B)) (MapDomRestrTo A B (M0 A) m)=(M0 A).
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma MapDomRestrTo_empty_m : 
-      (m:(Map B)) (eqmap (MapDomRestrTo A B (M0 A) m) (M0 A)).
-  Proof.
-    Unfold eqmap eqm. Trivial.
-  Qed.
-
-  Lemma MapDomRestrTo_m_empty_1 : 
-      (m:(Map A)) (MapDomRestrTo A B m (M0 B))=(M0 A).
-  Proof.
-    Induction m;Trivial.
-  Qed.
-
-  Lemma MapDomRestrTo_m_empty : 
-      (m:(Map A)) (eqmap (MapDomRestrTo A B m (M0 B)) (M0 A)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDomRestrTo_m_empty_1 m). Reflexivity.
-  Qed.
-
-  Lemma MapDomRestrTo_assoc : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'')
-             (MapDomRestrTo A B m (MapDomRestrTo B C m' m''))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a).
-    Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A B m (MapDomRestrTo B C m' m'') a).
-    Rewrite (MapDomRestrTo_semantics B C m' m'' a).
-    Case (MapGet C m'' a); Case (MapGet B m' a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrTo_idempotent : (m:(Map A)) (eqmap (MapDomRestrTo A A m m) m).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDomRestrTo_semantics A A m m a).
-    Case (MapGet A m a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrTo_Dom : (m:(Map A)) (m':(Map B))
-      (eqmap (MapDomRestrTo A B m m') (MapDomRestrTo A unit m (MapDom B m'))).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A unit m (MapDom B m') a).
-    Elim (sumbool_of_bool (in_FSet a (MapDom B m'))). Intro H.
-    Elim (MapDom_semantics_2 B m' a H). Intros y H0. Rewrite H0. Unfold in_FSet in_dom in H.
-    Generalize H. Case (MapGet unit (MapDom B m') a); Trivial. Intro H1. Discriminate H1.
-    Intro H. Rewrite (MapDom_semantics_4 B m' a H). Unfold in_FSet in_dom in H.
-    Generalize H. Case (MapGet unit (MapDom B m') a). Trivial.
-    Intros H0 H1. Discriminate H1.
-  Qed.
-
-  Lemma MapDomRestrBy_empty_m_1 : 
-      (m:(Map B)) (MapDomRestrBy A B (M0 A) m)=(M0 A).
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma MapDomRestrBy_empty_m : 
-      (m:(Map B)) (eqmap (MapDomRestrBy A B (M0 A) m) (M0 A)).
-  Proof.
-    Unfold eqmap eqm. Trivial.
-  Qed.
-
-  Lemma MapDomRestrBy_m_empty_1 : (m:(Map A)) (MapDomRestrBy A B m (M0 B))=m.
-  Proof.
-    Induction m;Trivial.
-  Qed.
-
-  Lemma MapDomRestrBy_m_empty : (m:(Map A)) (eqmap (MapDomRestrBy A B m (M0 B)) m).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDomRestrBy_m_empty_1 m). Reflexivity.
-  Qed.
-
-  Lemma MapDomRestrBy_Dom : (m:(Map A)) (m':(Map B))
-      (eqmap (MapDomRestrBy A B m m') (MapDomRestrBy A unit m (MapDom B m'))).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Rewrite (MapDomRestrBy_semantics A unit m (MapDom B m') a).
-    Elim (sumbool_of_bool (in_FSet a (MapDom B m'))). Intro H.
-    Elim (MapDom_semantics_2 B m' a H). Intros y H0. Rewrite H0.
-    Unfold in_FSet in_dom in H. Generalize H. Case (MapGet unit (MapDom B m') a); Trivial.
-    Intro H1. Discriminate H1.
-    Intro H. Rewrite (MapDom_semantics_4 B m' a H). Unfold in_FSet in_dom in H.
-    Generalize H. Case (MapGet unit (MapDom B m') a). Trivial.
-    Intros H0 H1. Discriminate H1.
-  Qed.
-
-  Lemma MapDomRestrBy_m_m_1 : (m:(Map A)) (eqmap (MapDomRestrBy A A m m) (M0 A)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDomRestrBy_semantics A A m m a).
-    Case (MapGet A m a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrBy_By : (m:(Map A)) (m':(Map B)) (m'':(Map B))
-      (eqmap (MapDomRestrBy A B (MapDomRestrBy A B m m') m'')
-             (MapDomRestrBy A B m (MapMerge B m' m''))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A B m m') m'' a).
-    Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Rewrite (MapDomRestrBy_semantics A B m (MapMerge B m' m'') a).
-    Rewrite (MapMerge_semantics B m' m'' a).
-    Case (MapGet B m'' a); Case (MapGet B m' a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrBy_By_comm : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (eqmap (MapDomRestrBy A C (MapDomRestrBy A B m m') m'')
-             (MapDomRestrBy A B (MapDomRestrBy A C m m'') m')).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrBy_semantics A C (MapDomRestrBy A B m m') m'' a).
-    Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A C m m'') m' a).
-    Rewrite (MapDomRestrBy_semantics A C m m'' a).
-    Case (MapGet C m'' a); Case (MapGet B m' a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrBy_To : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'')
-             (MapDomRestrTo A B m (MapDomRestrBy B C m' m''))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a).
-    Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A B m (MapDomRestrBy B C m' m'') a).
-    Rewrite (MapDomRestrBy_semantics B C m' m'' a).
-    Case (MapGet C m'' a); Case (MapGet B m' a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrBy_To_comm : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'')
-             (MapDomRestrTo A B (MapDomRestrBy A C m m'') m')).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a).
-    Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A B (MapDomRestrBy A C m m'') m' a).
-    Rewrite (MapDomRestrBy_semantics A C m m'' a).
-    Case (MapGet C m'' a); Case (MapGet B m' a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrTo_By : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'')
-             (MapDomRestrTo A C m (MapDomRestrBy C B m'' m'))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a).
-    Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A C m (MapDomRestrBy C B m'' m') a).
-    Rewrite (MapDomRestrBy_semantics C B m'' m' a).
-    Case (MapGet C m'' a); Case (MapGet B m' a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrTo_By_comm : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'')
-             (MapDomRestrBy A B (MapDomRestrTo A C m m'') m')).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a).
-    Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Rewrite (MapDomRestrBy_semantics A B (MapDomRestrTo A C m m'') m' a).
-    Rewrite (MapDomRestrTo_semantics A C m m'' a).
-    Case (MapGet C m'' a); Case (MapGet B m' a); Trivial.
-  Qed.
-
-  Lemma MapDomRestrTo_To_comm : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'')
-             (MapDomRestrTo A B (MapDomRestrTo A C m m'') m')).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a).
-    Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A B (MapDomRestrTo A C m m'') m' a).
-    Rewrite (MapDomRestrTo_semantics A C m m'' a).
-    Case (MapGet C m'' a); Case (MapGet B m' a); Trivial.
-  Qed.
-
-  Lemma MapMerge_DomRestrTo : (m,m':(Map A)) (m'':(Map B))
-      (eqmap (MapDomRestrTo A B (MapMerge A m m') m'')
-             (MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m''))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrTo_semantics A B (MapMerge A m m') m'' a).
-    Rewrite (MapMerge_semantics A m m' a).
-    Rewrite (MapMerge_semantics A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m'') a).
-    Rewrite (MapDomRestrTo_semantics A B m' m'' a).
-    Rewrite (MapDomRestrTo_semantics A B m m'' a).
-    Case (MapGet B m'' a); Case (MapGet A m' a); Trivial.
-  Qed.
-
-  Lemma MapMerge_DomRestrBy : (m,m':(Map A)) (m'':(Map B))
-      (eqmap (MapDomRestrBy A B (MapMerge A m m') m'')
-             (MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m''))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrBy_semantics A B (MapMerge A m m') m'' a).
-    Rewrite (MapMerge_semantics A m m' a).
-    Rewrite (MapMerge_semantics A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m'') a).
-    Rewrite (MapDomRestrBy_semantics A B m' m'' a).
-    Rewrite (MapDomRestrBy_semantics A B m m'' a).
-    Case (MapGet B m'' a); Case (MapGet A m' a); Trivial.
-  Qed.
-
-  Lemma MapDelta_empty_m_1 : (m:(Map A)) (MapDelta A (M0 A) m)=m.
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma MapDelta_empty_m : (m:(Map A)) (eqmap (MapDelta A (M0 A) m) m).
-  Proof.
-    Unfold eqmap eqm. Trivial.
-  Qed.
-
-  Lemma MapDelta_m_empty_1 : (m:(Map A)) (MapDelta A m (M0 A))=m.
-  Proof.
-    Induction m;Trivial.
-  Qed.
-
-  Lemma MapDelta_m_empty : (m:(Map A)) (eqmap (MapDelta A m (M0 A)) m).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite MapDelta_m_empty_1. Reflexivity.
-  Qed.
-
-  Lemma MapDelta_nilpotent : (m:(Map A)) (eqmap (MapDelta A m m) (M0 A)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDelta_semantics A m m a).
-    Case (MapGet A m a); Trivial.
-  Qed.
-
-  Lemma MapDelta_as_Merge : (m,m':(Map A)) (eqmap (MapDelta A m m')
-      	(MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDelta_semantics A m m' a).
-    Rewrite (MapMerge_semantics A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m) a).
-    Rewrite (MapDomRestrBy_semantics A A m' m a).
-    Rewrite (MapDomRestrBy_semantics A A m m' a).
-    Case (MapGet A m a); Case (MapGet A m' a); Trivial.
-  Qed.
-
-  Lemma MapDelta_as_DomRestrBy : (m,m':(Map A)) (eqmap (MapDelta A m m')
-      	(MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m'))).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDelta_semantics A m m' a).
-    Rewrite (MapDomRestrBy_semantics A A (MapMerge A m m') (MapDomRestrTo A A m m') a).
-    Rewrite (MapDomRestrTo_semantics A A m m' a). Rewrite (MapMerge_semantics A m m' a).
-    Case (MapGet A m a); Case (MapGet A m' a); Trivial.
-  Qed.
-
-  Lemma MapDelta_as_DomRestrBy_2 : (m,m':(Map A)) (eqmap (MapDelta A m m')
-      	(MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m))).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDelta_semantics A m m' a).
-    Rewrite (MapDomRestrBy_semantics A A (MapMerge A m m') (MapDomRestrTo A A m' m) a).
-    Rewrite (MapDomRestrTo_semantics A A m' m a). Rewrite (MapMerge_semantics A m m' a).
-    Case (MapGet A m a); Case (MapGet A m' a); Trivial.
-  Qed.
-
-  Lemma MapDelta_sym : (m,m':(Map A)) (eqmap (MapDelta A m m') (MapDelta A m' m)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDelta_semantics A m m' a).
-    Rewrite (MapDelta_semantics A m' m a). 
-    Case (MapGet A m a); Case (MapGet A m' a); Trivial.
-  Qed.
-
-  Lemma MapDelta_ext : (m1,m2,m'1,m'2:(Map A))
-      (eqmap m1 m'1) -> (eqmap m2 m'2) -> 
-        (eqmap (MapDelta A m1 m2) (MapDelta A m'1 m'2)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite (MapDelta_semantics A m1 m2 a).
-    Rewrite (MapDelta_semantics A m'1 m'2 a). Rewrite (H a). Rewrite (H0 a). Reflexivity.
-  Qed.
-
-  Lemma MapDelta_ext_l : (m1,m'1,m2:(Map A))
-      (eqmap m1 m'1) -> (eqmap (MapDelta A m1 m2) (MapDelta A m'1 m2)).
-  Proof.
-    Intros. Apply MapDelta_ext. Assumption.
-    Apply eqmap_refl.
-  Qed.
-
-  Lemma MapDelta_ext_r : (m1,m2,m'2:(Map A))
-      (eqmap m2 m'2) -> (eqmap (MapDelta A m1 m2) (MapDelta A m1 m'2)).
-  Proof.
-    Intros. Apply MapDelta_ext. Apply eqmap_refl.
-    Assumption.
-  Qed.
-
-  Lemma MapDom_Split_1 : (m:(Map A)) (m':(Map B))
-      (eqmap m (MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m'))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapMerge_semantics A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m') a).
-    Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Case (MapGet B m' a); Case (MapGet A m a); Trivial.
-  Qed.
- 
-  Lemma MapDom_Split_2 : (m:(Map A)) (m':(Map B))
-      (eqmap m (MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m'))).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapMerge_semantics A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m') a).
-    Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Case (MapGet B m' a); Case (MapGet A m a); Trivial.
-  Qed.
-
-  Lemma MapDom_Split_3 : (m:(Map A)) (m':(Map B))
-      (eqmap (MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')) 
-	(M0 A)).
-  Proof.
-    Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrTo_semantics A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m') a).
-    Rewrite (MapDomRestrBy_semantics A B m m' a).
-    Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Case (MapGet B m' a); Case (MapGet A m a); Trivial.
-  Qed.
-
-End MapAxioms.
-
-Lemma MapDomRestrTo_ext : (A,B:Set) 
-    (m1:(Map A)) (m2:(Map B)) (m'1:(Map A)) (m'2:(Map B))
-      (eqmap A m1 m'1) -> (eqmap B m2 m'2) ->
-        (eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m'2)).
-Proof.
-  Unfold eqmap eqm. Intros. Rewrite (MapDomRestrTo_semantics A B m1 m2 a).
-  Rewrite (MapDomRestrTo_semantics A B m'1 m'2 a). Rewrite (H a). Rewrite (H0 a). Reflexivity.
-Qed.
-
-Lemma MapDomRestrTo_ext_l : (A,B:Set) (m1:(Map A)) (m2:(Map B)) (m'1:(Map A))
-    (eqmap A m1 m'1) ->
-      (eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m2)).
-Proof.
-  Intros. Apply MapDomRestrTo_ext; [ Assumption | Apply eqmap_refl ].
-Qed.
-
-Lemma MapDomRestrTo_ext_r : (A,B:Set) (m1:(Map A)) (m2:(Map B)) (m'2:(Map B))
-    (eqmap B m2 m'2) ->
-      (eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m1 m'2)).
-Proof.
-  Intros. Apply MapDomRestrTo_ext; [ Apply eqmap_refl | Assumption ].
-Qed.
-
-Lemma MapDomRestrBy_ext : (A,B:Set) 
-    (m1:(Map A)) (m2:(Map B)) (m'1:(Map A)) (m'2:(Map B))
-      (eqmap A m1 m'1) -> (eqmap B m2 m'2) ->
-        (eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m'2)).
-Proof.
-  Unfold eqmap eqm. Intros. Rewrite (MapDomRestrBy_semantics A B m1 m2 a).
-  Rewrite (MapDomRestrBy_semantics A B m'1 m'2 a). Rewrite (H a). Rewrite (H0 a). Reflexivity.
-Qed.
-
-Lemma MapDomRestrBy_ext_l : (A,B:Set) (m1:(Map A)) (m2:(Map B)) (m'1:(Map A))
-    (eqmap A m1 m'1) ->
-      (eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m2)).
-Proof.
-  Intros. Apply MapDomRestrBy_ext; [ Assumption | Apply eqmap_refl ].
-Qed.
-
-Lemma MapDomRestrBy_ext_r : (A,B:Set) (m1:(Map A)) (m2:(Map B)) (m'2:(Map B))
-    (eqmap B m2 m'2) ->
-      (eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m1 m'2)).
-Proof.
-  Intros. Apply MapDomRestrBy_ext; [ Apply eqmap_refl | Assumption ].
-Qed.
-
-Lemma MapDomRestrBy_m_m : (A:Set) (m:(Map A))
-    (eqmap A (MapDomRestrBy A unit m (MapDom A m)) (M0 A)).
-Proof.
-  Intros. Apply eqmap_trans with m':=(MapDomRestrBy A A m m). Apply eqmap_sym.
-  Apply MapDomRestrBy_Dom.
-  Apply MapDomRestrBy_m_m_1.
-Qed.
-
-Lemma FSetDelta_assoc : (s,s',s'':FSet)
-    (eqmap unit (MapDelta ? (MapDelta ? s s') s'') (MapDelta ? s (MapDelta ? s' s''))).
-Proof.
-  Unfold eqmap eqm. Intros. Rewrite (MapDelta_semantics unit (MapDelta unit s s') s'' a).
-  Rewrite (MapDelta_semantics unit s s' a).
-  Rewrite (MapDelta_semantics unit s (MapDelta unit s' s'') a).
-  Rewrite (MapDelta_semantics unit s' s'' a).
-  Case (MapGet ? s a); Case (MapGet ? s' a); Case (MapGet ? s'' a); Trivial.
-  Intros. Elim u. Elim u1. Reflexivity.
-Qed.
-
-Lemma FSet_ext : (s,s':FSet) ((a:ad) (in_FSet a s)=(in_FSet a s')) -> (eqmap unit s s').
-Proof.
-  Unfold in_FSet eqmap eqm. Intros. Elim (sumbool_of_bool (in_dom ? a s)). Intro H0.
-  Elim (in_dom_some ? s a H0). Intros y H1. Rewrite (H a) in H0. Elim (in_dom_some ? s' a H0).
-  Intros y' H2. Rewrite H1. Rewrite H2. Elim y. Elim y'. Reflexivity.
-  Intro H0. Rewrite (in_dom_none ? s a H0). Rewrite (H a) in H0. Rewrite (in_dom_none ? s' a H0).
-  Reflexivity.
-Qed.
-
-Lemma FSetUnion_comm : (s,s':FSet) (eqmap unit (FSetUnion s s') (FSetUnion s' s)).
-Proof.
-  Intros. Apply FSet_ext. Intro. Rewrite in_FSet_union. Rewrite in_FSet_union. Apply orb_sym.
-Qed.
-
-Lemma FSetUnion_assoc : (s,s',s'':FSet) (eqmap unit
-      (FSetUnion (FSetUnion s s') s'') (FSetUnion s (FSetUnion s' s''))).
-Proof.
-  Exact (MapMerge_assoc unit).
-Qed.
-
-Lemma FSetUnion_M0_s : (s:FSet) (eqmap unit (FSetUnion (M0 unit) s) s).
-Proof.
-  Exact (MapMerge_empty_m unit).
-Qed.
-
-Lemma FSetUnion_s_M0 : (s:FSet) (eqmap unit (FSetUnion s (M0 unit)) s).
-Proof.
-  Exact (MapMerge_m_empty unit).
-Qed.
-
-Lemma FSetUnion_idempotent : (s:FSet) (eqmap unit (FSetUnion s s) s).
-Proof.
-  Exact (MapMerge_idempotent unit).
-Qed.
-
-Lemma FSetInter_comm : (s,s':FSet) (eqmap unit (FSetInter s s') (FSetInter s' s)).
-Proof.
-  Intros. Apply FSet_ext. Intro. Rewrite in_FSet_inter. Rewrite in_FSet_inter. Apply andb_sym.
-Qed.
-
-Lemma FSetInter_assoc : (s,s',s'':FSet) (eqmap unit
-      (FSetInter (FSetInter s s') s'') (FSetInter s (FSetInter s' s''))).
-Proof.
-  Exact (MapDomRestrTo_assoc unit unit unit).
-Qed.
-
-Lemma FSetInter_M0_s : (s:FSet) (eqmap unit (FSetInter (M0 unit) s) (M0 unit)).
-Proof.
-  Exact (MapDomRestrTo_empty_m unit unit).
-Qed.
-
-Lemma FSetInter_s_M0 : (s:FSet) (eqmap unit (FSetInter s (M0 unit)) (M0 unit)).
-Proof.
-  Exact (MapDomRestrTo_m_empty unit unit).
-Qed.
-
-Lemma FSetInter_idempotent : (s:FSet) (eqmap unit (FSetInter s s) s).
-Proof.
-  Exact (MapDomRestrTo_idempotent unit).
-Qed.
-
-Lemma FSetUnion_Inter_l : (s,s',s'':FSet) (eqmap unit
-      (FSetUnion (FSetInter s s') s'') (FSetInter (FSetUnion s s'') (FSetUnion s' s''))).
-Proof.
-  Intros. Apply FSet_ext. Intro. Rewrite in_FSet_union. Rewrite in_FSet_inter.
-  Rewrite in_FSet_inter. Rewrite in_FSet_union. Rewrite in_FSet_union.
-  Case (in_FSet a s); Case (in_FSet a s'); Case (in_FSet a s''); Reflexivity.
-Qed.
-
-Lemma FSetUnion_Inter_r : (s,s',s'':FSet) (eqmap unit
-      (FSetUnion s (FSetInter s' s'')) (FSetInter (FSetUnion s s') (FSetUnion s s''))).
-Proof.
-  Intros. Apply FSet_ext. Intro. Rewrite in_FSet_union. Rewrite in_FSet_inter.
-  Rewrite in_FSet_inter. Rewrite in_FSet_union. Rewrite in_FSet_union.
-  Case (in_FSet a s); Case (in_FSet a s'); Case (in_FSet a s''); Reflexivity.
-Qed.
-
-Lemma FSetInter_Union_l : (s,s',s'':FSet) (eqmap unit
-      (FSetInter (FSetUnion s s') s'') (FSetUnion (FSetInter s s'') (FSetInter s' s''))).
-Proof.
-  Intros. Apply FSet_ext. Intro. Rewrite in_FSet_inter. Rewrite in_FSet_union.
-  Rewrite in_FSet_union. Rewrite in_FSet_inter. Rewrite in_FSet_inter.
-  Case (in_FSet a s); Case (in_FSet a s'); Case (in_FSet a s''); Reflexivity.
-Qed.
-
-Lemma FSetInter_Union_r : (s,s',s'':FSet) (eqmap unit
-      (FSetInter s (FSetUnion s' s'')) (FSetUnion (FSetInter s s') (FSetInter s s''))).
-Proof.
-  Intros. Apply FSet_ext. Intro. Rewrite in_FSet_inter. Rewrite in_FSet_union.
-  Rewrite in_FSet_union. Rewrite in_FSet_inter. Rewrite in_FSet_inter.
-  Case (in_FSet a s); Case (in_FSet a s'); Case (in_FSet a s''); Reflexivity.
-Qed.
diff --git a/theories7/IntMap/Mapc.v b/theories7/IntMap/Mapc.v
deleted file mode 100644
index 181050b1..00000000
--- a/theories7/IntMap/Mapc.v
+++ /dev/null
@@ -1,457 +0,0 @@
-(************************************************************************)
-(*  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: Mapc.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $	 i*)
-
-Require Bool.
-Require Sumbool.
-Require Arith.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require Mapaxioms.
-Require Fset.
-Require Mapiter.
-Require Mapsubset.
-Require PolyList.
-Require Lsort.
-Require Mapcard.
-Require Mapcanon.
-
-Section MapC.
-
-  Variable A, B, C : Set.
-
-  Lemma MapPut_as_Merge_c : (m:(Map A)) (mapcanon A m) ->
-      (a:ad) (y:A) (MapPut A m a y)=(MapMerge A m (M1 A a y)).
-  Proof.
-    Intros. Apply mapcanon_unique. Exact (MapPut_canon A m H a y).
-    Apply MapMerge_canon. Assumption.
-    Apply M1_canon.
-    Apply MapPut_as_Merge.
-  Qed.
-
-  Lemma MapPut_behind_as_Merge_c : (m:(Map A)) (mapcanon A m) ->
-      (a:ad) (y:A) (MapPut_behind A m a y)=(MapMerge A (M1 A a y) m).
-  Proof.
-    Intros. Apply mapcanon_unique. Exact (MapPut_behind_canon A m H a y).
-    Apply MapMerge_canon. Apply M1_canon.
-    Assumption.
-    Apply MapPut_behind_as_Merge.
-  Qed.
-
-  Lemma MapMerge_empty_m_c : (m:(Map A)) (MapMerge A (M0 A) m)=m.
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma MapMerge_assoc_c : (m,m',m'':(Map A))
-      (mapcanon A m) -> (mapcanon A m') -> (mapcanon A m'') ->
-        (MapMerge A (MapMerge A m m') m'')=(MapMerge A m (MapMerge A m' m'')).
-  Proof.
-    Intros. Apply mapcanon_unique.
-    (Apply MapMerge_canon; Try Assumption). (Apply MapMerge_canon; Try Assumption).
-    (Apply MapMerge_canon; Try Assumption). (Apply MapMerge_canon; Try Assumption).
-    Apply MapMerge_assoc.
-  Qed.
-
-  Lemma MapMerge_idempotent_c : (m:(Map A)) (mapcanon A m) -> (MapMerge A m m)=m.
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapMerge_canon; Assumption).
-    Assumption.
-    Apply MapMerge_idempotent.
-  Qed.
-
-  Lemma MapMerge_RestrTo_l_c : (m,m',m'':(Map A)) 
-      (mapcanon A m) -> (mapcanon A m'') -> 
-        (MapMerge A (MapDomRestrTo A A m m') m'')=
-        (MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m'')).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapMerge_canon. Apply MapDomRestrTo_canon; Assumption.
-    Assumption.
-    Apply MapDomRestrTo_canon; Apply MapMerge_canon; Assumption.
-    Apply MapMerge_RestrTo_l.
-  Qed.
-
-  Lemma MapRemove_as_RestrBy_c : (m:(Map A)) (mapcanon A m) ->
-      (a:ad) (y:B) (MapRemove A m a)=(MapDomRestrBy A B m (M1 B a y)).
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapRemove_canon; Assumption).
-    (Apply MapDomRestrBy_canon; Assumption).
-    Apply MapRemove_as_RestrBy.
-  Qed.
-
-  Lemma MapDomRestrTo_assoc_c : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (mapcanon A m) ->
-        (MapDomRestrTo A C (MapDomRestrTo A B m m') m'')=
-        (MapDomRestrTo A B m (MapDomRestrTo B C m' m'')).
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDomRestrTo_canon; Try Assumption).
-    (Apply MapDomRestrTo_canon; Try Assumption).
-    (Apply MapDomRestrTo_canon; Try Assumption).
-    Apply MapDomRestrTo_assoc.
-  Qed.
-
-  Lemma MapDomRestrTo_idempotent_c : (m:(Map A)) (mapcanon A m) -> 
-      (MapDomRestrTo A A m m)=m.
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDomRestrTo_canon; Assumption).
-    Assumption.
-    Apply MapDomRestrTo_idempotent.
-  Qed.
-
-  Lemma MapDomRestrTo_Dom_c : (m:(Map A)) (m':(Map B)) (mapcanon A m) ->
-      (MapDomRestrTo A B m m')=(MapDomRestrTo A unit m (MapDom B m')).
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDomRestrTo_canon; Assumption).
-    (Apply MapDomRestrTo_canon; Assumption).
-    Apply MapDomRestrTo_Dom.
-  Qed.
-
-  Lemma MapDomRestrBy_Dom_c : (m:(Map A)) (m':(Map B)) (mapcanon A m) ->
-      (MapDomRestrBy A B m m')=(MapDomRestrBy A unit m (MapDom B m')).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrBy_canon; Assumption.
-    Apply MapDomRestrBy_canon; Assumption.
-    Apply MapDomRestrBy_Dom.
-  Qed.
-
-  Lemma MapDomRestrBy_By_c : (m:(Map A)) (m':(Map B)) (m'':(Map B)) 
-      (mapcanon A m) -> 
-        (MapDomRestrBy A B (MapDomRestrBy A B m m') m'')=
-        (MapDomRestrBy A B m (MapMerge B m' m'')).
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDomRestrBy_canon; Try Assumption).
-    (Apply MapDomRestrBy_canon; Try Assumption).
-    (Apply MapDomRestrBy_canon; Try Assumption).
-    Apply MapDomRestrBy_By.
-  Qed.
-
-  Lemma MapDomRestrBy_By_comm_c : (m:(Map A)) (m':(Map B)) (m'':(Map C)) 
-      (mapcanon A m) ->
-        (MapDomRestrBy A C (MapDomRestrBy A B m m') m'')=
-        (MapDomRestrBy A B (MapDomRestrBy A C m m'') m').
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrBy_canon.
-    (Apply MapDomRestrBy_canon; Assumption).
-    Apply MapDomRestrBy_canon. (Apply MapDomRestrBy_canon; Assumption).
-    Apply MapDomRestrBy_By_comm.
-  Qed.
-
-  Lemma MapDomRestrBy_To_c : (m:(Map A)) (m':(Map B)) (m'':(Map C)) 
-      (mapcanon A m) ->
-        (MapDomRestrBy A C (MapDomRestrTo A B m m') m'')=
-        (MapDomRestrTo A B m (MapDomRestrBy B C m' m'')).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrBy_canon.
-    (Apply MapDomRestrTo_canon; Assumption).
-    (Apply MapDomRestrTo_canon; Assumption).
-    Apply MapDomRestrBy_To.
-  Qed.
-
-  Lemma MapDomRestrBy_To_comm_c : (m:(Map A)) (m':(Map B)) (m'':(Map C)) 
-      (mapcanon A m) ->
-        (MapDomRestrBy A C (MapDomRestrTo A B m m') m'')=
-        (MapDomRestrTo A B (MapDomRestrBy A C m m'') m').
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrBy_canon.
-    Apply MapDomRestrTo_canon; Assumption.
-    Apply MapDomRestrTo_canon. Apply MapDomRestrBy_canon; Assumption.
-    Apply MapDomRestrBy_To_comm.
-  Qed.
-
-  Lemma MapDomRestrTo_By_c : (m:(Map A)) (m':(Map B)) (m'':(Map C)) 
-      (mapcanon A m) ->
-        (MapDomRestrTo A C (MapDomRestrBy A B m m') m'')=
-        (MapDomRestrTo A C m (MapDomRestrBy C B m'' m')).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrTo_canon.
-    Apply MapDomRestrBy_canon; Assumption.
-    Apply MapDomRestrTo_canon; Assumption.
-    Apply MapDomRestrTo_By.
-  Qed.
-
-  Lemma MapDomRestrTo_By_comm_c : (m:(Map A)) (m':(Map B)) (m'':(Map C)) 
-      (mapcanon A m) ->
-        (MapDomRestrTo A C (MapDomRestrBy A B m m') m'')=
-        (MapDomRestrBy A B (MapDomRestrTo A C m m'') m').
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrTo_canon.
-    (Apply MapDomRestrBy_canon; Assumption).
-    Apply MapDomRestrBy_canon. (Apply MapDomRestrTo_canon; Assumption).
-    Apply MapDomRestrTo_By_comm.
-  Qed.
-
-  Lemma MapDomRestrTo_To_comm_c : (m:(Map A)) (m':(Map B)) (m'':(Map C)) 
-      (mapcanon A m) ->
-        (MapDomRestrTo A C (MapDomRestrTo A B m m') m'')=
-        (MapDomRestrTo A B (MapDomRestrTo A C m m'') m').
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrTo_canon.
-    Apply MapDomRestrTo_canon; Assumption.
-    Apply MapDomRestrTo_canon. Apply MapDomRestrTo_canon; Assumption.
-    Apply MapDomRestrTo_To_comm.
-  Qed.
-
-  Lemma MapMerge_DomRestrTo_c : (m,m':(Map A)) (m'':(Map B))
-      (mapcanon A m) -> (mapcanon A m') ->
-        (MapDomRestrTo A B (MapMerge A m m') m'')=
-        (MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m'')).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrTo_canon.
-    (Apply MapMerge_canon; Assumption).
-    Apply MapMerge_canon. (Apply MapDomRestrTo_canon; Assumption).
-    (Apply MapDomRestrTo_canon; Assumption).
-    Apply MapMerge_DomRestrTo.
-  Qed.
-
-  Lemma MapMerge_DomRestrBy_c : (m,m':(Map A)) (m'':(Map B))
-      (mapcanon A m) -> (mapcanon A m') ->
-        (MapDomRestrBy A B (MapMerge A m m') m'')=
-        (MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m'')).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrBy_canon. Apply MapMerge_canon; Assumption.
-    Apply MapMerge_canon. Apply MapDomRestrBy_canon; Assumption.
-    Apply MapDomRestrBy_canon; Assumption.
-    Apply MapMerge_DomRestrBy.
-  Qed.
-
-  Lemma MapDelta_nilpotent_c : (m:(Map A)) (mapcanon A m) -> 
-      (MapDelta A m m)=(M0 A).
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDelta_canon; Assumption).
-    Apply M0_canon.
-    Apply MapDelta_nilpotent.
-  Qed.
-
-  Lemma MapDelta_as_Merge_c : (m,m':(Map A))
-      (mapcanon A m) -> (mapcanon A m') ->
-        (MapDelta A m m')=
-	(MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m)).
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDelta_canon; Assumption).
-    (Apply MapMerge_canon; Apply MapDomRestrBy_canon; Assumption).
-    Apply MapDelta_as_Merge.
-  Qed.
-
-  Lemma MapDelta_as_DomRestrBy_c : (m,m':(Map A))
-      (mapcanon A m) -> (mapcanon A m') ->
-        (MapDelta A m m')=
-	(MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDelta_canon; Assumption.
-    Apply MapDomRestrBy_canon. (Apply MapMerge_canon; Assumption).
-    Apply MapDelta_as_DomRestrBy.
-  Qed.
-
-  Lemma MapDelta_as_DomRestrBy_2_c : (m,m':(Map A))
-      (mapcanon A m) -> (mapcanon A m') ->
-        (MapDelta A m m')=
-	(MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m)).
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDelta_canon; Assumption).
-    Apply MapDomRestrBy_canon. Apply MapMerge_canon; Assumption.
-    Apply MapDelta_as_DomRestrBy_2.
-  Qed.
-
-  Lemma MapDelta_sym_c : (m,m':(Map A))
-      (mapcanon A m) -> (mapcanon A m') -> (MapDelta A m m')=(MapDelta A m' m).
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDelta_canon; Assumption).
-    (Apply MapDelta_canon; Assumption). Apply MapDelta_sym.
-  Qed.
-
-  Lemma MapDom_Split_1_c : (m:(Map A)) (m':(Map B)) (mapcanon A m) ->
-      m=(MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')).
-  Proof.
-    Intros. Apply mapcanon_unique. Assumption.
-    Apply MapMerge_canon. Apply MapDomRestrTo_canon; Assumption.
-    Apply MapDomRestrBy_canon; Assumption.
-    Apply MapDom_Split_1.
-  Qed.
-
-  Lemma MapDom_Split_2_c : (m:(Map A)) (m':(Map B)) (mapcanon A m) ->
-      m=(MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m')).
-  Proof.
-    Intros. Apply mapcanon_unique. Assumption.
-    Apply MapMerge_canon. (Apply MapDomRestrBy_canon; Assumption).
-    (Apply MapDomRestrTo_canon; Assumption).
-    Apply MapDom_Split_2.
-  Qed.
-
-  Lemma MapDom_Split_3_c : (m:(Map A)) (m':(Map B)) (mapcanon A m) ->
-      (MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m'))=
-      (M0 A).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrTo_canon.
-    Apply MapDomRestrTo_canon; Assumption.
-    Apply M0_canon.
-    Apply MapDom_Split_3.
-  Qed.
-
-  Lemma Map_of_alist_of_Map_c : (m:(Map A)) (mapcanon A m) ->
-      (Map_of_alist A (alist_of_Map A m))=m.
-  Proof.
-    Intros. (Apply mapcanon_unique; Try Assumption). Apply Map_of_alist_canon.
-    Apply Map_of_alist_of_Map.
-  Qed.
-
-  Lemma alist_of_Map_of_alist_c : (l:(alist A)) (alist_sorted_2 A l) ->
-      (alist_of_Map A (Map_of_alist A l))=l.
-  Proof.
-    Intros. Apply alist_canonical. Apply alist_of_Map_of_alist.
-    Apply alist_of_Map_sorts2.
-    Assumption.
-  Qed.
-
-  Lemma MapSubset_antisym_c : (m:(Map A)) (m':(Map B))
-      (mapcanon A m) -> (mapcanon B m') ->
-      (MapSubset A B m m') -> (MapSubset B A m' m) -> (MapDom A m)=(MapDom B m').
-  Proof.
-    Intros. Apply (mapcanon_unique unit). (Apply MapDom_canon; Assumption).
-    (Apply MapDom_canon; Assumption).
-    (Apply MapSubset_antisym; Assumption).
-  Qed.
-
-  Lemma FSubset_antisym_c : (s,s':FSet) (mapcanon unit s) -> (mapcanon unit s') ->
-      (MapSubset ? ? s s') -> (MapSubset ? ? s' s) -> s=s'.
-  Proof.
-    Intros. Apply (mapcanon_unique unit); Try Assumption. Apply FSubset_antisym; Assumption.
-  Qed.
-
-  Lemma MapDisjoint_empty_c : (m:(Map A)) (mapcanon A m) ->
-      (MapDisjoint A A m m) -> m=(M0 A).
-  Proof.
-    Intros. Apply mapcanon_unique; Try Assumption; Try Apply M0_canon.
-    Apply MapDisjoint_empty; Assumption.
-  Qed.
-
-  Lemma MapDelta_disjoint_c : (m,m':(Map A)) (mapcanon A m) -> (mapcanon A m') ->
-      (MapDisjoint A A m m') -> (MapDelta A m m')=(MapMerge A m m').
-  Proof.
-    Intros. Apply mapcanon_unique. (Apply MapDelta_canon; Assumption).
-    (Apply MapMerge_canon; Assumption). Apply MapDelta_disjoint; Assumption.
-  Qed.
-
-End MapC.
-
-Lemma FSetDelta_assoc_c : (s,s',s'':FSet)
-    (mapcanon unit s) -> (mapcanon unit s') -> (mapcanon unit s'') ->
-      (MapDelta ? (MapDelta ? s s') s'')=(MapDelta ? s (MapDelta ? s' s'')).
-Proof.
-  Intros. Apply (mapcanon_unique unit). Apply MapDelta_canon. (Apply MapDelta_canon; Assumption).
-  Assumption.
-  Apply MapDelta_canon. Assumption.
-  (Apply MapDelta_canon; Assumption).
-  Apply FSetDelta_assoc; Assumption.
-Qed.
-
-Lemma FSet_ext_c : (s,s':FSet) (mapcanon unit s) -> (mapcanon unit s') ->
-      ((a:ad) (in_FSet a s)=(in_FSet a s')) -> s=s'.
-Proof.
-  Intros. (Apply (mapcanon_unique unit); Try Assumption). Apply FSet_ext. Assumption.
-Qed.
-
-Lemma FSetUnion_comm_c : (s,s':FSet) (mapcanon unit s) -> (mapcanon unit s') ->
-      (FSetUnion s s')=(FSetUnion s' s).
-Proof.
-  Intros.
-  Apply (mapcanon_unique unit); Try (Unfold FSetUnion; Apply MapMerge_canon; Assumption).
-  Apply FSetUnion_comm.
-Qed.
-
-Lemma FSetUnion_assoc_c : (s,s',s'':FSet)
-      (mapcanon unit s) -> (mapcanon unit s') -> (mapcanon unit s'') ->
-        (FSetUnion (FSetUnion s s') s'')=(FSetUnion s (FSetUnion s' s'')).
-Proof.
-  Exact (MapMerge_assoc_c unit).
-Qed.
-
-Lemma FSetUnion_M0_s_c : (s:FSet) (FSetUnion (M0 unit) s)=s.
-Proof.
-  Exact (MapMerge_empty_m_c unit).
-Qed.
-
-Lemma FSetUnion_s_M0_c : (s:FSet) (FSetUnion s (M0 unit))=s.
-Proof.
-  Exact (MapMerge_m_empty_1 unit).
-Qed.
-
-Lemma FSetUnion_idempotent : (s:FSet) (mapcanon unit s) -> (FSetUnion s s)=s.
-Proof.
-  Exact (MapMerge_idempotent_c unit).
-Qed.
-
-Lemma FSetInter_comm_c : (s,s':FSet) (mapcanon unit s) -> (mapcanon unit s') ->
-      (FSetInter s s')=(FSetInter s' s).
-Proof.
-  Intros.
-  Apply (mapcanon_unique unit); Try (Unfold FSetInter; Apply MapDomRestrTo_canon; Assumption).
-  Apply FSetInter_comm.
-Qed.
-
-Lemma FSetInter_assoc_c : (s,s',s'':FSet)
-      (mapcanon unit s) ->
-        (FSetInter (FSetInter s s') s'')=(FSetInter s (FSetInter s' s'')).
-Proof.
-  Exact (MapDomRestrTo_assoc_c unit unit unit).
-Qed.
-
-Lemma FSetInter_M0_s_c : (s:FSet) (FSetInter (M0 unit) s)=(M0 unit).
-Proof.
-  Trivial.
-Qed.
-
-Lemma FSetInter_s_M0_c : (s:FSet) (FSetInter s (M0 unit))=(M0 unit).
-Proof.
-  Exact (MapDomRestrTo_m_empty_1 unit unit).
-Qed.
-
-Lemma FSetInter_idempotent : (s:FSet) (mapcanon unit s) -> (FSetInter s s)=s.
-Proof.
-  Exact (MapDomRestrTo_idempotent_c unit).
-Qed.
-
-Lemma FSetUnion_Inter_l_c : (s,s',s'':FSet) (mapcanon unit s) -> (mapcanon unit s'') ->
-      (FSetUnion (FSetInter s s') s'')=(FSetInter (FSetUnion s s'') (FSetUnion s' s'')).
-Proof.
-  Intros. Apply (mapcanon_unique unit). Unfold FSetUnion. (Apply MapMerge_canon; Try Assumption).
-  Unfold FSetInter. (Apply MapDomRestrTo_canon; Assumption).
-  Unfold FSetInter; Unfold FSetUnion; Apply MapDomRestrTo_canon; Apply MapMerge_canon; Assumption.
-  Apply FSetUnion_Inter_l.
-Qed.
-
-Lemma FSetUnion_Inter_r : (s,s',s'':FSet) (mapcanon unit s) -> (mapcanon unit s') ->
-      (FSetUnion s (FSetInter s' s''))=(FSetInter (FSetUnion s s') (FSetUnion s s'')).
-Proof.
-  Intros. Apply (mapcanon_unique unit). Unfold FSetUnion. (Apply MapMerge_canon; Try Assumption).
-  Unfold FSetInter. (Apply MapDomRestrTo_canon; Assumption).
-  Unfold FSetInter; Unfold FSetUnion; Apply MapDomRestrTo_canon; Apply MapMerge_canon; Assumption.
-  Apply FSetUnion_Inter_r.
-Qed.
-
-Lemma FSetInter_Union_l_c : (s,s',s'':FSet) (mapcanon unit s) -> (mapcanon unit s') ->
-      (FSetInter (FSetUnion s s') s'')=(FSetUnion (FSetInter s s'') (FSetInter s' s'')).
-Proof.
-  Intros. Apply (mapcanon_unique unit). Unfold FSetInter.
-  Apply MapDomRestrTo_canon; Try Assumption. Unfold FSetUnion.
-  Apply MapMerge_canon; Assumption.
-  Unfold FSetUnion; Unfold FSetInter; Apply MapMerge_canon; Apply MapDomRestrTo_canon;
-  Assumption.
-  Apply FSetInter_Union_l.
-Qed.
-
-Lemma FSetInter_Union_r : (s,s',s'':FSet) (mapcanon unit s) -> (mapcanon unit s') ->
-      (FSetInter s (FSetUnion s' s''))=(FSetUnion (FSetInter s s') (FSetInter s s'')).
-Proof.
-  Intros. Apply (mapcanon_unique unit). Unfold FSetInter.
-  Apply MapDomRestrTo_canon; Try Assumption.
-  Unfold FSetUnion. Apply MapMerge_canon; Unfold FSetInter; Apply MapDomRestrTo_canon; Assumption.
-  Apply FSetInter_Union_r.
-Qed.
diff --git a/theories7/IntMap/Mapcanon.v b/theories7/IntMap/Mapcanon.v
deleted file mode 100644
index 7beb1fd4..00000000
--- a/theories7/IntMap/Mapcanon.v
+++ /dev/null
@@ -1,376 +0,0 @@
-(************************************************************************)
-(*  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: Mapcanon.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $	 i*)
-
-Require Bool.
-Require Sumbool.
-Require Arith.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require Mapaxioms.
-Require Mapiter.
-Require Fset.
-Require PolyList.
-Require Lsort.
-Require Mapsubset.
-Require Mapcard.
-
-Section MapCanon.
-
-  Variable A : Set.
-
-  Inductive mapcanon : (Map A) -> Prop :=
-      M0_canon : (mapcanon (M0 A))
-    | M1_canon : (a:ad) (y:A) (mapcanon (M1 A a y))
-    | M2_canon : (m1,m2:(Map A)) (mapcanon m1) -> (mapcanon m2) ->
-        (le (2) (MapCard A (M2 A m1 m2))) -> (mapcanon (M2 A m1 m2)).
-
-  Lemma mapcanon_M2 : 
-      (m1,m2:(Map A)) (mapcanon (M2 A m1 m2)) -> (le (2) (MapCard A (M2 A m1 m2))).
-  Proof.
-    Intros. Inversion H. Assumption.
-  Qed.
-
-  Lemma mapcanon_M2_1 : (m1,m2:(Map A)) (mapcanon (M2 A m1 m2)) -> (mapcanon m1).
-  Proof.
-    Intros. Inversion H. Assumption.
-  Qed.
-
-  Lemma mapcanon_M2_2 : (m1,m2:(Map A)) (mapcanon (M2 A m1 m2)) -> (mapcanon m2).
-  Proof.
-    Intros. Inversion H. Assumption.
-  Qed.
-
-  Lemma M2_eqmap_1 : (m0,m1,m2,m3:(Map A)) 
-      (eqmap A (M2 A m0 m1) (M2 A m2 m3)) -> (eqmap A m0 m2).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite <- (ad_double_div_2 a).
-    Rewrite <- (MapGet_M2_bit_0_0 A ? (ad_double_bit_0 a) m0 m1).
-    Rewrite <- (MapGet_M2_bit_0_0 A ? (ad_double_bit_0 a) m2 m3).
-    Exact (H (ad_double a)).
-  Qed.
-
-  Lemma M2_eqmap_2 : (m0,m1,m2,m3:(Map A)) 
-      (eqmap A (M2 A m0 m1) (M2 A m2 m3)) -> (eqmap A m1 m3).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite <- (ad_double_plus_un_div_2 a).
-    Rewrite <- (MapGet_M2_bit_0_1 A ? (ad_double_plus_un_bit_0 a) m0 m1).
-    Rewrite <- (MapGet_M2_bit_0_1 A ? (ad_double_plus_un_bit_0 a) m2 m3).
-    Exact (H (ad_double_plus_un a)).
-  Qed.
-
-  Lemma mapcanon_unique : (m,m':(Map A)) (mapcanon m) -> (mapcanon m') ->
-      (eqmap A m m') -> m=m'.
-  Proof.
-    Induction m. Induction m'. Trivial.
-    Intros a y H H0 H1. Cut (NONE A)=(MapGet A (M1 A a y) a). Simpl. Rewrite (ad_eq_correct a).
-    Intro. Discriminate H2.
-    Exact (H1 a).
-    Intros. Cut (le (2) (MapCard A (M0 A))). Intro. Elim (le_Sn_O ? H4).
-    Rewrite (MapCard_ext A ? ? H3). Exact (mapcanon_M2 ? ? H2).
-    Intros a y. Induction m'. Intros. Cut (MapGet A (M1 A a y) a)=(NONE A). Simpl.
-    Rewrite (ad_eq_correct a). Intro. Discriminate H2.
-    Exact (H1 a).
-    Intros a0 y0 H H0 H1. Cut (MapGet A (M1 A a y) a)=(MapGet A (M1 A a0 y0) a). Simpl.
-    Rewrite (ad_eq_correct a). Intro. Elim (sumbool_of_bool (ad_eq a0 a)). Intro H3.
-    Rewrite H3 in H2. Inversion H2. Rewrite (ad_eq_complete ? ? H3). Reflexivity.
-    Intro H3. Rewrite H3 in H2. Discriminate H2.
-    Exact (H1 a).
-    Intros. Cut (le (2) (MapCard A (M1 A a y))). Intro. Elim (le_Sn_O ? (le_S_n ? ? H4)).
-    Rewrite (MapCard_ext A ? ? H3). Exact (mapcanon_M2 ? ? H2).
-    Induction m'. Intros. Cut (le (2) (MapCard A (M0 A))). Intro. Elim (le_Sn_O ? H4).
-    Rewrite <- (MapCard_ext A ? ? H3). Exact (mapcanon_M2 ? ? H1).
-    Intros a y H1 H2 H3. Cut (le (2) (MapCard A (M1 A a y))). Intro.
-    Elim (le_Sn_O ? (le_S_n ? ? H4)).
-    Rewrite <- (MapCard_ext A ? ? H3). Exact (mapcanon_M2 ? ? H1).
-    Intros. Rewrite (H m2). Rewrite (H0 m3). Reflexivity.
-    Exact (mapcanon_M2_2 ? ? H3).
-    Exact (mapcanon_M2_2 ? ? H4).
-    Exact (M2_eqmap_2 ? ? ? ? H5).
-    Exact (mapcanon_M2_1 ? ? H3).
-    Exact (mapcanon_M2_1 ? ? H4).
-    Exact (M2_eqmap_1 ? ? ? ? H5).
-  Qed.
-
-  Lemma MapPut1_canon : 
-      (p:positive) (a,a':ad) (y,y':A) (mapcanon (MapPut1 A a y a' y' p)).
-  Proof.
-    Induction p. Simpl. Intros. Case (ad_bit_0 a). Apply M2_canon. Apply M1_canon.
-    Apply M1_canon.
-    Apply le_n.
-    Apply M2_canon. Apply M1_canon.
-    Apply M1_canon.
-    Apply le_n.
-    Simpl. Intros. Case (ad_bit_0 a). Apply M2_canon. Apply M0_canon.
-    Apply H.
-    Simpl. Rewrite MapCard_Put1_equals_2. Apply le_n.
-    Apply M2_canon. Apply H.
-    Apply M0_canon.
-    Simpl. Rewrite MapCard_Put1_equals_2. Apply le_n.
-    Simpl. Simpl. Intros. Case (ad_bit_0 a). Apply M2_canon. Apply M1_canon.
-    Apply M1_canon.
-    Simpl. Apply le_n.
-    Apply M2_canon. Apply M1_canon.
-    Apply M1_canon.
-    Simpl. Apply le_n.
-  Qed.
-
-  Lemma MapPut_canon : 
-      (m:(Map A)) (mapcanon m) -> (a:ad) (y:A) (mapcanon (MapPut A m a y)).
-  Proof.
-    Induction m. Intros. Simpl. Apply M1_canon.
-    Intros a0 y0 H a y. Simpl. Case (ad_xor a0 a). Apply M1_canon.
-    Intro. Apply MapPut1_canon.
-    Intros. Simpl. Elim a. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 m0 m1 H1).
-    Exact (mapcanon_M2_2 m0 m1 H1).
-    Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). Exact (mapcanon_M2 ? ? H1).
-    Apply le_plus_plus. Exact (MapCard_Put_lb A m0 ad_z y).
-    Apply le_n.
-    Intro. Case p. Intro. Apply M2_canon. Exact (mapcanon_M2_1 m0 m1 H1).
-    Apply H0. Exact (mapcanon_M2_2 m0 m1 H1).
-    Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)).
-    Exact (mapcanon_M2 m0 m1 H1).
-    Apply le_reg_l. Exact (MapCard_Put_lb A m1 (ad_x p0) y).
-    Intro. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 m0 m1 H1).
-    Exact (mapcanon_M2_2 m0 m1 H1).
-    Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)).
-    Exact (mapcanon_M2 m0 m1 H1).
-    Apply le_reg_r. Exact (MapCard_Put_lb A m0 (ad_x p0) y).
-    Apply M2_canon. Apply (mapcanon_M2_1 m0 m1 H1).
-    Apply H0. Apply (mapcanon_M2_2 m0 m1 H1).
-    Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)).
-    Exact (mapcanon_M2 m0 m1 H1).
-    Apply le_reg_l. Exact (MapCard_Put_lb A m1 ad_z y).
-  Qed.
-
-  Lemma MapPut_behind_canon : (m:(Map A)) (mapcanon m) ->
-      (a:ad) (y:A) (mapcanon (MapPut_behind A m a y)).
-  Proof.
-    Induction m. Intros. Simpl. Apply M1_canon.
-    Intros a0 y0 H a y. Simpl. Case (ad_xor a0 a). Apply M1_canon.
-    Intro. Apply MapPut1_canon.
-    Intros. Simpl. Elim a. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 m0 m1 H1).
-    Exact (mapcanon_M2_2 m0 m1 H1).
-    Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). Exact (mapcanon_M2 ? ? H1).
-    Apply le_plus_plus. Rewrite MapCard_Put_behind_Put. Exact (MapCard_Put_lb A m0 ad_z y).
-    Apply le_n.
-    Intro. Case p. Intro. Apply M2_canon. Exact (mapcanon_M2_1 m0 m1 H1).
-    Apply H0. Exact (mapcanon_M2_2 m0 m1 H1).
-    Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)).
-    Exact (mapcanon_M2 m0 m1 H1).
-    Apply le_reg_l. Rewrite MapCard_Put_behind_Put. Exact (MapCard_Put_lb A m1 (ad_x p0) y).
-    Intro. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 m0 m1 H1).
-    Exact (mapcanon_M2_2 m0 m1 H1).
-    Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)).
-    Exact (mapcanon_M2 m0 m1 H1).
-    Apply le_reg_r. Rewrite MapCard_Put_behind_Put. Exact (MapCard_Put_lb A m0 (ad_x p0) y).
-    Apply M2_canon. Apply (mapcanon_M2_1 m0 m1 H1).
-    Apply H0. Apply (mapcanon_M2_2 m0 m1 H1).
-    Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)).
-    Exact (mapcanon_M2 m0 m1 H1).
-    Apply le_reg_l. Rewrite MapCard_Put_behind_Put. Exact (MapCard_Put_lb A m1 ad_z y).
-  Qed.
-
-  Lemma makeM2_canon : 
-      (m,m':(Map A)) (mapcanon m) -> (mapcanon m') -> (mapcanon (makeM2 A m m')).
-  Proof.
-    Intro. Case m. Intro. Case m'. Intros. Exact M0_canon.
-    Intros a y H H0. Exact (M1_canon (ad_double_plus_un a) y).
-    Intros. Simpl. (Apply M2_canon; Try Assumption). Exact (mapcanon_M2 m0 m1 H0).
-    Intros a y m'. Case m'. Intros. Exact (M1_canon (ad_double a) y).
-    Intros a0 y0 H H0. Simpl. (Apply M2_canon; Try Assumption). Apply le_n.
-    Intros. Simpl. (Apply M2_canon; Try Assumption).
-    Apply le_trans with m:=(MapCard A (M2 A m0 m1)). Exact (mapcanon_M2 ? ? H0).
-    Exact (le_plus_r (MapCard A (M1 A a y)) (MapCard A (M2 A m0 m1))).
-    Simpl. Intros. (Apply M2_canon; Try Assumption).
-    Apply le_trans with m:=(MapCard A (M2 A m0 m1)). Exact (mapcanon_M2 ? ? H).
-    Exact (le_plus_l (MapCard A (M2 A m0 m1)) (MapCard A m')).
-  Qed.
-
-  Fixpoint MapCanonicalize [m:(Map A)] : (Map A) :=
-      Cases m of
-          (M2 m0 m1) => (makeM2 A (MapCanonicalize m0) (MapCanonicalize m1))
-	| _ => m
-      end.
-
-  Lemma mapcanon_exists_1 : (m:(Map A)) (eqmap A m (MapCanonicalize m)).
-  Proof.
-    Induction m. Apply eqmap_refl.
-    Intros. Apply eqmap_refl.
-    Intros. Simpl. Unfold eqmap eqm. Intro.
-    Rewrite (makeM2_M2 A (MapCanonicalize m0) (MapCanonicalize m1) a).
-    Rewrite MapGet_M2_bit_0_if. Rewrite MapGet_M2_bit_0_if.
-    Rewrite <- (H (ad_div_2 a)). Rewrite <- (H0 (ad_div_2 a)). Reflexivity.
-  Qed.
-
-  Lemma mapcanon_exists_2 : (m:(Map A)) (mapcanon (MapCanonicalize m)).
-  Proof.
-    Induction m. Apply M0_canon.
-    Intros. Simpl. Apply M1_canon.
-    Intros. Simpl. (Apply makeM2_canon; Assumption).
-  Qed.
-
-  Lemma mapcanon_exists : 
-      (m:(Map A)) {m':(Map A) | (eqmap A m m') /\ (mapcanon m')}.
-  Proof.
-    Intro. Split with (MapCanonicalize m). Split. Apply mapcanon_exists_1.
-    Apply mapcanon_exists_2.
-  Qed.
-
-  Lemma MapRemove_canon : 
-      (m:(Map A)) (mapcanon m) -> (a:ad) (mapcanon (MapRemove A m a)).
-  Proof.
-    Induction m. Intros. Exact M0_canon.
-    Intros a y H a0. Simpl. Case (ad_eq a a0). Exact M0_canon.
-    Assumption.
-    Intros. Simpl. Case (ad_bit_0 a). Apply makeM2_canon. Exact (mapcanon_M2_1 ? ? H1).
-    Apply H0. Exact (mapcanon_M2_2 ? ? H1).
-    Apply makeM2_canon. Apply H. Exact (mapcanon_M2_1 ? ? H1).
-    Exact (mapcanon_M2_2 ? ? H1).
-  Qed.
-
-  Lemma MapMerge_canon : (m,m':(Map A)) (mapcanon m) -> (mapcanon m') ->
-      (mapcanon (MapMerge A m m')).
-  Proof.
-    Induction m. Intros. Exact H0.
-    Simpl. Intros a y m' H H0. Exact (MapPut_behind_canon m' H0 a y).
-    Induction m'. Intros. Exact H1.
-    Intros a y H1 H2. Unfold MapMerge. Exact (MapPut_canon ? H1 a y).
-    Intros. Simpl. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 ? ? H3).
-    Exact (mapcanon_M2_1 ? ? H4).
-    Apply H0. Exact (mapcanon_M2_2 ? ? H3).
-    Exact (mapcanon_M2_2 ? ? H4).
-    Change (le (2) (MapCard A (MapMerge A (M2 A m0 m1) (M2 A m2 m3)))).
-    Apply le_trans with m:=(MapCard A (M2 A m0 m1)). Exact (mapcanon_M2 ? ? H3).
-    Exact (MapMerge_Card_lb_l A (M2 A m0 m1) (M2 A m2 m3)).
-  Qed.
-
-  Lemma MapDelta_canon : (m,m':(Map A)) (mapcanon m) -> (mapcanon m') ->
-      (mapcanon (MapDelta A m m')).
-  Proof.
-    Induction m. Intros. Exact H0.
-    Simpl. Intros a y m' H H0. Case (MapGet A m' a). Exact (MapPut_canon m' H0 a y).
-    Intro. Exact (MapRemove_canon m' H0 a).
-    Induction m'. Intros. Exact H1.
-    Unfold MapDelta. Intros a y H1 H2. Case (MapGet A (M2 A m0 m1) a).
-    Exact (MapPut_canon ? H1 a y).
-    Intro. Exact (MapRemove_canon ? H1 a).
-    Intros. Simpl. Apply makeM2_canon. Apply H. Exact (mapcanon_M2_1 ? ? H3).
-    Exact (mapcanon_M2_1 ? ? H4).
-    Apply H0. Exact (mapcanon_M2_2 ? ? H3).
-    Exact (mapcanon_M2_2 ? ? H4).
-  Qed.
-
-  Variable B : Set.
-
-  Lemma MapDomRestrTo_canon : (m:(Map A)) (mapcanon m) ->
-      (m':(Map B)) (mapcanon (MapDomRestrTo A B m m')).
-  Proof.
-    Induction m. Intros. Exact M0_canon.
-    Simpl. Intros a y H m'. Case (MapGet B m' a). Exact M0_canon.
-    Intro. Apply M1_canon.
-    Induction m'. Exact M0_canon.
-    Unfold MapDomRestrTo. Intros a y. Case (MapGet A (M2 A m0 m1) a). Exact M0_canon.
-    Intro. Apply M1_canon.
-    Intros. Simpl. Apply makeM2_canon. Apply H. Exact (mapcanon_M2_1 m0 m1 H1).
-    Apply H0. Exact (mapcanon_M2_2 m0 m1 H1).
-  Qed.
-
-  Lemma MapDomRestrBy_canon : (m:(Map A)) (mapcanon m) ->
-      (m':(Map B)) (mapcanon (MapDomRestrBy A B m m')).
-  Proof.
-    Induction m. Intros. Exact M0_canon.
-    Simpl. Intros a y H m'. Case (MapGet B m' a). Assumption.
-    Intro. Exact M0_canon.
-    Induction m'. Exact H1.
-    Intros a y. Simpl. Case (ad_bit_0 a). Apply makeM2_canon. Exact (mapcanon_M2_1 ? ? H1).
-    Apply MapRemove_canon. Exact (mapcanon_M2_2 ? ? H1).
-    Apply makeM2_canon. Apply MapRemove_canon. Exact (mapcanon_M2_1 ? ? H1).
-    Exact (mapcanon_M2_2 ? ? H1).
-    Intros. Simpl. Apply makeM2_canon. Apply H. Exact (mapcanon_M2_1 ? ? H1).
-    Apply H0. Exact (mapcanon_M2_2 ? ? H1).
-  Qed.
-
-  Lemma Map_of_alist_canon : (l:(alist A)) (mapcanon (Map_of_alist A l)).
-  Proof.
-    Induction l. Exact M0_canon.
-    Intro r. Elim r. Intros a y l0 H. Simpl. Apply MapPut_canon. Assumption.
-  Qed.
-
-  Lemma MapSubset_c_1 : (m:(Map A)) (m':(Map B)) (mapcanon m) ->
-      (MapSubset A B m m') -> (MapDomRestrBy A B m m')=(M0 A).
-  Proof.
-    Intros. Apply mapcanon_unique. Apply MapDomRestrBy_canon. Assumption.
-    Apply M0_canon.
-    Exact (MapSubset_imp_2 ? ? m m' H0).
-  Qed.
-
-  Lemma MapSubset_c_2 : (m:(Map A)) (m':(Map B))
-      (MapDomRestrBy A B m m')=(M0 A) -> (MapSubset A B m m').
-  Proof.
-    Intros. Apply MapSubset_2_imp. Unfold MapSubset_2. Rewrite H. Apply eqmap_refl.
-  Qed.
-
-End MapCanon.
-
-Section FSetCanon.
-
-  Variable A : Set.
-
-  Lemma MapDom_canon : (m:(Map A)) (mapcanon A m) -> (mapcanon unit (MapDom A m)).
-  Proof.
-    Induction m. Intro. Exact (M0_canon unit).
-    Intros a y H. Exact (M1_canon unit a ?).
-    Intros. Simpl. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 A ? ? H1).
-    Apply H0. Exact (mapcanon_M2_2 A ? ? H1).
-    Change (le (2) (MapCard unit (MapDom A (M2 A m0 m1)))). Rewrite <- MapCard_Dom.
-    Exact (mapcanon_M2 A ? ? H1).
-  Qed.
-
-End FSetCanon.
-
-Section MapFoldCanon.
-
-  Variable A, B : Set.
-
-  Lemma MapFold_canon_1 : (m0:(Map B)) (mapcanon B m0) ->
-      (op : (Map B) -> (Map B) -> (Map B))
-      	((m1:(Map B)) (mapcanon B m1) -> (m2:(Map B)) (mapcanon B m2) ->
-	  (mapcanon B (op m1 m2))) ->
-      (f : ad->A->(Map B)) ((a:ad) (y:A) (mapcanon B (f a y))) ->
-	(m:(Map A)) (pf : ad->ad) (mapcanon B (MapFold1 A (Map B) m0 op f pf m)).
-  Proof.
-    Induction m. Intro. Exact H.
-    Intros a y pf. Simpl. Apply H1.
-    Intros. Simpl. Apply H0. Apply H2.
-    Apply H3.
-  Qed.
-
-  Lemma MapFold_canon : (m0:(Map B)) (mapcanon B m0) ->
-      (op : (Map B) -> (Map B) -> (Map B))
-      	((m1:(Map B)) (mapcanon B m1) -> (m2:(Map B)) (mapcanon B m2) ->
-	  (mapcanon B (op m1 m2))) ->
-      (f : ad->A->(Map B)) ((a:ad) (y:A) (mapcanon B (f a y))) ->
-	(m:(Map A)) (mapcanon B (MapFold A (Map B) m0 op f m)).
-  Proof.
-    Intros. Exact (MapFold_canon_1 m0 H op H0 f H1 m [a:ad]a).
-  Qed.
-
-  Lemma MapCollect_canon : 
-      (f : ad->A->(Map B)) ((a:ad) (y:A) (mapcanon B (f a y))) ->
-	(m:(Map A)) (mapcanon B (MapCollect A B f m)).
-  Proof.
-    Intros. Rewrite MapCollect_as_Fold. Apply MapFold_canon. Apply M0_canon.
-    Intros. Exact (MapMerge_canon B m1 m2 H0 H1).
-    Assumption.
-  Qed.
-
-End MapFoldCanon.
diff --git a/theories7/IntMap/Mapcard.v b/theories7/IntMap/Mapcard.v
deleted file mode 100644
index 5c5e2a93..00000000
--- a/theories7/IntMap/Mapcard.v
+++ /dev/null
@@ -1,670 +0,0 @@
-(************************************************************************)
-(*  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: Mapcard.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $	 i*)
-
-Require Bool.
-Require Sumbool.
-Require Arith.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require Mapaxioms.
-Require Mapiter.
-Require Fset.
-Require Mapsubset.
-Require PolyList.
-Require Lsort.
-Require Peano_dec.
-
-Section MapCard.
-
-  Variable A, B : Set.
-
-  Lemma MapCard_M0 : (MapCard A (M0 A))=O.
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma MapCard_M1 : (a:ad) (y:A) (MapCard A (M1 A a y))=(1).
-  Proof.
-    Trivial.
-  Qed.
-
-  Lemma MapCard_is_O : (m:(Map A)) (MapCard A m)=O -> 
-      (a:ad) (MapGet A m a)=(NONE A).
-  Proof.
-    Induction m. Trivial.
-    Intros a y H. Discriminate H.
-    Intros. Simpl in H1. Elim (plus_is_O ? ? H1). Intros. Rewrite (MapGet_M2_bit_0_if A m0 m1 a).
-    Case (ad_bit_0 a). Apply H0. Assumption.
-    Apply H. Assumption.
-  Qed.
-
-  Lemma MapCard_is_not_O : (m:(Map A)) (a:ad) (y:A) (MapGet A m a)=(SOME A y) ->
-      {n:nat | (MapCard A m)=(S n)}.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Intros a y a0 y0 H. Simpl in H. Elim (sumbool_of_bool (ad_eq a a0)). Intro H0. Split with O.
-    Reflexivity.
-    Intro H0. Rewrite H0 in H. Discriminate H.
-    Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H2.
-    Rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. Elim (H0 (ad_div_2 a) y H1). Intros n H3.
-    Simpl. Rewrite H3. Split with (plus (MapCard A m0) n).
-    Rewrite <- (plus_Snm_nSm (MapCard A m0) n). Reflexivity.
-    Intro H2. Rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. Elim (H (ad_div_2 a) y H1).
-    Intros n H3. Simpl. Rewrite H3. Split with (plus n (MapCard A m1)). Reflexivity.
-  Qed.
-
-  Lemma MapCard_is_one : (m:(Map A)) (MapCard A m)=(1) ->
-      {a:ad & {y:A | (MapGet A m a)=(SOME A y)}}.
-  Proof.
-    Induction m. Intro. Discriminate H.
-    Intros a y H. Split with a. Split with y. Apply M1_semantics_1.
-    Intros. Simpl in H1. Elim (plus_is_one (MapCard A m0) (MapCard A m1) H1).
-    Intro H2. Elim H2. Intros. Elim (H0 H4). Intros a H5. Split with (ad_double_plus_un a).
-    Rewrite (MapGet_M2_bit_0_1 A ? (ad_double_plus_un_bit_0 a) m0 m1).
-    Rewrite ad_double_plus_un_div_2. Exact H5.
-    Intro H2. Elim H2. Intros. Elim (H H3). Intros a H5. Split with (ad_double a).
-    Rewrite (MapGet_M2_bit_0_0 A ? (ad_double_bit_0 a) m0 m1).
-    Rewrite ad_double_div_2. Exact H5.
-  Qed.
-
-  Lemma MapCard_is_one_unique : (m:(Map A)) (MapCard A m)=(1) -> (a,a':ad) (y,y':A) 
-      (MapGet A m a)=(SOME A y) -> (MapGet A m a')=(SOME A y') ->
-        a=a' /\ y=y'.
-  Proof.
-    Induction m. Intro. Discriminate H.
-    Intros. Elim (sumbool_of_bool (ad_eq a a1)). Intro H2. Rewrite (ad_eq_complete ? ? H2) in H0.
-    Rewrite (M1_semantics_1 A a1 a0) in H0. Inversion H0. Elim (sumbool_of_bool (ad_eq a a')).
-    Intro H5. Rewrite (ad_eq_complete ? ? H5) in H1. Rewrite (M1_semantics_1 A a' a0) in H1.
-    Inversion H1. Rewrite <- (ad_eq_complete ? ? H2). Rewrite <- (ad_eq_complete ? ? H5).
-    Rewrite <- H4. Rewrite <- H6. (Split; Reflexivity).
-    Intro H5. Rewrite (M1_semantics_2 A a a' a0 H5) in H1. Discriminate H1.
-    Intro H2. Rewrite (M1_semantics_2 A a a1 a0 H2) in H0. Discriminate H0.
-    Intros. Simpl in H1. Elim (plus_is_one ? ? H1). Intro H4. Elim H4. Intros.
-    Rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. Elim (sumbool_of_bool (ad_bit_0 a)).
-    Intro H7. Rewrite H7 in H2. Rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3.
-    Elim (sumbool_of_bool (ad_bit_0 a')). Intro H8. Rewrite H8 in H3. Elim (H0 H6 ? ? ? ? H2 H3).
-    Intros. Split. Rewrite <- (ad_div_2_double_plus_un a H7).
-    Rewrite <- (ad_div_2_double_plus_un a' H8). Rewrite H9. Reflexivity.
-    Assumption.
-    Intro H8. Rewrite H8 in H3. Rewrite (MapCard_is_O m0 H5 (ad_div_2 a')) in H3.
-    Discriminate H3.
-    Intro H7. Rewrite H7 in H2. Rewrite (MapCard_is_O m0 H5 (ad_div_2 a)) in H2.
-    Discriminate H2.
-    Intro H4. Elim H4. Intros. Rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2.
-    Elim (sumbool_of_bool (ad_bit_0 a)). Intro H7. Rewrite H7 in H2.
-    Rewrite (MapCard_is_O m1 H6 (ad_div_2 a)) in H2. Discriminate H2.
-    Intro H7. Rewrite H7 in H2. Rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3.
-    Elim (sumbool_of_bool (ad_bit_0 a')). Intro H8. Rewrite H8 in H3.
-    Rewrite (MapCard_is_O m1 H6 (ad_div_2 a')) in H3. Discriminate H3.
-    Intro H8. Rewrite H8 in H3. Elim (H H5 ? ? ? ? H2 H3). Intros. Split.
-    Rewrite <- (ad_div_2_double a H7). Rewrite <- (ad_div_2_double a' H8).
-    Rewrite H9. Reflexivity.
-    Assumption.
-  Qed.
-
-  Lemma length_as_fold : (C:Set) (l:(list C)) 
-      (length l)=(fold_right [_:C][n:nat](S n) O l).
-  Proof.
-    Induction l. Reflexivity.
-    Intros. Simpl. Rewrite H. Reflexivity.
-  Qed.
-
-  Lemma length_as_fold_2 : (l:(alist A)) 
-      (length l)=(fold_right [r:ad*A][n:nat]let (a,y)=r in (plus (1) n) O l).
-  Proof.
-    Induction l. Reflexivity.
-    Intros. Simpl. Rewrite H. (Elim a; Reflexivity).
-  Qed.
-
-  Lemma MapCard_as_Fold_1 : (m:(Map A)) (pf:ad->ad)
-      (MapCard A m)=(MapFold1 A nat O plus [_:ad][_:A](1) pf m).
-  Proof.
-    Induction m. Trivial.
-    Trivial.
-    Intros. Simpl. Rewrite <- (H [a0:ad](pf (ad_double a0))).
-    Rewrite <- (H0 [a0:ad](pf (ad_double_plus_un a0))). Reflexivity.
-  Qed.
-
-  Lemma MapCard_as_Fold : 
-      (m:(Map A)) (MapCard A m)=(MapFold A nat O plus [_:ad][_:A](1) m).
-  Proof.
-    Intro. Exact (MapCard_as_Fold_1 m [a0:ad]a0).
-  Qed.
- 
-  Lemma MapCard_as_length : (m:(Map A)) (MapCard A m)=(length (alist_of_Map A m)).
-  Proof.
-    Intro. Rewrite MapCard_as_Fold. Rewrite length_as_fold_2.
-    Apply MapFold_as_fold with op:=plus neutral:=O f:=[_:ad][_:A](1). Exact plus_assoc_r.
-    Trivial.
-    Intro. Rewrite <- plus_n_O. Reflexivity.
-  Qed.
-
-  Lemma MapCard_Put1_equals_2 : (p:positive) (a,a':ad) (y,y':A)
-      (MapCard A (MapPut1 A a y a' y' p))=(2).
-  Proof.
-    Induction p. Intros. Simpl. (Case (ad_bit_0 a); Reflexivity).
-    Intros. Simpl. Case (ad_bit_0 a). Exact (H (ad_div_2 a) (ad_div_2 a') y y').
-    Simpl. Rewrite <- plus_n_O. Exact (H (ad_div_2 a) (ad_div_2 a') y y').
-    Intros. Simpl. (Case (ad_bit_0 a); Reflexivity).
-  Qed.
-
-  Lemma MapCard_Put_sum : (m,m':(Map A)) (a:ad) (y:A) (n,n':nat)
-      m'=(MapPut A m a y) -> n=(MapCard A m) -> n'=(MapCard A m') ->
-        {n'=n}+{n'=(S n)}.
-  Proof.
-    Induction m. Simpl. Intros. Rewrite H in H1. Simpl in H1. Right .
-    Rewrite H0. Rewrite H1. Reflexivity.
-    Intros a y m' a0 y0 n n' H H0 H1. Simpl in H. Elim (ad_sum (ad_xor a a0)). Intro H2.
-    Elim H2. Intros p H3. Rewrite H3 in H. Rewrite H in H1.
-    Rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H1. Simpl in H0. Right .
-    Rewrite H0. Rewrite H1. Reflexivity.
-    Intro H2. Rewrite H2 in H. Rewrite H in H1. Simpl in H1. Simpl in H0. Left .
-    Rewrite H0. Rewrite H1. Reflexivity.
-    Intros. Simpl in H2. Rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1.
-    Elim (sumbool_of_bool (ad_bit_0 a)). Intro H4. Rewrite H4 in H1.
-    Elim (H0 (MapPut A m1 (ad_div_2 a) y) (ad_div_2 a) y (MapCard A m1)
-       (MapCard A (MapPut A m1 (ad_div_2 a) y)) (refl_equal ? ?)
-       (refl_equal ? ?) (refl_equal ? ?)).
-    Intro H5. Rewrite H1 in H3. Simpl in H3. Rewrite H5 in H3. Rewrite <- H2 in H3. Left .
-    Assumption.
-    Intro H5. Rewrite H1 in H3. Simpl in H3. Rewrite H5 in H3.
-    Rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)) in H3.
-    Simpl in H3. Rewrite <- H2 in H3. Right . Assumption.
-    Intro H4. Rewrite H4 in H1.
-    Elim (H (MapPut A m0 (ad_div_2 a) y) (ad_div_2 a) y (MapCard A m0)
-       (MapCard A (MapPut A m0 (ad_div_2 a) y)) (refl_equal ? ?)
-       (refl_equal ? ?) (refl_equal ? ?)).
-    Intro H5. Rewrite H1 in H3. Simpl in H3. Rewrite H5 in H3. Rewrite <- H2 in H3.
-    Left . Assumption.
-    Intro H5. Rewrite H1 in H3. Simpl in H3. Rewrite H5 in H3. Simpl in H3. Rewrite <- H2 in H3.
-    Right . Assumption.
-  Qed.
-
-  Lemma MapCard_Put_lb : (m:(Map A)) (a:ad) (y:A)
-      (ge (MapCard A (MapPut A m a y)) (MapCard A m)).
-  Proof.
-    Unfold ge. Intros.
-    Elim (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
-       (MapCard A (MapPut A m a y)) (refl_equal ? ?) (refl_equal ? ?)
-       (refl_equal ? ?)).
-    Intro H. Rewrite H. Apply le_n.
-    Intro H. Rewrite H. Apply le_n_Sn.
-  Qed.
-
-  Lemma MapCard_Put_ub : (m:(Map A)) (a:ad) (y:A)
-      (le (MapCard A (MapPut A m a y)) (S (MapCard A m))).
-  Proof.
-    Intros.
-    Elim (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
-       (MapCard A (MapPut A m a y)) (refl_equal ? ?) (refl_equal ? ?)
-       (refl_equal ? ?)).
-    Intro H. Rewrite H. Apply le_n_Sn.
-    Intro H. Rewrite H. Apply le_n.
-  Qed.
-
-  Lemma MapCard_Put_1 : (m:(Map A)) (a:ad) (y:A)
-      (MapCard A (MapPut A m a y))=(MapCard A m) -> 
-        {y:A | (MapGet A m a)=(SOME A y)}.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Intros a y a0 y0 H. Simpl in H. Elim (ad_sum (ad_xor a a0)). Intro H0. Elim H0.
-    Intros p H1. Rewrite H1 in H. Rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H.
-    Discriminate H.
-    Intro H0. Rewrite H0 in H. Rewrite (ad_xor_eq ? ? H0). Split with y. Apply M1_semantics_1.
-    Intros. Rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1. Elim (sumbool_of_bool (ad_bit_0 a)).
-    Intro H2. Rewrite H2 in H1. Simpl in H1. Elim (H0 (ad_div_2 a) y (simpl_plus_l ? ? ? H1)).
-    Intros y0 H3. Split with y0. Rewrite <- H3. Exact (MapGet_M2_bit_0_1 A a H2 m0 m1).
-    Intro H2. Rewrite H2 in H1. Simpl in H1.
-    Rewrite (plus_sym (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1)) in H1.
-    Rewrite (plus_sym (MapCard A m0) (MapCard A m1)) in H1.
-    Elim (H (ad_div_2 a) y (simpl_plus_l ? ? ? H1)). Intros y0 H3. Split with y0.
-    Rewrite <- H3. Exact (MapGet_M2_bit_0_0 A a H2 m0 m1).
-  Qed.
-
-  Lemma MapCard_Put_2 : (m:(Map A)) (a:ad) (y:A)
-      (MapCard A (MapPut A m a y))=(S (MapCard A m)) -> (MapGet A m a)=(NONE A).
-  Proof.
-    Induction m. Trivial.
-    Intros. Simpl in H. Elim (sumbool_of_bool (ad_eq a a1)). Intro H0.
-    Rewrite (ad_eq_complete ? ? H0) in H. Rewrite (ad_xor_nilpotent a1) in H. Discriminate H.
-    Intro H0. Exact (M1_semantics_2 A a a1 a0 H0).
-    Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H2.
-    Rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). Apply (H0 (ad_div_2 a) y).
-    Apply simpl_plus_l with n:=(MapCard A m0).
-    Rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)). Simpl in H1. Simpl. Rewrite <- H1.
-    Clear H1.
-    NewInduction a. Discriminate H2.
-    NewInduction p. Reflexivity.
-    Discriminate H2.
-    Reflexivity.
-    Intro H2. Rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). Apply (H (ad_div_2 a) y).
-    Cut (plus (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1))
-         =(plus (S (MapCard A m0)) (MapCard A m1)).
-    Intro. Rewrite (plus_sym (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1)) in H3.
-    Rewrite (plus_sym (S (MapCard A m0)) (MapCard A m1)) in H3. Exact (simpl_plus_l ? ? ? H3).
-    Simpl. Simpl in H1. Rewrite <- H1. NewInduction a. Trivial.
-    NewInduction p. Discriminate H2.
-    Reflexivity.
-    Discriminate H2.
-  Qed.
-
-  Lemma MapCard_Put_1_conv : (m:(Map A)) (a:ad) (y,y':A)
-      (MapGet A m a)=(SOME A y) -> (MapCard A (MapPut A m a y'))=(MapCard A m).
-  Proof.
-    Intros.
-    Elim (MapCard_Put_sum m (MapPut A m a y') a y' (MapCard A m)
-           (MapCard A (MapPut A m a y')) (refl_equal ? ?) (refl_equal ? ?)
-           (refl_equal ? ?)).
-    Trivial.
-    Intro H0. Rewrite (MapCard_Put_2 m a y' H0) in H. Discriminate H.
-  Qed.
-
-  Lemma MapCard_Put_2_conv : (m:(Map A)) (a:ad) (y:A)
-      (MapGet A m a)=(NONE A) -> (MapCard A (MapPut A m a y))=(S (MapCard A m)).
-  Proof.
-    Intros.
-    Elim (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m)
-           (MapCard A (MapPut A m a y)) (refl_equal ? ?) (refl_equal ? ?)
-           (refl_equal ? ?)).
-    Intro H0. Elim (MapCard_Put_1 m a y H0). Intros y' H1. Rewrite H1 in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma MapCard_ext : (m,m':(Map A))
-      (eqm A (MapGet A m) (MapGet A m')) -> (MapCard A m)=(MapCard A m').
-  Proof.
-    Unfold eqm. Intros. Rewrite (MapCard_as_length m). Rewrite (MapCard_as_length m').
-    Rewrite (alist_canonical A (alist_of_Map A m) (alist_of_Map A m')). Reflexivity.
-    Unfold eqm. Intro. Rewrite (Map_of_alist_semantics A (alist_of_Map A m) a).
-    Rewrite (Map_of_alist_semantics A (alist_of_Map A m') a). Rewrite (Map_of_alist_of_Map A m' a).
-    Rewrite (Map_of_alist_of_Map A m a). Exact (H a).
-    Apply alist_of_Map_sorts2.
-    Apply alist_of_Map_sorts2.
-  Qed.
-
-  Lemma MapCard_Dom : (m:(Map A)) (MapCard A m)=(MapCard unit (MapDom A m)).
-  Proof.
-    (Induction m; Trivial). Intros. Simpl. Rewrite H. Rewrite H0. Reflexivity.
-  Qed.
-
-  Lemma MapCard_Dom_Put_behind : (m:(Map A)) (a:ad) (y:A)
-      (MapDom A (MapPut_behind A m a y))=(MapDom A (MapPut A m a y)).
-  Proof.
-    Induction m. Trivial.
-    Intros a y a0 y0. Simpl. Elim (ad_sum (ad_xor a a0)). Intro H. Elim H.
-    Intros p H0. Rewrite H0. Reflexivity.
-    Intro H. Rewrite H. Rewrite (ad_xor_eq ? ? H). Reflexivity.
-    Intros. Simpl. Elim (ad_sum a). Intro H1. Elim H1. Intros p H2. Rewrite H2. Case p.
-    Intro p0. Simpl. Rewrite H0. Reflexivity.
-    Intro p0. Simpl. Rewrite H. Reflexivity.
-    Simpl. Rewrite H0. Reflexivity.
-    Intro H1. Rewrite H1. Simpl. Rewrite H. Reflexivity.
-  Qed.
-
-  Lemma MapCard_Put_behind_Put : (m:(Map A)) (a:ad) (y:A)
-      (MapCard A (MapPut_behind A m a y))=(MapCard A (MapPut A m a y)).
-  Proof.
-    Intros. Rewrite MapCard_Dom. Rewrite MapCard_Dom. Rewrite MapCard_Dom_Put_behind.
-    Reflexivity.
-  Qed.
-
-  Lemma MapCard_Put_behind_sum : (m,m':(Map A)) (a:ad) (y:A) (n,n':nat)
-      m'=(MapPut_behind A m a y) -> n=(MapCard A m) -> n'=(MapCard A m') ->
-        {n'=n}+{n'=(S n)}.
-  Proof.
-    Intros. (Apply (MapCard_Put_sum m (MapPut A m a y) a y n n'); Trivial).
-    Rewrite <- MapCard_Put_behind_Put. Rewrite <- H. Assumption.
-  Qed.
-
-  Lemma MapCard_makeM2 : (m,m':(Map A))
-      (MapCard A (makeM2 A m m'))=(plus (MapCard A m) (MapCard A m')).
-  Proof.
-    Intros. Rewrite (MapCard_ext ? ? (makeM2_M2 A m m')). Reflexivity.
-  Qed.
- 
-  Lemma MapCard_Remove_sum : (m,m':(Map A)) (a:ad) (n,n':nat)
-      m'=(MapRemove A m a) -> n=(MapCard A m) -> n'=(MapCard A m') ->
-        {n=n'}+{n=(S n')}.
-  Proof.
-    Induction m. Simpl. Intros. Rewrite H in H1. Simpl in H1. Left . Rewrite H1. Assumption.
-    Simpl. Intros. Elim (sumbool_of_bool (ad_eq a a1)). Intro H2. Rewrite H2 in H.
-    Rewrite H in H1. Simpl in H1. Right . Rewrite H1. Assumption.
-    Intro H2. Rewrite H2 in H. Rewrite H in H1. Simpl in H1. Left . Rewrite H1. Assumption.
-    Intros. Simpl in H1. Simpl in H2. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H4.
-    Rewrite H4 in H1. Rewrite H1 in H3.
-    Rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H3.
-    Elim (H0 (MapRemove A m1 (ad_div_2 a)) (ad_div_2 a) (MapCard A m1)
-             (MapCard A (MapRemove A m1 (ad_div_2 a))) (refl_equal ? ?)
-             (refl_equal ? ?) (refl_equal ? ?)).
-    Intro H5. Rewrite H5 in H2. Left . Rewrite H3. Exact H2.
-    Intro H5. Rewrite H5 in H2.
-    Rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (ad_div_2 a)))) in H2.
-    Right . Rewrite H3. Exact H2.
-    Intro H4. Rewrite H4 in H1. Rewrite H1 in H3.
-    Rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H3.
-    Elim (H (MapRemove A m0 (ad_div_2 a)) (ad_div_2 a) (MapCard A m0)
-            (MapCard A (MapRemove A m0 (ad_div_2 a))) (refl_equal ? ?)
-            (refl_equal ? ?) (refl_equal ? ?)).
-    Intro H5. Rewrite H5 in H2. Left . Rewrite H3. Exact H2.
-    Intro H5. Rewrite H5 in H2. Right . Rewrite H3. Exact H2.
-  Qed.
-
-  Lemma MapCard_Remove_ub : (m:(Map A)) (a:ad)
-      (le (MapCard A (MapRemove A m a)) (MapCard A m)).
-  Proof.
-    Intros.
-    Elim (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
-           (MapCard A (MapRemove A m a)) (refl_equal ? ?) (refl_equal ? ?)
-           (refl_equal ? ?)).
-    Intro H. Rewrite H. Apply le_n.
-    Intro H. Rewrite H. Apply le_n_Sn.
-  Qed.
-
-  Lemma MapCard_Remove_lb : (m:(Map A)) (a:ad)
-      (ge (S (MapCard A (MapRemove A m a))) (MapCard A m)).
-  Proof.
-    Unfold ge. Intros.
-    Elim (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
-           (MapCard A (MapRemove A m a)) (refl_equal ? ?) (refl_equal ? ?)
-           (refl_equal ? ?)).
-    Intro H. Rewrite H. Apply le_n_Sn.
-    Intro H. Rewrite H. Apply le_n.
-  Qed.
-
-  Lemma MapCard_Remove_1 : (m:(Map A)) (a:ad)
-      (MapCard A (MapRemove A m a))=(MapCard A m) -> (MapGet A m a)=(NONE A).
-  Proof.
-    Induction m. Trivial.
-    Simpl. Intros a y a0 H. Elim (sumbool_of_bool (ad_eq a a0)). Intro H0.
-    Rewrite H0 in H. Discriminate H.
-    Intro H0. Rewrite H0. Reflexivity.
-    Intros. Simpl in H1. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H2. Rewrite H2 in H1.
-    Rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H1.
-    Rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). Apply H0. Exact (simpl_plus_l ? ? ? H1).
-    Intro H2. Rewrite H2 in H1.
-    Rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H1.
-    Rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). Apply H.
-    Rewrite (plus_sym (MapCard A (MapRemove A m0 (ad_div_2 a))) (MapCard A m1)) in H1.
-    Rewrite (plus_sym (MapCard A m0) (MapCard A m1)) in H1. Exact (simpl_plus_l ? ? ? H1).
-  Qed.
-
-  Lemma MapCard_Remove_2 : (m:(Map A)) (a:ad)
-      (S (MapCard A (MapRemove A m a)))=(MapCard A m) -> 
-        {y:A | (MapGet A m a)=(SOME A y)}.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Intros a y a0 H. Simpl in H. Elim (sumbool_of_bool (ad_eq a a0)). Intro H0.
-    Rewrite (ad_eq_complete ? ? H0). Split with y. Exact (M1_semantics_1 A a0 y).
-    Intro H0. Rewrite H0 in H. Discriminate H.
-    Intros. Simpl in H1. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H2. Rewrite H2 in H1.
-    Rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H1.
-    Rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). Apply H0.
-    Change (plus (S (MapCard A m0)) (MapCard A (MapRemove A m1 (ad_div_2 a))))
-            =(plus (MapCard A m0) (MapCard A m1)) in H1.
-    Rewrite (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (ad_div_2 a)))) in H1.
-    Exact (simpl_plus_l ? ? ? H1).
-    Intro H2. Rewrite H2 in H1. Rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). Apply H.
-    Rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H1.
-    Change (plus (S (MapCard A (MapRemove A m0 (ad_div_2 a)))) (MapCard A m1))
-      	   =(plus (MapCard A m0) (MapCard A m1)) in H1.
-    Rewrite (plus_sym (S (MapCard A (MapRemove A m0 (ad_div_2 a)))) (MapCard A m1)) in H1.
-    Rewrite (plus_sym (MapCard A m0) (MapCard A m1)) in H1. Exact (simpl_plus_l ? ? ? H1).
-  Qed.
-
-  Lemma MapCard_Remove_1_conv : (m:(Map A)) (a:ad)
-      (MapGet A m a)=(NONE A) -> (MapCard A (MapRemove A m a))=(MapCard A m).
-  Proof.
-    Intros.
-    Elim (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
-           (MapCard A (MapRemove A m a)) (refl_equal ? ?) (refl_equal ? ?)
-           (refl_equal ? ?)).
-    Intro H0. Rewrite H0. Reflexivity.
-    Intro H0. Elim (MapCard_Remove_2 m a (sym_eq ? ? ? H0)). Intros y H1. Rewrite H1 in H.
-    Discriminate H.
-  Qed.
-
-  Lemma MapCard_Remove_2_conv : (m:(Map A)) (a:ad) (y:A)
-      (MapGet A m a)=(SOME A y) -> 
-        (S (MapCard A (MapRemove A m a)))=(MapCard A m).
-  Proof.
-    Intros.
-    Elim (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m)
-           (MapCard A (MapRemove A m a)) (refl_equal ? ?) (refl_equal ? ?)
-           (refl_equal ? ?)).
-    Intro H0. Rewrite (MapCard_Remove_1 m a (sym_eq ? ? ? H0)) in H. Discriminate H.
-    Intro H0. Rewrite H0. Reflexivity.
-  Qed.
-
-  Lemma MapMerge_Restr_Card : (m,m':(Map A))
-      (plus (MapCard A m) (MapCard A m'))=
-      (plus (MapCard A (MapMerge A m m')) (MapCard A (MapDomRestrTo A A m m'))).
-  Proof.
-    Induction m. Simpl. Intro. Apply plus_n_O.
-    Simpl. Intros a y m'. Elim (option_sum A (MapGet A m' a)). Intro H. Elim H. Intros y0 H0.
-    Rewrite H0. Rewrite MapCard_Put_behind_Put. Rewrite (MapCard_Put_1_conv m' a y0 y H0).
-    Simpl. Rewrite <- plus_Snm_nSm. Apply plus_n_O.
-    Intro H. Rewrite H. Rewrite MapCard_Put_behind_Put. Rewrite (MapCard_Put_2_conv m' a y H).
-    Apply plus_n_O.
-    Intros.
-    Change (plus (plus (MapCard A m0) (MapCard A m1)) (MapCard A m'))
-            =(plus (MapCard A (MapMerge A (M2 A m0 m1) m'))
-               (MapCard A (MapDomRestrTo A A (M2 A m0 m1) m'))).
-    Elim m'. Reflexivity.
-    Intros a y. Unfold MapMerge. Unfold MapDomRestrTo.
-    Elim (option_sum A (MapGet A (M2 A m0 m1) a)). Intro H1. Elim H1. Intros y0 H2. Rewrite H2.
-    Rewrite (MapCard_Put_1_conv (M2 A m0 m1) a y0 y H2). Reflexivity.
-    Intro H1. Rewrite H1. Rewrite (MapCard_Put_2_conv (M2 A m0 m1) a y H1). Simpl.
-    Rewrite <- (plus_Snm_nSm (plus (MapCard A m0) (MapCard A m1)) O). Reflexivity.
-    Intros. Simpl.
-    Rewrite (plus_permute_2_in_4 (MapCard A m0) (MapCard A m1) (MapCard A m2) (MapCard A m3)).
-    Rewrite (H m2). Rewrite (H0 m3).
-    Rewrite (MapCard_makeM2 (MapDomRestrTo A A m0 m2) (MapDomRestrTo A A m1 m3)).
-    Apply plus_permute_2_in_4.
-  Qed.
-
-  Lemma MapMerge_disjoint_Card : (m,m':(Map A)) (MapDisjoint A A m m') ->
-      	(MapCard A (MapMerge A m m'))=(plus (MapCard A m) (MapCard A m')).
-  Proof.
-    Intros. Rewrite (MapMerge_Restr_Card m m').
-    Rewrite (MapCard_ext ? ? (MapDisjoint_imp_2 ? ? ? ? H)). Apply plus_n_O.
-  Qed.
-
-  Lemma MapSplit_Card : (m:(Map A)) (m':(Map B))
-      (MapCard A m)=(plus (MapCard A (MapDomRestrTo A B m m'))
-                          (MapCard A (MapDomRestrBy A B m m'))).
-  Proof.
-    Intros. Rewrite (MapCard_ext ? ? (MapDom_Split_1 A B m m')). Apply MapMerge_disjoint_Card.
-    Apply MapDisjoint_2_imp. Unfold MapDisjoint_2. Apply MapDom_Split_3.
-  Qed.
-
-  Lemma MapMerge_Card_ub : (m,m':(Map A))
-      (le (MapCard A (MapMerge A m m')) (plus (MapCard A m) (MapCard A m'))).
-  Proof.
-    Intros. Rewrite MapMerge_Restr_Card. Apply le_plus_l.
-  Qed.
-
-  Lemma MapDomRestrTo_Card_ub_l : (m:(Map A)) (m':(Map B))
-      (le (MapCard A (MapDomRestrTo A B m m')) (MapCard A m)).
-  Proof.
-    Intros. Rewrite (MapSplit_Card m m'). Apply le_plus_l.
-  Qed.
-
-  Lemma MapDomRestrBy_Card_ub_l : (m:(Map A)) (m':(Map B))
-      (le (MapCard A (MapDomRestrBy A B m m')) (MapCard A m)).
-  Proof.
-    Intros. Rewrite (MapSplit_Card m m'). Apply le_plus_r.
-  Qed.
-
-  Lemma MapMerge_Card_disjoint : (m,m':(Map A))
-      (MapCard A (MapMerge A m m'))=(plus (MapCard A m) (MapCard A m')) ->
-        (MapDisjoint A A m m').
-  Proof.
-    Induction m. Intros. Apply Map_M0_disjoint.
-    Simpl. Intros. Rewrite (MapCard_Put_behind_Put m' a a0) in H. Unfold MapDisjoint in_dom.
-    Simpl. Intros. Elim (sumbool_of_bool (ad_eq a a1)). Intro H2.
-    Rewrite (ad_eq_complete ? ? H2) in H. Rewrite (MapCard_Put_2 m' a1 a0 H) in H1.
-    Discriminate H1.
-    Intro H2. Rewrite H2 in H0. Discriminate H0.
-    Induction m'. Intros. Apply Map_disjoint_M0.
-    Intros a y H1. Rewrite <- (MapCard_ext ? ? (MapPut_as_Merge A (M2 A m0 m1) a y)) in H1.
-    Unfold 3 MapCard in H1. Rewrite <- (plus_Snm_nSm (MapCard A (M2 A m0 m1)) O) in H1.
-    Rewrite <- (plus_n_O (S (MapCard A (M2 A m0 m1)))) in H1. Unfold MapDisjoint in_dom.
-    Unfold 2 MapGet. Intros. Elim (sumbool_of_bool (ad_eq a a0)). Intro H4.
-    Rewrite <- (ad_eq_complete ? ? H4) in H2. Rewrite (MapCard_Put_2 ? ? ? H1) in H2.
-    Discriminate H2.
-    Intro H4. Rewrite H4 in H3. Discriminate H3.
-    Intros. Unfold MapDisjoint. Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H6.
-    Unfold MapDisjoint in H0. Apply H0 with m':=m3 a:=(ad_div_2 a). Apply le_antisym.
-    Apply MapMerge_Card_ub.
-    Apply simpl_le_plus_l with p:=(plus (MapCard A m0) (MapCard A m2)).
-    Rewrite (plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) (MapCard A m1) (MapCard A m3)).
-    Change (MapCard A (M2 A (MapMerge A m0 m2) (MapMerge A m1 m3)))
-           =(plus (plus (MapCard A m0) (MapCard A m1)) (plus (MapCard A m2) (MapCard A m3))) in H3.
-    Rewrite <- H3. Simpl. Apply le_reg_r. Apply MapMerge_Card_ub.
-    Elim (in_dom_some ? ? ? H4). Intros y H7. Rewrite (MapGet_M2_bit_0_1 ? a H6 m0 m1) in H7.
-    Unfold in_dom. Rewrite H7. Reflexivity.
-    Elim (in_dom_some ? ? ? H5). Intros y H7. Rewrite (MapGet_M2_bit_0_1 ? a H6 m2 m3) in H7.
-    Unfold in_dom. Rewrite H7. Reflexivity.
-    Intro H6. Unfold MapDisjoint in H. Apply H with m':=m2 a:=(ad_div_2 a). Apply le_antisym.
-    Apply MapMerge_Card_ub.
-    Apply simpl_le_plus_l with p:=(plus (MapCard A m1) (MapCard A m3)).
-    Rewrite (plus_sym (plus (MapCard A m1) (MapCard A m3)) (plus (MapCard A m0) (MapCard A m2))).
-    Rewrite (plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) (MapCard A m1) (MapCard A m3)).
-    Rewrite (plus_sym (plus (MapCard A m1) (MapCard A m3)) (MapCard A (MapMerge A m0 m2))).
-    Change (plus (MapCard A (MapMerge A m0 m2)) (MapCard A (MapMerge A m1 m3)))
-           =(plus (plus (MapCard A m0) (MapCard A m1)) (plus (MapCard A m2) (MapCard A m3))) in H3.
-    Rewrite <- H3. Apply le_reg_l. Apply MapMerge_Card_ub.
-    Elim (in_dom_some ? ? ? H4). Intros y H7. Rewrite (MapGet_M2_bit_0_0 ? a H6 m0 m1) in H7.
-    Unfold in_dom. Rewrite H7. Reflexivity.
-    Elim (in_dom_some ? ? ? H5). Intros y H7. Rewrite (MapGet_M2_bit_0_0 ? a H6 m2 m3) in H7.
-    Unfold in_dom. Rewrite H7. Reflexivity.
-  Qed.
-
-  Lemma MapCard_is_Sn : (m:(Map A)) (n:nat) (MapCard ? m)=(S n) -> 
-      {a:ad | (in_dom ? a m)=true}.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Intros a y n H. Split with a. Unfold in_dom. Rewrite (M1_semantics_1 ? a y). Reflexivity.
-    Intros. Simpl in H1. Elim (O_or_S (MapCard ? m0)). Intro H2. Elim H2. Intros m2 H3.
-    Elim (H ? (sym_eq ? ? ? H3)). Intros a H4. Split with (ad_double a). Unfold in_dom.
-    Rewrite (MapGet_M2_bit_0_0 A (ad_double a) (ad_double_bit_0 a) m0 m1).
-    Rewrite (ad_double_div_2 a). Elim (in_dom_some ? ? ? H4). Intros y H5. Rewrite H5. Reflexivity.
-    Intro H2. Rewrite <- H2 in H1. Simpl in H1. Elim (H0 ? H1). Intros a H3.
-    Split with (ad_double_plus_un a). Unfold in_dom.
-    Rewrite (MapGet_M2_bit_0_1 A (ad_double_plus_un a) (ad_double_plus_un_bit_0 a) m0 m1).
-    Rewrite (ad_double_plus_un_div_2 a). Elim (in_dom_some ? ? ? H3). Intros y H4. Rewrite H4.
-    Reflexivity.
-  Qed.
-
-End MapCard.
-
-Section MapCard2.
-
-  Variable A, B : Set.
-
-  Lemma MapSubset_card_eq_1 : (n:nat) (m:(Map A)) (m':(Map B))
-      (MapSubset ? ? m m') -> (MapCard ? m)=n -> (MapCard ? m')=n ->
-        (MapSubset ? ? m' m).
-  Proof.
-    Induction n. Intros. Unfold MapSubset in_dom. Intro. Rewrite (MapCard_is_O ? m H0 a).
-    Rewrite (MapCard_is_O ? m' H1 a). Intro H2. Discriminate H2.
-    Intros. Elim (MapCard_is_Sn A m n0 H1). Intros a H3. Elim (in_dom_some ? ? ? H3).
-    Intros y H4. Elim (in_dom_some ? ? ? (H0 ? H3)). Intros y' H6.
-    Cut (eqmap ? (MapPut ? (MapRemove ? m a) a y) m). Intro.
-    Cut (eqmap ? (MapPut ? (MapRemove ? m' a) a y') m'). Intro.
-    Apply MapSubset_ext with m0:=(MapPut ? (MapRemove ? m' a) a y')
-                             m2:=(MapPut ? (MapRemove ? m a) a y).
-    Assumption.
-    Assumption.
-    Apply MapSubset_Put_mono. Apply H. Apply MapSubset_Remove_mono. Assumption.
-    Rewrite <- (MapCard_Remove_2_conv ? m a y H4) in H1. Inversion_clear H1. Reflexivity.
-    Rewrite <- (MapCard_Remove_2_conv ? m' a y' H6) in H2. Inversion_clear H2. Reflexivity.
-    Unfold eqmap eqm. Intro. Rewrite (MapPut_semantics ? (MapRemove B m' a) a y' a0).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H7. Rewrite H7. Rewrite <- (ad_eq_complete ? ? H7).
-    Apply sym_eq. Assumption.
-    Intro H7. Rewrite H7. Rewrite (MapRemove_semantics ? m' a a0). Rewrite H7. Reflexivity.
-    Unfold eqmap eqm. Intro. Rewrite (MapPut_semantics ? (MapRemove A m a) a y a0).
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H7. Rewrite H7. Rewrite <- (ad_eq_complete ? ? H7).
-    Apply sym_eq. Assumption.
-    Intro H7. Rewrite H7. Rewrite (MapRemove_semantics A m a a0). Rewrite H7. Reflexivity.
-  Qed.
-
-  Lemma MapDomRestrTo_Card_ub_r : (m:(Map A)) (m':(Map B))
-      (le (MapCard A (MapDomRestrTo A B m m')) (MapCard B m')).
-  Proof.
-    Induction m. Intro. Simpl. Apply le_O_n.
-    Intros a y m'. Simpl. Elim (option_sum B (MapGet B m' a)). Intro H. Elim H. Intros y0 H0.
-    Rewrite H0. Elim (MapCard_is_not_O B m' a y0 H0). Intros n H1. Rewrite H1. Simpl.
-    Apply le_n_S. Apply le_O_n.
-    Intro H. Rewrite H. Simpl. Apply le_O_n.
-    Induction m'. Simpl. Apply le_O_n.
-
-    Intros a y. Unfold MapDomRestrTo. Case (MapGet A (M2 A m0 m1) a). Simpl. Apply le_O_n.
-    Intro. Simpl. Apply le_n.
-    Intros. Simpl. Rewrite (MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3)).
-    Apply le_plus_plus. Apply H.
-    Apply H0.
-  Qed.
-
-End MapCard2.
-
-Section MapCard3.
-
-  Variable A, B : Set.
-
-  Lemma MapMerge_Card_lb_l : (m,m':(Map A))
-      (ge (MapCard A (MapMerge A m m')) (MapCard A m)).
-  Proof.
-    Unfold ge. Intros. Apply (simpl_le_plus_l (MapCard A m')).
-    Rewrite (plus_sym (MapCard A m') (MapCard A m)).
-    Rewrite (plus_sym (MapCard A m') (MapCard A (MapMerge A m m'))).
-    Rewrite (MapMerge_Restr_Card A m m'). Apply le_reg_l. Apply MapDomRestrTo_Card_ub_r.
-  Qed.
-
-  Lemma MapMerge_Card_lb_r : (m,m':(Map A))
-      (ge (MapCard A (MapMerge A m m')) (MapCard A m')).
-  Proof.
-    Unfold ge. Intros. Apply (simpl_le_plus_l (MapCard A m)). Rewrite (MapMerge_Restr_Card A m m').
-    Rewrite (plus_sym (MapCard A (MapMerge A m m')) (MapCard A (MapDomRestrTo A A m m'))).
-    Apply le_reg_r. Apply MapDomRestrTo_Card_ub_l.
-  Qed.
-
-  Lemma MapDomRestrBy_Card_lb : (m:(Map A)) (m':(Map B))
-      (ge (plus (MapCard B m') (MapCard A (MapDomRestrBy A B m m'))) (MapCard A m)).
-  Proof.
-    Unfold ge. Intros. Rewrite (MapSplit_Card A B m m'). Apply le_reg_r.
-    Apply MapDomRestrTo_Card_ub_r.
-  Qed.
-
-  Lemma MapSubset_Card_le : (m:(Map A)) (m':(Map B))
-      (MapSubset A B m m') -> (le (MapCard A m) (MapCard B m')).
-  Proof.
-    Intros. Apply le_trans with m:=(plus (MapCard B m') (MapCard A (MapDomRestrBy A B m m'))).
-    Exact (MapDomRestrBy_Card_lb m m').
-    Rewrite (MapCard_ext ? ? ? (MapSubset_imp_2 ? ? ? ? H)). Simpl. Rewrite <- plus_n_O.
-    Apply le_n.
-  Qed.
-
-  Lemma MapSubset_card_eq : (m:(Map A)) (m':(Map B))
-      (MapSubset ? ? m m') -> (le (MapCard ? m') (MapCard ? m)) ->
-        (eqmap ? (MapDom ? m) (MapDom ? m')).
-  Proof.
-    Intros. Apply MapSubset_antisym. Assumption.
-    Cut (MapCard B m')=(MapCard A m). Intro. Apply (MapSubset_card_eq_1 A B (MapCard A m)).
-    Assumption.
-    Reflexivity.
-    Assumption.
-    Apply le_antisym. Assumption.
-    Apply MapSubset_Card_le. Assumption.
-  Qed.
-
-End MapCard3.
diff --git a/theories7/IntMap/Mapfold.v b/theories7/IntMap/Mapfold.v
deleted file mode 100644
index 8061f253..00000000
--- a/theories7/IntMap/Mapfold.v
+++ /dev/null
@@ -1,381 +0,0 @@
-(************************************************************************)
-(*  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: Mapfold.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $      i*)
-
-Require Bool.
-Require Sumbool.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require Fset.
-Require Mapaxioms.
-Require Mapiter.
-Require Lsort.
-Require Mapsubset.
-Require PolyList.
-
-Section MapFoldResults.
-
-  Variable A : Set.
-
-  Variable M : Set.
-  Variable neutral : M.
-  Variable op : M -> M -> M.
-
-  Variable nleft : (a:M) (op neutral a)=a.
-  Variable nright : (a:M) (op a neutral)=a.
-  Variable assoc : (a,b,c:M) (op (op a b) c)=(op a (op b c)).
-
-  Lemma MapFold_ext : (f:ad->A->M) (m,m':(Map A)) (eqmap A m m') ->
-      (MapFold ? ? neutral op f m)=(MapFold ? ? neutral op f m').
-  Proof.
-    Intros. Rewrite (MapFold_as_fold A M neutral op assoc nleft nright f m).
-    Rewrite (MapFold_as_fold A M neutral op assoc nleft nright f m').
-    Cut (alist_of_Map A m)=(alist_of_Map A m'). Intro. Rewrite H0. Reflexivity.
-    Apply alist_canonical. Unfold eqmap in H. Apply eqm_trans with f':=(MapGet A m).
-    Apply eqm_sym. Apply alist_of_Map_semantics.
-    Apply eqm_trans with f':=(MapGet A m'). Assumption.
-    Apply alist_of_Map_semantics.
-    Apply alist_of_Map_sorts2.
-    Apply alist_of_Map_sorts2.
-  Qed.
-
-  Lemma MapFold_ext_f_1 : (m:(Map A)) (f,g:ad->A->M) (pf:ad->ad)
-      ((a:ad) (y:A) (MapGet ? m a)=(SOME ? y) -> (f (pf a) y)=(g (pf a) y)) ->
-        (MapFold1 ? ? neutral op f pf m)=(MapFold1 ? ? neutral op g pf m).
-  Proof.
-    Induction m. Trivial.
-    Simpl. Intros. Apply H. Rewrite (ad_eq_correct a). Reflexivity.
-    Intros. Simpl. Rewrite (H f g [a0:ad](pf (ad_double a0))).
-    Rewrite (H0 f g [a0:ad](pf (ad_double_plus_un a0))). Reflexivity.
-    Intros. Apply H1. Rewrite MapGet_M2_bit_0_1. Rewrite ad_double_plus_un_div_2. Assumption.
-    Apply ad_double_plus_un_bit_0.
-    Intros. Apply H1. Rewrite MapGet_M2_bit_0_0. Rewrite ad_double_div_2. Assumption.
-    Apply ad_double_bit_0.
-  Qed.
-
-  Lemma MapFold_ext_f : (f,g:ad->A->M) (m:(Map A))
-      ((a:ad) (y:A) (MapGet ? m a)=(SOME ? y) -> (f a y)=(g a y)) ->
-        (MapFold ? ? neutral op f m)=(MapFold ? ? neutral op g m).
-  Proof.
-    Intros. Exact (MapFold_ext_f_1 m f g [a0:ad]a0 H).
-  Qed.
-
-  Lemma MapFold1_as_Fold_1 : (m:(Map A)) (f,f':ad->A->M) (pf, pf':ad->ad)
-      ((a:ad) (y:A) (f (pf a) y)=(f' (pf' a) y)) ->
-        (MapFold1 ? ? neutral op f pf m)=(MapFold1 ? ? neutral op f' pf' m).
-  Proof.
-    Induction m. Trivial.
-    Intros. Simpl. Apply H.
-    Intros. Simpl.
-    Rewrite (H f f' [a0:ad](pf (ad_double a0)) [a0:ad](pf' (ad_double a0))).
-    Rewrite (H0 f f' [a0:ad](pf (ad_double_plus_un a0)) [a0:ad](pf' (ad_double_plus_un a0))).
-    Reflexivity.
-    Intros. Apply H1.
-    Intros. Apply H1.
-  Qed.
-
-  Lemma MapFold1_as_Fold : (f:ad->A->M) (pf:ad->ad) (m:(Map A))
-      (MapFold1 ? ? neutral op f pf m)=(MapFold ? ? neutral op [a:ad][y:A] (f (pf a) y) m).
-  Proof.
-    Intros. Unfold MapFold. Apply MapFold1_as_Fold_1. Trivial.
-  Qed.
-
-  Lemma MapFold1_ext : (f:ad->A->M) (m,m':(Map A)) (eqmap A m m') -> (pf:ad->ad)
-      (MapFold1 ? ? neutral op f pf m)=(MapFold1 ? ? neutral op f pf m').
-  Proof.
-    Intros. Rewrite MapFold1_as_Fold. Rewrite MapFold1_as_Fold. Apply MapFold_ext. Assumption.
-  Qed.
-
-  Variable comm : (a,b:M) (op a b)=(op b a).
-
-  Lemma MapFold_Put_disjoint_1 : (p:positive)
-        (f:ad->A->M) (pf:ad->ad) (a1,a2:ad) (y1,y2:A) 
-	  (ad_xor a1 a2)=(ad_x p) ->
-      	    (MapFold1 A M neutral op f pf (MapPut1 A a1 y1 a2 y2 p))=
-	    (op (f (pf a1) y1) (f (pf a2) y2)).
-  Proof.
-    Induction p. Intros. Simpl. Elim (sumbool_of_bool (ad_bit_0 a1)). Intro H1. Rewrite H1.
-    Simpl. Rewrite ad_div_2_double_plus_un. Rewrite ad_div_2_double. Apply comm.
-    Change (ad_bit_0 a2)=(negb true). Rewrite <- H1. Rewrite (ad_neg_bit_0_2 ? ? ? H0).
-    Rewrite negb_elim. Reflexivity.
-    Assumption.
-    Intro H1. Rewrite H1. Simpl. Rewrite ad_div_2_double. Rewrite ad_div_2_double_plus_un.
-    Reflexivity.
-    Change (ad_bit_0 a2)=(negb false). Rewrite <- H1. Rewrite (ad_neg_bit_0_2 ? ? ? H0).
-    Rewrite negb_elim. Reflexivity.
-    Assumption.
-    Simpl. Intros. Elim (sumbool_of_bool (ad_bit_0 a1)). Intro H1. Rewrite H1. Simpl.
-    Rewrite nleft.
-    Rewrite (H f [a0:ad](pf (ad_double_plus_un a0)) (ad_div_2 a1) (ad_div_2 a2) y1 y2).
-    Rewrite ad_div_2_double_plus_un. Rewrite ad_div_2_double_plus_un. Reflexivity.
-    Rewrite <- (ad_same_bit_0 ? ? ? H0). Assumption.
-    Assumption.
-    Rewrite <- ad_xor_div_2. Rewrite H0. Reflexivity.
-    Intro H1. Rewrite H1. Simpl. Rewrite nright.
-    Rewrite (H f [a0:ad](pf (ad_double a0)) (ad_div_2 a1) (ad_div_2 a2) y1 y2).
-    Rewrite ad_div_2_double. Rewrite ad_div_2_double. Reflexivity.
-    Rewrite <- (ad_same_bit_0 ? ? ? H0). Assumption.
-    Assumption.
-    Rewrite <- ad_xor_div_2. Rewrite H0. Reflexivity.
-    Intros. Simpl. Elim (sumbool_of_bool (ad_bit_0 a1)). Intro H0. Rewrite H0. Simpl.
-    Rewrite ad_div_2_double. Rewrite ad_div_2_double_plus_un. Apply comm.
-    Assumption.
-    Change (ad_bit_0 a2)=(negb true). Rewrite <- H0. Rewrite (ad_neg_bit_0_1 ? ? H).
-    Rewrite negb_elim. Reflexivity.
-    Intro H0. Rewrite H0. Simpl. Rewrite ad_div_2_double. Rewrite ad_div_2_double_plus_un.
-    Reflexivity.
-    Change (ad_bit_0 a2)=(negb false). Rewrite <- H0. Rewrite (ad_neg_bit_0_1 ? ? H).
-    Rewrite negb_elim. Reflexivity.
-    Assumption.
-  Qed.
-
-  Lemma MapFold_Put_disjoint_2 : 
-        (f:ad->A->M) (m:(Map A)) (a:ad) (y:A) (pf:ad->ad)
-	  (MapGet A m a)=(NONE A) ->
-      	    (MapFold1 A M neutral op f pf (MapPut A m a y))=
-	    (op (f (pf a) y) (MapFold1 A M neutral op f pf m)).
-  Proof.
-    Induction m. Intros. Simpl. Rewrite (nright (f (pf a) y)). Reflexivity.
-    Intros a1 y1 a2 y2 pf H. Simpl. Elim (ad_sum (ad_xor a1 a2)). Intro H0. Elim H0.
-    Intros p H1. Rewrite H1. Rewrite comm. Exact (MapFold_Put_disjoint_1 p f pf a1 a2 y1 y2 H1).
-    Intro H0. Rewrite (ad_eq_complete ? ? (ad_xor_eq_true ? ? H0)) in H.
-    Rewrite (M1_semantics_1 A a2 y1) in H. Discriminate H.
-    Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H2.
-    Cut (MapPut A (M2 A m0 m1) a y)=(M2 A m0 (MapPut A m1 (ad_div_2 a) y)). Intro.
-    Rewrite H3. Simpl. Rewrite (H0 (ad_div_2 a) y [a0:ad](pf (ad_double_plus_un a0))).
-    Rewrite ad_div_2_double_plus_un. Rewrite <- assoc.
-    Rewrite (comm (MapFold1 A M neutral op f [a0:ad](pf (ad_double a0)) m0) (f (pf a) y)).
-    Rewrite assoc. Reflexivity.
-    Assumption.
-    Rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. Assumption.
-    Simpl. Elim (ad_sum a). Intro H3. Elim H3. Intro p. Elim p. Intros p0 H4 H5. Rewrite H5.
-    Reflexivity.
-    Intros p0 H4 H5. Rewrite H5 in H2. Discriminate H2.
-    Intro H4. Rewrite H4. Reflexivity.
-    Intro H3. Rewrite H3 in H2. Discriminate H2.
-    Intro H2. Cut (MapPut A (M2 A m0 m1) a y)=(M2 A (MapPut A m0 (ad_div_2 a) y) m1).
-    Intro. Rewrite H3. Simpl. Rewrite (H (ad_div_2 a) y [a0:ad](pf (ad_double a0))).
-    Rewrite ad_div_2_double. Rewrite <- assoc. Reflexivity.
-    Assumption.
-    Rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. Assumption.
-    Simpl. Elim (ad_sum a). Intro H3. Elim H3. Intro p. Elim p. Intros p0 H4 H5. Rewrite H5 in H2.
-    Discriminate H2.
-    Intros p0 H4 H5. Rewrite H5. Reflexivity.
-    Intro H4. Rewrite H4 in H2. Discriminate H2.
-    Intro H3. Rewrite H3. Reflexivity.
-  Qed.
-
-  Lemma MapFold_Put_disjoint : 
-        (f:ad->A->M) (m:(Map A)) (a:ad) (y:A)
-	  (MapGet A m a)=(NONE A) ->
-      	    (MapFold A M neutral op f (MapPut A m a y))=
-	    (op (f a y) (MapFold A M neutral op f m)).
-  Proof.
-    Intros. Exact (MapFold_Put_disjoint_2 f m a y [a0:ad]a0 H).
-  Qed.
-
-  Lemma MapFold_Put_behind_disjoint_2 : 
-        (f:ad->A->M) (m:(Map A)) (a:ad) (y:A) (pf:ad->ad)
-	  (MapGet A m a)=(NONE A) ->
-      	    (MapFold1 A M neutral op f pf (MapPut_behind A m a y))=
-	    (op (f (pf a) y) (MapFold1 A M neutral op f pf m)).
-  Proof.
-    Intros. Cut (eqmap A (MapPut_behind A m a y) (MapPut A m a y)). Intro.
-    Rewrite (MapFold1_ext f ? ? H0 pf). Apply MapFold_Put_disjoint_2. Assumption.
-    Apply eqmap_trans with m':=(MapMerge A (M1 A a y) m). Apply MapPut_behind_as_Merge.
-    Apply eqmap_trans with m':=(MapMerge A m (M1 A a y)).
-    Apply eqmap_trans with m':=(MapDelta A (M1 A a y) m). Apply eqmap_sym. Apply MapDelta_disjoint.
-    Unfold MapDisjoint. Unfold in_dom. Simpl. Intros. Elim (sumbool_of_bool (ad_eq a a0)).
-    Intro H2. Rewrite (ad_eq_complete ? ? H2) in H. Rewrite H in H1. Discriminate H1.
-    Intro H2. Rewrite H2 in H0. Discriminate H0.
-    Apply eqmap_trans with m':=(MapDelta A m (M1 A a y)). Apply MapDelta_sym.
-    Apply MapDelta_disjoint. Unfold MapDisjoint. Unfold in_dom. Simpl. Intros.
-    Elim (sumbool_of_bool (ad_eq a a0)). Intro H2. Rewrite (ad_eq_complete ? ? H2) in H.
-    Rewrite H in H0. Discriminate H0.
-    Intro H2. Rewrite H2 in H1. Discriminate H1.
-    Apply eqmap_sym. Apply MapPut_as_Merge.
-  Qed.
-
-  Lemma MapFold_Put_behind_disjoint : 
-        (f:ad->A->M) (m:(Map A)) (a:ad) (y:A)
-	  (MapGet A m a)=(NONE A) ->
-      	    (MapFold A M neutral op f (MapPut_behind A m a y))
-            =(op (f a y) (MapFold A M neutral op f m)).
-  Proof.
-    Intros. Exact (MapFold_Put_behind_disjoint_2 f m a y [a0:ad]a0 H).
-  Qed.
-
-  Lemma MapFold_Merge_disjoint_1 :
-        (f:ad->A->M) (m1,m2:(Map A)) (pf:ad->ad)
-	  (MapDisjoint A A m1 m2) ->
-      	    (MapFold1 A M neutral op f pf (MapMerge A m1 m2))=
-	    (op (MapFold1 A M neutral op f pf m1) (MapFold1 A M neutral op f pf m2)).
-  Proof.
-    Induction m1. Simpl. Intros. Rewrite nleft. Reflexivity.
-    Intros. Unfold MapMerge. Apply (MapFold_Put_behind_disjoint_2 f m2 a a0 pf).
-    Apply in_dom_none. Exact (MapDisjoint_M1_l ? ? m2 a a0 H).
-    Induction m2. Intros. Simpl. Rewrite nright. Reflexivity.
-    Intros. Unfold MapMerge. Rewrite (MapFold_Put_disjoint_2 f (M2 A m m0) a a0 pf). Apply comm.
-    Apply in_dom_none. Exact (MapDisjoint_M1_r ? ? (M2 A m m0) a a0 H1).
-    Intros. Simpl. Rewrite (H m3 [a0:ad](pf (ad_double a0))).
-    Rewrite (H0 m4 [a0:ad](pf (ad_double_plus_un a0))).
-    Cut (a,b,c,d:M)(op (op a b) (op c d))=(op (op a c) (op b d)). Intro. Apply H4.
-    Intros. Rewrite assoc. Rewrite <- (assoc b c d). Rewrite (comm b c). Rewrite (assoc c b d).
-    Rewrite assoc. Reflexivity.
-    Exact (MapDisjoint_M2_r ? ? ? ? ? ? H3).
-    Exact (MapDisjoint_M2_l ? ? ? ? ? ? H3).
-  Qed.
-
-  Lemma MapFold_Merge_disjoint :
-        (f:ad->A->M) (m1,m2:(Map A))
-	  (MapDisjoint A A m1 m2) ->
-      	    (MapFold A M neutral op f (MapMerge A m1 m2))=
-	    (op (MapFold A M neutral op f m1) (MapFold A M neutral op f m2)).
-  Proof.
-    Intros. Exact (MapFold_Merge_disjoint_1 f m1 m2 [a0:ad]a0 H).
-  Qed.
- 
-End MapFoldResults.
-
-Section MapFoldDistr.
-
-  Variable A : Set.
-
-  Variable M : Set.
-  Variable neutral : M.
-  Variable op : M -> M -> M.
-
-  Variable M' : Set.
-  Variable neutral' : M'.
-  Variable op' : M' -> M' -> M'.
-
-  Variable N : Set.
-
-  Variable times : M -> N -> M'.
-
-  Variable absorb : (c:N)(times neutral c)=neutral'.
-  Variable distr : (a,b:M) (c:N) (times (op a b) c) = (op' (times a c) (times b c)).
-
-  Lemma MapFold_distr_r_1 : (f:ad->A->M) (m:(Map A)) (c:N) (pf:ad->ad)
-      (times (MapFold1 A M neutral op f pf m) c)=
-      (MapFold1 A M' neutral' op' [a:ad][y:A] (times (f a y) c) pf m).
-  Proof.
-    Induction m. Intros. Exact (absorb c).
-    Trivial.
-    Intros. Simpl. Rewrite distr. Rewrite H. Rewrite H0. Reflexivity.
-  Qed.
-
-  Lemma MapFold_distr_r : (f:ad->A->M) (m:(Map A)) (c:N)
-      (times (MapFold A M neutral op f m) c)=
-      (MapFold A M' neutral' op' [a:ad][y:A] (times (f a y) c) m).
-  Proof.
-    Intros. Exact (MapFold_distr_r_1 f m c [a:ad]a).
-  Qed.
-
-End MapFoldDistr.
-
-Section MapFoldDistrL.
-
-  Variable A : Set.
-
-  Variable M : Set.
-  Variable neutral : M.
-  Variable op : M -> M -> M.
-
-  Variable M' : Set.
-  Variable neutral' : M'.
-  Variable op' : M' -> M' -> M'.
-
-  Variable N : Set.
-
-  Variable times : N -> M -> M'.
-
-  Variable absorb : (c:N)(times c neutral)=neutral'.
-  Variable distr : (a,b:M) (c:N) (times c (op a b)) = (op' (times c a) (times c b)).
-
-  Lemma MapFold_distr_l : (f:ad->A->M) (m:(Map A)) (c:N)
-      (times c (MapFold A M neutral op f m))=
-      (MapFold A M' neutral' op' [a:ad][y:A] (times c (f a y)) m).
-  Proof.
-    Intros. Apply MapFold_distr_r with times:=[a:M][b:N](times b a); Assumption.
-  Qed.
-
-End MapFoldDistrL.
-
-Section MapFoldExists.
-
-  Variable A : Set.
-
-  Lemma MapFold_orb_1 : (f:ad->A->bool) (m:(Map A)) (pf:ad->ad)
-      	       	      (MapFold1 A bool false orb f pf m)=
-                      (Cases (MapSweep1 A f pf m) of
-		           (SOME _) => true
-			 | _ => false
-	               end).
-  Proof.
-    Induction m. Trivial.
-    Intros a y pf. Simpl. Unfold MapSweep2. (Case (f (pf a) y); Reflexivity).
-    Intros. Simpl. Rewrite (H [a0:ad](pf (ad_double a0))).
-    Rewrite (H0 [a0:ad](pf (ad_double_plus_un a0))).
-    Case (MapSweep1 A f [a0:ad](pf (ad_double a0)) m0); Reflexivity.
-  Qed.
-
-  Lemma MapFold_orb : (f:ad->A->bool) (m:(Map A)) (MapFold A bool false orb f m)=
-                      (Cases (MapSweep A f m) of
-		           (SOME _) => true
-			 | _ => false
-	               end).
-  Proof.
-    Intros. Exact (MapFold_orb_1 f m [a:ad]a).
-  Qed.
-
-End MapFoldExists.
-
-Section DMergeDef.
-
-  Variable A : Set.
-
-  Definition DMerge := (MapFold (Map A) (Map A) (M0 A) (MapMerge A) [_:ad][m:(Map A)] m).
-
-  Lemma in_dom_DMerge_1 : (m:(Map (Map A))) (a:ad) (in_dom A a (DMerge m))=
-                              (Cases (MapSweep ? [_:ad][m0:(Map A)] (in_dom A a m0) m) of
-			           (SOME _) => true
-				 | _ => false
-		               end).
-  Proof.
-    Unfold DMerge. Intros.
-    Rewrite (MapFold_distr_l (Map A) (Map A) (M0 A) (MapMerge A) bool false
-               orb ad (in_dom A) [c:ad](refl_equal ? ?) (in_dom_merge A)).
-    Apply MapFold_orb.
-  Qed.
-
-  Lemma in_dom_DMerge_2 : (m:(Map (Map A))) (a:ad) (in_dom A a (DMerge m))=true ->
-                               {b:ad & {m0:(Map A) | (MapGet ? m b)=(SOME ? m0) /\
-			                             (in_dom A a m0)=true}}.
-  Proof.
-    Intros m a. Rewrite in_dom_DMerge_1.
-    Elim (option_sum ? (MapSweep (Map A) [_:ad][m0:(Map A)](in_dom A a m0) m)).
-    Intro H. Elim H. Intro r. Elim r. Intros b m0 H0. Intro. Split with b. Split with m0.
-    Split. Exact (MapSweep_semantics_2 ? ? ? ? ? H0).
-    Exact (MapSweep_semantics_1 ? ? ? ? ? H0).
-    Intro H. Rewrite H. Intro. Discriminate H0.
-  Qed.
-
-  Lemma in_dom_DMerge_3 : (m:(Map (Map A))) (a,b:ad) (m0:(Map A))
-      (MapGet ? m a)=(SOME ? m0) -> (in_dom A b m0)=true -> 
-        (in_dom A b (DMerge m))=true.
-  Proof.
-    Intros m a b m0 H H0. Rewrite in_dom_DMerge_1.
-    Elim (MapSweep_semantics_4 ? [_:ad][m'0:(Map A)](in_dom A b m'0) ? ? ? H H0).
-    Intros a' H1. Elim H1. Intros m'0 H2. Rewrite H2. Reflexivity.
-  Qed.
-
-End DMergeDef.
diff --git a/theories7/IntMap/Mapiter.v b/theories7/IntMap/Mapiter.v
deleted file mode 100644
index 144572fd..00000000
--- a/theories7/IntMap/Mapiter.v
+++ /dev/null
@@ -1,527 +0,0 @@
-(************************************************************************)
-(*  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: Mapiter.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $	 i*)
-
-Require Bool.
-Require Sumbool.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require Mapaxioms.
-Require Fset.
-Require PolyList.
-
-Section MapIter.
-
-  Variable A : Set.
-
-  Section MapSweepDef.
-
-  Variable f:ad->A->bool.
-
-  Definition MapSweep2 := [a0:ad; y:A] if (f a0 y) then (SOME ? (a0, y)) else (NONE ?).
-
-  Fixpoint MapSweep1 [pf:ad->ad; m:(Map A)] : (option (ad * A)) :=
-    Cases m of
-        M0 => (NONE ?)
-      | (M1 a y) => (MapSweep2 (pf a) y)
-      | (M2 m m') => Cases (MapSweep1 ([a:ad] (pf (ad_double a))) m) of
-                         (SOME r) => (SOME ? r)
-		       | NONE => (MapSweep1 ([a:ad] (pf (ad_double_plus_un a))) m')
-		     end
-    end.
-
-  Definition MapSweep := [m:(Map A)] (MapSweep1 ([a:ad] a) m).
-
-  Lemma MapSweep_semantics_1_1 : (m:(Map A)) (pf:ad->ad) (a:ad) (y:A)
-      (MapSweep1 pf m)=(SOME ? (a, y)) -> (f a y)=true.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Simpl. Intros a y pf a0 y0. Elim (sumbool_of_bool (f (pf a) y)). Intro H. Unfold MapSweep2.
-    Rewrite H. Intro H0. Inversion H0. Rewrite <- H3. Assumption.
-    Intro H. Unfold MapSweep2. Rewrite H. Intro H0. Discriminate H0.
-    Simpl. Intros. Elim (option_sum ad*A (MapSweep1 [a0:ad](pf (ad_double a0)) m0)).
-    Intro H2. Elim H2. Intros r H3. Rewrite H3 in H1. Inversion H1. Rewrite H5 in H3.
-    Exact (H [a0:ad](pf (ad_double a0)) a y H3).
-    Intro H2. Rewrite H2 in H1. Exact (H0 [a0:ad](pf (ad_double_plus_un a0)) a y H1).
-  Qed.
-
-  Lemma MapSweep_semantics_1 : (m:(Map A)) (a:ad) (y:A)
-      (MapSweep m)=(SOME ? (a, y)) -> (f a y)=true.
-  Proof.
-    Intros. Exact (MapSweep_semantics_1_1 m [a:ad]a a y H).
-  Qed.
-
-  Lemma MapSweep_semantics_2_1 : (m:(Map A)) (pf:ad->ad) (a:ad) (y:A)
-      	(MapSweep1 pf m)=(SOME ? (a, y)) -> {a':ad | a=(pf a')}.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Simpl. Unfold MapSweep2. Intros a y pf a0 y0. Case (f (pf a) y). Intros. Split with a.
-    Inversion H. Reflexivity.
-    Intro. Discriminate H.
-    Intros m0 H m1 H0 pf a y. Simpl.
-    Elim (option_sum ad*A (MapSweep1 [a0:ad](pf (ad_double a0)) m0)). Intro H1. Elim H1.
-    Intros r H2. Rewrite H2. Intro H3. Inversion H3. Rewrite H5 in H2.
-    Elim (H [a0:ad](pf (ad_double a0)) a y H2). Intros a0 H6. Split with (ad_double a0).
-    Assumption.
-    Intro H1. Rewrite H1. Intro H2. Elim (H0 [a0:ad](pf (ad_double_plus_un a0)) a y H2).
-    Intros a0 H3. Split with (ad_double_plus_un a0). Assumption.
-  Qed.
-
-  Lemma MapSweep_semantics_2_2 : (m:(Map A))
-      (pf,fp:ad->ad) ((a0:ad) (fp (pf a0))=a0) -> (a:ad) (y:A)
-      	(MapSweep1 pf m)=(SOME ? (a, y)) -> (MapGet A m (fp a))=(SOME ? y).
-  Proof.
-    Induction m. Intros. Discriminate H0.
-    Simpl. Intros a y pf fp H a0 y0. Unfold MapSweep2. Elim (sumbool_of_bool (f (pf a) y)).
-    Intro H0. Rewrite H0. Intro H1. Inversion H1. Rewrite (H a). Rewrite (ad_eq_correct a).
-    Reflexivity.
-    Intro H0. Rewrite H0. Intro H1. Discriminate H1.
-    Intros. Rewrite (MapGet_M2_bit_0_if A m0 m1 (fp a)). Elim (sumbool_of_bool (ad_bit_0 (fp a))).
-    Intro H3. Rewrite H3. Elim (option_sum ad*A (MapSweep1 [a0:ad](pf (ad_double a0)) m0)).
-    Intro H4. Simpl in H2. Apply (H0 [a0:ad](pf (ad_double_plus_un a0)) [a0:ad](ad_div_2 (fp a0))).
-    Intro. Rewrite H1. Apply ad_double_plus_un_div_2.
-    Elim (option_sum ad*A (MapSweep1 [a0:ad](pf (ad_double a0)) m0)). Intro H5. Elim H5.
-    Intros r H6. Rewrite H6 in H2. Inversion H2. Rewrite H8 in H6.
-    Elim (MapSweep_semantics_2_1 m0 [a0:ad](pf (ad_double a0)) a y H6). Intros a0 H9.
-    Rewrite H9 in H3. Rewrite (H1 (ad_double a0)) in H3. Rewrite (ad_double_bit_0 a0) in H3.
-    Discriminate H3.
-    Intro H5. Rewrite H5 in H2. Assumption.
-    Intro H4. Simpl in H2. Rewrite H4 in H2.
-    Apply (H0 [a0:ad](pf (ad_double_plus_un a0)) [a0:ad](ad_div_2 (fp a0))). Intro.
-    Rewrite H1. Apply ad_double_plus_un_div_2.
-    Assumption.
-    Intro H3. Rewrite H3. Simpl in H2.
-    Elim (option_sum ad*A (MapSweep1 [a0:ad](pf (ad_double a0)) m0)). Intro H4. Elim H4.
-    Intros r H5. Rewrite H5 in H2. Inversion H2. Rewrite H7 in H5.
-    Apply (H [a0:ad](pf (ad_double a0)) [a0:ad](ad_div_2 (fp a0))). Intro. Rewrite H1.
-    Apply ad_double_div_2.
-    Assumption.
-    Intro H4. Rewrite H4 in H2.
-    Elim (MapSweep_semantics_2_1 m1 [a0:ad](pf (ad_double_plus_un a0)) a y H2).
-    Intros a0 H5. Rewrite H5 in H3. Rewrite (H1 (ad_double_plus_un a0)) in H3.
-    Rewrite (ad_double_plus_un_bit_0 a0) in H3. Discriminate H3.
-  Qed.
-
-  Lemma MapSweep_semantics_2 : (m:(Map A)) (a:ad) (y:A)
-      (MapSweep m)=(SOME ? (a, y)) -> (MapGet A m a)=(SOME ? y).
-  Proof.
-    Intros.
-    Exact (MapSweep_semantics_2_2 m [a0:ad]a0 [a0:ad]a0 [a0:ad](refl_equal ad a0) a y H).
-  Qed.
-
-  Lemma MapSweep_semantics_3_1 : (m:(Map A)) (pf:ad->ad)
-      (MapSweep1 pf m)=(NONE ?) ->
-        (a:ad) (y:A) (MapGet A m a)=(SOME ? y) -> (f (pf a) y)=false.
-  Proof.
-    Induction m. Intros. Discriminate H0.
-    Simpl. Unfold MapSweep2. Intros a y pf. Elim (sumbool_of_bool (f (pf a) y)). Intro H.
-    Rewrite H. Intro. Discriminate H0.
-    Intro H. Rewrite H. Intros H0 a0 y0. Elim (sumbool_of_bool (ad_eq a a0)). Intro H1. Rewrite H1.
-    Intro H2. Inversion H2. Rewrite <- H4. Rewrite <- (ad_eq_complete ? ? H1). Assumption.
-    Intro H1. Rewrite H1. Intro. Discriminate H2.
-    Intros. Simpl in H1. Elim (option_sum ad*A (MapSweep1 [a:ad](pf (ad_double a)) m0)).
-    Intro H3. Elim H3. Intros r H4. Rewrite H4 in H1. Discriminate H1.
-    Intro H3. Rewrite H3 in H1. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H4.
-    Rewrite (MapGet_M2_bit_0_1 A a H4 m0 m1) in H2. Rewrite <- (ad_div_2_double_plus_un a H4).
-    Exact (H0 [a:ad](pf (ad_double_plus_un a)) H1 (ad_div_2 a) y H2).
-    Intro H4. Rewrite (MapGet_M2_bit_0_0 A a H4 m0 m1) in H2. Rewrite <- (ad_div_2_double a H4).
-    Exact (H [a:ad](pf (ad_double a)) H3 (ad_div_2 a) y H2).
-  Qed.
-
-  Lemma MapSweep_semantics_3 : (m:(Map A))
-      (MapSweep m)=(NONE ?) -> (a:ad) (y:A) (MapGet A m a)=(SOME ? y) -> 
-        (f a y)=false.
-  Proof.
-    Intros.
-    Exact (MapSweep_semantics_3_1 m [a0:ad]a0 H a y H0).
-  Qed.
-
-  Lemma MapSweep_semantics_4_1 : (m:(Map A)) (pf:ad->ad) (a:ad) (y:A)
-      (MapGet A m a)=(SOME A y) -> (f (pf a) y)=true ->
-      	{a':ad & {y':A | (MapSweep1 pf m)=(SOME ? (a', y'))}}.
-  Proof.
-    Induction m. Intros. Discriminate H.
-    Intros. Elim (sumbool_of_bool (ad_eq a a1)). Intro H1. Split with (pf a1). Split with y.
-    Rewrite (ad_eq_complete ? ? H1). Unfold MapSweep1 MapSweep2.
-    Rewrite (ad_eq_complete ? ? H1) in H. Rewrite (M1_semantics_1 ? a1 a0) in H.
-    Inversion H. Rewrite H0. Reflexivity.
-
-    Intro H1. Rewrite (M1_semantics_2 ? a a1 a0 H1) in H. Discriminate H.
-
-    Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H3.
-    Rewrite (MapGet_M2_bit_0_1 ? ? H3 m0 m1) in H1.
-    Rewrite <- (ad_div_2_double_plus_un a H3) in H2.
-    Elim (H0 [a0:ad](pf (ad_double_plus_un a0)) (ad_div_2 a) y H1 H2). Intros a'' H4. Elim H4.
-    Intros y'' H5. Simpl. Elim (option_sum ? (MapSweep1 [a:ad](pf (ad_double a)) m0)).
-    Intro H6. Elim H6. Intro r. Elim r. Intros a''' y''' H7. Rewrite H7. Split with a'''.
-    Split with y'''. Reflexivity.
-    Intro H6. Rewrite H6. Split with a''. Split with y''. Assumption.
-    Intro H3. Rewrite (MapGet_M2_bit_0_0 ? ? H3 m0 m1) in H1.
-    Rewrite <- (ad_div_2_double a H3) in H2.
-    Elim (H [a0:ad](pf (ad_double a0)) (ad_div_2 a) y H1 H2). Intros a'' H4. Elim H4.
-    Intros y'' H5. Split with a''. Split with y''. Simpl. Rewrite H5. Reflexivity.
-  Qed.
-
-  Lemma MapSweep_semantics_4 : (m:(Map A)) (a:ad) (y:A)
-      (MapGet A m a)=(SOME A y) -> (f a y)=true ->
-      	{a':ad & {y':A | (MapSweep m)=(SOME ? (a', y'))}}.
-  Proof.
-    Intros. Exact (MapSweep_semantics_4_1 m [a0:ad]a0 a y H H0).
-  Qed.
-
-  End MapSweepDef.
-
-  Variable B : Set.
-
-  Fixpoint MapCollect1 [f:ad->A->(Map B); pf:ad->ad; m:(Map A)] : (Map B) :=
-    Cases m of
-        M0 => (M0 B)
-      | (M1 a y) => (f (pf a) y)
-      | (M2 m1 m2) => (MapMerge B (MapCollect1 f [a0:ad] (pf (ad_double a0)) m1)
-                                  (MapCollect1 f [a0:ad] (pf (ad_double_plus_un a0)) m2))
-    end.
-
-  Definition MapCollect := [f:ad->A->(Map B); m:(Map A)] (MapCollect1 f [a:ad]a m).
-
-  Section MapFoldDef.
-
-    Variable M : Set.
-    Variable neutral : M.
-    Variable op : M -> M -> M.
-
-    Fixpoint MapFold1 [f:ad->A->M; pf:ad->ad; m:(Map A)] : M :=
-      Cases m of
-      	  M0 => neutral
-        | (M1 a y) => (f (pf a) y)
-        | (M2 m1 m2) => (op (MapFold1 f [a0:ad] (pf (ad_double a0)) m1)
-                            (MapFold1 f [a0:ad] (pf (ad_double_plus_un a0)) m2))
-      end.
-
-    Definition MapFold := [f:ad->A->M; m:(Map A)] (MapFold1 f [a:ad]a m).
-
-    Lemma MapFold_empty : (f:ad->A->M) (MapFold f (M0 A))=neutral.
-    Proof.
-      Trivial.
-    Qed.
-
-    Lemma MapFold_M1 : (f:ad->A->M) (a:ad) (y:A) (MapFold f (M1 A a y)) = (f a y).
-    Proof.
-      Trivial.
-    Qed.
-
-    Variable State : Set.
-    Variable f:State -> ad -> A -> State * M.
-
-    Fixpoint MapFold1_state [state:State; pf:ad->ad; m:(Map A)]
-                            : State * M :=
-      Cases m of
-          M0 => (state, neutral)
-	| (M1 a y) => (f state (pf a) y)
-	| (M2 m1 m2) =>
-          Cases (MapFold1_state state [a0:ad] (pf (ad_double a0)) m1) of
-              (state1, x1) =>
-	      Cases (MapFold1_state state1 [a0:ad] (pf (ad_double_plus_un a0)) m2) of
-	          (state2, x2) => (state2, (op x1 x2))
-	      end
-          end
-      end.
-
-    Definition MapFold_state := [state:State] (MapFold1_state state [a:ad]a).
-
-    Lemma pair_sp : (B,C:Set) (x:B*C) x=(Fst x, Snd x).
-    Proof.
-      Induction x. Trivial.
-    Qed.
-
-    Lemma MapFold_state_stateless_1 : (m:(Map A)) (g:ad->A->M) (pf:ad->ad)
-        ((state:State) (a:ad) (y:A) (Snd (f state a y))=(g a y)) ->
-      	  (state:State)
-      	    (Snd (MapFold1_state state pf m))=(MapFold1 g pf m).
-    Proof.
-      Induction m. Trivial.
-      Intros. Simpl. Apply H.
-      Intros. Simpl. Rewrite (pair_sp ? ?
-          (MapFold1_state state [a0:ad](pf (ad_double a0)) m0)).
-      Rewrite (H g [a0:ad](pf (ad_double a0)) H1 state).
-      Rewrite (pair_sp ? ?
-          (MapFold1_state
-            (Fst (MapFold1_state state [a0:ad](pf (ad_double a0)) m0))
-            [a0:ad](pf (ad_double_plus_un a0)) m1)).
-      Simpl.
-      Rewrite (H0 g [a0:ad](pf (ad_double_plus_un a0)) H1
-          (Fst (MapFold1_state state [a0:ad](pf (ad_double a0)) m0))).
-      Reflexivity.
-    Qed.
-
-    Lemma MapFold_state_stateless : (g:ad->A->M)
-        ((state:State) (a:ad) (y:A) (Snd (f state a y))=(g a y)) ->
-      	  (state:State) (m:(Map A))
-      	    (Snd (MapFold_state state m))=(MapFold g m).
-    Proof.
-      Intros. Exact (MapFold_state_stateless_1 m g [a0:ad]a0 H state).
-    Qed.
-
-  End MapFoldDef.
-
-  Lemma MapCollect_as_Fold : (f:ad->A->(Map B)) (m:(Map A))
-      (MapCollect f m)=(MapFold (Map B) (M0 B) (MapMerge B) f m).
-  Proof.
-    Induction m;Trivial.
-  Qed.
-
-  Definition alist := (list (ad*A)).
-  Definition anil := (nil (ad*A)).
-  Definition acons := (!cons (ad*A)).
-  Definition aapp := (!app (ad*A)).
-
-  Definition alist_of_Map := (MapFold alist anil aapp [a:ad;y:A] (acons (pair ? ? a y) anil)).
-
-  Fixpoint alist_semantics [l:alist] : ad -> (option A) :=
-    Cases l of
-        nil => [_:ad] (NONE A)
-      | (cons (a, y) l') => [a0:ad] if (ad_eq a a0) then (SOME A y) else (alist_semantics l' a0)
-    end.
-
-  Lemma alist_semantics_app : (l,l':alist) (a:ad)
-      (alist_semantics (aapp l l') a)=
-      (Cases (alist_semantics l a) of
-           NONE => (alist_semantics l' a)
-	 | (SOME y) => (SOME A y)
-       end).
-  Proof.
-    Unfold aapp. Induction l. Trivial.
-    Intros. Elim a. Intros a1 y1. Simpl. Case (ad_eq a1 a0). Reflexivity.
-    Apply H.
-  Qed.
-
-  Lemma alist_of_Map_semantics_1_1 : (m:(Map A)) (pf:ad->ad) (a:ad) (y:A)
-      (alist_semantics (MapFold1 alist anil aapp [a0:ad][y:A](acons (a0,y) anil) pf m) a)
-      =(SOME A y) -> {a':ad | a=(pf a')}.
-  Proof.
-    Induction m. Simpl. Intros. Discriminate H.
-    Simpl. Intros a y pf a0 y0. Elim (sumbool_of_bool (ad_eq (pf a) a0)). Intro H. Rewrite H.
-    Intro H0. Split with a. Rewrite (ad_eq_complete ? ? H). Reflexivity.
-    Intro H. Rewrite H. Intro H0. Discriminate H0.
-    Intros. Change (alist_semantics
-         (aapp
-           (MapFold1 alist anil aapp [a0:ad][y:A](acons (a0,y) anil)
-             [a0:ad](pf (ad_double a0)) m0)
-           (MapFold1 alist anil aapp [a0:ad][y:A](acons (a0,y) anil)
-             [a0:ad](pf (ad_double_plus_un a0)) m1)) a)=(SOME A y)  in H1.
-    Rewrite (alist_semantics_app
-          (MapFold1 alist anil aapp [a0:ad][y0:A](acons (a0,y0) anil)
-            [a0:ad](pf (ad_double a0)) m0)
-          (MapFold1 alist anil aapp [a0:ad][y0:A](acons (a0,y0) anil)
-            [a0:ad](pf (ad_double_plus_un a0)) m1) a) in H1.
-    Elim (option_sum A
-       (alist_semantics
-         (MapFold1 alist anil aapp [a0:ad][y0:A](acons (a0,y0) anil)
-           [a0:ad](pf (ad_double a0)) m0) a)).
-    Intro H2. Elim H2. Intros y0 H3. Elim (H [a0:ad](pf (ad_double a0)) a y0 H3). Intros a0 H4.
-    Split with (ad_double a0). Assumption.
-    Intro H2. Rewrite H2 in H1. Elim (H0 [a0:ad](pf (ad_double_plus_un a0)) a y H1).
-    Intros a0 H3. Split with (ad_double_plus_un a0). Assumption.
-  Qed.
-
-  Definition ad_inj := [pf:ad->ad] (a0,a1:ad) (pf a0)=(pf a1) -> a0=a1.
-
-  Lemma ad_comp_double_inj : 
-      (pf:ad->ad) (ad_inj pf) -> (ad_inj [a0:ad] (pf (ad_double a0))).
-  Proof.
-    Unfold ad_inj. Intros. Apply ad_double_inj. Exact (H ? ? H0).
-  Qed.
-
-  Lemma ad_comp_double_plus_un_inj : (pf:ad->ad) (ad_inj pf) ->
-      (ad_inj [a0:ad] (pf (ad_double_plus_un a0))).
-  Proof.
-    Unfold ad_inj. Intros. Apply ad_double_plus_un_inj. Exact (H ? ? H0).
-  Qed.
-
-  Lemma alist_of_Map_semantics_1 : (m:(Map A)) (pf:ad->ad) (ad_inj pf) ->
-      (a:ad) (MapGet A m a)=(alist_semantics (MapFold1 alist anil aapp
-                                                   [a0:ad;y:A] (acons (pair ? ? a0 y) anil) pf m)
-                                      (pf a)).
-  Proof.
-    Induction m. Trivial.
-    Simpl. Intros. Elim (sumbool_of_bool (ad_eq a a1)). Intro H0. Rewrite H0.
-    Rewrite (ad_eq_complete ? ? H0). Rewrite (ad_eq_correct (pf a1)). Reflexivity.
-    Intro H0. Rewrite H0. Elim (sumbool_of_bool (ad_eq (pf a) (pf a1))). Intro H1.
-    Rewrite (H a a1 (ad_eq_complete ? ? H1)) in H0. Rewrite (ad_eq_correct a1) in H0.
-    Discriminate H0.
-    Intro H1. Rewrite H1. Reflexivity.
-    Intros. Change (MapGet A (M2 A m0 m1) a)
-        =(alist_semantics
-           (aapp
-             (MapFold1 alist anil aapp [a0:ad][y:A](acons (a0,y) anil)
-               [a0:ad](pf (ad_double a0)) m0)
-             (MapFold1 alist anil aapp [a0:ad][y:A](acons (a0,y) anil)
-               [a0:ad](pf (ad_double_plus_un a0)) m1)) (pf a)).
-    Rewrite alist_semantics_app. Rewrite (MapGet_M2_bit_0_if A m0 m1 a).
-    Elim (ad_double_or_double_plus_un a). Intro H2. Elim H2. Intros a0 H3. Rewrite H3.
-    Rewrite (ad_double_bit_0 a0).
-    Rewrite <- (H [a1:ad](pf (ad_double a1)) (ad_comp_double_inj pf H1) a0).
-    Rewrite ad_double_div_2. Case (MapGet A m0 a0).
-    Elim (option_sum A
-       (alist_semantics
-         (MapFold1 alist anil aapp [a1:ad][y:A](acons (a1,y) anil)
-           [a1:ad](pf (ad_double_plus_un a1)) m1) (pf (ad_double a0)))).
-    Intro H4. Elim H4. Intros y H5.
-    Elim (alist_of_Map_semantics_1_1 m1 [a1:ad](pf (ad_double_plus_un a1))
-          (pf (ad_double a0)) y H5).
-    Intros a1 H6. Cut (ad_bit_0 (ad_double a0))=(ad_bit_0 (ad_double_plus_un a1)).
-    Intro. Rewrite (ad_double_bit_0 a0) in H7. Rewrite (ad_double_plus_un_bit_0 a1) in H7.
-    Discriminate H7.
-    Rewrite (H1 (ad_double a0) (ad_double_plus_un a1) H6). Reflexivity.
-    Intro H4. Rewrite H4. Reflexivity.
-    Trivial.
-    Intro H2. Elim H2. Intros a0 H3. Rewrite H3. Rewrite (ad_double_plus_un_bit_0 a0).
-    Rewrite <- (H0 [a1:ad](pf (ad_double_plus_un a1)) (ad_comp_double_plus_un_inj pf H1) a0).
-    Rewrite ad_double_plus_un_div_2.
-    Elim (option_sum A
-       (alist_semantics
-         (MapFold1 alist anil aapp [a1:ad][y:A](acons (a1,y) anil)
-           [a1:ad](pf (ad_double a1)) m0) (pf (ad_double_plus_un a0)))).
-    Intro H4. Elim H4. Intros y H5.
-    Elim (alist_of_Map_semantics_1_1 m0 [a1:ad](pf (ad_double a1))
-       (pf (ad_double_plus_un a0)) y H5).
-    Intros a1 H6. Cut (ad_bit_0 (ad_double_plus_un a0))=(ad_bit_0 (ad_double a1)).
-    Intro H7. Rewrite (ad_double_plus_un_bit_0 a0) in H7. Rewrite (ad_double_bit_0 a1) in H7.
-    Discriminate H7.
-    Rewrite (H1 (ad_double_plus_un a0) (ad_double a1) H6). Reflexivity.
-    Intro H4. Rewrite H4. Reflexivity.
-  Qed.
-
-  Lemma alist_of_Map_semantics : (m:(Map A))
-      (eqm A (MapGet A m) (alist_semantics (alist_of_Map m))).
-  Proof.
-    Unfold eqm. Intros. Exact (alist_of_Map_semantics_1 m [a0:ad]a0 [a0,a1:ad][p:a0=a1]p a).
-  Qed.
-
-  Fixpoint Map_of_alist [l:alist] : (Map A) :=
-    Cases l of
-        nil => (M0 A)
-      | (cons (a, y) l') => (MapPut A (Map_of_alist l') a y)
-    end.
-
-  Lemma Map_of_alist_semantics : (l:alist)
-      (eqm A (alist_semantics l) (MapGet A (Map_of_alist l))).
-  Proof.
-    Unfold eqm. Induction l. Trivial.
-    Intros r l0 H a. Elim r. Intros a0 y0. Simpl. Elim (sumbool_of_bool (ad_eq a0 a)).
-    Intro H0. Rewrite H0. Rewrite (ad_eq_complete ? ? H0).
-    Rewrite (MapPut_semantics A (Map_of_alist l0) a y0 a). Rewrite (ad_eq_correct a).
-    Reflexivity.
-    Intro H0. Rewrite H0. Rewrite (MapPut_semantics A (Map_of_alist l0) a0 y0 a).
-    Rewrite H0. Apply H.
-  Qed.
-
-  Lemma Map_of_alist_of_Map : (m:(Map A)) (eqmap A (Map_of_alist (alist_of_Map m)) m).
-  Proof.
-    Unfold eqmap. Intro. Apply eqm_trans with f':=(alist_semantics (alist_of_Map m)).
-    Apply eqm_sym. Apply Map_of_alist_semantics.
-    Apply eqm_sym. Apply alist_of_Map_semantics.
-  Qed.
-
-  Lemma alist_of_Map_of_alist : (l:alist)
-      (eqm A (alist_semantics (alist_of_Map (Map_of_alist l))) (alist_semantics l)).
-  Proof.
-    Intro. Apply eqm_trans with f':=(MapGet A (Map_of_alist l)).
-    Apply eqm_sym. Apply alist_of_Map_semantics.
-    Apply eqm_sym. Apply Map_of_alist_semantics.
-  Qed.
-
-  Lemma fold_right_aapp : (M:Set) (neutral:M) (op:M->M->M)
-      ((a,b,c:M) (op (op a b) c)=(op a (op b c))) ->
-      ((a:M) (op neutral a)=a) ->
-      (f:ad->A->M) (l,l':alist)
-        (fold_right [r:ad*A][m:M] let (a,y)=r in (op (f a y) m) neutral
-                    (aapp l l'))=
-        (op (fold_right [r:ad*A][m:M] let (a,y)=r in (op (f a y) m) neutral l)
-            (fold_right [r:ad*A][m:M] let (a,y)=r in (op (f a y) m) neutral l'))
-.
-  Proof.
-    Induction l. Simpl. Intro. Rewrite H0. Reflexivity.
-    Intros r l0 H1 l'. Elim r. Intros a y. Simpl. Rewrite H. Rewrite (H1 l'). Reflexivity.
-  Qed.
-
-  Lemma MapFold_as_fold_1 : (M:Set) (neutral:M) (op:M->M->M)
-      ((a,b,c:M) (op (op a b) c)=(op a (op b c))) ->
-      ((a:M) (op neutral a)=a) ->
-      ((a:M) (op a neutral)=a) ->
-        (f:ad->A->M) (m:(Map A)) (pf:ad->ad)
-         (MapFold1 M neutral op f pf m)=
-         (fold_right [r:(ad*A)][m:M] let (a,y)=r in (op (f a y) m) neutral
-                    (MapFold1 alist anil aapp [a:ad;y:A] (acons (pair ? ? 
-a y) anil) pf m)).
-  Proof.
-    Induction m. Trivial.
-    Intros. Simpl. Rewrite H1. Reflexivity.
-    Intros. Simpl. Rewrite (fold_right_aapp M neutral op H H0 f).
-    Rewrite (H2 [a0:ad](pf (ad_double a0))). Rewrite (H3 [a0:ad](pf (ad_double_plus_un a0))).
-    Reflexivity.
-  Qed.
-
-  Lemma MapFold_as_fold : (M:Set) (neutral:M) (op:M->M->M)
-      ((a,b,c:M) (op (op a b) c)=(op a (op b c))) ->
-      ((a:M) (op neutral a)=a) ->
-      ((a:M) (op a neutral)=a) ->
-        (f:ad->A->M) (m:(Map A))
-         (MapFold M neutral op f m)=
-         (fold_right [r:(ad*A)][m:M] let (a,y)=r in (op (f a y) m) neutral
-  (alist_of_Map m)).
-  Proof.
-    Intros. Exact (MapFold_as_fold_1 M neutral op H H0 H1 f m [a0:ad]a0).
-  Qed.
-
-  Lemma alist_MapMerge_semantics : (m,m':(Map A))
-      (eqm A (alist_semantics (aapp (alist_of_Map m') (alist_of_Map m)))
-             (alist_semantics (alist_of_Map (MapMerge A m m')))).
-  Proof.
-    Unfold eqm. Intros. Rewrite alist_semantics_app. Rewrite <- (alist_of_Map_semantics m a).
-    Rewrite <- (alist_of_Map_semantics m' a).
-    Rewrite <- (alist_of_Map_semantics (MapMerge A m m') a).
-    Rewrite (MapMerge_semantics A m m' a). Reflexivity.
-  Qed.
-
-  Lemma alist_MapMerge_semantics_disjoint : (m,m':(Map A))
-        (eqmap A (MapDomRestrTo A A m m') (M0 A)) ->
-	  (eqm A (alist_semantics (aapp (alist_of_Map m) (alist_of_Map m')))
-	         (alist_semantics (alist_of_Map (MapMerge A m m')))).
-  Proof.
-    Unfold eqm. Intros. Rewrite alist_semantics_app. Rewrite <- (alist_of_Map_semantics m a).
-    Rewrite <- (alist_of_Map_semantics m' a).
-    Rewrite <- (alist_of_Map_semantics (MapMerge A m m') a). Rewrite (MapMerge_semantics A m m' a).
-    Elim (option_sum ? (MapGet A m a)). Intro H0. Elim H0. Intros y H1. Rewrite H1.
-    Elim (option_sum ? (MapGet A m' a)). Intro H2. Elim H2. Intros y' H3.
-    Cut (MapGet A (MapDomRestrTo A A m m') a)=(NONE A).
-    Rewrite (MapDomRestrTo_semantics A A m m' a). Rewrite H3. Rewrite H1. Intro. Discriminate H4.
-    Exact (H a).
-    Intro H2. Rewrite H2. Reflexivity.
-    Intro H0. Rewrite H0. Case (MapGet A m' a); Trivial.
-  Qed.
-
-  Lemma alist_semantics_disjoint_comm : (l,l':alist)
-      (eqmap A (MapDomRestrTo A A (Map_of_alist l) (Map_of_alist l')) (M0 A)) ->
-      	(eqm A (alist_semantics (aapp l l')) (alist_semantics (aapp l' l))).
-  Proof.
-    Unfold eqm. Intros. Rewrite (alist_semantics_app l l' a). Rewrite (alist_semantics_app l' l a).
-    Rewrite <- (alist_of_Map_of_alist l a). Rewrite <- (alist_of_Map_of_alist l' a).
-    Rewrite <- (alist_semantics_app (alist_of_Map (Map_of_alist l))
-                                    (alist_of_Map (Map_of_alist l')) a).
-    Rewrite <- (alist_semantics_app (alist_of_Map (Map_of_alist l'))
-                                    (alist_of_Map (Map_of_alist l)) a).
-    Rewrite (alist_MapMerge_semantics (Map_of_alist l) (Map_of_alist l') a).
-    Rewrite (alist_MapMerge_semantics_disjoint (Map_of_alist l) (Map_of_alist l') H a).
-    Reflexivity.
-  Qed.
-
-End MapIter.
-
diff --git a/theories7/IntMap/Maplists.v b/theories7/IntMap/Maplists.v
deleted file mode 100644
index f01ee3d8..00000000
--- a/theories7/IntMap/Maplists.v
+++ /dev/null
@@ -1,399 +0,0 @@
-(************************************************************************)
-(*  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: Maplists.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $	 i*)
-
-Require Addr.
-Require Addec.
-Require Map.
-Require Fset.
-Require Mapaxioms.
-Require Mapsubset.
-Require Mapcard.
-Require Mapcanon.
-Require Mapc.
-Require Bool.
-Require Sumbool.
-Require PolyList.
-Require Arith.
-Require Mapiter.
-Require Mapfold.
-
-Section MapLists.
-
-  Fixpoint ad_in_list [a:ad;l:(list ad)] : bool :=
-    Cases l of
-	nil => false
-      | (cons a' l') => (orb (ad_eq a a') (ad_in_list a l'))
-    end.
-
-  Fixpoint ad_list_stutters [l:(list ad)] : bool :=
-    Cases l of
-	nil => false
-      | (cons a l') => (orb (ad_in_list a l') (ad_list_stutters l'))
-    end.
-
-  Lemma ad_in_list_forms_circuit : (x:ad) (l:(list ad)) (ad_in_list x l)=true ->
-      {l1 : (list ad) & {l2 : (list ad) | l=(app l1 (cons x l2))}}.
-  Proof.
-    Induction l. Intro. Discriminate H.
-    Intros. Elim (sumbool_of_bool (ad_eq x a)). Intro H1. Simpl in H0. Split with (nil ad).
-    Split with l0. Rewrite (ad_eq_complete ? ? H1). Reflexivity.
-    Intro H2. Simpl in H0. Rewrite H2 in H0. Simpl in H0. Elim (H H0). Intros l'1 H3.
-    Split with (cons a l'1). Elim H3. Intros l2 H4. Split with l2. Rewrite H4. Reflexivity.
-  Qed.
-
-  Lemma ad_list_stutters_has_circuit : (l:(list ad)) (ad_list_stutters l)=true ->
-      {x:ad & {l0 : (list ad) & {l1 : (list ad) & {l2 : (list ad) |
-        l=(app l0 (cons x (app l1 (cons x l2))))}}}}.
-  Proof.
-    Induction l. Intro. Discriminate H.
-    Intros. Simpl in H0. Elim (orb_true_elim ? ? H0). Intro H1. Split with a.
-    Split with (nil ad). Simpl. Elim (ad_in_list_forms_circuit a l0 H1). Intros l1 H2.
-    Split with l1. Elim H2. Intros l2 H3. Split with l2. Rewrite H3. Reflexivity.
-    Intro H1. Elim (H H1). Intros x H2. Split with x. Elim H2. Intros l1 H3.
-    Split with (cons a l1). Elim H3. Intros l2 H4. Split with l2. Elim H4. Intros l3 H5.
-    Split with l3. Rewrite H5. Reflexivity.
-  Qed.
-
-  Fixpoint Elems [l:(list ad)] : FSet :=
-    Cases l of
-	nil => (M0 unit)
-      | (cons a l') => (MapPut ? (Elems l') a tt)
-    end.
-
-  Lemma Elems_canon : (l:(list ad)) (mapcanon ? (Elems l)).
-  Proof.
-    Induction l. Exact (M0_canon unit).
-    Intros. Simpl. Apply MapPut_canon. Assumption.
-  Qed.
-
-  Lemma Elems_app : (l,l':(list ad)) (Elems (app l l'))=(FSetUnion (Elems l) (Elems l')).
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite (MapPut_as_Merge_c unit (Elems l0)).
-    Rewrite (MapPut_as_Merge_c unit (Elems (app l0 l'))).
-    Change (FSetUnion (Elems (app l0 l')) (M1 unit a tt))
-           =(FSetUnion (FSetUnion (Elems l0) (M1 unit a tt)) (Elems l')).
-    Rewrite FSetUnion_comm_c. Rewrite (FSetUnion_comm_c (Elems l0) (M1 unit a tt)).
-    Rewrite FSetUnion_assoc_c. Rewrite (H l'). Reflexivity.
-    Apply M1_canon.
-    Apply Elems_canon.
-    Apply Elems_canon.
-    Apply Elems_canon.
-    Apply M1_canon.
-    Apply Elems_canon.
-    Apply M1_canon.
-    Apply Elems_canon.
-    Apply Elems_canon.
-  Qed.
-
-  Lemma Elems_rev : (l:(list ad)) (Elems (rev l))=(Elems l).
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite Elems_app. Simpl. Rewrite (MapPut_as_Merge_c unit (Elems l0)).
-    Rewrite H. Reflexivity.
-    Apply Elems_canon.
-  Qed.
-
-  Lemma ad_in_elems_in_list : (l:(list ad)) (a:ad) (in_FSet a (Elems l))=(ad_in_list a l).
-  Proof.
-    Induction l. Trivial.
-    Simpl. Unfold in_FSet. Intros. Rewrite (in_dom_put ? (Elems l0) a tt a0).
-    Rewrite (H a0). Reflexivity.
-  Qed.
-
-  Lemma ad_list_not_stutters_card : (l:(list ad)) (ad_list_stutters l)=false ->
-      	  (length l)=(MapCard ? (Elems l)).
-  Proof.
-    Induction l. Trivial.
-    Simpl. Intros. Rewrite MapCard_Put_2_conv. Rewrite H. Reflexivity.
-    Elim (orb_false_elim ? ? H0). Trivial.
-    Elim (sumbool_of_bool (in_FSet a (Elems l0))). Rewrite ad_in_elems_in_list.
-    Intro H1. Rewrite H1 in H0. Discriminate H0.
-    Exact (in_dom_none unit (Elems l0) a).
-  Qed.
-
-  Lemma ad_list_card : (l:(list ad)) (le (MapCard ? (Elems l)) (length l)).
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Apply le_trans with m:=(S (MapCard ? (Elems l0))). Apply MapCard_Put_ub.
-    Apply le_n_S. Assumption.
-  Qed.
-
-  Lemma ad_list_stutters_card : (l:(list ad)) (ad_list_stutters l)=true ->
-      	 (lt (MapCard ? (Elems l)) (length l)).
-  Proof.
-    Induction l. Intro. Discriminate H.
-    Intros. Simpl. Simpl in H0. Elim (orb_true_elim ? ? H0). Intro H1.
-    Rewrite <- (ad_in_elems_in_list l0 a) in H1. Elim (in_dom_some ? ? ? H1). Intros y H2.
-    Rewrite (MapCard_Put_1_conv ? ? ? ? tt H2). Apply le_lt_trans with m:=(length l0).
-    Apply ad_list_card.
-    Apply lt_n_Sn.
-    Intro H1. Apply le_lt_trans with m:=(S (MapCard ? (Elems l0))). Apply MapCard_Put_ub.
-    Apply lt_n_S. Apply H. Assumption.
-  Qed.
-
-  Lemma ad_list_not_stutters_card_conv : (l:(list ad)) (length l)=(MapCard ? (Elems l)) ->
-      (ad_list_stutters l)=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_list_stutters l)). Intro H0.
-    Cut (lt (MapCard ? (Elems l)) (length l)). Intro. Rewrite H in H1. Elim (lt_n_n ? H1).
-    Exact (ad_list_stutters_card ? H0).
-    Trivial.
-  Qed.
-
-  Lemma ad_list_stutters_card_conv : (l:(list ad)) (lt (MapCard ? (Elems l)) (length l)) ->
-      (ad_list_stutters l)=true.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_list_stutters l)). Trivial.
-    Intro H0. Rewrite (ad_list_not_stutters_card ? H0) in H. Elim (lt_n_n ? H).
-  Qed.
-
-  Lemma ad_in_list_l : (l,l':(list ad)) (a:ad) (ad_in_list a l)=true ->
-      (ad_in_list a (app l l'))=true.
-  Proof.
-    Induction l. Intros. Discriminate H.
-    Intros. Simpl. Simpl in H0. Elim (orb_true_elim ? ? H0). Intro H1. Rewrite H1. Reflexivity.
-    Intro H1. Rewrite (H l' a0 H1). Apply orb_b_true.
-  Qed.
-
-  Lemma ad_list_stutters_app_l : (l,l':(list ad)) (ad_list_stutters l)=true ->
-      (ad_list_stutters (app l l'))=true.
-  Proof.
-    Induction l. Intros. Discriminate H.
-    Intros. Simpl. Simpl in H0. Elim (orb_true_elim ? ? H0). Intro H1.
-    Rewrite (ad_in_list_l l0 l' a H1). Reflexivity.
-    Intro H1. Rewrite (H l' H1). Apply orb_b_true.
-  Qed.
-
-  Lemma ad_in_list_r : (l,l':(list ad)) (a:ad) (ad_in_list a l')=true ->
-      (ad_in_list a (app l l'))=true.
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite (H l' a0 H0). Apply orb_b_true. 
-  Qed.
-
-  Lemma ad_list_stutters_app_r : (l,l':(list ad)) (ad_list_stutters l')=true ->
-      (ad_list_stutters (app l l'))=true.
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite (H l' H0). Apply orb_b_true.
-  Qed.
-
-  Lemma ad_list_stutters_app_conv_l : (l,l':(list ad)) (ad_list_stutters (app l l'))=false ->
-      (ad_list_stutters l)=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_list_stutters l)). Intro H0.
-    Rewrite (ad_list_stutters_app_l l l' H0) in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma ad_list_stutters_app_conv_r : (l,l':(list ad)) (ad_list_stutters (app l l'))=false ->
-      (ad_list_stutters l')=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_list_stutters l')). Intro H0.
-    Rewrite (ad_list_stutters_app_r l l' H0) in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma ad_in_list_app_1 : (l,l':(list ad)) (x:ad) (ad_in_list x (app l (cons x l')))=true.
-  Proof.
-    Induction l. Simpl. Intros. Rewrite (ad_eq_correct x). Reflexivity.
-    Intros. Simpl. Rewrite (H l' x). Apply orb_b_true.
-  Qed.
-
-  Lemma ad_in_list_app : (l,l':(list ad)) (x:ad)
-      (ad_in_list x (app l l'))=(orb (ad_in_list x l) (ad_in_list x l')).
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite <- orb_assoc. Rewrite (H l' x). Reflexivity.
-  Qed.
-
-  Lemma ad_in_list_rev : (l:(list ad)) (x:ad)
-      (ad_in_list x (rev l))=(ad_in_list x l).
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite ad_in_list_app. Rewrite (H x). Simpl. Rewrite orb_b_false.
-    Apply orb_sym.
-  Qed.
-
-  Lemma ad_list_has_circuit_stutters : (l0,l1,l2:(list ad)) (x:ad)
-      (ad_list_stutters (app l0 (cons x (app l1 (cons x l2)))))=true.
-  Proof.
-    Induction l0. Simpl. Intros. Rewrite (ad_in_list_app_1 l1 l2 x). Reflexivity.
-    Intros. Simpl. Rewrite (H l1 l2 x). Apply orb_b_true.
-  Qed.
-
-  Lemma ad_list_stutters_prev_l : (l,l':(list ad)) (x:ad) (ad_in_list x l)=true ->
-      (ad_list_stutters (app l (cons x l')))=true.
-  Proof.
-    Intros. Elim (ad_in_list_forms_circuit ? ? H). Intros l0 H0. Elim H0. Intros l1 H1.
-    Rewrite H1. Rewrite app_ass. Simpl. Apply ad_list_has_circuit_stutters.
-  Qed.
-
-  Lemma ad_list_stutters_prev_conv_l : (l,l':(list ad)) (x:ad)
-      (ad_list_stutters (app l (cons x l')))=false -> (ad_in_list x l)=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_in_list x l)). Intro H0.
-    Rewrite (ad_list_stutters_prev_l l l' x H0) in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma ad_list_stutters_prev_r : (l,l':(list ad)) (x:ad) (ad_in_list x l')=true ->
-      (ad_list_stutters (app l (cons x l')))=true.
-  Proof.
-    Intros. Elim (ad_in_list_forms_circuit ? ? H). Intros l0 H0. Elim H0. Intros l1 H1.
-    Rewrite H1. Apply ad_list_has_circuit_stutters.
-  Qed.
-
-  Lemma ad_list_stutters_prev_conv_r : (l,l':(list ad)) (x:ad)
-      (ad_list_stutters (app l (cons x l')))=false -> (ad_in_list x l')=false.
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_in_list x l')). Intro H0.
-    Rewrite (ad_list_stutters_prev_r l l' x H0) in H. Discriminate H.
-    Trivial.
-  Qed.
-
-  Lemma ad_list_Elems : (l,l':(list ad)) (MapCard ? (Elems l))=(MapCard ? (Elems l')) ->
-      (length l)=(length l') ->
-        (ad_list_stutters l)=(ad_list_stutters l').
-  Proof.
-    Intros. Elim (sumbool_of_bool (ad_list_stutters l)). Intro H1. Rewrite H1. Apply sym_eq.
-    Apply ad_list_stutters_card_conv. Rewrite <- H. Rewrite <- H0. Apply ad_list_stutters_card.
-    Assumption.
-    Intro H1. Rewrite H1. Apply sym_eq. Apply ad_list_not_stutters_card_conv. Rewrite <- H.
-    Rewrite <- H0. Apply ad_list_not_stutters_card. Assumption.
-  Qed.
-
-  Lemma ad_list_app_length : (l,l':(list ad)) (length (app l l'))=(plus (length l) (length l')).
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite (H l'). Reflexivity.
-  Qed.
-
-  Lemma ad_list_stutters_permute : (l,l':(list ad))
-      (ad_list_stutters (app l l'))=(ad_list_stutters (app l' l)).
-  Proof.
-    Intros. Apply ad_list_Elems. Rewrite Elems_app. Rewrite Elems_app.
-    Rewrite (FSetUnion_comm_c ? ? (Elems_canon l) (Elems_canon l')). Reflexivity.
-    Rewrite ad_list_app_length. Rewrite ad_list_app_length. Apply plus_sym.
-  Qed.
-
-  Lemma ad_list_rev_length : (l:(list ad)) (length (rev l))=(length l).
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite ad_list_app_length. Simpl. Rewrite H. Rewrite <- plus_Snm_nSm.
-    Rewrite <- plus_n_O. Reflexivity.
-  Qed.
-
-  Lemma ad_list_stutters_rev : (l:(list ad)) (ad_list_stutters (rev l))=(ad_list_stutters l).
-  Proof.
-    Intros. Apply ad_list_Elems. Rewrite Elems_rev. Reflexivity.
-    Apply ad_list_rev_length.
-  Qed.
-
-  Lemma ad_list_app_rev : (l,l':(list ad)) (x:ad)
-      (app (rev l) (cons x l'))=(app (rev (cons x l)) l').
-  Proof.
-    Induction l. Trivial.
-    Intros. Simpl. Rewrite (app_ass (rev l0) (cons a (nil ad)) (cons x l')). Simpl.
-    Rewrite (H (cons x l') a). Simpl.
-    Rewrite (app_ass (rev l0) (cons a (nil ad)) (cons x (nil ad))). Simpl.
-    Rewrite app_ass. Simpl. Rewrite app_ass. Reflexivity.
-  Qed.
-
-  Section ListOfDomDef.
-
-  Variable A : Set.
-
-  Definition ad_list_of_dom :=
-      (MapFold A (list ad) (nil ad) (!app ad) [a:ad][_:A] (cons a (nil ad))).
-
-  Lemma ad_in_list_of_dom_in_dom : (m:(Map A)) (a:ad)
-      (ad_in_list a (ad_list_of_dom m))=(in_dom A a m).
-  Proof.
-    Unfold ad_list_of_dom. Intros.
-    Rewrite (MapFold_distr_l A (list ad) (nil ad) (!app ad) bool false orb
-              ad [a:ad][l:(list ad)](ad_in_list a l) [c:ad](refl_equal ? ?)
-              ad_in_list_app [a0:ad][_:A](cons a0 (nil ad)) m a).
-    Simpl. Rewrite (MapFold_orb A [a0:ad][_:A](orb (ad_eq a a0) false) m).
-    Elim (option_sum ? (MapSweep A [a0:ad][_:A](orb (ad_eq a a0) false) m)). Intro H. Elim H.
-    Intro r. Elim r. Intros a0 y H0. Rewrite H0. Unfold in_dom.
-    Elim (orb_prop ? ? (MapSweep_semantics_1 ? ? ? ? ? H0)). Intro H1.
-    Rewrite (ad_eq_complete ? ? H1). Rewrite (MapSweep_semantics_2 A ? ? ? ? H0). Reflexivity.
-    Intro H1. Discriminate H1.
-    Intro H. Rewrite H. Elim (sumbool_of_bool (in_dom A a m)). Intro H0.
-    Elim (in_dom_some A m a H0). Intros y H1.
-    Elim (orb_false_elim ? ? (MapSweep_semantics_3 ? ? ? H ? ? H1)). Intro H2.
-    Rewrite (ad_eq_correct a) in H2. Discriminate H2.
-    Exact (sym_eq ? ? ?).
-  Qed.
-
-  Lemma Elems_of_list_of_dom : 
-      (m:(Map A)) (eqmap unit (Elems (ad_list_of_dom m)) (MapDom A m)).
-  Proof.
-    Unfold eqmap eqm. Intros. Elim (sumbool_of_bool (in_FSet a (Elems (ad_list_of_dom m)))).
-    Intro H. Elim (in_dom_some ? ? ? H). Intro t. Elim t. Intro H0.
-    Rewrite (ad_in_elems_in_list (ad_list_of_dom m) a) in H.
-    Rewrite (ad_in_list_of_dom_in_dom m a) in H. Rewrite (MapDom_Dom A m a) in H.
-    Elim (in_dom_some ? ? ? H). Intro t'. Elim t'. Intro H1. Rewrite H1. Assumption.
-    Intro H. Rewrite (in_dom_none ? ? ? H).
-    Rewrite (ad_in_elems_in_list (ad_list_of_dom m) a) in H.
-    Rewrite (ad_in_list_of_dom_in_dom m a) in H. Rewrite (MapDom_Dom A m a) in H.
-    Rewrite (in_dom_none ? ? ? H). Reflexivity.
-  Qed.
-
-  Lemma Elems_of_list_of_dom_c : (m:(Map A)) (mapcanon A m) ->
-      (Elems (ad_list_of_dom m))=(MapDom A m).
-  Proof.
-    Intros. Apply (mapcanon_unique unit). Apply Elems_canon.
-    Apply MapDom_canon. Assumption.
-    Apply Elems_of_list_of_dom.
-  Qed.
-
-  Lemma ad_list_of_dom_card_1 : (m:(Map A)) (pf:ad->ad)
-      (length (MapFold1 A (list ad) (nil ad) (app 1!ad) [a:ad][_:A](cons a (nil ad)) pf m))=
-      (MapCard A m).
-  Proof.
-    Induction m; Try Trivial. Simpl. Intros. Rewrite ad_list_app_length.
-    Rewrite (H [a0:ad](pf (ad_double a0))). Rewrite (H0 [a0:ad](pf (ad_double_plus_un a0))).
-    Reflexivity.
-  Qed.
-
-  Lemma ad_list_of_dom_card : (m:(Map A)) (length (ad_list_of_dom m))=(MapCard A m).
-  Proof.
-    Exact [m:(Map A)](ad_list_of_dom_card_1 m [a:ad]a).
-  Qed.
-
-  Lemma ad_list_of_dom_not_stutters : 
-      (m:(Map A)) (ad_list_stutters (ad_list_of_dom m))=false.
-  Proof.
-    Intro. Apply ad_list_not_stutters_card_conv. Rewrite ad_list_of_dom_card. Apply sym_eq.
-    Rewrite (MapCard_Dom A m). Apply MapCard_ext. Exact (Elems_of_list_of_dom m).
-  Qed.
-
-  End ListOfDomDef.
-
-  Lemma ad_list_of_dom_Dom_1 : (A:Set)
-    (m:(Map A)) (pf:ad->ad)
-      (MapFold1 A (list ad) (nil ad) (app 1!ad) 
-        [a:ad][_:A](cons a (nil ad)) pf m)=
-      (MapFold1 unit (list ad) (nil ad) (app 1!ad)
-        [a:ad][_:unit](cons a (nil ad)) pf (MapDom A m)).
-  Proof.
-    Induction m; Try Trivial. Simpl. Intros. Rewrite (H [a0:ad](pf (ad_double a0))).
-    Rewrite (H0 [a0:ad](pf (ad_double_plus_un a0))). Reflexivity.
-  Qed.
-
-  Lemma ad_list_of_dom_Dom : (A:Set) (m:(Map A))
-      (ad_list_of_dom A m)=(ad_list_of_dom unit (MapDom A m)).
-  Proof.
-    Intros. Exact (ad_list_of_dom_Dom_1 A m [a0:ad]a0).
-  Qed.
-
-End MapLists.
diff --git a/theories7/IntMap/Mapsubset.v b/theories7/IntMap/Mapsubset.v
deleted file mode 100644
index c0b1cccd..00000000
--- a/theories7/IntMap/Mapsubset.v
+++ /dev/null
@@ -1,554 +0,0 @@
-(************************************************************************)
-(*  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: Mapsubset.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $	 i*)
-
-Require Bool.
-Require Sumbool.
-Require Arith.
-Require ZArith.
-Require Addr.
-Require Adist.
-Require Addec.
-Require Map.
-Require Fset.
-Require Mapaxioms.
-Require Mapiter.
-
-Section MapSubsetDef.
-
-  Variable A, B : Set.
-
-  Definition MapSubset := [m:(Map A)] [m':(Map B)]
-      (a:ad) (in_dom A a m)=true -> (in_dom B a m')=true.
-
-  Definition MapSubset_1 := [m:(Map A)] [m':(Map B)]
-      Cases (MapSweep A [a:ad][_:A] (negb (in_dom B a m')) m) of
-          NONE => true
-	| _ => false
-      end.
-
-  Definition MapSubset_2 := [m:(Map A)] [m':(Map B)] 
-      (eqmap A (MapDomRestrBy A B m m') (M0 A)).
-
-  Lemma MapSubset_imp_1 : (m:(Map A)) (m':(Map B))
-      (MapSubset m m') -> (MapSubset_1 m m')=true.
-  Proof.
-    Unfold MapSubset MapSubset_1. Intros.
-    Elim (option_sum ? (MapSweep A [a:ad][_:A](negb (in_dom B a m')) m)).
-    Intro H0. Elim H0. Intro r. Elim r. Intros a y H1. Cut (negb (in_dom B a m'))=true.
-    Intro. Cut (in_dom A a m)=false. Intro. Unfold in_dom in H3.
-    Rewrite (MapSweep_semantics_2 ? ? m a y H1) in H3. Discriminate H3.
-    Elim (sumbool_of_bool (in_dom A a m)). Intro H3. Rewrite (H a H3) in H2. Discriminate H2.
-    Trivial.
-    Exact (MapSweep_semantics_1 ? ? m a y H1).
-    Intro H0. Rewrite H0. Reflexivity.
-  Qed.
-
-  Lemma MapSubset_1_imp : (m:(Map A)) (m':(Map B))
-      (MapSubset_1 m m')=true -> (MapSubset m m').
-  Proof.
-    Unfold MapSubset MapSubset_1. Unfold 2 in_dom. Intros. Elim (option_sum ? (MapGet A m a)).
-    Intro H1. Elim H1. Intros y H2.
-    Elim (option_sum ? (MapSweep A [a:ad][_:A](negb (in_dom B a m')) m)). Intro H3.
-    Elim H3. Intro r. Elim r. Intros a' y' H4. Rewrite H4 in H. Discriminate H.
-    Intro H3. Cut (negb (in_dom B a m'))=false. Intro. Rewrite (negb_intro (in_dom B a m')).
-    Rewrite H4. Reflexivity.
-    Exact (MapSweep_semantics_3 ? ? m H3 a y H2).
-    Intro H1. Rewrite H1 in H0. Discriminate H0.
-  Qed.
-
-  Lemma map_dom_empty_1 : 
-      (m:(Map A)) (eqmap A m (M0 A)) -> (a:ad) (in_dom ? a m)=false.
-  Proof.
-    Unfold eqmap eqm in_dom. Intros. Rewrite (H a). Reflexivity.
-  Qed.
-
-  Lemma map_dom_empty_2 : 
-      (m:(Map A)) ((a:ad) (in_dom ? a m)=false) -> (eqmap A m (M0 A)).
-  Proof.
-    Unfold eqmap eqm in_dom. Intros.
-    Cut (Cases (MapGet A m a) of NONE => false | (SOME _) => true end)=false.
-    Case (MapGet A m a). Trivial.
-    Intros. Discriminate H0.
-    Exact (H a).
-  Qed.
-
-  Lemma MapSubset_imp_2 : 
-      (m:(Map A)) (m':(Map B)) (MapSubset m m') -> (MapSubset_2 m m').
-  Proof.
-    Unfold MapSubset MapSubset_2. Intros. Apply map_dom_empty_2. Intro. Rewrite in_dom_restrby.
-    Elim (sumbool_of_bool (in_dom A a m)). Intro H0. Rewrite H0. Rewrite (H a H0). Reflexivity.
-    Intro H0. Rewrite H0. Reflexivity.
-  Qed.
-
-  Lemma MapSubset_2_imp : 
-      (m:(Map A)) (m':(Map B)) (MapSubset_2 m m') -> (MapSubset m m').
-  Proof.
-    Unfold MapSubset MapSubset_2. Intros. Cut (in_dom ? a (MapDomRestrBy A B m m'))=false.
-    Rewrite in_dom_restrby. Intro. Elim (andb_false_elim ? ? H1). Rewrite H0.
-    Intro H2. Discriminate H2.
-    Intro H2. Rewrite (negb_intro (in_dom B a m')). Rewrite H2. Reflexivity.
-    Exact (map_dom_empty_1 ? H a).
-  Qed.
-
-End MapSubsetDef.
-
-Section MapSubsetOrder.
-
-  Variable A, B, C : Set.
-
-  Lemma MapSubset_refl : (m:(Map A)) (MapSubset A A m m).
-  Proof.
-      Unfold MapSubset. Trivial.
-  Qed.
-
-  Lemma MapSubset_antisym : (m:(Map A)) (m':(Map B))
-      (MapSubset A B m m') -> (MapSubset B A m' m) -> 
-        (eqmap unit (MapDom A m) (MapDom B m')).
-  Proof.
-    Unfold MapSubset eqmap eqm. Intros. Elim (option_sum ? (MapGet ? (MapDom A m) a)).
-    Intro H1. Elim H1. Intro t. Elim t. Intro H2. Elim (option_sum ? (MapGet ? (MapDom B m') a)).
-    Intro H3. Elim H3. Intro t'. Elim t'. Intro H4. Rewrite H4. Exact H2. 
-    Intro H3. Cut (in_dom B a m')=true. Intro. Rewrite (MapDom_Dom B m' a) in H4.
-    Unfold in_FSet in_dom in H4. Rewrite H3 in H4. Discriminate H4.
-    Apply H. Rewrite (MapDom_Dom A m a). Unfold in_FSet in_dom. Rewrite H2. Reflexivity.
-    Intro H1. Elim (option_sum ? (MapGet ? (MapDom B m') a)). Intro H2. Elim H2. Intros t H3.
-    Cut (in_dom A a m)=true. Intro. Rewrite (MapDom_Dom A m a) in H4. Unfold in_FSet in_dom in H4.
-    Rewrite H1 in H4. Discriminate H4.
-    Apply H0. Rewrite (MapDom_Dom B m' a). Unfold in_FSet in_dom. Rewrite H3. Reflexivity.
-    Intro H2. Rewrite H2. Exact H1.
-  Qed.
-
-  Lemma MapSubset_trans : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (MapSubset A B m m') -> (MapSubset B C m' m'') -> (MapSubset A C m m'').
-  Proof.
-    Unfold MapSubset. Intros. Apply H0. Apply H. Assumption.
-  Qed.
-
-End MapSubsetOrder.
-
-Section FSubsetOrder.
-
-  Lemma FSubset_refl : (s:FSet) (MapSubset ? ? s s).
-  Proof.
-    Exact (MapSubset_refl unit).
-  Qed.
-
-  Lemma FSubset_antisym : (s,s':FSet)
-      (MapSubset ? ? s s') -> (MapSubset ? ? s' s) -> (eqmap unit s s').
-  Proof.
-    Intros. Rewrite <- (FSet_Dom s). Rewrite <- (FSet_Dom s').
-    Exact (MapSubset_antisym ? ? s s' H H0).
-  Qed.
-
-  Lemma FSubset_trans : (s,s',s'':FSet)
-      (MapSubset ? ? s s') -> (MapSubset ? ? s' s'') -> (MapSubset ? ? s s'').
-  Proof.
-    Exact (MapSubset_trans unit unit unit).
-  Qed.
-
-End FSubsetOrder.
-
-Section MapSubsetExtra.
-
-  Variable A, B : Set.
-
-  Lemma MapSubset_Dom_1 : (m:(Map A)) (m':(Map B))
-      (MapSubset A B m m') -> (MapSubset unit unit (MapDom A m) (MapDom B m')).
-  Proof.
-    Unfold MapSubset. Intros. Elim (MapDom_semantics_2 ? m a H0). Intros y H1.
-    Cut (in_dom A a m)=true->(in_dom B a m')=true. Intro. Unfold in_dom in H2.
-    Rewrite H1 in H2. Elim (option_sum ? (MapGet B m' a)). Intro H3. Elim H3.
-    Intros y' H4. Exact (MapDom_semantics_1 ? m' a y' H4).
-    Intro H3. Rewrite H3 in H2. Cut false=true. Intro. Discriminate H4.
-    Apply H2. Reflexivity.
-    Exact (H a).
-  Qed.
-
-  Lemma MapSubset_Dom_2 : (m:(Map A)) (m':(Map B))
-      (MapSubset unit unit (MapDom A m) (MapDom B m')) -> (MapSubset A B m m').
-  Proof.
-    Unfold MapSubset. Intros. Unfold in_dom in H0. Elim (option_sum ? (MapGet A m a)).
-    Intro H1. Elim H1. Intros y H2.
-    Elim (MapDom_semantics_2 ? ? ? (H a (MapDom_semantics_1 ? ? ? ? H2))). Intros y' H3.
-    Unfold in_dom. Rewrite H3. Reflexivity.
-    Intro H1. Rewrite H1 in H0. Discriminate H0.
-  Qed.
-
-  Lemma MapSubset_1_Dom : (m:(Map A)) (m':(Map B))
-      (MapSubset_1 A B m m')=(MapSubset_1 unit unit (MapDom A m) (MapDom B m')).
-  Proof.
-    Intros. Elim (sumbool_of_bool (MapSubset_1 A B m m')). Intro H. Rewrite H.
-    Apply sym_eq. Apply MapSubset_imp_1. Apply MapSubset_Dom_1. Exact (MapSubset_1_imp ? ? ? ? H).
-    Intro H. Rewrite H. Elim (sumbool_of_bool (MapSubset_1 unit unit (MapDom A m) (MapDom B m'))).
-    Intro H0.
-    Rewrite (MapSubset_imp_1 ? ? ? ? (MapSubset_Dom_2 ? ? (MapSubset_1_imp ? ? ? ? H0))) in H.
-    Discriminate H.
-    Intro. Apply sym_eq. Assumption.
-  Qed.
-
-  Lemma MapSubset_Put : (m:(Map A)) (a:ad) (y:A) (MapSubset A A m (MapPut A m a y)).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_put. Rewrite H. Apply orb_b_true.
-  Qed.
-
-  Lemma MapSubset_Put_mono : (m:(Map A)) (m':(Map B)) (a:ad) (y:A) (y':B)
-      (MapSubset A B m m') -> (MapSubset A B (MapPut A m a y) (MapPut B m' a y')).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_put. Rewrite (in_dom_put A m a y a0) in H0.
-    Elim (orb_true_elim ? ? H0). Intro H1. Rewrite H1. Reflexivity.
-    Intro H1. Rewrite (H ? H1). Apply orb_b_true.
-  Qed.
-
-  Lemma MapSubset_Put_behind : 
-      (m:(Map A)) (a:ad) (y:A) (MapSubset A A m (MapPut_behind A m a y)).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_put_behind. Rewrite H. Apply orb_b_true.
-  Qed.
-
-  Lemma MapSubset_Put_behind_mono : (m:(Map A)) (m':(Map B)) (a:ad) (y:A) (y':B)
-      (MapSubset A B m m') -> 
-        (MapSubset A B (MapPut_behind A m a y) (MapPut_behind B m' a y')).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_put_behind.
-    Rewrite (in_dom_put_behind A m a y a0) in H0.
-    Elim (orb_true_elim ? ? H0). Intro H1. Rewrite H1. Reflexivity.
-    Intro H1. Rewrite (H ? H1). Apply orb_b_true.
-  Qed.
-
-  Lemma MapSubset_Remove : (m:(Map A)) (a:ad) (MapSubset A A (MapRemove A m a) m).
-  Proof.
-    Unfold MapSubset. Intros. Unfold MapSubset. Intros. Rewrite (in_dom_remove ? m a a0) in H.
-    Elim (andb_prop ? ? H). Trivial.
-  Qed.
-
-  Lemma MapSubset_Remove_mono : (m:(Map A)) (m':(Map B)) (a:ad)
-      (MapSubset A B m m') -> (MapSubset A B (MapRemove A m a) (MapRemove B m' a)).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_remove. Rewrite (in_dom_remove A m a a0) in H0.
-    Elim (andb_prop ? ? H0). Intros. Rewrite H1. Rewrite (H ? H2). Reflexivity.
-  Qed.
-
-  Lemma MapSubset_Merge_l : (m,m':(Map A)) (MapSubset A A m (MapMerge A m m')).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_merge. Rewrite H. Reflexivity.
-  Qed.
-
-  Lemma MapSubset_Merge_r : (m,m':(Map A)) (MapSubset A A m' (MapMerge A m m')).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_merge. Rewrite H. Apply orb_b_true.
-  Qed.
-
-  Lemma MapSubset_Merge_mono : (m,m':(Map A)) (m'',m''':(Map B))
-      (MapSubset A B m m'') -> (MapSubset A B m' m''') ->
-      	(MapSubset A B (MapMerge A m m') (MapMerge B m'' m''')).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_merge. Rewrite (in_dom_merge A m m' a) in H1.
-    Elim (orb_true_elim ? ? H1). Intro H2. Rewrite (H ? H2). Reflexivity.
-    Intro H2. Rewrite (H0 ? H2). Apply orb_b_true.
-  Qed.
-
-  Lemma MapSubset_DomRestrTo_l : (m:(Map A)) (m':(Map B))
-      (MapSubset A A (MapDomRestrTo A B m m') m).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite (in_dom_restrto ? ? m m' a) in H. Elim (andb_prop ? ? H).
-    Trivial.
-  Qed.
-
-  Lemma MapSubset_DomRestrTo_r: (m:(Map A)) (m':(Map B))
-      (MapSubset A B (MapDomRestrTo A B m m') m').
-  Proof.
-    Unfold MapSubset. Intros. Rewrite (in_dom_restrto ? ? m m' a) in H. Elim (andb_prop ? ? H).
-    Trivial.
-  Qed.
-
-  Lemma MapSubset_ext : (m0,m1:(Map A)) (m2,m3:(Map B))
-      (eqmap A m0 m1) -> (eqmap B m2 m3) ->
-        (MapSubset A B m0 m2) -> (MapSubset A B m1 m3).
-  Proof.
-    Intros. Apply MapSubset_2_imp. Unfold MapSubset_2.
-    Apply eqmap_trans with m':=(MapDomRestrBy A B m0 m2). Apply MapDomRestrBy_ext. Apply eqmap_sym.
-    Assumption.
-    Apply eqmap_sym. Assumption.
-    Exact (MapSubset_imp_2 ? ? ? ? H1).
-  Qed.
-
-  Variable C, D : Set.
-
-  Lemma MapSubset_DomRestrTo_mono : 
-      (m:(Map A)) (m':(Map B)) (m'':(Map C)) (m''':(Map D))
-        (MapSubset ? ? m m'') -> (MapSubset ? ?  m' m''') ->
-      	  (MapSubset ? ? (MapDomRestrTo ? ? m m') (MapDomRestrTo ? ? m'' m''')).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_restrto. Rewrite (in_dom_restrto A B m m' a) in H1.
-    Elim (andb_prop ? ? H1). Intros. Rewrite (H ? H2). Rewrite (H0 ? H3). Reflexivity.
-  Qed.
-
-  Lemma MapSubset_DomRestrBy_l : (m:(Map A)) (m':(Map B))
-      (MapSubset A A (MapDomRestrBy A B m m') m).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite (in_dom_restrby ? ? m m' a) in H. Elim (andb_prop ? ? H).
-    Trivial.
-  Qed.
-
-  Lemma MapSubset_DomRestrBy_mono : 
-      (m:(Map A)) (m':(Map B)) (m'':(Map C)) (m''':(Map D))
-        (MapSubset ? ? m m'') -> (MapSubset ? ?  m''' m') ->
-      	  (MapSubset ? ? (MapDomRestrBy ? ? m m') (MapDomRestrBy ? ? m'' m''')).
-  Proof.
-    Unfold MapSubset. Intros. Rewrite in_dom_restrby. Rewrite (in_dom_restrby A B m m' a) in H1.
-    Elim (andb_prop ? ? H1). Intros. Rewrite (H ? H2). Elim (sumbool_of_bool (in_dom D a m''')).
-    Intro H4. Rewrite (H0 ? H4) in H3. Discriminate H3.
-    Intro H4. Rewrite H4. Reflexivity.
-  Qed.
-  
-End MapSubsetExtra.
-
-Section MapDisjointDef.
-
-  Variable A, B : Set.
-
-  Definition MapDisjoint := [m:(Map A)] [m':(Map B)]
-      (a:ad) (in_dom A a m)=true -> (in_dom B a m')=true -> False.
-
-  Definition MapDisjoint_1 := [m:(Map A)] [m':(Map B)]
-      Cases (MapSweep A [a:ad][_:A] (in_dom B a m') m) of
-          NONE => true
-	| _ => false
-      end.
-
-  Definition MapDisjoint_2 := [m:(Map A)] [m':(Map B)] 
-      (eqmap A (MapDomRestrTo A B m m') (M0 A)).
-
-  Lemma MapDisjoint_imp_1 : (m:(Map A)) (m':(Map B))
-      (MapDisjoint m m') -> (MapDisjoint_1 m m')=true.
-  Proof.
-    Unfold MapDisjoint MapDisjoint_1. Intros.
-    Elim (option_sum ? (MapSweep A [a:ad][_:A](in_dom B a m') m)). Intro H0. Elim H0.
-    Intro r. Elim r. Intros a y H1. Cut (in_dom A a m)=true->(in_dom B a m')=true->False.
-    Intro. Unfold 1 in_dom in H2. Rewrite (MapSweep_semantics_2 ? ? ? ? ? H1) in H2.
-    Rewrite (MapSweep_semantics_1 ? ? ? ? ? H1) in H2. Elim (H2 (refl_equal ? ?) (refl_equal ? ?)).
-    Exact (H a).
-    Intro H0. Rewrite H0. Reflexivity.
-  Qed.
-
-  Lemma MapDisjoint_1_imp : (m:(Map A)) (m':(Map B))
-      (MapDisjoint_1 m m')=true -> (MapDisjoint m m').
-  Proof.
-    Unfold MapDisjoint MapDisjoint_1. Intros.
-    Elim (option_sum ? (MapSweep A [a:ad][_:A](in_dom B a m') m)). Intro H2. Elim H2.
-    Intro r. Elim r. Intros a' y' H3. Rewrite H3 in H. Discriminate H.
-    Intro H2. Unfold in_dom in H0. Elim (option_sum ? (MapGet A m a)). Intro H3. Elim H3.
-    Intros y H4. Rewrite (MapSweep_semantics_3 ? ? ? H2 a y H4) in H1. Discriminate H1.
-    Intro H3. Rewrite H3 in H0. Discriminate H0.
-  Qed.
-
-  Lemma MapDisjoint_imp_2 : (m:(Map A)) (m':(Map B)) (MapDisjoint m m') -> 
-      (MapDisjoint_2 m m').
-  Proof.
-    Unfold MapDisjoint MapDisjoint_2. Unfold eqmap eqm. Intros.
-    Rewrite (MapDomRestrTo_semantics A B m m' a).
-    Cut (in_dom A a m)=true->(in_dom B a m')=true->False. Intro.
-    Elim (option_sum ? (MapGet A m a)). Intro H1. Elim H1. Intros y H2. Unfold 1 in_dom in H0.
-    Elim (option_sum ? (MapGet B m' a)). Intro H3. Elim H3. Intros y' H4. Unfold 1 in_dom in H0.
-    Rewrite H4 in H0. Rewrite H2 in H0. Elim (H0 (refl_equal ? ?) (refl_equal ? ?)).
-    Intro H3. Rewrite H3. Reflexivity.
-    Intro H1. Rewrite H1. Case (MapGet B m' a); Reflexivity.
-    Exact (H a).
-  Qed.
-
-  Lemma MapDisjoint_2_imp : (m:(Map A)) (m':(Map B)) (MapDisjoint_2 m m') -> 
-      (MapDisjoint m m').
-  Proof.
-    Unfold MapDisjoint MapDisjoint_2. Unfold eqmap eqm. Intros. Elim (in_dom_some ? ? ? H0).
-    Intros y H2. Elim (in_dom_some ? ? ? H1). Intros y' H3.
-    Cut (MapGet A (MapDomRestrTo A B m m') a)=(NONE A). Intro.
-    Rewrite (MapDomRestrTo_semantics ? ? m m' a) in H4. Rewrite H3 in H4. Rewrite H2 in H4.
-    Discriminate H4.
-    Exact (H a).
-  Qed.
-
-  Lemma Map_M0_disjoint : (m:(Map B)) (MapDisjoint (M0 A) m).
-  Proof.
-    Unfold MapDisjoint in_dom. Intros. Discriminate H.
-  Qed.
-
-  Lemma Map_disjoint_M0 : (m:(Map A)) (MapDisjoint m (M0 B)).
-  Proof.
-    Unfold MapDisjoint in_dom. Intros. Discriminate H0.
-  Qed.
-
-End MapDisjointDef.
-
-Section MapDisjointExtra.
-
-  Variable A, B : Set.
-
-  Lemma MapDisjoint_ext : (m0,m1:(Map A)) (m2,m3:(Map B))
-      (eqmap A m0 m1) -> (eqmap B m2 m3) -> 
-        (MapDisjoint A B m0 m2) -> (MapDisjoint A B m1 m3).
-  Proof.
-    Intros. Apply MapDisjoint_2_imp. Unfold MapDisjoint_2.
-    Apply eqmap_trans with m':=(MapDomRestrTo A B m0 m2). Apply eqmap_sym. Apply MapDomRestrTo_ext.
-    Assumption.
-    Assumption.
-    Exact (MapDisjoint_imp_2 ? ? ? ? H1).
-  Qed.
-
-  Lemma MapMerge_disjoint : (m,m':(Map A)) (MapDisjoint A A m m') ->
-      	(a:ad) (in_dom A a (MapMerge A m m'))=
-	       (orb (andb (in_dom A a m) (negb (in_dom A a m')))
-	            (andb (in_dom A a m') (negb (in_dom A a m)))).
-  Proof.
-    Unfold MapDisjoint. Intros. Rewrite in_dom_merge. Elim (sumbool_of_bool (in_dom A a m)).
-    Intro H0. Rewrite H0. Elim (sumbool_of_bool (in_dom A a m')). Intro H1. Elim (H a H0 H1).
-    Intro H1. Rewrite H1. Reflexivity.
-    Intro H0. Rewrite H0. Simpl. Rewrite andb_b_true. Reflexivity.
-  Qed.
-
-  Lemma MapDisjoint_M2_l : (m0,m1:(Map A)) (m2,m3:(Map B))
-      (MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3)) -> (MapDisjoint A B m0 m2).
-  Proof.
-    Unfold MapDisjoint in_dom. Intros. Elim (option_sum ? (MapGet A m0 a)). Intro H2.
-    Elim H2. Intros y H3. Elim (option_sum ? (MapGet B m2 a)). Intro H4. Elim H4.
-    Intros y' H5. Apply (H (ad_double a)).
-    Rewrite (MapGet_M2_bit_0_0 ? (ad_double a) (ad_double_bit_0 a) m0 m1).
-    Rewrite (ad_double_div_2 a). Rewrite H3. Reflexivity.
-    Rewrite (MapGet_M2_bit_0_0 ? (ad_double a) (ad_double_bit_0 a) m2 m3).
-    Rewrite (ad_double_div_2 a). Rewrite H5. Reflexivity.
-    Intro H4. Rewrite H4 in H1. Discriminate H1.
-    Intro H2. Rewrite H2 in H0. Discriminate H0.
-  Qed.
-
-  Lemma MapDisjoint_M2_r : (m0,m1:(Map A)) (m2,m3:(Map B))
-      (MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3)) -> (MapDisjoint A B m1 m3).
-  Proof.
-    Unfold MapDisjoint in_dom. Intros. Elim (option_sum ? (MapGet A m1 a)). Intro H2.
-    Elim H2. Intros y H3. Elim (option_sum ? (MapGet B m3 a)). Intro H4. Elim H4.
-    Intros y' H5. Apply (H (ad_double_plus_un a)).
-    Rewrite (MapGet_M2_bit_0_1 ? (ad_double_plus_un a) (ad_double_plus_un_bit_0 a) m0 m1).
-    Rewrite (ad_double_plus_un_div_2 a). Rewrite H3. Reflexivity.
-    Rewrite (MapGet_M2_bit_0_1 ? (ad_double_plus_un a) (ad_double_plus_un_bit_0 a) m2 m3).
-    Rewrite (ad_double_plus_un_div_2 a). Rewrite H5. Reflexivity.
-    Intro H4. Rewrite H4 in H1. Discriminate H1.
-    Intro H2. Rewrite H2 in H0. Discriminate H0.
-  Qed.
-
-  Lemma MapDisjoint_M2 : (m0,m1:(Map A)) (m2,m3:(Map B))
-      (MapDisjoint A B m0 m2) -> (MapDisjoint A B m1 m3) ->
-      	(MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3)).
-  Proof.
-    Unfold MapDisjoint in_dom. Intros. Elim (sumbool_of_bool (ad_bit_0 a)). Intro H3.
-    Rewrite (MapGet_M2_bit_0_1 A a H3 m0 m1) in H1.
-    Rewrite (MapGet_M2_bit_0_1 B a H3 m2 m3) in H2. Exact (H0 (ad_div_2 a) H1 H2).
-    Intro H3. Rewrite (MapGet_M2_bit_0_0 A a H3 m0 m1) in H1.
-    Rewrite (MapGet_M2_bit_0_0 B a H3 m2 m3) in H2. Exact (H (ad_div_2 a) H1 H2).
-  Qed.
-
-  Lemma MapDisjoint_M1_l : (m:(Map A)) (a:ad) (y:B)
-      (MapDisjoint B A (M1 B a y) m) -> (in_dom A a m)=false.
-  Proof.
-    Unfold MapDisjoint. Intros. Elim (sumbool_of_bool (in_dom A a m)). Intro H0.
-    Elim (H a (in_dom_M1_1 B a y) H0).
-    Trivial.
-  Qed.
-
-  Lemma MapDisjoint_M1_r : (m:(Map A)) (a:ad) (y:B)
-      (MapDisjoint A B m (M1 B a y)) -> (in_dom A a m)=false.
-  Proof.
-    Unfold MapDisjoint. Intros. Elim (sumbool_of_bool (in_dom A a m)). Intro H0.
-    Elim (H a H0 (in_dom_M1_1 B a y)).
-    Trivial.
-  Qed.
-
-  Lemma MapDisjoint_M1_conv_l : (m:(Map A)) (a:ad) (y:B)
-      (in_dom A a m)=false -> (MapDisjoint B A (M1 B a y) m).
-  Proof.
-    Unfold MapDisjoint. Intros. Rewrite (in_dom_M1_2 B a a0 y H0) in H. Rewrite H1 in H.
-    Discriminate H.
-  Qed.
-
-  Lemma MapDisjoint_M1_conv_r : (m:(Map A)) (a:ad) (y:B)
-      (in_dom A a m)=false -> (MapDisjoint A B m (M1 B a y)).
-  Proof.
-    Unfold MapDisjoint. Intros. Rewrite (in_dom_M1_2 B a a0 y H1) in H. Rewrite H0 in H.
-    Discriminate H.
-  Qed.
- 
-  Lemma MapDisjoint_sym : (m:(Map A)) (m':(Map B))
-      (MapDisjoint A B m m') -> (MapDisjoint B A m' m).
-  Proof.
-    Unfold MapDisjoint. Intros. Exact (H ? H1 H0).
-  Qed.
-
-  Lemma MapDisjoint_empty : (m:(Map A)) (MapDisjoint A A m m) -> (eqmap A m (M0 A)).
-  Proof.
-    Unfold eqmap eqm. Intros. Rewrite <- (MapDomRestrTo_idempotent A m a).
-    Exact (MapDisjoint_imp_2 A A m m H a).
-  Qed.
-
-  Lemma MapDelta_disjoint : (m,m':(Map A)) (MapDisjoint A A m m') ->
-      (eqmap A (MapDelta A m m') (MapMerge A m m')).
-  Proof.
-    Intros.
-    Apply eqmap_trans with m':=(MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')).
-    Apply MapDelta_as_DomRestrBy.
-    Apply eqmap_trans with m':=(MapDomRestrBy A A (MapMerge A m m') (M0 A)).
-    Apply MapDomRestrBy_ext. Apply eqmap_refl.
-    Exact (MapDisjoint_imp_2 A A m m' H).
-    Apply MapDomRestrBy_m_empty.
-  Qed.
-
-  Variable C : Set.
-
-  Lemma MapDomRestr_disjoint : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (MapDisjoint A B (MapDomRestrTo A C m m'') (MapDomRestrBy B C m' m'')).
-  Proof.
-    Unfold MapDisjoint. Intros m m' m'' a. Rewrite in_dom_restrto. Rewrite in_dom_restrby.
-    Intros. Elim (andb_prop ? ? H). Elim (andb_prop ? ? H0). Intros. Rewrite H4 in H2.
-    Discriminate H2.
-  Qed.
-
-  Lemma MapDelta_RestrTo_disjoint : (m,m':(Map A))
-      (MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m m')).
-  Proof.
-    Unfold MapDisjoint. Intros m m' a. Rewrite in_dom_delta. Rewrite in_dom_restrto.
-    Intros. Elim (andb_prop ? ? H0). Intros. Rewrite H1 in H. Rewrite H2 in H. Discriminate H.
-  Qed.
-
-  Lemma MapDelta_RestrTo_disjoint_2 : (m,m':(Map A))
-      (MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m' m)).
-  Proof.
-    Unfold MapDisjoint. Intros m m' a. Rewrite in_dom_delta. Rewrite in_dom_restrto.
-    Intros. Elim (andb_prop ? ? H0). Intros. Rewrite H1 in H. Rewrite H2 in H. Discriminate H.
-  Qed.
-
-  Variable D : Set.
-
-  Lemma MapSubset_Disjoint : (m:(Map A)) (m':(Map B)) (m'':(Map C)) (m''':(Map D))
-      (MapSubset ? ? m m') -> (MapSubset ? ? m'' m''') -> (MapDisjoint ? ? m' m''') ->
-        (MapDisjoint ? ? m m'').
-  Proof.
-    Unfold MapSubset MapDisjoint. Intros. Exact (H1 ? (H ? H2) (H0 ? H3)).
-  Qed.
-
-  Lemma MapSubset_Disjoint_l : (m:(Map A)) (m':(Map B)) (m'':(Map C))
-      (MapSubset ? ? m m') -> (MapDisjoint ? ? m' m'') ->
-        (MapDisjoint ? ? m m'').
-  Proof.
-    Unfold MapSubset MapDisjoint. Intros. Exact (H0 ? (H ? H1) H2).
-  Qed.
-
-  Lemma MapSubset_Disjoint_r : (m:(Map A)) (m'':(Map C)) (m''':(Map D))
-      (MapSubset ? ? m'' m''') -> (MapDisjoint ? ? m m''') ->
-        (MapDisjoint ? ? m m'').
-  Proof.
-    Unfold MapSubset MapDisjoint. Intros. Exact (H0 ? H1 (H ? H2)).
-  Qed.
-
-End MapDisjointExtra.
diff --git a/theories7/Lists/List.v b/theories7/Lists/List.v
deleted file mode 100755
index 574b2688..00000000
--- a/theories7/Lists/List.v
+++ /dev/null
@@ -1,261 +0,0 @@
-(************************************************************************)
-(*  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: List.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*)
-
-(* This file is a copy of file MonoList.v *)
-
-(** THIS IS A OLD CONTRIB. IT IS NO LONGER MAINTAINED ***)
-
-Require Le.
-
-Parameter List_Dom:Set.
-Definition A := List_Dom.
-
-Inductive list : Set := nil : list | cons : A -> list -> list.
-
-Fixpoint app [l:list] : list -> list 
-      := [m:list]<list>Cases l of
-                           nil =>  m 
-                       | (cons a l1) => (cons a (app l1 m)) 
-                   end.
-
-
-Lemma app_nil_end : (l:list)(l=(app l nil)).
-Proof. 
-	Intro l ; Elim l ; Simpl ; Auto.
-        Induction 1; Auto.
-Qed.
-Hints Resolve app_nil_end : list v62.
-
-Lemma app_ass : (l,m,n : list)(app (app l m) n)=(app l (app m n)).
-Proof. 
-	Intros l m n ; Elim l ; Simpl ; Auto with list.
-	Induction 1; Auto with list.
-Qed.
-Hints Resolve app_ass : list v62.
-
-Lemma ass_app : (l,m,n : list)(app l (app m n))=(app (app l m) n).
-Proof. 
-	Auto with list.
-Qed.
-Hints Resolve ass_app : list v62.
-
-Definition tail := 
-    [l:list] <list>Cases l of  (cons _ m) => m | _ => nil end : list->list.
-                   
-
-Lemma nil_cons : (a:A)(m:list)~nil=(cons a m).
-  Intros; Discriminate.
-Qed.
-
-(****************************************)
-(* Length of lists                      *)
-(****************************************)
-
-Fixpoint length [l:list] : nat 
-   := <nat>Cases l of (cons _ m) => (S (length m)) | _ => O end.
-
-(******************************)
-(* Length order of lists      *)
-(******************************)
-
-Section length_order.
-Definition lel := [l,m:list](le (length l) (length m)).
-
-Hints Unfold lel : list.
-
-Variables a,b:A.
-Variables l,m,n:list.
-
-Lemma lel_refl : (lel l l).
-Proof. 
-	Unfold lel ; Auto with list.
-Qed.
-
-Lemma lel_trans : (lel l m)->(lel m n)->(lel l n).
-Proof. 
-	Unfold lel ; Intros.
-        Apply le_trans with (length m) ; Auto with list.
-Qed.
-
-Lemma lel_cons_cons : (lel l m)->(lel (cons a l) (cons b m)).
-Proof. 
-	Unfold lel ; Simpl ; Auto with list arith.
-Qed.
-
-Lemma lel_cons : (lel l m)->(lel l (cons b m)).
-Proof. 
-	Unfold lel ; Simpl ; Auto with list arith.
-Qed.
-
-Lemma lel_tail : (lel (cons a l) (cons b m)) -> (lel l m).
-Proof. 
-	Unfold lel ; Simpl ; Auto with list arith.
-Qed.
-
-Lemma lel_nil : (l':list)(lel l' nil)->(nil=l').
-Proof. 
-	Intro l' ; Elim l' ; Auto with list arith.
-	Intros a' y H H0.
-	(*  <list>nil=(cons a' y)
-	    ============================
-	      H0 : (lel (cons a' y) nil)
-	      H : (lel y nil)->(<list>nil=y)
-	      y : list
-	      a' : A
-	      l' : list *)
-	Absurd (le (S (length y)) O); Auto with list arith.
-Qed.
-End length_order.
-
-Hints Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons : list v62.
-
-Fixpoint In  [a:A;l:list] : Prop :=
-      Cases l of
-         nil => False 
-      | (cons b m) => (b=a)\/(In a m)
-      end.
-
-Lemma in_eq : (a:A)(l:list)(In a (cons a l)).
-Proof. 
-	Simpl ; Auto with list.
-Qed.
-Hints Resolve in_eq : list v62.
-
-Lemma in_cons : (a,b:A)(l:list)(In b l)->(In b (cons a l)).
-Proof. 
-	Simpl ; Auto with list.
-Qed.
-Hints Resolve in_cons : list v62.
-
-Lemma in_app_or : (l,m:list)(a:A)(In a (app l m))->((In a l)\/(In a m)).
-Proof. 
-	Intros l m a.
-	Elim l ; Simpl ; Auto with list.
-	Intros a0 y H H0.
-	(*  ((<A>a0=a)\/(In a y))\/(In a m)
-	    ============================
-	      H0 : (<A>a0=a)\/(In a (app y m))
-	      H : (In a (app y m))->((In a y)\/(In a m))
-	      y : list
-	      a0 : A
-	      a : A
-	      m : list
-	      l : list *)
-	Elim H0 ; Auto with list.
-	Intro H1.
-	(*  ((<A>a0=a)\/(In a y))\/(In a m)
-	    ============================
-	      H1 : (In a (app y m)) *)
-	Elim (H H1) ; Auto with list.
-Qed.
-Hints Immediate in_app_or : list v62.
-
-Lemma in_or_app : (l,m:list)(a:A)((In a l)\/(In a m))->(In a (app l m)).
-Proof. 
-	Intros l m a.
-	Elim l ; Simpl ; Intro H.
-	(* 1 (In a m)
-	    ============================
-	      H : False\/(In a m)
-	      a : A
-	      m : list
-	      l : list *)
-	Elim H ; Auto with list ; Intro H0.
-	(*  (In a m)
-	    ============================
-	      H0 : False *)
-	Elim H0. (* subProof completed *)
-	Intros y H0 H1.
-	(*  2 (<A>H=a)\/(In a (app y m))
-	    ============================
-	      H1 : ((<A>H=a)\/(In a y))\/(In a m)
-	      H0 : ((In a y)\/(In a m))->(In a (app y m))
-	      y : list *)
-	Elim H1 ; Auto 4 with list.
-	Intro H2.
-	(*  (<A>H=a)\/(In a (app y m))
-	    ============================
-	      H2 : (<A>H=a)\/(In a y) *)
-	Elim H2 ; Auto with list.
-Qed.
-Hints Resolve in_or_app : list v62.
-
-Definition incl := [l,m:list](a:A)(In a l)->(In a m).
-
-Hints Unfold  incl : list v62.
-
-Lemma incl_refl : (l:list)(incl l l).
-Proof. 
-	Auto with list.
-Qed.
-Hints Resolve incl_refl : list v62.
-
-Lemma incl_tl : (a:A)(l,m:list)(incl l m)->(incl l (cons a m)).
-Proof. 
-	Auto with list.
-Qed.
-Hints Immediate incl_tl : list v62.
-
-Lemma incl_tran : (l,m,n:list)(incl l m)->(incl m n)->(incl l n).
-Proof. 
-	Auto with list.
-Qed.
-
-Lemma incl_appl : (l,m,n:list)(incl l n)->(incl l (app n m)).
-Proof. 
-	Auto with list.
-Qed.
-Hints Immediate incl_appl : list v62.
-
-Lemma incl_appr : (l,m,n:list)(incl l n)->(incl l (app m n)).
-Proof. 
-	Auto with list.
-Qed.
-Hints Immediate incl_appr : list v62.
-
-Lemma incl_cons : (a:A)(l,m:list)(In a m)->(incl l m)->(incl (cons a l) m).
-Proof. 
-	Unfold incl ; Simpl ; Intros a l m H H0 a0 H1.
-	(*  (In a0 m)
-	    ============================
-	      H1 : (<A>a=a0)\/(In a0 l)
-	      a0 : A
-	      H0 : (a:A)(In a l)->(In a m)
-	      H : (In a m)
-	      m : list
-	      l : list
-	      a : A *)
-	Elim H1.
-	(*  1 (<A>a=a0)->(In a0 m) *)
-	Elim H1 ; Auto with list ; Intro H2.
-	(*  (<A>a=a0)->(In a0 m)
-	    ============================
-	      H2 : <A>a=a0 *)
-	Elim H2 ; Auto with list. (* solves subgoal *)
-	(*  2 (In a0 l)->(In a0 m) *)
-	Auto with list.
-Qed.
-Hints Resolve incl_cons : list v62.
-
-Lemma incl_app : (l,m,n:list)(incl l n)->(incl m n)->(incl (app l m) n).
-Proof. 
-	Unfold incl ; Simpl ; Intros l m n H H0 a H1.
-	(*  (In a n)
-	    ============================
-	      H1 : (In a (app l m))
-	      a : A
-	      H0 : (a:A)(In a m)->(In a n)
-	      H : (a:A)(In a l)->(In a n)
-	      n : list
-	      m : list
-	      l : list *)
-	Elim (in_app_or l m a) ; Auto with list.
-Qed.
-Hints Resolve incl_app : list v62.
diff --git a/theories7/Lists/ListSet.v b/theories7/Lists/ListSet.v
deleted file mode 100644
index 9bf259da..00000000
--- a/theories7/Lists/ListSet.v
+++ /dev/null
@@ -1,389 +0,0 @@
-(************************************************************************)
-(*  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: ListSet.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*)
-
-(** A Library for finite sets, implemented as lists 
-    A Library with similar interface will soon be available under
-    the name TreeSet in the theories/Trees directory *)
-
-(** PolyList is loaded, but not exported.
-    This allow to "hide" the definitions, functions and theorems of PolyList
-    and to see only the ones of ListSet *)
-
-Require PolyList.
-
-Set Implicit Arguments.
-V7only [Implicits nil [1].].
-
-Section first_definitions.
-
-  Variable A : Set.
-  Hypothesis Aeq_dec : (x,y:A){x=y}+{~x=y}.
-
-  Definition set := (list A).
-
-  Definition empty_set := (!nil ?) : set.
-
-  Fixpoint set_add [a:A; x:set] : set :=
-    Cases x of
-    | nil => (cons a nil)
-    | (cons a1 x1) => Cases (Aeq_dec a a1) of 
-                    | (left _) => (cons a1 x1) 
-                    | (right _) => (cons a1 (set_add a x1))
-                   end
-    end.
-
-
-  Fixpoint set_mem [a:A; x:set] : bool :=
-    Cases x of
-    | nil => false
-    | (cons a1 x1) => Cases (Aeq_dec a a1) of 
-                    | (left _) => true 
-                    | (right _) => (set_mem a x1)
-                   end
-    end.
- 
-  (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing *)
-  Fixpoint set_remove [a:A; x:set] : set :=
-    Cases x of
-    | nil => empty_set
-    | (cons a1 x1) => Cases (Aeq_dec a a1) of 
-                    | (left _) => x1 
-                    | (right _) => (cons a1 (set_remove a x1))
-                   end
-    end.
-
-  Fixpoint set_inter [x:set] : set -> set :=
-    Cases x of
-    | nil => [y]nil
-    | (cons a1 x1) => [y]if (set_mem a1 y) 
-                      then (cons a1 (set_inter x1 y))
-		      else (set_inter x1 y)
-    end.
-
-  Fixpoint set_union [x,y:set] : set :=
-    Cases y of
-    | nil => x
-    | (cons a1 y1) => (set_add a1 (set_union x y1))
-    end.
-        
-  (** returns the set of all els of [x] that does not belong to [y] *)
-  Fixpoint set_diff [x:set] : set -> set :=
-    [y]Cases x of
-    | nil => nil
-    | (cons a1 x1) => if (set_mem a1 y) 
-                      then (set_diff x1 y)
-		      else (set_add a1 (set_diff x1 y))
-    end.
-   
-
-  Definition set_In : A -> set -> Prop := (In 1!A).
-
-  Lemma set_In_dec : (a:A; x:set){(set_In a x)}+{~(set_In a x)}.
-
-  Proof.
-    Unfold set_In.
-    (*** Realizer set_mem. Program_all. ***)
-    Induction x.
-    Auto.
-    Intros a0 x0 Ha0. Case (Aeq_dec a a0); Intro eq.
-    Rewrite eq; Simpl; Auto with datatypes.
-    Elim Ha0.
-    Auto with datatypes.
-    Right; Simpl; Unfold not; Intros [Hc1 | Hc2 ]; Auto with datatypes.
-  Qed.
-
-  Lemma set_mem_ind : 
-    (B:Set)(P:B->Prop)(y,z:B)(a:A)(x:set)
-      ((set_In a x) -> (P y))
-       ->(P z)
-       ->(P (if (set_mem a x) then y else z)).
-
-  Proof.
-    Induction x; Simpl; Intros.
-    Assumption.
-    Elim (Aeq_dec a a0); Auto with datatypes.
-  Qed.
-
-  Lemma set_mem_ind2 : 
-    (B:Set)(P:B->Prop)(y,z:B)(a:A)(x:set)
-      ((set_In a x) -> (P y))
-       ->(~(set_In a x) -> (P z))
-       ->(P (if (set_mem a x) then y else z)).
-
-  Proof.
-    Induction x; Simpl; Intros.
-    Apply H0; Red; Trivial.
-    Case (Aeq_dec a a0); Auto with datatypes.
-    Intro; Apply H; Intros; Auto.
-    Apply H1; Red; Intro.
-    Case H3; Auto.
-  Qed.
-
- 
-  Lemma set_mem_correct1 :
-    (a:A)(x:set)(set_mem a x)=true -> (set_In a x).
-  Proof.
-    Induction x; Simpl.
-    Discriminate.
-    Intros a0 l; Elim (Aeq_dec a a0); Auto with datatypes.
-  Qed.
-
-  Lemma set_mem_correct2 :
-    (a:A)(x:set)(set_In a x) -> (set_mem a x)=true.
-  Proof.
-    Induction x; Simpl.
-    Intro Ha; Elim Ha.
-    Intros a0 l; Elim (Aeq_dec a a0); Auto with datatypes.
-    Intros H1 H2 [H3 | H4].
-    Absurd a0=a; Auto with datatypes.
-    Auto with datatypes.
-  Qed.
-
-  Lemma set_mem_complete1 :
-    (a:A)(x:set)(set_mem a x)=false -> ~(set_In a x).
-  Proof.
-    Induction x; Simpl.
-    Tauto.
-    Intros a0 l; Elim (Aeq_dec a a0).
-    Intros; Discriminate H0.
-    Unfold not; Intros; Elim H1; Auto with datatypes.
-  Qed.
-
-  Lemma set_mem_complete2 :
-    (a:A)(x:set)~(set_In a x) -> (set_mem a x)=false.
-  Proof.
-    Induction x; Simpl.
-    Tauto.
-    Intros a0 l; Elim (Aeq_dec a a0).
-    Intros; Elim H0; Auto with datatypes.
-    Tauto.
-  Qed.
-
-  Lemma set_add_intro1 : (a,b:A)(x:set) 
-    (set_In a x) -> (set_In a (set_add b x)).
-
-  Proof.
-    Unfold set_In; Induction x; Simpl.
-    Auto with datatypes.
-    Intros a0 l H [ Ha0a | Hal ].
-    Elim (Aeq_dec b a0); Left; Assumption.
-    Elim (Aeq_dec b a0); Right; [ Assumption | Auto with datatypes ].
-  Qed.
-
-  Lemma set_add_intro2 : (a,b:A)(x:set) 
-    a=b -> (set_In a (set_add b x)).
-
-  Proof.
-    Unfold set_In; Induction x; Simpl.
-    Auto with datatypes.
-    Intros a0 l H Hab.
-    Elim (Aeq_dec b a0); 
-    [ Rewrite Hab; Intro Hba0; Rewrite Hba0; Simpl; Auto with datatypes
-    | Auto with datatypes ].
-  Qed.
-
-  Hints Resolve set_add_intro1 set_add_intro2.
-
-  Lemma set_add_intro : (a,b:A)(x:set) 
-    a=b\/(set_In a x) -> (set_In a (set_add b x)).
-  
-  Proof.
-    Intros a b x [H1 | H2] ; Auto with datatypes.
-  Qed.
- 
-  Lemma set_add_elim : (a,b:A)(x:set) 
-    (set_In a (set_add b x)) -> a=b\/(set_In a x).
-
-  Proof.
-    Unfold set_In.
-    Induction x.
-    Simpl; Intros [H1|H2]; Auto with datatypes.
-    Simpl; Do 3 Intro.
-    Elim (Aeq_dec b a0).
-    Simpl; Tauto.
-    Simpl; Intros; Elim H0.
-    Trivial with datatypes.
-    Tauto.
-    Tauto.
-  Qed.
-
-  Lemma set_add_elim2 :  (a,b:A)(x:set) 
-    (set_In a (set_add b x)) -> ~(a=b) -> (set_In a x).
-   Intros a b x H; Case (set_add_elim H); Intros; Trivial.
-   Case H1; Trivial.
-   Qed.
-
-  Hints Resolve set_add_intro set_add_elim set_add_elim2.
-
-  Lemma set_add_not_empty : (a:A)(x:set)~(set_add a x)=empty_set.
-  Proof.
-    Induction x; Simpl.
-    Discriminate.
-    Intros; Elim  (Aeq_dec a a0); Intros; Discriminate.
-  Qed.   
-
-
-  Lemma set_union_intro1 : (a:A)(x,y:set)
-    (set_In a x) -> (set_In a (set_union x y)).
-  Proof.
-    Induction y; Simpl; Auto with datatypes.
-  Qed.
-
-  Lemma set_union_intro2 : (a:A)(x,y:set)
-    (set_In a y) -> (set_In a (set_union x y)).
-  Proof.
-    Induction y; Simpl.
-    Tauto.
-    Intros; Elim H0; Auto with datatypes.
-  Qed.
-
-  Hints Resolve set_union_intro2 set_union_intro1.
-
-  Lemma set_union_intro : (a:A)(x,y:set)
-    (set_In a x)\/(set_In a y) -> (set_In a (set_union x y)).
-  Proof.
-    Intros; Elim H; Auto with datatypes.
-  Qed.
-
-  Lemma set_union_elim : (a:A)(x,y:set)
-    (set_In a (set_union x y)) -> (set_In a x)\/(set_In a y).
-  Proof.
-    Induction y; Simpl.
-    Auto with datatypes.
-    Intros.
-    Generalize (set_add_elim H0).
-    Intros [H1 | H1].
-    Auto with datatypes.
-    Tauto.
-  Qed.
-
-  Lemma set_union_emptyL : (a:A)(x:set)(set_In a (set_union empty_set x)) -> (set_In a x).
-    Intros a x H; Case (set_union_elim H); Auto Orelse Contradiction.
-  Qed.
-
-
-  Lemma set_union_emptyR : (a:A)(x:set)(set_In a (set_union x empty_set)) -> (set_In a x).
-    Intros a x H; Case (set_union_elim H); Auto Orelse Contradiction.
-  Qed.
-
-
-  Lemma set_inter_intro :  (a:A)(x,y:set)
-    (set_In a x) -> (set_In a y) -> (set_In a (set_inter x y)).
-  Proof.
-    Induction x.
-    Auto with datatypes.
-    Simpl; Intros a0 l Hrec y [Ha0a | Hal] Hy.
-    Simpl; Rewrite Ha0a.
-    Generalize (!set_mem_correct1 a y).
-    Generalize (!set_mem_complete1 a y).
-    Elim (set_mem a y); Simpl; Intros.
-    Auto with datatypes.
-    Absurd (set_In a y); Auto with datatypes.
-    Elim (set_mem a0 y); [ Right; Auto with datatypes | Auto with datatypes].     
-  Qed.
-
-  Lemma set_inter_elim1 : (a:A)(x,y:set)
-    (set_In a (set_inter x y)) -> (set_In a x).
-  Proof.
-    Induction x.
-    Auto with datatypes.
-    Simpl; Intros a0 l Hrec y.
-    Generalize (!set_mem_correct1 a0 y).
-    Elim (set_mem a0 y); Simpl; Intros.
-    Elim H0; EAuto with datatypes.
-    EAuto with datatypes.
-  Qed.
-
-  Lemma set_inter_elim2 : (a:A)(x,y:set)
-    (set_In a (set_inter x y)) -> (set_In a y).
-  Proof.
-    Induction x.
-    Simpl; Tauto.
-    Simpl; Intros a0 l Hrec y.
-    Generalize (!set_mem_correct1 a0 y).
-    Elim (set_mem a0 y); Simpl; Intros.
-    Elim H0; [ Intro Hr; Rewrite <- Hr; EAuto with datatypes  | EAuto with datatypes ] .
-    EAuto with datatypes.
-  Qed.
-
-  Hints Resolve set_inter_elim1 set_inter_elim2.
-
-  Lemma set_inter_elim : (a:A)(x,y:set)
-    (set_In a (set_inter x y)) -> (set_In a x)/\(set_In a y).
-  Proof.
-    EAuto with datatypes.
-  Qed. 
-
-  Lemma set_diff_intro : (a:A)(x,y:set)
-    (set_In a x) -> ~(set_In a y) -> (set_In a (set_diff x y)).
-  Proof.
-    Induction x.
-    Simpl; Tauto.
-    Simpl; Intros a0 l Hrec y [Ha0a | Hal] Hay.
-    Rewrite Ha0a; Generalize (set_mem_complete2 Hay).
-    Elim (set_mem a y); [ Intro Habs; Discriminate Habs | Auto with datatypes ].
-    Elim (set_mem a0 y); Auto with datatypes.
-  Qed.
-
-  Lemma set_diff_elim1 : (a:A)(x,y:set)
-    (set_In a (set_diff x y)) -> (set_In a x).
-  Proof.
-    Induction x.
-    Simpl; Tauto.
-    Simpl; Intros a0 l Hrec y; Elim (set_mem a0 y).
-    EAuto with datatypes.
-    Intro; Generalize (set_add_elim  H).
-    Intros [H1 | H2]; EAuto with datatypes.
-  Qed.
-
-  Lemma set_diff_elim2 : (a:A)(x,y:set)
-    (set_In a (set_diff x y)) -> ~(set_In a y).
-  Intros a x y; Elim x; Simpl.
-  Intros; Contradiction.
-  Intros a0 l Hrec. 
-  Apply set_mem_ind2; Auto.
-  Intros H1 H2; Case (set_add_elim H2); Intros; Auto.
-  Rewrite H; Trivial.
-  Qed.
-
-  Lemma set_diff_trivial : (a:A)(x:set)~(set_In a (set_diff x x)).
-  Red; Intros a x H.
-  Apply (set_diff_elim2 H).
-  Apply (set_diff_elim1 H).
-  Qed.
-
-Hints Resolve set_diff_intro set_diff_trivial.
-
-
-End first_definitions.
-
-Section other_definitions.
-
-  Variables A,B : Set.
-
-  Definition set_prod : (set A) -> (set B) -> (set A*B) := (list_prod 1!A 2!B).
-
-  (** [B^A], set of applications from [A] to [B] *)
-  Definition set_power : (set A) -> (set B) -> (set (set A*B)) := 
-    (list_power 1!A 2!B).
-
-  Definition set_map : (A->B) -> (set A) ->  (set B) := (map 1!A 2!B).
-
-  Definition set_fold_left : (B -> A -> B) -> (set A) -> B -> B := 
-     (fold_left 1!B 2!A).
-
-  Definition set_fold_right : (A -> B -> B) -> (set A) -> B -> B  := 
-     [f][x][b](fold_right f b x).
-
- 
-End other_definitions.
-
-V7only [Implicits nil [].].
-Unset Implicit Arguments.
diff --git a/theories7/Lists/MonoList.v b/theories7/Lists/MonoList.v
deleted file mode 100755
index 2ab78f7f..00000000
--- a/theories7/Lists/MonoList.v
+++ /dev/null
@@ -1,259 +0,0 @@
-(************************************************************************)
-(*  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: MonoList.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*)
-
-(** THIS IS A OLD CONTRIB. IT IS NO LONGER MAINTAINED ***)
-
-Require Le.
-
-Parameter List_Dom:Set.
-Definition A := List_Dom.
-
-Inductive list : Set := nil : list | cons : A -> list -> list.
-
-Fixpoint app [l:list] : list -> list 
-      := [m:list]<list>Cases l of
-                           nil =>  m 
-                       | (cons a l1) => (cons a (app l1 m)) 
-                   end.
-
-
-Lemma app_nil_end : (l:list)(l=(app l nil)).
-Proof. 
-	Intro l ; Elim l ; Simpl ; Auto.
-        Induction 1; Auto.
-Qed.
-Hints Resolve app_nil_end : list v62.
-
-Lemma app_ass : (l,m,n : list)(app (app l m) n)=(app l (app m n)).
-Proof. 
-	Intros l m n ; Elim l ; Simpl ; Auto with list.
-	Induction 1; Auto with list.
-Qed.
-Hints Resolve app_ass : list v62.
-
-Lemma ass_app : (l,m,n : list)(app l (app m n))=(app (app l m) n).
-Proof. 
-	Auto with list.
-Qed.
-Hints Resolve ass_app : list v62.
-
-Definition tail := 
-    [l:list] <list>Cases l of  (cons _ m) => m | _ => nil end : list->list.
-                   
-
-Lemma nil_cons : (a:A)(m:list)~nil=(cons a m).
-  Intros; Discriminate.
-Qed.
-
-(****************************************)
-(* Length of lists                      *)
-(****************************************)
-
-Fixpoint length [l:list] : nat 
-   := <nat>Cases l of (cons _ m) => (S (length m)) | _ => O end.
-
-(******************************)
-(* Length order of lists      *)
-(******************************)
-
-Section length_order.
-Definition lel := [l,m:list](le (length l) (length m)).
-
-Hints Unfold lel : list.
-
-Variables a,b:A.
-Variables l,m,n:list.
-
-Lemma lel_refl : (lel l l).
-Proof. 
-	Unfold lel ; Auto with list.
-Qed.
-
-Lemma lel_trans : (lel l m)->(lel m n)->(lel l n).
-Proof. 
-	Unfold lel ; Intros.
-        Apply le_trans with (length m) ; Auto with list.
-Qed.
-
-Lemma lel_cons_cons : (lel l m)->(lel (cons a l) (cons b m)).
-Proof. 
-	Unfold lel ; Simpl ; Auto with list arith.
-Qed.
-
-Lemma lel_cons : (lel l m)->(lel l (cons b m)).
-Proof. 
-	Unfold lel ; Simpl ; Auto with list arith.
-Qed.
-
-Lemma lel_tail : (lel (cons a l) (cons b m)) -> (lel l m).
-Proof. 
-	Unfold lel ; Simpl ; Auto with list arith.
-Qed.
-
-Lemma lel_nil : (l':list)(lel l' nil)->(nil=l').
-Proof. 
-	Intro l' ; Elim l' ; Auto with list arith.
-	Intros a' y H H0.
-	(*  <list>nil=(cons a' y)
-	    ============================
-	      H0 : (lel (cons a' y) nil)
-	      H : (lel y nil)->(<list>nil=y)
-	      y : list
-	      a' : A
-	      l' : list *)
-	Absurd (le (S (length y)) O); Auto with list arith.
-Qed.
-End length_order.
-
-Hints Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons : list v62.
-
-Fixpoint In  [a:A;l:list] : Prop :=
-      Cases l of
-         nil => False 
-      | (cons b m) => (b=a)\/(In a m)
-      end.
-
-Lemma in_eq : (a:A)(l:list)(In a (cons a l)).
-Proof. 
-	Simpl ; Auto with list.
-Qed.
-Hints Resolve in_eq : list v62.
-
-Lemma in_cons : (a,b:A)(l:list)(In b l)->(In b (cons a l)).
-Proof. 
-	Simpl ; Auto with list.
-Qed.
-Hints Resolve in_cons : list v62.
-
-Lemma in_app_or : (l,m:list)(a:A)(In a (app l m))->((In a l)\/(In a m)).
-Proof. 
-	Intros l m a.
-	Elim l ; Simpl ; Auto with list.
-	Intros a0 y H H0.
-	(*  ((<A>a0=a)\/(In a y))\/(In a m)
-	    ============================
-	      H0 : (<A>a0=a)\/(In a (app y m))
-	      H : (In a (app y m))->((In a y)\/(In a m))
-	      y : list
-	      a0 : A
-	      a : A
-	      m : list
-	      l : list *)
-	Elim H0 ; Auto with list.
-	Intro H1.
-	(*  ((<A>a0=a)\/(In a y))\/(In a m)
-	    ============================
-	      H1 : (In a (app y m)) *)
-	Elim (H H1) ; Auto with list.
-Qed.
-Hints Immediate in_app_or : list v62.
-
-Lemma in_or_app : (l,m:list)(a:A)((In a l)\/(In a m))->(In a (app l m)).
-Proof. 
-	Intros l m a.
-	Elim l ; Simpl ; Intro H.
-	(* 1 (In a m)
-	    ============================
-	      H : False\/(In a m)
-	      a : A
-	      m : list
-	      l : list *)
-	Elim H ; Auto with list ; Intro H0.
-	(*  (In a m)
-	    ============================
-	      H0 : False *)
-	Elim H0. (* subProof completed *)
-	Intros y H0 H1.
-	(*  2 (<A>H=a)\/(In a (app y m))
-	    ============================
-	      H1 : ((<A>H=a)\/(In a y))\/(In a m)
-	      H0 : ((In a y)\/(In a m))->(In a (app y m))
-	      y : list *)
-	Elim H1 ; Auto 4 with list.
-	Intro H2.
-	(*  (<A>H=a)\/(In a (app y m))
-	    ============================
-	      H2 : (<A>H=a)\/(In a y) *)
-	Elim H2 ; Auto with list.
-Qed.
-Hints Resolve in_or_app : list v62.
-
-Definition incl := [l,m:list](a:A)(In a l)->(In a m).
-
-Hints Unfold  incl : list v62.
-
-Lemma incl_refl : (l:list)(incl l l).
-Proof. 
-	Auto with list.
-Qed.
-Hints Resolve incl_refl : list v62.
-
-Lemma incl_tl : (a:A)(l,m:list)(incl l m)->(incl l (cons a m)).
-Proof. 
-	Auto with list.
-Qed.
-Hints Immediate incl_tl : list v62.
-
-Lemma incl_tran : (l,m,n:list)(incl l m)->(incl m n)->(incl l n).
-Proof. 
-	Auto with list.
-Qed.
-
-Lemma incl_appl : (l,m,n:list)(incl l n)->(incl l (app n m)).
-Proof. 
-	Auto with list.
-Qed.
-Hints Immediate incl_appl : list v62.
-
-Lemma incl_appr : (l,m,n:list)(incl l n)->(incl l (app m n)).
-Proof. 
-	Auto with list.
-Qed.
-Hints Immediate incl_appr : list v62.
-
-Lemma incl_cons : (a:A)(l,m:list)(In a m)->(incl l m)->(incl (cons a l) m).
-Proof. 
-	Unfold incl ; Simpl ; Intros a l m H H0 a0 H1.
-	(*  (In a0 m)
-	    ============================
-	      H1 : (<A>a=a0)\/(In a0 l)
-	      a0 : A
-	      H0 : (a:A)(In a l)->(In a m)
-	      H : (In a m)
-	      m : list
-	      l : list
-	      a : A *)
-	Elim H1.
-	(*  1 (<A>a=a0)->(In a0 m) *)
-	Elim H1 ; Auto with list ; Intro H2.
-	(*  (<A>a=a0)->(In a0 m)
-	    ============================
-	      H2 : <A>a=a0 *)
-	Elim H2 ; Auto with list. (* solves subgoal *)
-	(*  2 (In a0 l)->(In a0 m) *)
-	Auto with list.
-Qed.
-Hints Resolve incl_cons : list v62.
-
-Lemma incl_app : (l,m,n:list)(incl l n)->(incl m n)->(incl (app l m) n).
-Proof. 
-	Unfold incl ; Simpl ; Intros l m n H H0 a H1.
-	(*  (In a n)
-	    ============================
-	      H1 : (In a (app l m))
-	      a : A
-	      H0 : (a:A)(In a m)->(In a n)
-	      H : (a:A)(In a l)->(In a n)
-	      n : list
-	      m : list
-	      l : list *)
-	Elim (in_app_or l m a) ; Auto with list.
-Qed.
-Hints Resolve incl_app : list v62.
diff --git a/theories7/Lists/PolyList.v b/theories7/Lists/PolyList.v
deleted file mode 100644
index e69ecd10..00000000
--- a/theories7/Lists/PolyList.v
+++ /dev/null
@@ -1,646 +0,0 @@
-(************************************************************************)
-(*  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: PolyList.v,v 1.2.2.1 2004/07/16 19:31:28 herbelin Exp $ i*)
-
-Require Le.
-
-
-Section Lists.
-
-Variable A : Set.
-
-Set Implicit Arguments.
-
-Inductive list : Set := nil : list | cons : A -> list -> list.
-
-Infix "::" cons (at level 7, right associativity) : list_scope
-  V8only (at level 60, right associativity).
-
-Open Scope list_scope.
-
-(*************************)
-(** Discrimination       *)
-(*************************)
-
-Lemma nil_cons : (a:A)(m:list)~(nil=(cons a m)).
-Proof. 
-  Intros; Discriminate.
-Qed.
-
-(*************************)
-(** Concatenation        *)
-(*************************)
-
-Fixpoint app [l:list] : list -> list 
-      := [m:list]Cases l of
-                   nil         => m 
-                 | (cons a l1) => (cons a (app l1 m))
-                 end.
-
-Infix RIGHTA 7 "^" app : list_scope
-  V8only RIGHTA 60 "++".
-
-Lemma app_nil_end : (l:list)l=(l^nil).
-Proof. 
-	NewInduction l ; Simpl ; Auto.
-        Rewrite <- IHl; Auto.
-Qed.
-Hints Resolve app_nil_end.
-
-Tactic Definition now_show c := Change c.
-V7only [Tactic Definition NowShow := now_show.].
-
-Lemma app_ass : (l,m,n : list)((l^m)^ n)=(l^(m^n)).
-Proof. 
-	Intros. NewInduction l ; Simpl ; Auto.
-        NowShow '(cons a (app (app l m) n))=(cons a (app l (app m n))).
-	Rewrite <- IHl; Auto.
-Qed.
-Hints Resolve app_ass.
-
-Lemma ass_app : (l,m,n : list)(l^(m^n))=((l^m)^n).
-Proof. 
-	Auto.
-Qed.
-Hints Resolve ass_app.
-
-Lemma app_comm_cons : (x,y:list)(a:A) (cons a (x^y))=((cons a x)^y).
-Proof.
- Auto.
-Qed.
-
-Lemma app_eq_nil: (x,y:list) (x^y)=nil -> x=nil /\ y=nil.
-Proof.
-  NewDestruct x;NewDestruct y;Simpl;Auto.
-  Intros H;Discriminate H.
-  Intros;Discriminate H.
-Qed.
-
-Lemma app_cons_not_nil: (x,y:list)(a:A)~nil=(x^(cons a y)).
-Proof.
-Unfold not .
-  NewDestruct x;Simpl;Intros.
-  Discriminate H.
-  Discriminate H.
-Qed.
-
-Lemma app_eq_unit:(x,y:list)(a:A)
-     (x^y)=(cons a nil)-> (x=nil)/\ y=(cons a nil) \/ x=(cons a nil)/\ y=nil.
-
-Proof.
-  NewDestruct x;NewDestruct y;Simpl.
-  Intros a H;Discriminate H.
-  Left;Split;Auto.
-  Right;Split;Auto.
-  Generalize H .
-  Generalize (app_nil_end  l) ;Intros E.
-  Rewrite <- E;Auto.
-  Intros.
-  Injection H.
-  Intro.
-  Cut  nil=(l^(cons a0 l0));Auto.
-  Intro.
-  Generalize (app_cons_not_nil H1); Intro.
-  Elim H2.
-Qed.
-
-Lemma app_inj_tail : (x,y:list)(a,b:A)
-   (x^(cons a nil))=(y^(cons b nil)) -> x=y /\ a=b.
-Proof.
-  NewInduction x as [|x l IHl];NewDestruct y;Simpl;Auto.
-  Intros a b H.
-  Injection H.
-  Auto.
-  Intros a0 b H.
-  Injection H;Intros.
-  Generalize (app_cons_not_nil H0) ;NewDestruct 1.
-  Intros a b H.
-  Injection H;Intros.
-  Cut   nil=(l^(cons a nil));Auto.
-  Intro.
-  Generalize (app_cons_not_nil H2) ;NewDestruct 1.
-  Intros a0 b H.
-  Injection H;Intros.
-  NewDestruct (IHl l0 a0 b H0). 
-  Split;Auto.
-  Rewrite <- H1;Rewrite <- H2;Reflexivity.
-Qed.
-
-(*************************)
-(** Head and tail        *)
-(*************************)
-
-Definition head :=
-  [l:list]Cases l of
-  | nil => Error
-  | (cons x _) => (Value x)
-  end.
-
-Definition tail : list -> list :=
-  [l:list]Cases l of
-  | nil => nil 
-  | (cons a m) => m
-  end.
-
-(****************************************)
-(** Length of lists                     *)
-(****************************************)
-
-Fixpoint length [l:list] : nat 
-   := Cases l of nil => O | (cons _ m) => (S (length m)) end.
-
-(******************************)
-(** Length order of lists     *)
-(******************************)
-
-Section length_order.
-Definition lel := [l,m:list](le (length l) (length m)).
-
-Variables a,b:A.
-Variables l,m,n:list.
-
-Lemma lel_refl : (lel l l).
-Proof. 
-	Unfold lel ; Auto with arith.
-Qed.
-
-Lemma lel_trans : (lel l m)->(lel m n)->(lel l n).
-Proof. 
-	Unfold lel ; Intros.
-        NowShow '(le (length l) (length n)).
-        Apply le_trans with (length m) ; Auto with arith.
-Qed.
-
-Lemma lel_cons_cons : (lel l m)->(lel (cons a l) (cons b m)).
-Proof. 
-	Unfold lel ; Simpl ; Auto with arith.
-Qed.
-
-Lemma lel_cons : (lel l m)->(lel l (cons b m)).
-Proof. 
-	Unfold lel ; Simpl ; Auto with arith.
-Qed.
-
-Lemma lel_tail : (lel (cons a l) (cons b m)) -> (lel l m).
-Proof. 
-	Unfold lel ; Simpl ; Auto with arith.
-Qed.
-
-Lemma lel_nil : (l':list)(lel l' nil)->(nil=l').
-Proof. 
-	Intro l' ; Elim l' ; Auto with arith.
-	Intros a' y H H0.
-        NowShow 'nil=(cons a' y).
-	Absurd (le (S (length y)) O); Auto with arith.
-Qed.
-End length_order.
-
-Hints Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons.
-
-(*********************************)
-(** The [In] predicate           *)
-(*********************************)
-
-Fixpoint In  [a:A;l:list] : Prop :=
-      Cases l of nil => False | (cons b m) => (b=a)\/(In a m) end.
-
-Lemma in_eq : (a:A)(l:list)(In a (cons a l)).
-Proof. 
-	Simpl ; Auto.
-Qed.
-Hints Resolve in_eq.
-
-Lemma in_cons : (a,b:A)(l:list)(In b l)->(In b (cons a l)).
-Proof. 
-	Simpl ; Auto.
-Qed.
-Hints Resolve in_cons.
-
-Lemma in_nil : (a:A)~(In a nil).
-Proof.
-  Unfold not; Intros a H; Inversion_clear H.
-Qed.
-
-
-Lemma in_inv : (a,b:A)(l:list)
-               (In b (cons a l)) -> a=b \/ (In b l).
-Proof.
- Intros a b l H ; Inversion_clear H ; Auto.
-Qed.
-
-Lemma In_dec : ((x,y:A){x=y}+{~x=y}) ->   (a:A)(l:list){(In a l)}+{~(In a l)}.
-
-Proof.
-  NewInduction l as [|a0 l IHl].
-  Right; Apply in_nil.
-  NewDestruct (H a0 a); Simpl; Auto.
-  NewDestruct IHl; Simpl; Auto. 
-  Right; Unfold not; Intros [Hc1 | Hc2]; Auto.
-Qed.
-
-Lemma in_app_or : (l,m:list)(a:A)(In a (l^m))->((In a l)\/(In a m)).
-Proof. 
-	Intros l m a.
-	Elim l ; Simpl ; Auto.
-	Intros a0 y H H0.
-	NowShow '(a0=a\/(In a y))\/(In a m).
-	Elim H0 ; Auto.
-	Intro H1.
-        NowShow '(a0=a\/(In a y))\/(In a m).
-	Elim (H H1) ; Auto.
-Qed.
-Hints Immediate in_app_or.
-
-Lemma in_or_app : (l,m:list)(a:A)((In a l)\/(In a m))->(In a (l^m)).
-Proof. 
-	Intros l m a.
-	Elim l ; Simpl ; Intro H.
-        NowShow '(In a m).
-	Elim H ; Auto ; Intro H0.
-	NowShow '(In a m).
-	Elim H0. (* subProof completed *)
-	Intros y H0 H1.
-	NowShow 'H=a\/(In a (app y m)).
-	Elim H1 ; Auto 4.
-	Intro H2.
-	NowShow 'H=a\/(In a (app y m)).
-	Elim H2 ; Auto.
-Qed.
-Hints Resolve in_or_app.
-
-(***************************)
-(** Set inclusion on list  *)
-(***************************)
-
-Definition incl := [l,m:list](a:A)(In a l)->(In a m).
-Hints Unfold  incl.
-
-Lemma incl_refl : (l:list)(incl l l).
-Proof. 
-	Auto.
-Qed.
-Hints Resolve incl_refl.
-
-Lemma incl_tl : (a:A)(l,m:list)(incl l m)->(incl l (cons a m)).
-Proof. 
-	Auto.
-Qed.
-Hints Immediate incl_tl.
-
-Lemma incl_tran : (l,m,n:list)(incl l m)->(incl m n)->(incl l n).
-Proof. 
-	Auto.
-Qed.
-
-Lemma incl_appl : (l,m,n:list)(incl l n)->(incl l (n^m)).
-Proof. 
-	Auto.
-Qed.
-Hints Immediate incl_appl.
-
-Lemma incl_appr : (l,m,n:list)(incl l n)->(incl l (m^n)).
-Proof. 
-	Auto.
-Qed.
-Hints Immediate incl_appr.
-
-Lemma incl_cons : (a:A)(l,m:list)(In a m)->(incl l m)->(incl (cons a l) m).
-Proof. 
-	Unfold incl ; Simpl ; Intros a l m H H0 a0 H1.
-        NowShow '(In a0 m).
-	Elim H1.
-	NowShow 'a=a0->(In a0 m).
-	Elim H1 ; Auto ; Intro H2.
-	NowShow 'a=a0->(In a0 m).
-	Elim H2 ; Auto. (* solves subgoal *)
-	NowShow '(In a0 l)->(In a0 m).
-	Auto.
-Qed.
-Hints Resolve incl_cons.
-
-Lemma incl_app : (l,m,n:list)(incl l n)->(incl m n)->(incl (l^m) n).
-Proof. 
-	Unfold incl ; Simpl ; Intros l m n H H0 a H1.
-        NowShow '(In a n).
-	Elim (in_app_or H1); Auto.
-Qed.
-Hints Resolve incl_app.
-
-(**************************)
-(** Nth element of a list *)
-(**************************)
-
-Fixpoint nth [n:nat; l:list] : A->A :=
-  [default]Cases n l of
-    O (cons x l') => x
-  | O other => default
-  | (S m) nil => default
-  | (S m) (cons x t) => (nth m t default)
-  end.
-
-Fixpoint nth_ok [n:nat; l:list] : A->bool :=
-  [default]Cases n l of
-    O (cons x l') => true
-  | O other => false
-  | (S m) nil => false
-  | (S m) (cons x t) => (nth_ok m t default)
-  end.
-
-Lemma nth_in_or_default :
-  (n:nat)(l:list)(d:A){(In (nth n l d) l)}+{(nth n l d)=d}.
-(* Realizer nth_ok. Program_all. *)
-Proof. 
-  Intros n l d; Generalize n; NewInduction l; Intro n0.
-  Right; Case n0; Trivial.
-  Case n0; Simpl.
-  Auto.
-  Intro n1; Elim (IHl n1); Auto.     
-Qed.
-
-Lemma nth_S_cons :
- (n:nat)(l:list)(d:A)(a:A)(In (nth n l d) l)
-   ->(In (nth (S n) (cons a l) d) (cons a l)).
-Proof. 
-  Simpl; Auto.
-Qed.
-
-Fixpoint nth_error [l:list;n:nat] : (Exc A) :=
-  Cases n l of
-  | O (cons x _) => (Value x)
-  | (S n) (cons _ l) => (nth_error l n)
-  | _ _ => Error 
-  end.
-
-Definition nth_default : A -> list -> nat -> A :=
-  [default,l,n]Cases (nth_error l n) of
-  | (Some x) => x
-  | None => default
-  end.
-
-Lemma nth_In :
-  (n:nat)(l:list)(d:A)(lt n (length l))->(In (nth n l d) l).
-
-Proof.
-Unfold lt; NewInduction n as [|n hn]; Simpl.
-NewDestruct l ; Simpl ;  [ Inversion 2 | Auto].
-NewDestruct l as [|a l hl] ; Simpl.
-Inversion 2.
-Intros d ie ; Right ; Apply hn ; Auto with arith.
-Qed.
-
-(********************************)
-(** Decidable equality on lists *)
-(********************************)
-
-
-Lemma list_eq_dec : ((x,y:A){x=y}+{~x=y})->(x,y:list){x=y}+{~x=y}.
-Proof.
-  NewInduction x as [|a l IHl]; NewDestruct y as [|a0 l0]; Auto.
-  NewDestruct (H a a0) as [e|e].
-  NewDestruct (IHl l0) as [e'|e'].
-  Left; Rewrite e; Rewrite e'; Trivial.
-  Right; Red; Intro.
-  Apply e'; Injection H0; Trivial.
-  Right; Red; Intro.
-  Apply e; Injection H0; Trivial.
-Qed.
-
-(*************************)
-(**  Reverse             *)
-(*************************)
-
-Fixpoint rev [l:list] : list :=
-   Cases l of
-      nil        => nil
-   | (cons x l') => (rev l')^(cons x nil)
-   end.
-
-Lemma distr_rev : 
- (x,y:list) (rev (x^y))=((rev y)^(rev x)).
-Proof.
- NewInduction x as [|a l IHl].
- NewDestruct y.
- Simpl.
- Auto.
-
- Simpl.
- Apply app_nil_end;Auto.
-
- Intro y.
- Simpl.
- Rewrite (IHl y).
- Apply (app_ass (rev y) (rev l) (cons a nil)).
-Qed.
-
-Remark  rev_unit : (l:list)(a:A) (rev  l^(cons a nil))= (cons a (rev l)).
-Proof.
- Intros.
- Apply (distr_rev l (cons a nil));Simpl;Auto.
-Qed.
-
-Lemma idempot_rev : (l:list)(rev (rev l))=l.
-Proof.
- NewInduction l as [|a l IHl].
- Simpl;Auto.
-
- Simpl.
- Rewrite (rev_unit (rev l) a).
- Rewrite -> IHl;Auto.
-Qed.
-
-(*********************************************)
-(**  Reverse Induction Principle on Lists    *)
-(*********************************************)
-
-Section Reverse_Induction.
-
-Unset Implicit Arguments.
-
-Remark rev_list_ind: (P:list->Prop)
-      (P nil)
-       ->((a:A)(l:list)(P (rev l))->(P (rev  (cons a l)))) 
-             ->(l:list) (P (rev  l)).
-Proof.
- NewInduction l; Auto.
-Qed.
-Set Implicit Arguments.
-
-Lemma rev_ind : 
- (P:list->Prop)
-   (P nil)->
-    ((x:A)(l:list)(P l)->(P l^(cons x nil)))
-      ->(l:list)(P l).
-Proof.
- Intros.
- Generalize (idempot_rev l) .
- Intros E;Rewrite <- E.
- Apply (rev_list_ind P).
- Auto.
-
- Simpl.
- Intros.
- Apply (H0 a (rev l0)).
- Auto.
-Qed.
-
-End Reverse_Induction.
-
-End Lists.
-
-Implicits nil [1].
-
-Hints Resolve nil_cons app_nil_end ass_app app_ass : datatypes v62.
-Hints Resolve app_comm_cons  app_cons_not_nil : datatypes v62.
-Hints Immediate app_eq_nil : datatypes v62.
-Hints Resolve app_eq_unit app_inj_tail : datatypes v62. 
-Hints Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons 
-   : datatypes v62.
-Hints Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app : datatypes v62.
-Hints Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons incl_app 
-  : datatypes v62.
-
-Section Functions_on_lists.
-
-(****************************************************************)
-(** Some generic functions on lists and basic functions of them *)
-(****************************************************************)
-
-Section Map.
-Variables A,B:Set.
-Variable  f:A->B.
-Fixpoint map [l:(list A)] : (list B) :=
-  Cases l of 
-     nil       => nil
-  | (cons a t) => (cons (f a) (map t))
-  end.
-End Map.
-
-Lemma in_map : (A,B:Set)(f:A->B)(l:(list A))(x:A)
-  (In x l) -> (In (f x) (map f l)).
-Proof. 
-  NewInduction l as [|a l IHl]; Simpl;
-  [ Auto
-  | NewDestruct 1;
-    [ Left; Apply f_equal with f:=f; Assumption
-    | Auto]
-  ].
-Qed.
-
-Fixpoint flat_map [A,B:Set; f:A->(list B); l:(list A)] : (list B) :=
-  Cases l of
-    nil => nil
-  | (cons x t) => (app (f x) (flat_map f t))
-  end.
-
-Fixpoint list_prod [A:Set; B:Set; l:(list A)] : (list B)->(list A*B) :=
-  [l']Cases l of
-    nil => nil
-  | (cons x t) => (app (map [y:B](x,y) l')
-      	       	       	     (list_prod t l'))
-  end.
-
-Lemma in_prod_aux :
-  (A:Set)(B:Set)(x:A)(y:B)(l:(list B))
-    (In y l) -> (In (x,y) (map [y0:B](x,y0) l)).
-Proof. 
-  NewInduction l;
-  [ Simpl; Auto
-  | Simpl; NewDestruct 1 as [H1|];
-    [ Left; Rewrite H1; Trivial
-    | Right; Auto]
-  ].
-Qed.
-
-Lemma in_prod : (A:Set)(B:Set)(l:(list A))(l':(list B))
-  (x:A)(y:B)(In x l)->(In y l')->(In (x,y) (list_prod l l')).
-Proof. 
-  NewInduction l;
-  [ Simpl; Tauto
-  | Simpl; Intros; Apply in_or_app; NewDestruct H;
-    [ Left; Rewrite H; Apply in_prod_aux; Assumption
-    | Right; Auto]
-  ].
-Qed.
-
-(** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
-    indexed by elts of [x], sorted in lexicographic order. *)
-
-Fixpoint list_power [A,B:Set; l:(list A)] : (list B)->(list (list A*B)) :=
-  [l']Cases l of
-    nil => (cons nil nil)
-  | (cons x t) => (flat_map [f:(list A*B)](map [y:B](cons (x,y) f) l') 
-      	       	       	    (list_power t l'))
-  end.
-
-(************************************)
-(** Left-to-right iterator on lists *)
-(************************************)
-
-Section Fold_Left_Recursor.
-Variables A,B:Set.
-Variable  f:A->B->A.
-Fixpoint fold_left[l:(list B)] : A -> A :=
-[a0]Cases l of
-     nil       => a0
-  | (cons b t) => (fold_left t (f a0 b))
-  end.
-End Fold_Left_Recursor.
-
-(************************************)
-(** Right-to-left iterator on lists *)
-(************************************)
-
-Section Fold_Right_Recursor.
-Variables A,B:Set.
-Variable  f:B->A->A.
-Variable  a0:A.
-Fixpoint fold_right [l:(list B)] : A :=
-  Cases l of
-    nil => a0
-  | (cons b t) => (f b (fold_right t))
-  end.
-End Fold_Right_Recursor.
-
-Theorem fold_symmetric :
-  (A:Set)(f:A->A->A)
-   ((x,y,z:A)(f x (f y z))=(f (f x y) z))
-    ->((x,y:A)(f x y)=(f y x))
-     ->(a0:A)(l:(list A))(fold_left f l a0)=(fold_right f a0 l).
-Proof.
-NewDestruct l as [|a l].
-Reflexivity.
-Simpl.
-Rewrite <- H0.
-Generalize a0 a.
-NewInduction l as [|a3 l IHl]; Simpl.
-Trivial.
-Intros.
-Rewrite H.
-Rewrite (H0 a2).
-Rewrite <- (H a1).
-Rewrite (H0 a1).
-Rewrite IHl.
-Reflexivity.
-Qed.
-
-End Functions_on_lists.
-
-V7only [Implicits nil [].].
-
-(** Exporting list notations *)
-
-V8Infix "::" cons (at level 60, right associativity) : list_scope.
-
-Infix RIGHTA 7 "^" app : list_scope V8only RIGHTA 60 "++".
-
-Open Scope list_scope.
-
-Delimits Scope list_scope with list.
-
-Bind Scope list_scope with list.
diff --git a/theories7/Lists/PolyListSyntax.v b/theories7/Lists/PolyListSyntax.v
deleted file mode 100644
index 15c57166..00000000
--- a/theories7/Lists/PolyListSyntax.v
+++ /dev/null
@@ -1,10 +0,0 @@
-(************************************************************************)
-(*  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: PolyListSyntax.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
diff --git a/theories7/Lists/Streams.v b/theories7/Lists/Streams.v
deleted file mode 100755
index ccfc4895..00000000
--- a/theories7/Lists/Streams.v
+++ /dev/null
@@ -1,170 +0,0 @@
-(************************************************************************)
-(*  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: Streams.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-Set Implicit Arguments.
-
-(** Streams *)
-
-Section Streams.
-
-Variable A : Set.
-
-CoInductive Set Stream   := Cons : A->Stream->Stream.
-
-
-Definition hd  := 
-  [x:Stream] Cases x of (Cons a _) => a end.
-
-Definition tl  := 
-  [x:Stream] Cases x of (Cons _ s) => s end.
-
-
-Fixpoint Str_nth_tl [n:nat] : Stream->Stream := 
-  [s:Stream] Cases n of
-	          O    => s
-		|(S m) => (Str_nth_tl m (tl s))
-	    end.
-
-Definition Str_nth : nat->Stream->A := [n:nat][s:Stream](hd (Str_nth_tl n s)).
-
-
-Lemma unfold_Stream :(x:Stream)x=(Cases x of (Cons a s) => (Cons a s) end). 
-Proof.
-  Intro x.
-  Case x.
-  Trivial.
-Qed.
-
-Lemma tl_nth_tl : (n:nat)(s:Stream)(tl (Str_nth_tl n s))=(Str_nth_tl n (tl s)).
-Proof.
-  Induction n; Simpl; Auto.
-Qed.
-Hints Resolve tl_nth_tl : datatypes v62.
-
-Lemma Str_nth_tl_plus 
-: (n,m:nat)(s:Stream)(Str_nth_tl n (Str_nth_tl m s))=(Str_nth_tl (plus n m) s).
-Induction n; Simpl; Intros; Auto with datatypes.
-Rewrite <- H.
-Rewrite tl_nth_tl; Trivial with datatypes.
-Qed.
-
-Lemma Str_nth_plus 
-  : (n,m:nat)(s:Stream)(Str_nth n (Str_nth_tl m s))=(Str_nth (plus n m) s).
-Intros; Unfold Str_nth; Rewrite Str_nth_tl_plus; Trivial with datatypes.
-Qed.
-
-(** Extensional Equality between two streams  *)
-
-CoInductive EqSt  : Stream->Stream->Prop := 
-	    eqst : (s1,s2:Stream)
-		   ((hd s1)=(hd s2))->
-		   (EqSt (tl s1) (tl s2))
-                    ->(EqSt s1 s2).
-
-(** A coinduction principle *)
-
-Tactic Definition CoInduction proof := 
-  Cofix proof; Intros; Constructor;
-    [Clear proof | Try (Apply proof;Clear proof)].
-
-
-(** Extensional equality is an equivalence relation *)
-
-Theorem  EqSt_reflex : (s:Stream)(EqSt s s).
-CoInduction EqSt_reflex.
-Reflexivity.
-Qed.
-
-Theorem sym_EqSt : 
- (s1:Stream)(s2:Stream)(EqSt s1 s2)->(EqSt s2 s1).
-(CoInduction Eq_sym).
-Case H;Intros;Symmetry;Assumption.
-Case H;Intros;Assumption.
-Qed.
-
-
-Theorem trans_EqSt : 
- (s1,s2,s3:Stream)(EqSt s1 s2)->(EqSt s2 s3)->(EqSt s1 s3).
-(CoInduction Eq_trans).
-Transitivity (hd s2).
-Case H; Intros; Assumption.
-Case H0; Intros; Assumption.
-Apply (Eq_trans (tl s1) (tl s2) (tl s3)).
-Case H;  Trivial with datatypes.
-Case H0; Trivial with datatypes.
-Qed.
-
-(** The definition given is equivalent to require the elements at each
-    position to be equal *)
-
-Theorem eqst_ntheq :
-  (n:nat)(s1,s2:Stream)(EqSt s1 s2)->(Str_nth n s1)=(Str_nth n s2).
-Unfold Str_nth; Induction n.
-Intros s1 s2 H; Case H; Trivial with datatypes.
-Intros m hypind.
-Simpl.
-Intros s1 s2 H.
-Apply hypind.
-Case H; Trivial with datatypes.
-Qed.
-
-Theorem ntheq_eqst : 
-  (s1,s2:Stream)((n:nat)(Str_nth n s1)=(Str_nth n s2))->(EqSt s1 s2).
-(CoInduction Equiv2).
-Apply (H O).
-Intros n; Apply (H (S n)).
-Qed.
-
-Section Stream_Properties.
-
-Variable P : Stream->Prop.
-
-(*i
-Inductive Exists : Stream -> Prop :=
-  | Here    : forall x:Stream, P x -> Exists x
-  | Further : forall x:Stream, ~ P x -> Exists (tl x) -> Exists x.
-i*)
-
-Inductive   Exists :  Stream -> Prop :=
-   Here    : (x:Stream)(P x) ->(Exists x) |
-   Further : (x:Stream)(Exists (tl x))->(Exists x).
-
-CoInductive ForAll : Stream  -> Prop :=
-    forall : (x:Stream)(P x)->(ForAll (tl x))->(ForAll x).
-
-
-Section Co_Induction_ForAll.
-Variable   Inv        :  Stream -> Prop.
-Hypothesis InvThenP   : (x:Stream)(Inv x)->(P x).
-Hypothesis InvIsStable: (x:Stream)(Inv x)->(Inv (tl x)).
-
-Theorem ForAll_coind : (x:Stream)(Inv x)->(ForAll x).
-(CoInduction ForAll_coind);Auto.
-Qed.
-End Co_Induction_ForAll.
-
-End Stream_Properties.
-
-End Streams.
-
-Section Map.
-Variables A,B : Set.
-Variable  f   : A->B.
-CoFixpoint map : (Stream A)->(Stream B) :=
- [s:(Stream A)](Cons (f (hd s)) (map (tl s))).
-End Map.
-
-Section Constant_Stream.
-Variable A : Set.
-Variable a : A.
-CoFixpoint const : (Stream A) := (Cons a const).
-End Constant_Stream.
-
-Unset Implicit Arguments.
diff --git a/theories7/Lists/TheoryList.v b/theories7/Lists/TheoryList.v
deleted file mode 100755
index f7adda70..00000000
--- a/theories7/Lists/TheoryList.v
+++ /dev/null
@@ -1,386 +0,0 @@
-(************************************************************************)
-(*  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: TheoryList.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** Some programs and results about lists following CAML Manual *)
-
-Require Export PolyList.
-Set Implicit Arguments.
-Chapter Lists.
-
-Variable  A : Set.
-
-(**********************)
-(** The null function *)
-(**********************)
-
-Definition Isnil : (list A) -> Prop := [l:(list A)](nil A)=l.
-
-Lemma Isnil_nil : (Isnil (nil A)).
-Red; Auto.
-Qed.
-Hints Resolve Isnil_nil.
-
-Lemma not_Isnil_cons : (a:A)(l:(list A))~(Isnil (cons a l)).
-Unfold Isnil.
-Intros; Discriminate.
-Qed.
-
-Hints Resolve Isnil_nil not_Isnil_cons.
-
-Lemma Isnil_dec : (l:(list A)){(Isnil l)}+{~(Isnil l)}.
-Intro l; Case l;Auto.
-(*
-Realizer (fun l => match l with
-  | nil => true
-  | _ => false
-  end).
-*)
-Qed.
-
-(************************)
-(** The Uncons function *)
-(************************)
-
-Lemma Uncons : (l:(list A)){a : A & { m: (list A) | (cons a m)=l}}+{Isnil l}.
-Intro l; Case l.
-Auto.
-Intros a m; Intros; Left; Exists a; Exists m; Reflexivity.
-(*
-Realizer (fun l => match l with
-  | nil => error
-  | (cons a m) => value (a,m)
-  end).
-*)
-Qed.
-
-(********************************)
-(** The head function           *)
-(********************************)
-
-Lemma Hd : (l:(list A)){a : A | (EX m:(list A) |(cons a m)=l)}+{Isnil l}.
-Intro l; Case l.
-Auto.
-Intros a m; Intros; Left; Exists a; Exists m; Reflexivity.
-(*
-Realizer (fun l => match l with
-  | nil => error
-  | (cons a m) => value a
-  end).
-*)
-Qed.
-
-Lemma Tl : (l:(list A)){m:(list A)| (EX a:A |(cons a m)=l)
-                         \/ ((Isnil l) /\ (Isnil m)) }.
-Intro l; Case l.
-Exists (nil A); Auto.
-Intros a m; Intros; Exists m; Left; Exists a; Reflexivity.
-(*
-Realizer (fun l => match l with
-  | nil => nil
-  | (cons a m) => m
-  end).
-*)
-Qed.
-
-(****************************************)
-(** Length of lists                     *)
-(****************************************)
-
-(* length is defined in List *)
-Fixpoint Length_l [l:(list A)] : nat -> nat 
-  :=  [n:nat] Cases l of
-                  nil => n
-              | (cons _ m) => (Length_l m (S n))
-	     end.
-
-(* A tail recursive version *)
-Lemma Length_l_pf : (l:(list A))(n:nat){m:nat|(plus n (length l))=m}.
-NewInduction l as [|a m lrec].
-Intro n; Exists n; Simpl; Auto.
-Intro n; Elim (lrec (S n)); Simpl; Intros.
-Exists x; Transitivity (S (plus n (length m))); Auto.
-(*
-Realizer Length_l.
-*)
-Qed.
-
-Lemma Length : (l:(list A)){m:nat|(length l)=m}.
-Intro l. Apply (Length_l_pf l O).
-(*
-Realizer (fun l -> Length_l_pf l O).
-*)
-Qed.
-
-(*******************************)
-(** Members of lists           *)
-(*******************************)
-Inductive In_spec [a:A] : (list A) -> Prop := 
-   | in_hd : (l:(list A))(In_spec a (cons a l))
-   | in_tl : (l:(list A))(b:A)(In a l)->(In_spec a (cons b l)).
-Hints Resolve in_hd in_tl.
-Hints Unfold  In.
-Hints Resolve in_cons.
-
-Theorem In_In_spec : (a:A)(l:(list A))(In a l) <-> (In_spec a l).
-Split.
-Elim l; [ Intros; Contradiction 
-      	| Intros; Elim H0; 
-	  [ Intros; Rewrite H1; Auto
-	  | Auto ]].
-Intros; Elim H; Auto.
-Qed.
-
-Inductive AllS [P:A->Prop] : (list A) -> Prop 
-   := allS_nil : (AllS P (nil A))
-   | allS_cons : (a:A)(l:(list A))(P a)->(AllS P l)->(AllS P (cons a l)).
-Hints Resolve allS_nil allS_cons.
-
-Hypothesis eqA_dec : (a,b:A){a=b}+{~a=b}.
-
-Fixpoint mem [a:A; l:(list A)] : bool :=
-  Cases l of
-    nil => false
-  | (cons b m) => if (eqA_dec a b) then [H]true else [H](mem a m)
-  end.
-
-Hints Unfold  In.
-Lemma Mem : (a:A)(l:(list A)){(In a l)}+{(AllS [b:A]~b=a l)}.
-Intros a l.
-NewInduction l.
-Auto.
-Elim (eqA_dec a a0).
-Auto.
-Simpl. Elim IHl; Auto.
-(*
-Realizer mem.
-*)
-Qed.
-
-(*********************************)
-(** Index of elements            *)
-(*********************************)
-
-Require Le.
-Require Lt.
-
-Inductive nth_spec : (list A)->nat->A->Prop :=
-  nth_spec_O : (a:A)(l:(list A))(nth_spec (cons a l) (S O) a)
-| nth_spec_S : (n:nat)(a,b:A)(l:(list A))
-           (nth_spec l n a)->(nth_spec (cons b l) (S n) a).
-Hints Resolve nth_spec_O nth_spec_S.
-
-Inductive fst_nth_spec : (list A)->nat->A->Prop :=
-  fst_nth_O : (a:A)(l:(list A))(fst_nth_spec (cons a l) (S O) a)
-| fst_nth_S : (n:nat)(a,b:A)(l:(list A))(~a=b)->
-           (fst_nth_spec l n a)->(fst_nth_spec (cons b l) (S n) a).
-Hints Resolve fst_nth_O fst_nth_S.
-
-Lemma fst_nth_nth : (l:(list A))(n:nat)(a:A)(fst_nth_spec l n a)->(nth_spec l n a).
-NewInduction 1; Auto.
-Qed.
-Hints Immediate fst_nth_nth.
-
-Lemma nth_lt_O : (l:(list A))(n:nat)(a:A)(nth_spec l n a)->(lt O n).
-NewInduction 1; Auto.
-Qed.
-
-Lemma nth_le_length : (l:(list A))(n:nat)(a:A)(nth_spec l n a)->(le n (length l)).
-NewInduction 1; Simpl; Auto with arith.
-Qed.
-
-Fixpoint Nth_func [l:(list A)] : nat -> (Exc A) 
-  := [n:nat] Cases  l  n  of 
-               (cons a _)  (S O)       => (value A a) 
-             | (cons _ l') (S (S p)) => (Nth_func l' (S p))
-             |  _ _      => Error
-            end.
-
-Lemma Nth : (l:(list A))(n:nat)
-            {a:A|(nth_spec l n a)}+{(n=O)\/(lt (length l) n)}.
-NewInduction l as [|a l IHl].
-Intro n; Case n; Simpl; Auto with arith.
-Intro n; NewDestruct n as [|[|n1]]; Simpl; Auto.
-Left; Exists a; Auto.
-NewDestruct (IHl (S n1)) as [[b]|o].
-Left; Exists b; Auto.
-Right; NewDestruct o.
-Absurd (S n1)=O; Auto.
-Auto with arith.
-(*
-Realizer Nth_func.
-*)
-Qed.
-
-Lemma Item : (l:(list A))(n:nat){a:A|(nth_spec l (S n) a)}+{(le (length l) n)}.
-Intros l n; Case (Nth l (S n)); Intro.
-Case s; Intro a; Left; Exists a; Auto.
-Right; Case o; Intro.
-Absurd (S n)=O; Auto.
-Auto with arith.
-Qed.
-
-Require Minus.
-Require DecBool.
-
-Fixpoint index_p [a:A;l:(list A)] : nat -> (Exc nat) := 
-   Cases l of nil => [p]Error
-     | (cons b m) => [p](ifdec (eqA_dec a b) (Value p) (index_p a m (S p)))
-   end.
-
-Lemma Index_p : (a:A)(l:(list A))(p:nat)
-     {n:nat|(fst_nth_spec l (minus (S n) p) a)}+{(AllS [b:A]~a=b l)}.
-NewInduction l as [|b m irec].
-Auto.
-Intro p.
-NewDestruct (eqA_dec a b) as [e|e].
-Left; Exists p.
-NewDestruct e; Elim minus_Sn_m; Trivial; Elim minus_n_n; Auto with arith.
-NewDestruct (irec (S p)) as [[n H]|].
-Left; Exists n; Auto with arith.
-Elim minus_Sn_m; Auto with arith.
-Apply lt_le_weak; Apply lt_O_minus_lt; Apply nth_lt_O with m a; Auto with arith.
-Auto.
-Qed.
-
-Lemma Index : (a:A)(l:(list A))
-     {n:nat|(fst_nth_spec l n a)}+{(AllS [b:A]~a=b l)}.
-
-Intros a l; Case (Index_p a l (S O)); Auto.
-Intros (n,P); Left; Exists n; Auto.
-Rewrite (minus_n_O n); Trivial.
-(*
-Realizer (fun a l -> Index_p a l (S O)).
-*)
-Qed.
-
-Section Find_sec.
-Variable R,P : A -> Prop.
-
-Inductive InR : (list A) -> Prop 
-   := inR_hd : (a:A)(l:(list A))(R a)->(InR (cons a l))
-   | inR_tl : (a:A)(l:(list A))(InR l)->(InR (cons a l)).
-Hints Resolve inR_hd inR_tl.
-
-Definition InR_inv := 
-       [l:(list A)]Cases l of 
-                   nil => False 
-                | (cons b m) => (R b)\/(InR m) 
-               end.
-
-Lemma InR_INV : (l:(list A))(InR l)->(InR_inv l).
-NewInduction 1; Simpl; Auto.
-Qed.
-
-Lemma InR_cons_inv : (a:A)(l:(list A))(InR (cons a l))->((R a)\/(InR l)).
-Intros a l H; Exact (InR_INV H).
-Qed.
-
-Lemma InR_or_app : (l,m:(list A))((InR l)\/(InR m))->(InR (app l m)).
-Intros l m [|].
-NewInduction 1; Simpl; Auto.
-Intro. NewInduction l; Simpl; Auto.
-Qed.
-
-Lemma InR_app_or : (l,m:(list A))(InR (app l m))->((InR l)\/(InR m)).
-Intros l m; Elim l; Simpl; Auto.
-Intros b l' Hrec IAc; Elim (InR_cons_inv IAc);Auto.
-Intros; Elim Hrec; Auto.
-Qed.
-
-Hypothesis RS_dec : (a:A){(R a)}+{(P a)}.
-
-Fixpoint find [l:(list A)] : (Exc A) := 
-	Cases l of nil => Error
-                | (cons a m) => (ifdec (RS_dec a) (Value a) (find m))
-        end.
-
-Lemma Find : (l:(list A)){a:A | (In a l) & (R a)}+{(AllS P l)}.
-NewInduction l as [|a m [[b H1 H2]|H]]; Auto.
-Left; Exists b; Auto.
-NewDestruct (RS_dec a).
-Left; Exists a; Auto.
-Auto.
-(*
-Realizer find.
-*)
-Qed.
-
-Variable B : Set.
-Variable T : A -> B -> Prop.
-
-Variable TS_dec : (a:A){c:B| (T a c)}+{(P a)}.
-
-Fixpoint try_find [l:(list A)] : (Exc B) :=
-   Cases l of
-     nil => Error
-   | (cons a l1) =>
-	   Cases (TS_dec a) of
-	     (inleft (exist c _)) => (Value c)
-	   | (inright _) => (try_find l1)
-	   end
-   end.
-
-Lemma Try_find : (l:(list A)){c:B|(EX a:A |(In a l) & (T a c))}+{(AllS P l)}.
-NewInduction l as [|a m [[b H1]|H]].
-Auto.
-Left; Exists b; NewDestruct H1 as [a' H2 H3]; Exists a'; Auto.
-NewDestruct (TS_dec a) as [[c H1]|].
-Left; Exists c.
-Exists a; Auto.
-Auto.
-(* 
-Realizer try_find.
-*)
-Qed.
-
-End Find_sec.
-
-Section Assoc_sec.
-
-Variable B : Set.
-Fixpoint assoc [a:A;l:(list A*B)] : (Exc B) :=
-    Cases l of        nil => Error
-        | (cons (a',b) m) => (ifdec (eqA_dec a a') (Value b) (assoc a m))
-    end.
-
-Inductive AllS_assoc [P:A -> Prop]: (list A*B) -> Prop := 
-      allS_assoc_nil : (AllS_assoc P (nil A*B))
-    | allS_assoc_cons : (a:A)(b:B)(l:(list A*B))
-        (P a)->(AllS_assoc P l)->(AllS_assoc P (cons (a,b) l)).
-
-Hints Resolve allS_assoc_nil allS_assoc_cons.
-
-(* The specification seems too weak: it is enough to return b if the
-   list has at least an element (a,b); probably the intention is to have
-   the specification
-
-   (a:A)(l:(list A*B)){b:B|(In_spec (a,b) l)}+{(AllS_assoc [a':A]~(a=a') l)}.
-*)
-
-Lemma Assoc : (a:A)(l:(list A*B))(B+{(AllS_assoc [a':A]~(a=a') l)}).
-NewInduction l as [|[a' b] m assrec]. Auto.
-NewDestruct (eqA_dec a a').
-Left; Exact b.
-NewDestruct assrec as [b'|].
-Left; Exact b'.
-Right; Auto.
-(*
-Realizer assoc.
-*)
-Qed.
-
-End Assoc_sec.
-
-End Lists.
-
-Hints Resolve Isnil_nil not_Isnil_cons in_hd in_tl in_cons allS_nil allS_cons 
- : datatypes.
-Hints Immediate fst_nth_nth : datatypes.
-
diff --git a/theories7/Logic/Berardi.v b/theories7/Logic/Berardi.v
deleted file mode 100644
index db9007ec..00000000
--- a/theories7/Logic/Berardi.v
+++ /dev/null
@@ -1,170 +0,0 @@
-(************************************************************************)
-(*  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: Berardi.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** This file formalizes Berardi's paradox which says that in
-   the calculus of constructions, excluded middle (EM) and axiom of
-   choice (AC) implie proof irrelevenace (PI).
-   Here, the axiom of choice is not necessary because of the use
-   of inductive types.
-<<
-@article{Barbanera-Berardi:JFP96,
-   author    = {F. Barbanera and S. Berardi},
-   title     = {Proof-irrelevance out of Excluded-middle and Choice
-                in the Calculus of Constructions},
-   journal   = {Journal of Functional Programming},
-   year      = {1996},
-   volume    = {6},
-   number    = {3},
-   pages     = {519-525}
-}
->> *)
-
-Set Implicit Arguments.
-
-Section Berardis_paradox.
-
-(** Excluded middle *)
-Hypothesis EM : (P:Prop) P \/ ~P.
-
-(** Conditional on any proposition. *)
-Definition IFProp := [P,B:Prop][e1,e2:P]
-  Cases (EM B) of
-    (or_introl _) => e1
-  | (or_intror _) => e2
-  end.
-
-(** Axiom of choice applied to disjunction.
-    Provable in Coq because of dependent elimination. *)
-Lemma AC_IF : (P,B:Prop)(e1,e2:P)(Q:P->Prop)
-  ( B -> (Q e1))->
-  (~B -> (Q e2))->
-  (Q (IFProp B e1 e2)).
-Proof.
-Intros P B e1 e2 Q p1 p2.
-Unfold IFProp.
-Case (EM B); Assumption.
-Qed.
-
-
-(** We assume a type with two elements. They play the role of booleans.
-    The main theorem under the current assumptions is that [T=F] *)
-Variable Bool: Prop.
-Variable T: Bool.
-Variable F: Bool.
-
-(** The powerset operator *)
-Definition pow [P:Prop] :=P->Bool.
-
-
-(** A piece of theory about retracts *)
-Section Retracts.
-
-Variable A,B: Prop.
-
-Record retract : Prop := {
-    i: A->B;
-    j: B->A;
-    inv: (a:A)(j (i a))==a
-  }.
-
-Record retract_cond : Prop := {
-    i2: A->B;
-    j2: B->A;
-    inv2: retract -> (a:A)(j2 (i2 a))==a
-  }.
-
-
-(** The dependent elimination above implies the axiom of choice: *)
-Lemma AC: (r:retract_cond) retract -> (a:A)((j2 r) ((i2 r) a))==a.
-Proof.
-Intros r.
-Case r; Simpl.
-Trivial.
-Qed.
-
-End Retracts.
-
-(** This lemma is basically a commutation of implication and existential
-    quantification:  (EX x | A -> P(x))  <=> (A -> EX x | P(x))
-    which is provable in classical logic ( => is already provable in
-    intuitionnistic logic). *)
-
-Lemma L1 : (A,B:Prop)(retract_cond (pow A) (pow B)).
-Proof.
-Intros A B.
-Elim (EM (retract (pow A) (pow B))).
-Intros (f0, g0, e).
-Exists f0 g0.
-Trivial.
-
-Intros hf.
-Exists ([x:(pow A); y:B]F) ([x:(pow B); y:A]F).
-Intros; Elim hf; Auto.
-Qed.
-
-
-(** The paradoxical set *)
-Definition U := (P:Prop)(pow P).
-
-(** Bijection between [U] and [(pow U)] *)
-Definition f : U -> (pow U) :=
-  [u](u U).
-
-Definition g : (pow U) -> U :=
-  [h,X]
-    let lX = (j2 (L1 X U)) in
-    let rU = (i2 (L1 U U)) in
-    (lX (rU h)).
-
-(** We deduce that the powerset of [U] is a retract of [U].
-    This lemma is stated in Berardi's article, but is not used
-    afterwards. *)
-Lemma retract_pow_U_U : (retract (pow U) U).
-Proof.
-Exists g f.
-Intro a.
-Unfold f g; Simpl.
-Apply AC.
-Exists ([x:(pow U)]x) ([x:(pow U)]x).
-Trivial.
-Qed.
-
-(** Encoding of Russel's paradox *)
-
-(** The boolean negation. *)
-Definition Not_b := [b:Bool](IFProp b==T F T).
-
-(** the set of elements not belonging to itself *)
-Definition R : U := (g ([u:U](Not_b (u U u)))).
-
-
-Lemma not_has_fixpoint : (R R)==(Not_b (R R)).
-Proof.
-Unfold 1 R.
-Unfold g.
-Rewrite AC with r:=(L1 U U) a:=[u:U](Not_b (u U u)).
-Trivial.
-Exists ([x:(pow U)]x) ([x:(pow U)]x); Trivial.
-Qed.
-
-
-Theorem classical_proof_irrelevence : T==F.
-Proof.
-Generalize not_has_fixpoint.
-Unfold Not_b.
-Apply AC_IF.
-Intros is_true is_false.
-Elim is_true; Elim is_false; Trivial.
-
-Intros not_true is_true.
-Elim not_true; Trivial.
-Qed.
-
-End Berardis_paradox.
diff --git a/theories7/Logic/ChoiceFacts.v b/theories7/Logic/ChoiceFacts.v
deleted file mode 100644
index 5b7e002a..00000000
--- a/theories7/Logic/ChoiceFacts.v
+++ /dev/null
@@ -1,134 +0,0 @@
-(************************************************************************)
-(*  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: ChoiceFacts.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(* We show that the functional formulation of the axiom of Choice
-   (usual formulation in type theory) is equivalent to its relational
-   formulation (only formulation of set theory) + the axiom of
-   (parametric) definite description (aka axiom of unique choice) *)
-
-(* This shows that the axiom of choice can be assumed (under its
-   relational formulation) without known inconsistency with classical logic,
-   though definite description conflicts with classical logic *)
-
-Definition RelationalChoice :=
- (A:Type;B:Type;R: A->B->Prop) 
-  ((x:A)(EX y:B|(R x y)))
-   -> (EXT R':A->B->Prop | 
-         ((x:A)(EX y:B|(R x y)/\(R' x y)/\ ((y':B) (R' x y') -> y=y')))).
-
-Definition FunctionalChoice :=
- (A:Type;B:Type;R: A->B->Prop)
-  ((x:A)(EX y:B|(R x y))) -> (EX f:A->B | (x:A)(R x (f x))).
-
-Definition ParamDefiniteDescription :=
- (A:Type;B:Type;R: A->B->Prop)
-  ((x:A)(EX y:B|(R x y)/\ ((y':B)(R x y') -> y=y')))
-   -> (EX f:A->B | (x:A)(R x (f x))).
-
-Lemma description_rel_choice_imp_funct_choice : 
-  ParamDefiniteDescription->RelationalChoice->FunctionalChoice.
-Intros Descr RelCh.
-Red; Intros A B R H.
-NewDestruct (RelCh A B R H) as [R' H0].
-NewDestruct (Descr A B R') as [f H1].
-Intro x.
-Elim (H0 x); Intros y [H2 [H3 H4]]; Exists y; Split; [Exact H3 | Exact H4].
-Exists f; Intro x.
-Elim (H0 x); Intros y [H2 [H3 H4]].
-Rewrite <- (H4 (f x) (H1 x)).
-Exact H2.
-Qed.
-
-Lemma funct_choice_imp_rel_choice : 
-  FunctionalChoice->RelationalChoice.
-Intros FunCh.
-Red; Intros A B R H.
-NewDestruct (FunCh A B R H) as [f H0].
-Exists [x,y]y=(f x).
-Intro x; Exists (f x);
-Split; [Apply H0| Split;[Reflexivity| Intros y H1; Symmetry; Exact H1]].
-Qed.
-
-Lemma funct_choice_imp_description : 
-  FunctionalChoice->ParamDefiniteDescription.
-Intros FunCh.
-Red; Intros A B R H.
-NewDestruct (FunCh A B R) as [f H0].
-(* 1 *)
-Intro x.
-Elim (H x); Intros y [H0 H1].
-Exists y; Exact H0.
-(* 2 *)
-Exists f; Exact H0.
-Qed.
-
-Theorem FunChoice_Equiv_RelChoice_and_ParamDefinDescr :
-  FunctionalChoice <-> RelationalChoice /\ ParamDefiniteDescription.
-Split.
-Intro H; Split; [
-  Exact (funct_choice_imp_rel_choice H)
- | Exact (funct_choice_imp_description H)].
-Intros [H H0]; Exact (description_rel_choice_imp_funct_choice H0 H).
-Qed.
-
-(* We show that the guarded relational formulation of the axiom of Choice
-   comes from the non guarded formulation in presence either of the
-   independance of premises or proof-irrelevance *)
-
-Definition GuardedRelationalChoice :=
- (A:Type;B:Type;P:A->Prop;R: A->B->Prop) 
-  ((x:A)(P x)->(EX y:B|(R x y)))
-   -> (EXT R':A->B->Prop | 
-        ((x:A)(P x)->(EX y:B|(R x y)/\(R' x y)/\ ((y':B) (R' x y') -> y=y')))).
-
-Definition ProofIrrelevance := (A:Prop)(a1,a2:A) a1==a2.
-
-Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice : 
-  RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice.
-Proof.
-Intros rel_choice proof_irrel.
-Red; Intros A B P R H.
-NewDestruct (rel_choice ? ? [x:(sigT ? P);y:B](R (projT1 ? ? x) y)) as [R' H0].
-Intros [x HPx].
-NewDestruct (H x HPx) as [y HRxy].
-Exists y; Exact HRxy.
-Pose R'':=[x:A;y:B](EXT H:(P x) | (R' (existT ? P x H) y)).
-Exists R''; Intros x HPx.
-NewDestruct (H0 (existT ? P x HPx)) as [y [HRxy [HR'xy Huniq]]].
-Exists y. Split.
-  Exact HRxy.
-  Split.
-    Red; Exists HPx; Exact HR'xy.
-    Intros y' HR''xy'.
-      Apply Huniq.
-      Unfold R'' in HR''xy'.
-      NewDestruct HR''xy' as [H'Px HR'xy'].
-      Rewrite proof_irrel with a1:=HPx a2:=H'Px.
-      Exact HR'xy'.
-Qed.
-
-Definition IndependenceOfPremises :=
- (A:Type)(P:A->Prop)(Q:Prop)(Q->(EXT x|(P x)))->(EXT x|Q->(P x)).
-
-Lemma rel_choice_indep_of_premises_imp_guarded_rel_choice :
-  RelationalChoice -> IndependenceOfPremises -> GuardedRelationalChoice.
-Proof.
-Intros RelCh IndPrem.
-Red; Intros A B P R H.
-NewDestruct (RelCh A B [x,y](P x)->(R x y)) as [R' H0].
-  Intro x. Apply IndPrem.
-    Apply H.
-  Exists R'.
-  Intros x HPx.
-    NewDestruct (H0 x) as [y [H1 H2]].
-    Exists y. Split. 
-      Apply (H1 HPx).
-      Exact H2.
-Qed.
diff --git a/theories7/Logic/ClassicalChoice.v b/theories7/Logic/ClassicalChoice.v
deleted file mode 100644
index 5419e958..00000000
--- a/theories7/Logic/ClassicalChoice.v
+++ /dev/null
@@ -1,31 +0,0 @@
-(************************************************************************)
-(*  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: ClassicalChoice.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** This file provides classical logic and functional choice *)
-
-(** This file extends ClassicalDescription.v with the axiom of choice.
-    As ClassicalDescription.v, it implies the double-negation of
-    excluded-middle in Set and implies a strongly classical
-    world. Especially it conflicts with impredicativity of Set, knowing
-    that true<>false in Set.
-*)
-
-Require Export ClassicalDescription.
-Require Export RelationalChoice.
-Require ChoiceFacts.
-
-Theorem choice : 
- (A:Type;B:Type;R: A->B->Prop)
-  ((x:A)(EX y:B|(R x y))) -> (EX f:A->B | (x:A)(R x (f x))).
-Proof.
-Apply description_rel_choice_imp_funct_choice.
-Exact description.
-Exact relational_choice.
-Qed.
diff --git a/theories7/Logic/ClassicalDescription.v b/theories7/Logic/ClassicalDescription.v
deleted file mode 100644
index 85700c22..00000000
--- a/theories7/Logic/ClassicalDescription.v
+++ /dev/null
@@ -1,76 +0,0 @@
-(************************************************************************)
-(*  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: ClassicalDescription.v,v 1.2.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** This file provides classical logic and definite description *)
-
-(** Classical logic and definite description, as shown in [1],
-    implies the double-negation of excluded-middle in Set, hence it
-    implies a strongly classical world. Especially it conflicts with
-    impredicativity of Set, knowing that true<>false in Set.
-
-    [1] Laurent Chicli, Loïc Pottier, Carlos Simpson, Mathematical
-    Quotients and Quotient Types in Coq, Proceedings of TYPES 2002,
-    Lecture Notes in Computer Science 2646, Springer Verlag.
-*)
-
-Require Export Classical.
-
-Axiom dependent_description :
-  (A:Type;B:A->Type;R: (x:A)(B x)->Prop)
-  ((x:A)(EX y:(B x)|(R x y)/\ ((y':(B x))(R x y') -> y=y')))
-   -> (EX f:(x:A)(B x) | (x:A)(R x (f x))).
-
-(** Principle of definite descriptions (aka axiom of unique choice) *)
-
-Theorem description :
-  (A:Type;B:Type;R: A->B->Prop)
-  ((x:A)(EX y:B|(R x y)/\ ((y':B)(R x y') -> y=y')))
-   -> (EX f:A->B | (x:A)(R x (f x))).
-Proof.
-Intros A B.
-Apply (dependent_description A [_]B).
-Qed.
-
-(** The followig proof comes from [1] *)
-
-Theorem classic_set : (((P:Prop){P}+{~P}) -> False) -> False.
-Proof.
-Intro HnotEM.
-Pose R:=[A,b]A/\true=b \/ ~A/\false=b.
-Assert H:(EX f:Prop->bool|(A:Prop)(R A (f A))).
-Apply description.
-Intro A.
-NewDestruct (classic A) as [Ha|Hnota].
-  Exists true; Split.
-    Left; Split; [Assumption|Reflexivity].
-    Intros y [[_ Hy]|[Hna _]].
-      Assumption.
-      Contradiction.
-  Exists false; Split.
-    Right; Split; [Assumption|Reflexivity].
-    Intros y [[Ha _]|[_ Hy]].
-      Contradiction.
-      Assumption.
-NewDestruct H as [f Hf].
-Apply HnotEM.
-Intro P.
-Assert HfP := (Hf P).
-(* Elimination from Hf to Set is not allowed but from f to Set yes ! *)
-NewDestruct (f P).
-  Left.
-  NewDestruct HfP as [[Ha _]|[_ Hfalse]].
-    Assumption.
-    Discriminate.
-  Right.
-  NewDestruct HfP as [[_ Hfalse]|[Hna _]].
-    Discriminate.
-    Assumption.
-Qed.
- 
diff --git a/theories7/Logic/ClassicalFacts.v b/theories7/Logic/ClassicalFacts.v
deleted file mode 100644
index 1d37652e..00000000
--- a/theories7/Logic/ClassicalFacts.v
+++ /dev/null
@@ -1,214 +0,0 @@
-(************************************************************************)
-(*  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: ClassicalFacts.v,v 1.2.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** Some facts and definitions about classical logic *)
-
-(** [prop_degeneracy] (also referred as propositional completeness) *)
-(*  asserts (up to consistency) that there are only two distinct formulas *)
-Definition prop_degeneracy := (A:Prop) A==True \/ A==False.
-
-(** [prop_extensionality] asserts equivalent formulas are equal *)
-Definition prop_extensionality := (A,B:Prop) (A<->B) -> A==B.
-
-(** [excluded_middle] asserts we can reason by case on the truth *)
-(*  or falsity of any formula *)
-Definition excluded_middle := (A:Prop) A \/ ~A.
-
-(** [proof_irrelevance] asserts equality of all proofs of a given formula *)
-Definition proof_irrelevance := (A:Prop)(a1,a2:A) a1==a2.
-
-(** We show [prop_degeneracy <-> (prop_extensionality /\ excluded_middle)] *)
-
-Lemma prop_degen_ext : prop_degeneracy -> prop_extensionality.
-Proof.
-Intros H A B (Hab,Hba).
-NewDestruct (H A); NewDestruct (H B).
-  Rewrite H1; Exact H0.
-  Absurd B.
-    Rewrite H1; Exact [H]H.
-    Apply Hab; Rewrite H0; Exact I.
-  Absurd A.
-    Rewrite H0; Exact [H]H.
-    Apply Hba; Rewrite H1; Exact I.
-  Rewrite H1; Exact H0.
-Qed.
-
-Lemma prop_degen_em : prop_degeneracy -> excluded_middle.
-Proof.
-Intros H A.
-NewDestruct (H A).
-  Left; Rewrite H0; Exact I.
-  Right; Rewrite H0; Exact [x]x.
-Qed.
-
-Lemma prop_ext_em_degen :
-   prop_extensionality -> excluded_middle -> prop_degeneracy.
-Proof.
-Intros Ext EM A.
-NewDestruct (EM A).
-  Left; Apply (Ext A True); Split; [Exact [_]I | Exact [_]H].
-  Right; Apply (Ext A False); Split; [Exact H | Apply False_ind].
-Qed.
-
-(** We successively show that:
-
-   [prop_extensionality]
-     implies equality of [A] and [A->A] for inhabited [A], which 
-     implies the existence of a (trivial) retract from [A->A] to [A]
-        (just take the identity), which
-     implies the existence of a fixpoint operator in [A]
-        (e.g. take the Y combinator of lambda-calculus)
-*)
-
-Definition inhabited [A:Prop] := A.
-
-Lemma prop_ext_A_eq_A_imp_A :
-  prop_extensionality->(A:Prop)(inhabited A)->(A->A)==A.
-Proof.
-Intros Ext A a.
-Apply (Ext A->A A); Split; [ Exact [_]a | Exact [_;_]a ].
-Qed.
-
-Record retract [A,B:Prop] : Prop := {
-  f1: A->B;
-  f2: B->A;
-  f1_o_f2: (x:B)(f1 (f2 x))==x
-}.
-
-Lemma prop_ext_retract_A_A_imp_A :
-  prop_extensionality->(A:Prop)(inhabited A)->(retract A A->A).
-Proof.
-Intros Ext A a.
-Rewrite -> (prop_ext_A_eq_A_imp_A Ext A a).
-Exists [x:A]x [x:A]x.
-Reflexivity.
-Qed.
-
-Record has_fixpoint [A:Prop] : Prop := {
-  F : (A->A)->A;
-  fix : (f:A->A)(F f)==(f (F f))
-}.
-
-Lemma ext_prop_fixpoint :
-  prop_extensionality->(A:Prop)(inhabited A)->(has_fixpoint A).
-Proof.
-Intros Ext A a.
-Case (prop_ext_retract_A_A_imp_A Ext A a); Intros g1 g2 g1_o_g2.
-Exists [f]([x:A](f (g1 x x)) (g2 [x](f (g1 x x)))).
-Intro f.
-Pattern 1 (g1 (g2 [x:A](f (g1 x x)))).
-Rewrite (g1_o_g2 [x:A](f (g1 x x))).
-Reflexivity.
-Qed.
-
-(** Assume we have booleans with the property that there is at most 2
-    booleans (which is equivalent to dependent case analysis). Consider
-    the fixpoint of the negation function: it is either true or false by
-    dependent case analysis, but also the opposite by fixpoint. Hence
-    proof-irrelevance.
-
-    We then map bool proof-irrelevance to all propositions.
-*)
-
-Section Proof_irrelevance_gen.
-
-Variable bool : Prop.
-Variable true : bool.
-Variable false : bool.
-Hypothesis bool_elim : (C:Prop)C->C->bool->C.
-Hypothesis bool_elim_redl : (C:Prop)(c1,c2:C)c1==(bool_elim C c1 c2 true).
-Hypothesis bool_elim_redr : (C:Prop)(c1,c2:C)c2==(bool_elim C c1 c2 false).
-Local bool_dep_induction := (P:bool->Prop)(P true)->(P false)->(b:bool)(P b).
-
-Lemma aux : prop_extensionality -> bool_dep_induction -> true==false.
-Proof.
-Intros Ext Ind.
-Case (ext_prop_fixpoint Ext bool true); Intros G Gfix.
-Pose neg := [b:bool](bool_elim bool false true b).
-Generalize (refl_eqT ? (G neg)).
-Pattern 1 (G neg).
-Apply Ind with b:=(G neg); Intro Heq.
-Rewrite (bool_elim_redl bool false true).
-Change true==(neg true); Rewrite -> Heq; Apply Gfix.
-Rewrite (bool_elim_redr bool false true).
-Change (neg false)==false; Rewrite -> Heq; Symmetry; Apply Gfix.
-Qed.
-
-Lemma ext_prop_dep_proof_irrel_gen :
-  prop_extensionality -> bool_dep_induction -> proof_irrelevance.
-Proof.
-Intros Ext Ind A a1 a2.
-Pose f := [b:bool](bool_elim A a1 a2 b).
-Rewrite (bool_elim_redl A a1 a2).
-Change (f true)==a2.
-Rewrite (bool_elim_redr A a1 a2).
-Change (f true)==(f false).
-Rewrite (aux Ext Ind).
-Reflexivity.
-Qed.
-
-End Proof_irrelevance_gen.
-
-(** In the pure Calculus of Constructions, we can define the boolean
-    proposition bool = (C:Prop)C->C->C but we cannot prove that it has at
-    most 2 elements.
-*)
-
-Section Proof_irrelevance_CC.
-
-Definition BoolP  := (C:Prop)C->C->C.
-Definition TrueP  := [C][c1,c2]c1 : BoolP.
-Definition FalseP := [C][c1,c2]c2 : BoolP.
-Definition BoolP_elim := [C][c1,c2][b:BoolP](b C c1 c2).
-Definition BoolP_elim_redl : (C:Prop)(c1,c2:C)c1==(BoolP_elim C c1 c2 TrueP)
-  := [C;c1,c2](refl_eqT C c1).
-Definition BoolP_elim_redr : (C:Prop)(c1,c2:C)c2==(BoolP_elim C c1 c2 FalseP)
-  := [C;c1,c2](refl_eqT C c2).
-
-Definition BoolP_dep_induction := 
- (P:BoolP->Prop)(P TrueP)->(P FalseP)->(b:BoolP)(P b).
-
-Lemma ext_prop_dep_proof_irrel_cc :
-  prop_extensionality -> BoolP_dep_induction -> proof_irrelevance.
-Proof (ext_prop_dep_proof_irrel_gen BoolP TrueP FalseP BoolP_elim
-         BoolP_elim_redl BoolP_elim_redr).
-
-End Proof_irrelevance_CC.
-
-(** In the Calculus of Inductive Constructions, inductively defined booleans
-    enjoy dependent case analysis, hence directly proof-irrelevance from
-    propositional extensionality.
-*)
-
-Section Proof_irrelevance_CIC.
-
-Inductive boolP : Prop := trueP : boolP | falseP : boolP.
-Definition boolP_elim_redl : (C:Prop)(c1,c2:C)c1==(boolP_ind C c1 c2 trueP)
-  := [C;c1,c2](refl_eqT C c1).
-Definition boolP_elim_redr : (C:Prop)(c1,c2:C)c2==(boolP_ind C c1 c2 falseP)
-  := [C;c1,c2](refl_eqT C c2).
-Scheme boolP_indd := Induction for boolP Sort Prop.
-
-Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance.
-Proof [pe](ext_prop_dep_proof_irrel_gen boolP trueP falseP boolP_ind
-         boolP_elim_redl boolP_elim_redr pe boolP_indd).
-
-End Proof_irrelevance_CIC.
-
-(** Can we state proof irrelevance from propositional degeneracy
-  (i.e. propositional extensionality + excluded middle) without
-  dependent case analysis ?
-
-  Conjecture: it seems possible to build a model of CC interpreting
-  all non-empty types by the set of all lambda-terms. Such a model would
-  satisfy propositional degeneracy without satisfying proof-irrelevance
-  (nor dependent case analysis). This would imply that the previous
-  results cannot be refined.
-*)
diff --git a/theories7/Logic/Classical_Pred_Set.v b/theories7/Logic/Classical_Pred_Set.v
deleted file mode 100755
index b1c26e6d..00000000
--- a/theories7/Logic/Classical_Pred_Set.v
+++ /dev/null
@@ -1,64 +0,0 @@
-(************************************************************************)
-(*  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: Classical_Pred_Set.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** Classical Predicate Logic on Set*)
-
-Require Classical_Prop.
-
-Section Generic.
-Variable U: Set.
-
-(** de Morgan laws for quantifiers *)
-
-Lemma not_all_ex_not : (P:U->Prop)(~(n:U)(P n)) -> (EX n:U | ~(P n)).
-Proof.
-Unfold not; Intros P notall.
-Apply NNPP; Unfold not.
-Intro abs.
-Cut ((n:U)(P n)); Auto.
-Intro n; Apply NNPP.
-Unfold not; Intros.
-Apply abs; Exists n; Trivial.
-Qed.
-
-Lemma not_all_not_ex : (P:U->Prop)(~(n:U)~(P n)) -> (EX n:U |(P n)).
-Proof.
-Intros P H.
-Elim (not_all_ex_not [n:U]~(P n) H); Intros n Pn; Exists n.
-Apply NNPP; Trivial.
-Qed.
-
-Lemma not_ex_all_not : (P:U->Prop) (~(EX n:U |(P n))) -> (n:U)~(P n).
-Proof.
-Unfold not; Intros P notex n abs.
-Apply notex.
-Exists n; Trivial.
-Qed. 
-
-Lemma not_ex_not_all : (P:U->Prop)(~(EX n:U | ~(P n))) -> (n:U)(P n).
-Proof.
-Intros P H n.
-Apply NNPP.
-Red; Intro K; Apply H; Exists n; Trivial.
-Qed.
-
-Lemma ex_not_not_all : (P:U->Prop) (EX n:U | ~(P n)) -> ~(n:U)(P n).
-Proof.
-Unfold not; Intros P exnot allP.
-Elim exnot; Auto.
-Qed.
-
-Lemma all_not_not_ex : (P:U->Prop) ((n:U)~(P n)) -> ~(EX n:U |(P n)).
-Proof.
-Unfold not; Intros P allnot exP; Elim exP; Intros n p.
-Apply allnot with n; Auto.
-Qed.
-
-End Generic.
diff --git a/theories7/Logic/Classical_Pred_Type.v b/theories7/Logic/Classical_Pred_Type.v
deleted file mode 100755
index 69175ec7..00000000
--- a/theories7/Logic/Classical_Pred_Type.v
+++ /dev/null
@@ -1,64 +0,0 @@
-(************************************************************************)
-(*  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: Classical_Pred_Type.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** Classical Predicate Logic on Type *)
-
-Require Classical_Prop.
-
-Section Generic.
-Variable U: Type.
-
-(** de Morgan laws for quantifiers *)
-
-Lemma not_all_ex_not : (P:U->Prop)(~(n:U)(P n)) -> (EXT n:U | ~(P n)).
-Proof.
-Unfold not; Intros P notall.
-Apply NNPP; Unfold not.
-Intro abs.
-Cut ((n:U)(P n)); Auto.
-Intro n; Apply NNPP.
-Unfold not; Intros.
-Apply abs; Exists n; Trivial.
-Qed.
-
-Lemma not_all_not_ex : (P:U->Prop)(~(n:U)~(P n)) -> (EXT n:U | (P n)).
-Proof.
-Intros P H.
-Elim (not_all_ex_not [n:U]~(P n) H); Intros n Pn; Exists n.
-Apply NNPP; Trivial.
-Qed.
-
-Lemma not_ex_all_not : (P:U->Prop)(~(EXT n:U | (P n))) -> (n:U)~(P n).
-Proof.
-Unfold not; Intros P notex n abs.
-Apply notex.
-Exists n; Trivial.
-Qed. 
-
-Lemma not_ex_not_all : (P:U->Prop)(~(EXT n:U | ~(P n))) -> (n:U)(P n).
-Proof.
-Intros P H n.
-Apply NNPP.
-Red; Intro K; Apply H; Exists n; Trivial.
-Qed.
-
-Lemma ex_not_not_all : (P:U->Prop) (EXT n:U | ~(P n)) -> ~(n:U)(P n).
-Proof.
-Unfold not; Intros P exnot allP.
-Elim exnot; Auto.
-Qed.
-
-Lemma all_not_not_ex : (P:U->Prop) ((n:U)~(P n)) -> ~(EXT n:U | (P n)).
-Proof.
-Unfold not; Intros P allnot exP; Elim exP; Intros n p.
-Apply allnot with n; Auto.
-Qed.
-
-End Generic.
diff --git a/theories7/Logic/Classical_Prop.v b/theories7/Logic/Classical_Prop.v
deleted file mode 100755
index 1dc7ec57..00000000
--- a/theories7/Logic/Classical_Prop.v
+++ /dev/null
@@ -1,85 +0,0 @@
-(************************************************************************)
-(*  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: Classical_Prop.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** Classical Propositional Logic *)
-
-Require ProofIrrelevance.
-
-Hints Unfold not : core.
-
-Axiom classic: (P:Prop)(P \/ ~(P)).
-
-Lemma NNPP : (p:Prop)~(~(p))->p.
-Proof.
-Unfold not; Intros; Elim (classic p); Auto.
-Intro NP; Elim (H NP).
-Qed.
-
-Lemma not_imply_elim : (P,Q:Prop)~(P->Q)->P.
-Proof.
-Intros; Apply NNPP; Red.
-Intro; Apply H; Intro; Absurd P; Trivial.
-Qed.
-
-Lemma not_imply_elim2 : (P,Q:Prop)~(P->Q) -> ~Q.
-Proof.
-Intros; Elim (classic Q); Auto.
-Qed.
-
-Lemma imply_to_or : (P,Q:Prop)(P->Q) -> ~P \/ Q.
-Proof.
-Intros; Elim (classic P); Auto.
-Qed.
-
-Lemma imply_to_and : (P,Q:Prop)~(P->Q) -> P /\ ~Q.
-Proof.
-Intros; Split.
-Apply not_imply_elim with Q;  Trivial.
-Apply not_imply_elim2 with P; Trivial.
-Qed.
-
-Lemma or_to_imply : (P,Q:Prop)(~P \/ Q) -> P->Q.
-Proof.
-Induction 1; Auto.
-Intros H1 H2; Elim (H1 H2).
-Qed.
-
-Lemma not_and_or : (P,Q:Prop)~(P/\Q)-> ~P \/ ~Q.
-Proof.
-Intros; Elim (classic P); Auto.
-Qed.
-
-Lemma or_not_and : (P,Q:Prop)(~P \/ ~Q) -> ~(P/\Q).
-Proof.
-Induction 1; Red; Induction 2; Auto.
-Qed.
-
-Lemma not_or_and : (P,Q:Prop)~(P\/Q)-> ~P /\ ~Q.
-Proof.
-Intros; Elim (classic P); Auto.
-Qed.
-
-Lemma and_not_or : (P,Q:Prop)(~P /\ ~Q) -> ~(P\/Q).
-Proof.
-Induction 1; Red; Induction 3; Trivial.
-Qed.
-
-Lemma imply_and_or: (P,Q:Prop)(P->Q) -> P \/ Q -> Q.
-Proof.
-Induction 2; Trivial.
-Qed.
-
-Lemma imply_and_or2: (P,Q,R:Prop)(P->Q) -> P \/ R -> Q \/ R.
-Proof.
-Induction 2; Auto.
-Qed.
-
-Lemma proof_irrelevance: (P:Prop)(p1,p2:P)p1==p2.
-Proof (proof_irrelevance_cci classic).
diff --git a/theories7/Logic/Classical_Type.v b/theories7/Logic/Classical_Type.v
deleted file mode 100755
index e34170cd..00000000
--- a/theories7/Logic/Classical_Type.v
+++ /dev/null
@@ -1,14 +0,0 @@
-(************************************************************************)
-(*  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: Classical_Type.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** Classical Logic for Type *)
-
-Require Export Classical_Prop.
-Require Export Classical_Pred_Type.
diff --git a/theories7/Logic/Decidable.v b/theories7/Logic/Decidable.v
deleted file mode 100644
index 537b5e88..00000000
--- a/theories7/Logic/Decidable.v
+++ /dev/null
@@ -1,58 +0,0 @@
-(************************************************************************)
-(*  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: Decidable.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $	 i*)
-
-(** Properties of decidable propositions *)
-
-Definition decidable := [P:Prop] P \/ ~P.
-
-Theorem dec_not_not : (P:Prop)(decidable P) -> (~P -> False) -> P.
-Unfold decidable; Tauto. 
-Qed.
-
-Theorem dec_True: (decidable True).
-Unfold decidable; Auto.
-Qed.
-
-Theorem dec_False: (decidable False).
-Unfold decidable not; Auto.
-Qed.
-
-Theorem dec_or: (A,B:Prop)(decidable A) -> (decidable B) -> (decidable (A\/B)).
-Unfold decidable; Tauto. 
-Qed.
-
-Theorem dec_and: (A,B:Prop)(decidable A) -> (decidable B) ->(decidable (A/\B)).
-Unfold decidable; Tauto. 
-Qed.
-
-Theorem dec_not: (A:Prop)(decidable A) -> (decidable ~A).
-Unfold decidable; Tauto. 
-Qed.
-
-Theorem dec_imp: (A,B:Prop)(decidable A) -> (decidable B) ->(decidable (A->B)).
-Unfold decidable; Tauto. 
-Qed.
-
-Theorem not_not : (P:Prop)(decidable P) -> (~(~P)) -> P.
-Unfold decidable; Tauto. Qed.
-
-Theorem not_or : (A,B:Prop) ~(A\/B) -> ~A /\ ~B.
-Tauto. Qed.
-
-Theorem not_and : (A,B:Prop) (decidable A) -> ~(A/\B) -> ~A \/ ~B.
-Unfold decidable; Tauto. Qed.
-
-Theorem not_imp : (A,B:Prop) (decidable A) -> ~(A -> B) -> A /\ ~B.
-Unfold decidable;Tauto.
-Qed.
-
-Theorem imp_simp : (A,B:Prop) (decidable A) -> (A -> B) -> ~A \/ B.
-Unfold decidable; Tauto.
-Qed.
-
diff --git a/theories7/Logic/Diaconescu.v b/theories7/Logic/Diaconescu.v
deleted file mode 100644
index 9f5f91a0..00000000
--- a/theories7/Logic/Diaconescu.v
+++ /dev/null
@@ -1,133 +0,0 @@
-(************************************************************************)
-(*  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: Diaconescu.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(* R. Diaconescu [Diaconescu] showed that the Axiom of Choice in Set Theory
-   entails Excluded-Middle; S. Lacas and B. Werner [LacasWerner]
-   adapted the proof to show that the axiom of choice in equivalence
-   classes entails Excluded-Middle in Type Theory.
-
-   This is an adaptatation of the proof by Hugo Herbelin to show that
-   the relational form of the Axiom of Choice + Extensionality for
-   predicates entails Excluded-Middle
-
-   [Diaconescu] R. Diaconescu, Axiom of Choice and Complementation, in
-   Proceedings of AMS, vol 51, pp 176-178, 1975.
-
-   [LacasWerner] S. Lacas, B Werner, Which Choices imply the excluded middle?,
-   preprint, 1999.
-
-*)
-
-Section PredExt_GuardRelChoice_imp_EM.
-
-(* The axiom of extensionality for predicates *)
-
-Definition PredicateExtensionality :=
-   (P,Q:bool->Prop)((b:bool)(P b)<->(Q b))->P==Q.
-
-(* From predicate extensionality we get propositional extensionality
-   hence proof-irrelevance *)
-
-Require ClassicalFacts.
-
-Variable pred_extensionality : PredicateExtensionality.
-  
-Lemma prop_ext : (A,B:Prop) (A<->B) -> A==B.
-Proof.
-  Intros A B H.
-  Change ([_]A true)==([_]B true).
-  Rewrite pred_extensionality with P:=[_:bool]A Q:=[_:bool]B.
-    Reflexivity.
-    Intros _; Exact H.
-Qed.
-
-Lemma proof_irrel : (A:Prop)(a1,a2:A) a1==a2.
-Proof.
-  Apply (ext_prop_dep_proof_irrel_cic prop_ext).
-Qed.
-
-(* From proof-irrelevance and relational choice, we get guarded
-   relational choice *)
-
-Require ChoiceFacts.
-
-Variable rel_choice : RelationalChoice.
-
-Lemma guarded_rel_choice :
-  (A:Type)(B:Type)(P:A->Prop)(R:A->B->Prop)
-  ((x:A)(P x)->(EX y:B|(R x y)))->
-    (EXT R':A->B->Prop | 
-      ((x:A)(P x)->(EX y:B|(R x y)/\(R' x y)/\ ((y':B)(R' x y') -> y=y')))).
-Proof.
-  Exact
-    (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
-Qed.
-
-(* The form of choice we need: there is a functional relation which chooses
-   an element in any non empty subset of bool *)
-
-Require Bool.
-
-Lemma AC :
-  (EXT R:(bool->Prop)->bool->Prop |
-     (P:bool->Prop)(EX b : bool | (P b))->
-        (EX b : bool | (P b) /\ (R P b) /\ ((b':bool)(R P b')->b=b'))).
-Proof.
-  Apply guarded_rel_choice with
-    P:= [Q:bool->Prop](EX y | (Q y)) R:=[Q:bool->Prop;y:bool](Q y).
-  Exact [_;H]H.
-Qed.
-
-(* The proof of the excluded middle *)
-(* Remark: P could have been in Set or Type *)
-
-Theorem pred_ext_and_rel_choice_imp_EM : (P:Prop)P\/~P.
-Proof.
-Intro P.
-
-(* first we exhibit the choice functional relation R *)
-NewDestruct AC as [R H].
-
-Pose class_of_true := [b]b=true\/P.
-Pose class_of_false := [b]b=false\/P.
-
-(* the actual "decision": is (R class_of_true) = true or false? *)
-NewDestruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
-Exists true; Left; Reflexivity.
-NewDestruct H0.
-
-(* the actual "decision": is (R class_of_false) = true or false? *)
-NewDestruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
-Exists false; Left; Reflexivity.
-NewDestruct H1.
-
-(* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
-Right.
-Intro HP.
-Assert Hequiv:(b:bool)(class_of_true b)<->(class_of_false b).
-Intro b; Split.
-Unfold class_of_false; Right; Assumption.
-Unfold class_of_true; Right; Assumption.
-Assert Heq:class_of_true==class_of_false.
-Apply pred_extensionality with 1:=Hequiv.
-Apply diff_true_false.
-Rewrite <- H0.
-Rewrite <- H1.
-Rewrite <- H0''. Reflexivity.
-Rewrite Heq.
-Assumption.
-
-(* cases where P is true *)
-Left; Assumption.
-Left; Assumption.
-
-Qed.
-
-End PredExt_GuardRelChoice_imp_EM.
diff --git a/theories7/Logic/Eqdep.v b/theories7/Logic/Eqdep.v
deleted file mode 100755
index fc2dfe52..00000000
--- a/theories7/Logic/Eqdep.v
+++ /dev/null
@@ -1,183 +0,0 @@
-(************************************************************************)
-(*  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: Eqdep.v,v 1.2.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** This file defines dependent equality and shows its equivalence with
-    equality on dependent pairs (inhabiting sigma-types). It axiomatizes
-    the invariance by substitution of reflexive equality proofs and 
-    shows the equivalence between the 4 following statements
-
-    - Invariance by Substitution of Reflexive Equality Proofs.
-    - Injectivity of Dependent Equality
-    - Uniqueness of Identity Proofs
-    - Uniqueness of Reflexive Identity Proofs
-    - Streicher's Axiom K
-
-  These statements are independent of the calculus of constructions [2].
-
-  References:
-
-  [1] T. Streicher, Semantical Investigations into Intensional Type Theory,
-      Habilitationsschrift, LMU München, 1993.
-  [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory,
-      Proceedings of the meeting Twenty-five years of constructive
-      type theory, Venice, Oxford University Press, 1998
-*)
-
-Section Dependent_Equality.
-
-Variable U : Type.
-Variable P : U->Type.
-
-(** Dependent equality *)
-
-Inductive eq_dep [p:U;x:(P p)] : (q:U)(P q)->Prop :=
-   eq_dep_intro : (eq_dep p x p x).
-Hint constr_eq_dep : core v62 := Constructors eq_dep.
-
-Lemma eq_dep_sym : (p,q:U)(x:(P p))(y:(P q))(eq_dep p x q y)->(eq_dep q y p x).
-Proof.
-NewDestruct 1; Auto.
-Qed.
-Hints Immediate eq_dep_sym : core v62.
-
-Lemma eq_dep_trans : (p,q,r:U)(x:(P p))(y:(P q))(z:(P r))
-     (eq_dep p x q y)->(eq_dep q y r z)->(eq_dep p x r z).
-Proof.
-NewDestruct 1; Auto.
-Qed.
-
-Inductive eq_dep1 [p:U;x:(P p);q:U;y:(P q)] : Prop :=
-   eq_dep1_intro : (h:q=p)
-                  (x=(eq_rect U q P y p h))->(eq_dep1 p x q y).
-
-Scheme eq_indd := Induction for eq Sort Prop.
-
-Lemma eq_dep1_dep :
-      (p:U)(x:(P p))(q:U)(y:(P q))(eq_dep1 p x q y)->(eq_dep p x q y).
-Proof.
-NewDestruct 1 as [eq_qp H].
-NewDestruct eq_qp using eq_indd.
-Rewrite H.
-Apply eq_dep_intro.
-Qed.
-
-Lemma eq_dep_dep1 : 
-  (p,q:U)(x:(P p))(y:(P q))(eq_dep p x q y)->(eq_dep1 p x q y).
-Proof.
-NewDestruct 1.
-Apply eq_dep1_intro with (refl_equal U p).
-Simpl; Trivial.
-Qed.
-
-(** Invariance by Substitution of Reflexive Equality Proofs *)
-
-Axiom eq_rect_eq : (p:U)(Q:U->Type)(x:(Q p))(h:p=p)
-                  x=(eq_rect U p Q x p h).
-
-(** Injectivity of Dependent Equality is a consequence of *)
-(** Invariance by Substitution of Reflexive Equality Proof *)
-
-Lemma eq_dep1_eq : (p:U)(x,y:(P p))(eq_dep1 p x p y)->x=y.
-Proof.
-Destruct 1; Intro.
-Rewrite <- eq_rect_eq; Auto.
-Qed.
-
-Lemma eq_dep_eq : (p:U)(x,y:(P p))(eq_dep p x p y)->x=y.
-Proof.
-Intros; Apply eq_dep1_eq; Apply eq_dep_dep1; Trivial.
-Qed.
-
-End Dependent_Equality.
-
-(** Uniqueness of Identity Proofs (UIP) is a consequence of *)
-(** Injectivity of Dependent Equality *)
-
-Lemma UIP : (U:Type)(x,y:U)(p1,p2:x=y)p1=p2.
-Proof.
-Intros; Apply eq_dep_eq with P:=[y]x=y.
-Elim p2 using eq_indd.
-Elim p1 using eq_indd.
-Apply eq_dep_intro.
-Qed.
-
-(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)
-
-Lemma UIP_refl : (U:Type)(x:U)(p:x=x)p=(refl_equal U x).
-Proof.
-Intros; Apply UIP.
-Qed.
-
-(** Streicher axiom K is a direct consequence of Uniqueness of
-    Reflexive Identity Proofs *)
-
-Lemma Streicher_K : (U:Type)(x:U)(P:x=x->Prop)
-  (P (refl_equal ? x))->(p:x=x)(P p).
-Proof.
-Intros; Rewrite UIP_refl; Assumption.
-Qed.
-
-(** We finally recover eq_rec_eq (alternatively eq_rect_eq) from K *)
-
-Lemma eq_rec_eq : (U:Type)(P:U->Set)(p:U)(x:(P p))(h:p=p)
-  x=(eq_rec U p P x p h).
-Proof.
-Intros.
-Apply Streicher_K with p:=h.
-Reflexivity.
-Qed.
-
-(** Dependent equality is equivalent to equality on dependent pairs *)
-
-Lemma equiv_eqex_eqdep : (U:Set)(P:U->Set)(p,q:U)(x:(P p))(y:(P q)) 
-    (existS U P p x)=(existS U P q y) <-> (eq_dep U P p x q y).
-Proof.
-Split. 
-(* -> *)
-Intro H.
-Change p with   (projS1 U P (existS U P p x)).
-Change 2 x with (projS2 U P (existS U P p x)).
-Rewrite H.
-Apply eq_dep_intro.
-(* <- *)
-NewDestruct 1; Reflexivity.
-Qed.
-
-(** UIP implies the injectivity of equality on dependent pairs *)
-
-Lemma inj_pair2: (U:Set)(P:U->Set)(p:U)(x,y:(P p))
-    (existS U P p x)=(existS U P p y)-> x=y.
-Proof.
-Intros.
-Apply (eq_dep_eq U P).
-Generalize (equiv_eqex_eqdep U P p p x y) .
-Induction 1.
-Intros.
-Auto.
-Qed.
-
-(** UIP implies the injectivity of equality on dependent pairs *)
-
-Lemma inj_pairT2: (U:Type)(P:U->Type)(p:U)(x,y:(P p))
-    (existT U P p x)=(existT U P p y)-> x=y.
-Proof.
-Intros.
-Apply (eq_dep_eq U P).
-Change 1 p with (projT1 U P (existT U P p x)).
-Change 2 x with (projT2 U P (existT U P p x)).
-Rewrite H.
-Apply eq_dep_intro.
-Qed.
-
-(** The main results to be exported *)
-
-Hints Resolve eq_dep_intro eq_dep_eq : core v62.
-Hints Immediate eq_dep_sym : core v62.
-Hints Resolve inj_pair2 inj_pairT2 : core.
diff --git a/theories7/Logic/Eqdep_dec.v b/theories7/Logic/Eqdep_dec.v
deleted file mode 100644
index 959395e3..00000000
--- a/theories7/Logic/Eqdep_dec.v
+++ /dev/null
@@ -1,149 +0,0 @@
-(************************************************************************)
-(*  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: Eqdep_dec.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** We prove that there is only one proof of [x=x], i.e [(refl_equal ? x)].
-   This holds if the equality upon the set of [x] is decidable.
-   A corollary of this theorem is the equality of the right projections
-   of two equal dependent pairs.
-
-   Author:   Thomas Kleymann |<tms@dcs.ed.ac.uk>| in Lego
-             adapted to Coq by B. Barras
-
-   Credit:   Proofs up to [K_dec] follows an outline by Michael Hedberg
-*)
-
-
-(** We need some dependent elimination schemes *)
-
-Set Implicit Arguments.
-
-  (** Bijection between [eq] and [eqT] *)
-  Definition eq2eqT: (A:Set)(x,y:A)x=y->x==y :=
-    [A,x,_,eqxy]<[y:A]x==y>Cases eqxy of refl_equal => (refl_eqT ? x) end.
-
-  Definition eqT2eq: (A:Set)(x,y:A)x==y->x=y :=
-    [A,x,_,eqTxy]<[y:A]x=y>Cases eqTxy of refl_eqT => (refl_equal ? x) end.
-
-  Lemma eq_eqT_bij: (A:Set)(x,y:A)(p:x=y)p==(eqT2eq (eq2eqT p)).
-Intros.
-Case p; Reflexivity.
-Qed.
-
-  Lemma eqT_eq_bij: (A:Set)(x,y:A)(p:x==y)p==(eq2eqT (eqT2eq p)).
-Intros.
-Case p; Reflexivity.
-Qed.
-
-
-Section DecidableEqDep.
-
-  Variable A: Type.
-
-  Local comp [x,y,y':A]: x==y->x==y'->y==y' :=
-    [eq1,eq2](eqT_ind ? ? [a]a==y' eq2 ? eq1).
-
-  Remark trans_sym_eqT: (x,y:A)(u:x==y)(comp u u)==(refl_eqT ? y).
-Intros.
-Case u; Trivial.
-Qed.
-
-
-
-  Variable eq_dec: (x,y:A) x==y \/ ~x==y.
-
-  Variable x: A.
-
-
-  Local nu [y:A]: x==y->x==y :=
-    [u]Cases (eq_dec x y) of
-       (or_introl eqxy)  => eqxy
-     | (or_intror neqxy) => (False_ind ? (neqxy u))
-     end.
-
-  Local nu_constant : (y:A)(u,v:x==y) (nu u)==(nu v).
-Intros.
-Unfold nu.
-Case (eq_dec x y); Intros.
-Reflexivity.
-
-Case n; Trivial.
-Qed.
-
-
-  Local nu_inv [y:A]: x==y->x==y := [v](comp (nu (refl_eqT ? x)) v).
-
-
-  Remark nu_left_inv : (y:A)(u:x==y) (nu_inv (nu u))==u.
-Intros.
-Case u; Unfold nu_inv.
-Apply trans_sym_eqT.
-Qed.
-
-
-  Theorem eq_proofs_unicity: (y:A)(p1,p2:x==y) p1==p2.
-Intros.
-Elim nu_left_inv with u:=p1.
-Elim nu_left_inv with u:=p2.
-Elim nu_constant with y p1 p2.
-Reflexivity.
-Qed.
-
-  Theorem K_dec: (P:x==x->Prop)(P (refl_eqT ? x)) -> (p:x==x)(P p).
-Intros.
-Elim eq_proofs_unicity with x (refl_eqT ? x) p.
-Trivial.
-Qed.
-
-
-  (** The corollary *)
-
-  Local proj: (P:A->Prop)(ExT P)->(P x)->(P x) :=
-    [P,exP,def]Cases exP of
-      (exT_intro x' prf) =>
-        Cases (eq_dec x' x) of
-          (or_introl eqprf) => (eqT_ind ? x' P prf x eqprf)
-        | _ => def
-        end
-      end.
-
-
-  Theorem inj_right_pair: (P:A->Prop)(y,y':(P x))
-    (exT_intro ? P x y)==(exT_intro ? P x y') -> y==y'.
-Intros.
-Cut (proj (exT_intro A P x y) y)==(proj (exT_intro A P x y') y).
-Simpl.
-Case (eq_dec x x).
-Intro e.
-Elim e using K_dec; Trivial.
-
-Intros.
-Case n; Trivial.
-
-Case H.
-Reflexivity.
-Qed.
-
-End DecidableEqDep.
-
-  (** We deduce the [K] axiom for (decidable) Set *)
-  Theorem K_dec_set: (A:Set)((x,y:A){x=y}+{~x=y})
-                       ->(x:A)(P: x=x->Prop)(P (refl_equal ? x))
-                         ->(p:x=x)(P p).
-Intros.
-Rewrite eq_eqT_bij.
-Elim (eq2eqT p) using K_dec.
-Intros.
-Case (H x0 y); Intros.
-Elim e; Left ; Reflexivity.
-
-Right ; Red; Intro neq; Apply n; Elim neq; Reflexivity.
-
-Trivial.
-Qed.
diff --git a/theories7/Logic/Hurkens.v b/theories7/Logic/Hurkens.v
deleted file mode 100644
index 066e51aa..00000000
--- a/theories7/Logic/Hurkens.v
+++ /dev/null
@@ -1,79 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(*                              Hurkens.v                               *)
-(************************************************************************)
-
-(** This is Hurkens paradox [Hurkens] in system U-, adapted by Herman
-    Geuvers [Geuvers] to show the inconsistency in the pure calculus of
-    constructions of a retract from Prop into a small type.
-
-    References:
-
-    - [Hurkens] A. J. Hurkens, "A simplification of Girard's paradox",
-      Proceedings of the 2nd international conference Typed Lambda-Calculi
-      and Applications (TLCA'95), 1995.
-
-    - [Geuvers] "Inconsistency of Classical Logic in Type Theory", 2001
-      (see www.cs.kun.nl/~herman/note.ps.gz).
-*)
-
-Section Paradox.
-
-Variable bool : Prop.
-Variable p2b : Prop -> bool.
-Variable b2p : bool -> Prop.
-Hypothesis p2p1 : (A:Prop)(b2p (p2b A))->A.
-Hypothesis p2p2 : (A:Prop)A->(b2p (p2b A)).
-Variable B:Prop.
-
-Definition V := (A:Prop)((A->bool)->(A->bool))->(A->bool).
-Definition U := V->bool.
-Definition sb : V -> V := [z][A;r;a](r (z A r) a).
-Definition le : (U->bool)->(U->bool) := [i][x](x [A;r;a](i [v](sb v A r a))).
-Definition induct : (U->bool)->Prop := [i](x:U)(b2p (le i x))->(b2p (i x)).
-Definition WF : U := [z](p2b (induct (z U le))).
-Definition I : U->Prop :=
-  [x]((i:U->bool)(b2p (le i x))->(b2p (i [v](sb v U le x))))->B.
-
-Lemma Omega : (i:U->bool)(induct i)->(b2p (i WF)).
-Proof.
-Intros i y.
-Apply y.
-Unfold le WF induct.
-Apply p2p2.
-Intros x H0.
-Apply y.
-Exact H0.
-Qed.
-
-Lemma lemma1 : (induct [u](p2b (I u))).
-Proof.
-Unfold induct.
-Intros x p.
-Apply (p2p2 (I x)).
-Intro q.
-Apply (p2p1 (I [v:V](sb v U le x)) (q [u](p2b (I u)) p)).
-Intro i.
-Apply q with i:=[y:?](i [v:V](sb v U le y)).
-Qed.
-
-Lemma lemma2 : ((i:U->bool)(induct i)->(b2p (i WF)))->B.
-Proof.
-Intro x.
-Apply (p2p1 (I WF) (x [u](p2b (I u)) lemma1)).
-Intros i H0.
-Apply (x [y](i [v](sb v U le y))).
-Apply (p2p1 ? H0).
-Qed.
-
-Theorem paradox : B.
-Proof.
-Exact (lemma2 Omega).
-Qed.
-
-End Paradox.
diff --git a/theories7/Logic/JMeq.v b/theories7/Logic/JMeq.v
deleted file mode 100644
index 38dfa5e6..00000000
--- a/theories7/Logic/JMeq.v
+++ /dev/null
@@ -1,64 +0,0 @@
-(************************************************************************)
-(*  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: JMeq.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(** John Major's Equality as proposed by C. Mc Bride *)
-
-Set Implicit Arguments.
-
-Inductive JMeq [A:Set;x:A] : (B:Set)B->Prop := 
-	JMeq_refl : (JMeq x x).
-Reset JMeq_ind.
-
-Hints Resolve JMeq_refl.
-
-Lemma sym_JMeq : (A,B:Set)(x:A)(y:B)(JMeq x y)->(JMeq y x).
-NewDestruct 1; Trivial.
-Qed.
-
-Hints Immediate sym_JMeq.
-
-Lemma trans_JMeq : (A,B,C:Set)(x:A)(y:B)(z:C)
-	(JMeq x y)->(JMeq y z)->(JMeq x z).
-NewDestruct 1; Trivial.
-Qed.
-
-Axiom JMeq_eq : (A:Set)(x,y:A)(JMeq x y)->(x=y).
-
-Lemma JMeq_ind : (A:Set)(x,y:A)(P:A->Prop)(P x)->(JMeq x y)->(P y).
-Intros A x y P H H'; Case JMeq_eq with 1:=H'; Trivial.
-Qed.
-
-Lemma JMeq_rec : (A:Set)(x,y:A)(P:A->Set)(P x)->(JMeq x y)->(P y).
-Intros A x y P H H'; Case JMeq_eq with 1:=H'; Trivial.
-Qed.
-
-Lemma JMeq_ind_r : (A:Set)(x,y:A)(P:A->Prop)(P y)->(JMeq x y)->(P x).
-Intros A x y P H H'; Case JMeq_eq with 1:=(sym_JMeq H'); Trivial.
-Qed.
-
-Lemma JMeq_rec_r : (A:Set)(x,y:A)(P:A->Set)(P y)->(JMeq x y)->(P x).
-Intros A x y P H H'; Case JMeq_eq with 1:=(sym_JMeq H'); Trivial.
-Qed.
-
-(** [JMeq] is equivalent to [(eq_dep Set [X]X)] *)
-
-Require Eqdep.
-
-Lemma JMeq_eq_dep : (A,B:Set)(x:A)(y:B)(JMeq x y)->(eq_dep Set [X]X A x B y).
-Proof.
-NewDestruct 1.
-Apply eq_dep_intro.
-Qed.
-
-Lemma eq_dep_JMeq : (A,B:Set)(x:A)(y:B)(eq_dep Set [X]X A x B y)->(JMeq x y).
-Proof.
-NewDestruct 1.
-Apply JMeq_refl. 
-Qed.
diff --git a/theories7/Logic/ProofIrrelevance.v b/theories7/Logic/ProofIrrelevance.v
deleted file mode 100644
index 3f031ff7..00000000
--- a/theories7/Logic/ProofIrrelevance.v
+++ /dev/null
@@ -1,113 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-
-(** This is a proof in the pure Calculus of Construction that
-    classical logic in Prop + dependent elimination of disjunction entails
-    proof-irrelevance.
-
-    Since, dependent elimination is derivable in the Calculus of
-    Inductive Constructions (CCI), we get proof-irrelevance from classical
-    logic in the CCI.
-
-    Reference:
-
-    - [Coquand] T. Coquand, "Metamathematical Investigations of a
-      Calculus of Constructions", Proceedings of Logic in Computer Science
-      (LICS'90), 1990.
-
-    Proof skeleton: classical logic + dependent elimination of
-    disjunction + discrimination of proofs implies the existence of a
-    retract from Prop into bool, hence inconsistency by encoding any
-    paradox of system U- (e.g. Hurkens' paradox).
-*)
-
-Require Hurkens.
-
-Section Proof_irrelevance_CC.
-
-Variable or : Prop -> Prop -> Prop.
-Variable or_introl : (A,B:Prop)A->(or A B).
-Variable or_intror : (A,B:Prop)B->(or A B).
-Hypothesis or_elim : (A,B:Prop)(C:Prop)(A->C)->(B->C)->(or A B)->C.
-Hypothesis or_elim_redl :
-  (A,B:Prop)(C:Prop)(f:A->C)(g:B->C)(a:A)
-  (f a)==(or_elim A B C f g (or_introl A B a)).
-Hypothesis or_elim_redr :
-  (A,B:Prop)(C:Prop)(f:A->C)(g:B->C)(b:B)
-  (g b)==(or_elim A B C f g (or_intror A B b)).
-Hypothesis or_dep_elim :
- (A,B:Prop)(P:(or A B)->Prop)
- ((a:A)(P (or_introl A B a))) ->
- ((b:B)(P (or_intror A B b))) -> (b:(or A B))(P b).
-
-Hypothesis em : (A:Prop)(or A ~A).
-Variable B : Prop.
-Variable b1,b2 : B.
-
-(** [p2b] and [b2p] form a retract if [~b1==b2] *)
-
-Definition p2b [A] := (or_elim A ~A B [_]b1 [_]b2 (em A)).
-Definition b2p [b] := b1==b.
-
-Lemma p2p1 : (A:Prop) A -> (b2p (p2b A)).
-Proof.
-  Unfold p2b; Intro A; Apply or_dep_elim with b:=(em A); Unfold b2p; Intros.
-  Apply (or_elim_redl A ~A B [_]b1 [_]b2).
-  NewDestruct (b H).
-Qed.
-Lemma p2p2 :  ~b1==b2->(A:Prop) (b2p (p2b A)) -> A.
-Proof.
-  Intro not_eq_b1_b2.
-  Unfold p2b; Intro A; Apply or_dep_elim with b:=(em A); Unfold b2p; Intros.
-  Assumption.
-  NewDestruct not_eq_b1_b2.
-  Rewrite <- (or_elim_redr A ~A B [_]b1 [_]b2) in H.
-  Assumption.
-Qed.
-
-(** Using excluded-middle a second time, we get proof-irrelevance *)
-
-Theorem proof_irrelevance_cc : b1==b2.
-Proof.
-  Refine (or_elim ? ? ? ? ? (em b1==b2));Intro H.
-    Trivial.
-  Apply (paradox B p2b b2p (p2p2 H) p2p1).
-Qed.
-
-End Proof_irrelevance_CC.
-
-
-(** The Calculus of Inductive Constructions (CCI) enjoys dependent
-    elimination, hence classical logic in CCI entails proof-irrelevance.
-*)
-
-Section Proof_irrelevance_CCI.
-
-Hypothesis em : (A:Prop) A \/ ~A.
-
-Definition or_elim_redl :
-  (A,B:Prop)(C:Prop)(f:A->C)(g:B->C)(a:A)
-  (f a)==(or_ind A B C f g (or_introl A B a))
-  := [A,B,C;f;g;a](refl_eqT C (f a)).
-Definition or_elim_redr :
-  (A,B:Prop)(C:Prop)(f:A->C)(g:B->C)(b:B)
-  (g b)==(or_ind A B C f g (or_intror A B b))
-  := [A,B,C;f;g;b](refl_eqT C (g b)).
-Scheme or_indd := Induction for or Sort Prop.
-
-Theorem proof_irrelevance_cci : (B:Prop)(b1,b2:B)b1==b2.
-Proof
-  (proof_irrelevance_cc or or_introl or_intror or_ind
-     or_elim_redl or_elim_redr or_indd em).
-
-End Proof_irrelevance_CCI.
-
-(** Remark: in CCI, [bool] can be taken in [Set] as well in the
-    paradox and since [~true=false] for [true] and [false] in
-    [bool], we get the inconsistency of [em : (A:Prop){A}+{~A}] in CCI
-*)
diff --git a/theories7/Logic/RelationalChoice.v b/theories7/Logic/RelationalChoice.v
deleted file mode 100644
index e61f3582..00000000
--- a/theories7/Logic/RelationalChoice.v
+++ /dev/null
@@ -1,17 +0,0 @@
-(************************************************************************)
-(*  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: RelationalChoice.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
-
-(* This file axiomatizes the relational form of the axiom of choice *)
-
-Axiom relational_choice :
- (A:Type;B:Type;R: A->B->Prop) 
-  ((x:A)(EX y:B|(R x y)))
-   -> (EXT R':A->B->Prop | 
-         ((x:A)(EX y:B|(R x y)/\(R' x y)/\ ((y':B) (R' x y') -> y=y')))).
diff --git a/theories7/NArith/BinNat.v b/theories7/NArith/BinNat.v
deleted file mode 100644
index 5e04e22e..00000000
--- a/theories7/NArith/BinNat.v
+++ /dev/null
@@ -1,205 +0,0 @@
-(************************************************************************)
-(*  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: BinNat.v,v 1.1.2.1 2004/07/16 19:31:30 herbelin Exp $ i*)
-
-Require BinPos.
-
-(**********************************************************************)
-(** Binary natural numbers *)
-
-Inductive entier: Set := Nul : entier | Pos : positive -> entier.
-
-(** Declare binding key for scope positive_scope *)
-
-Delimits Scope N_scope with N.
-
-(** Automatically open scope N_scope for the constructors of N *)
-
-Bind Scope N_scope with entier.
-Arguments Scope Pos [ N_scope ].
-
-Open Local Scope N_scope.
-
-(** Operation x -> 2*x+1 *)
-
-Definition Un_suivi_de := [x]
-  Cases x of Nul => (Pos xH) | (Pos p) => (Pos (xI p)) end.
-
-(** Operation x -> 2*x *)
-
-Definition Zero_suivi_de :=
-  [n] Cases n of Nul => Nul | (Pos p) => (Pos (xO p)) end.
-
-(** Successor *)
-
-Definition Nsucc :=
-  [n] Cases n of Nul => (Pos xH) | (Pos p) => (Pos (add_un p)) end.
-
-(** Addition *)
-
-Definition Nplus := [n,m]
-  Cases n m of
-  | Nul     _       => m
-  | _       Nul     => n
-  | (Pos p) (Pos q) => (Pos (add p q))
-  end.
-
-V8Infix "+" Nplus : N_scope.
-
-(** Multiplication *)
-
-Definition Nmult := [n,m]
-  Cases n m of
-  | Nul     _       => Nul
-  | _       Nul     => Nul
-  | (Pos p) (Pos q) => (Pos (times p q))
-  end.
-
-V8Infix "*" Nmult : N_scope.
-
-(** Order *)
-
-Definition Ncompare := [n,m]
-  Cases n m of
-  | Nul      Nul      => EGAL
-  | Nul      (Pos m') => INFERIEUR
-  | (Pos n') Nul      => SUPERIEUR
-  | (Pos n') (Pos m') => (compare n' m' EGAL)
-  end.
-
-V8Infix "?=" Ncompare (at level 70, no associativity) : N_scope.
-
-(** Peano induction on binary natural numbers *)
-
-Theorem Nind : (P:(entier ->Prop))
-  (P Nul) ->((n:entier)(P n) ->(P (Nsucc n))) ->(n:entier)(P n).
-Proof.
-NewDestruct n.
-  Assumption.
-  Apply Pind with P := [p](P (Pos p)).
-Exact (H0 Nul H).
-Intro p'; Exact (H0 (Pos p')).
-Qed.
-
-(** Properties of addition *)
-
-Theorem Nplus_0_l : (n:entier)(Nplus Nul n)=n.
-Proof.
-Reflexivity.
-Qed.
-
-Theorem Nplus_0_r : (n:entier)(Nplus n Nul)=n.
-Proof.
-NewDestruct n; Reflexivity.
-Qed.
-
-Theorem Nplus_comm : (n,m:entier)(Nplus n m)=(Nplus m n).
-Proof.
-Intros.
-NewDestruct n; NewDestruct m; Simpl; Try Reflexivity.
-Rewrite add_sym; Reflexivity.
-Qed.
-
-Theorem Nplus_assoc : 
-  (n,m,p:entier)(Nplus n (Nplus m p))=(Nplus (Nplus n m) p).
-Proof.
-Intros.
-NewDestruct n; Try Reflexivity.
-NewDestruct m; Try Reflexivity.
-NewDestruct p; Try Reflexivity.
-Simpl; Rewrite add_assoc; Reflexivity.
-Qed.
-
-Theorem Nplus_succ : (n,m:entier)(Nplus (Nsucc n) m)=(Nsucc (Nplus n m)).
-Proof.
-NewDestruct n; NewDestruct m.
-  Simpl; Reflexivity.
-  Unfold Nsucc Nplus; Rewrite <- ZL12bis; Reflexivity.
-  Simpl; Reflexivity.
-  Simpl; Rewrite ZL14bis; Reflexivity.
-Qed.
-
-Theorem Nsucc_inj : (n,m:entier)(Nsucc n)=(Nsucc m)->n=m.
-Proof.
-NewDestruct n; NewDestruct m; Simpl; Intro H; 
-  Reflexivity Orelse Injection H; Clear H; Intro H.
-  Symmetry in H; Contradiction add_un_not_un with p.
-  Contradiction add_un_not_un with p.
-  Rewrite add_un_inj with 1:=H; Reflexivity.
-Qed.
-
-Theorem Nplus_reg_l : (n,m,p:entier)(Nplus n m)=(Nplus n p)->m=p.
-Proof.
-Intro n; Pattern n; Apply Nind; Clear n; Simpl.
-  Trivial.
-  Intros n IHn m p H0; Do 2 Rewrite Nplus_succ in H0.
-  Apply IHn; Apply Nsucc_inj; Assumption.
-Qed.
-
-(** Properties of multiplication *)
-
-Theorem Nmult_1_l : (n:entier)(Nmult (Pos xH) n)=n.
-Proof.
-NewDestruct n; Reflexivity.
-Qed.
-
-Theorem Nmult_1_r : (n:entier)(Nmult n (Pos xH))=n.
-Proof.
-NewDestruct n; Simpl; Try Reflexivity.
-Rewrite times_x_1; Reflexivity.
-Qed.
-
-Theorem Nmult_comm : (n,m:entier)(Nmult n m)=(Nmult m n).
-Proof.
-Intros.
-NewDestruct n; NewDestruct m; Simpl; Try Reflexivity.
-Rewrite times_sym; Reflexivity.
-Qed.
-
-Theorem Nmult_assoc : 
-  (n,m,p:entier)(Nmult n (Nmult m p))=(Nmult (Nmult n m) p).
-Proof.
-Intros.
-NewDestruct n; Try Reflexivity.
-NewDestruct m; Try Reflexivity.
-NewDestruct p; Try Reflexivity.
-Simpl; Rewrite times_assoc; Reflexivity.
-Qed.
-
-Theorem Nmult_plus_distr_r :
-  (n,m,p:entier)(Nmult (Nplus n m) p)=(Nplus (Nmult n p) (Nmult m p)).
-Proof.
-Intros.
-NewDestruct n; Try Reflexivity.
-NewDestruct m; NewDestruct p; Try Reflexivity.
-Simpl; Rewrite times_add_distr_l; Reflexivity.
-Qed.
-
-Theorem Nmult_reg_r : (n,m,p:entier) ~p=Nul->(Nmult n p)=(Nmult m p) -> n=m.
-Proof.
-NewDestruct p; Intros Hp H.
-Contradiction Hp; Reflexivity.
-NewDestruct n; NewDestruct m; Reflexivity Orelse Try Discriminate H.
-Injection H; Clear H; Intro H; Rewrite simpl_times_r with 1:=H; Reflexivity.
-Qed. 
-
-Theorem Nmult_0_l : (n:entier) (Nmult Nul n) = Nul.
-Proof.
-Reflexivity.
-Qed.
-
-(** Properties of comparison *)
-
-Theorem Ncompare_Eq_eq : (n,m:entier) (Ncompare n m) = EGAL -> n = m.
-Proof.
-NewDestruct n as [|n]; NewDestruct m as [|m]; Simpl; Intro H;
-  Reflexivity Orelse Try Discriminate H.
-  Rewrite (compare_convert_EGAL n m H); Reflexivity.
-Qed.
-
diff --git a/theories7/NArith/BinPos.v b/theories7/NArith/BinPos.v
deleted file mode 100644
index ae61587d..00000000
--- a/theories7/NArith/BinPos.v
+++ /dev/null
@@ -1,894 +0,0 @@
-(************************************************************************)
-(*  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: BinPos.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ i*)
-
-(**********************************************************************)
-(** Binary positive numbers *)
-
-(** Original development by Pierre Crégut, CNET, Lannion, France *)
-
-Inductive positive : Set :=
-  xI : positive -> positive
-| xO : positive -> positive
-| xH : positive.
-
-(** Declare binding key for scope positive_scope *)
-
-Delimits Scope positive_scope with positive.
-
-(** Automatically open scope positive_scope for type positive, xO and xI *)
-
-Bind Scope positive_scope with positive.
-Arguments Scope xO [ positive_scope ].
-Arguments Scope xI [ positive_scope ].
-
-(** Successor *)
-
-Fixpoint add_un [x:positive]:positive :=
-  Cases x of
-    (xI x') => (xO (add_un x'))
-  | (xO x') => (xI x')
-  | xH => (xO xH)
-  end.
-
-(** Addition *)
-
-Fixpoint add [x:positive]:positive -> positive := [y:positive]
-  Cases x y of
-  | (xI x') (xI y') => (xO (add_carry x' y'))
-  | (xI x') (xO y') => (xI (add x' y'))
-  | (xI x') xH      => (xO (add_un x'))
-  | (xO x') (xI y') => (xI (add x' y'))
-  | (xO x') (xO y') => (xO (add x' y'))
-  | (xO x') xH      => (xI x')
-  | xH      (xI y') => (xO (add_un y'))
-  | xH      (xO y') => (xI y')
-  | xH      xH      => (xO xH)
-  end
-with add_carry [x:positive]:positive -> positive := [y:positive]
-  Cases x y of
-  | (xI x') (xI y') => (xI (add_carry x' y'))
-  | (xI x') (xO y') => (xO (add_carry x' y'))
-  | (xI x') xH      => (xI (add_un x'))
-  | (xO x') (xI y') => (xO (add_carry x' y'))
-  | (xO x') (xO y') => (xI (add x' y'))
-  | (xO x') xH      => (xO (add_un x'))
-  | xH      (xI y') => (xI (add_un y'))
-  | xH      (xO y') => (xO (add_un y'))
-  | xH      xH      => (xI xH)
-  end.
-
-V7only [Notation "x + y" := (add x y) : positive_scope.].
-V8Infix "+" add : positive_scope.
-
-Open Local Scope positive_scope.
-
-(** From binary positive numbers to Peano natural numbers *)
-
-Fixpoint positive_to_nat [x:positive]:nat -> nat :=
-  [pow2:nat]
-   Cases x of
-     (xI x') => (plus pow2 (positive_to_nat x' (plus pow2 pow2)))
-   | (xO x') => (positive_to_nat x' (plus pow2 pow2))
-   | xH      => pow2
-   end.
-
-Definition convert := [x:positive] (positive_to_nat x (S O)).
-
-(** From Peano natural numbers to binary positive numbers *)
-
-Fixpoint anti_convert [n:nat]: positive :=
-   Cases n of
-                O => xH
-             | (S x') => (add_un (anti_convert x'))
-             end.
-
-(** Operation x -> 2*x-1 *)
-
-Fixpoint double_moins_un [x:positive]:positive :=
-  Cases x of
-      (xI x') => (xI (xO x'))
-    | (xO x') => (xI (double_moins_un x'))
-    | xH => xH
-    end.
-
-(** Predecessor *)
-
-Definition sub_un := [x:positive]
-   Cases x of
-             (xI x') => (xO x')
-           | (xO x') => (double_moins_un x')
-           | xH => xH
-           end.
-
-(** An auxiliary type for subtraction *)
-
-Inductive positive_mask: Set :=
-   IsNul : positive_mask
- | IsPos : positive -> positive_mask
- | IsNeg : positive_mask.
-
-(** Operation x -> 2*x+1 *)
-
-Definition Un_suivi_de_mask := [x:positive_mask]
-  Cases x of IsNul => (IsPos xH) | IsNeg => IsNeg | (IsPos p) => (IsPos (xI p)) end.
-
-(** Operation x -> 2*x *)
-
-Definition Zero_suivi_de_mask := [x:positive_mask]
-  Cases x of IsNul => IsNul | IsNeg => IsNeg | (IsPos p) => (IsPos (xO p)) end.
-
-(** Operation x -> 2*x-2 *)
-
-Definition double_moins_deux :=
-  [x:positive] Cases x of
-           (xI x') => (IsPos (xO (xO x')))
-         | (xO x') => (IsPos (xO (double_moins_un x')))
-         | xH => IsNul
-         end.
-
-(** Subtraction of binary positive numbers into a positive numbers mask *)
-
-Fixpoint sub_pos[x,y:positive]:positive_mask :=
-  Cases x y of
-  | (xI x') (xI y') => (Zero_suivi_de_mask (sub_pos x' y'))
-  | (xI x') (xO y') => (Un_suivi_de_mask (sub_pos x' y'))
-  | (xI x') xH      => (IsPos (xO x'))
-  | (xO x') (xI y') => (Un_suivi_de_mask (sub_neg x' y'))
-  | (xO x') (xO y') => (Zero_suivi_de_mask (sub_pos x' y'))
-  | (xO x') xH      => (IsPos (double_moins_un x'))
-  | xH      xH      => IsNul
-  | xH      _       => IsNeg
-  end
-with sub_neg [x,y:positive]:positive_mask :=
-  Cases x y of
-    (xI x') (xI y') => (Un_suivi_de_mask (sub_neg x' y'))
-  | (xI x') (xO y') => (Zero_suivi_de_mask (sub_pos x' y'))
-  | (xI x') xH      => (IsPos (double_moins_un x'))
-  | (xO x') (xI y') => (Zero_suivi_de_mask (sub_neg x' y'))
-  | (xO x') (xO y') => (Un_suivi_de_mask (sub_neg x' y'))
-  | (xO x') xH      => (double_moins_deux x')
-  | xH      _       => IsNeg
-  end.
-
-(** Subtraction of binary positive numbers x and y, returns 1 if x<=y *)
-
-Definition true_sub := [x,y:positive] 
-  Cases (sub_pos x y) of (IsPos z) => z | _ => xH  end.
-
-V8Infix "-" true_sub : positive_scope.
-
-(** Multiplication on binary positive numbers *)
-
-Fixpoint times [x:positive] : positive -> positive:=
-  [y:positive]
-  Cases x of
-    (xI x') => (add y (xO (times x' y)))
-  | (xO x') => (xO (times x' y))
-  | xH => y
-  end.
-
-V8Infix "*" times : positive_scope.
-
-(** Division by 2 rounded below but for 1 *)
-
-Definition Zdiv2_pos :=
-  [z:positive]Cases z of xH => xH
-                       | (xO p) => p
-		       | (xI p) => p
-		      end.
-
-V8Infix "/" Zdiv2_pos : positive_scope.
-
-(** Comparison on binary positive numbers *)
-
-Fixpoint compare [x,y:positive]: relation -> relation :=
-  [r:relation] 
-  Cases x y of
-  | (xI x') (xI y') => (compare x' y' r)
-  | (xI x') (xO y') => (compare x' y' SUPERIEUR)
-  | (xI x')  xH     => SUPERIEUR
-  | (xO x') (xI y') => (compare x' y' INFERIEUR)
-  | (xO x') (xO y') => (compare x' y' r)
-  | (xO x')  xH     => SUPERIEUR
-  | xH      (xI y') => INFERIEUR
-  | xH      (xO y') => INFERIEUR
-  | xH       xH     => r
-  end.
-
-V8Infix "?=" compare (at level 70, no associativity) : positive_scope.
-
-(**********************************************************************)
-(** Miscellaneous properties of binary positive numbers *)
-
-Lemma ZL11: (x:positive) (x=xH) \/ ~(x=xH).
-Proof.
-Intros x;Case x;Intros; (Left;Reflexivity) Orelse (Right;Discriminate).
-Qed.
-
-(**********************************************************************)
-(** Properties of successor on binary positive numbers *)
-
-(** Specification of [xI] in term of [Psucc] and [xO] *)
-
-Lemma xI_add_un_xO : (x:positive)(xI x) = (add_un (xO x)).
-Proof.
-Reflexivity.
-Qed.
-
-Lemma add_un_discr : (x:positive)x<>(add_un x).
-Proof.
-Intro x; NewDestruct x; Discriminate.
-Qed.
-
-(** Successor and double *)
-
-Lemma is_double_moins_un : (x:positive) (add_un (double_moins_un x)) = (xO x).
-Proof.
-Intro x; NewInduction x as [x IHx|x|]; Simpl; Try Rewrite IHx; Reflexivity.
-Qed.
-
-Lemma double_moins_un_add_un_xI : 
- (x:positive)(double_moins_un (add_un x))=(xI x).
-Proof.
-Intro x;NewInduction x as [x IHx|x|]; Simpl; Try Rewrite IHx; Reflexivity.
-Qed.
-
-Lemma ZL1: (y:positive)(xO (add_un y)) = (add_un (add_un (xO y))).
-Proof.
-Intro y; Induction y; Simpl; Auto.
-Qed.
-
-Lemma double_moins_un_xO_discr : (x:positive)(double_moins_un x)<>(xO x).
-Proof.
-Intro x; NewDestruct x; Discriminate.
-Qed.
-
-(** Successor and predecessor *)
-
-Lemma add_un_not_un : (x:positive) (add_un x) <> xH.
-Proof.
-Intro x; NewDestruct x as [x|x|]; Discriminate.
-Qed.
-
-Lemma sub_add_one : (x:positive) (sub_un (add_un x)) = x.
-Proof.
-(Intro x; NewDestruct x as [p|p|]; [Idtac | Idtac | Simpl;Auto]);
-(NewInduction p as [p IHp||]; [Idtac | Reflexivity | Reflexivity ]);
-Simpl; Simpl in IHp; Try Rewrite <- IHp; Reflexivity.
-Qed.
-
-Lemma add_sub_one : (x:positive) (x=xH) \/ (add_un (sub_un x)) = x.
-Proof.
-Intro x; Induction x; [
-  Simpl; Auto
-| Simpl; Intros;Right;Apply is_double_moins_un
-| Auto ].
-Qed.
-
-(** Injectivity of successor *)
-
-Lemma add_un_inj : (x,y:positive) (add_un x)=(add_un y) -> x=y.
-Proof.
-Intro x;NewInduction x; Intro y; NewDestruct y as [y|y|]; Simpl; 
-  Intro H; Discriminate H Orelse Try (Injection H; Clear H; Intro H).
-Rewrite (IHx y H); Reflexivity.
-Absurd (add_un x)=xH; [ Apply add_un_not_un | Assumption ].
-Apply f_equal with 1:=H; Assumption.
-Absurd (add_un y)=xH; [ Apply add_un_not_un | Symmetry; Assumption ].
-Reflexivity.
-Qed.
-
-(**********************************************************************)
-(** Properties of addition on binary positive numbers *)
-
-(** Specification of [Psucc] in term of [Pplus] *)
-
-Lemma ZL12: (q:positive) (add_un q) = (add q xH).
-Proof.
-Intro q; NewDestruct q; Reflexivity.
-Qed.
-
-Lemma ZL12bis: (q:positive) (add_un q) = (add xH q).
-Proof.
-Intro q; NewDestruct q; Reflexivity.
-Qed.
-
-(** Specification of [Pplus_carry] *)
-
-Theorem ZL13: (x,y:positive)(add_carry x y) = (add_un (add x y)).
-Proof.
-(Intro x; NewInduction x as [p IHp|p IHp|];Intro y; NewDestruct y;Simpl;Auto);
-  Rewrite IHp; Auto.
-Qed.
-
-(** Commutativity *)
-
-Theorem add_sym : (x,y:positive) (add x y) = (add y x).
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|];Intro y; NewDestruct y;Simpl;Auto;
-  Try Do 2 Rewrite ZL13; Rewrite IHp;Auto.
-Qed. 
-
-(** Permutation of [Pplus] and [Psucc] *)
-
-Theorem ZL14: (x,y:positive)(add x (add_un y)) = (add_un (add x y)).
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|];Intro y; NewDestruct y;Simpl;Auto; [
-  Rewrite ZL13; Rewrite IHp; Auto
-| Rewrite ZL13; Auto
-| NewDestruct p;Simpl;Auto
-| Rewrite IHp;Auto
-| NewDestruct p;Simpl;Auto ].
-Qed.
-
-Theorem ZL14bis: (x,y:positive)(add (add_un x) y) = (add_un (add x y)).
-Proof.
-Intros x y; Rewrite add_sym; Rewrite add_sym with x:=x; Apply ZL14.
-Qed.
-
-Theorem ZL15: (q,z:positive) ~z=xH -> (add_carry q (sub_un z)) = (add q z).
-Proof.
-Intros q z H; Elim (add_sub_one z); [
-  Intro;Absurd z=xH;Auto
-| Intros E;Pattern 2 z ;Rewrite <- E; Rewrite ZL14; Rewrite ZL13; Trivial ].
-Qed. 
-
-(** No neutral for addition on strictly positive numbers *)
-
-Lemma add_no_neutral : (x,y:positive) ~(add y x)=x.
-Proof.
-Intro x;NewInduction x; Intro y; NewDestruct y as [y|y|]; Simpl; Intro H;
-  Discriminate H Orelse Injection H; Clear H; Intro H; Apply (IHx y H).
-Qed.
-
-Lemma add_carry_not_add_un : (x,y:positive) ~(add_carry y x)=(add_un x).
-Proof.
-Intros x y H; Absurd (add y x)=x; 
-      [ Apply add_no_neutral
-      | Apply add_un_inj; Rewrite <- ZL13; Assumption ].
-Qed.
-
-(** Simplification *)
-
-Lemma add_carry_add :
-  (x,y,z,t:positive) (add_carry x z)=(add_carry y t) -> (add x z)=(add y t).
-Proof.
-Intros x y z t H; Apply add_un_inj; Do 2 Rewrite <- ZL13; Assumption.
-Qed.
-
-Lemma simpl_add_r : (x,y,z:positive) (add x z)=(add y z) -> x=y.
-Proof.
-Intros x y z; Generalize x y; Clear x y.
-NewInduction z as [z|z|].
-  NewDestruct x as [x|x|]; Intro y; NewDestruct y as [y|y|]; Simpl; Intro H; 
-  Discriminate H Orelse Try (Injection H; Clear H; Intro H).
-    Rewrite IHz with 1:=(add_carry_add ? ? ? ? H); Reflexivity.
-    Absurd (add_carry x z)=(add_un z);
-      [ Apply add_carry_not_add_un | Assumption ].
-    Rewrite IHz with 1:=H; Reflexivity.
-    Symmetry in H; Absurd (add_carry y z)=(add_un z);
-      [ Apply add_carry_not_add_un | Assumption ].
-    Reflexivity.
-  NewDestruct x as [x|x|]; Intro y; NewDestruct y as [y|y|]; Simpl; Intro H; 
-  Discriminate H Orelse Try (Injection H; Clear H; Intro H).
-    Rewrite IHz with 1:=H; Reflexivity.
-    Absurd (add x z)=z; [ Apply add_no_neutral | Assumption ].
-    Rewrite IHz with 1:=H; Reflexivity.
-    Symmetry in H; Absurd y+z=z; [ Apply add_no_neutral | Assumption ].
-    Reflexivity.
-  Intros H x y; Apply add_un_inj; Do 2 Rewrite ZL12; Assumption.
-Qed.
-
-Lemma simpl_add_l : (x,y,z:positive) (add x y)=(add x z) -> y=z.
-Proof.
-Intros x y z H;Apply simpl_add_r with z:=x; 
-  Rewrite add_sym with x:=z; Rewrite add_sym with x:=y; Assumption.
-Qed.
-
-Lemma simpl_add_carry_r :
- (x,y,z:positive) (add_carry x z)=(add_carry y z) -> x=y.
-Proof.
-Intros x y z H; Apply simpl_add_r with z:=z; Apply add_carry_add; Assumption.
-Qed.
-
-Lemma simpl_add_carry_l :
-  (x,y,z:positive) (add_carry x y)=(add_carry x z) -> y=z.
-Proof.
-Intros x y z H;Apply simpl_add_r with z:=x; 
-Rewrite add_sym with x:=z; Rewrite add_sym with x:=y; Apply add_carry_add; 
-Assumption.
-Qed.
-
-(** Addition on positive is associative *)
-
-Theorem add_assoc: (x,y,z:positive)(add x (add y z)) = (add (add x y) z).
-Proof.
-Intros x y; Generalize x; Clear x.
-NewInduction y as [y|y|]; Intro x.
-  NewDestruct x as [x|x|]; 
-    Intro z; NewDestruct z as [z|z|]; Simpl; Repeat Rewrite ZL13;
-    Repeat Rewrite ZL14; Repeat Rewrite ZL14bis; Reflexivity Orelse
-    Repeat Apply f_equal with A:=positive; Apply IHy.
-  NewDestruct x as [x|x|]; 
-    Intro z; NewDestruct z as [z|z|]; Simpl; Repeat Rewrite ZL13;
-    Repeat Rewrite ZL14; Repeat Rewrite ZL14bis; Reflexivity Orelse
-    Repeat Apply f_equal with A:=positive; Apply IHy.
-  Intro z; Rewrite add_sym with x:=xH; Do 2 Rewrite <- ZL12; Rewrite ZL14bis; Rewrite ZL14; Reflexivity.
-Qed.
-
-(** Commutation of addition with the double of a positive number *)
-
-Lemma add_xI_double_moins_un :
-  (p,q:positive)(xO (add p q)) = (add (xI p) (double_moins_un q)).
-Proof.
-Intros; Change (xI p) with (add (xO p) xH).
-Rewrite <- add_assoc; Rewrite <- ZL12bis; Rewrite is_double_moins_un.
-Reflexivity.
-Qed.
-
-Lemma add_xO_double_moins_un :
- (p,q:positive) (double_moins_un (add p q)) = (add (xO p) (double_moins_un q)).
-Proof.
-NewInduction p as [p IHp|p IHp|]; NewDestruct q as [q|q|];
- Simpl; Try Rewrite ZL13; Try Rewrite double_moins_un_add_un_xI;
- Try Rewrite IHp; Try Rewrite add_xI_double_moins_un; Try Reflexivity.
- Rewrite <- is_double_moins_un; Rewrite ZL12bis; Reflexivity. 
-Qed.
-
-(** Misc *)
-
-Lemma add_x_x : (x:positive) (add x x) = (xO x).
-Proof.
-Intro x;NewInduction x; Simpl; Try Rewrite ZL13; Try Rewrite IHx; Reflexivity.
-Qed.
-
-(**********************************************************************)
-(** Peano induction on binary positive positive numbers *)
-
-Fixpoint plus_iter [x:positive] : positive -> positive := 
-  [y]Cases x of 
-  | xH => (add_un y)
-  | (xO x) => (plus_iter x (plus_iter x y))
-  | (xI x) => (plus_iter x (plus_iter x (add_un y)))
-  end.
-
-Lemma plus_iter_add : (x,y:positive)(plus_iter x y)=(add x y).
-Proof.
-Intro x;NewInduction x as [p IHp|p IHp|]; Intro y; NewDestruct y; Simpl;
-  Reflexivity Orelse Do 2 Rewrite IHp; Rewrite add_assoc; Rewrite add_x_x;
-  Try Reflexivity.
-Rewrite ZL13; Rewrite <- ZL14; Reflexivity.
-Rewrite ZL12; Reflexivity.
-Qed.
-
-Lemma plus_iter_xO : (x:positive)(plus_iter x x)=(xO x).
-Proof.
-Intro; Rewrite <- add_x_x; Apply plus_iter_add.
-Qed.
-
-Lemma plus_iter_xI : (x:positive)(add_un (plus_iter x x))=(xI x).
-Proof.
-Intro; Rewrite xI_add_un_xO; Rewrite <- add_x_x; 
-  Apply (f_equal positive); Apply plus_iter_add.
-Qed.
-
-Lemma iterate_add : (P:(positive->Type))
-  ((n:positive)(P n) ->(P (add_un n)))->(p,n:positive)(P n) ->
-  (P (plus_iter p n)).
-Proof.
-Intros P H; NewInduction p; Simpl; Intros.
-Apply IHp; Apply IHp; Apply H; Assumption.
-Apply IHp; Apply IHp; Assumption.
-Apply H; Assumption.
-Defined.
-
-(** Peano induction *)
-
-Theorem Pind : (P:(positive->Prop))
-  (P xH) ->((n:positive)(P n) ->(P (add_un n))) ->(n:positive)(P n).
-Proof.
-Intros P H1 Hsucc n; NewInduction n.
-Rewrite <- plus_iter_xI; Apply Hsucc; Apply iterate_add; Assumption.
-Rewrite <- plus_iter_xO; Apply iterate_add; Assumption.
-Assumption.
-Qed.
-
-(** Peano recursion *)
-
-Definition Prec : (A:Set)A->(positive->A->A)->positive->A :=
-  [A;a;f]Fix Prec { Prec [p:positive] : A :=
-  Cases p of
-  | xH => a
-  | (xO p) => (iterate_add [_]A f p p (Prec p))
-  | (xI p) => (f (plus_iter p p) (iterate_add [_]A f p p (Prec p)))
-  end}.
-
-(** Peano case analysis *)
-
-Theorem Pcase : (P:(positive->Prop))
-  (P xH) ->((n:positive)(P (add_un n))) ->(n:positive)(P n).
-Proof.
-Intros; Apply Pind; Auto.
-Qed.
-
-Check
- let fact = (Prec positive xH [p;r](times (add_un p) r)) in
- let seven = (xI (xI xH)) in
- let five_thousand_forty= (xO(xO(xO(xO(xI(xI(xO(xI(xI(xI(xO(xO xH))))))))))))
- in ((refl_equal ? ?) :: (fact seven) = five_thousand_forty).
-
-(**********************************************************************)
-(** Properties of multiplication on binary positive numbers *)
-
-(** One is right neutral for multiplication *)
-
-Lemma times_x_1 : (x:positive) (times x xH) = x.
-Proof.
-Intro x;NewInduction x; Simpl.
-  Rewrite IHx; Reflexivity.
-  Rewrite IHx; Reflexivity.
-  Reflexivity.
-Qed.
-
-(** Right reduction properties for multiplication *)
-
-Lemma times_x_double : (x,y:positive) (times x (xO y)) = (xO (times x y)).
-Proof.
-Intros x y; NewInduction x; Simpl.
-  Rewrite IHx; Reflexivity.
-  Rewrite IHx; Reflexivity.
-  Reflexivity.
-Qed.
-
-Lemma times_x_double_plus_one :
- (x,y:positive) (times x (xI y)) = (add x (xO (times x y))).
-Proof.
-Intros x y; NewInduction x; Simpl.
-  Rewrite IHx; Do 2 Rewrite add_assoc; Rewrite add_sym with x:=y; Reflexivity.
-  Rewrite IHx; Reflexivity.
-  Reflexivity.
-Qed.
-
-(** Commutativity of multiplication *)
-
-Theorem times_sym : (x,y:positive) (times x y) = (times y x).
-Proof.
-Intros x y; NewInduction y; Simpl.
-  Rewrite <- IHy; Apply times_x_double_plus_one.
-  Rewrite <- IHy; Apply times_x_double.
-  Apply times_x_1.
-Qed.
-
-(** Distributivity of multiplication over addition *)
-
-Theorem times_add_distr:
-  (x,y,z:positive) (times x (add y z)) = (add (times x y) (times x z)).
-Proof.
-Intros x y z; NewInduction x; Simpl.
-  Rewrite IHx; Rewrite <- add_assoc with y := (xO (times x y));
-    Rewrite -> add_assoc with x := (xO (times x y));
-    Rewrite -> add_sym with x := (xO (times x y));
-    Rewrite <- add_assoc with y := (xO (times x y));
-    Rewrite -> add_assoc with y := z; Reflexivity.
-  Rewrite IHx; Reflexivity.
-  Reflexivity.
-Qed.
-
-Theorem times_add_distr_l:
-  (x,y,z:positive) (times (add x y) z) = (add (times x z) (times y z)).
-Proof.
-Intros x y z; Do 3 Rewrite times_sym with y:=z; Apply times_add_distr.
-Qed.
-
-(** Associativity of multiplication *)
-
-Theorem times_assoc :
-  ((x,y,z:positive) (times x (times y z))= (times (times x y) z)).
-Proof.
-Intro x;NewInduction x as [x|x|]; Simpl; Intros y z.
-  Rewrite IHx; Rewrite times_add_distr_l; Reflexivity.
-  Rewrite IHx; Reflexivity.
-  Reflexivity.
-Qed.
-
-(** Parity properties of multiplication *)
-
-Lemma times_discr_xO_xI : 
-  (x,y,z:positive)(times (xI x) z)<>(times (xO y) z).
-Proof.
-Intros x y z; NewInduction z as [|z IHz|]; Try Discriminate.
-Intro H; Apply IHz; Clear IHz.
-Do 2 Rewrite times_x_double in H.
-Injection H; Clear H; Intro H; Exact H.
-Qed.
-
-Lemma times_discr_xO : (x,y:positive)(times (xO x) y)<>y.
-Proof.
-Intros x y; NewInduction y; Try Discriminate.
-Rewrite times_x_double; Injection; Assumption.
-Qed.
-
-(** Simplification properties of multiplication *)
-
-Theorem simpl_times_r : (x,y,z:positive) (times x z)=(times y z) -> x=y.
-Proof.
-Intro x;NewInduction x as [p IHp|p IHp|]; Intro y; NewDestruct y as [q|q|]; Intros z H;
-    Reflexivity Orelse Apply (f_equal positive) Orelse Apply False_ind.
-  Simpl in H; Apply IHp with (xO z); Simpl; Do 2 Rewrite times_x_double;
-    Apply simpl_add_l with 1 := H.
-  Apply times_discr_xO_xI with 1 := H.
-  Simpl in H; Rewrite add_sym in H; Apply add_no_neutral with 1 := H.
-  Symmetry in H; Apply times_discr_xO_xI with 1 := H.
-  Apply IHp with (xO z); Simpl; Do 2 Rewrite times_x_double; Assumption.
-  Apply times_discr_xO with 1:=H.
-  Simpl in H; Symmetry in H; Rewrite add_sym in H; 
-    Apply add_no_neutral with 1 := H.
-  Symmetry in H; Apply times_discr_xO with 1:=H.
-Qed.
-
-Theorem simpl_times_l : (x,y,z:positive) (times z x)=(times z y) -> x=y.
-Proof.
-Intros x y z H; Apply simpl_times_r with z:=z.
-Rewrite times_sym with x:=x; Rewrite times_sym with x:=y; Assumption.
-Qed.
-
-(** Inversion of multiplication *)
-
-Lemma times_one_inversion_l : (x,y:positive) (times x y)=xH -> x=xH.
-Proof.
-Intros x y; NewDestruct x; Simpl.
- NewDestruct y; Intro; Discriminate.
- Intro; Discriminate.
- Reflexivity.
-Qed.
-
-(**********************************************************************)
-(** Properties of comparison on binary positive numbers *)
-
-Theorem compare_convert1 : 
- (x,y:positive) 
-  ~(compare x y SUPERIEUR) = EGAL /\ ~(compare x y INFERIEUR) = EGAL.
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|]; Intro y; NewDestruct y as [q|q|];
-  Split;Simpl;Auto;
-  Discriminate Orelse (Elim (IHp q); Auto).
-Qed.
-
-Theorem compare_convert_EGAL : (x,y:positive) (compare x y EGAL) = EGAL -> x=y.
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|]; 
-  Intro y; NewDestruct y as [q|q|];Simpl;Auto; Intro H; [
-  Rewrite (IHp q); Trivial
-| Absurd (compare p q SUPERIEUR)=EGAL ;
-   [ Elim (compare_convert1 p q);Auto | Assumption ]
-| Discriminate H
-| Absurd (compare p q INFERIEUR) = EGAL; 
-    [ Elim (compare_convert1 p q);Auto | Assumption ]
-| Rewrite (IHp q);Auto 
-| Discriminate H
-| Discriminate H
-| Discriminate H ].
-Qed.
-
-Lemma ZLSI:
- (x,y:positive) (compare x y SUPERIEUR) = INFERIEUR -> 
-                (compare x y EGAL) = INFERIEUR.
-Proof.
-Intro x; Induction x;Intro y; Induction y;Simpl;Auto; 
-  Discriminate Orelse Intros H;Discriminate H.
-Qed.
-
-Lemma ZLIS:
- (x,y:positive) (compare x y INFERIEUR) = SUPERIEUR -> 
-                (compare x y EGAL) = SUPERIEUR.
-Proof.
-Intro x; Induction x;Intro y; Induction y;Simpl;Auto; 
-  Discriminate Orelse Intros H;Discriminate H.
-Qed.
-
-Lemma ZLII:
- (x,y:positive) (compare x y INFERIEUR) = INFERIEUR ->
-                (compare x y EGAL) = INFERIEUR \/ x = y.
-Proof.
-(Intro x; NewInduction x as [p IHp|p IHp|];
- Intro y; NewDestruct y as [q|q|];Simpl;Auto;Try Discriminate);
- Intro H2; Elim (IHp q H2);Auto; Intros E;Rewrite E;
- Auto.
-Qed.
-
-Lemma ZLSS:
- (x,y:positive) (compare x y SUPERIEUR) = SUPERIEUR ->
-                (compare x y EGAL) = SUPERIEUR \/ x = y.
-Proof.
-(Intro x; NewInduction x as [p IHp|p IHp|];
- Intro y; NewDestruct y as [q|q|];Simpl;Auto;Try Discriminate);
- Intro H2; Elim (IHp q H2);Auto; Intros E;Rewrite E;
- Auto.
-Qed.
-
-Lemma Dcompare : (r:relation) r=EGAL \/ r = INFERIEUR \/ r = SUPERIEUR.
-Proof.
-Induction r; Auto. 
-Qed.
-
-Tactic Definition ElimPcompare c1 c2:=
-  Elim (Dcompare (compare c1 c2 EGAL)); [ Idtac | 
-     Let x = FreshId "H" In Intro x; Case x; Clear x ].
-
-Theorem convert_compare_EGAL: (x:positive)(compare x x EGAL)=EGAL.
-Intro x; Induction x; Auto.
-Qed.
-
-Lemma Pcompare_antisym :
-  (x,y:positive)(r:relation) (Op (compare x y r)) = (compare y x (Op r)).
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|]; Intro y; NewDestruct y; 
-Intro r; Reflexivity Orelse (Symmetry; Assumption) Orelse Discriminate H
-Orelse Simpl; Apply IHp Orelse Try Rewrite IHp; Try Reflexivity.
-Qed.
-
-Lemma ZC1:
-  (x,y:positive)(compare x y EGAL)=SUPERIEUR -> (compare y x EGAL)=INFERIEUR.
-Proof.
-Intros; Change EGAL with (Op EGAL).
-Rewrite <- Pcompare_antisym; Rewrite H; Reflexivity.
-Qed.
-
-Lemma ZC2:
-  (x,y:positive)(compare x y EGAL)=INFERIEUR -> (compare y x EGAL)=SUPERIEUR.
-Proof.
-Intros; Change EGAL with (Op EGAL).
-Rewrite <- Pcompare_antisym; Rewrite H; Reflexivity.
-Qed.
-
-Lemma ZC3: (x,y:positive)(compare x y EGAL)=EGAL -> (compare y x EGAL)=EGAL.
-Proof.
-Intros; Change EGAL with (Op EGAL).
-Rewrite <- Pcompare_antisym; Rewrite H; Reflexivity.
-Qed.
-
-Lemma ZC4: (x,y:positive) (compare x y EGAL) = (Op (compare y x EGAL)).
-Proof.
-Intros; Change 1 EGAL with (Op EGAL).
-Symmetry; Apply Pcompare_antisym.
-Qed.
-
-(**********************************************************************)
-(** Properties of subtraction on binary positive numbers *)
-
-Lemma ZS: (p:positive_mask) (Zero_suivi_de_mask p) = IsNul -> p = IsNul.
-Proof.
-NewDestruct p; Simpl; [ Trivial | Discriminate 1 | Discriminate 1 ].
-Qed.
-
-Lemma US: (p:positive_mask) ~(Un_suivi_de_mask p)=IsNul.
-Proof.
-Induction p; Intros; Discriminate.
-Qed.
-
-Lemma USH: (p:positive_mask) (Un_suivi_de_mask p) = (IsPos xH) -> p = IsNul.
-Proof.
-NewDestruct p; Simpl; [ Trivial | Discriminate 1 | Discriminate 1 ].
-Qed.
-
-Lemma ZSH: (p:positive_mask) ~(Zero_suivi_de_mask p)= (IsPos xH).
-Proof.
-Induction p; Intros; Discriminate.
-Qed.
-
-Theorem sub_pos_x_x : (x:positive) (sub_pos x x) = IsNul.
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|]; [
-  Simpl; Rewrite IHp;Simpl; Trivial
-| Simpl; Rewrite IHp;Auto
-| Auto ].
-Qed.
-
-Lemma ZL10: (x,y:positive)
- (sub_pos x y) = (IsPos xH) -> (sub_neg x y) = IsNul.
-Proof.
-Intro x; NewInduction x as [p|p|]; Intro y; NewDestruct y as [q|q|]; Simpl; 
-  Intro H; Try Discriminate H; [
-  Absurd (Zero_suivi_de_mask (sub_pos p q))=(IsPos xH);
-   [ Apply ZSH | Assumption ]
-| Assert Heq : (sub_pos p q)=IsNul;
-   [ Apply USH;Assumption | Rewrite Heq; Reflexivity ]
-| Assert Heq : (sub_neg p q)=IsNul;
-   [ Apply USH;Assumption | Rewrite Heq; Reflexivity ]
-| Absurd (Zero_suivi_de_mask (sub_pos p q))=(IsPos xH); 
-   [ Apply ZSH | Assumption ]
-| NewDestruct p; Simpl; [ Discriminate H | Discriminate H | Reflexivity ] ].
-Qed.
-
-(** Properties of subtraction valid only for x>y *)
-
-Lemma sub_pos_SUPERIEUR:
-  (x,y:positive)(compare x y EGAL)=SUPERIEUR -> 
-    (EX h:positive | (sub_pos x y) = (IsPos h) /\ (add y h) = x /\
-                     (h = xH \/ (sub_neg x y) = (IsPos (sub_un h)))).
-Proof.
-Intro x;NewInduction x as [p|p|];Intro y; NewDestruct y as [q|q|]; Simpl; Intro H;
-  Try Discriminate H.
-  NewDestruct (IHp q H) as [z [H4 [H6 H7]]]; Exists (xO z); Split.
-    Rewrite H4; Reflexivity.
-    Split.
-      Simpl; Rewrite H6; Reflexivity.
-      Right; Clear H6; NewDestruct (ZL11 z) as [H8|H8]; [
-        Rewrite H8; Rewrite H8 in H4;
-        Rewrite ZL10; [ Reflexivity | Assumption ]
-      | Clear H4; NewDestruct H7 as [H9|H9]; [
-          Absurd z=xH; Assumption
-        | Rewrite H9; Clear H9; NewDestruct z; 
-            [ Reflexivity | Reflexivity | Absurd xH=xH; Trivial ]]].
-  Case ZLSS with 1:=H; [
-    Intros H3;Elim (IHp q H3); Intros z H4; Exists (xI z);
-    Elim H4;Intros H5 H6;Elim H6;Intros H7 H8; Split; [
-      Simpl;Rewrite H5;Auto
-    | Split; [
-        Simpl; Rewrite H7; Trivial
-      | Right;
-        Change (Zero_suivi_de_mask (sub_pos p q))=(IsPos (sub_un (xI z)));
-        Rewrite H5; Auto ]]
-  | Intros H3; Exists xH; Rewrite H3; Split; [
-      Simpl; Rewrite sub_pos_x_x; Auto
-    | Split; Auto ]].
-  Exists (xO p); Auto.
-  NewDestruct (IHp q) as [z [H4 [H6 H7]]].
-    Apply ZLIS; Assumption.
-    NewDestruct (ZL11 z) as [vZ|]; [
-      Exists xH; Split; [
-        Rewrite ZL10; [ Reflexivity | Rewrite vZ in H4;Assumption ]
-      | Split; [
-          Simpl; Rewrite ZL12; Rewrite <- vZ; Rewrite H6; Trivial
-        | Auto ]]
-    | Exists (xI (sub_un z)); NewDestruct H7 as [|H8];[
-        Absurd z=xH;Assumption
-      | Split; [
-          Rewrite H8; Trivial
-        | Split; [ Simpl; Rewrite ZL15; [
-              Rewrite H6;Trivial
-            | Assumption ]
-          | Right; Rewrite H8; Reflexivity]]]].
-  NewDestruct (IHp q H) as [z [H4 [H6 H7]]].
-  Exists (xO z); Split; [
-    Rewrite H4;Auto
-  | Split; [
-      Simpl;Rewrite H6;Reflexivity
-    | Right; 
-      Change (Un_suivi_de_mask (sub_neg p q))=(IsPos (double_moins_un z));
-      NewDestruct (ZL11 z) as [H8|H8]; [
-        Rewrite H8; Simpl;
-        Assert H9:(sub_neg p q)=IsNul;[
-          Apply ZL10;Rewrite <- H8;Assumption
-        | Rewrite H9;Reflexivity ]
-      | NewDestruct H7 as [H9|H9]; [
-          Absurd z=xH;Auto
-        | Rewrite H9; NewDestruct z; Simpl; 
-            [ Reflexivity
-            | Reflexivity
-            | Absurd xH=xH; [Assumption | Reflexivity]]]]]].
-  Exists (double_moins_un p); Split; [
-    Reflexivity
-  | Clear IHp; Split; [
-      NewDestruct p; Simpl; [
-        Reflexivity
-      | Rewrite is_double_moins_un; Reflexivity
-      | Reflexivity ]
-    | NewDestruct p; [Right|Right|Left]; Reflexivity ]].
-Qed.
-
-Theorem sub_add: 
-(x,y:positive) (compare x y EGAL) = SUPERIEUR -> (add y (true_sub x y)) = x.
-Proof.
-Intros x y H;Elim sub_pos_SUPERIEUR with 1:=H;
-Intros z H1;Elim H1;Intros H2 H3; Elim H3;Intros H4 H5; 
-Unfold true_sub ;Rewrite H2; Exact H4.
-Qed.
-
diff --git a/theories7/NArith/Pnat.v b/theories7/NArith/Pnat.v
deleted file mode 100644
index d62661ed..00000000
--- a/theories7/NArith/Pnat.v
+++ /dev/null
@@ -1,472 +0,0 @@
-(************************************************************************)
-(*  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: Pnat.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ i*)
-
-Require BinPos.
-
-(**********************************************************************)
-(** Properties of the injection from binary positive numbers to Peano 
-    natural numbers *)
-
-(** Original development by Pierre Crégut, CNET, Lannion, France *)
-
-Require Le.
-Require Lt.
-Require Gt.
-Require Plus.
-Require Mult.
-Require Minus.
-
-(** [nat_of_P] is a morphism for addition *)
-
-Lemma convert_add_un :
-  (x:positive)(m:nat)
-    (positive_to_nat (add_un x) m) = (plus m (positive_to_nat x m)).
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|]; Simpl; Auto; Intro m; Rewrite IHp;
-Rewrite plus_assoc_l; Trivial.
-Qed.
-
-Lemma cvt_add_un :
-  (p:positive) (convert (add_un p)) = (S (convert p)).
-Proof.
-  Intro; Change (S (convert p)) with (plus (S O) (convert p));
-  Unfold convert; Apply convert_add_un.
-Qed.
-
-Theorem convert_add_carry :
-  (x,y:positive)(m:nat)
-    (positive_to_nat (add_carry x y) m) =
-    (plus m (positive_to_nat (add x y) m)).
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|];
-  Intro y; NewDestruct y; Simpl; Auto with arith; Intro m; [
-  Rewrite IHp; Rewrite plus_assoc_l; Trivial with arith
-| Rewrite IHp; Rewrite plus_assoc_l; Trivial with arith
-| Rewrite convert_add_un; Rewrite plus_assoc_l; Trivial with arith
-| Rewrite convert_add_un; Apply plus_assoc_r ].
-Qed.
-
-Theorem cvt_carry :
-  (x,y:positive)(convert (add_carry x y)) = (S (convert (add x y))).
-Proof.
-Intros;Unfold convert; Rewrite convert_add_carry; Simpl; Trivial with arith.
-Qed.
-
-Theorem add_verif :
-  (x,y:positive)(m:nat)
-    (positive_to_nat (add x y) m) = 
-    (plus (positive_to_nat x m) (positive_to_nat y m)).
-Proof.
-Intro x; NewInduction x as [p IHp|p IHp|];
-  Intro y; NewDestruct y;Simpl;Auto with arith; [
-  Intros m;Rewrite convert_add_carry; Rewrite IHp; 
-  Rewrite plus_assoc_r; Rewrite plus_assoc_r; 
-  Rewrite (plus_permute m (positive_to_nat p (plus m m))); Trivial with arith
-| Intros m; Rewrite IHp; Apply plus_assoc_l
-| Intros m; Rewrite convert_add_un; 
-  Rewrite (plus_sym (plus m (positive_to_nat p (plus m m))));
-  Apply plus_assoc_r
-| Intros m; Rewrite IHp; Apply plus_permute
-| Intros m; Rewrite convert_add_un; Apply plus_assoc_r ].
-Qed.
-
-Theorem convert_add:
-  (x,y:positive) (convert (add x y)) = (plus (convert x) (convert y)).
-Proof.
-Intros x y; Exact (add_verif x y (S O)).
-Qed.
-
-(** [Pmult_nat] is a morphism for addition *)
-
-Lemma ZL2:
-  (y:positive)(m:nat)
-    (positive_to_nat y (plus m m)) =
-              (plus (positive_to_nat y m) (positive_to_nat y m)).
-Proof.
-Intro y; NewInduction y as [p H|p H|]; Intro m; [
-  Simpl; Rewrite H; Rewrite plus_assoc_r; 
-  Rewrite (plus_permute m (positive_to_nat p (plus m m)));
-  Rewrite plus_assoc_r; Auto with arith
-| Simpl; Rewrite H; Auto with arith
-| Simpl; Trivial with arith ].
-Qed.
-
-Lemma ZL6:
-  (p:positive) (positive_to_nat p (S (S O))) = (plus (convert p) (convert p)).
-Proof.
-Intro p;Change (2) with (plus (S O) (S O)); Rewrite ZL2; Trivial.
-Qed.
- 
-(** [nat_of_P] is a morphism for multiplication *)
-
-Theorem times_convert :
-  (x,y:positive) (convert (times x y)) = (mult (convert x) (convert y)).
-Proof.
-Intros x y; NewInduction x as [ x' H | x' H | ]; [
-  Change (times (xI x') y) with (add y (xO (times x' y))); Rewrite convert_add;
-  Unfold 2 3 convert; Simpl; Do 2 Rewrite ZL6; Rewrite H;
-  Rewrite -> mult_plus_distr; Reflexivity
-| Unfold 1 2 convert; Simpl; Do 2 Rewrite ZL6;
-  Rewrite H; Rewrite mult_plus_distr; Reflexivity
-| Simpl; Rewrite <- plus_n_O; Reflexivity ].
-Qed.
-V7only [
-  Comments "Compatibility with the old version of times and times_convert".
-  Syntactic Definition times1 :=
-    [x:positive;_:positive->positive;y:positive](times x y).
-  Syntactic Definition times1_convert :=
-    [x,y:positive;_:positive->positive](times_convert x y).
-].
-
-(** [nat_of_P] maps to the strictly positive subset of [nat] *)
-
-Lemma ZL4: (y:positive) (EX h:nat |(convert y)=(S h)).
-Proof.
-Intro y; NewInduction y as [p H|p H|]; [
-  NewDestruct H as [x H1]; Exists (plus (S x) (S x));
-  Unfold convert ;Simpl; Change (2) with (plus (1) (1)); Rewrite ZL2; Unfold convert in H1;
-  Rewrite H1; Auto with arith
-| NewDestruct H as [x H2]; Exists (plus x (S x)); Unfold convert;
-  Simpl; Change (2) with (plus (1) (1)); Rewrite ZL2;Unfold convert in H2; Rewrite H2; Auto with arith
-| Exists O ;Auto with arith ].
-Qed.
-
-(** Extra lemmas on [lt] on Peano natural numbers *)
-
-Lemma ZL7:
-  (m,n:nat) (lt m n) -> (lt (plus m m) (plus n n)).
-Proof.
-Intros m n H; Apply lt_trans with m:=(plus m n); [
-  Apply lt_reg_l with 1:=H
-| Rewrite (plus_sym m n); Apply lt_reg_l with 1:=H ].
-Qed.
-
-Lemma ZL8:
-  (m,n:nat) (lt m n) -> (lt (S (plus m m)) (plus n n)).
-Proof.
-Intros m n H; Apply le_lt_trans with m:=(plus m n); [
-  Change (lt (plus m m) (plus m n)) ; Apply lt_reg_l with 1:=H
-| Rewrite (plus_sym m n); Apply lt_reg_l with 1:=H ].
-Qed.
-
-(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed
-    from [compare] on [positive])
-
-    Part 1: [lt] on [positive] is finer than [lt] on [nat]
-*)
-
-Lemma compare_convert_INFERIEUR : 
-  (x,y:positive) (compare x y EGAL) = INFERIEUR -> 
-    (lt (convert x) (convert y)).
-Proof.
-Intro x; NewInduction x as [p H|p H|];Intro y; NewDestruct y as [q|q|];
-  Intro H2; [
-  Unfold convert ;Simpl; Apply lt_n_S; 
-  Do 2 Rewrite ZL6; Apply ZL7; Apply H; Simpl in H2; Assumption
-| Unfold convert ;Simpl; Do 2 Rewrite ZL6; 
-  Apply ZL8; Apply H;Simpl in H2; Apply ZLSI;Assumption
-| Simpl; Discriminate H2
-| Simpl; Unfold convert ;Simpl;Do 2 Rewrite ZL6; 
-  Elim (ZLII p q H2); [
-    Intros H3;Apply lt_S;Apply ZL7; Apply H;Apply H3
-  | Intros E;Rewrite E;Apply lt_n_Sn]
-| Simpl; Unfold convert ;Simpl;Do 2 Rewrite ZL6; 
-  Apply ZL7;Apply H;Assumption
-| Simpl; Discriminate H2
-| Unfold convert ;Simpl; Apply lt_n_S; Rewrite ZL6;
-  Elim (ZL4 q);Intros h H3; Rewrite H3;Simpl; Apply lt_O_Sn
-| Unfold convert ;Simpl; Rewrite ZL6; Elim (ZL4 q);Intros h H3;
-  Rewrite H3; Simpl; Rewrite <- plus_n_Sm; Apply lt_n_S; Apply lt_O_Sn
-| Simpl; Discriminate H2 ].
-Qed.
-
-(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed
-    from [compare] on [positive])
-
-    Part 1: [gt] on [positive] is finer than [gt] on [nat]
-*)
-
-Lemma compare_convert_SUPERIEUR : 
-  (x,y:positive) (compare x y EGAL)=SUPERIEUR -> (gt (convert x) (convert y)).
-Proof.
-Unfold gt; Intro x; NewInduction x as [p H|p H|];
-  Intro y; NewDestruct y as [q|q|]; Intro H2; [
-  Simpl; Unfold convert ;Simpl;Do 2 Rewrite ZL6; 
-  Apply lt_n_S; Apply ZL7; Apply H;Assumption
-| Simpl; Unfold convert ;Simpl; Do 2 Rewrite ZL6;
-  Elim (ZLSS p q H2); [
-    Intros H3;Apply lt_S;Apply ZL7;Apply H;Assumption
-  | Intros E;Rewrite E;Apply lt_n_Sn]
-| Unfold convert ;Simpl; Rewrite ZL6;Elim (ZL4 p);
-  Intros h H3;Rewrite H3;Simpl; Apply lt_n_S; Apply lt_O_Sn
-| Simpl;Unfold convert ;Simpl;Do 2 Rewrite ZL6; 
-  Apply ZL8; Apply H; Apply ZLIS; Assumption
-| Simpl; Unfold convert ;Simpl;Do 2 Rewrite ZL6; 
-  Apply ZL7;Apply H;Assumption
-| Unfold convert ;Simpl; Rewrite ZL6; Elim (ZL4 p);
-  Intros h H3;Rewrite H3;Simpl; Rewrite <- plus_n_Sm;Apply lt_n_S;
-  Apply lt_O_Sn
-| Simpl; Discriminate H2
-| Simpl; Discriminate H2
-| Simpl; Discriminate H2 ].
-Qed.
-
-(** [nat_of_P] is a morphism from [positive] to [nat] for [lt] (expressed
-    from [compare] on [positive])
-
-    Part 2: [lt] on [nat] is finer than [lt] on [positive]
-*)
-
-Lemma convert_compare_INFERIEUR : 
-  (x,y:positive)(lt (convert x) (convert y)) -> (compare x y EGAL) = INFERIEUR.
-Proof.
-Intros x y; Unfold gt; Elim (Dcompare (compare x y EGAL)); [
-  Intros E; Rewrite (compare_convert_EGAL x y E); 
-  Intros H;Absurd (lt (convert y) (convert y)); [ Apply lt_n_n | Assumption ]
-| Intros H;Elim H; [
-    Auto
-  | Intros H1 H2; Absurd (lt (convert x) (convert y)); [
-      Apply lt_not_sym; Change (gt (convert x) (convert y)); 
-      Apply compare_convert_SUPERIEUR; Assumption
-    | Assumption ]]].
-Qed.
-
-(** [nat_of_P] is a morphism from [positive] to [nat] for [gt] (expressed
-    from [compare] on [positive])
-
-    Part 2: [gt] on [nat] is finer than [gt] on [positive]
-*)
-
-Lemma convert_compare_SUPERIEUR : 
-  (x,y:positive)(gt (convert x) (convert y)) -> (compare x y EGAL) = SUPERIEUR.
-Proof.
-Intros x y; Unfold gt; Elim (Dcompare (compare x y EGAL)); [
-  Intros E; Rewrite (compare_convert_EGAL x y E); 
-  Intros H;Absurd (lt (convert y) (convert y)); [ Apply lt_n_n | Assumption ]
-| Intros H;Elim H; [
-    Intros H1 H2; Absurd (lt (convert y) (convert x)); [
-      Apply lt_not_sym; Apply compare_convert_INFERIEUR; Assumption
-    | Assumption ]
-  | Auto]].
-Qed.
-
-(** [nat_of_P] is strictly positive *)
-
-Lemma compare_positive_to_nat_O : 
-	(p:positive)(m:nat)(le m (positive_to_nat p m)).
-NewInduction p; Simpl; Auto with arith.
-Intro m; Apply le_trans with (plus m m);  Auto with arith.
-Qed.
-
-Lemma compare_convert_O : (p:positive)(lt O (convert p)).
-Intro; Unfold convert; Apply lt_le_trans with (S O); Auto with arith.
-Apply compare_positive_to_nat_O.
-Qed.
-
-(** Pmult_nat permutes with multiplication *)
-
-Lemma positive_to_nat_mult : (p:positive) (n,m:nat)
-    (positive_to_nat p (mult m n))=(mult m (positive_to_nat p n)).
-Proof.
-  Induction p. Intros. Simpl. Rewrite mult_plus_distr_r. Rewrite <- (mult_plus_distr_r m n n).
-  Rewrite (H (plus n n) m). Reflexivity.
-  Intros. Simpl. Rewrite <- (mult_plus_distr_r m n n). Apply H.
-  Trivial.
-Qed.
-
-Lemma positive_to_nat_2 : (p:positive)
-    (positive_to_nat p (2))=(mult (2) (positive_to_nat p (1))).
-Proof.
-  Intros. Rewrite <- positive_to_nat_mult. Reflexivity.
-Qed.
-
-Lemma positive_to_nat_4 : (p:positive)
-    (positive_to_nat p (4))=(mult (2) (positive_to_nat p (2))).
-Proof.
-  Intros. Rewrite <- positive_to_nat_mult. Reflexivity.
-Qed.
-
-(** Mapping of xH, xO and xI through [nat_of_P] *)
-
-Lemma convert_xH : (convert xH)=(1).
-Proof.
-  Reflexivity.
-Qed.
-
-Lemma convert_xO : (p:positive) (convert (xO p))=(mult (2) (convert p)).
-Proof.
-  Induction p. Unfold convert. Simpl. Intros. Rewrite positive_to_nat_2.
-  Rewrite positive_to_nat_4. Rewrite H. Simpl. Rewrite <- plus_Snm_nSm. Reflexivity.
-  Unfold convert. Simpl. Intros. Rewrite positive_to_nat_2. Rewrite positive_to_nat_4.
-  Rewrite H. Reflexivity.
-  Reflexivity.
-Qed.
-
-Lemma convert_xI : (p:positive) (convert (xI p))=(S (mult (2) (convert p))).
-Proof.
-  Induction p. Unfold convert. Simpl. Intro p0. Intro. Rewrite positive_to_nat_2.
-  Rewrite positive_to_nat_4; Injection H; Intro H1; Rewrite H1; Rewrite <- plus_Snm_nSm; Reflexivity.
-  Unfold convert. Simpl. Intros. Rewrite positive_to_nat_2. Rewrite positive_to_nat_4.
-  Injection H; Intro H1; Rewrite H1; Reflexivity.
-  Reflexivity.
-Qed.
-
-(**********************************************************************)
-(** Properties of the shifted injection from Peano natural numbers to 
-    binary positive numbers *)
-
-(** Composition of [P_of_succ_nat] and [nat_of_P] is successor on [nat] *)
-
-Theorem bij1 : (m:nat) (convert (anti_convert m)) = (S m).
-Proof.
-Intro m; NewInduction m as [|n H]; [
-  Reflexivity
-| Simpl; Rewrite cvt_add_un; Rewrite H; Auto ].
-Qed.
-
-(** Miscellaneous lemmas on [P_of_succ_nat] *)
-
-Lemma ZL3: (x:nat) (add_un (anti_convert (plus x x))) =  (xO (anti_convert x)).
-Proof.
-Intro x; NewInduction x as [|n H]; [
-  Simpl; Auto with arith
-| Simpl; Rewrite  plus_sym; Simpl; Rewrite  H; Rewrite  ZL1;Auto with arith].
-Qed.
-
-Lemma ZL5: (x:nat) (anti_convert (plus (S x) (S x))) =  (xI (anti_convert x)).
-Proof.
-Intro x; NewInduction x as [|n H];Simpl; [
-  Auto with arith
-| Rewrite <- plus_n_Sm; Simpl; Simpl in H; Rewrite H; Auto with arith].
-Qed.
-
-(** Composition of [nat_of_P] and [P_of_succ_nat] is successor on [positive] *)
-
-Theorem bij2 : (x:positive) (anti_convert (convert x)) = (add_un x).
-Proof.
-Intro x; NewInduction x as [p H|p H|]; [
-  Simpl; Rewrite <- H; Change (2) with (plus (1) (1));
-  Rewrite ZL2; Elim (ZL4 p); 
-  Unfold convert; Intros n H1;Rewrite H1; Rewrite ZL3; Auto with arith
-| Unfold convert ;Simpl; Change (2) with (plus (1) (1));
-  Rewrite ZL2;
-  Rewrite <- (sub_add_one
-               (anti_convert
-                 (plus (positive_to_nat p (S O)) (positive_to_nat p (S O)))));
-  Rewrite <- (sub_add_one (xI p));
-  Simpl;Rewrite <- H;Elim (ZL4 p); Unfold convert ;Intros n H1;Rewrite H1;
-  Rewrite ZL5; Simpl; Trivial with arith
-| Unfold convert; Simpl; Auto with arith ].
-Qed.
-
-(** Composition of [nat_of_P], [P_of_succ_nat] and [Ppred] is identity
-    on [positive] *)
-
-Theorem bij3: (x:positive)(sub_un (anti_convert (convert x))) = x.
-Proof.
-Intros x; Rewrite bij2; Rewrite sub_add_one; Trivial with arith.
-Qed.
-
-(**********************************************************************)
-(** Extra properties of the injection from binary positive numbers to Peano 
-    natural numbers *)
-
-(** [nat_of_P] is a morphism for subtraction on positive numbers *)
-
-Theorem true_sub_convert:
-  (x,y:positive) (compare x y EGAL) = SUPERIEUR -> 
-     (convert (true_sub x y)) = (minus (convert x) (convert y)).
-Proof.
-Intros x y H; Apply plus_reg_l with (convert y);
-Rewrite le_plus_minus_r; [
-  Rewrite <- convert_add; Rewrite sub_add; Auto with arith
-| Apply lt_le_weak; Exact (compare_convert_SUPERIEUR x y H)].
-Qed.
-
-(** [nat_of_P] is injective *)
-
-Lemma convert_intro : (x,y:positive)(convert x)=(convert y) -> x=y.
-Proof.
-Intros x y H;Rewrite <- (bij3 x);Rewrite <- (bij3 y); Rewrite H; Trivial with arith.
-Qed.
-
-Lemma ZL16: (p,q:positive)(lt (minus (convert p) (convert q)) (convert p)).
-Proof.
-Intros p q; Elim (ZL4 p);Elim (ZL4 q); Intros h H1 i H2; 
-Rewrite H1;Rewrite H2; Simpl;Unfold lt; Apply le_n_S; Apply le_minus.
-Qed.
-
-Lemma ZL17: (p,q:positive)(lt (convert p) (convert (add p q))).
-Proof.
-Intros p q; Rewrite convert_add;Unfold lt;Elim (ZL4 q); Intros k H;Rewrite H;
-Rewrite plus_sym;Simpl; Apply le_n_S; Apply le_plus_r.
-Qed.
-
-(** Comparison and subtraction *)
-
-Lemma compare_true_sub_right :
-  (p,q,z:positive)
-  (compare q p EGAL)=INFERIEUR->
-  (compare z p EGAL)=SUPERIEUR->
-  (compare z q EGAL)=SUPERIEUR->
-  (compare (true_sub z p) (true_sub z q) EGAL)=INFERIEUR.
-Proof.
-Intros; Apply convert_compare_INFERIEUR; Rewrite true_sub_convert; [
-  Rewrite true_sub_convert; [
-    Apply simpl_lt_plus_l with p:=(convert q); Rewrite le_plus_minus_r; [
-      Rewrite plus_sym; Apply simpl_lt_plus_l with p:=(convert p);
-        Rewrite plus_assoc_l; Rewrite le_plus_minus_r; [
-          Rewrite (plus_sym (convert p)); Apply lt_reg_l;
-          Apply compare_convert_INFERIEUR; Assumption 
-        | Apply lt_le_weak; Apply compare_convert_INFERIEUR;
-          Apply ZC1; Assumption ]
-      | Apply lt_le_weak;Apply compare_convert_INFERIEUR;
-        Apply ZC1; Assumption ]
-    | Assumption ]
-  | Assumption ].
-Qed.
-
-Lemma compare_true_sub_left :
-  (p,q,z:positive)
-  (compare q p EGAL)=INFERIEUR->
-  (compare p z EGAL)=SUPERIEUR->
-  (compare q z EGAL)=SUPERIEUR->
-  (compare (true_sub q z) (true_sub p z) EGAL)=INFERIEUR.
-Proof.
-Intros p q z; Intros; 
-  Apply convert_compare_INFERIEUR; Rewrite true_sub_convert; [
-  Rewrite true_sub_convert; [
-    Unfold gt; Apply simpl_lt_plus_l with p:=(convert z);
-    Rewrite le_plus_minus_r; [
-      Rewrite le_plus_minus_r; [
-        Apply compare_convert_INFERIEUR;Assumption
-      | Apply lt_le_weak; Apply compare_convert_INFERIEUR;Apply ZC1;Assumption]
-    | Apply lt_le_weak; Apply compare_convert_INFERIEUR;Apply ZC1; Assumption]
-  | Assumption]
-| Assumption].
-Qed.
-
-(** Distributivity of multiplication over subtraction *)
-
-Theorem times_true_sub_distr:
-  (x,y,z:positive) (compare y z EGAL) = SUPERIEUR -> 
-      (times x (true_sub y z)) = (true_sub (times x y) (times x z)).
-Proof.
-Intros x y z H; Apply convert_intro;
-Rewrite times_convert; Rewrite true_sub_convert; [
-  Rewrite true_sub_convert; [
-    Do 2 Rewrite times_convert;
-    Do 3 Rewrite (mult_sym (convert x));Apply mult_minus_distr
-  | Apply convert_compare_SUPERIEUR; Do 2 Rewrite times_convert; 
-    Unfold gt; Elim (ZL4 x);Intros h H1;Rewrite H1; Apply lt_mult_left;
-    Exact (compare_convert_SUPERIEUR y z H) ]
-| Assumption ].
-Qed.
-
diff --git a/theories7/Reals/Alembert.v b/theories7/Reals/Alembert.v
deleted file mode 100644
index 702daffc..00000000
--- a/theories7/Reals/Alembert.v
+++ /dev/null
@@ -1,549 +0,0 @@
-(************************************************************************)
-(*  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: Alembert.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rseries.
-Require SeqProp.
-Require PartSum.
-Require Max.
-
-Open Local Scope R_scope.
-
-(***************************************************)
-(* Various versions of the criterion of D'Alembert *)
-(***************************************************)
-
-Lemma Alembert_C1 : (An:nat->R) ((n:nat)``0<(An n)``) -> (Un_cv [n:nat](Rabsolu ``(An (S n))/(An n)``) R0) -> (SigT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intros An H H0.
-Cut (sigTT R [l:R](is_lub (EUn [N:nat](sum_f_R0 An N)) l)) -> (SigT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intro; Apply X.
-Apply complet.
-Unfold Un_cv in H0; Unfold bound; Cut ``0</2``; [Intro | Apply Rlt_Rinv; Sup0].
-Elim (H0 ``/2`` H1); Intros.
-Exists ``(sum_f_R0 An x)+2*(An (S x))``.
-Unfold is_upper_bound; Intros; Unfold EUn in H3; Elim H3; Intros.
-Rewrite H4; Assert H5 := (lt_eq_lt_dec x1 x).
-Elim H5; Intros.
-Elim a; Intro.
-Replace (sum_f_R0 An x) with (Rplus (sum_f_R0 An x1) (sum_f_R0 [i:nat](An (plus (S x1) i)) (minus x (S x1)))).
-Pattern 1 (sum_f_R0 An x1); Rewrite <- Rplus_Or; Rewrite Rplus_assoc; Apply Rle_compatibility.
-Left; Apply gt0_plus_gt0_is_gt0.
-Apply tech1; Intros; Apply H.
-Apply Rmult_lt_pos; [Sup0 | Apply H].
-Symmetry; Apply tech2; Assumption.
-Rewrite b; Pattern 1 (sum_f_R0 An x); Rewrite <- Rplus_Or; Apply Rle_compatibility.
-Left; Apply Rmult_lt_pos; [Sup0 | Apply H].
-Replace (sum_f_R0 An x1) with (Rplus (sum_f_R0 An x) (sum_f_R0 [i:nat](An (plus (S x) i)) (minus x1 (S x)))).
-Apply Rle_compatibility.
-Cut (Rle (sum_f_R0 [i:nat](An (plus (S x) i)) (minus x1 (S x))) (Rmult (An (S x)) (sum_f_R0 [i:nat](pow ``/2`` i) (minus x1 (S x))))).
-Intro; Apply Rle_trans with (Rmult (An (S x)) (sum_f_R0 [i:nat](pow ``/2`` i) (minus x1 (S x)))).
-Assumption.
-Rewrite <- (Rmult_sym (An (S x))); Apply Rle_monotony.
-Left; Apply H.
-Rewrite tech3.
-Replace ``1-/2`` with ``/2``.
-Unfold Rdiv; Rewrite Rinv_Rinv.
-Pattern 3 ``2``; Rewrite <- Rmult_1r; Rewrite <- (Rmult_sym ``2``); Apply Rle_monotony.
-Left; Sup0.
-Left; Apply Rlt_anti_compatibility with ``(pow (/2) (S (minus x1 (S x))))``.
-Replace ``(pow (/2) (S (minus x1 (S x))))+(1-(pow (/2) (S (minus x1 (S x)))))`` with R1; [Idtac | Ring].
-Rewrite <- (Rplus_sym ``1``); Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rlt_compatibility.
-Apply pow_lt; Apply Rlt_Rinv; Sup0.
-DiscrR.
-Apply r_Rmult_mult with ``2``.
-Rewrite Rminus_distr; Rewrite <- Rinv_r_sym.
-Ring.
-DiscrR.
-DiscrR.
-Pattern 3 R1; Replace R1 with ``/1``; [Apply tech7; DiscrR | Apply Rinv_R1].
-Replace (An (S x)) with (An (plus (S x) O)).
-Apply (tech6 [i:nat](An (plus (S x) i)) ``/2``).
-Left; Apply Rlt_Rinv; Sup0.
-Intro; Cut (n:nat)(ge n x)->``(An (S n))</2*(An n)``.
-Intro; Replace (plus (S x) (S i)) with (S (plus (S x) i)).
-Apply H6; Unfold ge; Apply tech8.
-Apply INR_eq; Rewrite S_INR; Do 2 Rewrite plus_INR; Do 2 Rewrite S_INR; Ring.
-Intros; Unfold R_dist in H2; Apply Rlt_monotony_contra with ``/(An n)``.
-Apply Rlt_Rinv; Apply H.
-Do 2 Rewrite (Rmult_sym ``/(An n)``); Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Replace ``(An (S n))*/(An n)`` with ``(Rabsolu ((Rabsolu ((An (S n))/(An n)))-0))``.
-Apply H2; Assumption.
-Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_Rabsolu; Rewrite Rabsolu_right.
-Unfold Rdiv; Reflexivity.
-Left; Unfold Rdiv; Change ``0<(An (S n))*/(An n)``; Apply Rmult_lt_pos; [Apply H | Apply Rlt_Rinv; Apply H].
-Red; Intro; Assert H8 := (H n); Rewrite H7 in H8; Elim (Rlt_antirefl ? H8).
-Replace (plus (S x) O) with (S x); [Reflexivity | Ring].
-Symmetry; Apply tech2; Assumption.
-Exists (sum_f_R0 An O); Unfold EUn; Exists O; Reflexivity.
-Intro; Elim X; Intros.
-Apply Specif.existT with x; Apply tech10; [Unfold Un_growing; Intro; Rewrite tech5; Pattern 1 (sum_f_R0 An n); Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Apply H | Apply p].
-Qed.
-
-Lemma Alembert_C2 : (An:nat->R) ((n:nat)``(An n)<>0``) -> (Un_cv [n:nat](Rabsolu ``(An (S n))/(An n)``) R0) -> (SigT R  [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intros.
-Pose Vn := [i:nat]``(2*(Rabsolu (An i))+(An i))/2``.
-Pose Wn := [i:nat]``(2*(Rabsolu (An i))-(An i))/2``.
-Cut (n:nat)``0<(Vn n)``.
-Intro; Cut (n:nat)``0<(Wn n)``.
-Intro; Cut (Un_cv [n:nat](Rabsolu ``(Vn (S n))/(Vn n)``) ``0``).
-Intro; Cut (Un_cv [n:nat](Rabsolu ``(Wn (S n))/(Wn n)``) ``0``).
-Intro; Assert H5 := (Alembert_C1 Vn H1 H3).
-Assert H6 := (Alembert_C1 Wn H2 H4).
-Elim H5; Intros.
-Elim H6; Intros.
-Apply Specif.existT with ``x-x0``; Unfold Un_cv; Unfold Un_cv in p; Unfold Un_cv in p0; Intros; Cut ``0<eps/2``.
-Intro; Elim (p ``eps/2`` H8); Clear p; Intros.
-Elim (p0 ``eps/2`` H8); Clear p0; Intros.
-Pose N := (max x1 x2).
-Exists N; Intros; Replace (sum_f_R0 An n) with (Rminus (sum_f_R0 Vn n) (sum_f_R0 Wn n)).
-Unfold R_dist; Replace (Rminus (Rminus (sum_f_R0 Vn n) (sum_f_R0 Wn n)) (Rminus x x0)) with (Rplus (Rminus (sum_f_R0 Vn n) x) (Ropp (Rminus (sum_f_R0 Wn n) x0))); [Idtac | Ring]; Apply Rle_lt_trans with (Rplus (Rabsolu (Rminus (sum_f_R0 Vn n) x)) (Rabsolu (Ropp (Rminus (sum_f_R0 Wn n) x0)))).
-Apply Rabsolu_triang.
-Rewrite Rabsolu_Ropp; Apply Rlt_le_trans with ``eps/2+eps/2``.
-Apply Rplus_lt.
-Unfold R_dist in H9; Apply H9; Unfold ge; Apply le_trans with N; [Unfold N; Apply le_max_l | Assumption].
-Unfold R_dist in H10; Apply H10; Unfold ge; Apply le_trans with N; [Unfold N; Apply le_max_r | Assumption].
-Right; Symmetry; Apply double_var.
-Symmetry; Apply tech11; Intro; Unfold Vn Wn; Unfold Rdiv; Do 2 Rewrite <- (Rmult_sym ``/2``); Apply r_Rmult_mult with ``2``.
-Rewrite Rminus_distr; Repeat Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Ring.
-DiscrR.
-DiscrR.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Cut (n:nat)``/2*(Rabsolu (An n))<=(Wn n)<=(3*/2)*(Rabsolu (An n))``.
-Intro; Cut (n:nat)``/(Wn n)<=2*/(Rabsolu (An n))``.
-Intro; Cut (n:nat)``(Wn (S n))/(Wn n)<=3*(Rabsolu (An (S n))/(An n))``.
-Intro; Unfold Un_cv; Intros; Unfold Un_cv in H0; Cut ``0<eps/3``.
-Intro; Elim (H0 ``eps/3`` H8); Intros.
-Exists x; Intros.
-Assert H11 := (H9 n H10).
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_Rabsolu; Unfold R_dist in H11; Unfold Rminus in H11; Rewrite Ropp_O in H11; Rewrite Rplus_Or in H11; Rewrite Rabsolu_Rabsolu in H11; Rewrite Rabsolu_right.
-Apply Rle_lt_trans with ``3*(Rabsolu ((An (S n))/(An n)))``.
-Apply H6.
-Apply Rlt_monotony_contra with ``/3``.
-Apply Rlt_Rinv; Sup0.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR]; Rewrite Rmult_1l; Rewrite <- (Rmult_sym eps); Unfold Rdiv in H11; Exact H11.
-Left; Change ``0<(Wn (S n))/(Wn n)``; Unfold Rdiv; Apply Rmult_lt_pos.
-Apply H2.
-Apply Rlt_Rinv; Apply H2.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Intro; Unfold Rdiv; Rewrite Rabsolu_mult; Rewrite <- Rmult_assoc; Replace ``3`` with ``2*(3*/2)``; [Idtac | Rewrite <- Rmult_assoc; Apply Rinv_r_simpl_m; DiscrR]; Apply Rle_trans with ``(Wn (S n))*2*/(Rabsolu (An n))``.
-Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply H2.
-Apply H5.
-Rewrite Rabsolu_Rinv.
-Replace ``(Wn (S n))*2*/(Rabsolu (An n))`` with ``(2*/(Rabsolu (An n)))*(Wn (S n))``; [Idtac | Ring]; Replace ``2*(3*/2)*(Rabsolu (An (S n)))*/(Rabsolu (An n))`` with ``(2*/(Rabsolu (An n)))*((3*/2)*(Rabsolu (An (S n))))``; [Idtac | Ring]; Apply Rle_monotony.
-Left; Apply Rmult_lt_pos.
-Sup0.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Apply H.
-Elim (H4 (S n)); Intros; Assumption.
-Apply H.
-Intro; Apply Rle_monotony_contra with (Wn n).
-Apply H2.
-Rewrite <- Rinv_r_sym.
-Apply Rle_monotony_contra with (Rabsolu (An n)).
-Apply Rabsolu_pos_lt; Apply H.
-Rewrite Rmult_1r; Replace ``(Rabsolu (An n))*((Wn n)*(2*/(Rabsolu (An n))))`` with ``2*(Wn n)*((Rabsolu (An n))*/(Rabsolu (An n)))``; [Idtac | Ring]; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Apply Rle_monotony_contra with ``/2``.
-Apply Rlt_Rinv; Sup0.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Elim (H4 n); Intros; Assumption.
-DiscrR.
-Apply Rabsolu_no_R0; Apply H.
-Red; Intro; Assert H6 := (H2 n); Rewrite H5 in H6; Elim (Rlt_antirefl ? H6).
-Intro; Split.
-Unfold Wn; Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Sup0.
-Pattern 1 (Rabsolu (An n)); Rewrite <- Rplus_Or; Rewrite double; Unfold Rminus; Rewrite Rplus_assoc; Apply Rle_compatibility.
-Apply Rle_anti_compatibility with (An n).
-Rewrite Rplus_Or; Rewrite (Rplus_sym (An n)); Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Apply Rle_Rabsolu.
-Unfold Wn; Unfold Rdiv; Repeat Rewrite <- (Rmult_sym ``/2``); Repeat Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Sup0.
-Unfold Rminus; Rewrite double; Replace ``3*(Rabsolu (An n))`` with ``(Rabsolu (An n))+(Rabsolu (An n))+(Rabsolu (An n))``; [Idtac | Ring]; Repeat Rewrite Rplus_assoc; Repeat Apply Rle_compatibility.
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Cut (n:nat)``/2*(Rabsolu (An n))<=(Vn n)<=(3*/2)*(Rabsolu (An n))``.
-Intro; Cut (n:nat)``/(Vn n)<=2*/(Rabsolu (An n))``.
-Intro; Cut (n:nat)``(Vn (S n))/(Vn n)<=3*(Rabsolu (An (S n))/(An n))``.
-Intro; Unfold Un_cv; Intros; Unfold Un_cv in H1; Cut ``0<eps/3``.
-Intro; Elim (H0 ``eps/3`` H7); Intros.
-Exists x; Intros.
-Assert H10 := (H8 n H9).
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_Rabsolu; Unfold R_dist in H10; Unfold Rminus in H10; Rewrite Ropp_O in H10; Rewrite Rplus_Or in H10; Rewrite Rabsolu_Rabsolu in H10; Rewrite Rabsolu_right.
-Apply Rle_lt_trans with ``3*(Rabsolu ((An (S n))/(An n)))``.
-Apply H5.
-Apply Rlt_monotony_contra with ``/3``.
-Apply Rlt_Rinv; Sup0.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR]; Rewrite Rmult_1l; Rewrite <- (Rmult_sym eps); Unfold Rdiv in H10; Exact H10.
-Left; Change ``0<(Vn (S n))/(Vn n)``; Unfold Rdiv; Apply Rmult_lt_pos.
-Apply H1.
-Apply Rlt_Rinv; Apply H1.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Intro; Unfold Rdiv; Rewrite Rabsolu_mult; Rewrite <- Rmult_assoc; Replace ``3`` with ``2*(3*/2)``; [Idtac | Rewrite <- Rmult_assoc; Apply Rinv_r_simpl_m; DiscrR]; Apply Rle_trans with ``(Vn (S n))*2*/(Rabsolu (An n))``.
-Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply H1.
-Apply H4.
-Rewrite Rabsolu_Rinv.
-Replace ``(Vn (S n))*2*/(Rabsolu (An n))`` with ``(2*/(Rabsolu (An n)))*(Vn (S n))``; [Idtac | Ring]; Replace ``2*(3*/2)*(Rabsolu (An (S n)))*/(Rabsolu (An n))`` with ``(2*/(Rabsolu (An n)))*((3*/2)*(Rabsolu (An (S n))))``; [Idtac | Ring]; Apply Rle_monotony.
-Left; Apply Rmult_lt_pos.
-Sup0.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Apply H.
-Elim (H3 (S n)); Intros; Assumption.
-Apply H.
-Intro; Apply Rle_monotony_contra with (Vn n).
-Apply H1.
-Rewrite <- Rinv_r_sym.
-Apply Rle_monotony_contra with (Rabsolu (An n)).
-Apply Rabsolu_pos_lt; Apply H.
-Rewrite Rmult_1r; Replace ``(Rabsolu (An n))*((Vn n)*(2*/(Rabsolu (An n))))`` with ``2*(Vn n)*((Rabsolu (An n))*/(Rabsolu (An n)))``; [Idtac | Ring]; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Apply Rle_monotony_contra with ``/2``.
-Apply Rlt_Rinv; Sup0.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Elim (H3 n); Intros; Assumption.
-DiscrR.
-Apply Rabsolu_no_R0; Apply H.
-Red; Intro; Assert H5 := (H1 n); Rewrite H4 in H5; Elim (Rlt_antirefl ? H5).
-Intro; Split.
-Unfold Vn; Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Sup0.
-Pattern 1 (Rabsolu (An n)); Rewrite <- Rplus_Or; Rewrite double; Rewrite Rplus_assoc; Apply Rle_compatibility.
-Apply Rle_anti_compatibility with ``-(An n)``; Rewrite Rplus_Or; Rewrite <- (Rplus_sym (An n)); Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Unfold Vn; Unfold Rdiv; Repeat Rewrite <- (Rmult_sym ``/2``); Repeat Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Sup0.
-Unfold Rminus; Rewrite double; Replace ``3*(Rabsolu (An n))`` with ``(Rabsolu (An n))+(Rabsolu (An n))+(Rabsolu (An n))``; [Idtac | Ring]; Repeat Rewrite Rplus_assoc; Repeat Apply Rle_compatibility; Apply Rle_Rabsolu.
-Intro; Unfold Wn; Unfold Rdiv; Rewrite <- (Rmult_Or ``/2``); Rewrite <- (Rmult_sym ``/2``); Apply Rlt_monotony.
-Apply Rlt_Rinv; Sup0.
-Apply Rlt_anti_compatibility with (An n); Rewrite Rplus_Or; Unfold Rminus; Rewrite (Rplus_sym (An n)); Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Apply Rle_lt_trans with (Rabsolu (An n)).
-Apply Rle_Rabsolu.
-Rewrite double; Pattern 1 (Rabsolu (An n)); Rewrite <- Rplus_Or; Apply Rlt_compatibility; Apply Rabsolu_pos_lt; Apply H.
-Intro; Unfold Vn; Unfold Rdiv; Rewrite <- (Rmult_Or ``/2``); Rewrite <- (Rmult_sym ``/2``); Apply Rlt_monotony.
-Apply Rlt_Rinv; Sup0.
-Apply Rlt_anti_compatibility with ``-(An n)``; Rewrite Rplus_Or; Unfold Rminus; Rewrite (Rplus_sym ``-(An n)``); Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Apply Rle_lt_trans with (Rabsolu (An n)).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Rewrite double; Pattern 1 (Rabsolu (An n)); Rewrite <- Rplus_Or; Apply Rlt_compatibility; Apply Rabsolu_pos_lt; Apply H.
-Qed.
-
-Lemma AlembertC3_step1 : (An:nat->R;x:R) ``x<>0`` -> ((n:nat)``(An n)<>0``) -> (Un_cv [n:nat](Rabsolu ``(An (S n))/(An n)``) ``0``) -> (SigT R [l:R](Pser An x l)).
-Intros; Pose Bn := [i:nat]``(An i)*(pow x i)``.
-Cut (n:nat)``(Bn n)<>0``.
-Intro; Cut (Un_cv [n:nat](Rabsolu ``(Bn (S n))/(Bn n)``) ``0``).
-Intro; Assert H4 := (Alembert_C2 Bn H2 H3).
-Elim H4; Intros.
-Apply Specif.existT with x0; Unfold Bn in p; Apply tech12; Assumption.
-Unfold Un_cv; Intros; Unfold Un_cv in H1; Cut ``0<eps/(Rabsolu x)``.
-Intro; Elim (H1 ``eps/(Rabsolu x)`` H4); Intros.
-Exists x0; Intros; Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_Rabsolu; Unfold Bn; Replace ``((An (S n))*(pow x (S n)))/((An n)*(pow x n))`` with ``(An (S n))/(An n)*x``.
-Rewrite Rabsolu_mult; Apply Rlt_monotony_contra with ``/(Rabsolu x)``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption.
-Rewrite <- (Rmult_sym (Rabsolu x)); Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Rewrite <- (Rmult_sym eps); Unfold Rdiv in H5; Replace ``(Rabsolu ((An (S n))/(An n)))`` with ``(R_dist (Rabsolu ((An (S n))*/(An n))) 0)``.
-Apply H5; Assumption.
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_Rabsolu; Unfold Rdiv; Reflexivity.
-Apply Rabsolu_no_R0; Assumption.
-Replace (S n) with (plus n (1)); [Idtac | Ring]; Rewrite pow_add; Unfold Rdiv; Rewrite Rinv_Rmult.
-Replace ``(An (plus n (S O)))*((pow x n)*(pow x (S O)))*(/(An n)*/(pow x n))`` with ``(An (plus n (S O)))*(pow x (S O))*/(An n)*((pow x n)*/(pow x n))``; [Idtac | Ring]; Rewrite <- Rinv_r_sym.
-Simpl; Ring.
-Apply pow_nonzero; Assumption.
-Apply H0.
-Apply pow_nonzero; Assumption.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption].
-Intro; Unfold Bn; Apply prod_neq_R0; [Apply H0 | Apply pow_nonzero; Assumption].
-Qed.
-
-Lemma AlembertC3_step2 : (An:nat->R;x:R) ``x==0`` -> (SigT R [l:R](Pser An x l)).
-Intros; Apply Specif.existT with (An O).
-Unfold Pser; Unfold infinit_sum; Intros; Exists O; Intros; Replace (sum_f_R0 [n0:nat]``(An n0)*(pow x n0)`` n) with (An O).
-Unfold R_dist; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Induction n.
-Simpl; Ring.
-Rewrite tech5; Rewrite Hrecn; [Rewrite H; Simpl; Ring | Unfold ge; Apply le_O_n].
-Qed.
-
-(* An useful criterion of convergence for power series *)
-Theorem Alembert_C3 : (An:nat->R;x:R) ((n:nat)``(An n)<>0``) -> (Un_cv [n:nat](Rabsolu ``(An (S n))/(An n)``) ``0``) -> (SigT R [l:R](Pser An x l)).
-Intros; Case (total_order_T x R0); Intro.
-Elim s; Intro.
-Cut ``x<>0``.
-Intro; Apply AlembertC3_step1; Assumption.
-Red; Intro; Rewrite H1 in a; Elim (Rlt_antirefl ? a).
-Apply AlembertC3_step2; Assumption.
-Cut ``x<>0``.
-Intro; Apply AlembertC3_step1; Assumption.
-Red; Intro; Rewrite H1 in r; Elim (Rlt_antirefl ? r).
-Qed.
-
-Lemma Alembert_C4 : (An:nat->R;k:R) ``0<=k<1`` -> ((n:nat)``0<(An n)``) -> (Un_cv [n:nat](Rabsolu ``(An (S n))/(An n)``) k) -> (SigT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intros An k Hyp H H0.
-Cut (sigTT R [l:R](is_lub (EUn [N:nat](sum_f_R0 An N)) l)) -> (SigT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intro; Apply X.
-Apply complet.
-Assert H1 := (tech13 ? ? Hyp H0).
-Elim H1; Intros.
-Elim H2; Intros.
-Elim H4; Intros.
-Unfold bound; Exists ``(sum_f_R0 An x0)+/(1-x)*(An (S x0))``.
-Unfold is_upper_bound; Intros; Unfold EUn in H6.
-Elim H6; Intros.
-Rewrite H7.
-Assert H8 := (lt_eq_lt_dec x2 x0).
-Elim H8; Intros.
-Elim a; Intro.
-Replace (sum_f_R0 An x0) with (Rplus (sum_f_R0 An x2) (sum_f_R0 [i:nat](An (plus (S x2) i)) (minus x0 (S x2)))).
-Pattern 1 (sum_f_R0 An x2); Rewrite <- Rplus_Or.
-Rewrite Rplus_assoc; Apply Rle_compatibility.
-Left; Apply gt0_plus_gt0_is_gt0.
-Apply tech1.
-Intros; Apply H.
-Apply Rmult_lt_pos.
-Apply Rlt_Rinv; Apply Rlt_anti_compatibility with x; Rewrite Rplus_Or; Replace ``x+(1-x)`` with R1; [Elim H3; Intros; Assumption | Ring].
-Apply H.
-Symmetry; Apply tech2; Assumption.
-Rewrite b; Pattern 1 (sum_f_R0 An x0); Rewrite <- Rplus_Or; Apply Rle_compatibility.
-Left; Apply Rmult_lt_pos.
-Apply Rlt_Rinv; Apply Rlt_anti_compatibility with x; Rewrite Rplus_Or; Replace ``x+(1-x)`` with R1; [Elim H3; Intros; Assumption | Ring].
-Apply H.
-Replace (sum_f_R0 An x2) with (Rplus (sum_f_R0 An x0) (sum_f_R0 [i:nat](An (plus (S x0) i)) (minus x2 (S x0)))).
-Apply Rle_compatibility.
-Cut (Rle (sum_f_R0 [i:nat](An (plus (S x0) i)) (minus x2 (S x0))) (Rmult (An (S x0)) (sum_f_R0 [i:nat](pow x i) (minus x2 (S x0))))).
-Intro; Apply Rle_trans with (Rmult (An (S x0)) (sum_f_R0 [i:nat](pow x i) (minus x2 (S x0)))).
-Assumption.
-Rewrite <- (Rmult_sym (An (S x0))); Apply Rle_monotony.
-Left; Apply H.
-Rewrite tech3.
-Unfold Rdiv; Apply Rle_monotony_contra with ``1-x``.
-Apply Rlt_anti_compatibility with x; Rewrite Rplus_Or.
-Replace ``x+(1-x)`` with R1; [Elim H3; Intros; Assumption | Ring].
-Do 2 Rewrite (Rmult_sym ``1-x``).
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Apply Rle_anti_compatibility with ``(pow x (S (minus x2 (S x0))))``.
-Replace ``(pow x (S (minus x2 (S x0))))+(1-(pow x (S (minus x2 (S x0)))))`` with R1; [Idtac | Ring].
-Rewrite <- (Rplus_sym R1); Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rle_compatibility.
-Left; Apply pow_lt.
-Apply Rle_lt_trans with k.
-Elim Hyp; Intros; Assumption.
-Elim H3; Intros; Assumption.
-Apply Rminus_eq_contra.
-Red; Intro.
-Elim H3; Intros.
-Rewrite H10 in H12; Elim (Rlt_antirefl ? H12).
-Red; Intro.
-Elim H3; Intros.
-Rewrite H10 in H12; Elim (Rlt_antirefl ? H12).
-Replace (An (S x0)) with (An (plus (S x0) O)).
-Apply (tech6 [i:nat](An (plus (S x0) i)) x).
-Left; Apply Rle_lt_trans with k.
-Elim Hyp; Intros; Assumption.
-Elim H3; Intros; Assumption.
-Intro.
-Cut (n:nat)(ge n x0)->``(An (S n))<x*(An n)``.
-Intro.
-Replace (plus (S x0) (S i)) with (S (plus (S x0) i)).
-Apply H9.
-Unfold ge.
-Apply tech8.
-  Apply INR_eq; Rewrite S_INR; Do 2 Rewrite plus_INR; Do 2 Rewrite S_INR; Ring.
-Intros.
-Apply Rlt_monotony_contra with ``/(An n)``.
-Apply Rlt_Rinv; Apply H.
-Do 2 Rewrite (Rmult_sym ``/(An n)``).
-Rewrite Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r.
-Replace ``(An (S n))*/(An n)`` with ``(Rabsolu ((An (S n))/(An n)))``.
-Apply H5; Assumption.
-Rewrite Rabsolu_right.
-Unfold Rdiv; Reflexivity.
-Left; Unfold Rdiv; Change ``0<(An (S n))*/(An n)``; Apply Rmult_lt_pos.
-Apply H.
-Apply Rlt_Rinv; Apply H.
-Red; Intro.
-Assert H11 := (H n).
-Rewrite H10 in H11; Elim (Rlt_antirefl ? H11).
-Replace (plus (S x0) O) with (S x0); [Reflexivity | Ring].
-Symmetry; Apply tech2; Assumption.
-Exists (sum_f_R0 An O); Unfold EUn; Exists O; Reflexivity.
-Intro; Elim X; Intros.
-Apply Specif.existT with x; Apply tech10; [Unfold Un_growing; Intro; Rewrite tech5; Pattern 1 (sum_f_R0 An n); Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Apply H | Apply p].
-Qed.
-
-Lemma Alembert_C5 : (An:nat->R;k:R) ``0<=k<1`` -> ((n:nat)``(An n)<>0``) -> (Un_cv [n:nat](Rabsolu ``(An (S n))/(An n)``) k) -> (SigT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intros.
-Cut (sigTT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)) -> (SigT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intro Hyp0; Apply Hyp0.
-Apply cv_cauchy_2.
-Apply cauchy_abs.
-Apply cv_cauchy_1.
-Cut (SigT R [l:R](Un_cv [N:nat](sum_f_R0 [i:nat](Rabsolu (An i)) N) l)) -> (sigTT R [l:R](Un_cv [N:nat](sum_f_R0 [i:nat](Rabsolu (An i)) N) l)).
-Intro Hyp; Apply Hyp.
-Apply (Alembert_C4 [i:nat](Rabsolu (An i)) k).
-Assumption.
-Intro; Apply Rabsolu_pos_lt; Apply H0.
-Unfold Un_cv.
-Unfold Un_cv in H1.
-Unfold Rdiv.
-Intros.
-Elim (H1 eps H2); Intros.
-Exists x; Intros.
-Rewrite <- Rabsolu_Rinv.
-Rewrite <- Rabsolu_mult.
-Rewrite Rabsolu_Rabsolu.
-Unfold Rdiv in H3; Apply H3; Assumption.
-Apply H0.
-Intro.
-Elim X; Intros.
-Apply existTT with x.
-Assumption.
-Intro.
-Elim X; Intros.
-Apply Specif.existT with x.
-Assumption.
-Qed.
-
-(* Convergence of power series in D(O,1/k) *)
-(*     k=0 is described in Alembert_C3     *)
-Lemma Alembert_C6 : (An:nat->R;x,k:R) ``0<k`` -> ((n:nat)``(An n)<>0``) -> (Un_cv [n:nat](Rabsolu ``(An (S n))/(An n)``) k) -> ``(Rabsolu x)</k`` -> (SigT R [l:R](Pser An x l)).
-Intros.
-Cut (SigT R [l:R](Un_cv [N:nat](sum_f_R0 [i:nat]``(An i)*(pow x i)`` N) l)).
-Intro.
-Elim X; Intros.
-Apply Specif.existT with x0.
-Apply tech12; Assumption.
-Case (total_order_T x R0); Intro.
-Elim s; Intro.
-EApply Alembert_C5 with ``k*(Rabsolu x)``.
-Split.
-Unfold Rdiv; Apply Rmult_le_pos.
-Left; Assumption.
-Left; Apply Rabsolu_pos_lt.
-Red; Intro; Rewrite H3 in a; Elim (Rlt_antirefl ? a).
-Apply Rlt_monotony_contra with ``/k``.
-Apply Rlt_Rinv; Assumption.
-Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Rewrite Rmult_1r; Assumption.
-Red; Intro; Rewrite H3 in H; Elim (Rlt_antirefl ? H).
-Intro; Apply prod_neq_R0.
-Apply H0.
-Apply pow_nonzero.
-Red; Intro; Rewrite H3 in a; Elim (Rlt_antirefl ? a).
-Unfold Un_cv; Unfold Un_cv in H1.
-Intros.
-Cut ``0<eps/(Rabsolu x)``.
-Intro.
-Elim (H1 ``eps/(Rabsolu x)`` H4); Intros.
-Exists x0.
-Intros.
-Replace ``((An (S n))*(pow x (S n)))/((An n)*(pow x n))`` with ``(An (S n))/(An n)*x``.
-Unfold R_dist.
-Rewrite Rabsolu_mult.
-Replace ``(Rabsolu ((An (S n))/(An n)))*(Rabsolu x)-k*(Rabsolu x)`` with ``(Rabsolu x)*((Rabsolu ((An (S n))/(An n)))-k)``; [Idtac | Ring].
-Rewrite Rabsolu_mult.
-Rewrite Rabsolu_Rabsolu.
-Apply Rlt_monotony_contra with ``/(Rabsolu x)``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt.
-Red; Intro; Rewrite H7 in a; Elim (Rlt_antirefl ? a).
-Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Rewrite <- (Rmult_sym eps).
-Unfold R_dist in H5.
-Unfold Rdiv; Unfold Rdiv in H5; Apply H5; Assumption.
-Apply Rabsolu_no_R0.
-Red; Intro; Rewrite H7 in a; Elim (Rlt_antirefl ? a).
-Unfold Rdiv; Replace (S n) with (plus n (1)); [Idtac | Ring].
-Rewrite pow_add.
-Simpl.
-Rewrite Rmult_1r.
-Rewrite Rinv_Rmult.
-Replace ``(An (plus n (S O)))*((pow x n)*x)*(/(An n)*/(pow x n))`` with ``(An (plus n (S O)))*/(An n)*x*((pow x n)*/(pow x n))``; [Idtac | Ring].
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Reflexivity.
-Apply pow_nonzero.
-Red; Intro; Rewrite H7 in a; Elim (Rlt_antirefl ? a).
-Apply H0.
-Apply pow_nonzero.
-Red; Intro; Rewrite H7 in a; Elim (Rlt_antirefl ? a).
-Unfold Rdiv; Apply Rmult_lt_pos.
-Assumption.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt.
-Red; Intro H7; Rewrite H7 in a; Elim (Rlt_antirefl ? a).
-Apply Specif.existT with (An O).
-Unfold Un_cv.
-Intros.
-Exists O.
-Intros.
-Unfold R_dist.
-Replace (sum_f_R0 [i:nat]``(An i)*(pow x i)`` n) with (An O).
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Induction n.
-Simpl; Ring.
-Rewrite tech5.
-Rewrite <- Hrecn.
-Rewrite b; Simpl; Ring.
-Unfold ge; Apply le_O_n.
-EApply Alembert_C5 with ``k*(Rabsolu x)``.
-Split.
-Unfold Rdiv; Apply Rmult_le_pos.
-Left; Assumption.
-Left; Apply Rabsolu_pos_lt.
-Red; Intro; Rewrite H3 in r; Elim (Rlt_antirefl ? r).
-Apply Rlt_monotony_contra with ``/k``.
-Apply Rlt_Rinv; Assumption.
-Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Rewrite Rmult_1r; Assumption.
-Red; Intro; Rewrite H3 in H; Elim (Rlt_antirefl ? H).
-Intro; Apply prod_neq_R0.
-Apply H0.
-Apply pow_nonzero.
-Red; Intro; Rewrite H3 in r; Elim (Rlt_antirefl ? r).
-Unfold Un_cv; Unfold Un_cv in H1.
-Intros.
-Cut ``0<eps/(Rabsolu x)``.
-Intro.
-Elim (H1 ``eps/(Rabsolu x)`` H4); Intros.
-Exists x0.
-Intros.
-Replace ``((An (S n))*(pow x (S n)))/((An n)*(pow x n))`` with ``(An (S n))/(An n)*x``.
-Unfold R_dist.
-Rewrite Rabsolu_mult.
-Replace ``(Rabsolu ((An (S n))/(An n)))*(Rabsolu x)-k*(Rabsolu x)`` with ``(Rabsolu x)*((Rabsolu ((An (S n))/(An n)))-k)``; [Idtac | Ring].
-Rewrite Rabsolu_mult.
-Rewrite Rabsolu_Rabsolu.
-Apply Rlt_monotony_contra with ``/(Rabsolu x)``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt.
-Red; Intro; Rewrite H7 in r; Elim (Rlt_antirefl ? r).
-Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Rewrite <- (Rmult_sym eps).
-Unfold R_dist in H5.
-Unfold Rdiv; Unfold Rdiv in H5; Apply H5; Assumption.
-Apply Rabsolu_no_R0.
-Red; Intro; Rewrite H7 in r; Elim (Rlt_antirefl ? r).
-Unfold Rdiv; Replace (S n) with (plus n (1)); [Idtac | Ring].
-Rewrite pow_add.
-Simpl.
-Rewrite Rmult_1r.
-Rewrite Rinv_Rmult.
-Replace ``(An (plus n (S O)))*((pow x n)*x)*(/(An n)*/(pow x n))`` with ``(An (plus n (S O)))*/(An n)*x*((pow x n)*/(pow x n))``; [Idtac | Ring].
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Reflexivity.
-Apply pow_nonzero.
-Red; Intro; Rewrite H7 in r; Elim (Rlt_antirefl ? r).
-Apply H0.
-Apply pow_nonzero.
-Red; Intro; Rewrite H7 in r; Elim (Rlt_antirefl ? r).
-Unfold Rdiv; Apply Rmult_lt_pos.
-Assumption.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt.
-Red; Intro H7; Rewrite H7 in r; Elim (Rlt_antirefl ? r).
-Qed.
diff --git a/theories7/Reals/AltSeries.v b/theories7/Reals/AltSeries.v
deleted file mode 100644
index af4b558a..00000000
--- a/theories7/Reals/AltSeries.v
+++ /dev/null
@@ -1,362 +0,0 @@
-(************************************************************************)
-(*  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: AltSeries.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rseries.
-Require SeqProp.
-Require PartSum.
-Require Max.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(**********)
-Definition tg_alt [Un:nat->R] : nat->R := [i:nat]``(pow (-1) i)*(Un i)``.
-Definition positivity_seq [Un:nat->R] : Prop := (n:nat)``0<=(Un n)``.
-
-Lemma CV_ALT_step0 : (Un:nat->R) (Un_decreasing Un) -> (Un_growing [N:nat](sum_f_R0 (tg_alt Un) (S (mult (2) N)))).
-Intros; Unfold Un_growing; Intro.
-Cut (mult (S (S O)) (S n)) = (S (S (mult (2) n))).
-Intro; Rewrite H0.
-Do 4 Rewrite tech5; Repeat Rewrite Rplus_assoc; Apply Rle_compatibility.
-Pattern 1 (tg_alt Un (S (mult (S (S O)) n))); Rewrite <- Rplus_Or.
-Apply Rle_compatibility.
-Unfold tg_alt; Rewrite <- H0; Rewrite pow_1_odd; Rewrite pow_1_even; Rewrite Rmult_1l.
-Apply Rle_anti_compatibility with ``(Un (S (mult (S (S O)) (S n))))``.
-Rewrite Rplus_Or; Replace ``(Un (S (mult (S (S O)) (S n))))+((Un (mult (S (S O)) (S n)))+ -1*(Un (S (mult (S (S O)) (S n)))))`` with ``(Un (mult (S (S O)) (S n)))``; [Idtac | Ring].
-Apply H.
-Cut (n:nat) (S n)=(plus n (1)); [Intro | Intro; Ring].
-Rewrite (H0 n); Rewrite (H0 (S (mult (2) n))); Rewrite (H0 (mult (2) n)); Ring.
-Qed.
-
-Lemma CV_ALT_step1 : (Un:nat->R) (Un_decreasing Un) -> (Un_decreasing [N:nat](sum_f_R0 (tg_alt Un) (mult (2) N))).
-Intros; Unfold Un_decreasing; Intro.
-Cut (mult (S (S O)) (S n)) = (S (S (mult (2) n))).
-Intro; Rewrite H0; Do 2 Rewrite tech5; Repeat Rewrite Rplus_assoc.
-Pattern 2 (sum_f_R0 (tg_alt Un) (mult (S (S O)) n)); Rewrite <- Rplus_Or.
-Apply Rle_compatibility.
-Unfold tg_alt; Rewrite <- H0; Rewrite pow_1_odd; Rewrite pow_1_even; Rewrite Rmult_1l.
-Apply Rle_anti_compatibility with ``(Un (S (mult (S (S O)) n)))``.
-Rewrite Rplus_Or; Replace ``(Un (S (mult (S (S O)) n)))+( -1*(Un (S (mult (S (S O)) n)))+(Un (mult (S (S O)) (S n))))`` with ``(Un (mult (S (S O)) (S n)))``; [Idtac | Ring].
-Rewrite H0; Apply H.
-Cut (n:nat) (S n)=(plus n (1)); [Intro | Intro; Ring].
-Rewrite (H0 n); Rewrite (H0 (S (mult (2) n))); Rewrite (H0 (mult (2) n)); Ring.
-Qed.
-
-(**********)
-Lemma CV_ALT_step2 : (Un:nat->R;N:nat) (Un_decreasing Un) -> (positivity_seq Un) -> (Rle (sum_f_R0 [i:nat](tg_alt Un (S i)) (S (mult (2) N))) R0). 
-Intros; Induction N.
-Simpl; Unfold tg_alt; Simpl; Rewrite Rmult_1r.
-Replace ``-1* -1*(Un (S (S O)))`` with (Un (S (S O))); [Idtac | Ring].
-Apply Rle_anti_compatibility with ``(Un (S O))``; Rewrite Rplus_Or.
-Replace ``(Un (S O))+ (-1*(Un (S O))+(Un (S (S O))))`` with (Un (S (S O))); [Apply H | Ring].
-Cut (S (mult (2) (S N))) = (S (S (S (mult (2) N)))).
-Intro; Rewrite H1; Do 2 Rewrite tech5.
-Apply Rle_trans with (sum_f_R0 [i:nat](tg_alt Un (S i)) (S (mult (S (S O)) N))).
-Pattern 2 (sum_f_R0 [i:nat](tg_alt Un (S i)) (S (mult (S (S O)) N))); Rewrite <- Rplus_Or.
-Rewrite Rplus_assoc; Apply Rle_compatibility.
-Unfold tg_alt; Rewrite <- H1.
-Rewrite pow_1_odd.
-Cut (S (S (mult (2) (S N)))) = (mult (2) (S (S N))).
-Intro; Rewrite H2; Rewrite pow_1_even; Rewrite Rmult_1l; Rewrite <- H2.
-Apply Rle_anti_compatibility with ``(Un (S (mult (S (S O)) (S N))))``.
-Rewrite Rplus_Or; Replace ``(Un (S (mult (S (S O)) (S N))))+( -1*(Un (S (mult (S (S O)) (S N))))+(Un (S (S (mult (S (S O)) (S N))))))`` with ``(Un (S (S (mult (S (S O)) (S N)))))``; [Idtac | Ring].
-Apply H.
-Apply INR_eq; Rewrite mult_INR; Repeat Rewrite S_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply HrecN.
-Apply INR_eq; Repeat Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Qed.
-
-(* A more general inequality *)
-Lemma CV_ALT_step3 : (Un:nat->R;N:nat) (Un_decreasing Un) -> (positivity_seq Un) -> (Rle (sum_f_R0 [i:nat](tg_alt Un (S i)) N) R0). 
-Intros; Induction N.
-Simpl; Unfold tg_alt; Simpl; Rewrite Rmult_1r.
-Apply Rle_anti_compatibility with (Un (S O)).
-Rewrite Rplus_Or; Replace ``(Un (S O))+ -1*(Un (S O))`` with R0; [Apply H0 | Ring].
-Assert H1 := (even_odd_cor N).
-Elim H1; Intros.
-Elim H2; Intro.
-Rewrite H3; Apply CV_ALT_step2; Assumption.
-Rewrite H3; Rewrite tech5.
-Apply Rle_trans with (sum_f_R0 [i:nat](tg_alt Un (S i)) (S (mult (S (S O)) x))).
-Pattern 2 (sum_f_R0 [i:nat](tg_alt Un (S i)) (S (mult (S (S O)) x))); Rewrite <- Rplus_Or.
-Apply Rle_compatibility.
-Unfold tg_alt; Simpl.
-Replace (plus x (plus x O)) with (mult (2) x); [Idtac | Ring].
-Rewrite pow_1_even.
-Replace `` -1*( -1*( -1*1))*(Un (S (S (S (mult (S (S O)) x)))))`` with ``-(Un (S (S (S (mult (S (S O)) x)))))``; [Idtac | Ring].
-Apply Rle_anti_compatibility with (Un (S (S (S (mult (S (S O)) x))))).
-Rewrite Rplus_Or; Rewrite Rplus_Ropp_r.
-Apply H0.
-Apply CV_ALT_step2; Assumption.
-Qed.
-
-(**********)
-Lemma CV_ALT_step4 : (Un:nat->R) (Un_decreasing Un) -> (positivity_seq Un) -> (has_ub [N:nat](sum_f_R0 (tg_alt Un) (S (mult (2) N)))).
-Intros; Unfold has_ub; Unfold bound.
-Exists ``(Un O)``.
-Unfold is_upper_bound; Intros; Elim H1; Intros.
-Rewrite H2; Rewrite decomp_sum.
-Replace (tg_alt Un O) with ``(Un O)``.
-Pattern 2 ``(Un O)``; Rewrite <- Rplus_Or.
-Apply Rle_compatibility.
-Apply CV_ALT_step3; Assumption.
-Unfold tg_alt; Simpl; Ring.
-Apply lt_O_Sn.
-Qed.
-
-(* This lemma gives an interesting result about alternated series *)
-Lemma CV_ALT : (Un:nat->R) (Un_decreasing Un) -> (positivity_seq Un) -> (Un_cv Un R0) -> (sigTT R [l:R](Un_cv [N:nat](sum_f_R0 (tg_alt Un) N) l)).
-Intros.
-Assert H2 := (CV_ALT_step0 ? H).
-Assert H3 := (CV_ALT_step4 ? H H0).
-Assert X := (growing_cv ? H2 H3).
-Elim X; Intros.
-Apply existTT with x.
-Unfold Un_cv; Unfold R_dist; Unfold Un_cv in H1; Unfold R_dist in H1; Unfold Un_cv in p; Unfold R_dist in p.
-Intros; Cut ``0<eps/2``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0]].
-Elim (H1 ``eps/2`` H5); Intros N2 H6.
-Elim (p ``eps/2`` H5); Intros N1 H7.
-Pose N := (max (S (mult (2) N1)) N2).
-Exists N; Intros.
-Assert H9 := (even_odd_cor n).
-Elim H9; Intros P H10.
-Cut (le N1 P).
-Intro; Elim H10; Intro.
-Replace ``(sum_f_R0 (tg_alt Un) n)-x`` with ``((sum_f_R0 (tg_alt Un) (S n))-x)+(-(tg_alt Un (S n)))``.
-Apply Rle_lt_trans with ``(Rabsolu ((sum_f_R0 (tg_alt Un) (S n))-x))+(Rabsolu (-(tg_alt Un (S n))))``.
-Apply Rabsolu_triang.
-Rewrite (double_var eps); Apply Rplus_lt.
-Rewrite H12; Apply H7; Assumption.
-Rewrite Rabsolu_Ropp; Unfold tg_alt; Rewrite Rabsolu_mult; Rewrite pow_1_abs; Rewrite Rmult_1l; Unfold Rminus in H6; Rewrite Ropp_O in H6; Rewrite <- (Rplus_Or (Un (S n))); Apply H6.
-Unfold ge; Apply le_trans with n.
-Apply le_trans with N; [Unfold N; Apply le_max_r | Assumption].
-Apply le_n_Sn.
-Rewrite tech5; Ring.
-Rewrite H12; Apply Rlt_trans with ``eps/2``.
-Apply H7; Assumption.
-Unfold Rdiv; Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Rewrite (Rmult_sym ``2``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Rewrite Rmult_1r | DiscrR].
-Rewrite RIneq.double.
-Pattern 1 eps; Rewrite <- (Rplus_Or eps); Apply Rlt_compatibility; Assumption.
-Elim H10; Intro; Apply le_double.
-Rewrite <- H11; Apply le_trans with N.
-Unfold N; Apply le_trans with (S (mult (2) N1)); [Apply le_n_Sn | Apply le_max_l].
-Assumption.
-Apply lt_n_Sm_le.
-Rewrite <- H11.
-Apply lt_le_trans with N.
-Unfold N; Apply lt_le_trans with (S (mult (2) N1)).
-Apply lt_n_Sn.
-Apply le_max_l.
-Assumption.
-Qed.
-
-(************************************************)
-(*        Convergence of alternated series      *)
-(*                                              *)
-(*         Applications: PI, cos, sin           *)
-(************************************************)
-Theorem alternated_series : (Un:nat->R) (Un_decreasing Un) -> (Un_cv Un R0) -> (sigTT R [l:R](Un_cv [N:nat](sum_f_R0 (tg_alt Un) N) l)).
-Intros; Apply CV_ALT.
-Assumption.
-Unfold positivity_seq; Apply decreasing_ineq; Assumption.
-Assumption.
-Qed.
-
-Theorem alternated_series_ineq : (Un:nat->R;l:R;N:nat) (Un_decreasing Un) -> (Un_cv Un R0) -> (Un_cv [N:nat](sum_f_R0 (tg_alt Un) N) l) -> ``(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) N)))<=l<=(sum_f_R0 (tg_alt Un) (mult (S (S O)) N))``.
-Intros.
-Cut (Un_cv [N:nat](sum_f_R0 (tg_alt Un) (mult (2) N)) l).
-Cut (Un_cv [N:nat](sum_f_R0 (tg_alt Un) (S (mult (2) N))) l).
-Intros; Split.
-Apply (growing_ineq [N:nat](sum_f_R0 (tg_alt Un) (S (mult (2) N)))).
-Apply CV_ALT_step0; Assumption.
-Assumption.
-Apply (decreasing_ineq [N:nat](sum_f_R0 (tg_alt Un) (mult (2) N))).
-Apply CV_ALT_step1; Assumption.
-Assumption.
-Unfold Un_cv; Unfold R_dist; Unfold Un_cv in H1; Unfold R_dist in H1; Intros. 
-Elim (H1 eps H2); Intros.
-Exists x; Intros.
-Apply H3.
-Unfold ge; Apply le_trans with (mult (2) n).
-Apply le_trans with n.
-Assumption.
-Assert H5 := (mult_O_le n (2)).
-Elim H5; Intro. 
-Cut ~(O)=(2); [Intro; Elim H7; Symmetry; Assumption | Discriminate].
-Assumption.
-Apply le_n_Sn.
-Unfold Un_cv; Unfold R_dist; Unfold Un_cv in H1; Unfold R_dist in H1; Intros. 
-Elim (H1 eps H2); Intros.
-Exists x; Intros.
-Apply H3.
-Unfold ge; Apply le_trans with n.
-Assumption.
-Assert H5 := (mult_O_le n (2)).
-Elim H5; Intro. 
-Cut ~(O)=(2); [Intro; Elim H7; Symmetry; Assumption | Discriminate].
-Assumption.
-Qed.
-
-(************************************)
-(* Application : construction of PI *)
-(************************************)
-
-Definition PI_tg := [n:nat]``/(INR (plus (mult (S (S O)) n) (S O)))``.
-
-Lemma PI_tg_pos : (n:nat)``0<=(PI_tg n)``.
-Intro; Unfold PI_tg; Left; Apply Rlt_Rinv; Apply lt_INR_0; Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Apply lt_O_Sn | Ring].
-Qed.
-
-Lemma PI_tg_decreasing : (Un_decreasing PI_tg).
-Unfold PI_tg Un_decreasing; Intro.
-Apply Rle_monotony_contra with ``(INR (plus (mult (S (S O)) n) (S O)))``.
-Apply lt_INR_0.
-Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Apply lt_O_Sn | Ring].
-Rewrite <- Rinv_r_sym.
-Apply Rle_monotony_contra with ``(INR (plus (mult (S (S O)) (S n)) (S O)))``.
-Apply lt_INR_0.
-Replace (plus (mult (2) (S n)) (1)) with (S (mult (2) (S n))); [Apply lt_O_Sn | Ring].
-Rewrite (Rmult_sym ``(INR (plus (mult (S (S O)) (S n)) (S O)))``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Do 2 Rewrite Rmult_1r; Apply le_INR.
-Replace (plus (mult (2) (S n)) (1)) with (S (S (plus (mult (2) n) (1)))).
-Apply le_trans with (S (plus (mult (2) n) (1))); Apply le_n_Sn.
-Apply INR_eq; Do 2  Rewrite S_INR; Do 2 Rewrite plus_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply not_O_INR; Discriminate.
-Apply not_O_INR; Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Discriminate | Ring].
-Qed.
-
-Lemma PI_tg_cv : (Un_cv PI_tg R0).
-Unfold Un_cv; Unfold R_dist; Intros.
-Cut ``0<2*eps``; [Intro | Apply Rmult_lt_pos; [Sup0 | Assumption]].
-Assert H1 := (archimed ``/(2*eps)``).
-Cut (Zle `0` ``(up (/(2*eps)))``).
-Intro; Assert H3 := (IZN ``(up (/(2*eps)))`` H2).
-Elim H3; Intros N H4.
-Cut (lt O N).
-Intro; Exists N; Intros.
-Cut (lt O n).
-Intro; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_right.
-Unfold PI_tg; Apply Rlt_trans with ``/(INR (mult (S (S O)) n))``.
-Apply Rlt_monotony_contra with ``(INR (mult (S (S O)) n))``.
-Apply lt_INR_0.
-Replace (mult (2) n) with (plus n n); [Idtac | Ring].
-Apply lt_le_trans with n.
-Assumption.
-Apply le_plus_l.
-Rewrite <- Rinv_r_sym.
-Apply Rlt_monotony_contra with ``(INR (plus (mult (S (S O)) n) (S O)))``.
-Apply lt_INR_0.
-Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Apply lt_O_Sn | Ring].
-Rewrite (Rmult_sym ``(INR (plus (mult (S (S O)) n) (S O)))``).
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Do 2 Rewrite Rmult_1r; Apply lt_INR.
-Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Apply lt_n_Sn | Ring].
-Apply not_O_INR; Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Discriminate | Ring].
-Replace n with (S (pred n)).
-Apply not_O_INR; Discriminate.
-Symmetry; Apply S_pred with O.
-Assumption.
-Apply Rle_lt_trans with ``/(INR (mult (S (S O)) N))``.
-Apply Rle_monotony_contra with ``(INR (mult (S (S O)) N))``.
-Rewrite mult_INR; Apply Rmult_lt_pos; [Simpl; Sup0 | Apply lt_INR_0; Assumption].
-Rewrite <- Rinv_r_sym.
-Apply Rle_monotony_contra with ``(INR (mult (S (S O)) n))``.
-Rewrite mult_INR; Apply Rmult_lt_pos; [Simpl; Sup0 | Apply lt_INR_0; Assumption].
-Rewrite (Rmult_sym (INR (mult (S (S O)) n))); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Do 2 Rewrite Rmult_1r; Apply le_INR.
-Apply mult_le; Assumption.
-Replace n with (S (pred n)).
-Apply not_O_INR; Discriminate.
-Symmetry; Apply S_pred with O.
-Assumption.
-Replace N with (S (pred N)).
-Apply not_O_INR; Discriminate.
-Symmetry; Apply S_pred with O.
-Assumption.
-Rewrite mult_INR.
-Rewrite Rinv_Rmult.
-Replace (INR (S (S O))) with ``2``; [Idtac | Reflexivity].
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Idtac | DiscrR].
-Rewrite Rmult_1l; Apply Rlt_monotony_contra with (INR N).
-Apply lt_INR_0; Assumption.
-Rewrite <- Rinv_r_sym.
-Apply Rlt_monotony_contra with ``/(2*eps)``.
-Apply Rlt_Rinv; Assumption.
-Rewrite Rmult_1r; Replace ``/(2*eps)*((INR N)*(2*eps))`` with ``(INR N)*((2*eps)*/(2*eps))``; [Idtac | Ring].
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Replace (INR N) with (IZR (INZ N)).
-Rewrite <- H4.
-Elim H1; Intros; Assumption.
-Symmetry; Apply INR_IZR_INZ.
-Apply prod_neq_R0; [DiscrR | Red; Intro; Rewrite H8 in H; Elim (Rlt_antirefl ? H)].
-Apply not_O_INR.
-Red; Intro; Rewrite H8 in H5; Elim (lt_n_n ? H5).
-Replace (INR (S (S O))) with ``2``; [DiscrR | Reflexivity].
-Apply not_O_INR.
-Red; Intro; Rewrite H8 in H5; Elim (lt_n_n ? H5).
-Apply Rle_sym1; Apply PI_tg_pos.
-Apply lt_le_trans with N; Assumption.
-Elim H1; Intros H5 _.
-Assert H6 := (lt_eq_lt_dec O N).
-Elim H6; Intro.
-Elim a; Intro.
-Assumption.
-Rewrite <- b in H4.
-Rewrite H4 in H5.
-Simpl in H5.
-Cut ``0</(2*eps)``; [Intro | Apply Rlt_Rinv; Assumption].
-Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H7 H5)).
-Elim (lt_n_O ? b).
-Apply le_IZR.
-Simpl.
-Left; Apply Rlt_trans with ``/(2*eps)``.
-Apply Rlt_Rinv; Assumption.
-Elim H1; Intros; Assumption.
-Qed.
-
-Lemma exist_PI : (sigTT R [l:R](Un_cv [N:nat](sum_f_R0 (tg_alt PI_tg) N) l)).
-Apply alternated_series.
-Apply PI_tg_decreasing.
-Apply PI_tg_cv.
-Qed.
-
-(* Now, PI is defined *)
-Definition PI : R := (Rmult ``4`` (Cases exist_PI of (existTT a b) => a end)).
-
-(* We can get an approximation of PI with the following inequality *)
-Lemma PI_ineq : (N:nat) ``(sum_f_R0 (tg_alt PI_tg) (S (mult (S (S O)) N)))<=PI/4<=(sum_f_R0 (tg_alt PI_tg) (mult (S (S O)) N))``.
-Intro; Apply alternated_series_ineq.
-Apply PI_tg_decreasing.
-Apply PI_tg_cv.
-Unfold PI; Case exist_PI; Intro.
-Replace ``(4*x)/4`` with x.
-Trivial.
-Unfold Rdiv; Rewrite (Rmult_sym ``4``); Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1r; Reflexivity | DiscrR].
-Qed.
-
-Lemma PI_RGT_0 : ``0<PI``.
-Assert H := (PI_ineq O).
-Apply Rlt_monotony_contra with ``/4``.
-Apply Rlt_Rinv; Sup0.
-Rewrite Rmult_Or; Rewrite Rmult_sym.
-Elim H; Clear H; Intros H _.
-Unfold Rdiv in H; Apply Rlt_le_trans with ``(sum_f_R0 (tg_alt PI_tg) (S (mult (S (S O)) O)))``.
-Simpl; Unfold tg_alt; Simpl; Rewrite Rmult_1l; Rewrite Rmult_1r; Apply Rlt_anti_compatibility with ``(PI_tg (S O))``.
-Rewrite Rplus_Or; Replace ``(PI_tg (S O))+((PI_tg O)+ -1*(PI_tg (S O)))`` with ``(PI_tg O)``; [Unfold PI_tg | Ring].
-Simpl; Apply Rinv_lt.
-Rewrite Rmult_1l; Replace ``2+1`` with ``3``; [Sup0 | Ring].
-Rewrite Rplus_sym; Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Sup0.
-Assumption.
-Qed.
diff --git a/theories7/Reals/ArithProp.v b/theories7/Reals/ArithProp.v
deleted file mode 100644
index 468675ca..00000000
--- a/theories7/Reals/ArithProp.v
+++ /dev/null
@@ -1,134 +0,0 @@
-(************************************************************************)
-(*  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: ArithProp.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rbasic_fun.
-Require Even.
-Require Div2.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope Z_scope.
-Open Local Scope R_scope.
-
-Lemma minus_neq_O : (n,i:nat) (lt i n) -> ~(minus n i)=O.
-Intros; Red; Intro.
-Cut (n,m:nat) (le m n) -> (minus n m)=O -> n=m.
-Intro; Assert H2 := (H1 ? ? (lt_le_weak ? ? H) H0); Rewrite H2 in H; Elim (lt_n_n ? H).
-Pose R := [n,m:nat](le m n)->(minus n m)=(0)->n=m.
-Cut ((n,m:nat)(R n m)) -> ((n0,m:nat)(le m n0)->(minus n0 m)=(0)->n0=m).
-Intro; Apply H1.
-Apply nat_double_ind.
-Unfold R; Intros; Inversion H2; Reflexivity.
-Unfold R; Intros; Simpl in H3; Assumption.
-Unfold R; Intros; Simpl in H4; Assert H5 := (le_S_n ? ? H3); Assert H6 := (H2 H5 H4); Rewrite H6; Reflexivity.
-Unfold R; Intros; Apply H1; Assumption.
-Qed.
-
-Lemma le_minusni_n : (n,i:nat) (le i n)->(le (minus n i) n).
-Pose R := [m,n:nat] (le n m) -> (le (minus m n) m).
-Cut ((m,n:nat)(R m n)) -> ((n,i:nat)(le i n)->(le (minus n i) n)).
-Intro; Apply H.
-Apply nat_double_ind.
-Unfold R; Intros; Simpl; Apply le_n.
-Unfold R; Intros; Simpl; Apply le_n.
-Unfold R; Intros; Simpl; Apply le_trans with n.
-Apply H0; Apply le_S_n; Assumption.
-Apply le_n_Sn.
-Unfold R; Intros; Apply H; Assumption.
-Qed.
-
-Lemma lt_minus_O_lt : (m,n:nat) (lt m n) -> (lt O (minus n m)).
-Intros n m; Pattern n m; Apply nat_double_ind; [
-  Intros; Rewrite <- minus_n_O; Assumption
-| Intros; Elim (lt_n_O ? H)
-| Intros; Simpl; Apply H; Apply lt_S_n; Assumption].
-Qed.
-
-Lemma even_odd_cor : (n:nat) (EX p : nat | n=(mult (2) p)\/n=(S (mult (2) p))).
-Intro.
-Assert H := (even_or_odd n).
-Exists (div2 n).
-Assert H0 := (even_odd_double n).
-Elim H0; Intros.
-Elim H1; Intros H3 _.
-Elim H2; Intros H4 _.
-Replace (mult (2) (div2 n)) with (Div2.double (div2 n)).
-Elim H; Intro.
-Left.
-Apply H3; Assumption.
-Right.
-Apply H4; Assumption.
-Unfold Div2.double; Ring.
-Qed.
-
-(* 2m <= 2n => m<=n *)
-Lemma le_double : (m,n:nat) (le (mult (2) m) (mult (2) n)) -> (le m n).
-Intros; Apply INR_le.
-Assert H1 := (le_INR ? ? H).
-Do 2 Rewrite mult_INR in H1.
-Apply Rle_monotony_contra with ``(INR (S (S O)))``.
-Replace (INR (S (S O))) with ``2``; [Sup0 | Reflexivity].
-Assumption.
-Qed.
-
-(* Here, we have the euclidian division *)
-(* This lemma is used in the proof of sin_eq_0 : (sin x)=0<->x=kPI *)
-Lemma euclidian_division : (x,y:R) ``y<>0`` -> (EXT k:Z | (EXT r : R | ``x==(IZR k)*y+r``/\``0<=r<(Rabsolu y)``)).
-Intros.
-Pose k0 := Cases (case_Rabsolu y) of
-     (leftT _) => (Zminus `1` (up ``x/-y``))
-   | (rightT _) => (Zminus (up ``x/y``) `1`) end.
-Exists k0.
-Exists ``x-(IZR k0)*y``.
-Split.
-Ring.
-Unfold k0; Case (case_Rabsolu y); Intro.
-Assert H0 := (archimed ``x/-y``); Rewrite <- Z_R_minus; Simpl; Unfold Rminus.
-Replace ``-((1+ -(IZR (up (x/( -y)))))*y)`` with ``((IZR (up (x/-y)))-1)*y``; [Idtac | Ring].
-Split.
-Apply Rle_monotony_contra with ``/-y``.
-Apply Rlt_Rinv; Apply Rgt_RO_Ropp; Exact r.
-Rewrite Rmult_Or; Rewrite (Rmult_sym ``/-y``); Rewrite Rmult_Rplus_distrl; Rewrite <- Ropp_Rinv; [Idtac | Assumption].
-Rewrite Rmult_assoc; Repeat Rewrite Ropp_mul3; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1r | Assumption].
-Apply Rle_anti_compatibility with ``(IZR (up (x/( -y))))-x/( -y)``.
-Rewrite Rplus_Or; Unfold Rdiv; Pattern 4 ``/-y``; Rewrite <- Ropp_Rinv; [Idtac | Assumption].
-Replace ``(IZR (up (x*/ -y)))-x* -/y+( -(x*/y)+ -((IZR (up (x*/ -y)))-1))`` with R1; [Idtac | Ring].
-Elim H0; Intros _ H1; Unfold Rdiv in H1; Exact H1.
-Rewrite (Rabsolu_left ? r); Apply Rlt_monotony_contra with ``/-y``.
-Apply Rlt_Rinv; Apply Rgt_RO_Ropp; Exact r.
-Rewrite <- Rinv_l_sym.
-Rewrite (Rmult_sym ``/-y``); Rewrite Rmult_Rplus_distrl; Rewrite <- Ropp_Rinv; [Idtac | Assumption].
-Rewrite Rmult_assoc; Repeat Rewrite Ropp_mul3; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1r | Assumption]; Apply Rlt_anti_compatibility with ``((IZR (up (x/( -y))))-1)``.
-Replace ``(IZR (up (x/( -y))))-1+1`` with ``(IZR (up (x/( -y))))``; [Idtac | Ring].
-Replace ``(IZR (up (x/( -y))))-1+( -(x*/y)+ -((IZR (up (x/( -y))))-1))`` with ``-(x*/y)``; [Idtac | Ring].
-Rewrite <- Ropp_mul3; Rewrite (Ropp_Rinv ? H); Elim H0; Unfold Rdiv; Intros H1 _; Exact H1.
-Apply Ropp_neq; Assumption.
-Assert H0 := (archimed ``x/y``); Rewrite <- Z_R_minus; Simpl; Cut ``0<y``.
-Intro; Unfold Rminus; Replace ``-(((IZR (up (x/y)))+ -1)*y)`` with ``(1-(IZR (up (x/y))))*y``; [Idtac | Ring].
-Split.
-Apply Rle_monotony_contra with ``/y``.
-Apply Rlt_Rinv; Assumption.
-Rewrite Rmult_Or; Rewrite (Rmult_sym ``/y``); Rewrite Rmult_Rplus_distrl; Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1r | Assumption]; Apply Rle_anti_compatibility with ``(IZR (up (x/y)))-x/y``; Rewrite Rplus_Or; Unfold Rdiv; Replace ``(IZR (up (x*/y)))-x*/y+(x*/y+(1-(IZR (up (x*/y)))))`` with R1; [Idtac | Ring]; Elim H0; Intros _ H2; Unfold Rdiv in H2; Exact H2.
-Rewrite (Rabsolu_right ? r); Apply Rlt_monotony_contra with ``/y``.
-Apply Rlt_Rinv; Assumption.
-Rewrite <- (Rinv_l_sym ? H); Rewrite (Rmult_sym ``/y``); Rewrite Rmult_Rplus_distrl; Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1r | Assumption]; Apply Rlt_anti_compatibility with ``((IZR (up (x/y)))-1)``; Replace ``(IZR (up (x/y)))-1+1`` with ``(IZR (up (x/y)))``; [Idtac | Ring]; Replace ``(IZR (up (x/y)))-1+(x*/y+(1-(IZR (up (x/y)))))`` with ``x*/y``; [Idtac | Ring]; Elim H0; Unfold Rdiv; Intros H2 _; Exact H2.
-Case (total_order_T R0 y); Intro.
-Elim s; Intro.
-Assumption.
-Elim H; Symmetry; Exact b.
-Assert H1 := (Rle_sym2 ? ? r); Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H1 r0)).
-Qed.
-
-Lemma tech8 : (n,i:nat) (le n (plus (S n) i)).
-Intros; Induction i.
-Replace (plus (S n) O) with (S n); [Apply le_n_Sn | Ring].
-Replace (plus (S n) (S i)) with (S (plus (S n) i)).
-Apply le_S; Assumption.
-Apply INR_eq; Rewrite S_INR; Do 2 Rewrite plus_INR; Do 2 Rewrite S_INR; Ring.
-Qed.
diff --git a/theories7/Reals/Binomial.v b/theories7/Reals/Binomial.v
deleted file mode 100644
index 1dfd2ec0..00000000
--- a/theories7/Reals/Binomial.v
+++ /dev/null
@@ -1,181 +0,0 @@
-(************************************************************************)
-(*  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: Binomial.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require PartSum.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Definition C [n,p:nat] : R := ``(INR (fact n))/((INR (fact p))*(INR (fact (minus n p))))``.
-
-Lemma pascal_step1 : (n,i:nat) (le i n) -> (C n i) == (C n (minus n i)).
-Intros; Unfold C; Replace (minus n (minus n i)) with i.
-Rewrite Rmult_sym.
-Reflexivity.
-Apply plus_minus; Rewrite plus_sym; Apply le_plus_minus; Assumption.
-Qed.
-
-Lemma pascal_step2 : (n,i:nat) (le i n) -> (C (S n) i) == ``(INR (S n))/(INR (minus (S n) i))*(C n i)``.
-Intros; Unfold C; Replace (minus (S n) i) with (S (minus n i)).
-Cut (n:nat) (fact (S n))=(mult (S n) (fact n)).
-Intro; Repeat Rewrite H0.
-Unfold Rdiv; Repeat Rewrite mult_INR; Repeat Rewrite Rinv_Rmult.
-Ring.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply not_O_INR; Discriminate.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply prod_neq_R0.
-Apply not_O_INR; Discriminate.
-Apply INR_fact_neq_0.
-Intro; Reflexivity.
-Apply minus_Sn_m; Assumption.
-Qed.
-
-Lemma pascal_step3 : (n,i:nat) (lt i n) -> (C n (S i)) == ``(INR (minus n i))/(INR (S i))*(C n i)``.
-Intros; Unfold C.
-Cut (n:nat) (fact (S n))=(mult (S n) (fact n)).
-Intro.
-Cut (minus n i) = (S (minus n (S i))).
-Intro.
-Pattern 2 (minus n i); Rewrite H1.
-Repeat Rewrite H0; Unfold Rdiv; Repeat Rewrite mult_INR; Repeat Rewrite Rinv_Rmult.
-Rewrite <- H1; Rewrite (Rmult_sym ``/(INR (minus n i))``); Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym (INR (minus n i))); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Ring.
-Apply not_O_INR; Apply minus_neq_O; Assumption.
-Apply not_O_INR; Discriminate.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply prod_neq_R0; [Apply not_O_INR; Discriminate | Apply INR_fact_neq_0].
-Apply not_O_INR; Discriminate.
-Apply INR_fact_neq_0.
-Apply prod_neq_R0; [Apply not_O_INR; Discriminate | Apply INR_fact_neq_0].
-Apply INR_fact_neq_0.
-Rewrite minus_Sn_m.
-Simpl; Reflexivity.
-Apply lt_le_S; Assumption.
-Intro; Reflexivity.
-Qed.
-
-(**********)
-Lemma pascal : (n,i:nat) (lt i n) -> ``(C n i)+(C n (S i))==(C (S n) (S i))``.
-Intros.
-Rewrite pascal_step3; [Idtac | Assumption].
-Replace ``(C n i)+(INR (minus n i))/(INR (S i))*(C n i)`` with ``(C n i)*(1+(INR (minus n i))/(INR (S i)))``; [Idtac | Ring].
-Replace ``1+(INR (minus n i))/(INR (S i))`` with ``(INR (S n))/(INR (S i))``.
-Rewrite pascal_step1.
-Rewrite Rmult_sym; Replace (S i) with (minus (S n) (minus n i)).
-Rewrite <- pascal_step2.
-Apply pascal_step1.
-Apply le_trans with n.
-Apply le_minusni_n.
-Apply lt_le_weak; Assumption.
-Apply le_n_Sn.
-Apply le_minusni_n.
-Apply lt_le_weak; Assumption.
-Rewrite <- minus_Sn_m.
-Cut (minus n (minus n i))=i.
-Intro; Rewrite H0; Reflexivity.
-Symmetry; Apply plus_minus.
-Rewrite plus_sym; Rewrite le_plus_minus_r.
-Reflexivity.
-Apply lt_le_weak; Assumption.
-Apply le_minusni_n; Apply lt_le_weak; Assumption.
-Apply lt_le_weak; Assumption.
-Unfold Rdiv.
-Repeat Rewrite S_INR.
-Rewrite minus_INR.
-Cut ``((INR i)+1)<>0``.
-Intro.
-Apply r_Rmult_mult with ``(INR i)+1``; [Idtac | Assumption].
-Rewrite Rmult_Rplus_distr.
-Rewrite Rmult_1r.
-Do 2 Rewrite (Rmult_sym ``(INR i)+1``).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym; [Idtac | Assumption].
-Ring.
-Rewrite <- S_INR.
-Apply not_O_INR; Discriminate.
-Apply lt_le_weak; Assumption.
-Qed.
-
-(*********************)
-(*********************)
-Lemma binomial : (x,y:R;n:nat) ``(pow (x+y) n)``==(sum_f_R0 [i:nat]``(C n i)*(pow x i)*(pow y (minus n i))`` n).
-Intros; Induction n.
-Unfold C; Simpl; Unfold Rdiv; Repeat Rewrite Rmult_1r; Rewrite Rinv_R1; Ring.
-Pattern 1 (S n); Replace (S n) with (plus n (1)); [Idtac | Ring].
-Rewrite pow_add; Rewrite Hrecn.
-Replace ``(pow (x+y) (S O))`` with ``x+y``; [Idtac | Simpl; Ring].
-Rewrite tech5.
-Cut (p:nat)(C p p)==R1.
-Cut (p:nat)(C p O)==R1.
-Intros; Rewrite H0; Rewrite <- minus_n_n; Rewrite Rmult_1l.
-Replace (pow y O) with R1; [Rewrite Rmult_1r | Simpl; Reflexivity].
-Induction n.
-Simpl; Do 2 Rewrite H; Ring.
-(* N >= 1 *)
-Pose N := (S n).
-Rewrite Rmult_Rplus_distr.
-Replace (Rmult (sum_f_R0 ([i:nat]``(C N i)*(pow x i)*(pow y (minus N i))``) N) x) with (sum_f_R0 [i:nat]``(C N i)*(pow x (S i))*(pow y (minus N i))`` N).
-Replace (Rmult (sum_f_R0 ([i:nat]``(C N i)*(pow x i)*(pow y (minus N i))``) N) y) with (sum_f_R0 [i:nat]``(C N i)*(pow x i)*(pow y (minus (S N) i))`` N).
-Rewrite (decomp_sum [i:nat]``(C (S N) i)*(pow x i)*(pow y (minus (S N) i))`` N).
-Rewrite H; Replace (pow x O) with R1; [Idtac | Reflexivity].
-Do 2 Rewrite Rmult_1l.
-Replace (minus (S N) O) with (S N); [Idtac | Reflexivity].
-Pose An := [i:nat]``(C N i)*(pow x (S i))*(pow y (minus N i))``.
-Pose Bn := [i:nat]``(C N (S i))*(pow x (S i))*(pow y (minus N i))``.
-Replace (pred N) with n.
-Replace (sum_f_R0 ([i:nat]``(C (S N) (S i))*(pow x (S i))*(pow y (minus (S N) (S i)))``) n) with (sum_f_R0 [i:nat]``(An i)+(Bn i)`` n).
-Rewrite plus_sum.
-Replace (pow x (S N)) with (An (S n)).
-Rewrite (Rplus_sym (sum_f_R0 An n)).
-Repeat Rewrite Rplus_assoc.
-Rewrite <- tech5.
-Fold N.
-Pose Cn := [i:nat]``(C N i)*(pow x i)*(pow y (minus (S N) i))``.
-Cut (i:nat) (lt i N)-> (Cn (S i))==(Bn i).
-Intro; Replace (sum_f_R0 Bn n) with (sum_f_R0 [i:nat](Cn (S i)) n).
-Replace (pow y (S N)) with (Cn O).
-Rewrite <- Rplus_assoc; Rewrite (decomp_sum Cn N).
-Replace (pred N) with n.
-Ring.
-Unfold N; Simpl; Reflexivity.
-Unfold N; Apply lt_O_Sn.
-Unfold Cn; Rewrite H; Simpl; Ring.
-Apply sum_eq.
-Intros; Apply H1.
-Unfold N; Apply le_lt_trans with n; [Assumption | Apply lt_n_Sn].
-Intros; Unfold Bn Cn.
-Replace (minus (S N) (S i)) with (minus N i); Reflexivity.
-Unfold An; Fold N; Rewrite <- minus_n_n; Rewrite H0; Simpl; Ring.
-Apply sum_eq.
-Intros; Unfold An Bn; Replace (minus (S N) (S i)) with (minus N i); [Idtac | Reflexivity].
-Rewrite <- pascal; [Ring | Apply le_lt_trans with n; [Assumption | Unfold N; Apply lt_n_Sn]].
-Unfold N; Reflexivity.
-Unfold N; Apply lt_O_Sn.
-Rewrite <- (Rmult_sym y); Rewrite scal_sum; Apply sum_eq.
-Intros; Replace (minus (S N) i) with (S (minus N i)).
-Replace (S (minus N i)) with (plus (minus N i) (1)); [Idtac | Ring].
-Rewrite pow_add; Replace (pow y (S O)) with y; [Idtac | Simpl; Ring]; Ring.
-Apply minus_Sn_m; Assumption.
-Rewrite <- (Rmult_sym x); Rewrite scal_sum; Apply sum_eq.
-Intros; Replace (S i) with (plus i (1)); [Idtac | Ring]; Rewrite pow_add; Replace (pow x (S O)) with x; [Idtac | Simpl; Ring]; Ring.
-Intro; Unfold C.
-Replace (INR (fact O)) with R1; [Idtac | Reflexivity].
-Replace (minus p O) with p; [Idtac | Apply minus_n_O].
-Rewrite Rmult_1l; Unfold Rdiv; Rewrite <- Rinv_r_sym; [Reflexivity | Apply INR_fact_neq_0].
-Intro; Unfold C.
-Replace (minus p p) with O; [Idtac | Apply minus_n_n].
-Replace (INR (fact O)) with R1; [Idtac | Reflexivity].
-Rewrite Rmult_1r; Unfold Rdiv; Rewrite <- Rinv_r_sym; [Reflexivity | Apply INR_fact_neq_0].
-Qed.
diff --git a/theories7/Reals/Cauchy_prod.v b/theories7/Reals/Cauchy_prod.v
deleted file mode 100644
index 9442eff0..00000000
--- a/theories7/Reals/Cauchy_prod.v
+++ /dev/null
@@ -1,347 +0,0 @@
-(************************************************************************)
-(*  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: Cauchy_prod.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rseries.
-Require PartSum.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(**********)
-Lemma sum_N_predN : (An:nat->R;N:nat) (lt O N) -> (sum_f_R0 An N)==``(sum_f_R0 An (pred N)) + (An N)``.
-Intros.
-Replace N with (S (pred N)).
-Rewrite tech5.
-Reflexivity.
-Symmetry; Apply S_pred with O; Assumption.
-Qed.
-
-(**********)
-Lemma sum_plus : (An,Bn:nat->R;N:nat) (sum_f_R0 [l:nat]``(An l)+(Bn l)`` N)==``(sum_f_R0 An N)+(sum_f_R0 Bn N)``.
-Intros.
-Induction N.
-Reflexivity.
-Do 3 Rewrite tech5.
-Rewrite HrecN; Ring.
-Qed.
-
-(* The main result *)
-Theorem cauchy_finite : (An,Bn:nat->R;N:nat) (lt O N) -> (Rmult (sum_f_R0 An N) (sum_f_R0 Bn N)) == (Rplus (sum_f_R0 [k:nat](sum_f_R0 [p:nat]``(An p)*(Bn (minus k p))`` k) N) (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (plus l k)))*(Bn (minus N l))`` (pred (minus N k))) (pred N))). 
-Intros; Induction N.
-Elim (lt_n_n ? H).
-Cut N=O\/(lt O N).
-Intro; Elim H0; Intro.
-Rewrite H1; Simpl; Ring.
-Replace (pred (S N)) with (S (pred N)).
-Do 5 Rewrite tech5.
-Rewrite Rmult_Rplus_distrl; Rewrite Rmult_Rplus_distr; Rewrite (HrecN H1).
-Repeat Rewrite Rplus_assoc; Apply Rplus_plus_r.
-Replace (pred (minus (S N) (S (pred N)))) with (O).
-Rewrite Rmult_Rplus_distr; Replace (sum_f_R0 [l:nat]``(An (S (plus l (S (pred N)))))*(Bn (minus (S N) l))`` O) with ``(An (S N))*(Bn (S N))``.
-Repeat Rewrite <- Rplus_assoc; Do 2 Rewrite <- (Rplus_sym ``(An (S N))*(Bn (S N))``); Repeat Rewrite Rplus_assoc; Apply Rplus_plus_r.
-Rewrite <- minus_n_n; Cut N=(1)\/(le (2) N).
-Intro; Elim H2; Intro.
-Rewrite H3; Simpl; Ring.
-Replace (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (plus l k)))*(Bn (minus N l))`` (pred (minus N k))) (pred N)) with (Rplus (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (pred (minus N k)))) (pred (pred N))) (sum_f_R0 [l:nat]``(An (S l))*(Bn (minus N l))`` (pred N))).
-Replace (sum_f_R0 [p:nat]``(An p)*(Bn (minus (S N) p))`` N) with (Rplus (sum_f_R0 [l:nat]``(An (S l))*(Bn (minus N l))`` (pred N)) ``(An O)*(Bn (S N))``).
-Repeat Rewrite <- Rplus_assoc; Rewrite <- (Rplus_sym (sum_f_R0 [l:nat]``(An (S l))*(Bn (minus N l))`` (pred N))); Repeat Rewrite Rplus_assoc; Apply Rplus_plus_r.
-Replace (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (plus l k)))*(Bn (minus (S N) l))`` (pred (minus (S N) k))) (pred N)) with (Rplus (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (minus N k))) (pred N)) (Rmult (Bn (S N)) (sum_f_R0 [l:nat](An (S l)) (pred N)))).
-Rewrite (decomp_sum An N H1); Rewrite Rmult_Rplus_distrl; Repeat Rewrite <- Rplus_assoc; Rewrite <- (Rplus_sym ``(An O)*(Bn (S N))``); Repeat Rewrite Rplus_assoc; Apply Rplus_plus_r.
-Repeat Rewrite <- Rplus_assoc; Rewrite <- (Rplus_sym (Rmult (sum_f_R0 [i:nat](An (S i)) (pred N)) (Bn (S N)))); Rewrite <- (Rplus_sym (Rmult (Bn (S N)) (sum_f_R0 [i:nat](An (S i)) (pred N)))); Rewrite (Rmult_sym (Bn (S N))); Repeat Rewrite Rplus_assoc; Apply Rplus_plus_r.
-Replace (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (minus N k))) (pred N)) with (Rplus (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (pred (minus N k)))) (pred (pred N))) (Rmult (An (S N)) (sum_f_R0 [l:nat](Bn (S l)) (pred N)))).
-Rewrite (decomp_sum Bn N H1); Rewrite Rmult_Rplus_distr.
-Pose Z := (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (pred (minus N k)))) (pred (pred N))); Pose Z2 := (sum_f_R0 [i:nat](Bn (S i)) (pred N)); Ring.
-Rewrite (sum_N_predN [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (minus N k))) (pred N)).
-Replace (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (minus N k))) (pred (pred N))) with (sum_f_R0 [k:nat](Rplus (sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (pred (minus N k)))) ``(An (S N))*(Bn (S k))``) (pred (pred N))).
-Rewrite (sum_plus [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (pred (minus N k)))) [k:nat]``(An (S N))*(Bn (S k))`` (pred (pred N))).
-Repeat Rewrite Rplus_assoc; Apply Rplus_plus_r.
-Replace (pred (minus N (pred N))) with O.
-Simpl; Rewrite <- minus_n_O.
-Replace (S (pred N)) with N.
-Replace (sum_f_R0 [k:nat]``(An (S N))*(Bn (S k))`` (pred (pred N))) with (sum_f_R0 [k:nat]``(Bn (S k))*(An (S N))`` (pred (pred N))).
-Rewrite <- (scal_sum [l:nat](Bn (S l)) (pred (pred N)) (An (S N))); Rewrite (sum_N_predN [l:nat](Bn (S l)) (pred N)).
-Replace (S (pred N)) with N.
-Ring.
-Apply S_pred with O; Assumption.
-Apply lt_pred; Apply lt_le_trans with (2); [Apply lt_n_Sn | Assumption].
-Apply sum_eq; Intros; Apply Rmult_sym.
-Apply S_pred with O; Assumption.
-Replace (minus N (pred N)) with (1).
-Reflexivity.
-Pattern 1 N; Replace N with (S (pred N)).
-Rewrite <- minus_Sn_m.
-Rewrite <- minus_n_n; Reflexivity.
-Apply le_n.
-Symmetry; Apply S_pred with O; Assumption.
-Apply sum_eq; Intros; Rewrite (sum_N_predN [l:nat]``(An (S (S (plus l i))))*(Bn (minus N l))`` (pred (minus N i))).
-Replace (S (S (plus (pred (minus N i)) i))) with (S N).
-Replace (minus N (pred (minus N i))) with (S i).
-Ring.
-Rewrite pred_of_minus; Apply INR_eq; Repeat Rewrite minus_INR.
-Rewrite S_INR; Ring.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Apply INR_le; Rewrite minus_INR.
-Apply Rle_anti_compatibility with ``(INR i)-1``.
-Replace ``(INR i)-1+(INR (S O))`` with (INR i); [Idtac | Ring].
-Replace ``(INR i)-1+((INR N)-(INR i))`` with ``(INR N)-(INR (S O))``; [Idtac | Ring].
-Rewrite <- minus_INR.
-Apply le_INR; Apply le_trans with (pred (pred N)).
-Assumption.
-Rewrite <- pred_of_minus; Apply le_pred_n.
-Apply le_trans with (2).
-Apply le_n_Sn.
-Assumption.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Rewrite <- pred_of_minus.
-Apply le_trans with (pred N).
-Apply le_S_n.
-Replace (S (pred N)) with N.
-Replace (S (pred (minus N i))) with (minus N i).
-Apply simpl_le_plus_l with i; Rewrite le_plus_minus_r.
-Apply le_plus_r.
-Apply le_trans with (pred (pred N)); [Assumption | Apply le_trans with (pred N); Apply le_pred_n].
-Apply S_pred with O.
-Apply simpl_lt_plus_l with i; Rewrite le_plus_minus_r.
-Replace (plus i O) with i; [Idtac | Ring].
-Apply le_lt_trans with (pred (pred N)); [Assumption | Apply lt_trans with (pred N); Apply lt_pred_n_n].
-Apply lt_S_n.
-Replace (S (pred N)) with N.
-Apply lt_le_trans with (2).
-Apply lt_n_Sn.
-Assumption.
-Apply S_pred with O; Assumption.
-Assumption.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Apply S_pred with O; Assumption.
-Apply le_pred_n.
-Apply INR_eq; Rewrite pred_of_minus; Do 3 Rewrite S_INR; Rewrite plus_INR; Repeat Rewrite minus_INR.
-Ring.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Apply INR_le.
-Rewrite minus_INR.
-Apply Rle_anti_compatibility with ``(INR i)-1``.
-Replace ``(INR i)-1+(INR (S O))`` with (INR i); [Idtac | Ring].
-Replace ``(INR i)-1+((INR N)-(INR i))`` with ``(INR N)-(INR (S O))``; [Idtac | Ring].
-Rewrite <- minus_INR.
-Apply le_INR.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Rewrite <- pred_of_minus.
-Apply le_pred_n.
-Apply le_trans with (2).
-Apply le_n_Sn.
-Assumption.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Apply lt_le_trans with (1).
-Apply lt_O_Sn.
-Apply INR_le.
-Rewrite pred_of_minus.
-Repeat Rewrite minus_INR.
-Apply Rle_anti_compatibility with ``(INR i)-1``.
-Replace ``(INR i)-1+(INR (S O))`` with (INR i); [Idtac | Ring].
-Replace ``(INR i)-1+((INR N)-(INR i)-(INR (S O)))`` with ``(INR N)-(INR (S O)) -(INR (S O))``.
-Repeat Rewrite <- minus_INR.
-Apply le_INR.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Do 2 Rewrite <- pred_of_minus.
-Apply le_n.
-Apply simpl_le_plus_l with (1).
-Rewrite le_plus_minus_r.
-Simpl; Assumption.
-Apply le_trans with (2); [Apply le_n_Sn | Assumption].
-Apply le_trans with (2); [Apply le_n_Sn | Assumption].
-Ring.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Apply simpl_le_plus_l with i.
-Rewrite le_plus_minus_r.
-Replace (plus i (1)) with (S i).
-Replace N with (S (pred N)).
-Apply le_n_S.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_pred_n.
-Symmetry; Apply S_pred with O; Assumption.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Reflexivity.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Apply lt_le_trans with (1).
-Apply lt_O_Sn.
-Apply le_S_n.
-Replace (S (pred N)) with N.
-Assumption.
-Apply S_pred with O; Assumption.
-Replace (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(An (S (plus l k)))*(Bn (minus (S N) l))`` (pred (minus (S N) k))) (pred N)) with (sum_f_R0 [k:nat](Rplus (sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (minus N k))) ``(An (S k))*(Bn (S N))``) (pred N)).
-Rewrite (sum_plus [k:nat](sum_f_R0 [l:nat]``(An (S (S (plus l k))))*(Bn (minus N l))`` (pred (minus N k))) [k:nat]``(An (S k))*(Bn (S N))``).
-Apply Rplus_plus_r.
-Rewrite scal_sum; Reflexivity.
-Apply sum_eq; Intros; Rewrite Rplus_sym; Rewrite (decomp_sum [l:nat]``(An (S (plus l i)))*(Bn (minus (S N) l))`` (pred (minus (S N) i))).
-Replace (plus O i) with i; [Idtac | Ring].
-Rewrite <- minus_n_O; Apply Rplus_plus_r.
-Replace (pred (pred (minus (S N) i))) with (pred (minus N i)).
-Apply sum_eq; Intros.
-Replace (minus (S N) (S i0)) with (minus N i0); [Idtac | Reflexivity].
-Replace (plus (S i0) i) with (S (plus i0 i)).
-Reflexivity.
-Apply INR_eq; Rewrite S_INR; Do 2 Rewrite plus_INR; Rewrite S_INR; Ring.
-Cut (minus N i)=(pred (minus (S N) i)).
-Intro; Rewrite H5; Reflexivity.
-Rewrite pred_of_minus.
-Apply INR_eq; Repeat Rewrite minus_INR.
-Rewrite S_INR; Ring.
-Apply le_trans with N.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply simpl_le_plus_l with i.
-Rewrite le_plus_minus_r.
-Replace (plus i (1)) with (S i).
-Apply le_n_S.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_trans with N.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Replace (pred (minus (S N) i)) with (minus (S N) (S i)).
-Replace (minus (S N) (S i)) with (minus N i); [Idtac | Reflexivity].
-Apply simpl_lt_plus_l with i.
-Rewrite le_plus_minus_r.
-Replace (plus i O) with i; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n.
-Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Rewrite pred_of_minus.
-Apply INR_eq; Repeat Rewrite minus_INR.
-Repeat Rewrite S_INR; Ring.
-Apply le_trans with N.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply simpl_le_plus_l with i.
-Rewrite le_plus_minus_r.
-Replace (plus i (1)) with (S i).
-Apply le_n_S.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_trans with N.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply le_n_S.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Rewrite Rplus_sym.
-Rewrite (decomp_sum [p:nat]``(An p)*(Bn (minus (S N) p))`` N).
-Rewrite <- minus_n_O.
-Apply Rplus_plus_r.
-Apply sum_eq; Intros.
-Reflexivity.
-Assumption.
-Rewrite Rplus_sym.
-Rewrite (decomp_sum [k:nat](sum_f_R0 [l:nat]``(An (S (plus l k)))*(Bn (minus N l))`` (pred (minus N k))) (pred N)).
-Rewrite <- minus_n_O.
-Replace (sum_f_R0 [l:nat]``(An (S (plus l O)))*(Bn (minus N l))`` (pred N)) with (sum_f_R0 [l:nat]``(An (S l))*(Bn (minus N l))`` (pred N)).
-Apply Rplus_plus_r.
-Apply sum_eq; Intros.
-Replace (pred (minus N (S i))) with (pred (pred (minus N i))).
-Apply sum_eq; Intros.
-Replace (plus i0 (S i)) with (S (plus i0 i)).
-Reflexivity.
-Apply INR_eq; Rewrite S_INR; Do 2 Rewrite plus_INR; Rewrite S_INR; Ring.
-Cut (pred (minus N i))=(minus N (S i)).
-Intro; Rewrite H5; Reflexivity.
-Rewrite pred_of_minus.
-Apply INR_eq.
-Repeat Rewrite minus_INR.
-Repeat Rewrite S_INR; Ring.
-Apply le_trans with (S (pred (pred N))).
-Apply le_n_S; Assumption.
-Replace (S (pred (pred N))) with (pred N).
-Apply le_pred_n.
-Apply S_pred with O.
-Apply lt_S_n.
-Replace (S (pred N)) with N.
-Apply lt_le_trans with (2).
-Apply lt_n_Sn.
-Assumption.
-Apply S_pred with O; Assumption.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Apply simpl_le_plus_l with i.
-Rewrite le_plus_minus_r.
-Replace (plus i (1)) with (S i).
-Replace N with (S (pred N)).
-Apply le_n_S.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_pred_n.
-Symmetry; Apply S_pred with O; Assumption.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_trans with (pred (pred N)).
-Assumption.
-Apply le_trans with (pred N); Apply le_pred_n.
-Apply sum_eq; Intros.
-Replace (plus i O) with i; [Reflexivity | Trivial].
-Apply lt_S_n.
-Replace (S (pred N)) with N.
-Apply lt_le_trans with (2); [Apply lt_n_Sn | Assumption].
-Apply S_pred with O; Assumption.
-Inversion H1.
-Left; Reflexivity.
-Right; Apply le_n_S; Assumption.
-Simpl.
-Replace (S (pred N)) with N.
-Reflexivity.
-Apply S_pred with O; Assumption.
-Simpl.
-Cut (minus N (pred N))=(1).
-Intro; Rewrite H2; Reflexivity.
-Rewrite pred_of_minus.
-Apply INR_eq; Repeat Rewrite minus_INR.
-Ring.
-Apply lt_le_S; Assumption.
-Rewrite <- pred_of_minus; Apply le_pred_n.
-Simpl; Symmetry; Apply S_pred with O; Assumption.
-Inversion H.
-Left; Reflexivity.
-Right; Apply lt_le_trans with (1); [Apply lt_n_Sn | Exact H1].
-Qed.
diff --git a/theories7/Reals/Cos_plus.v b/theories7/Reals/Cos_plus.v
deleted file mode 100644
index 481e51bf..00000000
--- a/theories7/Reals/Cos_plus.v
+++ /dev/null
@@ -1,1017 +0,0 @@
-(************************************************************************)
-(*  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: Cos_plus.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo_def.
-Require Cos_rel.
-Require Max.
-V7only [Import nat_scope.]. Open Local Scope nat_scope.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Definition Majxy [x,y:R] : nat->R := [n:nat](Rdiv (pow (Rmax R1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (4) (S n))) (INR (fact n))).
-
-Lemma Majxy_cv_R0 : (x,y:R) (Un_cv (Majxy x y) R0).
-Intros.
-Pose C := (Rmax R1 (Rmax (Rabsolu x) (Rabsolu y))).
-Pose C0 := (pow C (4)).
-Cut ``0<C``.
-Intro.
-Cut ``0<C0``.
-Intro.
-Assert H1 := (cv_speed_pow_fact C0).
-Unfold Un_cv in H1; Unfold R_dist in H1.
-Unfold Un_cv; Unfold R_dist; Intros.
-Cut ``0<eps/C0``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Assumption]].
-Elim (H1 ``eps/C0`` H3); Intros N0 H4.
-Exists N0; Intros.
-Replace (Majxy x y n) with ``(pow C0 (S n))/(INR (fact n))``.
-Simpl.
-Apply Rlt_monotony_contra with ``(Rabsolu (/C0))``.
-Apply Rabsolu_pos_lt.
-Apply Rinv_neq_R0.
-Red; Intro; Rewrite H6 in H0; Elim (Rlt_antirefl ? H0).
-Rewrite <- Rabsolu_mult.
-Unfold Rminus; Rewrite Rmult_Rplus_distr.
-Rewrite Ropp_O; Rewrite Rmult_Or.
-Unfold Rdiv; Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Rewrite (Rabsolu_right ``/C0``).
-Rewrite <- (Rmult_sym eps).
-Replace ``(pow C0 n)*/(INR (fact n))+0`` with ``(pow C0 n)*/(INR (fact n))-0``; [Idtac | Ring].
-Unfold Rdiv in H4; Apply H4; Assumption.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Assumption.
-Red; Intro; Rewrite H6 in H0; Elim (Rlt_antirefl ? H0).
-Unfold Majxy.
-Unfold C0.
-Rewrite pow_mult.
-Unfold C; Reflexivity.
-Unfold C0; Apply pow_lt; Assumption.
-Apply Rlt_le_trans with R1.
-Apply Rlt_R0_R1.
-Unfold C.
-Apply RmaxLess1.
-Qed.
-
-Lemma reste1_maj : (x,y:R;N:nat) (lt O N) -> ``(Rabsolu (Reste1 x y N))<=(Majxy x y (pred N))``.
-Intros.
-Pose C := (Rmax R1 (Rmax (Rabsolu x) (Rabsolu y))).
-Unfold Reste1.
-Apply Rle_trans with (sum_f_R0
-     [k:nat]
-        (Rabsolu (sum_f_R0
-          [l:nat]
-           ``(pow ( -1) (S (plus l k)))/
-           (INR (fact (mult (S (S O)) (S (plus l k)))))*
-           (pow x (mult (S (S O)) (S (plus l k))))*
-           (pow ( -1) (minus N l))/
-           (INR (fact (mult (S (S O)) (minus N l))))*
-           (pow y (mult (S (S O)) (minus N l)))`` (pred (minus N k))))
-     (pred N)).
-Apply (sum_Rabsolu [k:nat]
-        (sum_f_R0
-          [l:nat]
-           ``(pow ( -1) (S (plus l k)))/
-           (INR (fact (mult (S (S O)) (S (plus l k)))))*
-           (pow x (mult (S (S O)) (S (plus l k))))*
-           (pow ( -1) (minus N l))/
-           (INR (fact (mult (S (S O)) (minus N l))))*
-           (pow y (mult (S (S O)) (minus N l)))`` (pred (minus N k))) (pred N)).
-Apply Rle_trans with (sum_f_R0
-     [k:nat]
-          (sum_f_R0
-            [l:nat]
-             (Rabsolu (``(pow ( -1) (S (plus l k)))/
-             (INR (fact (mult (S (S O)) (S (plus l k)))))*
-             (pow x (mult (S (S O)) (S (plus l k))))*
-             (pow ( -1) (minus N l))/
-             (INR (fact (mult (S (S O)) (minus N l))))*
-             (pow y (mult (S (S O)) (minus N l)))``)) (pred (minus N k)))
-     (pred N)).
-Apply sum_Rle.
-Intros.
-Apply (sum_Rabsolu [l:nat]
-        ``(pow ( -1) (S (plus l n)))/
-        (INR (fact (mult (S (S O)) (S (plus l n)))))*
-        (pow x (mult (S (S O)) (S (plus l n))))*
-        (pow ( -1) (minus N l))/
-        (INR (fact (mult (S (S O)) (minus N l))))*
-        (pow y (mult (S (S O)) (minus N l)))`` (pred (minus N n))).
-Apply Rle_trans with (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``/(INR (mult (fact (mult (S (S O)) (S (plus l k)))) (fact (mult (S (S O)) (minus N l)))))*(pow C (mult (S (S O)) (S (plus N k))))`` (pred (minus N k))) (pred N)).
-Apply sum_Rle; Intros.
-Apply sum_Rle; Intros.
-Unfold Rdiv; Repeat Rewrite Rabsolu_mult.
-Do 2 Rewrite pow_1_abs.
-Do 2 Rewrite Rmult_1l.
-Rewrite (Rabsolu_right ``/(INR (fact (mult (S (S O)) (S (plus n0 n)))))``).
-Rewrite (Rabsolu_right ``/(INR (fact (mult (S (S O)) (minus N n0))))``).
-Rewrite mult_INR.
-Rewrite Rinv_Rmult.
-Repeat Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Rewrite <- Rmult_assoc.
-Rewrite <- (Rmult_sym ``/(INR (fact (mult (S (S O)) (minus N n0))))``).
-Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Do 2 Rewrite <- Pow_Rabsolu.
-Apply Rle_trans with ``(pow (Rabsolu x) (mult (S (S O)) (S (plus n0 n))))*(pow C (mult (S (S O)) (minus N n0)))``.
-Apply Rle_monotony.
-Apply pow_le; Apply Rabsolu_pos.
-Apply pow_incr.
-Split.
-Apply Rabsolu_pos.
-Unfold C.
-Apply Rle_trans with (Rmax (Rabsolu x) (Rabsolu y)); Apply RmaxLess2.
-Apply Rle_trans with ``(pow C (mult (S (S O)) (S (plus n0 n))))*(pow C (mult (S (S O)) (minus N n0)))``.
-Do 2 Rewrite <- (Rmult_sym ``(pow C (mult (S (S O)) (minus N n0)))``).
-Apply Rle_monotony.
-Apply pow_le.
-Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Unfold C; Apply RmaxLess1.
-Apply pow_incr.
-Split.
-Apply Rabsolu_pos.
-Unfold C; Apply Rle_trans with (Rmax (Rabsolu x) (Rabsolu y)).
-Apply RmaxLess1.
-Apply RmaxLess2.
-Right.
-Replace (mult (2) (S (plus N n))) with (plus (mult (2) (minus N n0)) (mult (2) (S (plus n0 n)))).
-Rewrite pow_add.
-Apply Rmult_sym.
-Apply INR_eq; Rewrite plus_INR; Do 3 Rewrite mult_INR.
-Rewrite minus_INR.
-Repeat Rewrite S_INR; Do 2 Rewrite plus_INR; Ring.
-Apply le_trans with (pred (minus N n)).
-Exact H1.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_trans with (sum_f_R0
-     [k:nat]
-        (sum_f_R0
-          [l:nat]
-           ``/(INR
-              (mult (fact (mult (S (S O)) (S (plus l k))))
-              (fact (mult (S (S O)) (minus N l)))))*
-           (pow C (mult (S (S (S (S O)))) N))`` (pred (minus N k)))
-     (pred N)).
-Apply sum_Rle; Intros.
-Apply sum_Rle; Intros.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv.
-Rewrite mult_INR; Apply Rmult_lt_pos; Apply INR_fact_lt_0.
-Apply Rle_pow.
-Unfold C; Apply RmaxLess1.
-Replace (mult (4) N) with (mult (2) (mult (2) N)); [Idtac | Ring].
-Apply mult_le.
-Replace (mult (2) N) with (S (plus N (pred N))).
-Apply le_n_S.
-Apply le_reg_l; Assumption.
-Rewrite pred_of_minus.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Rewrite minus_INR.
-Repeat Rewrite S_INR; Ring.
-Apply lt_le_S; Assumption.
-Apply Rle_trans with (sum_f_R0
-     [k:nat]
-        (sum_f_R0
-          [l:nat]
-         ``(pow C (mult (S (S (S (S O)))) N))*(Rsqr (/(INR (fact (S (plus N k))))))`` (pred (minus N k)))
-     (pred N)).
-Apply sum_Rle; Intros.
-Apply sum_Rle; Intros.
-Rewrite <- (Rmult_sym ``(pow C (mult (S (S (S (S O)))) N))``).
-Apply Rle_monotony.
-Apply pow_le.
-Left; Apply Rlt_le_trans with R1.
-Apply Rlt_R0_R1.
-Unfold C; Apply RmaxLess1.
-Replace ``/(INR
-      (mult (fact (mult (S (S O)) (S (plus n0 n))))
-      (fact (mult (S (S O)) (minus N n0)))))`` with ``(Binomial.C (mult (S (S O)) (S (plus N n))) (mult (S (S O)) (S (plus n0 n))))/(INR (fact (mult (S (S O)) (S (plus N n)))))``.
-Apply Rle_trans with ``(Binomial.C (mult (S (S O)) (S (plus N n))) (S (plus N n)))/(INR (fact (mult (S (S O)) (S (plus N n)))))``.
-Unfold Rdiv; Do 2 Rewrite <- (Rmult_sym ``/(INR (fact (mult (S (S O)) (S (plus N n)))))``).
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply C_maj.
-Apply mult_le.
-Apply le_n_S.
-Apply le_reg_r.
-Apply le_trans with (pred (minus N n)).
-Assumption.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Right.
-Unfold Rdiv; Rewrite Rmult_sym.
-Unfold Binomial.C.
-Unfold Rdiv; Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Replace (minus (mult (2) (S (plus N n))) (S (plus N n))) with (S (plus N n)).
-Rewrite Rinv_Rmult.
-Unfold Rsqr; Reflexivity.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_eq; Rewrite S_INR; Rewrite minus_INR.
-Rewrite mult_INR; Repeat Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_n_2n.
-Apply INR_fact_neq_0.
-Unfold Rdiv; Rewrite Rmult_sym.
-Unfold Binomial.C.
-Unfold Rdiv; Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Replace (minus (mult (2) (S (plus N n))) (mult (2) (S (plus n0 n)))) with (mult (2) (minus N n0)).
-Rewrite mult_INR.
-Reflexivity.
-Apply INR_eq; Rewrite minus_INR.
-Do 3 Rewrite mult_INR; Repeat Rewrite S_INR; Do 2 Rewrite plus_INR; Rewrite minus_INR.
-Ring.
-Apply le_trans with (pred (minus N n)).
-Assumption.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply mult_le.
-Apply le_n_S.
-Apply le_reg_r.
-Apply le_trans with (pred (minus N n)).
-Assumption.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply INR_fact_neq_0.
-Apply Rle_trans with (sum_f_R0 [k:nat]``(INR N)/(INR (fact (S N)))*(pow C (mult (S (S (S (S O)))) N))`` (pred N)).
-Apply sum_Rle; Intros.
-Rewrite <- (scal_sum [_:nat]``(pow C (mult (S (S (S (S O)))) N))`` (pred (minus N n)) ``(Rsqr (/(INR (fact (S (plus N n))))))``).
-Rewrite sum_cte.
-Rewrite <- Rmult_assoc.
-Do 2 Rewrite <- (Rmult_sym ``(pow C (mult (S (S (S (S O)))) N))``).
-Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Apply pow_le.
-Left; Apply Rlt_le_trans with R1.
-Apply Rlt_R0_R1.
-Unfold C; Apply RmaxLess1.
-Apply Rle_trans with ``(Rsqr (/(INR (fact (S (plus N n))))))*(INR N)``.
-Apply Rle_monotony.
-Apply pos_Rsqr.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_INR.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Rewrite Rmult_sym; Unfold Rdiv; Apply Rle_monotony.
-Apply pos_INR.
-Apply Rle_trans with ``/(INR (fact (S (plus N n))))``.
-Pattern 2 ``/(INR (fact (S (plus N n))))``; Rewrite <- Rmult_1r.
-Unfold Rsqr.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_monotony_contra with ``(INR (fact (S (plus N n))))``.
-Apply INR_fact_lt_0.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r.
-Replace R1 with (INR (S O)).
-Apply le_INR.
-Apply lt_le_S.
-Apply INR_lt; Apply INR_fact_lt_0.
-Reflexivity.
-Apply INR_fact_neq_0.
-Apply Rle_monotony_contra with ``(INR (fact (S (plus N n))))``.
-Apply INR_fact_lt_0.
-Rewrite <- Rinv_r_sym.
-Apply Rle_monotony_contra with ``(INR (fact (S N)))``.
-Apply INR_fact_lt_0.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym (INR (fact (S N)))).
-Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Apply le_INR.
-Apply fact_growing.
-Apply le_n_S.
-Apply le_plus_l.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Rewrite sum_cte.
-Apply Rle_trans with ``(pow C (mult (S (S (S (S O)))) N))/(INR (fact (pred N)))``.
-Rewrite <- (Rmult_sym ``(pow C (mult (S (S (S (S O)))) N))``).
-Unfold Rdiv; Rewrite Rmult_assoc; Apply Rle_monotony.
-Apply pow_le.
-Left; Apply Rlt_le_trans with R1.
-Apply Rlt_R0_R1.
-Unfold C; Apply RmaxLess1.
-Cut (S (pred N)) = N.
-Intro; Rewrite H0.
-Pattern 2 N; Rewrite <- H0.
-Do 2 Rewrite fact_simpl.
-Rewrite H0.
-Repeat Rewrite mult_INR.
-Repeat Rewrite Rinv_Rmult.
-Rewrite (Rmult_sym ``/(INR (S N))``).
-Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l.
-Pattern 2 ``/(INR (fact (pred N)))``; Rewrite <- Rmult_1r.
-Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_monotony_contra with (INR (S N)).
-Apply lt_INR_0; Apply lt_O_Sn.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Rewrite Rmult_1l.
-Apply le_INR; Apply le_n_Sn.
-Apply not_O_INR; Discriminate.
-Apply not_O_INR.
-Red; Intro; Rewrite H1 in H; Elim (lt_n_n ? H).
-Apply not_O_INR.
-Red; Intro; Rewrite H1 in H; Elim (lt_n_n ? H).
-Apply INR_fact_neq_0.
-Apply not_O_INR; Discriminate.
-Apply prod_neq_R0.
-Apply not_O_INR.
-Red; Intro; Rewrite H1 in H; Elim (lt_n_n ? H).
-Apply INR_fact_neq_0.
-Symmetry; Apply S_pred with O; Assumption.
-Right.
-Unfold Majxy.
-Unfold C.
-Replace (S (pred N)) with N.
-Reflexivity.
-Apply S_pred with O; Assumption.
-Qed.
-
-Lemma reste2_maj : (x,y:R;N:nat) (lt O N) -> ``(Rabsolu (Reste2 x y N))<=(Majxy x y N)``.
-Intros.
-Pose C := (Rmax R1 (Rmax (Rabsolu x) (Rabsolu y))).
-Unfold Reste2.
-Apply Rle_trans with (sum_f_R0
-     [k:nat]
-        (Rabsolu (sum_f_R0
-          [l:nat]
-           ``(pow ( -1) (S (plus l k)))/
-           (INR (fact (plus (mult (S (S O)) (S (plus l k))) (S O))))*
-           (pow x (plus (mult (S (S O)) (S (plus l k))) (S O)))*
-           (pow ( -1) (minus N l))/
-           (INR (fact (plus (mult (S (S O)) (minus N l)) (S O))))*
-           (pow y (plus (mult (S (S O)) (minus N l)) (S O)))`` (pred (minus N k))))
-     (pred N)).
-Apply (sum_Rabsolu [k:nat]
-        (sum_f_R0
-          [l:nat]
-           ``(pow ( -1) (S (plus l k)))/
-           (INR (fact (plus (mult (S (S O)) (S (plus l k))) (S O))))*
-           (pow x (plus (mult (S (S O)) (S (plus l k))) (S O)))*
-           (pow ( -1) (minus N l))/
-           (INR (fact (plus (mult (S (S O)) (minus N l)) (S O))))*
-           (pow y (plus (mult (S (S O)) (minus N l)) (S O)))`` (pred (minus N k))) (pred N)).
-Apply Rle_trans with (sum_f_R0
-     [k:nat]
-          (sum_f_R0
-            [l:nat]
-             (Rabsolu (``(pow ( -1) (S (plus l k)))/
-             (INR (fact (plus (mult (S (S O)) (S (plus l k))) (S O))))*
-             (pow x (plus (mult (S (S O)) (S (plus l k))) (S O)))*
-             (pow ( -1) (minus N l))/
-             (INR (fact (plus (mult (S (S O)) (minus N l)) (S O))))*
-             (pow y (plus (mult (S (S O)) (minus N l)) (S O)))``)) (pred (minus N k)))
-     (pred N)).
-Apply sum_Rle.
-Intros.
-Apply (sum_Rabsolu [l:nat]
-        ``(pow ( -1) (S (plus l n)))/
-        (INR (fact (plus (mult (S (S O)) (S (plus l n))) (S O))))*
-        (pow x (plus (mult (S (S O)) (S (plus l n))) (S O)))*
-        (pow ( -1) (minus N l))/
-        (INR (fact (plus (mult (S (S O)) (minus N l)) (S O))))*
-        (pow y (plus (mult (S (S O)) (minus N l)) (S O)))`` (pred (minus N n))).
-Apply Rle_trans with (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``/(INR (mult (fact (plus (mult (S (S O)) (S (plus l k))) (S O))) (fact (plus (mult (S (S O)) (minus N l)) (S O)))))*(pow C (mult (S (S O)) (S (S (plus N k)))))`` (pred (minus N k))) (pred N)).
-Apply sum_Rle; Intros.
-Apply sum_Rle; Intros.
-Unfold Rdiv; Repeat Rewrite Rabsolu_mult.
-Do 2 Rewrite pow_1_abs.
-Do 2 Rewrite Rmult_1l.
-Rewrite (Rabsolu_right ``/(INR (fact (plus (mult (S (S O)) (S (plus n0 n))) (S O))))``).
-Rewrite (Rabsolu_right ``/(INR (fact (plus (mult (S (S O)) (minus N n0)) (S O))))``).
-Rewrite mult_INR.
-Rewrite Rinv_Rmult.
-Repeat Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Rewrite <- Rmult_assoc.
-Rewrite <- (Rmult_sym ``/(INR (fact (plus (mult (S (S O)) (minus N n0)) (S O))))``).
-Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Do 2 Rewrite <- Pow_Rabsolu.
-Apply Rle_trans with ``(pow (Rabsolu x) (plus (mult (S (S O)) (S (plus n0 n))) (S O)))*(pow C (plus (mult (S (S O)) (minus N n0)) (S O)))``.
-Apply Rle_monotony.
-Apply pow_le; Apply Rabsolu_pos.
-Apply pow_incr.
-Split.
-Apply Rabsolu_pos.
-Unfold C.
-Apply Rle_trans with (Rmax (Rabsolu x) (Rabsolu y)); Apply RmaxLess2.
-Apply Rle_trans with ``(pow C (plus (mult (S (S O)) (S (plus n0 n))) (S O)))*(pow C (plus (mult (S (S O)) (minus N n0)) (S O)))``.
-Do 2 Rewrite <- (Rmult_sym ``(pow C (plus (mult (S (S O)) (minus N n0)) (S O)))``).
-Apply Rle_monotony.
-Apply pow_le.
-Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Unfold C; Apply RmaxLess1.
-Apply pow_incr.
-Split.
-Apply Rabsolu_pos.
-Unfold C; Apply Rle_trans with (Rmax (Rabsolu x) (Rabsolu y)).
-Apply RmaxLess1.
-Apply RmaxLess2.
-Right.
-Replace (mult (2) (S (S (plus N n)))) with (plus (plus (mult (2) (minus N n0)) (S O)) (plus (mult (2) (S (plus n0 n))) (S O))).
-Repeat Rewrite pow_add.
-Ring.
-Apply INR_eq; Repeat Rewrite plus_INR; Do 3 Rewrite mult_INR.
-Rewrite minus_INR.
-Repeat Rewrite S_INR; Do 2 Rewrite plus_INR; Ring.
-Apply le_trans with (pred (minus N n)).
-Exact H1.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply Rle_sym1; Left; Apply Rlt_Rinv.
-Apply INR_fact_lt_0.
-Apply Rle_sym1; Left; Apply Rlt_Rinv.
-Apply INR_fact_lt_0.
-Apply Rle_trans with (sum_f_R0
-     [k:nat]
-        (sum_f_R0
-          [l:nat]
-           ``/(INR
-              (mult (fact (plus (mult (S (S O)) (S (plus l k))) (S O)))
-              (fact (plus (mult (S (S O)) (minus N l)) (S O)))))*
-           (pow C (mult (S (S (S (S O)))) (S N)))`` (pred (minus N k)))
-     (pred N)).
-Apply sum_Rle; Intros.
-Apply sum_Rle; Intros.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv.
-Rewrite mult_INR; Apply Rmult_lt_pos; Apply INR_fact_lt_0.
-Apply Rle_pow.
-Unfold C; Apply RmaxLess1.
-Replace (mult (4) (S N)) with (mult (2) (mult (2) (S N))); [Idtac | Ring].
-Apply mult_le.
-Replace (mult (2) (S N)) with (S (S (plus N N))).
-Repeat Apply le_n_S.
-Apply le_reg_l.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply INR_eq; Do 2Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR.
-Repeat Rewrite S_INR; Ring.
-Apply Rle_trans with (sum_f_R0
-     [k:nat]
-        (sum_f_R0
-          [l:nat]
-         ``(pow C (mult (S (S (S (S O)))) (S N)))*(Rsqr (/(INR (fact (S (S (plus N k)))))))`` (pred (minus N k)))
-     (pred N)).
-Apply sum_Rle; Intros.
-Apply sum_Rle; Intros.
-Rewrite <- (Rmult_sym ``(pow C (mult (S (S (S (S O)))) (S N)))``).
-Apply Rle_monotony.
-Apply pow_le.
-Left; Apply Rlt_le_trans with R1.
-Apply Rlt_R0_R1.
-Unfold C; Apply RmaxLess1.
-Replace ``/(INR
-      (mult (fact (plus (mult (S (S O)) (S (plus n0 n))) (S O)))
-      (fact (plus (mult (S (S O)) (minus N n0)) (S O)))))`` with ``(Binomial.C (mult (S (S O)) (S (S (plus N n)))) (plus (mult (S (S O)) (S (plus n0 n))) (S O)))/(INR (fact (mult (S (S O)) (S (S (plus N n))))))``.
-Apply Rle_trans with ``(Binomial.C (mult (S (S O)) (S (S (plus N n)))) (S (S (plus N n))))/(INR (fact (mult (S (S O)) (S (S (plus N n))))))``.
-Unfold Rdiv; Do 2 Rewrite <- (Rmult_sym ``/(INR (fact (mult (S (S O)) (S (S (plus N n))))))``).
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply C_maj.
-Apply le_trans with (mult (2) (S (S (plus n0 n)))).
-Replace (mult (2) (S (S (plus n0 n)))) with (S (plus (mult (2) (S (plus n0 n))) (1))).
-Apply le_n_Sn.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply mult_le.
-Repeat Apply le_n_S.
-Apply le_reg_r.
-Apply le_trans with (pred (minus N n)).
-Assumption.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Right.
-Unfold Rdiv; Rewrite Rmult_sym.
-Unfold Binomial.C.
-Unfold Rdiv; Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Replace (minus (mult (2) (S (S (plus N n)))) (S (S (plus N n)))) with (S (S (plus N n))).
-Rewrite Rinv_Rmult.
-Unfold Rsqr; Reflexivity.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_eq; Do 2 Rewrite S_INR; Rewrite minus_INR.
-Rewrite mult_INR; Repeat Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_n_2n.
-Apply INR_fact_neq_0.
-Unfold Rdiv; Rewrite Rmult_sym.
-Unfold Binomial.C.
-Unfold Rdiv; Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Replace (minus (mult (2) (S (S (plus N n)))) (plus (mult (2) (S (plus n0 n))) (S O))) with (plus (mult (2) (minus N n0)) (S O)).
-Rewrite mult_INR.
-Reflexivity.
-Apply INR_eq; Rewrite minus_INR.
-Do 2 Rewrite plus_INR; Do 3 Rewrite mult_INR; Repeat Rewrite S_INR; Do 2 Rewrite plus_INR; Rewrite minus_INR.
-Ring.
-Apply le_trans with (pred (minus N n)).
-Assumption.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_trans with (mult (2) (S (S (plus n0 n)))).
-Replace (mult (2) (S (S (plus n0 n)))) with (S (plus (mult (2) (S (plus n0 n))) (1))).
-Apply le_n_Sn.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply mult_le.
-Repeat Apply le_n_S.
-Apply le_reg_r.
-Apply le_trans with (pred (minus N n)).
-Assumption.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply INR_fact_neq_0.
-Apply Rle_trans with (sum_f_R0 [k:nat]``(INR N)/(INR (fact (S (S N))))*(pow C (mult (S (S (S (S O)))) (S N)))`` (pred N)).
-Apply sum_Rle; Intros.
-Rewrite <- (scal_sum [_:nat]``(pow C (mult (S (S (S (S O)))) (S N)))`` (pred (minus N n)) ``(Rsqr (/(INR (fact (S (S (plus N n)))))))``).
-Rewrite sum_cte.
-Rewrite <- Rmult_assoc.
-Do 2 Rewrite <- (Rmult_sym ``(pow C (mult (S (S (S (S O)))) (S N)))``).
-Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Apply pow_le.
-Left; Apply Rlt_le_trans with R1.
-Apply Rlt_R0_R1.
-Unfold C; Apply RmaxLess1.
-Apply Rle_trans with ``(Rsqr (/(INR (fact (S (S (plus N n)))))))*(INR N)``.
-Apply Rle_monotony.
-Apply pos_Rsqr.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_INR.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n O) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Assumption.
-Apply lt_pred_n_n; Assumption.
-Apply le_trans with (pred N).
-Assumption.
-Apply le_pred_n.
-Rewrite Rmult_sym; Unfold Rdiv; Apply Rle_monotony.
-Apply pos_INR.
-Apply Rle_trans with ``/(INR (fact (S (S (plus N n)))))``.
-Pattern 2 ``/(INR (fact (S (S (plus N n)))))``; Rewrite <- Rmult_1r.
-Unfold Rsqr.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_monotony_contra with ``(INR (fact (S (S (plus N n)))))``.
-Apply INR_fact_lt_0.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r.
-Replace R1 with (INR (S O)).
-Apply le_INR.
-Apply lt_le_S.
-Apply INR_lt; Apply INR_fact_lt_0.
-Reflexivity.
-Apply INR_fact_neq_0.
-Apply Rle_monotony_contra with ``(INR (fact (S (S (plus N n)))))``.
-Apply INR_fact_lt_0.
-Rewrite <- Rinv_r_sym.
-Apply Rle_monotony_contra with ``(INR (fact (S (S N))))``.
-Apply INR_fact_lt_0.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym (INR (fact (S (S N))))).
-Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Apply le_INR.
-Apply fact_growing.
-Repeat Apply le_n_S.
-Apply le_plus_l.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Rewrite sum_cte.
-Apply Rle_trans with ``(pow C (mult (S (S (S (S O)))) (S N)))/(INR (fact N))``.
-Rewrite <- (Rmult_sym ``(pow C (mult (S (S (S (S O)))) (S N)))``).
-Unfold Rdiv; Rewrite Rmult_assoc; Apply Rle_monotony.
-Apply pow_le.
-Left; Apply Rlt_le_trans with R1.
-Apply Rlt_R0_R1.
-Unfold C; Apply RmaxLess1.
-Cut (S (pred N)) = N.
-Intro; Rewrite H0.
-Do 2 Rewrite fact_simpl.
-Repeat Rewrite mult_INR.
-Repeat Rewrite Rinv_Rmult.
-Apply Rle_trans with ``(INR (S (S N)))*(/(INR (S (S N)))*(/(INR (S N))*/(INR (fact N))))*
-   (INR N)``.
-Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym (INR N)).
-Rewrite (Rmult_sym (INR (S (S N)))).
-Apply Rle_monotony.
-Repeat Apply Rmult_le_pos.
-Left; Apply Rlt_Rinv; Apply lt_INR_0; Apply lt_O_Sn.
-Left; Apply Rlt_Rinv; Apply lt_INR_0; Apply lt_O_Sn.
-Left; Apply Rlt_Rinv.
-Apply INR_fact_lt_0.
-Apply pos_INR.
-Apply le_INR.
-Apply le_trans with (S N); Apply le_n_Sn.
-Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l.
-Apply Rle_trans with ``/(INR (S N))*/(INR (fact N))*(INR (S N))``.
-Repeat Rewrite Rmult_assoc.
-Repeat Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply lt_INR_0; Apply lt_O_Sn.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply le_INR; Apply le_n_Sn.
-Rewrite (Rmult_sym ``/(INR (S N))``).
-Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Right; Reflexivity.
-Apply not_O_INR; Discriminate.
-Apply not_O_INR; Discriminate.
-Apply not_O_INR; Discriminate.
-Apply INR_fact_neq_0.
-Apply not_O_INR; Discriminate.
-Apply prod_neq_R0; [Apply not_O_INR; Discriminate | Apply INR_fact_neq_0].
-Symmetry; Apply S_pred with O; Assumption.
-Right.
-Unfold Majxy.
-Unfold C.
-Reflexivity.
-Qed.
-
-Lemma reste1_cv_R0 : (x,y:R) (Un_cv (Reste1 x y) R0).
-Intros.
-Assert H := (Majxy_cv_R0 x y).
-Unfold Un_cv in H; Unfold R_dist in H.
-Unfold Un_cv; Unfold R_dist; Intros.
-Elim (H eps H0); Intros N0 H1.
-Exists (S N0); Intros.
-Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or.
-Apply Rle_lt_trans with (Rabsolu (Majxy x y (pred n))).
-Rewrite (Rabsolu_right (Majxy x y (pred n))).
-Apply reste1_maj.
-Apply lt_le_trans with (S N0).
-Apply lt_O_Sn.
-Assumption.
-Apply Rle_sym1.
-Unfold Majxy.
-Unfold Rdiv; Apply Rmult_le_pos.
-Apply pow_le.
-Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Apply RmaxLess1.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Replace (Majxy x y (pred n)) with ``(Majxy x y (pred n))-0``; [Idtac | Ring].
-Apply H1.
-Unfold ge; Apply le_S_n.
-Replace (S (pred n)) with n.
-Assumption.
-Apply S_pred with O.
-Apply lt_le_trans with (S N0); [Apply lt_O_Sn | Assumption].
-Qed.
-
-Lemma reste2_cv_R0 : (x,y:R) (Un_cv (Reste2 x y) R0).
-Intros.
-Assert H := (Majxy_cv_R0 x y).
-Unfold Un_cv in H; Unfold R_dist in H.
-Unfold Un_cv; Unfold R_dist; Intros.
-Elim (H eps H0); Intros N0 H1.
-Exists (S N0); Intros.
-Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or.
-Apply Rle_lt_trans with (Rabsolu (Majxy x y n)).
-Rewrite (Rabsolu_right (Majxy x y n)).
-Apply reste2_maj.
-Apply lt_le_trans with (S N0).
-Apply lt_O_Sn.
-Assumption.
-Apply Rle_sym1.
-Unfold Majxy.
-Unfold Rdiv; Apply Rmult_le_pos.
-Apply pow_le.
-Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Apply RmaxLess1.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Replace (Majxy x y n) with ``(Majxy x y n)-0``; [Idtac | Ring].
-Apply H1.
-Unfold ge; Apply le_trans with (S N0).
-Apply le_n_Sn.
-Exact H2.
-Qed.
-
-Lemma reste_cv_R0 : (x,y:R) (Un_cv (Reste x y) R0).
-Intros.
-Unfold Reste.
-Pose An := [n:nat](Reste2 x y n).
-Pose Bn := [n:nat](Reste1 x y (S n)).
-Cut (Un_cv [n:nat]``(An n)-(Bn n)`` ``0-0``) -> (Un_cv [N:nat]``(Reste2 x y N)-(Reste1 x y (S N))`` ``0``).
-Intro.
-Apply H.
-Apply CV_minus.
-Unfold An.
-Replace [n:nat](Reste2 x y n) with (Reste2 x y).
-Apply reste2_cv_R0.
-Reflexivity.
-Unfold Bn.
-Assert H0 := (reste1_cv_R0 x y).
-Unfold Un_cv in H0; Unfold R_dist in H0.
-Unfold Un_cv; Unfold R_dist; Intros.
-Elim (H0 eps H1); Intros N0 H2.
-Exists N0; Intros.
-Apply H2.
-Unfold ge; Apply le_trans with (S N0).
-Apply le_n_Sn.
-Apply le_n_S; Assumption.
-Unfold An Bn.
-Intro.
-Replace R0 with ``0-0``; [Idtac | Ring].
-Exact H.
-Qed.
-
-Theorem cos_plus : (x,y:R) ``(cos (x+y))==(cos x)*(cos y)-(sin x)*(sin y)``. 
-Intros. 
-Cut (Un_cv (C1 x y) ``(cos x)*(cos y)-(sin x)*(sin y)``). 
-Cut (Un_cv (C1 x y) ``(cos (x+y))``). 
-Intros. 
-Apply UL_sequence with (C1 x y); Assumption. 
-Apply C1_cvg. 
-Unfold Un_cv; Unfold R_dist. 
-Intros. 
-Assert H0 := (A1_cvg x). 
-Assert H1 := (A1_cvg y). 
-Assert H2 := (B1_cvg x). 
-Assert H3 := (B1_cvg y). 
-Assert H4 := (CV_mult ? ? ? ? H0 H1). 
-Assert H5 := (CV_mult ? ? ? ? H2 H3). 
-Assert H6 := (reste_cv_R0 x y).
-Unfold Un_cv in H4; Unfold Un_cv in H5; Unfold Un_cv in H6.
-Unfold R_dist in H4; Unfold R_dist in H5; Unfold R_dist in H6. 
-Cut ``0<eps/3``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0]]. 
-Elim (H4 ``eps/3`` H7); Intros N1 H8. 
-Elim (H5 ``eps/3`` H7); Intros N2 H9. 
-Elim (H6 ``eps/3`` H7); Intros N3 H10.
-Pose N := (S (S (max (max N1 N2) N3))). 
-Exists N. 
-Intros. 
-Cut n = (S (pred n)). 
-Intro; Rewrite H12. 
-Rewrite <- cos_plus_form. 
-Rewrite <- H12. 
-Apply Rle_lt_trans with ``(Rabsolu ((A1 x n)*(A1 y n)-(cos x)*(cos y)))+(Rabsolu ((sin x)*(sin y)-(B1 x (pred n))*(B1 y (pred n))+(Reste x y (pred n))))``. 
-Replace ``(A1 x n)*(A1 y n)-(B1 x (pred n))*(B1 y (pred n))+
-     (Reste x y (pred n))-((cos x)*(cos y)-(sin x)*(sin y))`` with ``((A1 x n)*(A1 y n)-(cos x)*(cos y))+((sin x)*(sin y)-(B1 x (pred n))*(B1 y (pred n))+(Reste x y (pred n)))``; [Apply Rabsolu_triang | Ring].
-Replace ``eps`` with ``eps/3+(eps/3+eps/3)``.
-Apply Rplus_lt. 
-Apply H8. 
-Unfold ge; Apply le_trans with N. 
-Unfold N. 
-Apply le_trans with (max N1 N2). 
-Apply le_max_l. 
-Apply le_trans with (max (max N1 N2) N3).
-Apply le_max_l.
-Apply le_trans with (S (max (max N1 N2) N3)); Apply le_n_Sn.
-Assumption. 
-Apply Rle_lt_trans with ``(Rabsolu ((sin x)*(sin y)-(B1 x (pred n))*(B1 y (pred n))))+(Rabsolu (Reste x y (pred n)))``.
-Apply Rabsolu_triang.
-Apply Rplus_lt.
-Rewrite <- Rabsolu_Ropp. 
-Rewrite Ropp_distr2. 
-Apply H9. 
-Unfold ge; Apply le_trans with (max N1 N2). 
-Apply le_max_r. 
-Apply le_S_n. 
-Rewrite <- H12. 
-Apply le_trans with N.
-Unfold N.
-Apply le_n_S.
-Apply le_trans with (max (max N1 N2) N3).
-Apply le_max_l.
-Apply le_n_Sn.
-Assumption.
-Replace (Reste x y (pred n)) with ``(Reste x y (pred n))-0``.
-Apply H10.
-Unfold ge.
-Apply le_S_n.
-Rewrite <- H12.
-Apply le_trans with N.
-Unfold N.
-Apply le_n_S.
-Apply le_trans with (max (max N1 N2) N3).
-Apply le_max_r.
-Apply le_n_Sn.
-Assumption.
-Ring.
-Pattern 4 eps; Replace eps with ``3*eps/3``.
-Ring.
-Unfold Rdiv.
-Rewrite <- Rmult_assoc.
-Apply Rinv_r_simpl_m.
-DiscrR.
-Apply lt_le_trans with (pred N).
-Unfold N; Simpl; Apply lt_O_Sn.
-Apply le_S_n.
-Rewrite <- H12.
-Replace (S (pred N)) with N.
-Assumption.
-Unfold N; Simpl; Reflexivity.
-Cut (lt O N). 
-Intro. 
-Cut (lt O n). 
-Intro. 
-Apply S_pred with O; Assumption.
-Apply lt_le_trans with N; Assumption. 
-Unfold N; Apply lt_O_Sn.
-Qed.
diff --git a/theories7/Reals/Cos_rel.v b/theories7/Reals/Cos_rel.v
deleted file mode 100644
index e29825ab..00000000
--- a/theories7/Reals/Cos_rel.v
+++ /dev/null
@@ -1,360 +0,0 @@
-(************************************************************************)
-(*  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: Cos_rel.v,v 1.1.2.1 2004/07/16 19:31:32 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo_def.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Definition A1 [x:R] : nat->R := [N:nat](sum_f_R0 [k:nat]``(pow (-1) k)/(INR (fact (mult (S (S O)) k)))*(pow x (mult (S (S O)) k))`` N). 
- 
-Definition B1 [x:R] : nat->R := [N:nat](sum_f_R0 [k:nat]``(pow (-1) k)/(INR (fact (plus (mult (S (S O)) k) (S O))))*(pow x (plus (mult (S (S O)) k) (S O)))`` N). 
- 
-Definition C1 [x,y:R] : nat -> R := [N:nat](sum_f_R0 [k:nat]``(pow (-1) k)/(INR (fact (mult (S (S O)) k)))*(pow (x+y) (mult (S (S O)) k))`` N). 
- 
-Definition Reste1 [x,y:R] : nat -> R := [N:nat](sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(pow (-1) (S (plus l k)))/(INR (fact (mult (S (S O)) (S (plus l k)))))*(pow x (mult (S (S O)) (S (plus l k))))*(pow (-1) (minus N l))/(INR (fact (mult (S (S O)) (minus N l))))*(pow y (mult (S (S O)) (minus N l)))`` (pred (minus N k))) (pred N)).
-
-Definition Reste2 [x,y:R] : nat -> R := [N:nat](sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(pow (-1) (S (plus l k)))/(INR (fact (plus (mult (S (S O)) (S (plus l k))) (S O))))*(pow x (plus (mult (S (S O)) (S (plus l k))) (S O)))*(pow (-1) (minus N l))/(INR (fact (plus (mult (S (S O)) (minus N l)) (S O))))*(pow y (plus (mult (S (S O)) (minus N l)) (S O)))`` (pred (minus N k))) (pred N)).
-
-Definition Reste [x,y:R] : nat -> R := [N:nat]``(Reste2 x y N)-(Reste1 x y (S N))``.
-
-(* Here is the main result that will be used to prove that (cos (x+y))=(cos x)(cos y)-(sin x)(sin y) *)
-Theorem cos_plus_form : (x,y:R;n:nat) (lt O n) -> ``(A1 x (S n))*(A1 y (S n))-(B1 x n)*(B1 y n)+(Reste x y n)``==(C1 x y (S n)). 
-Intros.
-Unfold A1 B1.
-Rewrite (cauchy_finite [k:nat]
-        ``(pow ( -1) k)/(INR (fact (mult (S (S O)) k)))*
-        (pow x (mult (S (S O)) k))`` [k:nat]
-      ``(pow ( -1) k)/(INR (fact (mult (S (S O)) k)))*
-      (pow y (mult (S (S O)) k))`` (S n)).
-Rewrite (cauchy_finite [k:nat]
-      ``(pow ( -1) k)/(INR (fact (plus (mult (S (S O)) k) (S O))))*
-      (pow x (plus (mult (S (S O)) k) (S O)))`` [k:nat]
-      ``(pow ( -1) k)/(INR (fact (plus (mult (S (S O)) k) (S O))))*
-      (pow y (plus (mult (S (S O)) k) (S O)))`` n H).
-Unfold Reste.
-Replace (sum_f_R0
-   [k:nat]
-      (sum_f_R0
-        [l:nat]
-         ``(pow ( -1) (S (plus l k)))/
-         (INR (fact (mult (S (S O)) (S (plus l k)))))*
-         (pow x (mult (S (S O)) (S (plus l k))))*
-         ((pow ( -1) (minus (S n) l))/
-         (INR (fact (mult (S (S O)) (minus (S n) l))))*
-         (pow y (mult (S (S O)) (minus (S n) l))))``
-        (pred (minus (S n) k))) (pred (S n))) with (Reste1 x y (S n)).
-Replace (sum_f_R0
-   [k:nat]
-      (sum_f_R0
-        [l:nat]
-         ``(pow ( -1) (S (plus l k)))/
-         (INR (fact (plus (mult (S (S O)) (S (plus l k))) (S O))))*
-         (pow x (plus (mult (S (S O)) (S (plus l k))) (S O)))*
-         ((pow ( -1) (minus n l))/
-         (INR (fact (plus (mult (S (S O)) (minus n l)) (S O))))*
-         (pow y (plus (mult (S (S O)) (minus n l)) (S O))))``
-        (pred (minus n k))) (pred n)) with (Reste2 x y n).
-Ring.
-Replace (sum_f_R0
-   [k:nat]
-      (sum_f_R0
-        [p:nat]
-         ``(pow ( -1) p)/(INR (fact (mult (S (S O)) p)))*
-         (pow x (mult (S (S O)) p))*((pow ( -1) (minus k p))/
-         (INR (fact (mult (S (S O)) (minus k p))))*
-         (pow y (mult (S (S O)) (minus k p))))`` k) (S n)) with (sum_f_R0 [k:nat](Rmult ``(pow (-1) k)/(INR (fact (mult (S (S O)) k)))`` (sum_f_R0 [l:nat]``(C (mult (S (S O)) k) (mult (S (S O)) l))*(pow x (mult (S (S O)) l))*(pow y (mult (S (S O)) (minus k l)))`` k)) (S n)).
-Pose sin_nnn := [n:nat]Cases n of O => R0 | (S p) => (Rmult ``(pow (-1) (S p))/(INR (fact (mult (S (S O)) (S p))))`` (sum_f_R0 [l:nat]``(C (mult (S (S O)) (S p)) (S (mult (S (S O)) l)))*(pow x (S (mult (S (S O)) l)))*(pow y (S (mult (S (S O)) (minus p l))))`` p)) end.
-Replace (Ropp (sum_f_R0
-       [k:nat]
-          (sum_f_R0
-            [p:nat]
-             ``(pow ( -1) p)/
-             (INR (fact (plus (mult (S (S O)) p) (S O))))*
-             (pow x (plus (mult (S (S O)) p) (S O)))*
-             ((pow ( -1) (minus k p))/
-             (INR (fact (plus (mult (S (S O)) (minus k p)) (S O))))*
-             (pow y (plus (mult (S (S O)) (minus k p)) (S O))))`` k)
-       n)) with (sum_f_R0 sin_nnn (S n)).
-Rewrite <- sum_plus.
-Unfold C1.
-Apply sum_eq; Intros.
-Induction i.
-Simpl.
-Rewrite Rplus_Ol.
-Replace (C O O) with R1.
-Unfold Rdiv; Rewrite Rinv_R1.
-Ring.
-Unfold C.
-Rewrite <- minus_n_n.
-Simpl.
-Unfold Rdiv; Rewrite Rmult_1r; Rewrite Rinv_R1; Ring.
-Unfold sin_nnn.
-Rewrite <- Rmult_Rplus_distr.
-Apply Rmult_mult_r.
-Rewrite binomial.
-Pose Wn := [i0:nat]``(C (mult (S (S O)) (S i)) i0)*(pow x i0)*
-         (pow y (minus (mult (S (S O)) (S i)) i0))``.
-Replace (sum_f_R0
-   [l:nat]
-      ``(C (mult (S (S O)) (S i)) (mult (S (S O)) l))*
-      (pow x (mult (S (S O)) l))*
-      (pow y (mult (S (S O)) (minus (S i) l)))`` (S i)) with (sum_f_R0 [l:nat](Wn (mult (2) l)) (S i)).
-Replace (sum_f_R0
-     [l:nat]
-        ``(C (mult (S (S O)) (S i)) (S (mult (S (S O)) l)))*
-        (pow x (S (mult (S (S O)) l)))*
-        (pow y (S (mult (S (S O)) (minus i l))))`` i) with (sum_f_R0 [l:nat](Wn (S (mult (2) l))) i).
-Rewrite Rplus_sym.
-Apply sum_decomposition.
-Apply sum_eq; Intros.
-Unfold Wn.
-Apply Rmult_mult_r.
-Replace (minus (mult (2) (S i)) (S (mult (2) i0))) with (S (mult (2) (minus i i0))).
-Reflexivity.
-Apply INR_eq.
-Rewrite S_INR; Rewrite mult_INR.
-Repeat Rewrite minus_INR.
-Rewrite mult_INR; Repeat Rewrite S_INR.
-Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Replace (mult (2) (S i)) with (S (S (mult (2) i))).
-Apply le_n_S.
-Apply le_trans with (mult (2) i).
-Apply mult_le; Assumption.
-Apply le_n_Sn.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Assumption.
-Apply sum_eq; Intros.
-Unfold Wn.
-Apply Rmult_mult_r.
-Replace (minus (mult (2) (S i)) (mult (2) i0)) with (mult (2) (minus (S i) i0)).
-Reflexivity.
-Apply INR_eq.
-Rewrite mult_INR.
-Repeat Rewrite minus_INR.
-Rewrite mult_INR; Repeat Rewrite S_INR.
-Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply mult_le; Assumption.
-Assumption.
-Rewrite <- (Ropp_Ropp (sum_f_R0 sin_nnn (S n))).
-Apply eq_Ropp.
-Replace ``-(sum_f_R0 sin_nnn (S n))`` with ``-1*(sum_f_R0 sin_nnn (S n))``; [Idtac | Ring].
-Rewrite scal_sum.
-Rewrite decomp_sum.
-Replace (sin_nnn O) with R0.
-Rewrite Rmult_Ol; Rewrite Rplus_Ol.
-Replace (pred (S n)) with n; [Idtac | Reflexivity].
-Apply sum_eq; Intros.
-Rewrite Rmult_sym.
-Unfold sin_nnn.
-Rewrite scal_sum.
-Rewrite scal_sum.
-Apply sum_eq; Intros.
-Unfold Rdiv.
-Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym ``/(INR (fact (mult (S (S O)) (S i))))``).
-Repeat Rewrite <- Rmult_assoc.
-Rewrite <- (Rmult_sym ``/(INR (fact (mult (S (S O)) (S i))))``).
-Repeat Rewrite <- Rmult_assoc.
-Replace ``/(INR (fact (mult (S (S O)) (S i))))*
-   (C (mult (S (S O)) (S i)) (S (mult (S (S O)) i0)))`` with ``/(INR (fact (plus (mult (S (S O)) i0) (S O))))*/(INR (fact (plus (mult (S (S O)) (minus i i0)) (S O))))``.
-Replace (S (mult (2) i0)) with (plus (mult (2) i0) (1)); [Idtac | Ring].
-Replace (S (mult (2) (minus i i0))) with (plus (mult (2) (minus i i0)) (1)); [Idtac | Ring].
-Replace ``(pow (-1) (S i))`` with ``-1*(pow (-1) i0)*(pow (-1) (minus i i0))``.
-Ring.
-Simpl.
-Pattern 2 i; Replace i with (plus i0 (minus i i0)).
-Rewrite pow_add.
-Ring.
-Symmetry; Apply le_plus_minus; Assumption.
-Unfold C.
-Unfold Rdiv; Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Rewrite Rinv_Rmult.
-Replace (S (mult (S (S O)) i0)) with (plus (mult (2) i0) (1)); [Apply Rmult_mult_r | Ring].
-Replace (minus (mult (2) (S i)) (plus (mult (2) i0) (1))) with (plus (mult (2) (minus i i0)) (1)).
-Reflexivity.
-Apply INR_eq.
-Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite minus_INR.
-Rewrite plus_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Replace (plus (mult (2) i0) (1)) with (S (mult (2) i0)).
-Replace (mult (2) (S i)) with (S (S (mult (2) i))).
-Apply le_n_S.
-Apply le_trans with (mult (2) i).
-Apply mult_le; Assumption.
-Apply le_n_Sn.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Assumption.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Reflexivity.
-Apply lt_O_Sn.
-Apply sum_eq; Intros.
-Rewrite scal_sum.
-Apply sum_eq; Intros.
-Unfold Rdiv.
-Repeat Rewrite <- Rmult_assoc.
-Rewrite <- (Rmult_sym ``/(INR (fact (mult (S (S O)) i)))``).
-Repeat Rewrite <- Rmult_assoc.
-Replace ``/(INR (fact (mult (S (S O)) i)))*
-   (C (mult (S (S O)) i) (mult (S (S O)) i0))`` with ``/(INR (fact (mult (S (S O)) i0)))*/(INR (fact (mult (S (S O)) (minus i i0))))``.
-Replace ``(pow (-1) i)`` with ``(pow (-1) i0)*(pow (-1) (minus i i0))``.
-Ring.
-Pattern 2 i; Replace i with (plus i0 (minus i i0)).
-Rewrite pow_add.
-Ring.
-Symmetry; Apply le_plus_minus; Assumption.
-Unfold C.
-Unfold Rdiv; Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Rewrite Rinv_Rmult.
-Replace (minus (mult (2) i) (mult (2) i0)) with (mult (2) (minus i i0)).
-Reflexivity.
-Apply INR_eq.
-Rewrite mult_INR; Repeat Rewrite minus_INR.
-Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply mult_le; Assumption.
-Assumption.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Unfold Reste2; Apply sum_eq; Intros.
-Apply sum_eq; Intros.
-Unfold Rdiv; Ring. 
-Unfold Reste1; Apply sum_eq; Intros.
-Apply sum_eq; Intros.
-Unfold Rdiv; Ring.
-Apply lt_O_Sn.
-Qed.
-
-Lemma pow_sqr : (x:R;i:nat) (pow x (mult (2) i))==(pow ``x*x`` i). 
-Intros. 
-Assert H := (pow_Rsqr x i).
-Unfold Rsqr in H; Exact H.
-Qed. 
- 
-Lemma A1_cvg : (x:R) (Un_cv (A1 x) (cos x)). 
-Intro. 
-Assert H := (exist_cos ``x*x``). 
-Elim H; Intros. 
-Assert p_i := p. 
-Unfold cos_in in p. 
-Unfold cos_n infinit_sum in p. 
-Unfold R_dist in p. 
-Cut ``(cos x)==x0``. 
-Intro. 
-Rewrite H0. 
-Unfold Un_cv; Unfold R_dist; Intros. 
-Elim (p eps H1); Intros. 
-Exists x1; Intros. 
-Unfold A1. 
-Replace (sum_f_R0 ([k:nat]``(pow ( -1) k)/(INR (fact (mult (S (S O)) k)))*(pow x (mult (S (S O)) k))``) n) with (sum_f_R0 ([i:nat]``(pow ( -1) i)/(INR (fact (mult (S (S O)) i)))*(pow (x*x) i)``) n). 
-Apply H2; Assumption. 
-Apply sum_eq. 
-Intros. 
-Replace ``(pow (x*x) i)`` with ``(pow x (mult (S (S O)) i))``. 
-Reflexivity. 
-Apply pow_sqr. 
-Unfold cos. 
-Case (exist_cos (Rsqr x)). 
-Unfold Rsqr; Intros. 
-Unfold cos_in in p_i. 
-Unfold cos_in in c. 
-Apply unicity_sum with [i:nat]``(cos_n i)*(pow (x*x) i)``; Assumption. 
-Qed. 
- 
-Lemma C1_cvg : (x,y:R) (Un_cv (C1 x y) (cos (Rplus x y))). 
-Intros. 
-Assert H := (exist_cos ``(x+y)*(x+y)``). 
-Elim H; Intros. 
-Assert p_i := p. 
-Unfold cos_in in p. 
-Unfold cos_n infinit_sum in p. 
-Unfold R_dist in p. 
-Cut ``(cos (x+y))==x0``. 
-Intro. 
-Rewrite H0. 
-Unfold Un_cv; Unfold R_dist; Intros. 
-Elim (p eps H1); Intros. 
-Exists x1; Intros. 
-Unfold C1. 
-Replace (sum_f_R0 ([k:nat]``(pow ( -1) k)/(INR (fact (mult (S (S O)) k)))*(pow (x+y) (mult (S (S O)) k))``) n) with (sum_f_R0 ([i:nat]``(pow ( -1) i)/(INR (fact (mult (S (S O)) i)))*(pow ((x+y)*(x+y)) i)``) n). 
-Apply H2; Assumption. 
-Apply sum_eq. 
-Intros. 
-Replace ``(pow ((x+y)*(x+y)) i)`` with ``(pow (x+y) (mult (S (S O)) i))``. 
-Reflexivity. 
-Apply pow_sqr. 
-Unfold cos. 
-Case (exist_cos (Rsqr ``x+y``)). 
-Unfold Rsqr; Intros. 
-Unfold cos_in in p_i. 
-Unfold cos_in in c. 
-Apply unicity_sum with [i:nat]``(cos_n i)*(pow ((x+y)*(x+y)) i)``; Assumption. 
-Qed. 
- 
-Lemma B1_cvg : (x:R) (Un_cv (B1 x) (sin x)). 
-Intro. 
-Case (Req_EM x R0); Intro. 
-Rewrite H. 
-Rewrite sin_0. 
-Unfold B1. 
-Unfold Un_cv; Unfold R_dist; Intros; Exists O; Intros. 
-Replace (sum_f_R0 ([k:nat]``(pow ( -1) k)/(INR (fact (plus (mult (S (S O)) k) (S O))))*(pow 0 (plus (mult (S (S O)) k) (S O)))``) n) with R0. 
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption. 
-Induction n. 
-Simpl; Ring. 
-Rewrite tech5; Rewrite <- Hrecn. 
-Simpl; Ring. 
-Unfold ge; Apply le_O_n. 
-Assert H0 := (exist_sin ``x*x``). 
-Elim H0; Intros. 
-Assert p_i := p. 
-Unfold sin_in in p. 
-Unfold sin_n infinit_sum in p. 
-Unfold R_dist in p. 
-Cut ``(sin x)==x*x0``. 
-Intro. 
-Rewrite H1. 
-Unfold Un_cv; Unfold R_dist; Intros. 
-Cut ``0<eps/(Rabsolu x)``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption]]. 
-Elim (p ``eps/(Rabsolu x)`` H3); Intros. 
-Exists x1; Intros. 
-Unfold B1. 
-Replace (sum_f_R0 ([k:nat]``(pow ( -1) k)/(INR (fact (plus (mult (S (S O)) k) (S O))))*(pow x (plus (mult (S (S O)) k) (S O)))``) n) with (Rmult x (sum_f_R0 ([i:nat]``(pow ( -1) i)/(INR (fact (plus (mult (S (S O)) i) (S O))))*(pow (x*x) i)``) n)). 
-Replace (Rminus (Rmult x (sum_f_R0 ([i:nat]``(pow ( -1) i)/(INR (fact (plus (mult (S (S O)) i) (S O))))*(pow (x*x) i)``) n)) (Rmult x x0)) with (Rmult x (Rminus (sum_f_R0 ([i:nat]``(pow ( -1) i)/(INR (fact (plus (mult (S (S O)) i) (S O))))*(pow (x*x) i)``) n) x0)); [Idtac | Ring]. 
-Rewrite Rabsolu_mult. 
-Apply Rlt_monotony_contra with ``/(Rabsolu x)``. 
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption. 
-Rewrite <- Rmult_assoc. 
-Rewrite <- Rinv_l_sym. 
-Rewrite Rmult_1l; Rewrite <- (Rmult_sym eps); Unfold Rdiv in H4; Apply H4; Assumption. 
-Apply Rabsolu_no_R0; Assumption. 
-Rewrite scal_sum. 
-Apply sum_eq. 
-Intros. 
-Rewrite pow_add. 
-Rewrite pow_sqr. 
-Simpl. 
-Ring. 
-Unfold sin. 
-Case (exist_sin (Rsqr x)). 
-Unfold Rsqr; Intros. 
-Unfold sin_in in p_i. 
-Unfold sin_in in s. 
-Assert H1 := (unicity_sum [i:nat]``(sin_n i)*(pow (x*x) i)`` x0 x1 p_i s). 
-Rewrite H1; Reflexivity. 
-Qed. 
diff --git a/theories7/Reals/DiscrR.v b/theories7/Reals/DiscrR.v
deleted file mode 100644
index 31c90727..00000000
--- a/theories7/Reals/DiscrR.v
+++ /dev/null
@@ -1,58 +0,0 @@
-(************************************************************************)
-(*  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: DiscrR.v,v 1.1.2.1 2004/07/16 19:31:32 herbelin Exp $       i*)
-
-Require RIneq.
-Require Omega.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Lemma Rlt_R0_R2 : ``0<2``.
-Replace ``2`` with (INR (2)); [Apply lt_INR_0; Apply lt_O_Sn | Reflexivity].
-Qed.
-
-Lemma Rplus_lt_pos : (x,y:R) ``0<x`` -> ``0<y`` -> ``0<x+y``.
-Intros.
-Apply Rlt_trans with x.
-Assumption. 
-Pattern 1 x; Rewrite <- Rplus_Or.
-Apply Rlt_compatibility.
-Assumption.
-Qed.
-
-Lemma IZR_eq : (z1,z2:Z) z1=z2 -> (IZR z1)==(IZR z2).
-Intros; Rewrite H; Reflexivity.
-Qed.
-
-Lemma IZR_neq : (z1,z2:Z) `z1<>z2` -> ``(IZR z1)<>(IZR z2)``.
-Intros; Red; Intro; Elim H; Apply eq_IZR; Assumption.
-Qed.
-
-Tactic Definition DiscrR :=
-  Try Match Context With
-  | [ |- ~(?1==?2) ] -> Replace ``2`` with (IZR `2`); [Replace R1 with (IZR `1`); [Replace R0 with (IZR `0`); [Repeat Rewrite <- plus_IZR Orelse Rewrite <- mult_IZR Orelse Rewrite <- Ropp_Ropp_IZR Orelse Rewrite Z_R_minus; Apply IZR_neq; Try Discriminate | Reflexivity] | Reflexivity] | Reflexivity].
-
-Recursive Tactic Definition Sup0 :=
-  Match Context With
-  | [ |- ``0<1`` ] -> Apply Rlt_R0_R1
-  | [ |- ``0<?1`` ] -> Repeat (Apply Rmult_lt_pos Orelse Apply Rplus_lt_pos; Try Apply Rlt_R0_R1 Orelse Apply Rlt_R0_R2)
-  | [ |- ``?1>0`` ] -> Change ``0<?1``; Sup0.
-
-Tactic Definition SupOmega := Replace ``2`` with (IZR `2`); [Replace R1 with (IZR `1`); [Replace R0 with (IZR `0`); [Repeat Rewrite <- plus_IZR Orelse Rewrite <- mult_IZR Orelse Rewrite <- Ropp_Ropp_IZR Orelse Rewrite Z_R_minus; Apply IZR_lt; Omega | Reflexivity] | Reflexivity] | Reflexivity].
-  
-Recursive Tactic Definition Sup :=
-  Match Context With
-  | [ |- (Rgt ?1 ?2) ] -> Change ``?2<?1``; Sup
-  | [ |- ``0<?1`` ] -> Sup0
-  | [ |- (Rlt (Ropp ?1) R0) ] -> Rewrite <- Ropp_O; Sup
-  | [ |- (Rlt (Ropp ?1) (Ropp ?2)) ] -> Apply Rlt_Ropp; Sup
-  | [ |- (Rlt (Ropp ?1) ?2) ] -> Apply Rlt_trans with ``0``; Sup
-  | [ |- (Rlt ?1 ?2) ] -> SupOmega
-  | _ -> Idtac.
-
-Tactic Definition RCompute := Replace ``2`` with (IZR `2`); [Replace R1 with (IZR `1`); [Replace R0 with (IZR `0`); [Repeat Rewrite <- plus_IZR Orelse Rewrite <- mult_IZR Orelse Rewrite <- Ropp_Ropp_IZR Orelse Rewrite Z_R_minus; Apply IZR_eq; Try Reflexivity | Reflexivity] | Reflexivity] | Reflexivity].
diff --git a/theories7/Reals/Exp_prop.v b/theories7/Reals/Exp_prop.v
deleted file mode 100644
index 6ed9c00b..00000000
--- a/theories7/Reals/Exp_prop.v
+++ /dev/null
@@ -1,890 +0,0 @@
-(************************************************************************)
-(*  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: Exp_prop.v,v 1.1.2.1 2004/07/16 19:31:32 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo.
-Require Ranalysis1.
-Require PSeries_reg.
-Require Div2.
-Require Even.
-Require Max.
-V7only [Import R_scope.].
-Open Local Scope nat_scope.
-V7only [Import nat_scope.].
-Open Local Scope R_scope.
-
-Definition E1 [x:R] : nat->R := [N:nat](sum_f_R0 [k:nat]``/(INR (fact k))*(pow x k)`` N).
-
-Lemma E1_cvg : (x:R) (Un_cv (E1 x) (exp x)).
-Intro; Unfold exp; Unfold projT1.
-Case (exist_exp x); Intro.
-Unfold exp_in Un_cv; Unfold infinit_sum E1; Trivial.
-Qed.
-
-Definition Reste_E [x,y:R] : nat->R := [N:nat](sum_f_R0 [k:nat](sum_f_R0 [l:nat]``/(INR (fact (S (plus l k))))*(pow x (S (plus l k)))*(/(INR (fact (minus N l)))*(pow y (minus N l)))`` (pred (minus N k))) (pred N)).
-
-Lemma exp_form : (x,y:R;n:nat) (lt O n) -> ``(E1 x n)*(E1 y n)-(Reste_E x y n)==(E1 (x+y) n)``.
-Intros; Unfold E1.
-Rewrite cauchy_finite.
-Unfold Reste_E; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Apply sum_eq; Intros.
-Rewrite binomial.
-Rewrite scal_sum; Apply sum_eq; Intros.
-Unfold C; Unfold Rdiv; Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym (INR (fact i))); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite Rinv_Rmult.
-Ring.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply H.
-Qed.
-
-Definition maj_Reste_E [x,y:R] : nat->R := [N:nat]``4*(pow (Rmax R1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (S (S O)) N))/(Rsqr (INR (fact (div2 (pred N)))))``.
-
-Lemma Rle_Rinv : (x,y:R) ``0<x`` -> ``0<y`` -> ``x<=y`` -> ``/y<=/x``.
-Intros; Apply Rle_monotony_contra with x.
-Apply H.
-Rewrite <- Rinv_r_sym.
-Apply Rle_monotony_contra with y.
-Apply H0.
-Rewrite Rmult_1r; Rewrite Rmult_sym; Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Apply H1.
-Red; Intro; Rewrite H2 in H0; Elim (Rlt_antirefl ? H0).
-Red; Intro; Rewrite H2 in H; Elim (Rlt_antirefl ? H).
-Qed.
-
-(**********)
-Lemma div2_double : (N:nat) (div2 (mult (2) N))=N.
-Intro; Induction N.
-Reflexivity.
-Replace (mult (2) (S N)) with (S (S (mult (2) N))).
-Simpl; Simpl in HrecN; Rewrite HrecN; Reflexivity.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Qed.
-
-Lemma div2_S_double : (N:nat) (div2 (S (mult (2) N)))=N.
-Intro; Induction N.
-Reflexivity.
-Replace (mult (2) (S N)) with (S (S (mult (2) N))).
-Simpl; Simpl in HrecN; Rewrite HrecN; Reflexivity.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Qed.
-
-Lemma div2_not_R0 : (N:nat) (lt (1) N) -> (lt O (div2 N)).
-Intros; Induction N.
-Elim (lt_n_O ? H).
-Cut (lt (1) N)\/N=(1).
-Intro; Elim H0; Intro.
-Assert H2 := (even_odd_dec N).
-Elim H2; Intro.
-Rewrite <- (even_div2 ? a); Apply HrecN; Assumption.
-Rewrite <- (odd_div2 ? b); Apply lt_O_Sn.
-Rewrite H1; Simpl; Apply lt_O_Sn.
-Inversion H.
-Right; Reflexivity.
-Left; Apply lt_le_trans with (2); [Apply lt_n_Sn | Apply H1].
-Qed.
-
-Lemma Reste_E_maj : (x,y:R;N:nat) (lt O N) -> ``(Rabsolu (Reste_E x y N))<=(maj_Reste_E x y N)``.
-Intros; Pose M := (Rmax R1 (Rmax (Rabsolu x) (Rabsolu y))).
-Apply Rle_trans with (Rmult (pow M (mult (2) N)) (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``/(Rsqr (INR (fact (div2 (S N)))))`` (pred (minus N k))) (pred N))). 
-Unfold Reste_E.
-Apply Rle_trans with (sum_f_R0 [k:nat](Rabsolu (sum_f_R0 [l:nat]``/(INR (fact (S (plus l k))))*(pow x (S (plus l k)))*(/(INR (fact (minus N l)))*(pow y (minus N l)))`` (pred (minus N k)))) (pred N)).
-Apply (sum_Rabsolu [k:nat](sum_f_R0 [l:nat]``/(INR (fact (S (plus l k))))*(pow x (S (plus l k)))*(/(INR (fact (minus N l)))*(pow y (minus N l)))`` (pred (minus N k))) (pred N)).
-Apply Rle_trans with (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(Rabsolu (/(INR (fact (S (plus l k))))*(pow x (S (plus l k)))*(/(INR (fact (minus N l)))*(pow y (minus N l)))))`` (pred (minus N k))) (pred N)).
-Apply sum_Rle; Intros.
-Apply (sum_Rabsolu [l:nat]``/(INR (fact (S (plus l n))))*(pow x (S (plus l n)))*(/(INR (fact (minus N l)))*(pow y (minus N l)))``).
-Apply Rle_trans with (sum_f_R0 [k:nat](sum_f_R0 [l:nat]``(pow M (mult (S (S O)) N))*/(INR (fact (S l)))*/(INR (fact (minus N l)))`` (pred (minus N k))) (pred N)).
-Apply sum_Rle; Intros.
-Apply sum_Rle; Intros.
-Repeat Rewrite Rabsolu_mult.
-Do 2 Rewrite <- Pow_Rabsolu.
-Rewrite (Rabsolu_right ``/(INR (fact (S (plus n0 n))))``).
-Rewrite (Rabsolu_right ``/(INR (fact (minus N n0)))``).
-Replace ``/(INR (fact (S (plus n0 n))))*(pow (Rabsolu x) (S (plus n0 n)))*
-   (/(INR (fact (minus N n0)))*(pow (Rabsolu y) (minus N n0)))`` with ``/(INR (fact (minus N n0)))*/(INR (fact (S (plus n0 n))))*(pow (Rabsolu x) (S (plus n0 n)))*(pow (Rabsolu y) (minus N n0))``; [Idtac | Ring].
-Rewrite <- (Rmult_sym ``/(INR (fact (minus N n0)))``).
-Repeat Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_trans with ``/(INR (fact (S n0)))*(pow (Rabsolu x) (S (plus n0 n)))*(pow (Rabsolu y) (minus N n0))``.
-Rewrite (Rmult_sym ``/(INR (fact (S (plus n0 n))))``); Rewrite (Rmult_sym ``/(INR (fact (S n0)))``); Repeat Rewrite Rmult_assoc; Apply Rle_monotony.
-Apply pow_le; Apply Rabsolu_pos.
-Rewrite (Rmult_sym ``/(INR (fact (S n0)))``); Apply Rle_monotony.
-Apply pow_le; Apply Rabsolu_pos.
-Apply Rle_Rinv.
-Apply INR_fact_lt_0.
-Apply INR_fact_lt_0.
-Apply le_INR; Apply fact_growing; Apply le_n_S.
-Apply le_plus_l.
-Rewrite (Rmult_sym ``(pow M (mult (S (S O)) N))``); Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_trans with ``(pow M (S (plus n0 n)))*(pow (Rabsolu y) (minus N n0))``.
-Do 2 Rewrite <- (Rmult_sym ``(pow (Rabsolu y) (minus N n0))``).
-Apply Rle_monotony.
-Apply pow_le; Apply Rabsolu_pos.
-Apply pow_incr; Split.
-Apply Rabsolu_pos.
-Apply Rle_trans with (Rmax (Rabsolu x) (Rabsolu y)).
-Apply RmaxLess1.
-Unfold M; Apply RmaxLess2.
-Apply Rle_trans with ``(pow M (S (plus n0 n)))*(pow M (minus N n0))``.
-Apply Rle_monotony.
-Apply pow_le; Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Unfold M; Apply RmaxLess1.
-Apply pow_incr; Split.
-Apply Rabsolu_pos.
-Apply Rle_trans with (Rmax (Rabsolu x) (Rabsolu y)).
-Apply RmaxLess2.
-Unfold M; Apply RmaxLess2.
-Rewrite <- pow_add; Replace (plus (S (plus n0 n)) (minus N n0)) with (plus N (S n)).
-Apply Rle_pow.
-Unfold M; Apply RmaxLess1.
-Replace (mult (2) N) with (plus N N); [Idtac | Ring].
-Apply le_reg_l.
-Replace N with (S (pred N)).
-Apply le_n_S; Apply H0.
-Symmetry; Apply S_pred with O; Apply H.
-Apply INR_eq; Do 2 Rewrite plus_INR; Do 2 Rewrite S_INR; Rewrite plus_INR; Rewrite minus_INR.
-Ring.
-Apply le_trans with (pred (minus N n)).
-Apply H1.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Apply H0.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n (0)) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Apply H0.
-Apply lt_pred_n_n.
-Apply H.
-Apply le_trans with (pred N).
-Apply H0.
-Apply le_pred_n.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Rewrite scal_sum.
-Apply sum_Rle; Intros.
-Rewrite <- Rmult_sym.
-Rewrite scal_sum.
-Apply sum_Rle; Intros.
-Rewrite (Rmult_sym ``/(Rsqr (INR (fact (div2 (S N)))))``).
-Rewrite Rmult_assoc; Apply Rle_monotony.
-Apply pow_le.
-Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Unfold M; Apply RmaxLess1.
-Assert H2 := (even_odd_cor N).
-Elim H2; Intros N0 H3.
-Elim H3; Intro.
-Apply Rle_trans with ``/(INR (fact n0))*/(INR (fact (minus N n0)))``.
-Do 2 Rewrite <- (Rmult_sym ``/(INR (fact (minus N n0)))``).
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_Rinv.
-Apply INR_fact_lt_0.
-Apply INR_fact_lt_0.
-Apply le_INR.
-Apply fact_growing.
-Apply le_n_Sn.
-Replace ``/(INR (fact n0))*/(INR (fact (minus N n0)))`` with ``(C N n0)/(INR (fact N))``.
-Pattern 1 N; Rewrite H4.
-Apply Rle_trans with ``(C N N0)/(INR (fact N))``.
-Unfold Rdiv; Do 2 Rewrite <- (Rmult_sym ``/(INR (fact N))``).
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Rewrite H4.
-Apply C_maj.
-Rewrite <- H4; Apply le_trans with (pred (minus N n)).
-Apply H1.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Apply H0.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n (0)) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Apply H0.
-Apply lt_pred_n_n.
-Apply H.
-Apply le_trans with (pred N).
-Apply H0.
-Apply le_pred_n.
-Replace ``(C N N0)/(INR (fact N))`` with ``/(Rsqr (INR (fact N0)))``.
-Rewrite H4; Rewrite div2_S_double; Right; Reflexivity.
-Unfold Rsqr C Rdiv.
-Repeat Rewrite Rinv_Rmult.
-Rewrite (Rmult_sym (INR (fact N))).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Replace (minus N N0) with N0.
-Ring.
-Replace N with (plus N0 N0).
-Symmetry; Apply minus_plus.
-Rewrite H4.
-Apply INR_eq; Rewrite plus_INR; Rewrite mult_INR; Do 2 Rewrite S_INR; Ring.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Unfold C Rdiv.
-Rewrite (Rmult_sym (INR (fact N))).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rinv_Rmult.
-Rewrite Rmult_1r; Ring.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Replace ``/(INR (fact (S n0)))*/(INR (fact (minus N n0)))`` with ``(C (S N) (S n0))/(INR (fact (S N)))``.
-Apply Rle_trans with ``(C (S N) (S N0))/(INR (fact (S N)))``.
-Unfold Rdiv; Do 2 Rewrite <- (Rmult_sym ``/(INR (fact (S N)))``).
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Cut (S N) = (mult (2) (S N0)).
-Intro; Rewrite H5; Apply C_maj.
-Rewrite <- H5; Apply le_n_S.
-Apply le_trans with (pred (minus N n)).
-Apply H1.
-Apply le_S_n.
-Replace (S (pred (minus N n))) with (minus N n).
-Apply le_trans with N.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Apply H0.
-Apply le_pred_n.
-Apply le_n_Sn.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n (0)) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Apply H0.
-Apply lt_pred_n_n.
-Apply H.
-Apply le_trans with (pred N).
-Apply H0.
-Apply le_pred_n.
-Apply INR_eq; Rewrite H4.
-Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat  Rewrite S_INR; Ring.
-Cut (S N) = (mult (2) (S N0)).
-Intro.
-Replace ``(C (S N) (S N0))/(INR (fact (S N)))`` with ``/(Rsqr (INR (fact (S N0))))``.
-Rewrite H5; Rewrite div2_double.
-Right; Reflexivity.
-Unfold Rsqr C Rdiv.
-Repeat Rewrite Rinv_Rmult.
-Replace (minus (S N) (S N0)) with (S N0).
-Rewrite (Rmult_sym (INR (fact (S N)))).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Reflexivity.
-Apply INR_fact_neq_0.
-Replace (S N) with (plus (S N0) (S N0)).
-Symmetry; Apply minus_plus.
-Rewrite H5; Ring.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_eq; Rewrite H4; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Unfold C Rdiv.
-Rewrite (Rmult_sym (INR (fact (S N)))).
-Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Rewrite Rinv_Rmult.
-Reflexivity.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Unfold maj_Reste_E.
-Unfold Rdiv; Rewrite (Rmult_sym ``4``).
-Rewrite Rmult_assoc.
-Apply Rle_monotony.
-Apply pow_le.
-Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Apply RmaxLess1.
-Apply Rle_trans with (sum_f_R0 [k:nat]``(INR (minus N k))*/(Rsqr (INR (fact (div2 (S N)))))`` (pred N)).
-Apply sum_Rle; Intros.
-Rewrite sum_cte.
-Replace (S (pred (minus N n))) with (minus N n).
-Right; Apply Rmult_sym.
-Apply S_pred with O.
-Apply simpl_lt_plus_l with n.
-Rewrite <- le_plus_minus.
-Replace (plus n (0)) with n; [Idtac | Ring].
-Apply le_lt_trans with (pred N).
-Apply H0.
-Apply lt_pred_n_n.
-Apply H.
-Apply le_trans with (pred N).
-Apply H0.
-Apply le_pred_n.
-Apply Rle_trans with (sum_f_R0 [k:nat]``(INR N)*/(Rsqr (INR (fact (div2 (S N)))))`` (pred N)).
-Apply sum_Rle; Intros.
-Do 2 Rewrite <- (Rmult_sym ``/(Rsqr (INR (fact (div2 (S N)))))``).
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply Rsqr_pos_lt.
-Apply INR_fact_neq_0.
-Apply le_INR.
-Apply simpl_le_plus_l with n.
-Rewrite <- le_plus_minus.
-Apply le_plus_r.
-Apply le_trans with (pred N).
-Apply H0.
-Apply le_pred_n.
-Rewrite sum_cte; Replace (S (pred N)) with N.
-Cut (div2 (S N)) = (S (div2 (pred N))).
-Intro; Rewrite H0.
-Rewrite fact_simpl; Rewrite mult_sym; Rewrite mult_INR; Rewrite Rsqr_times.
-Rewrite Rinv_Rmult.
-Rewrite (Rmult_sym (INR N)); Repeat Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply Rsqr_pos_lt; Apply INR_fact_neq_0.
-Rewrite <- H0.
-Cut ``(INR N)<=(INR (mult (S (S O)) (div2 (S N))))``.
-Intro; Apply Rle_monotony_contra with ``(Rsqr (INR (div2 (S N))))``.
-Apply Rsqr_pos_lt.
-Apply not_O_INR; Red; Intro.
-Cut (lt (1) (S N)).
-Intro; Assert H4 := (div2_not_R0 ? H3).
-Rewrite H2 in H4; Elim (lt_n_O ? H4).
-Apply lt_n_S; Apply H.
-Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l.
-Replace ``(INR N)*(INR N)`` with (Rsqr (INR N)); [Idtac | Reflexivity].
-Rewrite Rmult_assoc.
-Rewrite Rmult_sym.
-Replace ``4`` with (Rsqr ``2``); [Idtac | SqRing].
-Rewrite <- Rsqr_times.
-Apply Rsqr_incr_1.
-Replace ``2`` with (INR (2)).
-Rewrite <- mult_INR; Apply H1.
-Reflexivity.
-Left; Apply lt_INR_0; Apply H.
-Left; Apply Rmult_lt_pos.
-Sup0.
-Apply lt_INR_0; Apply div2_not_R0.
-Apply lt_n_S; Apply H.
-Cut (lt (1) (S N)).
-Intro; Unfold Rsqr; Apply prod_neq_R0; Apply not_O_INR; Intro; Assert H4 := (div2_not_R0 ? H2); Rewrite H3 in H4; Elim (lt_n_O ? H4).
-Apply lt_n_S; Apply H.
-Assert H1 := (even_odd_cor N).
-Elim H1; Intros N0 H2.
-Elim H2; Intro.
-Pattern 2 N; Rewrite H3.
-Rewrite div2_S_double.
-Right; Rewrite H3; Reflexivity.
-Pattern 2 N; Rewrite H3.
-Replace (S (S (mult (2) N0))) with (mult (2) (S N0)).
-Rewrite div2_double.
-Rewrite H3.
-Rewrite S_INR; Do 2 Rewrite mult_INR.
-Rewrite (S_INR N0).
-Rewrite Rmult_Rplus_distr.
-Apply Rle_compatibility.
-Rewrite Rmult_1r.
-Simpl.
-Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Apply Rlt_R0_R1.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Unfold Rsqr; Apply prod_neq_R0; Apply INR_fact_neq_0.
-Unfold Rsqr; Apply prod_neq_R0; Apply not_O_INR; Discriminate.
-Assert H0 := (even_odd_cor N).
-Elim H0; Intros N0 H1.
-Elim H1; Intro.
-Cut (lt O N0).
-Intro; Rewrite H2.
-Rewrite div2_S_double.
-Replace (mult (2) N0) with (S (S (mult (2) (pred N0)))).
-Replace (pred (S (S (mult (2) (pred N0))))) with (S (mult (2) (pred N0))).
-Rewrite div2_S_double.
-Apply S_pred with O; Apply H3.
-Reflexivity.
-Replace N0 with (S (pred N0)).
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Symmetry; Apply S_pred with O; Apply H3.
-Rewrite H2 in H.
-Apply neq_O_lt.
-Red; Intro.
-Rewrite <- H3 in H.
-Simpl in H.
-Elim (lt_n_O ? H).
-Rewrite H2.
-Replace (pred (S (mult (2) N0))) with (mult (2) N0); [Idtac | Reflexivity].
-Replace (S (S (mult (2) N0))) with (mult (2) (S N0)).
-Do 2 Rewrite div2_double.
-Reflexivity.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply S_pred with O; Apply H.
-Qed.
-
-Lemma maj_Reste_cv_R0 : (x,y:R) (Un_cv (maj_Reste_E x y) ``0``).
-Intros; Assert H := (Majxy_cv_R0 x y).
-Unfold Un_cv in H; Unfold Un_cv; Intros.
-Cut ``0<eps/4``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0]].
-Elim (H ? H1); Intros N0 H2.
-Exists (max (mult (2) (S N0)) (2)); Intros.
-Unfold R_dist in H2; Unfold R_dist; Rewrite minus_R0; Unfold Majxy in H2; Unfold maj_Reste_E.
-Rewrite Rabsolu_right.
-Apply Rle_lt_trans with ``4*(pow (Rmax 1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (S (S (S (S O)))) (S (div2 (pred n)))))/(INR (fact (div2 (pred n))))``.
-Apply Rle_monotony.
-Left; Sup0.
-Unfold Rdiv Rsqr; Rewrite Rinv_Rmult.
-Rewrite (Rmult_sym ``(pow (Rmax 1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (S (S O)) n))``); Rewrite (Rmult_sym ``(pow (Rmax 1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (S (S (S (S O)))) (S (div2 (pred n)))))``); Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Rle_trans with ``(pow (Rmax 1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (S (S O)) n))``.
-Rewrite Rmult_sym; Pattern 2 (pow (Rmax R1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (2) n)); Rewrite <- Rmult_1r; Apply Rle_monotony.
-Apply pow_le; Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Apply RmaxLess1.
-Apply Rle_monotony_contra with ``(INR (fact (div2 (pred n))))``.
-Apply INR_fact_lt_0.
-Rewrite Rmult_1r; Rewrite <- Rinv_r_sym.
-Replace R1 with (INR (1)); [Apply le_INR | Reflexivity].
-Apply lt_le_S.
-Apply INR_lt.
-Apply INR_fact_lt_0.
-Apply INR_fact_neq_0.
-Apply Rle_pow.
-Apply RmaxLess1.
-Assert H4 := (even_odd_cor n).
-Elim H4; Intros N1 H5.
-Elim H5; Intro.
-Cut (lt O N1).
-Intro.
-Rewrite H6.
-Replace (pred (mult (2) N1)) with (S (mult (2) (pred N1))).
-Rewrite div2_S_double.
-Replace (S (pred N1)) with N1.
-Apply INR_le.
-Right.
-Do 3 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply S_pred with O; Apply H7.
-Replace (mult (2) N1) with (S (S (mult (2) (pred N1)))).
-Reflexivity.
-Pattern 2 N1; Replace N1 with (S (pred N1)).
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Symmetry ; Apply S_pred with O; Apply H7.
-Apply INR_lt.
-Apply Rlt_monotony_contra with (INR (2)).
-Simpl; Sup0.
-Rewrite Rmult_Or; Rewrite <- mult_INR.
-Apply lt_INR_0.
-Rewrite <- H6.
-Apply lt_le_trans with (2).
-Apply lt_O_Sn.
-Apply le_trans with (max (mult (2) (S N0)) (2)).
-Apply le_max_r.
-Apply H3.
-Rewrite H6.
-Replace (pred (S (mult (2) N1))) with (mult (2) N1).
-Rewrite div2_double.
-Replace (mult (4) (S N1)) with (mult (2) (mult (2) (S N1))).
-Apply mult_le.
-Replace (mult (2) (S N1)) with (S (S (mult (2) N1))).
-Apply le_n_Sn.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Ring.
-Reflexivity.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply Rlt_monotony_contra with ``/4``.
-Apply Rlt_Rinv; Sup0.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Rewrite Rmult_sym.
-Replace ``(pow (Rmax 1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (S (S (S (S O)))) (S (div2 (pred n)))))/(INR (fact (div2 (pred n))))`` with ``(Rabsolu ((pow (Rmax 1 (Rmax (Rabsolu x) (Rabsolu y))) (mult (S (S (S (S O)))) (S (div2 (pred n)))))/(INR (fact (div2 (pred n))))-0))``.
-Apply H2; Unfold ge.
-Cut (le (mult (2) (S N0)) n).
-Intro; Apply le_S_n.
-Apply INR_le; Apply Rle_monotony_contra with (INR (2)).
-Simpl; Sup0.
-Do 2 Rewrite <- mult_INR; Apply le_INR.
-Apply le_trans with n.
-Apply H4.
-Assert H5 := (even_odd_cor n).
-Elim H5; Intros N1 H6.
-Elim H6; Intro.
-Cut (lt O N1).
-Intro.
-Rewrite H7.
-Apply mult_le.
-Replace (pred (mult (2) N1)) with (S (mult (2) (pred N1))).
-Rewrite div2_S_double.
-Replace (S (pred N1)) with N1.
-Apply le_n.
-Apply S_pred with O; Apply H8.
-Replace (mult (2) N1) with (S (S (mult (2) (pred N1)))).
-Reflexivity.
-Pattern 2 N1; Replace N1 with (S (pred N1)).
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Symmetry; Apply S_pred with O; Apply H8.
-Apply INR_lt.
-Apply Rlt_monotony_contra with (INR (2)).
-Simpl; Sup0.
-Rewrite Rmult_Or; Rewrite <- mult_INR.
-Apply lt_INR_0.
-Rewrite <- H7.
-Apply lt_le_trans with (2).
-Apply lt_O_Sn.
-Apply le_trans with (max (mult (2) (S N0)) (2)).
-Apply le_max_r.
-Apply H3.
-Rewrite H7.
-Replace (pred (S (mult (2) N1))) with (mult (2) N1).
-Rewrite div2_double.
-Replace (mult (2) (S N1)) with (S (S (mult (2) N1))).
-Apply le_n_Sn.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Reflexivity.
-Apply le_trans with (max (mult (2) (S N0)) (2)).
-Apply le_max_l.
-Apply H3.
-Rewrite minus_R0; Apply Rabsolu_right.
-Apply Rle_sym1.
-Unfold Rdiv; Repeat Apply Rmult_le_pos.
-Apply pow_le.
-Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Apply RmaxLess1.
-Left; Apply Rlt_Rinv; Apply INR_fact_lt_0.
-DiscrR.
-Apply Rle_sym1.
-Unfold Rdiv; Apply Rmult_le_pos.
-Left; Sup0.
-Apply Rmult_le_pos.
-Apply pow_le.
-Apply Rle_trans with R1.
-Left; Apply Rlt_R0_R1.
-Apply RmaxLess1.
-Left; Apply Rlt_Rinv; Apply Rsqr_pos_lt; Apply INR_fact_neq_0.
-Qed.
-
-(**********)
-Lemma Reste_E_cv : (x,y:R) (Un_cv (Reste_E x y) R0).
-Intros; Assert H := (maj_Reste_cv_R0 x y).
-Unfold Un_cv in H; Unfold Un_cv; Intros; Elim (H ? H0); Intros.
-Exists (max x0 (1)); Intros.
-Unfold R_dist; Rewrite minus_R0.
-Apply Rle_lt_trans with (maj_Reste_E x y n).
-Apply Reste_E_maj.
-Apply lt_le_trans with (1).
-Apply lt_O_Sn.
-Apply le_trans with (max x0 (1)).
-Apply le_max_r.
-Apply H2.
-Replace (maj_Reste_E x y n) with (R_dist (maj_Reste_E x y n) R0).
-Apply H1.
-Unfold ge; Apply le_trans with (max x0 (1)).
-Apply le_max_l.
-Apply H2.
-Unfold R_dist; Rewrite minus_R0; Apply Rabsolu_right.
-Apply Rle_sym1; Apply Rle_trans with (Rabsolu (Reste_E x y n)).
-Apply Rabsolu_pos.
-Apply Reste_E_maj.
-Apply lt_le_trans with (1).
-Apply lt_O_Sn.
-Apply le_trans with (max x0 (1)).
-Apply le_max_r.
-Apply H2.
-Qed.
-
-(**********)
-Lemma exp_plus : (x,y:R) ``(exp (x+y))==(exp x)*(exp y)``.
-Intros; Assert H0 := (E1_cvg x).
-Assert H := (E1_cvg y).
-Assert H1 := (E1_cvg ``x+y``).
-EApply UL_sequence.
-Apply H1.
-Assert H2 := (CV_mult ? ? ? ? H0 H).
-Assert H3 := (CV_minus ? ? ? ? H2 (Reste_E_cv x y)).
-Unfold Un_cv; Unfold Un_cv in H3; Intros.
-Elim (H3 ? H4); Intros.
-Exists (S x0); Intros.
-Rewrite <- (exp_form x y n).
-Rewrite minus_R0 in H5.
-Apply H5.
-Unfold ge; Apply le_trans with (S x0).
-Apply le_n_Sn.
-Apply H6.
-Apply lt_le_trans with (S x0).
-Apply lt_O_Sn.
-Apply H6.
-Qed.
-
-(**********)
-Lemma exp_pos_pos : (x:R) ``0<x`` -> ``0<(exp x)``.
-Intros; Pose An := [N:nat]``/(INR (fact N))*(pow x N)``.
-Cut (Un_cv [n:nat](sum_f_R0 An n) (exp x)).
-Intro; Apply Rlt_le_trans with (sum_f_R0 An O).
-Unfold An; Simpl; Rewrite Rinv_R1; Rewrite Rmult_1r; Apply Rlt_R0_R1.
-Apply sum_incr.
-Assumption.
-Intro; Unfold An; Left; Apply Rmult_lt_pos.
-Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply (pow_lt ? n H).
-Unfold exp; Unfold projT1; Case (exist_exp x); Intro.
-Unfold exp_in; Unfold infinit_sum Un_cv; Trivial.
-Qed.
-
-(**********)
-Lemma exp_pos : (x:R) ``0<(exp x)``.
-Intro; Case (total_order_T R0 x); Intro.
-Elim s; Intro.
-Apply (exp_pos_pos ? a).
-Rewrite <- b; Rewrite exp_0; Apply Rlt_R0_R1.
-Replace (exp x) with ``1/(exp (-x))``.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply Rlt_R0_R1.
-Apply Rlt_Rinv; Apply exp_pos_pos.
-Apply (Rgt_RO_Ropp ? r).
-Cut ``(exp (-x))<>0``.
-Intro; Unfold Rdiv; Apply r_Rmult_mult with ``(exp (-x))``.
-Rewrite Rmult_1l; Rewrite <- Rinv_r_sym.
-Rewrite <- exp_plus.
-Rewrite Rplus_Ropp_l; Rewrite exp_0; Reflexivity.
-Apply H.
-Apply H.
-Assert H := (exp_plus x ``-x``).
-Rewrite Rplus_Ropp_r in H; Rewrite exp_0 in H.
-Red; Intro; Rewrite H0 in H.
-Rewrite Rmult_Or in H.
-Elim R1_neq_R0; Assumption.
-Qed.
-
-(* ((exp h)-1)/h -> 0 quand h->0 *)
-Lemma derivable_pt_lim_exp_0 : (derivable_pt_lim exp ``0`` ``1``).
-Unfold derivable_pt_lim; Intros.
-Pose fn := [N:nat][x:R]``(pow x N)/(INR (fact (S N)))``.
-Cut (CVN_R fn).
-Intro; Cut (x:R)(sigTT ? [l:R](Un_cv [N:nat](SP fn N x) l)).
-Intro cv; Cut ((n:nat)(continuity (fn n))).
-Intro; Cut (continuity (SFL fn cv)).
-Intro; Unfold continuity in H1.
-Assert H2 := (H1 R0).
-Unfold continuity_pt in H2; Unfold continue_in in H2; Unfold limit1_in in H2; Unfold limit_in in H2; Simpl in H2; Unfold R_dist in H2.
-Elim (H2 ? H); Intros alp H3.
-Elim H3; Intros.
-Exists (mkposreal ? H4); Intros.
-Rewrite Rplus_Ol; Rewrite exp_0.
-Replace ``((exp h)-1)/h`` with (SFL fn cv h).
-Replace R1 with (SFL fn cv R0).
-Apply H5.
-Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Apply (not_sym ? ? H6).
-Rewrite minus_R0; Apply H7.
-Unfold SFL.
-Case (cv ``0``); Intros.
-EApply UL_sequence.
-Apply u.
-Unfold Un_cv SP.
-Intros; Exists (1); Intros.
-Unfold R_dist; Rewrite decomp_sum.
-Rewrite (Rplus_sym (fn O R0)).
-Replace (fn O R0) with R1.
-Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or.
-Replace (sum_f_R0 [i:nat](fn (S i) ``0``) (pred n)) with R0.
-Rewrite Rabsolu_R0; Apply H8.
-Symmetry; Apply sum_eq_R0; Intros.
-Unfold fn.
-Simpl.
-Unfold Rdiv; Do 2 Rewrite Rmult_Ol; Reflexivity.
-Unfold fn; Simpl.
-Unfold Rdiv; Rewrite Rinv_R1; Rewrite Rmult_1r; Reflexivity.
-Apply lt_le_trans with (1); [Apply lt_n_Sn | Apply H9].
-Unfold SFL exp.
-Unfold projT1.
-Case (cv h); Case (exist_exp h); Intros.
-EApply UL_sequence.
-Apply u.
-Unfold Un_cv; Intros.
-Unfold exp_in in e.
-Unfold infinit_sum in e.
-Cut ``0<eps0*(Rabsolu h)``.
-Intro; Elim (e ? H9); Intros N0 H10.
-Exists N0; Intros.
-Unfold R_dist.
-Apply Rlt_monotony_contra with ``(Rabsolu h)``.
-Apply Rabsolu_pos_lt; Assumption.
-Rewrite <- Rabsolu_mult.
-Rewrite Rminus_distr.
-Replace ``h*(x-1)/h`` with ``(x-1)``.
-Unfold R_dist in H10.
-Replace ``h*(SP fn n h)-(x-1)`` with (Rminus (sum_f_R0 [i:nat]``/(INR (fact i))*(pow h i)`` (S n)) x).
-Rewrite (Rmult_sym (Rabsolu h)).
-Apply H10.
-Unfold ge.
-Apply le_trans with (S N0).
-Apply le_n_Sn.
-Apply le_n_S; Apply H11.
-Rewrite decomp_sum.
-Replace ``/(INR (fact O))*(pow h O)`` with R1.
-Unfold Rminus.
-Rewrite Ropp_distr1.
-Rewrite Ropp_Ropp.
-Rewrite <- (Rplus_sym ``-x``).
-Rewrite <- (Rplus_sym ``-x+1``).
-Rewrite Rplus_assoc; Repeat Apply Rplus_plus_r.
-Replace (pred (S n)) with n; [Idtac | Reflexivity].
-Unfold SP.
-Rewrite scal_sum.
-Apply sum_eq; Intros.
-Unfold fn.
-Replace (pow h (S i)) with ``h*(pow h i)``.
-Unfold Rdiv; Ring.
-Simpl; Ring.
-Simpl; Rewrite Rinv_R1; Rewrite Rmult_1r; Reflexivity.
-Apply lt_O_Sn.
-Unfold Rdiv.
-Rewrite <- Rmult_assoc.
-Symmetry; Apply Rinv_r_simpl_m.
-Assumption.
-Apply Rmult_lt_pos.
-Apply H8.
-Apply Rabsolu_pos_lt; Assumption.
-Apply SFL_continuity; Assumption.
-Intro; Unfold fn.
-Replace [x:R]``(pow x n)/(INR (fact (S n)))`` with (div_fct (pow_fct n) (fct_cte (INR (fact (S n))))); [Idtac | Reflexivity].
-Apply continuity_div.
-Apply derivable_continuous; Apply (derivable_pow n).
-Apply derivable_continuous; Apply derivable_const.
-Intro; Unfold fct_cte; Apply INR_fact_neq_0.
-Apply (CVN_R_CVS ? X).
-Assert H0 := Alembert_exp.
-Unfold CVN_R.
-Intro; Unfold CVN_r.
-Apply Specif.existT with [N:nat]``(pow r N)/(INR (fact (S N)))``.
-Cut (SigT ? [l:R](Un_cv [n:nat](sum_f_R0 [k:nat](Rabsolu ``(pow r k)/(INR (fact (S k)))``) n) l)).
-Intro.
-Elim X; Intros.
-Exists x; Intros.
-Split.
-Apply p.
-Unfold Boule; Intros.
-Rewrite minus_R0 in H1.
-Unfold fn.
-Unfold Rdiv; Rewrite Rabsolu_mult.
-Cut ``0<(INR (fact (S n)))``.
-Intro.
-Rewrite (Rabsolu_right ``/(INR (fact (S n)))``).
-Do 2 Rewrite <- (Rmult_sym ``/(INR (fact (S n)))``).
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply H2.
-Rewrite <- Pow_Rabsolu.
-Apply pow_maj_Rabs.
-Rewrite Rabsolu_Rabsolu; Left; Apply H1.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Apply H2.
-Apply INR_fact_lt_0.
-Cut (r::R)<>``0``.
-Intro; Apply Alembert_C2.
-Intro; Apply Rabsolu_no_R0.
-Unfold Rdiv; Apply prod_neq_R0.
-Apply pow_nonzero; Assumption.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Unfold Un_cv in H0.
-Unfold Un_cv; Intros.
-Cut ``0<eps0/r``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Apply (cond_pos r)]].
-Elim (H0 ? H3); Intros N0 H4.
-Exists N0; Intros.
-Cut (ge (S n) N0).
-Intro hyp_sn.
-Assert H6 := (H4 ? hyp_sn).
-Unfold R_dist in H6; Rewrite minus_R0 in H6.
-Rewrite Rabsolu_Rabsolu in H6.
-Unfold R_dist; Rewrite minus_R0.
-Rewrite Rabsolu_Rabsolu.
-Replace ``(Rabsolu ((pow r (S n))/(INR (fact (S (S n))))))/
-     (Rabsolu ((pow r n)/(INR (fact (S n)))))`` with ``r*/(INR (fact (S (S n))))*//(INR (fact (S n)))``.
-Rewrite Rmult_assoc; Rewrite Rabsolu_mult.
-Rewrite (Rabsolu_right r).
-Apply Rlt_monotony_contra with ``/r``.
-Apply Rlt_Rinv; Apply (cond_pos r).
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Rewrite <- (Rmult_sym eps0).
-Apply H6.
-Assumption.
-Apply Rle_sym1; Left; Apply (cond_pos r).
-Unfold Rdiv.
-Repeat Rewrite Rabsolu_mult.
-Repeat Rewrite Rabsolu_Rinv.
-Rewrite Rinv_Rmult.
-Repeat Rewrite Rabsolu_right.
-Rewrite Rinv_Rinv.
-Rewrite (Rmult_sym r).
-Rewrite (Rmult_sym (pow r (S n))).
-Repeat Rewrite Rmult_assoc.
-Apply Rmult_mult_r.
-Rewrite (Rmult_sym r).
-Rewrite <- Rmult_assoc; Rewrite <- (Rmult_sym (INR (fact (S n)))).
-Apply Rmult_mult_r.
-Simpl.
-Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Ring.
-Apply pow_nonzero; Assumption.
-Apply INR_fact_neq_0.
-Apply Rle_sym1; Left; Apply INR_fact_lt_0.
-Apply Rle_sym1; Left; Apply pow_lt; Apply (cond_pos r).
-Apply Rle_sym1; Left; Apply INR_fact_lt_0.
-Apply Rle_sym1; Left; Apply pow_lt; Apply (cond_pos r).
-Apply Rabsolu_no_R0; Apply pow_nonzero; Assumption.
-Apply Rinv_neq_R0; Apply Rabsolu_no_R0; Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Unfold ge; Apply le_trans with n.
-Apply H5.
-Apply le_n_Sn.
-Assert H1 := (cond_pos r); Red; Intro; Rewrite H2 in H1; Elim (Rlt_antirefl ? H1).
-Qed.
-
-(**********)
-Lemma derivable_pt_lim_exp : (x:R) (derivable_pt_lim exp x (exp x)).
-Intro; Assert H0 := derivable_pt_lim_exp_0.
-Unfold derivable_pt_lim in H0; Unfold derivable_pt_lim; Intros.
-Cut ``0<eps/(exp x)``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Apply H | Apply Rlt_Rinv; Apply exp_pos]].
-Elim (H0 ? H1); Intros del H2.
-Exists del; Intros.
-Assert H5 := (H2 ? H3 H4).
-Rewrite Rplus_Ol in H5; Rewrite exp_0 in H5.
-Replace ``((exp (x+h))-(exp x))/h-(exp x)`` with ``(exp x)*(((exp h)-1)/h-1)``.
-Rewrite Rabsolu_mult; Rewrite (Rabsolu_right (exp x)).
-Apply Rlt_monotony_contra with ``/(exp x)``.
-Apply Rlt_Rinv; Apply exp_pos.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Rewrite <- (Rmult_sym eps).
-Apply H5.
-Assert H6 := (exp_pos x); Red; Intro; Rewrite H7 in H6; Elim (Rlt_antirefl ? H6).
-Apply Rle_sym1; Left; Apply exp_pos.
-Rewrite Rminus_distr.
-Rewrite Rmult_1r; Unfold Rdiv; Rewrite <- Rmult_assoc; Rewrite Rminus_distr.
-Rewrite Rmult_1r; Rewrite exp_plus; Reflexivity.
-Qed.
diff --git a/theories7/Reals/Integration.v b/theories7/Reals/Integration.v
deleted file mode 100644
index 410429ed..00000000
--- a/theories7/Reals/Integration.v
+++ /dev/null
@@ -1,13 +0,0 @@
-(************************************************************************)
-(*  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: Integration.v,v 1.1.2.1 2004/07/16 19:31:32 herbelin Exp $ i*)
-
-Require Export NewtonInt.
-Require Export RiemannInt_SF.
-Require Export RiemannInt.
\ No newline at end of file
diff --git a/theories7/Reals/MVT.v b/theories7/Reals/MVT.v
deleted file mode 100644
index eae414b1..00000000
--- a/theories7/Reals/MVT.v
+++ /dev/null
@@ -1,517 +0,0 @@
-(************************************************************************)
-(*  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: MVT.v,v 1.1.2.1 2004/07/16 19:31:32 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Ranalysis1.
-Require Rtopology.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(* The Mean Value Theorem *)
-Theorem MVT : (f,g:R->R;a,b:R;pr1:(c:R)``a<c<b``->(derivable_pt f c);pr2:(c:R)``a<c<b``->(derivable_pt g c)) ``a<b`` -> ((c:R)``a<=c<=b``->(continuity_pt f c)) -> ((c:R)``a<=c<=b``->(continuity_pt g c)) -> (EXT c : R | (EXT P : ``a<c<b`` | ``((g b)-(g a))*(derive_pt f c (pr1 c P))==((f b)-(f a))*(derive_pt g c (pr2 c P))``)).
-Intros; Assert H2 := (Rlt_le ? ? H).
-Pose h := [y:R]``((g b)-(g a))*(f y)-((f b)-(f a))*(g y)``.
-Cut (c:R)``a<c<b``->(derivable_pt h c).
-Intro; Cut ((c:R)``a<=c<=b``->(continuity_pt h c)).
-Intro; Assert H4 := (continuity_ab_maj h a b H2 H3).
-Assert H5 := (continuity_ab_min h a b H2 H3).
-Elim H4; Intros Mx H6.
-Elim H5; Intros mx H7.
-Cut (h a)==(h b).
-Intro; Pose M := (h Mx); Pose m := (h mx).
-Cut (c:R;P:``a<c<b``) (derive_pt h c (X c P))==``((g b)-(g a))*(derive_pt f c (pr1 c P))-((f b)-(f a))*(derive_pt g c (pr2 c P))``.
-Intro; Case (Req_EM (h a) M); Intro.
-Case (Req_EM (h a) m); Intro.
-Cut ((c:R)``a<=c<=b``->(h c)==M).
-Intro; Cut ``a<(a+b)/2<b``.
-(*** h constant ***)
-Intro; Exists ``(a+b)/2``.
-Exists H13.
-Apply Rminus_eq; Rewrite <- H9; Apply deriv_constant2 with a b.
-Elim H13; Intros; Assumption.
-Elim H13; Intros; Assumption.
-Intros; Rewrite (H12 ``(a+b)/2``).
-Apply H12; Split; Left; Assumption.
-Elim H13; Intros; Split; Left; Assumption.
-Split.
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Apply H.
-DiscrR.
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite Rplus_sym; Rewrite double; Apply Rlt_compatibility; Apply H.
-DiscrR.
-Intros; Elim H6; Intros H13 _.
-Elim H7; Intros H14 _.
-Apply Rle_antisym.
-Apply H13; Apply H12.
-Rewrite H10 in H11; Rewrite H11; Apply H14; Apply H12.
-Cut ``a<mx<b``.
-(*** h admet un minimum global sur [a,b] ***)
-Intro; Exists mx.
-Exists H12.
-Apply Rminus_eq; Rewrite <- H9; Apply deriv_minimum with a b.
-Elim H12; Intros; Assumption.
-Elim H12; Intros; Assumption.
-Intros; Elim H7; Intros.
-Apply H15; Split; Left; Assumption.
-Elim H7; Intros _ H12; Elim H12; Intros; Split.
-Inversion H13.
-Apply H15.
-Rewrite H15 in H11; Elim H11; Reflexivity.
-Inversion H14.
-Apply H15.
-Rewrite H8 in H11; Rewrite <- H15 in H11; Elim H11; Reflexivity.
-Cut ``a<Mx<b``.
-(*** h admet un maximum global sur [a,b] ***)
-Intro; Exists Mx.
-Exists H11.
-Apply Rminus_eq; Rewrite <- H9; Apply deriv_maximum with a b.
-Elim H11; Intros; Assumption.
-Elim H11; Intros; Assumption.
-Intros; Elim H6; Intros; Apply H14.
-Split; Left; Assumption.
-Elim H6; Intros _ H11; Elim H11; Intros; Split.
-Inversion H12.
-Apply H14.
-Rewrite H14 in H10; Elim H10; Reflexivity.
-Inversion H13.
-Apply H14.
-Rewrite H8 in H10; Rewrite <- H14 in H10; Elim H10; Reflexivity.
-Intros; Unfold h; Replace (derive_pt [y:R]``((g b)-(g a))*(f y)-((f b)-(f a))*(g y)`` c (X c P)) with (derive_pt (minus_fct (mult_fct (fct_cte ``(g b)-(g a)``) f) (mult_fct (fct_cte ``(f b)-(f a)``) g)) c (derivable_pt_minus ? ? ? (derivable_pt_mult ? ? ? (derivable_pt_const ``(g b)-(g a)`` c) (pr1 c P)) (derivable_pt_mult ? ? ? (derivable_pt_const ``(f b)-(f a)`` c) (pr2 c P)))); [Idtac | Apply pr_nu].
-Rewrite derive_pt_minus; Do 2 Rewrite derive_pt_mult; Do 2 Rewrite derive_pt_const; Do 2 Rewrite Rmult_Ol; Do 2 Rewrite Rplus_Ol; Reflexivity.
-Unfold h; Ring.
-Intros; Unfold h; Change (continuity_pt (minus_fct (mult_fct (fct_cte ``(g b)-(g a)``) f) (mult_fct (fct_cte ``(f b)-(f a)``) g)) c).
-Apply continuity_pt_minus; Apply continuity_pt_mult.
-Apply derivable_continuous_pt; Apply derivable_const.
-Apply H0; Apply H3.
-Apply derivable_continuous_pt; Apply derivable_const.
-Apply H1; Apply H3.
-Intros; Change (derivable_pt (minus_fct (mult_fct (fct_cte ``(g b)-(g a)``) f) (mult_fct (fct_cte ``(f b)-(f a)``) g)) c).
-Apply derivable_pt_minus; Apply derivable_pt_mult.
-Apply derivable_pt_const.
-Apply (pr1 ? H3).
-Apply derivable_pt_const.
-Apply (pr2 ? H3).
-Qed.
-
-(* Corollaries ... *)
-Lemma MVT_cor1 : (f:(R->R); a,b:R; pr:(derivable f)) ``a < b``->(EXT c:R | ``(f b)-(f a) == (derive_pt f c (pr c))*(b-a)``/\``a < c < b``).
-Intros f a b pr H; Cut (c:R)``a<c<b``->(derivable_pt f c); [Intro | Intros; Apply pr].
-Cut (c:R)``a<c<b``->(derivable_pt id c); [Intro | Intros; Apply derivable_pt_id].
-Cut ((c:R)``a<=c<=b``->(continuity_pt f c)); [Intro | Intros; Apply derivable_continuous_pt; Apply pr].
-Cut ((c:R)``a<=c<=b``->(continuity_pt id c)); [Intro | Intros; Apply derivable_continuous_pt; Apply derivable_id].
-Assert H2 := (MVT f id a b X X0 H H0 H1).
-Elim H2; Intros c H3; Elim H3; Intros.
-Exists c; Split.
-Cut (derive_pt id c (X0 c x)) == (derive_pt id c (derivable_pt_id c)); [Intro | Apply pr_nu].
-Rewrite H5 in H4; Rewrite (derive_pt_id c) in H4; Rewrite Rmult_1r in H4; Rewrite <- H4; Replace (derive_pt f c (X c x)) with (derive_pt f c (pr c)); [Idtac | Apply pr_nu]; Apply Rmult_sym.
-Apply x.
-Qed.
-
-Theorem MVT_cor2 : (f,f':R->R;a,b:R) ``a<b`` -> ((c:R)``a<=c<=b``->(derivable_pt_lim f c (f' c))) -> (EXT c:R | ``(f b)-(f a)==(f' c)*(b-a)``/\``a<c<b``).
-Intros f f' a b H H0; Cut ((c:R)``a<=c<=b``->(derivable_pt f c)).
-Intro; Cut ((c:R)``a<c<b``->(derivable_pt f c)).
-Intro; Cut ((c:R)``a<=c<=b``->(continuity_pt f c)).
-Intro; Cut ((c:R)``a<=c<=b``->(derivable_pt id c)).
-Intro; Cut ((c:R)``a<c<b``->(derivable_pt id c)).
-Intro; Cut ((c:R)``a<=c<=b``->(continuity_pt id c)).
-Intro; Elim (MVT f id a b X0 X2 H H1 H2); Intros; Elim H3; Clear H3; Intros; Exists x; Split.
-Cut (derive_pt id x (X2 x x0))==R1.
-Cut (derive_pt f x (X0 x x0))==(f' x).
-Intros; Rewrite H4 in H3; Rewrite H5 in H3; Unfold id in H3; Rewrite Rmult_1r in H3; Rewrite Rmult_sym; Symmetry; Assumption.
-Apply derive_pt_eq_0; Apply H0; Elim x0; Intros; Split; Left; Assumption.
-Apply derive_pt_eq_0; Apply derivable_pt_lim_id.
-Assumption.
-Intros; Apply derivable_continuous_pt; Apply X1; Assumption.
-Intros; Apply derivable_pt_id.
-Intros; Apply derivable_pt_id.
-Intros; Apply derivable_continuous_pt; Apply X; Assumption.
-Intros; Elim H1; Intros; Apply X; Split; Left; Assumption.
-Intros; Unfold derivable_pt; Apply Specif.existT with (f' c); Apply H0; Apply H1.
-Qed.
-
-Lemma MVT_cor3 : (f,f':(R->R); a,b:R) ``a < b``  -> ((x:R)``a <= x`` ->  ``x <= b``->(derivable_pt_lim f x (f' x))) -> (EXT c:R | ``a<=c``/\``c<=b``/\``(f b)==(f a) + (f' c)*(b-a)``).
-Intros f f' a b H H0; Assert H1 : (EXT c:R | ``(f b) -(f a) == (f' c)*(b-a)``/\``a<c<b``); [Apply MVT_cor2; [Apply H | Intros; Elim H1; Intros; Apply (H0 ? H2 H3)] | Elim H1; Intros; Exists x; Elim H2; Intros; Elim H4; Intros; Split; [Left; Assumption | Split; [Left; Assumption | Rewrite <- H3; Ring]]].
-Qed.
-
-Lemma Rolle : (f:R->R;a,b:R;pr:(x:R)``a<x<b``->(derivable_pt f x)) ((x:R)``a<=x<=b``->(continuity_pt f x)) -> ``a<b`` -> (f a)==(f b) -> (EXT c:R | (EXT P: ``a<c<b`` | ``(derive_pt f c (pr c P))==0``)).
-Intros; Assert H2 : (x:R)``a<x<b``->(derivable_pt id x).
-Intros; Apply derivable_pt_id.
-Assert H3 := (MVT f id a b pr H2 H0 H); Assert H4 : (x:R)``a<=x<=b``->(continuity_pt id x).
-Intros; Apply derivable_continuous; Apply derivable_id.
-Elim (H3 H4); Intros; Elim H5; Intros; Exists x; Exists x0; Rewrite H1 in H6; Unfold id in H6; Unfold Rminus in H6; Rewrite Rplus_Ropp_r in H6; Rewrite Rmult_Ol in H6; Apply r_Rmult_mult with ``b-a``; [Rewrite Rmult_Or; Apply H6 | Apply Rminus_eq_contra; Red; Intro; Rewrite H7 in H0; Elim (Rlt_antirefl ? H0)].
-Qed.
-
-(**********)
-Lemma nonneg_derivative_1 : (f:R->R;pr:(derivable f)) ((x:R) ``0<=(derive_pt f x (pr x))``) -> (increasing f).
-Intros.
-Unfold increasing.
-Intros.
-Case (total_order_T x y); Intro.
-Elim s; Intro.
-Apply Rle_anti_compatibility with ``-(f x)``.
-Rewrite Rplus_Ropp_l; Rewrite Rplus_sym.
-Assert H1 := (MVT_cor1 f ? ? pr a).
-Elim H1; Intros.
-Elim H2; Intros.
-Unfold Rminus in H3.
-Rewrite H3.
-Apply Rmult_le_pos.
-Apply H.
-Apply Rle_anti_compatibility with x.
-Rewrite Rplus_Or; Replace ``x+(y+ -x)`` with y; [Assumption | Ring].
-Rewrite b; Right; Reflexivity.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H0 r)).
-Qed.
- 
-(**********)
-Lemma nonpos_derivative_0 : (f:R->R;pr:(derivable f)) (decreasing f) -> ((x:R) ``(derive_pt f x (pr x))<=0``).
-Intros f pr H x; Assert H0 :=H; Unfold decreasing in H0; Generalize (derivable_derive f x (pr x)); Intro; Elim H1; Intros l H2.
-Rewrite H2; Case (total_order l R0); Intro.
-Left; Assumption.
-Elim H3; Intro.
-Right; Assumption.
-Generalize (derive_pt_eq_1 f x l (pr x) H2); Intros; Cut ``0< (l/2)``.
-Intro; Elim (H5 ``(l/2)`` H6); Intros delta H7; Cut ``delta/2<>0``/\``0<delta/2``/\``(Rabsolu delta/2)<delta``.
-Intro; Decompose [and] H8; Intros; Generalize (H7 ``delta/2`` H9 H12); Cut ``((f (x+delta/2))-(f x))/(delta/2)<=0``.
-Intro; Cut ``0< -(((f (x+delta/2))-(f x))/(delta/2)-l)``.
-Intro; Unfold Rabsolu; Case (case_Rabsolu ``((f (x+delta/2))-(f x))/(delta/2)-l``).
-Intros; Generalize (Rlt_compatibility_r ``-l`` ``-(((f (x+delta/2))-(f x))/(delta/2)-l)`` ``(l/2)`` H14); Unfold Rminus.
-Replace ``(l/2)+ -l`` with ``-(l/2)``.
-Replace `` -(((f (x+delta/2))+ -(f x))/(delta/2)+ -l)+ -l`` with ``-(((f (x+delta/2))+ -(f x))/(delta/2))``.
-Intro.
-Generalize (Rlt_Ropp ``-(((f (x+delta/2))+ -(f x))/(delta/2))`` ``-(l/2)`` H15). 
-Repeat Rewrite Ropp_Ropp.
-Intro.
-Generalize (Rlt_trans ``0`` ``l/2`` ``((f (x+delta/2))-(f x))/(delta/2)`` H6 H16); Intro.
-Elim (Rlt_antirefl ``0`` (Rlt_le_trans ``0`` ``((f (x+delta/2))-(f x))/(delta/2)`` ``0`` H17 H10)).
-Ring.
-Pattern 3 l; Rewrite double_var.
-Ring.
-Intros.
-Generalize (Rge_Ropp ``((f (x+delta/2))-(f x))/(delta/2)-l`` ``0`` r).
-Rewrite Ropp_O.
-Intro.
-Elim (Rlt_antirefl ``0`` (Rlt_le_trans ``0`` ``-(((f (x+delta/2))-(f x))/(delta/2)-l)`` ``0`` H13 H15)).
-Replace ``-(((f (x+delta/2))-(f x))/(delta/2)-l)`` with ``(((f (x))-(f (x+delta/2)))/(delta/2)) +l``.
-Unfold Rminus.
-Apply ge0_plus_gt0_is_gt0.
-Unfold Rdiv; Apply Rmult_le_pos.
-Cut ``x<=(x+(delta*/2))``.
-Intro; Generalize (H0 x ``x+(delta*/2)`` H13); Intro; Generalize (Rle_compatibility ``-(f (x+delta/2))`` ``(f (x+delta/2))`` ``(f x)`` H14); Rewrite Rplus_Ropp_l; Rewrite Rplus_sym; Intro; Assumption.
-Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rle_compatibility; Left; Assumption.
-Left; Apply Rlt_Rinv; Assumption.
-Assumption.
-Rewrite Ropp_distr2.
-Unfold Rminus.
-Rewrite (Rplus_sym l).
-Unfold Rdiv.
-Rewrite <- Ropp_mul1.
-Rewrite Ropp_distr1.
-Rewrite Ropp_Ropp.
-Rewrite (Rplus_sym (f x)).
-Reflexivity.
-Replace ``((f (x+delta/2))-(f x))/(delta/2)`` with ``-(((f x)-(f (x+delta/2)))/(delta/2))``.
-Rewrite <- Ropp_O.
-Apply Rge_Ropp.
-Apply Rle_sym1.
-Unfold Rdiv; Apply Rmult_le_pos.
-Cut ``x<=(x+(delta*/2))``.
-Intro; Generalize (H0 x ``x+(delta*/2)`` H10); Intro.
-Generalize (Rle_compatibility ``-(f (x+delta/2))`` ``(f (x+delta/2))`` ``(f x)`` H13); Rewrite Rplus_Ropp_l; Rewrite Rplus_sym; Intro; Assumption.
-Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rle_compatibility; Left; Assumption.
-Left; Apply Rlt_Rinv; Assumption.
-Unfold Rdiv; Rewrite <- Ropp_mul1.
-Rewrite Ropp_distr2.
-Reflexivity.
-Split.
-Unfold Rdiv; Apply prod_neq_R0.
-Generalize (cond_pos delta); Intro; Red; Intro H9; Rewrite H9 in H8; Elim (Rlt_antirefl ``0`` H8).
-Apply Rinv_neq_R0; DiscrR.
-Split.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos delta) | Apply Rlt_Rinv; Sup0].
-Rewrite Rabsolu_right.
-Unfold Rdiv; Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite double; Pattern 1 (pos delta); Rewrite <- Rplus_Or.
-Apply Rlt_compatibility; Apply (cond_pos delta).
-DiscrR.
-Apply Rle_sym1; Unfold Rdiv; Left; Apply Rmult_lt_pos.
-Apply (cond_pos delta).
-Apply Rlt_Rinv; Sup0.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply H4 | Apply Rlt_Rinv; Sup0].
-Qed.
-
-(**********)
-Lemma increasing_decreasing_opp : (f:R->R) (increasing f) -> (decreasing (opp_fct f)).
-Unfold increasing decreasing opp_fct; Intros; Generalize (H x y H0); Intro; Apply Rge_Ropp; Apply Rle_sym1; Assumption.
-Qed.
-
-(**********)
-Lemma nonpos_derivative_1 : (f:R->R;pr:(derivable f)) ((x:R) ``(derive_pt f x (pr x))<=0``) -> (decreasing f).
-Intros.
-Cut (h:R)``-(-(f h))==(f h)``.
-Intro.
-Generalize (increasing_decreasing_opp (opp_fct f)).
-Unfold decreasing.
-Unfold opp_fct.
-Intros.
-Rewrite <- (H0 x); Rewrite <- (H0 y).
-Apply H1.
-Cut (x:R)``0<=(derive_pt (opp_fct f) x ((derivable_opp f pr) x))``.
-Intros.
-Replace [x:R]``-(f x)`` with (opp_fct f); [Idtac | Reflexivity].
-Apply (nonneg_derivative_1 (opp_fct f) (derivable_opp f pr) H3).
-Intro.
-Assert H3 := (derive_pt_opp f x0 (pr x0)).
-Cut ``(derive_pt (opp_fct f) x0 (derivable_pt_opp f x0 (pr x0)))==(derive_pt (opp_fct f) x0 (derivable_opp f pr x0))``.
-Intro.
-Rewrite <- H4.
-Rewrite H3.
-Rewrite <- Ropp_O; Apply Rge_Ropp; Apply Rle_sym1; Apply (H x0).
-Apply pr_nu.
-Assumption.
-Intro; Ring.
-Qed.
- 
-(**********)
-Lemma positive_derivative : (f:R->R;pr:(derivable f)) ((x:R) ``0<(derive_pt f x (pr x))``)->(strict_increasing f).
-Intros.
-Unfold strict_increasing.
-Intros.
-Apply Rlt_anti_compatibility with ``-(f x)``.
-Rewrite Rplus_Ropp_l; Rewrite Rplus_sym.
-Assert H1 := (MVT_cor1 f ? ? pr H0).
-Elim H1; Intros.
-Elim H2; Intros.
-Unfold Rminus in H3.
-Rewrite H3.
-Apply Rmult_lt_pos.
-Apply H.
-Apply Rlt_anti_compatibility with x.
-Rewrite Rplus_Or; Replace ``x+(y+ -x)`` with y; [Assumption | Ring].
-Qed.
-
-(**********)
-Lemma strictincreasing_strictdecreasing_opp : (f:R->R) (strict_increasing f) ->
-(strict_decreasing (opp_fct f)).
-Unfold strict_increasing strict_decreasing opp_fct; Intros; Generalize (H x y H0); Intro; Apply Rlt_Ropp; Assumption.
-Qed.
- 
-(**********)
-Lemma negative_derivative : (f:R->R;pr:(derivable f)) ((x:R) ``(derive_pt f x (pr x))<0``)->(strict_decreasing f).
-Intros.
-Cut (h:R)``- (-(f h))==(f h)``.
-Intros.
-Generalize (strictincreasing_strictdecreasing_opp (opp_fct f)).
-Unfold strict_decreasing opp_fct.
-Intros.
-Rewrite <- (H0 x).
-Rewrite <- (H0 y).
-Apply H1; [Idtac | Assumption].
-Cut (x:R)``0<(derive_pt (opp_fct f) x (derivable_opp f pr x))``.
-Intros; EApply positive_derivative; Apply H3.
-Intro.
-Assert H3 := (derive_pt_opp f x0 (pr x0)).
-Cut ``(derive_pt (opp_fct f) x0 (derivable_pt_opp f x0 (pr x0)))==(derive_pt (opp_fct f) x0 (derivable_opp f pr x0))``.
-Intro.
-Rewrite <- H4; Rewrite H3.
-Rewrite <- Ropp_O; Apply Rlt_Ropp; Apply (H x0).
-Apply pr_nu.
-Intro; Ring.
-Qed.
- 
-(**********)
-Lemma null_derivative_0 : (f:R->R;pr:(derivable f)) (constant f)->((x:R) ``(derive_pt f x (pr x))==0``). 
-Intros.
-Unfold constant in H.
-Apply derive_pt_eq_0.
-Intros; Exists (mkposreal ``1`` Rlt_R0_R1); Simpl; Intros.
-Rewrite (H x ``x+h``); Unfold Rminus; Unfold Rdiv; Rewrite Rplus_Ropp_r; Rewrite Rmult_Ol; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Qed.
-
-(**********)
-Lemma increasing_decreasing : (f:R->R) (increasing f) -> (decreasing f) -> (constant f).
-Unfold increasing decreasing constant; Intros; Case (total_order x y); Intro.
-Generalize (Rlt_le x y H1); Intro; Apply (Rle_antisym (f x) (f y) (H x y H2) (H0 x y H2)).
-Elim H1; Intro.
-Rewrite H2; Reflexivity.
-Generalize (Rlt_le y x H2); Intro; Symmetry; Apply (Rle_antisym (f y) (f x) (H y x H3) (H0 y x H3)).
-Qed.
-
-(**********)
-Lemma null_derivative_1 : (f:R->R;pr:(derivable f)) ((x:R) ``(derive_pt f x (pr x))==0``)->(constant f).
-Intros.
-Cut (x:R)``(derive_pt f x (pr x)) <= 0``.
-Cut (x:R)``0 <= (derive_pt f x (pr x))``.
-Intros.
-Assert H2 := (nonneg_derivative_1 f pr H0).
-Assert H3 := (nonpos_derivative_1 f  pr H1).
-Apply increasing_decreasing; Assumption.
-Intro; Right; Symmetry; Apply (H x).
-Intro; Right; Apply (H x).
-Qed.
-
-(**********)
-Lemma derive_increasing_interv_ax : (a,b:R;f:R->R;pr:(derivable f)) ``a<b``-> (((t:R) ``a<t<b`` -> ``0<(derive_pt f t (pr t))``) -> ((x,y:R) ``a<=x<=b``->``a<=y<=b``->``x<y``->``(f x)<(f y)``)) /\ (((t:R) ``a<t<b`` -> ``0<=(derive_pt f t (pr t))``) -> ((x,y:R) ``a<=x<=b``->``a<=y<=b``->``x<y``->``(f x)<=(f y)``)).
-Intros.
-Split; Intros.
-Apply Rlt_anti_compatibility with ``-(f x)``.
-Rewrite Rplus_Ropp_l; Rewrite Rplus_sym.
-Assert H4 := (MVT_cor1 f ? ? pr H3).
-Elim H4; Intros.
-Elim H5; Intros.
-Unfold Rminus in H6.
-Rewrite H6.
-Apply Rmult_lt_pos.
-Apply H0.
-Elim H7; Intros.
-Split.
-Elim H1; Intros.
-Apply Rle_lt_trans with x; Assumption.
-Elim H2; Intros.
-Apply Rlt_le_trans with y; Assumption.
-Apply Rlt_anti_compatibility with x.
-Rewrite Rplus_Or; Replace ``x+(y+ -x)`` with y; [Assumption | Ring].
-Apply Rle_anti_compatibility with ``-(f x)``.
-Rewrite Rplus_Ropp_l; Rewrite Rplus_sym.
-Assert H4 := (MVT_cor1 f ? ? pr H3).
-Elim H4; Intros.
-Elim H5; Intros.
-Unfold Rminus in H6.
-Rewrite H6.
-Apply Rmult_le_pos.
-Apply H0.
-Elim H7; Intros.
-Split.
-Elim H1; Intros.
-Apply Rle_lt_trans with x; Assumption.
-Elim H2; Intros.
-Apply Rlt_le_trans with y; Assumption.
-Apply Rle_anti_compatibility with x.
-Rewrite Rplus_Or; Replace ``x+(y+ -x)`` with y; [Left; Assumption | Ring].
-Qed.
-
-(**********)
-Lemma derive_increasing_interv : (a,b:R;f:R->R;pr:(derivable f)) ``a<b``-> ((t:R) ``a<t<b`` -> ``0<(derive_pt f t (pr t))``) -> ((x,y:R) ``a<=x<=b``->``a<=y<=b``->``x<y``->``(f x)<(f y)``).
-Intros.
-Generalize (derive_increasing_interv_ax a b f pr H); Intro.
-Elim H4; Intros H5 _; Apply (H5 H0 x y H1 H2 H3).
-Qed.
-
-(**********)
-Lemma derive_increasing_interv_var : (a,b:R;f:R->R;pr:(derivable f)) ``a<b``-> ((t:R) ``a<t<b`` -> ``0<=(derive_pt f t (pr t))``) -> ((x,y:R) ``a<=x<=b``->``a<=y<=b``->``x<y``->``(f x)<=(f y)``).
-Intros a b f pr H H0 x y H1 H2 H3; Generalize (derive_increasing_interv_ax a b f pr H); Intro; Elim H4; Intros _ H5; Apply (H5 H0 x y H1 H2 H3).
-Qed.
-
-(**********)
-(**********)
-Theorem IAF : (f:R->R;a,b,k:R;pr:(derivable f)) ``a<=b`` -> ((c:R) ``a<=c<=b`` -> ``(derive_pt f c (pr c))<=k``) -> ``(f b)-(f a)<=k*(b-a)``.
-Intros.
-Case (total_order_T a b); Intro.
-Elim s; Intro.
-Assert H1 := (MVT_cor1 f ? ? pr a0).
-Elim H1; Intros.
-Elim H2; Intros.
-Rewrite H3.
-Do 2 Rewrite <- (Rmult_sym ``(b-a)``).
-Apply Rle_monotony.
-Apply Rle_anti_compatibility with ``a``; Rewrite Rplus_Or.
-Replace ``a+(b-a)`` with b; [Assumption | Ring].
-Apply H0.
-Elim H4; Intros.
-Split; Left; Assumption.
-Rewrite b0.
-Unfold Rminus; Do 2 Rewrite Rplus_Ropp_r.
-Rewrite Rmult_Or; Right; Reflexivity.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Qed.
-
-Lemma IAF_var : (f,g:R->R;a,b:R;pr1:(derivable f);pr2:(derivable g)) ``a<=b`` -> ((c:R) ``a<=c<=b`` -> ``(derive_pt g c (pr2 c))<=(derive_pt f c (pr1 c))``) -> ``(g b)-(g a)<=(f b)-(f a)``.
-Intros.
-Cut (derivable (minus_fct g f)).
-Intro.
-Cut (c:R)``a<=c<=b``->``(derive_pt (minus_fct g f) c (X c))<=0``.
-Intro. 
-Assert H2 := (IAF (minus_fct g f) a b R0 X H H1).
-Rewrite Rmult_Ol in H2; Unfold minus_fct in H2.
-Apply Rle_anti_compatibility with ``-(f b)+(f a)``.
-Replace ``-(f b)+(f a)+((f b)-(f a))`` with R0; [Idtac | Ring].
-Replace ``-(f b)+(f a)+((g b)-(g a))`` with ``(g b)-(f b)-((g a)-(f a))``; [Apply H2 | Ring].
-Intros.
-Cut (derive_pt (minus_fct g f) c (X c))==(derive_pt (minus_fct g f) c (derivable_pt_minus ? ? ? (pr2 c) (pr1 c))).
-Intro.
-Rewrite H2.
-Rewrite derive_pt_minus.
-Apply Rle_anti_compatibility with (derive_pt f c (pr1 c)).
-Rewrite Rplus_Or.
-Replace ``(derive_pt f c (pr1 c))+((derive_pt g c (pr2 c))-(derive_pt f c (pr1 c)))`` with ``(derive_pt g c (pr2 c))``; [Idtac | Ring].
-Apply H0; Assumption.
-Apply pr_nu.
-Apply derivable_minus; Assumption.
-Qed.
-
-(* If f has a null derivative in ]a,b[ and is continue in [a,b], *)
-(* then f is constant on [a,b] *)
-Lemma null_derivative_loc : (f:R->R;a,b:R;pr:(x:R)``a<x<b``->(derivable_pt f x)) ((x:R)``a<=x<=b``->(continuity_pt f x)) -> ((x:R;P:``a<x<b``)(derive_pt f x (pr x P))==R0) -> (constant_D_eq f [x:R]``a<=x<=b`` (f a)).
-Intros; Unfold constant_D_eq; Intros; Case (total_order_T a b); Intro.
-Elim s; Intro.
-Assert H2 : (y:R)``a<y<x``->(derivable_pt id y).
-Intros; Apply derivable_pt_id.
-Assert H3 : (y:R)``a<=y<=x``->(continuity_pt id y).
-Intros; Apply derivable_continuous; Apply derivable_id.
-Assert H4 : (y:R)``a<y<x``->(derivable_pt f y).
-Intros; Apply pr; Elim H4; Intros; Split.
-Assumption.
-Elim H1; Intros; Apply Rlt_le_trans with x; Assumption.
-Assert H5 : (y:R)``a<=y<=x``->(continuity_pt f y).
-Intros; Apply H; Elim H5; Intros; Split.
-Assumption.
-Elim H1; Intros; Apply Rle_trans with x; Assumption.
-Elim H1; Clear H1; Intros; Elim H1; Clear H1; Intro.
-Assert H7 := (MVT f id a x H4 H2 H1 H5 H3).
-Elim H7; Intros; Elim H8; Intros; Assert H10 : ``a<x0<b``.
-Elim x1; Intros; Split.
-Assumption.
-Apply Rlt_le_trans with x; Assumption.
-Assert H11 : ``(derive_pt f x0 (H4 x0 x1))==0``.
-Replace (derive_pt f x0 (H4 x0 x1)) with (derive_pt f x0 (pr x0 H10)); [Apply H0 | Apply pr_nu].
-Assert H12 : ``(derive_pt id x0 (H2 x0 x1))==1``.
-Apply derive_pt_eq_0; Apply derivable_pt_lim_id.
-Rewrite H11 in H9; Rewrite H12 in H9; Rewrite Rmult_Or in H9; Rewrite Rmult_1r in H9; Apply Rminus_eq; Symmetry; Assumption.
-Rewrite H1; Reflexivity.
-Assert H2 : x==a.
-Rewrite <- b0 in H1; Elim H1; Intros; Apply Rle_antisym; Assumption.
-Rewrite H2; Reflexivity.
-Elim H1; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? (Rle_trans ? ? ? H2 H3) r)).
-Qed.
-
-(* Unicity of the antiderivative *)
-Lemma antiderivative_Ucte : (f,g1,g2:R->R;a,b:R) (antiderivative f g1 a b) -> (antiderivative f g2 a b) -> (EXT c:R | (x:R)``a<=x<=b``->``(g1 x)==(g2 x)+c``).
-Unfold antiderivative; Intros; Elim H; Clear H; Intros; Elim H0; Clear H0; Intros H0 _; Exists ``(g1 a)-(g2 a)``; Intros; Assert H3 : (x:R)``a<=x<=b``->(derivable_pt g1 x).
-Intros; Unfold derivable_pt; Apply Specif.existT with (f x0); Elim (H x0 H3); Intros; EApply derive_pt_eq_1; Symmetry; Apply H4.
-Assert H4 : (x:R)``a<=x<=b``->(derivable_pt g2 x).
-Intros; Unfold derivable_pt; Apply Specif.existT with (f x0); Elim (H0 x0 H4); Intros; EApply derive_pt_eq_1; Symmetry; Apply H5.
-Assert H5 : (x:R)``a<x<b``->(derivable_pt (minus_fct g1 g2) x).
-Intros; Elim H5; Intros; Apply derivable_pt_minus; [Apply H3; Split; Left; Assumption | Apply H4; Split; Left; Assumption].
-Assert H6 : (x:R)``a<=x<=b``->(continuity_pt (minus_fct g1 g2) x).
-Intros; Apply derivable_continuous_pt; Apply derivable_pt_minus; [Apply H3 | Apply H4]; Assumption.
-Assert H7 : (x:R;P:``a<x<b``)(derive_pt (minus_fct g1 g2) x (H5 x P))==``0``.
-Intros; Elim P; Intros; Apply derive_pt_eq_0; Replace R0 with ``(f x0)-(f x0)``; [Idtac | Ring].
-Assert H9 : ``a<=x0<=b``.
-Split; Left; Assumption.
-Apply derivable_pt_lim_minus; [Elim (H ? H9) | Elim (H0 ? H9)]; Intros; EApply derive_pt_eq_1; Symmetry; Apply H10.
-Assert H8 := (null_derivative_loc (minus_fct g1 g2) a b H5 H6 H7); Unfold constant_D_eq in H8; Assert H9 := (H8 ? H2); Unfold minus_fct in H9; Rewrite <- H9; Ring.
-Qed.
diff --git a/theories7/Reals/NewtonInt.v b/theories7/Reals/NewtonInt.v
deleted file mode 100644
index 56e5f15e..00000000
--- a/theories7/Reals/NewtonInt.v
+++ /dev/null
@@ -1,600 +0,0 @@
-(************************************************************************)
-(*  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: NewtonInt.v,v 1.1.2.1 2004/07/16 19:31:32 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo.
-Require Ranalysis.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(*******************************************)
-(*            Newton's Integral            *)
-(*******************************************)
-
-Definition Newton_integrable [f:R->R;a,b:R] : Type := (sigTT ? [g:R->R](antiderivative f g a b)\/(antiderivative f g b a)).
-
-Definition NewtonInt [f:R->R;a,b:R;pr:(Newton_integrable f a b)] : R := let g = Cases pr of (existTT a b) => a end in ``(g b)-(g a)``.
-
-(* If f is differentiable, then f' is Newton integrable (Tautology ?) *)
-Lemma FTCN_step1 : (f:Differential;a,b:R) (Newton_integrable [x:R](derive_pt f x (cond_diff f x)) a b).
-Intros f a b; Unfold Newton_integrable; Apply existTT with (d1 f); Unfold antiderivative; Intros; Case (total_order_Rle a b); Intro; [Left; Split; [Intros; Exists (cond_diff f x); Reflexivity | Assumption] | Right; Split; [Intros; Exists (cond_diff f x); Reflexivity | Auto with real]].
-Defined.
-
-(* By definition, we have the Fondamental Theorem of Calculus *)
-Lemma FTC_Newton : (f:Differential;a,b:R) (NewtonInt [x:R](derive_pt f x (cond_diff f x)) a b (FTCN_step1 f a b))==``(f b)-(f a)``.
-Intros; Unfold NewtonInt; Reflexivity.
-Qed.
-
-(* $\int_a^a f$ exists forall a:R and f:R->R *)
-Lemma NewtonInt_P1 : (f:R->R;a:R) (Newton_integrable f a a).
-Intros f a; Unfold Newton_integrable; Apply existTT with (mult_fct (fct_cte (f a)) id); Left; Unfold antiderivative; Split.
-Intros; Assert H1 : (derivable_pt (mult_fct (fct_cte (f a)) id) x).
-Apply derivable_pt_mult.
-Apply derivable_pt_const.
-Apply derivable_pt_id.
-Exists H1; Assert H2 : x==a.
-Elim H; Intros; Apply Rle_antisym; Assumption.
-Symmetry; Apply derive_pt_eq_0; Replace (f x) with ``0*(id x)+(fct_cte (f a) x)*1``; [Apply (derivable_pt_lim_mult (fct_cte (f a)) id x); [Apply derivable_pt_lim_const | Apply derivable_pt_lim_id] | Unfold id fct_cte; Rewrite H2; Ring].
-Right; Reflexivity.
-Defined.
-
-(* $\int_a^a f = 0$ *)
-Lemma NewtonInt_P2 : (f:R->R;a:R) ``(NewtonInt f a a (NewtonInt_P1 f a))==0``.
-Intros; Unfold NewtonInt; Simpl; Unfold mult_fct fct_cte id; Ring.
-Qed.
-
-(* If $\int_a^b f$ exists, then $\int_b^a f$ exists too *)
-Lemma NewtonInt_P3 : (f:R->R;a,b:R;X:(Newton_integrable f a b)) (Newton_integrable f b a).
-Unfold Newton_integrable; Intros; Elim X; Intros g H; Apply existTT with g; Tauto.
-Defined.
-
-(* $\int_a^b f = -\int_b^a f$ *)
-Lemma NewtonInt_P4 : (f:R->R;a,b:R;pr:(Newton_integrable f a b)) ``(NewtonInt f a b pr)==-(NewtonInt f b a (NewtonInt_P3 f a b pr))``.
-Intros; Unfold Newton_integrable in pr; Elim pr; Intros; Elim p; Intro.
-Unfold NewtonInt; Case (NewtonInt_P3 f a b (existTT R->R [g:(R->R)](antiderivative f g a b)\/(antiderivative f g b a) x p)).
-Intros; Elim o; Intro.
-Unfold antiderivative in H0; Elim H0; Intros; Elim H2; Intro.
-Unfold antiderivative in H; Elim H; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H5 H3)).
-Rewrite H3; Ring.
-Assert H1 := (antiderivative_Ucte f x x0 a b H H0); Elim H1; Intros; Unfold antiderivative in H0; Elim H0; Clear H0; Intros _ H0.
-Assert H3 : ``a<=a<=b``.
-Split; [Right; Reflexivity | Assumption].
-Assert H4 : ``a<=b<=b``.
-Split; [Assumption | Right; Reflexivity].
-Assert H5 := (H2 ? H3); Assert H6 := (H2 ? H4); Rewrite H5; Rewrite H6; Ring.
-Unfold NewtonInt; Case (NewtonInt_P3 f a b (existTT R->R [g:(R->R)](antiderivative f g a b)\/(antiderivative f g b a) x p)); Intros; Elim o; Intro.
-Assert H1 := (antiderivative_Ucte f x x0 b a H H0); Elim H1; Intros; Unfold antiderivative in H0; Elim H0; Clear H0; Intros _ H0.
-Assert H3 : ``b<=a<=a``.
-Split; [Assumption | Right; Reflexivity].
-Assert H4 : ``b<=b<=a``.
-Split; [Right; Reflexivity | Assumption].
-Assert H5 := (H2 ? H3); Assert H6 := (H2 ? H4); Rewrite H5; Rewrite H6; Ring.
-Unfold antiderivative in H0; Elim H0; Intros; Elim H2; Intro.
-Unfold antiderivative in H; Elim H; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H5 H3)).
-Rewrite H3; Ring.
-Qed.
-
-(* The set of Newton integrable functions is a vectorial space *)
-Lemma NewtonInt_P5 : (f,g:R->R;l,a,b:R) (Newton_integrable f a b) -> (Newton_integrable g a b) -> (Newton_integrable [x:R]``l*(f x)+(g x)`` a b).
-Unfold Newton_integrable; Intros; Elim X; Intros; Elim X0; Intros; Exists [y:R]``l*(x y)+(x0 y)``.
-Elim p; Intro.
-Elim p0; Intro.
-Left; Unfold antiderivative; Unfold antiderivative in H H0; Elim H; Clear H; Intros; Elim H0; Clear H0; Intros H0 _.
-Split.
-Intros; Elim (H ? H2); Elim (H0 ? H2); Intros.
-Assert H5 : (derivable_pt [y:R]``l*(x y)+(x0 y)`` x1).
-Reg.
-Exists H5; Symmetry; Reg; Rewrite <- H3; Rewrite <- H4; Reflexivity.
-Assumption.
-Unfold antiderivative in H H0; Elim H; Elim H0; Intros; Elim H4; Intro.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H5 H2)).
-Left; Rewrite <- H5; Unfold antiderivative; Split.
-Intros; Elim H6; Intros; Assert H9 : ``x1==a``.
-Apply Rle_antisym; Assumption.
-Assert H10 : ``a<=x1<=b``.
-Split; Right; [Symmetry; Assumption | Rewrite <- H5; Assumption].
-Assert H11 : ``b<=x1<=a``.
-Split; Right; [Rewrite <- H5; Symmetry; Assumption | Assumption].
-Assert H12 : (derivable_pt x x1).
-Unfold derivable_pt; Exists (f x1); Elim (H3 ? H10); Intros; EApply derive_pt_eq_1; Symmetry; Apply H12.
-Assert H13 : (derivable_pt x0 x1).
-Unfold derivable_pt; Exists (g x1); Elim (H1 ? H11); Intros; EApply derive_pt_eq_1; Symmetry; Apply H13.
-Assert H14 : (derivable_pt [y:R]``l*(x y)+(x0 y)`` x1).
-Reg.
-Exists H14; Symmetry; Reg.
-Assert H15 : ``(derive_pt x0 x1 H13)==(g x1)``.
-Elim (H1 ? H11); Intros; Rewrite H15; Apply pr_nu.
-Assert H16 : ``(derive_pt x x1 H12)==(f x1)``.
-Elim (H3 ? H10); Intros; Rewrite H16; Apply pr_nu.
-Rewrite H15; Rewrite H16; Ring.
-Right; Reflexivity.
-Elim p0; Intro.
-Unfold antiderivative in H H0; Elim H; Elim H0; Intros; Elim H4; Intro.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H5 H2)).
-Left; Rewrite H5; Unfold antiderivative; Split.
-Intros; Elim H6; Intros; Assert H9 : ``x1==a``.
-Apply Rle_antisym; Assumption.
-Assert H10 : ``a<=x1<=b``.
-Split; Right; [Symmetry; Assumption | Rewrite H5; Assumption].
-Assert H11 : ``b<=x1<=a``.
-Split; Right; [Rewrite H5; Symmetry; Assumption | Assumption].
-Assert H12 : (derivable_pt x x1).
-Unfold derivable_pt; Exists (f x1); Elim (H3 ? H11); Intros; EApply derive_pt_eq_1; Symmetry; Apply H12.
-Assert H13 : (derivable_pt x0 x1).
-Unfold derivable_pt; Exists (g x1); Elim (H1 ? H10); Intros; EApply derive_pt_eq_1; Symmetry; Apply H13.
-Assert H14 : (derivable_pt [y:R]``l*(x y)+(x0 y)`` x1).
-Reg.
-Exists H14; Symmetry; Reg.
-Assert H15 : ``(derive_pt x0 x1 H13)==(g x1)``.
-Elim (H1 ? H10); Intros; Rewrite H15; Apply pr_nu.
-Assert H16 : ``(derive_pt x x1 H12)==(f x1)``.
-Elim (H3 ? H11); Intros; Rewrite H16; Apply pr_nu.
-Rewrite H15; Rewrite H16; Ring.
-Right; Reflexivity.
-Right; Unfold antiderivative; Unfold antiderivative in H H0; Elim H; Clear H; Intros; Elim H0; Clear H0; Intros H0 _; Split.
-Intros; Elim (H ? H2); Elim (H0 ? H2); Intros.
-Assert H5 : (derivable_pt [y:R]``l*(x y)+(x0 y)`` x1).
-Reg.
-Exists H5; Symmetry; Reg; Rewrite <- H3; Rewrite <- H4; Reflexivity.
-Assumption.
-Defined.
-
-(**********)
-Lemma antiderivative_P1 : (f,g,F,G:R->R;l,a,b:R) (antiderivative f F a b) -> (antiderivative g G a b) -> (antiderivative [x:R]``l*(f x)+(g x)`` [x:R]``l*(F x)+(G x)`` a b).
-Unfold antiderivative; Intros; Elim H; Elim H0; Clear H H0; Intros; Split.
-Intros; Elim (H ? H3); Elim (H1 ? H3); Intros.
-Assert H6 : (derivable_pt [x:R]``l*(F x)+(G x)`` x).
-Reg.
-Exists H6; Symmetry; Reg; Rewrite <- H4; Rewrite <- H5; Ring.
-Assumption.
-Qed.
-
-(* $\int_a^b \lambda f + g = \lambda \int_a^b f + \int_a^b f *)
-Lemma NewtonInt_P6 : (f,g:R->R;l,a,b:R;pr1:(Newton_integrable f a b);pr2:(Newton_integrable g a b)) (NewtonInt [x:R]``l*(f x)+(g x)`` a b (NewtonInt_P5 f g l a b pr1 pr2))==``l*(NewtonInt f a b pr1)+(NewtonInt g a b pr2)``.
-Intros f g l a b pr1 pr2; Unfold NewtonInt; Case (NewtonInt_P5 f g l a b pr1 pr2); Intros; Case pr1; Intros; Case pr2; Intros; Case (total_order_T a b); Intro.
-Elim s; Intro.
-Elim o; Intro.
-Elim o0; Intro.
-Elim o1; Intro.
-Assert H2 := (antiderivative_P1 f g x0 x1 l a b H0 H1); Assert H3 := (antiderivative_Ucte ? ? ? ? ? H H2); Elim H3; Intros; Assert H5 : ``a<=a<=b``.
-Split; [Right; Reflexivity | Left; Assumption].
-Assert H6 : ``a<=b<=b``.
-Split; [Left; Assumption | Right; Reflexivity].
-Assert H7 := (H4 ? H5); Assert H8 := (H4 ? H6); Rewrite H7; Rewrite H8; Ring.
-Unfold antiderivative in H1; Elim H1; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H3 a0)).
-Unfold antiderivative in H0; Elim H0; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 a0)).
-Unfold antiderivative in H; Elim H; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H1 a0)).
-Rewrite b0; Ring.
-Elim o; Intro.
-Unfold antiderivative in H; Elim H; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H1 r)).
-Elim o0; Intro.
-Unfold antiderivative in H0; Elim H0; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 r)).
-Elim o1; Intro.
-Unfold antiderivative in H1; Elim H1; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H3 r)).
-Assert H2 := (antiderivative_P1 f g x0 x1 l b a H0 H1); Assert H3 := (antiderivative_Ucte ? ? ? ? ? H H2); Elim H3; Intros; Assert H5 : ``b<=a<=a``.
-Split; [Left; Assumption | Right; Reflexivity].
-Assert H6 : ``b<=b<=a``.
-Split; [Right; Reflexivity | Left; Assumption].
-Assert H7 := (H4 ? H5); Assert H8 := (H4 ? H6); Rewrite H7; Rewrite H8; Ring.
-Qed.
-
-Lemma antiderivative_P2 : (f,F0,F1:R->R;a,b,c:R) (antiderivative f F0 a b) -> (antiderivative f F1 b c) -> (antiderivative f [x:R](Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))``  end) a c).
-Unfold antiderivative; Intros; Elim H; Clear H; Intros; Elim H0; Clear H0; Intros; Split.
-2:Apply Rle_trans with b; Assumption.
-Intros; Elim H3; Clear H3; Intros; Case (total_order_T x b); Intro.
-Elim s; Intro.
-Assert H5 : ``a<=x<=b``.
-Split; [Assumption | Left; Assumption].
-Assert H6 := (H ? H5); Elim H6; Clear H6; Intros; Assert H7 : (derivable_pt_lim [x:R](Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))`` end) x (f x)).
-Unfold derivable_pt_lim; Assert H7 : ``(derive_pt F0 x x0)==(f x)``.
-Symmetry; Assumption.
-Assert H8 := (derive_pt_eq_1 F0 x (f x) x0 H7); Unfold derivable_pt_lim in H8; Intros; Elim (H8 ? H9); Intros; Pose D := (Rmin x1 ``b-x``).
-Assert H11 : ``0<D``.
-Unfold D; Unfold Rmin; Case (total_order_Rle x1 ``b-x``); Intro.
-Apply (cond_pos x1).
-Apply Rlt_Rminus; Assumption.
-Exists (mkposreal ? H11); Intros; Case (total_order_Rle x b); Intro.
-Case (total_order_Rle ``x+h`` b); Intro.
-Apply H10.
-Assumption.
-Apply Rlt_le_trans with D; [Assumption | Unfold D; Apply Rmin_l].
-Elim n; Left; Apply Rlt_le_trans with ``x+D``.
-Apply Rlt_compatibility; Apply Rle_lt_trans with (Rabsolu h).
-Apply Rle_Rabsolu.
-Apply H13.
-Apply Rle_anti_compatibility with ``-x``; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Rewrite Rplus_sym; Unfold D; Apply Rmin_r.
-Elim n; Left; Assumption.
-Assert H8 : (derivable_pt  [x:R]Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))`` end x).
-Unfold derivable_pt; Apply Specif.existT with (f x); Apply H7.
-Exists H8; Symmetry; Apply derive_pt_eq_0; Apply H7.
-Assert H5 : ``a<=x<=b``.
-Split; [Assumption | Right; Assumption].
-Assert H6 :  ``b<=x<=c``.
-Split; [Right; Symmetry; Assumption | Assumption].
-Elim (H ? H5); Elim (H0 ? H6); Intros; Assert H9 : (derive_pt F0 x x1)==(f x).
-Symmetry; Assumption.
-Assert H10 : (derive_pt F1 x x0)==(f x).
-Symmetry; Assumption.
-Assert H11 := (derive_pt_eq_1 F0 x (f x) x1 H9); Assert H12 := (derive_pt_eq_1 F1 x (f x) x0 H10); Assert H13 : (derivable_pt_lim [x:R]Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))`` end x (f x)).
-Unfold derivable_pt_lim; Unfold derivable_pt_lim in H11 H12; Intros; Elim (H11 ? H13); Elim (H12 ? H13); Intros; Pose D := (Rmin x2 x3); Assert H16 : ``0<D``.
-Unfold D; Unfold Rmin; Case (total_order_Rle x2 x3); Intro.
-Apply (cond_pos x2).
-Apply (cond_pos x3).
-Exists (mkposreal ? H16); Intros; Case (total_order_Rle x b); Intro.
-Case (total_order_Rle ``x+h`` b); Intro.
-Apply H15.
-Assumption.
-Apply Rlt_le_trans with D; [Assumption | Unfold D; Apply Rmin_r].
-Replace ``(F1 (x+h))+((F0 b)-(F1 b))-(F0 x)`` with ``(F1 (x+h))-(F1 x)``.
-Apply H14.
-Assumption.
-Apply Rlt_le_trans with D; [Assumption | Unfold D; Apply Rmin_l].
-Rewrite b0; Ring.
-Elim n; Right; Assumption.
-Assert H14 : (derivable_pt [x:R](Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))`` end) x).
-Unfold derivable_pt; Apply Specif.existT with (f x); Apply H13.
-Exists H14; Symmetry; Apply derive_pt_eq_0; Apply H13.
-Assert H5 : ``b<=x<=c``.
-Split; [Left; Assumption | Assumption].
-Assert H6 := (H0 ? H5); Elim H6; Clear H6; Intros; Assert H7 : (derivable_pt_lim [x:R]Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))`` end x (f x)).
-Unfold derivable_pt_lim; Assert H7 : ``(derive_pt F1 x x0)==(f x)``.
-Symmetry; Assumption.
-Assert H8 := (derive_pt_eq_1 F1 x (f x) x0 H7); Unfold derivable_pt_lim in H8; Intros; Elim (H8 ? H9); Intros; Pose D := (Rmin x1 ``x-b``); Assert H11 : ``0<D``.
-Unfold D; Unfold Rmin; Case (total_order_Rle x1 ``x-b``); Intro.
-Apply (cond_pos x1).
-Apply Rlt_Rminus; Assumption.
-Exists (mkposreal ? H11); Intros; Case (total_order_Rle x b); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r0 r)).
-Case (total_order_Rle ``x+h`` b); Intro.
-Cut ``b<x+h``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r0 H14)).
-Apply Rlt_anti_compatibility with ``-h-b``; Replace ``-h-b+b`` with ``-h``; [Idtac | Ring]; Replace ``-h-b+(x+h)`` with ``x-b``; [Idtac | Ring]; Apply Rle_lt_trans with (Rabsolu h).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Apply Rlt_le_trans with D.
-Apply H13.
-Unfold D; Apply Rmin_r.
-Replace ``((F1 (x+h))+((F0 b)-(F1 b)))-((F1 x)+((F0 b)-(F1 b)))`` with ``(F1 (x+h))-(F1 x)``; [Idtac | Ring]; Apply H10.
-Assumption.
-Apply Rlt_le_trans with D.
-Assumption.
-Unfold D; Apply Rmin_l.
-Assert H8 : (derivable_pt  [x:R]Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))`` end x).
-Unfold derivable_pt; Apply Specif.existT with (f x); Apply H7.
-Exists H8; Symmetry; Apply derive_pt_eq_0; Apply H7.
-Qed.
-
-Lemma antiderivative_P3 : (f,F0,F1:R->R;a,b,c:R) (antiderivative f F0 a b) -> (antiderivative f F1 c b) -> (antiderivative f F1 c a)\/(antiderivative f F0 a c).
-Intros; Unfold antiderivative in H H0; Elim H; Clear H; Elim H0; Clear H0; Intros; Case (total_order_T a c); Intro.
-Elim s; Intro.
-Right; Unfold antiderivative; Split.
-Intros; Apply H1; Elim H3; Intros; Split; [Assumption | Apply Rle_trans with c; Assumption].
-Left; Assumption.
-Right; Unfold antiderivative; Split.
-Intros; Apply H1; Elim H3; Intros; Split; [Assumption | Apply Rle_trans with c; Assumption].
-Right; Assumption.
-Left; Unfold antiderivative; Split.
-Intros; Apply H; Elim H3; Intros; Split; [Assumption | Apply Rle_trans with a; Assumption].
-Left; Assumption.
-Qed.
-
-Lemma antiderivative_P4 : (f,F0,F1:R->R;a,b,c:R) (antiderivative f F0 a b) -> (antiderivative f F1 a c) -> (antiderivative f F1 b c)\/(antiderivative f F0 c b).
-Intros; Unfold antiderivative in H H0; Elim H; Clear H; Elim H0; Clear H0; Intros; Case (total_order_T c b); Intro.
-Elim s; Intro.
-Right; Unfold antiderivative; Split.
-Intros; Apply H1; Elim H3; Intros; Split; [Apply Rle_trans with c; Assumption | Assumption].
-Left; Assumption.
-Right; Unfold antiderivative; Split.
-Intros; Apply H1; Elim H3; Intros; Split; [Apply Rle_trans with c; Assumption | Assumption].
-Right; Assumption.
-Left; Unfold antiderivative; Split.
-Intros; Apply H; Elim H3; Intros; Split; [Apply Rle_trans with b; Assumption | Assumption].
-Left; Assumption.
-Qed.
-
-Lemma NewtonInt_P7 : (f:R->R;a,b,c:R) ``a<b`` -> ``b<c`` -> (Newton_integrable f a b) -> (Newton_integrable f b c) -> (Newton_integrable f a c).
-Unfold Newton_integrable; Intros f a b c Hab Hbc X X0; Elim X; Clear X; Intros F0 H0; Elim X0; Clear X0; Intros F1 H1; Pose g := [x:R](Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))``  end); Apply existTT with g; Left; Unfold g; Apply antiderivative_P2.
-Elim H0; Intro.
-Assumption.
-Unfold antiderivative in H; Elim H; Clear H; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 Hab)).
-Elim H1; Intro.
-Assumption.
-Unfold antiderivative in H; Elim H; Clear H; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 Hbc)).
-Qed.
-
-Lemma NewtonInt_P8 : (f:(R->R); a,b,c:R) (Newton_integrable f a b) -> (Newton_integrable f b c) -> (Newton_integrable f a c).
-Intros.
-Elim X; Intros F0 H0.
-Elim X0; Intros F1 H1.
-Case (total_order_T a b); Intro.
-Elim s; Intro.
-Case (total_order_T b c); Intro.
-Elim s0; Intro.
-(* a<b & b<c *)
-Unfold Newton_integrable; Apply existTT with [x:R](Cases (total_order_Rle x b) of (leftT _) => (F0 x) | (rightT _) => ``(F1 x)+((F0 b)-(F1 b))`` end).
-Elim H0; Intro.
-Elim H1; Intro.
-Left; Apply antiderivative_P2; Assumption.
-Unfold antiderivative in H2; Elim H2; Clear H2; Intros _ H2.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 a1)).
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H a0)).
-(* a<b & b=c *)
-Rewrite b0 in X; Apply X.
-(* a<b & b>c *)
-Case (total_order_T a c); Intro.
-Elim s0; Intro.
-Unfold Newton_integrable; Apply existTT with F0.
-Left.
-Elim H1; Intro.
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Elim H0; Intro.
-Assert H3 := (antiderivative_P3 f F0 F1 a b c H2 H).
-Elim H3; Intro.
-Unfold antiderivative in H4; Elim H4; Clear H4; Intros _ H4.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H4 a1)).
-Assumption.
-Unfold antiderivative in H2; Elim H2; Clear H2; Intros _ H2.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 a0)).
-Rewrite b0; Apply NewtonInt_P1.
-Unfold Newton_integrable; Apply existTT with F1.
-Right.
-Elim H1; Intro.
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Elim H0; Intro.
-Assert H3 := (antiderivative_P3 f F0 F1 a b c H2 H).
-Elim H3; Intro.
-Assumption.
-Unfold antiderivative in H4; Elim H4; Clear H4; Intros _ H4.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H4 r0)).
-Unfold antiderivative in H2; Elim H2; Clear H2; Intros _ H2.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 a0)).
-(* a=b *)
-Rewrite b0; Apply X0.
-Case (total_order_T b c); Intro.
-Elim s; Intro.
-(* a>b & b<c *)
-Case (total_order_T a c); Intro.
-Elim s0; Intro.
-Unfold Newton_integrable; Apply existTT with F1.
-Left.
-Elim H1; Intro.
-(*****************)
-Elim H0; Intro.
-Unfold antiderivative in H2; Elim H2; Clear H2; Intros _ H2.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 r)).
-Assert H3 := (antiderivative_P4 f F0 F1 b a c H2 H).
-Elim H3; Intro.
-Assumption.
-Unfold antiderivative in H4; Elim H4; Clear H4; Intros _ H4.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H4 a1)).
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H a0)).
-Rewrite b0; Apply NewtonInt_P1.
-Unfold Newton_integrable; Apply existTT with F0.
-Right.
-Elim H0; Intro.
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Elim H1; Intro.
-Assert H3 := (antiderivative_P4 f F0 F1 b a c H H2).
-Elim H3; Intro.
-Unfold antiderivative in H4; Elim H4; Clear H4; Intros _ H4.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H4 r0)).
-Assumption.
-Unfold antiderivative in H2; Elim H2; Clear H2; Intros _ H2.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H2 a0)).
-(* a>b & b=c *)
-Rewrite b0 in X; Apply X.
-(* a>b & b>c *)
-Assert X1 := (NewtonInt_P3 f a b X).
-Assert X2 := (NewtonInt_P3 f b c X0).
-Apply NewtonInt_P3.
-Apply NewtonInt_P7 with b; Assumption.
-Defined.
-
-(* Chasles' relation *)
-Lemma NewtonInt_P9 : (f:R->R;a,b,c:R;pr1:(Newton_integrable f a b);pr2:(Newton_integrable f b c)) ``(NewtonInt f a c (NewtonInt_P8 f a b c pr1 pr2))==(NewtonInt f a b pr1)+(NewtonInt f b c pr2)``.
-Intros; Unfold NewtonInt.
-Case (NewtonInt_P8 f a b c pr1 pr2); Intros.
-Case pr1; Intros.
-Case pr2; Intros.
-Case (total_order_T a b); Intro.
-Elim s; Intro.
-Case (total_order_T b c); Intro.
-Elim s0; Intro.
-(* a<b & b<c *)
-Elim o0; Intro.
-Elim o1; Intro.
-Elim o; Intro.
-Assert H2 := (antiderivative_P2 f x0 x1 a b c H H0).
-Assert H3 := (antiderivative_Ucte f x [x:R]
-          Cases (total_order_Rle x b) of
-            (leftT _) => (x0 x)
-          | (rightT _) => ``(x1 x)+((x0 b)-(x1 b))``
-          end a c H1 H2).
-Elim H3; Intros.
-Assert H5 : ``a<=a<=c``.
-Split; [Right; Reflexivity | Left; Apply Rlt_trans with b; Assumption].
-Assert H6 : ``a<=c<=c``.
-Split; [Left; Apply Rlt_trans with b; Assumption | Right; Reflexivity].
-Rewrite (H4 ? H5); Rewrite (H4 ? H6).
-Case (total_order_Rle a b); Intro.
-Case (total_order_Rle c b); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r0 a1)).
-Ring.
-Elim n; Left; Assumption.
-Unfold antiderivative in H1; Elim H1; Clear H1; Intros _ H1.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H1 (Rlt_trans ? ? ? a0 a1))).
-Unfold antiderivative in H0; Elim H0; Clear H0; Intros _ H0.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H0 a1)).
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H a0)).
-(* a<b & b=c *)
-Rewrite <- b0.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or.
-Rewrite <- b0 in o.
-Elim o0; Intro.
-Elim o; Intro.
-Assert H1 := (antiderivative_Ucte f x x0 a b H0 H).
-Elim H1; Intros.
-Rewrite (H2 b).
-Rewrite (H2 a).
-Ring.
-Split; [Right; Reflexivity | Left; Assumption].
-Split; [Left; Assumption | Right; Reflexivity].
-Unfold antiderivative in H0; Elim H0; Clear H0; Intros _ H0.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H0 a0)).
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H a0)).
-(* a<b & b>c *)
-Elim o1; Intro.
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Elim o0; Intro.
-Elim o; Intro.
-Assert H2 := (antiderivative_P2 f x x1 a c b H1 H).
-Assert H3 := (antiderivative_Ucte ? ? ? a b H0 H2).
-Elim H3; Intros.
-Rewrite (H4 a).
-Rewrite (H4 b).
-Case (total_order_Rle b c); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r0 r)).
-Case (total_order_Rle a c); Intro.
-Ring.
-Elim n0; Unfold antiderivative in H1; Elim H1; Intros; Assumption.
-Split; [Left; Assumption | Right; Reflexivity].
-Split; [Right; Reflexivity | Left; Assumption].
-Assert H2 := (antiderivative_P2 ? ? ? ? ? ? H1 H0).
-Assert H3 := (antiderivative_Ucte ? ? ? c b H H2).
-Elim H3; Intros.
-Rewrite (H4 c).
-Rewrite (H4 b).
-Case (total_order_Rle b a); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r0 a0)).
-Case (total_order_Rle c a); Intro.
-Ring.
-Elim n0; Unfold antiderivative in H1; Elim H1; Intros; Assumption.
-Split; [Left; Assumption | Right; Reflexivity].
-Split; [Right; Reflexivity | Left; Assumption].
-Unfold antiderivative in H0; Elim H0; Clear H0; Intros _ H0.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H0 a0)).
-(* a=b *)
-Rewrite b0 in o; Rewrite b0.
-Elim o; Intro.
-Elim o1; Intro.
-Assert H1 := (antiderivative_Ucte ? ? ? b c H H0).
-Elim H1; Intros.
-Assert H3 : ``b<=c``.
-Unfold antiderivative in H; Elim H; Intros; Assumption.
-Rewrite (H2 b).
-Rewrite (H2 c).
-Ring.
-Split; [Assumption | Right; Reflexivity].
-Split; [Right; Reflexivity | Assumption].
-Assert H1 : ``b==c``.
-Unfold antiderivative in H H0; Elim H; Elim H0; Intros; Apply Rle_antisym; Assumption.
-Rewrite H1; Ring.
-Elim o1; Intro.
-Assert H1 : ``b==c``.
-Unfold antiderivative in H H0; Elim H; Elim H0; Intros; Apply Rle_antisym; Assumption.
-Rewrite H1; Ring.
-Assert H1 := (antiderivative_Ucte ? ? ? c b H H0).
-Elim H1; Intros.
-Assert H3 : ``c<=b``.
-Unfold antiderivative in H; Elim H; Intros; Assumption.
-Rewrite (H2 c).
-Rewrite (H2 b).
-Ring.
-Split; [Assumption | Right; Reflexivity].
-Split; [Right; Reflexivity | Assumption].
-(* a>b & b<c *)
-Case (total_order_T b c); Intro.
-Elim s; Intro.
-Elim o0; Intro.
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Elim o1; Intro.
-Elim o; Intro.
-Assert H2 := (antiderivative_P2 ? ? ? ? ? ? H H1).
-Assert H3 := (antiderivative_Ucte ? ? ? b c H0 H2).
-Elim H3; Intros.
-Rewrite (H4 b).
-Rewrite (H4 c).
-Case (total_order_Rle b a); Intro.
-Case (total_order_Rle c a); Intro.
-Assert H5 : ``a==c``.
-Unfold antiderivative in  H1; Elim H1; Intros; Apply Rle_antisym; Assumption.
-Rewrite H5; Ring.
-Ring.
-Elim n; Left; Assumption.
-Split; [Left; Assumption | Right; Reflexivity].
-Split; [Right; Reflexivity | Left; Assumption].
-Assert H2 := (antiderivative_P2 ? ? ? ? ? ? H0 H1).
-Assert H3 := (antiderivative_Ucte ? ? ? b a H H2).
-Elim H3; Intros.
-Rewrite (H4 a).
-Rewrite (H4 b).
-Case (total_order_Rle b c); Intro.
-Case (total_order_Rle a c); Intro.
-Assert H5 : ``a==c``.
-Unfold antiderivative in  H1; Elim H1; Intros; Apply Rle_antisym; Assumption.
-Rewrite H5; Ring.
-Ring.
-Elim n; Left; Assumption.
-Split; [Right; Reflexivity | Left; Assumption].
-Split; [Left; Assumption | Right; Reflexivity].
-Unfold antiderivative in H0; Elim H0; Clear H0; Intros _ H0.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H0 a0)).
-(* a>b & b=c *)
-Rewrite <- b0.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or.
-Rewrite <- b0 in o.
-Elim o0; Intro.
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Elim o; Intro.
-Unfold antiderivative in H0; Elim H0; Clear H0; Intros _ H0.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H0 r)).
-Assert H1 := (antiderivative_Ucte f x x0 b a H0 H).
-Elim H1; Intros.
-Rewrite (H2 b).
-Rewrite (H2 a).
-Ring.
-Split; [Left; Assumption | Right; Reflexivity].
-Split; [Right; Reflexivity | Left; Assumption].
-(* a>b & b>c *)
-Elim o0; Intro.
-Unfold antiderivative in H; Elim H; Clear H; Intros _ H.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Elim o1; Intro.
-Unfold antiderivative in H0; Elim H0; Clear H0; Intros _ H0.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H0 r0)).
-Elim o; Intro.
-Unfold antiderivative in H1; Elim H1; Clear H1; Intros _ H1.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H1 (Rlt_trans ? ? ? r0 r))).
-Assert H2 := (antiderivative_P2 ? ? ? ? ? ? H0 H).
-Assert H3 := (antiderivative_Ucte ? ? ? c a H1 H2).
-Elim H3; Intros.
-Assert H5 : ``c<=a``.
-Unfold antiderivative in H1; Elim H1; Intros; Assumption.
-Rewrite (H4 c).
-Rewrite (H4 a).
-Case (total_order_Rle a b); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r1 r)).
-Case (total_order_Rle c b); Intro.
-Ring.
-Elim n0; Left; Assumption.
-Split; [Assumption | Right; Reflexivity].
-Split; [Right; Reflexivity | Assumption].
-Qed.
-
diff --git a/theories7/Reals/PSeries_reg.v b/theories7/Reals/PSeries_reg.v
deleted file mode 100644
index 68645379..00000000
--- a/theories7/Reals/PSeries_reg.v
+++ /dev/null
@@ -1,194 +0,0 @@
-(************************************************************************)
-(*  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: PSeries_reg.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Ranalysis1.
-Require Max.
-Require Even.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Definition Boule [x:R;r:posreal] : R -> Prop := [y:R]``(Rabsolu (y-x))<r``.
-
-(* Uniform convergence *)
-Definition CVU [fn:nat->R->R;f:R->R;x:R;r:posreal] : Prop := (eps:R)``0<eps``->(EX N:nat | (n:nat;y:R) (le N n)->(Boule x r y)->``(Rabsolu ((f y)-(fn n y)))<eps``). 
-
-(* Normal convergence *)
-Definition CVN_r [fn:nat->R->R;r:posreal] : Type := (SigT ? [An:nat->R](sigTT R [l:R]((Un_cv [n:nat](sum_f_R0 [k:nat](Rabsolu (An k)) n) l)/\((n:nat)(y:R)(Boule R0 r y)->(Rle (Rabsolu (fn n y)) (An n)))))).
-
-Definition CVN_R [fn:nat->R->R] : Type := (r:posreal) (CVN_r fn r).
-
-Definition SFL [fn:nat->R->R;cv:(x:R)(sigTT ? [l:R](Un_cv [N:nat](SP fn N x) l))] : R-> R := [y:R](Cases (cv y) of (existTT a b) => a end).
-
-(* In a complete space, normal convergence implies uniform convergence *)
-Lemma CVN_CVU : (fn:nat->R->R;cv:(x:R)(sigTT ? [l:R](Un_cv [N:nat](SP fn N x) l));r:posreal) (CVN_r fn r) -> (CVU [n:nat](SP fn n) (SFL fn cv) ``0`` r).
-Intros; Unfold CVU; Intros.
-Unfold CVN_r in X.
-Elim X; Intros An X0.
-Elim X0; Intros s H0.
-Elim H0; Intros.
-Cut (Un_cv [n:nat](Rminus (sum_f_R0 [k:nat]``(Rabsolu (An k))`` n) s) R0).
-Intro; Unfold Un_cv in H3.
-Elim (H3 eps H); Intros N0 H4.
-Exists N0; Intros.
-Apply Rle_lt_trans with (Rabsolu (Rminus (sum_f_R0 [k:nat]``(Rabsolu (An k))`` n) s)).
-Rewrite <- (Rabsolu_Ropp (Rminus (sum_f_R0 [k:nat]``(Rabsolu (An k))`` n) s)); Rewrite Ropp_distr3; Rewrite (Rabsolu_right (Rminus s (sum_f_R0 [k:nat]``(Rabsolu (An k))`` n))).
-EApply sum_maj1.
-Unfold SFL; Case (cv y); Intro.
-Trivial.
-Apply H1.
-Intro; Elim H0; Intros.
-Rewrite (Rabsolu_right (An n0)).
-Apply H8; Apply H6.
-Apply Rle_sym1; Apply Rle_trans with (Rabsolu (fn n0 y)).
-Apply Rabsolu_pos.
-Apply H8; Apply H6.
-Apply Rle_sym1; Apply Rle_anti_compatibility with (sum_f_R0 [k:nat](Rabsolu (An k)) n).
-Rewrite Rplus_Or; Unfold Rminus; Rewrite (Rplus_sym s); Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Ol; Apply sum_incr.
-Apply H1.
-Intro; Apply Rabsolu_pos.
-Unfold R_dist in H4; Unfold Rminus in H4; Rewrite Ropp_O in H4.
-Assert H7 := (H4 n H5).
-Rewrite Rplus_Or in H7; Apply H7.
-Unfold Un_cv in H1; Unfold Un_cv; Intros.
-Elim (H1? H3); Intros.
-Exists x; Intros.
-Unfold R_dist; Unfold R_dist in H4.
-Rewrite minus_R0; Apply H4; Assumption.
-Qed.
-
-(* Each limit of a sequence of functions which converges uniformly is continue *)
-Lemma CVU_continuity : (fn:nat->R->R;f:R->R;x:R;r:posreal) (CVU fn f x r) -> ((n:nat)(y:R) (Boule x r y)->(continuity_pt (fn n) y)) -> ((y:R) (Boule x r y) -> (continuity_pt f y)).
-Intros; Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros.
-Unfold CVU in H.
-Cut ``0<eps/3``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0]].
-Elim (H ? H3); Intros N0 H4.
-Assert H5 := (H0 N0 y H1).
-Cut (EXT del : posreal | (h:R) ``(Rabsolu h)<del`` -> (Boule x r ``y+h``) ).
-Intro.
-Elim H6; Intros del1 H7.
-Unfold continuity_pt in H5; Unfold continue_in in H5; Unfold limit1_in in H5; Unfold limit_in in H5; Simpl in H5; Unfold R_dist in H5.
-Elim (H5 ? H3); Intros del2 H8.
-Pose del := (Rmin del1 del2).
-Exists del; Intros.
-Split.
-Unfold del; Unfold Rmin; Case (total_order_Rle del1 del2); Intro.
-Apply (cond_pos del1).
-Elim H8; Intros; Assumption.
-Intros; Apply Rle_lt_trans with ``(Rabsolu ((f x0)-(fn N0 x0)))+(Rabsolu ((fn N0 x0)-(f y)))``.
-Replace ``(f x0)-(f y)`` with ``((f x0)-(fn N0 x0))+((fn N0 x0)-(f y))``; [Apply Rabsolu_triang | Ring].
-Apply Rle_lt_trans with ``(Rabsolu ((f x0)-(fn N0 x0)))+(Rabsolu ((fn N0 x0)-(fn N0 y)))+(Rabsolu ((fn N0 y)-(f y)))``.
-Rewrite Rplus_assoc; Apply Rle_compatibility.
-Replace ``(fn N0 x0)-(f y)`` with ``((fn N0 x0)-(fn N0 y))+((fn N0 y)-(f y))``; [Apply Rabsolu_triang | Ring].
-Replace ``eps`` with ``eps/3+eps/3+eps/3``.
-Repeat Apply Rplus_lt.
-Apply H4.
-Apply le_n.
-Replace x0 with ``y+(x0-y)``; [Idtac | Ring]; Apply H7.
-Elim H9; Intros.
-Apply Rlt_le_trans with del.
-Assumption.
-Unfold del; Apply Rmin_l.
-Elim H8; Intros.
-Apply H11.
-Split.
-Elim H9; Intros; Assumption.
-Elim H9; Intros; Apply Rlt_le_trans with del.
-Assumption.
-Unfold del; Apply Rmin_r.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr3; Apply H4.
-Apply le_n.
-Assumption.
-Apply r_Rmult_mult with ``3``.
-Do 2 Rewrite Rmult_Rplus_distr; Unfold Rdiv; Rewrite <- Rmult_assoc; Rewrite Rinv_r_simpl_m.
-Ring.
-DiscrR.
-DiscrR.
-Cut ``0<r-(Rabsolu (x-y))``.
-Intro; Exists (mkposreal ? H6).
-Simpl; Intros.
-Unfold Boule; Replace ``y+h-x`` with ``h+(y-x)``; [Idtac | Ring]; Apply Rle_lt_trans with ``(Rabsolu h)+(Rabsolu (y-x))``.
-Apply Rabsolu_triang.
-Apply Rlt_anti_compatibility with ``-(Rabsolu (x-y))``.
-Rewrite <- (Rabsolu_Ropp ``y-x``); Rewrite Ropp_distr3.
-Replace ``-(Rabsolu (x-y))+r`` with ``r-(Rabsolu (x-y))``.
-Replace ``-(Rabsolu (x-y))+((Rabsolu h)+(Rabsolu (x-y)))`` with (Rabsolu h).
-Apply H7.
-Ring.
-Ring.
-Unfold Boule in H1; Rewrite <- (Rabsolu_Ropp ``x-y``); Rewrite Ropp_distr3; Apply Rlt_anti_compatibility with ``(Rabsolu (y-x))``.
-Rewrite Rplus_Or; Replace ``(Rabsolu (y-x))+(r-(Rabsolu (y-x)))`` with ``(pos r)``; [Apply H1 | Ring].
-Qed.
-
-(**********)
-Lemma continuity_pt_finite_SF : (fn:nat->R->R;N:nat;x:R) ((n:nat)(le n N)->(continuity_pt (fn n) x)) -> (continuity_pt [y:R](sum_f_R0 [k:nat]``(fn k y)`` N) x).
-Intros; Induction N.
-Simpl; Apply (H O); Apply le_n.
-Simpl; Replace [y:R](Rplus (sum_f_R0 [k:nat](fn k y) N) (fn (S N) y)) with (plus_fct [y:R](sum_f_R0 [k:nat](fn k y) N) [y:R](fn (S N) y)); [Idtac | Reflexivity].
-Apply continuity_pt_plus.
-Apply HrecN.
-Intros; Apply H.
-Apply le_trans with N; [Assumption | Apply le_n_Sn].
-Apply (H (S N)); Apply le_n.
-Qed.
-
-(* Continuity and normal convergence *)
-Lemma SFL_continuity_pt : (fn:nat->R->R;cv:(x:R)(sigTT ? [l:R](Un_cv [N:nat](SP fn N x) l));r:posreal) (CVN_r fn r) -> ((n:nat)(y:R) (Boule ``0`` r y) -> (continuity_pt (fn n) y)) -> ((y:R) (Boule ``0`` r y) -> (continuity_pt (SFL fn cv) y)).
-Intros; EApply CVU_continuity.
-Apply CVN_CVU.
-Apply X.
-Intros; Unfold SP; Apply continuity_pt_finite_SF.
-Intros; Apply H.
-Apply H1.
-Apply H0.
-Qed.
-
-Lemma SFL_continuity : (fn:nat->R->R;cv:(x:R)(sigTT ? [l:R](Un_cv [N:nat](SP fn N x) l))) (CVN_R fn) -> ((n:nat)(continuity (fn n))) -> (continuity (SFL fn cv)).
-Intros; Unfold continuity; Intro.
-Cut ``0<(Rabsolu x)+1``; [Intro | Apply ge0_plus_gt0_is_gt0; [Apply Rabsolu_pos | Apply Rlt_R0_R1]].
-Cut (Boule ``0`` (mkposreal ? H0) x).
-Intro; EApply SFL_continuity_pt with (mkposreal ? H0).
-Apply X.
-Intros; Apply (H n y).
-Apply H1.
-Unfold Boule; Simpl; Rewrite minus_R0; Pattern 1 (Rabsolu x); Rewrite <- Rplus_Or; Apply Rlt_compatibility; Apply Rlt_R0_R1.
-Qed.
-
-(* As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) 
-Lemma CVN_R_CVS : (fn:nat->R->R) (CVN_R fn) -> ((x:R)(sigTT ? [l:R](Un_cv [N:nat](SP fn N x) l))).
-Intros; Apply R_complete.
-Unfold SP; Pose An := [N:nat](fn N x).
-Change (Cauchy_crit_series An).
-Apply cauchy_abs.
-Unfold Cauchy_crit_series; Apply CV_Cauchy.
-Unfold CVN_R in X; Cut ``0<(Rabsolu x)+1``.
-Intro; Assert H0 := (X (mkposreal ? H)).
-Unfold CVN_r in H0; Elim H0; Intros Bn H1.
-Elim H1; Intros l H2.
-Elim H2; Intros.
-Apply Rseries_CV_comp with Bn.
-Intro; Split.
-Apply Rabsolu_pos.
-Unfold An; Apply H4; Unfold Boule; Simpl; Rewrite minus_R0.
-Pattern 1 (Rabsolu x); Rewrite <- Rplus_Or; Apply Rlt_compatibility; Apply Rlt_R0_R1.
-Apply existTT with l.
-Cut (n:nat)``0<=(Bn n)``.
-Intro; Unfold Un_cv in H3; Unfold Un_cv; Intros.
-Elim (H3 ? H6); Intros.
-Exists x0; Intros.
-Replace (sum_f_R0 Bn n) with (sum_f_R0 [k:nat](Rabsolu (Bn k)) n).
-Apply H7; Assumption.
-Apply sum_eq; Intros; Apply Rabsolu_right; Apply Rle_sym1; Apply H5.
-Intro; Apply Rle_trans with (Rabsolu (An n)).
-Apply Rabsolu_pos.
-Unfold An; Apply H4; Unfold Boule; Simpl; Rewrite minus_R0; Pattern 1 (Rabsolu x); Rewrite <- Rplus_Or; Apply Rlt_compatibility; Apply Rlt_R0_R1.
-Apply ge0_plus_gt0_is_gt0; [Apply Rabsolu_pos | Apply Rlt_R0_R1].
-Qed.
diff --git a/theories7/Reals/PartSum.v b/theories7/Reals/PartSum.v
deleted file mode 100644
index 4d28bec8..00000000
--- a/theories7/Reals/PartSum.v
+++ /dev/null
@@ -1,475 +0,0 @@
-(************************************************************************)
-(*  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: PartSum.v,v 1.1.2.2 2005/07/13 23:19:16 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rseries.
-Require Rcomplete.
-Require Max.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Lemma tech1 : (An:nat->R;N:nat) ((n:nat)``(le n N)``->``0<(An n)``) -> ``0 < (sum_f_R0 An N)``.
-Intros; Induction N.
-Simpl; Apply H; Apply le_n.
-Simpl; Apply gt0_plus_gt0_is_gt0.
-Apply HrecN; Intros; Apply H; Apply le_S; Assumption.
-Apply H; Apply le_n.
-Qed.
-
-(* Chasles' relation *)
-Lemma tech2 : (An:nat->R;m,n:nat) (lt m n) -> (sum_f_R0 An n) == (Rplus (sum_f_R0 An m) (sum_f_R0 [i:nat]``(An (plus (S m) i))`` (minus n (S m)))). 
-Intros; Induction n.
-Elim (lt_n_O ? H).
-Cut (lt m n)\/m=n.
-Intro; Elim H0; Intro.
-Replace (sum_f_R0 An (S n)) with ``(sum_f_R0 An n)+(An (S n))``; [Idtac | Reflexivity].
-Replace (minus (S n) (S m)) with (S (minus n (S m))).
-Replace (sum_f_R0 [i:nat](An (plus (S m) i)) (S (minus n (S m)))) with (Rplus (sum_f_R0 [i:nat](An (plus (S m) i)) (minus n (S m))) (An (plus (S m) (S (minus n (S m)))))); [Idtac | Reflexivity].
-Replace (plus (S m) (S (minus n (S m)))) with (S n).
-Rewrite (Hrecn H1).
-Ring.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Do 2 Rewrite S_INR; Rewrite minus_INR.
-Rewrite S_INR; Ring.
-Apply lt_le_S; Assumption.
-Apply INR_eq; Rewrite S_INR; Repeat Rewrite minus_INR.
-Repeat Rewrite S_INR; Ring.
-Apply le_n_S; Apply lt_le_weak; Assumption.
-Apply lt_le_S; Assumption.
-Rewrite H1; Rewrite <- minus_n_n; Simpl.
-Replace (plus n O) with n; [Reflexivity | Ring].
-Inversion H.
-Right; Reflexivity.
-Left; Apply lt_le_trans with (S m); [Apply lt_n_Sn | Assumption].
-Qed.
-
-(* Sum of geometric sequences *)
-Lemma tech3 : (k:R;N:nat) ``k<>1`` -> (sum_f_R0 [i:nat](pow k i) N)==``(1-(pow k (S N)))/(1-k)``.
-Intros; Cut ``1-k<>0``.
-Intro; Induction N.
-Simpl; Rewrite Rmult_1r; Unfold Rdiv; Rewrite <- Rinv_r_sym.
-Reflexivity.
-Apply H0.
-Replace (sum_f_R0 ([i:nat](pow k i)) (S N)) with (Rplus (sum_f_R0 [i:nat](pow k i) N) (pow k (S N))); [Idtac | Reflexivity]; Rewrite HrecN; Replace ``(1-(pow k (S N)))/(1-k)+(pow k (S N))`` with ``((1-(pow k (S N)))+(1-k)*(pow k (S N)))/(1-k)``.
-Apply r_Rmult_mult with ``1-k``.
-Unfold Rdiv; Do 2 Rewrite <- (Rmult_sym ``/(1-k)``); Repeat Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [ Do 2 Rewrite Rmult_1l; Simpl; Ring | Apply H0].
-Apply H0.
-Unfold Rdiv; Rewrite Rmult_Rplus_distrl; Rewrite (Rmult_sym ``1-k``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Reflexivity.
-Apply H0.
-Apply Rminus_eq_contra; Red; Intro; Elim H; Symmetry; Assumption.
-Qed.
-
-Lemma tech4 : (An:nat->R;k:R;N:nat) ``0<=k`` -> ((i:nat)``(An (S i))<k*(An i)``) -> ``(An N)<=(An O)*(pow k N)``.
-Intros; Induction N.
-Simpl; Right; Ring.
-Apply Rle_trans with ``k*(An N)``.
-Left; Apply (H0 N).
-Replace (S N) with (plus N (1)); [Idtac | Ring].
-Rewrite pow_add; Simpl; Rewrite Rmult_1r; Replace ``(An O)*((pow k N)*k)`` with ``k*((An O)*(pow k N))``; [Idtac | Ring]; Apply Rle_monotony.
-Assumption.
-Apply HrecN.
-Qed.
-
-Lemma tech5 : (An:nat->R;N:nat) (sum_f_R0 An (S N))==``(sum_f_R0 An N)+(An (S N))``.
-Intros; Reflexivity.
-Qed.
-
-Lemma tech6 : (An:nat->R;k:R;N:nat) ``0<=k`` -> ((i:nat)``(An (S i))<k*(An i)``) -> (Rle (sum_f_R0 An N) (Rmult (An O) (sum_f_R0 [i:nat](pow k i) N))).
-Intros; Induction N.
-Simpl; Right; Ring.
-Apply Rle_trans with (Rplus (Rmult (An O) (sum_f_R0 [i:nat](pow k i) N)) (An (S N))).
-Rewrite tech5; Do 2 Rewrite <- (Rplus_sym (An (S N))); Apply Rle_compatibility.
-Apply HrecN.
-Rewrite tech5 ; Rewrite Rmult_Rplus_distr; Apply Rle_compatibility.
-Apply tech4; Assumption.
-Qed.
-
-Lemma tech7 : (r1,r2:R) ``r1<>0`` -> ``r2<>0`` -> ``r1<>r2`` -> ``/r1<>/r2``.
-Intros; Red; Intro.
-Assert H3 := (Rmult_mult_r r1 ? ? H2).
-Rewrite <- Rinv_r_sym in H3; [Idtac | Assumption].
-Assert H4 := (Rmult_mult_r r2 ? ? H3).
-Rewrite Rmult_1r in H4; Rewrite <- Rmult_assoc in H4.
-Rewrite Rinv_r_simpl_m in H4; [Idtac | Assumption].
-Elim H1; Symmetry; Assumption.
-Qed.
-
-Lemma tech11 : (An,Bn,Cn:nat->R;N:nat) ((i:nat) (An i)==``(Bn i)-(Cn i)``) -> (sum_f_R0 An N)==``(sum_f_R0 Bn N)-(sum_f_R0 Cn N)``.
-Intros; Induction N.
-Simpl; Apply H.
-Do 3 Rewrite tech5; Rewrite HrecN; Rewrite (H (S N)); Ring.
-Qed.
-
-Lemma tech12 : (An:nat->R;x:R;l:R) (Un_cv [N:nat](sum_f_R0 [i:nat]``(An i)*(pow x i)`` N) l) -> (Pser An x l).
-Intros; Unfold Pser; Unfold infinit_sum; Unfold Un_cv in H; Assumption.
-Qed. 
-
-Lemma scal_sum : (An:nat->R;N:nat;x:R) (Rmult x (sum_f_R0 An N))==(sum_f_R0 [i:nat]``(An i)*x`` N).
-Intros; Induction N.
-Simpl; Ring.
-Do 2 Rewrite tech5.
-Rewrite Rmult_Rplus_distr; Rewrite <- HrecN; Ring.
-Qed.
-
-Lemma decomp_sum : (An:nat->R;N:nat) (lt O N) -> (sum_f_R0 An N)==(Rplus (An O) (sum_f_R0 [i:nat](An (S i)) (pred N))).
-Intros; Induction N.
-Elim (lt_n_n ? H).
-Cut (lt O N)\/N=O.
-Intro; Elim H0; Intro.
-Cut (S (pred N))=(pred (S N)).
-Intro; Rewrite <- H2.
-Do 2 Rewrite tech5.
-Replace (S (S (pred N))) with (S N).
-Rewrite (HrecN H1); Ring.
-Rewrite H2; Simpl; Reflexivity.
-Assert H2 := (O_or_S N).
-Elim H2; Intros.
-Elim a; Intros.
-Rewrite <- p.
-Simpl; Reflexivity.
-Rewrite <- b in H1; Elim (lt_n_n ? H1).
-Rewrite H1; Simpl; Reflexivity.
-Inversion H.
-Right; Reflexivity.
-Left; Apply lt_le_trans with (1); [Apply lt_O_Sn | Assumption].
-Qed.
-
-Lemma plus_sum : (An,Bn:nat->R;N:nat) (sum_f_R0 [i:nat]``(An i)+(Bn i)`` N)==``(sum_f_R0 An N)+(sum_f_R0 Bn N)``.
-Intros; Induction N.
-Simpl; Ring.
-Do 3 Rewrite tech5; Rewrite HrecN; Ring.
-Qed.
-
-Lemma sum_eq : (An,Bn:nat->R;N:nat) ((i:nat)(le i N)->(An i)==(Bn i)) -> (sum_f_R0 An N)==(sum_f_R0 Bn N).
-Intros; Induction N.
-Simpl; Apply H; Apply le_n.
-Do 2 Rewrite tech5; Rewrite HrecN.
-Rewrite (H (S N)); [Reflexivity | Apply le_n].
-Intros; Apply H; Apply le_trans with N; [Assumption | Apply le_n_Sn].
-Qed.
-
-(* Unicity of the limit defined by convergent series *)
-Lemma unicity_sum : (An:nat->R;l1,l2:R) (infinit_sum An l1) -> (infinit_sum An l2) -> l1 == l2.
-Unfold infinit_sum; Intros.
-Case (Req_EM l1 l2); Intro.
-Assumption.
-Cut ``0<(Rabsolu ((l1-l2)/2))``; [Intro | Apply Rabsolu_pos_lt].
-Elim (H ``(Rabsolu ((l1-l2)/2))`` H2); Intros.
-Elim (H0 ``(Rabsolu ((l1-l2)/2))`` H2); Intros.
-Pose N := (max x0 x); Cut (ge N x0).
-Cut (ge N x).
-Intros; Assert H7 := (H3 N H5); Assert H8 := (H4 N H6).
-Cut ``(Rabsolu (l1-l2)) <= (R_dist (sum_f_R0 An N) l1) + (R_dist (sum_f_R0 An N) l2)``.
-Intro; Assert H10 := (Rplus_lt ? ? ? ? H7 H8); Assert H11 := (Rle_lt_trans ? ? ? H9 H10); Unfold Rdiv in H11; Rewrite Rabsolu_mult in H11.
-Cut ``(Rabsolu (/2))==/2``.
-Intro; Rewrite H12 in H11; Assert H13 := double_var; Unfold Rdiv in H13; Rewrite <- H13 in H11.
-Elim (Rlt_antirefl ? H11).
-Apply Rabsolu_right; Left; Change ``0</2``; Apply Rlt_Rinv; Cut ~(O=(2)); [Intro H20; Generalize (lt_INR_0 (2) (neq_O_lt (2) H20)); Unfold INR; Intro; Assumption | Discriminate].
-Unfold R_dist; Rewrite <- (Rabsolu_Ropp ``(sum_f_R0 An N)-l1``); Rewrite Ropp_distr3.
-Replace ``l1-l2`` with ``((l1-(sum_f_R0 An N)))+((sum_f_R0 An N)-l2)``; [Idtac | Ring].
-Apply Rabsolu_triang.
-Unfold ge; Unfold N; Apply le_max_r.
-Unfold ge; Unfold N; Apply le_max_l.
-Unfold Rdiv; Apply prod_neq_R0.
-Apply Rminus_eq_contra; Assumption.
-Apply Rinv_neq_R0; DiscrR.
-Qed.
-
-Lemma minus_sum : (An,Bn:nat->R;N:nat) (sum_f_R0 [i:nat]``(An i)-(Bn i)`` N)==``(sum_f_R0 An N)-(sum_f_R0 Bn N)``. 
-Intros; Induction N. 
-Simpl; Ring. 
-Do 3 Rewrite tech5; Rewrite HrecN; Ring. 
-Qed. 
-
-Lemma sum_decomposition : (An:nat->R;N:nat) (Rplus (sum_f_R0 [l:nat](An (mult (2) l)) (S N)) (sum_f_R0 [l:nat](An (S (mult (2) l))) N))==(sum_f_R0 An (mult (2) (S N))).
-Intros.
-Induction N.
-Simpl; Ring.
-Rewrite tech5.
-Rewrite (tech5 [l:nat](An (S (mult (2) l))) N).
-Replace (mult (2) (S (S N))) with (S (S (mult (2) (S N)))).
-Rewrite (tech5 An (S (mult (2) (S N)))).
-Rewrite (tech5 An (mult (2) (S N))).
-Rewrite <- HrecN.
-Ring.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR;Repeat Rewrite S_INR.
-Ring.
-Qed.
-
-Lemma sum_Rle : (An,Bn:nat->R;N:nat) ((n:nat)(le n N)->``(An n)<=(Bn n)``) -> ``(sum_f_R0 An N)<=(sum_f_R0 Bn N)``.
-Intros.
-Induction N.
-Simpl; Apply H.
-Apply le_n.
-Do 2 Rewrite tech5.
-Apply Rle_trans with ``(sum_f_R0 An N)+(Bn (S N))``.
-Apply Rle_compatibility.
-Apply H.
-Apply le_n.
-Do 2 Rewrite <- (Rplus_sym ``(Bn (S N))``).
-Apply Rle_compatibility.
-Apply HrecN.
-Intros; Apply H.
-Apply le_trans with N; [Assumption | Apply le_n_Sn].
-Qed.
-
-Lemma sum_Rabsolu : (An:nat->R;N:nat) (Rle (Rabsolu (sum_f_R0 An N)) (sum_f_R0 [l:nat](Rabsolu (An l)) N)).
-Intros.
-Induction N.
-Simpl.
-Right; Reflexivity.
-Do 2 Rewrite tech5.
-Apply Rle_trans with ``(Rabsolu (sum_f_R0 An N))+(Rabsolu (An (S N)))``.
-Apply Rabsolu_triang.
-Do 2 Rewrite <- (Rplus_sym (Rabsolu (An (S N)))).
-Apply Rle_compatibility.
-Apply HrecN.
-Qed.
-
-Lemma sum_cte : (x:R;N:nat) (sum_f_R0 [_:nat]x N) == ``x*(INR (S N))``.
-Intros.
-Induction N.
-Simpl; Ring.
-Rewrite tech5.
-Rewrite HrecN; Repeat Rewrite S_INR; Ring.
-Qed.
-
-(**********)
-Lemma sum_growing : (An,Bn:nat->R;N:nat) ((n:nat)``(An n)<=(Bn n)``)->``(sum_f_R0 An N)<=(sum_f_R0 Bn N)``.
-Intros.
-Induction N.
-Simpl; Apply H.
-Do 2 Rewrite tech5.
-Apply Rle_trans with ``(sum_f_R0 An N)+(Bn (S N))``.
-Apply Rle_compatibility; Apply H.
-Do 2 Rewrite <- (Rplus_sym (Bn (S N))).
-Apply Rle_compatibility; Apply HrecN.
-Qed.
-
-(**********)
-Lemma Rabsolu_triang_gen : (An:nat->R;N:nat) (Rle (Rabsolu (sum_f_R0 An N)) (sum_f_R0 [i:nat](Rabsolu (An i)) N)). 
-Intros.
-Induction N.
-Simpl.
-Right; Reflexivity.
-Do 2 Rewrite tech5.
-Apply Rle_trans with ``(Rabsolu ((sum_f_R0 An N)))+(Rabsolu (An (S N)))``.
-Apply Rabsolu_triang.
-Do 2 Rewrite <- (Rplus_sym (Rabsolu (An (S N)))).
-Apply Rle_compatibility; Apply HrecN.
-Qed.
-
-(**********)
-Lemma cond_pos_sum : (An:nat->R;N:nat) ((n:nat)``0<=(An n)``) -> ``0<=(sum_f_R0 An N)``.
-Intros.
-Induction N.
-Simpl; Apply H.
-Rewrite tech5.
-Apply ge0_plus_ge0_is_ge0.
-Apply HrecN.
-Apply H.
-Qed.
-
-(* Cauchy's criterion for series *)
-Definition Cauchy_crit_series [An:nat->R] : Prop := (Cauchy_crit [N:nat](sum_f_R0 An N)).
-
-(* If (|An|) satisfies the Cauchy's criterion for series, then (An) too *)
-Lemma cauchy_abs : (An:nat->R) (Cauchy_crit_series [i:nat](Rabsolu (An i))) -> (Cauchy_crit_series An).
-Unfold Cauchy_crit_series; Unfold Cauchy_crit.
-Intros.
-Elim (H eps H0); Intros.
-Exists x.
-Intros.
-Cut (Rle (R_dist (sum_f_R0 An n) (sum_f_R0 An m)) (R_dist (sum_f_R0 [i:nat](Rabsolu (An i)) n) (sum_f_R0 [i:nat](Rabsolu (An i)) m))).
-Intro.
-Apply Rle_lt_trans with (R_dist (sum_f_R0 [i:nat](Rabsolu (An i)) n) (sum_f_R0 [i:nat](Rabsolu (An i)) m)).
-Assumption.
-Apply H1; Assumption.
-Assert H4 := (lt_eq_lt_dec n m).
-Elim H4; Intro.
-Elim a; Intro.
-Rewrite (tech2 An n m); [Idtac | Assumption].
-Rewrite (tech2 [i:nat](Rabsolu (An i)) n m); [Idtac | Assumption].
-Unfold R_dist.
-Unfold Rminus.
-Do 2 Rewrite Ropp_distr1.
-Do 2 Rewrite <- Rplus_assoc.
-Do 2 Rewrite Rplus_Ropp_r.
-Do 2 Rewrite Rplus_Ol.
-Do 2 Rewrite Rabsolu_Ropp.
-Rewrite (Rabsolu_right (sum_f_R0 [i:nat](Rabsolu (An (plus (S n) i))) (minus m (S n)))).
-Pose Bn:=[i:nat](An (plus (S n) i)).
-Replace [i:nat](Rabsolu (An (plus (S n) i))) with [i:nat](Rabsolu (Bn i)).
-Apply Rabsolu_triang_gen.
-Unfold Bn; Reflexivity.
-Apply Rle_sym1.
-Apply cond_pos_sum.
-Intro; Apply Rabsolu_pos.
-Rewrite b.
-Unfold R_dist.
-Unfold Rminus; Do 2 Rewrite Rplus_Ropp_r.
-Rewrite Rabsolu_R0; Right; Reflexivity.
-Rewrite (tech2 An m n); [Idtac | Assumption].
-Rewrite (tech2 [i:nat](Rabsolu (An i)) m n); [Idtac | Assumption].
-Unfold R_dist.
-Unfold Rminus.
-Do 2 Rewrite Rplus_assoc.
-Rewrite (Rplus_sym (sum_f_R0 An m)).
-Rewrite (Rplus_sym (sum_f_R0 [i:nat](Rabsolu (An i)) m)).
-Do 2 Rewrite Rplus_assoc.
-Do 2 Rewrite Rplus_Ropp_l.
-Do 2 Rewrite Rplus_Or.
-Rewrite (Rabsolu_right (sum_f_R0 [i:nat](Rabsolu (An (plus (S m) i))) (minus n (S m)))).
-Pose Bn:=[i:nat](An (plus (S m) i)).
-Replace [i:nat](Rabsolu (An (plus (S m) i))) with [i:nat](Rabsolu (Bn i)).
-Apply Rabsolu_triang_gen.
-Unfold Bn; Reflexivity.
-Apply Rle_sym1.
-Apply cond_pos_sum.
-Intro; Apply Rabsolu_pos.
-Qed.
-
-(**********)
-Lemma cv_cauchy_1 : (An:nat->R) (sigTT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)) -> (Cauchy_crit_series An).
-Intros.
-Elim X; Intros.
-Unfold Un_cv in p.
-Unfold Cauchy_crit_series; Unfold Cauchy_crit.
-Intros.
-Cut ``0<eps/2``.
-Intro.
-Elim (p ``eps/2`` H0); Intros.
-Exists x0.
-Intros.
-Apply Rle_lt_trans with ``(R_dist (sum_f_R0 An n) x)+(R_dist (sum_f_R0 An m) x)``.
-Unfold R_dist.
-Replace ``(sum_f_R0 An n)-(sum_f_R0 An m)`` with ``((sum_f_R0 An n)-x)+ -((sum_f_R0 An m)-x)``; [Idtac | Ring].
-Rewrite <- (Rabsolu_Ropp ``(sum_f_R0 An m)-x``).
-Apply Rabsolu_triang.
-Apply Rlt_le_trans with ``eps/2+eps/2``.
-Apply Rplus_lt.
-Apply H1; Assumption.
-Apply H1; Assumption.
-Right; Symmetry; Apply double_var.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Qed.
-
-Lemma cv_cauchy_2 : (An:nat->R) (Cauchy_crit_series An) -> (sigTT R [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intros.
-Apply R_complete.
-Unfold Cauchy_crit_series in H.
-Exact H.
-Qed.
-
-(**********)
-Lemma sum_eq_R0 : (An:nat->R;N:nat) ((n:nat)(le n N)->``(An n)==0``) -> (sum_f_R0 An N)==R0.
-Intros; Induction N.
-Simpl; Apply H; Apply le_n.
-Rewrite tech5; Rewrite HrecN; [Rewrite Rplus_Ol; Apply H; Apply le_n | Intros; Apply H; Apply le_trans with N; [Assumption | Apply le_n_Sn]].
-Qed.
-
-Definition SP [fn:nat->R->R;N:nat] : R->R := [x:R](sum_f_R0 [k:nat]``(fn k x)`` N).
-
-(**********)
-Lemma sum_incr : (An:nat->R;N:nat;l:R) (Un_cv [n:nat](sum_f_R0 An n) l) -> ((n:nat)``0<=(An n)``) -> ``(sum_f_R0 An N)<=l``.
-Intros; Case (total_order_T (sum_f_R0 An N) l); Intro.
-Elim s; Intro.
-Left; Apply a.
-Right; Apply b.
-Cut (Un_growing [n:nat](sum_f_R0 An n)).
-Intro; LetTac l1 := (sum_f_R0 An N) in r.
-Unfold Un_cv in H; Cut ``0<l1-l``.
-Intro; Elim (H ? H2); Intros.
-Pose N0 := (max x N); Cut (ge N0 x).
-Intro; Assert H5 := (H3 N0 H4).
-Cut ``l1<=(sum_f_R0 An N0)``.
-Intro; Unfold R_dist in H5; Rewrite Rabsolu_right in H5.
-Cut ``(sum_f_R0 An N0)<l1``.
-Intro; Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H7 H6)).
-Apply Rlt_anti_compatibility with ``-l``.
-Do 2 Rewrite (Rplus_sym ``-l``).
-Apply H5.
-Apply Rle_sym1; Apply Rle_anti_compatibility with l.
-Rewrite Rplus_Or; Replace ``l+((sum_f_R0 An N0)-l)`` with (sum_f_R0 An N0); [Idtac | Ring]; Apply Rle_trans with l1.
-Left; Apply r.
-Apply H6.
-Unfold l1; Apply Rle_sym2; Apply (growing_prop [k:nat](sum_f_R0 An k)).
-Apply H1.
-Unfold ge N0; Apply le_max_r.
-Unfold ge N0; Apply le_max_l.
-Apply Rlt_anti_compatibility with l; Rewrite Rplus_Or; Replace ``l+(l1-l)`` with l1; [Apply r | Ring].
-Unfold Un_growing; Intro; Simpl; Pattern 1 (sum_f_R0 An n); Rewrite <- Rplus_Or; Apply Rle_compatibility; Apply H0.
-Qed.
-
-(**********)
-Lemma sum_cv_maj : (An:nat->R;fn:nat->R->R;x,l1,l2:R) (Un_cv [n:nat](SP fn n x) l1) -> (Un_cv [n:nat](sum_f_R0 An n) l2) -> ((n:nat)``(Rabsolu (fn n x))<=(An n)``) -> ``(Rabsolu l1)<=l2``.
-Intros; Case (total_order_T (Rabsolu l1) l2); Intro.
-Elim s; Intro.
-Left; Apply a.
-Right; Apply b.
-Cut (n0:nat)``(Rabsolu (SP fn n0 x))<=(sum_f_R0 An n0)``.
-Intro; Cut ``0<((Rabsolu l1)-l2)/2``.
-Intro; Unfold Un_cv in H H0.
-Elim (H ? H3); Intros Na H4.
-Elim (H0 ? H3); Intros Nb H5.
-Pose N := (max Na Nb).
-Unfold R_dist in H4 H5.
-Cut ``(Rabsolu ((sum_f_R0 An N)-l2))<((Rabsolu l1)-l2)/2``.
-Intro; Cut ``(Rabsolu ((Rabsolu l1)-(Rabsolu (SP fn N x))))<((Rabsolu l1)-l2)/2``.
-Intro; Cut ``(sum_f_R0 An N)<((Rabsolu l1)+l2)/2``.
-Intro; Cut ``((Rabsolu l1)+l2)/2<(Rabsolu (SP fn N x))``.
-Intro; Cut ``(sum_f_R0 An N)<(Rabsolu (SP fn N x))``.
-Intro; Assert H11 := (H2 N).
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H11 H10)).
-Apply Rlt_trans with ``((Rabsolu l1)+l2)/2``; Assumption.
-Case (case_Rabsolu ``(Rabsolu l1)-(Rabsolu (SP fn N x))``); Intro.
-Apply Rlt_trans with (Rabsolu l1).
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Unfold Rdiv; Rewrite (Rmult_sym ``2``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite double; Apply Rlt_compatibility; Apply r.
-DiscrR.
-Apply (Rminus_lt ? ? r0).
-Rewrite (Rabsolu_right ? r0) in H7.
-Apply Rlt_anti_compatibility with ``((Rabsolu l1)-l2)/2-(Rabsolu (SP fn N x))``.
-Replace ``((Rabsolu l1)-l2)/2-(Rabsolu (SP fn N x))+((Rabsolu l1)+l2)/2`` with ``(Rabsolu l1)-(Rabsolu (SP fn N x))``.
-Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Apply H7.
-Unfold Rdiv; Rewrite Rmult_Rplus_distrl; Rewrite <- (Rmult_sym ``/2``); Rewrite Rminus_distr; Repeat Rewrite (Rmult_sym ``/2``); Pattern 1 (Rabsolu l1); Rewrite double_var; Unfold Rdiv; Ring.
-Case (case_Rabsolu ``(sum_f_R0 An N)-l2``); Intro.
-Apply Rlt_trans with l2.
-Apply (Rminus_lt ? ? r0).
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Rewrite (double l2); Unfold Rdiv; Rewrite (Rmult_sym ``2``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite (Rplus_sym (Rabsolu l1)); Apply Rlt_compatibility; Apply r.
-DiscrR.
-Rewrite (Rabsolu_right ? r0) in H6; Apply Rlt_anti_compatibility with ``-l2``.
-Replace ``-l2+((Rabsolu l1)+l2)/2`` with ``((Rabsolu l1)-l2)/2``.
-Rewrite Rplus_sym; Apply H6.
-Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite Rminus_distr; Rewrite Rmult_Rplus_distrl; Pattern 2 l2; Rewrite double_var; Repeat Rewrite (Rmult_sym ``/2``); Rewrite Ropp_distr1; Unfold Rdiv; Ring.
-Apply Rle_lt_trans with ``(Rabsolu ((SP fn N x)-l1))``.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr3; Apply Rabsolu_triang_inv2.
-Apply H4; Unfold ge N; Apply le_max_l.
-Apply H5; Unfold ge N; Apply le_max_r.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply Rlt_anti_compatibility with l2.
-Rewrite Rplus_Or; Replace ``l2+((Rabsolu l1)-l2)`` with (Rabsolu l1); [Apply r | Ring].
-Apply Rlt_Rinv; Sup0.
-Intros; Induction n0.
-Unfold SP; Simpl; Apply H1.
-Unfold SP; Simpl.
-Apply Rle_trans with (Rplus (Rabsolu (sum_f_R0 [k:nat](fn k x) n0)) (Rabsolu (fn (S n0) x))).
-Apply Rabsolu_triang.
-Apply Rle_trans with ``(sum_f_R0 An n0)+(Rabsolu (fn (S n0) x))``.
-Do 2 Rewrite <- (Rplus_sym (Rabsolu (fn (S n0) x))).
-Apply Rle_compatibility; Apply Hrecn0.
-Apply Rle_compatibility; Apply H1.
-Qed.
diff --git a/theories7/Reals/RIneq.v b/theories7/Reals/RIneq.v
deleted file mode 100644
index 00d41c70..00000000
--- a/theories7/Reals/RIneq.v
+++ /dev/null
@@ -1,1631 +0,0 @@
-(************************************************************************)
-(*  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: RIneq.v,v 1.2.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-(***************************************************************************)
-(**              Basic lemmas for the classical reals numbers              *)
-(***************************************************************************)
-
-Require Export Raxioms.
-Require Export ZArithRing.
-Require Omega.
-Require Export Field.
-
-Open Local Scope Z_scope.
-Open Local Scope R_scope.
-
-Implicit Variable Type r:R.
-
-(***************************************************************************)
-(**       Instantiating Ring tactic on reals                               *)
-(***************************************************************************)
-
-Lemma RTheory : (Ring_Theory Rplus Rmult R1 R0 Ropp [x,y:R]false).
-  Split.
-  Exact Rplus_sym.
-  Symmetry; Apply Rplus_assoc.
-  Exact Rmult_sym.
-  Symmetry; Apply Rmult_assoc.
-  Intro; Apply Rplus_Ol.
-  Intro; Apply Rmult_1l.
-  Exact Rplus_Ropp_r.
-  Intros.
-  Rewrite Rmult_sym.
-  Rewrite (Rmult_sym n p).
-  Rewrite (Rmult_sym m p).
-  Apply Rmult_Rplus_distr.
-  Intros; Contradiction.
-Defined.
-
-Add Field R Rplus Rmult R1 R0 Ropp [x,y:R]false Rinv RTheory Rinv_l
-          with minus:=Rminus div:=Rdiv.
-
-(**************************************************************************)
-(**  Relation between orders and equality                                 *)
-(**************************************************************************)
-
-(**********)
-Lemma Rlt_antirefl:(r:R)~``r<r``.
-  Generalize Rlt_antisym. Intuition EAuto.
-Qed.
-Hints Resolve Rlt_antirefl : real.
-
-Lemma Rle_refl : (x:R) ``x<=x``.
-Intro; Right; Reflexivity.
-Qed.
-
-Lemma Rlt_not_eq:(r1,r2:R)``r1<r2``->``r1<>r2``.
-  Red; Intros r1 r2 H H0; Apply (Rlt_antirefl r1).
-  Pattern 2 r1; Rewrite H0; Trivial.
-Qed.
-
-Lemma Rgt_not_eq:(r1,r2:R)``r1>r2``->``r1<>r2``.
-Intros; Apply sym_not_eqT; Apply Rlt_not_eq; Auto with real.
-Qed.
-
-(**********)
-Lemma imp_not_Req:(r1,r2:R)(``r1<r2``\/ ``r1>r2``) -> ``r1<>r2``.
-Generalize Rlt_not_eq Rgt_not_eq. Intuition EAuto.
-Qed.
-Hints Resolve imp_not_Req : real.
-
-(** Reasoning by case on equalities and order *)
-
-(**********)
-Lemma Req_EM:(r1,r2:R)(r1==r2)\/``r1<>r2``.
-Intros ; Generalize (total_order_T r1 r2) imp_not_Req ; Intuition EAuto 3. 
-Qed.
-Hints Resolve Req_EM : real.
-
-(**********)
-Lemma total_order:(r1,r2:R)``r1<r2``\/(r1==r2)\/``r1>r2``.
-Intros;Generalize (total_order_T r1 r2);Tauto.
-Qed.
-
-(**********)
-Lemma not_Req:(r1,r2:R)``r1<>r2``->(``r1<r2``\/``r1>r2``).
-Intros; Generalize (total_order_T r1 r2) ; Tauto.
-Qed.
-
-
-(*********************************************************************************)
-(**       Order Lemma  : relating [<], [>], [<=] and [>=]  	                 *)
-(*********************************************************************************)
-
-(**********)
-Lemma Rlt_le:(r1,r2:R)``r1<r2``-> ``r1<=r2``.
-Intros ; Red ; Tauto.
-Qed.
-Hints Resolve Rlt_le : real.
-
-(**********)
-Lemma Rle_ge : (r1,r2:R)``r1<=r2`` -> ``r2>=r1``.
-NewDestruct 1; Red; Auto with real.
-Qed.
-
-Hints Immediate Rle_ge : real.
-
-(**********)
-Lemma Rge_le : (r1,r2:R)``r1>=r2`` -> ``r2<=r1``.
-NewDestruct 1; Red; Auto with real.
-Qed.
-
-Hints Resolve Rge_le : real.
-
-(**********)
-Lemma not_Rle:(r1,r2:R)~``r1<=r2`` -> ``r2<r1``.
-Intros r1 r2 ; Generalize (total_order r1 r2) ; Unfold Rle; Tauto.
-Qed.
-
-Hints Immediate not_Rle : real.
-
-Lemma not_Rge:(r1,r2:R)~``r1>=r2`` -> ``r1<r2``.
-Intros; Apply not_Rle; Auto with real.
-Qed.
-
-(**********)
-Lemma Rlt_le_not:(r1,r2:R)``r2<r1`` -> ~``r1<=r2``.
-Generalize Rlt_antisym imp_not_Req ; Unfold Rle.
-Intuition EAuto 3.
-Qed.
-
-Lemma Rle_not:(r1,r2:R)``r1>r2`` -> ~``r1<=r2``.
-Proof Rlt_le_not.
-
-Hints Immediate Rlt_le_not : real.
-
-Lemma Rle_not_lt: (r1, r2:R) ``r2 <= r1`` -> ~``r1<r2``.
-Intros r1 r2. Generalize (Rlt_antisym r1 r2) (imp_not_Req r1 r2).
-Unfold Rle; Intuition.
-Qed.
-
-(**********)
-Lemma Rlt_ge_not:(r1,r2:R)``r1<r2`` -> ~``r1>=r2``.
-Generalize Rlt_le_not. Unfold Rle Rge. Intuition EAuto 3.
-Qed.
-
-Hints Immediate Rlt_ge_not : real.
-
-(**********)
-Lemma eq_Rle:(r1,r2:R)r1==r2->``r1<=r2``.
-Unfold Rle; Tauto.
-Qed.
-Hints Immediate eq_Rle : real.
-
-Lemma eq_Rge:(r1,r2:R)r1==r2->``r1>=r2``.
-Unfold Rge; Tauto.
-Qed.
-Hints Immediate eq_Rge : real.
-
-Lemma eq_Rle_sym:(r1,r2:R)r2==r1->``r1<=r2``.
-Unfold Rle; Auto.
-Qed.
-Hints Immediate eq_Rle_sym : real.
-
-Lemma eq_Rge_sym:(r1,r2:R)r2==r1->``r1>=r2``.
-Unfold Rge; Auto.
-Qed.
-Hints Immediate eq_Rge_sym : real.
-
-Lemma Rle_antisym : (r1,r2:R)``r1<=r2`` -> ``r2<=r1``-> r1==r2.
-Intros r1 r2; Generalize (Rlt_antisym r1 r2) ; Unfold Rle ; Intuition.
-Qed.
-Hints Resolve Rle_antisym : real.
-
-(**********)
-Lemma Rle_le_eq:(r1,r2:R)(``r1<=r2``/\``r2<=r1``)<->(r1==r2).
-Intuition.
-Qed.
-
-Lemma Rlt_rew : (x,x',y,y':R)``x==x'``->``x'<y'`` -> `` y' == y`` -> ``x < y``.
-Intros x x' y y'; Intros; Replace x with x'; Replace y with y'; Assumption.
-Qed.
-
-(**********)
-Lemma Rle_trans:(r1,r2,r3:R) ``r1<=r2``->``r2<=r3``->``r1<=r3``.
-Generalize trans_eqT Rlt_trans Rlt_rew.
-Unfold Rle.
-Intuition EAuto 2.
-Qed.
-
-(**********)
-Lemma Rle_lt_trans:(r1,r2,r3:R)``r1<=r2``->``r2<r3``->``r1<r3``.
-Generalize Rlt_trans Rlt_rew. 
-Unfold Rle.
-Intuition EAuto 2.
-Qed.
-
-(**********)
-Lemma Rlt_le_trans:(r1,r2,r3:R)``r1<r2``->``r2<=r3``->``r1<r3``.
-Generalize Rlt_trans Rlt_rew; Unfold Rle; Intuition EAuto 2.
-Qed.
-
-
-(** Decidability of the order *)
-Lemma total_order_Rlt:(r1,r2:R)(sumboolT ``r1<r2`` ~(``r1<r2``)).
-Intros;Generalize (total_order_T r1 r2) (imp_not_Req r1 r2) ; Intuition.
-Qed.
-
-(**********)
-Lemma total_order_Rle:(r1,r2:R)(sumboolT ``r1<=r2`` ~(``r1<=r2``)).
-Intros r1 r2.
-Generalize (total_order_T r1 r2) (imp_not_Req r1 r2).
-Intuition EAuto 4 with real.
-Qed.
-
-(**********)
-Lemma total_order_Rgt:(r1,r2:R)(sumboolT ``r1>r2`` ~(``r1>r2``)).
-Intros;Unfold Rgt;Intros;Apply total_order_Rlt.
-Qed.
-
-(**********)
-Lemma total_order_Rge:(r1,r2:R)(sumboolT (``r1>=r2``) ~(``r1>=r2``)).
-Intros;Generalize (total_order_Rle r2 r1);Intuition.
-Qed.
-
-Lemma total_order_Rlt_Rle:(r1,r2:R)(sumboolT ``r1<r2`` ``r2<=r1``).
-Intros;Generalize (total_order_T r1 r2); Intuition.
-Qed.
-
-Lemma Rle_or_lt: (n, m:R)(Rle n m) \/ (Rlt m n).
-Intros n m; Elim (total_order_Rlt_Rle m n);Auto with real.
-Qed.
-
-Lemma total_order_Rle_Rlt_eq :(r1,r2:R)``r1<=r2``-> 
-                              (sumboolT ``r1<r2`` ``r1==r2``).
-Intros r1 r2 H;Generalize (total_order_T r1 r2); Intuition.
-Qed.
-
-(**********)
-Lemma inser_trans_R:(n,m,p,q:R)``n<=m<p``-> (sumboolT ``n<=m<q`` ``q<=m<p``).
-Intros n m p q; Intros; Generalize (total_order_Rlt_Rle m q); Intuition.
-Qed.
-
-(****************************************************************)
-(**        Field Lemmas                                         *)
-(* This part contains lemma involving the Fields operations     *)
-(****************************************************************)
-(*********************************************************)
-(**      Addition                                        *)
-(*********************************************************)
-
-Lemma Rplus_ne:(r:R)``r+0==r``/\``0+r==r``.
-Intro;Split;Ring.
-Qed.
-Hints Resolve Rplus_ne : real v62.
-
-Lemma Rplus_Or:(r:R)``r+0==r``.
-Intro; Ring.
-Qed.
-Hints Resolve Rplus_Or : real.
-
-(**********)
-Lemma Rplus_Ropp_l:(r:R)``(-r)+r==0``.
-  Intro; Ring.
-Qed.
-Hints Resolve Rplus_Ropp_l : real.
-
-
-(**********)
-Lemma Rplus_Ropp:(x,y:R)``x+y==0``->``y== -x``.
-  Intros x y H; Replace y with ``(-x+x)+y``;
-  [ Rewrite -> Rplus_assoc; Rewrite -> H; Ring
-  | Ring ].
-Qed.
-
-(*i New i*)
-Hint eqT_R_congr : real := Resolve (congr_eqT R).
-
-Lemma Rplus_plus_r:(r,r1,r2:R)(r1==r2)->``r+r1==r+r2``.
-  Auto with real.
-Qed.
-
-(*i Old i*)Hints Resolve Rplus_plus_r : v62.
-
-(**********)
-Lemma r_Rplus_plus:(r,r1,r2:R)``r+r1==r+r2``->r1==r2.
-  Intros; Transitivity ``(-r+r)+r1``.
-  Ring.
-  Transitivity ``(-r+r)+r2``.
-  Repeat Rewrite -> Rplus_assoc; Rewrite <- H; Reflexivity.
-  Ring.
-Qed.
-Hints Resolve r_Rplus_plus : real.
-
-(**********)
-Lemma Rplus_ne_i:(r,b:R)``r+b==r`` -> ``b==0``.
-  Intros r b; Pattern 2 r; Replace r with ``r+0``;
-  EAuto with real.
-Qed.
-
-(***********************************************************)       
-(**       Multiplication                                   *)
-(***********************************************************)
-
-(**********)
-Lemma Rinv_r:(r:R)``r<>0``->``r* (/r)==1``.
-  Intros; Rewrite -> Rmult_sym; Auto with real.
-Qed.
-Hints Resolve Rinv_r : real.
-
-Lemma Rinv_l_sym:(r:R)``r<>0``->``1==(/r) * r``.
-  Symmetry; Auto with real.
-Qed.
-
-Lemma Rinv_r_sym:(r:R)``r<>0``->``1==r* (/r)``.
-  Symmetry; Auto with real.
-Qed.
-Hints Resolve Rinv_l_sym Rinv_r_sym : real.
-
-
-(**********)
-Lemma Rmult_Or :(r:R) ``r*0==0``.
-Intro; Ring.
-Qed.
-Hints Resolve Rmult_Or : real v62.
-
-(**********)
-Lemma Rmult_Ol:(r:R) ``0*r==0``.
-Intro; Ring.
-Qed.
-Hints Resolve Rmult_Ol : real v62.
-
-(**********)
-Lemma Rmult_ne:(r:R)``r*1==r``/\``1*r==r``.
-Intro;Split;Ring.
-Qed.
-Hints Resolve Rmult_ne : real v62.
-
-(**********)
-Lemma Rmult_1r:(r:R)(``r*1==r``).
-Intro; Ring.
-Qed.
-Hints Resolve Rmult_1r : real.
-
-(**********)
-Lemma Rmult_mult_r:(r,r1,r2:R)r1==r2->``r*r1==r*r2``.
-  Auto with real.
-Qed.
-
-(*i OLD i*)Hints Resolve Rmult_mult_r : v62.
-
-(**********)
-Lemma r_Rmult_mult:(r,r1,r2:R)(``r*r1==r*r2``)->``r<>0``->(r1==r2).
-  Intros; Transitivity ``(/r * r)*r1``.
-  Rewrite Rinv_l; Auto with real.
-  Transitivity ``(/r * r)*r2``.
-  Repeat Rewrite Rmult_assoc; Rewrite H; Trivial.
-  Rewrite Rinv_l; Auto with real.
-Qed.
-
-(**********)
-Lemma without_div_Od:(r1,r2:R)``r1*r2==0`` -> ``r1==0`` \/ ``r2==0``.
-  Intros; Case (Req_EM r1 ``0``); [Intro Hz | Intro Hnotz].
-  Auto.
-  Right; Apply r_Rmult_mult with r1; Trivial.
-  Rewrite H; Auto with real.
-Qed.
-
-(**********)
-Lemma without_div_Oi:(r1,r2:R) ``r1==0``\/``r2==0`` -> ``r1*r2==0``.
-  Intros r1 r2 [H | H]; Rewrite H; Auto with real.
-Qed.
-
-Hints Resolve without_div_Oi : real.
-
-(**********)
-Lemma without_div_Oi1:(r1,r2:R) ``r1==0`` -> ``r1*r2==0``.
-  Auto with real.
-Qed.
-
-(**********)
-Lemma without_div_Oi2:(r1,r2:R) ``r2==0`` -> ``r1*r2==0``.
-  Auto with real.
-Qed.
-
-
-(**********) 
-Lemma without_div_O_contr:(r1,r2:R)``r1*r2<>0`` -> ``r1<>0`` /\ ``r2<>0``.
-Intros r1 r2 H; Split; Red; Intro; Apply H; Auto with real.
-Qed.
-
-(**********) 
-Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``.
-Red; Intros r1 r2 (H1,H2) H.
-Case (without_div_Od r1 r2); Auto with real.
-Qed.
-Hints Resolve mult_non_zero : real.
-
-(**********) 
-Lemma Rmult_Rplus_distrl:
-   (r1,r2,r3:R) ``(r1+r2)*r3 == (r1*r3)+(r2*r3)``.
-Intros; Ring.
-Qed.
-
-(** Square function *)
-
-(***********)
-Definition Rsqr:R->R:=[r:R]``r*r``.
-V7only[Notation "x ²" := (Rsqr x) (at level 2,left associativity).].
-
-(***********)
-Lemma Rsqr_O:(Rsqr ``0``)==``0``.
-  Unfold Rsqr; Auto with real.
-Qed.
-
-(***********)
-Lemma Rsqr_r_R0:(r:R)(Rsqr r)==``0``->``r==0``.
-Unfold Rsqr;Intros;Elim (without_div_Od r r H);Trivial.
-Qed.
-
-(*********************************************************)
-(**      Opposite                                        *)
-(*********************************************************)
-
-(**********)
-Lemma eq_Ropp:(r1,r2:R)(r1==r2)->``-r1 == -r2``.
-  Auto with real.
-Qed.
-Hints Resolve eq_Ropp : real.
-
-(**********)
-Lemma Ropp_O:``-0==0``.
-  Ring.
-Qed.
-Hints Resolve Ropp_O : real v62.
-
-(**********)
-Lemma eq_RoppO:(r:R)``r==0``-> ``-r==0``.
-  Intros; Rewrite -> H; Auto with real.
-Qed.
-Hints Resolve eq_RoppO : real.
-
-(**********)
-Lemma Ropp_Ropp:(r:R)``-(-r)==r``.
-  Intro; Ring.
-Qed.
-Hints Resolve Ropp_Ropp : real.
-
-(*********)
-Lemma Ropp_neq:(r:R)``r<>0``->``-r<>0``.
-Red;Intros r H H0.
-Apply H.
-Transitivity ``-(-r)``; Auto with real.
-Qed.
-Hints Resolve Ropp_neq : real.
-
-(**********)
-Lemma Ropp_distr1:(r1,r2:R)``-(r1+r2)==(-r1 + -r2)``.
-  Intros; Ring.
-Qed.
-Hints Resolve Ropp_distr1 : real.
-
-(** Opposite and multiplication *)
-
-Lemma Ropp_mul1:(r1,r2:R)``(-r1)*r2 == -(r1*r2)``.
-  Intros; Ring.
-Qed.
-Hints Resolve Ropp_mul1 : real.
-
-(**********)
-Lemma Ropp_mul2:(r1,r2:R)``(-r1)*(-r2)==r1*r2``.
-  Intros; Ring.
-Qed.
-Hints Resolve Ropp_mul2 : real.
-
-Lemma Ropp_mul3 : (r1,r2:R) ``r1*(-r2) == -(r1*r2)``.
-Intros; Rewrite <- Ropp_mul1; Ring.
-Qed.
-
-(** Substraction *)
-
-Lemma minus_R0:(r:R)``r-0==r``.
-Intro;Ring.
-Qed.
-Hints Resolve minus_R0 : real.
-
-Lemma Rminus_Ropp:(r:R)``0-r==-r``.
-Intro;Ring.
-Qed.
-Hints Resolve Rminus_Ropp : real.
-
-(**********)
-Lemma Ropp_distr2:(r1,r2:R)``-(r1-r2)==r2-r1``.
-  Intros; Ring.
-Qed.
-Hints Resolve Ropp_distr2 : real.
-
-Lemma Ropp_distr3:(r1,r2:R)``-(r2-r1)==r1-r2``.
-Intros; Ring.
-Qed.
-Hints Resolve Ropp_distr3 : real. 
-
-(**********)
-Lemma eq_Rminus:(r1,r2:R)(r1==r2)->``r1-r2==0``.
-  Intros; Rewrite H; Ring.
-Qed.
-Hints Resolve eq_Rminus : real.
-
-(**********)
-Lemma Rminus_eq:(r1,r2:R)``r1-r2==0`` -> r1==r2.
-  Intros r1 r2; Unfold Rminus; Rewrite -> Rplus_sym; Intro.
-  Rewrite <- (Ropp_Ropp r2); Apply (Rplus_Ropp (Ropp r2) r1 H).
-Qed.
-Hints Immediate Rminus_eq : real.
-
-Lemma Rminus_eq_right:(r1,r2:R)``r2-r1==0`` -> r1==r2.
-Intros;Generalize (Rminus_eq r2 r1 H);Clear H;Intro H;Rewrite H;Ring.
-Qed.
-Hints Immediate Rminus_eq_right : real.
-
-Lemma Rplus_Rminus: (p,q:R)``p+(q-p)``==q.
-Intros; Ring.
-Qed.
-Hints Resolve Rplus_Rminus:real.
-
-(**********)
-Lemma Rminus_eq_contra:(r1,r2:R)``r1<>r2``->``r1-r2<>0``.
-Red; Intros r1 r2 H H0.
-Apply H; Auto with real.
-Qed.
-Hints Resolve Rminus_eq_contra : real.
-
-Lemma Rminus_not_eq:(r1,r2:R)``r1-r2<>0``->``r1<>r2``.
-Red; Intros; Elim H; Apply eq_Rminus; Auto.
-Qed.
-Hints Resolve Rminus_not_eq : real.
-
-Lemma Rminus_not_eq_right:(r1,r2:R)``r2-r1<>0`` -> ``r1<>r2``.
-Red; Intros;Elim H;Rewrite H0; Ring.
-Qed.
-Hints Resolve Rminus_not_eq_right : real. 
-
-V7only [Notation not_sym := (sym_not_eq R).].
-
-(**********)
-Lemma Rminus_distr:  (x,y,z:R) ``x*(y-z)==(x*y) - (x*z)``.
-Intros; Ring.
-Qed.
-
-(** Inverse *)
-Lemma Rinv_R1:``/1==1``.
-Field;Auto with real.
-Qed.
-Hints Resolve Rinv_R1 : real.
-
-(*********)
-Lemma Rinv_neq_R0:(r:R)``r<>0``->``(/r)<>0``.
-Red; Intros; Apply R1_neq_R0.
-Replace ``1`` with ``(/r) * r``; Auto with real.
-Qed.
-Hints Resolve Rinv_neq_R0 : real.
-
-(*********)
-Lemma Rinv_Rinv:(r:R)``r<>0``->``/(/r)==r``.
-Intros;Field;Auto with real.
-Qed.
-Hints Resolve Rinv_Rinv : real.
-
-(*********)
-Lemma Rinv_Rmult:(r1,r2:R)``r1<>0``->``r2<>0``->``/(r1*r2)==(/r1)*(/r2)``.
-Intros;Field;Auto with real.
-Qed.
-
-(*********)
-Lemma Ropp_Rinv:(r:R)``r<>0``->``-(/r)==/(-r)``.
-Intros;Field;Auto with real.
-Qed.
-
-Lemma Rinv_r_simpl_r : (r1,r2:R)``r1<>0``->``r1*(/r1)*r2==r2``.
-Intros; Transitivity ``1*r2``; Auto with real.
-Rewrite Rinv_r; Auto with real.
-Qed.
-
-Lemma Rinv_r_simpl_l : (r1,r2:R)``r1<>0``->``r2*r1*(/r1)==r2``.
-Intros; Transitivity ``r2*1``; Auto with real.
-Transitivity ``r2*(r1*/r1)``; Auto with real.
-Qed.
-
-Lemma Rinv_r_simpl_m : (r1,r2:R)``r1<>0``->``r1*r2*(/r1)==r2``.
-Intros; Transitivity ``r2*1``; Auto with real.
-Transitivity ``r2*(r1*/r1)``; Auto with real.
-Ring.
-Qed.
-Hints Resolve Rinv_r_simpl_l Rinv_r_simpl_r Rinv_r_simpl_m : real.
-
-(*********)
-Lemma Rinv_Rmult_simpl:(a,b,c:R)``a<>0``->``(a*(/b))*(c*(/a))==c*(/b)``.
-Intros a b c; Intros.
-Transitivity ``(a*/a)*(c*(/b))``; Auto with real.
-Ring.
-Qed.
-
-(** Order and addition *)
-
-Lemma Rlt_compatibility_r:(r,r1,r2:R)``r1<r2``->``r1+r<r2+r``.
-Intros.
-Rewrite (Rplus_sym r1 r); Rewrite (Rplus_sym r2 r); Auto with real.
-Qed.
-
-Hints Resolve Rlt_compatibility_r : real.
-
-(**********)
-Lemma Rlt_anti_compatibility:  (r,r1,r2:R)``r+r1 < r+r2`` -> ``r1<r2``.
-Intros; Cut ``(-r+r)+r1 < (-r+r)+r2``.
-Rewrite -> Rplus_Ropp_l.
-Elim (Rplus_ne r1); Elim (Rplus_ne r2); Intros; Rewrite <- H3;
- Rewrite <- H1; Auto with zarith real.
-Rewrite -> Rplus_assoc; Rewrite -> Rplus_assoc;
- Apply (Rlt_compatibility ``-r`` ``r+r1`` ``r+r2`` H).
-Qed.
-
-(**********)
-Lemma Rle_compatibility:(r,r1,r2:R)``r1<=r2`` -> ``r+r1 <= r+r2 ``.
-Unfold Rle; Intros; Elim H; Intro.
-Left; Apply (Rlt_compatibility r r1 r2 H0).
-Right; Rewrite <- H0; Auto with zarith real.
-Qed.
-
-(**********)
-Lemma Rle_compatibility_r:(r,r1,r2:R)``r1<=r2`` -> ``r1+r<=r2+r``.
-Unfold Rle; Intros; Elim H; Intro.
-Left; Apply (Rlt_compatibility_r r r1 r2 H0).
-Right; Rewrite <- H0; Auto with real.
-Qed.
-
-Hints Resolve Rle_compatibility Rle_compatibility_r : real.
-
-(**********)
-Lemma Rle_anti_compatibility: (r,r1,r2:R)``r+r1<=r+r2`` -> ``r1<=r2``.
-Unfold Rle; Intros; Elim H; Intro.
-Left; Apply (Rlt_anti_compatibility r r1 r2 H0).
-Right; Apply (r_Rplus_plus r r1 r2 H0).
-Qed.
-
-(**********)
-Lemma sum_inequa_Rle_lt:(a,x,b,c,y,d:R)``a<=x`` -> ``x<b`` ->
-           ``c<y`` -> ``y<=d`` -> ``a+c < x+y < b+d``.
-Intros;Split.
-Apply Rlt_le_trans with ``a+y``; Auto with real.
-Apply Rlt_le_trans with ``b+y``; Auto with real.
-Qed.
-
-(*********)
-Lemma Rplus_lt:(r1,r2,r3,r4:R)``r1<r2`` -> ``r3<r4`` -> ``r1+r3 < r2+r4``.
-Intros; Apply Rlt_trans with ``r2+r3``; Auto with real.
-Qed.
-
-Lemma Rplus_le:(r1,r2,r3,r4:R)``r1<=r2`` -> ``r3<=r4`` -> ``r1+r3 <= r2+r4``.
-Intros; Apply Rle_trans with ``r2+r3``; Auto with real.
-Qed.
-
-(*********)
-Lemma Rplus_lt_le_lt:(r1,r2,r3,r4:R)``r1<r2`` -> ``r3<=r4`` -> 
-                     ``r1+r3 < r2+r4``.
-Intros; Apply Rlt_le_trans with ``r2+r3``; Auto with real.
-Qed.
-
-(*********)
-Lemma Rplus_le_lt_lt:(r1,r2,r3,r4:R)``r1<=r2`` -> ``r3<r4`` -> 
-                                    ``r1+r3 < r2+r4``.
-Intros; Apply Rle_lt_trans with ``r2+r3``; Auto with real.
-Qed.
-
-Hints Immediate Rplus_lt Rplus_le Rplus_lt_le_lt Rplus_le_lt_lt : real.
-
-(** Order and Opposite *)
-
-(**********)
-Lemma Rgt_Ropp:(r1,r2:R) ``r1 > r2`` -> ``-r1 < -r2``.
-Unfold Rgt; Intros.
-Apply (Rlt_anti_compatibility ``r2+r1``).
-Replace ``r2+r1+(-r1)`` with r2.
-Replace ``r2+r1+(-r2)`` with r1.
-Trivial.
-Ring.
-Ring.
-Qed.
-Hints Resolve Rgt_Ropp.
-
-(**********)
-Lemma Rlt_Ropp:(r1,r2:R) ``r1 < r2`` -> ``-r1 > -r2``.
-Unfold Rgt; Auto with real.
-Qed.
-Hints Resolve Rlt_Ropp : real.
-
-Lemma Ropp_Rlt: (x,y:R) ``-y < -x`` ->``x<y``.
-Intros x y H'.
-Rewrite <- (Ropp_Ropp x); Rewrite <- (Ropp_Ropp y); Auto with real.
-Qed.
-Hints Immediate Ropp_Rlt : real.
-
-Lemma Rlt_Ropp1:(r1,r2:R) ``r2 < r1`` -> ``-r1 < -r2``.
-Auto with real.
-Qed.
-Hints Resolve Rlt_Ropp1 : real.
-
-(**********)
-Lemma Rle_Ropp:(r1,r2:R) ``r1 <= r2`` -> ``-r1 >= -r2``.
-Unfold Rge; Intros r1 r2 [H|H]; Auto with real.
-Qed.
-Hints Resolve Rle_Ropp : real.
-
-Lemma Ropp_Rle: (x,y:R) ``-y <= -x`` ->``x <= y``.
-Intros x y H.
-Elim H;Auto with real.
-Intro H1;Rewrite <-(Ropp_Ropp x);Rewrite <-(Ropp_Ropp y);Rewrite H1;
-  Auto with real.
-Qed.
-Hints Immediate Ropp_Rle : real.
-
-Lemma Rle_Ropp1:(r1,r2:R) ``r2 <= r1`` -> ``-r1 <= -r2``.
-Intros r1 r2 H;Elim H;Auto with real.
-Qed.
-Hints Resolve Rle_Ropp1 : real.
-
-(**********)
-Lemma Rge_Ropp:(r1,r2:R) ``r1 >= r2`` -> ``-r1 <= -r2``.
-Unfold Rge; Intros r1 r2 [H|H]; Auto with real.
-Qed.
-Hints Resolve Rge_Ropp : real.
-
-(**********)
-Lemma Rlt_RO_Ropp:(r:R) ``0 < r`` -> ``0 > -r``.
-Intros; Replace ``0`` with ``-0``; Auto with real.
-Qed.
-Hints Resolve Rlt_RO_Ropp : real.
-
-(**********)
-Lemma Rgt_RO_Ropp:(r:R) ``0 > r`` -> ``0 < -r``.
-Intros; Replace ``0`` with ``-0``; Auto with real.
-Qed.
-Hints Resolve Rgt_RO_Ropp : real.
-
-(**********)
-Lemma Rgt_RoppO:(r:R)``r>0``->``(-r)<0``.
-Intros; Rewrite <- Ropp_O; Auto with real.
-Qed.
-
-(**********)
-Lemma Rlt_RoppO:(r:R)``r<0``->``-r>0``.
-Intros; Rewrite <- Ropp_O; Auto with real.
-Qed.
-Hints Resolve Rgt_RoppO Rlt_RoppO: real.
-
-(**********)
-Lemma Rle_RO_Ropp:(r:R) ``0 <= r`` -> ``0 >= -r``.
-Intros; Replace ``0`` with ``-0``; Auto with real.
-Qed.
-Hints Resolve Rle_RO_Ropp : real.
-
-(**********)
-Lemma Rge_RO_Ropp:(r:R) ``0 >= r`` -> ``0 <= -r``.
-Intros; Replace ``0`` with ``-0``; Auto with real.
-Qed.
-Hints Resolve Rge_RO_Ropp : real.
-
-(** Order and multiplication *)
-
-Lemma Rlt_monotony_r:(r,r1,r2:R)``0<r`` -> ``r1 < r2`` -> ``r1*r < r2*r``.
-Intros; Rewrite (Rmult_sym r1 r); Rewrite (Rmult_sym r2 r); Auto with real.
-Qed.
-Hints Resolve Rlt_monotony_r.
-
-Lemma Rlt_monotony_contra: (z, x, y:R) ``0<z`` ->``z*x<z*y`` ->``x<y``.
-Intros z x y H H0.
-Case (total_order x y); Intros Eq0; Auto; Elim Eq0; Clear Eq0; Intros Eq0.
- Rewrite Eq0 in H0;ElimType False;Apply (Rlt_antirefl ``z*y``);Auto.
-Generalize (Rlt_monotony z y x H Eq0);Intro;ElimType False;
- Generalize (Rlt_trans ``z*x`` ``z*y`` ``z*x`` H0 H1);Intro;
- Apply (Rlt_antirefl ``z*x``);Auto.
-Qed.
-
-V7only [
-Notation Rlt_monotony_rev := Rlt_monotony_contra.
-Notation "'Rlt_monotony_contra' a b c" := (Rlt_monotony_contra c a b)
-  (at level 10, a,b,c at level 9, only parsing).
-].
-
-Lemma Rlt_anti_monotony:(r,r1,r2:R)``r < 0`` -> ``r1 < r2`` -> ``r*r1 > r*r2``.
-Intros; Replace r with ``-(-r)``; Auto with real.
-Rewrite (Ropp_mul1 ``-r``); Rewrite (Ropp_mul1 ``-r``).
-Apply Rlt_Ropp; Auto with real.
-Qed.
-
-(**********)
-Lemma Rle_monotony: 
-  (r,r1,r2:R)``0 <= r`` -> ``r1 <= r2`` -> ``r*r1 <= r*r2``.
-Intros r r1 r2 H H0; NewDestruct H; NewDestruct H0; Unfold Rle; Auto with real.
-Right; Rewrite <- H; Do 2 Rewrite Rmult_Ol; Reflexivity.
-Qed.
-Hints Resolve Rle_monotony : real.
-
-Lemma Rle_monotony_r: 
-  (r,r1,r2:R)``0 <= r`` -> ``r1 <= r2`` -> ``r1*r <= r2*r``.
-Intros r r1 r2 H;
-Rewrite (Rmult_sym r1 r); Rewrite (Rmult_sym r2 r); Auto with real.
-Qed.
-Hints Resolve Rle_monotony_r : real.
-
-Lemma Rmult_le_reg_l:
-  (z, x, y:R) ``0<z`` ->``z*x<=z*y`` ->``x<=y``.
-Intros z x y H H0;Case H0; Auto with real.
-Intros H1; Apply Rlt_le.
-Apply Rlt_monotony_contra with z := z;Auto.
-Intros H1;Replace x with (Rmult (Rinv z) (Rmult z x)); Auto with real.
-Replace y with (Rmult (Rinv z) (Rmult z y)).
- Rewrite H1;Auto with real.
-Rewrite <- Rmult_assoc; Rewrite Rinv_l; Auto with real.
-Rewrite <- Rmult_assoc; Rewrite Rinv_l; Auto with real.
-Qed.
-
-V7only [
-Notation "'Rle_monotony_contra' a b c" := (Rmult_le_reg_l c a b)
-  (at level 10, a,b,c at level 9, only parsing).
-Notation Rle_monotony_contra := Rmult_le_reg_l.
-].
-
-
-Lemma Rle_anti_monotony1
-	:(r,r1,r2:R)``r <= 0`` -> ``r1 <= r2`` -> ``r*r2 <= r*r1``.
-Intros; Replace r with ``-(-r)``; Auto with real.
-Do 2 Rewrite (Ropp_mul1 ``-r``).
-Apply Rle_Ropp1; Auto with real.
-Qed.
-Hints Resolve Rle_anti_monotony1 : real.
-
-Lemma Rle_anti_monotony
-	:(r,r1,r2:R)``r <= 0`` -> ``r1 <= r2`` -> ``r*r1 >= r*r2``.
-Intros; Apply Rle_ge; Auto with real.
-Qed.
-Hints Resolve Rle_anti_monotony : real.
-
-Lemma Rle_Rmult_comp:
-  (x, y, z, t:R) ``0 <= x`` -> ``0 <= z`` -> ``x <= y`` -> ``z <= t`` ->
-  ``x*z <= y*t``.
-Intros x y z t H' H'0 H'1 H'2.
-Apply Rle_trans with r2 := ``x*t``; Auto with real.
-Repeat Rewrite [x:?](Rmult_sym x t).
-Apply Rle_monotony; Auto.
-Apply Rle_trans with z; Auto.
-Qed.
-Hints Resolve Rle_Rmult_comp :real.
-
-Lemma Rmult_lt:(r1,r2,r3,r4:R)``r3>0`` -> ``r2>0`` ->
-  `` r1 < r2`` -> ``r3 < r4`` -> ``r1*r3 < r2*r4``.
-Intros; Apply Rlt_trans with ``r2*r3``; Auto with real.
-Qed.
-
-(*********)
-Lemma Rmult_lt_0
-  :(r1,r2,r3,r4:R)``r3>=0``->``r2>0``->``r1<r2``->``r3<r4``->``r1*r3<r2*r4``.
-Intros; Apply Rle_lt_trans with ``r2*r3``; Auto with real.
-Qed.
-
-(** Order and Substractions *)
-Lemma Rlt_minus:(r1,r2:R)``r1 < r2`` -> ``r1-r2 < 0``.
-Intros; Apply (Rlt_anti_compatibility ``r2``).
-Replace ``r2+(r1-r2)`` with r1.
-Replace  ``r2+0`` with r2; Auto with real.
-Ring.
-Qed.
-Hints Resolve Rlt_minus : real.
-
-(**********)
-Lemma Rle_minus:(r1,r2:R)``r1 <= r2`` -> ``r1-r2 <= 0``.
-NewDestruct 1; Unfold Rle; Auto with real.
-Qed.
-
-(**********)
-Lemma Rminus_lt:(r1,r2:R)``r1-r2 < 0`` -> ``r1 < r2``.
-Intros; Replace r1 with ``r1-r2+r2``.
-Pattern 3 r2; Replace r2 with ``0+r2``; Auto with real.
-Ring.
-Qed.
-
-(**********)
-Lemma Rminus_le:(r1,r2:R)``r1-r2 <= 0`` -> ``r1 <= r2``.
-Intros; Replace r1 with ``r1-r2+r2``.
-Pattern 3 r2; Replace r2 with ``0+r2``; Auto with real.
-Ring.
-Qed.
-
-(**********)
-Lemma tech_Rplus:(r,s:R)``0<=r`` -> ``0<s`` -> ``r+s<>0``.
-Intros; Apply sym_not_eqT; Apply Rlt_not_eq.
-Rewrite Rplus_sym; Replace ``0`` with ``0+0``; Auto with real.
-Qed.
-Hints Immediate tech_Rplus : real.
-
-(** Order and the square function *)
-Lemma pos_Rsqr:(r:R)``0<=(Rsqr r)``.
-Intro; Case (total_order_Rlt_Rle r ``0``); Unfold Rsqr; Intro.
-Replace ``r*r`` with ``(-r)*(-r)``; Auto with real.
-Replace ``0`` with ``-r*0``; Auto with real.
-Replace ``0`` with ``0*r``; Auto with real.
-Qed.
-
-(***********)
-Lemma pos_Rsqr1:(r:R)``r<>0``->``0<(Rsqr r)``.
-Intros; Case (not_Req r ``0``); Trivial; Unfold Rsqr; Intro.
-Replace ``r*r`` with ``(-r)*(-r)``; Auto with real.
-Replace ``0`` with ``-r*0``; Auto with real.
-Replace ``0`` with ``0*r``; Auto with real.
-Qed.
-Hints Resolve pos_Rsqr pos_Rsqr1 : real.
-
-(** Zero is less than one *)
-Lemma Rlt_R0_R1:``0<1``.
-Replace ``1`` with ``(Rsqr 1)``; Auto with real.
-Unfold Rsqr; Auto with real.
-Qed.
-Hints Resolve Rlt_R0_R1 : real.
-
-Lemma Rle_R0_R1:``0<=1``.
-Left.
-Exact Rlt_R0_R1.
-Qed.
-
-(** Order and inverse *)
-Lemma Rlt_Rinv:(r:R)``0<r``->``0</r``.
-Intros; Apply not_Rle; Red; Intros.
-Absurd ``1<=0``; Auto with real.
-Replace ``1`` with ``r*(/r)``; Auto with real.
-Replace ``0`` with ``r*0``; Auto with real.
-Qed.
-Hints Resolve Rlt_Rinv : real.
-
-(*********)
-Lemma Rlt_Rinv2:(r:R)``r < 0``->``/r < 0``.
-Intros; Apply not_Rle; Red; Intros.
-Absurd ``1<=0``; Auto with real.
-Replace ``1`` with ``r*(/r)``; Auto with real.
-Replace ``0`` with ``r*0``; Auto with real.
-Qed.
-Hints Resolve Rlt_Rinv2 : real.
-
-(*********)
-Lemma Rinv_lt:(r1,r2:R)``0 < r1*r2`` -> ``r1 < r2`` -> ``/r2 < /r1``.
-Intros; Apply Rlt_monotony_rev with ``r1*r2``; Auto with real.
-Case (without_div_O_contr r1 r2 ); Intros; Auto with real.
-Replace ``r1*r2*/r2`` with r1.
-Replace ``r1*r2*/r1`` with r2; Trivial.
-Symmetry; Auto with real.
-Symmetry; Auto with real.
-Qed.
-
-Lemma Rlt_Rinv_R1: (x, y:R) ``1 <= x`` -> ``x<y`` ->``/y< /x``.
-Intros x y H' H'0.
-Cut (Rlt R0 x); [Intros Lt0 | Apply Rlt_le_trans with r2 := R1]; 
-  Auto with real.
-Apply Rlt_monotony_contra with z := x; Auto with real.
-Rewrite (Rmult_sym x (Rinv x)); Rewrite Rinv_l; Auto with real.
-Apply Rlt_monotony_contra with z := y; Auto with real.
-Apply Rlt_trans with r2:=x;Auto.
-Cut ``y*(x*/y)==x``.
-Intro H1;Rewrite H1;Rewrite (Rmult_1r y);Auto.
-Rewrite (Rmult_sym x); Rewrite <- Rmult_assoc; Rewrite (Rmult_sym y (Rinv y));
- Rewrite Rinv_l; Auto with real.
-Apply imp_not_Req; Right.
-Red; Apply Rlt_trans with r2 := x; Auto with real.
-Qed.
-Hints Resolve Rlt_Rinv_R1 :real.
-
-(*********************************************************)        
-(**      Greater                                         *)
-(*********************************************************)
-
-(**********)
-Lemma Rge_ge_eq:(r1,r2:R)``r1 >= r2`` -> ``r2 >= r1`` -> r1==r2.
-Intros; Apply Rle_antisym; Auto with real.
-Qed.
-
-(**********)
-Lemma Rlt_not_ge:(r1,r2:R)~(``r1<r2``)->``r1>=r2``.
-Intros; Unfold Rge; Elim (total_order r1 r2); Intro.
-Absurd ``r1<r2``; Trivial.
-Case H0; Auto.
-Qed.
-
-(**********)
-Lemma Rnot_lt_le:(r1,r2:R)~(``r1<r2``)->``r2<=r1``.
-Intros; Apply Rge_le; Apply Rlt_not_ge; Assumption.
-Qed.
-
-(**********)
-Lemma Rgt_not_le:(r1,r2:R)~(``r1>r2``)->``r1<=r2``.
-Intros r1 r2 H; Apply Rge_le.
-Exact (Rlt_not_ge r2 r1 H).
-Qed.
-
-(**********)
-Lemma Rgt_ge:(r1,r2:R)``r1>r2`` -> ``r1 >= r2``.
-Red; Auto with real.
-Qed.
-
-V7only [
-(**********)
-Lemma Rlt_sym:(r1,r2:R)``r1<r2`` <-> ``r2>r1``.
-Split; Unfold Rgt; Auto with real.
-Qed.
-
-(**********)
-Lemma Rle_sym1:(r1,r2:R)``r1<=r2``->``r2>=r1``.
-Proof Rle_ge.
-
-Notation "'Rle_sym2' a b" := (Rge_le b a)
-  (at level 10, a,b at next level).
-Notation "'Rle_sym2' a" := [b:R](Rge_le b a)
-  (at level 10, a at next level).
-Notation Rle_sym2 := Rge_le.
-(*
-(**********)
-Lemma Rle_sym2:(r1,r2:R)``r2>=r1`` -> ``r1<=r2``.
-Proof [r1,r2](Rge_le r2 r1).
-*)
-
-(**********)
-Lemma Rle_sym:(r1,r2:R)``r1<=r2``<->``r2>=r1``.
-Split; Auto with real.
-Qed.
-].
-
-(**********)
-Lemma Rge_gt_trans:(r1,r2,r3:R)``r1>=r2``->``r2>r3``->``r1>r3``.
-Unfold Rgt; Intros; Apply Rlt_le_trans with r2; Auto with real.
-Qed.
-
-(**********)
-Lemma Rgt_ge_trans:(r1,r2,r3:R)``r1>r2`` -> ``r2>=r3`` -> ``r1>r3``.
-Unfold Rgt; Intros; Apply Rle_lt_trans with r2; Auto with real.
-Qed.
-
-(**********)
-Lemma Rgt_trans:(r1,r2,r3:R)``r1>r2`` -> ``r2>r3`` -> ``r1>r3``.
-Unfold Rgt; Intros; Apply Rlt_trans with r2; Auto with real.
-Qed.
-
-(**********)
-Lemma Rge_trans:(r1,r2,r3:R)``r1>=r2`` -> ``r2>=r3`` -> ``r1>=r3``.
-Intros; Apply Rle_ge.
-Apply Rle_trans with r2; Auto with real.
-Qed.
-
-(**********)
-Lemma Rlt_r_plus_R1:(r:R)``0<=r`` -> ``0<r+1``.
-Intros.
-Apply Rlt_le_trans with ``1``; Auto with real.
-Pattern 1 ``1``; Replace ``1`` with ``0+1``; Auto with real.
-Qed.
-Hints Resolve Rlt_r_plus_R1: real.
-
-(**********)
-Lemma Rlt_r_r_plus_R1:(r:R)``r<r+1``.
-Intros.
-Pattern 1 r; Replace r with ``r+0``; Auto with real.
-Qed.
-Hints Resolve Rlt_r_r_plus_R1: real.
-
-(**********)
-Lemma tech_Rgt_minus:(r1,r2:R)``0<r2``->``r1>r1-r2``.
-Red; Unfold Rminus; Intros.
-Pattern 2 r1; Replace r1 with ``r1+0``; Auto with real.
-Qed.
-
-(***********)
-Lemma Rgt_plus_plus_r:(r,r1,r2:R)``r1>r2``->``r+r1 > r+r2``.
-Unfold Rgt; Auto with real.
-Qed.
-Hints Resolve Rgt_plus_plus_r : real.
-
-(***********)
-Lemma Rgt_r_plus_plus:(r,r1,r2:R)``r+r1 > r+r2`` -> ``r1 > r2``.
-Unfold Rgt; Intros; Apply (Rlt_anti_compatibility r r2 r1 H).
-Qed.
-
-(***********)
-Lemma Rge_plus_plus_r:(r,r1,r2:R)``r1>=r2`` -> ``r+r1 >= r+r2``.
-Intros; Apply Rle_ge; Auto with real.
-Qed.
-Hints Resolve Rge_plus_plus_r : real.
-
-(***********)
-Lemma Rge_r_plus_plus:(r,r1,r2:R)``r+r1 >= r+r2`` -> ``r1>=r2``.
-Intros; Apply Rle_ge; Apply Rle_anti_compatibility with r; Auto with real.
-Qed.
-
-(***********)
-Lemma Rmult_ge_compat_r:
- (z,x,y:R) ``z>=0`` -> ``x>=y`` -> ``x*z >= y*z``.
-Intros z x y; Intros; Apply Rle_ge; Apply Rle_monotony_r; Apply Rge_le; Assumption.
-Qed.
-
-V7only [
-Notation "'Rge_monotony' a b c" := (Rmult_ge_compat_r c a b)
-  (at level 10, a,b,c at level 9, only parsing).
-Notation Rge_monotony := Rmult_ge_compat_r.
-].
-
-(***********)
-Lemma Rgt_minus:(r1,r2:R)``r1>r2`` -> ``r1-r2 > 0``.
-Intros; Replace ``0`` with ``r2-r2``; Auto with real.
-Unfold Rgt Rminus; Auto with real.
-Qed.
-
-(*********)
-Lemma minus_Rgt:(r1,r2:R)``r1-r2 > 0`` -> ``r1>r2``.
-Intros; Replace r2 with ``r2+0``; Auto with real.
-Intros; Replace r1 with ``r2+(r1-r2)``; Auto with real.
-Qed.
-
-(**********)
-Lemma Rge_minus:(r1,r2:R)``r1>=r2`` -> ``r1-r2 >= 0``.
-Unfold Rge; Intros; Elim H; Intro.
-Left; Apply (Rgt_minus r1 r2 H0).
-Right; Apply (eq_Rminus r1 r2 H0).
-Qed.
-
-(*********)
-Lemma minus_Rge:(r1,r2:R)``r1-r2 >= 0`` -> ``r1>=r2``.
-Intros; Replace r2 with ``r2+0``; Auto with real.
-Intros; Replace r1 with ``r2+(r1-r2)``; Auto with real.
-Qed.
-
-
-(*********)
-Lemma Rmult_gt:(r1,r2:R)``r1>0`` -> ``r2>0`` -> ``r1*r2>0``.
-Unfold Rgt;Intros.
-Replace ``0`` with ``0*r2``; Auto with real.
-Qed.
-
-(*********)
-Lemma Rmult_lt_pos:(x,y:R)``0<x`` -> ``0<y`` -> ``0<x*y``.
-Proof Rmult_gt.
-
-(***********)
-Lemma Rplus_eq_R0_l:(a,b:R)``0<=a`` -> ``0<=b`` -> ``a+b==0`` -> ``a==0``.
-Intros a b [H|H] H0 H1; Auto with real.
-Absurd ``0<a+b``.
-Rewrite H1; Auto with real.
-Replace ``0`` with ``0+0``; Auto with real.
-Qed.
-
-
-Lemma Rplus_eq_R0
-	:(a,b:R)``0<=a`` -> ``0<=b`` -> ``a+b==0`` -> ``a==0``/\``b==0``.
-Intros a b; Split.
-Apply Rplus_eq_R0_l with b; Auto with real.
-Apply Rplus_eq_R0_l with a; Auto with real.
-Rewrite Rplus_sym; Auto with real.
-Qed.
-
-
-(***********)
-Lemma Rplus_Rsr_eq_R0_l:(a,b:R)``(Rsqr a)+(Rsqr b)==0``->``a==0``.
-Intros a b; Intros; Apply Rsqr_r_R0; Apply Rplus_eq_R0_l with (Rsqr b); Auto with real.
-Qed.
-
-Lemma Rplus_Rsr_eq_R0:(a,b:R)``(Rsqr a)+(Rsqr b)==0``->``a==0``/\``b==0``.
-Intros a b; Split.
-Apply Rplus_Rsr_eq_R0_l with b; Auto with real.
-Apply Rplus_Rsr_eq_R0_l with a; Auto with real.
-Rewrite Rplus_sym; Auto with real.
-Qed.
-
-
-(**********************************************************) 
-(**       Injection from [N] to [R]                       *)
-(**********************************************************)
-
-(**********)
-Lemma S_INR:(n:nat)(INR (S n))==``(INR n)+1``.
-Intro; Case n; Auto with real.
-Qed.
-
-(**********)
-Lemma S_O_plus_INR:(n:nat)
-    (INR (plus (S O) n))==``(INR (S O))+(INR n)``.
-Intro; Simpl; Case n; Intros; Auto with real.
-Qed.
-
-(**********)
-Lemma plus_INR:(n,m:nat)(INR (plus n m))==``(INR n)+(INR m)``. 
-Intros n m; Induction n.
-Simpl; Auto with real.
-Replace (plus (S n) m) with (S (plus n m)); Auto with arith.
-Repeat Rewrite S_INR.
-Rewrite Hrecn; Ring.
-Qed.
-
-(**********)
-Lemma minus_INR:(n,m:nat)(le m n)->(INR (minus n m))==``(INR n)-(INR m)``.
-Intros n m le; Pattern m n; Apply le_elim_rel; Auto with real.
-Intros; Rewrite <- minus_n_O; Auto with real.
-Intros; Repeat Rewrite S_INR; Simpl.
-Rewrite H0; Ring.
-Qed.
-
-(*********)
-Lemma mult_INR:(n,m:nat)(INR (mult n m))==(Rmult (INR n) (INR m)).
-Intros n m; Induction n.
-Simpl; Auto with real.
-Intros; Repeat Rewrite S_INR; Simpl.
-Rewrite plus_INR; Rewrite Hrecn; Ring.
-Qed.
-
-Hints Resolve plus_INR minus_INR mult_INR : real.
-
-(*********)
-Lemma lt_INR_0:(n:nat)(lt O n)->``0 < (INR n)``.
-Induction 1; Intros; Auto with real.
-Rewrite S_INR; Auto with real.
-Qed.
-Hints Resolve lt_INR_0: real.
-
-Lemma lt_INR:(n,m:nat)(lt n m)->``(INR n) < (INR m)``.
-Induction 1; Intros; Auto with real.
-Rewrite S_INR; Auto with real.
-Rewrite S_INR; Apply Rlt_trans with (INR m0); Auto with real.
-Qed.
-Hints Resolve lt_INR: real.
-
-Lemma INR_lt_1:(n:nat)(lt (S O) n)->``1 < (INR n)``.
-Intros;Replace ``1`` with (INR (S O));Auto with real.
-Qed.
-Hints Resolve INR_lt_1: real.
-
-(**********)
-Lemma INR_pos : (p:positive)``0<(INR (convert p))``.
-Intro; Apply lt_INR_0.
-Simpl; Auto with real.
-Apply compare_convert_O.
-Qed.
-Hints Resolve INR_pos : real.
-
-(**********)
-Lemma pos_INR:(n:nat)``0 <= (INR n)``.
-Intro n; Case n.
-Simpl; Auto with real.
-Auto with arith real.
-Qed.
-Hints Resolve pos_INR: real.
-
-Lemma INR_lt:(n,m:nat)``(INR n) < (INR m)``->(lt n m).
-Double Induction n m;Intros.
-Simpl;ElimType False;Apply (Rlt_antirefl R0);Auto.
-Auto with arith.
-Generalize (pos_INR (S n0));Intro;Cut (INR O)==R0;
-  [Intro H2;Rewrite H2 in H0;Idtac|Simpl;Trivial]. 
-Generalize (Rle_lt_trans ``0`` (INR (S n0)) ``0`` H1 H0);Intro;
-  ElimType False;Apply (Rlt_antirefl R0);Auto.
-Do 2 Rewrite S_INR in H1;Cut ``(INR n1) < (INR n0)``.
-Intro H2;Generalize (H0 n0 H2);Intro;Auto with arith.
-Apply (Rlt_anti_compatibility ``1`` (INR n1) (INR n0)).
-Rewrite Rplus_sym;Rewrite (Rplus_sym ``1`` (INR n0));Trivial.
-Qed.
-Hints Resolve INR_lt: real.
-
-(*********)
-Lemma le_INR:(n,m:nat)(le n m)->``(INR n)<=(INR m)``.
-Induction 1; Intros; Auto with real.
-Rewrite S_INR.
-Apply Rle_trans with (INR m0); Auto with real.
-Qed.
-Hints Resolve le_INR: real.
-
-(**********)
-Lemma not_INR_O:(n:nat)``(INR n)<>0``->~n=O.
-Red; Intros n H H1.
-Apply H.
-Rewrite H1; Trivial.
-Qed.
-Hints Immediate not_INR_O : real.
-
-(**********)
-Lemma not_O_INR:(n:nat)~n=O->``(INR n)<>0``.
-Intro n; Case n.
-Intro; Absurd (0)=(0); Trivial.
-Intros; Rewrite S_INR.
-Apply Rgt_not_eq; Red; Auto with real.
-Qed.
-Hints Resolve not_O_INR : real.
-
-Lemma not_nm_INR:(n,m:nat)~n=m->``(INR n)<>(INR m)``.
-Intros n m H; Case (le_or_lt n m); Intros H1.
-Case (le_lt_or_eq ? ? H1); Intros H2.
-Apply imp_not_Req; Auto with real.
-ElimType False;Auto.
-Apply sym_not_eqT; Apply imp_not_Req; Auto with real.
-Qed.
-Hints Resolve not_nm_INR : real.
-
-Lemma INR_eq: (n,m:nat)(INR n)==(INR m)->n=m.
-Intros;Case (le_or_lt n m); Intros H1.
-Case (le_lt_or_eq ? ? H1); Intros H2;Auto.
-Cut ~n=m.
-Intro H3;Generalize (not_nm_INR n m H3);Intro H4;
-  ElimType False;Auto.
-Omega.
-Symmetry;Cut ~m=n.
-Intro H3;Generalize (not_nm_INR m n H3);Intro H4;
-  ElimType False;Auto.
-Omega.
-Qed.
-Hints Resolve INR_eq : real.
-
-Lemma INR_le: (n, m : nat) (Rle (INR n) (INR m)) ->  (le n m).
-Intros;Elim H;Intro.
-Generalize (INR_lt n m H0);Intro;Auto with arith.
-Generalize (INR_eq n m H0);Intro;Rewrite H1;Auto.
-Qed.
-Hints Resolve INR_le : real.
-
-Lemma not_1_INR:(n:nat)~n=(S O)->``(INR n)<>1``.
-Replace ``1``  with (INR (S O)); Auto with real.
-Qed.
-Hints Resolve not_1_INR : real.
-
-(**********************************************************) 
-(**      Injection from [Z] to [R]                        *)
-(**********************************************************)
-
-V7only [
-(**********)
-Definition Z_of_nat := inject_nat.
-Notation INZ:=Z_of_nat.
-].
-
-(**********)
-Lemma IZN:(z:Z)(`0<=z`)->(Ex [m:nat] z=(INZ m)).
-Intros z; Unfold INZ; Apply inject_nat_complete; Assumption.
-Qed.
-
-(**********)
-Lemma INR_IZR_INZ:(n:nat)(INR n)==(IZR (INZ n)).
-Induction n; Auto with real.
-Intros; Simpl; Rewrite bij1; Auto with real.
-Qed.
-
-Lemma plus_IZR_NEG_POS : 
-  (p,q:positive)(IZR `(POS p)+(NEG q)`)==``(IZR (POS p))+(IZR (NEG q))``.
-Intros.
-Case (lt_eq_lt_dec (convert p) (convert q)).
-Intros [H | H]; Simpl.
-Rewrite convert_compare_INFERIEUR; Simpl; Trivial.
-Rewrite (true_sub_convert q p).
-Rewrite minus_INR; Auto with arith; Ring.
-Apply ZC2; Apply convert_compare_INFERIEUR; Trivial.
-Rewrite (convert_intro p q); Trivial.
-Rewrite convert_compare_EGAL; Simpl; Auto with real.
-Intro H; Simpl.
-Rewrite convert_compare_SUPERIEUR; Simpl; Auto with arith.
-Rewrite (true_sub_convert p q).
-Rewrite minus_INR; Auto with arith; Ring.
-Apply ZC2; Apply convert_compare_INFERIEUR; Trivial.
-Qed.
-
-(**********)
-Lemma plus_IZR:(z,t:Z)(IZR `z+t`)==``(IZR z)+(IZR t)``.
-Intro z; NewDestruct z; Intro t; NewDestruct t; Intros; Auto with real.
-Simpl; Intros; Rewrite convert_add; Auto with real.
-Apply plus_IZR_NEG_POS.
-Rewrite Zplus_sym; Rewrite Rplus_sym; Apply plus_IZR_NEG_POS.
-Simpl; Intros; Rewrite convert_add; Rewrite plus_INR; Auto with real.
-Qed.
-
-(**********)
-Lemma mult_IZR:(z,t:Z)(IZR `z*t`)==``(IZR z)*(IZR t)``.
-Intros z t; Case z; Case t; Simpl; Auto with real.
-Intros t1 z1; Rewrite times_convert; Auto with real.
-Intros t1 z1; Rewrite times_convert; Auto with real.
-Rewrite Rmult_sym.
-Rewrite Ropp_mul1; Auto with real.
-Apply eq_Ropp; Rewrite mult_sym; Auto with real.
-Intros t1 z1; Rewrite times_convert; Auto with real.
-Rewrite Ropp_mul1; Auto with real.
-Intros t1 z1; Rewrite times_convert; Auto with real.
-Rewrite Ropp_mul2; Auto with real.
-Qed.
-
-(**********)
-Lemma Ropp_Ropp_IZR:(z:Z)(IZR (`-z`))==``-(IZR z)``.
-Intro z; Case z; Simpl; Auto with real.
-Qed.
-
-(**********)
-Lemma Z_R_minus:(z1,z2:Z)``(IZR z1)-(IZR z2)``==(IZR `z1-z2`).
-Intros z1 z2; Unfold Rminus; Unfold Zminus.
-Rewrite <-(Ropp_Ropp_IZR z2); Symmetry; Apply plus_IZR.
-Qed. 
-
-(**********)
-Lemma lt_O_IZR:(z:Z)``0 < (IZR z)``->`0<z`.
-Intro z; Case z; Simpl; Intros.
-Absurd ``0<0``; Auto with real.
-Unfold Zlt; Simpl; Trivial.
-Case Rlt_le_not with 1:=H.
-Replace ``0`` with ``-0``; Auto with real.
-Qed.
-
-(**********)
-Lemma lt_IZR:(z1,z2:Z)``(IZR z1)<(IZR z2)``->`z1<z2`.
-Intros z1 z2 H; Apply Zlt_O_minus_lt. 
-Apply lt_O_IZR.
-Rewrite <- Z_R_minus.
-Exact (Rgt_minus (IZR z2) (IZR z1) H).
-Qed.
-
-(**********)
-Lemma eq_IZR_R0:(z:Z)``(IZR z)==0``->`z=0`.
-Intro z; NewDestruct z; Simpl; Intros; Auto with zarith.
-Case (Rlt_not_eq ``0`` (INR (convert p))); Auto with real.
-Case (Rlt_not_eq ``-(INR (convert p))`` ``0`` ); Auto with real.
-Apply Rgt_RoppO. Unfold Rgt; Apply INR_pos.
-Qed.
-
-(**********)
-Lemma eq_IZR:(z1,z2:Z)(IZR z1)==(IZR z2)->z1=z2.
-Intros z1 z2 H;Generalize (eq_Rminus (IZR z1) (IZR z2) H);
- Rewrite (Z_R_minus z1 z2);Intro;Generalize (eq_IZR_R0 `z1-z2` H0);
- Intro;Omega.
-Qed.
-
-(**********)
-Lemma not_O_IZR:(z:Z)`z<>0`->``(IZR z)<>0``.
-Intros z H; Red; Intros H0; Case H.
-Apply eq_IZR; Auto.
-Qed.
-
-(*********)
-Lemma le_O_IZR:(z:Z)``0<= (IZR z)``->`0<=z`.
-Unfold Rle; Intros z [H|H].
-Red;Intro;Apply (Zlt_le_weak `0` z (lt_O_IZR z H)); Assumption.
-Rewrite (eq_IZR_R0 z); Auto with zarith real.
-Qed.
-
-(**********)
-Lemma le_IZR:(z1,z2:Z)``(IZR z1)<=(IZR z2)``->`z1<=z2`.
-Unfold Rle; Intros z1 z2 [H|H].
-Apply (Zlt_le_weak z1 z2); Auto with real.
-Apply lt_IZR; Trivial.
-Rewrite (eq_IZR z1 z2); Auto with zarith real.
-Qed.
-
-(**********)
-Lemma le_IZR_R1:(z:Z)``(IZR z)<=1``-> `z<=1`.
-Pattern 1 ``1``; Replace ``1`` with (IZR `1`); Intros; Auto.
-Apply le_IZR; Trivial.
-Qed.
-
-(**********)
-Lemma IZR_ge: (m,n:Z) `m>= n` -> ``(IZR m)>=(IZR n)``.
-Intros m n H; Apply Rlt_not_ge;Red;Intro.
-Generalize (lt_IZR m n H0); Intro; Omega.
-Qed.
-
-Lemma IZR_le: (m,n:Z) `m<= n` -> ``(IZR m)<=(IZR n)``.
-Intros m n H;Apply Rgt_not_le;Red;Intro.
-Unfold Rgt in H0;Generalize (lt_IZR n m H0); Intro; Omega.
-Qed.
-
-Lemma IZR_lt: (m,n:Z) `m< n` -> ``(IZR m)<(IZR n)``.
-Intros m n H;Cut `m<=n`.
-Intro H0;Elim (IZR_le m n H0);Intro;Auto.
-Generalize (eq_IZR m n H1);Intro;ElimType False;Omega.
-Omega.
-Qed.
-
-Lemma one_IZR_lt1 : (z:Z)``-1<(IZR z)<1``->`z=0`.
-Intros z (H1,H2).
-Apply Zle_antisym.
-Apply Zlt_n_Sm_le; Apply lt_IZR; Trivial.
-Replace `0` with (Zs `-1`); Trivial.
-Apply Zlt_le_S; Apply lt_IZR; Trivial.
-Qed.
-
-Lemma one_IZR_r_R1
-  : (r:R)(z,x:Z)``r<(IZR z)<=r+1``->``r<(IZR x)<=r+1``->z=x.
-Intros r z x (H1,H2) (H3,H4).
-Cut `z-x=0`; Auto with zarith.
-Apply one_IZR_lt1.
-Rewrite <- Z_R_minus; Split.
-Replace ``-1`` with ``r-(r+1)``.
-Unfold Rminus; Apply Rplus_lt_le_lt; Auto with real.
-Ring.
-Replace ``1`` with ``(r+1)-r``.
-Unfold Rminus; Apply Rplus_le_lt_lt; Auto with real.
-Ring.
-Qed.
-
-
-(**********)
-Lemma single_z_r_R1: 
-   (r:R)(z,x:Z)``r<(IZR z)``->``(IZR z)<=r+1``->``r<(IZR x)``->
-        ``(IZR x)<=r+1``->z=x.
-Intros; Apply one_IZR_r_R1 with r; Auto.
-Qed.
-
-(**********)
-Lemma tech_single_z_r_R1
-	:(r:R)(z:Z)``r<(IZR z)``->``(IZR z)<=r+1``
-         -> (Ex [s:Z] (~s=z/\``r<(IZR s)``/\``(IZR s)<=r+1``))->False.
-Intros r z H1 H2 (s, (H3,(H4,H5))).
-Apply H3; Apply single_z_r_R1 with r; Trivial.
-Qed.
-
-(*****************************************************************)
-(** Definitions of new types                                     *)
-(*****************************************************************)
-
-Record nonnegreal : Type := mknonnegreal {
-nonneg :> R;
-cond_nonneg : ``0<=nonneg`` }.
-
-Record posreal : Type := mkposreal {
-pos :> R;
-cond_pos : ``0<pos`` }.
-
-Record nonposreal : Type := mknonposreal {
-nonpos :> R;
-cond_nonpos : ``nonpos<=0`` }.
-
-Record negreal : Type := mknegreal {
-neg :> R;
-cond_neg : ``neg<0`` }.
-
-Record nonzeroreal : Type := mknonzeroreal {
-nonzero :> R;
-cond_nonzero : ~``nonzero==0`` }.
-
-(**********)
-Lemma prod_neq_R0 : (x,y:R) ~``x==0``->~``y==0``->~``x*y==0``.
-Intros x y; Intros; Red; Intro; Generalize (without_div_Od x y H1); Intro; Elim H2; Intro; [Rewrite H3 in H; Elim H | Rewrite H3 in H0; Elim H0]; Reflexivity.
-Qed.
-
-(*********)
-Lemma Rmult_le_pos : (x,y:R) ``0<=x`` -> ``0<=y`` -> ``0<=x*y``.
-Intros x y H H0; Rewrite <- (Rmult_Ol x); Rewrite <- (Rmult_sym x); Apply (Rle_monotony x R0 y H H0).
-Qed.
-
-Lemma double : (x:R) ``2*x==x+x``.
-Intro; Ring.
-Qed.
-
-Lemma double_var : (x:R) ``x == x/2 + x/2``.
-Intro; Rewrite <- double; Unfold Rdiv; Rewrite <- Rmult_assoc; Symmetry; Apply Rinv_r_simpl_m.
-Replace ``2`` with (INR (2)); [Apply not_O_INR; Discriminate | Unfold INR; Ring].
-Qed.
-
-(**********************************************************)
-(** Other rules about < and <=                            *)
-(**********************************************************)
-
-Lemma gt0_plus_gt0_is_gt0 : (x,y:R) ``0<x`` -> ``0<y`` -> ``0<x+y``.
-Intros x y; Intros; Apply Rlt_trans with x; [Assumption | Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rlt_compatibility; Assumption].
-Qed.
-
-Lemma ge0_plus_gt0_is_gt0 : (x,y:R) ``0<=x`` -> ``0<y`` -> ``0<x+y``.
-Intros x y; Intros; Apply Rle_lt_trans with x; [Assumption | Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rlt_compatibility; Assumption].
-Qed.
-
-Lemma gt0_plus_ge0_is_gt0 : (x,y:R) ``0<x`` -> ``0<=y`` -> ``0<x+y``.
-Intros x y; Intros; Rewrite <- Rplus_sym; Apply ge0_plus_gt0_is_gt0; Assumption.
-Qed.
-
-Lemma ge0_plus_ge0_is_ge0 : (x,y:R) ``0<=x`` -> ``0<=y`` -> ``0<=x+y``.
-Intros x y; Intros; Apply Rle_trans with x; [Assumption | Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rle_compatibility; Assumption].
-Qed.
-
-Lemma plus_le_is_le : (x,y,z:R) ``0<=y`` -> ``x+y<=z`` -> ``x<=z``.
-Intros x y z; Intros; Apply Rle_trans with ``x+y``; [Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rle_compatibility; Assumption | Assumption].
-Qed.
-
-Lemma plus_lt_is_lt : (x,y,z:R) ``0<=y`` -> ``x+y<z`` -> ``x<z``.
-Intros x y z; Intros; Apply Rle_lt_trans with ``x+y``; [Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rle_compatibility; Assumption | Assumption].
-Qed.
-
-Lemma Rmult_lt2 : (r1,r2,r3,r4:R) ``0<=r1`` -> ``0<=r3`` -> ``r1<r2`` -> ``r3<r4`` -> ``r1*r3<r2*r4``.
-Intros; Apply Rle_lt_trans with ``r2*r3``; [Apply Rle_monotony_r; [Assumption | Left; Assumption] | Apply Rlt_monotony; [Apply Rle_lt_trans with r1; Assumption | Assumption]].
-Qed.
-
-Lemma le_epsilon : (x,y:R) ((eps : R) ``0<eps``->``x<=y+eps``) -> ``x<=y``.
-Intros x y; Intros; Elim (total_order x y); Intro.
-Left; Assumption.
-Elim H0; Intro.
-Right; Assumption.
-Clear H0; Generalize (Rgt_minus x y H1); Intro H2; Change ``0<x-y`` in H2.
-Cut ``0<2``.
-Intro.
-Generalize (Rmult_lt_pos ``x-y`` ``/2`` H2 (Rlt_Rinv ``2`` H0)); Intro H3; Generalize (H ``(x-y)*/2`` H3); Replace ``y+(x-y)*/2`` with ``(y+x)*/2``.
-Intro H4; Generalize (Rle_monotony ``2`` x ``(y+x)*/2`` (Rlt_le ``0`` ``2`` H0) H4); Rewrite <- (Rmult_sym ``((y+x)*/2)``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Replace ``2*x`` with ``x+x``.
-Rewrite (Rplus_sym y); Intro H5; Apply Rle_anti_compatibility with x; Assumption.
-Ring. 
-Replace ``2`` with (INR (S (S O))); [Apply not_O_INR; Discriminate | Ring].
-Pattern 2 y; Replace y with ``y/2+y/2``.
-Unfold Rminus Rdiv.
-Repeat Rewrite Rmult_Rplus_distrl.
-Ring.
-Cut (z:R) ``2*z == z + z``.
-Intro.
-Rewrite <- (H4 ``y/2``).
-Unfold Rdiv.
-Rewrite <- Rmult_assoc; Apply Rinv_r_simpl_m.
-Replace ``2`` with (INR (2)).
-Apply not_O_INR.
-Discriminate.
-Unfold INR; Reflexivity.
-Intro; Ring.
-Cut ~(O=(2)); [Intro H0; Generalize (lt_INR_0 (2) (neq_O_lt (2) H0)); Unfold INR; Intro; Assumption | Discriminate].
-Qed.
-
-(**********)
-Lemma complet_weak : (E:R->Prop) (bound E) -> (ExT [x:R] (E x)) -> (ExT [m:R] (is_lub E m)).
-Intros; Elim (complet E H H0); Intros; Split with x; Assumption.
-Qed.
diff --git a/theories7/Reals/RList.v b/theories7/Reals/RList.v
deleted file mode 100644
index b89296fb..00000000
--- a/theories7/Reals/RList.v
+++ /dev/null
@@ -1,427 +0,0 @@
-(************************************************************************)
-(*  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: RList.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Inductive Rlist : Type :=
-| nil : Rlist
-| cons : R -> Rlist -> Rlist.
-
-Fixpoint In [x:R;l:Rlist] : Prop :=
-Cases l of
-| nil => False
-| (cons a l') => ``x==a``\/(In x l') end.
-
-Fixpoint Rlength [l:Rlist] : nat :=
-Cases l of
-| nil => O
-| (cons a l') => (S (Rlength l')) end.
-
-Fixpoint MaxRlist [l:Rlist] : R :=
- Cases l of
- | nil => R0
- | (cons a l1) => 
-   Cases l1 of
-   | nil => a
-   | (cons a' l2) => (Rmax a (MaxRlist l1)) 
-   end
-end.
-
-Fixpoint MinRlist [l:Rlist] : R :=
-Cases l of
- | nil => R1 
- | (cons a l1) => 
-   Cases l1 of
-   | nil => a
-   | (cons a' l2) => (Rmin a (MinRlist l1)) 
-   end
-end.
-
-Lemma MaxRlist_P1 : (l:Rlist;x:R) (In x l)->``x<=(MaxRlist l)``.
-Intros; Induction l.
-Simpl in H; Elim H.
-Induction l.
-Simpl in H; Elim H; Intro.
-Simpl; Right; Assumption.
-Elim H0.
-Replace (MaxRlist (cons r (cons r0 l))) with (Rmax r (MaxRlist (cons r0 l))).
-Simpl in H; Decompose [or] H.
-Rewrite H0; Apply RmaxLess1.
-Unfold Rmax; Case (total_order_Rle r (MaxRlist (cons r0 l))); Intro.
-Apply Hrecl; Simpl; Tauto.
-Apply Rle_trans with (MaxRlist (cons r0 l)); [Apply Hrecl; Simpl; Tauto | Left; Auto with real].
-Unfold Rmax; Case (total_order_Rle r (MaxRlist (cons r0 l))); Intro.
-Apply Hrecl; Simpl; Tauto.
-Apply Rle_trans with (MaxRlist (cons r0 l)); [Apply Hrecl; Simpl; Tauto | Left; Auto with real].
-Reflexivity.
-Qed.
-
-Fixpoint AbsList [l:Rlist] : R->Rlist :=
-[x:R] Cases l of
-| nil => nil
-| (cons a l') => (cons ``(Rabsolu (a-x))/2`` (AbsList l' x))
-end.
-
-Lemma MinRlist_P1 : (l:Rlist;x:R) (In x l)->``(MinRlist l)<=x``.
-Intros; Induction l.
-Simpl in H; Elim H.
-Induction l.
-Simpl in H; Elim H; Intro.
-Simpl; Right; Symmetry; Assumption.
-Elim H0.
-Replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
-Simpl in H; Decompose [or] H.
-Rewrite H0; Apply Rmin_l.
-Unfold Rmin; Case (total_order_Rle r (MinRlist (cons r0 l))); Intro.
-Apply Rle_trans with (MinRlist (cons r0 l)).
-Assumption.
-Apply Hrecl; Simpl; Tauto.
-Apply Hrecl; Simpl; Tauto.
-Apply Rle_trans with (MinRlist (cons r0 l)).
-Apply Rmin_r.
-Apply Hrecl; Simpl; Tauto.
-Reflexivity.
-Qed.
-
-Lemma AbsList_P1 : (l:Rlist;x,y:R) (In y l) -> (In ``(Rabsolu (y-x))/2`` (AbsList l x)).
-Intros; Induction l.
-Elim H.
-Simpl; Simpl in H; Elim H; Intro.
-Left; Rewrite H0; Reflexivity.
-Right; Apply Hrecl; Assumption.
-Qed.
-
-Lemma MinRlist_P2 : (l:Rlist) ((y:R)(In y l)->``0<y``)->``0<(MinRlist l)``.
-Intros; Induction l.
-Apply Rlt_R0_R1.
-Induction l.
-Simpl; Apply H; Simpl; Tauto.
-Replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
-Unfold Rmin; Case (total_order_Rle r (MinRlist (cons r0 l))); Intro.
-Apply H; Simpl; Tauto.
-Apply Hrecl; Intros; Apply H; Simpl; Simpl in H0; Tauto.
-Reflexivity.
-Qed.
-
-Lemma AbsList_P2 : (l:Rlist;x,y:R) (In y (AbsList l x)) -> (EXT z : R | (In z l)/\``y==(Rabsolu (z-x))/2``).
-Intros; Induction l.
-Elim H.
-Elim H; Intro.
-Exists r; Split.
-Simpl; Tauto.
-Assumption.
-Assert H1 := (Hrecl H0); Elim H1; Intros; Elim H2; Clear H2; Intros; Exists x0; Simpl; Simpl in H2; Tauto.
-Qed.
-
-Lemma MaxRlist_P2 : (l:Rlist) (EXT y:R | (In y l)) -> (In (MaxRlist l) l).
-Intros; Induction l.
-Simpl in H; Elim H; Trivial.
-Induction l.
-Simpl; Left; Reflexivity.
-Change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))); Unfold Rmax; Case (total_order_Rle r (MaxRlist (cons r0 l))); Intro.
-Right; Apply Hrecl; Exists r0; Left; Reflexivity.
-Left; Reflexivity.
-Qed.
-
-Fixpoint pos_Rl [l:Rlist] : nat->R :=
-[i:nat] Cases l of
-| nil => R0
-| (cons a l') =>
- Cases i of
- | O => a
- | (S i') => (pos_Rl l' i')
- end
-end.
-
-Lemma pos_Rl_P1 : (l:Rlist;a:R) (lt O (Rlength l)) -> (pos_Rl (cons a l) (Rlength l))==(pos_Rl l (pred (Rlength l))).
-Intros; Induction l; [Elim (lt_n_O ? H) | Simpl; Case (Rlength l); [Reflexivity | Intro; Reflexivity]].
-Qed.
-
-Lemma pos_Rl_P2 : (l:Rlist;x:R) (In x l)<->(EX i:nat | (lt i (Rlength l))/\x==(pos_Rl l i)).
-Intros; Induction l.
-Split; Intro; [Elim H | Elim H; Intros; Elim H0; Intros; Elim (lt_n_O ? H1)].
-Split; Intro.
-Elim H; Intro.
-Exists O; Split; [Simpl; Apply lt_O_Sn | Simpl; Apply H0].
-Elim Hrecl; Intros; Assert H3 := (H1 H0); Elim H3; Intros; Elim H4; Intros; Exists (S x0); Split; [Simpl; Apply lt_n_S; Assumption | Simpl; Assumption].
-Elim H; Intros; Elim H0; Intros; Elim (zerop x0); Intro.
-Rewrite a in H2; Simpl in H2; Left; Assumption.
-Right; Elim Hrecl; Intros; Apply H4; Assert H5 : (S (pred x0))=x0.
-Symmetry; Apply S_pred with O; Assumption.
-Exists (pred x0); Split; [Simpl in H1; Apply lt_S_n; Rewrite H5; Assumption | Rewrite <- H5 in H2; Simpl in H2; Assumption].
-Qed.
-
-Lemma Rlist_P1 : (l:Rlist;P:R->R->Prop) ((x:R)(In x l)->(EXT y:R | (P x y))) -> (EXT l':Rlist | (Rlength l)=(Rlength l')/\(i:nat) (lt i (Rlength l))->(P (pos_Rl l i) (pos_Rl l' i))).
-Intros; Induction l.
-Exists nil; Intros; Split; [Reflexivity | Intros; Simpl in H0; Elim (lt_n_O ? H0)].
-Assert H0 : (In r (cons r l)).
-Simpl; Left; Reflexivity.
-Assert H1 := (H ? H0); Assert H2 : (x:R)(In x l)->(EXT y:R | (P x y)).
-Intros; Apply H; Simpl; Right; Assumption.
-Assert H3 := (Hrecl H2); Elim H1; Intros; Elim H3; Intros; Exists (cons x x0); Intros; Elim H5; Clear H5; Intros; Split.
-Simpl; Rewrite H5; Reflexivity.
-Intros; Elim (zerop i); Intro.
-Rewrite a; Simpl; Assumption.
-Assert H8 : i=(S (pred i)).
-Apply S_pred with O; Assumption.
-Rewrite H8; Simpl; Apply H6; Simpl in H7; Apply lt_S_n; Rewrite <- H8; Assumption.
-Qed.
-
-Definition ordered_Rlist [l:Rlist] : Prop := (i:nat) (lt i (pred (Rlength l))) -> (Rle (pos_Rl l i) (pos_Rl l (S i))).
-
-Fixpoint insert [l:Rlist] : R->Rlist :=
-[x:R] Cases l of
-| nil => (cons x nil)
-| (cons a l') =>
- Cases (total_order_Rle a x) of
- | (leftT _) => (cons a (insert l' x))
- | (rightT _) => (cons x l)
- end
-end.
-
-Fixpoint cons_Rlist [l:Rlist] : Rlist->Rlist :=
-[k:Rlist] Cases l of
-| nil => k
-| (cons a l') => (cons a (cons_Rlist l' k)) end.
-
-Fixpoint cons_ORlist [k:Rlist] : Rlist->Rlist :=
-[l:Rlist] Cases k of
-| nil => l
-| (cons a k') => (cons_ORlist k' (insert l a))
-end.
-
-Fixpoint app_Rlist [l:Rlist] : (R->R)->Rlist :=
-[f:R->R] Cases l of
-| nil => nil
-| (cons a l') => (cons (f a) (app_Rlist l' f))
-end.
-
-Fixpoint mid_Rlist [l:Rlist] : R->Rlist :=
-[x:R] Cases l of
-| nil => nil
-| (cons a l') => (cons ``(x+a)/2`` (mid_Rlist l' a))
-end.
-
-Definition Rtail [l:Rlist] : Rlist :=
-Cases l of
-| nil => nil
-| (cons a l') => l'
-end.
-
-Definition FF [l:Rlist;f:R->R] : Rlist := 
-Cases l of
-| nil => nil
-| (cons a l') => (app_Rlist (mid_Rlist l' a) f)
-end.
-
-Lemma RList_P0 : (l:Rlist;a:R) ``(pos_Rl (insert l a) O) == a`` \/ ``(pos_Rl (insert l a) O) == (pos_Rl l O)``.
-Intros; Induction l; [Left; Reflexivity | Simpl; Case (total_order_Rle r a); Intro; [Right; Reflexivity | Left; Reflexivity]].
-Qed.
-
-Lemma RList_P1 : (l:Rlist;a:R) (ordered_Rlist l) -> (ordered_Rlist (insert l a)).
-Intros; Induction l.
-Simpl; Unfold ordered_Rlist; Intros; Simpl in H0; Elim (lt_n_O ? H0).
-Simpl; Case (total_order_Rle r a); Intro.
-Assert H1 : (ordered_Rlist l).
-Unfold ordered_Rlist; Unfold ordered_Rlist in H; Intros; Assert H1 : (lt (S i) (pred (Rlength (cons r l)))); [Simpl; Replace (Rlength l) with (S (pred (Rlength l))); [Apply lt_n_S; Assumption | Symmetry; Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H1 in H0; Simpl in H0; Elim (lt_n_O ? H0)] | Apply (H ? H1)].
-Assert H2 := (Hrecl H1); Unfold ordered_Rlist; Intros; Induction i.
-Simpl; Assert H3 := (RList_P0 l a); Elim H3; Intro.
-Rewrite H4; Assumption.
-Induction l; [Simpl; Assumption | Rewrite H4; Apply (H O); Simpl; Apply lt_O_Sn].
-Simpl; Apply H2; Simpl in H0; Apply lt_S_n; Replace (S (pred (Rlength (insert l a)))) with (Rlength (insert l a)); [Assumption | Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H3 in H0; Elim (lt_n_O ? H0)].
-Unfold ordered_Rlist; Intros; Induction i; [Simpl; Auto with real | Change ``(pos_Rl (cons r l) i)<=(pos_Rl (cons r l) (S i))``; Apply H; Simpl in H0; Simpl; Apply (lt_S_n ? ? H0)].
-Qed.
-
-Lemma RList_P2 : (l1,l2:Rlist) (ordered_Rlist l2) ->(ordered_Rlist (cons_ORlist l1 l2)).
-Induction l1; [Intros; Simpl; Apply H | Intros; Simpl; Apply H; Apply RList_P1; Assumption].
-Qed.
-
-Lemma RList_P3 : (l:Rlist;x:R) (In x l) <-> (EX i:nat | x==(pos_Rl l i)/\(lt i (Rlength l))).
-Intros; Split; Intro; Induction l.
-Elim H.
-Elim H; Intro; [Exists O; Split; [Apply H0 | Simpl; Apply lt_O_Sn] | Elim (Hrecl H0); Intros; Elim H1; Clear H1; Intros; Exists (S x0); Split; [Apply H1 | Simpl; Apply lt_n_S; Assumption]].
-Elim H; Intros; Elim H0; Intros; Elim (lt_n_O ? H2).
-Simpl; Elim H; Intros; Elim H0; Clear H0; Intros; Induction x0; [Left; Apply H0 | Right; Apply Hrecl; Exists x0; Split; [Apply H0 | Simpl in H1; Apply lt_S_n; Assumption]].
-Qed.
-
-Lemma RList_P4 : (l1:Rlist;a:R) (ordered_Rlist (cons a l1)) -> (ordered_Rlist l1).
-Intros; Unfold ordered_Rlist; Intros; Apply (H (S i)); Simpl; Replace (Rlength l1) with (S (pred (Rlength l1))); [Apply lt_n_S; Assumption | Symmetry; Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H1 in H0; Elim (lt_n_O ? H0)].
-Qed.
-
-Lemma RList_P5 : (l:Rlist;x:R) (ordered_Rlist l) -> (In x l) -> ``(pos_Rl l O)<=x``.
-Intros; Induction l; [Elim H0 | Simpl; Elim H0; Intro; [Rewrite H1; Right; Reflexivity | Apply Rle_trans with (pos_Rl l O); [Apply (H O); Simpl; Induction l; [Elim H1 | Simpl; Apply lt_O_Sn] | Apply Hrecl; [EApply RList_P4; Apply H | Assumption]]]].
-Qed.
-
-Lemma RList_P6 : (l:Rlist) (ordered_Rlist l)<->((i,j:nat)(le i j)->(lt j (Rlength l))->``(pos_Rl l i)<=(pos_Rl l j)``).
-Induction l; Split; Intro.
-Intros; Right; Reflexivity.
-Unfold ordered_Rlist; Intros; Simpl in H0; Elim (lt_n_O ? H0).
-Intros; Induction i; [Induction j; [Right; Reflexivity | Simpl; Apply Rle_trans with (pos_Rl r0 O); [Apply (H0 O); Simpl; Simpl in H2; Apply neq_O_lt; Red; Intro; Rewrite <- H3 in H2; Assert H4 := (lt_S_n ? ? H2); Elim (lt_n_O ? H4) | Elim H; Intros; Apply H3; [Apply RList_P4 with r; Assumption | Apply le_O_n | Simpl in H2; Apply lt_S_n; Assumption]]] | Induction j; [Elim (le_Sn_O ? H1) | Simpl; Elim H; Intros; Apply H3; [Apply RList_P4 with r; Assumption | Apply le_S_n; Assumption | Simpl in H2; Apply lt_S_n; Assumption]]].
-Unfold ordered_Rlist; Intros; Apply H0; [Apply le_n_Sn | Simpl; Simpl in H1; Apply lt_n_S; Assumption].
-Qed.
-
-Lemma RList_P7 : (l:Rlist;x:R) (ordered_Rlist l) -> (In x l) -> ``x<=(pos_Rl l (pred (Rlength l)))``.
-Intros; Assert H1 := (RList_P6 l); Elim H1; Intros H2 _; Assert H3 := (H2 H); Clear H1 H2; Assert H1 := (RList_P3 l x); Elim H1; Clear H1; Intros; Assert H4 := (H1 H0); Elim H4; Clear H4; Intros; Elim H4; Clear H4; Intros; Rewrite H4; Assert H6 : (Rlength l)=(S (pred (Rlength l))).
-Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H6 in H5; Elim (lt_n_O ? H5).
-Apply H3; [Rewrite H6 in H5; Apply lt_n_Sm_le; Assumption | Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H7 in H5; Elim (lt_n_O ? H5)].
-Qed.
-
-Lemma RList_P8 : (l:Rlist;a,x:R) (In x (insert l a)) <-> x==a\/(In x l).
-Induction l.
-Intros; Split; Intro; Simpl in H; Apply H.
-Intros; Split; Intro; [Simpl in H0; Generalize H0; Case (total_order_Rle r a); Intros; [Simpl in H1; Elim H1; Intro; [Right; Left; Assumption |Elim (H a x); Intros; Elim (H3 H2); Intro; [Left; Assumption | Right; Right; Assumption]] | Simpl in H1; Decompose [or] H1; [Left; Assumption | Right; Left; Assumption | Right; Right; Assumption]]  |  Simpl; Case (total_order_Rle r a); Intro; [Simpl in H0; Decompose [or] H0; [Right; Elim (H a x); Intros; Apply H3; Left | Left | Right; Elim (H a x); Intros; Apply H3; Right] | Simpl in H0; Decompose [or] H0; [Left | Right; Left | Right; Right]]; Assumption].
-Qed.
-
-Lemma RList_P9 : (l1,l2:Rlist;x:R) (In x (cons_ORlist l1 l2)) <-> (In x l1)\/(In x l2).
-Induction l1.
-Intros; Split; Intro; [Simpl in H; Right; Assumption | Simpl; Elim H; Intro; [Elim H0 | Assumption]].
-Intros; Split.
-Simpl; Intros; Elim (H (insert l2 r) x); Intros; Assert H3 := (H1 H0); Elim H3; Intro; [Left; Right; Assumption | Elim (RList_P8 l2 r x); Intros H5 _; Assert H6 := (H5 H4); Elim H6; Intro; [Left; Left; Assumption | Right; Assumption]].
-Intro; Simpl; Elim (H (insert l2 r) x); Intros _ H1; Apply H1; Elim H0; Intro; [Elim H2; Intro; [Right; Elim (RList_P8 l2 r x); Intros _ H4; Apply H4; Left; Assumption | Left; Assumption] | Right; Elim (RList_P8 l2 r x); Intros _ H3; Apply H3; Right; Assumption].
-Qed.
-
-Lemma RList_P10 : (l:Rlist;a:R) (Rlength (insert l a))==(S (Rlength l)).
-Intros; Induction l; [Reflexivity | Simpl; Case (total_order_Rle r a); Intro; [Simpl; Rewrite Hrecl; Reflexivity | Reflexivity]].
-Qed.
-
-Lemma RList_P11 : (l1,l2:Rlist) (Rlength (cons_ORlist l1 l2))=(plus (Rlength l1) (Rlength l2)).
-Induction l1; [Intro; Reflexivity | Intros; Simpl; Rewrite (H (insert l2 r)); Rewrite RList_P10; Apply INR_eq; Rewrite S_INR; Do 2 Rewrite plus_INR; Rewrite S_INR; Ring].
-Qed.
-
-Lemma RList_P12 : (l:Rlist;i:nat;f:R->R) (lt i (Rlength l)) -> (pos_Rl (app_Rlist l f) i)==(f (pos_Rl l i)).
-Induction l; [Intros; Elim (lt_n_O ? H) | Intros; Induction i; [Reflexivity | Simpl; Apply H; Apply lt_S_n; Apply H0]].
-Qed.
-
-Lemma RList_P13 : (l:Rlist;i:nat;a:R) (lt i (pred (Rlength l))) -> ``(pos_Rl (mid_Rlist l a) (S i)) == ((pos_Rl l i)+(pos_Rl l (S i)))/2``.
-Induction l.
-Intros; Simpl in H; Elim (lt_n_O ? H).
-Induction r0.
-Intros; Simpl in H0; Elim (lt_n_O ? H0).
-Intros; Simpl in H1; Induction i.
-Reflexivity.
-Change ``(pos_Rl (mid_Rlist (cons r1 r2) r) (S i)) == ((pos_Rl (cons r1 r2) i)+(pos_Rl (cons r1 r2) (S i)))/2``; Apply H0; Simpl; Apply lt_S_n; Assumption.
-Qed.
-
-Lemma RList_P14 : (l:Rlist;a:R) (Rlength (mid_Rlist l a))=(Rlength l).
-Induction l; Intros; [Reflexivity | Simpl; Rewrite (H r); Reflexivity].
-Qed.
-
-Lemma RList_P15 : (l1,l2:Rlist) (ordered_Rlist l1) -> (ordered_Rlist l2) -> (pos_Rl l1 O)==(pos_Rl l2 O) -> (pos_Rl (cons_ORlist l1 l2) O)==(pos_Rl l1 O).
-Intros; Apply Rle_antisym.
-Induction l1; [Simpl; Simpl in H1; Right; Symmetry; Assumption | Elim (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) (0))); Intros; Assert H4 : (In (pos_Rl (cons r l1) (0)) (cons r l1))\/(In (pos_Rl (cons r l1) (0)) l2); [Left; Left; Reflexivity | Assert H5 := (H3 H4); Apply RList_P5; [Apply RList_P2; Assumption | Assumption]]].
-Induction l1; [Simpl; Simpl in H1; Right; Assumption | Assert H2 : (In (pos_Rl (cons_ORlist (cons r l1) l2) (0)) (cons_ORlist (cons r l1) l2)); [Elim (RList_P3 (cons_ORlist (cons r l1) l2) (pos_Rl (cons_ORlist (cons r l1) l2) (0))); Intros; Apply H3; Exists O; Split; [Reflexivity | Rewrite RList_P11; Simpl; Apply lt_O_Sn] | Elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) (0))); Intros; Assert H5 := (H3 H2); Elim H5; Intro; [Apply RList_P5; Assumption | Rewrite H1; Apply RList_P5; Assumption]]].
-Qed.
-
-Lemma RList_P16 : (l1,l2:Rlist) (ordered_Rlist l1) -> (ordered_Rlist l2) -> (pos_Rl l1 (pred (Rlength l1)))==(pos_Rl l2 (pred (Rlength l2))) -> (pos_Rl (cons_ORlist l1 l2) (pred (Rlength (cons_ORlist l1 l2))))==(pos_Rl l1 (pred (Rlength l1))).
-Intros; Apply Rle_antisym.
-Induction l1.
-Simpl; Simpl in H1; Right; Symmetry; Assumption. 
-Assert H2 : (In (pos_Rl (cons_ORlist (cons r l1) l2) (pred (Rlength (cons_ORlist (cons r l1) l2)))) (cons_ORlist (cons r l1) l2)); [Elim (RList_P3 (cons_ORlist (cons r l1) l2) (pos_Rl (cons_ORlist (cons r l1) l2) (pred (Rlength (cons_ORlist (cons r l1) l2))))); Intros; Apply H3; Exists (pred (Rlength (cons_ORlist (cons r l1) l2))); Split; [Reflexivity | Rewrite RList_P11; Simpl; Apply lt_n_Sn] | Elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) (pred (Rlength (cons_ORlist (cons r l1) l2))))); Intros; Assert H5 := (H3 H2); Elim H5; Intro; [Apply RList_P7; Assumption | Rewrite H1; Apply RList_P7; Assumption]].
-Induction l1.
-Simpl; Simpl in H1; Right; Assumption.
-Elim (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); Intros; Assert H4 : (In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1))\/(In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2); [Left; Change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)); Elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); Intros; Apply H5; Exists (Rlength l1); Split; [Reflexivity | Simpl; Apply lt_n_Sn] | Assert H5 := (H3 H4); Apply RList_P7; [Apply RList_P2; Assumption | Elim (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); Intros; Apply H7; Left; Elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); Intros; Apply H9; Exists (pred (Rlength (cons r l1))); Split; [Reflexivity | Simpl; Apply lt_n_Sn]]].
-Qed.
-
-Lemma RList_P17 : (l1:Rlist;x:R;i:nat) (ordered_Rlist l1) -> (In x l1) -> ``(pos_Rl l1 i)<x`` -> (lt i (pred (Rlength l1))) -> ``(pos_Rl l1 (S i))<=x``.
-Induction l1.
-Intros; Elim H0.
-Intros; Induction i.
-Simpl; Elim H1; Intro; [Simpl in H2; Rewrite H4 in H2; Elim (Rlt_antirefl ? H2) | Apply RList_P5; [Apply RList_P4 with r; Assumption | Assumption]].
-Simpl; Simpl in H2; Elim H1; Intro.
-Rewrite H4 in H2; Assert H5 : ``r<=(pos_Rl r0 i)``; [Apply Rle_trans with (pos_Rl r0 O); [Apply (H0 O); Simpl; Simpl in H3; Apply neq_O_lt; Red; Intro; Rewrite <- H5 in H3; Elim (lt_n_O ? H3) | Elim (RList_P6 r0); Intros; Apply H5; [Apply RList_P4 with r; Assumption | Apply le_O_n | Simpl in H3; Apply lt_S_n; Apply lt_trans with (Rlength r0); [Apply H3 | Apply lt_n_Sn]]] | Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H5 H2))].
-Apply H; Try Assumption; [Apply RList_P4 with r; Assumption | Simpl in H3; Apply lt_S_n; Replace (S (pred (Rlength r0))) with (Rlength r0); [Apply H3 | Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H5 in H3; Elim (lt_n_O ? H3)]].
-Qed.
-
-Lemma RList_P18 : (l:Rlist;f:R->R) (Rlength (app_Rlist l f))=(Rlength l).
-Induction l; Intros; [Reflexivity | Simpl; Rewrite H; Reflexivity].
-Qed.
-
-Lemma RList_P19 : (l:Rlist) ~l==nil -> (EXT r:R | (EXT r0:Rlist | l==(cons r r0))).
-Intros; Induction l; [Elim H; Reflexivity | Exists r; Exists l; Reflexivity].
-Qed.
-
-Lemma RList_P20 : (l:Rlist) (le (2) (Rlength l)) -> (EXT r:R | (EXT r1:R | (EXT l':Rlist | l==(cons r (cons r1 l'))))). 
-Intros; Induction l; [Simpl in H; Elim (le_Sn_O ? H) | Induction l; [Simpl in H; Elim (le_Sn_O ? (le_S_n ? ? H)) | Exists r; Exists r0; Exists l; Reflexivity]].
-Qed.
-
-Lemma RList_P21 : (l,l':Rlist) l==l' -> (Rtail l)==(Rtail l').
-Intros; Rewrite H; Reflexivity.
-Qed.
-
-Lemma RList_P22 : (l1,l2:Rlist) ~l1==nil -> (pos_Rl (cons_Rlist l1 l2) O)==(pos_Rl l1 O).
-Induction l1; [Intros; Elim H; Reflexivity | Intros; Reflexivity].
-Qed.
-
-Lemma RList_P23 : (l1,l2:Rlist) (Rlength (cons_Rlist l1 l2))==(plus (Rlength l1) (Rlength l2)).
-Induction l1; [Intro; Reflexivity | Intros; Simpl; Rewrite H; Reflexivity].
-Qed.
-
-Lemma RList_P24 : (l1,l2:Rlist) ~l2==nil -> (pos_Rl (cons_Rlist l1 l2) (pred (Rlength (cons_Rlist l1 l2)))) == (pos_Rl l2 (pred (Rlength l2))).
-Induction l1.
-Intros; Reflexivity.
-Intros; Rewrite <- (H l2 H0); Induction l2.
-Elim H0; Reflexivity.
-Do 2 Rewrite RList_P23; Replace (plus (Rlength (cons r r0)) (Rlength (cons r1 l2))) with (S (S (plus (Rlength r0) (Rlength l2)))); [Replace (plus (Rlength r0) (Rlength (cons r1 l2))) with (S (plus (Rlength r0) (Rlength l2))); [Reflexivity | Simpl; Apply INR_eq; Rewrite S_INR; Do 2 Rewrite plus_INR; Rewrite S_INR; Ring] | Simpl; Apply INR_eq; Do 3 Rewrite S_INR; Do 2 Rewrite plus_INR; Rewrite S_INR; Ring].
-Qed.
-
-Lemma RList_P25 : (l1,l2:Rlist) (ordered_Rlist l1) -> (ordered_Rlist l2) -> ``(pos_Rl l1 (pred (Rlength l1)))<=(pos_Rl l2 O)`` -> (ordered_Rlist (cons_Rlist l1 l2)).
-Induction l1.
-Intros; Simpl; Assumption.
-Induction r0.
-Intros; Simpl; Simpl in H2; Unfold ordered_Rlist; Intros; Simpl in H3.
-Induction i.
-Simpl; Assumption.
-Change ``(pos_Rl l2 i)<=(pos_Rl l2 (S i))``; Apply (H1 i); Apply lt_S_n; Replace (S (pred (Rlength l2))) with (Rlength l2); [Assumption | Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H4 in H3; Elim (lt_n_O ? H3)].
-Intros; Clear H; Assert H : (ordered_Rlist (cons_Rlist (cons r1 r2) l2)).
-Apply H0; Try Assumption.
-Apply RList_P4 with r; Assumption.
-Unfold ordered_Rlist; Intros; Simpl in H4; Induction i.
-Simpl; Apply (H1 O); Simpl; Apply lt_O_Sn.
-Change ``(pos_Rl (cons_Rlist (cons r1 r2) l2) i)<=(pos_Rl (cons_Rlist (cons r1 r2) l2) (S i))``; Apply (H i); Simpl; Apply lt_S_n; Assumption.
-Qed.
-
-Lemma RList_P26 : (l1,l2:Rlist;i:nat) (lt i (Rlength l1)) -> (pos_Rl (cons_Rlist l1 l2) i)==(pos_Rl l1 i).
-Induction l1.
-Intros; Elim (lt_n_O ? H).
-Intros; Induction i.
-Apply RList_P22; Discriminate.
-Apply (H l2 i); Simpl in H0; Apply lt_S_n; Assumption.
-Qed.
-
-Lemma RList_P27 : (l1,l2,l3:Rlist) (cons_Rlist l1 (cons_Rlist l2 l3))==(cons_Rlist (cons_Rlist l1 l2) l3).
-Induction l1; Intros; [Reflexivity | Simpl; Rewrite (H l2 l3); Reflexivity].
-Qed.
-
-Lemma RList_P28 : (l:Rlist) (cons_Rlist l nil)==l.
-Induction l; [Reflexivity | Intros; Simpl; Rewrite H; Reflexivity].
-Qed.
-
-Lemma RList_P29 : (l2,l1:Rlist;i:nat) (le (Rlength l1) i) -> (lt i (Rlength (cons_Rlist l1 l2))) -> (pos_Rl (cons_Rlist l1 l2) i)==(pos_Rl l2 (minus i (Rlength l1))).
-Induction l2.
-Intros; Rewrite RList_P28 in H0; Elim (lt_n_n ? (le_lt_trans ? ? ? H H0)).
-Intros; Replace (cons_Rlist l1 (cons r r0)) with (cons_Rlist (cons_Rlist l1 (cons r nil)) r0).
-Inversion H0.
-Rewrite <- minus_n_n; Simpl; Rewrite RList_P26.
-Clear l2 r0 H i H0 H1 H2; Induction l1.
-Reflexivity.
-Simpl; Assumption.
-Rewrite RList_P23; Rewrite plus_sym; Simpl; Apply lt_n_Sn.
-Replace (minus (S m) (Rlength l1)) with (S (minus (S m) (S (Rlength l1)))).
-Rewrite H3; Simpl; Replace (S (Rlength l1)) with (Rlength (cons_Rlist l1 (cons r nil))).
-Apply (H (cons_Rlist l1 (cons r nil)) i).
-Rewrite RList_P23; Rewrite plus_sym; Simpl; Rewrite <- H3; Apply le_n_S; Assumption.
-Repeat Rewrite RList_P23; Simpl; Rewrite RList_P23 in H1; Rewrite plus_sym in H1; Simpl in H1; Rewrite (plus_sym (Rlength l1)); Simpl; Rewrite plus_sym; Apply H1.
-Rewrite RList_P23; Rewrite plus_sym; Reflexivity.
-Change (S (minus m (Rlength l1)))=(minus (S m) (Rlength l1)); Apply minus_Sn_m; Assumption.
-Replace (cons r r0) with (cons_Rlist (cons r nil) r0); [Symmetry; Apply RList_P27 | Reflexivity].
-Qed.
diff --git a/theories7/Reals/R_Ifp.v b/theories7/Reals/R_Ifp.v
deleted file mode 100644
index 621cca64..00000000
--- a/theories7/Reals/R_Ifp.v
+++ /dev/null
@@ -1,552 +0,0 @@
-(************************************************************************)
-(*  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: R_Ifp.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-(**********************************************************)
-(** Complements for the reals.Integer and fractional part *)
-(*                                                        *)
-(**********************************************************)
-
-Require Rbase.
-Require Omega.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(*********************************************************)
-(**      Fractional part                                 *)
-(*********************************************************)
-
-(**********)
-Definition Int_part:R->Z:=[r:R](`(up r)-1`).
-
-(**********)
-Definition frac_part:R->R:=[r:R](Rminus r (IZR (Int_part r))).
-
-(**********)
-Lemma tech_up:(r:R)(z:Z)(Rlt r (IZR z))->(Rle (IZR z) (Rplus r R1))->
-  z=(up r).
-Intros;Generalize (archimed r);Intro;Elim H1;Intros;Clear H1;
- Unfold Rgt in H2;Unfold Rminus in H3;
-Generalize (Rle_compatibility r (Rplus (IZR (up r)) 
- (Ropp r)) R1 H3);Intro;Clear H3;
- Rewrite (Rplus_sym (IZR (up r)) (Ropp r)) in H1;
- Rewrite <-(Rplus_assoc r (Ropp r) (IZR (up r))) in H1;
- Rewrite (Rplus_Ropp_r r) in H1;Elim (Rplus_ne (IZR (up r)));Intros a b;
- Rewrite b in H1;Clear a b;Apply (single_z_r_R1 r z (up r));Auto with zarith real.
-Qed.
-
-(**********)
-Lemma up_tech:(r:R)(z:Z)(Rle (IZR z) r)->(Rlt r (IZR `z+1`))->
-  `z+1`=(up r).
-Intros;Generalize (Rle_compatibility R1 (IZR z) r H);Intro;Clear H;
- Rewrite (Rplus_sym R1 (IZR z)) in H1;Rewrite (Rplus_sym R1 r) in H1;
- Cut (R1==(IZR `1`));Auto with zarith real.
-Intro;Generalize H1;Pattern 1 R1;Rewrite H;Intro;Clear H H1;
- Rewrite <-(plus_IZR z `1`) in H2;Apply (tech_up r `z+1`);Auto with zarith real.
-Qed.
-
-(**********)
-Lemma fp_R0:(frac_part R0)==R0.
-Unfold frac_part; Unfold Int_part; Elim (archimed R0);
- Intros; Unfold Rminus;
- Elim (Rplus_ne (Ropp (IZR `(up R0)-1`))); Intros a b;
- Rewrite b;Clear a b;Rewrite <- Z_R_minus;Cut (up R0)=`1`.
-Intro;Rewrite H1;
- Rewrite (eq_Rminus (IZR `1`) (IZR `1`) (refl_eqT R (IZR `1`)));
- Apply Ropp_O. 
-Elim (archimed R0);Intros;Clear H2;Unfold Rgt in H1;
- Rewrite (minus_R0 (IZR (up R0))) in H0;
- Generalize (lt_O_IZR (up R0) H1);Intro;Clear H1;
- Generalize (le_IZR_R1 (up R0) H0);Intro;Clear H H0;Omega.
-Qed.
-
-(**********)
-Lemma for_base_fp:(r:R)(Rgt (Rminus (IZR (up r)) r) R0)/\ 
-                       (Rle (Rminus (IZR (up r)) r) R1).
-Intro; Split;
- Cut (Rgt (IZR (up r)) r)/\(Rle (Rminus (IZR (up r)) r) R1).
-Intro; Elim H; Intros.
-Apply (Rgt_minus (IZR (up r)) r H0).
-Apply archimed.
-Intro; Elim H; Intros.
-Exact H1.
-Apply archimed.
-Qed.
-
-(**********)
-Lemma base_fp:(r:R)(Rge (frac_part r) R0)/\(Rlt (frac_part r) R1).
-Intro; Unfold frac_part; Unfold Int_part; Split.
-     (*sup a O*)
-Cut (Rge (Rminus r (IZR (up r))) (Ropp R1)).
-Rewrite <- Z_R_minus;Simpl;Intro; Unfold Rminus;
- Rewrite Ropp_distr1;Rewrite <-Rplus_assoc;
- Fold (Rminus r (IZR (up r)));
- Fold (Rminus (Rminus r (IZR (up r))) (Ropp R1));
- Apply Rge_minus;Auto with zarith real.
-Rewrite <- Ropp_distr2;Apply Rle_Ropp;Elim (for_base_fp r); Auto with zarith real.
-    (*inf a 1*) 
-Cut (Rlt (Rminus r (IZR (up r))) R0).
-Rewrite <- Z_R_minus; Simpl;Intro; Unfold Rminus;
- Rewrite Ropp_distr1;Rewrite <-Rplus_assoc;
- Fold (Rminus r (IZR (up r)));Rewrite Ropp_Ropp;
- Elim (Rplus_ne R1);Intros a b;Pattern 2 R1;Rewrite <-a;Clear a b;
- Rewrite (Rplus_sym  (Rminus r (IZR (up r))) R1);
- Apply Rlt_compatibility;Auto with zarith real.
-Elim (for_base_fp r);Intros;Rewrite <-Ropp_O;
- Rewrite<-Ropp_distr2;Apply Rgt_Ropp;Auto with zarith real.
-Qed.
-
-(*********************************************************)
-(**      Properties                                      *)
-(*********************************************************)
-
-(**********)
-Lemma base_Int_part:(r:R)(Rle (IZR (Int_part r)) r)/\
-                    (Rgt (Rminus (IZR (Int_part r)) r) (Ropp R1)). 
-Intro;Unfold Int_part;Elim (archimed r);Intros.
-Split;Rewrite <- (Z_R_minus (up r) `1`);Simpl.
-Generalize (Rle_minus (Rminus (IZR (up r)) r) R1 H0);Intro;
- Unfold Rminus in H1;
- Rewrite (Rplus_assoc (IZR (up r)) (Ropp r) (Ropp R1)) in 
- H1;Rewrite (Rplus_sym (Ropp r) (Ropp R1)) in H1;
- Rewrite <-(Rplus_assoc (IZR (up r)) (Ropp R1) (Ropp r)) in
- H1;Fold (Rminus (IZR (up r)) R1) in H1;
- Fold (Rminus (Rminus (IZR (up r)) R1) r) in H1;
- Apply Rminus_le;Auto with zarith real.
-Generalize (Rgt_plus_plus_r (Ropp R1) (IZR (up r)) r H);Intro;
- Rewrite (Rplus_sym (Ropp R1) (IZR (up r))) in H1;
- Generalize (Rgt_plus_plus_r (Ropp r) 
-   (Rplus (IZR (up r)) (Ropp R1)) (Rplus (Ropp R1) r) H1);
- Intro;Clear H H0 H1;
- Rewrite (Rplus_sym (Ropp r) (Rplus (IZR (up r)) (Ropp R1)))
- in H2;Fold (Rminus (IZR (up r)) R1) in H2;
- Fold (Rminus (Rminus (IZR (up r)) R1) r) in H2;
- Rewrite (Rplus_sym (Ropp r) (Rplus (Ropp R1) r)) in H2;
- Rewrite (Rplus_assoc (Ropp R1) r (Ropp r)) in H2;
- Rewrite (Rplus_Ropp_r r) in H2;Elim (Rplus_ne (Ropp R1));Intros a b;
- Rewrite a in H2;Clear a b;Auto with zarith real.  
-Qed.
-
-(**********)
-Lemma Int_part_INR:(n : nat)  (Int_part (INR n)) = (inject_nat n).
-Intros n; Unfold Int_part.
-Cut (up (INR n)) = (Zplus (inject_nat n) (inject_nat (1))).
-Intros H'; Rewrite H'; Simpl; Ring.
-Apply sym_equal; Apply tech_up; Auto.
-Replace (Zplus (inject_nat n) (inject_nat (1))) with (INZ (S n)).
-Repeat Rewrite <- INR_IZR_INZ.
-Apply lt_INR; Auto.
-Rewrite Zplus_sym; Rewrite <- inj_plus; Simpl; Auto.
-Rewrite plus_IZR; Simpl; Auto with real.
-Repeat Rewrite <- INR_IZR_INZ; Auto with real.
-Qed.
-
-(**********)
-Lemma fp_nat:(r:R)(frac_part r)==R0->(Ex [c:Z](r==(IZR c))).
-Unfold frac_part;Intros;Split with (Int_part r);Apply Rminus_eq; Auto with zarith real.
-Qed.
-
-(**********)
-Lemma R0_fp_O:(r:R)~R0==(frac_part r)->~R0==r.
-Red;Intros;Rewrite <- H0 in H;Generalize fp_R0;Intro;Auto with zarith real.
-Qed.
-
-(**********)
-Lemma Rminus_Int_part1:(r1,r2:R)(Rge (frac_part r1) (frac_part r2))->
-  (Int_part (Rminus r1 r2))=(Zminus (Int_part r1) (Int_part r2)).
-Intros;Elim (base_fp r1);Elim (base_fp r2);Intros;
- Generalize (Rle_sym2 R0 (frac_part r2) H0);Intro;Clear H0;
- Generalize (Rle_Ropp R0 (frac_part r2) H4);Intro;Clear H4;
- Rewrite (Ropp_O) in H0;
- Generalize (Rle_sym2 (Ropp (frac_part r2)) R0 H0);Intro;Clear H0;
- Generalize (Rle_sym2 R0 (frac_part r1) H2);Intro;Clear H2;
- Generalize (Rlt_Ropp (frac_part r2) R1 H1);Intro;Clear H1;
- Unfold Rgt in H2;
- Generalize (sum_inequa_Rle_lt R0 (frac_part r1) R1 (Ropp R1)
-   (Ropp (frac_part r2)) R0 H0 H3 H2 H4);Intro;Elim H1;Intros;
- Clear H1;Elim (Rplus_ne R1);Intros a b;Rewrite a in H6;Clear a b H5;
- Generalize (Rge_minus (frac_part r1) (frac_part r2) H);Intro;Clear H;
- Fold (Rminus (frac_part r1) (frac_part r2)) in H6;
- Generalize (Rle_sym2 R0 (Rminus (frac_part r1) (frac_part r2)) H1);
- Intro;Clear H1 H3 H4 H0 H2;Unfold frac_part in H6 H;
- Unfold Rminus in H6 H;
- Rewrite (Ropp_distr1 r2 (Ropp (IZR (Int_part r2)))) in H;
- Rewrite (Ropp_Ropp (IZR (Int_part r2))) in H;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus (Ropp r2) (IZR (Int_part r2)))) in H;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp r2)
-  (IZR (Int_part r2))) in H;
- Rewrite (Rplus_sym (Ropp (IZR (Int_part r1))) (Ropp r2)) in H;
- Rewrite (Rplus_assoc (Ropp r2) (Ropp (IZR (Int_part r1)))
-  (IZR (Int_part r2))) in H;
- Rewrite <-(Rplus_assoc r1 (Ropp r2) 
-  (Rplus (Ropp (IZR (Int_part r1))) (IZR (Int_part r2)))) in H;
- Rewrite (Rplus_sym (Ropp (IZR (Int_part r1))) (IZR (Int_part r2))) in H;
- Fold (Rminus r1 r2) in H;Fold (Rminus (IZR (Int_part r2)) (IZR (Int_part r1))) 
- in H;Generalize (Rle_compatibility 
-  (Rminus (IZR (Int_part r1)) (IZR (Int_part r2))) R0 
-  (Rplus (Rminus r1 r2) (Rminus (IZR (Int_part r2)) (IZR (Int_part r1)))) H);Intro;
- Clear H;Rewrite (Rplus_sym (Rminus r1 r2)
-  (Rminus (IZR (Int_part r2)) (IZR (Int_part r1)))) in H0;
- Rewrite <-(Rplus_assoc (Rminus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Rminus (IZR (Int_part r2)) (IZR (Int_part r1))) (Rminus r1 r2)) in H0;
- Unfold Rminus in H0;Fold (Rminus r1 r2) in H0;
- Rewrite (Rplus_assoc (IZR (Int_part r1)) (Ropp (IZR (Int_part r2))) 
-  (Rplus (IZR (Int_part r2)) (Ropp (IZR (Int_part r1))))) in H0;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r2))) (IZR (Int_part r2))
-  (Ropp (IZR (Int_part r1)))) in H0;Rewrite (Rplus_Ropp_l (IZR (Int_part r2))) in 
- H0;Elim (Rplus_ne (Ropp (IZR (Int_part r1))));Intros a b;Rewrite b in H0;
- Clear a b;
- Elim (Rplus_ne (Rplus (IZR (Int_part r1)) (Ropp (IZR (Int_part r2)))));
- Intros a b;Rewrite a in H0;Clear a b;Rewrite (Rplus_Ropp_r (IZR (Int_part r1))) 
- in H0;Elim (Rplus_ne (Rminus r1 r2));Intros a b;Rewrite b in H0;
- Clear a b;Fold (Rminus (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
- Rewrite (Ropp_distr1 r2 (Ropp (IZR (Int_part r2)))) in H6;
- Rewrite (Ropp_Ropp (IZR (Int_part r2))) in H6;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus (Ropp r2) (IZR (Int_part r2)))) in H6;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp r2)
-  (IZR (Int_part r2))) in H6;
- Rewrite (Rplus_sym (Ropp (IZR (Int_part r1))) (Ropp r2)) in H6;
- Rewrite (Rplus_assoc (Ropp r2) (Ropp (IZR (Int_part r1)))
-  (IZR (Int_part r2))) in H6;
- Rewrite <-(Rplus_assoc r1 (Ropp r2) 
-  (Rplus (Ropp (IZR (Int_part r1))) (IZR (Int_part r2)))) in H6;
- Rewrite (Rplus_sym (Ropp (IZR (Int_part r1))) (IZR (Int_part r2))) in H6;
- Fold (Rminus r1 r2) in H6;Fold (Rminus (IZR (Int_part r2)) (IZR (Int_part r1))) 
- in H6;Generalize (Rlt_compatibility 
-   (Rminus (IZR (Int_part r1)) (IZR (Int_part r2))) 
-   (Rplus (Rminus r1 r2) (Rminus (IZR (Int_part r2)) (IZR (Int_part r1)))) R1 H6);
- Intro;Clear H6;
- Rewrite (Rplus_sym (Rminus r1 r2)
-  (Rminus (IZR (Int_part r2)) (IZR (Int_part r1)))) in H;
- Rewrite <-(Rplus_assoc (Rminus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Rminus (IZR (Int_part r2)) (IZR (Int_part r1))) (Rminus r1 r2)) in H;
- Rewrite <-(Ropp_distr2 (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
- Rewrite (Rplus_Ropp_r (Rminus (IZR (Int_part r1)) (IZR (Int_part r2)))) in H;
- Elim (Rplus_ne (Rminus r1 r2));Intros a b;Rewrite b in H;Clear a b;
- Rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
- Rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
- Cut R1==(IZR `1`);Auto with zarith real.
-Intro;Rewrite H1 in H;Clear H1;
- Rewrite <-(plus_IZR `(Int_part r1)-(Int_part r2)` `1`) in H;
- Generalize (up_tech  (Rminus r1 r2) `(Int_part r1)-(Int_part r2)`
-  H0 H);Intros;Clear H H0;Unfold 1 Int_part;Omega.
-Qed.
-
-(**********)
-Lemma Rminus_Int_part2:(r1,r2:R)(Rlt (frac_part r1) (frac_part r2))->
-  (Int_part (Rminus r1 r2))=(Zminus (Zminus (Int_part r1) (Int_part r2)) `1`).
-Intros;Elim (base_fp r1);Elim (base_fp r2);Intros;
- Generalize (Rle_sym2 R0 (frac_part r2) H0);Intro;Clear H0;
- Generalize (Rle_Ropp R0 (frac_part r2) H4);Intro;Clear H4;
- Rewrite (Ropp_O) in H0;
- Generalize (Rle_sym2 (Ropp (frac_part r2)) R0 H0);Intro;Clear H0;
- Generalize (Rle_sym2 R0 (frac_part r1) H2);Intro;Clear H2;
- Generalize (Rlt_Ropp (frac_part r2) R1 H1);Intro;Clear H1;
- Unfold Rgt in H2;
- Generalize (sum_inequa_Rle_lt R0 (frac_part r1) R1 (Ropp R1)
-   (Ropp (frac_part r2)) R0 H0 H3 H2 H4);Intro;Elim H1;Intros;
- Clear H1;Elim (Rplus_ne (Ropp R1));Intros a b;Rewrite b in H5;
- Clear a b H6;Generalize (Rlt_minus (frac_part r1) (frac_part r2) H);
- Intro;Clear H;Fold (Rminus (frac_part r1) (frac_part r2)) in H5;
- Clear H3 H4 H0 H2;Unfold frac_part in H5 H1;
- Unfold Rminus in H5 H1;
- Rewrite (Ropp_distr1 r2 (Ropp (IZR (Int_part r2)))) in H5;
- Rewrite (Ropp_Ropp (IZR (Int_part r2))) in H5;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus (Ropp r2) (IZR (Int_part r2)))) in H5;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp r2)
-  (IZR (Int_part r2))) in H5;
- Rewrite (Rplus_sym (Ropp (IZR (Int_part r1))) (Ropp r2)) in H5;
- Rewrite (Rplus_assoc (Ropp r2) (Ropp (IZR (Int_part r1)))
-  (IZR (Int_part r2))) in H5;
- Rewrite <-(Rplus_assoc r1 (Ropp r2) 
-  (Rplus (Ropp (IZR (Int_part r1))) (IZR (Int_part r2)))) in H5;
- Rewrite (Rplus_sym (Ropp (IZR (Int_part r1))) (IZR (Int_part r2))) in H5;
- Fold (Rminus r1 r2) in H5;Fold (Rminus (IZR (Int_part r2)) (IZR (Int_part r1))) 
- in H5;Generalize (Rlt_compatibility 
-  (Rminus (IZR (Int_part r1)) (IZR (Int_part r2))) (Ropp R1) 
-  (Rplus (Rminus r1 r2) (Rminus (IZR (Int_part r2)) (IZR (Int_part r1)))) H5);
- Intro;Clear H5;Rewrite (Rplus_sym (Rminus r1 r2)
-  (Rminus (IZR (Int_part r2)) (IZR (Int_part r1)))) in H;
- Rewrite <-(Rplus_assoc (Rminus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Rminus (IZR (Int_part r2)) (IZR (Int_part r1))) (Rminus r1 r2)) in H;
- Unfold Rminus in H;Fold (Rminus r1 r2) in H;
- Rewrite (Rplus_assoc (IZR (Int_part r1)) (Ropp (IZR (Int_part r2))) 
-  (Rplus (IZR (Int_part r2)) (Ropp (IZR (Int_part r1))))) in H;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r2))) (IZR (Int_part r2))
-  (Ropp (IZR (Int_part r1)))) in H;Rewrite (Rplus_Ropp_l (IZR (Int_part r2))) in 
- H;Elim (Rplus_ne (Ropp (IZR (Int_part r1))));Intros a b;Rewrite b in H;
- Clear a b;Rewrite (Rplus_Ropp_r (IZR (Int_part r1))) in H;
- Elim (Rplus_ne (Rminus r1 r2));Intros a b;Rewrite b in H;
- Clear a b;Fold (Rminus (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
- Fold (Rminus (Rminus (IZR (Int_part r1)) (IZR (Int_part r2))) R1) in H;
- Rewrite (Ropp_distr1 r2 (Ropp (IZR (Int_part r2)))) in H1;
- Rewrite (Ropp_Ropp (IZR (Int_part r2))) in H1;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus (Ropp r2) (IZR (Int_part r2)))) in H1;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp r2)
-  (IZR (Int_part r2))) in H1;
- Rewrite (Rplus_sym (Ropp (IZR (Int_part r1))) (Ropp r2)) in H1;
- Rewrite (Rplus_assoc (Ropp r2) (Ropp (IZR (Int_part r1)))
-  (IZR (Int_part r2))) in H1;
- Rewrite <-(Rplus_assoc r1 (Ropp r2) 
-  (Rplus (Ropp (IZR (Int_part r1))) (IZR (Int_part r2)))) in H1;
- Rewrite (Rplus_sym (Ropp (IZR (Int_part r1))) (IZR (Int_part r2))) in H1;
- Fold (Rminus r1 r2) in H1;Fold (Rminus (IZR (Int_part r2)) (IZR (Int_part r1))) 
- in H1;Generalize (Rlt_compatibility 
-   (Rminus (IZR (Int_part r1)) (IZR (Int_part r2))) 
-   (Rplus (Rminus r1 r2) (Rminus (IZR (Int_part r2)) (IZR (Int_part r1)))) R0 H1);
- Intro;Clear H1;
- Rewrite (Rplus_sym (Rminus r1 r2)
-  (Rminus (IZR (Int_part r2)) (IZR (Int_part r1)))) in H0;
- Rewrite <-(Rplus_assoc (Rminus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Rminus (IZR (Int_part r2)) (IZR (Int_part r1))) (Rminus r1 r2)) in H0;
- Rewrite <-(Ropp_distr2 (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
- Rewrite (Rplus_Ropp_r (Rminus (IZR (Int_part r1)) (IZR (Int_part r2)))) in H0;
- Elim (Rplus_ne (Rminus r1 r2));Intros a b;Rewrite b in H0;Clear a b;
- Rewrite <-(Rplus_Ropp_l R1) in H0;
- Rewrite <-(Rplus_assoc (Rminus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Ropp R1) R1) in H0;
- Fold (Rminus (Rminus (IZR (Int_part r1)) (IZR (Int_part r2))) R1) in H0;
- Rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0;
- Rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H;
- Cut R1==(IZR `1`);Auto with zarith real.
-Intro;Rewrite H1 in H;Rewrite H1 in H0;Clear H1;
- Rewrite (Z_R_minus `(Int_part r1)-(Int_part r2)` `1`) in H;
- Rewrite (Z_R_minus `(Int_part r1)-(Int_part r2)` `1`) in H0;
- Rewrite <-(plus_IZR `(Int_part r1)-(Int_part r2)-1` `1`) in H0;
- Generalize (Rlt_le (IZR `(Int_part r1)-(Int_part r2)-1`) (Rminus r1 r2) H);
- Intro;Clear H;
- Generalize (up_tech  (Rminus r1 r2) `(Int_part r1)-(Int_part r2)-1`
-  H1 H0);Intros;Clear H0 H1;Unfold 1 Int_part;Omega.
-Qed.
-
-(**********)
-Lemma Rminus_fp1:(r1,r2:R)(Rge (frac_part r1) (frac_part r2))->
-  (frac_part (Rminus r1 r2))==(Rminus (frac_part r1) (frac_part r2)).
-Intros;Unfold frac_part;
- Generalize (Rminus_Int_part1 r1 r2 H);Intro;Rewrite -> H0;
- Rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));Unfold Rminus;
- Rewrite -> (Ropp_distr1 (IZR (Int_part r1)) (Ropp (IZR (Int_part r2))));
- Rewrite -> (Ropp_distr1 r2 (Ropp (IZR (Int_part r2))));
- Rewrite -> (Ropp_Ropp (IZR (Int_part r2)));
- Rewrite -> (Rplus_assoc r1 (Ropp r2)
-             (Rplus (Ropp (IZR (Int_part r1))) (IZR (Int_part r2))));
- Rewrite -> (Rplus_assoc r1 (Ropp (IZR (Int_part r1)))
-             (Rplus (Ropp r2) (IZR (Int_part r2))));
- Rewrite <- (Rplus_assoc (Ropp r2) (Ropp (IZR (Int_part r1)))
-             (IZR (Int_part r2)));
- Rewrite <- (Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp r2)
-             (IZR (Int_part r2)));
- Rewrite -> (Rplus_sym (Ropp r2) (Ropp (IZR (Int_part r1))));Auto with zarith real.
-Qed.
-
-(**********)
-Lemma Rminus_fp2:(r1,r2:R)(Rlt (frac_part r1) (frac_part r2))->
-  (frac_part (Rminus r1 r2))==
-  (Rplus (Rminus (frac_part r1) (frac_part r2)) R1).
-Intros;Unfold frac_part;Generalize (Rminus_Int_part2 r1 r2 H);Intro;
- Rewrite -> H0;
- Rewrite <- (Z_R_minus (Zminus (Int_part r1) (Int_part r2)) `1`);
- Rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));Unfold Rminus;
- Rewrite -> (Ropp_distr1 (Rplus (IZR (Int_part r1)) (Ropp (IZR (Int_part r2))))
-             (Ropp (IZR `1`)));
- Rewrite -> (Ropp_distr1 r2 (Ropp (IZR (Int_part r2))));
- Rewrite -> (Ropp_Ropp (IZR `1`));
- Rewrite -> (Ropp_Ropp (IZR (Int_part r2)));
- Rewrite -> (Ropp_distr1 (IZR (Int_part r1)));
- Rewrite -> (Ropp_Ropp (IZR (Int_part r2)));Simpl;
- Rewrite <- (Rplus_assoc (Rplus r1 (Ropp r2))
-             (Rplus (Ropp (IZR (Int_part r1))) (IZR (Int_part r2))) R1);
- Rewrite -> (Rplus_assoc r1 (Ropp r2)
-             (Rplus (Ropp (IZR (Int_part r1))) (IZR (Int_part r2))));
- Rewrite -> (Rplus_assoc r1 (Ropp (IZR (Int_part r1)))
-             (Rplus (Ropp r2) (IZR (Int_part r2)))); 
- Rewrite <- (Rplus_assoc (Ropp r2) (Ropp (IZR (Int_part r1)))
-             (IZR (Int_part r2)));
- Rewrite <- (Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp r2)
-             (IZR (Int_part r2)));
- Rewrite -> (Rplus_sym (Ropp r2) (Ropp (IZR (Int_part r1))));Auto with zarith real.
-Qed.
-
-(**********)
-Lemma plus_Int_part1:(r1,r2:R)(Rge (Rplus (frac_part r1) (frac_part r2)) R1)->
-  (Int_part (Rplus r1 r2))=(Zplus (Zplus (Int_part r1) (Int_part r2)) `1`).
-Intros;
- Generalize (Rle_sym2 R1 (Rplus (frac_part r1) (frac_part r2)) H);
- Intro;Clear H;Elim (base_fp r1);Elim (base_fp r2);Intros;Clear H H2;
- Generalize (Rlt_compatibility (frac_part r2) (frac_part r1) R1 H3);
- Intro;Clear H3;
- Generalize (Rlt_compatibility R1 (frac_part r2) R1 H1);Intro;Clear H1;
- Rewrite (Rplus_sym R1 (frac_part r2)) in H2;
- Generalize (Rlt_trans (Rplus (frac_part r2) (frac_part r1))
-  (Rplus (frac_part r2) R1) (Rplus R1 R1) H H2);Intro;Clear H H2;
- Rewrite (Rplus_sym (frac_part r2) (frac_part r1)) in H1;
- Unfold frac_part in H0 H1;Unfold Rminus in H0 H1;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus r2 (Ropp (IZR (Int_part r2))))) in H1;
- Rewrite (Rplus_sym r2 (Ropp (IZR (Int_part r2)))) in H1;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))
-  r2) in H1;
- Rewrite (Rplus_sym 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))) r2) in H1;
- Rewrite <-(Rplus_assoc r1 r2 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2))))) in H1;
- Rewrite <-(Ropp_distr1 (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus r2 (Ropp (IZR (Int_part r2))))) in H0;
- Rewrite (Rplus_sym r2 (Ropp (IZR (Int_part r2)))) in H0;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))
-  r2) in H0;
- Rewrite (Rplus_sym 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))) r2) in H0;
- Rewrite <-(Rplus_assoc r1 r2 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2))))) in H0;
- Rewrite <-(Ropp_distr1 (IZR (Int_part r1)) (IZR (Int_part r2))) in H0;
- Generalize (Rle_compatibility (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  R1 (Rplus (Rplus r1 r2)
-           (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))) H0);Intro;
- Clear H0;
- Generalize (Rlt_compatibility (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Rplus (Rplus r1 r2)
-   (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))) (Rplus R1 R1) H1);
- Intro;Clear H1;
- Rewrite (Rplus_sym (Rplus r1 r2) 
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))) in H;
- Rewrite <-(Rplus_assoc (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))) (Rplus r1 r2)) in H;
- Rewrite (Rplus_Ropp_r (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))) in H;
- Elim (Rplus_ne (Rplus r1 r2));Intros a b;Rewrite b in H;Clear a b;
- Rewrite (Rplus_sym (Rplus r1 r2) 
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))) in H0;
- Rewrite <-(Rplus_assoc (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))) (Rplus r1 r2)) in H0;
- Rewrite (Rplus_Ropp_r (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))) in H0;
- Elim (Rplus_ne (Rplus r1 r2));Intros a b;Rewrite b in H0;Clear a b;
- Rewrite <-(Rplus_assoc (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))) R1 R1) in 
- H0;Cut R1==(IZR `1`);Auto with zarith real.
-Intro;Rewrite H1 in H0;Rewrite H1 in H;Clear H1;
- Rewrite <-(plus_IZR (Int_part r1) (Int_part r2)) in H; 
- Rewrite <-(plus_IZR (Int_part r1) (Int_part r2)) in H0;
- Rewrite <-(plus_IZR `(Int_part r1)+(Int_part r2)` `1`) in H;
- Rewrite <-(plus_IZR `(Int_part r1)+(Int_part r2)` `1`) in H0;
- Rewrite <-(plus_IZR `(Int_part r1)+(Int_part r2)+1` `1`) in H0;
- Generalize (up_tech (Rplus r1 r2) `(Int_part r1)+(Int_part r2)+1` H H0);Intro;
- Clear H H0;Unfold 1 Int_part;Omega.
-Qed.
-
-(**********)
-Lemma plus_Int_part2:(r1,r2:R)(Rlt (Rplus (frac_part r1) (frac_part r2)) R1)->
-  (Int_part (Rplus r1 r2))=(Zplus (Int_part r1) (Int_part r2)).
-Intros;Elim (base_fp r1);Elim (base_fp r2);Intros;Clear H1 H3;
- Generalize (Rle_sym2 R0 (frac_part r2) H0);Intro;Clear H0;
- Generalize (Rle_sym2 R0 (frac_part r1) H2);Intro;Clear H2;
- Generalize (Rle_compatibility (frac_part r1) R0 (frac_part r2) H1);
- Intro;Clear H1;Elim (Rplus_ne (frac_part r1));Intros a b;
- Rewrite a in H2;Clear a b;Generalize (Rle_trans R0 (frac_part r1)
-  (Rplus (frac_part r1) (frac_part r2)) H0 H2);Intro;Clear H0 H2;
- Unfold frac_part in H H1;Unfold Rminus in H H1;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus r2 (Ropp (IZR (Int_part r2))))) in H1;
- Rewrite (Rplus_sym r2 (Ropp (IZR (Int_part r2)))) in H1;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))
-  r2) in H1;
- Rewrite (Rplus_sym 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))) r2) in H1;
- Rewrite <-(Rplus_assoc r1 r2 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2))))) in H1;
- Rewrite <-(Ropp_distr1 (IZR (Int_part r1)) (IZR (Int_part r2))) in H1;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus r2 (Ropp (IZR (Int_part r2))))) in H;
- Rewrite (Rplus_sym r2 (Ropp (IZR (Int_part r2)))) in H;
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))
-  r2) in H;
- Rewrite (Rplus_sym 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))) r2) in H;
- Rewrite <-(Rplus_assoc r1 r2 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2))))) in H;
- Rewrite <-(Ropp_distr1 (IZR (Int_part r1)) (IZR (Int_part r2))) in H;
- Generalize (Rle_compatibility (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  R0 (Rplus (Rplus r1 r2)
-           (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))) H1);Intro;
- Clear H1;
- Generalize (Rlt_compatibility (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Rplus (Rplus r1 r2)
-   (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))) R1 H);
- Intro;Clear H;
- Rewrite (Rplus_sym (Rplus r1 r2) 
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))) in H1;
- Rewrite <-(Rplus_assoc (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))) (Rplus r1 r2)) in H1;
- Rewrite (Rplus_Ropp_r (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))) in H1;
- Elim (Rplus_ne (Rplus r1 r2));Intros a b;Rewrite b in H1;Clear a b;
- Rewrite (Rplus_sym (Rplus r1 r2) 
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))) in H0;
- Rewrite <-(Rplus_assoc (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))) (Rplus r1 r2)) in H0;
- Rewrite (Rplus_Ropp_r (Rplus (IZR (Int_part r1)) (IZR (Int_part r2)))) in H0;
- Elim (Rplus_ne (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))));Intros a b;
- Rewrite a in H0;Clear a b;Elim (Rplus_ne (Rplus r1 r2));Intros a b;
- Rewrite b in H0;Clear a b;Cut R1==(IZR `1`);Auto with zarith real.
-Intro;Rewrite H in H1;Clear H;
- Rewrite <-(plus_IZR (Int_part r1) (Int_part r2)) in H0;
- Rewrite <-(plus_IZR (Int_part r1) (Int_part r2)) in H1;
- Rewrite <-(plus_IZR `(Int_part r1)+(Int_part r2)` `1`) in H1;
- Generalize (up_tech (Rplus r1 r2) `(Int_part r1)+(Int_part r2)` H0 H1);Intro;
- Clear H0 H1;Unfold 1 Int_part;Omega.
-Qed.
-
-(**********)
-Lemma plus_frac_part1:(r1,r2:R)
-  (Rge (Rplus (frac_part r1) (frac_part r2)) R1)->
-                (frac_part (Rplus r1 r2))==
-                (Rminus (Rplus (frac_part r1) (frac_part r2)) R1).
-Intros;Unfold frac_part;
- Generalize (plus_Int_part1 r1 r2 H);Intro;Rewrite H0;
- Rewrite (plus_IZR `(Int_part r1)+(Int_part r2)` `1`);
- Rewrite (plus_IZR (Int_part r1) (Int_part r2));Simpl;Unfold 3 4 Rminus;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus r2 (Ropp (IZR (Int_part r2)))));
- Rewrite (Rplus_sym r2 (Ropp (IZR (Int_part r2))));
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))
-   r2);
- Rewrite (Rplus_sym 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))) r2);
- Rewrite <-(Rplus_assoc r1 r2 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))));
- Rewrite <-(Ropp_distr1 (IZR (Int_part r1)) (IZR (Int_part r2)));
- Unfold Rminus;
- Rewrite (Rplus_assoc (Rplus r1 r2) 
-  (Ropp (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))))
-  (Ropp R1));
- Rewrite <-(Ropp_distr1 (Rplus (IZR (Int_part r1)) (IZR (Int_part r2))) R1);
- Trivial with zarith real.
-Qed.
-
-(**********)
-Lemma plus_frac_part2:(r1,r2:R)
-  (Rlt (Rplus (frac_part r1) (frac_part r2)) R1)->
-(frac_part (Rplus r1 r2))==(Rplus (frac_part r1) (frac_part r2)).
-Intros;Unfold frac_part;
- Generalize (plus_Int_part2 r1 r2 H);Intro;Rewrite H0;
- Rewrite (plus_IZR (Int_part r1) (Int_part r2));Unfold 2 3 Rminus;
- Rewrite (Rplus_assoc r1 (Ropp (IZR (Int_part r1))) 
-  (Rplus r2 (Ropp (IZR (Int_part r2)))));
- Rewrite (Rplus_sym r2 (Ropp (IZR (Int_part r2))));
- Rewrite <-(Rplus_assoc (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))
-  r2);
- Rewrite (Rplus_sym 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))) r2);
- Rewrite <-(Rplus_assoc r1 r2 
-  (Rplus (Ropp (IZR (Int_part r1))) (Ropp (IZR (Int_part r2)))));
- Rewrite <-(Ropp_distr1 (IZR (Int_part r1)) (IZR (Int_part r2)));Unfold Rminus;
- Trivial with zarith real.
-Qed.
diff --git a/theories7/Reals/R_sqr.v b/theories7/Reals/R_sqr.v
deleted file mode 100644
index fc01a164..00000000
--- a/theories7/Reals/R_sqr.v
+++ /dev/null
@@ -1,232 +0,0 @@
-(************************************************************************)
-(*  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: R_sqr.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rbasic_fun.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(****************************************************)
-(* Rsqr : some results                              *)
-(****************************************************)
-
-Tactic Definition SqRing := Unfold Rsqr; Ring.
-
-Lemma Rsqr_neg : (x:R) ``(Rsqr x)==(Rsqr (-x))``.
-Intros; SqRing.
-Qed.
-
-Lemma Rsqr_times : (x,y:R) ``(Rsqr (x*y))==(Rsqr x)*(Rsqr y)``.
-Intros; SqRing.
-Qed.
-
-Lemma Rsqr_plus : (x,y:R) ``(Rsqr (x+y))==(Rsqr x)+(Rsqr y)+2*x*y``.
-Intros; SqRing.
-Qed.
-
-Lemma Rsqr_minus : (x,y:R) ``(Rsqr (x-y))==(Rsqr x)+(Rsqr y)-2*x*y``.
-Intros; SqRing.
-Qed.
-
-Lemma Rsqr_neg_minus : (x,y:R) ``(Rsqr (x-y))==(Rsqr (y-x))``.
-Intros; SqRing.
-Qed.
-
-Lemma Rsqr_1 : ``(Rsqr 1)==1``.
-SqRing.
-Qed.
-
-Lemma Rsqr_gt_0_0 : (x:R) ``0<(Rsqr x)`` -> ~``x==0``.
-Intros; Red; Intro; Rewrite H0 in H; Rewrite Rsqr_O in H; Elim (Rlt_antirefl ``0`` H).
-Qed.
-
-Lemma Rsqr_pos_lt : (x:R) ~(x==R0)->``0<(Rsqr x)``.
-Intros; Case (total_order R0 x); Intro; [Unfold Rsqr; Apply Rmult_lt_pos; Assumption | Elim H0; Intro; [Elim H; Symmetry; Exact H1 | Rewrite Rsqr_neg; Generalize (Rlt_Ropp x ``0`` H1); Rewrite Ropp_O; Intro; Unfold Rsqr; Apply Rmult_lt_pos; Assumption]].
-Qed.
-
-Lemma Rsqr_div : (x,y:R) ~``y==0`` -> ``(Rsqr (x/y))==(Rsqr x)/(Rsqr y)``.
-Intros; Unfold Rsqr.
-Unfold Rdiv.
-Rewrite Rinv_Rmult.
-Repeat Rewrite Rmult_assoc.
-Apply Rmult_mult_r.
-Pattern 2 x; Rewrite Rmult_sym.
-Repeat Rewrite Rmult_assoc.
-Apply Rmult_mult_r.
-Reflexivity.
-Assumption.
-Assumption.
-Qed.
-
-Lemma Rsqr_eq_0 : (x:R) ``(Rsqr x)==0`` -> ``x==0``.
-Unfold Rsqr; Intros; Generalize (without_div_Od x x H); Intro; Elim H0; Intro ; Assumption.
-Qed.
-
-Lemma Rsqr_minus_plus : (a,b:R) ``(a-b)*(a+b)==(Rsqr a)-(Rsqr b)``.
-Intros; SqRing.
-Qed.
-
-Lemma Rsqr_plus_minus : (a,b:R) ``(a+b)*(a-b)==(Rsqr a)-(Rsqr b)``.
-Intros; SqRing.
-Qed.
-
-Lemma Rsqr_incr_0 : (x,y:R) ``(Rsqr x)<=(Rsqr y)`` -> ``0<=x`` -> ``0<=y`` -> ``x<=y``.
-Intros; Case (total_order_Rle x y); Intro; [Assumption | Cut ``y<x``; [Intro; Unfold Rsqr in H; Generalize (Rmult_lt2 y x y x H1 H1 H2 H2); Intro; Generalize (Rle_lt_trans ``x*x`` ``y*y`` ``x*x`` H H3); Intro; Elim (Rlt_antirefl ``x*x`` H4) | Auto with real]].
-Qed.
-
-Lemma Rsqr_incr_0_var : (x,y:R) ``(Rsqr x)<=(Rsqr y)`` -> ``0<=y`` -> ``x<=y``.
-Intros; Case (total_order_Rle x y); Intro; [Assumption | Cut ``y<x``; [Intro; Unfold Rsqr in H; Generalize (Rmult_lt2 y x y x H0 H0 H1 H1); Intro; Generalize (Rle_lt_trans ``x*x`` ``y*y`` ``x*x`` H H2); Intro; Elim (Rlt_antirefl ``x*x`` H3) | Auto with real]].
-Qed.
-
-Lemma Rsqr_incr_1 : (x,y:R) ``x<=y``->``0<=x``->``0<= y``->``(Rsqr x)<=(Rsqr y)``.
-Intros; Unfold Rsqr; Apply Rle_Rmult_comp; Assumption.
-Qed.
-
-Lemma Rsqr_incrst_0 : (x,y:R) ``(Rsqr x)<(Rsqr y)``->``0<=x``->``0<=y``-> ``x<y``.
-Intros; Case (total_order x y); Intro; [Assumption | Elim H2; Intro; [Rewrite H3 in H; Elim (Rlt_antirefl (Rsqr y) H) | Generalize (Rmult_lt2 y x y x H1 H1 H3 H3); Intro; Unfold Rsqr in H; Generalize (Rlt_trans ``x*x`` ``y*y`` ``x*x`` H H4); Intro; Elim (Rlt_antirefl ``x*x`` H5)]].
-Qed.
-
-Lemma Rsqr_incrst_1 : (x,y:R) ``x<y``->``0<=x``->``0<=y``->``(Rsqr x)<(Rsqr y)``.
-Intros; Unfold Rsqr; Apply Rmult_lt2; Assumption.
-Qed.
-
-Lemma Rsqr_neg_pos_le_0 : (x,y:R) ``(Rsqr x)<=(Rsqr y)``->``0<=y``->``-y<=x``.
-Intros; Case (case_Rabsolu x); Intro.
-Generalize (Rlt_Ropp x ``0`` r); Rewrite Ropp_O; Intro; Generalize (Rlt_le ``0`` ``-x`` H1); Intro; Rewrite (Rsqr_neg x) in H; Generalize (Rsqr_incr_0 (Ropp x) y H H2 H0); Intro; Rewrite <- (Ropp_Ropp x); Apply Rge_Ropp; Apply Rle_sym1; Assumption.
-Apply Rle_trans with ``0``; [Rewrite <- Ropp_O; Apply Rge_Ropp; Apply Rle_sym1; Assumption | Apply Rle_sym2; Assumption].
-Qed.
-
-Lemma Rsqr_neg_pos_le_1 : (x,y:R) ``(-y)<=x`` -> ``x<=y`` -> ``0<=y`` -> ``(Rsqr x)<=(Rsqr y)``.
-Intros; Case (case_Rabsolu x); Intro.
-Generalize (Rlt_Ropp x ``0`` r); Rewrite Ropp_O; Intro; Generalize (Rlt_le ``0`` ``-x`` H2); Intro; Generalize (Rle_Ropp ``-y`` x H); Rewrite Ropp_Ropp; Intro; Generalize (Rle_sym2 ``-x`` y H4); Intro; Rewrite (Rsqr_neg x); Apply Rsqr_incr_1; Assumption.
-Generalize (Rle_sym2 ``0`` x r); Intro; Apply Rsqr_incr_1; Assumption.
-Qed.
-
-Lemma neg_pos_Rsqr_le : (x,y:R) ``(-y)<=x``->``x<=y``->``(Rsqr x)<=(Rsqr y)``.
-Intros; Case (case_Rabsolu x); Intro.
-Generalize (Rlt_Ropp x ``0`` r); Rewrite Ropp_O; Intro; Generalize (Rle_Ropp ``-y`` x H); Rewrite Ropp_Ropp; Intro; Generalize (Rle_sym2 ``-x`` y H2); Intro; Generalize (Rlt_le ``0`` ``-x`` H1); Intro; Generalize (Rle_trans ``0`` ``-x`` y H4 H3); Intro; Rewrite (Rsqr_neg x); Apply Rsqr_incr_1; Assumption.
-Generalize (Rle_sym2 ``0`` x r); Intro; Generalize (Rle_trans ``0`` x y H1 H0); Intro; Apply Rsqr_incr_1; Assumption.
-Qed.
-
-Lemma Rsqr_abs : (x:R) ``(Rsqr x)==(Rsqr (Rabsolu x))``.
-Intro; Unfold Rabsolu; Case (case_Rabsolu x); Intro; [Apply Rsqr_neg | Reflexivity].
-Qed.
-
-Lemma Rsqr_le_abs_0 : (x,y:R) ``(Rsqr x)<=(Rsqr y)`` -> ``(Rabsolu x)<=(Rabsolu y)``.
-Intros; Apply Rsqr_incr_0; Repeat Rewrite <- Rsqr_abs; [Assumption | Apply Rabsolu_pos | Apply Rabsolu_pos].
-Qed.
-
-Lemma Rsqr_le_abs_1 : (x,y:R) ``(Rabsolu x)<=(Rabsolu y)`` -> ``(Rsqr x)<=(Rsqr y)``.
-Intros; Rewrite (Rsqr_abs x); Rewrite (Rsqr_abs y); Apply (Rsqr_incr_1 (Rabsolu x) (Rabsolu y)  H (Rabsolu_pos x) (Rabsolu_pos y)).
-Qed.
-
-Lemma Rsqr_lt_abs_0 : (x,y:R) ``(Rsqr x)<(Rsqr y)`` -> ``(Rabsolu x)<(Rabsolu y)``.
-Intros; Apply Rsqr_incrst_0; Repeat Rewrite <- Rsqr_abs; [Assumption | Apply Rabsolu_pos | Apply Rabsolu_pos].
-Qed.
-
-Lemma Rsqr_lt_abs_1 : (x,y:R) ``(Rabsolu x)<(Rabsolu y)`` -> ``(Rsqr x)<(Rsqr y)``.
-Intros; Rewrite (Rsqr_abs x); Rewrite (Rsqr_abs y); Apply (Rsqr_incrst_1 (Rabsolu x) (Rabsolu y)  H (Rabsolu_pos x) (Rabsolu_pos y)).
-Qed.
-
-Lemma Rsqr_inj : (x,y:R) ``0<=x`` -> ``0<=y`` -> (Rsqr x)==(Rsqr y) -> x==y.
-Intros; Generalize (Rle_le_eq (Rsqr x) (Rsqr y)); Intro; Elim H2; Intros _ H3; Generalize (H3 H1); Intro; Elim H4; Intros; Apply Rle_antisym; Apply Rsqr_incr_0; Assumption.
-Qed.
-
-Lemma Rsqr_eq_abs_0 : (x,y:R) (Rsqr x)==(Rsqr y) -> (Rabsolu x)==(Rabsolu y).
-Intros; Unfold Rabsolu; Case (case_Rabsolu x); Case (case_Rabsolu y); Intros.
-Rewrite -> (Rsqr_neg x) in H; Rewrite -> (Rsqr_neg y) in H; Generalize (Rlt_Ropp y ``0`` r); Generalize (Rlt_Ropp x ``0`` r0); Rewrite Ropp_O; Intros; Generalize (Rlt_le ``0`` ``-x`` H0); Generalize (Rlt_le ``0`` ``-y`` H1); Intros; Apply Rsqr_inj; Assumption.
-Rewrite -> (Rsqr_neg x) in H; Generalize (Rle_sym2 ``0`` y r); Intro; Generalize (Rlt_Ropp x ``0`` r0); Rewrite Ropp_O; Intro; Generalize (Rlt_le ``0`` ``-x`` H1); Intro; Apply Rsqr_inj; Assumption.
-Rewrite -> (Rsqr_neg y) in H; Generalize (Rle_sym2 ``0`` x r0); Intro; Generalize (Rlt_Ropp y ``0`` r); Rewrite Ropp_O; Intro; Generalize (Rlt_le ``0`` ``-y`` H1); Intro; Apply Rsqr_inj; Assumption.
-Generalize (Rle_sym2 ``0`` x r0); Generalize (Rle_sym2 ``0`` y r); Intros; Apply Rsqr_inj; Assumption.
-Qed.
-
-Lemma Rsqr_eq_asb_1 : (x,y:R) (Rabsolu x)==(Rabsolu y) -> (Rsqr x)==(Rsqr y).
-Intros; Cut ``(Rsqr (Rabsolu x))==(Rsqr (Rabsolu y))``.
-Intro; Repeat Rewrite <- Rsqr_abs in H0; Assumption.
-Rewrite H; Reflexivity.
-Qed.
-
-Lemma triangle_rectangle : (x,y,z:R) ``0<=z``->``(Rsqr x)+(Rsqr y)<=(Rsqr z)``->``-z<=x<=z`` /\``-z<=y<=z``.
-Intros; Generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (pos_Rsqr y) H0); Rewrite Rplus_sym in H0; Generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (pos_Rsqr x) H0); Intros; Split; [Split; [Apply Rsqr_neg_pos_le_0; Assumption | Apply Rsqr_incr_0_var; Assumption] | Split; [Apply Rsqr_neg_pos_le_0; Assumption | Apply Rsqr_incr_0_var; Assumption]].
-Qed.
-
-Lemma triangle_rectangle_lt : (x,y,z:R) ``(Rsqr x)+(Rsqr y)<(Rsqr z)`` -> ``(Rabsolu x)<(Rabsolu z)``/\``(Rabsolu y)<(Rabsolu z)``.
-Intros; Split; [Generalize (plus_lt_is_lt (Rsqr x) (Rsqr y) (Rsqr z) (pos_Rsqr y) H); Intro; Apply Rsqr_lt_abs_0; Assumption | Rewrite Rplus_sym in H; Generalize (plus_lt_is_lt (Rsqr y) (Rsqr x) (Rsqr z) (pos_Rsqr x) H); Intro; Apply Rsqr_lt_abs_0; Assumption].
-Qed.
-
-Lemma triangle_rectangle_le : (x,y,z:R) ``(Rsqr x)+(Rsqr y)<=(Rsqr z)`` -> ``(Rabsolu x)<=(Rabsolu z)``/\``(Rabsolu y)<=(Rabsolu z)``.
-Intros; Split; [Generalize (plus_le_is_le (Rsqr x) (Rsqr y) (Rsqr z) (pos_Rsqr y) H); Intro; Apply Rsqr_le_abs_0; Assumption | Rewrite Rplus_sym in H; Generalize (plus_le_is_le (Rsqr y) (Rsqr x) (Rsqr z) (pos_Rsqr x) H); Intro; Apply Rsqr_le_abs_0; Assumption].
-Qed.
-
-Lemma Rsqr_inv : (x:R) ~``x==0`` -> ``(Rsqr (/x))==/(Rsqr x)``.
-Intros; Unfold Rsqr.
-Rewrite Rinv_Rmult; Try Reflexivity Orelse Assumption.
-Qed.
-
-Lemma canonical_Rsqr : (a:nonzeroreal;b,c,x:R) ``a*(Rsqr x)+b*x+c == a* (Rsqr (x+b/(2*a))) + (4*a*c - (Rsqr b))/(4*a)``.
-Intros.
-Rewrite Rsqr_plus.
-Repeat Rewrite Rmult_Rplus_distr.
-Repeat Rewrite Rplus_assoc.
-Apply Rplus_plus_r.
-Unfold Rdiv Rminus.
-Replace ``2*1+2*1`` with ``4``; [Idtac | Ring].
-Rewrite (Rmult_Rplus_distrl ``4*a*c`` ``-(Rsqr b)`` ``/(4*a)``).
-Rewrite Rsqr_times.
-Repeat Rewrite Rinv_Rmult.
-Repeat Rewrite (Rmult_sym a).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym ``2``).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym ``/2``).
-Rewrite (Rmult_sym ``2``).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym a).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym ``2``).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Repeat Rewrite Rplus_assoc.
-Rewrite (Rplus_sym ``(Rsqr b)*((Rsqr (/a*/2))*a)``).
-Repeat Rewrite Rplus_assoc.
-Rewrite (Rmult_sym x).
-Apply Rplus_plus_r.
-Rewrite (Rmult_sym ``/a``).
-Unfold Rsqr; Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Ring.
-Apply (cond_nonzero a).
-DiscrR.
-Apply (cond_nonzero a).
-DiscrR.
-DiscrR.
-Apply (cond_nonzero a).
-DiscrR.
-DiscrR.
-DiscrR.
-Apply (cond_nonzero a).
-DiscrR.
-Apply (cond_nonzero a).
-Qed.
-
-Lemma Rsqr_eq : (x,y:R) (Rsqr x)==(Rsqr y) -> x==y \/ x==``-y``.
-Intros; Unfold Rsqr in H; Generalize (Rplus_plus_r ``-(y*y)`` ``x*x`` ``y*y`` H); Rewrite Rplus_Ropp_l; Replace ``-(y*y)+x*x`` with ``(x-y)*(x+y)``.
-Intro; Generalize (without_div_Od ``x-y`` ``x+y`` H0); Intro; Elim H1; Intros.
-Left; Apply Rminus_eq; Assumption.
-Right; Apply Rminus_eq; Unfold Rminus; Rewrite Ropp_Ropp; Assumption.
-Ring.
-Qed.
diff --git a/theories7/Reals/R_sqrt.v b/theories7/Reals/R_sqrt.v
deleted file mode 100644
index 8c87659b..00000000
--- a/theories7/Reals/R_sqrt.v
+++ /dev/null
@@ -1,251 +0,0 @@
-(************************************************************************)
-(*  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: R_sqrt.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rsqrt_def.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(* Here is a continuous extension of Rsqrt on R *)
-Definition sqrt : R->R := [x:R](Cases (case_Rabsolu x) of
-      (leftT _) => R0
-    | (rightT a) => (Rsqrt (mknonnegreal x (Rle_sym2 ? ? a))) end).
-
-Lemma sqrt_positivity : (x:R) ``0<=x`` -> ``0<=(sqrt x)``.
-Intros.
-Unfold sqrt.
-Case (case_Rabsolu x); Intro.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? r H)).
-Apply Rsqrt_positivity.
-Qed.
-
-Lemma sqrt_sqrt : (x:R) ``0<=x`` -> ``(sqrt x)*(sqrt x)==x``.
-Intros.
-Unfold sqrt.
-Case (case_Rabsolu x); Intro.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? r H)).
-Rewrite Rsqrt_Rsqrt; Reflexivity.
-Qed.
-
-Lemma sqrt_0 : ``(sqrt 0)==0``.
-Apply Rsqr_eq_0; Unfold Rsqr; Apply sqrt_sqrt; Right; Reflexivity. 
-Qed.
-
-Lemma sqrt_1 : ``(sqrt 1)==1``.
-Apply (Rsqr_inj (sqrt R1) R1); [Apply sqrt_positivity; Left | Left | Unfold Rsqr; Rewrite -> sqrt_sqrt; [Ring | Left]]; Apply Rlt_R0_R1.
-Qed.
-
-Lemma sqrt_eq_0 : (x:R) ``0<=x``->``(sqrt x)==0``->``x==0``.
-Intros; Cut ``(Rsqr (sqrt x))==0``.
-Intro; Unfold Rsqr in H1; Rewrite -> sqrt_sqrt in H1; Assumption.
-Rewrite H0; Apply Rsqr_O.
-Qed.
-
-Lemma sqrt_lem_0 : (x,y:R) ``0<=x``->``0<=y``->(sqrt x)==y->``y*y==x``.
-Intros; Rewrite <- H1; Apply (sqrt_sqrt x H).
-Qed.
-
-Lemma sqtr_lem_1 : (x,y:R) ``0<=x``->``0<=y``->``y*y==x``->(sqrt x)==y.
-Intros; Apply Rsqr_inj; [Apply (sqrt_positivity x H) | Assumption | Unfold Rsqr; Rewrite -> H1; Apply (sqrt_sqrt x H)].
-Qed.
-
-Lemma sqrt_def : (x:R) ``0<=x``->``(sqrt x)*(sqrt x)==x``.
-Intros; Apply (sqrt_sqrt x H).
-Qed.
-
-Lemma sqrt_square : (x:R) ``0<=x``->``(sqrt (x*x))==x``.
-Intros; Apply (Rsqr_inj (sqrt (Rsqr x)) x (sqrt_positivity (Rsqr x) (pos_Rsqr x)) H); Unfold Rsqr; Apply (sqrt_sqrt (Rsqr x) (pos_Rsqr x)).
-Qed.
-
-Lemma sqrt_Rsqr : (x:R) ``0<=x``->``(sqrt (Rsqr x))==x``.
-Intros; Unfold Rsqr; Apply sqrt_square; Assumption.
-Qed.
-
-Lemma sqrt_Rsqr_abs : (x:R) (sqrt (Rsqr x))==(Rabsolu x).
-Intro x; Rewrite -> Rsqr_abs; Apply sqrt_Rsqr; Apply Rabsolu_pos.
-Qed.
-
-Lemma Rsqr_sqrt : (x:R) ``0<=x``->(Rsqr (sqrt x))==x.
-Intros x H1; Unfold Rsqr; Apply (sqrt_sqrt x H1).
-Qed.
-
-Lemma sqrt_times : (x,y:R) ``0<=x``->``0<=y``->``(sqrt (x*y))==(sqrt x)*(sqrt y)``.
-Intros x y H1 H2; Apply (Rsqr_inj (sqrt (Rmult x y)) (Rmult (sqrt x) (sqrt y)) (sqrt_positivity (Rmult x y) (Rmult_le_pos x y H1 H2)) (Rmult_le_pos (sqrt x) (sqrt y) (sqrt_positivity x H1) (sqrt_positivity y H2))); Rewrite Rsqr_times; Repeat Rewrite Rsqr_sqrt; [Ring | Assumption |Assumption | Apply (Rmult_le_pos x y H1 H2)].
-Qed.
-
-Lemma sqrt_lt_R0 : (x:R) ``0<x`` -> ``0<(sqrt x)``.
-Intros x H1; Apply Rsqr_incrst_0; [Rewrite Rsqr_O; Rewrite Rsqr_sqrt ; [Assumption | Left; Assumption] | Right; Reflexivity | Apply (sqrt_positivity x (Rlt_le R0 x H1))].
-Qed.
-
-Lemma sqrt_div : (x,y:R) ``0<=x``->``0<y``->``(sqrt (x/y))==(sqrt x)/(sqrt y)``.
-Intros x y H1 H2; Apply Rsqr_inj; [ Apply sqrt_positivity; Apply (Rmult_le_pos x (Rinv y)); [ Assumption | Generalize (Rlt_Rinv y H2); Clear H2; Intro H2; Left; Assumption] | Apply (Rmult_le_pos (sqrt x) (Rinv (sqrt y))) ; [ Apply (sqrt_positivity x H1) | Generalize (sqrt_lt_R0 y H2); Clear H2; Intro H2; Generalize (Rlt_Rinv (sqrt y) H2); Clear H2; Intro H2; Left; Assumption] | Rewrite Rsqr_div; Repeat Rewrite Rsqr_sqrt; [ Reflexivity | Left; Assumption | Assumption | Generalize (Rlt_Rinv y H2); Intro H3; Generalize (Rlt_le R0 (Rinv y) H3); Intro H4; Apply (Rmult_le_pos x (Rinv y) H1 H4) |Red; Intro H3; Generalize (Rlt_le R0 y H2); Intro H4; Generalize (sqrt_eq_0 y H4 H3); Intro H5; Rewrite H5 in H2; Elim (Rlt_antirefl R0 H2)]].
-Qed.
-
-Lemma sqrt_lt_0 : (x,y:R) ``0<=x``->``0<=y``->``(sqrt x)<(sqrt y)``->``x<y``.
-Intros x y H1 H2 H3; Generalize (Rsqr_incrst_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1) (sqrt_positivity y H2)); Intro H4; Rewrite (Rsqr_sqrt x H1) in H4; Rewrite (Rsqr_sqrt y H2) in H4; Assumption.
-Qed.
-
-Lemma sqrt_lt_1 : (x,y:R) ``0<=x``->``0<=y``->``x<y``->``(sqrt x)<(sqrt y)``.
-Intros x y H1 H2 H3; Apply Rsqr_incrst_0; [Rewrite (Rsqr_sqrt x H1); Rewrite (Rsqr_sqrt y H2); Assumption | Apply (sqrt_positivity x H1) | Apply (sqrt_positivity y H2)].
-Qed.
-
-Lemma sqrt_le_0 : (x,y:R) ``0<=x``->``0<=y``->``(sqrt x)<=(sqrt y)``->``x<=y``.
-Intros x y H1 H2 H3; Generalize (Rsqr_incr_1 (sqrt x) (sqrt y) H3 (sqrt_positivity x H1) (sqrt_positivity y H2)); Intro H4; Rewrite (Rsqr_sqrt x H1) in H4; Rewrite (Rsqr_sqrt y H2) in H4; Assumption.
-Qed.
-
-Lemma sqrt_le_1 : (x,y:R) ``0<=x``->``0<=y``->``x<=y``->``(sqrt x)<=(sqrt y)``.
-Intros x y H1 H2 H3; Apply Rsqr_incr_0; [ Rewrite (Rsqr_sqrt x H1); Rewrite (Rsqr_sqrt y H2); Assumption | Apply (sqrt_positivity x H1) | Apply (sqrt_positivity y H2)].
-Qed.
-
-Lemma sqrt_inj : (x,y:R) ``0<=x``->``0<=y``->(sqrt x)==(sqrt y)->x==y.
-Intros; Cut ``(Rsqr (sqrt x))==(Rsqr (sqrt y))``.
-Intro; Rewrite (Rsqr_sqrt x H) in H2; Rewrite (Rsqr_sqrt y H0) in H2; Assumption.
-Rewrite H1; Reflexivity.
-Qed.
-
-Lemma sqrt_less : (x:R)  ``0<=x``->``1<x``->``(sqrt x)<x``.
-Intros x H1 H2; Generalize (sqrt_lt_1 R1 x (Rlt_le R0 R1 (Rlt_R0_R1)) H1 H2); Intro H3; Rewrite  sqrt_1 in H3; Generalize (Rmult_ne (sqrt x)); Intro H4; Elim H4; Intros H5 H6; Rewrite <- H5; Pattern 2 x; Rewrite <- (sqrt_def x H1); Apply (Rlt_monotony (sqrt x) R1 (sqrt x) (sqrt_lt_R0 x (Rlt_trans R0 R1 x Rlt_R0_R1 H2)) H3).
-Qed.
-
-Lemma sqrt_more : (x:R) ``0<x``->``x<1``->``x<(sqrt x)``.
-Intros x H1 H2; Generalize (sqrt_lt_1 x R1 (Rlt_le R0 x H1) (Rlt_le R0 R1 (Rlt_R0_R1)) H2); Intro H3; Rewrite  sqrt_1 in H3; Generalize (Rmult_ne (sqrt x)); Intro H4; Elim H4; Intros H5 H6; Rewrite <- H5; Pattern 1 x; Rewrite <- (sqrt_def x (Rlt_le R0 x H1)); Apply (Rlt_monotony (sqrt x) (sqrt x) R1 (sqrt_lt_R0 x H1) H3).
-Qed.
-
-Lemma sqrt_cauchy : (a,b,c,d:R) ``a*c+b*d<=(sqrt ((Rsqr a)+(Rsqr b)))*(sqrt ((Rsqr c)+(Rsqr d)))``.
-Intros a b c d; Apply Rsqr_incr_0_var; [Rewrite Rsqr_times; Repeat Rewrite Rsqr_sqrt; Unfold Rsqr; [Replace ``(a*c+b*d)*(a*c+b*d)`` with ``(a*a*c*c+b*b*d*d)+(2*a*b*c*d)``; [Replace ``(a*a+b*b)*(c*c+d*d)`` with ``(a*a*c*c+b*b*d*d)+(a*a*d*d+b*b*c*c)``; [Apply Rle_compatibility; Replace ``a*a*d*d+b*b*c*c`` with ``(2*a*b*c*d)+(a*a*d*d+b*b*c*c-2*a*b*c*d)``; [Pattern 1 ``2*a*b*c*d``; Rewrite <- Rplus_Or; Apply Rle_compatibility; Replace ``a*a*d*d+b*b*c*c-2*a*b*c*d`` with (Rsqr (Rminus (Rmult a d) (Rmult b c))); [Apply pos_Rsqr | Unfold Rsqr; Ring] | Ring] | Ring] | Ring] | Apply (ge0_plus_ge0_is_ge0 (Rsqr c) (Rsqr d) (pos_Rsqr c) (pos_Rsqr d)) | Apply (ge0_plus_ge0_is_ge0 (Rsqr a) (Rsqr b) (pos_Rsqr a) (pos_Rsqr b))] | Apply Rmult_le_pos; Apply sqrt_positivity; Apply ge0_plus_ge0_is_ge0; Apply pos_Rsqr].
-Qed.
-
-(************************************************************)
-(* Resolution of [a*X^2+b*X+c=0]                            *)
-(************************************************************)
-
-Definition Delta [a:nonzeroreal;b,c:R] : R := ``(Rsqr b)-4*a*c``.
-
-Definition Delta_is_pos [a:nonzeroreal;b,c:R] : Prop := ``0<=(Delta a b c)``.
-
-Definition sol_x1 [a:nonzeroreal;b,c:R] : R := ``(-b+(sqrt (Delta a b c)))/(2*a)``.
-
-Definition sol_x2 [a:nonzeroreal;b,c:R] : R := ``(-b-(sqrt (Delta a b c)))/(2*a)``.
-
-Lemma Rsqr_sol_eq_0_1 : (a:nonzeroreal;b,c,x:R) (Delta_is_pos a b c) -> (x==(sol_x1 a b c))\/(x==(sol_x2 a b c)) -> ``a*(Rsqr x)+b*x+c==0``.
-Intros; Elim H0; Intro.
-Unfold sol_x1 in H1; Unfold Delta in H1; Rewrite H1; Unfold Rdiv; Repeat Rewrite Rsqr_times; Rewrite Rsqr_plus; Rewrite <- Rsqr_neg; Rewrite Rsqr_sqrt.
-Rewrite Rsqr_inv.
-Unfold Rsqr; Repeat Rewrite Rinv_Rmult.
-Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym a).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite Rmult_Rplus_distrl.
-Repeat Rewrite Rmult_assoc.
-Pattern 2 ``2``; Rewrite (Rmult_sym ``2``).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite (Rmult_Rplus_distrl ``-b`` ``(sqrt (b*b-(2*(2*(a*c)))))`` ``(/2*/a)``).
-Rewrite Rmult_Rplus_distr; Repeat Rewrite Rplus_assoc.
-Replace ``( -b*((sqrt (b*b-(2*(2*(a*c)))))*(/2*/a))+(b*( -b*(/2*/a))+(b*((sqrt (b*b-(2*(2*(a*c)))))*(/2*/a))+c)))`` with ``(b*( -b*(/2*/a)))+c``.
-Unfold Rminus; Repeat Rewrite <- Rplus_assoc.
-Replace ``b*b+b*b`` with ``2*(b*b)``.
-Rewrite Rmult_Rplus_distrl; Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym ``2``); Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite Ropp_mul1; Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym ``2``).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite (Rmult_sym ``/2``); Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym ``2``).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym a); Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite <- Ropp_mul2.
-Ring.
-Apply (cond_nonzero a).
-DiscrR.
-DiscrR.
-DiscrR.
-Ring.
-Ring.
-DiscrR.
-Apply (cond_nonzero a).
-DiscrR.
-Apply (cond_nonzero a).
-Apply prod_neq_R0; [DiscrR | Apply (cond_nonzero a)].
-Apply prod_neq_R0; [DiscrR | Apply (cond_nonzero a)].
-Apply prod_neq_R0; [DiscrR | Apply (cond_nonzero a)].
-Assumption.
-Unfold sol_x2 in H1; Unfold Delta in H1; Rewrite H1; Unfold Rdiv; Repeat Rewrite Rsqr_times; Rewrite Rsqr_minus; Rewrite <- Rsqr_neg; Rewrite Rsqr_sqrt.
-Rewrite Rsqr_inv.
-Unfold Rsqr; Repeat Rewrite Rinv_Rmult; Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym a); Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Unfold Rminus; Rewrite Rmult_Rplus_distrl.
-Rewrite Ropp_mul1; Repeat Rewrite Rmult_assoc; Pattern 2 ``2``; Rewrite (Rmult_sym ``2``).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite (Rmult_Rplus_distrl ``-b`` ``-(sqrt (b*b+ -(2*(2*(a*c))))) `` ``(/2*/a)``).
-Rewrite Rmult_Rplus_distr; Repeat Rewrite Rplus_assoc.
-Rewrite Ropp_mul1; Rewrite Ropp_Ropp.
-Replace ``(b*((sqrt (b*b+ -(2*(2*(a*c)))))*(/2*/a))+(b*( -b*(/2*/a))+(b*( -(sqrt (b*b+ -(2*(2*(a*c)))))*(/2*/a))+c)))`` with ``(b*( -b*(/2*/a)))+c``.
-Repeat Rewrite <- Rplus_assoc; Replace ``b*b+b*b`` with ``2*(b*b)``.
-Rewrite Rmult_Rplus_distrl; Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym ``2``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Ropp_mul1; Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym ``2``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite (Rmult_sym ``/2``); Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym ``2``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym a); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite <- Ropp_mul2; Ring.
-Apply (cond_nonzero a).
-DiscrR.
-DiscrR.
-DiscrR.
-Ring.
-Ring.
-DiscrR.
-Apply (cond_nonzero a).
-DiscrR.
-DiscrR.
-Apply (cond_nonzero a).
-Apply prod_neq_R0; DiscrR Orelse Apply (cond_nonzero a).
-Apply prod_neq_R0; DiscrR Orelse Apply (cond_nonzero a).
-Apply prod_neq_R0; DiscrR Orelse Apply (cond_nonzero a).
-Assumption.
-Qed.
-
-Lemma Rsqr_sol_eq_0_0 : (a:nonzeroreal;b,c,x:R) (Delta_is_pos a b c) -> ``a*(Rsqr x)+b*x+c==0`` -> (x==(sol_x1 a b c))\/(x==(sol_x2 a b c)).
-Intros; Rewrite (canonical_Rsqr a b c x) in H0; Rewrite Rplus_sym in H0; Generalize (Rplus_Ropp  ``(4*a*c-(Rsqr b))/(4*a)`` ``a*(Rsqr (x+b/(2*a)))`` H0); Cut ``(Rsqr b)-4*a*c==(Delta a b c)``.
-Intro; Replace ``-((4*a*c-(Rsqr b))/(4*a))`` with ``((Rsqr b)-4*a*c)/(4*a)``.
-Rewrite H1; Intro; Generalize (Rmult_mult_r ``/a`` ``a*(Rsqr (x+b/(2*a)))`` ``(Delta a b c)/(4*a)`` H2); Replace ``/a*(a*(Rsqr (x+b/(2*a))))`` with ``(Rsqr (x+b/(2*a)))``.
-Replace ``/a*(Delta a b c)/(4*a)`` with ``(Rsqr ((sqrt (Delta a b c))/(2*a)))``.
-Intro; Generalize (Rsqr_eq ``(x+b/(2*a))`` ``((sqrt (Delta a b c))/(2*a))`` H3); Intro; Elim H4; Intro.
-Left; Unfold sol_x1; Generalize (Rplus_plus_r ``-(b/(2*a))`` ``x+b/(2*a)`` ``(sqrt (Delta a b c))/(2*a)`` H5); Replace `` -(b/(2*a))+(x+b/(2*a))`` with x.
-Intro; Rewrite H6; Unfold Rdiv; Ring.
-Ring.
-Right; Unfold sol_x2; Generalize (Rplus_plus_r ``-(b/(2*a))`` ``x+b/(2*a)`` ``-((sqrt (Delta a b c))/(2*a))`` H5); Replace `` -(b/(2*a))+(x+b/(2*a))`` with x.
-Intro; Rewrite H6; Unfold Rdiv; Ring.
-Ring.
-Rewrite Rsqr_div.
-Rewrite Rsqr_sqrt.
-Unfold Rdiv.
-Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym ``/a``).
-Rewrite Rmult_assoc.
-Rewrite <- Rinv_Rmult.
-Replace ``(2*(2*a))*a`` with ``(Rsqr (2*a))``.
-Reflexivity.
-SqRing.
-Rewrite <- Rmult_assoc; Apply prod_neq_R0; [DiscrR | Apply (cond_nonzero a)].
-Apply (cond_nonzero a).
-Assumption.
-Apply prod_neq_R0; [DiscrR | Apply (cond_nonzero a)].
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Symmetry; Apply Rmult_1l.
-Apply (cond_nonzero a).
-Unfold Rdiv; Rewrite <- Ropp_mul1.
-Rewrite Ropp_distr2.
-Reflexivity.
-Reflexivity.
-Qed.
diff --git a/theories7/Reals/Ranalysis.v b/theories7/Reals/Ranalysis.v
deleted file mode 100644
index d5d84f50..00000000
--- a/theories7/Reals/Ranalysis.v
+++ /dev/null
@@ -1,477 +0,0 @@
-(************************************************************************)
-(*  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: Ranalysis.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rtrigo.
-Require SeqSeries.
-Require Export Ranalysis1.
-Require Export Ranalysis2.
-Require Export Ranalysis3.
-Require Export Rtopology.
-Require Export MVT.
-Require Export PSeries_reg.
-Require Export Exp_prop.
-Require Export Rtrigo_reg.
-Require Export Rsqrt_def.
-Require Export R_sqrt.
-Require Export Rtrigo_calc.
-Require Export Rgeom.
-Require Export RList.
-Require Export Sqrt_reg.
-Require Export Ranalysis4.
-Require Export Rpower.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Axiom AppVar : R.
-
-(**********)
-Recursive Tactic Definition IntroHypG trm :=
-Match trm With
-|[(plus_fct ?1 ?2)] -> 
- (Match Context With
- |[|-(derivable ?)] -> IntroHypG ?1; IntroHypG ?2
- |[|-(continuity ?)] -> IntroHypG ?1; IntroHypG ?2
- | _ -> Idtac)
-|[(minus_fct ?1 ?2)] -> 
- (Match Context With
- |[|-(derivable ?)] -> IntroHypG ?1; IntroHypG ?2
- |[|-(continuity ?)] -> IntroHypG ?1; IntroHypG ?2
- | _ -> Idtac)
-|[(mult_fct ?1 ?2)] ->
- (Match Context With
- |[|-(derivable ?)] -> IntroHypG ?1; IntroHypG ?2
- |[|-(continuity ?)] -> IntroHypG ?1; IntroHypG ?2
- | _ -> Idtac)
-|[(div_fct ?1 ?2)] -> Let aux = ?2 In
- (Match Context With
- |[_:(x0:R)``(aux x0)<>0``|-(derivable ?)] -> IntroHypG ?1; IntroHypG ?2
- |[_:(x0:R)``(aux x0)<>0``|-(continuity ?)] -> IntroHypG ?1; IntroHypG ?2
- |[|-(derivable ?)] -> Cut ((x0:R)``(aux x0)<>0``); [Intro; IntroHypG ?1; IntroHypG ?2 | Try Assumption]
- |[|-(continuity ?)] -> Cut ((x0:R)``(aux x0)<>0``); [Intro; IntroHypG ?1; IntroHypG ?2 | Try Assumption]
- | _ -> Idtac)
-|[(comp ?1 ?2)] -> 
- (Match Context With
- |[|-(derivable ?)] -> IntroHypG ?1; IntroHypG ?2
- |[|-(continuity ?)] -> IntroHypG ?1; IntroHypG ?2
- | _ -> Idtac)
-|[(opp_fct ?1)] -> 
- (Match Context With
- |[|-(derivable ?)] -> IntroHypG ?1
- |[|-(continuity ?)] -> IntroHypG ?1
- | _ -> Idtac)
-|[(inv_fct ?1)] -> Let aux = ?1 In
- (Match Context With
- |[_:(x0:R)``(aux x0)<>0``|-(derivable ?)] -> IntroHypG ?1
- |[_:(x0:R)``(aux x0)<>0``|-(continuity ?)] -> IntroHypG ?1
- |[|-(derivable ?)] -> Cut ((x0:R)``(aux x0)<>0``); [Intro; IntroHypG ?1 | Try Assumption]
- |[|-(continuity ?)] -> Cut ((x0:R)``(aux x0)<>0``); [Intro; IntroHypG ?1| Try Assumption]
- | _ -> Idtac)
-|[cos] -> Idtac
-|[sin] -> Idtac
-|[cosh] -> Idtac
-|[sinh] -> Idtac
-|[exp] -> Idtac
-|[Rsqr] -> Idtac
-|[sqrt] -> Idtac
-|[id] -> Idtac
-|[(fct_cte ?)] -> Idtac
-|[(pow_fct ?)] -> Idtac
-|[Rabsolu] -> Idtac
-|[?1] -> Let p = ?1 In
- (Match Context With
- |[_:(derivable p)|- ?] -> Idtac
- |[|-(derivable p)] -> Idtac
- |[|-(derivable ?)] -> Cut True -> (derivable p); [Intro HYPPD; Cut (derivable p); [Intro; Clear HYPPD | Apply HYPPD; Clear HYPPD; Trivial] | Idtac]
- | [_:(continuity p)|- ?] -> Idtac
- |[|-(continuity p)] -> Idtac
- |[|-(continuity ?)] -> Cut True -> (continuity p); [Intro HYPPD; Cut (continuity p); [Intro; Clear HYPPD | Apply HYPPD; Clear HYPPD; Trivial] | Idtac]
- | _ -> Idtac).
-
-(**********)
-Recursive Tactic Definition IntroHypL trm pt :=
-Match trm With
-|[(plus_fct ?1 ?2)] -> 
- (Match Context With
- |[|-(derivable_pt ? ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[|-(continuity_pt ? ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- | _ -> Idtac)
-|[(minus_fct ?1 ?2)] -> 
- (Match Context With
- |[|-(derivable_pt ? ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[|-(continuity_pt ? ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- | _ -> Idtac)
-|[(mult_fct ?1 ?2)] ->
- (Match Context With
- |[|-(derivable_pt ? ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[|-(continuity_pt ? ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- | _ -> Idtac)
-|[(div_fct ?1 ?2)] -> Let aux = ?2 In
- (Match Context With
- |[_:``(aux pt)<>0``|-(derivable_pt ? ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[_:``(aux pt)<>0``|-(continuity_pt ? ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[_:``(aux pt)<>0``|-(eqT ? (derive_pt ? ? ?) ?)] -> IntroHypL ?1 pt; IntroHypL ?2 pt
- |[id:(x0:R)``(aux x0)<>0``|-(derivable_pt ? ?)] -> Generalize (id pt); Intro; IntroHypL ?1 pt; IntroHypL ?2 pt
- |[id:(x0:R)``(aux x0)<>0``|-(continuity_pt ? ?)] -> Generalize (id pt); Intro; IntroHypL ?1 pt; IntroHypL ?2 pt
- |[id:(x0:R)``(aux x0)<>0``|-(eqT ? (derive_pt ? ? ?) ?)] -> Generalize (id pt); Intro; IntroHypL ?1 pt; IntroHypL ?2 pt
- |[|-(derivable_pt ? ?)] -> Cut ``(aux pt)<>0``; [Intro; IntroHypL ?1 pt; IntroHypL ?2 pt | Try Assumption]
- |[|-(continuity_pt ? ?)] -> Cut ``(aux pt)<>0``; [Intro; IntroHypL ?1 pt; IntroHypL ?2 pt | Try Assumption]
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> Cut ``(aux pt)<>0``; [Intro; IntroHypL ?1 pt; IntroHypL ?2 pt | Try Assumption]
- | _ -> Idtac)
-|[(comp ?1 ?2)] -> 
- (Match Context With
- |[|-(derivable_pt ? ?)] -> Let pt_f1 = (Eval Cbv Beta in (?2 pt)) In IntroHypL ?1 pt_f1; IntroHypL ?2 pt
- |[|-(continuity_pt ? ?)] -> Let pt_f1 = (Eval Cbv Beta in (?2 pt)) In IntroHypL ?1 pt_f1; IntroHypL ?2 pt
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> Let pt_f1 = (Eval Cbv Beta in (?2 pt)) In IntroHypL ?1 pt_f1; IntroHypL ?2 pt
- | _ -> Idtac)
-|[(opp_fct ?1)] -> 
- (Match Context With
- |[|-(derivable_pt ? ?)] -> IntroHypL ?1 pt
- |[|-(continuity_pt ? ?)] -> IntroHypL ?1 pt
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> IntroHypL ?1 pt
- | _ -> Idtac)
-|[(inv_fct ?1)] -> Let aux = ?1 In
- (Match Context With
- |[_:``(aux pt)<>0``|-(derivable_pt ? ?)] -> IntroHypL ?1 pt
- |[_:``(aux pt)<>0``|-(continuity_pt ? ?)] -> IntroHypL ?1 pt
- |[_:``(aux pt)<>0``|-(eqT ? (derive_pt ? ? ?) ?)] -> IntroHypL ?1 pt
- |[id:(x0:R)``(aux x0)<>0``|-(derivable_pt ? ?)] -> Generalize (id pt); Intro; IntroHypL ?1 pt
- |[id:(x0:R)``(aux x0)<>0``|-(continuity_pt ? ?)] -> Generalize (id pt); Intro; IntroHypL ?1 pt
- |[id:(x0:R)``(aux x0)<>0``|-(eqT ? (derive_pt ? ? ?) ?)] -> Generalize (id pt); Intro; IntroHypL ?1 pt
- |[|-(derivable_pt ? ?)] -> Cut ``(aux pt)<>0``; [Intro; IntroHypL ?1 pt | Try Assumption]
- |[|-(continuity_pt ? ?)] -> Cut ``(aux pt)<>0``; [Intro; IntroHypL ?1 pt| Try Assumption]
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> Cut ``(aux pt)<>0``; [Intro; IntroHypL ?1 pt | Try Assumption]
- | _ -> Idtac)
-|[cos] -> Idtac
-|[sin] -> Idtac
-|[cosh] -> Idtac
-|[sinh] -> Idtac
-|[exp] -> Idtac
-|[Rsqr] -> Idtac
-|[id] -> Idtac
-|[(fct_cte ?)] -> Idtac
-|[(pow_fct ?)] -> Idtac
-|[sqrt] ->
- (Match Context With
- |[|-(derivable_pt ? ?)] -> Cut ``0<pt``; [Intro | Try Assumption]
- |[|-(continuity_pt ? ?)] -> Cut ``0<=pt``; [Intro | Try Assumption]
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> Cut ``0<pt``; [Intro | Try Assumption]
- | _ -> Idtac)
-|[Rabsolu] ->
- (Match Context With
- |[|-(derivable_pt ? ?)] -> Cut ``pt<>0``; [Intro | Try Assumption]
- | _ -> Idtac)
-|[?1] -> Let p = ?1 In
- (Match Context With
- |[_:(derivable_pt p pt)|- ?] -> Idtac
- |[|-(derivable_pt p pt)] -> Idtac
- |[|-(derivable_pt ? ?)] -> Cut True -> (derivable_pt p pt); [Intro HYPPD; Cut (derivable_pt p pt); [Intro; Clear HYPPD | Apply HYPPD; Clear HYPPD; Trivial] | Idtac]
- |[_:(continuity_pt p pt)|- ?] -> Idtac
- |[|-(continuity_pt p pt)] -> Idtac
- |[|-(continuity_pt ? ?)] -> Cut True -> (continuity_pt p pt); [Intro HYPPD; Cut (continuity_pt p pt); [Intro; Clear HYPPD | Apply HYPPD; Clear HYPPD; Trivial] | Idtac]
- |[|-(eqT ? (derive_pt ? ? ?) ?)] -> Cut True -> (derivable_pt p pt); [Intro HYPPD; Cut (derivable_pt p pt); [Intro; Clear HYPPD | Apply HYPPD; Clear HYPPD; Trivial] | Idtac]
- | _ -> Idtac).
- 
-(**********)
-Recursive Tactic Definition IsDiff_pt :=
-Match Context With
- (* fonctions de base *)
- [|-(derivable_pt Rsqr ?)] -> Apply derivable_pt_Rsqr
-|[|-(derivable_pt id ?1)] -> Apply (derivable_pt_id ?1)
-|[|-(derivable_pt (fct_cte ?) ?)] -> Apply derivable_pt_const
-|[|-(derivable_pt sin ?)] -> Apply derivable_pt_sin
-|[|-(derivable_pt cos ?)] -> Apply derivable_pt_cos
-|[|-(derivable_pt sinh ?)] -> Apply derivable_pt_sinh
-|[|-(derivable_pt cosh ?)] -> Apply derivable_pt_cosh
-|[|-(derivable_pt exp ?)] -> Apply derivable_pt_exp
-|[|-(derivable_pt (pow_fct ?) ?)] -> Unfold pow_fct; Apply derivable_pt_pow
-|[|-(derivable_pt sqrt ?1)] -> Apply (derivable_pt_sqrt ?1); Assumption Orelse Unfold plus_fct minus_fct opp_fct mult_fct div_fct inv_fct comp id fct_cte pow_fct
-|[|-(derivable_pt Rabsolu ?1)] -> Apply (derivable_pt_Rabsolu ?1); Assumption Orelse Unfold plus_fct minus_fct opp_fct mult_fct div_fct inv_fct comp id fct_cte pow_fct
- (* regles de differentiabilite *)
- (* PLUS *)
-|[|-(derivable_pt (plus_fct ?1 ?2) ?3)] -> Apply (derivable_pt_plus ?1 ?2 ?3); IsDiff_pt
- (* MOINS *)
-|[|-(derivable_pt (minus_fct ?1 ?2) ?3)] -> Apply (derivable_pt_minus ?1 ?2 ?3); IsDiff_pt
- (* OPPOSE *)
-|[|-(derivable_pt (opp_fct ?1) ?2)] -> Apply (derivable_pt_opp ?1 ?2); IsDiff_pt
- (* MULTIPLICATION PAR UN SCALAIRE *)
-|[|-(derivable_pt (mult_real_fct ?1 ?2) ?3)] -> Apply (derivable_pt_scal ?2 ?1 ?3); IsDiff_pt
- (* MULTIPLICATION *)
-|[|-(derivable_pt (mult_fct ?1 ?2) ?3)] -> Apply (derivable_pt_mult ?1 ?2 ?3); IsDiff_pt
-  (* DIVISION *)
- |[|-(derivable_pt (div_fct ?1 ?2) ?3)] -> Apply (derivable_pt_div ?1 ?2 ?3); [IsDiff_pt | IsDiff_pt | Try Assumption Orelse Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct comp pow_fct id fct_cte]
-  (* INVERSION *)
- |[|-(derivable_pt (inv_fct ?1) ?2)] -> Apply (derivable_pt_inv ?1 ?2); [Assumption Orelse Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct comp pow_fct id fct_cte | IsDiff_pt]
- (* COMPOSITION *)
-|[|-(derivable_pt (comp ?1 ?2) ?3)] -> Apply (derivable_pt_comp ?2 ?1 ?3); IsDiff_pt
-|[_:(derivable_pt ?1 ?2)|-(derivable_pt ?1 ?2)] -> Assumption
-|[_:(derivable ?1) |- (derivable_pt ?1 ?2)] -> Cut (derivable ?1); [Intro HypDDPT; Apply HypDDPT | Assumption]
-|[|-True->(derivable_pt ? ?)] -> Intro HypTruE; Clear HypTruE; IsDiff_pt
-| _ -> Try Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct id fct_cte comp pow_fct.
-
-(**********)
-Recursive Tactic Definition IsDiff_glob :=
-Match Context With
- (* fonctions de base *)
-  [|-(derivable Rsqr)] -> Apply derivable_Rsqr
- |[|-(derivable id)] -> Apply derivable_id
- |[|-(derivable (fct_cte ?))] -> Apply derivable_const
- |[|-(derivable sin)] -> Apply derivable_sin
- |[|-(derivable cos)] -> Apply derivable_cos
- |[|-(derivable cosh)] -> Apply derivable_cosh
- |[|-(derivable sinh)] -> Apply derivable_sinh
- |[|-(derivable exp)] -> Apply derivable_exp
- |[|-(derivable (pow_fct ?))] -> Unfold pow_fct; Apply derivable_pow
-  (* regles de differentiabilite *)
-  (* PLUS *)
- |[|-(derivable (plus_fct ?1 ?2))] -> Apply (derivable_plus ?1 ?2); IsDiff_glob
-  (* MOINS *)
- |[|-(derivable (minus_fct ?1 ?2))] -> Apply (derivable_minus ?1 ?2); IsDiff_glob
-  (* OPPOSE *)
- |[|-(derivable (opp_fct ?1))] -> Apply (derivable_opp ?1); IsDiff_glob
-  (* MULTIPLICATION PAR UN SCALAIRE *)
- |[|-(derivable (mult_real_fct ?1 ?2))] -> Apply (derivable_scal ?2 ?1); IsDiff_glob
-  (* MULTIPLICATION *)
- |[|-(derivable (mult_fct ?1 ?2))] -> Apply (derivable_mult ?1 ?2); IsDiff_glob
-  (* DIVISION *)
- |[|-(derivable (div_fct ?1 ?2))] -> Apply (derivable_div ?1 ?2); [IsDiff_glob | IsDiff_glob | Try Assumption Orelse Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct id fct_cte comp pow_fct]
-  (* INVERSION *)
- |[|-(derivable (inv_fct ?1))] -> Apply (derivable_inv ?1); [Try Assumption Orelse Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct id fct_cte comp pow_fct | IsDiff_glob]
-  (* COMPOSITION *)
- |[|-(derivable (comp sqrt ?))] -> Unfold derivable; Intro; Try IsDiff_pt
- |[|-(derivable (comp Rabsolu ?))] -> Unfold derivable; Intro; Try IsDiff_pt
- |[|-(derivable (comp ?1 ?2))] -> Apply (derivable_comp ?2 ?1); IsDiff_glob
- |[_:(derivable ?1)|-(derivable ?1)] -> Assumption
- |[|-True->(derivable ?)] -> Intro HypTruE; Clear HypTruE; IsDiff_glob
- | _ -> Try Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct id fct_cte comp pow_fct.
-
-(**********)
-Recursive Tactic Definition IsCont_pt :=
-Match Context With
- (* fonctions de base *)
- [|-(continuity_pt Rsqr ?)] -> Apply derivable_continuous_pt; Apply derivable_pt_Rsqr
-|[|-(continuity_pt id ?1)] -> Apply derivable_continuous_pt; Apply (derivable_pt_id ?1)
-|[|-(continuity_pt (fct_cte ?) ?)] -> Apply derivable_continuous_pt; Apply derivable_pt_const
-|[|-(continuity_pt sin ?)] -> Apply derivable_continuous_pt; Apply derivable_pt_sin
-|[|-(continuity_pt cos ?)] -> Apply derivable_continuous_pt; Apply derivable_pt_cos
-|[|-(continuity_pt sinh ?)] -> Apply derivable_continuous_pt; Apply derivable_pt_sinh
-|[|-(continuity_pt cosh ?)] -> Apply derivable_continuous_pt; Apply derivable_pt_cosh
-|[|-(continuity_pt exp ?)] -> Apply derivable_continuous_pt; Apply derivable_pt_exp
-|[|-(continuity_pt (pow_fct ?) ?)] -> Unfold pow_fct; Apply derivable_continuous_pt; Apply derivable_pt_pow
-|[|-(continuity_pt sqrt ?1)] -> Apply continuity_pt_sqrt; Assumption Orelse Unfold plus_fct minus_fct opp_fct mult_fct div_fct inv_fct comp id fct_cte pow_fct
-|[|-(continuity_pt Rabsolu ?1)] -> Apply (continuity_Rabsolu ?1)
- (* regles de differentiabilite *)
- (* PLUS *)
-|[|-(continuity_pt (plus_fct ?1 ?2) ?3)] -> Apply (continuity_pt_plus ?1 ?2 ?3); IsCont_pt
- (* MOINS *)
-|[|-(continuity_pt (minus_fct ?1 ?2) ?3)] -> Apply (continuity_pt_minus ?1 ?2 ?3); IsCont_pt
- (* OPPOSE *)
-|[|-(continuity_pt (opp_fct ?1) ?2)] -> Apply (continuity_pt_opp ?1 ?2); IsCont_pt
- (* MULTIPLICATION PAR UN SCALAIRE *)
-|[|-(continuity_pt (mult_real_fct ?1 ?2) ?3)] -> Apply (continuity_pt_scal ?2 ?1 ?3); IsCont_pt
- (* MULTIPLICATION *)
-|[|-(continuity_pt (mult_fct ?1 ?2) ?3)] -> Apply (continuity_pt_mult ?1 ?2 ?3); IsCont_pt
-  (* DIVISION *)
- |[|-(continuity_pt (div_fct ?1 ?2) ?3)] -> Apply (continuity_pt_div ?1 ?2 ?3); [IsCont_pt | IsCont_pt | Try Assumption Orelse Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct comp id fct_cte pow_fct]
-  (* INVERSION *)
- |[|-(continuity_pt (inv_fct ?1) ?2)] -> Apply (continuity_pt_inv ?1 ?2); [IsCont_pt | Assumption Orelse Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct comp id fct_cte pow_fct]
- (* COMPOSITION *)
-|[|-(continuity_pt (comp ?1 ?2) ?3)] -> Apply (continuity_pt_comp ?2 ?1 ?3); IsCont_pt
-|[_:(continuity_pt ?1 ?2)|-(continuity_pt ?1 ?2)] -> Assumption
-|[_:(continuity ?1) |- (continuity_pt ?1 ?2)] -> Cut (continuity ?1); [Intro HypDDPT; Apply HypDDPT | Assumption]
-|[_:(derivable_pt ?1 ?2)|-(continuity_pt ?1 ?2)] -> Apply derivable_continuous_pt; Assumption
-|[_:(derivable ?1)|-(continuity_pt ?1 ?2)] -> Cut (continuity ?1); [Intro HypDDPT; Apply HypDDPT | Apply derivable_continuous; Assumption]
-|[|-True->(continuity_pt ? ?)] -> Intro HypTruE; Clear HypTruE; IsCont_pt
-| _ -> Try Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct id fct_cte comp pow_fct.
-
-(**********)
-Recursive Tactic Definition IsCont_glob :=
-Match Context With
-  (* fonctions de base *)
-  [|-(continuity Rsqr)] -> Apply derivable_continuous; Apply derivable_Rsqr
- |[|-(continuity id)] -> Apply derivable_continuous; Apply derivable_id
- |[|-(continuity (fct_cte ?))] -> Apply derivable_continuous; Apply derivable_const
- |[|-(continuity sin)] -> Apply derivable_continuous; Apply derivable_sin
- |[|-(continuity cos)] -> Apply derivable_continuous; Apply derivable_cos
- |[|-(continuity exp)] -> Apply derivable_continuous; Apply derivable_exp
- |[|-(continuity (pow_fct ?))] -> Unfold pow_fct; Apply derivable_continuous; Apply derivable_pow
- |[|-(continuity sinh)] -> Apply derivable_continuous; Apply derivable_sinh
- |[|-(continuity cosh)] -> Apply derivable_continuous; Apply derivable_cosh
- |[|-(continuity Rabsolu)] -> Apply continuity_Rabsolu
- (* regles de continuite *)
- (* PLUS *)
-|[|-(continuity (plus_fct ?1 ?2))] -> Apply (continuity_plus ?1 ?2); Try IsCont_glob Orelse Assumption
- (* MOINS *)
-|[|-(continuity (minus_fct ?1 ?2))] -> Apply (continuity_minus ?1 ?2); Try IsCont_glob Orelse Assumption
- (* OPPOSE *)
-|[|-(continuity (opp_fct ?1))] -> Apply (continuity_opp ?1); Try IsCont_glob Orelse Assumption
- (* INVERSE *)
-|[|-(continuity (inv_fct ?1))] -> Apply (continuity_inv ?1); Try IsCont_glob Orelse Assumption
- (* MULTIPLICATION PAR UN SCALAIRE *)
-|[|-(continuity (mult_real_fct ?1 ?2))] -> Apply (continuity_scal ?2 ?1); Try IsCont_glob Orelse Assumption
- (* MULTIPLICATION *)
-|[|-(continuity (mult_fct ?1 ?2))] -> Apply (continuity_mult ?1 ?2); Try IsCont_glob Orelse Assumption
-  (* DIVISION *)
- |[|-(continuity (div_fct ?1 ?2))] -> Apply (continuity_div ?1 ?2); [Try IsCont_glob Orelse Assumption | Try IsCont_glob Orelse Assumption | Try Assumption Orelse Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct id fct_cte pow_fct]
-  (* COMPOSITION *)
- |[|-(continuity (comp sqrt ?))] -> Unfold continuity_pt; Intro; Try IsCont_pt
- |[|-(continuity (comp ?1 ?2))] -> Apply (continuity_comp ?2 ?1); Try IsCont_glob Orelse Assumption
- |[_:(continuity ?1)|-(continuity ?1)] -> Assumption
- |[|-True->(continuity ?)] -> Intro HypTruE; Clear HypTruE; IsCont_glob
- |[_:(derivable ?1)|-(continuity ?1)] -> Apply derivable_continuous; Assumption
- | _ -> Try Unfold plus_fct mult_fct div_fct minus_fct opp_fct inv_fct id fct_cte comp pow_fct.
-
-(**********)
-Recursive Tactic Definition RewTerm trm :=
-Match trm With
-| [(Rplus ?1 ?2)] -> Let p1= (RewTerm ?1) And p2 = (RewTerm ?2) In 
-  (Match p1 With
-   [(fct_cte ?3)] -> 
-    (Match p2 With
-    | [(fct_cte ?4)] -> '(fct_cte (Rplus ?3 ?4))
-    | _ -> '(plus_fct p1 p2))
-  | _ -> '(plus_fct p1 p2))
-| [(Rminus ?1 ?2)] -> Let p1 = (RewTerm ?1) And p2 = (RewTerm ?2) In
-  (Match p1 With
-   [(fct_cte ?3)] -> 
-    (Match p2 With
-    | [(fct_cte ?4)] -> '(fct_cte (Rminus ?3 ?4))
-    | _ -> '(minus_fct p1 p2))
-  | _ -> '(minus_fct p1 p2))
-| [(Rdiv ?1 ?2)] -> Let p1 = (RewTerm ?1) And p2 = (RewTerm ?2) In
-  (Match p1 With
-   [(fct_cte ?3)] -> 
-    (Match p2 With
-    | [(fct_cte ?4)] -> '(fct_cte (Rdiv ?3 ?4))
-    | _ -> '(div_fct p1 p2))
-  | _ -> 
-    (Match p2 With
-    | [(fct_cte ?4)] -> '(mult_fct p1 (fct_cte (Rinv ?4)))
-    | _ -> '(div_fct p1 p2)))
-| [(Rmult ?1 (Rinv ?2))] -> Let p1 = (RewTerm ?1) And p2 = (RewTerm ?2) In
-  (Match p1 With
-   [(fct_cte ?3)] -> 
-    (Match p2 With
-    | [(fct_cte ?4)] -> '(fct_cte (Rdiv ?3 ?4))
-    | _ -> '(div_fct p1 p2))
-  | _ -> 
-   (Match p2 With
-   | [(fct_cte ?4)] -> '(mult_fct p1 (fct_cte (Rinv ?4)))
-   | _ -> '(div_fct p1 p2)))
-| [(Rmult ?1 ?2)] -> Let p1 = (RewTerm ?1) And p2 = (RewTerm ?2) In
-  (Match p1 With
-   [(fct_cte ?3)] -> 
-    (Match p2 With
-    | [(fct_cte ?4)] -> '(fct_cte (Rmult ?3 ?4))
-    | _ -> '(mult_fct p1 p2))
-  | _ -> '(mult_fct p1 p2))
-| [(Ropp ?1)] -> Let p = (RewTerm ?1) In 
-  (Match p With
-   [(fct_cte ?2)] -> '(fct_cte (Ropp ?2))
-   | _ -> '(opp_fct p))
-| [(Rinv ?1)] -> Let p = (RewTerm ?1) In 
-  (Match p With
-   [(fct_cte ?2)] -> '(fct_cte (Rinv ?2))
-   | _ -> '(inv_fct p))
-| [(?1 AppVar)] -> '?1
-| [(?1 ?2)] -> Let p = (RewTerm ?2) In 
- (Match p With
- | [(fct_cte ?3)] -> '(fct_cte (?1 ?3))
- | _ -> '(comp ?1 p))
-| [AppVar] -> 'id
-| [(pow AppVar ?1)] -> '(pow_fct ?1)
-| [(pow ?1 ?2)] -> Let p = (RewTerm ?1) In 
- (Match p With
- | [(fct_cte ?3)] -> '(fct_cte (pow_fct ?2 ?3))
- | _ -> '(comp (pow_fct ?2) p))
-| [?1]-> '(fct_cte ?1).
-
-(**********)
-Recursive Tactic Definition ConsProof trm pt :=
-Match trm With
-| [(plus_fct ?1 ?2)] -> Let p1 = (ConsProof ?1 pt) And p2 = (ConsProof ?2 pt) In '(derivable_pt_plus ?1 ?2 pt p1 p2)
-| [(minus_fct ?1 ?2)] -> Let p1 = (ConsProof ?1 pt) And p2 = (ConsProof ?2 pt) In '(derivable_pt_minus ?1 ?2 pt p1 p2)
-| [(mult_fct ?1 ?2)] -> Let p1 = (ConsProof ?1 pt) And p2 = (ConsProof ?2 pt) In '(derivable_pt_mult ?1 ?2 pt p1 p2)
-| [(div_fct ?1 ?2)] ->
- (Match Context With
- |[id:~((?2 pt)==R0) |- ?] -> Let p1 = (ConsProof ?1 pt) And p2 = (ConsProof ?2 pt) In '(derivable_pt_div ?1 ?2 pt p1 p2 id)
- | _ -> 'False)
-| [(inv_fct ?1)] ->
- (Match Context With
- |[id:~((?1 pt)==R0) |- ?] -> Let p1 = (ConsProof ?1 pt) In '(derivable_pt_inv ?1 pt p1 id)
- | _ -> 'False)
-| [(comp ?1 ?2)] -> Let pt_f1 = (Eval Cbv Beta in (?2 pt)) In Let p1 = (ConsProof ?1 pt_f1) And p2 = (ConsProof ?2 pt) In '(derivable_pt_comp ?2 ?1 pt p2 p1)
-| [(opp_fct ?1)] -> Let p1 = (ConsProof ?1 pt) In '(derivable_pt_opp ?1 pt p1)
-| [sin] -> '(derivable_pt_sin pt)
-| [cos] -> '(derivable_pt_cos pt)
-| [sinh] -> '(derivable_pt_sinh pt)
-| [cosh] -> '(derivable_pt_cosh pt)
-| [exp] -> '(derivable_pt_exp pt)
-| [id] -> '(derivable_pt_id pt)
-| [Rsqr] -> '(derivable_pt_Rsqr pt)
-| [sqrt] ->
- (Match Context With
- |[id:(Rlt R0 pt) |- ?] -> '(derivable_pt_sqrt pt id)
- | _ -> 'False)
-| [(fct_cte ?1)] -> '(derivable_pt_const ?1 pt)
-| [?1] -> Let aux = ?1 In
- (Match Context With
-    [ id : (derivable_pt aux pt) |- ?] -> 'id
-   |[ id : (derivable aux) |- ?] -> '(id pt)
-   | _ -> 'False).
-
-(**********)
-Recursive Tactic Definition SimplifyDerive trm pt :=
-Match trm With
-| [(plus_fct ?1 ?2)] -> Try Rewrite derive_pt_plus; SimplifyDerive ?1 pt; SimplifyDerive ?2 pt
-| [(minus_fct ?1 ?2)] -> Try Rewrite derive_pt_minus; SimplifyDerive ?1 pt; SimplifyDerive ?2 pt
-| [(mult_fct ?1 ?2)] -> Try Rewrite derive_pt_mult; SimplifyDerive ?1 pt; SimplifyDerive ?2 pt
-| [(div_fct ?1 ?2)] -> Try Rewrite derive_pt_div; SimplifyDerive ?1 pt; SimplifyDerive ?2 pt
-| [(comp ?1 ?2)] -> Let pt_f1 = (Eval Cbv Beta in (?2 pt)) In Try Rewrite derive_pt_comp; SimplifyDerive ?1 pt_f1; SimplifyDerive ?2 pt
-| [(opp_fct ?1)] -> Try Rewrite derive_pt_opp; SimplifyDerive ?1 pt
-| [(inv_fct ?1)] -> Try Rewrite derive_pt_inv; SimplifyDerive ?1 pt
-| [(fct_cte ?1)] -> Try Rewrite derive_pt_const
-| [id] -> Try Rewrite derive_pt_id
-| [sin] -> Try Rewrite derive_pt_sin
-| [cos] -> Try Rewrite derive_pt_cos
-| [sinh] -> Try Rewrite derive_pt_sinh
-| [cosh] -> Try Rewrite derive_pt_cosh
-| [exp] -> Try Rewrite derive_pt_exp
-| [Rsqr] -> Try Rewrite derive_pt_Rsqr
-| [sqrt] -> Try Rewrite derive_pt_sqrt
-| [?1] -> Let aux = ?1 In
-  (Match Context With
-    [ id : (eqT ? (derive_pt aux pt ?2) ?); H : (derivable aux) |- ? ] -> Try Replace (derive_pt aux pt (H pt)) with (derive_pt aux pt ?2); [Rewrite id | Apply pr_nu]
-    |[ id : (eqT ? (derive_pt aux pt ?2) ?); H : (derivable_pt aux pt) |- ? ] -> Try Replace (derive_pt aux pt H) with (derive_pt aux pt ?2); [Rewrite id | Apply pr_nu]
-    | _ -> Idtac )
-| _ -> Idtac.
-
-(**********)
-Tactic Definition Reg :=
-Match Context With
-| [|-(derivable_pt ?1 ?2)] -> 
-Let trm = Eval Cbv Beta in (?1 AppVar) In
-Let aux = (RewTerm trm) In IntroHypL aux ?2; Try (Change (derivable_pt aux ?2); IsDiff_pt) Orelse IsDiff_pt
-| [|-(derivable ?1)] ->
-Let trm = Eval Cbv Beta in (?1 AppVar) In
-Let aux = (RewTerm trm) In IntroHypG aux; Try (Change (derivable aux); IsDiff_glob) Orelse IsDiff_glob
-| [|-(continuity ?1)] ->
-Let trm = Eval Cbv Beta in (?1 AppVar) In
-Let aux = (RewTerm trm) In IntroHypG aux; Try (Change (continuity aux); IsCont_glob) Orelse IsCont_glob
-| [|-(continuity_pt ?1 ?2)] ->
-Let trm = Eval Cbv Beta in (?1 AppVar) In
-Let aux = (RewTerm trm) In IntroHypL aux ?2; Try (Change (continuity_pt aux ?2); IsCont_pt) Orelse IsCont_pt
-| [|-(eqT ? (derive_pt ?1 ?2 ?3) ?4)] -> 
-Let trm = Eval Cbv Beta in (?1 AppVar) In
-Let aux = (RewTerm trm) In
-IntroHypL aux ?2; Let aux2 = (ConsProof aux ?2) In Try (Replace (derive_pt ?1 ?2 ?3) with (derive_pt aux ?2 aux2); [SimplifyDerive aux ?2; Try Unfold plus_fct minus_fct mult_fct div_fct id fct_cte inv_fct opp_fct; Try Ring | Try Apply pr_nu]) Orelse IsDiff_pt.
diff --git a/theories7/Reals/Ranalysis1.v b/theories7/Reals/Ranalysis1.v
deleted file mode 100644
index 8cb4c358..00000000
--- a/theories7/Reals/Ranalysis1.v
+++ /dev/null
@@ -1,1046 +0,0 @@
-(************************************************************************)
-(*  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: Ranalysis1.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Export Rlimit.
-Require Export Rderiv.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-Implicit Variable Type f:R->R.
-
-(****************************************************)
-(**           Basic operations on functions         *)
-(****************************************************)
-Definition plus_fct [f1,f2:R->R] : R->R := [x:R] ``(f1 x)+(f2 x)``.
-Definition opp_fct [f:R->R] : R->R := [x:R] ``-(f x)``.
-Definition mult_fct [f1,f2:R->R] : R->R := [x:R] ``(f1 x)*(f2 x)``.
-Definition mult_real_fct [a:R;f:R->R] : R->R := [x:R] ``a*(f x)``.
-Definition minus_fct [f1,f2:R->R] : R->R := [x:R] ``(f1 x)-(f2 x)``.
-Definition div_fct [f1,f2:R->R] : R->R := [x:R] ``(f1 x)/(f2 x)``.
-Definition div_real_fct [a:R;f:R->R] : R->R := [x:R] ``a/(f x)``.
-Definition comp [f1,f2:R->R] : R->R := [x:R] ``(f1 (f2 x))``.
-Definition inv_fct [f:R->R] : R->R := [x:R]``/(f x)``.
-
-V8Infix "+" plus_fct : Rfun_scope.
-V8Notation "- x" := (opp_fct x) : Rfun_scope.
-V8Infix "*" mult_fct : Rfun_scope.
-V8Infix "-" minus_fct : Rfun_scope.
-V8Infix "/" div_fct : Rfun_scope.
-Notation Local "f1 'o' f2" := (comp f1 f2) (at level 2, right associativity)
-  : Rfun_scope 
-  V8only (at level 20, right associativity).
-V8Notation "/ x" := (inv_fct x) : Rfun_scope.
-
-Delimits Scope Rfun_scope with F.
-
-Definition fct_cte [a:R] : R->R := [x:R]a.
-Definition id := [x:R]x.
-
-(****************************************************)
-(**            Variations of functions              *)
-(****************************************************)
-Definition increasing [f:R->R] : Prop := (x,y:R) ``x<=y``->``(f x)<=(f y)``.
-Definition decreasing [f:R->R] : Prop := (x,y:R) ``x<=y``->``(f y)<=(f x)``.
-Definition strict_increasing [f:R->R] : Prop := (x,y:R) ``x<y``->``(f x)<(f y)``.
-Definition strict_decreasing [f:R->R] : Prop := (x,y:R) ``x<y``->``(f y)<(f x)``.
-Definition constant [f:R->R] : Prop := (x,y:R) ``(f x)==(f y)``.
-  
-(**********) 
-Definition no_cond : R->Prop := [x:R] True.
-
-(**********)
-Definition constant_D_eq [f:R->R;D:R->Prop;c:R] : Prop := (x:R) (D x) -> (f x)==c.
-
-(***************************************************)
-(**      Definition of continuity as a limit       *)
-(***************************************************)
-
-(**********)
-Definition continuity_pt [f:R->R; x0:R] : Prop := (continue_in f no_cond x0).
-Definition continuity [f:R->R] : Prop := (x:R) (continuity_pt f x).
-
-Arguments Scope continuity_pt [Rfun_scope R_scope].
-Arguments Scope continuity [Rfun_scope].
-
-(**********)
-Lemma continuity_pt_plus : (f1,f2:R->R; x0:R) (continuity_pt f1 x0) -> (continuity_pt f2 x0) -> (continuity_pt (plus_fct f1 f2) x0).
-Unfold continuity_pt plus_fct; Unfold continue_in; Intros; Apply limit_plus; Assumption.
-Qed.
-
-Lemma continuity_pt_opp : (f:R->R; x0:R) (continuity_pt f x0) -> (continuity_pt (opp_fct f) x0).
-Unfold continuity_pt opp_fct; Unfold continue_in; Intros; Apply limit_Ropp; Assumption.
-Qed.
- 
-Lemma continuity_pt_minus : (f1,f2:R->R; x0:R) (continuity_pt f1 x0) -> (continuity_pt f2 x0) -> (continuity_pt (minus_fct f1 f2) x0).
-Unfold continuity_pt minus_fct; Unfold continue_in; Intros; Apply limit_minus; Assumption.
-Qed.
-
-Lemma continuity_pt_mult : (f1,f2:R->R; x0:R) (continuity_pt f1 x0) -> (continuity_pt f2 x0) -> (continuity_pt (mult_fct f1 f2) x0).
-Unfold continuity_pt mult_fct; Unfold continue_in; Intros; Apply limit_mul; Assumption.
-Qed.
-
-Lemma continuity_pt_const : (f:R->R; x0:R) (constant f) -> (continuity_pt f x0).
-Unfold constant continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Intros; Exists ``1``; Split; [Apply Rlt_R0_R1 | Intros; Generalize (H x x0); Intro; Rewrite H2; Simpl; Rewrite R_dist_eq; Assumption].
-Qed.
-
-Lemma continuity_pt_scal : (f:R->R;a:R; x0:R) (continuity_pt f x0) -> (continuity_pt (mult_real_fct a f) x0).
-Unfold continuity_pt mult_real_fct; Unfold continue_in; Intros; Apply (limit_mul ([x:R] a) f (D_x no_cond x0) a (f x0) x0).
-Unfold limit1_in; Unfold limit_in; Intros; Exists ``1``; Split.
-Apply Rlt_R0_R1.
-Intros; Rewrite R_dist_eq; Assumption.
-Assumption.
-Qed.
-
-Lemma continuity_pt_inv : (f:R->R; x0:R) (continuity_pt f x0) -> ~``(f x0)==0`` -> (continuity_pt (inv_fct f) x0).
-Intros.
-Replace (inv_fct f) with [x:R]``/(f x)``.
-Unfold continuity_pt; Unfold continue_in; Intros; Apply limit_inv; Assumption.
-Unfold inv_fct; Reflexivity.
-Qed.
- 
-Lemma div_eq_inv : (f1,f2:R->R) (div_fct f1 f2)==(mult_fct f1 (inv_fct f2)).
-Intros; Reflexivity.
-Qed.
- 
-Lemma continuity_pt_div : (f1,f2:R->R; x0:R) (continuity_pt f1 x0) -> (continuity_pt f2 x0) -> ~``(f2 x0)==0`` -> (continuity_pt (div_fct f1 f2) x0).
-Intros; Rewrite -> (div_eq_inv f1 f2); Apply continuity_pt_mult; [Assumption | Apply continuity_pt_inv; Assumption].
-Qed.
-
-Lemma continuity_pt_comp : (f1,f2:R->R;x:R) (continuity_pt f1 x) -> (continuity_pt f2 (f1 x)) -> (continuity_pt (comp f2 f1) x).
-Unfold continuity_pt; Unfold continue_in; Intros; Unfold comp.
-Cut (limit1_in [x0:R](f2 (f1 x0)) (Dgf (D_x no_cond x) (D_x no_cond (f1 x)) f1)
-(f2 (f1 x)) x) -> (limit1_in [x0:R](f2 (f1 x0)) (D_x no_cond x) (f2 (f1 x)) x).
-Intro; Apply H1.
-EApply limit_comp.
-Apply H.
-Apply H0.
-Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Assert H3 := (H1 eps H2).
-Elim H3; Intros.
-Exists x0.
-Split.
-Elim H4; Intros; Assumption.
-Intros; Case (Req_EM (f1 x) (f1 x1)); Intro.
-Rewrite H6; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Elim H4; Intros; Apply H8.
-Split.
-Unfold Dgf D_x no_cond.
-Split.
-Split.
-Trivial.
-Elim H5; Unfold D_x no_cond; Intros.
-Elim H9; Intros; Assumption.
-Split.
-Trivial.
-Assumption.
-Elim H5; Intros; Assumption.
-Qed.
-
-(**********) 
-Lemma continuity_plus : (f1,f2:R->R) (continuity f1)->(continuity f2)->(continuity (plus_fct f1 f2)).
-Unfold continuity; Intros; Apply (continuity_pt_plus f1 f2 x (H x) (H0 x)).
-Qed.
-
-Lemma continuity_opp : (f:R->R) (continuity f)->(continuity (opp_fct f)).
-Unfold continuity; Intros; Apply (continuity_pt_opp f x (H x)).
-Qed.
-
-Lemma continuity_minus : (f1,f2:R->R) (continuity f1)->(continuity f2)->(continuity (minus_fct f1 f2)).
-Unfold continuity; Intros; Apply (continuity_pt_minus f1 f2 x (H x) (H0 x)).
-Qed.
- 
-Lemma continuity_mult : (f1,f2:R->R) (continuity f1)->(continuity f2)->(continuity (mult_fct f1 f2)).
-Unfold continuity; Intros; Apply (continuity_pt_mult f1 f2 x (H x) (H0 x)).
-Qed.
-
-Lemma continuity_const : (f:R->R) (constant f) -> (continuity f).
-Unfold continuity; Intros; Apply (continuity_pt_const f x H).
-Qed.
-
-Lemma continuity_scal : (f:R->R;a:R) (continuity f) -> (continuity (mult_real_fct a f)).
-Unfold continuity; Intros; Apply (continuity_pt_scal f a x (H x)).
-Qed.
-  
-Lemma continuity_inv : (f:R->R) (continuity f)->((x:R) ~``(f x)==0``)->(continuity (inv_fct f)).
-Unfold continuity; Intros; Apply (continuity_pt_inv f x (H x) (H0 x)).
-Qed.
-
-Lemma continuity_div : (f1,f2:R->R) (continuity f1)->(continuity f2)->((x:R) ~``(f2 x)==0``)->(continuity (div_fct f1 f2)).
-Unfold continuity; Intros; Apply (continuity_pt_div f1 f2 x (H x) (H0 x) (H1 x)).
-Qed.
- 
-Lemma continuity_comp : (f1,f2:R->R) (continuity f1) -> (continuity f2) -> (continuity (comp f2 f1)).
-Unfold continuity; Intros.
-Apply (continuity_pt_comp f1 f2 x (H x) (H0 (f1 x))).
-Qed.
-
-
-(*****************************************************)
-(**  Derivative's definition using Landau's kernel   *)
-(*****************************************************)
-
-Definition derivable_pt_lim [f:R->R;x,l:R] : Prop := ((eps:R) ``0<eps``->(EXT delta : posreal | ((h:R) ~``h==0``->``(Rabsolu h)<delta`` -> ``(Rabsolu ((((f (x+h))-(f x))/h)-l))<eps``))).
-
-Definition derivable_pt_abs [f:R->R;x:R] : R -> Prop := [l:R](derivable_pt_lim f x l).
-
-Definition derivable_pt [f:R->R;x:R] := (SigT R (derivable_pt_abs f x)).
-Definition derivable [f:R->R] := (x:R)(derivable_pt f x).
-
-Definition derive_pt [f:R->R;x:R;pr:(derivable_pt f x)] := (projT1 ? ? pr).
-Definition derive [f:R->R;pr:(derivable f)] := [x:R](derive_pt f x (pr x)).
-
-Arguments Scope derivable_pt_lim [Rfun_scope R_scope].
-Arguments Scope derivable_pt_abs [Rfun_scope R_scope R_scope].
-Arguments Scope derivable_pt [Rfun_scope R_scope].
-Arguments Scope derivable [Rfun_scope].
-Arguments Scope derive_pt [Rfun_scope R_scope _].
-Arguments Scope derive [Rfun_scope _].
-
-Definition antiderivative [f,g:R->R;a,b:R] : Prop := ((x:R)``a<=x<=b``->(EXT pr : (derivable_pt g x) | (f x)==(derive_pt g x pr)))/\``a<=b``.
-(************************************)
-(** Class of differential functions *)
-(************************************)
-Record Differential : Type := mkDifferential {
-d1 :> R->R;
-cond_diff : (derivable d1) }.
- 
-Record Differential_D2 : Type := mkDifferential_D2 {
-d2 :> R->R;
-cond_D1 : (derivable d2);
-cond_D2 : (derivable (derive d2 cond_D1)) }.
-
-(**********)
-Lemma unicite_step1 : (f:R->R;x,l1,l2:R) (limit1_in [h:R]``((f (x+h))-(f x))/h`` [h:R]``h<>0`` l1 R0) -> (limit1_in [h:R]``((f (x+h))-(f x))/h`` [h:R]``h<>0`` l2 R0) -> l1 == l2.
-Intros; Apply (single_limit [h:R]``((f (x+h))-(f x))/h`` [h:R]``h<>0`` l1 l2 R0); Try Assumption.
-Unfold adhDa; Intros; Exists ``alp/2``.
-Split.
-Unfold Rdiv; Apply prod_neq_R0.
-Red; Intro; Rewrite H2 in H1; Elim (Rlt_antirefl ? H1).
-Apply Rinv_neq_R0; DiscrR.
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Unfold Rdiv; Rewrite Rabsolu_mult.
-Replace ``(Rabsolu (/2))`` with ``/2``.
-Replace (Rabsolu alp) with alp.
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Rewrite (Rmult_sym ``2``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR]; Rewrite Rmult_1r; Rewrite double; Pattern 1 alp; Replace alp with ``alp+0``; [Idtac | Ring]; Apply Rlt_compatibility; Assumption.
-Symmetry; Apply Rabsolu_right; Left; Assumption.
-Symmetry; Apply Rabsolu_right; Left; Change ``0</2``; Apply Rlt_Rinv; Sup0. 
-Qed.
-
-Lemma unicite_step2 : (f:R->R;x,l:R) (derivable_pt_lim f x l) -> (limit1_in [h:R]``((f (x+h))-(f x))/h`` [h:R]``h<>0`` l R0).
-Unfold derivable_pt_lim; Intros; Unfold limit1_in; Unfold limit_in; Intros.
-Assert H1 := (H eps H0).
-Elim H1 ; Intros.
-Exists (pos x0).
-Split.
-Apply (cond_pos x0).
-Simpl; Unfold R_dist; Intros.
-Elim H3; Intros.
-Apply H2; [Assumption |Unfold Rminus in H5; Rewrite Ropp_O in H5; Rewrite Rplus_Or in H5; Assumption].
-Qed.
-
-Lemma unicite_step3 : (f:R->R;x,l:R) (limit1_in [h:R]``((f (x+h))-(f x))/h`` [h:R]``h<>0`` l R0) -> (derivable_pt_lim f x l).
-Unfold limit1_in derivable_pt_lim; Unfold limit_in; Unfold dist; Simpl; Intros.
-Elim (H eps H0).
-Intros; Elim H1; Intros.
-Exists (mkposreal x0 H2).
-Simpl; Intros; Unfold R_dist in H3; Apply (H3 h).
-Split; [Assumption | Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Assumption].
-Qed.
-
-Lemma unicite_limite : (f:R->R;x,l1,l2:R) (derivable_pt_lim f x l1) -> (derivable_pt_lim f x l2) -> l1==l2.
-Intros.
-Assert H1 := (unicite_step2 ? ? ? H).
-Assert H2 := (unicite_step2 ? ? ? H0).
-Assert H3 := (unicite_step1 ? ? ? ? H1 H2).
-Assumption.
-Qed.
-
-Lemma derive_pt_eq : (f:R->R;x,l:R;pr:(derivable_pt f x)) (derive_pt f x pr)==l <-> (derivable_pt_lim f x l).
-Intros; Split.
-Intro; Assert H1 := (projT2 ? ? pr); Unfold derive_pt in H; Rewrite H in H1; Assumption.
-Intro; Assert H1 := (projT2 ? ? pr); Unfold derivable_pt_abs in H1.
-Assert H2 := (unicite_limite ? ? ? ? H H1).
-Unfold derive_pt; Unfold derivable_pt_abs.
-Symmetry; Assumption.
-Qed.
-
-(**********)
-Lemma derive_pt_eq_0 : (f:R->R;x,l:R;pr:(derivable_pt f x)) (derivable_pt_lim f x l) -> (derive_pt f x pr)==l.
-Intros; Elim (derive_pt_eq f x l pr); Intros.
-Apply (H1 H).
-Qed.
-
-(**********)
-Lemma derive_pt_eq_1 : (f:R->R;x,l:R;pr:(derivable_pt f x)) (derive_pt f x pr)==l -> (derivable_pt_lim f x l).
-Intros; Elim (derive_pt_eq f x l pr); Intros.
-Apply (H0 H).
-Qed.
-
-
-(********************************************************************)
-(** Equivalence of this definition with the one using limit concept *)
-(********************************************************************)
-Lemma derive_pt_D_in : (f,df:R->R;x:R;pr:(derivable_pt f x)) (D_in f df no_cond x) <-> (derive_pt f x pr)==(df x).
-Intros; Split.
-Unfold D_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros.
-Apply derive_pt_eq_0. 
-Unfold derivable_pt_lim.
-Intros; Elim (H eps H0); Intros alpha H1; Elim H1; Intros;  Exists (mkposreal alpha H2); Intros; Generalize (H3 ``x+h``); Intro; Cut ``x+h-x==h``; [Intro; Cut ``(D_x no_cond x (x+h))``/\``(Rabsolu (x+h-x)) < alpha``; [Intro; Generalize (H6 H8); Rewrite H7; Intro; Assumption | Split; [Unfold D_x; Split; [Unfold no_cond; Trivial | Apply Rminus_not_eq_right; Rewrite H7; Assumption] | Rewrite H7; Assumption]] | Ring].
-Intro.
-Assert H0 := (derive_pt_eq_1 f x (df x) pr H).
-Unfold D_in; Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Elim (H0 eps H1); Intros alpha H2; Exists (pos alpha); Split.
-Apply (cond_pos alpha).
-Intros; Elim H3; Intros; Unfold D_x in H4; Elim H4; Intros; Cut ``x0-x<>0``.
-Intro; Generalize (H2 ``x0-x`` H8 H5); Replace ``x+(x0-x)`` with x0.
-Intro; Assumption.
-Ring.
-Auto with real.
-Qed.
-
-Lemma derivable_pt_lim_D_in : (f,df:R->R;x:R) (D_in f df no_cond x) <-> (derivable_pt_lim f x (df x)).
-Intros; Split.
-Unfold D_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros.
-Unfold derivable_pt_lim.
-Intros; Elim (H eps H0); Intros alpha H1; Elim H1; Intros;  Exists (mkposreal alpha H2); Intros; Generalize (H3 ``x+h``); Intro; Cut ``x+h-x==h``; [Intro; Cut ``(D_x no_cond x (x+h))``/\``(Rabsolu (x+h-x)) < alpha``; [Intro; Generalize (H6 H8); Rewrite H7; Intro; Assumption | Split; [Unfold D_x; Split; [Unfold no_cond; Trivial | Apply Rminus_not_eq_right; Rewrite H7; Assumption] | Rewrite H7; Assumption]] | Ring].
-Intro.
-Unfold derivable_pt_lim in H.
-Unfold D_in; Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Elim (H eps H0); Intros alpha H2; Exists (pos alpha); Split.
-Apply (cond_pos alpha).
-Intros.
-Elim H1; Intros; Unfold D_x in H3; Elim H3; Intros; Cut ``x0-x<>0``.
-Intro; Generalize (H2 ``x0-x`` H7 H4); Replace ``x+(x0-x)`` with x0.
-Intro; Assumption.
-Ring.
-Auto with real.
-Qed.
-
-
-(***********************************)
-(**   derivability -> continuity   *)
-(***********************************)
-(**********)
-Lemma derivable_derive : (f:R->R;x:R;pr:(derivable_pt f x)) (EXT l : R | (derive_pt f x pr)==l).
-Intros; Exists (projT1  ? ? pr).
-Unfold derive_pt; Reflexivity.
-Qed.
-
-Theorem derivable_continuous_pt : (f:R->R;x:R) (derivable_pt f x) -> (continuity_pt f x).
-Intros.
-Generalize (derivable_derive f x X); Intro.
-Elim H; Intros l H1.
-Cut l==((fct_cte l) x).
-Intro.
-Rewrite H0 in H1.
-Generalize (derive_pt_D_in f (fct_cte l) x); Intro.
-Elim (H2 X); Intros.
-Generalize (H4 H1); Intro.
-Unfold continuity_pt.
-Apply (cont_deriv f (fct_cte l) no_cond x H5).
-Unfold fct_cte; Reflexivity.
-Qed.
-
-Theorem derivable_continuous : (f:R->R) (derivable f) -> (continuity f).
-Unfold derivable continuity; Intros.
-Apply (derivable_continuous_pt f x (X x)).
-Qed.
-
-(****************************************************************)
-(**                      Main rules                             *)
-(****************************************************************)
-
-Lemma derivable_pt_lim_plus : (f1,f2:R->R;x,l1,l2:R) (derivable_pt_lim f1 x l1) -> (derivable_pt_lim f2 x l2) -> (derivable_pt_lim (plus_fct f1 f2) x ``l1+l2``).
-Intros.
-Apply unicite_step3.
-Assert H1 := (unicite_step2 ? ? ? H).
-Assert H2 := (unicite_step2 ? ? ? H0).
-Unfold  plus_fct.
-Cut (h:R)``((f1 (x+h))+(f2 (x+h))-((f1 x)+(f2 x)))/h``==``((f1 (x+h))-(f1 x))/h+((f2 (x+h))-(f2 x))/h``.
-Intro.
-Generalize(limit_plus [h':R]``((f1 (x+h'))-(f1 x))/h'`` [h':R]``((f2 (x+h'))-(f2 x))/h'`` [h:R]``h <> 0`` l1 l2 ``0`` H1 H2).
-Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Elim (H4 eps H5); Intros.
-Exists x0.
-Elim H6; Intros.
-Split.
-Assumption.
-Intros; Rewrite H3; Apply H8; Assumption.
-Intro; Unfold Rdiv; Ring.
-Qed.
-
-Lemma derivable_pt_lim_opp : (f:R->R;x,l:R) (derivable_pt_lim f x l) -> (derivable_pt_lim (opp_fct f) x (Ropp l)).
-Intros.
-Apply unicite_step3.
-Assert H1 := (unicite_step2 ? ? ? H).
-Unfold opp_fct.
-Cut (h:R) ``( -(f (x+h))- -(f x))/h``==(Ropp ``((f (x+h))-(f x))/h``).
-Intro.
-Generalize (limit_Ropp [h:R]``((f (x+h))-(f x))/h``[h:R]``h <> 0`` l ``0`` H1).
-Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Elim (H2 eps H3); Intros.
-Exists x0.
-Elim H4; Intros.
-Split.
-Assumption.
-Intros; Rewrite H0; Apply H6; Assumption.
-Intro; Unfold Rdiv; Ring.
-Qed.
-
-Lemma derivable_pt_lim_minus : (f1,f2:R->R;x,l1,l2:R) (derivable_pt_lim f1 x l1) -> (derivable_pt_lim f2 x l2) -> (derivable_pt_lim (minus_fct f1 f2) x ``l1-l2``).
-Intros.
-Apply unicite_step3.
-Assert H1 := (unicite_step2 ? ? ? H).
-Assert H2 := (unicite_step2 ? ? ? H0).
-Unfold  minus_fct.
-Cut (h:R)``((f1 (x+h))-(f1 x))/h-((f2 (x+h))-(f2 x))/h``==``((f1 (x+h))-(f2 (x+h))-((f1 x)-(f2 x)))/h``.
-Intro.
-Generalize (limit_minus [h':R]``((f1 (x+h'))-(f1 x))/h'`` [h':R]``((f2 (x+h'))-(f2 x))/h'`` [h:R]``h <> 0`` l1 l2 ``0`` H1 H2).
-Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Elim (H4 eps H5); Intros.
-Exists x0.
-Elim H6; Intros.
-Split.
-Assumption.
-Intros; Rewrite <- H3; Apply H8; Assumption.
-Intro; Unfold Rdiv; Ring.
-Qed.
-
-Lemma derivable_pt_lim_mult : (f1,f2:R->R;x,l1,l2:R) (derivable_pt_lim f1 x l1) -> (derivable_pt_lim f2 x l2) -> (derivable_pt_lim (mult_fct f1 f2) x ``l1*(f2 x)+(f1 x)*l2``).
-Intros.
-Assert H1 := (derivable_pt_lim_D_in f1 [y:R]l1 x).
-Elim H1; Intros.
-Assert H4 := (H3 H).
-Assert H5 := (derivable_pt_lim_D_in f2 [y:R]l2 x).
-Elim H5; Intros.
-Assert H8 := (H7 H0).
-Clear H1 H2 H3 H5 H6 H7.
-Assert H1 := (derivable_pt_lim_D_in (mult_fct f1 f2) [y:R]``l1*(f2 x)+(f1 x)*l2`` x).
-Elim H1; Intros.
-Clear H1 H3.
-Apply H2.
-Unfold mult_fct.
-Apply (Dmult no_cond [y:R]l1 [y:R]l2 f1 f2 x); Assumption.
-Qed.
-
-Lemma derivable_pt_lim_const : (a,x:R) (derivable_pt_lim (fct_cte a) x ``0``).
-Intros; Unfold fct_cte derivable_pt_lim.
-Intros; Exists (mkposreal ``1`` Rlt_R0_R1); Intros; Unfold Rminus; Rewrite Rplus_Ropp_r; Unfold Rdiv; Rewrite Rmult_Ol; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Qed.
-
-Lemma derivable_pt_lim_scal : (f:R->R;a,x,l:R) (derivable_pt_lim f x l) -> (derivable_pt_lim (mult_real_fct a f) x ``a*l``).
-Intros.
-Assert H0 := (derivable_pt_lim_const a x).
-Replace (mult_real_fct a f) with (mult_fct (fct_cte a) f).
-Replace ``a*l`` with ``0*(f x)+a*l``; [Idtac | Ring].
-Apply (derivable_pt_lim_mult (fct_cte a) f x ``0`` l); Assumption.
-Unfold mult_real_fct mult_fct fct_cte; Reflexivity.
-Qed.
-
-Lemma derivable_pt_lim_id : (x:R) (derivable_pt_lim id x ``1``).
-Intro; Unfold derivable_pt_lim.
-Intros eps Heps; Exists (mkposreal eps Heps); Intros h H1 H2; Unfold id; Replace ``(x+h-x)/h-1`` with ``0``.
-Rewrite Rabsolu_R0; Apply Rle_lt_trans with ``(Rabsolu h)``.
-Apply Rabsolu_pos.
-Assumption.
-Unfold Rminus; Rewrite Rplus_assoc; Rewrite (Rplus_sym x); Rewrite Rplus_assoc.
-Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Unfold Rdiv; Rewrite <- Rinv_r_sym.
-Symmetry; Apply Rplus_Ropp_r.
-Assumption.
-Qed.
-
-Lemma derivable_pt_lim_Rsqr : (x:R) (derivable_pt_lim Rsqr x ``2*x``).
-Intro; Unfold derivable_pt_lim.
-Unfold Rsqr; Intros eps Heps; Exists (mkposreal eps Heps); Intros h H1 H2; Replace ``((x+h)*(x+h)-x*x)/h-2*x`` with ``h``.
-Assumption.
-Replace ``(x+h)*(x+h)-x*x`` with ``2*x*h+h*h``; [Idtac | Ring].
-Unfold Rdiv; Rewrite Rmult_Rplus_distrl.
-Repeat Rewrite Rmult_assoc.
-Repeat Rewrite <- Rinv_r_sym; [Idtac | Assumption].
-Ring.
-Qed.
-
-Lemma derivable_pt_lim_comp : (f1,f2:R->R;x,l1,l2:R) (derivable_pt_lim f1 x l1) -> (derivable_pt_lim f2 (f1 x) l2) -> (derivable_pt_lim (comp f2 f1) x ``l2*l1``).
-Intros; Assert H1 := (derivable_pt_lim_D_in f1 [y:R]l1 x).
-Elim H1; Intros.
-Assert H4 := (H3 H).
-Assert H5 := (derivable_pt_lim_D_in f2 [y:R]l2 (f1 x)).
-Elim H5; Intros.
-Assert H8 := (H7 H0).
-Clear H1 H2 H3 H5 H6 H7.
-Assert H1 := (derivable_pt_lim_D_in (comp f2 f1) [y:R]``l2*l1`` x).
-Elim H1; Intros.
-Clear H1 H3; Apply H2.
-Unfold comp; Cut (D_in [x0:R](f2 (f1 x0)) [y:R]``l2*l1`` (Dgf no_cond no_cond f1) x) -> (D_in [x0:R](f2 (f1 x0)) [y:R]``l2*l1`` no_cond x).
-Intro; Apply H1.
-Rewrite Rmult_sym; Apply (Dcomp no_cond no_cond [y:R]l1 [y:R]l2 f1 f2 x); Assumption.
-Unfold Dgf D_in no_cond; Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Elim (H1 eps H3); Intros.
-Exists x0; Intros; Split.
-Elim H5; Intros; Assumption.
-Intros; Elim H5; Intros; Apply H9; Split.
-Unfold D_x; Split.
-Split; Trivial.
-Elim H6; Intros; Unfold D_x in H10; Elim H10; Intros; Assumption.
-Elim H6; Intros; Assumption.
-Qed.
-
-Lemma derivable_pt_plus : (f1,f2:R->R;x:R) (derivable_pt f1 x) -> (derivable_pt f2 x) -> (derivable_pt (plus_fct f1 f2) x).
-Unfold derivable_pt; Intros.
-Elim X; Intros.
-Elim X0; Intros.
-Apply Specif.existT with ``x0+x1``.
-Apply derivable_pt_lim_plus; Assumption.
-Qed.
-
-Lemma derivable_pt_opp : (f:R->R;x:R) (derivable_pt f x) -> (derivable_pt (opp_fct f) x).
-Unfold derivable_pt; Intros.
-Elim X; Intros.
-Apply Specif.existT with ``-x0``.
-Apply derivable_pt_lim_opp; Assumption.
-Qed.
-
-Lemma derivable_pt_minus : (f1,f2:R->R;x:R) (derivable_pt f1 x) -> (derivable_pt f2 x) -> (derivable_pt (minus_fct f1 f2) x).
-Unfold derivable_pt; Intros.
-Elim X; Intros.
-Elim X0; Intros.
-Apply Specif.existT with ``x0-x1``.
-Apply derivable_pt_lim_minus; Assumption.
-Qed.
-
-Lemma derivable_pt_mult : (f1,f2:R->R;x:R) (derivable_pt f1 x) -> (derivable_pt f2 x) -> (derivable_pt (mult_fct f1 f2) x).
-Unfold derivable_pt; Intros.
-Elim X; Intros.
-Elim X0; Intros.
-Apply Specif.existT with ``x0*(f2 x)+(f1 x)*x1``.
-Apply derivable_pt_lim_mult; Assumption.
-Qed.
-
-Lemma derivable_pt_const : (a,x:R) (derivable_pt (fct_cte a) x).
-Intros; Unfold derivable_pt.
-Apply Specif.existT with ``0``.
-Apply derivable_pt_lim_const.
-Qed.
-
-Lemma derivable_pt_scal : (f:R->R;a,x:R) (derivable_pt f x) -> (derivable_pt (mult_real_fct a f) x).
-Unfold derivable_pt; Intros.
-Elim X; Intros.
-Apply Specif.existT with ``a*x0``.
-Apply derivable_pt_lim_scal; Assumption.
-Qed.
-
-Lemma derivable_pt_id : (x:R) (derivable_pt id x).
-Unfold derivable_pt; Intro.
-Exists ``1``.
-Apply derivable_pt_lim_id.
-Qed.
-
-Lemma derivable_pt_Rsqr : (x:R) (derivable_pt Rsqr x).
-Unfold derivable_pt; Intro; Apply Specif.existT with ``2*x``.
-Apply derivable_pt_lim_Rsqr.
-Qed.
-
-Lemma derivable_pt_comp : (f1,f2:R->R;x:R) (derivable_pt f1 x) -> (derivable_pt f2 (f1 x)) -> (derivable_pt (comp f2 f1) x).
-Unfold derivable_pt; Intros.
-Elim X; Intros.
-Elim X0 ;Intros.
-Apply Specif.existT with ``x1*x0``.
-Apply derivable_pt_lim_comp; Assumption.
-Qed.
-
-Lemma derivable_plus : (f1,f2:R->R) (derivable f1) -> (derivable f2) -> (derivable (plus_fct f1 f2)).
-Unfold derivable; Intros.
-Apply (derivable_pt_plus ? ? x (X ?) (X0 ?)).
-Qed.
-
-Lemma derivable_opp : (f:R->R) (derivable f) -> (derivable (opp_fct f)).
-Unfold derivable; Intros.
-Apply (derivable_pt_opp ? x (X ?)).
-Qed.
-
-Lemma derivable_minus : (f1,f2:R->R) (derivable f1) -> (derivable f2) -> (derivable (minus_fct f1 f2)).
-Unfold derivable; Intros.
-Apply (derivable_pt_minus ? ? x (X ?) (X0 ?)).
-Qed.
-
-Lemma derivable_mult : (f1,f2:R->R) (derivable f1) -> (derivable f2) -> (derivable (mult_fct f1 f2)).
-Unfold derivable; Intros.
-Apply (derivable_pt_mult ? ? x (X ?) (X0 ?)).
-Qed.
-
-Lemma derivable_const : (a:R) (derivable (fct_cte a)).
-Unfold derivable; Intros.
-Apply derivable_pt_const.
-Qed.
-
-Lemma derivable_scal : (f:R->R;a:R) (derivable f) -> (derivable (mult_real_fct a f)).
-Unfold derivable; Intros.
-Apply (derivable_pt_scal ? a x (X ?)).
-Qed.
-
-Lemma derivable_id : (derivable id).
-Unfold derivable; Intro; Apply derivable_pt_id.
-Qed.
-
-Lemma derivable_Rsqr : (derivable Rsqr).
-Unfold derivable; Intro; Apply derivable_pt_Rsqr.
-Qed.
-
-Lemma derivable_comp : (f1,f2:R->R) (derivable f1) -> (derivable f2) -> (derivable (comp f2 f1)).
-Unfold derivable; Intros.
-Apply (derivable_pt_comp ? ? x (X ?) (X0 ?)).
-Qed.
-
-Lemma derive_pt_plus : (f1,f2:R->R;x:R;pr1:(derivable_pt f1 x);pr2:(derivable_pt f2 x)) ``(derive_pt (plus_fct f1 f2) x (derivable_pt_plus ? ? ? pr1 pr2)) == (derive_pt f1 x pr1) + (derive_pt f2 x pr2)``.
-Intros.
-Assert H := (derivable_derive f1 x pr1).
-Assert H0 := (derivable_derive f2 x pr2).
-Assert H1 := (derivable_derive (plus_fct f1 f2) x (derivable_pt_plus ? ? ? pr1 pr2)).
-Elim H; Clear H; Intros l1 H.
-Elim H0; Clear H0; Intros l2 H0.
-Elim H1; Clear H1; Intros l H1.
-Rewrite H; Rewrite H0; Apply derive_pt_eq_0.
-Assert H3 := (projT2 ? ? pr1).
-Unfold derive_pt in H; Rewrite H in H3.
-Assert H4 := (projT2 ? ? pr2).
-Unfold derive_pt in H0; Rewrite H0 in H4.
-Apply derivable_pt_lim_plus; Assumption.
-Qed.
-
-Lemma derive_pt_opp : (f:R->R;x:R;pr1:(derivable_pt f x)) ``(derive_pt (opp_fct f) x (derivable_pt_opp ? ? pr1)) == -(derive_pt f x pr1)``.
-Intros.
-Assert H := (derivable_derive f x pr1).
-Assert H0 := (derivable_derive (opp_fct f) x (derivable_pt_opp ? ? pr1)).
-Elim H; Clear H; Intros l1 H.
-Elim H0; Clear H0; Intros l2 H0.
-Rewrite H; Apply derive_pt_eq_0.
-Assert H3 := (projT2 ? ? pr1).
-Unfold derive_pt in H; Rewrite H in H3.
-Apply derivable_pt_lim_opp; Assumption.
-Qed.
-
-Lemma derive_pt_minus : (f1,f2:R->R;x:R;pr1:(derivable_pt f1 x);pr2:(derivable_pt f2 x)) ``(derive_pt (minus_fct f1 f2) x (derivable_pt_minus ? ? ? pr1 pr2)) == (derive_pt f1 x pr1) - (derive_pt f2 x pr2)``.
-Intros.
-Assert H := (derivable_derive f1 x pr1).
-Assert H0 := (derivable_derive f2 x pr2).
-Assert H1 := (derivable_derive (minus_fct f1 f2) x (derivable_pt_minus ? ? ? pr1 pr2)).
-Elim H; Clear H; Intros l1 H.
-Elim H0; Clear H0; Intros l2 H0.
-Elim H1; Clear H1; Intros l H1.
-Rewrite H; Rewrite H0; Apply derive_pt_eq_0.
-Assert H3 := (projT2 ? ? pr1).
-Unfold derive_pt in H; Rewrite H in H3.
-Assert H4 := (projT2 ? ? pr2).
-Unfold derive_pt in H0; Rewrite H0 in H4.
-Apply derivable_pt_lim_minus; Assumption.
-Qed.
-
-Lemma derive_pt_mult : (f1,f2:R->R;x:R;pr1:(derivable_pt f1 x);pr2:(derivable_pt f2 x)) ``(derive_pt (mult_fct f1 f2) x (derivable_pt_mult ? ? ? pr1 pr2)) == (derive_pt f1 x pr1)*(f2 x) + (f1 x)*(derive_pt f2 x pr2)``.
-Intros.
-Assert H := (derivable_derive f1 x pr1).
-Assert H0 := (derivable_derive f2 x pr2).
-Assert H1 := (derivable_derive (mult_fct f1 f2) x (derivable_pt_mult ? ? ? pr1 pr2)).
-Elim H; Clear H; Intros l1 H.
-Elim H0; Clear H0; Intros l2 H0.
-Elim H1; Clear H1; Intros l H1.
-Rewrite H; Rewrite H0; Apply derive_pt_eq_0.
-Assert H3 := (projT2 ? ? pr1).
-Unfold derive_pt in H; Rewrite H in H3.
-Assert H4 := (projT2 ? ? pr2).
-Unfold derive_pt in H0; Rewrite H0 in H4.
-Apply derivable_pt_lim_mult; Assumption.
-Qed.
-
-Lemma derive_pt_const : (a,x:R) (derive_pt (fct_cte a) x (derivable_pt_const a x)) == R0.
-Intros.
-Apply derive_pt_eq_0.
-Apply derivable_pt_lim_const.
-Qed.
-
-Lemma derive_pt_scal : (f:R->R;a,x:R;pr:(derivable_pt f x)) ``(derive_pt (mult_real_fct a f) x (derivable_pt_scal ? ? ? pr)) == a * (derive_pt f x pr)``.
-Intros.
-Assert H := (derivable_derive f x pr).
-Assert H0 := (derivable_derive (mult_real_fct a f) x (derivable_pt_scal ? ? ? pr)).
-Elim H; Clear H; Intros l1 H.
-Elim H0; Clear H0; Intros l2 H0.
-Rewrite H; Apply derive_pt_eq_0.
-Assert H3 := (projT2 ? ? pr).
-Unfold derive_pt in H; Rewrite H in H3.
-Apply derivable_pt_lim_scal; Assumption.
-Qed.
-
-Lemma derive_pt_id : (x:R) (derive_pt id x (derivable_pt_id ?))==R1.
-Intros.
-Apply derive_pt_eq_0.
-Apply derivable_pt_lim_id.
-Qed.
-
-Lemma derive_pt_Rsqr : (x:R) (derive_pt Rsqr x (derivable_pt_Rsqr ?)) == ``2*x``.
-Intros.
-Apply derive_pt_eq_0.
-Apply derivable_pt_lim_Rsqr.
-Qed.
-
-Lemma derive_pt_comp : (f1,f2:R->R;x:R;pr1:(derivable_pt f1 x);pr2:(derivable_pt f2 (f1 x))) ``(derive_pt (comp f2 f1) x (derivable_pt_comp ? ? ? pr1 pr2)) == (derive_pt f2 (f1 x) pr2) * (derive_pt f1 x pr1)``.
-Intros.
-Assert H := (derivable_derive f1 x pr1).
-Assert H0 := (derivable_derive f2 (f1 x) pr2).
-Assert H1 := (derivable_derive (comp f2 f1) x (derivable_pt_comp ? ? ? pr1 pr2)).
-Elim H; Clear H; Intros l1 H.
-Elim H0; Clear H0; Intros l2 H0.
-Elim H1; Clear H1; Intros l H1.
-Rewrite H; Rewrite H0; Apply derive_pt_eq_0.
-Assert H3 := (projT2 ? ? pr1).
-Unfold derive_pt in H; Rewrite H in H3.
-Assert H4 := (projT2 ? ? pr2).
-Unfold derive_pt in H0; Rewrite H0 in H4.
-Apply derivable_pt_lim_comp; Assumption.
-Qed.
-
-(* Pow *)
-Definition pow_fct [n:nat] : R->R := [y:R](pow y n).
-
-Lemma derivable_pt_lim_pow_pos : (x:R;n:nat) (lt O n) -> (derivable_pt_lim [y:R](pow y n) x ``(INR n)*(pow x (pred n))``).
-Intros.
-Induction n.
-Elim (lt_n_n ? H).
-Cut n=O\/(lt O n).
-Intro; Elim H0; Intro.
-Rewrite H1; Simpl.
-Replace [y:R]``y*1`` with (mult_fct id (fct_cte R1)).
-Replace ``1*1`` with ``1*(fct_cte R1 x)+(id x)*0``.
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_const.
-Unfold fct_cte id; Ring.
-Reflexivity.
-Replace [y:R](pow y (S n)) with [y:R]``y*(pow y n)``.
-Replace (pred (S n)) with n; [Idtac | Reflexivity].
-Replace [y:R]``y*(pow y n)`` with (mult_fct id [y:R](pow y n)).
-Pose f := [y:R](pow y n).
-Replace ``(INR (S n))*(pow x n)`` with (Rplus (Rmult R1 (f x)) (Rmult (id x) (Rmult (INR n) (pow x (pred n))))).
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_id.
-Unfold f; Apply Hrecn; Assumption.
-Unfold f.
-Pattern 1 5 n; Replace n with (S (pred n)).
-Unfold id; Rewrite S_INR; Simpl.
-Ring.
-Symmetry; Apply S_pred with O; Assumption.
-Unfold mult_fct id; Reflexivity.
-Reflexivity.
-Inversion H.
-Left; Reflexivity.
-Right.
-Apply lt_le_trans with (1).
-Apply lt_O_Sn.
-Assumption.
-Qed.
-
-Lemma derivable_pt_lim_pow : (x:R; n:nat) (derivable_pt_lim [y:R](pow y n) x ``(INR n)*(pow x (pred n))``).
-Intros.
-Induction n.
-Simpl.
-Rewrite Rmult_Ol.
-Replace [_:R]``1`` with (fct_cte R1); [Apply derivable_pt_lim_const | Reflexivity].
-Apply derivable_pt_lim_pow_pos.
-Apply lt_O_Sn.
-Qed.
-
-Lemma derivable_pt_pow : (n:nat;x:R) (derivable_pt [y:R](pow y n) x).
-Intros; Unfold derivable_pt.
-Apply Specif.existT with ``(INR n)*(pow x (pred n))``.
-Apply derivable_pt_lim_pow.
-Qed.
-
-Lemma derivable_pow : (n:nat) (derivable [y:R](pow y n)).
-Intro; Unfold derivable; Intro; Apply derivable_pt_pow.
-Qed.
-
-Lemma derive_pt_pow : (n:nat;x:R) (derive_pt [y:R](pow y n) x (derivable_pt_pow n x))==``(INR n)*(pow x (pred n))``.
-Intros; Apply derive_pt_eq_0.
-Apply derivable_pt_lim_pow.
-Qed.
-
-Lemma pr_nu : (f:R->R;x:R;pr1,pr2:(derivable_pt f x)) (derive_pt f x pr1)==(derive_pt f x pr2). 
-Intros.
-Unfold derivable_pt in pr1.
-Unfold derivable_pt in pr2.
-Elim pr1; Intros.
-Elim pr2; Intros.
-Unfold derivable_pt_abs in p.
-Unfold derivable_pt_abs in p0.
-Simpl.
-Apply (unicite_limite f x x0 x1 p p0).
-Qed.
-
-
-(************************************************************)
-(**             Local extremum's condition                  *)
-(************************************************************)
-
-Theorem deriv_maximum : (f:R->R;a,b,c:R;pr:(derivable_pt f c)) ``a<c``->``c<b``->((x:R) ``a<x``->``x<b``->``(f x)<=(f c)``)->``(derive_pt f c pr)==0``.
-Intros; Case (total_order R0 (derive_pt f c pr)); Intro.
-Assert H3 := (derivable_derive f c pr).
-Elim H3; Intros l H4; Rewrite H4 in H2.
-Assert H5 := (derive_pt_eq_1 f c l pr H4).
-Cut ``0<l/2``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0]].
-Elim (H5 ``l/2`` H6); Intros delta H7.
-Cut ``0<(b-c)/2``.
-Intro; Cut ``(Rmin delta/2 ((b-c)/2))<>0``.
-Intro; Cut ``(Rabsolu (Rmin delta/2 ((b-c)/2)))<delta``.
-Intro.
-Assert H11 := (H7 ``(Rmin delta/2 ((b-c)/2))`` H9 H10).
-Cut ``0<(Rmin (delta/2) ((b-c)/2))``.
-Intro; Cut ``a<c+(Rmin (delta/2) ((b-c)/2))``.
-Intro; Cut ``c+(Rmin (delta/2) ((b-c)/2))<b``.
-Intro; Assert H15 := (H1 ``c+(Rmin (delta/2) ((b-c)/2))`` H13 H14).
-Cut ``((f (c+(Rmin (delta/2) ((b-c)/2))))-(f c))/(Rmin (delta/2) ((b-c)/2))<=0``.
-Intro; Cut ``-l<0``.
-Intro; Unfold Rminus in H11.
-Cut ``((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2))+ -l<0``.
-Intro; Cut ``(Rabsolu (((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2))+ -l)) < l/2``.
-Unfold Rabsolu; Case (case_Rabsolu ``((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2))+ -l``); Intro.
-Replace `` -(((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2))+ -l)`` with ``l+ -(((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2)))``.
-Intro; Generalize (Rlt_compatibility ``-l`` ``l+ -(((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2)))`` ``l/2`` H19); Repeat Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Replace ``-l+l/2`` with ``-(l/2)``.
-Intro; Generalize (Rlt_Ropp ``-(((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2)))`` ``-(l/2)`` H20); Repeat Rewrite Ropp_Ropp; Intro; Generalize (Rlt_trans ``0`` ``l/2`` ``((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2))`` H6 H21); Intro; Elim (Rlt_antirefl ``0`` (Rlt_le_trans ``0`` ``((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2))`` ``0`` H22 H16)).
-Pattern 2 l; Rewrite double_var.
-Ring.
-Ring.
-Intro.
-Assert H20 := (Rle_sym2 ``0`` ``((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2))+ -l`` r).
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H20 H18)). 
-Assumption.
-Rewrite <- Ropp_O; Replace ``((f (c+(Rmin (delta/2) ((b+ -c)/2))))+ -(f c))/(Rmin (delta/2) ((b+ -c)/2))+ -l`` with ``-(l+ -(((f (c+(Rmin (delta/2) ((b+ -c)/2))))-(f c))/(Rmin (delta/2) ((b+ -c)/2))))``.
-Apply Rgt_Ropp; Change ``0<l+ -(((f (c+(Rmin (delta/2) ((b+ -c)/2))))-(f c))/(Rmin (delta/2) ((b+ -c)/2)))``; Apply gt0_plus_ge0_is_gt0; [Assumption | Rewrite <- Ropp_O; Apply Rge_Ropp; Apply Rle_sym1; Assumption].
-Ring.
-Rewrite <- Ropp_O; Apply Rlt_Ropp; Assumption.
-Replace ``((f (c+(Rmin (delta/2) ((b-c)/2))))-(f c))/(Rmin (delta/2) ((b-c)/2))`` with ``- (((f c)-(f (c+(Rmin (delta/2) ((b-c)/2)))))/(Rmin (delta/2) ((b-c)/2)))``.
-Rewrite <- Ropp_O; Apply Rge_Ropp; Apply Rle_sym1; Unfold Rdiv; Apply Rmult_le_pos; [Generalize (Rle_compatibility_r ``-(f (c+(Rmin (delta*/2) ((b-c)*/2))))`` ``(f (c+(Rmin (delta*/2) ((b-c)*/2))))`` (f c) H15); Rewrite Rplus_Ropp_r; Intro; Assumption | Left; Apply Rlt_Rinv; Assumption].
-Unfold Rdiv.
-Rewrite <- Ropp_mul1.
-Repeat Rewrite <- (Rmult_sym ``/(Rmin (delta*/2) ((b-c)*/2))``).
-Apply r_Rmult_mult with ``(Rmin (delta*/2) ((b-c)*/2))``.
-Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Repeat Rewrite Rmult_1l.
-Ring.
-Red; Intro.
-Unfold Rdiv in H12; Rewrite H16 in H12; Elim (Rlt_antirefl ``0`` H12).
-Red; Intro.
-Unfold Rdiv in H12; Rewrite H16 in H12; Elim (Rlt_antirefl ``0`` H12).
-Assert H14 := (Rmin_r ``(delta/2)`` ``((b-c)/2)``).
-Assert H15 := (Rle_compatibility ``c`` ``(Rmin (delta/2) ((b-c)/2))`` ``(b-c)/2`` H14).
-Apply Rle_lt_trans with ``c+(b-c)/2``.
-Assumption.
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Replace ``2*(c+(b-c)/2)`` with ``c+b``.
-Replace ``2*b`` with ``b+b``.
-Apply Rlt_compatibility_r; Assumption.
-Ring.
-Unfold Rdiv; Rewrite Rmult_Rplus_distr.
-Repeat Rewrite (Rmult_sym ``2``).
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Ring.
-DiscrR.
-Apply Rlt_trans with c.
-Assumption.
-Pattern 1 c; Rewrite <- (Rplus_Or c); Apply Rlt_compatibility; Assumption.
-Cut ``0<delta/2``.
-Intro; Apply (Rmin_stable_in_posreal (mkposreal ``delta/2`` H12) (mkposreal ``(b-c)/2`` H8)).
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos delta) | Apply Rlt_Rinv; Sup0].
-Unfold Rabsolu; Case (case_Rabsolu (Rmin ``delta/2`` ``(b-c)/2``)).
-Intro.
-Cut ``0<delta/2``.
-Intro.
-Generalize (Rmin_stable_in_posreal (mkposreal ``delta/2`` H10) (mkposreal ``(b-c)/2`` H8)); Simpl; Intro; Elim (Rlt_antirefl ``0`` (Rlt_trans ``0`` ``(Rmin (delta/2) ((b-c)/2))`` ``0`` H11 r)).
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos delta) | Apply Rlt_Rinv; Sup0].
-Intro; Apply Rle_lt_trans with ``delta/2``.
-Apply Rmin_l.
-Unfold Rdiv; Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l.
-Replace ``2*delta`` with ``delta+delta``. 
-Pattern 2 delta; Rewrite <- (Rplus_Or delta); Apply Rlt_compatibility.
-Rewrite Rplus_Or; Apply (cond_pos delta).
-Symmetry; Apply double.
-DiscrR.
-Cut ``0<delta/2``.
-Intro; Generalize (Rmin_stable_in_posreal (mkposreal ``delta/2`` H9) (mkposreal ``(b-c)/2`` H8)); Simpl; Intro; Red; Intro; Rewrite H11 in H10; Elim (Rlt_antirefl ``0`` H10).
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos delta) | Apply Rlt_Rinv; Sup0].
-Unfold Rdiv; Apply Rmult_lt_pos.
-Generalize (Rlt_compatibility_r ``-c`` c b H0); Rewrite Rplus_Ropp_r; Intro; Assumption.
-Apply Rlt_Rinv; Sup0.
-Elim H2; Intro.
-Symmetry; Assumption.
-Generalize (derivable_derive f c pr); Intro; Elim H4; Intros l H5.
-Rewrite H5 in H3; Generalize (derive_pt_eq_1 f c l pr H5); Intro; Cut ``0< -(l/2)``.
-Intro; Elim (H6 ``-(l/2)`` H7); Intros delta H9.
-Cut ``0<(c-a)/2``.
-Intro; Cut ``(Rmax (-(delta/2)) ((a-c)/2))<0``.
-Intro; Cut ``(Rmax (-(delta/2)) ((a-c)/2))<>0``.
-Intro; Cut ``(Rabsolu (Rmax (-(delta/2)) ((a-c)/2)))<delta``.
-Intro; Generalize (H9 ``(Rmax (-(delta/2)) ((a-c)/2))`` H11 H12); Intro; Cut ``a<c+(Rmax (-(delta/2)) ((a-c)/2))``.
-Cut ``c+(Rmax (-(delta/2)) ((a-c)/2))<b``.
-Intros; Generalize (H1 ``c+(Rmax (-(delta/2)) ((a-c)/2))`` H15 H14); Intro; Cut ``0<=((f (c+(Rmax (-(delta/2)) ((a-c)/2))))-(f c))/(Rmax (-(delta/2)) ((a-c)/2))``.
-Intro; Cut ``0< -l``.
-Intro; Unfold Rminus in H13; Cut ``0<((f (c+(Rmax (-(delta/2)) ((a+ -c)/2))))+ -(f c))/(Rmax (-(delta/2)) ((a+ -c)/2))+ -l``.
-Intro; Cut ``(Rabsolu (((f (c+(Rmax (-(delta/2)) ((a+ -c)/2))))+ -(f c))/(Rmax (-(delta/2)) ((a+ -c)/2))+ -l)) < -(l/2)``.
-Unfold Rabsolu; Case (case_Rabsolu ``((f (c+(Rmax (-(delta/2)) ((a+ -c)/2))))+ -(f c))/(Rmax (-(delta/2)) ((a+ -c)/2))+ -l``).
-Intro; Elim (Rlt_antirefl ``0`` (Rlt_trans ``0`` ``((f (c+(Rmax ( -(delta/2)) ((a+ -c)/2))))+ -(f c))/(Rmax ( -(delta/2)) ((a+ -c)/2))+ -l`` ``0`` H19 r)).
-Intros; Generalize (Rlt_compatibility_r ``l`` ``(((f (c+(Rmax (-(delta/2)) ((a+ -c)/2))))+ -(f c))/(Rmax (-(delta/2)) ((a+ -c)/2)))+ -l`` ``-(l/2)`` H20); Repeat Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Replace ``-(l/2)+l`` with ``l/2``.
-Cut ``l/2<0``.
-Intros; Generalize (Rlt_trans ``((f (c+(Rmax ( -(delta/2)) ((a+ -c)/2))))+ -(f c))/(Rmax ( -(delta/2)) ((a+ -c)/2))`` ``l/2`` ``0`` H22 H21); Intro; Elim (Rlt_antirefl ``0`` (Rle_lt_trans ``0`` ``((f (c+(Rmax ( -(delta/2)) ((a-c)/2))))-(f c))/(Rmax ( -(delta/2)) ((a-c)/2))`` ``0`` H17 H23)).
-Rewrite <- (Ropp_Ropp ``l/2``); Rewrite <- Ropp_O; Apply Rlt_Ropp; Assumption.
-Pattern 3 l; Rewrite double_var.
-Ring.
-Assumption.
-Apply ge0_plus_gt0_is_gt0; Assumption.
-Rewrite <- Ropp_O; Apply Rlt_Ropp; Assumption.
-Unfold Rdiv; Replace ``((f (c+(Rmax ( -(delta*/2)) ((a-c)*/2))))-(f c))*/(Rmax ( -(delta*/2)) ((a-c)*/2))`` with ``(-((f (c+(Rmax ( -(delta*/2)) ((a-c)*/2))))-(f c)))*/(-(Rmax ( -(delta*/2)) ((a-c)*/2)))``.
-Apply Rmult_le_pos.
-Generalize (Rle_compatibility ``-(f (c+(Rmax (-(delta*/2)) ((a-c)*/2))))`` ``(f (c+(Rmax (-(delta*/2)) ((a-c)*/2))))`` (f c) H16); Rewrite Rplus_Ropp_l; Replace ``-((f (c+(Rmax ( -(delta*/2)) ((a-c)*/2))))-(f c))`` with ``-((f (c+(Rmax ( -(delta*/2)) ((a-c)*/2)))))+(f c)``.
-Intro; Assumption.
-Ring.
-Left; Apply Rlt_Rinv; Rewrite <- Ropp_O; Apply Rlt_Ropp; Assumption.
-Unfold Rdiv.
-Rewrite <- Ropp_Rinv.
-Rewrite Ropp_mul2.
-Reflexivity.
-Unfold Rdiv in H11; Assumption.
-Generalize (Rlt_compatibility c ``(Rmax ( -(delta/2)) ((a-c)/2))`` ``0`` H10); Rewrite Rplus_Or; Intro; Apply Rlt_trans with ``c``; Assumption.
-Generalize (RmaxLess2 ``(-(delta/2))`` ``((a-c)/2)``); Intro; Generalize (Rle_compatibility c ``(a-c)/2`` ``(Rmax ( -(delta/2)) ((a-c)/2))`` H14); Intro; Apply Rlt_le_trans with ``c+(a-c)/2``.
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Replace ``2*(c+(a-c)/2)`` with ``a+c``.
-Rewrite double.
-Apply Rlt_compatibility; Assumption.
-Ring.
-Rewrite <- Rplus_assoc.
-Rewrite <- double_var.
-Ring.
-Assumption.
-Unfold Rabsolu; Case (case_Rabsolu (Rmax ``-(delta/2)`` ``(a-c)/2``)).
-Intro; Generalize (RmaxLess1 ``-(delta/2)`` ``(a-c)/2``); Intro; Generalize (Rle_Ropp ``-(delta/2)`` ``(Rmax ( -(delta/2)) ((a-c)/2))`` H12); Rewrite Ropp_Ropp; Intro; Generalize (Rle_sym2 ``-(Rmax ( -(delta/2)) ((a-c)/2))`` ``delta/2`` H13); Intro; Apply Rle_lt_trans with ``delta/2``.
-Assumption.
-Apply Rlt_monotony_contra with ``2``. 
-Sup0.
-Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite double.
-Pattern 2 delta; Rewrite <- (Rplus_Or delta); Apply Rlt_compatibility; Rewrite Rplus_Or; Apply (cond_pos delta).
-DiscrR. 
-Cut ``-(delta/2) < 0``.
-Cut ``(a-c)/2<0``.
-Intros; Generalize (Rmax_stable_in_negreal (mknegreal ``-(delta/2)`` H13) (mknegreal ``(a-c)/2`` H12)); Simpl; Intro; Generalize (Rle_sym2 ``0`` ``(Rmax ( -(delta/2)) ((a-c)/2))`` r); Intro; Elim (Rlt_antirefl ``0`` (Rle_lt_trans ``0`` ``(Rmax ( -(delta/2)) ((a-c)/2))`` ``0`` H15 H14)).
-Rewrite <- Ropp_O; Rewrite <- (Ropp_Ropp ``(a-c)/2``); Apply Rlt_Ropp; Replace ``-((a-c)/2)`` with ``(c-a)/2``.
-Assumption.
-Unfold Rdiv.
-Rewrite <- Ropp_mul1. 
-Rewrite (Ropp_distr2 a c).
-Reflexivity.
-Rewrite <- Ropp_O; Apply Rlt_Ropp; Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos delta) | Assert Hyp : ``0<2``; [Sup0 | Apply (Rlt_Rinv ``2`` Hyp)]].
-Red; Intro; Rewrite H11 in H10; Elim (Rlt_antirefl ``0`` H10).
-Cut ``(a-c)/2<0``.
-Intro; Cut ``-(delta/2)<0``.
-Intro; Apply (Rmax_stable_in_negreal (mknegreal ``-(delta/2)`` H11) (mknegreal ``(a-c)/2`` H10)).
-Rewrite <- Ropp_O; Apply Rlt_Ropp; Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos delta) | Assert Hyp : ``0<2``; [Sup0 | Apply (Rlt_Rinv ``2`` Hyp)]].
-Rewrite <- Ropp_O; Rewrite <- (Ropp_Ropp ``(a-c)/2``); Apply Rlt_Ropp; Replace ``-((a-c)/2)`` with ``(c-a)/2``.
-Assumption.
-Unfold Rdiv.
-Rewrite <- Ropp_mul1. 
-Rewrite (Ropp_distr2 a c).
-Reflexivity.
-Unfold Rdiv; Apply Rmult_lt_pos; [Generalize (Rlt_compatibility_r ``-a`` a c H); Rewrite Rplus_Ropp_r; Intro; Assumption | Assert Hyp : ``0<2``; [Sup0 | Apply (Rlt_Rinv ``2`` Hyp)]].
-Replace ``-(l/2)`` with ``(-l)/2``.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Rewrite <- Ropp_O; Apply Rlt_Ropp; Assumption.
-Assert Hyp : ``0<2``; [Sup0 | Apply (Rlt_Rinv ``2`` Hyp)].
-Unfold Rdiv; Apply Ropp_mul1.
-Qed.
-
-Theorem deriv_minimum : (f:R->R;a,b,c:R;pr:(derivable_pt f c)) ``a<c``->``c<b``->((x:R) ``a<x``->``x<b``->``(f c)<=(f x)``)->``(derive_pt f c pr)==0``.
-Intros.
-Rewrite <- (Ropp_Ropp (derive_pt f c pr)).
-Apply eq_RoppO.
-Rewrite <- (derive_pt_opp f c pr).
-Cut (x:R)(``a<x``->``x<b``->``((opp_fct f) x)<=((opp_fct f) c)``).
-Intro.
-Apply (deriv_maximum (opp_fct f) a b c (derivable_pt_opp ? ? pr) H H0 H2).
-Intros; Unfold opp_fct; Apply Rge_Ropp; Apply Rle_sym1.
-Apply (H1 x H2 H3).
-Qed.
- 
-Theorem deriv_constant2 : (f:R->R;a,b,c:R;pr:(derivable_pt f c)) ``a<c``->``c<b``->((x:R) ``a<x``->``x<b``->``(f x)==(f c)``)->``(derive_pt f c pr)==0``.
-Intros.
-EApply deriv_maximum with a b; Try Assumption.
-Intros; Right; Apply (H1 x H2 H3).
-Qed.
-
-(**********)
-Lemma nonneg_derivative_0 : (f:R->R;pr:(derivable f)) (increasing f) -> ((x:R) ``0<=(derive_pt f x (pr x))``).
-Intros; Unfold increasing in H.
-Assert H0 := (derivable_derive f x (pr x)).
-Elim H0; Intros l H1.
-Rewrite H1; Case (total_order R0 l); Intro.
-Left; Assumption.
-Elim H2; Intro.
-Right; Assumption.
-Assert H4 := (derive_pt_eq_1 f x l (pr x) H1).
-Cut ``0< -(l/2)``.
-Intro; Elim (H4 ``-(l/2)`` H5); Intros delta H6.
-Cut ``delta/2<>0``/\``0<delta/2``/\``(Rabsolu delta/2)<delta``.
-Intro; Decompose [and] H7; Intros; Generalize (H6 ``delta/2`` H8 H11); Cut ``0<=((f (x+delta/2))-(f x))/(delta/2)``.
-Intro; Cut ``0<=((f (x+delta/2))-(f x))/(delta/2)-l``.
-Intro; Unfold Rabsolu; Case (case_Rabsolu ``((f (x+delta/2))-(f x))/(delta/2)-l``).
-Intro; Elim (Rlt_antirefl ``0`` (Rle_lt_trans ``0`` ``((f (x+delta/2))-(f x))/(delta/2)-l`` ``0`` H12 r)).
-Intros; Generalize (Rlt_compatibility_r l ``((f (x+delta/2))-(f x))/(delta/2)-l`` ``-(l/2)`` H13); Unfold Rminus; Replace ``-(l/2)+l`` with ``l/2``.
-Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Intro; Generalize (Rle_lt_trans ``0`` ``((f (x+delta/2))-(f x))/(delta/2)`` ``l/2`` H9 H14); Intro; Cut ``l/2<0``.
-Intro; Elim (Rlt_antirefl ``0`` (Rlt_trans ``0`` ``l/2`` ``0`` H15 H16)).
-Rewrite <- Ropp_O in H5; Generalize (Rlt_Ropp ``-0`` ``-(l/2)`` H5); Repeat Rewrite Ropp_Ropp; Intro; Assumption.
-Pattern 3 l ; Rewrite double_var.
-Ring.
-Unfold Rminus; Apply ge0_plus_ge0_is_ge0.
-Unfold Rdiv; Apply Rmult_le_pos.
-Cut ``x<=(x+(delta*/2))``.
-Intro; Generalize (H x ``x+(delta*/2)`` H12); Intro; Generalize (Rle_compatibility ``-(f x)`` ``(f x)`` ``(f (x+delta*/2))`` H13); Rewrite Rplus_Ropp_l; Rewrite Rplus_sym; Intro; Assumption.
-Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rle_compatibility; Left; Assumption.
-Left; Apply Rlt_Rinv; Assumption.
-Left; Rewrite <- Ropp_O; Apply Rlt_Ropp; Assumption.
-Unfold Rdiv; Apply Rmult_le_pos.
-Cut ``x<=(x+(delta*/2))``.
-Intro; Generalize (H x ``x+(delta*/2)`` H9); Intro; Generalize (Rle_compatibility ``-(f x)`` ``(f x)`` ``(f (x+delta*/2))`` H12); Rewrite Rplus_Ropp_l; Rewrite Rplus_sym; Intro; Assumption.
-Pattern 1 x; Rewrite <- (Rplus_Or x); Apply Rle_compatibility; Left; Assumption. 
-Left; Apply Rlt_Rinv; Assumption.
-Split.
-Unfold Rdiv; Apply prod_neq_R0.
-Generalize (cond_pos delta); Intro; Red; Intro H9; Rewrite H9 in H7; Elim (Rlt_antirefl ``0`` H7).
-Apply Rinv_neq_R0; DiscrR.
-Split.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos delta) | Apply Rlt_Rinv; Sup0].
-Replace ``(Rabsolu delta/2)`` with ``delta/2``.
-Unfold Rdiv; Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Rewrite (Rmult_sym ``2``).
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR].
-Rewrite Rmult_1r.
-Rewrite double.
-Pattern 1 (pos delta); Rewrite <- Rplus_Or.
-Apply Rlt_compatibility; Apply (cond_pos delta).
-Symmetry; Apply Rabsolu_right.
-Left; Change ``0<delta/2``; Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos delta) | Apply Rlt_Rinv; Sup0].
-Unfold Rdiv; Rewrite <- Ropp_mul1; Apply Rmult_lt_pos.
-Apply Rlt_anti_compatibility with l.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Assumption.
-Apply Rlt_Rinv; Sup0.
-Qed.
diff --git a/theories7/Reals/Ranalysis2.v b/theories7/Reals/Ranalysis2.v
deleted file mode 100644
index 35fa58d5..00000000
--- a/theories7/Reals/Ranalysis2.v
+++ /dev/null
@@ -1,302 +0,0 @@
-(************************************************************************)
-(*  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: Ranalysis2.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Ranalysis1.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(**********)
-Lemma formule : (x,h,l1,l2:R;f1,f2:R->R) ``h<>0`` -> ``(f2 x)<>0`` -> ``(f2 (x+h))<>0`` -> ``((f1 (x+h))/(f2 (x+h))-(f1 x)/(f2 x))/h-(l1*(f2 x)-l2*(f1 x))/(Rsqr (f2 x))`` == ``/(f2 (x+h))*(((f1 (x+h))-(f1 x))/h-l1) + l1/((f2 x)*(f2 (x+h)))*((f2 x)-(f2 (x+h))) - (f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))-(f2 x))/h-l2) + (l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))*((f2 (x+h))-(f2 x))``.
-Intros; Unfold Rdiv Rminus Rsqr.
-Repeat Rewrite Rmult_Rplus_distrl; Repeat Rewrite Rmult_Rplus_distr; Repeat Rewrite Rinv_Rmult; Try Assumption.
-Replace ``l1*(f2 x)*(/(f2 x)*/(f2 x))`` with ``l1*/(f2 x)*((f2 x)*/(f2 x))``; [Idtac | Ring].
-Replace ``l1*(/(f2 x)*/(f2 (x+h)))*(f2 x)`` with ``l1*/(f2 (x+h))*((f2 x)*/(f2 x))``; [Idtac | Ring].
-Replace ``l1*(/(f2 x)*/(f2 (x+h)))* -(f2 (x+h))`` with ``-(l1*/(f2 x)*((f2 (x+h))*/(f2 (x+h))))``; [Idtac | Ring].
-Replace ``(f1 x)*(/(f2 x)*/(f2 (x+h)))*((f2 (x+h))*/h)`` with ``(f1 x)*/(f2 x)*/h*((f2 (x+h))*/(f2 (x+h)))``; [Idtac | Ring].
-Replace ``(f1 x)*(/(f2 x)*/(f2 (x+h)))*( -(f2 x)*/h)`` with ``-((f1 x)*/(f2 (x+h))*/h*((f2 x)*/(f2 x)))``; [Idtac | Ring].
-Replace ``(l2*(f1 x)*(/(f2 x)*/(f2 x)*/(f2 (x+h)))*(f2 (x+h)))`` with ``l2*(f1 x)*/(f2 x)*/(f2 x)*((f2 (x+h))*/(f2 (x+h)))``; [Idtac | Ring].
-Replace ``l2*(f1 x)*(/(f2 x)*/(f2 x)*/(f2 (x+h)))* -(f2 x)`` with ``-(l2*(f1 x)*/(f2 x)*/(f2 (x+h))*((f2 x)*/(f2 x)))``; [Idtac | Ring].
-Repeat Rewrite <- Rinv_r_sym; Try Assumption Orelse Ring.
-Apply prod_neq_R0; Assumption.
-Qed.
-
-Lemma Rmin_pos : (x,y:R) ``0<x`` -> ``0<y`` -> ``0 < (Rmin x y)``.
-Intros; Unfold Rmin.
-Case (total_order_Rle x y); Intro; Assumption.
-Qed.
-
-Lemma maj_term1 : (x,h,eps,l1,alp_f2:R;eps_f2,alp_f1d:posreal;f1,f2:R->R) ``0 < eps`` -> ``(f2 x)<>0`` -> ``(f2 (x+h))<>0`` -> ((h:R)``h <> 0``->``(Rabsolu h) < alp_f1d``->``(Rabsolu (((f1 (x+h))-(f1 x))/h-l1)) < (Rabsolu ((eps*(f2 x))/8))``) -> ((a:R)``(Rabsolu a) < (Rmin eps_f2 alp_f2)``->``/(Rabsolu (f2 (x+a))) < 2/(Rabsolu (f2 x))``) -> ``h<>0`` -> ``(Rabsolu h)<alp_f1d`` -> ``(Rabsolu h) < (Rmin eps_f2 alp_f2)`` -> ``(Rabsolu (/(f2 (x+h))*(((f1 (x+h))-(f1 x))/h-l1))) < eps/4``.
-Intros.
-Assert H7 := (H3 h H6).
-Assert H8 := (H2 h H4 H5).
-Apply Rle_lt_trans with ``2/(Rabsolu (f2 x))*(Rabsolu (((f1 (x+h))-(f1 x))/h-l1))``.
-Rewrite Rabsolu_mult.
-Apply Rle_monotony_r.
-Apply Rabsolu_pos.
-Rewrite Rabsolu_Rinv; [Left; Exact H7 | Assumption].
-Apply Rlt_le_trans with ``2/(Rabsolu (f2 x))*(Rabsolu ((eps*(f2 x))/8))``.
-Apply Rlt_monotony.
-Unfold Rdiv; Apply Rmult_lt_pos; [Sup0 | Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption].
-Exact H8.
-Right; Unfold Rdiv.
-Repeat Rewrite Rabsolu_mult.
-Rewrite Rabsolu_Rinv; DiscrR.
-Replace ``(Rabsolu 8)`` with ``8``.
-Replace ``8`` with ``2*4``; [Idtac | Ring].
-Rewrite Rinv_Rmult; [Idtac | DiscrR | DiscrR].
-Replace ``2*/(Rabsolu (f2 x))*((Rabsolu eps)*(Rabsolu (f2 x))*(/2*/4))`` with ``(Rabsolu eps)*/4*(2*/2)*((Rabsolu (f2 x))*/(Rabsolu (f2 x)))``; [Idtac | Ring].
-Replace (Rabsolu eps) with eps.
-Repeat Rewrite <- Rinv_r_sym; Try DiscrR Orelse (Apply Rabsolu_no_R0; Assumption).
-Ring.
-Symmetry; Apply Rabsolu_right; Left; Assumption.
-Symmetry; Apply Rabsolu_right; Left; Sup.
-Qed.
-
-Lemma maj_term2 : (x,h,eps,l1,alp_f2,alp_f2t2:R;eps_f2:posreal;f2:R->R) ``0 < eps`` -> ``(f2 x)<>0`` -> ``(f2 (x+h))<>0`` -> ((a:R)``(Rabsolu a) < alp_f2t2``->``(Rabsolu ((f2 (x+a))-(f2 x))) < (Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``)-> ((a:R)``(Rabsolu a) < (Rmin eps_f2 alp_f2)``->``/(Rabsolu (f2 (x+a))) < 2/(Rabsolu (f2 x))``) -> ``h<>0`` -> ``(Rabsolu h)<alp_f2t2`` -> ``(Rabsolu h) < (Rmin eps_f2 alp_f2)`` -> ``l1<>0`` -> ``(Rabsolu (l1/((f2 x)*(f2 (x+h)))*((f2 x)-(f2 (x+h))))) < eps/4``.
-Intros.
-Assert H8 := (H3 h H6).
-Assert H9 := (H2 h H5).
-Apply Rle_lt_trans with ``(Rabsolu (l1/((f2 x)*(f2 (x+h)))))*(Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``.
-Rewrite Rabsolu_mult; Apply Rle_monotony.
-Apply Rabsolu_pos.
-Rewrite <- (Rabsolu_Ropp ``(f2 x)-(f2 (x+h))``); Rewrite Ropp_distr2.
-Left; Apply H9.
-Apply Rlt_le_trans with ``(Rabsolu (2*l1/((f2 x)*(f2 x))))*(Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``.
-Apply Rlt_monotony_r.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv; Unfold Rsqr; Repeat Apply prod_neq_R0; Try Assumption Orelse DiscrR.
-Red; Intro H10; Rewrite H10 in H; Elim (Rlt_antirefl ? H).
-Apply Rinv_neq_R0; Apply prod_neq_R0; Try Assumption Orelse DiscrR.
-Unfold Rdiv.
-Repeat Rewrite Rinv_Rmult; Try Assumption.
-Repeat Rewrite Rabsolu_mult.
-Replace ``(Rabsolu 2)`` with ``2``.
-Rewrite (Rmult_sym ``2``).
-Replace ``(Rabsolu l1)*((Rabsolu (/(f2 x)))*(Rabsolu (/(f2 x))))*2`` with ``(Rabsolu l1)*((Rabsolu (/(f2 x)))*((Rabsolu (/(f2 x)))*2))``; [Idtac | Ring].
-Repeat Apply Rlt_monotony.
-Apply Rabsolu_pos_lt; Assumption.
-Apply Rabsolu_pos_lt; Apply Rinv_neq_R0; Assumption.
-Repeat Rewrite Rabsolu_Rinv; Try Assumption.
-Rewrite <- (Rmult_sym ``2``).
-Unfold Rdiv in H8; Exact H8.
-Symmetry; Apply Rabsolu_right; Left; Sup0.
-Right.
-Unfold Rsqr Rdiv.
-Do 1 Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Do 1 Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Repeat Rewrite Rabsolu_mult.
-Repeat Rewrite Rabsolu_Rinv; Try Assumption Orelse DiscrR.
-Replace (Rabsolu eps) with eps.
-Replace ``(Rabsolu (8))`` with ``8``.
-Replace ``(Rabsolu 2)`` with ``2``.
-Replace ``8`` with ``4*2``; [Idtac | Ring].
-Rewrite Rinv_Rmult; DiscrR.
-Replace ``2*((Rabsolu l1)*(/(Rabsolu (f2 x))*/(Rabsolu (f2 x))))*(eps*((Rabsolu (f2 x))*(Rabsolu (f2 x)))*(/4*/2*/(Rabsolu l1)))`` with ``eps*/4*((Rabsolu l1)*/(Rabsolu l1))*((Rabsolu (f2 x))*/(Rabsolu (f2 x)))*((Rabsolu (f2 x))*/(Rabsolu (f2 x)))*(2*/2)``; [Idtac | Ring].
-Repeat Rewrite <- Rinv_r_sym; Try (Apply Rabsolu_no_R0; Assumption) Orelse DiscrR.
-Ring.
-Symmetry; Apply Rabsolu_right; Left; Sup0.
-Symmetry; Apply Rabsolu_right; Left; Sup.
-Symmetry; Apply Rabsolu_right; Left; Assumption.
-Qed.
-
-Lemma maj_term3 : (x,h,eps,l2,alp_f2:R;eps_f2,alp_f2d:posreal;f1,f2:R->R) ``0 < eps`` -> ``(f2 x)<>0`` -> ``(f2 (x+h))<>0`` -> ((h:R)``h <> 0``->``(Rabsolu h) < alp_f2d``->``(Rabsolu (((f2 (x+h))-(f2 x))/h-l2)) < (Rabsolu (((Rsqr (f2 x))*eps)/(8*(f1 x))))``) -> ((a:R)``(Rabsolu a) < (Rmin eps_f2 alp_f2)``->``/(Rabsolu (f2 (x+a))) < 2/(Rabsolu (f2 x))``) -> ``h<>0`` -> ``(Rabsolu h)<alp_f2d`` -> ``(Rabsolu h) < (Rmin eps_f2 alp_f2)`` -> ``(f1 x)<>0`` -> ``(Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))-(f2 x))/h-l2))) < eps/4``.
-Intros.
-Assert H8 := (H2 h H4 H5).
-Assert H9 := (H3 h H6).
-Apply Rle_lt_trans with ``(Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))))*(Rabsolu (((Rsqr (f2 x))*eps)/(8*(f1 x))))``.
-Rewrite Rabsolu_mult.
-Apply Rle_monotony.
-Apply Rabsolu_pos.
-Left; Apply H8.
-Apply Rlt_le_trans with ``(Rabsolu (2*(f1 x)/((f2 x)*(f2 x))))*(Rabsolu (((Rsqr (f2 x))*eps)/(8*(f1 x))))``.
-Apply Rlt_monotony_r.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv; Unfold Rsqr; Repeat Apply prod_neq_R0; Try Assumption.
-Red; Intro H10; Rewrite H10 in H; Elim (Rlt_antirefl ? H).
-Apply Rinv_neq_R0; Apply prod_neq_R0; DiscrR Orelse Assumption.
-Unfold Rdiv.
-Repeat Rewrite Rinv_Rmult; Try Assumption.
-Repeat Rewrite Rabsolu_mult.
-Replace ``(Rabsolu 2)`` with ``2``.
-Rewrite (Rmult_sym ``2``).
-Replace ``(Rabsolu (f1 x))*((Rabsolu (/(f2 x)))*(Rabsolu (/(f2 x))))*2`` with ``(Rabsolu (f1 x))*((Rabsolu (/(f2 x)))*((Rabsolu (/(f2 x)))*2))``; [Idtac | Ring].
-Repeat Apply Rlt_monotony.
-Apply Rabsolu_pos_lt; Assumption.
-Apply Rabsolu_pos_lt; Apply Rinv_neq_R0; Assumption.
-Repeat Rewrite Rabsolu_Rinv; Assumption Orelse Idtac.
-Rewrite <- (Rmult_sym ``2``).
-Unfold Rdiv in H9; Exact H9.
-Symmetry; Apply Rabsolu_right; Left; Sup0.
-Right.
-Unfold Rsqr Rdiv.
-Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Repeat Rewrite Rabsolu_mult.
-Repeat Rewrite Rabsolu_Rinv; Try Assumption Orelse DiscrR.
-Replace (Rabsolu eps) with eps.
-Replace ``(Rabsolu (8))`` with ``8``.
-Replace ``(Rabsolu 2)`` with ``2``.
-Replace ``8`` with ``4*2``; [Idtac | Ring].
-Rewrite Rinv_Rmult; DiscrR.
-Replace ``2*((Rabsolu (f1 x))*(/(Rabsolu (f2 x))*/(Rabsolu (f2 x))))*((Rabsolu (f2 x))*(Rabsolu (f2 x))*eps*(/4*/2*/(Rabsolu (f1 x))))`` with ``eps*/4*((Rabsolu (f2 x))*/(Rabsolu (f2 x)))*((Rabsolu (f2 x))*/(Rabsolu (f2 x)))*((Rabsolu (f1 x))*/(Rabsolu (f1 x)))*(2*/2)``; [Idtac | Ring].
-Repeat Rewrite <- Rinv_r_sym; Try DiscrR Orelse (Apply Rabsolu_no_R0; Assumption).
-Ring.
-Symmetry; Apply Rabsolu_right; Left; Sup0.
-Symmetry; Apply Rabsolu_right; Left; Sup.
-Symmetry; Apply Rabsolu_right; Left; Assumption.
-Qed.
-
-Lemma maj_term4 : (x,h,eps,l2,alp_f2,alp_f2c:R;eps_f2:posreal;f1,f2:R->R) ``0 < eps`` -> ``(f2 x)<>0`` -> ``(f2 (x+h))<>0`` -> ((a:R)``(Rabsolu a) < alp_f2c`` -> ``(Rabsolu ((f2 (x+a))-(f2 x))) < (Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``)  -> ((a:R)``(Rabsolu a) < (Rmin eps_f2 alp_f2)``->``/(Rabsolu (f2 (x+a))) < 2/(Rabsolu (f2 x))``) -> ``h<>0`` -> ``(Rabsolu h)<alp_f2c`` -> ``(Rabsolu h) < (Rmin eps_f2 alp_f2)`` -> ``(f1 x)<>0`` -> ``l2<>0`` -> ``(Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))*((f2 (x+h))-(f2 x)))) < eps/4``.
-Intros.
-Assert H9 := (H2 h H5).
-Assert H10 := (H3 h H6).
-Apply Rle_lt_trans with ``(Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))))*(Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``.
-Rewrite Rabsolu_mult.
-Apply Rle_monotony.
-Apply Rabsolu_pos.
-Left; Apply H9.
-Apply Rlt_le_trans with ``(Rabsolu (2*l2*(f1 x)/((Rsqr (f2 x))*(f2 x))))*(Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``.
-Apply Rlt_monotony_r.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv; Unfold Rsqr; Repeat Apply prod_neq_R0; Assumption Orelse Idtac.
-Red; Intro H11; Rewrite H11 in H; Elim (Rlt_antirefl ? H).
-Apply Rinv_neq_R0; Apply prod_neq_R0.
-Apply prod_neq_R0.
-DiscrR.
-Assumption.
-Assumption.
-Unfold Rdiv.
-Repeat Rewrite Rinv_Rmult; Try Assumption Orelse (Unfold Rsqr; Apply prod_neq_R0; Assumption).
-Repeat Rewrite Rabsolu_mult.
-Replace ``(Rabsolu 2)`` with ``2``.
-Replace ``2*(Rabsolu l2)*((Rabsolu (f1 x))*((Rabsolu (/(Rsqr (f2 x))))*(Rabsolu (/(f2 x)))))`` with ``(Rabsolu l2)*((Rabsolu (f1 x))*((Rabsolu (/(Rsqr (f2 x))))*((Rabsolu (/(f2 x)))*2)))``; [Idtac | Ring].
-Replace ``(Rabsolu l2)*(Rabsolu (f1 x))*((Rabsolu (/(Rsqr (f2 x))))*(Rabsolu (/(f2 (x+h)))))`` with ``(Rabsolu l2)*((Rabsolu (f1 x))*(((Rabsolu (/(Rsqr (f2 x))))*(Rabsolu (/(f2 (x+h)))))))``; [Idtac | Ring].
-Repeat Apply Rlt_monotony.
-Apply Rabsolu_pos_lt; Assumption.
-Apply Rabsolu_pos_lt; Assumption.
-Apply Rabsolu_pos_lt; Apply Rinv_neq_R0; Unfold Rsqr; Apply prod_neq_R0;  Assumption.
-Repeat Rewrite Rabsolu_Rinv; [Idtac | Assumption | Assumption].
-Rewrite <- (Rmult_sym ``2``).
-Unfold Rdiv in H10; Exact H10.
-Symmetry; Apply Rabsolu_right; Left; Sup0.
-Right; Unfold Rsqr Rdiv.
-Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Repeat Rewrite Rabsolu_mult.
-Repeat Rewrite Rabsolu_Rinv; Try Assumption Orelse DiscrR.
-Replace (Rabsolu eps) with eps.
-Replace ``(Rabsolu (8))`` with ``8``.
-Replace ``(Rabsolu 2)`` with ``2``.
-Replace ``8`` with ``4*2``; [Idtac | Ring].
-Rewrite Rinv_Rmult; DiscrR.
-Replace ``2*(Rabsolu l2)*((Rabsolu (f1 x))*(/(Rabsolu (f2 x))*/(Rabsolu (f2 x))*/(Rabsolu (f2 x))))*((Rabsolu (f2 x))*(Rabsolu (f2 x))*(Rabsolu (f2 x))*eps*(/4*/2*/(Rabsolu (f1 x))*/(Rabsolu l2)))`` with ``eps*/4*((Rabsolu l2)*/(Rabsolu l2))*((Rabsolu (f1 x))*/(Rabsolu (f1 x)))*((Rabsolu (f2 x))*/(Rabsolu (f2 x)))*((Rabsolu (f2 x))*/(Rabsolu (f2 x)))*((Rabsolu (f2 x))*/(Rabsolu (f2 x)))*(2*/2)``; [Idtac | Ring].
-Repeat Rewrite <- Rinv_r_sym; Try DiscrR Orelse (Apply Rabsolu_no_R0; Assumption).
-Ring.
-Symmetry; Apply Rabsolu_right; Left; Sup0.
-Symmetry; Apply Rabsolu_right; Left; Sup.
-Symmetry; Apply Rabsolu_right; Left; Assumption.
-Apply prod_neq_R0; Assumption Orelse DiscrR.
-Apply prod_neq_R0; Assumption.
-Qed.
-
-Lemma D_x_no_cond : (x,a:R) ``a<>0`` -> (D_x no_cond x ``x+a``).
-Intros.
-Unfold D_x no_cond.
-Split.
-Trivial.
-Apply Rminus_not_eq.
-Unfold Rminus.
-Rewrite Ropp_distr1.
-Rewrite <- Rplus_assoc.
-Rewrite Rplus_Ropp_r.
-Rewrite Rplus_Ol.
-Apply Ropp_neq; Assumption.
-Qed.
-
-Lemma Rabsolu_4 : (a,b,c,d:R) ``(Rabsolu (a+b+c+d)) <= (Rabsolu a) + (Rabsolu b) + (Rabsolu c) + (Rabsolu d)``.
-Intros.
-Apply Rle_trans with ``(Rabsolu (a+b)) + (Rabsolu (c+d))``.
-Replace ``a+b+c+d`` with ``(a+b)+(c+d)``; [Apply Rabsolu_triang | Ring].
-Apply Rle_trans with ``(Rabsolu a) + (Rabsolu b) + (Rabsolu (c+d))``.
-Apply Rle_compatibility_r.
-Apply Rabsolu_triang.
-Repeat Rewrite Rplus_assoc; Repeat Apply Rle_compatibility.
-Apply Rabsolu_triang.
-Qed.
-
-Lemma Rlt_4 : (a,b,c,d,e,f,g,h:R) ``a < b`` -> ``c < d`` -> ``e < f `` -> ``g < h`` -> ``a+c+e+g < b+d+f+h``.
-Intros; Apply Rlt_trans with ``b+c+e+g``.
-Repeat Apply Rlt_compatibility_r; Assumption.
-Repeat Rewrite Rplus_assoc; Apply Rlt_compatibility.
-Apply Rlt_trans with ``d+e+g``.
-Rewrite Rplus_assoc; Apply Rlt_compatibility_r; Assumption.
-Rewrite Rplus_assoc; Apply Rlt_compatibility; Apply Rlt_trans with ``f+g``.
-Apply Rlt_compatibility_r; Assumption.
-Apply Rlt_compatibility; Assumption.
-Qed.
-
-Lemma Rmin_2 : (a,b,c:R) ``a < b`` -> ``a < c`` -> ``a < (Rmin b c)``.
-Intros; Unfold Rmin; Case (total_order_Rle b c); Intro; Assumption.
-Qed.
-
-Lemma quadruple : (x:R) ``4*x == x + x + x + x``.
-Intro; Ring.
-Qed.
-
-Lemma quadruple_var : (x:R) `` x == x/4 + x/4 + x/4 + x/4``.
-Intro; Rewrite <- quadruple.
-Unfold Rdiv; Rewrite <- Rmult_assoc; Rewrite Rinv_r_simpl_m; DiscrR.
-Reflexivity.
-Qed.
-
-(**********)
-Lemma continuous_neq_0 : (f:R->R; x0:R) (continuity_pt f x0) -> ~``(f x0)==0`` -> (EXT eps : posreal | (h:R) ``(Rabsolu h) < eps`` -> ~``(f (x0+h))==0``).
-Intros; Unfold continuity_pt in H; Unfold continue_in in H; Unfold limit1_in in H; Unfold limit_in in H; Elim (H ``(Rabsolu ((f x0)/2))``).
-Intros; Elim H1; Intros.
-Exists (mkposreal x H2).
-Intros; Assert H5 := (H3 ``x0+h``).
-Cut ``(dist R_met (x0+h) x0) < x`` -> ``(dist R_met (f (x0+h)) (f x0)) < (Rabsolu ((f x0)/2))``.
-Unfold dist; Simpl; Unfold R_dist; Replace ``x0+h-x0`` with h.
-Intros; Assert H7 := (H6 H4).
-Red; Intro.
-Rewrite H8 in H7; Unfold Rminus in H7; Rewrite Rplus_Ol in H7; Rewrite Rabsolu_Ropp in H7; Unfold Rdiv in H7; Rewrite Rabsolu_mult in H7; Pattern 1 ``(Rabsolu (f x0)) `` in H7; Rewrite <- Rmult_1r in H7.
-Cut ``0<(Rabsolu (f x0))``.
-Intro; Assert H10 := (Rlt_monotony_contra ? ? ? H9 H7).
-Cut ``(Rabsolu (/2))==/2``.
-Assert Hyp:``0<2``.
-Sup0.
-Intro; Rewrite H11 in H10; Assert H12 := (Rlt_monotony ``2`` ? ? Hyp H10); Rewrite Rmult_1r in H12; Rewrite <- Rinv_r_sym in H12; [Idtac | DiscrR].
-Cut (Rlt (IZR `1`) (IZR `2`)).
-Unfold IZR; Unfold INR convert; Simpl; Intro; Elim (Rlt_antirefl ``1`` (Rlt_trans ? ? ? H13 H12)).
-Apply IZR_lt; Omega.
-Unfold Rabsolu; Case (case_Rabsolu ``/2``); Intro.
-Assert Hyp:``0<2``.
-Sup0.
-Assert H11 := (Rlt_monotony ``2`` ? ? Hyp r); Rewrite Rmult_Or in H11; Rewrite <- Rinv_r_sym in H11; [Idtac | DiscrR].
-Elim (Rlt_antirefl ``0`` (Rlt_trans ? ? ? Rlt_R0_R1 H11)).
-Reflexivity.
-Apply (Rabsolu_pos_lt ? H0).
-Ring.
-Assert H6 := (Req_EM ``x0`` ``x0+h``); Elim H6; Intro.
-Intro; Rewrite <- H7; Unfold dist R_met; Unfold R_dist; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply Rabsolu_pos_lt.
-Unfold Rdiv; Apply prod_neq_R0; [Assumption | Apply Rinv_neq_R0; DiscrR].
-Intro; Apply H5.
-Split.
-Unfold D_x no_cond.
-Split; Trivial Orelse Assumption.
-Assumption.
-Change ``0 < (Rabsolu ((f x0)/2))``.
-Apply Rabsolu_pos_lt; Unfold Rdiv; Apply prod_neq_R0.
-Assumption.
-Apply Rinv_neq_R0; DiscrR.
-Qed.
diff --git a/theories7/Reals/Ranalysis3.v b/theories7/Reals/Ranalysis3.v
deleted file mode 100644
index 6ce63bbc..00000000
--- a/theories7/Reals/Ranalysis3.v
+++ /dev/null
@@ -1,617 +0,0 @@
-(************************************************************************)
-(*  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: Ranalysis3.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Ranalysis1.
-Require Ranalysis2.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(* Division *)
-Theorem derivable_pt_lim_div : (f1,f2:R->R;x,l1,l2:R) (derivable_pt_lim f1 x l1) -> (derivable_pt_lim f2 x l2) -> ~``(f2 x)==0``-> (derivable_pt_lim (div_fct f1 f2) x ``(l1*(f2 x)-l2*(f1 x))/(Rsqr (f2 x))``).
-Intros.
-Cut (derivable_pt f2 x); [Intro | Unfold derivable_pt; Apply Specif.existT with l2; Exact H0].
-Assert H2 := ((continuous_neq_0 ? ? (derivable_continuous_pt ? ? X)) H1).
-Elim H2; Clear H2; Intros eps_f2 H2.
-Unfold div_fct.
-Assert H3 := (derivable_continuous_pt ? ? X).
-Unfold continuity_pt in H3; Unfold continue_in in H3; Unfold limit1_in in H3; Unfold limit_in in H3; Unfold dist in H3.
-Simpl in H3; Unfold R_dist in H3.
-Elim (H3 ``(Rabsolu (f2 x))/2``); [Idtac | Unfold Rdiv; Change ``0 < (Rabsolu (f2 x))*/2``; Apply Rmult_lt_pos; [Apply Rabsolu_pos_lt; Assumption | Apply Rlt_Rinv; Sup0]].
-Clear H3; Intros alp_f2 H3.
-Cut (x0:R) ``(Rabsolu (x0-x)) < alp_f2`` ->``(Rabsolu ((f2 x0)-(f2 x))) < (Rabsolu (f2 x))/2``.
-Intro H4.
-Cut (a:R) ``(Rabsolu (a-x)) < alp_f2``->``(Rabsolu (f2 x))/2 < (Rabsolu (f2 a))``.
-Intro H5.
-Cut (a:R) ``(Rabsolu (a)) < (Rmin eps_f2 alp_f2)`` -> ``/(Rabsolu (f2 (x+a))) < 2/(Rabsolu (f2 x))``.
-Intro Maj.
-Unfold derivable_pt_lim; Intros.
-Elim (H ``(Rabsolu ((eps*(f2 x))/8))``); [Idtac | Unfold Rdiv; Change ``0 < (Rabsolu (eps*(f2 x)*/8))``; Apply Rabsolu_pos_lt; Repeat Apply prod_neq_R0; [Red; Intro H7; Rewrite H7 in H6; Elim (Rlt_antirefl ? H6) | Assumption | Apply Rinv_neq_R0; DiscrR]].
-Intros alp_f1d H7.
-Case (Req_EM (f1 x) R0); Intro.
-Case (Req_EM l1 R0); Intro.
-(***********************************)
-(*              Cas n° 1           *)
-(*           (f1 x)=0  l1 =0       *)
-(***********************************)
-Cut ``0 < (Rmin eps_f2 (Rmin alp_f2 alp_f1d))``; [Intro | Repeat Apply Rmin_pos; [Apply (cond_pos eps_f2) | Elim H3; Intros; Assumption | Apply (cond_pos alp_f1d)]].
-Exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10).
-Simpl; Intros.
-Assert H13 := (Rlt_le_trans ? ? ? H12 (Rmin_r ? ?)).
-Assert H14 := (Rlt_le_trans ? ? ? H12 (Rmin_l ? ?)).
-Assert H15 := (Rlt_le_trans ? ? ? H13 (Rmin_r ? ?)).
-Assert H16 := (Rlt_le_trans ? ? ? H13 (Rmin_l ? ?)).
-Assert H17 := (H7 ? H11 H15).
-Rewrite formule; [Idtac | Assumption | Assumption | Apply H2; Apply H14].
-Apply Rle_lt_trans with ``(Rabsolu (/(f2 (x+h))*(((f1 (x+h))-(f1 x))/h-l1))) + (Rabsolu (l1/((f2 x)*(f2 (x+h)))*((f2 x)-(f2 (x+h))))) + (Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))-(f2 x))/h-l2))) + (Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))*((f2 (x+h))-(f2 x))))``.
-Unfold Rminus.
-Rewrite <- (Rabsolu_Ropp ``(f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))+ -(f2 x))/h+ -l2)``).
-Apply Rabsolu_4.
-Repeat Rewrite Rabsolu_mult.
-Apply Rlt_le_trans with ``eps/4+eps/4+eps/4+eps/4``.
-Cut ``(Rabsolu (/(f2 (x+h))))*(Rabsolu (((f1 (x+h))-(f1 x))/h-l1)) < eps/4``.
-Cut ``(Rabsolu (l1/((f2 x)*(f2 (x+h)))))*(Rabsolu ((f2 x)-(f2 (x+h)))) < eps/4``.
-Cut ``(Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))))*(Rabsolu (((f2 (x+h))-(f2 x))/h-l2)) < eps/4``.
-Cut ``(Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))))*(Rabsolu ((f2 (x+h))-(f2 x))) < eps/4``.
-Intros.
-Apply Rlt_4; Assumption.
-Rewrite H8.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite H8.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite H9.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite <- Rabsolu_mult.
-Apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); Try Assumption Orelse Apply H2.
-Apply H14.
-Apply Rmin_2; Assumption.
-Right; Symmetry; Apply quadruple_var.
-(***********************************)
-(*              Cas n° 2           *)
-(*           (f1 x)=0  l1<>0       *)
-(***********************************)
-Assert H10 := (derivable_continuous_pt ? ? X).
-Unfold continuity_pt in H10.
-Unfold continue_in in H10.
-Unfold limit1_in in H10.
-Unfold limit_in in H10.
-Unfold dist in H10.
-Simpl in H10.
-Unfold R_dist in H10.
-Elim (H10 ``(Rabsolu (eps*(Rsqr (f2 x)))/(8*l1))``).
-Clear H10; Intros alp_f2t2 H10.
-Cut (a:R) ``(Rabsolu a) < alp_f2t2`` -> ``(Rabsolu ((f2 (x+a)) - (f2 x))) < (Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``.
-Intro H11.
-Cut ``0 < (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2))``.
-Intro.
-Exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12).
-Simpl.
-Intros.
-Assert H15 := (Rlt_le_trans ? ? ? H14 (Rmin_r ? ?)).
-Assert H16 := (Rlt_le_trans ? ? ? H14 (Rmin_l ? ?)).
-Assert H17 := (Rlt_le_trans ? ? ? H15 (Rmin_l ? ?)).
-Assert H18 := (Rlt_le_trans ? ? ? H15 (Rmin_r ? ?)).
-Assert H19 := (Rlt_le_trans ? ? ? H16 (Rmin_l ? ?)).
-Assert H20 := (Rlt_le_trans ? ? ? H16 (Rmin_r ? ?)).
-Clear H14 H15 H16.
-Rewrite formule; Try Assumption.
-Apply Rle_lt_trans with ``(Rabsolu (/(f2 (x+h))*(((f1 (x+h))-(f1 x))/h-l1))) + (Rabsolu (l1/((f2 x)*(f2 (x+h)))*((f2 x)-(f2 (x+h))))) + (Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))-(f2 x))/h-l2))) + (Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))*((f2 (x+h))-(f2 x))))``.
-Unfold Rminus.
-Rewrite <- (Rabsolu_Ropp ``(f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))+ -(f2 x))/h+ -l2)``).
-Apply Rabsolu_4.
-Repeat Rewrite Rabsolu_mult.
-Apply Rlt_le_trans with ``eps/4+eps/4+eps/4+eps/4``.
-Cut ``(Rabsolu (/(f2 (x+h))))*(Rabsolu (((f1 (x+h))-(f1 x))/h-l1)) < eps/4``.
-Cut ``(Rabsolu (l1/((f2 x)*(f2 (x+h)))))*(Rabsolu ((f2 x)-(f2 (x+h)))) < eps/4``.
-Cut ``(Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))))*(Rabsolu (((f2 (x+h))-(f2 x))/h-l2)) < eps/4``.
-Cut ``(Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))))*(Rabsolu ((f2 (x+h))-(f2 x))) < eps/4``.
-Intros.
-Apply Rlt_4; Assumption.
-Rewrite H8.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite H8.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite <- Rabsolu_mult.
-Apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Right; Symmetry; Apply quadruple_var.
-Apply H2; Assumption.
-Repeat Apply Rmin_pos.
-Apply (cond_pos eps_f2).
-Apply (cond_pos alp_f1d).
-Elim H3; Intros; Assumption.
-Elim H10; Intros; Assumption.
-Intros.
-Elim H10; Intros.
-Case (Req_EM a R0); Intro.
-Rewrite H14; Rewrite Rplus_Or.
-Unfold Rminus; Rewrite Rplus_Ropp_r.
-Rewrite Rabsolu_R0.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr; Repeat Rewrite Rmult_assoc.
-Repeat Apply prod_neq_R0; Try Assumption.
-Red; Intro; Rewrite H15 in H6; Elim (Rlt_antirefl ? H6).
-Apply Rinv_neq_R0; Repeat Apply prod_neq_R0; DiscrR Orelse Assumption.
-Apply H13.
-Split.
-Apply D_x_no_cond; Assumption.
-Replace ``x+a-x`` with a; [Assumption | Ring].
-Change ``0<(Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``.
-Apply Rabsolu_pos_lt; Unfold Rdiv Rsqr; Repeat Rewrite Rmult_assoc; Repeat Apply prod_neq_R0.
-Red; Intro; Rewrite H11 in H6; Elim (Rlt_antirefl ? H6).
-Assumption. 
-Assumption.
-Apply Rinv_neq_R0; Repeat Apply prod_neq_R0; [DiscrR | DiscrR | DiscrR | Assumption].
-(***********************************)
-(*              Cas n° 3           *)
-(*     (f1 x)<>0  l1=0  l2=0       *)
-(***********************************)
-Case (Req_EM l1 R0); Intro.
-Case (Req_EM l2 R0); Intro.
-Elim (H0 ``(Rabsolu ((Rsqr (f2 x))*eps)/(8*(f1 x)))``); [Idtac | Apply Rabsolu_pos_lt; Unfold Rdiv Rsqr; Repeat Rewrite Rmult_assoc; Repeat Apply prod_neq_R0; [Assumption | Assumption | Red; Intro; Rewrite H11 in H6; Elim (Rlt_antirefl ? H6) | Apply Rinv_neq_R0; Repeat Apply prod_neq_R0; DiscrR Orelse Assumption]].
-Intros alp_f2d H12.
-Cut ``0 < (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))``.
-Intro.
-Exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11).
-Simpl.
-Intros.
-Assert H15 := (Rlt_le_trans ? ? ? H14 (Rmin_l ? ?)).
-Assert H16 := (Rlt_le_trans ? ? ? H14 (Rmin_r ? ?)).
-Assert H17 := (Rlt_le_trans ? ? ? H15 (Rmin_l ? ?)).
-Assert H18 := (Rlt_le_trans ? ? ? H15 (Rmin_r ? ?)).
-Assert H19 := (Rlt_le_trans ? ? ? H16 (Rmin_l ? ?)).
-Assert H20 := (Rlt_le_trans ? ? ? H16 (Rmin_r ? ?)).
-Clear H15 H16.
-Rewrite formule; Try Assumption.
-Apply Rle_lt_trans with ``(Rabsolu (/(f2 (x+h))*(((f1 (x+h))-(f1 x))/h-l1))) + (Rabsolu (l1/((f2 x)*(f2 (x+h)))*((f2 x)-(f2 (x+h))))) + (Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))-(f2 x))/h-l2))) + (Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))*((f2 (x+h))-(f2 x))))``.
-Unfold Rminus.
-Rewrite <- (Rabsolu_Ropp ``(f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))+ -(f2 x))/h+ -l2)``).
-Apply Rabsolu_4.
-Repeat Rewrite Rabsolu_mult.
-Apply Rlt_le_trans with ``eps/4+eps/4+eps/4+eps/4``.
-Cut ``(Rabsolu (/(f2 (x+h))))*(Rabsolu (((f1 (x+h))-(f1 x))/h-l1)) < eps/4``.
-Cut ``(Rabsolu (l1/((f2 x)*(f2 (x+h)))))*(Rabsolu ((f2 x)-(f2 (x+h)))) < eps/4``.
-Cut ``(Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))))*(Rabsolu (((f2 (x+h))-(f2 x))/h-l2)) < eps/4``.
-Cut ``(Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))))*(Rabsolu ((f2 (x+h))-(f2 x))) < eps/4``.
-Intros.
-Apply Rlt_4; Assumption.
-Rewrite H10.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite <- Rabsolu_mult.
-Apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite H9.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite <- Rabsolu_mult.
-Apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); Assumption Orelse Idtac.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Right; Symmetry; Apply quadruple_var.
-Apply H2; Assumption.
-Repeat Apply Rmin_pos.
-Apply (cond_pos eps_f2).
-Elim H3; Intros; Assumption.
-Apply (cond_pos alp_f1d).
-Apply (cond_pos alp_f2d).
-(***********************************)
-(*              Cas n° 4           *)
-(*    (f1 x)<>0  l1=0  l2<>0       *)
-(***********************************)
-Elim (H0 ``(Rabsolu ((Rsqr (f2 x))*eps)/(8*(f1 x)))``); [Idtac | Apply Rabsolu_pos_lt; Unfold Rsqr Rdiv; Repeat Rewrite Rinv_Rmult; Repeat Apply prod_neq_R0; Try Assumption Orelse DiscrR].
-Intros alp_f2d H11.
-Assert H12 := (derivable_continuous_pt ? ? X).
-Unfold continuity_pt in H12.
-Unfold continue_in in H12.
-Unfold limit1_in in H12.
-Unfold limit_in in H12.
-Unfold dist in H12.
-Simpl in H12.
-Unfold R_dist in H12.
-Elim (H12 ``(Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``).
-Intros alp_f2c H13.
-Cut ``0 < (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c)))``.
-Intro.
-Exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))) H14).
-Simpl; Intros.
-Assert H17 := (Rlt_le_trans ? ? ? H16 (Rmin_l ? ?)).
-Assert H18 := (Rlt_le_trans ? ? ? H16 (Rmin_r ? ?)).
-Assert H19 := (Rlt_le_trans ? ? ? H18 (Rmin_r ? ?)).
-Assert H20 := (Rlt_le_trans ? ? ? H19 (Rmin_l ? ?)).
-Assert H21 := (Rlt_le_trans ? ? ? H19 (Rmin_r ? ?)).
-Assert H22 := (Rlt_le_trans ? ? ? H18 (Rmin_l ? ?)).
-Assert H23 := (Rlt_le_trans ? ? ? H17 (Rmin_l ? ?)).
-Assert H24 := (Rlt_le_trans ? ? ? H17 (Rmin_r ? ?)).
-Clear H16 H17 H18 H19.
-Cut (a:R) ``(Rabsolu a) < alp_f2c`` -> ``(Rabsolu ((f2 (x+a))-(f2 x))) < (Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``.
-Intro.
-Rewrite formule; Try Assumption.
-Apply Rle_lt_trans with ``(Rabsolu (/(f2 (x+h))*(((f1 (x+h))-(f1 x))/h-l1))) + (Rabsolu (l1/((f2 x)*(f2 (x+h)))*((f2 x)-(f2 (x+h))))) + (Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))-(f2 x))/h-l2))) + (Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))*((f2 (x+h))-(f2 x))))``.
-Unfold Rminus.
-Rewrite <- (Rabsolu_Ropp ``(f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))+ -(f2 x))/h+ -l2)``).
-Apply Rabsolu_4.
-Repeat Rewrite Rabsolu_mult.
-Apply Rlt_le_trans with ``eps/4+eps/4+eps/4+eps/4``.
-Cut ``(Rabsolu (/(f2 (x+h))))*(Rabsolu (((f1 (x+h))-(f1 x))/h-l1)) < eps/4``.
-Cut ``(Rabsolu (l1/((f2 x)*(f2 (x+h)))))*(Rabsolu ((f2 x)-(f2 (x+h)))) < eps/4``.
-Cut ``(Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))))*(Rabsolu (((f2 (x+h))-(f2 x))/h-l2)) < eps/4``.
-Cut ``(Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))))*(Rabsolu ((f2 (x+h))-(f2 x))) < eps/4``.
-Intros.
-Apply Rlt_4; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite H9.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite <- Rabsolu_mult.
-Apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Right; Symmetry; Apply quadruple_var.
-Apply H2; Assumption.
-Intros.
-Case (Req_EM a R0); Intro.
-Rewrite H17; Rewrite Rplus_Or.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr.
-Repeat Rewrite Rinv_Rmult; Try Assumption.
-Repeat Apply prod_neq_R0; Try Assumption.
-Red; Intro H18; Rewrite H18 in H6; Elim (Rlt_antirefl ? H6). 
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; Assumption.
-Apply Rinv_neq_R0; Assumption.
-DiscrR.
-DiscrR.
-DiscrR.
-DiscrR.
-DiscrR.
-Apply prod_neq_R0; [DiscrR | Assumption].
-Elim H13; Intros.
-Apply H19.
-Split.
-Apply D_x_no_cond; Assumption.
-Replace ``x+a-x`` with a; [Assumption | Ring].
-Repeat Apply Rmin_pos.
-Apply (cond_pos eps_f2).
-Elim H3; Intros; Assumption.
-Apply (cond_pos alp_f1d).
-Apply (cond_pos alp_f2d).
-Elim H13; Intros; Assumption.
-Change ``0 < (Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``.
-Apply Rabsolu_pos_lt.
-Unfold Rsqr Rdiv.
-Repeat Rewrite Rinv_Rmult; Try Assumption Orelse DiscrR.
-Repeat Apply prod_neq_R0; Try Assumption.
-Red; Intro H13; Rewrite H13 in H6; Elim (Rlt_antirefl ? H6). 
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; Assumption.
-Apply Rinv_neq_R0; Assumption.
-Apply prod_neq_R0; [DiscrR | Assumption].
-Red; Intro H11; Rewrite H11 in H6; Elim (Rlt_antirefl ? H6). 
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; DiscrR.
-Apply Rinv_neq_R0; Assumption.
-(***********************************)
-(*              Cas n° 5           *)
-(*    (f1 x)<>0  l1<>0  l2=0       *)
-(***********************************)
-Case (Req_EM l2 R0); Intro.
-Assert H11 := (derivable_continuous_pt ? ? X).
-Unfold continuity_pt in H11.
-Unfold continue_in in H11.
-Unfold limit1_in in H11.
-Unfold limit_in in H11.
-Unfold dist in H11.
-Simpl in H11.
-Unfold R_dist in H11.
-Elim (H11 ``(Rabsolu (eps*(Rsqr (f2 x)))/(8*l1))``).
-Clear H11; Intros alp_f2t2 H11.
-Elim (H0 ``(Rabsolu ((Rsqr (f2 x))*eps)/(8*(f1 x)))``).
-Intros alp_f2d H12.
-Cut ``0 < (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2)))``.
-Intro.
-Exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13).
-Simpl.
-Intros.
-Cut (a:R) ``(Rabsolu a)<alp_f2t2`` -> ``(Rabsolu ((f2 (x+a))-(f2 x)))<(Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``.
-Intro.
-Assert H17 := (Rlt_le_trans ? ? ? H15 (Rmin_l ? ?)).
-Assert H18 := (Rlt_le_trans ? ? ? H15 (Rmin_r ? ?)).
-Assert H19 := (Rlt_le_trans ? ? ? H17 (Rmin_r ? ?)).
-Assert H20 := (Rlt_le_trans ? ? ? H17 (Rmin_l ? ?)).
-Assert H21 := (Rlt_le_trans ? ? ? H18 (Rmin_r ? ?)).
-Assert H22 := (Rlt_le_trans ? ? ? H18 (Rmin_l ? ?)).
-Assert H23 := (Rlt_le_trans ? ? ? H21 (Rmin_l ? ?)).
-Assert H24 := (Rlt_le_trans ? ? ? H21 (Rmin_r ? ?)).
-Clear H15 H17 H18 H21.
-Rewrite formule; Try Assumption.
-Apply Rle_lt_trans with ``(Rabsolu (/(f2 (x+h))*(((f1 (x+h))-(f1 x))/h-l1))) + (Rabsolu (l1/((f2 x)*(f2 (x+h)))*((f2 x)-(f2 (x+h))))) + (Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))-(f2 x))/h-l2))) + (Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))*((f2 (x+h))-(f2 x))))``.
-Unfold Rminus.
-Rewrite <- (Rabsolu_Ropp ``(f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))+ -(f2 x))/h+ -l2)``).
-Apply Rabsolu_4.
-Repeat Rewrite Rabsolu_mult.
-Apply Rlt_le_trans with ``eps/4+eps/4+eps/4+eps/4``.
-Cut ``(Rabsolu (/(f2 (x+h))))*(Rabsolu (((f1 (x+h))-(f1 x))/h-l1)) < eps/4``.
-Cut ``(Rabsolu (l1/((f2 x)*(f2 (x+h)))))*(Rabsolu ((f2 x)-(f2 (x+h)))) < eps/4``.
-Cut ``(Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))))*(Rabsolu (((f2 (x+h))-(f2 x))/h-l2)) < eps/4``.
-Cut ``(Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))))*(Rabsolu ((f2 (x+h))-(f2 x))) < eps/4``.
-Intros.
-Apply Rlt_4; Assumption.
-Rewrite H10.
-Unfold Rdiv; Repeat Rewrite Rmult_Or Orelse Rewrite Rmult_Ol.
-Rewrite Rabsolu_R0; Rewrite Rmult_Ol.
-Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup].
-Rewrite <- Rabsolu_mult.
-Apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Right; Symmetry; Apply quadruple_var.
-Apply H2; Assumption.
-Intros.
-Case (Req_EM a R0); Intro.
-Rewrite H17; Rewrite Rplus_Or; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv; Rewrite Rinv_Rmult; Try DiscrR Orelse Assumption.
-Unfold Rsqr.
-Repeat Apply prod_neq_R0; Assumption Orelse (Apply Rinv_neq_R0; Assumption) Orelse (Apply Rinv_neq_R0; DiscrR) Orelse (Red; Intro H18; Rewrite H18 in H6; Elim (Rlt_antirefl ? H6)).
-Elim H11; Intros.
-Apply H19.
-Split.
-Apply D_x_no_cond; Assumption.
-Replace ``x+a-x`` with a; [Assumption | Ring].
-Repeat Apply Rmin_pos.
-Apply (cond_pos eps_f2).
-Elim H3; Intros; Assumption.
-Apply (cond_pos alp_f1d). 
-Apply (cond_pos alp_f2d).
-Elim H11; Intros; Assumption.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr; Rewrite Rinv_Rmult; Try DiscrR Orelse Assumption.
-Repeat Apply prod_neq_R0; Assumption Orelse (Apply Rinv_neq_R0; Assumption) Orelse (Apply Rinv_neq_R0; DiscrR) Orelse (Red; Intro H12; Rewrite H12 in H6; Elim (Rlt_antirefl ? H6)).
-Change ``0 < (Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr; Rewrite Rinv_Rmult; Try DiscrR Orelse Assumption.
-Repeat Apply prod_neq_R0; Assumption Orelse (Apply Rinv_neq_R0; Assumption) Orelse (Apply Rinv_neq_R0; DiscrR) Orelse (Red; Intro H12; Rewrite H12 in H6; Elim (Rlt_antirefl ? H6)).
-(***********************************)
-(*              Cas n° 6           *)
-(*    (f1 x)<>0  l1<>0  l2<>0      *)
-(***********************************)
-Elim (H0 ``(Rabsolu ((Rsqr (f2 x))*eps)/(8*(f1 x)))``).
-Intros alp_f2d H11.
-Assert H12 := (derivable_continuous_pt ? ? X).
-Unfold continuity_pt in H12.
-Unfold continue_in in H12.
-Unfold limit1_in in H12.
-Unfold limit_in in H12.
-Unfold dist in H12.
-Simpl in H12.
-Unfold R_dist in H12.
-Elim (H12 ``(Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``).
-Intros alp_f2c H13.
-Elim (H12 ``(Rabsolu (eps*(Rsqr (f2 x)))/(8*l1))``).
-Intros alp_f2t2 H14.
-Cut ``0 < (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) (Rmin alp_f2c alp_f2t2))``.
-Intro.
-Exists (mkposreal (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) (Rmin alp_f2c alp_f2t2)) H15).
-Simpl.
-Intros.
-Assert H18 := (Rlt_le_trans ? ? ? H17 (Rmin_l ? ?)).
-Assert H19 := (Rlt_le_trans ? ? ? H17 (Rmin_r ? ?)).
-Assert H20 := (Rlt_le_trans ? ? ? H18 (Rmin_l ? ?)).
-Assert H21 := (Rlt_le_trans ? ? ? H18 (Rmin_r ? ?)).
-Assert H22 := (Rlt_le_trans ? ? ? H19 (Rmin_l ? ?)).
-Assert H23 := (Rlt_le_trans ? ? ? H19 (Rmin_r ? ?)).
-Assert H24 := (Rlt_le_trans ? ? ? H20 (Rmin_l ? ?)).
-Assert H25 := (Rlt_le_trans ? ? ? H20 (Rmin_r ? ?)).
-Assert H26 := (Rlt_le_trans ? ? ? H21 (Rmin_l ? ?)).
-Assert H27 := (Rlt_le_trans ? ? ? H21 (Rmin_r ? ?)).
-Clear H17 H18 H19 H20 H21.
-Cut (a:R) ``(Rabsolu a) < alp_f2t2`` -> ``(Rabsolu ((f2 (x+a))-(f2 x))) < (Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``.
-Cut (a:R) ``(Rabsolu a) < alp_f2c`` -> ``(Rabsolu ((f2 (x+a))-(f2 x))) < (Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``.
-Intros.
-Rewrite formule; Try Assumption.
-Apply Rle_lt_trans with ``(Rabsolu (/(f2 (x+h))*(((f1 (x+h))-(f1 x))/h-l1))) + (Rabsolu (l1/((f2 x)*(f2 (x+h)))*((f2 x)-(f2 (x+h))))) + (Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))-(f2 x))/h-l2))) + (Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))*((f2 (x+h))-(f2 x))))``.
-Unfold Rminus.
-Rewrite <- (Rabsolu_Ropp ``(f1 x)/((f2 x)*(f2 (x+h)))*(((f2 (x+h))+ -(f2 x))/h+ -l2)``).
-Apply Rabsolu_4.
-Repeat Rewrite Rabsolu_mult.
-Apply Rlt_le_trans with ``eps/4+eps/4+eps/4+eps/4``.
-Cut ``(Rabsolu (/(f2 (x+h))))*(Rabsolu (((f1 (x+h))-(f1 x))/h-l1)) < eps/4``.
-Cut ``(Rabsolu (l1/((f2 x)*(f2 (x+h)))))*(Rabsolu ((f2 x)-(f2 (x+h)))) < eps/4``.
-Cut ``(Rabsolu ((f1 x)/((f2 x)*(f2 (x+h)))))*(Rabsolu (((f2 (x+h))-(f2 x))/h-l2)) < eps/4``.
-Cut ``(Rabsolu ((l2*(f1 x))/((Rsqr (f2 x))*(f2 (x+h)))))*(Rabsolu ((f2 (x+h))-(f2 x))) < eps/4``.
-Intros.
-Apply Rlt_4; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Rewrite <- Rabsolu_mult.
-Apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); Try Assumption.
-Apply H2; Assumption.
-Apply Rmin_2; Assumption.
-Right; Symmetry; Apply quadruple_var.
-Apply H2; Assumption.
-Intros.
-Case (Req_EM a R0); Intro.
-Rewrite H18; Rewrite Rplus_Or; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr; Rewrite Rinv_Rmult.
-Repeat Apply prod_neq_R0; Assumption Orelse (Apply Rinv_neq_R0; Assumption) Orelse (Apply Rinv_neq_R0; DiscrR) Orelse (Red; Intro H28; Rewrite H28 in H6; Elim (Rlt_antirefl ? H6)).
-Apply prod_neq_R0; [DiscrR | Assumption].
-Apply prod_neq_R0; [DiscrR | Assumption].
-Assumption.
-Elim H13; Intros.
-Apply H20.
-Split.
-Apply D_x_no_cond; Assumption.
-Replace ``x+a-x`` with a; [Assumption | Ring].
-Intros.
-Case (Req_EM a R0); Intro.
-Rewrite H18; Rewrite Rplus_Or; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr; Rewrite Rinv_Rmult.
-Repeat Apply prod_neq_R0; Assumption Orelse (Apply Rinv_neq_R0; Assumption) Orelse (Apply Rinv_neq_R0; DiscrR) Orelse (Red; Intro H28; Rewrite H28 in H6; Elim (Rlt_antirefl ? H6)).
-DiscrR.
-Assumption.
-Elim H14; Intros.
-Apply H20.
-Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Apply Rminus_not_eq_right.
-Replace ``x+a-x`` with a; [Assumption | Ring].
-Replace ``x+a-x`` with a; [Assumption | Ring].
-Repeat Apply Rmin_pos.
-Apply (cond_pos eps_f2).
-Elim H3; Intros; Assumption.
-Apply (cond_pos alp_f1d).
-Apply (cond_pos alp_f2d).
-Elim H13; Intros; Assumption.
-Elim H14; Intros; Assumption.
-Change ``0 < (Rabsolu ((eps*(Rsqr (f2 x)))/(8*l1)))``; Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr; Rewrite Rinv_Rmult; Try DiscrR Orelse Assumption.
-Repeat Apply prod_neq_R0; Assumption Orelse (Apply Rinv_neq_R0; Assumption) Orelse (Apply Rinv_neq_R0; DiscrR) Orelse (Red; Intro H14; Rewrite H14 in H6; Elim (Rlt_antirefl ? H6)).
-Change ``0 < (Rabsolu (((Rsqr (f2 x))*(f2 x)*eps)/(8*(f1 x)*l2)))``; Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr; Rewrite Rinv_Rmult.
-Repeat Apply prod_neq_R0; Assumption Orelse (Apply Rinv_neq_R0; Assumption) Orelse (Apply Rinv_neq_R0; DiscrR) Orelse (Red; Intro H13; Rewrite H13 in H6; Elim (Rlt_antirefl ? H6)).
-Apply prod_neq_R0; [DiscrR | Assumption].
-Apply prod_neq_R0; [DiscrR | Assumption].
-Assumption.
-Apply Rabsolu_pos_lt.
-Unfold Rdiv Rsqr; Rewrite Rinv_Rmult; [Idtac | DiscrR | Assumption].
-Repeat Apply prod_neq_R0; Assumption Orelse (Apply Rinv_neq_R0; Assumption) Orelse (Apply Rinv_neq_R0; DiscrR) Orelse (Red; Intro H11; Rewrite H11 in H6; Elim (Rlt_antirefl ? H6)).
-Intros.
-Unfold Rdiv.
-Apply Rlt_monotony_contra with ``(Rabsolu (f2 (x+a)))``.
-Apply Rabsolu_pos_lt; Apply H2.
-Apply Rlt_le_trans with (Rmin eps_f2 alp_f2).
-Assumption.
-Apply Rmin_l.
-Rewrite <- Rinv_r_sym.
-Apply Rlt_monotony_contra with (Rabsolu (f2 x)).
-Apply Rabsolu_pos_lt; Assumption.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym (Rabsolu (f2 x))).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Apply Rlt_monotony_contra with ``/2``.
-Apply Rlt_Rinv; Sup0.
-Repeat Rewrite (Rmult_sym ``/2``).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r.
-Unfold Rdiv in H5; Apply H5.
-Replace ``x+a-x`` with a.
-Assert H7 := (Rlt_le_trans ? ? ? H6 (Rmin_r ? ?)); Assumption.
-Ring.
-DiscrR.
-Apply Rabsolu_no_R0; Assumption.
-Apply Rabsolu_no_R0; Apply H2.
-Assert H7 := (Rlt_le_trans ? ? ? H6 (Rmin_l ? ?)); Assumption.
-Intros.
-Assert H6 := (H4 a H5).
-Rewrite <- (Rabsolu_Ropp ``(f2 a)-(f2 x)``) in H6.
-Rewrite Ropp_distr2 in H6.
-Assert H7 := (Rle_lt_trans ? ? ? (Rabsolu_triang_inv ? ?) H6).
-Apply Rlt_anti_compatibility with ``-(Rabsolu (f2 a)) + (Rabsolu (f2 x))/2``.
-Rewrite Rplus_assoc.
-Rewrite <- double_var.
-Do 2 Rewrite (Rplus_sym ``-(Rabsolu (f2 a))``).
-Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or.
-Unfold Rminus in H7; Assumption.
-Intros.
-Case (Req_EM x x0); Intro.
-Rewrite <- H5; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Unfold Rdiv; Apply Rmult_lt_pos; [Apply Rabsolu_pos_lt; Assumption | Apply Rlt_Rinv; Sup0].
-Elim H3; Intros.
-Apply H7.
-Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Assumption.
-Assumption.
-Qed.
-
-Lemma derivable_pt_div : (f1,f2:R->R;x:R) (derivable_pt f1 x) -> (derivable_pt f2 x) -> ``(f2 x)<>0`` -> (derivable_pt (div_fct f1 f2) x).
-Unfold derivable_pt.
-Intros.
-Elim X; Intros.
-Elim X0; Intros.
-Apply Specif.existT with ``(x0*(f2 x)-x1*(f1 x))/(Rsqr (f2 x))``.
-Apply derivable_pt_lim_div; Assumption.
-Qed.
-
-Lemma derivable_div : (f1,f2:R->R) (derivable f1) -> (derivable f2) -> ((x:R)``(f2 x)<>0``) -> (derivable (div_fct f1 f2)).
-Unfold derivable; Intros.
-Apply (derivable_pt_div ? ? ? (X x) (X0 x) (H x)).
-Qed.
-
-Lemma derive_pt_div : (f1,f2:R->R;x:R;pr1:(derivable_pt f1 x);pr2:(derivable_pt f2 x);na:``(f2 x)<>0``) ``(derive_pt (div_fct f1 f2) x (derivable_pt_div ? ? ? pr1 pr2 na)) == ((derive_pt f1 x pr1)*(f2 x)-(derive_pt f2 x pr2)*(f1 x))/(Rsqr (f2 x))``.
-Intros.
-Assert H := (derivable_derive f1 x pr1).
-Assert H0 := (derivable_derive f2 x pr2).
-Assert H1 := (derivable_derive (div_fct f1 f2) x (derivable_pt_div ? ? ? pr1 pr2 na)).
-Elim H; Clear H; Intros l1 H.
-Elim H0; Clear H0; Intros l2 H0.
-Elim H1; Clear H1; Intros l H1.
-Rewrite H; Rewrite H0; Apply derive_pt_eq_0.
-Assert H3 := (projT2 ? ? pr1).
-Unfold derive_pt in H; Rewrite H in H3.
-Assert H4 := (projT2 ? ? pr2).
-Unfold derive_pt in H0; Rewrite H0 in H4.
-Apply derivable_pt_lim_div; Assumption.
-Qed.
diff --git a/theories7/Reals/Ranalysis4.v b/theories7/Reals/Ranalysis4.v
deleted file mode 100644
index 061854dc..00000000
--- a/theories7/Reals/Ranalysis4.v
+++ /dev/null
@@ -1,313 +0,0 @@
-(************************************************************************)
-(*  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: Ranalysis4.v,v 1.1.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo.
-Require Ranalysis1.
-Require Ranalysis3.
-Require Exp_prop.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(**********)
-Lemma derivable_pt_inv : (f:R->R;x:R) ``(f x)<>0`` -> (derivable_pt f x) -> (derivable_pt (inv_fct f) x).
-Intros; Cut (derivable_pt (div_fct (fct_cte R1) f) x) -> (derivable_pt (inv_fct f) x).
-Intro; Apply X0.
-Apply derivable_pt_div.
-Apply derivable_pt_const.
-Assumption.
-Assumption.
-Unfold div_fct inv_fct fct_cte; Intro; Elim X0; Intros; Unfold derivable_pt; Apply Specif.existT with x0; Unfold derivable_pt_abs; Unfold derivable_pt_lim; Unfold derivable_pt_abs in p; Unfold derivable_pt_lim in p; Intros; Elim (p eps H0); Intros; Exists x1; Intros; Unfold Rdiv in H1; Unfold Rdiv; Rewrite <- (Rmult_1l ``/(f x)``); Rewrite <- (Rmult_1l ``/(f (x+h))``).
-Apply H1; Assumption.
-Qed.
-
-(**********)
-Lemma pr_nu_var : (f,g:R->R;x:R;pr1:(derivable_pt f x);pr2:(derivable_pt g x)) f==g -> (derive_pt f x pr1) == (derive_pt g x pr2).
-Unfold derivable_pt derive_pt; Intros.
-Elim pr1; Intros.
-Elim pr2; Intros.
-Simpl.
-Rewrite H in p.
-Apply unicite_limite with g x; Assumption.
-Qed.
-
-(**********)
-Lemma pr_nu_var2 : (f,g:R->R;x:R;pr1:(derivable_pt f x);pr2:(derivable_pt g x)) ((h:R)(f h)==(g h)) -> (derive_pt f x pr1) == (derive_pt g x pr2).
-Unfold derivable_pt derive_pt; Intros.
-Elim pr1; Intros.
-Elim pr2; Intros.
-Simpl.
-Assert H0 := (unicite_step2 ? ? ? p). 
-Assert H1 := (unicite_step2 ? ? ? p0). 
-Cut (limit1_in [h:R]``((f (x+h))-(f x))/h`` [h:R]``h <> 0`` x1 ``0``).
-Intro; Assert H3 := (unicite_step1 ? ? ? ? H0 H2). 
-Assumption.
-Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Unfold limit1_in in H1; Unfold limit_in in H1; Unfold dist in H1; Simpl in H1; Unfold R_dist in H1.
-Intros; Elim (H1 eps H2); Intros.
-Elim H3; Intros.
-Exists x2.
-Split.
-Assumption.
-Intros; Do 2 Rewrite H; Apply H5; Assumption.
-Qed.
-
-(**********)
-Lemma derivable_inv : (f:R->R) ((x:R)``(f x)<>0``)->(derivable f)->(derivable (inv_fct f)).
-Intros.
-Unfold derivable; Intro.
-Apply derivable_pt_inv.
-Apply (H x).
-Apply (X x).
-Qed.
-
-Lemma derive_pt_inv : (f:R->R;x:R;pr:(derivable_pt f x);na:``(f x)<>0``) (derive_pt (inv_fct f) x (derivable_pt_inv f x na pr)) == ``-(derive_pt f x pr)/(Rsqr (f x))``.
-Intros; Replace (derive_pt (inv_fct f) x (derivable_pt_inv f x na pr)) with (derive_pt (div_fct (fct_cte R1) f) x (derivable_pt_div (fct_cte R1) f x (derivable_pt_const R1 x) pr na)).
-Rewrite derive_pt_div; Rewrite derive_pt_const; Unfold fct_cte; Rewrite Rmult_Ol; Rewrite Rmult_1r; Unfold Rminus; Rewrite Rplus_Ol; Reflexivity.
-Apply pr_nu_var2.
-Intro; Unfold div_fct fct_cte inv_fct.
-Unfold Rdiv; Ring.
-Qed.
-
-(* Rabsolu *)
-Lemma Rabsolu_derive_1 : (x:R) ``0<x`` -> (derivable_pt_lim Rabsolu x ``1``).
-Intros.
-Unfold derivable_pt_lim; Intros.
-Exists (mkposreal x H); Intros.
-Rewrite (Rabsolu_right x).
-Rewrite (Rabsolu_right ``x+h``).
-Rewrite Rplus_sym.
-Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r.
-Rewrite Rplus_Or; Unfold Rdiv; Rewrite <- Rinv_r_sym.
-Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply H0.
-Apply H1.
-Apply Rle_sym1.
-Case (case_Rabsolu h); Intro.
-Rewrite (Rabsolu_left h r) in H2.
-Left; Rewrite Rplus_sym; Apply Rlt_anti_compatibility with ``-h``; Rewrite Rplus_Or; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Apply H2.
-Apply ge0_plus_ge0_is_ge0.
-Left; Apply H.
-Apply Rle_sym2; Apply r.
-Left; Apply H.
-Qed.
-
-Lemma Rabsolu_derive_2 : (x:R) ``x<0`` -> (derivable_pt_lim Rabsolu x ``-1``).
-Intros.
-Unfold derivable_pt_lim; Intros.
-Cut ``0< -x``.
-Intro; Exists (mkposreal ``-x`` H1); Intros.
-Rewrite (Rabsolu_left x).
-Rewrite (Rabsolu_left ``x+h``).
-Rewrite Rplus_sym.
-Rewrite Ropp_distr1.
-Unfold Rminus; Rewrite Ropp_Ropp; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l.
-Rewrite Rplus_Or; Unfold Rdiv.
-Rewrite Ropp_mul1.
-Rewrite <- Rinv_r_sym.
-Rewrite Ropp_Ropp; Rewrite Rplus_Ropp_l; Rewrite Rabsolu_R0; Apply H0.
-Apply H2.
-Case (case_Rabsolu h); Intro.
-Apply Ropp_Rlt.
-Rewrite Ropp_O; Rewrite Ropp_distr1; Apply gt0_plus_gt0_is_gt0.
-Apply H1.
-Apply Rgt_RO_Ropp; Apply r.
-Rewrite (Rabsolu_right h r) in H3.
-Apply Rlt_anti_compatibility with ``-x``; Rewrite Rplus_Or; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Apply H3.
-Apply H.
-Apply Rgt_RO_Ropp; Apply H.
-Qed.
-
-(* Rabsolu is derivable for all x <> 0 *)
-Lemma derivable_pt_Rabsolu : (x:R) ``x<>0`` -> (derivable_pt Rabsolu x).
-Intros.
-Case (total_order_T x R0); Intro.
-Elim s; Intro.
-Unfold derivable_pt; Apply Specif.existT with ``-1``.
-Apply (Rabsolu_derive_2 x a).
-Elim H; Exact b.
-Unfold derivable_pt; Apply Specif.existT with ``1``.
-Apply (Rabsolu_derive_1 x r).
-Qed.
-
-(* Rabsolu is continuous for all x *)
-Lemma continuity_Rabsolu : (continuity Rabsolu).
-Unfold continuity; Intro.
-Case (Req_EM x R0); Intro.
-Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Exists eps; Split.
-Apply H0.
-Intros; Rewrite H; Rewrite Rabsolu_R0; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_Rabsolu; Elim H1; Intros; Rewrite H in H3; Unfold Rminus in H3; Rewrite Ropp_O in H3; Rewrite Rplus_Or in H3; Apply H3.
-Apply derivable_continuous_pt; Apply (derivable_pt_Rabsolu x H).
-Qed.
-
-(* Finite sums : Sum a_k x^k *)
-Lemma continuity_finite_sum : (An:nat->R;N:nat) (continuity [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` N)).
-Intros; Unfold continuity; Intro.
-Induction N.
-Simpl.
-Apply continuity_pt_const.
-Unfold constant; Intros; Reflexivity.
-Replace [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` (S N)) with (plus_fct [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` N) [y:R]``(An (S N))*(pow y (S N))``).
-Apply continuity_pt_plus.
-Apply HrecN.
-Replace [y:R]``(An (S N))*(pow y (S N))`` with (mult_real_fct (An (S N)) [y:R](pow y (S N))).
-Apply continuity_pt_scal.
-Apply derivable_continuous_pt.
-Apply derivable_pt_pow.
-Reflexivity.
-Reflexivity.
-Qed.
-
-Lemma derivable_pt_lim_fs : (An:nat->R;x:R;N:nat) (lt O N) -> (derivable_pt_lim [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` N) x (sum_f_R0 [k:nat]``(INR (S k))*(An (S k))*(pow x k)`` (pred N))).
-Intros; Induction N.
-Elim (lt_n_n ? H).
-Cut N=O\/(lt O N).
-Intro; Elim H0; Intro.
-Rewrite H1.
-Simpl.
-Replace [y:R]``(An O)*1+(An (S O))*(y*1)`` with (plus_fct (fct_cte ``(An O)*1``) (mult_real_fct ``(An (S O))`` (mult_fct id (fct_cte R1)))).
-Replace ``1*(An (S O))*1`` with ``0+(An (S O))*(1*(fct_cte R1 x)+(id x)*0)``.
-Apply derivable_pt_lim_plus.
-Apply derivable_pt_lim_const.
-Apply derivable_pt_lim_scal.
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_const.
-Unfold fct_cte id; Ring.
-Reflexivity.
-Replace [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` (S N)) with (plus_fct [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` N) [y:R]``(An (S N))*(pow y (S N))``).
-Replace (sum_f_R0 [k:nat]``(INR (S k))*(An (S k))*(pow x k)`` (pred (S N))) with (Rplus (sum_f_R0 [k:nat]``(INR (S k))*(An (S k))*(pow x k)`` (pred N)) ``(An (S N))*((INR (S (pred (S N))))*(pow x (pred (S N))))``).
-Apply derivable_pt_lim_plus.
-Apply HrecN.
-Assumption.
-Replace [y:R]``(An (S N))*(pow y (S N))`` with (mult_real_fct (An (S N)) [y:R](pow y (S N))).
-Apply derivable_pt_lim_scal.
-Replace (pred (S N)) with N; [Idtac | Reflexivity].
-Pattern 3 N; Replace N with (pred (S N)).
-Apply derivable_pt_lim_pow.
-Reflexivity.
-Reflexivity.
-Cut (pred (S N)) = (S (pred N)).
-Intro; Rewrite H2.
-Rewrite tech5.
-Apply Rplus_plus_r.
-Rewrite <- H2.
-Replace (pred (S N)) with N; [Idtac | Reflexivity].
-Ring.
-Simpl.
-Apply S_pred with O; Assumption.
-Unfold plus_fct.
-Simpl; Reflexivity.
-Inversion H.
-Left; Reflexivity.
-Right; Apply lt_le_trans with (1); [Apply lt_O_Sn | Assumption].
-Qed.
-
-Lemma derivable_pt_lim_finite_sum : (An:(nat->R); x:R; N:nat) (derivable_pt_lim [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` N) x (Cases N of O => R0 | _ => (sum_f_R0 [k:nat]``(INR (S k))*(An (S k))*(pow x k)`` (pred N)) end)).
-Intros.
-Induction N.
-Simpl.
-Rewrite Rmult_1r.
-Replace [_:R]``(An O)`` with (fct_cte (An O)); [Apply derivable_pt_lim_const | Reflexivity].
-Apply derivable_pt_lim_fs; Apply lt_O_Sn.
-Qed.
-
-Lemma derivable_pt_finite_sum : (An:nat->R;N:nat;x:R) (derivable_pt [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` N) x).
-Intros.
-Unfold derivable_pt.
-Assert H := (derivable_pt_lim_finite_sum An x N).
-Induction N.
-Apply Specif.existT with R0; Apply H.
-Apply Specif.existT with (sum_f_R0 [k:nat]``(INR (S k))*(An (S k))*(pow x k)`` (pred (S N))); Apply H.
-Qed.
-
-Lemma derivable_finite_sum : (An:nat->R;N:nat) (derivable [y:R](sum_f_R0 [k:nat]``(An k)*(pow y k)`` N)).
-Intros; Unfold derivable; Intro; Apply derivable_pt_finite_sum.
-Qed.
-
-(* Regularity of hyperbolic functions *)
-Lemma derivable_pt_lim_cosh : (x:R) (derivable_pt_lim cosh x ``(sinh x)``).
-Intro.
-Unfold cosh sinh; Unfold Rdiv.
-Replace [x0:R]``((exp x0)+(exp ( -x0)))*/2`` with (mult_fct (plus_fct exp (comp exp (opp_fct id))) (fct_cte ``/2``)); [Idtac | Reflexivity].
-Replace ``((exp x)-(exp ( -x)))*/2`` with ``((exp x)+((exp (-x))*-1))*((fct_cte (Rinv 2)) x)+((plus_fct exp (comp exp (opp_fct id))) x)*0``. 
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_plus.
-Apply derivable_pt_lim_exp.
-Apply derivable_pt_lim_comp.
-Apply derivable_pt_lim_opp.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_exp.
-Apply derivable_pt_lim_const.
-Unfold plus_fct mult_real_fct comp opp_fct id fct_cte; Ring.
-Qed.
-
-Lemma derivable_pt_lim_sinh : (x:R) (derivable_pt_lim sinh x ``(cosh x)``).
-Intro.
-Unfold cosh sinh; Unfold Rdiv.
-Replace [x0:R]``((exp x0)-(exp ( -x0)))*/2`` with (mult_fct (minus_fct exp (comp exp (opp_fct id))) (fct_cte ``/2``)); [Idtac | Reflexivity].
-Replace ``((exp x)+(exp ( -x)))*/2`` with ``((exp x)-((exp (-x))*-1))*((fct_cte (Rinv 2)) x)+((minus_fct exp (comp exp (opp_fct id))) x)*0``. 
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_minus.
-Apply derivable_pt_lim_exp.
-Apply derivable_pt_lim_comp.
-Apply derivable_pt_lim_opp.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_exp.
-Apply derivable_pt_lim_const.
-Unfold plus_fct mult_real_fct comp opp_fct id fct_cte; Ring.
-Qed.
-
-Lemma derivable_pt_exp : (x:R) (derivable_pt exp x).
-Intro.
-Unfold derivable_pt.
-Apply Specif.existT with (exp x).
-Apply derivable_pt_lim_exp.
-Qed.
-
-Lemma derivable_pt_cosh : (x:R) (derivable_pt cosh x).
-Intro.
-Unfold derivable_pt.
-Apply Specif.existT with (sinh x).
-Apply derivable_pt_lim_cosh.
-Qed.
-
-Lemma derivable_pt_sinh : (x:R) (derivable_pt sinh x).
-Intro.
-Unfold derivable_pt.
-Apply Specif.existT with (cosh x).
-Apply derivable_pt_lim_sinh.
-Qed.
-
-Lemma derivable_exp : (derivable exp).
-Unfold derivable; Apply derivable_pt_exp.
-Qed.
-
-Lemma derivable_cosh : (derivable cosh).
-Unfold derivable; Apply derivable_pt_cosh.
-Qed.
-
-Lemma derivable_sinh : (derivable sinh).
-Unfold derivable; Apply derivable_pt_sinh.
-Qed.
-
-Lemma derive_pt_exp : (x:R) (derive_pt exp x (derivable_pt_exp x))==(exp x).
-Intro; Apply derive_pt_eq_0.
-Apply derivable_pt_lim_exp.
-Qed.
-
-Lemma derive_pt_cosh : (x:R) (derive_pt cosh x (derivable_pt_cosh x))==(sinh x).
-Intro; Apply derive_pt_eq_0.
-Apply derivable_pt_lim_cosh.
-Qed.
-
-Lemma derive_pt_sinh : (x:R) (derive_pt sinh x (derivable_pt_sinh x))==(cosh x).
-Intro; Apply derive_pt_eq_0.
-Apply derivable_pt_lim_sinh.
-Qed.
diff --git a/theories7/Reals/Raxioms.v b/theories7/Reals/Raxioms.v
deleted file mode 100644
index caf8524c..00000000
--- a/theories7/Reals/Raxioms.v
+++ /dev/null
@@ -1,172 +0,0 @@
-(************************************************************************)
-(*  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: Raxioms.v,v 1.2.2.1 2004/07/16 19:31:33 herbelin Exp $ i*)
-
-(*********************************************************)
-(**    Axiomatisation of the classical reals             *)
-(*********************************************************)
-
-Require Export ZArith_base.
-V7only [
-Require Export Rsyntax.
-Import R_scope.
-].
-Open Local Scope R_scope.
-
-V7only [
-(*********************************************************)
-(*   Compatibility                                       *)
-(*********************************************************)
-Notation sumboolT := Specif.sumbool.
-Notation leftT := Specif.left.
-Notation rightT := Specif.right.
-Notation sumorT := Specif.sumor.
-Notation inleftT := Specif.inleft.
-Notation inrightT := Specif.inright.
-Notation sigTT := Specif.sigT.
-Notation existTT := Specif.existT.
-Notation SigT := Specif.sigT.
-].
-
-(*********************************************************)
-(*               Field axioms                            *)
-(*********************************************************)
-
-(*********************************************************)
-(**      Addition                                        *)
-(*********************************************************)
-
-(**********)
-Axiom Rplus_sym:(r1,r2:R)``r1+r2==r2+r1``.
-Hints Resolve Rplus_sym : real.
-
-(**********)
-Axiom Rplus_assoc:(r1,r2,r3:R)``(r1+r2)+r3==r1+(r2+r3)``.
-Hints Resolve Rplus_assoc : real.
-
-(**********)
-Axiom Rplus_Ropp_r:(r:R)``r+(-r)==0``.
-Hints Resolve Rplus_Ropp_r : real v62.
-
-(**********)
-Axiom Rplus_Ol:(r:R)``0+r==r``.
-Hints Resolve Rplus_Ol : real.
-
-(***********************************************************)       
-(**       Multiplication                                   *)
-(***********************************************************)
-
-(**********)
-Axiom Rmult_sym:(r1,r2:R)``r1*r2==r2*r1``.
-Hints Resolve Rmult_sym : real v62. 
-
-(**********)
-Axiom Rmult_assoc:(r1,r2,r3:R)``(r1*r2)*r3==r1*(r2*r3)``.
-Hints Resolve Rmult_assoc : real v62.
-
-(**********)
-Axiom Rinv_l:(r:R)``r<>0``->``(/r)*r==1``.
-Hints Resolve Rinv_l : real.
-
-(**********)
-Axiom Rmult_1l:(r:R)``1*r==r``.
-Hints Resolve Rmult_1l : real.
-
-(**********)
-Axiom R1_neq_R0:``1<>0``.
-Hints Resolve R1_neq_R0 : real.
-
-(*********************************************************)
-(**      Distributivity                                  *)
-(*********************************************************)
-
-(**********)
-Axiom Rmult_Rplus_distr:(r1,r2,r3:R)``r1*(r2+r3)==(r1*r2)+(r1*r3)``.
-Hints Resolve Rmult_Rplus_distr : real v62.
-
-(*********************************************************)
-(**      Order axioms                                    *)
-(*********************************************************)
-(*********************************************************)
-(**      Total Order                                     *)
-(*********************************************************)
-
-(**********)
-Axiom total_order_T:(r1,r2:R)(sumorT (sumboolT ``r1<r2`` r1==r2) ``r1>r2``).
-
-(*********************************************************)
-(**      Lower                                           *)
-(*********************************************************)
-
-(**********)
-Axiom Rlt_antisym:(r1,r2:R)``r1<r2`` -> ~ ``r2<r1``.
-
-(**********)
-Axiom Rlt_trans:(r1,r2,r3:R)
-  ``r1<r2``->``r2<r3``->``r1<r3``.
-
-(**********)
-Axiom Rlt_compatibility:(r,r1,r2:R)``r1<r2``->``r+r1<r+r2``.
-
-(**********)
-Axiom Rlt_monotony:(r,r1,r2:R)``0<r``->``r1<r2``->``r*r1<r*r2``.
-
-Hints Resolve Rlt_antisym Rlt_compatibility Rlt_monotony : real.
-
-(**********************************************************) 
-(**      Injection from N to R                            *)
-(**********************************************************)
-
-(**********)
-Fixpoint INR [n:nat]:R:=(Cases n of
-                          O      => ``0``
-                         |(S O)  => ``1``
-                         |(S n)  => ``(INR n)+1``
-                        end).  
-Arguments Scope INR [nat_scope].
-
-
-(**********************************************************) 
-(**      Injection from [Z] to [R]                        *)
-(**********************************************************)
-
-(**********)
-Definition IZR:Z->R:=[z:Z](Cases z of
-                         ZERO      => ``0``
-                        |(POS n) => (INR (convert n))
-                        |(NEG n) => ``-(INR (convert n))``
-                           end).  
-Arguments Scope IZR [Z_scope].
-
-(**********************************************************)
-(**      [R] Archimedian                                  *)
-(**********************************************************)
-
-(**********)
-Axiom archimed:(r:R)``(IZR (up r)) > r``/\``(IZR (up r))-r <= 1``.
-
-(**********************************************************)
-(**      [R] Complete                                     *)
-(**********************************************************)
-
-(**********)
-Definition is_upper_bound:=[E:R->Prop][m:R](x:R)(E x)->``x <= m``.
-
-(**********)
-Definition bound:=[E:R->Prop](ExT [m:R](is_upper_bound E m)).
-
-(**********)
-Definition is_lub:=[E:R->Prop][m:R]
-    (is_upper_bound E m)/\(b:R)(is_upper_bound E b)->``m <= b``.
-
-(**********)
-Axiom complet:(E:R->Prop)(bound E)->
-              (ExT [x:R] (E x))->
-              (sigTT R [m:R](is_lub E m)).
-
diff --git a/theories7/Reals/Rbase.v b/theories7/Reals/Rbase.v
deleted file mode 100644
index 54226206..00000000
--- a/theories7/Reals/Rbase.v
+++ /dev/null
@@ -1,14 +0,0 @@
-(************************************************************************)
-(*  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: Rbase.v,v 1.1.2.1 2004/07/16 19:31:34 herbelin Exp $ i*)
-
-Require Export Rdefinitions.
-Require Export Raxioms.
-Require Export RIneq.
-Require Export DiscrR.
diff --git a/theories7/Reals/Rbasic_fun.v b/theories7/Reals/Rbasic_fun.v
deleted file mode 100644
index 3d143e34..00000000
--- a/theories7/Reals/Rbasic_fun.v
+++ /dev/null
@@ -1,476 +0,0 @@
-(************************************************************************)
-(*  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: Rbasic_fun.v,v 1.1.2.1 2004/07/16 19:31:34 herbelin Exp $ i*)
-
-(*********************************************************)
-(**          Complements for the real numbers            *)
-(*                                                       *)
-(*********************************************************)
-
-Require Rbase.
-Require R_Ifp.
-Require Fourier.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Implicit Variable Type r:R.
-
-(*******************************)
-(**          Rmin              *)
-(*******************************)
-
-(*********)
-Definition Rmin :R->R->R:=[x,y:R]
-  Cases (total_order_Rle x y) of 
-    (leftT _)  => x
-  | (rightT _) => y
-  end.
-
-(*********)
-Lemma Rmin_Rgt_l:(r1,r2,r:R)(Rgt (Rmin r1 r2) r) ->
-    ((Rgt r1 r)/\(Rgt r2 r)).
-Intros r1 r2 r;Unfold Rmin;Case (total_order_Rle r1 r2);Intros.
-Split.
-Assumption.
-Unfold Rgt;Unfold Rgt in H;Exact (Rlt_le_trans r r1 r2 H r0).
-Split.
-Generalize (not_Rle r1 r2 n);Intro;Exact (Rgt_trans r1 r2 r H0 H).
-Assumption.
-Qed.
-
-(*********)
-Lemma Rmin_Rgt_r:(r1,r2,r:R)(((Rgt r1 r)/\(Rgt r2 r)) -> 
-         (Rgt (Rmin r1 r2) r)).
-Intros;Unfold Rmin;Case (total_order_Rle r1 r2);Elim H;Clear H;Intros;
- Assumption.
-Qed.
-
-(*********)
-Lemma Rmin_Rgt:(r1,r2,r:R)(Rgt (Rmin r1 r2) r)<->
-    ((Rgt r1 r)/\(Rgt r2 r)).
-Intros; Split.
-Exact (Rmin_Rgt_l r1 r2 r).
-Exact (Rmin_Rgt_r r1 r2 r).
-Qed.
-
-(*********)
-Lemma Rmin_l : (x,y:R) ``(Rmin x y)<=x``.
-Intros; Unfold Rmin; Case (total_order_Rle x y); Intro H1; [Right; Reflexivity | Auto with real].
-Qed.
- 
-(*********)
-Lemma Rmin_r : (x,y:R) ``(Rmin x y)<=y``.
-Intros; Unfold Rmin; Case (total_order_Rle x y); Intro H1; [Assumption | Auto with real].
-Qed.
-
-(*********)
-Lemma Rmin_sym : (a,b:R) (Rmin a b)==(Rmin b a).
-Intros; Unfold Rmin; Case (total_order_Rle a b); Case (total_order_Rle b a); Intros; Try Reflexivity Orelse (Apply Rle_antisym; Assumption Orelse Auto with real).
-Qed.
-
-(*********)
-Lemma Rmin_stable_in_posreal : (x,y:posreal) ``0<(Rmin x y)``.
-Intros; Apply Rmin_Rgt_r; Split; [Apply (cond_pos x) | Apply (cond_pos y)].
-Qed.
-
-(*******************************)
-(**          Rmax              *)
-(*******************************)
-
-(*********)
-Definition Rmax :R->R->R:=[x,y:R]
-  Cases (total_order_Rle x y) of 
-    (leftT _)  => y
-  | (rightT _) => x
-  end.
-
-(*********)
-Lemma Rmax_Rle:(r1,r2,r:R)(Rle r (Rmax r1 r2))<->
-    ((Rle r r1)\/(Rle r r2)).
-Intros;Split.
-Unfold Rmax;Case (total_order_Rle r1 r2);Intros;Auto.
-Intro;Unfold Rmax;Case (total_order_Rle r1 r2);Elim H;Clear H;Intros;Auto.
-Apply (Rle_trans r r1 r2);Auto.
-Generalize (not_Rle r1 r2 n);Clear n;Intro;Unfold Rgt in H0;
- Apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
-Qed.
-
-Lemma RmaxLess1: (r1, r2 : R)  (Rle r1 (Rmax r1 r2)).
-Intros r1 r2; Unfold Rmax; Case (total_order_Rle r1 r2); Auto with real.
-Qed.
- 
-Lemma RmaxLess2: (r1, r2 : R)  (Rle r2 (Rmax r1 r2)).
-Intros r1 r2; Unfold Rmax; Case (total_order_Rle r1 r2); Auto with real.
-Qed.
- 
-Lemma RmaxSym: (p, q : R)  (Rmax p q) == (Rmax q p).
-Intros p q; Unfold Rmax;
- Case (total_order_Rle p q); Case (total_order_Rle q p); Auto; Intros H1 H2;
- Apply Rle_antisym; Auto with real.
-Qed.
-
-Lemma RmaxRmult:
- (p, q, r : R)
- (Rle R0 r) ->  (Rmax (Rmult r p) (Rmult r q)) == (Rmult r (Rmax p q)).
-Intros p q r H; Unfold Rmax.
-Case (total_order_Rle p q); Case (total_order_Rle (Rmult r p) (Rmult r q));
- Auto; Intros H1 H2; Auto.
-Case H; Intros E1.
-Case H1; Auto with real.
-Rewrite <- E1; Repeat Rewrite Rmult_Ol; Auto.
-Case H; Intros E1.
-Case H2; Auto with real.
-Apply Rle_monotony_contra with z := r; Auto.
-Rewrite <- E1; Repeat Rewrite Rmult_Ol; Auto.
-Qed.
-
-Lemma Rmax_stable_in_negreal : (x,y:negreal) ``(Rmax x y)<0``.
-Intros; Unfold Rmax; Case (total_order_Rle x y); Intro; [Apply (cond_neg y) | Apply (cond_neg x)].
-Qed.
-
-(*******************************)
-(**          Rabsolu           *)
-(*******************************)
-
-(*********)
-Lemma case_Rabsolu:(r:R)(sumboolT (Rlt r R0) (Rge r R0)). 
-Intro;Generalize (total_order_Rle R0 r);Intro X;Elim X;Intro;Clear X.
-Right;Apply (Rle_sym1 R0 r a).
-Left;Fold (Rgt R0 r);Apply (not_Rle R0 r b).
-Qed.
-
-(*********)
-Definition Rabsolu:R->R:=
-      [r:R](Cases (case_Rabsolu r) of
-              (leftT  _) => (Ropp r)
-             |(rightT _) => r
-            end).
-
-(*********)
-Lemma Rabsolu_R0:(Rabsolu R0)==R0.
-Unfold Rabsolu;Case (case_Rabsolu R0);Auto;Intro.
-Generalize (Rlt_antirefl R0);Intro;ElimType False;Auto.
-Qed.
-
-Lemma Rabsolu_R1: (Rabsolu R1)==R1.
-Unfold Rabsolu; Case (case_Rabsolu R1); Auto with real.
-Intros H; Absurd ``1 < 0``;Auto with real.
-Qed.
-
-(*********)
-Lemma Rabsolu_no_R0:(r:R)~r==R0->~(Rabsolu r)==R0.
-Intros;Unfold Rabsolu;Case (case_Rabsolu r);Intro;Auto.
-Apply Ropp_neq;Auto.
-Qed.
-
-(*********)
-Lemma Rabsolu_left: (r:R)(Rlt r R0)->((Rabsolu r) == (Ropp r)).
-Intros;Unfold Rabsolu;Case (case_Rabsolu r);Trivial;Intro;Absurd (Rge r R0).
-Exact (Rlt_ge_not r R0 H).
-Assumption.
-Qed.
-
-(*********)
-Lemma Rabsolu_right: (r:R)(Rge r R0)->((Rabsolu r) == r).
-Intros;Unfold Rabsolu;Case (case_Rabsolu r);Intro.
-Absurd (Rge r R0).
-Exact (Rlt_ge_not r R0 r0).
-Assumption.
-Trivial.
-Qed.
-
-Lemma Rabsolu_left1: (a : R) (Rle a R0) ->  (Rabsolu a) == (Ropp a).
-Intros a H; Case H; Intros H1.
-Apply Rabsolu_left; Auto.
-Rewrite H1; Simpl; Rewrite Rabsolu_right; Auto with real.
-Qed.
-
-(*********)
-Lemma Rabsolu_pos:(x:R)(Rle R0 (Rabsolu x)).
-Intros;Unfold Rabsolu;Case (case_Rabsolu x);Intro.
-Generalize (Rlt_Ropp x R0 r);Intro;Unfold Rgt in H;
- Rewrite Ropp_O in H;Unfold Rle;Left;Assumption.
-Apply Rle_sym2;Assumption.
-Qed.
-
-Lemma Rle_Rabsolu:
- (x:R) (Rle x (Rabsolu x)).
-Intro; Unfold Rabsolu;Case (case_Rabsolu x);Intros;Fourier.
-Qed.
-
-(*********)
-Lemma Rabsolu_pos_eq:(x:R)(Rle R0 x)->(Rabsolu x)==x.
-Intros;Unfold Rabsolu;Case (case_Rabsolu x);Intro;
- [Generalize (Rle_not R0 x r);Intro;ElimType False;Auto|Trivial].
-Qed.
-
-(*********)
-Lemma Rabsolu_Rabsolu:(x:R)(Rabsolu (Rabsolu x))==(Rabsolu x).
-Intro;Apply (Rabsolu_pos_eq (Rabsolu x) (Rabsolu_pos x)).
-Qed.
-
-(*********)
-Lemma Rabsolu_pos_lt:(x:R)(~x==R0)->(Rlt R0 (Rabsolu x)).
-Intros;Generalize (Rabsolu_pos x);Intro;Unfold Rle in H0;
- Elim H0;Intro;Auto.
-ElimType False;Clear H0;Elim H;Clear H;Generalize H1;
- Unfold Rabsolu;Case (case_Rabsolu x);Intros;Auto.
-Clear r H1; Generalize (Rplus_plus_r x R0 (Ropp x) H0);
- Rewrite (let (H1,H2)=(Rplus_ne x) in H1);Rewrite (Rplus_Ropp_r x);Trivial.
-Qed.
-
-(*********)
-Lemma Rabsolu_minus_sym:(x,y:R)
- (Rabsolu (Rminus x y))==(Rabsolu (Rminus y x)).
-Intros;Unfold Rabsolu;Case (case_Rabsolu (Rminus x y)); 
- Case (case_Rabsolu (Rminus y x));Intros.
- Generalize (Rminus_lt y x r);Generalize (Rminus_lt x y r0);Intros;
- Generalize (Rlt_antisym x y H);Intro;ElimType False;Auto.
-Rewrite (Ropp_distr2 x y);Trivial.
-Rewrite (Ropp_distr2 y x);Trivial.
-Unfold Rge in r r0;Elim r;Elim r0;Intros;Clear r r0.
-Generalize (Rgt_RoppO (Rminus x y) H);Rewrite (Ropp_distr2 x y);
- Intro;Unfold Rgt in H0;Generalize (Rlt_antisym R0 (Rminus y x) H0);
- Intro;ElimType False;Auto.
-Rewrite (Rminus_eq x y H);Trivial.
-Rewrite (Rminus_eq y x H0);Trivial.
-Rewrite (Rminus_eq y x H0);Trivial.
-Qed.
-
-(*********)
-Lemma Rabsolu_mult:(x,y:R)
- (Rabsolu (Rmult x y))==(Rmult (Rabsolu x) (Rabsolu y)).
-Intros;Unfold Rabsolu;Case (case_Rabsolu (Rmult x y));
- Case (case_Rabsolu x);Case (case_Rabsolu y);Intros;Auto.
-Generalize (Rlt_anti_monotony y x R0 r r0);Intro;
- Rewrite (Rmult_Or y) in H;Generalize (Rlt_antisym (Rmult x y) R0 r1);
- Intro;Unfold Rgt in H;ElimType False;Rewrite (Rmult_sym y x) in H;
- Auto.
-Rewrite (Ropp_mul1 x y);Trivial. 
-Rewrite (Rmult_sym x (Ropp y));Rewrite (Ropp_mul1 y x);
- Rewrite (Rmult_sym  x y);Trivial.
-Unfold Rge in r r0;Elim r;Elim r0;Clear r r0;Intros;Unfold Rgt in H H0.
-Generalize (Rlt_monotony x R0 y H H0);Intro;Rewrite (Rmult_Or x) in H1;
- Generalize (Rlt_antisym (Rmult x y) R0 r1);Intro;ElimType False;Auto.
-Rewrite H in r1;Rewrite (Rmult_Ol y) in r1;Generalize (Rlt_antirefl R0);
- Intro;ElimType False;Auto.
-Rewrite H0 in r1;Rewrite (Rmult_Or x) in r1;Generalize (Rlt_antirefl R0);
- Intro;ElimType False;Auto.
-Rewrite H0 in r1;Rewrite (Rmult_Or x) in r1;Generalize (Rlt_antirefl R0);
- Intro;ElimType False;Auto.
-Rewrite (Ropp_mul2 x y);Trivial.
-Unfold Rge in r r1;Elim r;Elim r1;Clear r r1;Intros;Unfold Rgt in H0 H.
-Generalize (Rlt_monotony y x R0 H0 r0);Intro;Rewrite (Rmult_Or y) in H1;
- Rewrite (Rmult_sym y x) in H1; 
- Generalize (Rlt_antisym (Rmult x y) R0 H1);Intro;ElimType False;Auto.
-Generalize (imp_not_Req x R0 (or_introl (Rlt x R0) (Rgt x R0) r0));
- Generalize (imp_not_Req y R0 (or_intror (Rlt y R0) (Rgt y R0) H0));Intros;
- Generalize (without_div_Od x y H);Intro;Elim H3;Intro;ElimType False;
- Auto.  
-Rewrite H0 in H;Rewrite (Rmult_Or x) in H;Unfold Rgt in H;
- Generalize (Rlt_antirefl R0);Intro;ElimType False;Auto.
-Rewrite H0;Rewrite (Rmult_Or x);Rewrite (Rmult_Or (Ropp x));Trivial.
-Unfold Rge in r0 r1;Elim r0;Elim r1;Clear r0 r1;Intros;Unfold Rgt in H0 H.
-Generalize (Rlt_monotony x y R0 H0 r);Intro;Rewrite (Rmult_Or x) in H1;
- Generalize (Rlt_antisym (Rmult x y) R0 H1);Intro;ElimType False;Auto.
-Generalize (imp_not_Req y R0 (or_introl (Rlt y R0) (Rgt y R0) r));
- Generalize (imp_not_Req R0 x (or_introl (Rlt R0 x) (Rgt R0 x) H0));Intros;
- Generalize (without_div_Od x y H);Intro;Elim H3;Intro;ElimType False;
- Auto.  
-Rewrite H0 in H;Rewrite (Rmult_Ol y) in H;Unfold Rgt in H;
- Generalize (Rlt_antirefl R0);Intro;ElimType False;Auto.
-Rewrite H0;Rewrite (Rmult_Ol y);Rewrite (Rmult_Ol (Ropp y));Trivial.
-Qed.
-
-(*********)
-Lemma Rabsolu_Rinv:(r:R)(~r==R0)->(Rabsolu (Rinv r))==
-                                  (Rinv (Rabsolu r)).
-Intro;Unfold Rabsolu;Case (case_Rabsolu r);
- Case (case_Rabsolu (Rinv r));Auto;Intros.
-Apply Ropp_Rinv;Auto.
-Generalize (Rlt_Rinv2 r r1);Intro;Unfold Rge in r0;Elim r0;Intros.
-Unfold Rgt in H1;Generalize (Rlt_antisym R0 (Rinv r) H1);Intro; 
- ElimType False;Auto.
-Generalize 
-  (imp_not_Req (Rinv r) R0 
-   (or_introl (Rlt (Rinv r) R0) (Rgt (Rinv r) R0) H0));Intro;
- ElimType False;Auto.
-Unfold Rge in r1;Elim r1;Clear r1;Intro.
-Unfold Rgt in H0;Generalize (Rlt_antisym R0 (Rinv r)  
-     (Rlt_Rinv r H0));Intro;ElimType False;Auto.
-ElimType False;Auto.
-Qed. 
-
-Lemma Rabsolu_Ropp:
-  (x:R) (Rabsolu (Ropp x))==(Rabsolu x).
-Intro;Cut (Ropp x)==(Rmult (Ropp R1) x).
-Intros; Rewrite H.
-Rewrite Rabsolu_mult.
-Cut (Rabsolu (Ropp R1))==R1.
-Intros; Rewrite H0.
-Ring.
-Unfold Rabsolu; Case (case_Rabsolu (Ropp R1)).
-Intro; Ring.
-Intro H0;Generalize (Rle_sym2 R0 (Ropp R1) H0);Intros.
-Generalize (Rle_Ropp R0 (Ropp R1) H1).
-Rewrite Ropp_Ropp; Rewrite Ropp_O.
-Intro;Generalize (Rle_not R1 R0 Rlt_R0_R1);Intro;
- Generalize (Rle_sym2 R1 R0 H2);Intro;
- ElimType False;Auto.  
-Ring.
-Qed.
-
-(*********)
-Lemma Rabsolu_triang:(a,b:R)(Rle (Rabsolu (Rplus a b)) 
-                                (Rplus (Rabsolu a) (Rabsolu b))).
-Intros a b;Unfold Rabsolu;Case (case_Rabsolu (Rplus a b));
- Case (case_Rabsolu a);Case (case_Rabsolu b);Intros.
-Apply (eq_Rle (Ropp (Rplus a b)) (Rplus (Ropp a) (Ropp b)));
- Rewrite (Ropp_distr1 a b);Reflexivity.
-(**)
-Rewrite (Ropp_distr1 a b);
- Apply (Rle_compatibility (Ropp a) (Ropp b) b);
- Unfold Rle;Unfold Rge in r;Elim r;Intro.
-Left;Unfold Rgt in H;Generalize (Rlt_compatibility (Ropp b) R0 b H);
- Intro;Elim (Rplus_ne (Ropp b));Intros v w;Rewrite v in H0;Clear v w;
- Rewrite (Rplus_Ropp_l b) in H0;Apply (Rlt_trans (Ropp b) R0 b H0 H).
-Right;Rewrite H;Apply Ropp_O.
-(**)
-Rewrite (Ropp_distr1 a b);
- Rewrite (Rplus_sym (Ropp a) (Ropp b));
- Rewrite (Rplus_sym a (Ropp b));
- Apply (Rle_compatibility (Ropp b) (Ropp a) a);
- Unfold Rle;Unfold Rge in r0;Elim r0;Intro.
-Left;Unfold Rgt in H;Generalize (Rlt_compatibility (Ropp a) R0 a H);
- Intro;Elim (Rplus_ne (Ropp a));Intros v w;Rewrite v in H0;Clear v w;
- Rewrite (Rplus_Ropp_l a) in H0;Apply (Rlt_trans (Ropp a) R0 a H0 H).
-Right;Rewrite H;Apply Ropp_O.
-(**)
-ElimType False;Generalize (Rge_plus_plus_r a b R0 r);Intro;
- Elim (Rplus_ne a);Intros v w;Rewrite v in H;Clear v w; 
- Generalize (Rge_trans (Rplus a b) a R0 H r0);Intro;Clear H;
- Unfold Rge in H0;Elim H0;Intro;Clear H0.
-Unfold Rgt in H;Generalize (Rlt_antisym (Rplus a b) R0 r1);Intro;Auto.
-Absurd (Rplus a b)==R0;Auto.
-Apply (imp_not_Req (Rplus a b) R0);Left;Assumption.
-(**)
-ElimType False;Generalize (Rlt_compatibility a b R0 r);Intro;
- Elim (Rplus_ne a);Intros v w;Rewrite v in H;Clear v w;
- Generalize (Rlt_trans (Rplus a b) a R0 H r0);Intro;Clear H;
- Unfold Rge in r1;Elim r1;Clear r1;Intro.
-Unfold Rgt in H;
- Generalize (Rlt_trans (Rplus a b) R0 (Rplus a b) H0 H);Intro;
- Apply (Rlt_antirefl (Rplus a b));Assumption.
-Rewrite H in H0;Apply (Rlt_antirefl R0);Assumption.
-(**)
-Rewrite (Rplus_sym a b);Rewrite (Rplus_sym (Ropp a) b);
- Apply (Rle_compatibility b a (Ropp a));
- Apply (Rminus_le a (Ropp a));Unfold Rminus;Rewrite (Ropp_Ropp a);
- Generalize (Rlt_compatibility a a R0 r0);Clear r r1;Intro;
- Elim (Rplus_ne a);Intros v w;Rewrite v in H;Clear v w;
- Generalize (Rlt_trans (Rplus a a) a R0 H r0);Intro;
- Apply (Rlt_le (Rplus a a) R0 H0).
-(**)
-Apply (Rle_compatibility a b (Ropp b));
- Apply (Rminus_le b (Ropp b));Unfold Rminus;Rewrite (Ropp_Ropp b);
- Generalize (Rlt_compatibility b b R0 r);Clear r0 r1;Intro;
- Elim (Rplus_ne b);Intros v w;Rewrite v in H;Clear v w;
- Generalize (Rlt_trans (Rplus b b) b R0 H r);Intro;
- Apply (Rlt_le (Rplus b b) R0 H0).
-(**)
-Unfold Rle;Right;Reflexivity.
-Qed.
-
-(*********)
-Lemma Rabsolu_triang_inv:(a,b:R)(Rle (Rminus (Rabsolu a) (Rabsolu b))
-                                     (Rabsolu (Rminus a b))).
-Intros;
- Apply (Rle_anti_compatibility (Rabsolu b)
-        (Rminus (Rabsolu a) (Rabsolu b)) (Rabsolu (Rminus a b)));
- Unfold Rminus;
- Rewrite <- (Rplus_assoc (Rabsolu b) (Rabsolu a) (Ropp (Rabsolu b)));
- Rewrite (Rplus_sym (Rabsolu b) (Rabsolu a));
- Rewrite (Rplus_assoc (Rabsolu a) (Rabsolu b) (Ropp (Rabsolu b)));
- Rewrite (Rplus_Ropp_r (Rabsolu b));
- Rewrite (proj1 ? ? (Rplus_ne (Rabsolu a)));
- Replace (Rabsolu a) with (Rabsolu (Rplus a R0)).
- Rewrite <- (Rplus_Ropp_r b);
- Rewrite <- (Rplus_assoc a b (Ropp b)); 
- Rewrite (Rplus_sym a b);
- Rewrite (Rplus_assoc b a (Ropp b)).
- Exact (Rabsolu_triang b (Rplus a (Ropp b))).
- Rewrite (proj1 ? ? (Rplus_ne a));Trivial.
-Qed.
-
-(* ||a|-|b||<=|a-b| *)
-Lemma Rabsolu_triang_inv2 : (a,b:R) ``(Rabsolu ((Rabsolu a)-(Rabsolu b)))<=(Rabsolu (a-b))``. 
-Cut (a,b:R) ``(Rabsolu b)<=(Rabsolu a)``->``(Rabsolu ((Rabsolu a)-(Rabsolu b))) <= (Rabsolu (a-b))``. 
-Intros; NewDestruct (total_order (Rabsolu a) (Rabsolu b)) as [Hlt|[Heq|Hgt]].
-Rewrite <- (Rabsolu_Ropp ``(Rabsolu a)-(Rabsolu b)``); Rewrite <- (Rabsolu_Ropp ``a-b``); Do 2 Rewrite Ropp_distr2. 
-Apply H; Left; Assumption. 
-Rewrite Heq; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply Rabsolu_pos. 
-Apply H; Left; Assumption. 
-Intros; Replace ``(Rabsolu ((Rabsolu a)-(Rabsolu b)))`` with ``(Rabsolu a)-(Rabsolu b)``. 
-Apply Rabsolu_triang_inv. 
-Rewrite (Rabsolu_right ``(Rabsolu a)-(Rabsolu b)``); [Reflexivity | Apply Rle_sym1; Apply Rle_anti_compatibility with (Rabsolu b); Rewrite Rplus_Or; Replace ``(Rabsolu b)+((Rabsolu a)-(Rabsolu b))`` with (Rabsolu a); [Assumption | Ring]]. 
-Qed. 
-
-(*********)
-Lemma Rabsolu_def1:(x,a:R)(Rlt x a)->(Rlt (Ropp a) x)->(Rlt (Rabsolu x) a).
-Unfold Rabsolu;Intros;Case (case_Rabsolu x);Intro.
-Generalize (Rlt_Ropp (Ropp a) x H0);Unfold Rgt;Rewrite Ropp_Ropp;Intro;
- Assumption.
-Assumption.
-Qed.
-
-(*********)
-Lemma Rabsolu_def2:(x,a:R)(Rlt (Rabsolu x) a)->(Rlt x a)/\(Rlt (Ropp a) x).
-Unfold Rabsolu;Intro x;Case (case_Rabsolu x);Intros.
-Generalize (Rlt_RoppO x r);Unfold Rgt;Intro;
- Generalize (Rlt_trans R0 (Ropp x) a H0 H);Intro;Split. 
-Apply (Rlt_trans x R0 a r H1).
-Generalize (Rlt_Ropp (Ropp x) a H);Rewrite (Ropp_Ropp x);Unfold Rgt;Trivial.
-Fold (Rgt a x) in H;Generalize (Rgt_ge_trans a x R0 H r);Intro;
- Generalize (Rgt_RoppO a H0);Intro;Fold (Rgt R0 (Ropp a));
- Generalize (Rge_gt_trans x R0 (Ropp a) r H1);Unfold Rgt;Intro;Split;
- Assumption.
-Qed.
-
-Lemma RmaxAbs:
- (p, q, r : R)
- (Rle p q) -> (Rle q r) ->  (Rle (Rabsolu q) (Rmax (Rabsolu p) (Rabsolu r))).
-Intros p q r H' H'0; Case (Rle_or_lt R0 p); Intros H'1.
-Repeat Rewrite Rabsolu_right; Auto with real.
-Apply Rle_trans with r; Auto with real.
-Apply RmaxLess2; Auto.
-Apply Rge_trans with p; Auto with real; Apply Rge_trans with q; Auto with real.
-Apply Rge_trans with p; Auto with real.
-Rewrite (Rabsolu_left p); Auto.
-Case (Rle_or_lt R0 q); Intros H'2.
-Repeat Rewrite Rabsolu_right; Auto with real.
-Apply Rle_trans with r; Auto.
-Apply RmaxLess2; Auto.
-Apply Rge_trans with q; Auto with real.
-Rewrite (Rabsolu_left q); Auto.
-Case (Rle_or_lt R0 r); Intros H'3.
-Repeat Rewrite Rabsolu_right; Auto with real.
-Apply Rle_trans with (Ropp p); Auto with real.
-Apply RmaxLess1; Auto.
-Rewrite (Rabsolu_left r); Auto.
-Apply Rle_trans with (Ropp p); Auto with real.
-Apply RmaxLess1; Auto.
-Qed.
-
-Lemma Rabsolu_Zabs: (z : Z)  (Rabsolu (IZR z)) == (IZR (Zabs z)).
-Intros z; Case z; Simpl; Auto with real.
-Apply Rabsolu_right; Auto with real.
-Intros p0; Apply Rabsolu_right; Auto with real zarith.
-Intros p0; Rewrite Rabsolu_Ropp.
-Apply Rabsolu_right; Auto with real zarith.
-Qed.
- 
diff --git a/theories7/Reals/Rcomplete.v b/theories7/Reals/Rcomplete.v
deleted file mode 100644
index 5985a382..00000000
--- a/theories7/Reals/Rcomplete.v
+++ /dev/null
@@ -1,175 +0,0 @@
-(************************************************************************)
-(*  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: Rcomplete.v,v 1.1.2.1 2004/07/16 19:31:34 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rseries.
-Require SeqProp.
-Require Max.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(****************************************************)
-(*              R is complete :                     *)
-(*        Each sequence which satisfies             *)
-(*       the Cauchy's criterion converges           *)
-(*                                                  *)
-(*    Proof with adjacent sequences (Vn and Wn)     *)
-(****************************************************)
-
-Theorem R_complete : (Un:nat->R) (Cauchy_crit Un) -> (sigTT R [l:R](Un_cv Un l)).
-Intros.
-Pose Vn := (sequence_minorant Un (cauchy_min Un H)).
-Pose Wn := (sequence_majorant Un (cauchy_maj Un H)).
-Assert H0 := (maj_cv Un H).
-Fold Wn in H0.
-Assert H1 := (min_cv Un H).
-Fold Vn in H1.
-Elim H0; Intros.
-Elim H1; Intros.
-Cut x==x0.
-Intros.
-Apply existTT with x.
-Rewrite <- H2 in p0.
-Unfold Un_cv.
-Intros.
-Unfold Un_cv in p; Unfold Un_cv in p0.
-Cut ``0<eps/3``.
-Intro.
-Elim (p ``eps/3`` H4); Intros.
-Elim (p0 ``eps/3`` H4); Intros.
-Exists (max x1 x2).
-Intros.
-Unfold R_dist.
-Apply Rle_lt_trans with ``(Rabsolu ((Un n)-(Vn n)))+(Rabsolu ((Vn n)-x))``.
-Replace ``(Un n)-x`` with ``((Un n)-(Vn n))+((Vn n)-x)``; [Apply Rabsolu_triang | Ring].
-Apply Rle_lt_trans with ``(Rabsolu ((Wn n)-(Vn n)))+(Rabsolu ((Vn n)-x))``.
-Do 2 Rewrite <- (Rplus_sym ``(Rabsolu ((Vn n)-x))``).
-Apply Rle_compatibility.
-Repeat Rewrite Rabsolu_right.
-Unfold Rminus; Do 2 Rewrite <- (Rplus_sym ``-(Vn n)``); Apply Rle_compatibility.
-Assert H8 := (Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
-Fold Vn Wn in H8.
-Elim (H8 n); Intros.
-Assumption.
-Apply Rle_sym1.
-Unfold Rminus; Apply Rle_anti_compatibility with (Vn n).
-Rewrite Rplus_Or.
-Replace ``(Vn n)+((Wn n)+ -(Vn n))`` with (Wn n); [Idtac | Ring].
-Assert H8 := (Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
-Fold Vn Wn in H8.
-Elim (H8 n); Intros.
-Apply Rle_trans with (Un n); Assumption.
-Apply Rle_sym1.
-Unfold Rminus; Apply Rle_anti_compatibility with (Vn n).
-Rewrite Rplus_Or.
-Replace ``(Vn n)+((Un n)+ -(Vn n))`` with (Un n); [Idtac | Ring].
-Assert H8 := (Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
-Fold Vn Wn in H8.
-Elim (H8 n); Intros.
-Assumption.
-Apply Rle_lt_trans with ``(Rabsolu ((Wn n)-x))+(Rabsolu (x-(Vn n)))+(Rabsolu ((Vn n)-x))``.
-Do 2 Rewrite <- (Rplus_sym ``(Rabsolu ((Vn n)-x))``).
-Apply Rle_compatibility.
-Replace ``(Wn n)-(Vn n)`` with ``((Wn n)-x)+(x-(Vn n))``; [Apply Rabsolu_triang | Ring].
-Apply Rlt_le_trans with ``eps/3+eps/3+eps/3``.
-Repeat Apply Rplus_lt.
-Unfold R_dist in H5.
-Apply H5.
-Unfold ge; Apply le_trans with (max x1 x2).
-Apply le_max_l.
-Assumption.
-Rewrite <- Rabsolu_Ropp.
-Replace ``-(x-(Vn n))`` with ``(Vn n)-x``; [Idtac | Ring].
-Unfold R_dist in H6.
-Apply H6.
-Unfold ge; Apply le_trans with (max x1 x2).
-Apply le_max_r.
-Assumption.
-Unfold R_dist in H6.
-Apply H6.
-Unfold ge; Apply le_trans with (max x1 x2).
-Apply le_max_r.
-Assumption.
-Right.
-Pattern 4 eps; Replace ``eps`` with ``3*eps/3``.
-Ring.
-Unfold Rdiv; Rewrite <- Rmult_assoc; Apply Rinv_r_simpl_m; DiscrR.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Apply cond_eq.
-Intros.
-Cut ``0<eps/5``.
-Intro.
-Unfold Un_cv in p; Unfold Un_cv in p0.
-Unfold R_dist in p; Unfold R_dist in p0.
-Elim (p ``eps/5`` H3); Intros N1 H4.
-Elim (p0 ``eps/5`` H3); Intros N2 H5.
-Unfold Cauchy_crit in H.
-Unfold R_dist in H.
-Elim (H ``eps/5`` H3); Intros N3 H6.
-Pose N := (max (max N1 N2) N3).
-Apply Rle_lt_trans with ``(Rabsolu (x-(Wn N)))+(Rabsolu ((Wn N)-x0))``.
-Replace ``x-x0`` with ``(x-(Wn N))+((Wn N)-x0)``; [Apply Rabsolu_triang | Ring].
-Apply Rle_lt_trans with ``(Rabsolu (x-(Wn N)))+(Rabsolu ((Wn N)-(Vn N)))+(Rabsolu (((Vn N)-x0)))``.
-Rewrite Rplus_assoc.
-Apply Rle_compatibility.
-Replace ``(Wn N)-x0`` with ``((Wn N)-(Vn N))+((Vn N)-x0)``; [Apply Rabsolu_triang | Ring].
-Replace ``eps`` with ``eps/5+3*eps/5+eps/5``.
-Repeat Apply Rplus_lt.
-Rewrite <- Rabsolu_Ropp.
-Replace ``-(x-(Wn N))`` with ``(Wn N)-x``; [Apply H4 | Ring].
-Unfold ge N.
-Apply le_trans with (max N1 N2); Apply le_max_l.
-Unfold Wn Vn.
-Unfold sequence_majorant sequence_minorant.
-Assert H7 := (approx_maj [k:nat](Un (plus N k)) (maj_ss Un N (cauchy_maj Un H))).
-Assert H8 := (approx_min [k:nat](Un (plus N k)) (min_ss Un N (cauchy_min Un H))).
-Cut (Wn N)==(majorant ([k:nat](Un (plus N k))) (maj_ss Un N (cauchy_maj Un H))).
-Cut (Vn N)==(minorant ([k:nat](Un (plus N k))) (min_ss Un N (cauchy_min Un H))).
-Intros.
-Rewrite <- H9; Rewrite <- H10.
-Rewrite <- H9 in H8.
-Rewrite <- H10 in H7.
-Elim (H7 ``eps/5`` H3); Intros k2 H11.
-Elim (H8 ``eps/5`` H3); Intros k1 H12.
-Apply Rle_lt_trans with ``(Rabsolu ((Wn N)-(Un (plus N k2))))+(Rabsolu ((Un (plus N k2))-(Vn N)))``.
-Replace ``(Wn N)-(Vn N)`` with ``((Wn N)-(Un (plus N k2)))+((Un (plus N k2))-(Vn N))``; [Apply Rabsolu_triang | Ring].
-Apply Rle_lt_trans with ``(Rabsolu ((Wn N)-(Un (plus N k2))))+(Rabsolu ((Un (plus N k2))-(Un (plus N k1))))+(Rabsolu ((Un (plus N k1))-(Vn N)))``.
-Rewrite Rplus_assoc.
-Apply Rle_compatibility.
-Replace ``(Un (plus N k2))-(Vn N)`` with ``((Un (plus N k2))-(Un (plus N k1)))+((Un (plus N k1))-(Vn N))``; [Apply Rabsolu_triang | Ring].
-Replace ``3*eps/5`` with ``eps/5+eps/5+eps/5``; [Repeat Apply Rplus_lt | Ring].
-Assumption.
-Apply H6.
-Unfold ge.
-Apply le_trans with N.
-Unfold N; Apply le_max_r.
-Apply le_plus_l.
-Unfold ge.
-Apply le_trans with N.
-Unfold N; Apply le_max_r.
-Apply le_plus_l.
-Rewrite <- Rabsolu_Ropp.
-Replace ``-((Un (plus N k1))-(Vn N))`` with ``(Vn N)-(Un (plus N k1))``; [Assumption | Ring].
-Reflexivity.
-Reflexivity.
-Apply H5.
-Unfold ge; Apply le_trans with (max N1 N2).
-Apply le_max_r.
-Unfold N; Apply le_max_l.
-Pattern 4 eps; Replace ``eps`` with ``5*eps/5``.
-Ring.
-Unfold Rdiv; Rewrite <- Rmult_assoc; Apply Rinv_r_simpl_m.
-DiscrR.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Assumption.
-Apply Rlt_Rinv.
-Sup0; Try Apply lt_O_Sn.
-Qed.
diff --git a/theories7/Reals/Rdefinitions.v b/theories7/Reals/Rdefinitions.v
deleted file mode 100644
index 79be0176..00000000
--- a/theories7/Reals/Rdefinitions.v
+++ /dev/null
@@ -1,69 +0,0 @@
-(************************************************************************)
-(*  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: Rdefinitions.v,v 1.1.2.1 2004/07/16 19:31:34 herbelin Exp $ i*)
-
-
-(*********************************************************)
-(**          Definitions for the axiomatization          *)
-(*                                                       *)
-(*********************************************************)
-
-Require Export ZArith_base.
-
-Parameter R:Set.
-
-(* Declare Scope positive_scope with Key R *)
-Delimits Scope R_scope with R.
-
-(* Automatically open scope R_scope for arguments of type R *)
-Bind Scope R_scope with R.
-
-Parameter R0:R.
-Parameter R1:R.
-Parameter Rplus:R->R->R.
-Parameter Rmult:R->R->R.
-Parameter Ropp:R->R.
-Parameter Rinv:R->R. 
-Parameter Rlt:R->R->Prop.    
-Parameter up:R->Z.
-
-V8Infix "+" Rplus : R_scope.
-V8Infix "*" Rmult : R_scope.
-V8Notation "- x" := (Ropp x) : R_scope.
-V8Notation "/ x" := (Rinv x) : R_scope.
-
-V8Infix "<"  Rlt : R_scope.
-
-(*i*******************************************************i*)
-
-(**********)
-Definition Rgt:R->R->Prop:=[r1,r2:R](Rlt r2 r1).
-
-(**********)
-Definition Rle:R->R->Prop:=[r1,r2:R]((Rlt r1 r2)\/(r1==r2)).
-
-(**********)
-Definition Rge:R->R->Prop:=[r1,r2:R]((Rgt r1 r2)\/(r1==r2)).
-
-(**********)
-Definition Rminus:R->R->R:=[r1,r2:R](Rplus r1 (Ropp r2)).
-
-(**********)
-Definition Rdiv:R->R->R:=[r1,r2:R](Rmult r1 (Rinv r2)).
-
-V8Infix "-" Rminus : R_scope.
-V8Infix "/" Rdiv : R_scope.
-
-V8Infix "<=" Rle : R_scope.
-V8Infix ">=" Rge : R_scope.
-V8Infix ">" Rgt : R_scope.
-
-V8Notation "x <= y <= z" := (Rle x y)/\(Rle y z) : R_scope.
-V8Notation "x <= y < z" := (Rle x y)/\(Rlt y z) : R_scope.
-V8Notation "x < y < z" := (Rlt x y)/\(Rlt y z) : R_scope.
-V8Notation "x < y <= z" := (Rlt x y)/\(Rle y z) : R_scope.
diff --git a/theories7/Reals/Rderiv.v b/theories7/Reals/Rderiv.v
deleted file mode 100644
index b55aa6ea..00000000
--- a/theories7/Reals/Rderiv.v
+++ /dev/null
@@ -1,453 +0,0 @@
-(************************************************************************)
-(*  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: Rderiv.v,v 1.1.2.1 2004/07/16 19:31:34 herbelin Exp $ i*)
-
-(*********************************************************)
-(**     Definition of the derivative,continuity          *)
-(*                                                       *)
-(*********************************************************)
-
-Require Rbase.
-Require Rfunctions.
-Require Rlimit.
-Require Fourier.
-Require Classical_Prop.
-Require Classical_Pred_Type.
-Require Omega.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(*********)
-Definition D_x:(R->Prop)->R->R->Prop:=[D:R->Prop][y:R][x:R]
-       (D x)/\(~y==x).
-
-(*********)
-Definition continue_in:(R->R)->(R->Prop)->R->Prop:=
-       [f:R->R; D:R->Prop; x0:R](limit1_in f (D_x D x0) (f x0) x0).
-
-(*********)
-Definition D_in:(R->R)->(R->R)->(R->Prop)->R->Prop:=
-  [f:R->R; d:R->R; D:R->Prop; x0:R](limit1_in 
-    [x:R] (Rdiv (Rminus (f x) (f x0)) (Rminus x x0)) 
-    (D_x D x0) (d x0) x0).
-
-(*********)
-Lemma cont_deriv:(f,d:R->R;D:R->Prop;x0:R)
-         (D_in f d D x0)->(continue_in f D x0).
-Unfold continue_in;Unfold D_in;Unfold limit1_in;Unfold limit_in;
- Unfold Rdiv;Simpl;Intros;Elim (H eps H0); Clear H;Intros;
- Elim H;Clear H;Intros; Elim (Req_EM (d x0) R0);Intro.
-Split with (Rmin R1 x);Split.
-Elim (Rmin_Rgt R1 x R0);Intros a b;
- Apply (b (conj (Rgt R1 R0) (Rgt x R0) Rlt_R0_R1 H)).
-Intros;Elim H3;Clear H3;Intros;
-Generalize (let (H1,H2)=(Rmin_Rgt R1 x (R_dist x1 x0)) in H1);
- Unfold Rgt;Intro;Elim (H5 H4);Clear H5;Intros;
- Generalize (H1 x1 (conj (D_x D x0 x1) (Rlt (R_dist x1 x0) x) H3 H6));
- Clear H1;Intro;Unfold D_x in H3;Elim H3;Intros.
-Rewrite H2 in H1;Unfold R_dist; Unfold R_dist in H1;
- Cut (Rlt (Rabsolu (Rminus (f x1) (f x0))) 
-          (Rmult eps (Rabsolu (Rminus x1 x0)))).
-Intro;Unfold R_dist in H5;
-  Generalize (Rlt_monotony eps ``(Rabsolu (x1-x0))`` ``1`` H0 H5);
-Rewrite Rmult_1r;Intro;Apply Rlt_trans with r2:=``eps*(Rabsolu (x1-x0))``;
- Assumption.
-Rewrite (minus_R0 ``((f x1)-(f x0))*/(x1-x0)``) in H1;
- Rewrite Rabsolu_mult in H1; Cut ``x1-x0 <> 0``.
-Intro;Rewrite (Rabsolu_Rinv (Rminus x1 x0) H9) in H1;
- Generalize (Rlt_monotony ``(Rabsolu (x1-x0))`` 
- ``(Rabsolu ((f x1)-(f x0)))*/(Rabsolu (x1-x0))`` eps 
- (Rabsolu_pos_lt ``x1-x0`` H9) H1);Intro; Rewrite Rmult_sym in H10;
- Rewrite Rmult_assoc in H10;Rewrite Rinv_l in H10.
-Rewrite Rmult_1r in H10;Rewrite Rmult_sym;Assumption.
-Apply Rabsolu_no_R0;Auto.
-Apply Rminus_eq_contra;Auto.
-(**)
- Split with (Rmin (Rmin (Rinv (Rplus R1 R1)) x) 
-              (Rmult eps (Rinv (Rabsolu (Rmult (Rplus R1 R1) (d x0))))));
- Split.
-Cut (Rgt (Rmin (Rinv (Rplus R1 R1)) x) R0).
-Cut (Rgt (Rmult eps (Rinv (Rabsolu (Rmult (Rplus R1 R1) (d x0))))) R0).
-Intros;Elim (Rmin_Rgt (Rmin (Rinv (Rplus R1 R1)) x) 
-            (Rmult eps (Rinv (Rabsolu (Rmult (Rplus R1 R1) (d x0))))) R0);
- Intros a b;
- Apply (b (conj (Rgt (Rmin (Rinv (Rplus R1 R1)) x) R0)
-       (Rgt (Rmult eps (Rinv (Rabsolu (Rmult (Rplus R1 R1) (d x0))))) R0)
-        H4 H3)).
-Apply Rmult_gt;Auto.
-Unfold Rgt;Apply Rlt_Rinv;Apply Rabsolu_pos_lt;Apply mult_non_zero;
- Split.
-DiscrR.
-Assumption.
-Elim (Rmin_Rgt (Rinv (Rplus R1 R1)) x R0);Intros a b;
- Cut (Rlt R0 (Rplus R1 R1)).
-Intro;Generalize (Rlt_Rinv (Rplus R1 R1) H3);Intro;
- Fold (Rgt (Rinv (Rplus R1 R1)) R0) in H4;
- Apply (b (conj (Rgt (Rinv (Rplus R1 R1)) R0) (Rgt x R0) H4 H)).
-Fourier.
-Intros;Elim H3;Clear H3;Intros;
- Generalize (let (H1,H2)=(Rmin_Rgt (Rmin (Rinv (Rplus R1 R1)) x)
-       (Rmult eps (Rinv (Rabsolu (Rmult (Rplus R1 R1) (d x0)))))
-       (R_dist x1 x0)) in H1);Unfold Rgt;Intro;Elim (H5 H4);Clear H5;
- Intros;
- Generalize (let (H1,H2)=(Rmin_Rgt (Rinv (Rplus R1 R1)) x
-          (R_dist x1 x0)) in H1);Unfold Rgt;Intro;Elim (H7 H5);Clear H7;
- Intros;Clear H4 H5;
- Generalize (H1 x1 (conj (D_x D x0 x1) (Rlt (R_dist x1 x0) x) H3 H8));
- Clear H1;Intro;Unfold D_x in H3;Elim H3;Intros;
- Generalize (sym_not_eqT R x0 x1 H5);Clear H5;Intro H5;
- Generalize (Rminus_eq_contra x1 x0 H5);
- Intro;Generalize H1;Pattern 1 (d x0); 
- Rewrite <-(let (H1,H2)=(Rmult_ne (d x0)) in H2);
- Rewrite <-(Rinv_l (Rminus x1 x0) H9); Unfold R_dist;Unfold 1 Rminus;
- Rewrite (Rmult_sym (Rminus (f x1) (f x0)) (Rinv (Rminus x1 x0)));
- Rewrite (Rmult_sym (Rmult (Rinv (Rminus x1 x0)) (Rminus x1 x0)) (d x0));
- Rewrite <-(Ropp_mul1 (d x0) (Rmult (Rinv (Rminus x1 x0)) (Rminus x1 x0)));
- Rewrite (Rmult_sym (Ropp (d x0))
-                    (Rmult (Rinv (Rminus x1 x0)) (Rminus x1 x0)));
- Rewrite (Rmult_assoc (Rinv (Rminus x1 x0)) (Rminus x1 x0) (Ropp (d x0)));
- Rewrite <-(Rmult_Rplus_distr (Rinv (Rminus x1 x0)) (Rminus (f x1) (f x0))
-                   (Rmult (Rminus x1 x0) (Ropp (d x0))));
- Rewrite (Rabsolu_mult (Rinv (Rminus x1 x0))
-                       (Rplus (Rminus (f x1) (f x0))
-                              (Rmult (Rminus x1 x0) (Ropp (d x0)))));
- Clear H1;Intro;Generalize (Rlt_monotony (Rabsolu (Rminus x1 x0)) 
-        (Rmult (Rabsolu (Rinv (Rminus x1 x0)))
-           (Rabsolu
-             (Rplus (Rminus (f x1) (f x0))
-               (Rmult (Rminus x1 x0) (Ropp (d x0)))))) eps 
-        (Rabsolu_pos_lt (Rminus x1 x0) H9) H1); 
- Rewrite <-(Rmult_assoc (Rabsolu (Rminus x1 x0)) 
-                 (Rabsolu (Rinv (Rminus x1 x0)))
-               (Rabsolu
-           (Rplus (Rminus (f x1) (f x0))
-             (Rmult (Rminus x1 x0) (Ropp (d x0)))))); 
- Rewrite (Rabsolu_Rinv (Rminus x1 x0) H9);
- Rewrite (Rinv_r (Rabsolu (Rminus x1 x0)) 
-                 (Rabsolu_no_R0 (Rminus x1 x0) H9));
- Rewrite (let (H1,H2)=(Rmult_ne (Rabsolu
-         (Rplus (Rminus (f x1) (f x0))
-           (Rmult (Rminus x1 x0) (Ropp (d x0)))))) in H2);
- Generalize (Rabsolu_triang_inv (Rminus (f x1) (f x0))
-         (Rmult (Rminus x1 x0) (d x0)));Intro;
- Rewrite (Rmult_sym (Rminus x1 x0) (Ropp (d x0)));
- Rewrite (Ropp_mul1 (d x0) (Rminus x1 x0));
- Fold (Rminus (Rminus (f x1) (f x0)) (Rmult (d x0) (Rminus x1 x0)));
- Rewrite (Rmult_sym (Rminus x1 x0) (d x0)) in H10;
- Clear H1;Intro;Generalize (Rle_lt_trans 
-           (Rminus (Rabsolu (Rminus (f x1) (f x0)))
-           (Rabsolu (Rmult (d x0) (Rminus x1 x0))))
-          (Rabsolu
-           (Rminus (Rminus (f x1) (f x0)) (Rmult (d x0) (Rminus x1 x0))))
-          (Rmult (Rabsolu (Rminus x1 x0)) eps) H10 H1);
- Clear H1;Intro;
- Generalize (Rlt_compatibility (Rabsolu (Rmult (d x0) (Rminus x1 x0)))
-   (Rminus (Rabsolu (Rminus (f x1) (f x0)))
-           (Rabsolu (Rmult (d x0) (Rminus x1 x0))))
-   (Rmult (Rabsolu (Rminus x1 x0)) eps) H1);
- Unfold 2 Rminus;Rewrite (Rplus_sym (Rabsolu (Rminus (f x1) (f x0)))
-    (Ropp (Rabsolu (Rmult (d x0) (Rminus x1 x0)))));
- Rewrite <-(Rplus_assoc (Rabsolu (Rmult (d x0) (Rminus x1 x0)))
-  (Ropp (Rabsolu (Rmult (d x0) (Rminus x1 x0)))) 
-  (Rabsolu (Rminus (f x1) (f x0))));
- Rewrite (Rplus_Ropp_r (Rabsolu (Rmult (d x0) (Rminus x1 x0))));
- Rewrite (let (H1,H2)=(Rplus_ne (Rabsolu (Rminus (f x1) (f x0)))) in H2);
- Clear H1;Intro;Cut (Rlt (Rplus (Rabsolu (Rmult (d x0) (Rminus x1 x0)))
-           (Rmult (Rabsolu (Rminus x1 x0)) eps)) eps).
-Intro;Apply (Rlt_trans (Rabsolu (Rminus (f x1) (f x0))) 
-    (Rplus (Rabsolu (Rmult (d x0) (Rminus x1 x0)))
-            (Rmult (Rabsolu (Rminus x1 x0)) eps)) eps H1 H11). 
-Clear H1 H5 H3 H10;Generalize (Rabsolu_pos_lt (d x0) H2);
- Intro;Unfold Rgt in H0;Generalize (Rlt_monotony eps (R_dist x1 x0)
-       (Rinv (Rplus R1 R1)) H0 H7);Clear H7;Intro;
- Generalize (Rlt_monotony (Rabsolu (d x0)) (R_dist x1 x0) 
-    (Rmult eps (Rinv (Rabsolu (Rmult (Rplus R1 R1) (d x0))))) H1 H6);
- Clear H6;Intro;Rewrite (Rmult_sym eps (R_dist x1 x0)) in H3; 
- Unfold R_dist in H3 H5;
- Rewrite <-(Rabsolu_mult (d x0) (Rminus x1 x0)) in H5;
- Rewrite (Rabsolu_mult (Rplus R1 R1) (d x0)) in H5;
- Cut ~(Rabsolu (Rplus R1 R1))==R0.
-Intro;Fold (Rgt (Rabsolu (d x0)) R0) in H1;
- Rewrite (Rinv_Rmult (Rabsolu (Rplus R1 R1)) (Rabsolu (d x0))
- H6 (imp_not_Req (Rabsolu (d x0)) R0 
-  (or_intror (Rlt (Rabsolu (d x0)) R0) (Rgt (Rabsolu (d x0)) R0) H1))) 
-  in H5;
- Rewrite (Rmult_sym (Rabsolu (d x0)) (Rmult eps
-             (Rmult (Rinv (Rabsolu (Rplus R1 R1)))
-               (Rinv (Rabsolu (d x0)))))) in H5;
- Rewrite <-(Rmult_assoc eps (Rinv (Rabsolu (Rplus R1 R1))) 
-   (Rinv (Rabsolu (d x0)))) in H5;
- Rewrite (Rmult_assoc (Rmult eps (Rinv (Rabsolu (Rplus R1 R1))))
-    (Rinv (Rabsolu (d x0))) (Rabsolu (d x0))) in H5;
- Rewrite (Rinv_l (Rabsolu (d x0)) (imp_not_Req (Rabsolu (d x0)) R0 
-  (or_intror (Rlt (Rabsolu (d x0)) R0) (Rgt (Rabsolu (d x0)) R0) H1))) 
-  in H5;
- Rewrite (let (H1,H2)=(Rmult_ne (Rmult eps (Rinv (Rabsolu (Rplus R1 R1)))))
-   in H1) in H5;Cut (Rabsolu (Rplus R1 R1))==(Rplus R1 R1).
-Intro;Rewrite H7 in H5;
- Generalize (Rplus_lt (Rabsolu (Rmult (d x0) (Rminus x1 x0)))
-        (Rmult eps (Rinv (Rplus R1 R1)))
-        (Rmult (Rabsolu (Rminus x1 x0)) eps)
-        (Rmult eps (Rinv (Rplus R1 R1))) H5 H3);Intro;
- Rewrite eps2 in H10;Assumption.
-Unfold Rabsolu;Case (case_Rabsolu (Rplus R1 R1));Auto.
- Intro;Cut (Rlt R0 (Rplus R1 R1)).
-Intro;Generalize (Rlt_antisym R0 (Rplus R1 R1) H7);Intro;ElimType False;
- Auto.
-Fourier.
-Apply Rabsolu_no_R0.
-DiscrR.
-Qed.
-
-
-(*********)
-Lemma Dconst:(D:R->Prop)(y:R)(x0:R)(D_in [x:R]y [x:R]R0 D x0).
-Unfold D_in;Intros;Unfold limit1_in;Unfold limit_in;Unfold Rdiv;Intros;Simpl;
- Split with eps;Split;Auto.
-Intros;Rewrite (eq_Rminus y y (refl_eqT R y));
- Rewrite Rmult_Ol;Unfold R_dist; 
- Rewrite (eq_Rminus R0 R0 (refl_eqT R R0));Unfold Rabsolu;
- Case (case_Rabsolu R0);Intro.
-Absurd (Rlt R0 R0);Auto.
-Red;Intro;Apply (Rlt_antirefl R0 H1).
-Unfold Rgt in H0;Assumption.
-Qed.
-
-(*********)
-Lemma Dx:(D:R->Prop)(x0:R)(D_in [x:R]x [x:R]R1 D x0).
-Unfold D_in;Unfold Rdiv;Intros;Unfold limit1_in;Unfold limit_in;Intros;Simpl;
-  Split with eps;Split;Auto.
-Intros;Elim H0;Clear H0;Intros;Unfold D_x in H0;
- Elim H0;Intros;
- Rewrite (Rinv_r (Rminus x x0) (Rminus_eq_contra x x0 
-      (sym_not_eqT R x0 x H3)));
- Unfold R_dist; 
- Rewrite (eq_Rminus R1 R1 (refl_eqT R R1));Unfold Rabsolu;
- Case (case_Rabsolu R0);Intro.
-Absurd (Rlt R0 R0);Auto.
-Red;Intro;Apply (Rlt_antirefl R0 r).
-Unfold Rgt in H;Assumption.
-Qed. 
-
-(*********)
-Lemma Dadd:(D:R->Prop)(df,dg:R->R)(f,g:R->R)(x0:R)
-  (D_in f df D x0)->(D_in g dg D x0)->
-  (D_in [x:R](Rplus (f x) (g x)) [x:R](Rplus (df x) (dg x)) D x0).
-Unfold D_in;Intros;Generalize (limit_plus 
-   [x:R](Rmult (Rminus (f x) (f x0)) (Rinv (Rminus x x0)))
-   [x:R](Rmult  (Rminus (g x) (g x0)) (Rinv (Rminus x x0))) 
-   (D_x D x0) (df x0) (dg x0) x0 H H0);Clear H H0;
- Unfold limit1_in;Unfold limit_in;Simpl;Intros;
- Elim (H eps H0);Clear H;Intros;Elim H;Clear H;Intros;
- Split with x;Split;Auto;Intros;Generalize (H1 x1 H2);Clear H1;Intro; 
- Rewrite (Rmult_sym (Rminus (f x1) (f x0)) (Rinv (Rminus x1 x0))) in H1;
- Rewrite (Rmult_sym (Rminus (g x1) (g x0)) (Rinv (Rminus x1 x0))) in H1;
- Rewrite <-(Rmult_Rplus_distr (Rinv (Rminus x1 x0)) 
-                    (Rminus (f x1) (f x0)) 
-                    (Rminus (g x1) (g x0))) in H1;
- Rewrite (Rmult_sym (Rinv (Rminus x1 x0))
-           (Rplus (Rminus (f x1) (f x0)) (Rminus (g x1) (g x0)))) in H1;
- Cut (Rplus (Rminus (f x1) (f x0)) (Rminus (g x1) (g x0)))==
-      (Rminus (Rplus (f x1) (g x1)) (Rplus (f x0) (g x0))).
-Intro;Rewrite H3 in H1;Assumption.
-Ring.
-Qed.
-
-(*********)
-Lemma Dmult:(D:R->Prop)(df,dg:R->R)(f,g:R->R)(x0:R)
-  (D_in f df D x0)->(D_in g dg D x0)->
-  (D_in [x:R](Rmult (f x) (g x))  
-             [x:R](Rplus (Rmult (df x) (g x)) (Rmult (f x) (dg x))) D x0).
-Intros;Unfold D_in;Generalize H H0;Intros;Unfold D_in in H H0;
- Generalize (cont_deriv f df D x0 H1);Unfold continue_in;Intro;
- Generalize (limit_mul 
-   [x:R](Rmult (Rminus (g x) (g x0)) (Rinv (Rminus x x0)))
-   [x:R](f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3);Intro;
- Cut (limit1_in [x:R](g x0) (D_x D x0) (g x0) x0).
-Intro;Generalize (limit_mul 
-  [x:R](Rmult (Rminus (f x) (f x0)) (Rinv (Rminus x x0)))
-  [_:R](g x0) (D_x D x0) (df x0) (g x0) x0 H H5);Clear H H0 H1 H2 H3 H5;
- Intro;Generalize (limit_plus 
-  [x:R](Rmult (Rmult (Rminus (f x) (f x0)) (Rinv (Rminus x x0))) (g x0))
-  [x:R](Rmult (Rmult (Rminus (g x) (g x0)) (Rinv (Rminus x x0)))
-                (f x)) (D_x D x0) (Rmult (df x0) (g x0)) 
-                               (Rmult (dg x0) (f x0)) x0 H H4);
- Clear H4 H;Intro;Unfold limit1_in in H;Unfold limit_in in H;
- Simpl in H;Unfold limit1_in;Unfold limit_in;Simpl;Intros;
- Elim (H eps H0);Clear H;Intros;Elim H;Clear H;Intros;
- Split with x;Split;Auto;Intros;Generalize (H1 x1 H2);Clear H1;Intro;
- Rewrite (Rmult_sym (Rminus (f x1) (f x0)) (Rinv (Rminus x1 x0))) in H1;
- Rewrite (Rmult_sym (Rminus (g x1) (g x0)) (Rinv (Rminus x1 x0))) in H1;
- Rewrite (Rmult_assoc (Rinv (Rminus x1 x0)) (Rminus (f x1) (f x0))
-       (g x0)) in H1;
- Rewrite (Rmult_assoc (Rinv (Rminus x1 x0)) (Rminus (g x1) (g x0))
-       (f x1)) in H1;
- Rewrite <-(Rmult_Rplus_distr (Rinv (Rminus x1 x0))
-                (Rmult (Rminus (f x1) (f x0)) (g x0))
-                (Rmult (Rminus (g x1) (g x0)) (f x1))) in H1;
- Rewrite (Rmult_sym (Rinv (Rminus x1 x0))
-       (Rplus (Rmult (Rminus (f x1) (f x0)) (g x0))
-               (Rmult (Rminus (g x1) (g x0)) (f x1)))) in H1;
- Rewrite (Rmult_sym (dg x0) (f x0)) in H1;
- Cut (Rplus (Rmult (Rminus (f x1) (f x0)) (g x0))
-               (Rmult (Rminus (g x1) (g x0)) (f x1)))==
-      (Rminus (Rmult (f x1) (g x1)) (Rmult (f x0) (g x0))).
-Intro;Rewrite H3 in H1;Assumption.
-Ring.
-Unfold limit1_in;Unfold limit_in;Simpl;Intros;
- Split with eps;Split;Auto;Intros;Elim (R_dist_refl (g x0) (g x0));
- Intros a b;Rewrite (b (refl_eqT R (g x0)));Unfold Rgt in H;Assumption.
-Qed.
-
-(*********)
-Lemma Dmult_const:(D:R->Prop)(f,df:R->R)(x0:R)(a:R)(D_in f df D x0)->
-  (D_in [x:R](Rmult a (f x)) ([x:R](Rmult a (df x))) D x0).
-Intros;Generalize (Dmult D [_:R]R0 df [_:R]a f x0 (Dconst D a x0) H);
- Unfold D_in;Intros;
- Rewrite (Rmult_Ol (f x0)) in H0;
- Rewrite (let (H1,H2)=(Rplus_ne (Rmult a (df x0))) in H2) in H0;
- Assumption.
-Qed.
-
-(*********)
-Lemma Dopp:(D:R->Prop)(f,df:R->R)(x0:R)(D_in f df D x0)->
-  (D_in [x:R](Ropp (f x)) ([x:R](Ropp (df x))) D x0).
-Intros;Generalize (Dmult_const D f df x0 (Ropp R1) H); Unfold D_in;
- Unfold limit1_in;Unfold limit_in;Intros;
- Generalize (H0 eps H1);Clear H0;Intro;Elim H0;Clear H0;Intros; 
- Elim H0;Clear H0;Simpl;Intros;Split with x;Split;Auto.
-Intros;Generalize (H2 x1 H3);Clear H2;Intro;Rewrite Ropp_mul1 in H2;
- Rewrite Ropp_mul1 in H2;Rewrite Ropp_mul1 in H2;
- Rewrite (let (H1,H2)=(Rmult_ne (f x1)) in H2) in H2; 
- Rewrite (let (H1,H2)=(Rmult_ne (f x0)) in H2) in H2;
- Rewrite (let (H1,H2)=(Rmult_ne (df x0)) in H2) in H2;Assumption.
-Qed.
-
-(*********)
-Lemma Dminus:(D:R->Prop)(df,dg:R->R)(f,g:R->R)(x0:R)
-  (D_in f df D x0)->(D_in g dg D x0)->
-  (D_in [x:R](Rminus (f x) (g x)) [x:R](Rminus (df x) (dg x)) D x0).
-Unfold Rminus;Intros;Generalize (Dopp D g dg x0 H0);Intro;
- Apply (Dadd D df [x:R](Ropp (dg x)) f [x:R](Ropp (g x)) x0);Assumption. 
-Qed.
-
-(*********)
-Lemma Dx_pow_n:(n:nat)(D:R->Prop)(x0:R)
-  (D_in [x:R](pow x n)  
-        [x:R](Rmult (INR n) (pow x (minus n (1)))) D x0).
-Induction n;Intros.
-Simpl; Rewrite Rmult_Ol; Apply Dconst.
-Intros;Cut n0=(minus (S n0) (1));
-  [ Intro a; Rewrite <- a;Clear a | Simpl; Apply minus_n_O ].
-Generalize (Dmult D [_:R]R1 
-   [x:R](Rmult (INR n0) (pow x (minus n0 (1)))) [x:R]x [x:R](pow x n0) 
-   x0 (Dx D x0) (H D x0));Unfold D_in;Unfold limit1_in;Unfold limit_in;
- Simpl;Intros;
- Elim (H0 eps H1);Clear H0;Intros;Elim H0;Clear H0;Intros;
- Split with x;Split;Auto.
-Intros;Generalize (H2 x1 H3);Clear H2 H3;Intro;
- Rewrite (let (H1,H2)=(Rmult_ne (pow x0 n0)) in H2) in H2;
- Rewrite (tech_pow_Rmult x1 n0) in H2;
- Rewrite (tech_pow_Rmult x0 n0) in H2;
- Rewrite (Rmult_sym (INR n0) (pow x0 (minus n0 (1)))) in H2;
- Rewrite <-(Rmult_assoc x0 (pow x0 (minus n0 (1))) (INR n0)) in H2;
- Rewrite (tech_pow_Rmult x0 (minus n0 (1))) in H2;
- Elim (classic (n0=O));Intro cond.
-Rewrite cond in H2;Rewrite cond;Simpl in H2;Simpl;
- Cut (Rplus R1 (Rmult (Rmult x0 R1) R0))==(Rmult R1 R1);
- [Intro A; Rewrite A in H2; Assumption|Ring].
-Cut ~(n0=O)->(S (minus n0 (1)))=n0;[Intro|Omega];
- Rewrite (H3 cond) in H2; Rewrite (Rmult_sym (pow x0 n0) (INR n0)) in H2;
- Rewrite (tech_pow_Rplus x0 n0 n0) in H2; Assumption.
-Qed.
-
-(*********)
-Lemma Dcomp:(Df,Dg:R->Prop)(df,dg:R->R)(f,g:R->R)(x0:R)
-  (D_in f df Df x0)->(D_in g dg Dg (f x0))->
-  (D_in [x:R](g (f x)) [x:R](Rmult (df x) (dg (f x))) 
-                       (Dgf Df Dg f) x0).
-Intros Df Dg df dg f g x0 H H0;Generalize H H0;Unfold D_in;Unfold Rdiv;Intros;
-Generalize (limit_comp f [x:R](Rmult (Rminus (g x) (g (f x0)))
-                               (Rinv (Rminus x (f x0)))) (D_x Df x0)
-              (D_x Dg (f x0)) 
-              (f x0) (dg (f x0)) x0);Intro;
- Generalize (cont_deriv f df Df x0 H);Intro;Unfold continue_in in H4;
- Generalize (H3 H4 H2);Clear H3;Intro;
- Generalize (limit_mul [x:R](Rmult (Rminus (g (f x)) (g (f x0)))
-                                   (Rinv (Rminus (f x) (f x0))))
-                       [x:R](Rmult (Rminus (f x) (f x0))
-                                   (Rinv (Rminus x x0))) 
-                       (Dgf (D_x Df x0) (D_x Dg (f x0)) f) 
-                       (dg (f x0)) (df x0) x0 H3);Intro;
- Cut (limit1_in
-         [x:R](Rmult (Rminus (f x) (f x0)) (Rinv (Rminus x x0)))
-         (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (df x0) x0).
-Intro;Generalize (H5 H6);Clear H5;Intro;
- Generalize (limit_mul 
-        [x:R](Rmult (Rminus (f x) (f x0)) (Rinv (Rminus x x0))) 
-        [x:R](dg (f x0))
-       (D_x Df x0) (df x0) (dg (f x0)) x0 H1
-    (limit_free [x:R](dg (f x0)) (D_x Df x0) x0 x0));
- Intro;
- Unfold limit1_in;Unfold limit_in;Simpl;Unfold limit1_in in H5 H7;
- Unfold limit_in in H5 H7;Simpl in H5 H7;Intros;Elim (H5 eps H8);
- Elim (H7 eps H8);Clear H5 H7;Intros;Elim H5;Elim H7;Clear H5 H7;
- Intros;Split with (Rmin x x1);Split.
-Elim (Rmin_Rgt x x1 R0);Intros a b;
- Apply (b (conj (Rgt x R0) (Rgt x1 R0) H9 H5));Clear a b.
-Intros;Elim H11;Clear H11;Intros;Elim (Rmin_Rgt x x1 (R_dist x2 x0));
- Intros a b;Clear b;Unfold Rgt in a;Elim (a H12);Clear H5 a;Intros;
- Unfold D_x Dgf in H11 H7 H10;Clear H12;
- Elim (classic (f x2)==(f x0));Intro.
-Elim H11;Clear H11;Intros;Elim H11;Clear H11;Intros;
- Generalize (H10 x2 (conj (Df x2)/\~x0==x2 (Rlt (R_dist x2 x0) x)
-        (conj (Df x2) ~x0==x2 H11 H14) H5));Intro;
- Rewrite (eq_Rminus (f x2) (f x0) H12) in H16;
- Rewrite (Rmult_Ol (Rinv (Rminus x2 x0))) in H16;
- Rewrite (Rmult_Ol (dg (f x0))) in H16;
- Rewrite H12;
- Rewrite (eq_Rminus (g (f x0)) (g (f x0)) (refl_eqT R (g (f x0))));
- Rewrite (Rmult_Ol (Rinv (Rminus x2 x0)));Assumption.
-Clear H10 H5;Elim H11;Clear H11;Intros;Elim H5;Clear H5;Intros;
-Cut (((Df x2)/\~x0==x2)/\(Dg (f x2))/\~(f x0)==(f x2))
-        /\(Rlt (R_dist x2 x0) x1);Auto;Intro;
- Generalize (H7 x2 H14);Intro;
- Generalize (Rminus_eq_contra (f x2) (f x0) H12);Intro;
- Rewrite (Rmult_assoc (Rminus (g (f x2)) (g (f x0))) 
-           (Rinv (Rminus (f x2) (f x0)))
-          (Rmult (Rminus (f x2) (f x0)) (Rinv (Rminus x2 x0)))) in H15;
- Rewrite <-(Rmult_assoc (Rinv (Rminus (f x2) (f x0))) 
-             (Rminus (f x2) (f x0)) (Rinv (Rminus x2 x0))) in H15;
- Rewrite (Rinv_l (Rminus (f x2) (f x0)) H16) in H15;
- Rewrite (let (H1,H2)=(Rmult_ne (Rinv (Rminus x2 x0))) in H2) in H15;
- Rewrite (Rmult_sym (df x0) (dg (f x0)));Assumption.
-Clear H5 H3 H4 H2;Unfold limit1_in;Unfold limit_in;Simpl;
- Unfold limit1_in in H1;Unfold limit_in in H1;Simpl in H1;Intros;
- Elim (H1 eps H2);Clear H1;Intros;Elim H1;Clear H1;Intros;
- Split with x;Split;Auto;Intros;Unfold D_x Dgf in H4 H3;
- Elim H4;Clear H4;Intros;Elim H4;Clear H4;Intros;
- Exact (H3 x1 (conj (Df x1)/\~x0==x1 (Rlt (R_dist x1 x0) x) H4 H5)).
-Qed.   
-
-(*********)
-Lemma D_pow_n:(n:nat)(D:R->Prop)(x0:R)(expr,dexpr:R->R)
- (D_in expr dexpr D x0)-> (D_in [x:R](pow (expr x) n) 
-     [x:R](Rmult (Rmult (INR n) (pow (expr x) (minus n (1)))) (dexpr x)) 
-          (Dgf D D expr) x0).
-Intros n D x0 expr dexpr H; 
- Generalize (Dcomp D D dexpr [x:R](Rmult (INR n) (pow x (minus n (1)))) 
-         expr [x:R](pow x n) x0  H (Dx_pow_n n D (expr x0)));
- Intro; Unfold D_in; Unfold limit1_in; Unfold limit_in;Simpl;Intros; 
- Unfold D_in in H0; Unfold limit1_in in H0; Unfold limit_in in H0;Simpl in H0;
- Elim (H0 eps H1);Clear H0;Intros;Elim H0;Clear H0;Intros;Split with x;Split;
- Intros; Auto.
-Cut ``((dexpr x0)*((INR n)*(pow (expr x0) (minus n (S O)))))==
-            ((INR n)*(pow (expr x0) (minus n (S O)))*(dexpr x0))``;
- [Intro Rew;Rewrite <- Rew;Exact (H2 x1 H3)|Ring].
-Qed.
-
diff --git a/theories7/Reals/Reals.v b/theories7/Reals/Reals.v
deleted file mode 100644
index d0f879ab..00000000
--- a/theories7/Reals/Reals.v
+++ /dev/null
@@ -1,32 +0,0 @@
-(************************************************************************)
-(*  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: Reals.v,v 1.1.2.1 2004/07/16 19:31:34 herbelin Exp $ i*)
-
-(* The library REALS is divided in 6 parts :
-   - Rbase: basic lemmas on R
-            equalities and inequalities
-            Ring and Field are instantiated on R
-   - Rfunctions: some useful functions (Rabsolu, Rmin, Rmax, fact...)
-   - SeqSeries: theory of sequences and series
-   - Rtrigo: theory of trigonometric functions
-   - Ranalysis: some topology and general results of real analysis (mean value theorem, intermediate value theorem,...)
-   - Integration: Newton and Riemann' integrals
-
-  Tactics are:
-  - DiscrR: for goals like ``?1<>0``
-  - Sup: for goals like ``?1<?2``
-  - RCompute: for equalities with constants like ``10*10==100``
-  - Reg: for goals like (continuity_pt ?1 ?2) or (derivable_pt ?1 ?2) *)
-  
-Require Export Rbase.
-Require Export Rfunctions.
-Require Export SeqSeries.
-Require Export Rtrigo.
-Require Export Ranalysis.
-Require Export Integration.
diff --git a/theories7/Reals/Rfunctions.v b/theories7/Reals/Rfunctions.v
deleted file mode 100644
index fe6ccd96..00000000
--- a/theories7/Reals/Rfunctions.v
+++ /dev/null
@@ -1,832 +0,0 @@
-(************************************************************************)
-(*  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: Rfunctions.v,v 1.2.2.1 2004/07/16 19:31:34 herbelin Exp $ i*)
-
-(*i Some properties about pow and sum have been made with John Harrison i*)
-(*i Some Lemmas (about pow and powerRZ) have been done by Laurent Thery i*)
-
-(********************************************************)
-(**          Definition of the sum functions            *)
-(*                                                      *)
-(********************************************************)
-
-Require Rbase.
-Require Export R_Ifp.
-Require Export Rbasic_fun.
-Require Export R_sqr.
-Require Export SplitAbsolu.
-Require Export SplitRmult.
-Require Export ArithProp.
-Require Omega.
-Require Zpower.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope nat_scope.
-Open Local Scope R_scope.
-
-(*******************************)
-(**  Lemmas about factorial    *)
-(*******************************)
-(*********)
-Lemma INR_fact_neq_0:(n:nat)~(INR (fact n))==R0.
-Proof.
-Intro;Red;Intro;Apply (not_O_INR (fact n) (fact_neq_0 n));Assumption.
-Qed.    
-
-(*********)
-Lemma fact_simpl : (n:nat) (fact (S n))=(mult (S n) (fact n)).
-Proof.
-Intro; Reflexivity.
-Qed. 
-
-(*********)
-Lemma simpl_fact:(n:nat)(Rmult (Rinv (INR (fact (S n)))) 
-         (Rinv (Rinv (INR (fact n)))))==
-         (Rinv (INR (S n))).
-Proof.
-Intro;Rewrite (Rinv_Rinv (INR (fact n)) (INR_fact_neq_0 n)); 
- Unfold 1 fact;Cbv Beta Iota;Fold fact;
- Rewrite (mult_INR (S n) (fact n));
- Rewrite (Rinv_Rmult (INR (S n)) (INR (fact n))).
-Rewrite (Rmult_assoc (Rinv (INR (S n))) (Rinv (INR (fact n))) 
-  (INR (fact n)));Rewrite (Rinv_l (INR (fact n)) (INR_fact_neq_0 n));
- Apply (let (H1,H2)=(Rmult_ne (Rinv (INR (S n)))) in H1).
-Apply not_O_INR;Auto.
-Apply INR_fact_neq_0.
-Qed.
-
-(*******************************)
-(*          Power              *)
-(*******************************)
-(*********)
-Fixpoint pow [r:R;n:nat]:R:=
-  Cases n of
-     O     => R1
-    |(S n) => (Rmult r (pow r n))
-  end.
-
-V8Infix "^" pow : R_scope.
-
-Lemma pow_O: (x : R)  (pow x O) == R1.
-Proof.
-Reflexivity.
-Qed.
- 
-Lemma pow_1: (x : R)  (pow x (1)) == x.
-Proof.
-Simpl; Auto with real.
-Qed.
- 
-Lemma pow_add:
- (x : R) (n, m : nat)  (pow x (plus n m)) == (Rmult (pow x n) (pow x m)).
-Proof.
-Intros x n; Elim n; Simpl; Auto with real.
-Intros n0 H' m; Rewrite H'; Auto with real.
-Qed.
-
-Lemma pow_nonzero:
-  (x:R) (n:nat) ~(x==R0) -> ~((pow x n)==R0).
-Proof.
-Intro; Induction n; Simpl.
-Intro; Red;Intro;Apply R1_neq_R0;Assumption.
-Intros;Red; Intro;Elim (without_div_Od x (pow x n0) H1).
-Intro; Auto.
-Apply H;Assumption.
-Qed.
-
-Hints Resolve pow_O pow_1 pow_add pow_nonzero:real.
- 
-Lemma pow_RN_plus:
- (x : R)
- (n, m : nat)
- ~ x == R0 ->  (pow x n) == (Rmult (pow x (plus n m)) (Rinv (pow x m))).
-Proof.
-Intros x n; Elim n; Simpl; Auto with real.
-Intros n0 H' m H'0.
-Rewrite Rmult_assoc; Rewrite <- H'; Auto.
-Qed.
-
-Lemma pow_lt: (x : R) (n : nat) (Rlt R0 x) ->  (Rlt R0 (pow x n)).
-Proof.
-Intros x n; Elim n; Simpl; Auto with real.
-Intros n0 H' H'0; Replace R0 with (Rmult x R0); Auto with real.
-Qed.
-Hints Resolve pow_lt :real.
-
-Lemma Rlt_pow_R1:
- (x : R) (n : nat) (Rlt R1 x) -> (lt O n) ->  (Rlt R1 (pow x n)).
-Proof.
-Intros x n; Elim n; Simpl; Auto with real.
-Intros H' H'0; ElimType False; Omega.
-Intros n0; Case n0.
-Simpl; Rewrite Rmult_1r; Auto.
-Intros n1 H' H'0 H'1.
-Replace R1 with (Rmult R1 R1); Auto with real.
-Apply Rlt_trans with r2 := (Rmult x R1); Auto with real.
-Apply Rlt_monotony; Auto with real.
-Apply Rlt_trans with r2 := R1; Auto with real.
-Apply H'; Auto with arith.
-Qed.
-Hints Resolve Rlt_pow_R1 :real.
-
-Lemma Rlt_pow:
- (x : R) (n, m : nat) (Rlt R1 x) -> (lt n m) ->  (Rlt (pow x n) (pow x m)).
-Proof.
-Intros x n m H' H'0; Replace m with (plus (minus m n) n).
-Rewrite pow_add.
-Pattern 1 (pow x n); Replace (pow x n) with (Rmult R1 (pow x n)); 
- Auto with real.
-Apply Rminus_lt.
-Repeat Rewrite [y : R]  (Rmult_sym y (pow x n)); Rewrite <- Rminus_distr.
-Replace R0 with (Rmult (pow x n) R0); Auto with real.
-Apply Rlt_monotony; Auto with real.
-Apply pow_lt; Auto with real.
-Apply Rlt_trans with r2 := R1; Auto with real.
-Apply Rlt_minus; Auto with real.
-Apply Rlt_pow_R1; Auto with arith.
-Apply simpl_lt_plus_l with p := n; Auto with arith.
-Rewrite le_plus_minus_r; Auto with arith; Rewrite <- plus_n_O; Auto.
-Rewrite plus_sym; Auto with arith.
-Qed.
-Hints Resolve Rlt_pow :real.
-
-(*********)
-Lemma tech_pow_Rmult:(x:R)(n:nat)(Rmult x (pow x n))==(pow x (S n)).
-Proof.
-Induction n; Simpl; Trivial.
-Qed.
-
-(*********)
-Lemma tech_pow_Rplus:(x:R)(a,n:nat)
-  (Rplus (pow x a) (Rmult (INR n) (pow x a)))==
-           (Rmult (INR (S n)) (pow x a)).
-Proof.
-Intros; Pattern 1 (pow x a);  
- Rewrite <-(let (H1,H2)=(Rmult_ne (pow x a)) in H1); 
- Rewrite (Rmult_sym (INR n) (pow x a));
- Rewrite <- (Rmult_Rplus_distr (pow x a) R1 (INR n));
- Rewrite (Rplus_sym R1 (INR n)); Rewrite <-(S_INR n);
- Apply Rmult_sym.
-Qed.
-
-Lemma poly: (n:nat)(x:R)(Rlt R0 x)->
- (Rle (Rplus R1 (Rmult (INR n) x)) (pow  (Rplus R1 x) n)).
-Proof.
-Intros;Elim n.
-Simpl;Cut (Rplus R1 (Rmult R0 x))==R1.
-Intro;Rewrite H0;Unfold Rle;Right; Reflexivity.
-Ring.
-Intros;Unfold pow; Fold pow;
- Apply (Rle_trans (Rplus R1 (Rmult (INR (S n0)) x))
-    (Rmult (Rplus R1 x) (Rplus R1 (Rmult (INR n0) x))) 
-    (Rmult (Rplus R1 x) (pow (Rplus R1 x) n0))).
-Cut (Rmult (Rplus R1 x) (Rplus R1 (Rmult (INR n0) x)))== 
-  (Rplus (Rplus R1 (Rmult (INR (S n0)) x)) 
-         (Rmult (INR n0) (Rmult x x))).
-Intro;Rewrite H1;Pattern 1 (Rplus R1 (Rmult (INR (S n0)) x));
- Rewrite <-(let (H1,H2)=
-   (Rplus_ne (Rplus R1 (Rmult (INR (S n0)) x))) in H1);
- Apply Rle_compatibility;Elim n0;Intros.
-Simpl;Rewrite Rmult_Ol;Unfold Rle;Right;Auto.
-Unfold Rle;Left;Generalize Rmult_gt;Unfold Rgt;Intro;
- Fold (Rsqr x);Apply (H3 (INR (S n1)) (Rsqr x) 
-        (lt_INR_0 (S n1) (lt_O_Sn n1)));Fold (Rgt x R0) in H;
- Apply (pos_Rsqr1 x (imp_not_Req x R0 
-  (or_intror (Rlt x R0) (Rgt x R0) H))).
-Rewrite (S_INR n0);Ring.
-Unfold Rle in H0;Elim H0;Intro. 
-Unfold Rle;Left;Apply Rlt_monotony.
-Rewrite Rplus_sym;
- Apply (Rlt_r_plus_R1 x (Rlt_le R0 x H)).
-Assumption.
-Rewrite H1;Unfold Rle;Right;Trivial.
-Qed.
-
-Lemma Power_monotonic:
- (x:R) (m,n:nat) (Rgt (Rabsolu x) R1) 
-        -> (le m n)
-           -> (Rle (Rabsolu (pow x m)) (Rabsolu (pow x n))).
-Proof.
-Intros x m n H;Induction n;Intros;Inversion H0.
-Unfold Rle; Right; Reflexivity.
-Unfold Rle; Right; Reflexivity.
-Apply (Rle_trans (Rabsolu (pow x m))
-                 (Rabsolu (pow x n))
-                 (Rabsolu (pow x (S n)))).
-Apply Hrecn; Assumption.
-Simpl;Rewrite Rabsolu_mult.
-Pattern 1 (Rabsolu (pow x n)).
-Rewrite <-Rmult_1r.
-Rewrite (Rmult_sym (Rabsolu x) (Rabsolu (pow x n))).
-Apply Rle_monotony.
-Apply Rabsolu_pos.
-Unfold Rgt in H.
-Apply Rlt_le; Assumption.
-Qed.
-
-Lemma Pow_Rabsolu: (x:R) (n:nat)
-     (pow (Rabsolu x) n)==(Rabsolu (pow x n)).
-Proof.
-Intro;Induction n;Simpl.
-Apply sym_eqT;Apply Rabsolu_pos_eq;Apply Rlt_le;Apply Rlt_R0_R1.
-Intros; Rewrite H;Apply sym_eqT;Apply Rabsolu_mult.
-Qed.
-
-
-Lemma Pow_x_infinity:
-  (x:R) (Rgt (Rabsolu x) R1)
-        -> (b:R) (Ex [N:nat] ((n:nat) (ge n N) 
-                     -> (Rge (Rabsolu (pow x n)) b ))).
-Proof.
-Intros;Elim (archimed (Rmult b (Rinv (Rminus (Rabsolu x) R1))));Intros;
-  Clear H1;
-  Cut (Ex[N:nat] (Rge (INR N) (Rmult b (Rinv (Rminus (Rabsolu x) R1))))).
-Intro; Elim H1;Clear H1;Intros;Exists x0;Intros;
- Apply (Rge_trans (Rabsolu (pow x n)) (Rabsolu (pow x x0)) b).
-Apply Rle_sym1;Apply Power_monotonic;Assumption.
-Rewrite <- Pow_Rabsolu;Cut (Rabsolu x)==(Rplus R1 (Rminus (Rabsolu x) R1)).
-Intro; Rewrite H3;
- Apply (Rge_trans (pow (Rplus R1 (Rminus (Rabsolu x) R1)) x0)
-                 (Rplus R1 (Rmult (INR x0)  
-                                  (Rminus (Rabsolu x) R1)))
-                 b).
-Apply Rle_sym1;Apply poly;Fold (Rgt (Rminus (Rabsolu x) R1) R0);
- Apply Rgt_minus;Assumption.
-Apply (Rge_trans 
-         (Rplus R1 (Rmult (INR x0) (Rminus (Rabsolu x) R1)))
-         (Rmult (INR x0) (Rminus (Rabsolu x) R1))
-         b).
-Apply Rle_sym1; Apply Rlt_le;Rewrite (Rplus_sym R1 
-                   (Rmult (INR x0) (Rminus (Rabsolu x) R1)));
- Pattern 1 (Rmult (INR x0) (Rminus (Rabsolu x) R1));
- Rewrite <- (let (H1,H2) = (Rplus_ne 
-            (Rmult (INR x0) (Rminus (Rabsolu x) R1))) in
-         H1);
- Apply Rlt_compatibility;
- Apply Rlt_R0_R1.
-Cut b==(Rmult (Rmult b (Rinv (Rminus (Rabsolu x) R1)))
-              (Rminus (Rabsolu x) R1)).
-Intros; Rewrite H4;Apply Rge_monotony.
-Apply Rge_minus;Unfold Rge; Left; Assumption.
-Assumption.
-Rewrite Rmult_assoc;Rewrite Rinv_l.
-Ring.
-Apply imp_not_Req; Right;Apply Rgt_minus;Assumption.
-Ring.
-Cut `0<= (up (Rmult b (Rinv (Rminus (Rabsolu x) R1))))`\/
-     `(up (Rmult b (Rinv (Rminus (Rabsolu x) R1)))) <=  0`.
-Intros;Elim H1;Intro.
-Elim (IZN (up (Rmult b (Rinv (Rminus (Rabsolu x) R1)))) H2);Intros;Exists x0;
- Apply (Rge_trans 
-   (INR x0)
-   (IZR (up (Rmult b (Rinv (Rminus (Rabsolu x) R1)))))
-   (Rmult b (Rinv (Rminus (Rabsolu x) R1)))).
-Rewrite INR_IZR_INZ;Apply IZR_ge;Omega.
-Unfold Rge; Left; Assumption.
-Exists O;Apply (Rge_trans (INR (0))
-          (IZR (up (Rmult b (Rinv (Rminus (Rabsolu x) R1)))))
-          (Rmult b (Rinv (Rminus (Rabsolu x) R1)))).
-Rewrite INR_IZR_INZ;Apply IZR_ge;Simpl;Omega.
-Unfold Rge; Left; Assumption.
-Omega.
-Qed.
-
-Lemma pow_ne_zero:
-  (n:nat) ~(n=(0))-> (pow R0 n) == R0.
-Proof.
-Induction n.
-Simpl;Auto.
-Intros;Elim H;Reflexivity.
-Intros; Simpl;Apply Rmult_Ol.
-Qed.
-
-Lemma Rinv_pow:
-  (x:R) (n:nat) ~(x==R0) -> (Rinv (pow x n))==(pow (Rinv x) n).
-Proof.
-Intros; Elim n; Simpl.
-Apply Rinv_R1.
-Intro m;Intro;Rewrite Rinv_Rmult.
-Rewrite H0; Reflexivity;Assumption.
-Assumption.
-Apply pow_nonzero;Assumption.
-Qed.
-
-Lemma pow_lt_1_zero:
-  (x:R) (Rlt (Rabsolu x) R1)
-        -> (y:R) (Rlt R0 y) 
-                 -> (Ex[N:nat] (n:nat) (ge n N)
-                         -> (Rlt (Rabsolu (pow x n)) y)).
-Proof.
-Intros;Elim (Req_EM x R0);Intro. 
-Exists (1);Rewrite H1;Intros n GE;Rewrite pow_ne_zero.
-Rewrite Rabsolu_R0;Assumption.
-Inversion GE;Auto.
-Cut (Rgt (Rabsolu (Rinv x)) R1).
-Intros;Elim (Pow_x_infinity (Rinv x) H2 (Rplus (Rinv y) R1));Intros N.
-Exists N;Intros;Rewrite <- (Rinv_Rinv y).
-Rewrite <- (Rinv_Rinv (Rabsolu (pow x n))).
-Apply Rinv_lt.
-Apply Rmult_lt_pos.
-Apply Rlt_Rinv.
-Assumption.
-Apply Rlt_Rinv.
-Apply Rabsolu_pos_lt.
-Apply pow_nonzero.
-Assumption.
-Rewrite <- Rabsolu_Rinv.
-Rewrite Rinv_pow.
-Apply (Rlt_le_trans (Rinv y)
-                    (Rplus (Rinv y) R1)
-                    (Rabsolu (pow (Rinv x) n))).
-Pattern 1 (Rinv y).
-Rewrite <- (let (H1,H2) = 
-                (Rplus_ne (Rinv y)) in H1).
-Apply Rlt_compatibility.
-Apply Rlt_R0_R1.
-Apply Rle_sym2.
-Apply H3.
-Assumption.
-Assumption.
-Apply pow_nonzero.
-Assumption.
-Apply Rabsolu_no_R0.
-Apply pow_nonzero.
-Assumption.
-Apply imp_not_Req.
-Right; Unfold Rgt; Assumption.
-Rewrite <- (Rinv_Rinv R1).
-Rewrite Rabsolu_Rinv.
-Unfold Rgt; Apply Rinv_lt.
-Apply Rmult_lt_pos.
-Apply Rabsolu_pos_lt.
-Assumption.
-Rewrite Rinv_R1; Apply Rlt_R0_R1.
-Rewrite Rinv_R1; Assumption.
-Assumption.
-Red;Intro; Apply R1_neq_R0;Assumption.
-Qed.
-
-Lemma pow_R1:
- (r : R) (n : nat) (pow r n) == R1 ->  (Rabsolu r) == R1 \/ n = O.
-Proof.
-Intros r n H'.
-Case (Req_EM (Rabsolu r) R1); Auto; Intros H'1.
-Case (not_Req ? ? H'1); Intros H'2.
-Generalize H'; Case n; Auto.
-Intros n0 H'0.
-Cut ~ r == R0; [Intros Eq1 | Idtac].
-Cut ~ (Rabsolu r) == R0; [Intros Eq2 | Apply Rabsolu_no_R0]; Auto.
-Absurd (Rlt (pow (Rabsolu (Rinv r)) O) (pow (Rabsolu (Rinv r)) (S n0))); Auto.
-Replace (pow (Rabsolu (Rinv r)) (S n0)) with R1.
-Simpl; Apply Rlt_antirefl; Auto.
-Rewrite Rabsolu_Rinv; Auto.
-Rewrite <- Rinv_pow; Auto.
-Rewrite Pow_Rabsolu; Auto.
-Rewrite H'0; Rewrite Rabsolu_right; Auto with real.
-Apply Rle_ge; Auto with real.
-Apply Rlt_pow; Auto with arith.
-Rewrite Rabsolu_Rinv; Auto.
-Apply Rlt_monotony_contra with z := (Rabsolu r).
-Case (Rabsolu_pos r); Auto.
-Intros H'3; Case Eq2; Auto.
-Rewrite Rmult_1r; Rewrite Rinv_r; Auto with real.
-Red;Intro;Absurd ``(pow r (S n0)) == 1``;Auto.
-Simpl; Rewrite H; Rewrite Rmult_Ol; Auto with real.
-Generalize H'; Case n; Auto.
-Intros n0 H'0.
-Cut ~ r == R0; [Intros Eq1 | Auto with real].
-Cut ~ (Rabsolu r) == R0; [Intros Eq2 | Apply Rabsolu_no_R0]; Auto.
-Absurd (Rlt (pow (Rabsolu r) O) (pow (Rabsolu r) (S n0))); 
-  Auto with real arith.
-Repeat Rewrite Pow_Rabsolu; Rewrite H'0; Simpl; Auto with real.
-Red;Intro;Absurd ``(pow r (S n0)) == 1``;Auto.
-Simpl; Rewrite H; Rewrite Rmult_Ol; Auto with real.
-Qed.
-
-Lemma pow_Rsqr : (x:R;n:nat) (pow x (mult (2) n))==(pow (Rsqr x) n).
-Proof.
-Intros; Induction n.
-Reflexivity.
-Replace (mult (2) (S n)) with (S (S (mult (2) n))).
-Replace (pow x (S (S (mult (2) n)))) with ``x*x*(pow x (mult (S (S O)) n))``.
-Rewrite Hrecn; Reflexivity.
-Simpl; Ring.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Qed.
-
-Lemma pow_le : (a:R;n:nat) ``0<=a`` -> ``0<=(pow a n)``.
-Proof.
-Intros; Induction n.
-Simpl; Left; Apply Rlt_R0_R1.
-Simpl; Apply Rmult_le_pos; Assumption.
-Qed.
-
-(**********)
-Lemma pow_1_even : (n:nat) ``(pow (-1) (mult (S (S O)) n))==1``.
-Proof.
-Intro; Induction n.
-Reflexivity.
-Replace (mult (2) (S n)) with (plus (2) (mult (2) n)).
-Rewrite pow_add; Rewrite Hrecn; Simpl; Ring.
-Replace (S n) with (plus n (1)); [Ring | Ring].
-Qed.
-
-(**********)
-Lemma pow_1_odd : (n:nat) ``(pow (-1) (S (mult (S (S O)) n)))==-1``.
-Proof.
-Intro; Replace (S (mult (2) n)) with (plus (mult (2) n) (1)); [Idtac | Ring].
-Rewrite pow_add; Rewrite pow_1_even; Simpl; Ring.
-Qed.
-
-(**********)
-Lemma pow_1_abs : (n:nat) ``(Rabsolu (pow (-1) n))==1``.
-Proof.
-Intro; Induction n.
-Simpl; Apply Rabsolu_R1.
-Replace (S n) with (plus n (1)); [Rewrite pow_add | Ring].
-Rewrite Rabsolu_mult.
-Rewrite Hrecn; Rewrite Rmult_1l; Simpl; Rewrite Rmult_1r; Rewrite Rabsolu_Ropp; Apply Rabsolu_R1.
-Qed.
-
-Lemma pow_mult : (x:R;n1,n2:nat) (pow x (mult n1 n2))==(pow (pow x n1) n2).
-Proof.
-Intros; Induction n2.
-Simpl; Replace (mult n1 O) with O; [Reflexivity | Ring].
-Replace (mult n1 (S n2)) with (plus (mult n1 n2) n1).
-Replace (S n2) with (plus n2 (1)); [Idtac | Ring].
-Do 2 Rewrite pow_add.
-Rewrite Hrecn2.
-Simpl.
-Ring.
-Apply INR_eq; Rewrite plus_INR; Do 2 Rewrite mult_INR; Rewrite S_INR; Ring.
-Qed.
-
-Lemma pow_incr : (x,y:R;n:nat) ``0<=x<=y`` -> ``(pow x n)<=(pow y n)``.
-Proof.
-Intros.
-Induction n.
-Right; Reflexivity.
-Simpl.
-Elim H; Intros.
-Apply Rle_trans with ``y*(pow x n)``.
-Do 2 Rewrite <- (Rmult_sym (pow x n)).
-Apply Rle_monotony.
-Apply pow_le; Assumption.
-Assumption.
-Apply Rle_monotony.
-Apply Rle_trans with x; Assumption.
-Apply Hrecn.
-Qed.
-
-Lemma pow_R1_Rle : (x:R;k:nat) ``1<=x`` -> ``1<=(pow x k)``.
-Proof.
-Intros.
-Induction k.
-Right; Reflexivity.
-Simpl.
-Apply Rle_trans with ``x*1``.
-Rewrite Rmult_1r; Assumption.
-Apply Rle_monotony.
-Left; Apply Rlt_le_trans with R1; [Apply Rlt_R0_R1 | Assumption].
-Exact Hreck.
-Qed.
-
-Lemma Rle_pow : (x:R;m,n:nat) ``1<=x`` -> (le m n) -> ``(pow x m)<=(pow x n)``.
-Proof.
-Intros.
-Replace n with (plus (minus n m) m).
-Rewrite pow_add.
-Rewrite Rmult_sym.
-Pattern 1 (pow x m); Rewrite <- Rmult_1r.
-Apply Rle_monotony.
-Apply pow_le; Left; Apply Rlt_le_trans with R1; [Apply Rlt_R0_R1 | Assumption].
-Apply pow_R1_Rle; Assumption.
-Rewrite plus_sym.
-Symmetry; Apply le_plus_minus; Assumption.
-Qed.
-
-Lemma pow1 : (n:nat) (pow R1 n)==R1.
-Proof.
-Intro; Induction n.
-Reflexivity.
-Simpl; Rewrite Hrecn; Rewrite Rmult_1r; Reflexivity.
-Qed.
-
-Lemma pow_Rabs : (x:R;n:nat) ``(pow x n)<=(pow (Rabsolu x) n)``.
-Proof.
-Intros; Induction n.
-Right; Reflexivity.
-Simpl; Case (case_Rabsolu x); Intro.
-Apply Rle_trans with (Rabsolu ``x*(pow x n)``).
-Apply Rle_Rabsolu.
-Rewrite Rabsolu_mult.
-Apply Rle_monotony.
-Apply Rabsolu_pos.
-Right; Symmetry; Apply Pow_Rabsolu.
-Pattern 1 (Rabsolu x); Rewrite (Rabsolu_right x r); Apply Rle_monotony.
-Apply Rle_sym2; Exact r.
-Apply Hrecn.
-Qed.
-
-Lemma pow_maj_Rabs : (x,y:R;n:nat) ``(Rabsolu y)<=x`` -> ``(pow y n)<=(pow x n)``.
-Proof.
-Intros; Cut ``0<=x``.
-Intro; Apply Rle_trans with (pow (Rabsolu y) n).
-Apply pow_Rabs.
-Induction n.
-Right; Reflexivity.
-Simpl; Apply Rle_trans with ``x*(pow (Rabsolu y) n)``.
-Do 2 Rewrite <- (Rmult_sym (pow (Rabsolu y) n)).
-Apply Rle_monotony.
-Apply pow_le; Apply Rabsolu_pos.
-Assumption.
-Apply Rle_monotony.
-Apply H0.
-Apply Hrecn.
-Apply Rle_trans with (Rabsolu y); [Apply Rabsolu_pos | Exact H].
-Qed.
-
-(*******************************)
-(**         PowerRZ            *)
-(*******************************)
-(*i Due to L.Thery i*)
-
-Tactic Definition CaseEqk name :=
-Generalize (refl_equal ? name); Pattern -1 name; Case name.
-
-Definition powerRZ :=
-   [x : R] [n : Z]  Cases n of
-                      ZERO => R1
-                     | (POS p) => (pow x (convert p))
-                     | (NEG p) => (Rinv (pow x (convert p)))
-                    end.
-
-Infix Local "^Z" powerRZ (at level 2, left associativity) : R_scope.
-
-Lemma Zpower_NR0:
- (x : Z) (n : nat) (Zle ZERO x) ->  (Zle ZERO (Zpower_nat x n)).
-Proof.
-NewInduction n; Unfold Zpower_nat; Simpl; Auto with zarith.
-Qed.
-
-Lemma powerRZ_O: (x : R)  (powerRZ x ZERO) == R1.
-Proof.
-Reflexivity.
-Qed.
- 
-Lemma powerRZ_1: (x : R)  (powerRZ x (Zs ZERO)) == x.
-Proof.
-Simpl; Auto with real.
-Qed.
- 
-Lemma powerRZ_NOR: (x : R) (z : Z) ~ x == R0 ->  ~ (powerRZ x z) == R0.
-Proof.
-NewDestruct z; Simpl; Auto with real.
-Qed.
- 
-Lemma powerRZ_add:
- (x : R)
- (n, m : Z)
- ~ x == R0 ->  (powerRZ x (Zplus n m)) == (Rmult (powerRZ x n) (powerRZ x m)).
-Proof.
-Intro x; NewDestruct n as [|n1|n1]; NewDestruct m as [|m1|m1]; Simpl;
-  Auto with real.
-(* POS/POS *)
-Rewrite convert_add; Auto with real.
-(* POS/NEG *)
-(CaseEqk '(compare n1 m1 EGAL)); Simpl; Auto with real.
-Intros H' H'0; Rewrite compare_convert_EGAL with 1 := H'; Auto with real.
-Intros H' H'0; Rewrite (true_sub_convert m1 n1); Auto with real.
-Rewrite (pow_RN_plus x (minus (convert m1) (convert n1)) (convert n1));
- Auto with real.
-Rewrite plus_sym; Rewrite le_plus_minus_r; Auto with real.
-Rewrite Rinv_Rmult; Auto with real.
-Rewrite Rinv_Rinv; Auto with real.
-Apply lt_le_weak.
-Apply compare_convert_INFERIEUR; Auto.
-Apply ZC2; Auto.
-Intros H' H'0; Rewrite (true_sub_convert n1 m1); Auto with real.
-Rewrite (pow_RN_plus x (minus (convert n1) (convert m1)) (convert m1));
- Auto with real.
-Rewrite plus_sym; Rewrite le_plus_minus_r; Auto with real.
-Apply lt_le_weak.
-Change (gt (convert n1) (convert m1)).
-Apply compare_convert_SUPERIEUR; Auto.
-(* NEG/POS *)
-(CaseEqk '(compare n1 m1 EGAL)); Simpl; Auto with real.
-Intros H' H'0; Rewrite compare_convert_EGAL with 1 := H'; Auto with real.
-Intros H' H'0; Rewrite (true_sub_convert m1 n1); Auto with real.
-Rewrite (pow_RN_plus x (minus (convert m1) (convert n1)) (convert n1));
- Auto with real.
-Rewrite plus_sym; Rewrite le_plus_minus_r; Auto with real.
-Apply lt_le_weak.
-Apply compare_convert_INFERIEUR; Auto.
-Apply ZC2; Auto.
-Intros H' H'0; Rewrite (true_sub_convert n1 m1); Auto with real.
-Rewrite (pow_RN_plus x (minus (convert n1) (convert m1)) (convert m1));
- Auto with real.
-Rewrite plus_sym; Rewrite le_plus_minus_r; Auto with real.
-Rewrite Rinv_Rmult; Auto with real.
-Apply lt_le_weak.
-Change (gt (convert n1) (convert m1)).
-Apply compare_convert_SUPERIEUR; Auto.
-(* NEG/NEG *)
-Rewrite convert_add; Auto with real.
-Intros H'; Rewrite pow_add; Auto with real.
-Apply Rinv_Rmult; Auto.
-Apply pow_nonzero; Auto.
-Apply pow_nonzero; Auto.
-Qed.
-Hints Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add :real.
- 
-Lemma Zpower_nat_powerRZ:
- (n, m : nat)
-  (IZR (Zpower_nat (inject_nat n) m)) == (powerRZ (INR n) (inject_nat m)).
-Proof.
-Intros n m; Elim m; Simpl; Auto with real.
-Intros m1 H'; Rewrite bij1; Simpl.
-Replace (Zpower_nat (inject_nat n) (S m1))
-     with (Zmult (inject_nat n) (Zpower_nat (inject_nat n) m1)).
-Rewrite mult_IZR; Auto with real.
-Repeat Rewrite <- INR_IZR_INZ; Simpl.
-Rewrite H'; Simpl.
-Case m1; Simpl; Auto with real.
-Intros m2; Rewrite bij1; Auto.
-Unfold Zpower_nat; Auto.
-Qed.
- 
-Lemma powerRZ_lt: (x : R) (z : Z) (Rlt R0 x) ->  (Rlt R0 (powerRZ x z)).
-Proof.
-Intros x z; Case z; Simpl; Auto with real.
-Qed.
-Hints Resolve powerRZ_lt :real.
- 
-Lemma powerRZ_le: (x : R) (z : Z) (Rlt R0 x) ->  (Rle R0 (powerRZ x z)).
-Proof.
-Intros x z H'; Apply Rlt_le; Auto with real.
-Qed.
-Hints Resolve powerRZ_le :real.
- 
-Lemma Zpower_nat_powerRZ_absolu:
- (n, m : Z)
- (Zle ZERO m) ->  (IZR (Zpower_nat n (absolu m))) == (powerRZ (IZR n) m).
-Proof.
-Intros n m; Case m; Simpl; Auto with zarith.
-Intros p H'; Elim (convert p); Simpl; Auto with zarith.
-Intros n0 H'0; Rewrite <- H'0; Simpl; Auto with zarith.
-Rewrite <- mult_IZR; Auto.
-Intros p H'; Absurd `0 <= (NEG p)`;Auto with zarith.
-Qed.
-
-Lemma powerRZ_R1: (n : Z)  (powerRZ R1 n) == R1.
-Proof.
-Intros n; Case n; Simpl; Auto.
-Intros p; Elim (convert p); Simpl; Auto; Intros n0 H'; Rewrite H'; Ring.
-Intros p; Elim (convert p); Simpl.
-Exact Rinv_R1.
-Intros n1 H'; Rewrite Rinv_Rmult; Try Rewrite Rinv_R1; Try Rewrite H';
- Auto with real.
-Qed.
-
-(*******************************)
-(** Sum of n first naturals    *)
-(*******************************)
-(*********)
-Fixpoint sum_nat_f_O [f:nat->nat;n:nat]:nat:=       
-  Cases n of                            
-    O => (f O)                               
-   |(S n') => (plus (sum_nat_f_O f n') (f (S n'))) 
-  end.
-
-(*********)
-Definition sum_nat_f [s,n:nat;f:nat->nat]:nat:=      
-  (sum_nat_f_O [x:nat](f (plus x s)) (minus n s)).
-
-(*********)
-Definition sum_nat_O [n:nat]:nat:=
-  (sum_nat_f_O [x:nat]x n).
-
-(*********)
-Definition sum_nat [s,n:nat]:nat:=
-  (sum_nat_f s n [x:nat]x).
-
-(*******************************)
-(**            Sum             *)
-(*******************************)
-(*********)
-Fixpoint sum_f_R0 [f:nat->R;N:nat]:R:=
-  Cases N of
-     O     => (f O)
-    |(S i) => (Rplus (sum_f_R0 f i) (f (S i)))
-  end.
-
-(*********)
-Definition sum_f [s,n:nat;f:nat->R]:R:=      
-  (sum_f_R0 [x:nat](f (plus x s)) (minus n s)).
-
-Lemma GP_finite:
-  (x:R) (n:nat) (Rmult (sum_f_R0 [n:nat] (pow x n) n)
-                       (Rminus x R1)) ==
-                (Rminus (pow x (plus n (1))) R1).
-Proof.
-Intros; Induction n; Simpl.
-Ring.
-Rewrite Rmult_Rplus_distrl;Rewrite Hrecn;Cut (plus n (1))=(S n).
-Intro H;Rewrite H;Simpl;Ring.
-Omega.
-Qed.
-
-Lemma sum_f_R0_triangle:
-  (x:nat->R)(n:nat) (Rle (Rabsolu (sum_f_R0 x n))
-                         (sum_f_R0 [i:nat] (Rabsolu (x i)) n)).
-Proof.
-Intro; Induction n; Simpl.
-Unfold Rle; Right; Reflexivity.
-Intro m; Intro;Apply (Rle_trans
-          (Rabsolu (Rplus (sum_f_R0 x m) (x (S m))))
-          (Rplus (Rabsolu (sum_f_R0 x m))
-                 (Rabsolu (x (S m))))
-          (Rplus (sum_f_R0 [i:nat](Rabsolu (x i)) m) 
-                 (Rabsolu (x (S m))))).
-Apply Rabsolu_triang.
-Rewrite Rplus_sym;Rewrite (Rplus_sym 
-  (sum_f_R0 [i:nat](Rabsolu (x i)) m) (Rabsolu (x (S m))));
-  Apply Rle_compatibility;Assumption.
-Qed.
-
-(*******************************)
-(*        Distance  in R       *)
-(*******************************)
-
-(*********)
-Definition R_dist:R->R->R:=[x,y:R](Rabsolu (Rminus x y)).
-
-(*********)
-Lemma R_dist_pos:(x,y:R)(Rge (R_dist x y) R0).
-Proof.
-Intros;Unfold R_dist;Unfold Rabsolu;Case (case_Rabsolu (Rminus x y));Intro l.
-Unfold Rge;Left;Apply (Rlt_RoppO (Rminus x y) l).
-Trivial.
-Qed.
-
-(*********)
-Lemma R_dist_sym:(x,y:R)(R_dist x y)==(R_dist y x).
-Proof.
-Unfold R_dist;Intros;SplitAbsolu;Ring.
-Generalize (Rlt_RoppO (Rminus y x) r); Intro;
- Rewrite (Ropp_distr2 y x) in H;
- Generalize (Rlt_antisym (Rminus x y) R0 r0); Intro;Unfold Rgt in H;
- ElimType False; Auto.
-Generalize (minus_Rge y x r); Intro;
- Generalize (minus_Rge x y r0); Intro;
- Generalize (Rge_ge_eq x y H0 H); Intro;Rewrite H1;Ring.
-Qed.
-
-(*********)
-Lemma R_dist_refl:(x,y:R)((R_dist x y)==R0<->x==y).
-Proof.
-Unfold R_dist;Intros;SplitAbsolu;Split;Intros.
-Rewrite (Ropp_distr2 x y) in H;Apply sym_eqT;
- Apply (Rminus_eq y x H).
-Rewrite (Ropp_distr2 x y);Generalize (sym_eqT R x y H);Intro;
- Apply (eq_Rminus y x H0).
-Apply (Rminus_eq x y H).
-Apply (eq_Rminus x y H). 
-Qed.
-
-Lemma R_dist_eq:(x:R)(R_dist x x)==R0.
-Proof.
-Unfold R_dist;Intros;SplitAbsolu;Intros;Ring.
-Qed.
-
-(***********)
-Lemma R_dist_tri:(x,y,z:R)(Rle (R_dist x y) 
-                   (Rplus (R_dist x z) (R_dist z y))).
-Proof.
-Intros;Unfold R_dist; Replace ``x-y`` with ``(x-z)+(z-y)``;
-  [Apply (Rabsolu_triang ``x-z`` ``z-y``)|Ring].
-Qed.
-
-(*********)
-Lemma R_dist_plus: (a,b,c,d:R)(Rle (R_dist (Rplus a c) (Rplus b d))
-                   (Rplus (R_dist a b) (R_dist c d))).
-Proof.
-Intros;Unfold R_dist;
- Replace (Rminus (Rplus a c) (Rplus b d))
-  with (Rplus (Rminus a b) (Rminus c d)).
-Exact (Rabsolu_triang (Rminus a b) (Rminus c d)).
-Ring.
-Qed.
-
-(*******************************)
-(**       Infinit Sum          *)
-(*******************************)
-(*********)
-Definition infinit_sum:(nat->R)->R->Prop:=[s:nat->R;l:R]
-  (eps:R)(Rgt eps R0)->
-  (Ex[N:nat](n:nat)(ge n N)->(Rlt (R_dist (sum_f_R0 s n) l) eps)).
diff --git a/theories7/Reals/Rgeom.v b/theories7/Reals/Rgeom.v
deleted file mode 100644
index 12c52e37..00000000
--- a/theories7/Reals/Rgeom.v
+++ /dev/null
@@ -1,84 +0,0 @@
-(************************************************************************)
-(*  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: Rgeom.v,v 1.1.2.1 2004/07/16 19:31:34 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo.
-Require R_sqrt.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Definition dist_euc [x0,y0,x1,y1:R] : R := ``(sqrt ((Rsqr (x0-x1))+(Rsqr (y0-y1))))``.
-
-Lemma distance_refl : (x0,y0:R) ``(dist_euc x0 y0 x0 y0)==0``.
-Intros x0 y0; Unfold dist_euc; Apply Rsqr_inj; [Apply sqrt_positivity; Apply ge0_plus_ge0_is_ge0; [Apply pos_Rsqr | Apply pos_Rsqr] | Right; Reflexivity | Rewrite Rsqr_O; Rewrite Rsqr_sqrt; [Unfold Rsqr; Ring | Apply ge0_plus_ge0_is_ge0; [Apply pos_Rsqr | Apply pos_Rsqr]]].
-Qed.
-
-Lemma distance_symm : (x0,y0,x1,y1:R) ``(dist_euc x0 y0 x1 y1) == (dist_euc x1 y1 x0 y0)``. 
-Intros x0 y0 x1 y1; Unfold dist_euc; Apply Rsqr_inj; [ Apply sqrt_positivity; Apply ge0_plus_ge0_is_ge0 | Apply sqrt_positivity; Apply ge0_plus_ge0_is_ge0 | Repeat Rewrite Rsqr_sqrt; [Unfold Rsqr; Ring | Apply ge0_plus_ge0_is_ge0 |Apply ge0_plus_ge0_is_ge0]]; Apply pos_Rsqr.
-Qed.
-
-Lemma law_cosines : (x0,y0,x1,y1,x2,y2,ac:R) let a = (dist_euc x1 y1 x0 y0) in let b=(dist_euc x2 y2 x0 y0) in let c=(dist_euc x2 y2 x1 y1) in ( ``a*c*(cos ac) == ((x0-x1)*(x2-x1) + (y0-y1)*(y2-y1))`` -> ``(Rsqr b)==(Rsqr c)+(Rsqr a)-2*(a*c*(cos ac))`` ).
-Unfold dist_euc; Intros; Repeat Rewrite -> Rsqr_sqrt; [ Rewrite H; Unfold Rsqr; Ring | Apply ge0_plus_ge0_is_ge0 | Apply ge0_plus_ge0_is_ge0 | Apply ge0_plus_ge0_is_ge0]; Apply pos_Rsqr.
-Qed.
-
-Lemma triangle : (x0,y0,x1,y1,x2,y2:R) ``(dist_euc x0 y0 x1 y1)<=(dist_euc x0 y0 x2 y2)+(dist_euc x2 y2 x1 y1)``.
-Intros; Unfold dist_euc; Apply Rsqr_incr_0; [Rewrite Rsqr_plus; Repeat Rewrite Rsqr_sqrt; [Replace ``(Rsqr (x0-x1))`` with ``(Rsqr (x0-x2))+(Rsqr (x2-x1))+2*(x0-x2)*(x2-x1)``; [Replace ``(Rsqr (y0-y1))`` with ``(Rsqr (y0-y2))+(Rsqr (y2-y1))+2*(y0-y2)*(y2-y1)``; [Apply Rle_anti_compatibility with ``-(Rsqr (x0-x2))-(Rsqr (x2-x1))-(Rsqr (y0-y2))-(Rsqr (y2-y1))``; Replace `` -(Rsqr (x0-x2))-(Rsqr (x2-x1))-(Rsqr (y0-y2))-(Rsqr (y2-y1))+((Rsqr (x0-x2))+(Rsqr (x2-x1))+2*(x0-x2)*(x2-x1)+((Rsqr (y0-y2))+(Rsqr (y2-y1))+2*(y0-y2)*(y2-y1)))`` with ``2*((x0-x2)*(x2-x1)+(y0-y2)*(y2-y1))``; [Replace ``-(Rsqr (x0-x2))-(Rsqr (x2-x1))-(Rsqr (y0-y2))-(Rsqr (y2-y1))+((Rsqr (x0-x2))+(Rsqr (y0-y2))+((Rsqr (x2-x1))+(Rsqr (y2-y1)))+2*(sqrt ((Rsqr (x0-x2))+(Rsqr (y0-y2))))*(sqrt ((Rsqr (x2-x1))+(Rsqr (y2-y1)))))`` with ``2*((sqrt ((Rsqr (x0-x2))+(Rsqr (y0-y2))))*(sqrt ((Rsqr (x2-x1))+(Rsqr (y2-y1)))))``; [Apply Rle_monotony; [Left; Cut ~(O=(2)); [Intros; Generalize (lt_INR_0 (2) (neq_O_lt (2) H)); Intro H0; Assumption | Discriminate] | Apply sqrt_cauchy] | Ring] | Ring] | SqRing] | SqRing] | Apply ge0_plus_ge0_is_ge0; Apply pos_Rsqr | Apply ge0_plus_ge0_is_ge0; Apply pos_Rsqr | Apply ge0_plus_ge0_is_ge0; Apply pos_Rsqr] | Apply sqrt_positivity; Apply ge0_plus_ge0_is_ge0; Apply pos_Rsqr | Apply ge0_plus_ge0_is_ge0; Apply sqrt_positivity; Apply ge0_plus_ge0_is_ge0; Apply pos_Rsqr].
-Qed.
-
-(******************************************************************)
-(**                         Translation                           *)
-(******************************************************************)
-
-Definition xt[x,tx:R] : R := ``x+tx``.
-Definition yt[y,ty:R] : R := ``y+ty``.
-
-Lemma translation_0 : (x,y:R) ``(xt x 0)==x``/\``(yt y 0)==y``.
-Intros x y; Split; [Unfold xt | Unfold yt]; Ring.
-Qed.
-
-Lemma isometric_translation : (x1,x2,y1,y2,tx,ty:R) ``(Rsqr (x1-x2))+(Rsqr (y1-y2))==(Rsqr ((xt x1 tx)-(xt x2 tx)))+(Rsqr ((yt y1 ty)-(yt y2 ty)))``.
-Intros; Unfold Rsqr xt yt; Ring.
-Qed.
-
-(******************************************************************)
-(**                           Rotation                            *)
-(******************************************************************)
-
-Definition xr [x,y,theta:R] : R := ``x*(cos theta)+y*(sin theta)``.
-Definition yr [x,y,theta:R] : R := ``-x*(sin theta)+y*(cos theta)``.
-
-Lemma rotation_0 : (x,y:R) ``(xr x y 0)==x`` /\ ``(yr x y 0)==y``.
-Intros x y; Unfold xr yr; Split; Rewrite cos_0; Rewrite sin_0; Ring.
-Qed.
-
-Lemma rotation_PI2 : (x,y:R) ``(xr x y PI/2)==y`` /\ ``(yr x y PI/2)==-x``.
-Intros  x y; Unfold xr yr; Split; Rewrite cos_PI2; Rewrite sin_PI2; Ring.
-Qed.
-
-Lemma isometric_rotation_0 : (x1,y1,x2,y2,theta:R) ``(Rsqr (x1-x2))+(Rsqr (y1-y2)) == (Rsqr ((xr x1 y1 theta))-(xr x2 y2 theta)) + (Rsqr ((yr x1 y1 theta))-(yr x2 y2 theta))``.
-Intros; Unfold xr yr; Replace ``x1*(cos theta)+y1*(sin theta)-(x2*(cos theta)+y2*(sin theta))`` with ``(cos theta)*(x1-x2)+(sin theta)*(y1-y2)``; [Replace ``-x1*(sin theta)+y1*(cos theta)-( -x2*(sin theta)+y2*(cos theta))`` with ``(cos theta)*(y1-y2)+(sin theta)*(x2-x1)``; [Repeat Rewrite Rsqr_plus; Repeat Rewrite Rsqr_times; Repeat Rewrite cos2; Ring; Replace ``x2-x1`` with ``-(x1-x2)``; [Rewrite <- Rsqr_neg; Ring | Ring] |Ring] | Ring].
-Qed.
-
-Lemma isometric_rotation : (x1,y1,x2,y2,theta:R) ``(dist_euc x1 y1 x2 y2) == (dist_euc (xr x1 y1 theta) (yr x1 y1 theta) (xr x2 y2 theta) (yr x2 y2 theta))``.
-Unfold dist_euc; Intros; Apply Rsqr_inj; [Apply sqrt_positivity; Apply ge0_plus_ge0_is_ge0 | Apply sqrt_positivity; Apply ge0_plus_ge0_is_ge0 | Repeat Rewrite Rsqr_sqrt; [ Apply isometric_rotation_0 | Apply ge0_plus_ge0_is_ge0 | Apply ge0_plus_ge0_is_ge0]]; Apply pos_Rsqr.
-Qed.
-
-(******************************************************************)
-(**                         Similarity                            *)
-(******************************************************************)
-
-Lemma isometric_rot_trans : (x1,y1,x2,y2,tx,ty,theta:R) ``(Rsqr (x1-x2))+(Rsqr (y1-y2)) == (Rsqr ((xr (xt x1 tx) (yt y1 ty) theta)-(xr (xt x2 tx) (yt y2 ty) theta))) + (Rsqr ((yr (xt x1 tx) (yt y1 ty) theta)-(yr (xt x2 tx) (yt y2 ty) theta)))``. 
-Intros; Rewrite <- isometric_rotation_0; Apply isometric_translation.
-Qed.
-
-Lemma isometric_trans_rot : (x1,y1,x2,y2,tx,ty,theta:R) ``(Rsqr (x1-x2))+(Rsqr (y1-y2)) == (Rsqr ((xt (xr x1 y1 theta) tx)-(xt (xr x2 y2 theta) tx))) + (Rsqr ((yt (yr x1 y1 theta) ty)-(yt (yr x2 y2 theta) ty)))``. 
-Intros; Rewrite <- isometric_translation; Apply isometric_rotation_0.
-Qed.
diff --git a/theories7/Reals/RiemannInt.v b/theories7/Reals/RiemannInt.v
deleted file mode 100644
index cc537c6d..00000000
--- a/theories7/Reals/RiemannInt.v
+++ /dev/null
@@ -1,1699 +0,0 @@
-(************************************************************************)
-(*  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: RiemannInt.v,v 1.1.2.2 2005/07/13 23:19:16 herbelin Exp $ i*)
-
-Require Rfunctions.
-Require SeqSeries.
-Require Ranalysis.
-Require Rbase.
-Require RiemannInt_SF.
-Require Classical_Prop.
-Require Classical_Pred_Type.
-Require Max.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Implicit Arguments On.
-
-(********************************************)
-(*            Riemann's Integral            *)
-(********************************************)
-
-Definition Riemann_integrable [f:R->R;a,b:R] : Type := (eps:posreal) (SigT ? [phi:(StepFun a b)](SigT ? [psi:(StepFun a b)]((t:R)``(Rmin a b)<=t<=(Rmax a b)``->``(Rabsolu ((f t)-(phi t)))<=(psi t)``)/\``(Rabsolu (RiemannInt_SF psi))<eps``)).
-
-Definition phi_sequence [un:nat->posreal;f:R->R;a,b:R;pr:(Riemann_integrable f a b)] := [n:nat](projT1 ? ? (pr (un n))).
-
-Lemma phi_sequence_prop : (un:nat->posreal;f:R->R;a,b:R;pr:(Riemann_integrable f a b);N:nat) (SigT ? [psi:(StepFun a b)]((t:R)``(Rmin a b)<=t<=(Rmax a b)``->``(Rabsolu ((f t)-[(phi_sequence un pr N t)]))<=(psi t)``)/\``(Rabsolu (RiemannInt_SF psi))<(un N)``).
-Intros; Apply (projT2 ? ? (pr (un N))).
-Qed.
-
-Lemma RiemannInt_P1 : (f:R->R;a,b:R) (Riemann_integrable f a b) -> (Riemann_integrable f b a).
-Unfold Riemann_integrable; Intros; Elim (X eps); Clear X; Intros; Elim p; Clear p; Intros; Apply Specif.existT with (mkStepFun (StepFun_P6 (pre x))); Apply Specif.existT with (mkStepFun (StepFun_P6 (pre x0))); Elim p; Clear p; Intros; Split.
-Intros; Apply (H t); Elim H1; Clear H1; Intros; Split; [Apply Rle_trans with (Rmin b a); Try Assumption; Right; Unfold Rmin | Apply Rle_trans with (Rmax b a); Try Assumption; Right; Unfold Rmax]; (Case (total_order_Rle a b); Case (total_order_Rle b a); Intros; Try Reflexivity Orelse Apply Rle_antisym; [Assumption | Assumption | Auto with real | Auto with real]).
-Generalize H0; Unfold RiemannInt_SF; Case (total_order_Rle a b); Case (total_order_Rle b a); Intros; (Replace (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre x0)))) (subdivision (mkStepFun (StepFun_P6 (pre x0))))) with (Int_SF (subdivision_val x0) (subdivision x0)); [Idtac | Apply StepFun_P17 with (fe x0) a b; [Apply StepFun_P1 | Apply StepFun_P2; Apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre x0))))]]).
-Apply H1.
-Rewrite Rabsolu_Ropp; Apply H1.
-Rewrite Rabsolu_Ropp in H1; Apply H1.
-Apply H1.
-Qed.
-
-Lemma RiemannInt_P2 : (f:R->R;a,b:R;un:nat->posreal;vn,wn:nat->(StepFun a b)) (Un_cv un R0) -> ``a<=b`` -> ((n:nat)((t:R)``(Rmin a b)<=t<=(Rmax a b)``->``(Rabsolu ((f t)-(vn n t)))<=(wn n t)``)/\``(Rabsolu (RiemannInt_SF (wn n)))<(un n)``) -> (sigTT ? [l:R](Un_cv [N:nat](RiemannInt_SF (vn N)) l)).
-Intros; Apply R_complete; Unfold Un_cv in H; Unfold Cauchy_crit; Intros; Assert H3 : ``0<eps/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H ? H3); Intros N0 H4; Exists N0; Intros; Unfold R_dist; Unfold R_dist in H4; Elim (H1 n); Elim (H1 m); Intros; Replace ``(RiemannInt_SF (vn n))-(RiemannInt_SF (vn m))`` with ``(RiemannInt_SF (vn n))+(-1)*(RiemannInt_SF (vn m))``; [Idtac | Ring]; Rewrite <- StepFun_P30; Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 ``-1`` (vn n) (vn m)))))).
-Apply StepFun_P34; Assumption.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P28 R1 (wn n) (wn m)))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Apply Rle_trans with ``(Rabsolu ((vn n x)-(f x)))+(Rabsolu ((f x)-(vn m x)))``.
-Replace ``(vn n x)+-1*(vn m x)`` with ``((vn n x)-(f x))+((f x)-(vn m x))``; [Apply Rabsolu_triang | Ring].
-Assert H12 : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Assert H13 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Rewrite <- H12 in H11; Pattern 2 b in H11; Rewrite <- H13 in H11; Rewrite Rmult_1l; Apply Rplus_le.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H9.
-Elim H11; Intros; Split; Left; Assumption.
-Apply H7.
-Elim H11; Intros; Split; Left; Assumption.
-Rewrite StepFun_P30; Rewrite Rmult_1l; Apply Rlt_trans with ``(un n)+(un m)``.
-Apply Rle_lt_trans with ``(Rabsolu (RiemannInt_SF (wn n)))+(Rabsolu (RiemannInt_SF (wn m)))``.
-Apply Rplus_le; Apply Rle_Rabsolu.
-Apply Rplus_lt; Assumption.
-Apply Rle_lt_trans with ``(Rabsolu (un n))+(Rabsolu (un m))``.
-Apply Rplus_le; Apply Rle_Rabsolu.
-Replace (pos (un n)) with ``(un n)-0``; [Idtac | Ring]; Replace (pos (un m)) with ``(un m)-0``; [Idtac | Ring]; Rewrite (double_var eps); Apply Rplus_lt; Apply H4; Assumption.
-Qed.
-
-Lemma RiemannInt_P3 : (f:R->R;a,b:R;un:nat->posreal;vn,wn:nat->(StepFun a b)) (Un_cv un R0) -> ((n:nat)((t:R)``(Rmin a b)<=t<=(Rmax a b)``->``(Rabsolu ((f t)-(vn n t)))<=(wn n t)``)/\``(Rabsolu (RiemannInt_SF (wn n)))<(un n)``)->(sigTT R ([l:R](Un_cv ([N:nat](RiemannInt_SF (vn N))) l))).
-Intros; Case (total_order_Rle a b); Intro.
-Apply RiemannInt_P2 with f un wn; Assumption.
-Assert H1 : ``b<=a``; Auto with real.
-Pose vn' := [n:nat](mkStepFun (StepFun_P6 (pre (vn n)))); Pose wn' := [n:nat](mkStepFun (StepFun_P6 (pre (wn n)))); Assert H2 : (n:nat)((t:R)``(Rmin b a)<=t<=(Rmax b a)``->``(Rabsolu ((f t)-(vn' n t)))<=(wn' n t)``)/\``(Rabsolu (RiemannInt_SF (wn' n)))<(un n)``.
-Intro; Elim (H0 n0); Intros; Split.
-Intros; Apply (H2 t); Elim H4; Clear H4; Intros; Split; [Apply Rle_trans with (Rmin b a); Try Assumption; Right; Unfold Rmin | Apply Rle_trans with (Rmax b a); Try Assumption; Right; Unfold Rmax]; (Case (total_order_Rle a b); Case (total_order_Rle b a); Intros; Try Reflexivity Orelse Apply Rle_antisym; [Assumption | Assumption | Auto with real | Auto with real]).
-Generalize H3; Unfold RiemannInt_SF; Case (total_order_Rle a b); Case (total_order_Rle b a); Unfold wn'; Intros; (Replace (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (wn n0))))) (subdivision (mkStepFun (StepFun_P6 (pre (wn n0)))))) with (Int_SF (subdivision_val (wn n0)) (subdivision (wn n0))); [Idtac | Apply StepFun_P17 with (fe (wn n0)) a b; [Apply StepFun_P1 | Apply StepFun_P2; Apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (wn n0)))))]]).
-Apply H4.
-Rewrite Rabsolu_Ropp; Apply H4.
-Rewrite Rabsolu_Ropp in H4; Apply H4.
-Apply H4.
-Assert H3 := (RiemannInt_P2 H H1 H2); Elim H3; Intros; Apply existTT with ``-x``; Unfold Un_cv; Unfold Un_cv in p; Intros; Elim (p ? H4); Intros; Exists x0; Intros; Generalize (H5 ? H6); Unfold R_dist RiemannInt_SF; Case (total_order_Rle b a); Case (total_order_Rle a b); Intros.
-Elim n; Assumption.
-Unfold vn' in H7; Replace (Int_SF (subdivision_val (vn n0)) (subdivision (vn n0))) with (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0))))) (subdivision (mkStepFun (StepFun_P6 (pre (vn n0)))))); [Unfold Rminus; Rewrite Ropp_Ropp; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr1; Rewrite Ropp_Ropp; Apply H7 | Symmetry; Apply StepFun_P17 with (fe (vn n0)) a b; [Apply StepFun_P1 | Apply StepFun_P2; Apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n0)))))]].
-Elim n1; Assumption.
-Elim n2; Assumption.
-Qed.
-
-Lemma RiemannInt_exists : (f:R->R;a,b:R;pr:(Riemann_integrable f a b);un:nat->posreal) (Un_cv un R0) -> (sigTT ? [l:R](Un_cv [N:nat](RiemannInt_SF (phi_sequence un pr N)) l)).
-Intros f; Intros; Apply RiemannInt_P3 with f un [n:nat](projT1 ? ? (phi_sequence_prop un pr n)); [Apply H | Intro; Apply (projT2 ? ? (phi_sequence_prop un pr n))].
-Qed.
-
-Lemma RiemannInt_P4 : (f:R->R;a,b,l:R;pr1,pr2:(Riemann_integrable f a b);un,vn:nat->posreal) (Un_cv un R0) -> (Un_cv vn R0) -> (Un_cv [N:nat](RiemannInt_SF (phi_sequence un pr1 N)) l) -> (Un_cv [N:nat](RiemannInt_SF (phi_sequence vn pr2 N)) l).
-Unfold Un_cv; Unfold R_dist; Intros f; Intros; Assert H3 : ``0<eps/3``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H ? H3); Clear H; Intros N0 H; Elim (H0 ? H3); Clear H0; Intros N1 H0; Elim (H1 ? H3); Clear H1; Intros N2 H1; Pose N := (max (max N0 N1) N2); Exists N; Intros; Apply Rle_lt_trans with ``(Rabsolu ((RiemannInt_SF [(phi_sequence vn pr2 n)])-(RiemannInt_SF [(phi_sequence un pr1 n)])))+(Rabsolu ((RiemannInt_SF [(phi_sequence un pr1 n)])-l))``.
-Replace ``(RiemannInt_SF [(phi_sequence vn pr2 n)])-l`` with ``((RiemannInt_SF [(phi_sequence vn pr2 n)])-(RiemannInt_SF [(phi_sequence un pr1 n)]))+((RiemannInt_SF [(phi_sequence un pr1 n)])-l)``; [Apply Rabsolu_triang | Ring].
-Replace ``eps`` with ``2*eps/3+eps/3``.
-Apply Rplus_lt.
-Elim (phi_sequence_prop vn pr2 n); Intros psi_vn H5; Elim (phi_sequence_prop un pr1 n); Intros psi_un H6; Replace ``(RiemannInt_SF [(phi_sequence vn pr2 n)])-(RiemannInt_SF [(phi_sequence un pr1 n)])`` with ``(RiemannInt_SF [(phi_sequence vn pr2 n)])+(-1)*(RiemannInt_SF [(phi_sequence un pr1 n)])``; [Idtac | Ring]; Rewrite <- StepFun_P30.
-Case (total_order_Rle a b); Intro.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 ``-1`` (phi_sequence vn pr2 n) (phi_sequence un pr1 n)))))).
-Apply StepFun_P34; Assumption.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P28 R1 psi_un psi_vn))).
-Apply StepFun_P37; Try Assumption; Intros; Simpl; Rewrite Rmult_1l; Apply Rle_trans with ``(Rabsolu ([(phi_sequence vn pr2 n x)]-(f x)))+(Rabsolu ((f x)-[(phi_sequence un pr1 n x)]))``.
-Replace ``[(phi_sequence vn pr2 n x)]+-1*[(phi_sequence un pr1 n x)]`` with ``([(phi_sequence vn pr2 n x)]-(f x))+((f x)-[(phi_sequence un pr1 n x)])``; [Apply Rabsolu_triang | Ring].
-Assert H10 : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Assert H11 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Rewrite (Rplus_sym (psi_un x)); Apply Rplus_le.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Elim H5; Intros; Apply H8.
-Rewrite H10; Rewrite H11; Elim H7; Intros; Split; Left; Assumption.
-Elim H6; Intros; Apply H8.
-Rewrite H10; Rewrite H11; Elim H7; Intros; Split; Left; Assumption.
-Rewrite StepFun_P30; Rewrite Rmult_1l; Rewrite double; Apply Rplus_lt.
-Apply Rlt_trans with (pos (un n)).
-Elim H6; Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF psi_un)).
-Apply Rle_Rabsolu.
-Assumption.
-Replace (pos (un n)) with (Rabsolu ``(un n)-0``); [Apply H; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_trans with (max N0 N1); Apply le_max_l | Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Apply Rle_sym1; Left; Apply (cond_pos (un n))].
-Apply Rlt_trans with (pos (vn n)).
-Elim H5; Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF psi_vn)).
-Apply Rle_Rabsolu; Assumption.
-Assumption.
-Replace (pos (vn n)) with (Rabsolu ``(vn n)-0``); [Apply H0; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_trans with (max N0 N1); [Apply le_max_r | Apply le_max_l] | Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Apply Rle_sym1; Left; Apply (cond_pos (vn n))].
-Rewrite StepFun_P39; Rewrite Rabsolu_Ropp; Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 ``-1`` (phi_sequence vn pr2 n) (phi_sequence un pr1 n))))))))).
-Apply StepFun_P34; Try Auto with real.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 R1 psi_vn psi_un)))))).
-Apply StepFun_P37.
-Auto with real.
-Intros; Simpl; Rewrite Rmult_1l; Apply Rle_trans with ``(Rabsolu ([(phi_sequence vn pr2 n x)]-(f x)))+(Rabsolu ((f x)-[(phi_sequence un pr1 n x)]))``.
-Replace ``[(phi_sequence vn pr2 n x)]+-1*[(phi_sequence un pr1 n x)]`` with ``([(phi_sequence vn pr2 n x)]-(f x))+((f x)-[(phi_sequence un pr1 n x)])``; [Apply Rabsolu_triang | Ring].
-Assert H10 : (Rmin a b)==b.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Elim n0; Assumption | Reflexivity].
-Assert H11 : (Rmax a b)==a.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Elim n0; Assumption | Reflexivity].
-Apply Rplus_le.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Elim H5; Intros; Apply H8.
-Rewrite H10; Rewrite H11; Elim H7; Intros; Split; Left; Assumption.
-Elim H6; Intros; Apply H8.
-Rewrite H10; Rewrite H11; Elim H7; Intros; Split; Left; Assumption.
-Rewrite <- (Ropp_Ropp (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 R1 psi_vn psi_un))))))); Rewrite <- StepFun_P39; Rewrite StepFun_P30; Rewrite Rmult_1l; Rewrite double; Rewrite Ropp_distr1; Apply Rplus_lt.
-Apply Rlt_trans with (pos (vn n)).
-Elim H5; Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF psi_vn)).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Assumption.
-Replace (pos (vn n)) with (Rabsolu ``(vn n)-0``); [Apply H0; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_trans with (max N0 N1); [Apply le_max_r | Apply le_max_l] | Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Apply Rle_sym1; Left; Apply (cond_pos (vn n))].
-Apply Rlt_trans with (pos (un n)).
-Elim H6; Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF psi_un)).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu; Assumption.
-Assumption.
-Replace (pos (un n)) with (Rabsolu ``(un n)-0``); [Apply H; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_trans with (max N0 N1); Apply le_max_l | Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Apply Rle_sym1; Left; Apply (cond_pos (un n))].
-Apply H1; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_max_r.
-Apply r_Rmult_mult with ``3``; [Unfold Rdiv; Rewrite Rmult_Rplus_distr; Do 2 Rewrite (Rmult_sym ``3``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | DiscrR] | DiscrR].
-Qed.
-
-Lemma RinvN_pos : (n:nat) ``0</((INR n)+1)``.
-Intro; Apply Rlt_Rinv; Apply ge0_plus_gt0_is_gt0; [Apply pos_INR | Apply Rlt_R0_R1].
-Qed.
-
-Definition RinvN : nat->posreal := [N:nat](mkposreal ? (RinvN_pos N)).
- 
-Lemma RinvN_cv : (Un_cv RinvN R0).
-Unfold Un_cv; Intros; Assert H0 := (archimed ``/eps``); Elim H0; Clear H0; Intros; Assert H2 : `0<=(up (Rinv eps))`.
-Apply le_IZR; Left; Apply Rlt_trans with ``/eps``; [Apply Rlt_Rinv; Assumption | Assumption].
-Elim (IZN ? H2); Intros; Exists x; Intros; Unfold R_dist; Simpl; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Assert H5 : ``0<(INR n)+1``.
-Apply ge0_plus_gt0_is_gt0; [Apply pos_INR | Apply Rlt_R0_R1].
-Rewrite Rabsolu_right; [Idtac | Left; Change ``0</((INR n)+1)``; Apply Rlt_Rinv; Assumption]; Apply Rle_lt_trans with ``/((INR x)+1)``.
-Apply Rle_Rinv.
-Apply ge0_plus_gt0_is_gt0; [Apply pos_INR | Apply Rlt_R0_R1].
-Assumption.
-Do 2 Rewrite <- (Rplus_sym R1); Apply Rle_compatibility; Apply le_INR; Apply H4.
-Rewrite <- (Rinv_Rinv eps).
-Apply Rinv_lt.
-Apply Rmult_lt_pos.
-Apply Rlt_Rinv; Assumption.
-Apply ge0_plus_gt0_is_gt0; [Apply pos_INR | Apply Rlt_R0_R1].
-Apply Rlt_trans with (INR x); [Rewrite INR_IZR_INZ; Rewrite <- H3; Apply H0 | Pattern 1 (INR x); Rewrite <- Rplus_Or; Apply Rlt_compatibility; Apply Rlt_R0_R1].
-Red; Intro; Rewrite H6 in H; Elim (Rlt_antirefl ? H).
-Qed.
-
-(**********) 
-Definition RiemannInt [f:R->R;a,b:R;pr:(Riemann_integrable f a b)] : R := Cases
-(RiemannInt_exists pr 5!RinvN RinvN_cv) of (existTT a' b') => a' end.
-
-Lemma RiemannInt_P5 : (f:R->R;a,b:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable f a b)) (RiemannInt pr1)==(RiemannInt pr2).
-Intros; Unfold RiemannInt; Case (RiemannInt_exists pr1 5!RinvN RinvN_cv); Case (RiemannInt_exists pr2 5!RinvN RinvN_cv); Intros; EApply UL_sequence; [Apply u0 | Apply RiemannInt_P4 with pr2 RinvN; Apply RinvN_cv Orelse Assumption].
-Qed.
-
-(**************************************)
-(* C°([a,b]) is included in L1([a,b]) *)
-(**************************************)
-
-Lemma maxN : (a,b:R;del:posreal) ``a<b`` -> (sigTT ? [n:nat]``a+(INR n)*del<b``/\``b<=a+(INR (S n))*del``).
-Intros; Pose I := [n:nat]``a+(INR n)*del < b``; Assert H0 : (EX n:nat | (I n)).
-Exists O; Unfold I; Rewrite Rmult_Ol; Rewrite Rplus_Or; Assumption.
-Cut (Nbound I).
-Intro; Assert H2 := (Nzorn H0 H1); Elim H2; Intros; Exists x; Elim p; Intros; Split.
-Apply H3.
-Case (total_order_T ``a+(INR (S x))*del`` b); Intro.
-Elim s; Intro.
-Assert H5 := (H4 (S x) a0); Elim (le_Sn_n ? H5).
-Right; Symmetry; Assumption.
-Left; Apply r.
-Assert H1 : ``0<=(b-a)/del``.
-Unfold Rdiv; Apply Rmult_le_pos; [Apply Rle_sym2; Apply Rge_minus; Apply Rle_sym1; Left; Apply H | Left; Apply Rlt_Rinv; Apply (cond_pos del)].
-Elim (archimed ``(b-a)/del``); Intros; Assert H4 : `0<=(up (Rdiv (Rminus b a) del))`.
-Apply le_IZR; Simpl; Left; Apply Rle_lt_trans with ``(b-a)/del``; Assumption.
-Assert H5 := (IZN ? H4); Elim H5; Clear H5; Intros N H5; Unfold Nbound; Exists N; Intros; Unfold I in H6; Apply INR_le; Rewrite H5 in H2; Rewrite <- INR_IZR_INZ in H2; Left; Apply Rle_lt_trans with ``(b-a)/del``; Try Assumption; Apply Rle_monotony_contra with (pos del); [Apply (cond_pos del) | Unfold Rdiv; Rewrite <- (Rmult_sym ``/del``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite Rmult_sym; Apply Rle_anti_compatibility with a; Replace ``a+(b-a)`` with b; [Left; Assumption | Ring] | Assert H7 := (cond_pos del); Red; Intro; Rewrite H8 in H7; Elim (Rlt_antirefl ? H7)]].
-Qed.
-
-Fixpoint SubEquiN [N:nat] : R->R->posreal->Rlist :=
-[x:R][y:R][del:posreal] Cases N of
-| O => (cons y nil)
-| (S p) => (cons x (SubEquiN p ``x+del`` y del))
-end.
-
-Definition max_N [a,b:R;del:posreal;h:``a<b``] : nat := Cases (maxN del h) of (existTT N H0) => N end.
-
-Definition SubEqui [a,b:R;del:posreal;h:``a<b``] :Rlist := (SubEquiN (S (max_N del h)) a b del).
-
-Lemma Heine_cor1 : (f:R->R;a,b:R) ``a<b`` -> ((x:R)``a<=x<=b``->(continuity_pt f x)) -> (eps:posreal) (sigTT ? [delta:posreal]``delta<=b-a``/\(x,y:R)``a<=x<=b``->``a<=y<=b``->``(Rabsolu (x-y)) < delta``->``(Rabsolu ((f x)-(f y))) < eps``).
-Intro f; Intros; Pose E := [l:R]``0<l<=b-a``/\(x,y:R)``a <= x <= b``->``a <= y <= b``->``(Rabsolu (x-y)) < l``->``(Rabsolu ((f x)-(f y))) < eps``; Assert H1 : (bound E).
-Unfold bound; Exists ``b-a``; Unfold is_upper_bound; Intros; Unfold E in H1; Elim H1; Clear H1; Intros H1 _; Elim H1; Intros; Assumption.
-Assert H2 : (EXT x:R | (E x)).
-Assert H2 := (Heine f [x:R]``a<=x<=b`` (compact_P3 a b) H0 eps); Elim H2; Intros; Exists (Rmin x ``b-a``); Unfold E; Split; [Split; [Unfold Rmin; Case (total_order_Rle x ``b-a``); Intro; [Apply (cond_pos x) | Apply Rlt_Rminus; Assumption] | Apply Rmin_r] | Intros; Apply H3; Try Assumption; Apply Rlt_le_trans with (Rmin x ``b-a``); [Assumption | Apply Rmin_l]].
-Assert H3 := (complet E H1 H2); Elim H3; Intros; Cut ``0<x<=b-a``.
-Intro; Elim H4; Clear H4; Intros; Apply existTT with (mkposreal ? H4); Split.
-Apply H5.
-Unfold is_lub in p; Elim p; Intros; Unfold is_upper_bound in H6; Pose D := ``(Rabsolu (x0-y))``; Elim (classic (EXT y:R | ``D<y``/\(E y))); Intro.
-Elim H11; Intros; Elim H12; Clear H12; Intros; Unfold E in H13; Elim H13; Intros; Apply H15; Assumption.
-Assert H12 := (not_ex_all_not ? [y:R]``D < y``/\(E y) H11); Assert H13 : (is_upper_bound E D).
-Unfold is_upper_bound; Intros; Assert H14 := (H12 x1); Elim (not_and_or ``D<x1`` (E x1) H14); Intro.
-Case (total_order_Rle x1 D); Intro.
-Assumption.
-Elim H15; Auto with real.
-Elim H15; Assumption.
-Assert H14 := (H7 ? H13); Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H14 H10)).
-Unfold is_lub in p; Unfold is_upper_bound in p; Elim p; Clear p; Intros; Split.
-Elim H2; Intros; Assert H7 := (H4 ? H6); Unfold E in H6; Elim H6; Clear H6; Intros H6 _; Elim H6; Intros; Apply Rlt_le_trans with x0; Assumption.
-Apply H5; Intros; Unfold E in H6; Elim H6; Clear H6; Intros H6 _; Elim H6; Intros; Assumption.
-Qed.
-
-Lemma Heine_cor2 : (f:(R->R); a,b:R) ((x:R)``a <= x <= b``->(continuity_pt f x))->(eps:posreal)(sigTT posreal [delta:posreal]((x,y:R)``a <= x <= b``->``a <= y <= b``->``(Rabsolu (x-y)) < delta``->``(Rabsolu ((f x)-(f y))) < eps``)).
-Intro f; Intros; Case (total_order_T a b); Intro.
-Elim s; Intro.
-Assert H0 := (Heine_cor1 a0 H eps); Elim H0; Intros; Apply existTT with x; Elim p; Intros; Apply H2; Assumption.
-Apply existTT with (mkposreal ? Rlt_R0_R1); Intros; Assert H3 : x==y; [Elim H0; Elim H1; Intros; Rewrite b0 in H3; Rewrite b0 in H5; Apply Rle_antisym; Apply Rle_trans with b; Assumption | Rewrite H3; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply (cond_pos eps)].
-Apply existTT with (mkposreal ? Rlt_R0_R1); Intros; Elim H0; Intros; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? (Rle_trans ? ? ? H3 H4) r)).
-Qed.
-
-Lemma SubEqui_P1 : (a,b:R;del:posreal;h:``a<b``) (pos_Rl (SubEqui del h) O)==a.
-Intros; Unfold SubEqui; Case (maxN del h); Intros; Reflexivity.
-Qed.
-
-Lemma SubEqui_P2 : (a,b:R;del:posreal;h:``a<b``) (pos_Rl (SubEqui del h) (pred (Rlength (SubEqui del h))))==b.
-Intros; Unfold SubEqui; Case (maxN del h); Intros; Clear a0; Cut (x:nat)(a:R)(del:posreal)(pos_Rl (SubEquiN (S x) a b del) (pred (Rlength (SubEquiN (S x) a b del)))) == b; [Intro; Apply H | Induction x0; [Intros; Reflexivity | Intros; Change (pos_Rl (SubEquiN (S n) ``a0+del0`` b del0) (pred (Rlength (SubEquiN (S n) ``a0+del0`` b del0))))==b; Apply H]].
-Qed.
-
-Lemma SubEqui_P3 : (N:nat;a,b:R;del:posreal) (Rlength (SubEquiN N a b del))=(S N).
-Induction N; Intros; [Reflexivity | Simpl; Rewrite H; Reflexivity].
-Qed.
-
-Lemma SubEqui_P4 : (N:nat;a,b:R;del:posreal;i:nat) (lt i (S N)) -> (pos_Rl (SubEquiN (S N) a b del) i)==``a+(INR i)*del``.
-Induction N; [Intros; Inversion H; [Simpl; Ring | Elim (le_Sn_O ? H1)] | Intros; Induction i; [Simpl; Ring | Change (pos_Rl (SubEquiN (S n) ``a+del`` b del) i)==``a+(INR (S i))*del``; Rewrite H; [Rewrite S_INR; Ring | Apply lt_S_n; Apply H0]]].
-Qed.
-
-Lemma SubEqui_P5 : (a,b:R;del:posreal;h:``a<b``) (Rlength (SubEqui del h))=(S (S (max_N del h))).
-Intros; Unfold SubEqui; Apply SubEqui_P3.
-Qed.
-
-Lemma SubEqui_P6 : (a,b:R;del:posreal;h:``a<b``;i:nat) (lt i (S (max_N del h))) -> (pos_Rl (SubEqui del h) i)==``a+(INR i)*del``.
-Intros; Unfold SubEqui; Apply SubEqui_P4; Assumption.
-Qed.
-
-Lemma SubEqui_P7 : (a,b:R;del:posreal;h:``a<b``) (ordered_Rlist (SubEqui del h)).
-Intros; Unfold ordered_Rlist; Intros; Rewrite SubEqui_P5 in H; Simpl in H; Inversion H.
-Rewrite (SubEqui_P6 3!del 4!h 5!(max_N del h)).
-Replace (S (max_N del h)) with (pred (Rlength (SubEqui del h))).
-Rewrite SubEqui_P2; Unfold max_N; Case (maxN del h); Intros; Left; Elim a0; Intros; Assumption.
-Rewrite SubEqui_P5; Reflexivity.
-Apply lt_n_Sn.
-Repeat Rewrite SubEqui_P6.
-3:Assumption.
-2:Apply le_lt_n_Sm; Assumption.
-Apply Rle_compatibility; Rewrite S_INR; Rewrite Rmult_Rplus_distrl; Pattern 1 ``(INR i)*del``; Rewrite <- Rplus_Or; Apply Rle_compatibility; Rewrite Rmult_1l; Left; Apply (cond_pos del).
-Qed.
-
-Lemma SubEqui_P8 : (a,b:R;del:posreal;h:``a<b``;i:nat) (lt i (Rlength (SubEqui del h))) -> ``a<=(pos_Rl (SubEqui del h) i)<=b``.
-Intros; Split.
-Pattern 1 a; Rewrite <- (SubEqui_P1 del h); Apply RList_P5.
-Apply SubEqui_P7.
-Elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); Intros; Apply H1; Exists i; Split; [Reflexivity | Assumption].
-Pattern 2 b; Rewrite <- (SubEqui_P2 del h); Apply RList_P7; [Apply SubEqui_P7 | Elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); Intros; Apply H1; Exists i; Split; [Reflexivity | Assumption]].
-Qed.
-
-Lemma SubEqui_P9 : (a,b:R;del:posreal;f:R->R;h:``a<b``) (sigTT ? [g:(StepFun a b)](g b)==(f b)/\(i:nat)(lt i (pred (Rlength (SubEqui del h))))->(constant_D_eq g (co_interval (pos_Rl (SubEqui del h) i) (pos_Rl (SubEqui del h) (S i))) (f (pos_Rl (SubEqui del h) i)))).
-Intros; Apply StepFun_P38; [Apply SubEqui_P7 | Apply SubEqui_P1 | Apply SubEqui_P2].
-Qed.
-
-Lemma  RiemannInt_P6 : (f:R->R;a,b:R) ``a<b`` -> ((x:R)``a<=x<=b``->(continuity_pt f x)) -> (Riemann_integrable f a b).
-Intros; Unfold Riemann_integrable; Intro; Assert H1 : ``0<eps/(2*(b-a))``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos eps) | Apply Rlt_Rinv; Apply Rmult_lt_pos; [Sup0 | Apply Rlt_Rminus; Assumption]].
-Assert H2 : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Left; Assumption].
-Assert H3 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Left; Assumption].
-Elim (Heine_cor2 H0 (mkposreal ? H1)); Intros del H4; Elim (SubEqui_P9 del f H); Intros phi [H5 H6]; Split with phi; Split with (mkStepFun (StepFun_P4 a b ``eps/(2*(b-a))``)); Split.
-2:Rewrite StepFun_P18; Unfold Rdiv; Rewrite Rinv_Rmult.
-2:Do 2 Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-2:Rewrite Rmult_1r; Rewrite Rabsolu_right.
-2:Apply Rlt_monotony_contra with ``2``.
-2:Sup0.
-2:Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-2:Rewrite Rmult_1l; Pattern 1 (pos eps); Rewrite <- Rplus_Or; Rewrite double; Apply Rlt_compatibility; Apply (cond_pos eps).
-2:DiscrR.
-2:Apply Rle_sym1; Left; Apply Rmult_lt_pos.
-2:Apply (cond_pos eps).
-2:Apply Rlt_Rinv; Sup0.
-2:Apply Rminus_eq_contra; Red; Intro; Clear H6; Rewrite H7 in H; Elim (Rlt_antirefl ? H).
-2:DiscrR.
-2:Apply Rminus_eq_contra; Red; Intro; Clear H6; Rewrite H7 in H; Elim (Rlt_antirefl ? H).
-Intros; Rewrite H2 in H7; Rewrite H3 in H7; Simpl; Unfold fct_cte; Cut (t:R)``a<=t<=b``->t==b\/(EX i:nat | (lt i (pred (Rlength (SubEqui del H))))/\(co_interval (pos_Rl (SubEqui del H) i) (pos_Rl (SubEqui del H) (S i)) t)).
-Intro; Elim (H8 ? H7); Intro.
-Rewrite H9; Rewrite H5; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Left; Assumption.
-Elim H9; Clear H9; Intros I [H9 H10]; Assert H11 := (H6 I H9 t H10); Rewrite H11; Left; Apply H4.
-Assumption.
-Apply SubEqui_P8; Apply lt_trans with (pred (Rlength (SubEqui del H))).
-Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H12 in H9; Elim (lt_n_O ? H9).
-Unfold co_interval in H10; Elim H10; Clear H10; Intros; Rewrite Rabsolu_right.
-Rewrite SubEqui_P5 in H9; Simpl in H9; Inversion H9.
-Apply Rlt_anti_compatibility with (pos_Rl (SubEqui del H) (max_N del H)).
-Replace ``(pos_Rl (SubEqui del H) (max_N del H))+(t-(pos_Rl (SubEqui del H) (max_N del H)))`` with t; [Idtac | Ring]; Apply Rlt_le_trans with b.
-Rewrite H14 in H12; Assert H13 : (S (max_N del H))=(pred (Rlength (SubEqui del H))).
-Rewrite SubEqui_P5; Reflexivity.
-Rewrite H13 in H12; Rewrite SubEqui_P2 in H12; Apply H12.
-Rewrite SubEqui_P6.
-2:Apply lt_n_Sn.
-Unfold max_N; Case (maxN del H); Intros; Elim a0; Clear a0; Intros _ H13; Replace ``a+(INR x)*del+del`` with ``a+(INR (S x))*del``; [Assumption | Rewrite S_INR; Ring].
-Apply Rlt_anti_compatibility with (pos_Rl (SubEqui del H) I); Replace ``(pos_Rl (SubEqui del H) I)+(t-(pos_Rl (SubEqui del H) I))`` with t; [Idtac | Ring]; Replace ``(pos_Rl (SubEqui del H) I)+del`` with (pos_Rl (SubEqui del H) (S I)).
-Assumption.
-Repeat Rewrite SubEqui_P6.
-Rewrite S_INR; Ring.
-Assumption.
-Apply le_lt_n_Sm; Assumption.
-Apply Rge_minus; Apply Rle_sym1; Assumption.
-Intros; Clear H0 H1 H4 phi H5 H6 t H7; Case (Req_EM t0 b); Intro.
-Left; Assumption.
-Right; Pose I := [j:nat]``a+(INR j)*del<=t0``; Assert H1 : (EX n:nat | (I n)).
-Exists O; Unfold I; Rewrite Rmult_Ol; Rewrite Rplus_Or; Elim H8; Intros; Assumption.
-Assert H4 : (Nbound I).
-Unfold Nbound; Exists (S (max_N del H)); Intros; Unfold max_N; Case (maxN del H); Intros; Elim a0; Clear a0; Intros _ H5; Apply INR_le; Apply Rle_monotony_contra with (pos del).
-Apply (cond_pos del).
-Apply Rle_anti_compatibility with a; Do 2 Rewrite (Rmult_sym del); Apply Rle_trans with t0; Unfold I in H4; Try Assumption; Apply Rle_trans with b; Try Assumption; Elim H8; Intros; Assumption.
-Elim (Nzorn H1 H4); Intros N [H5 H6]; Assert H7 : (lt N (S (max_N del H))).
-Unfold max_N; Case (maxN del H); Intros; Apply INR_lt; Apply Rlt_monotony_contra with (pos del).
-Apply (cond_pos del).
-Apply Rlt_anti_compatibility with a; Do 2 Rewrite (Rmult_sym del); Apply Rle_lt_trans with t0; Unfold I in H5; Try Assumption; Elim a0; Intros; Apply Rlt_le_trans with b; Try Assumption; Elim H8; Intros.
-Elim H11; Intro.
-Assumption.
-Elim H0; Assumption.
-Exists N; Split.
-Rewrite SubEqui_P5; Simpl; Assumption.
-Unfold co_interval; Split.
-Rewrite SubEqui_P6.
-Apply H5.
-Assumption.
-Inversion H7.
-Replace (S (max_N del H)) with (pred (Rlength (SubEqui del H))).
-Rewrite (SubEqui_P2 del H); Elim H8; Intros.
-Elim H11; Intro.
-Assumption.
-Elim H0; Assumption.
-Rewrite SubEqui_P5; Reflexivity.
-Rewrite SubEqui_P6.
-Case (total_order_Rle ``a+(INR (S N))*del`` t0); Intro.
-Assert H11 := (H6 (S N) r); Elim (le_Sn_n ? H11).
-Auto with real.
-Apply le_lt_n_Sm; Assumption.
-Qed.
-
-Lemma RiemannInt_P7 : (f:R->R;a:R) (Riemann_integrable f a a).
-Unfold Riemann_integrable; Intro f; Intros; Split with (mkStepFun (StepFun_P4 a a (f a))); Split with (mkStepFun (StepFun_P4 a a R0)); Split.
-Intros; Simpl; Unfold fct_cte; Replace t with a.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Right; Reflexivity.
-Generalize H; Unfold Rmin Rmax; Case (total_order_Rle a a); Intros; Elim H0; Intros; Apply Rle_antisym; Assumption.
-Rewrite StepFun_P18; Rewrite Rmult_Ol; Rewrite Rabsolu_R0; Apply (cond_pos eps).
-Qed.
-
-Lemma continuity_implies_RiemannInt : (f:R->R;a,b:R) ``a<=b`` -> ((x:R)``a<=x<=b``->(continuity_pt f x)) -> (Riemann_integrable f a b).
-Intros; Case (total_order_T a b); Intro; [Elim s; Intro; [Apply RiemannInt_P6; Assumption | Rewrite b0; Apply RiemannInt_P7] | Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r))].
-Qed.
-
-Lemma RiemannInt_P8 : (f:R->R;a,b:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable f b a)) ``(RiemannInt pr1)==-(RiemannInt pr2)``.
-Intro f; Intros; EApply UL_sequence.
-Unfold RiemannInt; Case (RiemannInt_exists pr1 5!RinvN RinvN_cv); Intros; Apply u.
-Unfold RiemannInt; Case (RiemannInt_exists pr2 5!RinvN RinvN_cv); Intros; Cut (EXT psi1:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((f t)-([(phi_sequence RinvN pr1 n)] t)))<= (psi1 n t)``)/\``(Rabsolu (RiemannInt_SF (psi1 n))) < (RinvN n)``).
-Cut (EXT psi2:nat->(StepFun b a) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((f t)-([(phi_sequence RinvN pr2 n)] t)))<= (psi2 n t)``)/\``(Rabsolu (RiemannInt_SF (psi2 n))) < (RinvN n)``).
-Intros; Elim H; Clear H; Intros psi2 H; Elim H0; Clear H0; Intros psi1 H0; Assert H1 := RinvN_cv; Unfold Un_cv; Intros; Assert H3 : ``0<eps/3``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Unfold Un_cv in H1; Elim (H1 ? H3); Clear H1; Intros N0 H1; Unfold R_dist in H1; Simpl in H1; Assert H4 : (n:nat)(ge n N0)->``(RinvN n)<eps/3``.
-Intros; Assert H5 := (H1 ? H4); Replace (pos (RinvN n)) with ``(Rabsolu (/((INR n)+1)-0))``; [Assumption | Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Left; Apply (cond_pos (RinvN n))].
-Clear H1; Unfold Un_cv in u; Elim (u ? H3); Clear u; Intros N1 H1; Exists (max N0 N1); Intros; Unfold R_dist; Apply Rle_lt_trans with ``(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(RiemannInt_SF [(phi_sequence RinvN pr2 n)])))+(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x))``.
-Rewrite <- (Rabsolu_Ropp ``(RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x``); Replace ``(RiemannInt_SF [(phi_sequence RinvN pr1 n)])- -x`` with ``((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))+ -((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x)``; [Apply Rabsolu_triang | Ring].
-Replace eps with ``2*eps/3+eps/3``.
-Apply Rplus_lt.
-Rewrite (StepFun_P39 (phi_sequence RinvN pr2 n)); Replace ``(RiemannInt_SF [(phi_sequence RinvN pr1 n)])+ -(RiemannInt_SF (mkStepFun (StepFun_P6 (pre [(phi_sequence RinvN pr2 n)]))))`` with ``(RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(-1)*(RiemannInt_SF (mkStepFun (StepFun_P6 (pre [(phi_sequence RinvN pr2 n)]))))``; [Idtac | Ring]; Rewrite <- StepFun_P30.
-Case (total_order_Rle a b); Intro.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 ``-1`` (phi_sequence RinvN pr1 n) (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n))))))))).
-Apply StepFun_P34; Assumption.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P28 ``1`` (psi1 n) (mkStepFun (StepFun_P6 (pre (psi2 n))))))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Rewrite Rmult_1l; Apply Rle_trans with ``(Rabsolu (([(phi_sequence RinvN pr1 n)] x0)-(f x0)))+(Rabsolu ((f x0)-([(phi_sequence RinvN pr2 n)] x0)))``.
-Replace ``([(phi_sequence RinvN pr1 n)] x0)+ -1*([(phi_sequence RinvN pr2 n)] x0)`` with ``(([(phi_sequence RinvN pr1 n)] x0)-(f x0))+((f x0)-([(phi_sequence RinvN pr2 n)] x0))``; [Apply Rabsolu_triang | Ring].
-Assert H7 : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Assert H8 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Apply Rplus_le.
-Elim (H0 n); Intros; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H9; Rewrite H7; Rewrite H8.
-Elim H6; Intros; Split; Left; Assumption.
-Elim (H n); Intros; Apply H9; Rewrite H7; Rewrite H8.
-Elim H6; Intros; Split; Left; Assumption.
-Rewrite StepFun_P30; Rewrite Rmult_1l; Rewrite double; Apply Rplus_lt.
-Elim (H0 n); Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi1 n))); [Apply Rle_Rabsolu | Apply Rlt_trans with (pos (RinvN n)); [Assumption | Apply H4; Unfold ge; Apply le_trans with (max N0 N1); [Apply le_max_l | Assumption]]].
-Elim (H n); Intros; Rewrite <- (Ropp_Ropp (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi2 n)))))); Rewrite <- StepFun_P39; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi2 n))); [Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu | Apply Rlt_trans with (pos (RinvN n)); [Assumption | Apply H4; Unfold ge; Apply le_trans with (max N0 N1); [Apply le_max_l | Assumption]]].
-Assert Hyp : ``b<=a``.
-Auto with real.
-Rewrite StepFun_P39; Rewrite Rabsolu_Ropp; Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P6 (StepFun_P28 ``-1`` (phi_sequence RinvN pr1 n) (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))))))))).
-Apply StepFun_P34; Assumption.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P28 ``1`` (mkStepFun (StepFun_P6 (pre (psi1 n)))) (psi2 n)))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Rewrite Rmult_1l; Apply Rle_trans with ``(Rabsolu (([(phi_sequence RinvN pr1 n)] x0)-(f x0)))+(Rabsolu ((f x0)-([(phi_sequence RinvN pr2 n)] x0)))``.
-Replace ``([(phi_sequence RinvN pr1 n)] x0)+ -1*([(phi_sequence RinvN pr2 n)] x0)`` with ``(([(phi_sequence RinvN pr1 n)] x0)-(f x0))+((f x0)-([(phi_sequence RinvN pr2 n)] x0))``; [Apply Rabsolu_triang | Ring].
-Assert H7 : (Rmin a b)==b.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Elim n0; Assumption | Reflexivity].
-Assert H8 : (Rmax a b)==a.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Elim n0; Assumption | Reflexivity].
-Apply Rplus_le.
-Elim (H0 n); Intros; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H9; Rewrite H7; Rewrite H8.
-Elim H6; Intros; Split; Left; Assumption.
-Elim (H n); Intros; Apply H9; Rewrite H7; Rewrite H8; Elim H6; Intros; Split; Left; Assumption.
-Rewrite StepFun_P30; Rewrite Rmult_1l; Rewrite double; Apply Rplus_lt.
-Elim (H0 n); Intros; Rewrite <- (Ropp_Ropp (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (psi1 n)))))); Rewrite <- StepFun_P39; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi1 n))); [Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu | Apply Rlt_trans with (pos (RinvN n)); [Assumption | Apply H4; Unfold ge; Apply le_trans with (max N0 N1); [Apply le_max_l | Assumption]]].
-Elim (H n); Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi2 n))); [Apply Rle_Rabsolu | Apply Rlt_trans with (pos (RinvN n)); [Assumption | Apply H4; Unfold ge; Apply le_trans with (max N0 N1); [Apply le_max_l | Assumption]]].
-Unfold R_dist in H1; Apply H1; Unfold ge; Apply le_trans with (max N0 N1); [Apply le_max_r | Assumption].
-Apply r_Rmult_mult with ``3``; [Unfold Rdiv; Rewrite Rmult_Rplus_distr; Do 2 Rewrite (Rmult_sym ``3``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | DiscrR] | DiscrR].
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr2 n)); Intro; Rewrite Rmin_sym; Rewrite RmaxSym; Apply (projT2 ? ? (phi_sequence_prop RinvN pr2 n)).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr1 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr1 n)).
-Qed.
-
-Lemma RiemannInt_P9 : (f:R->R;a:R;pr:(Riemann_integrable f a a)) ``(RiemannInt pr)==0``.
-Intros; Assert H := (RiemannInt_P8 pr pr); Apply r_Rmult_mult with ``2``; [Rewrite Rmult_Or; Rewrite double; Pattern 2 (RiemannInt pr); Rewrite H; Apply Rplus_Ropp_r | DiscrR].
-Qed.
-
-Lemma Req_EM_T :(r1,r2:R) (sumboolT (r1==r2) ``r1<>r2``).
-Intros; Elim (total_order_T r1 r2);Intros; [Elim a;Intro; [Right; Red; Intro; Rewrite H in a0; Elim (Rlt_antirefl ``r2`` a0) | Left;Assumption] | Right; Red; Intro; Rewrite H in b; Elim (Rlt_antirefl ``r2`` b)].
-Qed.
-
-(* L1([a,b]) is a vectorial space *)
-Lemma RiemannInt_P10 : (f,g:R->R;a,b,l:R) (Riemann_integrable f a b) -> (Riemann_integrable g a b) -> (Riemann_integrable [x:R]``(f x)+l*(g x)`` a b).
-Unfold Riemann_integrable; Intros f g; Intros; Case (Req_EM_T l R0); Intro.
-Elim (X eps); Intros; Split with x; Elim p; Intros; Split with x0; Elim p0; Intros; Split; Try Assumption; Rewrite e; Intros; Rewrite Rmult_Ol; Rewrite Rplus_Or; Apply H; Assumption.
-Assert H : ``0<eps/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos eps) | Apply Rlt_Rinv; Sup0].
-Assert H0 : ``0<eps/(2*(Rabsolu l))``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos eps) | Apply Rlt_Rinv; Apply Rmult_lt_pos; [Sup0 | Apply Rabsolu_pos_lt; Assumption]].
-Elim (X (mkposreal ? H)); Intros; Elim (X0 (mkposreal ? H0)); Intros; Split with (mkStepFun (StepFun_P28 l x x0)); Elim p0; Elim p; Intros; Split with (mkStepFun (StepFun_P28 (Rabsolu l) x1 x2)); Elim p1; Elim p2; Clear p1 p2 p0 p X X0; Intros; Split.
-Intros; Simpl; Apply Rle_trans with ``(Rabsolu ((f t)-(x t)))+(Rabsolu (l*((g t)-(x0 t))))``.
-Replace ``(f t)+l*(g t)-((x t)+l*(x0 t))`` with ``((f t)-(x t))+ l*((g t)-(x0 t))``; [Apply Rabsolu_triang | Ring].
-Apply Rplus_le; [Apply H3; Assumption | Rewrite Rabsolu_mult; Apply Rle_monotony; [Apply Rabsolu_pos | Apply H1; Assumption]].
-Rewrite StepFun_P30; Apply Rle_lt_trans with ``(Rabsolu (RiemannInt_SF x1))+(Rabsolu ((Rabsolu l)*(RiemannInt_SF x2)))``.
-Apply Rabsolu_triang.
-Rewrite (double_var eps); Apply Rplus_lt.
-Apply H4.
-Rewrite Rabsolu_mult; Rewrite Rabsolu_Rabsolu; Apply Rlt_monotony_contra with ``/(Rabsolu l)``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym; [Rewrite Rmult_1l; Replace ``/(Rabsolu l)*eps/2`` with ``eps/(2*(Rabsolu l))``; [Apply H2 | Unfold Rdiv; Rewrite Rinv_Rmult; [Ring | DiscrR | Apply Rabsolu_no_R0; Assumption]] | Apply Rabsolu_no_R0; Assumption].
-Qed.
-
-Lemma RiemannInt_P11 : (f:R->R;a,b,l:R;un:nat->posreal;phi1,phi2,psi1,psi2:nat->(StepFun a b)) (Un_cv un R0) -> ((n:nat)((t:R)``(Rmin a b)<=t<=(Rmax a b)``->``(Rabsolu ((f t)-(phi1 n t)))<=(psi1 n t)``)/\``(Rabsolu (RiemannInt_SF (psi1 n)))<(un n)``) -> ((n:nat)((t:R)``(Rmin a b)<=t<=(Rmax a b)``->``(Rabsolu ((f t)-(phi2 n t)))<=(psi2 n t)``)/\``(Rabsolu (RiemannInt_SF (psi2 n)))<(un n)``) -> (Un_cv [N:nat](RiemannInt_SF (phi1 N)) l) -> (Un_cv [N:nat](RiemannInt_SF (phi2 N)) l).
-Unfold Un_cv; Intro f; Intros; Intros.
-Case (total_order_Rle a b); Intro Hyp.
-Assert H4 : ``0<eps/3``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H ? H4); Clear H; Intros N0 H.
-Elim (H2 ? H4); Clear H2; Intros N1 H2.
-Pose N := (max N0 N1); Exists N; Intros; Unfold R_dist.
-Apply Rle_lt_trans with ``(Rabsolu ((RiemannInt_SF (phi2 n))-(RiemannInt_SF (phi1 n))))+(Rabsolu ((RiemannInt_SF (phi1 n))-l))``.
-Replace ``(RiemannInt_SF (phi2 n))-l`` with ``((RiemannInt_SF (phi2 n))-(RiemannInt_SF (phi1 n)))+((RiemannInt_SF (phi1 n))-l)``; [Apply Rabsolu_triang | Ring].
-Replace ``eps`` with ``2*eps/3+eps/3``.
-Apply Rplus_lt.
-Replace ``(RiemannInt_SF (phi2 n))-(RiemannInt_SF (phi1 n))`` with ``(RiemannInt_SF (phi2 n))+(-1)*(RiemannInt_SF (phi1 n))``; [Idtac | Ring].
-Rewrite <- StepFun_P30.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 ``-1`` (phi2 n) (phi1 n)))))).
-Apply StepFun_P34; Assumption.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P28 R1 (psi1 n) (psi2 n)))).
-Apply StepFun_P37; Try Assumption; Intros; Simpl; Rewrite Rmult_1l.
-Apply Rle_trans with ``(Rabsolu ((phi2 n x)-(f x)))+(Rabsolu ((f x)-(phi1 n x)))``.
-Replace ``(phi2 n x)+-1*(phi1 n x)`` with ``((phi2 n x)-(f x))+((f x)-(phi1 n x))``; [Apply Rabsolu_triang | Ring].
-Rewrite (Rplus_sym (psi1 n x)); Apply Rplus_le.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Elim (H1 n); Intros; Apply H7.
-Assert H10 : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Assert H11 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Rewrite H10; Rewrite H11; Elim H6; Intros; Split; Left; Assumption.
-Elim (H0 n); Intros; Apply H7; Assert H10 : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Assert H11 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Rewrite H10; Rewrite H11; Elim H6; Intros; Split; Left; Assumption.
-Rewrite StepFun_P30; Rewrite Rmult_1l; Rewrite double; Apply Rplus_lt.
-Apply Rlt_trans with (pos (un n)).
-Elim (H0 n); Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi1 n))).
-Apply Rle_Rabsolu.
-Assumption.
-Replace (pos (un n)) with (R_dist (un n) R0).
-Apply H; Unfold ge; Apply le_trans with N; Try Assumption.
-Unfold N; Apply le_max_l.
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right.
-Apply Rle_sym1; Left; Apply (cond_pos (un n)).
-Apply Rlt_trans with (pos (un n)).
-Elim (H1 n); Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi2 n))).
-Apply Rle_Rabsolu; Assumption.
-Assumption.
-Replace (pos (un n)) with (R_dist (un n) R0).
-Apply H; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_max_l.
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Apply Rle_sym1; Left; Apply (cond_pos (un n)).
-Unfold R_dist in H2; Apply H2; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_max_r.
-Apply r_Rmult_mult with ``3``; [Unfold Rdiv; Rewrite Rmult_Rplus_distr; Do 2 Rewrite (Rmult_sym ``3``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | DiscrR] | DiscrR].
-Assert H4 : ``0<eps/3``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H ? H4); Clear H; Intros N0 H.
-Elim (H2 ? H4); Clear H2; Intros N1 H2.
-Pose N := (max N0 N1); Exists N; Intros; Unfold R_dist.
-Apply Rle_lt_trans with ``(Rabsolu ((RiemannInt_SF (phi2 n))-(RiemannInt_SF (phi1 n))))+(Rabsolu ((RiemannInt_SF (phi1 n))-l))``.
-Replace ``(RiemannInt_SF (phi2 n))-l`` with ``((RiemannInt_SF (phi2 n))-(RiemannInt_SF (phi1 n)))+((RiemannInt_SF (phi1 n))-l)``; [Apply Rabsolu_triang | Ring].
-Assert Hyp_b : ``b<=a``.
-Auto with real.
-Replace ``eps`` with ``2*eps/3+eps/3``.
-Apply Rplus_lt.
-Replace ``(RiemannInt_SF (phi2 n))-(RiemannInt_SF (phi1 n))`` with ``(RiemannInt_SF (phi2 n))+(-1)*(RiemannInt_SF (phi1 n))``; [Idtac | Ring].
-Rewrite <- StepFun_P30.
-Rewrite StepFun_P39.
-Rewrite Rabsolu_Ropp.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 ``-1`` (phi2 n) (phi1 n))))))))).
-Apply StepFun_P34; Try Assumption.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 R1 (psi1 n) (psi2 n))))))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Rewrite Rmult_1l.
-Apply Rle_trans with ``(Rabsolu ((phi2 n x)-(f x)))+(Rabsolu ((f x)-(phi1 n x)))``.
-Replace ``(phi2 n x)+-1*(phi1 n x)`` with ``((phi2 n x)-(f x))+((f x)-(phi1 n x))``; [Apply Rabsolu_triang | Ring].
-Rewrite (Rplus_sym (psi1 n x)); Apply Rplus_le.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Elim (H1 n); Intros; Apply H7.
-Assert H10 : (Rmin a b)==b.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Elim Hyp; Assumption | Reflexivity].
-Assert H11 : (Rmax a b)==a.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Elim Hyp; Assumption | Reflexivity].
-Rewrite H10; Rewrite H11; Elim H6; Intros; Split; Left; Assumption.
-Elim (H0 n); Intros; Apply H7; Assert H10 : (Rmin a b)==b.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Elim Hyp; Assumption | Reflexivity].
-Assert H11 : (Rmax a b)==a.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Elim Hyp; Assumption | Reflexivity].
-Rewrite H10; Rewrite H11; Elim H6; Intros; Split; Left; Assumption.
-Rewrite <- (Ropp_Ropp (RiemannInt_SF
-     (mkStepFun
-     (StepFun_P6 (pre (mkStepFun (StepFun_P28 R1 (psi1 n) (psi2 n)))))))).
-Rewrite <- StepFun_P39.
-Rewrite StepFun_P30.
-Rewrite Rmult_1l; Rewrite double.
-Rewrite Ropp_distr1; Apply Rplus_lt.
-Apply Rlt_trans with (pos (un n)).
-Elim (H0 n); Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi1 n))).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Assumption.
-Replace (pos (un n)) with (R_dist (un n) R0).
-Apply H; Unfold ge; Apply le_trans with N; Try Assumption.
-Unfold N; Apply le_max_l.
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right.
-Apply Rle_sym1; Left; Apply (cond_pos (un n)).
-Apply Rlt_trans with (pos (un n)).
-Elim (H1 n); Intros; Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi2 n))).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu; Assumption.
-Assumption.
-Replace (pos (un n)) with (R_dist (un n) R0).
-Apply H; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_max_l.
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Apply Rle_sym1; Left; Apply (cond_pos (un n)).
-Unfold R_dist in H2; Apply H2; Unfold ge; Apply le_trans with N; Try Assumption; Unfold N; Apply le_max_r.
-Apply r_Rmult_mult with ``3``; [Unfold Rdiv; Rewrite Rmult_Rplus_distr; Do 2 Rewrite (Rmult_sym ``3``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | DiscrR] | DiscrR].
-Qed.
-
-Lemma RiemannInt_P12 : (f,g:R->R;a,b,l:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable g a b);pr3:(Riemann_integrable [x:R]``(f x)+l*(g x)`` a b)) ``a<=b`` -> ``(RiemannInt pr3)==(RiemannInt pr1)+l*(RiemannInt pr2)``.
-Intro f; Intros; Case (Req_EM l R0); Intro.
-Pattern 2 l; Rewrite H0; Rewrite Rmult_Ol; Rewrite Rplus_Or; Unfold RiemannInt; Case (RiemannInt_exists pr3 5!RinvN RinvN_cv); Case (RiemannInt_exists pr1 5!RinvN RinvN_cv); Intros; EApply UL_sequence; [Apply u0 | Pose psi1 := [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr1 n)); Pose psi2 := [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr3 n)); Apply RiemannInt_P11 with f RinvN (phi_sequence RinvN pr1) psi1 psi2; [Apply RinvN_cv | Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr1 n)) | Intro; Assert H1 : ((t:R) ``(Rmin a b) <= t``/\``t <= (Rmax a b)`` -> (Rle (Rabsolu (Rminus ``(f t)+l*(g t)`` (phi_sequence RinvN pr3 n t))) (psi2 n t))) /\ ``(Rabsolu (RiemannInt_SF (psi2 n))) < (RinvN n)``; [Apply (projT2 ? ? (phi_sequence_prop RinvN pr3 n)) | Elim H1; Intros; Split; Try Assumption; Intros; Replace (f t) with ``(f t)+l*(g t)``; [Apply H2; Assumption | Rewrite H0; Ring]] | Assumption]].
-EApply UL_sequence.
-Unfold RiemannInt; Case (RiemannInt_exists pr3 5!RinvN RinvN_cv); Intros; Apply u.
-Unfold Un_cv; Intros; Unfold RiemannInt; Case (RiemannInt_exists pr1 5!RinvN RinvN_cv); Case (RiemannInt_exists pr2 5!RinvN RinvN_cv); Unfold Un_cv; Intros; Assert H2 : ``0<eps/5``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (u0 ? H2); Clear u0; Intros N0 H3; Assert H4 := RinvN_cv; Unfold Un_cv in H4; Elim (H4 ? H2); Clear H4 H2; Intros N1 H4; Assert H5 : ``0<eps/(5*(Rabsolu l))``. 
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Apply Rmult_lt_pos; [Sup0 | Apply Rabsolu_pos_lt; Assumption]].
-Elim (u ? H5); Clear u; Intros N2 H6; Assert H7 := RinvN_cv; Unfold Un_cv in H7; Elim (H7 ? H5); Clear H7 H5; Intros N3 H5; Unfold R_dist in H3 H4 H5 H6; Pose N := (max (max N0 N1) (max N2 N3)).
-Assert H7 : (n:nat) (ge n N1)->``(RinvN n)< eps/5``.
-Intros; Replace (pos (RinvN n)) with ``(Rabsolu ((RinvN n)-0))``; [Unfold RinvN; Apply H4; Assumption | Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Left; Apply (cond_pos (RinvN n))].
-Clear H4; Assert H4 := H7; Clear H7; Assert H7 : (n:nat) (ge n N3)->``(RinvN n)< eps/(5*(Rabsolu l))``.
-Intros; Replace (pos (RinvN n)) with ``(Rabsolu ((RinvN n)-0))``; [Unfold RinvN; Apply H5; Assumption | Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Left; Apply (cond_pos (RinvN n))].
-Clear H5; Assert H5 := H7; Clear H7; Exists N; Intros; Unfold R_dist.
-Apply Rle_lt_trans with ``(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr3 n)])-((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+l*(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))))+(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr1 n)])-x0))+(Rabsolu l)*(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x))``.
-Apply Rle_trans with ``(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr3 n)])-((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+l*(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))))+(Rabsolu (((RiemannInt_SF [(phi_sequence RinvN pr1 n)])-x0)+l*((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x)))``.
-Replace ``(RiemannInt_SF [(phi_sequence RinvN pr3 n)])-(x0+l*x)`` with ``(((RiemannInt_SF [(phi_sequence RinvN pr3 n)])-((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+l*(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))))+(((RiemannInt_SF [(phi_sequence RinvN pr1 n)])-x0)+l*((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x))``; [Apply Rabsolu_triang | Ring].
-Rewrite Rplus_assoc; Apply Rle_compatibility; Rewrite <- Rabsolu_mult; Replace ``(RiemannInt_SF [(phi_sequence RinvN pr1 n)])-x0+l*((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x)`` with ``((RiemannInt_SF [(phi_sequence RinvN pr1 n)])-x0)+(l*((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x))``; [Apply Rabsolu_triang | Ring].
-Replace eps with ``3*eps/5+eps/5+eps/5``.
-Repeat Apply Rplus_lt.
-Assert H7 : (EXT psi1:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((f t)-([(phi_sequence RinvN pr1 n)] t)))<= (psi1 n t)``)/\``(Rabsolu (RiemannInt_SF (psi1 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr1 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr1 n0)).
-Assert H8 : (EXT psi2:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((g t)-([(phi_sequence RinvN pr2 n)] t)))<= (psi2 n t)``)/\``(Rabsolu (RiemannInt_SF (psi2 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr2 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr2 n0)).
-Assert H9 : (EXT psi3:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu (((f t)+l*(g t))-([(phi_sequence RinvN pr3 n)] t)))<= (psi3 n t)``)/\``(Rabsolu (RiemannInt_SF (psi3 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr3 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr3 n0)).
-Elim H7; Clear H7; Intros psi1 H7; Elim H8; Clear H8; Intros psi2 H8; Elim H9; Clear H9; Intros psi3 H9; Replace ``(RiemannInt_SF [(phi_sequence RinvN pr3 n)])-((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+l*(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))`` with ``(RiemannInt_SF [(phi_sequence RinvN pr3 n)])+(-1)*((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+l*(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))``; [Idtac | Ring]; Do 2 Rewrite <- StepFun_P30; Assert H10 : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Assert H11 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Rewrite H10 in H7; Rewrite H10 in H8; Rewrite H10 in H9; Rewrite H11 in H7; Rewrite H11 in H8; Rewrite H11 in H9; Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 ``-1`` (phi_sequence RinvN pr3 n) (mkStepFun (StepFun_P28 l (phi_sequence RinvN pr1 n) (phi_sequence RinvN pr2 n)))))))).
-Apply StepFun_P34; Assumption.
-Apply Rle_lt_trans with (RiemannInt_SF (mkStepFun (StepFun_P28 R1 (psi3 n) (mkStepFun (StepFun_P28 (Rabsolu l) (psi1 n) (psi2 n)))))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Rewrite Rmult_1l.
-Apply Rle_trans with ``(Rabsolu (([(phi_sequence RinvN pr3 n)] x1)-((f x1)+l*(g x1))))+(Rabsolu (((f x1)+l*(g x1))+ -1*(([(phi_sequence RinvN pr1 n)] x1)+l*([(phi_sequence RinvN pr2 n)] x1))))``.
-Replace ``([(phi_sequence RinvN pr3 n)] x1)+ -1*(([(phi_sequence RinvN pr1 n)] x1)+l*([(phi_sequence RinvN pr2 n)] x1))`` with ``(([(phi_sequence RinvN pr3 n)] x1)-((f x1)+l*(g x1)))+(((f x1)+l*(g x1))+ -1*(([(phi_sequence RinvN pr1 n)] x1)+l*([(phi_sequence RinvN pr2 n)] x1)))``; [Apply Rabsolu_triang | Ring].
-Rewrite Rplus_assoc; Apply Rplus_le.
-Elim (H9 n); Intros; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H13.
-Elim H12; Intros; Split; Left; Assumption. 
-Apply Rle_trans with ``(Rabsolu ((f x1)-([(phi_sequence RinvN pr1 n)] x1)))+(Rabsolu l)*(Rabsolu ((g x1)-([(phi_sequence RinvN pr2 n)] x1)))``.
-Rewrite <- Rabsolu_mult; Replace ``((f x1)+(l*(g x1)+ -1*(([(phi_sequence RinvN pr1 n)] x1)+l*([(phi_sequence RinvN pr2 n)] x1))))`` with ``((f x1)-([(phi_sequence RinvN pr1 n)] x1))+l*((g x1)-([(phi_sequence RinvN pr2 n)] x1))``; [Apply Rabsolu_triang | Ring].
-Apply Rplus_le.
-Elim (H7 n); Intros; Apply H13.
-Elim H12; Intros; Split; Left; Assumption.
-Apply Rle_monotony; [Apply Rabsolu_pos | Elim (H8 n); Intros; Apply H13; Elim H12; Intros; Split; Left; Assumption].
-Do 2 Rewrite StepFun_P30; Rewrite Rmult_1l; Replace ``3*eps/5`` with ``eps/5+(eps/5+eps/5)``; [Repeat Apply Rplus_lt | Ring].
-Apply Rlt_trans with (pos (RinvN n)); [Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi3 n))); [Apply Rle_Rabsolu | Elim (H9 n); Intros; Assumption] | Apply H4; Unfold ge; Apply le_trans with N; [Apply le_trans with (max N0 N1); [Apply le_max_r | Unfold N; Apply le_max_l] | Assumption]].
-Apply Rlt_trans with (pos (RinvN n)); [Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi1 n))); [Apply Rle_Rabsolu | Elim (H7 n); Intros; Assumption] | Apply H4; Unfold ge; Apply le_trans with N; [Apply le_trans with (max N0 N1); [Apply le_max_r | Unfold N; Apply le_max_l] | Assumption]].
-Apply Rlt_monotony_contra with ``/(Rabsolu l)``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Replace ``/(Rabsolu l)*eps/5`` with ``eps/(5*(Rabsolu l))``.
-Apply Rlt_trans with (pos (RinvN n)); [Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi2 n))); [Apply Rle_Rabsolu | Elim (H8 n); Intros; Assumption] | Apply H5; Unfold ge; Apply le_trans with N; [Apply le_trans with (max N2 N3); [Apply le_max_r | Unfold N; Apply le_max_r] | Assumption]].
-Unfold Rdiv; Rewrite Rinv_Rmult; [Ring | DiscrR | Apply Rabsolu_no_R0; Assumption].
-Apply Rabsolu_no_R0; Assumption.
-Apply H3; Unfold ge; Apply le_trans with (max N0 N1); [Apply le_max_l | Apply le_trans with N; [Unfold N; Apply le_max_l | Assumption]].
-Apply Rlt_monotony_contra with ``/(Rabsolu l)``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Replace ``/(Rabsolu l)*eps/5`` with ``eps/(5*(Rabsolu l))``.
-Apply H6; Unfold ge; Apply le_trans with (max N2 N3); [Apply le_max_l | Apply le_trans with N; [Unfold N; Apply le_max_r | Assumption]].
-Unfold Rdiv; Rewrite Rinv_Rmult; [Ring | DiscrR | Apply Rabsolu_no_R0; Assumption].
-Apply Rabsolu_no_R0; Assumption.
-Apply r_Rmult_mult with ``5``; [Unfold Rdiv; Do 2 Rewrite Rmult_Rplus_distr; Do 3 Rewrite (Rmult_sym ``5``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | DiscrR] | DiscrR]. 
-Qed.
-
-Lemma RiemannInt_P13 : (f,g:R->R;a,b,l:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable g a b);pr3:(Riemann_integrable [x:R]``(f x)+l*(g x)`` a b)) ``(RiemannInt pr3)==(RiemannInt pr1)+l*(RiemannInt pr2)``.
-Intros; Case (total_order_Rle a b); Intro; [Apply RiemannInt_P12; Assumption | Assert H : ``b<=a``; [Auto with real | Replace (RiemannInt pr3) with (Ropp (RiemannInt (RiemannInt_P1 pr3))); [Idtac | Symmetry; Apply RiemannInt_P8]; Replace (RiemannInt pr2) with (Ropp (RiemannInt (RiemannInt_P1 pr2))); [Idtac | Symmetry; Apply RiemannInt_P8]; Replace (RiemannInt pr1) with (Ropp (RiemannInt (RiemannInt_P1 pr1))); [Idtac | Symmetry; Apply RiemannInt_P8]; Rewrite (RiemannInt_P12 (RiemannInt_P1 pr1) (RiemannInt_P1 pr2) (RiemannInt_P1 pr3) H); Ring]].
-Qed.
-
-Lemma RiemannInt_P14 : (a,b,c:R) (Riemann_integrable (fct_cte c) a b).
-Unfold Riemann_integrable; Intros; Split with (mkStepFun (StepFun_P4 a b c)); Split with (mkStepFun (StepFun_P4 a b R0)); Split; [Intros; Simpl; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Unfold fct_cte; Right; Reflexivity | Rewrite StepFun_P18; Rewrite Rmult_Ol; Rewrite Rabsolu_R0; Apply (cond_pos eps)].
-Qed.
-
-Lemma RiemannInt_P15 : (a,b,c:R;pr:(Riemann_integrable (fct_cte c) a b)) ``(RiemannInt pr)==c*(b-a)``.
-Intros; Unfold RiemannInt; Case (RiemannInt_exists 1!(fct_cte c) 2!a 3!b pr 5!RinvN RinvN_cv); Intros; EApply UL_sequence.
-Apply u.
-Pose phi1 := [N:nat](phi_sequence RinvN 2!(fct_cte c) 3!a 4!b pr N); Change (Un_cv [N:nat](RiemannInt_SF (phi1 N)) ``c*(b-a)``); Pose f := (fct_cte c); Assert H1 : (EXT psi1:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((f t)-([(phi_sequence RinvN pr n)] t)))<= (psi1 n t)``)/\``(Rabsolu (RiemannInt_SF (psi1 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr n)).
-Elim H1; Clear H1; Intros psi1 H1; Pose phi2 := [n:nat](mkStepFun (StepFun_P4 a b c)); Pose psi2 := [n:nat](mkStepFun (StepFun_P4 a b R0)); Apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; Try Assumption.
-Apply RinvN_cv.
-Intro; Split.
-Intros; Unfold f; Simpl; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Unfold fct_cte; Right; Reflexivity.
-Unfold psi2; Rewrite StepFun_P18; Rewrite Rmult_Ol; Rewrite Rabsolu_R0; Apply (cond_pos (RinvN n)).
-Unfold Un_cv; Intros; Split with O; Intros; Unfold R_dist; Unfold phi2; Rewrite StepFun_P18; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply H.
-Qed.
-
-Lemma RiemannInt_P16 : (f:R->R;a,b:R) (Riemann_integrable f a b) -> (Riemann_integrable [x:R](Rabsolu (f x)) a b).
-Unfold Riemann_integrable; Intro f; Intros; Elim (X eps); Clear X; Intros phi [psi [H H0]]; Split with (mkStepFun (StepFun_P32 phi)); Split with psi; Split; Try Assumption; Intros; Simpl; Apply Rle_trans with ``(Rabsolu ((f t)-(phi t)))``; [Apply Rabsolu_triang_inv2 | Apply H; Assumption].
-Qed.
-
-Lemma Rle_cv_lim : (Un,Vn:nat->R;l1,l2:R) ((n:nat)``(Un n)<=(Vn n)``) -> (Un_cv Un l1) -> (Un_cv Vn l2) -> ``l1<=l2``.
-Intros; Case (total_order_Rle l1 l2); Intro.
-Assumption.
-Assert H2 : ``l2<l1``.
-Auto with real.
-Clear n; Assert H3 : ``0<(l1-l2)/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply Rlt_Rminus; Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H1 ? H3); Elim (H0 ? H3); Clear H0 H1; Unfold R_dist; Intros; Pose N := (max x x0); Cut ``(Vn N)<(Un N)``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? (H N) H4)).
-Apply Rlt_trans with ``(l1+l2)/2``.
-Apply Rlt_anti_compatibility with ``-l2``; Replace ``-l2+(l1+l2)/2`` with ``(l1-l2)/2``.
-Rewrite Rplus_sym; Apply Rle_lt_trans with ``(Rabsolu ((Vn N)-l2))``.
-Apply Rle_Rabsolu.
-Apply H1; Unfold ge; Unfold N; Apply le_max_r.
-Apply r_Rmult_mult with ``2``; [Unfold Rdiv; Do 2 Rewrite -> (Rmult_sym ``2``); Rewrite (Rmult_Rplus_distrl ``-l2`` ``(l1+l2)*/2`` ``2``); Repeat Rewrite -> Rmult_assoc; Rewrite <- Rinv_l_sym; [ Ring | DiscrR ] | DiscrR].
-Apply Ropp_Rlt; Apply Rlt_anti_compatibility with l1; Replace ``l1+ -((l1+l2)/2)`` with ``(l1-l2)/2``.
-Apply Rle_lt_trans with ``(Rabsolu ((Un N)-l1))``.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply Rle_Rabsolu.
-Apply H0; Unfold ge; Unfold N; Apply le_max_l.
-Apply r_Rmult_mult with ``2``; [Unfold Rdiv; Do 2 Rewrite -> (Rmult_sym ``2``); Rewrite (Rmult_Rplus_distrl ``l1`` ``-((l1+l2)*/2)`` ``2``); Rewrite <- Ropp_mul1; Repeat Rewrite -> Rmult_assoc; Rewrite <- Rinv_l_sym; [ Ring | DiscrR ] | DiscrR].
-Qed.
-
-Lemma RiemannInt_P17 : (f:R->R;a,b:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable [x:R](Rabsolu (f x)) a b)) ``a<=b`` -> ``(Rabsolu (RiemannInt pr1))<=(RiemannInt pr2)``.
-Intro f; Intros; Unfold RiemannInt; Case (RiemannInt_exists 1!f 2!a 3!b pr1 5!RinvN RinvN_cv); Case (RiemannInt_exists 1!([x0:R](Rabsolu (f x0))) 2!a 3!b pr2 5!RinvN RinvN_cv); Intros; LetTac phi1 := (phi_sequence RinvN pr1) in u0; Pose phi2 := [N:nat](mkStepFun (StepFun_P32 (phi1 N))); Apply Rle_cv_lim with [N:nat](Rabsolu (RiemannInt_SF (phi1 N))) [N:nat](RiemannInt_SF (phi2 N)).
-Intro; Unfold phi2; Apply StepFun_P34; Assumption.
-Apply (continuity_seq Rabsolu [N:nat](RiemannInt_SF (phi1 N)) x0); Try Assumption.
-Apply continuity_Rabsolu.
-Pose phi3 := (phi_sequence RinvN pr2); Assert H0 : (EXT psi3:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((Rabsolu (f t))-((phi3 n) t)))<= (psi3 n t)``)/\``(Rabsolu (RiemannInt_SF (psi3 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr2 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr2 n)). 
-Assert H1 : (EXT psi2:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((Rabsolu (f t))-((phi2 n) t)))<= (psi2 n t)``)/\``(Rabsolu (RiemannInt_SF (psi2 n))) < (RinvN n)``).
-Assert H1 : (EXT psi2:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((f t)-((phi1 n) t)))<= (psi2 n t)``)/\``(Rabsolu (RiemannInt_SF (psi2 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr1 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr1 n)).
-Elim H1; Clear H1; Intros psi2 H1; Split with psi2; Intros; Elim (H1 n); Clear H1; Intros; Split; Try Assumption.
-Intros; Unfold phi2; Simpl; Apply Rle_trans with ``(Rabsolu ((f t)-((phi1 n) t)))``.
-Apply Rabsolu_triang_inv2.
-Apply H1; Assumption.
-Elim H0; Clear H0; Intros psi3 H0; Elim H1; Clear H1; Intros psi2 H1; Apply RiemannInt_P11 with [x:R](Rabsolu (f x)) RinvN phi3 psi3 psi2; Try Assumption; Apply RinvN_cv.
-Qed.
-
-Lemma RiemannInt_P18 : (f,g:R->R;a,b:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable g a b)) ``a<=b`` -> ((x:R)``a<x<b``->``(f x)==(g x)``) -> ``(RiemannInt pr1)==(RiemannInt pr2)``.
-Intro f; Intros; Unfold RiemannInt; Case (RiemannInt_exists 1!f 2!a 3!b pr1 5!RinvN RinvN_cv); Case (RiemannInt_exists 1!g 2!a 3!b pr2 5!RinvN RinvN_cv); Intros; EApply UL_sequence.
-Apply u0.
-Pose phi1 := [N:nat](phi_sequence RinvN 2!f 3!a 4!b pr1 N); Change (Un_cv [N:nat](RiemannInt_SF (phi1 N)) x); Assert H1 : (EXT psi1:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((f t)-((phi1 n) t)))<= (psi1 n t)``)/\``(Rabsolu (RiemannInt_SF (psi1 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr1 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr1 n)). 
-Elim H1; Clear H1; Intros psi1 H1; Pose phi2 := [N:nat](phi_sequence RinvN 2!g 3!a 4!b pr2 N).
-Pose phi2_aux := [N:nat][x:R](Cases (Req_EM_T x a) of
-    | (leftT _) => (f a)
-    | (rightT _) => (Cases (Req_EM_T x b) of
-	| (leftT _) => (f b)
-	| (rightT _) => (phi2 N x) end) end).
-Cut (N:nat)(IsStepFun (phi2_aux N) a b).
-Intro; Pose phi2_m := [N:nat](mkStepFun (X N)).
-Assert H2 : (EXT psi2:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((g t)-((phi2 n) t)))<= (psi2 n t)``)/\``(Rabsolu (RiemannInt_SF (psi2 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr2 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr2 n)). 
-Elim H2; Clear H2; Intros psi2 H2; Apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; Try Assumption. 
-Apply RinvN_cv.
-Intro; Elim (H2 n); Intros; Split; Try Assumption.
-Intros; Unfold phi2_m; Simpl; Unfold phi2_aux; Case (Req_EM_T t a); Case (Req_EM_T t b); Intros.
-Rewrite e0; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply Rle_trans with ``(Rabsolu ((g t)-((phi2 n) t)))``.
-Apply Rabsolu_pos.
-Pattern 3 a; Rewrite <- e0; Apply H3; Assumption.
-Rewrite e; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply Rle_trans with ``(Rabsolu ((g t)-((phi2 n) t)))``.
-Apply Rabsolu_pos.
-Pattern 3 a; Rewrite <- e; Apply H3; Assumption.
-Rewrite e; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply Rle_trans with ``(Rabsolu ((g t)-((phi2 n) t)))``.
-Apply Rabsolu_pos.
-Pattern 3 b; Rewrite <- e; Apply H3; Assumption.
-Replace (f t) with (g t).
-Apply H3; Assumption.
-Symmetry; Apply H0; Elim H5; Clear H5; Intros.
-Assert H7 : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n2; Assumption].
-Assert H8 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n2; Assumption].
-Rewrite H7 in H5; Rewrite H8 in H6; Split.
-Elim H5; Intro; [Assumption | Elim n1; Symmetry; Assumption].
-Elim H6; Intro; [Assumption | Elim n0; Assumption].
-Cut (N:nat)(RiemannInt_SF (phi2_m N))==(RiemannInt_SF (phi2 N)).
-Intro; Unfold Un_cv; Intros; Elim (u ? H4); Intros; Exists x1; Intros; Rewrite (H3 n); Apply H5; Assumption.
-Intro; Apply Rle_antisym.
-Apply StepFun_P37; Try Assumption.
-Intros; Unfold phi2_m; Simpl; Unfold phi2_aux; Case (Req_EM_T x1 a); Case (Req_EM_T x1 b); Intros.
-Elim H3; Intros; Rewrite e0 in H4; Elim (Rlt_antirefl ? H4).
-Elim H3; Intros; Rewrite e in H4; Elim (Rlt_antirefl ? H4).
-Elim H3; Intros; Rewrite e in H5; Elim (Rlt_antirefl ? H5).
-Right; Reflexivity.
-Apply StepFun_P37; Try Assumption.
-Intros; Unfold phi2_m; Simpl; Unfold phi2_aux; Case (Req_EM_T x1 a); Case (Req_EM_T x1 b); Intros.
-Elim H3; Intros; Rewrite e0 in H4; Elim (Rlt_antirefl ? H4).
-Elim H3; Intros; Rewrite e in H4; Elim (Rlt_antirefl ? H4).
-Elim H3; Intros; Rewrite e in H5; Elim (Rlt_antirefl ? H5).
-Right; Reflexivity.
-Intro; Assert H2 := (pre (phi2 N)); Unfold IsStepFun in H2; Unfold is_subdivision in H2; Elim H2; Clear H2; Intros l [lf H2]; Split with l; Split with lf; Unfold adapted_couple in H2; Decompose [and] H2; Clear H2; Unfold adapted_couple; Repeat Split; Try Assumption.
-Intros; Assert H9 := (H8 i H2); Unfold constant_D_eq open_interval in H9; Unfold constant_D_eq open_interval; Intros; Rewrite <- (H9 x1 H7); Assert H10 : ``a<=(pos_Rl l i)``.
-Replace a with (Rmin a b).
-Rewrite <- H5; Elim (RList_P6 l); Intros; Apply H10.
-Assumption.
-Apply le_O_n.
-Apply lt_trans with (pred (Rlength l)); [Assumption | Apply lt_pred_n_n].
-Apply neq_O_lt; Intro; Rewrite <- H12 in H6; Discriminate.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Assert H11 : ``(pos_Rl l (S i))<=b``.
-Replace b with (Rmax a b).
-Rewrite <- H4; Elim (RList_P6 l); Intros; Apply H11.
-Assumption.
-Apply lt_le_S; Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Intro; Rewrite <- H13 in H6; Discriminate.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Elim H7; Clear H7; Intros; Unfold phi2_aux; Case (Req_EM_T x1 a); Case (Req_EM_T x1 b); Intros.
-Rewrite e in H12; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H11 H12)).
-Rewrite e in H7; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H10 H7)).
-Rewrite e in H12; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H11 H12)).
-Reflexivity.
-Qed.
-
-Lemma RiemannInt_P19 : (f,g:R->R;a,b:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable g a b)) ``a<=b`` -> ((x:R)``a<x<b``->``(f x)<=(g x)``) -> ``(RiemannInt pr1)<=(RiemannInt pr2)``.
-Intro f; Intros; Apply Rle_anti_compatibility with ``-(RiemannInt pr1)``; Rewrite Rplus_Ropp_l; Rewrite Rplus_sym; Apply Rle_trans with (Rabsolu (RiemannInt (RiemannInt_P10 ``-1`` pr2 pr1))).
-Apply Rabsolu_pos.
-Replace ``(RiemannInt pr2)+ -(RiemannInt pr1)`` with (RiemannInt (RiemannInt_P16 (RiemannInt_P10 ``-1`` pr2 pr1))).
-Apply (RiemannInt_P17 (RiemannInt_P10 ``-1`` pr2 pr1) (RiemannInt_P16 (RiemannInt_P10 ``-1`` pr2 pr1))); Assumption.
-Replace ``(RiemannInt pr2)+-(RiemannInt pr1)`` with (RiemannInt (RiemannInt_P10 ``-1`` pr2 pr1)).
-Apply RiemannInt_P18; Try Assumption.
-Intros; Apply Rabsolu_right.
-Apply Rle_sym1; Apply Rle_anti_compatibility with (f x); Rewrite Rplus_Or; Replace ``(f x)+((g x)+ -1*(f x))`` with (g x); [Apply H0; Assumption | Ring].
-Rewrite (RiemannInt_P12 pr2 pr1 (RiemannInt_P10 ``-1`` pr2 pr1)); [Ring | Assumption].
-Qed.
-
-Lemma FTC_P1 : (f:R->R;a,b:R) ``a<=b`` -> ((x:R)``a<=x<=b``->(continuity_pt f x)) -> ((x:R)``a<=x``->``x<=b``->(Riemann_integrable f a x)).
-Intros; Apply continuity_implies_RiemannInt; [Assumption | Intros; Apply H0; Elim H3; Intros; Split; Assumption Orelse Apply Rle_trans with x; Assumption].
-Qed.
-V7only [Notation FTC_P2 := Rle_refl.].
-
-Definition primitive [f:R->R;a,b:R;h:``a<=b``;pr:((x:R)``a<=x``->``x<=b``->(Riemann_integrable f a x))] : R->R := [x:R] Cases (total_order_Rle a x) of
-   | (leftT r) => Cases (total_order_Rle x b) of
-          | (leftT r0) => (RiemannInt (pr x r r0))
-          | (rightT _) => ``(f b)*(x-b)+(RiemannInt (pr b h (FTC_P2 b)))`` end
-   | (rightT _) => ``(f a)*(x-a)`` end.
-
-Lemma RiemannInt_P20 : (f:R->R;a,b:R;h:``a<=b``;pr:((x:R)``a<=x``->``x<=b``->(Riemann_integrable f a x));pr0:(Riemann_integrable f a b)) ``(RiemannInt pr0)==(primitive h pr b)-(primitive h pr a)``.
-Intros; Replace (primitive h pr a) with R0.
-Replace (RiemannInt pr0) with (primitive h pr b).
-Ring.
-Unfold primitive; Case (total_order_Rle a b); Case (total_order_Rle b b); Intros; [Apply RiemannInt_P5 | Elim n; Right; Reflexivity | Elim n; Assumption | Elim n0; Assumption].
-Symmetry; Unfold primitive; Case (total_order_Rle a a); Case (total_order_Rle a b); Intros; [Apply RiemannInt_P9 | Elim n; Assumption | Elim n; Right; Reflexivity | Elim n0; Right; Reflexivity].
-Qed.
-
-Lemma RiemannInt_P21 : (f:R->R;a,b,c:R) ``a<=b``-> ``b<=c`` -> (Riemann_integrable f a b) -> (Riemann_integrable f b c) -> (Riemann_integrable f a c).
-Unfold Riemann_integrable; Intros f a b c Hyp1 Hyp2 X X0 eps.
-Assert H : ``0<eps/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos eps) | Apply Rlt_Rinv; Sup0].
-Elim (X (mkposreal ? H)); Clear X; Intros phi1 [psi1 H1]; Elim (X0 (mkposreal ? H)); Clear X0; Intros phi2 [psi2 H2].
-Pose phi3 := [x:R] Cases (total_order_Rle a x) of
-  | (leftT _) => Cases (total_order_Rle x b) of
-    | (leftT _) => (phi1 x)
-    | (rightT _) => (phi2 x) end
-  | (rightT _) => R0 end.
-Pose psi3 := [x:R] Cases (total_order_Rle a x) of
-  | (leftT _) => Cases (total_order_Rle x b) of
-    | (leftT _) => (psi1 x)
-    | (rightT _) => (psi2 x) end
-  | (rightT _) => R0 end.
-Cut (IsStepFun phi3 a c).
-Intro; Cut (IsStepFun psi3 a b).
-Intro; Cut (IsStepFun psi3 b c).
-Intro; Cut (IsStepFun psi3 a c).
-Intro; Split with (mkStepFun X); Split with (mkStepFun X2); Simpl; Split.
-Intros; Unfold phi3 psi3; Case (total_order_Rle t b); Case (total_order_Rle a t); Intros.
-Elim H1; Intros; Apply H3.
-Replace (Rmin a b) with a.
-Replace (Rmax a b) with b.
-Split; Assumption.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Elim n; Replace a with (Rmin a c).
-Elim H0; Intros; Assumption.
-Unfold Rmin; Case (total_order_Rle a c); Intro; [Reflexivity | Elim n0; Apply Rle_trans with b; Assumption].
-Elim H2; Intros; Apply H3.
-Replace (Rmax b c) with (Rmax a c).
-Elim H0; Intros; Split; Try Assumption.
-Replace (Rmin b c) with b.
-Auto with real.
-Unfold Rmin; Case (total_order_Rle b c); Intro; [Reflexivity | Elim n0; Assumption].
-Unfold Rmax; Case (total_order_Rle a c); Case (total_order_Rle b c); Intros; Try (Elim n0; Assumption Orelse Elim n0; Apply Rle_trans with b; Assumption).
-Reflexivity.
-Elim n; Replace a with (Rmin a c).
-Elim H0; Intros; Assumption.
-Unfold Rmin; Case (total_order_Rle a c); Intro; [Reflexivity | Elim n1; Apply Rle_trans with b; Assumption].
-Rewrite <- (StepFun_P43 X0 X1 X2).
-Apply Rle_lt_trans with ``(Rabsolu (RiemannInt_SF (mkStepFun X0)))+(Rabsolu (RiemannInt_SF (mkStepFun X1)))``.
-Apply Rabsolu_triang.
-Rewrite (double_var eps); Replace (RiemannInt_SF (mkStepFun X0)) with (RiemannInt_SF psi1).
-Replace (RiemannInt_SF (mkStepFun X1)) with (RiemannInt_SF psi2).
-Apply Rplus_lt.
-Elim H1; Intros; Assumption.
-Elim H2; Intros; Assumption.
-Apply Rle_antisym.
-Apply StepFun_P37; Try Assumption.
-Simpl; Intros; Unfold psi3; Elim H0; Clear H0; Intros; Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; [Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H0)) | Right; Reflexivity | Elim n; Apply Rle_trans with b; [Assumption | Left; Assumption] | Elim n0; Apply Rle_trans with b; [Assumption | Left; Assumption]].
-Apply StepFun_P37; Try Assumption.
-Simpl; Intros; Unfold psi3; Elim H0; Clear H0; Intros; Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; [Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H0)) | Right; Reflexivity | Elim n; Apply Rle_trans with b; [Assumption | Left; Assumption] | Elim n0; Apply Rle_trans with b; [Assumption | Left; Assumption]].
-Apply Rle_antisym.
-Apply StepFun_P37; Try Assumption.
-Simpl; Intros; Unfold psi3; Elim H0; Clear H0; Intros; Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; [Right; Reflexivity | Elim n; Left; Assumption | Elim n; Left; Assumption | Elim n0; Left; Assumption].
-Apply StepFun_P37; Try Assumption.
-Simpl; Intros; Unfold psi3; Elim H0; Clear H0; Intros; Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; [Right; Reflexivity | Elim n; Left; Assumption | Elim n; Left; Assumption | Elim n0; Left; Assumption].
-Apply StepFun_P46 with b; Assumption.
-Assert H3 := (pre psi2); Unfold IsStepFun in H3; Unfold is_subdivision in H3; Elim H3; Clear H3; Intros l1 [lf1 H3]; Split with l1; Split with lf1; Unfold adapted_couple in H3; Decompose [and] H3; Clear H3; Unfold adapted_couple; Repeat Split; Try Assumption.
-Intros; Assert H9 := (H8 i H3); Unfold constant_D_eq open_interval; Unfold constant_D_eq open_interval in H9; Intros; Rewrite <- (H9 x H7); Unfold psi3; Assert H10 : ``b<x``.
-Apply Rle_lt_trans with (pos_Rl l1 i).
-Replace b with (Rmin b c).
-Rewrite <- H5; Elim (RList_P6 l1); Intros; Apply H10; Try Assumption.
-Apply le_O_n.
-Apply lt_trans with (pred (Rlength l1)); Try Assumption; Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H12 in H6; Discriminate. 
-Unfold Rmin; Case (total_order_Rle b c); Intro; [Reflexivity | Elim n; Assumption].
-Elim H7; Intros; Assumption.
-Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; [Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H10)) | Reflexivity | Elim n; Apply Rle_trans with b; [Assumption | Left; Assumption] | Elim n0; Apply Rle_trans with b; [Assumption | Left; Assumption]].
-Assert H3 := (pre psi1); Unfold IsStepFun in H3; Unfold is_subdivision in H3; Elim H3; Clear H3; Intros l1 [lf1 H3]; Split with l1; Split with lf1; Unfold adapted_couple in H3; Decompose [and] H3; Clear H3; Unfold adapted_couple; Repeat Split; Try Assumption.
-Intros; Assert H9 := (H8 i H3); Unfold constant_D_eq open_interval; Unfold constant_D_eq open_interval in H9; Intros; Rewrite <- (H9 x H7); Unfold psi3; Assert H10 : ``x<=b``.
-Apply Rle_trans with (pos_Rl l1 (S i)).
-Elim H7; Intros; Left; Assumption.
-Replace b with (Rmax a b).
-Rewrite <- H4; Elim (RList_P6 l1); Intros; Apply H10; Try Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H12 in H6; Discriminate. 
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Assert H11 : ``a<=x``.
-Apply Rle_trans with (pos_Rl l1 i).
-Replace a with (Rmin a b).
-Rewrite <- H5; Elim (RList_P6 l1); Intros; Apply H11; Try Assumption.
-Apply le_O_n.
-Apply lt_trans with (pred (Rlength l1)); Try Assumption; Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H6; Discriminate. 
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Left; Elim H7; Intros; Assumption.
-Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; Reflexivity Orelse Elim n; Assumption.
-Apply StepFun_P46 with b.
-Assert H3 := (pre phi1); Unfold IsStepFun in H3; Unfold is_subdivision in H3; Elim H3; Clear H3; Intros l1 [lf1 H3]; Split with l1; Split with lf1; Unfold adapted_couple in H3; Decompose [and] H3; Clear H3; Unfold adapted_couple; Repeat Split; Try Assumption.
-Intros; Assert H9 := (H8 i H3); Unfold constant_D_eq open_interval; Unfold constant_D_eq open_interval in H9; Intros; Rewrite <- (H9 x H7); Unfold psi3; Assert H10 : ``x<=b``.
-Apply Rle_trans with (pos_Rl l1 (S i)).
-Elim H7; Intros; Left; Assumption.
-Replace b with (Rmax a b).
-Rewrite <- H4; Elim (RList_P6 l1); Intros; Apply H10; Try Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H12 in H6; Discriminate. 
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Assert H11 : ``a<=x``.
-Apply Rle_trans with (pos_Rl l1 i).
-Replace a with (Rmin a b).
-Rewrite <- H5; Elim (RList_P6 l1); Intros; Apply H11; Try Assumption.
-Apply le_O_n.
-Apply lt_trans with (pred (Rlength l1)); Try Assumption; Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H6; Discriminate. 
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Left; Elim H7; Intros; Assumption.
-Unfold phi3; Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; Reflexivity Orelse Elim n; Assumption.
-Assert H3 := (pre phi2); Unfold IsStepFun in H3; Unfold is_subdivision in H3; Elim H3; Clear H3; Intros l1 [lf1 H3]; Split with l1; Split with lf1; Unfold adapted_couple in H3; Decompose [and] H3; Clear H3; Unfold adapted_couple; Repeat Split; Try Assumption.
-Intros; Assert H9 := (H8 i H3); Unfold constant_D_eq open_interval; Unfold constant_D_eq open_interval in H9; Intros; Rewrite <- (H9 x H7); Unfold psi3; Assert H10 : ``b<x``.
-Apply Rle_lt_trans with (pos_Rl l1 i).
-Replace b with (Rmin b c).
-Rewrite <- H5; Elim (RList_P6 l1); Intros; Apply H10; Try Assumption.
-Apply le_O_n.
-Apply lt_trans with (pred (Rlength l1)); Try Assumption; Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H12 in H6; Discriminate. 
-Unfold Rmin; Case (total_order_Rle b c); Intro; [Reflexivity | Elim n; Assumption].
-Elim H7; Intros; Assumption.
-Unfold phi3; Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; [Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H10)) | Reflexivity | Elim n; Apply Rle_trans with b; [Assumption | Left; Assumption] | Elim n0; Apply Rle_trans with b; [Assumption | Left; Assumption]].
-Qed.
-
-Lemma RiemannInt_P22 : (f:R->R;a,b,c:R) (Riemann_integrable f a b) -> ``a<=c<=b`` -> (Riemann_integrable f a c).
-Unfold Riemann_integrable; Intros; Elim (X eps); Clear X; Intros phi [psi H0]; Elim H; Elim H0; Clear H H0; Intros; Assert H3 : (IsStepFun phi a c).
-Apply StepFun_P44 with b.
-Apply (pre phi).
-Split; Assumption.
-Assert H4 : (IsStepFun psi a c).
-Apply StepFun_P44 with b.
-Apply (pre psi).
-Split; Assumption.
-Split with (mkStepFun H3); Split with (mkStepFun H4); Split.
-Simpl; Intros; Apply H.
-Replace (Rmin a b) with (Rmin a c).
-Elim H5; Intros; Split; Try Assumption.
-Apply Rle_trans with (Rmax a c); Try Assumption.
-Replace (Rmax a b) with b.
-Replace (Rmax a c) with c.
-Assumption.
-Unfold Rmax; Case (total_order_Rle a c); Intro; [Reflexivity | Elim n; Assumption].
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Unfold Rmin; Case (total_order_Rle a c); Case (total_order_Rle a b); Intros; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption | Elim n; Assumption | Elim n0; Assumption].
-Rewrite Rabsolu_right.
-Assert H5 : (IsStepFun psi c b).
-Apply StepFun_P46 with a.
-Apply StepFun_P6; Assumption.
-Apply (pre psi).
-Replace (RiemannInt_SF (mkStepFun H4)) with ``(RiemannInt_SF psi)-(RiemannInt_SF (mkStepFun H5))``.
-Apply Rle_lt_trans with (RiemannInt_SF psi).
-Unfold Rminus; Pattern 2 (RiemannInt_SF psi); Rewrite <- Rplus_Or; Apply Rle_compatibility; Rewrite <- Ropp_O; Apply Rge_Ropp; Apply Rle_sym1; Replace R0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b R0))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Unfold fct_cte; Apply Rle_trans with ``(Rabsolu ((f x)-(phi x)))``.
-Apply Rabsolu_pos.
-Apply H.
-Replace (Rmin a b) with a.
-Replace (Rmax a b) with b.
-Elim H6; Intros; Split; Left.
-Apply Rle_lt_trans with c; Assumption.
-Assumption.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Rewrite StepFun_P18; Ring.
-Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF psi)).
-Apply Rle_Rabsolu.
-Assumption.
-Assert H6 : (IsStepFun psi a b).
-Apply (pre psi).
-Replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
-Rewrite <- (StepFun_P43 H4 H5 H6); Ring.
-Unfold RiemannInt_SF; Case (total_order_Rle a b); Intro.
-EApply StepFun_P17.
-Apply StepFun_P1.
-Simpl; Apply StepFun_P1.
-Apply eq_Ropp; EApply StepFun_P17.
-Apply StepFun_P1.
-Simpl; Apply StepFun_P1.
-Apply Rle_sym1; Replace R0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c R0))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Unfold fct_cte; Apply Rle_trans with ``(Rabsolu ((f x)-(phi x)))``.
-Apply Rabsolu_pos.
-Apply H.
-Replace (Rmin a b) with a.
-Replace (Rmax a b) with b.
-Elim H5; Intros; Split; Left.
-Assumption.
-Apply Rlt_le_trans with c; Assumption.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Rewrite StepFun_P18; Ring.
-Qed.
-
-Lemma RiemannInt_P23 : (f:R->R;a,b,c:R) (Riemann_integrable f a b) -> ``a<=c<=b`` -> (Riemann_integrable f c b).
-Unfold Riemann_integrable; Intros; Elim (X eps); Clear X; Intros phi [psi H0]; Elim H; Elim H0; Clear H H0; Intros; Assert H3 : (IsStepFun phi c b).
-Apply StepFun_P45 with a.
-Apply (pre phi).
-Split; Assumption.
-Assert H4 : (IsStepFun psi c b).
-Apply StepFun_P45 with a.
-Apply (pre psi).
-Split; Assumption.
-Split with (mkStepFun H3); Split with (mkStepFun H4); Split.
-Simpl; Intros; Apply H.
-Replace (Rmax a b) with (Rmax c b).
-Elim H5; Intros; Split; Try Assumption.
-Apply Rle_trans with (Rmin c b); Try Assumption.
-Replace (Rmin a b) with a.
-Replace (Rmin c b) with c.
-Assumption.
-Unfold Rmin; Case (total_order_Rle c b); Intro; [Reflexivity | Elim n; Assumption].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Unfold Rmax; Case (total_order_Rle c b); Case (total_order_Rle a b); Intros; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption | Elim n; Assumption | Elim n0; Assumption].
-Rewrite Rabsolu_right.
-Assert H5 : (IsStepFun psi a c).
-Apply StepFun_P46 with b.
-Apply (pre psi).
-Apply StepFun_P6; Assumption.
-Replace (RiemannInt_SF (mkStepFun H4)) with ``(RiemannInt_SF psi)-(RiemannInt_SF (mkStepFun H5))``.
-Apply Rle_lt_trans with (RiemannInt_SF psi).
-Unfold Rminus; Pattern 2 (RiemannInt_SF psi); Rewrite <- Rplus_Or; Apply Rle_compatibility; Rewrite <- Ropp_O; Apply Rge_Ropp; Apply Rle_sym1; Replace R0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c R0))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Unfold fct_cte; Apply Rle_trans with ``(Rabsolu ((f x)-(phi x)))``.
-Apply Rabsolu_pos.
-Apply H.
-Replace (Rmin a b) with a.
-Replace (Rmax a b) with b.
-Elim H6; Intros; Split; Left.
-Assumption.
-Apply Rlt_le_trans with c; Assumption.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Rewrite StepFun_P18; Ring.
-Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF psi)).
-Apply Rle_Rabsolu.
-Assumption.
-Assert H6 : (IsStepFun psi a b).
-Apply (pre psi).
-Replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
-Rewrite <- (StepFun_P43 H5 H4 H6); Ring.
-Unfold RiemannInt_SF; Case (total_order_Rle a b); Intro.
-EApply StepFun_P17.
-Apply StepFun_P1.
-Simpl; Apply StepFun_P1.
-Apply eq_Ropp; EApply StepFun_P17.
-Apply StepFun_P1.
-Simpl; Apply StepFun_P1.
-Apply Rle_sym1; Replace R0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b R0))).
-Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Unfold fct_cte; Apply Rle_trans with ``(Rabsolu ((f x)-(phi x)))``.
-Apply Rabsolu_pos.
-Apply H.
-Replace (Rmin a b) with a.
-Replace (Rmax a b) with b.
-Elim H5; Intros; Split; Left.
-Apply Rle_lt_trans with c; Assumption.
-Assumption.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Apply Rle_trans with c; Assumption].
-Rewrite StepFun_P18; Ring.
-Qed.
-
-Lemma RiemannInt_P24 : (f:R->R;a,b,c:R) (Riemann_integrable f a b) -> (Riemann_integrable f b c) -> (Riemann_integrable f a c).
-Intros; Case (total_order_Rle a b); Case (total_order_Rle b c); Intros.
-Apply RiemannInt_P21 with b; Assumption.
-Case (total_order_Rle a c); Intro.
-Apply RiemannInt_P22 with b; Try Assumption.
-Split; [Assumption | Auto with real].
-Apply RiemannInt_P1; Apply RiemannInt_P22 with b.
-Apply RiemannInt_P1; Assumption.
-Split; Auto with real.
-Case (total_order_Rle a c); Intro.
-Apply RiemannInt_P23 with b; Try Assumption.
-Split; Auto with real.
-Apply RiemannInt_P1; Apply RiemannInt_P23 with b.
-Apply RiemannInt_P1; Assumption.
-Split; [Assumption | Auto with real].
-Apply RiemannInt_P1; Apply RiemannInt_P21 with b; Auto with real Orelse Apply RiemannInt_P1; Assumption.
-Qed.
-
-Lemma RiemannInt_P25 : (f:R->R;a,b,c:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable f b c);pr3:(Riemann_integrable f a c)) ``a<=b``->``b<=c``->``(RiemannInt pr1)+(RiemannInt pr2)==(RiemannInt pr3)``.
-Intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; Unfold RiemannInt; Case (RiemannInt_exists 1!f 2!a 3!b pr1 5!RinvN RinvN_cv); Case (RiemannInt_exists 1!f 2!b 3!c pr2 5!RinvN RinvN_cv); Case (RiemannInt_exists 1!f 2!a 3!c pr3 5!RinvN RinvN_cv); Intros; Symmetry; EApply UL_sequence.
-Apply u.
-Unfold Un_cv; Intros; Assert H0 : ``0<eps/3``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (u1 ? H0); Clear u1; Intros N1 H1; Elim (u0 ? H0); Clear u0; Intros N2 H2; Cut (Un_cv [n:nat]``(RiemannInt_SF [(phi_sequence RinvN pr3 n)])-((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))`` R0).
-Intro; Elim (H3 ? H0); Clear H3; Intros N3 H3; Pose N0 := (max (max N1 N2) N3); Exists N0; Intros; Unfold R_dist; Apply Rle_lt_trans with ``(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr3 n)])-((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))))+(Rabsolu (((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))-(x1+x0)))``.
-Replace ``(RiemannInt_SF [(phi_sequence RinvN pr3 n)])-(x1+x0)`` with ``((RiemannInt_SF [(phi_sequence RinvN pr3 n)])-((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(RiemannInt_SF [(phi_sequence RinvN pr2 n)])))+(((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))-(x1+x0))``; [Apply Rabsolu_triang | Ring].
-Replace eps with ``eps/3+eps/3+eps/3``.
-Rewrite Rplus_assoc; Apply Rplus_lt.
-Unfold R_dist in H3; Cut (ge n N3).
-Intro; Assert H6 := (H3 ? H5); Unfold Rminus in H6; Rewrite Ropp_O in H6; Rewrite Rplus_Or in H6; Apply H6.
-Unfold ge; Apply le_trans with N0; [Unfold N0; Apply le_max_r | Assumption].
-Apply Rle_lt_trans with ``(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr1 n)])-x1))+(Rabsolu ((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x0))``.
-Replace ``((RiemannInt_SF [(phi_sequence RinvN pr1 n)])+(RiemannInt_SF [(phi_sequence RinvN pr2 n)]))-(x1+x0)`` with ``((RiemannInt_SF [(phi_sequence RinvN pr1 n)])-x1)+((RiemannInt_SF [(phi_sequence RinvN pr2 n)])-x0)``; [Apply Rabsolu_triang | Ring].
-Apply Rplus_lt.
-Unfold R_dist in H1; Apply H1.
-Unfold ge; Apply le_trans with N0; [Apply le_trans with (max N1 N2); [Apply le_max_l | Unfold N0; Apply le_max_l] | Assumption].
-Unfold R_dist in H2; Apply H2.
-Unfold ge; Apply le_trans with N0; [Apply le_trans with (max N1 N2); [Apply le_max_r | Unfold N0; Apply le_max_l] | Assumption].
-Apply r_Rmult_mult with ``3``; [Unfold Rdiv; Repeat Rewrite Rmult_Rplus_distr; Do 2 Rewrite (Rmult_sym ``3``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | DiscrR] | DiscrR].
-Clear x u x0 x1 eps H H0 N1 H1 N2 H2; Assert H1 : (EXT psi1:nat->(StepFun a b) | (n:nat) ((t:R)``(Rmin a b) <= t``/\``t <= (Rmax a b)``->``(Rabsolu ((f t)-([(phi_sequence RinvN pr1 n)] t)))<= (psi1 n t)``)/\``(Rabsolu (RiemannInt_SF (psi1 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr1 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr1 n)). 
-Assert H2 : (EXT psi2:nat->(StepFun b c) | (n:nat) ((t:R)``(Rmin b c) <= t``/\``t <= (Rmax b c)``->``(Rabsolu ((f t)-([(phi_sequence RinvN pr2 n)] t)))<= (psi2 n t)``)/\``(Rabsolu (RiemannInt_SF (psi2 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr2 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr2 n)). 
-Assert H3 : (EXT psi3:nat->(StepFun a c) | (n:nat) ((t:R)``(Rmin a c) <= t``/\``t <= (Rmax a c)``->``(Rabsolu ((f t)-([(phi_sequence RinvN pr3 n)] t)))<= (psi3 n t)``)/\``(Rabsolu (RiemannInt_SF (psi3 n))) < (RinvN n)``).
-Split with [n:nat](projT1 ? ? (phi_sequence_prop RinvN pr3 n)); Intro; Apply (projT2 ? ? (phi_sequence_prop RinvN pr3 n)). 
-Elim H1; Clear H1; Intros psi1 H1; Elim H2; Clear H2; Intros psi2 H2; Elim H3; Clear H3; Intros psi3 H3; Assert H := RinvN_cv; Unfold Un_cv; Intros; Assert H4 : ``0<eps/3``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H ? H4); Clear H; Intros N0 H; Assert H5 : (n:nat)(ge n N0)->``(RinvN n)<eps/3``.
-Intros; Replace (pos (RinvN n)) with ``(R_dist (mkposreal (/((INR n)+1)) (RinvN_pos n)) 0)``.
-Apply H; Assumption.
-Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rabsolu_right; Apply Rle_sym1; Left; Apply (cond_pos (RinvN n)).
-Exists N0; Intros; Elim (H1 n); Elim (H2 n); Elim (H3 n); Clear H1 H2 H3; Intros; Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; LetTac phi1 := (phi_sequence RinvN pr1 n) in H8 Goal; LetTac phi2 := (phi_sequence RinvN pr2 n) in H3 Goal; LetTac phi3 := (phi_sequence RinvN pr3 n) in H1 Goal; Assert H10 : (IsStepFun phi3 a b).
-Apply StepFun_P44 with c.
-Apply (pre phi3).
-Split; Assumption.
-Assert H11 : (IsStepFun (psi3 n) a b).
-Apply StepFun_P44 with c.
-Apply (pre (psi3 n)).
-Split; Assumption.
-Assert H12 : (IsStepFun phi3 b c).
-Apply StepFun_P45 with a.
-Apply (pre phi3).
-Split; Assumption.
-Assert H13 : (IsStepFun (psi3 n) b c).
-Apply StepFun_P45 with a.
-Apply (pre (psi3 n)).
-Split; Assumption.
-Replace (RiemannInt_SF phi3) with ``(RiemannInt_SF (mkStepFun H10))+(RiemannInt_SF (mkStepFun H12))``.
-Apply Rle_lt_trans with ``(Rabsolu ((RiemannInt_SF (mkStepFun H10))-(RiemannInt_SF phi1)))+(Rabsolu ((RiemannInt_SF (mkStepFun H12))-(RiemannInt_SF phi2)))``.
-Replace ``(RiemannInt_SF (mkStepFun H10))+(RiemannInt_SF (mkStepFun H12))+ -((RiemannInt_SF phi1)+(RiemannInt_SF phi2))`` with ``((RiemannInt_SF (mkStepFun H10))-(RiemannInt_SF phi1))+((RiemannInt_SF (mkStepFun H12))-(RiemannInt_SF phi2))``; [Apply Rabsolu_triang | Ring].
-Replace ``(RiemannInt_SF (mkStepFun H10))-(RiemannInt_SF phi1)`` with (RiemannInt_SF (mkStepFun (StepFun_P28 ``-1`` (mkStepFun H10) phi1))).
-Replace ``(RiemannInt_SF (mkStepFun H12))-(RiemannInt_SF phi2)`` with (RiemannInt_SF (mkStepFun (StepFun_P28 ``-1`` (mkStepFun H12) phi2))).
-Apply Rle_lt_trans with ``(RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))))+(RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2)))))``.
-Apply Rle_trans with ``(Rabsolu (RiemannInt_SF (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1))))+(RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H12) phi2)))))``.
-Apply Rle_compatibility.
-Apply StepFun_P34; Try Assumption.
-Do 2 Rewrite <- (Rplus_sym (RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 ``-1`` (mkStepFun H12) phi2)))))); Apply Rle_compatibility; Apply StepFun_P34; Try Assumption.
-Apply Rle_lt_trans with ``(RiemannInt_SF (mkStepFun (StepFun_P28 R1 (mkStepFun H11) (psi1 n))))+(RiemannInt_SF (mkStepFun (StepFun_P28 R1 (mkStepFun H13) (psi2 n))))``.
-Apply Rle_trans with ``(RiemannInt_SF (mkStepFun (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))))+(RiemannInt_SF (mkStepFun (StepFun_P28 R1 (mkStepFun H13) (psi2 n))))``.
-Apply Rle_compatibility; Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Rewrite Rmult_1l; Apply Rle_trans with ``(Rabsolu ((f x)-(phi3 x)))+(Rabsolu ((f x)-(phi2 x)))``.
-Rewrite <- (Rabsolu_Ropp ``(f x)-(phi3 x)``); Rewrite Ropp_distr2; Replace ``(phi3 x)+ -1*(phi2 x)`` with ``((phi3 x)-(f x))+((f x)-(phi2 x))``; [Apply Rabsolu_triang | Ring].
-Apply Rplus_le.
-Apply H1.
-Elim H14; Intros; Split.
-Replace (Rmin a c) with a.
-Apply Rle_trans with b; Try Assumption.
-Left; Assumption.
-Unfold Rmin; Case (total_order_Rle a c); Intro; [Reflexivity | Elim n0; Apply Rle_trans with b; Assumption].
-Replace (Rmax a c) with c.
-Left; Assumption.
-Unfold Rmax; Case (total_order_Rle a c); Intro; [Reflexivity | Elim n0; Apply Rle_trans with b; Assumption].
-Apply H3.
-Elim H14; Intros; Split.
-Replace (Rmin b c) with b.
-Left; Assumption.
-Unfold Rmin; Case (total_order_Rle b c); Intro; [Reflexivity | Elim n0; Assumption].
-Replace (Rmax b c) with c.
-Left; Assumption.
-Unfold Rmax; Case (total_order_Rle b c); Intro; [Reflexivity | Elim n0; Assumption].
-Do 2 Rewrite <- (Rplus_sym ``(RiemannInt_SF (mkStepFun (StepFun_P28 R1 (mkStepFun H13) (psi2 n))))``); Apply Rle_compatibility; Apply StepFun_P37; Try Assumption.
-Intros; Simpl; Rewrite Rmult_1l; Apply Rle_trans with ``(Rabsolu ((f x)-(phi3 x)))+(Rabsolu ((f x)-(phi1 x)))``.
-Rewrite <- (Rabsolu_Ropp ``(f x)-(phi3 x)``); Rewrite Ropp_distr2; Replace ``(phi3 x)+ -1*(phi1 x)`` with ``((phi3 x)-(f x))+((f x)-(phi1 x))``; [Apply Rabsolu_triang | Ring].
-Apply Rplus_le.
-Apply H1.
-Elim H14; Intros; Split.
-Replace (Rmin a c) with a.
-Left; Assumption.
-Unfold Rmin; Case (total_order_Rle a c); Intro; [Reflexivity | Elim n0; Apply Rle_trans with b; Assumption].
-Replace (Rmax a c) with c.
-Apply Rle_trans with b.
-Left; Assumption.
-Assumption.
-Unfold Rmax; Case (total_order_Rle a c); Intro; [Reflexivity | Elim n0; Apply Rle_trans with b; Assumption].
-Apply H8.
-Elim H14; Intros; Split.
-Replace (Rmin a b) with a.
-Left; Assumption.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Replace (Rmax a b) with b.
-Left; Assumption.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n0; Assumption].
-Do 2 Rewrite StepFun_P30.
-Do 2 Rewrite Rmult_1l; Replace ``(RiemannInt_SF (mkStepFun H11))+(RiemannInt_SF (psi1 n))+((RiemannInt_SF (mkStepFun H13))+(RiemannInt_SF (psi2 n)))`` with ``(RiemannInt_SF (psi3 n))+(RiemannInt_SF (psi1 n))+(RiemannInt_SF (psi2 n))``.
-Replace eps with ``eps/3+eps/3+eps/3``.
-Repeat Rewrite Rplus_assoc; Repeat Apply Rplus_lt.
-Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi3 n))).
-Apply Rle_Rabsolu.
-Apply Rlt_trans with (pos (RinvN n)).
-Assumption.
-Apply H5; Assumption.
-Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi1 n))).
-Apply Rle_Rabsolu.
-Apply Rlt_trans with (pos (RinvN n)).
-Assumption.
-Apply H5; Assumption.
-Apply Rle_lt_trans with (Rabsolu (RiemannInt_SF (psi2 n))).
-Apply Rle_Rabsolu.
-Apply Rlt_trans with (pos (RinvN n)).
-Assumption.
-Apply H5; Assumption.
-Apply r_Rmult_mult with ``3``; [Unfold Rdiv; Repeat Rewrite Rmult_Rplus_distr; Do 2 Rewrite (Rmult_sym ``3``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | DiscrR] | DiscrR].
-Replace (RiemannInt_SF (psi3 n)) with (RiemannInt_SF (mkStepFun (pre (psi3 n)))).
-Rewrite <- (StepFun_P43 H11 H13 (pre (psi3 n))); Ring.
-Reflexivity.
-Rewrite StepFun_P30; Ring.
-Rewrite StepFun_P30; Ring.
-Apply (StepFun_P43 H10 H12 (pre phi3)).
-Qed.
-
-Lemma RiemannInt_P26 : (f:R->R;a,b,c:R;pr1:(Riemann_integrable f a b);pr2:(Riemann_integrable f b c);pr3:(Riemann_integrable f a c)) ``(RiemannInt pr1)+(RiemannInt pr2)==(RiemannInt pr3)``.
-Intros; Case (total_order_Rle a b); Case (total_order_Rle b c); Intros.
-Apply RiemannInt_P25; Assumption.
-Case (total_order_Rle a c); Intro.
-Assert H : ``c<=b``.
-Auto with real.
-Rewrite <- (RiemannInt_P25 pr3 (RiemannInt_P1 pr2) pr1 r0 H); Rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); Ring.
-Assert H : ``c<=a``.
-Auto with real.
-Rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); Rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr3) pr1 (RiemannInt_P1 pr2) H r); Rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); Ring.
-Assert H : ``b<=a``.
-Auto with real.
-Case (total_order_Rle a c); Intro.
-Rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr1) pr3 pr2 H r0); Rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); Ring.
-Assert H0 : ``c<=a``.
-Auto with real.
-Rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); Rewrite <- (RiemannInt_P25 pr2 (RiemannInt_P1 pr3) (RiemannInt_P1 pr1) r  H0); Rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); Ring.
-Rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); Rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); Rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); Rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr2) (RiemannInt_P1 pr1) (RiemannInt_P1 pr3)); [Ring | Auto with real | Auto with real].
-Qed.
-
-Lemma RiemannInt_P27 : (f:R->R;a,b,x:R;h:``a<=b``;C0:((x:R)``a<=x<=b``->(continuity_pt f x))) ``a<x<b`` -> (derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x)).
-Intro f; Intros; Elim H; Clear H; Intros; Assert H1 : (continuity_pt f x).
-Apply C0; Split; Left; Assumption.
-Unfold derivable_pt_lim; Intros; Assert Hyp : ``0<eps/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H1 ? Hyp); Unfold dist D_x no_cond; Simpl; Unfold R_dist; Intros; Pose del := (Rmin x0 (Rmin ``b-x`` ``x-a``)); Assert H4 : ``0<del``.
-Unfold del; Unfold Rmin; Case (total_order_Rle ``b-x`` ``x-a``); Intro.
-Case (total_order_Rle x0 ``b-x``); Intro; [Elim H3; Intros; Assumption | Apply Rlt_Rminus; Assumption].
-Case (total_order_Rle x0 ``x-a``); Intro; [Elim H3; Intros; Assumption | Apply Rlt_Rminus; Assumption].
-Split with (mkposreal ? H4); Intros; Assert H7 : (Riemann_integrable f x ``x+h0``).
-Case (total_order_Rle x ``x+h0``); Intro.
-Apply continuity_implies_RiemannInt; Try Assumption.
-Intros; Apply C0; Elim H7; Intros; Split.
-Apply Rle_trans with x; [Left; Assumption | Assumption].
-Apply Rle_trans with ``x+h0``.
-Assumption.
-Left; Apply Rlt_le_trans with ``x+del``.
-Apply Rlt_compatibility; Apply Rle_lt_trans with (Rabsolu h0); [Apply Rle_Rabsolu | Apply H6].
-Unfold del; Apply Rle_trans with ``x+(Rmin (b-x) (x-a))``.
-Apply Rle_compatibility; Apply Rmin_r.
-Pattern 2 b; Replace b with ``x+(b-x)``; [Apply Rle_compatibility; Apply Rmin_l | Ring].
-Apply RiemannInt_P1; Apply continuity_implies_RiemannInt; Auto with real.
-Intros; Apply C0; Elim H7; Intros; Split.
-Apply Rle_trans with ``x+h0``.
-Left; Apply Rle_lt_trans with ``x-del``.
-Unfold del; Apply Rle_trans with ``x-(Rmin (b-x) (x-a))``.
-Pattern 1 a; Replace a with ``x+(a-x)``; [Idtac | Ring].
-Unfold Rminus; Apply Rle_compatibility; Apply Ropp_Rle.
-Rewrite Ropp_Ropp; Rewrite Ropp_distr1; Rewrite Ropp_Ropp; Rewrite (Rplus_sym x); Apply Rmin_r.
-Unfold Rminus; Apply Rle_compatibility; Apply Ropp_Rle.
-Do 2 Rewrite Ropp_Ropp; Apply Rmin_r.
-Unfold Rminus; Apply Rlt_compatibility; Apply Ropp_Rlt.
-Rewrite Ropp_Ropp; Apply Rle_lt_trans with (Rabsolu h0); [Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu | Apply H6].
-Assumption.
-Apply Rle_trans with x; [Assumption | Left; Assumption].
-Replace ``(primitive h (FTC_P1 h C0) (x+h0))-(primitive h (FTC_P1 h C0) x)`` with (RiemannInt H7).
-Replace (f x) with ``(RiemannInt (RiemannInt_P14 x (x+h0) (f x)))/h0``.
-Replace ``(RiemannInt H7)/h0-(RiemannInt (RiemannInt_P14 x (x+h0) (f x)))/h0`` with ``((RiemannInt H7)-(RiemannInt (RiemannInt_P14 x (x+h0) (f x))))/h0``.
-Replace ``(RiemannInt H7)-(RiemannInt (RiemannInt_P14 x (x+h0) (f x)))`` with (RiemannInt (RiemannInt_P10 ``-1`` H7 (RiemannInt_P14 x ``x+h0`` (f x)))).
-Unfold Rdiv; Rewrite Rabsolu_mult; Case (total_order_Rle x ``x+h0``); Intro.
-Apply Rle_lt_trans with ``(RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x+h0) (f x)))))*(Rabsolu (/h0))``.
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu (/h0))``); Apply Rle_monotony.
-Apply Rabsolu_pos.
-Apply (RiemannInt_P17 (RiemannInt_P10 ``-1`` H7 (RiemannInt_P14 x ``x+h0`` (f x))) (RiemannInt_P16 (RiemannInt_P10 ``-1`` H7 (RiemannInt_P14 x ``x+h0`` (f x))))); Assumption.
-Apply Rle_lt_trans with ``(RiemannInt (RiemannInt_P14 x (x+h0) (eps/2)))*(Rabsolu (/h0))``.
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu (/h0))``); Apply Rle_monotony.
-Apply Rabsolu_pos.
-Apply RiemannInt_P19; Try Assumption.
-Intros; Replace ``(f x1)+ -1*(fct_cte (f x) x1)`` with ``(f x1)-(f x)``.
-Unfold fct_cte; Case (Req_EM x x1); Intro.
-Rewrite H9; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Left; Assumption.
-Elim H3; Intros; Left; Apply H11.
-Repeat Split.
-Assumption.
-Rewrite Rabsolu_right.
-Apply Rlt_anti_compatibility with x; Replace ``x+(x1-x)`` with x1; [Idtac | Ring].
-Apply Rlt_le_trans with ``x+h0``.
-Elim H8; Intros; Assumption.
-Apply Rle_compatibility; Apply Rle_trans with del.
-Left; Apply Rle_lt_trans with (Rabsolu h0); [Apply Rle_Rabsolu | Assumption].
-Unfold del; Apply Rmin_l.
-Apply Rge_minus; Apply Rle_sym1; Left; Elim H8; Intros; Assumption.
-Unfold fct_cte; Ring.
-Rewrite RiemannInt_P15.
-Rewrite Rmult_assoc; Replace ``(x+h0-x)*(Rabsolu (/h0))`` with R1.
-Rewrite Rmult_1r; Unfold Rdiv; Apply Rlt_monotony_contra with ``2``; [Sup0 | Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Pattern 1 eps; Rewrite <- Rplus_Or; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Rewrite Rabsolu_right.
-Replace ``x+h0-x`` with h0; [Idtac | Ring].
-Apply Rinv_r_sym.
-Assumption.
-Apply Rle_sym1; Left; Apply Rlt_Rinv.
-Elim r; Intro.
-Apply Rlt_anti_compatibility with x; Rewrite Rplus_Or; Assumption.
-Elim H5; Symmetry; Apply r_Rplus_plus with x; Rewrite Rplus_Or; Assumption.
-Apply Rle_lt_trans with ``(RiemannInt (RiemannInt_P16 (RiemannInt_P1 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x+h0) (f x))))))*(Rabsolu (/h0))``.
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu (/h0))``); Apply Rle_monotony.
-Apply Rabsolu_pos.
-Replace (RiemannInt (RiemannInt_P10 ``-1`` H7 (RiemannInt_P14 x ``x+h0`` (f x)))) with ``-(RiemannInt (RiemannInt_P1 (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x+h0) (f x)))))``.
-Rewrite Rabsolu_Ropp; Apply (RiemannInt_P17 (RiemannInt_P1 (RiemannInt_P10 ``-1`` H7 (RiemannInt_P14 x ``x+h0`` (f x)))) (RiemannInt_P16 (RiemannInt_P1 (RiemannInt_P10 ``-1`` H7 (RiemannInt_P14 x ``x+h0`` (f x)))))); Auto with real.
-Symmetry; Apply RiemannInt_P8.
-Apply Rle_lt_trans with ``(RiemannInt (RiemannInt_P14 (x+h0) x (eps/2)))*(Rabsolu (/h0))``.
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu (/h0))``); Apply Rle_monotony.
-Apply Rabsolu_pos.
-Apply RiemannInt_P19.
-Auto with real.
-Intros; Replace ``(f x1)+ -1*(fct_cte (f x) x1)`` with ``(f x1)-(f x)``.
-Unfold fct_cte; Case (Req_EM x x1); Intro.
-Rewrite H9; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Left; Assumption.
-Elim H3; Intros; Left; Apply H11.
-Repeat Split.
-Assumption.
-Rewrite Rabsolu_left.
-Apply Rlt_anti_compatibility with ``x1-x0``; Replace ``x1-x0+x0`` with x1; [Idtac | Ring].
-Replace ``x1-x0+ -(x1-x)`` with ``x-x0``; [Idtac | Ring].
-Apply Rle_lt_trans with ``x+h0``.
-Unfold Rminus; Apply Rle_compatibility; Apply Ropp_Rle.
-Rewrite Ropp_Ropp; Apply Rle_trans with (Rabsolu h0).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Apply Rle_trans with del; [Left; Assumption | Unfold del; Apply Rmin_l].
-Elim H8; Intros; Assumption.
-Apply Rlt_anti_compatibility with x; Rewrite Rplus_Or; Replace ``x+(x1-x)`` with x1; [Elim H8; Intros; Assumption | Ring].
-Unfold fct_cte; Ring.
-Rewrite RiemannInt_P15.
-Rewrite Rmult_assoc; Replace ``(x-(x+h0))*(Rabsolu (/h0))`` with R1.
-Rewrite Rmult_1r; Unfold Rdiv; Apply Rlt_monotony_contra with ``2``; [Sup0 | Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Pattern 1 eps; Rewrite <- Rplus_Or; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Rewrite Rabsolu_left.
-Replace ``x-(x+h0)`` with ``-h0``; [Idtac | Ring].
-Rewrite Ropp_mul1; Rewrite Ropp_mul3; Rewrite Ropp_Ropp; Apply Rinv_r_sym.
-Assumption.
-Apply Rlt_Rinv2.
-Assert H8 : ``x+h0<x``.
-Auto with real.
-Apply Rlt_anti_compatibility with x; Rewrite Rplus_Or; Assumption.
-Rewrite (RiemannInt_P13 H7 (RiemannInt_P14 x ``x+h0`` (f x)) (RiemannInt_P10 ``-1`` H7 (RiemannInt_P14 x ``x+h0`` (f x)))).
-Ring.
-Unfold Rdiv Rminus; Rewrite Rmult_Rplus_distrl; Ring.
-Rewrite RiemannInt_P15; Apply r_Rmult_mult with h0; [Unfold Rdiv; Rewrite -> (Rmult_sym h0); Repeat Rewrite -> Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | Assumption] | Assumption].
-Cut ``a<=x+h0``.
-Cut ``x+h0<=b``.
-Intros; Unfold primitive.
-Case (total_order_Rle a ``x+h0``); Case (total_order_Rle ``x+h0`` b); Case (total_order_Rle a x); Case (total_order_Rle x b); Intros; Try (Elim n; Assumption Orelse Left; Assumption).
-Rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r0 r) H7 (FTC_P1 h C0 r2 r1)); Ring.
-Apply Rle_anti_compatibility with ``-x``; Replace ``-x+(x+h0)`` with h0; [Idtac | Ring].
-Rewrite Rplus_sym; Apply Rle_trans with (Rabsolu h0).
-Apply Rle_Rabsolu.
-Apply Rle_trans with del; [Left; Assumption | Unfold del; Apply Rle_trans with ``(Rmin (b-x) (x-a))``; [Apply Rmin_r | Apply Rmin_l]].
-Apply Ropp_Rle; Apply Rle_anti_compatibility with ``x``; Replace ``x+-(x+h0)`` with ``-h0``; [Idtac | Ring].
-Apply Rle_trans with (Rabsolu h0); [Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu | Apply Rle_trans with del; [Left; Assumption | Unfold del; Apply Rle_trans with ``(Rmin (b-x) (x-a))``; Apply Rmin_r]].
-Qed.
-
-Lemma RiemannInt_P28 : (f:R->R;a,b,x:R;h:``a<=b``;C0:((x:R)``a<=x<=b``->(continuity_pt f x))) ``a<=x<=b`` -> (derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x)).
-Intro f; Intros; Elim h; Intro.
-Elim H; Clear H; Intros; Elim H; Intro.
-Elim H1; Intro.
-Apply RiemannInt_P27; Split; Assumption.
-Pose f_b := [x:R]``(f b)*(x-b)+(RiemannInt [(FTC_P1 h C0 h (FTC_P2 b))])``; Rewrite H3.
-Assert H4 : (derivable_pt_lim f_b b (f b)).
-Unfold f_b; Pattern 2 (f b); Replace (f b) with ``(f b)+0``.
-Change (derivable_pt_lim (plus_fct (mult_fct (fct_cte (f b)) (minus_fct id (fct_cte b))) (fct_cte (RiemannInt (FTC_P1 h C0 h (FTC_P2 b))))) b ``(f b)+0``). 
-Apply derivable_pt_lim_plus.
-Pattern 2 (f b); Replace (f b) with ``0*((minus_fct id (fct_cte b)) b)+((fct_cte (f b)) b)*1``.
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_const.
-Replace R1 with ``1-0``; [Idtac | Ring].
-Apply derivable_pt_lim_minus.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_const.
-Unfold fct_cte; Ring.
-Apply derivable_pt_lim_const.
-Ring.
-Unfold derivable_pt_lim; Intros; Elim (H4 ? H5); Intros; Assert H7 : (continuity_pt f b).
-Apply C0; Split; [Left; Assumption | Right; Reflexivity].
-Assert H8 : ``0<eps/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H7 ? H8); Unfold D_x no_cond dist; Simpl; Unfold R_dist; Intros; Pose del := (Rmin x0 (Rmin x1 ``b-a``)); Assert H10 : ``0<del``.
-Unfold del; Unfold Rmin; Case (total_order_Rle x1 ``b-a``); Intros.
-Case (total_order_Rle x0 x1); Intro; [Apply (cond_pos x0) | Elim H9; Intros; Assumption].
-Case (total_order_Rle x0 ``b-a``); Intro; [Apply (cond_pos x0) | Apply Rlt_Rminus; Assumption].
-Split with (mkposreal ? H10); Intros; Case (case_Rabsolu h0); Intro.
-Assert H14 : ``b+h0<b``.
-Pattern 2 b; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Assumption.
-Assert H13 : (Riemann_integrable f ``b+h0`` b).
-Apply continuity_implies_RiemannInt.
-Left; Assumption.
-Intros; Apply C0; Elim H13; Intros; Split; Try Assumption.
-Apply Rle_trans with ``b+h0``; Try Assumption.
-Apply Rle_anti_compatibility with ``-a-h0``.
-Replace ``-a-h0+a`` with ``-h0``; [Idtac | Ring].
-Replace ``-a-h0+(b+h0)`` with ``b-a``; [Idtac | Ring].
-Apply Rle_trans with del.
-Apply Rle_trans with (Rabsolu h0).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Left; Assumption.
-Unfold del; Apply Rle_trans with (Rmin x1 ``b-a``); Apply Rmin_r.
-Replace ``[(primitive h (FTC_P1 h C0) (b+h0))]-[(primitive h (FTC_P1 h C0) b)]`` with ``-(RiemannInt H13)``.
-Replace (f b) with ``-[(RiemannInt (RiemannInt_P14 (b+h0) b (f b)))]/h0``.
-Rewrite <- Rabsolu_Ropp; Unfold Rminus; Unfold Rdiv; Rewrite Ropp_mul1; Rewrite Ropp_distr1; Repeat Rewrite Ropp_Ropp; Replace ``(RiemannInt H13)*/h0+ -(RiemannInt (RiemannInt_P14 (b+h0) b (f b)))*/h0`` with ``((RiemannInt H13)-(RiemannInt (RiemannInt_P14 (b+h0) b (f b))))/h0``.
-Replace ``(RiemannInt H13)-(RiemannInt (RiemannInt_P14 (b+h0) b (f b)))`` with (RiemannInt (RiemannInt_P10 ``-1`` H13 (RiemannInt_P14 ``b+h0`` b (f b)))).
-Unfold Rdiv; Rewrite Rabsolu_mult; Apply Rle_lt_trans with ``(RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b+h0) b (f b)))))*(Rabsolu (/h0))``.
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu (/h0))``); Apply Rle_monotony.
-Apply Rabsolu_pos.
-Apply (RiemannInt_P17 (RiemannInt_P10 ``-1`` H13 (RiemannInt_P14 ``b+h0`` b (f b))) (RiemannInt_P16 (RiemannInt_P10 ``-1`` H13 (RiemannInt_P14 ``b+h0`` b (f b))))); Left; Assumption.
-Apply Rle_lt_trans with ``(RiemannInt (RiemannInt_P14 (b+h0) b (eps/2)))*(Rabsolu (/h0))``.
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu (/h0))``); Apply Rle_monotony.
-Apply Rabsolu_pos.
-Apply RiemannInt_P19.
-Left; Assumption.
-Intros; Replace ``(f x2)+ -1*(fct_cte (f b) x2)`` with ``(f x2)-(f b)``.
-Unfold fct_cte; Case (Req_EM b x2); Intro.
-Rewrite H16; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Left; Assumption.
-Elim H9; Intros; Left; Apply H18.
-Repeat Split.
-Assumption.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Rewrite Rabsolu_right.
-Apply Rlt_anti_compatibility with ``x2-x1``; Replace ``x2-x1+(b-x2)`` with ``b-x1``; [Idtac | Ring].
-Replace ``x2-x1+x1`` with x2; [Idtac | Ring].
-Apply Rlt_le_trans with ``b+h0``.
-2:Elim H15; Intros; Left; Assumption.
-Unfold Rminus; Apply Rlt_compatibility; Apply Ropp_Rlt; Rewrite Ropp_Ropp; Apply Rle_lt_trans with (Rabsolu h0).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Apply Rlt_le_trans with del; [Assumption | Unfold del; Apply Rle_trans with (Rmin x1 ``b-a``); [Apply Rmin_r | Apply Rmin_l]].
-Apply Rle_sym1; Left; Apply Rlt_Rminus; Elim H15; Intros; Assumption.
-Unfold fct_cte; Ring.
-Rewrite RiemannInt_P15.
-Rewrite Rmult_assoc; Replace ``(b-(b+h0))*(Rabsolu (/h0))`` with R1.
-Rewrite Rmult_1r; Unfold Rdiv; Apply Rlt_monotony_contra with ``2``; [Sup0 | Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Pattern 1 eps; Rewrite <- Rplus_Or; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Rewrite Rabsolu_left.
-Apply r_Rmult_mult with h0; [Do 2 Rewrite (Rmult_sym h0); Rewrite Rmult_assoc; Rewrite Ropp_mul1; Rewrite <- Rinv_l_sym; [ Ring | Assumption ] | Assumption].
-Apply Rlt_Rinv2; Assumption.
-Rewrite (RiemannInt_P13 H13 (RiemannInt_P14 ``b+h0`` b (f b)) (RiemannInt_P10 ``-1`` H13 (RiemannInt_P14 ``b+h0`` b (f b)))); Ring.
-Unfold Rdiv Rminus; Rewrite Rmult_Rplus_distrl; Ring.
-Rewrite RiemannInt_P15.
-Rewrite <- Ropp_mul1; Apply r_Rmult_mult with h0; [Repeat Rewrite (Rmult_sym h0); Unfold Rdiv; Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Ring | Assumption] | Assumption].
-Cut ``a<=b+h0``.
-Cut ``b+h0<=b``.
-Intros; Unfold primitive; Case (total_order_Rle a ``b+h0``); Case (total_order_Rle ``b+h0`` b); Case (total_order_Rle a b); Case (total_order_Rle b b); Intros; Try (Elim n; Right; Reflexivity) Orelse (Elim n; Left; Assumption).
-Rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); Ring.
-Elim n; Assumption.
-Left; Assumption.
-Apply Rle_anti_compatibility with ``-a-h0``.
-Replace ``-a-h0+a`` with ``-h0``; [Idtac | Ring].
-Replace ``-a-h0+(b+h0)`` with ``b-a``; [Idtac | Ring].
-Apply Rle_trans with del.
-Apply Rle_trans with (Rabsolu h0).
-Rewrite <- Rabsolu_Ropp; Apply Rle_Rabsolu.
-Left; Assumption.
-Unfold del; Apply Rle_trans with (Rmin x1 ``b-a``); Apply Rmin_r.
-Cut (primitive  h (FTC_P1 h C0) b)==(f_b b).
-Intro; Cut (primitive  h (FTC_P1 h C0) ``b+h0``)==(f_b ``b+h0``).
-Intro; Rewrite H13; Rewrite H14; Apply H6.
-Assumption.
-Apply Rlt_le_trans with del; [Assumption | Unfold del; Apply Rmin_l].
-Assert H14 : ``b<b+h0``.
-Pattern 1 b; Rewrite <- Rplus_Or; Apply Rlt_compatibility.
-Assert H14 := (Rle_sym2 ? ? r); Elim H14; Intro.
-Assumption.
-Elim H11; Symmetry; Assumption.
-Unfold primitive; Case (total_order_Rle a ``b+h0``); Case (total_order_Rle ``b+h0`` b); Intros; [Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r0 H14)) | Unfold f_b; Reflexivity | Elim n; Left; Apply Rlt_trans with b; Assumption | Elim n0; Left; Apply Rlt_trans with b; Assumption].
-Unfold f_b; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rmult_Or; Rewrite Rplus_Ol; Unfold primitive; Case (total_order_Rle a b); Case (total_order_Rle b b); Intros; [Apply RiemannInt_P5 | Elim n; Right; Reflexivity | Elim n; Left; Assumption | Elim n; Right; Reflexivity].
-(*****)
-Pose f_a := [x:R]``(f a)*(x-a)``; Rewrite <- H2; Assert H3 : (derivable_pt_lim f_a a (f a)).
-Unfold f_a; Change (derivable_pt_lim (mult_fct (fct_cte (f a)) (minus_fct id (fct_cte a))) a (f a)); Pattern 2 (f a); Replace (f a) with ``0*((minus_fct id (fct_cte a)) a)+((fct_cte (f a)) a)*1``.
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_const.
-Replace R1 with ``1-0``; [Idtac | Ring].
-Apply derivable_pt_lim_minus.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_const.
-Unfold fct_cte; Ring.
-Unfold derivable_pt_lim; Intros; Elim (H3 ? H4); Intros.
-Assert H6 : (continuity_pt f a).
-Apply C0; Split; [Right; Reflexivity | Left; Assumption].
-Assert H7 : ``0<eps/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Elim (H6 ? H7); Unfold D_x no_cond dist; Simpl; Unfold R_dist; Intros.
-Pose del := (Rmin x0 (Rmin x1 ``b-a``)).
-Assert H9 : ``0<del``.
-Unfold del; Unfold Rmin.
-Case (total_order_Rle x1 ``b-a``); Intros.
-Case (total_order_Rle x0 x1); Intro.
-Apply (cond_pos x0).
-Elim H8; Intros; Assumption.
-Case (total_order_Rle x0 ``b-a``); Intro.
-Apply (cond_pos x0).
-Apply Rlt_Rminus; Assumption.
-Split with (mkposreal ? H9).
-Intros; Case (case_Rabsolu h0); Intro.
-Assert H12 : ``a+h0<a``.
-Pattern 2 a; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Assumption.
-Unfold primitive.
-Case (total_order_Rle a ``a+h0``); Case (total_order_Rle ``a+h0`` b); Case (total_order_Rle a a); Case (total_order_Rle a b); Intros; Try (Elim n; Left; Assumption) Orelse (Elim n; Right; Reflexivity).
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r3 H12)).
-Elim n; Left; Apply Rlt_trans with a; Assumption.
-Rewrite RiemannInt_P9; Replace R0 with (f_a a).
-Replace ``(f a)*(a+h0-a)`` with (f_a ``a+h0``).
-Apply H5; Try Assumption.
-Apply Rlt_le_trans with del; [Assumption | Unfold del; Apply Rmin_l].
-Unfold f_a; Ring.
-Unfold f_a; Ring.
-Elim n; Left; Apply Rlt_trans with a; Assumption.
-Assert H12 : ``a<a+h0``.
-Pattern 1 a; Rewrite <- Rplus_Or; Apply Rlt_compatibility.
-Assert H12 := (Rle_sym2 ? ? r); Elim H12; Intro.
-Assumption.
-Elim H10; Symmetry; Assumption.
-Assert H13 : (Riemann_integrable f a ``a+h0``).
-Apply continuity_implies_RiemannInt.
-Left; Assumption.
-Intros; Apply C0; Elim H13; Intros; Split; Try Assumption.
-Apply Rle_trans with ``a+h0``; Try Assumption.
-Apply Rle_anti_compatibility with ``-b-h0``.
-Replace ``-b-h0+b`` with ``-h0``; [Idtac | Ring].
-Replace ``-b-h0+(a+h0)`` with ``a-b``; [Idtac | Ring].
-Apply Ropp_Rle; Rewrite Ropp_Ropp; Rewrite Ropp_distr2; Apply Rle_trans with del.
-Apply Rle_trans with (Rabsolu h0); [Apply Rle_Rabsolu | Left; Assumption].
-Unfold del; Apply Rle_trans with (Rmin x1 ``b-a``); Apply Rmin_r.
-Replace ``(primitive h (FTC_P1 h C0) (a+h0))-(primitive h (FTC_P1 h C0) a)`` with ``(RiemannInt H13)``.
-Replace (f a) with ``(RiemannInt (RiemannInt_P14 a (a+h0) (f a)))/h0``.
-Replace ``(RiemannInt H13)/h0-(RiemannInt (RiemannInt_P14 a (a+h0) (f a)))/h0`` with ``((RiemannInt H13)-(RiemannInt (RiemannInt_P14 a (a+h0) (f a))))/h0``.
-Replace ``(RiemannInt H13)-(RiemannInt (RiemannInt_P14 a (a+h0) (f a)))`` with (RiemannInt (RiemannInt_P10 ``-1`` H13 (RiemannInt_P14  a ``a+h0`` (f a)))).
-Unfold Rdiv; Rewrite Rabsolu_mult; Apply Rle_lt_trans with ``(RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a+h0) (f a)))))*(Rabsolu (/h0))``.
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu (/h0))``); Apply Rle_monotony.
-Apply Rabsolu_pos.
-Apply (RiemannInt_P17 (RiemannInt_P10 ``-1`` H13 (RiemannInt_P14 a ``a+h0`` (f a))) (RiemannInt_P16 (RiemannInt_P10 ``-1`` H13 (RiemannInt_P14 a ``a+h0`` (f a))))); Left; Assumption.
-Apply Rle_lt_trans with ``(RiemannInt (RiemannInt_P14 a (a+h0) (eps/2)))*(Rabsolu (/h0))``.
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu (/h0))``); Apply Rle_monotony.
-Apply Rabsolu_pos.
-Apply RiemannInt_P19.
-Left; Assumption.
-Intros; Replace ``(f x2)+ -1*(fct_cte (f a) x2)`` with ``(f x2)-(f a)``.
-Unfold fct_cte; Case (Req_EM a x2); Intro.
-Rewrite H15; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Left; Assumption.
-Elim H8; Intros; Left; Apply H17; Repeat Split.
-Assumption.
-Rewrite Rabsolu_right.
-Apply Rlt_anti_compatibility with a; Replace ``a+(x2-a)`` with x2; [Idtac | Ring].
-Apply Rlt_le_trans with ``a+h0``.
-Elim H14; Intros; Assumption.
-Apply Rle_compatibility; Left; Apply Rle_lt_trans with (Rabsolu h0).
-Apply Rle_Rabsolu.
-Apply Rlt_le_trans with del; [Assumption | Unfold del; Apply Rle_trans with (Rmin x1 ``b-a``); [Apply Rmin_r | Apply Rmin_l]].
-Apply Rle_sym1; Left; Apply Rlt_Rminus; Elim H14; Intros; Assumption.
-Unfold fct_cte; Ring.
-Rewrite RiemannInt_P15.
-Rewrite Rmult_assoc; Replace ``((a+h0)-a)*(Rabsolu (/h0))`` with R1.
-Rewrite Rmult_1r; Unfold Rdiv; Apply Rlt_monotony_contra with ``2``; [Sup0 | Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Pattern 1 eps; Rewrite <- Rplus_Or; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Rewrite Rabsolu_right.
-Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Rewrite <- Rinv_r_sym; [ Reflexivity | Assumption ].
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Assert H14 := (Rle_sym2 ? ? r); Elim H14; Intro.
-Assumption.
-Elim H10; Symmetry; Assumption.
-Rewrite (RiemannInt_P13 H13 (RiemannInt_P14 a ``a+h0`` (f a)) (RiemannInt_P10 ``-1`` H13 (RiemannInt_P14 a ``a+h0`` (f a)))); Ring.
-Unfold Rdiv Rminus; Rewrite Rmult_Rplus_distrl; Ring.
-Rewrite RiemannInt_P15.
-Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Unfold Rdiv; Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym; [ Ring | Assumption ].
-Cut ``a<=a+h0``.
-Cut ``a+h0<=b``.
-Intros; Unfold primitive; Case (total_order_Rle a ``a+h0``); Case (total_order_Rle ``a+h0`` b); Case (total_order_Rle a a); Case (total_order_Rle a b); Intros; Try (Elim n; Right; Reflexivity) Orelse (Elim n; Left; Assumption).
-Rewrite RiemannInt_P9; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply RiemannInt_P5.
-Elim n; Assumption.
-Elim n; Assumption.
-2:Left; Assumption.
-Apply Rle_anti_compatibility with ``-a``; Replace ``-a+(a+h0)`` with h0; [Idtac | Ring].
-Rewrite Rplus_sym; Apply Rle_trans with del; [Apply Rle_trans with (Rabsolu h0); [Apply Rle_Rabsolu | Left; Assumption] | Unfold del; Apply Rle_trans with (Rmin x1 ``b-a``); Apply Rmin_r].
-(*****)
-Assert H1 : x==a.
-Rewrite <- H0 in H; Elim H; Intros; Apply Rle_antisym; Assumption.
-Pose f_a := [x:R]``(f a)*(x-a)``.
-Assert H2 : (derivable_pt_lim f_a a (f a)).
-Unfold f_a; Change (derivable_pt_lim (mult_fct (fct_cte (f a)) (minus_fct id (fct_cte a))) a (f a)); Pattern 2 (f a); Replace (f a) with ``0*((minus_fct id (fct_cte a)) a)+((fct_cte (f a)) a)*1``.
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_const.
-Replace R1 with ``1-0``; [Idtac | Ring].
-Apply derivable_pt_lim_minus.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_const.
-Unfold fct_cte; Ring.
-Pose f_b := [x:R]``(f b)*(x-b)+(RiemannInt (FTC_P1 h C0 b h (FTC_P2 b)))``.
-Assert H3 : (derivable_pt_lim f_b b (f b)).
-Unfold f_b; Pattern 2 (f b); Replace (f b) with ``(f b)+0``.
-Change (derivable_pt_lim (plus_fct (mult_fct (fct_cte (f b)) (minus_fct id (fct_cte b))) (fct_cte (RiemannInt (FTC_P1 h C0 h (FTC_P2 b))))) b ``(f b)+0``). 
-Apply derivable_pt_lim_plus.
-Pattern 2 (f b); Replace (f b) with ``0*((minus_fct id (fct_cte b)) b)+((fct_cte (f b)) b)*1``.
-Apply derivable_pt_lim_mult.
-Apply derivable_pt_lim_const.
-Replace R1 with ``1-0``; [Idtac | Ring].
-Apply derivable_pt_lim_minus.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_const.
-Unfold fct_cte; Ring.
-Apply derivable_pt_lim_const.
-Ring.
-Unfold derivable_pt_lim; Intros; Elim (H2 ? H4); Intros; Elim (H3 ? H4); Intros; Pose del := (Rmin x0 x1).
-Assert H7 : ``0<del``.
-Unfold del; Unfold Rmin; Case (total_order_Rle x0 x1); Intro.
-Apply (cond_pos x0).
-Apply (cond_pos x1).
-Split with (mkposreal ? H7); Intros; Case (case_Rabsolu h0); Intro.
-Assert H10 : ``a+h0<a``.
-Pattern 2 a; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Assumption.
-Rewrite H1; Unfold primitive; Case (total_order_Rle a ``a+h0``); Case (total_order_Rle ``a+h0`` b); Case (total_order_Rle a a); Case (total_order_Rle a b); Intros;  Try (Elim n; Right; Assumption Orelse Reflexivity).
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r3 H10)).
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r2 H10)).
-Rewrite RiemannInt_P9; Replace R0 with (f_a a).
-Replace ``(f a)*(a+h0-a)`` with (f_a ``a+h0``).
-Apply H5; Try Assumption.
-Apply Rlt_le_trans with del; Try Assumption.
-Unfold del; Apply Rmin_l.
-Unfold f_a; Ring.
-Unfold f_a; Ring.
-Elim n; Rewrite <- H0; Left; Assumption.
-Assert H10 : ``a<a+h0``.
-Pattern 1 a; Rewrite <- Rplus_Or; Apply Rlt_compatibility.
-Assert H10 := (Rle_sym2 ? ? r); Elim H10; Intro.
-Assumption.
-Elim H8; Symmetry; Assumption.
-Rewrite H0 in H1; Rewrite H1; Unfold primitive; Case (total_order_Rle a ``b+h0``); Case (total_order_Rle ``b+h0`` b); Case (total_order_Rle a b); Case (total_order_Rle b b); Intros;  Try (Elim n; Right; Assumption Orelse Reflexivity).
-Rewrite H0 in H10; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r2 H10)).
-Repeat Rewrite RiemannInt_P9.
-Replace (RiemannInt (FTC_P1 h C0 r1 r0)) with (f_b b).
-Fold (f_b ``b+h0``).
-Apply H6; Try Assumption.
-Apply Rlt_le_trans with del; Try Assumption.
-Unfold del; Apply Rmin_r.
-Unfold f_b; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rmult_Or; Rewrite Rplus_Ol; Apply RiemannInt_P5.
-Elim n; Rewrite <- H0; Left; Assumption.
-Elim n0; Rewrite <- H0; Left; Assumption.
-Qed.
-
-Lemma RiemannInt_P29 : (f:R->R;a,b;h:``a<=b``;C0:((x:R)``a<=x<=b``->(continuity_pt f x))) (antiderivative f (primitive h (FTC_P1 h C0)) a b).
-Intro f; Intros; Unfold antiderivative; Split; Try Assumption; Intros; Assert H0 := (RiemannInt_P28 h C0 H); Assert H1 : (derivable_pt (primitive h (FTC_P1 h C0)) x); [Unfold derivable_pt; Split with (f x); Apply H0 | Split with H1; Symmetry; Apply derive_pt_eq_0; Apply H0].
-Qed.
-
-Lemma RiemannInt_P30 : (f:R->R;a,b:R) ``a<=b`` -> ((x:R)``a<=x<=b``->(continuity_pt f x)) -> (sigTT ? [g:R->R](antiderivative f g a b)).
-Intros; Split with (primitive H (FTC_P1 H H0)); Apply RiemannInt_P29.
-Qed.
-
-Record C1_fun : Type := mkC1 {
-c1 :> R->R;
-diff0 : (derivable c1);
-cont1 : (continuity (derive c1 diff0)) }.
-
-Lemma RiemannInt_P31 : (f:C1_fun;a,b:R) ``a<=b`` -> (antiderivative (derive f (diff0 f)) f a b).
-Intro f; Intros; Unfold antiderivative; Split; Try Assumption; Intros; Split with (diff0 f x); Reflexivity.
-Qed.
-
-Lemma RiemannInt_P32 : (f:C1_fun;a,b:R) (Riemann_integrable (derive f (diff0 f)) a b).
-Intro f; Intros; Case (total_order_Rle a b); Intro; [Apply continuity_implies_RiemannInt; Try Assumption; Intros; Apply (cont1 f) | Assert H : ``b<=a``; [Auto with real | Apply RiemannInt_P1; Apply continuity_implies_RiemannInt; Try Assumption; Intros; Apply (cont1 f)]].
-Qed.
-
-Lemma RiemannInt_P33 : (f:C1_fun;a,b:R;pr:(Riemann_integrable (derive f (diff0 f)) a b)) ``a<=b`` -> (RiemannInt pr)==``(f b)-(f a)``.
-Intro f; Intros; Assert H0 : (x:R)``a<=x<=b``->(continuity_pt (derive f (diff0 f)) x).
-Intros; Apply (cont1 f).
-Rewrite (RiemannInt_P20 H (FTC_P1 H H0) pr); Assert H1 := (RiemannInt_P29 H H0); Assert H2 := (RiemannInt_P31 f H); Elim (antiderivative_Ucte (derive f (diff0 f)) ? ? ? ? H1 H2); Intros C H3; Repeat Rewrite H3; [Ring | Split; [Right; Reflexivity | Assumption] | Split; [Assumption | Right; Reflexivity]].
-Qed.
-
-Lemma FTC_Riemann : (f:C1_fun;a,b:R;pr:(Riemann_integrable (derive f (diff0 f)) a b)) (RiemannInt pr)==``(f b)-(f a)``.
-Intro f; Intros; Case (total_order_Rle a b); Intro; [Apply RiemannInt_P33; Assumption | Assert H : ``b<=a``; [Auto with real | Assert H0 := (RiemannInt_P1 pr); Rewrite (RiemannInt_P8 pr H0); Rewrite (RiemannInt_P33 H0 H); Ring]].
-Qed.
diff --git a/theories7/Reals/RiemannInt_SF.v b/theories7/Reals/RiemannInt_SF.v
deleted file mode 100644
index 3e2cc457..00000000
--- a/theories7/Reals/RiemannInt_SF.v
+++ /dev/null
@@ -1,1400 +0,0 @@
-(************************************************************************)
-(*  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: RiemannInt_SF.v,v 1.2.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Ranalysis.
-Require Classical_Prop.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Implicit Arguments On.
-
-(**************************************************)
-(* Each bounded subset of N has a maximal element *)
-(**************************************************)
-
-Definition Nbound [I:nat->Prop] : Prop := (EX n:nat | (i:nat)(I i)->(le i n)).
-
-Lemma IZN_var:(z:Z)(`0<=z`)->{ n:nat | z=(INZ n)}.
-Intros; Apply inject_nat_complete_inf; Assumption.
-Qed.
-
-Lemma Nzorn : (I:nat->Prop) (EX n:nat | (I n)) -> (Nbound I) -> (sigTT ?  [n:nat](I n)/\(i:nat)(I i)->(le i n)).
-Intros I H H0; Pose E := [x:R](EX i:nat | (I i)/\(INR i)==x); Assert H1 : (bound E).
-Unfold Nbound in H0; Elim H0; Intros N H1; Unfold bound; Exists (INR N); Unfold is_upper_bound; Intros; Unfold E in H2; Elim H2; Intros; Elim H3; Intros; Rewrite <- H5; Apply le_INR; Apply H1; Assumption.
-Assert H2 : (EXT x:R | (E x)).
-Elim H; Intros; Exists (INR x); Unfold E; Exists x; Split; [Assumption | Reflexivity].
-Assert H3 := (complet E H1 H2); Elim H3; Intros; Unfold is_lub in p; Elim p; Clear p; Intros; Unfold is_upper_bound in H4 H5; Assert H6 : ``0<=x``.
-Elim H2; Intros; Unfold E in H6; Elim H6; Intros; Elim H7; Intros; Apply Rle_trans with x0; [Rewrite <- H9; Change ``(INR O)<=(INR x1)``; Apply le_INR; Apply le_O_n | Apply H4; Assumption].
-Assert H7 := (archimed x); Elim H7; Clear H7; Intros; Assert H9 : ``x<=(IZR (up x))-1``.
-Apply H5; Intros; Assert H10 := (H4 ? H9); Unfold E in H9; Elim H9; Intros; Elim H11; Intros; Rewrite <- H13; Apply Rle_anti_compatibility with R1; Replace ``1+((IZR (up x))-1)`` with (IZR (up x)); [Idtac | Ring]; Replace ``1+(INR x1)`` with (INR (S x1)); [Idtac | Rewrite S_INR; Ring].
-Assert H14 : `0<=(up x)`.
-Apply le_IZR; Apply Rle_trans with x; [Apply H6 | Left; Assumption].
-Assert H15 := (IZN ? H14); Elim H15; Clear H15; Intros; Rewrite H15; Rewrite <- INR_IZR_INZ; Apply le_INR; Apply lt_le_S; Apply INR_lt; Rewrite H13; Apply Rle_lt_trans with x; [Assumption | Rewrite INR_IZR_INZ; Rewrite <- H15; Assumption].
-Assert H10 : ``x==(IZR (up x))-1``.
-Apply Rle_antisym; [Assumption | Apply Rle_anti_compatibility with ``-x+1``; Replace `` -x+1+((IZR (up x))-1)`` with ``(IZR (up x))-x``; [Idtac | Ring]; Replace ``-x+1+x`` with R1; [Assumption | Ring]].
-Assert H11 : `0<=(up x)`.
-Apply le_IZR; Apply Rle_trans with x; [Apply H6 | Left; Assumption].
-Assert H12 := (IZN_var H11); Elim H12; Clear H12; Intros; Assert H13 : (E x).
-Elim (classic (E x)); Intro; Try Assumption.
-Cut ((y:R)(E y)->``y<=x-1``).
-Intro; Assert H14 := (H5 ? H13); Cut ``x-1<x``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H14 H15)).
-Apply Rminus_lt; Replace ``x-1-x`` with ``-1``; [Idtac | Ring]; Rewrite <- Ropp_O; Apply Rlt_Ropp; Apply Rlt_R0_R1.
-Intros; Assert H14 := (H4 ? H13); Elim H14; Intro; Unfold E in H13; Elim H13; Intros; Elim H16; Intros; Apply Rle_anti_compatibility with R1.
-Replace ``1+(x-1)`` with x; [Idtac | Ring]; Rewrite <- H18; Replace ``1+(INR x1)`` with (INR (S x1)); [Idtac | Rewrite S_INR; Ring].
-Cut x==(INR (pred x0)).
-Intro; Rewrite H19; Apply le_INR; Apply lt_le_S; Apply INR_lt; Rewrite H18; Rewrite <- H19; Assumption.
-Rewrite H10; Rewrite p; Rewrite <- INR_IZR_INZ; Replace R1 with (INR (S O)); [Idtac | Reflexivity]; Rewrite <- minus_INR.
-Replace (minus x0 (S O)) with (pred x0); [Reflexivity | Case x0; [Reflexivity | Intro; Simpl; Apply minus_n_O]].
-Induction x0; [Rewrite p in H7; Rewrite <- INR_IZR_INZ in H7; Simpl in H7; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H6 H7)) | Apply le_n_S; Apply le_O_n].
-Rewrite H15 in H13; Elim H12; Assumption.
-Split with (pred x0); Unfold E in H13; Elim H13; Intros; Elim H12; Intros; Rewrite H10 in H15; Rewrite p in H15; Rewrite <- INR_IZR_INZ in H15; Assert H16 : ``(INR x0)==(INR x1)+1``.
-Rewrite H15; Ring.
-Rewrite <- S_INR in H16; Assert H17 := (INR_eq ? ? H16); Rewrite H17; Simpl; Split.
-Assumption.
-Intros; Apply INR_le; Rewrite H15; Rewrite <- H15; Elim H12; Intros; Rewrite H20; Apply H4; Unfold E; Exists i; Split; [Assumption | Reflexivity].
-Qed.
-
-(*******************************************)
-(*             Step functions              *)
-(*******************************************)
-
-Definition open_interval [a,b:R] : R->Prop := [x:R]``a<x<b``.
-Definition co_interval [a,b:R] : R->Prop := [x:R]``a<=x<b``. 
-
-Definition adapted_couple [f:R->R;a,b:R;l,lf:Rlist] : Prop := (ordered_Rlist l)/\``(pos_Rl l O)==(Rmin a b)``/\``(pos_Rl l (pred (Rlength l)))==(Rmax a b)``/\(Rlength l)=(S (Rlength lf))/\(i:nat)(lt i (pred (Rlength l)))->(constant_D_eq f (open_interval (pos_Rl l i) (pos_Rl l (S i))) (pos_Rl lf i)).
-
-Definition adapted_couple_opt [f:R->R;a,b:R;l,lf:Rlist] := (adapted_couple f a b l lf)/\((i:nat)(lt i (pred (Rlength lf)))->(``(pos_Rl lf i)<>(pos_Rl lf (S i))``\/``(f (pos_Rl l (S i)))<>(pos_Rl lf i)``))/\((i:nat)(lt i (pred (Rlength l)))->``(pos_Rl l i)<>(pos_Rl l (S i))``).
-
-Definition is_subdivision [f:R->R;a,b:R;l:Rlist] : Type := (sigTT ? [l0:Rlist](adapted_couple f a b l l0)).
-
-Definition IsStepFun [f:R->R;a,b:R] : Type := (SigT ? [l:Rlist](is_subdivision f a b l)).
-
-(* Class of step functions *)
-Record StepFun [a,b:R] : Type := mkStepFun {
-  fe:> R->R;
-  pre:(IsStepFun fe a b)}.
-
-Definition subdivision [a,b:R;f:(StepFun a b)] : Rlist := (projT1 ? ? (pre f)).
-
-Definition subdivision_val [a,b:R;f:(StepFun a b)] : Rlist := Cases (projT2 ? ? (pre f)) of (existTT a b) => a end.
-
-Fixpoint Int_SF [l:Rlist] : Rlist -> R :=
-[k:Rlist] Cases l of
-| nil => R0
-| (cons a l') => Cases k of
-   | nil => R0
-   | (cons x nil) => R0
-   | (cons x (cons y k')) => ``a*(y-x)+(Int_SF l' (cons y k'))``
-  end
-end.
-
-(* Integral of step functions *)
-Definition RiemannInt_SF [a,b:R;f:(StepFun a b)] : R := 
-Cases (total_order_Rle a b) of
-  (leftT _) => (Int_SF (subdivision_val f) (subdivision f))
-| (rightT _) => ``-(Int_SF (subdivision_val f) (subdivision f))``
-end.
-
-(********************************)
-(* Properties of step functions *)
-(********************************)
-
-Lemma StepFun_P1 : (a,b:R;f:(StepFun a b)) (adapted_couple f a b (subdivision f) (subdivision_val f)).
-Intros a b f; Unfold subdivision_val; Case (projT2 Rlist ([l:Rlist](is_subdivision f a b l)) (pre f)); Intros; Apply a0.
-Qed.
-
-Lemma StepFun_P2 : (a,b:R;f:R->R;l,lf:Rlist) (adapted_couple f a b l lf) -> (adapted_couple f b a l lf).
-Unfold adapted_couple; Intros; Decompose [and] H; Clear H; Repeat Split; Try Assumption.
-Rewrite H2; Unfold Rmin; Case (total_order_Rle a b); Intro; Case (total_order_Rle b a); Intro; Try Reflexivity.
-Apply Rle_antisym; Assumption.
-Apply Rle_antisym; Auto with real.
-Rewrite H1; Unfold Rmax; Case (total_order_Rle a b); Intro; Case (total_order_Rle b a); Intro; Try Reflexivity.
-Apply Rle_antisym; Assumption.
-Apply Rle_antisym; Auto with real.
-Qed.
-
-Lemma StepFun_P3 : (a,b,c:R) ``a<=b`` -> (adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil)).
-Intros; Unfold adapted_couple; Repeat Split.
-Unfold ordered_Rlist; Intros; Simpl in H0; Inversion H0; [Simpl; Assumption | Elim (le_Sn_O ? H2)].
-Simpl; Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Simpl; Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Unfold constant_D_eq open_interval; Intros; Simpl in H0; Inversion H0; [Reflexivity | Elim (le_Sn_O ? H3)].
-Qed.
-
-Lemma StepFun_P4 : (a,b,c:R) (IsStepFun (fct_cte c) a b).
-Intros; Unfold IsStepFun; Case (total_order_Rle a b); Intro.
-Apply Specif.existT with (cons a (cons b nil)); Unfold is_subdivision; Apply existTT with (cons c nil); Apply (StepFun_P3 c r).
-Apply Specif.existT with (cons b (cons a nil)); Unfold is_subdivision; Apply existTT with (cons c nil); Apply StepFun_P2; Apply StepFun_P3; Auto with real.
-Qed.
-
-Lemma StepFun_P5 : (a,b:R;f:R->R;l:Rlist) (is_subdivision f a b l) -> (is_subdivision f b a l).
-Unfold is_subdivision; Intros; Elim X; Intros; Exists x; Unfold adapted_couple in p; Decompose [and] p; Clear p; Unfold adapted_couple; Repeat Split; Try Assumption.
-Rewrite H1; Unfold Rmin; Case (total_order_Rle a b); Intro; Case (total_order_Rle b a); Intro; Try Reflexivity.
-Apply Rle_antisym; Assumption.
-Apply Rle_antisym; Auto with real.
-Rewrite H0; Unfold Rmax; Case (total_order_Rle a b); Intro; Case (total_order_Rle b a); Intro; Try Reflexivity.
-Apply Rle_antisym; Assumption.
-Apply Rle_antisym; Auto with real.
-Qed.
-
-Lemma StepFun_P6 : (f:R->R;a,b:R) (IsStepFun f a b) -> (IsStepFun f b a).
-Unfold IsStepFun; Intros; Elim X; Intros; Apply Specif.existT with x; Apply StepFun_P5; Assumption.
-Qed.
-
-Lemma StepFun_P7 : (a,b,r1,r2,r3:R;f:R->R;l,lf:Rlist) ``a<=b`` -> (adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf)) -> (adapted_couple f r2 b (cons r2 l) lf).
-Unfold adapted_couple; Intros; Decompose [and] H0; Clear H0; Assert H5 : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Assert H7 : ``r2<=b``.
-Rewrite H5 in H2; Rewrite <- H2; Apply RList_P7; [Assumption | Simpl; Right; Left; Reflexivity].
-Repeat Split.
-Apply RList_P4 with r1; Assumption.
-Rewrite H5 in H2; Unfold Rmin; Case (total_order_Rle r2 b); Intro; [Reflexivity | Elim n; Assumption].
-Unfold Rmax; Case (total_order_Rle r2 b); Intro; [Rewrite H5 in H2; Rewrite <- H2; Reflexivity | Elim n; Assumption].
-Simpl in H4; Simpl; Apply INR_eq; Apply r_Rplus_plus with R1; Do 2 Rewrite (Rplus_sym R1); Do 2 Rewrite <- S_INR; Rewrite H4; Reflexivity.
-Intros; Unfold constant_D_eq open_interval; Intros; Unfold constant_D_eq open_interval in H6; Assert H9 : (lt (S i) (pred (Rlength (cons r1 (cons r2 l))))).
-Simpl; Simpl in H0; Apply lt_n_S; Assumption.
-Assert H10 := (H6 ? H9); Apply H10; Assumption.
-Qed.
-
-Lemma StepFun_P8 : (f:R->R;l1,lf1:Rlist;a,b:R) (adapted_couple f a b l1 lf1) -> a==b -> (Int_SF lf1 l1)==R0.
-Induction l1.
-Intros; Induction lf1; Reflexivity.
-Induction r0.
-Intros; Induction lf1.
-Reflexivity.
-Unfold adapted_couple in H0; Decompose [and] H0; Clear H0; Simpl in H5; Discriminate.
-Intros; Induction lf1.
-Reflexivity.
-Simpl; Cut r==r1.
-Intro; Rewrite H3; Rewrite (H0 lf1 r b).
-Ring.
-Rewrite H3; Apply StepFun_P7 with a r r3; [Right; Assumption | Assumption].
-Clear H H0 Hreclf1 r0; Unfold adapted_couple in H1; Decompose [and] H1; Intros; Simpl in H4; Rewrite H4; Unfold Rmin; Case (total_order_Rle a b); Intro; [Assumption | Reflexivity].
-Unfold adapted_couple in H1; Decompose [and] H1; Intros; Apply Rle_antisym.
-Apply (H3 O); Simpl; Apply lt_O_Sn.
-Simpl in H5; Rewrite H2 in H5; Rewrite H5; Replace (Rmin b b) with (Rmax a b); [Rewrite <- H4; Apply RList_P7; [Assumption | Simpl; Right; Left; Reflexivity] | Unfold Rmin Rmax; Case (total_order_Rle b b); Case (total_order_Rle a b); Intros; Try Assumption Orelse Reflexivity].
-Qed.
-
-Lemma StepFun_P9 : (a,b:R;f:R->R;l,lf:Rlist) (adapted_couple f a b l lf) -> ``a<>b`` -> (le (2) (Rlength l)).
-Intros; Unfold adapted_couple in H; Decompose [and] H; Clear H; Induction l; [Simpl in H4; Discriminate | Induction l; [Simpl in H3; Simpl in H2; Generalize H3; Generalize H2; Unfold Rmin Rmax; Case (total_order_Rle a b); Intros; Elim H0; Rewrite <- H5; Rewrite <- H7; Reflexivity | Simpl; Do 2 Apply le_n_S; Apply le_O_n]].
-Qed.
-
-Lemma StepFun_P10 : (f:R->R;l,lf:Rlist;a,b:R) ``a<=b`` -> (adapted_couple f a b l lf) -> (EXT l':Rlist | (EXT lf':Rlist | (adapted_couple_opt f a b l' lf'))).
-Induction l.
-Intros; Unfold adapted_couple in H0; Decompose [and] H0; Simpl in H4; Discriminate.
-Intros; Case (Req_EM a b); Intro.
-Exists (cons a nil); Exists nil; Unfold adapted_couple_opt; Unfold adapted_couple; Unfold ordered_Rlist; Repeat Split; Try (Intros; Simpl in H3; Elim (lt_n_O ? H3)).
-Simpl; Rewrite <- H2; Unfold Rmin; Case (total_order_Rle a a); Intro; Reflexivity.
-Simpl; Rewrite <- H2; Unfold Rmax; Case (total_order_Rle a a); Intro; Reflexivity.
-Elim (RList_P20 ? (StepFun_P9 H1 H2)); Intros t1 [t2 [t3 H3]]; Induction lf.
-Unfold adapted_couple in H1; Decompose [and] H1; Rewrite H3 in H7; Simpl in H7; Discriminate.
-Clear Hreclf; Assert H4 : (adapted_couple f t2 b r0 lf).
-Rewrite H3 in H1; Assert H4 := (RList_P21 ? ? H3); Simpl in H4; Rewrite H4; EApply StepFun_P7; [Apply H0 | Apply H1].
-Cut ``t2<=b``.
-Intro; Assert H6 := (H ? ? ? H5 H4); Case (Req_EM t1 t2); Intro Hyp_eq.
-Replace a with t2.
-Apply H6.
-Rewrite <- Hyp_eq; Rewrite H3 in H1; Unfold adapted_couple in H1; Decompose [and] H1; Clear H1; Simpl in H9; Rewrite H9; Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Elim H6; Clear H6; Intros l' [lf' H6]; Case (Req_EM t2 b); Intro.
-Exists (cons a (cons b nil)); Exists (cons r1 nil); Unfold adapted_couple_opt; Unfold adapted_couple; Repeat Split.
-Unfold ordered_Rlist; Intros; Simpl in H8; Inversion H8; [Simpl; Assumption | Elim (le_Sn_O ? H10)].
-Simpl; Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Simpl; Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Intros; Simpl in H8; Inversion H8.
-Unfold constant_D_eq open_interval; Intros; Simpl; Simpl in H9; Rewrite H3 in H1; Unfold adapted_couple in H1; Decompose [and] H1; Apply (H16 O).
-Simpl; Apply lt_O_Sn.
-Unfold open_interval; Simpl; Rewrite H7; Simpl in H13; Rewrite H13; Unfold Rmin; Case (total_order_Rle a b); Intro; [Assumption | Elim n; Assumption].
-Elim (le_Sn_O ? H10).
-Intros; Simpl in H8; Elim (lt_n_O ? H8).
-Intros; Simpl in H8; Inversion H8; [Simpl; Assumption | Elim (le_Sn_O ? H10)].
-Assert Hyp_min : (Rmin t2 b)==t2.
-Unfold Rmin; Case (total_order_Rle t2 b); Intro; [Reflexivity | Elim n; Assumption].
-Unfold adapted_couple in H6; Elim H6; Clear H6; Intros; Elim (RList_P20 ? (StepFun_P9 H6 H7)); Intros s1 [s2 [s3 H9]]; Induction lf'.
-Unfold adapted_couple in H6; Decompose [and] H6; Rewrite H9 in H13; Simpl in H13; Discriminate.
-Clear Hreclf'; Case (Req_EM r1 r2); Intro.
-Case (Req_EM (f t2) r1); Intro.
-Exists (cons t1 (cons s2 s3)); Exists (cons r1 lf'); Rewrite H3 in H1; Rewrite H9 in H6; Unfold adapted_couple in H6 H1; Decompose [and] H1; Decompose [and] H6; Clear H1 H6; Unfold adapted_couple_opt; Unfold adapted_couple; Repeat Split.
-Unfold ordered_Rlist; Intros; Simpl in H1; Induction i.
-Simpl; Apply Rle_trans with s1.
-Replace s1 with t2.
-Apply (H12 O).
-Simpl; Apply lt_O_Sn.
-Simpl in H19; Rewrite H19; Symmetry; Apply Hyp_min.
-Apply (H16 O); Simpl; Apply lt_O_Sn.
-Change ``(pos_Rl (cons s2 s3) i)<=(pos_Rl (cons s2 s3) (S i))``; Apply (H16 (S i)); Simpl; Assumption.
-Simpl; Simpl in H14; Rewrite H14; Reflexivity.
-Simpl; Simpl in H18; Rewrite H18; Unfold Rmax; Case (total_order_Rle a b); Case (total_order_Rle t2 b); Intros; Reflexivity Orelse Elim n; Assumption.
-Simpl; Simpl in H20; Apply H20.
-Intros; Simpl in H1; Unfold constant_D_eq open_interval; Intros; Induction i.
-Simpl; Simpl in H6; Case (total_order_T x t2); Intro.
-Elim s; Intro.
-Apply (H17 O); [Simpl; Apply lt_O_Sn | Unfold open_interval; Simpl; Elim H6; Intros; Split; Assumption].
-Rewrite b0; Assumption.
-Rewrite H10; Apply (H22 O); [Simpl; Apply lt_O_Sn | Unfold open_interval; Simpl; Replace s1 with t2; [Elim H6; Intros; Split; Assumption | Simpl in H19; Rewrite H19; Rewrite Hyp_min; Reflexivity]].
-Simpl; Simpl in H6; Apply (H22 (S i)); [Simpl; Assumption | Unfold open_interval; Simpl; Apply H6].
-Intros; Simpl in H1; Rewrite H10; Change ``(pos_Rl (cons r2 lf') i)<>(pos_Rl (cons r2 lf') (S i))``\/``(f (pos_Rl (cons s1 (cons s2 s3)) (S i)))<>(pos_Rl (cons r2 lf') i)``; Rewrite <- H9; Elim H8; Intros; Apply H6; Simpl; Apply H1.
-Intros; Induction i.
-Simpl; Red; Intro; Elim Hyp_eq; Apply Rle_antisym.
-Apply (H12 O); Simpl; Apply lt_O_Sn.
-Rewrite <- Hyp_min; Rewrite H6; Simpl in H19; Rewrite <- H19; Apply (H16 O); Simpl; Apply lt_O_Sn.
-Elim H8; Intros; Rewrite H9 in H21; Apply (H21 (S i)); Simpl; Simpl in H1; Apply H1.
-Exists (cons t1 l'); Exists (cons r1 (cons r2 lf')); Rewrite H9 in H6; Rewrite H3 in H1; Unfold adapted_couple in H1 H6; Decompose [and] H6; Decompose [and] H1; Clear H6 H1; Unfold adapted_couple_opt; Unfold adapted_couple; Repeat Split.
-Rewrite H9; Unfold ordered_Rlist; Intros; Simpl in H1; Induction i.
-Simpl; Replace s1 with t2.
-Apply (H16 O); Simpl; Apply lt_O_Sn.
-Simpl in H14; Rewrite H14; Rewrite Hyp_min; Reflexivity.
-Change ``(pos_Rl (cons s1 (cons s2 s3)) i)<=(pos_Rl (cons s1 (cons s2 s3)) (S i))``; Apply (H12 i); Simpl; Apply lt_S_n; Assumption.
-Simpl; Simpl in H19; Apply H19.
-Rewrite H9; Simpl; Simpl in H13; Rewrite H13; Unfold Rmax; Case (total_order_Rle t2 b); Case (total_order_Rle a b); Intros; Reflexivity Orelse Elim n; Assumption.
-Rewrite H9; Simpl; Simpl in H15; Rewrite H15; Reflexivity.
-Intros; Simpl in H1; Unfold constant_D_eq open_interval; Intros; Induction i.
-Simpl; Rewrite H9 in H6; Simpl in H6; Apply (H22 O).
-Simpl; Apply lt_O_Sn.
-Unfold open_interval; Simpl.
-Replace t2 with s1.
-Assumption.
-Simpl in H14; Rewrite H14; Rewrite Hyp_min; Reflexivity.
-Change (f x)==(pos_Rl (cons r2 lf') i); Clear Hreci; Apply (H17 i).
-Simpl; Rewrite H9 in H1; Simpl in H1; Apply lt_S_n; Apply H1.
-Rewrite H9 in H6; Unfold open_interval; Apply H6.
-Intros; Simpl in H1; Induction i.
-Simpl; Rewrite H9; Right; Simpl; Replace s1 with t2.
-Assumption.
-Simpl in H14; Rewrite H14; Rewrite Hyp_min; Reflexivity.
-Elim H8; Intros; Apply (H6 i).
-Simpl; Apply lt_S_n; Apply H1.
-Intros; Rewrite H9; Induction i.
-Simpl; Red; Intro; Elim Hyp_eq; Apply Rle_antisym.
-Apply (H16 O); Simpl; Apply lt_O_Sn.
-Rewrite <- Hyp_min; Rewrite H6; Simpl in H14; Rewrite <- H14; Right; Reflexivity.
-Elim H8; Intros; Rewrite <- H9; Apply (H21 i); Rewrite H9; Rewrite H9 in H1; Simpl; Simpl in H1; Apply lt_S_n; Apply H1.
-Exists (cons t1 l'); Exists (cons r1 (cons r2 lf')); Rewrite H9 in H6; Rewrite H3 in H1; Unfold adapted_couple in H1 H6; Decompose [and] H6; Decompose [and] H1; Clear H6 H1; Unfold adapted_couple_opt; Unfold adapted_couple; Repeat Split.
-Rewrite H9; Unfold ordered_Rlist; Intros; Simpl in H1; Induction i.
-Simpl; Replace s1 with t2.
-Apply (H15 O); Simpl; Apply lt_O_Sn.
-Simpl in H13; Rewrite H13; Rewrite Hyp_min; Reflexivity.
-Change ``(pos_Rl (cons s1 (cons s2 s3)) i)<=(pos_Rl (cons s1 (cons s2 s3)) (S i))``; Apply (H11 i); Simpl; Apply lt_S_n; Assumption.
-Simpl; Simpl in H18; Apply H18.
-Rewrite H9; Simpl; Simpl in H12; Rewrite H12; Unfold Rmax; Case (total_order_Rle t2 b); Case (total_order_Rle a b); Intros; Reflexivity Orelse Elim n; Assumption.
-Rewrite H9; Simpl; Simpl in H14; Rewrite H14; Reflexivity.
-Intros; Simpl in H1; Unfold constant_D_eq open_interval; Intros; Induction i.
-Simpl; Rewrite H9 in H6; Simpl in H6; Apply (H21 O).
-Simpl; Apply lt_O_Sn.
-Unfold open_interval; Simpl; Replace t2 with s1.
-Assumption.
-Simpl in H13; Rewrite H13; Rewrite Hyp_min; Reflexivity.
-Change (f x)==(pos_Rl (cons r2 lf') i); Clear Hreci; Apply (H16 i).
-Simpl; Rewrite H9 in H1; Simpl in H1; Apply lt_S_n; Apply H1.
-Rewrite H9 in H6; Unfold open_interval; Apply H6.
-Intros; Simpl in H1; Induction i.
-Simpl; Left; Assumption.
-Elim H8; Intros; Apply (H6 i).
-Simpl; Apply lt_S_n; Apply H1.
-Intros; Rewrite H9; Induction i.
-Simpl; Red; Intro; Elim Hyp_eq; Apply Rle_antisym.
-Apply (H15 O); Simpl; Apply lt_O_Sn.
-Rewrite <- Hyp_min; Rewrite H6; Simpl in H13; Rewrite <- H13; Right; Reflexivity.
-Elim H8; Intros; Rewrite <- H9; Apply (H20 i); Rewrite H9; Rewrite H9 in H1; Simpl; Simpl in H1; Apply lt_S_n; Apply H1.
-Rewrite H3 in H1; Clear H4; Unfold adapted_couple in H1; Decompose [and] H1; Clear H1; Clear H H7 H9; Cut (Rmax a b)==b; [Intro; Rewrite H in H5; Rewrite <- H5; Apply RList_P7; [Assumption | Simpl; Right; Left; Reflexivity] | Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption]].
-Qed.
-
-Lemma StepFun_P11 : (a,b,r,r1,r3,s1,s2,r4:R;r2,lf1,s3,lf2:Rlist;f:R->R) ``a<b`` -> (adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1)) -> (adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2)) -> ``r1<=s2``.
-Intros; Unfold adapted_couple_opt in H1; Elim H1; Clear H1; Intros; Unfold adapted_couple in H0 H1; Decompose [and] H0; Decompose [and] H1; Clear H0 H1; Assert H12 : r==s1.
-Simpl in H10; Simpl in H5; Rewrite H10; Rewrite H5; Reflexivity.
-Assert H14 := (H3 O (lt_O_Sn ?)); Simpl in H14; Elim H14; Intro.
-Assert H15 := (H7 O (lt_O_Sn ?)); Simpl in H15; Elim H15; Intro.
-Rewrite <- H12 in H1; Case (total_order_Rle r1 s2); Intro; Try Assumption.
-Assert H16 : ``s2<r1``; Auto with real.
-Induction s3.
-Simpl in H9; Rewrite H9 in H16; Cut ``r1<=(Rmax a b)``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H17 H16)).
-Rewrite <- H4; Apply RList_P7; [Assumption | Simpl; Right; Left; Reflexivity].
-Clear Hrecs3; Induction lf2.
-Simpl in H11; Discriminate.
-Clear Hreclf2; Assert H17 : r3==r4.
-Pose x := ``(r+s2)/2``; Assert H17 := (H8 O (lt_O_Sn ?)); Assert H18 := (H13 O (lt_O_Sn ?)); Unfold constant_D_eq open_interval in H17 H18; Simpl in H17; Simpl in H18; Rewrite <- (H17 x).
-Rewrite <- (H18 x).
-Reflexivity.
-Rewrite <- H12; Unfold x; Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite (Rplus_sym r); Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Unfold x; Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Apply Rlt_trans with s2; [Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite (Rplus_sym r); Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]] | Assumption].
-Assert H18 : (f s2)==r3.
-Apply (H8 O); [Simpl; Apply lt_O_Sn | Unfold open_interval; Simpl; Split; Assumption].
-Assert H19 : r3 == r5.
-Assert H19 := (H7 (S O)); Simpl in H19; Assert H20 := (H19 (lt_n_S ? ? (lt_O_Sn ?))); Elim H20; Intro.
-Pose x := ``(s2+(Rmin r1 r0))/2``; Assert H22 := (H8 O); Assert H23 := (H13 (S O)); Simpl in H22; Simpl in H23; Rewrite <- (H22 (lt_O_Sn ?) x).
-Rewrite <- (H23 (lt_n_S ? ? (lt_O_Sn ?)) x).
-Reflexivity.
-Unfold open_interval; Simpl; Unfold x; Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Unfold Rmin; Case (total_order_Rle r1 r0); Intro; Assumption | DiscrR]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_le_trans with ``r0+(Rmin r1 r0)``; [Do 2 Rewrite <- (Rplus_sym (Rmin r1 r0)); Apply Rlt_compatibility; Assumption | Apply Rle_compatibility; Apply Rmin_r] | DiscrR]].
-Unfold open_interval; Simpl; Unfold x; Split.
-Apply Rlt_trans with s2; [Assumption | Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Unfold Rmin; Case (total_order_Rle r1 r0); Intro; Assumption | DiscrR]]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_le_trans with ``r1+(Rmin r1 r0)``; [Do 2 Rewrite <- (Rplus_sym (Rmin r1 r0)); Apply Rlt_compatibility; Assumption | Apply Rle_compatibility; Apply Rmin_l] | DiscrR]].
-Elim H2; Clear H2; Intros; Assert H23 := (H22 (S O)); Simpl in H23; Assert H24 := (H23 (lt_n_S ? ? (lt_O_Sn ?))); Elim H24; Assumption.
-Elim H2; Intros; Assert H22 := (H20 O); Simpl in H22; Assert H23 := (H22 (lt_O_Sn ?)); Elim H23; Intro; [Elim H24; Rewrite <- H17; Rewrite <- H19; Reflexivity | Elim H24; Rewrite <- H17; Assumption].
-Elim H2; Clear H2; Intros; Assert H17 := (H16 O); Simpl in H17; Elim (H17 (lt_O_Sn ?)); Assumption.
-Rewrite <- H0; Rewrite H12; Apply (H7 O); Simpl; Apply lt_O_Sn.
-Qed.
-
-Lemma StepFun_P12 : (a,b:R;f:R->R;l,lf:Rlist) (adapted_couple_opt f a b l lf) -> (adapted_couple_opt f b a l lf).
-Unfold adapted_couple_opt; Unfold adapted_couple; Intros; Decompose [and] H; Clear H; Repeat Split; Try Assumption.
-Rewrite H0; Unfold Rmin; Case (total_order_Rle a b); Intro; Case (total_order_Rle b a); Intro; Try Reflexivity.
-Apply Rle_antisym; Assumption.
-Apply Rle_antisym; Auto with real.
-Rewrite H3; Unfold Rmax; Case (total_order_Rle a b); Intro; Case (total_order_Rle b a); Intro; Try Reflexivity.
-Apply Rle_antisym; Assumption.
-Apply Rle_antisym; Auto with real.
-Qed.
-
-Lemma StepFun_P13 : (a,b,r,r1,r3,s1,s2,r4:R;r2,lf1,s3,lf2:Rlist;f:R->R) ``a<>b`` -> (adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1)) -> (adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2)) -> ``r1<=s2``.
-Intros; Case (total_order_T a b); Intro.
-Elim s; Intro.
-EApply StepFun_P11; [Apply a0 | Apply H0 | Apply H1].
-Elim H; Assumption.
-EApply StepFun_P11; [Apply r0 | Apply StepFun_P2; Apply H0 | Apply StepFun_P12; Apply H1].
-Qed.
-
-Lemma StepFun_P14 : (f:R->R;l1,l2,lf1,lf2:Rlist;a,b:R) ``a<=b`` -> (adapted_couple f a b l1 lf1) -> (adapted_couple_opt f a b l2 lf2) -> (Int_SF lf1 l1)==(Int_SF lf2 l2).
-Induction l1.
-Intros l2 lf1 lf2 a b Hyp H H0; Unfold adapted_couple in H; Decompose [and] H; Clear H H0 H2 H3 H1 H6; Simpl in H4; Discriminate.
-Induction r0.
-Intros; Case (Req_EM a b); Intro.
-Unfold adapted_couple_opt in H2; Elim H2; Intros; Rewrite (StepFun_P8 H4 H3); Rewrite (StepFun_P8 H1 H3); Reflexivity.
-Assert H4 := (StepFun_P9 H1 H3); Simpl in H4; Elim (le_Sn_O ? (le_S_n ? ? H4)).
-Intros; Clear H; Unfold adapted_couple_opt in H3; Elim H3; Clear H3; Intros; Case (Req_EM a b); Intro.
-Rewrite (StepFun_P8 H2 H4); Rewrite (StepFun_P8 H H4); Reflexivity.
-Assert Hyp_min : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Assert Hyp_max : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Elim (RList_P20 ? (StepFun_P9 H H4)); Intros s1 [s2 [s3 H5]]; Rewrite H5 in H; Rewrite H5; Induction lf1.
-Unfold adapted_couple in H2; Decompose [and] H2; Clear H H2 H4 H5 H3 H6 H8 H7 H11; Simpl in H9; Discriminate.
-Clear Hreclf1; Induction lf2.
-Unfold adapted_couple in H; Decompose [and] H; Clear H H2 H4 H5 H3 H6 H8 H7 H11; Simpl in H9; Discriminate.
-Clear Hreclf2; Assert H6 : r==s1.
-Unfold adapted_couple in H H2; Decompose [and] H; Decompose [and] H2; Clear H H2; Simpl in H13; Simpl in H8; Rewrite H13; Rewrite H8; Reflexivity.
-Assert H7 : r3==r4\/r==r1.
-Case (Req_EM r r1); Intro.
-Right; Assumption.
-Left; Cut ``r1<=s2``.
-Intro; Unfold adapted_couple in H2 H; Decompose [and] H; Decompose [and] H2; Clear H H2; Pose x := ``(r+r1)/2``; Assert H18 := (H14 O); Assert H20 := (H19 O); Unfold constant_D_eq open_interval in H18 H20; Simpl in H18; Simpl in H20; Rewrite <- (H18 (lt_O_Sn ?) x).
-Rewrite <- (H20 (lt_O_Sn ?) x).
-Reflexivity.
-Assert H21 := (H13 O (lt_O_Sn ?)); Simpl in H21; Elim H21; Intro; [Idtac | Elim H7; Assumption]; Unfold x; Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Apply H | DiscrR]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite <- (Rplus_sym r1); Rewrite double; Apply Rlt_compatibility; Apply H | DiscrR]].
-Rewrite <- H6; Assert H21 := (H13 O (lt_O_Sn ?)); Simpl in H21; Elim H21; Intro; [Idtac | Elim H7; Assumption]; Unfold x; Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Apply H | DiscrR]].
-Apply Rlt_le_trans with r1; [Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite <- (Rplus_sym r1); Rewrite double; Apply Rlt_compatibility; Apply H | DiscrR]] | Assumption].
-EApply StepFun_P13.
-Apply H4.
-Apply H2.
-Unfold adapted_couple_opt; Split.
-Apply H.
-Rewrite H5 in H3; Apply H3.
-Assert H8 : ``r1<=s2``.
-EApply StepFun_P13.
-Apply H4.
-Apply H2.
-Unfold adapted_couple_opt; Split.
-Apply H.
-Rewrite H5 in H3; Apply H3.
-Elim H7; Intro.
-Simpl; Elim H8; Intro.
-Replace ``r4*(s2-s1)`` with ``r3*(r1-r)+r3*(s2-r1)``; [Idtac | Rewrite H9; Rewrite H6; Ring].
-Rewrite Rplus_assoc; Apply Rplus_plus_r; Change (Int_SF lf1 (cons r1 r2))==(Int_SF (cons r3 lf2) (cons r1 (cons s2 s3))); Apply H0 with r1 b.
-Unfold adapted_couple in H2; Decompose [and] H2; Clear H2; Replace b with (Rmax a b).
-Rewrite <- H12; Apply RList_P7; [Assumption | Simpl; Right; Left; Reflexivity].
-EApply StepFun_P7.
-Apply H1.
-Apply H2.
-Unfold adapted_couple_opt; Split.
-Apply StepFun_P7 with a a r3.
-Apply H1.
-Unfold adapted_couple in H2 H; Decompose [and] H2; Decompose [and] H; Clear H H2; Assert H20 : r==a.
-Simpl in H13; Rewrite H13; Apply Hyp_min.
-Unfold adapted_couple; Repeat Split.
-Unfold ordered_Rlist; Intros; Simpl in H; Induction i.
-Simpl; Rewrite <- H20; Apply (H11 O).
-Simpl; Apply lt_O_Sn.
-Induction i.
-Simpl; Assumption.
-Change ``(pos_Rl (cons s2 s3) i)<=(pos_Rl (cons s2 s3) (S i))``; Apply (H15 (S i)); Simpl; Apply lt_S_n; Assumption.
-Simpl; Symmetry; Apply Hyp_min.
-Rewrite <- H17; Reflexivity.
-Simpl in H19; Simpl; Rewrite H19; Reflexivity.
-Intros; Simpl in H; Unfold constant_D_eq open_interval; Intros; Induction i.
-Simpl; Apply (H16 O).
-Simpl; Apply lt_O_Sn.
-Simpl in H2; Rewrite <- H20 in H2; Unfold open_interval; Simpl; Apply H2.
-Clear Hreci; Induction i.
-Simpl; Simpl in H2; Rewrite H9; Apply (H21 O).
-Simpl; Apply lt_O_Sn.
-Unfold open_interval; Simpl; Elim H2; Intros; Split.
-Apply Rle_lt_trans with r1; Try Assumption; Rewrite <- H6; Apply (H11 O); Simpl; Apply lt_O_Sn.
-Assumption.
-Clear Hreci; Simpl; Apply (H21 (S i)).
-Simpl; Apply lt_S_n; Assumption.
-Unfold open_interval; Apply H2.
-Elim H3; Clear H3; Intros; Split.
-Rewrite H9; Change (i:nat) (lt i (pred (Rlength (cons r4 lf2)))) ->``(pos_Rl (cons r4 lf2) i)<>(pos_Rl (cons r4 lf2) (S i))``\/``(f (pos_Rl (cons s1 (cons s2 s3)) (S i)))<>(pos_Rl (cons r4 lf2) i)``; Rewrite <- H5; Apply H3.
-Rewrite H5 in H11; Intros; Simpl in H12; Induction i.
-Simpl; Red; Intro; Rewrite H13 in H10; Elim (Rlt_antirefl ? H10).
-Clear Hreci; Apply (H11 (S i)); Simpl; Apply H12.
-Rewrite H9; Rewrite H10; Rewrite H6; Apply Rplus_plus_r; Rewrite <- H10; Apply H0 with r1 b.
-Unfold adapted_couple in H2; Decompose [and] H2; Clear H2; Replace b with (Rmax a b).
-Rewrite <- H12; Apply RList_P7; [Assumption | Simpl; Right; Left; Reflexivity].
-EApply StepFun_P7.
-Apply H1.
-Apply H2.
-Unfold adapted_couple_opt; Split.
-Apply StepFun_P7 with a a r3.
-Apply H1.
-Unfold adapted_couple in H2 H; Decompose [and] H2; Decompose [and] H; Clear H H2; Assert H20 : r==a.
-Simpl in H13; Rewrite H13; Apply Hyp_min.
-Unfold adapted_couple; Repeat Split.
-Unfold ordered_Rlist; Intros; Simpl in H; Induction i.
-Simpl; Rewrite <- H20; Apply (H11 O); Simpl; Apply lt_O_Sn.
-Rewrite H10; Apply (H15 (S i)); Simpl; Assumption.
-Simpl; Symmetry; Apply Hyp_min.
-Rewrite <- H17; Rewrite H10; Reflexivity.
-Simpl in H19; Simpl; Apply H19.
-Intros; Simpl in H; Unfold constant_D_eq open_interval; Intros; Induction i.
-Simpl; Apply (H16 O).
-Simpl; Apply lt_O_Sn.
-Simpl in H2; Rewrite <- H20 in H2; Unfold open_interval; Simpl; Apply H2.
-Clear Hreci; Simpl; Apply (H21 (S i)).
-Simpl; Assumption.
-Rewrite <- H10; Unfold open_interval; Apply H2.
-Elim H3; Clear H3; Intros; Split.
-Rewrite H5 in H3; Intros; Apply (H3 (S i)).
-Simpl; Replace (Rlength lf2) with (S (pred (Rlength lf2))).
-Apply lt_n_S; Apply H12.
-Symmetry; Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H12; Elim (lt_n_O ? H12).
-Intros; Simpl in H12; Rewrite H10; Rewrite H5 in H11; Apply (H11 (S i)); Simpl; Apply lt_n_S; Apply H12.
-Simpl; Rewrite H9; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rmult_Or; Rewrite Rplus_Ol; Change (Int_SF lf1 (cons r1 r2))==(Int_SF (cons r4 lf2) (cons s1 (cons s2 s3))); EApply H0.
-Apply H1.
-2: Rewrite H5 in H3; Unfold adapted_couple_opt; Split; Assumption.
-Assert H10 : r==a.
-Unfold adapted_couple in H2; Decompose [and] H2; Clear H2; Simpl in H12; Rewrite H12; Apply Hyp_min.
-Rewrite <- H9; Rewrite H10; Apply StepFun_P7 with a r r3; [Apply H1 | Pattern 2 a; Rewrite <- H10; Pattern 2 r; Rewrite H9; Apply H2].
-Qed.
-
-Lemma StepFun_P15 : (f:R->R;l1,l2,lf1,lf2:Rlist;a,b:R) (adapted_couple f a b l1 lf1) -> (adapted_couple_opt f a b l2 lf2) -> (Int_SF lf1 l1)==(Int_SF lf2 l2).
-Intros; Case (total_order_Rle a b); Intro; [Apply (StepFun_P14 r H H0) | Assert H1 : ``b<=a``; [Auto with real | EApply StepFun_P14; [Apply H1 | Apply StepFun_P2; Apply H | Apply StepFun_P12; Apply H0]]].
-Qed.
-
-Lemma StepFun_P16 : (f:R->R;l,lf:Rlist;a,b:R) (adapted_couple f a b l lf) -> (EXT l':Rlist | (EXT lf':Rlist | (adapted_couple_opt f a b l' lf'))). 
-Intros; Case (total_order_Rle a b); Intro; [Apply (StepFun_P10 r H) | Assert H1 : ``b<=a``; [Auto with real | Assert H2 := (StepFun_P10 H1 (StepFun_P2 H)); Elim H2; Intros l' [lf' H3]; Exists l'; Exists lf'; Apply StepFun_P12; Assumption]].
-Qed.
-
-Lemma StepFun_P17 : (f:R->R;l1,l2,lf1,lf2:Rlist;a,b:R) (adapted_couple f a b l1 lf1) -> (adapted_couple f a b l2 lf2) -> (Int_SF lf1 l1)==(Int_SF lf2 l2).
-Intros; Elim (StepFun_P16 H); Intros l' [lf' H1]; Rewrite (StepFun_P15 H H1); Rewrite (StepFun_P15 H0 H1); Reflexivity.
-Qed.
-
-Lemma StepFun_P18 : (a,b,c:R) (RiemannInt_SF (mkStepFun (StepFun_P4 a b c)))==``c*(b-a)``.
-Intros; Unfold RiemannInt_SF; Case (total_order_Rle a b); Intro.
-Replace (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c))) (subdivision (mkStepFun (StepFun_P4 a b c)))) with (Int_SF (cons c nil) (cons a (cons b nil))); [Simpl; Ring | Apply StepFun_P17 with (fct_cte c) a b; [Apply StepFun_P3; Assumption | Apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c)))]].
-Replace (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c))) (subdivision (mkStepFun (StepFun_P4 a b c)))) with (Int_SF (cons c nil) (cons b (cons a nil))); [Simpl; Ring | Apply StepFun_P17 with (fct_cte c) a b; [Apply StepFun_P2; Apply StepFun_P3; Auto with real | Apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c)))]].
-Qed.
-
-Lemma StepFun_P19 : (l1:Rlist;f,g:R->R;l:R) (Int_SF (FF l1 [x:R]``(f x)+l*(g x)``) l1)==``(Int_SF (FF l1 f) l1)+l*(Int_SF (FF l1 g) l1)``.
-Intros; Induction l1; [Simpl; Ring | Induction l1; Simpl; [Ring | Simpl in Hrecl1; Rewrite Hrecl1; Ring]].
-Qed.
-
-Lemma StepFun_P20 : (l:Rlist;f:R->R) (lt O (Rlength l)) -> (Rlength l)=(S (Rlength (FF l f))).
-Intros l f H; NewInduction l; [Elim (lt_n_n ? H) | Simpl; Rewrite RList_P18; Rewrite RList_P14; Reflexivity].
-Qed.
-
-Lemma StepFun_P21 : (a,b:R;f:R->R;l:Rlist) (is_subdivision f a b l) -> (adapted_couple f a b l (FF l f)).
-Intros; Unfold adapted_couple; Unfold is_subdivision in X; Unfold adapted_couple in X; Elim X; Clear X; Intros; Decompose [and] p; Clear p; Repeat Split; Try Assumption.
-Apply StepFun_P20; Rewrite H2; Apply lt_O_Sn.
-Intros; Assert H5 := (H4 ? H3); Unfold constant_D_eq open_interval in H5; Unfold constant_D_eq open_interval; Intros; Induction l.
-Discriminate.
-Unfold FF; Rewrite RList_P12.
-Simpl; Change (f x0)==(f (pos_Rl (mid_Rlist (cons r l) r) (S i))); Rewrite RList_P13; Try Assumption; Rewrite (H5 x0 H6); Rewrite H5.
-Reflexivity.
-Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Elim H6; Intros; Apply Rlt_trans with x0; Assumption | DiscrR]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Rewrite (Rplus_sym (pos_Rl (cons r l) i)); Apply Rlt_compatibility; Elim H6; Intros; Apply Rlt_trans with x0; Assumption | DiscrR]].
-Rewrite RList_P14; Simpl in H3; Apply H3.
-Qed.
-
-Lemma StepFun_P22 : (a,b:R;f,g:R->R;lf,lg:Rlist) ``a<=b`` -> (is_subdivision f a b lf) -> (is_subdivision g a b lg) -> (is_subdivision f a b (cons_ORlist lf lg)).
-Unfold is_subdivision; Intros a b f g lf lg Hyp X X0; Elim X; Elim X0; Clear X X0; Intros lg0 p lf0 p0; Assert Hyp_min : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Assert Hyp_max : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Apply existTT with (FF (cons_ORlist lf lg) f); Unfold adapted_couple in p p0; Decompose [and] p; Decompose [and] p0; Clear p p0; Rewrite Hyp_min in H6; Rewrite Hyp_min in H1; Rewrite Hyp_max in H0; Rewrite Hyp_max in H5; Unfold adapted_couple; Repeat Split.
-Apply RList_P2; Assumption.
-Rewrite Hyp_min; Symmetry; Apply Rle_antisym.
-Induction lf.
-Simpl; Right; Symmetry; Assumption.
-Assert H10 : (In (pos_Rl (cons_ORlist (cons r lf) lg) (0)) (cons_ORlist (cons r lf) lg)).
-Elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) (0))); Intros _ H10; Apply H10; Exists O; Split; [Reflexivity | Rewrite RList_P11; Simpl; Apply lt_O_Sn].
-Elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) (0))); Intros H12 _; Assert H13 := (H12 H10); Elim H13; Intro.
-Elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) (0))); Intros H11 _; Assert H14 := (H11 H8); Elim H14; Intros; Elim H15; Clear H15; Intros; Rewrite H15; Rewrite <- H6; Elim (RList_P6 (cons r lf)); Intros; Apply H17; [Assumption | Apply le_O_n | Assumption].
-Elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) (0))); Intros H11 _; Assert H14 := (H11 H8); Elim H14; Intros; Elim H15; Clear H15; Intros; Rewrite H15; Rewrite <- H1; Elim (RList_P6 lg); Intros; Apply H17; [Assumption | Apply le_O_n | Assumption].
-Induction lf.
-Simpl; Right; Assumption.
-Assert H8 : (In a (cons_ORlist (cons r lf) lg)).
-Elim (RList_P9 (cons r lf) lg a); Intros; Apply H10; Left; Elim (RList_P3 (cons r lf) a); Intros; Apply H12; Exists O; Split; [Symmetry; Assumption | Simpl; Apply lt_O_Sn].
-Apply RList_P5; [Apply RList_P2; Assumption | Assumption].
-Rewrite Hyp_max; Apply Rle_antisym.
-Induction lf.
-Simpl; Right; Assumption.
-Assert H8 : (In (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg)))) (cons_ORlist (cons r lf) lg)).
-Elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg))))); Intros _ H10; Apply H10; Exists (pred (Rlength (cons_ORlist (cons r lf) lg))); Split; [Reflexivity | Rewrite RList_P11; Simpl; Apply lt_n_Sn].
-Elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg))))); Intros H10 _.
-Assert H11 := (H10 H8); Elim H11; Intro.
-Elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg))))); Intros H13 _; Assert H14 := (H13 H12); Elim H14; Intros; Elim H15; Clear H15; Intros; Rewrite H15; Rewrite <- H5; Elim (RList_P6 (cons r lf)); Intros; Apply H17; [Assumption | Simpl; Simpl in H14; Apply lt_n_Sm_le; Assumption | Simpl; Apply lt_n_Sn].
-Elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg))))); Intros H13 _; Assert H14 := (H13 H12); Elim H14; Intros; Elim H15; Clear H15; Intros.
-Rewrite H15; Assert H17 : (Rlength lg)=(S (pred (Rlength lg))).
-Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H17 in H16; Elim (lt_n_O ? H16).
-Rewrite <- H0; Elim (RList_P6 lg); Intros; Apply H18; [Assumption | Rewrite H17 in H16; Apply lt_n_Sm_le; Assumption | Apply lt_pred_n_n; Rewrite H17; Apply lt_O_Sn].
-Induction lf.
-Simpl; Right; Symmetry; Assumption.
-Assert H8 : (In b (cons_ORlist (cons r lf) lg)).
-Elim (RList_P9 (cons r lf) lg b); Intros; Apply H10; Left; Elim (RList_P3 (cons r lf) b); Intros; Apply H12; Exists (pred (Rlength (cons r lf))); Split; [Symmetry; Assumption | Simpl; Apply lt_n_Sn].
-Apply RList_P7; [Apply RList_P2; Assumption | Assumption].
-Apply StepFun_P20; Rewrite RList_P11; Rewrite H2; Rewrite H7; Simpl; Apply lt_O_Sn.
-Intros; Unfold constant_D_eq open_interval; Intros; Cut (EXT l:R | (constant_D_eq f (open_interval (pos_Rl (cons_ORlist lf lg) i) (pos_Rl (cons_ORlist lf lg) (S i))) l)).
-Intros; Elim H11; Clear H11; Intros; Assert H12 := H11; Assert Hyp_cons : (EXT r:R | (EXT r0:Rlist | (cons_ORlist lf lg)==(cons r r0))).
-Apply RList_P19; Red; Intro; Rewrite H13 in H8; Elim (lt_n_O ? H8).
-Elim Hyp_cons; Clear Hyp_cons; Intros r [r0 Hyp_cons]; Rewrite Hyp_cons; Unfold FF; Rewrite RList_P12.
-Change (f x)==(f (pos_Rl (mid_Rlist (cons r r0) r) (S i))); Rewrite <- Hyp_cons; Rewrite RList_P13.
-Assert H13 := (RList_P2 ? ? H ? H8); Elim H13; Intro.
-Unfold constant_D_eq open_interval in H11 H12; Rewrite (H11 x H10); Assert H15 : ``(pos_Rl (cons_ORlist lf lg) i)<((pos_Rl (cons_ORlist lf lg) i)+(pos_Rl (cons_ORlist lf lg) (S i)))/2<(pos_Rl (cons_ORlist lf lg) (S i))``.
-Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Rewrite (Rplus_sym (pos_Rl (cons_ORlist lf lg) i)); Apply Rlt_compatibility; Assumption | DiscrR]].
-Rewrite (H11 ? H15); Reflexivity.
-Elim H10; Intros; Rewrite H14 in H15; Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H16 H15)).
-Apply H8.
-Rewrite RList_P14; Rewrite Hyp_cons in H8; Simpl in H8; Apply H8.
-Assert H11 : ``a<b``.
-Apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i).
-Rewrite <- H6; Rewrite <- (RList_P15 lf lg).
-Elim (RList_P6 (cons_ORlist lf lg)); Intros; Apply H11.
-Apply RList_P2; Assumption.
-Apply le_O_n.
-Apply lt_trans with (pred (Rlength (cons_ORlist lf lg))); [Assumption | Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H8; Elim (lt_n_O ? H8)].
-Assumption.
-Assumption.
-Rewrite H1; Assumption.
-Apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
-Elim H10; Intros; Apply Rlt_trans with x; Assumption.
-Rewrite <- H5; Rewrite <- (RList_P16 lf lg); Try Assumption.
-Elim (RList_P6 (cons_ORlist lf lg)); Intros; Apply H11.
-Apply RList_P2; Assumption.
-Apply lt_n_Sm_le; Apply lt_n_S; Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H8; Elim (lt_n_O ? H8).
-Rewrite H0; Assumption.
-Pose I := [j:nat]``(pos_Rl lf j)<=(pos_Rl (cons_ORlist lf lg) i)``/\(lt j (Rlength lf)); Assert H12 : (Nbound I).
-Unfold Nbound; Exists (Rlength lf); Intros; Unfold I in H12; Elim H12; Intros; Apply lt_le_weak; Assumption.
-Assert H13 : (EX n:nat | (I n)).
-Exists O; Unfold I; Split.
-Apply Rle_trans with (pos_Rl (cons_ORlist lf lg) O).
-Right; Symmetry.
-Apply RList_P15; Try Assumption; Rewrite H1; Assumption.
-Elim (RList_P6 (cons_ORlist lf lg)); Intros; Apply H13.
-Apply RList_P2; Assumption.
-Apply le_O_n.
-Apply lt_trans with (pred (Rlength (cons_ORlist lf lg))).
-Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H15 in H8; Elim (lt_n_O ? H8).
-Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H5; Rewrite <- H6 in H11; Rewrite <- H5 in H11; Elim (Rlt_antirefl ? H11).
-Assert H14 := (Nzorn H13 H12); Elim H14; Clear H14; Intros x0 H14; Exists (pos_Rl lf0 x0); Unfold constant_D_eq open_interval; Intros; Assert H16 := (H9 x0); Assert H17 : (lt x0 (pred (Rlength lf))).
-Elim H14; Clear H14; Intros; Unfold I in H14; Elim H14; Clear H14; Intros; Apply lt_S_n; Replace (S (pred (Rlength lf))) with (Rlength lf).
-Inversion H18.
-2:Apply lt_n_S; Assumption.
-Cut x0=(pred (Rlength lf)).
-Intro; Rewrite H19 in H14; Rewrite H5 in H14; Cut ``(pos_Rl (cons_ORlist lf lg) i)<b``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H14 H21)).
-Apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
-Elim H10; Intros; Apply Rlt_trans with x; Assumption.
-Rewrite <- H5; Apply Rle_trans with (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))).
-Elim (RList_P6 (cons_ORlist lf lg)); Intros; Apply H21.
-Apply RList_P2; Assumption.
-Apply lt_n_Sm_le; Apply lt_n_S; Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H23 in H8; Elim (lt_n_O ? H8).
-Right; Apply RList_P16; Try Assumption; Rewrite H0; Assumption.
-Rewrite <- H20; Reflexivity.
-Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H19 in H18; Elim (lt_n_O ? H18).
-Assert H18 := (H16 H17); Unfold constant_D_eq open_interval in H18; Rewrite (H18 x1).
-Reflexivity.
-Elim H15; Clear H15; Intros; Elim H14; Clear H14; Intros; Unfold I in H14; Elim H14; Clear H14; Intros; Split.
-Apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); Assumption.
-Apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); Try Assumption.
-Assert H22 : (lt (S x0) (Rlength lf)).
-Replace (Rlength lf) with (S (pred (Rlength lf))); [Apply lt_n_S; Assumption | Symmetry; Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H22 in H21; Elim (lt_n_O ? H21)].
-Elim (total_order_Rle (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); Intro.
-Assert H23 : (le (S x0) x0).
-Apply H20; Unfold I; Split; Assumption.
-Elim (le_Sn_n ? H23).
-Assert H23 : ``(pos_Rl (cons_ORlist lf lg) i)<(pos_Rl lf (S x0))``.
-Auto with real.
-Clear b0; Apply RList_P17; Try Assumption.
-Apply RList_P2; Assumption.
-Elim (RList_P9 lf lg (pos_Rl lf (S x0))); Intros; Apply H25; Left; Elim (RList_P3 lf (pos_Rl lf (S x0))); Intros; Apply H27; Exists (S x0); Split; [Reflexivity | Apply H22].
-Qed.
-
-Lemma StepFun_P23 : (a,b:R;f,g:R->R;lf,lg:Rlist) (is_subdivision f a b lf) -> (is_subdivision g a b lg) -> (is_subdivision f a b (cons_ORlist lf lg)).
-Intros; Case (total_order_Rle a b); Intro; [Apply StepFun_P22 with g; Assumption | Apply StepFun_P5; Apply StepFun_P22 with g; [Auto with real | Apply StepFun_P5; Assumption | Apply StepFun_P5; Assumption]].
-Qed.
-
-Lemma StepFun_P24 : (a,b:R;f,g:R->R;lf,lg:Rlist) ``a<=b`` -> (is_subdivision f a b lf) -> (is_subdivision g a b lg) -> (is_subdivision g a b (cons_ORlist lf lg)).
-Unfold is_subdivision; Intros a b f g lf lg Hyp X X0; Elim X; Elim X0; Clear X X0; Intros lg0 p lf0 p0; Assert Hyp_min : (Rmin a b)==a.
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Assert Hyp_max : (Rmax a b)==b.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Apply existTT with (FF (cons_ORlist lf lg) g); Unfold adapted_couple in p p0; Decompose [and] p; Decompose [and] p0; Clear p p0; Rewrite Hyp_min in H1; Rewrite Hyp_min in H6; Rewrite Hyp_max in H0; Rewrite Hyp_max in H5; Unfold adapted_couple; Repeat Split.
-Apply RList_P2; Assumption.
-Rewrite Hyp_min; Symmetry; Apply Rle_antisym.
-Induction lf.
-Simpl; Right; Symmetry; Assumption.
-Assert H10 : (In (pos_Rl (cons_ORlist (cons r lf) lg) (0)) (cons_ORlist (cons r lf) lg)).
-Elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) (0))); Intros _ H10; Apply H10; Exists O; Split; [Reflexivity | Rewrite RList_P11; Simpl; Apply lt_O_Sn].
-Elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) (0))); Intros H12 _; Assert H13 := (H12 H10); Elim H13; Intro.
-Elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) (0))); Intros H11 _; Assert H14 := (H11 H8); Elim H14; Intros; Elim H15; Clear H15; Intros; Rewrite H15; Rewrite <- H6; Elim (RList_P6 (cons r lf)); Intros; Apply H17; [Assumption | Apply le_O_n | Assumption].
-Elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) (0))); Intros H11 _; Assert H14 := (H11 H8); Elim H14; Intros; Elim H15; Clear H15; Intros; Rewrite H15; Rewrite <- H1; Elim (RList_P6 lg); Intros; Apply H17; [Assumption | Apply le_O_n | Assumption].
-Induction lf.
-Simpl; Right; Assumption.
-Assert H8 : (In a (cons_ORlist (cons r lf) lg)).
-Elim (RList_P9 (cons r lf) lg a); Intros; Apply H10; Left; Elim (RList_P3 (cons r lf) a); Intros; Apply H12; Exists O; Split; [Symmetry; Assumption | Simpl; Apply lt_O_Sn].
-Apply RList_P5; [Apply RList_P2; Assumption | Assumption].
-Rewrite Hyp_max; Apply Rle_antisym.
-Induction lf.
-Simpl; Right; Assumption.
-Assert H8 : (In (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg)))) (cons_ORlist (cons r lf) lg)).
-Elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg))))); Intros _ H10; Apply H10; Exists (pred (Rlength (cons_ORlist (cons r lf) lg))); Split; [Reflexivity | Rewrite RList_P11; Simpl; Apply lt_n_Sn].
-Elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg))))); Intros H10 _; Assert H11 := (H10 H8); Elim H11; Intro.
-Elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg))))); Intros H13 _; Assert H14 := (H13 H12); Elim H14; Intros; Elim H15; Clear H15; Intros; Rewrite H15; Rewrite <- H5; Elim (RList_P6 (cons r lf)); Intros; Apply H17; [Assumption | Simpl; Simpl in H14; Apply lt_n_Sm_le; Assumption | Simpl; Apply lt_n_Sn].
-Elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) (pred (Rlength (cons_ORlist (cons r lf) lg))))); Intros H13 _; Assert H14 := (H13 H12); Elim H14; Intros; Elim H15; Clear H15; Intros; Rewrite H15; Assert H17 : (Rlength lg)=(S (pred (Rlength lg))).
-Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H17 in H16; Elim (lt_n_O ? H16).
-Rewrite <- H0; Elim (RList_P6 lg); Intros; Apply H18; [Assumption | Rewrite H17 in H16; Apply lt_n_Sm_le; Assumption | Apply lt_pred_n_n; Rewrite H17; Apply lt_O_Sn].
-Induction lf.
-Simpl; Right; Symmetry; Assumption.
-Assert H8 : (In b (cons_ORlist (cons r lf) lg)).
-Elim (RList_P9 (cons r lf) lg b); Intros; Apply H10; Left; Elim (RList_P3 (cons r lf) b); Intros; Apply H12; Exists (pred (Rlength (cons r lf))); Split; [Symmetry; Assumption | Simpl; Apply lt_n_Sn].
-Apply RList_P7; [Apply RList_P2; Assumption | Assumption].
-Apply StepFun_P20; Rewrite RList_P11; Rewrite H7; Rewrite H2; Simpl; Apply lt_O_Sn.
-Unfold constant_D_eq open_interval; Intros; Cut (EXT l:R | (constant_D_eq g (open_interval (pos_Rl (cons_ORlist lf lg) i) (pos_Rl (cons_ORlist lf lg) (S i))) l)).
-Intros; Elim H11; Clear H11; Intros;  Assert H12 := H11; Assert Hyp_cons : (EXT r:R | (EXT r0:Rlist | (cons_ORlist lf lg)==(cons r r0))).
-Apply RList_P19; Red; Intro; Rewrite H13 in H8; Elim (lt_n_O ? H8).
-Elim Hyp_cons; Clear Hyp_cons; Intros r [r0 Hyp_cons]; Rewrite Hyp_cons; Unfold FF; Rewrite RList_P12.
-Change (g x)==(g (pos_Rl (mid_Rlist (cons r r0) r) (S i))); Rewrite <- Hyp_cons; Rewrite RList_P13.
-Assert H13 := (RList_P2 ? ? H ? H8); Elim H13; Intro.
-Unfold constant_D_eq open_interval in H11 H12; Rewrite (H11 x H10); Assert H15 : ``(pos_Rl (cons_ORlist lf lg) i)<((pos_Rl (cons_ORlist lf lg) i)+(pos_Rl (cons_ORlist lf lg) (S i)))/2<(pos_Rl (cons_ORlist lf lg) (S i))``.
-Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Rewrite (Rplus_sym (pos_Rl (cons_ORlist lf lg) i)); Apply Rlt_compatibility; Assumption | DiscrR]].
-Rewrite (H11 ? H15); Reflexivity.
-Elim H10; Intros; Rewrite H14 in H15; Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H16 H15)).
-Apply H8.
-Rewrite RList_P14; Rewrite Hyp_cons in H8; Simpl in H8; Apply H8.
-Assert H11 : ``a<b``.
-Apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i).
-Rewrite <- H6; Rewrite <- (RList_P15 lf lg); Try Assumption.
-Elim (RList_P6 (cons_ORlist lf lg)); Intros; Apply H11.
-Apply RList_P2; Assumption.
-Apply le_O_n.
-Apply lt_trans with (pred (Rlength (cons_ORlist lf lg))); [Assumption | Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H8; Elim (lt_n_O ? H8)].
-Rewrite H1; Assumption.
-Apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
-Elim H10; Intros; Apply Rlt_trans with x; Assumption.
-Rewrite <- H5; Rewrite <- (RList_P16 lf lg); Try Assumption.
-Elim (RList_P6 (cons_ORlist lf lg)); Intros; Apply H11.
-Apply RList_P2; Assumption.
-Apply lt_n_Sm_le; Apply lt_n_S; Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H8; Elim (lt_n_O ? H8).
-Rewrite H0; Assumption.
-Pose I := [j:nat]``(pos_Rl lg j)<=(pos_Rl (cons_ORlist lf lg) i)``/\(lt j (Rlength lg)); Assert H12 : (Nbound I).
-Unfold Nbound; Exists (Rlength lg); Intros; Unfold I in H12; Elim H12; Intros; Apply lt_le_weak; Assumption.
-Assert H13 : (EX n:nat | (I n)).
-Exists O; Unfold I; Split.
-Apply Rle_trans with (pos_Rl (cons_ORlist lf lg) O).
-Right; Symmetry; Rewrite H1; Rewrite <- H6; Apply RList_P15; Try Assumption; Rewrite H1; Assumption.
-Elim (RList_P6 (cons_ORlist lf lg)); Intros; Apply H13; [Apply RList_P2; Assumption | Apply le_O_n | Apply lt_trans with (pred (Rlength (cons_ORlist lf lg))); [Assumption | Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H15 in H8; Elim (lt_n_O ? H8)]].
-Apply neq_O_lt; Red; Intro; Rewrite <- H13 in H0; Rewrite <- H1 in H11; Rewrite <- H0 in H11; Elim (Rlt_antirefl ? H11).
-Assert H14 := (Nzorn H13 H12); Elim H14; Clear H14; Intros x0 H14; Exists (pos_Rl lg0 x0); Unfold constant_D_eq open_interval; Intros; Assert H16 := (H4 x0); Assert H17 : (lt x0 (pred (Rlength lg))).
-Elim H14; Clear H14; Intros; Unfold I in H14; Elim H14; Clear H14; Intros; Apply lt_S_n; Replace (S (pred (Rlength lg))) with (Rlength lg).
-Inversion H18.
-2:Apply lt_n_S; Assumption.
-Cut x0=(pred (Rlength lg)).
-Intro; Rewrite H19 in H14; Rewrite H0 in H14; Cut ``(pos_Rl (cons_ORlist lf lg) i)<b``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H14 H21)).
-Apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
-Elim H10; Intros; Apply Rlt_trans with x; Assumption.
-Rewrite <- H0; Apply Rle_trans with (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))).
-Elim (RList_P6 (cons_ORlist lf lg)); Intros; Apply H21.
-Apply RList_P2; Assumption.
-Apply lt_n_Sm_le; Apply lt_n_S; Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H23 in H8; Elim (lt_n_O ? H8).
-Right; Rewrite H0; Rewrite <- H5; Apply RList_P16; Try Assumption.
-Rewrite H0; Assumption.
-Rewrite <- H20; Reflexivity.
-Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H19 in H18; Elim (lt_n_O ? H18).
-Assert H18 := (H16 H17); Unfold constant_D_eq open_interval in H18; Rewrite (H18 x1).
-Reflexivity.
-Elim H15; Clear H15; Intros; Elim H14; Clear H14; Intros; Unfold I in H14; Elim H14; Clear H14; Intros; Split.
-Apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); Assumption.
-Apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); Try Assumption.
-Assert H22 : (lt (S x0) (Rlength lg)).
-Replace (Rlength lg) with (S (pred (Rlength lg))).
-Apply lt_n_S; Assumption.
-Symmetry; Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H22 in H21; Elim (lt_n_O ? H21).
-Elim (total_order_Rle (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); Intro.
-Assert H23 : (le (S x0) x0); [Apply H20; Unfold I; Split; Assumption | Elim (le_Sn_n ? H23)].
-Assert H23 : ``(pos_Rl (cons_ORlist lf lg) i)<(pos_Rl lg (S x0))``.
-Auto with real.
-Clear b0; Apply RList_P17; Try Assumption; [Apply RList_P2; Assumption | Elim (RList_P9 lf lg (pos_Rl lg (S x0))); Intros; Apply H25; Right; Elim (RList_P3 lg (pos_Rl lg (S x0))); Intros; Apply H27; Exists (S x0); Split; [Reflexivity | Apply H22]].
-Qed.
-
-Lemma StepFun_P25 : (a,b:R;f,g:R->R;lf,lg:Rlist) (is_subdivision f a b lf) -> (is_subdivision g a b lg) -> (is_subdivision g a b (cons_ORlist lf lg)).
-Intros a b f g lf lg H H0; Case (total_order_Rle a b); Intro; [Apply StepFun_P24 with f; Assumption | Apply StepFun_P5; Apply StepFun_P24 with f; [Auto with real | Apply StepFun_P5; Assumption | Apply StepFun_P5; Assumption]].
-Qed.
-
-Lemma StepFun_P26 : (a,b,l:R;f,g:R->R;l1:Rlist) (is_subdivision f a b l1) -> (is_subdivision g a b l1) -> (is_subdivision [x:R]``(f x)+l*(g x)`` a b l1).
-Intros a b l f g l1; Unfold is_subdivision; Intros; Elim X; Elim X0; Intros; Clear X X0; Unfold adapted_couple in p p0; Decompose [and] p; Decompose [and] p0; Clear p p0; Apply existTT with (FF l1 [x:R]``(f x)+l*(g x)``); Unfold adapted_couple; Repeat Split; Try Assumption.
-Apply StepFun_P20; Apply neq_O_lt; Red; Intro; Rewrite <- H8 in H7; Discriminate.
-Intros; Unfold constant_D_eq open_interval; Unfold constant_D_eq open_interval in H9 H4; Intros; Rewrite (H9 ? H8 ? H10); Rewrite (H4 ? H8 ? H10); Assert H11 : ~l1==nil.
-Red; Intro; Rewrite H11 in H8; Elim (lt_n_O ? H8).
-Assert H12 := (RList_P19 ? H11); Elim H12; Clear H12; Intros r [r0 H12]; Rewrite H12; Unfold FF; Change ``(pos_Rl x0 i)+l*(pos_Rl x i)`` == (pos_Rl (app_Rlist (mid_Rlist (cons r r0) r) [x2:R]``(f x2)+l*(g x2)``) (S i)); Rewrite RList_P12.
-Rewrite RList_P13.
-Rewrite <- H12; Rewrite (H9 ? H8); Try Rewrite (H4 ? H8); Reflexivity Orelse (Elim H10; Clear H10; Intros; Split; [Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Apply Rlt_trans with x1; Assumption | DiscrR]] | Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Rewrite (Rplus_sym (pos_Rl l1 i)); Apply Rlt_compatibility; Apply Rlt_trans with x1; Assumption | DiscrR]]]).
-Rewrite <- H12; Assumption.
-Rewrite RList_P14; Simpl; Rewrite H12 in H8; Simpl in H8; Apply lt_n_S; Apply H8.
-Qed.
-
-Lemma StepFun_P27 : (a,b,l:R;f,g:R->R;lf,lg:Rlist) (is_subdivision f a b lf) -> (is_subdivision g a b lg) -> (is_subdivision [x:R]``(f x)+l*(g x)`` a b (cons_ORlist lf lg)).
-Intros a b l f g lf lg H H0; Apply StepFun_P26; [Apply StepFun_P23 with g; Assumption | Apply StepFun_P25 with f; Assumption].
-Qed.
-
-(* The set of step functions on [a,b] is a vectorial space *)
-Lemma StepFun_P28 : (a,b,l:R;f,g:(StepFun a b)) (IsStepFun [x:R]``(f x)+l*(g x)`` a b).
-Intros a b l f g; Unfold IsStepFun; Assert H := (pre f); Assert H0 := (pre g); Unfold IsStepFun in H H0; Elim H; Elim H0; Intros; Apply Specif.existT with (cons_ORlist x0 x); Apply StepFun_P27; Assumption.
-Qed.
-
-Lemma StepFun_P29 : (a,b:R;f:(StepFun a b)) (is_subdivision f a b (subdivision f)).
-Intros a b f; Unfold is_subdivision; Apply existTT with (subdivision_val f); Apply StepFun_P1.
-Qed.
-
-Lemma StepFun_P30 : (a,b,l:R;f,g:(StepFun a b)) ``(RiemannInt_SF (mkStepFun (StepFun_P28 l f g)))==(RiemannInt_SF f)+l*(RiemannInt_SF g)``.
-Intros a b l f g; Unfold RiemannInt_SF; Case (total_order_Rle a b); (Intro; Replace ``(Int_SF (subdivision_val (mkStepFun (StepFun_P28 l f g))) (subdivision (mkStepFun (StepFun_P28 l f g))))`` with (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) [x:R]``(f x)+l*(g x)``) (cons_ORlist (subdivision f) (subdivision g))); [Rewrite StepFun_P19; Replace (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) f) (cons_ORlist (subdivision f) (subdivision g))) with (Int_SF (subdivision_val f) (subdivision f)); [Replace (Int_SF (FF (cons_ORlist (subdivision f) (subdivision g)) g) (cons_ORlist (subdivision f) (subdivision g))) with (Int_SF (subdivision_val g) (subdivision g)); [Ring | Apply StepFun_P17 with (fe g) a b; [Apply StepFun_P1 | Apply StepFun_P21; Apply StepFun_P25 with (fe f); Apply StepFun_P29]] | Apply StepFun_P17 with (fe f) a b; [Apply StepFun_P1 | Apply StepFun_P21; Apply StepFun_P23 with (fe g); Apply StepFun_P29]] | Apply StepFun_P17 with [x:R]``(f x)+l*(g x)`` a b; [Apply StepFun_P21; Apply StepFun_P27; Apply StepFun_P29 | Apply (StepFun_P1 (mkStepFun (StepFun_P28 l f g)))]]).
-Qed.
-
-Lemma StepFun_P31 : (a,b:R;f:R->R;l,lf:Rlist) (adapted_couple f a b l lf) -> (adapted_couple [x:R](Rabsolu (f x)) a b l (app_Rlist lf Rabsolu)).
-Unfold adapted_couple; Intros; Decompose [and] H; Clear H; Repeat Split; Try Assumption.
-Symmetry; Rewrite H3; Rewrite RList_P18; Reflexivity.
-Intros; Unfold constant_D_eq open_interval; Unfold constant_D_eq open_interval in H5; Intros; Rewrite (H5 ? H ? H4); Rewrite RList_P12; [Reflexivity | Rewrite H3 in H; Simpl in H; Apply H].
-Qed.
-
-Lemma StepFun_P32 : (a,b:R;f:(StepFun a b)) (IsStepFun [x:R](Rabsolu (f x)) a b).
-Intros a b f; Unfold IsStepFun; Apply Specif.existT with (subdivision f); Unfold is_subdivision; Apply existTT with (app_Rlist (subdivision_val f) Rabsolu); Apply StepFun_P31; Apply StepFun_P1.
-Qed.
-
-Lemma StepFun_P33 : (l2,l1:Rlist) (ordered_Rlist l1) -> ``(Rabsolu (Int_SF l2 l1))<=(Int_SF (app_Rlist l2 Rabsolu) l1)``.
-Induction l2; Intros.
-Simpl; Rewrite Rabsolu_R0; Right; Reflexivity.
-Simpl; Induction l1.
-Rewrite Rabsolu_R0; Right; Reflexivity.
-Induction l1.
-Rewrite Rabsolu_R0; Right; Reflexivity.
-Apply Rle_trans with ``(Rabsolu (r*(r2-r1)))+(Rabsolu (Int_SF r0 (cons r2 l1)))``.
-Apply Rabsolu_triang.
-Rewrite Rabsolu_mult; Rewrite (Rabsolu_right ``r2-r1``); [Apply Rle_compatibility; Apply H; Apply RList_P4 with r1; Assumption | Apply Rge_minus; Apply Rle_sym1; Apply (H0 O); Simpl; Apply lt_O_Sn].
-Qed.
-
-Lemma StepFun_P34 : (a,b:R;f:(StepFun a b)) ``a<=b`` -> ``(Rabsolu (RiemannInt_SF f))<=(RiemannInt_SF (mkStepFun (StepFun_P32 f)))``.
-Intros; Unfold RiemannInt_SF; Case (total_order_Rle a b); Intro.
-Replace (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f))) (subdivision (mkStepFun (StepFun_P32 f)))) with (Int_SF (app_Rlist (subdivision_val f) Rabsolu) (subdivision f)).
-Apply StepFun_P33; Assert H0 := (StepFun_P29 f); Unfold is_subdivision in H0; Elim H0; Intros; Unfold adapted_couple in p; Decompose [and] p; Assumption.
-Apply StepFun_P17 with [x:R](Rabsolu (f x)) a b; [Apply StepFun_P31; Apply StepFun_P1 | Apply (StepFun_P1 (mkStepFun (StepFun_P32 f)))].
-Elim n; Assumption.
-Qed.
-
-Lemma StepFun_P35 : (l:Rlist;a,b:R;f,g:R->R) (ordered_Rlist l) -> (pos_Rl l O)==a -> (pos_Rl l (pred (Rlength l)))==b -> ((x:R)``a<x<b``->``(f x)<=(g x)``) -> ``(Int_SF (FF l f) l)<=(Int_SF (FF l g) l)``.
-Induction l; Intros.
-Right; Reflexivity.
-Simpl; Induction r0.
-Right; Reflexivity.
-Simpl; Apply Rplus_le.
-Case (Req_EM r r0); Intro.
-Rewrite H4; Right; Ring.
-Do 2 Rewrite <- (Rmult_sym ``r0-r``); Apply Rle_monotony.
-Apply Rle_sym2; Apply Rge_minus; Apply Rle_sym1; Apply (H0 O); Simpl; Apply lt_O_Sn.
-Apply H3; Split.
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Assert H5 : r==a.
-Apply H1.
-Rewrite H5; Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility.
-Assert H6 := (H0 O (lt_O_Sn ?)).
-Simpl in H6.
-Elim H6; Intro.
-Rewrite H5 in H7; Apply H7.
-Elim H4; Assumption.
-DiscrR.
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite double; Assert H5 : ``r0<=b``.
-Replace b with (pos_Rl (cons r (cons r0 r1)) (pred (Rlength (cons r (cons r0 r1))))).
-Replace r0 with (pos_Rl (cons r (cons r0 r1)) (S O)).
-Elim (RList_P6 (cons r (cons r0 r1))); Intros; Apply H5.
-Assumption.
-Simpl; Apply le_n_S.
-Apply le_O_n.
-Simpl; Apply lt_n_Sn.
-Reflexivity.
-Apply Rle_lt_trans with ``r+b``.
-Apply Rle_compatibility; Assumption.
-Rewrite (Rplus_sym r); Apply Rlt_compatibility.
-Apply Rlt_le_trans with r0.
-Assert H6 := (H0 O (lt_O_Sn ?)).
-Simpl in H6.
-Elim H6; Intro.
-Apply H7.
-Elim H4; Assumption.
-Assumption.
-DiscrR.
-Simpl in H; Apply H with r0 b.
-Apply RList_P4 with r; Assumption.
-Reflexivity.
-Rewrite <- H2; Reflexivity.
-Intros; Apply H3; Elim H4; Intros; Split; Try Assumption.
-Apply Rle_lt_trans with r0; Try Assumption.
-Rewrite <- H1.
-Simpl; Apply (H0 O); Simpl; Apply lt_O_Sn.
-Qed.
-
-Lemma StepFun_P36 : (a,b:R;f,g:(StepFun a b);l:Rlist) ``a<=b`` -> (is_subdivision f a b l) -> (is_subdivision g a b l) -> ((x:R)``a<x<b``->``(f x)<=(g x)``) -> ``(RiemannInt_SF f) <= (RiemannInt_SF g)``.
-Intros; Unfold RiemannInt_SF; Case (total_order_Rle a b); Intro.
-Replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l).
-Replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l).
-Unfold is_subdivision in X; Elim X; Clear X; Intros; Unfold adapted_couple in p; Decompose [and] p; Clear p; Assert H5 : (Rmin a b)==a; [Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption] | Assert H7 : (Rmax a b)==b; [Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption] | Rewrite H5 in H3; Rewrite H7 in H2; EApply StepFun_P35 with a b; Assumption]].
-Apply StepFun_P17 with (fe g) a b; [Apply StepFun_P21; Assumption | Apply StepFun_P1].
-Apply StepFun_P17 with (fe f) a b; [Apply StepFun_P21; Assumption | Apply StepFun_P1].
-Elim n; Assumption.
-Qed.
-
-Lemma StepFun_P37 : (a,b:R;f,g:(StepFun a b)) ``a<=b`` -> ((x:R)``a<x<b``->``(f x)<=(g x)``) -> ``(RiemannInt_SF f) <= (RiemannInt_SF g)``.
-Intros; EApply StepFun_P36; Try Assumption.
-EApply StepFun_P25; Apply StepFun_P29.
-EApply StepFun_P23; Apply StepFun_P29.
-Qed.
-
-Lemma StepFun_P38 : (l:Rlist;a,b:R;f:R->R) (ordered_Rlist l) -> (pos_Rl l O)==a -> (pos_Rl l (pred (Rlength l)))==b -> (sigTT ? [g:(StepFun a b)](g b)==(f b)/\(i:nat)(lt i (pred (Rlength l)))->(constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i))) (f (pos_Rl l i)))).
-Intros l a b f; Generalize a; Clear a; NewInduction l. 
-Intros a H H0 H1; Simpl in H0; Simpl in H1; Exists (mkStepFun (StepFun_P4 a b (f b))); Split.
-Reflexivity.
-Intros; Elim (lt_n_O ? H2).
-Intros; NewDestruct l as [|r1 l].
-Simpl in H1; Simpl in H0; Exists (mkStepFun (StepFun_P4 a b (f b))); Split.
-Reflexivity.
-Intros i H2; Elim (lt_n_O ? H2).
-Intros; Assert H2 : (ordered_Rlist (cons r1 l)).
-Apply RList_P4 with r; Assumption.
-Assert H3 : (pos_Rl (cons r1 l) O)==r1.
-Reflexivity.
-Assert H4 : (pos_Rl (cons r1 l) (pred (Rlength (cons r1 l))))==b.
-Rewrite <- H1; Reflexivity.
-Elim (IHl r1 H2 H3 H4); Intros g [H5 H6].
-Pose g' := [x:R]Cases (total_order_Rle r1 x) of
-                      | (leftT _) => (g x)
-                      | (rightT _) => (f a) end.
-Assert H7 : ``r1<=b``.
-Rewrite <- H4; Apply RList_P7; [Assumption | Left; Reflexivity].
-Assert H8 : (IsStepFun g' a b).
-Unfold IsStepFun; Assert H8 := (pre g); Unfold IsStepFun in H8; Elim H8; Intros lg H9; Unfold is_subdivision in H9; Elim H9; Clear H9; Intros lg2 H9; Split with (cons a lg); Unfold is_subdivision; Split with (cons (f a) lg2); Unfold adapted_couple in H9; Decompose [and] H9; Clear H9; Unfold adapted_couple; Repeat Split.
-Unfold ordered_Rlist; Intros; Simpl in H9; Induction i.
-Simpl; Rewrite H12; Replace (Rmin r1 b) with r1.
-Simpl in H0; Rewrite <- H0; Apply (H O); Simpl; Apply lt_O_Sn.
-Unfold Rmin; Case (total_order_Rle r1 b); Intro; [Reflexivity | Elim n; Assumption].
-Apply (H10 i); Apply lt_S_n.
-Replace (S (pred (Rlength lg))) with (Rlength lg).
-Apply H9.
-Apply S_pred with O; Apply neq_O_lt; Intro; Rewrite <- H14 in H9; Elim (lt_n_O ? H9).
-Simpl; Assert H14 : ``a<=b``.
-Rewrite <- H1; Simpl in H0; Rewrite <- H0; Apply RList_P7; [Assumption | Left; Reflexivity].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Assert H14 : ``a<=b``.
-Rewrite <- H1; Simpl in H0; Rewrite <- H0; Apply RList_P7; [Assumption | Left; Reflexivity].
-Replace (Rmax a b) with (Rmax r1 b).
-Rewrite <- H11; Induction lg.
-Simpl in H13; Discriminate.
-Reflexivity.
-Unfold Rmax; Case (total_order_Rle a b); Case (total_order_Rle r1 b); Intros; Reflexivity Orelse Elim n; Assumption.
-Simpl; Rewrite H13; Reflexivity.
-Intros; Simpl in H9; Induction i.
-Unfold constant_D_eq open_interval; Simpl; Intros; Assert H16 : (Rmin r1 b)==r1.
-Unfold Rmin; Case (total_order_Rle r1 b); Intro; [Reflexivity | Elim n; Assumption].
-Rewrite H16 in H12; Rewrite H12 in H14; Elim H14; Clear H14; Intros _ H14; Unfold g'; Case (total_order_Rle r1 x); Intro r3.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r3 H14)).
-Reflexivity.
-Change (constant_D_eq g' (open_interval (pos_Rl lg i) (pos_Rl lg (S i))) (pos_Rl lg2 i)); Clear Hreci; Assert H16 := (H15 i); Assert H17 : (lt i (pred (Rlength lg))).
-Apply lt_S_n.
-Replace (S (pred (Rlength lg))) with (Rlength lg).
-Assumption.
-Apply S_pred with O; Apply neq_O_lt; Red; Intro; Rewrite <- H14 in H9; Elim (lt_n_O ? H9).
-Assert H18 := (H16 H17); Unfold constant_D_eq open_interval in H18; Unfold constant_D_eq open_interval; Intros; Assert H19 := (H18 ? H14); Rewrite <- H19; Unfold g'; Case (total_order_Rle r1 x); Intro.
-Reflexivity.
-Elim n; Replace r1 with (Rmin r1 b).
-Rewrite <- H12; Elim H14; Clear H14; Intros H14 _; Left; Apply Rle_lt_trans with (pos_Rl lg i); Try Assumption.
-Apply RList_P5.
-Assumption.
-Elim (RList_P3 lg (pos_Rl lg i)); Intros; Apply H21; Exists i; Split.
-Reflexivity.
-Apply lt_trans with (pred (Rlength lg)); Try Assumption.
-Apply lt_pred_n_n; Apply neq_O_lt; Red; Intro; Rewrite <- H22 in H17; Elim (lt_n_O ? H17).
-Unfold Rmin; Case (total_order_Rle r1 b); Intro; [Reflexivity | Elim n0; Assumption].
-Exists (mkStepFun H8); Split.
-Simpl; Unfold g'; Case (total_order_Rle r1 b); Intro.
-Assumption.
-Elim n; Assumption.
-Intros; Simpl in H9; Induction i.
-Unfold constant_D_eq co_interval; Simpl; Intros; Simpl in H0; Rewrite H0; Elim H10; Clear H10; Intros; Unfold g'; Case (total_order_Rle r1 x); Intro r3.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r3 H11)).
-Reflexivity.
-Clear Hreci; Change (constant_D_eq (mkStepFun H8) (co_interval (pos_Rl (cons r1 l) i) (pos_Rl (cons r1 l) (S i))) (f (pos_Rl (cons r1 l) i))); Assert H10 := (H6 i); Assert H11 : (lt i (pred (Rlength (cons r1 l)))).
-Simpl; Apply lt_S_n; Assumption.
-Assert H12 := (H10 H11); Unfold constant_D_eq co_interval in H12; Unfold constant_D_eq co_interval; Intros; Rewrite <- (H12 ? H13); Simpl; Unfold g'; Case (total_order_Rle r1 x); Intro.
-Reflexivity.
-Elim n; Elim H13; Clear H13; Intros; Apply Rle_trans with (pos_Rl (cons r1 l) i); Try Assumption; Change ``(pos_Rl (cons r1 l) O)<=(pos_Rl (cons r1 l) i)``; Elim (RList_P6 (cons r1 l)); Intros; Apply H15; [Assumption | Apply le_O_n | Simpl; Apply lt_trans with (Rlength l); [Apply lt_S_n; Assumption | Apply lt_n_Sn]].
-Qed.
-
-Lemma StepFun_P39 : (a,b:R;f:(StepFun a b)) (RiemannInt_SF f)==(Ropp (RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))))).
-Intros; Unfold RiemannInt_SF; Case (total_order_Rle a b); Case (total_order_Rle b a); Intros.
-Assert H : (adapted_couple f a b (subdivision f) (subdivision_val f)); [Apply StepFun_P1 | Assert H0 : (adapted_couple (mkStepFun (StepFun_P6 (pre f))) b a (subdivision (mkStepFun (StepFun_P6 (pre f)))) (subdivision_val (mkStepFun (StepFun_P6 (pre f))))); [Apply StepFun_P1 | Assert H1 : a==b; [Apply Rle_antisym; Assumption | Rewrite (StepFun_P8 H H1); Assert H2 : b==a; [Symmetry; Apply H1 | Rewrite (StepFun_P8 H0 H2); Ring]]]].
-Rewrite Ropp_Ropp; EApply StepFun_P17; [Apply StepFun_P1 | Apply StepFun_P2; Pose H := (StepFun_P6 (pre f)); Unfold IsStepFun in H; Elim H; Intros; Unfold is_subdivision; Elim p; Intros; Apply p0].
-Apply eq_Ropp; EApply StepFun_P17; [Apply StepFun_P1 | Apply StepFun_P2; Pose H := (StepFun_P6 (pre f)); Unfold IsStepFun in H; Elim H; Intros; Unfold is_subdivision; Elim p; Intros; Apply p0].
-Assert H : ``a<b``; [Auto with real | Assert H0 : ``b<a``; [Auto with real | Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H H0))]].
-Qed.
-
-Lemma StepFun_P40 : (f:R->R;a,b,c:R;l1,l2,lf1,lf2:Rlist) ``a<b`` -> ``b<c`` -> (adapted_couple f a b l1 lf1) -> (adapted_couple f b c l2 lf2) -> (adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f)).
-Intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; Unfold adapted_couple in H1 H2; Unfold adapted_couple; Decompose [and] H1; Decompose [and] H2; Clear H1 H2; Repeat Split.
-Apply RList_P25; Try Assumption.
-Rewrite H10; Rewrite H4; Unfold Rmin Rmax; Case (total_order_Rle a b); Case (total_order_Rle b c); Intros; (Right; Reflexivity) Orelse (Elim n; Left; Assumption).
-Rewrite RList_P22.
-Rewrite H5; Unfold Rmin Rmax; Case (total_order_Rle a b); Case (total_order_Rle a c); Intros; [Reflexivity | Elim n; Apply Rle_trans with b; Left; Assumption | Elim n; Left; Assumption | Elim n0; Left; Assumption].
-Red; Intro; Rewrite H1 in H6; Discriminate.
-Rewrite RList_P24.
-Rewrite H9; Unfold Rmin Rmax; Case (total_order_Rle b c); Case (total_order_Rle a c); Intros; [Reflexivity | Elim n; Apply Rle_trans with b; Left; Assumption | Elim n; Left; Assumption | Elim n0; Left; Assumption].
-Red; Intro; Rewrite H1 in H11; Discriminate.
-Apply StepFun_P20.
-Rewrite RList_P23; Apply neq_O_lt; Red; Intro.
-Assert H2 : (plus (Rlength l1) (Rlength l2))=O.
-Symmetry; Apply H1.
-Elim (plus_is_O ? ? H2); Intros; Rewrite H12 in H6; Discriminate.
-Unfold constant_D_eq open_interval; Intros; Elim (le_or_lt (S (S i)) (Rlength l1)); Intro.
-Assert H14 : (pos_Rl (cons_Rlist l1 l2) i) == (pos_Rl l1 i).
-Apply RList_P26; Apply lt_S_n; Apply le_lt_n_Sm; Apply le_S_n; Apply le_trans with (Rlength l1); [Assumption | Apply le_n_Sn].
-Assert H15 : (pos_Rl (cons_Rlist l1 l2) (S i))==(pos_Rl l1 (S i)).
-Apply RList_P26; Apply lt_S_n; Apply le_lt_n_Sm; Assumption.
-Rewrite H14 in H2; Rewrite H15 in H2; Assert H16 : (le (2) (Rlength l1)).
-Apply le_trans with (S (S i)); [Repeat Apply le_n_S; Apply le_O_n | Assumption].
-Elim (RList_P20 ? H16); Intros r1 [r2 [r3 H17]]; Rewrite H17; Change (f x)==(pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i); Rewrite RList_P12.
-Induction i.
-Simpl; Assert H18 := (H8 O); Unfold constant_D_eq open_interval in H18; Assert H19 : (lt O (pred (Rlength l1))).
-Rewrite H17; Simpl; Apply lt_O_Sn.
-Assert H20 := (H18 H19); Repeat Rewrite H20.
-Reflexivity.
-Assert H21 : ``r1<=r2``.
-Rewrite H17 in H3; Apply (H3 O).
-Simpl; Apply lt_O_Sn.
-Elim H21; Intro.
-Split.
-Rewrite H17; Simpl; Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Rewrite H17; Simpl; Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite (Rplus_sym r1); Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Elim H2; Intros; Rewrite H17 in H23; Rewrite H17 in H24; Simpl in H24; Simpl in H23; Rewrite H22 in H23; Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H23 H24)).
-Assumption.
-Clear Hreci; Rewrite RList_P13.
-Rewrite H17 in H14; Rewrite H17 in H15; Change (pos_Rl (cons_Rlist (cons r2 r3) l2) i)== (pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; Rewrite H14; Change (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i))==(pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; Rewrite H15; Assert H18 := (H8 (S i)); Unfold constant_D_eq open_interval in H18; Assert H19 : (lt (S i) (pred (Rlength l1))).
-Apply lt_pred; Apply lt_S_n; Apply le_lt_n_Sm; Assumption.
-Assert H20 := (H18 H19); Repeat Rewrite H20.
-Reflexivity.
-Rewrite <- H17; Assert H21 : ``(pos_Rl l1 (S i))<=(pos_Rl l1 (S (S i)))``.
-Apply (H3 (S i)); Apply lt_pred; Apply lt_S_n; Apply le_lt_n_Sm; Assumption.
-Elim H21; Intro.
-Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite (Rplus_sym (pos_Rl l1 (S i))); Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Elim H2; Intros; Rewrite H22 in H23; Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H23 H24)).
-Assumption.
-Simpl; Rewrite H17 in H1; Simpl in H1; Apply lt_S_n; Assumption.
-Rewrite RList_P14; Rewrite H17 in H1; Simpl in H1; Apply H1.
-Inversion H12.
-Assert H16 : (pos_Rl (cons_Rlist l1 l2) (S i))==b.
-Rewrite RList_P29.
-Rewrite H15; Rewrite <- minus_n_n; Rewrite H10; Unfold Rmin; Case (total_order_Rle b c); Intro; [Reflexivity | Elim n; Left; Assumption].
-Rewrite H15; Apply le_n.
-Induction l1.
-Simpl in H15; Discriminate.
-Clear Hrecl1; Simpl in H1; Simpl; Apply lt_n_S; Assumption.
-Assert H17 : (pos_Rl (cons_Rlist l1 l2) i)==b.
-Rewrite RList_P26.
-Replace i with (pred (Rlength l1)); [Rewrite H4; Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Left; Assumption] | Rewrite H15; Reflexivity].
-Rewrite H15; Apply lt_n_Sn.
-Rewrite H16 in H2; Rewrite H17 in H2; Elim H2; Intros; Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H14 H18)).
-Assert H16 : (pos_Rl (cons_Rlist l1 l2) i) == (pos_Rl l2 (minus i (Rlength l1))).
-Apply RList_P29.
-Apply le_S_n; Assumption.
-Apply lt_le_trans with (pred (Rlength (cons_Rlist l1 l2))); [Assumption | Apply le_pred_n].
-Assert H17 : (pos_Rl (cons_Rlist l1 l2) (S i))==(pos_Rl l2 (S (minus i (Rlength l1)))).
-Replace (S (minus i (Rlength l1))) with (minus (S i) (Rlength l1)).
-Apply RList_P29.
-Apply le_S_n; Apply le_trans with (S i); [Assumption | Apply le_n_Sn].
-Induction l1.
-Simpl in H6; Discriminate.
-Clear Hrecl1; Simpl in H1; Simpl; Apply lt_n_S; Assumption.
-Symmetry; Apply minus_Sn_m; Apply le_S_n; Assumption.
-Assert H18 : (le (2) (Rlength l1)).
-Clear f c l2 lf2 H0 H3 H8 H7 H10 H9 H11 H13 i H1 x H2 H12 m H14 H15 H16 H17; Induction l1.
-Discriminate.
-Clear Hrecl1; Induction l1.
-Simpl in H5; Simpl in H4; Assert H0 : ``(Rmin a b)<(Rmax a b)``.
-Unfold Rmin Rmax; Case (total_order_Rle a b); Intro; [Assumption | Elim n; Left; Assumption].
-Rewrite <- H5 in H0; Rewrite <- H4 in H0; Elim (Rlt_antirefl ? H0).
-Clear Hrecl1; Simpl; Repeat Apply le_n_S; Apply le_O_n.
-Elim (RList_P20 ? H18); Intros r1 [r2 [r3 H19]]; Rewrite H19; Change (f x)==(pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i); Rewrite RList_P12.
-Induction i.
-Assert H20 := (le_S_n ? ? H15); Assert H21 := (le_trans ? ? ? H18 H20); Elim (le_Sn_O ? H21).
-Clear Hreci; Rewrite RList_P13.
-Rewrite H19 in H16; Rewrite H19 in H17; Change (pos_Rl (cons_Rlist (cons r2 r3) l2) i)==  (pos_Rl l2 (minus (S i) (Rlength (cons r1 (cons r2 r3))))) in H16; Rewrite H16; Change (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i))== (pos_Rl l2 (S (minus (S i) (Rlength (cons r1 (cons r2 r3)))))) in H17; Rewrite H17; Assert H20 := (H13 (minus (S i) (Rlength l1))); Unfold constant_D_eq open_interval in H20; Assert H21 : (lt (minus (S i) (Rlength l1)) (pred (Rlength l2))).
-Apply lt_pred; Rewrite minus_Sn_m.
-Apply simpl_lt_plus_l with (Rlength l1); Rewrite <- le_plus_minus.
-Rewrite H19 in H1; Simpl in H1; Rewrite H19; Simpl; Rewrite RList_P23 in H1; Apply lt_n_S; Assumption.
-Apply le_trans with (S i); [Apply le_S_n; Assumption | Apply le_n_Sn].
-Apply le_S_n; Assumption.
-Assert H22 := (H20 H21); Repeat Rewrite H22.
-Reflexivity.
-Rewrite <- H19; Assert H23 : ``(pos_Rl l2 (minus (S i) (Rlength l1)))<=(pos_Rl l2 (S (minus (S i) (Rlength l1))))``.
-Apply H7; Apply lt_pred.
-Rewrite minus_Sn_m.
-Apply simpl_lt_plus_l with (Rlength l1); Rewrite <- le_plus_minus.
-Rewrite H19 in H1; Simpl in H1; Rewrite H19; Simpl; Rewrite RList_P23 in H1; Apply lt_n_S; Assumption.
-Apply le_trans with (S i); [Apply le_S_n; Assumption | Apply le_n_Sn].
-Apply le_S_n; Assumption.
-Elim H23; Intro.
-Split.
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Apply Rlt_monotony_contra with ``2``; [Sup0 | Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym; [Rewrite Rmult_1l; Rewrite (Rplus_sym (pos_Rl l2 (minus (S i) (Rlength l1)))); Rewrite double; Apply Rlt_compatibility; Assumption | DiscrR]].
-Rewrite <- H19 in H16; Rewrite <- H19 in H17; Elim H2; Intros; Rewrite H19 in H25; Rewrite H19 in H26; Simpl in H25; Simpl in H16; Rewrite H16 in H25; Simpl in H26; Simpl in H17; Rewrite H17 in H26; Simpl in H24; Rewrite H24 in H25; Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H25 H26)).
-Assert H23 : (pos_Rl (cons_Rlist l1 l2) (S i))==(pos_Rl l2 (minus (S i) (Rlength l1))).
-Rewrite H19; Simpl; Simpl in H16; Apply H16.
-Assert H24 : (pos_Rl (cons_Rlist l1 l2) (S (S i)))==(pos_Rl l2 (S (minus (S i) (Rlength l1)))).
-Rewrite H19; Simpl; Simpl in H17; Apply H17.
-Rewrite <- H23; Rewrite <- H24; Assumption.
-Simpl; Rewrite H19 in H1; Simpl in H1; Apply lt_S_n; Assumption.
-Rewrite RList_P14; Rewrite H19 in H1; Simpl in H1; Simpl; Apply H1.
-Qed.
-
-Lemma StepFun_P41 : (f:R->R;a,b,c:R) ``a<=b``->``b<=c``->(IsStepFun f a b) -> (IsStepFun f b c) -> (IsStepFun f a c).
-Unfold IsStepFun; Unfold is_subdivision; Intros; Elim X; Clear X; Intros l1 [lf1 H1]; Elim X0; Clear X0; Intros l2 [lf2 H2]; Case (total_order_T a b); Intro.
-Elim s; Intro.
-Case (total_order_T b c); Intro.
-Elim s0; Intro.
-Split with (cons_Rlist l1 l2); Split with (FF (cons_Rlist l1 l2) f); Apply StepFun_P40 with b lf1 lf2; Assumption.
-Split with l1; Split with lf1; Rewrite b0 in H1; Assumption.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H0 r)).
-Split with l2; Split with lf2; Rewrite <- b0 in H2; Assumption.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Qed.
-
-Lemma StepFun_P42 : (l1,l2:Rlist;f:R->R) (pos_Rl l1 (pred (Rlength l1)))==(pos_Rl l2 O) -> ``(Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)) == (Int_SF (FF l1 f) l1) + (Int_SF (FF l2 f) l2)``.
-Intros l1 l2 f; NewInduction l1 as [|r l1 IHl1]; Intros H; [ Simpl; Ring | NewDestruct l1; [Simpl in H; Simpl; NewDestruct l2; [Simpl; Ring | Simpl; Simpl in H; Rewrite H; Ring] | Simpl; Rewrite Rplus_assoc; Apply Rplus_plus_r; Apply IHl1; Rewrite <- H; Reflexivity]].
-Qed.
-
-Lemma StepFun_P43 : (f:R->R;a,b,c:R;pr1:(IsStepFun f a b);pr2:(IsStepFun f b c);pr3:(IsStepFun f a c)) ``(RiemannInt_SF (mkStepFun pr1))+(RiemannInt_SF (mkStepFun pr2))==(RiemannInt_SF (mkStepFun pr3))``.
-Intros f; Intros; Assert H1 : (SigT ? [l:Rlist](sigTT ? [l0:Rlist](adapted_couple f a b l l0))).
-Apply pr1.
-Assert H2 : (SigT ? [l:Rlist](sigTT ? [l0:Rlist](adapted_couple f b c l l0))).
-Apply pr2.
-Assert H3 : (SigT ? [l:Rlist](sigTT ? [l0:Rlist](adapted_couple f a c l l0))).
-Apply pr3.
-Elim H1; Clear H1; Intros l1 [lf1 H1]; Elim H2; Clear H2; Intros l2 [lf2 H2]; Elim H3; Clear H3; Intros l3 [lf3 H3].
-Replace (RiemannInt_SF (mkStepFun pr1)) with (Cases (total_order_Rle a b) of (leftT _) => (Int_SF lf1 l1) | (rightT _) => ``-(Int_SF lf1 l1)`` end).
-Replace (RiemannInt_SF (mkStepFun pr2)) with (Cases (total_order_Rle b c) of (leftT _) => (Int_SF lf2 l2) | (rightT _) => ``-(Int_SF lf2 l2)`` end).
-Replace (RiemannInt_SF (mkStepFun pr3)) with (Cases (total_order_Rle a c) of (leftT _) => (Int_SF lf3 l3) | (rightT _) => ``-(Int_SF lf3 l3)`` end).
-Case (total_order_Rle a b); Case (total_order_Rle b c); Case (total_order_Rle a c); Intros.
-Elim r1; Intro.
-Elim r0; Intro.
-Replace (Int_SF lf3 l3) with (Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)).
-Replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-Replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-Symmetry; Apply StepFun_P42.
-Unfold adapted_couple in H1 H2; Decompose [and] H1; Decompose [and] H2; Clear H1 H2; Rewrite H11; Rewrite H5; Unfold Rmax Rmin; Case (total_order_Rle a b); Case (total_order_Rle b c); Intros; Reflexivity Orelse Elim n; Assumption.
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf2; Apply H2; Assumption | Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf1; Apply H1 | Assumption].
-EApply StepFun_P17; [Apply (StepFun_P40 H H0 H1 H2) | Apply H3].
-Replace (Int_SF lf2 l2) with R0.
-Rewrite Rplus_Or; EApply StepFun_P17; [Apply H1 | Rewrite <- H0 in H3; Apply H3].
-Symmetry; EApply StepFun_P8; [Apply H2 | Assumption].
-Replace (Int_SF lf1 l1) with R0.
-Rewrite Rplus_Ol; EApply StepFun_P17; [Apply H2 | Rewrite H in H3; Apply H3].
-Symmetry; EApply StepFun_P8; [Apply H1 | Assumption].
-Elim n; Apply Rle_trans with b; Assumption.
-Apply r_Rplus_plus with (Int_SF lf2 l2); Replace ``(Int_SF lf2 l2)+((Int_SF lf1 l1)+ -(Int_SF lf2 l2))`` with (Int_SF lf1 l1); [Idtac | Ring].
-Assert H : ``c<b``.
-Auto with real.
-Elim r; Intro.
-Rewrite Rplus_sym; Replace (Int_SF lf1 l1) with (Int_SF (FF (cons_Rlist l3 l2) f) (cons_Rlist l3 l2)).
-Replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
-Replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-Apply StepFun_P42.
-Unfold adapted_couple in H2 H3; Decompose [and] H2; Decompose [and] H3; Clear H3 H2; Rewrite H10; Rewrite H6; Unfold Rmax Rmin; Case (total_order_Rle a c); Case (total_order_Rle b c); Intros; [Elim n; Assumption | Reflexivity | Elim n0; Assumption | Elim n1; Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf2; Apply H2 | Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf3; Apply H3 | Assumption].
-EApply StepFun_P17; [Apply (StepFun_P40 H0 H H3 (StepFun_P2 H2)) | Apply H1].
-Replace (Int_SF lf3 l3) with R0.
-Rewrite Rplus_Or; EApply StepFun_P17; [Apply H1 | Apply StepFun_P2; Rewrite <- H0 in H2; Apply H2].
-Symmetry; EApply StepFun_P8; [Apply H3 | Assumption].
-Replace (Int_SF lf2 l2) with ``(Int_SF lf3 l3)+(Int_SF lf1 l1)``.
-Ring.
-Elim r; Intro.
-Replace (Int_SF lf2 l2) with (Int_SF (FF (cons_Rlist l3 l1) f) (cons_Rlist l3 l1)).
-Replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
-Replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-Symmetry; Apply StepFun_P42.
-Unfold adapted_couple in H1 H3; Decompose [and] H1; Decompose [and] H3; Clear H3 H1; Rewrite H9; Rewrite H5; Unfold Rmax Rmin; Case (total_order_Rle a c); Case (total_order_Rle a b); Intros; [Elim n; Assumption | Elim n1; Assumption | Reflexivity | Elim n1; Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf1; Apply H1 | Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf3; Apply H3 | Assumption].
-EApply StepFun_P17.
-Assert H0 : ``c<a``.
-Auto with real.
-Apply (StepFun_P40 H0 H (StepFun_P2 H3) H1).
-Apply StepFun_P2; Apply H2.
-Replace (Int_SF lf1 l1) with R0.
-Rewrite Rplus_Or; EApply StepFun_P17; [Apply H3 | Rewrite <- H in H2; Apply H2].
-Symmetry; EApply StepFun_P8; [Apply H1 | Assumption].
-Assert H : ``b<a``.
-Auto with real.
-Replace (Int_SF lf2 l2) with ``(Int_SF lf3 l3)+(Int_SF lf1 l1)``.
-Ring.
-Rewrite Rplus_sym; Elim r; Intro.
-Replace (Int_SF lf2 l2) with (Int_SF (FF (cons_Rlist l1 l3) f) (cons_Rlist l1 l3)).
-Replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
-Replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-Symmetry; Apply StepFun_P42.
-Unfold adapted_couple in H1 H3; Decompose [and] H1; Decompose [and] H3; Clear H3 H1; Rewrite H11; Rewrite H5; Unfold Rmax Rmin; Case (total_order_Rle a c); Case (total_order_Rle a b); Intros; [Elim n; Assumption | Reflexivity | Elim n0; Assumption | Elim n1; Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf1; Apply H1 | Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf3; Apply H3 | Assumption].
-EApply StepFun_P17.
-Apply (StepFun_P40 H H0 (StepFun_P2 H1) H3).
-Apply H2.
-Replace (Int_SF lf3 l3) with R0.
-Rewrite Rplus_Or; EApply StepFun_P17; [Apply H1 | Rewrite <- H0 in H2; Apply StepFun_P2; Apply H2].
-Symmetry; EApply StepFun_P8; [Apply H3 | Assumption].
-Assert H : ``c<a``.
-Auto with real.
-Replace (Int_SF lf1 l1) with ``(Int_SF lf2 l2)+(Int_SF lf3 l3)``.
-Ring.
-Elim r; Intro.
-Replace (Int_SF lf1 l1) with (Int_SF (FF (cons_Rlist l2 l3) f) (cons_Rlist l2 l3)).
-Replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
-Replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-Symmetry; Apply StepFun_P42.
-Unfold adapted_couple in H2 H3; Decompose [and] H2; Decompose [and] H3; Clear H3 H2; Rewrite H11; Rewrite H5; Unfold Rmax Rmin; Case (total_order_Rle a c); Case (total_order_Rle b c); Intros; [Elim n; Assumption | Elim n1; Assumption | Reflexivity | Elim n1; Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf2; Apply H2 | Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf3; Apply H3 | Assumption].
-EApply StepFun_P17.
-Apply (StepFun_P40 H0 H H2 (StepFun_P2 H3)).
-Apply StepFun_P2; Apply H1.
-Replace (Int_SF lf2 l2) with R0.
-Rewrite Rplus_Ol; EApply StepFun_P17; [Apply H3 | Rewrite H0 in H1; Apply H1].
-Symmetry; EApply StepFun_P8; [Apply H2 | Assumption].
-Elim n; Apply Rle_trans with a; Try Assumption.
-Auto with real.
-Assert H : ``c<b``.
-Auto with real.
-Assert H0 : ``b<a``.
-Auto with real.
-Replace (Int_SF lf3 l3) with ``(Int_SF lf2 l2)+(Int_SF lf1 l1)``.
-Ring.
-Replace (Int_SF lf3 l3) with (Int_SF (FF (cons_Rlist l2 l1) f) (cons_Rlist l2 l1)).
-Replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-Replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-Symmetry; Apply StepFun_P42.
-Unfold adapted_couple in H2 H1; Decompose [and] H2; Decompose [and] H1; Clear H1 H2; Rewrite H11; Rewrite H5; Unfold Rmax Rmin; Case (total_order_Rle a b); Case (total_order_Rle b c); Intros; [Elim n1; Assumption | Elim n1; Assumption | Elim n0; Assumption | Reflexivity].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf2; Apply H2 | Assumption].
-EApply StepFun_P17; [Apply StepFun_P21; Unfold is_subdivision; Split with lf1; Apply H1 | Assumption].
-EApply StepFun_P17.
-Apply (StepFun_P40 H H0 (StepFun_P2 H2) (StepFun_P2 H1)).
-Apply StepFun_P2; Apply H3.
-Unfold RiemannInt_SF; Case (total_order_Rle a c); Intro.
-EApply StepFun_P17.
-Apply H3.
-Change (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun 1!a 2!c 3!f pr3)) (subdivision_val (mkStepFun 1!a 2!c 3!f pr3))); Apply StepFun_P1.
-Apply eq_Ropp; EApply StepFun_P17.
-Apply H3.
-Change (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun 1!a 2!c 3!f pr3)) (subdivision_val (mkStepFun 1!a 2!c 3!f pr3))); Apply StepFun_P1.
-Unfold RiemannInt_SF; Case (total_order_Rle b c); Intro.
-EApply StepFun_P17.
-Apply H2.
-Change (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun 1!b 2!c 3!f pr2)) (subdivision_val (mkStepFun 1!b 2!c 3!f pr2))); Apply StepFun_P1.
-Apply eq_Ropp; EApply StepFun_P17.
-Apply H2.
-Change (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun 1!b 2!c 3!f pr2)) (subdivision_val (mkStepFun 1!b 2!c 3!f pr2))); Apply StepFun_P1.
-Unfold RiemannInt_SF; Case (total_order_Rle a b); Intro.
-EApply StepFun_P17.
-Apply H1.
-Change (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun 1!a 2!b 3!f pr1)) (subdivision_val (mkStepFun 1!a 2!b 3!f pr1))); Apply StepFun_P1.
-Apply eq_Ropp; EApply StepFun_P17.
-Apply H1.
-Change (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun 1!a 2!b 3!f pr1)) (subdivision_val (mkStepFun 1!a 2!b 3!f pr1))); Apply StepFun_P1.
-Qed.
-
-Lemma StepFun_P44 : (f:R->R;a,b,c:R) (IsStepFun f a b) -> ``a<=c<=b`` -> (IsStepFun f a c).
-Intros f; Intros; Assert H0 : ``a<=b``.
-Elim H; Intros; Apply Rle_trans with c; Assumption.
-Elim H; Clear H; Intros; Unfold IsStepFun in X; Unfold is_subdivision in X; Elim X; Clear X; Intros l1 [lf1 H2]; Cut (l1,lf1:Rlist;a,b,c:R;f:R->R) (adapted_couple f a b l1 lf1) -> ``a<=c<=b`` -> (SigT ? [l:Rlist](sigTT ? [l0:Rlist](adapted_couple f a c l l0))).
-Intros; Unfold IsStepFun; Unfold is_subdivision; EApply X.
-Apply H2.
-Split; Assumption.
-Clear f a b c H0 H H1 H2 l1 lf1; Induction l1.
-Intros; Unfold adapted_couple in H; Decompose [and] H; Clear H; Simpl in H4; Discriminate.
-Induction r0.
-Intros; Assert H1 : ``a==b``.
-Unfold adapted_couple in H; Decompose [and] H; Clear H; Simpl in H3; Simpl in H2; Assert H7 : ``a<=b``.
-Elim H0; Intros; Apply Rle_trans with c; Assumption.
-Replace a with (Rmin a b).
-Pattern 2 b; Replace b with (Rmax a b).
-Rewrite <- H2; Rewrite H3; Reflexivity.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Split with (cons r nil); Split with lf1; Assert H2 : ``c==b``.
-Rewrite H1 in H0; Elim H0; Intros; Apply Rle_antisym; Assumption.
-Rewrite H2; Assumption.
-Intros; Clear X; Induction lf1.
-Unfold adapted_couple in H; Decompose [and] H; Clear H; Simpl in H4; Discriminate.
-Clear Hreclf1; Assert H1 : (sumboolT ``c<=r1`` ``r1<c``).
-Case (total_order_Rle c r1); Intro; [Left; Assumption | Right; Auto with real].
-Elim H1; Intro.
-Split with (cons r (cons c nil)); Split with (cons r3 nil); Unfold adapted_couple in H; Decompose [and] H; Clear H; Assert H6 : ``r==a``.
-Simpl in H4; Rewrite H4; Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Elim H0; Intros; Apply Rle_trans with c; Assumption].
-Elim H0; Clear H0; Intros; Unfold adapted_couple; Repeat Split.
-Rewrite H6; Unfold ordered_Rlist; Intros; Simpl in H8; Inversion H8; [Simpl; Assumption | Elim (le_Sn_O ? H10)].
-Simpl; Unfold Rmin; Case (total_order_Rle a c); Intro; [Assumption | Elim n; Assumption].
-Simpl; Unfold Rmax; Case (total_order_Rle a c); Intro; [Reflexivity | Elim n; Assumption].
-Unfold constant_D_eq open_interval; Intros; Simpl in H8; Inversion H8.
-Simpl; Assert H10 := (H7 O); Assert H12 : (lt (0) (pred (Rlength (cons r (cons r1 r2))))).
-Simpl; Apply lt_O_Sn.
-Apply (H10 H12); Unfold open_interval; Simpl; Rewrite H11 in H9; Simpl in H9; Elim H9; Clear H9; Intros; Split; Try Assumption.
-Apply Rlt_le_trans with c; Assumption.
-Elim (le_Sn_O ? H11).
-Cut (adapted_couple f r1 b (cons r1 r2) lf1).
-Cut ``r1<=c<=b``.
-Intros.
-Elim (X0 ? ? ? ? ? H3 H2); Intros l1' [lf1' H4]; Split with (cons r l1'); Split with (cons r3 lf1'); Unfold adapted_couple in H H4; Decompose [and] H; Decompose [and] H4; Clear H H4 X0; Assert H14 : ``a<=b``.
-Elim H0; Intros; Apply Rle_trans with c; Assumption.
-Assert H16 : ``r==a``.
-Simpl in H7; Rewrite H7; Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Induction l1'.
-Simpl in H13; Discriminate.
-Clear Hrecl1'; Unfold adapted_couple; Repeat Split.
-Unfold ordered_Rlist; Intros; Simpl in H; Induction i.
-Simpl; Replace r4 with r1.
-Apply (H5 O).
-Simpl; Apply lt_O_Sn.
-Simpl in H12; Rewrite H12; Unfold Rmin; Case (total_order_Rle r1 c); Intro; [Reflexivity | Elim n; Left; Assumption].
-Apply (H9 i); Simpl; Apply lt_S_n; Assumption.
-Simpl; Unfold Rmin; Case (total_order_Rle a c); Intro; [Assumption | Elim n; Elim H0; Intros; Assumption].
-Replace (Rmax a c) with (Rmax r1 c).
-Rewrite <- H11; Reflexivity.
-Unfold Rmax; Case (total_order_Rle r1 c); Case (total_order_Rle a c); Intros; [Reflexivity | Elim n; Elim H0; Intros; Assumption | Elim n; Left; Assumption | Elim n0; Left; Assumption].
-Simpl; Simpl in H13; Rewrite H13; Reflexivity.
-Intros; Simpl in H; Unfold constant_D_eq open_interval; Intros; Induction i.
-Simpl; Assert H17 := (H10 O); Assert H18 : (lt (0) (pred (Rlength (cons r (cons r1 r2))))).
-Simpl; Apply lt_O_Sn.
-Apply (H17 H18); Unfold open_interval; Simpl; Simpl in H4; Elim H4; Clear H4; Intros; Split; Try Assumption; Replace r1 with r4.
-Assumption.
-Simpl in H12; Rewrite H12; Unfold Rmin; Case (total_order_Rle r1 c); Intro; [Reflexivity | Elim n; Left; Assumption].
-Clear Hreci; Simpl; Apply H15.
-Simpl; Apply lt_S_n; Assumption.
-Unfold open_interval; Apply H4.
-Split.
-Left; Assumption.
-Elim H0; Intros; Assumption.
-EApply StepFun_P7; [Elim H0; Intros; Apply Rle_trans with c; [Apply H2 | Apply H3] | Apply H].
-Qed.
-
-Lemma StepFun_P45 : (f:R->R;a,b,c:R) (IsStepFun f a b) -> ``a<=c<=b`` -> (IsStepFun f c b).
-Intros f; Intros; Assert H0 : ``a<=b``.
-Elim H; Intros; Apply Rle_trans with c; Assumption.
-Elim H; Clear H; Intros; Unfold IsStepFun in X; Unfold is_subdivision in X; Elim X; Clear X; Intros l1 [lf1 H2]; Cut (l1,lf1:Rlist;a,b,c:R;f:R->R) (adapted_couple f a b l1 lf1) -> ``a<=c<=b`` -> (SigT ? [l:Rlist](sigTT ? [l0:Rlist](adapted_couple f c b l l0))).
-Intros; Unfold IsStepFun; Unfold is_subdivision; EApply X; [Apply H2 | Split; Assumption].
-Clear f a b c H0 H H1 H2 l1 lf1; Induction l1.
-Intros; Unfold adapted_couple in H; Decompose [and] H; Clear H; Simpl in H4; Discriminate.
-Induction r0.
-Intros; Assert H1 : ``a==b``.
-Unfold adapted_couple in H; Decompose [and] H; Clear H; Simpl in H3; Simpl in H2; Assert H7 : ``a<=b``.
-Elim H0; Intros; Apply Rle_trans with c; Assumption.
-Replace a with (Rmin a b).
-Pattern 2 b; Replace b with (Rmax a b).
-Rewrite <- H2; Rewrite H3; Reflexivity.
-Unfold Rmax; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Unfold Rmin; Case (total_order_Rle a b); Intro; [Reflexivity | Elim n; Assumption].
-Split with (cons r nil); Split with lf1; Assert H2 : ``c==b``.
-Rewrite H1 in H0; Elim H0; Intros; Apply Rle_antisym; Assumption.
-Rewrite <- H2 in H1; Rewrite <- H1; Assumption.
-Intros; Clear X; Induction lf1.
-Unfold adapted_couple in H; Decompose [and] H; Clear H; Simpl in H4; Discriminate.
-Clear Hreclf1; Assert H1 : (sumboolT ``c<=r1`` ``r1<c``).
-Case (total_order_Rle c r1); Intro; [Left; Assumption | Right; Auto with real].
-Elim H1; Intro.
-Split with (cons c (cons r1 r2)); Split with (cons r3 lf1); Unfold adapted_couple in H; Decompose [and] H; Clear H; Unfold adapted_couple; Repeat Split.
-Unfold ordered_Rlist; Intros; Simpl in H; Induction i.
-Simpl; Assumption.
-Clear Hreci; Apply (H2 (S i)); Simpl; Assumption.
-Simpl; Unfold Rmin; Case (total_order_Rle c b); Intro; [Reflexivity | Elim n; Elim H0; Intros; Assumption].
-Replace (Rmax c b) with (Rmax a b).
-Rewrite <- H3; Reflexivity.
-Unfold Rmax; Case (total_order_Rle a b); Case (total_order_Rle c b); Intros; [Reflexivity | Elim n; Elim H0; Intros; Assumption | Elim n; Elim H0; Intros; Apply Rle_trans with c; Assumption | Elim n0; Elim H0; Intros; Apply Rle_trans with c; Assumption].
-Simpl; Simpl in H5; Apply H5.
-Intros; Simpl in H; Induction i.
-Unfold constant_D_eq open_interval; Intros; Simpl; Apply (H7 O).
-Simpl; Apply lt_O_Sn.
-Unfold open_interval; Simpl; Simpl in H6; Elim H6; Clear H6; Intros; Split; Try Assumption; Apply Rle_lt_trans with c; Try Assumption; Replace r with a.
-Elim H0; Intros; Assumption.
-Simpl in H4; Rewrite H4; Unfold Rmin; Case (total_order_Rle a b); Intros; [Reflexivity | Elim n; Elim H0; Intros; Apply Rle_trans with c; Assumption].
-Clear Hreci; Apply (H7 (S i)); Simpl; Assumption.
-Cut (adapted_couple f r1 b (cons r1 r2) lf1).
-Cut ``r1<=c<=b``.
-Intros; Elim (X0 ? ? ? ? ? H3 H2); Intros l1' [lf1' H4]; Split with l1'; Split with lf1'; Assumption.
-Split; [Left; Assumption | Elim H0; Intros; Assumption].
-EApply StepFun_P7; [Elim H0; Intros; Apply Rle_trans with c; [Apply H2 | Apply H3] | Apply H].
-Qed.
-
-Lemma StepFun_P46 : (f:R->R;a,b,c:R) (IsStepFun f a b) -> (IsStepFun f b c) -> (IsStepFun f a c).
-Intros f; Intros; Case (total_order_Rle a b); Case (total_order_Rle b c); Intros.
-Apply StepFun_P41 with b; Assumption.
-Case (total_order_Rle a c); Intro.
-Apply StepFun_P44 with b; Try Assumption.
-Split; [Assumption | Auto with real].
-Apply StepFun_P6; Apply StepFun_P44 with b.
-Apply StepFun_P6; Assumption.
-Split; Auto with real.
-Case (total_order_Rle a c); Intro.
-Apply StepFun_P45 with b; Try Assumption.
-Split; Auto with real.
-Apply StepFun_P6; Apply StepFun_P45 with b.
-Apply StepFun_P6; Assumption.
-Split; [Assumption | Auto with real].
-Apply StepFun_P6; Apply StepFun_P41 with b; Auto with real Orelse Apply StepFun_P6; Assumption.
-Qed.
diff --git a/theories7/Reals/Rlimit.v b/theories7/Reals/Rlimit.v
deleted file mode 100644
index 3308b2e3..00000000
--- a/theories7/Reals/Rlimit.v
+++ /dev/null
@@ -1,539 +0,0 @@
-(************************************************************************)
-(*  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: Rlimit.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-(*********************************************************)
-(*           Definition of the limit                     *)
-(*                                                       *)
-(*********************************************************)
-
-Require Rbase.
-Require Rfunctions.
-Require Classical_Prop.
-Require Fourier.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(*******************************)
-(*      Calculus               *)
-(*******************************)
-(*********)
-Lemma eps2_Rgt_R0:(eps:R)(Rgt eps R0)->
-      (Rgt (Rmult eps (Rinv (Rplus R1 R1))) R0).
-Intros;Fourier.
-Qed.
-
-(*********)
-Lemma eps2:(eps:R)(Rplus (Rmult eps (Rinv (Rplus R1 R1)))
-                        (Rmult eps (Rinv (Rplus R1 R1))))==eps.
-Intro esp.
-Assert H := (double_var esp).
-Unfold Rdiv in H.
-Symmetry; Exact H.
-Qed.
-
-(*********)
-Lemma eps4:(eps:R)
-  (Rplus (Rmult eps (Rinv (Rplus (Rplus R1 R1) (Rplus R1 R1) )))
-        (Rmult eps (Rinv (Rplus (Rplus R1 R1) (Rplus R1 R1) ))))==
-                  (Rmult eps (Rinv (Rplus R1 R1))).
-Intro eps.
-Replace ``2+2`` with ``2*2``.
-Pattern 3 eps; Rewrite double_var.
-Rewrite (Rmult_Rplus_distrl ``eps/2`` ``eps/2`` ``/2``).
-Unfold Rdiv.
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_Rmult.
-Reflexivity.
-DiscrR.
-DiscrR.
-Ring.
-Qed.
-
-(*********)
-Lemma Rlt_eps2_eps:(eps:R)(Rgt eps R0)->
-        (Rlt (Rmult eps (Rinv (Rplus R1 R1))) eps).
-Intros.
-Pattern 2 eps; Rewrite <- Rmult_1r.
-Repeat Rewrite (Rmult_sym eps).
-Apply Rlt_monotony_r.
-Exact H.
-Apply Rlt_monotony_contra with ``2``.
-Fourier.
-Rewrite Rmult_1r; Rewrite <- Rinv_r_sym.
-Fourier.
-DiscrR.
-Qed.
-
-(*********)
-Lemma Rlt_eps4_eps:(eps:R)(Rgt eps R0)->
-        (Rlt (Rmult eps (Rinv (Rplus (Rplus R1 R1) (Rplus R1 R1)))) eps).
-Intros.
-Replace ``2+2`` with ``4``.
-Pattern 2 eps; Rewrite <- Rmult_1r.
-Repeat Rewrite (Rmult_sym eps).
-Apply Rlt_monotony_r.
-Exact H.
-Apply Rlt_monotony_contra with ``4``.
-Replace ``4`` with ``2*2``.
-Apply Rmult_lt_pos; Fourier.
-Ring.
-Rewrite Rmult_1r; Rewrite <- Rinv_r_sym.
-Fourier.
-DiscrR.
-Ring.
-Qed. 
-
-(*********)
-Lemma prop_eps:(r:R)((eps:R)(Rgt eps R0)->(Rlt r eps))->(Rle r R0).
-Intros;Elim (total_order r R0); Intro.
-Apply Rlt_le; Assumption.
-Elim H0; Intro.
-Apply eq_Rle; Assumption.
-Clear H0;Generalize (H r H1); Intro;Generalize (Rlt_antirefl r);
- Intro;ElimType False; Auto.
-Qed.
-
-(*********)
-Definition mul_factor := [l,l':R](Rinv (Rplus R1 (Rplus (Rabsolu l) 
-                                                        (Rabsolu l')))).
-
-(*********)
-Lemma mul_factor_wd : (l,l':R)
-  ~(Rplus R1 (Rplus (Rabsolu l) (Rabsolu l')))==R0.
-Intros;Rewrite (Rplus_sym R1 (Rplus (Rabsolu l) (Rabsolu l')));
- Apply tech_Rplus.
-Cut (Rle (Rabsolu (Rplus l l')) (Rplus (Rabsolu l) (Rabsolu l'))).
-Cut (Rle R0 (Rabsolu (Rplus l l'))).
-Exact (Rle_trans ? ? ?).
-Exact (Rabsolu_pos (Rplus l l')).
-Exact (Rabsolu_triang ? ?).
-Exact Rlt_R0_R1.
-Qed.
-
-(*********)
-Lemma mul_factor_gt:(eps:R)(l,l':R)(Rgt eps R0)->
-      (Rgt (Rmult eps (mul_factor l l')) R0).
-Intros;Unfold Rgt;Rewrite <- (Rmult_Or eps);Apply Rlt_monotony.
-Assumption.
-Unfold mul_factor;Apply Rlt_Rinv;
- Cut (Rle R1 (Rplus R1 (Rplus (Rabsolu l) (Rabsolu l')))).
-Cut (Rlt R0 R1).
-Exact (Rlt_le_trans ? ? ?).
-Exact Rlt_R0_R1.
-Replace (Rle R1 (Rplus R1 (Rplus (Rabsolu l) (Rabsolu l'))))
- with (Rle (Rplus R1 R0) (Rplus R1 (Rplus (Rabsolu l) (Rabsolu l')))).
-Apply Rle_compatibility.
-Cut (Rle (Rabsolu (Rplus l l')) (Rplus (Rabsolu l) (Rabsolu l'))).
-Cut (Rle R0 (Rabsolu (Rplus l l'))).
-Exact (Rle_trans ? ? ?).
-Exact (Rabsolu_pos ?).
-Exact (Rabsolu_triang ? ?).
-Rewrite (proj1 ? ? (Rplus_ne R1));Trivial.
-Qed.
-
-(*********)
-Lemma mul_factor_gt_f:(eps:R)(l,l':R)(Rgt eps R0)->
-      (Rgt (Rmin R1 (Rmult eps (mul_factor l l'))) R0).
-Intros;Apply Rmin_Rgt_r;Split.
-Exact Rlt_R0_R1.
-Exact (mul_factor_gt eps l l' H).
-Qed.
-
-
-(*******************************)
-(*      Metric space           *)
-(*******************************)
-
-(*********)
-Record Metric_Space:Type:= {
-   Base:Type;
-   dist:Base->Base->R;
-   dist_pos:(x,y:Base)(Rge (dist x y) R0);
-   dist_sym:(x,y:Base)(dist x y)==(dist y x);
-   dist_refl:(x,y:Base)((dist x y)==R0<->x==y);
-   dist_tri:(x,y,z:Base)(Rle (dist x y) 
-              (Rplus (dist x z) (dist z y))) }.
-
-(*******************************)
-(*     Limit in Metric space   *)
-(*******************************)
-
-(*********)
-Definition limit_in:=
-   [X:Metric_Space; X':Metric_Space; f:(Base X)->(Base X'); 
-    D:(Base X)->Prop; x0:(Base X); l:(Base X')]
-   (eps:R)(Rgt eps R0)->
-   (EXT alp:R | (Rgt alp R0)/\(x:(Base X))(D x)/\
-                (Rlt (dist X x x0) alp)->
-                (Rlt (dist X' (f x) l) eps)). 
-
-(*******************************)
-(*    R is a metric space      *)
-(*******************************)
-
-(*********)
-Definition R_met:Metric_Space:=(Build_Metric_Space R R_dist 
-  R_dist_pos R_dist_sym R_dist_refl R_dist_tri).
-
-(*******************************)
-(*         Limit 1 arg         *)
-(*******************************)
-(*********)
-Definition Dgf:=[Df,Dg:R->Prop][f:R->R][x:R](Df x)/\(Dg (f x)).
-
-(*********)
-Definition limit1_in:(R->R)->(R->Prop)->R->R->Prop:=
-  [f:R->R; D:R->Prop; l:R; x0:R](limit_in R_met R_met f D x0 l).
-
-(*********)
-Lemma tech_limit:(f:R->R)(D:R->Prop)(l:R)(x0:R)(D x0)->
-   (limit1_in f D l x0)->l==(f x0).
-Intros f D l x0 H H0.
-Case (Rabsolu_pos (Rminus (f x0) l)); Intros H1.
-Absurd (Rlt (dist R_met (f x0) l) (dist R_met (f x0) l)).
-Apply Rlt_antirefl.
-Case (H0 (dist R_met (f x0) l)); Auto.
-Intros alpha1 (H2, H3); Apply H3; Auto; Split; Auto.
-Case (dist_refl R_met x0 x0); Intros Hr1 Hr2; Rewrite Hr2; Auto.
-Case (dist_refl R_met (f x0) l); Intros Hr1 Hr2; Apply sym_eqT; Auto.
-Qed.
-
-(*********)
-Lemma tech_limit_contr:(f:R->R)(D:R->Prop)(l:R)(x0:R)(D x0)->~l==(f x0)
-   ->~(limit1_in f D l x0).
-Intros;Generalize (tech_limit f D l x0);Tauto.
-Qed.
-
-(*********)
-Lemma lim_x:(D:R->Prop)(x0:R)(limit1_in [x:R]x D x0 x0).
-Unfold limit1_in; Unfold limit_in; Simpl; Intros;Split with eps;
- Split; Auto;Intros;Elim H0; Intros; Auto.
-Qed.
-
-(*********)
-Lemma limit_plus:(f,g:R->R)(D:R->Prop)(l,l':R)(x0:R)
-   (limit1_in f D l x0)->(limit1_in g D l' x0)->
-   (limit1_in [x:R](Rplus (f x) (g x)) D (Rplus l l') x0).
-Intros;Unfold limit1_in; Unfold limit_in; Simpl; Intros;
- Elim (H (Rmult eps (Rinv (Rplus R1 R1))) (eps2_Rgt_R0 eps H1));
-  Elim (H0 (Rmult eps (Rinv (Rplus R1 R1))) (eps2_Rgt_R0 eps H1));
- Simpl;Clear H H0; Intros; Elim H; Elim H0; Clear H H0; Intros;
-  Split with (Rmin x1 x); Split.
-Exact (Rmin_Rgt_r x1 x R0 (conj ? ? H H2)).
-Intros;Elim H4; Clear H4; Intros;
- Cut (Rlt (Rplus (R_dist (f x2) l) (R_dist (g x2) l')) eps).
- Cut (Rle (R_dist (Rplus (f x2) (g x2)) (Rplus l l'))
-      (Rplus (R_dist (f x2) l) (R_dist (g x2) l'))).
-Exact (Rle_lt_trans ? ? ?).
-Exact (R_dist_plus ? ? ? ?).
-Elim (Rmin_Rgt_l x1 x (R_dist x2 x0) H5); Clear H5; Intros.
-Generalize (H3 x2 (conj (D x2) (Rlt (R_dist x2 x0) x) H4 H6));
- Generalize (H0 x2 (conj (D x2) (Rlt (R_dist x2 x0) x1) H4 H5));
- Intros;
- Replace eps
- with (Rplus (Rmult eps (Rinv (Rplus R1 R1)))
-        (Rmult eps (Rinv (Rplus R1 R1)))).
-Exact (Rplus_lt ? ? ? ? H7 H8).
-Exact (eps2 eps).
-Qed.
-
-(*********)
-Lemma limit_Ropp:(f:R->R)(D:R->Prop)(l:R)(x0:R)
-   (limit1_in f D l x0)->(limit1_in [x:R](Ropp (f x)) D (Ropp l) x0).
-Unfold limit1_in;Unfold limit_in;Simpl;Intros;Elim (H eps H0);Clear H;
- Intros;Elim H;Clear H;Intros;Split with x;Split;Auto;Intros;
- Generalize (H1 x1 H2);Clear H1;Intro;Unfold R_dist;Unfold Rminus;
- Rewrite (Ropp_Ropp l);Rewrite (Rplus_sym (Ropp (f x1)) l);
- Fold (Rminus l (f x1));Fold (R_dist l (f x1));Rewrite R_dist_sym;
- Assumption.
-Qed.
-
-(*********)
-Lemma limit_minus:(f,g:R->R)(D:R->Prop)(l,l':R)(x0:R)
-   (limit1_in f D l x0)->(limit1_in g D l' x0)->
-   (limit1_in [x:R](Rminus (f x) (g x)) D (Rminus l l') x0).
-Intros;Unfold Rminus;Generalize (limit_Ropp g D l' x0 H0);Intro;
- Exact (limit_plus f [x:R](Ropp (g x)) D l (Ropp l') x0 H H1).
-Qed.
-
-(*********)
-Lemma limit_free:(f:R->R)(D:R->Prop)(x:R)(x0:R)
-   (limit1_in [h:R](f x) D (f x) x0).
-Unfold limit1_in;Unfold limit_in;Simpl;Intros;Split with eps;Split;
- Auto;Intros;Elim (R_dist_refl (f x) (f x));Intros a b;
- Rewrite (b (refl_eqT R (f x)));Unfold Rgt in H;Assumption.
-Qed.
-
-(*********)
-Lemma limit_mul:(f,g:R->R)(D:R->Prop)(l,l':R)(x0:R)
-   (limit1_in f D l x0)->(limit1_in g D l' x0)->
-   (limit1_in [x:R](Rmult (f x) (g x)) D (Rmult l l') x0).
-Intros;Unfold limit1_in; Unfold limit_in; Simpl; Intros; 
- Elim (H (Rmin R1 (Rmult eps (mul_factor l l'))) 
-                   (mul_factor_gt_f eps l l' H1));
- Elim (H0 (Rmult eps (mul_factor l l')) (mul_factor_gt eps l l' H1));
- Clear H H0; Simpl; Intros; Elim H; Elim H0; Clear H H0; Intros;
- Split with (Rmin x1 x); Split.
-Exact (Rmin_Rgt_r x1 x R0 (conj ? ? H H2)).
-Intros; Elim H4; Clear H4; Intros;Unfold R_dist;
- Replace (Rminus (Rmult (f x2) (g x2)) (Rmult l l')) with 
-     (Rplus (Rmult (f x2) (Rminus (g x2) l')) (Rmult l' (Rminus (f x2) l))).
-Cut (Rlt (Rplus (Rabsolu (Rmult (f x2) (Rminus (g x2) l'))) (Rabsolu (Rmult l' 
- (Rminus (f x2) l)))) eps). 
-Cut (Rle (Rabsolu (Rplus (Rmult (f x2) (Rminus (g x2) l')) (Rmult l' (Rminus 
-  (f x2) l)))) (Rplus (Rabsolu (Rmult (f x2) (Rminus (g x2) l'))) (Rabsolu 
-        (Rmult l' (Rminus (f x2) l))))).
-Exact (Rle_lt_trans ? ? ?).
-Exact (Rabsolu_triang ? ?).
-Rewrite (Rabsolu_mult (f x2) (Rminus (g x2) l'));
- Rewrite (Rabsolu_mult l' (Rminus (f x2) l));
- Cut (Rle (Rplus (Rmult (Rplus R1 (Rabsolu l)) (Rmult eps (mul_factor l l'))) 
-   (Rmult (Rabsolu l') (Rmult eps (mul_factor l l')))) eps).
-Cut (Rlt (Rplus (Rmult (Rabsolu (f x2)) (Rabsolu (Rminus (g x2) l'))) (Rmult 
-  (Rabsolu l') (Rabsolu (Rminus (f x2) l)))) (Rplus (Rmult (Rplus R1 (Rabsolu 
-     l)) (Rmult eps (mul_factor l l'))) (Rmult (Rabsolu l') (Rmult eps 
-      (mul_factor l l'))))).
-Exact (Rlt_le_trans ? ? ?).
-Elim (Rmin_Rgt_l x1 x (R_dist x2 x0) H5); Clear H5; Intros;
- Generalize (H0 x2 (conj (D x2) (Rlt (R_dist x2 x0) x1) H4 H5));Intro;
- Generalize (Rmin_Rgt_l ? ? ? H7);Intro;Elim H8;Intros;Clear H0 H8;
- Apply Rplus_lt_le_lt.
-Apply Rmult_lt_0.
-Apply Rle_sym1.
-Exact (Rabsolu_pos (Rminus (g x2) l')).
-Rewrite (Rplus_sym R1 (Rabsolu l));Unfold Rgt;Apply Rlt_r_plus_R1;
- Exact (Rabsolu_pos l).
-Unfold R_dist in H9;
- Apply (Rlt_anti_compatibility (Ropp (Rabsolu l)) (Rabsolu (f x2)) 
-     (Rplus R1 (Rabsolu l))).
-Rewrite <- (Rplus_assoc (Ropp (Rabsolu l)) R1 (Rabsolu l));
- Rewrite (Rplus_sym (Ropp (Rabsolu l)) R1);
- Rewrite (Rplus_assoc R1 (Ropp (Rabsolu l)) (Rabsolu l));
- Rewrite (Rplus_Ropp_l (Rabsolu l));
- Rewrite (proj1 ? ? (Rplus_ne R1));
- Rewrite (Rplus_sym (Ropp (Rabsolu l)) (Rabsolu (f x2)));
- Generalize H9;
-Cut (Rle (Rminus (Rabsolu (f x2)) (Rabsolu l)) (Rabsolu (Rminus (f x2) l))).
-Exact (Rle_lt_trans ? ? ?).
-Exact (Rabsolu_triang_inv ? ?).
-Generalize (H3 x2 (conj (D x2) (Rlt (R_dist x2 x0) x) H4 H6));Trivial.
-Apply Rle_monotony.
-Exact (Rabsolu_pos l').
-Unfold Rle;Left;Assumption.
-Rewrite (Rmult_sym (Rplus R1 (Rabsolu l)) (Rmult eps (mul_factor l l')));
- Rewrite (Rmult_sym (Rabsolu l') (Rmult eps (mul_factor l l')));
- Rewrite <- (Rmult_Rplus_distr
-           (Rmult eps (mul_factor l l'))
-           (Rplus R1 (Rabsolu l))
-           (Rabsolu l'));
- Rewrite (Rmult_assoc eps (mul_factor l l') (Rplus (Rplus R1 (Rabsolu l)) 
-      (Rabsolu l')));
- Rewrite (Rplus_assoc R1 (Rabsolu l) (Rabsolu l'));Unfold mul_factor;
- Rewrite (Rinv_l (Rplus R1 (Rplus (Rabsolu l) (Rabsolu l'))) 
-  (mul_factor_wd l l'));
- Rewrite (proj1 ? ? (Rmult_ne eps));Apply eq_Rle;Trivial.
-Ring.
-Qed.
-
-(*********)
-Definition adhDa:(R->Prop)->R->Prop:=[D:R->Prop][a:R]
-  (alp:R)(Rgt alp R0)->(EXT x:R | (D x)/\(Rlt (R_dist x a) alp)).
-
-(*********)
-Lemma single_limit:(f:R->R)(D:R->Prop)(l:R)(l':R)(x0:R)
-  (adhDa D x0)->(limit1_in f D l x0)->(limit1_in f D l' x0)->l==l'.
-Unfold limit1_in; Unfold limit_in; Intros.
-Cut (eps:R)(Rgt eps R0)->(Rlt (dist R_met l l') 
-                              (Rmult (Rplus R1 R1) eps)).
-Clear H0 H1;Unfold dist; Unfold R_met; Unfold R_dist; 
- Unfold Rabsolu;Case (case_Rabsolu (Rminus l l')); Intros.
-Cut (eps:R)(Rgt eps R0)->(Rlt (Ropp (Rminus l l')) eps).
-Intro;Generalize (prop_eps (Ropp (Rminus l l')) H1);Intro;
- Generalize (Rlt_RoppO (Rminus l l') r); Intro;Unfold Rgt in H3;
- Generalize (Rle_not (Ropp (Rminus l l')) R0 H3); Intro;
- ElimType False; Auto.
-Intros;Cut (Rgt (Rmult eps (Rinv (Rplus R1 R1))) R0).
-Intro;Generalize (H0 (Rmult eps (Rinv (Rplus R1 R1))) H2);
- Rewrite (Rmult_sym eps (Rinv (Rplus R1 R1)));
- Rewrite <- (Rmult_assoc (Rplus R1 R1) (Rinv (Rplus R1 R1)) eps);
- Rewrite (Rinv_r (Rplus R1 R1)).
-Elim (Rmult_ne eps);Intros a b;Rewrite b;Clear a b;Trivial.
-Apply (imp_not_Req (Rplus R1 R1) R0);Right;Generalize Rlt_R0_R1;Intro;
- Unfold Rgt;Generalize (Rlt_compatibility R1 R0 R1 H3);Intro;
- Elim (Rplus_ne R1);Intros a b;Rewrite a in H4;Clear a b; 
- Apply (Rlt_trans R0 R1 (Rplus R1 R1) H3 H4).
-Unfold Rgt;Unfold Rgt in H1;
- Rewrite (Rmult_sym eps(Rinv (Rplus R1 R1)));
- Rewrite <-(Rmult_Or (Rinv (Rplus R1 R1)));
- Apply (Rlt_monotony (Rinv (Rplus R1 R1)) R0 eps);Auto.
-Apply (Rlt_Rinv (Rplus R1 R1));Cut (Rlt R1 (Rplus R1 R1)).
-Intro;Apply (Rlt_trans R0 R1 (Rplus R1 R1) Rlt_R0_R1 H2).
-Generalize (Rlt_compatibility R1 R0 R1 Rlt_R0_R1);Elim (Rplus_ne R1);
- Intros a b;Rewrite a;Clear a b;Trivial.
-(**)
-Cut (eps:R)(Rgt eps R0)->(Rlt (Rminus l l') eps).
-Intro;Generalize (prop_eps (Rminus l l') H1);Intro;
- Elim (Rle_le_eq (Rminus l l') R0);Intros a b;Clear b;
- Apply (Rminus_eq l l');Apply a;Split.
-Assumption.
-Apply (Rle_sym2 R0 (Rminus l l') r).
-Intros;Cut (Rgt (Rmult eps (Rinv (Rplus R1 R1))) R0).
-Intro;Generalize (H0 (Rmult eps (Rinv (Rplus R1 R1))) H2);
- Rewrite (Rmult_sym eps (Rinv (Rplus R1 R1)));
- Rewrite <- (Rmult_assoc (Rplus R1 R1) (Rinv (Rplus R1 R1)) eps);
- Rewrite (Rinv_r (Rplus R1 R1)).
-Elim (Rmult_ne eps);Intros a b;Rewrite b;Clear a b;Trivial.
-Apply (imp_not_Req (Rplus R1 R1) R0);Right;Generalize Rlt_R0_R1;Intro;
- Unfold Rgt;Generalize (Rlt_compatibility R1 R0 R1 H3);Intro;
- Elim (Rplus_ne R1);Intros a b;Rewrite a in H4;Clear a b; 
- Apply (Rlt_trans R0 R1 (Rplus R1 R1) H3 H4).
-Unfold Rgt;Unfold Rgt in H1;
- Rewrite (Rmult_sym eps(Rinv (Rplus R1 R1)));
- Rewrite <-(Rmult_Or (Rinv (Rplus R1 R1)));
- Apply (Rlt_monotony (Rinv (Rplus R1 R1)) R0 eps);Auto.
-Apply (Rlt_Rinv (Rplus R1 R1));Cut (Rlt R1 (Rplus R1 R1)).
-Intro;Apply (Rlt_trans R0 R1 (Rplus R1 R1) Rlt_R0_R1 H2).
-Generalize (Rlt_compatibility R1 R0 R1 Rlt_R0_R1);Elim (Rplus_ne R1);
- Intros a b;Rewrite a;Clear a b;Trivial.
-(**)
-Intros;Unfold adhDa in H;Elim (H0 eps H2);Intros;Elim (H1 eps H2);
- Intros;Clear H0 H1;Elim H3;Elim H4;Clear H3 H4;Intros;
- Simpl;Simpl in H1 H4;Generalize (Rmin_Rgt x x1 R0);Intro;Elim H5;
- Intros;Clear H5;
- Elim (H (Rmin x x1) (H7 (conj (Rgt x R0) (Rgt x1 R0) H3 H0)));
- Intros; Elim H5;Intros;Clear H5 H H6 H7;
- Generalize (Rmin_Rgt x x1 (R_dist x2 x0));Intro;Elim H;
- Intros;Clear H H6;Unfold Rgt in H5;Elim (H5 H9);Intros;Clear H5 H9;
- Generalize (H1 x2 (conj (D x2) (Rlt (R_dist x2 x0) x1) H8 H6));
- Generalize (H4 x2 (conj (D x2) (Rlt (R_dist x2 x0) x) H8 H));
- Clear H8 H H6 H1 H4 H0 H3;Intros;
- Generalize (Rplus_lt (R_dist (f x2) l) eps (R_dist (f x2) l') eps 
-  H H0); Unfold R_dist;Intros;
- Rewrite (Rabsolu_minus_sym (f x2) l) in H1;
- Rewrite (Rmult_sym (Rplus R1 R1) eps);Rewrite (Rmult_Rplus_distr eps R1 R1);
- Elim (Rmult_ne eps);Intros a b;Rewrite a;Clear a b;
- Generalize (R_dist_tri l l' (f x2));Unfold R_dist;Intros;
- Apply (Rle_lt_trans (Rabsolu (Rminus l l')) 
-  (Rplus (Rabsolu (Rminus l (f x2))) (Rabsolu (Rminus (f x2) l')))
-  (Rplus eps eps) H3 H1).
-Qed.
-
-(*********)
-Lemma limit_comp:(f,g:R->R)(Df,Dg:R->Prop)(l,l':R)(x0:R)
-   (limit1_in f Df l x0)->(limit1_in g Dg l' l)->
-   (limit1_in [x:R](g (f x)) (Dgf Df Dg f) l' x0).
-Unfold limit1_in limit_in Dgf;Simpl.
-Intros f g Df Dg l l' x0 Hf Hg eps eps_pos.
-Elim (Hg eps eps_pos).
-Intros alpg lg.
-Elim (Hf alpg).
-2: Tauto.
-Intros alpf lf.
-Exists alpf.
-Intuition.
-Qed.
-
-(*********)
-
-Lemma limit_inv : (f:R->R)(D:R->Prop)(l:R)(x0:R) (limit1_in f D l x0)->~(l==R0)->(limit1_in [x:R](Rinv (f x)) D (Rinv l) x0).
-Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Elim (H ``(Rabsolu l)/2``).
-Intros delta1 H2; Elim (H ``eps*((Rsqr l)/2)``).
-Intros delta2 H3; Elim H2; Elim H3; Intros; Exists (Rmin delta1 delta2); Split.
-Unfold Rmin; Case (total_order_Rle delta1 delta2); Intro; Assumption.
-Intro; Generalize (H5 x); Clear H5; Intro H5; Generalize (H7 x); Clear H7; Intro H7; Intro H10; Elim H10; Intros; Cut (D x)/\``(Rabsolu (x-x0))<delta1``.
-Cut (D x)/\``(Rabsolu (x-x0))<delta2``.
-Intros; Generalize (H5 H11); Clear H5; Intro H5; Generalize (H7 H12); Clear H7; Intro H7; Generalize (Rabsolu_triang_inv l (f x)); Intro; Rewrite Rabsolu_minus_sym in H7; Generalize (Rle_lt_trans ``(Rabsolu l)-(Rabsolu (f x))`` ``(Rabsolu (l-(f x)))`` ``(Rabsolu l)/2`` H13 H7); Intro; Generalize (Rlt_compatibility ``(Rabsolu (f x))-(Rabsolu l)/2`` ``(Rabsolu l)-(Rabsolu (f x))`` ``(Rabsolu l)/2`` H14); Replace ``(Rabsolu (f x))-(Rabsolu l)/2+((Rabsolu l)-(Rabsolu (f x)))`` with ``(Rabsolu l)/2``.
-Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Intro; Cut ~``(f x)==0``.
-Intro; Replace ``/(f x)+ -/l`` with ``(l-(f x))*/(l*(f x))``.
-Rewrite Rabsolu_mult; Rewrite Rabsolu_Rinv.
-Cut ``/(Rabsolu (l*(f x)))<2/(Rsqr l)``.
-Intro; Rewrite Rabsolu_minus_sym in H5; Cut ``0<=/(Rabsolu (l*(f x)))``.
-Intro; Generalize (Rmult_lt2 ``(Rabsolu (l-(f x)))`` ``eps*(Rsqr l)/2`` ``/(Rabsolu (l*(f x)))`` ``2/(Rsqr l)`` (Rabsolu_pos ``l-(f x)``) H18 H5 H17); Replace ``eps*(Rsqr l)/2*2/(Rsqr l)`` with ``eps``.
-Intro; Assumption.
-Unfold Rdiv; Unfold Rsqr; Rewrite Rinv_Rmult.
-Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym l).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym l).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Reflexivity.
-DiscrR.
-Exact H0.
-Exact H0.
-Exact H0.
-Exact H0.
-Left; Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Apply prod_neq_R0; Assumption.
-Rewrite Rmult_sym; Rewrite Rabsolu_mult; Rewrite Rinv_Rmult.
-Rewrite (Rsqr_abs l); Unfold Rsqr; Unfold Rdiv; Rewrite Rinv_Rmult.
-Repeat Rewrite <- Rmult_assoc; Apply Rlt_monotony_r.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption.
-Apply Rlt_monotony_contra with ``(Rabsolu (f x))*(Rabsolu l)*/2``.
-Repeat Apply Rmult_lt_pos.
-Apply Rabsolu_pos_lt; Assumption.
-Apply Rabsolu_pos_lt; Assumption.
-Apply Rlt_Rinv; Cut ~(O=(2)); [Intro H17; Generalize (lt_INR_0 (2) (neq_O_lt (2) H17)); Unfold INR; Intro H18; Assumption | Discriminate].
-Replace ``(Rabsolu (f x))*(Rabsolu l)*/2*/(Rabsolu (f x))`` with ``(Rabsolu l)/2``.
-Replace ``(Rabsolu (f x))*(Rabsolu l)*/2*(2*/(Rabsolu l))`` with ``(Rabsolu (f x))``.
-Assumption.
-Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym (Rabsolu l)).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Reflexivity.
-DiscrR.
-Apply Rabsolu_no_R0.
-Assumption.
-Unfold Rdiv.
-Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym (Rabsolu (f x))).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Reflexivity.
-Apply Rabsolu_no_R0; Assumption.
-Apply Rabsolu_no_R0; Assumption.
-Apply Rabsolu_no_R0; Assumption.
-Apply Rabsolu_no_R0; Assumption.
-Apply Rabsolu_no_R0; Assumption.
-Apply prod_neq_R0; Assumption.
-Rewrite (Rinv_Rmult ? ? H0 H16).
-Unfold Rminus; Rewrite Rmult_Rplus_distrl.
-Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l.
-Rewrite Ropp_mul1.
-Rewrite (Rmult_sym (f x)).
-Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Reflexivity.
-Assumption.
-Assumption.
-Red; Intro; Rewrite H16 in H15; Rewrite Rabsolu_R0 in H15; Cut ``0<(Rabsolu l)/2``.
-Intro; Elim (Rlt_antirefl ``0`` (Rlt_trans ``0`` ``(Rabsolu l)/2`` ``0`` H17 H15)).
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply Rabsolu_pos_lt; Assumption.
-Apply Rlt_Rinv; Cut ~(O=(2)); [Intro H17; Generalize (lt_INR_0 (2) (neq_O_lt (2) H17)); Unfold INR; Intro; Assumption | Discriminate].
-Pattern 3 (Rabsolu l); Rewrite double_var.
-Ring.
-Split; [Assumption | Apply Rlt_le_trans with (Rmin delta1 delta2); [Assumption | Apply Rmin_r]].
-Split; [Assumption | Apply Rlt_le_trans with (Rmin delta1 delta2); [Assumption | Apply Rmin_l]].
-Change ``0<eps*(Rsqr l)/2``; Unfold Rdiv; Repeat Rewrite Rmult_assoc; Repeat Apply Rmult_lt_pos.
-Assumption.
-Apply Rsqr_pos_lt; Assumption.
-Apply Rlt_Rinv; Cut ~(O=(2)); [Intro H3; Generalize (lt_INR_0 (2) (neq_O_lt (2) H3)); Unfold INR; Intro; Assumption | Discriminate].
-Change ``0<(Rabsolu l)/2``; Unfold Rdiv; Apply Rmult_lt_pos; [Apply Rabsolu_pos_lt; Assumption | Apply Rlt_Rinv; Cut ~(O=(2)); [Intro H3; Generalize (lt_INR_0 (2) (neq_O_lt (2) H3)); Unfold INR; Intro; Assumption | Discriminate]].
-Qed.
diff --git a/theories7/Reals/Rpower.v b/theories7/Reals/Rpower.v
deleted file mode 100644
index 0acfa8d2..00000000
--- a/theories7/Reals/Rpower.v
+++ /dev/null
@@ -1,560 +0,0 @@
-(************************************************************************)
-(*  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: Rpower.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-(*i Due to L.Thery i*) 
-
-(************************************************************)
-(* Definitions of log and Rpower : R->R->R; main properties *)
-(************************************************************)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo.
-Require Ranalysis1.
-Require Exp_prop.
-Require Rsqrt_def.
-Require R_sqrt.
-Require MVT.
-Require Ranalysis4.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Lemma P_Rmin: (P : R ->  Prop) (x, y : R) (P x) -> (P y) ->  (P (Rmin x y)).
-Intros P x y H1 H2; Unfold Rmin; Case (total_order_Rle x y); Intro; Assumption.
-Qed.
-
-Lemma exp_le_3 :  ``(exp 1)<=3``.
-Assert exp_1 : ``(exp 1)<>0``.
-Assert H0 := (exp_pos R1); Red; Intro; Rewrite H in H0; Elim (Rlt_antirefl ? H0).
-Apply Rle_monotony_contra with ``/(exp 1)``.
-Apply Rlt_Rinv; Apply exp_pos.
-Rewrite <- Rinv_l_sym.
-Apply Rle_monotony_contra with ``/3``.
-Apply Rlt_Rinv; Sup0.
-Rewrite Rmult_1r; Rewrite <- (Rmult_sym ``3``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Replace ``/(exp 1)`` with ``(exp (-1))``.
-Unfold exp; Case (exist_exp ``-1``); Intros; Simpl; Unfold exp_in in e; Assert H := (alternated_series_ineq [i:nat]``/(INR (fact i))`` x (S O)).
-Cut ``(sum_f_R0 (tg_alt [([i:nat]``/(INR (fact i))``)]) (S (mult (S (S O)) (S O)))) <= x <= (sum_f_R0 (tg_alt [([i:nat]``/(INR (fact i))``)]) (mult (S (S O)) (S O)))``.
-Intro; Elim H0; Clear H0; Intros H0 _; Simpl in H0; Unfold tg_alt in H0; Simpl in H0.
-Replace ``/3`` with ``1*/1+ -1*1*/1+ -1*( -1*1)*/2+ -1*( -1*( -1*1))*/(2+1+1+1+1)``.
-Apply H0.
-Repeat Rewrite Rinv_R1; Repeat Rewrite Rmult_1r; Rewrite Ropp_mul1; Rewrite Rmult_1l; Rewrite Ropp_Ropp; Rewrite Rplus_Ropp_r; Rewrite Rmult_1r; Rewrite Rplus_Ol; Rewrite Rmult_1l; Apply r_Rmult_mult with ``6``.
-Rewrite Rmult_Rplus_distr; Replace ``2+1+1+1+1`` with ``6``.
-Rewrite <- (Rmult_sym ``/6``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Replace ``6`` with ``2*3``.
-Do 2 Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Rewrite (Rmult_sym ``3``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Ring.
-DiscrR.
-DiscrR.
-Ring.
-DiscrR.
-Ring.
-DiscrR.
-Apply H.
-Unfold Un_decreasing; Intros; Apply Rle_monotony_contra with ``(INR (fact n))``.
-Apply INR_fact_lt_0.
-Apply Rle_monotony_contra with ``(INR (fact (S n)))``.
-Apply INR_fact_lt_0.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Rewrite Rmult_sym; Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Apply le_INR; Apply fact_growing; Apply le_n_Sn.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Assert H0 := (cv_speed_pow_fact R1); Unfold Un_cv; Unfold Un_cv in H0; Intros; Elim (H0 ? H1); Intros; Exists x0; Intros; Unfold R_dist in H2; Unfold R_dist; Replace ``/(INR (fact n))`` with ``(pow 1 n)/(INR (fact n))``.
-Apply (H2 ? H3).
-Unfold Rdiv; Rewrite pow1; Rewrite Rmult_1l; Reflexivity.
-Unfold infinit_sum in e; Unfold Un_cv tg_alt; Intros; Elim (e ? H0); Intros; Exists x0; Intros; Replace (sum_f_R0 ([i:nat]``(pow ( -1) i)*/(INR (fact i))``) n) with (sum_f_R0 ([i:nat]``/(INR (fact i))*(pow ( -1) i)``) n).
-Apply (H1 ? H2).
-Apply sum_eq; Intros; Apply Rmult_sym.
-Apply r_Rmult_mult with ``(exp 1)``.
-Rewrite <- exp_plus; Rewrite Rplus_Ropp_r; Rewrite exp_0; Rewrite <- Rinv_r_sym.
-Reflexivity.
-Assumption.
-Assumption.
-DiscrR.
-Assumption.
-Qed.
-
-(******************************************************************)
-(*                        Properties of  Exp                      *)
-(******************************************************************)
-
-Theorem exp_increasing: (x, y : R) ``x<y`` -> ``(exp x)<(exp y)``.
-Intros x y H.
-Assert H0 : (derivable exp).
-Apply derivable_exp.
-Assert H1 := (positive_derivative ? H0).
-Unfold strict_increasing in H1.
-Apply H1.
-Intro.
-Replace (derive_pt exp x0 (H0 x0)) with (exp x0).
-Apply exp_pos.
-Symmetry; Apply derive_pt_eq_0.
-Apply (derivable_pt_lim_exp x0).
-Apply H.
-Qed.
- 
-Theorem exp_lt_inv: (x, y : R) ``(exp x)<(exp y)`` -> ``x<y``.
-Intros x y H; Case (total_order x y); [Intros H1 | Intros [H1|H1]].
-Assumption.
-Rewrite H1 in H; Elim (Rlt_antirefl ? H).
-Assert H2 := (exp_increasing ? ? H1).
-Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H H2)).
-Qed.
- 
-Lemma exp_ineq1 : (x:R) ``0<x`` -> ``1+x < (exp x)``.
-Intros; Apply Rlt_anti_compatibility with ``-(exp 0)``; Rewrite <- (Rplus_sym (exp x)); Assert H0 := (MVT_cor1 exp R0 x derivable_exp H); Elim H0; Intros; Elim H1; Intros; Unfold Rminus in H2; Rewrite H2; Rewrite Ropp_O; Rewrite Rplus_Or; Replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
-Rewrite exp_0; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Pattern 1 x; Rewrite <- Rmult_1r; Rewrite (Rmult_sym (exp x0)); Apply Rlt_monotony.
-Apply H.
-Rewrite <- exp_0; Apply exp_increasing; Elim H3; Intros; Assumption.
-Symmetry; Apply derive_pt_eq_0; Apply derivable_pt_lim_exp.
-Qed.
-
-Lemma ln_exists1 : (y:R) ``0<y``->``1<=y``->(sigTT R [z:R]``y==(exp z)``).
-Intros; Pose f := [x:R]``(exp x)-y``; Cut ``(f 0)<=0``.
-Intro; Cut (continuity f).
-Intro; Cut ``0<=(f y)``.
-Intro; Cut ``(f 0)*(f y)<=0``.
-Intro; Assert X := (IVT_cor f R0 y H2 (Rlt_le ? ? H) H4); Elim X; Intros t H5; Apply existTT with t; Elim H5; Intros; Unfold f in H7; Apply Rminus_eq_right; Exact H7.
-Pattern 2 R0; Rewrite <- (Rmult_Or (f y)); Rewrite (Rmult_sym (f R0)); Apply Rle_monotony; Assumption.
-Unfold f; Apply Rle_anti_compatibility with y; Left; Apply Rlt_trans with ``1+y``.
-Rewrite <- (Rplus_sym y); Apply Rlt_compatibility; Apply Rlt_R0_R1.
-Replace ``y+((exp y)-y)`` with (exp y); [Apply (exp_ineq1 y H) | Ring].
-Unfold f; Change (continuity (minus_fct exp (fct_cte y))); Apply continuity_minus; [Apply derivable_continuous; Apply derivable_exp | Apply derivable_continuous; Apply derivable_const].
-Unfold f; Rewrite exp_0; Apply Rle_anti_compatibility with y; Rewrite Rplus_Or; Replace ``y+(1-y)`` with R1; [Apply H0 | Ring].
-Qed.
-
-(**********)
-Lemma ln_exists : (y:R) ``0<y`` -> (sigTT R [z:R]``y==(exp z)``).
-Intros; Case (total_order_Rle R1 y); Intro.
-Apply (ln_exists1 ? H r).
-Assert H0 : ``1<=/y``.
-Apply Rle_monotony_contra with y.
-Apply H.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Left; Apply (not_Rle ? ? n).
-Red; Intro; Rewrite H0 in H; Elim (Rlt_antirefl ? H).
-Assert H1 : ``0</y``.
-Apply Rlt_Rinv; Apply H.
-Assert H2 := (ln_exists1 ? H1 H0); Elim H2; Intros; Apply existTT with ``-x``; Apply r_Rmult_mult with ``(exp x)/y``.
-Unfold Rdiv; Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite <- (Rmult_sym ``/y``); Rewrite Rmult_assoc; Rewrite <- exp_plus; Rewrite Rplus_Ropp_r; Rewrite exp_0; Rewrite Rmult_1r; Symmetry; Apply p.
-Red; Intro; Rewrite H3 in H; Elim (Rlt_antirefl ? H).
-Unfold Rdiv; Apply prod_neq_R0.
-Assert H3 := (exp_pos x); Red; Intro; Rewrite H4 in H3; Elim (Rlt_antirefl ? H3).
-Apply Rinv_neq_R0; Red; Intro; Rewrite H3 in H; Elim (Rlt_antirefl ? H).
-Qed.
-
-(* Definition of log R+* -> R *)
-Definition Rln [y:posreal] : R := Cases (ln_exists (pos y) (RIneq.cond_pos y)) of (existTT a b) => a end.
-
-(* Extension on R *)
-Definition ln : R->R := [x:R](Cases (total_order_Rlt R0 x) of
-      (leftT a) => (Rln (mkposreal x a)) 
-    | (rightT a) => R0 end).
-
-Lemma exp_ln :  (x : R) ``0<x`` ->  (exp (ln x)) == x.
-Intros; Unfold ln; Case (total_order_Rlt R0 x); Intro.
-Unfold Rln; Case (ln_exists (mkposreal x r) (RIneq.cond_pos (mkposreal x r))); Intros.
-Simpl in e; Symmetry; Apply e.
-Elim n; Apply H.
-Qed.
-
-Theorem exp_inv: (x, y : R) (exp x) == (exp y) ->  x == y.
-Intros x y H; Case (total_order x y); [Intros H1 | Intros [H1|H1]]; Auto; Assert H2 := (exp_increasing ? ? H1); Rewrite H in H2; Elim (Rlt_antirefl ? H2).
-Qed.
- 
-Theorem exp_Ropp: (x : R)  ``(exp (-x)) == /(exp x)``.
-Intros x; Assert H : ``(exp x)<>0``.
-Assert H := (exp_pos x); Red; Intro; Rewrite H0 in H; Elim (Rlt_antirefl ? H).
-Apply r_Rmult_mult with r := (exp x).
-Rewrite <- exp_plus; Rewrite Rplus_Ropp_r; Rewrite exp_0.
-Apply Rinv_r_sym.
-Apply H.
-Apply H.
-Qed.
- 
-(******************************************************************)
-(*                        Properties of  Ln                       *)
-(******************************************************************)
-
-Theorem ln_increasing:
- (x, y : R) ``0<x`` -> ``x<y`` -> ``(ln x) < (ln y)``.
-Intros x y H H0; Apply exp_lt_inv.
-Repeat  Rewrite exp_ln. 
-Apply H0.
-Apply Rlt_trans with x; Assumption.
-Apply H.
-Qed.
-
-Theorem ln_exp: (x : R)  (ln (exp x)) == x.
-Intros x; Apply exp_inv.
-Apply exp_ln.
-Apply exp_pos.
-Qed.
- 
-Theorem ln_1: ``(ln 1) == 0``.
-Rewrite <- exp_0; Rewrite ln_exp; Reflexivity.
-Qed.
- 
-Theorem ln_lt_inv:
- (x, y : R) ``0<x`` -> ``0<y`` -> ``(ln x)<(ln y)`` ->  ``x<y``.
-Intros x y H H0 H1; Rewrite <- (exp_ln x); Try Rewrite <- (exp_ln y).
-Apply exp_increasing; Apply H1.
-Assumption. 
-Assumption.
-Qed.
- 
-Theorem ln_inv: (x, y : R) ``0<x`` -> ``0<y`` -> (ln x) == (ln y) ->  x == y.
-Intros x y H H0 H'0; Case (total_order x y); [Intros H1 | Intros [H1|H1]]; Auto.
-Assert H2 := (ln_increasing ? ? H H1); Rewrite H'0 in H2; Elim (Rlt_antirefl ? H2).
-Assert H2 := (ln_increasing ? ? H0 H1); Rewrite H'0 in H2; Elim (Rlt_antirefl ? H2).
-Qed.
- 
-Theorem ln_mult: (x, y : R) ``0<x`` -> ``0<y`` ->  ``(ln (x*y)) == (ln x)+(ln y)``.
-Intros x y H H0; Apply exp_inv.
-Rewrite exp_plus.
-Repeat Rewrite exp_ln.
-Reflexivity.
-Assumption.
-Assumption.
-Apply Rmult_lt_pos; Assumption.
-Qed.
-
-Theorem ln_Rinv: (x : R) ``0<x`` ->  ``(ln (/x)) == -(ln x)``.
-Intros x H; Apply exp_inv; Repeat (Rewrite exp_ln Orelse Rewrite exp_Ropp).
-Reflexivity.
-Assumption. 
-Apply Rlt_Rinv; Assumption.
-Qed.
-
-Theorem ln_continue:
- (y : R) ``0<y`` ->  (continue_in ln [x : R]  (Rlt R0 x) y).
-Intros y H.
-Unfold continue_in limit1_in limit_in; Intros eps Heps.
-Cut (Rlt R1 (exp eps)); [Intros H1 | Idtac].
-Cut (Rlt (exp (Ropp eps)) R1); [Intros H2 | Idtac].
-Exists
- (Rmin (Rmult y (Rminus (exp eps) R1)) (Rmult y (Rminus R1 (exp (Ropp eps)))));
- Split.
-Red; Apply P_Rmin.
-Apply Rmult_lt_pos.
-Assumption.
-Apply Rlt_anti_compatibility with R1.
-Rewrite Rplus_Or; Replace ``(1+((exp eps)-1))`` with (exp eps); [Apply H1 | Ring].
-Apply Rmult_lt_pos.
-Assumption.
-Apply Rlt_anti_compatibility with ``(exp (-eps))``.
-Rewrite Rplus_Or; Replace ``(exp ( -eps))+(1-(exp ( -eps)))`` with R1; [Apply H2 | Ring].
-Unfold dist R_met R_dist; Simpl.
-Intros x ((H3, H4), H5).
-Cut (Rmult y (Rmult x (Rinv y))) == x.
-Intro Hxyy. 
-Replace (Rminus (ln x) (ln y)) with (ln (Rmult x (Rinv y))).
-Case (total_order x y); [Intros Hxy | Intros [Hxy|Hxy]].
-Rewrite Rabsolu_left.
-Apply Ropp_Rlt; Rewrite Ropp_Ropp.
-Apply exp_lt_inv.
-Rewrite exp_ln.
-Apply Rlt_monotony_contra with z := y.
-Apply H.
-Rewrite Hxyy.
-Apply Ropp_Rlt.
-Apply Rlt_anti_compatibility with r := y.
-Replace (Rplus y (Ropp (Rmult y (exp (Ropp eps)))))
-     with (Rmult y (Rminus R1 (exp (Ropp eps)))); [Idtac | Ring].
-Replace (Rplus y (Ropp x)) with (Rabsolu (Rminus x y)); [Idtac | Ring].
-Apply Rlt_le_trans with 1 := H5; Apply Rmin_r.
-Rewrite Rabsolu_left; [Ring | Idtac].
-Apply (Rlt_minus ? ? Hxy).
-Apply Rmult_lt_pos; [Apply H3  | Apply (Rlt_Rinv ? H)].
-Rewrite <- ln_1.
-Apply ln_increasing.
-Apply Rmult_lt_pos; [Apply H3  | Apply (Rlt_Rinv ? H)].
-Apply Rlt_monotony_contra with z := y.
-Apply H.
-Rewrite Hxyy; Rewrite Rmult_1r; Apply Hxy.
-Rewrite Hxy; Rewrite Rinv_r.
-Rewrite ln_1; Rewrite Rabsolu_R0; Apply Heps.
-Red; Intro; Rewrite H0 in H; Elim (Rlt_antirefl ? H).
-Rewrite Rabsolu_right.
-Apply exp_lt_inv.
-Rewrite exp_ln.
-Apply Rlt_monotony_contra with z := y.
-Apply H.
-Rewrite Hxyy.
-Apply Rlt_anti_compatibility with r := (Ropp y).
-Replace (Rplus (Ropp y) (Rmult y (exp eps)))
-     with (Rmult y (Rminus (exp eps) R1)); [Idtac | Ring].
-Replace (Rplus (Ropp y) x) with (Rabsolu (Rminus x y)); [Idtac | Ring].
-Apply Rlt_le_trans with 1 := H5; Apply Rmin_l.
-Rewrite Rabsolu_right; [Ring | Idtac].
-Left; Apply (Rgt_minus ? ? Hxy).
-Apply Rmult_lt_pos; [Apply H3  | Apply (Rlt_Rinv ? H)].
-Rewrite <- ln_1.
-Apply Rgt_ge; Red; Apply ln_increasing.
-Apply Rlt_R0_R1.
-Apply Rlt_monotony_contra with z := y.
-Apply H.
-Rewrite Hxyy; Rewrite Rmult_1r; Apply Hxy.
-Rewrite ln_mult.
-Rewrite ln_Rinv.
-Ring.
-Assumption.
-Assumption.
-Apply Rlt_Rinv; Assumption.
-Rewrite (Rmult_sym x); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Ring.
-Red; Intro; Rewrite H0 in H; Elim (Rlt_antirefl ? H).
-Apply Rlt_monotony_contra with (exp eps).
-Apply exp_pos.
-Rewrite <- exp_plus; Rewrite Rmult_1r; Rewrite Rplus_Ropp_r; Rewrite exp_0; Apply H1.
-Rewrite <- exp_0.
-Apply exp_increasing; Apply Heps.
-Qed.
-
-(******************************************************************)
-(*                        Definition of  Rpower                   *)
-(******************************************************************)
- 
-Definition Rpower := [x : R] [y : R]  ``(exp (y*(ln x)))``.
-
-Infix Local "^R" Rpower (at level 2, left associativity) : R_scope.
-
-(******************************************************************)
-(*                        Properties of  Rpower                   *)
-(******************************************************************)
- 
-Theorem Rpower_plus:
- (x, y, z : R)  ``(Rpower z (x+y)) == (Rpower z x)*(Rpower z y)``.
-Intros x y z; Unfold Rpower.
-Rewrite Rmult_Rplus_distrl; Rewrite exp_plus; Auto.
-Qed.
- 
-Theorem Rpower_mult:
- (x, y, z : R)  ``(Rpower (Rpower x y) z) == (Rpower x (y*z))``.
-Intros x y z; Unfold Rpower.
-Rewrite ln_exp.
-Replace (Rmult z (Rmult y (ln x))) with (Rmult (Rmult y z) (ln x)).
-Reflexivity.
-Ring.
-Qed.
- 
-Theorem Rpower_O: (x : R) ``0<x`` ->  ``(Rpower x 0) == 1``.
-Intros x H; Unfold Rpower.
-Rewrite Rmult_Ol; Apply exp_0.
-Qed.
- 
-Theorem Rpower_1: (x : R) ``0<x`` ->  ``(Rpower x 1) == x``.
-Intros x H; Unfold Rpower.
-Rewrite Rmult_1l; Apply exp_ln; Apply H.
-Qed.
- 
-Theorem Rpower_pow:
- (n : nat) (x : R) ``0<x`` ->  (Rpower x (INR n)) == (pow x n).
-Intros n; Elim n; Simpl; Auto; Fold INR.
-Intros x H; Apply Rpower_O; Auto.
-Intros n1; Case n1.
-Intros H x H0; Simpl; Rewrite Rmult_1r; Apply Rpower_1; Auto.
-Intros n0 H x H0; Rewrite Rpower_plus; Rewrite H; Try Rewrite Rpower_1; Try Apply Rmult_sym Orelse Assumption.
-Qed.
- 
-Theorem Rpower_lt: (x, y, z : R) ``1<x`` -> ``0<=y`` -> ``y<z`` ->  ``(Rpower x y) < (Rpower x z)``.
-Intros x y z H H0 H1.
-Unfold Rpower.
-Apply exp_increasing.
-Apply Rlt_monotony_r.
-Rewrite <- ln_1; Apply ln_increasing.
-Apply Rlt_R0_R1.
-Apply H.
-Apply H1.
-Qed.
- 
-Theorem Rpower_sqrt: (x : R) ``0<x`` ->  ``(Rpower x (/2)) == (sqrt x)``.
-Intros x H.
-Apply ln_inv.
-Unfold Rpower; Apply exp_pos.
-Apply sqrt_lt_R0; Apply H.
-Apply r_Rmult_mult with (INR (S (S O))).
-Apply exp_inv.
-Fold Rpower.
-Cut (Rpower (Rpower x (Rinv (Rplus R1 R1))) (INR (S (S O)))) == (Rpower (sqrt x) (INR (S (S O)))).
-Unfold Rpower; Auto.
-Rewrite Rpower_mult.
-Rewrite Rinv_l.
-Replace R1 with (INR (S O)); Auto.
-Repeat Rewrite Rpower_pow; Simpl.
-Pattern 1 x; Rewrite <- (sqrt_sqrt x (Rlt_le ? ? H)).
-Ring.
-Apply sqrt_lt_R0; Apply H.
-Apply H.
-Apply not_O_INR; Discriminate.
-Apply not_O_INR; Discriminate.
-Qed.
- 
-Theorem Rpower_Ropp: (x, y : R) ``(Rpower x (-y)) == /(Rpower x y)``.
-Unfold Rpower.
-Intros x y; Rewrite Ropp_mul1.
-Apply exp_Ropp.
-Qed.
- 
-Theorem Rle_Rpower: (e,n,m : R) ``1<e`` -> ``0<=n`` -> ``n<=m`` ->  ``(Rpower e n)<=(Rpower e m)``.
-Intros e n m H H0 H1; Case H1.
-Intros H2; Left; Apply Rpower_lt; Assumption.
-Intros H2; Rewrite H2; Right; Reflexivity.
-Qed.
-  
-Theorem ln_lt_2: ``/2<(ln 2)``.
-Apply Rlt_monotony_contra with z := (Rplus R1 R1).
-Sup0.
-Rewrite Rinv_r.
-Apply exp_lt_inv.
-Apply Rle_lt_trans with 1 := exp_le_3.
-Change (Rlt (Rplus R1 (Rplus R1 R1)) (Rpower (Rplus R1 R1) (Rplus R1 R1))).
-Repeat Rewrite Rpower_plus; Repeat Rewrite Rpower_1.
-Repeat Rewrite Rmult_Rplus_distrl; Repeat Rewrite Rmult_Rplus_distr;
- Repeat Rewrite Rmult_1l.
-Pattern 1 ``3``; Rewrite <- Rplus_Or; Replace ``2+2`` with ``3+1``; [Apply Rlt_compatibility; Apply Rlt_R0_R1 | Ring].
-Sup0.
-DiscrR.
-Qed.
-
-(**************************************)
-(* Differentiability of Ln and Rpower *)
-(**************************************)
-
-Theorem limit1_ext: (f, g : R ->  R)(D : R ->  Prop)(l, x : R) ((x : R) (D x) ->  (f x) == (g x)) -> (limit1_in f D l x) ->  (limit1_in g D l x).
-Intros f g D l x H; Unfold limit1_in limit_in.
-Intros H0 eps H1; Case (H0 eps); Auto.
-Intros x0 (H2, H3); Exists x0; Split; Auto.
-Intros x1 (H4, H5); Rewrite <- H; Auto.
-Qed.
-
-Theorem limit1_imp: (f : R ->  R)(D, D1 : R ->  Prop)(l, x : R) ((x : R) (D1 x) ->  (D x)) -> (limit1_in f D l x) ->  (limit1_in f D1 l x).
-Intros f D D1 l x H; Unfold limit1_in limit_in.
-Intros H0 eps H1; Case (H0 eps H1); Auto.
-Intros alpha (H2, H3); Exists alpha; Split; Auto.
-Intros d (H4, H5); Apply H3; Split; Auto.
-Qed.
-
-Theorem Rinv_Rdiv: (x, y : R) ``x<>0`` -> ``y<>0`` ->  ``/(x/y) == y/x``.
-Intros x y H1 H2; Unfold Rdiv; Rewrite Rinv_Rmult.
-Rewrite Rinv_Rinv.
-Apply Rmult_sym.
-Assumption.
-Assumption.
-Apply Rinv_neq_R0; Assumption.
-Qed.
-
-Theorem Dln: (y : R) ``0<y`` ->  (D_in ln Rinv [x:R]``0<x`` y).
-Intros y Hy; Unfold D_in.
-Apply limit1_ext with f := [x : R](Rinv (Rdiv (Rminus (exp (ln x)) (exp (ln y))) (Rminus (ln x) (ln y)))).
-Intros x (HD1, HD2); Repeat Rewrite exp_ln.
-Unfold Rdiv; Rewrite Rinv_Rmult.
-Rewrite Rinv_Rinv.
-Apply Rmult_sym.
-Apply Rminus_eq_contra.
-Red; Intros H2; Case HD2.
-Symmetry; Apply (ln_inv ? ? HD1 Hy H2).
-Apply Rminus_eq_contra; Apply (not_sym ? ? HD2).
-Apply Rinv_neq_R0; Apply Rminus_eq_contra; Red; Intros H2; Case HD2; Apply ln_inv; Auto.
-Assumption.
-Assumption.
-Apply limit_inv with f := [x : R]  (Rdiv (Rminus (exp (ln x)) (exp (ln y))) (Rminus (ln x) (ln y))).
-Apply limit1_imp with f := [x : R] ([x : R]  (Rdiv (Rminus (exp x) (exp (ln y))) (Rminus x (ln y))) (ln x)) D := (Dgf (D_x [x : R]  (Rlt R0 x) y) (D_x [x : R]  True (ln y)) ln).
-Intros x (H1, H2); Split.
-Split; Auto.
-Split; Auto.
-Red; Intros H3; Case H2; Apply ln_inv; Auto.
-Apply limit_comp with l := (ln y) g := [x : R]  (Rdiv (Rminus (exp x) (exp (ln y))) (Rminus x (ln y))) f := ln.
-Apply ln_continue; Auto.
-Assert H0 := (derivable_pt_lim_exp (ln y)); Unfold derivable_pt_lim in H0; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Elim (H0 ? H); Intros; Exists (pos x); Split.
-Apply (RIneq.cond_pos x).
-Intros; Pattern 3 y; Rewrite <- exp_ln.
-Pattern 1 x0; Replace x0 with ``(ln y)+(x0-(ln y))``; [Idtac | Ring].
-Apply H1.
-Elim H2; Intros H3 _; Unfold D_x in H3; Elim H3; Clear H3; Intros _ H3; Apply Rminus_eq_contra; Apply not_sym; Apply H3.
-Elim H2; Clear H2; Intros _ H2; Apply H2.
-Assumption.
-Red; Intro; Rewrite H in Hy; Elim (Rlt_antirefl ? Hy).
-Qed.
-
-Lemma derivable_pt_lim_ln : (x:R) ``0<x`` -> (derivable_pt_lim ln x ``/x``).
-Intros; Assert H0 := (Dln x H); Unfold D_in in H0; Unfold limit1_in in H0; Unfold limit_in in H0; Simpl in H0; Unfold R_dist in H0; Unfold derivable_pt_lim; Intros; Elim (H0 ? H1); Intros; Elim H2; Clear H2; Intros; Pose alp := (Rmin x0 ``x/2``); Assert H4 : ``0<alp``.
-Unfold alp; Unfold Rmin; Case (total_order_Rle x0 ``x/2``); Intro.
-Apply H2.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Exists (mkposreal ? H4); Intros; Pattern 2 h; Replace h with ``(x+h)-x``; [Idtac | Ring].
-Apply H3; Split.
-Unfold D_x; Split.
-Case (case_Rabsolu h); Intro.
-Assert H7 : ``(Rabsolu h)<x/2``.
-Apply Rlt_le_trans with alp.
-Apply H6.
-Unfold alp; Apply Rmin_r.
-Apply Rlt_trans with ``x/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Rewrite Rabsolu_left in H7.
-Apply Rlt_anti_compatibility with ``-h-x/2``.
-Replace ``-h-x/2+x/2`` with ``-h``; [Idtac | Ring].
-Pattern 2 x; Rewrite double_var.
-Replace ``-h-x/2+(x/2+x/2+h)`` with ``x/2``; [Apply H7 | Ring].
-Apply r.
-Apply gt0_plus_ge0_is_gt0; [Assumption | Apply Rle_sym2; Apply r].
-Apply not_sym; Apply Rminus_not_eq; Replace ``x+h-x`` with h; [Apply H5 | Ring].
-Replace ``x+h-x`` with h; [Apply Rlt_le_trans with alp; [Apply H6 | Unfold alp; Apply Rmin_l] | Ring].
-Qed.
-
-Theorem D_in_imp: (f, g : R ->  R)(D, D1 : R ->  Prop)(x : R) ((x : R) (D1 x) ->  (D x)) -> (D_in f g D x) ->  (D_in f g D1 x).
-Intros f g D D1 x H; Unfold D_in.
-Intros H0; Apply limit1_imp with D := (D_x D x); Auto.
-Intros x1 (H1, H2); Split; Auto.
-Qed.
-
-Theorem D_in_ext: (f, g, h : R ->  R)(D : R ->  Prop) (x : R) (f x) == (g x) -> (D_in h f D x) ->  (D_in h g D x).
-Intros f g h D x H; Unfold D_in.
-Rewrite H; Auto.
-Qed.
-
-Theorem Dpower: (y, z : R) ``0<y`` -> (D_in [x:R](Rpower x z) [x:R](Rmult z (Rpower x (Rminus z R1))) [x:R]``0<x`` y).
-Intros y z H; Apply D_in_imp with D := (Dgf [x : R]  (Rlt R0 x) [x : R]  True ln).
-Intros x H0; Repeat Split.
-Assumption.
-Apply D_in_ext with f := [x : R]  (Rmult (Rinv x) (Rmult z (exp (Rmult z (ln x))))).
-Unfold Rminus; Rewrite Rpower_plus; Rewrite Rpower_Ropp; Rewrite (Rpower_1 ? H); Ring.
-Apply Dcomp with f := ln g := [x : R]  (exp (Rmult z x)) df := Rinv dg := [x : R]  (Rmult z (exp (Rmult z x))).
-Apply (Dln ? H).
-Apply D_in_imp with D := (Dgf [x : R]  True [x : R]  True [x : R]  (Rmult z x)).
-Intros x H1; Repeat Split; Auto.
-Apply (Dcomp [_ : R]  True [_ : R]  True [x : ?]  z exp [x : R]  (Rmult z x) exp); Simpl.
-Apply D_in_ext with f := [x : R]  (Rmult z R1).
-Apply Rmult_1r.
-Apply (Dmult_const [x : ?]  True [x : ?]  x [x : ?]  R1); Apply Dx.
-Assert H0 := (derivable_pt_lim_D_in exp exp ``z*(ln y)``); Elim H0; Clear H0; Intros _ H0; Apply H0; Apply derivable_pt_lim_exp.
-Qed.
-
-Theorem derivable_pt_lim_power: (x, y : R) (Rlt R0 x) -> (derivable_pt_lim [x : ?]  (Rpower x y) x (Rmult y (Rpower x (Rminus y R1)))).
-Intros x y H.
-Unfold Rminus; Rewrite Rpower_plus.
-Rewrite Rpower_Ropp.
-Rewrite Rpower_1; Auto.
-Rewrite <- Rmult_assoc.
-Unfold Rpower.
-Apply derivable_pt_lim_comp with f1 := ln f2 := [x : ?]  (exp (Rmult y x)).
-Apply derivable_pt_lim_ln; Assumption.
-Rewrite (Rmult_sym y).
-Apply derivable_pt_lim_comp with f1 := [x : ?]  (Rmult y x) f2 := exp.
-Pattern 2 y; Replace y with (Rplus (Rmult R0 (ln x)) (Rmult y R1)).
-Apply derivable_pt_lim_mult with f1 := [x : R]  y f2 := [x : R]  x.
-Apply derivable_pt_lim_const with a := y.
-Apply derivable_pt_lim_id.
-Ring.
-Apply derivable_pt_lim_exp.
-Qed.
diff --git a/theories7/Reals/Rprod.v b/theories7/Reals/Rprod.v
deleted file mode 100644
index a524a915..00000000
--- a/theories7/Reals/Rprod.v
+++ /dev/null
@@ -1,164 +0,0 @@
-(************************************************************************)
-(*  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: Rprod.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-Require Compare.
-Require Rbase.
-Require Rfunctions.
-Require Rseries.
-Require PartSum.
-Require Binomial.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(* TT Ak; 1<=k<=N *)
-Fixpoint prod_f_SO [An:nat->R;N:nat] : R := Cases N of
-  O => R1
-| (S p) => ``(prod_f_SO An p)*(An (S p))``
-end.
-
-(**********)
-Lemma prod_SO_split : (An:nat->R;n,k:nat) (le k n) -> (prod_f_SO An n)==(Rmult (prod_f_SO An k) (prod_f_SO [l:nat](An (plus k l)) (minus n k))).
-Intros; Induction n.
-Cut k=O; [Intro; Rewrite H0; Simpl; Ring | Inversion H; Reflexivity].
-Cut k=(S n)\/(le k n).
-Intro; Elim H0; Intro.
-Rewrite H1; Simpl; Rewrite <- minus_n_n; Simpl; Ring.
-Replace (minus (S n) k) with (S (minus n k)).
-Simpl; Replace (plus k (S (minus n k))) with (S n).
-Rewrite Hrecn; [Ring | Assumption].
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Rewrite S_INR; Rewrite minus_INR; [Ring | Assumption].
-Apply INR_eq; Rewrite S_INR; Repeat Rewrite minus_INR.
-Rewrite S_INR; Ring.
-Apply le_trans with n; [Assumption | Apply le_n_Sn].
-Assumption.
-Inversion H; [Left; Reflexivity | Right; Assumption].
-Qed.
-
-(**********)
-Lemma prod_SO_pos : (An:nat->R;N:nat) ((n:nat)(le n N)->``0<=(An n)``) -> ``0<=(prod_f_SO An N)``.
-Intros; Induction N.
-Simpl; Left; Apply Rlt_R0_R1.
-Simpl; Apply Rmult_le_pos.
-Apply HrecN; Intros; Apply H; Apply le_trans with N; [Assumption | Apply le_n_Sn].
-Apply H; Apply le_n.
-Qed.
-
-(**********)
-Lemma prod_SO_Rle : (An,Bn:nat->R;N:nat) ((n:nat)(le n N)->``0<=(An n)<=(Bn n)``) -> ``(prod_f_SO An N)<=(prod_f_SO Bn N)``.
-Intros; Induction N.
-Right; Reflexivity.
-Simpl; Apply Rle_trans with ``(prod_f_SO An N)*(Bn (S N))``.
-Apply Rle_monotony.
-Apply prod_SO_pos; Intros; Elim (H n (le_trans ? ? ? H0 (le_n_Sn N))); Intros; Assumption.
-Elim (H (S N) (le_n (S N))); Intros; Assumption.
-Do 2 Rewrite <- (Rmult_sym (Bn (S N))); Apply Rle_monotony.
-Elim (H (S N) (le_n (S N))); Intros.
-Apply Rle_trans with (An (S N)); Assumption.
-Apply HrecN; Intros; Elim (H n (le_trans ? ? ? H0 (le_n_Sn N))); Intros; Split; Assumption.
-Qed.
-
-(* Application to factorial *)
-Lemma fact_prodSO : (n:nat) (INR (fact n))==(prod_f_SO [k:nat](INR k) n).
-Intro; Induction n.
-Reflexivity.
-Change (INR (mult (S n) (fact n)))==(prod_f_SO ([k:nat](INR k)) (S n)).
-Rewrite mult_INR; Rewrite Rmult_sym; Rewrite Hrecn; Reflexivity.
-Qed.
-
-Lemma le_n_2n : (n:nat) (le n (mult (2) n)).
-Induction n.
-Replace (mult (2) (O)) with O; [Apply le_n | Ring].
-Intros; Replace (mult (2) (S n0)) with (S (S (mult (2) n0))).
-Apply le_n_S; Apply le_S; Assumption.
-Replace (S (S (mult (2) n0))) with (plus (mult (2) n0) (2)); [Idtac | Ring].
-Replace (S n0) with (plus n0 (1)); [Idtac | Ring].
-Ring.
-Qed. 
-
-(* We prove that (N!)²<=(2N-k)!*k! forall k in [|O;2N|] *)
-Lemma RfactN_fact2N_factk : (N,k:nat) (le k (mult (2) N)) -> ``(Rsqr (INR (fact N)))<=(INR (fact (minus (mult (S (S O)) N) k)))*(INR (fact k))``.
-Intros; Unfold Rsqr; Repeat Rewrite fact_prodSO.
-Cut (le k N)\/(le N k).
-Intro; Elim H0; Intro.
-Rewrite (prod_SO_split [l:nat](INR l) (minus (mult (2) N) k) N).
-Rewrite Rmult_assoc; Apply Rle_monotony.
-Apply prod_SO_pos; Intros; Apply pos_INR.
-Replace (minus (minus (mult (2) N) k) N) with (minus N k).
-Rewrite Rmult_sym; Rewrite (prod_SO_split [l:nat](INR l) N k).
-Apply Rle_monotony.
-Apply prod_SO_pos; Intros; Apply pos_INR.
-Apply prod_SO_Rle; Intros; Split.
-Apply pos_INR.
-Apply le_INR; Apply le_reg_r; Assumption.
-Assumption.
-Apply INR_eq; Repeat Rewrite minus_INR.
-Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply le_trans with N; [Assumption | Apply le_n_2n].
-Apply simpl_le_plus_l with k; Rewrite <- le_plus_minus.
-Replace (mult (2) N) with (plus N N); [Idtac | Ring].
-Apply le_reg_r; Assumption.
-Assumption.
-Assumption.
-Apply simpl_le_plus_l with k; Rewrite <- le_plus_minus.
-Replace (mult (2) N) with (plus N N); [Idtac | Ring].
-Apply le_reg_r; Assumption.
-Assumption.
-Rewrite <- (Rmult_sym (prod_f_SO [l:nat](INR l) k)); Rewrite (prod_SO_split [l:nat](INR l) k N).
-Rewrite Rmult_assoc; Apply Rle_monotony.
-Apply prod_SO_pos; Intros; Apply pos_INR.
-Rewrite Rmult_sym; Rewrite (prod_SO_split [l:nat](INR l) N (minus (mult (2) N) k)).
-Apply Rle_monotony.
-Apply prod_SO_pos; Intros; Apply pos_INR.
-Replace (minus N (minus (mult (2) N) k)) with (minus k N).
-Apply prod_SO_Rle; Intros; Split.
-Apply pos_INR.
-Apply le_INR; Apply le_reg_r.
-Apply simpl_le_plus_l with k; Rewrite <- le_plus_minus.
-Replace (mult (2) N) with (plus N N); [Idtac | Ring]; Apply le_reg_r; Assumption.
-Assumption.
-Apply INR_eq; Repeat Rewrite minus_INR.
-Rewrite mult_INR; Do 2 Rewrite S_INR; Ring.
-Assumption.
-Apply simpl_le_plus_l with k; Rewrite <- le_plus_minus.
-Replace (mult (2) N) with (plus N N); [Idtac | Ring]; Apply le_reg_r; Assumption.
-Assumption.
-Assumption.
-Apply simpl_le_plus_l with k; Rewrite <- le_plus_minus.
-Replace (mult (2) N) with (plus N N); [Idtac | Ring]; Apply le_reg_r; Assumption.
-Assumption.
-Assumption.
-Elim (le_dec k N); Intro; [Left; Assumption | Right; Assumption].
-Qed.
-
-(**********)
-Lemma INR_fact_lt_0 : (n:nat) ``0<(INR (fact n))``.
-Intro; Apply lt_INR_0; Apply neq_O_lt; Red; Intro; Elim (fact_neq_0 n); Symmetry; Assumption.
-Qed.
-
-(* We have the following inequality : (C 2N k) <= (C 2N N) forall k in [|O;2N|] *)
-Lemma C_maj : (N,k:nat) (le k (mult (2) N)) -> ``(C (mult (S (S O)) N) k)<=(C (mult (S (S O)) N) N)``.
-Intros; Unfold C; Unfold Rdiv; Apply Rle_monotony.
-Apply pos_INR.
-Replace (minus (mult (2) N) N) with N.
-Apply Rle_monotony_contra with ``((INR (fact N))*(INR (fact N)))``.
-Apply Rmult_lt_pos; Apply INR_fact_lt_0.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_sym; Apply Rle_monotony_contra with ``((INR (fact k))*
-   (INR (fact (minus (mult (S (S O)) N) k))))``.
-Apply Rmult_lt_pos; Apply INR_fact_lt_0.
-Rewrite Rmult_1r; Rewrite <- mult_INR; Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite mult_INR; Rewrite (Rmult_sym (INR (fact k))); Replace ``(INR (fact N))*(INR (fact N))`` with (Rsqr (INR (fact N))).
-Apply RfactN_fact2N_factk.
-Assumption.
-Reflexivity.
-Rewrite mult_INR; Apply prod_neq_R0; Apply INR_fact_neq_0.
-Apply prod_neq_R0; Apply INR_fact_neq_0.
-Apply INR_eq; Rewrite minus_INR; [Rewrite mult_INR; Do 2 Rewrite S_INR; Ring | Apply le_n_2n].
-Qed.
diff --git a/theories7/Reals/Rseries.v b/theories7/Reals/Rseries.v
deleted file mode 100644
index a38099dd..00000000
--- a/theories7/Reals/Rseries.v
+++ /dev/null
@@ -1,279 +0,0 @@
-(************************************************************************)
-(*  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: Rseries.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Classical.
-Require Compare.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Implicit Variable Type r:R.
-
-(* classical is needed for [Un_cv_crit] *)
-(*********************************************************)
-(*           Definition of sequence and properties       *)
-(*                                                       *)
-(*********************************************************)
-
-Section sequence.
-
-(*********)
-Variable Un:nat->R.
-
-(*********)
-Fixpoint Rmax_N [N:nat]:R:=
-   Cases N of
-     O     => (Un O)
-    |(S n) => (Rmax (Un (S n)) (Rmax_N n))
-   end.
-
-(*********)
-Definition EUn:R->Prop:=[r:R](Ex [i:nat] (r==(Un i))).
-
-(*********)
-Definition Un_cv:R->Prop:=[l:R]
-  (eps:R)(Rgt eps R0)->(Ex[N:nat](n:nat)(ge n N)->
-             (Rlt (R_dist (Un n) l) eps)).
-
-(*********)
-Definition Cauchy_crit:Prop:=(eps:R)(Rgt eps R0)->
-       (Ex[N:nat] (n,m:nat)(ge n N)->(ge m N)->
-                  (Rlt (R_dist (Un n) (Un m)) eps)).
-
-(*********)
-Definition Un_growing:Prop:=(n:nat)(Rle (Un n) (Un (S n))).
-
-(*********)
-Lemma EUn_noempty:(ExT [r:R] (EUn r)).
-Unfold EUn;Split with (Un O);Split with O;Trivial.
-Qed.
-
-(*********)
-Lemma Un_in_EUn:(n:nat)(EUn (Un n)).
-Intro;Unfold EUn;Split with n;Trivial.
-Qed.
-
-(*********)
-Lemma Un_bound_imp:(x:R)((n:nat)(Rle (Un n) x))->(is_upper_bound EUn x).
-Intros;Unfold is_upper_bound;Intros;Unfold EUn in H0;Elim H0;Clear H0;
- Intros;Generalize (H x1);Intro;Rewrite <- H0 in H1;Trivial.
-Qed.
-
-(*********)
-Lemma growing_prop:(n,m:nat)Un_growing->(ge n m)->(Rge (Un n) (Un m)).
-Double Induction n m;Intros.
-Unfold Rge;Right;Trivial.
-ElimType False;Unfold ge in H1;Generalize (le_Sn_O n0);Intro;Auto.
-Cut (ge n0 (0)).
-Generalize H0;Intros;Unfold Un_growing in H0;
- Apply (Rge_trans (Un (S n0)) (Un n0) (Un (0)) 
-                  (Rle_sym1 (Un n0) (Un (S n0)) (H0 n0)) (H O H2 H3)).
-Elim n0;Auto.
-Elim (lt_eq_lt_dec n1 n0);Intro y.
-Elim y;Clear y;Intro y.
-Unfold ge in H2;Generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2));Intro;
- ElimType False;Auto.
-Rewrite y;Unfold Rge;Right;Trivial.
-Unfold ge in H0;Generalize (H0 (S n0) H1 (lt_le_S n0 n1 y));Intro;
- Unfold Un_growing in H1;
- Apply (Rge_trans (Un (S n1)) (Un n1) (Un (S n0)) 
-                  (Rle_sym1 (Un n1) (Un (S n1)) (H1 n1)) H3).
-Qed.
-
-
-(* classical is needed: [not_all_not_ex] *)
-(*********)
-Lemma Un_cv_crit:Un_growing->(bound EUn)->(ExT [l:R] (Un_cv l)).
-Unfold Un_growing Un_cv;Intros;
- Generalize (complet_weak EUn H0 EUn_noempty);Intro;
- Elim H1;Clear H1;Intros;Split with x;Intros;
- Unfold is_lub in H1;Unfold bound in H0;Unfold is_upper_bound in H0 H1;
- Elim H0;Clear H0;Intros;Elim H1;Clear H1;Intros;
- Generalize (H3 x0 H0);Intro;Cut (n:nat)(Rle (Un n) x);Intro.
-Cut (Ex [N:nat] (Rlt (Rminus x eps) (Un N))).
-Intro;Elim H6;Clear H6;Intros;Split with x1.
-Intros;Unfold R_dist;Apply (Rabsolu_def1 (Rminus (Un n) x) eps).
-Unfold Rgt in H2;
- Apply (Rle_lt_trans (Rminus (Un n) x) R0 eps 
-                     (Rle_minus (Un n) x (H5 n)) H2).
-Fold Un_growing in H;Generalize (growing_prop n x1 H H7);Intro;
- Generalize (Rlt_le_trans (Rminus x eps) (Un x1) (Un n) H6
-                          (Rle_sym2 (Un x1) (Un n) H8));Intro;
- Generalize (Rlt_compatibility (Ropp x) (Rminus x eps) (Un n) H9);
- Unfold Rminus;Rewrite <-(Rplus_assoc (Ropp x) x (Ropp eps));
- Rewrite (Rplus_sym (Ropp x) (Un n));Fold (Rminus (Un n) x);
- Rewrite Rplus_Ropp_l;Rewrite (let (H1,H2)=(Rplus_ne (Ropp eps)) in H2);
- Trivial.
-Cut ~((N:nat)(Rge (Rminus x eps) (Un N))).
-Intro;Apply (not_all_not_ex nat ([N:nat](Rlt (Rminus x eps) (Un N))));
- Red;Intro;Red in H6;Elim H6;Clear H6;Intro;
- Apply (Rlt_not_ge (Rminus x eps) (Un N) (H7 N)).
-Red;Intro;Cut (N:nat)(Rle (Un N) (Rminus x eps)).
-Intro;Generalize (Un_bound_imp (Rminus x eps) H7);Intro;
- Unfold is_upper_bound in H8;Generalize (H3 (Rminus x eps) H8);Intro;
- Generalize (Rle_minus x (Rminus x eps) H9);Unfold Rminus;
- Rewrite Ropp_distr1;Rewrite <- Rplus_assoc;Rewrite Rplus_Ropp_r;
- Rewrite (let (H1,H2)=(Rplus_ne (Ropp (Ropp eps))) in H2);
- Rewrite Ropp_Ropp;Intro;Unfold Rgt in H2;
- Generalize (Rle_not eps R0 H2);Intro;Auto.
-Intro;Elim (H6 N);Intro;Unfold Rle.
-Left;Unfold Rgt in H7;Assumption.
-Right;Auto.
-Apply (H1 (Un n) (Un_in_EUn n)).
-Qed.
-
-(*********)
-Lemma finite_greater:(N:nat)(ExT [M:R] (n:nat)(le n N)->(Rle (Un n) M)).
-Intro;Induction N.
-Split with (Un O);Intros;Rewrite (le_n_O_eq n H); 
- Apply (eq_Rle (Un (n)) (Un (n)) (refl_eqT R (Un (n)))).
-Elim HrecN;Clear HrecN;Intros;Split with (Rmax (Un (S N)) x);Intros;
- Elim (Rmax_Rle (Un (S N)) x (Un n));Intros;Clear H1;Inversion H0.
-Rewrite <-H1;Rewrite <-H1 in H2;
- Apply (H2 (or_introl (Rle (Un n) (Un n)) (Rle (Un n) x) 
-    (eq_Rle (Un n) (Un n) (refl_eqT R (Un n))))).
-Apply (H2 (or_intror (Rle (Un n) (Un (S N))) (Rle (Un n) x) 
-    (H n H3))).
-Qed.
-
-(*********)
-Lemma cauchy_bound:Cauchy_crit->(bound EUn).
-Unfold Cauchy_crit bound;Intros;Unfold is_upper_bound;
- Unfold Rgt in H;Elim (H R1 Rlt_R0_R1);Clear H;Intros;
- Generalize (H x);Intro;Generalize (le_dec x);Intro;
- Elim (finite_greater x);Intros;Split with (Rmax x0 (Rplus (Un x) R1));
- Clear H;Intros;Unfold EUn in H;Elim H;Clear H;Intros;Elim (H1 x2);
- Clear H1;Intro y.
-Unfold ge in H0;Generalize (H0 x2 (le_n x) y);Clear H0;Intro;
- Rewrite <- H in H0;Unfold R_dist in H0;
- Elim (Rabsolu_def2 (Rminus (Un x) x1) R1 H0);Clear H0;Intros;
- Elim (Rmax_Rle x0 (Rplus (Un x) R1) x1);Intros;Apply H4;Clear H3 H4;
- Right;Clear H H0 y;Apply (Rlt_le x1 (Rplus (Un x) R1));
- Generalize (Rlt_minus (Ropp R1) (Rminus (Un x) x1) H1);Clear H1;
- Intro;Apply (Rminus_lt x1 (Rplus (Un x) R1));
- Cut (Rminus (Ropp R1) (Rminus (Un x) x1))==
-  (Rminus x1 (Rplus (Un x) R1));[Intro;Rewrite H0 in H;Assumption|Ring].
-Generalize (H2 x2 y);Clear H2 H0;Intro;Rewrite<-H in H0;
- Elim (Rmax_Rle x0 (Rplus (Un x) R1) x1);Intros;Clear H1;Apply H2;
- Left;Assumption.
-Qed.
-
-End sequence.
-
-(*****************************************************************)
-(*           Definition of Power Series and properties           *)
-(*                                                               *)
-(*****************************************************************)
-
-Section Isequence.
-
-(*********)
-Variable An:nat->R.
-
-(*********)
-Definition Pser:R->R->Prop:=[x,l:R]
-   (infinit_sum [n:nat](Rmult (An n) (pow x n)) l).
-
-End Isequence.
-
-Lemma GP_infinite:
- (x:R) (Rlt (Rabsolu x) R1) 
-       -> (Pser ([n:nat] R1) x (Rinv(Rminus R1 x))).
-Intros;Unfold Pser; Unfold infinit_sum;Intros;Elim (Req_EM x R0).
-Intros;Exists O; Intros;Rewrite H1;Rewrite minus_R0;Rewrite Rinv_R1;
-  Cut (sum_f_R0 [n0:nat](Rmult R1 (pow R0 n0)) n)==R1.
-Intros; Rewrite H3;Rewrite R_dist_eq;Auto.
-Elim n; Simpl.
-Ring.
-Intros;Rewrite H3;Ring.
-Intro;Cut (Rlt R0
-      (Rmult eps (Rmult (Rabsolu (Rminus R1 x)) 
-                        (Rabsolu (Rinv x))))).
-Intro;Elim (pow_lt_1_zero x H
-                    (Rmult eps (Rmult (Rabsolu (Rminus R1 x))
-                                 (Rabsolu (Rinv x))))
-                    H2);Intro N; Intros;Exists N; Intros;
-  Cut (sum_f_R0 [n0:nat](Rmult R1 (pow x n0)) n)==
-    (sum_f_R0 [n0:nat](pow x n0) n).
-Intros; Rewrite H5;Apply (Rlt_monotony_rev
-         (Rabsolu (Rminus R1 x))
-         (R_dist (sum_f_R0 [n0:nat](pow x n0) n) 
-                 (Rinv (Rminus R1 x))) 
-         eps).
-Apply Rabsolu_pos_lt.
-Apply Rminus_eq_contra.
-Apply imp_not_Req.
-Right; Unfold Rgt.
-Apply (Rle_lt_trans x (Rabsolu x) R1).
-Apply Rle_Rabsolu.
-Assumption.
-Unfold R_dist; Rewrite <- Rabsolu_mult.
-Rewrite Rminus_distr.
-Cut (Rmult (Rminus R1 x) (sum_f_R0 [n0:nat](pow x n0) n))==
-    (Ropp (Rmult(sum_f_R0 [n0:nat](pow x n0) n) 
-          (Rminus x R1))).
-Intro; Rewrite H6.
-Rewrite GP_finite.
-Rewrite Rinv_r.
-Cut (Rminus (Ropp (Rminus (pow x (plus n (1))) R1)) R1)==
-    (Ropp (pow x (plus n (1)))).
-Intro; Rewrite H7.
-Rewrite Rabsolu_Ropp;Cut (plus n (S O))=(S n);Auto.
-Intro H8;Rewrite H8;Simpl;Rewrite Rabsolu_mult;
-  Apply (Rlt_le_trans (Rmult (Rabsolu x) (Rabsolu (pow x n)))
-                    (Rmult (Rabsolu x)
-                           (Rmult eps
-                              (Rmult (Rabsolu (Rminus R1 x)) 
-                                      (Rabsolu (Rinv x)))))
-                 (Rmult (Rabsolu (Rminus R1 x)) eps)).
-Apply Rlt_monotony.
-Apply Rabsolu_pos_lt.
-Assumption.
-Auto.
-Cut (Rmult (Rabsolu x)
-           (Rmult eps (Rmult (Rabsolu (Rminus R1 x)) 
-                             (Rabsolu (Rinv x)))))==
-    (Rmult (Rmult (Rabsolu x) (Rabsolu (Rinv x))) 
-           (Rmult eps (Rabsolu (Rminus R1 x)))).
-Clear H8;Intros; Rewrite H8;Rewrite <- Rabsolu_mult;Rewrite Rinv_r.  
-Rewrite Rabsolu_R1;Cut (Rmult R1 (Rmult eps (Rabsolu (Rminus R1 x))))==
-    (Rmult (Rabsolu (Rminus R1 x)) eps).
-Intros; Rewrite H9;Unfold Rle; Right; Reflexivity.
-Ring.
-Assumption.
-Ring.
-Ring.
-Ring.
-Apply Rminus_eq_contra.
-Apply imp_not_Req.
-Right; Unfold Rgt.
-Apply (Rle_lt_trans x (Rabsolu x) R1).
-Apply Rle_Rabsolu.
-Assumption.
-Ring; Ring.
-Elim n; Simpl.
-Ring.
-Intros; Rewrite H5.
-Ring.
-Apply Rmult_lt_pos.
-Auto.
-Apply Rmult_lt_pos.
-Apply Rabsolu_pos_lt.
-Apply Rminus_eq_contra.
-Apply imp_not_Req.
-Right; Unfold Rgt.
-Apply (Rle_lt_trans x (Rabsolu x) R1).
-Apply Rle_Rabsolu.
-Assumption.
-Apply Rabsolu_pos_lt.
-Apply Rinv_neq_R0.
-Assumption.
-Qed.
diff --git a/theories7/Reals/Rsigma.v b/theories7/Reals/Rsigma.v
deleted file mode 100644
index f9e8e92b..00000000
--- a/theories7/Reals/Rsigma.v
+++ /dev/null
@@ -1,117 +0,0 @@
-(************************************************************************)
-(*  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: Rsigma.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rseries.
-Require PartSum.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Set Implicit Arguments.
-
-Section Sigma.
-
-Variable f : nat->R.
-
-Definition sigma [low,high:nat] : R := (sum_f_R0 [k:nat](f (plus low k)) (minus high low)).
-
-Theorem sigma_split : (low,high,k:nat) (le low k)->(lt k high)->``(sigma low high)==(sigma low k)+(sigma (S k) high)``.
-Intros; Induction k.
-Cut low = O.
-Intro; Rewrite H1; Unfold sigma; Rewrite <- minus_n_n; Rewrite <- minus_n_O; Simpl; Replace (minus high (S O)) with (pred high).
-Apply (decomp_sum [k:nat](f k)).
-Assumption.
-Apply pred_of_minus.
-Inversion H; Reflexivity.
-Cut (le low k)\/low=(S k).
-Intro; Elim H1; Intro.
-Replace (sigma low (S k)) with ``(sigma low k)+(f (S k))``.
-Rewrite Rplus_assoc; Replace ``(f (S k))+(sigma (S (S k)) high)`` with (sigma (S k) high).
-Apply Hreck.
-Assumption.
-Apply lt_trans with (S k); [Apply lt_n_Sn | Assumption].
-Unfold sigma; Replace (minus high (S (S k))) with (pred (minus high (S k))).
-Pattern 3 (S k); Replace (S k) with (plus (S k) O); [Idtac | Ring].
-Replace (sum_f_R0 [k0:nat](f (plus (S (S k)) k0)) (pred (minus high (S k)))) with (sum_f_R0 [k0:nat](f (plus (S k) (S k0))) (pred (minus high (S k)))).
-Apply (decomp_sum [i:nat](f (plus (S k) i))).
-Apply lt_minus_O_lt; Assumption.
-Apply sum_eq; Intros; Replace (plus (S k) (S i)) with (plus (S (S k)) i).
-Reflexivity.
-Apply INR_eq; Do 2 Rewrite plus_INR; Do 3 Rewrite S_INR; Ring.
-Replace (minus high (S (S k))) with (minus (minus high (S k)) (S O)).
-Apply pred_of_minus.
-Apply INR_eq; Repeat  Rewrite minus_INR.
-Do 4 Rewrite S_INR; Ring.
-Apply lt_le_S; Assumption.
-Apply lt_le_weak; Assumption.
-Apply lt_le_S; Apply lt_minus_O_lt; Assumption.
-Unfold sigma; Replace (minus (S k) low) with (S (minus k low)).
-Pattern 1 (S k); Replace (S k) with (plus low (S (minus k low))).
-Symmetry; Apply (tech5 [i:nat](f (plus low i))).
-Apply INR_eq; Rewrite plus_INR; Do 2 Rewrite S_INR; Rewrite minus_INR.
-Ring.
-Assumption.
-Apply minus_Sn_m; Assumption.
-Rewrite <- H2; Unfold sigma; Rewrite <- minus_n_n; Simpl; Replace (minus high (S low)) with (pred (minus high low)).
-Replace (sum_f_R0 [k0:nat](f (S (plus low k0))) (pred (minus high low))) with (sum_f_R0 [k0:nat](f (plus low (S k0))) (pred (minus high low))).
-Apply (decomp_sum [k0:nat](f (plus low k0))).
-Apply lt_minus_O_lt.
-Apply le_lt_trans with (S k); [Rewrite H2; Apply le_n | Assumption].
-Apply sum_eq; Intros; Replace (S (plus low i)) with (plus low (S i)).
-Reflexivity.
-Apply INR_eq; Rewrite plus_INR; Do 2 Rewrite S_INR; Rewrite plus_INR; Ring.
-Replace (minus high (S low)) with (minus (minus high low) (S O)).
-Apply pred_of_minus.
-Apply INR_eq; Repeat  Rewrite minus_INR.
-Do 2 Rewrite S_INR; Ring.
-Apply lt_le_S; Rewrite H2; Assumption.
-Rewrite H2; Apply lt_le_weak; Assumption.
-Apply lt_le_S; Apply lt_minus_O_lt; Rewrite H2; Assumption.
-Inversion H; [
-  Right; Reflexivity
-| Left; Assumption].
-Qed.
-
-Theorem sigma_diff : (low,high,k:nat) (le low k) -> (lt k high )->``(sigma low high)-(sigma low k)==(sigma (S k) high)``.
-Intros low high k H1 H2; Symmetry; Rewrite -> (sigma_split H1 H2); Ring.
-Qed.
-
-Theorem sigma_diff_neg : (low,high,k:nat) (le low k) -> (lt k high)-> ``(sigma low k)-(sigma low high)==-(sigma (S k) high)``.
-Intros low high k H1 H2; Rewrite -> (sigma_split H1 H2); Ring.
-Qed.
-
-Theorem sigma_first : (low,high:nat) (lt low high) -> ``(sigma low high)==(f low)+(sigma (S low) high)``.
-Intros low high H1; Generalize (lt_le_S low high H1); Intro H2; Generalize (lt_le_weak low high H1); Intro H3; Replace ``(f low)`` with ``(sigma low low)``.
-Apply sigma_split.
-Apply le_n.
-Assumption.
-Unfold sigma; Rewrite <- minus_n_n.
-Simpl.
-Replace (plus low O) with low; [Reflexivity | Ring].
-Qed.
-
-Theorem sigma_last : (low,high:nat) (lt low high) -> ``(sigma low high)==(f high)+(sigma low (pred high))``.
-Intros low high H1; Generalize (lt_le_S low high H1); Intro H2; Generalize (lt_le_weak low high H1); Intro H3; Replace ``(f high)`` with ``(sigma high high)``.
-Rewrite Rplus_sym; Cut high = (S (pred high)).
-Intro; Pattern 3 high; Rewrite H.
-Apply sigma_split.
-Apply le_S_n; Rewrite <- H; Apply lt_le_S; Assumption.
-Apply lt_pred_n_n; Apply le_lt_trans with low; [Apply le_O_n | Assumption].
-Apply S_pred with O; Apply le_lt_trans with low; [Apply le_O_n | Assumption].
-Unfold sigma; Rewrite <- minus_n_n; Simpl; Replace (plus high O) with high; [Reflexivity | Ring].
-Qed.
-
-Theorem sigma_eq_arg : (low:nat) (sigma low low)==(f low).
-Intro; Unfold sigma; Rewrite <- minus_n_n.
-Simpl; Replace (plus low O) with low; [Reflexivity | Ring].
-Qed.
-
-End Sigma.
diff --git a/theories7/Reals/Rsqrt_def.v b/theories7/Reals/Rsqrt_def.v
deleted file mode 100644
index 17367dce..00000000
--- a/theories7/Reals/Rsqrt_def.v
+++ /dev/null
@@ -1,688 +0,0 @@
-(************************************************************************)
-(*  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: Rsqrt_def.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-Require Sumbool.
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Ranalysis1.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Fixpoint Dichotomy_lb [x,y:R;P:R->bool;N:nat] : R :=
-Cases N of 
-  O => x
-| (S n) => let down = (Dichotomy_lb x y P n) in let up = (Dichotomy_ub x y P n) in let z = ``(down+up)/2``  in if (P z) then down else z
-end
-with Dichotomy_ub [x,y:R;P:R->bool;N:nat] : R :=
-Cases N of 
-  O => y
-| (S n) => let down = (Dichotomy_lb x y P n) in let up = (Dichotomy_ub x y P n) in let z = ``(down+up)/2``  in if (P z) then z else up
-end.
-
-Definition dicho_lb [x,y:R;P:R->bool] : nat->R := [N:nat](Dichotomy_lb x y P N).
-Definition dicho_up [x,y:R;P:R->bool] : nat->R := [N:nat](Dichotomy_ub x y P N).
-
-(**********)
-Lemma dicho_comp : (x,y:R;P:R->bool;n:nat) ``x<=y`` -> ``(dicho_lb x y P n)<=(dicho_up x y P n)``.
-Intros.
-Induction n.
-Simpl; Assumption.
-Simpl.
-Case (P ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))/2``).
-Unfold Rdiv; Apply Rle_monotony_contra with ``2``.
-Sup0.
-Pattern 1 ``2``; Rewrite Rmult_sym.
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR].
-Rewrite Rmult_1r.
-Rewrite double.
-Apply Rle_compatibility.
-Assumption.
-Unfold Rdiv; Apply Rle_monotony_contra with ``2``.
-Sup0.
-Pattern 3 ``2``; Rewrite Rmult_sym.
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR].
-Rewrite Rmult_1r.
-Rewrite double.
-Rewrite <- (Rplus_sym (Dichotomy_ub x y P n)).
-Apply Rle_compatibility.
-Assumption.
-Qed.
-
-Lemma dicho_lb_growing : (x,y:R;P:R->bool) ``x<=y`` -> (Un_growing (dicho_lb x y P)).
-Intros.
-Unfold Un_growing.
-Intro.
-Simpl.
-Case (P ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))/2``).
-Right; Reflexivity.
-Unfold Rdiv; Apply Rle_monotony_contra with ``2``.
-Sup0.
-Pattern 1 ``2``; Rewrite Rmult_sym.
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR].
-Rewrite Rmult_1r.
-Rewrite double.
-Apply Rle_compatibility.
-Replace (Dichotomy_ub x y P n) with (dicho_up x y P n); [Apply dicho_comp; Assumption | Reflexivity].
-Qed.
-
-Lemma dicho_up_decreasing : (x,y:R;P:R->bool) ``x<=y`` -> (Un_decreasing (dicho_up x y P)).
-Intros.
-Unfold Un_decreasing.
-Intro.
-Simpl.
-Case (P ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))/2``).
-Unfold Rdiv; Apply Rle_monotony_contra with ``2``.
-Sup0.
-Pattern 3 ``2``; Rewrite Rmult_sym.
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR].
-Rewrite Rmult_1r.
-Rewrite double.
-Replace (Dichotomy_ub x y P n) with (dicho_up x y P n); [Idtac | Reflexivity].
-Replace (Dichotomy_lb x y P n) with (dicho_lb x y P n); [Idtac | Reflexivity].
-Rewrite <- (Rplus_sym ``(dicho_up x y P n)``).
-Apply Rle_compatibility.
-Apply dicho_comp; Assumption.
-Right; Reflexivity.
-Qed.
-
-Lemma dicho_lb_maj_y : (x,y:R;P:R->bool) ``x<=y`` -> (n:nat)``(dicho_lb x y P n)<=y``.
-Intros.
-Induction n.
-Simpl; Assumption.
-Simpl.
-Case (P ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))/2``).
-Assumption.
-Unfold Rdiv; Apply Rle_monotony_contra with ``2``.
-Sup0.
-Pattern 3 ``2``; Rewrite Rmult_sym.
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Rewrite Rmult_1r | DiscrR].
-Rewrite double; Apply Rplus_le.
-Assumption.
-Pattern 2 y; Replace y with (Dichotomy_ub x y P O); [Idtac | Reflexivity].
-Apply decreasing_prop.
-Assert H0 := (dicho_up_decreasing x y P H).
-Assumption.
-Apply le_O_n.
-Qed.
-
-Lemma dicho_lb_maj : (x,y:R;P:R->bool) ``x<=y`` -> (has_ub (dicho_lb x y P)).
-Intros.
-Cut (n:nat)``(dicho_lb x y P n)<=y``.
-Intro.
-Unfold has_ub.
-Unfold bound.
-Exists y.
-Unfold is_upper_bound.
-Intros.
-Elim H1; Intros.
-Rewrite H2; Apply H0.
-Apply dicho_lb_maj_y; Assumption.
-Qed.
-
-Lemma dicho_up_min_x : (x,y:R;P:R->bool) ``x<=y`` -> (n:nat)``x<=(dicho_up x y P n)``.
-Intros.
-Induction n.
-Simpl; Assumption.
-Simpl.
-Case (P ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))/2``).
-Unfold Rdiv; Apply Rle_monotony_contra with ``2``.
-Sup0.
-Pattern 1 ``2``; Rewrite Rmult_sym.
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Rewrite Rmult_1r | DiscrR].
-Rewrite double; Apply Rplus_le.
-Pattern 1 x; Replace x with (Dichotomy_lb x y P O); [Idtac | Reflexivity].
-Apply tech9.
-Assert H0 := (dicho_lb_growing x y P H).
-Assumption.
-Apply le_O_n.
-Assumption.
-Assumption.
-Qed.
-
-Lemma dicho_up_min : (x,y:R;P:R->bool) ``x<=y`` -> (has_lb (dicho_up x y P)).
-Intros.
-Cut (n:nat)``x<=(dicho_up x y P n)``.
-Intro.
-Unfold has_lb.
-Unfold bound.
-Exists ``-x``.
-Unfold is_upper_bound.
-Intros.
-Elim H1; Intros.
-Rewrite H2.
-Unfold opp_seq.
-Apply Rle_Ropp1.
-Apply H0.
-Apply dicho_up_min_x; Assumption.
-Qed.
-
-Lemma dicho_lb_cv : (x,y:R;P:R->bool) ``x<=y`` -> (sigTT R [l:R](Un_cv (dicho_lb x y P) l)).
-Intros.
-Apply growing_cv.
-Apply dicho_lb_growing; Assumption.
-Apply dicho_lb_maj; Assumption.
-Qed.
-
-Lemma dicho_up_cv : (x,y:R;P:R->bool) ``x<=y`` -> (sigTT R [l:R](Un_cv (dicho_up x y P) l)).
-Intros.
-Apply decreasing_cv.
-Apply dicho_up_decreasing; Assumption.
-Apply dicho_up_min; Assumption.
-Qed.
-
-Lemma dicho_lb_dicho_up : (x,y:R;P:R->bool;n:nat) ``x<=y`` -> ``(dicho_up x y P n)-(dicho_lb x y P n)==(y-x)/(pow 2 n)``.
-Intros.
-Induction n.
-Simpl.
-Unfold Rdiv; Rewrite Rinv_R1; Ring.
-Simpl.
-Case (P ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))/2``).
-Unfold Rdiv.
-Replace ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))*/2-
-   (Dichotomy_lb x y P n)`` with ``((dicho_up x y P n)-(dicho_lb x y P n))/2``.
-Unfold Rdiv; Rewrite Hrecn.
-Unfold Rdiv.
-Rewrite Rinv_Rmult.
-Ring.
-DiscrR.
-Apply pow_nonzero; DiscrR.
-Pattern 2 (Dichotomy_lb x y P n); Rewrite (double_var (Dichotomy_lb x y P n)); Unfold dicho_up dicho_lb Rminus Rdiv; Ring.
-Replace ``(Dichotomy_ub x y P n)-((Dichotomy_lb x y P n)+
-   (Dichotomy_ub x y P n))/2`` with ``((dicho_up x y P n)-(dicho_lb x y P n))/2``.
-Unfold Rdiv; Rewrite Hrecn.
-Unfold Rdiv.
-Rewrite Rinv_Rmult.
-Ring.
-DiscrR.
-Apply pow_nonzero; DiscrR.
-Pattern 1 (Dichotomy_ub x y P n); Rewrite (double_var (Dichotomy_ub x y P n)); Unfold dicho_up dicho_lb Rminus Rdiv; Ring.
-Qed.
-
-Definition pow_2_n := [n:nat](pow ``2`` n).
-
-Lemma pow_2_n_neq_R0 : (n:nat) ``(pow_2_n n)<>0``.
-Intro.
-Unfold pow_2_n.
-Apply pow_nonzero.
-DiscrR.
-Qed.
-
-Lemma pow_2_n_growing : (Un_growing pow_2_n).
-Unfold Un_growing.
-Intro.
-Replace (S n) with (plus n (1)); [Unfold pow_2_n; Rewrite pow_add | Ring].
-Pattern 1 (pow ``2`` n); Rewrite <- Rmult_1r.
-Apply Rle_monotony.
-Left; Apply pow_lt; Sup0.
-Simpl.
-Rewrite Rmult_1r.
-Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Apply Rlt_R0_R1.
-Qed.
-
-Lemma pow_2_n_infty : (cv_infty pow_2_n).
-Cut (N:nat)``(INR N)<=(pow 2 N)``.
-Intros.
-Unfold cv_infty.
-Intro.
-Case (total_order_T R0 M); Intro.
-Elim s; Intro.
-Pose N := (up M).
-Cut `0<=N`.
-Intro.
-Elim (IZN N H0); Intros N0 H1.
-Exists N0.
-Intros.
-Apply Rlt_le_trans with (INR N0).
-Rewrite INR_IZR_INZ.
-Rewrite <- H1.
-Unfold N.
-Assert H3 := (archimed M).
-Elim H3; Intros; Assumption.
-Apply Rle_trans with (pow_2_n N0).
-Unfold pow_2_n; Apply H.
-Apply Rle_sym2.
-Apply growing_prop.
-Apply pow_2_n_growing.
-Assumption.
-Apply le_IZR.
-Unfold N.
-Simpl.
-Assert H0 := (archimed M); Elim H0; Intros.
-Left; Apply Rlt_trans with M; Assumption.
-Exists O; Intros.
-Rewrite <- b.
-Unfold pow_2_n; Apply pow_lt; Sup0.
-Exists O; Intros.
-Apply Rlt_trans with R0.
-Assumption.
-Unfold pow_2_n; Apply pow_lt; Sup0.
-Induction N.
-Simpl.
-Left; Apply Rlt_R0_R1.
-Intros.
-Pattern 2 (S n); Replace (S n) with (plus n (1)); [Idtac | Ring].
-Rewrite S_INR; Rewrite pow_add.
-Simpl.
-Rewrite Rmult_1r.
-Apply Rle_trans with ``(pow 2 n)``.
-Rewrite <- (Rplus_sym R1).
-Rewrite <- (Rmult_1r (INR n)).
-Apply (poly n R1).
-Apply Rlt_R0_R1.
-Pattern 1 (pow ``2`` n); Rewrite <- Rplus_Or.
-Rewrite <- (Rmult_sym ``2``).
-Rewrite double.
-Apply Rle_compatibility.
-Left; Apply pow_lt; Sup0.
-Qed.
-
-Lemma cv_dicho : (x,y,l1,l2:R;P:R->bool) ``x<=y`` -> (Un_cv (dicho_lb x y P) l1) -> (Un_cv (dicho_up x y P) l2) -> l1==l2.
-Intros.
-Assert H2 := (CV_minus ? ? ? ? H0 H1).
-Cut (Un_cv [i:nat]``(dicho_lb x y P i)-(dicho_up x y P i)`` R0).
-Intro.
-Assert H4 := (UL_sequence ? ? ? H2 H3).
-Symmetry; Apply Rminus_eq_right; Assumption.
-Unfold Un_cv; Unfold R_dist.
-Intros.
-Assert H4 := (cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
-Case (total_order_T x y); Intro.
-Elim s; Intro.
-Unfold Un_cv in H4; Unfold R_dist in H4.
-Cut ``0<y-x``.
-Intro Hyp.
-Cut ``0<eps/(y-x)``.
-Intro.
-Elim (H4 ``eps/(y-x)`` H5); Intros N H6.
-Exists N; Intros.
-Replace ``(dicho_lb x y P n)-(dicho_up x y P n)-0`` with ``(dicho_lb x y P n)-(dicho_up x y P n)``; [Idtac | Ring].
-Rewrite <- Rabsolu_Ropp.
-Rewrite Ropp_distr3.
-Rewrite dicho_lb_dicho_up.
-Unfold Rdiv; Rewrite Rabsolu_mult.
-Rewrite (Rabsolu_right ``y-x``).
-Apply Rlt_monotony_contra with ``/(y-x)``.
-Apply Rlt_Rinv; Assumption.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Replace ``/(pow 2 n)`` with ``/(pow 2 n)-0``; [Unfold pow_2_n Rdiv in H6; Rewrite <- (Rmult_sym eps); Apply H6; Assumption | Ring].
-Red; Intro; Rewrite H8 in Hyp; Elim (Rlt_antirefl ? Hyp).
-Apply Rle_sym1.
-Apply Rle_anti_compatibility with x; Rewrite Rplus_Or.
-Replace ``x+(y-x)`` with y; [Assumption | Ring].
-Assumption.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Assumption].
-Apply Rlt_anti_compatibility with x; Rewrite Rplus_Or.
-Replace ``x+(y-x)`` with y; [Assumption | Ring].
-Exists O; Intros.
-Replace ``(dicho_lb x y P n)-(dicho_up x y P n)-0`` with ``(dicho_lb x y P n)-(dicho_up x y P n)``; [Idtac | Ring].
-Rewrite <- Rabsolu_Ropp.
-Rewrite Ropp_distr3.
-Rewrite dicho_lb_dicho_up.
-Rewrite b.
-Unfold Rminus Rdiv; Rewrite Rplus_Ropp_r; Rewrite Rmult_Ol; Rewrite Rabsolu_R0; Assumption.
-Assumption.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H r)).
-Qed.
-
-Definition cond_positivity [x:R] : bool := Cases (total_order_Rle R0 x) of 
-  (leftT _) => true 
-| (rightT _) => false end.
-
-(* Sequential caracterisation of continuity *)
-Lemma continuity_seq : (f:R->R;Un:nat->R;l:R) (continuity_pt f l) -> (Un_cv Un l) -> (Un_cv [i:nat](f (Un i)) (f l)).
-Unfold continuity_pt Un_cv; Unfold continue_in.
-Unfold limit1_in.
-Unfold limit_in.
-Unfold dist.
-Simpl.
-Unfold R_dist.
-Intros.
-Elim (H eps H1); Intros alp H2.
-Elim H2; Intros.
-Elim (H0 alp H3); Intros N H5.
-Exists N; Intros.
-Case (Req_EM (Un n) l); Intro.
-Rewrite H7; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Apply H4.
-Split.
-Unfold D_x no_cond.
-Split.
-Trivial.
-Apply not_sym; Assumption.
-Apply H5; Assumption.
-Qed.
-
-Lemma dicho_lb_car : (x,y:R;P:R->bool;n:nat) (P x)=false -> (P (dicho_lb x y P n))=false.
-Intros.
-Induction n.
-Simpl.
-Assumption.
-Simpl.
-Assert X := (sumbool_of_bool (P ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))/2``)).
-Elim X; Intro.
-Rewrite a.
-Unfold dicho_lb in Hrecn; Assumption.
-Rewrite b.
-Assumption.
-Qed.
-
-Lemma dicho_up_car : (x,y:R;P:R->bool;n:nat) (P y)=true -> (P (dicho_up x y P n))=true.
-Intros.
-Induction n.
-Simpl.
-Assumption.
-Simpl.
-Assert X := (sumbool_of_bool (P ``((Dichotomy_lb x y P n)+(Dichotomy_ub x y P n))/2``)).
-Elim X; Intro.
-Rewrite a.
-Unfold dicho_lb in Hrecn; Assumption.
-Rewrite b.
-Assumption.
-Qed.
-
-(* Intermediate Value Theorem *)
-Lemma IVT : (f:R->R;x,y:R) (continuity f) -> ``x<y`` -> ``(f x)<0`` -> ``0<(f y)`` -> (sigTT R [z:R]``x<=z<=y``/\``(f z)==0``).
-Intros.
-Cut ``x<=y``.
-Intro.
-Generalize (dicho_lb_cv x y [z:R](cond_positivity (f z)) H3). 
-Generalize (dicho_up_cv x y [z:R](cond_positivity (f z)) H3). 
-Intros.
-Elim X; Intros.
-Elim X0; Intros.
-Assert H4 := (cv_dicho ? ? ? ? ? H3 p0 p).
-Rewrite H4 in p0.
-Apply existTT with x0.
-Split.
-Split.
-Apply Rle_trans with (dicho_lb x y [z:R](cond_positivity (f z)) O).
-Simpl.
-Right; Reflexivity.
-Apply growing_ineq.
-Apply dicho_lb_growing; Assumption.
-Assumption.
-Apply Rle_trans with (dicho_up x y [z:R](cond_positivity (f z)) O).
-Apply decreasing_ineq.
-Apply dicho_up_decreasing; Assumption.
-Assumption.
-Right; Reflexivity.
-2:Left; Assumption.
-Pose Vn := [n:nat](dicho_lb x y [z:R](cond_positivity (f z)) n).
-Pose Wn := [n:nat](dicho_up x y [z:R](cond_positivity (f z)) n).
-Cut ((n:nat)``(f (Vn n))<=0``)->``(f x0)<=0``.
-Cut ((n:nat)``0<=(f (Wn n))``)->``0<=(f x0)``.
-Intros.
-Cut (n:nat)``(f (Vn n))<=0``.
-Cut (n:nat)``0<=(f (Wn n))``.
-Intros.
-Assert H9 := (H6 H8).
-Assert H10 := (H5 H7).
-Apply Rle_antisym; Assumption.
-Intro.
-Unfold Wn.
-Cut (z:R) (cond_positivity z)=true <-> ``0<=z``.
-Intro.
-Assert H8 := (dicho_up_car x y [z:R](cond_positivity (f z)) n).
-Elim (H7 (f (dicho_up x y [z:R](cond_positivity (f z)) n))); Intros.
-Apply H9.
-Apply H8.
-Elim (H7 (f y)); Intros.
-Apply H12.
-Left; Assumption.
-Intro.
-Unfold cond_positivity.
-Case (total_order_Rle R0 z); Intro.
-Split.
-Intro; Assumption.
-Intro; Reflexivity.
-Split.
-Intro; Elim diff_false_true; Assumption.
-Intro.
-Elim n0; Assumption.
-Unfold Vn.
-Cut (z:R) (cond_positivity z)=false <-> ``z<0``.
-Intros.
-Assert H8 := (dicho_lb_car x y [z:R](cond_positivity (f z)) n).
-Left.
-Elim (H7 (f (dicho_lb x y [z:R](cond_positivity (f z)) n))); Intros.
-Apply H9.
-Apply H8.
-Elim (H7 (f x)); Intros.
-Apply H12.
-Assumption.
-Intro.
-Unfold cond_positivity.
-Case (total_order_Rle R0 z); Intro.
-Split.
-Intro; Elim diff_true_false; Assumption.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H7)).
-Split.
-Intro; Auto with real.
-Intro; Reflexivity.
-Cut (Un_cv Wn x0).
-Intros.
-Assert H7 := (continuity_seq f Wn x0 (H x0) H5).
-Case (total_order_T R0 (f x0)); Intro.
-Elim s; Intro.
-Left; Assumption.
-Rewrite <- b; Right; Reflexivity.
-Unfold Un_cv in H7; Unfold R_dist in H7.
-Cut ``0< -(f x0)``.
-Intro.
-Elim (H7 ``-(f x0)`` H8); Intros.
-Cut (ge x2 x2); [Intro | Unfold ge; Apply le_n].
-Assert H11 := (H9 x2 H10).
-Rewrite Rabsolu_right in H11.
-Pattern 1 ``-(f x0)`` in H11; Rewrite <- Rplus_Or in H11.
-Unfold Rminus in H11; Rewrite (Rplus_sym (f (Wn x2))) in H11.
-Assert H12 := (Rlt_anti_compatibility ? ? ? H11).
-Assert H13 := (H6 x2).
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H13 H12)).
-Apply Rle_sym1; Left; Unfold Rminus; Apply ge0_plus_gt0_is_gt0.
-Apply H6.
-Exact H8.
-Apply Rgt_RO_Ropp; Assumption.
-Unfold Wn; Assumption.
-Cut (Un_cv Vn x0).
-Intros.
-Assert H7 := (continuity_seq f Vn x0 (H x0) H5).
-Case (total_order_T R0 (f x0)); Intro.
-Elim s; Intro.
-Unfold Un_cv in H7; Unfold R_dist in H7.
-Elim (H7 ``(f x0)`` a); Intros.
-Cut (ge x2 x2); [Intro | Unfold ge; Apply le_n].
-Assert H10 := (H8 x2 H9).
-Rewrite Rabsolu_left in H10.
-Pattern 2 ``(f x0)`` in H10; Rewrite <- Rplus_Or in H10.
-Rewrite Ropp_distr3 in H10.
-Unfold Rminus in H10.
-Assert H11 := (Rlt_anti_compatibility ? ? ? H10).
-Assert H12 := (H6 x2).
-Cut ``0<(f (Vn x2))``.
-Intro.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H13 H12)).
-Rewrite <- (Ropp_Ropp (f (Vn x2))).
-Apply Rgt_RO_Ropp; Assumption.
-Apply Rlt_anti_compatibility with ``(f x0)-(f (Vn x2))``.
-Rewrite Rplus_Or; Replace ``(f x0)-(f (Vn x2))+((f (Vn x2))-(f x0))`` with R0; [Unfold Rminus; Apply gt0_plus_ge0_is_gt0 | Ring].
-Assumption.
-Apply Rge_RO_Ropp; Apply Rle_sym1; Apply H6.
-Right; Rewrite <- b; Reflexivity.
-Left; Assumption.
-Unfold Vn; Assumption.
-Qed.
-
-Lemma IVT_cor : (f:R->R;x,y:R) (continuity f) -> ``x<=y`` -> ``(f x)*(f y)<=0`` -> (sigTT R [z:R]``x<=z<=y``/\``(f z)==0``).
-Intros.
-Case (total_order_T R0 (f x)); Intro.
-Case (total_order_T R0 (f y)); Intro.
-Elim s; Intro.
-Elim s0; Intro.
-Cut ``0<(f x)*(f y)``; [Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H1 H2)) | Apply Rmult_lt_pos; Assumption].
-Exists y.
-Split.
-Split; [Assumption | Right; Reflexivity].
-Symmetry; Exact b.
-Exists x.
-Split.
-Split; [Right; Reflexivity | Assumption].
-Symmetry; Exact b.
-Elim s; Intro.
-Cut ``x<y``.
-Intro.
-Assert H3 := (IVT (opp_fct f) x y (continuity_opp f H) H2).
-Cut ``(opp_fct f x)<0``.
-Cut ``0<(opp_fct f y)``.
-Intros.
-Elim (H3 H5 H4); Intros.
-Apply existTT with x0.
-Elim p; Intros.
-Split.
-Assumption.
-Unfold opp_fct in H7.
-Rewrite <- (Ropp_Ropp (f x0)).
-Apply eq_RoppO; Assumption.
-Unfold opp_fct; Apply Rgt_RO_Ropp; Assumption.
-Unfold opp_fct.
-Apply Rlt_anti_compatibility with (f x); Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Assumption.
-Inversion H0.
-Assumption.
-Rewrite H2 in a.
-Elim (Rlt_antirefl ? (Rlt_trans ? ? ? r a)).
-Apply existTT with x.
-Split.
-Split; [Right; Reflexivity | Assumption].
-Symmetry; Assumption.
-Case (total_order_T R0 (f y)); Intro.
-Elim s; Intro.
-Cut ``x<y``.
-Intro.
-Apply IVT; Assumption.
-Inversion H0.
-Assumption.
-Rewrite H2 in r.
-Elim (Rlt_antirefl ? (Rlt_trans ? ? ? r a)).
-Apply existTT with y.
-Split.
-Split; [Assumption | Right; Reflexivity].
-Symmetry; Assumption.
-Cut ``0<(f x)*(f y)``.
-Intro.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H2 H1)).
-Rewrite <- Ropp_mul2; Apply Rmult_lt_pos; Apply Rgt_RO_Ropp; Assumption.
-Qed.
-
-(* We can now define the square root function as the reciprocal transformation of the square root function *)
-Lemma Rsqrt_exists : (y:R) ``0<=y`` -> (sigTT R [z:R]``0<=z``/\``y==(Rsqr z)``).
-Intros.
-Pose f := [x:R]``(Rsqr x)-y``.
-Cut ``(f 0)<=0``.
-Intro.
-Cut (continuity f).
-Intro.
-Case (total_order_T y R1); Intro.
-Elim s; Intro.
-Cut ``0<=(f 1)``.
-Intro.
-Cut ``(f 0)*(f 1)<=0``.
-Intro.
-Assert X := (IVT_cor f R0 R1 H1 (Rlt_le ? ? Rlt_R0_R1) H3).
-Elim X; Intros t H4.
-Apply existTT with t.
-Elim H4; Intros.
-Split.
-Elim H5; Intros; Assumption.
-Unfold f in H6.
-Apply Rminus_eq_right; Exact H6.
-Rewrite Rmult_sym; Pattern 2 R0; Rewrite <- (Rmult_Or (f R1)).
-Apply Rle_monotony; Assumption.
-Unfold f.
-Rewrite Rsqr_1.
-Apply Rle_anti_compatibility with y.
-Rewrite Rplus_Or; Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Left; Assumption.
-Apply existTT with R1.
-Split.
-Left; Apply Rlt_R0_R1.
-Rewrite b; Symmetry; Apply Rsqr_1.
-Cut ``0<=(f y)``.
-Intro.
-Cut ``(f 0)*(f y)<=0``.
-Intro.
-Assert X := (IVT_cor f R0 y H1 H H3).
-Elim X; Intros t H4.
-Apply existTT with t.
-Elim H4; Intros.
-Split.
-Elim H5; Intros; Assumption.
-Unfold f in H6.
-Apply Rminus_eq_right; Exact H6.
-Rewrite Rmult_sym; Pattern 2 R0; Rewrite <- (Rmult_Or (f y)).
-Apply Rle_monotony; Assumption.
-Unfold f.
-Apply Rle_anti_compatibility with y.
-Rewrite Rplus_Or; Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or.
-Pattern 1 y; Rewrite <- Rmult_1r.
-Unfold Rsqr; Apply Rle_monotony.
-Assumption.
-Left; Exact r.
-Replace f with (minus_fct Rsqr (fct_cte y)).
-Apply continuity_minus.
-Apply derivable_continuous; Apply derivable_Rsqr.
-Apply derivable_continuous; Apply derivable_const.
-Reflexivity.
-Unfold f; Rewrite Rsqr_O.
-Unfold Rminus; Rewrite Rplus_Ol.
-Apply Rle_sym2.
-Apply Rle_RO_Ropp; Assumption.
-Qed.
-
-(* Definition of the square root: R+->R *)
-Definition Rsqrt [y:nonnegreal] : R := Cases (Rsqrt_exists (nonneg y) (cond_nonneg y)) of (existTT a b) => a end.
-
-(**********)
-Lemma Rsqrt_positivity : (x:nonnegreal) ``0<=(Rsqrt x)``.
-Intro.
-Assert X := (Rsqrt_exists (nonneg x) (cond_nonneg x)).
-Elim X; Intros.
-Cut x0==(Rsqrt x).
-Intros.
-Elim p; Intros.
-Rewrite H in H0; Assumption.
-Unfold Rsqrt.
-Case (Rsqrt_exists x (cond_nonneg x)).
-Intros.
-Elim p; Elim a; Intros.
-Apply Rsqr_inj.
-Assumption.
-Assumption.
-Rewrite <- H0; Rewrite <- H2; Reflexivity.
-Qed.
-
-(**********)
-Lemma Rsqrt_Rsqrt : (x:nonnegreal) ``(Rsqrt x)*(Rsqrt x)==x``.
-Intros.
-Assert X := (Rsqrt_exists (nonneg x) (cond_nonneg x)).
-Elim X; Intros.
-Cut x0==(Rsqrt x).
-Intros.
-Rewrite <- H.
-Elim p; Intros.
-Rewrite H1; Reflexivity.
-Unfold Rsqrt.
-Case (Rsqrt_exists x (cond_nonneg x)).
-Intros.
-Elim p; Elim a; Intros.
-Apply Rsqr_inj.
-Assumption.
-Assumption.
-Rewrite <- H0; Rewrite <- H2; Reflexivity.
-Qed.
diff --git a/theories7/Reals/Rsyntax.v b/theories7/Reals/Rsyntax.v
deleted file mode 100644
index 7b1b6266..00000000
--- a/theories7/Reals/Rsyntax.v
+++ /dev/null
@@ -1,236 +0,0 @@
-(************************************************************************)
-(*  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: Rsyntax.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-Require Export Rdefinitions.
-
-Axiom NRplus : R->R.
-Axiom NRmult : R->R.
-
-V7only[
-Grammar rnatural ident :=
-  nat_id [ prim:var($id) ] -> [$id]
-
-with rnegnumber : constr := 
-  neg_expr [ "-" rnumber ($c) ] -> [ (Ropp $c) ] 
-
-with rnumber :=
-
-with rformula : constr :=
-  form_expr [ rexpr($p) ] -> [ $p ]
-(* | form_eq [ rexpr($p) "==" rexpr($c) ] -> [ (eqT R $p $c) ] *)
-| form_eq [ rexpr($p) "==" rexpr($c) ] -> [ (eqT ? $p $c) ]
-| form_eq2 [ rexpr($p) "=" rexpr($c) ] -> [ (eqT ? $p $c) ]
-| form_le [ rexpr($p) "<=" rexpr($c) ] -> [ (Rle $p $c) ]
-| form_lt [ rexpr($p) "<" rexpr($c) ] -> [ (Rlt $p $c) ]
-| form_ge [ rexpr($p) ">=" rexpr($c) ] -> [ (Rge $p $c) ]
-| form_gt [ rexpr($p) ">" rexpr($c) ] -> [ (Rgt $p $c) ]
-(*
-| form_eq_eq [ rexpr($p) "==" rexpr($c) "==" rexpr($c1) ]
-              -> [ (eqT R $p $c)/\(eqT R $c $c1) ]
-*)
-| form_eq_eq [ rexpr($p) "==" rexpr($c) "==" rexpr($c1) ]
-              -> [ (eqT ? $p $c)/\(eqT ? $c $c1) ]
-| form_le_le [ rexpr($p) "<=" rexpr($c) "<=" rexpr($c1) ]
-              -> [ (Rle $p $c)/\(Rle $c $c1) ]
-| form_le_lt [ rexpr($p) "<=" rexpr($c) "<" rexpr($c1) ]
-              -> [ (Rle $p $c)/\(Rlt $c $c1) ]
-| form_lt_le [ rexpr($p) "<" rexpr($c) "<=" rexpr($c1) ]
-              -> [ (Rlt $p $c)/\(Rle $c $c1) ]
-| form_lt_lt [ rexpr($p) "<" rexpr($c) "<" rexpr($c1) ]
-              -> [ (Rlt $p $c)/\(Rlt $c $c1) ]
-| form_neq  [ rexpr($p) "<>" rexpr($c) ] -> [ ~(eqT ? $p $c) ]
-
-with rexpr : constr :=
-  expr_plus [ rexpr($p) "+" rexpr($c) ] -> [ (Rplus $p $c) ]
-| expr_minus [ rexpr($p) "-" rexpr($c) ] -> [ (Rminus $p $c) ]
-| rexpr2 [ rexpr2($e) ] -> [ $e ]
-
-with rexpr2 : constr :=
-  expr_mult [ rexpr2($p) "*" rexpr2($c) ] -> [ (Rmult $p $c) ]
-| rexpr0 [ rexpr0($e) ] -> [ $e ]
-
-
-with rexpr0 : constr :=
-  expr_id [ constr:global($c) ] -> [ $c ]
-| expr_com [ "[" constr:constr($c) "]" ] -> [ $c ]
-| expr_appl [ "(" rapplication($a) ")" ] -> [ $a ]
-| expr_num [ rnumber($s) ] -> [ $s ]
-| expr_negnum [ "-" rnegnumber($n) ] -> [ $n ]
-| expr_div [ rexpr0($p) "/" rexpr0($c) ] -> [ (Rdiv $p $c) ]
-| expr_opp [ "-" rexpr0($c) ] -> [ (Ropp $c) ] 
-| expr_inv [ "/" rexpr0($c) ] -> [ (Rinv $c) ]
-| expr_meta [ meta($m) ] -> [ $m ]
-
-with meta :=
-| rimpl [ "?" ] -> [ ? ]
-| rmeta0 [ "?" "0" ] -> [ ?0 ]
-| rmeta1 [ "?" "1" ] -> [ ?1 ]
-| rmeta2 [ "?" "2" ] -> [ ?2 ]
-| rmeta3 [ "?" "3" ] -> [ ?3 ]
-| rmeta4 [ "?" "4" ] -> [ ?4 ]
-| rmeta5 [ "?" "5" ] -> [ ?5 ]
-
-with rapplication : constr :=
-  apply [ rapplication($p) rexpr($c1) ] -> [ ($p $c1) ]
-| pair [ rexpr($p) "," rexpr($c) ] -> [ ($p, $c) ]
-| appl0 [ rexpr($a) ] -> [ $a ].
-
-Grammar constr constr0 :=
-  r_in_com [ "``" rnatural:rformula($c) "``" ] -> [ $c ].
-
-Grammar constr atomic_pattern :=
-  r_in_pattern [ "``" rnatural:rnumber($c) "``" ] -> [ $c ].   
-
-(*i* pp **)
-
-Syntax constr
-  level 0:
-   Rle [ (Rle $n1 $n2) ] -> 
-      [[<hov 0> "``" (REXPR $n1) [1 0] "<= " (REXPR $n2) "``"]]
-  | Rlt [ (Rlt $n1 $n2) ] -> 
-      [[<hov 0> "``" (REXPR $n1) [1 0] "< "(REXPR $n2) "``" ]]
-  | Rge [ (Rge $n1 $n2) ] -> 
-      [[<hov 0> "``" (REXPR $n1) [1 0] ">= "(REXPR $n2) "``" ]]
-  | Rgt [ (Rgt $n1 $n2) ] -> 
-      [[<hov 0> "``" (REXPR $n1) [1 0] "> "(REXPR $n2) "``" ]]
-  | Req [ (eqT R $n1 $n2) ] -> 
-      [[<hov 0> "``" (REXPR $n1) [1 0] "= "(REXPR $n2)"``"]]
-  | Rneq [ ~(eqT R $n1 $n2) ] ->
-      [[<hov 0> "``" (REXPR $n1) [1 0] "<> "(REXPR $n2) "``"]]
-  | Rle_Rle [ (Rle $n1 $n2)/\(Rle $n2 $n3) ] ->
-      [[<hov 0> "``" (REXPR $n1) [1 0] "<= " (REXPR $n2)
-                                [1 0] "<= " (REXPR $n3) "``"]]
-  | Rle_Rlt [ (Rle $n1 $n2)/\(Rlt $n2 $n3) ] ->
-      [[<hov 0> "``" (REXPR $n1) [1 0] "<= "(REXPR $n2)
-                                [1 0] "< " (REXPR $n3) "``"]]
-  | Rlt_Rle [ (Rlt $n1 $n2)/\(Rle $n2 $n3) ] ->
-      [[<hov 0> "``" (REXPR $n1) [1 0] "< " (REXPR $n2)
-                                [1 0] "<= " (REXPR $n3) "``"]]
-  | Rlt_Rlt [ (Rlt $n1 $n2)/\(Rlt $n2 $n3) ] ->
-      [[<hov 0> "``" (REXPR $n1) [1 0] "< " (REXPR $n2)
-                                [1 0] "< " (REXPR $n3) "``"]]
-  | Rzero [ R0 ] -> [ "``0``" ]
-  | Rone [ R1 ] -> [ "``1``" ]
-  ;
-
-  level 7:
-    Rplus [ (Rplus $n1 $n2) ]
-      -> [ [<hov 0> "``"(REXPR $n1):E "+"  [0 0] (REXPR $n2):L "``"] ]
-   | Rodd_outside [(Rplus R1 $r)] -> [ $r:"r_printer_odd_outside"]
-   | Rminus [ (Rminus $n1 $n2) ]
-      -> [ [<hov 0> "``"(REXPR $n1):E "-" [0 0] (REXPR $n2):L "``"] ]
-  ;
-
-  level 6:
-    Rmult [ (Rmult $n1 $n2) ]
-      -> [ [<hov 0> "``"(REXPR $n1):E "*" [0 0] (REXPR $n2):L "``"] ]
-    | Reven_outside [ (Rmult (Rplus R1 R1) $r) ] -> [ $r:"r_printer_even_outside"]
-    | Rdiv [ (Rdiv $n1 $n2) ]
-      -> [ [<hov 0> "``"(REXPR $n1):E "/" [0 0] (REXPR $n2):L "``"] ]
-  ;
-
-  level 8:
-    Ropp [(Ropp $n1)] -> [ [<hov 0> "``" "-"(REXPR $n1):E "``"] ]
-    | Rinv [(Rinv $n1)] -> [ [<hov 0> "``" "/"(REXPR $n1):E "``"] ]
-  ;
-
-  level 0:
-    rescape_inside [<< (REXPR $r) >>] -> [ "[" $r:E "]" ]
-  ;
-
-  level 4:
-    Rappl_inside [<<(REXPR (APPLIST $h ($LIST $t)))>>]
- -> [ [<hov 0> "("(REXPR $h):E [1 0] (RAPPLINSIDETAIL ($LIST $t)):E ")"] ]
-  | Rappl_inside_tail [<<(RAPPLINSIDETAIL $h ($LIST $t))>>]
-      -> [(REXPR $h):E [1 0] (RAPPLINSIDETAIL ($LIST $t)):E] 
-  | Rappl_inside_one [<<(RAPPLINSIDETAIL $e)>>] ->[(REXPR $e):E]
-  | rpair_inside [<<(REXPR <<(pair $s1 $s2 $r1 $r2)>>)>>] 
-      -> [ [<hov 0> "("(REXPR $r1):E "," [1 0] (REXPR $r2):E ")"] ]
-  ;
-
- level 3:
-    rvar_inside [<<(REXPR ($VAR $i))>>] -> [$i]
-  | rsecvar_inside [<<(REXPR (SECVAR $i))>>] -> [(SECVAR $i)]
-  | rconst_inside [<<(REXPR (CONST $c))>>] -> [(CONST $c)]
-  | rmutind_inside [<<(REXPR (MUTIND $i $n))>>] 
-      -> [(MUTIND $i $n)]
-  | rmutconstruct_inside [<<(REXPR (MUTCONSTRUCT $c1 $c2 $c3))>>]
-      -> [ (MUTCONSTRUCT $c1 $c2 $c3) ]
-  | rimplicit_head_inside [<<(REXPR (XTRA "!" $c))>>] -> [ $c ]
-  | rimplicit_arg_inside  [<<(REXPR (XTRA "!" $n $c))>>] -> [ ]
-
-  ;
-
-  
-  level 7:
-   Rplus_inside
-      [<<(REXPR <<(Rplus $n1 $n2)>>)>>]
-      	 -> [ (REXPR $n1):E "+" [0 0] (REXPR $n2):L ]
-  | Rminus_inside
-      [<<(REXPR <<(Rminus $n1 $n2)>>)>>]
-      	 -> [ (REXPR $n1):E "-" [0 0] (REXPR $n2):L ]
-  | NRplus_inside
-      [<<(REXPR <<(NRplus $r)>>)>>] -> [ "(" "1" "+" (REXPR $r):L ")"]
-  ;
-
-  level 6:
-    Rmult_inside
-      [<<(REXPR <<(Rmult $n1 $n2)>>)>>]
-      	 -> [ (REXPR $n1):E "*" (REXPR $n2):L ]
-  |  NRmult_inside
-      [<<(REXPR <<(NRmult $r)>>)>>] -> [ "(" "2" "*" (REXPR $r):L ")"]
-  ;
-
-  level 5:
-    Ropp_inside [<<(REXPR <<(Ropp $n1)>>)>>] -> [ " -" (REXPR $n1):E  ]
-  | Rinv_inside [<<(REXPR <<(Rinv $n1)>>)>>] -> [ "/" (REXPR $n1):E  ]
-  | Rdiv_inside
-      [<<(REXPR <<(Rdiv $n1 $n2)>>)>>]
-      	 -> [ (REXPR $n1):E "/" [0 0] (REXPR $n2):L ]
-  ;  
-
-  level 0:
-    Rzero_inside [<<(REXPR <<R0>>)>>] -> ["0"]
-  | Rone_inside [<<(REXPR <<R1>>)>>] -> ["1"]
-  | Rodd_inside [<<(REXPR <<(Rplus R1 $r)>>)>>] -> [ $r:"r_printer_odd" ]
-  | Reven_inside [<<(REXPR <<(Rmult (Rplus R1 R1) $r)>>)>>] -> [ $r:"r_printer_even" ]
-.
-
-(* For parsing/printing based on scopes *)
-Module R_scope.
-
-Infix "<=" Rle (at level 5, no associativity) : R_scope V8only.
-Infix "<"  Rlt (at level 5, no associativity) : R_scope V8only.
-Infix ">=" Rge (at level 5, no associativity) : R_scope V8only.
-Infix ">" Rgt (at level 5, no associativity) : R_scope V8only.
-Infix "+" Rplus (at level 4) : R_scope V8only.
-Infix "-" Rminus (at level 4) : R_scope V8only.
-Infix "*" Rmult (at level 3) : R_scope V8only.
-Infix "/" Rdiv (at level 3) : R_scope V8only.
-Notation "- x" := (Ropp x) (at level 0) : R_scope V8only.
-Notation "x == y == z" := (eqT R x y)/\(eqT R y z)
-  (at level 5, y at level 4, no associtivity): R_scope.
-Notation "x <= y <= z" := (Rle x y)/\(Rle y z)
-  (at level 5, y at level 4) : R_scope
-  V8only.
-Notation "x <= y < z" := (Rle x y)/\(Rlt y z)
-  (at level 5, y at level 4) : R_scope
-  V8only.
-Notation "x < y < z" := (Rlt x y)/\(Rlt y z)
-  (at level 5, y at level 4) : R_scope
-  V8only.
-Notation "x < y <= z" := (Rlt x y)/\(Rle y z)
-  (at level 5, y at level 4) : R_scope
-  V8only.
-Notation "/ x" := (Rinv x) (at level 0): R_scope
-  V8only.
-
-Open Local Scope R_scope.
-End R_scope.
-].
diff --git a/theories7/Reals/Rtopology.v b/theories7/Reals/Rtopology.v
deleted file mode 100644
index f2ae19b9..00000000
--- a/theories7/Reals/Rtopology.v
+++ /dev/null
@@ -1,1178 +0,0 @@
-(************************************************************************)
-(*  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: Rtopology.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Ranalysis1.
-Require RList.
-Require Classical_Prop.
-Require Classical_Pred_Type.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-Definition included [D1,D2:R->Prop] : Prop := (x:R)(D1 x)->(D2 x).
-Definition disc [x:R;delta:posreal] : R->Prop := [y:R]``(Rabsolu (y-x))<delta``.
-Definition neighbourhood [V:R->Prop;x:R] : Prop := (EXT delta:posreal | (included (disc x delta) V)).
-Definition open_set [D:R->Prop] : Prop := (x:R) (D x)->(neighbourhood D x).
-Definition complementary [D:R->Prop] : R->Prop := [c:R]~(D c).
-Definition closed_set [D:R->Prop] : Prop := (open_set (complementary D)).
-Definition intersection_domain [D1,D2:R->Prop] : R->Prop := [c:R](D1 c)/\(D2 c).
-Definition union_domain [D1,D2:R->Prop] : R->Prop := [c:R](D1 c)\/(D2 c).
-Definition interior [D:R->Prop] : R->Prop := [x:R](neighbourhood D x).
-
-Lemma interior_P1 : (D:R->Prop) (included (interior D) D).
-Intros; Unfold included; Unfold interior; Intros; Unfold neighbourhood in H; Elim H; Intros; Unfold included in H0; Apply H0; Unfold disc; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply (cond_pos x0).
-Qed.
-
-Lemma interior_P2 : (D:R->Prop) (open_set D) -> (included D (interior D)).
-Intros; Unfold open_set in H; Unfold included; Intros; Assert H1 := (H ? H0); Unfold interior; Apply H1.
-Qed.
-
-Definition point_adherent [D:R->Prop;x:R] : Prop := (V:R->Prop) (neighbourhood V x) -> (EXT y:R | (intersection_domain V D y)).
-Definition adherence [D:R->Prop] : R->Prop := [x:R](point_adherent D x).
-
-Lemma adherence_P1 : (D:R->Prop) (included D (adherence D)).
-Intro; Unfold included; Intros; Unfold adherence; Unfold point_adherent; Intros; Exists x; Unfold intersection_domain; Split.
-Unfold neighbourhood in H0; Elim H0; Intros; Unfold included in H1; Apply H1; Unfold disc; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply (cond_pos x0).
-Apply H.
-Qed.
-
-Lemma included_trans : (D1,D2,D3:R->Prop) (included D1 D2) -> (included D2 D3) -> (included D1 D3).
-Unfold included; Intros; Apply H0; Apply H; Apply H1.
-Qed.
-
-Lemma interior_P3 : (D:R->Prop) (open_set (interior D)).
-Intro; Unfold open_set interior; Unfold neighbourhood; Intros; Elim H; Intros.
-Exists x0; Unfold included; Intros.
-Pose del := ``x0-(Rabsolu (x-x1))``.
-Cut ``0<del``.
-Intro; Exists (mkposreal del H2); Intros.
-Cut (included (disc x1 (mkposreal del H2)) (disc x x0)).
-Intro; Assert H5 := (included_trans ? ? ? H4 H0).
-Apply H5; Apply H3.
-Unfold included; Unfold disc; Intros.
-Apply Rle_lt_trans with ``(Rabsolu (x3-x1))+(Rabsolu (x1-x))``.
-Replace ``x3-x`` with ``(x3-x1)+(x1-x)``; [Apply Rabsolu_triang | Ring].
-Replace (pos x0) with ``del+(Rabsolu (x1-x))``.
-Do 2 Rewrite <- (Rplus_sym (Rabsolu ``x1-x``)); Apply Rlt_compatibility; Apply H4.
-Unfold del; Rewrite <- (Rabsolu_Ropp ``x-x1``); Rewrite Ropp_distr2; Ring.
-Unfold del; Apply Rlt_anti_compatibility with ``(Rabsolu (x-x1))``; Rewrite Rplus_Or; Replace ``(Rabsolu (x-x1))+(x0-(Rabsolu (x-x1)))`` with (pos x0); [Idtac | Ring].
-Unfold disc in H1; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H1.
-Qed.
-
-Lemma complementary_P1 : (D:R->Prop) ~(EXT y:R | (intersection_domain D (complementary D) y)).
-Intro; Red; Intro; Elim H; Intros; Unfold intersection_domain complementary in H0; Elim H0; Intros; Elim H2; Assumption.
-Qed.
-
-Lemma adherence_P2 : (D:R->Prop) (closed_set D) -> (included (adherence D) D).
-Unfold closed_set; Unfold open_set complementary; Intros; Unfold included adherence; Intros; Assert H1 := (classic (D x)); Elim H1; Intro.
-Assumption.
-Assert H3 := (H ? H2); Assert H4 := (H0 ? H3); Elim H4; Intros; Unfold intersection_domain in H5; Elim H5; Intros; Elim H6; Assumption.
-Qed.
-
-Lemma adherence_P3 : (D:R->Prop) (closed_set (adherence D)).
-Intro; Unfold closed_set adherence; Unfold open_set complementary point_adherent; Intros; Pose P := [V:R->Prop](neighbourhood V x)->(EXT y:R | (intersection_domain V D y)); Assert H0 := (not_all_ex_not ? P H); Elim H0; Intros V0 H1; Unfold P in H1; Assert H2 := (imply_to_and ? ? H1); Unfold neighbourhood; Elim H2; Intros; Unfold neighbourhood in H3; Elim H3; Intros; Exists x0; Unfold included; Intros; Red; Intro.
-Assert H8 := (H7 V0); Cut (EXT delta:posreal | (x:R)(disc x1 delta x)->(V0 x)).
-Intro; Assert H10 := (H8 H9); Elim H4; Assumption.
-Cut ``0<x0-(Rabsolu (x-x1))``.
-Intro; Pose del := (mkposreal ? H9); Exists del; Intros; Unfold included in H5; Apply H5; Unfold disc; Apply Rle_lt_trans with ``(Rabsolu (x2-x1))+(Rabsolu (x1-x))``.
-Replace ``x2-x`` with ``(x2-x1)+(x1-x)``; [Apply Rabsolu_triang | Ring].
-Replace (pos x0) with ``del+(Rabsolu (x1-x))``.
-Do 2 Rewrite <- (Rplus_sym ``(Rabsolu (x1-x))``); Apply Rlt_compatibility; Apply H10.
-Unfold del; Simpl; Rewrite <- (Rabsolu_Ropp ``x-x1``); Rewrite Ropp_distr2; Ring.
-Apply Rlt_anti_compatibility with ``(Rabsolu (x-x1))``; Rewrite Rplus_Or; Replace ``(Rabsolu (x-x1))+(x0-(Rabsolu (x-x1)))`` with (pos x0); [Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H6 | Ring].
-Qed.
-
-Definition eq_Dom [D1,D2:R->Prop] : Prop := (included D1 D2)/\(included D2 D1).
-
-Infix "=_D" eq_Dom (at level 5, no associativity).
-
-Lemma open_set_P1 : (D:R->Prop) (open_set D) <-> D =_D (interior D).
-Intro; Split.
-Intro; Unfold eq_Dom; Split.
-Apply interior_P2; Assumption.
-Apply interior_P1.
-Intro; Unfold eq_Dom in H; Elim H; Clear H; Intros; Unfold open_set; Intros; Unfold included interior in H; Unfold included in H0; Apply (H ? H1).
-Qed.
-
-Lemma closed_set_P1 : (D:R->Prop) (closed_set D) <-> D =_D (adherence D).
-Intro; Split.
-Intro; Unfold eq_Dom; Split.
-Apply adherence_P1.
-Apply adherence_P2; Assumption.
-Unfold eq_Dom; Unfold included; Intros; Assert H0 := (adherence_P3 D); Unfold closed_set in H0; Unfold closed_set; Unfold open_set; Unfold open_set in H0; Intros; Assert H2 : (complementary (adherence D) x).
-Unfold complementary; Unfold complementary in H1; Red; Intro; Elim H; Clear H; Intros _ H; Elim H1; Apply (H ? H2).
-Assert H3 := (H0 ? H2); Unfold neighbourhood; Unfold neighbourhood in H3; Elim H3; Intros; Exists x0; Unfold included; Unfold included in H4; Intros; Assert H6 := (H4 ? H5); Unfold complementary in H6; Unfold complementary; Red; Intro; Elim H; Clear H; Intros H _; Elim H6; Apply (H ? H7).
-Qed.
-
-Lemma neighbourhood_P1 : (D1,D2:R->Prop;x:R) (included D1 D2) -> (neighbourhood D1 x) -> (neighbourhood D2 x).
-Unfold included neighbourhood; Intros; Elim H0; Intros; Exists x0; Intros; Unfold included; Unfold included in H1; Intros; Apply (H ? (H1 ? H2)).
-Qed.
-
-Lemma open_set_P2 : (D1,D2:R->Prop) (open_set D1) -> (open_set D2) -> (open_set (union_domain D1 D2)).
-Unfold open_set; Intros; Unfold union_domain in H1; Elim H1; Intro.
-Apply neighbourhood_P1 with D1.
-Unfold included union_domain; Tauto.
-Apply H; Assumption.
-Apply neighbourhood_P1 with D2.
-Unfold included union_domain; Tauto.
-Apply H0; Assumption.
-Qed.
-
-Lemma open_set_P3 : (D1,D2:R->Prop) (open_set D1) -> (open_set D2) -> (open_set (intersection_domain D1 D2)).
-Unfold open_set; Intros; Unfold intersection_domain in H1; Elim H1; Intros.
-Assert H4 := (H ? H2); Assert H5 := (H0 ? H3); Unfold intersection_domain; Unfold neighbourhood in H4 H5; Elim H4; Clear H; Intros del1 H; Elim H5; Clear H0; Intros del2 H0; Cut ``0<(Rmin del1 del2)``.
-Intro; Pose del := (mkposreal ? H6).
-Exists del; Unfold included; Intros; Unfold included in H H0; Unfold disc in H H0 H7.
-Split.
-Apply H; Apply Rlt_le_trans with (pos del).
-Apply H7.
-Unfold del; Simpl; Apply Rmin_l.
-Apply H0; Apply Rlt_le_trans with (pos del).
-Apply H7.
-Unfold del; Simpl; Apply Rmin_r.
-Unfold Rmin; Case (total_order_Rle del1 del2); Intro.
-Apply (cond_pos del1).
-Apply (cond_pos del2).
-Qed.
-
-Lemma open_set_P4 : (open_set [x:R]False).
-Unfold open_set; Intros; Elim H.
-Qed.
-
-Lemma open_set_P5 : (open_set [x:R]True).
-Unfold open_set; Intros; Unfold neighbourhood.
-Exists (mkposreal R1 Rlt_R0_R1); Unfold included; Intros; Trivial.
-Qed.
-
-Lemma disc_P1 : (x:R;del:posreal) (open_set (disc x del)).
-Intros; Assert H := (open_set_P1 (disc x del)).
-Elim H; Intros; Apply H1.
-Unfold eq_Dom; Split.
-Unfold included interior disc; Intros; Cut ``0<del-(Rabsolu (x-x0))``.
-Intro; Pose del2 := (mkposreal ? H3).
-Exists del2; Unfold included; Intros.
-Apply Rle_lt_trans with ``(Rabsolu (x1-x0))+(Rabsolu (x0 -x))``.
-Replace ``x1-x`` with ``(x1-x0)+(x0-x)``; [Apply Rabsolu_triang | Ring].
-Replace (pos del) with ``del2 + (Rabsolu (x0-x))``.
-Do 2 Rewrite <- (Rplus_sym ``(Rabsolu (x0-x))``); Apply Rlt_compatibility.
-Apply H4.
-Unfold del2; Simpl; Rewrite <- (Rabsolu_Ropp ``x-x0``); Rewrite Ropp_distr2; Ring.
-Apply Rlt_anti_compatibility with ``(Rabsolu (x-x0))``; Rewrite Rplus_Or; Replace ``(Rabsolu (x-x0))+(del-(Rabsolu (x-x0)))`` with (pos del); [Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H2 | Ring].
-Apply interior_P1.
-Qed.
-
-Lemma continuity_P1 : (f:R->R;x:R) (continuity_pt f x) <-> (W:R->Prop)(neighbourhood W (f x)) -> (EXT V:R->Prop | (neighbourhood V x) /\ ((y:R)(V y)->(W (f y)))).
-Intros; Split.
-Intros; Unfold neighbourhood in H0.
-Elim H0; Intros del1 H1.
-Unfold continuity_pt in H; Unfold continue_in in H; Unfold limit1_in in H; Unfold limit_in in H; Simpl in H; Unfold R_dist in H.
-Assert H2 := (H del1 (cond_pos del1)).
-Elim H2; Intros del2 H3.
-Elim H3; Intros.
-Exists (disc x (mkposreal del2 H4)).
-Intros; Unfold included in H1; Split.
-Unfold neighbourhood disc.
-Exists (mkposreal del2 H4).
-Unfold included; Intros; Assumption.
-Intros; Apply H1; Unfold disc; Case (Req_EM y x); Intro.
-Rewrite H7; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply (cond_pos del1).
-Apply H5; Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Apply not_sym; Apply H7.
-Unfold disc in H6; Apply H6.
-Intros; Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Intros.
-Assert H1 := (H (disc (f x) (mkposreal eps H0))).
-Cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)).
-Intro; Assert H3 := (H1 H2).
-Elim H3; Intros D H4; Elim H4; Intros; Unfold neighbourhood in H5; Elim H5; Intros del1 H7.
-Exists (pos del1); Split.
-Apply (cond_pos del1).
-Intros; Elim H8; Intros; Simpl in H10; Unfold R_dist in H10; Simpl; Unfold R_dist; Apply (H6 ? (H7 ? H10)).
-Unfold neighbourhood disc; Exists (mkposreal eps H0); Unfold included; Intros; Assumption.
-Qed.
-
-Definition image_rec [f:R->R;D:R->Prop] : R->Prop := [x:R](D (f x)).
-
-(**********)
-Lemma continuity_P2 : (f:R->R;D:R->Prop) (continuity f) -> (open_set D) -> (open_set (image_rec f D)).
-Intros; Unfold open_set in H0; Unfold open_set; Intros; Assert H2 := (continuity_P1 f x); Elim H2; Intros H3 _; Assert H4 := (H3 (H x)); Unfold neighbourhood image_rec; Unfold image_rec in H1; Assert H5 := (H4 D (H0 (f x) H1)); Elim H5; Intros V0 H6; Elim H6; Intros; Unfold neighbourhood in H7; Elim H7; Intros del H9; Exists del; Unfold included in H9; Unfold included; Intros; Apply (H8 ? (H9 ? H10)).
-Qed.
-
-(**********)
-Lemma continuity_P3 : (f:R->R) (continuity f) <-> (D:R->Prop) (open_set D)->(open_set (image_rec f D)).
-Intros; Split.
-Intros; Apply continuity_P2; Assumption.
-Intros; Unfold continuity; Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Cut (open_set (disc (f x) (mkposreal ? H0))).
-Intro; Assert H2 := (H ? H1).
-Unfold open_set image_rec in H2; Cut (disc (f x) (mkposreal ? H0) (f x)).
-Intro; Assert H4 := (H2 ? H3).
-Unfold neighbourhood in H4; Elim H4; Intros del H5.
-Exists (pos del); Split.
-Apply (cond_pos del).
-Intros; Unfold included in H5; Apply H5; Elim H6; Intros; Apply H8.
-Unfold disc; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply H0.
-Apply disc_P1.
-Qed.
-
-(**********)
-Theorem Rsepare : (x,y:R) ``x<>y``->(EXT V:R->Prop | (EXT W:R->Prop | (neighbourhood V x)/\(neighbourhood W y)/\~(EXT y:R | (intersection_domain V W y)))).
-Intros x y Hsep; Pose D := ``(Rabsolu (x-y))``.
-Cut ``0<D/2``.
-Intro; Exists (disc x (mkposreal ? H)).
-Exists (disc y (mkposreal ? H)); Split.
-Unfold neighbourhood; Exists (mkposreal ? H); Unfold included; Tauto.
-Split.
-Unfold neighbourhood; Exists (mkposreal ? H); Unfold included; Tauto.
-Red; Intro; Elim H0; Intros; Unfold intersection_domain in H1; Elim H1; Intros.
-Cut ``D<D``.
-Intro; Elim (Rlt_antirefl ? H4).
-Change ``(Rabsolu (x-y))<D``; Apply Rle_lt_trans with ``(Rabsolu (x-x0))+(Rabsolu (x0-y))``.
-Replace ``x-y`` with ``(x-x0)+(x0-y)``; [Apply Rabsolu_triang | Ring].
-Rewrite (double_var D); Apply Rplus_lt.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H2.
-Apply H3.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Unfold D; Apply Rabsolu_pos_lt; Apply (Rminus_eq_contra ? ? Hsep).
-Apply Rlt_Rinv; Sup0.
-Qed.
-
-Record family : Type := mkfamily {
-  ind : R->Prop;
-  f :> R->R->Prop;
-  cond_fam : (x:R)(EXT y:R|(f x y))->(ind x) }.
-
-Definition family_open_set [f:family] : Prop := (x:R) (open_set (f x)).
-
-Definition domain_finite [D:R->Prop] : Prop := (EXT l:Rlist | (x:R)(D x)<->(In x l)).
-
-Definition family_finite [f:family] : Prop := (domain_finite (ind f)).
-
-Definition covering [D:R->Prop;f:family] : Prop := (x:R) (D x)->(EXT y:R | (f y x)).
-
-Definition covering_open_set [D:R->Prop;f:family] : Prop := (covering D f)/\(family_open_set f).
-
-Definition covering_finite [D:R->Prop;f:family] : Prop := (covering D f)/\(family_finite f).
-
-Lemma restriction_family : (f:family;D:R->Prop) (x:R)(EXT y:R|([z1:R][z2:R](f z1 z2)/\(D z1) x y))->(intersection_domain (ind f) D x).
-Intros; Elim H; Intros; Unfold intersection_domain; Elim H0; Intros; Split.
-Apply (cond_fam f0); Exists x0; Assumption.
-Assumption.
-Qed.
-
-Definition subfamily [f:family;D:R->Prop] : family := (mkfamily (intersection_domain (ind f) D) [x:R][y:R](f x y)/\(D x) (restriction_family f D)).
-
-Definition compact [X:R->Prop] : Prop := (f:family) (covering_open_set X f) -> (EXT D:R->Prop | (covering_finite X (subfamily f D))).
-
-(**********)
-Lemma family_P1 : (f:family;D:R->Prop) (family_open_set f) -> (family_open_set (subfamily f D)).
-Unfold family_open_set; Intros; Unfold subfamily; Simpl; Assert H0 := (classic (D x)).
-Elim H0; Intro.
-Cut (open_set (f0 x))->(open_set [y:R](f0 x y)/\(D x)).
-Intro; Apply H2; Apply H.
-Unfold open_set; Unfold neighbourhood; Intros; Elim H3; Intros; Assert H6 := (H2 ? H4); Elim H6; Intros; Exists x1; Unfold included; Intros; Split.
-Apply (H7 ? H8).
-Assumption.
-Cut (open_set [y:R]False) -> (open_set [y:R](f0 x y)/\(D x)).
-Intro; Apply H2; Apply open_set_P4.
-Unfold open_set; Unfold neighbourhood; Intros; Elim H3; Intros; Elim H1; Assumption.
-Qed.
-
-Definition bounded [D:R->Prop] : Prop := (EXT m:R | (EXT M:R | (x:R)(D x)->``m<=x<=M``)).
-
-Lemma open_set_P6 : (D1,D2:R->Prop) (open_set D1) -> D1 =_D D2 -> (open_set D2).
-Unfold open_set; Unfold neighbourhood; Intros.
-Unfold eq_Dom in H0; Elim H0; Intros.
-Assert H4 := (H ? (H3 ? H1)).
-Elim H4; Intros.
-Exists x0; Apply included_trans with D1; Assumption.
-Qed.
-
-(**********)
-Lemma compact_P1 : (X:R->Prop) (compact X) -> (bounded X).
-Intros; Unfold compact in H; Pose D := [x:R]True; Pose g := [x:R][y:R]``(Rabsolu y)<x``; Cut (x:R)(EXT y|(g x y))->True; [Intro | Intro; Trivial].
-Pose f0 := (mkfamily D g H0); Assert H1 := (H f0); Cut (covering_open_set X f0).
-Intro; Assert H3 := (H1 H2); Elim H3; Intros D' H4; Unfold covering_finite in H4; Elim H4; Intros; Unfold family_finite in H6; Unfold domain_finite in H6; Elim H6; Intros l H7; Unfold bounded; Pose r := (MaxRlist l).
-Exists ``-r``; Exists r; Intros.
-Unfold covering in H5; Assert H9 := (H5 ? H8); Elim H9; Intros; Unfold subfamily in H10; Simpl in H10; Elim H10; Intros; Assert H13 := (H7 x0); Simpl in H13; Cut (intersection_domain D D' x0).
-Elim H13; Clear H13; Intros.
-Assert H16 := (H13 H15); Unfold g in H11; Split.
-Cut ``x0<=r``.
-Intro; Cut ``(Rabsolu x)<r``.
-Intro; Assert H19 := (Rabsolu_def2 x r H18); Elim H19; Intros; Left; Assumption.
-Apply Rlt_le_trans with x0; Assumption.
-Apply (MaxRlist_P1 l x0 H16).
-Cut ``x0<=r``.
-Intro; Apply Rle_trans with (Rabsolu x).
-Apply Rle_Rabsolu.
-Apply Rle_trans with x0.
-Left; Apply H11.
-Assumption.
-Apply (MaxRlist_P1 l x0 H16).
-Unfold intersection_domain D; Tauto.
-Unfold covering_open_set; Split.
-Unfold covering; Intros; Simpl; Exists ``(Rabsolu x)+1``; Unfold g; Pattern 1 (Rabsolu x); Rewrite <- Rplus_Or; Apply Rlt_compatibility; Apply Rlt_R0_R1.
-Unfold family_open_set; Intro; Case (total_order R0 x); Intro.
-Apply open_set_P6 with (disc R0 (mkposreal ? H2)).
-Apply disc_P1.
-Unfold eq_Dom; Unfold f0; Simpl; Unfold g disc; Split.
-Unfold included; Intros; Unfold Rminus in H3; Rewrite Ropp_O in H3; Rewrite Rplus_Or in H3; Apply H3.
-Unfold included; Intros; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply H3.
-Apply open_set_P6 with [x:R]False.
-Apply open_set_P4.
-Unfold eq_Dom; Split.
-Unfold included; Intros; Elim H3.
-Unfold included f0; Simpl; Unfold g; Intros; Elim H2; Intro; [Rewrite <- H4 in H3; Assert H5 := (Rabsolu_pos x0); Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H5 H3)) | Assert H6 := (Rabsolu_pos x0); Assert H7 := (Rlt_trans ? ? ? H3 H4); Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H6 H7))].
-Qed.
-
-(**********)
-Lemma compact_P2 : (X:R->Prop) (compact X) -> (closed_set X).
-Intros; Assert H0 := (closed_set_P1 X); Elim H0; Clear H0; Intros _ H0; Apply H0; Clear H0.
-Unfold eq_Dom; Split.
-Apply adherence_P1.
-Unfold included; Unfold adherence; Unfold point_adherent; Intros; Unfold compact in H; Assert H1 := (classic (X x)); Elim H1; Clear H1; Intro.
-Assumption.
-Cut (y:R)(X y)->``0<(Rabsolu (y-x))/2``.
-Intro; Pose D := X; Pose g := [y:R][z:R]``(Rabsolu (y-z))<(Rabsolu (y-x))/2``/\(D y); Cut (x:R)(EXT y|(g x y))->(D x).
-Intro; Pose f0 := (mkfamily D g H3); Assert H4 := (H f0); Cut (covering_open_set X f0).
-Intro; Assert H6 := (H4 H5); Elim H6; Clear H6; Intros D' H6.
-Unfold covering_finite in H6; Decompose [and] H6; Unfold covering subfamily in H7; Simpl in H7; Unfold family_finite subfamily in H8; Simpl in H8; Unfold domain_finite in H8; Elim H8; Clear H8; Intros l H8; Pose alp := (MinRlist (AbsList l x)); Cut ``0<alp``.
-Intro; Assert H10 := (H0 (disc x (mkposreal ? H9))); Cut (neighbourhood (disc x (mkposreal alp H9)) x).
-Intro; Assert H12 := (H10 H11); Elim H12; Clear H12; Intros y H12; Unfold intersection_domain in H12; Elim H12; Clear H12; Intros; Assert H14 := (H7 ? H13); Elim H14; Clear H14; Intros y0 H14; Elim H14; Clear H14; Intros; Unfold g in H14; Elim H14; Clear H14; Intros; Unfold disc in H12; Simpl in H12; Cut ``alp<=(Rabsolu (y0-x))/2``.
-Intro; Assert H18 := (Rlt_le_trans ? ? ? H12 H17); Cut ``(Rabsolu (y0-x))<(Rabsolu (y0-x))``.
-Intro; Elim (Rlt_antirefl ? H19).
-Apply Rle_lt_trans with ``(Rabsolu (y0-y))+(Rabsolu (y-x))``.
-Replace ``y0-x`` with ``(y0-y)+(y-x)``; [Apply Rabsolu_triang | Ring].
-Rewrite (double_var ``(Rabsolu (y0-x))``); Apply Rplus_lt; Assumption.
-Apply (MinRlist_P1 (AbsList l x) ``(Rabsolu (y0-x))/2``); Apply AbsList_P1; Elim (H8 y0); Clear H8; Intros; Apply H8; Unfold intersection_domain; Split; Assumption.
-Assert H11 := (disc_P1 x (mkposreal alp H9)); Unfold open_set in H11; Apply H11.
-Unfold disc; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply H9.
-Unfold alp; Apply MinRlist_P2; Intros; Assert H10 := (AbsList_P2 ? ? ? H9); Elim H10; Clear H10; Intros z H10; Elim H10; Clear H10; Intros; Rewrite H11; Apply H2; Elim (H8 z); Clear H8; Intros; Assert H13 := (H12 H10); Unfold intersection_domain D in H13; Elim H13; Clear H13; Intros; Assumption.
-Unfold covering_open_set; Split.
-Unfold covering; Intros; Exists x0; Simpl; Unfold g; Split.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Unfold Rminus in H2; Apply (H2 ? H5).
-Apply H5.
-Unfold family_open_set; Intro; Simpl; Unfold g; Elim (classic (D x0)); Intro.
-Apply open_set_P6 with (disc x0 (mkposreal ? (H2 ? H5))).
-Apply disc_P1.
-Unfold eq_Dom; Split.
-Unfold included disc; Simpl; Intros; Split.
-Rewrite <- (Rabsolu_Ropp ``x0-x1``); Rewrite Ropp_distr2; Apply H6.
-Apply H5.
-Unfold included disc; Simpl; Intros; Elim H6; Intros; Rewrite <- (Rabsolu_Ropp ``x1-x0``); Rewrite Ropp_distr2; Apply H7.
-Apply open_set_P6 with [z:R]False.
-Apply open_set_P4.
-Unfold eq_Dom; Split.
-Unfold included; Intros; Elim H6.
-Unfold included; Intros; Elim H6; Intros; Elim H5; Assumption.
-Intros; Elim H3; Intros; Unfold g in H4; Elim H4; Clear H4; Intros _ H4; Apply H4.
-Intros; Unfold Rdiv; Apply Rmult_lt_pos.
-Apply Rabsolu_pos_lt; Apply Rminus_eq_contra; Red; Intro; Rewrite H3 in H2; Elim H1; Apply H2.
-Apply Rlt_Rinv; Sup0.
-Qed.
-
-(**********)
-Lemma compact_EMP : (compact [_:R]False).
-Unfold compact; Intros; Exists [x:R]False; Unfold covering_finite; Split.
-Unfold covering; Intros; Elim H0.
-Unfold family_finite; Unfold domain_finite; Exists nil; Intro.
-Split.
-Simpl; Unfold intersection_domain; Intros; Elim H0.
-Elim H0; Clear H0; Intros _ H0; Elim H0.
-Simpl; Intro; Elim H0.
-Qed.
-
-Lemma compact_eqDom : (X1,X2:R->Prop) (compact X1) -> X1 =_D X2 -> (compact X2).
-Unfold compact; Intros; Unfold eq_Dom in H0; Elim H0; Clear H0; Unfold included; Intros; Assert H3 : (covering_open_set X1 f0).
-Unfold covering_open_set; Unfold covering_open_set in H1; Elim H1; Clear H1; Intros; Split.
-Unfold covering in H1; Unfold covering; Intros; Apply (H1 ? (H0 ? H4)).
-Apply H3.
-Elim (H ? H3); Intros D H4; Exists D; Unfold covering_finite; Unfold covering_finite in H4; Elim H4; Intros; Split.
-Unfold covering in H5; Unfold covering; Intros; Apply (H5 ? (H2 ? H7)).
-Apply H6.
-Qed.
-
-(* Borel-Lebesgue's lemma *)
-Lemma compact_P3 : (a,b:R) (compact [c:R]``a<=c<=b``).
-Intros; Case (total_order_Rle a b); Intro.
-Unfold compact; Intros; Pose A := [x:R]``a<=x<=b``/\(EXT D:R->Prop | (covering_finite [c:R]``a <= c <= x`` (subfamily f0 D))); Cut (A a).
-Intro; Cut (bound A).
-Intro; Cut (EXT a0:R | (A a0)).
-Intro; Assert H3 := (complet A H1 H2); Elim H3; Clear H3; Intros m H3; Unfold is_lub in H3; Cut ``a<=m<=b``.
-Intro; Unfold covering_open_set in H; Elim H; Clear H; Intros; Unfold covering in H; Assert H6 := (H m H4); Elim H6; Clear H6; Intros y0 H6; Unfold family_open_set in H5; Assert H7 := (H5 y0); Unfold open_set in H7; Assert H8 := (H7 m H6); Unfold neighbourhood in H8; Elim H8; Clear H8; Intros eps H8; Cut (EXT x:R | (A x)/\``m-eps<x<=m``).
-Intro; Elim H9; Clear H9; Intros x H9; Elim H9; Clear H9; Intros; Case (Req_EM m b); Intro.
-Rewrite H11 in H10; Rewrite H11 in H8; Unfold A in H9; Elim H9; Clear H9; Intros; Elim H12; Clear H12; Intros Dx H12; Pose Db := [x:R](Dx x)\/x==y0; Exists Db; Unfold covering_finite; Split.
-Unfold covering; Unfold covering_finite in H12; Elim H12; Clear H12; Intros; Unfold covering in H12; Case (total_order_Rle x0 x); Intro.
-Cut ``a<=x0<=x``.
-Intro; Assert H16 := (H12 x0 H15); Elim H16; Clear H16; Intros; Exists x1; Simpl in H16; Simpl; Unfold Db; Elim H16; Clear H16; Intros; Split; [Apply H16 | Left; Apply H17].
-Split.
-Elim H14; Intros; Assumption.
-Assumption.
-Exists y0; Simpl; Split.
-Apply H8; Unfold disc; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Rewrite Rabsolu_right.
-Apply Rlt_trans with ``b-x``.
-Unfold Rminus; Apply Rlt_compatibility; Apply Rlt_Ropp; Auto with real.
-Elim H10; Intros H15 _; Apply Rlt_anti_compatibility with ``x-eps``; Replace ``x-eps+(b-x)`` with ``b-eps``; [Replace ``x-eps+eps`` with x; [Apply H15 | Ring] | Ring].
-Apply Rge_minus; Apply Rle_sym1; Elim H14; Intros _ H15; Apply H15.
-Unfold Db; Right; Reflexivity.
-Unfold family_finite; Unfold domain_finite; Unfold covering_finite in H12; Elim H12; Clear H12; Intros; Unfold family_finite in H13; Unfold domain_finite in H13; Elim H13; Clear H13; Intros l H13; Exists (cons y0 l); Intro; Split.
-Intro; Simpl in H14; Unfold intersection_domain in H14; Elim (H13 x0); Clear H13; Intros; Case (Req_EM x0 y0); Intro.
-Simpl; Left; Apply H16.
-Simpl; Right; Apply H13.
-Simpl; Unfold intersection_domain; Unfold Db in H14; Decompose [and or] H14.
-Split; Assumption.
-Elim H16; Assumption.
-Intro; Simpl in H14; Elim H14; Intro; Simpl; Unfold intersection_domain.
-Split.
-Apply (cond_fam f0); Rewrite H15; Exists m; Apply H6.
-Unfold Db; Right; Assumption.
-Simpl; Unfold intersection_domain; Elim (H13 x0).
-Intros _ H16; Assert H17 := (H16 H15); Simpl in H17; Unfold intersection_domain in H17; Split.
-Elim H17; Intros; Assumption.
-Unfold Db; Left; Elim H17; Intros; Assumption.
-Pose m' := (Rmin ``m+eps/2`` b); Cut (A m').
-Intro; Elim H3; Intros; Unfold is_upper_bound in H13; Assert H15 := (H13 m' H12); Cut ``m<m'``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H15 H16)).
-Unfold m'; Unfold Rmin; Case (total_order_Rle ``m+eps/2`` b); Intro.
-Pattern 1 m; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos eps) | Apply Rlt_Rinv; Sup0].
-Elim H4; Intros.
-Elim H17; Intro.
-Assumption.
-Elim H11; Assumption.
-Unfold A; Split.
-Split.
-Apply Rle_trans with m.
-Elim H4; Intros; Assumption.
-Unfold m'; Unfold Rmin; Case (total_order_Rle ``m+eps/2`` b); Intro.
-Pattern 1 m; Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos eps) | Apply Rlt_Rinv; Sup0].
-Elim H4; Intros.
-Elim H13; Intro.
-Assumption.
-Elim H11; Assumption.
-Unfold m'; Apply Rmin_r.
-Unfold A in H9; Elim H9; Clear H9; Intros; Elim H12; Clear H12; Intros Dx H12; Pose Db := [x:R](Dx x)\/x==y0; Exists Db; Unfold covering_finite; Split.
-Unfold covering; Unfold covering_finite in H12; Elim H12; Clear H12; Intros; Unfold covering in H12; Case (total_order_Rle x0 x); Intro.
-Cut ``a<=x0<=x``.
-Intro; Assert H16 := (H12 x0 H15); Elim H16; Clear H16; Intros; Exists x1; Simpl in H16; Simpl; Unfold Db.
-Elim H16; Clear H16; Intros; Split; [Apply H16 | Left; Apply H17].
-Elim H14; Intros; Split; Assumption.
-Exists y0; Simpl; Split.
-Apply H8; Unfold disc; Unfold Rabsolu; Case (case_Rabsolu ``x0-m``); Intro.
-Rewrite Ropp_distr2; Apply Rlt_trans with ``m-x``.
-Unfold Rminus; Apply Rlt_compatibility; Apply Rlt_Ropp; Auto with real.
-Apply Rlt_anti_compatibility with ``x-eps``; Replace ``x-eps+(m-x)`` with ``m-eps``.
-Replace ``x-eps+eps`` with x.
-Elim H10; Intros; Assumption.
-Ring.
-Ring.
-Apply Rle_lt_trans with ``m'-m``.
-Unfold Rminus; Do 2 Rewrite <- (Rplus_sym ``-m``); Apply Rle_compatibility; Elim H14; Intros; Assumption.
-Apply Rlt_anti_compatibility with m; Replace ``m+(m'-m)`` with m'.
-Apply Rle_lt_trans with ``m+eps/2``.
-Unfold m'; Apply Rmin_l.
-Apply Rlt_compatibility; Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Unfold Rdiv; Rewrite <- (Rmult_sym ``/2``); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Pattern 1 (pos eps); Rewrite <- Rplus_Or; Rewrite double; Apply Rlt_compatibility; Apply (cond_pos eps).
-DiscrR.
-Ring.
-Unfold Db; Right; Reflexivity.
-Unfold family_finite; Unfold domain_finite; Unfold covering_finite in H12; Elim H12; Clear H12; Intros; Unfold family_finite in H13; Unfold domain_finite in H13; Elim H13; Clear H13; Intros l H13; Exists (cons y0 l); Intro; Split.
-Intro; Simpl in H14; Unfold intersection_domain in H14; Elim (H13 x0); Clear H13; Intros; Case (Req_EM x0 y0); Intro.
-Simpl; Left; Apply H16.
-Simpl; Right; Apply H13; Simpl; Unfold intersection_domain; Unfold Db in H14; Decompose [and or] H14.
-Split; Assumption.
-Elim H16; Assumption.
-Intro; Simpl in H14; Elim H14; Intro; Simpl; Unfold intersection_domain.
-Split.
-Apply (cond_fam f0); Rewrite H15; Exists m; Apply H6.
-Unfold Db; Right; Assumption.
-Elim (H13 x0); Intros _ H16.
-Assert H17 := (H16 H15).
-Simpl in H17.
-Unfold intersection_domain in H17.
-Split.
-Elim H17; Intros; Assumption.
-Unfold Db; Left; Elim H17; Intros; Assumption.
-Elim (classic (EXT x:R | (A x)/\``m-eps < x <= m``)); Intro.
-Assumption.
-Elim H3; Intros; Cut (is_upper_bound A ``m-eps``).
-Intro; Assert H13 := (H11 ? H12); Cut ``m-eps<m``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H13 H14)).
-Pattern 2 m; Rewrite <- Rplus_Or; Unfold Rminus; Apply Rlt_compatibility; Apply Ropp_Rlt; Rewrite Ropp_Ropp; Rewrite Ropp_O; Apply (cond_pos eps).
-Pose P := [n:R](A n)/\``m-eps<n<=m``; Assert H12 := (not_ex_all_not ? P H9); Unfold P in H12; Unfold is_upper_bound; Intros; Assert H14 := (not_and_or ? ? (H12 x)); Elim H14; Intro.
-Elim H15; Apply H13.
-Elim (not_and_or ? ? H15); Intro.
-Case (total_order_Rle x ``m-eps``); Intro.
-Assumption.
-Elim H16; Auto with real.
-Unfold is_upper_bound in H10; Assert H17 := (H10 x H13); Elim H16; Apply H17.
-Elim H3; Clear H3; Intros.
-Unfold is_upper_bound in H3.
-Split.
-Apply (H3 ? H0).
-Apply (H4 b); Unfold is_upper_bound; Intros; Unfold A in H5; Elim H5; Clear H5; Intros H5 _; Elim H5; Clear H5; Intros _ H5; Apply H5.
-Exists a; Apply H0.
-Unfold bound; Exists b; Unfold is_upper_bound; Intros; Unfold A in H1; Elim H1; Clear H1; Intros H1 _; Elim H1; Clear H1; Intros _ H1; Apply H1.
-Unfold A; Split.
-Split; [Right; Reflexivity | Apply r].
-Unfold covering_open_set in H; Elim H; Clear H; Intros; Unfold covering in H; Cut ``a<=a<=b``.
-Intro; Elim (H ? H1); Intros y0 H2; Pose D':=[x:R]x==y0; Exists D'; Unfold covering_finite; Split.
-Unfold covering; Simpl; Intros; Cut x==a.
-Intro; Exists y0; Split.
-Rewrite H4; Apply H2.
-Unfold D'; Reflexivity.
-Elim H3; Intros; Apply Rle_antisym; Assumption.
-Unfold family_finite; Unfold domain_finite; Exists (cons y0 nil); Intro; Split.
-Simpl; Unfold intersection_domain; Intro; Elim H3; Clear H3; Intros; Unfold D' in H4; Left; Apply H4.
-Simpl; Unfold intersection_domain; Intro; Elim H3; Intro.
-Split; [Rewrite H4; Apply (cond_fam f0); Exists a; Apply H2 | Apply H4].
-Elim H4.
-Split; [Right; Reflexivity | Apply r].
-Apply compact_eqDom with [c:R]False.
-Apply compact_EMP.
-Unfold eq_Dom; Split.
-Unfold included; Intros; Elim H.
-Unfold included; Intros; Elim H; Clear H; Intros; Assert H1 := (Rle_trans ? ? ? H H0); Elim n; Apply H1.
-Qed.
-
-Lemma compact_P4 : (X,F:R->Prop) (compact X) -> (closed_set F) -> (included F X) -> (compact F).
-Unfold compact; Intros; Elim (classic (EXT z:R | (F z))); Intro Hyp_F_NE.
-Pose D := (ind f0); Pose g := (f f0); Unfold closed_set in H0.
-Pose g' := [x:R][y:R](f0 x y)\/((complementary F y)/\(D x)).
-Pose D' := D.
-Cut (x:R)(EXT y:R | (g' x y))->(D' x).
-Intro; Pose f' := (mkfamily D' g' H3); Cut (covering_open_set X f').
-Intro; Elim (H ? H4); Intros DX H5; Exists DX.
-Unfold covering_finite; Unfold covering_finite in H5; Elim H5; Clear H5; Intros.
-Split.
-Unfold covering; Unfold covering in H5; Intros.
-Elim (H5 ? (H1 ? H7)); Intros y0 H8; Exists y0; Simpl in H8; Simpl; Elim H8; Clear H8; Intros.
-Split.
-Unfold g' in H8; Elim H8; Intro.
-Apply H10.
-Elim H10; Intros H11 _; Unfold complementary in H11; Elim H11; Apply H7.
-Apply H9.
-Unfold family_finite; Unfold domain_finite; Unfold family_finite in H6; Unfold domain_finite in H6; Elim H6; Clear H6; Intros l H6; Exists l; Intro; Assert H7 := (H6 x); Elim H7; Clear H7; Intros.
-Split.
-Intro; Apply H7; Simpl; Unfold intersection_domain; Simpl in H9; Unfold intersection_domain in H9; Unfold D'; Apply H9.
-Intro; Assert H10 := (H8 H9); Simpl in H10; Unfold intersection_domain in H10; Simpl; Unfold intersection_domain; Unfold D' in H10; Apply H10.
-Unfold covering_open_set; Unfold covering_open_set in H2; Elim H2; Clear H2; Intros.
-Split.
-Unfold covering; Unfold covering in H2; Intros.
-Elim (classic (F x)); Intro.
-Elim (H2 ? H6); Intros y0 H7; Exists y0; Simpl; Unfold g'; Left; Assumption.
-Cut (EXT z:R | (D z)).
-Intro; Elim H7; Clear H7; Intros x0 H7; Exists x0; Simpl; Unfold g'; Right.
-Split.
-Unfold complementary; Apply H6.
-Apply H7.
-Elim Hyp_F_NE; Intros z0 H7.
-Assert H8 := (H2 ? H7).
-Elim H8; Clear H8; Intros t H8; Exists t; Apply (cond_fam f0); Exists z0; Apply H8.
-Unfold family_open_set; Intro; Simpl; Unfold g'; Elim (classic (D x)); Intro.
-Apply open_set_P6 with (union_domain (f0 x) (complementary F)).
-Apply open_set_P2.
-Unfold family_open_set in H4; Apply H4.
-Apply H0.
-Unfold eq_Dom; Split.
-Unfold included union_domain complementary; Intros.
-Elim H6; Intro; [Left; Apply H7 | Right; Split; Assumption].
-Unfold included union_domain complementary; Intros.
-Elim H6; Intro; [Left; Apply H7 | Right; Elim H7; Intros; Apply H8].
-Apply open_set_P6 with (f0 x).
-Unfold family_open_set in H4; Apply H4.
-Unfold eq_Dom; Split.
-Unfold included complementary; Intros; Left; Apply H6.
-Unfold included complementary; Intros.
-Elim H6; Intro.
-Apply H7.
-Elim H7; Intros _ H8; Elim H5; Apply H8.
-Intros; Elim H3; Intros y0 H4; Unfold g' in H4; Elim H4; Intro.
-Apply (cond_fam f0); Exists y0; Apply H5.
-Elim H5; Clear H5; Intros _ H5; Apply H5.
-(* Cas ou F est l'ensemble vide *)
-Cut (compact F).
-Intro; Apply (H3 f0 H2).
-Apply compact_eqDom with [_:R]False.
-Apply compact_EMP.
-Unfold eq_Dom; Split.
-Unfold included; Intros; Elim H3.
-Assert H3 := (not_ex_all_not ? ? Hyp_F_NE); Unfold included; Intros; Elim (H3 x); Apply H4.
-Qed.
-
-(**********)
-Lemma compact_P5 : (X:R->Prop) (closed_set X)->(bounded X)->(compact X).
-Intros; Unfold bounded in H0.
-Elim H0; Clear H0; Intros m H0.
-Elim H0; Clear H0; Intros M H0.
-Assert H1 := (compact_P3 m M).
-Apply (compact_P4 [c:R]``m<=c<=M`` X H1 H H0).
-Qed.
-
-(**********)
-Lemma compact_carac : (X:R->Prop) (compact X)<->(closed_set X)/\(bounded X).
-Intro; Split.
-Intro; Split; [Apply (compact_P2 ? H) | Apply (compact_P1 ? H)].
-Intro; Elim H; Clear H; Intros; Apply (compact_P5 ? H H0).
-Qed.
-
-Definition image_dir [f:R->R;D:R->Prop] : R->Prop := [x:R](EXT y:R | x==(f y)/\(D y)).
-
-(**********)
-Lemma continuity_compact : (f:R->R;X:R->Prop) ((x:R)(continuity_pt f x)) -> (compact X) -> (compact (image_dir f X)).
-Unfold compact; Intros; Unfold covering_open_set in H1.
-Elim H1; Clear H1; Intros.
-Pose D := (ind f1).
-Pose g := [x:R][y:R](image_rec f0 (f1 x) y).
-Cut (x:R)(EXT y:R | (g x y))->(D x).
-Intro; Pose f' := (mkfamily D g H3).
-Cut (covering_open_set X f').
-Intro; Elim (H0 f' H4); Intros D' H5; Exists D'.
-Unfold covering_finite in H5; Elim H5; Clear H5; Intros; Unfold covering_finite; Split.
-Unfold covering image_dir; Simpl; Unfold covering in H5; Intros; Elim H7; Intros y H8; Elim H8; Intros; Assert H11 := (H5 ? H10); Simpl in H11; Elim H11; Intros z H12; Exists z; Unfold g in H12; Unfold image_rec in H12; Rewrite H9; Apply H12.
-Unfold family_finite in H6; Unfold domain_finite in H6; Unfold family_finite; Unfold domain_finite; Elim H6; Intros l H7; Exists l; Intro; Elim (H7 x); Intros; Split; Intro.
-Apply H8; Simpl in H10; Simpl; Apply H10.
-Apply (H9 H10).
-Unfold covering_open_set; Split.
-Unfold covering; Intros; Simpl; Unfold covering in H1; Unfold image_dir in H1; Unfold g; Unfold image_rec; Apply H1.
-Exists x; Split; [Reflexivity | Apply H4].
-Unfold family_open_set; Unfold family_open_set in H2; Intro; Simpl; Unfold g; Cut ([y:R](image_rec f0 (f1 x) y))==(image_rec f0 (f1 x)).
-Intro; Rewrite H4.
-Apply (continuity_P2 f0 (f1 x) H (H2 x)).
-Reflexivity.
-Intros; Apply (cond_fam f1); Unfold g in H3; Unfold image_rec in H3; Elim H3; Intros; Exists (f0 x0); Apply H4.
-Qed.
-
-Lemma Rlt_Rminus : (a,b:R) ``a<b`` -> ``0<b-a``.
-Intros; Apply Rlt_anti_compatibility with a; Rewrite Rplus_Or; Replace ``a+(b-a)`` with b; [Assumption | Ring].
-Qed.
-
-Lemma prolongement_C0 : (f:R->R;a,b:R) ``a<=b`` -> ((c:R)``a<=c<=b``->(continuity_pt f c)) -> (EXT g:R->R | (continuity g)/\((c:R)``a<=c<=b``->(g c)==(f c))).
-Intros; Elim H; Intro.
-Pose h := [x:R](Cases (total_order_Rle x a) of
-  (leftT _) => (f0 a)
-| (rightT _) => (Cases (total_order_Rle x b) of
-       (leftT _) => (f0 x)
-     | (rightT _) => (f0 b) end) end).
-Assert H2 : ``0<b-a``.
-Apply Rlt_Rminus; Assumption.
-Exists h; Split.
-Unfold continuity; Intro; Case (total_order x a); Intro.
-Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Exists ``a-x``; Split.
-Change ``0<a-x``; Apply Rlt_Rminus; Assumption.
-Intros; Elim H5; Clear H5; Intros _ H5; Unfold h.
-Case (total_order_Rle x a); Intro.
-Case (total_order_Rle x0 a); Intro.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Elim n; Left; Apply Rlt_anti_compatibility with ``-x``; Do 2 Rewrite (Rplus_sym ``-x``); Apply Rle_lt_trans with ``(Rabsolu (x0-x))``.
-Apply Rle_Rabsolu.
-Assumption.
-Elim n; Left; Assumption.
-Elim H3; Intro.
-Assert H5 : ``a<=a<=b``.
-Split; [Right; Reflexivity | Left; Assumption].
-Assert H6 := (H0 ? H5); Unfold continuity_pt in H6; Unfold continue_in in H6; Unfold limit1_in in H6; Unfold limit_in in H6; Simpl in H6; Unfold R_dist in H6; Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Elim (H6 ? H7); Intros; Exists (Rmin x0 ``b-a``); Split.
-Unfold Rmin; Case (total_order_Rle x0 ``b-a``); Intro.
-Elim H8; Intros; Assumption.
-Change ``0<b-a``; Apply Rlt_Rminus; Assumption.
-Intros; Elim H9; Clear H9; Intros _ H9; Cut ``x1<b``.
-Intro; Unfold h; Case (total_order_Rle x a); Intro.
-Case (total_order_Rle x1 a); Intro.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Case (total_order_Rle x1 b); Intro.
-Elim H8; Intros; Apply H12; Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Red; Intro; Elim n; Right; Symmetry; Assumption.
-Apply Rlt_le_trans with (Rmin x0 ``b-a``).
-Rewrite H4 in H9; Apply H9.
-Apply Rmin_l.
-Elim n0; Left; Assumption.
-Elim n; Right; Assumption.
-Apply Rlt_anti_compatibility with ``-a``; Do 2 Rewrite (Rplus_sym ``-a``); Rewrite H4 in H9; Apply Rle_lt_trans with ``(Rabsolu (x1-a))``.
-Apply Rle_Rabsolu.
-Apply Rlt_le_trans with ``(Rmin x0 (b-a))``.
-Assumption.
-Apply Rmin_r.
-Case (total_order x b); Intro.
-Assert H6 : ``a<=x<=b``.
-Split; Left; Assumption.
-Assert H7 := (H0 ? H6); Unfold continuity_pt in H7; Unfold continue_in in H7; Unfold limit1_in in H7; Unfold limit_in in H7; Simpl in H7; Unfold R_dist in H7; Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Elim (H7 ? H8); Intros; Elim H9; Clear H9; Intros.
-Assert H11 : ``0<x-a``.
-Apply Rlt_Rminus; Assumption.
-Assert H12 : ``0<b-x``.
-Apply Rlt_Rminus; Assumption.
-Exists (Rmin x0 (Rmin ``x-a`` ``b-x``)); Split.
-Unfold Rmin; Case (total_order_Rle ``x-a`` ``b-x``); Intro.
-Case (total_order_Rle x0 ``x-a``); Intro.
-Assumption.
-Assumption.
-Case (total_order_Rle x0 ``b-x``); Intro.
-Assumption.
-Assumption.
-Intros; Elim H13; Clear H13; Intros; Cut ``a<x1<b``.
-Intro; Elim H15; Clear H15; Intros; Unfold h; Case (total_order_Rle x a); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H4)).
-Case (total_order_Rle x b); Intro.
-Case (total_order_Rle x1 a); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r0 H15)).
-Case (total_order_Rle x1 b); Intro.
-Apply H10; Split.
-Assumption.
-Apply Rlt_le_trans with ``(Rmin x0 (Rmin (x-a) (b-x)))``.
-Assumption.
-Apply Rmin_l.
-Elim n1; Left; Assumption.
-Elim n0; Left; Assumption.
-Split.
-Apply Ropp_Rlt; Apply Rlt_anti_compatibility with x; Apply Rle_lt_trans with ``(Rabsolu (x1-x))``.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply Rle_Rabsolu.
-Apply Rlt_le_trans with ``(Rmin x0 (Rmin (x-a) (b-x)))``.
-Assumption.
-Apply Rle_trans with ``(Rmin (x-a) (b-x))``.
-Apply Rmin_r.
-Apply Rmin_l.
-Apply Rlt_anti_compatibility with ``-x``; Do 2 Rewrite (Rplus_sym ``-x``); Apply Rle_lt_trans with ``(Rabsolu (x1-x))``.
-Apply Rle_Rabsolu.
-Apply Rlt_le_trans with ``(Rmin x0 (Rmin (x-a) (b-x)))``.
-Assumption.
-Apply Rle_trans with ``(Rmin (x-a) (b-x))``; Apply Rmin_r.
-Elim H5; Intro.
-Assert H7 : ``a<=b<=b``.
-Split; [Left; Assumption | Right; Reflexivity].
-Assert H8 := (H0 ? H7); Unfold continuity_pt in H8; Unfold continue_in in H8; Unfold limit1_in in H8; Unfold limit_in in H8; Simpl in H8; Unfold R_dist in H8; Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Elim (H8 ? H9); Intros; Exists (Rmin x0 ``b-a``); Split.
-Unfold Rmin; Case (total_order_Rle x0 ``b-a``); Intro.
-Elim H10; Intros; Assumption.
-Change ``0<b-a``; Apply Rlt_Rminus; Assumption.
-Intros; Elim H11; Clear H11; Intros _ H11; Cut ``a<x1``.
-Intro; Unfold h; Case (total_order_Rle x a); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H4)).
-Case (total_order_Rle x1 a); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H12)).
-Case (total_order_Rle x b); Intro.
-Case (total_order_Rle x1 b); Intro.
-Rewrite H6; Elim H10; Intros; Elim r0; Intro.
-Apply H14; Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Red; Intro; Rewrite <- H16 in H15; Elim (Rlt_antirefl ? H15).
-Rewrite H6 in H11; Apply Rlt_le_trans with ``(Rmin x0 (b-a))``.
-Apply H11.
-Apply Rmin_l.
-Rewrite H15; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Rewrite H6; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Elim n1; Right; Assumption.
-Rewrite H6 in H11; Apply Ropp_Rlt; Apply Rlt_anti_compatibility with b; Apply Rle_lt_trans with ``(Rabsolu (x1-b))``.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply Rle_Rabsolu.
-Apply Rlt_le_trans with ``(Rmin x0 (b-a))``.
-Assumption.
-Apply Rmin_r.
-Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros; Exists ``x-b``; Split.
-Change ``0<x-b``; Apply Rlt_Rminus; Assumption.
-Intros; Elim H8; Clear H8; Intros.
-Assert H10 : ``b<x0``.
-Apply Ropp_Rlt; Apply Rlt_anti_compatibility with x; Apply Rle_lt_trans with ``(Rabsolu (x0-x))``.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply Rle_Rabsolu.
-Assumption.
-Unfold h; Case (total_order_Rle x a); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H4)).
-Case (total_order_Rle x b); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H6)).
-Case (total_order_Rle x0 a); Intro.
-Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H1 (Rlt_le_trans ? ? ? H10 r))).
-Case (total_order_Rle x0 b); Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? r H10)).
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Intros; Elim H3; Intros; Unfold h; Case (total_order_Rle c a); Intro.
-Elim r; Intro.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H4 H6)).
-Rewrite H6; Reflexivity.
-Case (total_order_Rle c b); Intro.
-Reflexivity.
-Elim n0; Assumption.
-Exists [_:R](f0 a); Split.
-Apply derivable_continuous; Apply (derivable_const (f0 a)).
-Intros; Elim H2; Intros; Rewrite H1 in H3; Cut b==c.
-Intro; Rewrite <- H5; Rewrite H1; Reflexivity.
-Apply Rle_antisym; Assumption.
-Qed.
-
-(**********)
-Lemma continuity_ab_maj : (f:R->R;a,b:R) ``a<=b`` -> ((c:R)``a<=c<=b``->(continuity_pt f c)) -> (EXT Mx : R |  ((c:R)``a<=c<=b``->``(f c)<=(f Mx)``)/\``a<=Mx<=b``).
-Intros; Cut (EXT g:R->R | (continuity g)/\((c:R)``a<=c<=b``->(g c)==(f0 c))).
-Intro HypProl.
-Elim HypProl; Intros g Hcont_eq.
-Elim Hcont_eq; Clear Hcont_eq; Intros Hcont Heq.
-Assert H1 := (compact_P3 a b).
-Assert H2 := (continuity_compact g [c:R]``a<=c<=b`` Hcont H1).
-Assert H3 := (compact_P2 ? H2).
-Assert H4 := (compact_P1 ? H2).
-Cut (bound (image_dir g [c:R]``a <= c <= b``)).
-Cut (ExT [x:R] ((image_dir g [c:R]``a <= c <= b``) x)).
-Intros; Assert H7 := (complet ? H6 H5).
-Elim H7; Clear H7; Intros M H7; Cut (image_dir g [c:R]``a <= c <= b`` M).
-Intro; Unfold image_dir in H8; Elim H8; Clear H8; Intros Mxx H8; Elim H8; Clear H8; Intros; Exists Mxx; Split.
-Intros; Rewrite <- (Heq c H10); Rewrite <- (Heq Mxx H9); Intros; Rewrite <- H8; Unfold is_lub in H7; Elim H7; Clear H7; Intros H7 _; Unfold is_upper_bound in H7; Apply H7; Unfold image_dir; Exists c; Split; [Reflexivity | Apply H10].
-Apply H9.
-Elim (classic (image_dir g [c:R]``a <= c <= b`` M)); Intro.
-Assumption.
-Cut (EXT eps:posreal | (y:R)~(intersection_domain (disc M eps) (image_dir g [c:R]``a <= c <= b``) y)).
-Intro; Elim H9; Clear H9; Intros eps H9; Unfold is_lub in H7; Elim H7; Clear H7; Intros; Cut (is_upper_bound (image_dir g [c:R]``a <= c <= b``) ``M-eps``).
-Intro; Assert H12 := (H10 ? H11); Cut ``M-eps<M``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H12 H13)).
-Pattern 2 M; Rewrite <- Rplus_Or; Unfold Rminus; Apply Rlt_compatibility; Apply Ropp_Rlt; Rewrite Ropp_O; Rewrite Ropp_Ropp; Apply (cond_pos eps).
-Unfold is_upper_bound image_dir; Intros; Cut ``x<=M``.
-Intro; Case (total_order_Rle x ``M-eps``); Intro.
-Apply r.
-Elim (H9 x); Unfold intersection_domain disc image_dir; Split.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Rewrite Rabsolu_right.
-Apply Rlt_anti_compatibility with ``x-eps``; Replace ``x-eps+(M-x)`` with ``M-eps``.
-Replace ``x-eps+eps`` with x.
-Auto with real.
-Ring.
-Ring.
-Apply Rge_minus; Apply Rle_sym1; Apply H12.
-Apply H11.
-Apply H7; Apply H11.
-Cut (EXT V:R->Prop | (neighbourhood V M)/\((y:R)~(intersection_domain V (image_dir g [c:R]``a <= c <= b``) y))).
-Intro; Elim H9; Intros V H10; Elim H10; Clear H10; Intros.
-Unfold neighbourhood in H10; Elim H10; Intros del H12; Exists del; Intros; Red; Intro; Elim (H11 y).
-Unfold intersection_domain; Unfold intersection_domain in H13; Elim H13; Clear H13; Intros; Split.
-Apply (H12 ? H13).
-Apply H14.
-Cut ~(point_adherent (image_dir g [c:R]``a <= c <= b``) M).
-Intro; Unfold point_adherent in H9.
-Assert H10 := (not_all_ex_not ? [V:R->Prop](neighbourhood V M)
-            ->(EXT y:R |
-                   (intersection_domain V
-                     (image_dir g [c:R]``a <= c <= b``) y)) H9).
-Elim H10; Intros V0 H11; Exists V0; Assert H12 := (imply_to_and ? ? H11); Elim H12; Clear H12; Intros.
-Split.
-Apply H12.
-Apply (not_ex_all_not ? ? H13).
-Red; Intro; Cut (adherence (image_dir g [c:R]``a <= c <= b``) M).
-Intro; Elim (closed_set_P1 (image_dir g [c:R]``a <= c <= b``)); Intros H11 _; Assert H12 := (H11 H3).
-Elim H8.
-Unfold eq_Dom in H12; Elim H12; Clear H12; Intros.
-Apply (H13 ? H10).
-Apply H9.
-Exists (g a); Unfold image_dir; Exists a; Split.
-Reflexivity.
-Split; [Right; Reflexivity | Apply H].
-Unfold bound; Unfold bounded in H4; Elim H4; Clear H4; Intros m H4; Elim H4; Clear H4; Intros M H4; Exists M; Unfold is_upper_bound; Intros; Elim (H4 ? H5); Intros _ H6; Apply H6.
-Apply prolongement_C0; Assumption.
-Qed.
-
-(**********)
-Lemma continuity_ab_min : (f:(R->R); a,b:R) ``a <= b``->((c:R)``a<=c<=b``->(continuity_pt f c))->(EXT mx:R | ((c:R)``a <= c <= b``->``(f mx) <= (f c)``)/\``a <= mx <= b``).
-Intros.
-Cut ((c:R)``a<=c<=b``->(continuity_pt (opp_fct f0) c)).
-Intro; Assert H2 := (continuity_ab_maj (opp_fct f0) a b H H1); Elim H2; Intros x0 H3; Exists x0; Intros; Split.
-Intros; Rewrite <- (Ropp_Ropp (f0 x0)); Rewrite <- (Ropp_Ropp (f0 c)); Apply Rle_Ropp1; Elim H3; Intros; Unfold opp_fct in H5; Apply H5; Apply H4.
-Elim H3; Intros; Assumption.
-Intros.
-Assert H2 := (H0 ? H1).
-Apply (continuity_pt_opp ? ? H2).
-Qed.
-
-
-(********************************************************)
-(*         Proof of Bolzano-Weierstrass theorem         *)
-(********************************************************)
-
-Definition ValAdh [un:nat->R;x:R] : Prop := (V:R->Prop;N:nat) (neighbourhood V x) -> (EX p:nat | (le N p)/\(V (un p))).
-
-Definition intersection_family [f:family] : R->Prop := [x:R](y:R)(ind f y)->(f y x).
-
-Lemma ValAdh_un_exists : (un:nat->R) let D=[x:R](EX n:nat | x==(INR n)) in let f=[x:R](adherence [y:R](EX p:nat | y==(un p)/\``x<=(INR p)``)/\(D x)) in ((x:R)(EXT y:R | (f x y))->(D x)).
-Intros; Elim H; Intros; Unfold f in H0; Unfold adherence in H0; Unfold point_adherent in H0; Assert H1 : (neighbourhood (disc x0 (mkposreal ? Rlt_R0_R1)) x0).
-Unfold neighbourhood disc; Exists (mkposreal ? Rlt_R0_R1); Unfold included; Trivial.
-Elim (H0 ? H1); Intros; Unfold intersection_domain in H2; Elim H2; Intros; Elim H4; Intros; Apply H6.
-Qed.
-
-Definition ValAdh_un [un:nat->R] : R->Prop := let D=[x:R](EX n:nat | x==(INR n)) in let f=[x:R](adherence [y:R](EX p:nat | y==(un p)/\``x<=(INR p)``)/\(D x)) in (intersection_family (mkfamily D f (ValAdh_un_exists un))).
-
-Lemma ValAdh_un_prop : (un:nat->R;x:R) (ValAdh un x) <-> (ValAdh_un un x).
-Intros; Split; Intro.
-Unfold ValAdh in H; Unfold ValAdh_un; Unfold intersection_family; Simpl; Intros; Elim H0; Intros N H1; Unfold adherence; Unfold point_adherent; Intros; Elim (H V N H2); Intros; Exists (un x0); Unfold intersection_domain; Elim H3; Clear H3; Intros; Split.
-Assumption.
-Split.
-Exists x0; Split; [Reflexivity | Rewrite H1; Apply (le_INR ? ? H3)].
-Exists N; Assumption.
-Unfold ValAdh; Intros; Unfold ValAdh_un in H; Unfold intersection_family in H; Simpl in H; Assert H1 : (adherence [y0:R](EX p:nat | ``y0 == (un p)``/\``(INR N) <= (INR p)``)/\(EX n:nat | ``(INR N) == (INR n)``) x).
-Apply H; Exists N; Reflexivity.
-Unfold adherence in H1; Unfold point_adherent in H1; Assert H2 := (H1 ? H0); Elim H2; Intros; Unfold intersection_domain in H3; Elim H3; Clear H3; Intros; Elim H4; Clear H4; Intros; Elim H4; Clear H4; Intros; Elim H4; Clear H4; Intros; Exists x1; Split.
-Apply (INR_le ? ? H6).
-Rewrite H4 in H3; Apply H3.
-Qed.
-
-Lemma adherence_P4 : (F,G:R->Prop) (included F G) -> (included (adherence F) (adherence G)).
-Unfold adherence included; Unfold point_adherent; Intros; Elim (H0 ? H1); Unfold intersection_domain; Intros; Elim H2; Clear H2; Intros; Exists x0; Split; [Assumption | Apply (H ? H3)].
-Qed.
-
-Definition family_closed_set [f:family] : Prop := (x:R) (closed_set (f x)).
-
-Definition intersection_vide_in [D:R->Prop;f:family] : Prop := ((x:R)((ind f x)->(included (f x) D))/\~(EXT y:R | (intersection_family f y))).
-
-Definition intersection_vide_finite_in [D:R->Prop;f:family] : Prop := (intersection_vide_in D f)/\(family_finite f).
-
-(**********)
-Lemma compact_P6 : (X:R->Prop) (compact X) -> (EXT z:R | (X z)) -> ((g:family) (family_closed_set g) -> (intersection_vide_in X g) -> (EXT D:R->Prop | (intersection_vide_finite_in X (subfamily g D)))).
-Intros X H Hyp g H0 H1.
-Pose D' := (ind g).
-Pose f' := [x:R][y:R](complementary (g x) y)/\(D' x).
-Assert H2 : (x:R)(EXT y:R|(f' x y))->(D' x).
-Intros; Elim H2; Intros; Unfold f' in H3; Elim H3; Intros; Assumption.
-Pose f0 := (mkfamily D' f' H2).
-Unfold compact in H; Assert H3 : (covering_open_set X f0).
-Unfold covering_open_set; Split.
-Unfold covering; Intros; Unfold intersection_vide_in in H1; Elim (H1 x); Intros; Unfold intersection_family in H5; Assert H6 := (not_ex_all_not ? [y:R](y0:R)(ind g y0)->(g y0 y) H5 x); Assert H7 := (not_all_ex_not ? [y0:R](ind g y0)->(g y0 x) H6); Elim H7; Intros; Exists x0; Elim (imply_to_and ? ? H8); Intros; Unfold f0; Simpl; Unfold f'; Split; [Apply H10 | Apply H9].
-Unfold family_open_set; Intro; Elim (classic (D' x)); Intro.
-Apply open_set_P6 with (complementary (g x)).
-Unfold family_closed_set in H0; Unfold closed_set in H0; Apply H0.
-Unfold f0; Simpl; Unfold f'; Unfold eq_Dom; Split.
-Unfold included; Intros; Split; [Apply H4 | Apply H3].
-Unfold included; Intros; Elim H4; Intros; Assumption.
-Apply open_set_P6 with [_:R]False.
-Apply open_set_P4.
-Unfold eq_Dom; Unfold included; Split; Intros; [Elim H4 | Simpl in H4; Unfold f' in H4; Elim H4; Intros; Elim H3; Assumption].
-Elim (H ? H3); Intros SF H4; Exists SF; Unfold intersection_vide_finite_in; Split.
-Unfold intersection_vide_in; Simpl; Intros; Split.
-Intros; Unfold included; Intros; Unfold intersection_vide_in in H1; Elim (H1 x); Intros; Elim H6; Intros; Apply H7.
-Unfold intersection_domain in H5; Elim H5; Intros; Assumption.
-Assumption.
-Elim (classic (EXT y:R | (intersection_domain (ind g) SF y))); Intro Hyp'.
-Red; Intro; Elim H5; Intros; Unfold intersection_family in H6; Simpl in H6.
-Cut (X x0).
-Intro; Unfold covering_finite in H4; Elim H4; Clear H4; Intros H4 _; Unfold covering in H4; Elim (H4 x0 H7); Intros; Simpl in H8; Unfold intersection_domain in H6; Cut (ind g x1)/\(SF x1).
-Intro; Assert H10 := (H6 x1 H9); Elim H10; Clear H10; Intros H10 _; Elim H8; Clear H8; Intros H8 _; Unfold f' in H8; Unfold complementary in H8; Elim H8; Clear H8; Intros H8 _; Elim H8; Assumption.
-Split.
-Apply (cond_fam f0).
-Exists x0; Elim H8; Intros; Assumption.
-Elim H8; Intros; Assumption.
-Unfold intersection_vide_in in H1; Elim Hyp'; Intros; Assert H8 := (H6 ? H7); Elim H8; Intros; Cut (ind g x1).
-Intro; Elim (H1 x1); Intros; Apply H12.
-Apply H11.
-Apply H9.
-Apply (cond_fam g); Exists x0; Assumption.
-Unfold covering_finite in H4; Elim H4; Clear H4; Intros H4 _; Cut (EXT z:R | (X z)).
-Intro; Elim H5; Clear H5; Intros; Unfold covering in H4; Elim (H4 x0 H5); Intros; Simpl in H6; Elim Hyp'; Exists x1; Elim H6; Intros; Unfold intersection_domain; Split.
-Apply (cond_fam f0); Exists x0; Apply H7.
-Apply H8.
-Apply Hyp.
-Unfold covering_finite in H4; Elim H4; Clear H4; Intros; Unfold family_finite in H5; Unfold domain_finite in H5; Unfold family_finite; Unfold domain_finite; Elim H5; Clear H5; Intros l H5; Exists l; Intro; Elim (H5 x); Intros; Split; Intro; [Apply H6; Simpl; Simpl in H8; Apply H8 | Apply (H7 H8)].
-Qed.
-
-Theorem Bolzano_Weierstrass : (un:nat->R;X:R->Prop) (compact X) -> ((n:nat)(X (un n))) -> (EXT l:R | (ValAdh un l)).
-Intros; Cut (EXT l:R | (ValAdh_un un l)).
-Intro; Elim H1; Intros; Exists x; Elim (ValAdh_un_prop un x); Intros; Apply (H4 H2).
-Assert H1 : (EXT z:R | (X z)).
-Exists (un O); Apply H0.
-Pose D:=[x:R](EX n:nat | x==(INR n)).
-Pose g:=[x:R](adherence [y:R](EX p:nat | y==(un p)/\``x<=(INR p)``)/\(D x)).
-Assert H2 : (x:R)(EXT y:R | (g x y))->(D x).
-Intros; Elim H2; Intros; Unfold g in H3; Unfold adherence in H3; Unfold point_adherent in H3.
-Assert H4 : (neighbourhood (disc x0 (mkposreal ? Rlt_R0_R1)) x0).
-Unfold neighbourhood; Exists (mkposreal ? Rlt_R0_R1); Unfold included; Trivial.
-Elim (H3 ? H4); Intros; Unfold intersection_domain in H5; Decompose [and] H5; Assumption.
-Pose f0 := (mkfamily D g H2).
-Assert H3 := (compact_P6 X H H1 f0).
-Elim (classic (EXT l:R | (ValAdh_un un l))); Intro.
-Assumption.
-Cut (family_closed_set f0).
-Intro; Cut (intersection_vide_in X f0).
-Intro; Assert H7 := (H3 H5 H6).
-Elim H7; Intros SF H8; Unfold intersection_vide_finite_in in H8; Elim H8; Clear H8; Intros; Unfold intersection_vide_in in H8; Elim (H8 R0); Intros _ H10; Elim H10; Unfold family_finite in H9; Unfold domain_finite in H9; Elim H9; Clear H9; Intros l H9; Pose r := (MaxRlist l); Cut (D r).
-Intro; Unfold D in H11; Elim H11; Intros; Exists (un x); Unfold intersection_family; Simpl; Unfold intersection_domain; Intros; Split.
-Unfold g; Apply adherence_P1; Split.
-Exists x; Split; [Reflexivity | Rewrite <- H12; Unfold r; Apply MaxRlist_P1; Elim (H9 y); Intros; Apply H14; Simpl; Apply H13].
-Elim H13; Intros; Assumption.
-Elim H13; Intros; Assumption.
-Elim (H9 r); Intros.
-Simpl in H12; Unfold intersection_domain in H12; Cut (In r l).
-Intro; Elim (H12 H13); Intros; Assumption.
-Unfold r; Apply MaxRlist_P2; Cut (EXT z:R | (intersection_domain (ind f0) SF z)).
-Intro; Elim H13; Intros; Elim (H9 x); Intros; Simpl in H15; Assert H17 := (H15 H14); Exists x; Apply H17.
-Elim (classic (EXT z:R | (intersection_domain (ind f0) SF z))); Intro.
-Assumption.
-Elim (H8 R0); Intros _ H14; Elim H1; Intros; Assert H16 := (not_ex_all_not ? [y:R](intersection_family (subfamily f0 SF) y) H14); Assert H17 := (not_ex_all_not ? [z:R](intersection_domain (ind f0) SF z) H13); Assert H18 := (H16 x); Unfold intersection_family in H18; Simpl in H18; Assert H19 := (not_all_ex_not ? [y:R](intersection_domain D SF y)->(g y x)/\(SF y) H18); Elim H19; Intros; Assert H21 := (imply_to_and ? ? H20); Elim (H17 x0); Elim H21; Intros; Assumption.
-Unfold intersection_vide_in; Intros; Split.
-Intro; Simpl in H6; Unfold f0; Simpl; Unfold g; Apply included_trans with (adherence X).
-Apply adherence_P4.
-Unfold included; Intros; Elim H7; Intros; Elim H8; Intros; Elim H10; Intros; Rewrite H11; Apply H0.
-Apply adherence_P2; Apply compact_P2; Assumption.
-Apply H4.
-Unfold family_closed_set; Unfold f0; Simpl; Unfold g; Intro; Apply adherence_P3.
-Qed.
-
-(********************************************************)
-(*               Proof of Heine's theorem               *)
-(********************************************************)
-
-Definition uniform_continuity [f:R->R;X:R->Prop] : Prop := (eps:posreal)(EXT delta:posreal | (x,y:R) (X x)->(X y)->``(Rabsolu (x-y))<delta`` ->``(Rabsolu ((f x)-(f y)))<eps``).
-
-Lemma is_lub_u : (E:R->Prop;x,y:R) (is_lub E x) -> (is_lub E y) -> x==y.
-Unfold is_lub; Intros; Elim H; Elim H0; Intros; Apply Rle_antisym; [Apply (H4 ? H1) | Apply (H2 ? H3)].
-Qed.
-
-Lemma domain_P1 : (X:R->Prop) ~(EXT y:R | (X y))\/(EXT y:R | (X y)/\((x:R)(X x)->x==y))\/(EXT x:R | (EXT y:R | (X x)/\(X y)/\``x<>y``)).
-Intro; Elim (classic (EXT y:R | (X y))); Intro.
-Right; Elim H; Intros; Elim (classic (EXT y:R | (X y)/\``y<>x``)); Intro.
-Right; Elim H1; Intros; Elim H2; Intros; Exists x; Exists x0; Intros.
-Split; [Assumption | Split; [Assumption | Apply not_sym; Assumption]].
-Left; Exists x; Split.
-Assumption.
-Intros; Case (Req_EM x0 x); Intro.
-Assumption.
-Elim H1; Exists x0; Split; Assumption.
-Left; Assumption.
-Qed.
-
-Theorem Heine : (f:R->R;X:R->Prop) (compact X) -> ((x:R)(X x)->(continuity_pt f x)) -> (uniform_continuity f X).
-Intros f0 X H0 H; Elim (domain_P1 X); Intro Hyp.
-(* X est vide *)
-Unfold uniform_continuity; Intros; Exists (mkposreal ? Rlt_R0_R1); Intros; Elim Hyp; Exists x; Assumption.
-Elim Hyp; Clear Hyp; Intro Hyp.
-(* X possède un seul élément *)
-Unfold uniform_continuity; Intros; Exists (mkposreal ? Rlt_R0_R1); Intros; Elim Hyp; Clear Hyp; Intros; Elim H4; Clear H4; Intros; Assert H6 := (H5 ? H1); Assert H7 := (H5 ? H2); Rewrite H6; Rewrite H7; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply (cond_pos eps).
-(* X possède au moins deux éléments distincts *)
-Assert X_enc : (EXT m:R | (EXT M:R | ((x:R)(X x)->``m<=x<=M``)/\``m<M``)).
-Assert H1 := (compact_P1 X H0); Unfold bounded in H1; Elim H1; Intros; Elim H2; Intros; Exists x; Exists x0; Split.
-Apply H3.
-Elim Hyp; Intros; Elim H4; Intros; Decompose [and] H5; Assert H10 := (H3 ? H6); Assert H11 := (H3 ? H8); Elim H10; Intros; Elim H11; Intros; Case (total_order_T x x0); Intro.
-Elim s; Intro.
-Assumption.
-Rewrite b in H13; Rewrite b in H7; Elim H9; Apply Rle_antisym; Apply Rle_trans with x0; Assumption.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? (Rle_trans ? ? ? H13 H14) r)).
-Elim X_enc; Clear X_enc; Intros m X_enc; Elim X_enc; Clear X_enc; Intros M X_enc; Elim X_enc; Clear X_enc Hyp; Intros X_enc Hyp; Unfold uniform_continuity; Intro; Assert H1 : (t:posreal)``0<t/2``.
-Intro; Unfold Rdiv; Apply Rmult_lt_pos; [Apply (cond_pos t) | Apply Rlt_Rinv; Sup0].
-Pose g := [x:R][y:R](X x)/\(EXT del:posreal | ((z:R) ``(Rabsolu (z-x))<del``->``(Rabsolu ((f0 z)-(f0 x)))<eps/2``)/\(is_lub [zeta:R]``0<zeta<=M-m``/\((z:R) ``(Rabsolu (z-x))<zeta``->``(Rabsolu ((f0 z)-(f0 x)))<eps/2``) del)/\(disc x (mkposreal ``del/2`` (H1 del)) y)).
-Assert H2 : (x:R)(EXT y:R | (g x y))->(X x).
-Intros; Elim H2; Intros; Unfold g in H3; Elim H3; Clear H3; Intros H3 _; Apply H3.
-Pose f' := (mkfamily X g H2); Unfold compact in H0; Assert H3 : (covering_open_set X f').
-Unfold covering_open_set; Split.
-Unfold covering; Intros; Exists x; Simpl; Unfold g; Split.
-Assumption.
-Assert H4 := (H ? H3); Unfold continuity_pt in H4; Unfold continue_in in H4; Unfold limit1_in in H4; Unfold limit_in in H4; Simpl in H4; Unfold R_dist in H4; Elim (H4 ``eps/2`` (H1 eps)); Intros; Pose E:=[zeta:R]``0<zeta <= M-m``/\((z:R)``(Rabsolu (z-x)) < zeta``->``(Rabsolu ((f0 z)-(f0 x))) < eps/2``); Assert H6 : (bound E).
-Unfold bound; Exists ``M-m``; Unfold is_upper_bound; Unfold E; Intros; Elim H6; Clear H6; Intros H6 _; Elim H6; Clear H6; Intros _ H6; Apply H6.
-Assert H7 : (EXT x:R | (E x)).
-Elim H5; Clear H5; Intros; Exists (Rmin x0 ``M-m``); Unfold E; Intros; Split.
-Split.
-Unfold Rmin; Case (total_order_Rle x0 ``M-m``); Intro.
-Apply H5.
-Apply Rlt_Rminus; Apply Hyp.
-Apply Rmin_r.
-Intros; Case (Req_EM x z); Intro.
-Rewrite H9; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply (H1 eps).
-Apply H7; Split.
-Unfold D_x no_cond; Split; [Trivial | Assumption].
-Apply Rlt_le_trans with (Rmin x0 ``M-m``); [Apply H8 | Apply Rmin_l].
-Assert H8 := (complet ? H6 H7); Elim H8; Clear H8; Intros; Cut ``0<x1<=(M-m)``.
-Intro; Elim H8; Clear H8; Intros; Exists (mkposreal ? H8); Split.
-Intros; Cut (EXT alp:R | ``(Rabsolu (z-x))<alp<=x1``/\(E alp)).
-Intros; Elim H11; Intros; Elim H12; Clear H12; Intros; Unfold E in H13; Elim H13; Intros; Apply H15.
-Elim H12; Intros; Assumption.
-Elim (classic (EXT alp:R | ``(Rabsolu (z-x)) < alp <= x1``/\(E alp))); Intro.
-Assumption.
-Assert H12 := (not_ex_all_not ? [alp:R]``(Rabsolu (z-x)) < alp <= x1``/\(E alp) H11); Unfold is_lub in p; Elim p; Intros; Cut (is_upper_bound E ``(Rabsolu (z-x))``).
-Intro; Assert H16 := (H14 ? H15); Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H10 H16)).
-Unfold is_upper_bound; Intros; Unfold is_upper_bound in H13; Assert H16 := (H13 ? H15); Case (total_order_Rle x2 ``(Rabsolu (z-x))``); Intro.
-Assumption.
-Elim (H12 x2); Split; [Split; [Auto with real | Assumption] | Assumption].
-Split.
-Apply p.
-Unfold disc; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Simpl; Unfold Rdiv; Apply Rmult_lt_pos; [Apply H8 | Apply Rlt_Rinv; Sup0].
-Elim H7; Intros; Unfold E in H8; Elim H8; Intros H9 _; Elim H9; Intros H10 _; Unfold is_lub in p; Elim p; Intros; Unfold is_upper_bound in H12; Unfold is_upper_bound in H11; Split.
-Apply Rlt_le_trans with x2; [Assumption | Apply (H11 ? H8)].
-Apply H12; Intros; Unfold E in H13; Elim H13; Intros; Elim H14; Intros; Assumption.
-Unfold family_open_set; Intro; Simpl; Elim (classic (X x)); Intro.
-Unfold g; Unfold open_set; Intros; Elim H4; Clear H4; Intros _ H4; Elim H4; Clear H4; Intros; Elim H4; Clear H4; Intros; Unfold neighbourhood; Case (Req_EM x x0); Intro.
-Exists (mkposreal ? (H1 x1)); Rewrite <- H6; Unfold included; Intros; Split.
-Assumption.
-Exists x1; Split.
-Apply H4.
-Split.
-Elim H5; Intros; Apply H8.
-Apply H7.
-Pose d := ``x1/2-(Rabsolu (x0-x))``; Assert H7 : ``0<d``.
-Unfold d; Apply Rlt_Rminus; Elim H5; Clear H5; Intros; Unfold disc in H7; Apply H7.
-Exists (mkposreal ? H7); Unfold included; Intros; Split.
-Assumption.
-Exists x1; Split.
-Apply H4.
-Elim H5; Intros; Split.
-Assumption.
-Unfold disc in H8; Simpl in H8; Unfold disc; Simpl; Unfold disc in H10; Simpl in H10; Apply Rle_lt_trans with ``(Rabsolu (x2-x0))+(Rabsolu (x0-x))``.
-Replace ``x2-x`` with ``(x2-x0)+(x0-x)``; [Apply Rabsolu_triang | Ring].
-Replace ``x1/2`` with ``d+(Rabsolu (x0-x))``; [Idtac | Unfold d; Ring].
-Do 2 Rewrite <- (Rplus_sym ``(Rabsolu (x0-x))``); Apply Rlt_compatibility; Apply H8.
-Apply open_set_P6 with [_:R]False.
-Apply open_set_P4.
-Unfold eq_Dom; Unfold included; Intros; Split.
-Intros; Elim H4.
-Intros; Unfold g in H4; Elim H4; Clear H4; Intros H4 _; Elim H3; Apply H4.
-Elim (H0 ? H3); Intros DF H4; Unfold covering_finite in H4; Elim H4; Clear H4; Intros; Unfold family_finite in H5; Unfold domain_finite in H5; Unfold covering in H4; Simpl in H4; Simpl in H5; Elim H5; Clear H5; Intros l H5; Unfold intersection_domain in H5; Cut (x:R)(In x l)->(EXT del:R | ``0<del``/\((z:R)``(Rabsolu (z-x)) < del``->``(Rabsolu ((f0 z)-(f0 x))) < eps/2``)/\(included (g x) [z:R]``(Rabsolu (z-x))<del/2``)).
-Intros; Assert H7 := (Rlist_P1 l [x:R][del:R]``0<del``/\((z:R)``(Rabsolu (z-x)) < del``->``(Rabsolu ((f0 z)-(f0 x))) < eps/2``)/\(included (g x) [z:R]``(Rabsolu (z-x))<del/2``) H6); Elim H7; Clear H7; Intros l' H7; Elim H7; Clear H7; Intros; Pose D := (MinRlist l'); Cut ``0<D/2``.
-Intro; Exists (mkposreal ? H9); Intros; Assert H13 := (H4 ? H10); Elim H13; Clear H13; Intros xi H13; Assert H14 : (In xi l).
-Unfold g in H13; Decompose [and] H13; Elim (H5 xi); Intros; Apply H14; Split; Assumption.
-Elim (pos_Rl_P2 l xi); Intros H15 _; Elim (H15 H14); Intros i H16; Elim H16; Intros; Apply Rle_lt_trans with ``(Rabsolu ((f0 x)-(f0 xi)))+(Rabsolu ((f0 xi)-(f0 y)))``.
-Replace ``(f0 x)-(f0 y)`` with ``((f0 x)-(f0 xi))+((f0 xi)-(f0 y))``; [Apply Rabsolu_triang | Ring].
-Rewrite (double_var eps); Apply Rplus_lt.
-Assert H19 := (H8 i H17); Elim H19; Clear H19; Intros; Rewrite <- H18 in H20; Elim H20; Clear H20; Intros; Apply H20; Unfold included in H21; Apply Rlt_trans with ``(pos_Rl l' i)/2``.
-Apply H21.
-Elim H13; Clear H13; Intros; Assumption.
-Unfold Rdiv; Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Rewrite Rmult_sym; Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Pattern 1 (pos_Rl l' i); Rewrite <- Rplus_Or; Rewrite double; Apply Rlt_compatibility; Apply H19.
-DiscrR.
-Assert H19 := (H8 i H17); Elim H19; Clear H19; Intros; Rewrite <- H18 in H20; Elim H20; Clear H20; Intros; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H20; Unfold included in H21; Elim H13; Intros; Assert H24 := (H21 x H22); Apply Rle_lt_trans with ``(Rabsolu (y-x))+(Rabsolu (x-xi))``.
-Replace ``y-xi`` with ``(y-x)+(x-xi)``; [Apply Rabsolu_triang | Ring].
-Rewrite (double_var (pos_Rl l' i)); Apply Rplus_lt.
-Apply Rlt_le_trans with ``D/2``.
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H12.
-Unfold Rdiv; Do 2 Rewrite <- (Rmult_sym ``/2``); Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Sup0.
-Unfold D; Apply MinRlist_P1; Elim (pos_Rl_P2 l' (pos_Rl l' i)); Intros; Apply H26; Exists i; Split; [Rewrite <- H7; Assumption | Reflexivity].
-Assumption.
-Unfold Rdiv; Apply Rmult_lt_pos; [Unfold D; Apply MinRlist_P2; Intros; Elim (pos_Rl_P2 l' y); Intros; Elim (H10 H9); Intros; Elim H12; Intros; Rewrite H14; Rewrite <- H7 in H13; Elim (H8 x H13); Intros; Apply H15 | Apply Rlt_Rinv; Sup0].
-Intros; Elim (H5 x); Intros; Elim (H8 H6); Intros; Pose E:=[zeta:R]``0<zeta <= M-m``/\((z:R)``(Rabsolu (z-x)) < zeta``->``(Rabsolu ((f0 z)-(f0 x))) < eps/2``); Assert H11 : (bound E).
-Unfold bound; Exists ``M-m``; Unfold is_upper_bound; Unfold E; Intros; Elim H11; Clear H11; Intros H11 _; Elim H11; Clear H11; Intros _ H11; Apply H11.
-Assert H12 : (EXT x:R | (E x)).
-Assert H13 := (H ? H9); Unfold continuity_pt in H13; Unfold continue_in in H13; Unfold limit1_in in H13; Unfold limit_in in H13; Simpl in H13; Unfold R_dist in H13; Elim (H13 ? (H1 eps)); Intros; Elim H12; Clear H12; Intros; Exists (Rmin x0 ``M-m``); Unfold E; Intros; Split.
-Split; [Unfold Rmin; Case (total_order_Rle x0 ``M-m``); Intro; [Apply H12 | Apply Rlt_Rminus; Apply Hyp] | Apply Rmin_r].
-Intros; Case (Req_EM x z); Intro.
-Rewrite H16; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Apply (H1 eps).
-Apply H14; Split; [Unfold D_x no_cond; Split; [Trivial | Assumption] | Apply Rlt_le_trans with (Rmin x0 ``M-m``); [Apply H15 | Apply Rmin_l]].
-Assert H13 := (complet ? H11 H12); Elim H13; Clear H13; Intros; Cut ``0<x0<=M-m``.
-Intro; Elim H13; Clear H13; Intros; Exists x0; Split.
-Assumption.
-Split.
-Intros; Cut (EXT alp:R | ``(Rabsolu (z-x))<alp<=x0``/\(E alp)).
-Intros; Elim H16; Intros; Elim H17; Clear H17; Intros; Unfold E in H18; Elim H18; Intros; Apply H20; Elim H17; Intros; Assumption.
-Elim (classic (EXT alp:R | ``(Rabsolu (z-x)) < alp <= x0``/\(E alp))); Intro.
-Assumption.
-Assert H17 := (not_ex_all_not ? [alp:R]``(Rabsolu (z-x)) < alp <= x0``/\(E alp) H16); Unfold is_lub in p; Elim p; Intros; Cut (is_upper_bound E ``(Rabsolu (z-x))``).
-Intro; Assert H21 := (H19 ? H20); Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H15 H21)).
-Unfold is_upper_bound; Intros; Unfold is_upper_bound in H18; Assert H21 := (H18 ? H20); Case (total_order_Rle x1 ``(Rabsolu (z-x))``); Intro.
-Assumption.
-Elim (H17 x1); Split.
-Split; [Auto with real | Assumption].
-Assumption.
-Unfold included g; Intros; Elim H15; Intros; Elim H17; Intros; Decompose [and] H18; Cut x0==x2.
-Intro; Rewrite H20; Apply H22.
-Unfold E in p; EApply is_lub_u.
-Apply p.
-Apply H21.
-Elim H12; Intros; Unfold E in H13; Elim H13; Intros H14 _; Elim H14; Intros H15 _; Unfold is_lub in p; Elim p; Intros; Unfold is_upper_bound in H16; Unfold is_upper_bound in H17; Split.
-Apply Rlt_le_trans with x1; [Assumption | Apply (H16 ? H13)].
-Apply H17; Intros; Unfold E in H18; Elim H18; Intros; Elim H19; Intros; Assumption.
-Qed.
diff --git a/theories7/Reals/Rtrigo.v b/theories7/Reals/Rtrigo.v
deleted file mode 100644
index 2b19a00a..00000000
--- a/theories7/Reals/Rtrigo.v
+++ /dev/null
@@ -1,1111 +0,0 @@
-(************************************************************************)
-(*  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: Rtrigo.v,v 1.1.2.1 2004/07/16 19:31:35 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Export Rtrigo_fun.
-Require Export Rtrigo_def.
-Require Export Rtrigo_alt.
-Require Export Cos_rel.
-Require Export Cos_plus.
-Require ZArith_base.
-Require Zcomplements.
-Require Classical_Prop.
-V7only [Import nat_scope. Import Z_scope. Import R_scope.].
-Open Local Scope nat_scope.
-Open Local Scope R_scope.
-
-(** sin_PI2 is the only remaining axiom **)
-Axiom sin_PI2 : ``(sin (PI/2))==1``.
-
-(**********)
-Lemma PI_neq0 : ~``PI==0``.
-Red; Intro; Assert H0 := PI_RGT_0; Rewrite H in H0; Elim (Rlt_antirefl ? H0).
-Qed.
-
-(**********) 
-Lemma cos_minus : (x,y:R) ``(cos (x-y))==(cos x)*(cos y)+(sin x)*(sin y)``.
-Intros; Unfold Rminus; Rewrite cos_plus.
-Rewrite <- cos_sym; Rewrite sin_antisym; Ring.
-Qed.
-
-(**********)
-Lemma sin2_cos2 : (x:R) ``(Rsqr (sin x)) + (Rsqr (cos x))==1``.
-Intro; Unfold Rsqr; Rewrite Rplus_sym; Rewrite <- (cos_minus x x); Unfold Rminus; Rewrite Rplus_Ropp_r; Apply cos_0.
-Qed.
-
-Lemma cos2 : (x:R) ``(Rsqr (cos x))==1-(Rsqr (sin x))``.
-Intro x; Generalize (sin2_cos2 x); Intro H1; Rewrite <- H1; Unfold Rminus; Rewrite <- (Rplus_sym (Rsqr (cos x))); Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Symmetry; Apply Rplus_Or.
-Qed.
-
-(**********)
-Lemma cos_PI2 : ``(cos (PI/2))==0``.
-Apply Rsqr_eq_0; Rewrite cos2; Rewrite sin_PI2; Rewrite Rsqr_1; Unfold Rminus; Apply Rplus_Ropp_r.
-Qed.
-
-(**********)
-Lemma cos_PI : ``(cos PI)==-1``.
-Replace ``PI`` with ``PI/2+PI/2``.
-Rewrite cos_plus.
-Rewrite sin_PI2; Rewrite cos_PI2.
-Ring.
-Symmetry; Apply double_var.
-Qed.
-
-Lemma sin_PI : ``(sin PI)==0``.
-Assert H := (sin2_cos2 PI).
-Rewrite cos_PI in H.
-Rewrite <- Rsqr_neg in H.
-Rewrite Rsqr_1 in H.
-Cut (Rsqr (sin PI))==R0.
-Intro; Apply (Rsqr_eq_0 ? H0).
-Apply r_Rplus_plus with R1.
-Rewrite Rplus_Or; Rewrite Rplus_sym; Exact H.
-Qed.
-
-(**********)
-Lemma neg_cos : (x:R) ``(cos (x+PI))==-(cos x)``.
-Intro x; Rewrite -> cos_plus; Rewrite -> sin_PI; Rewrite -> cos_PI; Ring.
-Qed.
-
-(**********)
-Lemma sin_cos : (x:R) ``(sin x)==-(cos (PI/2+x))``.
-Intro x; Rewrite -> cos_plus; Rewrite -> sin_PI2; Rewrite -> cos_PI2; Ring.
-Qed.
-
-(**********)
-Lemma sin_plus : (x,y:R) ``(sin (x+y))==(sin x)*(cos y)+(cos x)*(sin y)``.
-Intros.
-Rewrite (sin_cos ``x+y``).
-Replace ``PI/2+(x+y)`` with ``(PI/2+x)+y``; [Rewrite cos_plus | Ring].
-Rewrite (sin_cos ``PI/2+x``).
-Replace ``PI/2+(PI/2+x)`` with ``x+PI``.
-Rewrite neg_cos.
-Replace (cos ``PI/2+x``) with ``-(sin x)``.
-Ring.
-Rewrite sin_cos; Rewrite Ropp_Ropp; Reflexivity.
-Pattern 1 PI; Rewrite (double_var PI); Ring.
-Qed.
-
-Lemma sin_minus : (x,y:R) ``(sin (x-y))==(sin x)*(cos y)-(cos x)*(sin y)``.
-Intros; Unfold Rminus; Rewrite sin_plus.
-Rewrite <- cos_sym; Rewrite sin_antisym; Ring.
-Qed.
-
-(**********)
-Definition tan [x:R] : R := ``(sin x)/(cos x)``.
-
-Lemma tan_plus : (x,y:R) ~``(cos x)==0`` -> ~``(cos y)==0`` -> ~``(cos (x+y))==0`` -> ~``1-(tan x)*(tan y)==0`` -> ``(tan (x+y))==((tan x)+(tan y))/(1-(tan x)*(tan y))``.
-Intros; Unfold tan; Rewrite sin_plus; Rewrite cos_plus; Unfold Rdiv; Replace ``((cos x)*(cos y)-(sin x)*(sin y))`` with ``((cos x)*(cos y))*(1-(sin x)*/(cos x)*((sin y)*/(cos y)))``.
-Rewrite Rinv_Rmult.
-Repeat Rewrite <- Rmult_assoc; Replace ``((sin x)*(cos y)+(cos x)*(sin y))*/((cos x)*(cos y))`` with ``((sin x)*/(cos x)+(sin y)*/(cos y))``.
-Reflexivity.
-Rewrite Rmult_Rplus_distrl; Rewrite Rinv_Rmult.
-Repeat Rewrite Rmult_assoc; Repeat Rewrite (Rmult_sym ``(sin x)``); Repeat Rewrite <- Rmult_assoc.
-Repeat Rewrite Rinv_r_simpl_m; [Reflexivity | Assumption | Assumption].
-Assumption.
-Assumption.
-Apply prod_neq_R0; Assumption.
-Assumption.
-Unfold Rminus; Rewrite Rmult_Rplus_distr; Rewrite Rmult_1r; Apply Rplus_plus_r; Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym ``(sin x)``); Rewrite (Rmult_sym ``(cos y)``); Rewrite <- Ropp_mul3; Repeat Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite (Rmult_sym (sin x)); Rewrite <- Ropp_mul3; Repeat Rewrite Rmult_assoc; Apply Rmult_mult_r; Rewrite (Rmult_sym ``/(cos y)``); Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Apply Rmult_1r.
-Assumption.
-Assumption.
-Qed.
-
-(*******************************************************)
-(* Some properties of cos, sin and tan                 *)
-(*******************************************************)
-
-Lemma sin2 : (x:R) ``(Rsqr (sin x))==1-(Rsqr (cos x))``.
-Intro x; Generalize (cos2 x); Intro H1; Rewrite -> H1.
-Unfold Rminus; Rewrite Ropp_distr1; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Ol; Symmetry; Apply Ropp_Ropp.
-Qed.
-
-Lemma sin_2a : (x:R) ``(sin (2*x))==2*(sin x)*(cos x)``.
-Intro x; Rewrite double; Rewrite sin_plus.
-Rewrite <- (Rmult_sym (sin x)); Symmetry; Rewrite Rmult_assoc; Apply double.
-Qed.
-
-Lemma cos_2a : (x:R) ``(cos (2*x))==(cos x)*(cos x)-(sin x)*(sin x)``.
-Intro x; Rewrite double; Apply cos_plus.
-Qed.
-
-Lemma cos_2a_cos : (x:R) ``(cos (2*x))==2*(cos x)*(cos x)-1``.
-Intro x; Rewrite double; Unfold Rminus; Rewrite Rmult_assoc; Rewrite cos_plus; Generalize (sin2_cos2 x); Rewrite double; Intro H1; Rewrite <- H1; SqRing.
-Qed.
-
-Lemma cos_2a_sin : (x:R) ``(cos (2*x))==1-2*(sin x)*(sin x)``.
-Intro x; Rewrite Rmult_assoc; Unfold Rminus; Repeat Rewrite double.
-Generalize (sin2_cos2 x); Intro H1; Rewrite <- H1; Rewrite cos_plus; SqRing.
-Qed.
-
-Lemma tan_2a : (x:R) ~``(cos x)==0`` -> ~``(cos (2*x))==0`` -> ~``1-(tan x)*(tan x)==0`` ->``(tan (2*x))==(2*(tan x))/(1-(tan x)*(tan x))``.
-Repeat Rewrite double; Intros; Repeat Rewrite double; Rewrite double in H0; Apply tan_plus; Assumption.
-Qed.
-
-Lemma sin_neg : (x:R) ``(sin (-x))==-(sin x)``.
-Apply sin_antisym.
-Qed.
-
-Lemma cos_neg : (x:R) ``(cos (-x))==(cos x)``.
-Intro; Symmetry; Apply cos_sym.
-Qed.
-
-Lemma tan_0 : ``(tan 0)==0``.
-Unfold tan; Rewrite -> sin_0; Rewrite -> cos_0.
-Unfold Rdiv; Apply Rmult_Ol. 
-Qed.
-
-Lemma tan_neg : (x:R) ``(tan (-x))==-(tan x)``.
-Intros x; Unfold tan; Rewrite sin_neg; Rewrite cos_neg; Unfold Rdiv.
-Apply Ropp_mul1.
-Qed.
-
-Lemma tan_minus : (x,y:R) ~``(cos x)==0`` -> ~``(cos y)==0`` -> ~``(cos (x-y))==0`` -> ~``1+(tan x)*(tan y)==0`` -> ``(tan (x-y))==((tan x)-(tan y))/(1+(tan x)*(tan y))``.
-Intros; Unfold Rminus; Rewrite tan_plus.
-Rewrite tan_neg; Unfold Rminus; Rewrite <- Ropp_mul1; Rewrite Ropp_mul2; Reflexivity.
-Assumption.
-Rewrite cos_neg; Assumption.
-Assumption.
-Rewrite tan_neg; Unfold Rminus; Rewrite <- Ropp_mul1; Rewrite Ropp_mul2; Assumption.
-Qed.
-
-Lemma cos_3PI2 : ``(cos (3*(PI/2)))==0``.
-Replace ``3*(PI/2)`` with ``PI+(PI/2)``.
-Rewrite -> cos_plus; Rewrite -> sin_PI; Rewrite -> cos_PI2; Ring.
-Pattern 1 PI; Rewrite (double_var PI).
-Ring.
-Qed.
-
-Lemma sin_2PI : ``(sin (2*PI))==0``.
-Rewrite -> sin_2a; Rewrite -> sin_PI; Ring.
-Qed.
-
-Lemma cos_2PI : ``(cos (2*PI))==1``.
-Rewrite -> cos_2a; Rewrite -> sin_PI; Rewrite -> cos_PI; Ring.
-Qed.
-
-Lemma neg_sin : (x:R) ``(sin (x+PI))==-(sin x)``.
-Intro x; Rewrite -> sin_plus; Rewrite -> sin_PI; Rewrite -> cos_PI; Ring.
-Qed.
-
-Lemma sin_PI_x : (x:R) ``(sin (PI-x))==(sin x)``.
-Intro x; Rewrite -> sin_minus; Rewrite -> sin_PI; Rewrite -> cos_PI; Rewrite Rmult_Ol; Unfold Rminus; Rewrite Rplus_Ol; Rewrite Ropp_mul1; Rewrite Ropp_Ropp; Apply Rmult_1l.
-Qed.
-
-Lemma sin_period : (x:R)(k:nat) ``(sin (x+2*(INR k)*PI))==(sin x)``.
-Intros x k; Induction k.
-Cut ``x+2*(INR O)*PI==x``; [Intro; Rewrite H; Reflexivity | Ring].
-Replace ``x+2*(INR (S k))*PI`` with ``(x+2*(INR k)*PI)+(2*PI)``; [Rewrite -> sin_plus; Rewrite -> sin_2PI; Rewrite -> cos_2PI; Ring; Apply Hreck | Rewrite -> S_INR; Ring].
-Qed.
-
-Lemma cos_period : (x:R)(k:nat) ``(cos (x+2*(INR k)*PI))==(cos x)``.
-Intros x k; Induction k.
-Cut ``x+2*(INR O)*PI==x``; [Intro; Rewrite H; Reflexivity | Ring].
-Replace ``x+2*(INR (S k))*PI`` with ``(x+2*(INR k)*PI)+(2*PI)``; [Rewrite -> cos_plus; Rewrite -> sin_2PI; Rewrite -> cos_2PI; Ring; Apply Hreck | Rewrite -> S_INR; Ring].
-Qed.
-
-Lemma sin_shift : (x:R) ``(sin (PI/2-x))==(cos x)``.
-Intro x; Rewrite -> sin_minus; Rewrite -> sin_PI2; Rewrite -> cos_PI2; Ring.
-Qed.
-
-Lemma cos_shift : (x:R) ``(cos (PI/2-x))==(sin x)``.
-Intro x; Rewrite -> cos_minus; Rewrite -> sin_PI2; Rewrite -> cos_PI2; Ring.
-Qed.
-
-Lemma cos_sin : (x:R) ``(cos x)==(sin (PI/2+x))``.
-Intro x; Rewrite -> sin_plus; Rewrite -> sin_PI2; Rewrite -> cos_PI2; Ring.
-Qed.
-
-Lemma PI2_RGT_0 : ``0<PI/2``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply PI_RGT_0 | Apply Rlt_Rinv; Sup].
-Qed. 
-
-Lemma SIN_bound : (x:R) ``-1<=(sin x)<=1``.
-Intro; Case (total_order_Rle ``-1`` (sin x)); Intro.
-Case (total_order_Rle (sin x) ``1``); Intro.
-Split; Assumption.
-Cut ``1<(sin x)``.
-Intro; Generalize (Rsqr_incrst_1 ``1`` (sin x) H (Rlt_le ``0`` ``1`` Rlt_R0_R1) (Rlt_le ``0`` (sin x) (Rlt_trans ``0`` ``1`` (sin x) Rlt_R0_R1 H))); Rewrite Rsqr_1; Intro; Rewrite sin2 in H0; Unfold Rminus in H0; Generalize (Rlt_compatibility ``-1`` ``1`` ``1+ -(Rsqr (cos x))`` H0); Repeat Rewrite <- Rplus_assoc; Repeat Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Intro; Rewrite <- Ropp_O in H1; Generalize (Rlt_Ropp ``-0`` ``-(Rsqr (cos x))`` H1); Repeat Rewrite Ropp_Ropp; Intro; Generalize (pos_Rsqr (cos x)); Intro; Elim (Rlt_antirefl ``0`` (Rle_lt_trans ``0`` (Rsqr (cos x)) ``0`` H3 H2)).
-Auto with real.
-Cut ``(sin x)< -1``.
-Intro; Generalize (Rlt_Ropp (sin x) ``-1`` H); Rewrite Ropp_Ropp; Clear H; Intro; Generalize (Rsqr_incrst_1 ``1`` ``-(sin x)`` H (Rlt_le ``0`` ``1`` Rlt_R0_R1) (Rlt_le ``0`` ``-(sin x)`` (Rlt_trans ``0`` ``1`` ``-(sin x)`` Rlt_R0_R1 H))); Rewrite Rsqr_1; Intro; Rewrite <- Rsqr_neg in H0; Rewrite sin2 in H0; Unfold Rminus in H0; Generalize (Rlt_compatibility ``-1`` ``1`` ``1+ -(Rsqr (cos x))`` H0); Repeat Rewrite <- Rplus_assoc; Repeat Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Intro; Rewrite <- Ropp_O in H1; Generalize (Rlt_Ropp ``-0`` ``-(Rsqr (cos x))`` H1); Repeat Rewrite Ropp_Ropp; Intro; Generalize (pos_Rsqr (cos x)); Intro; Elim (Rlt_antirefl ``0`` (Rle_lt_trans ``0`` (Rsqr (cos x)) ``0`` H3 H2)).
-Auto with real.
-Qed.
-
-Lemma COS_bound : (x:R) ``-1<=(cos x)<=1``.
-Intro; Rewrite <- sin_shift; Apply SIN_bound.
-Qed.
-
-Lemma cos_sin_0 : (x:R) ~(``(cos x)==0``/\``(sin x)==0``).
-Intro; Red; Intro; Elim H; Intros; Generalize (sin2_cos2 x); Intro; Rewrite H0 in H2; Rewrite H1 in H2; Repeat Rewrite Rsqr_O in H2; Rewrite Rplus_Or in H2; Generalize Rlt_R0_R1; Intro; Rewrite <- H2 in H3; Elim (Rlt_antirefl ``0`` H3).
-Qed.
-  
-Lemma cos_sin_0_var : (x:R) ~``(cos x)==0``\/~``(sin x)==0``.
-Intro; Apply not_and_or; Apply cos_sin_0.
-Qed.
-
-(*****************************************************************)
-(* Using series definitions of cos and sin                       *)
-(*****************************************************************)
-
-Definition sin_lb [a:R] : R := (sin_approx a (3)).
-Definition sin_ub [a:R] : R := (sin_approx a (4)).
-Definition cos_lb [a:R] : R := (cos_approx a (3)).
-Definition cos_ub [a:R] : R := (cos_approx a (4)).
-
-Lemma sin_lb_gt_0 : (a:R) ``0<a``->``a<=PI/2``->``0<(sin_lb a)``.
-Intros.
-Unfold sin_lb; Unfold sin_approx; Unfold sin_term.
-Pose Un := [i:nat]``(pow a (plus (mult (S (S O)) i) (S O)))/(INR (fact (plus (mult (S (S O)) i) (S O))))``.
-Replace (sum_f_R0 [i:nat] ``(pow ( -1) i)*(pow a (plus (mult (S (S O)) i) (S O)))/(INR (fact (plus (mult (S (S O)) i) (S O))))`` (S (S (S O)))) with (sum_f_R0 [i:nat]``(pow (-1) i)*(Un i)`` (3)); [Idtac | Apply sum_eq; Intros; Unfold Un; Reflexivity].
-Cut (n:nat)``(Un (S n))<(Un n)``.
-Intro; Simpl.
-Repeat Rewrite Rmult_1l; Repeat Rewrite Rmult_1r; Replace ``-1*(Un (S O))`` with ``-(Un (S O))``; [Idtac | Ring]; Replace ``-1* -1*(Un (S (S O)))`` with ``(Un (S (S O)))``; [Idtac | Ring]; Replace ``-1*( -1* -1)*(Un (S (S (S O))))`` with ``-(Un (S (S (S O))))``; [Idtac | Ring]; Replace ``(Un O)+ -(Un (S O))+(Un (S (S O)))+ -(Un (S (S (S O))))`` with ``((Un O)-(Un (S O)))+((Un (S (S O)))-(Un (S (S (S O)))))``; [Idtac | Ring].
-Apply gt0_plus_gt0_is_gt0.
-Unfold Rminus; Apply Rlt_anti_compatibility with (Un (S O)); Rewrite Rplus_Or; Rewrite (Rplus_sym (Un (S O))); Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Apply H1.
-Unfold Rminus; Apply Rlt_anti_compatibility with (Un (S (S (S O)))); Rewrite Rplus_Or; Rewrite (Rplus_sym (Un (S (S (S O))))); Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Apply H1.
-Intro; Unfold Un.
-Cut (plus (mult (2) (S n)) (S O)) = (plus (plus (mult (2) n) (S O)) (2)).
-Intro; Rewrite H1.
-Rewrite pow_add; Unfold Rdiv; Rewrite Rmult_assoc; Apply Rlt_monotony.
-Apply pow_lt; Assumption.
-Rewrite <- H1; Apply Rlt_monotony_contra with (INR (fact (plus (mult (S (S O)) n) (S O)))).
-Apply lt_INR_0; Apply neq_O_lt.
-Assert H2 := (fact_neq_0 (plus (mult (2) n) (1))).
-Red; Intro; Elim H2; Symmetry; Assumption.
-Rewrite <- Rinv_r_sym.
-Apply Rlt_monotony_contra with (INR (fact (plus (mult (S (S O)) (S n)) (S O)))).
-Apply lt_INR_0; Apply neq_O_lt.
-Assert H2 := (fact_neq_0 (plus (mult (2) (S n)) (1))).
-Red; Intro; Elim H2; Symmetry; Assumption.
-Rewrite (Rmult_sym (INR (fact (plus (mult (S (S O)) (S n)) (S O))))); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Do 2 Rewrite Rmult_1r; Apply Rle_lt_trans with ``(INR (fact (plus (mult (S (S O)) n) (S O))))*4``.
-Apply Rle_monotony.
-Replace R0 with (INR O); [Idtac | Reflexivity]; Apply le_INR; Apply le_O_n.
-Simpl; Rewrite Rmult_1r; Replace ``4`` with ``(Rsqr 2)``; [Idtac | SqRing]; Replace ``a*a`` with (Rsqr a); [Idtac | Reflexivity]; Apply Rsqr_incr_1.
-Apply Rle_trans with ``PI/2``; [Assumption | Unfold Rdiv; Apply Rle_monotony_contra with ``2``; [ Sup0 | Rewrite <- Rmult_assoc;  Rewrite Rinv_r_simpl_m; [Replace ``2*2`` with ``4``; [Apply PI_4 | Ring] | DiscrR]]].
-Left; Assumption.
-Left; Sup0.
-Rewrite H1; Replace (plus (plus (mult (S (S O)) n) (S O)) (S (S O))) with (S (S (plus (mult (S (S O)) n) (S O)))).
-Do 2 Rewrite fact_simpl; Do 2 Rewrite mult_INR.
-Repeat Rewrite <- Rmult_assoc.
-Rewrite <- (Rmult_sym (INR (fact (plus (mult (S (S O)) n) (S O))))).
-Rewrite Rmult_assoc.
-Apply Rlt_monotony.
-Apply lt_INR_0; Apply neq_O_lt.
-Assert H2 := (fact_neq_0 (plus (mult (2) n) (1))).
-Red; Intro; Elim H2; Symmetry; Assumption.
-Do 2 Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Pose x := (INR n); Unfold INR.
-Replace ``(2*x+1+1+1)*(2*x+1+1)`` with ``4*x*x+10*x+6``; [Idtac | Ring].
-Apply Rlt_anti_compatibility with ``-4``; Rewrite Rplus_Ropp_l; Replace ``-4+(4*x*x+10*x+6)`` with ``(4*x*x+10*x)+2``; [Idtac | Ring].
-Apply ge0_plus_gt0_is_gt0.
-Cut ``0<=x``.
-Intro; Apply ge0_plus_ge0_is_ge0; Repeat Apply Rmult_le_pos; Assumption Orelse Left; Sup.
-Unfold x; Replace R0 with (INR O); [Apply le_INR; Apply le_O_n | Reflexivity].
-Sup0.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 3 Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_eq; Do 3 Rewrite plus_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Qed.
-
-Lemma SIN : (a:R) ``0<=a`` -> ``a<=PI`` -> ``(sin_lb a)<=(sin a)<=(sin_ub a)``.
-Intros; Unfold sin_lb sin_ub; Apply (sin_bound a (S O) H H0).
-Qed.
-
-Lemma COS : (a:R) ``-PI/2<=a`` -> ``a<=PI/2`` -> ``(cos_lb a)<=(cos a)<=(cos_ub a)``.
-Intros; Unfold cos_lb cos_ub; Apply (cos_bound a (S O) H H0).
-Qed.
-
-(**********)
-Lemma _PI2_RLT_0 : ``-(PI/2)<0``.
-Rewrite <- Ropp_O; Apply Rlt_Ropp1; Apply PI2_RGT_0.
-Qed.
-
-Lemma PI4_RLT_PI2 : ``PI/4<PI/2``.
-Unfold Rdiv; Apply Rlt_monotony.
-Apply PI_RGT_0.
-Apply Rinv_lt.
-Apply Rmult_lt_pos; Sup0.
-Pattern 1 ``2``; Rewrite <- Rplus_Or.
-Replace ``4`` with ``2+2``; [Apply Rlt_compatibility; Sup0 | Ring].
-Qed.
-
-Lemma PI2_Rlt_PI : ``PI/2<PI``.
-Unfold Rdiv; Pattern 2 PI; Rewrite <- Rmult_1r.
-Apply Rlt_monotony.
-Apply PI_RGT_0.
-Pattern 3 R1; Rewrite <- Rinv_R1; Apply Rinv_lt.
-Rewrite Rmult_1l; Sup0.
-Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Apply Rlt_R0_R1.
-Qed.
-
-(********************************************)
-(* Increasing and decreasing of COS and SIN *)
-(********************************************)
-Theorem sin_gt_0 : (x:R) ``0<x`` -> ``x<PI`` -> ``0<(sin x)``.
-Intros; Elim (SIN x (Rlt_le R0 x H) (Rlt_le x PI H0)); Intros H1 _; Case (total_order x ``PI/2``); Intro H2.
-Apply Rlt_le_trans with (sin_lb x).
-Apply sin_lb_gt_0; [Assumption | Left; Assumption].
-Assumption.
-Elim H2; Intro H3.
-Rewrite H3; Rewrite sin_PI2; Apply Rlt_R0_R1.
-Rewrite <- sin_PI_x; Generalize (Rgt_Ropp x ``PI/2`` H3); Intro H4; Generalize (Rlt_compatibility PI (Ropp x) (Ropp ``PI/2``) H4).
-Replace ``PI+(-x)`` with ``PI-x``.
-Replace ``PI+ -(PI/2)`` with ``PI/2``.
-Intro H5; Generalize (Rlt_Ropp x PI H0); Intro H6; Change ``-PI < -x`` in H6; Generalize (Rlt_compatibility PI (Ropp PI) (Ropp x) H6).
-Rewrite Rplus_Ropp_r.
-Replace ``PI+ -x`` with ``PI-x``.
-Intro H7; Elim (SIN ``PI-x`` (Rlt_le R0 ``PI-x`` H7) (Rlt_le ``PI-x`` PI (Rlt_trans ``PI-x`` ``PI/2`` ``PI`` H5 PI2_Rlt_PI))); Intros H8 _; Generalize (sin_lb_gt_0 ``PI-x`` H7 (Rlt_le ``PI-x`` ``PI/2`` H5)); Intro H9; Apply (Rlt_le_trans ``0`` ``(sin_lb (PI-x))`` ``(sin (PI-x))`` H9 H8).
-Reflexivity.
-Pattern 2 PI; Rewrite double_var; Ring.
-Reflexivity.
-Qed.
-
-Theorem cos_gt_0 : (x:R) ``-(PI/2)<x`` -> ``x<PI/2`` -> ``0<(cos x)``.
-Intros; Rewrite cos_sin; Generalize (Rlt_compatibility ``PI/2`` ``-(PI/2)`` x H).
-Rewrite Rplus_Ropp_r; Intro H1; Generalize (Rlt_compatibility ``PI/2`` x ``PI/2`` H0); Rewrite <- double_var; Intro H2; Apply (sin_gt_0 ``PI/2+x`` H1 H2).
-Qed.
-
-Lemma sin_ge_0 : (x:R) ``0<=x`` -> ``x<=PI`` -> ``0<=(sin x)``.
-Intros x H1 H2; Elim H1; Intro H3; [ Elim H2; Intro H4; [ Left ; Apply (sin_gt_0 x H3 H4) | Rewrite H4; Right; Symmetry; Apply sin_PI ] | Rewrite <- H3; Right; Symmetry; Apply sin_0].
-Qed.
-
-Lemma cos_ge_0 : (x:R) ``-(PI/2)<=x`` -> ``x<=PI/2`` -> ``0<=(cos x)``.
-Intros x H1 H2; Elim H1; Intro H3; [ Elim H2; Intro H4; [ Left ; Apply (cos_gt_0 x H3 H4) | Rewrite H4; Right; Symmetry; Apply cos_PI2 ] | Rewrite <- H3; Rewrite cos_neg; Right; Symmetry; Apply cos_PI2 ].
-Qed.
-
-Lemma sin_le_0 : (x:R) ``PI<=x`` -> ``x<=2*PI`` -> ``(sin x)<=0``.
-Intros x H1 H2; Apply Rle_sym2; Rewrite <- Ropp_O; Rewrite <- (Ropp_Ropp (sin x)); Apply Rle_Ropp; Rewrite <- neg_sin; Replace ``x+PI`` with ``(x-PI)+2*(INR (S O))*PI``; [Rewrite -> (sin_period (Rminus x PI) (S O)); Apply sin_ge_0; [Replace ``x-PI`` with ``x+(-PI)``; [Rewrite Rplus_sym; Replace ``0`` with ``(-PI)+PI``; [Apply Rle_compatibility; Assumption | Ring] | Ring] | Replace ``x-PI`` with ``x+(-PI)``; Rewrite Rplus_sym; [Pattern 2 PI; Replace ``PI`` with ``(-PI)+2*PI``; [Apply Rle_compatibility; Assumption | Ring] | Ring]] |Unfold INR; Ring].
-Qed.
-
-Lemma cos_le_0 : (x:R) ``PI/2<=x``->``x<=3*(PI/2)``->``(cos x)<=0``.
-Intros x H1 H2; Apply Rle_sym2; Rewrite <- Ropp_O; Rewrite <- (Ropp_Ropp (cos x)); Apply Rle_Ropp; Rewrite <- neg_cos; Replace ``x+PI`` with ``(x-PI)+2*(INR (S O))*PI``.
-Rewrite cos_period; Apply cos_ge_0.
-Replace ``-(PI/2)`` with ``-PI+(PI/2)``.
-Unfold Rminus; Rewrite (Rplus_sym x); Apply Rle_compatibility; Assumption.
-Pattern 1 PI; Rewrite (double_var PI); Rewrite Ropp_distr1; Ring.
-Unfold Rminus; Rewrite Rplus_sym; Replace ``PI/2`` with ``(-PI)+3*(PI/2)``.
-Apply Rle_compatibility; Assumption.
-Pattern 1 PI; Rewrite (double_var PI); Rewrite Ropp_distr1; Ring. 
-Unfold INR; Ring.
-Qed.
-
-Lemma sin_lt_0 : (x:R) ``PI<x`` -> ``x<2*PI`` -> ``(sin x)<0``.
-Intros x H1 H2; Rewrite <- Ropp_O; Rewrite <- (Ropp_Ropp (sin x)); Apply Rlt_Ropp; Rewrite <- neg_sin; Replace ``x+PI`` with ``(x-PI)+2*(INR (S O))*PI``; [Rewrite -> (sin_period (Rminus x PI) (S O)); Apply sin_gt_0; [Replace ``x-PI`` with ``x+(-PI)``; [Rewrite Rplus_sym; Replace ``0`` with ``(-PI)+PI``; [Apply Rlt_compatibility; Assumption | Ring] | Ring] | Replace ``x-PI`` with ``x+(-PI)``; Rewrite Rplus_sym; [Pattern 2 PI; Replace ``PI`` with ``(-PI)+2*PI``; [Apply Rlt_compatibility; Assumption | Ring] | Ring]] |Unfold INR; Ring].
-Qed.
-
-Lemma sin_lt_0_var : (x:R) ``-PI<x`` -> ``x<0`` -> ``(sin x)<0``.
-Intros; Generalize (Rlt_compatibility ``2*PI`` ``-PI`` x H); Replace ``2*PI+(-PI)`` with ``PI``; [Intro H1; Rewrite Rplus_sym in H1; Generalize (Rlt_compatibility ``2*PI`` x ``0`` H0); Intro H2; Rewrite (Rplus_sym ``2*PI``) in H2; Rewrite <- (Rplus_sym R0) in H2; Rewrite Rplus_Ol in H2; Rewrite <- (sin_period x (1)); Unfold INR; Replace ``2*1*PI`` with ``2*PI``; [Apply (sin_lt_0 ``x+2*PI`` H1 H2) | Ring] | Ring].
-Qed.
-
-Lemma cos_lt_0 : (x:R) ``PI/2<x`` -> ``x<3*(PI/2)``-> ``(cos x)<0``.
-Intros x H1 H2; Rewrite <- Ropp_O; Rewrite <- (Ropp_Ropp (cos x)); Apply Rlt_Ropp; Rewrite <- neg_cos; Replace ``x+PI`` with ``(x-PI)+2*(INR (S O))*PI``.
-Rewrite cos_period; Apply cos_gt_0.
-Replace ``-(PI/2)`` with ``-PI+(PI/2)``.
-Unfold Rminus; Rewrite (Rplus_sym x); Apply Rlt_compatibility; Assumption.
-Pattern 1 PI; Rewrite (double_var PI); Rewrite Ropp_distr1; Ring. 
-Unfold Rminus; Rewrite Rplus_sym; Replace ``PI/2`` with ``(-PI)+3*(PI/2)``.
-Apply Rlt_compatibility; Assumption.
-Pattern 1 PI; Rewrite (double_var PI); Rewrite Ropp_distr1; Ring. 
-Unfold INR; Ring.
-Qed.
-
-Lemma tan_gt_0 : (x:R) ``0<x`` -> ``x<PI/2`` -> ``0<(tan x)``.
-Intros x H1 H2; Unfold tan; Generalize _PI2_RLT_0; Generalize (Rlt_trans R0 x ``PI/2`` H1 H2); Intros; Generalize (Rlt_trans ``-(PI/2)`` R0 x H0 H1); Intro H5; Generalize (Rlt_trans x ``PI/2`` PI H2 PI2_Rlt_PI); Intro H7; Unfold Rdiv;  Apply Rmult_lt_pos.
-Apply sin_gt_0; Assumption.
-Apply Rlt_Rinv; Apply cos_gt_0; Assumption.
-Qed.
-
-Lemma tan_lt_0 : (x:R) ``-(PI/2)<x``->``x<0``->``(tan x)<0``.
-Intros x H1 H2; Unfold tan; Generalize (cos_gt_0 x H1 (Rlt_trans x ``0`` ``PI/2`` H2 PI2_RGT_0)); Intro H3; Rewrite <- Ropp_O; Replace ``(sin x)/(cos x)`` with ``- ((-(sin x))/(cos x))``.
-Rewrite <- sin_neg; Apply Rgt_Ropp; Change ``0<(sin (-x))/(cos x)``; Unfold Rdiv; Apply Rmult_lt_pos.
-Apply sin_gt_0.
-Rewrite <- Ropp_O; Apply Rgt_Ropp; Assumption.
-Apply Rlt_trans with ``PI/2``.
-Rewrite <- (Ropp_Ropp ``PI/2``); Apply Rgt_Ropp; Assumption.
-Apply PI2_Rlt_PI.
-Apply Rlt_Rinv; Assumption.
-Unfold Rdiv; Ring.
-Qed.
-
-Lemma cos_ge_0_3PI2 : (x:R) ``3*(PI/2)<=x``->``x<=2*PI``->``0<=(cos x)``.
-Intros; Rewrite <- cos_neg; Rewrite <- (cos_period ``-x`` (1)); Unfold INR; Replace ``-x+2*1*PI`` with ``2*PI-x``.
-Generalize (Rle_Ropp x ``2*PI`` H0); Intro H1; Generalize (Rle_sym2 ``-(2*PI)`` ``-x`` H1); Clear H1; Intro H1; Generalize (Rle_compatibility ``2*PI`` ``-(2*PI)`` ``-x`` H1).
-Rewrite Rplus_Ropp_r. 
-Intro H2; Generalize (Rle_Ropp ``3*(PI/2)`` x H); Intro H3; Generalize (Rle_sym2 ``-x`` ``-(3*(PI/2))`` H3); Clear H3; Intro H3;  Generalize (Rle_compatibility ``2*PI`` ``-x`` ``-(3*(PI/2))`` H3).
-Replace ``2*PI+ -(3*PI/2)`` with ``PI/2``.
-Intro H4; Apply (cos_ge_0 ``2*PI-x`` (Rlt_le ``-(PI/2)`` ``2*PI-x`` (Rlt_le_trans ``-(PI/2)`` ``0`` ``2*PI-x`` _PI2_RLT_0 H2)) H4).
-Rewrite double; Pattern 2 3 PI; Rewrite double_var; Ring.
-Ring.
-Qed.
-
-Lemma form1 : (p,q:R) ``(cos p)+(cos q)==2*(cos ((p-q)/2))*(cos ((p+q)/2))``.
-Intros p q; Pattern 1 p; Replace ``p`` with ``(p-q)/2+(p+q)/2``.
-Rewrite <- (cos_neg q); Replace``-q`` with ``(p-q)/2-(p+q)/2``.
-Rewrite cos_plus; Rewrite cos_minus; Ring.
-Pattern 3 q; Rewrite double_var; Unfold Rdiv; Ring.
-Pattern 3 p; Rewrite double_var; Unfold Rdiv; Ring.
-Qed.
-
-Lemma form2 : (p,q:R) ``(cos p)-(cos q)==-2*(sin ((p-q)/2))*(sin ((p+q)/2))``.
-Intros p q; Pattern 1 p; Replace ``p`` with ``(p-q)/2+(p+q)/2``.
-Rewrite <- (cos_neg q); Replace``-q`` with ``(p-q)/2-(p+q)/2``.
-Rewrite cos_plus; Rewrite cos_minus; Ring.
-Pattern 3 q; Rewrite double_var; Unfold Rdiv; Ring.
-Pattern 3 p; Rewrite double_var; Unfold Rdiv; Ring.
-Qed.
-
-Lemma form3 : (p,q:R) ``(sin p)+(sin q)==2*(cos ((p-q)/2))*(sin ((p+q)/2))``.
-Intros p q; Pattern 1 p; Replace ``p`` with ``(p-q)/2+(p+q)/2``.
-Pattern 3 q; Replace ``q`` with ``(p+q)/2-(p-q)/2``.
-Rewrite sin_plus; Rewrite sin_minus; Ring.
-Pattern 3 q; Rewrite double_var; Unfold Rdiv; Ring.
-Pattern 3 p; Rewrite double_var; Unfold Rdiv; Ring.
-Qed.
-
-Lemma form4 : (p,q:R) ``(sin p)-(sin q)==2*(cos ((p+q)/2))*(sin ((p-q)/2))``.
-Intros p q; Pattern 1 p; Replace ``p`` with ``(p-q)/2+(p+q)/2``.
-Pattern 3 q; Replace ``q`` with ``(p+q)/2-(p-q)/2``.
-Rewrite sin_plus; Rewrite sin_minus; Ring.
-Pattern 3 q; Rewrite double_var; Unfold Rdiv; Ring.
-Pattern 3 p; Rewrite double_var; Unfold Rdiv; Ring.
-
-Qed.
-
-Lemma sin_increasing_0 : (x,y:R) ``-(PI/2)<=x``->``x<=PI/2``->``-(PI/2)<=y``->``y<=PI/2``->``(sin x)<(sin y)``->``x<y``.
-Intros; Cut ``(sin ((x-y)/2))<0``.
-Intro H4; Case (total_order ``(x-y)/2`` ``0``); Intro H5.
-Assert Hyp : ``0<2``.
-Sup0.
-Generalize (Rlt_monotony ``2`` ``(x-y)/2`` ``0`` Hyp H5).
-Unfold Rdiv.
-Rewrite <- Rmult_assoc.
-Rewrite Rinv_r_simpl_m.
-Rewrite Rmult_Or.
-Clear H5; Intro H5; Apply Rminus_lt; Assumption.
-DiscrR.
-Elim H5; Intro H6.
-Rewrite H6 in H4; Rewrite sin_0 in H4; Elim (Rlt_antirefl ``0`` H4).
-Change ``0<(x-y)/2`` in H6; Generalize (Rle_Ropp ``-(PI/2)`` y H1).
-Rewrite Ropp_Ropp.
-Intro H7; Generalize (Rle_sym2 ``-y`` ``PI/2`` H7); Clear H7; Intro H7; Generalize (Rplus_le x ``PI/2`` ``-y`` ``PI/2`` H0 H7).
-Rewrite <- double_var.
-Intro H8.
-Assert Hyp : ``0<2``.
-Sup0.
-Generalize (Rle_monotony ``(Rinv 2)`` ``x-y`` PI (Rlt_le ``0`` ``/2`` (Rlt_Rinv ``2`` Hyp)) H8).
-Repeat Rewrite (Rmult_sym ``/2``). 
-Intro H9; Generalize (sin_gt_0 ``(x-y)/2`` H6 (Rle_lt_trans ``(x-y)/2`` ``PI/2`` PI H9 PI2_Rlt_PI)); Intro H10; Elim (Rlt_antirefl ``(sin ((x-y)/2))`` (Rlt_trans ``(sin ((x-y)/2))`` ``0`` ``(sin ((x-y)/2))`` H4 H10)).
-Generalize (Rlt_minus (sin x) (sin y) H3); Clear H3; Intro H3; Rewrite form4 in H3; Generalize (Rplus_le x ``PI/2`` y ``PI/2`` H0 H2).
-Rewrite <- double_var.
-Assert Hyp : ``0<2``.
-Sup0.
-Intro H4; Generalize (Rle_monotony ``(Rinv 2)`` ``x+y`` PI (Rlt_le ``0`` ``/2`` (Rlt_Rinv ``2`` Hyp)) H4).
-Repeat Rewrite (Rmult_sym ``/2``). 
-Clear H4; Intro H4; Generalize (Rplus_le ``-(PI/2)`` x ``-(PI/2)`` y H H1); Replace ``-(PI/2)+(-(PI/2))`` with ``-PI``.
-Intro H5; Generalize (Rle_monotony ``(Rinv 2)`` ``-PI`` ``x+y`` (Rlt_le ``0`` ``/2`` (Rlt_Rinv ``2`` Hyp)) H5).
-Replace ``/2*(x+y)`` with ``(x+y)/2``.
-Replace ``/2*(-PI)`` with ``-(PI/2)``.
-Clear H5; Intro H5; Elim H4; Intro H40.
-Elim H5; Intro H50.
-Generalize (cos_gt_0 ``(x+y)/2`` H50 H40); Intro H6; Generalize (Rlt_monotony ``2`` ``0`` ``(cos ((x+y)/2))`` Hyp H6).
-Rewrite Rmult_Or. 
-Clear H6; Intro H6; Case (case_Rabsolu ``(sin ((x-y)/2))``); Intro H7.
-Assumption.
-Generalize (Rle_sym2 ``0`` ``(sin ((x-y)/2))`` H7); Clear H7; Intro H7; Generalize (Rmult_le_pos ``2*(cos ((x+y)/2))`` ``(sin ((x-y)/2))`` (Rlt_le ``0`` ``2*(cos ((x+y)/2))`` H6) H7); Intro H8; Generalize (Rle_lt_trans ``0`` ``2*(cos ((x+y)/2))*(sin ((x-y)/2))`` ``0`` H8 H3); Intro H9; Elim (Rlt_antirefl ``0`` H9).
-Rewrite <- H50 in H3; Rewrite cos_neg in H3; Rewrite cos_PI2 in H3; Rewrite Rmult_Or in H3; Rewrite Rmult_Ol in H3; Elim (Rlt_antirefl ``0`` H3).
-Unfold Rdiv in H3.
-Rewrite H40 in H3; Assert H50 := cos_PI2; Unfold Rdiv in H50; Rewrite H50 in H3; Rewrite Rmult_Or in H3; Rewrite Rmult_Ol in H3; Elim (Rlt_antirefl ``0`` H3).
-Unfold Rdiv.
-Rewrite <- Ropp_mul1.
-Apply Rmult_sym.
-Unfold Rdiv; Apply Rmult_sym.
-Pattern 1 PI; Rewrite double_var.
-Rewrite Ropp_distr1.
-Reflexivity.
-Qed.
-
-Lemma sin_increasing_1 : (x,y:R) ``-(PI/2)<=x``->``x<=PI/2``->``-(PI/2)<=y``->``y<=PI/2``->``x<y``->``(sin x)<(sin y)``.
-Intros; Generalize (Rlt_compatibility ``x`` ``x`` ``y`` H3); Intro H4; Generalize (Rplus_le ``-(PI/2)`` x ``-(PI/2)`` x H H); Replace ``-(PI/2)+ (-(PI/2))`` with ``-PI``.
-Assert Hyp : ``0<2``.
-Sup0.
-Intro H5; Generalize (Rle_lt_trans ``-PI`` ``x+x`` ``x+y`` H5 H4); Intro H6; Generalize (Rlt_monotony ``(Rinv 2)`` ``-PI`` ``x+y`` (Rlt_Rinv ``2`` Hyp) H6); Replace ``/2*(-PI)`` with ``-(PI/2)``.
-Replace ``/2*(x+y)`` with ``(x+y)/2``.
-Clear H4 H5 H6; Intro H4; Generalize (Rlt_compatibility ``y`` ``x`` ``y`` H3); Intro H5; Rewrite Rplus_sym in H5; Generalize (Rplus_le y ``PI/2`` y ``PI/2`` H2 H2).
-Rewrite <- double_var.
-Intro H6; Generalize (Rlt_le_trans ``x+y`` ``y+y`` PI H5 H6); Intro H7; Generalize (Rlt_monotony ``(Rinv 2)``  ``x+y`` PI (Rlt_Rinv ``2`` Hyp) H7); Replace ``/2*PI`` with ``PI/2``.
-Replace ``/2*(x+y)`` with ``(x+y)/2``.
-Clear H5 H6 H7; Intro H5; Generalize (Rle_Ropp ``-(PI/2)`` y H1); Rewrite Ropp_Ropp; Clear H1; Intro H1; Generalize (Rle_sym2 ``-y`` ``PI/2`` H1); Clear H1; Intro H1; Generalize (Rle_Ropp y ``PI/2`` H2); Clear H2; Intro H2; Generalize (Rle_sym2 ``-(PI/2)`` ``-y`` H2); Clear H2; Intro H2; Generalize (Rlt_compatibility ``-y`` x y H3); Replace ``-y+x`` with ``x-y``.
-Rewrite Rplus_Ropp_l.
-Intro H6; Generalize (Rlt_monotony ``(Rinv 2)``  ``x-y`` ``0`` (Rlt_Rinv ``2`` Hyp) H6); Rewrite Rmult_Or; Replace ``/2*(x-y)`` with ``(x-y)/2``.
-Clear H6; Intro H6; Generalize (Rplus_le  ``-(PI/2)`` x ``-(PI/2)`` ``-y`` H H2); Replace ``-(PI/2)+ (-(PI/2))`` with ``-PI``.
-Replace `` x+ -y`` with ``x-y``.
-Intro H7; Generalize (Rle_monotony ``(Rinv 2)`` ``-PI`` ``x-y`` (Rlt_le ``0`` ``/2`` (Rlt_Rinv ``2`` Hyp)) H7); Replace ``/2*(-PI)`` with ``-(PI/2)``.
-Replace ``/2*(x-y)`` with ``(x-y)/2``.
-Clear H7; Intro H7; Clear H H0 H1 H2; Apply Rminus_lt; Rewrite form4; Generalize (cos_gt_0 ``(x+y)/2`` H4 H5); Intro H8; Generalize (Rmult_lt_pos ``2`` ``(cos ((x+y)/2))`` Hyp H8); Clear H8; Intro H8; Cut ``-PI< -(PI/2)``.
-Intro H9; Generalize (sin_lt_0_var ``(x-y)/2`` (Rlt_le_trans ``-PI`` ``-(PI/2)`` ``(x-y)/2`` H9 H7) H6); Intro H10; Generalize (Rlt_anti_monotony ``(sin ((x-y)/2))`` ``0`` ``2*(cos ((x+y)/2))`` H10 H8); Intro H11; Rewrite Rmult_Or in H11; Rewrite Rmult_sym; Assumption.
-Apply Rlt_Ropp; Apply PI2_Rlt_PI.
-Unfold Rdiv; Apply Rmult_sym.
-Unfold Rdiv; Rewrite <- Ropp_mul1; Apply Rmult_sym.
-Reflexivity.
-Pattern 1 PI; Rewrite double_var.
-Rewrite Ropp_distr1.
-Reflexivity.
-Unfold Rdiv; Apply Rmult_sym.
-Unfold Rminus; Apply Rplus_sym.
-Unfold Rdiv; Apply Rmult_sym.
-Unfold Rdiv; Apply Rmult_sym.
-Unfold Rdiv; Apply Rmult_sym.
-Unfold Rdiv.
-Rewrite <- Ropp_mul1.
-Apply Rmult_sym.
-Pattern 1 PI; Rewrite double_var.
-Rewrite Ropp_distr1.
-Reflexivity.
-Qed.
-
-Lemma sin_decreasing_0 : (x,y:R) ``x<=3*(PI/2)``-> ``PI/2<=x`` -> ``y<=3*(PI/2)``-> ``PI/2<=y`` -> ``(sin x)<(sin y)`` -> ``y<x``.
-Intros; Rewrite <- (sin_PI_x x) in H3; Rewrite <- (sin_PI_x y) in H3; Generalize (Rlt_Ropp ``(sin (PI-x))`` ``(sin (PI-y))`` H3); Repeat Rewrite <- sin_neg; Generalize (Rle_compatibility ``-PI`` x ``3*(PI/2)`` H); Generalize (Rle_compatibility ``-PI`` ``PI/2`` x H0); Generalize (Rle_compatibility ``-PI`` y ``3*(PI/2)`` H1); Generalize (Rle_compatibility ``-PI`` ``PI/2`` y H2); Replace ``-PI+x`` with ``x-PI``.
-Replace ``-PI+PI/2`` with ``-(PI/2)``.
-Replace ``-PI+y`` with ``y-PI``.
-Replace ``-PI+3*(PI/2)`` with ``PI/2``.
-Replace ``-(PI-x)`` with ``x-PI``.
-Replace ``-(PI-y)`` with ``y-PI``.
-Intros; Change ``(sin (y-PI))<(sin (x-PI))`` in H8; Apply Rlt_anti_compatibility with ``-PI``; Rewrite Rplus_sym; Replace ``y+ (-PI)`` with ``y-PI``.
-Rewrite Rplus_sym; Replace ``x+ (-PI)`` with ``x-PI``.
-Apply (sin_increasing_0 ``y-PI`` ``x-PI`` H4 H5 H6 H7 H8).
-Reflexivity.
-Reflexivity.
-Unfold Rminus; Rewrite Ropp_distr1.
-Rewrite Ropp_Ropp.
-Apply Rplus_sym.
-Unfold Rminus; Rewrite Ropp_distr1.
-Rewrite Ropp_Ropp.
-Apply Rplus_sym.
-Pattern 2 PI; Rewrite double_var.
-Rewrite Ropp_distr1.
-Ring.
-Unfold Rminus; Apply Rplus_sym.
-Pattern 2 PI; Rewrite double_var.
-Rewrite Ropp_distr1.
-Ring.
-Unfold Rminus; Apply Rplus_sym.
-Qed.
-
-Lemma sin_decreasing_1 : (x,y:R) ``x<=3*(PI/2)``-> ``PI/2<=x`` -> ``y<=3*(PI/2)``-> ``PI/2<=y`` -> ``x<y``  -> ``(sin y)<(sin x)``.
-Intros; Rewrite <- (sin_PI_x x); Rewrite <- (sin_PI_x y); Generalize (Rle_compatibility ``-PI`` x ``3*(PI/2)`` H); Generalize (Rle_compatibility ``-PI`` ``PI/2`` x H0); Generalize (Rle_compatibility ``-PI`` y ``3*(PI/2)`` H1); Generalize (Rle_compatibility ``-PI`` ``PI/2`` y H2); Generalize (Rlt_compatibility ``-PI`` x y H3); Replace ``-PI+PI/2`` with ``-(PI/2)``.
-Replace ``-PI+y`` with ``y-PI``.
-Replace ``-PI+3*(PI/2)`` with ``PI/2``.
-Replace ``-PI+x`` with ``x-PI``.
-Intros; Apply Ropp_Rlt; Repeat Rewrite <- sin_neg; Replace ``-(PI-x)`` with ``x-PI``.
-Replace ``-(PI-y)`` with ``y-PI``.
-Apply (sin_increasing_1 ``x-PI`` ``y-PI`` H7 H8 H5 H6 H4).
-Unfold Rminus; Rewrite Ropp_distr1.
-Rewrite Ropp_Ropp.
-Apply Rplus_sym.
-Unfold Rminus; Rewrite Ropp_distr1.
-Rewrite Ropp_Ropp.
-Apply Rplus_sym.
-Unfold Rminus; Apply Rplus_sym.
-Pattern 2 PI; Rewrite double_var; Ring.
-Unfold Rminus; Apply Rplus_sym.
-Pattern 2 PI; Rewrite double_var; Ring.
-Qed.
-
-Lemma cos_increasing_0 : (x,y:R) ``PI<=x`` -> ``x<=2*PI`` ->``PI<=y`` -> ``y<=2*PI`` -> ``(cos x)<(cos y)`` -> ``x<y``.
-Intros x y H1 H2 H3 H4; Rewrite <- (cos_neg x); Rewrite <- (cos_neg y); Rewrite <- (cos_period ``-x`` (1)); Rewrite <- (cos_period ``-y`` (1)); Unfold INR; Replace ``-x+2*1*PI`` with ``PI/2-(x-3*(PI/2))``.
-Replace ``-y+2*1*PI`` with ``PI/2-(y-3*(PI/2))``.
-Repeat Rewrite cos_shift; Intro H5; Generalize (Rle_compatibility ``-3*(PI/2)`` PI x H1); Generalize (Rle_compatibility ``-3*(PI/2)`` x ``2*PI`` H2); Generalize (Rle_compatibility ``-3*(PI/2)`` PI y H3); Generalize (Rle_compatibility ``-3*(PI/2)`` y ``2*PI`` H4).
-Replace ``-3*(PI/2)+y`` with ``y-3*(PI/2)``.
-Replace ``-3*(PI/2)+x`` with ``x-3*(PI/2)``.
-Replace ``-3*(PI/2)+2*PI`` with ``PI/2``.
-Replace ``-3*PI/2+PI`` with ``-(PI/2)``.
-Clear H1 H2 H3 H4; Intros H1 H2 H3 H4; Apply Rlt_anti_compatibility with ``-3*(PI/2)``; Replace ``-3*PI/2+x`` with ``x-3*(PI/2)``.
-Replace ``-3*PI/2+y`` with ``y-3*(PI/2)``.
-Apply (sin_increasing_0 ``x-3*(PI/2)`` ``y-3*(PI/2)`` H4 H3 H2 H1 H5).
-Unfold Rminus.
-Rewrite Ropp_mul1. 
-Apply Rplus_sym. 
-Unfold Rminus.
-Rewrite Ropp_mul1. 
-Apply Rplus_sym. 
-Pattern 3 PI; Rewrite double_var.
-Ring.
-Rewrite double; Pattern 3 4 PI; Rewrite double_var.
-Ring.
-Unfold Rminus.
-Rewrite Ropp_mul1. 
-Apply Rplus_sym. 
-Unfold Rminus.
-Rewrite Ropp_mul1. 
-Apply Rplus_sym. 
-Rewrite Rmult_1r.
-Rewrite (double PI); Pattern 3 4 PI; Rewrite double_var.
-Ring.
-Rewrite Rmult_1r.
-Rewrite (double PI); Pattern 3 4 PI; Rewrite double_var.
-Ring.
-Qed.
-
-Lemma cos_increasing_1 : (x,y:R) ``PI<=x`` -> ``x<=2*PI`` ->``PI<=y`` -> ``y<=2*PI`` -> ``x<y`` -> ``(cos x)<(cos y)``.
-Intros x y H1 H2 H3 H4 H5; Generalize (Rle_compatibility ``-3*(PI/2)`` PI x H1); Generalize (Rle_compatibility ``-3*(PI/2)`` x ``2*PI`` H2); Generalize (Rle_compatibility ``-3*(PI/2)`` PI y H3); Generalize (Rle_compatibility ``-3*(PI/2)`` y ``2*PI`` H4); Generalize (Rlt_compatibility ``-3*(PI/2)`` x y H5); Rewrite <- (cos_neg x); Rewrite <- (cos_neg y); Rewrite <- (cos_period ``-x`` (1)); Rewrite <- (cos_period ``-y`` (1)); Unfold INR; Replace ``-3*(PI/2)+x`` with ``x-3*(PI/2)``.
-Replace ``-3*(PI/2)+y`` with ``y-3*(PI/2)``.
-Replace ``-3*(PI/2)+PI`` with ``-(PI/2)``.
-Replace ``-3*(PI/2)+2*PI`` with ``PI/2``.
-Clear H1 H2 H3 H4 H5; Intros H1 H2 H3 H4 H5; Replace ``-x+2*1*PI`` with ``(PI/2)-(x-3*(PI/2))``.
-Replace ``-y+2*1*PI`` with ``(PI/2)-(y-3*(PI/2))``.
-Repeat Rewrite cos_shift; Apply (sin_increasing_1 ``x-3*(PI/2)`` ``y-3*(PI/2)`` H5 H4 H3 H2 H1).
-Rewrite Rmult_1r.
-Rewrite (double PI); Pattern 3 4 PI; Rewrite double_var.
-Ring.
-Rewrite Rmult_1r.
-Rewrite (double PI); Pattern 3 4 PI; Rewrite double_var.
-Ring.
-Rewrite (double PI); Pattern 3 4 PI; Rewrite double_var.
-Ring.
-Pattern 3 PI; Rewrite double_var; Ring.
-Unfold Rminus.
-Rewrite <- Ropp_mul1.
-Apply Rplus_sym.
-Unfold Rminus.
-Rewrite <- Ropp_mul1.
-Apply Rplus_sym.
-Qed.
-
-Lemma cos_decreasing_0 : (x,y:R) ``0<=x``->``x<=PI``->``0<=y``->``y<=PI``->``(cos x)<(cos y)``->``y<x``.
-Intros; Generalize (Rlt_Ropp (cos x) (cos y) H3); Repeat Rewrite <- neg_cos; Intro H4; Change ``(cos (y+PI))<(cos (x+PI))`` in H4; Rewrite (Rplus_sym x) in H4; Rewrite (Rplus_sym y) in H4; Generalize (Rle_compatibility PI ``0`` x H); Generalize (Rle_compatibility PI x PI H0); Generalize (Rle_compatibility PI ``0`` y H1); Generalize (Rle_compatibility PI y PI H2); Rewrite Rplus_Or.
-Rewrite <- double.
-Clear H H0 H1 H2 H3; Intros; Apply Rlt_anti_compatibility with ``PI``; Apply (cos_increasing_0 ``PI+y`` ``PI+x`` H0 H H2 H1 H4).
-Qed.
-
-Lemma cos_decreasing_1 : (x,y:R) ``0<=x``->``x<=PI``->``0<=y``->``y<=PI``->``x<y``->``(cos y)<(cos x)``.
-Intros; Apply Ropp_Rlt; Repeat Rewrite <- neg_cos; Rewrite (Rplus_sym x); Rewrite (Rplus_sym y); Generalize (Rle_compatibility PI ``0`` x H); Generalize (Rle_compatibility PI x PI H0); Generalize (Rle_compatibility PI ``0`` y H1); Generalize (Rle_compatibility PI y PI H2); Rewrite Rplus_Or.
-Rewrite <- double.
-Generalize (Rlt_compatibility PI x y H3); Clear H H0 H1 H2 H3; Intros; Apply (cos_increasing_1 ``PI+x`` ``PI+y`` H3 H2 H1 H0 H).
-Qed.
-
-Lemma tan_diff : (x,y:R) ~``(cos x)==0``->~``(cos y)==0``->``(tan x)-(tan y)==(sin (x-y))/((cos x)*(cos y))``.
-Intros; Unfold tan;Rewrite sin_minus.
-Unfold Rdiv. 
-Unfold Rminus.
-Rewrite Rmult_Rplus_distrl.
-Rewrite Rinv_Rmult.
-Repeat Rewrite (Rmult_sym (sin x)).
-Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym (cos y)).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Rewrite (Rmult_sym (sin x)).
-Apply Rplus_plus_r.
-Rewrite <- Ropp_mul1.
-Rewrite <- Ropp_mul3.
-Rewrite (Rmult_sym ``/(cos x)``).
-Repeat Rewrite Rmult_assoc.
-Rewrite (Rmult_sym (cos x)).
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Reflexivity.
-Assumption.
-Assumption.
-Assumption.
-Assumption.
-Qed.
-
-Lemma tan_increasing_0 : (x,y:R) ``-(PI/4)<=x``->``x<=PI/4`` ->``-(PI/4)<=y``->``y<=PI/4``->``(tan x)<(tan y)``->``x<y``.
-Intros; Generalize PI4_RLT_PI2; Intro H4; Generalize (Rlt_Ropp ``PI/4`` ``PI/2`` H4); Intro H5; Change ``-(PI/2)< -(PI/4)`` in H5; Generalize (cos_gt_0 x (Rlt_le_trans ``-(PI/2)`` ``-(PI/4)`` x H5 H) (Rle_lt_trans x ``PI/4`` ``PI/2`` H0 H4)); Intro HP1; Generalize (cos_gt_0 y (Rlt_le_trans ``-(PI/2)`` ``-(PI/4)`` y H5 H1) (Rle_lt_trans y ``PI/4`` ``PI/2`` H2 H4)); Intro HP2; Generalize (not_sym ``0`` (cos x) (Rlt_not_eq ``0`` (cos x) (cos_gt_0 x (Rlt_le_trans ``-(PI/2)`` ``-(PI/4)`` x H5 H) (Rle_lt_trans x ``PI/4`` ``PI/2`` H0 H4)))); Intro H6; Generalize (not_sym ``0`` (cos y) (Rlt_not_eq ``0`` (cos y) (cos_gt_0 y (Rlt_le_trans ``-(PI/2)`` ``-(PI/4)`` y H5 H1) (Rle_lt_trans y ``PI/4`` ``PI/2`` H2 H4)))); Intro H7; Generalize (tan_diff x y H6 H7); Intro H8; Generalize (Rlt_minus (tan x) (tan y) H3); Clear H3; Intro H3; Rewrite H8 in H3; Cut ``(sin (x-y))<0``.
-Intro H9; Generalize (Rle_Ropp ``-(PI/4)`` y H1); Rewrite Ropp_Ropp; Intro H10; Generalize (Rle_sym2 ``-y`` ``PI/4`` H10); Clear H10; Intro H10; Generalize (Rle_Ropp y ``PI/4`` H2); Intro H11; Generalize (Rle_sym2 ``-(PI/4)`` ``-y`` H11); Clear H11; Intro H11; Generalize (Rplus_le ``-(PI/4)`` x ``-(PI/4)`` ``-y`` H H11); Generalize (Rplus_le x ``PI/4`` ``-y`` ``PI/4`` H0 H10); Replace ``x+ -y`` with ``x-y``.
-Replace ``PI/4+PI/4`` with ``PI/2``.
-Replace ``-(PI/4)+ -(PI/4)`` with ``-(PI/2)``.
-Intros; Case (total_order ``0`` ``x-y``); Intro H14.
-Generalize (sin_gt_0 ``x-y`` H14 (Rle_lt_trans ``x-y`` ``PI/2`` PI H12 PI2_Rlt_PI)); Intro H15; Elim (Rlt_antirefl ``0`` (Rlt_trans ``0`` ``(sin (x-y))`` ``0`` H15 H9)).
-Elim H14; Intro H15.
-Rewrite <- H15 in H9; Rewrite -> sin_0 in H9;  Elim (Rlt_antirefl ``0`` H9). 
-Apply Rminus_lt; Assumption.
-Pattern 1 PI; Rewrite double_var.
-Unfold Rdiv.
-Rewrite Rmult_Rplus_distrl.
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_Rmult.
-Rewrite Ropp_distr1.
-Replace ``2*2`` with ``4``.
-Reflexivity.
-Ring.
-DiscrR.
-DiscrR.
-Pattern 1 PI; Rewrite double_var.
-Unfold Rdiv.
-Rewrite Rmult_Rplus_distrl.
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_Rmult.
-Replace ``2*2`` with ``4``.
-Reflexivity.
-Ring.
-DiscrR.
-DiscrR.
-Reflexivity.
-Case (case_Rabsolu ``(sin (x-y))``); Intro H9.
-Assumption.
-Generalize (Rle_sym2 ``0`` ``(sin (x-y))`` H9); Clear H9; Intro H9; Generalize (Rlt_Rinv (cos x) HP1); Intro H10; Generalize (Rlt_Rinv (cos y) HP2); Intro H11; Generalize (Rmult_lt_pos (Rinv (cos x)) (Rinv (cos y)) H10 H11); Replace ``/(cos x)*/(cos y)`` with ``/((cos x)*(cos y))``.
-Intro H12; Generalize (Rmult_le_pos ``(sin (x-y))`` ``/((cos x)*(cos y))`` H9 (Rlt_le ``0`` ``/((cos x)*(cos y))`` H12)); Intro H13; Elim (Rlt_antirefl ``0`` (Rle_lt_trans ``0`` ``(sin (x-y))*/((cos x)*(cos y))`` ``0`` H13 H3)).
-Rewrite Rinv_Rmult.
-Reflexivity. 
-Assumption.
-Assumption.
-Qed.
-
-Lemma tan_increasing_1 : (x,y:R) ``-(PI/4)<=x``->``x<=PI/4`` ->``-(PI/4)<=y``->``y<=PI/4``->``x<y``->``(tan x)<(tan y)``.
-Intros; Apply Rminus_lt; Generalize PI4_RLT_PI2; Intro H4; Generalize (Rlt_Ropp ``PI/4`` ``PI/2`` H4); Intro H5; Change ``-(PI/2)< -(PI/4)`` in H5; Generalize (cos_gt_0 x (Rlt_le_trans ``-(PI/2)`` ``-(PI/4)`` x H5 H) (Rle_lt_trans x ``PI/4`` ``PI/2`` H0 H4)); Intro HP1; Generalize (cos_gt_0 y (Rlt_le_trans ``-(PI/2)`` ``-(PI/4)`` y H5 H1) (Rle_lt_trans y ``PI/4`` ``PI/2`` H2 H4)); Intro HP2; Generalize (not_sym ``0`` (cos x) (Rlt_not_eq ``0`` (cos x) (cos_gt_0 x (Rlt_le_trans ``-(PI/2)`` ``-(PI/4)`` x H5 H) (Rle_lt_trans x ``PI/4`` ``PI/2`` H0 H4)))); Intro H6; Generalize (not_sym ``0`` (cos y) (Rlt_not_eq ``0`` (cos y) (cos_gt_0 y (Rlt_le_trans ``-(PI/2)`` ``-(PI/4)`` y H5 H1) (Rle_lt_trans y ``PI/4`` ``PI/2`` H2 H4)))); Intro H7; Rewrite (tan_diff x y H6 H7); Generalize (Rlt_Rinv (cos x) HP1); Intro H10; Generalize (Rlt_Rinv (cos y) HP2); Intro H11; Generalize (Rmult_lt_pos (Rinv (cos x)) (Rinv (cos y)) H10 H11); Replace ``/(cos x)*/(cos y)`` with ``/((cos x)*(cos y))``.
-Clear H10 H11; Intro H8; Generalize (Rle_Ropp y ``PI/4`` H2); Intro H11; Generalize (Rle_sym2 ``-(PI/4)`` ``-y`` H11); Clear H11; Intro H11; Generalize (Rplus_le ``-(PI/4)`` x ``-(PI/4)`` ``-y`` H H11); Replace ``x+ -y`` with ``x-y``.
-Replace ``-(PI/4)+ -(PI/4)`` with ``-(PI/2)``.
-Clear H11; Intro H9; Generalize (Rlt_minus x y H3); Clear H3; Intro H3; Clear H H0 H1 H2 H4 H5 HP1 HP2; Generalize PI2_Rlt_PI; Intro H1; Generalize (Rlt_Ropp ``PI/2`` PI H1); Clear H1; Intro H1; Generalize (sin_lt_0_var ``x-y`` (Rlt_le_trans ``-PI`` ``-(PI/2)`` ``x-y`` H1 H9) H3); Intro H2; Generalize (Rlt_anti_monotony ``(sin (x-y))`` ``0`` ``/((cos x)*(cos y))`` H2 H8); Rewrite Rmult_Or; Intro H4; Assumption.
-Pattern 1 PI; Rewrite double_var.
-Unfold Rdiv.
-Rewrite Rmult_Rplus_distrl.
-Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_Rmult.
-Replace ``2*2`` with ``4``.
-Rewrite Ropp_distr1.
-Reflexivity.
-Ring.
-DiscrR.
-DiscrR.
-Reflexivity.
-Apply Rinv_Rmult; Assumption.
-Qed.
-
-Lemma sin_incr_0 : (x,y:R) ``-(PI/2)<=x``->``x<=PI/2``->``-(PI/2)<=y``->``y<=PI/2``->``(sin x)<=(sin y)``->``x<=y``.
-Intros; Case (total_order (sin x) (sin y)); Intro H4; [Left; Apply (sin_increasing_0 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order x y); Intro H6; [Left; Assumption | Elim H6; Intro H7; [Right; Assumption | Generalize (sin_increasing_1 y x H1 H2 H H0 H7); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl (sin y) H8)]] | Elim (Rlt_antirefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5))]].
-Qed.
-
-Lemma sin_incr_1 : (x,y:R) ``-(PI/2)<=x``->``x<=PI/2``->``-(PI/2)<=y``->``y<=PI/2``->``x<=y``->``(sin x)<=(sin y)``.
-Intros; Case (total_order x y); Intro H4; [Left; Apply (sin_increasing_1 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order (sin x) (sin y)); Intro H6; [Left; Assumption | Elim H6; Intro H7; [Right; Assumption | Generalize (sin_increasing_0 y x H1 H2 H H0 H7); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl y H8)]] | Elim (Rlt_antirefl x (Rle_lt_trans x y x H3 H5))]].
-Qed.
-
-Lemma sin_decr_0 : (x,y:R) ``x<=3*(PI/2)``->``PI/2<=x``->``y<=3*(PI/2)``->``PI/2<=y``-> ``(sin x)<=(sin y)`` -> ``y<=x``.
-Intros; Case (total_order (sin x) (sin y)); Intro H4; [Left; Apply (sin_decreasing_0 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order x y); Intro H6; [Generalize (sin_decreasing_1 x y H H0 H1 H2 H6); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl (sin y) H8) | Elim H6; Intro H7; [Right; Symmetry; Assumption | Left; Assumption]] | Elim (Rlt_antirefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5))]].
-Qed.
-
-Lemma sin_decr_1 : (x,y:R) ``x<=3*(PI/2)``-> ``PI/2<=x`` -> ``y<=3*(PI/2)``-> ``PI/2<=y`` -> ``x<=y``  -> ``(sin y)<=(sin x)``.
-Intros; Case (total_order x y); Intro H4; [Left; Apply (sin_decreasing_1 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order (sin x) (sin y)); Intro H6; [Generalize (sin_decreasing_0 x y H H0 H1 H2 H6); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl y H8) | Elim H6; Intro H7; [Right; Symmetry; Assumption | Left; Assumption]] | Elim (Rlt_antirefl x (Rle_lt_trans x y x H3 H5))]].
-Qed.
-
-Lemma cos_incr_0 : (x,y:R) ``PI<=x`` -> ``x<=2*PI`` ->``PI<=y`` -> ``y<=2*PI`` -> ``(cos x)<=(cos y)`` -> ``x<=y``.
-Intros; Case (total_order (cos x) (cos y)); Intro H4; [Left; Apply (cos_increasing_0 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order x y); Intro H6; [Left; Assumption | Elim H6; Intro H7; [Right; Assumption | Generalize (cos_increasing_1 y x H1 H2 H H0 H7); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl (cos y) H8)]] | Elim (Rlt_antirefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5))]].
-Qed.
-
-Lemma cos_incr_1 : (x,y:R) ``PI<=x`` -> ``x<=2*PI`` ->``PI<=y`` -> ``y<=2*PI`` -> ``x<=y`` -> ``(cos x)<=(cos y)``.
-Intros; Case (total_order x y); Intro H4; [Left; Apply (cos_increasing_1 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order (cos x) (cos y)); Intro H6; [Left; Assumption | Elim H6; Intro H7; [Right; Assumption | Generalize (cos_increasing_0 y x H1 H2 H H0 H7); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl y H8)]] | Elim (Rlt_antirefl x (Rle_lt_trans x y x H3 H5))]].
-Qed.
-
-Lemma cos_decr_0 : (x,y:R) ``0<=x``->``x<=PI``->``0<=y``->``y<=PI``->``(cos x)<=(cos y)`` -> ``y<=x``.
-Intros; Case (total_order (cos x) (cos y)); Intro H4; [Left; Apply (cos_decreasing_0 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order x y); Intro H6; [Generalize (cos_decreasing_1 x y H H0 H1 H2 H6); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl (cos y) H8) | Elim H6; Intro H7; [Right; Symmetry; Assumption | Left; Assumption]] | Elim (Rlt_antirefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5))]].
-Qed.
-
-Lemma cos_decr_1 : (x,y:R) ``0<=x``->``x<=PI``->``0<=y``->``y<=PI``->``x<=y``->``(cos y)<=(cos x)``.
-Intros; Case (total_order x y); Intro H4; [Left; Apply (cos_decreasing_1 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order (cos x) (cos y)); Intro H6; [Generalize (cos_decreasing_0 x y H H0 H1 H2 H6); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl y H8) | Elim H6; Intro H7; [Right; Symmetry; Assumption | Left; Assumption]] | Elim (Rlt_antirefl x (Rle_lt_trans x y x H3 H5))]].
-Qed.
-
-Lemma tan_incr_0 : (x,y:R) ``-(PI/4)<=x``->``x<=PI/4`` ->``-(PI/4)<=y``->``y<=PI/4``->``(tan x)<=(tan y)``->``x<=y``.
-Intros; Case (total_order (tan x) (tan y)); Intro H4; [Left; Apply (tan_increasing_0 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order x y); Intro H6; [Left; Assumption | Elim H6; Intro H7; [Right; Assumption | Generalize (tan_increasing_1 y x H1 H2 H H0 H7); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl (tan y) H8)]] | Elim (Rlt_antirefl (tan x) (Rle_lt_trans (tan x) (tan y) (tan x) H3 H5))]].
-Qed.
-
-Lemma tan_incr_1 : (x,y:R) ``-(PI/4)<=x``->``x<=PI/4`` ->``-(PI/4)<=y``->``y<=PI/4``->``x<=y``->``(tan x)<=(tan y)``.
-Intros; Case (total_order x y); Intro H4; [Left; Apply (tan_increasing_1 x y H H0 H1 H2 H4) | Elim H4; Intro H5; [Case (total_order (tan x) (tan y)); Intro H6; [Left; Assumption | Elim H6; Intro H7; [Right; Assumption | Generalize (tan_increasing_0 y x H1 H2 H H0 H7); Intro H8; Rewrite H5 in H8; Elim (Rlt_antirefl y H8)]] | Elim (Rlt_antirefl x (Rle_lt_trans x y x H3 H5))]].
-Qed.
-
-(**********)
-Lemma sin_eq_0_1 : (x:R) (EXT k:Z | x==(Rmult (IZR k) PI)) -> (sin x)==R0.
-Intros.
-Elim H; Intros.
-Apply (Zcase_sign x0).
-Intro.
-Rewrite H1 in H0.
-Simpl in H0.
-Rewrite H0; Rewrite Rmult_Ol; Apply sin_0.
-Intro.
-Cut `0<=x0`.
-Intro.
-Elim (IZN x0 H2); Intros.
-Rewrite H3 in H0.
-Rewrite <- INR_IZR_INZ in H0.
-Rewrite H0.
-Elim (even_odd_cor x1); Intros.
-Elim H4; Intro.
-Rewrite H5.
-Rewrite mult_INR.
-Simpl.
-Rewrite <- (Rplus_Ol ``2*(INR x2)*PI``).
-Rewrite sin_period.
-Apply sin_0.
-Rewrite H5.
-Rewrite S_INR; Rewrite mult_INR.
-Simpl.
-Rewrite Rmult_Rplus_distrl.
-Rewrite Rmult_1l; Rewrite sin_plus.
-Rewrite sin_PI.
-Rewrite Rmult_Or.
-Rewrite <- (Rplus_Ol ``2*(INR x2)*PI``).
-Rewrite sin_period.
-Rewrite sin_0; Ring.
-Apply le_IZR.
-Left; Apply IZR_lt.
-Assert H2 := Zgt_iff_lt.
-Elim (H2 x0 `0`); Intros.
-Apply H3; Assumption.
-Intro.
-Rewrite H0.
-Replace ``(sin ((IZR x0)*PI))`` with ``-(sin (-(IZR x0)*PI))``.
-Cut `0<=-x0`.
-Intro.
-Rewrite <- Ropp_Ropp_IZR.
-Elim (IZN `-x0` H2); Intros.
-Rewrite H3.
-Rewrite <- INR_IZR_INZ.
-Elim (even_odd_cor x1); Intros.
-Elim H4; Intro.
-Rewrite H5.
-Rewrite mult_INR.
-Simpl.
-Rewrite <- (Rplus_Ol ``2*(INR x2)*PI``).
-Rewrite sin_period.
-Rewrite sin_0; Ring.
-Rewrite H5.
-Rewrite S_INR; Rewrite mult_INR.
-Simpl.
-Rewrite Rmult_Rplus_distrl.
-Rewrite Rmult_1l; Rewrite sin_plus.
-Rewrite sin_PI.
-Rewrite Rmult_Or.
-Rewrite <- (Rplus_Ol ``2*(INR x2)*PI``).
-Rewrite sin_period.
-Rewrite sin_0; Ring.
-Apply le_IZR.
-Apply Rle_anti_compatibility with ``(IZR x0)``.
-Rewrite Rplus_Or.
-Rewrite Ropp_Ropp_IZR.
-Rewrite Rplus_Ropp_r.
-Left; Replace R0 with (IZR `0`); [Apply IZR_lt | Reflexivity].
-Assumption.
-Rewrite <- sin_neg.
-Rewrite Ropp_mul1.
-Rewrite Ropp_Ropp.
-Reflexivity.
-Qed.
-
-Lemma sin_eq_0_0 : (x:R) (sin x)==R0 -> (EXT k:Z | x==(Rmult (IZR k) PI)).
-Intros.
-Assert H0 := (euclidian_division x PI PI_neq0).
-Elim H0; Intros q H1.
-Elim H1; Intros r H2.
-Exists q.
-Cut r==R0.
-Intro.
-Elim H2; Intros H4 _; Rewrite H4; Rewrite H3.
-Apply Rplus_Or.
-Elim H2; Intros.
-Rewrite H3 in H.
-Rewrite sin_plus in H.
-Cut ``(sin ((IZR q)*PI))==0``.
-Intro.
-Rewrite H5 in H.
-Rewrite Rmult_Ol in H.
-Rewrite Rplus_Ol in H.
-Assert H6 := (without_div_Od ? ? H).
-Elim H6; Intro.
-Assert H8 := (sin2_cos2 ``(IZR q)*PI``).
-Rewrite H5 in H8; Rewrite H7 in H8.
-Rewrite Rsqr_O in H8.
-Rewrite Rplus_Or in H8.
-Elim R1_neq_R0; Symmetry; Assumption.
-Cut r==R0\/``0<r<PI``.
-Intro; Elim H8; Intro.
-Assumption.
-Elim H9; Intros.
-Assert H12 := (sin_gt_0 ? H10 H11).
-Rewrite H7 in H12; Elim (Rlt_antirefl ? H12).
-Rewrite Rabsolu_right in H4.
-Elim H4; Intros.
-Case (total_order R0 r); Intro.
-Right; Split; Assumption.
-Elim H10; Intro.
-Left; Symmetry; Assumption.
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H8 H11)).
-Apply Rle_sym1.
-Left; Apply PI_RGT_0.
-Apply sin_eq_0_1.
-Exists q; Reflexivity.
-Qed.
-
-Lemma cos_eq_0_0 : (x:R) (cos x)==R0 -> (EXT k : Z | ``x==(IZR k)*PI+PI/2``). 
-Intros x H; Rewrite -> cos_sin in H; Generalize (sin_eq_0_0 (Rplus (Rdiv PI (INR (2))) x) H); Intro H2; Elim H2; Intros x0 H3; Exists (Zminus x0 (inject_nat (S O))); Rewrite <- Z_R_minus; Ring; Rewrite Rmult_sym; Rewrite <- H3; Unfold INR.
-Rewrite (double_var ``-PI``); Unfold Rdiv; Ring.
-Qed.
-
-Lemma  cos_eq_0_1 : (x:R) (EXT k : Z | ``x==(IZR k)*PI+PI/2``) -> ``(cos x)==0``.
-Intros x H1; Rewrite cos_sin; Elim H1; Intros x0 H2; Rewrite H2; Replace ``PI/2+((IZR x0)*PI+PI/2)`` with ``(IZR x0)*PI+PI``.
-Rewrite neg_sin; Rewrite <- Ropp_O.
-Apply eq_Ropp; Apply sin_eq_0_1; Exists x0; Reflexivity.
-Pattern 2 PI; Rewrite (double_var PI); Ring.
-Qed.
-
-Lemma sin_eq_O_2PI_0 : (x:R) ``0<=x`` -> ``x<=2*PI`` -> ``(sin x)==0`` -> ``x==0``\/``x==PI``\/``x==2*PI``.
-Intros; Generalize (sin_eq_0_0 x H1); Intro.
-Elim H2; Intros k0 H3.
-Case (total_order PI x); Intro.
-Rewrite H3 in H4; Rewrite H3 in H0.
-Right; Right.
-Generalize (Rlt_monotony_r ``/PI`` ``PI`` ``(IZR k0)*PI`` (Rlt_Rinv ``PI`` PI_RGT_0) H4); Rewrite Rmult_assoc; Repeat Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Intro; Generalize (Rle_monotony_r ``/PI`` ``(IZR k0)*PI`` ``2*PI`` (Rlt_le ``0`` ``/PI`` (Rlt_Rinv ``PI`` PI_RGT_0)) H0); Repeat Rewrite Rmult_assoc; Repeat Rewrite <- Rinv_r_sym.
-Repeat Rewrite Rmult_1r; Intro; Generalize (Rlt_compatibility (IZR `-2`) ``1`` (IZR k0) H5); Rewrite <- plus_IZR.
-Replace ``(IZR (NEG (xO xH)))+1`` with ``-1``.
-Intro; Generalize (Rle_compatibility (IZR `-2`) (IZR k0) ``2`` H6); Rewrite <- plus_IZR.
-Replace ``(IZR (NEG (xO xH)))+2`` with ``0``.
-Intro; Cut ``-1 < (IZR (Zplus (NEG (xO xH)) k0)) < 1``.
-Intro; Generalize (one_IZR_lt1 (Zplus (NEG (xO xH)) k0) H9); Intro.
-Cut k0=`2`.
-Intro; Rewrite H11 in H3; Rewrite H3; Simpl.
-Reflexivity.
-Rewrite <- (Zplus_inverse_l `2`) in H10; Generalize (Zsimpl_plus_l `-2` k0 `2` H10); Intro; Assumption.
-Split.
-Assumption.
-Apply Rle_lt_trans with ``0``.
-Assumption.
-Apply Rlt_R0_R1.
-Simpl; Ring.
-Simpl; Ring.
-Apply PI_neq0.
-Apply PI_neq0.
-Elim H4; Intro.
-Right; Left.
-Symmetry; Assumption.
-Left.
-Rewrite H3 in H5; Rewrite H3 in H; Generalize (Rlt_monotony_r ``/PI``  ``(IZR k0)*PI`` PI (Rlt_Rinv ``PI`` PI_RGT_0) H5); Rewrite Rmult_assoc; Repeat Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Intro; Generalize (Rle_monotony_r ``/PI`` ``0`` ``(IZR k0)*PI`` (Rlt_le ``0`` ``/PI`` (Rlt_Rinv ``PI`` PI_RGT_0)) H); Repeat Rewrite Rmult_assoc; Repeat Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Rewrite Rmult_Ol; Intro.
-Cut ``-1 < (IZR (k0)) < 1``.
-Intro; Generalize (one_IZR_lt1 k0 H8); Intro; Rewrite H9 in H3; Rewrite H3; Simpl; Apply Rmult_Ol.
-Split.
-Apply Rlt_le_trans with ``0``.
-Rewrite <- Ropp_O; Apply Rgt_Ropp; Apply Rlt_R0_R1.
-Assumption.
-Assumption.
-Apply PI_neq0.
-Apply PI_neq0.
-Qed.
-
-Lemma sin_eq_O_2PI_1 : (x:R) ``0<=x`` -> ``x<=2*PI`` -> ``x==0``\/``x==PI``\/``x==2*PI`` -> ``(sin x)==0``.
-Intros x H1 H2 H3; Elim H3; Intro H4; [ Rewrite H4; Rewrite -> sin_0; Reflexivity | Elim H4; Intro H5; [Rewrite H5; Rewrite -> sin_PI; Reflexivity | Rewrite H5; Rewrite -> sin_2PI; Reflexivity]].
-Qed.
-
-Lemma cos_eq_0_2PI_0 : (x:R) ``R0<=x`` -> ``x<=2*PI`` -> ``(cos x)==0`` -> ``x==(PI/2)``\/``x==3*(PI/2)``.
-Intros; Case (total_order x ``3*(PI/2)``); Intro.
-Rewrite cos_sin in H1.
-Cut ``0<=PI/2+x``.
-Cut ``PI/2+x<=2*PI``.
-Intros; Generalize (sin_eq_O_2PI_0 ``PI/2+x`` H4 H3 H1); Intros.
-Decompose [or] H5.
-Generalize (Rle_compatibility ``PI/2`` ``0`` x H); Rewrite Rplus_Or; Rewrite H6; Intro.
-Elim (Rlt_antirefl ``0`` (Rlt_le_trans ``0`` ``PI/2`` ``0`` PI2_RGT_0 H7)).
-Left.
-Generalize (Rplus_plus_r ``-(PI/2)`` ``PI/2+x`` PI H7).
-Replace ``-(PI/2)+(PI/2+x)`` with x.
-Replace ``-(PI/2)+PI`` with ``PI/2``.
-Intro; Assumption.
-Pattern 3 PI; Rewrite (double_var PI); Ring.
-Ring.
-Right.
-Generalize (Rplus_plus_r ``-(PI/2)`` ``PI/2+x`` ``2*PI`` H7).
-Replace ``-(PI/2)+(PI/2+x)`` with x.
-Replace ``-(PI/2)+2*PI`` with ``3*(PI/2)``.
-Intro; Assumption.
-Rewrite double; Pattern 3 4 PI; Rewrite (double_var PI); Ring.
-Ring.
-Left; Replace ``2*PI`` with ``PI/2+3*(PI/2)``.
-Apply Rlt_compatibility; Assumption.
-Rewrite (double PI); Pattern 3 4 PI; Rewrite (double_var PI); Ring.
-Apply ge0_plus_ge0_is_ge0.
-Left; Unfold Rdiv; Apply Rmult_lt_pos.
-Apply PI_RGT_0.
-Apply Rlt_Rinv; Sup0. 
-Assumption.
-Elim H2; Intro.
-Right; Assumption.
-Generalize (cos_eq_0_0 x H1); Intro; Elim H4; Intros k0 H5.
-Rewrite H5 in H3; Rewrite H5 in H0; Generalize (Rlt_compatibility ``-(PI/2)`` ``3*PI/2`` ``(IZR k0)*PI+PI/2`` H3); Generalize (Rle_compatibility ``-(PI/2)`` ``(IZR k0)*PI+PI/2`` ``2*PI`` H0).
-Replace ``-(PI/2)+3*PI/2`` with PI.
-Replace ``-(PI/2)+((IZR k0)*PI+PI/2)`` with ``(IZR k0)*PI``.
-Replace ``-(PI/2)+2*PI`` with ``3*(PI/2)``.
-Intros; Generalize (Rlt_monotony ``/PI`` ``PI`` ``(IZR k0)*PI`` (Rlt_Rinv PI PI_RGT_0) H7); Generalize (Rle_monotony ``/PI`` ``(IZR k0)*PI`` ``3*(PI/2)`` (Rlt_le ``0`` ``/PI`` (Rlt_Rinv PI PI_RGT_0)) H6).
-Replace ``/PI*((IZR k0)*PI)`` with (IZR k0).
-Replace ``/PI*(3*PI/2)`` with ``3*/2``.
-Rewrite <- Rinv_l_sym.
-Intros; Generalize (Rlt_compatibility (IZR `-2`) ``1`` (IZR k0) H9); Rewrite <- plus_IZR.
-Replace ``(IZR (NEG (xO xH)))+1`` with ``-1``.
-Intro; Generalize (Rle_compatibility (IZR `-2`) (IZR k0) ``3*/2`` H8); Rewrite <- plus_IZR.
-Replace ``(IZR (NEG (xO xH)))+2`` with ``0``.
-Intro; Cut `` -1 < (IZR (Zplus (NEG (xO xH)) k0)) < 1``.
-Intro; Generalize (one_IZR_lt1 (Zplus (NEG (xO xH)) k0) H12); Intro.
-Cut k0=`2`.
-Intro; Rewrite H14 in H8.
-Assert Hyp : ``0<2``.
-Sup0.
-Generalize (Rle_monotony ``2`` ``(IZR (POS (xO xH)))`` ``3*/2`` (Rlt_le ``0`` ``2`` Hyp) H8); Simpl.
-Replace ``2*2`` with ``4``.
-Replace ``2*(3*/2)`` with ``3``.
-Intro; Cut ``3<4``.
-Intro; Elim (Rlt_antirefl ``3`` (Rlt_le_trans ``3`` ``4`` ``3`` H16 H15)).
-Generalize (Rlt_compatibility ``3`` ``0`` ``1`` Rlt_R0_R1); Rewrite Rplus_Or.
-Replace ``3+1`` with ``4``.
-Intro; Assumption.
-Ring.
-Symmetry; Rewrite <- Rmult_assoc; Apply Rinv_r_simpl_m.
-DiscrR.
-Ring.
-Rewrite <- (Zplus_inverse_l `2`) in H13; Generalize (Zsimpl_plus_l `-2` k0 `2` H13); Intro; Assumption.
-Split.
-Assumption.
-Apply Rle_lt_trans with ``(IZR (NEG (xO xH)))+3*/2``.
-Assumption.
-Simpl; Replace ``-2+3*/2`` with ``-(1*/2)``.
-Apply Rlt_trans with ``0``.
-Rewrite <- Ropp_O; Apply Rlt_Ropp.
-Apply Rmult_lt_pos; [Apply Rlt_R0_R1 | Apply Rlt_Rinv; Sup0].
-Apply Rlt_R0_R1.
-Rewrite Rmult_1l; Apply r_Rmult_mult with ``2``.
-Rewrite Ropp_mul3; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_Rplus_distr; Rewrite <- Rmult_assoc; Rewrite Rinv_r_simpl_m.
-Ring.
-DiscrR.
-DiscrR.
-DiscrR.
-Simpl; Ring.
-Simpl; Ring.
-Apply PI_neq0.
-Unfold Rdiv; Pattern 1 ``3``; Rewrite (Rmult_sym ``3``); Repeat Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Apply Rmult_sym.
-Apply PI_neq0.
-Symmetry; Rewrite (Rmult_sym ``/PI``); Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Apply Rmult_1r.
-Apply PI_neq0.
-Rewrite double; Pattern 3 4 PI; Rewrite double_var; Ring.
-Ring.
-Pattern 1 PI; Rewrite double_var; Ring.
-Qed.
-
-Lemma  cos_eq_0_2PI_1 : (x:R) ``0<=x`` -> ``x<=2*PI`` -> ``x==PI/2``\/``x==3*(PI/2)`` -> ``(cos x)==0``.
-Intros x H1 H2 H3; Elim H3; Intro H4; [ Rewrite H4; Rewrite -> cos_PI2; Reflexivity | Rewrite H4; Rewrite -> cos_3PI2; Reflexivity ].
-Qed.
diff --git a/theories7/Reals/Rtrigo_alt.v b/theories7/Reals/Rtrigo_alt.v
deleted file mode 100644
index db0e2fea..00000000
--- a/theories7/Reals/Rtrigo_alt.v
+++ /dev/null
@@ -1,294 +0,0 @@
-(************************************************************************)
-(*  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: Rtrigo_alt.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo_def.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(*****************************************************************)
-(* Using series definitions of cos and sin                       *)
-(*****************************************************************)
-
-Definition sin_term [a:R] : nat->R := [i:nat] ``(pow (-1) i)*(pow a (plus (mult (S (S O)) i) (S O)))/(INR (fact (plus (mult (S (S O)) i) (S O))))``.
-
-Definition cos_term [a:R] : nat->R := [i:nat] ``(pow (-1) i)*(pow a (mult (S (S O)) i))/(INR (fact (mult (S (S O)) i)))``.
-
-Definition sin_approx [a:R;n:nat] : R := (sum_f_R0 (sin_term a) n).
-
-Definition cos_approx [a:R;n:nat] : R := (sum_f_R0 (cos_term a) n).
-
-(**********)
-Lemma PI_4 : ``PI<=4``.
-Assert H0 := (PI_ineq O).
-Elim H0; Clear H0; Intros _ H0.
-Unfold tg_alt PI_tg in H0; Simpl in H0.
-Rewrite Rinv_R1 in H0; Rewrite Rmult_1r in H0; Unfold Rdiv in H0.
-Apply Rle_monotony_contra with ``/4``.
-Apply Rlt_Rinv; Sup0.
-Rewrite <- Rinv_l_sym; [Rewrite Rmult_sym; Assumption | DiscrR].
-Qed.
-
-(**********)
-Theorem sin_bound : (a:R; n:nat) ``0 <= a``->``a <= PI``->``(sin_approx a (plus (mult (S (S O)) n) (S O))) <= (sin a)<= (sin_approx a (mult (S (S O)) (plus n (S O))))``.
-Intros; Case (Req_EM a R0); Intro Hyp_a.
-Rewrite Hyp_a; Rewrite sin_0; Split; Right; Unfold sin_approx; Apply sum_eq_R0 Orelse (Symmetry; Apply sum_eq_R0); Intros; Unfold sin_term; Rewrite pow_add; Simpl; Unfold Rdiv; Rewrite Rmult_Ol; Ring.
-Unfold sin_approx; Cut ``0<a``.
-Intro Hyp_a_pos.
-Rewrite (decomp_sum (sin_term a) (plus (mult (S (S O)) n) (S O))).
-Rewrite (decomp_sum (sin_term a) (mult (S (S O)) (plus n (S O)))).
-Replace (sin_term a O) with a.
-Cut (Rle (sum_f_R0 [i:nat](sin_term a (S i)) (pred (plus (mult (S (S O)) n) (S O)))) ``(sin a)-a``)/\(Rle ``(sin a)-a`` (sum_f_R0 [i:nat](sin_term a (S i)) (pred (mult (S (S O)) (plus n (S O)))))) -> (Rle (Rplus a (sum_f_R0 [i:nat](sin_term a (S i)) (pred (plus (mult (S (S O)) n) (S O))))) (sin a))/\(Rle (sin a) (Rplus a (sum_f_R0 [i:nat](sin_term a (S i)) (pred (mult (S (S O)) (plus n (S O))))))).
-Intro; Apply H1.
-Pose Un := [n:nat]``(pow a (plus (mult (S (S O)) (S n)) (S O)))/(INR (fact (plus (mult (S (S O)) (S n)) (S O))))``.
-Replace (pred (plus (mult (S (S O)) n) (S O))) with (mult (S (S O)) n).
-Replace (pred (mult (S (S O)) (plus n (S O)))) with (S (mult (S (S O)) n)).
-Replace (sum_f_R0 [i:nat](sin_term a (S i)) (mult (S (S O)) n)) with ``-(sum_f_R0 (tg_alt Un) (mult (S (S O)) n))``.
-Replace (sum_f_R0 [i:nat](sin_term a (S i)) (S (mult (S (S O)) n))) with ``-(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n)))``.
-Cut ``(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n)))<=a-(sin a)<=(sum_f_R0 (tg_alt Un) (mult (S (S O)) n))``->`` -(sum_f_R0 (tg_alt Un) (mult (S (S O)) n)) <= (sin a)-a <=  -(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n)))``.
-Intro; Apply H2.
-Apply alternated_series_ineq.
-Unfold Un_decreasing Un; Intro; Cut (plus (mult (S (S O)) (S (S n0))) (S O))=(S (S (plus (mult (S (S O)) (S n0)) (S O)))).
-Intro; Rewrite H3.
-Replace ``(pow a (S (S (plus (mult (S (S O)) (S n0)) (S O)))))`` with ``(pow a (plus (mult (S (S O)) (S n0)) (S O)))*(a*a)``.
-Unfold Rdiv; Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply pow_lt; Assumption.
-Apply Rle_monotony_contra with ``(INR (fact (S (S (plus (mult (S (S O)) (S n0)) (S O))))))``.
-Rewrite <- H3; Apply lt_INR_0; Apply neq_O_lt; Red; Intro; Assert H5 := (sym_eq ? ? ? H4); Elim (fact_neq_0 ? H5).
-Rewrite <- H3; Rewrite (Rmult_sym ``(INR (fact (plus (mult (S (S O)) (S (S n0))) (S O))))``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite H3; Do 2 Rewrite fact_simpl; Do 2 Rewrite mult_INR; Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r.
-Do 2 Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Simpl; Replace ``((0+1+1)*((INR n0)+1)+(0+1)+1+1)*((0+1+1)*((INR n0)+1)+(0+1)+1)`` with ``4*(INR n0)*(INR n0)+18*(INR n0)+20``; [Idtac | Ring].
-Apply Rle_trans with ``20``.
-Apply Rle_trans with ``16``.
-Replace ``16`` with ``(Rsqr 4)``; [Idtac | SqRing].
-Replace ``a*a`` with (Rsqr a); [Idtac | Reflexivity].
-Apply Rsqr_incr_1.
-Apply Rle_trans with PI; [Assumption | Apply PI_4].
-Assumption.
-Left; Sup0.
-Rewrite <- (Rplus_Or ``16``); Replace ``20`` with ``16+4``; [Apply Rle_compatibility; Left; Sup0 | Ring].
-Rewrite <- (Rplus_sym ``20``); Pattern 1 ``20``; Rewrite <- Rplus_Or; Apply Rle_compatibility.
-Apply ge0_plus_ge0_is_ge0.
-Repeat Apply Rmult_le_pos.
-Left; Sup0.
-Left; Sup0.
-Replace R0 with (INR O); [Apply le_INR; Apply le_O_n | Reflexivity].
-Replace R0 with (INR O); [Apply le_INR; Apply le_O_n | Reflexivity].
-Apply Rmult_le_pos.
-Left; Sup0.
-Replace R0 with (INR O); [Apply le_INR; Apply le_O_n | Reflexivity].
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Simpl; Ring.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite plus_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Assert H3 := (cv_speed_pow_fact a); Unfold Un; Unfold Un_cv in H3; Unfold R_dist in H3; Unfold Un_cv; Unfold R_dist; Intros; Elim (H3 eps H4); Intros N H5.
-Exists N; Intros; Apply H5.
-Replace (plus (mult (2) (S n0)) (1)) with (S (mult (2) (S n0))).
-Unfold ge; Apply le_trans with (mult (2) (S n0)).
-Apply le_trans with (mult (2) (S N)).
-Apply le_trans with (mult (2) N).
-Apply le_n_2n.
-Apply mult_le; Apply le_n_Sn.
-Apply mult_le; Apply le_n_S; Assumption.
-Apply le_n_Sn.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Reflexivity.
-Assert X := (exist_sin (Rsqr a)); Elim X; Intros.
-Cut ``x==(sin a)/a``.
-Intro; Rewrite H3 in p; Unfold sin_in in p; Unfold infinit_sum in p; Unfold R_dist in p; Unfold Un_cv; Unfold R_dist; Intros.
-Cut ``0<eps/(Rabsolu a)``.
-Intro; Elim (p ? H5); Intros N H6.
-Exists N; Intros.
-Replace (sum_f_R0 (tg_alt Un) n0) with (Rmult a (Rminus R1 (sum_f_R0 [i:nat]``(sin_n i)*(pow (Rsqr a) i)`` (S n0)))).
-Unfold Rminus; Rewrite Rmult_Rplus_distr; Rewrite Rmult_1r; Rewrite Ropp_distr1; Rewrite Ropp_Ropp; Repeat Rewrite Rplus_assoc; Rewrite (Rplus_sym a); Rewrite (Rplus_sym ``-a``); Repeat Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Apply Rlt_monotony_contra with ``/(Rabsolu a)``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption.
-Pattern 1 ``/(Rabsolu a)``; Rewrite <- (Rabsolu_Rinv a  Hyp_a).
-Rewrite <- Rabsolu_mult; Rewrite Rmult_Rplus_distr; Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym; [Rewrite Rmult_1l | Assumption]; Rewrite (Rmult_sym ``/a``); Rewrite (Rmult_sym ``/(Rabsolu a)``); Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr1; Rewrite Ropp_Ropp; Unfold Rminus Rdiv in H6; Apply H6; Unfold ge; Apply le_trans with n0; [Exact H7 | Apply le_n_Sn].
-Rewrite (decomp_sum [i:nat]``(sin_n i)*(pow (Rsqr a) i)`` (S n0)).
-Replace (sin_n O) with R1.
-Simpl; Rewrite Rmult_1r; Unfold Rminus; Rewrite Ropp_distr1; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Ol; Rewrite Ropp_mul3; Rewrite <- Ropp_mul1; Rewrite scal_sum; Apply sum_eq.
-Intros; Unfold sin_n Un tg_alt; Replace ``(pow (-1) (S i))`` with ``-(pow (-1) i)``.
-Replace ``(pow a (plus (mult (S (S O)) (S i)) (S O)))`` with ``(Rsqr a)*(pow (Rsqr a) i)*a``.
-Unfold Rdiv; Ring.
-Rewrite pow_add; Rewrite pow_Rsqr; Simpl; Ring.
-Simpl; Ring.
-Unfold sin_n; Unfold Rdiv; Simpl; Rewrite Rinv_R1; Rewrite Rmult_1r; Reflexivity.
-Apply lt_O_Sn.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Assumption.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption.
-Unfold sin; Case (exist_sin (Rsqr a)).
-Intros; Cut x==x0.
-Intro; Rewrite H3; Unfold Rdiv.
-Symmetry; Apply Rinv_r_simpl_m; Assumption.
-Unfold sin_in in p; Unfold sin_in in s; EApply unicity_sum.
-Apply p.
-Apply s.
-Intros; Elim H2; Intros.
-Replace ``(sin a)-a`` with ``-(a-(sin a))``; [Idtac | Ring].
-Split; Apply Rle_Ropp1; Assumption.
-Replace ``-(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n)))`` with ``-1*(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n)))``; [Rewrite scal_sum | Ring].
-Apply sum_eq; Intros; Unfold sin_term Un tg_alt; Replace ``(pow (-1) (S i))`` with ``-1*(pow (-1) i)``.
-Unfold Rdiv; Ring.
-Reflexivity.
-Replace ``-(sum_f_R0 (tg_alt Un) (mult (S (S O)) n))`` with ``-1*(sum_f_R0 (tg_alt Un) (mult (S (S O)) n))``; [Rewrite scal_sum | Ring].
-Apply sum_eq; Intros.
-Unfold sin_term Un tg_alt; Replace ``(pow (-1) (S i))`` with ``-1*(pow (-1) i)``.
-Unfold Rdiv; Ring.
-Reflexivity.
-Replace (mult (2) (plus n (1))) with (S (S (mult (2) n))).
-Reflexivity.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Rewrite plus_INR; Repeat Rewrite S_INR; Ring.
-Replace (plus (mult (2) n) (1)) with (S (mult (2) n)).
-Reflexivity.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Intro; Elim H1; Intros.
-Split.
-Apply Rle_anti_compatibility with ``-a``.
-Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Rewrite (Rplus_sym ``-a``); Apply H2.
-Apply Rle_anti_compatibility with ``-a``.
-Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Rewrite (Rplus_sym ``-a``); Apply H3.
-Unfold sin_term; Simpl; Unfold Rdiv; Rewrite Rinv_R1; Ring.
-Replace (mult (2) (plus n (1))) with (S (S (mult (2) n))).
-Apply lt_O_Sn.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Rewrite plus_INR; Repeat Rewrite S_INR; Ring.
-Replace (plus (mult (2) n) (1)) with (S (mult (2) n)).
-Apply lt_O_Sn.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Inversion H; [Assumption | Elim Hyp_a; Symmetry; Assumption].
-Qed.
-
-(**********)
-Lemma cos_bound : (a:R; n:nat) `` -PI/2 <= a``->``a <= PI/2``->``(cos_approx a (plus (mult (S (S O)) n) (S O))) <= (cos a) <= (cos_approx a (mult (S (S O)) (plus n (S O))))``. 
-Cut ((a:R; n:nat) ``0 <= a``->``a <= PI/2``->``(cos_approx a (plus (mult (S (S O)) n) (S O))) <= (cos a) <= (cos_approx a (mult (S (S O)) (plus n (S O))))``) -> ((a:R; n:nat) `` -PI/2 <= a``->``a <= PI/2``->``(cos_approx a (plus (mult (S (S O)) n) (S O))) <= (cos a) <= (cos_approx a (mult (S (S O)) (plus n (S O))))``).
-Intros H a n; Apply H.
-Intros; Unfold cos_approx.
-Rewrite (decomp_sum (cos_term a0) (plus (mult (S (S O)) n0) (S O))).
-Rewrite (decomp_sum (cos_term a0) (mult (S (S O)) (plus n0 (S O)))).
-Replace (cos_term a0 O) with R1.
-Cut (Rle (sum_f_R0 [i:nat](cos_term a0 (S i)) (pred (plus (mult (S (S O)) n0) (S O)))) ``(cos a0)-1``)/\(Rle ``(cos a0)-1`` (sum_f_R0 [i:nat](cos_term a0 (S i)) (pred (mult (S (S O)) (plus n0 (S O)))))) -> (Rle (Rplus R1 (sum_f_R0 [i:nat](cos_term a0 (S i)) (pred (plus (mult (S (S O)) n0) (S O))))) (cos a0))/\(Rle (cos a0) (Rplus R1 (sum_f_R0 [i:nat](cos_term a0 (S i)) (pred (mult (S (S O)) (plus n0 (S O))))))).
-Intro; Apply H2.
-Pose Un := [n:nat]``(pow a0 (mult (S (S O)) (S n)))/(INR (fact (mult (S (S O)) (S n))))``.
-Replace (pred (plus (mult (S (S O)) n0) (S O))) with (mult (S (S O)) n0).
-Replace (pred (mult (S (S O)) (plus n0 (S O)))) with (S (mult (S (S O)) n0)).
-Replace (sum_f_R0 [i:nat](cos_term a0 (S i)) (mult (S (S O)) n0)) with ``-(sum_f_R0 (tg_alt Un) (mult (S (S O)) n0))``.
-Replace (sum_f_R0 [i:nat](cos_term a0 (S i)) (S (mult (S (S O)) n0))) with ``-(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n0)))``.
-Cut ``(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n0)))<=1-(cos a0)<=(sum_f_R0 (tg_alt Un) (mult (S (S O)) n0))``->`` -(sum_f_R0 (tg_alt Un) (mult (S (S O)) n0)) <= (cos a0)-1 <=  -(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n0)))``.
-Intro; Apply H3.
-Apply alternated_series_ineq.
-Unfold Un_decreasing; Intro; Unfold Un.
-Cut (mult (S (S O)) (S (S n1)))=(S (S (mult (S (S O)) (S n1)))).
-Intro; Rewrite H4; Replace ``(pow a0 (S (S (mult (S (S O)) (S n1)))))`` with ``(pow a0 (mult (S (S O)) (S n1)))*(a0*a0)``.
-Unfold Rdiv; Rewrite Rmult_assoc; Apply Rle_monotony.
-Apply pow_le; Assumption.
-Apply Rle_monotony_contra with ``(INR (fact (S (S (mult (S (S O)) (S n1))))))``.
-Rewrite <- H4; Apply lt_INR_0; Apply neq_O_lt; Red; Intro; Assert H6 := (sym_eq ? ? ? H5); Elim (fact_neq_0 ? H6).
-Rewrite <- H4; Rewrite (Rmult_sym ``(INR (fact (mult (S (S O)) (S (S n1)))))``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite H4; Do 2 Rewrite fact_simpl; Do 2 Rewrite mult_INR; Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Do 2 Rewrite S_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Simpl; Replace ``((0+1+1)*((INR n1)+1)+1+1)*((0+1+1)*((INR n1)+1)+1)`` with ``4*(INR n1)*(INR n1)+14*(INR n1)+12``; [Idtac | Ring].
-Apply Rle_trans with ``12``.
-Apply Rle_trans with ``4``.
-Replace ``4`` with ``(Rsqr 2)``; [Idtac | SqRing].
-Replace ``a0*a0`` with (Rsqr a0); [Idtac | Reflexivity].
-Apply Rsqr_incr_1.
-Apply Rle_trans with ``PI/2``.
-Assumption.
-Unfold Rdiv; Apply Rle_monotony_contra with ``2``.
-Sup0.
-Rewrite <- Rmult_assoc; Rewrite Rinv_r_simpl_m.
-Replace ``2*2`` with ``4``; [Apply PI_4 | Ring].
-DiscrR.
-Assumption.
-Left; Sup0.
-Pattern 1 ``4``; Rewrite <- Rplus_Or; Replace ``12`` with ``4+8``; [Apply Rle_compatibility; Left; Sup0 | Ring].
-Rewrite <- (Rplus_sym ``12``); Pattern 1 ``12``; Rewrite <- Rplus_Or; Apply Rle_compatibility.
-Apply ge0_plus_ge0_is_ge0.
-Repeat Apply Rmult_le_pos.
-Left; Sup0.
-Left; Sup0.
-Replace R0 with (INR O); [Apply le_INR; Apply le_O_n | Reflexivity].
-Replace R0 with (INR O); [Apply le_INR; Apply le_O_n | Reflexivity].
-Apply Rmult_le_pos.
-Left; Sup0.
-Replace R0 with (INR O); [Apply le_INR; Apply le_O_n | Reflexivity].
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Simpl; Ring.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Assert H4 := (cv_speed_pow_fact a0); Unfold Un; Unfold Un_cv in H4; Unfold R_dist in H4; Unfold Un_cv; Unfold R_dist; Intros; Elim (H4 eps H5); Intros N H6; Exists N; Intros.
-Apply H6; Unfold ge; Apply le_trans with (mult (2) (S N)).
-Apply le_trans with (mult (2) N).
-Apply le_n_2n.
-Apply mult_le; Apply le_n_Sn.
-Apply mult_le; Apply le_n_S; Assumption.
-Assert X := (exist_cos (Rsqr a0)); Elim X; Intros.
-Cut ``x==(cos a0)``.
-Intro; Rewrite H4 in p; Unfold cos_in in p; Unfold infinit_sum in p; Unfold R_dist in p; Unfold Un_cv; Unfold R_dist; Intros.
-Elim (p ? H5); Intros N H6.
-Exists N; Intros.
-Replace (sum_f_R0 (tg_alt Un) n1) with (Rminus R1 (sum_f_R0 [i:nat]``(cos_n i)*(pow (Rsqr a0) i)`` (S n1))).
-Unfold Rminus; Rewrite Ropp_distr1; Rewrite Ropp_Ropp; Repeat Rewrite Rplus_assoc; Rewrite (Rplus_sym R1); Rewrite (Rplus_sym ``-1``); Repeat Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr1; Rewrite Ropp_Ropp; Unfold Rminus in H6; Apply H6.
-Unfold ge; Apply le_trans with n1.
-Exact H7.
-Apply le_n_Sn.
-Rewrite (decomp_sum [i:nat]``(cos_n i)*(pow (Rsqr a0) i)`` (S n1)).
-Replace (cos_n O) with R1.
-Simpl; Rewrite Rmult_1r; Unfold Rminus; Rewrite Ropp_distr1; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Ol; Replace (Ropp (sum_f_R0 [i:nat]``(cos_n (S i))*((Rsqr a0)*(pow (Rsqr a0) i))`` n1)) with (Rmult ``-1`` (sum_f_R0 [i:nat]``(cos_n (S i))*((Rsqr a0)*(pow (Rsqr a0) i))`` n1)); [Idtac | Ring]; Rewrite scal_sum; Apply sum_eq; Intros; Unfold cos_n Un tg_alt.
-Replace ``(pow (-1) (S i))`` with ``-(pow (-1) i)``.
-Replace ``(pow a0 (mult (S (S O)) (S i)))`` with ``(Rsqr a0)*(pow (Rsqr a0) i)``.
-Unfold Rdiv; Ring.
-Rewrite pow_Rsqr; Reflexivity.
-Simpl; Ring.
-Unfold cos_n; Unfold Rdiv; Simpl; Rewrite Rinv_R1; Rewrite Rmult_1r; Reflexivity.
-Apply lt_O_Sn.
-Unfold cos; Case (exist_cos (Rsqr a0)); Intros; Unfold cos_in in p; Unfold cos_in in c; EApply unicity_sum.
-Apply p.
-Apply c.
-Intros; Elim H3; Intros; Replace ``(cos a0)-1`` with ``-(1-(cos a0))``; [Idtac | Ring].
-Split; Apply Rle_Ropp1; Assumption.
-Replace ``-(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n0)))`` with ``-1*(sum_f_R0 (tg_alt Un) (S (mult (S (S O)) n0)))``; [Rewrite scal_sum | Ring].
-Apply sum_eq; Intros; Unfold cos_term Un tg_alt; Replace ``(pow (-1) (S i))`` with ``-1*(pow (-1) i)``.
-Unfold Rdiv; Ring.
-Reflexivity.
-Replace ``-(sum_f_R0 (tg_alt Un) (mult (S (S O)) n0))`` with ``-1*(sum_f_R0 (tg_alt Un) (mult (S (S O)) n0))``; [Rewrite scal_sum | Ring]; Apply sum_eq; Intros; Unfold cos_term Un tg_alt; Replace ``(pow (-1) (S i))`` with ``-1*(pow (-1) i)``.
-Unfold Rdiv; Ring.
-Reflexivity.
-Replace (mult (2) (plus n0 (1))) with (S (S (mult (2) n0))).
-Reflexivity.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Rewrite plus_INR; Repeat Rewrite S_INR; Ring.
-Replace (plus (mult (2) n0) (1)) with (S (mult (2) n0)).
-Reflexivity.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Intro; Elim H2; Intros; Split.
-Apply Rle_anti_compatibility with ``-1``.
-Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Rewrite (Rplus_sym ``-1``); Apply H3.
-Apply Rle_anti_compatibility with ``-1``.
-Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Rewrite (Rplus_sym ``-1``); Apply H4.
-Unfold cos_term; Simpl; Unfold Rdiv; Rewrite Rinv_R1; Ring.
-Replace (mult (2) (plus n0 (1))) with (S (S (mult (2) n0))).
-Apply lt_O_Sn.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Rewrite plus_INR; Repeat Rewrite S_INR; Ring.
-Replace (plus (mult (2) n0) (1)) with (S (mult (2) n0)).
-Apply lt_O_Sn.
-Apply INR_eq; Rewrite S_INR; Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Intros; Case (total_order_T R0 a); Intro.
-Elim s; Intro.
-Apply H; [Left; Assumption | Assumption].
-Apply H; [Right; Assumption | Assumption].
-Cut ``0< -a``.
-Intro; Cut (x:R;n:nat) (cos_approx x n)==(cos_approx ``-x`` n).
-Intro; Rewrite H3; Rewrite (H3 a (mult (S (S O)) (plus n (S O)))); Rewrite cos_sym; Apply H.
-Left; Assumption.
-Rewrite <- (Ropp_Ropp ``PI/2``); Apply Rle_Ropp1; Unfold Rdiv; Unfold Rdiv in H0; Rewrite <- Ropp_mul1; Exact H0.
-Intros; Unfold cos_approx; Apply sum_eq; Intros; Unfold cos_term; Do 2 Rewrite pow_Rsqr; Rewrite Rsqr_neg; Unfold Rdiv; Reflexivity.
-Apply Rgt_RO_Ropp; Assumption.
-Qed.
diff --git a/theories7/Reals/Rtrigo_calc.v b/theories7/Reals/Rtrigo_calc.v
deleted file mode 100644
index ab181106..00000000
--- a/theories7/Reals/Rtrigo_calc.v
+++ /dev/null
@@ -1,350 +0,0 @@
-(************************************************************************)
-(*  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: Rtrigo_calc.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo.
-Require R_sqrt.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Lemma tan_PI : ``(tan PI)==0``.
-Unfold tan; Rewrite sin_PI; Rewrite cos_PI; Unfold Rdiv; Apply Rmult_Ol. 
-Qed.
-
-Lemma sin_3PI2 : ``(sin (3*(PI/2)))==(-1)``.
-Replace ``3*(PI/2)`` with ``PI+(PI/2)``.
-Rewrite sin_plus; Rewrite sin_PI; Rewrite cos_PI; Rewrite sin_PI2; Ring.
-Pattern 1 PI; Rewrite (double_var PI); Ring.
-Qed.
-
-Lemma tan_2PI : ``(tan (2*PI))==0``.
-Unfold tan; Rewrite sin_2PI; Unfold Rdiv; Apply Rmult_Ol.
-Qed.
-
-Lemma sin_cos_PI4 : ``(sin (PI/4)) == (cos (PI/4))``.
-Proof with Trivial.
-Rewrite cos_sin.
-Replace ``PI/2+PI/4`` with ``-(PI/4)+PI``.
-Rewrite neg_sin; Rewrite sin_neg; Ring.
-Cut ``PI==PI/2+PI/2``; [Intro | Apply double_var].
-Pattern 2 3 PI; Rewrite H; Pattern 2 3 PI; Rewrite H.
-Assert H0 : ``2<>0``; [DiscrR | Unfold Rdiv; Rewrite Rinv_Rmult; Try Ring].
-Qed.
-
-Lemma sin_PI3_cos_PI6 : ``(sin (PI/3))==(cos (PI/6))``.
-Proof with Trivial.
-Replace ``PI/6`` with ``(PI/2)-(PI/3)``.
-Rewrite cos_shift.
-Assert H0 : ``6<>0``; [DiscrR | Idtac].
-Assert H1 : ``3<>0``; [DiscrR | Idtac].
-Assert H2 : ``2<>0``; [DiscrR | Idtac].
-Apply r_Rmult_mult with ``6``.
-Rewrite Rminus_distr; Repeat Rewrite (Rmult_sym ``6``).
-Unfold Rdiv; Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite (Rmult_sym ``/3``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Pattern 2 PI; Rewrite (Rmult_sym PI); Repeat Rewrite Rmult_1r; Repeat Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Ring.
-Qed.
-
-Lemma sin_PI6_cos_PI3 : ``(cos (PI/3))==(sin (PI/6))``.
-Proof with Trivial.
-Replace ``PI/6`` with ``(PI/2)-(PI/3)``.
-Rewrite sin_shift.
-Assert H0 : ``6<>0``; [DiscrR | Idtac].
-Assert H1 : ``3<>0``; [DiscrR | Idtac].
-Assert H2 : ``2<>0``; [DiscrR | Idtac].
-Apply r_Rmult_mult with ``6``.
-Rewrite Rminus_distr; Repeat Rewrite (Rmult_sym ``6``).
-Unfold Rdiv; Repeat Rewrite Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite (Rmult_sym ``/3``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Pattern 2 PI; Rewrite (Rmult_sym PI); Repeat Rewrite Rmult_1r; Repeat Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Ring.
-Qed.
-
-Lemma PI6_RGT_0 : ``0<PI/6``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply PI_RGT_0 | Apply Rlt_Rinv; Sup0].
-Qed.
-
-Lemma PI6_RLT_PI2 : ``PI/6<PI/2``.
-Unfold Rdiv; Apply Rlt_monotony.
-Apply PI_RGT_0.
-Apply Rinv_lt; Sup.
-Qed.
-
-Lemma sin_PI6 : ``(sin (PI/6))==1/2``.
-Proof with Trivial.
-Assert H : ``2<>0``; [DiscrR | Idtac].
-Apply r_Rmult_mult with ``2*(cos (PI/6))``.
-Replace ``2*(cos (PI/6))*(sin (PI/6))`` with ``2*(sin (PI/6))*(cos (PI/6))``.
-Rewrite <- sin_2a; Replace ``2*(PI/6)`` with ``PI/3``.
-Rewrite sin_PI3_cos_PI6.
-Unfold Rdiv; Rewrite Rmult_1l; Rewrite Rmult_assoc; Pattern 2 ``2``; Rewrite (Rmult_sym ``2``); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Unfold Rdiv; Rewrite Rinv_Rmult.
-Rewrite (Rmult_sym ``/2``); Rewrite (Rmult_sym ``2``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-DiscrR.
-Ring.
-Apply prod_neq_R0.
-Cut ``0<(cos (PI/6))``; [Intro H1; Auto with real | Apply cos_gt_0; [Apply (Rlt_trans ``-(PI/2)`` ``0`` ``PI/6`` _PI2_RLT_0 PI6_RGT_0) | Apply PI6_RLT_PI2]].
-Qed.
-
-Lemma sqrt2_neq_0 : ~``(sqrt 2)==0``.
-Assert Hyp:``0<2``; [Sup0 | Generalize (Rlt_le ``0`` ``2`` Hyp); Intro H1; Red; Intro H2; Generalize (sqrt_eq_0 ``2`` H1 H2); Intro H; Absurd ``2==0``; [ DiscrR | Assumption]].
-Qed.
-
-Lemma R1_sqrt2_neq_0 : ~``1/(sqrt 2)==0``.
-Generalize (Rinv_neq_R0 ``(sqrt 2)`` sqrt2_neq_0); Intro H; Generalize (prod_neq_R0 ``1`` ``(Rinv (sqrt 2))`` R1_neq_R0 H); Intro H0; Assumption.
-Qed.
-
-Lemma sqrt3_2_neq_0 : ~``2*(sqrt 3)==0``.
-Apply prod_neq_R0; [DiscrR | Assert Hyp:``0<3``; [Sup0 | Generalize (Rlt_le ``0`` ``3`` Hyp); Intro H1; Red; Intro H2; Generalize (sqrt_eq_0 ``3`` H1 H2); Intro H; Absurd ``3==0``; [ DiscrR | Assumption]]].
-Qed.
-
-Lemma Rlt_sqrt2_0 : ``0<(sqrt 2)``.
-Assert Hyp:``0<2``; [Sup0 | Generalize (sqrt_positivity ``2`` (Rlt_le ``0`` ``2`` Hyp)); Intro H1; Elim H1; Intro H2; [Assumption | Absurd ``0 == (sqrt 2)``; [Apply not_sym; Apply sqrt2_neq_0 | Assumption]]].
-Qed.
-
-Lemma Rlt_sqrt3_0 : ``0<(sqrt 3)``.
-Cut ~(O=(1)); [Intro H0; Assert Hyp:``0<2``; [Sup0 | Generalize (Rlt_le ``0`` ``2`` Hyp); Intro H1; Assert Hyp2:``0<3``; [Sup0 | Generalize (Rlt_le ``0`` ``3`` Hyp2); Intro H2; Generalize (lt_INR_0 (1) (neq_O_lt (1) H0)); Unfold INR; Intro H3; Generalize (Rlt_compatibility ``2`` ``0`` ``1`` H3); Rewrite Rplus_sym; Rewrite Rplus_Ol; Replace ``2+1`` with ``3``; [Intro H4; Generalize (sqrt_lt_1 ``2`` ``3`` H1 H2 H4); Clear H3; Intro H3; Apply (Rlt_trans ``0`` ``(sqrt 2)`` ``(sqrt 3)`` Rlt_sqrt2_0 H3) | Ring]]] | Discriminate].
-Qed.
-
-Lemma PI4_RGT_0 : ``0<PI/4``.
-Unfold Rdiv; Apply Rmult_lt_pos; [Apply PI_RGT_0 | Apply Rlt_Rinv; Sup0].
-Qed.
-
-Lemma cos_PI4 : ``(cos (PI/4))==1/(sqrt 2)``.
-Proof with Trivial.
-Apply Rsqr_inj.
-Apply cos_ge_0.
-Left; Apply (Rlt_trans ``-(PI/2)`` R0 ``PI/4`` _PI2_RLT_0 PI4_RGT_0).
-Left; Apply PI4_RLT_PI2.
-Left; Apply (Rmult_lt_pos R1 ``(Rinv (sqrt 2))``).
-Sup.
-Apply Rlt_Rinv; Apply Rlt_sqrt2_0.
-Rewrite Rsqr_div.
-Rewrite Rsqr_1; Rewrite Rsqr_sqrt.
-Assert H : ``2<>0``; [DiscrR | Idtac].
-Unfold Rsqr; Pattern 1 ``(cos (PI/4))``; Rewrite <- sin_cos_PI4; Replace ``(sin (PI/4))*(cos (PI/4))`` with ``(1/2)*(2*(sin (PI/4))*(cos (PI/4)))``.
-Rewrite <- sin_2a; Replace ``2*(PI/4)`` with ``PI/2``.
-Rewrite sin_PI2.
-Apply Rmult_1r.
-Unfold Rdiv; Rewrite (Rmult_sym ``2``); Rewrite Rinv_Rmult.
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Unfold Rdiv; Rewrite Rmult_1l; Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Left; Sup.
-Apply sqrt2_neq_0.
-Qed.
-
-Lemma sin_PI4 : ``(sin (PI/4))==1/(sqrt 2)``.
-Rewrite sin_cos_PI4; Apply cos_PI4.
-Qed.
-
-Lemma tan_PI4 : ``(tan (PI/4))==1``.
-Unfold tan; Rewrite sin_cos_PI4.
-Unfold Rdiv; Apply Rinv_r.
-Change ``(cos (PI/4))<>0``; Rewrite cos_PI4; Apply R1_sqrt2_neq_0.
-Qed.
-
-Lemma cos3PI4 : ``(cos (3*(PI/4)))==-1/(sqrt 2)``.
-Proof with Trivial.
-Replace ``3*(PI/4)`` with ``(PI/2)-(-(PI/4))``.
-Rewrite cos_shift; Rewrite sin_neg; Rewrite sin_PI4.
-Unfold Rdiv; Rewrite Ropp_mul1.
-Unfold Rminus; Rewrite Ropp_Ropp; Pattern 1 PI; Rewrite double_var; Unfold Rdiv; Rewrite Rmult_Rplus_distrl; Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_Rmult; [Ring | DiscrR | DiscrR].
-Qed.
-
-Lemma sin3PI4 : ``(sin (3*(PI/4)))==1/(sqrt 2)``.
-Proof with Trivial.
-Replace ``3*(PI/4)`` with ``(PI/2)-(-(PI/4))``.
-Rewrite sin_shift; Rewrite cos_neg; Rewrite cos_PI4.
-Unfold Rminus; Rewrite Ropp_Ropp; Pattern 1 PI; Rewrite double_var; Unfold Rdiv; Rewrite Rmult_Rplus_distrl; Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_Rmult; [Ring | DiscrR | DiscrR].
-Qed.
-
-Lemma cos_PI6 : ``(cos (PI/6))==(sqrt 3)/2``.
-Proof with Trivial.
-Apply Rsqr_inj.
-Apply cos_ge_0.
-Left; Apply (Rlt_trans ``-(PI/2)`` R0 ``PI/6`` _PI2_RLT_0 PI6_RGT_0).
-Left; Apply PI6_RLT_PI2.
-Left; Apply (Rmult_lt_pos ``(sqrt 3)`` ``(Rinv 2)``).
-Apply Rlt_sqrt3_0.
-Apply Rlt_Rinv; Sup0.
-Assert H : ``2<>0``; [DiscrR | Idtac].
-Assert H1 : ``4<>0``; [Apply prod_neq_R0 | Idtac].
-Rewrite Rsqr_div.
-Rewrite cos2; Unfold Rsqr; Rewrite sin_PI6; Rewrite sqrt_def.
-Unfold Rdiv; Rewrite Rmult_1l; Apply r_Rmult_mult with ``4``.
-Rewrite Rminus_distr; Rewrite (Rmult_sym ``3``); Repeat Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite Rmult_1r.
-Rewrite <- (Rmult_sym ``/2``); Repeat Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Rewrite <- Rinv_r_sym.
-Ring.
-Left; Sup0.
-Qed.
-
-Lemma tan_PI6 : ``(tan (PI/6))==1/(sqrt 3)``.
-Unfold tan; Rewrite sin_PI6; Rewrite cos_PI6; Unfold Rdiv; Repeat Rewrite Rmult_1l; Rewrite Rinv_Rmult.
-Rewrite Rinv_Rinv.
-Rewrite (Rmult_sym ``/2``); Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Apply Rmult_1r.
-DiscrR.
-DiscrR.
-Red; Intro; Assert H1 := Rlt_sqrt3_0; Rewrite H in H1; Elim (Rlt_antirefl ``0`` H1).
-Apply Rinv_neq_R0; DiscrR.
-Qed.
-
-Lemma sin_PI3 : ``(sin (PI/3))==(sqrt 3)/2``.
-Rewrite sin_PI3_cos_PI6; Apply cos_PI6.
-Qed.
-
-Lemma cos_PI3 : ``(cos (PI/3))==1/2``.
-Rewrite sin_PI6_cos_PI3; Apply sin_PI6.
-Qed.
-
-Lemma tan_PI3 : ``(tan (PI/3))==(sqrt 3)``.
-Unfold tan; Rewrite sin_PI3; Rewrite cos_PI3; Unfold Rdiv; Rewrite Rmult_1l; Rewrite Rinv_Rinv.
-Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Apply Rmult_1r.
-DiscrR.
-DiscrR.
-Qed.
-
-Lemma sin_2PI3 : ``(sin (2*(PI/3)))==(sqrt 3)/2``.
-Rewrite double; Rewrite sin_plus; Rewrite sin_PI3; Rewrite cos_PI3; Unfold Rdiv; Repeat Rewrite Rmult_1l; Rewrite (Rmult_sym ``/2``); Repeat Rewrite <- Rmult_assoc; Rewrite double_var; Reflexivity.
-Qed.
-
-Lemma cos_2PI3 : ``(cos (2*(PI/3)))==-1/2``.
-Proof with Trivial.
-Assert H : ``2<>0``; [DiscrR | Idtac].
-Assert H0 : ``4<>0``; [Apply prod_neq_R0 | Idtac].
-Rewrite double; Rewrite cos_plus; Rewrite sin_PI3; Rewrite cos_PI3; Unfold Rdiv; Rewrite Rmult_1l; Apply r_Rmult_mult with ``4``.
-Rewrite Rminus_distr; Repeat Rewrite Rmult_assoc; Rewrite (Rmult_sym ``2``).
-Repeat Rewrite Rmult_assoc; Rewrite <- (Rinv_l_sym).
-Rewrite Rmult_1r; Rewrite <- Rinv_r_sym.
-Pattern 4 ``2``; Rewrite (Rmult_sym ``2``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite Ropp_mul3; Rewrite Rmult_1r.
-Rewrite (Rmult_sym ``2``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite (Rmult_sym ``2``); Rewrite (Rmult_sym ``/2``).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Rewrite sqrt_def.
-Ring.
-Left; Sup.
-Qed.
-
-Lemma tan_2PI3 : ``(tan (2*(PI/3)))==-(sqrt 3)``.
-Proof with Trivial.
-Assert H : ``2<>0``; [DiscrR | Idtac].
-Unfold tan; Rewrite sin_2PI3; Rewrite cos_2PI3; Unfold Rdiv; Rewrite Ropp_mul1; Rewrite Rmult_1l; Rewrite <- Ropp_Rinv.
-Rewrite Rinv_Rinv.
-Rewrite Rmult_assoc; Rewrite Ropp_mul3; Rewrite <- Rinv_l_sym.
-Ring.
-Apply Rinv_neq_R0.
-Qed.
-
-Lemma cos_5PI4 : ``(cos (5*(PI/4)))==-1/(sqrt 2)``.
-Proof with Trivial.
-Replace ``5*(PI/4)`` with ``(PI/4)+(PI)``.
-Rewrite neg_cos; Rewrite cos_PI4; Unfold Rdiv; Rewrite Ropp_mul1.
-Pattern 2 PI; Rewrite double_var; Pattern 2 3 PI; Rewrite double_var; Assert H : ``2<>0``; [DiscrR | Unfold Rdiv; Repeat Rewrite Rinv_Rmult; Try Ring].
-Qed.
-
-Lemma sin_5PI4 : ``(sin (5*(PI/4)))==-1/(sqrt 2)``.
-Proof with Trivial.
-Replace ``5*(PI/4)`` with ``(PI/4)+(PI)``.
-Rewrite neg_sin; Rewrite sin_PI4; Unfold Rdiv; Rewrite Ropp_mul1.
-Pattern 2 PI; Rewrite double_var; Pattern 2 3 PI; Rewrite double_var; Assert H : ``2<>0``; [DiscrR | Unfold Rdiv; Repeat Rewrite Rinv_Rmult; Try Ring].
-Qed.
-
-Lemma sin_cos5PI4 : ``(cos (5*(PI/4)))==(sin (5*(PI/4)))``.
-Rewrite cos_5PI4; Rewrite sin_5PI4; Reflexivity.
-Qed.
-
-Lemma Rgt_3PI2_0 : ``0<3*(PI/2)``.
-Apply Rmult_lt_pos; [Sup0 | Unfold Rdiv; Apply Rmult_lt_pos; [Apply PI_RGT_0 | Apply Rlt_Rinv; Sup0]].
-Qed.
-
-Lemma Rgt_2PI_0 : ``0<2*PI``.
-Apply Rmult_lt_pos; [Sup0 | Apply PI_RGT_0].
-Qed.
-
-Lemma Rlt_PI_3PI2 : ``PI<3*(PI/2)``.
-Generalize PI2_RGT_0; Intro H1; Generalize (Rlt_compatibility PI ``0`` ``PI/2`` H1); Replace ``PI+(PI/2)`` with ``3*(PI/2)``.
-Rewrite Rplus_Or; Intro H2; Assumption.
-Pattern 2 PI; Rewrite double_var; Ring.
-Qed. 
- 
-Lemma Rlt_3PI2_2PI : ``3*(PI/2)<2*PI``.
-Generalize PI2_RGT_0; Intro H1; Generalize (Rlt_compatibility ``3*(PI/2)`` ``0`` ``PI/2`` H1); Replace ``3*(PI/2)+(PI/2)`` with ``2*PI``.
-Rewrite Rplus_Or; Intro H2; Assumption.
-Rewrite double; Pattern 1 2 PI; Rewrite double_var; Ring.
-Qed.
-
-(***************************************************************)
-(* Radian -> Degree | Degree -> Radian                         *)
-(***************************************************************)
-
-Definition plat : R := ``180``.
-Definition toRad [x:R] : R := ``x*PI*/plat``.
-Definition toDeg [x:R] : R := ``x*plat*/PI``.
-
-Lemma rad_deg : (x:R) (toRad (toDeg x))==x.
-Intro; Unfold toRad toDeg; Replace ``x*plat*/PI*PI*/plat`` with ``x*(plat*/plat)*(PI*/PI)``; [Idtac | Ring].
-Repeat Rewrite <- Rinv_r_sym.
-Ring.
-Apply PI_neq0.
-Unfold plat; DiscrR.
-Qed.
-
-Lemma toRad_inj : (x,y:R) (toRad x)==(toRad y) -> x==y.
-Intros; Unfold toRad in H; Apply r_Rmult_mult with PI.
-Rewrite <- (Rmult_sym x); Rewrite <- (Rmult_sym y).
-Apply r_Rmult_mult with ``/plat``.
-Rewrite <- (Rmult_sym ``x*PI``); Rewrite <- (Rmult_sym ``y*PI``); Assumption.
-Apply Rinv_neq_R0; Unfold plat; DiscrR.
-Apply PI_neq0.
-Qed.
-
-Lemma deg_rad : (x:R) (toDeg (toRad x))==x.
-Intro x; Apply toRad_inj; Rewrite -> (rad_deg (toRad x)); Reflexivity.
-Qed.
-
-Definition sind [x:R] : R := (sin (toRad x)).
-Definition cosd [x:R] : R := (cos (toRad x)).
-Definition tand [x:R] : R := (tan (toRad x)).
-
-Lemma Rsqr_sin_cos_d_one : (x:R) ``(Rsqr (sind x))+(Rsqr (cosd x))==1``.
-Intro x; Unfold sind; Unfold cosd; Apply sin2_cos2.
-Qed.
-
-(***************************************************)
-(*                Other properties                 *)
-(***************************************************)
-
-Lemma sin_lb_ge_0 : (a:R) ``0<=a``->``a<=PI/2``->``0<=(sin_lb a)``.
-Intros; Case (total_order R0 a); Intro.
-Left; Apply sin_lb_gt_0; Assumption.
-Elim H1; Intro.
-Rewrite <- H2; Unfold sin_lb; Unfold sin_approx; Unfold sum_f_R0; Unfold sin_term; Repeat Rewrite pow_ne_zero.
-Unfold Rdiv; Repeat Rewrite Rmult_Ol; Repeat Rewrite Rmult_Or; Repeat Rewrite Rplus_Or; Right; Reflexivity.
-Discriminate.
-Discriminate.
-Discriminate.
-Discriminate.
-Elim (Rlt_antirefl ``0`` (Rle_lt_trans ``0`` a ``0`` H H2)).
-Qed.
diff --git a/theories7/Reals/Rtrigo_def.v b/theories7/Reals/Rtrigo_def.v
deleted file mode 100644
index 0897416b..00000000
--- a/theories7/Reals/Rtrigo_def.v
+++ /dev/null
@@ -1,357 +0,0 @@
-(************************************************************************)
-(*  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: Rtrigo_def.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo_fun.
-Require Max.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(*****************************)
-(* Definition of exponential *)
-(*****************************)
-Definition exp_in:R->R->Prop := [x,l:R](infinit_sum [i:nat]``/(INR (fact i))*(pow x i)`` l).
-
-Lemma exp_cof_no_R0 : (n:nat) ``/(INR (fact n))<>0``.
-Intro.
-Apply Rinv_neq_R0.
-Apply INR_fact_neq_0.
-Qed.
-
-Lemma exist_exp : (x:R)(SigT R [l:R](exp_in x l)).
-Intro; Generalize (Alembert_C3 [n:nat](Rinv (INR (fact n))) x exp_cof_no_R0 Alembert_exp).
-Unfold Pser exp_in.
-Trivial.
-Defined.
-
-Definition exp : R -> R := [x:R](projT1 ? ? (exist_exp x)).
-
-Lemma pow_i : (i:nat) (lt O i) -> (pow R0 i)==R0.
-Intros; Apply pow_ne_zero.
-Red; Intro; Rewrite H0 in H; Elim (lt_n_n ? H).
-Qed.
-
-(*i Calculus of $e^0$ *)
-Lemma exist_exp0 : (SigT R [l:R](exp_in R0 l)).
-Apply Specif.existT with R1.
-Unfold exp_in; Unfold infinit_sum; Intros.
-Exists O.
-Intros; Replace (sum_f_R0 ([i:nat]``/(INR (fact i))*(pow R0 i)``) n) with R1.
-Unfold R_dist; Replace ``1-1`` with R0; [Rewrite Rabsolu_R0; Assumption | Ring].
-Induction n.
-Simpl; Rewrite Rinv_R1; Ring.
-Rewrite tech5.
-Rewrite <- Hrecn.
-Simpl.
-Ring.
-Unfold ge; Apply le_O_n.
-Defined.
-
-Lemma exp_0 : ``(exp 0)==1``. 
-Cut (exp_in R0 (exp R0)).
-Cut (exp_in R0 R1).
-Unfold exp_in; Intros; EApply unicity_sum.
-Apply H0.
-Apply H.
-Exact (projT2 ? ? exist_exp0).
-Exact (projT2 ? ? (exist_exp R0)).
-Qed.
-
-(**************************************)
-(* Definition of hyperbolic functions *)
-(**************************************)
-Definition cosh : R->R := [x:R]``((exp x)+(exp (-x)))/2``.
-Definition sinh : R->R := [x:R]``((exp x)-(exp (-x)))/2``.
-Definition tanh : R->R := [x:R]``(sinh x)/(cosh x)``.
-
-Lemma cosh_0 : ``(cosh 0)==1``.
-Unfold cosh; Rewrite Ropp_O; Rewrite exp_0.
-Unfold Rdiv; Rewrite <- Rinv_r_sym; [Reflexivity | DiscrR].
-Qed.
-
-Lemma sinh_0 : ``(sinh 0)==0``.
-Unfold sinh; Rewrite Ropp_O; Rewrite exp_0.
-Unfold Rminus Rdiv; Rewrite Rplus_Ropp_r; Apply Rmult_Ol.
-Qed.
-
-Definition cos_n [n:nat] : R := ``(pow (-1) n)/(INR (fact (mult (S (S O)) n)))``.
-
-Lemma simpl_cos_n : (n:nat) (Rdiv (cos_n (S n)) (cos_n n))==(Ropp (Rinv (INR (mult (mult (2) (S n)) (plus (mult (2) n) (1)))))). 
-Intro; Unfold cos_n; Replace (S n) with (plus n (1)); [Idtac | Ring].
-Rewrite pow_add; Unfold Rdiv; Rewrite Rinv_Rmult.
-Rewrite Rinv_Rinv.
-Replace ``(pow ( -1) n)*(pow ( -1) (S O))*/(INR (fact (mult (S (S O)) (plus n (S O)))))*(/(pow ( -1) n)*(INR (fact (mult (S (S O)) n))))`` with ``((pow ( -1) n)*/(pow ( -1) n))*/(INR (fact (mult (S (S O)) (plus n (S O)))))*(INR (fact (mult (S (S O)) n)))*(pow (-1) (S O))``; [Idtac | Ring].
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Unfold pow; Rewrite Rmult_1r.
-Replace (mult (S (S O)) (plus n (S O))) with (S (S (mult (S (S O)) n))); [Idtac | Ring].
-Do 2 Rewrite fact_simpl; Do 2  Rewrite mult_INR; Repeat Rewrite Rinv_Rmult; Try (Apply not_O_INR; Discriminate).
-Rewrite <- (Rmult_sym ``-1``).
-Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r.
-Replace (S (mult (S (S O)) n)) with (plus (mult (S (S O)) n) (S O)); [Idtac | Ring].
-Rewrite mult_INR; Rewrite Rinv_Rmult.
-Ring.
-Apply not_O_INR; Discriminate.
-Replace (plus (mult (S (S O)) n) (S O)) with (S (mult (S (S O)) n)); [Apply not_O_INR; Discriminate | Ring].
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply prod_neq_R0; [Apply not_O_INR; Discriminate | Apply INR_fact_neq_0].
-Apply pow_nonzero; DiscrR.
-Apply INR_fact_neq_0.
-Apply pow_nonzero; DiscrR.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Qed.
-
-Lemma archimed_cor1 : (eps:R) ``0<eps`` -> (EX N : nat | ``/(INR N) < eps``/\(lt O N)).
-Intros; Cut ``/eps < (IZR (up (/eps)))``.
-Intro; Cut `0<=(up (Rinv eps))`.
-Intro; Assert H2 := (IZN ? H1); Elim H2; Intros; Exists (max x (1)).
-Split.
-Cut ``0<(IZR (INZ x))``.
-Intro; Rewrite INR_IZR_INZ; Apply Rle_lt_trans with ``/(IZR (INZ x))``.
-Apply Rle_monotony_contra with (IZR (INZ x)).
-Assumption.
-Rewrite <- Rinv_r_sym; [Idtac | Red; Intro; Rewrite H5 in H4; Elim (Rlt_antirefl ? H4)].
-Apply Rle_monotony_contra with (IZR (INZ (max x (1)))).
-Apply Rlt_le_trans with (IZR (INZ x)).
-Assumption.
-Repeat Rewrite <- INR_IZR_INZ; Apply le_INR; Apply le_max_l.
-Rewrite Rmult_1r; Rewrite (Rmult_sym (IZR (INZ (max x (S O))))); Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Repeat Rewrite <- INR_IZR_INZ; Apply le_INR; Apply le_max_l.
-Rewrite <- INR_IZR_INZ; Apply not_O_INR.
-Red; Intro;Assert H6 := (le_max_r x (1)); Cut (lt O (1)); [Intro | Apply lt_O_Sn]; Assert H8 := (lt_le_trans ? ? ? H7 H6); Rewrite H5 in H8; Elim (lt_n_n ? H8).
-Pattern 1 eps; Rewrite <- Rinv_Rinv.
-Apply Rinv_lt.
-Apply Rmult_lt_pos; [Apply Rlt_Rinv; Assumption | Assumption].
-Rewrite H3 in H0; Assumption.
-Red; Intro; Rewrite H5 in H; Elim (Rlt_antirefl ? H).
-Apply Rlt_trans with ``/eps``.
-Apply Rlt_Rinv; Assumption.
-Rewrite H3 in H0; Assumption.
-Apply lt_le_trans with (1); [Apply lt_O_Sn | Apply le_max_r].
-Apply le_IZR; Replace (IZR `0`) with R0; [Idtac | Reflexivity]; Left; Apply Rlt_trans with ``/eps``; [Apply Rlt_Rinv; Assumption | Assumption].
-Assert H0 := (archimed ``/eps``).
-Elim H0; Intros; Assumption.
-Qed.
-
-Lemma Alembert_cos : (Un_cv [n:nat]``(Rabsolu (cos_n (S n))/(cos_n n))`` R0).
-Unfold Un_cv; Intros.
-Assert H0 := (archimed_cor1 eps H).
-Elim H0; Intros; Exists x.
-Intros; Rewrite simpl_cos_n; Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_Rabsolu; Rewrite Rabsolu_Ropp; Rewrite Rabsolu_right.
-Rewrite mult_INR; Rewrite Rinv_Rmult.
-Cut ``/(INR (mult (S (S O)) (S n)))<1``.
-Intro; Cut ``/(INR (plus (mult (S (S O)) n) (S O)))<eps``.
-Intro; Rewrite <- (Rmult_1l eps).
-Apply Rmult_lt; Try Assumption.
-Change ``0</(INR (plus (mult (S (S O)) n) (S O)))``; Apply Rlt_Rinv; Apply lt_INR_0.
-Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Apply lt_O_Sn | Ring].
-Apply Rlt_R0_R1.
-Cut (lt x (plus (mult (2) n) (1))).
-Intro; Assert H5 := (lt_INR ? ? H4).
-Apply Rlt_trans with ``/(INR x)``.
-Apply Rinv_lt.
-Apply Rmult_lt_pos.
-Apply lt_INR_0.
-Elim H1; Intros; Assumption.
-Apply lt_INR_0; Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Apply lt_O_Sn | Ring].
-Assumption.
-Elim H1; Intros; Assumption.
-Apply lt_le_trans with (S n).
-Unfold ge in H2; Apply le_lt_n_Sm; Assumption.
-Replace (plus (mult (2) n) (1)) with (S (mult (2) n)); [Idtac | Ring].
-Apply le_n_S; Apply le_n_2n.
-Apply Rlt_monotony_contra with (INR (mult (S (S O)) (S n))).
-Apply lt_INR_0; Replace (mult (2) (S n)) with (S (S (mult (2) n))).
-Apply lt_O_Sn.
-Replace (S n) with (plus n (1)); [Idtac | Ring].
-Ring.
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Replace R1 with (INR (1)); [Apply lt_INR | Reflexivity].
-Replace (mult (2) (S n)) with (S (S (mult (2) n))).
-Apply lt_n_S; Apply lt_O_Sn.
-Replace (S n) with (plus n (1)); [Ring | Ring].
-Apply not_O_INR; Discriminate.
-Apply not_O_INR; Discriminate.
-Replace (plus (mult (S (S O)) n) (S O)) with (S (mult (2) n)); [Apply not_O_INR; Discriminate | Ring].
-Apply Rle_sym1; Left; Apply Rlt_Rinv.
-Apply lt_INR_0.
-Replace (mult (mult (2) (S n)) (plus (mult (2) n) (1))) with (S (S (plus (mult (4) (mult n n)) (mult (6) n)))).
-Apply lt_O_Sn.
-Apply INR_eq.
-Repeat Rewrite S_INR; Rewrite plus_INR; Repeat Rewrite mult_INR; Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Replace (INR O) with R0; [Ring | Reflexivity].
-Qed.
-
-Lemma cosn_no_R0 : (n:nat)``(cos_n n)<>0``.
-Intro; Unfold cos_n; Unfold Rdiv; Apply prod_neq_R0.
-Apply pow_nonzero; DiscrR.
-Apply Rinv_neq_R0.
-Apply INR_fact_neq_0.
-Qed.
-
-(**********)
-Definition cos_in:R->R->Prop := [x,l:R](infinit_sum [i:nat]``(cos_n i)*(pow x i)`` l).
-
-(**********)
-Lemma exist_cos : (x:R)(SigT R [l:R](cos_in x l)).
-Intro; Generalize (Alembert_C3 cos_n x cosn_no_R0 Alembert_cos).
-Unfold Pser cos_in; Trivial.
-Qed.
-
-(* Definition of cosinus *)
-(*************************)
-Definition cos : R -> R := [x:R](Cases (exist_cos (Rsqr x)) of (Specif.existT a b) => a end).
-
-
-Definition sin_n [n:nat] : R := ``(pow (-1) n)/(INR (fact (plus (mult (S (S O)) n) (S O))))``.
-
-Lemma simpl_sin_n : (n:nat) (Rdiv (sin_n (S n)) (sin_n n))==(Ropp (Rinv (INR (mult (plus (mult (2) (S n)) (1)) (mult (2) (S n)))))). 
-Intro; Unfold sin_n; Replace (S n) with (plus n (1)); [Idtac | Ring].
-Rewrite pow_add; Unfold Rdiv; Rewrite Rinv_Rmult.
-Rewrite Rinv_Rinv.
-Replace ``(pow ( -1) n)*(pow ( -1) (S O))*/(INR (fact (plus (mult (S (S O)) (plus n (S O))) (S O))))*(/(pow ( -1) n)*(INR (fact (plus (mult (S (S O)) n) (S O)))))`` with ``((pow ( -1) n)*/(pow ( -1) n))*/(INR (fact (plus (mult (S (S O)) (plus n (S O))) (S O))))*(INR (fact (plus (mult (S (S O)) n) (S O))))*(pow (-1) (S O))``; [Idtac | Ring].
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Unfold pow; Rewrite Rmult_1r; Replace (plus (mult (S (S O)) (plus n (S O))) (S O)) with (S (S (plus (mult (S (S O)) n) (S O)))).
-Do 2 Rewrite fact_simpl; Do 2  Rewrite mult_INR; Repeat Rewrite Rinv_Rmult.
-Rewrite <- (Rmult_sym ``-1``); Repeat Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Replace (S (plus (mult (S (S O)) n) (S O))) with (mult (S (S O)) (plus n (S O))).
-Repeat Rewrite mult_INR; Repeat Rewrite Rinv_Rmult.
-Ring.
-Apply not_O_INR; Discriminate.
-Replace (plus n (S O)) with (S n); [Apply not_O_INR; Discriminate | Ring].
-Apply not_O_INR; Discriminate.
-Apply prod_neq_R0.
-Apply not_O_INR; Discriminate.
-Replace (plus n (S O)) with (S n); [Apply not_O_INR; Discriminate | Ring].
-Apply not_O_INR; Discriminate.
-Replace (plus n (S O)) with (S n); [Apply not_O_INR; Discriminate | Ring].
-Rewrite mult_plus_distr_r; Cut (n:nat) (S n)=(plus n (1)).
-Intros; Rewrite (H (plus (mult (2) n) (1))).
-Ring.
-Intros; Ring.
-Apply INR_fact_neq_0.
-Apply not_O_INR; Discriminate.
-Apply INR_fact_neq_0.
-Apply not_O_INR; Discriminate.
-Apply prod_neq_R0; [Apply not_O_INR; Discriminate | Apply INR_fact_neq_0].
-Cut (n:nat) (S (S n))=(plus n (2)); [Intros; Rewrite (H (plus (mult (2) n) (1))); Ring | Intros; Ring].
-Apply pow_nonzero; DiscrR.
-Apply INR_fact_neq_0.
-Apply pow_nonzero; DiscrR.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Qed.
-
-Lemma Alembert_sin : (Un_cv [n:nat]``(Rabsolu (sin_n (S n))/(sin_n n))`` R0).
-Unfold Un_cv; Intros; Assert H0 := (archimed_cor1 eps H).
-Elim H0; Intros; Exists x.
-Intros; Rewrite simpl_sin_n; Unfold R_dist; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_Rabsolu; Rewrite Rabsolu_Ropp; Rewrite Rabsolu_right.
-Rewrite mult_INR; Rewrite Rinv_Rmult.
-Cut ``/(INR (mult (S (S O)) (S n)))<1``.
-Intro; Cut ``/(INR (plus (mult (S (S O)) (S n)) (S O)))<eps``.
-Intro; Rewrite <- (Rmult_1l eps); Rewrite (Rmult_sym ``/(INR (plus (mult (S (S O)) (S n)) (S O)))``); Apply Rmult_lt; Try Assumption.
-Change ``0</(INR (plus (mult (S (S O)) (S n)) (S O)))``; Apply Rlt_Rinv; Apply lt_INR_0; Replace (plus (mult (2) (S n)) (1)) with (S (mult (2) (S n))); [Apply lt_O_Sn | Ring].
-Apply Rlt_R0_R1.
-Cut (lt x (plus (mult (2) (S n)) (1))).
-Intro; Assert H5 := (lt_INR ? ? H4); Apply Rlt_trans with ``/(INR x)``.
-Apply Rinv_lt.
-Apply Rmult_lt_pos.
-Apply lt_INR_0; Elim H1; Intros; Assumption.
-Apply lt_INR_0; Replace (plus (mult (2) (S n)) (1)) with (S (mult (2) (S n))); [Apply lt_O_Sn | Ring].
-Assumption.
-Elim H1; Intros; Assumption.
-Apply lt_le_trans with (S n).
-Unfold ge in H2; Apply le_lt_n_Sm; Assumption.
-Replace (plus (mult (2) (S n)) (1)) with (S (mult (2) (S n))); [Idtac | Ring].
-Apply le_S; Apply le_n_2n.
-Apply Rlt_monotony_contra with (INR (mult (S (S O)) (S n))).
-Apply lt_INR_0; Replace (mult (2) (S n)) with (S (S (mult (2) n))); [Apply lt_O_Sn | Replace (S n) with (plus n (1)); [Idtac | Ring]; Ring].
-Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Replace R1 with (INR (1)); [Apply lt_INR | Reflexivity].
-Replace (mult (2) (S n)) with (S (S (mult (2) n))).
-Apply lt_n_S; Apply lt_O_Sn.
-Replace (S n) with (plus n (1)); [Ring | Ring].
-Apply not_O_INR; Discriminate.
-Apply not_O_INR; Discriminate.
-Apply not_O_INR; Discriminate.
-Left; Change ``0</(INR (mult (plus (mult (S (S O)) (S n)) (S O)) (mult (S (S O)) (S n))))``; Apply Rlt_Rinv.
-Apply lt_INR_0.
-Replace (mult (plus (mult (2) (S n)) (1)) (mult (2) (S n))) with (S (S (S (S (S (S (plus (mult (4) (mult n n)) (mult (10) n)))))))).
-Apply lt_O_Sn.
-Apply INR_eq; Repeat Rewrite S_INR; Rewrite plus_INR; Repeat Rewrite mult_INR; Rewrite plus_INR; Rewrite mult_INR; Repeat Rewrite S_INR; Replace (INR O) with R0; [Ring | Reflexivity].
-Qed.
-
-Lemma sin_no_R0 : (n:nat)``(sin_n n)<>0``.
-Intro; Unfold sin_n; Unfold Rdiv; Apply prod_neq_R0.
-Apply pow_nonzero; DiscrR.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Qed.
-
-(**********)
-Definition sin_in:R->R->Prop := [x,l:R](infinit_sum [i:nat]``(sin_n i)*(pow x i)`` l).
-
-(**********)
-Lemma exist_sin : (x:R)(SigT R [l:R](sin_in x l)).
-Intro; Generalize (Alembert_C3 sin_n x sin_no_R0 Alembert_sin).
-Unfold Pser sin_n; Trivial.
-Qed.
-
-(***********************)
-(* Definition of sinus *)
-Definition sin : R -> R := [x:R](Cases (exist_sin (Rsqr x)) of (Specif.existT a b) => ``x*a`` end).
-
-(*********************************************)
-(*                 PROPERTIES                *)
-(*********************************************)
-
-Lemma cos_sym : (x:R) ``(cos x)==(cos (-x))``.
-Intros; Unfold cos; Replace ``(Rsqr (-x))`` with (Rsqr x).
-Reflexivity.
-Apply Rsqr_neg.
-Qed.
-
-Lemma sin_antisym : (x:R)``(sin (-x))==-(sin x)``.
-Intro; Unfold sin; Replace ``(Rsqr (-x))`` with (Rsqr x); [Idtac | Apply Rsqr_neg]. 
-Case (exist_sin (Rsqr x)); Intros; Ring.
-Qed.
-
-Lemma sin_0 : ``(sin 0)==0``.
-Unfold sin; Case (exist_sin (Rsqr R0)).
-Intros; Ring.
-Qed.
-
-Lemma exist_cos0 : (SigT R [l:R](cos_in R0 l)).
-Apply Specif.existT with R1.
-Unfold cos_in; Unfold infinit_sum; Intros; Exists O.
-Intros.
-Unfold R_dist.
-Induction n.
-Unfold cos_n; Simpl.
-Unfold Rdiv; Rewrite Rinv_R1.
-Do 2 Rewrite Rmult_1r.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Rewrite tech5.
-Replace ``(cos_n (S n))*(pow 0 (S n))`` with R0.
-Rewrite Rplus_Or.
-Apply Hrecn; Unfold ge; Apply le_O_n.
-Simpl; Ring.
-Defined.
-
-(* Calculus of (cos 0) *)
-Lemma cos_0 : ``(cos 0)==1``.
-Cut (cos_in R0 (cos R0)).
-Cut (cos_in R0 R1).
-Unfold cos_in; Intros; EApply unicity_sum.
-Apply H0.
-Apply H.
-Exact (projT2 ? ? exist_cos0).
-Assert H := (projT2 ? ? (exist_cos (Rsqr R0))); Unfold cos; Pattern 1 R0; Replace R0 with (Rsqr R0); [Exact H | Apply Rsqr_O].
-Qed.
diff --git a/theories7/Reals/Rtrigo_fun.v b/theories7/Reals/Rtrigo_fun.v
deleted file mode 100644
index bc72c0e1..00000000
--- a/theories7/Reals/Rtrigo_fun.v
+++ /dev/null
@@ -1,118 +0,0 @@
-(************************************************************************)
-(*  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: Rtrigo_fun.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(*****************************************************************)
-(*           To define transcendental functions                  *)
-(*                                                               *)
-(*****************************************************************)
-(*****************************************************************)
-(*           For exponential function                            *)
-(*                                                               *)
-(*****************************************************************)
-
-(*********)
-Lemma Alembert_exp:(Un_cv
-   [n:nat](Rabsolu (Rmult (Rinv (INR (fact (S n)))) 
-         (Rinv (Rinv (INR (fact n)))))) R0).
-Unfold Un_cv;Intros;Elim (total_order_Rgt eps R1);Intro.
-Split with O;Intros;Rewrite (simpl_fact n);Unfold R_dist;
- Rewrite (minus_R0 (Rabsolu (Rinv (INR (S n)))));
- Rewrite (Rabsolu_Rabsolu (Rinv (INR (S n))));
- Cut (Rgt (Rinv (INR (S n))) R0).
-Intro; Rewrite (Rabsolu_pos_eq (Rinv (INR (S n)))).
-Cut (Rlt (Rminus (Rinv eps) R1) R0).
-Intro;Generalize (Rlt_le_trans (Rminus (Rinv eps) R1) R0 (INR n) H2 
-   (pos_INR n));Clear H2;Intro;
- Unfold Rminus in H2;Generalize (Rlt_compatibility R1 
-       (Rplus (Rinv eps) (Ropp R1)) (INR n) H2);
- Replace (Rplus R1 (Rplus (Rinv eps) (Ropp R1))) with (Rinv eps);
- [Clear H2;Intro|Ring].
-Rewrite (Rplus_sym R1 (INR n)) in H2;Rewrite <-(S_INR n) in H2;
- Generalize (Rmult_gt (Rinv (INR (S n))) eps H1 H);Intro;
- Unfold Rgt in H3;
- Generalize (Rlt_monotony (Rmult (Rinv (INR (S n))) eps) (Rinv eps)
-     (INR (S n)) H3 H2);Intro;
- Rewrite (Rmult_assoc (Rinv (INR (S n))) eps (Rinv eps)) in H4;
- Rewrite (Rinv_r eps (imp_not_Req eps R0 
-      (or_intror (Rlt eps R0) (Rgt eps R0) H))) 
-  in H4;Rewrite (let (H1,H2)=(Rmult_ne (Rinv (INR (S n)))) in H1) 
-  in H4;Rewrite (Rmult_sym (Rinv (INR (S n)))) in H4;
- Rewrite (Rmult_assoc eps (Rinv (INR (S n))) (INR (S n))) in H4;
- Rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) 
-      (sym_not_equal nat O (S n) (O_S n)))) in H4;
- Rewrite (let (H1,H2)=(Rmult_ne eps) in H1) in H4;Assumption.
-Apply Rlt_minus;Unfold Rgt in a;Rewrite <- Rinv_R1;
- Apply (Rinv_lt R1 eps);Auto;
- Rewrite (let (H1,H2)=(Rmult_ne eps) in H2);Unfold Rgt in H;Assumption.
-Unfold Rgt in H1;Apply Rlt_le;Assumption.
-Unfold Rgt;Apply Rlt_Rinv; Apply lt_INR_0;Apply lt_O_Sn.
-(**)
-Cut `0<=(up (Rminus (Rinv eps) R1))`.
-Intro;Elim (IZN (up (Rminus (Rinv eps) R1)) H0);Intros;
- Split with x;Intros;Rewrite (simpl_fact n);Unfold R_dist;
- Rewrite (minus_R0 (Rabsolu (Rinv (INR (S n)))));
- Rewrite (Rabsolu_Rabsolu (Rinv (INR (S n))));
- Cut (Rgt (Rinv (INR (S n))) R0).
-Intro; Rewrite (Rabsolu_pos_eq (Rinv (INR (S n)))).
-Cut (Rlt (Rminus (Rinv eps) R1) (INR x)).
-Intro;Generalize (Rlt_le_trans (Rminus (Rinv eps) R1) (INR x) (INR n) 
-      H4 (le_INR x n ([n,m:nat; H:(ge m n)]H x n H2)));  
- Clear H4;Intro;Unfold Rminus in H4;Generalize (Rlt_compatibility R1 
-       (Rplus (Rinv eps) (Ropp R1)) (INR n) H4);
- Replace (Rplus R1 (Rplus (Rinv eps) (Ropp R1))) with (Rinv eps);
- [Clear H4;Intro|Ring].
-Rewrite (Rplus_sym R1 (INR n)) in H4;Rewrite <-(S_INR n) in H4;
- Generalize (Rmult_gt (Rinv (INR (S n))) eps H3 H);Intro;
- Unfold Rgt in H5;
- Generalize (Rlt_monotony (Rmult (Rinv (INR (S n))) eps) (Rinv eps)
-     (INR (S n)) H5 H4);Intro;
- Rewrite (Rmult_assoc (Rinv (INR (S n))) eps (Rinv eps)) in H6;
- Rewrite (Rinv_r eps (imp_not_Req eps R0 
-      (or_intror (Rlt eps R0) (Rgt eps R0) H))) 
-  in H6;Rewrite (let (H1,H2)=(Rmult_ne (Rinv (INR (S n)))) in H1) 
-  in H6;Rewrite (Rmult_sym (Rinv (INR (S n)))) in H6;
- Rewrite (Rmult_assoc eps (Rinv (INR (S n))) (INR (S n))) in H6;
- Rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) 
-      (sym_not_equal nat O (S n) (O_S n)))) in H6;
- Rewrite (let (H1,H2)=(Rmult_ne eps) in H1) in H6;Assumption.
-Cut (IZR (up (Rminus (Rinv eps) R1)))==(IZR (INZ x));
- [Intro|Rewrite H1;Trivial].
-Elim (archimed (Rminus (Rinv eps) R1));Intros;Clear H6;
- Unfold Rgt in H5;Rewrite H4 in H5;Rewrite INR_IZR_INZ;Assumption.
-Unfold Rgt in H1;Apply Rlt_le;Assumption.
-Unfold Rgt;Apply Rlt_Rinv; Apply lt_INR_0;Apply lt_O_Sn.
-Apply (le_O_IZR (up (Rminus (Rinv eps) R1))); 
- Apply (Rle_trans R0 (Rminus (Rinv eps) R1) 
-  (IZR (up (Rminus (Rinv eps) R1)))).
-Generalize (Rgt_not_le eps R1 b);Clear b;Unfold Rle;Intro;Elim H0;
- Clear H0;Intro.
-Left;Unfold Rgt in H;
- Generalize (Rlt_monotony (Rinv eps) eps R1 (Rlt_Rinv eps H) H0);
- Rewrite (Rinv_l eps (sym_not_eqT R R0 eps
-    (imp_not_Req R0 eps (or_introl (Rlt R0 eps) (Rgt R0 eps) H))));
- Rewrite (let (H1,H2)=(Rmult_ne (Rinv eps)) in H1);Intro;
- Fold (Rgt (Rminus (Rinv eps) R1) R0);Apply Rgt_minus;Unfold Rgt;
- Assumption.
-Right;Rewrite H0;Rewrite Rinv_R1;Apply sym_eqT;Apply eq_Rminus;Auto.
-Elim (archimed (Rminus (Rinv eps) R1));Intros;Clear H1;
- Unfold Rgt in H0;Apply Rlt_le;Assumption.
-Qed.
-
-
-
-
-
-
diff --git a/theories7/Reals/Rtrigo_reg.v b/theories7/Reals/Rtrigo_reg.v
deleted file mode 100644
index 02e40caf..00000000
--- a/theories7/Reals/Rtrigo_reg.v
+++ /dev/null
@@ -1,497 +0,0 @@
-(************************************************************************)
-(*  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: Rtrigo_reg.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require SeqSeries.
-Require Rtrigo.
-Require Ranalysis1.
-Require PSeries_reg.
-V7only [Import nat_scope. Import Z_scope. Import R_scope.].
-Open Local Scope nat_scope.
-Open Local Scope R_scope.
-
-Lemma CVN_R_cos : (fn:nat->R->R) (fn == [N:nat][x:R]``(pow (-1) N)/(INR (fact (mult (S (S O)) N)))*(pow x (mult (S (S O)) N))``) -> (CVN_R fn).
-Unfold CVN_R; Intros.
-Cut (r::R)<>``0``.
-Intro hyp_r; Unfold CVN_r.
-Apply Specif.existT with [n:nat]``/(INR (fact (mult (S (S O)) n)))*(pow r (mult (S (S O)) n))``.
-Cut (SigT ? [l:R](Un_cv [n:nat](sum_f_R0 [k:nat](Rabsolu ``/(INR (fact (mult (S (S O)) k)))*(pow r (mult (S (S O)) k))``) n) l)).
-Intro; Elim X; Intros.
-Apply existTT with x.
-Split.
-Apply p.
-Intros; Rewrite H; Unfold Rdiv; Do 2 Rewrite Rabsolu_mult.
-Rewrite pow_1_abs; Rewrite Rmult_1l.
-Cut ``0</(INR (fact (mult (S (S O)) n)))``.
-Intro; Rewrite (Rabsolu_right  ? (Rle_sym1 ? ? (Rlt_le ? ? H1))).
-Apply Rle_monotony.
-Left; Apply H1.
-Rewrite <- Pow_Rabsolu; Apply pow_maj_Rabs.
-Rewrite Rabsolu_Rabsolu.
-Unfold Boule in H0; Rewrite minus_R0 in H0.
-Left; Apply H0.
-Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Apply Alembert_C2.
-Intro; Apply Rabsolu_no_R0.
-Apply prod_neq_R0.
-Apply Rinv_neq_R0.
-Apply INR_fact_neq_0.
-Apply pow_nonzero; Assumption.
-Assert H0 := Alembert_cos.
-Unfold cos_n in H0; Unfold Un_cv in H0; Unfold Un_cv; Intros.
-Cut ``0<eps/(Rsqr r)``.
-Intro; Elim (H0 ? H2); Intros N0 H3.
-Exists N0; Intros.
-Unfold R_dist; Assert H5 := (H3 ? H4).
-Unfold R_dist in H5; Replace ``(Rabsolu ((Rabsolu (/(INR (fact (mult (S (S O)) (S n))))*(pow r (mult (S (S O)) (S n)))))/(Rabsolu (/(INR (fact (mult (S (S O)) n)))*(pow r (mult (S (S O)) n))))))`` with ``(Rsqr r)*(Rabsolu ((pow ( -1) (S n))/(INR (fact (mult (S (S O)) (S n))))/((pow ( -1) n)/(INR (fact (mult (S (S O)) n))))))``.
-Apply Rlt_monotony_contra with ``/(Rsqr r)``.
-Apply Rlt_Rinv; Apply Rsqr_pos_lt; Assumption.
-Pattern 1 ``/(Rsqr r)``; Replace ``/(Rsqr r)`` with ``(Rabsolu (/(Rsqr r)))``.
-Rewrite <- Rabsolu_mult; Rewrite Rminus_distr; Rewrite Rmult_Or; Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Rewrite <- (Rmult_sym eps); Apply H5.
-Unfold Rsqr; Apply prod_neq_R0; Assumption.
-Rewrite Rabsolu_Rinv.
-Rewrite Rabsolu_right.
-Reflexivity.
-Apply Rle_sym1; Apply pos_Rsqr.
-Unfold Rsqr; Apply prod_neq_R0; Assumption.
-Rewrite (Rmult_sym (Rsqr r)); Unfold Rdiv; Repeat Rewrite Rabsolu_mult; Rewrite Rabsolu_Rabsolu; Rewrite pow_1_abs; Rewrite Rmult_1l; Repeat Rewrite Rmult_assoc; Apply Rmult_mult_r.
-Rewrite Rabsolu_Rinv.
-Rewrite Rabsolu_mult; Rewrite (pow_1_abs n); Rewrite Rmult_1l; Rewrite <- Rabsolu_Rinv.
-Rewrite Rinv_Rinv.
-Rewrite Rinv_Rmult.
-Rewrite Rabsolu_Rinv.
-Rewrite Rinv_Rinv.
-Rewrite (Rmult_sym ``(Rabsolu (Rabsolu (pow r (mult (S (S O)) (S n)))))``); Rewrite Rabsolu_mult; Rewrite Rabsolu_Rabsolu; Rewrite Rmult_assoc; Apply Rmult_mult_r.
-Rewrite Rabsolu_Rinv.
-Do 2 Rewrite Rabsolu_Rabsolu; Repeat Rewrite Rabsolu_right.
-Replace ``(pow r (mult (S (S O)) (S n)))`` with ``(pow r (mult (S (S O)) n))*r*r``.
-Repeat Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Unfold Rsqr; Ring.
-Apply pow_nonzero; Assumption.
-Replace (mult (2) (S n)) with (S (S (mult (2) n))).
-Simpl; Ring.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply Rle_sym1; Apply pow_le; Left; Apply (cond_pos r).
-Apply Rle_sym1; Apply pow_le; Left; Apply (cond_pos r).
-Apply Rabsolu_no_R0; Apply pow_nonzero; Assumption.
-Apply Rabsolu_no_R0; Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply Rabsolu_no_R0; Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Apply Rabsolu_no_R0; Apply pow_nonzero; Assumption.
-Apply INR_fact_neq_0.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Apply prod_neq_R0.
-Apply pow_nonzero; DiscrR.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply H1.
-Apply Rlt_Rinv; Apply Rsqr_pos_lt; Assumption.
-Assert H0 := (cond_pos r); Red; Intro; Rewrite H1 in H0; Elim (Rlt_antirefl ? H0).
-Qed.
-
-(**********)
-Lemma continuity_cos : (continuity cos).
-Pose fn := [N:nat][x:R]``(pow (-1) N)/(INR (fact (mult (S (S O)) N)))*(pow x (mult (S (S O)) N))``.
-Cut (CVN_R fn).
-Intro; Cut (x:R)(sigTT ? [l:R](Un_cv [N:nat](SP fn N x) l)).
-Intro cv; Cut ((n:nat)(continuity (fn n))).
-Intro; Cut (x:R)(cos x)==(SFL fn cv x).
-Intro; Cut (continuity (SFL fn cv))->(continuity cos).
-Intro; Apply H1.
-Apply SFL_continuity; Assumption.
-Unfold continuity; Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros.
-Elim (H1 x ? H2); Intros.
-Exists x0; Intros.
-Elim H3; Intros.
-Split.
-Apply H4.
-Intros; Rewrite (H0 x); Rewrite (H0 x1); Apply H5; Apply H6.
-Intro; Unfold cos SFL.
-Case (cv x); Case (exist_cos (Rsqr x)); Intros.
-Symmetry; EApply UL_sequence.
-Apply u.
-Unfold cos_in in c; Unfold infinit_sum in c; Unfold Un_cv; Intros.
-Elim (c ? H0); Intros N0 H1.
-Exists N0; Intros.
-Unfold R_dist in H1; Unfold R_dist SP.
-Replace (sum_f_R0 [k:nat](fn k x) n) with (sum_f_R0 [i:nat]``(cos_n i)*(pow (Rsqr x) i)`` n).
-Apply H1; Assumption.
-Apply sum_eq; Intros.
-Unfold cos_n fn; Apply Rmult_mult_r.
-Unfold Rsqr; Rewrite pow_sqr; Reflexivity.
-Intro; Unfold fn; Replace [x:R]``(pow ( -1) n)/(INR (fact (mult (S (S O)) n)))*(pow x (mult (S (S O)) n))`` with (mult_fct (fct_cte ``(pow ( -1) n)/(INR (fact (mult (S (S O)) n)))``) (pow_fct (mult (S (S O)) n))); [Idtac | Reflexivity].
-Apply continuity_mult.
-Apply derivable_continuous; Apply derivable_const.
-Apply derivable_continuous; Apply (derivable_pow (mult (2) n)).
-Apply CVN_R_CVS; Apply X.
-Apply CVN_R_cos; Unfold fn; Reflexivity.
-Qed.
-
-(**********)
-Lemma continuity_sin : (continuity sin).
-Unfold continuity; Intro.
-Assert H0 := (continuity_cos ``PI/2-x``).
-Unfold continuity_pt in H0; Unfold continue_in in H0; Unfold limit1_in in H0; Unfold limit_in in H0; Simpl in H0; Unfold R_dist in H0; Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros.
-Elim (H0 ? H); Intros.
-Exists x0; Intros.
-Elim H1; Intros.
-Split.
-Assumption.
-Intros; Rewrite <- (cos_shift x); Rewrite <- (cos_shift x1); Apply H3.
-Elim H4; Intros.
-Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Red; Intro; Unfold D_x no_cond in H5; Elim H5; Intros _ H8; Elim H8; Rewrite <- (Ropp_Ropp x); Rewrite <- (Ropp_Ropp x1); Apply eq_Ropp; Apply r_Rplus_plus with ``PI/2``; Apply H7.
-Replace ``PI/2-x1-(PI/2-x)`` with ``x-x1``; [Idtac | Ring]; Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr3; Apply H6.
-Qed.
-
-Lemma CVN_R_sin : (fn:nat->R->R) (fn == [N:nat][x:R]``(pow ( -1) N)/(INR (fact (plus (mult (S (S O)) N) (S O))))*(pow x (mult (S (S O)) N))``) -> (CVN_R fn).
-Unfold CVN_R; Unfold CVN_r; Intros fn H r.
-Apply Specif.existT with [n:nat]``/(INR (fact (plus (mult (S (S O)) n) (S O))))*(pow r (mult (S (S O)) n))``.
-Cut (SigT ? [l:R](Un_cv [n:nat](sum_f_R0 [k:nat](Rabsolu ``/(INR (fact (plus (mult (S (S O)) k) (S O))))*(pow r (mult (S (S O)) k))``) n) l)).
-Intro; Elim X; Intros.
-Apply existTT with x.
-Split.
-Apply p.
-Intros; Rewrite H; Unfold Rdiv; Do 2 Rewrite Rabsolu_mult; Rewrite pow_1_abs; Rewrite Rmult_1l.
-Cut ``0</(INR (fact (plus (mult (S (S O)) n) (S O))))``.
-Intro; Rewrite (Rabsolu_right  ? (Rle_sym1 ? ? (Rlt_le ? ? H1))).
-Apply Rle_monotony.
-Left; Apply H1.
-Rewrite <- Pow_Rabsolu; Apply pow_maj_Rabs.
-Rewrite Rabsolu_Rabsolu; Unfold Boule in H0; Rewrite minus_R0 in H0; Left; Apply H0.
-Apply Rlt_Rinv; Apply INR_fact_lt_0.
-Cut (r::R)<>``0``.
-Intro; Apply Alembert_C2.
-Intro; Apply Rabsolu_no_R0.
-Apply prod_neq_R0.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Apply pow_nonzero; Assumption.
-Assert H1 := Alembert_sin.
-Unfold sin_n in H1; Unfold Un_cv in H1; Unfold Un_cv; Intros.
-Cut ``0<eps/(Rsqr r)``.
-Intro; Elim (H1 ? H3); Intros N0 H4.
-Exists N0; Intros.
-Unfold R_dist; Assert H6 := (H4 ? H5).
-Unfold R_dist in H5; Replace ``(Rabsolu ((Rabsolu (/(INR (fact (plus (mult (S (S O)) (S n)) (S O))))*(pow r (mult (S (S O)) (S n)))))/(Rabsolu (/(INR (fact (plus (mult (S (S O)) n) (S O))))*(pow r (mult (S (S O)) n))))))`` with ``(Rsqr r)*(Rabsolu ((pow ( -1) (S n))/(INR (fact (plus (mult (S (S O)) (S n)) (S O))))/((pow ( -1) n)/(INR (fact (plus (mult (S (S O)) n) (S O)))))))``.
-Apply Rlt_monotony_contra with ``/(Rsqr r)``.
-Apply Rlt_Rinv; Apply Rsqr_pos_lt; Assumption.
-Pattern 1 ``/(Rsqr r)``; Rewrite <- (Rabsolu_right ``/(Rsqr r)``).
-Rewrite <- Rabsolu_mult.
-Rewrite Rminus_distr.
-Rewrite Rmult_Or; Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Rewrite <- (Rmult_sym eps).
-Apply H6.
-Unfold Rsqr; Apply prod_neq_R0; Assumption.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Apply Rsqr_pos_lt; Assumption.
-Unfold Rdiv; Rewrite (Rmult_sym (Rsqr r)); Repeat Rewrite Rabsolu_mult; Rewrite Rabsolu_Rabsolu; Rewrite pow_1_abs.
-Rewrite Rmult_1l.
-Repeat Rewrite Rmult_assoc; Apply Rmult_mult_r.
-Rewrite Rinv_Rmult.
-Rewrite Rinv_Rinv.
-Rewrite Rabsolu_mult.
-Rewrite Rabsolu_Rinv.
-Rewrite pow_1_abs; Rewrite Rinv_R1; Rewrite Rmult_1l.
-Rewrite Rinv_Rmult.
-Rewrite <- Rabsolu_Rinv.
-Rewrite Rinv_Rinv.
-Rewrite Rabsolu_mult.
-Do 2 Rewrite Rabsolu_Rabsolu.
-Rewrite (Rmult_sym ``(Rabsolu (pow r (mult (S (S O)) (S n))))``).
-Rewrite Rmult_assoc; Apply Rmult_mult_r.
-Rewrite Rabsolu_Rinv.
-Rewrite Rabsolu_Rabsolu.
-Repeat Rewrite Rabsolu_right.
-Replace ``(pow r (mult (S (S O)) (S n)))`` with ``(pow r (mult (S (S O)) n))*r*r``.
-Do 2 Rewrite <- Rmult_assoc.
-Rewrite <- Rinv_l_sym.
-Unfold Rsqr; Ring.
-Apply pow_nonzero; Assumption.
-Replace (mult (2) (S n)) with (S (S (mult (2) n))).
-Simpl; Ring.
-Apply INR_eq; Do 2 Rewrite S_INR; Do 2 Rewrite mult_INR; Repeat Rewrite S_INR; Ring.
-Apply Rle_sym1; Apply pow_le; Left; Apply (cond_pos r).
-Apply Rle_sym1; Apply pow_le; Left; Apply (cond_pos r).
-Apply Rabsolu_no_R0; Apply pow_nonzero; Assumption.
-Apply INR_fact_neq_0.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Apply Rabsolu_no_R0; Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Apply Rabsolu_no_R0; Apply pow_nonzero; Assumption.
-Apply pow_nonzero; DiscrR.
-Apply INR_fact_neq_0.
-Apply pow_nonzero; DiscrR.
-Apply Rinv_neq_R0; Apply INR_fact_neq_0.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Apply Rsqr_pos_lt; Assumption].
-Assert H0 := (cond_pos r); Red; Intro; Rewrite H1 in H0; Elim (Rlt_antirefl ? H0).
-Qed.
-
-(* (sin h)/h -> 1 when h -> 0 *)
-Lemma derivable_pt_lim_sin_0 : (derivable_pt_lim sin R0 R1).
-Unfold derivable_pt_lim; Intros.
-Pose fn := [N:nat][x:R]``(pow ( -1) N)/(INR (fact (plus (mult (S (S O)) N) (S O))))*(pow x (mult (S (S O)) N))``.
-Cut (CVN_R fn).
-Intro; Cut (x:R)(sigTT ? [l:R](Un_cv [N:nat](SP fn N x) l)).
-Intro cv.
-Pose r := (mkposreal ? Rlt_R0_R1).
-Cut (CVN_r fn r).
-Intro; Cut ((n:nat; y:R)(Boule ``0`` r y)->(continuity_pt (fn n) y)).
-Intro; Cut (Boule R0 r R0).
-Intro; Assert H2 := (SFL_continuity_pt ? cv ? X0 H0 ? H1).
-Unfold continuity_pt in H2; Unfold continue_in in H2; Unfold limit1_in in H2; Unfold limit_in in H2; Simpl in H2; Unfold R_dist in H2.
-Elim (H2 ? H); Intros alp H3.
-Elim H3; Intros.
-Exists (mkposreal ? H4).
-Simpl; Intros.
-Rewrite sin_0; Rewrite Rplus_Ol; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or.
-Cut ``(Rabsolu ((SFL fn cv h)-(SFL fn cv 0))) < eps``.
-Intro; Cut (SFL fn cv R0)==R1.
-Intro; Cut (SFL fn cv h)==``(sin h)/h``.
-Intro; Rewrite H9 in H8; Rewrite H10 in H8.
-Apply H8.
-Unfold SFL sin.
-Case (cv h); Intros.
-Case (exist_sin (Rsqr h)); Intros.
-Unfold Rdiv; Rewrite (Rinv_r_simpl_m h x0 H6).
-EApply UL_sequence.
-Apply u.
-Unfold sin_in in s; Unfold sin_n infinit_sum in s; Unfold SP fn Un_cv; Intros.
-Elim (s ? H10); Intros N0 H11.
-Exists N0; Intros.
-Unfold R_dist; Unfold R_dist in H11.
-Replace (sum_f_R0 [k:nat]``(pow ( -1) k)/(INR (fact (plus (mult (S (S O)) k) (S O))))*(pow h (mult (S (S O)) k))`` n) with (sum_f_R0 [i:nat]``(pow ( -1) i)/(INR (fact (plus (mult (S (S O)) i) (S O))))*(pow (Rsqr h) i)`` n).
-Apply H11; Assumption.
-Apply sum_eq; Intros; Apply Rmult_mult_r; Unfold Rsqr; Rewrite pow_sqr; Reflexivity.
-Unfold SFL sin.
-Case (cv R0); Intros.
-EApply UL_sequence.
-Apply u.
-Unfold SP fn; Unfold Un_cv; Intros; Exists (S O); Intros.
-Unfold R_dist; Replace (sum_f_R0 [k:nat]``(pow ( -1) k)/(INR (fact (plus (mult (S (S O)) k) (S O))))*(pow 0 (mult (S (S O)) k))`` n) with R1.
-Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Assumption.
-Rewrite decomp_sum.
-Simpl; Rewrite Rmult_1r; Unfold Rdiv; Rewrite Rinv_R1; Rewrite Rmult_1r; Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rplus_plus_r.
-Symmetry; Apply sum_eq_R0; Intros.
-Rewrite Rmult_Ol; Rewrite Rmult_Or; Reflexivity.
-Unfold ge in H10; Apply lt_le_trans with (1); [Apply lt_n_Sn | Apply H10].
-Apply H5.
-Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Apply not_sym; Apply H6.
-Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply H7.
-Unfold Boule; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_R0; Apply (cond_pos r).
-Intros; Unfold fn; Replace [x:R]``(pow ( -1) n)/(INR (fact (plus (mult (S (S O)) n) (S O))))*(pow x (mult (S (S O)) n))`` with (mult_fct (fct_cte ``(pow ( -1) n)/(INR (fact (plus (mult (S (S O)) n) (S O))))``) (pow_fct (mult (S (S O)) n))); [Idtac | Reflexivity].
-Apply continuity_pt_mult.
-Apply derivable_continuous_pt.
-Apply derivable_pt_const.
-Apply derivable_continuous_pt.
-Apply (derivable_pt_pow (mult (2) n) y).
-Apply (X r).
-Apply (CVN_R_CVS ? X).
-Apply CVN_R_sin; Unfold fn; Reflexivity.
-Qed.
-
-(* ((cos h)-1)/h -> 0 when h -> 0 *)
-Lemma derivable_pt_lim_cos_0 : (derivable_pt_lim cos ``0`` ``0``).
-Unfold derivable_pt_lim; Intros.
-Assert H0 := derivable_pt_lim_sin_0.
-Unfold derivable_pt_lim in H0.
-Cut ``0<eps/2``.
-Intro; Elim (H0 ? H1); Intros del H2.
-Cut (continuity_pt sin ``0``).
-Intro; Unfold continuity_pt in H3; Unfold continue_in in H3; Unfold limit1_in in H3; Unfold limit_in in H3; Simpl in H3; Unfold R_dist in H3.
-Cut ``0<eps/2``; [Intro | Assumption].
-Elim (H3 ? H4); Intros del_c H5.
-Cut ``0<(Rmin del del_c)``.
-Intro; Pose delta := (mkposreal ? H6).
-Exists delta; Intros.
-Rewrite Rplus_Ol; Replace ``((cos h)-(cos 0))`` with ``-2*(Rsqr (sin (h/2)))``.
-Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or.
-Unfold Rdiv; Do 2 Rewrite Ropp_mul1.
-Rewrite Rabsolu_Ropp.
-Replace ``2*(Rsqr (sin (h*/2)))*/h`` with ``(sin (h/2))*((sin (h/2))/(h/2)-1)+(sin (h/2))``.
-Apply Rle_lt_trans with ``(Rabsolu ((sin (h/2))*((sin (h/2))/(h/2)-1)))+(Rabsolu ((sin (h/2))))``.
-Apply Rabsolu_triang.
-Rewrite (double_var eps); Apply Rplus_lt.
-Apply Rle_lt_trans with ``(Rabsolu ((sin (h/2))/(h/2)-1))``.
-Rewrite Rabsolu_mult; Rewrite Rmult_sym; Pattern 2 ``(Rabsolu ((sin (h/2))/(h/2)-1))``; Rewrite <- Rmult_1r; Apply Rle_monotony.
-Apply Rabsolu_pos.
-Assert H9 := (SIN_bound ``h/2``).
-Unfold Rabsolu; Case (case_Rabsolu ``(sin (h/2))``); Intro.
-Pattern 3 R1; Rewrite <- (Ropp_Ropp ``1``).
-Apply Rle_Ropp1.
-Elim H9; Intros; Assumption.
-Elim H9; Intros; Assumption.
-Cut ``(Rabsolu (h/2))<del``.
-Intro; Cut ``h/2<>0``.
-Intro; Assert H11 := (H2 ? H10 H9). 
-Rewrite Rplus_Ol in H11; Rewrite sin_0 in H11.
-Rewrite minus_R0 in H11; Apply H11.
-Unfold Rdiv; Apply prod_neq_R0.
-Apply H7.
-Apply Rinv_neq_R0; DiscrR.
-Apply Rlt_trans with ``del/2``.
-Unfold Rdiv; Rewrite Rabsolu_mult.
-Rewrite (Rabsolu_right ``/2``).
-Do 2 Rewrite <- (Rmult_sym ``/2``); Apply Rlt_monotony.
-Apply Rlt_Rinv; Sup0.
-Apply Rlt_le_trans with (pos delta).
-Apply H8.
-Unfold delta; Simpl; Apply Rmin_l.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Sup0.
-Rewrite <- (Rplus_Or ``del/2``); Pattern 1 del; Rewrite (double_var del); Apply Rlt_compatibility; Unfold Rdiv; Apply Rmult_lt_pos.
-Apply (cond_pos del).
-Apply Rlt_Rinv; Sup0.
-Elim H5; Intros; Assert H11 := (H10 ``h/2``).
-Rewrite sin_0 in H11; Do 2 Rewrite minus_R0 in H11.
-Apply H11.
-Split.
-Unfold D_x no_cond; Split.
-Trivial.
-Apply not_sym; Unfold Rdiv; Apply prod_neq_R0.
-Apply H7.
-Apply Rinv_neq_R0; DiscrR.
-Apply Rlt_trans with ``del_c/2``.
-Unfold Rdiv; Rewrite Rabsolu_mult.
-Rewrite (Rabsolu_right ``/2``).
-Do 2 Rewrite <- (Rmult_sym ``/2``).
-Apply Rlt_monotony.
-Apply Rlt_Rinv; Sup0.
-Apply Rlt_le_trans with (pos delta).
-Apply H8.
-Unfold delta; Simpl; Apply Rmin_r.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Sup0.
-Rewrite <- (Rplus_Or ``del_c/2``); Pattern 2 del_c; Rewrite (double_var del_c); Apply Rlt_compatibility.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply H9.
-Apply Rlt_Rinv; Sup0.
-Rewrite Rminus_distr; Rewrite Rmult_1r; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Rewrite (Rmult_sym ``2``); Unfold Rdiv Rsqr.
-Repeat Rewrite Rmult_assoc.
-Repeat Apply Rmult_mult_r.
-Rewrite Rinv_Rmult.
-Rewrite Rinv_Rinv.
-Apply Rmult_sym.
-DiscrR.
-Apply H7.
-Apply Rinv_neq_R0; DiscrR.
-Pattern 2 h; Replace h with ``2*(h/2)``.
-Rewrite (cos_2a_sin ``h/2``).
-Rewrite cos_0; Unfold Rsqr; Ring.
-Unfold Rdiv; Rewrite <- Rmult_assoc; Apply Rinv_r_simpl_m.
-DiscrR.
-Unfold Rmin; Case (total_order_Rle del del_c); Intro.
-Apply (cond_pos del).
-Elim H5; Intros; Assumption.
-Apply continuity_sin.
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0].
-Qed.
-
-(**********)
-Theorem derivable_pt_lim_sin : (x:R)(derivable_pt_lim sin x (cos x)).
-Intro; Assert H0 := derivable_pt_lim_sin_0.
-Assert H := derivable_pt_lim_cos_0.
-Unfold derivable_pt_lim in H0 H.
-Unfold derivable_pt_lim; Intros.
-Cut ``0<eps/2``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Apply H1 | Apply Rlt_Rinv; Sup0]].
-Elim (H0 ? H2); Intros alp1 H3.
-Elim (H ? H2); Intros alp2 H4.
-Pose alp := (Rmin alp1 alp2).
-Cut ``0<alp``.
-Intro; Exists (mkposreal ? H5); Intros.
-Replace ``((sin (x+h))-(sin x))/h-(cos x)`` with ``(sin x)*((cos h)-1)/h+(cos x)*((sin h)/h-1)``.
-Apply Rle_lt_trans with ``(Rabsolu ((sin x)*((cos h)-1)/h))+(Rabsolu ((cos x)*((sin h)/h-1)))``.
-Apply Rabsolu_triang.
-Rewrite (double_var eps); Apply Rplus_lt.
-Apply Rle_lt_trans with ``(Rabsolu ((cos h)-1)/h)``.
-Rewrite Rabsolu_mult; Rewrite Rmult_sym; Pattern 2 ``(Rabsolu (((cos h)-1)/h))``; Rewrite <- Rmult_1r; Apply Rle_monotony.
-Apply Rabsolu_pos.
-Assert H8 := (SIN_bound x); Elim H8; Intros.
-Unfold Rabsolu; Case (case_Rabsolu (sin x)); Intro.
-Rewrite <- (Ropp_Ropp R1).
-Apply Rle_Ropp1; Assumption.
-Assumption.
-Cut ``(Rabsolu h)<alp2``.
-Intro; Assert H9 := (H4 ? H6 H8).
-Rewrite cos_0 in H9; Rewrite Rplus_Ol in H9; Rewrite minus_R0 in H9; Apply H9.
-Apply Rlt_le_trans with alp.
-Apply H7.
-Unfold alp; Apply Rmin_r.
-Apply Rle_lt_trans with ``(Rabsolu ((sin h)/h-1))``.
-Rewrite Rabsolu_mult; Rewrite Rmult_sym; Pattern 2 ``(Rabsolu ((sin h)/h-1))``; Rewrite <- Rmult_1r; Apply Rle_monotony.
-Apply Rabsolu_pos.
-Assert H8 := (COS_bound x); Elim H8; Intros.
-Unfold Rabsolu; Case (case_Rabsolu (cos x)); Intro.
-Rewrite <- (Ropp_Ropp R1); Apply Rle_Ropp1; Assumption.
-Assumption.
-Cut ``(Rabsolu h)<alp1``.
-Intro; Assert H9 := (H3 ? H6 H8).
-Rewrite sin_0 in H9; Rewrite Rplus_Ol in H9; Rewrite minus_R0 in H9; Apply H9.
-Apply Rlt_le_trans with alp.
-Apply H7.
-Unfold alp; Apply Rmin_l.
-Rewrite sin_plus; Unfold Rminus Rdiv; Repeat Rewrite Rmult_Rplus_distrl; Repeat Rewrite Rmult_Rplus_distr; Repeat Rewrite Rmult_assoc; Repeat Rewrite Rplus_assoc; Apply Rplus_plus_r.
-Rewrite (Rplus_sym ``(sin x)*( -1*/h)``); Repeat Rewrite Rplus_assoc; Apply Rplus_plus_r.
-Rewrite Ropp_mul3; Rewrite Ropp_mul1; Rewrite Rmult_1r; Rewrite Rmult_1l; Rewrite Ropp_mul3; Rewrite <- Ropp_mul1; Apply Rplus_sym.
-Unfold alp; Unfold Rmin; Case (total_order_Rle alp1 alp2); Intro.
-Apply (cond_pos alp1).
-Apply (cond_pos alp2).
-Qed.
-
-Lemma derivable_pt_lim_cos : (x:R) (derivable_pt_lim cos x ``-(sin x)``).
-Intro; Cut (h:R)``(sin (h+PI/2))``==(cos h).
-Intro; Replace ``-(sin x)`` with (Rmult (cos ``x+PI/2``) (Rplus R1 R0)).
-Generalize (derivable_pt_lim_comp (plus_fct id (fct_cte ``PI/2``)) sin); Intros.
-Cut (derivable_pt_lim (plus_fct id (fct_cte ``PI/2``)) x ``1+0``).
-Cut (derivable_pt_lim sin (plus_fct id (fct_cte ``PI/2``) x) ``(cos (x+PI/2))``).
-Intros; Generalize (H0 ? ? ? H2 H1); Replace (comp sin (plus_fct id (fct_cte ``PI/2``))) with [x:R]``(sin (x+PI/2))``; [Idtac | Reflexivity].
-Unfold derivable_pt_lim; Intros.
-Elim (H3 eps H4); Intros.
-Exists x0.
-Intros; Rewrite <- (H ``x+h``); Rewrite <- (H x); Apply H5; Assumption.
-Apply derivable_pt_lim_sin.
-Apply derivable_pt_lim_plus.
-Apply derivable_pt_lim_id.
-Apply derivable_pt_lim_const.
-Rewrite sin_cos; Rewrite <- (Rplus_sym x); Ring.
-Intro; Rewrite cos_sin; Rewrite Rplus_sym; Reflexivity.
-Qed.
-
-Lemma derivable_pt_sin : (x:R) (derivable_pt sin x).
-Unfold derivable_pt; Intro.
-Apply Specif.existT with (cos x).
-Apply derivable_pt_lim_sin.
-Qed.
-
-Lemma derivable_pt_cos : (x:R) (derivable_pt cos x).
-Unfold derivable_pt; Intro.
-Apply Specif.existT with ``-(sin x)``.
-Apply derivable_pt_lim_cos.
-Qed.
-
-Lemma derivable_sin : (derivable sin).
-Unfold derivable; Intro; Apply derivable_pt_sin.
-Qed.
-
-Lemma derivable_cos : (derivable cos).
-Unfold derivable; Intro; Apply derivable_pt_cos.
-Qed.
-
-Lemma derive_pt_sin : (x:R) ``(derive_pt sin x (derivable_pt_sin ?))==(cos x)``.
-Intros; Apply derive_pt_eq_0.
-Apply derivable_pt_lim_sin.
-Qed.
-
-Lemma derive_pt_cos : (x:R) ``(derive_pt cos x (derivable_pt_cos ?))==-(sin x)``.
-Intros; Apply derive_pt_eq_0.
-Apply derivable_pt_lim_cos.
-Qed.
diff --git a/theories7/Reals/SeqProp.v b/theories7/Reals/SeqProp.v
deleted file mode 100644
index b34fa339..00000000
--- a/theories7/Reals/SeqProp.v
+++ /dev/null
@@ -1,1089 +0,0 @@
-(************************************************************************)
-(*  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: SeqProp.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Rseries.
-Require Classical.
-Require Max.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-Definition Un_decreasing [Un:nat->R] : Prop := (n:nat) (Rle (Un (S n)) (Un n)).
-Definition opp_seq [Un:nat->R] : nat->R := [n:nat]``-(Un n)``.
-Definition has_ub [Un:nat->R] : Prop := (bound (EUn Un)).
-Definition has_lb [Un:nat->R] : Prop := (bound (EUn (opp_seq Un))).
-
-(**********)
-Lemma growing_cv : (Un:nat->R) (Un_growing Un) -> (has_ub Un) -> (sigTT R [l:R](Un_cv Un l)).
-Unfold Un_growing Un_cv;Intros; 
- NewDestruct (complet (EUn Un) H0 (EUn_noempty Un)) as [x [H2 H3]].
- Exists x;Intros eps H1.
- Unfold is_upper_bound in H2 H3.
-Assert H5:(n:nat)(Rle (Un n) x).
-  Intro n; Apply (H2 (Un n) (Un_in_EUn Un n)).
-Cut (Ex [N:nat] (Rlt (Rminus x eps) (Un N))).
-Intro H6;NewDestruct H6 as [N H6];Exists N.
-Intros n H7;Unfold R_dist;Apply (Rabsolu_def1 (Rminus (Un n) x) eps).
-Unfold Rgt in H1.
- Apply (Rle_lt_trans (Rminus (Un n) x) R0 eps
-                     (Rle_minus (Un n) x (H5 n)) H1).
-Fold Un_growing in H;Generalize (growing_prop Un n N H H7);Intro H8.
- Generalize (Rlt_le_trans (Rminus x eps) (Un N) (Un n) H6
-                          (Rle_sym2 (Un N) (Un n) H8));Intro H9;
- Generalize (Rlt_compatibility (Ropp x) (Rminus x eps) (Un n) H9);
- Unfold Rminus;Rewrite <-(Rplus_assoc (Ropp x) x (Ropp eps));
- Rewrite (Rplus_sym (Ropp x) (Un n));Fold (Rminus (Un n) x);
- Rewrite Rplus_Ropp_l;Rewrite (let (H1,H2)=(Rplus_ne (Ropp eps)) in H2);
- Trivial.
-Cut ~((N:nat)(Rle (Un N) (Rminus x eps))).
-Intro H6;Apply (not_all_not_ex nat ([N:nat](Rlt (Rminus x eps) (Un N)))).
- Intro H7; Apply H6; Intro N; Apply Rnot_lt_le; Apply H7.
-Intro H7;Generalize (Un_bound_imp Un (Rminus x eps) H7);Intro H8;
- Unfold is_upper_bound in H8;Generalize (H3 (Rminus x eps) H8);
- Apply Rlt_le_not; Apply tech_Rgt_minus; Exact H1.
-Qed.
-
-Lemma decreasing_growing : (Un:nat->R) (Un_decreasing Un) -> (Un_growing (opp_seq Un)).
-Intro.
-Unfold Un_growing opp_seq Un_decreasing.
-Intros.
-Apply Rle_Ropp1.
-Apply H.
-Qed.
-
-Lemma decreasing_cv : (Un:nat->R) (Un_decreasing Un) -> (has_lb Un) -> (sigTT R [l:R](Un_cv Un l)).
-Intros.
-Cut (sigTT R [l:R](Un_cv (opp_seq Un) l)) -> (sigTT R [l:R](Un_cv Un l)).
-Intro.
-Apply X.
-Apply growing_cv.
-Apply decreasing_growing; Assumption.
-Exact H0.
-Intro.
-Elim X; Intros.
-Apply existTT with ``-x``.
-Unfold Un_cv in p.
-Unfold R_dist in p.
-Unfold opp_seq in p.
-Unfold Un_cv.
-Unfold R_dist.
-Intros.
-Elim (p eps H1); Intros.
-Exists x0; Intros.
-Assert H4 := (H2 n H3).
-Rewrite <- Rabsolu_Ropp.
-Replace ``-((Un n)- -x)`` with ``-(Un n)-x``; [Assumption | Ring].
-Qed.
-
-(***********)
-Lemma maj_sup : (Un:nat->R) (has_ub Un) -> (sigTT R [l:R](is_lub (EUn Un) l)).
-Intros.
-Unfold has_ub in H.
-Apply complet.
-Assumption.
-Exists (Un O).
-Unfold EUn.
-Exists O; Reflexivity.
-Qed.
-
-(**********)
-Lemma min_inf : (Un:nat->R) (has_lb Un) -> (sigTT R [l:R](is_lub (EUn (opp_seq Un)) l)).
-Intros; Unfold has_lb in H.
-Apply complet.
-Assumption.
-Exists ``-(Un O)``.
-Exists O.
-Reflexivity.
-Qed.
-
-Definition majorant [Un:nat->R;pr:(has_ub Un)] : R := Cases (maj_sup Un pr) of (existTT a b) => a end.
-
-Definition minorant [Un:nat->R;pr:(has_lb Un)] : R := Cases (min_inf Un pr) of (existTT a b) => ``-a`` end.
-
-Lemma maj_ss : (Un:nat->R;k:nat) (has_ub Un) -> (has_ub [i:nat](Un (plus k i))).
-Intros.
-Unfold has_ub in H.
-Unfold bound in H.
-Elim H; Intros.
-Unfold is_upper_bound in H0.
-Unfold has_ub.
-Exists x.
-Unfold is_upper_bound.
-Intros.
-Apply H0.
-Elim H1; Intros.
-Exists (plus k x1); Assumption.
-Qed.
-
-Lemma min_ss : (Un:nat->R;k:nat) (has_lb Un) -> (has_lb [i:nat](Un (plus k i))).
-Intros.
-Unfold has_lb in H.
-Unfold bound in H.
-Elim H; Intros.
-Unfold is_upper_bound in H0.
-Unfold has_lb.
-Exists x.
-Unfold is_upper_bound.
-Intros.
-Apply H0.
-Elim H1; Intros.
-Exists (plus k x1); Assumption.
-Qed.
-
-Definition sequence_majorant [Un:nat->R;pr:(has_ub Un)] : nat -> R := [i:nat](majorant [k:nat](Un (plus i k)) (maj_ss Un i pr)).
-
-Definition sequence_minorant [Un:nat->R;pr:(has_lb Un)] : nat -> R := [i:nat](minorant [k:nat](Un (plus i k)) (min_ss Un i pr)).
-
-Lemma Wn_decreasing : (Un:nat->R;pr:(has_ub Un)) (Un_decreasing (sequence_majorant Un pr)). 
-Intros.
-Unfold Un_decreasing.
-Intro.
-Unfold sequence_majorant.
-Assert H := (maj_sup [k:nat](Un (plus (S n) k)) (maj_ss Un (S n) pr)).
-Assert H0 := (maj_sup [k:nat](Un (plus n k)) (maj_ss Un n pr)).
-Elim H; Intros.
-Elim H0; Intros.
-Cut (majorant ([k:nat](Un (plus (S n) k))) (maj_ss Un (S n) pr)) == x; [Intro Maj1; Rewrite Maj1 | Idtac].
-Cut (majorant ([k:nat](Un (plus n k))) (maj_ss Un n pr)) == x0; [Intro Maj2; Rewrite Maj2 | Idtac].
-Unfold is_lub in p.
-Unfold is_lub in p0.
-Elim p; Intros.
-Apply H2.
-Elim p0; Intros.
-Unfold is_upper_bound.
-Intros.
-Unfold is_upper_bound in H3.
-Apply H3.
-Elim H5; Intros.
-Exists (plus (1) x2).
-Replace (plus n (plus (S O) x2)) with (plus (S n) x2).
-Assumption.
-Replace (S n) with (plus (1) n); [Ring | Ring].
-Cut (is_lub (EUn [k:nat](Un (plus n k))) (majorant ([k:nat](Un (plus n k))) (maj_ss Un n pr))).
-Intro.
-Unfold is_lub in p0; Unfold is_lub in H1.
-Elim p0; Intros; Elim H1; Intros.
-Assert H6 := (H5 x0 H2).
-Assert H7 := (H3 (majorant ([k:nat](Un (plus n k))) (maj_ss Un n pr)) H4).
-Apply Rle_antisym; Assumption.
-Unfold majorant.
-Case (maj_sup [k:nat](Un (plus n k)) (maj_ss Un n pr)).
-Trivial.
-Cut (is_lub (EUn [k:nat](Un (plus (S n) k))) (majorant ([k:nat](Un (plus (S n) k))) (maj_ss Un (S n) pr))).
-Intro.
-Unfold is_lub in p; Unfold is_lub in H1.
-Elim p; Intros; Elim H1; Intros.
-Assert H6 := (H5 x H2).
-Assert H7 := (H3 (majorant ([k:nat](Un (plus (S n) k))) (maj_ss Un (S n) pr)) H4).
-Apply Rle_antisym; Assumption.
-Unfold majorant.
-Case (maj_sup [k:nat](Un (plus (S n) k)) (maj_ss Un (S n) pr)).
-Trivial.
-Qed.
-
-Lemma Vn_growing : (Un:nat->R;pr:(has_lb Un)) (Un_growing (sequence_minorant Un pr)).
-Intros.
-Unfold Un_growing.
-Intro.
-Unfold sequence_minorant.
-Assert H := (min_inf [k:nat](Un (plus (S n) k)) (min_ss Un (S n) pr)).
-Assert H0 := (min_inf [k:nat](Un (plus n k)) (min_ss Un n pr)).
-Elim H; Intros.
-Elim H0; Intros.
-Cut (minorant ([k:nat](Un (plus (S n) k))) (min_ss Un (S n) pr)) == ``-x``; [Intro Maj1; Rewrite Maj1 | Idtac].
-Cut (minorant ([k:nat](Un (plus n k))) (min_ss Un n pr)) == ``-x0``; [Intro Maj2; Rewrite Maj2 | Idtac].
-Unfold is_lub in p.
-Unfold is_lub in p0.
-Elim p; Intros.
-Apply Rle_Ropp1.
-Apply H2.
-Elim p0; Intros.
-Unfold is_upper_bound.
-Intros.
-Unfold is_upper_bound in H3.
-Apply H3.
-Elim H5; Intros.
-Exists (plus (1) x2).
-Unfold opp_seq in H6.
-Unfold opp_seq.
-Replace (plus n (plus (S O) x2)) with (plus (S n) x2).
-Assumption.
-Replace (S n) with (plus (1) n); [Ring | Ring].
-Cut (is_lub (EUn (opp_seq [k:nat](Un (plus n k)))) (Ropp (minorant ([k:nat](Un (plus n k))) (min_ss Un n pr)))).
-Intro.
-Unfold is_lub in p0; Unfold is_lub in H1.
-Elim p0; Intros; Elim H1; Intros.
-Assert H6 := (H5 x0 H2).
-Assert H7 := (H3 (Ropp (minorant ([k:nat](Un (plus n k))) (min_ss Un n pr))) H4).
-Rewrite <- (Ropp_Ropp (minorant ([k:nat](Un (plus n k))) (min_ss Un n pr))).
-Apply eq_Ropp; Apply Rle_antisym; Assumption.
-Unfold minorant.
-Case (min_inf [k:nat](Un (plus n k)) (min_ss Un n pr)).
-Intro; Rewrite Ropp_Ropp.
-Trivial.
-Cut (is_lub (EUn (opp_seq [k:nat](Un (plus (S n) k)))) (Ropp (minorant ([k:nat](Un (plus (S n) k))) (min_ss Un (S n) pr)))).
-Intro.
-Unfold is_lub in p; Unfold is_lub in H1.
-Elim p; Intros; Elim H1; Intros.
-Assert H6 := (H5 x H2).
-Assert H7 := (H3 (Ropp (minorant ([k:nat](Un (plus (S n) k))) (min_ss Un (S n) pr))) H4).
-Rewrite <- (Ropp_Ropp (minorant ([k:nat](Un (plus (S n) k))) (min_ss Un (S n) pr))).
-Apply eq_Ropp; Apply Rle_antisym; Assumption.
-Unfold minorant.
-Case (min_inf [k:nat](Un (plus (S n) k)) (min_ss Un (S n) pr)).
-Intro; Rewrite Ropp_Ropp.
-Trivial.
-Qed.
-
-(**********)
-Lemma Vn_Un_Wn_order : (Un:nat->R;pr1:(has_ub Un);pr2:(has_lb Un)) (n:nat) ``((sequence_minorant Un pr2) n)<=(Un n)<=((sequence_majorant Un pr1) n)``. 
-Intros.
-Split.
-Unfold sequence_minorant.
-Cut (sigTT R [l:R](is_lub (EUn (opp_seq [i:nat](Un (plus n i)))) l)).
-Intro.
-Elim X; Intros.
-Replace (minorant ([k:nat](Un (plus n k))) (min_ss Un n pr2)) with ``-x``.
-Unfold is_lub in p.
-Elim p; Intros.
-Unfold is_upper_bound in H.
-Rewrite <- (Ropp_Ropp (Un n)).
-Apply Rle_Ropp1.
-Apply H.
-Exists O.
-Unfold opp_seq.
-Replace (plus n O) with n; [Reflexivity | Ring].
-Cut (is_lub (EUn (opp_seq [k:nat](Un (plus n k)))) (Ropp (minorant ([k:nat](Un (plus n k))) (min_ss Un n pr2)))).
-Intro.
-Unfold is_lub in p; Unfold is_lub in H.
-Elim p; Intros; Elim H; Intros.
-Assert H4 := (H3 x H0).
-Assert H5 := (H1 (Ropp (minorant ([k:nat](Un (plus n k))) (min_ss Un n pr2))) H2).
-Rewrite <- (Ropp_Ropp (minorant ([k:nat](Un (plus n k))) (min_ss Un n pr2))).
-Apply eq_Ropp; Apply Rle_antisym; Assumption.
-Unfold minorant.
-Case (min_inf [k:nat](Un (plus n k)) (min_ss Un n pr2)).
-Intro; Rewrite Ropp_Ropp.
-Trivial.
-Apply min_inf.
-Apply min_ss; Assumption.
-Unfold sequence_majorant.
-Cut (sigTT R [l:R](is_lub (EUn [i:nat](Un (plus n i))) l)).
-Intro.
-Elim X; Intros.
-Replace (majorant ([k:nat](Un (plus n k))) (maj_ss Un n pr1)) with ``x``.
-Unfold is_lub in p.
-Elim p; Intros.
-Unfold is_upper_bound in H.
-Apply H.
-Exists O.
-Replace (plus n O) with n; [Reflexivity | Ring].
-Cut (is_lub (EUn [k:nat](Un (plus n k))) (majorant ([k:nat](Un (plus n k))) (maj_ss Un n pr1))).
-Intro.
-Unfold is_lub in p; Unfold is_lub in H.
-Elim p; Intros; Elim H; Intros.
-Assert H4 := (H3 x H0).
-Assert H5 := (H1 (majorant ([k:nat](Un (plus n k))) (maj_ss Un n pr1)) H2).
-Apply Rle_antisym; Assumption.
-Unfold majorant.
-Case (maj_sup [k:nat](Un (plus n k)) (maj_ss Un n pr1)).
-Intro; Trivial.
-Apply maj_sup.
-Apply maj_ss; Assumption.
-Qed.
-
-Lemma min_maj : (Un:nat->R;pr1:(has_ub Un);pr2:(has_lb Un)) (has_ub (sequence_minorant Un pr2)).
-Intros.
-Assert H := (Vn_Un_Wn_order Un pr1 pr2).
-Unfold has_ub.
-Unfold bound.
-Unfold has_ub in pr1.
-Unfold bound in pr1.
-Elim pr1; Intros.
-Exists x.
-Unfold is_upper_bound.
-Intros.
-Unfold is_upper_bound in H0.
-Elim H1; Intros.
-Rewrite H2.
-Apply Rle_trans with (Un x1).
-Assert H3 := (H x1); Elim H3; Intros; Assumption.
-Apply H0.
-Exists x1; Reflexivity.
-Qed.
-
-Lemma maj_min : (Un:nat->R;pr1:(has_ub Un);pr2:(has_lb Un)) (has_lb (sequence_majorant Un pr1)). 
-Intros.
-Assert H := (Vn_Un_Wn_order Un pr1 pr2).
-Unfold has_lb.
-Unfold bound.
-Unfold has_lb in pr2.
-Unfold bound in pr2.
-Elim pr2; Intros.
-Exists x.
-Unfold is_upper_bound.
-Intros.
-Unfold is_upper_bound in H0.
-Elim H1; Intros.
-Rewrite H2.
-Apply Rle_trans with ((opp_seq Un) x1).
-Assert H3 := (H x1); Elim H3; Intros.
-Unfold opp_seq; Apply Rle_Ropp1.
-Assumption.
-Apply H0.
-Exists x1; Reflexivity.
-Qed.
-
-(**********)
-Lemma cauchy_maj : (Un:nat->R) (Cauchy_crit Un) -> (has_ub Un).
-Intros.
-Unfold has_ub.
-Apply cauchy_bound.
-Assumption.
-Qed.
-
-(**********)
-Lemma cauchy_opp : (Un:nat->R) (Cauchy_crit Un) -> (Cauchy_crit (opp_seq Un)).
-Intro.
-Unfold Cauchy_crit.
-Unfold R_dist.
-Intros.
-Elim (H eps H0); Intros.
-Exists x; Intros.
-Unfold opp_seq.
-Rewrite <- Rabsolu_Ropp.
-Replace ``-( -(Un n)- -(Un m))`` with ``(Un n)-(Un m)``; [Apply H1; Assumption | Ring].
-Qed.
-
-(**********)
-Lemma cauchy_min : (Un:nat->R) (Cauchy_crit Un) -> (has_lb Un).
-Intros.
-Unfold has_lb.
-Assert H0 := (cauchy_opp ? H).
-Apply cauchy_bound.
-Assumption.
-Qed.
-
-(**********)
-Lemma maj_cv : (Un:nat->R;pr:(Cauchy_crit Un)) (sigTT R [l:R](Un_cv (sequence_majorant Un (cauchy_maj Un pr)) l)).
-Intros.
-Apply decreasing_cv.
-Apply Wn_decreasing.
-Apply maj_min.
-Apply cauchy_min.
-Assumption.
-Qed.
-
-(**********)
-Lemma min_cv : (Un:nat->R;pr:(Cauchy_crit Un)) (sigTT R [l:R](Un_cv (sequence_minorant Un (cauchy_min Un pr)) l)).
-Intros.
-Apply growing_cv.
-Apply Vn_growing.
-Apply min_maj.
-Apply cauchy_maj.
-Assumption.
-Qed.
-
-Lemma cond_eq : (x,y:R) ((eps:R)``0<eps``->``(Rabsolu (x-y))<eps``) -> x==y.
-Intros.
-Case (total_order_T x y); Intro.
-Elim s; Intro.
-Cut ``0<y-x``.
-Intro.
-Assert H1 := (H ``y-x`` H0).
-Rewrite <- Rabsolu_Ropp in H1.
-Cut ``-(x-y)==y-x``; [Intro; Rewrite H2 in H1 | Ring].
-Rewrite Rabsolu_right in H1.
-Elim (Rlt_antirefl ? H1).
-Left; Assumption.
-Apply Rlt_anti_compatibility with x.
-Rewrite Rplus_Or; Replace ``x+(y-x)`` with y; [Assumption | Ring].
-Assumption.
-Cut ``0<x-y``.
-Intro.
-Assert H1 := (H ``x-y`` H0).
-Rewrite Rabsolu_right in H1.
-Elim (Rlt_antirefl ? H1).
-Left; Assumption.
-Apply Rlt_anti_compatibility with y.
-Rewrite Rplus_Or; Replace ``y+(x-y)`` with x; [Assumption | Ring].
-Qed.
-
-Lemma not_Rlt : (r1,r2:R)~(``r1<r2``)->``r1>=r2``.
-Intros r1 r2 ; Generalize (total_order r1 r2) ; Unfold Rge.
-Tauto.
-Qed. 
-
-(**********)
-Lemma approx_maj : (Un:nat->R;pr:(has_ub Un)) (eps:R) ``0<eps`` -> (EX k : nat | ``(Rabsolu ((majorant Un pr)-(Un k))) < eps``).
-Intros.
-Pose P := [k:nat]``(Rabsolu ((majorant Un pr)-(Un k))) < eps``.
-Unfold P.
-Cut (EX k:nat | (P k)) -> (EX k:nat | ``(Rabsolu ((majorant Un pr)-(Un k))) < eps``).
-Intros.
-Apply H0.
-Apply not_all_not_ex.
-Red; Intro.
-2:Unfold P; Trivial.
-Unfold P in H1.
-Cut (n:nat)``(Rabsolu ((majorant Un pr)-(Un n))) >= eps``.
-Intro.
-Cut (is_lub (EUn Un) (majorant Un pr)).
-Intro.
-Unfold is_lub in H3.
-Unfold is_upper_bound in H3.
-Elim H3; Intros.
-Cut (n:nat)``eps<=(majorant Un pr)-(Un n)``.
-Intro.
-Cut (n:nat)``(Un n)<=(majorant Un pr)-eps``.
-Intro.
-Cut ((x:R)(EUn Un x)->``x <= (majorant Un pr)-eps``).
-Intro.
-Assert H9 := (H5 ``(majorant Un pr)-eps`` H8).
-Cut ``eps<=0``.
-Intro.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H H10)).
-Apply Rle_anti_compatibility with ``(majorant Un pr)-eps``.
-Rewrite Rplus_Or.
-Replace ``(majorant Un pr)-eps+eps`` with (majorant Un pr); [Assumption | Ring].
-Intros.
-Unfold EUn in H8.
-Elim H8; Intros.
-Rewrite H9; Apply H7.
-Intro.
-Assert H7 := (H6 n).
-Apply Rle_anti_compatibility with ``eps-(Un n)``.
-Replace ``eps-(Un n)+(Un n)`` with ``eps``.
-Replace ``eps-(Un n)+((majorant Un pr)-eps)`` with ``(majorant Un pr)-(Un n)``.
-Assumption.
-Ring.
-Ring.
-Intro.
-Assert H6 := (H2 n).
-Rewrite Rabsolu_right in H6.
-Apply Rle_sym2.
-Assumption.
-Apply Rle_sym1.
-Apply Rle_anti_compatibility with (Un n).
-Rewrite Rplus_Or; Replace ``(Un n)+((majorant Un pr)-(Un n))`` with (majorant Un pr); [Apply H4 | Ring].
-Exists n; Reflexivity.
-Unfold majorant.
-Case (maj_sup Un pr).
-Trivial.
-Intro.
-Assert H2 := (H1 n).
-Apply not_Rlt; Assumption.
-Qed.
-
-(**********)
-Lemma approx_min : (Un:nat->R;pr:(has_lb Un)) (eps:R) ``0<eps`` -> (EX k :nat | ``(Rabsolu ((minorant Un pr)-(Un k))) < eps``).
-Intros.
-Pose P := [k:nat]``(Rabsolu ((minorant Un pr)-(Un k))) < eps``.
-Unfold P.
-Cut (EX k:nat | (P k)) -> (EX k:nat | ``(Rabsolu ((minorant Un pr)-(Un k))) < eps``).
-Intros.
-Apply H0.
-Apply not_all_not_ex.
-Red; Intro.
-2:Unfold P; Trivial.
-Unfold P in H1.
-Cut (n:nat)``(Rabsolu ((minorant Un pr)-(Un n))) >= eps``.
-Intro.
-Cut (is_lub (EUn (opp_seq Un)) ``-(minorant Un pr)``).
-Intro.
-Unfold is_lub in H3.
-Unfold is_upper_bound in H3.
-Elim H3; Intros.
-Cut (n:nat)``eps<=(Un n)-(minorant Un pr)``.
-Intro.
-Cut (n:nat)``((opp_seq Un) n)<=-(minorant Un pr)-eps``.
-Intro.
-Cut ((x:R)(EUn (opp_seq Un) x)->``x <= -(minorant Un pr)-eps``).
-Intro.
-Assert H9 := (H5 ``-(minorant Un pr)-eps`` H8).
-Cut ``eps<=0``.
-Intro.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H H10)).
-Apply Rle_anti_compatibility with ``-(minorant Un pr)-eps``.
-Rewrite Rplus_Or.
-Replace ``-(minorant Un pr)-eps+eps`` with ``-(minorant Un pr)``; [Assumption | Ring].
-Intros.
-Unfold EUn in H8.
-Elim H8; Intros.
-Rewrite H9; Apply H7.
-Intro.
-Assert H7 := (H6 n).
-Unfold opp_seq.
-Apply Rle_anti_compatibility with ``eps+(Un n)``.
-Replace ``eps+(Un n)+ -(Un n)`` with ``eps``.
-Replace ``eps+(Un n)+(-(minorant Un pr)-eps)`` with ``(Un n)-(minorant Un pr)``.
-Assumption.
-Ring.
-Ring.
-Intro.
-Assert H6 := (H2 n).
-Rewrite Rabsolu_left1 in H6.
-Apply Rle_sym2.
-Replace ``(Un n)-(minorant Un pr)`` with `` -((minorant Un pr)-(Un n))``; [Assumption | Ring].
-Apply Rle_anti_compatibility with ``-(minorant Un pr)``.
-Rewrite Rplus_Or; Replace ``-(minorant Un pr)+((minorant Un pr)-(Un n))`` with ``-(Un n)``.
-Apply H4.
-Exists n; Reflexivity.
-Ring.
-Unfold minorant.
-Case (min_inf Un pr).
-Intro.
-Rewrite Ropp_Ropp.
-Trivial.
-Intro.
-Assert H2 := (H1 n).
-Apply not_Rlt; Assumption.
-Qed.
-
-(* Unicity of limit for convergent sequences *) 
-Lemma UL_sequence : (Un:nat->R;l1,l2:R) (Un_cv Un l1) -> (Un_cv Un l2) -> l1==l2. 
-Intros Un l1 l2; Unfold Un_cv; Unfold R_dist; Intros. 
-Apply cond_eq. 
-Intros; Cut ``0<eps/2``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0]]. 
-Elim (H ``eps/2`` H2); Intros. 
-Elim (H0 ``eps/2`` H2); Intros. 
-Pose N := (max x x0). 
-Apply Rle_lt_trans with ``(Rabsolu (l1 -(Un N)))+(Rabsolu ((Un N)-l2))``. 
-Replace ``l1-l2`` with ``(l1-(Un N))+((Un N)-l2)``; [Apply Rabsolu_triang | Ring]. 
-Rewrite (double_var eps); Apply Rplus_lt. 
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H3; Unfold ge N; Apply le_max_l. 
-Apply H4; Unfold ge N; Apply le_max_r. 
-Qed.
-
-(**********) 
-Lemma CV_plus : (An,Bn:nat->R;l1,l2:R) (Un_cv An l1) -> (Un_cv Bn l2) -> (Un_cv [i:nat]``(An i)+(Bn i)`` ``l1+l2``). 
-Unfold Un_cv; Unfold R_dist; Intros. 
-Cut ``0<eps/2``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0]]. 
-Elim (H ``eps/2`` H2); Intros. 
-Elim (H0 ``eps/2`` H2); Intros. 
-Pose N := (max x x0). 
-Exists N; Intros. 
-Replace ``(An n)+(Bn n)-(l1+l2)`` with ``((An n)-l1)+((Bn n)-l2)``; [Idtac | Ring]. 
-Apply Rle_lt_trans with ``(Rabsolu ((An n)-l1))+(Rabsolu ((Bn n)-l2))``. 
-Apply Rabsolu_triang. 
-Rewrite (double_var eps); Apply Rplus_lt. 
-Apply H3; Unfold ge; Apply le_trans with N; [Unfold N; Apply le_max_l | Assumption]. 
-Apply H4; Unfold ge; Apply le_trans with N; [Unfold N; Apply le_max_r | Assumption]. 
-Qed.
-
-(**********) 
-Lemma cv_cvabs : (Un:nat->R;l:R) (Un_cv Un l) -> (Un_cv [i:nat](Rabsolu (Un i)) (Rabsolu l)). 
-Unfold Un_cv; Unfold R_dist; Intros. 
-Elim (H eps H0); Intros. 
-Exists x; Intros. 
-Apply Rle_lt_trans with ``(Rabsolu ((Un n)-l))``. 
-Apply Rabsolu_triang_inv2. 
-Apply H1; Assumption. 
-Qed. 
-
-(**********) 
-Lemma CV_Cauchy : (Un:nat->R) (sigTT R [l:R](Un_cv Un l)) -> (Cauchy_crit Un). 
-Intros; Elim X; Intros. 
-Unfold Cauchy_crit; Intros. 
-Unfold Un_cv in p; Unfold R_dist in p. 
-Cut ``0<eps/2``; [Intro | Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Sup0]]. 
-Elim (p ``eps/2`` H0); Intros. 
-Exists x0; Intros. 
-Unfold R_dist; Apply Rle_lt_trans with ``(Rabsolu ((Un n)-x))+(Rabsolu (x-(Un m)))``. 
-Replace ``(Un n)-(Un m)`` with ``((Un n)-x)+(x-(Un m))``; [Apply Rabsolu_triang | Ring]. 
-Rewrite (double_var eps); Apply Rplus_lt. 
-Apply H1; Assumption. 
-Rewrite <- Rabsolu_Ropp; Rewrite Ropp_distr2; Apply H1; Assumption. 
-Qed. 
-
-(**********)
-Lemma maj_by_pos : (Un:nat->R) (sigTT R [l:R](Un_cv Un l)) -> (EXT l:R | ``0<l``/\((n:nat)``(Rabsolu (Un n))<=l``)). 
-Intros; Elim X; Intros. 
-Cut (sigTT R [l:R](Un_cv [k:nat](Rabsolu (Un k)) l)). 
-Intro. 
-Assert H := (CV_Cauchy [k:nat](Rabsolu (Un k)) X0). 
-Assert H0 := (cauchy_bound [k:nat](Rabsolu (Un k)) H). 
-Elim H0; Intros. 
-Exists ``x0+1``. 
-Cut ``0<=x0``. 
-Intro. 
-Split. 
-Apply ge0_plus_gt0_is_gt0; [Assumption | Apply Rlt_R0_R1]. 
-Intros. 
-Apply Rle_trans with x0. 
-Unfold is_upper_bound in H1. 
-Apply H1. 
-Exists n; Reflexivity. 
-Pattern 1 x0; Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Apply Rlt_R0_R1. 
-Apply Rle_trans with (Rabsolu (Un O)). 
-Apply Rabsolu_pos. 
-Unfold is_upper_bound in H1. 
-Apply H1. 
-Exists O; Reflexivity. 
-Apply existTT with (Rabsolu x). 
-Apply cv_cvabs; Assumption. 
-Qed. 
- 
-(**********) 
-Lemma CV_mult : (An,Bn:nat->R;l1,l2:R) (Un_cv An l1) -> (Un_cv Bn l2) -> (Un_cv [i:nat]``(An i)*(Bn i)`` ``l1*l2``). 
-Intros. 
-Cut (sigTT R [l:R](Un_cv An l)). 
-Intro. 
-Assert H1 := (maj_by_pos An X). 
-Elim H1; Intros M H2. 
-Elim H2; Intros. 
-Unfold Un_cv; Unfold R_dist; Intros. 
-Cut ``0<eps/(2*M)``. 
-Intro. 
-Case (Req_EM l2 R0); Intro. 
-Unfold Un_cv in H0; Unfold R_dist in H0. 
-Elim (H0 ``eps/(2*M)`` H6); Intros. 
-Exists x; Intros. 
-Apply Rle_lt_trans with ``(Rabsolu ((An n)*(Bn n)-(An n)*l2))+(Rabsolu ((An n)*l2-l1*l2))``. 
-Replace ``(An n)*(Bn n)-l1*l2`` with ``((An n)*(Bn n)-(An n)*l2)+((An n)*l2-l1*l2)``; [Apply Rabsolu_triang | Ring]. 
-Replace ``(Rabsolu ((An n)*(Bn n)-(An n)*l2))`` with ``(Rabsolu (An n))*(Rabsolu ((Bn n)-l2))``. 
-Replace ``(Rabsolu ((An n)*l2-l1*l2))`` with R0. 
-Rewrite Rplus_Or. 
-Apply Rle_lt_trans with ``M*(Rabsolu ((Bn n)-l2))``. 
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu ((Bn n)-l2))``). 
-Apply Rle_monotony. 
-Apply Rabsolu_pos. 
-Apply H4. 
-Apply Rlt_monotony_contra with ``/M``. 
-Apply Rlt_Rinv; Apply H3. 
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym. 
-Rewrite Rmult_1l; Rewrite (Rmult_sym ``/M``). 
-Apply Rlt_trans with  ``eps/(2*M)``. 
-Apply H8; Assumption. 
-Unfold Rdiv; Rewrite Rinv_Rmult. 
-Apply Rlt_monotony_contra with ``2``. 
-Sup0.
-Replace ``2*(eps*(/2*/M))`` with ``(2*/2)*(eps*/M)``; [Idtac | Ring]. 
-Rewrite <- Rinv_r_sym. 
-Rewrite Rmult_1l; Rewrite double. 
-Pattern 1 ``eps*/M``; Rewrite <- Rplus_Or. 
-Apply Rlt_compatibility; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Assumption]. 
-DiscrR. 
-DiscrR. 
-Red; Intro; Rewrite H10 in H3; Elim (Rlt_antirefl ? H3). 
-Red; Intro; Rewrite H10 in H3; Elim (Rlt_antirefl ? H3). 
-Rewrite H7; Do 2 Rewrite Rmult_Or; Unfold Rminus; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Reflexivity. 
-Replace ``(An n)*(Bn n)-(An n)*l2`` with ``(An n)*((Bn n)-l2)``; [Idtac | Ring]. 
-Symmetry; Apply Rabsolu_mult. 
-Cut ``0<eps/(2*(Rabsolu l2))``. 
-Intro. 
-Unfold Un_cv in H; Unfold R_dist in H; Unfold Un_cv in H0; Unfold R_dist in H0. 
-Elim (H ``eps/(2*(Rabsolu l2))`` H8); Intros N1 H9. 
-Elim (H0 ``eps/(2*M)`` H6); Intros N2 H10. 
-Pose N := (max N1 N2). 
-Exists N; Intros. 
-Apply Rle_lt_trans with ``(Rabsolu ((An n)*(Bn n)-(An n)*l2))+(Rabsolu ((An n)*l2-l1*l2))``. 
-Replace ``(An n)*(Bn n)-l1*l2`` with ``((An n)*(Bn n)-(An n)*l2)+((An n)*l2-l1*l2)``; [Apply Rabsolu_triang | Ring]. 
-Replace ``(Rabsolu ((An n)*(Bn n)-(An n)*l2))`` with ``(Rabsolu (An n))*(Rabsolu ((Bn n)-l2))``. 
-Replace ``(Rabsolu ((An n)*l2-l1*l2))`` with ``(Rabsolu l2)*(Rabsolu ((An n)-l1))``. 
-Rewrite (double_var eps); Apply Rplus_lt. 
-Apply Rle_lt_trans with ``M*(Rabsolu ((Bn n)-l2))``. 
-Do 2 Rewrite <- (Rmult_sym ``(Rabsolu ((Bn n)-l2))``). 
-Apply Rle_monotony. 
-Apply Rabsolu_pos. 
-Apply H4. 
-Apply Rlt_monotony_contra with ``/M``. 
-Apply Rlt_Rinv; Apply H3. 
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym. 
-Rewrite Rmult_1l; Rewrite (Rmult_sym ``/M``). 
-Apply Rlt_le_trans with  ``eps/(2*M)``. 
-Apply H10. 
-Unfold ge; Apply le_trans with N. 
-Unfold N; Apply le_max_r. 
-Assumption. 
-Unfold Rdiv; Rewrite Rinv_Rmult. 
-Right; Ring. 
-DiscrR. 
-Red; Intro; Rewrite H12 in H3; Elim (Rlt_antirefl ? H3). 
-Red; Intro; Rewrite H12 in H3; Elim (Rlt_antirefl ? H3). 
-Apply Rlt_monotony_contra with ``/(Rabsolu l2)``. 
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt; Assumption. 
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym. 
-Rewrite Rmult_1l; Apply Rlt_le_trans with ``eps/(2*(Rabsolu l2))``. 
-Apply H9. 
-Unfold ge; Apply le_trans with N. 
-Unfold N; Apply le_max_l. 
-Assumption. 
-Unfold Rdiv; Right; Rewrite Rinv_Rmult. 
-Ring. 
-DiscrR. 
-Apply Rabsolu_no_R0; Assumption. 
-Apply Rabsolu_no_R0; Assumption. 
-Replace ``(An n)*l2-l1*l2`` with ``l2*((An n)-l1)``; [Symmetry; Apply Rabsolu_mult | Ring]. 
-Replace ``(An n)*(Bn n)-(An n)*l2`` with ``(An n)*((Bn n)-l2)``; [Symmetry; Apply Rabsolu_mult | Ring]. 
-Unfold Rdiv; Apply Rmult_lt_pos. 
-Assumption. 
-Apply Rlt_Rinv; Apply Rmult_lt_pos; [Sup0 | Apply Rabsolu_pos_lt; Assumption]. 
-Unfold Rdiv; Apply Rmult_lt_pos; [Assumption | Apply Rlt_Rinv; Apply Rmult_lt_pos; [Sup0 | Assumption]]. 
-Apply existTT with l1; Assumption. 
-Qed. 
-
-Lemma tech9 : (Un:nat->R) (Un_growing Un) -> ((m,n:nat)(le m n)->``(Un m)<=(Un n)``).
-Intros; Unfold Un_growing in H.
-Induction n.
-Induction m.
-Right; Reflexivity.
-Elim (le_Sn_O ? H0).
-Cut (le m n)\/m=(S n).
-Intro; Elim H1; Intro.
-Apply Rle_trans with (Un n).
-Apply Hrecn; Assumption.
-Apply H.
-Rewrite H2; Right; Reflexivity.
-Inversion H0.
-Right; Reflexivity.
-Left; Assumption.
-Qed.
-
-Lemma tech10 : (Un:nat->R;x:R) (Un_growing Un) -> (is_lub (EUn Un) x) -> (Un_cv Un x).
-Intros; Cut (bound (EUn Un)).
-Intro; Assert H2 := (Un_cv_crit ? H H1).
-Elim H2; Intros.
-Case (total_order_T x x0); Intro.
-Elim s; Intro.
-Cut (n:nat)``(Un n)<=x``.
-Intro; Unfold Un_cv in H3; Cut ``0<x0-x``.
-Intro; Elim (H3 ``x0-x`` H5); Intros.
-Cut (ge x1 x1).
-Intro; Assert H8 := (H6 x1 H7).
-Unfold R_dist in H8; Rewrite Rabsolu_left1 in H8.
-Rewrite Ropp_distr2 in H8; Unfold Rminus in H8.
-Assert H9 := (Rlt_anti_compatibility ``x0`` ? ? H8).
-Assert H10 := (Ropp_Rlt ? ? H9).
-Assert H11 := (H4 x1).
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H10 H11)).
-Apply Rle_minus; Apply Rle_trans with x.
-Apply H4.
-Left; Assumption.
-Unfold ge; Apply le_n.
-Apply Rgt_minus; Assumption.
-Intro; Unfold is_lub in H0; Unfold is_upper_bound in H0; Elim H0; Intros.
-Apply H4; Unfold EUn; Exists n; Reflexivity.
-Rewrite b; Assumption.
-Cut ((n:nat)``(Un n)<=x0``).
-Intro; Unfold is_lub in H0; Unfold is_upper_bound in H0; Elim H0; Intros.
-Cut (y:R)(EUn Un y)->``y<=x0``.
-Intro; Assert H8 := (H6 ? H7). 
-Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H8 r)).
-Unfold EUn; Intros; Elim H7; Intros.
-Rewrite H8; Apply H4.
-Intro; Case (total_order_Rle (Un n) x0); Intro.
-Assumption.
-Cut (n0:nat)(le n n0) -> ``x0<(Un n0)``. 
-Intro; Unfold Un_cv in H3; Cut ``0<(Un n)-x0``.
-Intro; Elim (H3 ``(Un n)-x0`` H5); Intros.
-Cut (ge (max n x1) x1).
-Intro; Assert H8 := (H6 (max n x1) H7).
-Unfold R_dist in H8.
-Rewrite Rabsolu_right in H8.
-Unfold Rminus in H8; Do 2 Rewrite <- (Rplus_sym ``-x0``) in H8.
-Assert H9 := (Rlt_anti_compatibility ? ? ? H8).
-Cut ``(Un n)<=(Un (max n x1))``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H10 H9)).
-Apply tech9; [Assumption | Apply le_max_l].
-Apply Rge_trans with ``(Un n)-x0``.
-Unfold Rminus; Apply Rle_sym1; Do 2 Rewrite <- (Rplus_sym ``-x0``); Apply Rle_compatibility.
-Apply tech9; [Assumption | Apply le_max_l].
-Left; Assumption.
-Unfold ge; Apply le_max_r.
-Apply Rlt_anti_compatibility with x0.
-Rewrite Rplus_Or; Unfold Rminus; Rewrite (Rplus_sym x0); Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or; Apply H4; Apply le_n.
-Intros; Apply Rlt_le_trans with (Un n).
-Case (total_order_Rlt_Rle x0 (Un n)); Intro.
-Assumption.
-Elim n0; Assumption.
-Apply tech9; Assumption.
-Unfold bound; Exists x; Unfold is_lub in H0; Elim H0; Intros; Assumption.
-Qed.
-
-Lemma tech13 : (An:nat->R;k:R) ``0<=k<1`` -> (Un_cv [n:nat](Rabsolu ``(An (S n))/(An n)``) k) -> (EXT k0 : R | ``k<k0<1`` /\ (EX N:nat | (n:nat) (le N n)->``(Rabsolu ((An (S n))/(An n)))<k0``)).
-Intros; Exists ``k+(1-k)/2``.
-Split.
-Split.
-Pattern 1 k; Rewrite <- Rplus_Or; Apply Rlt_compatibility.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply Rlt_anti_compatibility with k; Rewrite Rplus_Or; Replace ``k+(1-k)`` with R1; [Elim H; Intros; Assumption | Ring].
-Apply Rlt_Rinv; Sup0.
-Apply Rlt_monotony_contra with ``2``.
-Sup0.
-Unfold Rdiv; Rewrite Rmult_1r; Rewrite Rmult_Rplus_distr; Pattern 1 ``2``; Rewrite Rmult_sym; Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym; [Idtac | DiscrR]; Rewrite Rmult_1r; Replace ``2*k+(1-k)`` with ``1+k``; [Idtac | Ring].
-Elim H; Intros.
-Apply Rlt_compatibility; Assumption.
-Unfold Un_cv in H0; Cut ``0<(1-k)/2``.
-Intro; Elim (H0 ``(1-k)/2`` H1); Intros.
-Exists x; Intros.
-Assert H4 := (H2 n H3).
-Unfold R_dist in H4; Rewrite <- Rabsolu_Rabsolu; Replace ``(Rabsolu ((An (S n))/(An n)))`` with ``((Rabsolu ((An (S n))/(An n)))-k)+k``; [Idtac | Ring]; Apply Rle_lt_trans with ``(Rabsolu ((Rabsolu ((An (S n))/(An n)))-k))+(Rabsolu k)``.
-Apply Rabsolu_triang.
-Rewrite (Rabsolu_right k).
-Apply Rlt_anti_compatibility with ``-k``; Rewrite <- (Rplus_sym k); Repeat Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Repeat Rewrite Rplus_Ol; Apply H4.
-Apply Rle_sym1; Elim H; Intros; Assumption.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply Rlt_anti_compatibility with k; Rewrite Rplus_Or; Elim H; Intros; Replace ``k+(1-k)`` with R1; [Assumption | Ring].
-Apply Rlt_Rinv; Sup0.
-Qed.
-
-(**********)
-Lemma growing_ineq : (Un:nat->R;l:R) (Un_growing Un) -> (Un_cv Un l) -> ((n:nat)``(Un n)<=l``). 
-Intros; Case (total_order_T (Un n) l); Intro.
-Elim s; Intro.
-Left; Assumption.
-Right; Assumption.
-Cut ``0<(Un n)-l``.
-Intro; Unfold Un_cv in H0; Unfold R_dist in H0.
-Elim (H0 ``(Un n)-l`` H1); Intros N1 H2.
-Pose N := (max n N1).
-Cut ``(Un n)-l<=(Un N)-l``.
-Intro; Cut ``(Un N)-l<(Un n)-l``.
-Intro; Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H3 H4)).
-Apply Rle_lt_trans with ``(Rabsolu ((Un N)-l))``.
-Apply Rle_Rabsolu.
-Apply H2.
-Unfold ge N; Apply le_max_r.
-Unfold Rminus; Do 2 Rewrite <- (Rplus_sym ``-l``); Apply Rle_compatibility.
-Apply tech9.
-Assumption.
-Unfold N; Apply le_max_l.
-Apply Rlt_anti_compatibility with l.
-Rewrite Rplus_Or.
-Replace ``l+((Un n)-l)`` with (Un n); [Assumption | Ring].
-Qed.
-
-(* Un->l => (-Un) -> (-l) *)
-Lemma CV_opp : (An:nat->R;l:R) (Un_cv An l) -> (Un_cv (opp_seq An) ``-l``).
-Intros An l.
-Unfold Un_cv; Unfold R_dist; Intros.
-Elim (H eps H0); Intros.
-Exists x; Intros.
-Unfold opp_seq; Replace ``-(An n)- (-l)`` with ``-((An n)-l)``; [Rewrite Rabsolu_Ropp | Ring].
-Apply H1; Assumption.
-Qed.
-
-(**********)
-Lemma decreasing_ineq : (Un:nat->R;l:R) (Un_decreasing Un) -> (Un_cv Un l) -> ((n:nat)``l<=(Un n)``).
-Intros.
-Assert H1 := (decreasing_growing ? H).
-Assert H2 := (CV_opp ? ? H0).
-Assert H3 := (growing_ineq ? ? H1 H2).
-Apply Ropp_Rle.
-Unfold opp_seq in H3; Apply H3.
-Qed.
-
-(**********)
-Lemma CV_minus : (An,Bn:nat->R;l1,l2:R) (Un_cv An l1) -> (Un_cv Bn l2) -> (Un_cv [i:nat]``(An i)-(Bn i)`` ``l1-l2``). 
-Intros. 
-Replace [i:nat]``(An i)-(Bn i)`` with [i:nat]``(An i)+((opp_seq Bn) i)``. 
-Unfold Rminus; Apply CV_plus. 
-Assumption. 
-Apply CV_opp; Assumption. 
-Unfold Rminus opp_seq; Reflexivity. 
-Qed. 
-
-(* Un -> +oo *)
-Definition cv_infty [Un:nat->R] : Prop := (M:R)(EXT N:nat | (n:nat) (le N n) -> ``M<(Un n)``).
-
-(* Un -> +oo => /Un -> O *)
-Lemma cv_infty_cv_R0 : (Un:nat->R) ((n:nat)``(Un n)<>0``) -> (cv_infty Un) -> (Un_cv [n:nat]``/(Un n)`` R0).
-Unfold cv_infty Un_cv; Unfold R_dist; Intros.
-Elim (H0 ``/eps``); Intros N0 H2.
-Exists N0; Intros.
-Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite (Rabsolu_Rinv ? (H n)).
-Apply Rlt_monotony_contra with (Rabsolu (Un n)).
-Apply Rabsolu_pos_lt; Apply H.
-Rewrite <- Rinv_r_sym.
-Apply Rlt_monotony_contra with ``/eps``.
-Apply Rlt_Rinv; Assumption.
-Rewrite Rmult_1r; Rewrite (Rmult_sym ``/eps``); Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Apply Rlt_le_trans with (Un n).
-Apply H2; Assumption.
-Apply Rle_Rabsolu.
-Red; Intro; Rewrite H4 in H1; Elim (Rlt_antirefl ? H1).
-Apply Rabsolu_no_R0; Apply H.
-Qed.
-
-(**********)
-Lemma decreasing_prop : (Un:nat->R;m,n:nat) (Un_decreasing Un) -> (le m n) -> ``(Un n)<=(Un m)``.
-Unfold Un_decreasing; Intros.
-Induction n.
-Induction m.
-Right; Reflexivity.
-Elim (le_Sn_O ? H0).
-Cut (le m n)\/m=(S n).
-Intro; Elim H1; Intro.
-Apply Rle_trans with (Un n).
-Apply H.
-Apply Hrecn; Assumption.
-Rewrite H2; Right; Reflexivity.
-Inversion H0; [Right; Reflexivity | Left; Assumption].
-Qed.
-
-(* |x|^n/n! -> 0 *)
-Lemma cv_speed_pow_fact : (x:R) (Un_cv [n:nat]``(pow x n)/(INR (fact n))`` R0).
-Intro; Cut (Un_cv [n:nat]``(pow (Rabsolu x) n)/(INR (fact n))`` R0) -> (Un_cv [n:nat]``(pow x n)/(INR (fact n))`` ``0``).
-Intro; Apply H.
-Unfold Un_cv; Unfold R_dist; Intros; Case (Req_EM x R0); Intro.
-Exists (S O); Intros.
-Rewrite H1; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite Rabsolu_R0; Rewrite pow_ne_zero; [Unfold Rdiv; Rewrite Rmult_Ol; Rewrite Rabsolu_R0; Assumption | Red; Intro; Rewrite H3 in H2; Elim (le_Sn_n ? H2)].
-Assert H2 := (Rabsolu_pos_lt x H1); Pose M := (up (Rabsolu x)); Cut `0<=M`.
-Intro; Elim (IZN M H3); Intros M_nat H4.
-Pose Un := [n:nat]``(pow (Rabsolu x) (plus M_nat n))/(INR (fact (plus M_nat n)))``.
-Cut (Un_cv Un R0); Unfold Un_cv; Unfold R_dist; Intros.
-Elim (H5 eps H0); Intros N H6.
-Exists (plus M_nat N); Intros; Cut (EX p:nat | (ge p N)/\n=(plus M_nat p)).
-Intro; Elim H8; Intros p H9.
-Elim H9; Intros; Rewrite H11; Unfold Un in H6; Apply H6; Assumption.
-Exists (minus n M_nat).
-Split.
-Unfold ge; Apply simpl_le_plus_l with M_nat; Rewrite <- le_plus_minus.
-Assumption.
-Apply le_trans with (plus M_nat N).
-Apply le_plus_l.
-Assumption.
-Apply le_plus_minus; Apply le_trans with (plus M_nat N); [Apply le_plus_l | Assumption].
-Pose Vn := [n:nat]``(Rabsolu x)*(Un O)/(INR (S n))``.
-Cut (le (1) M_nat).
-Intro; Cut (n:nat)``0<(Un n)``.
-Intro; Cut (Un_decreasing Un).
-Intro; Cut (n:nat)``(Un (S n))<=(Vn n)``.
-Intro; Cut (Un_cv Vn R0).
-Unfold Un_cv; Unfold R_dist; Intros.
-Elim (H10 eps0 H5); Intros N1 H11.
-Exists (S N1); Intros.
-Cut (n:nat)``0<(Vn n)``.
-Intro; Apply Rle_lt_trans with ``(Rabsolu ((Vn (pred n))-0))``.
-Repeat Rewrite Rabsolu_right.
-Unfold Rminus; Rewrite Ropp_O; Do 2 Rewrite Rplus_Or; Replace n with (S (pred n)).
-Apply H9.
-Inversion H12; Simpl; Reflexivity.
-Apply Rle_sym1; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Left; Apply H13.
-Apply Rle_sym1; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Left; Apply H7.
-Apply H11; Unfold ge; Apply le_S_n; Replace (S (pred n)) with n; [Unfold ge in H12; Exact H12 | Inversion H12; Simpl; Reflexivity].
-Intro; Apply Rlt_le_trans with (Un (S n0)); [Apply H7 | Apply H9].
-Cut (cv_infty [n:nat](INR (S n))).
-Intro; Cut (Un_cv [n:nat]``/(INR (S n))`` R0).
-Unfold Un_cv R_dist; Intros; Unfold Vn.
-Cut ``0<eps1/((Rabsolu x)*(Un O))``.
-Intro; Elim (H11 ? H13); Intros N H14.
-Exists N; Intros; Replace ``(Rabsolu x)*(Un O)/(INR (S n))-0`` with ``((Rabsolu x)*(Un O))*(/(INR (S n))-0)``; [Idtac | Unfold Rdiv; Ring].
-Rewrite Rabsolu_mult; Apply Rlt_monotony_contra with ``/(Rabsolu ((Rabsolu x)*(Un O)))``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt.
-Apply prod_neq_R0.
-Apply Rabsolu_no_R0; Assumption.
-Assert H16 := (H7 O); Red; Intro; Rewrite H17 in H16; Elim (Rlt_antirefl ? H16).
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l.
-Replace ``/(Rabsolu ((Rabsolu x)*(Un O)))*eps1`` with ``eps1/((Rabsolu x)*(Un O))``.
-Apply H14; Assumption.
-Unfold Rdiv; Rewrite (Rabsolu_right ``(Rabsolu x)*(Un O)``).
-Apply Rmult_sym.
-Apply Rle_sym1; Apply Rmult_le_pos.
-Apply Rabsolu_pos.
-Left; Apply H7.
-Apply Rabsolu_no_R0.
-Apply prod_neq_R0; [Apply Rabsolu_no_R0; Assumption | Assert H16 := (H7 O); Red; Intro; Rewrite H17 in H16; Elim (Rlt_antirefl ? H16)].
-Unfold Rdiv; Apply Rmult_lt_pos.
-Assumption.
-Apply Rlt_Rinv; Apply Rmult_lt_pos.
-Apply Rabsolu_pos_lt; Assumption.
-Apply H7.
-Apply (cv_infty_cv_R0 [n:nat]``(INR (S n))``).
-Intro; Apply not_O_INR; Discriminate.
-Assumption.
-Unfold cv_infty; Intro; Case (total_order_T M0 R0); Intro.
-Elim s; Intro.
-Exists O; Intros.
-Apply Rlt_trans with R0; [Assumption | Apply lt_INR_0; Apply lt_O_Sn].
-Exists O; Intros; Rewrite b; Apply lt_INR_0; Apply lt_O_Sn.
-Pose M0_z := (up M0).
-Assert H10 := (archimed M0).
-Cut `0<=M0_z`.
-Intro; Elim (IZN ? H11); Intros M0_nat H12.
-Exists M0_nat; Intros.
-Apply Rlt_le_trans with (IZR M0_z).
-Elim H10; Intros; Assumption.
-Rewrite H12; Rewrite <- INR_IZR_INZ; Apply le_INR.
-Apply le_trans with n; [Assumption | Apply le_n_Sn].
-Apply le_IZR; Left; Simpl; Unfold M0_z; Apply Rlt_trans with M0; [Assumption | Elim H10; Intros; Assumption].
-Intro; Apply Rle_trans with ``(Rabsolu x)*(Un n)*/(INR (S n))``.
-Unfold Un; Replace (plus M_nat (S n)) with (plus (plus M_nat n) (1)).
-Rewrite pow_add; Replace (pow (Rabsolu x) (S O)) with (Rabsolu x); [Idtac | Simpl; Ring].
-Unfold Rdiv; Rewrite <- (Rmult_sym (Rabsolu x)); Repeat Rewrite Rmult_assoc; Repeat Apply Rle_monotony.
-Apply Rabsolu_pos.
-Left; Apply pow_lt; Assumption.
-Replace (plus (plus M_nat n) (S O)) with (S (plus M_nat n)).
-Rewrite fact_simpl; Rewrite mult_sym; Rewrite mult_INR; Rewrite Rinv_Rmult.
-Apply Rle_monotony.
-Left; Apply Rlt_Rinv; Apply lt_INR_0; Apply neq_O_lt; Red; Intro; Assert H10 := (sym_eq ? ? ? H9); Elim (fact_neq_0 ? H10).
-Left; Apply Rinv_lt.
-Apply Rmult_lt_pos; Apply lt_INR_0; Apply lt_O_Sn.
-Apply lt_INR; Apply lt_n_S.
-Pattern 1 n; Replace n with (plus O n); [Idtac | Reflexivity].
-Apply lt_reg_r.
-Apply lt_le_trans with (S O); [Apply lt_O_Sn | Assumption].
-Apply INR_fact_neq_0.
-Apply not_O_INR; Discriminate.
-Apply INR_eq; Rewrite S_INR; Do 3 Rewrite plus_INR; Reflexivity.
-Apply INR_eq; Do 3 Rewrite plus_INR; Do 2 Rewrite S_INR; Ring.
-Unfold Vn; Rewrite Rmult_assoc; Unfold Rdiv; Rewrite (Rmult_sym (Un O)); Rewrite (Rmult_sym (Un n)).
-Repeat Apply Rle_monotony.
-Apply Rabsolu_pos.
-Left; Apply Rlt_Rinv; Apply lt_INR_0; Apply lt_O_Sn.
-Apply decreasing_prop; [Assumption | Apply le_O_n].
-Unfold Un_decreasing; Intro; Unfold Un.
-Replace (plus M_nat (S n)) with (plus (plus M_nat n) (1)).
-Rewrite pow_add; Unfold Rdiv; Rewrite Rmult_assoc; Apply Rle_monotony.
-Left; Apply pow_lt; Assumption.
-Replace (pow (Rabsolu x) (S O)) with (Rabsolu x); [Idtac | Simpl; Ring].
-Replace (plus (plus M_nat n) (S O)) with (S (plus M_nat n)).
-Apply Rle_monotony_contra with (INR (fact (S (plus M_nat n)))).
-Apply lt_INR_0; Apply neq_O_lt; Red; Intro; Assert H9 := (sym_eq ? ? ? H8); Elim (fact_neq_0 ? H9).
-Rewrite (Rmult_sym (Rabsolu x)); Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l.
-Rewrite fact_simpl; Rewrite mult_INR; Rewrite Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1r; Apply Rle_trans with (INR M_nat).
-Left; Rewrite INR_IZR_INZ.
-Rewrite <- H4; Assert H8 := (archimed (Rabsolu x)); Elim H8; Intros; Assumption.
-Apply le_INR; Apply le_trans with (S M_nat); [Apply le_n_Sn | Apply le_n_S; Apply le_plus_l].
-Apply INR_fact_neq_0.
-Apply INR_fact_neq_0.
-Apply INR_eq; Rewrite S_INR; Do 3 Rewrite plus_INR; Reflexivity.
-Apply INR_eq; Do 3 Rewrite plus_INR; Do 2 Rewrite S_INR; Ring.
-Intro; Unfold Un; Unfold Rdiv; Apply Rmult_lt_pos.
-Apply pow_lt; Assumption.
-Apply Rlt_Rinv; Apply lt_INR_0; Apply neq_O_lt; Red; Intro; Assert H8 := (sym_eq ? ? ? H7); Elim (fact_neq_0 ? H8).
-Clear Un Vn; Apply INR_le; Simpl.
-Induction M_nat.
-Assert H6 := (archimed (Rabsolu x)); Fold M in H6; Elim H6; Intros. 
-Rewrite H4 in H7; Rewrite <- INR_IZR_INZ in H7.
-Simpl in H7; Elim (Rlt_antirefl ? (Rlt_trans ? ? ? H2 H7)).
-Replace R1 with (INR (S O)); [Apply le_INR | Reflexivity]; Apply le_n_S; Apply le_O_n.
-Apply le_IZR; Simpl; Left; Apply Rlt_trans with (Rabsolu x).
-Assumption.
-Elim (archimed (Rabsolu x)); Intros; Assumption.
-Unfold Un_cv; Unfold R_dist; Intros; Elim (H eps H0); Intros.
-Exists x0; Intros; Apply Rle_lt_trans with ``(Rabsolu ((pow (Rabsolu x) n)/(INR (fact n))-0))``.
-Unfold Rminus; Rewrite Ropp_O; Do 2 Rewrite Rplus_Or; Rewrite (Rabsolu_right ``(pow (Rabsolu x) n)/(INR (fact n))``).
-Unfold Rdiv; Rewrite Rabsolu_mult; Rewrite (Rabsolu_right ``/(INR (fact n))``).
-Rewrite Pow_Rabsolu; Right; Reflexivity.
-Apply Rle_sym1; Left; Apply Rlt_Rinv; Apply lt_INR_0; Apply neq_O_lt; Red; Intro; Assert H4 := (sym_eq ? ? ? H3); Elim (fact_neq_0 ? H4).
-Apply Rle_sym1; Unfold Rdiv; Apply Rmult_le_pos.
-Case (Req_EM x R0); Intro.
-Rewrite H3; Rewrite Rabsolu_R0.
-Induction n; [Simpl; Left; Apply Rlt_R0_R1 | Simpl; Rewrite Rmult_Ol; Right; Reflexivity].
-Left; Apply pow_lt; Apply Rabsolu_pos_lt; Assumption.
-Left; Apply Rlt_Rinv; Apply lt_INR_0; Apply neq_O_lt; Red; Intro; Assert H4 := (sym_eq ? ? ? H3); Elim (fact_neq_0 ? H4).
-Apply H1; Assumption.
-Qed.
diff --git a/theories7/Reals/SeqSeries.v b/theories7/Reals/SeqSeries.v
deleted file mode 100644
index dd93c304..00000000
--- a/theories7/Reals/SeqSeries.v
+++ /dev/null
@@ -1,307 +0,0 @@
-(************************************************************************)
-(*  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: SeqSeries.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Max.
-Require Export Rseries.
-Require Export SeqProp.
-Require Export Rcomplete.
-Require Export PartSum.
-Require Export AltSeries.
-Require Export Binomial.
-Require Export Rsigma.
-Require Export Rprod.
-Require Export Cauchy_prod.
-Require Export Alembert.
-V7only [ Import nat_scope. Import Z_scope. Import R_scope. ].
-Open Local Scope R_scope.
-
-(**********)
-Lemma sum_maj1 : (fn:nat->R->R;An:nat->R;x,l1,l2:R;N:nat) (Un_cv [n:nat](SP fn n x) l1) -> (Un_cv [n:nat](sum_f_R0 An n) l2) -> ((n:nat)``(Rabsolu (fn n x))<=(An n)``) -> ``(Rabsolu (l1-(SP fn N x)))<=l2-(sum_f_R0 An N)``.
-Intros; Cut (sigTT R [l:R](Un_cv [n:nat](sum_f_R0 [l:nat](fn (plus (S N) l) x) n) l)).
-Intro; Cut (sigTT R [l:R](Un_cv [n:nat](sum_f_R0 [l:nat](An (plus (S N) l)) n) l)).
-Intro; Elim X; Intros l1N H2.
-Elim X0; Intros l2N H3.
-Cut ``l1-(SP fn N x)==l1N``.
-Intro; Cut ``l2-(sum_f_R0 An N)==l2N``.
-Intro; Rewrite H4; Rewrite H5.
-Apply sum_cv_maj with [l:nat](An (plus (S N) l)) [l:nat][x:R](fn (plus (S N) l) x) x.
-Unfold SP; Apply H2.
-Apply H3.
-Intros; Apply H1.
-Symmetry; EApply UL_sequence.
-Apply H3.
-Unfold Un_cv in H0; Unfold Un_cv; Intros; Elim (H0 eps H5); Intros N0 H6.
-Unfold R_dist in H6; Exists N0; Intros.
-Unfold R_dist; Replace (Rminus (sum_f_R0 [l:nat](An (plus (S N) l)) n) (Rminus l2 (sum_f_R0 An N))) with (Rminus (Rplus (sum_f_R0 An N) (sum_f_R0 [l:nat](An (plus (S N) l)) n)) l2); [Idtac | Ring].
-Replace (Rplus (sum_f_R0 An N) (sum_f_R0 [l:nat](An (plus (S N) l)) n)) with (sum_f_R0 An (S (plus N n))).
-Apply H6; Unfold ge; Apply le_trans with n.
-Apply H7.
-Apply le_trans with (plus N n).
-Apply le_plus_r.
-Apply le_n_Sn.
-Cut (le O N).
-Cut (lt N (S (plus N n))).
-Intros; Assert H10 := (sigma_split An H9 H8).
-Unfold sigma in H10.
-Do 2 Rewrite <- minus_n_O in H10.
-Replace (sum_f_R0 An (S (plus N n))) with (sum_f_R0 [k:nat](An (plus (0) k)) (S (plus N n))).
-Replace (sum_f_R0 An N) with (sum_f_R0 [k:nat](An (plus (0) k)) N).
-Cut (minus (S (plus N n)) (S N))=n.
-Intro; Rewrite H11 in H10.
-Apply H10.
-Apply INR_eq; Rewrite minus_INR.
-Do 2 Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_n_S; Apply le_plus_l.
-Apply sum_eq; Intros.
-Reflexivity.
-Apply sum_eq; Intros.
-Reflexivity.
-Apply le_lt_n_Sm; Apply le_plus_l.
-Apply le_O_n.
-Symmetry; EApply UL_sequence.
-Apply H2.
-Unfold Un_cv in H; Unfold Un_cv; Intros.
-Elim (H eps H4); Intros N0 H5.
-Unfold R_dist in H5; Exists N0; Intros.
-Unfold R_dist SP; Replace (Rminus (sum_f_R0 [l:nat](fn (plus (S N) l) x) n) (Rminus l1 (sum_f_R0 [k:nat](fn k x) N))) with (Rminus (Rplus (sum_f_R0 [k:nat](fn k x) N) (sum_f_R0 [l:nat](fn (plus (S N) l) x) n)) l1); [Idtac | Ring].
-Replace (Rplus (sum_f_R0 [k:nat](fn k x) N) (sum_f_R0 [l:nat](fn (plus (S N) l) x) n)) with (sum_f_R0 [k:nat](fn k x) (S (plus N n))).
-Unfold SP in H5; Apply H5; Unfold ge; Apply le_trans with n.
-Apply H6.
-Apply le_trans with (plus N n).
-Apply le_plus_r.
-Apply le_n_Sn.
-Cut (le O N).
-Cut (lt N (S (plus N n))).
-Intros; Assert H9 := (sigma_split [k:nat](fn k x) H8 H7).
-Unfold sigma in H9.
-Do 2 Rewrite <- minus_n_O in H9.
-Replace (sum_f_R0 [k:nat](fn k x) (S (plus N n))) with (sum_f_R0 [k:nat](fn (plus (0) k) x) (S (plus N n))).
-Replace (sum_f_R0 [k:nat](fn k x) N) with (sum_f_R0 [k:nat](fn (plus (0) k) x) N).
-Cut (minus (S (plus N n)) (S N))=n.
-Intro; Rewrite H10 in H9.
-Apply H9.
-Apply INR_eq; Rewrite minus_INR.
-Do 2 Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_n_S; Apply le_plus_l.
-Apply sum_eq; Intros.
-Reflexivity.
-Apply sum_eq; Intros.
-Reflexivity.
-Apply le_lt_n_Sm.
-Apply le_plus_l.
-Apply le_O_n.
-Apply existTT with ``l2-(sum_f_R0 An N)``.
-Unfold Un_cv in H0; Unfold Un_cv; Intros.
-Elim (H0 eps H2); Intros N0 H3.
-Unfold R_dist in H3; Exists N0; Intros.
-Unfold R_dist; Replace (Rminus (sum_f_R0 [l:nat](An (plus (S N) l)) n) (Rminus l2 (sum_f_R0 An N))) with (Rminus (Rplus (sum_f_R0 An N) (sum_f_R0 [l:nat](An (plus (S N) l)) n)) l2); [Idtac | Ring].
-Replace (Rplus (sum_f_R0 An N) (sum_f_R0 [l:nat](An (plus (S N) l)) n)) with (sum_f_R0 An (S (plus N n))).
-Apply H3; Unfold ge; Apply le_trans with n.
-Apply H4.
-Apply le_trans with (plus N n).
-Apply le_plus_r.
-Apply le_n_Sn.
-Cut (le O N).
-Cut (lt N (S (plus N n))).
-Intros; Assert H7 := (sigma_split An H6 H5).
-Unfold sigma in H7.
-Do 2 Rewrite <- minus_n_O in H7.
-Replace (sum_f_R0 An (S (plus N n))) with (sum_f_R0 [k:nat](An (plus (0) k)) (S (plus N n))).
-Replace (sum_f_R0 An N) with (sum_f_R0 [k:nat](An (plus (0) k)) N).
-Cut (minus (S (plus N n)) (S N))=n.
-Intro; Rewrite H8 in H7.
-Apply H7.
-Apply INR_eq; Rewrite minus_INR.
-Do 2 Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_n_S; Apply le_plus_l.
-Apply sum_eq; Intros.
-Reflexivity.
-Apply sum_eq; Intros.
-Reflexivity.
-Apply le_lt_n_Sm.
-Apply le_plus_l.
-Apply le_O_n.
-Apply existTT with ``l1-(SP fn N x)``.
-Unfold Un_cv in H; Unfold Un_cv; Intros.
-Elim (H eps H2); Intros N0 H3.
-Unfold R_dist in H3; Exists N0; Intros.
-Unfold R_dist SP.
-Replace (Rminus (sum_f_R0 [l:nat](fn (plus (S N) l) x) n) (Rminus l1 (sum_f_R0 [k:nat](fn k x) N))) with (Rminus (Rplus (sum_f_R0 [k:nat](fn k x) N) (sum_f_R0 [l:nat](fn (plus (S N) l) x) n)) l1); [Idtac | Ring].
-Replace (Rplus (sum_f_R0 [k:nat](fn k x) N) (sum_f_R0 [l:nat](fn (plus (S N) l) x) n)) with (sum_f_R0 [k:nat](fn k x) (S (plus N n))).
-Unfold SP in H3; Apply H3.
-Unfold ge; Apply le_trans with n.
-Apply H4.
-Apply le_trans with (plus N n).
-Apply le_plus_r.
-Apply le_n_Sn.
-Cut (le O N).
-Cut (lt N (S (plus N n))).
-Intros; Assert H7 := (sigma_split [k:nat](fn k x) H6 H5).
-Unfold sigma in H7.
-Do 2 Rewrite <- minus_n_O in H7.
-Replace (sum_f_R0 [k:nat](fn k x) (S (plus N n))) with (sum_f_R0 [k:nat](fn (plus (0) k) x) (S (plus N n))).
-Replace (sum_f_R0 [k:nat](fn k x) N) with (sum_f_R0 [k:nat](fn (plus (0) k) x) N).
-Cut (minus (S (plus N n)) (S N))=n.
-Intro; Rewrite H8 in H7.
-Apply H7.
-Apply INR_eq; Rewrite minus_INR.
-Do 2 Rewrite S_INR; Rewrite plus_INR; Ring.
-Apply le_n_S; Apply le_plus_l.
-Apply sum_eq; Intros.
-Reflexivity.
-Apply sum_eq; Intros.
-Reflexivity.
-Apply le_lt_n_Sm.
-Apply le_plus_l.
-Apply le_O_n.
-Qed.
-
-(* Comparaison of convergence for series *)
-Lemma Rseries_CV_comp : (An,Bn:nat->R) ((n:nat)``0<=(An n)<=(Bn n)``) -> (sigTT ? [l:R](Un_cv [N:nat](sum_f_R0 Bn N) l)) -> (sigTT ? [l:R](Un_cv [N:nat](sum_f_R0 An N) l)).
-Intros; Apply cv_cauchy_2.
-Assert H0 := (cv_cauchy_1 ? X).
-Unfold Cauchy_crit_series; Unfold Cauchy_crit.
-Intros; Elim (H0 eps H1); Intros.
-Exists x; Intros.
-Cut (Rle (R_dist (sum_f_R0 An n) (sum_f_R0 An m)) (R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m))).
-Intro; Apply Rle_lt_trans with (R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
-Assumption.
-Apply H2; Assumption.
-Assert H5 := (lt_eq_lt_dec n m).
-Elim H5; Intro.
-Elim a; Intro.
-Rewrite (tech2 An n m); [Idtac | Assumption].
-Rewrite (tech2 Bn n m); [Idtac | Assumption].
-Unfold R_dist; Unfold Rminus; Do 2 Rewrite Ropp_distr1; Do 2 Rewrite <- Rplus_assoc; Do 2 Rewrite Rplus_Ropp_r; Do 2 Rewrite Rplus_Ol; Do 2 Rewrite Rabsolu_Ropp; Repeat Rewrite Rabsolu_right.
-Apply sum_Rle; Intros.
-Elim (H (plus (S n) n0)); Intros.
-Apply H8.
-Apply Rle_sym1; Apply cond_pos_sum; Intro.
-Elim (H (plus (S n) n0)); Intros.
-Apply Rle_trans with (An (plus (S n) n0)); Assumption.
-Apply Rle_sym1; Apply cond_pos_sum; Intro.
-Elim (H (plus (S n) n0)); Intros; Assumption.
-Rewrite b; Unfold R_dist; Unfold Rminus; Do 2 Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0; Right; Reflexivity.
-Rewrite (tech2 An m n); [Idtac | Assumption].
-Rewrite (tech2 Bn m n); [Idtac | Assumption].
-Unfold R_dist; Unfold Rminus; Do 2 Rewrite Rplus_assoc; Rewrite (Rplus_sym (sum_f_R0 An m)); Rewrite (Rplus_sym (sum_f_R0 Bn m)); Do 2 Rewrite Rplus_assoc; Do 2 Rewrite Rplus_Ropp_l; Do 2 Rewrite Rplus_Or; Repeat Rewrite Rabsolu_right.
-Apply sum_Rle; Intros.
-Elim (H (plus (S m) n0)); Intros; Apply H8.
-Apply Rle_sym1; Apply cond_pos_sum; Intro.
-Elim (H (plus (S m) n0)); Intros.
-Apply Rle_trans with (An (plus (S m) n0)); Assumption.
-Apply Rle_sym1.
-Apply cond_pos_sum; Intro.
-Elim (H (plus (S m) n0)); Intros; Assumption.
-Qed.
-
-(* Cesaro's theorem *)
-Lemma Cesaro : (An,Bn:nat->R;l:R) (Un_cv Bn l) -> ((n:nat)``0<(An n)``) -> (cv_infty [n:nat](sum_f_R0 An n)) -> (Un_cv [n:nat](Rdiv (sum_f_R0 [k:nat]``(An k)*(Bn k)`` n) (sum_f_R0 An n)) l).
-Proof with Trivial.
-Unfold Un_cv; Intros; Assert H3 : (n:nat)``0<(sum_f_R0 An n)``.
-Intro; Apply tech1.
-Assert H4 : (n:nat) ``(sum_f_R0 An n)<>0``.
-Intro; Red; Intro; Assert H5 := (H3 n); Rewrite H4 in H5; Elim (Rlt_antirefl ? H5).
-Assert H5 := (cv_infty_cv_R0 ? H4 H1); Assert H6 : ``0<eps/2``.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply Rlt_Rinv; Sup.
-Elim (H ? H6); Clear H; Intros N1 H; Pose C := (Rabsolu (sum_f_R0 [k:nat]``(An k)*((Bn k)-l)`` N1)); Assert H7 : (EX N:nat | (n:nat) (le N n) -> ``C/(sum_f_R0 An n)<eps/2``).
-Case (Req_EM C R0); Intro.
-Exists O; Intros.
-Rewrite H7; Unfold Rdiv; Rewrite Rmult_Ol; Apply Rmult_lt_pos.
-Apply Rlt_Rinv; Sup.
-Assert H8 : ``0<eps/(2*(Rabsolu C))``.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply Rlt_Rinv; Apply Rmult_lt_pos.
-Sup.
-Apply Rabsolu_pos_lt.
-Elim (H5 ? H8); Intros; Exists x; Intros; Assert H11 := (H9 ? H10); Unfold R_dist in H11; Unfold Rminus in H11; Rewrite Ropp_O in H11; Rewrite Rplus_Or in H11.
-Apply Rle_lt_trans with (Rabsolu ``C/(sum_f_R0 An n)``).
-Apply Rle_Rabsolu.
-Unfold Rdiv; Rewrite Rabsolu_mult; Apply Rlt_monotony_contra with ``/(Rabsolu C)``.
-Apply Rlt_Rinv; Apply Rabsolu_pos_lt.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Replace ``/(Rabsolu C)*(eps*/2)`` with ``eps/(2*(Rabsolu C))``.
-Unfold Rdiv; Rewrite Rinv_Rmult.
-Ring.
-DiscrR.
-Apply Rabsolu_no_R0.
-Apply Rabsolu_no_R0.
-Elim H7; Clear H7; Intros N2 H7; Pose N := (max N1 N2); Exists (S N); Intros; Unfold R_dist; Replace (Rminus (Rdiv (sum_f_R0 [k:nat]``(An k)*(Bn k)`` n) (sum_f_R0 An n)) l) with (Rdiv (sum_f_R0 [k:nat]``(An k)*((Bn k)-l)`` n) (sum_f_R0 An n)).
-Assert H9 : (lt N1 n).
-Apply lt_le_trans with (S N).
-Apply le_lt_n_Sm; Unfold N; Apply le_max_l.
-Rewrite (tech2 [k:nat]``(An k)*((Bn k)-l)`` ? ? H9); Unfold Rdiv; Rewrite Rmult_Rplus_distrl; Apply Rle_lt_trans with (Rplus (Rabsolu (Rdiv (sum_f_R0 [k:nat]``(An k)*((Bn k)-l)`` N1) (sum_f_R0 An n))) (Rabsolu (Rdiv (sum_f_R0 [i:nat]``(An (plus (S N1) i))*((Bn (plus (S N1) i))-l)`` (minus n (S N1))) (sum_f_R0 An n)))).
-Apply Rabsolu_triang.
-Rewrite (double_var eps); Apply Rplus_lt.
-Unfold Rdiv; Rewrite Rabsolu_mult; Fold C; Rewrite Rabsolu_right.
-Apply (H7 n); Apply le_trans with (S N).
-Apply le_trans with N; [Unfold N; Apply le_max_r | Apply le_n_Sn].
-Apply Rle_sym1; Left; Apply Rlt_Rinv.
-
-Unfold R_dist in H; Unfold Rdiv; Rewrite Rabsolu_mult; Rewrite (Rabsolu_right ``/(sum_f_R0 An n)``).
-Apply Rle_lt_trans with (Rmult (sum_f_R0 [i:nat](Rabsolu ``(An (plus (S N1) i))*((Bn (plus (S N1) i))-l)``) (minus n (S N1))) ``/(sum_f_R0 An n)``).
-Do 2 Rewrite <- (Rmult_sym ``/(sum_f_R0 An n)``); Apply Rle_monotony.
-Left; Apply Rlt_Rinv.
-Apply (sum_Rabsolu [i:nat]``(An (plus (S N1) i))*((Bn (plus (S N1) i))-l)`` (minus n (S N1))).
-Apply Rle_lt_trans with (Rmult (sum_f_R0 [i:nat]``(An (plus (S N1) i))*eps/2`` (minus n (S N1))) ``/(sum_f_R0 An n)``).
-Do 2 Rewrite <- (Rmult_sym ``/(sum_f_R0 An n)``); Apply Rle_monotony.
-Left; Apply Rlt_Rinv.
-Apply sum_Rle; Intros; Rewrite Rabsolu_mult; Pattern 2 (An (plus (S N1) n0)); Rewrite <- (Rabsolu_right (An (plus (S N1) n0))).
-Apply Rle_monotony.
-Apply Rabsolu_pos.
-Left; Apply H; Unfold ge; Apply le_trans with (S N1); [Apply le_n_Sn | Apply le_plus_l].
-Apply Rle_sym1; Left.
-Rewrite <- (scal_sum [i:nat](An (plus (S N1) i)) (minus n (S N1)) ``eps/2``); Unfold Rdiv; Repeat Rewrite Rmult_assoc; Apply Rlt_monotony.
-Pattern 2 ``/2``; Rewrite <- Rmult_1r; Apply Rlt_monotony.
-Apply Rlt_Rinv; Sup.
-Rewrite Rmult_sym; Apply Rlt_monotony_contra with (sum_f_R0 An n).
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite Rmult_1r; Rewrite (tech2 An N1 n).
-Rewrite Rplus_sym; Pattern 1 (sum_f_R0 [i:nat](An (plus (S N1) i)) (minus n (S N1))); Rewrite <- Rplus_Or; Apply Rlt_compatibility.
-Apply Rle_sym1; Left; Apply Rlt_Rinv.
-Replace (sum_f_R0 [k:nat]``(An k)*((Bn k)-l)`` n) with (Rplus (sum_f_R0 [k:nat]``(An k)*(Bn k)`` n) (sum_f_R0 [k:nat]``(An k)*-l`` n)).
-Rewrite <- (scal_sum An n ``-l``); Field.
-Rewrite <- plus_sum; Apply sum_eq; Intros; Ring.
-Qed.
-
-Lemma Cesaro_1 : (An:nat->R;l:R) (Un_cv An l) -> (Un_cv [n:nat]``(sum_f_R0 An (pred n))/(INR n)`` l).
-Proof with Trivial.
-Intros Bn l H; Pose An := [_:nat]R1.
-Assert H0 : (n:nat) ``0<(An n)``.
-Intro; Unfold An; Apply Rlt_R0_R1.
-Assert H1 : (n:nat)``0<(sum_f_R0 An n)``.
-Intro; Apply tech1.
-Assert H2 : (cv_infty [n:nat](sum_f_R0 An n)).
-Unfold cv_infty; Intro; Case (total_order_Rle M R0); Intro.
-Exists O; Intros; Apply Rle_lt_trans with R0.
-Assert H2 : ``0<M``.
-Auto with real.
-Clear n; Pose m := (up M); Elim (archimed M); Intros; Assert H5 : `0<=m`.
-Apply le_IZR; Unfold m; Simpl; Left; Apply Rlt_trans with M.
-Elim (IZN ? H5); Intros; Exists x; Intros; Unfold An; Rewrite sum_cte; Rewrite Rmult_1l; Apply Rlt_trans with (IZR (up M)).
-Apply Rle_lt_trans with (INR x).
-Rewrite INR_IZR_INZ; Fold m; Rewrite <- H6; Right.
-Apply lt_INR; Apply le_lt_n_Sm.
-Assert H3 := (Cesaro ? ? ? H H0 H2).
-Unfold Un_cv; Unfold Un_cv in H3; Intros; Elim (H3 ? H4); Intros; Exists (S x); Intros; Unfold R_dist; Unfold R_dist in H5; Apply Rle_lt_trans with (Rabsolu (Rminus (Rdiv (sum_f_R0 [k:nat]``(An k)*(Bn k)`` (pred n)) (sum_f_R0 An (pred n))) l)).
-Right; Replace ``(sum_f_R0 Bn (pred n))/(INR n)-l`` with (Rminus (Rdiv (sum_f_R0 [k:nat]``(An k)*(Bn k)`` (pred n)) (sum_f_R0 An (pred n))) l).
-Unfold Rminus; Do 2 Rewrite <- (Rplus_sym ``-l``); Apply Rplus_plus_r.
-Unfold An; Replace (sum_f_R0 [k:nat]``1*(Bn k)`` (pred n)) with (sum_f_R0 Bn (pred n)).
-Rewrite sum_cte; Rewrite Rmult_1l; Replace (S (pred n)) with n.
-Apply S_pred with O; Apply lt_le_trans with (S x).
-Apply lt_O_Sn.
-Apply sum_eq; Intros; Ring.
-Apply H5; Unfold ge; Apply le_S_n; Replace (S (pred n)) with n.
-Apply S_pred with O; Apply lt_le_trans with (S x).
-Apply lt_O_Sn.
-Qed.
diff --git a/theories7/Reals/Sqrt_reg.v b/theories7/Reals/Sqrt_reg.v
deleted file mode 100644
index d2068e5d..00000000
--- a/theories7/Reals/Sqrt_reg.v
+++ /dev/null
@@ -1,297 +0,0 @@
-(************************************************************************)
-(*  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: Sqrt_reg.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
-
-Require Rbase.
-Require Rfunctions.
-Require Ranalysis1.
-Require R_sqrt.
-V7only [Import R_scope.]. Open Local Scope R_scope.
-
-(**********)
-Lemma sqrt_var_maj : (h:R) ``(Rabsolu h) <= 1`` -> ``(Rabsolu ((sqrt (1+h))-1))<=(Rabsolu h)``.
-Intros; Cut ``0<=1+h``.
-Intro; Apply Rle_trans with ``(Rabsolu ((sqrt (Rsqr (1+h)))-1))``.
-Case (total_order_T h R0); Intro.
-Elim s; Intro.
-Repeat Rewrite Rabsolu_left.
-Unfold Rminus; Do 2 Rewrite <- (Rplus_sym ``-1``).
-Do 2 Rewrite Ropp_distr1;Rewrite Ropp_Ropp; Apply Rle_compatibility.
-Apply Rle_Ropp1; Apply sqrt_le_1.
-Apply pos_Rsqr.
-Apply H0.
-Pattern 2 ``1+h``; Rewrite <- Rmult_1r; Unfold Rsqr; Apply Rle_monotony.
-Apply H0.
-Pattern 2 R1; Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Assumption.
-Apply Rlt_anti_compatibility with R1; Rewrite Rplus_Or; Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or.
-Pattern 2 R1; Rewrite <- sqrt_1; Apply sqrt_lt_1.
-Apply pos_Rsqr.
-Left; Apply Rlt_R0_R1.
-Pattern 2 R1; Rewrite <- Rsqr_1; Apply Rsqr_incrst_1.
-Pattern 2 R1; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Assumption.
-Apply H0.
-Left; Apply Rlt_R0_R1.
-Apply Rlt_anti_compatibility with R1; Rewrite Rplus_Or; Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or.
-Pattern 2 R1; Rewrite <- sqrt_1; Apply sqrt_lt_1.
-Apply H0.
-Left; Apply Rlt_R0_R1.
-Pattern 2 R1; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Assumption.
-Rewrite b; Rewrite Rplus_Or; Rewrite Rsqr_1; Rewrite sqrt_1; Right; Reflexivity.
-Repeat Rewrite Rabsolu_right.
-Unfold Rminus; Do 2 Rewrite <- (Rplus_sym ``-1``); Apply Rle_compatibility.
-Apply sqrt_le_1.
-Apply H0.
-Apply pos_Rsqr.
-Pattern 1 ``1+h``; Rewrite <- Rmult_1r; Unfold Rsqr; Apply Rle_monotony.
-Apply H0.
-Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Assumption.
-Apply Rle_sym1; Apply Rle_anti_compatibility with R1.
-Rewrite Rplus_Or; Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or.
-Pattern 1 R1; Rewrite <- sqrt_1; Apply sqrt_le_1.
-Left; Apply Rlt_R0_R1.
-Apply pos_Rsqr.
-Pattern 1 R1; Rewrite <- Rsqr_1; Apply Rsqr_incr_1.
-Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rle_compatibility; Left; Assumption.
-Left; Apply Rlt_R0_R1.
-Apply H0.
-Apply Rle_sym1; Left; Apply Rlt_anti_compatibility with R1.
-Rewrite Rplus_Or; Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Or.
-Pattern 1 R1; Rewrite <- sqrt_1; Apply sqrt_lt_1.
-Left; Apply Rlt_R0_R1.
-Apply H0.
-Pattern 1 R1; Rewrite <- Rplus_Or; Apply Rlt_compatibility; Assumption.
-Rewrite sqrt_Rsqr.
-Replace ``(1+h)-1`` with h; [Right; Reflexivity | Ring].
-Apply H0.
-Case (total_order_T h R0); Intro.
-Elim s; Intro.
-Rewrite (Rabsolu_left h a) in H.
-Apply Rle_anti_compatibility with ``-h``.
-Rewrite Rplus_Or; Rewrite Rplus_sym; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Exact H.
-Left; Rewrite b; Rewrite Rplus_Or; Apply Rlt_R0_R1.
-Left; Apply gt0_plus_gt0_is_gt0.
-Apply Rlt_R0_R1.
-Apply r.
-Qed.
-
-(* sqrt is continuous in 1 *)
-Lemma sqrt_continuity_pt_R1 : (continuity_pt sqrt R1).
-Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Pose alpha := (Rmin eps R1).
-Exists alpha; Intros.
-Split.
-Unfold alpha; Unfold Rmin; Case (total_order_Rle eps R1); Intro.
-Assumption.
-Apply Rlt_R0_R1.
-Intros; Elim H0; Intros.
-Rewrite sqrt_1; Replace x with ``1+(x-1)``; [Idtac | Ring]; Apply Rle_lt_trans with ``(Rabsolu (x-1))``.
-Apply sqrt_var_maj.
-Apply Rle_trans with alpha.
-Left; Apply H2.
-Unfold alpha; Apply Rmin_r.
-Apply Rlt_le_trans with alpha; [Apply H2 | Unfold alpha; Apply Rmin_l].
-Qed.
-
-(* sqrt is continuous forall x>0 *)
-Lemma sqrt_continuity_pt : (x:R) ``0<x`` -> (continuity_pt sqrt x).
-Intros; Generalize sqrt_continuity_pt_R1.
-Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Unfold dist; Simpl; Unfold R_dist; Intros.
-Cut ``0<eps/(sqrt x)``.
-Intro; Elim (H0 ? H2); Intros alp_1 H3.
-Elim H3; Intros.
-Pose alpha := ``alp_1*x``.
-Exists (Rmin alpha x); Intros.
-Split.
-Change ``0<(Rmin alpha x)``; Unfold Rmin; Case (total_order_Rle alpha x); Intro.
-Unfold alpha; Apply Rmult_lt_pos; Assumption.
-Apply H.
-Intros; Replace x0 with ``x+(x0-x)``; [Idtac | Ring]; Replace ``(sqrt (x+(x0-x)))-(sqrt x)`` with ``(sqrt x)*((sqrt (1+(x0-x)/x))-(sqrt 1))``.
-Rewrite Rabsolu_mult; Rewrite (Rabsolu_right (sqrt x)).
-Apply Rlt_monotony_contra with ``/(sqrt x)``.
-Apply Rlt_Rinv; Apply sqrt_lt_R0; Assumption.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1l; Rewrite Rmult_sym.
-Unfold Rdiv in H5.
-Case (Req_EM x x0); Intro.
-Rewrite H7; Unfold Rminus Rdiv; Rewrite Rplus_Ropp_r; Rewrite Rmult_Ol; Rewrite Rplus_Or; Rewrite Rplus_Ropp_r; Rewrite Rabsolu_R0.
-Apply Rmult_lt_pos.
-Assumption.
-Apply Rlt_Rinv; Rewrite <- H7; Apply sqrt_lt_R0; Assumption.
-Apply H5.
-Split.
-Unfold D_x no_cond.
-Split.
-Trivial.
-Red; Intro.
-Cut ``(x0-x)*/x==0``.
-Intro.
-Elim (without_div_Od ? ? H9); Intro.
-Elim H7.
-Apply (Rminus_eq_right ? ? H10).
-Assert H11 := (without_div_Oi1 ? x H10).
-Rewrite <- Rinv_l_sym in H11.
-Elim R1_neq_R0; Exact H11.
-Red; Intro; Rewrite H12 in H; Elim (Rlt_antirefl ? H).
-Symmetry; Apply r_Rplus_plus with R1; Rewrite Rplus_Or; Unfold Rdiv in H8; Exact H8.
-Unfold Rminus; Rewrite Rplus_sym; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Elim H6; Intros.
-Unfold Rdiv; Rewrite Rabsolu_mult.
-Rewrite Rabsolu_Rinv.
-Rewrite (Rabsolu_right x).
-Rewrite Rmult_sym; Apply Rlt_monotony_contra with x.
-Apply H.
-Rewrite <- Rmult_assoc; Rewrite <- Rinv_r_sym.
-Rewrite Rmult_1l; Rewrite Rmult_sym; Fold alpha.
-Apply Rlt_le_trans with (Rmin alpha x).
-Apply H9.
-Apply Rmin_l.
-Red; Intro; Rewrite H10 in H; Elim (Rlt_antirefl ? H).
-Apply Rle_sym1; Left; Apply H.
-Red; Intro; Rewrite H10 in H; Elim (Rlt_antirefl ? H).
-Assert H7 := (sqrt_lt_R0 x H).
-Red; Intro; Rewrite H8 in H7; Elim (Rlt_antirefl ? H7).
-Apply Rle_sym1; Apply sqrt_positivity.
-Left; Apply H.
-Unfold Rminus; Rewrite Rmult_Rplus_distr; Rewrite Ropp_mul3; Repeat Rewrite <- sqrt_times.
-Rewrite Rmult_1r; Rewrite Rmult_Rplus_distr; Rewrite Rmult_1r; Unfold Rdiv; Rewrite Rmult_sym; Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Reflexivity.
-Red; Intro; Rewrite H7 in H; Elim (Rlt_antirefl ? H).
-Left; Apply H.
-Left; Apply Rlt_R0_R1.
-Left; Apply H.
-Elim H6; Intros.
-Case (case_Rabsolu ``x0-x``); Intro.
-Rewrite (Rabsolu_left ``x0-x`` r) in H8.
-Rewrite Rplus_sym.
-Apply Rle_anti_compatibility with ``-((x0-x)/x)``.
-Rewrite Rplus_Or; Rewrite <- Rplus_assoc; Rewrite Rplus_Ropp_l; Rewrite Rplus_Ol; Unfold Rdiv; Rewrite <- Ropp_mul1.
-Apply Rle_monotony_contra with x.
-Apply H.
-Rewrite Rmult_1r; Rewrite Rmult_sym; Rewrite Rmult_assoc; Rewrite <- Rinv_l_sym.
-Rewrite Rmult_1r; Left; Apply Rlt_le_trans with (Rmin alpha x).
-Apply H8.
-Apply Rmin_r.
-Red; Intro; Rewrite H9 in H; Elim (Rlt_antirefl ? H).
-Apply ge0_plus_ge0_is_ge0.
-Left; Apply Rlt_R0_R1.
-Unfold Rdiv; Apply Rmult_le_pos.
-Apply Rle_sym2; Exact r.
-Left; Apply Rlt_Rinv; Apply H.
-Unfold Rdiv; Apply Rmult_lt_pos.
-Apply H1.
-Apply Rlt_Rinv; Apply sqrt_lt_R0; Apply H.
-Qed.
-
-(* sqrt is derivable for all x>0 *)
-Lemma derivable_pt_lim_sqrt : (x:R) ``0<x`` -> (derivable_pt_lim sqrt x ``/(2*(sqrt x))``).
-Intros; Pose g := [h:R]``(sqrt x)+(sqrt (x+h))``.
-Cut (continuity_pt g R0).
-Intro; Cut ``(g 0)<>0``.
-Intro; Assert H2 := (continuity_pt_inv g R0 H0 H1).
-Unfold derivable_pt_lim; Intros; Unfold continuity_pt in H2; Unfold continue_in in H2; Unfold limit1_in in H2; Unfold limit_in in H2; Simpl in H2; Unfold R_dist in H2.
-Elim (H2 eps H3); Intros alpha H4.
-Elim H4; Intros.
-Pose alpha1 := (Rmin alpha x).
-Cut ``0<alpha1``.
-Intro; Exists (mkposreal alpha1 H7); Intros.
-Replace ``((sqrt (x+h))-(sqrt x))/h`` with ``/((sqrt x)+(sqrt (x+h)))``.
-Unfold inv_fct g in H6; Replace ``2*(sqrt x)`` with ``(sqrt x)+(sqrt (x+0))``.
-Apply H6.
-Split.
-Unfold D_x no_cond.
-Split.
-Trivial.
-Apply not_sym; Exact H8.
-Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Apply Rlt_le_trans with alpha1.
-Exact H9.
-Unfold alpha1; Apply Rmin_l.
-Rewrite Rplus_Or; Ring.
-Cut ``0<=x+h``.
-Intro; Cut ``0<(sqrt x)+(sqrt (x+h))``.
-Intro; Apply r_Rmult_mult with ``((sqrt x)+(sqrt (x+h)))``.
-Rewrite <- Rinv_r_sym.
-Rewrite Rplus_sym; Unfold Rdiv; Rewrite <- Rmult_assoc; Rewrite Rsqr_plus_minus; Repeat Rewrite Rsqr_sqrt.
-Rewrite Rplus_sym; Unfold Rminus; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Rewrite <- Rinv_r_sym.
-Reflexivity.
-Apply H8.
-Left; Apply H.
-Assumption.
-Red; Intro; Rewrite H12 in H11; Elim (Rlt_antirefl ? H11).
-Red; Intro; Rewrite H12 in H11; Elim (Rlt_antirefl ? H11).
-Apply gt0_plus_ge0_is_gt0.
-Apply sqrt_lt_R0; Apply H.
-Apply sqrt_positivity; Apply H10.
-Case (case_Rabsolu h); Intro.
-Rewrite (Rabsolu_left h r) in H9.
-Apply Rle_anti_compatibility with ``-h``.
-Rewrite Rplus_Or; Rewrite Rplus_sym; Rewrite Rplus_assoc; Rewrite Rplus_Ropp_r; Rewrite Rplus_Or; Left; Apply Rlt_le_trans with alpha1.
-Apply H9.
-Unfold alpha1; Apply Rmin_r.
-Apply ge0_plus_ge0_is_ge0.
-Left; Assumption.
-Apply Rle_sym2; Apply r.
-Unfold alpha1; Unfold Rmin; Case (total_order_Rle alpha x); Intro.
-Apply H5.
-Apply H.
-Unfold g; Rewrite Rplus_Or.
-Cut ``0<(sqrt x)+(sqrt x)``.
-Intro; Red; Intro; Rewrite H2 in H1; Elim (Rlt_antirefl ? H1).
-Apply gt0_plus_gt0_is_gt0; Apply sqrt_lt_R0; Apply H.
-Replace g with (plus_fct (fct_cte (sqrt x)) (comp sqrt (plus_fct (fct_cte x) id))); [Idtac | Reflexivity].
-Apply continuity_pt_plus.
-Apply continuity_pt_const; Unfold constant fct_cte; Intro; Reflexivity.
-Apply continuity_pt_comp.
-Apply continuity_pt_plus.
-Apply continuity_pt_const; Unfold constant fct_cte; Intro; Reflexivity.
-Apply derivable_continuous_pt; Apply derivable_pt_id.
-Apply sqrt_continuity_pt.
-Unfold plus_fct fct_cte id; Rewrite Rplus_Or; Apply H.
-Qed.
-
-(**********)
-Lemma derivable_pt_sqrt : (x:R) ``0<x`` -> (derivable_pt sqrt x).
-Unfold derivable_pt; Intros.
-Apply Specif.existT with ``/(2*(sqrt x))``.
-Apply derivable_pt_lim_sqrt; Assumption.
-Qed.
-
-(**********)
-Lemma derive_pt_sqrt : (x:R;pr:``0<x``) ``(derive_pt sqrt x (derivable_pt_sqrt ? pr)) == /(2*(sqrt x))``.
-Intros.
-Apply derive_pt_eq_0.
-Apply derivable_pt_lim_sqrt; Assumption.
-Qed.
-
-(* We show that sqrt is continuous for all x>=0 *)
-(* Remark : by definition of sqrt (as extension of Rsqrt on |R), *)
-(*          we could also show that sqrt is continuous for all x *)
-Lemma continuity_pt_sqrt : (x:R) ``0<=x`` -> (continuity_pt sqrt x).
-Intros; Case (total_order R0 x); Intro.
-Apply (sqrt_continuity_pt x H0).
-Elim H0; Intro.
-Unfold continuity_pt; Unfold continue_in; Unfold limit1_in; Unfold limit_in; Simpl; Unfold R_dist; Intros.
-Exists (Rsqr eps); Intros.
-Split.
-Change ``0<(Rsqr eps)``; Apply Rsqr_pos_lt.
-Red; Intro; Rewrite H3 in H2; Elim (Rlt_antirefl ? H2).
-Intros; Elim H3; Intros.
-Rewrite <- H1; Rewrite sqrt_0; Unfold Rminus; Rewrite Ropp_O; Rewrite Rplus_Or; Rewrite <- H1 in H5; Unfold Rminus in H5; Rewrite Ropp_O in H5; Rewrite Rplus_Or in H5.
-Case (case_Rabsolu x0); Intro.
-Unfold sqrt; Case (case_Rabsolu x0); Intro.
-Rewrite Rabsolu_R0; Apply H2.
-Assert H6 := (Rle_sym2 ? ? r0); Elim (Rlt_antirefl ? (Rle_lt_trans ? ? ? H6 r)).
-Rewrite Rabsolu_right.
-Apply Rsqr_incrst_0.
-Rewrite Rsqr_sqrt.
-Rewrite (Rabsolu_right x0 r) in H5; Apply H5.
-Apply Rle_sym2; Exact r.
-Apply sqrt_positivity; Apply Rle_sym2; Exact r.
-Left; Exact H2.
-Apply Rle_sym1; Apply sqrt_positivity; Apply Rle_sym2; Exact r.
-Elim (Rlt_antirefl ? (Rlt_le_trans ? ? ? H1 H)).
-Qed.
diff --git a/theories7/Relations/Newman.v b/theories7/Relations/Newman.v
deleted file mode 100755
index c53db971..00000000
--- a/theories7/Relations/Newman.v
+++ /dev/null
@@ -1,115 +0,0 @@
-(************************************************************************)
-(*  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: Newman.v,v 1.1.2.1 2004/07/16 19:31:37 herbelin Exp $ i*)
-
-Require Rstar.
-
-Section Newman.
-
-Variable A: Type. 
-Variable R: A->A->Prop.
-
-Local Rstar := (Rstar A R). 
-Local Rstar_reflexive := (Rstar_reflexive A R).
-Local Rstar_transitive := (Rstar_transitive A R).
-Local Rstar_Rstar' := (Rstar_Rstar' A R).
-
-Definition coherence := [x:A][y:A] (exT2 ? (Rstar x) (Rstar y)).
-
-Theorem coherence_intro :  (x:A)(y:A)(z:A)(Rstar x z)->(Rstar y z)->(coherence x y).
-Proof [x:A][y:A][z:A][h1:(Rstar x z)][h2:(Rstar y z)]
-      (exT_intro2 A (Rstar x) (Rstar y) z h1 h2).
-  
-(** A very simple case of coherence : *)
-
-Lemma Rstar_coherence : (x:A)(y:A)(Rstar x y)->(coherence x y).
- Proof  [x:A][y:A][h:(Rstar x y)](coherence_intro x y y h (Rstar_reflexive y)).  
-  
-(** coherence is symmetric *)
-Lemma coherence_sym: (x:A)(y:A)(coherence x y)->(coherence y x).
- Proof [x:A][y:A][h:(coherence x y)]
-        (exT2_ind A (Rstar x) (Rstar y) (coherence y x)
-                 [w:A][h1:(Rstar x w)][h2:(Rstar y w)]
-                      (coherence_intro y x w h2 h1) h).
-
-Definition confluence :=
-     [x:A](y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z).  
-  
-Definition local_confluence :=
-     [x:A](y:A)(z:A)(R x y)->(R x z)->(coherence y z).  
-  
-Definition noetherian :=
-     (x:A)(P:A->Prop)((y:A)((z:A)(R y z)->(P z))->(P y))->(P x).  
-  
-Section Newman_section.
-
-(** The general hypotheses of the theorem *)
-
-Hypothesis Hyp1:noetherian.
-Hypothesis Hyp2:(x:A)(local_confluence x).  
-  
-(** The induction hypothesis *)
-
-Section Induct.
-  Variable    x:A.
-  Hypothesis  hyp_ind:(u:A)(R x u)->(confluence u).  
-  
-(** Confluence in [x] *)
-
-  Variables   y,z:A.  
-  Hypothesis  h1:(Rstar x y).  
-  Hypothesis  h2:(Rstar x z).  
-  
-(** particular case [x->u] and [u->*y]   *)
-Section Newman_.
-  Variable    u:A.  
-  Hypothesis  t1:(R x u).  
-  Hypothesis  t2:(Rstar u y).  
-  
-(** In the usual diagram, we assume also [x->v] and [v->*z] *)
-
-Theorem Diagram : (v:A)(u1:(R x v))(u2:(Rstar v z))(coherence y z).
-
-Proof     (* We draw the diagram ! *)
-   [v:A][u1:(R x v)][u2:(Rstar v z)]
-   (exT2_ind A (Rstar u) (Rstar v)    (* local confluence in x for u,v *)
-      (coherence y z)                (* gives w, u->*w and v->*w *)
-      ([w:A][s1:(Rstar u w)][s2:(Rstar v w)]
-   (exT2_ind A (Rstar y) (Rstar w)    (* confluence in u => coherence(y,w) *)
-      (coherence y z)                (* gives a, y->*a and z->*a *)
-      ([a:A][v1:(Rstar y a)][v2:(Rstar w a)]
-   (exT2_ind A (Rstar a) (Rstar z)    (* confluence in v => coherence(a,z) *)
-      (coherence y z)                (* gives b, a->*b and z->*b *)
-      ([b:A][w1:(Rstar a b)][w2:(Rstar z b)]
-        (coherence_intro y z b (Rstar_transitive y a b v1 w1) w2))
-      (hyp_ind v u1 a z (Rstar_transitive v w a s2 v2) u2)))
-     (hyp_ind u t1 y w t2 s1)))
-    (Hyp2 x u v t1 u1)).
-  
-Theorem caseRxy : (coherence y z).
-Proof (Rstar_Rstar' x z h2 
-      ([v:A][w:A](coherence y w))
-      (coherence_sym x y (Rstar_coherence x y h1))  (*i case x=z i*)
-      Diagram).                                     (*i case x->v->*z i*)
-End Newman_.
-
-Theorem Ind_proof : (coherence y z).
-Proof (Rstar_Rstar' x y h1 ([u:A][v:A](coherence v z))
-        (Rstar_coherence x z h2)                    (*i case x=y i*)
-        caseRxy).                                   (*i case x->u->*z i*)
-End Induct.
-
-Theorem Newman : (x:A)(confluence x).
-Proof [x:A](Hyp1 x confluence Ind_proof).  
-
-End Newman_section.
-
-
-End Newman.
-
diff --git a/theories7/Relations/Operators_Properties.v b/theories7/Relations/Operators_Properties.v
deleted file mode 100755
index 4f1818bc..00000000
--- a/theories7/Relations/Operators_Properties.v
+++ /dev/null
@@ -1,98 +0,0 @@
-(************************************************************************)
-(*  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: Operators_Properties.v,v 1.1.2.1 2004/07/16 19:31:37 herbelin Exp $ i*)
-
-(****************************************************************************)
-(*                            Bruno Barras                                  *)
-(****************************************************************************)
-
-Require Relation_Definitions.
-Require Relation_Operators.
-
-
-Section Properties.
-
-  Variable A: Set.
-  Variable R: (relation A).
-
-  Local incl : (relation A)->(relation A)->Prop :=
-      [R1,R2: (relation A)] (x,y:A) (R1 x y) -> (R2 x y).
-
-Section Clos_Refl_Trans.
-
-  Lemma clos_rt_is_preorder: (preorder A (clos_refl_trans A R)).
-Apply Build_preorder.
-Exact (rt_refl A R).
-
-Exact (rt_trans A R).
-Qed.
-
-
-
-Lemma clos_rt_idempotent:
-       (incl (clos_refl_trans A (clos_refl_trans A R))
-                     (clos_refl_trans A R)).
-Red.
-NewInduction 1; Auto with sets.
-Intros.
-Apply rt_trans with y; Auto with sets.
-Qed.
-
-  Lemma  clos_refl_trans_ind_left: (A:Set)(R:A->A->Prop)(M:A)(P:A->Prop)
-           (P M)
-            ->((P0,N:A)
-                (clos_refl_trans A R M P0)->(P P0)->(R P0 N)->(P N))
-               ->(a:A)(clos_refl_trans A R M a)->(P a).
-Intros.
-Generalize H H0 .
-Clear  H H0.
-Elim H1; Intros; Auto with sets.
-Apply H2 with x; Auto with sets.
-
-Apply H3.
-Apply H0; Auto with sets.
-
-Intros.
-Apply H5 with P0; Auto with sets.
-Apply rt_trans with y; Auto with sets.
-Qed.
-
-
-End Clos_Refl_Trans.
-
-
-Section Clos_Refl_Sym_Trans.
-
-  Lemma clos_rt_clos_rst: (inclusion A (clos_refl_trans A R)
-				        (clos_refl_sym_trans A R)).
-Red.
-NewInduction 1; Auto with sets.
-Apply rst_trans with y; Auto with sets.
-Qed.
-
-  Lemma clos_rst_is_equiv: (equivalence A (clos_refl_sym_trans A R)).
-Apply Build_equivalence.
-Exact (rst_refl A R).
-
-Exact (rst_trans A R).
-
-Exact (rst_sym A R).
-Qed.
-
-  Lemma clos_rst_idempotent:
-       (incl (clos_refl_sym_trans A (clos_refl_sym_trans A R))
-                     (clos_refl_sym_trans A R)).
-Red.
-NewInduction 1; Auto with sets.
-Apply rst_trans with y; Auto with sets.
-Qed.
-
-End Clos_Refl_Sym_Trans.
-
-End Properties.
diff --git a/theories7/Relations/Relation_Definitions.v b/theories7/Relations/Relation_Definitions.v
deleted file mode 100755
index 1e38e753..00000000
--- a/theories7/Relations/Relation_Definitions.v
+++ /dev/null
@@ -1,83 +0,0 @@
-(************************************************************************)
-(*  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: Relation_Definitions.v,v 1.1.2.1 2004/07/16 19:31:38 herbelin Exp $ i*)
-
-Section Relation_Definition.
-
-   Variable A: Type.
-   
-   Definition relation :=  A -> A -> Prop.
-
-   Variable R: relation.
-   
-
-Section General_Properties_of_Relations.
-
-  Definition reflexive : Prop :=  (x: A) (R x x).
-  Definition transitive : Prop :=  (x,y,z: A) (R x y) -> (R y z) -> (R x z).
-  Definition symmetric : Prop :=  (x,y: A) (R x y) -> (R y x).
-  Definition antisymmetric : Prop :=  (x,y: A) (R x y) -> (R y x) -> x=y.
-
-  (* for compatibility with Equivalence in  ../PROGRAMS/ALG/  *)
-  Definition equiv := reflexive /\ transitive /\ symmetric.
-
-End General_Properties_of_Relations.
-
-
-
-Section Sets_of_Relations.
-
-   Record preorder : Prop := {
-       preord_refl  : reflexive;
-       preord_trans : transitive }.
-
-   Record order : Prop := {
-       ord_refl    : reflexive;
-       ord_trans   : transitive;
-       ord_antisym : antisymmetric }.
-
-   Record equivalence : Prop := {
-       equiv_refl  : reflexive;
-       equiv_trans : transitive;
-       equiv_sym   : symmetric }.
-   
-   Record PER : Prop := {
-       per_sym   : symmetric;
-       per_trans : transitive }.
-
-End Sets_of_Relations.
-
-
-
-Section Relations_of_Relations.
-
-  Definition inclusion : relation -> relation -> Prop :=
-      [R1,R2: relation] (x,y:A) (R1 x y) -> (R2 x y).
-
-  Definition same_relation : relation -> relation -> Prop :=
-      [R1,R2: relation] (inclusion R1 R2) /\ (inclusion R2 R1).
-   
-  Definition commut : relation -> relation -> Prop :=
-      [R1,R2:relation] (x,y:A) (R1 y x) -> (z:A) (R2 z y)
-                          -> (EX y':A |(R2 y' x) & (R1 z y')).
-
-End Relations_of_Relations.
-
-   
-End Relation_Definition.
-
-Hints Unfold reflexive transitive antisymmetric symmetric : sets v62.
-
-Hints Resolve Build_preorder Build_order Build_equivalence 
-	Build_PER preord_refl preord_trans 
-	ord_refl ord_trans ord_antisym
-	equiv_refl equiv_trans equiv_sym
-	per_sym per_trans : sets v62.
-
-Hints Unfold inclusion same_relation commut : sets v62.
diff --git a/theories7/Relations/Relation_Operators.v b/theories7/Relations/Relation_Operators.v
deleted file mode 100755
index 14c2ae30..00000000
--- a/theories7/Relations/Relation_Operators.v
+++ /dev/null
@@ -1,157 +0,0 @@
-(************************************************************************)
-(*  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: Relation_Operators.v,v 1.1.2.1 2004/07/16 19:31:38 herbelin Exp $ i*)
-
-(****************************************************************************)
-(*                      Bruno Barras, Cristina Cornes                       *)
-(*                                                                          *)
-(*  Some of these definitons were taken from :                              *)
-(*     Constructing Recursion Operators in Type Theory                      *)
-(*     L. Paulson  JSC (1986) 2, 325-355                                    *)
-(****************************************************************************)
-
-Require Relation_Definitions.
-Require PolyList.
-Require PolyListSyntax.
-
-(** Some operators to build relations *)
-
-Section Transitive_Closure.
-  Variable A: Set.
-  Variable R: (relation A).
-
-  Inductive clos_trans : A->A->Prop :=
-     t_step: (x,y:A)(R x y)->(clos_trans x y)
-   | t_trans: (x,y,z:A)(clos_trans x y)->(clos_trans y z)->(clos_trans x z).
-End Transitive_Closure.
-
-
-Section Reflexive_Transitive_Closure.
-  Variable A: Set.
-  Variable R: (relation A).
-
-  Inductive clos_refl_trans: (relation A) :=
-    rt_step: (x,y:A)(R x y)->(clos_refl_trans x y)
-  | rt_refl: (x:A)(clos_refl_trans x x)
-  | rt_trans: (x,y,z: A)(clos_refl_trans x y)->(clos_refl_trans y z)
-                      ->(clos_refl_trans x z).
-End Reflexive_Transitive_Closure.
-
-
-Section Reflexive_Symetric_Transitive_Closure.
-  Variable A: Set.
-  Variable R: (relation A).
-
-  Inductive clos_refl_sym_trans: (relation A) :=
-    rst_step: (x,y:A)(R x y)->(clos_refl_sym_trans x y)
-  | rst_refl: (x:A)(clos_refl_sym_trans x x)
-  | rst_sym: (x,y:A)(clos_refl_sym_trans x y)->(clos_refl_sym_trans y x)
-  | rst_trans: (x,y,z:A)(clos_refl_sym_trans x y)->(clos_refl_sym_trans y z)
-                      ->(clos_refl_sym_trans x z).
-End Reflexive_Symetric_Transitive_Closure.
-
-
-Section Transposee.
-  Variable A: Set.
-  Variable R: (relation A).
-
-  Definition transp := [x,y:A](R y x).
-End Transposee.
-
-
-Section Union.
-  Variable A: Set.
-  Variable R1,R2: (relation A).
-
-  Definition union := [x,y:A](R1 x y)\/(R2 x y).
-End Union.
-
-
-Section Disjoint_Union.
-Variable A,B:Set.
-Variable leA: A->A->Prop.
-Variable leB: B->B->Prop.
-
-Inductive le_AsB : A+B->A+B->Prop :=
-   le_aa: (x,y:A) (leA x y) -> (le_AsB (inl A B x) (inl A B y))
-|  le_ab: (x:A)(y:B) (le_AsB (inl A B x) (inr A B y))
-|  le_bb: (x,y:B)  (leB x y) -> (le_AsB (inr A B x) (inr A B y)).
-
-End Disjoint_Union. 
-
-
-
-Section Lexicographic_Product.
-(* Lexicographic order on dependent pairs *)
-
-Variable A:Set.
-Variable B:A->Set.
-Variable leA: A->A->Prop.
-Variable leB: (x:A)(B x)->(B x)->Prop.
-
-Inductive lexprod : (sigS A B) -> (sigS A B) ->Prop :=
-  left_lex : (x,x':A)(y:(B x)) (y':(B x')) 
-               (leA x x') ->(lexprod (existS A B x y) (existS A B x' y'))
-| right_lex : (x:A) (y,y':(B x)) 
-                (leB x y y') -> (lexprod (existS A B x y) (existS A B x y')).
-End Lexicographic_Product.
-
-
-Section Symmetric_Product.
-  Variable A:Set.
-  Variable B:Set.
-  Variable leA: A->A->Prop.
-  Variable leB: B->B->Prop.
-
-  Inductive symprod : (A*B) -> (A*B) ->Prop :=
-     left_sym : (x,x':A)(leA x x')->(y:B)(symprod (x,y) (x',y))
-  | right_sym : (y,y':B)(leB y y')->(x:A)(symprod (x,y) (x,y')).
-
-End Symmetric_Product.
-
-
-Section Swap.
-  Variable A:Set.
-  Variable R:A->A->Prop.
-
-  Inductive swapprod: (A*A)->(A*A)->Prop :=
-     sp_noswap: (x,x':A*A)(symprod A A R R x x')->(swapprod x x')
-   | sp_swap: (x,y:A)(p:A*A)(symprod A A R R (x,y) p)->(swapprod (y,x) p).
-End Swap.
-
-
-Section Lexicographic_Exponentiation.
-
-Variable A : Set.
-Variable leA : A->A->Prop.
-Local Nil := (nil A).
-Local List := (list A).
-
-Inductive Ltl : List->List->Prop :=
-  Lt_nil: (a:A)(x:List)(Ltl Nil (cons a x))
-| Lt_hd : (a,b:A) (leA a b)-> (x,y:(list A))(Ltl (cons a x) (cons b y))
-| Lt_tl : (a:A)(x,y:List)(Ltl x y) -> (Ltl (cons a x) (cons a y)).
-
-
-Inductive Desc : List->Prop :=
-   d_nil : (Desc Nil)
-|  d_one : (x:A)(Desc (cons x Nil))
-|  d_conc : (x,y:A)(l:List)(leA x y) 
-              -> (Desc l^(cons y Nil))->(Desc (l^(cons y Nil))^(cons x Nil)).
-
-Definition  Pow :Set := (sig List Desc).
-
-Definition lex_exp : Pow -> Pow ->Prop := 
-      [a,b:Pow](Ltl (proj1_sig List Desc a) (proj1_sig  List Desc b)).
-
-End Lexicographic_Exponentiation.
-
-Hints Unfold transp union : sets v62.
-Hints Resolve t_step rt_step rt_refl rst_step rst_refl : sets v62.
-Hints Immediate rst_sym : sets v62.
diff --git a/theories7/Relations/Relations.v b/theories7/Relations/Relations.v
deleted file mode 100755
index 694d0eec..00000000
--- a/theories7/Relations/Relations.v
+++ /dev/null
@@ -1,28 +0,0 @@
-(************************************************************************)
-(*  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: Relations.v,v 1.1.2.1 2004/07/16 19:31:38 herbelin Exp $ i*)
-
-Require Export Relation_Definitions.
-Require Export Relation_Operators.
-Require Export Operators_Properties.
-
-Lemma inverse_image_of_equivalence : (A,B:Set)(f:A->B)
-  (r:(relation B))(equivalence B r)->(equivalence A [x,y:A](r (f x) (f y))).
-Intros; Split; Elim H; Red; Auto.
-Intros _ equiv_trans _ x y z H0 H1; Apply equiv_trans with (f y); Assumption.
-Qed.
-
-Lemma inverse_image_of_eq : (A,B:Set)(f:A->B)
-  (equivalence A [x,y:A](f x)=(f y)).
-Split; Red;
-[ (* reflexivity *)  Reflexivity
-| (* transitivity *) Intros; Transitivity (f y); Assumption
-| (* symmetry *) Intros; Symmetry; Assumption
-].
-Qed.
diff --git a/theories7/Relations/Rstar.v b/theories7/Relations/Rstar.v
deleted file mode 100755
index 3747b45e..00000000
--- a/theories7/Relations/Rstar.v
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  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: Rstar.v,v 1.1.2.1 2004/07/16 19:31:38 herbelin Exp $ i*)
-
-(** Properties of a binary relation [R] on type [A] *)
-
-Section Rstar.
-
-Variable A : Type.  
-Variable R : A->A->Prop.  
-
-(** Definition of the reflexive-transitive closure [R*] of [R] *)
-(** Smallest reflexive [P] containing [R o P] *)
-
-Definition Rstar  := [x,y:A](P:A->A->Prop)
-   ((u:A)(P u u))->((u:A)(v:A)(w:A)(R u v)->(P v w)->(P u w)) -> (P x y).  
-
-Theorem Rstar_reflexive:  (x:A)(Rstar x x).
- Proof [x:A][P:A->A->Prop]
-       [h1:(u:A)(P u u)][h2:(u:A)(v:A)(w:A)(R u v)->(P v w)->(P u w)]
-       (h1 x).  
-  
-Theorem Rstar_R: (x:A)(y:A)(z:A)(R x y)->(Rstar y z)->(Rstar x z).
- Proof [x:A][y:A][z:A][t1:(R x y)][t2:(Rstar y z)]
-       [P:A->A->Prop]
-       [h1:(u:A)(P u u)][h2:(u:A)(v:A)(w:A)(R u v)->(P v w)->(P u w)]
-       (h2 x y z t1 (t2 P h1 h2)).  
-  
-(** We conclude with transitivity of [Rstar] : *)
-
-Theorem  Rstar_transitive:  (x:A)(y:A)(z:A)(Rstar x y)->(Rstar y z)->(Rstar x z).
- Proof  [x:A][y:A][z:A][h:(Rstar x y)]
-        (h ([u:A][v:A](Rstar v z)->(Rstar u z))
-           ([u:A][t:(Rstar u z)]t)
-           ([u:A][v:A][w:A][t1:(R u v)][t2:(Rstar w z)->(Rstar v z)]
-            [t3:(Rstar w z)](Rstar_R u v z t1 (t2 t3)))).  
-
-(** Another characterization of [R*] *)
-(** Smallest reflexive [P] containing [R o R*] *)
-
-Definition Rstar' := [x:A][y:A](P:A->A->Prop)
-    ((P x x))->((u:A)(R x u)->(Rstar u y)->(P x y)) -> (P x y).  
-
-Theorem Rstar'_reflexive: (x:A)(Rstar' x x).
- Proof  [x:A][P:A->A->Prop][h:(P x x)][h':(u:A)(R x u)->(Rstar u x)->(P x x)]h.
-  
-Theorem Rstar'_R: (x:A)(y:A)(z:A)(R x z)->(Rstar z y)->(Rstar' x y).
- Proof  [x:A][y:A][z:A][t1:(R x z)][t2:(Rstar z y)]
-        [P:A->A->Prop][h1:(P x x)]
-        [h2:(u:A)(R x u)->(Rstar u y)->(P x y)](h2 z t1 t2).  
-  
-(** Equivalence of the two definitions: *)
-
-Theorem Rstar'_Rstar:  (x:A)(y:A)(Rstar' x y)->(Rstar x y).
- Proof  [x:A][y:A][h:(Rstar' x y)]
-        (h Rstar (Rstar_reflexive x) ([u:A](Rstar_R x u y))).  
-  
-Theorem Rstar_Rstar':  (x:A)(y:A)(Rstar x y)->(Rstar' x y).
- Proof  [x:A][y:A][h:(Rstar x y)](h Rstar' ([u:A](Rstar'_reflexive u))
-         ([u:A][v:A][w:A][h1:(R u v)][h2:(Rstar' v w)]
-          (Rstar'_R u w v h1 (Rstar'_Rstar v w h2)))).  
-
-
-(** Property of Commutativity of two relations *)
-
-Definition commut := [A:Set][R1,R2:A->A->Prop]
-                       (x,y:A)(R1 y x)->(z:A)(R2 z y)
-                        ->(EX y':A |(R2 y' x) & (R1 z y')).
-
-
-End Rstar.
-
diff --git a/theories7/Setoids/Setoid.v b/theories7/Setoids/Setoid.v
deleted file mode 100644
index f8176f60..00000000
--- a/theories7/Setoids/Setoid.v
+++ /dev/null
@@ -1,73 +0,0 @@
-(************************************************************************)
-(*  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: Setoid.v,v 1.1.2.1 2004/07/16 19:31:38 herbelin Exp $: i*)
-
-Section Setoid.
-
-Variable A : Type.
-Variable Aeq : A -> A -> Prop.
-
-Record Setoid_Theory : Prop :=
-{ Seq_refl : (x:A) (Aeq x x);
-  Seq_sym : (x,y:A) (Aeq x y) -> (Aeq y x);
-  Seq_trans : (x,y,z:A) (Aeq x y) -> (Aeq y z) -> (Aeq x z)
-}.
-
-End Setoid.
-
-Definition Prop_S : (Setoid_Theory Prop iff).
-Split; [Exact iff_refl | Exact iff_sym | Exact iff_trans].
-Qed.
-
-Add Setoid Prop iff Prop_S.
-
-Hint prop_set : setoid := Resolve (Seq_refl Prop iff Prop_S).
-Hint prop_set : setoid := Resolve (Seq_sym Prop iff Prop_S).
-Hint prop_set : setoid := Resolve (Seq_trans Prop iff Prop_S).
-
-Add Morphism or : or_ext.
-Intros.
-Inversion H1.
-Left.
-Inversion H.
-Apply (H3 H2).
-
-Right.
-Inversion H0.
-Apply (H3 H2).
-Qed.
-
-Add Morphism and : and_ext.
-Intros.
-Inversion H1.
-Split.
-Inversion H.
-Apply (H4 H2).
-
-Inversion H0.
-Apply (H4 H3).
-Qed.
-
-Add Morphism not : not_ext.
-Red ; Intros.
-Apply H0.
-Inversion H.
-Apply (H3 H1).
-Qed.
-
-Definition fleche [A,B:Prop] := A -> B.
-
-Add Morphism fleche : fleche_ext.
-Unfold fleche.
-Intros.
-Inversion H0.
-Inversion H.
-Apply (H3 (H1 (H6 H2))).
-Qed.
-
diff --git a/theories7/Sets/Classical_sets.v b/theories7/Sets/Classical_sets.v
deleted file mode 100755
index a6928ffd..00000000
--- a/theories7/Sets/Classical_sets.v
+++ /dev/null
@@ -1,133 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Classical_sets.v,v 1.1.2.1 2004/07/16 19:31:38 herbelin Exp $ i*)
-
-Require Export Ensembles.
-Require Export Constructive_sets.
-Require Export Classical_Type.
-
-(* Hints Unfold  not . *)
-
-Section Ensembles_classical.
-Variable U: Type.
-
-Lemma not_included_empty_Inhabited: 
-  (A: (Ensemble  U)) ~ (Included U A (Empty_set U)) -> (Inhabited U A).
-Proof.
-Intros A NI.
-Elim (not_all_ex_not U [x:U]~(In U A x)).
-Intros x H; Apply Inhabited_intro with x.
-Apply NNPP; Auto with sets.
-Red; Intro.
-Apply NI; Red.
-Intros x H'; Elim (H x); Trivial with sets.
-Qed.
-Hints Resolve not_included_empty_Inhabited.
-
-Lemma not_empty_Inhabited: 
-  (A: (Ensemble  U)) ~ A == (Empty_set U) -> (Inhabited U A).
-Proof.
-Intros; Apply not_included_empty_Inhabited.
-Red; Auto with sets.
-Qed.
-
-Lemma Inhabited_Setminus :
-(X, Y: (Ensemble U)) (Included U X Y) -> ~ (Included U Y X) ->
-       (Inhabited U (Setminus U Y X)).
-Proof.
-Intros X Y I NI. 
-Elim (not_all_ex_not U [x:U](In U Y x)->(In U X x) NI).
-Intros x YX.
-Apply Inhabited_intro with x.
-Apply Setminus_intro.
-Apply not_imply_elim with (In U X x); Trivial with sets.
-Auto with sets.
-Qed.
-Hints Resolve Inhabited_Setminus.
-
-Lemma Strict_super_set_contains_new_element:
-  (X, Y: (Ensemble U)) (Included U X Y) -> ~ X == Y ->
-   (Inhabited U (Setminus U Y X)).
-Proof.
-Auto 7 with sets.
-Qed.
-Hints Resolve Strict_super_set_contains_new_element.
-
-Lemma Subtract_intro:
-  (A: (Ensemble U)) (x, y: U) (In U A y) -> ~ x == y ->
-   (In U (Subtract U A x) y).
-Proof.
-Unfold 1 Subtract; Auto with sets.
-Qed.
-Hints Resolve Subtract_intro.
-
-Lemma Subtract_inv:
-  (A: (Ensemble U)) (x, y: U) (In U (Subtract U A x) y) ->
-   (In U A y) /\ ~ x == y.
-Proof.
-Intros A x y H'; Elim H'; Auto with sets.
-Qed.
-
-Lemma Included_Strict_Included:
-  (X, Y: (Ensemble U)) (Included U X Y) -> (Strict_Included U X Y) \/ X == Y.
-Proof.
-Intros X Y H'; Try Assumption.
-Elim (classic X == Y); Auto with sets.
-Qed.
-
-Lemma Strict_Included_inv:
-  (X, Y: (Ensemble U)) (Strict_Included U X Y) ->
-   (Included U X Y) /\ (Inhabited U (Setminus U Y X)).
-Proof.
-Intros X Y H'; Red in H'.
-Split; [Tauto | Idtac].
-Elim H'; Intros H'0 H'1; Try Exact H'1; Clear H'.
-Apply Strict_super_set_contains_new_element; Auto with sets.
-Qed.
-
-Lemma not_SIncl_empty: 
-    (X: (Ensemble U)) ~ (Strict_Included U X (Empty_set U)).
-Proof.
-Intro X; Red; Intro H'; Try Exact H'.
-LApply (Strict_Included_inv X (Empty_set U)); Auto with sets.
-Intro H'0; Elim H'0; Intros H'1 H'2; Elim H'2; Clear H'0.
-Intros x H'0; Elim H'0.
-Intro H'3; Elim H'3.
-Qed.
-
-Lemma Complement_Complement :
-  (A: (Ensemble U)) (Complement U (Complement U A)) == A.
-Proof.
-Unfold Complement; Intros; Apply Extensionality_Ensembles; Auto with sets.
-Red; Split; Auto with sets.
-Red; Intros; Apply NNPP; Auto with sets.
-Qed.
-
-End Ensembles_classical.
-
-Hints Resolve Strict_super_set_contains_new_element Subtract_intro 
-	not_SIncl_empty : sets v62.
diff --git a/theories7/Sets/Constructive_sets.v b/theories7/Sets/Constructive_sets.v
deleted file mode 100755
index 35c88e9d..00000000
--- a/theories7/Sets/Constructive_sets.v
+++ /dev/null
@@ -1,162 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Constructive_sets.v,v 1.1.2.1 2004/07/16 19:31:38 herbelin Exp $ i*)
-
-Require Export Ensembles.
-
-Section Ensembles_facts.
-Variable U: Type.
-
-Lemma Extension: (B, C: (Ensemble U)) B == C -> (Same_set U B C).
-Proof.
-Intros B C H'; Rewrite H'; Auto with sets.
-Qed.
-
-Lemma Noone_in_empty: (x: U) ~ (In U (Empty_set U) x).
-Proof.
-Red; NewDestruct 1.
-Qed.
-Hints Resolve Noone_in_empty.
-
-Lemma Included_Empty: (A: (Ensemble U))(Included U (Empty_set U) A).
-Proof.
-Intro; Red.
-Intros x H; Elim (Noone_in_empty x); Auto with sets.
-Qed.
-Hints Resolve Included_Empty.
-
-Lemma Add_intro1:
-  (A: (Ensemble U)) (x, y: U) (In U A y) -> (In U (Add U A x) y).
-Proof.
-Unfold 1 Add; Auto with sets.
-Qed.
-Hints Resolve Add_intro1.
-
-Lemma Add_intro2: (A: (Ensemble U)) (x: U) (In U (Add U A x) x).
-Proof.
-Unfold 1 Add; Auto with sets.
-Qed.
-Hints Resolve Add_intro2.
-
-Lemma Inhabited_add: (A: (Ensemble U)) (x: U) (Inhabited U (Add U A x)).
-Proof.
-Intros A x.
-Apply Inhabited_intro with x := x; Auto with sets.
-Qed.
-Hints Resolve Inhabited_add.
-
-Lemma Inhabited_not_empty:
-  (X: (Ensemble U)) (Inhabited U X) -> ~ X == (Empty_set U).
-Proof.
-Intros X H'; Elim H'.
-Intros x H'0; Red; Intro H'1.
-Absurd (In U X x); Auto with sets.
-Rewrite H'1; Auto with sets.
-Qed.
-Hints Resolve Inhabited_not_empty.
-
-Lemma Add_not_Empty :
- (A: (Ensemble U)) (x: U) ~ (Add U A x) == (Empty_set U).
-Proof.
-Auto with sets.
-Qed.
-Hints Resolve Add_not_Empty.
-
-Lemma not_Empty_Add :
- (A: (Ensemble U)) (x: U) ~ (Empty_set U) == (Add U A x).
-Proof.
-Intros; Red; Intro H; Generalize (Add_not_Empty A x); Auto with sets.
-Qed.
-Hints Resolve not_Empty_Add.
-
-Lemma Singleton_inv: (x, y: U) (In U (Singleton U x) y) -> x == y.
-Proof.
-Intros x y H'; Elim H'; Trivial with sets.
-Qed.
-Hints Resolve Singleton_inv.
-
-Lemma Singleton_intro: (x, y: U) x == y -> (In U (Singleton U x) y).
-Proof.
-Intros x y H'; Rewrite H'; Trivial with sets.
-Qed.
-Hints Resolve Singleton_intro.
-
-Lemma Union_inv:  (B, C: (Ensemble U)) (x: U) 
-  (In U (Union U B C) x) -> (In U B x) \/ (In U C x).
-Proof.
-Intros B C x H'; Elim H'; Auto with sets.
-Qed.
-
-Lemma Add_inv:
-  (A: (Ensemble U)) (x, y: U) (In U (Add U A x) y) -> (In U A y) \/ x == y.
-Proof.
-Intros A x y H'; Elim H'; Auto with sets.
-Qed.
-
-Lemma Intersection_inv:
-  (B, C: (Ensemble U)) (x: U) (In U (Intersection U B C) x) ->
-   (In U B x) /\ (In U C x).
-Proof.
-Intros B C x H'; Elim H'; Auto with sets.
-Qed.
-Hints Resolve Intersection_inv.
-
-Lemma Couple_inv: (x, y, z: U) (In U (Couple U x y) z) -> z == x \/ z == y.
-Proof.
-Intros x y z H'; Elim H'; Auto with sets.
-Qed.
-Hints Resolve Couple_inv.
-
-Lemma Setminus_intro:
-  (A, B: (Ensemble U)) (x: U) (In U A x) -> ~ (In U B x) ->
-   (In U (Setminus U A B) x).
-Proof.
-Unfold 1 Setminus; Red; Auto with sets.
-Qed.
-Hints Resolve Setminus_intro.
- 
-Lemma Strict_Included_intro:
-  (X, Y: (Ensemble U)) (Included U X Y) /\ ~ X == Y -> 
-                       (Strict_Included U X Y).
-Proof.
-Auto with sets.
-Qed.
-Hints Resolve Strict_Included_intro.
-
-Lemma Strict_Included_strict: (X: (Ensemble U)) ~ (Strict_Included U X X).
-Proof.
-Intro X; Red; Intro H'; Elim H'.
-Intros H'0 H'1; Elim H'1; Auto with sets.
-Qed.
-Hints Resolve Strict_Included_strict.
-
-End Ensembles_facts.
-
-Hints Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2 
-	Intersection_inv Couple_inv Setminus_intro Strict_Included_intro
-	Strict_Included_strict Noone_in_empty Inhabited_not_empty
-	Add_not_Empty  not_Empty_Add Inhabited_add Included_Empty : sets v62.
diff --git a/theories7/Sets/Cpo.v b/theories7/Sets/Cpo.v
deleted file mode 100755
index 2fe46be6..00000000
--- a/theories7/Sets/Cpo.v
+++ /dev/null
@@ -1,107 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Cpo.v,v 1.1.2.1 2004/07/16 19:31:38 herbelin Exp $ i*)
-
-Require Export Ensembles.
-Require Export Relations_1.
-Require Export Partial_Order.
-
-Section Bounds.
-Variable U: Type.
-Variable D: (PO U).
-
-Local C :=  (Carrier_of U D).
-
-Local R :=  (Rel_of U D).
-
-Inductive Upper_Bound [B:(Ensemble U); x:U]: Prop :=
-      Upper_Bound_definition:
-        (In U C x) -> ((y: U) (In U B y) -> (R y x)) -> (Upper_Bound B x).
-
-Inductive Lower_Bound [B:(Ensemble U); x:U]: Prop :=
-      Lower_Bound_definition:
-        (In U C x) -> ((y: U) (In U B y) -> (R x y)) -> (Lower_Bound B x).
-
-Inductive Lub [B:(Ensemble U); x:U]: Prop :=
-      Lub_definition:
-        (Upper_Bound B x) -> ((y: U) (Upper_Bound B y) -> (R x y)) -> (Lub B x).
-
-Inductive Glb [B:(Ensemble U); x:U]: Prop :=
-      Glb_definition:
-        (Lower_Bound B x) -> ((y: U) (Lower_Bound B y) -> (R y x)) -> (Glb B x).
-
-Inductive Bottom [bot:U]: Prop :=
-      Bottom_definition:
-        (In U C bot) -> ((y: U) (In U C y) -> (R bot y)) -> (Bottom bot).
-
-Inductive Totally_ordered [B:(Ensemble U)]: Prop :=
-      Totally_ordered_definition:
-        ((Included U B C) ->
-          (x: U) (y: U) (Included U (Couple U x y) B) -> (R x y) \/ (R y x)) ->
-         (Totally_ordered B).
-
-Definition Compatible : (Relation U) :=
-   [x: U] [y: U] (In U C x) -> (In U C y) ->
-    (EXT z | (In U C z) /\ (Upper_Bound (Couple U x y) z)).
-	
-Inductive Directed [X:(Ensemble U)]: Prop :=
-      Definition_of_Directed:
-        (Included U X C) ->
-        (Inhabited U X) ->
-        ((x1: U) (x2: U) (Included U (Couple U x1 x2) X) ->
-          (EXT x3 | (In U X x3) /\ (Upper_Bound (Couple U x1 x2) x3))) ->
-         (Directed X).
-
-Inductive Complete : Prop :=
-      Definition_of_Complete:
-        ((EXT bot | (Bottom bot))) ->
-        ((X: (Ensemble U)) (Directed X) -> (EXT bsup | (Lub X bsup))) ->
-         Complete.
-
-Inductive Conditionally_complete : Prop :=
-      Definition_of_Conditionally_complete:
-        ((X: (Ensemble U))
-         (Included U X C) -> (EXT maj | (Upper_Bound X maj)) ->
-          (EXT bsup | (Lub X bsup))) -> Conditionally_complete.
-End Bounds.
-Hints Resolve Totally_ordered_definition Upper_Bound_definition 
-	Lower_Bound_definition Lub_definition Glb_definition
-	Bottom_definition Definition_of_Complete
-  	 Definition_of_Complete Definition_of_Conditionally_complete.
-
-Section Specific_orders.
-Variable U: Type.
-
-Record Cpo : Type := Definition_of_cpo {
-   PO_of_cpo: (PO U);
-   Cpo_cond: (Complete U PO_of_cpo) }.
-
-Record Chain : Type := Definition_of_chain {
-   PO_of_chain: (PO U);
-   Chain_cond: (Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)) }.
-
-End Specific_orders.
diff --git a/theories7/Sets/Ensembles.v b/theories7/Sets/Ensembles.v
deleted file mode 100755
index c3a044c0..00000000
--- a/theories7/Sets/Ensembles.v
+++ /dev/null
@@ -1,108 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Ensembles.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Section Ensembles.
-Variable U: Type.
-
-Definition Ensemble :=  U -> Prop. 
-
-Definition In : Ensemble -> U -> Prop :=  [A: Ensemble] [x: U] (A x).
-
-Definition Included : Ensemble -> Ensemble -> Prop :=
-   [B, C: Ensemble] (x: U) (In B x) -> (In C x).
-
-Inductive Empty_set : Ensemble :=
-   .
-
-Inductive Full_set : Ensemble :=
-     Full_intro: (x: U) (In Full_set x).
-
-(** NB: The following definition builds-in equality of elements in [U] as 
-   Leibniz equality. 
-
-   This may have to be changed if we replace [U] by a Setoid on [U] 
-   with its own equality [eqs], with  
-   [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *)
-
-Inductive Singleton [x:U] : Ensemble :=
-      In_singleton: (In (Singleton x) x).
-
-Inductive Union [B, C: Ensemble] : Ensemble :=
-     Union_introl: (x: U) (In B x) -> (In (Union B C) x)
-   | Union_intror: (x: U) (In C x) -> (In (Union B C) x).
-
-Definition Add : Ensemble -> U -> Ensemble :=
-   [B: Ensemble] [x: U] (Union B (Singleton x)).
-
-Inductive Intersection [B, C:Ensemble] : Ensemble :=
-      Intersection_intro:
-        (x: U) (In B x) -> (In C x) -> (In (Intersection B C) x).
-
-Inductive Couple [x,y:U] : Ensemble :=
-     Couple_l: (In (Couple x y) x)
-   | Couple_r: (In (Couple x y) y).
-
-Inductive Triple[x, y, z:U] : Ensemble :=
-    Triple_l: (In (Triple x y z) x)
-  | Triple_m: (In (Triple x y z) y)
-  | Triple_r: (In (Triple x y z) z).
-
-Definition Complement : Ensemble -> Ensemble :=
-   [A: Ensemble] [x: U] ~ (In A x).
-
-Definition Setminus : Ensemble -> Ensemble -> Ensemble :=
-   [B: Ensemble] [C: Ensemble] [x: U] (In B x) /\ ~ (In C x).
-
-Definition Subtract : Ensemble -> U -> Ensemble :=
-   [B: Ensemble] [x: U] (Setminus B (Singleton x)).
-
-Inductive Disjoint [B, C:Ensemble] : Prop :=
-      Disjoint_intro: ((x: U) ~ (In (Intersection B C) x)) -> (Disjoint B C).
-
-Inductive Inhabited [B:Ensemble] : Prop :=
-      Inhabited_intro: (x: U) (In B x) -> (Inhabited B).
-
-Definition Strict_Included : Ensemble -> Ensemble -> Prop :=
-   [B, C: Ensemble] (Included B C) /\ ~ B == C.
-
-Definition Same_set : Ensemble -> Ensemble -> Prop :=
-   [B, C: Ensemble] (Included B C) /\ (Included C B).
-
-(** Extensionality Axiom *)
-
-Axiom Extensionality_Ensembles:
-   (A,B: Ensemble) (Same_set A B) -> A == B.
-Hints Resolve Extensionality_Ensembles.
-
-End Ensembles.
-
-Hints Unfold In Included Same_set Strict_Included Add Setminus Subtract : sets v62.
-
-Hints Resolve Union_introl Union_intror Intersection_intro In_singleton Couple_l
-	Couple_r Triple_l Triple_m Triple_r Disjoint_intro 
-	Extensionality_Ensembles : sets v62.
diff --git a/theories7/Sets/Finite_sets.v b/theories7/Sets/Finite_sets.v
deleted file mode 100755
index fb53994d..00000000
--- a/theories7/Sets/Finite_sets.v
+++ /dev/null
@@ -1,74 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Finite_sets.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Ensembles.
-
-Section Ensembles_finis.
-Variable U: Type.
-
-Inductive Finite : (Ensemble U) -> Prop :=
-      Empty_is_finite: (Finite (Empty_set U))
-   |  Union_is_finite:
-      (A: (Ensemble U)) (Finite A) -> 
-      (x: U) ~ (In U A x) -> (Finite (Add U A x)).
-
-Inductive cardinal : (Ensemble U) -> nat -> Prop :=
-      card_empty: (cardinal (Empty_set U) O)
-   |  card_add:
-       (A: (Ensemble U)) (n: nat) (cardinal A n) ->
-        (x: U) ~ (In U A x) -> (cardinal (Add U A x) (S n)).
-
-End Ensembles_finis.
-
-Hints Resolve Empty_is_finite Union_is_finite : sets v62.
-Hints Resolve card_empty card_add : sets v62.
-
-Require Constructive_sets.
-
-Section Ensembles_finis_facts.
-Variable U: Type.
-
-Lemma cardinal_invert :
- (X: (Ensemble U)) (p:nat)(cardinal U X p) -> Case p of
-           X == (Empty_set U)
-   [n:nat] (EXT A | (EXT x | 
-           X == (Add U A x) /\ ~ (In U A x) /\ (cardinal U A n))) end.
-Proof.
-NewInduction 1; Simpl; Auto.
-Exists A; Exists x; Auto.
-Qed.
-
-Lemma cardinal_elim :
- (X: (Ensemble U)) (p:nat)(cardinal U X p) -> Case p of
-                              X == (Empty_set U)
-                             [n:nat](Inhabited U X) end.
-Proof.
-Intros X p C; Elim C; Simpl; Trivial with sets.
-Qed.
-
-End Ensembles_finis_facts.
diff --git a/theories7/Sets/Finite_sets_facts.v b/theories7/Sets/Finite_sets_facts.v
deleted file mode 100755
index 63d4d2ad..00000000
--- a/theories7/Sets/Finite_sets_facts.v
+++ /dev/null
@@ -1,345 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Finite_sets_facts.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Export Finite_sets.
-Require Export Constructive_sets.
-Require Export Classical_Type.
-Require Export Classical_sets.
-Require Export Powerset.
-Require Export Powerset_facts.
-Require Export Powerset_Classical_facts.
-Require Export Gt.
-Require Export Lt.
-
-Section Finite_sets_facts.
-Variable U: Type.
-
-Lemma finite_cardinal :
- (X: (Ensemble U)) (Finite U X) -> (EX n:nat |(cardinal U X n)).
-Proof.
-NewInduction 1 as [|A _ [n H]].
-Exists O; Auto with sets.
-Exists (S n); Auto with sets.
-Qed.
-
-Lemma cardinal_finite:
-  (X: (Ensemble U)) (n: nat) (cardinal U X n) -> (Finite U X).
-Proof.
-NewInduction 1; Auto with sets.
-Qed.
-
-Theorem Add_preserves_Finite:
-  (X: (Ensemble U)) (x: U) (Finite U X) -> (Finite U (Add U X x)).
-Proof.
-Intros X x H'.
-Elim (classic (In U X x)); Intro H'0; Auto with sets.
-Rewrite (Non_disjoint_union U X x); Auto with sets.
-Qed.
-Hints Resolve Add_preserves_Finite.
-
-Theorem Singleton_is_finite: (x: U) (Finite U (Singleton U x)).
-Proof.
-Intro x; Rewrite <- (Empty_set_zero U (Singleton U x)).
-Change (Finite U (Add U (Empty_set U) x)); Auto with sets.
-Qed.
-Hints Resolve Singleton_is_finite.
-
-Theorem Union_preserves_Finite:
-  (X, Y: (Ensemble U)) (Finite U X) -> (Finite U Y) -> 
-                       (Finite U (Union U X Y)).
-Proof.
-Intros X Y H'; Elim H'.
-Rewrite (Empty_set_zero U Y); Auto with sets.
-Intros A H'0 H'1 x H'2 H'3.
-Rewrite (Union_commutative U (Add U A x) Y).
-Rewrite <- (Union_add U Y A x).
-Rewrite (Union_commutative U Y A); Auto with sets.
-Qed.
-
-Lemma Finite_downward_closed:
-  (A: (Ensemble U)) (Finite U A) ->
-   (X: (Ensemble U)) (Included U X A) -> (Finite U X).
-Proof.
-Intros A H'; Elim H'; Auto with sets.
-Intros X H'0.
-Rewrite (less_than_empty U X H'0); Auto with sets.
-Intros; Elim Included_Add with U X A0 x; Auto with sets.
-NewDestruct 1 as [A' [H5 H6]].
-Rewrite H5; Auto with sets.
-Qed.
-
-Lemma Intersection_preserves_finite:
-  (A: (Ensemble U)) (Finite U A) ->
-   (X: (Ensemble U)) (Finite U (Intersection U X A)).
-Proof.
-Intros A H' X; Apply Finite_downward_closed with A; Auto with sets.
-Qed.
-
-Lemma cardinalO_empty:
-  (X: (Ensemble U)) (cardinal U X O) -> X == (Empty_set U).
-Proof.
-Intros X H; Apply (cardinal_invert U X O); Trivial with sets.
-Qed.
-Hints Resolve cardinalO_empty.
-
-Lemma inh_card_gt_O:
-  (X: (Ensemble U)) (Inhabited U X) -> (n: nat) (cardinal U X n) -> (gt n O).
-Proof.
-NewInduction 1 as [x H'].
-Intros n H'0.
-Elim (gt_O_eq n); Auto with sets.
-Intro H'1; Generalize H'; Generalize H'0.
-Rewrite <- H'1; Intro H'2.
-Rewrite (cardinalO_empty X); Auto with sets.
-Intro H'3; Elim H'3.
-Qed.
-
-Lemma card_soustr_1:
-  (X: (Ensemble U)) (n: nat) (cardinal U X n) ->
-   (x: U) (In U X x) -> (cardinal U (Subtract U X x) (pred n)).
-Proof.
-Intros X n H'; Elim H'.
-Intros x H'0; Elim H'0.
-Clear H' n X.
-Intros X n H' H'0 x H'1 x0 H'2.
-Elim (classic (In U X x0)).
-Intro H'4; Rewrite (add_soustr_xy U X x x0).
-Elim (classic x == x0).
-Intro H'5.
-Absurd (In U X x0); Auto with sets.
-Rewrite <- H'5; Auto with sets.
-Intro H'3; Try Assumption.
-Cut (S (pred n)) = (pred (S n)).
-Intro H'5; Rewrite <- H'5.
-Apply card_add; Auto with sets.
-Red; Intro H'6; Elim H'6.
-Intros H'7 H'8; Try Assumption.
-Elim H'1; Auto with sets.
-Unfold 2 pred; Symmetry.
-Apply S_pred with m := O.
-Change (gt n O).
-Apply inh_card_gt_O with X := X; Auto with sets.
-Apply Inhabited_intro with x := x0; Auto with sets.
-Red; Intro H'3.
-Apply H'1.
-Elim H'3; Auto with sets.
-Rewrite H'3; Auto with sets.
-Elim (classic x == x0).
-Intro H'3; Rewrite <- H'3.
-Cut (Subtract U (Add U X x) x) == X; Auto with sets.
-Intro H'4; Rewrite H'4; Auto with sets.
-Intros H'3 H'4; Try Assumption.
-Absurd (In U (Add U X x) x0); Auto with sets.
-Red; Intro H'5; Try Exact H'5.
-LApply (Add_inv U X x x0); Tauto.
-Qed.
-
-Lemma cardinal_is_functional:
-  (X: (Ensemble U)) (c1: nat) (cardinal U X c1) ->
-   (Y: (Ensemble U)) (c2: nat) (cardinal U Y c2) -> X == Y ->
-    c1 = c2.
-Proof.
-Intros X c1 H'; Elim H'.
-Intros Y c2 H'0; Elim H'0; Auto with sets.
-Intros A n H'1 H'2 x H'3 H'5.
-Elim (not_Empty_Add U A x); Auto with sets.
-Clear H' c1 X.
-Intros X n H' H'0 x H'1 Y c2 H'2.
-Elim H'2.
-Intro H'3.
-Elim (not_Empty_Add U X x); Auto with sets.
-Clear H'2 c2 Y.
-Intros X0 c2 H'2 H'3 x0 H'4 H'5.
-Elim (classic (In U X0 x)).
-Intro H'6; Apply f_equal with nat.
-Apply H'0 with Y := (Subtract U (Add U X0 x0) x).
-ElimType (pred (S c2)) = c2; Auto with sets.
-Apply card_soustr_1; Auto with sets.
-Rewrite <- H'5.
-Apply Sub_Add_new; Auto with sets.
-Elim (classic x == x0).
-Intros H'6 H'7; Apply f_equal with nat.
-Apply H'0 with Y := X0; Auto with sets.
-Apply Simplify_add with x := x; Auto with sets.
-Pattern 2 x; Rewrite H'6; Auto with sets.
-Intros H'6 H'7.
-Absurd (Add U X x) == (Add U X0 x0); Auto with sets.
-Clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2.
-Red; Intro H'.
-LApply (Extension U (Add U X x) (Add U X0 x0)); Auto with sets.
-Clear H'.
-Intro H'; Red in H'.
-Elim H'; Intros H'0 H'1; Red in H'0; Clear H' H'1.
-Absurd (In U (Add U X0 x0) x); Auto with sets.
-LApply (Add_inv U X0 x0 x); [ Intuition | Apply (H'0 x); Apply Add_intro2 ].
-Qed.
-
-Lemma cardinal_Empty : (m:nat)(cardinal U (Empty_set U) m) -> O = m.
-Proof.
-Intros m Cm; Generalize (cardinal_invert U (Empty_set U) m Cm).
-Elim m; Auto with sets.
-Intros; Elim H0; Intros; Elim H1; Intros; Elim H2; Intros.
-Elim (not_Empty_Add U x x0 H3).
-Qed.
-
-Lemma cardinal_unicity :
-  (X: (Ensemble U)) (n: nat) (cardinal U X n) -> 
-                    (m: nat) (cardinal U X m) -> n = m.
-Proof.
-Intros; Apply cardinal_is_functional with X X; Auto with sets.
-Qed.
-
-Lemma card_Add_gen:
-  (A: (Ensemble U))
-  (x: U) (n, n': nat) (cardinal U A n) -> (cardinal U (Add U A x) n') ->
-   (le n' (S n)).
-Proof.
-Intros A x n n' H'.
-Elim (classic (In U A x)).
-Intro H'0.
-Rewrite (Non_disjoint_union U A x H'0).
-Intro H'1; Cut n = n'.
-Intro E; Rewrite E; Auto with sets.
-Apply cardinal_unicity with A; Auto with sets.
-Intros H'0 H'1.
-Cut n'=(S n).
-Intro E; Rewrite E; Auto with sets.
-Apply cardinal_unicity with (Add U A x); Auto with sets.
-Qed.
-
-Lemma incl_st_card_lt:
-  (X: (Ensemble U)) (c1: nat) (cardinal U X c1) ->
-  (Y: (Ensemble U)) (c2: nat) (cardinal U Y c2) -> (Strict_Included U X Y) ->
-    (gt c2 c1).
-Proof.
-Intros X c1 H'; Elim H'.
-Intros Y c2 H'0; Elim H'0; Auto with sets arith.
-Intro H'1.
-Elim (Strict_Included_strict U (Empty_set U)); Auto with sets arith.
-Clear H' c1 X.
-Intros X n H' H'0 x H'1 Y c2 H'2.
-Elim H'2.
-Intro H'3; Elim (not_SIncl_empty U (Add U X x)); Auto with sets arith.
-Clear H'2 c2 Y.
-Intros X0 c2 H'2 H'3 x0 H'4 H'5; Elim (classic (In U X0 x)).
-Intro H'6; Apply gt_n_S.
-Apply H'0 with Y := (Subtract U (Add U X0 x0) x).
-ElimType (pred (S c2)) = c2; Auto with sets arith.
-Apply card_soustr_1; Auto with sets arith.
-Apply incl_st_add_soustr; Auto with sets arith.
-Elim (classic x == x0).
-Intros H'6 H'7; Apply gt_n_S.
-Apply H'0 with Y := X0; Auto with sets arith.
-Apply sincl_add_x with x := x0.
-Rewrite <- H'6; Auto with sets arith.
-Pattern 1 x0; Rewrite <- H'6; Trivial with sets arith.
-Intros H'6 H'7; Red in H'5.
-Elim H'5; Intros H'8 H'9; Try Exact H'8; Clear H'5.
-Red in H'8.
-Generalize (H'8 x).
-Intro H'5; LApply H'5; Auto with sets arith.
-Intro H; Elim Add_inv with U X0 x0 x; Auto with sets arith.
-Intro; Absurd (In U X0 x); Auto with sets arith.
-Intro; Absurd x==x0; Auto with sets arith.
-Qed.
-
-Lemma incl_card_le:
-  (X,Y: (Ensemble U)) (n,m: nat) (cardinal U X n) -> (cardinal U Y m) -> 
-  (Included U X Y) -> (le n m).
-Proof.
-Intros;
-Elim Included_Strict_Included with U X Y; Auto with sets arith; Intro.
-Cut (gt m n); Auto with sets arith.
-Apply incl_st_card_lt with X := X Y := Y; Auto with sets arith.
-Generalize H0; Rewrite <- H2; Intro.
-Cut n=m.
-Intro E; Rewrite E; Auto with sets arith.
-Apply cardinal_unicity with X; Auto with sets arith.
-Qed.
-
-Lemma G_aux:
-  (P:(Ensemble U) ->Prop)
-  ((X:(Ensemble U))
-   (Finite U X) -> ((Y:(Ensemble U)) (Strict_Included U Y X) ->(P Y)) ->(P X)) ->
-  (P (Empty_set U)).
-Proof.
-Intros P H'; Try Assumption.
-Apply H'; Auto with sets.
-Clear H'; Auto with sets.
-Intros Y H'; Try Assumption.
-Red in H'.
-Elim H'; Intros H'0 H'1; Try Exact H'1; Clear H'.
-LApply (less_than_empty U Y); [Intro H'3; Try Exact H'3 | Assumption].
-Elim H'1; Auto with sets.
-Qed.
-
-Hints Unfold  not.
-
-Lemma Generalized_induction_on_finite_sets:
-  (P:(Ensemble U) ->Prop)
-  ((X:(Ensemble U))
-   (Finite U X) -> ((Y:(Ensemble U)) (Strict_Included U Y X) ->(P Y)) ->(P X)) ->
-  (X:(Ensemble U)) (Finite U X) ->(P X).
-Proof.
-Intros P H'0 X H'1.
-Generalize P H'0; Clear H'0 P.
-Elim H'1.
-Intros P H'0.
-Apply G_aux; Auto with sets.
-Clear H'1 X.
-Intros A H' H'0 x H'1 P H'3.
-Cut (Y:(Ensemble U)) (Included U Y (Add U A x)) ->(P Y); Auto with sets.
-Generalize H'1.
-Apply H'0.
-Intros X K H'5 L Y H'6; Apply H'3; Auto with sets.
-Apply Finite_downward_closed with A := (Add U X x); Auto with sets.
-Intros Y0 H'7.
-Elim (Strict_inclusion_is_transitive_with_inclusion U Y0 Y (Add U X x)); Auto with sets.
-Intros H'2 H'4.
-Elim (Included_Add U Y0 X x);
- [Intro H'14 |
-   Intro H'14; Elim H'14; Intros A' E; Elim E; Intros H'15 H'16; Clear E H'14 |
-   Idtac]; Auto with sets.
-Elim (Included_Strict_Included U Y0 X); Auto with sets.
-Intro H'9; Apply H'5 with Y := Y0; Auto with sets.
-Intro H'9; Rewrite H'9.
-Apply H'3; Auto with sets.
-Intros Y1 H'8; Elim H'8.
-Intros H'10 H'11; Apply H'5 with Y := Y1; Auto with sets.
-Elim (Included_Strict_Included U A' X); Auto with sets.
-Intro H'8; Apply H'5 with Y := A'; Auto with sets.
-Rewrite <- H'15; Auto with sets.
-Intro H'8.
-Elim H'7.
-Intros H'9 H'10; Apply H'10 Orelse Elim H'10; Try Assumption.
-Generalize H'6.
-Rewrite <- H'8.
-Rewrite <- H'15; Auto with sets.
-Qed.
-
-End Finite_sets_facts.
diff --git a/theories7/Sets/Image.v b/theories7/Sets/Image.v
deleted file mode 100755
index 0794a3bb..00000000
--- a/theories7/Sets/Image.v
+++ /dev/null
@@ -1,199 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Image.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Export Finite_sets.
-Require Export Constructive_sets.
-Require Export Classical_Type.
-Require Export Classical_sets.
-Require Export Powerset.
-Require Export Powerset_facts.
-Require Export Powerset_Classical_facts.
-Require Export Gt.
-Require Export Lt.
-Require Export Le.
-Require Export Finite_sets_facts.
-
-Section Image.
-Variables U, V: Type.
-
-Inductive Im [X:(Ensemble U); f:U -> V]: (Ensemble V) :=
-      Im_intro: (x: U) (In ? X x) -> (y: V) y == (f x) -> (In ? (Im X f) y).
-
-Lemma Im_def:
-  (X: (Ensemble U)) (f: U -> V) (x: U) (In ? X x) -> (In ? (Im X f) (f x)).
-Proof.
-Intros X f x H'; Try Assumption.
-Apply Im_intro with x := x; Auto with sets.
-Qed.
-Hints Resolve Im_def.
-
-Lemma Im_add:
-  (X: (Ensemble U)) (x: U) (f: U -> V)
-      (Im (Add ? X x) f) == (Add ? (Im X f) (f x)).
-Proof.
-Intros X x f.
-Apply Extensionality_Ensembles.
-Split; Red; Intros x0 H'.
-Elim H'; Intros.
-Rewrite H0.
-Elim Add_inv with U X x x1; Auto with sets.
-NewDestruct 1; Auto with sets.
-Elim Add_inv with V (Im X f) (f x) x0; Auto with sets.
-NewDestruct 1 as [x0 H y H0].
-Rewrite H0; Auto with sets.
-NewDestruct 1; Auto with sets.
-Qed.
-
-Lemma image_empty: (f: U -> V) (Im (Empty_set U) f) == (Empty_set V).
-Proof.
-Intro f; Try Assumption.
-Apply Extensionality_Ensembles.
-Split; Auto with sets.
-Red.
-Intros x H'; Elim H'.
-Intros x0 H'0; Elim H'0; Auto with sets.
-Qed.
-Hints Resolve image_empty.
-
-Lemma finite_image:
-  (X: (Ensemble U)) (f: U -> V) (Finite ? X) -> (Finite ? (Im X f)).
-Proof.
-Intros X f H'; Elim H'.
-Rewrite (image_empty f); Auto with sets.
-Intros A H'0 H'1 x H'2; Clear H' X.
-Rewrite (Im_add A x f); Auto with sets.
-Apply Add_preserves_Finite; Auto with sets.
-Qed.
-Hints Resolve finite_image.
-
-Lemma Im_inv:
-  (X: (Ensemble U)) (f: U -> V) (y: V) (In ? (Im X f) y) ->
-   (exT ? [x: U] (In ? X x) /\ (f x) == y).
-Proof.
-Intros X f y H'; Elim H'.
-Intros x H'0 y0 H'1; Rewrite H'1.
-Exists x; Auto with sets.
-Qed.
-
-Definition injective :=  [f: U -> V] (x, y: U) (f x) == (f y) -> x == y.
-
-Lemma not_injective_elim:
-  (f: U -> V) ~ (injective f) ->
-   (EXT x | (EXT y | (f x) == (f y) /\ ~ x == y)).
-Proof.
-Unfold injective; Intros f H.
-Cut (EXT x | ~ ((y: U) (f x) == (f y) -> x == y)).
-2: Apply not_all_ex_not with P:=[x:U](y: U) (f x) == (f y) -> x == y; 
-   Trivial with sets.
-NewDestruct 1 as [x C]; Exists x.
-Cut (EXT y | ~((f x)==(f y)->x==y)).
-2: Apply not_all_ex_not with P:=[y:U](f x)==(f y)->x==y; Trivial with sets.
-NewDestruct 1 as [y D]; Exists y.
-Apply imply_to_and; Trivial with sets.
-Qed.
-
-Lemma cardinal_Im_intro:
-  (A: (Ensemble U)) (f: U -> V) (n: nat) (cardinal ? A n) ->
-   (EX p: nat | (cardinal ? (Im A f) p)).
-Proof.
-Intros.
-Apply finite_cardinal; Apply finite_image.
-Apply cardinal_finite with n; Trivial with sets.
-Qed.
-
-Lemma In_Image_elim:
-  (A: (Ensemble U)) (f: U -> V) (injective f) ->
-   (x: U) (In ? (Im A f) (f x)) -> (In ? A x).
-Proof.
-Intros.
-Elim Im_inv with A f (f x); Trivial with sets.
-Intros z C; Elim C; Intros InAz E.
-Elim (H z x E); Trivial with sets.
-Qed.
-
-Lemma injective_preserves_cardinal:
-  (A: (Ensemble U)) (f: U -> V) (n: nat) (injective f) -> (cardinal ? A n) ->
-   (n': nat) (cardinal ? (Im A f) n') -> n' = n.
-Proof.
-NewInduction 2 as [|A n H'0 H'1 x H'2]; Auto with sets.
-Rewrite (image_empty f).
-Intros n' CE.
-Apply cardinal_unicity with V (Empty_set V); Auto with sets.
-Intro n'.
-Rewrite (Im_add A x f).
-Intro H'3.
-Elim cardinal_Im_intro with A f n; Trivial with sets.
-Intros i CI.
-LApply (H'1 i); Trivial with sets.
-Cut ~ (In ? (Im A f) (f x)).
-Intros H0 H1.
-Apply cardinal_unicity with V (Add ? (Im A f) (f x)); Trivial with sets.
-Apply card_add; Auto with sets.
-Rewrite <- H1; Trivial with sets.
-Red; Intro; Apply H'2.
-Apply In_Image_elim with f; Trivial with sets.
-Qed.
-
-Lemma cardinal_decreases:
-  (A: (Ensemble U)) (f: U -> V) (n: nat) (cardinal U A n) ->
-   (n': nat) (cardinal V (Im A f) n') -> (le n' n).
-Proof.
-NewInduction 1 as [|A n H'0 H'1 x H'2]; Auto with sets.
-Rewrite (image_empty f); Intros.
-Cut n' = O.
-Intro E; Rewrite E; Trivial with sets.
-Apply cardinal_unicity with V (Empty_set V); Auto with sets.
-Intro n'.
-Rewrite (Im_add A x f).
-Elim cardinal_Im_intro with A f n; Trivial with sets.
-Intros p C H'3.
-Apply le_trans with (S p).
-Apply card_Add_gen with V (Im A f) (f x); Trivial with sets.
-Apply le_n_S; Auto with sets.
-Qed.
-
-Theorem Pigeonhole:
-  (A: (Ensemble U)) (f: U -> V) (n: nat) (cardinal U A n) ->
-   (n': nat) (cardinal V (Im A f) n') -> (lt n' n) -> ~ (injective f).
-Proof.
-Unfold not; Intros A f n CAn n' CIfn' ltn'n I.
-Cut n' = n.
-Intro E; Generalize ltn'n; Rewrite E; Exact (lt_n_n n).
-Apply injective_preserves_cardinal with A := A f := f n := n; Trivial with sets.
-Qed.
-
-Lemma Pigeonhole_principle:
-  (A: (Ensemble U)) (f: U -> V) (n: nat) (cardinal ? A n) ->
-   (n': nat) (cardinal ? (Im A f) n') -> (lt n' n) ->
-    (EXT x | (EXT y | (f x) == (f y) /\ ~ x == y)).
-Proof.
-Intros; Apply not_injective_elim.
-Apply Pigeonhole with A n n'; Trivial with sets.
-Qed.
-End Image.
-Hints Resolve Im_def image_empty finite_image : sets v62.
diff --git a/theories7/Sets/Infinite_sets.v b/theories7/Sets/Infinite_sets.v
deleted file mode 100755
index bf423753..00000000
--- a/theories7/Sets/Infinite_sets.v
+++ /dev/null
@@ -1,232 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Infinite_sets.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Export Finite_sets.
-Require Export Constructive_sets.
-Require Export Classical_Type.
-Require Export Classical_sets.
-Require Export Powerset.
-Require Export Powerset_facts.
-Require Export Powerset_Classical_facts.
-Require Export Gt.
-Require Export Lt.
-Require Export Le.
-Require Export Finite_sets_facts.
-Require Export Image.
-
-Section Approx.
-Variable U: Type.
-
-Inductive Approximant [A, X:(Ensemble U)] : Prop :=
-  Defn_of_Approximant: (Finite U X) -> (Included U X A) -> (Approximant A X).
-End Approx.
-
-Hints Resolve Defn_of_Approximant.
-
-Section Infinite_sets.
-Variable U: Type.
-
-Lemma make_new_approximant:
-  (A: (Ensemble U)) (X: (Ensemble U)) ~ (Finite U A) -> (Approximant U A X) ->
-   (Inhabited U (Setminus U A X)).
-Proof.
-Intros A X H' H'0.
-Elim H'0; Intros H'1 H'2.
-Apply Strict_super_set_contains_new_element; Auto with sets.
-Red; Intro H'3; Apply H'.
-Rewrite <- H'3; Auto with sets.
-Qed.
-
-Lemma approximants_grow:
-  (A: (Ensemble U)) (X: (Ensemble U)) ~ (Finite U A) ->
-   (n: nat) (cardinal U X n) -> (Included U X A) ->
-    (EXT Y | (cardinal U Y (S n)) /\ (Included U Y A)).
-Proof.
-Intros A X H' n H'0; Elim H'0; Auto with sets.
-Intro H'1.
-Cut (Inhabited U (Setminus U A (Empty_set U))).
-Intro H'2; Elim H'2.
-Intros x H'3.
-Exists (Add U (Empty_set U) x); Auto with sets.
-Split.
-Apply card_add; Auto with sets.
-Cut (In U A x).
-Intro H'4; Red; Auto with sets.
-Intros x0 H'5; Elim H'5; Auto with sets.
-Intros x1 H'6; Elim H'6; Auto with sets.
-Elim H'3; Auto with sets.
-Apply make_new_approximant; Auto with sets.
-Intros A0 n0 H'1 H'2 x H'3 H'5.
-LApply H'2; [Intro H'6; Elim H'6; Clear H'2 | Clear H'2]; Auto with sets.
-Intros x0 H'2; Try Assumption.
-Elim H'2; Intros H'7 H'8; Try Exact H'8; Clear H'2.
-Elim (make_new_approximant A x0); Auto with sets.
-Intros x1 H'2; Try Assumption.
-Exists (Add U x0 x1); Auto with sets.
-Split.
-Apply card_add; Auto with sets.
-Elim H'2; Auto with sets.
-Red.
-Intros x2 H'9; Elim H'9; Auto with sets.
-Intros x3 H'10; Elim H'10; Auto with sets.
-Elim H'2; Auto with sets.
-Auto with sets.
-Apply Defn_of_Approximant; Auto with sets.
-Apply cardinal_finite with n := (S n0); Auto with sets.
-Qed.
-
-Lemma approximants_grow':
-  (A: (Ensemble U)) (X: (Ensemble U)) ~ (Finite U A) ->
-   (n: nat) (cardinal U X n) -> (Approximant U A X) ->
-    (EXT Y | (cardinal U Y (S n)) /\ (Approximant U A Y)).
-Proof.
-Intros A X H' n H'0 H'1; Try Assumption.
-Elim H'1.
-Intros H'2 H'3.
-ElimType (EXT Y | (cardinal U Y (S n)) /\ (Included U Y A)).
-Intros x H'4; Elim H'4; Intros H'5 H'6; Try Exact H'5; Clear H'4.
-Exists x; Auto with sets.
-Split; [Auto with sets | Idtac].
-Apply Defn_of_Approximant; Auto with sets.
-Apply cardinal_finite with n := (S n); Auto with sets.
-Apply approximants_grow with X := X; Auto with sets.
-Qed.
-
-Lemma approximant_can_be_any_size:
-  (A: (Ensemble U)) (X: (Ensemble U)) ~ (Finite U A) ->
-   (n: nat) (EXT Y | (cardinal U Y n) /\ (Approximant U A Y)).
-Proof.
-Intros A H' H'0 n; Elim n.
-Exists (Empty_set U); Auto with sets.
-Intros n0 H'1; Elim H'1.
-Intros x H'2.
-Apply approximants_grow' with X := x; Tauto.
-Qed.
-
-Variable V: Type.
-
-Theorem Image_set_continuous:
-  (A: (Ensemble U))
-  (f: U -> V) (X: (Ensemble V)) (Finite V X) -> (Included V X (Im U V A f)) ->
-   (EX n |
-   (EXT Y | ((cardinal U Y n) /\ (Included U Y A)) /\ (Im U V Y f) == X)).
-Proof.
-Intros A f X H'; Elim H'.
-Intro H'0; Exists O.
-Exists (Empty_set U); Auto with sets.
-Intros A0 H'0 H'1 x H'2 H'3; Try Assumption.
-LApply H'1;
- [Intro H'4; Elim H'4; Intros n E; Elim E; Clear H'4 H'1 | Clear H'1]; Auto with sets.
-Intros x0 H'1; Try Assumption.
-Exists (S n); Try Assumption.
-Elim H'1; Intros H'4 H'5; Elim H'4; Intros H'6 H'7; Try Exact H'6; Clear H'4 H'1.
-Clear E.
-Generalize H'2.
-Rewrite <- H'5.
-Intro H'1; Try Assumption.
-Red in H'3.
-Generalize (H'3 x).
-Intro H'4; LApply H'4; [Intro H'8; Try Exact H'8; Clear H'4 | Clear H'4]; Auto with sets.
-Specialize 5 Im_inv with U := U V:=V X := A f := f y := x; Intro H'11; 
- LApply H'11; [Intro H'13; Elim H'11; Clear H'11 | Clear H'11]; Auto with sets.
-Intros x1 H'4; Try Assumption.
-Apply exT_intro with x := (Add U x0 x1).
-Split; [Split; [Try Assumption | Idtac] | Idtac].
-Apply card_add; Auto with sets.
-Red; Intro H'9; Try Exact H'9.
-Apply H'1.
-Elim H'4; Intros H'10 H'11; Rewrite <- H'11; Clear H'4; Auto with sets.
-Elim H'4; Intros H'9 H'10; Try Exact H'9; Clear H'4; Auto with sets.
-Red; Auto with sets.
-Intros x2 H'4; Elim H'4; Auto with sets.
-Intros x3 H'11; Elim H'11; Auto with sets.
-Elim H'4; Intros H'9 H'10; Rewrite <- H'10; Clear H'4; Auto with sets.
-Apply Im_add; Auto with sets.
-Qed.
-
-Theorem Image_set_continuous':
-  (A: (Ensemble U))
-  (f: U -> V) (X: (Ensemble V)) (Approximant V (Im U V A f) X) ->
-   (EXT Y | (Approximant U A Y) /\ (Im U V Y f) == X).
-Proof.
-Intros A f X H'; Try Assumption.
-Cut (EX n | (EXT Y |
-    ((cardinal U Y n) /\ (Included U Y A)) /\ (Im U V Y f) == X)).
-Intro H'0; Elim H'0; Intros n E; Elim E; Clear H'0.
-Intros x H'0; Try Assumption.
-Elim H'0; Intros H'1 H'2; Elim H'1; Intros H'3 H'4; Try Exact H'3;
- Clear H'1 H'0; Auto with sets.
-Exists x.
-Split; [Idtac | Try Assumption].
-Apply Defn_of_Approximant; Auto with sets.
-Apply cardinal_finite with n := n; Auto with sets.
-Apply Image_set_continuous; Auto with sets.
-Elim H'; Auto with sets.
-Elim H'; Auto with sets.
-Qed.
-
-Theorem Pigeonhole_bis:
-  (A: (Ensemble U)) (f: U -> V) ~ (Finite U A) -> (Finite V (Im U V A f)) ->
-   ~ (injective U V f).
-Proof.
-Intros A f H'0 H'1; Try Assumption.
-Elim (Image_set_continuous' A f (Im U V A f)); Auto with sets.
-Intros x H'2; Elim H'2; Intros H'3 H'4; Try Exact H'3; Clear H'2.
-Elim (make_new_approximant A x); Auto with sets.
-Intros x0 H'2; Elim H'2.
-Intros H'5 H'6.
-Elim (finite_cardinal V (Im U V A f)); Auto with sets.
-Intros n E.
-Elim (finite_cardinal U x); Auto with sets.
-Intros n0 E0.
-Apply Pigeonhole with A := (Add U x x0) n := (S n0) n' := n.
-Apply card_add; Auto with sets.
-Rewrite (Im_add U V x x0 f); Auto with sets.
-Cut (In V (Im U V x f) (f x0)).
-Intro H'8.
-Rewrite (Non_disjoint_union V (Im U V x f) (f x0)); Auto with sets.
-Rewrite H'4; Auto with sets.
-Elim (Extension V (Im U V x f) (Im U V A f)); Auto with sets.
-Apply le_lt_n_Sm.
-Apply cardinal_decreases with U := U V := V A := x f := f; Auto with sets.
-Rewrite H'4; Auto with sets.
-Elim H'3; Auto with sets.
-Qed.
-
-Theorem Pigeonhole_ter:
-  (A: (Ensemble U))
-  (f: U -> V) (n: nat) (injective U V f) -> (Finite V (Im U V A f)) ->
-   (Finite U A).
-Proof.
-Intros A f H' H'0 H'1.
-Apply NNPP.
-Red; Intro H'2.
-Elim (Pigeonhole_bis A f); Auto with sets.
-Qed.
-
-End Infinite_sets.
diff --git a/theories7/Sets/Integers.v b/theories7/Sets/Integers.v
deleted file mode 100755
index 7dee371f..00000000
--- a/theories7/Sets/Integers.v
+++ /dev/null
@@ -1,166 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Integers.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Export Finite_sets.
-Require Export Constructive_sets.
-Require Export Classical_Type.
-Require Export Classical_sets.
-Require Export Powerset.
-Require Export Powerset_facts.
-Require Export Powerset_Classical_facts.
-Require Export Gt.
-Require Export Lt.
-Require Export Le.
-Require Export Finite_sets_facts.
-Require Export Image.
-Require Export Infinite_sets.
-Require Export Compare_dec.
-Require Export Relations_1.
-Require Export Partial_Order.
-Require Export Cpo.
-
-Section Integers_sect.
-
-Inductive Integers : (Ensemble nat) :=
-      Integers_defn: (x: nat) (In nat Integers x).
-Hints Resolve Integers_defn.
-
-Lemma le_reflexive: (Reflexive nat le).
-Proof.
-Red; Auto with arith.
-Qed.
-
-Lemma le_antisym: (Antisymmetric nat le).
-Proof.
-Red; Intros x y H H';Rewrite (le_antisym x y);Auto.
-Qed.
-
-Lemma le_trans: (Transitive nat le).
-Proof.
-Red; Intros; Apply le_trans with y;Auto.
-Qed.
-Hints Resolve le_reflexive le_antisym le_trans.
-
-Lemma le_Order: (Order nat le).
-Proof.
-Auto with sets arith.
-Qed.
-Hints Resolve le_Order.
-
-Lemma triv_nat: (n: nat) (In nat Integers n).
-Proof.
-Auto with sets arith.
-Qed.
-Hints Resolve triv_nat.
-
-Definition nat_po: (PO nat).
-Apply Definition_of_PO with Carrier_of := Integers Rel_of := le; Auto with sets arith.
-Apply Inhabited_intro with x := O; Auto with sets arith.
-Defined.
-Hints Unfold nat_po.
-
-Lemma le_total_order: (Totally_ordered nat nat_po Integers).
-Proof.
-Apply Totally_ordered_definition.
-Simpl.
-Intros H' x y H'0.
-Specialize 2 le_or_lt with n := x m := y; Intro H'2; Elim H'2.
-Intro H'1; Left; Auto with sets arith.
-Intro H'1; Right.
-Cut (le y x); Auto with sets arith.
-Qed.
-Hints Resolve le_total_order.
-
-Lemma Finite_subset_has_lub:
-  (X: (Ensemble nat)) (Finite nat X) ->
-   (EXT m: nat | (Upper_Bound nat nat_po X m)).
-Proof.
-Intros X H'; Elim H'.
-Exists O.
-Apply Upper_Bound_definition; Auto with sets arith.
-Intros y H'0; Elim H'0; Auto with sets arith.
-Intros A H'0 H'1 x H'2; Try Assumption.
-Elim H'1; Intros x0 H'3; Clear H'1.
-Elim le_total_order.
-Simpl.
-Intro H'1; Try Assumption.
-LApply H'1; [Intro H'4; Idtac | Try Assumption]; Auto with sets arith.
-Generalize (H'4 x0 x).
-Clear H'4.
-Clear H'1.
-Intro H'1; LApply H'1;
- [Intro H'4; Elim H'4;
-   [Intro H'5; Try Exact H'5; Clear H'4 H'1 | Intro H'5; Clear H'4 H'1] |
-   Clear H'1].
-Exists x.
-Apply Upper_Bound_definition; Auto with sets arith; Simpl.
-Intros y H'1; Elim H'1.
-Generalize le_trans.
-Intro H'4; Red in H'4.
-Intros x1 H'6; Try Assumption.
-Apply H'4 with y := x0; Auto with sets arith.
-Elim H'3; Simpl; Auto with sets arith.
-Intros x1 H'4; Elim H'4; Auto with sets arith.
-Exists x0.
-Apply Upper_Bound_definition; Auto with sets arith; Simpl.
-Intros y H'1; Elim H'1.
-Intros x1 H'4; Try Assumption.
-Elim H'3; Simpl; Auto with sets arith.
-Intros x1 H'4; Elim H'4; Auto with sets arith.
-Red.
-Intros x1 H'1; Elim H'1; Auto with sets arith.
-Qed.
-
-Lemma Integers_has_no_ub: ~ (EXT m:nat | (Upper_Bound nat nat_po Integers m)).
-Proof.
-Red; Intro H'; Elim H'.
-Intros x H'0.
-Elim H'0; Intros H'1 H'2.
-Cut (In nat Integers (S x)).
-Intro H'3.
-Specialize 1 H'2 with y := (S x); Intro H'4; LApply H'4;
- [Intro H'5; Clear H'4 | Try Assumption; Clear H'4].
-Simpl in H'5.
-Absurd (le (S x) x); Auto with arith.
-Auto with sets arith.
-Qed.
-
-Lemma Integers_infinite: ~ (Finite nat Integers).
-Proof.
-Generalize Integers_has_no_ub.
-Intro H'; Red; Intro H'0; Try Exact H'0.
-Apply H'.
-Apply Finite_subset_has_lub; Auto with sets arith.
-Qed.
-
-End Integers_sect.
-
-
-
-
-
diff --git a/theories7/Sets/Multiset.v b/theories7/Sets/Multiset.v
deleted file mode 100755
index b5d5edf7..00000000
--- a/theories7/Sets/Multiset.v
+++ /dev/null
@@ -1,186 +0,0 @@
-(************************************************************************)
-(*  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: Multiset.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-(* G. Huet 1-9-95 *)
-
-Require Permut.
-
-Set Implicit Arguments.
-
-Section multiset_defs.
-
-Variable A : Set.
-Variable eqA : A -> A -> Prop.
-Hypothesis Aeq_dec : (x,y:A){(eqA x y)}+{~(eqA x y)}.
-
-Inductive multiset : Set := 
-      Bag : (A->nat) -> multiset.
-
-Definition EmptyBag := (Bag [a:A]O).
-Definition SingletonBag := [a:A]
-	(Bag [a':A]Cases (Aeq_dec a a') of
-                      (left _) => (S O) 
-	           | (right _) => O 
-                   end
-	).
-
-Definition multiplicity : multiset -> A -> nat :=
-  [m:multiset][a:A]let (f) = m in (f a).
-
-(** multiset equality *)
-Definition meq := [m1,m2:multiset]
-    (a:A)(multiplicity m1 a)=(multiplicity m2 a).
-
-Hints Unfold  meq multiplicity.
-
-Lemma meq_refl : (x:multiset)(meq x x).
-Proof.
-NewDestruct x; Auto.
-Qed.
-Hints Resolve meq_refl.
-
-Lemma meq_trans : (x,y,z:multiset)(meq x y)->(meq y z)->(meq x z).
-Proof.
-Unfold meq.
-NewDestruct x; NewDestruct y; NewDestruct z.
-Intros; Rewrite H; Auto.
-Qed.
-
-Lemma meq_sym : (x,y:multiset)(meq x y)->(meq y x).
-Proof.
-Unfold meq.
-NewDestruct x; NewDestruct y; Auto.
-Qed.
-Hints Immediate meq_sym.
-
-(** multiset union *)
-Definition munion := [m1,m2:multiset]
-    (Bag [a:A](plus (multiplicity m1 a)(multiplicity m2 a))).
-
-Lemma munion_empty_left :
-     (x:multiset)(meq x (munion EmptyBag x)).
-Proof.
-Unfold meq; Unfold munion; Simpl; Auto.
-Qed.
-Hints Resolve munion_empty_left.
-
-Lemma munion_empty_right :
-     (x:multiset)(meq x (munion x EmptyBag)).
-Proof.
-Unfold meq; Unfold munion; Simpl; Auto.
-Qed.
-
-
-Require Plus. (* comm. and ass. of plus *)
-
-Lemma munion_comm : (x,y:multiset)(meq (munion x y) (munion y x)).
-Proof.
-Unfold meq; Unfold multiplicity; Unfold munion.
-NewDestruct x; NewDestruct y; Auto with arith.
-Qed.
-Hints Resolve munion_comm.
-
-Lemma munion_ass : 
-      (x,y,z:multiset)(meq (munion (munion x y) z) (munion x (munion y z))).
-Proof.
-Unfold meq; Unfold munion; Unfold multiplicity.
-NewDestruct x; NewDestruct y; NewDestruct z; Auto with arith.
-Qed.
-Hints Resolve munion_ass.
-
-Lemma meq_left :  (x,y,z:multiset)(meq x y)->(meq (munion x z) (munion y z)).
-Proof.
-Unfold meq; Unfold munion; Unfold multiplicity.
-NewDestruct x; NewDestruct y; NewDestruct z.
-Intros; Elim H; Auto with arith.
-Qed.
-Hints Resolve meq_left.
-
-Lemma meq_right : (x,y,z:multiset)(meq x y)->(meq (munion z x) (munion z y)).
-Proof.
-Unfold meq; Unfold munion; Unfold multiplicity.
-NewDestruct x; NewDestruct y; NewDestruct z.
-Intros; Elim H; Auto.
-Qed.
-Hints Resolve meq_right.
-
-
-(** Here we should make multiset an abstract datatype, by hiding [Bag],
-    [munion], [multiplicity]; all further properties are proved abstractly *)
-
-Lemma munion_rotate :
-   (x,y,z:multiset)(meq (munion x (munion y z)) (munion z (munion x y))).
-Proof.
-Intros; Apply (op_rotate multiset munion meq); Auto.
-Exact meq_trans.
-Qed.
-
-Lemma meq_congr : (x,y,z,t:multiset)(meq x y)->(meq z t)->
-                  (meq (munion x z) (munion y t)).
-Proof.
-Intros; Apply (cong_congr multiset munion meq); Auto.
-Exact meq_trans.
-Qed.
-
-Lemma munion_perm_left :
-   (x,y,z:multiset)(meq (munion x (munion y z)) (munion y (munion x z))).
-Proof.
-Intros; Apply (perm_left multiset munion meq); Auto.
-Exact meq_trans.
-Qed.
-
-Lemma multiset_twist1 : (x,y,z,t:multiset)
-   (meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z)).
-Proof.
-Intros; Apply (twist multiset munion meq); Auto.
-Exact meq_trans.
-Qed.
-
-Lemma multiset_twist2 : (x,y,z,t:multiset)
-   (meq (munion x (munion (munion y z) t)) (munion (munion y (munion x z)) t)).
-Proof.
-Intros; Apply meq_trans with (munion (munion x (munion y z)) t).
-Apply meq_sym; Apply munion_ass.
-Apply meq_left; Apply munion_perm_left.
-Qed.
-
-(** specific for treesort *)
-
-Lemma treesort_twist1 : (x,y,z,t,u:multiset) (meq u (munion y z)) ->
-   (meq (munion x (munion u t)) (munion (munion y (munion x t)) z)).
-Proof.
-Intros; Apply meq_trans with (munion x (munion (munion y z) t)).
-Apply meq_right; Apply meq_left; Trivial.
-Apply multiset_twist1.
-Qed.
-
-Lemma treesort_twist2 : (x,y,z,t,u:multiset) (meq u (munion y z)) ->
-   (meq (munion x (munion u t)) (munion (munion y (munion x z)) t)).
-Proof.
-Intros; Apply meq_trans with (munion x (munion (munion y z) t)).
-Apply meq_right; Apply meq_left; Trivial.
-Apply multiset_twist2.
-Qed.
-
-
-(*i theory of minter to do similarly 
-Require Min.
-(* multiset intersection *)
-Definition minter := [m1,m2:multiset]
-    (Bag [a:A](min (multiplicity m1 a)(multiplicity m2 a))).
-i*)
-
-End multiset_defs.
-
-Unset Implicit Arguments.
-
-Hints Unfold meq multiplicity : v62 datatypes.
-Hints Resolve munion_empty_right munion_comm munion_ass meq_left meq_right munion_empty_left : v62 datatypes.
-Hints Immediate meq_sym : v62 datatypes.
diff --git a/theories7/Sets/Partial_Order.v b/theories7/Sets/Partial_Order.v
deleted file mode 100755
index 759cf4e2..00000000
--- a/theories7/Sets/Partial_Order.v
+++ /dev/null
@@ -1,100 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Partial_Order.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Export Ensembles.
-Require Export Relations_1.
-
-Section Partial_orders.
-Variable U: Type.
-
-Definition Carrier :=  (Ensemble U).
-
-Definition Rel :=  (Relation U).
-
-Record PO : Type := Definition_of_PO {
-   Carrier_of: (Ensemble U);
-   Rel_of: (Relation U);
-   PO_cond1: (Inhabited U Carrier_of);
-   PO_cond2: (Order U Rel_of) }.
-Variable p: PO.
-
-Definition Strict_Rel_of : Rel :=  [x, y: U] (Rel_of p x y) /\ ~ x == y.
-
-Inductive covers [y, x:U]: Prop :=
-      Definition_of_covers:
-      (Strict_Rel_of x y) -> 
-          ~ (EXT z | (Strict_Rel_of x z) /\ (Strict_Rel_of z y)) -> 
-          (covers y x).
-
-End Partial_orders.
-
-Hints Unfold Carrier_of Rel_of  Strict_Rel_of : sets v62.
-Hints Resolve Definition_of_covers : sets v62.
-
-
-Section Partial_order_facts.
-Variable U:Type.
-Variable D:(PO U).
-
-Lemma Strict_Rel_Transitive_with_Rel:
-  (x:U) (y:U) (z:U) (Strict_Rel_of U D x y) -> (Rel_of U D y z) ->
-  (Strict_Rel_of U D x z).
-Unfold 1 Strict_Rel_of.
-Red.
-Elim D; Simpl.
-Intros C R H' H'0; Elim H'0.
-Intros H'1 H'2 H'3 x y z H'4 H'5; Split.
-Apply H'2 with y := y; Tauto.
-Red; Intro H'6.
-Elim H'4; Intros H'7 H'8; Apply H'8; Clear H'4.
-Apply H'3; Auto.
-Rewrite H'6; Tauto.
-Qed.
-
-Lemma Strict_Rel_Transitive_with_Rel_left:
-  (x:U) (y:U) (z:U) (Rel_of U D x y) -> (Strict_Rel_of U D y z) ->
-  (Strict_Rel_of U D x z).
-Unfold 1 Strict_Rel_of.
-Red.
-Elim D; Simpl.
-Intros C R H' H'0; Elim H'0.
-Intros H'1 H'2 H'3 x y z H'4 H'5; Split.
-Apply H'2 with y := y; Tauto.
-Red; Intro H'6.
-Elim H'5; Intros H'7 H'8; Apply H'8; Clear H'5.
-Apply H'3; Auto.
-Rewrite <- H'6; Auto.
-Qed.
-
-Lemma Strict_Rel_Transitive: (Transitive U (Strict_Rel_of U D)).
-Red.
-Intros x y z H' H'0.
-Apply Strict_Rel_Transitive_with_Rel with y := y; 
-  [ Intuition | Unfold Strict_Rel_of in H' H'0; Intuition ].
-Qed.
-End Partial_order_facts.
diff --git a/theories7/Sets/Permut.v b/theories7/Sets/Permut.v
deleted file mode 100755
index 2d0413a8..00000000
--- a/theories7/Sets/Permut.v
+++ /dev/null
@@ -1,91 +0,0 @@
-(************************************************************************)
-(*  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: Permut.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-(* G. Huet 1-9-95 *)
-
-(** We consider a Set [U], given with a commutative-associative operator [op],
-    and a congruence [cong]; we show permutation lemmas *)
-
-Section Axiomatisation.
-
-Variable U: Set.
-
-Variable op: U -> U -> U.
-
-Variable cong : U -> U -> Prop.
-
-Hypothesis op_comm : (x,y:U)(cong (op x y) (op y x)).
-Hypothesis op_ass  : (x,y,z:U)(cong (op (op x y) z) (op x (op y z))).
-
-Hypothesis cong_left :  (x,y,z:U)(cong x y)->(cong (op x z) (op y z)).
-Hypothesis cong_right : (x,y,z:U)(cong x y)->(cong (op z x) (op z y)).
-Hypothesis cong_trans : (x,y,z:U)(cong x y)->(cong y z)->(cong x z).
-Hypothesis cong_sym : (x,y:U)(cong x y)->(cong y x).
-
-(** Remark. we do not need: [Hypothesis cong_refl : (x:U)(cong x x)]. *)
-
-Lemma cong_congr :
- (x,y,z,t:U)(cong x y)->(cong z t)->(cong (op x z) (op y t)).
-Proof.
-Intros; Apply cong_trans with (op y z).
-Apply cong_left; Trivial.
-Apply cong_right; Trivial.
-Qed.
-
-Lemma comm_right : (x,y,z:U)(cong (op x (op y z)) (op x (op z y))).
-Proof.
-Intros; Apply cong_right; Apply op_comm.
-Qed.
-
-Lemma comm_left : (x,y,z:U)(cong (op (op x y) z) (op (op y x) z)).
-Proof.
-Intros; Apply cong_left; Apply op_comm.
-Qed.
-
-Lemma perm_right : (x,y,z:U)(cong (op (op x y) z) (op (op x z) y)).
-Proof.
-Intros.
-Apply cong_trans with (op x (op y z)).
-Apply op_ass.
-Apply cong_trans with (op x (op z y)). 
-Apply cong_right; Apply op_comm.
-Apply cong_sym; Apply op_ass.
-Qed.
-
-Lemma perm_left : (x,y,z:U)(cong (op x (op y z)) (op y (op x z))).
-Proof.
-Intros.
-Apply cong_trans with (op (op x y) z).
-Apply cong_sym; Apply op_ass.
-Apply cong_trans with (op (op y x) z).
-Apply cong_left; Apply op_comm.
-Apply op_ass.
-Qed.
-
-Lemma op_rotate : (x,y,z,t:U)(cong (op x (op y z)) (op z (op x y))).
-Proof.
-Intros; Apply cong_trans with (op (op x y) z).
-Apply cong_sym; Apply op_ass.
-Apply op_comm.
-Qed.
-
-(* Needed for treesort ... *)
-Lemma twist : (x,y,z,t:U)
-   (cong (op x (op (op y z) t)) (op (op y (op x t)) z)).
-Proof.
-Intros.
-Apply cong_trans with (op x (op (op y t) z)).
-Apply cong_right; Apply perm_right.
-Apply cong_trans with (op (op x (op y t)) z).
-Apply cong_sym; Apply op_ass.
-Apply cong_left; Apply perm_left.
-Qed.
-
-End Axiomatisation.
diff --git a/theories7/Sets/Powerset.v b/theories7/Sets/Powerset.v
deleted file mode 100755
index b1fa892c..00000000
--- a/theories7/Sets/Powerset.v
+++ /dev/null
@@ -1,188 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Powerset.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Export Ensembles.
-Require Export Relations_1.
-Require Export Relations_1_facts.
-Require Export Partial_Order.
-Require Export Cpo.
-
-Section The_power_set_partial_order.
-Variable U: Type.
-
-Inductive Power_set [A:(Ensemble U)]: (Ensemble (Ensemble U)) :=
-    Definition_of_Power_set:
-     (X: (Ensemble U)) (Included U X A) -> (In (Ensemble U) (Power_set A) X).
-Hints Resolve Definition_of_Power_set.
-
-Theorem Empty_set_minimal: (X: (Ensemble U)) (Included U (Empty_set U) X).
-Intro X; Red.
-Intros x H'; Elim H'.
-Qed.
-Hints Resolve Empty_set_minimal.
-
-Theorem Power_set_Inhabited:
-  (X: (Ensemble U)) (Inhabited (Ensemble U) (Power_set X)).
-Intro X.
-Apply Inhabited_intro with (Empty_set U); Auto with sets.
-Qed.
-Hints Resolve Power_set_Inhabited.
-
-Theorem Inclusion_is_an_order: (Order (Ensemble U) (Included U)).
-Auto 6 with sets.
-Qed.
-Hints Resolve Inclusion_is_an_order.
-
-Theorem Inclusion_is_transitive: (Transitive (Ensemble U) (Included U)).
-Elim Inclusion_is_an_order; Auto with sets.
-Qed.
-Hints Resolve Inclusion_is_transitive.
-
-Definition Power_set_PO: (Ensemble U) -> (PO (Ensemble U)).
-Intro A; Try Assumption.
-Apply Definition_of_PO with (Power_set A) (Included U); Auto with sets.
-Defined.
-Hints Unfold  Power_set_PO.
-
-Theorem Strict_Rel_is_Strict_Included:
-  (same_relation
-     (Ensemble U) (Strict_Included U)
-     (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U)))).
-Auto with sets.
-Qed.
-Hints Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included.
-
-Lemma Strict_inclusion_is_transitive_with_inclusion:
-  (x, y, z:(Ensemble U)) (Strict_Included U x y) -> (Included U y z) ->
-  (Strict_Included U x z).
-Intros x y z H' H'0; Try Assumption.
-Elim Strict_Rel_is_Strict_Included.
-Unfold contains.
-Intros H'1 H'2; Try Assumption.
-Apply H'1.
-Apply Strict_Rel_Transitive_with_Rel with y := y; Auto with sets.
-Qed.
-
-Lemma Strict_inclusion_is_transitive_with_inclusion_left:
-  (x, y, z:(Ensemble U)) (Included U x y) -> (Strict_Included U y z) ->
-  (Strict_Included U x z).
-Intros x y z H' H'0; Try Assumption.
-Elim Strict_Rel_is_Strict_Included.
-Unfold contains.
-Intros H'1 H'2; Try Assumption.
-Apply H'1.
-Apply Strict_Rel_Transitive_with_Rel_left with y := y; Auto with sets.
-Qed.
-
-Lemma Strict_inclusion_is_transitive:
-  (Transitive (Ensemble U) (Strict_Included U)).
-Apply cong_transitive_same_relation
-     with R := (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))); Auto with sets.
-Qed.
-
-Theorem Empty_set_is_Bottom:
-  (A: (Ensemble U)) (Bottom (Ensemble U) (Power_set_PO A) (Empty_set U)).
-Intro A; Apply Bottom_definition; Simpl; Auto with sets.
-Qed.
-Hints Resolve Empty_set_is_Bottom.
-
-Theorem Union_minimal:
-  (a, b, X: (Ensemble U)) (Included U a X) -> (Included U b X) ->
-   (Included U (Union U a b) X).
-Intros a b X H' H'0; Red.
-Intros x H'1; Elim H'1; Auto with sets.
-Qed.
-Hints Resolve Union_minimal.
-
-Theorem Intersection_maximal:
-  (a, b, X: (Ensemble U)) (Included U X a) -> (Included U X b) ->
-   (Included U X (Intersection U a b)).
-Auto with sets.
-Qed.
-
-Theorem Union_increases_l: (a, b: (Ensemble U)) (Included U a (Union U a b)).
-Auto with sets.
-Qed.
-
-Theorem Union_increases_r: (a, b: (Ensemble U)) (Included U b (Union U a b)).
-Auto with sets.
-Qed.
-
-Theorem Intersection_decreases_l:
-  (a, b: (Ensemble U)) (Included U (Intersection U a b) a).
-Intros a b; Red.
-Intros x H'; Elim H'; Auto with sets.
-Qed.
-
-Theorem Intersection_decreases_r:
-  (a, b: (Ensemble U)) (Included U (Intersection U a b) b).
-Intros a b; Red.
-Intros x H'; Elim H'; Auto with sets.
-Qed.
-Hints Resolve Union_increases_l Union_increases_r Intersection_decreases_l
-     Intersection_decreases_r.
-
-Theorem Union_is_Lub:
-  (A: (Ensemble U)) (a, b: (Ensemble U)) (Included U a A) -> (Included U b A) ->
-   (Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b)).
-Intros A a b H' H'0.
-Apply Lub_definition; Simpl.
-Apply Upper_Bound_definition; Simpl; Auto with sets.
-Intros y H'1; Elim H'1; Auto with sets.
-Intros y H'1; Elim H'1; Simpl; Auto with sets.
-Qed.
-
-Theorem Intersection_is_Glb:
-  (A: (Ensemble U)) (a, b: (Ensemble U)) (Included U a A) -> (Included U b A) ->
-   (Glb
-      (Ensemble U)
-      (Power_set_PO A)
-      (Couple (Ensemble U) a b)
-      (Intersection U a b)).
-Intros A a b H' H'0.
-Apply Glb_definition; Simpl.
-Apply Lower_Bound_definition; Simpl; Auto with sets.
-Apply Definition_of_Power_set.
-Generalize Inclusion_is_transitive; Intro IT; Red in IT; Apply IT with a; Auto with sets.
-Intros y H'1; Elim H'1; Auto with sets.
-Intros y H'1; Elim H'1; Simpl; Auto with sets.
-Qed.
-
-End The_power_set_partial_order.
-
-Hints Resolve Empty_set_minimal : sets v62.
-Hints Resolve Power_set_Inhabited : sets v62.
-Hints Resolve Inclusion_is_an_order : sets v62.
-Hints Resolve Inclusion_is_transitive : sets v62.
-Hints Resolve Union_minimal : sets v62.
-Hints Resolve Union_increases_l : sets v62.
-Hints Resolve Union_increases_r : sets v62.
-Hints Resolve Intersection_decreases_l : sets v62.
-Hints Resolve Intersection_decreases_r : sets v62.
-Hints Resolve Empty_set_is_Bottom : sets v62.
-Hints Resolve Strict_inclusion_is_transitive : sets v62.
diff --git a/theories7/Sets/Powerset_Classical_facts.v b/theories7/Sets/Powerset_Classical_facts.v
deleted file mode 100755
index 1a51c562..00000000
--- a/theories7/Sets/Powerset_Classical_facts.v
+++ /dev/null
@@ -1,338 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Powerset_Classical_facts.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Export Ensembles.
-Require Export Constructive_sets.
-Require Export Relations_1.
-Require Export Relations_1_facts.
-Require Export Partial_Order.
-Require Export Cpo.
-Require Export Powerset.
-Require Export Powerset_facts.
-Require Export Classical_Type.
-Require Export Classical_sets.
-
-Section Sets_as_an_algebra.
-
-Variable U: Type.
-
-Lemma sincl_add_x:
-  (A, B: (Ensemble U))
-  (x: U) ~ (In U A x) -> (Strict_Included U (Add U A x) (Add U B x)) ->
-                         (Strict_Included U A B).
-Proof.
-Intros A B x H' H'0; Red.
-LApply (Strict_Included_inv U (Add U A x) (Add U B x)); Auto with sets.
-Clear H'0; Intro H'0; Split.
-Apply incl_add_x with x := x; Tauto.
-Elim H'0; Intros H'1 H'2; Elim H'2; Clear H'0 H'2.
-Intros x0 H'0.
-Red; Intro H'2.
-Elim H'0; Clear H'0.
-Rewrite <- H'2; Auto with sets.
-Qed.
-
-Lemma incl_soustr_in:
-  (X: (Ensemble U)) (x: U) (In U X x) -> (Included U (Subtract U X x) X).
-Proof.
-Intros X x H'; Red.
-Intros x0 H'0; Elim H'0; Auto with sets.
-Qed.
-Hints Resolve incl_soustr_in : sets v62.
-
-Lemma incl_soustr:
-  (X, Y: (Ensemble U)) (x: U) (Included U X Y) ->
-   (Included U (Subtract U X x) (Subtract U Y x)).
-Proof.
-Intros X Y x H'; Red.
-Intros x0 H'0; Elim H'0.
-Intros H'1 H'2.
-Apply Subtract_intro; Auto with sets.
-Qed.
-Hints Resolve incl_soustr : sets v62.
-
-
-Lemma incl_soustr_add_l:
-  (X: (Ensemble U)) (x: U) (Included U (Subtract U (Add U X x) x) X).
-Proof.
-Intros X x; Red.
-Intros x0 H'; Elim H'; Auto with sets.
-Intro H'0; Elim H'0; Auto with sets.
-Intros t H'1 H'2; Elim H'2; Auto with sets.
-Qed.
-Hints Resolve incl_soustr_add_l : sets v62.
-
-Lemma incl_soustr_add_r:
-  (X: (Ensemble U)) (x: U) ~ (In U X x) ->
-   (Included U X (Subtract U (Add U X x) x)).
-Proof.
-Intros X x H'; Red.
-Intros x0 H'0; Try Assumption.
-Apply Subtract_intro; Auto with sets.
-Red; Intro H'1; Apply H'; Rewrite H'1; Auto with sets.
-Qed.
-Hints Resolve incl_soustr_add_r : sets v62.
-
-Lemma add_soustr_2:
-  (X: (Ensemble U)) (x: U) (In U X x) ->
-   (Included U X (Add U (Subtract U X x) x)).
-Proof.
-Intros X x H'; Red.
-Intros x0 H'0; Try Assumption.
-Elim (classic x == x0); Intro K; Auto with sets.
-Elim K; Auto with sets.
-Qed.
-
-Lemma add_soustr_1:
-  (X: (Ensemble U)) (x: U) (In U X x) ->
-   (Included U (Add U (Subtract U X x) x) X).
-Proof.
-Intros X x H'; Red.
-Intros x0 H'0; Elim H'0; Auto with sets.
-Intros y H'1; Elim H'1; Auto with sets.
-Intros t H'1; Try Assumption.
-Rewrite <- (Singleton_inv U x t); Auto with sets.
-Qed.
-Hints Resolve add_soustr_1 add_soustr_2 : sets v62.
-
-Lemma add_soustr_xy:
-  (X: (Ensemble U)) (x, y: U) ~ x == y ->
-    (Subtract U (Add U X x) y) == (Add U (Subtract U X y) x).
-Proof.
-Intros X x y H'; Apply Extensionality_Ensembles.
-Split; Red.
-Intros x0 H'0; Elim H'0; Auto with sets.
-Intro H'1; Elim H'1.
-Intros u H'2 H'3; Try Assumption.
-Apply Add_intro1.
-Apply Subtract_intro; Auto with sets.
-Intros t H'2 H'3; Try Assumption.
-Elim (Singleton_inv U x t); Auto with sets.
-Intros u H'2; Try Assumption.
-Elim (Add_inv U (Subtract U X y) x u); Auto with sets.
-Intro H'0; Elim H'0; Auto with sets.
-Intro H'0; Rewrite <- H'0; Auto with sets.
-Qed.
-Hints Resolve add_soustr_xy : sets v62.
-
-Lemma incl_st_add_soustr:
-  (X, Y: (Ensemble U)) (x: U) ~ (In U X x) -> 
-   (Strict_Included U (Add U X x) Y) ->
-   (Strict_Included U X (Subtract U Y x)).
-Proof.
-Intros X Y x H' H'0; Apply sincl_add_x with x := x; Auto with sets.
-Split.
-Elim H'0.
-Intros H'1 H'2.
-Generalize (Inclusion_is_transitive U).
-Intro H'4; Red in H'4.
-Apply H'4 with y := Y; Auto with sets.
-Red in H'0.
-Elim H'0; Intros H'1 H'2; Try Exact H'1; Clear H'0. (* PB *)
-Red; Intro H'0; Apply H'2.
-Rewrite H'0; Auto 8 with sets.
-Qed.
-
-Lemma Sub_Add_new:
-  (X: (Ensemble U)) (x: U) ~ (In U X x) -> X == (Subtract U (Add U X x) x).
-Proof.
-Auto with sets.
-Qed.
-
-Lemma Simplify_add:
-  (X, X0 : (Ensemble U)) (x: U)
-  ~ (In U X x) -> ~ (In U X0 x) ->  (Add U X x) == (Add U X0 x) -> X == X0.
-Proof.
-Intros X X0 x H' H'0 H'1; Try Assumption.
-Rewrite (Sub_Add_new X x); Auto with sets.
-Rewrite (Sub_Add_new X0 x); Auto with sets.
-Rewrite H'1; Auto with sets.
-Qed.
-
-Lemma Included_Add:
-  (X, A: (Ensemble U)) (x: U) (Included U X (Add U A x)) ->
-   (Included U X A) \/
-   (EXT A' | X == (Add U A' x) /\ (Included U A' A)).
-Proof.
-Intros X A x H'0; Try Assumption.
-Elim (classic (In U X x)).
-Intro H'1; Right; Try Assumption.
-Exists (Subtract U X x).
-Split; Auto with sets.
-Red in H'0.
-Red.
-Intros x0 H'2; Try Assumption.
-LApply (Subtract_inv U X x x0); Auto with sets.
-Intro H'3; Elim H'3; Intros K K'; Clear H'3.
-LApply (H'0 x0); Auto with sets.
-Intro H'3; Try Assumption.
-LApply (Add_inv U A x x0); Auto with sets.
-Intro H'4; Elim H'4;
- [Intro H'5; Try Exact H'5; Clear H'4 | Intro H'5; Clear H'4].
-Elim K'; Auto with sets.
-Intro H'1; Left; Try Assumption.
-Red in H'0.
-Red.
-Intros x0 H'2; Try Assumption.
-LApply (H'0 x0); Auto with sets.
-Intro H'3; Try Assumption.
-LApply (Add_inv U A x x0); Auto with sets.
-Intro H'4; Elim H'4;
- [Intro H'5; Try Exact H'5; Clear H'4 | Intro H'5; Clear H'4].
-Absurd (In U X x0); Auto with sets.
-Rewrite <- H'5; Auto with sets.
-Qed.
-
-Lemma setcover_inv:
- (A: (Ensemble U))
- (x, y: (Ensemble U)) (covers (Ensemble U) (Power_set_PO U A) y x) ->
- (Strict_Included U x y) /\
- ((z: (Ensemble U)) (Included U x z) -> (Included U z y) -> x == z \/ z == y).
-Proof.
-Intros A x y H'; Elim H'.
-Unfold Strict_Rel_of; Simpl.
-Intros H'0 H'1; Split; [Auto with sets | Idtac].
-Intros z H'2 H'3; Try Assumption.
-Elim (classic  x == z); Auto with sets.
-Intro H'4; Right; Try Assumption.
-Elim (classic  z == y); Auto with sets.
-Intro H'5; Try Assumption.
-Elim H'1.
-Exists z; Auto with sets.
-Qed.
-
-Theorem Add_covers:
-  (A: (Ensemble U)) (a: (Ensemble U)) (Included U a A) ->
-   (x: U) (In U A x) -> ~ (In U a x) ->
-    (covers (Ensemble U) (Power_set_PO U A) (Add U a x) a).
-Proof.
-Intros A a H' x H'0 H'1; Try Assumption.
-Apply setcover_intro; Auto with sets.
-Red.
-Split; [Idtac | Red; Intro H'2; Try Exact H'2]; Auto with sets.
-Apply H'1.
-Rewrite H'2; Auto with sets.
-Red; Intro H'2; Elim H'2; Clear H'2.
-Intros z H'2; Elim H'2; Intros H'3 H'4; Try Exact H'3; Clear H'2.
-LApply (Strict_Included_inv U a z); Auto with sets; Clear H'3.
-Intro H'2; Elim H'2; Intros H'3 H'5; Elim H'5; Clear H'2 H'5.
-Intros x0 H'2; Elim H'2.
-Intros H'5 H'6; Try Assumption.
-Generalize H'4; Intro K.
-Red in H'4.
-Elim H'4; Intros H'8 H'9; Red in H'8; Clear H'4.
-LApply (H'8 x0); Auto with sets.
-Intro H'7; Try Assumption.
-Elim (Add_inv U a x x0); Auto with sets.
-Intro H'15.
-Cut (Included U (Add U a x) z).
-Intro H'10; Try Assumption.
-Red in K.
-Elim K; Intros H'11 H'12; Apply H'12; Clear K; Auto with sets.
-Rewrite H'15.
-Red.
-Intros x1 H'10; Elim H'10; Auto with sets.
-Intros x2 H'11; Elim H'11; Auto with sets.
-Qed.
-
-Theorem covers_Add:
-  (A: (Ensemble U))
-  (a, a': (Ensemble U))
-  (Included U a A) ->
-  (Included U a' A) -> (covers (Ensemble U) (Power_set_PO U A) a' a) ->
-   (EXT x | a' == (Add U a x) /\ ((In U A x) /\ ~ (In U a x))).
-Proof.
-Intros A a a' H' H'0 H'1; Try Assumption.
-Elim (setcover_inv A a a'); Auto with sets.
-Intros H'6 H'7.
-Clear H'1.
-Elim (Strict_Included_inv U a a'); Auto with sets.
-Intros H'5 H'8; Elim H'8.
-Intros x H'1; Elim H'1.
-Intros H'2 H'3; Try Assumption.
-Exists x.
-Split; [Try Assumption | Idtac].
-Clear H'8 H'1.
-Elim (H'7 (Add U a x)); Auto with sets.
-Intro H'1.
-Absurd a ==(Add U a x); Auto with sets.
-Red; Intro H'8; Try Exact H'8.
-Apply H'3.
-Rewrite H'8; Auto with sets.
-Auto with sets.
-Red.
-Intros x0 H'1; Elim H'1; Auto with sets.
-Intros x1 H'8; Elim H'8; Auto with sets.
-Split; [Idtac | Try Assumption].
-Red in H'0; Auto with sets.
-Qed.
-
-Theorem covers_is_Add:
-  (A: (Ensemble U))
-  (a, a': (Ensemble U)) (Included U a A) -> (Included U a' A) ->
-   (iff
-      (covers (Ensemble U) (Power_set_PO U A) a' a)
-      (EXT x | a' == (Add U a x) /\ ((In U A x) /\ ~ (In U a x)))).
-Proof.
-Intros A a a' H' H'0; Split; Intro K.
-Apply covers_Add with A := A; Auto with sets.
-Elim K.
-Intros x H'1; Elim H'1; Intros H'2 H'3; Rewrite H'2; Clear H'1.
-Apply Add_covers; Intuition.
-Qed.
-
-Theorem Singleton_atomic:
-  (x:U) (A:(Ensemble U)) (In U A x) ->
-  (covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U)).
-Intros x A H'.
-Rewrite <- (Empty_set_zero' U x).
-Apply Add_covers; Auto with sets.
-Qed.
-
-Lemma less_than_singleton:
-  (X:(Ensemble U)) (x:U) (Strict_Included U X (Singleton U x)) ->
-  X ==(Empty_set U).
-Intros X x H'; Try Assumption.
-Red in H'.
-LApply (Singleton_atomic x (Full_set U));
- [Intro H'2; Try Exact H'2 | Apply Full_intro].
-Elim H'; Intros H'0 H'1; Try Exact H'1; Clear H'.
-Elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x));
- [Intros H'6 H'7; Try Exact H'7 | Idtac]; Auto with sets.
-Elim (H'7 X); [Intro H'5; Try Exact H'5 | Intro H'5 | Idtac | Idtac]; Auto with sets.
-Elim H'1; Auto with sets.
-Qed.
-
-End Sets_as_an_algebra.
-
-Hints Resolve incl_soustr_in : sets v62.
-Hints Resolve incl_soustr : sets v62.
-Hints Resolve incl_soustr_add_l : sets v62.
-Hints Resolve incl_soustr_add_r : sets v62.
-Hints Resolve add_soustr_1 add_soustr_2 : sets v62.
-Hints Resolve add_soustr_xy : sets v62.
diff --git a/theories7/Sets/Powerset_facts.v b/theories7/Sets/Powerset_facts.v
deleted file mode 100755
index fbe7d93e..00000000
--- a/theories7/Sets/Powerset_facts.v
+++ /dev/null
@@ -1,276 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Powerset_facts.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Require Export Ensembles.
-Require Export Constructive_sets.
-Require Export Relations_1.
-Require Export Relations_1_facts.
-Require Export Partial_Order.
-Require Export Cpo.
-Require Export Powerset.
-
-Section Sets_as_an_algebra.
-Variable U: Type.
-Hints Unfold not.
-
-Theorem Empty_set_zero :
-  (X: (Ensemble U)) (Union U (Empty_set U) X) == X.
-Proof.
-Auto 6 with sets.
-Qed.
-Hints Resolve Empty_set_zero.
-
-Theorem Empty_set_zero' :
-  (x: U) (Add U (Empty_set U) x) == (Singleton U x).
-Proof.
-Unfold 1 Add; Auto with sets.
-Qed.
-Hints Resolve Empty_set_zero'.
-
-Lemma less_than_empty :
-  (X: (Ensemble U)) (Included U X (Empty_set U)) -> X == (Empty_set U).
-Proof.
-Auto with sets.
-Qed.
-Hints Resolve less_than_empty.
-
-Theorem Union_commutative :
-  (A,B: (Ensemble U)) (Union U A B) == (Union U B A).
-Proof.
-Auto with sets.
-Qed.
-
-Theorem Union_associative :
-  (A, B, C: (Ensemble U))
-  (Union U (Union U A B) C) == (Union U A (Union U B C)).
-Proof.
-Auto 9 with sets.
-Qed.
-Hints Resolve Union_associative.
-
-Theorem Union_idempotent : (A: (Ensemble U)) (Union U A A) == A.
-Proof.
-Auto 7 with sets.
-Qed.
-
-Lemma Union_absorbs :
-  (A, B: (Ensemble U)) (Included U B A) -> (Union U A B) == A.
-Proof.
-Auto 7 with sets.
-Qed.
-
-Theorem Couple_as_union:
-  (x, y: U) (Union U (Singleton U x) (Singleton U y)) == (Couple U x y).
-Proof.
-Intros x y; Apply Extensionality_Ensembles; Split; Red.
-Intros x0 H'; Elim H'; (Intros x1 H'0; Elim H'0; Auto with sets).
-Intros x0 H'; Elim H'; Auto with sets.
-Qed.
-
-Theorem Triple_as_union :
-  (x, y, z: U)
-  (Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z)) ==
-  (Triple U x y z).
-Proof.
-Intros x y z; Apply Extensionality_Ensembles; Split; Red.
-Intros x0 H'; Elim H'.
-Intros x1 H'0; Elim H'0; (Intros x2 H'1; Elim H'1; Auto with sets).
-Intros x1 H'0; Elim H'0; Auto with sets.
-Intros x0 H'; Elim H'; Auto with sets.
-Qed.
-
-Theorem Triple_as_Couple : (x, y: U) (Couple U x y) == (Triple U x x y).
-Proof.
-Intros x y.
-Rewrite <- (Couple_as_union x y).
-Rewrite <- (Union_idempotent (Singleton U x)).
-Apply Triple_as_union.
-Qed.
-
-Theorem Triple_as_Couple_Singleton :
-  (x, y, z: U) (Triple U x y z) == (Union U (Couple U x y) (Singleton U z)).
-Proof.
-Intros x y z.
-Rewrite <- (Triple_as_union x y z).
-Rewrite <- (Couple_as_union x y); Auto with sets.
-Qed.
-
-Theorem Intersection_commutative :
-  (A,B: (Ensemble U)) (Intersection U A B) == (Intersection U B A).
-Proof.
-Intros A B.
-Apply Extensionality_Ensembles.
-Split; Red; Intros x H'; Elim H'; Auto with sets.
-Qed.
-
-Theorem Distributivity :
-  (A, B, C: (Ensemble U))
-     (Intersection U A (Union U B C)) ==
-     (Union U (Intersection U A B) (Intersection U A C)).
-Proof.
-Intros A B C.
-Apply Extensionality_Ensembles.
-Split; Red; Intros x H'.
-Elim H'.
-Intros x0 H'0 H'1; Generalize H'0.
-Elim H'1; Auto with sets.
-Elim H'; Intros x0 H'0; Elim H'0; Auto with sets.
-Qed.
-
-Theorem Distributivity' :
-  (A, B, C: (Ensemble U))
-     (Union U A (Intersection U B C)) ==
-     (Intersection U (Union U A B) (Union U A C)).
-Proof.
-Intros A B C.
-Apply Extensionality_Ensembles.
-Split; Red; Intros x H'.
-Elim H'; Auto with sets.
-Intros x0 H'0; Elim H'0; Auto with sets.
-Elim H'.
-Intros x0 H'0; Elim H'0; Auto with sets.
-Intros x1 H'1 H'2; Try Exact H'2.
-Generalize H'1.
-Elim H'2; Auto with sets.
-Qed.
-
-Theorem Union_add :
-  (A, B: (Ensemble U)) (x: U)
-    (Add U (Union U A B) x) == (Union U A (Add U B x)).
-Proof.
-Unfold Add; Auto with sets.
-Qed.
-Hints Resolve Union_add.
-
-Theorem Non_disjoint_union :
-  (X: (Ensemble U)) (x: U) (In U X x) -> (Add U X x) == X.
-Intros X x H'; Unfold Add.
-Apply Extensionality_Ensembles; Red.
-Split; Red; Auto with sets.
-Intros x0 H'0; Elim H'0; Auto with sets.
-Intros t H'1; Elim H'1; Auto with sets.
-Qed.
-
-Theorem Non_disjoint_union' :
-  (X: (Ensemble U)) (x: U) ~ (In U X x) -> (Subtract U X x) == X.
-Proof.
-Intros X x H'; Unfold Subtract.
-Apply Extensionality_Ensembles.
-Split; Red; Auto with sets.
-Intros x0 H'0; Elim H'0; Auto with sets.
-Intros x0 H'0; Apply Setminus_intro; Auto with sets.
-Red; Intro H'1; Elim H'1.
-LApply (Singleton_inv U x x0); Auto with sets.
-Intro H'4; Apply H'; Rewrite H'4; Auto with sets.
-Qed.
-
-Lemma singlx : (x, y: U) (In U (Add U (Empty_set U) x) y) -> x == y.
-Proof.
-Intro x; Rewrite (Empty_set_zero' x); Auto with sets.
-Qed.
-Hints Resolve singlx.
-
-Lemma incl_add :
-  (A, B: (Ensemble U)) (x: U) (Included U A B) ->
-   (Included U (Add U A x) (Add U B x)).
-Proof.
-Intros A B x H'; Red; Auto with sets.
-Intros x0 H'0.
-LApply (Add_inv U A x x0); Auto with sets.
-Intro H'1; Elim H'1;
- [Intro H'2; Clear H'1 | Intro H'2; Rewrite <- H'2; Clear H'1]; Auto with sets.
-Qed.
-Hints Resolve incl_add.
-
-Lemma incl_add_x :
-  (A, B: (Ensemble U))
-  (x: U) ~ (In U A x) -> (Included U (Add U A x) (Add U B x)) ->
-   (Included U A B).
-Proof.
-Unfold Included.
-Intros A B x H' H'0 x0 H'1.
-LApply (H'0 x0); Auto with sets.
-Intro H'2; LApply (Add_inv U B x x0); Auto with sets.
-Intro H'3; Elim H'3;
- [Intro H'4; Try Exact H'4; Clear H'3 | Intro H'4; Clear H'3].
-Absurd (In U A x0); Auto with sets.
-Rewrite <- H'4; Auto with sets.
-Qed.
-
-Lemma Add_commutative :
-  (A: (Ensemble U)) (x, y: U) (Add U (Add U A x) y) == (Add U (Add U A y) x).
-Proof.
-Intros A x y.
-Unfold Add.
-Rewrite (Union_associative A (Singleton U x) (Singleton U y)).
-Rewrite (Union_commutative (Singleton U x) (Singleton U y)).
-Rewrite <- (Union_associative A (Singleton U y) (Singleton U x)); Auto with sets.
-Qed.
-
-Lemma Add_commutative' :
-  (A: (Ensemble U)) (x, y, z: U)
-    (Add U (Add U (Add U A x) y) z) == (Add U (Add U (Add U A z) x) y).
-Proof.
-Intros A x y z.
-Rewrite (Add_commutative (Add U A x) y z).
-Rewrite (Add_commutative A x z); Auto with sets.
-Qed.
-
-Lemma Add_distributes :
-  (A, B: (Ensemble U)) (x, y: U) (Included U B A) ->
-  (Add U (Add U A x) y) == (Union U (Add U A x) (Add U B y)).
-Proof.
-Intros A B x y H'; Try Assumption.
-Rewrite <- (Union_add (Add U A x) B y).
-Unfold 4 Add.
-Rewrite (Union_commutative A (Singleton U x)).
-Rewrite Union_associative.
-Rewrite (Union_absorbs A B H').
-Rewrite (Union_commutative (Singleton U x) A).
-Auto with sets.
-Qed.
-
-Lemma setcover_intro :
-  (U: Type)
-  (A: (Ensemble U))
-  (x, y: (Ensemble U))
-  (Strict_Included U x y) ->
-  ~ (EXT z | (Strict_Included U x z) 
-              /\ (Strict_Included U z y)) ->
-   (covers (Ensemble U) (Power_set_PO U A) y x).
-Proof.
-Intros; Apply Definition_of_covers; Auto with sets.
-Qed.
-Hints Resolve setcover_intro.
-
-End Sets_as_an_algebra.
-
-Hints Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add
-	singlx incl_add : sets v62.
-
-
diff --git a/theories7/Sets/Relations_1.v b/theories7/Sets/Relations_1.v
deleted file mode 100755
index d4ed823b..00000000
--- a/theories7/Sets/Relations_1.v
+++ /dev/null
@@ -1,67 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Relations_1.v,v 1.1.2.1 2004/07/16 19:31:39 herbelin Exp $ i*)
-
-Section Relations_1.
-   Variable U: Type.
-   
-   Definition Relation :=  U -> U -> Prop.
-   Variable R: Relation.
-   
-   Definition Reflexive : Prop :=  (x: U) (R x x).
-   
-   Definition Transitive : Prop :=  (x,y,z: U) (R x y) -> (R y z) -> (R x z).
-   
-   Definition Symmetric : Prop :=  (x,y: U) (R x y) -> (R y x).
-   
-   Definition Antisymmetric : Prop :=
-      (x: U) (y: U) (R x y) -> (R y x) -> x == y.
-   
-   Definition contains : Relation -> Relation -> Prop :=
-      [R,R': Relation] (x: U) (y: U) (R' x y) -> (R x y).
-   
-   Definition same_relation : Relation -> Relation -> Prop :=
-      [R,R': Relation] (contains R R') /\ (contains R' R).
-   
-   Inductive Preorder : Prop :=
-         Definition_of_preorder: Reflexive -> Transitive -> Preorder.
-   
-   Inductive Order : Prop :=
-         Definition_of_order: Reflexive -> Transitive -> Antisymmetric -> Order.
-   
-   Inductive Equivalence : Prop :=
-         Definition_of_equivalence:
-           Reflexive -> Transitive -> Symmetric -> Equivalence.
-   
-   Inductive PER : Prop :=
-         Definition_of_PER: Symmetric -> Transitive -> PER.
-   
-End Relations_1.
-Hints Unfold Reflexive Transitive Antisymmetric Symmetric contains 
-	same_relation : sets v62.
-Hints Resolve Definition_of_preorder Definition_of_order 
-	Definition_of_equivalence Definition_of_PER : sets v62.
diff --git a/theories7/Sets/Relations_1_facts.v b/theories7/Sets/Relations_1_facts.v
deleted file mode 100755
index cf73ce8b..00000000
--- a/theories7/Sets/Relations_1_facts.v
+++ /dev/null
@@ -1,109 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Relations_1_facts.v,v 1.1.2.1 2004/07/16 19:31:40 herbelin Exp $ i*)
-
-Require Export Relations_1.
-
-Definition Complement : (U: Type) (Relation U) -> (Relation U) :=
-   [U: Type] [R: (Relation U)] [x,y: U] ~ (R x y).
-
-Theorem Rsym_imp_notRsym: (U: Type) (R: (Relation U)) (Symmetric U R) ->
-            (Symmetric U (Complement U R)).
-Proof.
-Unfold Symmetric Complement.
-Intros U R H' x y H'0; Red; Intro H'1; Apply H'0; Auto with sets.
-Qed.
-
-Theorem Equiv_from_preorder :
-  (U: Type) (R: (Relation U)) (Preorder U R) ->
-            (Equivalence U [x,y: U] (R x y) /\ (R y x)).
-Proof.
-Intros U R H'; Elim H'; Intros H'0 H'1.
-Apply Definition_of_equivalence.
-Red in H'0; Auto 10 with sets.
-2:Red; Intros x y h; Elim h; Intros H'3 H'4; Auto 10 with sets.
-Red in H'1; Red; Auto 10 with sets.
-Intros x y z h; Elim h; Intros H'3 H'4; Clear h.
-Intro h; Elim h; Intros H'5 H'6; Clear h.
-Split; Apply H'1 with y; Auto 10 with sets.
-Qed.
-Hints Resolve Equiv_from_preorder.
-
-Theorem Equiv_from_order :
-  (U: Type) (R: (Relation U)) (Order U R) ->
-            (Equivalence U [x,y: U] (R x y) /\ (R y x)).
-Proof.
-Intros U R H'; Elim H'; Auto 10 with sets.
-Qed.
-Hints Resolve Equiv_from_order.
-
-Theorem contains_is_preorder :
-  (U: Type) (Preorder (Relation U) (contains U)).
-Proof.
-Auto 10 with sets.
-Qed.
-Hints Resolve contains_is_preorder.
-
-Theorem same_relation_is_equivalence :
-  (U: Type) (Equivalence (Relation U) (same_relation U)).
-Proof.
-Unfold 1 same_relation; Auto 10 with sets.
-Qed.
-Hints Resolve same_relation_is_equivalence.
-
-Theorem cong_reflexive_same_relation:
-  (U:Type) (R, R':(Relation U)) (same_relation U R R') -> (Reflexive U R) ->
-  (Reflexive U R').
-Proof.
-Unfold same_relation; Intuition.
-Qed.
-
-Theorem cong_symmetric_same_relation:
-  (U:Type) (R, R':(Relation U)) (same_relation U R R') -> (Symmetric U R) ->
-  (Symmetric U R').
-Proof.
-  Compute;Intros;Elim H;Intros;Clear H;Apply (H3 y x (H0 x y (H2 x y H1))).
-(*Intuition.*)
-Qed.
-
-Theorem cong_antisymmetric_same_relation:
-  (U:Type) (R, R':(Relation U)) (same_relation U R R') ->
-           (Antisymmetric U R) -> (Antisymmetric U R').
-Proof.
-  Compute;Intros;Elim H;Intros;Clear H;Apply (H0 x y (H3 x y H1) (H3 y x H2)).
-(*Intuition.*)
-Qed.
-
-Theorem cong_transitive_same_relation:
-  (U:Type) (R, R':(Relation U)) (same_relation U R R') -> (Transitive U R) ->
-  (Transitive U R').
-Proof.
-Intros U R R' H' H'0; Red.
-Elim H'.
-Intros H'1 H'2 x y z H'3 H'4; Apply H'2.
-Apply H'0 with y; Auto with sets.
-Qed.
diff --git a/theories7/Sets/Relations_2.v b/theories7/Sets/Relations_2.v
deleted file mode 100755
index 92a1236e..00000000
--- a/theories7/Sets/Relations_2.v
+++ /dev/null
@@ -1,56 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Relations_2.v,v 1.1.2.1 2004/07/16 19:31:40 herbelin Exp $ i*)
-
-Require Export Relations_1.
-
-Section Relations_2.
-Variable U: Type.
-Variable R: (Relation U).
-
-Inductive Rstar : (Relation U) :=
-     Rstar_0: (x: U) (Rstar x x)
-   | Rstar_n: (x, y, z: U) (R x y) -> (Rstar y z) -> (Rstar x z).
-
-Inductive Rstar1 : (Relation U) :=
-     Rstar1_0: (x: U) (Rstar1 x x)
-   | Rstar1_1: (x: U) (y: U) (R x y) -> (Rstar1 x y)
-   | Rstar1_n: (x, y, z: U) (Rstar1 x y) -> (Rstar1 y z) -> (Rstar1 x z).
-
-Inductive Rplus : (Relation U) :=
-     Rplus_0: (x, y: U) (R x y) -> (Rplus x y)
-   | Rplus_n: (x, y, z: U) (R x y) -> (Rplus y z) -> (Rplus x z).
-
-Definition Strongly_confluent : Prop :=
-   (x, a, b: U) (R x a) -> (R x b) -> (exT U [z: U] (R a z) /\ (R b z)).
-
-End Relations_2.
-
-Hints Resolve Rstar_0 : sets v62.
-Hints Resolve Rstar1_0 : sets v62.
-Hints Resolve Rstar1_1 : sets v62.
-Hints Resolve Rplus_0 : sets v62.
diff --git a/theories7/Sets/Relations_2_facts.v b/theories7/Sets/Relations_2_facts.v
deleted file mode 100755
index b82438eb..00000000
--- a/theories7/Sets/Relations_2_facts.v
+++ /dev/null
@@ -1,151 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Relations_2_facts.v,v 1.1.2.1 2004/07/16 19:31:40 herbelin Exp $ i*)
-
-Require Export Relations_1.
-Require Export Relations_1_facts.
-Require Export Relations_2.
-
-Theorem Rstar_reflexive : 
-  (U: Type) (R: (Relation U)) (Reflexive U (Rstar U R)).
-Proof.
-Auto with sets.
-Qed.
-
-Theorem Rplus_contains_R :
-  (U: Type) (R: (Relation U)) (contains U (Rplus U R) R).
-Proof.
-Auto with sets.
-Qed.
-
-Theorem Rstar_contains_R :
-  (U: Type) (R: (Relation U)) (contains U (Rstar U R) R).
-Proof.
-Intros U R; Red; Intros x y H'; Apply Rstar_n with y; Auto with sets.
-Qed.
-
-Theorem Rstar_contains_Rplus :
-  (U: Type) (R: (Relation U)) (contains U (Rstar U R) (Rplus U R)).
-Proof.
-Intros U R; Red.
-Intros x y H'; Elim H'.
-Generalize Rstar_contains_R; Intro T; Red in T; Auto with sets.
-Intros x0 y0 z H'0 H'1 H'2; Apply Rstar_n with y0; Auto with sets.
-Qed.
-
-Theorem Rstar_transitive :
-  (U: Type) (R: (Relation U)) (Transitive U (Rstar U R)).
-Proof.
-Intros U R; Red.
-Intros x y z H'; Elim H'; Auto with sets.
-Intros x0 y0 z0 H'0 H'1 H'2 H'3; Apply Rstar_n with y0; Auto with sets.
-Qed.
-
-Theorem Rstar_cases :
-  (U: Type) (R: (Relation U)) (x, y: U) (Rstar U R x y) ->
-    x == y \/ (EXT u | (R x u) /\ (Rstar U R u y)).
-Proof.
-Intros U R x y H'; Elim H'; Auto with sets.
-Intros x0 y0 z H'0 H'1 H'2; Right; Exists y0; Auto with sets.
-Qed.
-
-Theorem Rstar_equiv_Rstar1 :
-  (U: Type) (R: (Relation U)) (same_relation U (Rstar U R) (Rstar1 U R)).
-Proof.
-Generalize Rstar_contains_R; Intro T; Red in T.
-Intros U R; Unfold same_relation contains.
-Split; Intros x y H'; Elim H'; Auto with sets.
-Generalize Rstar_transitive; Intro T1; Red in T1.
-Intros x0 y0 z H'0 H'1 H'2 H'3; Apply T1 with y0; Auto with sets.
-Intros x0 y0 z H'0 H'1 H'2; Apply Rstar1_n with y0; Auto with sets.
-Qed.
-
-Theorem Rsym_imp_Rstarsym :
-  (U: Type) (R: (Relation U)) (Symmetric U R) -> (Symmetric U (Rstar U R)).
-Proof.
-Intros U R H'; Red.
-Intros x y H'0; Elim H'0; Auto with sets.
-Intros x0 y0 z H'1 H'2 H'3.
-Generalize Rstar_transitive; Intro T1; Red in T1.
-Apply T1 with y0; Auto with sets.
-Apply Rstar_n with x0; Auto with sets.
-Qed.
-
-Theorem Sstar_contains_Rstar :
-  (U: Type) (R, S: (Relation U)) (contains U (Rstar U S) R) ->
-   (contains U (Rstar U S) (Rstar U R)).
-Proof.
-Unfold contains.
-Intros U R S H' x y H'0; Elim H'0; Auto with sets.
-Generalize Rstar_transitive; Intro T1; Red in T1.
-Intros x0 y0 z H'1 H'2 H'3; Apply T1 with y0; Auto with sets.
-Qed.
-
-Theorem star_monotone :
-  (U: Type) (R, S: (Relation U)) (contains U S R) ->
-   (contains U (Rstar U S) (Rstar U R)).
-Proof.
-Intros U R S H'.
-Apply Sstar_contains_Rstar; Auto with sets.
-Generalize (Rstar_contains_R U S); Auto with sets.
-Qed.
-
-Theorem RstarRplus_RRstar :
-  (U: Type) (R: (Relation U)) (x, y, z: U) 
-    (Rstar U R x y) -> (Rplus U R y z) ->
-    (EXT u | (R x u) /\ (Rstar U R u z)).
-Proof.
-Generalize Rstar_contains_Rplus; Intro T; Red in T.
-Generalize Rstar_transitive; Intro T1; Red in T1.
-Intros U R x y z H'; Elim H'.
-Intros x0 H'0; Elim H'0.
-Intros x1 y0 H'1; Exists y0; Auto with sets.
-Intros x1 y0 z0 H'1 H'2 H'3; Exists y0; Auto with sets.
-Intros x0 y0 z0 H'0 H'1 H'2 H'3; Exists y0.
-Split; [Try Assumption | Idtac].
-Apply T1 with z0; Auto with sets.
-Qed.
-
-Theorem Lemma1 : 
-  (U: Type) (R: (Relation U)) (Strongly_confluent U R) ->
-   (x, b: U) (Rstar U R x b) ->
-    (a: U) (R x a) -> (EXT z | (Rstar U R a z) /\ (R b z)).
-Proof.
-Intros U R H' x b H'0; Elim H'0.
-Intros x0 a H'1; Exists a; Auto with sets.
-Intros x0 y z H'1 H'2 H'3 a H'4.
-Red in H'.
-Specialize 3 H' with x := x0 a := a b := y; Intro H'7; LApply H'7;
- [Intro H'8; LApply H'8;
-   [Intro H'9; Try Exact H'9; Clear H'8 H'7 | Clear H'8 H'7] | Clear H'7]; Auto with sets.
-Elim H'9.
-Intros t H'5; Elim H'5; Intros H'6 H'7; Try Exact H'6; Clear H'5.
-Elim (H'3 t); Auto with sets.
-Intros z1 H'5; Elim H'5; Intros H'8 H'10; Try Exact H'8; Clear H'5.
-Exists z1; Split; [Idtac | Assumption].
-Apply Rstar_n with t; Auto with sets.
-Qed.
diff --git a/theories7/Sets/Relations_3.v b/theories7/Sets/Relations_3.v
deleted file mode 100755
index 092fc534..00000000
--- a/theories7/Sets/Relations_3.v
+++ /dev/null
@@ -1,63 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Relations_3.v,v 1.1.2.1 2004/07/16 19:31:40 herbelin Exp $ i*)
-
-Require Export Relations_1.
-Require Export Relations_2.
-
-Section Relations_3.
-   Variable U: Type.
-   Variable R: (Relation U).
-   
-   Definition coherent : U -> U -> Prop :=
-      [x,y: U]  (EXT z | (Rstar U R x z) /\ (Rstar U R y z)).
-   
-   Definition locally_confluent : U -> Prop :=
-      [x: U] (y,z: U) (R x y) -> (R x z) -> (coherent y z).
-   
-   Definition Locally_confluent : Prop :=  (x: U) (locally_confluent x).
-   
-   Definition confluent : U -> Prop :=
-      [x: U] (y,z: U) (Rstar U R x y) -> (Rstar U R x z) -> (coherent y z).
-   
-   Definition Confluent : Prop :=  (x: U) (confluent x).
-   
-   Inductive  noetherian : U -> Prop :=
-         definition_of_noetherian:
-           (x: U) ((y: U) (R x y) -> (noetherian y)) -> (noetherian x).
-   
-   Definition Noetherian : Prop :=  (x: U) (noetherian x).
-   
-End Relations_3.
-Hints Unfold  coherent : sets v62.
-Hints Unfold  locally_confluent : sets v62.
-Hints Unfold  confluent : sets v62.
-Hints Unfold  Confluent : sets v62.
-Hints Resolve definition_of_noetherian : sets v62.
-Hints Unfold  Noetherian : sets v62.
-
-
diff --git a/theories7/Sets/Relations_3_facts.v b/theories7/Sets/Relations_3_facts.v
deleted file mode 100755
index 822f550a..00000000
--- a/theories7/Sets/Relations_3_facts.v
+++ /dev/null
@@ -1,157 +0,0 @@
-(************************************************************************)
-(*  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        *)
-(************************************************************************)
-(****************************************************************************)
-(*                                                                          *)
-(*                         Naive Set Theory in Coq                          *)
-(*                                                                          *)
-(*                     INRIA                        INRIA                   *)
-(*              Rocquencourt                        Sophia-Antipolis        *)
-(*                                                                          *)
-(*                                 Coq V6.1                                 *)
-(*									    *)
-(*			         Gilles Kahn 				    *)
-(*				 Gerard Huet				    *)
-(*									    *)
-(*									    *)
-(*                                                                          *)
-(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
-(* to the Newton Institute for providing an exceptional work environment    *)
-(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
-(****************************************************************************)
-
-(*i $Id: Relations_3_facts.v,v 1.1.2.1 2004/07/16 19:31:40 herbelin Exp $ i*)
-
-Require Export Relations_1.
-Require Export Relations_1_facts.
-Require Export Relations_2.
-Require Export Relations_2_facts.
-Require Export Relations_3.
-
-Theorem Rstar_imp_coherent :
-  (U: Type) (R: (Relation U)) (x: U) (y: U) (Rstar U R x y) ->
-   (coherent U R x y).
-Proof.
-Intros U R x y H'; Red.
-Exists y; Auto with sets.
-Qed.
-Hints Resolve Rstar_imp_coherent.
-
-Theorem coherent_symmetric :
-  (U: Type) (R: (Relation U)) (Symmetric U (coherent U R)).
-Proof.
-Unfold 1 coherent.
-Intros U R; Red.
-Intros x y H'; Elim H'.
-Intros z H'0; Exists z; Tauto.
-Qed.
-
-Theorem Strong_confluence :
-  (U: Type) (R: (Relation U)) (Strongly_confluent U R) -> (Confluent U R).
-Proof.
-Intros U R H'; Red.
-Intro x; Red; Intros a b H'0.
-Unfold 1 coherent.
-Generalize b; Clear b.
-Elim H'0; Clear H'0.
-Intros x0 b H'1; Exists b; Auto with sets.
-Intros x0 y z H'1 H'2 H'3 b H'4.
-Generalize (Lemma1 U R); Intro h; LApply h;
-  [Intro H'0; Generalize (H'0 x0 b); Intro h0; LApply h0;
-    [Intro H'5; Generalize (H'5 y); Intro h1; LApply h1;
-      [Intro h2; Elim h2; Intros z0 h3; Elim h3; Intros H'6 H'7;
-        Clear h h0 h1 h2 h3 | Clear h h0 h1] | Clear h h0] | Clear h]; Auto with sets.
-Generalize (H'3 z0); Intro h; LApply h;
-  [Intro h0; Elim h0; Intros z1 h1; Elim h1; Intros H'8 H'9; Clear h h0 h1 |
-    Clear h]; Auto with sets.
-Exists z1; Split; Auto with sets.
-Apply Rstar_n with z0; Auto with sets.
-Qed.
-
-Theorem Strong_confluence_direct :
-  (U: Type) (R: (Relation U)) (Strongly_confluent U R) -> (Confluent U R).
-Proof.
-Intros U R H'; Red.
-Intro x; Red; Intros a b H'0.
-Unfold 1 coherent.
-Generalize b; Clear b.
-Elim H'0; Clear H'0.
-Intros x0 b H'1; Exists b; Auto with sets.
-Intros x0 y z H'1 H'2 H'3 b H'4.
-Cut (exT U [t: U] (Rstar U R y t) /\ (R b t)).
-Intro h; Elim h; Intros t h0; Elim h0; Intros H'0 H'5; Clear h h0.
-Generalize (H'3 t); Intro h; LApply h;
-  [Intro h0; Elim h0; Intros z0 h1; Elim h1; Intros H'6 H'7; Clear h h0 h1 |
-    Clear h]; Auto with sets.
-Exists z0; Split; [Assumption | Idtac].
-Apply Rstar_n with t; Auto with sets.
-Generalize H'1; Generalize y; Clear H'1.
-Elim H'4.
-Intros x1 y0 H'0; Exists y0; Auto with sets.
-Intros x1 y0 z0 H'0 H'1 H'5 y1 H'6.
-Red in H'.
-Generalize (H' x1 y0 y1); Intro h; LApply h;
-  [Intro H'7; LApply H'7;
-    [Intro h0; Elim h0; Intros z1 h1; Elim h1; Intros H'8 H'9; Clear h H'7 h0 h1 |
-      Clear h] | Clear h]; Auto with sets.
-Generalize (H'5 z1); Intro h; LApply h;
-  [Intro h0; Elim h0; Intros t h1; Elim h1; Intros H'7 H'10; Clear h h0 h1 |
-    Clear h]; Auto with sets.
-Exists t; Split; Auto with sets.
-Apply Rstar_n with z1; Auto with sets.
-Qed.
-
-Theorem Noetherian_contains_Noetherian :
-  (U: Type) (R, R': (Relation U)) (Noetherian U R) -> (contains U R R') ->
-   (Noetherian U R').
-Proof.
-Unfold 2 Noetherian.
-Intros U R R' H' H'0 x.
-Elim (H' x); Auto with sets.
-Qed.
-
-Theorem Newman :
-  (U: Type) (R: (Relation U)) (Noetherian U R) -> (Locally_confluent U R) ->
-   (Confluent U R).
-Proof.
-Intros U R H' H'0; Red; Intro x.
-Elim (H' x); Unfold confluent.
-Intros x0 H'1 H'2 y z H'3 H'4.
-Generalize (Rstar_cases U R x0 y); Intro h; LApply h;
-  [Intro h0; Elim h0;
-    [Clear h h0; Intro h1 |
-      Intro h1; Elim h1; Intros u h2; Elim h2; Intros H'5 H'6; Clear h h0 h1 h2] |
-    Clear h]; Auto with sets.
-Elim h1; Auto with sets.
-Generalize (Rstar_cases U R x0 z); Intro h; LApply h;
-  [Intro h0; Elim h0;
-    [Clear h h0; Intro h1 |
-      Intro h1; Elim h1; Intros v h2; Elim h2; Intros H'7 H'8; Clear h h0 h1 h2] |
-    Clear h]; Auto with sets.
-Elim h1; Generalize coherent_symmetric; Intro t; Red in t; Auto with sets.
-Unfold Locally_confluent locally_confluent coherent in H'0.
-Generalize (H'0 x0 u v); Intro h; LApply h;
-  [Intro H'9; LApply H'9;
-    [Intro h0; Elim h0; Intros t h1; Elim h1; Intros H'10 H'11;
-      Clear h H'9 h0 h1 | Clear h] | Clear h]; Auto with sets.
-Clear H'0.
-Unfold 1 coherent in H'2.
-Generalize (H'2 u); Intro h; LApply h;
-  [Intro H'0; Generalize (H'0 y t); Intro h0; LApply h0;
-    [Intro H'9; LApply H'9;
-      [Intro h1; Elim h1; Intros y1 h2; Elim h2; Intros H'12 H'13;
-        Clear h h0 H'9 h1 h2 | Clear h h0] | Clear h h0] | Clear h]; Auto with sets.
-Generalize Rstar_transitive; Intro T; Red in T.
-Generalize (H'2 v); Intro h; LApply h;
-  [Intro H'9; Generalize (H'9 y1 z); Intro h0; LApply h0;
-    [Intro H'14; LApply H'14;
-      [Intro h1; Elim h1; Intros z1 h2; Elim h2; Intros H'15 H'16;
-        Clear h h0 H'14 h1 h2 | Clear h h0] | Clear h h0] | Clear h]; Auto with sets.
-Red; (Exists z1; Split); Auto with sets.
-Apply T with y1; Auto with sets.
-Apply T with t; Auto with sets.
-Qed.
diff --git a/theories7/Sets/Uniset.v b/theories7/Sets/Uniset.v
deleted file mode 100644
index 33880214..00000000
--- a/theories7/Sets/Uniset.v
+++ /dev/null
@@ -1,212 +0,0 @@
-(************************************************************************)
-(*  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: Uniset.v,v 1.1.2.1 2004/07/16 19:31:40 herbelin Exp $ i*)
-
-(** Sets as characteristic functions *)
-
-(* G. Huet 1-9-95 *)
-(* Updated Papageno 12/98 *)
-
-Require Bool.
-
-Set Implicit Arguments.
-
-Section defs.
-
-Variable A : Set.
-Variable eqA : A -> A -> Prop.
-Hypothesis eqA_dec : (x,y:A){(eqA x y)}+{~(eqA x y)}.
-
-Inductive uniset : Set := 
-      Charac : (A->bool) -> uniset.
-
-Definition charac : uniset -> A -> bool :=
-  [s:uniset][a:A]Case s of [f:A->bool](f a) end.
-
-Definition Emptyset := (Charac [a:A]false).
-
-Definition Fullset  := (Charac [a:A]true).
-
-Definition Singleton := [a:A](Charac [a':A]
-              Case (eqA_dec a a') of 
-                   [h:(eqA a a')]  true
-                   [h: ~(eqA a a')] false end).
-
-Definition In : uniset -> A -> Prop :=
-     [s:uniset][a:A](charac s a)=true.
-Hints Unfold In.
-
-(** uniset inclusion *)
-Definition incl := [s1,s2:uniset]
-    (a:A)(leb (charac s1 a) (charac s2 a)).
-Hints Unfold incl.
-
-(** uniset equality *)
-Definition seq := [s1,s2:uniset]
-    (a:A)(charac s1 a) = (charac s2 a).
-Hints Unfold seq.
-
-Lemma leb_refl : (b:bool)(leb b b).
-Proof.
-NewDestruct b; Simpl; Auto.
-Qed.
-Hints Resolve leb_refl.
-
-Lemma incl_left : (s1,s2:uniset)(seq s1 s2)->(incl s1 s2).
-Proof.
-Unfold incl; Intros s1 s2 E a; Elim (E a); Auto.
-Qed.
-
-Lemma incl_right : (s1,s2:uniset)(seq s1 s2)->(incl s2 s1).
-Proof.
-Unfold incl; Intros s1 s2 E a; Elim (E a); Auto.
-Qed.
-
-Lemma seq_refl : (x:uniset)(seq x x).
-Proof.
-NewDestruct x; Unfold seq; Auto.
-Qed.
-Hints Resolve seq_refl.
-
-Lemma seq_trans : (x,y,z:uniset)(seq x y)->(seq y z)->(seq x z).
-Proof.
-Unfold seq.
-NewDestruct x; NewDestruct y; NewDestruct z; Simpl; Intros.
-Rewrite H; Auto.
-Qed.
-
-Lemma seq_sym : (x,y:uniset)(seq x y)->(seq y x).
-Proof.
-Unfold seq.
-NewDestruct x; NewDestruct y; Simpl; Auto.
-Qed.
-
-(** uniset union *)
-Definition union := [m1,m2:uniset]
-    (Charac [a:A](orb (charac m1 a)(charac m2 a))).
-
-Lemma union_empty_left :
-     (x:uniset)(seq x (union Emptyset x)).  
-Proof.  
-Unfold seq; Unfold union; Simpl; Auto.  
-Qed. 
-Hints Resolve union_empty_left.
-
-Lemma union_empty_right :
-     (x:uniset)(seq x (union x Emptyset)).
-Proof.
-Unfold seq; Unfold union; Simpl.
-Intros x a; Rewrite (orb_b_false (charac x a)); Auto.
-Qed.
-Hints Resolve union_empty_right.
-
-Lemma union_comm : (x,y:uniset)(seq (union x y) (union y x)).
-Proof.
-Unfold seq; Unfold charac; Unfold union.
-NewDestruct x; NewDestruct y; Auto with bool.
-Qed.
-Hints Resolve union_comm.
-
-Lemma union_ass : 
-      (x,y,z:uniset)(seq (union (union x y) z) (union x (union y z))).
-Proof.
-Unfold seq; Unfold union; Unfold charac.
-NewDestruct x; NewDestruct y; NewDestruct z; Auto with bool.
-Qed.
-Hints Resolve union_ass.
-
-Lemma seq_left :  (x,y,z:uniset)(seq x y)->(seq (union x z) (union y z)).
-Proof.
-Unfold seq; Unfold union; Unfold charac.
-NewDestruct x; NewDestruct y; NewDestruct z.
-Intros; Elim H; Auto.
-Qed.
-Hints Resolve seq_left.
-
-Lemma seq_right : (x,y,z:uniset)(seq x y)->(seq (union z x) (union z y)).
-Proof.
-Unfold seq; Unfold union; Unfold charac.
-NewDestruct x; NewDestruct y; NewDestruct z.
-Intros; Elim H; Auto.
-Qed.
-Hints Resolve seq_right.
-
-
-(** All the proofs that follow duplicate [Multiset_of_A] *)
-
-(** Here we should make uniset an abstract datatype, by hiding [Charac],
-    [union], [charac]; all further properties are proved abstractly *)
-
-Require Permut.
-
-Lemma union_rotate :
-   (x,y,z:uniset)(seq (union x (union y z)) (union z (union x y))).
-Proof.
-Intros; Apply (op_rotate uniset union seq); Auto.
-Exact seq_trans.
-Qed.
-
-Lemma seq_congr : (x,y,z,t:uniset)(seq x y)->(seq z t)->
-                  (seq (union x z) (union y t)).
-Proof.
-Intros; Apply (cong_congr uniset union seq); Auto.
-Exact seq_trans.
-Qed.
-
-Lemma union_perm_left :
-   (x,y,z:uniset)(seq (union x (union y z)) (union y (union x z))).
-Proof.
-Intros; Apply (perm_left uniset union seq); Auto.
-Exact seq_trans.
-Qed.
-
-Lemma uniset_twist1 : (x,y,z,t:uniset)
-   (seq (union x (union (union y z) t)) (union (union y (union x t)) z)).
-Proof.
-Intros; Apply (twist uniset union seq); Auto.
-Exact seq_trans.
-Qed.
-
-Lemma uniset_twist2 : (x,y,z,t:uniset)
-   (seq (union x (union (union y z) t)) (union (union y (union x z)) t)).
-Proof.
-Intros; Apply seq_trans with (union (union x (union y z)) t).
-Apply seq_sym; Apply union_ass.
-Apply seq_left; Apply union_perm_left.
-Qed.
-
-(** specific for treesort *)
-
-Lemma treesort_twist1 : (x,y,z,t,u:uniset) (seq u (union y z)) ->
-   (seq (union x (union u t)) (union (union y (union x t)) z)).
-Proof.
-Intros; Apply seq_trans with (union x (union (union y z) t)).
-Apply seq_right; Apply seq_left; Trivial.
-Apply uniset_twist1.
-Qed.
-
-Lemma treesort_twist2 : (x,y,z,t,u:uniset) (seq u (union y z)) ->
-   (seq (union x (union u t)) (union (union y (union x z)) t)).
-Proof.
-Intros; Apply seq_trans with (union x (union (union y z) t)).
-Apply seq_right; Apply seq_left; Trivial.
-Apply uniset_twist2.
-Qed.
-
-
-(*i theory of minter to do similarly 
-Require Min.
-(* uniset intersection *)
-Definition minter := [m1,m2:uniset]
-    (Charac [a:A](andb (charac m1 a)(charac m2 a))).
-i*)
-
-End defs.
-
-Unset Implicit Arguments.
diff --git a/theories7/Sorting/Heap.v b/theories7/Sorting/Heap.v
deleted file mode 100644
index 63e7f324..00000000
--- a/theories7/Sorting/Heap.v
+++ /dev/null
@@ -1,223 +0,0 @@
-(************************************************************************)
-(*  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: Heap.v,v 1.1.2.1 2004/07/16 19:31:41 herbelin Exp $ i*)
-
-(** A development of Treesort on Heap trees *)
-
-(* G. Huet 1-9-95 uses Multiset *)
-
-Require PolyList.
-Require Multiset.
-Require Permutation.
-Require Relations.
-Require Sorting.
-
-
-Section defs.
-
-Variable A : Set.
-Variable leA : (relation A).
-Variable eqA : (relation A).
-
-Local gtA := [x,y:A]~(leA x y).
-
-Hypothesis leA_dec : (x,y:A){(leA x y)}+{(leA y x)}.
-Hypothesis eqA_dec : (x,y:A){(eqA x y)}+{~(eqA x y)}.
-Hypothesis leA_refl : (x,y:A) (eqA x y) -> (leA x y).
-Hypothesis leA_trans : (x,y,z:A) (leA x y) -> (leA y z) -> (leA x z).
-Hypothesis leA_antisym : (x,y:A)(leA x y) -> (leA y x) -> (eqA x y).
-
-Hints Resolve leA_refl.
-Hints Immediate eqA_dec leA_dec leA_antisym.
-
-Local emptyBag := (EmptyBag A).
-Local singletonBag := (SingletonBag eqA_dec).
-
-Inductive Tree : Set :=
-      Tree_Leaf : Tree
-    | Tree_Node : A -> Tree -> Tree -> Tree.
-
-(** [a] is lower than a Tree [T] if [T] is a Leaf
-    or [T] is a Node holding [b>a] *)
-
-Definition leA_Tree := [a:A; t:Tree]
- Cases t of 
-   Tree_Leaf           => True
- | (Tree_Node b T1 T2) => (leA a b)
- end.
-
-Lemma leA_Tree_Leaf : (a:A)(leA_Tree a Tree_Leaf).
-Proof.
-Simpl; Auto with datatypes.
-Qed.
-
-Lemma leA_Tree_Node : (a,b:A)(G,D:Tree)(leA a b) ->
-                        (leA_Tree a (Tree_Node b G D)).
-Proof.
-Simpl; Auto with datatypes.
-Qed.
-
-Hints Resolve leA_Tree_Leaf leA_Tree_Node.
-
-
-(** The heap property *)
-
-Inductive is_heap : Tree -> Prop :=
-      nil_is_heap : (is_heap Tree_Leaf)
-    | node_is_heap : (a:A)(T1,T2:Tree)
-                     (leA_Tree a T1) ->
-                     (leA_Tree a T2) ->
-                     (is_heap T1) -> (is_heap T2) ->
-                     (is_heap (Tree_Node a T1 T2)).
-
-Hint constr_is_heap := Constructors is_heap.
-
-Lemma invert_heap : (a:A)(T1,T2:Tree)(is_heap (Tree_Node a T1 T2))->
-  (leA_Tree a T1) /\ (leA_Tree a T2) /\
-  (is_heap T1) /\ (is_heap T2).
-Proof.
-Intros; Inversion H; Auto with datatypes.
-Qed.
-
-(* This lemma ought to be generated automatically by the Inversion tools *)
-Lemma is_heap_rec : (P:Tree->Set)
-        (P Tree_Leaf)->
-         ((a:A)
-           (T1:Tree)
-            (T2:Tree)
-             (leA_Tree a T1)->
-              (leA_Tree a T2)->
-               (is_heap T1)->
-                (P T1)->(is_heap T2)->(P T2)->(P (Tree_Node a T1 T2)))
-         -> (T:Tree)(is_heap T) -> (P T).
-Proof.
-Induction T; Auto with datatypes.
-Intros a G PG D PD PN. 
-Elim (invert_heap a G D); Auto with datatypes.
-Intros H1 H2; Elim H2; Intros H3 H4; Elim H4; Intros.
-Apply H0; Auto with datatypes.
-Qed.
-
-Lemma low_trans : 
-  (T:Tree)(a,b:A)(leA a b) -> (leA_Tree b T) -> (leA_Tree a T).
-Proof.
-Induction T; Auto with datatypes.
-Intros; Simpl; Apply leA_trans with b; Auto with datatypes.
-Qed.
-
-(** contents of a tree as a multiset *)
-
-(** Nota Bene : In what follows the definition of SingletonBag
-    in not used. Actually, we could just take as postulate:
-    [Parameter SingletonBag : A->multiset].  *)
-
-Fixpoint  contents [t:Tree] : (multiset A) :=
- Cases t of
-   Tree_Leaf           => emptyBag
- | (Tree_Node a t1 t2) => (munion (contents t1) 
-                          (munion (contents t2) (singletonBag a)))
-end.
-
-
-(** equivalence of two trees is equality of corresponding multisets *)
-
-Definition equiv_Tree := [t1,t2:Tree](meq (contents t1) (contents t2)).
-
-
-(** specification of heap insertion *)
-
-Inductive insert_spec [a:A; T:Tree] : Set :=
-   insert_exist : (T1:Tree)(is_heap T1) ->
-                  (meq (contents T1) (munion (contents T) (singletonBag a))) ->
-                  ((b:A)(leA b a)->(leA_Tree b T)->(leA_Tree b T1)) ->
-                  (insert_spec a T).
-
-
-Lemma insert : (T:Tree)(is_heap T) -> (a:A)(insert_spec a T).
-Proof.
-Induction 1; Intros.
-Apply insert_exist with (Tree_Node a Tree_Leaf Tree_Leaf); Auto with datatypes.
-Simpl; Unfold meq munion; Auto with datatypes.
-Elim (leA_dec a a0); Intros.
-Elim (H3 a0); Intros.
-Apply insert_exist with (Tree_Node a T2 T0); Auto with datatypes.
-Simpl; Apply treesort_twist1; Trivial with datatypes. 
-Elim (H3 a); Intros T3 HeapT3 ConT3 LeA.
-Apply insert_exist with (Tree_Node a0 T2 T3); Auto with datatypes.
-Apply node_is_heap; Auto with datatypes.
-Apply low_trans with a; Auto with datatypes.
-Apply LeA; Auto with datatypes.
-Apply low_trans with a; Auto with datatypes.
-Simpl; Apply treesort_twist2; Trivial with datatypes. 
-Qed.
-
-(** building a heap from a list *)
-
-Inductive build_heap [l:(list A)] : Set :=
-   heap_exist : (T:Tree)(is_heap T) ->
-                (meq (list_contents eqA_dec l)(contents T)) ->
-                (build_heap l).
-
-Lemma list_to_heap : (l:(list A))(build_heap l).
-Proof.
-Induction l.
-Apply (heap_exist (nil  A) Tree_Leaf); Auto with datatypes.
-Simpl; Unfold meq; Auto with datatypes.
-Induction 1.
-Intros T i m; Elim (insert T i a).
-Intros; Apply heap_exist with T1; Simpl; Auto with datatypes.
-Apply meq_trans with (munion (contents T) (singletonBag a)).
-Apply meq_trans with (munion (singletonBag a) (contents T)).
-Apply meq_right; Trivial with datatypes.
-Apply munion_comm.
-Apply meq_sym; Trivial with datatypes.
-Qed.
-
-
-(** building the sorted list *)
-
-Inductive flat_spec [T:Tree] : Set :=
- flat_exist : (l:(list A))(sort leA l) ->
-              ((a:A)(leA_Tree a T)->(lelistA leA a l)) ->
-              (meq (contents T) (list_contents eqA_dec l)) ->
-              (flat_spec T).
-
-Lemma heap_to_list : (T:Tree)(is_heap T) -> (flat_spec T).
-Proof.
-  Intros T h; Elim h; Intros.
-  Apply flat_exist with (nil A); Auto with datatypes.
-  Elim H2; Intros l1 s1 i1 m1; Elim H4; Intros l2 s2 i2 m2.
-  Elim (merge leA_dec eqA_dec s1 s2); Intros.
-  Apply flat_exist with (cons a l); Simpl; Auto with datatypes.
-  Apply meq_trans with 
-    (munion (list_contents eqA_dec l1) (munion (list_contents eqA_dec l2) 
-                                               (singletonBag a))).
-  Apply meq_congr; Auto with datatypes.
-  Apply meq_trans with 
-    (munion (singletonBag a) (munion (list_contents eqA_dec l1) 
-                                     (list_contents eqA_dec  l2))).
-  Apply munion_rotate.
-  Apply meq_right; Apply meq_sym; Trivial with datatypes.
-Qed.
-
-(** specification of treesort *)
-
-Theorem treesort : (l:(list A))
-  {m:(list A) | (sort leA m) & (permutation eqA_dec l m)}.
-Proof.
-  Intro l; Unfold permutation.
-  Elim (list_to_heap l).
-  Intros.
-  Elim (heap_to_list T); Auto with datatypes.
-  Intros.
-  Exists l0; Auto with datatypes.
-  Apply meq_trans with (contents T); Trivial with datatypes.
-Qed.
-
-End defs.
diff --git a/theories7/Sorting/Permutation.v b/theories7/Sorting/Permutation.v
deleted file mode 100644
index 46b8da00..00000000
--- a/theories7/Sorting/Permutation.v
+++ /dev/null
@@ -1,111 +0,0 @@
-(************************************************************************)
-(*  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: Permutation.v,v 1.1.2.1 2004/07/16 19:31:41 herbelin Exp $ i*)
-
-Require Relations.
-Require PolyList.
-Require Multiset.
-
-Set Implicit Arguments.
-
-Section defs.
-
-Variable A : Set.
-Variable leA : (relation A).
-Variable eqA : (relation A).
-
-Local gtA := [x,y:A]~(leA x y).
-
-Hypothesis leA_dec : (x,y:A){(leA x y)}+{~(leA x y)}.
-Hypothesis eqA_dec : (x,y:A){(eqA x y)}+{~(eqA x y)}.
-Hypothesis leA_refl : (x,y:A) (eqA x y) -> (leA x y).
-Hypothesis leA_trans : (x,y,z:A) (leA x y) -> (leA y z) -> (leA x z).
-Hypothesis leA_antisym : (x,y:A)(leA x y) -> (leA y x) -> (eqA x y).
-
-Hints Resolve leA_refl : default.
-Hints Immediate eqA_dec leA_dec leA_antisym : default.
-
-Local emptyBag := (EmptyBag A).
-Local singletonBag := (SingletonBag eqA_dec).
-
-(** contents of a list *)
-
-Fixpoint list_contents [l:(list A)] : (multiset A) :=
- Cases l of
-   nil        => emptyBag
- | (cons a l) => (munion (singletonBag a) (list_contents l))
- end.
-
-Lemma list_contents_app : (l,m:(list A))
-  (meq (list_contents (app l m)) (munion (list_contents l) (list_contents m))).
-Proof.
-Induction l; Simpl; Auto with datatypes.
-Intros.
-Apply meq_trans with  
- (munion (singletonBag a) (munion (list_contents l0) (list_contents m))); Auto with datatypes.
-Qed.
-Hints Resolve list_contents_app.
-
-Definition permutation := [l,m:(list A)](meq (list_contents l) (list_contents m)).
-
-Lemma permut_refl : (l:(list A))(permutation l l).
-Proof.
-Unfold permutation; Auto with datatypes.
-Qed.
-Hints Resolve permut_refl.
-
-Lemma permut_tran : (l,m,n:(list A))
-   (permutation l m) -> (permutation m n) -> (permutation l n).
-Proof.
-Unfold permutation; Intros.
-Apply meq_trans with (list_contents m); Auto with datatypes.
-Qed.
-
-Lemma permut_right : (l,m:(list A))
-   (permutation l m) -> (a:A)(permutation (cons a l) (cons a m)).
-Proof.
-Unfold permutation; Simpl; Auto with datatypes.
-Qed.
-Hints Resolve permut_right.
-
-Lemma permut_app : (l,l',m,m':(list A))
-   (permutation l l') -> (permutation m m') ->
-   (permutation (app l m) (app l' m')).
-Proof.
-Unfold permutation; Intros.
-Apply meq_trans with (munion (list_contents l) (list_contents m)); Auto with datatypes.
-Apply meq_trans with (munion (list_contents l') (list_contents m')); Auto with datatypes.
-Apply meq_trans with (munion (list_contents l') (list_contents m)); Auto with datatypes.
-Qed.
-Hints Resolve permut_app.
-
-Lemma permut_cons : (l,m:(list A))(permutation l m) ->
-    (a:A)(permutation (cons a l) (cons a m)).
-Proof.
-Intros l m H a.
-Change (permutation (app (cons a (nil A)) l) (app (cons a (nil A)) m)).
-Apply permut_app; Auto with datatypes.
-Qed.
-Hints Resolve permut_cons.
-
-Lemma permut_middle : (l,m:(list A))
-   (a:A)(permutation (cons a (app l m)) (app l (cons a m))).
-Proof.
-Unfold permutation.
-Induction l; Simpl; Auto with datatypes.
-Intros.
-Apply meq_trans with (munion (singletonBag a)
-          (munion (singletonBag a0) (list_contents (app l0 m)))); Auto with datatypes.
-Apply munion_perm_left; Auto with datatypes.
-Qed.
-Hints Resolve permut_middle.
-
-End defs.
-Unset Implicit Arguments.
-
diff --git a/theories7/Sorting/Sorting.v b/theories7/Sorting/Sorting.v
deleted file mode 100644
index a6e38976..00000000
--- a/theories7/Sorting/Sorting.v
+++ /dev/null
@@ -1,117 +0,0 @@
-(************************************************************************)
-(*  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: Sorting.v,v 1.1.2.1 2004/07/16 19:31:41 herbelin Exp $ i*)
-
-Require PolyList.
-Require Multiset.
-Require Permutation.
-Require Relations.
-
-Set Implicit Arguments.
-
-Section defs.
-
-Variable A : Set.
-Variable leA : (relation A).
-Variable eqA : (relation A).
-
-Local gtA := [x,y:A]~(leA x y).
-
-Hypothesis leA_dec : (x,y:A){(leA x y)}+{(leA y x)}.
-Hypothesis eqA_dec : (x,y:A){(eqA x y)}+{~(eqA x y)}.
-Hypothesis leA_refl : (x,y:A) (eqA x y) -> (leA x y).
-Hypothesis leA_trans : (x,y,z:A) (leA x y) -> (leA y z) -> (leA x z).
-Hypothesis leA_antisym : (x,y:A)(leA x y) -> (leA y x) -> (eqA x y).
-
-Hints Resolve leA_refl.
-Hints Immediate eqA_dec leA_dec leA_antisym.
-
-Local emptyBag := (EmptyBag A).
-Local singletonBag := (SingletonBag eqA_dec).
-
-(** [lelistA] *)
-
-Inductive lelistA [a:A] : (list A) -> Prop :=
-      nil_leA : (lelistA a (nil A))
-    | cons_leA : (b:A)(l:(list A))(leA a b)->(lelistA a (cons b l)).
-Hint constr_lelistA := Constructors lelistA.
-
-Lemma lelistA_inv : (a,b:A)(l:(list A))
-      (lelistA a (cons b l)) -> (leA a b).
-Proof.
-  Intros; Inversion H; Trivial with datatypes.
-Qed.
-
-(** definition for a list to be sorted *)
-
-Inductive sort : (list A) -> Prop :=
-   nil_sort : (sort (nil A))
- | cons_sort : (a:A)(l:(list A))(sort l) -> (lelistA a l) -> (sort (cons a l)).
-Hint constr_sort := Constructors sort.
-
-Lemma sort_inv : (a:A)(l:(list A))(sort (cons a l))->(sort l) /\ (lelistA a l).
-Proof.
-Intros; Inversion H; Auto with datatypes.
-Qed.
-
-Lemma sort_rec : (P:(list A)->Set)
-     (P (nil A)) ->
-     ((a:A)(l:(list A))(sort l)->(P l)->(lelistA a l)->(P (cons a l))) ->
-     (y:(list A))(sort y) -> (P y).
-Proof.
-Induction y; Auto with datatypes.
-Intros; Elim (!sort_inv a l); Auto with datatypes.
-Qed.
-
-(** merging two sorted lists *)
-
-Inductive merge_lem [l1:(list A);l2:(list A)] : Set :=
-  merge_exist : (l:(list A))(sort l) ->
-    (meq (list_contents eqA_dec l)
-         (munion (list_contents eqA_dec l1) (list_contents eqA_dec l2))) ->
-    ((a:A)(lelistA a l1)->(lelistA a l2)->(lelistA a l)) ->
-    (merge_lem l1 l2).
-
-Lemma merge : (l1:(list A))(sort l1)->(l2:(list A))(sort l2)->(merge_lem l1 l2).
-Proof.
-  Induction 1; Intros.
-  Apply merge_exist with l2; Auto with datatypes.
-  Elim H3; Intros.
-  Apply merge_exist with (cons a l); Simpl; Auto with datatypes.
-  Elim (leA_dec a a0); Intros.
-
-(* 1 (leA a a0) *)
-  Cut (merge_lem l (cons a0 l0)); Auto with datatypes.
-  Intros (l3, l3sorted, l3contents, Hrec).
-  Apply merge_exist with (cons a l3); Simpl; Auto with datatypes.
-  Apply meq_trans with (munion (singletonBag a)
-	                       (munion (list_contents eqA_dec l)
-                                       (list_contents eqA_dec (cons a0 l0)))).
-  Apply meq_right; Trivial with datatypes.
-  Apply meq_sym; Apply munion_ass.
-  Intros; Apply cons_leA.
-  Apply lelistA_inv with l; Trivial with datatypes.
-
-(* 2 (leA a0 a) *)
-  Elim H5; Simpl; Intros.
-  Apply merge_exist with (cons a0 l3); Simpl; Auto with datatypes.
-  Apply meq_trans with (munion (singletonBag a0)
-                               (munion (munion (singletonBag a) 
-                                               (list_contents eqA_dec l))
-                               (list_contents eqA_dec l0))).
-  Apply meq_right; Trivial with datatypes.
-  Apply munion_perm_left.
-  Intros; Apply cons_leA; Apply lelistA_inv with l0; Trivial with datatypes.
-Qed.
-
-End defs.
-
-Unset Implicit Arguments.
-Hint constr_sort : datatypes v62 := Constructors sort.
-Hint constr_lelistA : datatypes v62 := Constructors lelistA.
diff --git a/theories7/Wellfounded/Disjoint_Union.v b/theories7/Wellfounded/Disjoint_Union.v
deleted file mode 100644
index 04930170..00000000
--- a/theories7/Wellfounded/Disjoint_Union.v
+++ /dev/null
@@ -1,56 +0,0 @@
-(************************************************************************)
-(*  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: Disjoint_Union.v,v 1.1.2.1 2004/07/16 19:31:41 herbelin Exp $ i*)
-
-(** Author: Cristina Cornes
-    From : Constructing Recursion Operators in Type Theory                 
-           L. Paulson  JSC (1986) 2, 325-355 *) 
-
-Require Relation_Operators.
-
-Section Wf_Disjoint_Union.
-Variable A,B:Set.
-Variable leA: A->A->Prop.
-Variable leB: B->B->Prop.
-
-Notation Le_AsB := (le_AsB A B leA leB).
-
-Lemma acc_A_sum: (x:A)(Acc A leA x)->(Acc A+B Le_AsB (inl A B x)).
-Proof.
- NewInduction 1.
- Apply Acc_intro;Intros y H2.
- Inversion_clear H2.
- Auto with sets.
-Qed.
-
-Lemma acc_B_sum: (well_founded A leA) ->(x:B)(Acc B leB x)
-                        ->(Acc A+B Le_AsB (inr A B x)).
-Proof.
- NewInduction 2.
- Apply Acc_intro;Intros y H3.
- Inversion_clear H3;Auto with sets.
- Apply acc_A_sum;Auto with sets.
-Qed.
-
-
-Lemma wf_disjoint_sum:
- (well_founded A leA) 
-    -> (well_founded B leB) -> (well_founded A+B Le_AsB).
-Proof.
- Intros.
- Unfold well_founded .
- NewDestruct a as [a|b].
- Apply (acc_A_sum a).
- Apply (H a).
-
- Apply (acc_B_sum H b).
- Apply (H0 b).
-Qed.
-
-End Wf_Disjoint_Union.
diff --git a/theories7/Wellfounded/Inclusion.v b/theories7/Wellfounded/Inclusion.v
deleted file mode 100644
index 6a515333..00000000
--- a/theories7/Wellfounded/Inclusion.v
+++ /dev/null
@@ -1,33 +0,0 @@
-(************************************************************************)
-(*  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: Inclusion.v,v 1.1.2.1 2004/07/16 19:31:41 herbelin Exp $ i*)
-
-(** Author: Bruno Barras *)
-
-Require Relation_Definitions.
-
-Section WfInclusion.
-  Variable A:Set.
-  Variable R1,R2:A->A->Prop.
-
-  Lemma Acc_incl: (inclusion A R1 R2)->(z:A)(Acc A R2 z)->(Acc A R1 z).
-  Proof.
-    NewInduction 2.
-    Apply Acc_intro;Auto with sets.
-  Qed.
-
-  Hints Resolve Acc_incl.
-
-  Theorem wf_incl: 
-         (inclusion A R1 R2)->(well_founded A R2)->(well_founded A R1).
-  Proof.
-    Unfold well_founded ;Auto with sets.
-  Qed.
-
-End WfInclusion.
diff --git a/theories7/Wellfounded/Inverse_Image.v b/theories7/Wellfounded/Inverse_Image.v
deleted file mode 100644
index 6c9c3e65..00000000
--- a/theories7/Wellfounded/Inverse_Image.v
+++ /dev/null
@@ -1,58 +0,0 @@
-(************************************************************************)
-(*  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: Inverse_Image.v,v 1.1.2.1 2004/07/16 19:31:41 herbelin Exp $ i*)
-
-(** Author: Bruno Barras *)
-
-Section Inverse_Image.
-
-  Variables A,B:Set.
-  Variable R : B->B->Prop.
-  Variable f:A->B.
-
-  Local Rof : A->A->Prop := [x,y:A](R (f x) (f y)).
-
-  Remark Acc_lemma : (y:B)(Acc B R y)->(x:A)(y=(f x))->(Acc A Rof x).
-    NewInduction 1 as [y _ IHAcc]; Intros x H.
-    Apply Acc_intro; Intros y0 H1.
-    Apply (IHAcc (f y0)); Try Trivial.
-    Rewrite H; Trivial.
-  Qed.
-
-  Lemma Acc_inverse_image : (x:A)(Acc B R (f x)) -> (Acc A Rof x).
-    Intros; Apply (Acc_lemma (f x)); Trivial.
-  Qed.
-
-  Theorem wf_inverse_image: (well_founded B R)->(well_founded A Rof).
-    Red; Intros; Apply Acc_inverse_image; Auto.
-  Qed.
-
-  Variable F : A -> B -> Prop.
-  Local RoF : A -> A -> Prop := [x,y]
-    (EX b : B | (F x b) & (c:B)(F y c)->(R b c)).
-
-Lemma Acc_inverse_rel :
-   (b:B)(Acc B R b)->(x:A)(F x b)->(Acc A RoF x).
-NewInduction 1 as [x _ IHAcc]; Intros x0 H2.
-Constructor; Intros y H3.
-NewDestruct H3.
-Apply (IHAcc x1); Auto.
-Save.
-
-
-Theorem wf_inverse_rel : 
-   (well_founded B R)->(well_founded A RoF).
-    Red; Constructor; Intros.
-    Case H0; Intros.
-    Apply (Acc_inverse_rel x); Auto.
-Save.
-
-End Inverse_Image.
-
-
diff --git a/theories7/Wellfounded/Lexicographic_Exponentiation.v b/theories7/Wellfounded/Lexicographic_Exponentiation.v
deleted file mode 100644
index 17f6d650..00000000
--- a/theories7/Wellfounded/Lexicographic_Exponentiation.v
+++ /dev/null
@@ -1,386 +0,0 @@
-(************************************************************************)
-(*  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: Lexicographic_Exponentiation.v,v 1.1.2.1 2004/07/16 19:31:41 herbelin Exp $ i*)
-
-(** Author: Cristina Cornes
-
-    From : Constructing Recursion Operators in Type Theory                
-           L. Paulson  JSC (1986) 2, 325-355  *)
-
-Require Eqdep.
-Require PolyList.
-Require PolyListSyntax.
-Require Relation_Operators.
-Require Transitive_Closure.
-
-Section Wf_Lexicographic_Exponentiation.
-Variable A:Set.
-Variable leA: A->A->Prop.
-
-Notation Power := (Pow A leA).
-Notation Lex_Exp := (lex_exp A leA).
-Notation ltl := (Ltl A leA).
-Notation Descl := (Desc A leA).
-
-Notation List := (list A).
-Notation Nil := (nil A).
-(* useless but symmetric *)
-Notation Cons := (cons 1!A).
-Notation "<< x , y >>" := (exist List Descl x y) (at level 0)
-  V8only (at level 0, x,y at level 100).
-
-V7only[
-Syntax constr
-  level 1:
-    List [ (list A) ] -> ["List"]
-  | Nil  [ (nil A) ] -> ["Nil"]
-  | Cons [ (cons A) ] -> ["Cons"]
-  ;
-  level 10:
-    Cons2 [ (cons A $e $l) ] -> ["Cons " $e:L " " $l:L ].
-
-Syntax constr
-  level 1:
-  pair_sig [ (exist (list A) Desc $e $d) ] -> ["<<" $e:L "," $d:L ">>"].
-].
-Hints Resolve d_one d_nil  t_step.
-
-Lemma left_prefix : (x,y,z:List)(ltl x^y z)-> (ltl x z).
-Proof.
- Induction x.
- Induction z.
- Simpl;Intros H.
- Inversion_clear H. 
- Simpl;Intros;Apply (Lt_nil A leA).
- Intros a l HInd.
- Simpl.
- Intros.
- Inversion_clear H.
- Apply (Lt_hd A leA);Auto with sets.
- Apply (Lt_tl A leA).
- Apply (HInd y y0);Auto with sets.
-Qed.
-
-
-Lemma  right_prefix : 
-  (x,y,z:List)(ltl x y^z)-> (ltl x y) \/ (EX y':List | x=(y^y') /\ (ltl y' z)).
-Proof.
- Intros x y;Generalize x.
- Elim y;Simpl.
- Right.
- Exists x0 ;Auto with sets.
- Intros.
- Inversion H0.
- Left;Apply (Lt_nil A leA).
- Left;Apply (Lt_hd A leA);Auto with sets.
- Generalize (H x1 z H3) .
- Induction 1.
- Left;Apply (Lt_tl A leA);Auto with sets.
- Induction 1.
- Induction 1;Intros.
- Rewrite -> H8.
- Right;Exists x2 ;Auto with sets.
-Qed.
-
-
-
-Lemma desc_prefix: (x:List)(a:A)(Descl x^(Cons a Nil))->(Descl x).
-Proof.
- Intros.
- Inversion H.
- Generalize (app_cons_not_nil H1); Induction 1. 
- Cut (x^(Cons a Nil))=(Cons x0 Nil); Auto with sets.
- Intro.
- Generalize (app_eq_unit H0) .
- Induction 1; Induction 1; Intros.
- Rewrite -> H4; Auto with sets.
- Discriminate H5.
- Generalize (app_inj_tail H0) .
- Induction 1; Intros.
- Rewrite <- H4; Auto with sets.
-Qed.
-
-Lemma desc_tail: (x:List)(a,b:A)
-          (Descl (Cons b (x^(Cons a Nil))))-> (clos_trans A leA a b).
-Proof.
- Intro.
- Apply rev_ind with  A:=A
-             P:=[x:List](a,b:A)
-          (Descl (Cons b (x^(Cons a Nil))))-> (clos_trans A leA a b).
- Intros.
-
- Inversion  H.
- Cut (Cons b (Cons a Nil))= ((Nil^(Cons b Nil))^ (Cons a Nil)); Auto with sets; Intro.
- Generalize H0.
- Intro.
- Generalize (app_inj_tail 2!(l^(Cons y Nil)) 3!(Nil^(Cons b Nil)) H4);
- Induction 1.
- Intros.
-
- Generalize (app_inj_tail H6); Induction 1; Intros.
- Generalize H1.
- Rewrite <- H10; Rewrite <- H7; Intro.
- Apply (t_step A leA); Auto with sets.
-
-
-
- Intros.
- Inversion H0.
- Generalize  (app_cons_not_nil H3); Intro.
- Elim H1.
-
- Generalize H0.
- Generalize (app_comm_cons (l^(Cons x0 Nil)) (Cons a Nil) b); Induction 1.
- Intro.
- Generalize (desc_prefix (Cons b (l^(Cons x0 Nil))) a H5); Intro.
- Generalize (H x0 b H6).
- Intro.
- Apply t_trans with A:=A  y:=x0; Auto with sets.
-
- Apply  t_step.
- Generalize H1.
- Rewrite -> H4; Intro.
-
- Generalize (app_inj_tail H8); Induction 1.
- Intros.
- Generalize H2; Generalize (app_comm_cons l (Cons x0 Nil) b).
- Intro.
- Generalize H10.
- Rewrite ->H12; Intro.
- Generalize (app_inj_tail H13); Induction 1.
- Intros.
- Rewrite <- H11; Rewrite <- H16; Auto with sets.
-Qed.
-
-
-Lemma dist_aux : (z:List)(Descl z)->(x,y:List)z=(x^y)->(Descl x)/\ (Descl y).
-Proof.
- Intros z D.
- Elim D.
- Intros.
- Cut (x^y)=Nil;Auto with sets; Intro.
- Generalize (app_eq_nil H0) ; Induction 1.
- Intros.
- Rewrite -> H2;Rewrite -> H3; Split;Apply d_nil.
-
- Intros.
- Cut (x0^y)=(Cons x Nil); Auto with sets.
- Intros E.
- Generalize (app_eq_unit E); Induction 1.
- Induction 1;Intros.
- Rewrite -> H2;Rewrite -> H3; Split.
- Apply d_nil.
-
- Apply d_one.
-
- Induction 1; Intros.
- Rewrite -> H2;Rewrite -> H3; Split.
- Apply d_one.
-
- Apply d_nil.
-
- Do 5 Intro.
- Intros Hind.
- Do 2 Intro.
- Generalize x0 .
- Apply rev_ind with A:=A 
-      P:=[y0:List]
-          (x0:List)
-          ((l^(Cons y Nil))^(Cons x Nil))=(x0^y0)->(Descl x0)/\(Descl y0).
-
- Intro.
- Generalize (app_nil_end x1) ; Induction 1; Induction 1.
- Split. Apply d_conc; Auto with sets.
-
- Apply d_nil.
-
- Do 3 Intro.
- Generalize x1 .
- Apply rev_ind with 
-  A:=A 
-  P:=[l0:List]
-     (x1:A)
-      (x0:List)
-       ((l^(Cons y Nil))^(Cons x Nil))=(x0^(l0^(Cons x1 Nil)))
-         ->(Descl x0)/\(Descl (l0^(Cons x1 Nil))).
-
-
- Simpl.
- Split.
- Generalize (app_inj_tail H2) ;Induction 1.
- Induction 1;Auto with sets.
-
- Apply d_one.
- Do 5 Intro.
- Generalize (app_ass x4 (l1^(Cons x2 Nil)) (Cons x3 Nil)) .
- Induction 1.
- Generalize (app_ass x4 l1 (Cons x2 Nil)) ;Induction 1.
- Intro E.
- Generalize (app_inj_tail E) .
- Induction 1;Intros.
- Generalize (app_inj_tail H6) ;Induction 1;Intros.
- Rewrite <- H7;  Rewrite <- H10; Generalize H6.
- Generalize (app_ass x4 l1 (Cons x2 Nil)); Intro E1.
- Rewrite -> E1.
- Intro.
- Generalize (Hind x4 (l1^(Cons x2 Nil))  H11) .
- Induction 1;Split.
- Auto with sets.
-
- Generalize H14.
- Rewrite <- H10; Intro.
- Apply d_conc;Auto with sets.
-Qed.
-
-
-
-Lemma dist_Desc_concat : (x,y:List)(Descl x^y)->(Descl x)/\(Descl y).
-Proof.
-  Intros.
-  Apply (dist_aux (x^y) H x y); Auto with sets.
-Qed.
-
-
-Lemma desc_end:(a,b:A)(x:List) 
-   (Descl x^(Cons a Nil)) /\ (ltl x^(Cons a Nil) (Cons b Nil))
-     -> (clos_trans A leA a b). 
-
-Proof.
- Intros a b x.
- Case x.
- Simpl.
- Induction 1.
- Intros.
- Inversion H1;Auto with sets.
- Inversion H3.
-
- Induction 1.
- Generalize (app_comm_cons l (Cons a Nil) a0).
- Intros E; Rewrite <- E; Intros.
- Generalize (desc_tail l a a0 H0); Intro.
- Inversion H1.
- Apply t_trans with y:=a0 ;Auto with sets.
-
- Inversion H4.
-Qed.
-
-
-
-
-Lemma  ltl_unit: (x:List)(a,b:A)
- (Descl (x^(Cons a Nil))) -> (ltl x^(Cons a Nil) (Cons b Nil))
-               -> (ltl x (Cons b Nil)).
-Proof.
- Intro.
- Case x.
- Intros;Apply (Lt_nil A leA).
-
- Simpl;Intros.
- Inversion_clear H0.
- Apply (Lt_hd A leA  a b);Auto with sets.
- 
- Inversion_clear H1.
-Qed.
-
-
-Lemma acc_app: 
-    (x1,x2:List)(y1:(Descl x1^x2))
-     (Acc Power Lex_Exp (exist List Descl (x1^x2)  y1))
-     ->(x:List)
-        (y:(Descl x))
-         (ltl x (x1^x2))->(Acc Power Lex_Exp (exist List Descl x y)).
-Proof.
- Intros.
- Apply (Acc_inv Power Lex_Exp (exist List Descl (x1^x2) y1)).
- Auto with sets.
-
- Unfold lex_exp ;Simpl;Auto with sets.
-Qed.
-
-
-Theorem wf_lex_exp :
-  (well_founded A leA)->(well_founded Power Lex_Exp).
-Proof.
- Unfold 2 well_founded .
- Induction a;Intros x y.
- Apply Acc_intro.
- Induction y0.
- Unfold 1 lex_exp ;Simpl.
- Apply rev_ind with A:=A P:=[x:List]
-                            (x0:List)
-                             (y:(Descl x0))
-                              (ltl x0 x)
-                               ->(Acc Power Lex_Exp (exist List Descl x0 y)) .
- Intros.
- Inversion_clear H0.
-
- Intro.
- Generalize (well_founded_ind A (clos_trans A leA) (wf_clos_trans A leA H)).
- Intros GR.
- Apply GR with P:=[x0:A]
-                  (l:List)
-                   ((x1:List)
-                     (y:(Descl x1))
-                      (ltl x1 l)
-                       ->(Acc Power Lex_Exp (exist List Descl x1 y)))
-                    ->(x1:List)
-                       (y:(Descl x1))
-                        (ltl x1 (l^(Cons x0 Nil)))
-                         ->(Acc Power Lex_Exp (exist List Descl x1 y)) .
- Intro;Intros HInd; Intros.
- Generalize (right_prefix x2 l (Cons x1 Nil) H1) .
- Induction 1.
- Intro; Apply (H0 x2 y1 H3).
-
- Induction 1.
- Intro;Induction 1.
- Clear  H4  H2.
- Intro;Generalize y1 ;Clear  y1.
- Rewrite -> H2.
- Apply rev_ind with A:=A P:=[x3:List]
-                            (y1:(Descl (l^x3)))
-                             (ltl x3 (Cons x1 Nil))
-                              ->(Acc Power Lex_Exp
-                                  (exist List Descl (l^x3) y1)) .
- Intros.
- Generalize (app_nil_end l) ;Intros Heq.
- Generalize y1 .
- Clear  y1.
- Rewrite <- Heq.
- Intro.
- Apply Acc_intro.
- Induction y2.
- Unfold 1 lex_exp .
- Simpl;Intros x4 y3. Intros.
- Apply (H0 x4 y3);Auto with sets.
-
- Intros. 
- Generalize (dist_Desc_concat l (l0^(Cons x4 Nil)) y1) .
- Induction 1.
- Intros.
- Generalize (desc_end x4 x1 l0  (conj ? ? H8 H5)) ; Intros.
- Generalize y1 .
- Rewrite <- (app_ass l l0 (Cons x4 Nil)); Intro.
- Generalize (HInd x4 H9 (l^l0)) ; Intros HInd2.
- Generalize (ltl_unit l0 x4 x1 H8 H5); Intro.
- Generalize (dist_Desc_concat (l^l0) (Cons x4 Nil) y2) .
- Induction 1;Intros.
- Generalize (H4 H12 H10); Intro.
- Generalize (Acc_inv Power Lex_Exp (exist List Descl (l^l0) H12) H14) .
- Generalize (acc_app l l0 H12 H14).
- Intros f g.
- Generalize (HInd2 f);Intro.
- Apply Acc_intro.
- Induction y3.
- Unfold 1 lex_exp ;Simpl; Intros.
- Apply H15;Auto with sets.
-Qed.
-
-
-End Wf_Lexicographic_Exponentiation.
diff --git a/theories7/Wellfounded/Lexicographic_Product.v b/theories7/Wellfounded/Lexicographic_Product.v
deleted file mode 100644
index f31d8c3f..00000000
--- a/theories7/Wellfounded/Lexicographic_Product.v
+++ /dev/null
@@ -1,191 +0,0 @@
-(************************************************************************)
-(*  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: Lexicographic_Product.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-(** Authors: Bruno Barras, Cristina Cornes *)
-
-Require Eqdep.
-Require Relation_Operators.
-Require Transitive_Closure.
-
-(**  From : Constructing Recursion Operators in Type Theory            
-     L. Paulson  JSC (1986) 2, 325-355 *)
-
-Section WfLexicographic_Product.
-Variable A:Set.
-Variable B:A->Set.
-Variable leA: A->A->Prop.
-Variable leB: (x:A)(B x)->(B x)->Prop.
-
-Notation LexProd := (lexprod A B leA leB).
-
-Hints Resolve t_step Acc_clos_trans wf_clos_trans.
-
-Lemma acc_A_B_lexprod : (x:A)(Acc A leA x)
-        ->((x0:A)(clos_trans A leA x0 x)->(well_founded (B x0) (leB x0)))
-                ->(y:(B x))(Acc (B x) (leB x) y)
-                        ->(Acc (sigS A B) LexProd (existS A B x y)).
-Proof.
- NewInduction 1 as [x _ IHAcc]; Intros H2 y.
- NewInduction 1 as [x0 H IHAcc0];Intros.
- Apply Acc_intro.
- NewDestruct y as [x2 y1]; Intro H6.
- Simple Inversion H6; Intro.
- Cut (leA x2 x);Intros.
- Apply IHAcc;Auto with sets.
- Intros.
- Apply H2.
- Apply t_trans with x2 ;Auto with sets.
-
- Red in H2.
- Apply H2.
- Auto with sets.
-
- Injection H1.
- NewDestruct 2.
- Injection H3.
- NewDestruct 2;Auto with sets.
-
- Rewrite <- H1.
- Injection H3; Intros _ Hx1.
- Subst x1.
- Apply IHAcc0.
- Elim inj_pair2 with A B x y' x0; Assumption.
-Qed.
-
-Theorem wf_lexprod: 
-   (well_founded A leA) ->((x:A) (well_founded (B x) (leB x))) 
-             -> (well_founded (sigS A B) LexProd).
-Proof.
- Intros wfA wfB;Unfold well_founded .
- NewDestruct a.
- Apply acc_A_B_lexprod;Auto with sets;Intros.
- Red in wfB.
- Auto with sets.
-Qed.
-
-
-End WfLexicographic_Product.
-
-
-Section Wf_Symmetric_Product.
-  Variable A:Set.
-  Variable B:Set.
-  Variable leA: A->A->Prop.
-  Variable leB: B->B->Prop.
-
-  Notation Symprod := (symprod A B leA leB).
-
-(*i
-  Local sig_prod:=
-         [x:A*B]<{_:A&B}>Case x of [a:A][b:B](existS A [_:A]B a b) end.
-
-Lemma incl_sym_lexprod: (included (A*B) Symprod  
-            (R_o_f (A*B) {_:A&B} sig_prod (lexprod A [_:A]B leA [_:A]leB))).
-Proof.
- Red.
- Induction x.
- (Induction y1;Intros).
- Red.
- Unfold sig_prod .
- Inversion_clear H.
- (Apply left_lex;Auto with sets).
-
- (Apply right_lex;Auto with sets).
-Qed.
-i*)
-
-  Lemma Acc_symprod: (x:A)(Acc A leA x)->(y:B)(Acc B leB y)
-                        ->(Acc (A*B) Symprod (x,y)).
- Proof.
- NewInduction 1 as [x _ IHAcc]; Intros y H2.
- NewInduction H2 as [x1 H3 IHAcc1].
- Apply Acc_intro;Intros y H5.
- Inversion_clear H5;Auto with sets.
- Apply IHAcc; Auto.
- Apply Acc_intro;Trivial.
-Qed.
-
-
-Lemma wf_symprod: (well_founded A leA)->(well_founded B leB)
-                        ->(well_founded (A*B) Symprod).
-Proof.
- Red.
- NewDestruct a.
- Apply Acc_symprod;Auto with sets.
-Qed.
-
-End Wf_Symmetric_Product.
-
-
-Section Swap.
-
-  Variable A:Set.
-  Variable R:A->A->Prop.
-
-  Notation SwapProd :=(swapprod A R).
-
-
-  Lemma swap_Acc: (x,y:A)(Acc A*A SwapProd (x,y))->(Acc A*A SwapProd (y,x)).
-Proof.
- Intros.
- Inversion_clear H.
- Apply Acc_intro.
- NewDestruct y0;Intros.
- Inversion_clear H;Inversion_clear H1;Apply H0.
- Apply sp_swap.
- Apply right_sym;Auto with sets.
-
- Apply sp_swap.
- Apply left_sym;Auto with sets.
-
- Apply sp_noswap.
- Apply right_sym;Auto with sets.
-
- Apply sp_noswap.
- Apply left_sym;Auto with sets.
-Qed.
-
-
-  Lemma Acc_swapprod: (x,y:A)(Acc A R x)->(Acc A R y)
-                                ->(Acc A*A SwapProd (x,y)).
-Proof.
- NewInduction 1 as [x0 _ IHAcc0];Intros H2.
- Cut (y0:A)(R y0 x0)->(Acc ? SwapProd (y0,y)).
- Clear  IHAcc0.
- NewInduction H2 as [x1 _ IHAcc1]; Intros H4.
- Cut (y:A)(R y x1)->(Acc ? SwapProd (x0,y)).
- Clear  IHAcc1.
- Intro.
- Apply Acc_intro.
- NewDestruct y; Intro H5.
- Inversion_clear H5.
- Inversion_clear H0;Auto with sets.
-
- Apply swap_Acc.
- Inversion_clear H0;Auto with sets.
-
- Intros.
- Apply IHAcc1;Auto with sets;Intros.
- Apply Acc_inv with (y0,x1) ;Auto with sets.
- Apply sp_noswap.
- Apply right_sym;Auto with sets.
-
- Auto with sets.
-Qed.
-
-
-  Lemma wf_swapprod: (well_founded A R)->(well_founded A*A SwapProd).
-Proof.
- Red.
- NewDestruct a;Intros.
- Apply Acc_swapprod;Auto with sets.
-Qed.
-
-End Swap.
diff --git a/theories7/Wellfounded/Transitive_Closure.v b/theories7/Wellfounded/Transitive_Closure.v
deleted file mode 100644
index 4d6cbe28..00000000
--- a/theories7/Wellfounded/Transitive_Closure.v
+++ /dev/null
@@ -1,47 +0,0 @@
-(************************************************************************)
-(*  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: Transitive_Closure.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-(** Author: Bruno Barras *)
-
-Require Relation_Definitions.
-Require Relation_Operators.
-
-Section Wf_Transitive_Closure.
-  Variable A: Set.
-  Variable R: (relation A).
-
-  Notation trans_clos := (clos_trans A R).
- 
-  Lemma incl_clos_trans: (inclusion A R trans_clos).
-    Red;Auto with sets.
-  Qed.
-
-  Lemma Acc_clos_trans: (x:A)(Acc A R x)->(Acc A trans_clos x).
-    NewInduction 1 as [x0 _ H1].
-    Apply Acc_intro.
-    Intros y H2.
-    NewInduction H2;Auto with sets.
-    Apply Acc_inv with y ;Auto with sets.
-  Qed.
-
-  Hints Resolve Acc_clos_trans.
-
-  Lemma Acc_inv_trans: (x,y:A)(trans_clos y x)->(Acc A R x)->(Acc A R y).
-  Proof.
-    NewInduction 1 as [|x y];Auto with sets.
-    Intro; Apply Acc_inv with y; Assumption.
-  Qed.
-
-  Theorem wf_clos_trans: (well_founded A R)  ->(well_founded A trans_clos).
-  Proof.
-    Unfold well_founded;Auto with sets.
-  Qed.
-
-End Wf_Transitive_Closure.
diff --git a/theories7/Wellfounded/Union.v b/theories7/Wellfounded/Union.v
deleted file mode 100644
index 9b31f72d..00000000
--- a/theories7/Wellfounded/Union.v
+++ /dev/null
@@ -1,74 +0,0 @@
-(************************************************************************)
-(*  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: Union.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-(** Author: Bruno Barras *)
-
-Require Relation_Operators.
-Require Relation_Definitions.
-Require Transitive_Closure.
-
-Section WfUnion.
-  Variable A: Set.
-  Variable R1,R2: (relation A).
-  
- Notation Union := (union A R1 R2).
-
- Hints Resolve Acc_clos_trans wf_clos_trans.
-
-Remark strip_commut: 
-      (commut A R1 R2)->(x,y:A)(clos_trans A R1 y x)->(z:A)(R2 z y)
-            ->(EX y':A | (R2 y' x) & (clos_trans A R1 z y')).
-Proof.
- NewInduction 2 as [x y|x y z H0 IH1 H1 IH2]; Intros.
- Elim H with y x z ;Auto with sets;Intros x0 H2 H3.
- Exists x0;Auto with sets.
-
- Elim IH1 with z0 ;Auto with sets;Intros.
- Elim IH2 with x0 ;Auto with sets;Intros.
- Exists x1;Auto with sets.
- Apply t_trans with x0; Auto with sets.
-Qed.
-
-
-  Lemma Acc_union:  (commut A R1 R2)->((x:A)(Acc A R2 x)->(Acc A R1 x))
-                         ->(a:A)(Acc A R2 a)->(Acc A Union a).
-Proof.
- NewInduction 3 as [x H1 H2].
- Apply Acc_intro;Intros.
- Elim H3;Intros;Auto with sets.
- Cut (clos_trans A  R1 y x);Auto with sets.
- ElimType (Acc A (clos_trans A R1) y);Intros.
- Apply Acc_intro;Intros.
- Elim H8;Intros.
- Apply H6;Auto with sets.
- Apply t_trans with x0 ;Auto with sets.
-
- Elim strip_commut with x x0 y0 ;Auto with sets;Intros.
- Apply Acc_inv_trans with x1 ;Auto with sets.
- Unfold union .
- Elim H11;Auto with sets;Intros.
- Apply t_trans with y1 ;Auto with sets.
-
- Apply (Acc_clos_trans A).
- Apply Acc_inv with x ;Auto with sets.
- Apply H0.
- Apply Acc_intro;Auto with sets.
-Qed.
-
-
-  Theorem wf_union:  (commut A R1 R2)->(well_founded A R1)->(well_founded A R2)
-                  ->(well_founded A Union).
-Proof.
- Unfold well_founded .
- Intros.
- Apply Acc_union;Auto with sets.
-Qed.
-
-End WfUnion.
diff --git a/theories7/Wellfounded/Well_Ordering.v b/theories7/Wellfounded/Well_Ordering.v
deleted file mode 100644
index 5c2b2405..00000000
--- a/theories7/Wellfounded/Well_Ordering.v
+++ /dev/null
@@ -1,72 +0,0 @@
-(************************************************************************)
-(*  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: Well_Ordering.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-(** Author: Cristina Cornes.
-    From: Constructing Recursion Operators in Type Theory
-    L. Paulson  JSC (1986) 2, 325-355 *)
-
-Require Eqdep.
-
-Section WellOrdering.
-Variable A:Set.
-Variable B:A->Set. 
-
-Inductive WO : Set :=
-   sup : (a:A)(f:(B a)->WO)WO.
-
-
-Inductive le_WO  : WO->WO->Prop :=
-  le_sup : (a:A)(f:(B a)->WO)(v:(B a)) (le_WO  (f v) (sup a f)).
- 
-
-Theorem wf_WO : (well_founded WO le_WO ).
-Proof.
- Unfold well_founded ;Intro.
- Apply Acc_intro.
- Elim a.
- Intros.
- Inversion H0.
- Apply Acc_intro.
- Generalize H4 ;Generalize H1 ;Generalize f0 ;Generalize v.
- Rewrite -> H3.
- Intros.
- Apply (H v0 y0).
- Cut (eq ? f f1).
- Intros E;Rewrite -> E;Auto.
- Symmetry.
- Apply (inj_pair2 A [a0:A](B a0)->WO a0 f1 f H5).
-Qed.
-
-End WellOrdering.
-
-
-Section Characterisation_wf_relations.
-
-(** Wellfounded relations are the inverse image of wellordering types *)
-(*  in course of development                                          *)
-
-
-Variable A:Set.
-Variable leA:A->A->Prop.
-
-Definition B:= [a:A] {x:A | (leA x a)}.
-
-Definition  wof: (well_founded A leA)-> A-> (WO A B).
-Proof.
- Intros.
- Apply (well_founded_induction A leA H [a:A](WO A B));Auto.
- Intros.
- Apply (sup A B x).
- Unfold 1 B .
- NewDestruct 1 as [x0].
- Apply (H1 x0);Auto.
-Qed.
-
-End Characterisation_wf_relations.
diff --git a/theories7/Wellfounded/Wellfounded.v b/theories7/Wellfounded/Wellfounded.v
deleted file mode 100644
index d1a8dd01..00000000
--- a/theories7/Wellfounded/Wellfounded.v
+++ /dev/null
@@ -1,20 +0,0 @@
-(************************************************************************)
-(*  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: Wellfounded.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-Require Export Disjoint_Union.
-Require Export Inclusion.
-Require Export Inverse_Image.
-Require Export Lexicographic_Exponentiation.
-Require Export Lexicographic_Product.
-Require Export Transitive_Closure.
-Require Export Union.
-Require Export Well_Ordering.
-
-
diff --git a/theories7/ZArith/BinInt.v b/theories7/ZArith/BinInt.v
deleted file mode 100644
index 9071896b..00000000
--- a/theories7/ZArith/BinInt.v
+++ /dev/null
@@ -1,1005 +0,0 @@
-(************************************************************************)
-(*  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: BinInt.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-(***********************************************************)
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
-(***********************************************************)
-
-Require Export BinPos.
-Require Export Pnat.
-Require BinNat.
-Require Plus.
-Require Mult.
-(**********************************************************************)
-(** Binary integer numbers *)
-
-Inductive Z : Set := 
-  ZERO : Z | POS : positive -> Z | NEG : positive -> Z.
-
-(** Declare Scope Z_scope with Key Z *)
-Delimits Scope Z_scope with Z.
-
-(** Automatically open scope positive_scope for the constructors of Z *)
-Bind Scope Z_scope with Z.
-Arguments Scope POS [ positive_scope ].
-Arguments Scope NEG [ positive_scope ].
-
-(** Subtraction of positive into Z *)
-
-Definition Zdouble_plus_one [x:Z] :=
-  Cases x of 
-  | ZERO    => (POS xH)
-  | (POS p) => (POS (xI p))
-  | (NEG p) => (NEG (double_moins_un p))
-  end.
-
-Definition Zdouble_minus_one [x:Z] :=
-  Cases x of 
-  | ZERO    => (NEG xH)
-  | (NEG p) => (NEG (xI p))
-  | (POS p) => (POS (double_moins_un p))
-  end.
-
-Definition Zdouble [x:Z] :=
-  Cases x of
-  | ZERO => ZERO
-  | (POS p) => (POS (xO p))
-  | (NEG p) => (NEG (xO p))
- end.
-
-Fixpoint ZPminus [x,y:positive] : Z :=
-  Cases x y of
-  | (xI x') (xI y') => (Zdouble (ZPminus x' y'))
-  | (xI x') (xO y') => (Zdouble_plus_one (ZPminus x' y'))
-  | (xI x') xH      => (POS (xO x'))
-  | (xO x') (xI y') => (Zdouble_minus_one (ZPminus x' y'))
-  | (xO x') (xO y') => (Zdouble (ZPminus x' y'))
-  | (xO x') xH      => (POS (double_moins_un x'))
-  | xH      (xI y') => (NEG (xO y'))
-  | xH      (xO y') => (NEG (double_moins_un y'))
-  | xH      xH      => ZERO
-  end.
-
-(** Addition on integers *)
-
-Definition Zplus := [x,y:Z]
-  Cases x y of
-    ZERO      y       => y
-  | x         ZERO    => x
-  | (POS x') (POS y') => (POS (add x' y'))
-  | (POS x') (NEG y') => 
-      Cases (compare x' y' EGAL) of
-      | EGAL => ZERO
-      | INFERIEUR => (NEG (true_sub y' x'))
-      | SUPERIEUR => (POS (true_sub x' y'))
-      end
-  | (NEG x') (POS y') =>
-      Cases (compare x' y' EGAL) of
-      | EGAL => ZERO
-      | INFERIEUR => (POS (true_sub y' x'))
-      | SUPERIEUR => (NEG (true_sub x' y'))
-      end
-  | (NEG x') (NEG y') => (NEG (add x' y'))
-  end.
-
-V8Infix "+" Zplus : Z_scope.
-
-(** Opposite *)
-
-Definition Zopp := [x:Z]
- Cases x of
-      ZERO => ZERO
-    | (POS x) => (NEG x)
-    | (NEG x) => (POS x)
-    end.
-
-V8Notation "- x" := (Zopp x) : Z_scope.
-
-(** Successor on integers *)
-
-Definition Zs := [x:Z](Zplus x (POS xH)).
-
-(** Predecessor on integers *)
-
-Definition Zpred := [x:Z](Zplus x (NEG xH)).
-
-(** Subtraction on integers *)
-
-Definition Zminus := [m,n:Z](Zplus m (Zopp n)).
-
-V8Infix "-" Zminus : Z_scope.
-
-(** Multiplication on integers *)
-
-Definition Zmult := [x,y:Z]
-  Cases x y of
-  | ZERO     _        => ZERO
-  | _        ZERO     => ZERO
-  | (POS x') (POS y') => (POS (times x' y'))
-  | (POS x') (NEG y') => (NEG (times x' y'))
-  | (NEG x') (POS y') => (NEG (times x' y'))
-  | (NEG x') (NEG y') => (POS (times x' y'))
-  end.
-
-V8Infix "*" Zmult : Z_scope.
-
-(** Comparison of integers *)
-
-Definition Zcompare := [x,y:Z]
-  Cases x y of
-  | ZERO     ZERO     => EGAL
-  | ZERO     (POS y') => INFERIEUR
-  | ZERO     (NEG y') => SUPERIEUR
-  | (POS x') ZERO     => SUPERIEUR
-  | (POS x') (POS y') => (compare x' y' EGAL)
-  | (POS x') (NEG y') => SUPERIEUR
-  | (NEG x') ZERO     => INFERIEUR
-  | (NEG x') (POS y') => INFERIEUR
-  | (NEG x') (NEG y') => (Op (compare x' y' EGAL))
-  end.
-
-V8Infix "?=" Zcompare (at level 70, no associativity) : Z_scope.
-
-Tactic Definition ElimCompare com1 com2:=
-  Case (Dcompare (Zcompare com1 com2)); [ Idtac | 
-     Let x = FreshId "H" In Intro x; Case x; Clear x ].
-
-(** Sign function *)
-
-Definition Zsgn [z:Z] : Z :=
-  Cases z of 
-     ZERO   => ZERO
-  | (POS p) => (POS xH)
-  | (NEG p) => (NEG xH)
-  end.
-
-(** Direct, easier to handle variants of successor and addition *)
-
-Definition Zsucc' [x:Z] :=
-  Cases x of
-  | ZERO => (POS xH)
-  | (POS x') => (POS (add_un x'))
-  | (NEG x') => (ZPminus xH x')
-  end.
-
-Definition Zpred' [x:Z] :=
-  Cases x of
-  | ZERO => (NEG xH)
-  | (POS x') => (ZPminus x' xH)
-  | (NEG x') => (NEG (add_un x'))
-  end.
-
-Definition Zplus' := [x,y:Z]
-  Cases x y of
-    ZERO      y       => y
-  | x         ZERO    => x
-  | (POS x') (POS y') => (POS (add x' y'))
-  | (POS x') (NEG y') => (ZPminus x' y')
-  | (NEG x') (POS y') => (ZPminus y' x')
-  | (NEG x') (NEG y') => (NEG (add x' y'))
-  end.
-
-Open Local Scope Z_scope.
-
-(**********************************************************************)
-(** Inductive specification of Z *)
-
-Theorem Zind : (P:(Z ->Prop))
-  (P ZERO) -> ((x:Z)(P x) ->(P (Zsucc' x))) -> ((x:Z)(P x) ->(P (Zpred' x))) ->
-     (z:Z)(P z).
-Proof.
-Intros P H0 Hs Hp z; NewDestruct z.
-  Assumption.
-  Apply Pind with P:=[p](P (POS p)).
-    Change (P (Zsucc' ZERO)); Apply Hs; Apply H0.
-    Intro n; Exact (Hs (POS n)).
-  Apply Pind with P:=[p](P (NEG p)).
-    Change (P (Zpred' ZERO)); Apply Hp; Apply H0.
-    Intro n; Exact (Hp (NEG n)).
-Qed.
-
-(**********************************************************************)
-(** Properties of opposite on binary integer numbers *)
-
-Theorem Zopp_NEG : (x:positive) (Zopp (NEG x)) = (POS x).
-Proof.
-Reflexivity.
-Qed.
-
-(** [opp] is involutive *)
-
-Theorem Zopp_Zopp: (x:Z) (Zopp (Zopp x)) = x.
-Proof.
-Intro x; NewDestruct x; Reflexivity.
-Qed.
-
-(** Injectivity of the opposite *)
-
-Theorem Zopp_intro : (x,y:Z) (Zopp x) = (Zopp y) -> x = y.
-Proof.
-Intros x y;Case x;Case y;Simpl;Intros; [
-  Trivial | Discriminate H | Discriminate H | Discriminate H
-| Simplify_eq H; Intro E; Rewrite E; Trivial
-| Discriminate H | Discriminate H | Discriminate H
-| Simplify_eq H; Intro E; Rewrite E; Trivial ].
-Qed.
-
-(**********************************************************************)
-(* Properties of the direct definition of successor and predecessor *)
-
-Lemma Zpred'_succ' : (x:Z)(Zpred' (Zsucc' x))=x.
-Proof.
-Intro x; NewDestruct x; Simpl.
-  Reflexivity.
-NewDestruct p; Simpl; Try Rewrite double_moins_un_add_un_xI; Reflexivity.
-NewDestruct p; Simpl; Try Rewrite is_double_moins_un; Reflexivity.
-Qed.
-
-Lemma Zsucc'_discr : (x:Z)x<>(Zsucc' x).
-Proof.
-Intro x; NewDestruct x; Simpl.
-  Discriminate.
-  Injection; Apply add_un_discr.
-  NewDestruct p; Simpl.
-    Discriminate.
-    Intro H; Symmetry in H; Injection H; Apply double_moins_un_xO_discr.
-    Discriminate.
-Qed.
-
-(**********************************************************************)
-(** Other properties of binary integer numbers *)
-
-Lemma ZL0 : (S (S O))=(plus (S O) (S O)).
-Proof.
-Reflexivity.
-Qed.
-
-(**********************************************************************)
-(** Properties of the addition on integers *)
-
-(** zero is left neutral for addition *)
-
-Theorem Zero_left: (x:Z) (Zplus ZERO x) = x.
-Proof.
-Intro x; NewDestruct x; Reflexivity.
-Qed.
-
-(** zero is right neutral for addition *)
-
-Theorem Zero_right: (x:Z) (Zplus x ZERO) = x.
-Proof.
-Intro x; NewDestruct x; Reflexivity.
-Qed.
-
-(** addition is commutative *)
-
-Theorem Zplus_sym: (x,y:Z) (Zplus x y) = (Zplus y x).
-Proof.
-Intro x;NewInduction x as [|p|p];Intro y; NewDestruct y as [|q|q];Simpl;Try Reflexivity.
-  Rewrite add_sym; Reflexivity.
-  Rewrite ZC4; NewDestruct (compare q p EGAL); Reflexivity.
-  Rewrite ZC4; NewDestruct (compare q p EGAL); Reflexivity.
-  Rewrite add_sym; Reflexivity.
-Qed.
-
-(** opposite distributes over addition *)
-
-Theorem Zopp_Zplus: 
-  (x,y:Z) (Zopp (Zplus x y)) = (Zplus (Zopp x) (Zopp y)).
-Proof.
-Intro x; NewDestruct x as [|p|p]; Intro y; NewDestruct y as [|q|q]; Simpl;
-  Reflexivity Orelse NewDestruct  (compare p q EGAL); Reflexivity.
-Qed.
-
-(** opposite is inverse for addition *)
-
-Theorem Zplus_inverse_r: (x:Z) (Zplus x (Zopp x)) = ZERO.
-Proof.
-Intro x; NewDestruct x as [|p|p]; Simpl; [
-  Reflexivity
-| Rewrite (convert_compare_EGAL p); Reflexivity
-| Rewrite (convert_compare_EGAL p); Reflexivity ].
-Qed.
-
-Theorem Zplus_inverse_l: (x:Z) (Zplus (Zopp x) x) = ZERO.
-Proof.
-Intro; Rewrite Zplus_sym; Apply Zplus_inverse_r.
-Qed.
-
-Hints Local Resolve Zero_left Zero_right.
-
-(** addition is associative *)
-
-Lemma weak_assoc :
-  (x,y:positive)(z:Z) (Zplus (POS x) (Zplus (POS y) z))=
-                       (Zplus (Zplus (POS x) (POS y)) z).
-Proof.
-Intros x y z';Case z'; [
-  Auto with arith
-| Intros z;Simpl; Rewrite add_assoc;Auto with arith
-| Intros z; Simpl; ElimPcompare y z;
-  Intros E0;Rewrite E0;
-  ElimPcompare '(add x y) 'z;Intros E1;Rewrite E1; [
-    Absurd (compare (add x y) z EGAL)=EGAL; [    (* Case 1 *)
-      Rewrite convert_compare_SUPERIEUR; [
-        Discriminate
-      | Rewrite convert_add; Rewrite (compare_convert_EGAL y z E0);
-        Elim (ZL4 x);Intros k E2;Rewrite E2; Simpl; Unfold gt lt; Apply le_n_S;
-        Apply le_plus_r ]
-    | Assumption ]
-  | Absurd (compare (add x y) z EGAL)=INFERIEUR; [ (* Case 2 *)
-      Rewrite convert_compare_SUPERIEUR; [
-        Discriminate
-      | Rewrite convert_add; Rewrite (compare_convert_EGAL y z E0);
-        Elim (ZL4 x);Intros k E2;Rewrite E2; Simpl; Unfold gt lt; Apply le_n_S;
-        Apply le_plus_r]
-    | Assumption ]
-  | Rewrite (compare_convert_EGAL y z E0); (* Case 3 *)
-    Elim (sub_pos_SUPERIEUR (add x z) z);[
-      Intros t H; Elim H;Intros H1 H2;Elim H2;Intros H3 H4;
-      Unfold true_sub; Rewrite H1; Cut x=t; [
-        Intros E;Rewrite E;Auto with arith
-      | Apply simpl_add_r with z:=z; Rewrite <- H3; Rewrite add_sym; Trivial with arith ]
-    | Pattern 1 z; Rewrite <- (compare_convert_EGAL y z E0); Assumption ]
-  | Elim (sub_pos_SUPERIEUR z y); [ (* Case 4 *)
-      Intros k H;Elim H;Intros H1 H2;Elim H2;Intros H3 H4; Unfold 1 true_sub;
-      Rewrite H1; Cut x=k; [
-        Intros E;Rewrite E; Rewrite (convert_compare_EGAL k); Trivial with arith
-      | Apply simpl_add_r with z:=y; Rewrite (add_sym k y); Rewrite H3;
-        Apply compare_convert_EGAL; Assumption ]
-    | Apply ZC2;Assumption]
-  | Elim (sub_pos_SUPERIEUR z y); [ (* Case 5 *)
-      Intros k H;Elim H;Intros H1 H2;Elim H2;Intros H3 H4;
-      Unfold 1 3 5 true_sub; Rewrite H1;
-      Cut (compare x k EGAL)=INFERIEUR; [
-        Intros E2;Rewrite E2; Elim (sub_pos_SUPERIEUR k x); [
-          Intros i H5;Elim H5;Intros H6 H7;Elim H7;Intros H8 H9;
-          Elim (sub_pos_SUPERIEUR z (add x y)); [
-            Intros j H10;Elim H10;Intros H11 H12;Elim H12;Intros H13 H14;
-            Unfold true_sub ;Rewrite H6;Rewrite H11; Cut i=j; [
-              Intros E;Rewrite E;Auto with arith
-            | Apply (simpl_add_l (add x y)); Rewrite H13; 
-              Rewrite (add_sym x y); Rewrite <- add_assoc; Rewrite H8;
-              Assumption ]
-          | Apply ZC2; Assumption]
-        | Apply ZC2;Assumption]
-      | Apply convert_compare_INFERIEUR;
-        Apply simpl_lt_plus_l with p:=(convert y);
-        Do 2 Rewrite <- convert_add; Apply compare_convert_INFERIEUR;
-        Rewrite H3; Rewrite add_sym; Assumption ]
-    | Apply ZC2; Assumption ]
-  | Elim (sub_pos_SUPERIEUR z y); [ (* Case 6 *)
-      Intros k H;Elim H;Intros H1 H2;Elim H2;Intros H3 H4;
-      Elim (sub_pos_SUPERIEUR (add x y) z); [
-        Intros i H5;Elim H5;Intros H6 H7;Elim H7;Intros H8 H9;
-        Unfold true_sub; Rewrite H1;Rewrite H6;
-        Cut (compare x k EGAL)=SUPERIEUR; [
-          Intros H10;Elim (sub_pos_SUPERIEUR x k H10);
-          Intros j H11;Elim H11;Intros H12 H13;Elim H13;Intros H14 H15;
-          Rewrite H10; Rewrite H12; Cut i=j; [
-            Intros H16;Rewrite H16;Auto with arith
-          | Apply (simpl_add_l (add z k)); Rewrite <- (add_assoc z k j);
-            Rewrite H14; Rewrite (add_sym z k); Rewrite <- add_assoc;
-            Rewrite H8; Rewrite (add_sym x y); Rewrite add_assoc;
-            Rewrite (add_sym k y); Rewrite H3; Trivial with arith]
-        | Apply convert_compare_SUPERIEUR; Unfold lt gt;
-          Apply simpl_lt_plus_l with p:=(convert y);
-          Do 2 Rewrite <- convert_add; Apply compare_convert_INFERIEUR;
-          Rewrite H3; Rewrite add_sym; Apply ZC1; Assumption ]
-      | Assumption ]
-    | Apply ZC2;Assumption ]
-  | Absurd (compare (add x y) z EGAL)=EGAL; [ (* Case 7 *)
-      Rewrite convert_compare_SUPERIEUR; [
-        Discriminate
-      | Rewrite convert_add; Unfold gt;Apply lt_le_trans with m:=(convert y);[
-          Apply compare_convert_INFERIEUR; Apply ZC1; Assumption
-        | Apply le_plus_r]]
-    | Assumption ]
-  | Absurd (compare (add x y) z EGAL)=INFERIEUR; [ (* Case 8 *)
-      Rewrite convert_compare_SUPERIEUR; [
-        Discriminate
-      | Unfold gt; Apply lt_le_trans with m:=(convert y);[
-          Exact (compare_convert_SUPERIEUR y z E0)
-        | Rewrite convert_add; Apply le_plus_r]]
-    | Assumption ]
-  | Elim sub_pos_SUPERIEUR with 1:=E0;Intros k H1; (* Case 9 *)
-    Elim sub_pos_SUPERIEUR with 1:=E1; Intros i H2;Elim H1;Intros H3 H4;
-    Elim H4;Intros H5 H6; Elim H2;Intros H7 H8;Elim H8;Intros H9 H10; 
-    Unfold true_sub ;Rewrite H3;Rewrite H7; Cut (add x k)=i; [
-      Intros E;Rewrite E;Auto with arith
-    | Apply (simpl_add_l z);Rewrite (add_sym x k);
-      Rewrite add_assoc; Rewrite H5;Rewrite H9;
-      Rewrite add_sym; Trivial with arith ]]].
-Qed.
-
-Hints Local Resolve weak_assoc.
-
-Theorem Zplus_assoc :
-  (n,m,p:Z) (Zplus n (Zplus m p))= (Zplus (Zplus n m) p).
-Proof.
-Intros x y z;Case x;Case y;Case z;Auto with arith; Intros; [
-  Rewrite (Zplus_sym (NEG p0)); Rewrite weak_assoc;
-  Rewrite (Zplus_sym (Zplus (POS p1) (NEG p0))); Rewrite weak_assoc;
-  Rewrite (Zplus_sym (POS p1)); Trivial with arith
-| Apply Zopp_intro; Do 4 Rewrite Zopp_Zplus; 
-  Do 2 Rewrite Zopp_NEG; Rewrite Zplus_sym; Rewrite <- weak_assoc;
-  Rewrite (Zplus_sym (Zopp (POS p1)));
-  Rewrite (Zplus_sym (Zplus (POS p0) (Zopp (POS p1))));
-  Rewrite (weak_assoc p); Rewrite weak_assoc; Rewrite (Zplus_sym (POS p0)); 
-  Trivial with arith
-| Rewrite Zplus_sym; Rewrite (Zplus_sym (POS p0) (POS p));
-  Rewrite <- weak_assoc; Rewrite Zplus_sym; Rewrite (Zplus_sym (POS p0));
-  Trivial with arith
-| Apply Zopp_intro; Do 4 Rewrite Zopp_Zplus; 
-  Do 2 Rewrite Zopp_NEG; Rewrite (Zplus_sym (Zopp (POS p0)));
-  Rewrite weak_assoc; Rewrite (Zplus_sym (Zplus (POS p1) (Zopp (POS p0))));
-  Rewrite weak_assoc;Rewrite (Zplus_sym (POS p)); Trivial with arith
-| Apply Zopp_intro; Do 4 Rewrite Zopp_Zplus; Do 2 Rewrite Zopp_NEG;
-  Apply weak_assoc
-| Apply Zopp_intro; Do 4 Rewrite Zopp_Zplus; Do 2 Rewrite Zopp_NEG;
-   Apply weak_assoc]
-.
-Qed.
-
-V7only [Notation Zplus_assoc_l := Zplus_assoc.].
-
-Lemma Zplus_assoc_r : (n,m,p:Z)(Zplus (Zplus n m) p) =(Zplus n (Zplus m p)).
-Proof.
-Intros; Symmetry; Apply Zplus_assoc.
-Qed.
-
-(** Associativity mixed with commutativity *)
-
-Theorem Zplus_permute : (n,m,p:Z) (Zplus n (Zplus m p))=(Zplus m (Zplus n p)).
-Proof.
-Intros n m p;
-Rewrite Zplus_sym;Rewrite <- Zplus_assoc; Rewrite (Zplus_sym p n); Trivial with arith.
-Qed.
-
-(** addition simplifies *)
-
-Theorem Zsimpl_plus_l : (n,m,p:Z)(Zplus n m)=(Zplus n p)->m=p.
-Intros n m p H; Cut (Zplus (Zopp n) (Zplus n m))=(Zplus (Zopp n) (Zplus n p));[
-  Do 2 Rewrite -> Zplus_assoc; Rewrite -> (Zplus_sym (Zopp n) n);
-  Rewrite -> Zplus_inverse_r;Simpl; Trivial with arith
-| Rewrite -> H; Trivial with arith ].
-Qed.
-
-(** addition and successor permutes *)
-
-Lemma Zplus_S_n: (x,y:Z) (Zplus (Zs x) y) = (Zs (Zplus x y)).
-Proof.
-Intros x y; Unfold Zs; Rewrite (Zplus_sym (Zplus x y)); Rewrite Zplus_assoc;
-Rewrite (Zplus_sym (POS xH)); Trivial with arith.
-Qed.
-
-Lemma Zplus_n_Sm : (n,m:Z) (Zs (Zplus n m))=(Zplus n (Zs m)).
-Proof.
-Intros n m; Unfold Zs; Rewrite Zplus_assoc; Trivial with arith.
-Qed.
-
-Lemma Zplus_Snm_nSm : (n,m:Z)(Zplus (Zs n) m)=(Zplus n (Zs m)).
-Proof.
-Unfold Zs ;Intros n m; Rewrite <- Zplus_assoc; Rewrite (Zplus_sym (POS xH));
-Trivial with arith.
-Qed.
-
-(** Misc properties, usually redundant or non natural *)
-
-Lemma Zplus_n_O : (n:Z) n=(Zplus n ZERO).
-Proof.
-Symmetry; Apply Zero_right.
-Qed.
-
-Lemma Zplus_unit_left : (n,m:Z) (Zplus n ZERO)=m -> n=m.
-Proof.
-Intros n m; Rewrite Zero_right; Intro; Assumption.
-Qed.
-
-Lemma Zplus_unit_right : (n,m:Z) n=(Zplus m ZERO) -> n=m.
-Proof.
-Intros n m; Rewrite Zero_right; Intro; Assumption.
-Qed.
-
-Lemma Zplus_simpl : (x,y,z,t:Z) x=y -> z=t -> (Zplus x z)=(Zplus y t).
-Proof.
-Intros; Rewrite H; Rewrite H0; Reflexivity.
-Qed.
-
-Lemma Zplus_Zopp_expand : (x,y,z:Z)
-  (Zplus x (Zopp y))=(Zplus (Zplus x (Zopp z)) (Zplus z (Zopp y))).
-Proof.
-Intros x y z.
-Rewrite <- (Zplus_assoc x).
-Rewrite (Zplus_assoc (Zopp z)).
-Rewrite Zplus_inverse_l.
-Reflexivity.
-Qed.
-
-(**********************************************************************)
-(** Properties of successor and predecessor on binary integer numbers *)
-
-Theorem Zn_Sn : (x:Z) ~ x=(Zs x).
-Proof.
-Intros n;Cut ~ZERO=(POS xH);[
-  Unfold not ;Intros H1 H2;Apply H1;Apply (Zsimpl_plus_l n);Rewrite Zero_right;
-  Exact H2
-| Discriminate ].
-Qed.
-
-Theorem add_un_Zs : (x:positive) (POS (add_un x)) = (Zs (POS x)).
-Proof.
-Intro; Rewrite -> ZL12; Unfold Zs; Simpl; Trivial with arith.
-Qed.
-
-(** successor and predecessor are inverse functions *)
-
-Theorem Zs_pred : (n:Z) n=(Zs (Zpred n)).
-Proof.
-Intros n; Unfold Zs Zpred ;Rewrite <- Zplus_assoc; Simpl; Rewrite Zero_right;
-Trivial with arith.
-Qed. 
-
-Hints Immediate Zs_pred : zarith.
- 
-Theorem Zpred_Sn : (x:Z) x=(Zpred (Zs x)).
-Proof.
-Intros m; Unfold Zpred Zs; Rewrite <- Zplus_assoc; Simpl; 
-Rewrite Zplus_sym; Auto with arith.
-Qed.
-
-Theorem Zeq_add_S : (n,m:Z) (Zs n)=(Zs m) -> n=m.
-Proof.
-Intros n m H.
-Change (Zplus (Zplus (NEG xH) (POS xH)) n)=
-       (Zplus (Zplus (NEG xH) (POS xH)) m);
-Do 2 Rewrite <- Zplus_assoc; Do 2 Rewrite (Zplus_sym (POS xH));
-Unfold Zs in H;Rewrite H; Trivial with arith.
-Qed.
- 
-(** Misc properties, usually redundant or non natural *)
-
-Lemma Zeq_S : (n,m:Z) n=m -> (Zs n)=(Zs m).
-Proof.
-Intros n m H; Rewrite H; Reflexivity.
-Qed.
-
-Lemma Znot_eq_S : (n,m:Z) ~(n=m) -> ~((Zs n)=(Zs m)).
-Proof.
-Unfold not ;Intros n m H1 H2;Apply H1;Apply Zeq_add_S; Assumption.
-Qed.
-
-(**********************************************************************)
-(** Properties of subtraction on binary integer numbers *)
-
-Lemma Zminus_0_r : (x:Z) (Zminus x ZERO)=x.
-Proof.
-Intro; Unfold Zminus; Simpl;Rewrite Zero_right; Trivial with arith.
-Qed.
-
-Lemma Zminus_n_O : (x:Z) x=(Zminus x ZERO).
-Proof.
-Intro; Symmetry; Apply Zminus_0_r.
-Qed.
-
-Lemma Zminus_diag : (n:Z)(Zminus n n)=ZERO.
-Proof.
-Intro; Unfold Zminus; Rewrite Zplus_inverse_r; Trivial with arith.
-Qed.
-
-Lemma Zminus_n_n : (n:Z)(ZERO=(Zminus n n)).
-Proof.
-Intro; Symmetry; Apply Zminus_diag.
-Qed.
-
-Lemma Zplus_minus : (x,y,z:Z)(x=(Zplus y z))->(z=(Zminus x y)).
-Proof.
-Intros n m p H;Unfold Zminus;Apply (Zsimpl_plus_l m); 
-Rewrite (Zplus_sym m (Zplus n (Zopp m))); Rewrite <- Zplus_assoc;
-Rewrite Zplus_inverse_l; Rewrite Zero_right; Rewrite H; Trivial with arith.
-Qed.
-
-Lemma Zminus_plus : (x,y:Z)(Zminus (Zplus x y) x)=y.
-Proof.
-Intros n m;Unfold Zminus ;Rewrite -> (Zplus_sym n m);Rewrite <- Zplus_assoc;
-Rewrite -> Zplus_inverse_r; Apply Zero_right.
-Qed.
-
-Lemma Zle_plus_minus : (n,m:Z) (Zplus n (Zminus m n))=m.
-Proof.
-Unfold Zminus; Intros n m; Rewrite Zplus_permute; Rewrite Zplus_inverse_r;
-Apply Zero_right.
-Qed.
-
-Lemma Zminus_Sn_m : (n,m:Z)((Zs (Zminus n m))=(Zminus (Zs n) m)).
-Proof.
-Intros n m;Unfold Zminus Zs; Rewrite (Zplus_sym n (Zopp m));
-Rewrite <- Zplus_assoc;Apply Zplus_sym.
-Qed.
-
-Lemma Zminus_plus_simpl_l : 
-  (x,y,z:Z)(Zminus (Zplus z x) (Zplus z y))=(Zminus x y).
-Proof.
-Intros n m p;Unfold Zminus; Rewrite Zopp_Zplus; Rewrite Zplus_assoc;
-Rewrite (Zplus_sym p); Rewrite <- (Zplus_assoc n p); Rewrite Zplus_inverse_r;
-Rewrite Zero_right; Trivial with arith.
-Qed.
-
-Lemma Zminus_plus_simpl : 
-  (x,y,z:Z)((Zminus x y)=(Zminus (Zplus z x) (Zplus z y))).
-Proof.
-Intros; Symmetry; Apply Zminus_plus_simpl_l.
-Qed.
-
-Lemma Zminus_Zplus_compatible :
-  (x,y,z:Z) (Zminus (Zplus x z) (Zplus y z)) = (Zminus x y).
-Intros x y n.
-Unfold Zminus.
-Rewrite -> Zopp_Zplus.
-Rewrite -> (Zplus_sym (Zopp y) (Zopp n)).
-Rewrite -> Zplus_assoc.
-Rewrite <- (Zplus_assoc x n (Zopp n)).
-Rewrite -> (Zplus_inverse_r n).
-Rewrite <- Zplus_n_O.
-Reflexivity.
-Qed.
-
-(** Misc redundant properties *)
-
-V7only [Set Implicit Arguments.].
-
-Lemma Zeq_Zminus : (x,y:Z)x=y -> (Zminus x y)=ZERO.
-Proof.
-Intros x y H; Rewrite H; Symmetry; Apply Zminus_n_n.
-Qed.
-
-Lemma Zminus_Zeq : (x,y:Z)(Zminus x y)=ZERO -> x=y.
-Proof.
-Intros x y H; Rewrite <- (Zle_plus_minus y x); Rewrite H; Apply Zero_right.
-Qed.
-
-V7only [Unset Implicit Arguments.].
-
-(**********************************************************************)
-(** Properties of multiplication on binary integer numbers *)
-
-(** One is neutral for multiplication *)
-
-Theorem Zmult_1_n : (n:Z)(Zmult (POS xH) n)=n.
-Proof.
-Intro x; NewDestruct x; Reflexivity.
-Qed.
-V7only [Notation Zmult_one := Zmult_1_n.].
-
-Theorem Zmult_n_1 : (n:Z)(Zmult n (POS xH))=n.
-Proof.
-Intro x; NewDestruct x; Simpl; Try Rewrite times_x_1; Reflexivity.
-Qed.
-
-(** Zero property of multiplication *)
-
-Theorem Zero_mult_left: (x:Z) (Zmult ZERO x) = ZERO.
-Proof.
-Intro x; NewDestruct x; Reflexivity.
-Qed.
-
-Theorem Zero_mult_right: (x:Z) (Zmult x ZERO) = ZERO.
-Proof.
-Intro x; NewDestruct x; Reflexivity.
-Qed.
-
-Hints Local Resolve Zero_mult_left Zero_mult_right.
-
-Lemma Zmult_n_O : (n:Z) ZERO=(Zmult n ZERO).
-Proof.
-Intro x; NewDestruct x; Reflexivity.
-Qed.
-
-(** Commutativity of multiplication *)
-
-Theorem Zmult_sym : (x,y:Z) (Zmult x y) = (Zmult y x).
-Proof.
-Intros x y; NewDestruct x as [|p|p]; NewDestruct y as [|q|q]; Simpl; 
-  Try Rewrite (times_sym p q); Reflexivity.
-Qed.
-
-(** Associativity of multiplication *)
-
-Theorem Zmult_assoc :
-  (x,y,z:Z) (Zmult x (Zmult y z))= (Zmult (Zmult x y) z).
-Proof.
-Intros x y z; NewDestruct x; NewDestruct y; NewDestruct z; Simpl; 
-  Try Rewrite times_assoc; Reflexivity.
-Qed.
-V7only [Notation Zmult_assoc_l := Zmult_assoc.].
-
-Lemma Zmult_assoc_r : (n,m,p:Z)((Zmult (Zmult n m) p) = (Zmult n (Zmult m p))).
-Proof.
-Intros n m p; Rewrite Zmult_assoc; Trivial with arith.
-Qed.
-
-(** Associativity mixed with commutativity *)
-
-Theorem Zmult_permute : (n,m,p:Z)(Zmult n (Zmult m p)) = (Zmult m (Zmult n p)).
-Proof.
-Intros x y z; Rewrite -> (Zmult_assoc y x z); Rewrite -> (Zmult_sym y x).
-Apply Zmult_assoc.
-Qed.
-
-(** Z is integral *)
-
-Theorem Zmult_eq: (x,y:Z) ~(x=ZERO) -> (Zmult y x) = ZERO -> y = ZERO.
-Proof.
-Intros x y; NewDestruct x as [|p|p].
-  Intro H; Absurd ZERO=ZERO; Trivial.
-  Intros _ H; NewDestruct y as [|q|q]; Reflexivity Orelse Discriminate.
-  Intros _ H; NewDestruct y as [|q|q]; Reflexivity Orelse Discriminate.
-Qed.
-
-V7only [Set Implicit Arguments.].
-
-Theorem Zmult_zero : (x,y:Z)(Zmult x y)=ZERO -> x=ZERO \/ y=ZERO.
-Proof.
-Intros x y; NewDestruct x; NewDestruct y; Auto; Simpl; Intro H; Discriminate H.
-Qed.
-
-V7only [Unset Implicit Arguments.].
-
-Lemma Zmult_1_inversion_l : 
- (x,y:Z) (Zmult x y)=(POS xH) -> x=(POS xH) \/ x=(NEG xH).
-Proof.
-Intros x y; NewDestruct x as [|p|p]; Intro; [ Discriminate | Left | Right ];
-  (NewDestruct y as [|q|q]; Try Discriminate;
-  Simpl in H; Injection H; Clear H; Intro H;
-  Rewrite times_one_inversion_l with 1:=H; Reflexivity).
-Qed.
-
-(** Multiplication and Opposite *)
-
-Theorem Zopp_Zmult_l : (x,y:Z)(Zopp (Zmult x y)) = (Zmult (Zopp x) y).
-Proof.
-Intros x y; NewDestruct x; NewDestruct y; Reflexivity.
-Qed.
-
-Theorem Zopp_Zmult_r : (x,y:Z)(Zopp (Zmult x y)) = (Zmult x (Zopp y)).
-Intros x y; Rewrite (Zmult_sym x y); Rewrite Zopp_Zmult_l; Apply Zmult_sym.
-Qed.
-
-Lemma Zopp_Zmult: (x,y:Z) (Zmult (Zopp x) y) = (Zopp (Zmult x y)).
-Proof.
-Intros x y; Symmetry; Apply Zopp_Zmult_l.
-Qed.
-
-Theorem Zmult_Zopp_left :  (x,y:Z)(Zmult (Zopp x) y) = (Zmult x (Zopp y)).
-Intros x y; Rewrite Zopp_Zmult; Rewrite Zopp_Zmult_r; Trivial with arith.
-Qed.
-
-Theorem Zmult_Zopp_Zopp: (x,y:Z) (Zmult (Zopp x) (Zopp y)) = (Zmult x y).
-Proof.
-Intros x y; NewDestruct x; NewDestruct y; Reflexivity.
-Qed.
-
-Theorem Zopp_one : (x:Z)(Zopp x)=(Zmult x (NEG xH)).
-Intro x; NewInduction x; Intros; Rewrite Zmult_sym; Auto with arith.
-Qed.
-
-(** Distributivity of multiplication over addition *)
-
-Lemma weak_Zmult_plus_distr_r:
-  (x:positive)(y,z:Z)
-   (Zmult (POS x) (Zplus y z)) = (Zplus (Zmult (POS x) y) (Zmult (POS x) z)).
-Proof.
-Intros x y' z';Case y';Case z';Auto with arith;Intros y z;
-  (Simpl; Rewrite times_add_distr; Trivial with arith)
-Orelse
-  (Simpl; ElimPcompare z y; Intros E0;Rewrite E0; [
-    Rewrite (compare_convert_EGAL z y E0);
-    Rewrite (convert_compare_EGAL (times x y)); Trivial with arith
-  | Cut (compare (times x z) (times x y) EGAL)=INFERIEUR; [
-      Intros E;Rewrite E; Rewrite times_true_sub_distr; [
-        Trivial with arith
-      | Apply ZC2;Assumption ]
-    | Apply convert_compare_INFERIEUR;Do 2 Rewrite times_convert; 
-      Elim (ZL4 x);Intros h H1;Rewrite H1;Apply lt_mult_left;
-      Exact (compare_convert_INFERIEUR z y E0)]
-  | Cut (compare (times x z) (times x y) EGAL)=SUPERIEUR; [
-      Intros E;Rewrite E; Rewrite times_true_sub_distr; Auto with arith
-    | Apply convert_compare_SUPERIEUR; Unfold gt; Do 2 Rewrite times_convert;
-      Elim (ZL4 x);Intros h H1;Rewrite H1;Apply lt_mult_left;
-      Exact (compare_convert_SUPERIEUR z y E0) ]]).
-Qed.
-
-Theorem Zmult_plus_distr_r:
-  (x,y,z:Z) (Zmult x (Zplus y z)) = (Zplus (Zmult x y) (Zmult x z)).
-Proof.
-Intros x y z; Case x; [
-  Auto with arith
-| Intros x';Apply weak_Zmult_plus_distr_r
-| Intros p; Apply Zopp_intro; Rewrite Zopp_Zplus; 
-  Do 3 Rewrite <- Zopp_Zmult; Rewrite Zopp_NEG; 
-  Apply weak_Zmult_plus_distr_r ].
-Qed.
-
-Theorem Zmult_plus_distr_l : 
-  (n,m,p:Z)((Zmult (Zplus n m) p)=(Zplus (Zmult n p) (Zmult m p))).
-Proof.
-Intros n m p;Rewrite Zmult_sym;Rewrite Zmult_plus_distr_r; 
-Do 2 Rewrite -> (Zmult_sym p); Trivial with arith.
-Qed.
-
-(** Distributivity of multiplication over subtraction *)
-
-Lemma Zmult_Zminus_distr_l :
-  (x,y,z:Z)((Zmult (Zminus x y) z)=(Zminus (Zmult x z) (Zmult y z))).
-Proof.
-Intros x y z; Unfold Zminus.
-Rewrite <- Zopp_Zmult.
-Apply Zmult_plus_distr_l.
-Qed.
-
-V7only [Notation Zmult_minus_distr := Zmult_Zminus_distr_l.].
- 
-Lemma  Zmult_Zminus_distr_r :
-  (x,y,z:Z)(Zmult z (Zminus x y)) = (Zminus (Zmult z x) (Zmult z y)).
-Proof.
-Intros x y z; Rewrite (Zmult_sym z (Zminus x y)).
-Rewrite (Zmult_sym  z x).
-Rewrite (Zmult_sym z y).
-Apply Zmult_Zminus_distr_l.
-Qed.
-
-(** Simplification of multiplication for non-zero integers *)
-V7only [Set Implicit Arguments.].
-
-Lemma Zmult_reg_left : (x,y,z:Z) z<>ZERO -> (Zmult z x)=(Zmult z y) -> x=y.
-Proof.
-Intros x y z H H0.
-Generalize (Zeq_Zminus H0).
-Intro.
-Apply Zminus_Zeq.
-Rewrite <- Zmult_Zminus_distr_r in H1.
-Clear H0; NewDestruct (Zmult_zero H1).
-Contradiction.
-Trivial.
-Qed.
-
-Lemma Zmult_reg_right : (x,y,z:Z) z<>ZERO -> (Zmult x z)=(Zmult y z) -> x=y.
-Proof.
-Intros x y z Hz.
-Rewrite (Zmult_sym x z).
-Rewrite (Zmult_sym y z).
-Intro; Apply Zmult_reg_left with z; Assumption.
-Qed.
-V7only [Unset Implicit Arguments.].
-
-(** Addition and multiplication by 2 *)
-
-Lemma Zplus_Zmult_2 : (x:Z) (Zplus x x) = (Zmult x (POS (xO xH))).
-Proof.
-Intros x; Pattern 1 2 x ; Rewrite <- (Zmult_n_1 x);
-Rewrite <- Zmult_plus_distr_r; Reflexivity.
-Qed.
-
-(** Multiplication and successor *)
-
-Lemma Zmult_succ_r : (n,m:Z) (Zmult n (Zs m))=(Zplus (Zmult n m) n).
-Proof.
-Intros n m;Unfold Zs; Rewrite Zmult_plus_distr_r;
-Rewrite (Zmult_sym n (POS xH));Rewrite Zmult_one; Trivial with arith.
-Qed.
-
-Lemma Zmult_n_Sm : (n,m:Z) (Zplus (Zmult n m) n)=(Zmult n (Zs m)).
-Proof.
-Intros; Symmetry; Apply Zmult_succ_r.
-Qed.
-
-Lemma Zmult_succ_l : (n,m:Z) (Zmult (Zs n) m)=(Zplus (Zmult n m) m).
-Proof.
-Intros n m; Unfold Zs; Rewrite Zmult_plus_distr_l; Rewrite Zmult_1_n;
-Trivial with arith.
-Qed.
-
-Lemma Zmult_Sm_n : (n,m:Z) (Zplus (Zmult n m) m)=(Zmult (Zs n) m).
-Proof.
-Intros; Symmetry; Apply Zmult_succ_l.
-Qed.
-
-(** Misc redundant properties *)
-
-Lemma Z_eq_mult:
-  (x,y:Z)  y = ZERO -> (Zmult y x) = ZERO.
-Intros x y H; Rewrite H; Auto with arith.
-Qed.
-
-(**********************************************************************)
-(** Relating binary positive numbers and binary integers *)
-
-Lemma POS_xI : (p:positive) (POS (xI p))=(Zplus (Zmult (POS (xO xH)) (POS p)) (POS xH)).
-Proof.
-Intro; Apply refl_equal.
-Qed.
-
-Lemma POS_xO : (p:positive) (POS (xO p))=(Zmult (POS (xO xH)) (POS p)).
-Proof.
-Intro; Apply refl_equal.
-Qed.
-
-Lemma NEG_xI : (p:positive) (NEG (xI p))=(Zminus (Zmult (POS (xO xH)) (NEG p)) (POS xH)).
-Proof.
-Intro; Apply refl_equal.
-Qed.
-
-Lemma NEG_xO : (p:positive) (NEG (xO p))=(Zmult (POS (xO xH)) (NEG p)).
-Proof.
-Reflexivity.
-Qed.
-
-Lemma POS_add : (p,p':positive)(POS (add p p'))=(Zplus (POS p) (POS p')).
-Proof.
-Intros p p'; NewDestruct p; NewDestruct p'; Reflexivity.
-Qed.
-
-Lemma NEG_add : (p,p':positive)(NEG (add p p'))=(Zplus (NEG p) (NEG p')).
-Proof.
-Intros p p'; NewDestruct p; NewDestruct p'; Reflexivity.
-Qed.
-
-(**********************************************************************)
-(** Order relations *)
-
-Definition Zlt := [x,y:Z](Zcompare x y) = INFERIEUR.
-Definition Zgt := [x,y:Z](Zcompare x y) = SUPERIEUR.
-Definition Zle := [x,y:Z]~(Zcompare x y) = SUPERIEUR.
-Definition Zge := [x,y:Z]~(Zcompare x y) = INFERIEUR.
-Definition Zne := [x,y:Z] ~(x=y).
-
-V8Infix "<=" Zle : Z_scope.
-V8Infix "<"  Zlt : Z_scope.
-V8Infix ">=" Zge : Z_scope.
-V8Infix ">"  Zgt : Z_scope.
-
-V8Notation "x <= y <= z" := (Zle x y)/\(Zle y z) :Z_scope.
-V8Notation "x <= y < z"  := (Zle x y)/\(Zlt y z) :Z_scope.
-V8Notation  "x < y < z"  := (Zlt x y)/\(Zlt y z) :Z_scope.
-V8Notation  "x < y <= z" := (Zlt x y)/\(Zle y z) :Z_scope.
-
-(**********************************************************************)
-(** Absolute value on integers *)
-
-Definition absolu [x:Z] : nat :=
-  Cases x of
-     ZERO   => O
-  | (POS p) => (convert p)
-  | (NEG p) => (convert p)
-  end.
-
-Definition Zabs [z:Z] : Z :=
-  Cases z of 
-     ZERO   => ZERO
-  | (POS p) => (POS p)
-  | (NEG p) => (POS p)
-  end.
-
-(**********************************************************************)
-(** From [nat] to [Z] *)
-
-Definition inject_nat := 
-  [x:nat]Cases x of
-           O => ZERO
-         | (S y) => (POS (anti_convert y))
-         end.
-
-Require BinNat.
-
-Definition entier_of_Z :=
-  [z:Z]Cases z of ZERO => Nul | (POS p) => (Pos p) | (NEG p) => (Pos p) end.
-
-Definition Z_of_entier :=
-  [x:entier]Cases x of Nul => ZERO | (Pos p) => (POS p) end.
diff --git a/theories7/ZArith/Wf_Z.v b/theories7/ZArith/Wf_Z.v
deleted file mode 100644
index e6cf4610..00000000
--- a/theories7/ZArith/Wf_Z.v
+++ /dev/null
@@ -1,194 +0,0 @@
-(************************************************************************)
-(*  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: Wf_Z.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-Require BinInt.
-Require Zcompare.
-Require Zorder.
-Require Znat.
-Require Zmisc.
-Require Zsyntax.
-Require Wf_nat.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-(** Our purpose is to write an induction shema for {0,1,2,...}
-  similar to the [nat] schema (Theorem [Natlike_rec]). For that the
-  following implications will be used :
-<<
- (n:nat)(Q n)==(n:nat)(P (inject_nat n)) ===> (x:Z)`x > 0) -> (P x)
-
-       	     /\
-             ||
-             ||
-
-  (Q O) (n:nat)(Q n)->(Q (S n)) <=== (P 0) (x:Z) (P x) -> (P (Zs x))
-
-      	       	       	       	<=== (inject_nat (S n))=(Zs (inject_nat n))
-
-      	       	       	       	<=== inject_nat_complete
->>
-  Then the  diagram will be closed and the theorem proved. *)
-
-Lemma inject_nat_complete :
-  (x:Z)`0 <= x` -> (EX n:nat | x=(inject_nat n)).
-Intro x; NewDestruct x; Intros;
-[ Exists  O; Auto with arith
-| Specialize (ZL4 p); Intros Hp; Elim Hp; Intros;
-  Exists (S x); Intros; Simpl;
-  Specialize (bij1 x); Intro Hx0;
-  Rewrite <- H0 in Hx0;
-  Apply f_equal with f:=POS;
-  Apply convert_intro; Auto with arith
-| Absurd `0 <= (NEG p)`;
-  [ Unfold Zle; Simpl; Do 2 (Unfold not); Auto with arith
-  | Assumption]
-].
-Qed.
-
-Lemma ZL4_inf: (y:positive) { h:nat | (convert y)=(S h) }.
-Intro y; NewInduction y as [p H|p H1|]; [
-  Elim H; Intros x H1; Exists (plus (S x) (S x));
-  Unfold convert ;Simpl; Rewrite ZL0; Rewrite ZL2; Unfold convert in H1;
-  Rewrite H1; Auto with arith
-| Elim H1;Intros x H2; Exists (plus x (S x)); Unfold convert;
-  Simpl; Rewrite ZL0; Rewrite ZL2;Unfold convert in H2; Rewrite H2; Auto with arith
-| Exists O ;Auto with arith].
-Qed.
-
-Lemma inject_nat_complete_inf :
-  (x:Z)`0 <= x` -> { n:nat | (x=(inject_nat n)) }.
-Intro x; NewDestruct x; Intros;
-[ Exists  O; Auto with arith
-| Specialize (ZL4_inf p); Intros Hp; Elim Hp; Intros x0 H0;
-  Exists (S x0); Intros; Simpl;
-  Specialize (bij1 x0); Intro Hx0;
-  Rewrite <- H0 in Hx0;
-  Apply f_equal with f:=POS;
-  Apply convert_intro; Auto with arith
-| Absurd `0 <= (NEG p)`;
-  [ Unfold Zle; Simpl; Do 2 (Unfold not); Auto with arith
-  | Assumption]
-].
-Qed.
-
-Lemma inject_nat_prop :
-  (P:Z->Prop)((n:nat)(P (inject_nat n))) -> 
-    (x:Z) `0 <= x` -> (P x).
-Intros P H x H0.
-Specialize (inject_nat_complete x H0).
-Intros Hn; Elim Hn; Intros.
-Rewrite -> H1; Apply H.
-Qed.
-
-Lemma inject_nat_set :
-  (P:Z->Set)((n:nat)(P (inject_nat n))) -> 
-    (x:Z) `0 <= x` -> (P x).
-Intros P H x H0.
-Specialize (inject_nat_complete_inf x H0).
-Intros Hn; Elim Hn; Intros.
-Rewrite -> p; Apply H.
-Qed.
-
-Lemma natlike_ind : (P:Z->Prop) (P `0`) ->
-  ((x:Z)(`0 <= x` -> (P x) -> (P (Zs x)))) ->
-  (x:Z) `0 <= x` -> (P x).
-Intros P H H0 x H1; Apply inject_nat_prop;
-[ Induction n;
-  [ Simpl; Assumption
-  | Intros; Rewrite -> (inj_S n0);
-    Exact (H0 (inject_nat n0) (ZERO_le_inj n0) H2) ]
-| Assumption].
-Qed.
-
-Lemma natlike_rec : (P:Z->Set) (P `0`) ->
-  ((x:Z)(`0 <= x` -> (P x) -> (P (Zs x)))) ->
-  (x:Z) `0 <= x` -> (P x).
-Intros P H H0 x H1; Apply inject_nat_set;
-[ Induction n;
-  [ Simpl; Assumption
-  | Intros; Rewrite -> (inj_S n0);
-    Exact (H0 (inject_nat n0) (ZERO_le_inj n0) H2) ]
-| Assumption].
-Qed.
-
-Section Efficient_Rec. 
-
-(** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed 
-     to give a better extracted term. *)
-
-Local R := [a,b:Z]`0<=a`/\`a<b`.
-
-Local R_wf : (well_founded Z R).
-Proof.
-LetTac f := [z]Cases z of (POS p) => (convert p) | ZERO => O | (NEG _) => O end.
-Apply  well_founded_lt_compat with f.
-Unfold R f; Clear f R.
-Intros x y; Case x; Intros; Elim H; Clear H.
-Case y; Intros; Apply compare_convert_O Orelse Inversion H0.
-Case y; Intros; Apply compare_convert_INFERIEUR Orelse Inversion H0; Auto.
-Intros; Elim H; Auto.
-Qed.
-
-Lemma natlike_rec2 : (P:Z->Type)(P `0`) -> 
-        ((z:Z)`0<=z` -> (P z) -> (P (Zs z))) -> (z:Z)`0<=z` -> (P z).
-Proof.
-Intros P Ho Hrec z; Pattern z; Apply (well_founded_induction_type Z R R_wf).
-Intro x; Case x.
-Trivial.
-Intros.
-Assert `0<=(Zpred (POS p))`.
-Apply Zlt_ZERO_pred_le_ZERO; Unfold Zlt; Simpl; Trivial.
-Rewrite Zs_pred.
-Apply Hrec.
-Auto.
-Apply X; Auto; Unfold R; Intuition; Apply Zlt_pred_n_n.
-Intros; Elim H; Simpl; Trivial.
-Qed.
-
-(** A variant of the previous using [Zpred] instead of [Zs]. *)
-
-Lemma natlike_rec3 : (P:Z->Type)(P `0`) -> 
-        ((z:Z)`0<z` -> (P (Zpred z)) -> (P z)) -> (z:Z)`0<=z` -> (P z).
-Proof.
-Intros P Ho Hrec z; Pattern z; Apply (well_founded_induction_type Z R R_wf).
-Intro x; Case x.
-Trivial.
-Intros; Apply Hrec.
-Unfold Zlt; Trivial.
-Assert `0<=(Zpred (POS p))`.
-Apply Zlt_ZERO_pred_le_ZERO; Unfold Zlt; Simpl; Trivial.
-Apply X; Auto; Unfold R; Intuition; Apply Zlt_pred_n_n.
-Intros; Elim H; Simpl; Trivial.
-Qed.
-
-(** A more general induction principal using [Zlt]. *)
-
-Lemma Z_lt_rec : (P:Z->Type)
- ((x:Z)((y:Z)`0 <= y < x`->(P y))->(P x)) -> (x:Z)`0 <= x`->(P x).
-Proof.
-Intros P Hrec z; Pattern z; Apply (well_founded_induction_type Z R R_wf).
-Intro x; Case x; Intros.
-Apply Hrec; Intros.
-Assert H2: `0<0`.
-  Apply Zle_lt_trans with y; Intuition.
-Inversion H2.
-Firstorder.
-Unfold Zle Zcompare in H; Elim H; Auto.
-Defined.
-
-Lemma Z_lt_induction : 
-  (P:Z->Prop)
-     ((x:Z)((y:Z)`0 <= y < x`->(P y))->(P x))
-  -> (x:Z)`0 <= x`->(P x).
-Proof.
-Exact Z_lt_rec.
-Qed.
-
-End Efficient_Rec.
diff --git a/theories7/ZArith/ZArith.v b/theories7/ZArith/ZArith.v
deleted file mode 100644
index e1746433..00000000
--- a/theories7/ZArith/ZArith.v
+++ /dev/null
@@ -1,22 +0,0 @@
-(************************************************************************)
-(*  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: ZArith.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-(** Library for manipulating integers based on binary encoding *)
-
-Require Export ZArith_base.
-
-(** Extra modules using [Omega] or [Ring]. *)
-
-Require Export Zcomplements.
-Require Export Zsqrt.
-Require Export Zpower.
-Require Export Zdiv.
-Require Export Zlogarithm.
-Require Export Zbool.
diff --git a/theories7/ZArith/ZArith_base.v b/theories7/ZArith/ZArith_base.v
deleted file mode 100644
index 7f2863d6..00000000
--- a/theories7/ZArith/ZArith_base.v
+++ /dev/null
@@ -1,39 +0,0 @@
-(************************************************************************)
-(*  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: ZArith_base.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ *)
-
-(** Library for manipulating integers based on binary encoding.
-    These are the basic modules, required by [Omega] and [Ring] for instance. 
-    The full library is [ZArith]. *)
-
-V7only [
-Require Export fast_integer.
-Require Export zarith_aux.
-].
-Require Export BinPos.
-Require Export BinNat.
-Require Export BinInt.
-Require Export Zcompare.
-Require Export Zorder.
-Require Export Zeven.
-Require Export Zmin.
-Require Export Zabs.
-Require Export Znat.
-Require Export auxiliary.
-Require Export Zsyntax.
-Require Export ZArith_dec.
-Require Export Zbool.
-Require Export Zmisc.
-Require Export Wf_Z.
-
-Hints Resolve Zle_n Zplus_sym Zplus_assoc Zmult_sym Zmult_assoc
-  Zero_left Zero_right Zmult_one Zplus_inverse_l Zplus_inverse_r 
-  Zmult_plus_distr_l Zmult_plus_distr_r : zarith.
-
-Require Export Zhints.
diff --git a/theories7/ZArith/ZArith_dec.v b/theories7/ZArith/ZArith_dec.v
deleted file mode 100644
index 985f7601..00000000
--- a/theories7/ZArith/ZArith_dec.v
+++ /dev/null
@@ -1,243 +0,0 @@
-(************************************************************************)
-(*  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: ZArith_dec.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-Require Sumbool.
-
-Require BinInt.
-Require Zorder.
-Require Zcompare.
-Require Zsyntax.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-Lemma Dcompare_inf : (r:relation) {r=EGAL} + {r=INFERIEUR} + {r=SUPERIEUR}.
-Proof.
-Induction r; Auto with arith. 
-Defined.
-
-Lemma Zcompare_rec :
-  (P:Set)(x,y:Z)
-    ((Zcompare x y)=EGAL -> P) ->
-    ((Zcompare x y)=INFERIEUR -> P) ->
-    ((Zcompare x y)=SUPERIEUR -> P) ->
-    P.
-Proof.
-Intros P x y H1 H2 H3.
-Elim (Dcompare_inf (Zcompare x y)).
-Intro H. Elim H; Auto with arith. Auto with arith.
-Defined.
-
-Section decidability.
-
-Variables x,y : Z.
-
-(** Decidability of equality on binary integers *)
-
-Definition Z_eq_dec : {x=y}+{~x=y}.
-Proof.
-Apply Zcompare_rec with x:=x y:=y.
-Intro. Left. Elim (Zcompare_EGAL x y); Auto with arith.
-Intro H3. Right. Elim (Zcompare_EGAL x y). Intros H1 H2. Unfold not. Intro H4.
-  Rewrite (H2 H4) in H3. Discriminate H3.
-Intro H3. Right. Elim (Zcompare_EGAL x y). Intros H1 H2. Unfold not. Intro H4.
-  Rewrite (H2 H4) in H3. Discriminate H3.
-Defined. 
-
-(** Decidability of order on binary integers *)
-
-Definition Z_lt_dec : {(Zlt x y)}+{~(Zlt x y)}.
-Proof.
-Unfold Zlt.
-Apply Zcompare_rec with x:=x y:=y; Intro H.
-Right. Rewrite H. Discriminate.
-Left; Assumption.
-Right. Rewrite H. Discriminate.
-Defined.
-
-Definition Z_le_dec : {(Zle x y)}+{~(Zle x y)}.
-Proof.
-Unfold Zle.
-Apply Zcompare_rec with x:=x y:=y; Intro H.
-Left. Rewrite H. Discriminate.
-Left. Rewrite H. Discriminate.
-Right. Tauto.
-Defined.
-
-Definition Z_gt_dec : {(Zgt x y)}+{~(Zgt x y)}.
-Proof.
-Unfold Zgt.
-Apply Zcompare_rec with x:=x y:=y; Intro H.
-Right. Rewrite H. Discriminate.
-Right. Rewrite H. Discriminate.
-Left; Assumption.
-Defined.
-
-Definition Z_ge_dec : {(Zge x y)}+{~(Zge x y)}.
-Proof.
-Unfold Zge.
-Apply Zcompare_rec with x:=x y:=y; Intro H.
-Left. Rewrite H. Discriminate.
-Right. Tauto.
-Left. Rewrite H. Discriminate.
-Defined.
-
-Definition Z_lt_ge_dec : {`x < y`}+{`x >= y`}.
-Proof.
-Exact Z_lt_dec.
-Defined.
-
-V7only [ (* From Zextensions *) ].
-Lemma Z_lt_le_dec: {`x < y`}+{`y <= x`}.
-Proof.
-Intros.
-Elim Z_lt_ge_dec.
-Intros; Left; Assumption.
-Intros; Right; Apply Zge_le; Assumption.
-Qed.
-
-Definition Z_le_gt_dec : {`x <= y`}+{`x > y`}.
-Proof.
-Elim Z_le_dec; Auto with arith.
-Intro. Right. Apply not_Zle; Auto with arith.
-Defined.
-
-Definition Z_gt_le_dec : {`x > y`}+{`x <= y`}.
-Proof.
-Exact Z_gt_dec.
-Defined.
-
-Definition Z_ge_lt_dec : {`x >= y`}+{`x < y`}.
-Proof.
-Elim Z_ge_dec; Auto with arith.
-Intro. Right. Apply not_Zge; Auto with arith.
-Defined.
-
-Definition Z_le_lt_eq_dec : `x <= y` -> {`x < y`}+{x=y}.
-Proof.
-Intro H.
-Apply Zcompare_rec with x:=x y:=y.
-Intro. Right. Elim (Zcompare_EGAL x y); Auto with arith.
-Intro. Left. Elim (Zcompare_EGAL x y); Auto with arith.
-Intro H1. Absurd `x > y`; Auto with arith.
-Defined.
-
-End decidability.
-
-(** Cotransitivity of order on binary integers *)
-
-Lemma Zlt_cotrans:(n,m:Z)`n<m`->(p:Z){`n<p`}+{`p<m`}.
-Proof.
- Intros x y H z.
- Case (Z_lt_ge_dec x z).
- Intro.
- Left.
- Assumption.
- Intro.
- Right.
- Apply Zle_lt_trans with m:=x.
- Apply Zge_le.
- Assumption.
- Assumption.
-Defined.
-
-Lemma Zlt_cotrans_pos:(x,y:Z)`0<x+y`->{`0<x`}+{`0<y`}.
-Proof.
- Intros x y H.
- Case (Zlt_cotrans `0` `x+y` H x).
- Intro.
- Left.
- Assumption.
- Intro.
- Right.
- Apply Zsimpl_lt_plus_l with p:=`x`.
- Rewrite Zero_right.
- Assumption.
-Defined.
-
-Lemma Zlt_cotrans_neg:(x,y:Z)`x+y<0`->{`x<0`}+{`y<0`}.
-Proof.
- Intros x y H;
- Case (Zlt_cotrans `x+y` `0` H x);
- Intro Hxy;
- [ Right;
-   Apply Zsimpl_lt_plus_l with p:=`x`;
-   Rewrite Zero_right
- | Left
- ];
- Assumption.
-Defined.
-
-Lemma not_Zeq_inf:(x,y:Z)`x<>y`->{`x<y`}+{`y<x`}.
-Proof.
- Intros x y H.
- Case Z_lt_ge_dec with x y.
- Intro.
- Left.
- Assumption.
- Intro H0.
- Generalize (Zge_le ? ? H0).
- Intro.
- Case (Z_le_lt_eq_dec ? ? H1).
- Intro.
- Right.
- Assumption.
- Intro.
- Apply False_rec.
- Apply H.
- Symmetry.
- Assumption.
-Defined.
-
-Lemma Z_dec:(x,y:Z){`x<y`}+{`x>y`}+{`x=y`}.
-Proof.
- Intros x y.
- Case (Z_lt_ge_dec x y).
- Intro H.
- Left.
- Left.
- Assumption.
- Intro H.
- Generalize (Zge_le ? ? H).
- Intro H0.
- Case (Z_le_lt_eq_dec y x H0).
- Intro H1.
- Left.
- Right.
- Apply Zlt_gt.
- Assumption.
- Intro.
- Right.
- Symmetry.
- Assumption.
-Defined.
-
-
-Lemma Z_dec':(x,y:Z){`x<y`}+{`y<x`}+{`x=y`}.
-Proof.
- Intros x y.
- Case (Z_eq_dec x y);
- Intro H;
- [ Right;
-   Assumption
- | Left;
-   Apply (not_Zeq_inf ?? H)
- ].
-Defined.
-
-
-
-Definition Z_zerop : (x:Z){(`x = 0`)}+{(`x <> 0`)}.
-Proof.
-Exact [x:Z](Z_eq_dec x ZERO).
-Defined.
-
-Definition Z_notzerop := [x:Z](sumbool_not ? ? (Z_zerop x)).
-
-Definition Z_noteq_dec := [x,y:Z](sumbool_not ? ? (Z_eq_dec x y)).
diff --git a/theories7/ZArith/Zabs.v b/theories7/ZArith/Zabs.v
deleted file mode 100644
index 57778cae..00000000
--- a/theories7/ZArith/Zabs.v
+++ /dev/null
@@ -1,138 +0,0 @@
-(************************************************************************)
-(*  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: Zabs.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
-
-Require Arith.
-Require BinPos.
-Require BinInt.
-Require Zorder.
-Require Zsyntax.
-Require ZArith_dec.
-
-V7only [Import nat_scope.].
-Open Local Scope Z_scope.
-
-(**********************************************************************)
-(** Properties of absolute value *)
-
-Lemma Zabs_eq : (x:Z) (Zle ZERO x) -> (Zabs x)=x.
-Intro x; NewDestruct x; Auto with arith.
-Compute; Intros; Absurd SUPERIEUR=SUPERIEUR; Trivial with arith.
-Qed.
-
-Lemma Zabs_non_eq : (x:Z) (Zle x ZERO) -> (Zabs x)=(Zopp x).
-Proof.
-Intro x; NewDestruct x; Auto with arith.
-Compute; Intros; Absurd SUPERIEUR=SUPERIEUR; Trivial with arith.
-Qed.
-
-V7only [ (* From Zdivides *) ].
-Theorem Zabs_Zopp: (z : Z)  (Zabs (Zopp z)) = (Zabs z).
-Proof.
-Intros z; Case z; Simpl; Auto.
-Qed.
-
-(** Proving a property of the absolute value by cases *)
-
-Lemma Zabs_ind : 
-  (P:Z->Prop)(x:Z)(`x >= 0` -> (P x)) -> (`x <= 0` -> (P `-x`)) ->
-  (P `|x|`).
-Proof.
-Intros P x H H0; Elim (Z_lt_ge_dec x `0`); Intro.
-Assert `x<=0`. Apply Zlt_le_weak; Assumption.
-Rewrite Zabs_non_eq. Apply H0. Assumption. Assumption.
-Rewrite Zabs_eq. Apply H; Assumption. Apply Zge_le. Assumption.
-Save.
-
-V7only [ (* From Zdivides *) ].
-Theorem Zabs_intro: (P : ?) (z : Z) (P (Zopp z)) -> (P z) ->  (P (Zabs z)).
-Intros P z; Case z; Simpl; Auto.
-Qed.
-
-Definition Zabs_dec : (x:Z){x=(Zabs x)}+{x=(Zopp (Zabs x))}.
-Proof.
-Intro x; NewDestruct x;Auto with arith.
-Defined.
-
-Lemma Zabs_pos : (x:Z)(Zle ZERO (Zabs x)).
-Intro x; NewDestruct x;Auto with arith; Compute; Intros H;Inversion H.
-Qed.
-
-V7only [ (* From Zdivides *) ].
-Theorem Zabs_eq_case:
- (z1, z2 : Z) (Zabs z1) = (Zabs z2) ->  z1 = z2 \/ z1 = (Zopp z2).
-Proof.
-Intros z1 z2; Case z1; Case z2; Simpl; Auto; Try (Intros; Discriminate);
- Intros p1 p2 H1; Injection H1; (Intros H2; Rewrite H2); Auto.
-Qed.
-
-(** Triangular inequality *)
-
-Hints Local Resolve Zle_NEG_POS :zarith.
-
-V7only [ (* From Zdivides *) ].
-Theorem Zabs_triangle:
- (z1, z2 : Z)  (Zle (Zabs (Zplus z1 z2)) (Zplus (Zabs z1) (Zabs z2))).
-Proof.
-Intros z1 z2; Case z1; Case z2; Try (Simpl; Auto with zarith; Fail).
-Intros p1 p2;
- Apply Zabs_intro
-      with P := [x : ?]  (Zle x (Zplus (Zabs (POS p2)) (Zabs (NEG p1))));
- Try Rewrite Zopp_Zplus; Auto with zarith.
-Apply Zle_plus_plus; Simpl; Auto with zarith.
-Apply Zle_plus_plus; Simpl; Auto with zarith.
-Intros p1 p2;
- Apply Zabs_intro
-      with P := [x : ?]  (Zle x (Zplus (Zabs (POS p2)) (Zabs (NEG p1))));
- Try Rewrite Zopp_Zplus; Auto with zarith.
-Apply Zle_plus_plus; Simpl; Auto with zarith.
-Apply Zle_plus_plus; Simpl; Auto with zarith.
-Qed.
-
-(** Absolute value and multiplication *)
-
-Lemma Zsgn_Zabs: (x:Z)(Zmult x (Zsgn x))=(Zabs x).
-Proof.
-Intro x; NewDestruct x; Rewrite Zmult_sym; Auto with arith.
-Qed.
-
-Lemma Zabs_Zsgn: (x:Z)(Zmult (Zabs x) (Zsgn x))=x.
-Proof.
-Intro x; NewDestruct x; Rewrite Zmult_sym; Auto with arith.
-Qed.
-
-V7only [ (* From Zdivides *) ].
-Theorem Zabs_Zmult:
- (z1, z2 : Z)  (Zabs (Zmult z1 z2)) = (Zmult (Zabs z1) (Zabs z2)).
-Proof.
-Intros z1 z2; Case z1; Case z2; Simpl; Auto.
-Qed.
-
-(** absolute value in nat is compatible with order *)
-
-Lemma absolu_lt : (x,y:Z) (Zle ZERO x)/\(Zlt x  y) -> (lt (absolu x) (absolu y)).
-Proof.
-Intros x y. Case x; Simpl. Case y; Simpl.
-
-Intro. Absurd (Zlt ZERO ZERO). Compute. Intro H0. Discriminate H0. Intuition.
-Intros. Elim (ZL4 p). Intros. Rewrite H0. Auto with arith.
-Intros. Elim (ZL4 p). Intros. Rewrite H0. Auto with arith.
-
-Case y; Simpl.
-Intros. Absurd (Zlt (POS p) ZERO). Compute. Intro H0. Discriminate H0. Intuition.
-Intros. Change (gt (convert p) (convert p0)).
-Apply compare_convert_SUPERIEUR.
-Elim H; Auto with arith. Intro. Exact (ZC2 p0 p).
-
-Intros. Absurd (Zlt (POS p0) (NEG p)).
-Compute. Intro H0. Discriminate H0. Intuition.
-
-Intros. Absurd (Zle ZERO (NEG p)). Compute. Auto with arith. Intuition.
-Qed.
diff --git a/theories7/ZArith/Zbinary.v b/theories7/ZArith/Zbinary.v
deleted file mode 100644
index c3efbe1e..00000000
--- a/theories7/ZArith/Zbinary.v
+++ /dev/null
@@ -1,425 +0,0 @@
-(************************************************************************)
-(*  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: Zbinary.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ i*)
-
-(** Bit vectors interpreted as integers. 
-    Contribution by Jean Duprat (ENS Lyon). *)
-
-Require Bvector.
-Require ZArith.
-Require Export Zpower.
-Require Omega.
-
-(*
-L'évaluation des vecteurs de booléens se font à la fois en binaire et
-en complément à deux. Le nombre appartient à Z. 
-On utilise donc Omega pour faire les calculs dans Z.
-De plus, on utilise les fonctions 2^n où n est un naturel, ici la longueur.
-	two_power_nat = [n:nat](POS (shift_nat n xH))
-     		: nat->Z
-	two_power_nat_S
-	     : (n:nat)`(two_power_nat (S n)) = 2*(two_power_nat n)`
-	Z_lt_ge_dec
-	     : (x,y:Z){`x < y`}+{`x >= y`}
-*)
-
-
-Section VALUE_OF_BOOLEAN_VECTORS.
-
-(*
-Les calculs sont effectués dans la convention positive usuelle.
-Les valeurs correspondent soit à l'écriture binaire (nat), 
-soit au complément à deux (int).
-On effectue le calcul suivant le schéma de Horner.
-Le complément à deux n'a de sens que sur les vecteurs de taille 
-supérieure ou égale à un, le bit de signe étant évalué négativement.
-*)
-
-Definition bit_value [b:bool] : Z :=
-Cases b of
-	| true => `1`
-	| false => `0`
-end.
-
-Lemma binary_value  : (n:nat) (Bvector n) -> Z.
-Proof.
-	Induction n; Intros.
-	Exact `0`.
-
-	Inversion H0.
-	Exact (Zplus (bit_value a) (Zmult `2` (H H2))).
-Defined.
-
-Lemma two_compl_value : (n:nat) (Bvector (S n)) -> Z.
-Proof.
-	Induction n; Intros.
-	Inversion H.
-	Exact (Zopp (bit_value a)).
-
-	Inversion H0.
-	Exact (Zplus (bit_value a) (Zmult `2` (H H2))).
-Defined.
-
-(*
-Coq < Eval Compute in (binary_value (3) (Bcons true (2) (Bcons false (1) (Bcons true (0) Bnil)))).
-     = `5`
-     : Z
-*)
-
-(*
-Coq < Eval Compute in (two_compl_value (3) (Bcons true (3) (Bcons false (2) (Bcons true (1) (Bcons true (0) Bnil))))).
-     = `-3`
-     : Z
-*)
-
-End VALUE_OF_BOOLEAN_VECTORS.
-
-Section ENCODING_VALUE.
-
-(*
-On calcule la valeur binaire selon un schema de Horner.
-Le calcul s'arrete à la longueur du vecteur sans vérification.
-On definit une fonction Zmod2 calquee sur Zdiv2 mais donnant le quotient
-de la division z=2q+r avec 0<=r<=1.
-La valeur en complément à deux est calculée selon un schema de Horner
-avec Zmod2, le paramètre est la taille moins un.
-*)
-
-Definition Zmod2 := [z:Z] Cases z of
-  	|  ZERO => `0`
- 	| ((POS p)) => Cases p of
-      		| (xI q) => (POS q)
-    		| (xO q) => (POS q)
-    		| xH => `0`
-    		end
- 	| ((NEG p)) => Cases p of
-      		| (xI q) => `(NEG q) - 1`
-    		| (xO q) => (NEG q)
-    		| xH => `-1`
-    		end
- 	end.
-
-V7only [
-Notation double_moins_un_add_un :=
-  [p](sym_eq ? ? ? (double_moins_un_add_un_xI p)).
-].
-
-Lemma Zmod2_twice : (z:Z)
-	`z = (2*(Zmod2 z) + (bit_value (Zodd_bool z)))`.
-Proof.
-	NewDestruct z; Simpl.
-	Trivial.
-
-	NewDestruct p; Simpl; Trivial.
-
-	NewDestruct p; Simpl.
-	NewDestruct p as [p|p|]; Simpl.
-	Rewrite <- (double_moins_un_add_un_xI p); Trivial.
-
-	Trivial.
-
-	Trivial.
-
-	Trivial.
-
-	Trivial.
-Save.
-
-Lemma Z_to_binary : (n:nat) Z -> (Bvector n).
-Proof.
-	Induction n; Intros.
-	Exact Bnil.
-
-	Exact (Bcons (Zodd_bool H0) n0 (H (Zdiv2 H0))).
-Defined.
-
-(*
-Eval Compute in (Z_to_binary (5) `5`).
-     = (Vcons bool true (4)
-          (Vcons bool false (3)
-            (Vcons bool true (2)
-              (Vcons bool false (1) (Vcons bool false (0) (Vnil bool))))))
-     :  (Bvector (5))
-*)
-
-Lemma Z_to_two_compl : (n:nat) Z -> (Bvector (S n)).
-Proof.
-	Induction n; Intros.
-	Exact (Bcons (Zodd_bool H) (0) Bnil).
-
-	Exact (Bcons (Zodd_bool H0) (S n0) (H (Zmod2 H0))).
-Defined.
-
-(*
-Eval Compute in (Z_to_two_compl (3) `0`).
-     =  (Vcons bool false (3)
-          (Vcons bool false (2)
-            (Vcons bool false (1) (Vcons bool false (0) (Vnil bool)))))
-     :  (vector bool (4))
-
-Eval Compute in (Z_to_two_compl (3) `5`).
-     = (Vcons bool true (3)
-          (Vcons bool false (2)
-            (Vcons bool true (1) (Vcons bool false (0) (Vnil bool)))))
-     :  (vector bool (4))
-
-Eval Compute in (Z_to_two_compl (3) `-5`).
-     =  (Vcons bool true (3)
-          (Vcons bool true (2)
-            (Vcons bool false (1) (Vcons bool true (0) (Vnil bool)))))
-     :  (vector bool (4))
-*)	
-
-End ENCODING_VALUE.
-
-Section Z_BRIC_A_BRAC.
-
-(*
-Bibliotheque de lemmes utiles dans la section suivante.
-Utilise largement ZArith.
-Meriterait d'etre reecrite.
-*)
-
-Lemma binary_value_Sn : (n:nat) (b:bool) (bv : (Bvector n))
-	(binary_value (S n) (Vcons bool b n bv))=`(bit_value b) + 2*(binary_value n bv)`.
-Proof.
-	Intros; Auto.
-Save.
-
-Lemma Z_to_binary_Sn : (n:nat) (b:bool) (z:Z)
-	`z>=0`->
-	(Z_to_binary (S n) `(bit_value b) + 2*z`)=(Bcons b n (Z_to_binary n z)).
-Proof.
-	NewDestruct b; NewDestruct z; Simpl; Auto.
-	Intro H; Elim H; Trivial.
-Save.
-
-Lemma binary_value_pos : (n:nat) (bv:(Bvector n))
-	`(binary_value n bv) >= 0`.
-Proof.
-	NewInduction bv as [|a n v IHbv]; Simpl.
-	Omega.
-
-	NewDestruct a; NewDestruct (binary_value n v); Simpl; Auto.
-	Auto with zarith.
-Save.
-
-V7only [Notation add_un_double_moins_un_xO := is_double_moins_un.].
-
-Lemma two_compl_value_Sn : (n:nat) (bv : (Bvector (S n))) (b:bool)
-	(two_compl_value (S n) (Bcons b (S n) bv)) =
-		`(bit_value b) + 2*(two_compl_value n bv)`.
-Proof.
-	Intros; Auto.
-Save.
-
-Lemma Z_to_two_compl_Sn : (n:nat) (b:bool) (z:Z) 
-	(Z_to_two_compl (S n) `(bit_value b) + 2*z`) =
-		(Bcons b (S n) (Z_to_two_compl n z)).
-Proof.
-	NewDestruct b; NewDestruct z as [|p|p]; Auto.
-	NewDestruct p as [p|p|]; Auto.
-	NewDestruct p as [p|p|]; Simpl; Auto.
-	Intros; Rewrite (add_un_double_moins_un_xO p); Trivial.
-Save.
-
-Lemma Z_to_binary_Sn_z : (n:nat) (z:Z)
-	(Z_to_binary (S n) z)=(Bcons (Zodd_bool z) n (Z_to_binary n (Zdiv2 z))).
-Proof.
-	Intros; Auto.
-Save.
-
-Lemma Z_div2_value : (z:Z)
-	` z>=0 `->
-	 `(bit_value (Zodd_bool z))+2*(Zdiv2 z) = z`.
-Proof.
-	NewDestruct z as [|p|p]; Auto.
-	NewDestruct p; Auto.
-  Intro H; Elim H; Trivial.
-Save.
-
-Lemma Zdiv2_pos : (z:Z)
-	` z >= 0 ` ->
-	`(Zdiv2 z) >= 0 `.
-Proof.
-	NewDestruct z as [|p|p].
-	Auto.
-
-	NewDestruct p; Auto.
-	Simpl; Intros; Omega.
-
-  Intro H; Elim H; Trivial.
-
-Save.
-
-Lemma Zdiv2_two_power_nat : (z:Z) (n:nat)
-	` z >= 0 ` ->
-	` z < (two_power_nat (S n)) ` ->
-	`(Zdiv2 z) < (two_power_nat n) `.
-Proof.
-	Intros.
-	Cut (Zlt (Zmult `2` (Zdiv2 z)) (Zmult `2` (two_power_nat n))); Intros.
-	Omega.
-
-	Rewrite <- two_power_nat_S.
-	NewDestruct (Zeven_odd_dec z); Intros.
-	Rewrite <- Zeven_div2; Auto.
-
-	Generalize (Zodd_div2 z H z0); Omega.
-Save.
-
-(*
-
-Lemma Z_minus_one_or_zero : (z:Z)
-	`z >= -1` ->
-	`z < 1` ->
-	{`z=-1`} + {`z=0`}.
-Proof.
-	NewDestruct z; Auto.
-	NewDestruct p; Auto.
-	Tauto.
-
-	Tauto.
-
-	Intros.
-	Right; Omega.
-
-	NewDestruct p.
-	Tauto.
-
-	Tauto.
-
-	Intros; Left; Omega.
-Save.
-*)
-
-Lemma Z_to_two_compl_Sn_z : (n:nat) (z:Z)
-	(Z_to_two_compl (S n) z)=(Bcons (Zodd_bool z) (S n) (Z_to_two_compl n (Zmod2 z))).
-Proof.
-	Intros; Auto.
-Save.
-
-Lemma Zeven_bit_value : (z:Z)
-	(Zeven z) ->
-	`(bit_value (Zodd_bool z))=0`.
-Proof.
-	NewDestruct z; Unfold bit_value; Auto.
-	NewDestruct p; Tauto Orelse (Intro H; Elim H).
- 	NewDestruct p; Tauto Orelse (Intro H; Elim H).
-Save.
-
-Lemma Zodd_bit_value : (z:Z)
-	(Zodd z) ->
-	`(bit_value (Zodd_bool z))=1`.
-Proof.
-	NewDestruct z; Unfold bit_value; Auto.
-  Intros; Elim H.
-  NewDestruct p; Tauto Orelse (Intros; Elim H).
-  NewDestruct p; Tauto Orelse (Intros; Elim H).
-Save.
-
-Lemma Zge_minus_two_power_nat_S : (n:nat) (z:Z)
-	`z >= (-(two_power_nat (S n)))`->
-	`(Zmod2 z) >= (-(two_power_nat n))`.
-Proof.
-	Intros n z; Rewrite (two_power_nat_S n).
-	Generalize (Zmod2_twice z).
-	NewDestruct (Zeven_odd_dec z) as [H|H].
-	Rewrite (Zeven_bit_value z H); Intros; Omega.
-
-        Rewrite (Zodd_bit_value z H); Intros; Omega.
-Save.
-
-Lemma Zlt_two_power_nat_S : (n:nat) (z:Z)
-	`z < (two_power_nat (S n))`->
-	`(Zmod2 z) < (two_power_nat n)`.
-Proof.
-	Intros n z; Rewrite (two_power_nat_S n).
-	Generalize (Zmod2_twice z).
-	NewDestruct (Zeven_odd_dec z) as [H|H].
-	Rewrite (Zeven_bit_value z H); Intros; Omega.
-
-	Rewrite (Zodd_bit_value z H); Intros; Omega.
-Save.
-
-End Z_BRIC_A_BRAC.
-
-Section COHERENT_VALUE.
-
-(*
-On vérifie que dans l'intervalle de définition les fonctions sont 
-réciproques l'une de l'autre.
-Elles utilisent les lemmes du bric-a-brac.
-*)
-
-Lemma binary_to_Z_to_binary : (n:nat) (bv : (Bvector n))
-	(Z_to_binary n (binary_value n bv))=bv.
-Proof.
-	NewInduction bv as [|a n bv IHbv].
-	Auto.
-
-	Rewrite binary_value_Sn.
-	Rewrite Z_to_binary_Sn.
-	Rewrite IHbv; Trivial.
-
-	Apply binary_value_pos.
-Save.
-		
-Lemma two_compl_to_Z_to_two_compl : (n:nat) (bv : (Bvector n)) (b:bool)
-	(Z_to_two_compl n (two_compl_value n (Bcons b n bv)))=
-		(Bcons b n bv).
-Proof.
-	NewInduction bv as [|a n bv IHbv]; Intro b.
-	NewDestruct b; Auto.
-
-	Rewrite two_compl_value_Sn.
-	Rewrite Z_to_two_compl_Sn.
-	Rewrite IHbv; Trivial.
-Save.
-
-Lemma Z_to_binary_to_Z : (n:nat) (z : Z)
-	`z >= 0 `->
-	`z < (two_power_nat n) `->
-	 (binary_value n (Z_to_binary n z))=z.
-Proof.
-	NewInduction n as [|n IHn].
-	Unfold two_power_nat shift_nat; Simpl; Intros; Omega.
-
-	Intros; Rewrite Z_to_binary_Sn_z.
-	Rewrite binary_value_Sn.
-	Rewrite IHn.
-	Apply Z_div2_value; Auto.
-
-	Apply Zdiv2_pos; Trivial.
-
-	Apply Zdiv2_two_power_nat; Trivial.
-Save.
-
-Lemma Z_to_two_compl_to_Z : (n:nat) (z : Z)
-	`z >= -(two_power_nat n) `->
-	`z < (two_power_nat n) `->
-	(two_compl_value n (Z_to_two_compl n  z))=z.
-Proof.
-	NewInduction n as [|n IHn].
-	Unfold two_power_nat shift_nat; Simpl; Intros.
-	Assert `z=-1`\/`z=0`. Omega.
-Intuition; Subst z; Trivial.
-
-	Intros; Rewrite Z_to_two_compl_Sn_z.
-	Rewrite two_compl_value_Sn.
-	Rewrite IHn.
-	Generalize (Zmod2_twice z); Omega.
-
-	Apply Zge_minus_two_power_nat_S; Auto.
-
-	Apply Zlt_two_power_nat_S; Auto.
-Save.
-
-End COHERENT_VALUE.
-
diff --git a/theories7/ZArith/Zbool.v b/theories7/ZArith/Zbool.v
deleted file mode 100644
index 258a485d..00000000
--- a/theories7/ZArith/Zbool.v
+++ /dev/null
@@ -1,158 +0,0 @@
-(************************************************************************)
-(*  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: Zbool.v,v 1.1.2.1 2004/07/16 19:31:42 herbelin Exp $ *)
-
-Require BinInt.
-Require Zeven.
-Require Zorder.
-Require Zcompare.
-Require ZArith_dec.
-Require Zsyntax.
-Require Sumbool.
-
-(** The decidability of equality and order relations over
-    type [Z] give some boolean functions with the adequate specification. *)
-
-Definition Z_lt_ge_bool := [x,y:Z](bool_of_sumbool (Z_lt_ge_dec x y)).
-Definition Z_ge_lt_bool := [x,y:Z](bool_of_sumbool (Z_ge_lt_dec x y)).
-
-Definition Z_le_gt_bool := [x,y:Z](bool_of_sumbool (Z_le_gt_dec x y)).
-Definition Z_gt_le_bool := [x,y:Z](bool_of_sumbool (Z_gt_le_dec x y)).
-
-Definition Z_eq_bool := [x,y:Z](bool_of_sumbool (Z_eq_dec x y)).
-Definition Z_noteq_bool := [x,y:Z](bool_of_sumbool (Z_noteq_dec x y)).
-
-Definition Zeven_odd_bool := [x:Z](bool_of_sumbool (Zeven_odd_dec x)).
-
-(**********************************************************************)
-(** Boolean comparisons of binary integers *)
-
-Definition Zle_bool := 
-  [x,y:Z]Cases `x ?= y` of SUPERIEUR => false | _ => true end.
-Definition Zge_bool := 
-  [x,y:Z]Cases `x ?= y` of INFERIEUR => false | _ => true end.
-Definition Zlt_bool := 
-  [x,y:Z]Cases `x ?= y` of INFERIEUR => true | _ => false end.
-Definition Zgt_bool := 
-  [x,y:Z]Cases ` x ?= y` of SUPERIEUR => true | _ => false end.
-Definition Zeq_bool := 
-  [x,y:Z]Cases `x ?= y` of EGAL => true | _ => false end.
-Definition Zneq_bool := 
-  [x,y:Z]Cases `x ?= y` of EGAL => false | _ => true end.
-
-Lemma Zle_cases : (x,y:Z)if (Zle_bool x y) then `x<=y` else `x>y`.
-Proof.
-Intros x y; Unfold Zle_bool Zle Zgt.
-Case (Zcompare x y); Auto; Discriminate.
-Qed.
-
-Lemma Zlt_cases : (x,y:Z)if (Zlt_bool x y) then `x<y` else `x>=y`.
-Proof.
-Intros x y; Unfold Zlt_bool Zlt Zge.
-Case (Zcompare x y); Auto; Discriminate.
-Qed.
-
-Lemma Zge_cases : (x,y:Z)if (Zge_bool x y) then `x>=y` else `x<y`.
-Proof.
-Intros x y; Unfold Zge_bool Zge Zlt.
-Case (Zcompare x y); Auto; Discriminate.
-Qed.
-
-Lemma Zgt_cases : (x,y:Z)if (Zgt_bool x y) then `x>y` else `x<=y`.
-Proof.
-Intros x y; Unfold Zgt_bool Zgt Zle.
-Case (Zcompare x y); Auto; Discriminate.
-Qed.
-
-(** Lemmas on [Zle_bool] used in contrib/graphs *)
-
-Lemma Zle_bool_imp_le : (x,y:Z) (Zle_bool x y)=true -> (Zle x y).
-Proof.
-  Unfold Zle_bool Zle. Intros x y. Unfold not. 
-  Case (Zcompare x y); Intros; Discriminate.
-Qed.
-
-Lemma Zle_imp_le_bool : (x,y:Z) (Zle x y) -> (Zle_bool x y)=true.
-Proof.
-  Unfold Zle Zle_bool. Intros x y. Case (Zcompare x y); Trivial. Intro. Elim (H (refl_equal ? ?)).
-Qed.
-
-Lemma Zle_bool_refl : (x:Z) (Zle_bool x x)=true.
-Proof.
-  Intro. Apply Zle_imp_le_bool. Apply Zle_refl. Reflexivity.
-Qed.
-
-Lemma Zle_bool_antisym : (x,y:Z) (Zle_bool x y)=true -> (Zle_bool y x)=true -> x=y.
-Proof.
-  Intros. Apply Zle_antisym. Apply Zle_bool_imp_le. Assumption.
-  Apply Zle_bool_imp_le. Assumption.
-Qed.
-
-Lemma Zle_bool_trans : (x,y,z:Z) (Zle_bool x y)=true -> (Zle_bool y z)=true -> (Zle_bool x z)=true.
-Proof.
-  Intros x y z; Intros. Apply Zle_imp_le_bool. Apply Zle_trans with m:=y. Apply Zle_bool_imp_le. Assumption.
-  Apply Zle_bool_imp_le. Assumption.
-Qed.
-
-Definition Zle_bool_total : (x,y:Z) {(Zle_bool x y)=true}+{(Zle_bool y x)=true}.
-Proof.
-  Intros x y; Intros. Unfold Zle_bool. Cut (Zcompare x y)=SUPERIEUR<->(Zcompare y x)=INFERIEUR.
-  Case (Zcompare x y). Left . Reflexivity.
-  Left . Reflexivity.
-  Right . Rewrite (proj1 ? ? H (refl_equal ? ?)). Reflexivity.
-  Apply Zcompare_ANTISYM.
-Defined.
-
-Lemma Zle_bool_plus_mono : (x,y,z,t:Z) (Zle_bool x y)=true -> (Zle_bool z t)=true ->
-                                (Zle_bool (Zplus x z) (Zplus y t))=true.
-Proof.
-  Intros. Apply Zle_imp_le_bool. Apply Zle_plus_plus. Apply Zle_bool_imp_le. Assumption.
-  Apply Zle_bool_imp_le. Assumption.
-Qed.
-
-Lemma Zone_pos : (Zle_bool `1` `0`)=false.
-Proof.
-  Reflexivity.
-Qed.
-
-Lemma Zone_min_pos : (x:Z) (Zle_bool x `0`)=false -> (Zle_bool `1` x)=true.
-Proof.
-  Intros x; Intros. Apply Zle_imp_le_bool. Change (Zle (Zs ZERO) x). Apply Zgt_le_S. Generalize H.
-  Unfold Zle_bool Zgt. Case (Zcompare x ZERO). Intro H0. Discriminate H0.
-  Intro H0. Discriminate H0.
-  Reflexivity.
-Qed.
-
-
- Lemma Zle_is_le_bool : (x,y:Z) (Zle x y) <-> (Zle_bool x y)=true.
-  Proof.
-    Intros. Split. Intro. Apply Zle_imp_le_bool. Assumption.
-    Intro. Apply Zle_bool_imp_le. Assumption.
-  Qed.
-
-  Lemma Zge_is_le_bool : (x,y:Z) (Zge x y) <-> (Zle_bool y x)=true.
-  Proof.
-    Intros. Split. Intro. Apply Zle_imp_le_bool. Apply Zge_le. Assumption.
-    Intro. Apply Zle_ge. Apply Zle_bool_imp_le. Assumption.
-  Qed.
-
-  Lemma Zlt_is_le_bool : (x,y:Z) (Zlt x y) <-> (Zle_bool x `y-1`)=true.
-  Proof.
-    Intros x y. Split. Intro. Apply Zle_imp_le_bool. Apply Zlt_n_Sm_le. Rewrite (Zs_pred y) in H.
-    Assumption.
-    Intro. Rewrite (Zs_pred y). Apply Zle_lt_n_Sm. Apply Zle_bool_imp_le. Assumption.
-  Qed.
-
-  Lemma Zgt_is_le_bool : (x,y:Z) (Zgt x y) <-> (Zle_bool y `x-1`)=true.
-  Proof.
-    Intros x y. Apply iff_trans with `y < x`. Split. Exact (Zgt_lt x y).
-    Exact (Zlt_gt y x).
-    Exact (Zlt_is_le_bool y x).
-  Qed.
-
diff --git a/theories7/ZArith/Zcompare.v b/theories7/ZArith/Zcompare.v
deleted file mode 100644
index fd11ae9b..00000000
--- a/theories7/ZArith/Zcompare.v
+++ /dev/null
@@ -1,480 +0,0 @@
-(************************************************************************)
-(*  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 $$ i*)
-
-Require Export BinPos.
-Require Export BinInt.
-Require Zsyntax.
-Require Lt.
-Require Gt.
-Require Plus.
-Require Mult.
-
-Open Local Scope Z_scope.
-
-(**********************************************************************)
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
-(**********************************************************************)
-
-(**********************************************************************)
-(** Comparison on integers *)
-
-Lemma Zcompare_x_x : (x:Z) (Zcompare x x) = EGAL.
-Proof.
-Intro x; NewDestruct x as [|p|p]; Simpl; [ Reflexivity | Apply convert_compare_EGAL
-  | Rewrite convert_compare_EGAL; Reflexivity ].
-Qed.
-
-Lemma Zcompare_EGAL_eq : (x,y:Z) (Zcompare x y) = EGAL -> x = y.
-Proof.
-Intros x y; NewDestruct x as [|x'|x'];NewDestruct y as [|y'|y'];Simpl;Intro H; Reflexivity Orelse Try Discriminate H; [
-    Rewrite (compare_convert_EGAL x' y' H); Reflexivity
-  | Rewrite (compare_convert_EGAL x' y'); [
-      Reflexivity
-    | NewDestruct (compare x' y' EGAL);
-      Reflexivity Orelse Discriminate]].
-Qed.
-
-Lemma Zcompare_EGAL : (x,y:Z) (Zcompare x y) = EGAL <-> x = y.
-Proof.
-Intros x y;Split; Intro E; [ Apply Zcompare_EGAL_eq; Assumption
-  | Rewrite E; Apply Zcompare_x_x ].
-Qed.
-
-Lemma Zcompare_antisym :
-  (x,y:Z)(Op (Zcompare x y)) = (Zcompare y x).
-Proof.
-Intros x y; NewDestruct x; NewDestruct y; Simpl;
-  Reflexivity Orelse Discriminate H Orelse 
-  Rewrite Pcompare_antisym; Reflexivity.
-Qed.
-
-Lemma Zcompare_ANTISYM : 
-  (x,y:Z) (Zcompare x y) = SUPERIEUR <->  (Zcompare y x) = INFERIEUR.
-Proof.
-Intros x y; Split; Intro H; [ 
-  Change INFERIEUR with (Op SUPERIEUR); 
-  Rewrite <- Zcompare_antisym; Rewrite H; Reflexivity
-| Change SUPERIEUR with (Op INFERIEUR); 
-  Rewrite <- Zcompare_antisym; Rewrite H; Reflexivity ].
-Qed.
-
-(** Transitivity of comparison *)
-
-Lemma Zcompare_trans_SUPERIEUR : 
-  (x,y,z:Z) (Zcompare x y) = SUPERIEUR ->  
-            (Zcompare y z) = SUPERIEUR ->
-            (Zcompare x z) = SUPERIEUR.
-Proof.
-Intros x y z;Case x;Case y;Case z; Simpl;
-Try (Intros; Discriminate H Orelse Discriminate H0);
-Auto with arith; [
-  Intros p q r H H0;Apply convert_compare_SUPERIEUR; Unfold gt;
-  Apply lt_trans with m:=(convert q);
-  Apply compare_convert_INFERIEUR;Apply ZC1;Assumption
-| Intros p q r; Do 3 Rewrite <- ZC4; Intros H H0;
-  Apply convert_compare_SUPERIEUR;Unfold gt;Apply lt_trans with m:=(convert q);
-  Apply compare_convert_INFERIEUR;Apply ZC1;Assumption ].
-Qed.
-
-(** Comparison and opposite *)
-
-Lemma Zcompare_Zopp :
-  (x,y:Z) (Zcompare x y) = (Zcompare (Zopp y) (Zopp x)).
-Proof.
-(Intros x y;Case x;Case y;Simpl;Auto with arith);
-Intros;Rewrite <- ZC4;Trivial with arith.
-Qed.
-
-Hints Local Resolve convert_compare_EGAL.
-
-(** Comparison first-order specification *)
-
-Lemma SUPERIEUR_POS :
-  (x,y:Z) (Zcompare x y) = SUPERIEUR ->
-  (EX h:positive |(Zplus x (Zopp y)) = (POS h)).
-Proof.
-Intros x y;Case x;Case y; [
-  Simpl; Intros H; Discriminate H
-| Simpl; Intros p H; Discriminate H
-| Intros p H; Exists p; Simpl; Auto with arith
-| Intros p H; Exists p; Simpl; Auto with arith
-| Intros q p H; Exists (true_sub p q); Unfold Zplus Zopp;
-  Unfold Zcompare in H; Rewrite H; Trivial with arith
-| Intros q p H; Exists (add p q); Simpl; Trivial with arith
-| Simpl; Intros p H; Discriminate H
-| Simpl; Intros q p H; Discriminate H
-| Unfold Zcompare; Intros q p; Rewrite <- ZC4; Intros H; Exists (true_sub q p);
-  Simpl; Rewrite (ZC1 q p H); Trivial with arith].
-Qed.
-
-(** Comparison and addition *)
-
-Lemma weaken_Zcompare_Zplus_compatible : 
-  ((n,m:Z) (p:positive) 
-    (Zcompare (Zplus (POS p) n) (Zplus (POS p) m)) = (Zcompare n m)) ->
-   (x,y,z:Z) (Zcompare (Zplus z x) (Zplus z y)) = (Zcompare x y).
-Proof.
-Intros H x y z; NewDestruct z; [
-  Reflexivity
-| Apply H
-| Rewrite (Zcompare_Zopp x y); Rewrite Zcompare_Zopp; 
-  Do 2 Rewrite Zopp_Zplus; Rewrite Zopp_NEG; Apply H ].
-Qed.
-
-Hints Local Resolve ZC4.
-
-Lemma weak_Zcompare_Zplus_compatible : 
-  (x,y:Z) (z:positive) 
-    (Zcompare (Zplus (POS z) x) (Zplus (POS z) y)) = (Zcompare x y).
-Proof.
-Intros x y z;Case x;Case y;Simpl;Auto with arith; [
-  Intros p;Apply convert_compare_INFERIEUR; Apply ZL17
-| Intros p;ElimPcompare z p;Intros E;Rewrite E;Auto with arith;
-  Apply convert_compare_SUPERIEUR; Rewrite true_sub_convert; [ Unfold gt ;
-  Apply ZL16 | Assumption ]
-| Intros p;ElimPcompare z p;
-  Intros E;Auto with arith; Apply convert_compare_SUPERIEUR;
-  Unfold gt;Apply ZL17
-| Intros p q;
-  ElimPcompare q p;
-  Intros E;Rewrite E;[
-    Rewrite (compare_convert_EGAL q p E); Apply convert_compare_EGAL
-  | Apply convert_compare_INFERIEUR;Do 2 Rewrite convert_add;Apply lt_reg_l;
-    Apply compare_convert_INFERIEUR with 1:=E
-  | Apply convert_compare_SUPERIEUR;Unfold gt ;Do 2 Rewrite convert_add;
-    Apply lt_reg_l;Exact (compare_convert_SUPERIEUR q p E) ]
-| Intros p q; 
-  ElimPcompare z p;
-  Intros E;Rewrite E;Auto with arith;
-  Apply convert_compare_SUPERIEUR; Rewrite true_sub_convert; [
-    Unfold gt; Apply lt_trans with m:=(convert z); [Apply ZL16 | Apply ZL17]
-  | Assumption ]
-| Intros p;ElimPcompare z p;Intros E;Rewrite E;Auto with arith; Simpl;
-  Apply convert_compare_INFERIEUR;Rewrite true_sub_convert;[Apply ZL16|
-  Assumption]
-| Intros p q;
-  ElimPcompare z q;
-  Intros E;Rewrite E;Auto with arith; Simpl;Apply convert_compare_INFERIEUR;
-  Rewrite true_sub_convert;[
-    Apply lt_trans with m:=(convert z) ;[Apply ZL16|Apply ZL17]
-  | Assumption]
-| Intros p q; ElimPcompare z q; Intros E0;Rewrite E0;
-  ElimPcompare z p; Intros E1;Rewrite E1; ElimPcompare q p;
-  Intros E2;Rewrite E2;Auto with arith; [
-    Absurd (compare q p EGAL)=INFERIEUR; [
-      Rewrite <- (compare_convert_EGAL z q E0);
-      Rewrite <- (compare_convert_EGAL z p E1); 
-      Rewrite (convert_compare_EGAL z); Discriminate
-    | Assumption ]
-  | Absurd (compare q p EGAL)=SUPERIEUR; [
-      Rewrite <- (compare_convert_EGAL z q E0);
-      Rewrite <- (compare_convert_EGAL z p E1);
-      Rewrite (convert_compare_EGAL z);Discriminate
-    | Assumption]
-  | Absurd (compare z p EGAL)=INFERIEUR; [
-      Rewrite (compare_convert_EGAL z q E0); 
-      Rewrite <- (compare_convert_EGAL q p E2);
-      Rewrite (convert_compare_EGAL q);Discriminate
-    | Assumption ]
-  | Absurd (compare z p EGAL)=INFERIEUR; [
-      Rewrite (compare_convert_EGAL z q E0); Rewrite E2;Discriminate
-    | Assumption]
-  | Absurd (compare z p EGAL)=SUPERIEUR;[
-      Rewrite (compare_convert_EGAL z q E0);
-      Rewrite <- (compare_convert_EGAL q p E2);
-      Rewrite (convert_compare_EGAL q);Discriminate
-    | Assumption]
-  | Absurd (compare z p EGAL)=SUPERIEUR;[
-      Rewrite (compare_convert_EGAL z q E0);Rewrite E2;Discriminate
-    | Assumption]
-  | Absurd (compare z q EGAL)=INFERIEUR;[
-      Rewrite (compare_convert_EGAL z p E1);
-      Rewrite (compare_convert_EGAL q p E2);
-      Rewrite (convert_compare_EGAL p); Discriminate
-    | Assumption]
-  | Absurd (compare p q EGAL)=SUPERIEUR; [
-      Rewrite <- (compare_convert_EGAL z p E1);
-      Rewrite E0; Discriminate
-    | Apply ZC2;Assumption ]
-  | Simpl; Rewrite (compare_convert_EGAL q p E2);
-    Rewrite (convert_compare_EGAL (true_sub p z)); Auto with arith
-  | Simpl; Rewrite <- ZC4; Apply convert_compare_SUPERIEUR;
-    Rewrite true_sub_convert; [
-      Rewrite true_sub_convert; [
-        Unfold gt; Apply simpl_lt_plus_l with p:=(convert z);
-        Rewrite le_plus_minus_r; [
-          Rewrite le_plus_minus_r; [
-            Apply compare_convert_INFERIEUR;Assumption
-          | Apply lt_le_weak; Apply compare_convert_INFERIEUR;Assumption ]
-        | Apply lt_le_weak; Apply compare_convert_INFERIEUR;Assumption ]
-      | Apply ZC2;Assumption ]
-    | Apply ZC2;Assumption ]
-  | Simpl; Rewrite <- ZC4; Apply convert_compare_INFERIEUR; 
-    Rewrite true_sub_convert; [
-      Rewrite true_sub_convert; [
-        Apply simpl_lt_plus_l with p:=(convert z);
-        Rewrite le_plus_minus_r; [
-          Rewrite le_plus_minus_r; [
-            Apply compare_convert_INFERIEUR;Apply ZC1;Assumption
-          | Apply lt_le_weak; Apply compare_convert_INFERIEUR;Assumption ]
-        | Apply lt_le_weak; Apply compare_convert_INFERIEUR;Assumption ]
-      | Apply ZC2;Assumption]
-    | Apply ZC2;Assumption ]
-  | Absurd (compare z q EGAL)=INFERIEUR; [
-      Rewrite (compare_convert_EGAL q p E2);Rewrite E1;Discriminate
-    | Assumption ]
-  | Absurd (compare q p EGAL)=INFERIEUR; [
-      Cut (compare q p EGAL)=SUPERIEUR; [
-        Intros E;Rewrite E;Discriminate
-      | Apply convert_compare_SUPERIEUR; Unfold gt;
-        Apply lt_trans with m:=(convert z); [
-          Apply compare_convert_INFERIEUR;Apply ZC1;Assumption
-        | Apply compare_convert_INFERIEUR;Assumption ]]
-    | Assumption ]
-  | Absurd (compare z q EGAL)=SUPERIEUR; [
-      Rewrite (compare_convert_EGAL z p E1);
-      Rewrite (compare_convert_EGAL q p E2);
-      Rewrite (convert_compare_EGAL p); Discriminate
-    | Assumption ]
-  | Absurd (compare z q EGAL)=SUPERIEUR; [
-      Rewrite (compare_convert_EGAL z p E1);
-      Rewrite ZC1; [Discriminate | Assumption ]
-    | Assumption ]
-  | Absurd (compare z q EGAL)=SUPERIEUR; [
-      Rewrite (compare_convert_EGAL q p E2); Rewrite E1; Discriminate
-    | Assumption ]
-  | Absurd (compare q p EGAL)=SUPERIEUR; [
-      Rewrite ZC1; [ 
-        Discriminate 
-      | Apply convert_compare_SUPERIEUR; Unfold gt; 
-        Apply lt_trans with m:=(convert z); [
-          Apply compare_convert_INFERIEUR;Apply ZC1;Assumption
-        | Apply compare_convert_INFERIEUR;Assumption ]]
-    | Assumption ]
-  | Simpl; Rewrite (compare_convert_EGAL q p E2); Apply convert_compare_EGAL
-  | Simpl; Apply convert_compare_SUPERIEUR; Unfold gt;
-    Rewrite true_sub_convert; [
-      Rewrite true_sub_convert; [
-        Apply simpl_lt_plus_l with p:=(convert p); Rewrite le_plus_minus_r; [
-          Rewrite plus_sym; Apply simpl_lt_plus_l with p:=(convert q);
-          Rewrite plus_assoc_l; Rewrite le_plus_minus_r; [
-            Rewrite (plus_sym (convert q)); Apply lt_reg_l;
-            Apply compare_convert_INFERIEUR;Assumption
-          | Apply lt_le_weak; Apply compare_convert_INFERIEUR;
-            Apply ZC1;Assumption ]
-        | Apply lt_le_weak; Apply compare_convert_INFERIEUR;Apply ZC1; 
-          Assumption ]
-      | Assumption ]
-    | Assumption ]
-  | Simpl; Apply convert_compare_INFERIEUR; Rewrite true_sub_convert; [
-      Rewrite true_sub_convert; [
-        Apply simpl_lt_plus_l with p:=(convert q); Rewrite le_plus_minus_r; [
-          Rewrite plus_sym; Apply simpl_lt_plus_l with p:=(convert p);
-          Rewrite plus_assoc_l; Rewrite le_plus_minus_r; [
-            Rewrite (plus_sym (convert p)); Apply lt_reg_l;
-            Apply compare_convert_INFERIEUR;Apply ZC1;Assumption 
-          | Apply lt_le_weak; Apply compare_convert_INFERIEUR;Apply ZC1;
-            Assumption ]
-        | Apply lt_le_weak;Apply compare_convert_INFERIEUR;Apply ZC1;Assumption]
-      | Assumption]
-    | Assumption]]].
-Qed.
-
-Lemma Zcompare_Zplus_compatible : 
-   (x,y,z:Z) (Zcompare (Zplus z x) (Zplus z y)) = (Zcompare x y).
-Proof.
-Exact (weaken_Zcompare_Zplus_compatible weak_Zcompare_Zplus_compatible).
-Qed.
-
-Lemma Zcompare_Zplus_compatible2 :
-  (r:relation)(x,y,z,t:Z)
-    (Zcompare x y) = r -> (Zcompare z t) = r ->
-    (Zcompare (Zplus x z) (Zplus y t)) = r.
-Proof.
-Intros r x y z t; Case r; [
-  Intros H1 H2; Elim (Zcompare_EGAL x y); Elim (Zcompare_EGAL z t);
-  Intros H3 H4 H5 H6; Rewrite H3; [ 
-    Rewrite H5; [ Elim (Zcompare_EGAL (Zplus y t) (Zplus y t)); Auto with arith | Auto with arith ]
-  | Auto with arith ]
-| Intros H1 H2; Elim (Zcompare_ANTISYM (Zplus y t) (Zplus x z));
-  Intros H3 H4; Apply H3;
-  Apply Zcompare_trans_SUPERIEUR with y:=(Zplus y z) ; [
-    Rewrite Zcompare_Zplus_compatible;
-    Elim (Zcompare_ANTISYM t z); Auto with arith
-  | Do 2 Rewrite <- (Zplus_sym z); 
-    Rewrite Zcompare_Zplus_compatible;
-    Elim (Zcompare_ANTISYM y x); Auto with arith]
-| Intros H1 H2;
-  Apply Zcompare_trans_SUPERIEUR with y:=(Zplus x t) ; [
-    Rewrite Zcompare_Zplus_compatible; Assumption
-  | Do 2 Rewrite <- (Zplus_sym t);
-    Rewrite Zcompare_Zplus_compatible; Assumption]].
-Qed.
-
-Lemma Zcompare_Zs_SUPERIEUR : (x:Z)(Zcompare (Zs x) x)=SUPERIEUR.
-Proof.
-Intro x; Unfold Zs; Pattern 2 x; Rewrite <- (Zero_right x); 
-Rewrite Zcompare_Zplus_compatible;Reflexivity.
-Qed.
-
-Lemma Zcompare_et_un: 
-  (x,y:Z) (Zcompare x y)=SUPERIEUR <-> 
-    ~(Zcompare x (Zplus y (POS xH)))=INFERIEUR.
-Proof.
-Intros x y; Split; [
-  Intro H; (ElimCompare 'x '(Zplus y (POS xH)));[
-    Intro H1; Rewrite H1; Discriminate
-  | Intros H1; Elim SUPERIEUR_POS with 1:=H; Intros h H2; 
-    Absurd (gt (convert h) O) /\ (lt (convert h) (S O)); [
-      Unfold not ;Intros H3;Elim H3;Intros H4 H5; Absurd (gt (convert h) O); [
-        Unfold gt ;Apply le_not_lt; Apply le_S_n; Exact H5
-      | Assumption]
-    | Split; [
-        Elim (ZL4 h); Intros i H3;Rewrite H3; Apply gt_Sn_O
-      | Change (lt (convert h) (convert xH)); 
-        Apply compare_convert_INFERIEUR;
-        Change (Zcompare (POS h) (POS xH))=INFERIEUR;
-        Rewrite <- H2; Rewrite <- [m,n:Z](Zcompare_Zplus_compatible m n y);
-        Rewrite (Zplus_sym x);Rewrite Zplus_assoc; Rewrite Zplus_inverse_r;
-        Simpl; Exact H1 ]]
-  | Intros H1;Rewrite -> H1;Discriminate ]
-| Intros H; (ElimCompare 'x '(Zplus y (POS xH))); [
-    Intros H1;Elim (Zcompare_EGAL x (Zplus y (POS xH))); Intros H2 H3;
-    Rewrite  (H2 H1); Exact (Zcompare_Zs_SUPERIEUR y)
-  | Intros H1;Absurd (Zcompare x (Zplus y (POS xH)))=INFERIEUR;Assumption
-  | Intros H1; Apply Zcompare_trans_SUPERIEUR with y:=(Zs y); 
-      [ Exact H1 | Exact (Zcompare_Zs_SUPERIEUR y)]]].
-Qed.
-
-(** Successor and comparison *)
-
-Lemma Zcompare_n_S : (n,m:Z)(Zcompare (Zs n) (Zs m)) = (Zcompare n m).
-Proof.
-Intros n m;Unfold Zs ;Do 2 Rewrite -> [t:Z](Zplus_sym t (POS xH));
-Rewrite -> Zcompare_Zplus_compatible;Auto with arith.
-Qed.
- 
-(** Multiplication and comparison *)
-
-Lemma Zcompare_Zmult_compatible : 
-   (x:positive)(y,z:Z)
-      (Zcompare (Zmult (POS x) y) (Zmult (POS x) z)) = (Zcompare y z).
-Proof.
-Intros x; NewInduction x as [p H|p H|]; [
-  Intros y z;
-  Cut (POS (xI p))=(Zplus (Zplus (POS p) (POS p)) (POS xH)); [
-    Intros E; Rewrite E; Do 4 Rewrite Zmult_plus_distr_l; 
-    Do 2 Rewrite Zmult_one;
-    Apply Zcompare_Zplus_compatible2; [
-      Apply Zcompare_Zplus_compatible2; Apply H
-    | Trivial with arith]
-  | Simpl; Rewrite (add_x_x p); Trivial with arith]
-| Intros y z; Cut (POS (xO p))=(Zplus (POS p) (POS p)); [
-    Intros E; Rewrite E; Do 2 Rewrite Zmult_plus_distr_l;
-      Apply Zcompare_Zplus_compatible2; Apply H
-    | Simpl; Rewrite (add_x_x p); Trivial with arith]
-  | Intros y z; Do 2 Rewrite Zmult_one; Trivial with arith].
-Qed.
-
-
-(** Reverting [x ?= y] to trichotomy *)
-
-Lemma rename : (A:Set)(P:A->Prop)(x:A) ((y:A)(x=y)->(P y)) -> (P x).
-Proof.
-Auto with arith. 
-Qed.
-
-Lemma Zcompare_elim :
-  (c1,c2,c3:Prop)(x,y:Z)
-    ((x=y) -> c1) ->(`x<y` -> c2) ->(`x>y`-> c3)
-     -> Cases (Zcompare x y) of EGAL => c1 | INFERIEUR => c2 | SUPERIEUR => c3 end.
-Proof.
-Intros c1 c2 c3 x y; Intros.
-Apply rename with x:=(Zcompare x y); Intro r; Elim r;
-[ Intro; Apply H; Apply (Zcompare_EGAL_eq x y); Assumption
-| Unfold Zlt in H0; Assumption
-| Unfold Zgt in H1; Assumption ].
-Qed.
-
-Lemma Zcompare_eq_case : 
-  (c1,c2,c3:Prop)(x,y:Z) c1 -> x=y ->
-  Cases (Zcompare x y) of EGAL => c1 | INFERIEUR => c2 | SUPERIEUR => c3 end.
-Proof.
-Intros c1 c2 c3 x y; Intros.
-Rewrite H0; Rewrite (Zcompare_x_x).
-Assumption.
-Qed.
-
-(** Decompose an egality between two [?=] relations into 3 implications *)
-
-Lemma Zcompare_egal_dec :
-   (x1,y1,x2,y2:Z)
-    (`x1<y1`->`x2<y2`)
-     ->((Zcompare x1 y1)=EGAL -> (Zcompare x2 y2)=EGAL)
-        ->(`x1>y1`->`x2>y2`)->(Zcompare x1 y1)=(Zcompare x2 y2).
-Proof.
-Intros x1 y1 x2 y2.
-Unfold Zgt; Unfold Zlt;
-Case (Zcompare x1 y1); Case (Zcompare x2 y2); Auto with arith; Symmetry; Auto with arith.
-Qed.
-
-(** Relating [x ?= y] to [Zle], [Zlt], [Zge] or [Zgt] *)
-
-Lemma Zle_Zcompare :
-  (x,y:Z)`x<=y` ->
-  Cases (Zcompare x y) of EGAL => True | INFERIEUR => True | SUPERIEUR => False end.
-Proof.
-Intros x y; Unfold Zle; Elim (Zcompare x y); Auto with arith.
-Qed.
-
-Lemma Zlt_Zcompare :
-  (x,y:Z)`x<y`  ->
-  Cases (Zcompare x y) of EGAL => False | INFERIEUR => True | SUPERIEUR => False end.
-Proof.
-Intros x y; Unfold Zlt; Elim (Zcompare x y); Intros; Discriminate Orelse Trivial with arith.
-Qed.
-
-Lemma Zge_Zcompare :
-  (x,y:Z)`x>=y`->
-  Cases (Zcompare x y) of EGAL => True | INFERIEUR => False | SUPERIEUR => True end.
-Proof.
-Intros x y; Unfold Zge; Elim (Zcompare x y); Auto with arith. 
-Qed.
-
-Lemma Zgt_Zcompare :
-  (x,y:Z)`x>y` ->
-  Cases (Zcompare x y) of EGAL => False | INFERIEUR => False | SUPERIEUR => True end.
-Proof.
-Intros x y; Unfold Zgt; Elim (Zcompare x y); Intros; Discriminate Orelse Trivial with arith.
-Qed.
-
-(**********************************************************************)
-(* Other properties *)
-
-V7only [Set Implicit Arguments.].
-
-Lemma  Zcompare_Zmult_left : (x,y,z:Z)`z>0` -> `x ?= y`=`z*x ?= z*y`.
-Proof.
-Intros x y z H; NewDestruct z.
-  Discriminate H.
-  Rewrite Zcompare_Zmult_compatible; Reflexivity.
-  Discriminate H.
-Qed.
-
-Lemma Zcompare_Zmult_right : (x,y,z:Z)` z>0` -> `x ?= y`=`x*z ?= y*z`.
-Proof.
-Intros x y z H;
-Rewrite (Zmult_sym x z);
-Rewrite (Zmult_sym y z);
-Apply Zcompare_Zmult_left; Assumption.
-Qed.
-
-V7only [Unset Implicit Arguments.].
-
diff --git a/theories7/ZArith/Zcomplements.v b/theories7/ZArith/Zcomplements.v
deleted file mode 100644
index 72d837b6..00000000
--- a/theories7/ZArith/Zcomplements.v
+++ /dev/null
@@ -1,212 +0,0 @@
-(************************************************************************)
-(*  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: Zcomplements.v,v 1.1.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-Require ZArithRing.
-Require ZArith_base.
-Require Omega.
-Require Wf_nat.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-V7only [Set Implicit Arguments.].
-
-(**********************************************************************)
-(** About parity *)
-
-Lemma two_or_two_plus_one : (x:Z) { y:Z | `x = 2*y`}+{ y:Z | `x = 2*y+1`}. 
-Proof.
-Intro x; NewDestruct x.
-Left ; Split with ZERO; Reflexivity.
-
-NewDestruct p.
-Right ; Split with (POS p); Reflexivity.
-
-Left ; Split with (POS p); Reflexivity.
-
-Right ; Split with ZERO; Reflexivity.
-
-NewDestruct p.
-Right ; Split with (NEG (add xH p)).
-Rewrite NEG_xI.
-Rewrite NEG_add.
-Omega.
-
-Left ; Split with (NEG p); Reflexivity.
-
-Right ; Split with `-1`; Reflexivity.
-Qed.
-
-(**********************************************************************)
-(** The biggest power of 2 that is stricly less than [a]
-
-    Easy to compute: replace all "1" of the binary representation by
-    "0", except the first "1" (or the first one :-) *)
-
-Fixpoint floor_pos [a : positive] : positive :=
-  Cases a of
-  | xH => xH
-  | (xO a') => (xO (floor_pos a'))
-  | (xI b') => (xO (floor_pos b'))
-  end.
-
-Definition floor := [a:positive](POS (floor_pos a)).
-
-Lemma floor_gt0 : (x:positive) `(floor x) > 0`.
-Proof.
-Intro.
-Compute.
-Trivial.
-Qed.
-
-Lemma floor_ok : (a:positive) 
-  `(floor a) <=  (POS a) < 2*(floor a)`. 
-Proof.
-Unfold floor.
-Intro a; NewInduction a as [p|p|].
-
-Simpl.
-Repeat Rewrite POS_xI.
-Rewrite (POS_xO (xO (floor_pos p))). 
-Rewrite (POS_xO (floor_pos p)).
-Omega.
-
-Simpl.
-Repeat Rewrite POS_xI.
-Rewrite (POS_xO (xO (floor_pos p))).
-Rewrite (POS_xO (floor_pos p)).
-Rewrite (POS_xO p).
-Omega.
-
-Simpl; Omega.
-Qed.
-
-(**********************************************************************)
-(** Two more induction principles over [Z]. *)
-
-Theorem Z_lt_abs_rec : (P: Z -> Set)
-  ((n: Z) ((m: Z) `|m|<|n|` -> (P m)) -> (P n)) -> (p: Z) (P p).
-Proof.
-Intros P HP p.
-LetTac Q:=[z]`0<=z`->(P z)*(P `-z`).
-Cut (Q `|p|`);[Intros|Apply (Z_lt_rec Q);Auto with zarith].
-Elim (Zabs_dec p);Intro eq;Rewrite eq;Elim H;Auto with zarith.
-Unfold Q;Clear Q;Intros.
-Apply pair;Apply HP.
-Rewrite Zabs_eq;Auto;Intros.
-Elim (H `|m|`);Intros;Auto with zarith.
-Elim (Zabs_dec m);Intro eq;Rewrite eq;Trivial.
-Rewrite Zabs_non_eq;Auto with zarith.
-Rewrite Zopp_Zopp;Intros.
-Elim (H `|m|`);Intros;Auto with zarith.
-Elim (Zabs_dec m);Intro eq;Rewrite eq;Trivial.
-Qed.
-
-Theorem Z_lt_abs_induction : (P: Z -> Prop)
-  ((n: Z) ((m: Z) `|m|<|n|` -> (P m)) -> (P n)) -> (p: Z) (P p).
-Proof.
-Intros P HP p.
-LetTac Q:=[z]`0<=z`->(P z) /\ (P `-z`).
-Cut (Q `|p|`);[Intros|Apply (Z_lt_induction Q);Auto with zarith].
-Elim (Zabs_dec p);Intro eq;Rewrite eq;Elim H;Auto with zarith.
-Unfold Q;Clear Q;Intros.
-Split;Apply HP.
-Rewrite Zabs_eq;Auto;Intros.
-Elim (H `|m|`);Intros;Auto with zarith.
-Elim (Zabs_dec m);Intro eq;Rewrite eq;Trivial.
-Rewrite Zabs_non_eq;Auto with zarith.
-Rewrite Zopp_Zopp;Intros.
-Elim (H `|m|`);Intros;Auto with zarith.
-Elim (Zabs_dec m);Intro eq;Rewrite eq;Trivial.
-Qed.
-V7only [Unset Implicit Arguments.].
-
-(** To do case analysis over the sign of [z] *) 
-
-Lemma Zcase_sign : (x:Z)(P:Prop)
- (`x=0` -> P) ->
- (`x>0` -> P) ->
- (`x<0` -> P) -> P.
-Proof.
-Intros x P Hzero Hpos Hneg.
-Induction x.
-Apply Hzero; Trivial.
-Apply Hpos; Apply POS_gt_ZERO.
-Apply Hneg; Apply NEG_lt_ZERO.
-Save.
-
-Lemma sqr_pos : (x:Z)`x*x >= 0`.
-Proof.
-Intro x.
-Apply (Zcase_sign x `x*x >= 0`).
-Intros H; Rewrite H; Omega.
-Intros H; Replace `0` with `0*0`.
-Apply Zge_Zmult_pos_compat; Omega.
-Omega.
-Intros H; Replace `0` with `0*0`.
-Replace `x*x` with `(-x)*(-x)`.
-Apply Zge_Zmult_pos_compat; Omega.
-Ring.
-Omega.
-Save.
-
-(**********************************************************************)
-(** A list length in Z, tail recursive.  *)
-
-Require PolyList.
-
-Fixpoint Zlength_aux [acc: Z; A:Set; l:(list A)] : Z := Cases l of 
-    nil => acc
-  | (cons _ l) => (Zlength_aux (Zs acc) A l)
-end. 
-
-Definition Zlength := (Zlength_aux 0).
-Implicits Zlength [1].
-
-Section Zlength_properties.
-
-Variable A:Set.
-
-Implicit Variable Type l:(list A).
-
-Lemma Zlength_correct : (l:(list A))(Zlength l)=(inject_nat (length l)).
-Proof.
-Assert (l:(list A))(acc:Z)(Zlength_aux acc A l)=acc+(inject_nat (length l)). 
-Induction l.
-Simpl; Auto with zarith.
-Intros; Simpl (length (cons a l0)); Rewrite inj_S.
-Simpl; Rewrite H; Auto with zarith.
-Unfold Zlength; Intros; Rewrite H; Auto.
-Qed.
-
-Lemma Zlength_nil : (Zlength 1!A (nil A))=0.
-Proof.
-Auto.
-Qed.
-
-Lemma Zlength_cons : (x:A)(l:(list A))(Zlength (cons x l))=(Zs (Zlength l)).
-Proof.
-Intros; Do 2 Rewrite Zlength_correct.
-Simpl (length (cons x l)); Rewrite inj_S; Auto.
-Qed.
-
-Lemma Zlength_nil_inv : (l:(list A))(Zlength l)=0 -> l=(nil ?).
-Proof.
-Intro l; Rewrite Zlength_correct.
-Case l; Auto.
-Intros x l'; Simpl (length (cons x l')).
-Rewrite inj_S.
-Intros; ElimType False; Generalize (ZERO_le_inj (length l')); Omega.
-Qed.
-
-End Zlength_properties.
-
-Implicits Zlength_correct [1].
-Implicits Zlength_cons [1].
-Implicits Zlength_nil_inv [1].
diff --git a/theories7/ZArith/Zdiv.v b/theories7/ZArith/Zdiv.v
deleted file mode 100644
index 84d53931..00000000
--- a/theories7/ZArith/Zdiv.v
+++ /dev/null
@@ -1,432 +0,0 @@
-(************************************************************************)
-(*  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: Zdiv.v,v 1.1.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-(* Contribution by Claude Marché and Xavier Urbain *)
-
-(**
-
-Euclidean Division
-
-Defines first of function that allows Coq to normalize. 
-Then only after proves the main required property.
-
-*)
-
-Require Export ZArith_base.
-Require Zbool.
-Require Omega.
-Require ZArithRing.
-Require Zcomplements.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-(**
-
-  Euclidean division of a positive by a integer 
-  (that is supposed to be positive).
-
-  total function than returns an arbitrary value when
-  divisor is not positive
-  
-*)
-
-Fixpoint Zdiv_eucl_POS [a:positive] : Z -> Z*Z := [b:Z]
- Cases a of
- | xH => if `(Zge_bool b 2)` then `(0,1)` else `(1,0)` 
- | (xO a') => 
-    let (q,r) = (Zdiv_eucl_POS a' b) in 
-    [r':=`2*r`] if `(Zgt_bool b r')` then `(2*q,r')` else `(2*q+1,r'-b)`
- | (xI a') =>
-    let (q,r) = (Zdiv_eucl_POS a' b) in 
-    [r':=`2*r+1`] if `(Zgt_bool b r')` then `(2*q,r')` else `(2*q+1,r'-b)`
- end.
-
-
-(**
-
-  Euclidean division of integers.
- 
-  Total function than returns (0,0) when dividing by 0. 
-
-*) 
-    
-(* 
-
-  The pseudo-code is:
-  
-  if b = 0 : (0,0)
- 
-  if b <> 0 and a = 0 : (0,0)
-
-  if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in 
-                       if r = 0 then (-q,0) else (-(q+1),b-r)
-
-  if b < 0 and a < 0 : let (q,r) = div_eucl (-a) (-b) in (q,-r)
-
-  if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in 
-                       if r = 0 then (-q,0) else (-(q+1),b+r)
-
-  In other word, when b is non-zero, q is chosen to be the greatest integer 
-  smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b|.
-
-*)
-
-Definition Zdiv_eucl [a,b:Z] : Z*Z :=
-  Cases a b of
-  | ZERO _  => `(0,0)`
-  | _ ZERO  => `(0,0)`
-  | (POS a') (POS _) => (Zdiv_eucl_POS a' b)
-  | (NEG a') (POS _) => 
-      let (q,r) = (Zdiv_eucl_POS a' b) in 
-      Cases r of 
-      | ZERO => `(-q,0)`
-      | _    => `(-(q+1),b-r)`
-      end
-  | (NEG a') (NEG b') => 
-	 let (q,r) = (Zdiv_eucl_POS a' (POS b')) in `(q,-r)`
-  | (POS a') (NEG b') =>
-      let (q,r) = (Zdiv_eucl_POS a' (POS b')) in 
-      Cases r of 
-      | ZERO => `(-q,0)`
-      | _    => `(-(q+1),b+r)`
-      end
-    end.
-
-
-(** Division and modulo are projections of [Zdiv_eucl] *)
-     
-Definition Zdiv [a,b:Z] : Z := let (q,_) = (Zdiv_eucl a b) in q.
-
-Definition Zmod [a,b:Z] : Z := let (_,r) = (Zdiv_eucl a b) in r. 
-
-(* Tests:
-
-Eval Compute in `(Zdiv_eucl 7 3)`. 
-
-Eval Compute in `(Zdiv_eucl (-7) 3)`.
-
-Eval Compute in `(Zdiv_eucl 7 (-3))`.
-
-Eval Compute in `(Zdiv_eucl (-7) (-3))`.
-
-*)
-
-
-(**
-
-  Main division theorem. 
-
-  First a lemma for positive
-
-*)
-
-Lemma Z_div_mod_POS : (b:Z)`b > 0` -> (a:positive)
-  let (q,r)=(Zdiv_eucl_POS a b) in `(POS a) = b*q + r`/\`0<=r<b`.
-Proof.
-Induction a; Unfold Zdiv_eucl_POS; Fold Zdiv_eucl_POS.
-
-Intro p; Case (Zdiv_eucl_POS p b); Intros q r (H0,H1).
-Generalize (Zgt_cases b `2*r+1`).
-Case (Zgt_bool b `2*r+1`); 
-(Rewrite POS_xI; Rewrite H0; Split ; [ Ring | Omega ]).
-
-Intros p; Case (Zdiv_eucl_POS p b); Intros q r (H0,H1).
-Generalize (Zgt_cases b `2*r`).
-Case (Zgt_bool b `2*r`);
- Rewrite POS_xO; Change (POS (xO p)) with `2*(POS p)`; 
- Rewrite H0; (Split; [Ring | Omega]).
-
-Generalize (Zge_cases b `2`).
-Case (Zge_bool b `2`); (Intros; Split; [Ring | Omega ]).
-Omega.
-Qed.
-
-
-Theorem Z_div_mod : (a,b:Z)`b > 0` -> 
-  let (q,r) = (Zdiv_eucl a b) in `a = b*q + r` /\ `0<=r<b`.
-Proof.
-Intros a b; Case a; Case b; Try (Simpl; Intros; Omega).
-Unfold Zdiv_eucl; Intros; Apply Z_div_mod_POS; Trivial.
-
-Intros; Discriminate.
-
-Intros.
-Generalize (Z_div_mod_POS (POS p) H p0).
-Unfold Zdiv_eucl.
-Case (Zdiv_eucl_POS p0 (POS p)).
-Intros z z0.
-Case z0.
-
-Intros [H1 H2].
-Split; Trivial.
-Replace (NEG p0) with `-(POS p0)`; [ Rewrite H1; Ring | Trivial ].
-
-Intros p1 [H1 H2].
-Split; Trivial.
-Replace (NEG p0) with `-(POS p0)`; [ Rewrite H1; Ring | Trivial ].
-Generalize (POS_gt_ZERO p1); Omega.
-
-Intros p1 [H1 H2].
-Split; Trivial.
-Replace (NEG p0) with `-(POS p0)`; [ Rewrite H1; Ring | Trivial ].
-Generalize (NEG_lt_ZERO p1); Omega.
-
-Intros; Discriminate.
-Qed.
-
-(** Existence theorems *)
-
-Theorem Zdiv_eucl_exist : (b:Z)`b > 0` -> (a:Z)
-  { qr:Z*Z | let (q,r)=qr in `a=b*q+r` /\ `0 <= r < b` }.
-Proof.
-Intros b Hb a.
-Exists (Zdiv_eucl a b).
-Exact (Z_div_mod a b Hb).
-Qed.
-
-Implicits Zdiv_eucl_exist.
-
-Theorem Zdiv_eucl_extended : (b:Z)`b <> 0` -> (a:Z)
-  { qr:Z*Z | let (q,r)=qr in `a=b*q+r` /\ `0 <= r < |b|` }.
-Proof.
-Intros b Hb a.
-Elim (Z_le_gt_dec `0` b);Intro Hb'.
-Cut `b>0`;[Intro Hb''|Omega].
-Rewrite Zabs_eq;[Apply Zdiv_eucl_exist;Assumption|Assumption].
-Cut `-b>0`;[Intro Hb''|Omega].
-Elim (Zdiv_eucl_exist Hb'' a);Intros qr.
-Elim qr;Intros q r Hqr.
-Exists (pair ? ? `-q` r).
-Elim Hqr;Intros.
-Split.
-Rewrite <- Zmult_Zopp_left;Assumption.
-Rewrite Zabs_non_eq;[Assumption|Omega].
-Qed.
-
-Implicits Zdiv_eucl_extended.
-
-(** Auxiliary lemmas about [Zdiv] and [Zmod] *)
-
-Lemma Z_div_mod_eq : (a,b:Z)`b > 0` -> `a = b * (Zdiv a b) + (Zmod a b)`.
-Proof.
-Unfold Zdiv Zmod.
-Intros a b Hb.
-Generalize (Z_div_mod a b Hb).
-Case (Zdiv_eucl); Tauto.
-Save.
-
-Lemma Z_mod_lt : (a,b:Z)`b > 0` -> `0 <= (Zmod a b) < b`.
-Proof.
-Unfold Zmod.
-Intros a b Hb.
-Generalize (Z_div_mod a b Hb).
-Case (Zdiv_eucl a b); Tauto.
-Save.
-
-Lemma Z_div_POS_ge0 : (b:Z)(a:positive)
-  let (q,_) = (Zdiv_eucl_POS a b) in `q >= 0`.
-Proof.
-Induction a; Unfold Zdiv_eucl_POS; Fold Zdiv_eucl_POS.
-Intro p; Case (Zdiv_eucl_POS p b).
-Intros; Case (Zgt_bool b `2*z0+1`); Intros; Omega.
-Intro p; Case (Zdiv_eucl_POS p b).
-Intros; Case (Zgt_bool b `2*z0`); Intros; Omega.
-Case (Zge_bool b `2`); Simpl; Omega.
-Save.
-
-Lemma Z_div_ge0 : (a,b:Z)`b > 0` -> `a >= 0` -> `(Zdiv a b) >= 0`.
-Proof.
-Intros a b Hb; Unfold Zdiv Zdiv_eucl; Case a; Simpl; Intros.
-Case b; Simpl; Trivial.
-Generalize Hb; Case b; Try Trivial.
-Auto with zarith.
-Intros p0 Hp0; Generalize (Z_div_POS_ge0 (POS p0) p).
-Case (Zdiv_eucl_POS p (POS p0)); Simpl; Tauto.
-Intros; Discriminate.
-Elim H; Trivial.
-Save.
-
-Lemma Z_div_lt : (a,b:Z)`b >= 2` -> `a > 0` -> `(Zdiv a b) < a`.
-Proof.
-Intros. Cut `b > 0`; [Intro Hb | Omega].
-Generalize (Z_div_mod a b Hb).
-Cut `a >= 0`; [Intro Ha | Omega].
-Generalize (Z_div_ge0 a b Hb Ha).
-Unfold Zdiv; Case (Zdiv_eucl a b); Intros q r H1 [H2 H3].
-Cut `a >= 2*q` -> `q < a`; [ Intro h; Apply h; Clear h | Intros; Omega ].
-Apply Zge_trans with `b*q`.
-Omega.
-Auto with zarith.
-Save.
-
-(** Syntax *)
-
-V7only[
-Grammar znatural expr2 : constr :=
-  expr_div  [ expr2($p) "/" expr2($c) ] -> [ (Zdiv $p $c) ]
-| expr_mod  [ expr2($p) "%" expr2($c) ] -> [ (Zmod $p $c) ]
-.
-
-Syntax constr
-  level 6:
-    Zdiv [ (Zdiv $n1 $n2) ]
-      -> [ [<hov 0> "`"(ZEXPR $n1):E "/" [0 0] (ZEXPR $n2):L "`"] ]
-  | Zmod [ (Zmod $n1 $n2) ]
-      -> [ [<hov 0> "`"(ZEXPR $n1):E "%" [0 0] (ZEXPR $n2):L "`"] ]
-  | Zdiv_inside
-      [ << (ZEXPR <<(Zdiv $n1 $n2)>>) >> ]
-      	 -> [ (ZEXPR $n1):E "/" [0 0] (ZEXPR $n2):L ]
-  | Zmod_inside
-      [ << (ZEXPR <<(Zmod $n1 $n2)>>) >> ]
-      	 -> [ (ZEXPR $n1):E " %" [1 0] (ZEXPR $n2):L ]
-.
-].
-
-
-Infix 3 "/" Zdiv (no associativity) : Z_scope V8only.
-Infix 3 "mod" Zmod (no associativity) : Z_scope.
-
-(** Other lemmas (now using the syntax for [Zdiv] and [Zmod]). *)
-
-Lemma Z_div_ge : (a,b,c:Z)`c > 0`->`a >= b`->`a/c >= b/c`.
-Proof.
-Intros a b c cPos aGeb.
-Generalize (Z_div_mod_eq a c cPos).
-Generalize (Z_mod_lt a c cPos).
-Generalize (Z_div_mod_eq b c cPos).
-Generalize (Z_mod_lt b c cPos).
-Intros.
-Elim (Z_ge_lt_dec `a/c` `b/c`); Trivial.
-Intro.
-Absurd `b-a >= 1`.
-Omega.
-Rewrite -> H0.
-Rewrite -> H2.
-Assert `c*(b/c)+b % c-(c*(a/c)+a % c) = c*(b/c - a/c) + b % c - a % c`.
-Ring.
-Rewrite H3.
-Assert `c*(b/c-a/c) >= c*1`.
-Apply Zge_Zmult_pos_left.
-Omega.
-Omega.
-Assert `c*1=c`.
-Ring.
-Omega.
-Save.
-
-Lemma Z_mod_plus : (a,b,c:Z)`c > 0`->`(a+b*c) % c = a % c`.
-Proof.
-Intros a b c cPos.
-Generalize (Z_div_mod_eq a c cPos).
-Generalize (Z_mod_lt a c cPos).
-Generalize (Z_div_mod_eq `a+b*c` c cPos).
-Generalize (Z_mod_lt `a+b*c` c cPos).
-Intros.
-
-Assert `(a+b*c) % c - a % c = c*(b+a/c - (a+b*c)/c)`.
-Replace `(a+b*c) % c` with `a+b*c - c*((a+b*c)/c)`.
-Replace `a % c` with `a - c*(a/c)`.
-Ring.
-Omega.
-Omega.
-LetTac q := `b+a/c-(a+b*c)/c`.
-Apply (Zcase_sign q); Intros.
-Assert `c*q=0`.
-Rewrite H4; Ring.
-Rewrite H5 in H3.
-Omega.
-
-Assert `c*q >= c`.
-Pattern 2 c; Replace c with `c*1`.
-Apply Zge_Zmult_pos_left; Omega.
-Ring.
-Omega.
-
-Assert `c*q <= -c`.
-Replace `-c` with `c*(-1)`.
-Apply Zle_Zmult_pos_left; Omega.
-Ring.
-Omega.
-Save.
-
-Lemma Z_div_plus : (a,b,c:Z)`c > 0`->`(a+b*c)/c = a/c+b`.
-Proof.
-Intros a b c cPos.
-Generalize (Z_div_mod_eq a c cPos).
-Generalize (Z_mod_lt a c cPos).
-Generalize (Z_div_mod_eq `a+b*c` c cPos).
-Generalize (Z_mod_lt `a+b*c` c cPos).
-Intros.
-Apply Zmult_reg_left with c. Omega.
-Replace `c*((a+b*c)/c)` with `a+b*c-(a+b*c) % c`.
-Rewrite (Z_mod_plus a b c cPos).
-Pattern 1 a; Rewrite H2.
-Ring.
-Pattern 1 `a+b*c`; Rewrite H0.
-Ring.
-Save.
-
-Lemma Z_div_mult : (a,b:Z)`b > 0`->`(a*b)/b = a`.
-Intros; Replace `a*b` with `0+a*b`; Auto.
-Rewrite Z_div_plus; Auto.
-Save.
-
-Lemma Z_mult_div_ge : (a,b:Z)`b>0`->`b*(a/b) <= a`.
-Proof.
-Intros a b bPos.
-Generalize (Z_div_mod_eq `a` ? bPos); Intros.
-Generalize (Z_mod_lt `a` ? bPos); Intros.
-Pattern 2 a; Rewrite H.
-Omega.
-Save.
-
-Lemma Z_mod_same : (a:Z)`a>0`->`a % a=0`.
-Proof.
-Intros a aPos.
-Generalize (Z_mod_plus `0` `1` a aPos).
-Replace `0+1*a` with `a`.
-Intros.
-Rewrite H.
-Compute.
-Trivial.
-Ring.
-Save.
-
-Lemma Z_div_same : (a:Z)`a>0`->`a/a=1`.
-Proof.
-Intros a aPos.
-Generalize (Z_div_plus `0` `1` a aPos).
-Replace `0+1*a` with `a`.
-Intros.
-Rewrite H.
-Compute.
-Trivial.
-Ring.
-Save.
-
-Lemma Z_div_exact_1 : (a,b:Z)`b>0` -> `a = b*(a/b)` -> `a%b = 0`.
-Intros a b Hb; Generalize (Z_div_mod a b Hb); Unfold Zmod Zdiv.
-Case (Zdiv_eucl a b); Intros q r; Omega.
-Save.
-
-Lemma Z_div_exact_2 : (a,b:Z)`b>0` -> `a%b = 0` -> `a = b*(a/b)`.
-Intros a b Hb; Generalize (Z_div_mod a b Hb); Unfold Zmod Zdiv.
-Case (Zdiv_eucl a b); Intros q r; Omega.
-Save.
-
-Lemma Z_mod_zero_opp : (a,b:Z)`b>0` -> `a%b = 0` -> `(-a)%b = 0`.
-Intros a b Hb.
-Intros.
-Rewrite Z_div_exact_2 with a b; Auto.
-Replace `-(b*(a/b))` with `0+(-(a/b))*b`.
-Rewrite Z_mod_plus; Auto.
-Ring.
-Save.
-
diff --git a/theories7/ZArith/Zeven.v b/theories7/ZArith/Zeven.v
deleted file mode 100644
index 04b3ec09..00000000
--- a/theories7/ZArith/Zeven.v
+++ /dev/null
@@ -1,184 +0,0 @@
-(************************************************************************)
-(*  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: Zeven.v,v 1.1.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-Require BinInt.
-Require Zsyntax.
-
-(**********************************************************************)
-(** About parity: even and odd predicates on Z, division by 2 on Z *)
-
-(**********************************************************************)
-(** [Zeven], [Zodd], [Zdiv2] and their related properties *)
-
-Definition Zeven := 
-  [z:Z]Cases z of ZERO => True
-                | (POS (xO _)) => True
-		| (NEG (xO _)) => True
-		| _ => False
-               end.
-
-Definition Zodd := 
-  [z:Z]Cases z of (POS xH) => True
-                | (NEG xH) => True
-                | (POS (xI _)) => True
-		| (NEG (xI _)) => True
-		| _ => False
-               end.
-
-Definition Zeven_bool :=
-  [z:Z]Cases z of ZERO => true
-                | (POS (xO _)) => true
-		| (NEG (xO _)) => true
-		| _ => false
-               end.
-
-Definition Zodd_bool := 
-  [z:Z]Cases z of ZERO => false
-                | (POS (xO _)) => false
-		| (NEG (xO _)) => false
-		| _ => true
-               end.
-
-Definition Zeven_odd_dec : (z:Z) { (Zeven z) }+{ (Zodd z) }.
-Proof.
-  Intro z. Case z;
-  [ Left; Compute; Trivial
-  | Intro p; Case p; Intros; 
-    (Right; Compute; Exact I) Orelse (Left; Compute; Exact I)
-  | Intro p; Case p; Intros; 
-    (Right; Compute; Exact I) Orelse (Left; Compute; Exact I) ].
-Defined.
-
-Definition Zeven_dec : (z:Z) { (Zeven z) }+{ ~(Zeven z) }.
-Proof.
-  Intro z. Case z;
-  [ Left; Compute; Trivial
-  | Intro p; Case p; Intros; 
-    (Left; Compute; Exact I) Orelse (Right; Compute; Trivial) 
-  | Intro p; Case p; Intros; 
-    (Left; Compute; Exact I) Orelse (Right; Compute; Trivial) ].
-Defined.
-
-Definition Zodd_dec : (z:Z) { (Zodd z) }+{ ~(Zodd z) }.
-Proof.
-  Intro z. Case z;
-  [ Right; Compute; Trivial
-  | Intro p; Case p; Intros; 
-    (Left; Compute; Exact I) Orelse (Right; Compute; Trivial) 
-  | Intro p; Case p; Intros; 
-    (Left; Compute; Exact I) Orelse (Right; Compute; Trivial) ].
-Defined.
-
-Lemma Zeven_not_Zodd : (z:Z)(Zeven z) -> ~(Zodd z).
-Proof.
-  Intro z; NewDestruct z; [ Idtac | NewDestruct p | NewDestruct p  ]; Compute; Trivial.
-Qed.
-
-Lemma Zodd_not_Zeven : (z:Z)(Zodd z) -> ~(Zeven z).
-Proof.
-  Intro z; NewDestruct z; [ Idtac | NewDestruct p | NewDestruct p  ]; Compute; Trivial.
-Qed.
-
-Lemma Zeven_Sn : (z:Z)(Zodd z) -> (Zeven (Zs z)).
-Proof.
- Intro z; NewDestruct z; Unfold Zs; [ Idtac | NewDestruct p | NewDestruct p  ]; Simpl; Trivial. 
- Unfold double_moins_un; Case p; Simpl; Auto.
-Qed.
-
-Lemma Zodd_Sn : (z:Z)(Zeven z) -> (Zodd (Zs z)).
-Proof.
- Intro z; NewDestruct z; Unfold Zs; [ Idtac | NewDestruct p | NewDestruct p  ]; Simpl; Trivial. 
- Unfold double_moins_un; Case p; Simpl; Auto.
-Qed.
-
-Lemma Zeven_pred : (z:Z)(Zodd z) -> (Zeven (Zpred z)).
-Proof.
- Intro z; NewDestruct z; Unfold Zpred; [ Idtac | NewDestruct p | NewDestruct p  ]; Simpl; Trivial. 
- Unfold double_moins_un; Case p; Simpl; Auto.
-Qed.
-
-Lemma Zodd_pred : (z:Z)(Zeven z) -> (Zodd (Zpred z)).
-Proof.
- Intro z; NewDestruct z; Unfold Zpred; [ Idtac | NewDestruct p | NewDestruct p  ]; Simpl; Trivial. 
- Unfold double_moins_un; Case p; Simpl; Auto.
-Qed.
-
-Hints Unfold Zeven Zodd : zarith.
-
-(**********************************************************************)
-(** [Zdiv2] is defined on all [Z], but notice that for odd negative
-    integers it is not the euclidean quotient: in that case we have [n =
-    2*(n/2)-1] *)
-
-Definition Zdiv2 :=
-  [z:Z]Cases z of ZERO => ZERO
-                | (POS xH) => ZERO
-                | (POS p) => (POS (Zdiv2_pos p))
-		| (NEG xH) => ZERO
-		| (NEG p) => (NEG (Zdiv2_pos p))
-	       end.
-
-Lemma Zeven_div2 : (x:Z) (Zeven x) -> `x = 2*(Zdiv2 x)`.
-Proof.
-Intro x; NewDestruct x.
-Auto with arith.
-NewDestruct p; Auto with arith.
-Intros. Absurd (Zeven (POS (xI p))); Red; Auto with arith.
-Intros. Absurd (Zeven `1`); Red; Auto with arith.
-NewDestruct p; Auto with arith.
-Intros. Absurd (Zeven (NEG (xI p))); Red; Auto with arith.
-Intros. Absurd (Zeven `-1`); Red; Auto with arith.
-Qed.
-
-Lemma Zodd_div2 : (x:Z) `x >= 0` -> (Zodd x) -> `x = 2*(Zdiv2 x)+1`.
-Proof.
-Intro x; NewDestruct x.
-Intros. Absurd (Zodd `0`); Red; Auto with arith.
-NewDestruct p; Auto with arith.
-Intros. Absurd (Zodd (POS (xO p))); Red; Auto with arith.
-Intros. Absurd `(NEG p) >= 0`; Red; Auto with arith.
-Qed.
-
-Lemma Zodd_div2_neg : (x:Z) `x <= 0` -> (Zodd x) -> `x = 2*(Zdiv2 x)-1`.
-Proof.
-Intro x; NewDestruct x.
-Intros. Absurd (Zodd `0`); Red; Auto with arith.
-Intros. Absurd `(NEG p) >= 0`; Red; Auto with arith.
-NewDestruct p; Auto with arith.
-Intros. Absurd (Zodd (NEG (xO p))); Red; Auto with arith.
-Qed.
-
-Lemma Z_modulo_2 : (x:Z) { y:Z | `x=2*y` }+{ y:Z | `x=2*y+1` }.
-Proof.
-Intros x.
-Elim (Zeven_odd_dec x); Intro.
-Left. Split with (Zdiv2 x). Exact (Zeven_div2 x a).
-Right. Generalize b; Clear b; Case x.
-Intro b; Inversion b.
-Intro p; Split with (Zdiv2 (POS p)). Apply (Zodd_div2 (POS p)); Trivial.
-Unfold Zge Zcompare; Simpl; Discriminate.
-Intro p; Split with (Zdiv2 (Zpred (NEG p))).
-Pattern 1 (NEG p); Rewrite (Zs_pred (NEG p)).
-Pattern 1 (Zpred (NEG p)); Rewrite (Zeven_div2 (Zpred (NEG p))).
-Reflexivity.
-Apply Zeven_pred; Assumption.
-Qed.
-
-Lemma Zsplit2 :  (x:Z) { p : Z*Z | let (x1,x2)=p in (`x=x1+x2` /\ (x1=x2 \/ `x2=x1+1`)) }.
-Proof.
-Intros x.
-Elim (Z_modulo_2 x); Intros (y,Hy); Rewrite Zmult_sym in Hy; Rewrite <- Zplus_Zmult_2 in Hy.
-Exists (y,y); Split. 
-Assumption.
-Left; Reflexivity.
-Exists (y,`y+1`); Split.
-Rewrite Zplus_assoc; Assumption.
-Right; Reflexivity.
-Qed.
diff --git a/theories7/ZArith/Zhints.v b/theories7/ZArith/Zhints.v
deleted file mode 100644
index 01860d18..00000000
--- a/theories7/ZArith/Zhints.v
+++ /dev/null
@@ -1,387 +0,0 @@
-(************************************************************************)
-(*  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: Zhints.v,v 1.1.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-(** This file centralizes the lemmas about [Z], classifying them
-    according to the way they can be used in automatic search  *)
-
-(*i*)
-
-(* Lemmas which clearly leads to simplification during proof search are *)
-(* declared as Hints. A definite status (Hint or not) for the other lemmas *)
-(* remains to be given *)
-
-(* Structure of the file *)
-(* - simplification lemmas (only those are declared as Hints) *)
-(* - reversible lemmas relating operators *)
-(* - useful Bottom-up lemmas              *)
-(* - irreversible lemmas with meta-variables *)
-(* - unclear or too specific lemmas       *)
-(* - lemmas to be used as rewrite rules   *)
-
-(* Lemmas involving positive and compare are not taken into account *)
-
-Require BinInt.
-Require Zorder.
-Require Zmin.
-Require Zabs.
-Require Zcompare.
-Require Znat.
-Require auxiliary.
-Require Zsyntax.
-Require Zmisc.
-Require Wf_Z.
-
-(**********************************************************************)
-(*                  Simplification lemmas                             *)
-(* No subgoal or smaller subgoals                                     *)
-
-Hints Resolve
-  (* A) Reversible simplification lemmas (no loss of information)      *)
-  (* Should clearly declared as hints                                  *)
-  
-  (* Lemmas ending by eq *)
-  Zeq_S (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *)
-  
-  (* Lemmas ending by Zgt *)
-  Zgt_n_S (* :(n,m:Z)`m > n`->`(Zs m) > (Zs n)` *)
-  Zgt_Sn_n (* :(n:Z)`(Zs n) > n` *)
-  POS_gt_ZERO (* :(p:positive)`(POS p) > 0` *)
-  Zgt_reg_l (* :(n,m,p:Z)`n > m`->`p+n > p+m` *)
-  Zgt_reg_r (* :(n,m,p:Z)`n > m`->`n+p > m+p` *)
-  
-  (* Lemmas ending by Zlt *)
-  Zlt_n_Sn (* :(n:Z)`n < (Zs n)` *)
-  Zlt_n_S (* :(n,m:Z)`n < m`->`(Zs n) < (Zs m)` *)
-  Zlt_pred_n_n (* :(n:Z)`(Zpred n) < n` *)
-  Zlt_reg_l (* :(n,m,p:Z)`n < m`->`p+n < p+m` *)
-  Zlt_reg_r (* :(n,m,p:Z)`n < m`->`n+p < m+p` *)
-  
-  (* Lemmas ending by Zle *)
-  ZERO_le_inj (* :(n:nat)`0 <= (inject_nat n)` *)
-  ZERO_le_POS (* :(p:positive)`0 <= (POS p)` *)
-  Zle_n (* :(n:Z)`n <= n` *)
-  Zle_n_Sn (* :(n:Z)`n <= (Zs n)` *)
-  Zle_n_S (* :(n,m:Z)`m <= n`->`(Zs m) <= (Zs n)` *)
-  Zle_pred_n (* :(n:Z)`(Zpred n) <= n` *)
-  Zle_min_l (* :(n,m:Z)`(Zmin n m) <= n` *)
-  Zle_min_r (* :(n,m:Z)`(Zmin n m) <= m` *)
-  Zle_reg_l (* :(n,m,p:Z)`n <= m`->`p+n <= p+m` *)
-  Zle_reg_r (* :(a,b,c:Z)`a <= b`->`a+c <= b+c` *)
-  Zabs_pos (* :(x:Z)`0 <= |x|` *)
-  
-  (* B) Irreversible simplification lemmas : Probably to be declared as *)
-  (* hints, when no other simplification is possible *)
-  
-  (* Lemmas ending by eq *)
-  Z_eq_mult (* :(x,y:Z)`y = 0`->`y*x = 0` *)
-  Zplus_simpl (* :(n,m,p,q:Z)`n = m`->`p = q`->`n+p = m+q` *)
-  
-  (* Lemmas ending by Zge *)
-  Zge_Zmult_pos_right (* :(a,b,c:Z)`a >= b`->`c >= 0`->`a*c >= b*c` *)
-  Zge_Zmult_pos_left (* :(a,b,c:Z)`a >= b`->`c >= 0`->`c*a >= c*b` *)
-  Zge_Zmult_pos_compat (* :
-    (a,b,c,d:Z)`a >= c`->`b >= d`->`c >= 0`->`d >= 0`->`a*b >= c*d` *)
-  
-  (* Lemmas ending by Zlt *)
-  Zgt_ZERO_mult (* :(a,b:Z)`a > 0`->`b > 0`->`a*b > 0` *)
-  Zlt_S (* :(n,m:Z)`n < m`->`n < (Zs m)` *)
-  
-  (* Lemmas ending by Zle *)
-  Zle_ZERO_mult (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x*y` *)
-  Zle_Zmult_pos_right (* :(a,b,c:Z)`a <= b`->`0 <= c`->`a*c <= b*c` *)
-  Zle_Zmult_pos_left (* :(a,b,c:Z)`a <= b`->`0 <= c`->`c*a <= c*b` *)
-  OMEGA2 (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x+y` *)
-  Zle_le_S (* :(x,y:Z)`x <= y`->`x <= (Zs y)` *)
-  Zle_plus_plus (* :(n,m,p,q:Z)`n <= m`->`p <= q`->`n+p <= m+q` *)
-
-: zarith.
-  
-(**********************************************************************)
-(*         Reversible lemmas relating operators                       *)
-(* Probably to be declared as hints but need to define precedences    *)
-
-(* A) Conversion between comparisons/predicates and arithmetic operators
-
-(* Lemmas ending by eq *)
-Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0`
-Zabs_eq: (x:Z)`0 <= x`->`|x| = x`
-Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)`
-Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1`
-
-(* Lemmas ending by Zgt *)
-Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y`
-Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0`
-
-(* Lemmas ending by Zlt *)
-Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y`
-Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)`
-Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n`
-
-(* Lemmas ending by Zle *)
-Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)`
-Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y`
-Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)`
-Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)`
-Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)`
-
-(* B) Conversion between nat comparisons and Z comparisons *)
-
-(* Lemmas ending by eq *)
-inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)`
-
-(* Lemmas ending by Zge *)
-inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)`
-
-(* Lemmas ending by Zgt *)
-inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)`
-
-(* Lemmas ending by Zlt *)
-inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)`
-
-(* Lemmas ending by Zle *)
-inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)`
-
-(* C) Conversion between comparisons *)
-
-(* Lemmas ending by Zge *)
-not_Zlt: (x,y:Z)~`x < y`->`x >= y`
-Zle_ge: (m,n:Z)`m <= n`->`n >= m`
-
-(* Lemmas ending by Zgt *)
-Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n`
-not_Zle: (x,y:Z)~`x <= y`->`x > y`
-Zlt_gt: (m,n:Z)`m < n`->`n > m`
-Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n`
-
-(* Lemmas ending by Zlt *)
-not_Zge: (x,y:Z)~`x >= y`->`x < y`
-Zgt_lt: (m,n:Z)`m > n`->`n < m`
-Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)`
-
-(* Lemmas ending by Zle *)
-Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)`
-not_Zgt: (x,y:Z)~`x > y`->`x <= y`
-Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p`
-Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p`
-Zge_le: (m,n:Z)`m >= n`->`n <= m`
-Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p`
-Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m`
-Zlt_le_weak: (n,m:Z)`n < m`->`n <= m`
-Zle_refl: (n,m:Z)`n = m`->`n <= m`
-
-(* D) Irreversible simplification involving several comparaisons, *)
-(*    useful with clear precedences *)
-
-(* Lemmas ending by Zlt *)
-Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d`
-Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d`
-
-(* D) What is decreasing here ? *)
-
-(* Lemmas ending by eq *)
-Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m`
-
-(* Lemmas ending by Zgt *)
-Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n`
-
-(* Lemmas ending by Zlt *)
-Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)`
-
-*)
-
-(**********************************************************************)
-(*                 Useful Bottom-up lemmas                            *)
-
-(* A) Bottom-up simplification: should be used 
-
-(* Lemmas ending by eq *)
-Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m`
-Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p`
-Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m`
-Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m`
-
-(* Lemmas ending by Zgt *)
-Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m`
-Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m`
-Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n`
-
-(* Lemmas ending by Zlt *)
-Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m`
-Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m`
-Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m`
-
-(* Lemmas ending by Zle *)
-Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m`
-Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m`
-Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n`
-
-(* B) Bottom-up irreversible (syntactic) simplification *)
-
-(* Lemmas ending by Zle *)
-Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m`
-
-(* C) Other unclearly simplifying lemmas *)
-
-(* Lemmas ending by Zeq *)
-Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0`
-
-(* Lemmas ending by Zgt *)
-Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0`
-
-(* Lemmas ending by Zlt *)
-pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y`
-
-(* Lemmas ending by Zle *)
-Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y`
-OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y`
-*)
-
-(**********************************************************************)
-(*           Irreversible lemmas with meta-variables                  *)
-(* To be used by EAuto                                                
-
-Hints Immediate
-(* Lemmas ending by eq *)
-Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m`
-
-(* Lemmas ending by Zge *)
-Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p`
-
-(* Lemmas ending by Zgt *)
-Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p`
-Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p`
-Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p`
-Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p`
-
-(* Lemmas ending by Zlt *)
-Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p`
-Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p`
-Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p`
-
-(* Lemmas ending by Zle *)
-Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p`
-*)
-
-(**********************************************************************)
-(*               Unclear or too specific lemmas                       *)
-(* Not to be used ??                                                  *)
-
-(* A) Irreversible and too specific (not enough regular) 
-
-(* Lemmas ending by Zle *)
-Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x`
-Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z`
-OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z`
-OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t`
-
-
-(* B) Expansion and too specific ? *)
-
-(* Lemmas ending by Zge *)
-Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b`
-
-(* Lemmas ending by Zgt *)
-Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b`
-Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y`
-
-(* Lemmas ending by Zle *)
-Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b`
-Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y`
-
-(* C) Reversible but too specific ? *)
-
-(* Lemmas ending by Zlt *)
-Zlt_minus: (n,m:Z)`0 < m`->`n-m < n`
-*)
-
-(**********************************************************************)
-(*               Lemmas to be used as rewrite rules                   *)
-(* but can also be used as hints                                      
-
-(* Left-to-right simplification lemmas (a symbol disappears) *)
-
-Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m)
-Zmin_n_n: (n:Z)`(Zmin n n) = n`
-Zmult_1_n: (n:Z)`1*n = n`
-Zmult_n_1: (n:Z)`n*1 = n`
-Zminus_plus: (n,m:Z)`n+m-n = m`
-Zle_plus_minus: (n,m:Z)`n+(m-n) = m`
-Zopp_Zopp: (x:Z)`(-(-x)) = x`
-Zero_left: (x:Z)`0+x = x`
-Zero_right: (x:Z)`x+0 = x`
-Zplus_inverse_r: (x:Z)`x+(-x) = 0`
-Zplus_inverse_l: (x:Z)`(-x)+x = 0`
-Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y`
-Zmult_one: (x:Z)`1*x = x`
-Zero_mult_left: (x:Z)`0*x = 0`
-Zero_mult_right: (x:Z)`x*0 = 0`
-Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y`
-
-(* Right-to-left simplification lemmas (a symbol disappears) *)
-
-Zpred_Sn: (m:Z)`m = (Zpred (Zs m))`
-Zs_pred: (n:Z)`n = (Zs (Zpred n))`
-Zplus_n_O: (n:Z)`n = n+0`
-Zmult_n_O: (n:Z)`0 = n*0`
-Zminus_n_O: (n:Z)`n = n-0`
-Zminus_n_n: (n:Z)`0 = n-n`
-Zred_factor6: (x:Z)`x = x+0`
-Zred_factor0: (x:Z)`x = x*1`
-
-(* Unclear orientation (no symbol disappears) *)
-
-Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)`
-Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)`
-Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))`
-Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p`
-Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)`
-Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)`
-Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)`
-Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)`
-Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m`
-Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p`
-Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p`
-Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)`
-Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p`
-Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)`
-Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m`
-Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z`
-Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p`
-Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)`
-Zplus_sym: (x,y:Z)`x+y = y+x`
-Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z`
-Zmult_sym: (x,y:Z)`x*y = y*x`
-Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z`
-Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))`
-Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))`
-Zopp_one: (x:Z)`(-x) = x*(-1)`
-Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)`
-Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)`
-Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y`
-Zred_factor1: (x:Z)`x+x = x*2`
-Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)`
-Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)`
-Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)`
-Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y`
-Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n`
-
-(* nat <-> Z *)
-inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))`
-inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)`
-inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)`
-inj_minus1:
- (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)`
-inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0`
-
-(* Too specific ? *)
-Zred_factor5: (x,y:Z)`x*0+y = y`
-*)
-
-(*i*)
diff --git a/theories7/ZArith/Zlogarithm.v b/theories7/ZArith/Zlogarithm.v
deleted file mode 100644
index dc850738..00000000
--- a/theories7/ZArith/Zlogarithm.v
+++ /dev/null
@@ -1,272 +0,0 @@
-(************************************************************************)
-(*  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: Zlogarithm.v,v 1.1.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-(**********************************************************************)
-(** The integer logarithms with base 2. 
-
-    There are three logarithms,
-    depending on the rounding of the real 2-based logarithm:
-    - [Log_inf]: [y = (Log_inf x) iff 2^y <= x < 2^(y+1)]
-      i.e. [Log_inf x] is the biggest integer that is smaller than [Log x]
-    - [Log_sup]: [y = (Log_sup x) iff 2^(y-1) < x <= 2^y]
-      i.e. [Log_inf x] is the smallest integer that is bigger than [Log x]
-    - [Log_nearest]: [y= (Log_nearest x) iff 2^(y-1/2) < x <= 2^(y+1/2)]
-      i.e. [Log_nearest x] is the integer nearest from [Log x] *)
-
-Require ZArith_base.
-Require Omega.
-Require Zcomplements.
-Require Zpower.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-Section Log_pos. (* Log of positive integers *)
-
-(** First we build [log_inf] and [log_sup] *)
-
-Fixpoint log_inf [p:positive] : Z :=  
-  Cases p of
-    xH => `0`	 				(* 1 *)
-  | (xO q) => (Zs (log_inf q))		(* 2n *)
-  | (xI q) => (Zs (log_inf q))		(* 2n+1 *)
-  end.
-Fixpoint log_sup [p:positive] : Z :=
-  Cases p of
-    xH => `0`					(* 1 *)
-  | (xO n) => (Zs (log_sup n)) 		(* 2n *)
-  | (xI n) => (Zs (Zs (log_inf n)))		(* 2n+1 *)
-  end.
-
-Hints Unfold log_inf log_sup.
-
-(** Then we give the specifications of [log_inf] and [log_sup] 
-    and prove their validity *)
-
-(*i Hints Resolve ZERO_le_S : zarith. i*)
-Hints Resolve Zle_trans : zarith.
-
-Theorem log_inf_correct : (x:positive) ` 0 <= (log_inf x)` /\
-  ` (two_p (log_inf x)) <= (POS x) < (two_p (Zs (log_inf x)))`.
-Induction x; Intros; Simpl;
-[ Elim H; Intros Hp HR; Clear H; Split;
-  [ Auto with zarith
-  | Conditional (Apply Zle_le_S; Trivial) Rewrite two_p_S with x:=(Zs (log_inf p));
-    Conditional Trivial Rewrite two_p_S;
-    Conditional Trivial Rewrite two_p_S in HR;
-    Rewrite (POS_xI p); Omega ]
-| Elim H; Intros Hp HR; Clear H; Split;
-  [ Auto with zarith
-  | Conditional (Apply Zle_le_S; Trivial) Rewrite two_p_S with x:=(Zs (log_inf p));
-    Conditional Trivial Rewrite two_p_S;
-    Conditional Trivial Rewrite two_p_S in HR;
-    Rewrite (POS_xO p); Omega ]
-| Unfold two_power_pos; Unfold shift_pos; Simpl; Omega 
-].
-Qed.
-
-Definition log_inf_correct1 :=
-	[p:positive](proj1 ? ? (log_inf_correct p)).
-Definition log_inf_correct2 := 
-	[p:positive](proj2 ? ? (log_inf_correct p)).
-
-Opaque log_inf_correct1 log_inf_correct2.
-
-Hints Resolve log_inf_correct1 log_inf_correct2 : zarith.
-
-Lemma log_sup_correct1 : (p:positive)` 0 <= (log_sup p)`.
-Induction p; Intros; Simpl; Auto with zarith.
-Qed.
-
-(** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)]
-    either [(log_sup p)=(log_inf p)+1] *)
-
-Theorem log_sup_log_inf : (p:positive)
-  IF (POS p)=(two_p (log_inf p)) 
-  then (POS p)=(two_p (log_sup p))
-  else ` (log_sup p)=(Zs (log_inf p))`.
-
-Induction p; Intros;
-[ Elim H; Right; Simpl;
-  Rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-  Rewrite POS_xI; Unfold Zs; Omega
-| Elim H; Clear H; Intro Hif;
-  [ Left; Simpl;
-    Rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-    Rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0));
-    Rewrite <- (proj1 ? ? Hif); Rewrite <- (proj2 ? ? Hif);
-    Auto
-  | Right; Simpl;
-    Rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-    Rewrite POS_xO; Unfold Zs; Omega ]
-| Left; Auto ].
-Qed.
-
-Theorem log_sup_correct2 : (x:positive)
-  ` (two_p (Zpred (log_sup x))) < (POS x) <= (two_p (log_sup x))`.
-
-Intro.
-Elim (log_sup_log_inf x).
-(* x is a power of two and [log_sup = log_inf] *)
-Intros (E1,E2); Rewrite E2.
-Split ; [ Apply two_p_pred; Apply log_sup_correct1 | Apply Zle_n ].
-Intros (E1,E2); Rewrite E2.
-Rewrite <- (Zpred_Sn (log_inf x)).
-Generalize (log_inf_correct2 x); Omega.
-Qed.
-
-Lemma log_inf_le_log_sup : 
-	(p:positive) `(log_inf p) <= (log_sup p)`.
-Induction p; Simpl; Intros; Omega.
-Qed.
-
-Lemma log_sup_le_Slog_inf : 
-	(p:positive) `(log_sup p) <= (Zs (log_inf p))`.
-Induction p; Simpl; Intros; Omega.
-Qed.
-
-(** Now it's possible to specify and build the [Log] rounded to the nearest *)
-
-Fixpoint log_near[x:positive] : Z :=
-  Cases x of 
-    xH => `0`
-  | (xO xH) => `1`
-  | (xI xH) => `2`
-  | (xO y)  => (Zs (log_near y))
-  | (xI y)  => (Zs (log_near y))
-  end.    
-
-Theorem log_near_correct1 : (p:positive)` 0 <= (log_near p)`.
-Induction p; Simpl; Intros; 
-[Elim p0; Auto with zarith | Elim p0; Auto with zarith | Trivial with zarith ].
-Intros; Apply Zle_le_S.
-Generalize H0; Elim p1; Intros; Simpl;
-    [ Assumption | Assumption | Apply ZERO_le_POS ].
-Intros; Apply Zle_le_S.
-Generalize H0; Elim p1; Intros; Simpl;
-    [ Assumption | Assumption | Apply ZERO_le_POS ].
-Qed.
-
-Theorem log_near_correct2: (p:positive)
-  (log_near p)=(log_inf p)
-\/(log_near p)=(log_sup p).
-Induction p.
-Intros p0 [Einf|Esup].
-Simpl. Rewrite Einf.
-Case p0; [Left | Left | Right]; Reflexivity.
-Simpl; Rewrite Esup.
-Elim (log_sup_log_inf p0).
-Generalize (log_inf_le_log_sup p0).
-Generalize (log_sup_le_Slog_inf p0).
-Case p0; Auto with zarith.
-Intros; Omega.
-Case p0; Intros; Auto with zarith.
-Intros p0 [Einf|Esup].
-Simpl.
-Repeat Rewrite Einf.
-Case p0; Intros; Auto with zarith.
-Simpl.
-Repeat Rewrite Esup.
-Case p0; Intros; Auto with zarith.
-Auto.
-Qed.
-
-(*i******************
-Theorem log_near_correct: (p:positive)
-  `| (two_p (log_near p)) - (POS p) | <= (POS p)-(two_p (log_inf p))`
-  /\`| (two_p (log_near p)) - (POS p) | <= (two_p (log_sup p))-(POS p)`.
-Intro.
-Induction p.
-Intros p0 [(Einf1,Einf2)|(Esup1,Esup2)].
-Unfold log_near log_inf log_sup. Fold log_near log_inf log_sup.
-Rewrite Einf1.
-Repeat Rewrite two_p_S.
-Case p0; [Left | Left | Right].
-
-Split.
-Simpl.
-Rewrite E1; Case p0; Try Reflexivity.
-Compute.
-Unfold log_near; Fold log_near.
-Unfold log_inf; Fold log_inf.
-Repeat Rewrite E1.
-Split.
-**********************************i*)
-
-End Log_pos.
-
-Section divers.
-
-(** Number of significative digits. *)
-
-Definition N_digits :=
-  [x:Z]Cases x of 
-       	  (POS p) => (log_inf p)
-        | (NEG p) => (log_inf p)
-	|  ZERO   => `0`
-       end.
-
-Lemma ZERO_le_N_digits : (x:Z) ` 0 <= (N_digits x)`.
-Induction x; Simpl;
-[ Apply Zle_n
-| Exact log_inf_correct1
-| Exact log_inf_correct1].
-Qed.
-
-Lemma log_inf_shift_nat : 
-  (n:nat)(log_inf (shift_nat n xH))=(inject_nat n).
-Induction n; Intros;
-[ Try Trivial
-| Rewrite -> inj_S; Rewrite <- H; Reflexivity].
-Qed.
-
-Lemma log_sup_shift_nat : 
-  (n:nat)(log_sup (shift_nat n xH))=(inject_nat n).
-Induction n; Intros;
-[ Try Trivial
-| Rewrite -> inj_S; Rewrite <- H; Reflexivity].
-Qed.
-
-(** [Is_power p] means that p is a power of two *)
-Fixpoint Is_power[p:positive] : Prop :=
-  Cases p of
-    xH => True
-  | (xO q) => (Is_power q)
-  | (xI q) => False
-  end.
-
-Lemma Is_power_correct :
-  (p:positive) (Is_power p) <-> (Ex [y:nat](p=(shift_nat y xH))).
-
-Split; 
-[ Elim p; 
-   [ Simpl; Tauto
-   | Simpl; Intros; Generalize (H H0); Intro H1; Elim H1; Intros y0 Hy0;
-     Exists (S y0); Rewrite Hy0; Reflexivity
-   | Intro; Exists O; Reflexivity]
-| Intros; Elim H; Intros; Rewrite -> H0; Elim x; Intros; Simpl; Trivial].
-Qed.
-
-Lemma Is_power_or : (p:positive) (Is_power p)\/~(Is_power p).
-Induction p;
-[ Intros; Right; Simpl; Tauto
-| Intros; Elim H; 
-   [ Intros; Left; Simpl; Exact H0
-   | Intros; Right; Simpl; Exact H0]
-| Left; Simpl; Trivial].
-Qed.
-
-End divers.
-
-
-
-
-
-
-
diff --git a/theories7/ZArith/Zmin.v b/theories7/ZArith/Zmin.v
deleted file mode 100644
index 753fe461..00000000
--- a/theories7/ZArith/Zmin.v
+++ /dev/null
@@ -1,102 +0,0 @@
-(************************************************************************)
-(*  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: Zmin.v,v 1.1.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
-
-Require Arith.
-Require BinInt.
-Require Zcompare.
-Require Zorder.
-
-Open Local Scope Z_scope.
-
-(**********************************************************************)
-(** Minimum on binary integer numbers *)
-
-Definition Zmin := [n,m:Z]
- <Z>Cases (Zcompare n m) of
-      EGAL      => n
-    | INFERIEUR => n
-    | SUPERIEUR => m
-    end.
-
-(** Properties of minimum on binary integer numbers *)
-
-Lemma Zmin_SS : (n,m:Z)((Zs (Zmin n m))=(Zmin (Zs n) (Zs m))).
-Proof.
-Intros n m;Unfold Zmin; Rewrite (Zcompare_n_S n m);
-(ElimCompare 'n 'm);Intros E;Rewrite E;Auto with arith.
-Qed.
-
-Lemma Zle_min_l : (n,m:Z)(Zle (Zmin n m) n).
-Proof.
-Intros n m;Unfold Zmin ; (ElimCompare 'n 'm);Intros E;Rewrite -> E;
-  [ Apply Zle_n | Apply Zle_n | Apply Zlt_le_weak; Apply Zgt_lt;Exact E ].
-Qed.
-
-Lemma Zle_min_r : (n,m:Z)(Zle (Zmin n m) m).
-Proof.
-Intros n m;Unfold Zmin ; (ElimCompare 'n 'm);Intros E;Rewrite -> E;[
-  Unfold Zle ;Rewrite -> E;Discriminate
-| Unfold Zle ;Rewrite -> E;Discriminate
-| Apply Zle_n ].
-Qed.
-
-Lemma Zmin_case : (n,m:Z)(P:Z->Set)(P n)->(P m)->(P (Zmin n m)).
-Proof.
-Intros n m P H1 H2; Unfold Zmin; Case (Zcompare n m);Auto with arith.
-Qed.
-
-Lemma Zmin_or : (n,m:Z)(Zmin n m)=n \/ (Zmin n m)=m.
-Proof.
-Unfold Zmin; Intros; Elim (Zcompare n m); Auto.
-Qed.
-
-Lemma Zmin_n_n : (n:Z) (Zmin n n)=n.
-Proof.
-Unfold Zmin; Intros; Elim (Zcompare n n); Auto.
-Qed.
-
-Lemma Zmin_plus :
- (x,y,n:Z)(Zmin (Zplus x n) (Zplus y n))=(Zplus (Zmin x y) n).
-Proof.
-Intros x y n; Unfold Zmin.
-Rewrite (Zplus_sym x n);
-Rewrite (Zplus_sym y n);
-Rewrite (Zcompare_Zplus_compatible x y n).
-Case (Zcompare x y); Apply Zplus_sym.
-Qed.
-
-(**********************************************************************)
-(** Maximum of two binary integer numbers *)
-V7only [ (* From Zdivides *) ].
-
-Definition Zmax :=
-   [a, b : ?]  Cases (Zcompare a b) of INFERIEUR => b | _ => a end.
-
-(** Properties of maximum on binary integer numbers *)
-
-Tactic Definition CaseEq name :=
-Generalize (refl_equal ? name); Pattern -1 name; Case name.
-
-Theorem Zmax1: (a, b : ?)  (Zle a (Zmax a b)).
-Proof.
-Intros a b; Unfold Zmax; (CaseEq '(Zcompare a b)); Simpl; Auto with zarith.
-Unfold Zle; Intros H; Rewrite H; Red; Intros; Discriminate.
-Qed.
-
-Theorem Zmax2: (a, b : ?)  (Zle b (Zmax a b)).
-Proof.
-Intros a b; Unfold Zmax; (CaseEq '(Zcompare a b)); Simpl; Auto with zarith.
-Intros H;
- (Case (Zle_or_lt b a); Auto; Unfold Zlt; Rewrite H; Intros; Discriminate).
-Intros H;
- (Case (Zle_or_lt b a); Auto; Unfold Zlt; Rewrite H; Intros; Discriminate).
-Qed.
-
diff --git a/theories7/ZArith/Zmisc.v b/theories7/ZArith/Zmisc.v
deleted file mode 100644
index bd89ec66..00000000
--- a/theories7/ZArith/Zmisc.v
+++ /dev/null
@@ -1,188 +0,0 @@
-(************************************************************************)
-(*  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: Zmisc.v,v 1.1.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-Require BinInt.
-Require Zcompare.
-Require Zorder.
-Require Zsyntax.
-Require Bool.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-(**********************************************************************)
-(** Iterators *)
-
-(** [n]th iteration of the function [f] *)
-Fixpoint iter_nat[n:nat]  : (A:Set)(f:A->A)A->A :=
-  [A:Set][f:A->A][x:A]
-    Cases n of
-      O => x
-    | (S n') => (f (iter_nat n' A f x))
-    end.
-
-Fixpoint iter_pos[n:positive] : (A:Set)(f:A->A)A->A :=
-  [A:Set][f:A->A][x:A]
-    Cases n of
-     	xH => (f x)
-      | (xO n') => (iter_pos n' A f (iter_pos n' A f x))
-      | (xI n') => (f (iter_pos n' A f (iter_pos n' A f x)))
-    end.
-
-Definition iter :=
-  [n:Z][A:Set][f:A->A][x:A]Cases n of
-    ZERO => x
-  | (POS p) => (iter_pos p A f x)
-  | (NEG p) => x
-  end.
-
-Theorem iter_nat_plus :
-  (n,m:nat)(A:Set)(f:A->A)(x:A)
-    (iter_nat (plus n m) A f x)=(iter_nat n A f (iter_nat m A f x)).
-Proof.    
-Induction n;
-[ Simpl; Auto with arith
-| Intros; Simpl; Apply f_equal with f:=f; Apply H
-].  
-Qed.
-
-Theorem iter_convert : (n:positive)(A:Set)(f:A->A)(x:A)
-  (iter_pos n A f x) = (iter_nat (convert n) A f x).
-Proof.    
-Intro n; NewInduction n as [p H|p H|];
-[ Intros; Simpl; Rewrite -> (H A f x);
-  Rewrite -> (H A f (iter_nat (convert p) A f x));
-  Rewrite -> (ZL6 p); Symmetry; Apply f_equal with f:=f;
-  Apply iter_nat_plus
-| Intros; Unfold convert; Simpl; Rewrite -> (H A f x);
-  Rewrite -> (H A f (iter_nat (convert p) A f x));
-  Rewrite -> (ZL6 p); Symmetry;
-  Apply iter_nat_plus
-| Simpl; Auto with arith
-].
-Qed.
-
-Theorem iter_pos_add :
-  (n,m:positive)(A:Set)(f:A->A)(x:A)
-    (iter_pos (add n m) A f x)=(iter_pos n A f (iter_pos m A f x)).
-Proof.    
-Intros n m; Intros.
-Rewrite -> (iter_convert m A f x).
-Rewrite -> (iter_convert n A f (iter_nat (convert m) A f x)).
-Rewrite -> (iter_convert (add n m) A f x).
-Rewrite -> (convert_add n m).
-Apply iter_nat_plus.
-Qed.
-
-(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], 
-    then the iterates of [f] also preserve it. *)
-
-Theorem iter_nat_invariant :
-  (n:nat)(A:Set)(f:A->A)(Inv:A->Prop)
-  ((x:A)(Inv x)->(Inv (f x)))->(x:A)(Inv x)->(Inv (iter_nat n A f x)).
-Proof.    
-Induction n; Intros;
-[ Trivial with arith
-| Simpl; Apply H0 with x:=(iter_nat n0 A f x); Apply H; Trivial with arith].
-Qed.
-
-Theorem iter_pos_invariant :
-  (n:positive)(A:Set)(f:A->A)(Inv:A->Prop)
-  ((x:A)(Inv x)->(Inv (f x)))->(x:A)(Inv x)->(Inv (iter_pos n A f x)).
-Proof.    
-Intros; Rewrite iter_convert; Apply iter_nat_invariant; Trivial with arith.
-Qed.
-
-V7only [
-(* Compatibility *)
-Require Zbool.
-Require Zeven.
-Require Zabs.
-Require Zmin.
-Notation rename := rename.
-Notation POS_xI := POS_xI.
-Notation POS_xO := POS_xO.
-Notation NEG_xI := NEG_xI.
-Notation NEG_xO := NEG_xO.
-Notation POS_add := POS_add.
-Notation NEG_add := NEG_add.
-Notation Zle_cases := Zle_cases.
-Notation Zlt_cases := Zlt_cases.
-Notation Zge_cases := Zge_cases.
-Notation Zgt_cases := Zgt_cases.
-Notation POS_gt_ZERO := POS_gt_ZERO.
-Notation ZERO_le_POS := ZERO_le_POS.
-Notation Zlt_ZERO_pred_le_ZERO := Zlt_ZERO_pred_le_ZERO.
-Notation NEG_lt_ZERO := NEG_lt_ZERO.
-Notation Zeven_not_Zodd := Zeven_not_Zodd.
-Notation Zodd_not_Zeven := Zodd_not_Zeven.
-Notation Zeven_Sn := Zeven_Sn.
-Notation Zodd_Sn := Zodd_Sn.
-Notation Zeven_pred := Zeven_pred.
-Notation Zodd_pred := Zodd_pred.
-Notation Zeven_div2 := Zeven_div2.
-Notation Zodd_div2 := Zodd_div2.
-Notation Zodd_div2_neg := Zodd_div2_neg.
-Notation Z_modulo_2 := Z_modulo_2.
-Notation Zsplit2 := Zsplit2.
-Notation Zminus_Zplus_compatible := Zminus_Zplus_compatible.
-Notation Zcompare_egal_dec := Zcompare_egal_dec.
-Notation Zcompare_elim := Zcompare_elim.
-Notation Zcompare_x_x := Zcompare_x_x.
-Notation Zlt_not_eq := Zlt_not_eq.
-Notation Zcompare_eq_case := Zcompare_eq_case.
-Notation Zle_Zcompare := Zle_Zcompare.
-Notation Zlt_Zcompare := Zlt_Zcompare.
-Notation Zge_Zcompare := Zge_Zcompare.
-Notation Zgt_Zcompare := Zgt_Zcompare.
-Notation Zmin_plus := Zmin_plus.
-Notation absolu_lt := absolu_lt.
-Notation Zle_bool_imp_le := Zle_bool_imp_le.
-Notation Zle_imp_le_bool := Zle_imp_le_bool.
-Notation Zle_bool_refl := Zle_bool_refl.
-Notation Zle_bool_antisym := Zle_bool_antisym.
-Notation Zle_bool_trans := Zle_bool_trans.
-Notation Zle_bool_plus_mono := Zle_bool_plus_mono.
-Notation Zone_pos := Zone_pos.
-Notation Zone_min_pos := Zone_min_pos.
-Notation Zle_is_le_bool := Zle_is_le_bool.
-Notation Zge_is_le_bool := Zge_is_le_bool.
-Notation Zlt_is_le_bool := Zlt_is_le_bool.
-Notation Zgt_is_le_bool := Zgt_is_le_bool.
-Notation Zle_plus_swap := Zle_plus_swap.
-Notation Zge_iff_le := Zge_iff_le.
-Notation Zlt_plus_swap := Zlt_plus_swap.
-Notation Zgt_iff_lt := Zgt_iff_lt.
-Notation Zeq_plus_swap := Zeq_plus_swap.
-(* Definitions *)
-Notation entier_of_Z := entier_of_Z.
-Notation Z_of_entier := Z_of_entier.
-Notation Zle_bool := Zle_bool.
-Notation Zge_bool := Zge_bool.
-Notation Zlt_bool := Zlt_bool.
-Notation Zgt_bool := Zgt_bool.
-Notation Zeq_bool := Zeq_bool.
-Notation Zneq_bool := Zneq_bool.
-Notation Zeven := Zeven.
-Notation Zodd := Zodd.
-Notation Zeven_bool := Zeven_bool.
-Notation Zodd_bool := Zodd_bool.
-Notation Zeven_odd_dec := Zeven_odd_dec.
-Notation Zeven_dec := Zeven_dec.
-Notation Zodd_dec := Zodd_dec.
-Notation Zdiv2_pos := Zdiv2_pos.
-Notation Zdiv2 := Zdiv2.
-Notation Zle_bool_total := Zle_bool_total.
-Export Zbool.
-Export Zeven.
-Export Zabs.
-Export Zmin.
-Export Zorder.
-Export Zcompare.
-].
diff --git a/theories7/ZArith/Znat.v b/theories7/ZArith/Znat.v
deleted file mode 100644
index 99d1422f..00000000
--- a/theories7/ZArith/Znat.v
+++ /dev/null
@@ -1,138 +0,0 @@
-(************************************************************************)
-(*  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: Znat.v,v 1.1.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
-
-Require Export Arith.
-Require BinPos.
-Require BinInt.
-Require Zcompare.
-Require Zorder.
-Require Decidable.
-Require Peano_dec.
-Require Export Compare_dec.
-
-Open Local Scope Z_scope.
-
-Definition neq := [x,y:nat] ~(x=y).
-
-(**********************************************************************)
-(** Properties of the injection from nat into Z *)
-
-Theorem inj_S : (y:nat) (inject_nat (S y)) = (Zs (inject_nat y)).
-Proof.
-Intro y; NewInduction y as [|n H]; [
-  Unfold Zs ; Simpl; Trivial with arith
-| Change (POS (add_un (anti_convert n)))=(Zs (inject_nat (S n)));
-  Rewrite add_un_Zs; Trivial with arith].
-Qed.
- 
-Theorem inj_plus : 
-  (x,y:nat) (inject_nat (plus x y)) = (Zplus (inject_nat x) (inject_nat y)).
-Proof.
-Intro x; NewInduction x as [|n H]; Intro y; NewDestruct y as [|m]; [
-  Simpl; Trivial with arith
-| Simpl; Trivial with arith
-| Simpl; Rewrite <- plus_n_O; Trivial with arith
-| Change (inject_nat (S (plus n (S m))))=
-                        (Zplus (inject_nat (S n)) (inject_nat (S m)));
-  Rewrite inj_S; Rewrite H; Do 2 Rewrite inj_S; Rewrite Zplus_S_n; Trivial with arith].
-Qed.
- 
-Theorem inj_mult : 
-  (x,y:nat) (inject_nat (mult x y)) = (Zmult (inject_nat x) (inject_nat y)).
-Proof.
-Intro x; NewInduction x as [|n H]; [
-  Simpl; Trivial with arith
-| Intro y; Rewrite -> inj_S; Rewrite <- Zmult_Sm_n;
-    Rewrite <- H;Rewrite <- inj_plus; Simpl; Rewrite plus_sym; Trivial with arith].
-Qed.
-
-Theorem inj_neq:
-  (x,y:nat) (neq x y) -> (Zne (inject_nat x) (inject_nat y)).
-Proof.
-Unfold neq Zne not ; Intros x y H1 H2; Apply H1; Generalize H2; 
-Case x; Case y; Intros; [
-  Auto with arith
-| Discriminate H0
-| Discriminate H0
-| Simpl in H0; Injection H0; Do 2 Rewrite <- bij1; Intros E; Rewrite E; Auto with arith].
-Qed. 
-
-Theorem inj_le:
-  (x,y:nat) (le x y) -> (Zle (inject_nat x) (inject_nat y)).
-Proof.
-Intros x y; Intros H; Elim H; [
-  Unfold Zle ; Elim (Zcompare_EGAL (inject_nat x) (inject_nat x));
-  Intros H1 H2; Rewrite H2; [ Discriminate | Trivial with arith]
-| Intros m H1 H2; Apply Zle_trans with (inject_nat m); 
-    [Assumption | Rewrite inj_S; Apply Zle_n_Sn]].
-Qed.
-
-Theorem inj_lt: (x,y:nat) (lt x y) -> (Zlt (inject_nat x) (inject_nat y)).
-Proof.
-Intros x y H; Apply Zgt_lt; Apply Zle_S_gt; Rewrite <- inj_S; Apply inj_le;
-Exact H.
-Qed.
-
-Theorem inj_gt: (x,y:nat) (gt x y) -> (Zgt (inject_nat x) (inject_nat y)).
-Proof.
-Intros x y H; Apply Zlt_gt; Apply inj_lt; Exact H.
-Qed.
-
-Theorem inj_ge: (x,y:nat) (ge x y) -> (Zge (inject_nat x) (inject_nat y)).
-Proof.
-Intros x y H; Apply Zle_ge; Apply inj_le; Apply H.
-Qed.
-
-Theorem inj_eq: (x,y:nat) x=y -> (inject_nat x) = (inject_nat y).
-Proof.
-Intros x y H; Rewrite H; Trivial with arith.
-Qed.
-
-Theorem intro_Z : 
-  (x:nat) (EX y:Z | (inject_nat x)=y /\ 
-      	  (Zle ZERO (Zplus (Zmult y (POS xH)) ZERO))).
-Proof.
-Intros x; Exists (inject_nat x); Split; [
-  Trivial with arith
-| Rewrite Zmult_sym; Rewrite Zmult_one; Rewrite Zero_right; 
-  Unfold Zle ; Elim x; Intros;Simpl; Discriminate ].
-Qed.
-
-Theorem inj_minus1 :
-  (x,y:nat) (le y x) -> 
-    (inject_nat (minus x y)) = (Zminus (inject_nat x) (inject_nat y)).
-Proof.
-Intros x y H; Apply (Zsimpl_plus_l (inject_nat y)); Unfold Zminus ;
-Rewrite Zplus_permute; Rewrite Zplus_inverse_r; Rewrite <- inj_plus;
-Rewrite <- (le_plus_minus y x H);Rewrite Zero_right; Trivial with arith.
-Qed.
- 
-Theorem inj_minus2: (x,y:nat) (gt y x) -> (inject_nat (minus x y)) = ZERO.
-Proof.
-Intros x y H; Rewrite inj_minus_aux; [ Trivial with arith | Apply gt_not_le; Assumption].
-Qed.
-
-V7only [ (* From Zdivides *) ].
-Theorem POS_inject: (x : positive) (POS x) = (inject_nat (convert x)).
-Proof.
-Intros x; Elim x; Simpl; Auto.
-Intros p H; Rewrite ZL6.
-Apply f_equal with f := POS.
-Apply convert_intro.
-Rewrite bij1; Unfold convert; Simpl.
-Rewrite ZL6; Auto.
-Intros p H; Unfold convert; Simpl.
-Rewrite ZL6; Simpl.
-Rewrite inj_plus; Repeat Rewrite <- H.
-Rewrite POS_xO; Simpl; Rewrite add_x_x; Reflexivity.
-Qed.
-
diff --git a/theories7/ZArith/Znumtheory.v b/theories7/ZArith/Znumtheory.v
deleted file mode 100644
index b8e5f300..00000000
--- a/theories7/ZArith/Znumtheory.v
+++ /dev/null
@@ -1,629 +0,0 @@
-(************************************************************************)
-(*  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: Znumtheory.v,v 1.3.2.1 2004/07/16 19:31:43 herbelin Exp $ i*)
-
-Require ZArith_base.
-Require ZArithRing.
-Require Zcomplements.
-Require Zdiv.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-(** This file contains some notions of number theory upon Z numbers: 
-     - a divisibility predicate [Zdivide]
-     - a gcd predicate [gcd]
-     - Euclid algorithm [euclid]
-     - an efficient [Zgcd] function 
-     - a relatively prime predicate [rel_prime]
-     - a prime predicate [prime]
-*)
-
-(** * Divisibility *)
-
-Inductive Zdivide [a,b:Z] : Prop := 
-  Zdivide_intro : (q:Z) `b = q * a` -> (Zdivide a b).
-
-(** Syntax for divisibility *)
-
-Notation "( a | b )" := (Zdivide a b) 
- (at level 0, a,b at level 10) : Z_scope
- V8only "( a | b )" (at level 0).
-
-(** Results concerning divisibility*)
-
-Lemma Zdivide_refl : (a:Z) (a|a).
-Proof.
-Intros; Apply Zdivide_intro with `1`; Ring.
-Save.
-
-Lemma Zone_divide : (a:Z) (1|a).
-Proof.
-Intros; Apply Zdivide_intro with `a`; Ring.
-Save.
-
-Lemma Zdivide_0 : (a:Z) (a|0).
-Proof.
-Intros; Apply Zdivide_intro with `0`; Ring.
-Save.
-
-Hints Resolve Zdivide_refl Zone_divide Zdivide_0 : zarith.
-
-Lemma Zdivide_mult_left : (a,b,c:Z) (a|b) -> (`c*a`|`c*b`).
-Proof.
-Induction 1; Intros; Apply Zdivide_intro with q.
-Rewrite H0; Ring.
-Save.
-
-Lemma Zdivide_mult_right : (a,b,c:Z) (a|b) -> (`a*c`|`b*c`).
-Proof.
-Intros a b c; Rewrite (Zmult_sym a c); Rewrite (Zmult_sym b c).
-Apply Zdivide_mult_left; Trivial.
-Save.
-
-Hints Resolve Zdivide_mult_left Zdivide_mult_right : zarith.
-
-Lemma Zdivide_plus : (a,b,c:Z) (a|b) -> (a|c) -> (a|`b+c`).
-Proof.
-Induction 1; Intros q Hq; Induction 1; Intros q' Hq'.
-Apply Zdivide_intro with `q+q'`.
-Rewrite Hq; Rewrite Hq'; Ring.
-Save.
-
-Lemma Zdivide_opp : (a,b:Z) (a|b) -> (a|`-b`).
-Proof.
-Induction 1; Intros; Apply Zdivide_intro with `-q`.
-Rewrite H0; Ring.
-Save.
-
-Lemma Zdivide_opp_rev : (a,b:Z) (a|`-b`) -> (a| b).
-Proof.
-Intros; Replace b with `-(-b)`. Apply Zdivide_opp; Trivial. Ring.
-Save.
-
-Lemma Zdivide_opp_left : (a,b:Z) (a|b) -> (`-a`|b).
-Proof.
-Induction 1; Intros; Apply Zdivide_intro with `-q`.
-Rewrite H0; Ring.
-Save.
-
-Lemma Zdivide_opp_left_rev : (a,b:Z) (`-a`|b) -> (a|b).
-Proof.
-Intros; Replace a with `-(-a)`. Apply Zdivide_opp_left; Trivial. Ring.
-Save.
-
-Lemma Zdivide_minus : (a,b,c:Z) (a|b) -> (a|c) -> (a|`b-c`).
-Proof.
-Induction 1; Intros q Hq; Induction 1; Intros q' Hq'.
-Apply Zdivide_intro with `q-q'`.
-Rewrite Hq; Rewrite Hq'; Ring.
-Save.
-
-Lemma Zdivide_left : (a,b,c:Z) (a|b) -> (a|`b*c`).
-Proof.
-Induction 1; Intros q Hq; Apply Zdivide_intro with `q*c`.
-Rewrite Hq; Ring.
-Save.
-
-Lemma Zdivide_right : (a,b,c:Z) (a|c) -> (a|`b*c`).
-Proof.
-Induction 1; Intros q Hq; Apply Zdivide_intro with `q*b`.
-Rewrite Hq; Ring.
-Save.
-
-Lemma Zdivide_a_ab : (a,b:Z) (a|`a*b`).
-Proof.
-Intros; Apply Zdivide_intro with b; Ring.
-Save.
-
-Lemma Zdivide_a_ba : (a,b:Z) (a|`b*a`).
-Proof.
-Intros; Apply Zdivide_intro with b; Ring.
-Save.
-
-Hints Resolve Zdivide_plus Zdivide_opp Zdivide_opp_rev
-              Zdivide_opp_left Zdivide_opp_left_rev
-              Zdivide_minus Zdivide_left Zdivide_right
-              Zdivide_a_ab Zdivide_a_ba : zarith.
-
-(** Auxiliary result. *)
-
-Lemma Zmult_one : 
- (x,y:Z) `x>=0` -> `x*y=1` -> `x=1`.
-Proof.
-Intros x y H H0; NewDestruct (Zmult_1_inversion_l ? ? H0) as [Hpos|Hneg].
-  Assumption.
-  Rewrite Hneg in H; Simpl in H.
-  Contradiction (Zle_not_lt `0` `-1`).
-    Apply Zge_le; Assumption.
-    Apply NEG_lt_ZERO.
-Save.
-
-(** Only [1] and [-1] divide [1]. *)
-
-Lemma Zdivide_1 : (x:Z) (x|1) -> `x=1` \/ `x=-1`.
-Proof.
-Induction 1; Intros.
-Elim (Z_lt_ge_dec `0` x); [Left|Right].
-Apply Zmult_one with q; Auto with zarith; Rewrite H0; Ring.
-Assert `(-x) = 1`; Auto with zarith.
-Apply Zmult_one with (-q); Auto with zarith; Rewrite H0; Ring.
-Save.
-
-(** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *)
-
-Lemma Zdivide_antisym : (a,b:Z) (a|b) -> (b|a) -> `a=b` \/ `a=-b`.
-Proof.
-Induction 1; Intros.
-Inversion H1.
-Rewrite H0 in H2; Clear H H1.
-Case (Z_zerop a); Intro.
-Left; Rewrite H0; Rewrite e; Ring.
-Assert Hqq0: `q0*q = 1`.
-Apply Zmult_reg_left with a.
-Assumption.
-Ring.
-Pattern 2 a; Rewrite H2; Ring.
-Assert (q|1).
-Rewrite <- Hqq0; Auto with zarith.
-Elim (Zdivide_1 q H); Intros.
-Rewrite H1 in H0; Left; Omega.
-Rewrite H1 in H0; Right; Omega.
-Save.
-
-(** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *)
-
-Lemma Zdivide_bounds : (a,b:Z) (a|b) -> `b<>0` -> `|a| <= |b|`.
-Proof.
-Induction 1; Intros.
-Assert `|b|=|q|*|a|`.
- Subst; Apply Zabs_Zmult.
-Rewrite H2.
-Assert H3 := (Zabs_pos q).
-Assert H4 := (Zabs_pos a).
-Assert `|q|*|a|>=1*|a|`; Auto with zarith.
-Apply Zge_Zmult_pos_compat; Auto with zarith.
-Elim (Z_lt_ge_dec `|q|` `1`); [ Intros | Auto with zarith ].
-Assert `|q|=0`.
- Omega.
-Assert `q=0`.
- Rewrite <- (Zabs_Zsgn q).
-Rewrite H5; Auto with zarith.
-Subst q; Omega.
-Save.
-
-(** * Greatest common divisor (gcd). *)
-   
-(** There is no unicity of the gcd; hence we define the predicate [gcd a b d] 
-     expressing that [d] is a gcd of [a] and [b]. 
-     (We show later that the [gcd] is actually unique if we discard its sign.) *)
-
-Inductive gcd [a,b,d:Z] : Prop :=
-  gcd_intro : 
-    (d|a) -> (d|b) -> ((x:Z) (x|a) -> (x|b) -> (x|d)) -> (gcd a b d).
-
-(** Trivial properties of [gcd] *)
-
-Lemma gcd_sym : (a,b,d:Z)(gcd a b d) -> (gcd b a d).
-Proof.
-Induction 1; Constructor; Intuition.
-Save.
-
-Lemma gcd_0 : (a:Z)(gcd a `0` a).
-Proof.
-Constructor; Auto with zarith.
-Save.
-
-Lemma gcd_minus :(a,b,d:Z)(gcd a `-b` d) -> (gcd b a d).
-Proof.
-Induction 1; Constructor; Intuition.
-Save.
-
-Lemma gcd_opp :(a,b,d:Z)(gcd a b d) -> (gcd b a `-d`).
-Proof.
-Induction 1; Constructor; Intuition.
-Save.
-
-Hints Resolve gcd_sym gcd_0 gcd_minus gcd_opp : zarith.
-
-(** * Extended Euclid algorithm. *)
-
-(** Euclid's algorithm to compute the [gcd] mainly relies on
-    the following property. *)
-
-Lemma gcd_for_euclid :
-  (a,b,d,q:Z) (gcd b `a-q*b` d) -> (gcd a b d).
-Proof.
-Induction 1; Constructor; Intuition.
-Replace a with `a-q*b+q*b`. Auto with zarith. Ring.
-Save.
-
-Lemma gcd_for_euclid2 :
-  (b,d,q,r:Z) (gcd r b d) -> (gcd b `b*q+r` d).
-Proof.
-Induction 1; Constructor; Intuition.
-Apply H2; Auto.
-Replace r with `b*q+r-b*q`. Auto with zarith. Ring.
-Save.
-
-(** We implement the extended version of Euclid's algorithm,
-    i.e. the one computing Bezout's coefficients as it computes
-    the [gcd]. We follow the algorithm given in Knuth's
-    "Art of Computer Programming", vol 2, page 325. *)
-
-Section extended_euclid_algorithm.
-
-Variable a,b : Z.
-
-(** The specification of Euclid's algorithm is the existence of
-    [u], [v] and [d] such that [ua+vb=d] and [(gcd a b d)]. *)
-
-Inductive Euclid : Set :=
-  Euclid_intro : 
-    (u,v,d:Z) `u*a+v*b=d` -> (gcd a b d) -> Euclid.
-
-(** The recursive part of Euclid's algorithm uses well-founded
-    recursion of non-negative integers. It maintains 6 integers
-    [u1,u2,u3,v1,v2,v3] such that the following invariant holds:
-    [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. 
-    *)
-
-Lemma euclid_rec :
-  (v3:Z) `0 <= v3` -> (u1,u2,u3,v1,v2:Z) `u1*a+u2*b=u3` -> `v1*a+v2*b=v3` -> 
-  ((d:Z)(gcd u3 v3 d) -> (gcd a b d)) -> Euclid.
-Proof.
-Intros v3 Hv3; Generalize Hv3; Pattern v3.
-Apply Z_lt_rec.
-Clear v3 Hv3; Intros.
-Elim (Z_zerop x); Intro.
-Apply Euclid_intro with u:=u1 v:=u2 d:=u3.
-Assumption.
-Apply H2.
-Rewrite a0; Auto with zarith.
-LetTac q := (Zdiv u3 x).
-Assert Hq: `0 <= u3-q*x < x`.
-Replace `u3-q*x` with `u3%x`.
-Apply Z_mod_lt; Omega.
-Assert xpos : `x > 0`. Omega.
-Generalize (Z_div_mod_eq u3 x xpos). 
-Unfold q. 
-Intro eq; Pattern 2 u3; Rewrite eq; Ring.
-Apply (H `u3-q*x` Hq (proj1 ? ? Hq) v1 v2 x `u1-q*v1` `u2-q*v2`).
-Tauto.
-Replace `(u1-q*v1)*a+(u2-q*v2)*b` with `(u1*a+u2*b)-q*(v1*a+v2*b)`.
-Rewrite H0; Rewrite H1; Trivial.
-Ring.
-Intros; Apply H2.
-Apply gcd_for_euclid with q; Assumption.
-Assumption.
-Save.
-
-(** We get Euclid's algorithm by applying [euclid_rec] on
-    [1,0,a,0,1,b] when [b>=0] and [1,0,a,0,-1,-b] when [b<0]. *)
-
-Lemma euclid : Euclid.
-Proof.
-Case (Z_le_gt_dec `0` b); Intro.
-Intros; Apply euclid_rec with u1:=`1` u2:=`0` u3:=a
-                              v1:=`0` v2:=`1` v3:=b;
-Auto with zarith; Ring.
-Intros; Apply euclid_rec with u1:=`1` u2:=`0` u3:=a
-                              v1:=`0` v2:=`-1` v3:=`-b`;
-Auto with zarith; Try Ring.
-Save.
-
-End extended_euclid_algorithm.
-
-Theorem gcd_uniqueness_apart_sign :
-  (a,b,d,d':Z) (gcd a b d) -> (gcd a b d') -> `d = d'` \/ `d = -d'`.
-Proof.
-Induction 1.
-Intros H1 H2 H3; Induction 1; Intros.
-Generalize (H3 d' H4 H5); Intro Hd'd.
-Generalize (H6 d H1 H2); Intro Hdd'.
-Exact (Zdivide_antisym d d' Hdd' Hd'd).
-Save.
-
-(** * Bezout's coefficients *)
-
-Inductive Bezout [a,b,d:Z] : Prop := 
-  Bezout_intro : (u,v:Z) `u*a + v*b = d` -> (Bezout a b d).
-
-(** Existence of Bezout's coefficients for the [gcd] of [a] and [b] *)
-
-Lemma gcd_bezout : (a,b,d:Z) (gcd a b d) -> (Bezout a b d).
-Proof.
-Intros a b d Hgcd.
-Elim (euclid a b); Intros u v d0 e g.
-Generalize (gcd_uniqueness_apart_sign a b d d0 Hgcd g).
-Intro H; Elim H; Clear H; Intros.
-Apply Bezout_intro with u v.
-Rewrite H; Assumption.
-Apply Bezout_intro with `-u` `-v`.
-Rewrite H; Rewrite <- e; Ring.
-Save.
-
-(** gcd of [ca] and [cb] is [c gcd(a,b)]. *)
-
-Lemma gcd_mult : (a,b,c,d:Z) (gcd a b d) -> (gcd `c*a` `c*b` `c*d`).
-Proof.
-Intros a b c d; Induction 1; Constructor; Intuition.
-Elim (gcd_bezout a b d H); Intros.
-Elim H3; Intros.
-Elim H4; Intros.
-Apply Zdivide_intro with `u*q+v*q0`.
-Rewrite <- H5.
-Replace `c*(u*a+v*b)` with `u*(c*a)+v*(c*b)`.
-Rewrite H6; Rewrite H7; Ring.
-Ring.
-Save.
-
-(** We could obtain a [Zgcd] function via [euclid]. But we propose 
-  here a more direct version of a [Zgcd], with better extraction 
-  (no bezout coeffs). *)
-
-Definition Zgcd_pos : (a:Z)`0<=a` -> (b:Z) 
- { g:Z | `0<=a` -> (gcd a b g) /\ `g>=0` }.
-Proof.
-Intros a Ha.
-Apply (Z_lt_rec [a:Z](b:Z) { g:Z | `0<=a` -> (gcd a b g) /\`g>=0` }); Try Assumption.
-Intro x; Case x.
-Intros _ b; Exists (Zabs b).
-  Elim (Z_le_lt_eq_dec ? ? (Zabs_pos b)).
-    Intros H0; Split.
-    Apply Zabs_ind.
-    Intros; Apply gcd_sym; Apply gcd_0; Auto.
-    Intros; Apply gcd_opp; Apply gcd_0; Auto.
-    Auto with zarith.
-    
-    Intros H0;  Rewrite <- H0.
-    Rewrite <- (Zabs_Zsgn b); Rewrite <- H0; Simpl.
-    Split; [Apply gcd_0|Idtac];Auto with zarith.
-  
-Intros p Hrec b.
-Generalize (Z_div_mod b (POS p)).
-Case (Zdiv_eucl b (POS p)); Intros q r Hqr.
-Elim Hqr; Clear Hqr; Intros; Auto with zarith.
-Elim (Hrec r H0 (POS p)); Intros g Hgkl.
-Inversion_clear H0.
-Elim (Hgkl H1); Clear Hgkl; Intros H3 H4.
-Exists g; Intros.
-Split; Auto.
-Rewrite H.
-Apply gcd_for_euclid2; Auto.
-
-Intros p Hrec b.
-Exists `0`; Intros.
-Elim H; Auto.
-Defined.
-
-Definition Zgcd_spec : (a,b:Z){ g : Z | (gcd a b g) /\ `g>=0` }.
-Proof.
-Intros a; Case (Z_gt_le_dec `0` a).
-Intros; Assert `0 <= -a`.
-Omega.
-Elim (Zgcd_pos `-a` H b); Intros g Hgkl.
-Exists g.
-Intuition.
-Intros Ha b; Elim (Zgcd_pos a Ha b); Intros g; Exists g; Intuition.
-Defined.
-
-Definition Zgcd := [a,b:Z](let (g,_) = (Zgcd_spec a b) in g).
-
-Lemma Zgcd_is_pos : (a,b:Z)`(Zgcd a b) >=0`.
-Intros a b; Unfold Zgcd; Case (Zgcd_spec a b); Tauto.
-Qed.
-
-Lemma Zgcd_is_gcd : (a,b:Z)(gcd a b (Zgcd a b)).
-Intros a b; Unfold Zgcd; Case (Zgcd_spec a b); Tauto.
-Qed.
-
-(** * Relative primality *)
-
-Definition rel_prime [a,b:Z] : Prop := (gcd a b `1`).
-
-(** Bezout's theorem: [a] and [b] are relatively prime if and
-    only if there exist [u] and [v] such that [ua+vb = 1]. *)
-
-Lemma rel_prime_bezout : 
-  (a,b:Z) (rel_prime a b) -> (Bezout a b `1`).
-Proof.
-Intros a b; Exact (gcd_bezout a b `1`).
-Save.
-
-Lemma bezout_rel_prime :
-  (a,b:Z) (Bezout a b `1`) -> (rel_prime a b).
-Proof.
-Induction 1; Constructor; Auto with zarith.
-Intros. Rewrite <- H0; Auto with zarith.
-Save.
-
-(** Gauss's theorem: if [a] divides [bc] and if [a] and [b] are
-    relatively prime, then [a] divides [c]. *)
-
-Theorem Gauss : (a,b,c:Z) (a |`b*c`) -> (rel_prime a b) -> (a | c).
-Proof.
-Intros. Elim (rel_prime_bezout a b H0); Intros.
-Replace c with `c*1`; [ Idtac | Ring ].
-Rewrite <- H1.
-Replace `c*(u*a+v*b)` with `(c*u)*a + v*(b*c)`; [ EAuto with zarith | Ring ].
-Save.
-
-(** If [a] is relatively prime to [b] and [c], then it is to [bc] *)
-
-Lemma rel_prime_mult : 
-  (a,b,c:Z) (rel_prime a b) -> (rel_prime a c) -> (rel_prime a `b*c`).
-Proof.
-Intros a b c Hb Hc.
-Elim (rel_prime_bezout a b Hb); Intros.
-Elim (rel_prime_bezout a c Hc); Intros.
-Apply bezout_rel_prime.
-Apply Bezout_intro with u:=`u*u0*a+v0*c*u+u0*v*b` v:=`v*v0`.
-Rewrite <- H.
-Replace `u*a+v*b` with `(u*a+v*b) * 1`; [ Idtac | Ring ].
-Rewrite <- H0.
-Ring.
-Save.
-
-Lemma rel_prime_cross_prod :
-  (a,b,c,d:Z) (rel_prime a b) -> (rel_prime c d) -> `b>0` -> `d>0` -> 
-  `a*d = b*c` -> (a=c /\ b=d).
-Proof.
-Intros a b c d; Intros.
-Elim (Zdivide_antisym b d).
-Split; Auto with zarith.
-Rewrite H4 in H3.
-Rewrite Zmult_sym in H3.
-Apply Zmult_reg_left with d; Auto with zarith.
-Intros; Omega.
-Apply Gauss with a.
-Rewrite H3.
-Auto with zarith.
-Red; Auto with zarith.
-Apply Gauss with c.
-Rewrite Zmult_sym.
-Rewrite <- H3.
-Auto with zarith.
-Red; Auto with zarith.
-Save.
-
-(** After factorization by a gcd, the original numbers are relatively prime. *)
-
-Lemma gcd_rel_prime : 
- (a,b,g:Z)`b>0` -> `g>=0`-> (gcd a b g) -> (rel_prime `a/g` `b/g`).
-Intros a b g; Intros.
-Assert `g <> 0`.
- Intro.
- Elim H1; Intros. 
- Elim H4; Intros.
- Rewrite H2 in H6; Subst b; Omega.
-Unfold rel_prime.
-Elim (Zgcd_spec `a/g` `b/g`); Intros g' (H3,H4).
-Assert H5 := (gcd_mult ? ? g ? H3).
-Rewrite <- Z_div_exact_2 in H5; Auto with zarith.
-Rewrite <- Z_div_exact_2 in H5; Auto with zarith.
-Elim (gcd_uniqueness_apart_sign ? ? ? ? H1 H5).
-Intros; Rewrite (!Zmult_reg_left `1` g' g); Auto with zarith.
-Intros; Rewrite (!Zmult_reg_left `1` `-g'` g); Auto with zarith.
-Pattern 1 g; Rewrite H6; Ring.
-
-Elim H1; Intros.
-Elim H7; Intros.
-Rewrite H9.
-Replace `q*g` with `0+q*g`.
-Rewrite Z_mod_plus.
-Compute; Auto.
-Omega.
-Ring.
-
-Elim H1; Intros.
-Elim H6; Intros.
-Rewrite H9.
-Replace `q*g` with `0+q*g`.
-Rewrite Z_mod_plus.
-Compute; Auto.
-Omega.
-Ring.
-Save.
-
-(** * Primality *)
-
-Inductive prime [p:Z] : Prop := 
-  prime_intro : 
-   `1 < p` -> ((n:Z) `1 <= n < p` -> (rel_prime n p)) -> (prime p).
-
-(** The sole divisors of a prime number [p] are [-1], [1], [p] and [-p]. *)
-
-Lemma prime_divisors : 
-  (p:Z) (prime p) -> 
-  (a:Z) (a|p) -> `a = -1` \/ `a = 1` \/ a = p \/ `a = -p`.
-Proof.
-Induction 1; Intros.
-Assert `a = (-p)`\/`-p<a< -1`\/`a = -1`\/`a=0`\/`a = 1`\/`1<a<p`\/`a = p`.
-Assert `|a| <= |p|`. Apply Zdivide_bounds; [ Assumption | Omega ].
-Generalize H3. 
-Pattern `|a|`; Apply Zabs_ind; Pattern `|p|`; Apply Zabs_ind; Intros; Omega.
-Intuition Idtac.
-(* -p < a < -1 *)
-Absurd (rel_prime `-a` p); Intuition.
-Inversion H3.
-Assert (`-a` | `-a`); Auto with zarith.
-Assert (`-a` | p); Auto with zarith.
-Generalize (H8 `-a` H9 H10); Intuition Idtac.
-Generalize (Zdivide_1 `-a` H11); Intuition.
-(* a = 0 *)
-Inversion H2. Subst a; Omega.
-(* 1 < a < p *)
-Absurd (rel_prime a p); Intuition.
-Inversion H3.
-Assert (a | a); Auto with zarith.
-Assert (a | p); Auto with zarith.
-Generalize (H8 a H9 H10); Intuition Idtac.
-Generalize (Zdivide_1 a H11); Intuition.
-Save.
-
-(** A prime number is relatively prime with any number it does not divide *)
-
-Lemma prime_rel_prime : 
-  (p:Z) (prime p) -> (a:Z) ~ (p|a) -> (rel_prime p a).
-Proof.
-Induction 1; Intros.
-Constructor; Intuition.
-Elim (prime_divisors p H x H3); Intuition; Subst; Auto with zarith.
-Absurd (p | a); Auto with zarith.
-Absurd (p | a); Intuition.
-Save.
-
-Hints Resolve prime_rel_prime : zarith.
-
-(** [Zdivide] can be expressed using [Zmod]. *)
-
-Lemma Zmod_Zdivide : (a,b:Z) `b>0` -> `a%b = 0` -> (b|a).
-Intros a b H H0.
-Apply Zdivide_intro with `(a/b)`.
-Pattern 1 a; Rewrite (Z_div_mod_eq a b H).
-Rewrite H0; Ring.
-Save.
-
-Lemma Zdivide_Zmod : (a,b:Z) `b>0` -> (b|a) -> `a%b = 0`.
-Intros a b; Destruct 2; Intros; Subst.
-Change `q*b` with `0+q*b`.
-Rewrite Z_mod_plus; Auto.
-Save.
-
-(** [Zdivide] is hence decidable *)
-
-Lemma Zdivide_dec : (a,b:Z) { (a|b) } + { ~ (a|b) }.
-Proof.
-Intros a b; Elim (Ztrichotomy_inf a `0`).
-(* a<0 *)
-Intros H; Elim H; Intros. 
-Case (Z_eq_dec `b%(-a)` `0`).
-Left; Apply Zdivide_opp_left_rev; Apply Zmod_Zdivide; Auto with zarith.
-Intro H1; Right; Intro; Elim H1; Apply Zdivide_Zmod; Auto with zarith.
-(* a=0 *)
-Case (Z_eq_dec b `0`); Intro.
-Left; Subst; Auto with zarith.
-Right; Subst; Intro H0; Inversion H0; Omega.
-(* a>0 *)
-Intro H; Case (Z_eq_dec `b%a` `0`).
-Left; Apply Zmod_Zdivide; Auto with zarith.
-Intro H1; Right; Intro; Elim H1; Apply Zdivide_Zmod; Auto with zarith.
-Save.
-
-(** If a prime [p] divides [ab] then it divides either [a] or [b] *)
-
-Lemma prime_mult : 
-  (p:Z) (prime p) -> (a,b:Z) (p | `a*b`) -> (p | a) \/ (p | b).
-Proof.
-Intro p; Induction 1; Intros.
-Case (Zdivide_dec p a); Intuition.
-Right; Apply Gauss with a; Auto with zarith.
-Save.
-
-
diff --git a/theories7/ZArith/Zorder.v b/theories7/ZArith/Zorder.v
deleted file mode 100644
index d49a0800..00000000
--- a/theories7/ZArith/Zorder.v
+++ /dev/null
@@ -1,969 +0,0 @@
-(************************************************************************)
-(*  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: Zorder.v,v 1.1.2.1 2004/07/16 19:31:44 herbelin Exp $ i*)
-
-(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
-
-Require BinPos.
-Require BinInt.
-Require Arith.
-Require Decidable.
-Require Zsyntax.
-Require Zcompare.
-
-V7only [Import nat_scope.].
-Open Local Scope Z_scope.
-
-Implicit Variable Type x,y,z:Z.
-
-(**********************************************************************)
-(** Properties of the order relations on binary integers *)
-
-(** Trichotomy *)
-
-Theorem Ztrichotomy_inf : (m,n:Z) {`m<n`} + {m=n} + {`m>n`}.
-Proof.
-Unfold Zgt Zlt; Intros m n; Assert H:=(refl_equal ? (Zcompare m n)).
-  LetTac x := (Zcompare m n) in 2 H Goal.
-  NewDestruct x; 
-    [Left; Right;Rewrite Zcompare_EGAL_eq with 1:=H 
-    | Left; Left
-    | Right ]; Reflexivity.
-Qed.
-
-Theorem Ztrichotomy : (m,n:Z) `m<n` \/ m=n \/ `m>n`.
-Proof.
-  Intros m n; NewDestruct (Ztrichotomy_inf m n) as [[Hlt|Heq]|Hgt];
-    [Left | Right; Left |Right; Right]; Assumption.
-Qed.
-
-(**********************************************************************)
-(** Decidability of equality and order on Z *)
-
-Theorem dec_eq: (x,y:Z) (decidable (x=y)).
-Proof.
-Intros x y; Unfold decidable ; Elim (Zcompare_EGAL x y);
-Intros H1 H2; Elim (Dcompare (Zcompare x y)); [
-    Tauto
-  | Intros H3; Right; Unfold not ; Intros H4;
-    Elim H3; Rewrite (H2 H4); Intros H5; Discriminate H5].
-Qed. 
-
-Theorem dec_Zne: (x,y:Z) (decidable (Zne x y)).
-Proof.
-Intros x y; Unfold decidable Zne ; Elim (Zcompare_EGAL x y).
-Intros H1 H2; Elim (Dcompare (Zcompare x y)); 
-  [ Right; Rewrite H1; Auto
-  | Left; Unfold not; Intro; Absurd (Zcompare x y)=EGAL; 
-    [ Elim H; Intros HR; Rewrite HR; Discriminate 
-    | Auto]].
-Qed.
-
-Theorem dec_Zle: (x,y:Z) (decidable `x<=y`).
-Proof.
-Intros x y; Unfold decidable Zle ; Elim (Zcompare x y); [
-    Left; Discriminate
-  | Left; Discriminate
-  | Right; Unfold not ; Intros H; Apply H; Trivial with arith].
-Qed.
-
-Theorem dec_Zgt: (x,y:Z) (decidable `x>y`).
-Proof.
-Intros x y; Unfold decidable Zgt ; Elim (Zcompare x y);
-  [ Right; Discriminate | Right; Discriminate | Auto with arith].
-Qed.
-
-Theorem dec_Zge: (x,y:Z) (decidable `x>=y`).
-Proof.
-Intros x y; Unfold decidable Zge ; Elim (Zcompare x y); [
-  Left; Discriminate
-| Right; Unfold not ; Intros H; Apply H; Trivial with arith
-| Left; Discriminate]. 
-Qed.
-
-Theorem dec_Zlt: (x,y:Z) (decidable `x<y`).
-Proof.
-Intros x y; Unfold decidable Zlt ; Elim (Zcompare x y);
-  [ Right; Discriminate | Auto with arith | Right; Discriminate].
-Qed.
-
-Theorem not_Zeq : (x,y:Z) ~ x=y -> `x<y` \/ `y<x`.
-Proof.
-Intros x y; Elim (Dcompare (Zcompare x y)); [
-  Intros H1 H2; Absurd x=y; [ Assumption | Elim (Zcompare_EGAL x y); Auto with arith]
-| Unfold Zlt ; Intros H; Elim H; Intros H1; 
-    [Auto with arith | Right; Elim (Zcompare_ANTISYM x y); Auto with arith]].
-Qed. 
-
-(** Relating strict and large orders *)
-
-Lemma Zgt_lt : (m,n:Z) `m>n` -> `n<m`.
-Proof.
-Unfold Zgt Zlt ;Intros m n H; Elim (Zcompare_ANTISYM m n); Auto with arith.
-Qed.
-
-Lemma Zlt_gt : (m,n:Z) `m<n` -> `n>m`.
-Proof.
-Unfold Zgt Zlt ;Intros m n H; Elim (Zcompare_ANTISYM n m); Auto with arith.
-Qed.
-
-Lemma Zge_le : (m,n:Z) `m>=n` -> `n<=m`.
-Proof.
-Intros m n; Change ~`m<n`-> ~`n>m`;
-Unfold not; Intros H1 H2; Apply H1; Apply Zgt_lt; Assumption.
-Qed.
-
-Lemma Zle_ge : (m,n:Z) `m<=n` -> `n>=m`.
-Proof.
-Intros m n; Change ~`m>n`-> ~`n<m`;
-Unfold not; Intros H1 H2; Apply H1; Apply Zlt_gt; Assumption.
-Qed.
-
-Lemma Zle_not_gt     : (n,m:Z)`n<=m` -> ~`n>m`.
-Proof.
-Trivial.
-Qed.
-
-Lemma Zgt_not_le     : (n,m:Z)`n>m` -> ~`n<=m`.
-Proof.
-Intros n m H1 H2; Apply H2; Assumption.
-Qed.
-
-Lemma Zle_not_lt : (n,m:Z)`n<=m` -> ~`m<n`.
-Proof.
-Intros n m H1 H2.
-Assert H3:=(Zlt_gt ? ? H2).
-Apply Zle_not_gt with n m; Assumption.
-Qed.
-
-Lemma Zlt_not_le : (n,m:Z)`n<m` -> ~`m<=n`.
-Proof.
-Intros n m H1 H2.
-Apply Zle_not_lt with m n; Assumption.
-Qed.
-
-Lemma not_Zge : (x,y:Z) ~`x>=y` -> `x<y`.
-Proof.
-Unfold Zge Zlt ; Intros x y H; Apply dec_not_not;
-  [ Exact (dec_Zlt x y) | Assumption].
-Qed.
- 
-Lemma not_Zlt : (x,y:Z) ~`x<y` -> `x>=y`.
-Proof.
-Unfold Zlt Zge; Auto with arith.
-Qed.
-
-Lemma not_Zgt : (x,y:Z)~`x>y` -> `x<=y`.
-Proof.
-Trivial.
-Qed.
-
-Lemma not_Zle : (x,y:Z) ~`x<=y` -> `x>y`.
-Proof.
-Unfold Zle Zgt ; Intros x y H; Apply dec_not_not;
-  [ Exact (dec_Zgt x y) | Assumption].
-Qed.
-
-Lemma Zge_iff_le : (x,y:Z) `x>=y` <-> `y<=x`.
-Proof.
-    Intros x y; Intros. Split. Intro. Apply Zge_le. Assumption.
-    Intro. Apply Zle_ge. Assumption.
-Qed.
-
-Lemma Zgt_iff_lt : (x,y:Z) `x>y` <-> `y<x`.
-Proof.
-    Intros x y. Split. Intro. Apply Zgt_lt. Assumption.
-    Intro. Apply Zlt_gt. Assumption.
-Qed.
- 
-(** Reflexivity *)
-
-Lemma Zle_n : (n:Z) (Zle n n).
-Proof.
-Intros n; Unfold Zle; Rewrite (Zcompare_x_x n); Discriminate.
-Qed. 
-
-Lemma Zle_refl : (n,m:Z) n=m -> `n<=m`.
-Proof.
-Intros; Rewrite H; Apply Zle_n.
-Qed.
-
-Hints Resolve Zle_n : zarith.
-
-(** Antisymmetry *)
-
-Lemma Zle_antisym : (n,m:Z)`n<=m`->`m<=n`->n=m.
-Proof.
-Intros n m H1 H2; NewDestruct (Ztrichotomy n m) as [Hlt|[Heq|Hgt]]. 
-  Absurd `m>n`; [ Apply Zle_not_gt | Apply Zlt_gt]; Assumption.
-  Assumption.
-  Absurd `n>m`; [ Apply Zle_not_gt | Idtac]; Assumption.
-Qed.
-
-(** Asymmetry *)
-
-Lemma Zgt_not_sym    : (n,m:Z)`n>m` -> ~`m>n`.
-Proof.
-Unfold Zgt ;Intros n m H; Elim (Zcompare_ANTISYM n m); Intros H1 H2;
-Rewrite -> H1; [ Discriminate | Assumption ].
-Qed.
-
-Lemma Zlt_not_sym : (n,m:Z)`n<m` -> ~`m<n`.
-Proof.
-Intros n m H H1;
-Assert H2:`m>n`. Apply Zlt_gt; Assumption.
-Assert H3: `n>m`. Apply Zlt_gt; Assumption.
-Apply Zgt_not_sym with m n; Assumption.
-Qed.
-
-(** Irreflexivity *)
-
-Lemma Zgt_antirefl   : (n:Z)~`n>n`.
-Proof.
-Intros n H; Apply (Zgt_not_sym n n H H).
-Qed.
-
-Lemma Zlt_n_n : (n:Z)~`n<n`.
-Proof.
-Intros n H; Apply (Zlt_not_sym n n H H).
-Qed.
-
-Lemma Zlt_not_eq : (x,y:Z)`x<y` -> ~x=y.
-Proof.
-Unfold not; Intros x y H H0.
-Rewrite H0 in H.
-Apply (Zlt_n_n ? H).
-Qed.
-
-(** Large = strict or equal *)
-
-Lemma Zlt_le_weak : (n,m:Z)`n<m`->`n<=m`.
-Proof.
-Intros n m Hlt; Apply not_Zgt; Apply Zgt_not_sym; Apply Zlt_gt; Assumption.
-Qed.
-
-Lemma Zle_lt_or_eq : (n,m:Z)`n<=m`->(`n<m` \/ n=m).
-Proof.
-Intros n m H; NewDestruct (Ztrichotomy n m) as [Hlt|[Heq|Hgt]]; [
-  Left; Assumption
-| Right; Assumption
-| Absurd `n>m`; [Apply Zle_not_gt|Idtac]; Assumption ].
-Qed.
-
-(** Dichotomy *)
-
-Lemma Zle_or_lt : (n,m:Z)`n<=m`\/`m<n`.
-Proof.
-Intros n m; NewDestruct (Ztrichotomy n m) as [Hlt|[Heq|Hgt]]; [
-  Left; Apply not_Zgt; Intro Hgt; Assert Hgt':=(Zlt_gt ? ? Hlt);
-     Apply Zgt_not_sym with m n; Assumption
-| Left; Rewrite Heq; Apply Zle_n
-| Right; Apply Zgt_lt; Assumption ].
-Qed.
-
-(** Transitivity of strict orders *)
-
-Lemma Zgt_trans      : (n,m,p:Z)`n>m`->`m>p`->`n>p`.
-Proof.
-Exact Zcompare_trans_SUPERIEUR.
-Qed.
-
-Lemma Zlt_trans : (n,m,p:Z)`n<m`->`m<p`->`n<p`.
-Proof.
-Intros n m p H1 H2; Apply Zgt_lt; Apply Zgt_trans with m:= m; 
-Apply Zlt_gt; Assumption.
-Qed.
-
-(** Mixed transitivity *)
-
-Lemma Zle_gt_trans : (n,m,p:Z)`m<=n`->`m>p`->`n>p`.
-Proof.
-Intros n m p H1 H2; NewDestruct (Zle_lt_or_eq m n H1) as [Hlt|Heq]; [
-  Apply Zgt_trans with m; [Apply Zlt_gt; Assumption | Assumption ]
-| Rewrite <- Heq; Assumption ].
-Qed.
-
-Lemma Zgt_le_trans : (n,m,p:Z)`n>m`->`p<=m`->`n>p`.
-Proof.
-Intros n m p H1 H2; NewDestruct (Zle_lt_or_eq p m H2) as [Hlt|Heq]; [
-  Apply Zgt_trans with m; [Assumption|Apply Zlt_gt; Assumption]
-| Rewrite Heq; Assumption ].
-Qed.
-
-Lemma Zlt_le_trans : (n,m,p:Z)`n<m`->`m<=p`->`n<p`.
-Intros n m p H1 H2;Apply Zgt_lt;Apply Zle_gt_trans with m:=m;
-  [ Assumption | Apply Zlt_gt;Assumption ].
-Qed.
-
-Lemma Zle_lt_trans : (n,m,p:Z)`n<=m`->`m<p`->`n<p`.
-Proof.
-Intros n m p H1 H2;Apply Zgt_lt;Apply Zgt_le_trans with m:=m; 
-  [ Apply Zlt_gt;Assumption | Assumption ].
-Qed.
-
-(** Transitivity of large orders *)
-
-Lemma Zle_trans : (n,m,p:Z)`n<=m`->`m<=p`->`n<=p`.
-Proof.
-Intros n m p H1 H2; Apply not_Zgt.
-Intro Hgt; Apply Zle_not_gt with n m. Assumption.
-Exact (Zgt_le_trans n p m Hgt H2).
-Qed.
-
-Lemma Zge_trans : (n, m, p : Z) `n>=m` -> `m>=p` -> `n>=p`.
-Proof.
-Intros n m p H1 H2.
-Apply Zle_ge.
-Apply Zle_trans with m; Apply Zge_le; Trivial.
-Qed.
-
-Hints Resolve Zle_trans : zarith.
-
-(** Compatibility of successor wrt to order *)
-
-Lemma Zle_n_S : (n,m:Z) `m<=n` -> `(Zs m)<=(Zs n)`.
-Proof.
-Unfold Zle not ;Intros m n H1 H2; Apply H1; 
-Rewrite <- (Zcompare_Zplus_compatible n m (POS xH));
-Do 2 Rewrite (Zplus_sym (POS xH)); Exact H2.
-Qed.
-
-Lemma Zgt_n_S : (n,m:Z)`m>n` -> `(Zs m)>(Zs n)`.
-Proof.
-Unfold Zgt; Intros n m H; Rewrite Zcompare_n_S; Auto with arith.
-Qed.
-
-Lemma Zlt_n_S : (n,m:Z)`n<m`->`(Zs n)<(Zs m)`.
-Proof.
-Intros n m H;Apply Zgt_lt;Apply Zgt_n_S;Apply Zlt_gt; Assumption.
-Qed.
-
-Hints Resolve Zle_n_S : zarith.
-
-(** Simplification of successor wrt to order *)
-
-Lemma Zgt_S_n        : (n,p:Z)`(Zs p)>(Zs n)`->`p>n`.
-Proof.
-Unfold Zs Zgt;Intros n p;Do 2 Rewrite -> [m:Z](Zplus_sym m (POS xH));
-Rewrite -> (Zcompare_Zplus_compatible p n (POS xH));Trivial with arith.
-Qed.
-
-Lemma Zle_S_n     : (n,m:Z) `(Zs m)<=(Zs n)` -> `m<=n`.
-Proof.
-Unfold Zle not ;Intros m n H1 H2;Apply H1;
-Unfold Zs ;Do 2 Rewrite <- (Zplus_sym (POS xH));
-Rewrite -> (Zcompare_Zplus_compatible n m (POS xH));Assumption.
-Qed.
-
-Lemma Zlt_S_n : (n,m:Z)`(Zs n)<(Zs m)`->`n<m`.
-Proof.
-Intros n m H;Apply Zgt_lt;Apply Zgt_S_n;Apply Zlt_gt; Assumption.
-Qed.
-
-(** Compatibility of addition wrt to order *)
-
-Lemma Zgt_reg_l   : (n,m,p:Z)`n>m`->`p+n>p+m`.
-Proof.
-Unfold Zgt; Intros n m p H; Rewrite (Zcompare_Zplus_compatible n m p); 
-Assumption.
-Qed.
-
-Lemma Zgt_reg_r : (n,m,p:Z)`n>m`->`n+p>m+p`.
-Proof.
-Intros n m p H; Rewrite (Zplus_sym n p); Rewrite (Zplus_sym m p); Apply Zgt_reg_l; Trivial.
-Qed.
-
-Lemma Zle_reg_l : (n,m,p:Z)`n<=m`->`p+n<=p+m`.
-Proof.
-Intros n m p; Unfold Zle not ;Intros H1 H2;Apply H1; 
-Rewrite <- (Zcompare_Zplus_compatible n m p); Assumption.
-Qed.
-
-Lemma Zle_reg_r : (n,m,p:Z) `n<=m`->`n+p<=m+p`.
-Proof.
-Intros a b c;Do 2 Rewrite [n:Z](Zplus_sym n c); Exact (Zle_reg_l a b c).
-Qed.
-
-Lemma Zlt_reg_l : (n,m,p:Z)`n<m`->`p+n<p+m`.
-Proof.
-Unfold Zlt ;Intros n m p; Rewrite Zcompare_Zplus_compatible;Trivial with arith.
-Qed.
-
-Lemma Zlt_reg_r : (n,m,p:Z)`n<m`->`n+p<m+p`.
-Proof.
-Intros n m p H; Rewrite (Zplus_sym n p); Rewrite (Zplus_sym m p); Apply Zlt_reg_l; Trivial.
-Qed.
-
-Lemma Zlt_le_reg : (a,b,c,d:Z) `a<b`->`c<=d`->`a+c<b+d`.
-Proof.
-Intros a b c d H0 H1.
-Apply Zlt_le_trans with (Zplus b c).
-Apply  Zlt_reg_r; Trivial.
-Apply  Zle_reg_l; Trivial.
-Qed.
-
-Lemma Zle_lt_reg : (a,b,c,d:Z) `a<=b`->`c<d`->`a+c<b+d`.
-Proof.
-Intros a b c d H0 H1.
-Apply Zle_lt_trans with (Zplus b c).
-Apply  Zle_reg_r; Trivial.
-Apply  Zlt_reg_l; Trivial.
-Qed.
-
-Lemma Zle_plus_plus : (n,m,p,q:Z) `n<=m`->(Zle p q)->`n+p<=m+q`.
-Proof.
-Intros n m p q; Intros H1 H2;Apply Zle_trans with m:=(Zplus n q); [
-  Apply Zle_reg_l;Assumption | Apply Zle_reg_r;Assumption ].
-Qed.
-
-V7only [Set Implicit Arguments.].
-
-Lemma Zlt_Zplus : (x1,x2,y1,y2:Z)`x1 < x2` -> `y1 < y2` -> `x1 + y1 < x2 + y2`.
-Intros; Apply Zle_lt_reg. Apply Zlt_le_weak; Assumption. Assumption.
-Qed.
-
-V7only [Unset Implicit Arguments.].
-
-(** Compatibility of addition wrt to being positive *)
-
-Lemma Zle_0_plus : (x,y:Z) `0<=x` -> `0<=y` -> `0<=x+y`.
-Proof.
-Intros x y H1 H2;Rewrite <- (Zero_left ZERO); Apply Zle_plus_plus; Assumption.
-Qed.
-
-(** Simplification of addition wrt to order *)
-
-Lemma Zsimpl_gt_plus_l : (n,m,p:Z)`p+n>p+m`->`n>m`.
-Proof.
-Unfold Zgt; Intros n m p H; 
-	Rewrite <- (Zcompare_Zplus_compatible n m p); Assumption.
-Qed.
-
-Lemma Zsimpl_gt_plus_r : (n,m,p:Z)`n+p>m+p`->`n>m`.
-Proof.
-Intros n m p H; Apply Zsimpl_gt_plus_l with p.
-Rewrite (Zplus_sym p n); Rewrite (Zplus_sym p m); Trivial.
-Qed.
-
-Lemma Zsimpl_le_plus_l : (n,m,p:Z)`p+n<=p+m`->`n<=m`.
-Proof.
-Intros n m p; Unfold Zle not ;Intros H1 H2;Apply H1; 
-Rewrite (Zcompare_Zplus_compatible n m p); Assumption.
-Qed.
- 
-Lemma Zsimpl_le_plus_r : (n,m,p:Z)`n+p<=m+p`->`n<=m`.
-Proof.
-Intros n m p H; Apply Zsimpl_le_plus_l with p.
-Rewrite (Zplus_sym p n); Rewrite (Zplus_sym p m); Trivial.
-Qed.
-
-Lemma Zsimpl_lt_plus_l : (n,m,p:Z)`p+n<p+m`->`n<m`.
-Proof.
-Unfold Zlt ;Intros n m p; 
-	Rewrite Zcompare_Zplus_compatible;Trivial with arith.
-Qed.
- 
-Lemma Zsimpl_lt_plus_r : (n,m,p:Z)`n+p<m+p`->`n<m`.
-Proof.
-Intros n m p H; Apply Zsimpl_lt_plus_l with p.
-Rewrite (Zplus_sym p n); Rewrite (Zplus_sym p m); Trivial.
-Qed.
- 
-(** Special base instances of order *)
-
-Lemma Zgt_Sn_n : (n:Z)`(Zs n)>n`.
-Proof.
-Exact Zcompare_Zs_SUPERIEUR.
-Qed.
-
-Lemma Zle_Sn_n : (n:Z)~`(Zs n)<=n`.
-Proof.
-Intros n; Apply Zgt_not_le; Apply Zgt_Sn_n.
-Qed.
-
-Lemma Zlt_n_Sn : (n:Z)`n<(Zs n)`.
-Proof.
-Intro n; Apply Zgt_lt; Apply Zgt_Sn_n.
-Qed.
-
-Lemma Zlt_pred_n_n : (n:Z)`(Zpred n)<n`.
-Proof.
-Intros n; Apply Zlt_S_n; Rewrite <- Zs_pred; Apply Zlt_n_Sn.
-Qed.
-
-(** Relating strict and large order using successor or predecessor *)
-
-Lemma Zgt_le_S       : (n,p:Z)`p>n`->`(Zs n)<=p`.
-Proof.
-Unfold Zgt Zle; Intros n p H; Elim (Zcompare_et_un p n); Intros H1 H2;
-Unfold not ;Intros H3; Unfold not in H1; Apply H1; [
-  Assumption
-| Elim (Zcompare_ANTISYM (Zplus n (POS xH)) p);Intros H4 H5;Apply H4;Exact H3].
-Qed.
-
-Lemma Zle_gt_S       : (n,p:Z)`n<=p`->`(Zs p)>n`.
-Proof.
-Intros n p H; Apply Zgt_le_trans with p.
-  Apply Zgt_Sn_n.
-  Assumption.
-Qed.
-
-Lemma Zle_lt_n_Sm : (n,m:Z)`n<=m`->`n<(Zs m)`.
-Proof.
-Intros n m H; Apply Zgt_lt; Apply Zle_gt_S; Assumption.
-Qed.
-
-Lemma Zlt_le_S : (n,p:Z)`n<p`->`(Zs n)<=p`.
-Proof.
-Intros n p H; Apply Zgt_le_S; Apply Zlt_gt; Assumption.
-Qed.
-
-Lemma Zgt_S_le       : (n,p:Z)`(Zs p)>n`->`n<=p`.
-Proof.
-Intros n p H;Apply Zle_S_n; Apply Zgt_le_S; Assumption.
-Qed.
-
-Lemma Zlt_n_Sm_le : (n,m:Z)`n<(Zs m)`->`n<=m`.
-Proof.
-Intros n m H; Apply Zgt_S_le; Apply Zlt_gt; Assumption.
-Qed.
-
-Lemma Zle_S_gt : (n,m:Z) `(Zs n)<=m` -> `m>n`.
-Proof.
-Intros n m H;Apply Zle_gt_trans with m:=(Zs n);
-  [ Assumption | Apply Zgt_Sn_n ].
-Qed.
-
-(** Weakening order *)
-
-Lemma Zle_n_Sn : (n:Z)`n<=(Zs n)`.
-Proof.
-Intros n; Apply Zgt_S_le;Apply Zgt_trans with m:=(Zs n) ;Apply Zgt_Sn_n.
-Qed.
-
-Hints Resolve Zle_n_Sn : zarith.
-
-Lemma Zle_pred_n : (n:Z)`(Zpred n)<=n`.
-Proof.
-Intros n;Pattern 2 n ;Rewrite Zs_pred; Apply Zle_n_Sn.
-Qed.
-
-Lemma Zlt_S : (n,m:Z)`n<m`->`n<(Zs m)`.
-Intros n m H;Apply Zgt_lt; Apply Zgt_trans with m:=m; [
-  Apply Zgt_Sn_n
-| Apply Zlt_gt; Assumption ].
-Qed.
-
-Lemma Zle_le_S : (x,y:Z)`x<=y`->`x<=(Zs y)`.
-Proof.
-Intros x y H.
-Apply Zle_trans with y; Trivial with zarith.
-Qed.
-
-Lemma Zle_trans_S : (n,m:Z)`(Zs n)<=m`->`n<=m`.
-Proof.
-Intros n m H;Apply Zle_trans with m:=(Zs n); [ Apply Zle_n_Sn | Assumption ].
-Qed.
-
-Hints Resolve Zle_le_S : zarith.
-
-(** Relating order wrt successor and order wrt predecessor *)
-
-Lemma Zgt_pred : (n,p:Z)`p>(Zs n)`->`(Zpred p)>n`.
-Proof.
-Unfold Zgt Zs Zpred ;Intros n p H; 
-Rewrite <- [x,y:Z](Zcompare_Zplus_compatible x y (POS xH));
-Rewrite (Zplus_sym p); Rewrite Zplus_assoc; Rewrite [x:Z](Zplus_sym x n);
-Simpl; Assumption.
-Qed.
-
-Lemma Zlt_pred : (n,p:Z)`(Zs n)<p`->`n<(Zpred p)`.
-Proof.
-Intros n p H;Apply Zlt_S_n; Rewrite <- Zs_pred; Assumption.
-Qed.
-
-(** Relating strict order and large order on positive *)
-
-Lemma Zlt_ZERO_pred_le_ZERO : (n:Z) `0<n` -> `0<=(Zpred n)`.
-Intros x H.
-Rewrite (Zs_pred x) in H.
-Apply Zgt_S_le.
-Apply Zlt_gt.
-Assumption.
-Qed.
-
-V7only [Set Implicit Arguments.].
-
-Lemma Zgt0_le_pred : (y:Z) `y > 0` -> `0 <= (Zpred y)`.
-Intros; Apply Zlt_ZERO_pred_le_ZERO; Apply Zgt_lt. Assumption.
-Qed.
-
-V7only [Unset Implicit Arguments.].
-
-(** Special cases of ordered integers *)
-
-V7only [ (* Relevance confirmed from Zdivides *) ].
-Lemma Z_O_1: `0<1`.
-Proof.
-Change `0<(Zs 0)`. Apply Zlt_n_Sn.
-Qed.
-
-Lemma Zle_0_1: `0<=1`.
-Proof.
-Change `0<=(Zs 0)`. Apply Zle_n_Sn.
-Qed.
-
-V7only [ (* Relevance confirmed from Zdivides *) ].
-Lemma Zle_NEG_POS: (p,q:positive) `(NEG p)<=(POS q)`.
-Proof.
-Intros p; Red; Simpl; Red; Intros H; Discriminate.
-Qed.
-
-Lemma POS_gt_ZERO : (p:positive) `(POS p)>0`.
-Unfold Zgt; Trivial.
-Qed.
-
-  (* weaker but useful (in [Zpower] for instance) *)
-Lemma ZERO_le_POS : (p:positive) `0<=(POS p)`.
-Intro; Unfold Zle; Discriminate.
-Qed.
-
-Lemma NEG_lt_ZERO : (p:positive)`(NEG p)<0`.
-Unfold Zlt; Trivial.
-Qed.
-
-Lemma ZERO_le_inj :
-  (n:nat) `0 <= (inject_nat n)`.
-Induction n; Simpl; Intros;
-[ Apply Zle_n
-| Unfold Zle; Simpl; Discriminate].
-Qed.
-
-Hints Immediate Zle_refl : zarith.
-
-(** Transitivity using successor *)
-
-Lemma Zgt_trans_S  : (n,m,p:Z)`(Zs n)>m`->`m>p`->`n>p`.
-Proof.
-Intros n m p H1 H2;Apply Zle_gt_trans with m:=m;
-  [ Apply Zgt_S_le; Assumption | Assumption ].
-Qed.
-
-(** Derived lemma *)
-
-Lemma Zgt_S        : (n,m:Z)`(Zs n)>m`->(`n>m`\/(m=n)).
-Proof.
-Intros n m H.
-Assert Hle : `m<=n`.
-  Apply Zgt_S_le; Assumption.
-NewDestruct (Zle_lt_or_eq ? ? Hle) as [Hlt|Heq].
-  Left; Apply Zlt_gt; Assumption.  
-  Right; Assumption.
-Qed.
-
-(** Compatibility of multiplication by a positive wrt to order *)
-
-V7only [Set Implicit Arguments.].
-
-Lemma Zle_Zmult_pos_right : (a,b,c : Z) `a<=b` -> `0<=c` -> `a*c<=b*c`.
-Proof.
-Intros a b c H H0; NewDestruct c.
-  Do 2 Rewrite Zero_mult_right; Assumption.
-  Rewrite (Zmult_sym a); Rewrite (Zmult_sym b).
-    Unfold Zle; Rewrite Zcompare_Zmult_compatible; Assumption.
-  Unfold Zle in H0; Contradiction H0; Reflexivity.
-Qed.
-
-Lemma Zle_Zmult_pos_left : (a,b,c : Z) `a<=b` -> `0<=c` -> `c*a<=c*b`.
-Proof.
-Intros a b c H1 H2; Rewrite (Zmult_sym c a);Rewrite (Zmult_sym c b).
-Apply  Zle_Zmult_pos_right; Trivial.
-Qed.
-
-V7only [ (* Relevance confirmed from Zextensions *) ].
-Lemma Zmult_lt_compat_r : (x,y,z:Z)`0<z` -> `x < y` -> `x*z < y*z`.
-Proof.
-Intros x y z H H0; NewDestruct z.
-  Contradiction (Zlt_n_n `0`).
-  Rewrite (Zmult_sym x); Rewrite (Zmult_sym y).
-    Unfold Zlt; Rewrite Zcompare_Zmult_compatible; Assumption.
-  Discriminate H.
-Save.
-
-Lemma Zgt_Zmult_right : (x,y,z:Z)`z>0` -> `x > y` -> `x*z > y*z`.
-Proof.
-Intros x y z; Intros; Apply Zlt_gt; Apply Zmult_lt_compat_r; 
-  Apply Zgt_lt; Assumption.
-Qed.
-
-Lemma Zlt_Zmult_right : (x,y,z:Z)`z>0` -> `x < y` -> `x*z < y*z`.
-Proof.
-Intros x y z; Intros; Apply Zmult_lt_compat_r; 
-  [Apply Zgt_lt; Assumption | Assumption].
-Qed.
-
-Lemma Zle_Zmult_right : (x,y,z:Z)`z>0` -> `x <= y` -> `x*z <= y*z`.
-Proof.
-Intros x y z Hz Hxy.
-Elim (Zle_lt_or_eq x y Hxy).
-Intros; Apply Zlt_le_weak.
-Apply Zlt_Zmult_right; Trivial.
-Intros; Apply Zle_refl.
-Rewrite H; Trivial.
-Qed.
-
-V7only [ (* Relevance confirmed from Zextensions *) ].
-Lemma Zmult_lt_0_le_compat_r : (x,y,z:Z)`0 < z`->`x <= y`->`x*z <= y*z`.
-Proof.
-Intros x y z; Intros; Apply Zle_Zmult_right; Try Apply Zlt_gt; Assumption.
-Qed.
-
-Lemma Zlt_Zmult_left : (x,y,z:Z)`z>0` -> `x < y` -> `z*x < z*y`.
-Proof.
-Intros x y z; Intros.
-Rewrite (Zmult_sym z x); Rewrite (Zmult_sym z y);
-Apply Zlt_Zmult_right; Assumption.
-Qed.
-
-V7only [ (* Relevance confirmed from Zextensions *) ].
-Lemma Zmult_lt_compat_l : (x,y,z:Z)`0<z` -> `x < y` -> `z*x < z*y`.
-Proof.
-Intros x y z; Intros.
-Rewrite (Zmult_sym z x); Rewrite (Zmult_sym z y);
-Apply Zlt_Zmult_right; Try Apply Zlt_gt; Assumption.
-Save.
-
-Lemma Zgt_Zmult_left : (x,y,z:Z)`z>0` -> `x > y` -> `z*x > z*y`.
-Proof.
-Intros x y z; Intros;
-Rewrite (Zmult_sym z x); Rewrite (Zmult_sym z y);
-Apply Zgt_Zmult_right; Assumption.
-Qed.
-
-Lemma Zge_Zmult_pos_right : (a,b,c : Z) `a>=b` -> `c>=0` -> `a*c>=b*c`.
-Proof.
-Intros a b c H1 H2; Apply Zle_ge.
-Apply Zle_Zmult_pos_right; Apply Zge_le; Trivial.
-Qed.
-
-Lemma Zge_Zmult_pos_left : (a,b,c : Z) 	`a>=b` -> `c>=0` -> `c*a>=c*b`.
-Proof.
-Intros a b c H1 H2; Apply Zle_ge.
-Apply Zle_Zmult_pos_left; Apply Zge_le; Trivial.
-Qed.
-
-Lemma Zge_Zmult_pos_compat : 
-  (a,b,c,d : Z) `a>=c` -> `b>=d` -> `c>=0` -> `d>=0` -> `a*b>=c*d`.
-Proof.
-Intros a b c d H0 H1 H2 H3.
-Apply Zge_trans with (Zmult a d).
-Apply Zge_Zmult_pos_left; Trivial.
-Apply Zge_trans with c; Trivial. 
-Apply Zge_Zmult_pos_right; Trivial.
-Qed.
-
-V7only [ (* Relevance confirmed from Zextensions *) ].
-Lemma Zmult_le_compat: (a, b, c, d : Z)
- `a<=c` -> `b<=d` -> `0<=a` -> `0<=b` -> `a*b<=c*d`.
-Proof.
-Intros a b c d H0 H1 H2 H3.
-Apply Zle_trans with (Zmult c b).
-Apply Zle_Zmult_pos_right; Assumption.
-Apply Zle_Zmult_pos_left.
-Assumption.
-Apply Zle_trans with a; Assumption.
-Qed.
-
-(** Simplification of multiplication by a positive wrt to being positive *)
-
-Lemma Zlt_Zmult_right2 : (x,y,z:Z)`z>0`  -> `x*z < y*z` -> `x < y`.
-Proof.
-Intros x y z; Intros; NewDestruct z.
-  Contradiction (Zgt_antirefl `0`).
-  Rewrite (Zmult_sym x) in H0; Rewrite (Zmult_sym y) in H0.
-    Unfold Zlt in H0; Rewrite Zcompare_Zmult_compatible in H0; Assumption.
-  Discriminate H.
-Qed.
-
-V7only [ (* Relevance confirmed from Zextensions *) ].
-Lemma Zmult_lt_reg_r : (a, b, c : Z) `0<c` -> `a*c<b*c` -> `a<b`.
-Proof.
-Intros a b c H0 H1.
-Apply Zlt_Zmult_right2 with c; Try Apply Zlt_gt; Assumption.
-Qed.
-
-Lemma Zle_mult_simpl : (a,b,c:Z)`c>0`->`a*c<=b*c`->`a<=b`.
-Proof.
-Intros x y z Hz Hxy.
-Elim (Zle_lt_or_eq `x*z` `y*z` Hxy).
-Intros; Apply Zlt_le_weak.
-Apply Zlt_Zmult_right2 with z; Trivial.
-Intros; Apply Zle_refl.
-Apply Zmult_reg_right with z.
-  Intro. Rewrite H0 in Hz. Contradiction (Zgt_antirefl `0`).
-Assumption.
-Qed.
-V7only [Notation Zle_Zmult_right2 := Zle_mult_simpl.
-(* Zle_Zmult_right2 :  (x,y,z:Z)`z>0` -> `x*z <= y*z` -> `x <= y`. *)
-].
-
-V7only [ (* Relevance confirmed from Zextensions *) ].
-Lemma Zmult_lt_0_le_reg_r: (x,y,z:Z)`0 <z`->`x*z <= y*z`->`x <= y`.
-Intros x y z; Intros ; Apply Zle_mult_simpl with z.
-Try Apply Zlt_gt; Assumption.
-Assumption.
-Qed.
-
-V7only [Unset Implicit Arguments.].
-
-Lemma Zge_mult_simpl : (a,b,c:Z) `c>0`->`a*c>=b*c`->`a>=b`.
-Intros a b c H1 H2; Apply Zle_ge; Apply Zle_mult_simpl with c; Trivial.
-Apply Zge_le; Trivial.
-Qed.
-
-Lemma Zgt_mult_simpl : (a,b,c:Z) `c>0`->`a*c>b*c`->`a>b`.
-Intros a b c H1 H2; Apply Zlt_gt; Apply Zlt_Zmult_right2 with c; Trivial.
-Apply Zgt_lt; Trivial.
-Qed.
-
-
-(** Compatibility of multiplication by a positive wrt to being positive *)
-
-Lemma Zle_ZERO_mult : (x,y:Z) `0<=x` -> `0<=y` -> `0<=x*y`.
-Proof.
-Intros x y; Case x.
-Intros; Rewrite Zero_mult_left; Trivial.
-Intros p H1; Unfold Zle.
-  Pattern 2 ZERO ; Rewrite <- (Zero_mult_right (POS p)).
-  Rewrite  Zcompare_Zmult_compatible; Trivial.
-Intros p H1 H2; Absurd (Zgt ZERO (NEG p)); Trivial.
-Unfold Zgt; Simpl; Auto with zarith.
-Qed.
-
-Lemma Zgt_ZERO_mult: (a,b:Z) `a>0`->`b>0`->`a*b>0`.
-Proof.
-Intros x y; Case x.
-Intros H; Discriminate H.
-Intros p H1; Unfold Zgt; 
-Pattern 2 ZERO ; Rewrite <- (Zero_mult_right (POS p)).
-  Rewrite  Zcompare_Zmult_compatible; Trivial.
-Intros p H; Discriminate H.
-Qed.
-
-V7only [ (* Relevance confirmed from Zextensions *) ].
-Lemma Zmult_lt_O_compat : (a, b : Z) `0<a` -> `0<b` -> `0<a*b`.
-Intros a b apos bpos.
-Apply Zgt_lt.
-Apply Zgt_ZERO_mult; Try Apply Zlt_gt; Assumption.
-Qed.
-
-Lemma Zle_mult: (x,y:Z) `x>0` -> `0<=y` -> `0<=(Zmult y x)`.
-Proof.
-Intros x y H1 H2; Apply Zle_ZERO_mult; Trivial.
-Apply Zlt_le_weak; Apply Zgt_lt; Trivial.
-Qed.
-
-(** Simplification of multiplication by a positive wrt to being positive *)
-
-Lemma Zmult_le: (x,y:Z) `x>0` -> `0<=(Zmult y x)` -> `0<=y`.
-Proof.
-Intros x y; Case x; [
-  Simpl; Unfold Zgt ; Simpl; Intros H; Discriminate H
-| Intros p H1; Unfold Zle; Rewrite -> Zmult_sym;
-  Pattern 1 ZERO ; Rewrite <- (Zero_mult_right (POS p));
-  Rewrite  Zcompare_Zmult_compatible; Auto with arith
-| Intros p; Unfold Zgt ; Simpl; Intros H; Discriminate H].
-Qed.
-
-Lemma Zmult_lt: (x,y:Z) `x>0` -> `0<y*x` -> `0<y`.
-Proof.
-Intros x y; Case x; [
-  Simpl; Unfold Zgt ; Simpl; Intros H; Discriminate H
-| Intros p H1; Unfold Zlt; Rewrite -> Zmult_sym;
-  Pattern 1 ZERO ; Rewrite <- (Zero_mult_right (POS p));
-  Rewrite  Zcompare_Zmult_compatible; Auto with arith
-| Intros p; Unfold Zgt ; Simpl; Intros H; Discriminate H].
-Qed.
-
-V7only [ (* Relevance confirmed from Zextensions *) ].
-Lemma Zmult_lt_0_reg_r : (x,y:Z)`0 < x`->`0 < y*x`->`0 < y`.
-Proof.
-Intros x y; Intros; EApply Zmult_lt with x ; Try Apply Zlt_gt; Assumption.
-Qed.
-
-Lemma Zmult_gt: (x,y:Z) `x>0` -> `x*y>0` -> `y>0`.
-Proof.
-Intros x y; Case x.
- Intros H; Discriminate H.
- Intros p H1; Unfold Zgt.
- Pattern 1 ZERO ; Rewrite <- (Zero_mult_right (POS p)).
- Rewrite  Zcompare_Zmult_compatible; Trivial.
-Intros p H; Discriminate H.
-Qed.
-
-(** Simplification of square wrt order *)
-
-Lemma Zgt_square_simpl: (x, y : Z) `x>=0` -> `y>=0` -> `x*x>y*y` -> `x>y`.
-Proof.
-Intros x y H0 H1 H2.
-Case (dec_Zlt y x).
-Intro; Apply Zlt_gt; Trivial.
-Intros H3; Cut (Zge y x).
-Intros H.
-Elim Zgt_not_le with 1 := H2.
-Apply Zge_le.
-Apply Zge_Zmult_pos_compat; Auto.
-Apply not_Zlt; Trivial.
-Qed.
-
-Lemma Zlt_square_simpl: (x,y:Z) `0<=x` -> `0<=y` -> `y*y<x*x` -> `y<x`.
-Proof.
-Intros x y H0 H1 H2.
-Apply Zgt_lt.
-Apply Zgt_square_simpl; Try Apply Zle_ge; Try Apply Zlt_gt; Assumption.
-Qed.
-
-(** Equivalence between inequalities *)
-
-Lemma Zle_plus_swap : (x,y,z:Z) `x+z<=y` <-> `x<=y-z`.
-Proof.
-    Intros x y z; Intros. Split. Intro. Rewrite <- (Zero_right x). Rewrite <- (Zplus_inverse_r z).
-    Rewrite Zplus_assoc_l. Exact (Zle_reg_r ? ? ? H).
-    Intro. Rewrite <- (Zero_right y). Rewrite <- (Zplus_inverse_l z). Rewrite Zplus_assoc_l.
-    Apply Zle_reg_r. Assumption.
-Qed.
-
-Lemma Zlt_plus_swap : (x,y,z:Z) `x+z<y` <-> `x<y-z`.
-Proof.
-    Intros x y z; Intros. Split. Intro. Unfold Zminus. Rewrite Zplus_sym. Rewrite <- (Zero_left x).
-    Rewrite <- (Zplus_inverse_l z). Rewrite Zplus_assoc_r. Apply Zlt_reg_l. Rewrite Zplus_sym.
-    Assumption.
-    Intro. Rewrite Zplus_sym. Rewrite <- (Zero_left y). Rewrite <- (Zplus_inverse_r z).
-    Rewrite Zplus_assoc_r. Apply Zlt_reg_l. Rewrite Zplus_sym. Assumption.
-Qed.
-
-Lemma Zeq_plus_swap : (x,y,z:Z)`x+z=y` <-> `x=y-z`.
-Proof.
-Intros x y z; Intros. Split. Intro. Apply Zplus_minus. Symmetry. Rewrite Zplus_sym. 
-  Assumption.
-Intro. Rewrite H. Unfold Zminus. Rewrite Zplus_assoc_r. 
-  Rewrite Zplus_inverse_l. Apply Zero_right.
-Qed.
-
-Lemma Zlt_minus : (n,m:Z)`0<m`->`n-m<n`.
-Proof.
-Intros n m H; Apply Zsimpl_lt_plus_l with p:=m; Rewrite Zle_plus_minus;
-Pattern 1 n ;Rewrite <- (Zero_right n); Rewrite (Zplus_sym m n);
-Apply Zlt_reg_l; Assumption.
-Qed.
-
-Lemma Zlt_O_minus_lt : (n,m:Z)`0<n-m`->`m<n`.
-Proof.
-Intros n m H; Apply Zsimpl_lt_plus_l with p:=(Zopp m); Rewrite Zplus_inverse_l;
-Rewrite Zplus_sym;Exact H.
-Qed.
diff --git a/theories7/ZArith/Zpower.v b/theories7/ZArith/Zpower.v
deleted file mode 100644
index 97c2b3c9..00000000
--- a/theories7/ZArith/Zpower.v
+++ /dev/null
@@ -1,394 +0,0 @@
-(************************************************************************)
-(*  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: Zpower.v,v 1.2.2.1 2004/07/16 19:31:44 herbelin Exp $ i*)
-
-Require ZArith_base.
-Require Omega.
-Require Zcomplements.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-Section section1.
-
-(** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary
-    integer (type [nat]) and [z] a signed integer (type [Z]) *) 
-
-Definition Zpower_nat := 
-  [z:Z][n:nat] (iter_nat n Z ([x:Z]` z * x `) `1`).
-
-(** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for
-    [plus : nat->nat] and [Zmult : Z->Z] *)
-
-Lemma Zpower_nat_is_exp : 
-  (n,m:nat)(z:Z)
-  `(Zpower_nat z (plus n m)) = (Zpower_nat z n)*(Zpower_nat z m)`.
-
-Intros; Elim n; 
-[ Simpl; Elim (Zpower_nat z m); Auto with zarith
-| Unfold Zpower_nat; Intros;  Simpl; Rewrite H;
-  Apply Zmult_assoc].
-Qed.
-
-(** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary
-    integer (type [positive]) and [z] a signed integer (type [Z]) *) 
-
-Definition Zpower_pos := 
-  [z:Z][n:positive] (iter_pos n Z ([x:Z]`z * x`) `1`).
-
-(** This theorem shows that powers of unary and binary integers
-   are the same thing, modulo the function convert : [positive -> nat] *)
-
-Theorem Zpower_pos_nat : 
-  (z:Z)(p:positive)(Zpower_pos z p) = (Zpower_nat z (convert p)).
-
-Intros; Unfold Zpower_pos; Unfold Zpower_nat; Apply iter_convert.
-Qed.
-
-(** Using the theorem [Zpower_pos_nat] and the lemma [Zpower_nat_is_exp] we
-   deduce that the function [[n:positive](Zpower_pos z n)] is a morphism
-   for [add : positive->positive] and [Zmult : Z->Z] *)
-
-Theorem Zpower_pos_is_exp : 
-  (n,m:positive)(z:Z) 
-  ` (Zpower_pos z (add n m)) = (Zpower_pos z n)*(Zpower_pos z m)`.
-
-Intros.
-Rewrite -> (Zpower_pos_nat z n).
-Rewrite -> (Zpower_pos_nat z m).
-Rewrite -> (Zpower_pos_nat z (add n m)).
-Rewrite -> (convert_add n m).
-Apply Zpower_nat_is_exp.
-Qed.
-
-Definition Zpower :=
-  [x,y:Z]Cases y of
-    (POS p) => (Zpower_pos x p)
-  | ZERO => `1`
-  | (NEG p) => `0`
-  end.
-
-V8Infix "^" Zpower : Z_scope.
-
-Hints Immediate Zpower_nat_is_exp : zarith.
-Hints Immediate Zpower_pos_is_exp : zarith.
-Hints Unfold  Zpower_pos : zarith.
-Hints Unfold  Zpower_nat : zarith.
-
-Lemma Zpower_exp : (x:Z)(n,m:Z)
-  `n >= 0` -> `m >= 0` -> `(Zpower x (n+m))=(Zpower x n)*(Zpower x m)`.
-NewDestruct n; NewDestruct m; Auto with zarith.
-Simpl; Intros; Apply Zred_factor0.
-Simpl; Auto with zarith.
-Intros; Compute in H0; Absurd INFERIEUR=INFERIEUR; Auto with zarith.
-Intros; Compute in H0; Absurd INFERIEUR=INFERIEUR; Auto with zarith.
-Qed.
-
-End section1.
-
-(* Exporting notation "^" *)
-
-V8Infix "^" Zpower : Z_scope.
-
-Hints Immediate Zpower_nat_is_exp : zarith.
-Hints Immediate Zpower_pos_is_exp : zarith.
-Hints Unfold  Zpower_pos : zarith.
-Hints Unfold  Zpower_nat : zarith.
-
-Section Powers_of_2.
-
-(** For the powers of two, that will be widely used, a more direct
-   calculus is possible. We will also prove some properties such
-   as [(x:positive) x < 2^x] that are true for all integers bigger
-   than 2 but more difficult to prove and useless. *)     
-
-(** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *)
-
-Definition shift_nat := 
-  [n:nat][z:positive](iter_nat n positive xO z). 
-Definition shift_pos :=
-  [n:positive][z:positive](iter_pos n positive xO z). 
-Definition shift :=
-  [n:Z][z:positive]
-  Cases n of
-    ZERO => z
-  | (POS p) => (iter_pos p positive xO z)
-  | (NEG p) => z
-  end.
-
-Definition two_power_nat := [n:nat] (POS (shift_nat n xH)).
-Definition two_power_pos := [x:positive] (POS (shift_pos x xH)).
-
-Lemma two_power_nat_S : 
-  (n:nat)` (two_power_nat (S n)) = 2*(two_power_nat n)`.
-Intro; Simpl; Apply refl_equal.
-Qed.
-
-Lemma shift_nat_plus :
-  (n,m:nat)(x:positive)
-    (shift_nat (plus n m) x)=(shift_nat n (shift_nat m x)).
-
-Intros; Unfold shift_nat; Apply iter_nat_plus.
-Qed.
-
-Theorem shift_nat_correct :
-  (n:nat)(x:positive)(POS (shift_nat n x))=`(Zpower_nat 2 n)*(POS x)`.
-
-Unfold shift_nat; Induction n; 
-[ Simpl; Trivial with zarith
-| Intros; Replace (Zpower_nat `2` (S n0)) with `2 * (Zpower_nat 2 n0)`;
-[ Rewrite <- Zmult_assoc; Rewrite <- (H x); Simpl; Reflexivity
-| Auto with zarith ]
-].
-Qed.
-
-Theorem two_power_nat_correct :
-  (n:nat)(two_power_nat n)=(Zpower_nat `2` n).
-
-Intro n.
-Unfold two_power_nat.
-Rewrite -> (shift_nat_correct n).
-Omega.
-Qed.
-  
-(** Second we show that [two_power_pos] and [two_power_nat] are the same *)
-Lemma shift_pos_nat : (p:positive)(x:positive)
-  (shift_pos p x)=(shift_nat (convert p) x).
-
-Unfold shift_pos.
-Unfold shift_nat.
-Intros; Apply iter_convert.
-Qed.
-
-Lemma two_power_pos_nat : 
-  (p:positive) (two_power_pos p)=(two_power_nat (convert p)).
-
-Intro; Unfold two_power_pos; Unfold two_power_nat.
-Apply f_equal with f:=POS.
-Apply shift_pos_nat.
-Qed.
-
-(** Then we deduce that [two_power_pos] is also correct *)
-
-Theorem shift_pos_correct :
-  (p,x:positive) ` (POS (shift_pos p x)) = (Zpower_pos 2 p) * (POS x)`.
-
-Intros.
-Rewrite -> (shift_pos_nat p x).
-Rewrite -> (Zpower_pos_nat `2` p).
-Apply shift_nat_correct.
-Qed.
-
-Theorem two_power_pos_correct : 
-  (x:positive) (two_power_pos x)=(Zpower_pos `2` x).
-
-Intro.
-Rewrite -> two_power_pos_nat.
-Rewrite -> Zpower_pos_nat.
-Apply two_power_nat_correct.
-Qed.
-
-(** Some consequences *)
-
-Theorem two_power_pos_is_exp :
-  (x,y:positive) (two_power_pos (add x y))
-    =(Zmult (two_power_pos x) (two_power_pos y)).
-Intros.
-Rewrite -> (two_power_pos_correct (add x y)).
-Rewrite -> (two_power_pos_correct x).
-Rewrite -> (two_power_pos_correct y).
-Apply Zpower_pos_is_exp.
-Qed.
-
-(** The exponentiation [z -> 2^z] for [z] a signed integer. 
-    For convenience, we assume that [2^z = 0] for all [z < 0]
-    We could also define a inductive type [Log_result] with
-    3 contructors [ Zero | Pos positive -> | minus_infty]
-    but it's more complexe and not so useful. *)
- 
-Definition two_p :=
-  [x:Z]Cases x of
-         ZERO    => `1`
-       | (POS y) => (two_power_pos y)
-       | (NEG y) => `0`
-       end.
-
-Theorem two_p_is_exp :
-  (x,y:Z) ` 0 <= x` -> ` 0 <= y` -> 
-    ` (two_p (x+y)) = (two_p x)*(two_p y)`.
-Induction x; 
-[ Induction y; Simpl; Auto with zarith
-| Induction y; 
-  [ Unfold two_p;  Rewrite -> (Zmult_sym (two_power_pos p) `1`);
-    Rewrite -> (Zmult_one (two_power_pos p)); Auto with zarith
-  | Unfold Zplus; Unfold two_p;
-    Intros; Apply two_power_pos_is_exp
-  | Intros; Unfold Zle in H0; Unfold Zcompare in H0; 
-    Absurd SUPERIEUR=SUPERIEUR; Trivial with zarith
-  ]
-| Induction y; 
-  [ Simpl; Auto with zarith
-  | Intros; Unfold Zle in H; Unfold Zcompare in H;
-    Absurd (SUPERIEUR=SUPERIEUR); Trivial with zarith
-  | Intros; Unfold Zle in H; Unfold Zcompare in H;
-    Absurd (SUPERIEUR=SUPERIEUR); Trivial with zarith
-  ]
-].
-Qed.
-
-Lemma two_p_gt_ZERO : (x:Z) ` 0 <= x` -> ` (two_p x) > 0`.
-Induction x; Intros;
-[ Simpl; Omega
-| Simpl; Unfold two_power_pos; Apply POS_gt_ZERO
-| Absurd ` 0 <= (NEG p)`;
-  [ Simpl; Unfold Zle; Unfold Zcompare;
-    Do 2 Unfold not; Auto with zarith
-  | Assumption ]
-].
-Qed.
-
-Lemma two_p_S : (x:Z) ` 0 <= x` -> 
- `(two_p (Zs x)) = 2 * (two_p x)`.
-Intros; Unfold Zs. 
-Rewrite (two_p_is_exp x `1` H (ZERO_le_POS xH)).
-Apply Zmult_sym.
-Qed.
-
-Lemma two_p_pred : 
-  (x:Z)` 0 <= x` -> ` (two_p (Zpred x)) < (two_p x)`.
-Intros; Apply natlike_ind 
-with P:=[x:Z]` (two_p (Zpred x)) < (two_p x)`;
-[ Simpl; Unfold Zlt; Auto with zarith
-| Intros; Elim (Zle_lt_or_eq `0` x0 H0);
-  [ Intros;
-    Replace (two_p (Zpred (Zs x0)))
-    with (two_p (Zs (Zpred x0)));
-    [ Rewrite -> (two_p_S (Zpred x0));
-      [ Rewrite -> (two_p_S x0);
-      	[ Omega
-      	| Assumption]
-      | Apply Zlt_ZERO_pred_le_ZERO; Assumption]
-    | Rewrite <- (Zs_pred x0); Rewrite <- (Zpred_Sn x0); Trivial with zarith]
-  | Intro Hx0; Rewrite <- Hx0; Simpl; Unfold Zlt; Auto with zarith]
-| Assumption].
-Qed. 
-
-Lemma Zlt_lt_double : (x,y:Z) ` 0 <= x < y` -> ` x < 2*y`.
-Intros; Omega. Qed. 
-
-End Powers_of_2.
-
-Hints Resolve two_p_gt_ZERO : zarith.
-Hints Immediate two_p_pred two_p_S : zarith.
-
-Section power_div_with_rest.
-
-(** Division by a power of two.
-    To [n:Z] and [p:positive], [q],[r] are associated such that
-    [n = 2^p.q + r] and [0 <= r < 2^p] *)
-
-(** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<= r < d /\ 0 <= r' < d'] *)
-Definition Zdiv_rest_aux :=
-  [qrd:(Z*Z)*Z] 
-  let (qr,d)=qrd in let (q,r)=qr in
-  (Cases q of
-     ZERO => ` (0, r)`
-   | (POS xH) => ` (0, d + r)`
-   | (POS (xI n)) => ` ((POS n), d + r)`
-   | (POS (xO n)) => ` ((POS n), r)`
-   | (NEG xH) => ` (-1, d + r)`
-   | (NEG (xI n)) => ` ((NEG n) - 1, d + r)`
-   | (NEG (xO n)) => ` ((NEG n), r)`
-   end, ` 2*d`).
-
-Definition Zdiv_rest := 
-  [x:Z][p:positive]let (qr,d)=(iter_pos p ? Zdiv_rest_aux ((x,`0`),`1`)) in qr.
-
-Lemma Zdiv_rest_correct1 :
-  (x:Z)(p:positive)
-  let (qr,d)=(iter_pos p ? Zdiv_rest_aux ((x,`0`),`1`)) in d=(two_power_pos p).
-
-Intros x p; 
-Rewrite (iter_convert p ? Zdiv_rest_aux ((x,`0`),`1`));
-Rewrite (two_power_pos_nat p);
-Elim (convert p); Simpl;
-[ Trivial with zarith
-| Intro n; Rewrite (two_power_nat_S n);
-  Unfold 2 Zdiv_rest_aux;
-  Elim (iter_nat n (Z*Z)*Z Zdiv_rest_aux ((x,`0`),`1`));
-  NewDestruct a; Intros; Apply f_equal with f:=[z:Z]`2*z`; Assumption ]. 
-Qed.
-
-Lemma Zdiv_rest_correct2 :
-  (x:Z)(p:positive)
-  let (qr,d)=(iter_pos p ? Zdiv_rest_aux ((x,`0`),`1`)) in
-  let (q,r)=qr in
-  ` x=q*d + r` /\ ` 0 <= r < d`.
-
-Intros; Apply iter_pos_invariant with
-  f:=Zdiv_rest_aux
-  Inv:=[qrd:(Z*Z)*Z]let (qr,d)=qrd in let (q,r)=qr in
-                      ` x=q*d + r` /\ ` 0 <= r < d`;
-[ Intro x0; Elim x0; Intro y0; Elim y0;
-  Intros q r d; Unfold Zdiv_rest_aux; 
-  Elim q;
-  [ Omega
-  | NewDestruct p0; 
-    [ Rewrite POS_xI; Intro; Elim H; Intros; Split; 
-      [ Rewrite H0; Rewrite Zplus_assoc;
-      	Rewrite Zmult_plus_distr_l;
-      	Rewrite Zmult_1_n; Rewrite Zmult_assoc;
-      	Rewrite (Zmult_sym (POS p0) `2`); Apply refl_equal
-      | Omega ]
-    | Rewrite POS_xO; Intro; Elim H; Intros; Split;
-      [ Rewrite H0;
-      	Rewrite Zmult_assoc; Rewrite (Zmult_sym (POS p0) `2`);
-      	Apply refl_equal  
-      | Omega ]
-    | Omega ]
-  | NewDestruct p0; 
-    [ Rewrite NEG_xI; Unfold Zminus; Intro; Elim H; Intros; Split; 
-      [ Rewrite H0; Rewrite Zplus_assoc;
-      	Apply f_equal with f:=[z:Z]`z+r`;
-      	Do 2 (Rewrite Zmult_plus_distr_l);
-       	Rewrite Zmult_assoc; 
-      	Rewrite (Zmult_sym (NEG p0) `2`);
-      	Rewrite <- Zplus_assoc;
-	Apply f_equal with f:=[z:Z]`2 * (NEG p0) * d + z`; 
-      	Omega
-      | Omega ]
-    | Rewrite NEG_xO; Unfold Zminus; Intro; Elim H; Intros; Split;
-      [ Rewrite H0;
-      	Rewrite Zmult_assoc; Rewrite (Zmult_sym (NEG p0) `2`);
-      	Apply refl_equal  
-      | Omega ]
-    | Omega ] ]
-| Omega].
-Qed.
-
-Inductive Set Zdiv_rest_proofs[x:Z; p:positive] :=
-  Zdiv_rest_proof : (q:Z)(r:Z) 
-     `x = q * (two_power_pos p) + r` 
-       -> `0 <= r`
-        -> `r < (two_power_pos p)` 
-      	 -> (Zdiv_rest_proofs x p).
-
-Lemma  Zdiv_rest_correct :
-  (x:Z)(p:positive)(Zdiv_rest_proofs x p).
-Intros x p.
-Generalize (Zdiv_rest_correct1 x p); Generalize (Zdiv_rest_correct2 x p).
-Elim  (iter_pos p (Z*Z)*Z Zdiv_rest_aux ((x,`0`),`1`)).
-Induction a.
-Intros.
-Elim H; Intros H1 H2; Clear H.
-Rewrite -> H0 in H1; Rewrite -> H0 in H2;
-Elim H2; Intros;
-Apply Zdiv_rest_proof with q:=a0 r:=b; Assumption.
-Qed.
-
-End power_div_with_rest.
diff --git a/theories7/ZArith/Zsqrt.v b/theories7/ZArith/Zsqrt.v
deleted file mode 100644
index 72a2e9cf..00000000
--- a/theories7/ZArith/Zsqrt.v
+++ /dev/null
@@ -1,136 +0,0 @@
-(************************************************************************)
-(*  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: Zsqrt.v,v 1.1.2.1 2004/07/16 19:31:44 herbelin Exp $ *)
-
-Require Omega.
-Require Export ZArith_base.
-Require Export ZArithRing.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-(**********************************************************************)
-(** Definition and properties of square root on Z *)
-
-(** The following tactic replaces all instances of (POS (xI ...)) by
-    `2*(POS ...)+1` , but only when ... is not made only with xO, XI, or xH. *)
-Tactic Definition compute_POS :=
-  Match Context With
-  | [|- [(POS (xI ?1))]] ->
-    (Match ?1 With
-     | [[xH]] -> Fail
-     | _ -> Rewrite (POS_xI ?1))
-  | [|- [(POS (xO ?1))]] ->
-    (Match ?1 With
-     | [[xH]] -> Fail
-     | _ -> Rewrite (POS_xO ?1)).
-
-Inductive sqrt_data [n : Z] : Set :=
-  c_sqrt: (s, r :Z)`n=s*s+r`->`0<=r<=2*s`->(sqrt_data n) .
-
-Definition sqrtrempos: (p : positive)  (sqrt_data (POS p)).
-Refine (Fix sqrtrempos {
-         sqrtrempos [p : positive] : (sqrt_data (POS p)) :=
-            <[p : ?]  (sqrt_data (POS p))> Cases p of
-                xH => (c_sqrt `1` `1` `0` ? ?)
-               | (xO xH) => (c_sqrt `2` `1` `1` ? ?)
-               | (xI xH) => (c_sqrt `3` `1` `2` ? ?)
-               | (xO (xO p')) =>
-                   Cases (sqrtrempos p') of
-                     (c_sqrt s' r' Heq Hint) =>
-                       Cases (Z_le_gt_dec `4*s'+1` `4*r'`) of
-                         (left Hle) =>
-                           (c_sqrt (POS (xO (xO p'))) `2*s'+1` `4*r'-(4*s'+1)` ? ?)
-                        | (right Hgt) =>
-                            (c_sqrt (POS (xO (xO p'))) `2*s'` `4*r'` ? ?)
-                       end
-                   end
-               | (xO (xI p')) =>
-                   Cases (sqrtrempos p') of
-                     (c_sqrt s' r' Heq Hint) =>
-                       Cases
-                        (Z_le_gt_dec `4*s'+1` `4*r'+2`) of
-                         (left Hle) =>
-                           (c_sqrt 
-			     (POS (xO (xI p'))) `2*s'+1` `4*r'+2-(4*s'+1)` ? ?)
-                        | (right Hgt) =>
-                            (c_sqrt (POS (xO (xI p'))) `2*s'` `4*r'+2` ? ?)
-                       end
-                   end
-               | (xI (xO p')) =>
-                   Cases (sqrtrempos p') of
-                     (c_sqrt s' r' Heq Hint) =>
-                       Cases
-                        (Z_le_gt_dec `4*s'+1` `4*r'+1`) of
-                         (left Hle) =>
-                           (c_sqrt
-                            (POS (xI (xO p'))) `2*s'+1` `4*r'+1-(4*s'+1)` ? ?)
-                        | (right Hgt) =>
-                            (c_sqrt (POS (xI (xO p'))) `2*s'` `4*r'+1` ? ?)
-                       end
-                   end
-               | (xI (xI p')) =>
-                   Cases (sqrtrempos p') of
-                     (c_sqrt s' r' Heq Hint) =>
-                       Cases
-                        (Z_le_gt_dec `4*s'+1` `4*r'+3`) of
-                         (left Hle) =>
-                           (c_sqrt
-                            (POS (xI (xI p'))) `2*s'+1` `4*r'+3-(4*s'+1)` ? ?)
-                        | (right Hgt) =>
-                            (c_sqrt (POS (xI (xI p'))) `2*s'` `4*r'+3` ? ?)
-                       end
-                   end
-            end
-        }); Clear sqrtrempos; Repeat compute_POS;
- Try (Try Rewrite Heq; Ring; Fail); Try Omega.
-Defined.
-
-(** Define with integer input, but with a strong (readable) specification. *)
-Definition Zsqrt : (x:Z)`0<=x`->{s:Z & {r:Z | x=`s*s+r` /\ `s*s<=x<(s+1)*(s+1)`}}.
-Refine [x]
-   <[x:Z]`0<=x`->{s:Z & {r:Z | x=`s*s+r` /\ `s*s<=x<(s+1)*(s+1)`}}>Cases x of
-       (POS p) => [h]Cases (sqrtrempos p) of
-                    (c_sqrt s r Heq Hint) =>
-                  (existS ? [s:Z]{r:Z | `(POS p)=s*s+r` /\ 
-		                         `s*s<=(POS p)<(s+1)*(s+1)`}
-		   s
-                    (exist Z [r:Z]((POS p)=`s*s+r` /\ `s*s<=(POS p)<(s+1)*(s+1)`)
-                       r ?))
-                  end
-     | (NEG p) => [h](False_rec 
-		         {s:Z & {r:Z |
-			     (NEG p)=`s*s+r` /\ `s*s<=(NEG p)<(s+1)*(s+1)`}}
-                         (h (refl_equal ? SUPERIEUR)))
-     | ZERO => [h](existS ? [s:Z]{r:Z | `0=s*s+r` /\ `s*s<=0<(s+1)*(s+1)`}
-		     `0` (exist Z [r:Z](`0=0*0+r`/\`0*0<=0<(0+1)*(0+1)`)
-		     `0` ?))
-     end;Try Omega.
-Split;[Omega|Rewrite Heq;Ring `(s+1)*(s+1)`;Omega].
-Defined.
-
-(** Define a function of type Z->Z that computes the integer square root,
-    but only for positive numbers, and 0 for others. *)
-Definition Zsqrt_plain : Z->Z :=
-  [x]Cases x of
-    (POS p)=>Cases (Zsqrt (POS p) (ZERO_le_POS p)) of (existS s _) => s end
-   |(NEG p)=>`0`
-   |ZERO=>`0`
-   end.
-
-(** A basic theorem about Zsqrt_plain *)
-Theorem Zsqrt_interval :(x:Z)`0<=x`->
-  `(Zsqrt_plain x)*(Zsqrt_plain x)<= x < ((Zsqrt_plain x)+1)*((Zsqrt_plain x)+1)`.
-Intros x;Case x.
-Unfold Zsqrt_plain;Omega.
-Intros p;Unfold Zsqrt_plain;Case (Zsqrt (POS p) (ZERO_le_POS p)).
-Intros s (r,(Heq,Hint)) Hle;Assumption.
-Intros p Hle;Elim Hle;Auto.
-Qed.
-
-
diff --git a/theories7/ZArith/Zsyntax.v b/theories7/ZArith/Zsyntax.v
deleted file mode 100644
index 3c7f3a57..00000000
--- a/theories7/ZArith/Zsyntax.v
+++ /dev/null
@@ -1,278 +0,0 @@
-(************************************************************************)
-(*  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: Zsyntax.v,v 1.1.2.1 2004/07/16 19:31:44 herbelin Exp $ i*)
-
-Require Export BinInt.
-
-V7only[
-
-Grammar znatural ident :=
-  nat_id [ prim:var($id) ] -> [$id]
-
-with number :=
-
-with negnumber := 
-
-with formula : constr :=
-  form_expr [ expr($p) ] -> [$p]
-(*| form_eq [ expr($p) "=" expr($c) ] -> [ (eq Z $p $c) ]*)
-| form_eq [ expr($p) "=" expr($c) ] -> [ (Coq.Init.Logic.eq ? $p $c) ]
-| form_le [ expr($p) "<=" expr($c) ] -> [ (Zle $p $c) ]
-| form_lt [ expr($p) "<" expr($c) ] -> [ (Zlt $p $c) ]
-| form_ge [ expr($p) ">=" expr($c) ] -> [ (Zge $p $c) ]
-| form_gt [ expr($p) ">" expr($c) ] -> [ (Zgt $p $c) ]
-(*| form_eq_eq [ expr($p) "=" expr($c) "=" expr($c1) ]
-              -> [ (eq Z $p $c)/\(eq Z $c $c1) ]*)
-| form_eq_eq [ expr($p) "=" expr($c) "=" expr($c1) ]
-              -> [ (Coq.Init.Logic.eq ? $p $c)/\(Coq.Init.Logic.eq ? $c $c1) ]
-| form_le_le [ expr($p) "<=" expr($c) "<=" expr($c1) ]
-              -> [ (Zle $p $c)/\(Zle $c $c1) ]
-| form_le_lt [ expr($p) "<=" expr($c) "<" expr($c1) ]
-              -> [ (Zle $p $c)/\(Zlt $c $c1) ]
-| form_lt_le [ expr($p) "<" expr($c) "<=" expr($c1) ]
-              -> [ (Zlt $p $c)/\(Zle $c $c1) ]
-| form_lt_lt [ expr($p) "<" expr($c) "<" expr($c1) ]
-              -> [ (Zlt $p $c)/\(Zlt $c $c1) ]
-(*| form_neq  [ expr($p) "<>" expr($c) ] -> [  ~(Coq.Init.Logic.eq Z $p $c) ]*)
-| form_neq  [ expr($p) "<>" expr($c) ] -> [  ~(Coq.Init.Logic.eq ? $p $c) ]
-| form_comp [ expr($p) "?=" expr($c) ] -> [ (Zcompare $p $c) ]
-
-with expr : constr :=
-  expr_plus [ expr($p) "+" expr($c) ] -> [ (Zplus $p $c) ]
-| expr_minus [ expr($p) "-" expr($c) ] -> [ (Zminus $p $c) ]
-| expr2 [ expr2($e) ] -> [$e]
-
-with expr2 : constr :=
-  expr_mult [ expr2($p) "*" expr2($c) ] -> [ (Zmult $p $c) ]
-| expr1 [ expr1($e) ] -> [$e]
-
-with expr1 : constr :=
-  expr_abs [ "|" expr($c) "|" ] -> [ (Zabs $c) ]
-| expr0 [ expr0($e) ] -> [$e]
-
-with expr0 : constr :=
-  expr_id [ constr:global($c) ] -> [ $c ]
-| expr_com [ "[" constr:constr($c) "]" ] -> [$c]
-| expr_appl [ "(" application($a) ")" ] -> [$a]
-| expr_num [ number($s) ] -> [$s ]
-| expr_negnum [ "-" negnumber($n) ] -> [ $n ]
-| expr_inv [ "-" expr0($c) ] -> [ (Zopp $c) ] 
-| expr_meta [ zmeta($m) ] -> [ $m ]
-
-with zmeta :=
-| rimpl [ "?" ] -> [ ? ]
-| rmeta0 [ "?" "0" ] -> [ ?0 ]
-| rmeta1 [ "?" "1" ] -> [ ?1 ]
-| rmeta2 [ "?" "2" ] -> [ ?2 ]
-| rmeta3 [ "?" "3" ] -> [ ?3 ]
-| rmeta4 [ "?" "4" ] -> [ ?4 ]
-| rmeta5 [ "?" "5" ] -> [ ?5 ]
-
-with application : constr :=
-  apply [ application($p) expr($c1) ] -> [ ($p $c1) ]
-| apply_inject_nat [ "inject_nat" constr:constr($c1) ] -> [ (inject_nat $c1) ]
-| pair [ expr($p) "," expr($c) ] -> [ ($p, $c) ]
-| appl0 [ expr($a) ] -> [$a]
-.
-
-Grammar constr constr0 :=
-  z_in_com [ "`" znatural:formula($c) "`" ] -> [$c].
-
-Grammar constr pattern :=
-  z_in_pattern [ "`" prim:bigint($c) "`" ] -> [ 'Z: $c ' ].   
-
-(* The symbols "`" "`" must be printed just once at the top of the expressions,
-  to avoid printings like |``x` + `y`` < `45`| 
-  for |x + y < 45|.
-  So when a Z-expression is to be printed, its sub-expresssions are
-  enclosed into an ast (ZEXPR \$subexpr), which is printed like \$subexpr
-  but without symbols "`" "`" around. 
-
-  There is just one problem: NEG and Zopp have the same printing rules.
-  If Zopp is opaque, we may not be able to solve a goal like
-  ` -5 = -5 ` by reflexivity. (In fact, this precise Goal is solved
-  by the Reflexivity tactic, but more complex problems may arise 
-
-  SOLUTION : Print (Zopp 5) for constants and -x for variables *)
-
-Syntax constr
-  level 0:
-    Zle [ (Zle $n1 $n2) ] -> 
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "<= " (ZEXPR $n2) "`"]]
-  | Zlt [ (Zlt $n1 $n2) ] -> 
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "< " (ZEXPR $n2) "`" ]]
-  | Zge [ (Zge $n1 $n2) ] -> 
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] ">= " (ZEXPR $n2) "`" ]]
-  | Zgt [ (Zgt $n1 $n2) ] -> 
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "> " (ZEXPR $n2) "`" ]]
-  | Zcompare [<<(Zcompare $n1 $n2)>>] ->
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "?= " (ZEXPR $n2) "`" ]]
-  | Zeq [ (eq Z $n1 $n2) ] -> 
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "= " (ZEXPR $n2)"`"]]
-  | Zneq [ ~(eq Z $n1 $n2) ] ->
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "<> " (ZEXPR $n2) "`"]]
-  | Zle_Zle [ (Zle $n1 $n2)/\(Zle $n2 $n3) ] ->
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "<= " (ZEXPR $n2)
-                                [1 0] "<= " (ZEXPR $n3) "`"]]
-  | Zle_Zlt [ (Zle $n1 $n2)/\(Zlt $n2 $n3) ] ->
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "<= " (ZEXPR $n2)
-                                [1 0] "< " (ZEXPR $n3) "`"]]
-  | Zlt_Zle [ (Zlt $n1 $n2)/\(Zle $n2 $n3) ] ->
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "< " (ZEXPR $n2)
-                                [1 0] "<= " (ZEXPR $n3) "`"]]
-  | Zlt_Zlt [ (Zlt $n1 $n2)/\(Zlt $n2 $n3) ] ->
-      [[<hov 0> "`" (ZEXPR $n1) [1 0] "< " (ZEXPR $n2)
-                                [1 0] "< " (ZEXPR $n3) "`"]]
-  | ZZero_v7 [ ZERO ] -> [ "`0`" ]
-  | ZPos_v7 [ (POS $r) ] -> [$r:"positive_printer":9]
-  | ZNeg_v7 [ (NEG $r) ] -> [$r:"negative_printer":9]
-  ;
-
-  level 7:
-    Zplus [ (Zplus $n1 $n2) ]
-      -> [ [<hov 0> "`" (ZEXPR $n1):E "+"  [0 0] (ZEXPR $n2):L "`"] ]
-  | Zminus [ (Zminus $n1 $n2) ]
-      -> [ [<hov 0> "`" (ZEXPR $n1):E "-" [0 0] (ZEXPR $n2):L "`"] ]
-  ;
-
-  level 6:
-    Zmult [ (Zmult $n1 $n2) ]
-      -> [ [<hov 0> "`" (ZEXPR $n1):E "*" [0 0] (ZEXPR $n2):L "`"] ]
-  ;
-
-  level 8:
-    Zopp [ (Zopp $n1) ] -> [ [<hov 0> "`" "-" (ZEXPR $n1):E "`"] ]
-  | Zopp_POS [ (Zopp (POS $r)) ] -> 
-         [ [<hov 0> "`(" "Zopp" [1 0] $r:"positive_printer_inside"  ")`"] ]
-  | Zopp_ZERO [ (Zopp ZERO) ] -> [ [<hov 0> "`(" "Zopp" [1 0] "0" ")`"] ]
-  | Zopp_NEG [ (Zopp (NEG $r)) ] ->  
-         [ [<hov 0> "`(" "Zopp" [1 0] "(" $r:"negative_printer_inside" "))`"] ]
-  ;
-
-  level 4:
-    Zabs [ (Zabs $n1) ] -> [  [<hov 0> "`|" (ZEXPR $n1):E "|`"] ]
-  ;
-
-  level 0:
-    escape_inside [ << (ZEXPR $r) >> ] -> [ "[" $r:E "]" ]
-  ;
-
-  level 4:
-    Zappl_inside [ << (ZEXPR (APPLIST $h ($LIST $t))) >> ]
-      -> [ [<hov 0> "("(ZEXPR $h):E [1 0] (ZAPPLINSIDETAIL ($LIST $t)):E ")"] ]
-  | Zappl_inject_nat [ << (ZEXPR (APPLIST <<inject_nat>> $n)) >> ]
-      -> [ [<hov 0> "(inject_nat" [1 1] $n:L ")"] ]
-  | Zappl_inside_tail [ << (ZAPPLINSIDETAIL $h ($LIST $t)) >> ]
-      -> [(ZEXPR $h):E [1 0] (ZAPPLINSIDETAIL ($LIST $t)):E] 
-  | Zappl_inside_one [ << (ZAPPLINSIDETAIL $e) >> ] ->[(ZEXPR $e):E]
-  | pair_inside [ << (ZEXPR <<(pair $s1 $s2 $z1 $z2)>>) >> ] 
-      -> [ [<hov 0> "("(ZEXPR $z1):E "," [1 0] (ZEXPR $z2):E ")"] ]
-  ;
-
- level 3:
-    var_inside [ << (ZEXPR ($VAR $i)) >> ] -> [$i]
-  | secvar_inside [ << (ZEXPR (SECVAR $i)) >> ] -> [(SECVAR $i)]
-  | const_inside [ << (ZEXPR (CONST $c)) >> ] -> [(CONST $c)]
-  | mutind_inside [ << (ZEXPR (MUTIND $i $n)) >> ] 
-      -> [(MUTIND $i $n)]
-  | mutconstruct_inside [ << (ZEXPR (MUTCONSTRUCT $c1 $c2 $c3)) >> ]
-      -> [ (MUTCONSTRUCT $c1 $c2 $c3) ]
-
-  | O_inside [ << (ZEXPR << O >>) >> ] -> [ "O" ] (* To shunt Arith printer *)
-
-  (* Added by JCF, 9/3/98; updated HH, 11/9/01 *)
-  | implicit_head_inside [ << (ZEXPR (APPLISTEXPL ($LIST $c))) >> ]
-      -> [ (APPLIST ($LIST $c)) ]
-  | implicit_arg_inside  [ << (ZEXPR (EXPL "!" $n $c)) >> ] -> [ ]
-
-  ;
-
-  level 7:
-    Zplus_inside
-      [ << (ZEXPR <<(Zplus $n1 $n2)>>) >> ]
-      	 -> [ (ZEXPR $n1):E "+" [0 0] (ZEXPR $n2):L ]
-  | Zminus_inside
-      [ << (ZEXPR <<(Zminus $n1 $n2)>>) >> ]
-      	 -> [ (ZEXPR $n1):E "-" [0 0] (ZEXPR $n2):L ]
-  ;
-
-  level 6:
-    Zmult_inside
-      [ << (ZEXPR <<(Zmult $n1 $n2)>>) >> ]
-      	 -> [ (ZEXPR $n1):E "*" [0 0] (ZEXPR $n2):L ]
-  ;
-
-  level 5:
-    Zopp_inside [ << (ZEXPR <<(Zopp $n1)>>) >> ] -> [ "(-" (ZEXPR $n1):E ")" ]
-  ;  
-
-  level 10:
-    Zopp_POS_inside [ << (ZEXPR <<(Zopp (POS $r))>>) >> ] -> 
-      	 [ [<hov 0> "Zopp" [1 0] $r:"positive_printer_inside" ] ]
-  | Zopp_ZERO_inside [ << (ZEXPR <<(Zopp ZERO)>>) >> ] -> 
-      	 [ [<hov 0> "Zopp" [1 0] "0"] ]
-  | Zopp_NEG_inside [ << (ZEXPR <<(Zopp (NEG $r))>>) >> ] ->  
-      	 [ [<hov 0> "Zopp" [1 0] $r:"negative_printer_inside" ] ]
-  ;
-
-  level 4:
-    Zabs_inside [ << (ZEXPR <<(Zabs $n1)>>) >> ] -> [ "|" (ZEXPR $n1) "|"]
-  ;
-
-  level 0:
-    ZZero_inside [ << (ZEXPR <<ZERO>>) >> ] -> ["0"]
-  | ZPos_inside [ << (ZEXPR <<(POS $p)>>) >>] -> 
-      [$p:"positive_printer_inside":9]
-  | ZNeg_inside [ << (ZEXPR <<(NEG $p)>>) >>] ->
-      [$p:"negative_printer_inside":9]
-.
-].
-
-V7only[
-(* For parsing/printing based on scopes *)
-Module Z_scope.
-
-Infix LEFTA 4 "+" Zplus : Z_scope.
-Infix LEFTA 4 "-" Zminus : Z_scope.
-Infix LEFTA 3 "*" Zmult : Z_scope.
-Notation "- x" := (Zopp x) (at level 0): Z_scope V8only.
-Infix NONA 5 "<=" Zle : Z_scope.
-Infix NONA 5 "<"  Zlt : Z_scope.
-Infix NONA 5 ">=" Zge : Z_scope.
-Infix NONA 5 ">"  Zgt  : Z_scope.
-Infix NONA 5 "?=" Zcompare : Z_scope.
-Notation "x <= y <= z" := (Zle x y)/\(Zle y z)
-  (at level 5, y at level 4):Z_scope
-  V8only (at level 70, y at next level).
-Notation "x <= y < z"  := (Zle x y)/\(Zlt y z)
-  (at level 5, y at level 4):Z_scope
-  V8only (at level 70, y at next level).
-Notation  "x < y < z"  := (Zlt x y)/\(Zlt y z)
-  (at level 5, y at level 4):Z_scope
-  V8only (at level 70, y at next level).
-Notation  "x < y <= z" := (Zlt x y)/\(Zle y z)
-  (at level 5, y at level 4):Z_scope
-  V8only (at level 70, y at next level).
-Notation  "x = y = z" := x=y/\y=z : Z_scope
-  V8only (at level 70, y at next level).
-
-(* Now a polymorphic notation
-Notation "x <> y" := ~(eq Z x y) (at level 5, no associativity) : Z_scope.
-*)
-
-(* Notation "| x |" (Zabs x) : Z_scope.(* "|" conflicts with THENS *)*)
-
-(* Overwrite the printing of "`x = y`" *)
-Syntax constr level 0:
-  Zeq [ (eq Z $n1 $n2) ] -> [[<hov 0> $n1 [1 0] "= " $n2 ]].
-
-Open Scope Z_scope.
-
-End Z_scope.
-].
diff --git a/theories7/ZArith/Zwf.v b/theories7/ZArith/Zwf.v
deleted file mode 100644
index c2e6ca2a..00000000
--- a/theories7/ZArith/Zwf.v
+++ /dev/null
@@ -1,96 +0,0 @@
-(************************************************************************)
-(*  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: Zwf.v,v 1.1.2.1 2004/07/16 19:31:44 herbelin Exp $ *)
-
-Require ZArith_base.
-Require Export Wf_nat.
-Require Omega.
-V7only [Import Z_scope.].
-Open Local Scope Z_scope.
-
-(** Well-founded relations on Z. *)
-
-(** We define the following family of relations on [Z x Z]: 
-
-    [x (Zwf c) y]   iff   [x < y & c <= y]
- *)
-
-Definition Zwf := [c:Z][x,y:Z] `c <= y` /\ `x < y`.
-
-(** and we prove that [(Zwf c)] is well founded *)
-
-Section wf_proof.
-
-Variable c : Z.
-
-(** The proof of well-foundness is classic: we do the proof by induction
-    on a measure in nat, which is here [|x-c|] *)
-
-Local f := [z:Z](absolu (Zminus z c)).
-
-Lemma Zwf_well_founded : (well_founded Z (Zwf c)).
-Red; Intros.
-Assert (n:nat)(a:Z)(lt (f a) n)\/(`a<c`) -> (Acc Z (Zwf c) a).
-Clear a; Induction n; Intros.
-(** n= 0 *)
-Case H; Intros.
-Case (lt_n_O (f a)); Auto.
-Apply Acc_intro; Unfold Zwf; Intros.
-Assert False;Omega Orelse Contradiction.
-(** inductive case *)
-Case H0; Clear H0; Intro; Auto.
-Apply Acc_intro; Intros.
-Apply H.
-Unfold Zwf in H1.
-Case (Zle_or_lt c y); Intro; Auto with zarith.
-Left.
-Red in H0.
-Apply lt_le_trans with (f a); Auto with arith.
-Unfold f.
-Apply absolu_lt; Omega.
-Apply (H (S (f a))); Auto.
-Save.
-
-End wf_proof.
-
-Hints Resolve Zwf_well_founded : datatypes v62.
-
-
-(** We also define the other family of relations:
-
-    [x (Zwf_up c) y]   iff   [y < x <= c]
- *)
-
-Definition Zwf_up := [c:Z][x,y:Z] `y < x <= c`.
-
-(** and we prove that [(Zwf_up c)] is well founded *)
-
-Section wf_proof_up.
-
-Variable c : Z.
-
-(** The proof of well-foundness is classic: we do the proof by induction
-    on a measure in nat, which is here [|c-x|] *)
-
-Local f := [z:Z](absolu (Zminus c z)).
-
-Lemma Zwf_up_well_founded : (well_founded Z (Zwf_up c)).
-Proof.
-Apply well_founded_lt_compat with f:=f.
-Unfold Zwf_up f.
-Intros.
-Apply absolu_lt.
-Unfold Zminus. Split.
-Apply Zle_left; Intuition.
-Apply Zlt_reg_l; Unfold Zlt; Rewrite <- Zcompare_Zopp; Intuition.
-Save.
-
-End wf_proof_up.
-
-Hints Resolve Zwf_up_well_founded : datatypes v62.
diff --git a/theories7/ZArith/auxiliary.v b/theories7/ZArith/auxiliary.v
deleted file mode 100644
index 8db2c852..00000000
--- a/theories7/ZArith/auxiliary.v
+++ /dev/null
@@ -1,219 +0,0 @@
-(************************************************************************)
-(*  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: auxiliary.v,v 1.1.2.1 2004/07/16 19:31:44 herbelin Exp $ i*)
-
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
-
-Require Export Arith.
-Require BinInt.
-Require Zorder.
-Require Decidable.
-Require Peano_dec.
-Require Export Compare_dec.
-
-Open Local Scope Z_scope.
-
-(**********************************************************************)
-(** Moving terms from one side to the other of an inequality *)
-
-Theorem Zne_left : (x,y:Z) (Zne x y) -> (Zne (Zplus x (Zopp y)) ZERO).
-Proof.
-Intros x y; Unfold Zne; Unfold not; Intros H1 H2; Apply H1;
-Apply Zsimpl_plus_l with (Zopp y); Rewrite Zplus_inverse_l; Rewrite Zplus_sym;
-Trivial with arith.
-Qed.
-
-Theorem Zegal_left : (x,y:Z) (x=y) -> (Zplus x (Zopp y)) = ZERO.
-Proof.
-Intros x y H;
-Apply (Zsimpl_plus_l y);Rewrite -> Zplus_permute;
-Rewrite -> Zplus_inverse_r;Do 2 Rewrite -> Zero_right;Assumption.
-Qed.
-
-Theorem Zle_left : (x,y:Z) (Zle x y) -> (Zle ZERO (Zplus y (Zopp x))).
-Proof.
-Intros x y H; Replace ZERO with (Zplus x (Zopp x)).
-Apply Zle_reg_r; Trivial.
-Apply Zplus_inverse_r.
-Qed.
-
-Theorem Zle_left_rev : (x,y:Z) (Zle ZERO (Zplus y (Zopp x))) 
-	-> (Zle x y).
-Proof.
-Intros x y H; Apply Zsimpl_le_plus_r with (Zopp x).
-Rewrite Zplus_inverse_r; Trivial.
-Qed.
-
-Theorem Zlt_left_rev : (x,y:Z) (Zlt ZERO (Zplus y (Zopp x))) 
-	-> (Zlt x y).
-Proof.
-Intros x y H; Apply Zsimpl_lt_plus_r with (Zopp x).
-Rewrite Zplus_inverse_r; Trivial.
-Qed.
-
-Theorem Zlt_left :
-  (x,y:Z) (Zlt x y) -> (Zle ZERO (Zplus (Zplus y (NEG xH)) (Zopp x))).
-Proof.
-Intros x y H; Apply Zle_left; Apply Zle_S_n; 
-Change (Zle (Zs x) (Zs (Zpred y))); Rewrite <- Zs_pred; Apply Zlt_le_S;
-Assumption.
-Qed.
-
-Theorem Zlt_left_lt :
-  (x,y:Z) (Zlt x y) -> (Zlt ZERO (Zplus y (Zopp x))).
-Proof.
-Intros x y H; Replace ZERO with (Zplus x (Zopp x)).
-Apply Zlt_reg_r; Trivial.
-Apply Zplus_inverse_r.
-Qed.
-
-Theorem Zge_left : (x,y:Z) (Zge x y) -> (Zle ZERO (Zplus x (Zopp y))).
-Proof.
-Intros x y H; Apply Zle_left; Apply Zge_le; Assumption.
-Qed.
-
-Theorem Zgt_left :
-  (x,y:Z) (Zgt x y) -> (Zle ZERO (Zplus (Zplus x (NEG xH)) (Zopp y))).
-Proof.
-Intros x y H; Apply Zlt_left; Apply Zgt_lt; Assumption.
-Qed.
-
-Theorem Zgt_left_gt :
-  (x,y:Z) (Zgt x y) -> (Zgt (Zplus x (Zopp y)) ZERO).
-Proof.
-Intros x y H; Replace ZERO with (Zplus y (Zopp y)).
-Apply Zgt_reg_r; Trivial.
-Apply Zplus_inverse_r.
-Qed.
-
-Theorem Zgt_left_rev : (x,y:Z) (Zgt (Zplus x (Zopp y)) ZERO) 
-	-> (Zgt x y).
-Proof.
-Intros x y H; Apply Zsimpl_gt_plus_r with (Zopp y).
-Rewrite Zplus_inverse_r; Trivial.
-Qed.
-
-(**********************************************************************)
-(** Factorization lemmas *)
-
-Theorem Zred_factor0 : (x:Z) x = (Zmult x (POS xH)).
-Intro x; Rewrite (Zmult_n_1 x); Reflexivity.
-Qed.
-
-Theorem Zred_factor1 : (x:Z) (Zplus x x) = (Zmult x (POS (xO xH))).
-Proof.
-Exact Zplus_Zmult_2.
-Qed.
-
-Theorem Zred_factor2 :
-  (x,y:Z) (Zplus x (Zmult x y)) = (Zmult x (Zplus (POS xH) y)).
-
-Intros x y; Pattern 1 x ; Rewrite <- (Zmult_n_1 x);
-Rewrite <- Zmult_plus_distr_r; Trivial with arith.
-Qed.
-
-Theorem Zred_factor3 :
-  (x,y:Z) (Zplus (Zmult x y) x) = (Zmult x (Zplus (POS xH) y)).
-
-Intros x y; Pattern 2 x ; Rewrite <- (Zmult_n_1 x);
-Rewrite <- Zmult_plus_distr_r; Rewrite Zplus_sym; Trivial with arith.
-Qed.
-Theorem Zred_factor4 :
-  (x,y,z:Z) (Zplus (Zmult x y) (Zmult x z)) = (Zmult x (Zplus y z)).
-Intros x y z; Symmetry; Apply Zmult_plus_distr_r.
-Qed.
-
-Theorem Zred_factor5 : (x,y:Z) (Zplus (Zmult x ZERO) y) = y.
-
-Intros x y; Rewrite <- Zmult_n_O;Auto with arith.
-Qed.
-
-Theorem Zred_factor6 : (x:Z) x = (Zplus x ZERO).
-
-Intro; Rewrite Zero_right; Trivial with arith.
-Qed.
-
-Theorem Zle_mult_approx:
-  (x,y,z:Z) (Zgt x ZERO) -> (Zgt z ZERO) -> (Zle ZERO y) -> 
-    (Zle ZERO (Zplus (Zmult y x) z)).
-
-Intros x y z H1 H2 H3; Apply Zle_trans with m:=(Zmult y x) ; [
-  Apply Zle_mult; Assumption
-| Pattern 1 (Zmult y x) ; Rewrite <- Zero_right; Apply Zle_reg_l;
-  Apply Zlt_le_weak; Apply Zgt_lt; Assumption].
-Qed.
-
-Theorem Zmult_le_approx:
-  (x,y,z:Z) (Zgt x ZERO) -> (Zgt x z) -> 
-    (Zle ZERO (Zplus (Zmult y x) z)) -> (Zle ZERO y).
-
-Intros x y z H1 H2 H3; Apply Zlt_n_Sm_le; Apply Zmult_lt with x; [
-  Assumption
-  | Apply Zle_lt_trans with 1:=H3 ; Rewrite <- Zmult_Sm_n;
-    Apply Zlt_reg_l; Apply Zgt_lt; Assumption].
-
-Qed.
-
-V7only [
-(* Compatibility *)
-Require Znat.
-Require Zcompare.
-Notation neq := neq.
-Notation Zne := Zne.
-Notation OMEGA2 := Zle_0_plus.
-Notation add_un_Zs := add_un_Zs.
-Notation inj_S := inj_S.
-Notation Zplus_S_n := Zplus_S_n.
-Notation inj_plus := inj_plus.
-Notation inj_mult := inj_mult.
-Notation inj_neq := inj_neq.
-Notation inj_le := inj_le.
-Notation inj_lt := inj_lt.
-Notation inj_gt := inj_gt.
-Notation inj_ge := inj_ge.
-Notation inj_eq := inj_eq.
-Notation intro_Z := intro_Z.
-Notation inj_minus1 := inj_minus1.
-Notation inj_minus2 := inj_minus2.
-Notation dec_eq := dec_eq.
-Notation dec_Zne := dec_Zne.
-Notation dec_Zle := dec_Zle.
-Notation dec_Zgt := dec_Zgt.
-Notation dec_Zge := dec_Zge.
-Notation dec_Zlt := dec_Zlt.
-Notation dec_eq_nat := dec_eq_nat.
-Notation not_Zge := not_Zge.
-Notation not_Zlt := not_Zlt.
-Notation not_Zle := not_Zle.
-Notation not_Zgt := not_Zgt.
-Notation not_Zeq := not_Zeq.
-Notation Zopp_one := Zopp_one.
-Notation Zopp_Zmult_r := Zopp_Zmult_r.
-Notation Zmult_Zopp_left := Zmult_Zopp_left.
-Notation Zopp_Zmult_l := Zopp_Zmult_l.
-Notation Zcompare_Zplus_compatible2 := Zcompare_Zplus_compatible2.
-Notation Zcompare_Zmult_compatible := Zcompare_Zmult_compatible.
-Notation Zmult_eq := Zmult_eq.
-Notation Z_eq_mult := Z_eq_mult.
-Notation Zmult_le := Zmult_le.
-Notation Zle_ZERO_mult := Zle_ZERO_mult.
-Notation Zgt_ZERO_mult := Zgt_ZERO_mult.
-Notation Zle_mult := Zle_mult.
-Notation Zmult_lt := Zmult_lt.
-Notation Zmult_gt := Zmult_gt.
-Notation Zle_Zmult_pos_right := Zle_Zmult_pos_right.
-Notation Zle_Zmult_pos_left := Zle_Zmult_pos_left.
-Notation Zge_Zmult_pos_right := Zge_Zmult_pos_right.
-Notation Zge_Zmult_pos_left := Zge_Zmult_pos_left.
-Notation Zge_Zmult_pos_compat := Zge_Zmult_pos_compat.
-Notation Zle_mult_simpl := Zle_mult_simpl.
-Notation Zge_mult_simpl := Zge_mult_simpl.
-Notation Zgt_mult_simpl := Zgt_mult_simpl.
-Notation Zgt_square_simpl := Zgt_square_simpl.
-].
diff --git a/theories7/ZArith/fast_integer.v b/theories7/ZArith/fast_integer.v
deleted file mode 100644
index 7e3fe306..00000000
--- a/theories7/ZArith/fast_integer.v
+++ /dev/null
@@ -1,191 +0,0 @@
-(************************************************************************)
-(*  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: fast_integer.v,v 1.1.2.1 2004/07/16 19:31:44 herbelin Exp $ i*)
-
-(***********************************************************)
-(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
-(***********************************************************)
-
-Require BinPos.
-Require BinNat.
-Require BinInt.
-Require Zcompare.
-Require Mult.
-
-V7only [
-(* Defs and ppties on positive, entier and Z, previously in fast_integer *)
-(* For v7 compatibility *)
-Notation positive := positive.
-Notation xO := xO.
-Notation xI := xI.
-Notation xH := xH.
-Notation add_un := add_un.
-Notation add := add.
-Notation convert := convert.
-Notation convert_add_un := convert_add_un.
-Notation cvt_carry := cvt_carry.
-Notation convert_add := convert_add.
-Notation positive_to_nat := positive_to_nat.
-Notation anti_convert := anti_convert.
-Notation double_moins_un := double_moins_un.
-Notation sub_un := sub_un.
-Notation positive_mask := positive_mask.
-Notation Un_suivi_de_mask := Un_suivi_de_mask.
-Notation Zero_suivi_de_mask := Zero_suivi_de_mask.
-Notation double_moins_deux := double_moins_deux.
-Notation sub_pos := sub_pos.
-Notation true_sub := true_sub.
-Notation times := times.
-Notation relation := relation.
-Notation SUPERIEUR := SUPERIEUR.
-Notation INFERIEUR := INFERIEUR.
-Notation EGAL := EGAL.
-Notation Op := Op.
-Notation compare := compare.
-Notation compare_convert1 := compare_convert1.
-Notation compare_convert_EGAL := compare_convert_EGAL.
-Notation ZLSI := ZLSI.
-Notation ZLIS := ZLIS.
-Notation ZLII := ZLII.
-Notation ZLSS := ZLSS.
-Notation Dcompare := Dcompare.
-Notation convert_compare_EGAL := convert_compare_EGAL.
-Notation ZL0 := ZL0.
-Notation ZL11 := ZL11.
-Notation xI_add_un_xO := xI_add_un_xO.
-Notation is_double_moins_un := is_double_moins_un.
-Notation double_moins_un_add_un_xI := double_moins_un_add_un_xI.
-Notation ZL1 := ZL1.
-Notation add_un_not_un := add_un_not_un.
-Notation sub_add_one := sub_add_one.
-Notation add_sub_one := add_sub_one.
-Notation add_un_inj := add_un_inj.
-Notation ZL12 := ZL12.
-Notation ZL12bis := ZL12bis.
-Notation ZL13 := ZL13.
-Notation add_sym := add_sym.
-Notation ZL14 := ZL14.
-Notation ZL14bis := ZL14bis.
-Notation ZL15 := ZL15.
-Notation add_no_neutral := add_no_neutral.
-Notation add_carry_not_add_un := add_carry_not_add_un.
-Notation add_carry_add := add_carry_add.
-Notation simpl_add_r := simpl_add_r.
-Notation simpl_add_carry_r := simpl_add_carry_r.
-Notation simpl_add_l := simpl_add_l.
-Notation simpl_add_carry_l := simpl_add_carry_l.
-Notation add_assoc := add_assoc.
-Notation add_xI_double_moins_un := add_xI_double_moins_un.
-Notation add_x_x := add_x_x.
-Notation ZS := ZS.
-Notation US := US.
-Notation USH := USH.
-Notation ZSH := ZSH.
-Notation sub_pos_x_x := sub_pos_x_x.
-Notation ZL10 := ZL10.
-Notation sub_pos_SUPERIEUR := sub_pos_SUPERIEUR.
-Notation sub_add := sub_add.
-Notation convert_add_carry := convert_add_carry.
-Notation add_verif := add_verif.
-Notation ZL2 := ZL2.
-Notation ZL6 := ZL6.
-Notation positive_to_nat_mult := positive_to_nat_mult.
-Notation times_convert := times_convert.
-Notation compare_positive_to_nat_O := compare_positive_to_nat_O.
-Notation compare_convert_O := compare_convert_O.
-Notation convert_xH := convert_xH.
-Notation convert_xO := convert_xO.
-Notation convert_xI := convert_xI.
-Notation bij1 := bij1.
-Notation ZL3 := ZL3.
-Notation ZL4 := ZL4.
-Notation ZL5 := ZL5.
-Notation bij2 := bij2.
-Notation bij3 := bij3.
-Notation ZL7 := ZL7.
-Notation ZL8 := ZL8.
-Notation compare_convert_INFERIEUR := compare_convert_INFERIEUR.
-Notation compare_convert_SUPERIEUR := compare_convert_SUPERIEUR.
-Notation convert_compare_INFERIEUR := convert_compare_INFERIEUR.
-Notation convert_compare_SUPERIEUR := convert_compare_SUPERIEUR.
-Notation ZC1 := ZC1.
-Notation ZC2 := ZC2.
-Notation ZC3 := ZC3.
-Notation ZC4 := ZC4.
-Notation true_sub_convert := true_sub_convert.
-Notation convert_intro := convert_intro.
-Notation ZL16 := ZL16.
-Notation ZL17 := ZL17.
-Notation compare_true_sub_right := compare_true_sub_right.
-Notation compare_true_sub_left := compare_true_sub_left.
-Notation times_x_ := times_x_1.
-Notation times_x_double := times_x_double.
-Notation times_x_double_plus_one := times_x_double_plus_one.
-Notation times_sym := times_sym.
-Notation times_add_distr := times_add_distr.
-Notation times_add_distr_l := times_add_distr_l.
-Notation times_assoc := times_assoc.
-Notation times_true_sub_distr := times_true_sub_distr.
-Notation times_discr_xO_xI := times_discr_xO_xI.
-Notation times_discr_xO := times_discr_xO.
-Notation simpl_times_r := simpl_times_r.
-Notation simpl_times_l := simpl_times_l.
-Notation iterate_add := iterate_add.
-Notation entier := entier.
-Notation Nul := Nul.
-Notation Pos := Pos.
-Notation Un_suivi_de := Un_suivi_de.
-Notation Zero_suivi_de := Zero_suivi_de.
-Notation times1 :=
-    [x:positive;_:positive->positive;y:positive](times x y).
-Notation times1_convert :=
-    [x,y:positive;_:positive->positive](times_convert x y).
-
-Notation Z := Z.
-Notation POS := POS.
-Notation NEG := NEG.
-Notation ZERO := ZERO.
-Notation Zero_left := Zero_left.
-Notation Zopp_Zopp := Zopp_Zopp.
-Notation Zero_right := Zero_right.
-Notation Zplus_inverse_r := Zplus_inverse_r.
-Notation Zopp_Zplus := Zopp_Zplus.
-Notation Zplus_sym := Zplus_sym.
-Notation Zplus_inverse_l := Zplus_inverse_l.
-Notation Zopp_intro := Zopp_intro.
-Notation Zopp_NEG := Zopp_NEG.
-Notation weak_assoc := weak_assoc.
-Notation Zplus_assoc := Zplus_assoc.
-Notation Zplus_simpl := Zplus_simpl.
-Notation Zmult_sym := Zmult_sym.
-Notation Zmult_assoc := Zmult_assoc.
-Notation Zmult_one := Zmult_one.
-Notation lt_mult_left := lt_mult_left. (* Mult*)
-Notation Zero_mult_left := Zero_mult_left.
-Notation Zero_mult_right := Zero_mult_right.
-Notation Zopp_Zmult := Zopp_Zmult.
-Notation Zmult_Zopp_Zopp := Zmult_Zopp_Zopp.
-Notation weak_Zmult_plus_distr_r := weak_Zmult_plus_distr_r.
-Notation Zmult_plus_distr_r := Zmult_plus_distr_r.
-Notation Zcompare_EGAL := Zcompare_EGAL.
-Notation Zcompare_ANTISYM := Zcompare_ANTISYM.
-Notation le_minus := le_minus.
-Notation Zcompare_Zopp := Zcompare_Zopp.
-Notation weaken_Zcompare_Zplus_compatible := weaken_Zcompare_Zplus_compatible.
-Notation weak_Zcompare_Zplus_compatible := weak_Zcompare_Zplus_compatible.
-Notation Zcompare_Zplus_compatible := Zcompare_Zplus_compatible.
-Notation Zcompare_trans_SUPERIEUR := Zcompare_trans_SUPERIEUR.
-Notation SUPERIEUR_POS := SUPERIEUR_POS.
-Export Datatypes.
-Export BinPos.
-Export BinNat.
-Export BinInt.
-Export Zcompare.
-Export Mult.
-].
diff --git a/theories7/ZArith/zarith_aux.v b/theories7/ZArith/zarith_aux.v
deleted file mode 100644
index cd67d46b..00000000
--- a/theories7/ZArith/zarith_aux.v
+++ /dev/null
@@ -1,163 +0,0 @@
-(************************************************************************)
-(*  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: zarith_aux.v,v 1.2.2.1 2004/07/16 19:31:44 herbelin Exp $ i*)
-
-Require Export BinInt.
-Require Export Zcompare.
-Require Export Zorder.
-Require Export Zmin.
-Require Export Zabs.
-
-V7only [
-Notation Zlt := Zlt.
-Notation Zgt := Zgt.
-Notation Zle := Zle.
-Notation Zge := Zge.
-Notation Zsgn := Zsgn.
-Notation absolu := absolu.
-Notation Zabs := Zabs.
-Notation Zabs_eq := Zabs_eq.
-Notation Zabs_non_eq := Zabs_non_eq.
-Notation Zabs_dec := Zabs_dec.
-Notation Zabs_pos := Zabs_pos.
-Notation Zsgn_Zabs := Zsgn_Zabs.
-Notation Zabs_Zsgn := Zabs_Zsgn.
-Notation inject_nat := inject_nat.
-Notation Zs := Zs.
-Notation Zpred := Zpred.
-Notation Zgt_Sn_n := Zgt_Sn_n.
-Notation Zle_gt_trans := Zle_gt_trans.
-Notation Zgt_le_trans := Zgt_le_trans.
-Notation Zle_S_gt := Zle_S_gt.
-Notation Zcompare_n_S := Zcompare_n_S.
-Notation Zgt_n_S := Zgt_n_S.
-Notation Zle_not_gt := Zle_not_gt.
-Notation Zgt_antirefl := Zgt_antirefl.
-Notation Zgt_not_sym := Zgt_not_sym.
-Notation Zgt_not_le := Zgt_not_le.
-Notation Zgt_trans := Zgt_trans.
-Notation Zle_gt_S := Zle_gt_S.
-Notation Zgt_pred := Zgt_pred.       
-Notation Zsimpl_gt_plus_l := Zsimpl_gt_plus_l. 
-Notation Zsimpl_gt_plus_r := Zsimpl_gt_plus_r.
-Notation Zgt_reg_l := Zgt_reg_l.      
-Notation Zgt_reg_r := Zgt_reg_r.
-Notation Zcompare_et_un := Zcompare_et_un.
-Notation Zgt_S_n := Zgt_S_n.
-Notation Zle_S_n := Zle_S_n.
-Notation Zgt_le_S := Zgt_le_S.
-Notation Zgt_S_le := Zgt_S_le.
-Notation Zgt_S := Zgt_S.
-Notation Zgt_trans_S := Zgt_trans_S.
-Notation Zeq_S := Zeq_S.
-Notation Zpred_Sn := Zpred_Sn.
-Notation Zeq_add_S := Zeq_add_S.
-Notation Znot_eq_S := Znot_eq_S.
-Notation Zsimpl_plus_l := Zsimpl_plus_l.
-Notation Zn_Sn := Zn_Sn.
-Notation Zplus_n_O := Zplus_n_O.
-Notation Zplus_unit_left := Zplus_unit_left.
-Notation Zplus_unit_right := Zplus_unit_right.
-Notation Zplus_n_Sm := Zplus_n_Sm.
-Notation Zmult_n_O := Zmult_n_O.
-Notation Zmult_n_Sm := Zmult_n_Sm.
-Notation Zle_n := Zle_n.
-Notation Zle_refl := Zle_refl.
-Notation Zle_trans := Zle_trans.
-Notation Zle_n_Sn := Zle_n_Sn.
-Notation Zle_n_S := Zle_n_S.
-Notation Zs_pred := Zs_pred. (* BinInt *)
-Notation Zle_pred_n := Zle_pred_n.
-Notation Zle_trans_S := Zle_trans_S.
-Notation Zle_Sn_n := Zle_Sn_n.
-Notation Zle_antisym := Zle_antisym.
-Notation Zgt_lt := Zgt_lt.
-Notation Zlt_gt := Zlt_gt.
-Notation Zge_le := Zge_le.
-Notation Zle_ge := Zle_ge.
-Notation Zge_trans := Zge_trans.
-Notation Zlt_n_Sn := Zlt_n_Sn.
-Notation Zlt_S := Zlt_S.
-Notation Zlt_n_S := Zlt_n_S.
-Notation Zlt_S_n := Zlt_S_n.
-Notation Zlt_n_n := Zlt_n_n.
-Notation Zlt_pred := Zlt_pred.
-Notation Zlt_pred_n_n := Zlt_pred_n_n.
-Notation Zlt_le_S := Zlt_le_S.
-Notation Zlt_n_Sm_le := Zlt_n_Sm_le.
-Notation Zle_lt_n_Sm := Zle_lt_n_Sm.
-Notation Zlt_le_weak := Zlt_le_weak.
-Notation Zlt_trans := Zlt_trans.
-Notation Zlt_le_trans := Zlt_le_trans.
-Notation Zle_lt_trans := Zle_lt_trans.
-Notation Zle_lt_or_eq := Zle_lt_or_eq.
-Notation Zle_or_lt := Zle_or_lt.
-Notation Zle_not_lt := Zle_not_lt.
-Notation Zlt_not_le := Zlt_not_le.
-Notation Zlt_not_sym := Zlt_not_sym.
-Notation Zle_le_S := Zle_le_S.
-Notation Zmin := Zmin.
-Notation Zmin_SS := Zmin_SS.
-Notation Zle_min_l := Zle_min_l.
-Notation Zle_min_r := Zle_min_r.
-Notation Zmin_case := Zmin_case.
-Notation Zmin_or := Zmin_or.
-Notation Zmin_n_n := Zmin_n_n.
-Notation Zplus_assoc_l := Zplus_assoc_l.
-Notation Zplus_assoc_r := Zplus_assoc_r.
-Notation Zplus_permute := Zplus_permute.
-Notation Zsimpl_le_plus_l := Zsimpl_le_plus_l.
-Notation "'Zsimpl_le_plus_l' c" := [a,b:Z](Zsimpl_le_plus_l a b c)
-  (at level 10, c at next level).
-Notation "'Zsimpl_le_plus_l' c a" := [b:Z](Zsimpl_le_plus_l a b c)
-  (at level 10, a, c at next level).
-Notation "'Zsimpl_le_plus_l' c a b" := (Zsimpl_le_plus_l a b c)
-  (at level 10, a, b, c at next level).
-Notation Zsimpl_le_plus_r := Zsimpl_le_plus_r.
-Notation "'Zsimpl_le_plus_r' c" := [a,b:Z](Zsimpl_le_plus_r a b c)
-  (at level 10, c at next level).
-Notation "'Zsimpl_le_plus_r' c a" := [b:Z](Zsimpl_le_plus_r a b c)
-  (at level 10, a, c at next level).
-Notation "'Zsimpl_le_plus_r' c a b" := (Zsimpl_le_plus_r a b c)
-  (at level 10, a, b, c at next level).
-Notation Zle_reg_l := Zle_reg_l.
-Notation Zle_reg_r := Zle_reg_r.
-Notation Zle_plus_plus := Zle_plus_plus.
-Notation Zplus_Snm_nSm := Zplus_Snm_nSm.
-Notation Zsimpl_lt_plus_l := Zsimpl_lt_plus_l. 
-Notation Zsimpl_lt_plus_r := Zsimpl_lt_plus_r.
-Notation Zlt_reg_l := Zlt_reg_l.
-Notation Zlt_reg_r := Zlt_reg_r.
-Notation Zlt_le_reg := Zlt_le_reg.
-Notation Zle_lt_reg := Zle_lt_reg.
-Notation Zminus := Zminus.
-Notation Zminus_plus_simpl := Zminus_plus_simpl.
-Notation Zminus_n_O := Zminus_n_O.
-Notation Zminus_n_n := Zminus_n_n.
-Notation Zplus_minus := Zplus_minus.
-Notation Zminus_plus := Zminus_plus.
-Notation Zle_plus_minus := Zle_plus_minus.
-Notation Zminus_Sn_m := Zminus_Sn_m.
-Notation Zlt_minus := Zlt_minus.
-Notation Zlt_O_minus_lt := Zlt_O_minus_lt.
-Notation Zmult_plus_distr_l := Zmult_plus_distr_l.
-Notation Zmult_plus_distr := BinInt.Zmult_plus_distr_l.
-Notation Zmult_minus_distr := Zmult_minus_distr.
-Notation Zmult_assoc_r := Zmult_assoc_r.
-Notation Zmult_assoc_l := Zmult_assoc_l.
-Notation Zmult_permute := Zmult_permute.
-Notation Zmult_1_n := Zmult_1_n.
-Notation Zmult_n_1 := Zmult_n_1.
-Notation Zmult_Sm_n := Zmult_Sm_n.
-Notation Zmult_Zplus_distr := Zmult_plus_distr_r.
-Export BinInt.
-Export Zorder.
-Export Zmin.
-Export Zabs.
-Export Zcompare.
-].
diff --git a/tools/check-translate b/tools/check-translate
new file mode 100755
index 00000000..3dd82405
--- /dev/null
+++ b/tools/check-translate
@@ -0,0 +1,23 @@
+#!/bin/sh
+
+echo -------------- Producing translated files ---------------------
+rm */*/*.v8 >& /dev/null
+make COQ_XML=-translate theories || { echo ---- Failed to translate; exit 1; }
+if [ -e translated ]; then rm -r translated; fi
+if [ -e successful-translation ]; then rm -r successful-translation; fi
+if [ -e failed-translation ]; then rm -r failed-translation; fi
+mv theories translated
+mkdir theories
+echo -------------------- Upgrading files --------------------------
+cd translated
+for i in */*.v
+do
+  mkdir ../theories/`dirname $i` >& /dev/null
+  mv "$i"8 ../theories/$i
+done
+cd ..
+echo --------------- Recompiling translated files ------------------
+make theories || { echo ---- Failed to recompile; mv theories failed-translation; mv translated theories; exit 1; }
+echo ----------------- Recompilation successful --------------------
+if [ -e successful-translation ]; then rm -r successful-translation; fi
+mv theories successful-translation; mv translated theories
diff --git a/tools/check-v8 b/tools/check-v8
deleted file mode 100755
index 9dfa0be3..00000000
--- a/tools/check-v8
+++ /dev/null
@@ -1,24 +0,0 @@
-#!/bin/sh
-
-echo ------------------ Producing v8 files -------------------------
-if [ -e v8 ]; then rm -r v8; fi
-if [ -e /tmp/v8.$$ ]; then rm -r /tmp/v8.$$; fi
-cp -pr . /tmp/v8.$$
-mv /tmp/v8.$$ v8
-cd v8
-rm description
-make clean
-make COQFLAGS='-translate -q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)' || \
- { echo ---- Failed to translate; exit 1; }
-echo ------------------ Upgrading v8 files -------------------------
-v8files=`find . -name \*.v8`
-for i in $v8files; do
-  j=`dirname $i`/`basename $i .v8`.v
-  echo Upgrading $i
-  mv -u -f $i $j
-done
-echo ------------------ Recompiling v8 files -----------------------
-make clean
-make || { echo ---- Failed to recompile; exit 1; }
-make clean # to save disk space
-echo ------------------ Translation completed ----------------------
diff --git a/tools/coq-tex.ml4 b/tools/coq-tex.ml4
index 6987d78b..d55901b9 100644
--- a/tools/coq-tex.ml4
+++ b/tools/coq-tex.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq-tex.ml4,v 1.5.2.1 2004/07/16 19:31:45 herbelin Exp $ *)
+(* $Id: coq-tex.ml4 9551 2007-01-29 15:13:35Z bgregoir $ *)
 
 (* coq-tex
  * JCF, 16/1/98
@@ -92,9 +92,9 @@ let tex_escaped s =
     | [< s1 = (parser 
 		 | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] -> 
 		     "\\" ^ (String.make 1 c)
-		 | [< ''\\' >] -> "\\char'134" 
-		 | [< ''^'  >] -> "\\char'136" 
-		 | [< ''~'  >] -> "\\char'176"
+		 | [< ''\\' >] -> "{\\char'134}" 
+		 | [< ''^'  >] -> "{\\char'136}" 
+		 | [< ''~'  >] -> "{\\char'176}"
 		 | [< '' '  >] -> "~"
 		 | [< ''<'  >] -> "{<}"
 		 | [< ''>'  >] -> "{>}"
diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4
index 02607f14..cd9d3669 100644
--- a/tools/coq_makefile.ml4
+++ b/tools/coq_makefile.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq_makefile.ml4,v 1.16.2.4 2005/01/12 16:00:19 sacerdot Exp $ *)
+(* $Id: coq_makefile.ml4 8840 2006-05-22 13:51:14Z notin $ *)
 
 (* créer un Makefile pour un développement Coq automatiquement *)
 
@@ -79,9 +79,9 @@ coq_makefile [subdirectory] .... [file.v] ... [file.ml] ... [-custom
 [--help]: equivalent to [-h]\n";
   exit 1
 
-let standard sds =
+let standard sds sps =
   print "byte:\n";
-  print "\t$(MAKE) all \"OPT=-byte\"\n\n";
+  print "\t$(MAKE) all \"OPT=\"\n\n";
   print "opt:\n";
   if !opt = "" then print "\t@echo \"WARNING: opt is disabled\"\n";
   print "\t$(MAKE) all \"OPT="; print !opt; print "\"\n\n";
@@ -118,6 +118,9 @@ let standard sds =
   print "\trm -f *.cmo *.cmi *.cmx *.o $(VOFILES) $(VIFILES) $(GFILES) *~\n";
   print "\trm -f all.ps all-gal.ps $(HTMLFILES) $(GHTMLFILES)\n";
   List.iter
+    (fun (file,_,_) -> print "\t- rm -f "; print file; print "\n")
+    sps;
+  List.iter
     (fun x -> print "\t(cd "; print x; print " ; $(MAKE) clean)\n")
     sds;
   print "\n";
@@ -194,7 +197,7 @@ let variables l =
   print "COQFLAGS=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n";
   print "COQC=$(COQBIN)coqc\n";
   print "GALLINA=gallina\n";
-  print "COQDOC=coqdoc\n";
+  print "COQDOC=$(COQBIN)coqdoc\n";
   print "CAMLC=ocamlc -c\n";
   print "CAMLOPTC=ocamlopt -c\n";
   print "CAMLLINK=ocamlc\n";
@@ -224,17 +227,16 @@ let include_dirs l =
   print "OCAMLLIBS="; print_list "\\\n  " i_ocaml; print "\n";
   print "COQLIBS=";   print_list "\\\n  " i_coq; print "\n\n"
 
-let special l =
+let rec special = function
+  | [] -> []
+  | Special (file,deps,com) :: r -> (file,deps,com) :: (special r)
+  | _ :: r -> special r
+
+let custom sps =
   let pr_sp (file,dependencies,com) =
     print file; print ": "; print dependencies; print "\n";
     print "\t"; print com; print "\n\n"
   in
-  let rec sp_aux = function
-    | [] -> []
-    | Special (file,deps,com) :: r -> (file,deps,com) :: (sp_aux r)
-    | _ :: r -> sp_aux r
-  in
-  let sps = sp_aux l in
   if sps <> [] then section "Custom targets.";
   List.iter pr_sp sps
 
@@ -434,10 +436,11 @@ let do_makefile args =
   variables l;
   include_dirs l;
   all_target l;
-  special l;
+  let sps = special  l in
+  custom sps;
   let sds = subdirs l in
   implicit ();
-  standard sds;
+  standard sds sps;
   (* TEST directories_deps l; *)
   warning ();
   if not (!output_channel == stdout) then close_out !output_channel;
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index ab7cef92..3647152a 100755..100644
--- a/tools/coqdep.ml
+++ b/tools/coqdep.ml
@@ -6,18 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqdep.ml,v 1.15.2.1 2004/07/16 19:31:46 herbelin Exp $ *)
+(* $Id: coqdep.ml 9276 2006-10-25 13:00:22Z barras $ *)
 
 open Printf
 open Coqdep_lexer
 open Unix
 
-let (/) = Filename.concat
-
-let file_concat l =
-  if l=[] then "<empty>" else
-    List.fold_left (/) (List.hd l) (List.tl l)
-
 let stderr = Pervasives.stderr
 let stdout = Pervasives.stdout
 
@@ -28,12 +22,23 @@ let option_D = ref false
 let option_w = ref false
 let option_i = ref false
 let option_sort = ref false
+let option_slash = ref false
 
 let suffixe = ref ".vo"
 let suffixe_spec = ref ".vi"
 
 type dir = string option
 
+(* filename for printing *)
+let (//) s1 s2 =
+  if !option_slash then s1^"/"^s2 else Filename.concat s1 s2
+
+let (/) = Filename.concat
+
+let file_concat l =
+  if l=[] then "<empty>" else
+    List.fold_left (//) (List.hd l) (List.tl l)
+
 (* Files specified on the command line *)
 let mlAccu  = ref ([] : (string * string * dir) list) 
 and mliAccu = ref ([] : (string * string * dir) list) 
@@ -148,7 +153,7 @@ let cut_prefix p s =
   if ls >= lp && String.sub s 0 lp = p then String.sub s lp (ls - lp) else s
 
 let canonize f = match Sys.os_type with
-  | "Win32" -> cut_prefix ".\\" f
+  | "Win32" when not !option_slash -> cut_prefix ".\\" f
   | _ -> cut_prefix "./" f
 
 let sort () = 
@@ -162,8 +167,12 @@ let sort () =
       try
 	while true do
 	  match coq_action lb with
-	    | Require (_, s) ->
-		(try loop (List.assoc s !vKnown) with Not_found -> ())
+	    | Require (_, sl) ->
+		List.iter 
+		  (fun s -> 
+		    try loop (List.assoc s !vKnown) 
+		    with Not_found -> ())
+		sl
 	    | RequireString (_, s) -> loop s
 	    | _ -> ()
 	done
@@ -184,17 +193,18 @@ let traite_fichier_Coq verbose f =
       while true do
       	let tok = coq_action buf in
 	match tok with
-	  | Require (spec,str) ->
-	      if not (List.mem str !deja_vu_v) then begin
-	        addQueue deja_vu_v str;
-                try
-                  let file_str = safe_assoc verbose f str in
-                  printf " %s%s" (canonize file_str)
-                    (if spec then !suffixe_spec else !suffixe)
-                with Not_found -> 
-		  if verbose && not (List.mem_assoc str !coqlibKnown) then
-                    warning_module_notfound f str
-       	      end
+	  | Require (spec,strl) ->
+	      List.iter (fun str ->
+		if not (List.mem str !deja_vu_v) then begin
+	          addQueue deja_vu_v str;
+                  try
+                    let file_str = safe_assoc verbose f str in
+                    printf " %s%s" (canonize file_str)
+                      (if spec then !suffixe_spec else !suffixe)
+                  with Not_found -> 
+		    if verbose && not (List.mem_assoc str !coqlibKnown) then
+                      warning_module_notfound f str
+       		end) strl
 	  | RequireString (spec,s) -> 
 	      let str = Filename.basename s in
 	      if not (List.mem [str] !deja_vu_v) then begin
@@ -332,7 +342,7 @@ let mL_dependencies () =
        flush stdout)
     (List.rev !mlAccu);
   List.iter
-    (fun ((name,ext,dirname) as pairname) ->
+    (fun ((name,ext,dirname)) ->
        let fullname = file_name ([name],dirname) in
        let (dep,_) = traite_fichier_ML fullname ext in
        printf "%s.cmi: %s%s" fullname fullname ext;
@@ -512,6 +522,7 @@ let coqdep () =
       | "-coqlib" :: [] -> usage ()
       | "-suffix" :: (s :: ll) -> suffixe := s ; suffixe_spec := s; parse ll
       | "-suffix" :: [] -> usage ()
+      | "-slash" :: ll -> option_slash := true; parse ll
       | f :: ll -> treat None f; parse ll
       | [] -> ()
   in
@@ -523,6 +534,7 @@ let coqdep () =
   List.iter 
     (fun (s,_) -> add_coqlib_directory s)
     (all_subdirs (!coqlib/"contrib") "Coq");
+  add_coqlib_directory (!coqlib/"user-contrib");
   mliKnown := !mliKnown @ (List.map (fun (f,_,d) -> (f,d)) !mliAccu);
   mlKnown  := !mlKnown @ (List.map (fun (f,_,d) -> (f,d)) !mlAccu);
   warning_mult ".mli" !mliKnown;
diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll
index 4f5f172f..8ecab3b4 100755
--- a/tools/coqdep_lexer.mll
+++ b/tools/coqdep_lexer.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqdep_lexer.mll,v 1.6.6.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+(*i $Id: coqdep_lexer.mll 8737 2006-04-26 21:55:21Z herbelin $ i*)
   
 {
 
@@ -18,7 +18,7 @@
   type spec = bool
 		
   type coq_token = 
-    | Require of spec * string list
+    | Require of spec * string list list
     | RequireString of spec * string
     | Declare of string list
     | Load of string
@@ -27,7 +27,8 @@
  
   exception Fin_fichier
     
-  let module_name = ref []
+  let module_current_name = ref []
+  let module_names = ref []
   let ml_module_name = ref ""
 		      
   let specif = ref false
@@ -48,13 +49,11 @@ let dot = '.' ( space+ | eof)
 
 rule coq_action = parse
   | "Require" space+
-      { specif := false; opened_file lexbuf }
+      { specif := false; module_names := []; opened_file lexbuf }
   | "Require" space+ "Export" space+
-      { specif := false; opened_file lexbuf}
-  | "Require" space+ "Syntax" space+
-      { specif := false; opened_file lexbuf}
+      { specif := false; module_names := []; opened_file lexbuf}
   | "Require" space+ "Import" space+
-      { specif := false; opened_file lexbuf}
+      { specif := false; module_names := []; opened_file lexbuf}
   | "Declare" space+ "ML" space+ "Module" space+
       { mllist := []; modules lexbuf}
   | "Load" space+
@@ -175,7 +174,7 @@ and opened_file = parse
   | "Specification"
                 { specif := true; opened_file lexbuf }
   | coq_ident
-       	       	{ module_name := [Lexing.lexeme lexbuf];
+       	       	{ module_current_name := [Lexing.lexeme lexbuf];
                   opened_file_fields lexbuf }
 
   | '"' [^'"']* '"'   { (*'"'*)
@@ -186,23 +185,28 @@ and opened_file = parse
                             Filename.chop_suffix str ".v"
                           else str in
 			RequireString (!specif, str) }
-  | eof		      { raise Fin_fichier }
-  | _		      { opened_file lexbuf }
+  | eof         { raise Fin_fichier }
+  | _           { opened_file lexbuf }
 
 and opened_file_fields = parse
   | "(*" (* "*)" *)
                 { comment_depth := 1; comment lexbuf;
                   opened_file_fields lexbuf }
   | space+
-      	       	{ opened_file_fields lexbuf }
+                { opened_file_fields lexbuf }
   | coq_field
-       	       	{ module_name :=
-                    field_name (Lexing.lexeme lexbuf) :: !module_name;
+                { module_current_name :=
+                    field_name (Lexing.lexeme lexbuf) :: !module_current_name;
                   opened_file_fields lexbuf }
-  | dot               { Require (!specif, List.rev !module_name) }
-  | eof		      { raise Fin_fichier }
-  | _		      { opened_file_fields lexbuf }
-
+  | coq_ident   { module_names := 
+                    List.rev !module_current_name :: !module_names;
+                  module_current_name := [Lexing.lexeme lexbuf];
+                  opened_file_fields lexbuf }
+  | dot         { module_names :=
+                    List.rev !module_current_name :: !module_names;
+                  Require (!specif, List.rev !module_names) }
+  | eof         { raise Fin_fichier }
+  | _           { opened_file_fields lexbuf }
 
 and modules = parse
   | space+              { modules lexbuf }
diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml
index 2418b6e1..b1a46bae 100644
--- a/tools/coqdoc/alpha.ml
+++ b/tools/coqdoc/alpha.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: alpha.ml,v 1.1.2.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+(*i $Id: alpha.ml 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 let norm_char c = match Char.uppercase c with
   | '\192'..'\198' -> 'A'
diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli
index 46409c9a..d3c26537 100644
--- a/tools/coqdoc/alpha.mli
+++ b/tools/coqdoc/alpha.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: alpha.mli,v 1.1.2.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+(*i $Id: alpha.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Alphabetic order. *)
 
diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml
new file mode 100644
index 00000000..8a774876
--- /dev/null
+++ b/tools/coqdoc/cdglobals.ml
@@ -0,0 +1,72 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+
+
+(*s Output options *)
+
+type target_language = LaTeX | HTML | TeXmacs
+
+let target_language = ref HTML
+
+type output_t =
+  | StdOut
+  | MultFiles
+  | File of string
+
+let output_dir = ref ""
+
+let out_to = ref MultFiles
+
+let out_channel = ref stdout
+
+let open_out_file f =
+  let f = if !output_dir <> "" then Filename.concat !output_dir f else f in
+    out_channel := open_out f
+
+let close_out_file () = close_out !out_channel
+
+
+let header_trailer = ref true
+let quiet = ref false
+let light = ref false
+let gallina = ref false
+let short = ref false
+let index = ref true
+let multi_index = ref false
+let toc = ref false
+let page_title = ref ""
+let title = ref ""
+let externals = ref true
+let coqlib = ref "http://coq.inria.fr/library/"
+let coqlib_path = ref Coq_config.coqlib
+let raw_comments = ref false
+
+let charset = ref "iso-8859-1"
+let inputenc = ref ""
+let latin1 = ref false
+let utf8 = ref false
+
+let set_latin1 () =
+  charset := "iso-8859-1";
+  inputenc := "latin1";
+  latin1 := true
+
+let set_utf8 () =
+  charset := "utf-8";
+  inputenc := "utf8";
+  utf8 := true
+
+(* Parsing options *)
+
+type coq_module = string
+
+type file =
+  | Vernac_file of string * coq_module
+  | Latex_file of string
+      
diff --git a/tools/coqdoc/coqdoc.css b/tools/coqdoc/coqdoc.css
new file mode 100644
index 00000000..3900987e
--- /dev/null
+++ b/tools/coqdoc/coqdoc.css
@@ -0,0 +1,67 @@
+body { padding: 0px 0px;
+       margin: 0px 0px; 
+       background-color: white }
+
+#page { display: block;
+        padding: 0px;
+        margin: 0px;
+        padding-bottom: 10px; }
+
+#header { display: block;
+          position: relative;
+          padding: 0;
+          margin: 0;
+          vertical-align: middle;
+          border-bottom-style: solid;
+          border-width: thin }
+
+#header h1 { padding: 0; 
+             margin: 0;}
+
+
+/* Contenu */
+
+#main{ display: block;
+       padding: 10px;
+       overflow: hidden;
+       font-size: 10pt }
+
+#main  a.idref:visited {color : #416DFF; text-decoration : none; }
+#main  a.idref:link {color : #416DFF; text-decoration : none; }
+#main  a.idref:hover {text-decoration : none; }
+#main  a.idref:active {text-decoration : none; }
+
+#main  a.modref:visited {color : #416DFF; text-decoration : none; }
+#main  a.modref:link {color : #416DFF; text-decoration : none; }
+#main  a.modref:hover {text-decoration : none; }
+#main  a.modref:active {text-decoration : none; }
+
+#main .keyword { color : #cf1d1d }
+#main { color: black }
+
+#main .section { background-color:#899BD6;
+                 font-size : 20pt }
+
+#main code { font-family: monospace; 
+             line-height: 50% }
+
+#main .doc { margin: 0px;
+             padding: 10px;
+             font-family: sans-serif;
+             font-size: 11pt;
+             font-weight:bold;
+             color: black;
+             background-color: #90bdff;
+             border-style: plain}
+
+#main .doc code { font-family: monospace} 
+
+/* Pied de page */
+
+#footer { font-size: 8pt;
+          font-family: sans-serif; }
+
+#footer a:visited { color: blue; }
+#footer a:link { text-decoration: none; 
+                 color: #888888; }
+
diff --git a/tools/coqdoc/coqdoc.sty b/tools/coqdoc/coqdoc.sty
index 68b9ab26..2c07b9fc 100644
--- a/tools/coqdoc/coqdoc.sty
+++ b/tools/coqdoc/coqdoc.sty
@@ -9,13 +9,13 @@
 \ProvidesPackage{coqdoc}[2002/02/11]
 
 % Headings
-
 \usepackage{fancyhdr}
 \newcommand{\coqdocleftpageheader}{\thepage\ -- \today}
 \newcommand{\coqdocrightpageheader}{\today\ -- \thepage}
 \pagestyle{fancyplain}
 
 %BEGIN LATEX
+\headsep 8mm
 \renewcommand{\plainheadrulewidth}{0.4pt}
 \renewcommand{\plainfootrulewidth}{0pt}
 \lhead[\coqdocleftpageheader]{\leftmark}
@@ -50,7 +50,8 @@
 %HEVEA\newcommand{\coqdocindent}[1]{\hspace{#1}\hspace{#1}}
 
 % macro for typesetting the title of a module implementation
-\newcommand{\coqdocmodule}[1]{\section*{Module #1}\markboth{Module #1}{}}
+\newcommand{\coqdocmodule}[1]{\chapter{Module #1}\markboth{Module #1}{}
+}
 
 %HEVEA\newcommand{\lnot}{\coqwkw{not}}
 %HEVEA\newcommand{\lor}{\coqwkw{or}}
diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli
index 60c21387..4b53d6ff 100644
--- a/tools/coqdoc/index.mli
+++ b/tools/coqdoc/index.mli
@@ -6,9 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: index.mli,v 1.1.2.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+(*i $Id: index.mli 8617 2006-03-08 10:47:12Z notin $ i*)
 
-type coq_module = string
+open Cdglobals
 
 type loc = int
 
diff --git a/tools/coqdoc/index.mll b/tools/coqdoc/index.mll
index 875a2337..5b281b8b 100644
--- a/tools/coqdoc/index.mll
+++ b/tools/coqdoc/index.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: index.mll,v 1.2.2.2 2004/08/03 17:31:04 herbelin Exp $ i*)
+(*i $Id: index.mll 9204 2006-10-04 13:05:58Z notin $ i*)
 
 {
 
@@ -14,7 +14,7 @@ open Filename
 open Lexing 
 open Printf
 
-type coq_module = string
+open Cdglobals
 
 type loc = int
 
@@ -34,11 +34,14 @@ type index_entry =
   | Ref of coq_module * string
   | Mod of coq_module * string
 
-let table = Hashtbl.create 97
+let current_type = ref Library
+let current_library = ref ""
+  (** referes to the file being parsed *)
 
-let current_module = ref ""
+let table = Hashtbl.create 97
+  (** [table] is used to store references and definitions *)
 
-let add_def loc ty id = Hashtbl.add table (!current_module, loc) (Def (id, ty))
+let add_def loc ty id = Hashtbl.add table (!current_library, loc) (Def (id, ty))
 
 let add_ref m loc m' id = Hashtbl.add table (m, loc) (Ref (m', id))
 
@@ -46,7 +49,55 @@ let add_mod m loc m' id = Hashtbl.add table (m, loc) (Mod (m', id))
 
 let find m l = Hashtbl.find table (m, l)
 
-let current_type = ref Library
+
+(*s Manipulating path prefixes *) 
+
+type stack = string list 
+
+let rec string_of_stack st =
+  match st with
+    | [] -> ""
+    | x::[] -> x
+    | x::tl -> (string_of_stack tl) ^ "." ^ x
+
+let empty_stack = []
+
+let module_stack = ref empty_stack
+let section_stack = ref empty_stack
+
+let init_stack () =
+  module_stack := empty_stack; section_stack := empty_stack
+
+let push st p = st := p::!st
+let pop st = 
+  match !st with 
+    | [] -> ()
+    | _::tl -> st := tl
+	
+let head st =
+  match st with
+    | [] -> ""
+    | x::_ -> x
+
+let begin_module m = push module_stack m
+let begin_section s = push section_stack s
+
+let end_block id =
+  (** determines if it ends a module or a section and pops the stack *)
+  if ((String.compare (head !module_stack) id ) == 0) then
+    pop module_stack
+  else if ((String.compare (head !section_stack) id) == 0) then
+    pop section_stack
+  else
+    ()
+
+let make_fullid id = 
+  (** prepends the current module path to an id *)
+  let path = string_of_stack !module_stack in
+    if String.length path > 0 then
+      path ^ "." ^ id
+    else 
+      id
 
 (* Coq modules *)
 
@@ -83,7 +134,7 @@ let ref_module loc s =
     let n = String.length s in
     let i = String.rindex s ' ' in 
     let id = String.sub s (i+1) (n-i-1) in
-    add_mod !current_module (loc+i+1) (Hashtbl.find modules id) id
+      add_mod !current_library (loc+i+1) (Hashtbl.find modules id) id
   with Not_found -> 
     ()
 
@@ -104,25 +155,25 @@ let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2
 
 let sort_entries el =
   let t = Hashtbl.create 97 in
-  List.iter 
-    (fun c -> Hashtbl.add t c [])
-    ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; 
-     'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_'];  
-  List.iter 
-    (fun ((s,_) as e) -> 
-       let c = Alpha.norm_char s.[0] in 
-       let l = try Hashtbl.find t c with Not_found -> [] in
-       Hashtbl.replace t c (e :: l)) 
-    el;
-  let res = ref [] in
-  Hashtbl.iter 
-    (fun c l -> res := (c, List.sort compare_entries l) :: !res) t;
-  List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res
-    
+    List.iter 
+      (fun c -> Hashtbl.add t c [])
+      ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; 
+       'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_'];  
+    List.iter 
+      (fun ((s,_) as e) -> 
+	 let c = Alpha.norm_char s.[0] in 
+	 let l = try Hashtbl.find t c with Not_found -> [] in
+	   Hashtbl.replace t c (e :: l)) 
+      el;
+    let res = ref [] in
+      Hashtbl.iter 
+	(fun c l -> res := (c, List.sort compare_entries l) :: !res) t;
+      List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res
+	
 let index_size = List.fold_left (fun s (_,l) -> s + List.length l) 0
-
+  
 let hashtbl_elements h = Hashtbl.fold (fun x y l -> (x,y)::l) h []
-
+  
 let type_name = function
   | Library -> "library"
   | Module -> "module"
@@ -133,28 +184,28 @@ let type_name = function
   | Variable -> "variable"
   | Axiom -> "axiom"
   | TacticDefinition -> "tactic"
-
+      
 let all_entries () =
   let gl = ref [] in
   let add_g s m t = gl := (s,(m,t)) :: !gl in
   let bt = Hashtbl.create 11 in
   let add_bt t s m =
     let l = try Hashtbl.find bt t with Not_found -> [] in
-    Hashtbl.replace bt t ((s,m) :: l)
+      Hashtbl.replace bt t ((s,m) :: l)
   in
   let classify (m,_) e = match e with 
     | Def (s,t) -> add_g s m t; add_bt t s m
     | Ref _ | Mod _ -> ()
   in
-  Hashtbl.iter classify table;
-  Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules;
-  { idx_name = "global"; 
-    idx_entries = sort_entries !gl; 
-    idx_size = List.length !gl },
-  Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; 
+    Hashtbl.iter classify table;
+    Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules;
+    { idx_name = "global"; 
+      idx_entries = sort_entries !gl; 
+      idx_size = List.length !gl },
+    Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; 
 				   idx_entries = sort_entries e; 
 				   idx_size = List.length e }) :: l) bt []
-
+    
 }
 
 (*s Shortcuts for regular expressions. *)
@@ -165,15 +216,14 @@ let firstchar =
   ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255']
 let identchar = 
   ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' 
-   '\'' '0'-'9']
-let ident = 
-  firstchar identchar*
+     '\'' '0'-'9']
+let ident = firstchar identchar*
 
 let begin_hide = "(*" space* "begin" space+ "hide" space* "*)"
 let end_hide = "(*" space* "end" space+ "hide" space* "*)"
-
+  
 (*s Indexing entry point. *)
-
+  
 rule traverse = parse
   | "Definition" space
       { current_type := Definition; index_ident lexbuf; traverse lexbuf }
@@ -192,13 +242,15 @@ rule traverse = parse
   | "Record" space
       { current_type := Inductive; index_ident lexbuf; traverse lexbuf }
   | "Module" (space+ "Type")? space
-      { current_type := Module; index_ident lexbuf; traverse lexbuf }
+      { current_type := Module; module_ident lexbuf; traverse lexbuf }
 (*i***
   | "Variable" 's'? space
       { current_type := Variable; index_idents lexbuf; traverse lexbuf }
 ***i*)
   | "Require" (space+ ("Export"|"Import"))? space+ ident
       { ref_module (lexeme_start lexbuf) (lexeme lexbuf); traverse lexbuf }
+  | "End" space+ 
+      { end_ident lexbuf; traverse lexbuf }
   | begin_hide 
       { skip_hide lexbuf; traverse lexbuf }
   | "(*" 
@@ -216,7 +268,16 @@ and index_ident = parse
   | space+ 
       { index_ident lexbuf }
   | ident  
-      { add_def (lexeme_start lexbuf) !current_type (lexeme lexbuf) }
+      { let fullid = 
+	  let id = lexeme lexbuf in
+	    match !current_type with
+	      | Definition
+	      | Inductive
+	      | Constructor 
+	      | Lemma -> make_fullid id
+	      | _ -> id 
+	in 
+	  add_def (lexeme_start lexbuf) !current_type fullid }
   | eof    
       { () }
   | _      
@@ -234,12 +295,12 @@ and index_idents = parse
       { () }
   | _
       { skip_until_point lexbuf }
-
+      
 (*s Index identifiers in an inductive definition (types and constructors). *)
-
+      
 and inductive = parse
   | '|' | ":=" space* '|'? 
-      { current_type := Constructor; index_ident lexbuf; inductive lexbuf }
+	{ current_type := Constructor; index_ident lexbuf; inductive lexbuf }
   | "with" space
       { current_type := Inductive; index_ident lexbuf; inductive lexbuf }
   | '.'    
@@ -248,9 +309,9 @@ and inductive = parse
       { () }
   | _      
       { inductive lexbuf }
-
+      
 (*s Index identifiers in a Fixpoint declaration. *)
-
+      
 and fixpoint = parse
   | "with" space
       { index_ident lexbuf; fixpoint lexbuf }
@@ -260,9 +321,9 @@ and fixpoint = parse
       { () }
   | _      
       { fixpoint lexbuf }
-
+      
 (*s Skip a possibly nested comment. *)
-
+      
 and comment = parse
   | "*)" { () }
   | "(*" { comment lexbuf; comment lexbuf }
@@ -271,25 +332,49 @@ and comment = parse
   | _    { comment lexbuf }
 
 (*s Skip a constant string. *)
-
+      
 and string = parse
   | '"'  { () }
   | eof  { eprintf " *** Unterminated string while indexing" }
   | _    { string lexbuf }
 
 (*s Skip everything until the next dot. *)
-
+      
 and skip_until_point = parse
   | '.'  { () }
   | eof  { () }
   | _    { skip_until_point lexbuf }
-
+      
 (*s Skip everything until [(* end hide *)] *)
 
 and skip_hide = parse
   | eof | end_hide { () }
   | _ { skip_hide lexbuf }
 
+and end_ident = parse
+  | space+ 
+      { end_ident lexbuf }
+  | ident  
+      { let id = lexeme lexbuf in end_block id }
+  | eof    
+      { () }
+  | _      
+      { () }
+
+and module_ident = parse
+  | space+
+      { module_ident lexbuf }
+  | '"' { string lexbuf; module_ident lexbuf }
+  | ident space* ":="
+      { () }
+  | ident
+      { let id = lexeme lexbuf in
+	  begin_module id; add_def (lexeme_start lexbuf) !current_type id }
+  | eof
+      { () }
+  | _
+      { () }
+
 {
   
   let read_glob f = 
@@ -306,10 +391,11 @@ and skip_hide = parse
 	    | 'R' ->
 		(try
 		   let i = String.index s ' ' in
+		   let j = String.index_from s (i+1) ' ' in 
 		   let loc = int_of_string (String.sub s 1 (i - 1)) in
-		   let sp = String.sub s (i + 1) (n - i - 1) in
-		   let m',id = split_sp sp in
-		   add_ref !cur_mod loc m' id
+		   let lib_dp = String.sub s (i + 1) (j - i - 1) in
+		   let full_id = String.sub s (j + 1) (n - j - 1) in
+		     add_ref !cur_mod loc lib_dp full_id
 		 with Not_found -> 
 		   ())
 	    | _ -> ()
@@ -317,11 +403,11 @@ and skip_hide = parse
       done
     with End_of_file -> 
       close_in c
-
+	
   let scan_file f m = 
-    current_module := m;
+    init_stack (); current_library := m;
     let c = open_in f in
     let lb = from_channel c in
-    traverse lb;
-    close_in c
+      traverse lb;
+      close_in c
 }
diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml
index 66d2a993..18a44a44 100644
--- a/tools/coqdoc/main.ml
+++ b/tools/coqdoc/main.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: main.ml,v 1.4.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: main.ml 8777 2006-05-02 10:14:39Z notin $ i*)
 
 (* Modified by Lionel Elie Mamane <lionel@mamane.lu> on 9 & 10 Mar 2004:
  *  - handling of absolute filenames (function coq_module)
@@ -18,6 +18,7 @@
  * It may be removed or abbreviated as far as I am concerned.
  *)
 
+open Cdglobals
 open Filename
 open Printf
 open Output
@@ -33,6 +34,7 @@ let usage () =
   prerr_endline "  --texmacs           produce a TeXmacs document";
   prerr_endline "  --dvi               output the DVI";
   prerr_endline "  --ps                output the PostScript";
+  prerr_endline "  --stdout            write output to stdout";
   prerr_endline "  -o <file>           write output in file <file>";
   prerr_endline "  -d <dir>            output files into directory <dir>";
   prerr_endline "  -g                  (gallina) skip proofs";
@@ -52,14 +54,13 @@ let usage () =
   prerr_endline "  --no-externals      no links to Coq standard library";
   prerr_endline "  --coqlib <url>      set URL for Coq standard library";
   prerr_endline "                      (default is http://coq.inria.fr/library/)";
+  prerr_endline "  --coqlib_path <dir> set the path where Coq files are installed";
   prerr_endline "  -R <dir> <coqdir>   map physical dir to Coq dir";
   prerr_endline "  --latin1            set ISO-8859-1 input language";
   prerr_endline "  --utf8              set UTF-8 input language";
   prerr_endline "  --charset <string>  set HTML charset";
   prerr_endline "  --inputenc <string> set LaTeX input encoding";
   prerr_endline "";
-  prerr_endline 
-    "On-line documentation at http://www.lri.fr/~filliatr/coqdoc/\n";
   exit 1
 
 (*s \textbf{Banner.} Always printed. Notice that it is printed on error
@@ -72,7 +73,11 @@ let banner () =
     Coq_config.version Coq_config.compile_date;
   flush stderr
     
-
+let target_full_name f = 
+  match !target_language with
+    | HTML -> f ^ ".html"
+    | _ -> f ^ ".tex"
+	
 (*s \textbf{Separation of files.} Files given on the command line are
     separated according to their type, which is determined by their
     suffix.  Coq files have suffixe \verb!.v! or \verb!.g! and \LaTeX\
@@ -83,11 +88,11 @@ let check_if_file_exists f =
     eprintf "\ncoqdoc: %s: no such file\n" f;
     exit 1
   end
-
+    
 let paths = ref []
-
+  
 let add_path m l = paths := (m,l) :: !paths
-
+  
 let exists_dir dir =
   try let _ = Unix.opendir dir in true with Unix.Unix_error _ -> false
 
@@ -95,72 +100,72 @@ let add_rec_path f l =
   let rec traverse abs rel =
     add_path abs rel;
     let dirh = Unix.opendir abs in
-    try
-      while true do
-	let f = Unix.readdir dirh in
-	if f <> "" && f.[0] <> '.' && f <> "CVS" then
-	  let abs' = Filename.concat abs f in
-	  try 
-	    if exists_dir abs' then  traverse abs' (rel ^ "." ^ f)
-	  with Unix.Unix_error _ -> 
-	    ()
-      done
-    with End_of_file ->
-      Unix.closedir dirh
+      try
+	while true do
+	  let f = Unix.readdir dirh in
+	    if f <> "" && f.[0] <> '.' && f <> "CVS" then
+	      let abs' = Filename.concat abs f in
+		try 
+		  if exists_dir abs' then  traverse abs' (rel ^ "." ^ f)
+		with Unix.Unix_error _ -> 
+		  ()
+	done
+      with End_of_file ->
+	Unix.closedir dirh
   in
-  if exists_dir f then traverse f l
+    if exists_dir f then traverse f l
 
 (* turn A/B/C into A.B.C *)
 let make_path = Str.global_replace (Str.regexp "/") ".";;
 
 let coq_module file = 
-(* TODO
- * LEM:
- * We should also remove things like "/./" in the middle of the filename,
- * rewrite "/foo/../bar" to "/bar", recognise different paths that lead
- * to the same file / directory (via symlinks), etc. The best way to do
- * all this would be to use the libc function realpath() on _both_ p and
- * file / f before comparing them.
- *
- * The semantics of realpath() on file symlinks might not be what we
- * want... (But it is what we want on directory symlinks.) So, we would
- * have to cook up our own version of realpath()?
- *
- * Do all target platforms have realpath()?
- *)
+  (* TODO
+   * LEM:
+   * We should also remove things like "/./" in the middle of the filename,
+   * rewrite "/foo/../bar" to "/bar", recognise different paths that lead
+   * to the same file / directory (via symlinks), etc. The best way to do
+   * all this would be to use the libc function realpath() on _both_ p and
+   * file / f before comparing them.
+   *
+   * The semantics of realpath() on file symlinks might not be what we
+   * want... (But it is what we want on directory symlinks.) So, we would
+   * have to cook up our own version of realpath()?
+   *
+   * Do all target platforms have realpath()?
+   *)
   let f = chop_extension file in
-  (* remove leading ./ and any number of slashes after *)
+    (* remove leading ./ and any number of slashes after *)
   let f = Str.replace_first (Str.regexp "^\\./+") "" f in
-  if (Str.string_before f 1) = "/" then
-    (* f is an absolute path. Prefixes must be matched with the beginning of f,
-     * not prepended
-     *)
-    let rec trypath = function
-     | [] -> make_path f
-     | (p, lg) :: r ->
-         (* make sure p ends with a single '/'
-          * This guarantees that we don't match a file whose name is
-          * of the form p ^ "foo". It means we may miss p itself,
-          * but this does not matter: coqdoc doesn't do anything
-          * of a directory anyway. *)
-         let p = (Str.replace_first (Str.regexp "/*$") "/" p) in
-         let p_quoted = (Str.quote p) in
-         if (Str.string_match (Str.regexp p_quoted) f 0) then
-           make_path (Filename.concat lg (Str.replace_first (Str.regexp (p_quoted ^ "/*")) "" f))
-        else
-           trypath r
-    in trypath !paths
-  else (* f is a relative path *)
-    let rec trypath = function
-      | [] -> 
-	  make_path f
-      | (p,lg) :: r ->
-	  let p_file = Filename.concat p file in
-	  if Sys.file_exists p_file then
-	    make_path (Filename.concat lg f)
-	  else
-	    trypath r
-    in trypath !paths;;
+    if (Str.string_before f 1) = "/" then
+      (* f is an absolute path. Prefixes must be matched with the beginning of f,
+       * not prepended
+       *)
+      let rec trypath = function
+	| [] -> make_path f
+	| (p, lg) :: r ->
+            (* make sure p ends with a single '/'
+             * This guarantees that we don't match a file whose name is
+             * of the form p ^ "foo". It means we may miss p itself,
+             * but this does not matter: coqdoc doesn't do anything
+             * of a directory anyway. *)
+            let p = (Str.replace_first (Str.regexp "/*$") "/" p) in
+            let p_quoted = (Str.quote p) in
+              if (Str.string_match (Str.regexp p_quoted) f 0) then
+		make_path (Filename.concat lg (Str.replace_first (Str.regexp (p_quoted ^ "/*")) "" f))
+              else
+		trypath r
+      in trypath !paths
+    else (* f is a relative path *)
+      let rec trypath = function
+	| [] -> 
+	    make_path f
+	| (p,lg) :: r ->
+	    let p_file = Filename.concat p file in
+	      if Sys.file_exists p_file then
+		make_path (Filename.concat lg f)
+	      else
+		trypath r
+      in trypath !paths;;
 
 let what_file f =
   check_if_file_exists f;
@@ -172,43 +177,43 @@ let what_file f =
     eprintf "\ncoqdoc: don't know what to do with %s\n" f;
     exit 1
   end
-
+    
 (*s \textbf{Reading file names from a file.} 
-    File names may be given
-    in a file instead of being given on the command
-    line. [(files_from_file f)] returns the list of file names contained
-    in the file named [f]. These file names must be separated by spaces,
-    tabulations or newlines.
+ *  File names may be given
+ *  in a file instead of being given on the command
+ *  line. [(files_from_file f)] returns the list of file names contained
+ *  in the file named [f]. These file names must be separated by spaces,
+ *  tabulations or newlines.
  *)
 
 let files_from_file f =
   let files_from_channel ch =
     let buf = Buffer.create 80 in
     let l = ref [] in
-    try
-      while true do
-	match input_char ch with
-	  | ' ' | '\t' | '\n' ->
-	      if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l;
-	      Buffer.clear buf
-	  | c -> 
-	      Buffer.add_char buf c
-      done; []
-    with End_of_file ->
-      List.rev !l
+      try
+	while true do
+	  match input_char ch with
+	    | ' ' | '\t' | '\n' ->
+		if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l;
+		Buffer.clear buf
+	    | c -> 
+		Buffer.add_char buf c
+	done; []
+      with End_of_file ->
+	List.rev !l
   in
-  try
-    check_if_file_exists f;
-    let ch = open_in f in
-    let l = files_from_channel ch in
-    close_in ch;l
-  with Sys_error s -> begin
-    eprintf "\ncoqdoc: cannot read from file %s (%s)\n" f s;
-    exit 1
-  end
-
+    try
+      check_if_file_exists f;
+      let ch = open_in f in
+      let l = files_from_channel ch in
+	close_in ch;l
+    with Sys_error s -> begin
+      eprintf "\ncoqdoc: cannot read from file %s (%s)\n" f s;
+      exit 1
+    end
+      
 (*s \textbf{Parsing of the command line.} *)
-
+      
 let output_file = ref ""
 let dvi = ref false
 let ps = ref false
@@ -218,9 +223,9 @@ let parse () =
   let add_file f = files := f :: !files in
   let rec parse_rec = function
     | [] -> ()
-
+	
     | ("-nopreamble" | "--nopreamble" | "--no-preamble"
-    |  "-bodyonly"   | "--bodyonly"   | "--body-only") :: rem ->
+      |  "-bodyonly"   | "--bodyonly"   | "--body-only") :: rem ->
 	header_trailer := false; parse_rec rem
     | ("-p" | "--preamble") :: s :: rem ->
 	push_in_preamble s; parse_rec rem
@@ -232,8 +237,10 @@ let parse () =
 	multi_index := true; parse_rec rem
     | ("-toc" | "--toc" | "--table-of-contents") :: rem ->
 	toc := true; parse_rec rem
+    | ("-stdout" | "--stdout") :: rem ->
+	out_to := StdOut; parse_rec rem
     | ("-o" | "--output") :: f :: rem ->
-	output_file := f; parse_rec rem
+	out_to := File (Filename.basename f); output_dir := Filename.dirname f; parse_rec rem
     | ("-o" | "--output") :: [] -> 
 	usage ()
     | ("-d" | "--directory") :: dir :: rem ->
@@ -251,34 +258,33 @@ let parse () =
     | ("-t" | "-title" | "--title") :: [] ->
 	usage ()
     | ("-latex" | "--latex") :: rem ->
-	Output.target_language := LaTeX; parse_rec rem
+	Cdglobals.target_language := LaTeX; parse_rec rem
     | ("-dvi" | "--dvi") :: rem ->
-	Output.target_language := LaTeX; dvi := true; parse_rec rem
+	Cdglobals.target_language := LaTeX; dvi := true; parse_rec rem
     | ("-ps" | "--ps") :: rem ->
-	Output.target_language := LaTeX; ps := true; parse_rec rem
+	Cdglobals.target_language := LaTeX; ps := true; parse_rec rem
     | ("-html" | "--html") :: rem ->
-	Output.target_language := HTML; parse_rec rem
+	Cdglobals.target_language := HTML; parse_rec rem
     | ("-texmacs" | "--texmacs") :: rem ->
-	Output.target_language := TeXmacs; parse_rec rem
-
+	Cdglobals.target_language := TeXmacs; parse_rec rem
     | ("-charset" | "--charset") :: s :: rem ->
-	Output.charset := s; parse_rec rem
+	Cdglobals.charset := s; parse_rec rem
     | ("-charset" | "--charset") :: [] ->
 	usage ()
     | ("-inputenc" | "--inputenc") :: s :: rem ->
-	Output.inputenc := s; parse_rec rem
+	Cdglobals.inputenc := s; parse_rec rem
     | ("-inputenc" | "--inputenc") :: [] ->
 	usage ()
     | ("-raw-comments" | "--raw-comments") :: rem ->
-	Output.raw_comments := true; parse_rec rem
+	Cdglobals.raw_comments := true; parse_rec rem
     | ("-latin1" | "--latin1") :: rem ->
-	Output.set_latin1 (); parse_rec rem
+	Cdglobals.set_latin1 (); parse_rec rem
     | ("-utf8" | "--utf8") :: rem ->
-	Output.set_utf8 (); parse_rec rem
-
+	Cdglobals.set_utf8 (); parse_rec rem
+	  
     | ("-q" | "-quiet" | "--quiet") :: rem ->
 	quiet := true; parse_rec rem
-
+	  
     | ("-h" | "-help" | "-?" | "--help") :: rem ->
 	banner (); usage ()
     | ("-v" | "-version" | "--version") :: _ ->
@@ -298,7 +304,6 @@ let parse () =
 	parse_rec rem
     | ("-files" | "--files") :: [] ->
 	usage ()
-
     | "-R" :: path :: log :: rem -> 
 	add_path path log; parse_rec rem
     | "-R" :: ([] | [_]) ->
@@ -308,19 +313,22 @@ let parse () =
     | ("-glob-from" | "--glob-from") :: [] ->
 	usage ()
     | ("--no-externals" | "-no-externals" | "-noexternals") :: rem ->
-	Output.externals := false; parse_rec rem
+	Cdglobals.externals := false; parse_rec rem
     | ("--coqlib" | "-coqlib") :: u :: rem ->
-	Output.coqlib := u; parse_rec rem
+	Cdglobals.coqlib := u; parse_rec rem
     | ("--coqlib" | "-coqlib") :: [] ->
 	usage ()
-
+    | ("--coqlib_path" | "-coqlib_path") :: d :: rem ->
+	Cdglobals.coqlib_path := d; parse_rec rem
+    | ("--coqlib_path" | "-coqlib_path") :: [] ->
+	usage ()
     | f :: rem -> 
 	add_file (what_file f); parse_rec rem
   in 
-  parse_rec (List.tl (Array.to_list Sys.argv));
-  List.rev !files
-
+    parse_rec (List.tl (Array.to_list Sys.argv));
+    List.rev !files
 
+      
 (*s The following function produces the output. The default output is
     the \LaTeX\ document: in that case, we just call [Web.produce_document]. 
     If option \verb!-dvi!, \verb!-ps! or \verb!-html! is invoked, then
@@ -328,84 +336,160 @@ let parse () =
 
 let locally dir f x =
   let cwd = Sys.getcwd () in
-  try
-    Sys.chdir dir; let y = f x in Sys.chdir cwd; y
-  with e ->
-    Sys.chdir cwd; raise e
+    try
+      Sys.chdir dir; let y = f x in Sys.chdir cwd; y
+    with e ->
+      Sys.chdir cwd; raise e
 
 let clean_temp_files basefile =
   let remove f = try Sys.remove f with _ -> () in
-  remove (basefile ^ ".tex");
-  remove (basefile ^ ".log");
-  remove (basefile ^ ".aux");
-  remove (basefile ^ ".dvi");
-  remove (basefile ^ ".ps");
-  remove (basefile ^ ".haux");
-  remove (basefile ^ ".html")
-
+    remove (basefile ^ ".tex");
+    remove (basefile ^ ".log");
+    remove (basefile ^ ".aux");
+    remove (basefile ^ ".dvi");
+    remove (basefile ^ ".ps");
+    remove (basefile ^ ".haux");
+    remove (basefile ^ ".html")
+      
 let clean_and_exit file res = clean_temp_files file; exit res
-
+  
 let cat file =
   let c = open_in file in
-  try
-    while true do print_char (input_char c) done
-  with End_of_file ->
-    close_in c
+    try
+      while true do print_char (input_char c) done
+    with End_of_file ->
+      close_in c
 
 let copy src dst =
   let cin = open_in src 
   and cout = open_out dst in
-  try
-    while true do Pervasives.output_char cout (input_char cin) done
-  with End_of_file ->
-    close_in cin; close_out cout
+    try
+      while true do Pervasives.output_char cout (input_char cin) done
+    with End_of_file ->
+      close_in cin; close_out cout
 
+
+(*s Functions for generating output files *)
+	
+let gen_one_file l =
+  let file = function
+    | Vernac_file (f,m) -> 
+	set_module m; coq_file f m
+    | Latex_file _ -> ()
+  in
+    if (!header_trailer) then header ();
+    if !toc then make_toc ();
+    List.iter file l;
+    if !index then make_index();
+    if (!header_trailer) then trailer ()
+      
+let gen_mult_files l =
+  let file = function
+    | Vernac_file (f,m) -> 
+	set_module m;
+	let hf = target_full_name m in
+	  open_out_file hf;
+	  if (!header_trailer) then header (); 
+	  if !toc then make_toc ();
+	  coq_file f m; 
+	  if (!header_trailer) then trailer ();
+	  close_out_file()
+    | Latex_file _ -> ()
+  in
+    List.iter file l;
+    if (!index && !target_language=HTML) then begin
+      if (!multi_index) then make_multi_index (); 
+      open_out_file "index.html"; 
+      page_title := (if !title <> "" then !title else "Index");
+      if (!header_trailer) then header (); 
+      make_index (); 
+      if (!header_trailer) then trailer ();
+      close_out_file()
+    end;
+    if (!toc && !target_language=HTML) then begin
+      open_out_file "toc.html"; 
+      page_title := (if !title <> "" then !title else "Table of contents");
+      if (!header_trailer) then header ();
+      if !title <> "" then printf "<h1>%s</h1>\n" !title;
+      make_toc (); 
+      if (!header_trailer) then trailer ();
+      close_out_file()
+    end 
+      (* Rq: pour latex et texmacs, une toc ou un index séparé n'a pas de sens... *)
+
+
+let index_module = function
+  | Vernac_file (_,m) -> Index.add_module m
+  | Latex_file _ -> ()
+      
+let produce_document l =
+  List.iter index_module l;
+  (if !target_language=HTML then
+    let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.css") in
+    let dst = if !output_dir <> "" then Filename.concat !output_dir "coqdoc.css" else "coqdoc.css" in
+      copy src dst);
+  (if !target_language=LaTeX then
+    let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.sty") in
+    let dst = if !output_dir <> "" then 
+      Filename.concat !output_dir "coqdoc.sty" 
+    else "coqdoc.sty" in
+      copy src dst);
+  match !out_to with
+    | StdOut -> 
+	Cdglobals.out_channel := stdout;
+	gen_one_file l
+    | File f ->
+	open_out_file f;
+	gen_one_file l;
+	close_out_file()
+    | MultFiles ->
+	gen_mult_files l
+	  
 let produce_output fl =
   if not (!dvi || !ps) then begin
-    if !output_file <> "" then set_out_file !output_file;
     produce_document fl
   end else begin
     let texfile = temp_file "coqdoc" ".tex" in
     let basefile = chop_suffix texfile ".tex" in
-    set_out_file texfile;
-    produce_document fl;
-    let command = 
-      let file = basename texfile in
-      let file = 
-	if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file 
-      in
-      sprintf "(latex %s && latex %s) 1>&2 %s" file file
-	(if !quiet then "> /dev/null" else "")
-    in
-    let res = locally (dirname texfile) Sys.command command in
-    if res <> 0 then begin
-      eprintf "Couldn't run LaTeX successfully\n"; 
-      clean_and_exit basefile res
-    end;
-    let dvifile = basefile ^ ".dvi" in
-    if !dvi then begin
-      if !output_file <> "" then 
-	(* we cannot use Sys.rename accross file systems *)
-	copy dvifile !output_file 
-      else 
-	cat dvifile
-    end;
-    if !ps then begin
-      let psfile = 
-	if !output_file <> "" then !output_file else basefile ^ ".ps" 
-      in
+      open_out_file texfile;
+      produce_document fl;
       let command = 
-	sprintf "dvips %s -o %s %s" dvifile psfile 
-	  (if !quiet then "> /dev/null 2>&1" else "")
+	let file = basename texfile in
+	let file = 
+	  if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file 
+	in
+	  sprintf "(latex %s && latex %s) 1>&2 %s" file file
+	    (if !quiet then "> /dev/null" else "")
       in
-      let res = Sys.command command in
-      if res <> 0 then begin
-	eprintf "Couldn't run dvips successfully\n"; 
-	clean_and_exit basefile res
-      end;
-      if !output_file = "" then cat psfile
-    end;
-    clean_temp_files basefile
+      let res = locally (dirname texfile) Sys.command command in
+	if res <> 0 then begin
+	  eprintf "Couldn't run LaTeX successfully\n"; 
+	  clean_and_exit basefile res
+	end;
+	let dvifile = basefile ^ ".dvi" in
+	  if !dvi then begin
+	    if !output_file <> "" then 
+	      (* we cannot use Sys.rename accross file systems *)
+	      copy dvifile !output_file 
+	    else 
+	      cat dvifile
+	  end;
+	  if !ps then begin
+	    let psfile = 
+	      if !output_file <> "" then !output_file else basefile ^ ".ps" 
+	    in
+	    let command = 
+	      sprintf "dvips %s -o %s %s" dvifile psfile 
+		(if !quiet then "> /dev/null 2>&1" else "")
+	    in
+	    let res = Sys.command command in
+	      if res <> 0 then begin
+		eprintf "Couldn't run dvips successfully\n"; 
+		clean_and_exit basefile res
+	      end;
+	      if !output_file = "" then cat psfile
+	  end;
+	  clean_temp_files basefile
   end
 
 
@@ -414,7 +498,7 @@ let produce_output fl =
 
 let main () =
   let files = parse () in
-  if not !quiet then banner ();
-  if List.length files > 0 then produce_output files
-
+    if not !quiet then banner ();
+    if files <> [] then produce_output files
+      
 let _ = Printexc.catch main ()
diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml
index c10f3683..84e03d92 100644
--- a/tools/coqdoc/output.ml
+++ b/tools/coqdoc/output.ml
@@ -6,30 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: output.ml,v 1.7.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: output.ml 9245 2006-10-17 12:53:34Z notin $ i*)
 
+open Cdglobals
 open Index
 
-(*s Target language *)
-
-type target_language = LaTeX | HTML | TeXmacs
-
-let target_language = ref HTML
-
 (*s Low level output *)
 
-let out_channel = ref stdout
-let output_is_file = ref false
-let output_dir = ref ""
-
-let set_out_file f = 
-  let f = if !output_dir <> "" then Filename.concat !output_dir f else f in
-  out_channel := open_out f;
-  output_is_file := true
-
-let close () =
-  if !output_is_file then close_out !out_channel
-
 let output_char c = Pervasives.output_char !out_channel c
 
 let output_string s = Pervasives.output_string !out_channel s
@@ -38,43 +21,6 @@ let printf s = Printf.fprintf !out_channel s
 
 let sprintf = Printf.sprintf
 
-let dump_file f =
-  let ch = open_in f in
-  try
-    while true do
-      Pervasives.output_char !out_channel (input_char ch)
-    done
-  with End_of_file -> close_in ch
-
-(*s Options *)
-
-let header_trailer = ref true
-let quiet = ref false
-let light = ref false
-let short = ref false
-let index = ref true
-let multi_index = ref false
-let toc = ref false
-let page_title = ref ""
-let title = ref ""
-let externals = ref true
-let coqlib = ref "http://coq.inria.fr/library/"
-let raw_comments = ref false
-
-let charset = ref ""
-let inputenc = ref ""
-let latin1 = ref false
-let utf8 = ref false
-
-let set_latin1 () =
-  charset := "iso-8859-1";
-  inputenc := "latin1";
-  latin1 := true
-
-let set_utf8 () =
-  charset := "utf-8";
-  inputenc := "utf8";
-  utf8 := true
 
 (*s Coq keywords *)
 
@@ -85,9 +31,9 @@ let build_table l =
 
 let is_keyword = 
   build_table
-    [ "Add"; "AddPath"; "Axiom"; "Chapter"; "CoFixpoint";
+    [ "AddPath"; "Axiom"; "Chapter"; "CoFixpoint";
       "CoInductive"; "Defined"; "Definition"; 
-      "End"; "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Hint";
+      "End"; "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Goal"; "Hint";
       "Hypothesis"; "Hypotheses"; 
       "Immediate"; "Implicit"; "Import"; "Inductive"; 
       "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; 
@@ -145,6 +91,7 @@ let _ = List.iter
 	    "|-",  "\\ensuremath{\\vdash}";
 	    "forall", "\\ensuremath{\\forall}";
 	    "exists", "\\ensuremath{\\exists}";
+	    (* "fun", "\\ensuremath{\\lambda}" ? *)
 	  ]
 
 (*s Table of contents *)
@@ -171,7 +118,7 @@ module Latex = struct
 
   let header () =
     if !header_trailer then begin
-      printf "\\documentclass[12pt]{article}\n";
+      printf "\\documentclass[12pt]{report}\n";
       if !inputenc != "" then printf "\\usepackage[%s]{inputenc}\n" !inputenc;
       printf "\\usepackage[T1]{fontenc}\n";
       printf "\\usepackage{fullpage}\n";
@@ -308,6 +255,8 @@ module Latex = struct
 
   let end_inline_coq () = ()
 
+  let make_multi_index () = ()
+
   let make_index () = ()
 
   let make_toc () = printf "\\tableofcontents\n"
@@ -321,29 +270,31 @@ module Html = struct
 
   let header () =
     if !header_trailer then begin
+      printf "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n";
+      printf "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n";
       printf "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n<head>\n";
-      if !charset != "" then 
-	printf "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\">" !charset;
-      printf "<link rel=\"stylesheet\" href=\"style.css\" type=\"text/css\">";
+      printf "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\"/>\n" !charset;
+      printf "<link href=\"coqdoc.css\" rel=\"stylesheet\" type=\"text/css\"/>\n";
       printf "<title>%s</title>\n</head>\n\n" !page_title;
-      printf "<body>\n\n"
+      printf "<body>\n\n<div id=\"page\">\n\n<div id=\"header\">\n</div>\n\n";
+      printf "<div id=\"main\">\n\n"
     end
 
-  let self = "http://www.lri.fr/~filliatr/coqdoc/"
+  let self = "http://coq.inria.fr"
 
   let trailer () =
     if !index && !current_module <> "Index" then 
-      printf "<hr/><a href=\"index.html\">Index</a>";
+      printf "</div>\n\n<div id=\"footer\">\n<hr/><a href=\"index.html\">Index</a>";
     if !header_trailer then begin
       printf "<hr/><font size=\"-1\">This page has been generated by ";
       printf "<a href=\"%s\">coqdoc</a></font>\n" self;
-      printf "</body>\n</html>"
+      printf "</div>\n\n</div>\n\n</body>\n</html>"
     end
 
   let start_module () = 
     if not !short then begin
       (* add_toc_entry (Toc_library !current_module); *)
-      printf "<h1>Library %s</h1>\n\n" !current_module
+      printf "<h1 class=\"libtitle\">Library %s</h1>\n\n" !current_module
     end
 
   let indentation n = for i = 1 to n do printf "&nbsp;" done
@@ -373,7 +324,7 @@ module Html = struct
   let stop_verbatim () = printf "</pre>\n"
 
   let module_ref m s = 
-    printf "<a href=\"%s.html\">" m; raw_ident s; printf "</a>"
+    printf "<a class=\"modref\" href=\"%s.html\">" m; raw_ident s; printf "</a>"
     (*i
     match find_module m with
     | Local ->
@@ -385,33 +336,35 @@ module Html = struct
 	raw_ident s
     i*)
 
-  let ident_ref m s = match find_module m with
+  let ident_ref m fid s = match find_module m with
     | Local ->
-	printf "<a href=\"%s.html#%s\">" m s; raw_ident s; printf "</a>"
+	printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid; raw_ident s; printf "</a>"
     | Coqlib when !externals ->
 	let m = Filename.concat !coqlib m in
-	printf "<a href=\"%s.html#%s\">" m s; raw_ident s; printf "</a>"
+	printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid; raw_ident s; printf "</a>"
     | Coqlib | Unknown ->
 	raw_ident s
 
   let ident s loc = 
     if is_keyword s then begin
-      printf "<code class=\"keyword\">"; 
+      printf "<span class=\"keyword\">"; 
       raw_ident s; 
-      printf "</code>"
+      printf "</span>"
     end else 
-      try
-	(match Index.find !current_module loc with
-	   | Def _ -> 
-	       printf "<a name=\"%s\"></a>" s; raw_ident s
-           | Mod (m,s') when s = s' ->
-	       module_ref m s
-	   | Ref (m,s') when s = s' -> 
-	       ident_ref m s
-	   | Mod _ | Ref _ ->
-	       raw_ident s)
-      with Not_found ->
-	raw_ident s
+      begin
+	try
+	  (match Index.find !current_module loc with
+	     | Def (fullid,_) -> 
+		 printf "<a name=\"%s\"></a>" fullid; raw_ident s
+             | Mod (m,s') when s = s' ->
+		 module_ref m s
+	     | Ref (m,fullid) -> 
+		 ident_ref m fullid s
+	     | Mod _ | Ref _ ->
+		 raw_ident s)
+	with Not_found ->
+	  raw_ident s
+      end
 	  
   let with_html_printing f tok =
     try 
@@ -447,11 +400,11 @@ module Html = struct
 
   let start_doc () = 
     if not !raw_comments then
-      printf "\n<table width=\"100%%\"><tr class=\"doc\"><td>\n"
+      printf "\n<div class=\"doc\">\n"
 
   let end_doc () =
     stop_item (); 
-    if not !raw_comments then printf "\n</td></tr></table>\n"
+    if not !raw_comments then printf "\n</div>\n"
 
   let start_code () = end_doc (); start_coq ()
 
@@ -470,7 +423,7 @@ module Html = struct
     stop_item ();
     printf "<a name=\"%s\"></a><h%d>" lab lev;
     f ();
-    printf "</h%d>\n" lev
+    printf "</h%d class=\"section\">\n" lev
 
   let rule () = printf "<hr/>\n"
 
@@ -502,20 +455,8 @@ module Html = struct
 		
   let all_letters i = List.iter (letter_index false i.idx_name) i.idx_entries
 
-  let separate_index navig i =
-    let idx = i.idx_name in
-    let one_letter ((c,l) as cl) =
-      set_out_file (sprintf "index_%s_%c.html" idx c);
-      header ();
-      navig ();
-      printf "<hr/>";
-      letter_index true idx cl;
-      if List.length l > 30 then begin printf "<hr/>"; navig () end;
-      trailer ();
-      close ()
-    in
-    List.iter one_letter i.idx_entries
-
+  (* Construction d'une liste des index (1 index global, puis 1
+     index par catégorie) *)
   let format_global_index =
     Index.map 
       (fun s (m,t) -> 
@@ -523,7 +464,7 @@ module Html = struct
 	   "[library]", m ^ ".html"
 	 else
 	   sprintf "[%s, in <a href=\"%s.html\">%s</a>]" (entry_type t) m m ,
-	   sprintf "%s.html#%s" m s)
+	 sprintf "%s.html#%s" m s)
 
   let format_bytype_index = function
     | Library, idx ->
@@ -532,9 +473,10 @@ module Html = struct
 	Index.map 
 	  (fun s m -> 
 	     let text = sprintf "[in <a href=\"%s.html\">%s</a>]" m m in
-	     (text, sprintf "%s.html#%s" m s)) idx
+	       (text, sprintf "%s.html#%s" m s)) idx
 
-  let navig_one_index i =
+  (* Impression de la table d'index *)
+  let print_index_table_item i =
     printf "<tr>\n<td>%s Index</td>\n" (String.capitalize i.idx_name);
     List.iter 
       (fun (c,l) -> 
@@ -544,52 +486,58 @@ module Html = struct
 	   printf "<td>%c</td>\n" c)
       i.idx_entries;
     let n = i.idx_size in
-    printf "<td>(%d %s)</td>\n" n (if n > 1 then "entries" else "entry");
-    printf "</tr>\n"
+      printf "<td>(%d %s)</td>\n" n (if n > 1 then "entries" else "entry");
+      printf "</tr>\n"
 
-  let navig_index il = 
+  let print_index_table idxl = 
     printf "<table>\n";
-    List.iter navig_one_index il;
+    List.iter print_index_table_item idxl;
     printf "</table>\n"
-
+	
+  let make_one_multi_index prt_tbl i =
+    (* Attn: make_one_multi_index créé un nouveau fichier... *)
+    let idx = i.idx_name in
+    let one_letter ((c,l) as cl) =
+      open_out_file (sprintf "index_%s_%c.html" idx c);
+      if (!header_trailer) then header ();
+      prt_tbl (); printf "<hr/>";
+      letter_index true idx cl;
+      if List.length l > 30 then begin printf "<hr/>"; prt_tbl () end;
+      if (!header_trailer) then trailer ();
+      close_out_file ()
+    in
+      List.iter one_letter i.idx_entries
+
+  let make_multi_index () = 
+    let all_index = 
+      let glob,bt = Index.all_entries () in
+	(format_global_index glob) ::
+	  (List.map format_bytype_index bt) in
+    let print_table () = print_index_table all_index in
+      List.iter (make_one_multi_index print_table) all_index
+	
   let make_index () =
-    if !index then begin
-      let idxl = 
-	let glob,bt = Index.all_entries () in
-	format_global_index glob ::
-	List.map format_bytype_index bt 
-      in
-      let navig () = navig_index idxl in 
-      set_out_file "index.html";
+    let all_index = 
+      let glob,bt = Index.all_entries () in
+	(format_global_index glob) ::
+	  (List.map format_bytype_index bt) in
+    let print_table () = print_index_table all_index in
+    let print_one_index i =
+      if i.idx_size > 0 then begin
+	printf "<hr/>\n<h1>%s Index</h1>\n" (String.capitalize i.idx_name);
+	all_letters i
+      end
+    in
       current_module := "Index";
-      page_title := (if !title <> "" then !title else "Index");
-      header ();
       if !title <> "" then printf "<h1>%s</h1>\n" !title;
-      navig ();
-      if !multi_index then begin
-	trailer (); 
-	close ();
-	List.iter (separate_index navig) idxl;
-      end else begin
-	let one_index i =
-	  if i.idx_size > 0 then begin
-	    printf "<hr/>\n<h1>%s Index</h1>\n" (String.capitalize i.idx_name);
-	    all_letters i
-	  end
-	in
-	List.iter one_index idxl;
-	printf "<hr/>";
-	navig ();
-	trailer ();
-	close ()
-      end;
-    end
-
+      print_table ();
+      if not (!multi_index) then 
+	begin
+	  List.iter print_one_index all_index;
+	  printf "<hr/>"; print_table ()
+	end
+	    
   let make_toc () = 
-    set_out_file "toc.html";
-    page_title := (if !title <> "" then !title else "Table of contents");
-    header ();
-    if !title <> "" then printf "<h1>%s</h1>\n" !title;
     let make_toc_entry = function
       | Toc_library m -> 
 	  stop_item ();
@@ -600,9 +548,6 @@ module Html = struct
     in
     Queue.iter make_toc_entry toc_q;
     stop_item ();
-    if !index then printf "<a href=\"index.html\"><h2>Index</h2></a>";
-    trailer ();
-    close ()
 
 end
 
@@ -740,6 +685,8 @@ module TeXmacs = struct
 
   let end_inline_coq () = printf "]>"
 
+  let make_multi_index () = ()
+
   let make_index () = ()
 
   let make_toc () = ()
@@ -808,5 +755,6 @@ let verbatim_char =
   select output_char Html.char TeXmacs.char
 let hard_verbatim_char = output_char
 
+let make_multi_index = select Latex.make_multi_index Html.make_multi_index TeXmacs.make_multi_index
 let make_index = select Latex.make_index Html.make_index TeXmacs.make_index
 let make_toc = select Latex.make_toc Html.make_toc TeXmacs.make_toc
diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli
index 2195fa53..87b311f3 100644
--- a/tools/coqdoc/output.mli
+++ b/tools/coqdoc/output.mli
@@ -6,35 +6,11 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: output.mli,v 1.3.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: output.mli 8669 2006-03-28 17:34:15Z notin $ i*)
 
+open Cdglobals
 open Index
 
-type target_language = LaTeX | HTML | TeXmacs
-
-val target_language : target_language ref
-
-val set_out_file : string -> unit
-val output_dir : string ref
-val close : unit -> unit
-
-val quiet : bool ref
-val short : bool ref
-val light : bool ref
-val header_trailer : bool ref
-val index : bool ref
-val multi_index : bool ref
-val toc : bool ref
-val title : string ref
-val externals : bool ref
-val coqlib : string ref
-val raw_comments : bool ref
-
-val charset : string ref
-val inputenc : string ref
-val set_latin1 : unit -> unit
-val set_utf8 : unit -> unit
-
 val add_printing_token : string -> string option * string option -> unit
 val remove_printing_token : string -> unit
 
@@ -45,8 +21,6 @@ val trailer : unit -> unit
 
 val push_in_preamble : string -> unit
 
-val dump_file : string -> unit
-
 val start_module : unit -> unit
 
 val start_doc : unit -> unit
@@ -88,5 +62,6 @@ val stop_latex_math : unit -> unit
 val start_verbatim : unit -> unit
 val stop_verbatim : unit -> unit
 
+val make_multi_index : unit -> unit
 val make_index : unit -> unit
 val make_toc : unit -> unit
diff --git a/tools/coqdoc/pretty.mli b/tools/coqdoc/pretty.mli
index 07808fe9..dda0439e 100644
--- a/tools/coqdoc/pretty.mli
+++ b/tools/coqdoc/pretty.mli
@@ -6,14 +6,8 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretty.mli,v 1.1.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: pretty.mli 8617 2006-03-08 10:47:12Z notin $ i*)
 
 open Index
 
-type file =
-  | Vernac_file of string * coq_module
-  | Latex_file of string
-
-val gallina : bool ref
-
-val produce_document : file list -> unit
+val coq_file : string -> Cdglobals.coq_module -> unit
diff --git a/tools/coqdoc/pretty.mll b/tools/coqdoc/pretty.mll
index 541939b5..bdb58f86 100644
--- a/tools/coqdoc/pretty.mll
+++ b/tools/coqdoc/pretty.mll
@@ -6,12 +6,13 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: pretty.mll,v 1.7.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: pretty.mll 9204 2006-10-04 13:05:58Z notin $ i*)
 
 (*s Utility functions for the scanners *)
 
 {
 
+  open Cdglobals
   open Printf
   open Index
   open Lexing 
@@ -56,39 +57,8 @@
 
   let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos
 
-  (* Gallina (skipping proofs). This is a three states automaton. *)   
-
-  let gallina = ref false
-
-  type gallina_state = Nothing | AfterDot | Proof
-
-  let gstate = ref AfterDot
-
-  let is_proof = 
-    let t = Hashtbl.create 13 in
-    List.iter (fun s -> Hashtbl.add t s true)
-      [ "Theorem"; "Lemma"; "Fact"; "Remark"; "Goal"; "Let";
-	"Correctness"; "Definition"; "Morphism" ];
-    fun s -> try Hashtbl.find t s with Not_found -> false
-
-  let gallina_id id = 
-    if !gstate = AfterDot then
-      if is_proof id then gstate := Proof else 
-	if id <> "Add" then gstate := Nothing
-
-  let gallina_symbol s = 
-    if !gstate = AfterDot || (!gstate = Proof && s = ":=") then 
-      gstate := Nothing
-
   let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false
 
-  let gallina_char c = 
-    if c = '.' then
-      (let skip = !gstate = Proof in gstate := AfterDot; skip)
-    else
-      (if !gstate = AfterDot && not (is_space c) then gstate := Nothing;
-       false)
-
   (* saving/restoring the PP state *)
 
   type state = {
@@ -121,8 +91,7 @@
 
   let reset () =
     formatted := false;
-    brackets := 0;
-    gstate := AfterDot
+    brackets := 0
 
   (* erasing of Section/End *)
 
@@ -204,8 +173,11 @@ let firstchar =
   (* utf-8 letterlike symbols *) 
   '\226' ('\132' ['\128'-'\191'] | '\133' ['\128'-'\143'])
 let identchar = 
-  firstchar | ['\'' '0'-'9' '@']
-let identifier = firstchar identchar*
+  firstchar | ['\'' '0'-'9' '@' ]
+let id = firstchar identchar*
+let pfx_id = (id '.')*
+let identifier = 
+  id | pfx_id id
 
 let symbolchar_no_brackets =
   ['!' '$' '%' '&' '*' '+' ',' '@' '^' '#'
@@ -216,6 +188,100 @@ let symbolchar_no_brackets =
 let symbolchar = symbolchar_no_brackets | '[' | ']'
 let token = symbolchar+ | '[' [^ '[' ']' ':']* ']'
 
+
+let thm_token = 
+  "Theorem" 
+  | "Lemma" 
+  | "Fact" 
+  | "Remark" 
+  | "Corollary" 
+  | "Proposition" 
+  | "Property"
+  | "Goal"
+
+let def_token = 
+  "Definition" 
+  | "Let" 
+  | "SubClass" 
+  | "Example"
+  | "Local" 
+  | "Fixpoint" 
+  | "CoFixpoint" 
+  | "Record" 
+  | "Structure" 
+  | "Scheme"
+  | "Inductive"
+  | "CoInductive"
+
+let decl_token = 
+  "Hypothesis" 
+  | "Hypotheses" 
+  | "Parameter" 
+  | "Axiom" 's'? 
+  | "Conjecture"
+
+let gallina_ext =
+  "Module" 
+  | "Declare"
+  | "Transparent"
+  | "Opaque"
+  | "Canonical"
+  | "Coercion"
+  | "Identity"
+  | "Implicit"
+  | "Notation"
+  | "Infix"
+  | "Tactic" space+ "Notation"
+  | "Reserved" space+ "Notation"
+
+let commands = 
+  "Pwd"
+  | "Cd"
+  | "Drop"
+  | "ProtectedLoop"
+  | "Quit"
+  | "Load"
+  | "Add"
+  | "Remove" space+ "Loadpath"
+  | "Print"
+  | "Inspect"
+  | "About"
+  | "Search"
+  | "Eval"
+  | "Reset"
+  | "Check"
+  | "Type"
+
+let extraction = 
+  "Extraction"
+  | "Recursive" space+ "Extraction" 
+  | "Extract"
+
+let gallina_kw = thm_token | def_token | decl_token | gallina_ext | commands | extraction
+
+let gallina_kw_to_hide =
+  "Implicit"
+  | "Ltac"
+  | "Require"
+  | "Import"
+  | "Export"
+  | "Load" 
+  | "Hint"
+  | "Open"
+  | "Close"
+  | "Delimit"
+  | "Transparent"
+  | "Opaque"
+  | ("Declare" space+ ("Morphism" | "Step") )
+  | "Section"
+  | "Chapter"
+  | "Variable" 's'?
+  | ("Hypothesis" | "Hypotheses")
+  | "End"
+  | ("Set" | "Unset") space+ "Printing" space+ "Coercions"
+  | "Declare" space+ ("Left" | "Right") space+ "Step" 
+
+
 (* tokens with balanced brackets *)
 let token_brackets =
   ( symbolchar_no_brackets+ ('[' symbolchar_no_brackets* ']')* 
@@ -235,32 +301,18 @@ let begin_verb = "(*" space* "begin" space+ "verb" space* "*)"
 let end_verb = "(*" space* "end" space+ "verb" space* "*)"
 *)
 
-let coq_command_to_hide =
-  "Implicit" space |
-  "Ltac" space | 
-  "Require" space | 
-  "Load" space |
-  "Hint" space |
-  "Transparent" space |
-  "Opaque" space |
-  ("Declare" space+ ("Morphism" | "Step") space) |
-  "Section" space | 
-  "Variable" 's'? space | 
-  ("Hypothesis" | "Hypotheses") space | 
-  "End" space |
-  ("Set" | "Unset") space+ "Printing" space+ "Coercions" space |
-  "Declare" space+ ("Left" | "Right") space+ "Step" space
+
 
 (*s Scanning Coq, at beginning of line *)
 
 rule coq_bol = parse
-  | '\n'+
+  | space* '\n'+
       { empty_line_of_code (); coq_bol lexbuf }
   | space* "(**" space_nl
       { end_coq (); start_doc (); 
 	let eol = doc_bol lexbuf in
-	end_doc (); start_coq (); 
-	if eol then coq_bol lexbuf else coq lexbuf }
+	  end_doc (); start_coq (); 
+	  if eol then coq_bol lexbuf else coq lexbuf }
   | space* "Comments" space_nl
       { end_coq (); start_doc (); comments lexbuf; end_doc (); 
 	start_coq (); coq lexbuf }
@@ -270,28 +322,40 @@ rule coq_bol = parse
       { begin_show (); coq_bol lexbuf }
   | space* end_show
       { end_show (); coq_bol lexbuf }
-  | space* coq_command_to_hide
+  | space* gallina_kw_to_hide
       { let s = lexeme lexbuf in
-	if !light && section_or_end s then begin 
-	  skip_to_dot lexbuf; 
-	  coq_bol lexbuf 
-	end else begin
-	  indentation (count_spaces s); 
-	  backtrack lexbuf; 
-	  coq lexbuf 
-	end }
+	  if !light && section_or_end s then begin 
+	    skip_to_dot lexbuf; 
+	    coq_bol lexbuf 
+	  end else begin
+	    let s = lexeme lexbuf in 
+	    let nbsp = count_spaces s in
+	      indentation nbsp; 
+	      let s = String.sub s nbsp (String.length s - nbsp) in
+		ident s (lexeme_start lexbuf + nbsp); 
+		let eol= body lexbuf in 
+		  if eol then coq_bol lexbuf else coq lexbuf
+	  end }
+  | space* gallina_kw
+      { let s = lexeme lexbuf in 
+	let nbsp = count_spaces s in
+	  indentation nbsp;
+	  let s = String.sub s nbsp (String.length s - nbsp)  in
+	    ident s (lexeme_start lexbuf + nbsp); 
+	    let eol= body lexbuf in
+	      if eol then coq_bol lexbuf else coq lexbuf }
   | space* "(**" space+ "printing" space+ (identifier | token) space+
       { let tok = lexeme lexbuf in
 	let s = printing_token lexbuf in
-	add_printing_token tok s;
-	coq_bol lexbuf }
+	  add_printing_token tok s;
+	  coq_bol lexbuf }
   | space* "(**" space+ "printing" space+
       { eprintf "warning: bad 'printing' command at character %d\n" 
 	  (lexeme_start lexbuf); flush stderr;
 	ignore (comment lexbuf);
 	coq_bol lexbuf }
   | space* "(**" space+ "remove" space+ "printing" space+ 
-    (identifier | token) space* "*)"
+      (identifier | token) space* "*)"
       { remove_printing_token (lexeme lexbuf);
 	coq_bol lexbuf }
   | space* "(**" space+ "remove" space+ "printing" space+
@@ -301,68 +365,80 @@ rule coq_bol = parse
 	coq_bol lexbuf }
   | space* "(*"
       { let eol = comment lexbuf in
-	if eol then coq_bol lexbuf else coq lexbuf }
-  | space+
-      { indentation (count_spaces (lexeme lexbuf)); coq lexbuf }
+	  if eol then coq_bol lexbuf else coq lexbuf }
   | eof 
       { () }
-  | _ 
-      { backtrack lexbuf; indentation 0; coq lexbuf }
+  | _
+      { let eol = 
+	  if not !gallina then 
+	    begin backtrack lexbuf; indentation 0; body_bol lexbuf end 
+	  else 
+	    skip_to_dot lexbuf 
+	in
+	  if eol then coq_bol lexbuf else coq lexbuf }
 
 (*s Scanning Coq elsewhere *)
 
 and coq = parse
   | "\n" 
-      { line_break (); coq_bol lexbuf }
+      { line_break(); coq_bol lexbuf }
   | "(**" space_nl
       { end_coq (); start_doc (); 
 	let eol = doc_bol lexbuf in
-	end_doc (); start_coq (); 
-	if eol then coq_bol lexbuf else coq lexbuf }
+	  end_doc (); start_coq (); 
+	  if eol then coq_bol lexbuf else coq lexbuf }
   | "(*"
       { let eol = comment lexbuf in
-	if eol then coq_bol lexbuf else coq lexbuf }
+	  if eol then begin line_break(); coq_bol lexbuf end 
+          else coq lexbuf
+      }
   | '\n'+ space* "]]"
       { if not !formatted then begin symbol (lexeme lexbuf); coq lexbuf end }
   | eof 
       { () }
-  | token
+  | gallina_kw_to_hide
       { let s = lexeme lexbuf in
-	if !gallina then gallina_symbol s;
-	symbol s;
-	coq lexbuf }
-  | "with" space+ "Module" | "Module" space+ "Type" | "Declare" space+ "Module"
-    (* hack to avoid making Type a keyword *)
-      { let s = lexeme lexbuf in
-	if !gallina then gallina_id s;
-        ident s (lexeme_start lexbuf); coq lexbuf }
-  | "(" space* identifier space* ":=" 
-      { let id = extract_ident (lexeme lexbuf) in
-	symbol "("; ident id (lexeme_start lexbuf); symbol ":="; coq lexbuf }
-  | (identifier '.')* identifier
-      { let id = lexeme lexbuf in
-	if !gallina then gallina_id id;
-	ident id (lexeme_start lexbuf); coq lexbuf }
-  | _ 
-      { let c = lexeme_char lexbuf 0 in 
-	char c;
-	if !gallina && gallina_char c then skip_proof lexbuf;
-	coq lexbuf }
-
+	  if !light && section_or_end s then 
+	    begin 
+	      let eol = skip_to_dot lexbuf in
+		if eol then coq_bol lexbuf else coq lexbuf 
+	    end 
+	  else 
+	    begin
+	      ident s (lexeme_start lexbuf); 
+	      let eol=body lexbuf in 
+		if eol then coq_bol lexbuf else coq lexbuf
+	    end }
+  | gallina_kw
+      { let s = lexeme lexbuf in 
+	  ident s (lexeme_start lexbuf); 
+	let eol = body lexbuf in
+	  if eol then coq_bol lexbuf else coq lexbuf }
+  | space+ { char ' '; coq lexbuf }
+  | eof 
+      { () }
+  | _ { let eol = 
+	  if not !gallina then 
+	    begin backtrack lexbuf; indentation 0; body lexbuf end 
+	  else 
+	    skip_to_dot lexbuf 
+	in 
+	  if eol then coq_bol lexbuf else coq lexbuf}
+      
 (*s Scanning documentation, at beginning of line *)
-
+      
 and doc_bol = parse
   | space* "\n" '\n'*
       { paragraph (); doc_bol lexbuf }
   | space* section [^')'] ([^'\n' '*'] | '*' [^'\n'')'])*
-      { let lev, s = sec_title (lexeme lexbuf) in 
-	section lev (fun () -> ignore (doc (from_string s))); 
-	doc lexbuf }
-  | space* '-'+
-      { let n = count_dashes (lexeme lexbuf) in
-	if n >= 4 then rule () else item n;
-	doc lexbuf }
-  | "<<" space*
+{ let lev, s = sec_title (lexeme lexbuf) in 
+    section lev (fun () -> ignore (doc (from_string s))); 
+    doc lexbuf }
+| space* '-'+
+     { let n = count_dashes (lexeme lexbuf) in
+	 if n >= 4 then rule () else item n;
+	 doc lexbuf }
+| "<<" space*
       { start_verbatim (); verbatim lexbuf; doc_bol lexbuf }
   | eof 
       { false }
@@ -481,22 +557,33 @@ and comment = parse
   | eof  { false }
   | _    { comment lexbuf }
 
-(*s Skip proofs *)
-
-and skip_proof = parse
-  | "(*" { ignore (comment lexbuf); skip_proof lexbuf }
-  | "Save" | "Qed" | "Defined"
-  | "Abort" | "Proof" | "Admitted" { skip_to_dot lexbuf }
-  | "Proof" space* '.' { skip_proof lexbuf }
-  | identifier { skip_proof lexbuf } (* to avoid keywords within idents *)
-  | eof { () }
-  | _ { skip_proof lexbuf }
-
 and skip_to_dot = parse
-  | eof | '.' { if !gallina then gstate := AfterDot }
+  | '.' space* '\n' { true }
+  | eof | '.' space+ { false}
   | "(*" { ignore (comment lexbuf); skip_to_dot lexbuf }
   | _ { skip_to_dot lexbuf }
 
+and body_bol = parse
+  | space+
+      { indentation (count_spaces (lexeme lexbuf)); body lexbuf }
+  | _ { backtrack lexbuf; body lexbuf }
+
+and body = parse
+  | '\n' {line_break(); body_bol lexbuf}
+  | eof { false }
+  | '.' space* '\n' | '.' space* eof { char '.'; line_break(); true }      
+  | '.' space+ { char '.'; char ' '; false }
+  | "(*" { let eol = comment lexbuf in 
+	     if eol then body_bol lexbuf else body lexbuf }
+  | identifier 
+      { let s = lexeme lexbuf in 
+	  ident s (lexeme_start lexbuf); body lexbuf }
+  | token
+      { let s = lexeme lexbuf in
+	  symbol s; body lexbuf }
+  | _ { let c = lexeme_char lexbuf 0 in 
+	  char c; body lexbuf }
+
 and skip_hide = parse
   | eof | end_hide { () }
   | _ { skip_hide lexbuf }
@@ -515,10 +602,6 @@ and printing_token = parse
 
 {
 
-  type file =
-    | Vernac_file of string * coq_module
-    | Latex_file of string
-
   let coq_file f m =
     reset ();
     Index.scan_file f m;
@@ -528,59 +611,5 @@ and printing_token = parse
     start_coq (); coq_bol lb; end_coq ();
     close_in c
 
-  (* LaTeX document *)
-
-  let latex_document l = 
-    let file = function
-      | Vernac_file (f,m) -> set_module m; coq_file f m
-      | Latex_file f -> dump_file f
-    in
-    header ();
-    if !toc then make_toc ();
-    List.iter file l;
-    trailer ();
-    close ()
-
-  (* HTML document *)      
-
-  let html_document l =
-    let file = function
-      | Vernac_file (f,m) -> 
-	  set_module m;
-	  let hf = m ^ ".html" in
-	  set_out_file hf;
-	  header ();
-	  coq_file f m;
-	  trailer ();
-	  close ()
-      | Latex_file _ -> ()
-    in
-    List.iter file l;
-    make_index ();
-    if !toc then make_toc ()
-
-  (* TeXmacs document *)
-
-  let texmacs_document l = 
-    let file = function
-      | Vernac_file (f,m) -> set_module m; coq_file f m
-      | Latex_file f -> dump_file f
-    in
-    header ();
-    List.iter file l;
-    trailer ();
-    close ()
-
-  let index_module = function
-    | Vernac_file (_,m) -> Index.add_module m
-    | Latex_file _ -> ()
-
-  let produce_document l =
-    List.iter index_module l;
-    (match !target_language with
-       | LaTeX -> latex_document 
-       | HTML -> html_document
-       | TeXmacs -> texmacs_document) l
-
 }
 
diff --git a/tools/coqwc.mll b/tools/coqwc.mll
index 08bf2bcc..26b64095 100644
--- a/tools/coqwc.mll
+++ b/tools/coqwc.mll
@@ -9,7 +9,7 @@
 (* coqwc - counts the lines of spec, proof and comments in Coq sources
  * Copyright (C) 2003 Jean-Christophe Filliâtre *)
 
-(*i $Id: coqwc.mll,v 1.2.2.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+(*i $Id: coqwc.mll 7095 2005-05-31 15:05:23Z filliatr $ i*)
 
 (*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. 
     It assumes the files to be lexically well-formed. *)
@@ -99,7 +99,7 @@ let dot = '.' (' ' | '\t' | '\n' | '\r' | eof)
 let proof_start =   
   "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness"
 let proof_end =
-  ("Save" | "Qed" | "Defined" | "Abort") [^'.']* '.'
+  ("Save" | "Qed" | "Defined" | "Abort" | "Admitted") [^'.']* '.'
 
 (*s [spec] scans the specification. *)
 
diff --git a/tools/gallina.ml b/tools/gallina.ml
index c997820c..a2c05c6d 100644
--- a/tools/gallina.ml
+++ b/tools/gallina.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gallina.ml,v 1.2.16.1 2004/07/16 19:31:46 herbelin Exp $ *)
+(* $Id: gallina.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Gallina_lexer
 
diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll
index ce9fb950..0b769dbd 100644
--- a/tools/gallina_lexer.mll
+++ b/tools/gallina_lexer.mll
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: gallina_lexer.mll,v 1.5.6.1 2004/07/16 19:31:46 herbelin Exp $ *)
+(* $Id: gallina_lexer.mll 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 {
  open Lexing
diff --git a/tools/restore-v7 b/tools/restore-v7
deleted file mode 100755
index ab884587..00000000
--- a/tools/restore-v7
+++ /dev/null
@@ -1,9 +0,0 @@
-#!/bin/sh
-
-echo Restoring v7 files from directory v7
-v7files=`find v7 -name \*.v`
-for i in $v7files; do
-  j=`echo $i | sed -e "s@^v7/@@"`
-  echo Restoring $i from v7
-  cp -f $i $j
-done
diff --git a/tools/translate-v8 b/tools/translate-v8
deleted file mode 100755
index 7d71bea9..00000000
--- a/tools/translate-v8
+++ /dev/null
@@ -1,41 +0,0 @@
-#!/bin/sh
-
-if [ -e v7 ]; then
-  echo "Warning: v7 directory found, the files are maybe already translated";
-  sleep 5;
-fi
-echo --------- Producing v8 files in the translation directory -------------
-if [ -e v8 ]; then rm -r v8; fi
-if [ -e /tmp/v7.$$ ]; then rm -r /tmp/v7.$$; fi
-cp -pr . /tmp/v7.$$
-cp -pr /tmp/v7.$$ v8
-cd v8
-rm description toto
-make clean
-make COQFLAGS='-translate -q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)' || \
- { echo ---- Failed to translate; exit 1; }
-echo --------- Upgrading files in the translation directory ----------------
-v8files=`find . -name \*.v8`
-for i in $v8files; do
-  j=`dirname $i`/`basename $i .v8`.v
-  echo Upgrading $j in the translation directory
-  mv -u -f $i $j
-done
-echo --------- Recompiling v8 files in the translation directory -----------
-make clean
-make || { echo ---- Failed to recompile; exit 1; }
-echo --------- Saving v7 files in directory v7 -----------------------------
-/bin/rm -r ../v7
-mv /tmp/v7.$$ ../v7
-echo Saving v7 files done
-echo --------- Upgrading files in current directory ------------------------
-vfiles=`find . -name \*.v`
-cd ..
-for i in $vfiles; do
-  echo Upgrading $i in current directory
-  mv -u -f v8/$i $i
-done
-echo --------- Translation completed ---------------------------------------
-echo Old files are in directory '"v7"'
-echo New files are in current directory
-echo You can now remove the translation directory '"v8"'
diff --git a/tools/translate_V6-3-1_to_V7-0 b/tools/translate_V6-3-1_to_V7-0
deleted file mode 100755
index 10e7f140..00000000
--- a/tools/translate_V6-3-1_to_V7-0
+++ /dev/null
@@ -1,27 +0,0 @@
-#! /bin/sh
-
-echo "This shell script performs the following transformations:"
-echo "- Insertion of a space after a dot not followed by a separator"
-echo "- Insertion of a space between consecutive ~ and < and between"
-echo "  consecutive | and < assumed to be part of distinct tokens"
-echo "- Various renamings of commands as described in document Changes.ps"
-
-for i in $*
-  do sed -e "s/\.\([A-Z]\)/\. \1/g" -e "s/AddPath/Add LoadPath/g" \
-    -e "s/~</~ </g" -e "s/|</| </g" \
-    -e "s/AddPath/Add LoadPath/g" -e "s/DelPath/Remove LoadPath/g" \
-    -e "s/AddRecPath/Add Rec LoadPath/g" \
-    -e "s/Implicit  *Arguments  *On/Set Implicit Arguments/g" \
-    -e "s/Implicit *Arguments *Off/Unset Implicit Arguments/g" \
-    -e "s/Begin *Silent/Set Silent/g" -e "s/End *Silent/Unset Silent/g" \
-    -e "s/Print *Path/Print Coercion Paths/g" \
-    $i > $i.tmp$$
-  if diff $i.tmp$$ $i > /dev/null
-    then
-      rm $i.tmp$$
-    else
-      echo Le fichier $i a été modifié
-      mv $i.tmp$$ $i
-  fi
-  done
-echo
diff --git a/tools/upgrade-v8 b/tools/upgrade-v8
deleted file mode 100755
index 36d0bf8c..00000000
--- a/tools/upgrade-v8
+++ /dev/null
@@ -1,22 +0,0 @@
-#!/bin/sh
-
-mv v7 v7.bak
-
-echo ---------------- Saving v7 files into directory v7 ------------------
-vfiles=`find . -name \*.v`
-for i in $vfiles; do
-  if expr $i : 'v7\.bak/.*\.v' > /dev/null ; then continue ; fi
-  if expr $i : 'v7/.*\.v' > /dev/null ; then continue ; fi
-  echo Saving $i into v7/$i
-  j=v7/$i
-  mkdir -p `dirname $j`
-  mv -u -f $i $j
-done
-
-echo ---------------- Upgrading files with v8 syntax ---------------------
-v8files=`find . -name \*.v8`
-for i in $v8files; do
-  j=`dirname $i`/`basename $i .v8`.v
-  echo Upgrading $i
-  mv -u -f $i $j
-done
diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml
index 21098a57..f6c5c3af 100644
--- a/toplevel/cerrors.ml
+++ b/toplevel/cerrors.ml
@@ -6,14 +6,14 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cerrors.ml,v 1.12.2.2 2004/07/16 20:48:17 herbelin Exp $ *)
+(* $Id: cerrors.ml 9306 2006-10-28 18:28:19Z herbelin $ *)
 
 open Pp
 open Util
-open Ast
 open Indtypes
 open Type_errors
 open Pretype_errors
+open Indrec
 open Lexer
 
 let print_loc loc =
@@ -28,57 +28,61 @@ let guill s = "\""^s^"\""
 let where s =
   if !Options.debug then  (str"in " ++ str s ++ str":" ++ spc ()) else (mt ())
 
+let anomaly_string () = str "Anomaly: "
+
 let report () = (str "." ++ spc () ++ str "Please report.")
 
 (* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *)
 
-let rec explain_exn_default = function
+let rec explain_exn_default_aux anomaly_string report_fn = function
   | Stream.Failure -> 
-      hov 0 (str "Anomaly: uncaught Stream.Failure.")
+      hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.")
   | Stream.Error txt -> 
       hov 0 (str "Syntax error: " ++ str txt)
   | Token.Error txt -> 
       hov 0 (str "Syntax error: " ++ str txt)
   | Sys_error msg -> 
-      hov 0 (str "Anomaly: uncaught exception Sys_error " ++ str (guill msg) ++ report ())
+      hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report_fn ())
   | UserError(s,pps) -> 
       hov 1 (str "User error: " ++ where s ++ pps)
   | Out_of_memory -> 
       hov 0 (str "Out of memory")
   | Stack_overflow -> 
       hov 0 (str "Stack overflow")
-  | Ast.No_match s -> 
-      hov 0 (str "Anomaly: Ast matching error: " ++ str s ++ report ())
   | Anomaly (s,pps) -> 
-      hov 1 (str "Anomaly: " ++ where s ++ pps ++ report ())
+      hov 1 (anomaly_string () ++ where s ++ pps ++ report_fn ())
   | Match_failure(filename,pos1,pos2) ->
-      hov 1 (str "Anomaly: Match failure in file " ++ str (guill filename) ++ 
+      hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ 
       if Sys.ocaml_version = "3.06" then
 		   (str " from character " ++ int pos1 ++ 
                     str " to " ++ int pos2)
 		 else
 		   (str " at line " ++ int pos1 ++
 		    str " character " ++ int pos2)
-	           ++ report ())
+	           ++ report_fn ())
   | Not_found -> 
-      hov 0 (str "Anomaly: uncaught exception Not_found" ++ report ())
+      hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report_fn ())
   | Failure s -> 
-      hov 0 (str "Anomaly: uncaught exception Failure " ++ str (guill s) ++ report ())
+      hov 0 (anomaly_string () ++ str "uncaught exception Failure " ++ str (guill s) ++ report_fn ())
   | Invalid_argument s -> 
-      hov 0 (str "Anomaly: uncaught exception Invalid_argument " ++ str (guill s) ++ report ())
+      hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report_fn ())
   | Sys.Break -> 
-      hov 0 (fnl () ++ str "User Interrupt.")
+      hov 0 (fnl () ++ str "User interrupt.")
   | Univ.UniverseInconsistency -> 
-      hov 0 (str "Error: Universe Inconsistency.")
+      hov 0 (str "Error: Universe inconsistency.")
   | TypeError(ctx,te) -> 
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx te)
   | PretypeError(ctx,te) ->
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pretype_error ctx te)
   | InductiveError e -> 
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error e)
+  | RecursionSchemeError e -> 
+      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_recursion_scheme_error e)
   | Cases.PatternMatchingError (env,e) -> 
       hov 0
 	(str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e)
+  | Tacred.ReductionTacticError e -> 
+      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_reduction_tactic_error e)
   | Logic.RefinerError e -> 
       hov 0 (str "Error:" ++ spc () ++ Himsg.explain_refiner_error e)
   | Nametab.GlobalizationError q ->
@@ -90,13 +94,12 @@ let rec explain_exn_default = function
       hov 0 (str "Error:" ++ spc () ++
 	       str "No constant of this name:" ++ spc () ++ Libnames.pr_qualid q)
   | Refiner.FailError (i,s) ->
-      let s = if s="" then "" else " \""^s^"\"" in
-      hov 0 (str "Error: Tactic failure" ++ str s ++
+      hov 0 (str "Error: Tactic failure" ++ s ++
              if i=0 then mt () else str " (level " ++ int i ++ str").")
   | Stdpp.Exc_located (loc,exc) ->
       hov 0 ((if loc = dummy_loc then (mt ())
                else (str"At location " ++ print_loc loc ++ str":" ++ fnl ()))
-               ++ explain_exn_default exc)
+               ++ explain_exn_default_aux anomaly_string report_fn exc)
   | Lexer.Error Illegal_character -> 
       hov 0 (str "Syntax error: Illegal character.")
   | Lexer.Error Unterminated_comment -> 
@@ -108,7 +111,7 @@ let rec explain_exn_default = function
   | Lexer.Error (Bad_token s) -> 
       hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".")
   | Assert_failure (s,b,e) ->
-      hov 0 (str "Anomaly: assert failure" ++ spc () ++
+      hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++
 	       (if s <> "" then 
 		 if Sys.ocaml_version = "3.06" then
 		   (str ("(file \"" ^ s ^ "\", characters ") ++ 
@@ -119,16 +122,22 @@ let rec explain_exn_default = function
 		    int (e+6) ++ str ")")
 	       else
 		 (mt ())) ++
-	       report ())
+	       report_fn ())
   | reraise ->
-      hov 0 (str "Anomaly: Uncaught exception " ++ 
-	       str (Printexc.to_string reraise) ++ report ())
+      hov 0 (anomaly_string () ++ str "Uncaught exception " ++ 
+	       str (Printexc.to_string reraise) ++ report_fn ())
+
+let explain_exn_default =
+    explain_exn_default_aux (fun () -> str "Anomaly: ") report
 
 let raise_if_debug e =
   if !Options.debug then raise e
 
 let _ = Tactic_debug.explain_logic_error := explain_exn_default
 
+let _ = Tactic_debug.explain_logic_error_no_anomaly :=
+          explain_exn_default_aux (fun () -> mt()) (fun () -> mt())
+
 let explain_exn_function = ref explain_exn_default
 
 let explain_exn e = !explain_exn_function e
diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli
index 09d79cec..1236ecf5 100644
--- a/toplevel/cerrors.mli
+++ b/toplevel/cerrors.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cerrors.mli,v 1.2.6.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: cerrors.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Pp
diff --git a/toplevel/class.ml b/toplevel/class.ml
index f5493929..5f385934 100644
--- a/toplevel/class.ml
+++ b/toplevel/class.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: class.ml,v 1.44.2.3 2004/11/26 18:06:54 herbelin Exp $ *)
+(* $Id: class.ml 7941 2006-01-28 23:07:59Z herbelin $ *)
 
 open Util
 open Pp
@@ -92,42 +92,16 @@ let explain_coercion_error g = function
 
 (* Verifications pour l'ajout d'une classe *)
 
-let rec arity_sort (ctx,a) = match kind_of_term a with
-  | Sort (Prop _ | Type _) -> List.length ctx
-  | _ -> raise Not_found
-
 let check_reference_arity ref =
-  let t = Global.type_of_global ref in
-  try arity_sort (Reductionops.splay_prod (Global.env()) Evd.empty t)
-  with Not_found -> raise (CoercionError (NotAClass ref))
+  if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global ref)) then
+    raise (CoercionError (NotAClass ref))
 
 let check_arity = function
-  | CL_FUN | CL_SORT -> 0
+  | CL_FUN | CL_SORT -> ()
   | CL_CONST sp -> check_reference_arity (ConstRef sp)
   | CL_SECVAR sp -> check_reference_arity (VarRef sp)
   | CL_IND sp  -> check_reference_arity (IndRef sp)
 
-(* try_add_class : cl_typ -> strength option -> bool -> unit *)
-
-let strength_of_cl = function 
-  | CL_CONST kn -> constant_strength (sp_of_global (ConstRef kn))
-  | CL_SECVAR sp -> variable_strength sp
-  | _ -> Global
-
-let try_add_class cl streopt fail_if_exists =
-  if not (class_exists cl) then
-    let p = check_arity cl in
-    let stre' = strength_of_cl cl in 
-    let stre = match streopt with
-      | Some stre -> strength_min (stre,stre')
-      | None -> stre'
-    in
-    declare_class (cl,stre,p)
-  else
-    if fail_if_exists then errorlabstrm "try_add_new_class" 
-      (pr_class cl ++ str " is already a class")
-
-
 (* Coercions *)
 
 (* check that the computed target is the provided one *)
@@ -148,18 +122,18 @@ let uniform_cond nargs lt =
 let id_of_cl  = function
   | CL_FUN -> id_of_string "FUNCLASS"
   | CL_SORT -> id_of_string "SORTCLASS"
-  | CL_CONST kn -> id_of_label (label kn)
+  | CL_CONST kn -> id_of_label (con_label kn)
   | CL_IND ind ->
       let (_,mip) = Global.lookup_inductive ind in
       mip.mind_typename
   | CL_SECVAR id -> id
 
-let class_of_ref = function
+let class_of_global = function
   | ConstRef sp -> CL_CONST sp
   | IndRef sp -> CL_IND sp
   | VarRef id -> CL_SECVAR id
   | ConstructRef _ as c -> 
-      errorlabstrm "class_of_ref"
+      errorlabstrm "class_of_global"
 	(str "Constructors, such as " ++ Printer.pr_global c ++ 
 	   str " cannot be used as class")
 
@@ -204,14 +178,19 @@ let get_target t ind =
 let prods_of t = 
   let rec aux acc d = match kind_of_term d with
     | Prod (_,c1,c2) -> aux (c1::acc) c2
-    | Cast (c,_) -> aux acc c
+    | Cast (c,_,_) -> aux acc c
     | _ -> (d,acc)
   in 
   aux [] t
 
+let strength_of_cl = function 
+  | CL_CONST kn -> constant_strength (sp_of_global (ConstRef kn))
+  | CL_SECVAR sp -> variable_strength sp
+  | _ -> Global
+
 let get_strength stre ref cls clt =
-  let stres = (snd (class_info cls)).cl_strength in
-  let stret = (snd (class_info clt)).cl_strength in
+  let stres = strength_of_cl cls in
+  let stret = strength_of_cl clt in
   let stref = strength_of_global ref in
 (* 01/00: Supprimé la prise en compte de la force des variables locales. Sens ?
   let streunif = stre_unif_cond (s_vardep,f_vardep) in
@@ -265,10 +244,11 @@ let build_id_coercion idf_opt source =
   in
   let constr_entry = (* Cast is necessary to express [val_f] is identity *)
     DefinitionEntry
-      { const_entry_body = mkCast (val_f, typ_f);
+      { const_entry_body = mkCast (val_f, DEFAULTcast, typ_f);
 	const_entry_type = Some typ_f;
-        const_entry_opaque = false } in
-  let (_,kn) = declare_constant idf (constr_entry,Decl_kinds.IsDefinition) in
+        const_entry_opaque = false;
+	const_entry_boxed = Options.boxed_definitions()} in
+  let kn = declare_constant idf (constr_entry,IsDefinition IdentityCoercion) in
   ConstRef kn
 
 let check_source = function
@@ -288,11 +268,9 @@ lorque source est None alors target est None aussi.
 
 let add_new_coercion_core coef stre source target isid =
   check_source source;
-  let env = Global.env () in
-  let v = constr_of_reference coef in
-  let vj = Retyping.get_judgment_of env Evd.empty v in
+  let t = Global.type_of_global coef in
   if coercion_exists coef then raise (CoercionError AlreadyExists);
-  let tg,lp = prods_of (vj.uj_type) in
+  let tg,lp = prods_of t in
   let llp = List.length lp in
   if llp = 0 then raise (CoercionError NotAFunction);
   let (cls,lvs,ind) =
@@ -311,10 +289,10 @@ let add_new_coercion_core coef stre source target isid =
       raise (CoercionError NoTarget)
   in
   check_target clt target;
-  try_add_class cls None false;
-  try_add_class clt None false;
+  check_arity cls;
+  check_arity clt;
   let stre' = get_strength stre coef cls clt in
-  declare_coercion coef vj stre' isid cls clt (List.length lvs)
+  declare_coercion coef stre' isid cls clt (List.length lvs)
 
 let try_add_new_coercion_core ref b c d e =
   try add_new_coercion_core ref b c d e
@@ -345,114 +323,5 @@ let add_coercion_hook stre ref =
     ^ " is now a coercion")
 
 let add_subclass_hook stre ref =
-  let cl = class_of_ref ref in
+  let cl = class_of_global ref in
   try_add_new_coercion_subclass cl stre
-
-(* try_add_new_class : global_reference -> strength -> unit *)
-
-let class_of_global = function
-  | VarRef sp -> CL_SECVAR sp
-  | ConstRef sp -> CL_CONST sp
-  | IndRef sp -> CL_IND sp
-  | ConstructRef _ as ref -> raise (CoercionError (NotAClass ref))
-
-let try_add_new_class ref stre =
-  try try_add_class (class_of_global ref) (Some stre) true
-  with CoercionError e ->
-    errorlabstrm "try_add_new_class" (explain_coercion_error ref e)
-
-(* fonctions pour le discharge: encore un peu sale mais ça s'améliore *)
-
-type coercion_entry = 
-    global_reference * strength * bool * cl_typ * cl_typ * int
-
-let add_new_coercion (ref,stre,isid,cls,clt,n) =
-  (* Un peu lourd, tout cela pour trouver l'instance *)
-  let env = Global.env () in
-  let v = constr_of_reference ref in
-  let vj = Retyping.get_judgment_of env Evd.empty v in
-  declare_coercion ref vj stre isid cls clt n
-
-let count_extra_abstractions hyps ids_to_discard =
-  let _,n =
-    List.fold_left
-      (fun (hyps,n as sofar) id -> 
-	 match hyps with
-	   | (hyp,None,_)::rest when id = hyp ->(rest, n+1)
-	   | _ -> sofar)
-      (hyps,0) ids_to_discard
-  in n
-
-let defined_in_sec kn olddir = 
-  let _,dir,_ = repr_kn kn in
-    dir = olddir
-
-(* This moves the global path one step below *)
-let process_global olddir = function
-  | VarRef _ ->
-      anomaly "process_global only processes global surviving the section"
-  | ConstRef kn as x ->
-      if defined_in_sec kn olddir then
-        let newkn = Lib.make_kn (id_of_label (label kn)) in
-        ConstRef newkn
-      else x
-  | IndRef (kn,i) as x -> 
-      if defined_in_sec kn olddir then
-        let newkn = Lib.make_kn (id_of_label (label kn)) in
-        IndRef (newkn,i)
-      else x
-  | ConstructRef ((kn,i),j) as x -> 
-      if defined_in_sec kn olddir then
-        let newkn = Lib.make_kn (id_of_label (label kn)) in
-        ConstructRef ((newkn,i),j)
-      else x
-
-let process_class olddir ids_to_discard x =
-  let (cl,{cl_strength=stre; cl_param=p}) = x in
-(*  let env = Global.env () in*)
-  match cl with 
-    | CL_SECVAR _ -> x
-    | CL_CONST kn -> 
-       if defined_in_sec kn olddir then
-         let newkn = Lib.make_kn (id_of_label (label kn)) in
-	 let hyps = (Global.lookup_constant kn).const_hyps in
-	 let n = count_extra_abstractions hyps ids_to_discard in
-           (CL_CONST newkn,{cl_strength=stre;cl_param=p+n})
-       else 
-	 x
-    | CL_IND (kn,i) ->
-	if defined_in_sec kn olddir then
-          let newkn = Lib.make_kn (id_of_label (label kn)) in
-	  let hyps = (Global.lookup_mind kn).mind_hyps in
-	  let n = count_extra_abstractions hyps ids_to_discard in
-          (CL_IND (newkn,i),{cl_strength=stre;cl_param=p+n})
-        else 
-	  x
-    | _ -> anomaly "process_class" 
-
-let process_cl sec_sp cl =
-  match cl with
-    | CL_SECVAR id -> cl
-    | CL_CONST kn ->
-	if defined_in_sec kn sec_sp then
-          let newkn = Lib.make_kn (id_of_label (label kn)) in
-          CL_CONST newkn
-        else 
-	  cl
-    | CL_IND (kn,i) ->
-	if defined_in_sec kn sec_sp then
-          let newkn = Lib.make_kn (id_of_label (label kn)) in
-          CL_IND (newkn,i)
-        else 
-	  cl
-    | _ -> cl
-
-let process_coercion olddir ids_to_discard (coe,coeinfo,cls,clt) =
-  let hyps = context_of_global_reference coe in
-  let nargs = count_extra_abstractions hyps ids_to_discard in
-  (process_global olddir coe,
-   coercion_strength coeinfo,
-   coercion_identity coeinfo,
-   process_cl olddir cls,
-   process_cl olddir clt,
-   nargs + coercion_params coeinfo)
diff --git a/toplevel/class.mli b/toplevel/class.mli
index b0350985..7717d754 100644
--- a/toplevel/class.mli
+++ b/toplevel/class.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: class.mli,v 1.17.6.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: class.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -50,19 +50,4 @@ val add_coercion_hook : Tacexpr.declaration_hook
 
 val add_subclass_hook : Tacexpr.declaration_hook
 
-(* [try_add_new_class ref] declares [ref] as a new class; usually,
-   this is done implicitely by [try_add_new_coercion]'s functions *)
-val try_add_new_class : global_reference -> strength -> unit
-
-(*s This is used for the discharge *)
-type coercion_entry
-
-val add_new_coercion : coercion_entry -> unit
-
-val process_class :
-  dir_path -> identifier list -> 
-    (cl_typ * cl_info_typ) -> (cl_typ * cl_info_typ)
-val process_coercion :
-  dir_path -> identifier list -> coercion -> coercion_entry
-
-val class_of_ref : global_reference -> cl_typ
+val class_of_global : global_reference -> cl_typ
diff --git a/toplevel/command.ml b/toplevel/command.ml
index 10d6a620..9ef782ff 100644
--- a/toplevel/command.ml
+++ b/toplevel/command.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: command.ml,v 1.116.2.4 2005/11/29 21:40:53 letouzey Exp $ *)
+(* $Id: command.ml 9617 2007-02-07 18:59:26Z herbelin $ *)
 
 open Pp
 open Util
@@ -18,7 +18,7 @@ open Entries
 open Inductive
 open Environ
 open Reduction
-open Tacred
+open Redexpr
 open Declare
 open Nametab
 open Names
@@ -32,44 +32,57 @@ open Proof_type
 open Tacmach
 open Safe_typing
 open Nametab
+open Impargs
 open Typeops
+open Reductionops
 open Indtypes
 open Vernacexpr
 open Decl_kinds
 open Pretyping
-open Symbols
+open Evarutil
+open Evarconv
+open Notation
 
 let mkLambdaCit = List.fold_right (fun (x,a) b -> mkLambdaC(x,a,b))
 let mkProdCit = List.fold_right (fun (x,a) b -> mkProdC(x,a,b))
 
-let rec abstract_rawconstr c = function
+let rec abstract_constr_expr c = function
   | [] -> c
-  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_rawconstr c bl)
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl)
   | LocalRawAssum (idl,t)::bl ->
       List.fold_right (fun x b -> mkLambdaC([x],t,b)) idl
-        (abstract_rawconstr c bl)
+        (abstract_constr_expr c bl)
 
-let rec generalize_rawconstr c = function
+let rec generalize_constr_expr c = function
   | [] -> c
-  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,generalize_rawconstr c bl)
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,generalize_constr_expr c bl)
   | LocalRawAssum (idl,t)::bl ->
       List.fold_right (fun x b -> mkProdC([x],t,b)) idl
-        (generalize_rawconstr c bl)
+        (generalize_constr_expr c bl)
+
+let rec under_binders env f n c =
+  if n = 0 then f env Evd.empty c else
+    match kind_of_term c with
+      | Lambda (x,t,c) ->
+	  mkLambda (x,t,under_binders (push_rel (x,None,t) env) f (n-1) c)
+      | LetIn (x,b,t,c) ->
+	  mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) f (n-1) c)
+      | _ -> assert false
 
 let rec destSubCast c = match kind_of_term c with
   | Lambda (x,t,c) -> 
       let (b,u) = destSubCast c in mkLambda (x,t,b), mkProd (x,t,u)
   | LetIn (x,b,t,c) ->
       let (d,u) = destSubCast c in mkLetIn (x,b,t,d), mkLetIn (x,b,t,u)
-  | Cast (b,u) -> (b,u)
+  | Cast (b,_, u) -> (b,u)
   | _ -> assert false
 
-let rec adjust_conclusion a cs = function
-  | CProdN (loc,bl,c) -> CProdN (loc,bl,adjust_conclusion a cs c)
-  | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,adjust_conclusion a cs c)
+let rec complete_conclusion a cs = function
+  | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c)
+  | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c)
   | CHole loc ->
-      let (nar,name,params) = a in
-      if nar <> 0 then
+      let (has_no_args,name,params) = a in
+      if not has_no_args then
 	user_err_loc (loc,"",
 	  str "Cannot infer the non constant arguments of the conclusion of "
 	  ++ pr_id cs);
@@ -84,63 +97,51 @@ let rec adjust_conclusion a cs = function
 let definition_message id =
   if_verbose message ((string_of_id id) ^ " is defined")
 
-let constant_entry_of_com (bl,com,comtypopt,opacity) =
+let constant_entry_of_com (bl,com,comtypopt,opacity,boxed) =
   let sigma = Evd.empty in
   let env = Global.env() in
   match comtypopt with
       None -> 
-	let b = abstract_rawconstr com bl in
-	let j = judgment_of_rawconstr sigma env b in
+	let b = abstract_constr_expr com bl in
+	let j = interp_constr_judgment sigma env b in
 	{ const_entry_body = j.uj_val;
-	  const_entry_type = Some (Evarutil.refresh_universes j.uj_type);
-          const_entry_opaque = opacity }
+	  const_entry_type = None;
+          const_entry_opaque = opacity;
+	  const_entry_boxed = boxed }
     | Some comtyp ->
 	(* We use a cast to avoid troubles with evars in comtyp *)
 	(* that can only be resolved knowing com *)
-	let b = abstract_rawconstr (mkCastC (com,comtyp)) bl in
+	let b = abstract_constr_expr (mkCastC (com, Rawterm.CastConv DEFAULTcast,comtyp)) bl in
 	let (body,typ) = destSubCast (interp_constr sigma env b) in
 	{ const_entry_body = body;
 	  const_entry_type = Some typ;
-          const_entry_opaque = opacity }
-
-let rec length_of_raw_binders = function
-  | [] -> 0
-  | LocalRawDef _::bl -> 1 + length_of_raw_binders bl
-  | LocalRawAssum (idl,_)::bl -> List.length idl + length_of_raw_binders bl
-
-let rec under_binders env f n c =
-  if n = 0 then f env Evd.empty c else
-    match kind_of_term c with
-      | Lambda (x,t,c) ->
-        mkLambda (x,t,under_binders (push_rel (x,None,t) env) f (n-1) c)
-      | LetIn (x,b,t,c) ->
-        mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) f (n-1) c)
-      | _ -> assert false
+          const_entry_opaque = opacity;
+	  const_entry_boxed = boxed }
 
 let red_constant_entry bl ce = function
   | None -> ce
   | Some red ->
       let body = ce.const_entry_body in
       { ce with const_entry_body = 
-      under_binders (Global.env()) (reduction_of_redexp red)
-        (length_of_raw_binders bl)
-        body }
+	under_binders (Global.env()) (fst (reduction_of_red_expr red))
+	  (local_binders_length bl)
+	  body }
 
 let declare_global_definition ident ce local =
-  let (_,kn) = declare_constant ident (DefinitionEntry ce,IsDefinition) in
-  if local = Local then
+  let kn = declare_constant ident (DefinitionEntry ce,IsDefinition Definition) in
+  if local = Local && Options.is_verbose() then
     msg_warning (pr_id ident ++ str" is declared as a global definition");
   definition_message ident;
   ConstRef kn
 
-let declare_definition ident (local,_) bl red_option c typopt hook =
-  let ce = constant_entry_of_com (bl,c,typopt,false) in
+let declare_definition ident (local,boxed,dok) bl red_option c typopt hook =
+  let ce = constant_entry_of_com (bl,c,typopt,false,boxed) in
   let ce' = red_constant_entry bl ce red_option in
   let r = match local with
     | Local when Lib.sections_are_opened () ->
         let c =
           SectionLocalDef(ce'.const_entry_body,ce'.const_entry_type,false) in
-        let _ = declare_variable ident (Lib.cwd(), c, IsDefinition) in
+        let _ = declare_variable ident (Lib.cwd(),c,IsDefinition Definition) in
         definition_message ident;
         if Pfedit.refining () then 
           msgerrnl (str"Warning: Local definition " ++ pr_id ident ++ 
@@ -152,7 +153,6 @@ let declare_definition ident (local,_) bl red_option c typopt hook =
 
 let syntax_definition ident c local onlyparse =
   let c = snd (interp_aconstr [] [] c) in
-  let onlyparse = !Options.v7_only or onlyparse in
   Syntax_def.declare_syntactic_definition local ident onlyparse c
 
 (* 2| Variable/Hypothesis/Parameter/Axiom declarations *)
@@ -163,7 +163,7 @@ let assumption_message id =
 let declare_one_assumption is_coe (local,kind) c (_,ident) =
   let r = match local with
     | Local when Lib.sections_are_opened () ->
-        let r = 
+        let _ = 
           declare_variable ident 
             (Lib.cwd(), SectionLocalAssum c, IsAssumption kind) in
         assumption_message ident;
@@ -172,7 +172,7 @@ let declare_one_assumption is_coe (local,kind) c (_,ident) =
           str" is not visible from current goals");
         VarRef ident
     | (Global|Local) ->
-        let (_,kn) =
+        let kn =
           declare_constant ident (ParameterEntry c, IsAssumption kind) in
         assumption_message ident;
         if local=Local & Options.is_verbose () then
@@ -182,9 +182,13 @@ let declare_one_assumption is_coe (local,kind) c (_,ident) =
   if is_coe then Class.try_add_new_coercion r local
 
 let declare_assumption idl is_coe k bl c =
-  let c = generalize_rawconstr c bl in
-  let c = interp_type Evd.empty (Global.env()) c in
-  List.iter (declare_one_assumption is_coe k c) idl
+  if not (Pfedit.refining ()) then 
+    let c = generalize_constr_expr c bl in
+    let c = interp_type Evd.empty (Global.env()) c in
+      List.iter (declare_one_assumption is_coe k c) idl
+  else
+    errorlabstrm "Command.Assumption"
+	(str "Cannot declare an assumption while in proof editing mode.")
 
 (* 3a| Elimination schemes for mutual inductive definitions *)
 
@@ -203,27 +207,36 @@ let declare_one_elimination ind =
       (DefinitionEntry
         { const_entry_body = c;
           const_entry_type = t;
-          const_entry_opaque = false }, 
-       Decl_kinds.IsDefinition) in
+          const_entry_opaque = false;
+	  const_entry_boxed = Options.boxed_definitions() }, 
+       Decl_kinds.IsDefinition Definition) in
     definition_message id;
     kn
   in
   let env = Global.env () in
   let sigma = Evd.empty in
   let elim_scheme = Indrec.build_indrec env sigma ind in
-  let npars = mip.mind_nparams in
-  let make_elim s = Indrec.instanciate_indrec_scheme s npars elim_scheme in
-  let kelim = mip.mind_kelim in
-  (* in case the inductive has a type elimination, generates only one
-     induction scheme, the other ones share the same code with the
-     apropriate type *)
+  let npars = 
+    (* if a constructor of [ind] contains a recursive call, the scheme
+       is generalized only wrt recursively uniform parameters *)
+    if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs) 
+    then 
+      mib.mind_nparams_rec
+    else 
+      mib.mind_nparams in
+  let make_elim s = Indrec.instantiate_indrec_scheme s npars elim_scheme in
+  let kelim = elim_sorts (mib,mip) in
+    (* in case the inductive has a type elimination, generates only one
+       induction scheme, the other ones share the same code with the
+       apropriate type *)
   if List.mem InType kelim then
     let elim = make_elim (new_sort_in_family InType) in
     let cte = declare (mindstr^(Indrec.elimination_suffix InType)) elim None in
-    let c = mkConst (snd cte) and t = constant_type (Global.env()) (snd cte) in
+    let c = mkConst cte in
+    let t = type_of_constant (Global.env()) cte in
     List.iter (fun (sort,suff) -> 
       let (t',c') = 
-	Indrec.instanciate_type_indrec_scheme (new_sort_in_family sort)
+	Indrec.instantiate_type_indrec_scheme (new_sort_in_family sort)
 	  npars c t in
       let _ = declare (mindstr^suff) c' (Some t') in ())
       non_type_eliminations
@@ -242,364 +255,381 @@ let declare_eliminations sp =
       declare_one_elimination (sp,i)
     done
 
-(* 3b| Mutual Inductive definitions *)
-
-let minductive_message = function 
+(* 3b| Mutual inductive definitions *)
+
+let compute_interning_datas env l nal typl =
+  let mk_interning_data na typ =
+    let idl, impl =
+      if is_implicit_args() then
+	let impl = compute_implicits env typ in
+	let sub_impl,_ = list_chop (List.length l) impl in
+	let sub_impl' = List.filter is_status_implicit sub_impl in
+	(List.map name_of_implicit sub_impl', impl)
+      else 
+	([],[]) in
+    (na, (idl, impl, compute_arguments_scope typ)) in
+  (l, List.map2 mk_interning_data nal typl)
+
+let declare_interning_data (_,impls) (df,c,scope) =
+  silently (Metasyntax.add_notation_interpretation df impls c) scope
+
+let push_named_types env idl tl =
+  List.fold_left2 (fun env id t -> Environ.push_named (id,None,t) env)
+    env idl tl
+
+let push_types env idl tl =
+  List.fold_left2 (fun env id t -> Environ.push_rel (Name id,None,t) env)
+    env idl tl
+
+type inductive_expr = {
+  ind_name : identifier;
+  ind_arity : constr_expr;
+  ind_lc : (identifier * constr_expr) list
+}
+
+let minductive_message = function
   | []  -> error "no inductive definition"
   | [x] -> (pr_id x ++ str " is defined")
   | l   -> hov 0  (prlist_with_sep pr_coma pr_id l ++
 		     spc () ++ str "are defined")
 
-let recursive_message v =
-  match Array.length v with
-    | 0 -> error "no recursive definition"
-    | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined")
-    | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
-		    spc () ++ str "are recursively defined")
+let check_all_names_different indl =
+  let get_names ind = ind.ind_name::List.map fst ind.ind_lc in
+  if not (list_distinct (List.flatten (List.map get_names indl))) then
+    error "Two inductive objects have the same name"
+
+let mk_mltype_data isevars env assums arity indname =
+  let is_ml_type = is_sort env (Evd.evars_of !isevars) arity in
+  (is_ml_type,indname,assums)
+
+let prepare_param = function
+  | (na,None,t) -> out_name na, LocalAssum t 
+  | (na,Some b,_) -> out_name na, LocalDef b
+
+let interp_ind_arity isevars env ind =
+  interp_type_evars isevars env ind.ind_arity
+
+let interp_cstrs isevars env impls mldata arity ind =
+  let cnames,ctyps = List.split ind.ind_lc in
+  (* Complete conclusions of constructor types if given in ML-style syntax *)
+  let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in
+  (* Interpret the constructor types *)
+  let ctyps'' = List.map (interp_type_evars isevars env ~impls) ctyps' in
+  (cnames, ctyps'')
+
+let interp_mutual paramsl indl notations finite = 
+  check_all_names_different indl;
+  let env0 = Global.env() in
+  let isevars = ref (Evd.create_evar_defs Evd.empty) in
+  let env_params, ctx_params = interp_context_evars isevars env0 paramsl in
+  let indnames = List.map (fun ind -> ind.ind_name) indl in
 
-let corecursive_message v =
-  match Array.length v with
-    | 0 -> error "no corecursive definition"
-    | 1 -> (Printer.pr_global v.(0) ++ str " is corecursively defined")
-    | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
-                    spc () ++ str "are corecursively defined")
-
-let interp_mutual lparams lnamearconstrs finite = 
-  let allnames = 
-    List.fold_left (fun acc (id,_,_,l) -> id::(List.map fst l)@acc)
-      [] lnamearconstrs in
-  if not (list_distinct allnames) then
-    error "Two inductive objects have the same name";
-  let nparams = local_binders_length lparams
-  and sigma = Evd.empty 
-  and env0 = Global.env() in
-  let env_params, params =
-    List.fold_left
-      (fun (env, params) d -> match d with
-	| LocalRawAssum ([_,na],(CHole _ as t)) ->
-	    let t = interp_binder sigma env na t in
-	    let d = (na,None,t) in
-	    (push_rel d env, d::params)
-	| LocalRawAssum (nal,t) ->
-	    let t = interp_type sigma env t in
-	    let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
-	    let ctx = List.rev ctx in
-	    (push_rel_context ctx env, ctx@params)
-	| LocalRawDef ((_,na),c) ->
-	    let c = judgment_of_rawconstr sigma env c in
-	    let d = (na, Some c.uj_val, c.uj_type) in
-	    (push_rel d env,d::params))
-      (env0,[]) lparams
-  in
-  (* Builds the params of the inductive entry *)
-  let params' =
-    List.map (fun (na,b,t) ->
-		let id = match na with
-		  | Name id -> id
-		  | Anonymous -> anomaly "Unnamed inductive variable" in 
-		match b with
-		  | None -> (id, LocalAssum t)
-		  | Some b -> (id, LocalDef b)) params
-  in
-  let paramassums = 
-    List.fold_right (fun d l -> match d with
-	(id,LocalAssum _) -> id::l | (_,LocalDef _) -> l) params' [] in
-  let indnames =
-    List.map (fun (id,_,_,_)-> id) lnamearconstrs @ paramassums in
-  let nparamassums = List.length paramassums in
-  let (ind_env,ind_impls,arityl) =
-    List.fold_left
-      (fun (env, ind_impls, arl) (recname, _, arityc, _) ->
-         let arity = interp_type sigma env_params arityc in
-	 let fullarity = it_mkProd_or_LetIn arity params in
-	 let env' = Termops.push_rel_assum (Name recname,fullarity) env in
-	 let argsc = compute_arguments_scope fullarity in
-	 let ind_impls' = 
-	   if Impargs.is_implicit_args() then
-	     let impl = Impargs.compute_implicits false env_params fullarity in
-	     let paramimpl,_ = list_chop nparamassums impl in
-	     let l = List.fold_right
-	       (fun imp l -> if Impargs.is_status_implicit imp then
-		 Impargs.name_of_implicit imp::l else l) paramimpl [] in
-	     (recname,(l,impl,argsc))::ind_impls
-	   else
-	     (recname,([],[],argsc))::ind_impls in
-	 (env', ind_impls', (arity::arl)))
-      (env0, [], []) lnamearconstrs
-  in
   (* Names of parameters as arguments of the inductive type (defs removed) *)
-  let lparargs = 
-    List.flatten
-      (List.map (function (id,LocalAssum _) -> [id] | _ -> []) params') in
-  let notations = 
-    List.fold_right (fun (_,ntnopt,_,_) l -> option_cons ntnopt l) 
-      lnamearconstrs [] in
-  let fs = States.freeze() in
-  (* Declare the notations for the inductive types pushed in local context*)
-  try
-  List.iter (fun (df,c,scope) -> (* No scope for tmp notation *)
-    Metasyntax.add_notation_interpretation df ind_impls c None) notations;
-  let ind_env_params = push_rel_context params ind_env in
-
-  let mispecvec = 
-    List.map2
-      (fun ar (name,_,_,lname_constr) ->
-	 let constrnames, bodies = List.split lname_constr in
-         (* Compute the conclusions of constructor types *)
-	 (* for inductive given in ML syntax *)
-	 let nar = 
-	   List.length (fst (Reductionops.splay_arity env_params Evd.empty ar))
-	 in
-	 let bodies =
-	   List.map2 (adjust_conclusion (nar,name,lparargs))
-	     constrnames bodies
-	 in
-
-         (* Interpret the constructor types *)
-         let constrs =
-	   List.map 
-	     (interp_type_with_implicits sigma ind_env_params
-	       (paramassums,ind_impls))
-	     bodies
-	 in
-
-         (* Build the inductive entry *)
-	 { mind_entry_params = params';
-	   mind_entry_typename = name;
-	   mind_entry_arity = ar;
-	   mind_entry_consnames = constrnames;
-	   mind_entry_lc = constrs })
-      (List.rev arityl) lnamearconstrs
-  in
-  States.unfreeze fs;
-  notations, { mind_entry_record = false; 
-	       mind_entry_finite = finite; 
-	       mind_entry_inds = mispecvec }
-  with e -> States.unfreeze fs; raise e
+  let assums = List.filter(fun (_,b,_) -> b=None) ctx_params in
+  let params = List.map (fun (na,_,_) -> out_name na) assums in
+
+  (* Interpret the arities *)
+  let arities = List.map (interp_ind_arity isevars env_params) indl in
+  let fullarities = List.map (fun c -> it_mkProd_or_LetIn c ctx_params) arities in
+  let env_ar = push_types env0 indnames fullarities in
+  let env_ar_params = push_rel_context ctx_params env_ar in
+
+  (* Compute interpretation metadatas *)
+  let impls = compute_interning_datas env0 params indnames fullarities in
+  let mldatas = List.map2 (mk_mltype_data isevars env_params params) arities indnames in
+
+  let constructors =
+    States.with_heavy_rollback (fun () -> 
+     (* Temporary declaration of notations and scopes *)
+     List.iter (declare_interning_data impls) notations;
+     (* Interpret the constructor types *)
+     list_map3 (interp_cstrs isevars env_ar_params impls) mldatas arities indl)
+     () in
+
+  (* Instantiate evars and check all are resolved *)
+  let isevars,_ = consider_remaining_unif_problems env_params !isevars in
+  let sigma = Evd.evars_of isevars in
+  let constructors = List.map (fun (idl,cl) -> (idl,List.map (nf_evar sigma) cl)) constructors in
+  let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in
+  let arities = List.map (nf_evar sigma) arities in
+  List.iter (check_evars env_params Evd.empty isevars) arities;
+  Sign.iter_rel_context (check_evars env0 Evd.empty isevars) ctx_params;
+  List.iter (fun (_,ctyps) ->
+    List.iter (check_evars env_ar_params Evd.empty isevars) ctyps)
+    constructors;
+  
+  (* Build the inductive entries *)
+  let entries = list_map3 (fun ind arity (cnames,ctypes) -> {
+    mind_entry_typename = ind.ind_name;
+    mind_entry_arity = arity;
+    mind_entry_consnames = cnames;
+    mind_entry_lc = ctypes
+  }) indl arities constructors in
+
+  (* Build the mutual inductive entry *)
+  { mind_entry_params = List.map prepare_param ctx_params;
+    mind_entry_record = false; 
+    mind_entry_finite = finite; 
+    mind_entry_inds = entries }
+
+let eq_constr_expr c1 c2 =
+  try let _ = Constrextern.check_same_type c1 c2 in true with _ -> false
+
+(* Very syntactical equality *)
+let eq_local_binder d1 d2 = match d1,d2 with
+  | LocalRawAssum (nal1,c1), LocalRawAssum (nal2,c2) ->
+      List.length nal1 = List.length nal2 &&
+      List.for_all2 (fun (_,na1) (_,na2) -> na1 = na2) nal1 nal2 &&
+      eq_constr_expr c1 c2
+  | LocalRawDef ((_,id1),c1), LocalRawDef ((_,id2),c2) ->
+      id1 = id2 && eq_constr_expr c1 c2
+  | _ ->
+      false
+
+let eq_local_binders bl1 bl2 =
+  List.length bl1 = List.length bl2 && List.for_all2 eq_local_binder bl1 bl2
+
+let extract_coercions indl =
+  let mkqid (_,((_,id),_)) = make_short_qualid id in
+  let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in
+  List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl))
+
+let extract_params indl =
+  let paramsl = List.map (fun (_,params,_,_) -> params) indl in
+  match paramsl with
+  | [] -> anomaly "empty list of inductive types"
+  | params::paramsl ->
+      if not (List.for_all (eq_local_binders params) paramsl) then error 
+	"Parameters should be syntactically the same for each inductive type";
+      params
+
+let prepare_inductive ntnl indl =
+  let indl =
+    List.map (fun ((_,indname),_,ar,lc) -> { 
+      ind_name = indname;
+      ind_arity = ar;
+      ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc
+    }) indl in
+  List.fold_right option_cons ntnl [], indl
 
 let declare_mutual_with_eliminations isrecord mie =
-  let lrecnames =
-    List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in
+  let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in
   let (_,kn) = declare_mind isrecord mie in
-  if_verbose ppnl (minductive_message lrecnames);
+  if_verbose ppnl (minductive_message names);
   declare_eliminations kn;
   kn
 
-(* Very syntactical equality *)
-let eq_la d1 d2 = match d1,d2 with
-  | LocalRawAssum (nal,ast), LocalRawAssum (nal',ast') ->
-      List.for_all2 (fun (_,na) (_,na') -> na = na') nal nal'
-      & (try let _ = Constrextern.check_same_type ast ast' in true with _ -> false)
-  | LocalRawDef ((_,id),ast), LocalRawDef ((_,id'),ast') ->
-      id=id' & (try let _ = Constrextern.check_same_type ast ast' in true with _ -> false)
-  | _ -> false
-
-let extract_coe lc =
-  List.fold_right
-    (fun (addcoe,((_,(id:identifier)),t)) (l1,l2) ->
-      ((if addcoe then id::l1 else l1), (id,t)::l2)) lc ([],[])
-
-let extract_coe_la_lc = function
-  | []            -> anomaly "Vernacentries: empty list of inductive types"
-  | ((_,id),ntn,la,ar,lc)::rest ->
-      let rec check = function 
-	| []             -> [],[]
-  	| ((_,id),ntn,la',ar,lc)::rest ->
-            if (List.length la = List.length la') && 
-               (List.for_all2 eq_la la la')
-	    then
-	      let mcoes, mspec = check rest in
-	      let coes, lc' = extract_coe lc in
-	      (coes::mcoes,(id,ntn,ar,lc')::mspec)
-	    else 
-	      error ("Parameters should be syntactically the same "^
-		     "for each inductive type")
-      in
-      let mcoes, mspec = check rest in
-      let coes, lc' = extract_coe lc in
-      (coes,la,(id,ntn,ar,lc'):: mspec)
-
-let build_mutual lind finite =
-  let ((coes:identifier list),lparams,lnamearconstructs) = extract_coe_la_lc lind in
-  let notations,mie = interp_mutual lparams lnamearconstructs finite in
-  let kn = declare_mutual_with_eliminations false mie in
-  (* Declare the notations now bound to the inductive types *)
-  List.iter (fun (df,c,scope) ->
-    Metasyntax.add_notation_interpretation df [] c scope) notations;
-  List.iter
-    (fun id -> 
-      Class.try_add_new_coercion (locate (make_short_qualid id)) Global) coes
-
-(* try to find non recursive definitions *)
-
-let list_chop_hd i l = match list_chop i l with
-  | (l1,x::l2) -> (l1,x,l2)
-  | _ -> assert false
+let build_mutual l finite =
+  let indl,ntnl = List.split l in
+  let paramsl = extract_params indl in
+  let coes = extract_coercions indl in
+  let notations,indl = prepare_inductive ntnl indl in
+  let mie = interp_mutual paramsl indl notations finite in
+  (* Declare the mutual inductive block with its eliminations *)
+  ignore (declare_mutual_with_eliminations false mie);
+  (* Declare the possible notations of inductive types *)
+  List.iter (declare_interning_data ([],[])) notations;
+  (* Declare the coercions *)
+  List.iter (fun qid -> Class.try_add_new_coercion (locate qid) Global) coes
+
+(* 3c| Fixpoints and co-fixpoints *)
+
+let recursive_message = function
+  | [] -> anomaly "no recursive definition"
+  | [id] -> pr_id id ++ str " is recursively defined"
+  | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++
+		    spc () ++ str "are recursively defined")
 
-let collect_non_rec env = 
-  let rec searchrec lnonrec lnamerec ldefrec larrec nrec = 
-    try
-      let i = 
-        list_try_find_i
-          (fun i f ->
-             if List.for_all (fun def -> not (occur_var env f def)) ldefrec
-             then i else failwith "try_find_i")
-          0 lnamerec 
-      in
-      let (lf1,f,lf2) = list_chop_hd i lnamerec in
-      let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
-      let (lar1,ar,lar2) = list_chop_hd i larrec in
-      let newlnv = 
-	try 
-	  match list_chop i nrec with 
-            | (lnv1,_::lnv2) -> (lnv1@lnv2)
-	    | _ -> [] (* nrec=[] for cofixpoints *)
-        with Failure "list_chop" -> []
-      in 
-      searchrec ((f,def,ar)::lnonrec) 
-	(lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
-    with Failure "try_find_i" -> 
-      (List.rev lnonrec,
-       (Array.of_list lnamerec, Array.of_list ldefrec,
-        Array.of_list larrec, Array.of_list nrec))
-  in 
-  searchrec [] 
+let corecursive_message = function
+  | [] -> error "no corecursive definition"
+  | [id] -> pr_id id ++ str " is corecursively defined"
+  | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++
+                    spc () ++ str "are corecursively defined")
 
-let build_recursive (lnameargsardef:(fixpoint_expr *decl_notation) list)  =
-  let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef 
-  and sigma = Evd.empty
-  and env0 = Global.env()
-  and nv = Array.of_list (List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef) in
-  (* Build the recursive context and notations for the recursive types *)
-  let (rec_sign,rec_impls,arityl) = 
-    List.fold_left 
-      (fun (env,impls,arl) ((recname,_,bl,arityc,_),_) -> 
-        let arityc = generalize_rawconstr arityc bl in
-        let arity = interp_type sigma env0 arityc in
-	let impl = 
-	  if Impargs.is_implicit_args()
-	  then Impargs.compute_implicits false env0 arity
-	  else [] in
-	let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in
-        (Environ.push_named (recname,None,arity) env, impls', arity::arl))
-      (env0,[],[]) lnameargsardef in
-  let arityl = List.rev arityl in
-  let notations = 
-    List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) 
-      lnameargsardef [] in
-
-  let recdef =
-
-    (* Declare local notations *)
-    let fs = States.freeze() in
-    let def = 
-      try
-	List.iter (fun (df,c,scope) -> (* No scope for tmp notation *)
-	 Metasyntax.add_notation_interpretation df rec_impls c None) notations;
-	List.map2
-	  (fun ((_,_,bl,_,def),_) arity ->
-            let def = abstract_rawconstr def bl in
-            interp_casted_constr_with_implicits 
-	      sigma rec_sign rec_impls def arity)
-          lnameargsardef arityl
-      with e ->
-	States.unfreeze fs; raise e in
-    States.unfreeze fs; def 
-  in
+let recursive_message isfix = 
+  if isfix=Fixpoint then recursive_message else corecursive_message
 
-  let (lnonrec,(namerec,defrec,arrec,nvrec)) = 
-    collect_non_rec env0 lrecnames recdef arityl (Array.to_list nv) in
-  let recvec = 
-    Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in
-  let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in
-  let rec declare i fi =
-    let ce = 
-      { const_entry_body = mkFix ((nvrec,i),recdecls);
-        const_entry_type = Some arrec.(i);
-        const_entry_opaque = false } in
-    let (_,kn) = declare_constant fi (DefinitionEntry ce, IsDefinition) in
-    (ConstRef kn)
-  in 
-  (* declare the recursive definitions *)
-  let lrefrec = Array.mapi declare namerec in
-  if_verbose ppnl (recursive_message lrefrec);
-  (* The others are declared as normal definitions *)
-  let var_subst id = (id, global_reference id) in
-  let _ = 
-    List.fold_left
-      (fun subst (f,def,t) ->
-	 let ce = { const_entry_body = replace_vars subst def;
-		    const_entry_type = Some t;
-                    const_entry_opaque = false } in
-	 let _ = declare_constant f (DefinitionEntry ce, IsDefinition) in
-      	 warning ((string_of_id f)^" is non-recursively defined");
-      	 (var_subst f) :: subst)
-      (List.map var_subst (Array.to_list namerec))
-      lnonrec 
-  in
-  List.iter (fun (df,c,scope) ->
-    Metasyntax.add_notation_interpretation df [] c scope) notations
+(* An (unoptimized) function that maps preorders to partial orders...
 
-let build_corecursive lnameardef = 
-  let lrecnames = List.map (fun (f,_,_,_) -> f) lnameardef
-  and sigma = Evd.empty
-  and env0 = Global.env() in
-  let fs = States.freeze() in
-  let (rec_sign,arityl) = 
-    try 
-      List.fold_left 
-        (fun (env,arl) (recname,bl,arityc,_) -> 
-           let arityc = generalize_rawconstr arityc bl in
-           let arj = type_judgment_of_rawconstr Evd.empty env0 arityc in
-	   let arity = arj.utj_val in
-           let _ = declare_variable recname
-	     (Lib.cwd(),SectionLocalAssum arj.utj_val,IsAssumption Definitional) in
-           (Environ.push_named (recname,None,arity) env, (arity::arl)))
-        (env0,[]) lnameardef
-    with e -> 
-      States.unfreeze fs; raise e in 
-  let arityl = List.rev arityl in
-  let recdef =
-    try 
-      List.map (fun (_,bl,arityc,def) ->
-        let arityc = generalize_rawconstr arityc bl in
-        let def = abstract_rawconstr def bl in
-	let arity = interp_constr sigma rec_sign arityc in
-                  interp_casted_constr sigma rec_sign def arity)
-        lnameardef
-    with e -> 
-      States.unfreeze fs; raise e 
+   Input:  a list of associations (x,[y1;...;yn]), all yi distincts
+           and different of x, meaning x<=y1, ..., x<=yn
+
+   Output: a list of associations (x,Inr [y1;...;yn]), collecting all
+           distincts yi greater than x, _or_, (x, Inl y) meaning that
+           x is in the same class as y (in which case, x occurs
+           nowhere else in the association map)
+
+   partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list
+*)
+
+let rec partial_order = function
+  | [] -> []
+  | (x,xge)::rest ->
+    let rec browse res xge' = function
+    | [] ->
+	let res = List.map (function
+	  | (z, Inr zge) when List.mem x zge -> (z, Inr (list_union zge xge'))
+	  | r -> r) res in
+	(x,Inr xge')::res
+    | y::xge -> 
+      let rec link y = 
+	try match List.assoc y res with
+	| Inl z -> link z
+	| Inr yge -> 
+	  if List.mem x yge then
+	    let res = List.remove_assoc y res in
+	    let res = List.map (function
+	      | (z, Inl t) ->
+		  if t = y then (z, Inl x) else (z, Inl t)
+	      | (z, Inr zge) ->
+		  if List.mem y zge then
+		    (z, Inr (list_add_set x (list_remove y zge)))
+		  else
+		    (z, Inr zge)) res in
+	    browse ((y,Inl x)::res) xge' (list_union xge (list_remove x yge))
+	  else
+	    browse res (list_add_set y (list_union xge' yge)) xge
+	with Not_found -> browse res (list_add_set y xge') xge
+      in link y
+    in browse (partial_order rest) [] xge 
+
+let non_full_mutual_message x xge y yge kind rest =
+  let reason = 
+    if List.mem x yge then 
+      string_of_id y^" depends on "^string_of_id x^" but not conversely"
+    else if List.mem y xge then 
+      string_of_id x^" depends on "^string_of_id y^" but not conversely"
+    else
+      string_of_id y^" and "^string_of_id x^" are not mutually dependent" in
+  let e = if rest <> [] then "e.g.: "^reason else reason in
+  let k = if kind=Fixpoint then "fixpoint" else "cofixpoint" in
+  let w =
+    if kind=Fixpoint then "Well-foundedness check may fail unexpectedly.\n"
+    else "" in
+  "Not a fully mutually defined "^k^"\n("^e^").\n"^w
+
+let check_mutuality env kind fixl =
+  let names = List.map fst fixl in
+  let preorder =
+    List.map (fun (id,def) -> 
+      (id, List.filter (fun id' -> id<>id' & occur_var env id' def) names))
+      fixl in
+  let po = partial_order preorder in
+  match List.filter (function (_,Inr _) -> true | _ -> false) po with
+    | (x,Inr xge)::(y,Inr yge)::rest ->
+	if_verbose warning (non_full_mutual_message x xge y yge kind rest)
+    | _ -> ()
+
+type fixpoint_kind =
+  | IsFixpoint of (int option * recursion_order_expr) list
+  | IsCoFixpoint
+
+type fixpoint_expr = {
+  fix_name : identifier;
+  fix_binders : local_binder list;
+  fix_body : constr_expr;
+  fix_type : constr_expr
+}
+
+let interp_fix_type isevars env fix =
+  interp_type_evars isevars env 
+    (generalize_constr_expr fix.fix_type fix.fix_binders)
+
+let interp_fix_body isevars env impls fix fixtype =
+  interp_casted_constr_evars isevars env ~impls
+    (abstract_constr_expr fix.fix_body fix.fix_binders) fixtype
+
+let declare_fix boxed kind f def t =
+  let ce = {
+    const_entry_body = def;
+    const_entry_type = Some t;
+    const_entry_opaque = false;
+    const_entry_boxed = boxed
+  } in
+  let kn = declare_constant f (DefinitionEntry ce,IsDefinition kind) in
+  ConstRef kn
+
+let prepare_recursive_declaration fixnames fixtypes fixdefs =
+  let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
+  let names = List.map (fun id -> Name id) fixnames in
+  (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
+
+let compute_guardness_evidence (n,_) fixl fixtype =
+  match n with 
+  | Some n -> n 
+  | None -> 
+      (* Recursive argument was not given by the user : 
+	 We check that there is only one inductive argument *)
+      let m = local_binders_length fixl.fix_binders in
+      let ctx = fst (Sign.decompose_prod_n_assum m fixtype) in
+      let isIndApp t = isInd (fst (decompose_app (strip_head_cast t))) in 
+      (* This could be more precise (e.g. do some delta) *)
+      let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in
+      try (list_unique_index true lb) - 1
+      with Not_found -> error "the recursive argument needs to be specified"
+
+let interp_recursive fixkind l boxed =
+  let env = Global.env() in
+  let fixl, ntnl = List.split l in
+  let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in
+  let fixnames = List.map (fun fix -> fix.fix_name) fixl in
+
+  (* Interp arities allowing for unresolved types *)
+  let isevars = ref (Evd.create_evar_defs Evd.empty) in
+  let fixtypes = List.map (interp_fix_type isevars env) fixl in
+  let env_rec = push_named_types env fixnames fixtypes in
+
+  (* Get interpretation metadatas *)
+  let impls = compute_interning_datas env [] fixnames fixtypes in
+  let notations = List.fold_right option_cons ntnl [] in
+
+  (* Interp bodies with rollback because temp use of notations/implicit *)
+  let fixdefs = 
+    States.with_heavy_rollback (fun () -> 
+      List.iter (declare_interning_data impls) notations;
+      List.map2 (interp_fix_body isevars env_rec impls) fixl fixtypes)
+      () in
+
+  (* Instantiate evars and check all are resolved *)
+  let isevars,_ = consider_remaining_unif_problems env_rec !isevars in
+  let fixdefs = List.map (nf_evar (Evd.evars_of isevars)) fixdefs in
+  let fixtypes = List.map (nf_evar (Evd.evars_of isevars)) fixtypes in
+  List.iter (check_evars env_rec Evd.empty isevars) fixdefs;
+  List.iter (check_evars env Evd.empty isevars) fixtypes;
+  check_mutuality env kind (List.combine fixnames fixdefs);
+
+  (* Build the fix declaration block *)
+  let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
+  let fixdecls = 
+    match fixkind with
+    | IsFixpoint wfl ->
+	let fixwf = list_map3 compute_guardness_evidence wfl fixl fixtypes in
+	list_map_i (fun i _ -> mkFix ((Array.of_list fixwf,i),fixdecls)) 0 l
+    | IsCoFixpoint ->
+	list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l
   in
-  States.unfreeze fs;
-  let (lnonrec,(namerec,defrec,arrec,_)) = 
-    collect_non_rec env0 lrecnames recdef arityl [] in
-  let recvec = 
-    Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in
-  let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in
-  let rec declare i fi =
-    let ce = 
-      { const_entry_body = mkCoFix (i, recdecls);
-        const_entry_type = Some (arrec.(i));
-        const_entry_opaque = false } 
-    in
-    let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in
-    (ConstRef kn)
-  in 
-  let lrefrec = Array.mapi declare namerec in
-  if_verbose ppnl (corecursive_message lrefrec);
-  let var_subst id = (id, global_reference id) in
-  let _ = 
-    List.fold_left
-      (fun subst (f,def,t) ->
-	 let ce = { const_entry_body = replace_vars subst def;
-		    const_entry_type = Some t;
-                    const_entry_opaque = false } in
-	 let _ = declare_constant f (DefinitionEntry ce,IsDefinition) in
-      	 warning ((string_of_id f)^" is non-recursively defined");
-      	 (var_subst f) :: subst)
-      (List.map var_subst (Array.to_list namerec))
-      lnonrec 
-  in ()
+
+  (* Declare the recursive definitions *)
+  ignore (list_map3 (declare_fix boxed kind) fixnames fixdecls fixtypes);
+  if_verbose ppnl (recursive_message kind fixnames);
+
+  (* Declare notations *)
+  List.iter (declare_interning_data ([],[])) notations
+
+let build_recursive l b =
+  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
+  let fixl = List.map (fun ((id,_,bl,typ,def),ntn) -> 
+    ({fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ},ntn))
+    l in
+  interp_recursive (IsFixpoint g) fixl b
+
+let build_corecursive l b =
+  let fixl = List.map (fun ((id,bl,typ,def),ntn) -> 
+    ({fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ},ntn))
+    l in
+  interp_recursive IsCoFixpoint fixl b
+
+(* 3d| Schemes *)
 
 let build_scheme lnamedepindsort = 
   let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
@@ -616,15 +646,18 @@ let build_scheme lnamedepindsort =
   let listdecl = Indrec.build_mutual_indrec env0 sigma lrecspec in 
   let rec declare decl fi lrecref =
     let decltype = Retyping.get_type_of env0 Evd.empty decl in
-    let decltype = Evarutil.refresh_universes decltype in
+    let decltype = refresh_universes decltype in
     let ce = { const_entry_body = decl;
                const_entry_type = Some decltype;
-               const_entry_opaque = false } in
-    let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in
+               const_entry_opaque = false;
+	       const_entry_boxed = Options.boxed_definitions() } in
+    let kn = declare_constant fi (DefinitionEntry ce, IsDefinition Scheme) in
     ConstRef kn :: lrecref
   in 
-  let lrecref = List.fold_right2 declare listdecl lrecnames [] in
-  if_verbose ppnl (recursive_message (Array.of_list lrecref))
+  let _ = List.fold_right2 declare listdecl lrecnames [] in
+  if_verbose ppnl (recursive_message Fixpoint lrecnames)
+
+(* 4| Goal declaration *)
 
 let start_proof id kind c hook =
   let sign = Global.named_context () in
@@ -643,29 +676,30 @@ let start_proof_com sopt kind (bl,t) hook =
  	  (Pfedit.get_all_proof_names ())
   in
   let env = Global.env () in
-  let c = interp_type Evd.empty env (generalize_rawconstr t bl) in
+  let c = interp_type Evd.empty env (generalize_constr_expr t bl) in
   let _ = Typeops.infer_type env c in
   start_proof id kind c hook
 
-let save id const kind hook =
+let save id const (locality,kind) hook =
   let {const_entry_body = pft;
        const_entry_type = tpo;
        const_entry_opaque = opacity } = const in
-  let l,r = match kind with
-    | IsLocal when Lib.sections_are_opened () ->
+  let l,r = match locality with
+    | Local when Lib.sections_are_opened () ->
+        let k = logical_kind_of_goal_kind kind in
 	let c = SectionLocalDef (pft, tpo, opacity) in
-	let _ = declare_variable id (Lib.cwd(), c, IsDefinition) in
+	let _ = declare_variable id (Lib.cwd(), c, k) in
 	(Local, VarRef id)
-    | IsLocal ->
-        let k = IsDefinition in
-        let _,kn = declare_constant id (DefinitionEntry const, k) in
+    | Local ->
+        let k = logical_kind_of_goal_kind kind in
+        let kn = declare_constant id (DefinitionEntry const, k) in
 	(Global, ConstRef kn)
-    | IsGlobal k ->
-        let k = theorem_kind_of_goal_kind k in
-        let _,kn = declare_constant id (DefinitionEntry const, k) in
+    | Global ->
+        let k = logical_kind_of_goal_kind kind in
+        let kn = declare_constant id (DefinitionEntry const, k) in
 	(Global, ConstRef kn) in
-  hook l r;
   Pfedit.delete_current_proof ();
+  hook l r;
   definition_message id
 
 let save_named opacity =
@@ -691,7 +725,7 @@ let save_anonymous_with_strength kind opacity save_ident =
   let const = { const with const_entry_opaque = opacity } in
   check_anonymity id save_ident;
   (* we consider that non opaque behaves as local for discharge *)
-  save save_ident const (IsGlobal (Proof kind)) hook
+  save save_ident const (Global, Proof kind) hook
 
 let admit () =
   let (id,k,typ,hook) = Pfedit.current_proof_statement () in
@@ -699,9 +733,10 @@ let admit () =
   if k <> IsGlobal (Proof Conjecture) then
     error "Only statements declared as conjecture can be admitted";
 *)
-  let (_,kn) = declare_constant id (ParameterEntry typ, IsConjecture) in
-  hook Global (ConstRef kn);
+  let kn =
+    declare_constant id (ParameterEntry typ, IsAssumption Conjectural) in
   Pfedit.delete_current_proof ();
+  hook Global (ConstRef kn);
   assumption_message id
 
 let get_current_context () =
diff --git a/toplevel/command.mli b/toplevel/command.mli
index 7997288c..6f9a55c3 100644
--- a/toplevel/command.mli
+++ b/toplevel/command.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: command.mli,v 1.38.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: command.mli 9110 2006-09-01 12:30:52Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -22,6 +22,7 @@ open Vernacexpr
 open Rawterm
 open Topconstr
 open Decl_kinds
+open Redexpr
 (*i*)
 
 (*s Declaration functions. The following functions take ASTs,
@@ -30,7 +31,7 @@ open Decl_kinds
    defined object *)
 
 val declare_definition : identifier -> definition_kind ->
-  local_binder list -> Tacred.red_expr option -> constr_expr ->
+  local_binder list -> red_expr option -> constr_expr ->
     constr_expr option -> declaration_hook -> unit
 
 val syntax_definition : identifier -> constr_expr -> bool -> bool -> unit
@@ -38,18 +39,18 @@ val syntax_definition : identifier -> constr_expr -> bool -> bool -> unit
 val declare_assumption : identifier located list ->
   coercion_flag -> assumption_kind -> local_binder list -> constr_expr -> unit
 
-val build_mutual : inductive_expr list -> bool -> unit
+val build_mutual : (inductive_expr * decl_notation) list -> bool -> unit
 
 val declare_mutual_with_eliminations :
   bool -> Entries.mutual_inductive_entry -> mutual_inductive
 
-val build_recursive : (fixpoint_expr * decl_notation) list -> unit
+val build_recursive : (fixpoint_expr * decl_notation) list -> bool -> unit
 
-val build_corecursive : cofixpoint_expr list -> unit
+val build_corecursive : (cofixpoint_expr * decl_notation) list -> bool -> unit
 
 val build_scheme : (identifier located * bool * reference * rawsort) list -> unit
 
-val generalize_rawconstr : constr_expr -> local_binder list -> constr_expr
+val generalize_constr_expr : constr_expr -> local_binder list -> constr_expr
 
 val start_proof : identifier -> goal_kind -> constr ->
   declaration_hook -> unit
@@ -83,3 +84,5 @@ val admit : unit -> unit
    and the current global env *)
 
 val get_current_context : unit -> Evd.evar_map * Environ.env
+
+
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index 4ba8f6c2..44b2e231 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqinit.ml,v 1.30.2.4 2006/01/11 23:18:06 barras Exp $ *)
+(* $Id: coqinit.ml 7732 2005-12-26 13:51:24Z herbelin $ *)
 
 open Pp
 open System
@@ -73,23 +73,19 @@ let init_load_path () =
   (* developper specific directories to open *)
   let dev = if Coq_config.local then [ "dev" ] else [] in
   let coqlib =
-    if !Options.boot then Coq_config.coqtop
-      (* variable COQLIB overrides the default library *)
-    else getenv_else "COQLIB" Coq_config.coqlib in
-  let coqlib = canonical_path_name coqlib in
+    (* variable COQLIB overrides the default library *)
+    getenv_else "COQLIB"
+      (if Coq_config.local || !Options.boot then Coq_config.coqtop
+       else Coq_config.coqlib) in
   (* first user-contrib *)
   let user_contrib = coqlib/"user-contrib" in
   if Sys.file_exists user_contrib then 
-    Mltop.add_path user_contrib Nameops.default_root_prefix;
+    Mltop.add_rec_path user_contrib Nameops.default_root_prefix;
   (* then standard library *)
-  let vdirs = 
-    if !Options.v7 then [ "theories7"; "contrib7" ]
-    else [ "theories"; "contrib" ] in
-  let dirs = 
-    (if !Options.v7 then "states7" else "states") :: dev @ vdirs in
+  let vdirs = [ "theories"; "contrib" ] in
+  let dirs = "states" :: dev @ vdirs in
   List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs;
   let camlp4 = getenv_else "CAMLP4LIB" Coq_config.camlp4lib in
-  let camlp4 = canonical_path_name camlp4 in
   add_ml_include camlp4;
   (* then current directory *)
   Mltop.add_path "." Nameops.default_root_prefix;
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index e029d8ac..d7856170 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqinit.mli,v 1.7.16.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: coqinit.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Initialization. *)
 
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index af787460..3374b0ee 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqtop.ml,v 1.72.2.5 2005/11/23 14:46:09 barras Exp $ *)
+(* $Id: coqtop.ml 9191 2006-09-29 15:45:42Z courtieu $ *)
 
 open Pp
 open Util
@@ -21,19 +21,16 @@ open Coqinit
 
 let get_version_date () =
   try
-    let ch = open_in (Coq_config.coqtop^"/make.result") in
-    let l = input_line ch in
-    let i = String.index l ' ' in
-    let j = String.index_from l (i+1) ' ' in
-    "checked out on "^(String.sub l (i+1) (j-i-1))
-  with _ -> Coq_config.date
+    let ch = open_in (Coq_config.coqlib^"/revision") in
+    let ver = input_line ch in
+    let rev = input_line ch in
+      (ver,rev)
+  with _ -> (Coq_config.version,Coq_config.date)
 
 let print_header () =
-  Printf.printf "Welcome to Coq %s%s (%s)\n"
-    Coq_config.version 
-    (if !Options.v7 then " (V7 syntax)" else "")
-    (get_version_date ());
-  flush stdout
+  let (ver,rev) = (get_version_date ()) in
+    Printf.printf "Welcome to Coq %s (%s)\n" ver rev;
+    flush stdout
 
 let memory_stat = ref false
 
@@ -50,8 +47,10 @@ let engage () =
   
 let set_batch_mode () = batch_mode := true
 
-let toplevel_name = ref (make_dirpath [id_of_string "Top"])
-let set_toplevel_name dir = toplevel_name := dir
+let toplevel_default_name = make_dirpath [id_of_string "Top"]
+let toplevel_name = ref (Some toplevel_default_name)
+let set_toplevel_name dir = toplevel_name := Some dir
+let unset_toplevel_name () = toplevel_name := None
 
 let remove_top_ml () = Mltop.remove ()
 
@@ -91,12 +90,13 @@ let load_vernacular () =
 let load_vernacular_obj = ref ([] : string list)
 let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj
 let load_vernac_obj () = 
-  List.iter Library.read_library_from_file (List.rev !load_vernacular_obj)
+  List.iter (fun f -> Library.require_library_from_file None f None)
+    (List.rev !load_vernacular_obj)
 
 let require_list = ref ([] : string list)
 let add_require s = require_list := s :: !require_list
 let require () =
-  List.iter (fun s -> Library.require_library_from_file None None s false)
+  List.iter (fun s -> Library.require_library_from_file None s (Some false))
     (List.rev !require_list)
 
 let compile_list = ref ([] : (bool * string) list)
@@ -106,14 +106,16 @@ let add_compile verbose s =
   compile_list := (verbose,s) :: !compile_list
 let compile_files () =
   let init_state = States.freeze() in
-  List.iter
-    (fun (v,f) ->
-      States.unfreeze init_state;
-      if Options.do_translate () then
-	with_option translate_file (Vernac.compile v) f
-      else
-	Vernac.compile v f)
-    (List.rev !compile_list)
+  let coqdoc_init_state = Constrintern.coqdoc_freeze () in
+    List.iter
+      (fun (v,f) ->
+	 States.unfreeze init_state;
+	 Constrintern.coqdoc_unfreeze coqdoc_init_state;
+	 if Options.do_translate () then
+	   with_option translate_file (Vernac.compile v) f
+	 else
+	   Vernac.compile v f)
+      (List.rev !compile_list)
 
 let re_exec_version = ref ""
 let set_byte () = re_exec_version := "byte"
@@ -128,7 +130,6 @@ let re_exec is_ide =
   let s = !re_exec_version in
   let is_native = (Mltop.get()) = Mltop.Native in
   let prog = Sys.argv.(0) in
-  let coq = Filename.basename prog in
   if (is_native && s = "byte") || ((not is_native) && s = "opt")
   then begin
     let s = if s = "" then if is_native then "opt" else "byte" else s in
@@ -142,6 +143,17 @@ let re_exec is_ide =
     Unix.handle_unix_error (Unix.execvp newprog) Sys.argv
   end
 
+(*s options for the virtual machine *)
+
+let boxed_val = ref false
+let boxed_def = ref false
+let use_vm = ref false
+
+let set_vm_opt () =
+  Vm.set_transp_values (not !boxed_val);
+  Options.set_boxed_definitions !boxed_def;
+  Vconv.set_use_vm !use_vm
+
 (*s Parsing of the command line.
     We no longer use [Arg.parse], in order to use share [Usage.print_usage]
     between coqtop and coqc. *)
@@ -160,9 +172,13 @@ let ide_args = ref []
 let parse_args is_ide =
   let rec parse = function
     | [] -> ()
-
+    | "-with-geoproof" :: s :: rem -> 
+	if s = "yes" then Coq_config.with_geoproof := true
+	else if s = "no" then Coq_config.with_geoproof := false
+	else usage ();
+	parse rem
     | "-impredicative-set" :: rem -> 
-        set_engagement Environ.ImpredicativeSet; parse rem
+        set_engagement Declarations.ImpredicativeSet; parse rem
 
     | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem
     | ("-I"|"-include") :: []       -> usage ()
@@ -173,6 +189,7 @@ let parse_args is_ide =
     | "-top" :: d :: rem -> set_toplevel_name (dirpath_of_string d); parse rem
     | "-top" :: [] -> usage ()
 
+    | "-notop" :: rem -> unset_toplevel_name (); parse rem
     | "-q" :: rem -> no_load_rc (); parse rem
 
     | "-opt" :: rem -> set_opt(); parse rem
@@ -228,9 +245,12 @@ let parse_args is_ide =
 
     | "-debug" :: rem -> set_debug (); parse rem
 
-    | "-emacs" :: rem -> Options.print_emacs := true; parse rem
+    | "-vm" :: rem -> use_vm := true; parse rem
+    | "-emacs" :: rem -> Options.print_emacs := true; Pp.make_pp_emacs(); parse rem
+    | "-emacs-U" :: rem -> Options.print_emacs := true; 
+	Options.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem
 	  
-    | "-where" :: _ -> print_endline Coq_config.coqlib; exit 0
+    | "-where" :: _ -> print_endline (getenv_else "COQLIB" Coq_config.coqlib); exit 0
 
     | ("-quiet"|"-silent") :: rem -> Options.make_silent true; parse rem
 
@@ -253,12 +273,10 @@ let parse_args is_ide =
     | "-xml" :: rem -> Options.xml_export := true; parse rem
 
     (* Scanned in Options! *)
-    | "-v7" :: rem -> (* Options.v7 := true; *) parse rem
-    | "-v8" :: rem -> (* Options.v7 := false; *) parse rem
+    | "-v7" :: rem -> error "This version of Coq does not support v7 syntax"
+    | "-v8" :: rem -> parse rem
 
-    (* Translator options *)
-    | "-strict-implicit" :: rem -> 
-	Options.translate_strict_impargs := false; parse rem
+    | "-no-hash-consing" :: rem -> Options.hash_cons_proofs := false; parse rem
 
     | s :: rem -> 
 	if is_ide then begin
@@ -294,9 +312,10 @@ let init is_ide =
       if_verbose print_header ();
       init_load_path ();
       inputstate ();
+      set_vm_opt ();
       engage ();
-      if not !batch_mode && Global.env_is_empty() then
-        Declaremods.start_library !toplevel_name;
+      if (not !batch_mode|| !compile_list=[]) && Global.env_is_empty() then
+        option_iter Declaremods.start_library !toplevel_name;
       init_library_roots ();
       load_vernac_obj ();
       require ();
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
index ef8b4b37..b5a1106c 100644
--- a/toplevel/coqtop.mli
+++ b/toplevel/coqtop.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: coqtop.mli,v 1.5.4.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+(*i $Id: coqtop.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* The Coq main module. The following function [start] will parse the
    command line, print the banner, initialize the load path, load the input 
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
index 281ff1b6..63a6ad07 100644
--- a/toplevel/discharge.ml
+++ b/toplevel/discharge.ml
@@ -6,325 +6,83 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: discharge.ml,v 1.81.2.2 2005/11/29 21:40:53 letouzey Exp $ *)
+(* $Id: discharge.ml 9310 2006-10-28 19:35:09Z herbelin $ *)
 
-open Pp
-open Util
 open Names
-open Nameops
+open Util
 open Sign
 open Term
-open Declarations
 open Entries
-open Inductive
-open Instantiate
-open Reduction
+open Declarations
 open Cooking
-open Typeops
-open Libnames
-open Libobject
-open Lib
-open Nametab
-open Declare
-open Impargs
-open Classops
-open Class
-open Recordops
-open Library
-open Indtypes
-open Nametab
-open Decl_kinds
 
-let recalc_sp dir sp =
-  let (_,spid) = repr_path sp in Libnames.make_path dir spid
+(********************************)
+(* Discharging mutual inductive *)
 
-let recalc_kn dir kn = 
-  let (mp,_,l) = Names.repr_kn kn in
-    Names.make_kn mp dir l
+let detype_param = function
+  | (Name id,None,p) -> id, Entries.LocalAssum p
+  | (Name id,Some p,_) -> id, Entries.LocalDef p
+  | (Anonymous,_,_) -> anomaly"Unnamed inductive local variable"
 
-let rec find_var id = function
-  | [] -> false
-  | (x,b,_)::l -> if x = id then b=None else find_var id l
+(* Replace
 
-let build_abstract_list sec_sp hyps ids_to_discard =
-  let l1,l2 =
-   List.split
-    (List.fold_left
-      (fun vars id ->
-        if find_var id hyps then (mkVar id, Libnames.make_path sec_sp id)::vars
-        else vars)
-      [] ids_to_discard) in
-  Array.of_list l1, l2
+     Var(y1)..Var(yq):C1..Cq |- Ij:Bj
+     Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti
 
-(* Discharge of inductives is done here (while discharge of constants 
-   is done by the kernel for efficiency). *)
+   by
 
-let abstract_inductive sec_sp ids_to_abs hyps inds =
-  let abstract_one_assum id t inds =
-    let ntyp = List.length inds in 
-    let new_refs =
-      list_tabulate (fun k -> applist(mkRel (k+2),[mkRel 1])) ntyp in
-    let inds' =
-      List.map
-      	(function (np,tname,arity,cnames,lc) -> 
-	   let arity' = mkNamedProd id t arity in
-	   let lc' =
-	     List.map (fun b -> mkNamedProd id t (substl new_refs b)) lc
-	   in
-           (np,tname,arity',cnames,lc'))
-      	inds
-    in 
-    inds' in
-  let abstract_one_def id c inds =
-    List.map
-      (function (np,tname,arity,cnames,lc) -> 
-	 let arity' = replace_vars [id, c] arity in
-	 let lc' = List.map (replace_vars [id, c]) lc in
-         (np,tname,arity',cnames,lc'))
-      inds in
-  let abstract_once ((hyps,inds,vars) as sofar) id =
-    match hyps with
-      | (hyp,None,t as d)::rest when id = hyp ->
-	  let inds' = abstract_one_assum hyp t inds in 
-	  (rest, inds', (mkVar id, Libnames.make_path sec_sp id)::vars)
-      | (hyp,Some b,t as d)::rest when id = hyp ->
-	  let inds' = abstract_one_def hyp b inds in 
-	  (rest, inds', vars)
-      | _ -> sofar in
-  let (_,inds',vars) =
-    List.fold_left abstract_once (hyps,inds,[]) ids_to_abs in
-  let inds'' =
-    List.map 
-      (fun (nparams,a,arity,c,lc) ->
-	 let nparams' = nparams + (List.length vars) in
-	 let params, short_arity = decompose_prod_n_assum nparams' arity in
-	 let shortlc =
-	   List.map (fun c -> snd (decompose_prod_n_assum nparams' c))lc in
-	 let params' =
-	   List.map 
-	     (function
-		| (Name id,None,p) -> id, Entries.LocalAssum p
-		| (Name id,Some p,_) -> id, Entries.LocalDef p
-		| (Anonymous,_,_) -> anomaly"Unnamed inductive local variable")
-	     params in
-	 { mind_entry_params = params';
-	   mind_entry_typename = a;
-	   mind_entry_arity = short_arity;
-	   mind_entry_consnames = c;
-	   mind_entry_lc = shortlc })
-      inds' in
-  let l1,l2 = List.split vars in
-   (inds'', Array.of_list l1, l2)
+     |- Ij: (y1..yq:C1..Cq)Bj
+     I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)]
+*)
 
-let process_inductive sec_sp osecsp nsecsp oldenv (ids_to_discard,modlist) mib =
-  assert (Array.length mib.mind_packets > 0);
-  let record = mib.mind_record in 
-  let finite = mib.mind_finite in
+let abstract_inductive hyps nparams inds =
+  let ntyp = List.length inds in 
+  let nhyp = named_context_length hyps in
+  let args = instance_from_named_context (List.rev hyps) in
+  let subs = list_tabulate (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) ntyp in
+  let inds' =
+    List.map
+      (function (tname,arity,cnames,lc) -> 
+	let lc' = List.map (substl subs) lc in
+	let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in
+	let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in
+        (tname,arity',cnames,lc''))
+      	inds in
+  let nparams' = nparams + Array.length args in
+(* To be sure to be the same as before, should probably be moved to process_inductive *) 
+  let params' = let (_,arity,_,_) = List.hd inds' in 
+		let (params,_) = decompose_prod_n_assum nparams' arity in
+		  List.map detype_param params
+  in
+  let ind'' = 
+  List.map 
+    (fun (a,arity,c,lc) ->
+      let _, short_arity = decompose_prod_n_assum nparams' arity in
+      let shortlc =
+	List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in
+      { mind_entry_typename = a;
+	mind_entry_arity = short_arity;
+	mind_entry_consnames = c;
+	mind_entry_lc = shortlc })
+    inds'
+  in (params',ind'')
+
+
+let process_inductive sechyps modlist mib =
+  let nparams = mib.mind_nparams in
   let inds = 
     array_map_to_list
       (fun mip ->
-	 let nparams = mip.mind_nparams in
-	 let arity = expmod_type modlist mip.mind_user_arity in
-	 let lc = Array.map (expmod_type modlist) mip.mind_user_lc in
-	 (nparams,
-	  mip.mind_typename,
+	 let arity = expmod_constr modlist (Termops.refresh_universes (Inductive.type_of_inductive (Global.env()) (mib,mip))) in
+	 let lc = Array.map (expmod_constr modlist) mip.mind_user_lc in
+	 (mip.mind_typename,
 	  arity,
 	  Array.to_list mip.mind_consnames,
 	  Array.to_list lc))
-      mib.mind_packets
-  in
-  let hyps = mib.mind_hyps in
-  let hyps' =
-    Sign.fold_named_context
-      (fun (x,b,t) sgn ->
-        Sign.add_named_decl
-          (x, option_app (expmod_constr modlist) b,expmod_constr modlist t)
-          sgn)
-      mib.mind_hyps ~init:empty_named_context in
-  let (inds',abs_vars,discharged_hyps ) =
-   abstract_inductive sec_sp ids_to_discard hyps' inds in
-  let lmodif_one_mind i = 
-    let nbc = Array.length mib.mind_packets.(i).mind_consnames in 
-    (((osecsp,i), DO_ABSTRACT ((nsecsp,i),abs_vars)),
-     list_tabulate
-       (function j -> 
-	  let j' = j + 1 in
-	  (((osecsp,i),j'), DO_ABSTRACT (((nsecsp,i),j'),abs_vars)))
-      nbc)
-  in
-  let indmodifs,cstrmodifs =
-    List.split (list_tabulate lmodif_one_mind mib.mind_ntypes) in 
-  ({ mind_entry_record = record;
-     mind_entry_finite = finite;
-     mind_entry_inds = inds' },
-   indmodifs,
-   List.flatten cstrmodifs,
-   discharged_hyps)
-
-(* Discharge messages. *)
-
-let constant_message id =
-  Options.if_verbose ppnl (pr_id id ++ str " is discharged.")
-
-let inductive_message inds =
-  Options.if_verbose 
-    ppnl
-      (hov 0 
-	 (match inds with
-	    | [] -> assert false
-	    | [ind] ->
-		(pr_id ind.mind_entry_typename ++ str " is discharged.")
-	    | l ->
-		(prlist_with_sep pr_coma 
-		     (fun ind -> pr_id ind.mind_entry_typename) l ++
-		   spc () ++ str "are discharged.")))
-
-(* Discharge operations for the various objects of the environment. *)
-
-type opacity = bool
-
-type discharge_operation = 
-  | Variable of identifier * section_variable_entry * local_kind * 
-      implicits_flags * Dischargedhypsmap.discharged_hyps
-  | Constant of identifier * recipe * global_kind * constant * 
-      implicits_flags * Dischargedhypsmap.discharged_hyps
-  | Inductive of mutual_inductive_entry * implicits_flags *
-      Dischargedhypsmap.discharged_hyps
-  | Class of cl_typ * cl_info_typ
-  | Struc of inductive * (unit -> struc_typ)
-  | Objdef of constant
-  | Coercion of coercion_entry
-  | Require of library_reference
-  | Constraints of Univ.constraints
-
-(* Main function to traverse the library segment and compute the various
-   discharge operations. *)
-
-let process_object oldenv olddir full_olddir newdir  
-(* {dir -> newdir} {sec_sp -> full_olddir, olddir} *)
-  (ops,ids_to_discard,(constl,indl,cstrl as work_alist)) ((sp,kn),lobj) =
-  let tag = object_tag lobj in 
-  match tag with
-    | "VARIABLE" ->
-	let ((id,c,t),cst) = get_variable_with_constraints (basename sp) in
-	(* VARIABLE means local (entry Variable/Hypothesis/Local and are *)
-	(* always discharged *)
-	(Constraints cst :: ops, id :: ids_to_discard, work_alist)
-
-    | "CONSTANT" ->
-	(* CONSTANT means never discharge (though visibility may vary) *)
- 	let kind = constant_kind sp in
-	let kn = Nametab.locate_constant (qualid_of_sp sp) in
-	let lab = label kn in
-	let cb = Environ.lookup_constant kn oldenv in
-	let imp = is_implicit_constant kn in
-	let newkn = recalc_kn newdir kn in
-	let abs_vars,discharged_hyps0 =
-         build_abstract_list full_olddir cb.const_hyps ids_to_discard in
-        (* let's add the new discharged hypothesis to those already discharged*)
-        let discharged_hyps =
-         discharged_hyps0 @ Dischargedhypsmap.get_discharged_hyps sp in
-        let mods = [ (kn, DO_ABSTRACT(newkn,abs_vars)) ]
-	in
-	let r = { d_from = cb;
-	          d_modlist = work_alist;
-	          d_abstract = ids_to_discard } in
-	let op = Constant (id_of_label lab,r,kind,newkn,imp,discharged_hyps) in
-        (op :: ops, ids_to_discard, (mods@constl, indl, cstrl))
-  
-    | "INDUCTIVE" ->
-	let kn = Nametab.locate_mind (qualid_of_sp sp) in
-	let mib = Environ.lookup_mind kn oldenv in
-	let newkn = recalc_kn newdir kn in
-	let imp = is_implicit_inductive_definition kn in
-(*	let imp = is_implicit_args (* CHANGE *) in*)
-	let (mie,indmods,cstrmods,discharged_hyps0) = 
-	  process_inductive full_olddir kn newkn oldenv (ids_to_discard,work_alist) mib in
-        (* let's add the new discharged hypothesis to those already discharged*)
-        let discharged_hyps =
-         discharged_hyps0 @ Dischargedhypsmap.get_discharged_hyps sp in
-	((Inductive(mie,imp,discharged_hyps)) :: ops, ids_to_discard,
-	 (constl,indmods@indl,cstrmods@cstrl))
-
-    | "CLASS" -> 
-	let ((cl,clinfo) as x) = outClass lobj in
-	if clinfo.cl_strength = Local then 
-	  (ops,ids_to_discard,work_alist)
-	else
-	  let (y1,y2) = process_class olddir ids_to_discard x in
-          ((Class (y1,y2))::ops, ids_to_discard, work_alist)
-	  
-    | "COERCION" -> 
-	let (_,coeinfo,_,_ as x) = outCoercion lobj in
-	if coercion_strength coeinfo = Local then
-	  (ops,ids_to_discard,work_alist)
-        else
-	  let y = process_coercion olddir ids_to_discard x in
-          ((Coercion y)::ops, ids_to_discard, work_alist)
-                    
-    | "STRUCTURE" ->
-	let ((kn,i),info) = outStruc lobj in
-	let newkn = recalc_kn newdir kn in
-	let strobj () =
-	  let mib = Environ.lookup_mind newkn (Global.env ()) in
-	  { s_CONST = info.s_CONST;
-	    s_PARAM = mib.mind_packets.(0).mind_nparams;
-	    s_PROJ = List.map (option_app (fun kn -> recalc_kn newdir kn)) info.s_PROJ } in
-	((Struc ((newkn,i),strobj))::ops, ids_to_discard, work_alist)
-
-    | "OBJDEF1" -> 
-	let kn = outObjDef1 lobj in
-	let new_kn = recalc_kn newdir kn in
-        ((Objdef new_kn)::ops, ids_to_discard, work_alist)
-
-    | "REQUIRE" -> 
-	let c = out_require lobj in
-	((Require c)::ops, ids_to_discard, work_alist)
-
-    | _ -> (ops,ids_to_discard,work_alist)
-
-let process_item oldenv olddir full_olddir newdir acc = function
-  | (sp,Leaf lobj) -> 
-      process_object oldenv olddir full_olddir newdir  acc (sp,lobj)
-  | (_,_) -> acc
-
-let process_operation = function
-  | Variable (id,expmod_a,stre,imp,discharged_hyps) ->
-      (* Warning:parentheses needed to get a side-effect from with_implicits *)
-      with_implicits imp (redeclare_variable id discharged_hyps)
-        (Lib.cwd(),expmod_a,stre)
-  | Constant (id,r,stre,kn,imp,discharged_hyps) ->
-      with_implicits imp (redeclare_constant id discharged_hyps) (r,stre);
-      constant_message id
-  | Inductive (mie,imp,discharged_hyps) ->
-      let _ = with_implicits imp (redeclare_inductive discharged_hyps) mie in
-      inductive_message mie.mind_entry_inds
-  | Class (y1,y2) ->
-      Lib.add_anonymous_leaf (inClass (y1,y2))
-  | Struc (newsp,strobj) ->
-      Lib.add_anonymous_leaf (inStruc (newsp,strobj ()))
-  | Objdef newsp ->
-      begin try Recordobj.objdef_declare (ConstRef newsp) with _ -> () end
-  | Coercion y -> add_new_coercion y
-  | Require y -> reload_library y
-  | Constraints y -> Global.add_constraints y
-
-let catch_not_found f x =
-  try f x
-  with Not_found ->
-    error ("Something is missing; perhaps a reference to a"^
-    " module required inside the section")
-
-let close_section _ s = 
-  let oldenv = Global.env() in
-  let prefix,decls,fs = close_section false s in
-  let full_olddir, (_,olddir) = prefix in
-  let newdir = fst (split_dirpath olddir) in
-  let (ops,ids,_) = 
-    List.fold_left 
-      (process_item oldenv olddir full_olddir newdir) ([],[],([],[],[])) decls 
-  in
-  let ids = last_section_hyps olddir in
-  Summary.section_unfreeze_summaries fs;
-  catch_not_found (List.iter process_operation) (List.rev ops);
-  Nametab.push_dir (Until 1) full_olddir (DirClosedSection full_olddir)
+      mib.mind_packets in
+  let sechyps' = map_named_context (expmod_constr modlist) sechyps in
+  let (params',inds') = abstract_inductive sechyps' nparams inds in
+  { mind_entry_record = mib.mind_record;
+    mind_entry_finite = mib.mind_finite;
+    mind_entry_params = params';
+    mind_entry_inds = inds' }
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
index c80b93ce..dcf88f31 100644
--- a/toplevel/discharge.mli
+++ b/toplevel/discharge.mli
@@ -6,13 +6,12 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: discharge.mli,v 1.6.16.1 2004/07/16 19:31:48 herbelin Exp $ i*)
+(*i $Id: discharge.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
 
-open Names
+open Sign
+open Cooking
+open Declarations
+open Entries
 
-(* This module implements the discharge mechanism. It provides a function to
-   close the last opened section. That function calls [Lib.close_section] and
-   then re-introduce all the discharged versions of the objects that were
-   defined in the section. *)
-
-val close_section : bool -> identifier -> unit
+val process_inductive : 
+  named_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry
diff --git a/toplevel/fhimsg.ml b/toplevel/fhimsg.ml
index b5185cd3..4ef5d5fd 100644
--- a/toplevel/fhimsg.ml
+++ b/toplevel/fhimsg.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: fhimsg.ml,v 1.19.2.1 2004/07/16 19:31:48 herbelin Exp $ *)
+(* $Id: fhimsg.ml 7837 2006-01-11 09:47:32Z herbelin $ *)
 
 open Pp
 open Util
@@ -231,7 +231,7 @@ let explain_ill_formed_rec_body k ctx err names i vdefs =
   | RecCallInCasePred c ->
       (str "Not allowed recursive call in the type of cases in")
   | NotGuardedForm c ->
-      str "Sub-expression " ++ prterm_env ctx c ++ spc() ++
+      str "Sub-expression " ++ pr_lconstr_env ctx c ++ spc() ++
       str "not in guarded form (should be a constructor, Cases or CoFix)"
 in
   let pvd = P.pr_term k ctx vdefs.(i) in
@@ -278,14 +278,7 @@ let explain_ml_case k ctx mes c ct br brt =
   hov 0 (str "In ML case expression on " ++ pc ++ ws 1 ++ cut () ++
            str "of type" ++  ws 1 ++ pct ++ ws 1 ++ cut () ++ 
            str "which is an inductive predicate." ++ fnl () ++ expln)
-(*
-let explain_cant_find_case_type loc k ctx c =
-  let pe = P.pr_term k ctx c in
-  Ast.user_err_loc
-    (loc,"pretype",
-     hov 3 (str "Cannot infer type of whole Case expression on" ++ 
-	     ws 1 ++ pe))
-*)
+
 let explain_type_error k ctx = function
   | UnboundRel n -> 
       explain_unbound_rel k ctx n
diff --git a/toplevel/fhimsg.mli b/toplevel/fhimsg.mli
index 10175e2a..1ab786d1 100644
--- a/toplevel/fhimsg.mli
+++ b/toplevel/fhimsg.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: fhimsg.mli,v 1.8.16.1 2004/07/16 19:31:48 herbelin Exp $ i*)
+(*i $Id: fhimsg.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Pp
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
index beb80d03..dc2cc8cd 100644
--- a/toplevel/himsg.ml
+++ b/toplevel/himsg.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: himsg.ml,v 1.86.2.4 2004/12/03 18:45:53 herbelin Exp $ *)
+(* $Id: himsg.ml 9528 2007-01-24 09:43:03Z herbelin $ *)
 
 open Pp
 open Util
@@ -21,18 +21,20 @@ open Sign
 open Environ
 open Pretype_errors
 open Type_errors
+open Indrec
 open Reduction
 open Cases
 open Logic
 open Printer
-open Ast
 open Rawterm
+open Evd
 
-let quote s = if !Options.v7 then s else h 0 (str "\"" ++ s ++ str "\"")
+let quote s = h 0 (str "\"" ++ s ++ str "\"")
 
-let prterm c = quote (prterm c)
-let prterm_env e c = quote (prterm_env e c)
-let prjudge_env e c = let v,t = prjudge_env e c in (quote v,quote t)
+let pr_lconstr c = quote (pr_lconstr c)
+let pr_lconstr_env e c = quote (pr_lconstr_env e c)
+let pr_lconstr_env_at_top e c = quote (pr_lconstr_env_at_top e c)
+let pr_ljudge_env e c = let v,t = pr_ljudge_env e c in (quote v,quote t)
 
 let nth i =
   let many = match i mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in
@@ -56,20 +58,20 @@ let explain_unbound_var ctx v =
 
 let explain_not_type ctx j =
   let pe = pr_ne_context_of (str"In environment") ctx in
-  let pc,pt = prjudge_env ctx j in
+  let pc,pt = pr_ljudge_env ctx j in
   pe ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++
   str"has type" ++ spc () ++ pt ++ spc () ++ 
   str"which should be Set, Prop or Type."
 
 let explain_bad_assumption ctx j =
   let pe = pr_ne_context_of (str"In environment") ctx in
-  let pc,pt = prjudge_env ctx j in
+  let pc,pt = pr_ljudge_env ctx j in
   pe ++ str "cannot declare a variable or hypothesis over the term" ++
   brk(1,1) ++ pc ++ spc () ++ str"of type" ++ spc () ++ pt ++ spc () ++
   str "because this term is not a type."
 
 let explain_reference_variables c =
-  let pc = prterm c in
+  let pc = pr_lconstr c in
   str "the constant" ++ spc () ++ pc ++ spc () ++ 
   str "refers to variables which are not in the context"
 
@@ -79,15 +81,14 @@ let rec pr_disjunction pr = function
   | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l
   | [] -> assert false
 
-let explain_elim_arity ctx ind aritylst c pj okinds = 
+let explain_elim_arity ctx ind sorts c pj okinds = 
   let ctx = make_all_name_different ctx in
   let pi = pr_inductive ctx ind in
-  let pc = prterm_env ctx c in
-  let ppt = prterm_env ctx pj.uj_type in
+  let pc = pr_lconstr_env ctx c in
   let msg = match okinds with
   | Some(kp,ki,explanation) ->
-      let pki = prterm_env ctx ki in
-      let pkp = prterm_env ctx kp in
+      let pki = pr_sort_family ki in
+      let pkp = pr_sort_family kp in
       let explanation =	match explanation with
 	| NonInformativeToInformative ->
           "proofs can be eliminated only to build proofs"
@@ -95,40 +96,29 @@ let explain_elim_arity ctx ind aritylst c pj okinds =
           "strong elimination on non-small inductive types leads to paradoxes."
 	| WrongArity ->
 	  "wrong arity" in
-	(hov 0 
-           (fnl () ++ str "Elimination of an inductive object of sort " ++
-            pki ++ brk(1,0) ++
-            str "is not allowed on a predicate in sort " ++ pkp  ++fnl () ++
-            str "because" ++ spc () ++ str explanation))
+      let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in
+      let ppt = pr_lconstr_env ctx (snd (decompose_prod_assum pj.uj_type)) in
+      hov 0 
+	(str "the return type has sort" ++ spc() ++ ppt ++ spc() ++ 
+	 str "while it" ++ spc() ++ str "should be " ++ ppar ++ str ".") ++ 
+      fnl() ++ 
+      hov 0
+	(str "Elimination of an inductive object of sort " ++
+	 pki ++ brk(1,0) ++
+         str "is not allowed on a predicate in sort " ++ pkp ++ fnl() ++
+         str "because" ++ spc() ++ str explanation ++ str ".")
   | None -> 
-      mt ()
+      str "ill-formed elimination predicate."
   in
   hov 0 (
-  str "Incorrect elimination of" ++ spc() ++ pc ++ spc () ++
-  str "in the inductive type " ++ spc() ++ quote pi ++ 
-  (if !Options.v7 then 
-    let pp = prterm_env ctx pj.uj_val in
-    let ppar = pr_disjunction (prterm_env ctx) aritylst in
-    let ppt = prterm_env ctx pj.uj_type in
-    fnl () ++
-    str "The elimination predicate"  ++ brk(1,1) ++ pp ++ spc () ++
-    str "has arity" ++ brk(1,1) ++ ppt ++ fnl () ++
-    str "It should be " ++ brk(1,1)  ++ ppar
-  else
-    let sorts = List.map (fun x -> mkSort (new_sort_in_family x))
-      (list_uniquize (List.map (fun ar ->
-      family_of_sort (destSort (snd (decompose_prod_assum ar)))) aritylst)) in
-    let ppar = pr_disjunction (prterm_env ctx) sorts in
-    let ppt = prterm_env ctx (snd (decompose_prod_assum pj.uj_type)) in
-    str "," ++ spc() ++ str "the return type has sort" ++ spc() ++ ppt ++ 
-    spc () ++ str "while it should be " ++ ppar))
-  ++ fnl () ++ msg
-    
-    
+    str "Incorrect elimination of" ++ spc() ++ pc ++ spc () ++
+    str "in the inductive type" ++ spc() ++ quote pi ++ str":") ++ 
+  fnl () ++ msg
+
 let explain_case_not_inductive ctx cj =
   let ctx = make_all_name_different ctx in
-  let pc = prterm_env ctx cj.uj_val in
-  let pct = prterm_env ctx cj.uj_type in
+  let pc = pr_lconstr_env ctx cj.uj_val in
+  let pct = pr_lconstr_env ctx cj.uj_type in
     match kind_of_term cj.uj_type with
       | Evar _ -> 
 	  str "Cannot infer a type for this expression"
@@ -139,26 +129,30 @@ let explain_case_not_inductive ctx cj =
 
 let explain_number_branches ctx cj expn =
   let ctx = make_all_name_different ctx in
-  let pc = prterm_env ctx cj.uj_val in
-  let pct = prterm_env ctx cj.uj_type in
+  let pc = pr_lconstr_env ctx cj.uj_val in
+  let pct = pr_lconstr_env ctx cj.uj_type in
   str "Matching on term" ++ brk(1,1) ++ pc ++ spc ()  ++
   str "of type" ++ brk(1,1) ++ pct ++ spc () ++
   str "expects " ++  int expn ++ str " branches"
 
+let ordinal n =
+  let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in
+  string_of_int n ^ s
+
 let explain_ill_formed_branch ctx c i actty expty =
   let ctx = make_all_name_different ctx in
-  let pc = prterm_env ctx c in
-  let pa = prterm_env ctx actty in
-  let pe = prterm_env ctx expty in
+  let pc = pr_lconstr_env ctx c in
+  let pa = pr_lconstr_env ctx actty in
+  let pe = pr_lconstr_env ctx expty in
   str "In pattern-matching on term" ++ brk(1,1) ++ pc ++
-  spc () ++ str "the branch "  ++ int (i+1) ++
-  str " has type" ++ brk(1,1) ++ pa  ++ spc () ++ 
+  spc () ++ str "the " ++ str (ordinal (i+1)) ++ str " branch has type" ++
+  brk(1,1) ++ pa ++ spc () ++ 
   str "which should be" ++ brk(1,1) ++ pe
 
 let explain_generalization ctx (name,var) j =
   let pe = pr_ne_context_of (str "In environment") ctx in
-  let pv = prtype_env ctx var in
-  let (pc,pt) = prjudge_env (push_rel_assum (name,var) ctx) j in
+  let pv = pr_ltype_env ctx var in
+  let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) ctx) j in
   str"Illegal generalization: " ++ pe ++
   str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
   str"over" ++ brk(1,1) ++ pc ++ str"," ++ spc () ++ 
@@ -167,17 +161,18 @@ let explain_generalization ctx (name,var) j =
 
 let explain_actual_type ctx j pt =
   let pe = pr_ne_context_of (str "In environment") ctx in
-  let (pc,pct) = prjudge_env ctx j in
-  let pt = prterm_env ctx pt in
+  let (pc,pct) = pr_ljudge_env ctx j in
+  let pt = pr_lconstr_env ctx pt in
   pe ++
   str "The term" ++ brk(1,1) ++ pc ++ spc ()  ++
   str "has type"  ++ brk(1,1) ++ pct ++ brk(1,1) ++ 
   str "while it is expected to have type" ++ brk(1,1) ++ pt
 
 let explain_cant_apply_bad_type ctx (n,exptyp,actualtyp) rator randl =
+  let ctx = make_all_name_different ctx in
   let randl = Array.to_list randl in
 (*  let pe = pr_ne_context_of (str"in environment") ctx in*)
-  let pr,prt = prjudge_env ctx rator in
+  let pr,prt = pr_ljudge_env ctx rator in
   let term_string1,term_string2 =
     if List.length randl > 1 then
       str "terms", (str"The "++nth n++str" term")
@@ -185,7 +180,7 @@ let explain_cant_apply_bad_type ctx (n,exptyp,actualtyp) rator randl =
       str "term", str "This term" in
   let appl = prlist_with_sep pr_fnl 
 	       (fun c ->
-		  let pc,pct = prjudge_env ctx c in
+		  let pc,pct = pr_ljudge_env ctx c in
 		  hov 2 (pc ++ spc () ++ str": "  ++ pct)) randl
   in
   str"Illegal application (Type Error): " ++ (* pe ++ *) fnl () ++
@@ -193,19 +188,20 @@ let explain_cant_apply_bad_type ctx (n,exptyp,actualtyp) rator randl =
   str"of type" ++ brk(1,1) ++ prt ++ spc ()  ++
   str"cannot be applied to the " ++ term_string1 ++ fnl () ++ 
   str" " ++ v 0 appl ++ fnl () ++ term_string2 ++ str" has type" ++
-  brk(1,1) ++ prterm_env ctx actualtyp ++ spc () ++
-  str"which should be coercible to" ++ brk(1,1) ++ prterm_env ctx exptyp
+  brk(1,1) ++ pr_lconstr_env ctx actualtyp ++ spc () ++
+  str"which should be coercible to" ++ brk(1,1) ++ pr_lconstr_env ctx exptyp
 
 let explain_cant_apply_not_functional ctx rator randl =
+  let ctx = make_all_name_different ctx in
   let randl = Array.to_list randl in
 (*  let pe = pr_ne_context_of (str"in environment") ctx in*)
-  let pr = prterm_env ctx rator.uj_val in
-  let prt = prterm_env ctx rator.uj_type in
+  let pr = pr_lconstr_env ctx rator.uj_val in
+  let prt = pr_lconstr_env ctx rator.uj_type in
   let term_string = if List.length randl > 1 then "terms" else "term" in
   let appl = prlist_with_sep pr_fnl 
 	       (fun c ->
-		  let pc = prterm_env ctx c.uj_val in
-		  let pct = prterm_env ctx c.uj_type in
+		  let pc = pr_lconstr_env ctx c.uj_val in
+		  let pct = pr_lconstr_env ctx c.uj_type in
 		  hov 2 (pc ++ spc () ++ str": "  ++ pct)) randl
   in
   str"Illegal application (Non-functional construction): " ++ 
@@ -216,17 +212,17 @@ let explain_cant_apply_not_functional ctx rator randl =
   str" " ++ v 0 appl
 
 let explain_unexpected_type ctx actual_type expected_type =
-  let pract = prterm_env ctx actual_type in
-  let prexp = prterm_env ctx expected_type in
+  let pract = pr_lconstr_env ctx actual_type in
+  let prexp = pr_lconstr_env ctx expected_type in
   str"This type is" ++ spc () ++ pract ++ spc () ++ 
   str "but is expected to be" ++
   spc () ++ prexp
 
 let explain_not_product ctx c =
-  let pr = prterm_env ctx c in
+  let pr = pr_lconstr_env ctx c in
   str"The type of this term is a product," ++ spc () ++
-  str"but it is casted with type" ++
-  brk(1,1) ++ pr
+  str"while it is expected to be" ++ 
+  if is_Type c then str " a sort" else (brk(1,1) ++ pr)
 
 (* TODO: use the names *)
 (* (co)fixpoints *)
@@ -241,8 +237,9 @@ let explain_ill_formed_rec_body ctx err names i =
   (* Fixpoint guard errors *)
   | NotEnoughAbstractionInFixBody ->
       str "Not enough abstractions in the definition"
-  | RecursionNotOnInductiveType ->
-      str "Recursive definition on a non inductive type"
+  | RecursionNotOnInductiveType c ->
+      str "Recursive definition on" ++ spc() ++ pr_lconstr_env ctx c ++ spc() ++
+      str "which should be an inductive type"
   | RecursionOnIllegalTerm(j,arg,le,lt) ->
       let called =
         match names.(j) with
@@ -262,7 +259,7 @@ let explain_ill_formed_rec_body ctx err names i =
               prlist_with_sep pr_spc (pr_db ctx) lt in
       str "Recursive call to " ++ called ++ spc() ++
       str "has principal argument equal to" ++ spc() ++
-      prterm_env ctx arg ++ fnl() ++ str "instead of " ++ vars
+      pr_lconstr_env ctx arg ++ fnl() ++ str "instead of " ++ vars
 
   | NotEnoughArgumentsForFixCall j ->
       let called =
@@ -273,31 +270,31 @@ let explain_ill_formed_rec_body ctx err names i =
 
   (* CoFixpoint guard errors *)
   | CodomainNotInductiveType c ->
-      str "the codomain is" ++ spc () ++ prterm_env ctx c ++ spc () ++
+      str "the codomain is" ++ spc () ++ pr_lconstr_env ctx c ++ spc () ++
       str "which should be a coinductive type"
   | NestedRecursiveOccurrences ->
       str "nested recursive occurrences"
   | UnguardedRecursiveCall c ->
-      str "unguarded recursive call in" ++ spc() ++ prterm_env ctx c
+      str "unguarded recursive call in" ++ spc() ++ pr_lconstr_env ctx c
   | RecCallInTypeOfAbstraction c ->
       str "recursive call forbidden in the domain of an abstraction:" ++
-      spc() ++ prterm_env ctx c
+      spc() ++ pr_lconstr_env ctx c
   | RecCallInNonRecArgOfConstructor c ->
       str "recursive call on a non-recursive argument of constructor" ++
-      spc() ++ prterm_env ctx c
+      spc() ++ pr_lconstr_env ctx c
   | RecCallInTypeOfDef c ->
       str "recursive call forbidden in the type of a recursive definition" ++
-      spc() ++ prterm_env ctx c
+      spc() ++ pr_lconstr_env ctx c
   | RecCallInCaseFun c ->
-      str "recursive call in a branch of" ++ spc() ++ prterm_env ctx c
+      str "recursive call in a branch of" ++ spc() ++ pr_lconstr_env ctx c
   | RecCallInCaseArg c -> 
       str "recursive call in the argument of cases in" ++ spc() ++
-      prterm_env ctx c
+      pr_lconstr_env ctx c
   | RecCallInCasePred c ->
       str "recursive call in the type of cases in" ++  spc() ++
-      prterm_env ctx c
+      pr_lconstr_env ctx c
   | NotGuardedForm c ->
-      str "sub-expression " ++ prterm_env ctx c ++ spc() ++
+      str "sub-expression " ++ pr_lconstr_env ctx c ++ spc() ++
       str "not in guarded form" ++ spc()++
       str"(should be a constructor, an abstraction, a match, a cofix or a recursive call)"
   in
@@ -307,8 +304,8 @@ let explain_ill_formed_rec_body ctx err names i =
 
 let explain_ill_typed_rec_body ctx i names vdefj vargs =
   let ctx = make_all_name_different ctx in
-  let pvd,pvdt = prjudge_env ctx (vdefj.(i)) in
-  let pv = prterm_env ctx vargs.(i) in
+  let pvd,pvdt = pr_ljudge_env ctx (vdefj.(i)) in
+  let pv = pr_lconstr_env ctx vargs.(i) in
   str"The "  ++
   (if Array.length vdefj = 1 then mt () else int (i+1) ++ str "-th") ++
   str"recursive definition"  ++ spc () ++ pvd ++ spc () ++
@@ -317,19 +314,19 @@ let explain_ill_typed_rec_body ctx i names vdefj vargs =
 (*
 let explain_not_inductive ctx c =
   let ctx = make_all_name_different ctx in
-  let pc = prterm_env ctx c in
+  let pc = pr_lconstr_env ctx c in
   str"The term" ++ brk(1,1) ++ pc ++ spc () ++
   str "is not an inductive definition"
 *)
 let explain_cant_find_case_type ctx c =
   let ctx = make_all_name_different ctx in
-  let pe = prterm_env ctx c in
+  let pe = pr_lconstr_env ctx c in
   hov 3 (str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe)
 
 let explain_occur_check ctx ev rhs =
   let ctx = make_all_name_different ctx in
   let id = Evd.string_of_existential ev in
-  let pt = prterm_env ctx rhs in
+  let pt = pr_lconstr_env ctx rhs in
   str"Occur check failed: tried to define " ++ str id ++
   str" with term" ++ brk(1,1) ++ pt
 
@@ -342,14 +339,10 @@ let explain_hole_kind env = function
   | BinderType Anonymous ->
       str "a type for this anonymous binder"
   | ImplicitArg (c,(n,ido)) ->
-      if !Options.v7 then
-	str "the " ++ pr_ord n ++
-	str " implicit argument of " ++ Nametab.pr_global_env Idset.empty c
-      else
-	let id = out_some ido in
-	str "an instance for the implicit parameter " ++
-	pr_id id ++ spc () ++ str "of" ++
-	spc () ++ Nametab.pr_global_env Idset.empty c
+      let id = out_some ido in
+      str "an instance for the implicit parameter " ++
+      pr_id id ++ spc () ++ str "of" ++
+      spc () ++ Nametab.pr_global_env Idset.empty c
   | InternalHole ->
       str "a term for an internal placeholder"
   | TomatchTypeParameter (tyi,n) ->
@@ -361,7 +354,7 @@ let explain_not_clean ctx ev t k =
   let ctx = make_all_name_different ctx in
   let c = mkRel (Intset.choose (free_rels t)) in
   let id = Evd.string_of_existential ev in
-  let var = prterm_env ctx c in
+  let var = pr_lconstr_env ctx c in
   str"Tried to define " ++ explain_hole_kind ctx k ++
   str" (" ++ str id ++ str ")" ++ spc() ++
   str"with a term using variable " ++ var ++ spc () ++
@@ -377,18 +370,44 @@ let explain_var_not_found ctx id =
   spc ()  ++ str "in the current" ++ spc ()  ++ str "environment"
 
 let explain_wrong_case_info ctx ind ci =
-  let ctx = make_all_name_different ctx in
-  let pi = prterm (mkInd ind) in
+  let pi = pr_lconstr (mkInd ind) in
   if ci.ci_ind = ind then
     str"Pattern-matching expression on an object of inductive" ++ spc () ++ pi ++
     spc () ++ str"has invalid information"
   else
-    let pc = prterm (mkInd ci.ci_ind) in
+    let pc = pr_lconstr (mkInd ci.ci_ind) in
     str"A term of inductive type" ++ spc () ++ pi ++ spc () ++
     str"was given to a pattern-matching expression on the inductive type" ++
     spc () ++ pc
        
 
+let explain_cannot_unify m n =
+  let pm = pr_lconstr m in 
+  let pn = pr_lconstr n in
+  str"Impossible to unify" ++ brk(1,1)  ++ pm ++ spc ()  ++
+  str"with" ++ brk(1,1)  ++ pn
+
+let explain_cannot_unify_local env m n subn =
+  let pm = pr_lconstr m in 
+  let pn = pr_lconstr n in
+  let psubn = pr_lconstr_env env subn in
+    str"Impossible to unify" ++ brk(1,1)  ++ pm ++ spc ()  ++
+      str"with" ++ brk(1,1)  ++ pn ++ spc() ++ str"as" ++ brk(1,1) ++ 
+      psubn ++ str" contains local variables"
+
+let explain_refiner_cannot_generalize ty =
+  str "Cannot find a well-typed generalisation of the goal with type : " ++ 
+  pr_lconstr ty
+
+let explain_no_occurrence_found c =
+  str "Found no subterm matching " ++ pr_lconstr c ++ str " in the current goal"
+
+let explain_cannot_unify_binding_type m n =
+  let pm = pr_lconstr m in 
+  let pn = pr_lconstr n in
+  str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++ 
+  str "which should be unifiable with" ++ brk(1,1) ++ pn
+
 let explain_type_error ctx err =
   let ctx = make_all_name_different ctx in
   match err with
@@ -445,93 +464,75 @@ let explain_pretype_error ctx err =
       explain_unexpected_type ctx actual expected
   | NotProduct c ->
       explain_not_product ctx c
+  | CannotUnify (m,n) -> explain_cannot_unify m n
+  | CannotUnifyLocal (e,m,n,sn) -> explain_cannot_unify_local e m n sn
+  | CannotGeneralize ty -> explain_refiner_cannot_generalize ty
+  | NoOccurrenceFound c -> explain_no_occurrence_found c
+  | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type m n
 
 (* Refiner errors *)
 
 let explain_refiner_bad_type arg ty conclty =
   str"refiner was given an argument" ++ brk(1,1) ++ 
-  prterm arg ++ spc () ++
-  str"of type" ++ brk(1,1) ++ prterm ty ++ spc () ++
-  str"instead of" ++ brk(1,1) ++ prterm conclty
+  pr_lconstr arg ++ spc () ++
+  str"of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++
+  str"instead of" ++ brk(1,1) ++ pr_lconstr conclty
 
 let explain_refiner_occur_meta t =
-  str"cannot refine with term" ++ brk(1,1) ++ prterm t ++
+  str"cannot refine with term" ++ brk(1,1) ++ pr_lconstr t ++
   spc () ++ str"because there are metavariables, and it is" ++
   spc () ++ str"neither an application nor a Case"
 
 let explain_refiner_occur_meta_goal t =
-  str"generated subgoal" ++ brk(1,1) ++ prterm t ++
+  str"generated subgoal" ++ brk(1,1) ++ pr_lconstr t ++
   spc () ++ str"has metavariables in it"
 
-let explain_refiner_cannot_applt t harg =
+let explain_refiner_cannot_apply t harg =
   str"in refiner, a term of type " ++ brk(1,1) ++
-  prterm t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++
-  prterm harg
-
-let explain_cannot_unify m n =
-  let pm = prterm m in 
-  let pn = prterm n in
-  str"Impossible to unify" ++ brk(1,1)  ++ pm ++ spc ()  ++
-  str"with" ++ brk(1,1)  ++ pn
-
-let explain_cannot_unify_binding_type m n =
-  let pm = prterm m in 
-  let pn = prterm n in
-  str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++ 
-  str "which should be unifiable with" ++ brk(1,1) ++ pn
-
-let explain_refiner_cannot_generalize ty =
-  str "Cannot find a well-typed generalisation of the goal with type : " ++ 
-  prterm ty
+  pr_lconstr t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++
+  pr_lconstr harg
 
 let explain_refiner_not_well_typed c =
-  str"The term "  ++ prterm c  ++ str" is not well-typed"
+  str"The term "  ++ pr_lconstr c  ++ str" is not well-typed"
 
 let explain_intro_needs_product () =
   str "Introduction tactics needs products"
 
 let explain_does_not_occur_in c hyp =
-  str "The term" ++ spc () ++ prterm c ++ spc () ++ str "does not occur in" ++ 
+  str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++ str "does not occur in" ++ 
   spc () ++ pr_id hyp
 
 let explain_non_linear_proof c =
-  str "cannot refine with term" ++ brk(1,1) ++ prterm c ++
+  str "cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++
   spc () ++ str"because a metavariable has several occurrences"
 
-let explain_no_occurrence_found c =
-  str "Found no subterm matching " ++ prterm c ++ str " in the current goal"
-
 let explain_refiner_error = function
   | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty
   | OccurMeta t -> explain_refiner_occur_meta t
   | OccurMetaGoal t -> explain_refiner_occur_meta_goal t
-  | CannotApply (t,harg) -> explain_refiner_cannot_applt t harg
-  | CannotUnify (m,n) -> explain_cannot_unify m n
-  | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type m n
-  | CannotGeneralize ty -> explain_refiner_cannot_generalize ty
+  | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg
   | NotWellTyped c -> explain_refiner_not_well_typed c
   | IntroNeedsProduct -> explain_intro_needs_product ()
   | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp
   | NonLinearProof c -> explain_non_linear_proof c
-  | NoOccurrenceFound c -> explain_no_occurrence_found c
 
 (* Inductive errors *)
 
 let error_non_strictly_positive env c v  =
-  let pc = prterm_env env c in
-  let pv = prterm_env env v in
+  let pc = pr_lconstr_env env c in
+  let pv = pr_lconstr_env env v in
   str "Non strictly positive occurrence of " ++ pv ++ str " in" ++
   brk(1,1) ++ pc
 
 let error_ill_formed_inductive env c v =
-  let pc = prterm_env env c in
-  let pv = prterm_env env v in
+  let pc = pr_lconstr_env env c in
+  let pv = pr_lconstr_env env v in
   str "Not enough arguments applied to the " ++ pv ++
   str " in" ++ brk(1,1) ++ pc
 
 let error_ill_formed_constructor env c v =
-  let pc = prterm_env env c in
-  let pv = prterm_env env v in
+  let pc = pr_lconstr_env env c in
+  let pv = pr_lconstr_env env v in
   str "The conclusion of" ++ brk(1,1) ++ pc ++ brk(1,1) ++ 
   str "is not valid;" ++ brk(1,1) ++ str "it must be built from " ++ pv
 
@@ -544,9 +545,9 @@ let str_of_nth n =
      | _ -> "th")
 
 let error_bad_ind_parameters env c n v1 v2  =
-  let pc = prterm_env_at_top env c in
-  let pv1 = prterm_env env v1 in
-  let pv2 = prterm_env env v2 in
+  let pc = pr_lconstr_env_at_top env c in
+  let pv1 = pr_lconstr_env env v1 in
+  let pv2 = pr_lconstr_env env v2 in
   str ("The "^(str_of_nth n)^" argument of ") ++ pv2 ++ brk(1,1) ++
   str "must be " ++ pv1 ++ str " in" ++ brk(1,1) ++ pc
 
@@ -572,21 +573,22 @@ let error_bad_entry () =
 
 let error_not_allowed_case_analysis dep kind i =
   str (if dep then "Dependent" else "Non Dependent") ++
-  str " case analysis on sort: " ++ print_sort kind ++ fnl () ++
+  str " case analysis on sort: " ++ pr_sort kind ++ fnl () ++
   str "is not allowed for inductive definition: " ++
   pr_inductive (Global.env()) i
 
 let error_bad_induction dep indid kind =
   str (if dep then "Dependent" else "Non dependent") ++
   str " induction for type " ++ pr_id indid ++
-  str " and sort " ++ print_sort kind ++ spc () ++
+  str " and sort " ++ pr_sort kind ++ spc () ++
   str "is not allowed"
 
 let error_not_mutual_in_scheme () =
- str "Induction schemes is concerned only with mutually inductive types"
+ str "Induction schemes are concerned only with distinct mutually inductive types"
+
+(* Inductive constructions errors *)
 
 let explain_inductive_error = function
-  (* These are errors related to inductive constructions *)
   | NonPos (env,c,v) -> error_non_strictly_positive env c v
   | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v
   | NotConstructor (env,c,v) -> error_ill_formed_constructor env c v
@@ -596,7 +598,10 @@ let explain_inductive_error = function
   | SameNamesOverlap idl -> error_same_names_overlap idl
   | NotAnArity id -> error_not_an_arity id
   | BadEntry -> error_bad_entry ()
-  (* These are errors related to recursors *)
+
+(* Recursion schemes errors *)
+
+let explain_recursion_scheme_error = function
   | NotAllowedCaseAnalysis (dep,k,i) ->
       error_not_allowed_case_analysis dep k i
   | BadInduction (dep,indid,kind) -> error_bad_induction dep indid kind
@@ -606,7 +611,7 @@ let explain_inductive_error = function
 
 let explain_bad_pattern ctx cstr ty = 
   let ctx = make_all_name_different ctx in
-  let pt = prterm_env ctx ty in
+  let pt = pr_lconstr_env ctx ty in
   let pc = pr_constructor ctx cstr in
   str "Found the constructor " ++ pc ++ brk(1,1) ++ 
   str "while matching a term of type " ++ pt ++ brk(1,1) ++ 
@@ -620,31 +625,38 @@ let explain_bad_constructor ctx cstr ind =
   str "while a constructor of "  ++ pi ++ brk(1,1)  ++
   str "is expected"
 
-let explain_wrong_numarg_of_constructor ctx cstr n =
-  let pc = pr_constructor ctx cstr in
-  str "The constructor " ++ pc ++ str " expects "  ++
-  (if n = 0 then str "no argument." else if n = 1 then str "1 argument."
-   else (int n  ++ str " arguments."))
+let decline_string n s =
+  if n = 0 then "no "^s
+  else if n = 1 then "1 "^s
+  else (string_of_int n^" "^s^"s")
+
+let explain_wrong_numarg_constructor ctx cstr n =
+  str "The constructor " ++ pr_constructor ctx cstr ++ 
+  str " expects "  ++ str (decline_string n "argument")
+
+let explain_wrong_numarg_inductive ctx ind n =
+  str "The inductive type " ++ pr_inductive ctx ind ++ 
+  str " expects "  ++ str (decline_string n "argument")
 
 let explain_wrong_predicate_arity ctx pred nondep_arity dep_arity=
   let ctx = make_all_name_different ctx in
-  let pp = prterm_env ctx pred in
+  let pp = pr_lconstr_env ctx pred in
   str "The elimination predicate " ++ spc () ++ pp ++ fnl () ++
   str "should be of arity"  ++ spc () ++
-  prterm_env ctx nondep_arity  ++ spc () ++ 
+  pr_lconstr_env ctx nondep_arity  ++ spc () ++ 
   str "(for non dependent case) or"  ++
-  spc () ++ prterm_env ctx dep_arity  ++ spc () ++ str "(for dependent case)."
+  spc () ++ pr_lconstr_env ctx dep_arity  ++ spc () ++ str "(for dependent case)."
 
 let explain_needs_inversion ctx x t =
   let ctx = make_all_name_different ctx in
-  let px = prterm_env ctx x in
-  let pt = prterm_env ctx t in
+  let px = pr_lconstr_env ctx x in
+  let pt = pr_lconstr_env ctx t in
   str "Sorry, I need inversion to compile pattern matching of term " ++
   px  ++ str " of type: " ++ pt
 
 let explain_unused_clause env pats =
-  let s = if List.length pats > 1 then "s" else "" in
 (* Without localisation
+  let s = if List.length pats > 1 then "s" else "" in
   (str ("Unused clause with pattern"^s) ++ spc () ++
     hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) ++ str ")")
 *)
@@ -659,7 +671,7 @@ let explain_cannot_infer_predicate ctx typs =
   let ctx = make_all_name_different ctx in
   let pr_branch (cstr,typ) =
     let cstr,_ = decompose_app cstr in
-    str "For " ++ prterm_env ctx cstr ++ str " : " ++ prterm_env ctx typ
+    str "For " ++ pr_lconstr_env ctx cstr ++ str " : " ++ pr_lconstr_env ctx typ
   in
   str "Unable to unify the types found in the branches:" ++
   spc () ++ hov 0 (prlist_with_sep pr_fnl pr_branch (Array.to_list typs))
@@ -670,7 +682,9 @@ let explain_pattern_matching_error env = function
   | BadConstructor (c,ind) ->
       explain_bad_constructor env c ind
   | WrongNumargConstructor (c,n) ->
-      explain_wrong_numarg_of_constructor env c n
+      explain_wrong_numarg_constructor env c n
+  | WrongNumargInductive (c,n) ->
+      explain_wrong_numarg_inductive env c n
   | WrongPredicateArity (pred,n,dep) ->
       explain_wrong_predicate_arity env pred n dep
   | NeedsInversion (x,t) ->
@@ -681,3 +695,9 @@ let explain_pattern_matching_error env = function
       explain_non_exhaustive env tms
   | CannotInferPredicate typs ->
       explain_cannot_infer_predicate env typs
+
+let explain_reduction_tactic_error = function
+  | Tacred.InvalidAbstraction (env,c,(env',e)) ->
+      str "The abstracted term" ++ spc() ++ pr_lconstr_env_at_top env c ++ 
+      spc() ++ str "is not well typed." ++ fnl () ++
+      explain_type_error env' e
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
index 3e7ba575..92fcafb7 100644
--- a/toplevel/himsg.mli
+++ b/toplevel/himsg.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: himsg.mli,v 1.13.14.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+(*i $Id: himsg.mli 8003 2006-02-07 22:11:50Z herbelin $ i*)
 
 (*i*)
 open Pp
@@ -15,6 +15,7 @@ open Indtypes
 open Environ
 open Type_errors
 open Pretype_errors
+open Indrec
 open Cases
 open Logic
 (*i*)
@@ -27,7 +28,12 @@ val explain_pretype_error : env -> pretype_error -> std_ppcmds
 
 val explain_inductive_error : inductive_error -> std_ppcmds
 
+val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds
+
 val explain_refiner_error : refiner_error -> std_ppcmds
 
 val explain_pattern_matching_error :
   env -> pattern_matching_error -> std_ppcmds
+
+val explain_reduction_tactic_error :
+  Tacred.reduction_tactic_error -> std_ppcmds
diff --git a/toplevel/line_oriented_parser.ml b/toplevel/line_oriented_parser.ml
index 81221196..77f5198a 100644
--- a/toplevel/line_oriented_parser.ml
+++ b/toplevel/line_oriented_parser.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: line_oriented_parser.ml,v 1.2.16.1 2004/07/16 19:31:49 herbelin Exp $ *)
+(* $Id: line_oriented_parser.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 let line_oriented_channel_to_option stop_string input_channel =
   let count = ref 0 in
diff --git a/toplevel/line_oriented_parser.mli b/toplevel/line_oriented_parser.mli
index 13af0e06..f37472c0 100644
--- a/toplevel/line_oriented_parser.mli
+++ b/toplevel/line_oriented_parser.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: line_oriented_parser.mli,v 1.3.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+(*i $Id: line_oriented_parser.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 val line_oriented_channel_to_option: string -> in_channel -> int -> char option
 
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
index 4c554209..3dcb1f58 100644
--- a/toplevel/metasyntax.ml
+++ b/toplevel/metasyntax.ml
@@ -6,120 +6,27 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: metasyntax.ml,v 1.105.2.12 2006/01/04 20:31:16 herbelin Exp $ *)
+(* $Id: metasyntax.ml 9333 2006-11-02 13:59:14Z barras $ *)
 
 open Pp
 open Util
 open Names
 open Topconstr
-open Coqast
-open Ast
 open Ppextend
 open Extend
-open Esyntax
 open Libobject
-open Library
 open Summary
 open Constrintern
 open Vernacexpr
 open Pcoq
 open Rawterm
 open Libnames
-
-let interp_global_rawconstr_with_vars vars c =
-  interp_rawconstr_gen false Evd.empty (Global.env()) false (vars,[]) c
-
-(**********************************************************************)
-(* Parsing via ast (used in Zsyntax) *)
-
-(* This updates default parsers for Grammar actions and Syntax *)
-(* patterns by inserting globalization *)
-(* Done here to get parsing/g_*.ml4 non dependent from kernel *)
-let constr_to_ast a =
-  Termast.ast_of_rawconstr (interp_rawconstr Evd.empty (Global.env()) a)
-
-(* This installs default quotations parsers to escape the ast parser *)
-(* "constr" is used by default in quotations found in the ast parser *) 
-let constr_parser_with_glob = Pcoq.map_entry constr_to_ast Constr.constr
-
-let _ = define_ast_quotation true "constr" constr_parser_with_glob
+open Lexer
+open Egrammar
+open Notation
 
 (**********************************************************************)
-(* Globalisation for constr_expr *)
-
-let globalize_ref vars ref =
-  match Constrintern.interp_reference (vars,[]) ref with
-  | RRef (loc,VarRef a) -> Ident (loc,a)
-  | RRef (loc,a) -> Qualid (loc,qualid_of_sp (Nametab.sp_of_global a))
-  | RVar (loc,x) -> Ident (loc,x)
-  | _ -> anomaly "globalize_ref: not a reference"
-
-let globalize_ref_term vars ref =
-  match Constrintern.interp_reference (vars,[]) ref with
-  | RRef (loc,VarRef a) -> CRef (Ident (loc,a))
-  | RRef (loc,a) -> CRef (Qualid (loc,qualid_of_sp (Nametab.sp_of_global a)))
-  | RVar (loc,x) -> CRef (Ident (loc,x))
-  | c -> Constrextern.extern_rawconstr Idset.empty c 
-
-let rec globalize_constr_expr vars = function
-  | CRef ref -> globalize_ref_term vars ref
-  | CAppExpl (_,(p,ref),l) ->
-      let f = 
-	map_constr_expr_with_binders globalize_constr_expr
-	  (fun x e -> e) vars
-      in
-      CAppExpl (dummy_loc,(p,globalize_ref vars ref), List.map f l)
-  | c ->
-      map_constr_expr_with_binders globalize_constr_expr (fun id e -> id::e)
-        vars c
-
-let without_translation f x =
-  let old = Options.do_translate () in
-  let oldv7 = !Options.v7 in
-  Options.make_translate false;
-  try let r = f x in Options.make_translate old; Options.v7:=oldv7; r
-  with e -> Options.make_translate old; Options.v7:=oldv7; raise e
-
-let _ = set_constr_globalizer
-  (fun vars e -> for_grammar (without_translation (globalize_constr_expr vars)) e)
-
-(**********************************************************************)
-(** For old ast printer *)
-
-(* Pretty-printer state summary *)
-let _ = 
-  declare_summary "syntax"
-    { freeze_function = Esyntax.freeze;
-      unfreeze_function = Esyntax.unfreeze;
-      init_function = Esyntax.init;
-      survive_module = false;
-      survive_section = false }
-
-(* Pretty-printing objects = syntax_entry *)
-let cache_syntax (_,ppobj) = Esyntax.add_ppobject ppobj
-
-let subst_syntax (_,subst,ppobj) = 
-  Extend.subst_syntax_command Ast.subst_astpat subst ppobj
-
-let (inPPSyntax,outPPSyntax) =
-  declare_object {(default_object "PPSYNTAX") with
-       open_function = (fun i o -> if i=1 then cache_syntax o);
-       cache_function = cache_syntax;
-       subst_function = subst_syntax;
-       classify_function = (fun (_,o) -> Substitute o);       
-       export_function = (fun x -> Some x) }
-
-(* Syntax extension functions (registered in the environnement) *)
-
-(* Checking the pretty-printing rules against free meta-variables.
- * Note that object are checked before they are added in the environment.
- * Syntax objects in compiled modules are not re-checked. *)
-
-let add_syntax_obj whatfor sel =
-(*  if not !Options.v7_only then*)
-  Lib.add_anonymous_leaf (inPPSyntax (interp_syntax_entry whatfor sel))
-
-(* Tokens *)
+(* Tokens                                                             *)
 
 let cache_token (_,s) = Pcoq.lexer.Token.using ("", s)
 
@@ -134,69 +41,40 @@ let (inToken, outToken) =
 let add_token_obj s = Lib.add_anonymous_leaf (inToken s)
 
 (**********************************************************************)
-(* Grammars (especially Tactic Notation) *)
+(* Tactic Notation                                                    *)
 
 let make_terminal_status = function
   | VTerm s -> Some s
   | VNonTerm _ -> None
 
-let qualified_nterm current_univ = function
-  | NtQual (univ, en) -> (univ, en)
-  | NtShort en -> (current_univ, en)
-
-let rec make_tags = function
-  | VTerm s :: l -> make_tags l
+let rec make_tags lev = function
+  | VTerm s :: l -> make_tags lev l
   | VNonTerm (loc, nt, po) :: l ->
-      let (u,nt) = qualified_nterm "tactic" nt in
-      let (etyp, _) = Egrammar.interp_entry_name u nt in
-      etyp :: make_tags l
+      let (etyp, _) = Egrammar.interp_entry_name lev nt in
+      etyp :: make_tags lev l
   | [] -> []
 
-let declare_pprule = function
-  (* Pretty-printing rules only for Grammar (Tactic Notation) *)
-  | Egrammar.TacticGrammar (_,pp) ->
-      let f (s,t,p) =
-        Pptactic.declare_extra_tactic_pprule true s (t,p);
-        Pptactic.declare_extra_tactic_pprule false s (t,p) in
-      List.iter f pp
-  | _ -> ()
+let cache_tactic_notation (_,(pa,pp)) =
+  Egrammar.extend_grammar (Egrammar.TacticGrammar pa);
+  Pptactic.declare_extra_tactic_pprule pp
 
-let cache_grammar (_,a) =
-  Egrammar.extend_grammar a;
-  declare_pprule a
+let subst_tactic_parule subst (key,n,p,(d,tac)) =
+  (key,n,p,(d,Tacinterp.subst_tactic subst tac))
 
-let subst_grammar (_,subst,a) =
-  Egrammar.subst_all_grammar_command subst a
+let subst_tactic_notation (_,subst,(pa,pp)) =
+  (subst_tactic_parule subst pa,pp)
 
-let (inGrammar, outGrammar) =
-  declare_object {(default_object "GRAMMAR") with
-       open_function = (fun i o -> if i=1 then cache_grammar o);
-       cache_function = cache_grammar;
-       subst_function = subst_grammar;
+let (inTacticGrammar, outTacticGrammar) =
+  declare_object {(default_object "TacticGrammar") with
+       open_function = (fun i o -> if i=1 then cache_tactic_notation o);
+       cache_function = cache_tactic_notation;
+       subst_function = subst_tactic_notation;
        classify_function = (fun (_,o) -> Substitute o);
        export_function = (fun x -> Some x)}
 
-(**********************************************************************)
-(* V7 Grammar                                                         *)
-
-open Genarg
-
-let check_entry_type (u,n) =
-  if u = "tactic" or u = "vernac" then error "tactic and vernac not supported";
-  match entry_type (get_univ u) n with
-    | None -> Pcoq.create_entry_if_new (get_univ u) n ConstrArgType
-    | Some (ConstrArgType | IdentArgType | RefArgType) -> ()
-    | _ -> error "Cannot arbitrarily extend non constr/ident/ref entries"
-
-let add_grammar_obj univ entryl =
-  let u = create_univ_if_new univ in
-  let g = interp_grammar_command univ check_entry_type entryl in
-  Lib.add_anonymous_leaf (inGrammar (Egrammar.Grammar g))
-
-(**********************************************************************)
-(* V8 Grammar *)
-
-(* Tactic notations *)
+let cons_production_parameter l = function
+  | VTerm _ -> l
+  | VNonTerm (_,_,ido) -> option_cons ido l
 
 let rec tactic_notation_key = function
   | VTerm id :: _ -> id
@@ -207,41 +85,51 @@ let rec next_key_away key t =
   if Pptactic.exists_extra_tactic_pprule key t then next_key_away (key^"'") t
   else key
 
-let locate_tactic_body dir (s,(s',prods as x),e) =
-  let tags = make_tags prods in
-  let s = if s="" then next_key_away (tactic_notation_key prods) tags else s in
-  (s,x,(dir,e)),(s,tags,(s',List.map make_terminal_status prods))
-
-let add_tactic_grammar g =
-  let dir = Lib.cwd () in
-  let pa,pp = List.split (List.map (locate_tactic_body dir) g) in
-  Lib.add_anonymous_leaf (inGrammar (Egrammar.TacticGrammar (pa,pp)))
-
-(* Printing grammar entries *)
+let add_tactic_notation (n,prods,e) =
+  let tags = make_tags n prods in
+  let key = next_key_away (tactic_notation_key prods) tags in
+  let pprule = (key,tags,(n,List.map make_terminal_status prods)) in
+  let ids = List.fold_left cons_production_parameter [] prods in
+  let tac = Tacinterp.glob_tactic_env ids (Global.env()) e in
+  let parule = (key,n,prods,(Lib.cwd(),tac)) in
+  Lib.add_anonymous_leaf (inTacticGrammar (parule,pprule))
 
-let print_grammar univ entry =
-  if !Options.v7 then
-    let u = get_univ univ in
-    let typ = explicitize_entry (fst u) entry in
-    let te,_,_ = get_constr_entry false typ in
-    Gram.Entry.print te
-  else
-    match entry with
-      | "constr" | "operconstr" | "binder_constr" ->
-	  msgnl (str "Entry constr is");
-	  Gram.Entry.print Pcoq.Constr.constr;
-	  msgnl (str "and lconstr is");
-	  Gram.Entry.print Pcoq.Constr.lconstr;
-	  msgnl (str "where binder_constr is");
-	  Gram.Entry.print Pcoq.Constr.binder_constr;
-	  msgnl (str "and operconstr is");
-	  Gram.Entry.print Pcoq.Constr.operconstr;
-      | "pattern" ->
-	  Gram.Entry.print Pcoq.Constr.pattern
-      | "tactic" -> 
-	  Gram.Entry.print Pcoq.Tactic.simple_tactic
-      | _ -> error "Unknown or unprintable grammar entry"
+(**********************************************************************)
+(* Printing grammar entries                                           *)
+
+let print_grammar univ = function
+  | "constr" | "operconstr" | "binder_constr" ->
+      msgnl (str "Entry constr is");
+      Gram.Entry.print Pcoq.Constr.constr;
+      msgnl (str "and lconstr is");
+      Gram.Entry.print Pcoq.Constr.lconstr;
+      msgnl (str "where binder_constr is");
+      Gram.Entry.print Pcoq.Constr.binder_constr;
+      msgnl (str "and operconstr is");
+      Gram.Entry.print Pcoq.Constr.operconstr;
+  | "pattern" ->
+      Gram.Entry.print Pcoq.Constr.pattern
+  | "tactic" -> 
+      msgnl (str "Entry tactic_expr is");
+      Gram.Entry.print Pcoq.Tactic.tactic_expr;
+      msgnl (str "Entry binder_tactic is");
+      Gram.Entry.print Pcoq.Tactic.binder_tactic;
+      msgnl (str "Entry simple_tactic is");
+      Gram.Entry.print Pcoq.Tactic.simple_tactic;
+  | "vernac" -> 
+      msgnl (str "Entry vernac is");
+      Gram.Entry.print Pcoq.Vernac_.vernac;
+      msgnl (str "Entry command is");
+      Gram.Entry.print Pcoq.Vernac_.command;
+      msgnl (str "Entry syntax is");
+      Gram.Entry.print Pcoq.Vernac_.syntax;
+      msgnl (str "Entry gallina is");
+      Gram.Entry.print Pcoq.Vernac_.gallina;
+      msgnl (str "Entry gallina_ext is");
+      Gram.Entry.print Pcoq.Vernac_.gallina_ext;
+  | _ -> error "Unknown or unprintable grammar entry"
 
+(**********************************************************************)
 (* Parse a format (every terminal starting with a letter or a single
    quote (except a single quote alone) must be quoted) *)
 
@@ -342,12 +230,12 @@ let parse_format (loc,str) =
     Stdpp.raise_with_loc loc e
 
 (***********************)
-(* Analysing notations *)
-
-open Symbols
+(* Analyzing notations *)
 
 type symbol_token = WhiteSpace of int | String of string
 
+(* Decompose the notation string into tokens *)
+
 let split_notation_string str =
   let push_token beg i l =
     if beg = i then l else
@@ -376,6 +264,43 @@ let split_notation_string str =
   in
   loop 0 0
 
+(* Interpret notations with a recursive component *)
+
+let rec find_pattern xl = function
+  | Break n as x :: l, Break n' :: l' when n=n' -> 
+      find_pattern (x::xl) (l,l')
+  | Terminal s as x :: l, Terminal s' :: l' when s = s' -> 
+      find_pattern (x::xl) (l,l')
+  | [NonTerminal x], NonTerminal x' :: l' ->
+      (x,x',xl),l'
+  | [NonTerminal _], Terminal s :: _ | Terminal s :: _, _ ->
+      error ("The token "^s^" occurs on one side of \"..\" but not on the other side")
+  | [NonTerminal _], Break s :: _ | Break s :: _, _ ->
+      error ("A break occurs on one side of \"..\" but not on the other side")
+  | ((SProdList _ | NonTerminal _) :: _ | []), _ -> 
+      error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\"")
+
+let rec interp_list_parser hd = function
+  | [] -> [], List.rev hd
+  | NonTerminal id :: tl when id = ldots_var ->
+      let ((x,y,sl),tl') = find_pattern [] (hd,tl) in
+      let yl,tl'' = interp_list_parser [] tl' in
+      (* We remember the second copy of each recursive part variable to *)
+      (* remove it afterwards *)
+      y::yl, SProdList (x,sl) :: tl''
+  | (Terminal _ | Break _) as s :: tl ->
+      if hd = [] then 
+        let yl,tl' = interp_list_parser [] tl in
+        yl, s :: tl'
+      else
+        interp_list_parser (s::hd) tl
+  | NonTerminal _ as x :: tl ->
+      let yl,tl' = interp_list_parser [x] tl in
+      yl, List.rev_append hd tl'
+  | SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser"
+
+(* Find non-terminal tokens of notation *)
+
 let unquote_notation_token s =
   let n = String.length s in
   if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s
@@ -410,38 +335,12 @@ let rec raw_analyse_notation_tokens = function
       let (vars,l) = raw_analyse_notation_tokens sl in
       (vars, Break n :: l)
 
-let rec find_pattern xl = function
-  | Break n as x :: l, Break n' :: l' when n=n' -> 
-      find_pattern (x::xl) (l,l')
-  | Terminal s as x :: l, Terminal s' :: l' when s = s' -> 
-      find_pattern (x::xl) (l,l')
-  | [NonTerminal x], NonTerminal x' :: l' ->
-      (x,x',xl),l'
-  | [NonTerminal _], Terminal s :: _ | Terminal s :: _, _ ->
-      error ("The token "^s^" occurs on one side of \"..\" but not on the other side")
-  | [NonTerminal _], Break s :: _ | Break s :: _, _ ->
-      error ("A break occurs on one side of \"..\" but not on the other side")
-  | ((SProdList _ | NonTerminal _) :: _ | []), _ -> 
-      error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\"")
-
-let rec interp_list_parser hd = function
-  | [] -> [], List.rev hd
-  | NonTerminal id :: tl when id = ldots_var ->
-      let ((x,y,sl),tl') = find_pattern [] (hd,tl) in
-      let yl,tl'' = interp_list_parser [] tl' in
-      (* We remember the second copy of each recursive part variable to *)
-      (* remove it afterwards *)
-      y::yl, SProdList (x,sl) :: tl''
-  | (Terminal _ | Break _) as s :: tl ->
-      if hd = [] then 
-        let yl,tl' = interp_list_parser [] tl in
-        yl, s :: tl'
-      else
-        interp_list_parser (s::hd) tl
-  | NonTerminal _ as x :: tl ->
-      let yl,tl' = interp_list_parser [x] tl in
-      yl, List.rev_append hd tl'
-  | SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser"
+let is_numeral symbs = 
+  match List.filter (function Break _ -> false | _ -> true) symbs with
+  | ([Terminal "-"; Terminal x] | [Terminal x]) ->
+      (try let _ = Bigint.of_string x in true with _ -> false)
+  | _ ->
+      false
 
 let analyse_notation_tokens l =
   let vars,l = raw_analyse_notation_tokens l in
@@ -450,7 +349,8 @@ let analyse_notation_tokens l =
 
 let remove_vars = List.fold_right List.remove_assoc
  
-(* Build the syntax and grammar rules *)
+(**********************************************************************)
+(* Build pretty-printing rules                                        *)
 
 type printing_precedence = int * parenRelation
 type parsing_precedence = int option
@@ -460,15 +360,10 @@ let prec_assoc = function
   | Gramext.LeftA -> (E,L)
   | Gramext.NonA -> (L,L)
 
-(* For old ast printer *)
-let meta_pattern m = Pmeta(m,Tany)
-
-type white_status = Juxtapose | Separate of int | NextIsTerminal
-
 let precedence_of_entry_type from = function
   | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n
-  | ETConstr (NumLevel n,BorderProd (left,Some a)) ->
-      n, let (lp,rp) = prec_assoc a in if left then lp else rp
+  | ETConstr (NumLevel n,BorderProd (b,Some a)) ->
+      n, let (lp,rp) = prec_assoc a in if b=Left then lp else rp
   | ETConstr (NumLevel n,InternalProd) -> n, Prec n
   | ETConstr (NextLevel,_) -> from, L
   | ETOther ("constr","annot") -> 10, Prec 10
@@ -506,57 +401,19 @@ let is_operator s =
    s.[0] = '-' or s.[0] = '/' or s.[0] = '<' or s.[0] = '>' or
    s.[0] = '@' or s.[0] = '\\' or s.[0] = '&' or s.[0] = '~')
 
-type previous_prod_status = NoBreak | CanBreak
+let is_prod_ident = function
+  | Terminal s when is_letter s.[0] or s.[0] = '_' -> true
+  | _ -> false
 
 let rec is_non_terminal = function
   | NonTerminal _ | SProdList _ -> true
   | _ -> false
 
-let add_break n l = UNP_BRK (n,1) :: l
-
-(* For old ast printer *)
-let make_hunks_ast symbols etyps from =
-  let rec make ws = function
-    | NonTerminal m :: prods ->
-	let _,lp = precedence_of_entry_type from (List.assoc m etyps) in
-	let u = PH (meta_pattern (string_of_id m), None, lp) in
-	if prods <> [] && is_non_terminal (List.hd prods) then
-	  u :: add_break 1 (make CanBreak prods)
-	else
-	  u :: make CanBreak prods
-
-    | Terminal s :: prods when List.exists is_non_terminal prods ->
-	let protect =
-	  is_letter s.[0] ||
-	  (is_non_terminal (List.hd prods) &&
-	    (is_letter (s.[String.length s -1])) ||
-	    (is_digit (s.[String.length s -1]))) in
-	if is_comma s || is_right_bracket s then
-	  RO s :: add_break 0 (make NoBreak prods)
-	else if (is_operator s || is_left_bracket s) && ws = CanBreak then
-	  add_break (if protect then 1 else 0)
-	    (RO (if protect then s^" " else s) :: make CanBreak prods)
-	else
-          if protect then
-            (if ws = CanBreak then add_break 1 else (fun x -> x))
-	    (RO (s^" ") :: make CanBreak prods)
-          else
-	    RO s :: make CanBreak prods
-
-    | Terminal s :: prods ->
-	RO s :: make NoBreak prods
-
-    | Break n :: prods ->
-	add_break n (make NoBreak prods)
-
-    | SProdList _ :: _ ->
-        anomaly "Recursive notations not supported in old syntax"
-
-    | [] -> []
+let add_break n l = UnpCut (PpBrk(n,0)) :: l
 
-  in make NoBreak symbols
+(* Heuristics for building default printing rules *)
 
-let add_break n l = UnpCut (PpBrk(n,0)) :: l
+type previous_prod_status = NoBreak | CanBreak
 
 let make_hunks etyps symbols from =
   let vars,typs = List.split etyps in
@@ -586,10 +443,11 @@ let make_hunks etyps symbols from =
 	  else 
 	    UnpTerminal s :: add_break 1 (make NoBreak prods)
 	else if is_ident_tail s.[String.length s - 1] then
+	  let sep = if is_prod_ident (List.hd prods) then "" else " " in
 	  if ws = CanBreak then
-	    add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods)
+	    add_break 1 (UnpTerminal (s^sep) :: make CanBreak prods)
 	  else
-	    UnpTerminal (s^" ") :: make CanBreak prods
+	    UnpTerminal (s^sep) :: make CanBreak prods
 	else if ws = CanBreak then
 	  add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods)
 	else
@@ -621,6 +479,8 @@ let make_hunks etyps symbols from =
 
   in make NoBreak symbols
 
+(* Build default printing rules from explicit format *)
+
 let error_format () = error "The format does not match the notation"
 
 let rec split_format_at_ldots hd = function
@@ -656,12 +516,12 @@ let read_recursive_format sl fmt =
   let slfmt, fmt = get_head fmt in
   slfmt, get_tail (slfmt, fmt)
 
-let hunks_of_format (from,(vars,typs) as vt) symfmt = 
+let hunks_of_format (from,(vars,typs)) symfmt = 
   let rec aux = function
   | symbs, (UnpTerminal s' as u) :: fmt
       when s' = String.make (String.length s') ' ' ->
       let symbs, l = aux (symbs,fmt) in symbs, u :: l
-  | Terminal s :: symbs, (UnpTerminal s' as u) :: fmt
+  | Terminal s :: symbs, (UnpTerminal s') :: fmt
       when s = unquote_notation_token s' ->
       let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l
   | NonTerminal s :: symbs, UnpTerminal s' :: fmt when s = id_of_string s' ->
@@ -689,36 +549,31 @@ let hunks_of_format (from,(vars,typs) as vt) symfmt =
   | [], l -> l
   | _ -> error_format ()
 
-let string_of_prec (n,p) =
-  (string_of_int n)^(match p with E -> "E" | L -> "L" | _ -> "")
+(**********************************************************************)
+(* Build parsing rules                                                *)
 
 let assoc_of_type n (_,typ) = precedence_of_entry_type n typ
 
-let string_of_assoc = function
-  | Some(Gramext.RightA) -> "RIGHTA"
-  | Some(Gramext.LeftA) | None -> "LEFTA"
-  | Some(Gramext.NonA) -> "NONA"
-
 let is_not_small_constr = function
     ETConstr _ -> true
   | ETOther("constr","binder_constr") -> true
   | _ -> false
 
-let rec define_keywords = function
+let rec define_keywords_aux = function
     NonTerm(_,Some(_,e)) as n1 :: Term("IDENT",k) :: l
-     when not !Options.v7 && is_not_small_constr e ->
+      when is_not_small_constr e ->
       prerr_endline ("Defining '"^k^"' as keyword");
       Lexer.add_token("",k);
-      n1 :: Term("",k) :: define_keywords l
-  | n :: l -> n :: define_keywords l
+      n1 :: Term("",k) :: define_keywords_aux l
+  | n :: l -> n :: define_keywords_aux l
   | [] -> []
 
 let define_keywords = function
-    Term("IDENT",k)::l when not !Options.v7 ->
+    Term("IDENT",k)::l ->
       prerr_endline ("Defining '"^k^"' as keyword");
       Lexer.add_token("",k);
-      Term("",k) :: define_keywords l
-  | l -> define_keywords l
+      Term("",k) :: define_keywords_aux l
+  | l -> define_keywords_aux l
 
 let make_production etyps symbols =
   let prod =
@@ -728,12 +583,12 @@ let make_production etyps symbols =
 	    let typ = List.assoc m etyps in
 	    NonTerm (typ, Some (m,typ)) :: l
         | Terminal s ->
-	    Term (Extend.terminal s) :: l
+	    Term (terminal s) :: l
         | Break _ ->
             l
         | SProdList (x,sl) ->
             let sl = List.flatten
-              (List.map (function Terminal s -> [Extend.terminal s] 
+              (List.map (function Terminal s -> [terminal s] 
                 | Break _ -> []
                 | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in
 	    let y = match List.assoc x etyps with
@@ -766,44 +621,8 @@ let recompute_assoc typs =
     | _, Some Gramext.RightA -> Some Gramext.RightA
     | _ -> None
 
-let make_grammar_rule n typs symbols ntn perm =
-  let assoc = recompute_assoc typs in
-  let prod = make_production typs symbols in
-  (n,assoc,ntn,prod, perm)
-
-(* For old ast printer *)
-let metas_of sl =
-  List.fold_right
-    (fun it metatl -> match it with
-      | NonTerminal m -> m::metatl
-      | _ -> metatl)
-    sl []
-
-(* For old ast printer *)
-let make_pattern symbols ast =
-  let env = List.map (fun m -> (string_of_id m,ETast)) (metas_of symbols) in
-  fst (to_pat env ast)
-
-(* For old ast printer *)
-let make_syntax_rule n name symbols typs ast ntn sc =
-  [{syn_id = name;
-    syn_prec = n;
-    syn_astpat = make_pattern symbols ast;
-    syn_hunks =
-      [UNP_SYMBOLIC(sc,ntn,UNP_BOX (PpHOVB 1,make_hunks_ast symbols typs n))]}]
-
-let make_pp_rule (n,typs,symbols,fmt) =
-  match fmt with
-    | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)]
-    | Some fmt -> 
-	[UnpBox (PpHOVB 0, 
-	 hunks_of_format (n,List.split typs) (symbols,parse_format fmt))]
-
 (**************************************************************************)
-(* Syntax extenstion: common parsing/printing rules and no interpretation *)
-
-(* v7 and translator : prec is for v7 (None if V8Notation), prec8 is for v8 *)
-(* v8 : prec is for v8, prec8 is the same *)
+(* Registration of syntax extensions (parsing/printing, no interpretation)*)
 
 let pr_arg_level from = function
   | (n,L) when n=from -> str "at next level"
@@ -813,66 +632,38 @@ let pr_arg_level from = function
   | (n,_) -> str "Unknown level"
 
 let pr_level ntn (from,args) =
-  let lopen = ntn.[0] = '_' and ropen = ntn.[String.length ntn - 1] = '_' in
-(*
-  let ppassoc, args = match args with
-    | [] -> mt (), []
-    | (nl,lpr)::l when nl=from & fst (list_last l)=from ->
-	let (_,rpr),l = list_sep_last l in
-	match lpr, snd (list_last l) with
-	  | L,E -> Gramext.RightA, l
-	  | E,L -> Gramext.LeftA, l
-	  | L,L -> Gramext.NoneA, l
-	  | _ -> args
-*)
   str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++
   prlist_with_sep pr_coma (pr_arg_level from) args
 
-(* In v8: prec = Some prec8 is for both parsing and printing *)
-(* In v7 and translator: 
-     prec is for parsing (None if V8Notation), 
-     prec8 for v8 printing (v7 printing is via ast) *)
-let cache_syntax_extension (_,(_,((prec,prec8),ntn,gr,se))) =
+let error_incompatible_level ntn oldprec prec =
+  errorlabstrm ""
+    (str ("Notation "^ntn^" is already defined") ++ spc() ++ 
+    pr_level ntn oldprec ++ 
+    spc() ++ str "while it is now required to be" ++ spc() ++ 
+    pr_level ntn prec)
+
+let cache_one_syntax_extension (prec,ntn,gr,pp) =
   try 
-    let oldprec, oldprec8 = Symbols.level_of_notation ntn in
-    if prec8 <> oldprec8 & (Options.do_translate () or not !Options.v7) then
-      errorlabstrm ""
-	(str ((if Options.do_translate () then "For new syntax, notation "
-	else "Notation ")
-	^ntn^" is already defined") ++ spc() ++ pr_level ntn oldprec8 ++ 
-	spc() ++ str "while it is now required to be" ++ spc() ++ 
-	pr_level ntn prec8)
-    else
-      (* Inconsistent v8 notations but not while translating; forget... *)
-      ();
-    (* V8 notations are consistent (from both translator or v8) *)
-    if prec <> None & !Options.v7 then begin
-      (* Update the V7 parsing rule *)
-      if oldprec <> None & out_some oldprec <> out_some prec then
-	(* None of them is V8Notation and they are different: warn *)
-	Options.if_verbose
-	  warning ("Notation "^ntn^
-	  " was already assigned a different level or sublevels");
-      if oldprec = None or out_some oldprec <> out_some prec then
-        Egrammar.extend_grammar (Egrammar.Notation (out_some prec,out_some gr))
-    end
+    let oldprec = Notation.level_of_notation ntn in
+    if prec <> oldprec then error_incompatible_level ntn oldprec prec
   with Not_found ->
     (* Reserve the notation level *)
-    Symbols.declare_notation_level ntn (prec,prec8);
+    Notation.declare_notation_level ntn prec;
     (* Declare the parsing rule *)
-    option_iter (fun gr -> 
-      Egrammar.extend_grammar (Egrammar.Notation (out_some prec,gr))) gr;
+    Egrammar.extend_grammar (Egrammar.Notation (prec,gr));
     (* Declare the printing rule *)
-    Symbols.declare_notation_printing_rule ntn (se,fst prec8)
+    Notation.declare_notation_printing_rule ntn (pp,fst prec)
+
+let cache_syntax_extension (_,(_,sy_rules)) =
+  List.iter cache_one_syntax_extension sy_rules
 
-let subst_notation_grammar subst x = x
+let subst_parsing_rule subst x = x
 
 let subst_printing_rule subst x = x
 
-let subst_syntax_extension (_,subst,(local,(prec,ntn,gr,se))) =
-  (local,(prec,ntn,
-   option_app (subst_notation_grammar subst) gr,
-   subst_printing_rule subst se))
+let subst_syntax_extension (_,subst,(local,sy)) =
+  (local, List.map (fun (prec,ntn,gr,pp) ->
+     (prec,ntn, subst_parsing_rule subst gr, subst_printing_rule subst pp)) sy)
 
 let classify_syntax_definition (_,(local,_ as o)) =
   if local then Dispose else Substitute o
@@ -888,6 +679,11 @@ let (inSyntaxExtension, outSyntaxExtension) =
        classify_function = classify_syntax_definition;
        export_function = export_syntax_definition}
 
+(**************************************************************************)
+(* Precedences                                                            *)
+
+(* Interpreting user-provided modifiers *)
+
 let interp_modifiers modl =
   let onlyparsing = ref false in
   let rec interp assoc level etyps format = function
@@ -896,23 +692,22 @@ let interp_modifiers modl =
     | SetEntryType (s,typ) :: l ->
 	let id = id_of_string s in
 	if List.mem_assoc id etyps then
-	  error (s^" is already assigned to an entry or constr level")
-	else interp assoc level ((id,typ)::etyps) format l
+	  error (s^" is already assigned to an entry or constr level");
+	interp assoc level ((id,typ)::etyps) format l
     | SetItemLevel ([],n) :: l ->
 	interp assoc level etyps format l
     | SetItemLevel (s::idl,n) :: l ->
 	let id = id_of_string s in
 	if List.mem_assoc id etyps then
-	  error (s^" is already assigned to an entry or constr level")
-	else
-	  let typ = ETConstr (n,()) in
-	  interp assoc level ((id,typ)::etyps) format (SetItemLevel (idl,n)::l)
+	  error (s^" is already assigned to an entry or constr level");
+	let typ = ETConstr (n,()) in
+	interp assoc level ((id,typ)::etyps) format (SetItemLevel (idl,n)::l)
     | SetLevel n :: l ->
-	if level <> None then error "A level is given more than once"
-	else interp assoc (Some n) etyps format l
+	if level <> None then error "A level is given more than once";
+	interp assoc (Some n) etyps format l
     | SetAssoc a :: l ->
-	if assoc <> None then error "An associativity is given more than once"
-	else interp (Some a) level etyps format l
+	if assoc <> None then error "An associativity is given more than once";
+	interp (Some a) level etyps format l
     | SetOnlyParsing :: l ->
 	onlyparsing := true;
 	interp assoc level etyps format l
@@ -921,21 +716,15 @@ let interp_modifiers modl =
 	interp assoc level etyps (Some s) l
   in interp None None [] None modl
 
-let merge_modifiers a n l =
-  (match a with None -> [] | Some a -> [SetAssoc a]) @
-  (match n with None -> [] | Some n -> [SetLevel n]) @ l
-
-let interp_infix_modifiers modl =
-  let (assoc,level,t,b,fmt) = interp_modifiers modl in
+let check_infix_modifiers modifiers =
+  let (assoc,level,t,b,fmt) = interp_modifiers modifiers in
   if t <> [] then
-    error "explicit entry level or type unexpected in infix notation";
-  (assoc,level,b,fmt)
+    error "explicit entry level or type unexpected in infix notation"
+
+let no_syntax_modifiers modifiers = 
+  modifiers = [] or modifiers = [SetOnlyParsing]
 
-(* 2nd list of types has priority *)
-let rec merge_entry_types etyps' = function
-  | [] -> etyps'
-  | (x,_ as e)::etyps ->
-      e :: merge_entry_types (List.remove_assoc x etyps') etyps
+(* Compute precedences from modifiers (or find default ones) *)
 
 let set_entry_type etyps (x,typ) =
   let typ = try 
@@ -948,7 +737,7 @@ let set_entry_type etyps (x,typ) =
     with Not_found -> ETConstr typ
   in (x,typ)
 
-let check_rule_reversibility l = 
+let check_rule_productivity l = 
   if List.for_all (function NonTerminal _ -> true | _ -> false) l then
     error "A notation must include at least one symbol"
 
@@ -956,17 +745,6 @@ let is_not_printable = function
   | AVar _ -> warning "This notation won't be used for printing as it is bound to a \nsingle variable"; true
   | _ -> false
 
-let find_precedence_v7 lev etyps symbols =
-  (match symbols with
-    | NonTerminal x :: _ ->
-	(try match List.assoc x etyps with
-	  | ETConstr _ ->
-	      error "The level of the leftmost non-terminal cannot be changed"
-	  | _ -> ()
-	with Not_found -> ())
-    | _ -> ());
-  if lev = None then 1 else out_some lev
-
 let find_precedence lev etyps symbols =
   match symbols with
   | NonTerminal x :: _ ->
@@ -1000,7 +778,7 @@ let find_precedence lev etyps symbols =
       out_some lev
 
 let check_curly_brackets_notation_exists () =
-  try let _ = Symbols.level_of_notation "{ _ }" in ()
+  try let _ = Notation.level_of_notation "{ _ }" in ()
   with Not_found -> 
     error "Notations involving patterns of the form \"{ _ }\" are treated \n\
 specially and require that the notation \"{ _ }\" is already reserved"
@@ -1028,95 +806,59 @@ let remove_curly_brackets l =
   | x :: l -> x :: aux false l
   in aux true l
 
-let compute_syntax_data forv7 (df,modifiers) =
+let compute_syntax_data (df,modifiers) =
   let (assoc,n,etyps,onlyparse,fmt) = interp_modifiers modifiers in
   (* Notation defaults to NONA *)
   let assoc = match assoc with None -> Some Gramext.NonA | a -> a in
   let toks = split_notation_string df in
   let (recvars,vars,symbols) = analyse_notation_tokens toks in
   let ntn_for_interp = make_notation_key symbols in
-  let symbols = remove_curly_brackets symbols in
-  let notation = make_notation_key symbols in
-  check_rule_reversibility symbols;
-  let n =
-    if !Options.v7 then find_precedence_v7 n etyps symbols
-    else find_precedence n etyps symbols in
-  let innerlevel = NumLevel (if forv7 then 10 else 200) in
+  let symbols' = remove_curly_brackets symbols in
+  let need_squash = (symbols <> symbols') in
+  let ntn_for_grammar = make_notation_key symbols' in
+  check_rule_productivity symbols';
+  let n = find_precedence n etyps symbols' in
+  let innerlevel = NumLevel 200 in
   let typs =
     find_symbols
-      (NumLevel n,BorderProd(true,assoc))
+      (NumLevel n,BorderProd(Left,assoc))
       (innerlevel,InternalProd)
-      (NumLevel n,BorderProd(false,assoc))
-      symbols in
+      (NumLevel n,BorderProd(Right,assoc))
+      symbols' in
   (* To globalize... *)
   let typs = List.map (set_entry_type etyps) typs in
-  let ppdata = (n,typs,symbols,fmt) in
   let prec = (n,List.map (assoc_of_type n) typs) in
-  ((onlyparse,recvars,vars,
-    ntn_for_interp,notation),prec,ppdata,(Lib.library_dp(),df))
-
-(* Uninterpreted (reserved) notations *)
-let add_syntax_extension local mv mv8 =
-  (* from v7: 
-       if mv8 <> None: tells the translator how to print in v8
-       if mv <> None: tells how to parse and, how to print in v7
-       mv = None = mv8 does not occur   
-     from v8 (mv8 is always None and mv is always Some)
-       mv tells how to parse and print in v8
-  *)
-  let data8 = option_app (compute_syntax_data false) mv8 in
-  let data = option_app (compute_syntax_data !Options.v7) mv in
-  let prec,gram_rule = match data with
-  | None -> None, None (* Case of V8Notation from v7 *)
-  | Some ((_,_,_,_,notation),prec,(n,typs,symbols,_),_) -> 
-      Some prec, Some (make_grammar_rule n typs symbols notation None) in
-  match data, data8 with
-  | None, None -> (* Nothing to do: V8Notation while not translating *) () 
-  | _, Some d | Some d, None ->
-    let ((_,_,_,_,ntn),ppprec,ppdata,_) = d in (* tells how to print *)
-    let ntn' = match data with Some ((_,_,_,_,ntn),_,_,_) -> ntn | _ -> ntn in
-    let pp_rule = make_pp_rule ppdata in
-    Lib.add_anonymous_leaf
-      (inSyntaxExtension (local,((prec,ppprec),ntn',gram_rule,pp_rule)))
+  let sy_data = (ntn_for_grammar,prec,need_squash,(n,typs,symbols',fmt)) in
+  let df' = (Lib.library_dp(),df) in
+  let i_data = (onlyparse,recvars,vars,(ntn_for_interp,df')) in
+  (i_data,sy_data)
 
 (**********************************************************************)
-(* Distfix, Infix, Symbols *)
-
-(* A notation comes with a grammar rule, a pretty-printing rule, an
-   identifiying pattern called notation and an associated scope *)
-let load_notation _ (_,(_,_,ntn,scope,pat,onlyparse,_,_)) =
-  option_iter Symbols.declare_scope scope
-
-let open_notation i (_,(_,oldse,ntn,scope,pat,onlyparse,pp8only,df)) =
-  if i=1 then begin
-    let b,oldpp8only = Symbols.exists_notation_in_scope scope ntn pat in
-    (* Declare the old printer rule and its interpretation *)
-    if (not b or oldpp8only) & oldse <> None then
-      Esyntax.add_ppobject {sc_univ="constr";sc_entries=out_some oldse};
+(* Registration of notations interpretation                            *)
+
+let load_notation _ (_,(_,scope,pat,onlyparse,_)) =
+  option_iter Notation.declare_scope scope
+
+let open_notation i (_,(_,scope,pat,onlyparse,(ntn,df))) =
+  if i=1 & not (Notation.exists_notation_in_scope scope ntn pat) then begin
     (* Declare the interpretation *)
-    if not b then
-      Symbols.declare_notation_interpretation ntn scope pat df pp8only;
-    if oldpp8only & not pp8only then
-      Options.silently 
-	(Symbols.declare_notation_interpretation ntn scope pat df) pp8only;
-    if not b & not onlyparse then
-      Symbols.declare_uninterpretation (NotationRule (scope,ntn)) pat
+    Notation.declare_notation_interpretation ntn scope pat df;
+    (* Declare the uninterpretation *)
+    if not onlyparse then
+      Notation.declare_uninterpretation (NotationRule (scope,ntn)) pat
   end
 
 let cache_notation o =
   load_notation 1 o;
   open_notation 1 o
 
-let subst_notation (_,subst,(lc,oldse,ntn,scope,(metas,pat),b,b',df)) =
-  (lc,option_app
-    (list_smartmap (Extend.subst_syntax_entry Ast.subst_astpat subst)) oldse,
-   ntn,scope,
-   (metas,subst_aconstr subst pat), b, b', df)
+let subst_notation (_,subst,(lc,scope,(metas,pat),b,ndf)) =
+  (lc,scope,(metas,subst_aconstr subst (List.map fst metas) pat),b,ndf)
 
-let classify_notation (_,(local,_,_,_,_,_,_,_ as o)) =
+let classify_notation (_,(local,_,_,_,_ as o)) =
   if local then Dispose else Substitute o
 
-let export_notation (local,_,_,_,_,_,_,_ as o) =
+let export_notation (local,_,_,_,_ as o) =
   if local then None else Some o
 
 let (inNotation, outNotation) =
@@ -1128,37 +870,8 @@ let (inNotation, outNotation) =
        classify_function = classify_notation;
        export_function = export_notation}
 
-(* For old ast printer *)
-let rec reify_meta_ast vars = function
-  | Smetalam (loc,s,body) -> Smetalam (loc,s,reify_meta_ast vars body)
-(*  | Node(loc,"META",[Num (_,n)]) -> Nmeta (loc,create_meta n)*)
-  | Node(loc,"ISEVAR",[]) -> Nmeta (loc,"$_")
-  | Node(loc,op,args) -> Node (loc,op, List.map (reify_meta_ast vars) args)
-  | Slam(loc,Some id,body) when List.mem id vars ->
-      Smetalam (loc,string_of_id id,reify_meta_ast vars body)
-  | Slam(loc,na,body) -> Slam(loc,na,reify_meta_ast vars body)
-  | Nvar (loc,id) when List.mem id vars -> Nmeta (loc,string_of_id id)
-  | Nmeta _ | Id _ | Nvar _ | Str _ | Num _ | Path _ as a -> a
-  | Dynamic _ as a -> (* Hum... what to do here *) a
-
-(* For old ast syntax *)
-let make_old_pp_rule n symbols typs r ntn scope vars =
-  let ast = Termast.ast_of_rawconstr r in
-  let ast = reify_meta_ast vars ast in
-  let scope_name = match scope with Some s -> s | None -> "core_scope" in
-  let rule_name = ntn^"_"^scope_name^"_notation" in
-  make_syntax_rule n rule_name symbols typs ast ntn scope
-
-(* maps positions in v8-notation into positions in v7-notation (used
-   for parsing).
-   For instance  Notation "x < y < z" := .. V8only "y < z < x"
-   yields [1; 2; 0] (y is the second arg in v7; z is 3rd; x is fst) *)
-let mk_permut vars7 vars8 =
-  if vars7=vars8 then None else
-    Some
-      (List.fold_right
-        (fun v8 subs -> list_index v8 vars7 - 1 :: subs)
-        vars8 [])
+(**********************************************************************)
+(* Recovering existing syntax                                         *)
 
 let contract_notation ntn =
   if ntn = "{ _ }" then ntn else
@@ -1173,304 +886,120 @@ let contract_notation ntn =
     else ntn in
   aux ntn 0
 
-let add_notation_in_scope local df c mods omodv8 scope =
-  let ((onlyparse,recs,vars,intnot,notation),prec,(n,typs,symbols,_ as ppdata),df')=
-    compute_syntax_data !Options.v7 (df,mods) in
-  (* Declare the parsing and printing rules if not already done *)
-    (* For both v7 and translate: parsing is as described for v7 in v7 file *)
-    (* For v8: parsing is as described in v8 file *)
-    (* For v7: printing is by the old printer - see below *)
-    (* For translate: printing is as described for v8 in v7 file *)
-    (* For v8: printing is as described in v8 file *)
-    (* In short: parsing does not depend on omodv8 *)
-    (* Printing depends on mv8 if defined, otherwise of mods (scaled by 10) *)
-    (* if in v7, or of mods without scaling if in v8 *)
-  let intnot,ntn,pprecvars,ppvars,ppprec,pp_rule =
-    match omodv8 with
-    | Some mv8 ->
-        let (_,recs8,vars8,intnot8,ntn8),p,d,_ = compute_syntax_data false mv8 in
-        intnot8,ntn8,recs8,vars8,p,make_pp_rule d
-    | None when not !Options.v7 -> 
-        intnot,notation,recs,vars,prec,make_pp_rule ppdata
-    | None ->
-	(* means the rule already exists: recover it *)
-        (* occurs only with V8only flag alone *)
-	try 
-          let ntn = contract_notation notation in
-	  let _, oldprec8 = Symbols.level_of_notation ntn in
-	  let rule,_ = Symbols.find_notation_printing_rule ntn in
-	  notation,ntn,recs,vars,oldprec8,rule
-	with Not_found -> error "No known parsing rule for this notation in V8"
-  in
-  let permut = mk_permut vars ppvars in
-  let gram_rule = make_grammar_rule n typs symbols ntn permut in
-  Lib.add_anonymous_leaf
-    (inSyntaxExtension
-      (local,((Some prec,ppprec),ntn,Some gram_rule,pp_rule)));
-
-  (* Declare interpretation *)
-  let (acvars,ac) = interp_aconstr [] ppvars c in
-  let a = (remove_vars pprecvars acvars,ac) (* For recursive parts *) in
-  let old_pp_rule =
-    (* Used only by v7; disable if contains a recursive pattern *)
-    if onlyparse or pprecvars <> [] or not (!Options.v7) then None
-    else
-      let r = interp_global_rawconstr_with_vars vars c in
-      Some (make_old_pp_rule n symbols typs r intnot scope vars) in
-  let onlyparse = onlyparse or !Options.v7_only or is_not_printable ac in
-  Lib.add_anonymous_leaf
-    (inNotation(local,old_pp_rule,intnot,scope,a,onlyparse,false,df'))
-
-let level_rule (n,p) = if p = E then n else max (n-1) 0
+exception NoSyntaxRule
 
-let recover_syntax ntn = 
+let recover_syntax ntn =
   try 
-    match Symbols.level_of_notation ntn with
-      | (Some prec,_ as pprec) -> 
-	  let rule,_ = Symbols.find_notation_printing_rule ntn in
-	  let gr = Egrammar.recover_notation_grammar ntn prec in
-	  Some (pprec,ntn,Some gr,rule)
-      | None,_ -> None
-  with Not_found -> None
+    let prec = Notation.level_of_notation ntn in
+    let pprule,_ = Notation.find_notation_printing_rule ntn in
+    let gr = Egrammar.recover_notation_grammar ntn prec in
+    (prec,ntn,gr,pprule)
+  with Not_found ->
+    raise NoSyntaxRule
+
+let recover_squash_syntax () = recover_syntax "{ _ }"
 
 let recover_notation_syntax rawntn =
   let ntn = contract_notation rawntn in
-  match recover_syntax ntn with
-    | None -> None
-    | Some gr -> Some (gr,if ntn=rawntn then None else recover_syntax "{ _ }")
-
-let set_data_for_v7_pp recs a vars =
-  if not !Options.v7 then None else
-    if recs=[] then Some (a,vars)
-    else (warning "No recursive notation in v7 syntax";None)
-
-let build_old_pp_rule notation scope symbs (r,vars) =
-  let prec = 
-    try
-      let a,_ = Symbols.level_of_notation (contract_notation notation) in
-      if a = None then raise Not_found else out_some a
-    with Not_found ->
-      error "Parsing rule for this notation has to be previously declared" in
-  let typs = List.map2 
-    (fun id n -> 
-      id,ETConstr (NumLevel (level_rule n),InternalProd)) vars (snd prec) in
-  make_old_pp_rule (fst prec) symbs typs r notation scope vars
-
-let add_notation_interpretation_core local symbs for_old df a scope onlyparse 
-  onlypp gram_data =
-  let notation = make_notation_key symbs in
-  let old_pp_rule = 
-    if !Options.v7 then 
-      option_app (build_old_pp_rule notation scope symbs) for_old
-    else None in
-  option_iter
-    (fun (x,y) ->
-      Lib.add_anonymous_leaf (inSyntaxExtension (local,x));
-      option_iter
-	(fun z -> Lib.add_anonymous_leaf (inSyntaxExtension (local,z))) y)
-    gram_data;
-  Lib.add_anonymous_leaf
-    (inNotation(local,old_pp_rule,notation,scope,a,onlyparse,onlypp,
-     (Lib.library_dp(),df)))
+  let sy_rule = recover_syntax ntn in
+  let need_squash = ntn<>rawntn in
+  if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule]
 
-let add_notation_interpretation df names c sc =
+(**********************************************************************)
+(* Main entry point for building parsing and printing rules           *)
+ 
+let make_pa_rule (n,typs,symbols,_) ntn =
+  let assoc = recompute_assoc typs in
+  let prod = make_production typs symbols in
+  (n,assoc,ntn,prod)
+
+let make_pp_rule (n,typs,symbols,fmt) =
+  match fmt with
+  | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)]
+  | Some fmt -> hunks_of_format (n,List.split typs) (symbols,parse_format fmt)
+
+let make_syntax_rules (ntn,prec,need_squash,sy_data) =
+  let pa_rule = make_pa_rule sy_data ntn in
+  let pp_rule = make_pp_rule sy_data in
+  let sy_rule = (prec,ntn,pa_rule,pp_rule) in
+  (* By construction, the rule for "{ _ }" is declared, but we need to
+     redeclare it because the file where it is declared needs not be open
+     when the current file opens (especially in presence of -nois) *)
+  if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule]
+
+(**********************************************************************)
+(* Main functions about notations                                     *)
+
+let add_notation_in_scope local df c mods scope =
+  let (i_data,sy_data) = compute_syntax_data (df,mods) in
+  (* Declare the parsing and printing rules *)
+  let sy_rules = make_syntax_rules sy_data in
+  Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules));
+  (* Declare interpretation *)
+  let (onlyparse,recvars,vars,df') = i_data in
+  let (acvars,ac) = interp_aconstr [] vars c in
+  let a = (remove_vars recvars acvars,ac) (* For recursive parts *) in
+  let onlyparse = onlyparse or is_not_printable ac in
+  Lib.add_anonymous_leaf (inNotation(local,scope,a,onlyparse,df'))
+
+let add_notation_interpretation_core local df names c scope onlyparse =
   let (recs,vars,symbs) = analyse_notation_tokens (split_notation_string df) in
-  let gram_data = recover_notation_syntax (make_notation_key symbs) in
-  if gram_data = None then
-    error "Parsing rule for this notation has to be previously declared";
+  (* Redeclare pa/pp rules *)
+  if not (is_numeral symbs) then begin
+    let sy_rules = recover_notation_syntax (make_notation_key symbs) in
+    Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules))
+  end;
+  (* Declare interpretation *)
+  let df' = (make_notation_key symbs,(Lib.library_dp(),df)) in
   let (acvars,ac) = interp_aconstr names vars c in
   let a = (remove_vars recs acvars,ac) (* For recursive parts *) in
-  let a_for_old = interp_rawconstr_with_implicits Evd.empty (Global.env()) vars names c in
-  let for_oldpp = set_data_for_v7_pp recs a_for_old vars in
-  let onlyparse = is_not_printable ac in
-  add_notation_interpretation_core false symbs for_oldpp df a sc onlyparse 
-    false gram_data
-
-let add_notation_in_scope_v8only local df c mv8 scope =
-  let (_,recs,vars,intnot,notation),prec,ppdata,df' = compute_syntax_data false (df,mv8) in
-  let pp_rule = make_pp_rule ppdata in
-  Lib.add_anonymous_leaf
-    (inSyntaxExtension(local,((None,prec),notation,None,pp_rule)));
-  (* Declare the interpretation *)
-  let (acvars,ac) = interp_aconstr [] vars c in
-  let a = (remove_vars recs acvars,ac) (* For recursive parts *) in
-  let onlyparse = is_not_printable ac in
-  Lib.add_anonymous_leaf
-    (inNotation(local,None,intnot,scope,a,onlyparse,true,df'))
+  let onlyparse = onlyparse or is_not_printable ac in
+  Lib.add_anonymous_leaf (inNotation(local,scope,a,onlyparse,df'))
 
-let add_notation_v8only local c (df,modifiers) sc =
-  let toks = split_notation_string df in
-  match toks with 
-    | [String x] when (modifiers = [] or modifiers = [SetOnlyParsing]) ->
-	(* This is a ident to be declared as a rule *)
-        add_notation_in_scope_v8only local df c (SetLevel 0::modifiers) sc
-    | _ ->
-	let (assoc,lev,typs,onlyparse,fmt) = interp_modifiers modifiers	in
-	match lev with
-	  | None->
-	      if modifiers <> [] & modifiers <> [SetOnlyParsing] then
-		error "Parsing rule for this notation includes no level"
-	      else
-	        (* Declare only interpretation *)
-		let (recs,vars,symbs) = analyse_notation_tokens toks in
-                let (acvars,ac) = interp_aconstr [] vars c in
-		let onlyparse = modifiers = [SetOnlyParsing] 
-                  or is_not_printable ac in
-                let a = (remove_vars recs acvars,ac) in
-		add_notation_interpretation_core local symbs None df a sc 
-		  onlyparse true None
-	  | Some n ->
-	    (* Declare both syntax and interpretation *)
-	      let mods =
-		if List.for_all (function SetAssoc _ -> false | _ -> true)
-		  modifiers 
-		then SetAssoc Gramext.NonA :: modifiers else modifiers in
-	      add_notation_in_scope_v8only local df c mods sc
-
-let is_quoted_ident x =
-  let x' = unquote_notation_token x in
-  x <> x' & try Lexer.check_ident x'; true with _ -> false
-
-(* v7: dfmod=None; mv8=Some: add only v8 printing rule *)
-(*     dfmod=Some: add v7 parsing rule; mv8=Some: add v8 printing rule *)
-(*     dfmod=Some; mv8=None: same v7-parsing and v8-printing rules *)
-(* v8: dfmod=Some; mv8=None: same v8 parsing and printing rules *)
-let add_notation local c dfmod mv8 sc =
-  match dfmod with
-  | None -> add_notation_v8only local c (out_some mv8) sc
-  | Some (df,modifiers) ->
-  let toks = split_notation_string df in
-  match toks with 
-    | [String x] when (modifiers = [] or modifiers = [SetOnlyParsing]) ->
-	(* This is a ident to be declared as a rule *)
-        add_notation_in_scope local df c (SetLevel 0::modifiers) mv8 sc
-    | _ ->
-	let (assoc,lev,typs,onlyparse,fmt) = interp_modifiers modifiers	in
-	match lev with
-	  | None->
-	      if modifiers <> [] & modifiers <> [SetOnlyParsing] then
-		error "Parsing rule for this notation includes no level"
-	      else
-	        (* Declare only interpretation *)
-		let (recs,vars,symbs) = analyse_notation_tokens toks in
-                let gram_data =
-		  recover_notation_syntax (make_notation_key symbs) in
-		if gram_data <> None then
-                  let (acvars,ac) = interp_aconstr [] vars c in
-                  let a = (remove_vars recs acvars,ac) in
-		  let onlyparse = modifiers = [SetOnlyParsing] 
-                    or is_not_printable ac in
-		  let a_for_old = interp_global_rawconstr_with_vars vars c in
-                  let for_old = set_data_for_v7_pp recs a_for_old vars in
-		  add_notation_interpretation_core local symbs for_old df a
-		    sc onlyparse false gram_data
-                else
-                  add_notation_in_scope local df c modifiers mv8 sc
-	  | Some n ->
-	    (* Declare both syntax and interpretation *)
-	    let assoc = match assoc with None -> Some Gramext.NonA | a -> a in
-            add_notation_in_scope local df c modifiers mv8 sc
-
-(* TODO add boxes information in the expression *)
+(* Notations without interpretation (Reserved Notation) *)
+
+let add_syntax_extension local mv =
+  let (_,sy_data) = compute_syntax_data mv in
+  let sy_rules = make_syntax_rules sy_data in
+  Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules))
+
+(* Notations with only interpretation *)
+
+let add_notation_interpretation df names c sc =
+  try add_notation_interpretation_core false df names c sc false
+  with NoSyntaxRule ->
+    error "Parsing rule for this notation has to be previously declared"
+
+(* Main entry point *)
+
+let add_notation local c (df,modifiers) sc =
+  if no_syntax_modifiers modifiers then
+    (* No syntax data: try to rely on a previously declared rule *)
+    let onlyparse = modifiers=[SetOnlyParsing] in
+    try add_notation_interpretation_core local df [] c sc onlyparse
+    with NoSyntaxRule ->
+      (* Try to determine a default syntax rule *)
+      add_notation_in_scope local df c modifiers sc
+  else
+    (* Declare both syntax and interpretation *)
+    add_notation_in_scope local df c modifiers sc
+
+(* Infix notations *)
 
 let inject_var x = CRef (Ident (dummy_loc, id_of_string x))
 
-let rec rename x vars n = function
-  | [] ->
-      (vars,[])
-  | String "_"::l ->
-      let (vars,l) = rename x vars (n+1) l in
-      let xn = x^(string_of_int n) in
-      ((inject_var xn)::vars,xn::l)
-  | String y::l ->
-      let (vars,l) = rename x vars n l in (vars,(quote_notation_token y)::l)
-  | WhiteSpace _::l ->
-      rename x vars n l
-
-let translate_distfix assoc df r = 
-  let (vars,l) = rename "x" [] 1 (split_notation_string df) in
-  let df = String.concat " " l in
-  let a = mkAppC (mkRefC r, vars) in
-  let assoc = match assoc with None -> Gramext.LeftA | Some a -> a in
-  (assoc,df,a)
-
-let add_distfix local assoc n df r sc =
-  (* "x" cannot clash since r is globalized (included section vars) *)
-  let (vars,l) = rename "x" [] 1 (split_notation_string df) in
-  let df = String.concat " " l in
-  let a = mkAppC (mkRefC r, vars) in
-  let assoc = match assoc with None -> Gramext.LeftA | Some a -> a in
-  add_notation_in_scope local df a [SetAssoc assoc;SetLevel n] None sc
-
-let make_infix_data n assoc modl mv8 =
-  (* Infix defaults to LEFTA in V7 (cf doc) *)
-  let mv = match n with None when !Options.v7 -> SetLevel 1 :: modl | _ -> modl in
-  let mv = match assoc with None when !Options.v7 -> SetAssoc Gramext.LeftA :: mv | _ -> mv in
-  let mv8 = match mv8 with
-      None -> None
-    | Some(s8,mv8) ->
-	if List.for_all (function SetLevel _ -> false | _ -> true) mv8 then
-	  error "Needs a level"
-	else Some (("x "^quote_notation_token s8^" y"),mv8) in
-  mv,mv8
-
-let add_infix local (inf,modl) pr mv8 sc =
-  if inf="" (* Code for V8Infix only *) then
-    let (p8,mv8) = out_some mv8 in
-    let (a8,n8,onlyparse,fmt) = interp_infix_modifiers mv8 in
-    let metas = [inject_var "x"; inject_var "y"] in
-    let a = mkAppC (mkRefC pr,metas) in
-    let df = "x "^(quote_notation_token p8)^" y" in
-    let toks = split_notation_string df in
-    if a8=None & n8=None & fmt=None then
-      (* Declare only interpretation *)
-      let (recs,vars,symbs) = analyse_notation_tokens toks in
-      let (acvars,ac) = interp_aconstr [] vars a in
-      let a' = (remove_vars recs acvars,ac) in
-      let a_for_old = interp_global_rawconstr_with_vars vars a in
-      add_notation_interpretation_core local symbs None df a' sc 
-	onlyparse true None
-    else
-      if n8 = None then error "Needs a level" else
-      let mv8 = match a8 with None -> SetAssoc Gramext.NonA :: mv8 |_ -> mv8 in
-      add_notation_in_scope_v8only local df a mv8 sc
-  else begin
-  let (assoc,n,onlyparse,fmt) = interp_infix_modifiers modl in
+let add_infix local (inf,modifiers) pr sc =
+  check_infix_modifiers modifiers;
   (* check the precedence *)
-  if !Options.v7 & (n<> None & (out_some n < 1 or out_some n > 10)) then
-    errorlabstrm "Metasyntax.infix_grammar_entry"
-      (str"Precedence must be between 1 and 10.");
-  (*
-  if (assoc<>None) & (n<6 or n>9) then
-    errorlabstrm "Vernacentries.infix_grammar_entry"
-      (str"Associativity Precedence must be 6,7,8 or 9.");
-  *)
   let metas = [inject_var "x"; inject_var "y"] in
-  let a = mkAppC (mkRefC pr,metas) in
+  let c = mkAppC (mkRefC pr,metas) in
   let df = "x "^(quote_notation_token inf)^" y" in
-  let toks = split_notation_string df in
-  if not !Options.v7 & n=None & assoc=None then
-    (* En v8, une notation sans information de parsing signifie *)
-    (* de ne déclarer que l'interprétation *)
-    (* Declare only interpretation *)
-    let (recs,vars,symbs) = analyse_notation_tokens toks in
-    let gram_data = recover_notation_syntax (make_notation_key symbs) in
-    if gram_data <> None then 
-      let (acvars,ac) = interp_aconstr [] vars a in
-      let a' = (remove_vars recs acvars,ac) in
-      let a_for_old = interp_global_rawconstr_with_vars vars a in
-      let for_old = set_data_for_v7_pp recs a_for_old vars in
-      add_notation_interpretation_core local symbs for_old df a' sc 
-        onlyparse false gram_data
-    else
-      let mv,mv8 = make_infix_data n assoc modl mv8 in
-      add_notation_in_scope local df a mv mv8 sc
-  else
-    let mv,mv8 = make_infix_data n assoc modl mv8 in
-    add_notation_in_scope local df a mv mv8 sc
-  end
+  add_notation local c (df,modifiers) sc
+
+(**********************************************************************)
+(* Miscellaneous                                                      *)
 
-let standardise_locatable_notation ntn =
+let standardize_locatable_notation ntn =
   let unquote = function
     | String s -> [unquote_notation_token s]
     | _ -> [] in
@@ -1480,17 +1009,19 @@ let standardise_locatable_notation ntn =
   else
     unquote_notation_token ntn
 
-(* Delimiters and classes bound to scopes *)
+(**********************************************************************)
+(* Delimiters and classes bound to scopes                             *)
+
 type scope_command = ScopeDelim of string | ScopeClasses of Classops.cl_typ
 
 let load_scope_command _ (_,(scope,dlm)) =
-  Symbols.declare_scope scope
+  Notation.declare_scope scope
 
 let open_scope_command i (_,(scope,o)) =
   if i=1 then
     match o with
-    | ScopeDelim dlm -> Symbols.declare_delimiters scope dlm
-    | ScopeClasses cl -> Symbols.declare_class_scope scope cl
+    | ScopeDelim dlm -> Notation.declare_delimiters scope dlm
+    | ScopeClasses cl -> Notation.declare_class_scope scope cl
 
 let cache_scope_command o =
   load_scope_command 1 o;
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
index be90cd7a..71522567 100644
--- a/toplevel/metasyntax.mli
+++ b/toplevel/metasyntax.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: metasyntax.mli,v 1.26.2.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+(*i $Id: metasyntax.mli 7732 2005-12-26 13:51:24Z herbelin $ i*)
 
 (*i*)
 open Util
@@ -15,49 +15,44 @@ open Ppextend
 open Extend
 open Tacexpr
 open Vernacexpr
-open Symbols
+open Notation
 open Topconstr
 (*i*)
 
-(* Adding grammar and pretty-printing objects in the environment *)
+val add_token_obj : string -> unit
 
-val add_syntax_obj : string -> raw_syntax_entry list -> unit
+(* Adding a tactic notation in the environment *)
 
-val add_grammar_obj : string -> raw_grammar_entry list -> unit
-val add_token_obj : string -> unit
-val add_tactic_grammar :
-  (string * (string * grammar_production list) * raw_tactic_expr) list -> unit
+val add_tactic_notation : 
+  int * grammar_production list * raw_tactic_expr -> unit
+
+(* Adding a (constr) notation in the environment*)
 
 val add_infix : locality_flag -> (string * syntax_modifier list) ->
-  reference -> (string * syntax_modifier list) option ->
-    scope_name option -> unit
-val add_distfix : locality_flag ->
-  grammar_associativity -> precedence -> string -> reference
-    -> scope_name option -> unit
-val translate_distfix : grammar_associativity -> string -> reference ->
-  Gramext.g_assoc * string * constr_expr
+  reference -> scope_name option -> unit
+
+val add_notation : locality_flag -> constr_expr ->
+  (string * syntax_modifier list) -> scope_name option -> unit
+
+(* Declaring delimiter keys and default scopes *)
 
 val add_delimiters : scope_name -> string -> unit
 val add_class_scope : scope_name -> Classops.cl_typ -> unit
 
-val add_notation : locality_flag -> constr_expr
-  -> (string * syntax_modifier list) option
-  -> (string * syntax_modifier list) option
-      -> scope_name option -> unit
+(* Add only the interpretation of a notation that already has pa/pp rules *)
 
-val add_notation_interpretation : string -> Constrintern.implicits_env
-  -> constr_expr -> scope_name option -> unit
+val add_notation_interpretation : string -> Constrintern.implicits_env ->
+  constr_expr -> scope_name option -> unit
 
-val add_syntax_extension : locality_flag
-  -> (string * syntax_modifier list) option
-  -> (string * syntax_modifier list) option -> unit
+(* Add only the parsing/printing rule of a notation *)
 
-val print_grammar : string -> string -> unit
+val add_syntax_extension : 
+  locality_flag -> (string * syntax_modifier list) -> unit
 
-val merge_modifiers : Gramext.g_assoc option -> int option -> 
-  syntax_modifier list -> syntax_modifier list
+(* Print the Camlp4 state of a grammar *)
+
+val print_grammar : string -> string -> unit
 
-val interp_infix_modifiers : syntax_modifier list ->
-  Gramext.g_assoc option * precedence option * bool * string located option
+(* Removes quotes in a notation *)
 
-val standardise_locatable_notation : string -> string
+val standardize_locatable_notation : string -> string
diff --git a/toplevel/minicoq.ml b/toplevel/minicoq.ml
index dcf3e307..a3b51a11 100644
--- a/toplevel/minicoq.ml
+++ b/toplevel/minicoq.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: minicoq.ml,v 1.28.14.1 2004/07/16 19:31:49 herbelin Exp $ *)
+(* $Id: minicoq.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
 
 open Pp
 open Util
@@ -54,7 +54,7 @@ let check c =
 
 let definition id ty c =
   let c = globalize [] c in
-  let ty = option_app (globalize []) ty in
+  let ty = option_map (globalize []) ty in
   let ce = { const_entry_body = c; const_entry_type = ty } in
   let sp = make_path [] id CCI in
   env := add_constant sp ce (locals()) !env;
diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4
index 4da23d42..4e6058be 100644
--- a/toplevel/mltop.ml4
+++ b/toplevel/mltop.ml4
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: mltop.ml4,v 1.29.2.3 2004/07/17 13:00:15 herbelin Exp $ *)
+(* $Id: mltop.ml4 9397 2006-11-21 21:50:54Z herbelin $ *)
 
 open Util
 open Pp
@@ -42,9 +42,8 @@ open Vernacinterp
 
 (* This path is where we look for .cmo *)
 let coq_mlpath_copy = ref ["."]
-let keep_copy_mlpath s = 
-  let dir = glob s in
-  coq_mlpath_copy := dir :: !coq_mlpath_copy
+let keep_copy_mlpath path = 
+  coq_mlpath_copy := path :: !coq_mlpath_copy
 
 (* If there is a toplevel under Coq *)
 type toplevel = { 
@@ -109,7 +108,7 @@ let dir_ml_load s =
 	    [Filename.dirname gname]
 	with | Dynlink.Error a ->
           errorlabstrm "Mltop.load_object" [< str (Dynlink.error_message a) >]
-      else () 
+      else ()
     | Native ->
 	errorlabstrm "Mltop.no_load_object"
           [< str"Loading of ML object file forbidden in a native Coq" >]
@@ -137,7 +136,7 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath =
   if exists_dir dir then
     begin
       add_ml_dir dir;
-      Library.add_load_path_entry (dir,coq_dirpath)
+      Library.add_load_path (dir,coq_dirpath)
     end
   else
     msg_warning [< str ("Cannot open " ^ dir) >]
@@ -160,7 +159,7 @@ let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath =
     let dirs = map_succeed convert_dirs dirs in
     begin
       List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs;
-      List.iter Library.add_load_path_entry dirs
+      List.iter Library.add_load_path dirs
     end
   else
     msg_warning [< str ("Cannot open " ^ dir) >]
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
index 6ba8cd76..b869f70b 100644
--- a/toplevel/mltop.mli
+++ b/toplevel/mltop.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: mltop.mli,v 1.8.14.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+(*i $Id: mltop.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* If there is a toplevel under Coq, it is described by the following 
    record. *)
diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml
index c748a12d..a9ff3326 100644
--- a/toplevel/protectedtoplevel.ml
+++ b/toplevel/protectedtoplevel.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: protectedtoplevel.ml,v 1.9.10.1 2004/07/16 19:31:49 herbelin Exp $ *)
+(* $Id: protectedtoplevel.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
 
 open Pp
 open Line_oriented_parser
diff --git a/toplevel/protectedtoplevel.mli b/toplevel/protectedtoplevel.mli
index b31afbf6..1d4ba9fc 100644
--- a/toplevel/protectedtoplevel.mli
+++ b/toplevel/protectedtoplevel.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: protectedtoplevel.mli,v 1.5.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+(*i $Id: protectedtoplevel.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Pp
diff --git a/toplevel/record.ml b/toplevel/record.ml
index 3a10c7e5..bf0271d9 100644
--- a/toplevel/record.ml
+++ b/toplevel/record.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: record.ml,v 1.52.2.2 2005/11/29 21:40:53 letouzey Exp $ *)
+(* $Id: record.ml 9082 2006-08-24 17:03:28Z herbelin $ *)
 
 open Pp
 open Util
@@ -20,7 +20,6 @@ open Declarations
 open Entries
 open Declare
 open Nametab
-open Coqast
 open Constrintern
 open Command
 open Inductive
@@ -37,31 +36,14 @@ let interp_decl sigma env = function
   | Vernacexpr.DefExpr((_,id),c,t) ->
       let c = match t with
 	| None -> c
-	| Some t -> mkCastC (c,t)
+	| Some t -> mkCastC (c, Rawterm.CastConv DEFAULTcast,t)
       in
-      let j = judgment_of_rawconstr Evd.empty env c in
+      let j = interp_constr_judgment Evd.empty env c in
       (id,Some j.uj_val, j.uj_type)
 
 let typecheck_params_and_fields ps fs =
   let env0 = Global.env () in
-  let env1,newps =
-    List.fold_left
-      (fun (env,newps) d -> match d with
-	| LocalRawAssum ([_,na],(CHole _ as t)) ->
-	    let t = interp_binder Evd.empty env na t in
-	    let d = (na,None,t) in
-	    (push_rel d env, d::newps)
-	| LocalRawAssum (nal,t) ->
-	    let t = interp_type Evd.empty env t in
-	    let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
-	    let ctx = List.rev ctx in
-	    (push_rel_context ctx env, ctx@newps)
-	| LocalRawDef ((_,na),c) ->
-	    let c = judgment_of_rawconstr Evd.empty env c in
-	    let d = (na, Some c.uj_val, c.uj_type) in
-	    (push_rel d env, d::newps))
-      (env0,[]) ps
-  in
+  let env1,newps = interp_context Evd.empty env0 ps in
   let env2,newfs =
     List.fold_left
       (fun (env,newfs) d ->
@@ -146,19 +128,20 @@ let subst_projection fid l c =
 let declare_projections indsp coers fields =
   let env = Global.env() in
   let (mib,mip) = Global.lookup_inductive indsp in
-  let paramdecls = mip.mind_params_ctxt in
+  let paramdecls = mib.mind_params_ctxt in
   let r = mkInd indsp in
   let rp = applist (r, extended_rel_list 0 paramdecls) in
   let paramargs = extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*)
   let x = Termops.named_hd (Global.env()) r Anonymous in
   let lifted_fields = lift_rel_context 1 fields in
-  let (_,sp_projs,_) =
+  let (_,kinds,sp_projs,_) =
     List.fold_left2
-      (fun (nfi,sp_projs,subst) coe (fi,optci,ti) ->
-	match fi with
-	| Anonymous ->
-	    (nfi-1, None::sp_projs,NoProjection fi::subst)
-	| Name fid ->
+      (fun (nfi,kinds,sp_projs,subst) coe (fi,optci,ti) ->
+	let (sp_projs,subst) =
+	  match fi with
+	  | Anonymous ->
+	      (None::sp_projs,NoProjection fi::subst)
+	  | Name fid ->
             try
               let ccl = subst_projection fid subst ti in
 	      let body = match optci with
@@ -176,38 +159,39 @@ let declare_projections indsp coers fields =
 	        it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in
               let projtyp =
                 it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in
-	      let (sp,kn) =
+	      let kn =
 	        try
 		  let cie = {
 		    const_entry_body = proj;
                     const_entry_type = Some projtyp;
-                    const_entry_opaque = false } in
-		  let k = (DefinitionEntry cie,IsDefinition) in
-		  let sp = declare_internal_constant fid k in
+                    const_entry_opaque = false;
+		    const_entry_boxed = Options.boxed_definitions() } in
+		  let k = (DefinitionEntry cie,IsDefinition StructureComponent) in
+		  let kn = declare_internal_constant fid k in
 		  Options.if_verbose message (string_of_id fid ^" is defined");
-		  sp
+		  kn
                 with Type_errors.TypeError (ctx,te) ->
                   raise (NotDefinable (BadTypedProj (fid,ctx,te))) in
 	      let refi = ConstRef kn in
 	      let constr_fi = mkConst kn in
 	      if coe then begin
-	        let cl = Class.class_of_ref (IndRef indsp) in
+	        let cl = Class.class_of_global (IndRef indsp) in
 	        Class.try_add_new_coercion_with_source refi Global cl
 	      end;
 	      let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in
 	      let constr_fip = applist (constr_fi,proj_args) in
-	      (nfi-1, (Some kn)::sp_projs, Projection constr_fip::subst)
+	      (Some kn::sp_projs, Projection constr_fip::subst)
             with NotDefinable why ->
 	      warning_or_error coe indsp why;
-	      (nfi-1, None::sp_projs,NoProjection fi::subst))
-      (List.length fields,[],[]) coers (List.rev fields)
-  in sp_projs
+	      (None::sp_projs,NoProjection fi::subst) in
+      (nfi-1,(optci=None)::kinds,sp_projs,subst))
+      (List.length fields,[],[],[]) coers (List.rev fields)
+  in (kinds,sp_projs)
 
 (* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean 
    list telling if the corresponding fields must me declared as coercion *)
 let definition_structure ((is_coe,(_,idstruc)),ps,cfs,idbuild,s) =
   let coers,fs = List.split cfs in
-  let nparams = local_binders_length ps in
   let extract_name acc = function
       Vernacexpr.AssumExpr((_,Name id),_) -> id::acc
     | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc
@@ -220,18 +204,18 @@ let definition_structure ((is_coe,(_,idstruc)),ps,cfs,idbuild,s) =
   let ind = applist (mkRel (1+List.length params+List.length fields), args) in
   let type_constructor = it_mkProd_or_LetIn ind fields in
   let mie_ind =
-    { mind_entry_params = List.map degenerate_decl params;
-      mind_entry_typename = idstruc;
+    { mind_entry_typename = idstruc;
       mind_entry_arity = mkSort s;
       mind_entry_consnames = [idbuild];
       mind_entry_lc = [type_constructor] } in
   let mie =
-    { mind_entry_record = true;
+    { mind_entry_params = List.map degenerate_decl params;
+      mind_entry_record = true;
       mind_entry_finite = true;
       mind_entry_inds = [mie_ind] } in
   let sp = declare_mutual_with_eliminations true mie in
   let rsp = (sp,0) in (* This is ind path of idstruc *)
-  let sp_projs = declare_projections rsp coers fields in
+  let kinds,sp_projs = declare_projections rsp coers fields in
   let build = ConstructRef (rsp,1) in (* This is construct path of idbuild *)
   if is_coe then Class.try_add_new_coercion build Global;
-  Recordops.add_new_struc (rsp,idbuild,nparams,List.rev sp_projs)
+  Recordops.declare_structure(rsp,idbuild,List.rev kinds,List.rev sp_projs)
diff --git a/toplevel/record.mli b/toplevel/record.mli
index 8eff2ed5..66282c20 100644
--- a/toplevel/record.mli
+++ b/toplevel/record.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: record.mli,v 1.16.2.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+(*i $Id: record.mli 6743 2005-02-18 22:14:08Z herbelin $ i*)
 
 (*i*)
 open Names
@@ -21,7 +21,7 @@ open Topconstr
    [coers]; it returns the absolute names of projections *)
 
 val declare_projections :
-  inductive -> bool list -> rel_context -> constant option list
+  inductive -> bool list -> rel_context -> bool list * constant option list
 
 val definition_structure :
   lident with_coercion * local_binder list *
diff --git a/toplevel/recordobj.ml b/toplevel/recordobj.ml
deleted file mode 100755
index d2a1e36e..00000000
--- a/toplevel/recordobj.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(************************************************************************)
-(*  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: recordobj.ml,v 1.12.2.1 2004/07/16 19:31:49 herbelin Exp $ *)
-
-open Util
-open Pp
-open Names
-open Libnames
-open Nameops
-open Term
-open Instantiate
-open Lib
-open Declare
-open Recordops
-open Classops
-open Nametab
-
-(*****  object definition ******)
- 
-let typ_lams_of t = 
-  let rec aux acc c = match kind_of_term c with
-    | Lambda (x,c1,c2) -> aux (c1::acc) c2
-    | Cast (c,_) -> aux acc c
-    | t -> acc,t
-  in aux [] t
-
-let objdef_err ref =
-  errorlabstrm "object_declare"
-    (pr_id (id_of_global ref) ++
-       str" is not a structure object")
-
-let objdef_declare ref =
-  let sp = match ref with ConstRef sp -> sp | _ -> objdef_err ref in
-  let env = Global.env () in
-  let v = constr_of_reference ref in
-  let vc = match Environ.constant_opt_value env sp with
-    | Some vc -> vc
-    | None -> objdef_err ref in
-  let lt,t = decompose_lam vc in
-  let lt = List.rev (List.map snd lt) in
-  let f,args = match kind_of_term t with
-    | App (f,args) -> f,args 
-    | _ -> objdef_err ref in
-  let { s_PARAM = p; s_PROJ = lpj } = 
-    try (find_structure
-	   (match kind_of_term f with
-              | Construct (indsp,1) -> indsp
-	      | _ -> objdef_err ref))
-    with Not_found -> objdef_err ref in
-  let params, projs =
-    try list_chop p (Array.to_list args)
-    with _ -> objdef_err ref in
-  let lps = 
-    try List.combine lpj projs 
-    with _ -> objdef_err ref in
-  let comp =
-    List.fold_left
-      (fun l (spopt,t) -> (* comp=components *)
-	 match spopt with
-	   | None -> l
-           | Some proji_sp ->
-	       let c, args = decompose_app t in
-	       try (ConstRef proji_sp, reference_of_constr c, args) :: l
-               with Not_found -> l)
-      [] lps in
-  add_anonymous_leaf (inObjDef1 sp);
-  List.iter
-    (fun (refi,c,argj) -> add_new_objdef ((refi,c),v,lt,params,argj))
-    comp
-
-let add_object_hook _ = objdef_declare
diff --git a/toplevel/recordobj.mli b/toplevel/recordobj.mli
deleted file mode 100755
index 91550c34..00000000
--- a/toplevel/recordobj.mli
+++ /dev/null
@@ -1,12 +0,0 @@
-(************************************************************************)
-(*  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: recordobj.mli,v 1.7.6.2 2005/01/21 17:18:33 herbelin Exp $ i*)
-
-val objdef_declare : Libnames.global_reference -> unit
-val add_object_hook : Tacexpr.declaration_hook
diff --git a/toplevel/searchisos.mli b/toplevel/searchisos.mli
index f1ad7d5a..184725b2 100644
--- a/toplevel/searchisos.mli
+++ b/toplevel/searchisos.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: searchisos.mli,v 1.3.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+(*i $Id: searchisos.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 val search_in_lib : bool ref
 val type_search : Term.constr -> unit
diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml
index 7fa80bcb..39106bbf 100644
--- a/toplevel/toplevel.ml
+++ b/toplevel/toplevel.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: toplevel.ml,v 1.22.2.2 2004/07/16 20:48:17 herbelin Exp $ *)
+(* $Id: toplevel.ml 9432 2006-12-12 09:07:36Z courtieu $ *)
 
 open Pp
 open Util
@@ -47,9 +47,17 @@ let resynch_buffer ibuf =
         ibuf.start <- ibuf.start + ll
     | _ -> ()
 
+
+(* emacs special character for prompt end (fast) detection. Prefer
+   (Char.chr 6) since it does not interfere with utf8. For
+    compatibility we let (Char.chr 249) as default for a while. *)
+
+let emacs_prompt_startstring() = Printer.emacs_str "" "<prompt>"
+
+let emacs_prompt_endstring() = Printer.emacs_str (String.make 1 (Char.chr 249)) "</prompt>"
+
 (* Read a char in an input channel, displaying a prompt at every
    beginning of line. *)
-
 let prompt_char ic ibuf count =
   let bol = match ibuf.bols with
     | ll::_ -> ibuf.len == ll
@@ -125,6 +133,7 @@ let print_highlight_location ib loc =
                       str sn ++ str dn) in 
 	  (l1 ++ li ++ ln)
   in 
+  let loc = make_loc (bp,ep) in
   (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ fnl () ++
      highlight_lines ++ fnl ())
 
@@ -182,11 +191,49 @@ let make_prompt () =
   with _ -> 
     "Coq < "
 
+(*let build_pending_list l = 
+  let pl = ref ">" in
+  let l' = ref l in
+  let res = 
+    while List.length !l' > 1 do 
+      pl := !pl ^ "|" Names.string_of_id x;
+      l':=List.tl !l'
+    done in
+  let last = try List.hd !l' with _ ->   in
+  "<"^l'
+*)    
+
+(* the coq prompt added to the default one when in emacs mode
+   The prompt contains the current state label [n] (for global
+   backtracking) and the current proof state [p] (for proof
+   backtracking) plus the list of open (nested) proofs (for proof
+   aborting when backtracking). It looks like:
+   
+   "n |lem1|lem2|lem3| p < "
+*)
+let make_emacs_prompt() =
+  let statnum = string_of_int (Lib.current_command_label ()) in
+  let dpth = Pfedit.current_proof_depth() in
+  let pending = Pfedit.get_all_proof_names() in
+  let pendingprompt = 
+    List.fold_left 
+      (fun acc x -> acc ^ (if acc <> "" then "|" else "") ^ Names.string_of_id x)
+      "" pending in
+  let proof_info = if dpth >= 0 then string_of_int dpth else "0" in
+(*   statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < " ^ (emacs_prompt_endstring()) *)
+  if !Options.print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < "
+  else ""
+
+
 (* A buffer to store the current command read on stdin. It is
  * initialized when a vernac command is immediately followed by "\n",
  * or after a Drop. *)
 let top_buffer =
-  let pr() = (make_prompt())^(emacs_str (String.make 1 (Char.chr 249)))
+  let pr() = 
+    emacs_prompt_startstring() 
+    ^ make_prompt() 
+    ^ make_emacs_prompt()
+    ^ emacs_prompt_endstring()
   in
   { prompt = pr;
     str = "";
@@ -197,7 +244,10 @@ let top_buffer =
 
 let set_prompt prompt =
   top_buffer.prompt
-  <- (fun () -> (prompt ()) ^ (emacs_str (String.make 1 (Char.chr 249))))
+  <- (fun () -> 
+    emacs_prompt_startstring()
+    ^ prompt ()
+    ^ emacs_prompt_endstring())
 
 (* Removes and prints the location of the error. The following exceptions
    need not be located. *)
diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli
index 1b6b48d4..f4d2e28a 100644
--- a/toplevel/toplevel.mli
+++ b/toplevel/toplevel.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: toplevel.mli,v 1.6.10.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+(*i $Id: toplevel.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Pp
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index b00cfffc..782fdc80 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: usage.ml,v 1.15.2.2 2004/09/03 14:35:26 herbelin Exp $ *)
+(* $Id: usage.ml 8932 2006-06-09 09:29:03Z notin $ *)
 
 let version () =
   Printf.printf "The Coq Proof Assistant, version %s (%s)\n"
@@ -54,6 +54,7 @@ let print_usage_channel co command =
   -boot                  boot mode (implies -q and -batch)
   -emacs                 tells Coq it is executed under Emacs
   -dump-glob f           dump globalizations in file f (to be used by coqdoc)
+  -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)
   -impredicative-set     set sort Set impredicative
   -dont-load-proofs      don't load opaque proofs in memory
   -xml                   export XML files either to the hierarchy rooted in
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
index 16929d68..97814fd2 100644
--- a/toplevel/usage.mli
+++ b/toplevel/usage.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: usage.mli,v 1.5.16.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+(*i $Id: usage.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*s Prints the version number on the standard output and exits (with 0). *)
 
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index a5716619..0bcf55a8 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernac.ml,v 1.59.2.3 2004/07/16 20:48:17 herbelin Exp $ *)
+(* $Id: vernac.ml 9397 2006-11-21 21:50:54Z herbelin $ *)
 
 (* Parsing of vernacular. *)
 
@@ -15,10 +15,9 @@ open Lexer
 open Util
 open Options
 open System
-open Coqast
 open Vernacexpr
 open Vernacinterp
-open Ppvernacnew
+open Ppvernac
 
 (* The functions in this module may raise (unexplainable!) exceptions.
    Use the module Coqtoplevel, which catches these exceptions
@@ -57,7 +56,7 @@ let real_error = function
    the file we parse seems a bit risky to me.  B.B.  *)
 
 let open_file_twice_if verbosely fname =
-  let _,longfname = find_file_in_path (Library.get_load_path ()) fname in
+  let _,longfname = find_file_in_path (Library.get_load_paths ()) fname in
   let in_chan = open_in longfname in
   let verb_ch = if verbosely then Some (open_in longfname) else None in
   let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in
@@ -95,62 +94,18 @@ let parse_phrase (po, verbch) =
 
 let just_parsing = ref false
 let chan_translate = ref stdout
-let last_char = ref '\000'
 
-(* postprocessor to avoid lexical icompatibilities between V7 and V8.
-   Ex: auto.(* comment *)  or  simpl.auto
- *)
 let set_formatter_translator() =
   let ch = !chan_translate in
-  let out s b e =
-    let n = e-b in
-    if n > 0 then begin
-      (match !last_char with
-          '.' -> 
-            (match s.[b] with
-                '('|'a'..'z'|'A'..'Z' -> output ch " " 0 1 
-              | _ -> ())
-        | _ -> ());
-      last_char := s.[e-1]
-    end;
-    output ch s b e
-  in
+  let out s b e = output ch s b e in
   Format.set_formatter_output_functions out (fun () -> flush ch);
   Format.set_max_boxes max_int
 
-let pre_printing = function
-  | VernacSolve (i,tac,deftac) when Options.do_translate () ->
-      (try
-        let (_,env) = Pfedit.get_goal_context i in
-        let t = Options.with_option Options.translate_syntax
-	  (Tacinterp.glob_tactic_env [] env) tac in
-        let pfts = Pfedit.get_pftreestate () in
-        let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in
-        Some (env,t,Pfedit.focus(),List.length gls)
-      with UserError _|Stdpp.Exc_located _ -> None)
-  | _ -> None
-
-let post_printing loc (env,t,f,n) = function
-  | VernacSolve (i,_,deftac) ->
-      let loc = unloc loc in
-      set_formatter_translator();
-      let pp = Ppvernacnew.pr_vernac_solve (i,env,t,deftac) ++ sep_end () in
-      (if !translate_file then begin
-	msg (hov 0 (comment (fst loc) ++ pp ++ comment (snd loc - 1)));
-      end
-      else
-	msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ pp)));
-      Format.set_formatter_out_channel stdout
-  | _ -> ()
-
 let pr_new_syntax loc ocom =
   let loc = unloc loc in
   if !translate_file then set_formatter_translator();
   let fs = States.freeze () in
   let com = match ocom with
-    | Some (VernacV7only _) ->
-        Options.v7_only := true;
-        mt()
     | Some VernacNop -> mt()
     | Some com -> pr_vernac com
     | None -> mt() in
@@ -159,13 +114,12 @@ let pr_new_syntax loc ocom =
   else
     msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
   States.unfreeze fs;
-  Constrintern.set_temporary_implicits_in [];
-  Constrextern.set_temporary_implicits_out [];
   Format.set_formatter_out_channel stdout
 
 let rec vernac_com interpfun (loc,com) =
   let rec interp = function
     | VernacLoad (verbosely, fname) ->
+	let fname = expand_path_macros fname in
         (* translator state *)
         let ch = !chan_translate in
         let cs = Lexer.com_state() in
@@ -173,27 +127,30 @@ let rec vernac_com interpfun (loc,com) =
         (* end translator state *)
         (* coqdoc state *)
         let cds = Constrintern.coqdoc_freeze() in
-        if !Options.translate_file then begin
-          let _,f = find_file_in_path (Library.get_load_path ())
-            (make_suffix fname ".v") in
-          chan_translate := open_out (f^"8");
-          Pp.comments := []
-        end;
-        begin try
-          read_vernac_file verbosely (make_suffix fname ".v");
-          if !Options.translate_file then close_out !chan_translate;
-          chan_translate := ch;
-          Lexer.restore_com_state cs;
-          Pp.comments := cl;
-          Constrintern.coqdoc_unfreeze cds;
-        with e ->
-          if !Options.translate_file then close_out !chan_translate;
-          chan_translate := ch;
-          Lexer.restore_com_state cs;
-          Pp.comments := cl;
-          Constrintern.coqdoc_unfreeze cds;
-          raise e end;
-
+          if !Options.translate_file then 
+	    begin
+              let _,f = find_file_in_path (Library.get_load_paths ())
+		(make_suffix fname ".v") in
+		chan_translate := open_out (f^"8");
+		Pp.comments := []
+            end;
+          begin 
+	    try
+	      read_vernac_file verbosely (make_suffix fname ".v");
+              if !Options.translate_file then close_out !chan_translate;
+              chan_translate := ch;
+              Lexer.restore_com_state cs;
+              Pp.comments := cl;
+              Constrintern.coqdoc_unfreeze cds
+	    with e -> 
+	      if !Options.translate_file then close_out !chan_translate;
+              chan_translate := ch;
+              Lexer.restore_com_state cs;
+              Pp.comments := cl;
+              Constrintern.coqdoc_unfreeze cds;
+	      raise e
+	  end
+	      
     | VernacList l -> List.iter (fun (_,v) -> interp v) l
 
     | VernacTime v ->
@@ -203,40 +160,15 @@ let rec vernac_com interpfun (loc,com) =
         msgnl (str"Finished transaction in " ++
                  System.fmt_time_difference tstart tend)
 
-    (* To be interpreted in v7 or translator input only *)
-    | VernacV7only v ->
-        Options.v7_only := true;
-        if !Options.v7 || Options.do_translate() then interp v;
-        Options.v7_only := false
-
-    (* To be interpreted in translator output only *)
-    | VernacV8only v -> 
-        if not !Options.v7 && not (do_translate()) then
-          interp v
-
     | v -> if not !just_parsing then interpfun v
 
   in 
-  try
-    Options.v7_only := false;
-    if do_translate () then
-      match pre_printing com with
-          None ->
-            pr_new_syntax loc (Some com);
-            interp com
-        | Some state ->
-            (try
-              interp com;
-              post_printing loc state com
-            with e ->
-              post_printing loc state com;
-              raise e)
-    else
+    try
+      if do_translate () then pr_new_syntax loc (Some com);
       interp com
-  with e -> 
-    Format.set_formatter_out_channel stdout;
-    Options.v7_only := false;
-    raise (DuringCommandInterp (loc, e))
+    with e -> 
+      Format.set_formatter_out_channel stdout;
+      raise (DuringCommandInterp (loc, e))
 
 and vernac interpfun input =
   vernac_com interpfun (parse_phrase input)
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index d8f4b247..4f95376f 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernac.mli,v 1.10.2.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+(*i $Id: vernac.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (* Parsing of vernacular. *)
 
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
index 1c6ad9a6..248e0106 100644
--- a/toplevel/vernacentries.ml
+++ b/toplevel/vernacentries.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacentries.ml,v 1.195.2.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+(*i $Id: vernacentries.ml 9481 2007-01-11 19:17:56Z herbelin $ i*)
 
 (* Concrete syntax of the mathematical vernacular MV V2.6 *)
 
@@ -20,9 +20,11 @@ open Term
 open Pfedit
 open Tacmach
 open Proof_trees
+open Decl_mode
 open Constrintern
 open Prettyp
 open Printer
+open Tactic_printer
 open Tacinterp
 open Command
 open Goptions
@@ -32,6 +34,7 @@ open Vernacexpr
 open Decl_kinds
 open Topconstr
 open Pretyping
+open Redexpr
 
 (* Pcoq hooks *)
 
@@ -55,14 +58,13 @@ let set_pcoq_hook f = pcoq := Some f
 let cl_of_qualid = function
   | FunClass -> Classops.CL_FUN
   | SortClass -> Classops.CL_SORT
-  | RefClass r -> Class.class_of_ref (Nametab.global r)
+  | RefClass r -> Class.class_of_global (Nametab.global r)
 
 (*******************)
 (* "Show" commands *)
 
 let show_proof () =
   let pts = get_pftreestate () in
-  let pf = proof_of_pftreestate pts in
   let cursor = cursor_of_pftreestate pts in
   let evc = evc_of_pftreestate pts in
   let (pfterm,meta_types) = extract_open_pftreestate pts in
@@ -70,78 +72,117 @@ let show_proof () =
     prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++
     str"Subgoals" ++ fnl () ++
     prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ 
-      prtype ty ++ fnl ())
+      pr_ltype ty ++ fnl ())
       meta_types
-    ++ str"Proof: " ++ prterm (Evarutil.nf_evar evc pfterm))
+    ++ str"Proof: " ++ pr_lconstr (Evarutil.nf_evar evc pfterm))
 
 let show_node () =
   let pts = get_pftreestate () in
   let pf = proof_of_pftreestate pts
   and cursor = cursor_of_pftreestate pts in
   msgnl (prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++
-         prgl (goal_of_proof pf) ++ fnl () ++
+         pr_goal (goal_of_proof pf) ++ fnl () ++
          (match pf.Proof_type.ref with
             | None -> (str"BY <rule>")
             | Some(r,spfl) ->
-		(str"BY " ++ Refiner.pr_rule r ++ fnl () ++
+		(str"BY " ++ pr_rule r ++ fnl () ++
 		 str"  " ++
-		   hov 0 (prlist_with_sep pr_fnl prgl
+		   hov 0 (prlist_with_sep pr_fnl pr_goal
 			    (List.map goal_of_proof spfl)))))
     
 let show_script () =
   let pts = get_pftreestate () in
   let pf = proof_of_pftreestate pts
   and evc = evc_of_pftreestate pts in
-  msgnl (Refiner.print_treescript true evc (Global.named_context()) pf)
+  msgnl (print_treescript true evc pf)
+
+let show_thesis () =
+     msgnl (anomaly "TODO" )
 
 let show_top_evars () =
   let pfts = get_pftreestate () in 
   let gls = top_goal_of_pftreestate pfts in 
   let sigma = project gls in 
-  msg (pr_evars_int 1 (Evd.non_instantiated sigma))
+  msg (pr_evars_int 1 (Evarutil.non_instantiated sigma))
 
 let show_prooftree () =
   let pts = get_pftreestate () in
   let pf = proof_of_pftreestate pts
   and evc = evc_of_pftreestate pts in
-  msg (Refiner.print_proof evc (Global.named_context()) pf)
+  msg (print_proof evc (Global.named_context()) pf)
 
 let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) ()
 
   (* Simulate the Intro(s) tactic *)
 
-let fresh_id_of_name avoid gl = function
-    Anonymous -> Tactics.fresh_id avoid (id_of_string "H") gl
-  | Name id   -> id
-
-let rec do_renum avoid gl = function
-    [] -> mt ()
-  | [n] -> pr_id (fresh_id_of_name avoid gl n)
-  | n :: l ->
-      let id = fresh_id_of_name avoid gl n in
-      pr_id id ++ spc () ++ do_renum (id :: avoid) gl l
-
 let show_intro all =
   let pf = get_pftreestate() in
   let gl = nth_goal_of_pftreestate 1 pf in
-  let l,_= decompose_prod (strip_outer_cast (pf_concl gl)) in
-  let nl = List.rev_map fst l in
-  if all then
-    msgnl (do_renum [] gl nl)
-  else
-    try 
-      let n = List.hd nl in
-      msgnl (pr_id (fresh_id_of_name [] gl n))
-    with Failure "hd" -> message "" 
+  let l,_= Sign.decompose_prod_assum (strip_outer_cast (pf_concl gl)) in
+  if all 
+  then 
+    let lid = Tactics.find_intro_names l gl in 
+    msgnl (hov 0 (prlist_with_sep  spc pr_id lid))
+  else  
+    try  
+      let n = list_last l in
+      msgnl (pr_id (List.hd (Tactics.find_intro_names [n] gl)))
+    with Failure "list_last" -> message ""
+
+let id_of_name = function 
+  | Names.Anonymous -> id_of_string "x" 
+  | Names.Name x -> x
+
+
+(* Building of match expression *)
+(* From ide/coq.ml *)
+let make_cases s = 
+  let qualified_name = Libnames.qualid_of_string s in
+  let glob_ref = Nametab.locate qualified_name in
+  match glob_ref with
+    | Libnames.IndRef i -> 
+	let {Declarations.mind_nparams = np}
+	    , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } 
+	      = Global.lookup_inductive i in
+	Util.array_fold_right2 
+	  (fun n t l ->  
+	     let (al,_) = Term.decompose_prod t in
+	     let al,_ = Util.list_chop (List.length al - np) al in
+	     let rec rename avoid = function 
+	       | [] -> []
+	       | (n,_)::l -> 
+		   let n' = Termops.next_global_ident_away true (id_of_name n) avoid in
+		   string_of_id n' :: rename (n'::avoid) l in
+	     let al' = rename [] (List.rev al) in
+	     (string_of_id n :: al') :: l)
+	  carr tarr []
+    | _ -> raise Not_found
+
+
+let show_match id = 
+  try
+    let s = string_of_id (snd id) in
+    let patterns = make_cases s in
+    let cases = 
+      List.fold_left 
+	(fun acc x -> 
+	  match x with
+	    | [] -> assert false
+	    | [x] -> "| "^ x  ^ " => \n" ^ acc
+	    | x::l -> 
+		"| (" ^ List.fold_left (fun acc s ->  acc ^ " " ^ s) x l ^ ")" 
+		^ " => \n" ^ acc)
+	"end" patterns in
+    msg (str ("match # with\n" ^ cases))
+  with Not_found -> error "Unknown inductive type"
 
-(********************)
 (* "Print" commands *)
 
 let print_path_entry (s,l) =
   (str s ++ str " " ++ tbrk (0,2) ++ str (string_of_dirpath l))
 
 let print_loadpath () =
-  let l = Library.get_full_load_path () in
+  let l = Library.get_full_load_paths () in
   msgnl (Pp.t (str "Physical path:                                 " ++
 		 tab () ++ str "Logical Path:" ++ fnl () ++ 
 		 prlist_with_sep pr_fnl print_path_entry l))
@@ -190,8 +231,7 @@ let dump_universes s =
 
 let locate_file f =
   try
-    let _,file =
-      System.where_in_path (Library.get_load_path()) f in
+    let _,file = System.where_in_path (Library.get_load_paths ()) f in
     msgnl (str file)
   with Not_found -> 
     msgnl (hov 0 (str"Can't find file" ++ spc () ++ str f ++ spc () ++
@@ -219,13 +259,22 @@ let print_located_library r =
   try msg_found_library (Library.locate_qualified_library qid)
   with e -> msg_notfound_library loc qid e
 
+let print_located_module r = 
+  let (loc,qid) = qualid_of_reference r in
+  let msg =
+    try 
+      let dir = Nametab.full_name_module qid in
+      str "Module " ++ pr_dirpath dir
+    with Not_found ->
+      (if fst (repr_qualid qid) = empty_dirpath then
+	str "No module is referred to by basename "
+      else 
+	str "No module is referred to by name ") ++ pr_qualid qid
+  in msgnl msg  
+
 (**********)
 (* Syntax *)
 
-let vernac_syntax = Metasyntax.add_syntax_obj
-
-let vernac_grammar = Metasyntax.add_grammar_obj
-
 let vernac_syntax_extension = Metasyntax.add_syntax_extension
 
 let vernac_delimiters = Metasyntax.add_delimiters
@@ -233,15 +282,13 @@ let vernac_delimiters = Metasyntax.add_delimiters
 let vernac_bind_scope sc cll = 
   List.iter (fun cl -> Metasyntax.add_class_scope sc (cl_of_qualid cl)) cll
 
-let vernac_open_close_scope = Symbols.open_close_scope
+let vernac_open_close_scope = Notation.open_close_scope
 
-let vernac_arguments_scope qid scl =
-  Symbols.declare_arguments_scope (global qid) scl
+let vernac_arguments_scope local qid scl =
+  Notation.declare_arguments_scope local (global qid) scl
 
 let vernac_infix = Metasyntax.add_infix
 
-let vernac_distfix = Metasyntax.add_distfix
-
 let vernac_notation = Metasyntax.add_notation
 
 (***********)
@@ -252,7 +299,7 @@ let start_proof_and_print idopt k t hook =
   print_subgoals ();
   if !pcoq <> None then (out_some !pcoq).start_proof ()
 
-let vernac_definition (local,_ as k) id def hook =
+let vernac_definition (local,_,_ as k) id def hook =
   match def with
   | ProveBody (bl,t) ->   (* local binders, typ *)
       if Lib.is_modtype () then
@@ -260,8 +307,7 @@ let vernac_definition (local,_ as k) id def hook =
 	  (str "Proof editing mode not supported in module types")
       else
 	let hook _ _ = () in
-        let kind = if local=Local then IsLocal else IsGlobal DefinitionBody in
-	  start_proof_and_print (Some id) kind (bl,t) hook
+	start_proof_and_print (Some id) (local,DefinitionBody Definition) (bl,t) hook
   | DefineBody (bl,red_option,c,typ_opt) ->
       let red_option = match red_option with
         | None -> None
@@ -278,12 +324,12 @@ let vernac_start_proof kind sopt (bl,t) lettop hook =
   if Lib.is_modtype () then
     errorlabstrm "Vernacentries.StartProof"
       (str "Proof editing mode not supported in module types");
-  start_proof_and_print sopt (IsGlobal (Proof kind)) (bl,t) hook
+  start_proof_and_print sopt (Global, Proof kind) (bl,t) hook
 
 let vernac_end_proof = function
   | Admitted -> admit ()
   | Proved (is_opaque,idopt) ->
-    if_verbose show_script ();
+    if not !Options.print_emacs then if_verbose show_script ();
     match idopt with
     | None -> save_named is_opaque
     | Some ((_,id),None) -> save_anonymous is_opaque id
@@ -293,9 +339,15 @@ let vernac_end_proof = function
      the theories [??] *)
 
 let vernac_exact_proof c =
-  by (Tactics.exact_proof c); 
-  save_named true
-
+  let pfs = top_of_tree (get_pftreestate()) in
+  let pf = proof_of_pftreestate pfs in
+    if (is_leaf_proof pf) then begin
+      by (Tactics.exact_proof c);
+      save_named true end
+    else
+      errorlabstrm "Vernacentries.ExactProof"
+	(str "Command 'Proof ...' can only be used at the beginning of the proof")
+  	
 let vernac_assumption kind l =
   List.iter (fun (is_coe,(idl,c)) -> declare_assumption idl is_coe kind [] c) l
 
@@ -310,107 +362,70 @@ let vernac_scheme = build_scheme
 (**********************)
 (* Modules            *)
 
-let vernac_declare_module id binders_ast mty_ast_o mexpr_ast_o = 
+let vernac_import export refl =
+  let import ref = Library.import_module export (qualid_of_reference ref) in
+  List.iter import refl;
+  Lib.add_frozen_state ()
+
+let vernac_declare_module export id binders_ast mty_ast_o = 
   (* We check the state of the system (in section, in module type)
      and what module information is supplied *)
   if Lib.sections_are_opened () then
     error "Modules and Module Types are not allowed inside sections";
-
-  if not (Lib.is_modtype ()) then
-    error "Declare Module allowed in module types only";
-
-  let constrain_mty = match mty_ast_o with
-      Some (_,true) -> true
-    | _ -> false
-  in
-
-  match mty_ast_o, constrain_mty, mexpr_ast_o with
-    | _, false, None ->  (* no ident, no/soft type *)
-	Declaremods.start_module Modintern.interp_modtype
-	  id binders_ast mty_ast_o;
-	if_verbose message 
-	  ("Interactive Declaration of Module "^ string_of_id id ^" started")
-	  
-    | Some _, true, None           (* no ident, hard type *)
-    | _, false, Some (CMEident _) ->  (* ident, no/soft type *)
-	Declaremods.declare_module 
-	  Modintern.interp_modtype Modintern.interp_modexpr
-	  id binders_ast mty_ast_o mexpr_ast_o;
-	if_verbose message 
-	  ("Module "^ string_of_id id ^" is declared")
-
-    | _, true, Some (CMEident _) -> (* ident, hard type *)
-	error "You cannot declare an equality and a type in module declaration"
-
-    | _, _, Some _ ->    (* not ident *)
-	error "Only simple modules allowed in module declarations"
-
-    | None,true,None -> assert false  (* 1st None ==> false *)
-
-let vernac_define_module id binders_ast mty_ast_o mexpr_ast_o = 
+  let binders_ast = List.map
+   (fun (export,idl,ty) ->
+     if export <> None then
+      error ("Arguments of a functor declaration cannot be exported. " ^
+       "Remove the \"Export\" and \"Import\" keywords from every functor " ^
+       "argument.")
+     else (idl,ty)) binders_ast in
+  Declaremods.declare_module 
+    Modintern.interp_modtype Modintern.interp_modexpr
+     id binders_ast (Some mty_ast_o) None;
+  if_verbose message ("Module "^ string_of_id id ^" is declared");
+  option_iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
+
+let vernac_define_module export id binders_ast mty_ast_o mexpr_ast_o = 
   (* We check the state of the system (in section, in module type)
      and what module information is supplied *)
   if Lib.sections_are_opened () then
     error "Modules and Module Types are not allowed inside sections";
- 
-  if Lib.is_modtype () then
-    error "Module definitions not allowed in module types. Use Declare Module instead";
-
   match mexpr_ast_o with
     | None ->
-	Declaremods.start_module Modintern.interp_modtype
+       let binders_ast,argsexport =
+        List.fold_right
+         (fun (export,idl,ty) (args,argsexport) ->
+           (idl,ty)::args, List.map (fun (_,i) -> export,i) idl) binders_ast
+             ([],[]) in
+	Declaremods.start_module Modintern.interp_modtype export
 	  id binders_ast mty_ast_o;
 	if_verbose message 
-	  ("Interactive Module "^ string_of_id id ^" started")
-	  
+	  ("Interactive Module "^ string_of_id id ^" started") ;
+        List.iter
+         (fun (export,id) ->
+           option_iter
+            (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
+         ) argsexport
     | Some _ ->
+       let binders_ast = List.map
+        (fun (export,idl,ty) ->
+          if export <> None then
+           error ("Arguments of a functor definition can be imported only if" ^
+                  " the definition is interactive. Remove the \"Export\" and " ^
+                  "\"Import\" keywords from every functor argument.")
+          else (idl,ty)) binders_ast in
 	Declaremods.declare_module 
 	  Modintern.interp_modtype Modintern.interp_modexpr
 	  id binders_ast mty_ast_o mexpr_ast_o;
 	if_verbose message 
-	  ("Module "^ string_of_id id ^" is defined")
-
-(* let vernac_declare_module id binders_ast mty_ast_o mexpr_ast_o =  *)
-(*   (\* We check the state of the system (in section, in module type) *)
-(*      and what module information is supplied *\) *)
-(*   if Lib.sections_are_opened () then *)
-(*     error "Modules and Module Types are not allowed inside sections"; *)
- 
-(*   let constrain_mty = match mty_ast_o with *)
-(*       Some (_,true) -> true *)
-(*     | _ -> false *)
-(*   in *)
-
-(*   match Lib.is_modtype (), mty_ast_o, constrain_mty, mexpr_ast_o with *)
-(*     | _, None, _, None  *)
-(*     | true, Some _, false, None *)
-(*     | false, _, _, None -> *)
-(* 	Declaremods.start_module Modintern.interp_modtype *)
-(* 	  id binders_ast mty_ast_o; *)
-(* 	if_verbose message  *)
-(* 	  ("Interactive Module "^ string_of_id id ^" started") *)
-	  
-(*     | true, Some _, true, None *)
-(*     | true, _, false, Some (CMEident _) *)
-(*     | false, _, _, Some _ -> *)
-(* 	Declaremods.declare_module  *)
-(* 	  Modintern.interp_modtype Modintern.interp_modexpr *)
-(* 	  id binders_ast mty_ast_o mexpr_ast_o; *)
-(* 	if_verbose message  *)
-(* 	  ("Module "^ string_of_id id ^" is defined") *)
-
-(*     | true, _, _, _ -> *)
-(* 	error "Module definition not allowed in a Module Type" *)
-
-let vernac_end_module id =
-  Declaremods.end_module id;
-  if_verbose message 
-    (if Lib.is_modtype () then 
-       "Module "^ string_of_id id ^" is declared"
-     else
-       "Module "^ string_of_id id ^" is defined")
+	  ("Module "^ string_of_id id ^" is defined");
+        option_iter (fun export -> vernac_import export [Ident (dummy_loc,id)])
+         export
 
-  
+let vernac_end_module export id =
+  Declaremods.end_module id;
+  if_verbose message ("Module "^ string_of_id id ^" is defined") ;
+  option_iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
 
 
 let vernac_declare_module_type id binders_ast mty_ast_o =
@@ -419,11 +434,28 @@ let vernac_declare_module_type id binders_ast mty_ast_o =
   
   match mty_ast_o with
     | None ->
+       let binders_ast,argsexport =
+        List.fold_right
+         (fun (export,idl,ty) (args,argsexport) ->
+           (idl,ty)::args, List.map (fun (_,i) -> export,i) idl) binders_ast
+             ([],[]) in
 	Declaremods.start_modtype Modintern.interp_modtype id binders_ast;
 	if_verbose message 
-	  ("Interactive Module Type "^ string_of_id id ^" started")
+	  ("Interactive Module Type "^ string_of_id id ^" started");
+        List.iter
+         (fun (export,id) ->
+           option_iter
+            (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
+         ) argsexport
 	  
     | Some base_mty ->
+       let binders_ast = List.map
+        (fun (export,idl,ty) ->
+          if export <> None then
+           error ("Arguments of a functor definition can be imported only if" ^
+                  " the definition is interactive. Remove the \"Export\" " ^
+                  "and \"Import\" keywords from every functor argument.")
+          else (idl,ty)) binders_ast in
 	Declaremods.declare_modtype Modintern.interp_modtype 
 	  id binders_ast base_mty;
 	if_verbose message 
@@ -455,86 +487,25 @@ let vernac_record struc binders sort nameopt cfs =
 
   (* Sections *)
 
-let vernac_begin_section id = let _ = Lib.open_section id in ()
-
-let vernac_end_section id =
-  Discharge.close_section (is_verbose ()) id
-
+let vernac_begin_section = Lib.open_section
+let vernac_end_section = Lib.close_section
 
 let vernac_end_segment id =
   check_no_pending_proofs ();
-  try
-    match Lib.what_is_opened () with
-      | _,Lib.OpenedModule _ -> vernac_end_module id
+  let o = try Lib.what_is_opened () with 
+      Not_found -> error "There is nothing to end." in
+    match o with
+      | _,Lib.OpenedModule (export,_,_) -> vernac_end_module export id
       | _,Lib.OpenedModtype _ -> vernac_end_modtype id
       | _,Lib.OpenedSection _ -> vernac_end_section id
       | _ -> anomaly "No more opened things"
-  with
-      Not_found -> error "There is nothing to end."
-
-let is_obsolete_module (_,qid) =
-  match repr_qualid qid with
-  | dir, id when dir = empty_dirpath ->
-      (match string_of_id id with
-	| ("Refine" | "Inv" | "Equality" | "EAuto" | "AutoRewrite"
-	  | "EqDecide" | "Xml" |  "Extraction" | "Tauto" | "Setoid_replace"
-          | "Elimdep" 
-	  | "DatatypesSyntax" | "LogicSyntax" | "Logic_TypeSyntax"
-	  | "SpecifSyntax" | "PeanoSyntax" | "TypeSyntax" | "PolyListSyntax")
-	  -> true
-	| _ -> false)
-  | _ -> false
-
-let test_renamed_module (_,qid) =
-  match repr_qualid qid with
-  | dir, id when dir = empty_dirpath ->
-      (match string_of_id id with
-	| "List" -> warning "List has been renamed into MonoList"
-        | "PolyList" -> warning "PolyList has been renamed into List and old List into MonoList"
-        | _ -> ())
-  | _ -> ()
 
 let vernac_require import _ qidl =
   let qidl = List.map qualid_of_reference qidl in
-  try
-    match import with
-      | None -> List.iter Library.read_library qidl
-      | Some b -> Library.require_library None qidl b
-  with e ->
-  (* Compatibility message *)
-    let qidl' = List.filter is_obsolete_module qidl in
-    if qidl' = qidl then
-      List.iter
-	(fun (_,qid) ->
-	  warning ("Module "^(string_of_qualid qid)^
-	  " is now built-in and shouldn't be required")) qidl
-    else
-      (if not !Options.v7 then List.iter test_renamed_module qidl;
-       raise e)
-      
-let vernac_import export refl =
-  let import_one ref = 
-    let qid = qualid_of_reference ref in
-      Library.import_library export qid
-  in
-    List.iter import_one refl;
-    Lib.add_frozen_state ()
-
-(*  else
-    let import (loc,qid) = 
-      try
-	let mp = Nametab.locate_module qid in
-	  Declaremods.import_module mp
-      with Not_found ->
-	user_err_loc
-        (loc,"vernac_import",
-	 str ((string_of_qualid qid)^" is not a module"))
-    in
-      List.iter import qidl;
-*)
+  Library.require_library qidl import
 
 let vernac_canonical locqid =
-  Recordobj.objdef_declare (Nametab.global locqid)
+  Recordops.declare_canonical_structure (Nametab.global locqid)
 
 let locate_reference ref =
   let (loc,qid) = qualid_of_reference ref in
@@ -565,6 +536,7 @@ let vernac_identity_coercion stre id qids qidt =
 let vernac_solve n tcom b =
   if not (refining ()) then
     error "Unknown command of the non proof-editing mode";
+  Decl_mode.check_not_proof_mode "Unknown proof instruction";
   begin
     if b then 
       solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ()))
@@ -575,7 +547,7 @@ let vernac_solve n tcom b =
   if subtree_solved () then begin
     Options.if_verbose msgnl (str "Subgoal proved");
     make_focus 0;
-    reset_top_of_tree ()
+    reset_top_of_script ()
   end;
   print_subgoals();
   if !pcoq <> None then (out_some !pcoq).solve n
@@ -591,39 +563,68 @@ let vernac_solve_existential = instantiate_nth_evar_com
 let vernac_set_end_tac tac =
   if not (refining ()) then
     error "Unknown command of the non proof-editing mode";
-  if tac <> (Tacexpr.TacId "") then set_end_tac (Tacinterp.interp tac)
-(* TO DO verifier s'il faut pas mettre exist s | TacId s ici*)
- 
-   
+  if tac <> (Tacexpr.TacId []) then set_end_tac (Tacinterp.interp tac) else ()
+    (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*)
+
+(***********************)
+(* Proof Language Mode *)
+
+let vernac_decl_proof () = 
+  check_not_proof_mode "Already in Proof Mode";
+  if tree_solved () then 
+    error "Nothing left to prove here."
+  else
+    begin
+      Decl_proof_instr.go_to_proof_mode ();
+      print_subgoals ()
+    end
+
+let vernac_return () = 
+  match get_current_mode () with
+      Mode_tactic ->
+	Decl_proof_instr.return_from_tactic_mode ();
+	print_subgoals ()
+    | Mode_proof -> 
+	error "\"return\" is only used after \"escape\"."
+    | Mode_none -> 
+	error "There is no proof to end." 
+
+let vernac_proof_instr instr = 
+  Decl_proof_instr.proof_instr instr;
+  print_subgoals ()
+
 (*****************************)
 (* Auxiliary file management *)
 
 let vernac_require_from export spec filename =
-  match export with
-      Some exp ->
-        Library.require_library_from_file spec None filename exp
-    | None -> Library.read_library_from_file filename
+  Library.require_library_from_file None
+    (System.expand_path_macros filename)
+    export
 
 let vernac_add_loadpath isrec pdir ldiropt =
+  let pdir = System.expand_path_macros pdir in
   let alias = match ldiropt with
     | None -> Nameops.default_root_prefix
     | Some ldir -> ldir in
   (if isrec then Mltop.add_rec_path else Mltop.add_path) pdir alias
 
-let vernac_remove_loadpath = Library.remove_path
+let vernac_remove_loadpath path =
+  Library.remove_load_path (System.expand_path_macros path)
 
   (* Coq syntax for ML or system commands *)
 
-let vernac_add_ml_path isrec s =
-  (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (System.glob s)
+let vernac_add_ml_path isrec path =
+  (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir)
+    (System.expand_path_macros path)
 
-let vernac_declare_ml_module l = Mltop.declare_ml_modules l
+let vernac_declare_ml_module l =
+  Mltop.declare_ml_modules (List.map System.expand_path_macros l)
 
 let vernac_chdir = function
   | None -> message (Sys.getcwd())
-  | Some s ->
+  | Some path ->
       begin
-	try Sys.chdir (System.glob s)
+	try Sys.chdir (System.expand_path_macros path)
 	with Sys_error str -> warning ("Cd failed: " ^ str)
       end;
       if_verbose message (Sys.getcwd())
@@ -651,7 +652,9 @@ let vernac_reset_initial () = abort_refine Lib.reset_initial ()
 
 let vernac_back n = Lib.back n
 
+let vernac_backto n = Lib.reset_label n
 
+(* see also [vernac_backtrack] which combines undoing and resetting *)
 (************)
 (* Commands *)
 
@@ -661,13 +664,15 @@ let vernac_hints = Auto.add_hints
 
 let vernac_syntactic_definition = Command.syntax_definition 
 
-let vernac_declare_implicits locqid = function
-  | Some imps -> Impargs.declare_manual_implicits (Nametab.global locqid) imps
-  | None -> Impargs.declare_implicits (Nametab.global locqid)
+let vernac_declare_implicits local locqid = function
+  | Some imps ->
+      Impargs.declare_manual_implicits local (Nametab.global locqid) imps
+  | None -> 
+      Impargs.declare_implicits local (Nametab.global locqid)
 
 let vernac_reserve idl c =
   let t = Constrintern.interp_type Evd.empty (Global.env()) c in
-  let t = Detyping.detype (false,Global.env()) [] [] t in
+  let t = Detyping.detype false [] [] t in
   List.iter (fun id -> Reserve.declare_reserved_type id t) idl
 
 let make_silent_if_not_pcoq b =
@@ -691,13 +696,11 @@ let _ =
       optread  = Impargs.is_implicit_args;
       optwrite = Impargs.make_implicit_args }
 
-let impargs = if !Options.v7 then "Implicits" else "Implicit"
-
 let _ =
   declare_bool_option 
-    { optsync  = false; (* synchronisation is in Impargs *)
+    { optsync  = true;
       optname  = "strict implicit arguments";
-      optkey   = (SecondaryTable ("Strict",impargs));
+      optkey   = (SecondaryTable ("Strict","Implicit"));
       optread  = Impargs.is_strict_implicit_args;
       optwrite = Impargs.make_strict_implicit_args }
 
@@ -705,7 +708,7 @@ let _ =
   declare_bool_option 
     { optsync  = true;
       optname  = "contextual implicit arguments";
-      optkey   = (SecondaryTable ("Contextual",impargs));
+      optkey   = (SecondaryTable ("Contextual","Implicit"));
       optread  = Impargs.is_contextual_implicit_args;
       optwrite = Impargs.make_contextual_implicit_args }
 
@@ -721,7 +724,7 @@ let _ =
   declare_bool_option 
     { optsync  = true;
       optname  = "implicit arguments printing";
-      optkey   = (SecondaryTable ("Printing",impargs));
+      optkey   = (SecondaryTable ("Printing","Implicit"));
       optread  = (fun () -> !Constrextern.print_implicits);
       optwrite = (fun b ->  Constrextern.print_implicits := b) }
 
@@ -737,7 +740,7 @@ let _ =
   declare_bool_option 
     { optsync  = true;
       optname  = "notations printing";
-      optkey   = (SecondaryTable ("Printing",if !Options.v7 then "Symbols" else "Notations"));
+      optkey   = (SecondaryTable ("Printing","Notations"));
       optread  = (fun () -> not !Constrextern.print_no_symbol);
       optwrite = (fun b ->  Constrextern.print_no_symbol := not b) }
 
@@ -750,6 +753,30 @@ let _ =
       optwrite = (fun b -> Options.raw_print := b) }
 
 let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "use of virtual machine inside the kernel";
+      optkey   = (SecondaryTable ("Virtual","Machine"));
+      optread  = (fun () -> Vconv.use_vm ());
+      optwrite = (fun b -> Vconv.set_use_vm b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "use of boxed definitions";
+      optkey   = (SecondaryTable ("Boxed","Definitions"));
+      optread  = Options.boxed_definitions;
+      optwrite = (fun b -> Options.set_boxed_definitions b) } 
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "use of boxed values";
+      optkey   = (SecondaryTable ("Boxed","Values"));
+      optread  = (fun _ -> not (Vm.transp_values ()));
+      optwrite = (fun b -> Vm.set_transp_values (not b)) } 
+
+let _ =
   declare_int_option
     { optsync=false;
       optkey=PrimaryTable("Undo");
@@ -781,14 +808,33 @@ let _ =
       optread=Pp_control.get_margin;
       optwrite=Pp_control.set_margin }
 
+let _ =
+  declare_bool_option
+    { optsync=true;
+      optkey=SecondaryTable("Printing","Universes");
+      optname="the printing of universes";
+      optread=(fun () -> !Constrextern.print_universes);
+      optwrite=(fun b -> Constrextern.print_universes:=b) }
+
+let vernac_debug b =
+  set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
+
+let _ =
+  declare_bool_option
+    { optsync=false;
+      optkey=SecondaryTable("Ltac","Debug");
+      optname="Ltac debug";
+      optread=(fun () -> get_debug () <> Tactic_debug.DebugOff);
+      optwrite=vernac_debug }
+
 let vernac_set_opacity opaq locqid =
   match Nametab.global locqid with
     | ConstRef sp ->
-	if opaq then Tacred.set_opaque_const sp
-	else Tacred.set_transparent_const sp
+	if opaq then set_opaque_const sp
+	else set_transparent_const sp
     | VarRef id ->
-	if opaq then Tacred.set_opaque_var id
-	else Tacred.set_transparent_var id
+	if opaq then set_opaque_var id
+	else set_transparent_var id
     | _ -> error "cannot set an inductive type or a constructor as transparent"
 
 let vernac_set_option key = function
@@ -843,7 +889,7 @@ let vernac_check_may_eval redexp glopt rc =
 	if !pcoq <> None then (out_some !pcoq).print_check j
 	else msg (print_judgment env j)
     | Some r ->
-	let redfun = Tacred.reduction_of_redexp (interp_redexp env evmap r) in
+	let redfun = fst (reduction_of_red_expr (interp_redexp env evmap r)) in
 	if !pcoq <> None
 	then (out_some !pcoq).print_eval (redfun env evmap) env rc j
 	else msg (print_eval redfun env j)
@@ -859,7 +905,6 @@ let vernac_global_check c =
 
 let vernac_print = function
   | PrintTables -> print_tables ()
-  | PrintLocalContext -> msg (print_local_context ())
   | PrintFullContext -> msg (print_full_context_typ ())
   | PrintSectionContext qid -> msg (print_sec_context_typ qid)
   | PrintInspect n -> msg (inspect n)
@@ -876,21 +921,25 @@ let vernac_print = function
   | PrintOpaqueName qid -> msg (print_opaque_name qid)
   | PrintGraph -> ppnl (Prettyp.print_graph())
   | PrintClasses -> ppnl (Prettyp.print_classes())
+  | PrintLtac qid -> ppnl (Tacinterp.print_ltac (snd (qualid_of_reference qid)))
   | PrintCoercions -> ppnl (Prettyp.print_coercions())
   | PrintCoercionPaths (cls,clt) ->
       ppnl (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
+  | PrintCanonicalConversions -> ppnl (Prettyp.print_canonical_projections ())
   | PrintUniverses None -> pp (Univ.pr_universes (Global.universes ()))
   | PrintUniverses (Some s) -> dump_universes s
   | PrintHint qid -> Auto.print_hint_ref (Nametab.global qid)
   | PrintHintGoal -> Auto.print_applicable_hint ()
   | PrintHintDbName s -> Auto.print_hint_db_by_name s
+  | PrintRewriteHintDbName s -> Autorewrite.print_rewrite_hintdb s
   | PrintHintDb -> Auto.print_searchtable ()
+  | PrintSetoids -> Setoid_replace.print_setoids()
   | PrintScopes ->
-      pp (Symbols.pr_scopes (Constrextern.without_symbols pr_rawterm))
+      pp (Notation.pr_scopes (Constrextern.without_symbols pr_lrawconstr))
   | PrintScope s ->
-      pp (Symbols.pr_scope (Constrextern.without_symbols pr_rawterm) s)
+      pp (Notation.pr_scope (Constrextern.without_symbols pr_lrawconstr) s)
   | PrintVisibility s ->
-      pp (Symbols.pr_visibility (Constrextern.without_symbols pr_rawterm) s)
+      pp (Notation.pr_visibility (Constrextern.without_symbols pr_lrawconstr) s)
   | PrintAbout qid -> msgnl (print_about qid)
   | PrintImplicit qid -> msg (print_impargs qid)
 
@@ -929,10 +978,11 @@ let vernac_search s r =
 let vernac_locate = function
   | LocateTerm qid -> msgnl (print_located_qualid qid)
   | LocateLibrary qid -> print_located_library qid
+  | LocateModule qid -> print_located_module qid
   | LocateFile f -> locate_file f
   | LocateNotation ntn ->
-      ppnl (Symbols.locate_notation (Constrextern.without_symbols pr_rawterm)
-	(Metasyntax.standardise_locatable_notation ntn))
+      ppnl (Notation.locate_notation (Constrextern.without_symbols pr_lrawconstr)
+	(Metasyntax.standardize_locatable_notation ntn))
 
 (********************)
 (* Proof management *)
@@ -942,7 +992,7 @@ let vernac_goal = function
   | Some c ->
       if not (refining()) then begin
         let unnamed_kind = Lemma (* Arbitrary *) in
-        start_proof_com None (IsGlobal (Proof unnamed_kind)) c (fun _ _ ->());
+        start_proof_com None (Global, Proof unnamed_kind) c (fun _ _ ->());
 	print_subgoals ()
       end else 
 	error "repeated Goal not permitted in refining mode"
@@ -979,14 +1029,28 @@ let vernac_undo n =
   undo n;
   print_subgoals ()
 
-  (* Est-ce normal que "Focus" ne semble pas se comporter comme "Focus 1" ? *)
-let vernac_focus = function
-  | None -> traverse_nth_goal 1; print_subgoals ()
-  | Some n -> traverse_nth_goal n; print_subgoals ()
+(* backtrack with [naborts] abort, then undo_todepth to [pnum], then
+   back-to state number [snum]. This allows to backtrack proofs and
+   state with one command (easier for proofgeneral). *)
+let vernac_backtrack snum pnum naborts =
+  for i = 1 to naborts do vernac_abort None done;
+  undo_todepth pnum;
+  vernac_backto snum;
+  Pp.flush_all();
+  (* there may be no proof in progress, even if no abort *)
+  (try print_subgoals () with UserError _ -> ())
+  
 
+let vernac_focus gln =
+  check_not_proof_mode "No focussing or Unfocussing in Proof Mode.";
+  match gln with 
+    | None -> traverse_nth_goal 1; print_subgoals ()
+    | Some n -> traverse_nth_goal n; print_subgoals ()
+	
   (* Reset the focus to the top of the tree *)
 let vernac_unfocus () =
-  make_focus 0; reset_top_of_tree (); print_subgoals ()
+  check_not_proof_mode "No focussing or Unfocussing in Proof Mode.";
+  make_focus 0; reset_top_of_script (); print_subgoals ()
 
 let vernac_go = function
   | GoTo n -> Pfedit.traverse n;show_node()
@@ -1005,10 +1069,10 @@ let apply_subproof f occ =
   f evc (Global.named_context()) pf
 
 let explain_proof occ =
-  msg (apply_subproof (Refiner.print_treescript true) occ)
+  msg (apply_subproof (fun evd _ -> print_treescript true evd) occ)
 
 let explain_tree occ =
-  msg (apply_subproof Refiner.print_proof occ)
+  msg (apply_subproof print_proof occ)
 
 let vernac_show = function
   | ShowGoal nopt ->
@@ -1028,17 +1092,19 @@ let vernac_show = function
   | ShowProofNames ->
       msgnl (prlist_with_sep pr_spc pr_id (Pfedit.get_all_proof_names()))
   | ShowIntros all -> show_intro all
+  | ShowMatch id -> show_match id
+  | ShowThesis -> show_thesis ()
   | ExplainProof occ -> explain_proof occ
   | ExplainTree occ -> explain_tree occ
 
+
 let vernac_check_guard () =
   let pts = get_pftreestate () in
-  let pf = proof_of_pftreestate pts 
-  and cursor = cursor_of_pftreestate pts in
+  let pf = proof_of_pftreestate pts in
   let (pfterm,_) = extract_open_pftreestate pts in
   let message = 
     try 
-      Inductiveops.control_only_guard (Evarutil.evar_env (goal_of_proof pf))
+      Inductiveops.control_only_guard (Evd.evar_env (goal_of_proof pf))
 	pfterm; 
       (str "The condition holds up to here")
     with UserError(_,s) -> 
@@ -1046,103 +1112,19 @@ let vernac_check_guard () =
   in 
   msgnl message
 
-let vernac_debug b =
-  set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
-
-
-(**************************)
-(* Not supported commands *)
-(***
-let _ =
-  add "ResetSection"
-    (function 
-       | [VARG_IDENTIFIER id] ->
-	   (fun () -> reset_section (string_of_id id))
-       | _ -> bad_vernac_args "ResetSection")
-
-(* Modules *)
-
-let _ =
-  vinterp_add "BeginModule"
-    (function 
-       | [VARG_IDENTIFIER id] ->
-	   let s = string_of_id id in
-	   let lpe,_ = System.find_file_in_path (Library.get_load_path ()) (s^".v") in
-	   let dir = extend_dirpath (Library.find_logical_path lpe) id in
-	   fun () ->
-	     Lib.start_module dir
-       | _ -> bad_vernac_args "BeginModule")
-
-let _ =
-  vinterp_add "WriteModule"
-    (function 
-       | [VARG_IDENTIFIER id] ->
-	   let mid = Lib.end_module id in
-	   fun () -> let m = string_of_id id in Library.save_module_to mid m
-       | [VARG_IDENTIFIER id; VARG_STRING f] ->
-	   let mid = Lib.end_module id in
-	   fun () -> Library.save_module_to mid f
-       | _ -> bad_vernac_args "WriteModule")
-
-let _ =
-  vinterp_add "CLASS"
-    (function 
-       | [VARG_STRING kind; VARG_QUALID qid] -> 
-	   let stre = 
-	     if kind = "LOCAL" then 
-	       make_strength_0()
-             else 
-	       Nametab.NeverDischarge 
-	   in
-	   fun () -> 
-	     let ref = Nametab.global (dummy_loc, qid) in
-	     Class.try_add_new_class ref stre;
-             if_verbose message
-               ((string_of_qualid qid) ^ " is now a class")
-       | _ -> bad_vernac_args "CLASS")
-
-(* Meta-syntax commands *)
-let _ =
-  add "TOKEN"
-    (function
-       | [VARG_STRING s] -> (fun () -> Metasyntax.add_token_obj s)
-       | _ -> bad_vernac_args "TOKEN")
-***)
-
-(* Search commands *)
-
-(***
-let _ =
-  add "Searchisos"
-  (function
-     | [VARG_CONSTR com] -> 
-	 (fun () ->
-	    let env = Global.env() in
-	    let c = constr_of_com Evd.empty env com in
-	    let cc = nf_betaiota env Evd.empty c in
-            Searchisos.type_search cc)
-     | _ -> bad_vernac_args "Searchisos")
-***)
-
 let interp c = match c with
   (* Control (done in vernac) *)
   | (VernacTime _ | VernacVar _ | VernacList _ | VernacLoad _) -> assert false
-  | (VernacV7only _ | VernacV8only _) -> assert false
 
   (* Syntax *)
-  | VernacSyntax (whatfor,sel) -> vernac_syntax whatfor sel
-  | VernacTacticGrammar al -> Metasyntax.add_tactic_grammar al
-  | VernacGrammar (univ,al) -> vernac_grammar univ al
-  | VernacSyntaxExtension (lcl,sl,l8) -> vernac_syntax_extension lcl sl l8
+  | VernacTacticNotation (n,r,e) -> Metasyntax.add_tactic_notation (n,r,e)
+  | VernacSyntaxExtension (lcl,sl) -> vernac_syntax_extension lcl sl
   | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr
   | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl
   | VernacOpenCloseScope sc -> vernac_open_close_scope sc
-  | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope qid scl
-  | VernacInfix (local,mv,qid,mv8,sc) -> vernac_infix local mv qid mv8 sc
-  | VernacDistfix (local,assoc,n,inf,qid,sc) -> 
-      vernac_distfix local assoc n inf qid sc
-  | VernacNotation (local,c,infpl,mv8,sc) ->
-      vernac_notation local c infpl mv8 sc
+  | VernacArgumentsScope (lcl,qid,scl) -> vernac_arguments_scope lcl qid scl
+  | VernacInfix (local,mv,qid,sc) -> vernac_infix local mv qid sc
+  | VernacNotation (local,c,infpl,sc) -> vernac_notation local c infpl sc
 
   (* Gallina *)
   | VernacDefinition (k,(_,id),d,f) -> vernac_definition k id d f
@@ -1152,15 +1134,15 @@ let interp c = match c with
   | VernacExactProof c -> vernac_exact_proof c
   | VernacAssumption (stre,l) -> vernac_assumption stre l
   | VernacInductive (finite,l) -> vernac_inductive finite l
-  | VernacFixpoint l -> vernac_fixpoint l
-  | VernacCoFixpoint l -> vernac_cofixpoint l
+  | VernacFixpoint (l,b) -> vernac_fixpoint l b
+  | VernacCoFixpoint (l,b) -> vernac_cofixpoint l b
   | VernacScheme l -> vernac_scheme l
 
   (* Modules *)
-  | VernacDeclareModule ((_,id),bl,mtyo,mexpro) -> 
-      vernac_declare_module id bl mtyo mexpro
-  | VernacDefineModule ((_,id),bl,mtyo,mexpro) -> 
-      vernac_define_module id bl mtyo mexpro
+  | VernacDeclareModule (export,(_,id),bl,mtyo) -> 
+      vernac_declare_module export id bl mtyo
+  | VernacDefineModule (export,(_,id),bl,mtyo,mexpro) -> 
+      vernac_define_module export id bl mtyo mexpro
   | VernacDeclareModuleType ((_,id),bl,mtyo) -> 
       vernac_declare_module_type id bl mtyo
 
@@ -1180,6 +1162,14 @@ let interp c = match c with
   | VernacSolve (n,tac,b) -> vernac_solve n tac b
   | VernacSolveExistential (n,c) -> vernac_solve_existential n c
 
+  (* MMode *)
+
+  | VernacDeclProof -> vernac_decl_proof ()
+  | VernacReturn -> vernac_return ()
+  | VernacProofInstr stp -> vernac_proof_instr stp 
+
+  (* /MMode *)
+
   (* Auxiliary file and library management *)
   | VernacRequireFrom (exp,spec,f) -> vernac_require_from exp spec f
   | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias
@@ -1196,12 +1186,13 @@ let interp c = match c with
   | VernacResetName id -> vernac_reset_name id
   | VernacResetInitial -> vernac_reset_initial ()
   | VernacBack n -> vernac_back n
+  | VernacBackTo n -> vernac_backto n
 
   (* Commands *)
   | VernacDeclareTacticDefinition (x,l) -> vernac_declare_tactic_definition x l
   | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints
   | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b
-  | VernacDeclareImplicits (qid,l) -> vernac_declare_implicits qid l
+  | VernacDeclareImplicits (local,qid,l) ->vernac_declare_implicits local qid l
   | VernacReserve (idl,c) -> vernac_reserve idl c
   | VernacSetOpacity (opaq, qidl) -> List.iter (vernac_set_opacity opaq) qidl
   | VernacSetOption (key,v) -> vernac_set_option key v
@@ -1226,12 +1217,12 @@ let interp c = match c with
   | VernacSuspend -> vernac_suspend ()
   | VernacResume id -> vernac_resume id
   | VernacUndo n -> vernac_undo n
+  | VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts
   | VernacFocus n -> vernac_focus n
   | VernacUnfocus -> vernac_unfocus ()
   | VernacGo g -> vernac_go g
   | VernacShow s -> vernac_show s
   | VernacCheckGuard -> vernac_check_guard ()
-  | VernacDebug b -> vernac_debug b
   | VernacProof tac -> vernac_set_end_tac tac
   (* Toplevel control *)
   | VernacToplevelControl e -> raise e
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
index 89e0d708..bcd89490 100644
--- a/toplevel/vernacentries.mli
+++ b/toplevel/vernacentries.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacentries.mli,v 1.16.2.2 2005/01/21 16:41:52 herbelin Exp $ i*)
+(*i $Id: vernacentries.mli 8781 2006-05-03 10:15:05Z jforest $ i*)
 
 (*i*)
 open Names
@@ -52,3 +52,5 @@ val set_pcoq_hook : pcoq_hook -> unit
 val abort_refine : ('a -> unit) -> 'a -> unit;;
 
 val interp : Vernacexpr.vernac_expr -> unit
+
+val vernac_reset_name : identifier Util.located -> unit 
diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml
index 382434dc..4c671787 100644
--- a/toplevel/vernacexpr.ml
+++ b/toplevel/vernacexpr.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacexpr.ml,v 1.55.2.2 2005/01/21 17:14:10 herbelin Exp $ i*)
+(*i $Id: vernacexpr.ml 9481 2007-01-11 19:17:56Z herbelin $ i*)
 
 open Util
 open Names
@@ -34,7 +34,6 @@ type class_rawexpr = FunClass | SortClass | RefClass of reference
   
 type printable =
   | PrintTables
-  | PrintLocalContext
   | PrintFullContext
   | PrintSectionContext of reference
   | PrintInspect of int
@@ -49,13 +48,17 @@ type printable =
   | PrintOpaqueName of reference
   | PrintGraph
   | PrintClasses
+  | PrintLtac of reference
   | PrintCoercions
   | PrintCoercionPaths of class_rawexpr * class_rawexpr
+  | PrintCanonicalConversions
   | PrintUniverses of string option
   | PrintHint of reference
   | PrintHintGoal
   | PrintHintDbName of string
+  | PrintRewriteHintDbName of string
   | PrintHintDb
+  | PrintSetoids
   | PrintScopes
   | PrintScope of string
   | PrintVisibility of string option
@@ -75,6 +78,7 @@ type searchable =
 type locatable =
   | LocateTerm of reference
   | LocateLibrary of reference
+  | LocateModule of reference
   | LocateFile of string
   | LocateNotation of notation
 
@@ -94,6 +98,8 @@ type showable =
   | ShowTree
   | ShowProofNames
   | ShowIntros of bool
+  | ShowMatch of lident
+  | ShowThesis
   | ExplainProof of int list
   | ExplainTree of int list
 
@@ -103,11 +109,11 @@ type comment =
   | CommentInt of int
 
 type hints =
-  | HintsResolve of (identifier option * constr_expr) list
-  | HintsImmediate of (identifier option * constr_expr) list
-  | HintsUnfold of (identifier option * reference) list
-  | HintsConstructors of identifier option * reference list
-  | HintsExtern of identifier option * int * constr_expr * raw_tactic_expr
+  | HintsResolve of constr_expr list
+  | HintsImmediate of constr_expr list
+  | HintsUnfold of reference list
+  | HintsConstructors of reference list
+  | HintsExtern of int * constr_expr * raw_tactic_expr
   | HintsDestruct of identifier *
       int * (bool,unit) location * constr_expr * raw_tactic_expr
 
@@ -141,8 +147,7 @@ type simple_binder = lident list  * constr_expr
 type 'a with_coercion = coercion_flag * 'a
 type constructor_expr = (lident * constr_expr) with_coercion
 type inductive_expr =
-     lident * decl_notation * local_binder list * constr_expr
-    * constructor_expr list
+     lident * local_binder list * constr_expr * constructor_expr list
 type definition_expr =
   | ProveBody of local_binder list * constr_expr
   | DefineBody of local_binder list * raw_red_expr option * constr_expr
@@ -152,7 +157,11 @@ type local_decl_expr =
   | AssumExpr of lname * constr_expr
   | DefExpr of lname * constr_expr * constr_expr option
 
-type module_binder = lident list * module_type_ast
+type module_binder = bool option * lident list * module_type_ast
+
+type grammar_production =
+  | VTerm of string
+  | VNonTerm of loc * string * Names.identifier option
 
 type proof_end =
   | Admitted
@@ -166,25 +175,17 @@ type vernac_expr =
   | VernacVar of lident
 
   (* Syntax *) 
-  | VernacGrammar of lstring * raw_grammar_entry list
-  | VernacTacticGrammar of
-      (lstring * (lstring * grammar_production list) * raw_tactic_expr) list
-  | VernacSyntax of lstring * raw_syntax_entry list
-  | VernacSyntaxExtension of locality_flag *
-      (lstring * syntax_modifier list) option 
-      * (lstring * syntax_modifier list) option
-  | VernacDistfix of locality_flag *
-      grammar_associativity * precedence * lstring * lreference *
-      scope_name option
+  | VernacTacticNotation of int * grammar_production list * raw_tactic_expr
+  | VernacSyntaxExtension of locality_flag * (lstring * syntax_modifier list)
   | VernacOpenCloseScope of (locality_flag * bool * scope_name)
   | VernacDelimiters of scope_name * lstring
   | VernacBindScope of scope_name * class_rawexpr list
-  | VernacArgumentsScope of lreference * scope_name option list
+  | VernacArgumentsScope of locality_flag * lreference * scope_name option list
   | VernacInfix of locality_flag * (lstring * syntax_modifier list) *
-      lreference * (lstring * syntax_modifier list) option * scope_name option
+      lreference * scope_name option
   | VernacNotation of
-      locality_flag * constr_expr * (lstring * syntax_modifier list) option *
-      (lstring * syntax_modifier list) option * scope_name option
+      locality_flag * constr_expr * (lstring * syntax_modifier list) *
+      scope_name option
 
   (* Gallina *)
   | VernacDefinition of definition_kind * lident * definition_expr * 
@@ -194,9 +195,9 @@ type vernac_expr =
   | VernacEndProof of proof_end
   | VernacExactProof of constr_expr
   | VernacAssumption of assumption_kind * simple_binder with_coercion list
-  | VernacInductive of inductive_flag * inductive_expr list
-  | VernacFixpoint of (fixpoint_expr * decl_notation) list
-  | VernacCoFixpoint of cofixpoint_expr list
+  | VernacInductive of inductive_flag * (inductive_expr * decl_notation) list
+  | VernacFixpoint of (fixpoint_expr * decl_notation) list * bool
+  | VernacCoFixpoint of (cofixpoint_expr * decl_notation) list * bool
   | VernacScheme of (lident * bool * lreference * sort_expr) list
 
   (* Gallina extensions *)
@@ -214,17 +215,25 @@ type vernac_expr =
       class_rawexpr * class_rawexpr
 
   (* Modules and Module Types *)
-  | VernacDeclareModule of lident * 
-      module_binder list * (module_type_ast * bool) option * module_ast option
-  | VernacDefineModule of lident * 
+  | VernacDeclareModule of bool option * lident * 
+      module_binder list * (module_type_ast * bool)
+  | VernacDefineModule of bool option * lident * 
       module_binder list * (module_type_ast * bool) option * module_ast option
   | VernacDeclareModuleType of lident * 
       module_binder list * module_type_ast option
 
   (* Solving *)
+
   | VernacSolve of int * raw_tactic_expr * bool
   | VernacSolveExistential of int * constr_expr
 
+  (* Proof Mode *)
+
+  | VernacDeclProof
+  | VernacReturn
+  | VernacProofInstr of Decl_expr.raw_proof_instr
+
+
   (* Auxiliary file and library management *)
   | VernacRequireFrom of export_flag option * specif_flag option * lstring
   | VernacAddLoadPath of rec_flag * lstring * dir_path option
@@ -241,6 +250,7 @@ type vernac_expr =
   | VernacResetName of lident
   | VernacResetInitial
   | VernacBack of int
+  | VernacBackTo of int
 
   (* Commands *)
   | VernacDeclareTacticDefinition of
@@ -248,7 +258,8 @@ type vernac_expr =
   | VernacHints of locality_flag * lstring list * hints
   | VernacSyntacticDefinition of identifier * constr_expr * locality_flag *
       onlyparsing_flag
-  | VernacDeclareImplicits of lreference * explicitation list option
+  | VernacDeclareImplicits of locality_flag * lreference *
+      explicitation list option
   | VernacReserve of lident list * constr_expr
   | VernacSetOpacity of opacity_flag * lreference list
   | VernacUnsetOption of Goptions.option_name
@@ -273,20 +284,16 @@ type vernac_expr =
   | VernacSuspend
   | VernacResume of lident option
   | VernacUndo of int
+  | VernacBacktrack of int*int*int
   | VernacFocus of int option
   | VernacUnfocus
   | VernacGo of goable
   | VernacShow of showable
   | VernacCheckGuard
-  | VernacDebug of bool
   | VernacProof of raw_tactic_expr
   (* Toplevel control *)
   | VernacToplevelControl of exn
 
-  (* For translation from V7 to V8 syntax *)
-  | VernacV8only of vernac_expr
-  | VernacV7only of vernac_expr
-
   (* For extension *)
   | VernacExtend of string * raw_generic_argument list
 
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
index c7846d71..98584bac 100644
--- a/toplevel/vernacinterp.ml
+++ b/toplevel/vernacinterp.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernacinterp.ml,v 1.17.8.1 2004/07/16 19:31:50 herbelin Exp $ *)
+(* $Id: vernacinterp.ml 7732 2005-12-26 13:51:24Z herbelin $ *)
 
 open Pp
 open Util
@@ -15,10 +15,7 @@ open Libnames
 open Himsg
 open Proof_type
 open Tacinterp
-open Coqast
 open Vernacexpr
-open Ast
-open Extend
 
 let disable_drop e =
   if e <> Drop then e
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
index 86b80935..e0c34dc9 100644
--- a/toplevel/vernacinterp.mli
+++ b/toplevel/vernacinterp.mli
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vernacinterp.mli,v 1.11.10.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+(*i $Id: vernacinterp.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
 
 (*i*)
 open Tacexpr
diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4
new file mode 100644
index 00000000..042ee5c8
--- /dev/null
+++ b/toplevel/whelp.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*)
+
+(* $Id: whelp.ml4 7837 2006-01-11 09:47:32Z herbelin $ *)
+
+open Options
+open Pp
+open Util
+open System
+open Names
+open Term
+open Environ
+open Rawterm
+open Libnames
+open Nametab
+open Termops
+open Detyping
+open Constrintern
+open Dischargedhypsmap
+open Command
+open Pfedit
+open Refiner
+open Tacmach
+
+(* Coq interface to the Whelp query engine developed at 
+   the University of Bologna *)
+
+let make_whelp_request req c =
+  "http://mowgli.cs.unibo.it/forward/58080/apply?xmluri=http%3A%2F%2Fmowgli.cs.unibo.it%3A58081%2Fgetempty&param.profile=firewall&profile=firewall&param.keys=d_c%2CC1%2CHC2%2CL&param.embedkeys=d_c%2CTC1%2CHC2%2CL&param.thkeys=T1%2CT2%2CL%2CE&param.prooftreekeys=HAT%2CG%2CHAO%2CL&param.media-type=text%2Fhtml&param.thmedia-type=&prooftreemedia-type=&param.doctype-public=&param.encoding=&param.thencoding=&param.prooftreeencoding=&advanced=no&keys=S%2CT1%2CT2%2CL%2CRT%2CE&param.expression=" ^ c ^ "&param.action=" ^ req
+
+let b = Buffer.create 16
+
+let url_char c =
+  if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or 
+     '0' <= c & c <= '9' or c ='.'
+  then Buffer.add_char b c
+  else Buffer.add_string b (Printf.sprintf "%%%2X" (Char.code c))
+
+let url_string s = String.iter url_char s
+
+let rec url_list_with_sep sep f = function
+  | [] -> ()
+  | [a] -> f a
+  | a::l -> f a; url_string sep; url_list_with_sep sep f l 
+
+let url_id id = url_string (string_of_id id)
+
+let uri_of_dirpath dir =
+  url_string "cic:/"; url_list_with_sep "/" url_id (List.rev dir)
+
+let error_whelp_unknown_reference ref =
+  let qid = Nametab.shortest_qualid_of_global Idset.empty ref in
+  error ("Definitions of the current session not supported in Whelp: " ^ string_of_qualid qid)
+
+let uri_of_repr_kn ref (mp,dir,l) = 
+  match mp with
+    | MPfile sl ->
+        uri_of_dirpath (id_of_label l :: repr_dirpath dir @ repr_dirpath sl)
+    | _ ->
+        error_whelp_unknown_reference ref
+
+let url_paren f l = url_char '('; f l; url_char ')'
+let url_bracket f l = url_char '['; f l; url_char ']'
+
+let whelp_of_rawsort = function
+  | RProp Null -> "Prop"
+  | RProp Pos -> "Set"
+  | RType _ -> "Type"
+
+let uri_int n = Buffer.add_string b (string_of_int n)
+
+let uri_of_ind_pointer l =
+  url_string ".ind#xpointer"; url_paren (url_list_with_sep "/" uri_int) l
+
+let uri_of_global ref =
+  match ref with
+  | VarRef id -> error ("Unknown Whelp reference: "^(string_of_id id))
+  | ConstRef cst ->
+      uri_of_repr_kn ref (repr_con cst); url_string ".con"
+  | IndRef (kn,i) -> 
+      uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1]
+  | ConstructRef ((kn,i),j) ->
+      uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1;j]
+
+let whelm_special = id_of_string "WHELM_ANON_VAR"
+
+let url_of_name = function
+  | Name id -> url_id id
+  | Anonymous -> url_id whelm_special (* No anon id in Whelp *)
+
+let uri_of_binding f (id,c) = url_id id; url_string "\\Assign "; f c
+
+let uri_params f = function
+  | [] -> ()
+  | l -> url_string "\\subst"; 
+         url_bracket (url_list_with_sep ";" (uri_of_binding f)) l
+
+let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp)
+
+let section_parameters = function
+  | RRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) ->
+      get_discharged_hyp_names (sp_of_global (IndRef(induri,0)))
+  | RRef (_,(ConstRef cst as ref)) ->
+      get_discharged_hyp_names (sp_of_global ref)
+  | _ -> []
+
+let merge vl al =
+  let rec aux acc = function
+  | ([],l) | (_,([] as l)) -> List.rev acc, l
+  | (v::vl,a::al) -> aux ((v,a)::acc) (vl,al)
+  in aux [] (vl,al)
+
+let rec uri_of_constr c =
+  match c with
+  | RVar (_,id) -> url_id id
+  | RRef (_,ref) ->  uri_of_global ref
+  | RHole _ | REvar _ -> url_string "?"
+  | RSort (_,s) -> url_string (whelp_of_rawsort s)
+  | _ -> url_paren (fun () -> match c with
+  | RApp (_,f,args) ->
+      let inst,rest = merge (section_parameters f) args in
+      uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; 
+      url_list_with_sep " " uri_of_constr rest
+  | RLambda (_,na,ty,c) ->
+      url_string "\\lambda "; url_of_name na; url_string ":";
+      uri_of_constr ty; url_string "."; uri_of_constr c
+  | RProd (_,Anonymous,ty,c) ->
+      uri_of_constr ty; url_string "\\to "; uri_of_constr c
+  | RProd (_,Name id,ty,c) ->
+      url_string "\\forall "; url_id id; url_string ":";
+      uri_of_constr ty; url_string "."; uri_of_constr c
+  | RLetIn (_,na,b,c) ->
+      url_string "let "; url_of_name na; url_string "\\def ";
+      uri_of_constr b; url_string " in "; uri_of_constr c
+  | RCast (_,c,_,t) ->
+      uri_of_constr c; url_string ":"; uri_of_constr t
+  | RRec _ | RIf _ | RLetTuple _ | RCases _ ->
+      error "Whelp does not support pattern-matching and (co-)fixpoint"
+  | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ ->
+      anomaly "Written w/o parenthesis"
+  | RPatVar _ | RDynamic _ -> 
+      anomaly "Found constructors not supported in constr") ()
+
+let make_string f x = Buffer.reset b; f x; Buffer.contents b
+
+let send_whelp req s =
+  let url = make_whelp_request req s in
+  let command = (fst browser_cmd_fmt) ^ url ^ (snd browser_cmd_fmt) in
+  let _ = run_command (fun x -> x) print_string command in ()
+
+let whelp_constr req c =
+  let c = detype false [whelm_special] [] c in
+  send_whelp req (make_string uri_of_constr c)
+
+let whelp_constr_expr req c =
+  let (sigma,env)= get_current_context () in
+  let _,c = interp_open_constr sigma env c in
+  whelp_constr req c
+
+let whelp_locate s =
+  send_whelp "locate" s
+
+let whelp_elim ind = 
+  send_whelp "elim" (make_string uri_of_global (IndRef ind))
+
+let locate_inductive r =
+  let (loc,qid) = qualid_of_reference r in
+  try match Syntax_def.locate_global qid with
+    | IndRef ind -> ind
+    | _ -> user_err_loc (loc,"",str "Inductive type expected")
+  with Not_found -> error_global_not_found_loc loc qid
+
+let on_goal f =
+  let gls = nth_goal_of_pftreestate 1 (get_pftreestate ()) in
+  f (it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls))
+
+type whelp_request =
+  | Locate of string
+  | Elim of inductive
+  | Constr of string * constr
+
+let whelp = function
+  | Locate s -> whelp_locate s
+  | Elim ind -> whelp_elim ind
+  | Constr (s,c) -> whelp_constr s c
+
+VERNAC ARGUMENT EXTEND whelp_constr_request
+| [ "Match" ] -> [ "match" ]
+| [ "Instance" ] -> [ "instance" ]
+END
+
+VERNAC COMMAND EXTEND Whelp
+| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ] 
+| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ] 
+| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (locate_inductive r) ] 
+| [ "Whelp" whelp_constr_request(req) constr(c) ] -> [ whelp_constr_expr req c]
+END
+
+VERNAC COMMAND EXTEND WhelpHint
+| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ] 
+| [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ] 
+END
diff --git a/theories7/Reals/SplitRmult.v b/toplevel/whelp.mli
index 392675c3..f3f7408a 100644
--- a/theories7/Reals/SplitRmult.v
+++ b/toplevel/whelp.mli
@@ -6,14 +6,19 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: SplitRmult.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
+(*i $Id: whelp.mli 7837 2006-01-11 09:47:32Z herbelin $ i*)
 
-(*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*)
+(* Coq interface to the Whelp query engine developed at 
+   the University of Bologna *)
 
+open Names
+open Term
+open Topconstr
+open Environ
 
-Require Rbase.
-
-Recursive Tactic Definition SplitRmult :=
-  Match Context With
-  | [ |- ~(Rmult ?1 ?2)==R0 ] -> Apply mult_non_zero; Split;Try SplitRmult.
+type whelp_request =
+  | Locate of string
+  | Elim of inductive
+  | Constr of string * constr
 
+val whelp : whelp_request -> unit
diff --git a/translate/ppconstrnew.ml b/translate/ppconstrnew.ml
deleted file mode 100644
index 381ac2c3..00000000
--- a/translate/ppconstrnew.ml
+++ /dev/null
@@ -1,965 +0,0 @@
-(************************************************************************)
-(*  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: ppconstrnew.ml,v 1.62.2.6 2005/03/08 10:13:45 herbelin Exp $ *)      
-
-(*i*)
-open Ast
-open Util
-open Pp
-open Nametab
-open Names
-open Nameops
-open Libnames
-open Coqast
-open Ppextend
-open Topconstr
-open Term
-open Pattern
-(*i*)
-
-let pr_id id = Nameops.pr_id (Constrextern.v7_to_v8_id id)
-
-let sep_p = fun _ -> str"."
-let sep_v = fun _ -> str"," ++ spc()
-let sep_pp = fun _ -> str":"
-let sep_bar = fun _ -> spc() ++ str"| "
-let pr_tight_coma () = str "," ++ cut ()
-
-let latom = 0
-let lannot = 100
-let lprod = 200
-let llambda = 200
-let lif = 200
-let lletin = 200
-let lfix = 200
-let larrow = 90
-let lcast = 100
-let larg = 9
-let lapp = 10
-let lposint = 0
-let lnegint = 35 (* must be consistent with Notation "- x" *)
-let ltop = (200,E)
-let lproj = 1
-let lsimple = (1,E)
-
-let prec_less child (parent,assoc) =
-  if parent < 0 && child = lprod then true
-  else
-    let parent = abs parent in
-    match assoc with
-      | E -> (<=) child parent
-      | L -> (<) child parent
-      | Prec n -> child<=n
-      | Any -> true
-
-let env_assoc_value v env =
-  try List.nth env (v-1)
-  with Not_found -> anomaly ("Inconsistent environment for pretty-print rule")
-
-let decode_constrlist_value = function
-  | CAppExpl (_,_,l) -> l
-  | CApp (_,_,l) -> List.map fst l
-  | _ -> anomaly "Ill-formed list argument of notation"
-
-let decode_patlist_value = function
-  | CPatCstr (_,_,l) -> l
-  | _ -> anomaly "Ill-formed list argument of notation"
-
-open Symbols
-
-let rec print_hunk n decode pr env = function
-  | UnpMetaVar (e,prec) -> pr (n,prec) (env_assoc_value e env)
-  | UnpListMetaVar (e,prec,sl) -> 
-      prlist_with_sep (fun () -> prlist (print_hunk n decode pr env) sl)
-      (pr (n,prec)) (decode (env_assoc_value e env))
-  | UnpTerminal s -> str s
-  | UnpBox (b,sub) -> ppcmd_of_box b (prlist (print_hunk n decode pr env) sub)
-  | UnpCut cut -> ppcmd_of_cut cut
-
-let pr_notation_gen decode pr s env =
-  let unpl, level = find_notation_printing_rule s in
-  prlist (print_hunk level decode pr env) unpl, level
-
-let pr_notation = pr_notation_gen decode_constrlist_value
-let pr_patnotation = pr_notation_gen decode_patlist_value
-
-let pr_delimiters key strm =
-  strm ++ str ("%"^key)
-
-let surround p = hov 1 (str"(" ++ p ++ str")")
-
-let pr_located pr ((b,e),x) =
-  if Options.do_translate() && (b,e)<>dummy_loc then
-    let (b,e) = unloc (b,e) in
-    comment b ++ pr x ++ comment e
-  else pr x
-
-let pr_com_at n =
-  if Options.do_translate() && n <> 0 then comment n 
-  else mt()
-
-let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
-
-let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
-
-open Rawterm
-
-let pr_opt pr = function
-  | None -> mt ()
-  | Some x -> spc() ++ pr x
-
-let pr_optc pr = function
-  | None -> mt ()
-  | Some x -> pr_sep_com spc pr x
-
-let pr_universe = Univ.pr_uni
-
-let pr_sort = function
-  | RProp Term.Null -> str "Prop"
-  | RProp Term.Pos -> str "Set"
-  | RType u -> str "Type" ++ pr_opt pr_universe u
-
-let pr_expl_args pr (a,expl) =
-  match expl with
-  | None -> pr (lapp,L) a
-  | Some (_,ExplByPos n) ->
-      anomaly("Explicitation by position not implemented")
-  | Some (_,ExplByName id) -> 
-      str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")"
-
-let pr_opt_type pr = function
-  | CHole _ -> mt ()
-  | t -> cut () ++ str ":" ++ pr t
-
-let pr_opt_type_spc pr = function
-  | CHole _ -> mt ()
-  | t ->  str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t
-
-let pr_name = function
-  | Anonymous -> str"_"
-  | Name id -> pr_id id
-
-let pr_lident (b,_ as loc,id) =
-  if loc <> dummy_loc then
-    let (b,_) = unloc loc in
-    pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id)
-  else pr_id id
-
-let pr_lname = function
-    (loc,Name id) -> pr_lident (loc,id)
-  | lna -> pr_located pr_name lna
-
-let pr_or_var pr = function
-  | Genarg.ArgArg x -> pr x
-  | Genarg.ArgVar (loc,s) -> pr_lident (loc,s)
-
-let las = lapp
-
-let rec pr_patt sep inh p =
-  let (strm,prec) = match p with
-  | CPatAlias (_,p,id) ->
-      pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
-  | CPatCstr (_,c,[]) -> pr_reference c, latom
-  | CPatCstr (_,c,args) ->
-      pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
-  | CPatAtom (_,None) -> str "_", latom
-  | CPatAtom (_,Some r) -> pr_reference r, latom
-  | CPatNotation (_,"( _ )",[p]) ->
-      pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom
-  | CPatNotation (_,s,env) -> pr_patnotation (pr_patt mt) s env
-  | CPatNumeral (_,i) -> Bignat.pr_bigint i, latom
-  | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1
-  in
-  let loc = cases_pattern_loc p in
-  pr_with_comments loc
-    (sep() ++ if prec_less prec inh then strm else surround strm)
-
-let pr_patt = pr_patt mt
-
-
-let pr_eqn pr (loc,pl,rhs) =
-  spc() ++ hov 4
-    (pr_with_comments loc
-      (str "| " ++
-      hov 0 (prlist_with_sep sep_v (pr_patt ltop) pl ++ str " =>") ++
-      pr_sep_com spc (pr ltop) rhs))
-
-let begin_of_binder = function
-    LocalRawDef((loc,_),_) -> fst (unloc loc)
-  | LocalRawAssum((loc,_)::_,_) -> fst (unloc loc)
-  | _ -> assert false
-
-let begin_of_binders = function
-  | b::_ -> begin_of_binder b
-  | _ -> 0
-
-let pr_binder many pr (nal,t) =
-  match t with
-  | CHole _ -> prlist_with_sep spc pr_lname nal
-  | _ ->
-    let s = prlist_with_sep spc pr_lname nal ++ str" : " ++ pr t in
-    hov 1 (if many then surround s else s)
-
-let pr_binder_among_many pr_c = function
-  | LocalRawAssum (nal,t) ->
-      pr_binder true pr_c (nal,t)
-  | LocalRawDef (na,c) ->
-      let c,topt = match c with
-        | CCast(_,c,t) -> c, t
-        | _ -> c, CHole dummy_loc in
-      hov 1 (surround
-        (pr_lname na ++ pr_opt_type pr_c topt ++
-         str":=" ++ cut() ++ pr_c c))
-
-let pr_undelimited_binders pr_c =
-  prlist_with_sep spc (pr_binder_among_many pr_c)
-
-let pr_delimited_binders kw pr_c bl =
-  let n = begin_of_binders bl in
-  match bl with
-  | [LocalRawAssum (nal,t)] ->
-      pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,t)
-  | LocalRawAssum _ :: _ as bdl ->
-      pr_com_at n ++ kw() ++ pr_undelimited_binders pr_c bdl
-  | _ -> assert false
-
-let pr_let_binder pr x a =
-  hov 0 (hov 0 (pr_name x ++ brk(0,1) ++ str ":=") ++
-         pr_sep_com (fun () -> brk(0,1)) (pr ltop) a)
-
-let rec extract_prod_binders = function
-(*  | CLetIn (loc,na,b,c) as x ->
-      let bl,c = extract_prod_binders c in
-      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
-  | CProdN (loc,[],c) ->
-      extract_prod_binders c
-  | CProdN (loc,(nal,t)::bl,c) ->
-      let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in
-      LocalRawAssum (nal,t) :: bl, c
-  | c -> [], c
-
-let rec extract_lam_binders = function
-(*  | CLetIn (loc,na,b,c) as x ->
-      let bl,c = extract_lam_binders c in
-      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
-  | CLambdaN (loc,[],c) ->
-      extract_lam_binders c
-  | CLambdaN (loc,(nal,t)::bl,c) ->
-      let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
-      LocalRawAssum (nal,t) :: bl, c
-  | c -> [], c
-    
-let pr_global vars ref =
-  (* pr_global_env vars ref *)
-  let s = string_of_qualid (Constrextern.shortest_qualid_of_v7_global vars ref) in
-  (str s)
-
-let split_lambda = function
-  | CLambdaN (loc,[[na],t],c) -> (na,t,c)
-  | CLambdaN (loc,([na],t)::bl,c) -> (na,t,CLambdaN(loc,bl,c))
-  | CLambdaN (loc,(na::nal,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,t)::bl,c))
-  | _ -> anomaly "ill-formed fixpoint body"
-
-let rename na na' t c =
-  match (na,na') with
-    | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c)
-    | (_,Name id), (_,Anonymous) -> (na,t,c)
-    | _ -> (na',t,c)
-  
-let split_product na' = function
-  | CArrow (loc,t,c) -> (na',t,c)
-  | CProdN (loc,[[na],t],c) -> rename na na' t c
-  | CProdN (loc,([na],t)::bl,c) -> rename na na' t (CProdN(loc,bl,c))
-  | CProdN (loc,(na::nal,t)::bl,c) ->
-      rename na na' t (CProdN(loc,(nal,t)::bl,c))
-  | _ -> anomaly "ill-formed fixpoint body"
-
-let merge_binders (na1,ty1) cofun (na2,ty2) codom =
-  let na =
-    match snd na1, snd na2 with
-        Anonymous, Name id ->
-          if occur_var_constr_expr id cofun then
-            failwith "avoid capture"
-          else na2
-      | Name id, Anonymous ->
-          if occur_var_constr_expr id codom then
-            failwith "avoid capture"
-          else na1
-      | Anonymous, Anonymous -> na1
-      | Name id1, Name id2 ->
-          if id1 <> id2 then failwith "not same name" else na1 in
-  let ty =
-    match ty1, ty2 with
-        CHole _, _ -> ty2
-      | _, CHole _ -> ty1
-      | _ ->
-          Constrextern.check_same_type ty1 ty2;
-          ty2 in
-  (LocalRawAssum ([na],ty), codom)
-            
-let rec strip_domain bvar cofun c =
-  match c with
-    | CArrow(loc,a,b) ->
-        merge_binders bvar cofun ((dummy_loc,Anonymous),a) b
-    | CProdN(loc,[([na],ty)],c') ->
-        merge_binders bvar cofun (na,ty) c'
-    | CProdN(loc,([na],ty)::bl,c') ->
-        merge_binders bvar cofun (na,ty) (CProdN(loc,bl,c'))
-    | CProdN(loc,(na::nal,ty)::bl,c') ->
-        merge_binders bvar cofun (na,ty) (CProdN(loc,(nal,ty)::bl,c'))
-    | _ -> failwith "not a product"
-
-(* Note: binder sharing is lost *)
-let rec strip_domains (nal,ty) cofun c =
-  match nal with
-      [] -> assert false
-    | [na] ->
-        let bnd, c' = strip_domain (na,ty) cofun c in
-        ([bnd],None,c')
-    | na::nal ->
-        let f = CLambdaN(dummy_loc,[(nal,ty)],cofun) in
-        let bnd, c1 = strip_domain (na,ty) f c in
-        (try
-          let bl, rest, c2 = strip_domains (nal,ty) cofun c1 in
-          (bnd::bl, rest, c2)
-        with Failure _ -> ([bnd],Some (nal,ty), c1))
-
-(* Re-share binders *)
-let rec factorize_binders = function
-  | ([] | [_] as l) -> l
-  | LocalRawAssum (nal,ty) as d :: (LocalRawAssum (nal',ty')::l as l') ->
-      (try
-	let _ = Constrextern.check_same_type ty ty' in
-	factorize_binders (LocalRawAssum (nal@nal',ty)::l)
-      with _ ->
-	d :: factorize_binders l')
-  | d :: l -> d :: factorize_binders l
-
-(* Extract lambdas when a type constraint occurs *)
-let rec extract_def_binders c ty =
-  match c with
-    | CLambdaN(loc,bvar::lams,b) ->
-        (try
-          let f = CLambdaN(loc,lams,b) in
-          let bvar', rest, ty' = strip_domains bvar f ty in
-          let c' =
-            match rest, lams with
-                None,[] -> b
-              | None, _ -> f
-              | Some bvar,_ -> CLambdaN(loc,bvar::lams,b) in
-          let (bl,c2,ty2) = extract_def_binders c' ty' in
-          (factorize_binders (bvar'@bl), c2, ty2)
-        with Failure _ ->
-          ([],c,ty))
-    | _ -> ([],c,ty)
-
-let rec split_fix n typ def =
-  if n = 0 then ([],typ,def)
-  else
-    let (na,_,def) = split_lambda def in
-    let (na,t,typ) = split_product na typ in
-    let (bl,typ,def) = split_fix (n-1) typ def in
-    (LocalRawAssum ([na],t)::bl,typ,def)
-
-let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
-  let pr_body =
-    if dangling_with_for then pr_dangling else pr in
-  pr_id id ++ str" " ++
-  hov 0 (pr_undelimited_binders (pr ltop) bl ++ annot) ++
-  pr_opt_type_spc pr t ++ str " :=" ++
-  pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
-
-let pr_fixdecl pr prd dangling_with_for (id,n,bl,t,c) =
-  let annot =
-    let ids = names_of_local_assums bl in
-    if List.length ids > 1 then 
-      spc() ++ str "{struct " ++ pr_name (snd (List.nth ids n)) ++ str"}"
-    else mt() in
-  pr_recursive_decl pr prd dangling_with_for id bl annot t c
-
-let pr_cofixdecl pr prd dangling_with_for (id,bl,t,c) =
-  pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c
-
-let pr_recursive pr_decl id = function
-  | [] -> anomaly "(co)fixpoint with no definition"
-  | [d1] -> pr_decl false d1
-  | dl ->
-      prlist_with_sep (fun () -> fnl() ++ str "with ")
-        (pr_decl true) dl ++
-      fnl() ++ str "for " ++ pr_id id
-
-let pr_arg pr x = spc () ++ pr x
-
-let is_var id = function
-  | CRef (Ident (_,id')) when id=id' -> true
-  | _ -> false
-
-let tm_clash = function
-  | (CRef (Ident (_,id)), Some (CApp (_,_,nal))) 
-      when List.exists (function CRef (Ident (_,id')),_ -> id=id' | _ -> false)
-	nal
-      -> Some id
-  | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal))) 
-      when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false)
-	nal
-      -> Some id
-  | _ -> None
-
-let pr_case_item pr (tm,(na,indnalopt)) =
-  hov 0 (pr (lcast,E) tm ++
-(*
-  (match na with
-    | Name id when not (is_var id tm) -> spc () ++ str "as " ++  pr_id id
-    | Anonymous when tm_clash (tm,indnalopt) <> None ->
-	(* hide [tm] name to avoid conflicts *)
-	spc () ++ str "as _" (* ++ pr_id (out_some (tm_clash (tm,indnalopt)))*)
-    | _ -> mt ()) ++
-*)
-  (match na with (* Decision of printing "_" or not moved to constrextern.ml *)
-    | Some na -> spc () ++ str "as " ++  pr_name na
-    | None -> mt ()) ++
-  (match indnalopt with
-    | None -> mt ()
-(*
-    | Some (_,ind,nal) ->
-        spc () ++ str "in " ++ 
-        hov 0 (pr_reference ind ++ prlist (pr_arg pr_name) nal))
-*)
-    | Some t -> spc () ++ str "in " ++ pr lsimple t))
-
-let pr_case_type pr po =
-  match po with
-    | None | Some (CHole _) -> mt()
-    | Some p ->
-        spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimple) p)
-
-let pr_return_type pr po = pr_case_type pr po
-
-let pr_simple_return_type pr na po =
-  (match na with
-    | Some (Name id) ->
-        spc () ++ str "as " ++  pr_id id
-    | _ -> mt ()) ++
-  pr_case_type pr po
-
-let pr_proj pr pr_app a f l =
-  hov 0 (pr lsimple a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
-
-let pr_appexpl pr f l =
-      hov 2 (
-	str "@" ++ pr_reference f ++
-	prlist (pr_sep_com spc (pr (lapp,L))) l)
-
-let pr_app pr a l =
-  hov 2 (
-    pr (lapp,L) a  ++ 
-    prlist (fun a -> spc () ++ pr_expl_args pr a) l)
-
-let rec pr sep inherited a =
-  let (strm,prec) = match a with
-  | CRef r -> pr_reference r, latom
-  | CFix (_,id,fix) ->
-      hov 0 (str"fix " ++
-             pr_recursive
-               (pr_fixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) fix),
-      lfix
-  | CCoFix (_,id,cofix) ->
-      hov 0 (str "cofix " ++
-             pr_recursive
-              (pr_cofixdecl (pr mt) (pr_dangling_with_for mt)) (snd id) cofix),
-      lfix
-  | CArrow (_,a,b) ->
-      hov 0 (pr mt (larrow,L) a ++ str " ->" ++
-             pr (fun () ->brk(1,0)) (-larrow,E) b),
-      larrow
-  | CProdN _ ->
-      let (bl,a) = extract_prod_binders a in
-      hov 0 (
-	hov 2 (pr_delimited_binders (fun () -> str"forall" ++ spc())
-                 (pr mt ltop) bl) ++
-        str "," ++ pr spc ltop a),
-      lprod
-  | CLambdaN _ ->
-      let (bl,a) = extract_lam_binders a in
-      hov 0 (
-        hov 2 (pr_delimited_binders (fun () -> str"fun" ++ spc())
-                 (pr mt ltop) bl) ++
-
-        str " =>" ++ pr spc ltop a),
-      llambda
-  | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b)
-      when x=x' ->
-      hv 0 (
-        hov 2 (str "let " ++ pr mt ltop fx ++ str " in") ++
-        pr spc ltop b),
-      lletin
-  | CLetIn (_,x,a,b) ->
-      hv 0 (
-        hov 2 (str "let " ++ pr_lname x ++ str " :=" ++
-               pr spc ltop a ++ str " in") ++
-        pr spc ltop b),
-      lletin
-  | CAppExpl (_,(Some i,f),l) ->
-      let l1,l2 = list_chop i l in
-      let c,l1 = list_sep_last l1 in
-      let p = pr_proj (pr mt) pr_appexpl c f l1 in
-      if l2<>[] then
-	p ++ prlist (pr spc (lapp,L)) l2, lapp
-      else
-	p, lproj
-  | CAppExpl (_,(None,Ident (_,var)),[t])
-  | CApp (_,(_,CRef(Ident(_,var))),[t,None])
-        when var = Topconstr.ldots_var ->
-      hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg
-  | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp
-  | CApp (_,(Some i,f),l) ->
-      let l1,l2 = list_chop i l in
-      let c,l1 = list_sep_last l1 in
-      assert (snd c = None);
-      let p = pr_proj (pr mt) pr_app (fst c) f l1 in
-      if l2<>[] then 
-	p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp
-      else
-	p, lproj
-  | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp
-  | CCases (_,(po,rtntypopt),c,eqns) ->
-      v 0
-        (hv 0 (str "match" ++ brk (1,2) ++
-	  hov 0 (
-	    prlist_with_sep sep_v
-              (pr_case_item (pr_dangling_with_for mt)) c
-            ++ pr_case_type (pr_dangling_with_for mt) rtntypopt) ++
-	spc () ++ str "with") ++
-        prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"),
-      latom
-  | CLetTuple (_,nal,(na,po),c,b) ->
-      hv 0 (
-        str "let " ++
-	hov 0 (str "(" ++
-               prlist_with_sep sep_v pr_name nal ++
-               str ")" ++
-	       pr_simple_return_type (pr mt) na po ++ str " :=" ++
-               pr spc ltop c ++ str " in") ++
-        pr spc ltop b),
-      lletin
-  | CIf (_,c,(na,po),b1,b2) ->
-      (* On force les parenthèses autour d'un "if" sous-terme (même si le
-	 parsing est lui plus tolérant) *)
-      hv 0 (
-	hov 1 (str "if " ++ pr mt ltop c ++ pr_simple_return_type (pr mt) na po) ++
-	spc () ++
-	hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++
-	hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)),
-      lif
-     
-  | COrderedCase (_,st,po,c,[b1;b2]) when st = IfStyle ->
-      (* On force les parenthèses autour d'un "if" sous-terme (même si le
-	 parsing est lui plus tolérant) *)
-      hv 0 (
-	hov 1 (str "if " ++ pr mt ltop c ++
-                 pr_return_type (pr mt) po) ++ spc () ++
-	hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++
-	hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)),
-      lif
-  | COrderedCase (_,st,po,c,[CLambdaN(_,[nal,_],b)]) when st = LetStyle ->
-      hv 0 (
-        str "let " ++
-	hov 0 (str "(" ++
-               prlist_with_sep sep_v (fun (_,n) -> pr_name n) nal ++
-               str ")" ++
-	       pr_return_type (pr mt) po ++ str " :=" ++
-               pr spc ltop c ++ str " in") ++
-        pr spc ltop b),
-      lletin
-
-  | COrderedCase (_,style,po,c,bl) ->
-      hv 0 (
-	str (if style=MatchStyle then "old_match " else "match ") ++ 
-	pr mt ltop c ++
-	pr_return_type (pr_dangling_with_for mt) po ++
-	str " with" ++ brk (1,0) ++
-	hov 0 (prlist
-          (fun b -> str "| ??? =>" ++ pr spc ltop b ++ fnl ()) bl) ++
-        str "end"),
-      latom
-  | CHole _ -> str "_", latom
-  | CEvar (_,n) -> str (Evd.string_of_existential n), latom
-  | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom
-  | CSort (_,s) -> pr_sort s, latom
-  | CCast (_,a,b) ->
-      hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":" ++ pr mt (-lcast,E) b),
-      lcast
-  | CNotation (_,"( _ )",[t]) ->
-      pr (fun()->str"(") (max_int,L) t ++ str")", latom
-  | CNotation (_,s,env) -> pr_notation (pr mt) s env
-  | CNumeral (_,(Bignat.POS _ as p)) -> Bignat.pr_bigint p, lposint
-  | CNumeral (_,(Bignat.NEG _ as p)) -> Bignat.pr_bigint p, lnegint
-  | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1
-  | CDynamic _ -> str "<dynamic>", latom
-  in
-  let loc = constr_loc a in
-  pr_with_comments loc
-    (sep() ++ if prec_less prec inherited then strm else surround strm)
-
-and pr_dangling_with_for sep inherited a =
-  match a with
-  | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a
-  | _ -> pr sep inherited a
-
-let pr = pr mt
-
-let rec abstract_constr_expr c = function
-  | [] -> c
-  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl)
-  | LocalRawAssum (idl,t)::bl ->
-      List.fold_right (fun x b -> mkLambdaC([x],t,b)) idl
-      (abstract_constr_expr c bl)
-      
-let rec prod_constr_expr c = function
-  | [] -> c
-  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl)
-  | LocalRawAssum (idl,t)::bl ->
-      List.fold_right (fun x b -> mkProdC([x],t,b)) idl
-      (prod_constr_expr c bl)
-
-let rec strip_context n iscast t =
-  if n = 0 then
-    [], if iscast then match t with CCast (_,c,_) -> c | _ -> t else t
-  else match t with
-    | CLambdaN (loc,(nal,t)::bll,c) ->
-	let n' = List.length nal in
-	if n' > n then
-	  let nal1,nal2 = list_chop n nal in
-	  [LocalRawAssum (nal1,t)], CLambdaN (loc,(nal2,t)::bll,c)
-	else
-	let bl', c = strip_context (n-n') iscast
-	  (if bll=[] then c else CLambdaN (loc,bll,c)) in
-	LocalRawAssum (nal,t) :: bl', c 
-    | CProdN (loc,(nal,t)::bll,c) ->
-	let n' = List.length nal in
-	if n' > n then
-	  let nal1,nal2 = list_chop n nal in
-	  [LocalRawAssum (nal1,t)], CProdN (loc,(nal2,t)::bll,c)
-	else
-	let bl', c = strip_context (n-n') iscast
-	  (if bll=[] then c else CProdN (loc,bll,c)) in
-	LocalRawAssum (nal,t) :: bl', c 
-    | CArrow (loc,t,c) ->
-	let bl', c = strip_context (n-1) iscast c in
-	LocalRawAssum ([loc,Anonymous],t) :: bl', c 
-    | CCast (_,c,_) -> strip_context n false c
-    | CLetIn (_,na,b,c) -> 
-	let bl', c = strip_context (n-1) iscast c in
-	LocalRawDef (na,b) :: bl', c
-    | _ -> anomaly "ppconstrnew: strip_context"
-
-let transf istype env iscast bl c =
-  let c' =
-    if istype then prod_constr_expr c bl
-    else abstract_constr_expr c bl in
-  if Options.do_translate() then
-    let r = 
-      Constrintern.for_grammar
-        (Constrintern.interp_rawconstr_gen istype Evd.empty env false ([],[]))
-	c' in
-    begin try
-      (* Try to infer old case and type annotations *)
-      let _ = Pretyping.understand_gen_tcc Evd.empty env [] None r in 
-      (*msgerrnl (str "Typage OK");*) ()
-    with e -> (*msgerrnl (str "Warning: can't type")*) () end;
-    let c =
-      (if istype then Constrextern.extern_rawtype
-      else Constrextern.extern_rawconstr)
-      (Termops.vars_of_env env) r in
-    let n = local_binders_length bl in
-    strip_context n iscast c
-  else bl, c
-
-let pr_constr_env env c = pr lsimple (snd (transf false env false [] c))
-let pr_lconstr_env env c = pr ltop (snd (transf false env false [] c))
-let pr_constr c = pr_constr_env (Global.env()) c
-let pr_lconstr c = pr_lconstr_env (Global.env()) c
-
-let pr_binders = pr_undelimited_binders (pr ltop)
-
-let is_Eval_key c =
-  Options.do_translate () &
-  (let f id = let s = string_of_id id in s = "Eval" in
-  let g = function
-    | Ident(_,id) -> f id
-    | Qualid (_,qid) -> let d,id = repr_qualid qid in d = empty_dirpath & f id
-  in
-  match c with
-    | CRef ref | CApp (_,(_,CRef ref),_) when g ref -> true
-    | _ -> false)
-
-let pr_protect_eval c =
-  if is_Eval_key c then h 0 (str "(" ++ pr ltop c ++ str ")") else pr ltop c
-
-let pr_lconstr_env_n env iscast bl c =
-  let bl, c = transf false env iscast bl c in
-  bl, pr_protect_eval c
-let pr_type_env_n env bl c = pr ltop (snd (transf true env false bl c))
-let pr_type c = pr ltop (snd (transf true (Global.env()) false [] c))
-
-let transf_pattern env c =
-  if Options.do_translate() then
-    Constrextern.extern_rawconstr (Termops.vars_of_env env)
-      (Constrintern.for_grammar
-	(Constrintern.interp_rawconstr_gen false Evd.empty env true ([],[]))
-	c)
-  else c
-
-let pr_pattern c = pr lsimple (transf_pattern (Global.env()) c)
-
-let pr_rawconstr_env env c =
-  pr_constr (Constrextern.extern_rawconstr (Termops.vars_of_env env) c)
-let pr_lrawconstr_env env c =
-  pr_lconstr (Constrextern.extern_rawconstr (Termops.vars_of_env env) c)
-
-let pr_cases_pattern = pr_patt ltop
-
-let pr_pattern_occ prc = function
-    ([],c) -> prc c
-  | (nl,c) -> hov 1 (prc c ++ spc() ++ str"at " ++
-                     hov 0 (prlist_with_sep spc int nl))
-
-let pr_unfold_occ pr_ref = function
-    ([],qid) -> pr_ref qid
-  | (nl,qid) -> hov 1 (pr_ref qid ++ spc() ++ str"at " ++
-                       hov 0 (prlist_with_sep spc int nl))
-
-let pr_qualid qid = str (string_of_qualid qid)
-
-open Rawterm
-
-let pr_arg pr x = spc () ++ pr x
-
-let pr_red_flag pr r =
-  (if r.rBeta then pr_arg str "beta" else mt ()) ++
-  (if r.rIota then pr_arg str "iota" else mt ()) ++
-  (if r.rZeta then pr_arg str "zeta" else mt ()) ++
-  (if r.rConst = [] then
-     if r.rDelta then pr_arg str "delta"
-     else mt ()
-   else
-     pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++
-     hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]"))
-
-open Genarg
-
-let pr_metaid id = str"?" ++ pr_id id
-
-let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function
-  | Red false -> str "red"
-  | Hnf -> str "hnf"
-  | Simpl o -> str "simpl" ++ pr_opt (pr_pattern_occ pr_constr) o  
-  | Cbv f ->
-      if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then
-	str "compute"
-      else
-	hov 1 (str "cbv" ++ pr_red_flag pr_ref f)
-  | Lazy f -> 
-      hov 1 (str "lazy" ++ pr_red_flag pr_ref f)
-  | Unfold l ->
-      hov 1 (str "unfold" ++ spc() ++
-             prlist_with_sep pr_coma (pr_unfold_occ pr_ref) l)
-  | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l)
-  | Pattern l ->
-      hov 1 (str "pattern" ++
-        pr_arg (prlist_with_sep pr_coma (pr_pattern_occ pr_constr)) l)
-        
-  | Red true -> error "Shouldn't be accessible from user"
-  | ExtraRedExpr s -> str s
-
-let rec pr_may_eval test prc prlc pr2 = function
-  | ConstrEval (r,c) ->
-      hov 0
-        (str "eval" ++ brk (1,1) ++
-         pr_red_expr (prc,prlc,pr2) r ++
-	 str " in" ++ spc() ++ prc c)
-  | ConstrContext ((_,id),c) ->
-      hov 0
-	(str "context " ++ pr_id id ++ spc () ++
-	 str "[" ++ prlc c ++ str "]")
-  | ConstrTypeOf c -> hov 1 (str "type of" ++ spc() ++ prc c)
-  | ConstrTerm c when test c -> h 0 (str "(" ++ prc c ++ str ")")
-  | ConstrTerm c -> prc c
-
-let pr_may_eval a = pr_may_eval (fun _ -> false) a
-
-let pr_rawconstr_env_no_translate env c =
-  pr lsimple (Constrextern.extern_rawconstr (Termops.vars_of_env env) c)
-let pr_lrawconstr_env_no_translate env c =
-  pr ltop (Constrextern.extern_rawconstr (Termops.vars_of_env env) c)
-
-(* Printing reference with translation *)
-
-let pr_reference r =
-  let loc = loc_of_reference r in
-  try match Nametab.extended_locate (snd (qualid_of_reference r)) with
-    | TrueGlobal ref ->
-        pr_with_comments loc
-	  (pr_reference (Constrextern.extern_reference loc Idset.empty ref))
-    | SyntacticDef kn ->
-	let is_coq_root d =
-	  let d = repr_dirpath d in
-	  d <> [] & string_of_id (list_last d) = "Coq" in
-        let dir,id = repr_path (sp_of_syntactic_definition kn) in
-	let r =
-          if (is_coq_root (Lib.library_dp()) or is_coq_root dir) then
-	    (match Syntax_def.search_syntactic_definition loc kn with
-	      | RRef (_,ref) ->
-		  Constrextern.extern_reference dummy_loc Idset.empty ref
-              | _ -> r)
-          else r
-	in pr_with_comments loc (pr_reference r)
-  with Not_found ->
-    error_global_not_found (snd (qualid_of_reference r))
-
-(** constr printers *)
-
-let pr_term_env env  c = pr lsimple (Constrextern.extern_constr false env c)
-let pr_lterm_env env c = pr ltop    (Constrextern.extern_constr false env c)
-let pr_term  c = pr_term_env  (Global.env()) c
-let pr_lterm c = pr_lterm_env (Global.env()) c
-
-let pr_constr_pattern_env env c =
-  pr lsimple (Constrextern.extern_pattern env Termops.empty_names_context c)
-
-let pr_constr_pattern t =
-  pr lsimple
-    (Constrextern.extern_pattern (Global.env()) Termops.empty_names_context t)
-
-
-(************************************************************************)
-(* Automatic standardisation of names in Arith and ZArith by translator *)
-(* Very not robust *)
-
-let is_to_rename dir id =
-  let dirs = List.map string_of_id (repr_dirpath dir) in
-  match List.rev dirs with
-  | "Coq"::"Arith"::"Between"::_ -> false
-  | "Coq"::"ZArith"::
-    ("Wf_Z"|"Zpower"|"Zlogarithm"|"Zbinary"|"Zdiv"|"Znumtheory")::_ -> false
-  | "Coq"::("Arith"|"NArith"|"ZArith")::_ -> true
-  | "Coq"::"Init"::"Peano"::_ -> true
-  | "Coq"::"Init"::"Logic"::_ when string_of_id id = "iff_trans" -> true
-  | "Coq"::"Reals"::"RIneq"::_ -> true
-  | _ -> false
-
-let is_ref_to_rename ref =
-  let sp = sp_of_global ref in
-  is_to_rename (dirpath sp) (basename sp)
-
-let get_name (ln,lp,lz,ll,lr,lr') id refbase n =
-  let id' = string_of_id n in
-  (match id' with
-    | "nat" -> (id_of_string (List.hd ln),(List.tl ln,lp,lz,ll,lr,lr'))
-    | "positive" -> (id_of_string (List.hd lp),(ln,List.tl lp,lz,ll,lr,lr'))
-    | "Z" -> (id_of_string (List.hd lz),(ln,lp,List.tl lz,ll,lr,lr'))
-    | "Prop" when List.mem (string_of_id id) ["a";"b";"c"] -> 
-	(* pour iff_trans *)
-	(id_of_string (List.hd ll),(ln,lp,lz,List.tl ll,lr,lr'))
-    | "R" when (* Noms r,r1,r2 *)
-	refbase = "Rle_refl" or
-	refbase = "Rlt_monotony_contra" or 
-	refbase = "Rmult_le_reg_l" or 
-	refbase = "Rle_monotony_contra" or 
-	refbase = "Rge_monotony" ->
-	(id_of_string (List.hd lr')),(ln,lp,lz,ll,lr,List.tl lr')
-    | "R" when (* Noms r1,r2,r3,r4 *)
-	List.mem (string_of_id id)
-	  ["x";"y";"x'";"y'";"z";"t";"n";"m";"a";"b";"c";"p";"q"] 
-	& refbase <> "sum_inequa_Rle_lt"
-	-> 
-	(id_of_string (List.hd lr),(ln,lp,lz,ll,List.tl lr,lr'))
-    | _ -> id,(ln,lp,lz,ll,lr,lr'))
-
-let get_name_constr names id refbase t = match kind_of_term t with
-  | Ind ind ->
-      let n = basename (sp_of_global (IndRef ind)) in
-      get_name names id refbase n
-  | Const sp ->
-      let n = basename (sp_of_global (ConstRef sp)) in
-      get_name names id refbase n
-  | Sort _ -> get_name names id refbase (id_of_string "Prop")
-  | _ -> id,names
-
-let names = 
-  (["n";"m";"p";"q"],["p";"q";"r";"s"],["n";"m";"p";"q"],["A";"B";"C"],
-   ["r1";"r2";"r3";"r4"],["r";"r1";"r2"])
-
-let znames refbase t =
-  let rec aux c names = match kind_of_term c with
-    | Prod (Name id as na,t,c) ->
-	let (id,names) = get_name_constr names id refbase t in
-	(na,id) :: aux c names
-    | Prod (Anonymous,t,c) ->
-	(Anonymous,id_of_string "ZZ") :: aux c names
-    | _ -> []
-  in aux t names
-
-let get_name_raw names id refbase t = match t with
-  | CRef(Ident (_,n)) -> get_name names id refbase n
-  | CSort _ -> get_name names id refbase (id_of_string "Prop")
-  | _ -> id,names
-
-let rename_bound_variables id0 t =
-  if is_to_rename (Lib.library_dp()) id0 then
-  let refbase = string_of_id id0 in
-  let rec aux c names subst = match c with
-    | CProdN (loc,bl,c) ->
-	let rec aux2 names subst = function
-	  | (nal,t)::bl ->
-	      let rec aux3 names subst = function
-		| (loc,Name id)::nal ->
-		    let (id',names) = get_name_raw names id refbase t in
-		    let (nal,names,subst) = aux3 names ((id,id')::subst) nal in
-		    (loc,Name id')::nal, names, subst
-		| x::nal -> 
-		    let (nal,names,subst) = aux3 names subst nal in
-		    x::nal,names,subst
-		| [] -> [],names,subst in
-	      let t = replace_vars_constr_expr subst t in
-	      let nal,names,subst = aux3 names subst nal in
-	      let bl,names,subst = aux2 names subst bl in
-	      (nal,t)::bl, names, subst
-	  | [] -> [],names,subst in
-	let bl,names,subst = aux2 names subst bl in
-	CProdN (loc,bl,aux c names subst)
-    | CArrow (loc,t,u) ->
-	let u = aux u names subst in
-	CArrow (loc,replace_vars_constr_expr subst t,u)
-    | _ -> replace_vars_constr_expr subst c
-  in aux t names []
-  else t
-
-let translate_binding kn n ebl =
-  let t = Retyping.get_type_of (Global.env()) Evd.empty (mkConst kn) in
-  let subst= znames (string_of_id (basename (sp_of_global (ConstRef kn)))) t in
-  try
-    let _,subst' = list_chop n subst in
-    List.map (function
-      | (x,NamedHyp id,c) -> (x,NamedHyp (List.assoc (Name id) subst'),c)
-      |  x -> x) ebl
-  with _ -> ebl
-
-let translate_with_bindings c bl =
-  match bl with
-  | ExplicitBindings l ->
-      let l = match c with
-	| RRef (_,(ConstRef kn as ref)) when is_ref_to_rename ref -> 
-	    translate_binding kn 0 l
-	| RApp (_,RRef (_,(ConstRef kn as ref)),args) when is_ref_to_rename ref
-	    -> translate_binding kn (List.length args) l
-	| _ ->
-	    l
-      in ExplicitBindings l
-    | x -> x
diff --git a/translate/ppconstrnew.mli b/translate/ppconstrnew.mli
deleted file mode 100644
index 4a488499..00000000
--- a/translate/ppconstrnew.mli
+++ /dev/null
@@ -1,100 +0,0 @@
-(************************************************************************)
-(*  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: ppconstrnew.mli,v 1.16.2.2 2005/01/21 17:17:20 herbelin Exp $ i*)
-
-open Pp
-open Environ
-open Term
-open Libnames
-open Pcoq
-open Rawterm
-open Extend
-open Coqast
-open Topconstr
-open Names
-open Util
-open Genarg
-
-val extract_lam_binders :
-  constr_expr -> local_binder list * constr_expr
-val extract_prod_binders :
-  constr_expr -> local_binder list * constr_expr
-val extract_def_binders :
-  constr_expr -> constr_expr ->
-  local_binder list * constr_expr * constr_expr
-val split_fix :
-  int -> constr_expr -> constr_expr -> 
-  local_binder list *  constr_expr * constr_expr
-val pr_binders : local_binder list -> std_ppcmds
-
-val prec_less : int -> int * Ppextend.parenRelation -> bool
- 
-val pr_global : Idset.t -> global_reference -> std_ppcmds
- 
-val pr_tight_coma : unit -> std_ppcmds
-val pr_located :
-  ('a -> std_ppcmds) -> 'a located -> std_ppcmds
-val pr_lident : identifier located -> std_ppcmds
-val pr_lname : name located -> std_ppcmds
-
-val pr_with_comments : loc -> std_ppcmds -> std_ppcmds
-val pr_com_at : int -> std_ppcmds
-val pr_sep_com :
-  (unit -> std_ppcmds) ->
-  (constr_expr -> std_ppcmds) ->
-  constr_expr -> std_ppcmds
-val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
-val pr_id : identifier -> std_ppcmds
-val pr_name : name -> std_ppcmds
-val pr_qualid : qualid -> std_ppcmds
-val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
-val pr_metaid : identifier -> std_ppcmds
-val pr_red_expr :
-  ('a -> std_ppcmds) * ('a -> std_ppcmds) *  ('b -> std_ppcmds) ->
-    ('a,'b) red_expr_gen -> std_ppcmds
-
-val pr_sort : rawsort -> std_ppcmds
-val pr_pattern : Tacexpr.pattern_expr -> std_ppcmds
-val pr_constr : constr_expr -> std_ppcmds
-val pr_lconstr : constr_expr -> std_ppcmds
-val pr_constr_env : env -> constr_expr -> std_ppcmds
-val pr_lconstr_env : env -> constr_expr -> std_ppcmds
-val pr_lconstr_env_n : env -> bool -> local_binder list -> constr_expr -> 
-  local_binder list * std_ppcmds
-val pr_type_env_n : env -> local_binder list -> constr_expr -> std_ppcmds
-val pr_type : constr_expr -> std_ppcmds
-val pr_cases_pattern : cases_pattern_expr -> std_ppcmds
-val pr_may_eval :
-  ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('a,'b) may_eval
-    -> std_ppcmds
-val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr
-val prod_constr_expr : constr_expr -> local_binder list -> constr_expr
-
-
-val pr_rawconstr_env : env -> rawconstr -> std_ppcmds
-val pr_lrawconstr_env : env -> rawconstr -> std_ppcmds
-
-val pr_rawconstr_env_no_translate : env -> rawconstr -> std_ppcmds
-val pr_lrawconstr_env_no_translate : env -> rawconstr -> std_ppcmds
-
-val pr_reference : reference -> std_ppcmds
-
-(** constr printers *)
-
-val pr_term_env : env -> constr -> std_ppcmds
-val pr_lterm_env : env -> constr -> std_ppcmds
-val pr_term : constr -> std_ppcmds
-val pr_lterm : constr -> std_ppcmds
-
-val pr_constr_pattern_env : env -> Pattern.constr_pattern -> std_ppcmds
-val pr_constr_pattern : Pattern.constr_pattern -> std_ppcmds
-
-(* To translate names in ZArith *)
-val translate_with_bindings : rawconstr -> 'a bindings -> 'a bindings
-val rename_bound_variables : identifier -> constr_expr -> constr_expr
diff --git a/translate/pptacticnew.ml b/translate/pptacticnew.ml
deleted file mode 100644
index 7da30c4e..00000000
--- a/translate/pptacticnew.ml
+++ /dev/null
@@ -1,905 +0,0 @@
-(************************************************************************)
-(*  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: pptacticnew.ml,v 1.57.2.3 2005/05/15 12:47:03 herbelin Exp $ *)
-
-open Pp
-open Names
-open Nameops
-open Environ
-open Util
-open Extend
-open Ppextend
-open Ppconstrnew
-open Tacexpr
-open Rawterm
-open Topconstr
-open Genarg
-open Libnames
-open Pptactic
-
-let sep_v = fun _ -> str"," ++ spc()
-
-let strip_prod_binders_expr n ty =
-  let rec strip_ty acc n ty =
-    match ty with
-        Topconstr.CProdN(_,bll,a) ->
-          let nb =
-            List.fold_left (fun i (nal,_) -> i + List.length nal) 0 bll in
-          if nb >= n then (List.rev (bll@acc), a)
-          else strip_ty (bll@acc) (n-nb) a
-      | Topconstr.CArrow(_,a,b) ->
-          if n=1 then
-            (List.rev (([(dummy_loc,Anonymous)],a)::acc), b)
-          else strip_ty (([(dummy_loc,Anonymous)],a)::acc) (n-1) b
-      | _ -> error "Cannot translate fix tactic: not enough products" in
-  strip_ty [] n ty
-
-
-(* In v8 syntax only double quote char is escaped by repeating it *)
-let rec escape_string_v8 s =
-  let rec escape_at s i =
-    if i<0 then s
-    else if s.[i] == '"' then
-      let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in
-      escape_at s' (i-1)
-    else escape_at s (i-1) in
-  escape_at s (String.length s - 1)
-
-let qstringnew s = str ("\""^escape_string_v8 s^"\"")
-let qsnew = qstringnew
-
-let translate_v7_ltac = function
-  | "DiscrR" -> "discrR"
-  | "Sup0" -> "prove_sup0"
-  | "SupOmega" -> "omega_sup"
-  | "Sup" -> "prove_sup"
-  | "RCompute" -> "Rcompute"
-  | "IntroHypG" -> "intro_hyp_glob"
-  | "IntroHypL" -> "intro_hyp_pt"
-  | "IsDiff_pt" -> "is_diff_pt"
-  | "IsDiff_glob" -> "is_diff_glob"
-  | "IsCont_pt" -> "is_cont_pt"
-  | "IsCont_glob" -> "is_cont_glob"
-  | "RewTerm" -> "rew_term"
-  | "ConsProof" -> "deriv_proof"
-  | "SimplifyDerive" -> "simplify_derive"
-  | "Reg" -> "reg" (* ??? *)
-  | "SplitAbs" -> "split_case_Rabs"
-  | "SplitAbsolu" -> "split_Rabs"
-  | "SplitRmult" -> "split_Rmult"
-  | "CaseEqk" -> "case_eq"
-  | "SqRing" -> "ring_Rsqr"
-  | "TailSimpl" -> "tail_simpl"
-  | "CoInduction" -> "coinduction"
-  | "ElimCompare" -> "elim_compare"
-  | "CCsolve" -> "CCsolve"  (* ?? *)
-  | "ArrayAccess" -> "array_access"
-  | "MemAssoc" -> "mem_assoc"
-  | "SeekVarAux" -> "seek_var_aux"
-  | "SeekVar" -> "seek_var"
-  | "NumberAux" -> "number_aux"
-  | "Number" -> "number"
-  | "BuildVarList" -> "build_varlist"
-  | "Assoc" -> "assoc"
-  | "Remove" -> "remove"
-  | "Union" -> "union"
-  | "RawGiveMult" -> "raw_give_mult"
-  | "GiveMult" -> "give_mult"
-  | "ApplyAssoc" -> "apply_assoc"
-  | "ApplyDistrib" -> "apply_distrib"
-  | "GrepMult" -> "grep_mult"
-  | "WeakReduce" -> "weak_reduce"
-  | "Multiply" -> "multiply"
-  | "ApplyMultiply" -> "apply_multiply"
-  | "ApplyInverse" -> "apply_inverse"
-  | "StrongFail" -> "strong_fail"
-  | "InverseTestAux" -> "inverse_test_aux"
-  | "InverseTest" -> "inverse_test"
-  | "ApplySimplif" -> "apply_simplif"
-  | "Unfolds" -> "unfolds"
-  | "Reduce" -> "reduce"
-  | "Field_Gen_Aux" -> "field_gen_aux"
-  | "Field_Gen" -> "field_gen"
-  | "EvalWeakReduce" -> "eval_weak_reduce"
-  | "Field_Term" -> "field_term"
-  | "Fourier" -> "fourier" (* ou Fourier ?? *)
-  | "FourierEq" -> "fourier_eq"
-  | "S_to_plus" -> "rewrite_S_to_plus_term"
-  | "S_to_plus_eq" -> "rewrite_S_to_plus"
-  | "NatRing" -> "ring_nat"
-  | "Solve1" -> "solve1"
-  | "Solve2" -> "solve2"
-  | "Elim_eq_term" -> "elim_eq_term"
-  | "Elim_eq_Z" -> "elim_eq_Z"
-  | "Elim_eq_pos" -> "elim_eq_pos"
-  | "Elim_Zcompare" -> "elim_Zcompare"
-  | "ProveStable" -> "prove_stable"
-  | "interp_A" -> "interp_A"
-  | "InitExp" -> "init_exp"
-  | "SimplInv" -> "simpl_inv"
-  | "Map" -> "map_tactic"
-  | "BuildMonomAux" -> "build_monom_aux"
-  | "BuildMonom" -> "build_monom"
-  | "SimplMonomAux" -> "simpl_monom_aux"
-  | "SimplMonom" -> "simpl_monom"
-  | "SimplAllMonoms" -> "simpl_all_monomials"
-  | "AssocDistrib" -> "assoc_distrib"
-  | "NowShow" -> "now_show"
-  | ("subst"|"simpl"|"elim"|"destruct"|"apply"|"intro" (* ... *)) as x ->
-      let x' = x^"_" in
-      msgerrnl
-      (str ("Warning: '"^
-         x^"' is now a primitive tactic; it has been translated to '"^x'^"'"));
-      x'
-  | x -> x
-
-let id_of_ltac_v7_id id = 
-  id_of_string (translate_v7_ltac (string_of_id id))
-
-let pr_ltac_or_var pr = function
-  | ArgArg x -> pr x
-  | ArgVar (loc,id) ->
-      pr_with_comments loc (pr_id (id_of_ltac_v7_id id))
-
-let pr_arg pr x = spc () ++ pr x
-
-let pr_ltac_constant sp =
-  (* Source de bug: le nom le plus court n'est pas forcement correct 
-     apres renommage *)
-  let qid = Nametab.shortest_qualid_of_tactic sp in
-  let dir,id = repr_qualid qid in
-  pr_qualid (make_qualid dir (id_of_ltac_v7_id id))
-
-let pr_evaluable_reference_env env = function 
-  | EvalVarRef id -> pr_id (Constrextern.v7_to_v8_id id)
-  | EvalConstRef sp -> pr_global (Termops.vars_of_env env) (Libnames.ConstRef sp)
-
-let pr_inductive vars ind = pr_global vars (Libnames.IndRef ind)
-
-let pr_quantified_hypothesis = function
-  | AnonHyp n -> int n
-  | NamedHyp id -> pr_id id 
-
-let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
-
-(*
-let pr_binding prc = function
-  | NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
-  | AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
-*)
-
-let pr_esubst prc l =
-  let pr_qhyp = function
-      (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
-    | (_,NamedHyp id,c) ->
-        str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")"
-  in
-  prlist_with_sep spc pr_qhyp l
-
-let pr_bindings_gen for_ex prlc prc = function
-  | ImplicitBindings l ->
-      spc () ++
-      hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
-            prlist_with_sep spc prc l)
-  | ExplicitBindings l ->
-      spc () ++
-      hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
-            pr_esubst prlc l)
-  | NoBindings -> mt ()
-
-let pr_bindings prlc prc = pr_bindings_gen false prlc prc
-
-let pr_with_bindings prlc prc (c,bl) =
-  if Options.do_translate () then
-    (* translator calls pr_with_bindings on rawconstr: we cast it! *)
-    let bl' = translate_with_bindings (fst (Obj.magic c) : rawconstr) bl in
-    hov 1 (prc c ++ pr_bindings prlc prc bl')
-  else
-    hov 1 (prc c ++ pr_bindings prlc prc bl)
-
-let pr_with_constr prc = function
-  | None -> mt ()
-  | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
-
-(* Translator copy of pr_intro_pattern based on a translating "pr_id" *)
-let rec pr_intro_pattern = function
-  | IntroOrAndPattern pll -> pr_case_intro_pattern pll
-  | IntroWildcard -> str "_"
-  | IntroIdentifier id -> pr_id id
-and pr_case_intro_pattern = function
-  | [_::_ as pl] ->
-      str "(" ++ hov 0 (prlist_with_sep pr_coma pr_intro_pattern pl) ++ str ")"
-  | pll ->
-      str "[" ++
-      hv 0 (prlist_with_sep pr_bar 
-        (fun l -> hov 0 (prlist_with_sep spc pr_intro_pattern l)) pll)
-      ++ str "]"
-
-let pr_with_names = function
-  | None -> mt ()
-  | Some ipat -> spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat)
-
-let pr_occs pp = function
-    [] -> pp
-  | nl -> hov 1 (pp ++ spc() ++ str"at " ++
-                 hov 0 (prlist_with_sep spc int nl))
-
-let pr_hyp_location pr_id = function
-  | id, occs, InHyp -> spc () ++ pr_occs (pr_id id) occs
-  | id, occs, InHypTypeOnly ->
-      spc () ++ pr_occs (str "(type of " ++ pr_id id ++ str ")") occs
-  | id, occs, InHypValueOnly ->
-      spc () ++ pr_occs (str "(value of " ++ pr_id id ++ str ")") occs
-
-let pr_hyp_location pr_id (id,occs,(hl,hl')) =
-  if !hl' <> None then pr_hyp_location pr_id (id,occs,out_some !hl')
-  else
-    (if hl = InHyp && Options.do_translate () then 
-      msgerrnl (h 0 (str "Translator warning: Unable to detect if " ++ pr_id id ++ spc () ++ str "denotes a local definition"));
-    pr_hyp_location pr_id (id,occs,hl))
-
-let pr_in pp = spc () ++ hov 0 (str "in" ++ pp)
-
-let pr_simple_clause pr_id = function
-  | [] -> mt ()
-  | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
-
-let pr_clauses pr_id = function
-    { onhyps=None; onconcl=true; concl_occs=nl } ->
-      pr_in (pr_occs (str " *") nl)
-  | { onhyps=None; onconcl=false } -> pr_in (str " * |-")
-  | { onhyps=Some l; onconcl=true; concl_occs=nl } -> 
-      pr_in (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l
-             ++ pr_occs (str" |- *") nl)
-  | { onhyps=Some l; onconcl=false } ->
-      pr_in (prlist_with_sep (fun()->str",") (pr_hyp_location pr_id) l)
-
-let pr_clause_pattern pr_id = function
-  | (None, []) -> mt ()
-  | (glopt,l) ->
-      str " in" ++
-      prlist
-        (fun (id,nl) -> prlist (pr_arg int) nl 
-	  ++ spc () ++ pr_id id) l ++
-        pr_opt (fun nl -> prlist_with_sep spc int nl ++ str " Goal") glopt
-
-let pr_induction_arg prc = function
-  | ElimOnConstr c -> prc c
-  | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id)
-  | ElimOnAnonHyp n -> int n
-
-let pr_induction_kind = function
-  | SimpleInversion -> str "simple inversion"
-  | FullInversion -> str "inversion"
-  | FullInversionClear -> str "inversion_clear"
-
-let pr_match_pattern pr_pat = function
-  | Term a -> pr_pat a
-  | Subterm (None,a) -> str "context [" ++ pr_pat a ++ str "]"
-  | Subterm (Some id,a) ->
-      str "context " ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]"
-
-let pr_match_hyps pr_pat = function
-  | Hyp (nal,mp) -> pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp
-
-let pr_match_rule m pr pr_pat = function
-  | Pat ([],mp,t) when m ->
-      pr_match_pattern pr_pat mp ++
-      spc () ++ str "=>" ++ brk (1,4) ++ pr t
-  | Pat (rl,mp,t) ->
-      prlist_with_sep (fun () -> str",") (pr_match_hyps pr_pat) rl ++
-      spc () ++ str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
-      str "=>" ++ brk (1,4) ++ pr t
-  | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t
-
-let pr_funvar = function
-  | None -> spc () ++ str "_"
-  | Some id -> spc () ++ pr_id id
-
-let pr_let_clause k pr = function
-  | (id,None,t) ->
-      hov 0 (str k ++ pr_lident id ++ str " :=" ++ brk (1,1) ++
-             pr (TacArg t))
-  | (id,Some c,t) ->
-      hv 0 (str k ++ pr_lident id ++ str" :" ++ brk(1,2) ++
-      pr c ++
-      str " :=" ++ brk (1,1) ++ pr (TacArg t))
-
-let pr_let_clauses pr = function
-  | hd::tl ->
-      hv 0
-        (pr_let_clause "let " pr hd ++
-         prlist (fun t -> spc () ++ pr_let_clause "with " pr t) tl)
-  | [] -> anomaly "LetIn must declare at least one binding"
-
-let pr_rec_clause pr (id,(l,t)) =
-  hov 0
-    (pr_lident id ++ prlist pr_funvar l ++ str " :=") ++ spc () ++ pr t
-
-let pr_rec_clauses pr l = 
-  prlist_with_sep (fun () -> fnl () ++ str "with ") (pr_rec_clause pr) l
-
-let pr_seq_body pr tl =
-  hv 0 (str "[ " ++
-        prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
-        str " ]")
-
-let pr_as_names_force force ids (pp,ids') =
-  pr_with_names 
-    (if (!pp or force) & List.exists ((<>) (ref [])) ids'
-    then Some (IntroOrAndPattern (List.map (fun x -> !x) ids'))
-    else ids)
-
-let duplicate force nodup ids pr = function
-  | [] -> pr (pr_as_names_force force ids (ref false,[]))
-  | x::l when List.for_all (fun y -> snd x=snd y) l ->
-      pr (pr_as_names_force force ids x)
-  | l ->
-     if List.exists (fun (b,ids) -> !b) l & (force or
-	 List.exists (fun (_,ids) -> ids <> (snd (List.hd l))) (List.tl l))
-      then 
-        if nodup then begin
-          msgerrnl
-            (h 0 (str "Translator warning: Unable to enforce v7 names while translating Induction/NewDestruct/NewInduction. Names in the different branches are") ++ brk (0,0) ++
-            hov 0 (prlist_with_sep spc
-              (fun id -> hov 0 (pr_as_names_force true ids id))
-              (List.rev l)));
-          pr (pr_as_names_force force ids (ref false,[]))
-        end
-        else
-          pr_seq_body (fun x -> pr (pr_as_names_force force ids x)) (List.rev l)
-      else pr (pr_as_names_force force ids (ref false,[]))
-
-let pr_hintbases = function
-  | None -> spc () ++ str "with *"
-  | Some [] -> mt ()
-  | Some l ->
-      spc () ++ hov 2 (str "with" ++ prlist (fun s -> spc () ++ str s) l)
-
-let pr_autoarg_adding = function
-  | [] -> mt ()
-  | l ->
-      spc () ++ str "adding [" ++
-        hv 0 (prlist_with_sep spc pr_reference l) ++ str "]"
-
-let pr_autoarg_destructing = function
-  | true -> spc () ++ str "destructing"
-  | false -> mt ()
-
-let pr_autoarg_usingTDB = function
-  | true -> spc () ++ str "using tdb"
-  | false -> mt ()
-
-let rec pr_tacarg_using_rule pr_gen = function
-  | Egrammar.TacTerm s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al)
-  | Egrammar.TacNonTerm _ :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule pr_gen (l,al)
-  | [], [] -> mt ()
-  | _ -> failwith "Inconsistent arguments of extended tactic"
-
-let pr_then () = str ";"
-
-
-open Closure
-
-let make_pr_tac (pr_tac,pr_tac0,pr_constr,pr_lconstr,pr_pat,pr_cst,pr_ind,pr_ref,pr_ident,pr_extend,strip_prod_binders) =
-
-let pr_bindings env = pr_bindings (pr_lconstr env) (pr_constr env) in
-let pr_ex_bindings env = pr_bindings_gen true (pr_lconstr env) (pr_constr env) in
-let pr_with_bindings env = pr_with_bindings (pr_lconstr env) (pr_constr env) in
-let pr_eliminator env cb = str "using" ++ pr_arg (pr_with_bindings env) cb in
-let pr_constrarg env c = spc () ++ pr_constr env c in
-let pr_lconstrarg env c = spc () ++ pr_lconstr env c in
-
-let pr_intarg n = spc () ++ int n in
-
-let pr_binder_fix env (nal,t) =
-(*  match t with
-  | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
-  | _ ->*)
-    let s =
-      prlist_with_sep spc (pr_lname) nal ++ str ":" ++
-      pr_lconstr env t in
-    spc() ++ hov 1 (str"(" ++ s ++ str")") in
-
-let pr_fix_tac env (id,n,c) =
-  let rec set_nth_name avoid n = function
-      (nal,ty)::bll ->
-        if n <= List.length nal then
-          match list_chop (n-1) nal with
-              _, (_,Name id) :: _ -> id, (nal,ty)::bll
-            | bef, (loc,Anonymous) :: aft ->
-                let id = next_ident_away_from (id_of_string"y") avoid in
-                id, ((bef@(loc,Name id)::aft, ty)::bll)
-            | _ -> assert false
-        else
-          let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
-          (id,(nal,ty)::bll')
-    | [] -> assert false in
-  let (bll,ty) = strip_prod_binders n c in
-  let names =
-    List.fold_left
-      (fun ln (nal,_) -> List.fold_left
-          (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
-          ln nal)
-      [] bll in
-  let idarg,bll = set_nth_name names n bll in
-  let annot =
-    if List.length names = 1 then mt()
-    else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in
-  hov 1 (str"(" ++ pr_id id ++ 
-        prlist (pr_binder_fix env) bll ++ annot ++ str" :" ++
-        pr_lconstrarg env ty ++ str")") in
-(*  spc() ++
-  hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg
-    env c)
-*)
-let pr_cofix_tac env (id,c) =
-  hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg env c ++ str")") in
-
-
-  (* Printing tactics as arguments *)
-let rec pr_atom0 env = function
-  | TacIntroPattern [] -> str "intros"
-  | TacIntroMove (None,None) -> str "intro"
-  | TacAssumption -> str "assumption"
-  | TacAnyConstructor None -> str "constructor"
-  | TacTrivial (Some []) -> str "trivial"
-  | TacAuto (None,Some []) -> str "auto"
-(*  | TacAutoTDB None -> str "autotdb"
-  | TacDestructConcl -> str "dconcl"*)
-  | TacReflexivity -> str "reflexivity"
-  | t -> str "(" ++ pr_atom1 env t ++ str ")"
-
-  (* Main tactic printer *)
-and pr_atom1 env = function
-  | TacAutoTDB _ | TacDestructHyp _ | TacDestructConcl
-  | TacSuperAuto _ | TacExtend (_,
-    ("GTauto"|"GIntuition"|"TSimplif"|
-     "LinearIntuition"),_) ->
-      errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0")
-  | TacExtend (loc,s,l) ->
-      pr_with_comments loc
-        (pr_extend (pr_constr env) (pr_lconstr env) (pr_tac env) s l)
-  | TacAlias (loc,s,l,_) ->
-      pr_with_comments loc
-        (pr_extend (pr_constr env) (pr_lconstr env) (pr_tac env) s
-          (List.map snd l))
-
-  (* Basic tactics *)
-  | TacIntroPattern [] as t -> pr_atom0 env t
-  | TacIntroPattern (_::_ as p) -> 
-      hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p)
-  | TacIntrosUntil h ->
-      hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h)
-  | TacIntroMove (None,None) as t -> pr_atom0 env t
-  | TacIntroMove (Some id1,None) -> str "intro " ++ pr_id id1
-  | TacIntroMove (ido1,Some id2) ->
-      hov 1
-      (str "intro" ++ pr_opt pr_id ido1 ++ spc () ++ str "after " ++
-       pr_lident id2)
-  | TacAssumption as t -> pr_atom0 env t
-  | TacExact c -> hov 1 (str "exact" ++ pr_constrarg env c)
-  | TacApply cb -> hov 1 (str "apply" ++ spc () ++ pr_with_bindings env cb)
-  | TacElim (cb,cbo) ->
-      hov 1 (str "elim" ++ pr_arg (pr_with_bindings env) cb ++ 
-        pr_opt (pr_eliminator env) cbo)
-  | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg env c)
-  | TacCase cb -> hov 1 (str "case" ++ spc () ++ pr_with_bindings env cb)
-  | TacCaseType c -> hov 1 (str "casetype" ++ pr_constrarg env c)
-  | TacFix (ido,n) -> hov 1 (str "fix" ++ pr_opt pr_id ido ++ pr_intarg n)
-  | TacMutualFix (id,n,l) ->
-      hov 1 (str "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++
-             str"with " ++ prlist_with_sep spc (pr_fix_tac env) l)
-  | TacCofix ido -> hov 1 (str "cofix" ++ pr_opt pr_id ido)
-  | TacMutualCofix (id,l) ->
-      hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++
-             str"with " ++ prlist_with_sep spc (pr_cofix_tac env) l)
-  | TacCut c -> hov 1 (str "cut" ++ pr_constrarg env c)
-  | TacTrueCut (Anonymous,c) -> 
-      hov 1 (str "assert" ++ pr_constrarg env c)
-  | TacTrueCut (Name id,c) -> 
-      hov 1 (str "assert" ++ spc () ++
-             hov 1 (str"(" ++ pr_id id ++ str " :" ++
-                    pr_lconstrarg env c ++ str")"))
-  | TacForward (false,na,c) ->
-      hov 1 (str "assert" ++ spc () ++
-             hov 1 (str"(" ++ pr_name na ++ str " :=" ++
-                    pr_lconstrarg env c ++ str")"))
-  | TacForward (true,Anonymous,c) ->
-      if Options.do_translate () then
-        (* Pose was buggy and was wrongly substituted in conclusion in v7 *)
-        hov 1 (str "set" ++ pr_constrarg env c)
-      else
-        hov 1 (str "pose" ++ pr_constrarg env c)
-  | TacForward (true,Name id,c) ->
-      if Options.do_translate () then
-      hov 1 (str "set" ++ spc() ++
-             hov 1 (str"(" ++ pr_id id ++ str " :=" ++
-                    pr_lconstrarg env c ++ str")"))
-      else
-      hov 1 (str "pose" ++ spc() ++
-             hov 1 (str"(" ++ pr_id id ++ str " :=" ++
-                    pr_lconstrarg env c ++ str")"))
-  | TacGeneralize l ->
-      hov 1 (str "generalize" ++ spc () ++
-             prlist_with_sep spc (pr_constr env) l)
-  | TacGeneralizeDep c ->
-      hov 1 (str "generalize" ++ spc () ++ str "dependent" ++
-             pr_constrarg env c)
-  | TacLetTac (Anonymous,c,cl) ->
-      hov 1 (str "set" ++ pr_constrarg env c) ++ pr_clauses pr_ident cl
-  | TacLetTac (Name id,c,cl) ->
-      hov 1 (str "set" ++ spc () ++
-             hov 1 (str"(" ++ pr_id id ++ str " :=" ++
-                    pr_lconstrarg env c ++ str")") ++
-             pr_clauses pr_ident cl)
-  | TacInstantiate (n,c,cls) ->
-      hov 1 (str "instantiate" ++ spc() ++
-             hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
-                    pr_lconstrarg env c ++ str ")" ++ 
-		    pr_clauses pr_ident cls))
-  (* Derived basic tactics *)
-  | TacSimpleInduction (h,l) ->
-      if List.exists (fun (pp,_) -> !pp) !l then
-        duplicate true true None (fun pnames -> 
-          hov 1 (str "induction" ++ pr_arg pr_quantified_hypothesis h ++
-          pnames)) !l
-      else
-      hov 1 (str "simple induction" ++ pr_arg pr_quantified_hypothesis h)
-  | TacNewInduction (h,e,(ids,l)) ->
-      duplicate false true ids (fun pnames ->
-      hov 1 (str "induction" ++ spc () ++
-             pr_induction_arg (pr_constr env) h ++ pnames ++
-             pr_opt (pr_eliminator env) e)) !l
-  | TacSimpleDestruct h ->
-      hov 1 (str "simple destruct" ++ pr_arg pr_quantified_hypothesis h)
-  | TacNewDestruct (h,e,(ids,l)) ->
-      duplicate false true ids (fun pnames ->
-      hov 1 (str "destruct" ++ spc () ++
-             pr_induction_arg (pr_constr env) h ++ pnames ++
-             pr_opt (pr_eliminator env) e)) !l
-  | TacDoubleInduction (h1,h2) ->
-      hov 1
-        (str "double induction" ++  
-         pr_arg pr_quantified_hypothesis h1 ++
- 	 pr_arg pr_quantified_hypothesis h2)
-  | TacDecomposeAnd c ->
-      hov 1 (str "decompose record" ++ pr_constrarg env c)
-  | TacDecomposeOr c ->
-      hov 1 (str "decompose sum" ++ pr_constrarg env c)
-  | TacDecompose (l,c) ->
-      let vars = Termops.vars_of_env env in
-      hov 1 (str "decompose" ++ spc () ++
-        hov 0 (str "[" ++ prlist_with_sep spc (pr_ind vars) l
-	  ++ str "]" ++ pr_constrarg env c))
-  | TacSpecialize (n,c) ->
-      hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ pr_with_bindings env c)
-  | TacLApply c -> 
-      hov 1 (str "lapply" ++ pr_constrarg env c)
-
-  (* Automation tactics *)
-  | TacTrivial (Some []) as x -> pr_atom0 env x
-  | TacTrivial db -> hov 0 (str "trivial" ++ pr_hintbases db)
-  | TacAuto (None,Some []) as x -> pr_atom0 env x
-  | TacAuto (n,db) ->
-      hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ pr_hintbases db)
-(*  | TacAutoTDB None as x -> pr_atom0 env x
-  | TacAutoTDB (Some n) -> hov 0 (str "autotdb" ++ spc () ++ int n)
-  | TacDestructHyp (true,id) ->
-      hov 0 (str "cdhyp" ++ spc () ++ pr_lident id)
-  | TacDestructHyp (false,id) ->
-      hov 0 (str "dhyp" ++ spc () ++ pr_lident id)
-  | TacDestructConcl as x -> pr_atom0 env x
-  | TacSuperAuto (n,l,b1,b2) ->
-      hov 1 (str "superauto" ++ pr_opt int n ++ pr_autoarg_adding l ++ 
-             pr_autoarg_destructing b1 ++ pr_autoarg_usingTDB b2)*)
-  | TacDAuto (n,p) ->
-      hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ 
-      pr_opt int p)
-
-  (* Context management *)
-  | TacClear l ->
-      hov 1 (str "clear" ++ spc () ++ prlist_with_sep spc pr_ident l)
-  | TacClearBody l ->
-      hov 1 (str "clearbody" ++ spc () ++ prlist_with_sep spc pr_ident l)
-  | TacMove (b,id1,id2) ->
-      (* Rem: only b = true is available for users *)
-      assert b;
-      hov 1
-        (str "move" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ 
-	 str "after" ++ brk (1,1) ++ pr_ident id2)
-  | TacRename (id1,id2) ->
-      hov 1
-        (str "rename" ++ brk (1,1) ++ pr_ident id1 ++ spc () ++ 
-	 str "into" ++ brk (1,1) ++ pr_ident id2)
-
-  (* Constructors *)
-  | TacLeft l -> hov 1 (str "left" ++ pr_bindings env l)
-  | TacRight l -> hov 1 (str "right" ++ pr_bindings env l)
-  | TacSplit (false,l) -> hov 1 (str "split" ++ pr_bindings env l)
-  | TacSplit (true,l) -> hov 1 (str "exists" ++ pr_ex_bindings env l)
-  | TacAnyConstructor (Some t) ->
-      hov 1 (str "constructor" ++ pr_arg (pr_tac0 env) t)
-  | TacAnyConstructor None as t -> pr_atom0 env t
-  | TacConstructor (n,l) ->
-      hov 1 (str "constructor" ++ pr_or_metaid pr_intarg n ++
-             pr_bindings env l)
-
-  (* Conversion *)  
-  | TacReduce (r,h) ->
-      hov 1 (pr_red_expr (pr_constr env,pr_lconstr env,pr_cst env) r ++
-             pr_clauses pr_ident h)
-  | TacChange (occ,c,h) ->
-      hov 1 (str "change" ++ brk (1,1) ++
-      (match occ with
-          None -> mt()
-        | Some([],c1) ->
-            hov 1 (pr_constr env c1 ++ spc() ++ str "with ")
-        | Some(ocl,c1) ->
-            hov 1 (pr_constr env c1 ++ spc() ++
-	           str "at " ++ prlist_with_sep spc int ocl) ++ spc() ++
-	           str "with ") ++
-      pr_constr env c ++ pr_clauses pr_ident h)
-
-  (* Equivalence relations *)
-  | TacReflexivity as x -> pr_atom0 env x
-  | TacSymmetry cls -> str "symmetry " ++ pr_clauses pr_ident cls
-  | TacTransitivity c -> str "transitivity" ++ pr_constrarg env c
-
-  (* Equality and inversion *)
-  | TacInversion (DepInversion (k,c,ids),hyp) ->
-      hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++
-      pr_quantified_hypothesis hyp ++
-      pr_with_names ids ++ pr_with_constr (pr_constr env) c)
-  | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
-      hov 1 (pr_induction_kind k ++ spc () ++
-      pr_quantified_hypothesis hyp ++
-      pr_with_names ids ++ pr_simple_clause pr_ident cl)
-  | TacInversion (InversionUsing (c,cl),hyp) ->
-      hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ 
-      spc () ++ str "using" ++ spc () ++ pr_constr env c ++ 
-      pr_simple_clause pr_ident cl)
-
-in
-
-let ltop = (5,E) in
-let lseq = 5 in
-let ltactical = 3 in
-let lorelse = 2 in
-let llet = 1 in
-let lfun = 1 in
-let labstract = 3 in
-let lmatch = 1 in
-let latom = 0 in
-let lcall = 1 in
-let leval = 1 in
-let ltatom = 1 in
-
-let rec pr_tac env inherited tac =
-  let (strm,prec) = match tac with
-  | TacAbstract (t,None) ->
-      str "abstract " ++ pr_tac env (labstract,L) t, labstract
-  | TacAbstract (t,Some s) -> 
-      hov 0
-       (str "abstract (" ++ pr_tac env (labstract,L) t ++ str")" ++ spc () ++
-        str "using " ++ pr_id s),
-      labstract
-  | TacLetRecIn (l,t) -> 
-      hv 0
-        (str "let rec " ++ pr_rec_clauses (pr_tac env ltop) l ++ str " in" ++
-         fnl () ++ pr_tac env (llet,E) t),
-      llet
-  | TacLetIn (llc,u) ->
-      v 0
-       (hv 0 (pr_let_clauses (pr_tac env ltop) llc
-       ++ str " in") ++
-       fnl () ++ pr_tac env (llet,E) u),
-      llet
-  | TacMatch (t,lrul) ->
-      hov 0 (str "match " ++ pr_tac env ltop t ++ str " with"
-        ++ prlist
-	  (fun r -> fnl () ++ str "| " ++
-            pr_match_rule true (pr_tac env ltop) pr_pat r)
-	lrul
-        ++ fnl() ++ str "end"),
-      lmatch
-  | TacMatchContext (lr,lrul) ->
-      hov 0 (
-	str (if lr then "match reverse goal with" else "match goal with")
-	++ prlist
-	  (fun r -> fnl () ++ str "| " ++
-            pr_match_rule false (pr_tac env ltop) pr_pat r)
-	lrul
-        ++ fnl() ++ str "end"),
-      lmatch
-  | TacFun (lvar,body) ->
-      hov 2 (str "fun" ++
-        prlist pr_funvar lvar ++ str " =>" ++ spc () ++
-        pr_tac env (lfun,E) body),
-      lfun
-  | TacThens (t,tl) -> 
-      hov 1 (pr_tac env (lseq,E) t ++ pr_then () ++ spc () ++
-             pr_seq_body (pr_tac env ltop) tl),
-      lseq
-  | TacThen (t1,t2) ->
-      let pp2 =
-        (* Hook for translation names in induction/destruct *)
-        match t2 with
-          | TacAtom (_,TacSimpleInduction (h,l)) ->
-              if List.exists (fun (pp,ids) -> !pp) !l then
-                duplicate true false None (fun pnames ->
-                  hov 1 
-                  (str "induction" ++ pr_arg pr_quantified_hypothesis h ++
-                  pnames)) !l
-              else
-                hov 1
-                  (str "simple induction" ++ pr_arg pr_quantified_hypothesis h)
-          | TacAtom (_,TacNewInduction (h,e,(ids,l))) ->
-              duplicate false false ids (fun pnames -> 
-                hov 1 (str "induction" ++ spc () ++
-                pr_induction_arg (pr_constr env) h ++ pnames ++
-                pr_opt (pr_eliminator env) e)) !l
-          | TacAtom (_,TacNewDestruct (h,e,(ids,l))) ->
-              duplicate false false ids (fun pnames ->
-                hov 1 (str "destruct" ++ spc () ++
-                pr_induction_arg (pr_constr env) h ++ pnames ++
-                pr_opt (pr_eliminator env) e)) !l
-              (* end hook *)
-          | _ -> pr_tac env (lseq,L) t2 in
-      hov 1 (pr_tac env (lseq,E) t1 ++ pr_then () ++ spc () ++ pp2),
-      lseq
-  | TacTry t ->
-      hov 1 (str "try" ++ spc () ++ pr_tac env (ltactical,E) t),
-      ltactical
-  | TacDo (n,t) ->
-      hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ pr_tac env (ltactical,E) t),
-      ltactical
-  | TacRepeat t ->
-      hov 1 (str "repeat" ++ spc () ++ pr_tac env (ltactical,E) t),
-      ltactical
-  | TacProgress t ->
-      hov 1 (str "progress" ++ spc () ++ pr_tac env (ltactical,E) t),
-      ltactical
-  | TacInfo t ->
-      hov 1 (str "info" ++ spc () ++ pr_tac env (ltactical,E) t),
-      ltactical
-  | TacOrelse (t1,t2) ->
-      hov 1 (pr_tac env (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++
-             pr_tac env (lorelse,E) t2),
-      lorelse
-  | TacFail (ArgArg 0,"") -> str "fail", latom
-  | TacFail (n,s) -> 
-      str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++
-      (if s="" then mt() else qsnew s), latom
-  | TacFirst tl ->
-      str "first" ++ spc () ++ pr_seq_body (pr_tac env ltop) tl, llet
-  | TacSolve tl ->
-      str "solve" ++ spc () ++ pr_seq_body (pr_tac env ltop) tl, llet
-  | TacId "" -> str "idtac", latom
-  | TacId s -> str "idtac" ++ (qsnew s), latom
-  | TacAtom (loc,t) ->
-      pr_with_comments loc (hov 1 (pr_atom1 env t)), ltatom
-  | TacArg(Tacexp e) -> pr_tac0 env e, latom
-  | TacArg(ConstrMayEval (ConstrTerm c)) ->
-      str "constr:" ++ pr_constr env c, latom
-  | TacArg(ConstrMayEval c) ->
-      pr_may_eval (pr_constr env) (pr_lconstr env) (pr_cst env) c, leval
-  | TacArg(TacFreshId sopt) -> str "fresh" ++ pr_opt qsnew sopt, latom
-  | TacArg(Integer n) -> int n, latom
-  | TacArg(TacCall(loc,f,l)) ->
-      pr_with_comments loc
-        (hov 1 (pr_ref f ++ spc () ++
-         prlist_with_sep spc (pr_tacarg env) l)),
-      lcall
-  | TacArg a -> pr_tacarg env a, latom
-  in
-  if prec_less prec inherited then strm
-  else str"(" ++ strm ++ str")"
-
-and pr_tacarg env = function
-  | TacDynamic (loc,t) ->
-      pr_with_comments loc (str ("<dynamic ["^(Dyn.tag t)^"]>"))
-  | MetaIdArg (loc,s) -> pr_with_comments loc (str ("$" ^ s))
-  | IntroPattern ipat -> str "ipattern:" ++ pr_intro_pattern ipat
-  | TacVoid -> str "()"
-  | Reference r -> pr_ref r
-  | ConstrMayEval c ->
-      pr_may_eval (pr_constr env) (pr_lconstr env) (pr_cst env) c
-  | TacFreshId sopt -> str "fresh" ++ pr_opt qsnew sopt
-  | (TacCall _|Tacexp _|Integer _) as a ->
-      str "ltac:" ++ pr_tac env (latom,E) (TacArg a)
-
-in ((fun env -> pr_tac env ltop),
-    (fun env -> pr_tac env (latom,E)),
-    pr_match_rule)
-
-let pi1 (a,_,_) = a
-let pi2 (_,a,_) = a
-let pi3 (_,_,a) = a
-
-let strip_prod_binders_rawterm n (ty,_) =
-  let rec strip_ty acc n ty =
-    if n=0 then (List.rev acc, (ty,None)) else
-      match ty with
-          Rawterm.RProd(loc,na,a,b) ->
-            strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b
-        | _ -> error "Cannot translate fix tactic: not enough products" in
-  strip_ty [] n ty
-
-let strip_prod_binders_constr n ty =
-  let rec strip_ty acc n ty =
-    if n=0 then (List.rev acc, ty) else
-      match Term.kind_of_term ty with
-          Term.Prod(na,a,b) ->
-            strip_ty (([dummy_loc,na],a)::acc) (n-1) b
-        | _ -> error "Cannot translate fix tactic: not enough products" in
-  strip_ty [] n ty
-
-
-let rec raw_printers =
-    (pr_raw_tactic, 
-     pr_raw_tactic0,
-     Ppconstrnew.pr_constr_env,
-     Ppconstrnew.pr_lconstr_env,
-     Ppconstrnew.pr_pattern,
-     (fun _ -> pr_reference),
-     (fun _ -> pr_reference),
-     pr_reference,
-     pr_or_metaid pr_lident,
-     Pptactic.pr_raw_extend,
-     strip_prod_binders_expr)
-
-and pr_raw_tactic env (t:raw_tactic_expr) =
-  pi1 (make_pr_tac raw_printers) env t
-
-and pr_raw_tactic0 env t =
-  pi2 (make_pr_tac raw_printers) env t
-
-and pr_raw_match_rule env t =
-  pi3 (make_pr_tac raw_printers) env t
-
-let pr_and_constr_expr pr (c,_) = pr c
-
-
-let rec glob_printers =
-    (pr_glob_tactic, 
-     pr_glob_tactic0,
-     (fun env -> pr_and_constr_expr (Ppconstrnew.pr_rawconstr_env_no_translate env)),
-     (fun env -> pr_and_constr_expr (Ppconstrnew.pr_lrawconstr_env_no_translate env)),
-     (fun c -> Ppconstrnew.pr_constr_pattern_env (Global.env()) c),
-     (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))),
-     (fun vars -> pr_or_var (pr_inductive vars)),
-     pr_ltac_or_var (pr_located pr_ltac_constant),
-     pr_lident,
-     Pptactic.pr_glob_extend,
-     strip_prod_binders_rawterm)
-
-and pr_glob_tactic env (t:glob_tactic_expr) =
-  pi1 (make_pr_tac glob_printers) env t
-
-and pr_glob_tactic0 env t =
-  pi2 (make_pr_tac glob_printers) env t
-
-and pr_glob_match_rule env t =
-  pi3 (make_pr_tac glob_printers) env t
-
-let (pr_tactic,_,_) =
-  make_pr_tac
-    (pr_glob_tactic,
-     pr_glob_tactic0,
-     pr_term_env,
-     pr_lterm_env,
-     Ppconstrnew.pr_constr_pattern,
-     pr_evaluable_reference_env,
-     pr_inductive,
-     pr_ltac_constant,
-     pr_id,
-     Pptactic.pr_extend,
-     strip_prod_binders_constr)
-